/Meta command processor for FORTRAN
*400;INBUF, ;DECIMAL;VERSION, 05;38;OCTAL

/Written by:

/	Stephen R. Besch
/	Dept. of Physiology
/	SUNY at Buffalo
/	Buffalo, N.Y. 14214
/	APR 6, 1984
/
/Modified by:
/	Johnny Billquist

/Assemble, Load and Save:

/	.REN SYS:F4P1.SV<SYS:F4.SV
/	.PAL F4META-LS		/Listing if desired
/	.LO F4META
/	.SAVE SYS:F4

/This routine is a pre processor for FORTRAN 4. It generates an
/an output file on SYS, intended for input for pass1 of F4. In this
/file, all META commands have been expanded. The file start block
/and length/device information are stored in the command decoder
/area for F4, in place of the input file(s) specified to the
/command decoder.

/There are currently 2 meta commands: INCLUDE and FORCE. These are
/described in detail below. Any command must be specified with no
/embedded separator characters (space or tab) and must be followed
/by a separator character. If you wish to use one of the keywords
/as a variable or subroutine name, you must follow it with some
/non-separator character immediately. (E.g., FORCE=EXPR is OK but
/FORCE = EXPR is not.)

/The "INCLUDE" command functions to include, as part of the program
/file, the text in the files specified with the INCLUDE keyword.
/This insert of text is made immediately following
/the line which preceeds the INCLUDE command.

/The format of the command is as follows:

/	INCLUDE DEV:FILE1.EX,DEV:FILE2.EX,.......
/     1 .....
/     1 ...,DEV:FILEN.EX

/Each of these files will be processed in order as they are seen.
/There may be as many as 64 of them on a single line. Each file
/may itself contain INCLUDE lines, the only restriction being that
/the total number of INCLUDE files PENDING at any one time be
/limited to 73. Each file on an INCLUDE line is stored on an input
/file Q to await inclusion in the text stream before any of the
/files are read from. If one of the include files contains an
/INCLUDE statement, all of these files will be added to the pending
/Q along with any files still pending. It is impossible to
/predict how many levels of INCLUDE you are permitted. The best
/thing to do is act as though there are infinite levels until
/the Q overflows. If you can get this to happen, write and tell
/me about it while you're splitting the INCLUDE into 2 lines.
/Note that a line of INCLUDE files will only push 1 file
/on the pending Q if none of the included files contain INCLUDE
/lines. Thus many more than 73 files could be specified
/with a single INCLUDE.

/Note that if no "DEV" is specified, the routine will first look
/on the device the main program originates from. If the INCLUDE
/file cannot be found there (or on "DEV" when specified), the file
/will be looked up on DSK. Only when all these possibilities fail
/will the error message "Can't find INCLUDE file" be given.

/FORCE command added. This command allows the setting of processor
/run time switches from program level. The format of the command is:

/	FORCE x,y,z,...

/where, "x" etc. are "/" option characters. Invalid characters will
/generate an error condition and terminate program execution.
/For the options to have any meaning, they must of course have
/significance to one of the Fortran System programs. Continuation
/lines are permitted but since at least 29 option characters would
/fit on a single line, it is not likely that continuation lines
/would be necessary.

/Aditionally, this routine converts all lower case characters
/in the input stream into their upper case equivalents. This
/enables the use of lower case characters in FORTRAN code.

/Strippable comments are available after version 5.18. Any lines
/which have a "/" as the first character will not be passed to
/the output file. The "/" is not a valid FORTRAN character in
/col. 1 so there is no conflict with any FORTRAN program. This
/feature allows comments in the source file which will not appear
/in the listing file. It also permits comments between lines where
/they are normally not permitted (i.e., between continuation lines).

/By this method, version numbers in INCLUDE files need not be passed
/to the listing file.

/There are three run time switches applicable to this routine:

/	"/3"	Call PASS3 directly to generate listing file.
/		The first output file becomes the listing file

/	"/E"	Use Left-over FORTRAN error table to include
/		compilation errors in the listing. This option
/		only works if the compiler is called directly
/	 	from the monitor (i.e. R F4) or if the calling
/		program does not destroy the field 1 error table

/	"/D"	Include lines preceded by a "D".
/		Otherwise lines beginning with a "D" is treated
/		like they began with a "C".

	BSIZE=3			/I/O buffer size
	STKSIZ=1000		/room for 73 pending files (1000/7)
	ISTKSZ=200		/room for 64 files/line
	USR=200
	FILE1=7600
	FILE2=7605
	OPTION=7643


/Here if Monitor start

FILSET,	CIF 10			/Set field 1
	JMS I	[7700		/Call USR
	10			/Lock it in core

	CIF 10
	JMS I	[USR		/Call user service routine
	5			/Command decoder
	0624			/Default extension="FT"
	JMP	START2		/Skip USRIN and RESET

/Here if Chain in

START,	CIF 10
	JMS I	[7700		/Call USR
	10			/to lock it in core

	CIF 10			/Do a reset function to get rid
	JMS I	[USR		/of any handlers or Tentative
	13			/files left hanging around

/Here after files specified.

START2,	CIF 10			/Set field 1
	CLA IAC			/Set SYS:
	JMS I	[USR		/call USR
	3			/to open an output file
OB,	FRTNTM			/Name is FORTRAN.TM
OL,	0			/Length word
OFERR,	JMS	ERROR		/Can't open output file

	TAD	OB
	DCA	OUTBLK		/Set output block
	TAD	OL
	DCA	OUTLEN		/Set output length

/Here to process the "/D" option. If there is a listing specified,
/do not default to PURGED comments and empty lines.

	CDF 10

CHKD,	TAD I	(OPTION		/Load A-Z option word
	AND	(400		/Get "/D" option
	SNA CLA			/Skip if "D" option set
	JMP	NODOPT		/Not there

SETD,	CDF 0			/Reset this field
	TAD	(FIRSTC		/Load fix address
	DCA I	(YSTRIP+1	/Strip comments
	CDF 10

NODOPT,	TAD I	FILPTR		/Load first input file spec
	CDF 0
	SNA			/Skip if defined
NOINF,	JMS	ERROR		/No input file?
	AND	[17		/Remove the file length
	DCA	INDEV		/Store input device number
	CLA IAC			/Force SYS
	CDF 10
	DCA I	FILPTR		/Make first Input file on SYS
	ISZ	FILPTR		/Bump pointer
	TAD I	FILPTR		/Load the start block
	CDF 0
	DCA I	(INBLK		/Store it
	TAD	OB		/And move FORTRN.TM block number in
	CDF 10
	DCA I	FILPTR		/Store it for F4 chain
	CDF 0

/Loop here to stack all input files.

INFLP,	TAD I	(INBLK		/Stack the file
	JMS I	[PUSH2
	TAD	INDEV
	JMS I	[PUSH2

	ISZ	FILPTR		/Bump to next file
	CDF 10
	TAD I	FILPTR		/Load the next device number
	CDF 0
	SNA			/Skip if not zero
	JMP	PASS0		/Exit start up code
	AND	[17		/Get rid of file length
	DCA	INDEV		/Set input device
	CDF 10
	DCA I	FILPTR		/Make the file dissappear
	ISZ	FILPTR		/Point to start block
	TAD I	FILPTR
	CDF 0
	DCA	INBLK		/Set the input block
	JMP	INFLP		/Loop on all files

/Here to move the files onto the input file Q. The POP2 call will
/branch to the character fetch routines (FIRSTC) when the stack
/empties.

PASS0,	TLS			/Force the flag for error messages
PUSHF,	JMS I	[POP2		/Get input device
	DCA	INDEV		/Store it
	JMS I	[POP2		/Get the block number
	DCA I	(INBLK		/Store it
	TAD	(FIRSTC		/Load file service address
	JMS	STKFIL		/Stack the file
	JMP	PUSHF		/Do all of them

FILPTR,	7617			/Initial pointer

	*400^BSIZE+INBUF
OUTBUF,
MSSG04,	TEXT *^[ERROR OPENING FORTRN.TM^%*
MSSG12,	TEXT *^[NO INPUT FILE^%*
	*400^BSIZE+OUTBUF

/	PAGE /3400

PEND,	0
FIRSTC,	JMS I	[GETCHR		/Load first character on line

COND,	TAD	CHAR		/Load the character then
	DCA I	(SAVEB		/Store in save buffer
	DCA I	(SAVEB+1	/And the initial sentinel

	JMS I	[SORTJ		/Is it a comment?
	-"!;MTYLIN		/Copy line over
YSTRIP,	-"D;FIXC		/with or without comment mark.
	-"C;MTYLIN		/if it's a comment, and no pending OP
	-215;MTYLIN		/EMPTY line if CR first character
	-"/;PURGE		/Purge strippable comments

	TAD	(SAVEB+1	/Load the initial pointer
	DCA	SAVPTR		/Set the pointer

CHRLP,	JMS	SAVEC		/Get a character from input buffer
	CLA CLL			/Zero AC and link
	TAD	COLUMN		/Load current column
	TAD	(-6		/See if continuation col.
	SZA CLA			/Skip if continuation col
	JMP	NOTCNL		/It's not
	JMS I	[SORTJ		/Examine the character
	-" ;NOTCNL		/Not a continuation line
	TAD	PEND		/Sentinel

/If we have a continuation line and a pending operation,
/return to the  pending operation. Otherwise, just copy over
/the rest of the line.

	SNA CLA			/Skip if pending operation
	JMP	NEWLIN		/Get next line then
	ISZ	PEND		/Bumped return means line continued
	JMP I	PEND		/Return to pending operation

FIXC,	TAD	("C		/Set char to "C" insead of "D".
	DCA	CHAR
	JMP	COND		/And repeat with a C instead.

NOTCNL,	SNL CLA			/Skip if after continuation col.
	JMP	CHRLP		/If not, keep going till we are

/We arrive here for three reasons:

/ 1) We pass the continuation column without finding a continuation
/	character in col. 6. In this case, we have the start of a
/	fresh line.

/ 2) We have a true empty line (first character is a CR code).

/ 3) We have a comment line. This may at first seem strange, but
/	if we don't test PEND on comment lines, the INCLUDE
/	statement may replay the comment line to the output file.

/Any of these conditions will terminate pending operations. We must
/check to see if there is a pending operation here, and let the
/pending operation remove itself from the Q (i.e., call PEND without
/bumping), and then call CHKLIN.

/If there is no pending operation, we just fall through to
/CHKLIN. Note that CHKLIN will only have the opportunity to find
/a match character on condition #1, and will otherwise fall through
/to NEWLIN and copy the line over.

MTYLIN,	TAD	PEND		/Is there a pending operation
	SZA CLA			/Skip if not
	JMP I	PEND		/return to PEND

CHKLIN,	JMS I	[SORTJ		/Sort and jump
	-"I;INCLUD		/INCLUDE files
	-"F;FORCE		/FORCE processor switches
	-" ;CHRLP
	-211;CHRLP		/Ignore leading spaces and tabs
	0

/Copy the rest of a line to the output file

NEWLIN,	JMS I	[RESTC		/Get first character from save buffer
	SNA			/Skip if not end of list
	JMS	MOVEND		/Move the end of the line
	JMS I	[PUTCHR		/Send character to output file
	JMP	NEWLIN		/Get another

/Routine to move end of line over. A JMS to the routine which
/gets rid of the character follows the call. The JMS must be via
/page 0. STA CLL RTL in place of a SUB call will purge the line.

MOVEND,	0
	TAD I	MOVEND		/Load JMS
	DCA	SUBCAL		/Set call below

MOVELP,	TAD	CHAR		/Load last character output
	TAD	(-212		/Is it a LF code
	SNA CLA			/Skip if it is not
	JMP	FIRSTC		/Re-enter loop above
	JMS I	[GETCHR		/Get the next character
SUBCAL,	JMS I	[PUTCHR		/Move it
	JMP	MOVELP		/Or loop here

/Here to PURGE the line. Note, we load -3 into the AC so that when
/CHAR is added, a CR code looks like a LF code. This is because
/MOVEND tests for the LF that PUTCHR would have output when it
/got a CR code.

PURGE,	JMS	MOVEND		/Call MOVEND to purge the line
	STA CLL RTL		/AC=-3 so CR becomes LF

/Test for keyword. We do not allow any separator characters
/to be embedded in the keywords here. Even though this is contrary
/to Fortran convention in which spaces and tabs have only positional
/significance. It is otherwise too difficult to determine whether
/there the KEYWORD is being used in another context, which we
/would like to allow.

SYMB,	0
	TAD I	SYMB		/Load address of keyword
	ISZ	SYMB		/Bump return
	DCA	AINDX		/Store

SYMTLP,	JMS	SAVEC		/Get char and save it
	TAD	MCR		/Subtract a CR code
	SNA CLA			/Skip if not a carriage return
	JMP	NEWLIN		/On CR, must be a new line

	TAD	CHAR		/Load it
	TAD I	AINDX		/Compare a word
	SNA			/Skip if not a match
	JMP	SYMTLP		/Loop till no match
	CIA			/Take negative
	TAD	CHAR		/And see if we tested a 0
	SZA CLA			/Skip if we did
	JMP	NEWLIN		/new line if not

/Now determine if current character is a separator character.
/The only legal characters are space and TAB. Note, that if it
/is not a separator, we won't accept the keyword.

	JMS I	[SORTJ		/Call SORTJ to test character
	-" ;SMBXIT		/Space is valid separator
	-211;SMBXIT		/Tab is valid separator
	0			/Sentinel
	JMP	NEWLIN		/Symbol did not match

/Arithmetic context can be determined by the next significant character.
/The only danger here is that the next character is on a continuation
/line. Then the previous line will be lost. What is the risk of:

/	FORCE
/     1 =SOMTIN ?

/It is my opinion that this is the users problem. If he wants to use
/a KEYWORD as a variable name, then follow it directly with some
/non-separator character. We won't bother with it here.

SMBXIT,	JMP I	SYMB		/Return, successful

/Routine to get a character, and save it in the save buffer

SAVEC,	0
	JMS I	[GETCHR
	TAD	CHAR
	DCA I	SAVPTR		/Store the character
	ISZ	SAVPTR		/Bump the pointer
	DCA I	SAVPTR		/And store a sentinel
	TAD	CHAR
	JMP I	SAVEC		/And return with the character

/Get saved characters from save buffer

RESTC,	0
	TAD I	RSTPTR		/Load the next entry
	ISZ	RSTPTR		/Bump the pointer
	SZA			/Skip if sentinel
	JMP I	RESTC		/Return with character

	TAD	(SAVEB		/Load the initial pointer
	DCA	RSTPTR		/Store it
	JMP I	RESTC		/And return with sentinel

RSTPTR,	SAVEB
SAVPTR,	SAVEB

	PAGE /3600

/Routine to get next INCLUDE entry. The INCLUDE files are first
/stacked as they are received, then popped off and stored on the
/file Q. This 2 step operation is to keep the files in the right
/order. The next 2 routines are used to STACK/UNSTACK the files.

POP2,	0
	TAD	ISTKP		/Load include stack pointer
	TAD	(-ISTACK	/Subtract stack start
	SNA			/Skip if stack not empty
	JMP	CTRLZ		/Continue processing
	TAD	(ISTACK-1	/Decrement the pointer
	DCA	ISTKP		/Store it
	TAD I	ISTKP		/Load the entry
	JMP I	POP2		/And return

/Routine to store next include entry

PUSH2,	0
	DCA I	ISTKP		/Store the stack entry
	TAD	ISTKP		/Load the stack pointer
	TAD	(-ISTACK-ISTKSZ	/See if at the end
	SNA CLA			/Skip if not
STKER2,	JMS	ERROR		/Stack overflow
	ISZ	ISTKP		/Bump the pointer
	JMP I	PUSH2		/And return

ISTKP,	ISTACK			/Initial stack pointer

/Routine to get file read parameters from the Q. These next 2 routines
/are used to complete the next 1/2 of the operation described above
/(See comments at POP2)

POP,	0
	TAD	STKPTR		/Load stack pointer
	TAD	(-STACK		/Subtract the start
	SNA			/Skip if not empty
	JMP	ENDFIL		/All finished at last
	TAD	(STACK-1	/Decrement the pointer
	DCA	STKPTR		/And store it

	TAD I	STKPTR		/Load an entry from the stack
	JMP I	POP		/And return

STKPTR,	STACK			/Stack pointer

/Routine to store file read parameters on the Q

PUSH,	0
	DCA I	STKPTR		/Store the stack entry
	TAD	STKPTR		/Load the stack pointer
	TAD	(-STACK-STKSIZ	/See if at the end
	SNA CLA			/Skip if not
STKERR,	JMS	ERROR		/Stack overflow
	ISZ	STKPTR		/Bump the pointer
	JMP I	PUSH		/And return

/Here at end of last input file. Output the ^Z. We must be careful
/that this is not the first or second character of a new output
/buffer. PUTCHR does not bump the output buffer pointer until the
/third character of an OS-8 output group. We can verify this by
/examining the co-routine address in PUTCHR. If it points to
/WCH1 then we are done. Note that the call to WRCHR is a NOP if
/the buffer is empty.

ENDFIL,	TAD	(232		/Load an ^Z
	JMS I	[PUTCHR		/Output it
	DCA	CHAR		/So we don't output a lot of ^Z's
	TAD	WREXIT		/Load co-routine address
	TAD	(-WCH1		/OS-8 group complete?
	SZA CLA			/Skip if it is
	JMP	ENDFIL+1	/Else continue
	JMS	WRBUF		/Write partial output buffer

	CIF 10
	CLA IAC			/Set output device number
	JMS I	[USR		/Call to close output file
	4			/Close function
	FRTNTM
RELBLK,	0			/File length
CLSERR,	JMS	ERROR		/Error closing the file

	CDF 10			/Set field for Option words
	TAD I	(OPTION+2	/Load "/3" option
	AND	(100		/Save it
	CDF 0
	SZA CLA			/Skip if not set
	JMP	P3CALL		/Only call pass 3 if set

	CLA IAC			/Set SYS
CHNXIT,	CIF 10
	JMS I	[USR		/Call USR
CHNFUN,	2			/Lookup a file
	F4P1			/File name pointer
	0			/Length in here
F4ERR,	JMS	ERROR		/can't find pass 1 of F4!

	CLA STL IAC RTL		/AC=6
	DCA	CHNFUN		/Set chain function

/	JMS I	[PRINT		/Print .R F4P1
/	F4NAM
	JMP	CHNXIT		/And exit

/F4NAM,	TEXT *^[R [F4[P1^%*

F4P1,	FILENAME F4P1.SV	/For compilation
FRTNTM,	FILENAME FORTRN.TM	/Output file

MSSG01,	TEXT *^[ERROR LOADING INPUT HANDLER^%*

	PAGE /4000

/Read a character from the input file

GETCHR,	0

NXTCHR,	JMP I	.+1		/Get next character
COEXIT,	CHAR1			/First set to read buffer

	AND	[177		/Strip parity and other junk
	SNA
	JMP	NXTCHR		/Remove nulls
	TAD	(-"a+200	/Subtract "parity"less "a"
	CLL			/Clear the link
	TAD	("a-"z-1	/Set the link if not "a"-"z"
	SNL			/Skip if not "a"-"z"
	TAD	(-40		/Fold lower case to upper case
	TAD	("z+1		/Fix subtractions

	JMS I	[SORTJ		/Sort and jump
	-211;TAB		/TAB: Adjust Col. #
	-215;ENDLIN		/CR:End of line
MCTZ,	-232;CTZX		/End of file
	-212;NXTCHR		/Line feed, ignore it

	ISZ	COLUMN		/Bump Col. number
GCXIT,	JMP I	GETCHR		/Return with character in CHAR

ENDLIN,	DCA	COLUMN		/Zero col. number
	JMP I	GETCHR		/Exit

CTZX,	TAD	COLUMN		/Is COL.=0
	SNA CLA			/Skip if it is not
	JMP	CTRLZ		/Call "^Z" processor

/If the last line did not end with a CR code, then return a
/CRLF sequence before calling "^Z". This is to insure that there
/are no pending operations left hanging around.

	TAD	[215		/Load a CR character
	JMS	COEXIT		/Return a CR on ^Z

/Here when end of file detected. Move up one level.
/Note that when we call the stacked service address,
/it is assumed that there are no pre-existing pending
/operations. That last CR we returned should have done
/this.

CTRLZ,	JMS I	[POP		/Pop off the file block
	DCA	INBLK		/Store it in input routine
	JMS I	[POP		/Pop off the co-routine address
	DCA	COEXIT		/Reset it
	JMS I	[POP		/Pop off character count
	DCA	CHARCT		/Reset it
	JMS I	[POP		/Pop off the character pointer
	DCA	IBPTR		/Store the buffer pointer
	JMS I	[POP		/Pop off the saved character TEMP
	DCA	CHAR3		/Store it
	JMS I	[POP		/Pop off the device number
	JMS	HNDIN		/Call to load the handler

	JMS	READ		/Read the current block back in
	JMS I	[POP
ENDPND,	DCA	TEMP		/Store the address
	JMP I	TEMP		/And continue at service address

TAB,	TAD	COLUMN		/Load col. #
	TAD	(10		/Next tab stop
	AND	(7770		/Strip off partial tab
	DCA	COLUMN		/Pop into column
	JMP I	GETCHR		/Return with it

/Sequential routines to do OS8 unpacking

CHAR1,	TAD I	IBPTR		/Get word from input buffer
	AND	[7400		/Save high bytes
	RTR CLL			/Move to byte boundary
	DCA	CHAR3		/Save it for now
	TAD I	IBPTR		/Load same word again
	JMS	COEXIT		/return with first character

	ISZ	IBPTR		/Bump pointer
	TAD I	IBPTR		/Load next word
	JMS	COEXIT		/Return with second character

	TAD I	IBPTR		/Load the second word again
	ISZ	IBPTR		/Bump the pointer
	AND	[7400		/Strip the garbage
	BSW			/Align on lower byte boundary
	TAD	CHAR3		/Add on pending character half
	RTR CLL			/Move down to bottom of AC
	JMS	COEXIT		/Return with character 3

	ISZ	CHARCT		/Bump character count
	JMP	CHAR1		/Get next character

/Here to read in next buffer. Note that the input block number is
/bumped before the read. This is because we want to stack the
/correct block number if we re-route input with the INCLUDE
/command. This is safe for the initial read on the file
/because all file requests are popped off the stack as if a
/control Z were encountered, which performs the initial read to get
/the correct blocks back in memory.

RDBUFF,	TAD	INBLK		/Load block address
	TAD	(BSIZE		/Add blocks per buffer load
	DCA	INBLK		/Store it back
	JMS	READ		/Call input handler
	JMS	RDSETP		/Set pointers
	JMP	CHAR1		/Back to get first character

RDSETP,	0
	TAD	IBADR		/Load input buffer address
	DCA	IBPTR		/Store buffer pointer
	TAD	INFUN		/Load input function word
	CIA			/Neg. is # of double words
	DCA	CHARCT		/Store character count
	JMP I	RDSETP		/Return

CHAR3,	0
IBPTR,	INBUF			/Initially set to input buffer
CHARCT,	-200^BSIZE
TABCT,	0

READ,	0
	JMS I	INPUT		/Call input handler
INFUN,	200^BSIZE		/Initial function word
IBADR,	INBUF			/address of input buffer
INBLK,	0			/Input block number
EROR08,	JMS	ERROR		/Error processor
	JMP I	READ		/Return

/Routine to stack a file spec.

STKFIL,	0
	JMS I	[PUSH		/Stack the service address
	TAD	INDEV		/Load the input device number
	JMS I	[PUSH		/Store it too
	TAD	CHAR3		/Load the pending character
	JMS I	[PUSH		/Save character counter
	TAD	IBPTR		/Load input buffer pointer
	JMS I	[PUSH
	TAD	CHARCT
	JMS I	[PUSH
	TAD	COEXIT		/load co-routine address
	JMS I	[PUSH		/Save it
	TAD	INBLK		/And the input block number
	JMS I	[PUSH
	JMP I	STKFIL		/And return

	PAGE /4200

/Routine to write to output buffer in OS8 format

PUTCHR,	0
	SMA SZA			/Skip if neg or zero
	DCA	CHAR		/Set character if it's in AC
	TAD	CHAR		/Load input character
	JMP I	.+1		/Call co-routine

WREXIT,	WCH1			/Char 1 to start
	TAD	CHAR		/Get next character ready
	TAD	MCR		/Was it a CR code
	SZA CLA			/Skip if it was
	JMP I	PUTCHR		/Or return already
	TAD	[212		/Load a line feed
	JMP	PUTCHR+1	/And output it

/Here are the OS8 packing routines

	JMS	WREXIT		/Exit
WCH1,	DCA I	OBPTR		/Store character for now
	JMS	WREXIT		/And exit

	DCA	CHAR2		/Store second character
	JMS	WREXIT		/And exit

	RTL CLL			/Move middle to byte boundary
	MQL;MQA			/Store in MQ
	CLL RTL			/Move to upper bits
	AND	[7400		/Strip off lower 1/2
	TAD I	OBPTR		/Complete word 1
	DCA I	OBPTR
	ISZ	OBPTR		/Increment pointer now
	MQA			/Load back aligned word
	BSW			/Lower 1/2 to upper bits
	AND	[7400		/Strip off junk
	TAD	CHAR2		/Load on second character
	DCA I	OBPTR		/Store it
	ISZ	OBPTR		/Second bump
	ISZ	OUTCNT		/Bump word count
	JMP	WCH1-1		/Exit if buffer not full

	JMS	WRBUF		/Write output buffer

	JMP	WCH1-1		/And exit

/Routine to write the output buffer. No operation takes place if the
/buffer is empty. Routine may be called at file close to write a
/partial buffer with any output buffer count. A full block will be
/written in any case.

WRBUF,	0
	TAD	OUTCNT		/Load output count (Double wds. rem.)
	CIA			/Make count positive
	AND	(7600		/remove partial block
	CIA			/make whole blocks negative again
	TAD	(200^BSIZE	/Subtract from buffer size
	SNA			/Skip if anything in buffer
	JMP I	WRBUF		/Empty: just return
	DCA	OUTTMP		/Save pages in I/O operation
	CLA STL RAR		/AC=4000: write function, field 0
	TAD	OUTTMP		/Add in page count
	DCA	OUTF		/Store function word in handler call

	TAD	OUTBLK		/Load file start block
	TAD	RELBLK		/Add relative block
	DCA	HNDBLK		/to make up this disk block

/Now, compute next relative block. We have already aligned the count
/to a block boundary above, so there is no need to check it here.

	TAD	OUTTMP		/Load number of output pages
	BSW			/Move to low bits
	CLL RAR			/Divide by 2 to make blocks
	TAD	RELBLK		/Add to relative block #
	DCA	RELBLK		/Store away current file length

	CLL			/Now prepare to see if
	TAD	OUTLEN		/file will fit in allowed length
	TAD	RELBLK		/See if room for write
	SZL CLA			/Skip if room for output file
EROR10,	JMS	ERROR		/FILE OVERFLOW

	JMS I	(7607		/Call SYS (output handler)
OUTF,	0
	OUTBUF			/Address of output buffer
HNDBLK,	.-.			/Address of output block
EROR09,	JMS	ERROR		/Output error


/Now reset buffer pointers and return

	TAD	(-200^BSIZE
	DCA	OUTCNT		/Set output word count
	TAD	(OUTBUF
	DCA	OBPTR		/Set output buffer pointer
	JMP I	WRBUF		/Return

OUTLEN,	0
OUTBLK,	0
OUTTMP,	0
OUTCNT,	-200^BSIZE
CHAR2,	0

PACK,	0
	AND	[77		/Remove "8-bit"ness
	DCA	TEMP2		/Save 6-bit character

	TAD I	PACK		/Load the counter
	ISZ I	PACK		/Bump the counter for next time
	CLL RAR			/Divide by 2, save even/odd in link
	ISZ	PACK		/Point to buffer address
	TAD I	PACK		/Offset into buffer
	DCA	TEMP		/save the pointer for indirect reference

/First test for string length. Since the lower byte gets filled
/second, we neet only test for it's being 0. Note that the
/first word after the message buffer must have the lower byte
/non-zero. This criterion will be met by almost any instruction
/or constant.

	TAD I	TEMP		/Load the word there
	AND	[77		/Remove any upper byte
	SZA CLA			/Better be a zero in the lower byte
STRERR,	JMS	ERROR		/Buffer filled with too many characters

	TAD	TEMP2		/Load the new byte
	SNL			/Skip if lower byte
	BSW			/Rearrange it
	TAD I	TEMP		/Hook it on to the other byte
	DCA I	TEMP		/And replace the 2 characters
	ISZ	PACK		/Bump past the buffer address
	JMP I	PACK		/And return

MSSG08,	TEXT *^[INPUT READ ERROR^%*

	PAGE /4400

/Here for the INCLUDE command. First we decode and lookup all the
/include files. The device and block of these files are stacked
/in a LIFO buffer till later. After all of the files on the include
/line are looked up, each is then popped off the stack and put on
/the input file Q, now in the order in which they appeared on the
/INCLUDE line. On exit, the TOP entry of this Q is used to set up
/the input routines and we re-enter the character fetch loop.
/Note, that the first file we must put on the Q is the current
/input file.

INCLUD,	JMS	SYMB		/Call SYMB to see if "INCLUDE"
	NCLUDE-1

	TAD	(NCLRTN		/Load include service address
	JMS	STKFIL		/Now stack the current file

NXTFIL,	DCA	EXTFLG		/Reset the flags
	DCA	DEVFLG		/for extension and device

GFILE,	DCA	NAMBUF		/Zero the input name buffer
	DCA	NAMBUF+1
	DCA	NAMBUF+2
GEXT,	DCA	SIXCNT		/Zero or set the counter
	DCA	NAMBUF+3	/Zero extension buffer

FILELP,	JMS I	[SIGNIF		/Get next significant character
	JMP	NDINCL		/No next character, end command

	JMS I	[SORTJ		/See what it is
	-":;SETDEV		/Device spec
	-".;SETEXT		/Set the extension
	-",;LKPFIL		/Look up the file
	0			/Sentinel

	TAD	CHAR
	JMS	PACK		/Pack into 6-bit
SIXCNT,	0			/Six bit counter
XNAMBF,	NAMBUF			/and buffer
	JMP	FILELP		/Loop

SETDEV,	TAD	SIXCNT		/Load the character count
	TAD	DEVFLG		/Add the device flag
	CLL			/Zap the link
	TAD	(-5		/Is it legal name
	SZL CLA			/Skip if link is zero
BADDEV,	JMS	ERROR
	TAD	NAMBUF
	DCA	DEVBUF
	TAD	NAMBUF+1
	DCA	DEVBUF+1	/Move the device name
	CLA IAC RTL		/AC=4
	DCA	DEVFLG		/Force error on next colon
	JMP	GFILE

/Here after a "." See if we've been here before. It's an error
/if we have. Then make sure that the name is a legal length.
/Finally, set flag to force error on a second "."

SETEXT,	TAD	SIXCNT		/Load the character count
	TAD	EXTFLG		/Add extension flag
	CLL
	TAD	(-7		/See if legal name
	SZL CLA
BADEXT,	JMS	ERROR		/Error on extension
	CLA CLL STL IAC RTL	/AC=6
	DCA	EXTFLG		/Force error if 2 "."'s
	CLA CLL STL IAC RTL	/AC=6 to indicate 6 characters
	JMP	GEXT		/Get the extension

/Here to look up the file. Enter at LKPFIL if the file name
/ended with a comma. Enter at NDINCL if the file ended with
/a C.R. code, and there are no more continuation lines.

NDINCL,	TAD	NAMBUF		/Load first 2 characters of file name
	SNA CLA			/Skip if non-zero
	JMP	INCXIT		/Exit include statement

	CLA CMA
LKPFIL,	DCA	MULTFL		/Set multiple file switch

	TAD	EXTFLG		/Was an extension specified
	SZA CLA			/Skip if it was not
	JMP	EXTFIX		/Then use specified extension
	TAD	(0624		/Load ".FT"
	DCA	NAMBUF+3	/Set the extension to ".FT"

EXTFIX,	/JMS	PNAME		/Print the file name

	TAD	DEVFLG		/Was a device specified
	SZA CLA			/Skip if it was not
RTRYDF,	JMS	HNDIN		/Call to load handler

	TAD	XNAMBF		/Load address of name buffer
	DCA	BLOCK		/Set up name buffer

	CIF 10
	TAD	INDEV		/Load the device number
	JMS I	[USR		/call USR
	2			/to lookup our file
BLOCK,	NAMBUF			/Address of name
LENGTH,	0			/returned length
	JMP	TRYDEF		/Try the default devices then

	TAD	BLOCK
	JMS I	[PUSH2		/Set the input block

	TAD	INDEV
	JMS I	[PUSH2		/Store it

	ISZ	MULTFL		/Skip if last file
	JMP	NXTFIL		/Next file then

INCXIT,	JMS	RDSETP		/Set the READ pointers
	TAD	(CHAR1		/Load co-routine link for new buffer
	DCA	COEXIT		/Set co-routine address

/Loop here to move input file parameters onto the parameter stack.

SFLP,	JMS I	[POP2		/Get the device number
	DCA	INDEV		/Set the input device
	JMS I	[POP2		/Get the block
	DCA	INBLK		/Store it
	TAD	(FIRSTC		/Load file service address
	JMS	STKFIL		/Stack the file
	JMP	SFLP		/And loop

/Here to try default devices for LOOKUPS

TRYDEF,	JMP I	.+1		/Start sequence of default devices
DEFX,	DEF1			/First default device
	JMP	RTRYDF		/Try again

DEF1,	TAD	DEVFLG		/Load the device specified flag
	SZA CLA			/Skip if no device
LKPERR,	JMS	ERROR		/Error, can't find file

	CLA CMA CLL RAL		/AC=-2, link=1
	TAD	INDEV		/Add the input device, link=1 if SYS
	SNA CLA			/If it was not DSK, skip
	JMP	TRYSYS		/Try SYS if it was
	RAR			/Save link in case SYS
	IAC RAL			/AC=2, link=1 if SYS
	SZL			/Skip if it was not SYS
	JMP	TRYDSK		/So try DSK, not followed by SYS
	JMS	DEFX		/Return to try DSK, followed by SYS

TRYSYS,	CLA IAC			/Set SYS
TRYDSK,	ISZ	DEVFLG		/Force an error if failure
	JMS	DEFX		/Try another lookup, resetting vector
	JMP	DEF1		/Return to force error

	PAGE /4600

/Return here after INCLUDE files we put on the Q have been processed.
/Since we stacked the original input file before we read the
/INCLUDE line(s), we must now purge them from the input file.

/SIGNIF will take RETURN+1 until there are no more continuation
/lines. Then, goto CHKLIN to see if the next line is another
/INCLUDE statement.

NCLRTN,	DCA I	(SAVEB		/Things may be hanging around in SAVEB
	JMS I	[SIGNIF		/Get next sig. character
	JMP	CHKLIN		/All done, move the next line over
	CLA CLL			/Zap the character in the AC
	JMP	.-3		/Next character

/Routine to load a handler. Note that all handlers load
/into the same 2 pages. This presents a peculiar problem
/because of the way the USR works. Thus, if we load handler
/"A" first, then at a later time load handler "B", which is
/not co-resident with "A" the USR will assume that both are
/resident, since it does not test for handler overlay when
/loading handlers. The problem is that when we are finished
/with handler "B", and call USR to load "A" again, the USR,
/thinking that "A" is resident, will simply return the entry
/point, loading nothing, and "B" will still be resident!

HNDIN,	0
	SZA			/Skip if DN not in AC
	JMP	DVINAC

	CIF 10
	JMS I	[USR		/call USR
	12			/to inquire about the handler
DEVBUF,	0			/By name
DN,	0			/Device number in here
TENT,	0			/Entry point in here
	JMP	BADDEV		/Illegal device specified

	TAD	TENT		/Load the handler entry point
CHKHND,	SZA			/Skip if not loaded
	JMP	HNDLDD		/Handler loaded

	CIF 10
	JMS I	[USR		/Call USR reset function
	13			/to dump the old handlers
	0			/Preserving our tentative file

	TAD	(INHND+1	/Load the handler page
	DCA	FARG		/Store the fetch arg

	TAD	DN		/Load the device number
	CIF 10			/Set field 1
	JMS I	[USR		/Call USR, to load
	1			/the handler
FARG,	0			/Handler page address
FETERR,	JMS	ERROR		/Error loading handler
	TAD	FARG		/Load the entry point

HNDLDD,	DCA	INPUT		/Store the entry point
	TAD	DN
	AND	[17		/Remove file length
	DCA	INDEV		/Store the input device number
	JMP I	HNDIN		/And return

/Here if device number is in AC on arrival. Note, that if the
/device is SYS, the INQUIRE will always return an entry point.
/This avoids the removal of the other handler from memory,
/thus saving a re-read later.

DVINAC,	DCA	DN		/Save device number
	TAD	DN		/Reload the device number
	CIF 10
	JMS I	[USR		/Call USR
	12			/to inquire about handler
INQARG,	0			/Entry point gets returned here
	JMP	BADDEV		/Illegal device number
	TAD	INQARG		/Load the entry point
	JMP	CHKHND		/Go check handler residency

/Store the filename in message and print it

PNAME,	0
	TAD	NAMBUF		/Load the first 2 characters
	DCA	PNAME0
	TAD	NAMBUF+1
	DCA	PNAME1
	TAD	NAMBUF+2
	DCA	PNAME2
	TAD	NAMBUF+3	/Load the extension
	DCA	PNAME3		/Store it

	JMS I	[PRINT
	INCFM			/Include file message
	JMP I	PNAME		/And return

INCFM,	TEXT *^[INCLUDING [*
PNAME0,	0
PNAME1,	0
PNAME2,	0
	5600+UCFCHR
PNAME3,	0			/Extension
	SNTCHR

	PAGE /5000

/Here on FORCE command. First be sure the FORCE is with us.
/SYMB will verify that command ends with a separator.
/Get next significant character to see what to do. It's
/an error of there is none, or if it is illegal.

FORCE,	JMS I	[SYMB		/Call SYMBOL routine
	ORCE-1			/Address of SYMBOL

/Call to get nex significant character. It must be there or we've
/erred. Note that if we find a "," below, we return here, expecting
/the next character. It is still an error if it's not there.

FRCLP,	JMS I	[SIGNIF		/Get next character
FRCERR,	JMS I	[ERROR		/Call error processor if none

CHKCHR,	TAD	(-"A		/Make "A"=0
	STL			/Set the link
	TAD	("A-"Z-1	/Is it "A" through "Z"
	SZL			/Skip if not A-Z
	JMP	ATOZ		/Character is A-Z

	TAD	("Z+1-"0	/Make "0" zero
	CLL			/Zap the link
ATOZ,	TAD	("0-"9-1	/Leaves A>Z,0>9=-42>-1
	SZL			/Skip if it is Alphabetic or digit
	JMP	FRCERR		/Force syntax error
	TAD	(44		/Convert to relative bit number

SUBTR,	TAD	(-14		/Subtract 12 bits
	SPA			/Skip if positive
	JMP	GOTBIT		/Got the bit number
	ISZ	OPTL		/Bump the option word location
	JMP	SUBTR		/Subtract again

GOTBIT,	DCA	TEMP		/Store the bit count
	CLA STL			/Set the link for rotate loop

	RAL			/Rotate once
	ISZ	TEMP		/Count it
	JMP	.-2		/Repeat till count is up
	DCA	TEMP		/Save the rotated bit

	TAD	TEMP
	CDF 10			/Set option field
	AND I	OPTL		/Get the bit to toggle
	SNA CLA			/Skip if already set
	TAD	TEMP		/Set the new bit
	TAD I	OPTL		/by adding to option word
	DCA I	OPTL		/and store the result
	CDF 0			/Reset this field

	TAD	(7643		/Load address
	DCA	OPTL		/to reset option word pointer

	TAD	CHAR		/Save a copy of CHAR
	DCA	TEMP		/because PRINT destroys it
/	JMS I	[PRINT		/"Forcing /"
/	FORMSG			/Message address

/	TAD	TEMP
/	JMS	TYPE		/Print the character

/Look for a comma here. If there is no sig. character, we've entered
/the next non-continuation line and must go look for another KEYWORD.
/If there is a character, it must be a "," or there's an error.
/When we find a comma, go get the next option character.

	JMS I	[SIGNIF		/Look for a , or line terminator
	JMP	CHKLIN		/All done if no character
	TAD	(-",
	SZA CLA			/Skip if a comma
	JMP	FRCERR		/Error if not
	JMP	FRCLP		/Get next spec.

OPTL,	7643			/Option word pointer

ORCE,	-"O;-"R;-"C;-"E;0	/Keyword character string.

MSSG07,	TEXT *^[SYNTAX ERROR IN [F[O[R[C[E STATEMENT%*
FORMSG,	TEXT *^[FORCING /%*
/RPASS3,	TEXT *^.[R [P[A[S[S3^%*

	PAGE /5200

/Routine to SORT input character and vector to an address
/on a match. List of character address pairs follows the
/call. List terminator may be any positive number, and
/will be executed upon returning. This means TAD, ISZ
/and DCA are OK as terminators, as are any small
/constants which look like an AND instruction.

SORTJ,	0
	SZA			/Skip if character already in CHAR
	DCA	CHAR		/Store character

SJLOOP,	TAD I	SORTJ		/Load first test
	SMA			/Skip if not a termiator
	JMP	SJEXIT		/return
	ISZ	SORTJ		/Bump return
	TAD	CHAR		/See if match
	SNA CLA			/Skip if not
	JMP	JUMP		/Take JUMP pathway
	ISZ	SORTJ		/Ignore address word
	JMP	SJLOOP		/Loop till terminator found

JUMP,	TAD I	SORTJ		/Load address
	DCA	SORTJ		/Save it
SJEXIT,	CLA CLL			/Clear link (and AC)
	JMP I	SORTJ		/Take address branch


	SNTCHR="%&77		/Value of sentinel character
	CLFCHR="^&77		/Embedded CRLF character
	UCFCHR="[&77		/Uppercase flag character

/Six bit printing routine. All characters are assumed to be lower
/case unless preceeded by the upper case flag character.

PRINT,	0			/Routine to unpack and print 6-bit ASCII
	SZA			/Skip if AC=0
	JMP	ADINAC		/Address in AC
	TAD I	PRINT		/Load address of message
	ISZ	PRINT		/Bump return address
ADINAC,	DCA	PPTR		/Save pointer to message

/Flow through to initialize co-routine linkage.

PRINT1,	JMS	PSUB		/Go reset co-routine linkage
	BSW			/Move upper byte down
	JMS	PSUB		/Set new co-routine link

OUTXIT,	ISZ	PPTR		/Bump pointer after byte 2
	JMP	PRINT1		/Loop back for first character

PCRLF,	TAD	[215		/Do a CRLF here
	JMS	TYPE
	TAD	[212
	JMS	TYPE

PBACK,	TAD I	PPTR		/Load a word of messsage
	JMP I	PSUB		/Call co-routine

PSUB,	0			/Returns using JMS to set co-routine
	AND	[77		/Strip off unused byte
	SNA			/Skip if not null character
	JMP	PBACK		/Ignore nulls.

	JMS	SORTJ		/Sort and JUMP
	-SNTCHR;PREXIT		/Return on sentinel
	-CLFCHR;PCRLF		/Test for imbedded CRLF
	-UCFCHR;SETUCF		/Look for upper case flag

	TAD	CHAR		/Reload character
	TAD	(-40		/Make non-alpha characters negative
	SPA			/Skip if Non-alpha
	TAD	UCF		/Add 100 for upper case, 140 for lower
	TAD	[240		/Convert all to 8-bit

	JMS	TYPE		/Type the character

SETLC,	TAD	LOWER		/Load 1st. 1/2 of UCF if lower case
SETUCF,	TAD	(100		/Load only 2nd. half for upper case
	DCA	UCF		/Save result as upper case flag
	JMP	PBACK		/Back for more characters

PREXIT,	JMP I	PRINT

UCF,	140			/Value of flag is for lower case
LOWER,	40			/Set to 0 if upper case only

/Return next significant character.

SIGNIF,	0
IGNR2,	JMS I	[GETCHR		/Get a character
	JMS I	[SORTJ
	-211;IGNR2		/Ignore TABS
	-" ;IGNR2		/and spaces
	-215;SKPCHR		/Go get first character after CR

	ISZ	SIGNIF		/Take non-error return
	TAD	CHAR		/Load significant character
	JMP I	SIGNIF		/And return

SKPCHR,	JMS	PEND		/Call FIRSTC
	JMP	GOTNS		/No signif. character
	DCA	PEND		/Zero pending operation
	JMP	IGNR2		/Go test next character

GOTNS,	DCA	PEND		/Zero pending operation
	JMP I	SIGNIF		/Return, empty handed

/Error processing routine

ERROR,	0
	CLA CMA			/AC=-1
	TAD	ERROR		/Load error address
	TAD I	ENUM		/Compare to list
	SNA CLA			/Skip if no match
	JMP	GOTERR		/Found it

	ISZ	ENUM		/Ignore unused message address
	JMP	ERROR+1		/Try again

GOTERR,	TAD I	ENUM		/Load message address
	JMS	PRINT		/Print it
	JMP I	(7605		/return to monitor, saving core.

ELST,	-FETERR;MSSG01		/Output handler
	-OFERR;MSSG04		/Open error
	-CLSERR;MSSG05		/Close error
	-EROR08;MSSG08		/Read error
	-EROR09;MSSG09		/Write error
	-EROR10;MSSG10		/File overflow
	-NOINF;MSSG12		/No input file
	-STKER2;MSSG02		/Include stack overflow
	-STKERR;MSSG06		/Param stack overflow
	-FRCERR;MSSG07		/Syntax error in FORCE command
	-STRERR;MSSG11		/Too many characters in file name
	-LKPERR;MSSG13		/Can't find include file
	-BADEXT;MSSG14		/Illegal extension
	-BADDEV;MSSG15		/illegal device spec.
	-F4ERR;MSSG03		/can't find F4 pass 1
	-NOPAS3;NP3ERR		/No PASS3.SV
	-NOLPT;NLPTER		/No LPT:
	-SYRDER;P3RDER		/Error reading PASS3
	0			/Sentinel

	PAGE /5400

NCLUDE,	-"N;-"C;-"L;-"U;-"D;-"E;0

MSSG02,	TEXT *^[INCLUDE STACK OVERFLOW^%*
MSSG03,	TEXT *^[CAN'T FIND [F[O[R[T[R[A[N PASS 1!^%*
MSSG05,	TEXT *^[ERROR CLOSING [F[O[R[T[R[N.[T[M^%*
MSSG06,	TEXT *^[POINTER STACK OVERFLOW^%*
MSSG09,	TEXT *^[OUTPUT WRITE ERROR^%*
MSSG10,	TEXT *^[OUTPUT FILE OVERFLOW^%*
MSSG11,	TEXT *^[TOO MANY CHARACTERS IN [I[N[C[L[U[D[E FILENAME^%*
MSSG13,	TEXT *^[CAN'T FIND [I[N[C[L[U[D[E FILE^%*
MSSG14,	TEXT *^[BAD EXTENSION IN [I[N[C[L[U[D[E FILE^%*
MSSG15,	TEXT *^[BAD DEVICE IN [I[N[C[L[U[D[E FILE^%*

	DECIMAL
SAVEB,	ZBLOCK 72		/72 character save buffer
	OCTAL

	PAGE

STACK,	*.+STKSIZ
ISTACK,	*.+ISTKSZ

/It's an error if the code causes the stacks to pass address 7200
/which would cause a 2 page handler to overwrite the system
/handler. Either the code must be repacked, or the stack sizes
/must be adjusted.

	IFNZRO .-7200 <****CHANGE STACK SIZE****>

INHND=.				/Room for 2 page handler

/Page 0
	*10
AINDX,	0
ENUM,	ELST-1

	*20
OBPTR,	OUTBUF			/Output buffer pointer
INDEV,	0			/Input device number
CHAR,	0			/Current input character
PPTR,	0			/Print routine pointer
COLUMN,	0			/Screen col. (for TAB expansion)
INPUT,	0			/Input handler entry point
TEMP,	0
TEMP2,	0
DEVFLG,	0
EXTFLG,	0
MULTFL,	0
NAMBUF,	ZBLOCK 4
MCR,	-215

/Print a character to TTY

TYPE,	0
	TSF
	JMP	.-1
	TLS
	CLA CLL
	JMP I	TYPE

	PAGE /200		/Pass 3 call must be on page 200

/PROGRAM FLIST.PA
/Redesigned to run in F4META
/"/E" bug fixed.

	JMP FILSET		/Monitor and
	JMP START		/Chain entry

P3CALL,	CLA IAC			/AC=1/for SYS
	CIF 10			/Set field 1 for USR call
	JMS I	[USR		/Call USR
	2			/To look up a file 
P3REC,	P3NAM			/Address of file name;Start block
	0			/Arg2=Length
NOPAS3,	JMS I	[ERROR		/Error if no PASS3.SV

	CDF 10			/Set field 1
	TAD I	(OPTION		/Load "/E
	AND	(200		/Remove the bit
	SNA CLA 		/Skip if it was set
	DCA I	(5000		/Otherwise clear error table

	TAD	(OPTION-1	/Load address of option words
	DCA	AINDX		/Store in auto index
	CLA CLL CML RAR		/Load option "A"
	DCA I	AINDX		/Store "A" option
	DCA I	AINDX		/And zero all others
	DCA I	AINDX

/Now decide what to do. If there is a second output file, use it.
/If not, then move first output file over. If there is no first
/output file use LPT.

	TAD I	(FILE2		/Load file 2 device number
	SZA CLA			/Skip if no file there
	JMP	CHKEX		/Else just check extension

	TAD	(FILE2-1	/Load start of 2nd output file
	DCA	AINDX		/into autoindex

	TAD I	(FILE1		/Load first output file D.N.
	SNA CLA			/Skip if specified
	JMP	USELPT		/No output file, use LPT

MFNLP,	TAD I	(FILE1		/Load first output file
	DCA I	AINDX		/and make it the second
	DCA I	(FILE1		/since PASS3 expects ".LS" there
	ISZ	(FILE1		/Bump pointer
	ISZ	(-5		/Bump count
	JMP	MFNLP		/And loop

/Here to check for file extension. If there is none, then install
/".LS"

CHKEX,	TAD I	(FILE2+4	/Load extension of 2nd file
	SZA CLA			/Skip if no extension
	JMP	GETP3		/There is one, skip ahead
	TAD	(1423		/Load ".LS"
	DCA I	(FILE2+4	/Set the extension
	JMP	GETP3		/And load pass 3

USELPT,	CDF 0			/Set field 0
	CIF 10			/Field 1 for USR call
	JMS I	[USR		/call USR
	12			/Inquire
ARGS,	DEVICE LPT		/Device LPT
	0
NOLPT,	JMS I	[ERROR		/Error if NO LPT handler

	CDF 10
	TAD	ARGS+1		/Load device number of LPT
	DCA I	AINDX		/Store as second output file
	ISZ	(-5		/And loop to
	JMP	.-2		/zero the rest

GETP3,	CDF 0			/Reset field 0
	TAD	P3REC		/Get start block of PASS 3
	IAC			/Skip header block
	DCA	P3BLK		/Store in handler call
/	JMS I	[PRINT
/	RPASS3			/Print ".R PASS3"

	JMS I	(7607		/Load PASS 3
	1600			/Read 16 pages, field 0
PASS3,	400			/Into 400 page
P3BLK,	0			/Start block
SYRDER,	JMS I	[ERROR		/Errors halt
	JMP I	PASS3		/And start pass 3

P3NAM,	FILENAME PASS3.SV

NP3ERR,	TEXT *^[P[A[S[S3.[S[V [NOT ON [S[Y[S!%*
NLPTER,	TEXT *^[NO [L[P[T HANDLER!%*
P3RDER, TEXT *^[ERROR READING [P[A[S[S3.[S[V%*