;<MENDERIN>O1.MAC.35, 20-Jan-77 12:00:51, Edit by ENDERIN
;<TENDERIN>O1.MAC.6, 16-Jan-77 23:57:17, Edit by ENDERIN
;<TENDERIN>O1.MAC.1, 16-Jan-77 14:09:41, Edit by ENDERIN

Comment;

Author:		Claes Wihlborg (modified by L Enderin)
Version:	4 [1,03,13,16,17,45,144,162,225,250,306]
Purpose:	Pass 1 I/O
Contents:
		O1DB	Write debug information
		O1DF	Write declaration file
		O1EX	Read external attributes
		O1IC	Write intermediate code
		O1LS	Write source code
		O1RL	Write rel-file
		O1SC	Read source code
		O1XR	Write cross-reference file
		O1ZS	Write symbol table
		O1ERR	Error routine
		O1PACK	Pack files kept in core
		O1SETB	Set up buffer ring
;

	SALL
	SEARCH	SIMMC1,SIMMAC
	CTITLE	O1 Pass 1 IO
	SUBTTL	PROLOGUE


	MACINIT
	QHBYTE==(POINT 18)
	QWBYTE==(POINT 36)
	QOPEN==0
	QLOOKUP==1
	QENTER==2
	QREAD==3
	QWRITE==4
	QCLOSE==5
	EXTERN	T1AB,I1AB
	EXTERN	YJOB,YSWITCH
	EXTERN	YMAXID,ZSE1,ZSE2
	EXTERN	Y3OPEN
	EXTERN	YBRBUF,YBRSRC,YBRZSE
	EXTERN	Y1BUF,Y4BUF,Y6BUF,Y13BUF,Y15BUF,Y11BUF
	EXTERN	YDPD,YDPUNR
			edit(3)
	EXTERN	YRELBL	;[03] Number of last REL file block filled
			edit(13)
	EXTERN	YRQHEAD	;[13] Head of ZRQ chain
	EXTERN	YRQFIL,YRQPPN,YRQDEV	;[13] Request block info from file def
	EXTERN	YEXNAM	;[13] SIMULA name in SIXBIT of external class/proc
			edit(43) edit(144) edit(225)
	EXTERN	YEXTS		;[144] Lookup table
	EXTERN	YELIN1,YELIN2	;[45]
	EXTERN	YZQUGLO		;[144] Copy of global ZQU and ZHB
	EXTERN	YO1ASB		;[306] Where last ASCIZ word is
	EXTERN	YO1ASC		;[306] What it was before adjustment
TOPS10,<EXTERN YSFD,YSFDPPN,YSFD1,YSFDN ;[144,225]>
TOPS20,<;[225]
	EXTERN	YATRJF,YATRSZ
	EXTERN	YEXTAD,YEXTJF,YEXTLI,YEXTLX,YEXTMP,YEXTSZ,YEXTDV
	EXTERN	YFILSP
>
	EXTERN	YLSLLS	;[144]


	TWOSEG
	RELOC	400000

	;;; [144] ;;;

	OPDEF	XEC		[PUSHJ	XPDP,]
	OPDEF	setupbuffers	[XEC	O1SETB]
	OPDEF	zquremove	[XEC	DPEXRM]
	OPDEF	readmodule	[XEC	O1EXRM]
TOPS10,<;[225]
	OPDEF	exbuffers	[XEC	O1EXBU]
>
	OPDEF	sfdcopy		[XEC	O1SFDC]

	XZRQ==X2
	XNAME==X5
	XZQU==X4

	EXTERN	DPEXT,DPEXRM	;[144]

	EXTERN	YEXZQU,YATRDEV,YATRFN,YATRPPN,YATROFS ;[144]

	YEXBLK==YDPD	;Block no in ATR file
	YEXZRQ=:YDPD+1	;Start of ZRQ chain (ATR/REL file specs)
	YEXSINGLE==YDPD+2	;Parameter to findmodules
TOPS10,<;[225]
	YEXBF1==YDPD+10 ;Address of 1st ATR file buffer.
	YEXBF2==YEXBF1+204	;Next ATR file buffer. Space for one more assumed
>

 DF ZQUR50,3+OFFSET(ZHBUNR),36,35	;Name of entry in RADIX50

IF1,<;[225]
QDIRTR==QDEC20	;[305]
IFNDEF QDIRTR,<
QDIRTR==0	; Non-zero if STR:<DIRECTORY> should be translated
IFDEF	RCDIR,<TOPS20,<QDIRTR==1>>
>>
	DEFINE ERROR(FIL,ACTION)<
	;	IFG QDEBUG,<
	;		OUTSTR	[ASCIZ/ACTION ERROR FILE FIL
	;/]>
		IFN QERIMP,<
			IFIDN	<ACTION><OPEN>,<L X1,[ASCII/FIL/]>;;[144]
			IFDIF	<ACTION><OPEN>,<LI X1,YEL'FIL> ;;[144]
			ERRT	QT,Q.TER+Q'ACTION
		>
		BRANCH	T1AB
	>

	DEFINE	OUTSF(FILE,NBUF,STARTADD)<
		LI	X2,NBUF
		LI	X3,STARTADD
		LI	X1,200
		LOOP
			OUT	QCH'FILE,
			SKIPA
			 JSP	[ERROR(FILE,WRITE)]
			L	YBH'FILE+1
			ADDI	1
			HRL	X3
			ADDI	X3,200
			ADDM	X1,YBH'FILE+1
			BLT	@YBH'FILE+1
		AS
			SOJG	X2,TRUE
		SA
	>
	SUBTTL	O1DB  WRITE DEBUG INFORMATION

IFG QDEBUG,<

	INTERN	O1DBOP,O1DB6

	EXTERN	YELDEB,YBHDEB

	PROC


O1DBOP:

;SET UP ENTER BLOCK
	LI	X0,'DEB'
	HLL	X0,YJOB
	ST	X0,YELDEB
	MOVSI	X0,'TMP'
	ST	X0,YELDEB+1
	SETZM	YELDEB+2
	SETZM	YELDEB+3
;ENTER
	IF	ENTER	QCHDEB,YELDEB
		GOTO	FALSE
	THEN
					edit(162)
		SETZM	YELDEB+3	;[162]
		SETON	YOPDEB
		LI	QHBYTE
		HRLM	YBHDEB+1
		OUT	QCHDEB,
		 RET
	FI
	ERROR	DEB,ENTER


;OUTPUT X0 RIGHT HALFWORD

L1():!
	IF	OUT	QCHDEB,
		GOTO	FALSE
	THEN
		ERROR	DEB,WRITE
	FI
L2():!
	SOSGE	YBHDEB+2
	 GOTO	L1
	IDPB	X0,YBHDEB+1
	RET





O1DB6:
	STACK	X0
	HLR	X0,-4(XPDP)
	EXEC	L2
	HRR	X0,-4(XPDP)
	EXEC	L2
	HLR	X0,-3(XPDP)
	EXEC	L2
	HRR	X0,-3(XPDP)
	EXEC	L2
	HLR	X0,-2(XPDP)
	EXEC	L2
	HRR	X0,-2(XPDP)
	EXEC	L2
	UNSTK	X0
	RETURN

	EPROC
>;END OF DEBUG
	SUBTTL	O1DF  Write declaration file

	INTERN	O1DFOP,O1DF1,O1DFCL

	EXTERN	YELDF1,YBHDF1
	EXTERN	YO1DFC

;
; SET UP CORE FILE
;

O1DFOP:	PROC

;COMPUTE MAXIMAL SIZE
	L	X1,YBRZSE	;Break of files kept in core so far
	LI	X2,Y13BUF
	SKIPN	YELIC1
	 LI	X2,Y15BUF	;If IC1 in core, take two more buffers
	SUB	X2,X1
	TRZ	X2,177		;Truncate to multiple of buffer size
	HRLI	X1,444400
	STD	X1,YBHDF1+1
	SETZM	YELDF1
	ST	X2,YO1DFC	;Save size
	RETURN
	EPROC	;O1DFOP


;
;Core file too small, write file on disk
;

O1OPDF:	PROC

	SAVE	<X0,X1,X2,X3>
	OPEN	QCHDF1,[14
			SIXBIT/DSK/
			XWD YBHDF1,YBHDF1]
	 JSP	[ERROR(DF1,OPEN)]

;Set up ENTER block
	LI	X0,'DF1'
	HLL	X0,YJOB
	MOVSI	X1,'TMP'
	STD	X0,YELDF1
	SETZM	YELDF1+2
	SETZM	YELDF1+3
;ENTER
	ENTER	QCHDF1,YELDF1
	 JSP	[ERROR(DF1,ENTER)]
				edit(162)
	SETZM	YELDF1+3	;[162]
	SETON	YOPDF1

;SET UP BUFFERS
	L	[XWD 2,Y15BUF]
	ST	YBRBUF
	EXEC	O1SETB
	ST	X0,YBHDF1
;OUTPUT STORED FILE
	L	X1,YO1DFC	;Size of core file
	ASH	X1,-7		;Transform to no of buffers
	OUTSF(DF1,<(X1)>,@YBRZSE)
	RETURN
	EPROC	;O1OPDF


;
;Output buffer to DF1
;


O1DF1:	PROC
	SKIPN	YELDF1
	 XEC	O1OPDF	;First call
	OUT	QCHDF1,
	SOSGE	YBHDF1+2
	 JSP	[ERROR(DF1,WRITE)]
	RETURN
	EPROC	;O1DF1


;
;CLOSE DF1
;

O1DFCL:	PROC

	IF	;File in core
		SKIPE	YELDF1
		GOTO	FALSE
	THEN	;Set up buffer header for use when reading
		L	X1,YBRZSE
		L	X2,YO1DFC
		SUBB	X2,YBHDF1+2
		ADD	X2,X1
		ST	X2,YBRZSE	;Set new break for files kept in core
		HRLI	X1,444400
		ST	X1,YBHDF1+1
		RETURN
	FI

	CLOSE	QCHDF1,
	IF	STATZ	QCHDF1,740000
		GOTO	FALSE
	THEN
		SETON	YPODF1
		RETURN
	FI
	ERROR	DF1,CLOSE
	EPROC	;O1DFCL
	SUBTTL	O1EX Read External attributes [13]


	INTERN	O1EXCL,O1EXT
	TOPS10,<INTERN O1EXBU>;[225]
	INTERN	O1EXFM,O1EXNP,O1EXRM,O1EXSO,O1EXLU,O1SFDC,O1EX.O ;[144]
	INTERN	O1EXTB	;[225]

	EXTERN	YELEXT,YBHEXT


	IO.SYN==1B30	;Stop after each buffer
	IO.BIN==14	;Binary mode

	XFILE==X0
	XPPN==X3
	;Loader block types
	QINDEX==14
	QENTRY==4
	QREQLIB==17

	OPDEF	SKIPBLOCK [PUSHJ XPDP,O1EXSK]

TOPS20,<;[225]
	FCP==OFFSET(ZLFFCP)
	FFP==OFFSET(ZLFFFP)
	NPA==OFFSET(ZLFNPA)
	QLM==ZLF%S
>
	SUBTTL	exbuffers	[144]
TOPS10,<;[225]

Comment;
Set up standard buffer(s) starting with YEXBF2.
Initialize YBHEXT etc.
;

O1EXBU:	PROC
	L	[2,,YEXBF2]	;2 buffers, starting at YEXBF2
	ST	YBRBUF
	setupbuffers
	ST	YBHEXT
	LI	1
	ST	YEXBLK		;1st blk no
	SETZM	YBHEXT+2	;Clear byte count
	RETURN
	EPROC
>;[225]
	SUBTTL	findmodules (O1EXFM)	[144]

Comment;
An ATR (library) file is open on channel QCHEXT (DEC-10 only).
1) If XZRQ  =  0  on  entry,  it  is  required  to  find  the  module
corresponding  to  ZQU(XZQU),  otherwise  all  modules  on  the  list
starting at YEXZQU<RH> are to be found, if possible.
  Handle each index block separately. Check each ZQU (ZQUR50 field)
against entries in the index block, in order.
3)  When  a module is found, read it and update declaration structure
(DPEXT).
4) Return when all index blocks are exhausted or all ZQU's handled.
;


O1EXFM:	PROC
	SAVE	<X1,X3,XNAME>
	ST	XZRQ,YEXSINGLE

TOPS10,<;[225]
	exbuffers
	;Allocate YEXBF1 for index blocks only
	LD	X0,[201,,YEXBF2+1
		400K,,YEXBF1+1]
	ST	X0,YEXBF1+1
	ST	X1,YBHEXT
	>

	IF	;Library not on search list
		JUMPN	XZRQ,FALSE
	THEN	;Find ZRQ block for library
		EXEC	O1EXRQ
	FI
	HRRZM	XZRQ,YEXZRQ

	LI	X3,1	;[225] First index block
L1():!	;Loop over index blocks
	EXEC	O1EXFW	;[225] Locate index block word by X1
	HLRZ	(X1)
	IF	;NOT INDEX block
		CAIN	QINDEX
		GOTO	FALSE
	THEN	;Error unless in single module mode
		IF	SKIPG YEXSINGLE
			GOTO	FALSE
		THEN	;Not proper library format
			EXEC	O1EXCL
			L	YLSLLS
			ST	YELIN1
			ST	YELIN2
			LI	X1,YELEXT
			ERRT	QT,255
			GOTO	T1AB
		FI
		zquremove
		GOTO	L9
	FI

	SKIPG YEXSINGLE
	HRROS	YEXSINGLE	;Shows that file is a library
	LI	X1,1(X1)
L2():!	L	X3,(X1)	;Module header word
	SUB	X3,[QENTRY,,1]
	IF	;Normal case (one entry per module)
		JUMPN	X3,FALSE
	THEN	;Check the entry against all ZQU's
		L	XNAME,1(X1)
		IF	;Single module sought
			SKIPLE YEXSINGLE
			GOTO	FALSE
		THEN	;Just one comparison per entry in index block
			CAME	XNAME,OFFSET(ZQUR50)(XZQU)
			GOTO	L3
			readmodule
			GOTO	L9
		FI
		HRRZS	XZQU,YEXZQU
		JUMPE	XZQU,L9
		LOOP
			IF	;found
				CAME	XNAME,OFFSET(ZQUR50)(XZQU)
				GOTO	FALSE
			THEN	LF	X3,ZQUIND(XZQU)
				readmodule
				L	XZQU,X3
			ELSE
				HRLM	XZQU,YEXZQU	;Remember prev. ZQU
				LF	XZQU,ZQUIND(XZQU)
			FI
		AS
			JUMPN	XZQU,TRUE
		SA
L3():!		LI	X1,3(X1)	;Next
		GOTO	L2
	FI
	L	X3,(X1)
	AOJE	X3,L9		;Exhausted
	LI	X3,-1(X3)
	GOTO	L1	;Next index block
L9():!	IF	;Something was found in this library
		SKIPL	XZRQ,YEXZRQ
		GOTO	FALSE
	THEN	;Note it for output
		MOVSI	(1B<%ZRQOUT>)
		IORM	(XZRQ)
		IORM	YRQHEAD
		HRRZS	XZRQ,YEXZRQ
	ELSE	;Show that it was not found
		L	XZRQ,YEXSINGLE
	FI
	RETURN
	EPROC


	TOPS10,<;[225]
O1EXFW:	PROC
	CAIE	X3,1	;No USETI necessary for first block
	 USETI	QCHEXT,(X3)
	  NOP	;In case of JACCT
	SETZM	YBHEXT+2
	IN	QCHEXT,YEXBF1+1
	 SKIPG	YBHEXT+2
	  JSP	[ERROR(EXT,READ)]
	AOS	X1,YBHEXT+1	;Address of first word in buffer
	RETURN
	EPROC
>


	TOPS20,<;[225]
O1EXFW:	PROC	;Compute address of first word in index blk
	SUBI	X3,1
	LSH	X3,7	;We now have word offset in file
	SETZM	YEXTAD	;Zero denotes index blk allocation
	EXEC	O1EXMP	;Map several pages starting with the
			; page containing the word at offset (X3)
	RETURN	;With X1 pointing to the word in core
	EPROC
	>
	SUBTTL	O1EXMP, Map external ATR file to core

TOPS20,<;[225]

O1EXMP::PROC	;Make sure the page containing word (X3) of file is mapped
	SAVE	X4
	HRRZ	X1,X3
	LSH	X1,-9	;Page number in file
	IF	;Index area to be allocated
		SKIPE	YEXTAD
		GOTO	FALSE
	THEN	;Remap the whole area
		LI	X4,YEXTLX
		EXEC	O1EXMA	;Do the actual file mapping
		AOS	YEXTAD	;Restore to normal case
		L	[YEXTLX,,YEXTLI]
		BLT	YEXTLI+QLM-1	;Copy limit info
	ELSE	;Map data area, leaving index block alone
		LI	X4,YEXTLI
		EXEC	O1EXMA
	FI
	;Set up  "buffer header"
	L	NPA(X4)
	LSH	9
	ST	YBHEXT+2	;Word count
	L	X3
	ANDI	777
	MOVN
	ADDM	YBHEXT+2	;ADJUSTED
	LI	-1(X1)		;Point to preceding word
	HRLI	004400		;With no bit left
	ST	YBHEXT+1	;Byte pointer
	L	FCP(X4)
	LSH	9
	SUBI	2
	ST	YBHEXT
	RETURN
	EPROC
>;[225]
	SUBTTL	O1EXMA, map external file pages
TOPS20,<;[225]

O1EXMA:	PROC
	STACK	X3
	ST	X1,FFP(X4)	;First file page
	HLRZ	X2,YEXTMP	;First core page
	HRRZ	X3,YEXTMP	;Number of available pages
	L	YEXTSZ		;Need no more than whole rest of file
	SUBI	(X1)
	IF	;Rest of file is smaller than area
		CAML	X3
		GOTO	FALSE
	THEN	;Adjust map size
		ST	X3
	ELSE	;Adjust with any offset
		SUB	X3,YEXTAD
	FI
	ADD	X2,YEXTAD	;Adjust
	ST	X2,FCP(X4)	;Remember first page
	ST	X3,NPA(X4)
	HRL	X1,YEXTJF	;File handle
	HRLI	X2,.FHSLF	;Process handle
	HRLI	X3,(PM%CNT+PM%RD+PM%CPY) ;Copy on write if necessary
	PMAP
	LSH	X2,9		;Compute word address in core
	UNSTK	X3
	LI	X1,777		;Mask out all but offset within page
	AND	X1,X3
	ADDI	X1,(X2)		;X1 now points to the core word
	RETURN
	EPROC
>;[225]
	SUBTTL	O1EXNP, note position of global old ATR file

Comment;

When  a  ZQU  copy  for  a  global module currently being compiled is
found, it is processed like an external ZQU. O1EXNP takes note of its
file  spec:  <YRQDEV>:<YRQFIL>.ATR[<YRQPPN>], and the position of the
ATR module within the  file  (given  by  X0  as  [word  offset,,block
number],  zero  if not in a library). [225]: On the DEC-20, also save
JFN and file size. Pass 3 then uses the information to find  the  old
ATR information to compare it with the new info.
;

O1EXNP:	PROC
	ST	YATROFS	;[word offset,,block number]
	L	YRQDEV	;device
	ST	YATRDEV
	L	YRQFIL	;file name
	ST	YATRFN
	L	YRQPPN	;ppn
	CAMN	[-1]	;-1 stands for default path when explicit file
	 SETZ		; is required, i.e. when file name of ATR file
	ST	YATRPPN	; being produced differs from SIMULA name
	TOPS20,<;[225]
	L	YEXTJF
	ST	YATRJF
	L	YEXTSZ
	ST	YATRSZ
	>
	RETURN
	EPROC
	SUBTTL	readmodule	[144]

Comment;
Skip forward in the library file to the correct word.  X1  points  to
the  [QENTRY,,n]  word  of the index block. Call DPEXT to process the
attribute info.
;

O1EXRM:	PROC
	SAVE	<X1,X3>
	HRRZ	X3,(X1)
	ADDI	X1,1(X3)	;Addr of info
	L	(X1)	;[offset,,blk]
	WHILE	;offset >= blksize (FUDGE2 error??)
		JUMPL	L9
		CAMGE	[200,,0]
		GOTO	FALSE
	DO	;Modify
		ADD	[-200,,1]
	OD
	TOPS20,<CAME (X1) ;[225] Don't want to modify>
	ST	(X1)
	zquremove
	IF	;Global ZQU
		CAIE	XZQU,YZQUGLO
		GOTO	FALSE
	THEN	;Take note for PASS3
		L	(X1)
		EXEC	O1EXNP
		GOTO	L9	;No further processing now
	FI
	HRROS	YEXZRQ	;Mark this library as used
TOPS10,<;[225]
	IF	;Not current block
		HRRZ	(X1)
		CAMN	YEXBLK
		GOTO	FALSE
	THEN	;Position to correct block
		HRLI	(USETI	QCHEXT,)
		XCT
		 NOP
		SETZM	YBHEXT+2
		EXEC	O1EXT
		HRRM	YEXBLK
		AOS	YBHEXT+2	;Adjust count
	FI
	HLRZ	X2,(X1)		;word offset (wo)
	HRRZ	X1,YBHEXT	;current buffer (cb) - 2
	HRRZ	YBHEXT+1	; - <current word-1> (cw-1)
	SUBI	1(X1)		;written words (ww)
	ADD	YBHEXT+2	;+current count = total buffer count (bc)
	SUBI	(X2)		;-word offset (wo) = new count
	ST	YBHEXT+2
	ADDI	X1,1(X2)	;cb+wo+1 TO (cw-1)
	HRRM	X1,YBHEXT+1
>;[225]

TOPS20,<;[225]
	HRRZ	X3,(X1)	;Block no
	SUBI	X3,1
	LSH	X3,7	;Translate to word offset
	HLRZ	(X1)	;Word offset within block
	ADDM	X3
	HRRZ	(X1)
	SUBI	1
	LSH	-2	;Page no
	SUB	FFP+YEXTLI
	IF	;Not currently in core
		JUMPL	TRUE
		CAMGE	NPA+YEXTLI
		GOTO	FALSE
	THEN	;Put it there
		STACK	X4
		STACK	X1
		LI	X4,YEXTLI
		LI	1
		ST	YEXTAD
		EXEC	O1EXMP
		UNSTK	X1
		UNSTK	X4
	FI
	L	YEXTLI+NPA
	ADD	YEXTLI+FCP
	L	X1,YEXTLI+FCP
	SUB	X1,YEXTLI+FFP
	LSHC	9
	ADD	X3,X1
	SUBI	(X3)
	ST	YBHEXT+2
	LI	X1,-1(X3)
	HRRM	X1,YBHEXT+1
>;[225]

	EXEC	DPEXT
L9():!	RETURN
	EPROC
	SUBTTL	skipoverhead	[144]

O1EXSO:	PROC
	;; Here YBHEXT+1 points to first word-1 of module sought
	L	X1,YBHEXT+1
	HLRZ	1(X1)	;Type code
	IF	;New type of ATR file (entry block first)
		CAIE	QENTRY
		GOTO	FALSE
	THEN	;Get rid of overhead
		GETEXT	X1	;Phase in
		SKIPBLOCK
		CAIN	6
		 SKIPBLOCK	;Name block skipped
		IF	;Not type 0 block
			JUMPE	FALSE
		THEN	;Error
			RFAIL	ILLEGAL ATR FILE FORMAT
			ERROR	(EXT,READ)
	FI	FI
	;; At this point the first word of the ATR info is available
	RETURN
	EPROC


O1EXSK:	;Skip rest of loader block. (X1) = header word
	LI	1(X1)
	LOOP	GETEXT	X1
	AS	SOJGE	TRUE
	SA
	HLRZ	X1	;Type code returned in X0
	RETURN
	SUBTTL	lookitup, LOOKUP ATR file	[144]

Comment;
1) DEC-10:
Looks up <YRQFIL>.ATR[<YRQPPN>] on channel QCHEXT.
 DEC-20:
Uses  the  same info, with any positive ppn translated to a directory
name, to get a handle (JFN) on the  file,  and  opens  the  file  for
input. Skip return on success.
;


O1EXLU:	PROC
	L	XFILE,YRQFIL
	MOVSI	XFILE+1,'ATR'
	STD	XFILE,YELEXT
	SETZM	YELEXT+2
	L	XPPN,YRQPPN
	CAMN	XPPN,[-1]
	 SETZ	XPPN,	;Treat -1 like 0
	ST	XPPN,YELEXT+3
	LOKUPF	EXT;[225]
	 SKIPA
	  AOS	(XPDP)	;Ok, skip return
	ST	XPPN,YELEXT+3
	RETURN
	EPROC
	SUBTTL	Get a JFN, open the file for input
TOPS20,<;[225]

	;Field offsets: (See LOWSEG.MAC, ELBH macro)
	SZ==-4
	JF==-3
	MP==-2
	dev==-1
	fil==0
	ext==1
	dir==3

O1JFNI::PROC	;Get an input JFN for file defined by lookup blk at (X1)
		;OPEN the file for input
		;Skip return on success
	HRLI	X1,(GJ%OLD)
	EXEC	O1JFN	;Just get the JFN
	 RET		;FAILURE!!
	BRANCH	O1OJFI	;Go ahead, open it!
	EPROC

	DEFINE	ACHAR(C)<
	LI	C
	IDPB	X3
	>

O1OJFI::PROC
	SAVE	<X2,X3,X4>
	N==3	;Account for words on the stack
	L	X4,X1
	HRRZ	X1,JF(X4)
	L	X2,[^D36B5+OF%HER+OF%RD+OF%NWT+OF%PLN]
	OPENF
	 GOTO	L9	;FAILED
	SIZEF
	 GOTO	L9
	ST	X3,SZ(X4)	;File size in pages
	AOS	-N(XPDP)	;Skip return on success
L9():!	RETURN
	EPROC


O1JFN::	PROC	;Get a JFN for either input or output
		;The information is to be taken from the
		;TOPS-10 style lookup/enter blk at (X1)
		;Skip return on success.
	SAVE	<X2,X3,X4>
	N==3	;Words on the stack
	L	X3,[POINT 7,YFILSP]
	L	X4,X1
	IFN	QDIRTR,<
	L	X2,DIR(X4)
	IF	;PPN was specified
		JUMPE	X2,FALSE
	THEN	;Translate to "str:<directory-name>"
		SKIPN	X1,DEV(X4)	;Structure or logical name
		MOVSI	X1,'DSK'	;Default is DSK
		LI	X3,3(XPDP)	;Use the stack for struct name
		HRLI	X3,(POINT 7,)	; in ASCIZ
		EXEC	O16TO7
		SETZ
		IDPB	X3
		HRROI	X3,3(XPDP)
		HRROI	X1,YFILSP
		L	X2,DIR(X4)	;ppn
		PPNST%			;PPN to string
		 ERJMP	L8
		L	X3,X1		;Updated string ptr
	ELSE	;Just output the structure name:
	>
		L	X1,DEV(X4)
		IF	;Device field exists
			JUMPE	X1,FALSE
		THEN	;Output "STR:"
			EXEC	O16TO7
			ACHAR	<":">
		FI
		IFN QDIRTR,<
	FI>
	L	X1,FIL(X4)
	EXEC	O16TO7
	ACHAR	(".")
	L	X1,EXT(X4)
	EXEC	O16TO7
	SETZ
	IDPB	X3	;ASCIZ delimited by null
	HLL	X1,X4	;GET FLAGS FROM PARAMETER
	TLO	X1,(GJ%SHT)	;SHORT FORM
	HRROI	X2,YFILSP
	GTJFN
	GOTO	L8	;ERROR
	ST	X1,JF(X4)
	L	X1,X4	;POINTER TO LOOKUP/ENTER BLK
	GOTO	L9
L8():!	;ERROR
	SKIPA
L9():!	AOS	-N(XPDP)
	RETURN
	EPROC
>
	SUBTTL	O16TO7, Translate to ASCII from SIXBIT

O16TO7::PROC
	LOOP
		SETZ
		LSHC	6
		ADDI	" "
		CAIE	" "	;Do not output spaces
		 IDPB	X3
	AS
		JUMPN	X1,TRUE
	SA
	RETURN
	EPROC
	SUBTTL	O1EXRQ	Define request block information

Comment;

Purpose
-------
To define a ZRQ record, later possibly to be  output  as  a  type  17
loader  block  (REQUEST library), defining a REL file to be loaded in
library search mode.

Input
-----
YRQFIL, YRQPPN, YRQDEV from a file definition.

Output
------
XZRQ points to a ZRQ record containing the given information.

Function
--------
All  ZRQ  records  on  the  chain  starting  with YRQHEAD are matched
against  the  input  information.  If  none  exists  with   identical
information, a new ZRQ record is created via SDALLOC and put FIRST on
the chain. The search order is thus the  reverse  of  the  definition
order.

Register usage
--------------
Destroys X0,X1. Returns result in XZRQ.
;

	EXTERN	SDALLOC
	INTERN	O1EXRQ
O1EXRQ:	PROC
	XPPN==X4
	SAVE	<XALLOC,XPPN>
	HRRZ	XZRQ,YRQHEAD
	L	XPPN,YRQPPN
	IF	;Any ZRQ block on the chain
		JUMPE	XZRQ,FALSE
	THEN	;See if any of them matches YRQFIL etc.
		L	YRQFIL
		L	X1,YRQDEV
		LOOP
			IF	;[144] File name and device match
				CAMN	OFFSET(ZRQFIL)(XZRQ)
				CAME	X1,OFFSET(ZRQDEV)(XZRQ)
				GOTO	FALSE
			THEN	;May be there already
				CAMN	XPPN,OFFSET(ZRQPPN)(XZRQ)
				 GOTO	L9	;PPN also matched, ok
				LF	X1,ZRQPPN(XZRQ)
				TOPS10,<;[225]
				IF	;There is an SFD path
					JUMPE	XPPN,FALSE
					JUMPE	X1,FALSE
					TLNN	X1,-1
					TLNE	XPPN,-1
					GOTO	FALSE
				THEN	;See if paths are the same
					LOOP
						L	2(XPPN)
						CAME	2(X1)
						 GOTO	FALSE
						JUMPE	L9	;Finish on zero
						ADDI	X1,1
					AS
						AOJA	XPPN,TRUE
					SA
			FI>
		FI
			LF	XZRQ,ZRQZRQ(XZRQ)
		AS
			JUMPN	XZRQ,TRUE
		SA
	FI

	;Not found, make and put a new block on the chain
	L	[ZRQ%S,,ZRQ%S]
	EXEC	SDALLOC
	L	XZRQ,XALLOC
	HRRZ	YRQHEAD
	WSF	,ZRQZRQ(XZRQ)
	HRRM	XZRQ,YRQHEAD
	L	YRQFIL
	SF	,ZRQFIL(XZRQ)
	SF	XPPN,ZRQPPN(XZRQ)	;[144]
	L	YRQDEV
	SF	,ZRQDEV(XZRQ)
	TOPS10,<;[225]
	LI	X1,OFFSET(ZRQPPN)(XZRQ)	;[144] Old SFD pointer or just a ppn
	L	XPPN,X2	;[144] Save X2 over call
	SETZ	X2,	;[144] A new record must be allocated
	EXEC	O1SFDC	;[144] Copy SFD from global record
	L	X2,XPPN	;[144] Restore X2, ZRQPPN may now have been changed
	>
L9():!	RETURN
	EPROC
	SUBTTL	sfdcopy (O1SFDC)

Comment;	[144] New routine.
Copy SFD record from one place to another.
Input
-----
X1 points to a word - [a,,b]. This word is regarded as an SFD address
iff  a=0,  b NE 0, otherwise as a ppn. The routine has an effect only
if an SFD pointer is provided. X2 is zero or points to  the  new  SFD
record. If X2 is zero, a new record of the required length is created
by SDALLOC. The old SFD is copied to the new record, and  the  [a,,b]
word pointed to by X1 is changed to point to the new record.
;

O1SFDC:	PROC
TOPS10,<;[225]
	L	(X1)
	IF	;Not a ppn
		JUMPE	FALSE
		TLNE	-1
		GOTO	FALSE
	THEN	;Copy
		IF	;New record should be allocated
			JUMPN	X2,FALSE
		THEN	;Do that
			edit(306)
			HRRZ	X2,(X1)	;[306] Count SFD's
			SKIPE	3(X2)
			 AOBJP X2,.-1	;[306] Count
			HLRZ	X2
			ADDI	4	; + 4
			HRL		;Length in other half also
			L	X2,XALLOC
			EXEC	SDALLOC
			EXCH	X2,XALLOC
			L	(X1)
		FI
		ST	X2,(X1)	;New address
		ST	X1
		L	(X1)
		ST	(X2)
		L	1(X1)
		ST	1(X2)
		LOOP	;Copy starting with SFDPPN
			L	2(X1)
			ST	2(X2)
		AS	;Including terminal zero
			JUMPE	FALSE
			ADDI	X1,1
			AOJA	X2,TRUE
		SA
	FI
>;[225]
	RETURN
	EPROC
	SUBTTL	openext	[144]

	TOPS10,<;[225]
O1EX.O:	;Perform OPEN. Call by JSP X0,O1EX.O
	EXCH	X2,YELEXT		;Save X2
	LI	X1,IO.SYN+IO.BIN	;Synchronous binary
	L	X2,YRQDEV
	LI	X3,YBHEXT
	OPEN	QCHEXT,X1
	 BRANCH	[ERROR(EXT,OPEN)]
	EXCH	X2,YELEXT		;Restore X2
	BRANCH	@X0
>

	TOPS20,<;[225]
O1EX.O:	;Just record device name
	L	X1,YRQDEV
	ST	X1,YEXTDV
	BRANCH	@X0
>
	SUBTTL	READ, CLOSE attribute file
TOPS10,<;[225]

;READ ONE BUFFER FROM ATTRIBUTE FILE
;


O1EXTB:	exbuffers	;[225] Allocate buffers, then read first blk
O1EXT:	PROC
	IN	QCHEXT,
	SOSGE	YBHEXT+2
	 JSP	[ERROR(EXT,READ)]
	AOS	YEXBLK	;[144] Count the block
	RETURN
	EPROC	;O1EXT


;
;CLOSE ATTRIBUTE FILE
;

O1EXCL:	PROC
	CLOSE	QCHEXT,
	IF	STATZ	QCHEXT,740000
		GOTO	FALSE
	THEN
		SETON	YPOEXT
		RETURN
	FI
	ERROR	EXT,CLOSE
	EPROC	;O1EXCL
>
TOPS20,<;[225]
O1EXTB:	;Dummy entry for TOPS-20 version
O1EXT:	PROC
	SAVE	<X1,X2,X3,X4>
	LI	X4,YEXTLI
	LI	1
	ST	YEXTAD
	L	X3,FFP(X4)
	ADD	X3,NPA(X4)
	LSH	X3,9
	EXEC	O1EXMP
	SOSGE	YBHEXT+2
	 JSP	[ERROR(EXT,READ)]
	RETURN
	EPROC



O1EXCL:	PROC	;Close external file after unmapping
	SAVE	<X1,X2,X3>
	SETO	X1,
	HLRZ	X2,YEXTMP
	HRLI	X2,.FHSLF
	HRRZ	X3,YEXTMP
	HRLI	X3,(PM%CNT)
	PMAP
	HRRZ	X1,YEXTJF
	HRRZ	YATRJF
	CAIN	(X1)
	HRLI	X1,(CO%NRJ)	;Keep JFN for global ATR file
	CLOSF
	 JSP	[ERROR(EXT,CLOSE)]
	SETZM	YEXTLI+FFP
	SETOM	YEXTLI+FCP
	SETZM	YEXTLI+NPA
	SETON	YPOEXT
	RETURN
	RETURN
	EPROC
>
	SUBTTL	O1IC  Write intermediate code

	INTERN	O1IC1,O1ICCL,O1ICOP

	EXTERN	YELIC1,YBHIC1

;
;Set up core file
;

O1ICOP:	PROC
	LD	[XWD 442200,Y6BUF
		5*2*200]
	STD	YBHIC1+1
	SETZM	YELIC1
	RETURN
	EPROC	;O1ICOP


;
;Core file too small, write file on disk
;

O1OPIC:	PROC
	SAVE	<X0,X1,X2,X3>
	OPEN	QCHIC1,[14
			SIXBIT/DSK/
			XWD YBHIC1,YBHIC1]
	 JSP	[ERROR(IC1,OPEN)]

;Set up ENTER block

	LI	X0,'IC1'
	HLL	X0,YJOB
	MOVSI	X1,'TMP'
	STD	X0,YELIC1
	SETZM	YELIC1+2
	SETZM	YELIC1+3

;ENTER

	ENTER	QCHIC1,YELIC1
	 JSP	[ERROR(IC1,ENTER)]
				edit(162)
	SETZM	YELIC1+3	;[162]
	SETON	YOPIC1

;Set up buffers

	EXEC	O1SETB
	ST	X0,YBHIC1
	L	[XWD 5,Y6BUF]
	ST	YBRBUF
	LI	QHBYTE
	HRLM	YBHIC1+1	;Restore byte size

;Output stored file

	OUTSF(IC1,5,Y6BUF)

	RETURN
	EPROC	;O1OPIC


;
;Output buffer to IC1
;

O1IC1:	PROC
	SKIPN	YELIC1
	 XEC	O1OPIC	;If first call
	OUT	QCHIC1,
	SOSGE	YBHIC1+2
	 JSP	[ERROR(IC1,WRITE)]
	RETURN
	EPROC	;O1IC1


;
;Close IC1
;

O1ICCL:	PROC
	SKIPN	YELIC1
	 RET	;If file in core

	CLOSE	QCHIC1,
	IF	STATZ	QCHIC1,740000
		GOTO	FALSE
	THEN
		SETON	YPOIC1
		RETURN
	FI
	ERROR	IC1,CLOSE
	EPROC	;O1ICCL
	SUBTTL	O1LS  Write source code

	INTERN	O1LSOP,O1LS1,O1LSCL

	EXTERN	YELLS1,YBHLS1,YLCRT4


;
;SET UP CORE FILE
;

O1LSOP:	PROC

	LD	[XWD 444400,Y1BUF
		3*200]
	STD	YBHLS1+1
	SETZM	YELLS1
	RETURN
	EPROC	;O1LSOP


;
;CORE FILE TOO SMALL, WRITE FILE ON DISK
;

O1OPLS:	PROC
	SAVE	<X0,X1,X2,X3>
	OPEN	QCHLS1,[14
			SIXBIT/DSK/
			XWD YBHLS1,YBHLS1]
		JSP	[ERROR(LS1,OPEN)]

;SET UP ENTER BLOCK

	LI	X0,'LS1'
	HLL	X0,YJOB
	MOVSI	X1,'TMP'
	STD	X0,YELLS1
	SETZM	YELLS1+2
	SETZM	YELLS1+3

;ENTER

	ENTER	QCHLS1,YELLS1
	 JSP	[ERROR(LS1,ENTER)]
				edit(162)
	SETZM	YELLS1+3	;[162]
	SETON	YOPLS1

;SET UP BUFFERS

	EXEC	O1SETB
	ST	X0,YBHLS1
	L	[XWD 3,Y1BUF]
	ST	YBRBUF

;OUTPUT STORED FILE

	OUTSF(LS1,3,Y1BUF)

	RETURN
	EPROC	;O1OPLS


;
;OUTPUT BUFFER
;

O1LS1:	PROC
	SKIPN	YELLS1
	 XEC	O1OPLS	;First call
	OUT	QCHLS1,
	SOSGE	YBHLS1+2
	 JSP	[ERROR(LS1,WRITE)]
	RETURN
	EPROC	;O1LS1


;
;CLOSE LS1
;

O1LSCL:	PROC
	IF	;OLD RECORD TYPE 4
		SKIPN	X1,YLCRT4
		GOTO	FALSE
	THEN	;Output it to buffer
		IORI	X1,1
		PUTLS1	X1
	FI

	SKIPN	YELLS1
	 RET	;File in core

	CLOSE	QCHLS1,
	IF	STATZ	QCHLS1,740000
		GOTO	FALSE
	THEN
		SETON	YPOLS1
		RETURN
	FI
	ERROR	LS1,CLOSE
	EPROC	;O1LSCL
	SUBTTL	O1RL  WRITE REL FILE

	INTERN	O1RL,O1RLR,O1RLS,O1RLUNR

	EXTERN	YELREL,YBHREL
	EXTERN	YO1CNB,YO1ACN,YO1RBP,YBREAK


O1RLOP:	PROC

	IFON	YOPREL
	 RET		;If already opened


;SET UP ENTER BLOCK
				edit(162)
	LD	X0,YEXTS+4	;[162] Use correct name at the outset
	STD	X0,YELREL
	LD	X0,YEXTS+6
	STD	X0,YELREL+2
;ENTER

	ENTER	QCHREL,YELREL
	 JSP	[ERROR(REL,ENTER)]
	ST	X1,YELREL+3	;[162]
	SETON	YOPREL
	OUT	QCHREL,
	SKIPA
	 JSP	[ERROR(REL,WRITE)]

			edit(306)
	SETZM	YO1ASB	;[306] No ASCIZ string yet
	SETZM	YO1ASB+1 ;[306]
	SETZM	YO1ASC	;[306]

;Output entry (type 4) item (header word, reloc word, data word)
				edit(1)
	LI	X1,3		;[1]
	L	XLSTXT,[4,,1]	;[1] One data word, item type 4
	LOOP			;[1]
		PUTREL	XLSTXT	;[1]
		SETZ	XLSTXT,	;[1]
	AS			;[1]
		SOJG	X1,TRUE	;[1]
	SA			;[1]

;Generate name record in REL file

	L	XLSTXT,[6,,2]
	PUTREL	XLSTXT		;Generate header for code item type 6

	LI	XLSTXT,0
	PUTREL	XLSTXT		;Generate relocation record

	L	XLSTXT,[RADIX50 0,.MAIN]
	PUTREL	XLSTXT		;Generate standard name for main program
	L	X1,YBHREL	;[1] Also make it an entry name
	ST	XLSTXT,4(X1)	;[1]

	L	XLSTXT,[QSIMREL]
	PUTREL	XLSTXT		;Generate compiler identification entry

	SETZM	YBREAK
	EXEC	O1RLIC		;Initialize code stream

;Output lookup info for source code from which this rel-file originated

	L	YELSRC
	EXEC	O1RL
	L	YELSRC+1
	EXEC	O1RL
	L	YELSRC+2
				edit(250)
	EXEC	O1RL		;[250]
	L	YELSRC+3	;[250]
	TOPS10,<;[225]
	IF	;[144] SFD path [0,,adr]
		JUMPE	FALSE
		TLNE	-1
		GOTO	FALSE
	THEN	;Output the path (ppn,sfd1,sfd2,...,0)
		ST	X1
		LOOP
			L	2(X1)
			JUMPE	FALSE
			EXEC	O1RL
		AS
			AOJA	X1,TRUE
		SA
	FI	;[144]
	>;[225]
	EXEC	O1RL

	RETURN
	EPROC	;O1RLOP
O1RL:	PROC	;Output XLSTXT unrelocated to the code stream

	SOSGE	YO1CNB
	 XEC	O1RLC

	SOSGE	YBHREL+2
	 XEC	O1RLNB

	AOS	YBREAK
	IBP	YO1RBP
	IDPB	XLSTXT,YBHREL+1

	RETURN
	EPROC	;O1RL


O1RLR:	PROC	;Output XLSTXT relocated to the code stream
	SAVE	X1
	SOSGE	YO1CNB
	 XEC	O1RLC
	SOSGE	YBHREL+2
	 XEC	O1RLNB
	AOS	YBREAK
	LI	X1,1
	IDPB	X1,YO1RBP
	IDPB	XLSTXT,YBHREL+1
	RETURN
	EPROC	;O1RLR


O1RLS:	PROC	;Output a symbol to the rel file

	EXEC	O1RLD	;Close previous code item

	L	X0,[2,,2]
	PUTREL	X0	;Generate header for code item type 2
	PUTREL	X1	;Ac'S X1-X3 are set in calling program
	PUTREL	X2
	PUTREL	X3

	EXEC	O1RLIC	;Reinitialize code stream

	RETURN
	EPROC


O1RLC:	PROC	;Generate relocation word

	SAVE	X1

	IF	;No more room in buffer
		SOSLE	YBHREL+2
		GOTO	FALSE
		edit(71)
	THEN	;[71] New buffer
		EXEC	O1RLD
		EXEC	O1RLIC
		SOS	YO1CNB
	ELSE
		LI	X1,0
		IDPB	X1,YBHREL+1	;Relocation word
		L	X1,YBHREL+1
		HRLI	X1,440200
		ST	X1,YO1RBP	;Pointer to relocation word
		LI	X1,^D17
		ST	X1,YO1CNB	;Excess data words before next relocation word
	FI

	RETURN
	EPROC	;O1RLC


O1RLD:	PROC	;Close current code item
	SAVE	X1
	L	X1,YBREAK
	SUB	X1,@YO1ACN
	ADDI	X1,1
	HRRM	X1,@YO1ACN
	RETURN
	EPROC	;O1RLD


O1RLNB:	PROC	;Start new buffer
	EXEC	O1RLD
	EXEC	O1RLIC
	SOS	YBHREL+2
	SOS	YO1CNB
	RETURN
	EPROC	;O1RLNB
O1RLIC:	PROC	;Initialize new code item (type 1)
	SAVE	X1
	SOS	X1,YBHREL+2
	CAIGE	X1,3
	 XEC	O1REL
	L	X1,YBREAK
	HRLI	X1,1
	IDPB	X1,YBHREL+1	;Header of code item. (counter not correct)

	L	X1,YBHREL+1
	HRRZM	X1,YO1ACN	;Pointer to header

	EXEC	O1RLC		;Generate relocation word

	L	X1,YBREAK
	SOS	YBHREL+2
	IDPB	X1,YBHREL+1	;Load address

	LI	X1,1
	IDPB	X1,YO1RBP	;Relocate load address

	RETURN
	EPROC	;O1RLIC


O1REL:	PROC	;Write a buffer
edit(3) ;[030406] Begin
	SAVE	<X0,X1>
	AOS	X1,YRELBL	;Count this buffer
edit(16)
REPEAT 0,<	;[16] This code commented out because of i/o problems,
		;     to be revised later
	IF	;Not main program
		JUMPGE	X1,FALSE
	THEN	;Special buffer handling
		HRRZ	X1	;Number of buffers now
		IF	;Less than 2 buffers
			CAIL	2
			GOTO	FALSE
		THEN	;Suspend output of first buffer
			HRRZ	@YBHREL
			HRRM	YBHREL	;Switch buffer
			ADDI	1
			HRRM	YBHREL+1	;Byte pointer
			LI	200		;Number of words
			ST	YBHREL+2
			GOTO	L8
		FI
		IF	;2nd buffer was just filled
			CAIE	2
			GOTO	FALSE
		THEN	;Output first buffer
			HRRZ	X1,@YBHREL
			OUT	QCHREL,(X1)
			SOSGE	YBHREL+2
			 GOTO	L9
	FI	FI
>;[16] End repeat 0
	OUT	QCHREL,
	SOSGE	YBHREL+2
	 GOTO	L9	;Error

L8():!	RETURN
L9():!	ERROR	REL,WRITE
	EPROC	;O1REL
;[030406] End
O1RLRQ:	PROC	;Output all ZRQ records on YRQHEAD chain marked for output
		;Input: X2=YRQHEAD, which is non-zero
	IFOFFA	ZRQOUT(X2)
	 RET

	LOOP
		WLF	X3,ZRQZRQ(X2)
		IF	;Output required
			IFOFFA	ZRQOUT(X3)
			GOTO	FALSE
		THEN	;Output library search information to LINK
			IFN QDEC20,<EXEC O1RLOA>;[225] Output a command string
			IFE QDEC20,<;[225]
			IF	;[144] No SFD
				LF	,ZRQPPN(X2)
				JUMPE	TRUE
				TLNN	-1
				GOTO	FALSE
			THEN	;Output type QREQLIB block
				L	[QREQLIB,,3]
				PUTREL
				SETZ
				PUTREL
				LF	,ZRQFIL(X2)
				PUTREL
				LF	,ZRQPPN(X2)
				CAMN	[-1]	;[144]
				SETZ		;[144]
				PUTREL
				LF	,ZRQDEV(X2)
				PUTREL
			ELSE	;[144] Output ASCIZ string
				EXEC	O1RLOA
			FI>;[225]
		FI
		HRRZ	X2,X3
	AS
		JUMPN	X2,TRUE
	SA
	RETURN
	EPROC
	SUBTTL	O1RLOA Output ZRQ+ZSF as ASCIZ string in REL file

Comment;

Outputs a string "dev:atrfile[proj,prog,sfd1,sfd2,...]/SEARCH" to the
REL file in ASCIZ format, i e at least one trailing zero byte. [306]:
If last word output to rel file is the last  word  of  another  ASCIZ
string,  restart  there with a comma, making a longer command string.
Uses the routines O16BIT, O1OCTD,  which  call  O1RLAS  in  coroutine
fashion.

O16BIT receives a SIXBIT word in XARG and converts one character at a
time  to  ASCII  (in  XASCII).  Returns  to caller when all non-blank
characters have been converted.

O1RLAS assembles ASCII words of 5 characters in  XASCII  and  outputs
each  word to the REL file as it is filled. If O1RLAS receives a null
character in XCHAR, it will fill (the rest  of)  XASCII  with  nulls,
output the word and exit via PROCEED.

O1OCT  takes  an integer in XARG and produces successive octal digits
(initial zeros suppressed).
;

	XCHAR==	X3	;ASCII character
	XARG==	XCHAR+1	;SIXBIT or binary value
	XJSP==	X16	;JSP ac
	XSFD==	X7	;Pointer to ZSF record
	XASCII==X10	;ASCII word assembled here
	XN==	X12	;Counter in O1OCT

	OPDEF	GENABS	[XEC	O1RL]	;Output word to REL file unrelocated

	OPDEF	proceed	[JSP	XJSP,(XJSP)] ;Implements coroutine call

	DEFINE	outchar(C)<
	LI	XCHAR,C
	proceed
	>
	DEFINE	outsix(F)<;; F is a field macro defined via DF
	LF	XARG,F
	XEC	O16BIT
	>
	DEFINE	outoct(F)<
	LF	XARG,F
	XEC	O1OCT
	>

 DF word,0,36,35;;Any 36-bit word
 DF LH,0,18,17	;;Any left halfword
 DF RH,0,18,35	;;Any right halfword

O1RLOA:	PROC
	SAVE	<X1,XN,XSFD,XARG,XCHAR,XJSP>
	LI	XJSP,O1RLAS	;Initialize coroutine system
	LD	X0,YO1ASB	;[306] Block no of earlier string
				;Also byte pointer to its last word
	IF	;[306] That was last word output
		CAMN	X0,YRELBL
		CAME	X1,YBHREL+1
		GOTO	FALSE
	THEN	;Restart there, splicing in a comma
		SOS	YBHREL+1	;Back up byte ptr
		AOS	YBHREL+2	;Back up count
		LI	XCHAR,","
		proceed
	FI

	IFE QDIRTR,<;[225]
	outsix	<ZRQDEV(X2)>	;Device
	outchar	<":">
	>
	IFN QDIRTR,<;[225]
	LF	XSFD,ZRQPPN(X2)	;Zero or [p,pn]
	IF	;Non-zero
		JUMPE	XSFD,FALSE
	THEN	;Translate to "str:<directory>"
		EXCH	XSFD,X2
		LI	X3,3(XPDP)	;Use the stack for struct name
		HRLI	X3,(POINT 7,)	; in ASCIZ
		EXEC	O16TO7
		SETZ
		IDPB	X3
		HRROI	X3,3(XPDP)
		L	X1,[POINT 7,YFILSP]
		PPNST%
		ERJMP	FALSE
		EXCH	X2,XSFD
		L	XN,[POINT 7,YFILSP]
		LOOP	;Copy the string
			ILDB	XCHAR,XN
			JUMPE	XCHAR,FALSE
			proceed
		AS
			GOTO	TRUE
		SA
	ELSE	;Just dev:
		outsix	<ZRQDEV(X2)>
		outchar	<":">
	FI
	>;[225]
	outsix	<ZRQFIL(X2)>	;File name
	IFE QDIRTR,<;[225]
	LF	XSFD,ZRQPPN(X2)	;SFD pointer or PPN
	IF	;Non-zero PPN
		JUMPE	XSFD,FALSE
	THEN	;Output path definition
		outchar	<"[">
		IF	;No SFD
			TLNN	XSFD,-1
			GOTO	FALSE
		THEN	;Output just [proj no,programmer no]
			outoct	<LH(,XSFD)>	;project no
			outchar	<",">
			outoct	<RH(,XSFD)>	;programmer no
		ELSE	;Output SFD path
			TOPS10,<
			outoct	<ZSFPJ(XSFD)>	;Project no
			outchar	<",">
			outoct	<ZSFPG(XSFD)>	;Programmer no
			LOOP
				LF	XARG,ZSFSFD(XSFD)
				JUMPE	XARG,FALSE
				outchar	<",">
				EXEC	O16BIT
			AS
				AOJA	XSFD,TRUE
			SA
			>
		FI
		outchar	<"]">
	FI
	>;[225]
	outsix	<word(,[SIXBIT'/SEARC'])>
	outchar	<"H">
	outchar	0
			edit(306)
	L	X0,YRELBL	;[306] Save block no
	L	X1,YBHREL+1	;[306] and byte pointer
	STD	X0,YO1ASB	;[306] for any following command
	RETURN
	EPROC
	SUBTTL	O16BIT Convert word to ASCII characters

Comment;

Input
-----
SIXBIT word in XARG.

Output
------
ASCII character in XCHAR.

Function
--------
Starting  at  the  leftmost  bit  of  XARG, shift 6 bits to XCHAR and
convert to ASCII by adding octal 40. Deliver XCHAR  to  coroutine  by
the  PROCEED  coroutine  jump.  Return  to  caller  when  XARG=0, i e
trailing blanks (null characters) are ignored.
;

O16BIT:	PROC
	SETZ	XCHAR,
	LOOP
		LSHC	XCHAR,6
		ADDI	XCHAR,40
		proceed
		SETZ	XCHAR,
	AS
		JUMPN	XARG,TRUE
	SA
	RETURN
	EPROC
	SUBTTL	O1OCT Octal to ASCII

Comment;

Input
-----
Integer in XARG.

Output
------
ASCII  digits,  one  at  a  time,  in XCHAR, to the current coroutine
reached by PROCEED.

Function
--------
Similar to O16BIT. Returns directly if XARG=0.
;

O1OCT:	PROC
	JUMPE	XARG,L9
	SETZ	XCHAR,
	LI	XN,^D12
	LOOP	;Over initial zeros
		JUMPN	XCHAR,L1
		LSHC	XCHAR,3
	AS
		SOJG	XN,TRUE
	SA
	GOTO	L9
	LOOP
		LSHC	XCHAR,3
L1():!		ADDI	XCHAR,"0"
		proceed	;to character handler
		SETZ	XCHAR,
	AS
		SOJGE	XN,TRUE
	SA
L9():!	RETURN
	EPROC
	SUBTTL	O1RLAS Assemble ASCII word and output to REL file

Comment;

Input
-----
XCHAR = ASCII character.

Output
------
XASCII= ASCII string of 5 characters, left justified. Placed in REL
file buffer.

Function
--------
Coupled   as  a  coroutine  to  some  routine  which  delivers  ASCII
characters in XCHAR. Left and entered by the PROCEED  instruction  (a
JSP).  Special  action:  If  XCHAR=0 (null character), fill (rest of)
XASCII with nulls and output, then return via PROCEED.
;

O1RLAS:	PROC
				edit(306)
	L	XASCII,YO1ASC	;[306]  Load any unfinished word
	JUMPN	XASCII,L1	;[306] Right into the action
	LI	XASCII,200(XCHAR)	;Put overflow marker in front of first char
	LOOP	;over words
		LOOP	;Accumulating characters
			edit(306)
			proceed		;Get next character
			IF ;Zero filler
			   JUMPN XCHAR,FALSE
			THEN ;[306] Save current contents, zero fill
			    ST XASCII,YO1ASC
			    LSH XASCII,7
			    JUMPGE XASCII,.-1
			ELSE ;Accumulate
L1():!			    LSH	XASCII,7
			    TRO	XASCII,(XCHAR)
			FI
		AS	;Long as flag bit not shifted to sign pos
			JUMPGE	XASCII,TRUE
		SA
		L	XASCII
		LSH	1	;Adjust to normal ASCII format, skip flag bit
		PUTREL		;[225] No reloc wds needed
		LI	XASCII,1	;Flag bit to detect full word with LSH
	AS	;Long as non-zero characters are supplied
		JUMPN	XCHAR,TRUE
	SA
	proceed	;Escaped from loops!
	EPROC
	SUBTTL	O1RLUNR - Output special info to REL file

O1RLUNR:PROC
				edit(13)
	L	X1,YDPUNR	;[13]
	L	X2,YRQHEAD	;[13]
	IF	;[13] Either or both are non-zero
		JUMPN	X1,TRUE
		JUMPE	X2,FALSE
	THEN	;Output type 0 block and/or ASCIZ string to rel file
		EXEC	O1RLD	;Close current code item
		SKIPE	X1
		 XEC	O1RL.U	;External reference list
		SKIPE	X2,YRQHEAD
		 XEC	O1RLRQ	;LINK command string
		EXEC	O1RLIC	;Initialize new code item
	FI
	RETURN
	EPROC



O1RL.U:	PROC
;Count number of external references

	LI	X2,1
	SKIPE	X1,1(X1)
	 AOJA	X2,.-1

;Compute length of code item
;=no of externals - no of relocation words [+1]

	LI	X0,(X2)
	ADDI	X2,^D17
	IDIVI	X2,^D19
	SUBI	X0,(X2)

	PUTREL	X0	;Output item header [0,,n]

	L	X1,YDPUNR
	LOOP
		L	X0,(X1)
		PUTREL	X0
	AS
		SKIPE	X1,1(X1)
		GOTO	TRUE
	SA

	LI	X0,0
	PUTREL	X0
	RETURN
	EPROC
	SUBTTL	O1SC  Read source code

	INTERN	O1SCOP,O1SC,O1SCCL

	EXTERN	YELSRC,YBHSRC


O1SCOP:	PROC


;LOOKUP
	L	X0,YELSRC+1	;[144] Save extension and ppn
	L	X1,YELSRC+3	;[144]
	IF	LOOKUP	QCHSRC,YELSRC
		SKIPA
		GOTO	TRUE
		JUMPN	X0,FALSE	;[144]
		MOVSI	X0,'SIM'	;[144]
		ST	X0,YELSRC+1	;[144]
		ST	X1,YELSRC+3	;[144] Restore path info
		LOOKUP	QCHSRC,YELSRC
		GOTO	FALSE
	THEN	;Found it
					edit(250)
		ST	X1,YELSRC+3	;[144,250] Restore path info
		SETON	YOPSRC
		LI	X0,QWBYTE
		HRLM	X0,YBHSRC+1
	;Code for output of "SIMULA: <file name>"
		IF	;Started via CCL entry
			IFOFF	YI1CCL
			GOTO	FALSE
		THEN	;Probably COMPIL-class command
			IF	IFONA	YI1SWS
				GOTO	FALSE
			THEN	;First source
				OUTSTR	[ASCIZ/SIMULA:  /]
				L	X1,YELSRC	;Get file-name
				LOOP	;Until no more characters
					LI	X0,0
					LSHC	X0,6
					ADDI	X0,40
					OUTCHR	X0
				AS
					JUMPN	X1,TRUE
				SA
				SETONA	YI1SWS
			FI
		FI
		EXEC	O1RLOP	;Open REL file
		RETURN
	FI
						edit(45)
	LI	X1,YELSRC			;[45] Name of file in list
	ERRT	QT,256
	BRANCH	O1ERR
	EPROC


O1SC:	PROC
	IF	IFONA	YI1SWF
		GOTO	FALSE
	THEN	SETONA	YI1SWF
		AOS	(XPDP)
		RETURN
	FI
	IF	;No next buffer
		IN	QCHSRC,
		GOTO	FALSE
	THEN	;May be EOF
		IF	STATZ	QCHSRC,740000
			GOTO	FALSE
		THEN
			EXEC	O1SCCL
			AOS	0(XPDP)
			RETURN
		FI
		ERROR	SRC,READ
	FI
	AOS	YBHSRC+1
	RETURN
	EPROC


;CLOSE source code file

O1SCCL:	PROC
	CLOSE	QCHSRC,
	IF	STATZ	QCHSRC,740000
		GOTO	FALSE
	THEN
		SETOFF	YOPSRC
		RETURN
	FI
	ERROR	SRC,CLOSE
	EPROC
	SUBTTL	O1XR  Write cross-reference file

	INTERN	O1XROP
	INTERN	O1XR,O1XRCL

	EXTERN	YELXRF,YBHXRF


;
;Set up core file
;

O1XROP:	PROC

	LD	[XWD 444400,Y4BUF
		2*200]
	STD	YBHXRF+1
	SETZM	YELXRF
	RETURN
	EPROC	;O1XROP


;
;Core file too small, write file on disk
;

O1OPXR:	PROC
	SAVE	<X0,X1,X2,X3>
	OPEN	QCHXRF,[14
			SIXBIT/DSK/
			XWD YBHXRF,YBHXRF]
		JSP	[ERROR(XRF,OPEN)]

;Set up ENTER block

	LI	X0,'XRF'
	HLL	X0,YJOB
	MOVSI	X1,'TMP'
	STD	X0,YELXRF
	SETZM	YELXRF+2
	SETZM	YELXRF+3

;ENTER

	ENTER	QCHXRF,YELXRF
	 JSP	[ERROR(XRF,ENTER)]
				edit(162)
	SETZM	YELXRF+3	;[162]
	SETON	YOPXRF
;Set up buffers

	EXEC	O1SETB
	ST	0,YBHXRF
	L	[XWD 2,Y4BUF]
	ST	YBRBUF

;Output  stored file

	OUTSF(XRF,2,Y4BUF)

	RETURN
	EPROC	;O1OPXR


;
;Output buffer
;

O1XRF:	PROC

	SKIPN	YELXRF
	 XEC	O1OPXR	;First call
	OUT	QCHXRF,
	 SOSGE	YBHXRF+2
	  JSP	[ERROR(XRF,WRITE)]
	RETURN
	EPROC	;O1XRF


;
;Output a record to XRF
;

O1XR:	PROC

	LF	X0,YLSCLIN
	HRL	X0,X1CUR
	PUTXRF
	RETURN
	EPROC	;O1XR


;
;CLOSE cross-reference file
;

O1XRCL:	PROC

	SKIPN	YELXRF
	 RET	;File stayed in core

	CLOSE	QCHXRF,
	IF	STATZ	QCHXRF,740000
		GOTO	FALSE
	THEN
		SETON	YPOXRF
		RETURN
	FI
	ERROR	XRF,CLOSE
	EPROC	;O1XRCL
	SUBTTL	O1ZS  Write symbol table

	INTERN	O1ZS

	EXTERN	YELZSE,YBHZSE
	EXTERN	ZSE



O1ZSOP:	PROC

	OPEN	QCHZSE,[14
			SIXBIT/DSK/
			XWD YBHZSE,YBHZSE]
	 JSP	[ERROR(ZSE,OPEN)]

;Set up ENTER block

	LI	X0,'ZSE'
	HLL	X0,YJOB
	MOVSI	X1,'TMP'
	STD	X0,YELZSE
	SETZM	YELZSE+2
	SETZM	YELZSE+3

;ENTER

	ENTER	QCHZSE,YELZSE
	 JSP	[ERROR(ZSE,ENTER)]
	SETZM	YELZSE+3	;[162]
	SETON	YOPZSE
	L	[XWD 2,Y15BUF]
	ST	YBRBUF
	EXEC	O1SETB
	ST	X0,YBHZSE
	SETZM	YBHZSE+2
	RETURN
	EPROC	;O1ZSOP


;
;Output one buffer
;

O1ZSE:	PROC
	OUT	QCHZSE,
	SOSGE	YBHZSE+2
	 JSP	[ERROR (ZSE,WRITE)]
	RETURN
	EPROC	;O1ZSE


;
;Close file
;

O1ZSCL:	PROC
	CLOSE	QCHZSE,
	IF	STATZ	QCHZSE,740000
		GOTO	FALSE
	THEN
		SETON	YPOZSE
		RETURN
	FI
	ERROR	ZSE,CLOSE
	EPROC	;O1ZSCL


;
;Main program
;

O1ZS:	PROC
	IFONA	YO1ZSW
	 RET	;Called already
	SETONA	YO1ZSW
	IF	;Not too big
		LI	X1,Y11BUF
		SKIPN	YELIC1
		ADDI	X1,2*<QBUFS+1>
		SKIPN	YELDF1
		ADDI	X1,2*<QBUFS+1>
		SUB	X1,YBRZSE
		HRRZ	X2,YMAXID
		SUBI	X2,1777
		ASH	X2,1
		CAMLE	X2,X1
		GOTO	FALSE
	THEN	;ZSE can be kept in core
		L	X3,YBRZSE
		ADDM	X2,YBRZSE
		HRL	X0,X3
		LI	X1,-1(X2)
		STD	X0,YBHZSE+1
		ADDI	X2,2
		ASH	X2,-2
		LI	X4,2000
		LOOP
			LD	X11,YZSE1(X4)
			LD	X13,YZSE2(X4)
			EXCH	X12,X13
			STD	X11,(X3)
			STD	X13,2(X3)
			ADDI	X3,4
			ADDI	X4,2
		AS
			SOJG	X2,TRUE
		SA
		SETZM	YELZSE
		RETURN
	FI

	EXEC	O1ZSOP
	MOVN	X0,YMAXID
	ADDI	X0,1777
	LI	X1,2000
	HRL	X1,X0
	IF
		JUMPG	X1,FALSE
	THEN	LOOP
			L	X0,YZSE1(X1)
			PUTZSE
			L	X0,YZSE2(X1)
			PUTZSE
		AS
			AOBJN	X1,TRUE
		SA
	FI
	EXEC	O1ZSCL
	RETURN
	EPROC
	SUBTTL	O1ERR	ERROR ROUTINE

O1ERR:

			edit(45)
	ERRT	QT,256	;[45] Output name of file in message
	BRANCH	T1AB


REPEAT 0,<;; [144] Obsolete, not used
O1ERR1:	PROC
	LOOP
		LI	X3,0
		LSHC	X3,6
		ADDI	X3,40
		OUTCHR	X3
	AS
		SOJG	X5,TRUE
	SA
	RETURN
	EPROC	;O1ERR1


O1ERR2:	PROC
	LI	0
	LI	X5,6
	LOOP
		LSHC	3
	AS
		JUMPN	FALSE
		SOJG	X5,TRUE
	SA
	LSHC	-3
	LOOP
		LI	0
		LSHC	3
		ADDI	60
		OUTCHR
	AS
		SOJG	X5,TRUE
	SA

	RETURN
	EPROC	;O1ERR2
>;;[144] End REPEAT 0
	SUBTTL	O1PACK	Pack files kept in core

	INTERN	O1PACK

O1PACK:	PROC
	LI	X3,Y1BUF

;Pack LS1

	IF	;LS1 is in core entirely
		SKIPE	YELLS1
		GOTO	FALSE
	THEN	;Keep it there
		LI	X1,3*200
		SUBB	X1,YBHLS1+2
		L	[XWD 444400,Y1BUF]
		ST	YBHLS1+1
		ADD	X3,X1
	FI

;Pack XRF

	IF	;XRF in core and contains any data
		SKIPE	YELXRF
		GOTO	FALSE
		LI	X1,2*200
		SUBB	X1,YBHXRF+2
		JUMPE	X1,FALSE
	THEN	;Move it in core
		LI	X4,(X3)
		HRLI	X4,444400
		ST	X4,YBHXRF+1
		HRLI	X4,Y4BUF
		ADD	X3,X1
		BLT	X4,-1(X3)
	FI
	ST	X3,YBRSRC

;Pack IC1

	IF	;Not on disk
		SKIPE	YELIC1
		GOTO	FALSE
	THEN	;Move it down
		LI	X1,5*2*200
		SUBB	X1,YBHIC1+2
		ADDI	X1,1
		ASH	X1,-1
		LI	X4,(X3)
		HRLI	X4,442200
		ST	X4,YBHIC1+1
		HRLI	X4,Y6BUF
		ADD	X3,X1
		BLT	X4,-1(X3)
	FI
	ST	X3,YBRZSE

	RETURN
	EPROC	;O1PACK
	SUBTTL	O1SETB	Set up buffers

	INTERN	O1SETB

O1SETB:	PROC
	SAVE	<X2>	;[17]

	L	X0,YBRBUF
	HLRZ	X3,X0
	ADDI	X0,1
	HRLI	X0,201
	L	X2,X0
	WHILE
		SOJE	X3,FALSE
	DO
		L	X1,X2
		ADDI	X2,QBUFS+1
		ST	X2,(X1)
	OD
	ST	X0,(X2)
	HRLI	X0,400K
	RETURN
	EPROC	;O1SETB
	SUBTTL	Literals
	LIT
	XPUNGE
	END