Google
 

Trailing-Edge - PDP-10 Archives - decus_20tap2_198111 - decus/20-0035/alglib.mac
There are 11 other files named alglib.mac in the archive. Click here to see a list.
	TITLE	%LOW -- ALGOLW LOW CORE TABLES -- MICHAEL GREEN
; Modified by Paul T. Robinson, Wesleyan Univ. for
; DECUS conversion to DEC-20. Edits usually in lower case.
	ENTRY	%SREG,%LREG,%NREG,%ANREG,%ALREG,%AVIOB,%UUO
	ENTRY	%IOOPN,%IOLEB,%IOBFH,%IOPRO,%IOREG,%IOSIZ,%IOEND
	ENTRY	%HDBLK,%SAVE,%PDL,%ENTRY,%STAT,%STEND,%DYNAM
	ENTRY	%ARITH,%APRSV,%ERRPT,%IOBRK,%DCSAV,%IOPP,%OPNSW
	EXTERN	%RESET

	.jb41=	41
	LOC	.jb41
	JSP	1,%RESET	;UUO HANDLER SETUP
	RELOC

%SREG:	BLOCK	^D16	;START OF REGION TABLE
%LREG:	BLOCK	^D16	;AVAILABLE LENGTH IN REGION TABLE
%NREG:	BLOCK	^D16	;NEXT AVAILABLE LOCATION IN REGION TABLE
%ALREG:	BLOCK	^D16	;ALLOCATOR AVAILABLE LENGTH IN REGION
%ANREG:	BLOCK	^D16	;ALLOCATOR NEXT AVAILABLE LOCATION

%AVIOB:	BLOCK	1	;NEXT AVAILABLE I/O REGION

%IOOPN:	BLOCK	3	;OPEN CONTROL BLOCK
%IOLEB:	BLOCK	4	;LOOKUP/ENTER CONTROL BLOCK
%IOBFH:	BLOCK	3	;BUFFER HEADER
%IOPP:	BLOCK	1	;PROJECT-PROGRAMMER NUMBER FOR CLOSE
%IOPRO:	BLOCK	1	;PROTECTION CODE FOR CLOSE ON OUTPUT FILE
%IOREG:	BLOCK	1	;INDEX TO I/O REGION
%IOBRK:	BLOCK	10	;USED BY BREAK FUNCTION
%IOSIZ=	.-%IOOPN	;SIZE OF CHANNEL CONTROL BLOCKS
	BLOCK	^D15*%IOSIZ
%IOEND=	.-1			;END OF I/O CONTROL BLOCKS

%HDBLK:	BLOCK	6	;USED BY GARBAGE COLLECTOR AND RECORD I/O

%SAVE:	BLOCK	10	;SAVE AREA FOR AC'S 0 THROUGH 7

%APRSV:	BLOCK	2	;SAVE AREA FOR APR INTERRUPTS

%ENTRY:	BLOCK	1	;0-NORMAL ENTRY, -1-ALTERNATE ENTRY TO CUSP

%PDL:	BLOCK	^D128	;PUSH DOWN LIST

%STAT:	BLOCK	1	;+0 RUNTIM AT END OF LAST ALLOC
	BLOCK	1	;+1 RUNTIM AT END OF LAST COLLE
%DYNAM:	BLOCK	1	;+2 START OF DYNAMIC STORAGE
	BLOCK	1	;+3 # TIMES ALLOC CALLED
	BLOCK	1	;+4 # TIMES COLLE CALLED
	BLOCK	1	;+5 TOTAL CORE REQUESTED
	BLOCK	1	;+6 MAX CORE REQUESTED
	BLOCK	1	;+7 CUMULATIVE AVERAGE CORE REQUESTED
	BLOCK	1	;+10 TOTAL TIME BETWEEN ALLOC CALLS
	BLOCK	1	;+11 MAX TIME BETWEEN ALLOC CALLS
	BLOCK	1	;+12 TOTAL TIME IN ALLOC
	BLOCK	1	;+13 MAX TIME IN ALLOC
	BLOCK	1	;+14 TOTAL CORE FREED BY COLLECTION
	BLOCK	1	;+15 MAX CORE FREED BY COLLECTION
	BLOCK	1	;+16 CUMULATIVE AVERAGE CORE FREED
	BLOCK	1	;+17 TOTAL TIME BETWEEN COLLE CALLS
	BLOCK	1	;+20 MAX TIME BETWEEN COLLE CALLS
	BLOCK	1	;+21 TOTAL TIME IN COLLE
	BLOCK	1	;+22 MAX TIME IN COLLE
	BLOCK	1	;+23 STARTING TIME OF RUN
	BLOCK	1	;+24 RUNTIM AT START OF RUN
	BLOCK	1	;+25 CORE REQUESTED SINCE LAST COLLE
	BLOCK	1	;+26 MAX CORE REQUESTED SINCE LAST COLLE
	BLOCK	1	;+27 CUMULATIVE AVERAGE SINCE LAST COLLE
	BLOCK	1	;+30 # TIMES ALLOC CALLED SINCE LAST COLLE
%STEND=	.-1

%ERRPT:	BLOCK	1	;USED BY %ERROR ROUTINE

%DCSAV:	BLOCK	1	;USED TO SAVE %UUO FOR CALL ON %ARITH

%UUO:	BLOCK	2	;.jb41 CONTAINS JSR %UUO

%ARITH:	BLOCK	1	;CONTROL OF FLOATING POINT UNDERFLOWS

%OPNSW:	BLOCK	10	;USED TO HOLD DTA AND MTA SWITCHES DURING OPEN

	PRGEND
	TITLE	%RESET -- ALGOLW INITIALIZATION -- MICHAEL GREEN
	HISEG
	ENTRY	%RESET
	EXTERN	%PDL,%HDBLK,%ENTRY,%ERROR,%STEND	;JOBFF,JOBREN,JOBAPR
	EXTERN	%SREG,%NREG,%AVIOB,%IOOPN,%IOLEB,%IOBFH,%IOEND,%STAT
	EXTERN	%DYNAM,%UUO,%DCSAV,%IOBRK	;JOBCNI,JOBTPC,JOBOPC,JOB41
	EXTERN	%APRSV,%UUOTB,%ARITH,%BLOCK	;JOBSYM,JOBUSY,JOBSA
	extern	.jbff,.jbren,.jbapr,.jbcni,.jbtpc,.jbopc,.jb41
	extern	.jbsym,.jbusy,.jbsa

	%T=	14
	%TB=	15
	%B=	16
	%P=	17
	ENTRY=	0
	RETURN=	1
	TEMP=	2
	TEMP2=	3
	TEMP3=	4
	ERROR=	14
	INFLG=	040000		;FLAGS IN LH OF %IOOPN
	OUTFLG=	020000
	STRFLG=	004000
	LNEFLG=	200000
	SYMPAT=	2*^D32		;ROOM FOR NEW SYMBOLS IN DDT TABLE

%RESET:	MOVEM	RETURN,%UUO	;INITIAL SETUP
	SETZB	%T,%DCSAV	;MARK NOT IN %ARITH CALLING %ARITH
	SETZB	%TB,%B		;RESET BLOCK POINTERS
	RESET			;RESET I/O AND STORAGE LIMITS
	HRREM	ENTRY,%ENTRY	;SET ENTRY CODE
	SETZM	.jbUSY		;NO GLOBAL UNDEFINED SYMBOL TABLE
	MOVE	TEMP,.jbSYM
	JUMPE	TEMP,NOSYM	;NO SYMBOLS LOADED
	HRLE	TEMP2,TEMP
	SUBM	TEMP,TEMP2	;SEE IF .jbSA IS ABOVE TABLE
	HLRZ	TEMP3,.jbSA
	CAIL	TEMP3,(TEMP2)	;IF SO, WE ALREADY MOVED IT
	JRST	NOSYM
	ADDI	TEMP3,SYMPAT
	CAIL	TEMP3,(TEMP)	;HAS IT ALREADY BEEN MOVED BY LOADER
	JRST	NOMOVE
	HRLI	TEMP3,(TEMP)	;NO, SET UP TO MOVE IT
	HRRM	TEMP3,.jbSYM
	HRLE	TEMP2,TEMP
	SUBM	TEMP3,TEMP2
	BLT	TEMP3,-1(TEMP2)
NOMOVE:	HRLM	TEMP2,.jbSA
	HRRM	TEMP2,.jbFF
NOSYM:	MOVE	%P,[IOWD ^D108,%PDL]	;SET PDL POINTER
	MOVE	[XWD 400000+INFLG+OUTFLG+STRFLG+LNEFLG,1]
	MOVEM	%IOOPN
	HRLZI	(SIXBIT/TTY/)
	MOVEM	%IOOPN+1	;INITIALIZE CHANNEL 0 - TTY
	MOVE	[XWD %IOBFH,%IOLEB]
	MOVEM	%IOOPN+2
	SETZM	%IOOPN+3	;CLEAR REST OF CONTROL BLOCKS
	MOVE	[XWD %IOOPN+3,%IOOPN+4]
	BLT	%IOEND
	SETZM	%AVIOB
	SETZM	%SREG
	MOVE	[XWD %SREG,%SREG+1]
	BLT	%SREG+5*^D16-1	;CLEAR STORAGE ALLOCATION BLOCKS
	MOVE	[XWD 000014,176400]	;INITIALIZE BREAK TABLE
	MOVEM	%IOBRK
	MOVSI	3
	MOVEM	%IOBRK+1	;IGNORE CARRIAGE RETURN
	MOVEI	3
	MOVEM	%IOBRK+6	;BREAK ON VERTICAL MOTION CHARS
	MOVEI	-1
	MOVEM	%IOBRK+7	;AND BELL AND ^Z AND ALTMODE
	OPEN	%IOOPN		;OPEN TTY - CHANNEL 0
	HALT			;FATAL ERROR IF CANNOT
	INBUF	2		;GET BUFFER SPACE
	OUTBUF	2
	HRRZ	.jbFF		;GET NEW STORAGE LIMIT
	MOVEM	%SREG
	MOVEM	%NREG		;SET IN TABLES
	MOVEM	%DYNAM		;SET START OF DYNAMIC STORAGE
	SETZM	%ARITH		;INITIALIZE ARITH ERROR CONTROL
	MOVE	[XWD 400005,400001]
	MOVEM	%HDBLK		;INITIALIZE %HDBLK
	SETZM	%HDBLK+3	;SET EXTRA POINTERS TO NULL
	SETZM	%HDBLK+4
	MOVE	[JSR %UUO]	;SET UP FOR UUOS
	MOVEM	.jb41
	MOVE	[JRST %UUOTB]
	MOVEM	%UUO+1
	MOVEI	%REENT		;SET UP FOR REENTER
	HRRM	.jbREN		; FOR ERROR RECOVERY
	MOVEI	%APRER
	HRRM	.jbAPR		;SET UP FOR INTERRUPTS
	MOVEI	200110		; ON PDL OVF,OVF,EXP OVF
	APRENB
	SETZM	%STAT+3
	MOVE	[XWD %STAT+3,%STAT+4]
	BLT	%STEND		;INITIALIZE STATISTICS TABLE
	MOVEI	0
	RUNTIM
	MOVEM	%STAT		;INITIALIZE TIMES
	MOVEM	%STAT+1
	MOVEM	%STAT+24
	MSTIME			;GET MS TIME OF DAY
	MOVEM	%STAT+23
	JRST	%BLOCK		;TREAT NOW LIKE %BLOCK UUO

%REENT:	MOVE	.jbOPC		;INDICATE PROPER ERROR POINT
	SKIPN	%UUO
	MOVEM	%UUO
	MOVEI	ERROR,[ASCIZ/REENTER/]
	PUSHJ	%P,%ERROR	;REENTER, CALL ERROR ROUTINE
	EXIT			;AND QUIT

%APRER:	MOVEM	%APRSV
	MOVE	.jbTPC		;INDICATE PROPER ERROR POINT
	SKIPN	%UUO
	MOVEM	%UUO
	MOVE	.jbCNI		;APR ERROR, DECODE IT
	TRNE	200000
	JRST	PUSHER		;PUSHDOWN OVERFLOW
	TRNE	100
	JRST	FLTOVF		;FLOATING OVERFLOW
	MOVE	.jbTPC		;DECODE INTEGER OVERFLOW
	TLNE	40
	JRST	FIXDIV		;FIXED POINT DIVIDE BY ZERO
	MOVEI	ERROR,[ASCIZ/INTEGER OVERFLOW/]
ERRPRT:	PUSHJ	%P,%ERROR	;ERROR PRINTOUT
	EXIT			;AND QUIT

ERRRTN:	MOVE	%UUO		;SEE IF SHOULD RESET %UUO
	CAMN	.jbTPC
	SETZM	%UUO		;IF %UUO=INTERRUPT POINT
	MOVEM	ERROR,%APRSV+1	;SAVE ERROR
	MOVE	ERROR,.jbTPC	;SEE WHAT KIND OF INSTRUCTION
	HLRZ	-1(ERROR)
	ANDI	777000		;GET OPCODE
	CAIN	140000
	JRST	UFA		;UFA
	CAIN	142000
	JRST	AC		;FSC
	ANDI	007000		;GET MODE
	CAIN	001000
	JRST	LONG		;LONG MODE
	ANDI	003000		;WHAT DESTINATION
	CAIN	003000
	JRST	BOTH		;XXXXB
	CAIN	002000
	JRST	MEMORY		;XXXXM
AC:	HLRZ	ERROR,-1(ERROR)	;XXXX OR XXXXI, SET AC
	LSH	ERROR,-5
	ANDI	ERROR,17
STORE:	JUMPE	ERROR,.+3	;ACCOUNT FOR AC0 IN %APRSV
	SETZM	(ERROR)
	JRST	DONE
	SETZM	%APRSV
	JRST	DONE
UFA:	HLRZ	ERROR,-1(ERROR)	;GET AC+1
	ADDI	ERROR,40
	JRST	AC+1
MEMORY:	MOVE	-1(ERROR)	;GET INSTRUCTION
	MOVE	ERROR,%APRSV+1	;RESET ERROR
	MOVEI	ERROR,@0	;GET ADDRESS
	JRST	STORE
BOTH:	MOVE	-1(ERROR)	;GET INSTRUCTION
	MOVE	ERROR,%APRSV+1	;RESET ERROR
	MOVEI	ERROR,@0	;GET ADDRESS
	JUMPE	ERROR,.+3	;ACCOUNT FOR AC0 IN %APRSV
	SETZM	(ERROR)
	JRST	.+2
	SETZM	%APRSV
	MOVE	ERROR,.jbTPC	;SET UP AGAIN FOR STORE IN AC
	JRST	AC
LONG:	HLRZ	ERROR,-1(ERROR)	;GET AC
	LSH	ERROR,-5
	ANDI	ERROR,17
	JUMPE	ERROR,.+3	;ACCOUNT FOR AC0 IN %APRSV
	SETZM	(ERROR)
	JRST	.+2
	SETZM	%APRSV
	SETZM	1(ERROR)	;TAKE CARE OF AC+1 ALSO
DONE:	MOVE	ERROR,%APRSV+1
	MOVEI	200110		;RESET APRENB
	APRENB
	MOVE	%APRSV		;RESTORE REGISTER
	JRSTF	@.jbTPC		;AND RETURN

FIXDIV:	MOVEI	ERROR,[ASCIZ/INTEGER DIVISION BY ZERO/]
	JRST	ERRPRT

FLTOVF:	MOVE	.jbTPC		;DECODE FLOATING OVERFLOW
	TLNE	40
	JRST	FLTDIV		;FLOATING POINT DIVIDE BY ZERO
	TLNE	100
	JRST	FLTUNF		;FLOATING POINT UNDERFLOW
	MOVEI	ERROR,[ASCIZ/REAL OR COMPLEX OVERFLOW/]
	JRST	ERRPRT

FLTDIV:	MOVEI	ERROR,[ASCIZ/REAL OR COMPLEX DIVISION BY ZERO/]
	JRST	ERRPRT

FLTUNF:	AOSE	%ARITH		;KEEP ERROR COUNT
	JRST	ERRRTN
	MOVEI	ERROR,[ASCIZ/REAL OR COMPLEX UNDERFLOW/]
	JRST	ERRPRT

PUSHER:	MOVEI	ERROR,[ASCIZ/INTERNAL ERROR (STACK OVF)/]
	SUB	%P,[XWD ^D20,0]
	JRST	ERRPRT		;ALLOW ACCESS TO EXTRA STACK SPACE

	PRGEND
	TITLE	%UUOTB -- ALGOLW UUO DISPATCH TABLE -- MICHAEL GREEN
	HISEG
	ENTRY	%UUOTB,%XUUO
	EXTERN	%CSTE,%CSTN,%CSTL,%CSTLE,%CSTG,%CSTGE,%SMOVE,%SUBST
	EXTERN	%ARECD,%AARRY,%RARRY,%ASTRA,%DADD,%DSUB,%DMULT,%DDIV
	EXTERN	%CMULT,%CDIV,%DCMUL,%DCDIV,%RDLST,%WRLST,%READ,%WRITE
	EXTERN	%BRK0,%BRK1,%GETBK,%GETLN,%PUTLN,%CLRBK,%EFILE,%ASTRG
	EXTERN	%BLOCK,%THUNK,%FIX,%FLOAT,%DFIX,%DFLOT,%CLOSE,%RESET
	EXTERN	%ERROR,%UUO,%USRER,%SUBSC,%PROC,%OPEN,%IS,%HDBLK
	EXTERN .jbUUO
	%P=	17
	UUOPTR=	14		;NOTE: IS ALSO %T (SEE %ALLOC)

%UUOTB:	MOVEM	UUOPTR,%HDBLK+3	;SAVE %T IN %HDBLK
	HLRZ	UUOPTR,.jbUUO
	LSH	UUOPTR,-^D9	;GET TABLE INDEX
	HRLI	UUOPTR,%HDBLK+3	;SETUP FOR REGISTER RESTORE
	JRA	UUOPTR,.(UUOPTR);JUMP INTO TABLE

	JRST	%CSTE		;COMPARE STRING EQUAL
	JRST	%CSTN		;COMPARE STRING NOT EQUAL
	JRST	%CSTL		;COMPARE STRING LESS THAN
	JRST	%CSTLE		;COMPARE STRING LESS THAN OR EQUAL
	JRST	%CSTG		;COMPARE STRING GREATER THAN
	JRST	%CSTGE		;COMPARE STRING GREATER THAN OR EQUAL
	JRST	%SMOVE		;MOVE STRING
	JRST	%SUBST		;SUBSTRING
	JRST	%ARECD		;RECORD ALLOCATE
	JRST	%AARRY		;NON-REFERENCE ARRAY ALLOCATE
	JRST	%RARRY		;REFERENCE ARRAY ALLOCATE
	JRST	%ASTRA		;STRING ARRAY ALLOCATE
	JRST	%DADD		;LONG REAL ADD
	JRST	%DSUB		;LONG REAL SUBTRACT
	JRST	%DMULT		;LONG REAL MULTIPLY
	JRST	%DDIV		;LONG REAL DIVIDE
	JRST	%CMULT		;COMPLEX MULTIPLY
	JRST	%CDIV		;COMPLEX DIVIDE
	JRST	%DCMUL		;LONG COMPLEX MULTIPLY
	JRST	%DCDIV		;LONG COMPLEX DIVIDE
	JRST	%OPEN		;OPEN FILE
	JRST	%IS		;REFERENCE IS RECORD TEST
	JRST	%READ		;READ
	JRST	%WRITE		;WRITE
	JRST	%GETLN		;GET INPUT LINE NUMBER
	JRST	%PUTLN		;PUT OUTPUT LINE NUMBER
	JRST	%BRK0		;BREAK NOACTION, IGNORE
	JRST	%BRK1		;BREAK INCLUDE, DEFER
	JRST	%GETBK		;GET BREAK CHARACTER
	JRST	%SUBSC		;ARRAY SUBSCRIPT CHECKING

	HLRZ	UUOPTR,.jbUUO	;FURTHER UUO DECODE
	LSH	UUOPTR,-5	;USE AC FIELD
	HRLI	UUOPTR,%HDBLK+3	;SETUP FOR RESTORE AGAIN
	JRA	UUOPTR,.-757(UUOPTR)	;ALLOW FOR OPCODE=37

	JRST	%ASTRG		;STRING ALLOCATE
	JRST	%PROC		;PROCEDURE ENTRY
	JRST	%BLOCK		;BLOCK ENTRY
	JRST	%THUNK		;THUNK ENTRY
	JRST	%FIX		;REAL TO INTEGER
	JRST	%FLOAT		;INTEGER TO REAL
	JRST	%DFIX		;LONG REAL TO INTEGER
	JRST	%DFLOT		;INTEGER TO LONG REAL
	JRST	%CLOSE		;CLOSE FILE
	JRST	%EFILE		;END FILE TEST
	JRST	CALLUO		;ENTER INTERNAL ROUTINE
	JRST	%USRER		;USER ERROR TRACEBACK
	JRST	%CLRBK		;RESET BREAK TABLE
	JRST	%RDLST		;READ LIST STRUCTURE
	JRST	%WRLST		;WRITE LIST STRUCTURE
	JRST	%RESET+1	;RESET SYSTEM, ENTER OUTER BLOCK

CALLUO:	PUSHJ	%P,@.jbUUO	;SET TRACEBACK POINT ON ERROR

%XUUO:	PUSH	%P,%UUO		;RETURN TO POINT OF CALL
	SETZM	%UUO		;RESET TRACEBACK POINT
	MOVE	UUOPTR,%HDBLK+3	;RESTORE REGISTER
	POPJ	%P,

	PRGEND
	TITLE	%OPEN -- ALGOLW OPEN ROUTINE -- MICHAEL GREEN
	HISEG
	ENTRY	%OPEN,%OPENT
	EXTERN	%IOOPN,%IOSIZ,%IOLEB,%IOPRO,%IOREG,%AVIOB
	EXTERN	%SREG,%NREG,%LREG,%COLLE,%ERROR,%ERRNM
	EXTERN	%XUUO,%IOEND,%SAVE,%ERRSB
	EXTERN	%IOBFH,%IOBRK,%IOPP,%OPNSW,%UUO
	EXTERN .jbUUO,.jbFF
	%P=	17
	CHAN=	10
	CINDEX=	11
	TEMP=	12
	BUFFCT=	13
	TEMP2=	13
	ERROR=	14
	REGPT=	14
	TEMP3=	14
	OPNFLG=	400000		;OPNFLG MUST BE SIGN BIT FOR %OPENT
	LNEFLG=	200000
	RECFLG=	100000
	INFLG=	040000		;FLAGS IN LH OF %IOOPN
	OUTFLG=	020000
	BITFLG=	010000
	STRFLG=	004000
	REWFLG=	002000
	CONFLG=	001000

OPENI:	TLNN	TEMP,2		;DEVICE CAN DO INPUT
	JRST	NOINPT
	MOVEI	TEMP,%IOBFH(CINDEX)	;SET POINTER TO BUFF HEADER
	HRRZM	TEMP,%IOOPN+2(CINDEX)
	MOVE	TEMP,[OPEN %IOOPN(CINDEX)]
	DPB	CHAN,[POINT 4,TEMP,^D12]
	XCT	TEMP		;OPEN CHANNEL
	JRST	OPENER
	MOVE	TEMP,[LOOKUP %IOLEB(CINDEX)]
	DPB	CHAN,[POINT 4,TEMP,^D12]
	XCT	TEMP		;LOOKUP FILE
	JRST	LOOKER
	MOVE	TEMP,%IOOPN(CINDEX)
	TLNE	TEMP,RECFLG
	JRST	FORCEI		;IF LIST I/O, LEAVE BINARY BYTE PTR
	ANDI	TEMP,17		;IF BINARY, SET BYTE SIZE OF 1 BIT
	JUMPE	TEMP,FORCEI
	MOVEI	TEMP,1
	DPB	TEMP,[POINT 6,%IOBFH+1(CINDEX),^D11]
FORCEI:	PUSHJ	%P,MTASW	;PROCESS DTA AND MTA SWITCHES
	PUSH	%P,CHAN		;SAVE REGISTERS
	PUSH	%P,CINDEX
	PUSH	%P,BUFFCT
	PUSHJ	%P,%COLLE	;FORCE COLLECTION
	POP	%P,BUFFCT	;AND RESTORE REGISTERS
	POP	%P,CINDEX
	POP	%P,CHAN
	MOVE	REGPT,%AVIOB
	MOVE	TEMP,%NREG(REGPT)
	HRRM	TEMP,.jbFF	;SET AREA FOR BUFFERS
	MOVE	TEMP,[INBUF (BUFFCT)]
	DPB	CHAN,[POINT 4,TEMP,^D12]
	XCT	TEMP		;ALLOCATE THEM
	PUSHJ	%P,BUFFER	;ADJUST STORAGE CONTROL TABLES
	MOVSI	TEMP,OPNFLG+INFLG	;MARK NOW AS OPEN
	ORM	TEMP,%IOOPN(CINDEX)
	AOS	%UUO		;SKIP RETURN
	JRST	%XUUO		;DONE, EXIT

OPENO:	TLNN	TEMP,1		;DEVICE CAN DO OUTPUT
	JRST	NOOUT
	MOVEI	TEMP,%IOBFH(CINDEX)	;SET POINTER TO BUFF HEADER
	HRLZM	TEMP,%IOOPN+2(CINDEX)
	MOVE	TEMP,[OPEN %IOOPN(CINDEX)]
	DPB	CHAN,[POINT 4,TEMP,^D12]
	XCT	TEMP		;OPEN CHANNEL
	JRST	OPENER
	MOVE	TEMP,[ENTER %IOLEB(CINDEX)]
	DPB	CHAN,[POINT 4,TEMP,^D12]
	XCT	TEMP		;CREATE FILE
	JRST	ENTRER
	MOVE	TEMP,%IOOPN(CINDEX)
	TLNE	TEMP,RECFLG
	JRST	FORCEO		;IF LIST I/O, LEAVE BINARY BYTE PTR
	ANDI	TEMP,17		;IF BINARY, SET BYTE SIZE TO 1 BIT
	JUMPE	TEMP,FORCEO
	MOVEI	TEMP,1
	DPB	TEMP,[POINT 6,%IOBFH+1(CINDEX),^D11]
FORCEO:	PUSHJ	%P,MTASW	;PROCESS DTA AND MTA SWITCHES
	PUSH	%P,CHAN		;SAVE REGISTERS
	PUSH	%P,CINDEX
	PUSH	%P,BUFFCT
	PUSHJ	%P,%COLLE	;FORCE COLLECTION
	POP	%P,BUFFCT
	POP	%P,CINDEX
	POP	%P,CHAN
	MOVE	REGPT,%AVIOB
	MOVE	TEMP,%NREG(REGPT)
	HRRM	TEMP,.jbFF
	MOVE	TEMP,[OUTBUF (BUFFCT)]	;SET AREA FOR BUFFERS
	DPB	CHAN,[POINT 4,TEMP,^D12]
	XCT	TEMP		;ALLOCATE THEM
	PUSHJ	%P,BUFFER	;ADJUST STORAGE CONTROL TABLES
	MOVSI	TEMP,OPNFLG+OUTFLG	;MARK NOW AS OPEN
	ORM	TEMP,%IOOPN(CINDEX)
	AOS	%UUO		;SKIP RETURN
	JRST	%XUUO		;DONE, EXIT

NOINPT:	MOVEI	ERROR,[ASCIZ/OPEN - INPUT NOT POSSIBLE FOR $:/]
	JRST	OPENER+1

NOOUT:	MOVEI	ERROR,[ASCIZ/OPEN - OUTPUT NOT POSSIBLE FOR $:/]
	JRST	OPENER+1

OPENER:	MOVEI	ERROR,[ASCIZ@OPEN - $: I/O ERROR DURING OPEN@]
	MOVE	TEMP,%IOOPN(CINDEX)
	TLNE	TEMP,CONFLG	;ERROR ON CONDITIONAL OPEN
	JRST	%XUUO		;ERROR RETURN
	PUSHJ	%P,%ERROR
	MOVE	ERROR,%IOOPN+1(CINDEX)
	PUSHJ	%P,%ERRSB
	EXIT

ENTRER:	MOVEI	ERROR,[ASCIZ/OPEN OUTPUT - $:$.$ CAN NOT BE CREATED/]
	JRST	OPNEDT

LOOKER:	MOVEI	ERROR,[ASCIZ/OPEN INPUT - $:$.$ DOES NOT EXIST/]
OPNEDT:	MOVE	TEMP,%IOOPN(CINDEX)
	TLNE	TEMP,CONFLG	;ERROR ON CONDITIONAL OPEN
	JRST	%XUUO		;ERROR RETURN
	PUSHJ	%P,%ERROR
	MOVE	ERROR,%IOOPN+1(CINDEX)
	PUSHJ	%P,%ERRSB
	MOVE	ERROR,%IOLEB(CINDEX)
	PUSHJ	%P,%ERRSB
	HLLZ	ERROR,%IOLEB+1(CINDEX)
	PUSHJ	%P,%ERRSB
	EXIT

BUFFER:	SETZM	%LREG(REGPT)	;OLD REGION ZERO AVAILABLE SPACE
	AOS	REGPT,%AVIOB	;GET NEW REGION
	HRRZ	TEMP,.jbFF	;START OF AVAILABLE STORAGE
	MOVEM	TEMP,%SREG(REGPT)	;STORE IN TABLES
	MOVEM	TEMP,%NREG(REGPT)
	SETZM	%LREG(REGPT)	;NEW REGION ZERO LENGTH
	MOVEI	REGPT,0		;FIND OUT HOW MUCH ALREADY FREE
	MOVEI	TEMP,0
	ADD	TEMP,%LREG(REGPT)
	CAMGE	REGPT,%AVIOB	;ALL ALLOCATED REGIONS
	AOJA	REGPT,.-2
	CAIGE	TEMP,2000	;YES, IF LESS THAN 1K AVAILABLE
	SKIPA	TEMP,[2000]	;MAKE 1K MORE AVAILABLE
	MOVEI	TEMP,0
	ADD	TEMP,%NREG(REGPT)
	ORI	TEMP,1777	;ROUND UP TO 1K BOUNDARY
	MOVE	TEMP2,%NREG(REGPT)
	SUBM	TEMP,TEMP2	;FIND THE LENGTH OF AVAILABLE SPACE
	ADDI	TEMP2,1
	MOVEM	TEMP2,%LREG(REGPT)	;SAVE IT
	CORE	TEMP,		;ASK FOR CORE
	JRST	TIGHT
	POPJ	%P,

TIGHT:	MOVNI	TEMP,2000	;SEE IF WE REMOVE 1K PADDING
	ADDB	TEMP,%LREG(REGPT)
	ADD	TEMP,%NREG(REGPT)
	SUBI	TEMP,1		;SHOULD BE ABLE TO GET THAT MUCH
	CORE	TEMP,
	HALT
	POPJ	%P,

MTASW:	MOVE	TEMP,[POINT 7,%OPNSW]
	ILDB	TEMP3,TEMP	;PROCESS DTA OR MTA SWITCHES
	JUMPN	TEMP3,.+2
	POPJ	%P,		;ZERO BYTE ENDS LIST
	CAIE	TEMP3,"Z"
	JRST	.+5		;Z IS ZERO DECTAPE DIRECTORY
	MOVE	TEMP3,[UTPCLR]
DOSW:	DPB	CHAN,[POINT 4,TEMP3,^D12]
	XCT	TEMP3		;DO IT
	JRST	MTASW+1		;AND GET NEXT SWITCH
	CAIE	TEMP3,"A"
	JRST	.+3		;A IS ADVANCE ONE FILE
DOASW:	MOVE	TEMP3,[MTAPE 16]
	JRST	DOSW
	CAIE	TEMP3,"C"
	JRST	.+3		;C IS IBM COMPATIBLE MODE
	MOVE	TEMP3,[MTAPE 101]
	JRST	DOSW
	CAIE	TEMP3,"W"
	JRST	.+3		;W IS REWIND TAPE
	MOVE	TEMP3,[MTAPE 1]
	JRST	DOSW
	CAIE	TEMP3,"T"
	JRST	.+3		;T IS GO TO LOGICAL END OF TAPE
	MOVE	TEMP3,[MTAPE 10]
	JRST	DOSW
	MOVE	TEMP3,[MTAPE 17];ELSE ASSUME B - BACKSPACE FILE
	DPB	CHAN,[POINT 4,TEMP3,^D12]
	XCT	TEMP3		;BACKSPACE IT
	HRRI	TEMP3,0
	XCT	TEMP3		;WAIT TIL DONE
	MOVE	TEMP3,[STATO 4000]
	DPB	CHAN,[POINT 4,TEMP3,^D12]
	XCT	TEMP3		;IS BEGINNING OF TAPE
	JRST	DOASW		;NO, MOVE PAST TAPE MARK
	JRST	MTASW+1		;YES, GET NEXT SWITCH

	PAGE
;	FILE DESCRIPTOR SCANNER

	CHAR=	0
	ASSEMB=	1
	BYTEPT=	2
	LENGTH=	3
	FLAG=	4
	SWPTR=	5
	LOOKNM=	400000		;FLAG BITS
	FINDNM=	200000
	LOOKDG=	100000
	OCTAL=	040000
	FINDDG=	020000
	LOOKDV=	010000
	LOOKFL=	004000
	PASTFL=	002000
	LOOKPP=	001000
	LOOKPR=	000400
	LOOKPG=	000200
	LOOKBN=	000100
	FINDBN=	000040
	FINDPP=	000020
	FINDPR=	000010
	FINDMD=	000004
	SWSKIP=	000002
	GOTSW=	000001

%OPEN:	MOVEI	TEMP,%SAVE	;SAVE WORK REGISTERS
	BLT	TEMP,%SAVE+5
	MOVE	CHAN,@.jbUUO	;GET CHANNEL NUMBER
	JUMPG	CHAN,CHANOK	;MUST BE 0 < CHAN < 16
CHANER:	MOVEI	ERROR,[ASCIZ/OPEN - ILLEGAL CHANNEL - $/]
OPNERM:	PUSHJ	%P,%ERROR
	MOVE	ERROR,CHAN
	PUSHJ	%P,%ERRNM
	EXIT			;QUIT
CHANOK:	CAIL	CHAN,^D16
	JRST	CHANER
	MOVEI	CINDEX,(CHAN)	;GET INDEX INTO TABLES
	IMULI	CINDEX,%IOSIZ
	SKIPL	%IOOPN(CINDEX)	;SEE IF ALREADY OPEN
	JRST	NOTOPN
	MOVEI	ERROR,[ASCIZ/OPEN - CHANNEL $ ALREADY OPEN/]
	JRST	OPNERM
NOTOPN:	SETZB	FLAG,%IOOPN(CINDEX)	;INITIALIZE TABLES
	MOVEI	TEMP,%IOOPN+1(CINDEX)
	HRLI	TEMP,%IOOPN(CINDEX)
	MOVEI	TEMP2,%IOOPN(CINDEX)
	BLT	TEMP,%IOSIZ-1(TEMP2)
	MOVSI	TEMP,(SIXBIT/DSK/)	;DEFAULT DEVICE
	MOVEM	TEMP,%IOOPN+1(CINDEX)
	MOVEI	BUFFCT,2	;DEFAULT BUFFER COUNT = 2
	SETOM	%IOPRO(CINDEX)	;NO PROTECTION RENAME
	MOVE	TEMP,%AVIOB	;SET REGION NUMBER
	MOVEM	TEMP,%IOREG(CINDEX)
	SETZM	%OPNSW
	LDB	TEMP,[POINT 4,.jbUUO,^D12]
	TRZ	TEMP,1		;EITHER INPUT OR OUTPUT
	CAIG	TEMP,SWPTR	;GET DESCRIPTOR DOPE VECTOR
	ADDI	TEMP,%SAVE
	MOVE	BYTEPT,(TEMP)
	MOVE	TEMP,1(TEMP)
	HLRZ	LENGTH,TEMP
	ADDI	BYTEPT,(TEMP)	;MAKE BYTEPTR ABSOLUTE

NEWITM:	SETZ	ASSEMB,		;START OF NEW ITEM
	JUMPL	LENGTH,SETXIT	;DONE

NEXTCH:	SOJL	LENGTH,ENDFLD	;END OF STRING, FINISH UP
	ILDB	CHAR,BYTEPT	;GET CHARACTER
	CAIN	CHAR,")"
	JRST	ENDSW		;END OF DTA OR MTA SWITCHES
	TLNE	FLAG,SWSKIP
	JRST	SWTEST		;PROCESS DTA OR MTA SWITCH
	CAIN	CHAR,"("
	JRST	STRTSW		;START OF DTA OR MTA SWITCHES
	CAIN	CHAR,"?"
	JRST	CONDOP		;CONDITIONAL OPEN
	CAIN	CHAR,":"
	JRST	DEVCHK		;END OF DEVICE SPECIFICATION
	CAIN	CHAR,"."
	JRST	NAMCHK		;END OF FILE NAME
	CAIN	CHAR,"["
	JRST	STRTPP		;START OF PROJECT-PROGRAMMER
	CAIN	CHAR,"<"
	JRST	STRTPR		;START OF PROTECTION CODE
	CAIN	CHAR,"*"
	JRST	STRTMD		;START OF MODE CODE
	CAIN	CHAR,"#"
	JRST	STRTBN		;START OF BUFFER COUNT
	CAIN	CHAR,","
	JRST	COMMA		;END OF PROJECT START PROGRAMMER
	CAIN	CHAR,"]"
	JRST	ENDPP		;END OF PROGRAMMER
	CAIN	CHAR,">"
	JRST	ENDPR		;END OF PROTECT CODE
	CAIN	CHAR,"^"	;DELETE FILE CODE
	JRST	DELCOD
	CAIGE	CHAR,"0"
	JRST	.+3		;DIGIT
	CAIG	CHAR,"9"
	JRST	DIGIT
	CAIGE	CHAR,"A"
	JRST	.+3		;UPPER CASE LETTER
	CAIG	CHAR,"Z"
	JRST	LETTER
	CAIGE	CHAR,"A"+40
	JRST	.+3		;LOWER CASE LETTER
	CAIG	CHAR,"Z"+40
	JRST	LOWERC
	JRST	UNKNOW

LOWERC:	TRZ	CHAR,40		;CONVERT TO UPPER CASE
LETTER:	TLNE	FLAG,LOOKNM	;ARE WE LOOKING FOR A NAME?
	JRST	UNKNOW
	TLO	FLAG,FINDNM	;INDICATE WE FOUND ONE
	TLNE	ASSEMB,770000	;ONLY FIRST SIX CHARACTERS
	JRST	NEXTCH
	TRC	CHAR,40		;CONVERT TO SIXBIT
	ROT	CHAR,-6
	ROTC	CHAR,6		;PACK INTO ASSEMB
	JRST	NEXTCH

DIGIT:	TLNN	FLAG,LOOKDG	;ARE WE LOOKING FOR A NUMBER?
	JRST	LETTER		;MAYBE PART OF A NAME
	TLO	FLAG,FINDDG	;INDICATE WE FOUND ONE
	TLNE	FLAG,OCTAL	;IS IT DECIMAL
	JRST	POCTAL
	CAIL	ASSEMB,^D1000	;MAXIMUM 9999
	JRST	UNKNOW
	IMULI	ASSEMB,^D10	;PACK IN DIGIT
	ADDI	ASSEMB,-"0"(CHAR)
	JRST	NEXTCH

POCTAL:	CAIL	CHAR,"8"	;IS LEGAL OCTAL CHARACTER
	JRST	UNKNOW
	CAIL	ASSEMB,100000	;CHECK HALFWORD ONLY
	JRST	UNKNOW
	ROT	CHAR,-3
	ROTC	CHAR,3		;PACK IN ASSEMB
	JRST	NEXTCH

DEVCHK:	TLOE	FLAG,LOOKDV	;ARE WE LOOKING FOR A DEVICE NAME
	JRST	UNKNOW
	TLZN	FLAG,FINDNM	;HAVE WE FOUND A NAME
	JRST	UNKNOW
	TLNE	ASSEMB,770000	;LEFT JUSTIFY NAME
	JRST	.+3
	LSH	ASSEMB,6
	JRST	.-3
	MOVEM	ASSEMB,%IOOPN+1(CINDEX)
	JRST	NEWITM		;STORE DEVICE AND LEAVE LOOKNM SET

NAMCHK:	TLOE	FLAG,LOOKFL	;ARE WE LOOKING FOR A FILE NAME
	JRST	UNKNOW
	TLZN	FLAG,FINDNM	;HAVE WE FOUND A NAME
	JRST	UNKNOW
	TLO	FLAG,LOOKDV
STORFL:	TLNE	ASSEMB,770000	;LEFT JUSTIFY NAME
	JRST	.+3
	LSH	ASSEMB,6
	JRST	.-3
	MOVEM	ASSEMB,%IOLEB(CINDEX)
	JRST	NEWITM		;STORE FILE NAME AND LEAVE LOOKNM SET

ENDFLD:	TLNE	FLAG,SWSKIP	;END OF STRING IN SWITCH SCAN MODE
	JRST	UNKNOW
	TLOE	FLAG,PASTFL	;HAVE WE FINISHED WITH FILE NAME.EXT
	JRST	CHKBFN
STOEXT:	TLO	FLAG,LOOKNM	;NO, NO MORE NAMES
	TLZN	FLAG,FINDNM	;HAVE WE FOUND NAME
	JRST	NEWITM
	TLNN	FLAG,LOOKFL	;HAVE WE FOUND FILE NAME
	JRST	STORFL
	TLNE	ASSEMB,770000	;YES, LEFT JUSTIFY EXTENSION
	JRST	.+3
	LSH	ASSEMB,6
	JRST	.-3
	HLLM	ASSEMB,%IOLEB+1(CINDEX)
	JRST	NEWITM		;STORE EXTENSION

STRTPP:	TLNE	FLAG,LOOKPP+FINDPP+LOOKPR+LOOKPG
	JRST	UNKNOW		;NOT IN PROT OR P-P OR FOUND P-P
	TLO	FLAG,LOOKDG+OCTAL+LOOKPP
	JRST	ENDFLD		;LOOKING FOR OCTAL PROJECT NO.

STRTPR:	TLNE	FLAG,FINDPR+LOOKPR+LOOKPP+LOOKPG
	JRST	UNKNOW		;NOT IN PROT OR P-P OR FOUND PROT
	TLO	FLAG,LOOKDG+OCTAL+LOOKPR
	JRST	ENDFLD		;LOOKING FOR OCTAL PROTECTION

CHKBFN:	TLZN	FLAG,LOOKBN	;WERE WE PACKING BUFFER NUMBER
	JRST	NEWITM
	TLZN	FLAG,FINDDG	;HAD WE FOUND A NUMBER
	JRST	UNKNOW
	JUMPE	ASSEMB,UNKNOW	;MUST BE > 0
	TLO	FLAG,FINDBN	;WE FOUND IT
	MOVE	BUFFCT,ASSEMB	;SAVE VALUE
	JRST	NEWITM

STRTBN:	TLNE	FLAG,LOOKBN+FINDBN
	JRST	UNKNOW		;ONLY ONE BUFFER NUMBER SPEC.
	TLO	FLAG,LOOKDG+LOOKBN
	TLZ	FLAG,OCTAL	;LOOKING FOR DECIMAL BUFFER COUNT
	TLOE	FLAG,PASTFL	;ARE WE ENDING FILE NAME OR EXT.
	JRST	NEWITM
	JRST	STOEXT		;YES, LOOKBN ALREADY SET

STRTMD:	TLOE	FLAG,FINDMD	;ALREADY FOUND MODE
	JRST	UNKNOW
	TLZ	FLAG,LOOKDG
	SOJL	LENGTH,UNKNOW	;NO, GET NEXT CHARACTER
	ILDB	CHAR,BYTEPT
	CAIN	CHAR,"S"
	JRST	STRMOD		;ASCII MODE
	CAIN	CHAR,"L"
	JRST	LINEMD		;NUMBERED LINES (ASCII)
	CAIN	CHAR,"R"
	JRST	RECORD		;RECORD I/O
	CAIE	CHAR,"B"
	JRST	UNKNOW
	MOVSI	TEMP,BITFLG	;SET BITS MODE FLAG
	ORM	TEMP,%IOOPN(CINDEX)
SETBIN:	MOVEI	TEMP,14		;BINARY, SET MODE
	ORM	TEMP,%IOOPN(CINDEX)
	JRST	ENDFLD

RECORD:	MOVSI	TEMP,RECFLG	;SET RECORD I/O MODE
	ORM	TEMP,%IOOPN(CINDEX)
	JRST	SETBIN

LINEMD:	MOVSI	TEMP,LNEFLG+STRFLG	;SET NUMBERED LINE MODE
	ORM	TEMP,%IOOPN(CINDEX)
	HLLOS	%IOBRK+7(CINDEX)	;SET NO LINE NUMBERS YET
	JRST	ENDFLD

STRMOD:	MOVSI	TEMP,STRFLG	;SET STRING MODE
	ORM	TEMP,%IOOPN(CINDEX)
	JRST	ENDFLD

ENDPR:	TLZN	FLAG,LOOKPR	;WERE WE LOOKING FOR PROTECT CODE
	JRST	UNKNOW
	TLZN	FLAG,FINDDG	;DID WE FIND NUMBER
	JRST	UNKNOW
	CAIL	ASSEMB,1000	;IS LEGAL CODE
	JRST	UNKNOW
	TLO	FLAG,FINDPR	;MARK AS FOUND
	TLZ	FLAG,LOOKDG
	HRRZM	ASSEMB,%IOPRO(CINDEX)
	JRST	NEWITM		;STORE IT

COMMA:	TLZN	FLAG,LOOKPP	;WERE WE LOOKING FOR PROJECT
	JRST	UNKNOW
	TLZN	FLAG,FINDDG	;DID WE FIND NUMBER
	JRST	UNKNOW
	TLO	FLAG,LOOKPG	;MARK LOOKING FOR PROGRAMMER
	HRLZM	ASSEMB,%IOLEB+3(CINDEX)
	HRLZM	ASSEMB,%IOPP(CINDEX)
	JRST	NEWITM		;STORE IT

ENDPP:	TLZN	FLAG,LOOKPG	;WERE WE LOOKING FOR PROGRAMMER
	JRST	UNKNOW
	TLZN	FLAG,FINDDG	;DID WE FIND NUMBER
	JRST	UNKNOW
	TLO	FLAG,FINDPP	;MARK FOUND
	TLZ	FLAG,LOOKDG
	HRRM	ASSEMB,%IOLEB+3(CINDEX)
	HRRM	ASSEMB,%IOPP(CINDEX)
	JRST	NEWITM		;STORE IT

DELCOD:	TLNE	FLAG,LOOKPP+LOOKPR+FINDPR+LOOKPG
	JRST	UNKNOW		;NOT IN PROT OR P-P OR FOUND PROT
	TLZ	FLAG,LOOKDG
	TLO	FLAG,FINDPR
	HRRZS	%IOPRO(CINDEX)	;MARK FILE TO BE DELETED
	JRST	ENDFLD

CONDOP:	TLNE	FLAG,LOOKPP+LOOKPR+LOOKPG
	JRST	UNKNOW		;NOT IN P-P OR IN PROT
	TLZ	FLAG,LOOKDG
	MOVSI	TEMP,CONFLG
	ORM	TEMP,%IOOPN(CINDEX)
	JRST	ENDFLD		;SET CONDITIONAL MODE

STRTSW:	TLNE	FLAG,LOOKPP+LOOKPG+LOOKPR+GOTSW
	JRST	UNKNOW		;NOT IN P-P OR IN PROT OR GOT SWITCHES
	TLZ	FLAG,LOOKDG
	TLO	FLAG,SWSKIP
	MOVE	SWPTR,[POINT 7,%OPNSW]
	JRST	ENDFLD+2	;SET UP FOR SWITCHES

ENDSW:	TLZN	FLAG,SWSKIP	;BETTER HAVE BEEN PROCESSING SWITCHES
	JRST	UNKNOW
	TLO	FLAG,GOTSW
	MOVEI	TEMP,0
	IDPB	TEMP,SWPTR	;MARK END OF SWITCHES
	JRST	NEWITM

SWTEST:	MOVE	TEMP,SWPTR	;CHECK SWITCHES
	CAIN	CHAR,"Z"
	IDPB	CHAR,SWPTR
	CAIN	CHAR,"A"
	IDPB	CHAR,SWPTR	;CONDITIONALLY STORE
	CAIN	CHAR,"B"
	IDPB	CHAR,SWPTR	;JUST STORE DEFERRED ONES
	CAIN	CHAR,"C"
	IDPB	CHAR,SWPTR
	CAIN	CHAR,"W"
	IDPB	CHAR,SWPTR
	CAIN	CHAR,"T"
	IDPB	CHAR,SWPTR
	CAMN	SWPTR,[POINT 7,%OPNSW+7,^D34]
	JRST	UNKNOW		;CHECK LIMIT
	CAME	TEMP,SWPTR
	JRST	NEWITM		;IF WE STORED ONE, DONE
	CAIN	CHAR,"U"
	JRST	UNLOAD		;SPECIAL SWITCH
	CAIN	CHAR,"2"
	MOVE	ASSEMB,[XWD 000200,777177]	;200 BPI
	CAIN	CHAR,"5"
	MOVE	ASSEMB,[XWD 000400,777177]	;556 BPI
	CAIN	CHAR,"8"
	MOVE	ASSEMB,[XWD 000600,777177]	;800 BPI
	CAIN	CHAR,"E"
	HRLOI	ASSEMB,001000	;EVEN PARITY
	CAIN	CHAR,"O"
	HRRZI	ASSEMB,776777	;ODD PARITY
	JUMPE	ASSEMB,UNKNOW	;ERROR, UNKNOWN SWITCH
	HRROI	TEMP,(ASSEMB)
	ANDM	TEMP,%IOOPN(CINDEX)	;SET MODE
	HLRZ	TEMP,ASSEMB
	ORM	TEMP,%IOOPN(CINDEX)
	JRST	NEWITM		;GET NEXT

UNLOAD:	MOVSI	TEMP,REWFLG	;SET UNLOAD ON CLOSE
	ORM	TEMP,%IOOPN(CINDEX)
	JRST	NEWITM

SETXIT:	TLNE	FLAG,FINDMD	;HAVE WE FOUND MODE SET
	JRST	.+12
	MOVSI	TEMP,STRFLG+LNEFLG
	ORM	TEMP,%IOOPN(CINDEX)	;NO, SET DEFAULT
	HLLOS	%IOBRK+7(CINDEX)
	MOVE	TEMP,[XWD 000014,176400]
	MOVEM	TEMP,%IOBRK(CINDEX)
	MOVSI	TEMP,3
	MOVEM	TEMP,%IOBRK+1(CINDEX)
	MOVEI	TEMP,3
	MOVEM	TEMP,%IOBRK+6(CINDEX)
	MOVSI	TEMP,%SAVE	;DONE, RESTORE REGISTERS
	BLT	TEMP,5
	MOVE	TEMP,%IOOPN+1(CINDEX)	;WHAT ARE DEVICE CHARACTERISTICS
	DEVCHR	TEMP,
	TLNN	TEMP,40		;IS DEVICE AVAILABLE TO JOB
	JRST	NOTAV
	MOVE	TEMP3,%IOOPN(CINDEX)
	TRNE	TEMP3,17	;CHECK I/O MODE POSSIBLE
	JRST	.+6
	TRNN	TEMP,1		;STRING I/O
	JRST	NOSTRG
	JRST	.+3
	TRNN	TEMP,10000	;BITS I/O
	JRST	NOBITS
	MOVE	TEMP3,.jbUUO	;GO TO PROPER ROUTINE
	TLNE	TEMP3,40
	JRST	OPENO
	JRST	OPENI

NOTAV:	MOVEI	ERROR,[ASCIZ/OPEN - $: NOT AVAILABLE/]
	JRST	OPENER+1

NOSTRG:	MOVEI	ERROR,[ASCIZ@OPEN - $: CAN NOT DO STRING I/O@]
	JRST	OPENER+1

NOBITS:	MOVE	TEMP,%IOOPN(CINDEX)
	TLNE	TEMP,RECFLG	;IS RECORD I/O
	JRST	NORECD
	MOVEI	ERROR,[ASCIZ@OPEN - $: CAN NOT DO BITS I/O@]
	JRST	OPENER+1

NORECD:	MOVEI	ERROR,[ASCIZ@OPEN - $: CAN NOT DO RECORD I/O@]
	JRST	OPENER+1

UNKNOW:	MOVEI	ERROR,[ASCIZ/OPEN - UNRECOGNIZABLE FILE DESCRIPTOR/]
	PUSHJ	%P,%ERROR
	EXIT

%OPENT:	MOVE	CHAN,-1(%P)	;GET CHANNEL NUMBER
	POP	%P,-1(%P)	;CLOSE UP STACK
	JUMPL	CHAN,CHANER
	CAIL	CHAN,^D16	;0 <= CHAN < 16
	JRST	CHANER
	IMULI	CHAN,%IOSIZ	;GET INDEX INTO TABLES
	SKIPGE	%IOOPN(CHAN)	;OPEN FLAG IS SIGN BIT
	AOS	%UUO		;TRUE RETURN IF CHANNEL OPEN
	POPJ	%P,

	PRGEND
	TITLE	%INOUT -- ALGOLW INPUT/OUTPUT ROUTINES -- MICHAEL GREEN
	HISEG
	ENTRY	%READ,%WRITE,%EFILE,%BRK0,%BRK1,%GETLN,%PUTLN
	ENTRY	%GETBK,%CLRBK,%RDLST,%WRLST
	EXTERN	%IOOPN,%IOSIZ,%IOBRK,%ERROR,%ERRNM,%ERRSB,%IOLEB
	EXTERN	%ERRST,%SAVE,%XUUO,%UUO,%ERROC,%IOBFH
	EXTERN	.jbUUO
	%P=	17
	CHAN=	10
	CINDEX=	11
	BYTEPT=	12
	LENGTH=	13
	LINENO=	12
	DIGIT=	13
	TEMP2=	12
	TEMP=	14
	ERROR=	14
	CHAR=	6
	BFHD=	7
	BYTE=	7
	LNEFLG=	200000		;FLAGS IN LH OF %IOOPN
	INFLG=	040000
	OUTFLG=	020000
	BITFLG=	010000
	STRFLG=	004000

INCHK:	MOVE	CINDEX,@.jbUUO	;GET CHANNEL NUMBER
	JUMPGE	CINDEX,INCHK2	;CHECK FOR VALIDITY
ILLCHN:	MOVEI	ERROR,[ASCIZ/$ - ILLEGAL CHANNEL - $/]
	PUSHJ	%P,%ERROR
	HLRZ	ERROR,CHAN
	PUSHJ	%P,%ERRST
	MOVE	ERROR,CINDEX
	PUSHJ	%P,%ERRNM
	EXIT
INCHK2:	CAIL	CINDEX,^D16
	JRST	ILLCHN
	HRRI	CHAN,(CINDEX)	;SET CHANNEL NUMBER
	IMULI	CINDEX,%IOSIZ	;GET INDEX INTO TABLES
	SKIPGE	TEMP,%IOOPN(CINDEX)
	JRST	.+4		;CHECK CHANNEL OPEN
NOTOPN:	MOVEI	ERROR,[ASCIZ/$ - CHANNEL $ NOT OPEN/]
	MOVEI	CINDEX,(CHAN)
	JRST	ILLCHN+1
	TLNE	TEMP,INFLG	;CHECK OPEN FOR INPUT
	POPJ	%P,
	MOVEI	ERROR,[ASCIZ/$ - CHANNEL $ NOT OPEN FOR INPUT/]
	JRST	NOTOPN+1

OUTCHK:	MOVE	CINDEX,@.jbUUO	;GET CHANNEL NUMBER
	JUMPL	CINDEX,ILLCHN	;CHECK FOR VALIDITY
	CAIL	CINDEX,^D16
	JRST	ILLCHN
	HRRI	CHAN,(CINDEX)	;SET CHANNEL NUMBER
	IMULI	CINDEX,%IOSIZ	;GET INDEX INTO TABLES
	SKIPL	TEMP,%IOOPN(CINDEX)
	JRST	NOTOPN		;CHECK CHANNEL OPEN
	TLNE	TEMP,OUTFLG
	POPJ	%P,		;CHECK OPEN FOR OUTPUT
	MOVEI	ERROR,[ASCIZ/$ - CHANNEL $ NOT OPEN FOR OUTPUT/]
	JRST	NOTOPN+1

%EFILE:	HRLZI	CHAN,[ASCIZ/ENDFILE/]
	PUSHJ	%P,INCHK	;SET UP
	MOVE	TEMP,[STATZ 020000]
	DPB	CHAN,[POINT 4,TEMP,^D12]
	XCT	TEMP		;TEST FOR END OF FILE
	AOS	%UUO		;IF SO, SKIP RETURN
	JRST	%XUUO

%CLRBK:	HRLZI	CHAN,[ASCIZ/SETBREAK/]
	PUSHJ	%P,INCHK	;SET UP
	TLNE	TEMP,STRFLG	;CHECK STRING I/O
	JRST	.+3
BRKERR:	MOVEI	ERROR,[ASCIZ@$ - CHANNEL $ NOT OPEN FOR STRING I/O@]
	JRST	NOTOPN+1
	HRLI	CINDEX,-7	;SETUP FOR AOBJN THROUGH %IOBRK
	SETZM	%IOBRK(CINDEX)
	AOBJN	CINDEX,.-1	;CLEAR BREAK TABLE
	HRLOI	TEMP,37777
	ANDM	TEMP,%IOBRK(CINDEX)	;ADDRESS NOW %IOBRK+7
	JRST	%XUUO		;EXIT

BRKSUP:	HRLZI	CHAN,[ASCIZ/SETBREAK/]
	PUSHJ	%P,INCHK	;SET UP
	TLNN	TEMP,STRFLG	;CHECK STRING I/O
	JRST	BRKERR
	MOVEM	CHAR,%SAVE+CHAR	;SAVE REGISTERS
	MOVEM	BYTE,%SAVE+BYTE
	LDB	TEMP,[POINT 4,.jbUUO,^D12]
	HRLI	TEMP,(TEMP)	;SAVE COPY OF AC FIELD
	ANDCMI	TEMP,1
	MOVE	BYTEPT,(TEMP)	;GET DV
	MOVE	LENGTH,1(TEMP)
	ADDI	BYTEPT,(LENGTH)	;MAKE BYTEPT ADDR ABSOLUTE
	HLRZ	LENGTH,LENGTH	; AND GET LENGTH
	POPJ	%P,		;DONE WITH BREAK SETUP

BRKCON:	SOJL	LENGTH,BRKXIT	;ACTUALLY FILL BREAK TABLE
	ILDB	CHAR,BYTEPT
	IDIVI	CHAR,^D18	;GET WORD AND BYTE #
	ADDI	CHAR,%IOBRK(CINDEX)
	DPB	TEMP,BRKTBL(BYTE)
	JRST	BRKCON		;PROCESS NEXT
BRKXIT:	MOVE	CHAR,%SAVE+CHAR	;RESTORE REGISTERS
	MOVE	BYTE,%SAVE+BYTE
	JRST	%XUUO		;DONE

	.TEMP==	1		;SET UP BYTE POINTER TABLE
BRKTBL:	REPEAT	^D18,
<	POINT	2,(CHAR),.TEMP
	.TEMP==	.TEMP+2>

%BRK0:	PUSHJ	%P,BRKSUP	;SETUP
	TLNN	TEMP,1		;AC ODD OR EVEN
	SKIPA	TEMP,[0]
	MOVEI	TEMP,2
	JRST	BRKCON		;SET VALUE ACCORDINGLY

%BRK1:	PUSHJ	%P,BRKSUP	;SETUP
	TLNN	TEMP,1		;AC ODD OR EVEN
	SKIPA	TEMP,[1]
	MOVEI	TEMP,3
	JRST	BRKCON		;SET VALUE ACCORDINGLY

%RDLST:%WRLST:
	MOVEI	ERROR,[ASCIZ@RECORD I/O NOT IMPLEMENTED YET@]
	PUSHJ	%P,%ERROR
	EXIT

%GETBK:	HRLZI	CHAN,[ASCIZ/BREAK/]
	PUSHJ	%P,INCHK	;SETUP
	TLNN	TEMP,STRFLG
	JRST	BRKERR		;CHECK STRING I/O
	LDB	TEMP,[POINT 4,.jbUUO,^D12]
	TRZ	TEMP,1
	MOVE	BYTEPT,(TEMP)	;GET DV
	MOVE	LENGTH,1(TEMP)
	ADDI	BYTEPT,(LENGTH)	;MAKE BYTEPT ADDR ABSOLUTE
	HLRZ	LENGTH,LENGTH	;GET LENGTH
	LDB	TEMP,[POINT 7,%IOBRK+7(CINDEX),^D17]
	SOJL	LENGTH,%XUUO	;NULL STRING
	IDPB	TEMP,BYTEPT
	JRST	BREAK2+2	;STORE IT AND ADJUST LENGTH OR PAD OUT

%GETLN:	HRLZI	CHAN,[ASCIZ/LINENO/]
	PUSHJ	%P,INCHK	;SETUP
	TLNE	TEMP,LNEFLG	;CHECK LINE NUMBER MODE
	JRST	.+3
LNEERR:	MOVEI	ERROR,[ASCIZ/$ - CHANNEL $ NOT OPEN WITH LINE NUMBERING/]
	JRST	NOTOPN+1
	HRRE	TEMP2,%IOBRK+7(CINDEX)
	LDB	TEMP,[POINT 4,.jbUUO,^D12]
	MOVEM	TEMP2,(TEMP)	;STORE VALUE
	JRST	%XUUO		;DONE

OUTPUT:	SOSG	2(BFHD)		;OUTPUT A CHARACTER
	JRST	.+3
	IDPB	CHAR,1(BFHD)
	POPJ	%P,		;AND RETURN
	MOVE	TEMP,[OUT]	;OR GET BUFFER AND TRY AGAIN
	DPB	CHAN,[POINT 4,TEMP,^D12]
	XCT	TEMP
	JRST	OUTPUT+2
	JUMPG	CINDEX,.+2	;ERROR ON TTY, FATAL
	HALT
	MOVEI	ERROR,[ASCIZ/$ - $:$$$ OUTPUT ERROR - STATUS $/]
EDTSTS:	PUSHJ	%P,%ERROR
	HLRZ	ERROR,CHAN
	PUSHJ	%P,%ERRST
	MOVE	ERROR,%IOOPN+1(CINDEX)
	PUSHJ	%P,%ERRSB
	MOVE	ERROR,%IOLEB(CINDEX)
	JUMPE	ERROR,.+7	;EDIT MESSAGE WITH OR WITHOUT FILE NAME
	PUSHJ	%P,%ERRSB
	MOVEI	ERROR,[ASCIZ/./]
	PUSHJ	%P,%ERRST
	HLLZ	ERROR,%IOLEB+1(CINDEX)
	PUSHJ	%P,%ERRSB
	JRST	.+7
	MOVEI	ERROR,0
	PUSHJ	%P,%ERRSB
	MOVEI	ERROR,0
	PUSHJ	%P,%ERRSB
	MOVEI	ERROR,0
	PUSHJ	%P,%ERRSB
	MOVE	ERROR,[GETSTS ERROR]
	DPB	CHAN,[POINT 4,ERROR,^D12]
	XCT	ERROR		;GET STATUS
	PUSHJ	%P,%ERROC
	EXIT

%PUTLN:	HLRZI	CHAN,[ASCIZ/OUTLINE/]
	PUSHJ	%P,OUTCHK	;SETUP
	TLNN	TEMP,LNEFLG	;CHECK LINE NUMBERING
	JRST	LNEERR
	MOVEM	CHAR,%SAVE+CHAR	;SAVE REGISTERS
	MOVEM	BFHD,%SAVE+BFHD
	LDB	LINENO,[POINT 4,.jbUUO,^D12]
	SKIPL	LINENO,(LINENO)	;GET AND CHECK LINE NUMBER
	JRST	LNEOK
LNEVAL:	MOVEI	ERROR,[ASCIZ/OUTLINE - $ < 0 OR > 99999/]
	PUSHJ	%P,%ERROR
	MOVE	ERROR,LINENO
	PUSHJ	%P,%ERRNM
	EXIT
LNEOK:	CAILE	LINENO,^D99999
	JRST	LNEVAL
	HLRZ	BFHD,%IOOPN+2(CINDEX)
	LDB	TEMP,[POINT 6,1(BFHD),5]
	CAIE	TEMP,1		;GET OUTPUT ON WORD BOUNDARY
	CAIN	TEMP,^D36
	JRST	.+4
	MOVEI	CHAR,0
	PUSHJ	%P,OUTPUT	;OUTPUT NULLS UNTIL SO
	JRST	LNEOK+3
	PUSHJ	%P,LNEEDT	;OUTPUT LINE NUMBER
	ORM	LINENO,@1(BFHD)	;LINENO LEFT AS 1
	MOVEI	CHAR,011
	PUSHJ	%P,OUTPUT	;OUTPUT TAB AT END
	JRST	OUTXIT		;FORCE BUFFER OUT AND EXIT

LNEEDT:	ADDI	LINENO,^D100000	;TO FORCE FIVE DIGITS
	IDIVI	LINENO,^D10
	CAIN	LINENO,1
	JRST	.+4
	HRLM	DIGIT,(%P)	;REGULAR EDITOR
	PUSHJ	%P,LNEEDT+1
	HLRZ	DIGIT,(%P)
	MOVEI	CHAR,"0"
	ADDI	CHAR,(DIGIT)	;MAKE ASCII
	JRST	OUTPUT		;OUTPUT WILL RETURN

%WRITE:	HRLZI	CHAN,[ASCIZ/OUT/]
	PUSHJ	%P,OUTCHK	;SETUP
	MOVEM	CHAR,%SAVE+CHAR	;SAVE REGISTERS
	MOVEM	BFHD,%SAVE+BFHD
	LDB	CHAR,[POINT 4,.jbUUO,^D12]
	MOVE	BYTEPT,(CHAR)
	MOVE	LENGTH,1(CHAR)	;GET DV
	ADDI	BYTEPT,(LENGTH)	;MAKE BYTEPT ADDR ABSOLUTE
	HLRZ	LENGTH,LENGTH	;GET LENGTH
	HLRZ	BFHD,%IOOPN+2(CINDEX)
	LDB	CHAR,[POINT 6,BYTEPT,^D11]
	CAIN	CHAR,1		;SEE WHAT KIND OF BYTES
	JRST	CHKBIT
	TLNE	TEMP,STRFLG	;WANTS CHARACTERS
	JRST	OUTLP
	MOVEI	ERROR,[ASCIZ@$ - CHANNEL $ NOT OPEN FOR STRING I/O@]
	JRST	NOTOPN+1
CHKBIT:	TLNE	TEMP,BITFLG	;WANTS BITS
	JRST	OUTLP
	MOVEI	ERROR,[ASCIZ@$ - CHANNEL $ NOT OPEN FOR BITS I/O@]
	JRST	NOTOPN+1
OUTLP:	SOJL	LENGTH,OUTXIT	;DO ONE CHARACTER
	ILDB	CHAR,BYTEPT
	PUSHJ	%P,OUTPUT	;OUTPUT IT
	JRST	OUTLP
OUTXIT:	MOVE	CHAR,%SAVE+CHAR	;RESTORE REGISTERS
	MOVE	BFHD,%SAVE+BFHD
	JUMPG	CINDEX,%XUUO	;IF NOT CHANNEL 0, DONE
	OUT	0,
	AOSA	%IOBFH+2	;IF TTY, FORCE OUTPUT
	HALT			;ERROR ON TTY FATAL
	JRST	%XUUO		;NOW DONE

INPUT:	MOVE	TEMP,[STATZ 020000]
	DPB	CHAN,[POINT 4,TEMP,^D12]
	XCT	TEMP		;CHECK END FILE ALREADY
	JRST	FORCEF
	SOSG	2(BFHD)		;INPUT A CHARACTER
	JRST	.+3
	ILDB	CHAR,1(BFHD)
	POPJ	%P,		;AND EXIT
	MOVE	TEMP,[IN]	;OR GET A BUFFER AND TRY AGAIN
	DPB	CHAN,[POINT 4,TEMP,^D12]
	XCT	TEMP
	JRST	INPUT+6
	MOVE	TEMP,[STATZ 020000]
	DPB	CHAN,[POINT 4,TEMP,^D12]
	XCT	TEMP		;CHECK END FILE
	JRST	.+5
	JUMPG	CINDEX,.+2
	HALT			;ERROR ON TTY, FATAL
	MOVEI	ERROR,[ASCIZ/$ - $:$$$ INPUT ERROR - STATUS $/]
	JRST	EDTSTS
	JUMPG	CINDEX,FORCEF	;IF NOT TTY, FORCE END FILE CHAR
	GETSTS	0,ERROR		;ELSE RESET END FILE
	ANDI	ERROR,757777
	SETSTS	0,(ERROR)
	JRST	INPUT+4		;^Z ALREADY RECEIVED
FORCEF:	POP	%P,TEMP		;DISCARD RETURN
	MOVEI	TEMP,032	;FORCE ^Z BREAK CHARACTER
	AOJA	LENGTH,BREAK2+1

%READ:	HRLZI	CHAN,[ASCIZ/IN/]
	PUSHJ	%P,INCHK	;SETUP
	MOVEM	CHAR,%SAVE+CHAR	;SAVE REGISTERS
	MOVEM	BFHD,%SAVE+BFHD
	HRRZ	BFHD,%IOOPN+2(CINDEX)
	LDB	CHAR,[POINT 4,.jbUUO,^D12]
	ANDI	CHAR,16
	MOVE	BYTEPT,(CHAR)	;GET DV
	MOVE	LENGTH,1(CHAR)
	ADDI	BYTEPT,(LENGTH)	;MAKE BYTEPT ADDR ABSOLUTE
	HLRZ	LENGTH,LENGTH	;AND GET LENGTH
	LDB	CHAR,[POINT 6,BYTEPT,^D11]
	CAIE	CHAR,1		;SEE WHAT KIND OF BYTES
	JRST	RDCHAR
	TLNE	TEMP,BITFLG	;BITS EXPECTED
	JRST	.+3
	MOVEI	ERROR,[ASCIZ@$ - CHANNEL $ NOT OPEN FOR BITS I/O@]
	JRST	NOTOPN+1
BITLP:	SOJL	LENGTH,INXIT	;PROCESS BITS
	PUSHJ	%P,INPUT	;GET A BIT
	IDPB	CHAR,BYTEPT	;STORE IT
	JRST	BITLP
INXIT:	MOVE	CHAR,%SAVE+CHAR	;RESTORE REGISTERS
	MOVE	BFHD,%SAVE+BFHD
	JRST	%XUUO		;DONE, EXIT
RDCHAR:	TLNE	TEMP,STRFLG	;CHARACTERS EXPECTED
	JRST	.+3
	MOVEI	ERROR,[ASCIZ@$ - CHANNEL $ NOT OPEN FOR STRING I/O@]
	JRST	NOTOPN+1
	HRLZI	TEMP,177	;RESET BREAK CHARACTER
	ANDCAM	TEMP,%IOBRK+7(CINDEX)
CHARLP:	SOJL	LENGTH,INXIT
	PUSHJ	%P,INPUT	;GET A CHARACTER
	JUMPE	CHAR,.-1	;IGNORE NULLS
	MOVE	TEMP,@1(BFHD)	;SEE IF LINE NUMBER
	TRNN	TEMP,1
	JRST	NOLINE		;NOPE
	MOVE	TEMP,%IOOPN(CINDEX)
	TLNN	TEMP,LNEFLG	;LINE NUMBER MODE
	JRST	NOLINE		;NOPE, JUST CHARACTERS
	SUBI	CHAR,"0"
	HRRM	CHAR,%IOBRK+7(CINDEX)
	REPEAT	4,
<	PUSHJ	%P,INPUT
	HRRZ	TEMP,%IOBRK+7(CINDEX)
	IMULI	TEMP,^D10
	ADDI	TEMP,-"0"(CHAR)
	HRRM	TEMP,%IOBRK+7(CINDEX)>
	PUSHJ	%P,INPUT	;GOT LINE NUMBER, THROW AWAY TAB
	JRST	CHARLP+1	;GET NEXT CHARACTER
NOLINE:	MOVE	TEMP,BFHD	;SAVE FOR DIVIDE
	HRLI	TEMP,(CHAR)	;SAVE POSSIBLE BREAK CHAR
	IDPB	CHAR,BYTEPT	;ASSUME WE WANT CHARACTER
	IDIVI	CHAR,^D18
	EXCH	TEMP,BFHD
	ADDI	CHAR,%IOBRK(CINDEX)
	LDB	TEMP,BRKTBL(TEMP)
	JRST	.+1(TEMP)	;GOT BREAK TYPE, DO IT
	JRST	CHARLP		;NORMAL CHARACTER
	JRST	BACKUP		;IGNORE CHARACTER
	JRST	BREAK2		;IS BREAK CHARACTER
	IBP	BYTEPT		;IS BREAK CHARACTER TOO
	IBP	BYTEPT		; BUT BACKUP STUFF SO
	IBP	BYTEPT		; WILL NOT BE READ
	IBP	BYTEPT
	SOJ	BYTEPT,
	AOJA	LENGTH,BREAK2
BACKUP:	IBP	BYTEPT		;IGNORE CHARACTER
	IBP	BYTEPT
	IBP	BYTEPT
	IBP	BYTEPT
	SOJA	BYTEPT,CHARLP+1	;GET NEXT
BREAK2:	HLRZ	TEMP,BFHD	;GET BREAK CHARACTER
	DPB	TEMP,[POINT 7,%IOBRK+7(CINDEX),^D17]
	LDB	TEMP,[POINT 4,.jbUUO,^D12]
	TRZN	TEMP,1		;AFTER STORING CHARACTER,
	JRST	PADOUT		;SEE IF SHOULD ADJUST LENGTH
	HLRZ	TEMP2,1(TEMP)	;OR PAD OUT WITH BLANKS
	SUBI	TEMP2,(LENGTH)
	HRLM	TEMP2,1(TEMP)
	JRST	INXIT		;ADJUSTED LENGTH, EXIT
PADOUT:	MOVEI	CHAR," "
	SOJL	LENGTH,INXIT	;PAD OUT WITH BLANKS
	IDPB	CHAR,BYTEPT
	JRST	PADOUT+1

	PRGEND
	TITLE	%CLOSE -- ALGOLW FILE CLOSE ROUTINE -- MICHAEL GREEN
	HISEG
	ENTRY	%CLOSE
	EXTERN	%IOOPN,%IOLEB,%IOPRO,%IOREG,%AVIOB
	EXTERN	%SREG,%NREG,%LREG,%ERROR,%ERRNM,%COLLE,%IOSIZ
	EXTERN	%XUUO,%ERRSB,%IOPP,%ERRST
	EXTERN	.jbUUO
	%P=	17
	CHAN=	10
	CINDEX=	11
	TEMP1=	12
	TEMP2=	11
	REGPT=	13
	ERROR=	14
	REWFLG=	002000		;FLAGS IN LH OF %IOOPN

%CLOSE:	MOVE	CHAN,@.jbUUO	;GET CHANNEL NUMBER
	JUMPG	CHAN,CHANGR	;CHECK CHAN>0
	MOVEI	ERROR,[ASCIZ/CLOSE - ILLEGAL CHANNEL - $/]
	PUSHJ	%P,%ERROR
	MOVE	ERROR,CHAN
	PUSHJ	%P,%ERRNM	;EDIT ERROR MESSAGE
	EXIT			;QUIT

CHANGR:	CAIL	CHAN,^D16	;CHECK CHAN<16
	JRST	%CLOSE+2
	MOVEI	CINDEX,(CHAN)	;INDEX INTO TABLES
	IMULI	CINDEX,%IOSIZ
	SKIPGE	%IOOPN(CINDEX)	;IS CHANNEL OPEN?
	JRST	CHANOK
	MOVEI	ERROR,[ASCIZ/CLOSE - CHANNEL $ NOT OPEN/]
	PUSHJ	%P,%ERROR
	MOVE	ERROR,CHAN
	PUSHJ	%P,%ERRNM	;EDIT ERROR MESSAGE
	EXIT			;QUIT

CHANOK:	MOVE	TEMP1,[CLOSE]	;CLOSE CHANNEL
	DPB	CHAN,[POINT 4,TEMP1,^D12]
	XCT	TEMP1
	MOVE	TEMP1,[STATZ 740000]	;CHECK CLOSE STATUS
	DPB	CHAN,[POINT 4,TEMP1,^D12]
	XCT	TEMP1
	JRST	CLOSER		;ERROR ON CLOSE
	MOVE	TEMP1,%IOOPN(CINDEX)
	TLNN	TEMP1,REWFLG	;UNLOAD ON CLOSE?
	JRST	RENAME
	MOVE	TEMP1,[MTAPE 11]
	DPB	CHAN,[POINT 4,TEMP1,^D12]
	XCT	TEMP1		;YES, DO IT

RENAME:	SKIPGE	TEMP1,%IOPRO(CINDEX)
	JRST	NORENA		;SEE IF RENAME AFTER CLOSE
	MOVE	ERROR,%IOLEB(CINDEX)
	MOVEM	ERROR,%IOPRO(CINDEX)	;SAVE FILE NAME
	CAIG	TEMP1,777	;IS FILE TO BE DELETED
	JRST	.+3
	SETZM	%IOLEB(CINDEX)	;YES
	JRST	.+2		;ELSE JUST CHANGE PROTECTION
	DPB	TEMP1,[POINT ^D9,%IOLEB+2(CINDEX),^D8]
	MOVE	TEMP1,%IOPP(CINDEX)
	MOVEM	TEMP1,%IOLEB+3(CINDEX)	;RESTORE PROJ-PROG
RERE:	MOVE	TEMP1,[RENAME %IOLEB(CINDEX)]
	DPB	CHAN,[POINT 4,TEMP1,^D12]
	XCT	TEMP1
	JRST	RENERR		;ERROR ON RENAME

NORENA:	MOVE	TEMP1,[RELEAS]	;NOW RELEASE CHANNEL
	DPB	CHAN,[POINT 4,TEMP1,^D12]
	XCT	TEMP1
	HRLOI	TEMP1,377777	;MARK AS CLOSED
	ANDM	TEMP1,%IOOPN(CINDEX)
	MOVE	REGPT,%IOREG(CINDEX)	;MERGE ADJACENT REGIONS
	MOVE	TEMP1,%NREG(REGPT)
	MOVE	TEMP2,%SREG(REGPT)
	EXCH	TEMP2,%SREG+1(REGPT)
	SUBI	TEMP2,1(TEMP1)	;SET UP BUFFER AS STORAGE BLOCK
	HRLI	TEMP2,400000
	MOVSM	TEMP2,(TEMP1)
	MOVEI	TEMP1,0
	MOVEI	TEMP2,^D16	;ADJUST I/O REGION POINTERS
	CAMGE	REGPT,%IOREG(TEMP1)
	SOS	%IOREG(TEMP1)	;IS ABOVE MERGED REGION
	ADDI	TEMP1,%IOSIZ
	SOJG	TEMP2,.-3	;DO NEXT

CLOREG:	CAML	REGPT,%AVIOB	;NOW MOVE OTHER AREAS DOWN
	JRST	ENDCLO
	MOVE	TEMP1,%SREG+1(REGPT)
	MOVEM	TEMP1,%SREG(REGPT)
	MOVE	TEMP1,%LREG+1(REGPT)
	MOVEM	TEMP1,%LREG(REGPT)
	MOVE	TEMP1,%NREG+1(REGPT)
	MOVEM	TEMP1,%NREG(REGPT)
	AOJA	REGPT,CLOREG

ENDCLO:	SOS	%AVIOB		;ONE LESS REGION
	PUSHJ	%P,%COLLE	;FORCE GARBAGE COLLECTION TO CLOSE
	MOVEI	TEMP1,0		;FIND HOW MUCH FREE SPACE
	MOVE	REGPT,%AVIOB	; IN ALL BUT LAST REGION
	JUMPE	REGPT,.+3
	ADD	TEMP1,%LREG(REGPT)
	SOJG	REGPT,.-1
	MOVEI	TEMP2,0		;ALLOW EXTRA 1K GROWTH SPACE IF <1K
	CAIG	TEMP1,1777
	MOVEI	TEMP2,2000
	MOVE	REGPT,%AVIOB
	MOVE	TEMP1,%NREG(REGPT)
	ADD	TEMP1,TEMP2	;ALSO ALLOW TO NEXT 1K BOUNDARY
	ORI	TEMP1,1777
	MOVE	TEMP2,%NREG(REGPT)
	SUBM	TEMP1,TEMP2
	ADDI	TEMP2,1
	MOVEM	TEMP2,%LREG(REGPT)	;SET NEW FREE LENGTH
	CORE	TEMP1,		;ADJUST CORE BOUNDARY
	JRST	.+2
	JRST	%XUUO		;DONE, EXIT
	MOVNI	TEMP1,2000	;TRIED TO GET AT MOST 1K
	ADDB	TEMP1,%LREG(REGPT)
	ADD	TEMP1,%NREG(REGPT)
	SUBI	TEMP1,1		;MUST BE ABLE TO GET CORE WITHOUT
	CORE	TEMP1,		; EXTRA 1K
	HALT
	JRST	%XUUO

CLOSER:	MOVEI	ERROR,[ASCIZ@CLOSE - $:$$$ I/O ERROR DURING CLOSE@]
	PUSHJ	%P,%ERROR
	MOVE	ERROR,%IOOPN+1(CINDEX)
	PUSHJ	%P,%ERRSB
	MOVE	ERROR,%IOLEB(CINDEX)
	JUMPE	ERROR,.+7
	PUSHJ	%P,%ERRSB
	MOVEI	ERROR,[ASCIZ/./]
	PUSHJ	%P,%ERRST
	HLLZ	ERROR,%IOLEB+1(CINDEX)
	PUSHJ	%P,%ERRSB
	EXIT
	MOVEI	ERROR,0
	PUSHJ	%P,%ERRSB
	MOVEI	ERROR,0
	PUSHJ	%P,%ERRSB
	MOVEI	ERROR,0
	PUSHJ	%P,%ERRSB
	EXIT			;PRINT MESSAGE, QUIT

RENERR:	LDB	TEMP1,[POINT ^D12,%IOLEB+1(CINDEX),^D35]
	CAIN	TEMP1,3		;IS FILE IN USE, TRY AGAIN
	JRST	RERE
	MOVEI	ERROR,[ASCIZ@CLOSE - $:$.$ I/O ERROR ON PROTECTION CHANGE OR DELETE@]
	PUSHJ	%P,%ERROR
	MOVE	ERROR,CHAN
	PUSHJ	%P,%ERRNM
	MOVE	ERROR,%IOOPN+1(CINDEX)
	PUSHJ	%P,%ERRSB
	MOVE	ERROR,%IOPRO(CINDEX)
	PUSHJ	%P,%ERRSB
	HLLZ	ERROR,%IOLEB+1(CINDEX)
	PUSHJ	%P,%ERRSB
	EXIT

	PRGEND
	TITLE	%ALLOC -- ALGOLW STORAGE ALLOCATOR -- MICHAEL GREEN
	HISEG
	ENTRY	%ARECD,%ASTRG,%ASTRA,%AARRY,%RARRY,%PROC,%BLOCK,%THUNK
	EXTERN	%COLLE,%STAT,%NREG,%LREG,%AVIOB,%ERROR
	EXTERN	%SAVE,%XUUO,%UUO,%ERRNM,%HDBLK
	EXTERN	.jbUUO
	%T=	14
	%B=	16
	%P=	17
	SIZE=	6
	HEADER=	7
	REGPT=	10
	ARGCNT=	10
	TEMP=	11
	TEMP2=	12
	TEMP3=	13
	ERROR=	14
	RESULT=	14
	ARGTYP=	14

ALLOC:	AOS	%STAT+3		;INCREMENT CALL COUNTS
	AOS	%STAT+30
	MOVEI	TEMP,0
	RUNTIM	TEMP,		;CALCULATE TIME SINCE LAST CALL
	SUBM	TEMP,%STAT
	EXCH	TEMP,%STAT
	ADDM	TEMP,%STAT+10	;TOTAL TIME BETWEEN CALLS
	CAMLE	TEMP,%STAT+11	;MAX TIME BETWEEN CALLS
	MOVEM	TEMP,%STAT+11
	ADDM	SIZE,%STAT+25	;REQUESTS SINCE LAST COLLE
	ADDM	SIZE,%STAT+5	;TOTAL REQUESTS
	CAMLE	SIZE,%STAT+6
	MOVEM	SIZE,%STAT+6	;MAX REQUEST
	MOVE	TEMP,%STAT+7
	ADDI	TEMP,(SIZE)	;CUMULATIVE AVERAGE REQUEST
	LSH	TEMP,-1
	MOVEM	TEMP,%STAT+7
	MOVEI	REGPT,0

ALLOCL:	CAMG	SIZE,%LREG(REGPT);LOOK FOR SPACE IN REGIONS
	JRST	FOUNDS
	CAMGE	REGPT,%AVIOB	;NOT IN THAT ONE, TRY NEXT
	AOJA	REGPT,ALLOCL

;****************************************************************

	PUSHJ	%P,%COLLE	;TEMPORARY DECISION ALGORITHM
	MOVEI	REGPT,0		;COLLECT AND SEARCH FOR ROOM NOW
	MOVEI	TEMP,0		;ALSO SEE HOW MUCH ROOM IF CAN'T FIT

ALLOC2:	CAMG	SIZE,%LREG(REGPT)
	JRST	FOUND2		;FOUND SPACE, GO FREE UP EXTRA SPACE
	ADD	TEMP,%LREG(REGPT)
	CAMGE	REGPT,%AVIOB
	AOJA	REGPT,ALLOC2	;TRY NEXT REGION

	CAIL	TEMP,2000	;AT LEAST 1K FREE
	SKIPA	TEMP,[0]
	MOVEI	TEMP,2000
	MOVEI	TEMP3,(TEMP)
	ADDI	TEMP,(SIZE)
	ADD	TEMP,%NREG(REGPT);FIND NEW END OF STORAGE
	ORI	TEMP,1777	;ROUND UP TO 1K BOUNDARY
	MOVE	TEMP2,%NREG(REGPT)
	SUBM	TEMP,TEMP2	;GET NEW %LREG
	ADDI	TEMP2,1
	MOVEM	TEMP2,%LREG(REGPT)
	CORE	TEMP,
	JRST	.+2		;ERROR, NO MORE CORE
	JRST	FOUNDS		;OK, ALLOCATE BLOCK
	JUMPE	TEMP3,QUIT	;CAN WE GIVE UP 1K PADDING
	MOVNI	TEMP,2000
	ADDB	TEMP,%LREG(REGPT)
	ADD	TEMP,%NREG(REGPT)
	SUBI	TEMP,1
	CORE	TEMP,
	JRST	QUIT		;I GUESS NOT
	JRST	FOUNDS

FOUND2:	MOVE	TEMP3,REGPT	;TOTAL UP ROOM IN REST OF REGIONS
	ADD	TEMP,%LREG(TEMP3)
	CAMGE	TEMP3,%AVIOB
	AOJA	TEMP3,.-2
	CAIL	TEMP,2000(SIZE)	;DON'T COUNT SIZE
	JRST	FOUNDS
	MOVEI	TEMP,2000	;ALLOW 1K GROWTH ROOM
	ADD	TEMP,%NREG(TEMP3);FIND NEW END OF STORAGE
	ORI	TEMP,1777	;ROUND UP TO 1K BOUNDARY
	MOVE	TEMP2,%NREG(TEMP3)
	SUBM	TEMP,TEMP2	;GET NEW %LREG
	ADDI	TEMP2,1
	MOVEM	TEMP2,%LREG(TEMP3)
	CORE	TEMP,
	JRST	.+2		;ERROR, NO MORE CORE
	JRST	FOUNDS		;OK, ALLOCATE BLOCK
	MOVNI	TEMP,2000	;CAN WE GIVE UP 1K PADDING
	ADDB	TEMP,%LREG(TEMP3)
	ADD	TEMP,%NREG(TEMP3)
	SUBI	TEMP,1
	CORE	TEMP,
	JRST	QUIT		;I GUESS NOT
	JRST	FOUNDS

QUIT:	MOVEI	ERROR,[ASCIZ/REQUEST FOR STORAGE, NONE AVAILABLE/]
	PUSHJ	%P,%ERROR
	EXIT

;*****************************************************************

FOUNDS:	MOVNI	TEMP,(SIZE)	;ADJUST REGION FOR ALLOCATED SPACE
	ADDM	TEMP,%LREG(REGPT)
	MOVE	RESULT,%NREG(REGPT)
	ADDM	SIZE,%NREG(REGPT)
	MOVSM	HEADER,(RESULT)	;INITIALIZE STORAGE AREA
	SETZM	1(RESULT)
	MOVEI	TEMP,2(RESULT)	;SET UP FOR BLT
	HRLI	TEMP,1(RESULT)
	ADDI	SIZE,-1(RESULT)
	CAILE	SIZE,(TEMP)	;SKIP IF ONLY ONE WORD
	BLT	TEMP,(SIZE)	;CLEAR BLOCK
	MOVEI	TEMP,0
	RUNTIM	TEMP,		;CALCULATE TIME IN ALLOCATOR
	SUBM	TEMP,%STAT
	EXCH	TEMP,%STAT
	ADDM	TEMP,%STAT+12	;TOTAL TIME IN ALLOCATOR
	CAMLE	TEMP,%STAT+13	;MAX TIME IN ALLOCATOR
	MOVEM	TEMP,%STAT+13
	MOVE	SIZE,%SAVE+SIZE	;RESTORE SIZE AND HEADER
	MOVE	HEADER,%SAVE+HEADER
	ADDI	RESULT,1	;POINTER PAST HEADER
	POPJ	%P,		;DONE, EXIT

%ARECD:	MOVEM	SIZE,%SAVE+SIZE	;SAVE REGISTERS
	MOVEM	HEADER,%SAVE+HEADER
	HRRZ	HEADER,.jbUUO	;GET DESCRIPTOR ADDRESS
	HLRZ	SIZE,(HEADER)	;AND AREA SIZE
	ADDI	SIZE,1		;ACCOUNT FOR HEADER
	PUSHJ	%P,ALLOC	;ALLOCATE CORE
	LDB	TEMP,[POINT 4,.jbUUO,^D12]
	MOVEM	RESULT,(TEMP)
	JRST	%XUUO		;AND EXIT

%RARRY:	SKIPA	TEMP,[XWD 400000,400000]	;REFERENCE ARRAY HEADER
%AARRY:	MOVSI	TEMP,400000	;NON-REFERENCE ARRAY HEADER
	MOVEM	SIZE,%SAVE+SIZE	;SAVE REGISTERS
	MOVEM	HEADER,%SAVE+HEADER
	MOVE	HEADER,TEMP	;GET HEADER CONTROL BITS
	LDB	TEMP,[POINT 4,.jbUUO,^D12]	;GET NO. OF DIMENSIONS
	HRRZ	TEMP2,.jbUUO	;AND DOPE VECTOR ADDRESS
	HLRZ	SIZE,1(TEMP2)	;GET LENGTH (IN WORDS)
	MOVEM	SIZE,2(TEMP2)	;AND SET UP DIMENSION UNITS
ARRYL:	MOVE	SIZE,4(TEMP2)	;UPPER BOUND
	SUB	SIZE,3(TEMP2)	; - LOWER BOUND
	AOJLE	SIZE,NEGDIM	; + 1 = SIZE OF DIMENSION > 0
	MOVEM	SIZE,4(TEMP2)	;SAVE IT FOR SUBSCRIPT CALCULATIONS
	IMUL	SIZE,2(TEMP2)	; * DIMENSION UNITS
	CAIE	TEMP,1
	MOVEM	SIZE,5(TEMP2)	; = NEW DIMENSION UNITS
	ADDI	TEMP2,3		;NEXT DIMENSION
	SOJG	TEMP,ARRYL
	ADDI	SIZE,1		;ALLOW FOR HEADER
	CAIL	SIZE,400000	;MAXIMUM STORAGE ALLOWED
	JRST	TOOBIG
	ADDI	HEADER,-1(SIZE)	;FINISH UP HEADER
	PUSHJ	%P,ALLOC	;ALLOCATE STORAGE
	MOVE	TEMP,%UUO
	MOVEI	TEMP,@-1(TEMP)	;ADDRESS MUST BE INDEXED BY %TB OR %B
	HRRM	RESULT,1(TEMP)	; OR BE IN ABSOLUTE LOCATION
	JRST	%XUUO		;DONE, EXIT

%ASTRA:	MOVEM	SIZE,%SAVE+SIZE	;SAVE REGISTERS
	MOVEM	HEADER,%SAVE+HEADER
	LDB	TEMP,[POINT 4,.jbUUO,^D12]	;GET NO. OF DIMENSIONS
	HRRZ	TEMP2,.jbUUO	;AND DOPE VECTOR ADDRESS
	HLRE	SIZE,1(TEMP2)	;GET LENGTH (IN BYTES)
	JUMPL	SIZE,NEGLEN	; TEST > 0
	MOVEM	SIZE,2(TEMP2)	;AND SET UP DIMENSION UNITS
SARRYL:	MOVE	SIZE,4(TEMP2)	;UPPER BOUND
	SUB	SIZE,3(TEMP2)	; - LOWER BOUND
	AOJLE	SIZE,NEGDIM	; + 1 = SIZE OF DIMENSION > 0
	MOVEM	SIZE,4(TEMP2)	;SAVE IT FOR SUBSCRIPT CALCULATIONS
	IMUL	SIZE,2(TEMP2)	; * DIMENSION UNITS
	CAIE	TEMP,1
	MOVEM	SIZE,5(TEMP2)	; = NEW DIMENSION UNITS
	ADDI	TEMP2,3
	SOJG	TEMP,SARRYL	;NEXT DIMENSION
	JRST	STRING		;SIZE IN BYTES, PROCESS LIKE STRING

%ASTRG:	MOVEM	SIZE,%SAVE+SIZE	;SAVE REGISTERS
	MOVEM	HEADER,%SAVE+HEADER
	HRRZ	TEMP,.jbUUO	;GET DOPE VECTOR ADDRESS
	HLRE	SIZE,1(TEMP)	;AND LENGTH (IN BYTES)
	JUMPL	SIZE,NEGLEN	; TEST > 0
STRING:	JUMPG	SIZE,.+4	;TEST FOR NULL STRING
	MOVE	SIZE,%SAVE+SIZE	;RESTORE REGISTER
	MOVEI	RESULT,0	;NULL POINTER
	JRST	STRSTO
	LDB	TEMP2,[POINT 6,@.jbUUO,^D11]	;GET BYTE SIZE
	MOVEI	TEMP,^D36	;HOW MANY PER WORD?
	IDIVI	TEMP,(TEMP2)
	ADDI	SIZE,-1(TEMP)	;PAD OUT TO END OF WORD
	IDIVI	SIZE,(TEMP)	;NUMBER OF WORDS
	ADDI	SIZE,1		; + 1 FOR HEADER
	CAIL	SIZE,400000	;TEST MAXIMUM SIZE
	JRST	TOOBIG
	MOVEI	HEADER,-1(SIZE)	;SET UP HEADER
	TLO	HEADER,400000	;NON-REFERENCE STORAGE
	PUSHJ	%P,ALLOC	;ALLOCATE STORAGE
STRSTO:	MOVE	TEMP,%UUO	;DOPE VECTOR MUST BE INDEXED
	MOVEI	TEMP,@-1(TEMP)	; BY %TB OR %B OR BE IN ABSOLUTE LOCATION
	HRRM	RESULT,1(TEMP)	;STORE POINTER
	JRST	%XUUO		;AND EXIT

NEGDIM:	MOVEI	ERROR,[ASCIZ/ARRAY DECLARATION - LOWER BOUND $ > UPPER BOUND $/]
	PUSHJ	%P,%ERROR
	MOVE	ERROR,3(TEMP2)
	PUSHJ	%P,%ERRNM
	MOVE	ERROR,4(TEMP2)
	PUSHJ	%P,%ERRNM
	EXIT

TOOBIG:	MOVEI	ERROR,[ASCIZ/ARRAY DECLARATION - ARRAY TOO LARGE/]
	PUSHJ	%P,%ERROR
	EXIT

NEGLEN:	MOVEI	ERROR,[ASCIZ/STRING DECLARATION - LENGTH $ < 0/]
	PUSHJ	%P,%ERROR
	MOVE	ERROR,SIZE
	PUSHJ	%P,%ERRNM
	EXIT

%BLOCK:	MOVEM	SIZE,%SAVE+SIZE	;SAVE REGISTERS
	MOVEM	HEADER,%SAVE+HEADER
	HRRZ	HEADER,.jbUUO	;GET DESCRIPTOR ADDRESS
	HLRZ	SIZE,(HEADER)	;AND SIZE
	ADDI	SIZE,1		;ACCOUNT FOR HEADER
	PUSHJ	%P,ALLOC	;ALLOCATE STORAGE FOR BLOCK
	EXCH	RESULT,%B	;SET NEW BASE
	MOVEM	RESULT,(%B)	;AND SAVE OLD ONE
	HRRZ	TEMP,.jbUUO	;GET DISPLAY SIZE
	HLRZ	TEMP,-1(TEMP)
	JUMPE	TEMP,%XUUO	;NO DISPLAY
	SOJG	TEMP,.+3
	MOVEM	RESULT,3(%B)	;CALLER LEVEL ONLY
	JRST	%XUUO
	MOVEI	TEMP2,3(%B)	;OTHER LEVELS TOO, MOVE THEM
	HRLI	TEMP2,3(RESULT)	; FROM CALLER'S DISPLAY
	ADDI	TEMP,2(%B)
	BLT	TEMP2,(TEMP)
	MOVEM	RESULT,1(TEMP)	;ALSO CALLER LEVEL
	JRST	%XUUO		;EXIT

%THUNK:	MOVEM	SIZE,%SAVE+SIZE	;SAVE REGISTERS
	MOVEM	HEADER,%SAVE+HEADER
	HRRZ	HEADER,.jbUUO	;GET DESCRIPTOR ADDRESS
	HLRZ	SIZE,(HEADER)	;AND SIZE
	ADDI	SIZE,1		;ACCOUNT FOR HEADER
	PUSHJ	%P,ALLOC	;ALLOCATE STORAGE FOR THUNK
	EXCH	RESULT,%B	;SET NEW BASE
	MOVEM	RESULT,(%B)	;AND SAVE OLD ONE
	MOVE	%T,%HDBLK+3	;RESTORE THUNK BASE SAVED BY %UUOTB
	POP	%P,1(%B)	;SAVE THUNK RETURN ADDRESS
	HRRZ	TEMP,.jbUUO	;GET DISPLAY SIZE
	HLRZ	TEMP,-1(TEMP)
	SOJG	TEMP,.+3
	MOVEM	%T,3(%B)	;THUNK IMMEDIATE CONTEXT ONLY
	JRST	%XUUO
	MOVEI	TEMP2,3(%B)	;OTHER LEVELS, MOVE THEM
	HRLI	TEMP2,3(%T)	; FROM THUNK IMMEDIATE CONTEXT DISPLAY
	ADDI	TEMP,2(%B)
	BLT	TEMP2,(TEMP)
	MOVEM	%T,1(TEMP)	;ALSO THUNK IMMEDIATE CONTEXT
	JRST	%XUUO		;EXIT

%PROC:	MOVEM	SIZE,%SAVE+SIZE	;SAVE REGISTERS
	MOVEM	HEADER,%SAVE+HEADER
	HRRZ	HEADER,.jbUUO	;GET DESCRIPTOR ADDRESS
	HLRZ	SIZE,(HEADER)	;AND SIZE
	ADDI	SIZE,1		;ACCOUNT FOR HEADER
	PUSHJ	%P,ALLOC	;ALLOCATE STORAGE
	EXCH	RESULT,%B	;SET NEW BASE
	MOVEM	RESULT,(%B)	;AND SAVE OLD ONE
	POP	%P,1(%B)	;SAVE PROCEDURE RETURN ADDRESS
	POP	%P,2(%B)	;AND ARGUMENT LIST POINTER
	HRRZ	TEMP,.jbUUO	;GET DISPLAY SIZE
	HLRZ	TEMP2,-1(TEMP)
	JUMPE	TEMP2,CHKARG	;NO DISPLAY
	HLRZ	TEMP3,-1(RESULT)
	HLRZ	TEMP3,-1(TEMP3)	;GET PREVIOUS DISPLAY SIZE
	CAIL	TEMP3,(TEMP2)
	JRST	.+4		;IF NOT EXPANDING, JUST COPY
	ADDI	TEMP3,3(%B)
	MOVEM	RESULT,(TEMP3)	;ELSE ADD PREVIOUS LEVEL POINTER
	SOJE	TEMP2,CHKARG	;IF ANY ROOM LEFT, COPY STUFF
	MOVEI	TEMP3,3(%B)	;OTHER LEVELS, MOVE THEM
	HRLI	TEMP3,3(RESULT)	; FROM CALLER'S DISPLAY
	ADDI	TEMP2,2(%B)
	BLT	TEMP3,(TEMP2)

CHKARG:	HLRZ	TEMP,-2(TEMP)	;GET ADDRESS OF ARGUMENT TYPES
	JUMPE	TEMP,%XUUO	;IF ZERO, DON'T BOTHER CHECKING
	MOVE	TEMP2,2(%B)	;GET ARGUMENT LIST POINTER
	JUMPGE	TEMP2,%XUUO	;IF NOT NEGATIVE, NO CHECKING
	HRLI	TEMP,(POINT ^D9,0)	;MAKE BYTE POINTER TO TYPES
	HLRZ	ARGCNT,TEMP2	;GET ARGUMENT COUNT
	LSH	ARGCNT,-5
	ANDI	ARGCNT,17

CHKLP:	ILDB	ARGTYP,TEMP	;GET EXPECTED ARGUMENT TYPE
	SOJL	ARGCNT,CHKEND	;IS PROCEDURE VALUE TYPE
	TRNE	ARGTYP,400	;EXPECT PROCEDURE VALUE TYPE
	JRST	CNTERR		;NO MATCH, MISMATCHED COUNT
	HLRZ	TEMP3,(TEMP2)	;GET PROVIDED TYPE
	LSH	TEMP3,-^D9
	ADDI	TEMP2,4		;POINT TO NEXT ARGUMENT TYPE
	CAIN	ARGTYP,(TEMP3)	;COMPARE TYPES
	JRST	CHKLP		;OK, TRY NEXT
	MOVEI	ERROR,[ASCIZ/IMPROPER TYPE ARGUMENT SUPPLIED TO PROCEDURE/]
	PUSHJ	%P,%ERROR
	EXIT

CHKEND:	TRNN	ARGTYP,400	;PROCEDURE VALUE TYPE EXPECTED
	JRST	CNTERR
	HLRZ	TEMP2,TEMP2	;GET PROCEDURE VALUE TYPE EXPECTED
	LSH	TEMP2,-^D9
	CAIN	ARGTYP,(TEMP2)	;COMPARE TYPES
	JRST	%XUUO		;OK, DONE
	MOVEI	ERROR,[ASCIZ/IMPROPER TYPE PROCEDURE VALUE EXPECTED/]
	PUSHJ	%P,%ERROR
	EXIT

CNTERR:	MOVEI	ERROR,[ASCIZ/IMPROPER NUMBER OF ARGUMENTS SUPPLIED TO PROCEDURE/]
	PUSHJ	%P,%ERROR
	EXIT

	PRGEND
	TITLE	%COLLE -- ALGOLW GARBAGE COLLECTOR -- MICHAEL GREEN
	HISEG
	ENTRY	%COLLE
	EXTERN	%SREG,%LREG,%NREG,%ALREG,%ANREG,%AVIOB
	EXTERN	%HDBLK,%MARK,%STAT,%DYNAM
	%TB=	15
	%B=	16
	%P=	17
	DIMCNT=	6
	TEMP=	7
	REGPT=	10
	HEADER=	11
	VCOUNT=	12
	SIZE=	12
	VPOINT=	13
	AREGPT=	13
	FREED=	13
	POINTR=	14

%COLLE:	PUSH	%P,TEMP		;SAVE TEMP
	PUSH	%P,DIMCNT	; AND DIMCNT
	AOS	%STAT+4		;INCREMENT CALL COUNT
	MOVEI	TEMP,0
	RUNTIM	TEMP,		;FIND RUNTIM
	SUBM	TEMP,%STAT+1	;GET DIFFERENCE
	EXCH	TEMP,%STAT+1
	ADDM	TEMP,%STAT+17	;TOTAL RUNTIM BETWEEN CALLS
	CAMLE	TEMP,%STAT+20
	MOVEM	TEMP,%STAT+20	;MAX RUNTIM BETWEEN CALLS
	MOVE	TEMP,%STAT+25
	SETZM	%STAT+25	;RESET REQUESTS SINCE LAST COLLE
	CAMLE	TEMP,%STAT+26	;MAX REQUESTS SINCE LAST COLLE
	MOVEM	TEMP,%STAT+26
	ADD	TEMP,%STAT+27	;CUMULATIVE AVERAGE OF
	LSH	TEMP,-1		; REQUESTS SINCE LAST COLLE
	MOVEM	TEMP,%STAT+27
	SETZM	%STAT+30	;RESET ALLOC COUNT SINCE LAST COLLE
	HRRZM	%TB,%HDBLK+1	;SET %TB AND %B IN %HDBLK FOR
	HRRZM	%B,%HDBLK+2	; POINTERS INTO THE LIST STRUCTURE
	PUSHJ	%P,%MARK	;MARK ALL ACCESSABLE LIST NODES
	MOVEI	REGPT,0

INITA:	MOVE	TEMP,%NREG(REGPT)	;INITIALIZE %ALREG AND %ANREG
	SUB	TEMP,%SREG(REGPT)	;TO REGION LENGTH AND
	ADD	TEMP,%LREG(REGPT)	;START RESPECTIVELY
	MOVEM	TEMP,%ALREG(REGPT)
	MOVE	TEMP,%SREG(REGPT)
	MOVEM	TEMP,%ANREG(REGPT)
	CAMGE	REGPT,%AVIOB		;SET NEXT REGION
	AOJA	REGPT,INITA
	MOVEI	REGPT,0		;SETUP FOR STORAGE REALLOCATION
	HRROI	TEMP,400000	;MASK

ALLREG:	MOVE	HEADER,%SREG(REGPT)	;GET START OF REGION

NXTCEL:	CAML	HEADER,%NREG(REGPT)	;END OF REGION?
	JRST	NXTREG
	MOVS	SIZE,(HEADER)	;GET BLOCK HEADER
	TLZN	SIZE,400000	;SEE IF THIS IS SIZE
	HLR	SIZE,(SIZE)
	TRZ	SIZE,400000	;KILL TYPE BIT
	ADDI	SIZE,1
	TLZN	SIZE,377777	;IF NOT MARKED, SKIP IT
	JRST	ADVCEL
	MOVEI	AREGPT,0	;LOOK FOR REGION IT CAN FIT INTO
	CAMLE	SIZE,%ALREG(AREGPT)
	AOJA	AREGPT,.-1	;MUST FIND ONE
	MOVE	POINTR,%ANREG(AREGPT)	;GET NEW ADDRESS
	MOVN	SIZE,SIZE	;ADJUST AVAILABLE LENGTH
	ADDM	SIZE,%ALREG(AREGPT)
	MOVN	SIZE,SIZE
	ADDM	SIZE,%ANREG(AREGPT)	;AND AVAILABLE LOCATION
	ANDM	TEMP,(HEADER)	;STORE IT
	ORM	POINTR,(HEADER)
ADVCEL:	ADDI	HEADER,(SIZE)	;TRY NEXT BLOCK
	JRST	NXTCEL

NXTREG:	CAMGE	REGPT,%AVIOB	;TRY NEXT REGION
	AOJA	REGPT,ALLREG

	MOVEI	REGPT,0		;SETUP FOR REASSIGNMENT OF ADDR

REASNR:	MOVE	HEADER,%SREG(REGPT)	;GET START OF REGION

REASNB:	CAML	HEADER,%NREG(REGPT)	;IS END OF REGION
	JRST	ASNREG
	MOVS	VCOUNT,(HEADER)	;GET BLOCK HEADER
	TLZN	VCOUNT,377777	;IF NOT MARKED, SKIP IT
	JRST	NXTBLK
	TLZN	VCOUNT,400000	;IF RECORD, PROCESS
	JRST	RECORD
	TRZN	VCOUNT,400000	;IF NON-REFERENCE, SKIP IT
	JRST	NXTBLK
	MOVEI	VPOINT,1(HEADER);SET UP TO SCAN POINTERS

REASRV:	SOJL	VCOUNT,NXTBLK	;CONTINUE WHILE SIZE>0
	HRRE	POINTR,(VPOINT)	;DON'T CHANGE POINTERS TO HISEG
	JUMPLE	POINTR,REASNV
	CAMG	POINTR,%DYNAM	;OR TO BELOW %DYNAM
	JRST	REASNV
	MOVE	TEMP,-1(POINTR)
	ANDI	TEMP,377777
	ADDI	TEMP,1
	HRRM	TEMP,(VPOINT)	;CHANGE POINTER
REASNV:	AOJA	VPOINT,REASRV	;TRY NEXT

RECORD:	MOVEI	VPOINT,1(HEADER);SET UP FOR RECORD ADJUSTING
	HLLZ	TEMP,1(VCOUNT)	;IF REFERENCE VALUES,
	JUMPE	TEMP,NOREFV
	SUB	VPOINT,TEMP	;SET UP AOBJN AC

RECRVL:	HRRE	POINTR,(VPOINT)	;DON'T CHANGE POINTERS TO HISEG
	JUMPLE	POINTR,RECRVN
	CAMG	POINTR,%DYNAM	;OR TO BELOW %DYNAM
	JRST	RECRVN
	MOVE	TEMP,-1(POINTR)
	ANDI	TEMP,377777
	ADDI	TEMP,1
	HRRM	TEMP,(VPOINT)	;CHANGE POINTER
RECRVN:	AOBJN	VPOINT,RECRVL	;TRY NEXT

NOREFV:	HRRZ	DIMCNT,1(VCOUNT);GET NUMBER OF DV'S
	HRLI	VCOUNT,(POINT 4,0)
	ADDI	VCOUNT,2	;MAKE VCOUNT INTO BYTE POINTER

ARRYDV:	SOJL	DIMCNT,NXTBLK	;DONE WHEN NO MORE DV'S
	ILDB	TEMP,VCOUNT	;GET DIMENSION SIZE
	IMULI	TEMP,3
	HRRE	POINTR,1(VPOINT);DON'T CHANGE ANY POINTERS TO HISEG
	JUMPLE	POINTR,ARRYND
	CAMG	POINTR,%DYNAM	;OR TO BELOW %DYNAM
	JRST	ARRYND
	MOVE	POINTR,-1(POINTR)
	ANDI	POINTR,377777
	ADDI	POINTR,1
	HRRM	POINTR,1(VPOINT);CHANGE POINTER
ARRYND:	ADDI	VPOINT,2(TEMP)	;AND TRY NEXT
	JRST	ARRYDV

NXTBLK:	MOVS	SIZE,(HEADER)	;SKIP TO NEXT BLOCK
	TLNN	SIZE,400000	;SEE IF THIS IS SIZE
	HLR	SIZE,(SIZE)
	ANDI	SIZE,377777	;TRIM OFF CONTROL BITS
	ADDI	HEADER,1(SIZE)
	JRST	REASNB

ASNREG:	CAMGE	REGPT,%AVIOB	;PROCESSED ALL REGIONS?
	AOJA	REGPT,REASNR

	HLRZ	SIZE,%HDBLK	;ADJUST %HDBLK POINTERS
	ANDI	SIZE,377777	;SETUP AOBJN POINTER
	MOVN	SIZE,SIZE
	HRLZI	SIZE,(SIZE)
	HRRI	SIZE,%HDBLK+1
HDBLKL:	HRRE	TEMP,(SIZE)	;ADJUST POINTER
	JUMPLE	TEMP,.+7	;IF NOT POINTING TO HISEG
	CAMG	TEMP,%DYNAM	; AND NOT BELOW %DYNAM
	JRST	.+5
	HRRZ	TEMP,-1(TEMP)
	ANDI	TEMP,377777	;GET RID OF CONTROL BIT
	ADDI	TEMP,1
	HRRM	TEMP,(SIZE)	;AND STORE NEW POINTER
	AOBJN	SIZE,HDBLKL	;GO FOR NEXT

	HRRE	TEMP,%TB	;ADJUST %TB
	JUMPLE	TEMP,.+6	;IF NOT POINTING TO HISEG
	CAMG	TEMP,%DYNAM	; AND NOT BELOW %DYNAM
	JRST	.+4
	HRR	%TB,-1(%TB)
	TRZ	%TB,400000	;CLEAR CONTROL BIT
	ADDI	%TB,1

	HRRE	TEMP,%B		;ADJUST %B
	JUMPLE	TEMP,.+6	;IF NOT POINTING TO HISEG
	CAMG	TEMP,%DYNAM	; AND NOT BELOW %DYNAM
	JRST	.+4
	HRR	%B,-1(%B)
	TRZ	%B,400000	;CLEAR CONTROL BIT
	ADDI	%B,1

	MOVEI	REGPT,0		;SETUP FOR MOVE OF BLOCKS
	MOVEI	FREED,0		;HOW MUCH WAS FREED BY COLLECTING?

MOVENR:	MOVE	HEADER,%SREG(REGPT)	;START OF REGION
	HRROI	TEMP,400000	;GET MASK TO UNMARK BLOCKS

MOVENB:	CAML	HEADER,%NREG(REGPT)	;IS END OF REGION?
	JRST	MOVEAR
	MOVE	POINTR,(HEADER)	;GET NEW ADDRESS
	ANDI	POINTR,377777
	JUMPE	POINTR,MOVEAB	;IF ZERO, IGNORE
	ANDM	TEMP,(HEADER)	;UNMARK BLOCK
	CAIL	POINTR,(HEADER)	;DON'T MOVE IF IN SAME PLACE
	JRST	MOVEAB
	HRLI	POINTR,(HEADER)	;SET BLT SOURCE
	MOVS	SIZE,(HEADER)	;GET BLOCK DESCRIPTOR
	TLNN	SIZE,400000	;SEE IF THIS IS SIZE
	HLR	SIZE,(SIZE)
	ANDI	SIZE,377777	;CLEAR CONTROL BITS
	ADDI	HEADER,1(SIZE)	;ADVANCE TO NEXT BLOCK
	ADDI	SIZE,(POINTR)	;SET BLT END DESTINATION
	BLT	POINTR,(SIZE)	;MOVE BLOCK
	JRST	MOVENB		;TRY NEXT ONE

MOVEAB:	MOVS	SIZE,(HEADER)	;GET BLOCK DESCRIPTOR
	TLNN	SIZE,400000	;SEE IF THIS IS SIZE
	HLR	SIZE,(SIZE)
	ANDI	SIZE,377777	;CLEAR CONTROL BITS
	ADDI	HEADER,1(SIZE)	;ADVANCE TO NEXT BLOCK
	JRST	MOVENB

MOVEAR:	ADD	FREED,%ALREG(REGPT)	;FREED STORAGE IN EACH REGION
	SUB	FREED,%LREG(REGPT)
	MOVE	TEMP,%ALREG(REGPT)	;SET NEW %LREG
	MOVEM	TEMP,%LREG(REGPT)
	MOVE	TEMP,%ANREG(REGPT)	;AND NEW %NREG
	MOVEM	TEMP,%NREG(REGPT)
	CAMGE	REGPT,%AVIOB	;ANY MORE REGIONS?
	AOJA	REGPT,MOVENR

	ADDM	FREED,%STAT+14	;TOTAL FREED STORAGE
	CAMLE	FREED,%STAT+15
	MOVEM	FREED,%STAT+15	;MAX FREED STORAGE
	ADD	FREED,%STAT+16
	LSH	FREED,-1	;CUMULATIVE AVERAGE
	MOVEM	FREED,%STAT+16	; OF FREED STORAGE
	MOVEI	TEMP,0
	RUNTIM	TEMP,		;FIND RUNTIM
	SUBM	TEMP,%STAT+1	;GET DIFFERENCE
	EXCH	TEMP,%STAT+1
	ADDM	TEMP,%STAT+21	;TOTAL RUNTIM IN COLLE
	CAMLE	TEMP,%STAT+22
	MOVEM	TEMP,%STAT+22	;MAX RUNTIM IN COLLE
	POP	%P,DIMCNT
	POP	%P,TEMP		;RESTORE TEMP AND DIMCNT
	POPJ	%P,		;DONE, EXIT

	PRGEND
	TITLE	%MARK -- ALGOLW LIST CELL MARKER -- MICHAEL GREEN
	HISEG
	ENTRY	%MARK
	EXTERN	%HDBLK,%DYNAM
	%P=	17
	DIMCNT=	6
	TEMP=	7
	TOP=	10
	HEADER=	11
	VCOUNT=	12
	VPOINT=	13
	POINTR=	14

%MARK:	PUSH	%P,TEMP		;SAVE TEMP
	PUSH	%P,DIMCNT	;AND DIMCNT
	MOVEI	TOP,%HDBLK+1	;INITIALIZE PUSH DOWN LIST

POPSTK:	MOVEI	HEADER,(TOP)	;POP TOP ENTRY
	CAIN	HEADER,1
	JRST	MARKEX		;ONE MEANS DONE (RH OF %HDBLK)
	HRRZ	TOP,-1(TOP)
	ANDI	TOP,377777
	MOVS	VCOUNT,-1(HEADER)	;GET BLOCK HEADER
	TLNN	VCOUNT,400000	;SEE IF RECORD
	JRST	RECORD
	TRNN	VCOUNT,400000	;IF NON-REFERENCE ARRAY, TRY NEXT
	JRST	POPSTK
	MOVEI	VPOINT,(HEADER)	;SET UP FOR SCAN OF VALUES
	ANDI	VCOUNT,377777

MARKRV:	SOJL	VCOUNT,POPSTK	;CONTINUE WHILE SIZE>0
	HRRE	POINTR,(VPOINT)	;DON'T MARK ANY POINTERS TO HISEG
	JUMPLE	POINTR,MARKNV
	CAMG	POINTR,%DYNAM	;OR TO BELOW %DYNAM
	JRST	MARKNV
	MOVE	TEMP,-1(POINTR)
	TRNE	TEMP,377777	;IS IT MARKED ALREADY
	JRST	MARKNV
	ORM	TOP,-1(POINTR)
	MOVE	TOP,POINTR	;ELSE PUSH ONTO STACK
MARKNV:	AOJA	VPOINT,MARKRV	;TRY NEXT

RECORD:	MOVEI	VPOINT,(HEADER)	;SET UP FOR RECORD MARKING
	HLLZ	TEMP,1(VCOUNT)	;IF REFERENCE VALUES,
	JUMPE	TEMP,NOREFV	; SET UP AOBJN AC
	SUB	VPOINT,TEMP

RECRFV:	HRRE	POINTR,(VPOINT)	;DON'T MARK ANY POINTERS TO HISEG
	JUMPLE	POINTR,RECRNV
	CAMG	POINTR,%DYNAM	;OR TO BELOW %DYNAM
	JRST	RECRNV
	MOVE	TEMP,-1(POINTR)	;IS IT MARKED ALREADY
	TRNE	TEMP,377777
	JRST	RECRNV
	ORM	TOP,-1(POINTR)
	MOVE	TOP,POINTR	;ELSE PUSH ONTO STACK
RECRNV:	AOBJN	VPOINT,RECRFV	;AND TRY NEXT

NOREFV:	HRRZ	DIMCNT,1(VCOUNT)	;GET NUMBER OF DV'S
	HRLI	VCOUNT,(POINT 4,0)
	ADDI	VCOUNT,2	;MAKE VCOUNT INTO BYTE POINTER

ARRYDV:	SOJL	DIMCNT,POPSTK	;DONE WHEN NO MORE DV'S
	ILDB	TEMP,VCOUNT	;GET DIMENSION SIZE
	IMULI	TEMP,3
	HRRE	POINTR,1(VPOINT);DON'T MARK ANY POINTERS TO HISEG
	JUMPLE	POINTR,ARRYND
	CAMG	POINTR,%DYNAM	;OR TO BELOW %DYNAM
	JRST	ARRYND
	HRL	TEMP,-1(POINTR)	;SEE IF ALREADY MARKED
	TLNE	TEMP,377777
	JRST	ARRYND
	ORM	TOP,-1(POINTR)
	MOVE	TOP,POINTR	;ELSE PUSH ONTO STACK
ARRYND:	ADDI	VPOINT,2(TEMP)	;AND TRY NEXT
	JRST	ARRYDV	

MARKEX:	POP	%P,DIMCNT
	POP	%P,TEMP		;DONE, RESTORE TEMP AND DIMCNT
	POPJ	%P,		;EXIT

	PRGEND
	TITLE	%ERROR -- ALGOLW ERROR MESSAGE EDITOR -- MICHAEL GREEN
	HISEG
	ENTRY	%ERROR,%ERRNM,%ERROC,%ERRSB,%USRER,%ERRST
	EXTERN	%ERRPT,%UUO,%DCSAV,%XUUO
	EXTERN	.jbUUO
	%B=	16
	%P=	17
	BASE=	10
	LINENO=	11
	HEADER=	12
	WORK=	13
	ERROR=	14
	LENGTH=	10
	CHAR=	11
	BYTEPT=	12
	LNEADR=	12

%ERROR:	TTCALL	3,[BYTE (7) 015,012,0]
	HRLI	ERROR,(POINT 7,0)	;MAKE BYTE POINTER
	MOVEM	ERROR,%ERRPT	;AND SAVE IT

ERRPRT:	ILDB	ERROR,%ERRPT	;PRINT MESSAGE, EXIT ON "$"
	CAIN	ERROR,"$"
	POPJ	%P,
	JUMPE	ERROR,ENDSTR	;END OF MESSAGE
	TTCALL	1,ERROR
	JRST	ERRPRT		;PRINT IT AND GET NEXT

%ERRNM:	PUSH	%P,WORK		;PRINT NUMBER
	PUSHJ	%P,PRTNUM
	POP	%P,WORK		;USE ONLY ERROR
	JRST	ERRPRT

%ERROC:	PUSH	%P,WORK		;PRINT OCTAL NUMBER
	PUSHJ	%P,PRTOCT
	POP	%P,WORK		;USE ONLY ERROR
	JRST	ERRPRT

PRTOCT:	MOVE	WORK,ERROR
	IDIVI	WORK,^D8	;USUAL RECURSIVE EDITOR
	JUMPE	WORK,.+4	;ALWAYS PRINT ONE DIGIT
	HRLM	ERROR,(%P)
	PUSHJ	%P,PRTOCT+1	;SAVE DIGITS IN STACK
	HLRZ	ERROR,(%P)
	ADDI	ERROR,"0"	;MAKE ASCII
	TTCALL	1,ERROR
	POPJ	%P,		;OUTPUT AND RETURN

PRTNUM:	JUMPGE	ERROR,.+2	;DECIMAL EDITOR, CHECK SIGN
	TTCALL	1,["-"]
	MOVM	WORK,ERROR	;USUAL RECURSIVE ONE
	IDIVI	WORK,^D10
	JUMPE	WORK,.+4	;ALWAYS PRINT ONE DIGIT
	HRLM	ERROR,(%P)
	PUSHJ	%P,PRTNUM+3	;SAVE DIGITS IN STACK
	HLRZ	ERROR,(%P)
	ADDI	ERROR,"0"	;MAKE ASCII
	TTCALL	1,ERROR
	POPJ	%P,		;OUTPUT AND RETURN

%ERRSB:	PUSH	%P,WORK		;PRINT SIXBIT WORD
	JUMPN	ERROR,.+3	;NOTHING IF ZERO
	POP	%P,WORK
	JRST	ERRPRT
	MOVEI	WORK,1		;HIGH ORDER BIT
	LSHC	WORK,6		;NEXT SIX BITS
	TRC	WORK,40		;MAKE ASCII
	TTCALL	1,WORK
	JRST	%ERRSB+1	;OUTPUT, TRY NEXT

%ERRST:	TTCALL	3,(ERROR)	;ASCIZ STRING
	JRST	ERRPRT

%USRER:	TTCALL	3,[BYTE (7) 015,012,0]
	HRRZ	ERROR,.jbUUO	;USER CALL - STRING DV
	MOVE	BYTEPT,(ERROR)
	HLRZ	LENGTH,1(ERROR)	;GET BYTE POINTER AND LENGTH
	HRRZ	WORK,1(ERROR)
	ADDI	BYTEPT,(WORK)	;GET ACTUAL ADDRESS
	JUMPE	LENGTH,.+5	;NO MESSAGE IF NULL
	ILDB	CHAR,BYTEPT
	TTCALL	1,CHAR		;OUTPUT CHARACTER
	SOJG	LENGTH,.-2	;GET NEXT
	TTCALL	3,[BYTE (7) 015,012,0]
	PUSHJ	%P,ENDSTR+1	;CALL TRACEBACK STUFF
	EXIT			;NO RETURN TO USER

ENDSTR:	TTCALL	3,[BYTE (7) 015,012,0]	;CRLF
	SKIPN	ERROR,%DCSAV
	MOVE	ERROR,%UUO	;FIND POINT OF CALL
	JUMPE	%B,NOBASE	;ERROR IN RESET OR ALLOC
	MOVE	BASE,%B
	TTCALL	3,[ASCIZ/?ERROR OCCURRED IN /]
TRACE:	HLRZ	HEADER,-1(BASE)	;GET DESCRIPTOR INFO
	HRRZ	WORK,-1(HEADER)	;LIKE PROCEDURE NAME
	TTCALL	3,(WORK)
	HRRZ	WORK,-2(HEADER)	;SEE IF LINE NUMBER TABLE
	JUMPN	WORK,EDTLNE
NOLINE:	TTCALL	3,[ASCIZ/ AT LOCATION /]
	SUBI	ERROR,1
	ANDI	ERROR,777777	;EDIT ABSOLUTE ADDRESS
	PUSHJ	%P,PRTOCT
	JRST	ENDERL		;LOOK FOR CALLER
EDTLNE:	HRLI	WORK,(POINT ^D18,0)
	MOVEI	LINENO,1	;SET UP FOR SEARCH OF TABLE
	ILDB	LNEADR,WORK	;FIND FIRST LINE
	CAIL	LNEADR,140
	JRST	.+3
	ADDI	LINENO,(LNEADR)	;NOT ADDRESS, LINE INCREMENT
	JRST	.-4
	CAILE	LNEADR,-1(ERROR)	;ADDRESS IN TABLE
	JRST	NOLINE
LOOKLP:	ILDB	LNEADR,WORK	;SEARCH FOR MATCH
	JUMPE	LNEADR,NOLINE	;END OF TABLE
	CAIL	LNEADR,140
	JRST	.+3
	ADDI	LINENO,(LNEADR)	;NOT ADDRESS, LINE INCREMENT
	JRST	LOOKLP
	CAIG	LNEADR,-1(ERROR)
	AOJA	LINENO,LOOKLP	;NO MATCH, INCREMENT LINE NO
	TTCALL	3,[ASCIZ/ IN LINE /]
	MOVE	ERROR,LINENO
	PUSHJ	%P,PRTNUM	;EDIT LINE NUMBER
ENDERL:	TTCALL	3,[BYTE (7) 015,012,0]	;CRLF
NXTLVL:	MOVE	ERROR,1(BASE)	;GET CALLER
	MOVE	BASE,(BASE)	;AND HIS BASE
	JUMPE	BASE,EREXIT	;NONE, THEN DONE
	JUMPE	ERROR,NXTLVL	;NO CALLER, TRY NEXT LEVEL
	TTCALL	3,[ASCIZ/CALLED FROM /]
	JRST	TRACE		;EDIT STUFF

NOBASE:	TTCALL	3,[ASCIZ/?ERROR OCCURRED AT LOCATION /]
	SUBI	ERROR,1
	ANDI	ERROR,777777
	PUSHJ	%P,PRTOCT	;EDIT ABSOLUTE ADDRESS
	TTCALL	3,[BYTE (7) 015,012,0]	;CRLF

EREXIT:	POPJ	%P,		;RETURN TO USER

	PRGEND
	TITLE	%ARITH -- ALGOLW ARITHMETIC ROUTINES -- MICHAEL GREEN
	HISEG
	ENTRY	%DADD,%DSUB,%DMULT,%DDIV,%CMULT,%CDIV,%DCMUL,%DCDIV
	ENTRY	%FIX,%FLOAT,%DFIX,%DFLOT
	EXTERN	%XUUO,%SAVE,%UUO,%DCSAV,%HDBLK
	EXTERN	.jbUUO
	%P=	17
	T=	7
	A=	10
	MBASE=	13
	ACBASE=	12
	RESULT=	14
	AC0=	0
	AC1=	2
	AC2=	4
	ACAC=	6
	MAC=	7
	OPDEF	DADD	[BYTE (9) 15]
	OPDEF	DSUB	[BYTE (9) 16]
	OPDEF	DMUL	[BYTE (9) 17]
	OPDEF	DDIV	[BYTE (9) 20]

%DADD:	LDB	ACBASE,[POINT 4,.jbUUO,^D12]
	TRZN	ACBASE,1	;SET AC, DESTINATION
	SKIPA	RESULT,ACBASE
	HRRZ	RESULT,.jbUUO	;AC OR MEMORY
	MOVE	A,(ACBASE)
	MOVE	A+1,1(ACBASE)	;SETUP
	HRRZ	MBASE,.jbUUO
	UFA	A+1,1(MBASE)	;TAKEN FROM PDP-10 HANDBOOK
	FADL	A,(MBASE)
	UFA	A+1,A+2
	FADL	A,A+2
	MOVEM	A,(RESULT)	;STORE RESULT
	MOVEM	A+1,1(RESULT)
	JRST	%XUUO		;EXIT

%DSUB:	LDB	ACBASE,[POINT 4,.jbUUO,^D12]
	TRZN	ACBASE,1	;SET AC, DESTINATION
	SKIPA	RESULT,ACBASE
	HRRZ	RESULT,.jbUUO	;AC OR MEMORY
	MOVE	A,(ACBASE)
	MOVE	A+1,1(ACBASE)	;SETUP
	HRRZ	MBASE,.jbUUO
	DFN	A,A+1		;NEGATE
	UFA	A+1,1(MBASE)	;COPY OF ADD ROUTINE
	FADL	A,(MBASE)
	UFA	A+1,A+2
	FADL	A,A+2
	DFN	A,A+1		;NEGATE ANSWER
	MOVEM	A,(RESULT)	;STORE RESULT
	MOVEM	A+1,1(RESULT)
	JRST	%XUUO		;EXIT

%DMULT:	LDB	ACBASE,[POINT 4,.jbUUO,^D12]
	TRZN	ACBASE,1	;SET AC, DESTINATION
	SKIPA	RESULT,ACBASE
	HRRZ	RESULT,.jbUUO	;AC OR MEMORY
	MOVE	A,(ACBASE)
	MOVE	A+1,1(ACBASE)	;SETUP
	HRRZ	MBASE,.jbUUO
	MOVEM	A,A+2		;ALSO TAKEN FROM PDP-10 HANDBOOK
	FMPR	A+2,1(MBASE)
	FMPR	A+1,(MBASE)
	UFA	A+1,A+2
	FMPL	A,(MBASE)
	UFA	A+1,A+2
	FADL	A,A+2
	MOVEM	A,(RESULT)	;STORE RESULT
	MOVEM	A+1,1(RESULT)
	JRST	%XUUO		;EXIT

%DDIV:	LDB	ACBASE,[POINT 4,.jbUUO,^D12]
	TRZN	ACBASE,1	;SET AC, DESTINATION
	SKIPA	RESULT,ACBASE
	HRRZ	RESULT,.jbUUO	;AC OR MEMORY
	MOVE	A,(ACBASE)
	MOVE	A+1,1(ACBASE)	;SETUP
	HRRZ	MBASE,.jbUUO
	FDVL	A,(MBASE)	;TAKEN FROM PDP-10 HANDBOOK
	MOVN	A+2,A
	FMPR	A+2,1(MBASE)
	UFA	A+1,A+2
	FDVR	A+2,(MBASE)
	FADL	A,A+2
	MOVEM	A,(RESULT)	;STORE RESULT
	MOVEM	A+1,1(RESULT)
	JRST	%XUUO		;EXIT

%CMULT:	LDB	ACBASE,[POINT 4,.jbUUO,^D12]
	TRZN	ACBASE,1	;SET AC, DESTINATION
	SKIPA	RESULT,ACBASE
	HRRZ	RESULT,.jbUUO	;AC OR MEMORY
	HRRZ	MBASE,.jbUUO
	MOVE	A,(ACBASE)	;(A+BI)(C+DI)=
	FMPR	A,(MBASE)	; (AC-BD)+(AD+BC)I
	MOVE	A+1,1(ACBASE)
	FMPR	A+1,1(MBASE)
	FSBR	A,A+1
	MOVE	A+1,(ACBASE)
	FMPR	A+1,1(MBASE)
	MOVE	A+2,1(ACBASE)
	FMPR	A+2,(MBASE)
	FADR	A+1,A+2
	MOVEM	A,(RESULT)	;STORE RESULT
	MOVEM	A+1,1(RESULT)
	JRST	%XUUO		;EXIT

%CDIV:	PUSH	%P,T		;SAVE WORK REGISTER
	LDB	ACBASE,[POINT 4,.jbUUO,^D12]
	TRZN	ACBASE,1	;AC OR MEMORY
	SKIPA	RESULT,ACBASE
	HRRZ	RESULT,.jbUUO
	HRRZ	MBASE,.jbUUO
	MOVE	T,(MBASE)	;(A+BI)/(C+DI)=
	FMPR	T,T		; ((AC+BD)+(BC-AD)I)/(CC+DD)
	MOVE	A,1(MBASE)
	FMPR	A,A
	FADR	T,A
	MOVE	A,(ACBASE)
	FMPR	A,(MBASE)
	MOVE	A+1,1(ACBASE)
	FMPR	A+1,1(MBASE)
	FADR	A,A+1
	FDVR	A,T
	MOVE	A+1,1(ACBASE)
	FMPR	A+1,(MBASE)
	MOVE	A+2,(ACBASE)
	FMPR	A+2,1(MBASE)
	FSBR	A+1,A+2
	FDVR	A+1,T
	POP	%P,T
	MOVEM	A,(RESULT)	;STORE RESULT
	MOVEM	A+1,1(RESULT)
	JRST	%XUUO

%DCMUL:	MOVEI	RESULT,%SAVE	;SAVE REGISTERS
	BLT	RESULT,%SAVE+7
	MOVE	RESULT,%UUO	;SETUP FOR RECURSIVE CALL ON %ARITH
	MOVEM	RESULT,%DCSAV
	MOVE	RESULT,%HDBLK+3
	LDB	ACAC,[POINT 4,.jbUUO,^D12]
	TRZN	ACAC,1		;SET AC, DESTINATION
	SKIPA	MAC,ACAC
	HRRZ	MAC,.jbUUO	;AC OR MEMORY
	HRLI	ACAC,(MAC)	;SAVE DESTINATION
	HRRZ	MAC,.jbUUO
	CAIG	MAC,17		;MEMORY IS SAVED
	ADDI	MAC,%SAVE
	MOVE	AC0,%SAVE(ACAC)	;SAME AS %CMULT BUT DOUBLE PRECISION
	MOVE	AC0+1,%SAVE+1(ACAC)
	DMUL	AC0,(MAC)
	MOVE	AC1,%SAVE+2(ACAC)
	MOVE	AC1+1,%SAVE+3(ACAC)
	DMUL	AC1,2(MAC)
	DSUB	AC0,AC1
	MOVE	AC1,%SAVE(ACAC)
	MOVE	AC1+1,%SAVE+1(ACAC)
	DMUL	AC1,2(MAC)
	MOVE	AC2,(MAC)
	MOVE	AC2+1,1(MAC)
	DMUL	AC2,%SAVE+2(ACAC)
	DADD	AC1,AC2
	HLRZ	ACAC,ACAC	;STORE RESULT
	CAIG	ACAC,17
	ADDI	ACAC,%SAVE	;SAVED REGISTERS
	MOVEM	AC0,(ACAC)
	MOVEM	AC0+1,1(ACAC)
	MOVEM	AC1,2(ACAC)
	MOVEM	AC1+1,3(ACAC)
	MOVSI	RESULT,%SAVE	;RESTORE REGISTERS
	BLT	RESULT,7
	MOVE	RESULT,%DCSAV
	MOVEM	RESULT,%UUO	;UNDO RECURSION
	SETZM	%DCSAV
	JRST	%XUUO		;AND EXIT

%DCDIV:	MOVEI	RESULT,%SAVE	;SAVE REGISTERS
	BLT	RESULT,%SAVE+7
	MOVE	RESULT,%UUO	;SETUP FOR RECURSIVE CALL ON %ARITH
	MOVEM	RESULT,%DCSAV
	MOVE	RESULT,%HDBLK+3
	LDB	ACAC,[POINT 4,.jbUUO,^D12]
	TRZN	ACAC,1		;SET AC, DESTINATION
	SKIPA	MAC,ACAC
	HRRZ	MAC,.jbUUO	;AC OR MEMORY
	HRLI	ACAC,(MAC)	;SAVE DESTINATION
	HRRZ	MAC,.jbUUO
	CAIG	MAC,17		;SAVED MEMORY
	ADDI	MAC,%SAVE
	MOVE	AC0,(MAC)	;SAME AS %CDIV BUT DOUBLE PRECISION
	MOVE	AC0+1,1(MAC)
	DMUL	AC0,AC0
	MOVE	AC1,2(MAC)
	MOVE	AC1+1,3(MAC)
	DMUL	AC1,AC1
	DADD	AC0,AC1
	PUSH	%P,AC0		;USE STACK AS TEMPORARY STORAGE
	PUSH	%P,AC0+1
	MOVE	AC0,%SAVE(ACAC)
	MOVE	AC0+1,%SAVE+1(ACAC)
	DMUL	AC0,(MAC)
	MOVE	AC1,%SAVE+2(ACAC)
	MOVE	AC1+1,%SAVE+3(ACAC)
	DMUL	AC1,2(MAC)
	DADD	AC0,AC1
	DDIV	AC0,-1(%P)
	MOVE	AC1,%SAVE+2(ACAC)
	MOVE	AC1+1,%SAVE+3(ACAC)
	DMUL	AC1,(MAC)
	MOVE	AC2,%SAVE(ACAC)
	MOVE	AC2+1,%SAVE+1(ACAC)
	DMUL	AC2,2(MAC)
	DSUB	AC1,AC2
	DDIV	AC1,-1(%P)
	SUB	%P,[XWD 2,2]	;ADJUST STACK
	HLRZ	ACAC,ACAC	;STORE RESULT
	CAIG	ACAC,17		;SAVED REGISTERS
	ADDI	ACAC,%SAVE
	MOVEM	AC0,(ACAC)
	MOVEM	AC0+1,1(ACAC)
	MOVEM	AC1,2(ACAC)
	MOVEM	AC1+1,3(ACAC)
	MOVSI	RESULT,%SAVE	;RESTORE REGISTERS
	BLT	RESULT,7
	MOVE	RESULT,%DCSAV	;UNDO RECURSION
	MOVEM	RESULT,%UUO
	SETZM	%DCSAV
	JRST	%XUUO		;EXIT

%FIX:	MOVM	A+1,@.jbUUO	;GET MAGNITUDE OF NUMBER
	CAMG	A+1,[200777777777]	;IS < 1.0
	JRST	FIXZER		;ASSUME 0
	CAMLE	A+1,[243777777777]	;IS TOO BIG
	JRST	FIXOVF		;YES, FORCE OVERFLOW
	SETZ	A,
	LSHC	A,^D9		;GET EXPONENT
FIXSHL:	LSH	A+1,-244(A)	;ADJUST MANTISSA ACCORDINGLY
FIXSTO:	EXCH	A+1,@.jbUUO	;STORE NUMBER
	JUMPGE	A+1,%XUUO	;IF ORIGINAL WAS NEGATIVE,
	MOVNS	@.jbUUO		; NEGATE ANSWER
	JRST	%XUUO		;EXIT
FIXZER:	SETZM	@.jbUUO		;FORCE ZERO ANSWER
	JRST	%XUUO		;EXIT
FIXOVF:	MOVE	A+1,[377777777777]	;FORCE OVERFLOW
	AOJA	A+1,FIXSTO	;CONTINUE IF OVERFLOW IGNORED

%FLOAT:	MOVM	A,@.jbUUO	;GET MAGNITUDE OF NUMBER
	JUMPE	A,%XUUO		;ZERO, QUIT
	IDIVI	A,400000	;BREAK NUMBER INTO TWO PARTS
	HRLI	A+1,233000	;SET EXPONENT
	JUMPE	A,.+2		;IF < 18 BITS, SECOND NUMBER IS ZERO
	HRLI	A,254000
	FAD	A+1,A		;USE FAD TO COMBINE AND NORMALIZE
	EXCH	A+1,@.jbUUO	;STORE
	JUMPGE	A+1,%XUUO	;IF ORIGINAL WAS NEGATIVE,
	MOVNS	@.jbUUO		; NEGATE ANSWER
	JRST	%XUUO		;EXIT

%DFIX:	HRRZ	MBASE,.jbUUO	;GET ADDRESS
	MOVM	A+1,(MBASE)	;LOOK AT FIRST WORD
	CAMG	A+1,[200777777777]	;IS < 1.0L
	JRST	FIXZER		;ASSUME ZERO
	CAMLE	A+1,[243777777777]	;IS TOO BIG
	JRST	FIXOVF		;YES, FORCE OVERFLOW
	SKIPL	(MBASE)		;GET MAGNITUDE OF SECOND WORD
	SKIPA	A+2,1(MBASE)
	MOVN	A+2,1(MBASE)
	HLRZ	A+2,A+2		;ONLY FIRST 9 BITS OF SECOND WORD
	ANDI	A+2,777		; ARE OF INTEREST
	SETZ	A,
	LSHC	A,^D9		;GET EXPONENT
	ORI	A+1,(A+2)	; AND EXTRA 9 BITS
	JRST	FIXSHL		;CONTINUE AS FOR %FIX

%DFLOT:	HRRZ	MBASE,.jbUUO	;GET ADDRESS
	SETZM	1(MBASE)	;POSSIBLE ZERO RESULT
	MOVM	A,(MBASE)	;GET MAGNITUDE
	JUMPE	A,%XUUO		;DONE IF ZERO
	IDIVI	A,400000	;BREAK NUMBER INTO TWO PARTS
	HRLI	A+1,233000	;SET EXPONENT
	JUMPE	A,.+2		;IF < 18 BITS, SECOND NUMBER IS ZERO
	HRLI	A,254000
	FADL	A,A+1		;USE LONG FORM HERE
	SKIPGE	(MBASE)		;IF ORIGINAL WAS NEGATIVE,
	DFN	A,A+1		; NEGATE THE ANSWER
	MOVEM	A,(MBASE)	;STORE RESULT
	MOVEM	A+1,1(MBASE)
	JRST	%XUUO		;EXIT

	PRGEND
	TITLE	%STRNG -- ALGOLW STRING ROUTINES -- MICHAEL GREEN
	HISEG
	ENTRY	%CSTE,%CSTN,%CSTL,%CSTLE,%CSTG,%CSTGE
	ENTRY	%IS,%SMOVE,%SUBST,%SUBSC
	ENTRY	%STRIN,%BITIN,%INTBI,%INTST
	EXTERN	%XUUO,%UUO,%ERROR,%ERRNM
	EXTERN	.jbUUO
	%P=	17
	VALUE=	10
	DIGITS=	12
	SIGN=	13
	LEN1=	10
	BYTEP1=	11
	LEN2=	12
	BYTEP2=	13
	PAD=	11
	CHAR=	12
	TEMP=	14
	ERROR=	14

SETUP:	LDB	TEMP,[POINT 4,.jbUUO,^D12]
	TRZE	TEMP,1		;OPERANDS IN REVERSE ORDER?
	JRST	SETUP2
	MOVE	BYTEP1,(TEMP)	;GET STRING DV AT AC
	MOVE	LEN1,1(TEMP)
	ADDI	BYTEP1,(LEN1)	;MAKE BYTEPT ADDR ABSOLUTE
	HLRZ	LEN1,LEN1	;GET LENGTH FIELD
	HRRZ	TEMP,.jbUUO
	MOVE	BYTEP2,(TEMP)	;GET STRING DV AT ADDRESS
	MOVE	LEN2,1(TEMP)
	ADDI	BYTEP2,(LEN2)	;MAKE BYTEPT ADDR ABSOLUTE
	HLRZ	LEN2,LEN2	;GET LENGTH FIELD
	POPJ	%P,		;RETURN
SETUP2:	MOVE	BYTEP2,(TEMP)	;GET STRING DV AT AC
	MOVE	LEN2,1(TEMP)
	ADDI	BYTEP2,(LEN2)	;MAKE BYTEPT ADDR ABSOLUTE
	HLRZ	LEN2,LEN2	;GET LENGTH FIELD
	HRRZ	TEMP,.jbUUO
	MOVE	BYTEP1,(TEMP)	;GET STRING DV AT ADDRESS
	MOVE	LEN1,1(TEMP)
	ADDI	BYTEP1,(LEN1)	;MAKE BYTEPT ADDR ABSOLUTE
	HLRZ	LEN1,LEN1	;GET LENGTH FIELD
	POPJ	%P,		;RETURN

%CSTE:	PUSHJ	%P,SETUP	;SETUP REGISTERS
	HRLI	LEN1,(LEN2)	;PUT BOTH LENGTHS TOGETHER
	JUMPE	LEN1,SUCCES	;NULL STRINGS ARE EQUAL
CSTEL:	TRNN	LEN1,777777	;ANY LEFT IN FIRST OPERAND
	JRST	.+3
	SUBI	LEN1,1		;YEP, GET A CHARACTER
	JRST	.+4
	HRRI	BYTEP1,[XWD 200000,0]
	TLZ	BYTEP1,770000	;NOPE, FAKE A BYTE
	TLO	BYTEP1,440000	;WORKS WITH BITS OR STRING
	ILDB	CHAR,BYTEP1
	TLNN	LEN1,777777	;ANY LEFT IN SECOND OPERAND
	JRST	.+3
	SUB	LEN1,[XWD 1,0]	;YEP, GET A CHARACTER
	JRST	.+4
	HRRI	BYTEP2,[XWD 200000,0]
	TLZ	BYTEP2,770000	;NOPE, FAKE A BYTE
	TLO	BYTEP2,440000	;WORKS WITH BITS OR STRING
	ILDB	TEMP,BYTEP2
	CAIE	CHAR,(TEMP)	;COMPARE BYTES
	JRST	%XUUO		;NOT EQUAL
	JUMPN	LEN1,CSTEL	;IF MORE, PROCESS THEM
SUCCES:	AOS	%UUO		;SUCCES RETURN, SKIP
	JRST	%XUUO

%CSTN:	PUSHJ	%P,SETUP	;SETUP REGISTERS
	HRLI	LEN1,(LEN2)	;PUT LENGTHS TOGETHER
	JUMPE	LEN1,%XUUO	;NULL STRINGS, FAIL
CSTNL:	TRNN	LEN1,777777	;ANY LEFT IN FIRST OPERAND
	JRST	.+3
	SUBI	LEN1,1		;YEP, GET A BYTE
	JRST	.+4
	HRRI	BYTEP1,[XWD 200000,0]
	TLZ	BYTEP1,770000	;NOPE, FAKE A BYTE
	TLO	BYTEP1,440000	;WORKS WITH BITS OR STRING
	ILDB	CHAR,BYTEP1
	TLNN	LEN1,777777	;ANY LEFT IN SECOND OPERAND
	JRST	.+3
	SUB	LEN1,[XWD 1,0]	;YEP, GET A CHARACTER
	JRST	.+4
	HRRI	BYTEP2,[XWD 200000,0]
	TLZ	BYTEP2,770000	;NOPE, FAKE A BYTE
	TLO	BYTEP2,440000	;WORKS WITH BITS OR STRING
	ILDB	TEMP,BYTEP2
	CAIE	CHAR,(TEMP)	;COMPARE
	JRST	SUCCES		;NOT =, SUCCEED
	JUMPN	LEN1,CSTNL	;=, CONTINUE COMPARE
	JRST	%XUUO		;END OF STRING, FAIL

CSTL:	PUSHJ	%P,SETUP	;SETUP REGISTERS
	HRLI	LEN1,(LEN2)	;PUT LENGTHS TOGETHER
	JUMPE	LEN1,CSTEXT	;NULL STRINGS ARE EQUAL
CSTLL:	TRNN	LEN1,777777	;ANY LEFT IN FIRST OPERAND
	JRST	.+3
	SUBI	LEN1,1		;YEP, GET A BYTE
	JRST	.+4
	HRRI	BYTEP1,[XWD 200000,0]
	TLZ	BYTEP1,770000	;NOPE, FAKE A BYTE
	TLO	BYTEP1,440000	;WORKS WITH BITS OR STRING
	ILDB	CHAR,BYTEP1
	TLNN	LEN1,777777	;ANY LEFT IN SECOND OPERAND
	JRST	.+3
	SUB	LEN1,[XWD 1,0]	;YEP, GET A BYTE
	JRST	.+4
	HRRI	BYTEP2,[XWD 200000,0]
	TLZ	BYTEP2,770000	;NOPE, FAKE A BYTE
	TLO	BYTEP2,440000	;WORKS WITH BITS OR STRING
	ILDB	TEMP,BYTEP2
	CAIE	CHAR,(TEMP)	;COMPARE THEM
	JRST	LSSNEQ		;NOT =, CHECK FURTHER
	JUMPN	LEN1,CSTLL	;=, CONTINUE COMPARE
CSTEXT:	POPJ	%P,		;RETURN
LSSNEQ:	CAIL	CHAR,(TEMP)	;COMPARE NEQ CHARACTERS
	JRST	PFAIL		;>, FAIL
PSUCCE:	POP	%P,TEMP		;DISCARD RETURN
	AOS	%UUO		;SKIP RETURN
	JRST	%XUUO
PFAIL:	POP	%P,TEMP		;DISCARD RETURN
	JRST	%XUUO		;NON SKIP RETURN

%CSTL:	PUSHJ	%P,CSTL		;CALL LSS COMPARE
	JRST	%XUUO		;IF =, FAIL

%CSTLE:	PUSHJ	%P,CSTL		;CALL LSS COMPARE
	JRST	SUCCES		;IF =, SUCCEED

CSTG:	PUSHJ	%P,SETUP	;SETUP REGISTERS
	HRLI	LEN1,(LEN2)	;PUT LENGTHS TOGETHER
	JUMPE	LEN1,CSTEXT	;NULL STRINGS ARE EQUAL
CSTGL:	TRNN	LEN1,777777	;ANY LEFT IN FIRST OPERAND
	JRST	.+3
	SUBI	LEN1,1		;YEP, GET A CHARACTER
	JRST	.+4
	HRRI	BYTEP1,[XWD 200000,0]
	TLZ	BYTEP1,770000	;NOPE, FAKE A BYTE
	TLO	BYTEP1,440000	;WORKS WITH BITS OR STRING
	ILDB	CHAR,BYTEP1
	TLNN	LEN1,777777	;ANY LEFT IN SECOND OPERAND
	JRST	.+3
	SUB	LEN1,[XWD 1,0]	;YEP, GET A CHARACTER
	JRST	.+4
	HRRI	BYTEP2,[XWD 200000,0]
	TLZ	BYTEP2,770000	;NOPE, FAKE A BYTE
	TLO	BYTEP2,440000	;WORKS WITH BITS OR STRING
	ILDB	TEMP,BYTEP2
	CAIE	CHAR,(TEMP)	;COMPARE THEM
	JRST	GTRNEQ		;NOT =, CHECK FURTHER
	JUMPN	LEN1,CSTGL	;=, CONTINUE COMPARE
	POPJ	%P,		;RETURN
GTRNEQ:	CAIG	CHAR,(TEMP)	;COMPARE NEQ CHARACTERS
	JRST	PFAIL		;<, FAIL
	JRST	PSUCCE		;>, SUCCEED

%CSTG:	PUSHJ	%P,CSTG		;CALL GTR COMPARE
	JRST	%XUUO		;IF =, FAIL

%CSTGE:	PUSHJ	%P,CSTG		;CALL GTR COMPARE
	JRST	SUCCES		;IF =, SUCCEED

%SMOVE:	PUSHJ	%P,SETUP	;SETUP REGISTERS
	JUMPE	LEN2,%XUUO	;NULL DESTINATION, DONE
	TLNE	BYTEP1,007600	;CHECK FOR SAME BYTE SIZE
	JRST	SMOVET
	TLNE	BYTEP2,007600	;PERHAPS BOTH BITS
	JRST	SMOVEP
SMOVEL:	JUMPE	LEN1,.+3	;NO MORE SOURCE, SUPPLY BLANKS
	ILDB	TEMP,BYTEP1	;ELSE GET SOURCE CHARACTER
	SOJA	LEN1,.+2	;ADJUST LENGTH
	MOVEI	TEMP," "
	IDPB	TEMP,BYTEP2	;STORE CHARACTER
	SOJG	LEN2,SMOVEL	;PROCESS NEXT
	JRST	%XUUO		;DONE
SMOVET:	TLNE	BYTEP2,007600	;FIRST NOT BITS
	JRST	SMOVEL		;SECOND NOT BITS EITHER
SMOVEU:	JUMPE	LEN1,.+3	;NO MORE SOURCE IN
	ILDB	TEMP,BYTEP1	; STRING TO BITS MOVE
	SOJA	LEN1,.+2	;ADJUST LENGTH
	MOVEI	TEMP," "	;PAD OUT SOURCE WITH BLANKS
	LSH	TEMP,^D29	;UNPACK LEFT TO RIGHT
	TLO	TEMP,002000	;ADD BIT TO MARK END
SMOVER:	TLNN	TEMP,376000	;NOW CHECK FOR NO MORE BITS
	JRST	SMOVEU		;IF SO, GET NEXT SOURCE
	ROT	TEMP,1		;IF NOT, ROTATE NEW BIT
	IDPB	TEMP,BYTEP2	; TO STORE POSITION
	SOJG	LEN2,SMOVER	;IF DESTINATION ROOM, CONTINUE
	JRST	%XUUO		; ELSE QUIT
SMOVEP:	HRLI	LEN2,1		;SET UP FOR BITS TO STRING MOVE
	JUMPE	LEN1,.+4	;CHECK FOR NO MORE SOURCE
	ILDB	TEMP,BYTEP1	;IF NOT, GET A BYTE
	LSH	TEMP,^D17	; AND PUT IN HIGH ORDER OF HALF
	SOJA	LEN1,.+2	;ADJUST LENGTH
	MOVEI	TEMP,0		;PAD OUT SOURCE WITH ZEROES
	HLL	TEMP,LEN2
	LSH	TEMP,1		;PACK IN NEW BIT
	HLL	LEN2,TEMP
	TLNN	TEMP,000200	;CHECK FOR FINISHED BYTE
	JRST	SMOVEP+1
	HRLI	LEN2,0		;RESET LEFT HALF OF LENGTH
	HLRZS	TEMP		;RIGHT JUSTIFY
	IDPB	TEMP,BYTEP2	;AND STORE AWAY
	SOJG	LEN2,SMOVEP	;ADJUST DEST. LENGTH
	JRST	%XUUO		;EXIT IF DONE

%IS:	LDB	TEMP,[POINT 4,.jbUUO,^D12]
	MOVE	TEMP,(TEMP)	;GET RECORD DESCRIPTOR
	JUMPE	TEMP,%XUUO	;MAYBE IS NULL POINTER
	HLRZ	TEMP,-1(TEMP)
	CAIN	TEMP,@.jbUUO	;IF SAME AS ASKED RECORD,
	JRST	RECDIS		; SHORT CUT CHECK
	HRRZ	TEMP,(TEMP)	;GET NAME ADDRESS
	HRRZ	LEN1,@.jbUUO
	MOVE	CHAR,(TEMP)	;GET A WORD OF NAME
	CAME	CHAR,(LEN1)	;COMPARE TO OTHER NAME
	JRST	%XUUO		;FAIL IF NOT =
	ADDI	TEMP,1
	TRNE	CHAR,376	;IF END OF ASCIZ, SUCCEED
	AOJA	LEN1,.-5	; ELSE TRY NEXT WORDS
RECDIS:	AOS	%UUO
	JRST	%XUUO		;SKIP RETURN

%SUBST:	HRRZ	TEMP,.jbUUO	;GET DV
	MOVE	BYTEP1,(TEMP)
	MOVS	LEN1,1(TEMP)	;SWAPPED LENGTH
	LDB	TEMP,[POINT 4,.jbUUO,^D12]
	TRZN	TEMP,1
	JRST	.+3
	MOVE	LEN2,(TEMP)	;SPECIAL CASE, STRING SUBSCRIPTING
	JRST	SPECSB
	MOVE	LEN2,(TEMP)	;GET NEW START POSITION
	CAILE	LEN2,(LEN1)	;COMPARE TO OLD LENGTH
	JRST	ERR2		;ERROR IF >
	SOJL	LEN2,ERR1	; OR IF <= 0
	SUBI	LEN1,(LEN2)	;ADJUST OLD LENGTH
	MOVE	BYTEP2,1(TEMP)	;GET NEW LENGTH
	JUMPL	BYTEP2,ERR3	;ERROR IF < 0
	CAILE	BYTEP2,(LEN1)	; OR IF > ADJUSTED LENGTH
	JRST	ERR4
	HRRI	LEN1,(BYTEP2)	;SET NEW LENGTH
SPECSB:	LDB	BYTEP2,[POINT 6,BYTEP1,^D11]
	MOVEI	TEMP,^D36	;HOW MANY BYTES PER WORD
	IDIVM	TEMP,BYTEP2
	IDIVI	LEN2,(BYTEP2)	;GET WORD OFFSET AND REMAINDER
	ADDI	BYTEP1,(LEN2)
	JUMPE	BYTEP2,.+3	;ADJUST BYTE POINTER ACCORDINGLY
	IBP	BYTEP1
	SOJG	BYTEP2,.-1
	LDB	TEMP,[POINT 4,.jbUUO,^D12]
	ANDI	TEMP,16
	MOVEM	BYTEP1,(TEMP)	;STORE ADJUSTED DV
	MOVSM	LEN1,1(TEMP)
	JRST	%XUUO		;AND RETURN

ERR1:	MOVE	LEN2,(TEMP)	;SAVE START
	MOVEI	ERROR,[ASCIZ/SUBSTRING - START $ <= 0/]
EDIT:	PUSHJ	%P,%ERROR
	MOVE	ERROR,LEN2
	PUSHJ	%P,%ERRNM
	EXIT			;QUIT

ERR2:	MOVE	LEN2,(TEMP)	;SAVE START
	MOVEI	ERROR,[ASCIZ/SUBSTRING - START $ > STRING LENGTH $/]
	PUSHJ	%P,%ERROR
	MOVE	ERROR,LEN2
	PUSHJ	%P,%ERRNM
	MOVEI	ERROR,(LEN1)	;GET STRING LENGTH
	PUSHJ	%P,%ERRNM
	EXIT			;QUIT

ERR3:	MOVE	LEN2,1(TEMP)	;SAVE LENGTH
	MOVEI	ERROR,[ASCIZ/SUBSTRING - LENGTH $ < 0/]
	JRST	EDIT

ERR4:	MOVE	LEN2,(TEMP)	;SAVE START
	MOVE	BYTEP2,1(TEMP)	; AND LENGTH
	MOVEI	ERROR,[ASCIZ/SUBSTRING - LENGTH $ > STRING LENGTH $ - START $ + 1/]
	PUSHJ	%P,%ERROR
	MOVE	ERROR,BYTEP2
	PUSHJ	%P,%ERRNM
	MOVEI	ERROR,(LEN1)	;GET STRING LENGTH
	PUSHJ	%P,%ERRNM
	JRST	EDIT+1

%SUBSC:	LDB	TEMP,[POINT 4,.jbUUO,^D12]
	HRRZ	LEN1,.jbUUO	;SUBSCRIPT CHECKING
	MOVE	LEN2,1(TEMP)	;GET SUBSCRIPT
	SUB	LEN2,1(LEN1)	;SUBTRACT LOWER BOUND
	JUMPL	LEN2,LOWERR
	CAML	LEN2,2(LEN1)	;CHECK UPPER BOUND
	JRST	HGHERR
	IMUL	LEN2,(LEN1)	;MULTIPLY BY DIMENSION UNITS
	ADDM	LEN2,(TEMP)	;ADD IN TO TOTAL
	JRST	%XUUO

LOWERR:	MOVE	LEN2,1(TEMP)	;GET SUBSCRIPT
	MOVEI	ERROR,[ASCIZ/SUBSCRIPT - $ < LOWER BOUND $/]
	PUSHJ	%P,%ERROR
	MOVE	ERROR,LEN2
	PUSHJ	%P,%ERRNM
	MOVE	ERROR,1(LEN1)
	PUSHJ	%P,%ERRNM
	EXIT

HGHERR:	MOVE	LEN2,1(TEMP)	;GET SUBSCRIPT
	MOVEI	ERROR,[ASCIZ/SUBSCRIPT - $ > UPPER BOUND $/]
	PUSHJ	%P,%ERROR
	MOVE	ERROR,LEN2
	PUSHJ	%P,%ERRNM
	MOVE	ERROR,2(LEN1)	;CALCULATE UPPER BOUND
	ADD	ERROR,1(LEN1)
	SUBI	ERROR,1
	PUSHJ	%P,%ERRNM
	EXIT

%INTST:	MOVEI	SIGN," "	;INTEGER TO STRING CONVERSION
	SKIPGE	-3(%P)		;CHECK SIGN OF VALUE
	MOVEI	SIGN,"-"
	MOVM	VALUE,-3(%P)	;GET MAGNITUDE OF VALUE
	MOVE	DIGITS,[XWD 2,2];MINIMUM OF 2 CHARACTERS
INTSTD:	IDIVI	VALUE,^D10
	JUMPE	VALUE,INTSTE	;PUSH DIGITS INTO STACK
	ADDI	VALUE+1,"0"
	PUSH	%P,VALUE+1	;THEY ARE IN REVERSE ORDER
	AOBJP	DIGITS,INTSTD	;KEEP TRACK OF HOW MANY
INTSTE:	ADDI	VALUE+1,"0"
	PUSH	%P,VALUE+1	;DO LAST DIGIT
	PUSH	%P,SIGN		; AND SIGN
	SUB	%P,DIGITS	;NOW ADJUST STACK
	MOVE	LEN1,-1(%P)
	SUBI	LEN1,(DIGITS)	;HOW MANY LEADING BLANKS
	JUMPL	LEN1,INTSTX	; OR MAYBE AN ERROR
	JUMPE	LEN1,INTSTC
	MOVEI	PAD," "
	IDPB	PAD,-2(%P)	;STORE LEADING BLANKS
	SOJG	LEN1,.-1
INTSTC:	ADDI	DIGITS,(%P)	;POINT TO START OF NUMBER
	SUB	DIGITS,[XWD 1,0]
	MOVE	PAD,(DIGITS)	;GET A CHARACTER
	IDPB	PAD,-2(%P)	; AND STORE IT
	SUB	DIGITS,[XWD 1,1]
	JUMPGE	DIGITS,.-3	;LOOP UNTIL DONE
	POP	%P,-3(%P)
	SUB	%P,[XWD 2,2]	;CLOSE UP STACK
	POPJ	%P,		;AND EXIT
INTSTX:	MOVEI	ERROR,[ASCIZ/INTSTR - $ TOO BIG FOR $ CHARACTER STRING/]
	PUSHJ	%P,%ERROR
	MOVE	ERROR,-3(%P)	;EDIT IN INTEGER
	PUSHJ	%P,%ERRNM
	MOVE	ERROR,-1(%P)	;AND STRING LENGTH
	PUSHJ	%P,%ERRNM
	EXIT

%STRIN:	MOVE	LEN2,-1(%P)	;STRING TO INTEGER CONVERSION
	SOJL	LEN2,FMTERR
	ILDB	SIGN,-2(%P)	;SKIP LEADING BLANKS
	CAIN	SIGN," "
	JRST	.-3
	CAIE	SIGN,"+"	;ALLOW LEADING PLUS
	CAIN	SIGN,"-"	; OR MINUS
	JRST	STRINS
	CAIGE	SIGN,"0"	;MAKE SURE VALID DIGIT
	JRST	FMTERR
	CAILE	SIGN,"9"
	JRST	FMTERR
	MOVEI	VALUE,-"0"(SIGN);ASSUME POSITIVE
	SOJL	LEN2,STRINE
STRINL:	ILDB	VALUE+1,-2(%P)	;GET NEXT CHARACTER
	CAIGE	VALUE+1,"0"
	JRST	FMTERR		;ALLOW ONLY DIGITS
	CAILE	VALUE+1,"9"
	JRST	FMTERR
	CAMLE	VALUE,[DEC <^O377777777777-9>/10]
	JRST	SIZERR		;CHECK FOR SIZE
	IMULI	VALUE,^D10
	ADDI	VALUE,-"0"(VALUE+1)
	SOJGE	LEN2,STRINL	;PACK IN AND TRY AGAIN
STRINE:	CAIN	SIGN,"-"
	MOVN	VALUE,VALUE	;NEGATE IF MINUS SIGN
	MOVEM	VALUE,-2(%P)
	POP	%P,-1(%P)	;CLOSE UP STACK
	POPJ	%P,
STRINS:	SOJL	LEN2,FMTERR	;SIGN, CHECK FOR FOLLOWING
	MOVEI	VALUE,0		; DIGIT
	JRST	STRINL
SIZERR:	MOVEI	ERROR,[ASCIZ/STRINT - INTEGER TOO LARGE/]
	PUSHJ	%P,%ERROR
	EXIT
FMTERR:	MOVEI	ERROR,[ASCIZ/STRINT - STRING DOESN'T CONTAIN INTEGER/]
	PUSHJ	%P,%ERROR
	EXIT

%INTBI:	MOVE	LEN2,-1(%P)	;INTEGER TO BITS CONVERSION
	MOVEI	VALUE,0
	CAIG	LEN2,^D36	;PAD ON LEFT WITH ZEROES
	JRST	.+3
	IDPB	VALUE,-2(%P)
	SOJA	LEN2,.-3
	MOVE	VALUE,-3(%P)	;LEFT SHIFT FOR SHORT BITSTRINGS
	HRREI	SIGN,-^D36(CHAR)
	JUMPE	SIGN,INTBIS	;36 BITS, NO SHIFT NEEDED
	JUMPL	VALUE,BITSIZ	;CHECK FOR NOT ENOUGH ROOM
	LSH	VALUE,1
	AOJL	SIGN,.-2
INTBIS:	JUMPE	LEN2,INTBIE	;COPY BITS NOW
	ROT	VALUE,1
	IDPB	VALUE,-2(%P)
	SOJG	LEN2,.-2
INTBIE:	POP	%P,-3(%P)	;CLOSE UP STACK
	SUB	%P,[XWD 2,2]
	POPJ	%P,
BITSIZ:	MOVEI	ERROR,[ASCIZ/INTBIT - $ TOO BIG FOR $ BIT BITSTRING/]
	PUSHJ	%P,%ERROR
	MOVE	ERROR,-3(%P)	;EDIT IN INTEGER
	PUSHJ	%P,%ERRNM
	MOVE	ERROR,-1(%P)	;EDIT IN LENGTH
	PUSHJ	%P,%ERRNM
	EXIT

%BITIN:	MOVE	LEN2,-1(%P)	;BITSTRING TO INTEGER CONVERSION
	MOVEI	VALUE,0
	JUMPE	LEN2,BITINE	;NULL BITSTRING ALLOWED
BITINL:	JUMPL	VALUE,INTSIZ	;TOO BIG
	ILDB	VALUE+1,-2(%P)
	ROT	VALUE+1,-1	;GET BIT INTO POSITION
	LSHC	VALUE,1
	SOJG	LEN2,BITINL	;MERGE AND GET NEXT ONE
BITINE:	MOVEM	VALUE,-2(%P)	;SAVE VALUE
	POP	%P,-1(%P)	; AND CLOSE UP STACK
	POPJ	%P,
INTSIZ:	MOVEI	ERROR,[ASCIZ/BITINT - MORE THAN 36 SIGNIFICANT BITS/]
	PUSHJ	%P,%ERROR
	EXIT

	PRGEND
	TITLE	%RUN ROUTINE FOR ALGOLW -- MICHAEL GREEN
	HISEG
	ENTRY	%RUN
	EXTERN	%ERROR,%ERRSB,%OPNSW
	%P=	17
	CHAR=	10
	ASSEMB=	11
	LENGTH=	12
	FLAG=	13
	ERROR=	14
	LOOKNM=	400000		;FLAGS IN LH OF FLAG
	FINDNM=	200000
	LOOKDG=	100000
	FINDDG=	040000
	LOOKDV=	020000
	LOOKFL=	010000
	PASTFL=	004000
	LOOKPP=	002000
	OCTAL=	001000
	LOOKPG=	000400
	FINDPP=	000200
	LOOKEN=	000100
	FINDEN=	000040
	LOOKST=	000020
	FINDST=	000010
	CONDRN=	000004

	DEV=	%OPNSW		;DEVICE NAME
	NAME=	%OPNSW+1	;FILE NAME
	EXT=	%OPNSW+2	;EXTENSION
	PPNO=	%OPNSW+4	;PROJECT-PROGRAMMER NUMBER
	LOWMEM=	%OPNSW+5	;LOW SEGMENT LENGTH
	ENTRY=	%OPNSW+6	;RELATIVE ENTRY POINT

%RUN:	SETZB	FLAG,NAME	;CLEAR FLAGS AND CONTROL BLOCK
	MOVE	CHAR,[XWD NAME,EXT]
	BLT	CHAR,ENTRY
	MOVSI	CHAR,(SIXBIT/DSK/)
	MOVEM	CHAR,DEV	;DEFAULT DEVICE IS DSK
	MOVE	LENGTH,-1(%P)	;GET STRING LENGTH

NEWITM:	SETZ	ASSEMB,		;START NEW FIELD
	JUMPL	LENGTH,GORUN	; UNLESS NO MORE STRING

NEXTCH:	SOJL	LENGTH,ENDFLD	;END OF FIELD AT STRING END
	ILDB	CHAR,-2(%P)
	CAIN	CHAR,":"	;END OF DEVICE
	JRST	DEVCHK
	CAIN	CHAR,"."	;END OF FILE NAME
	JRST	NAMCHK
	CAIN	CHAR,"["	;START OF PROJECT-PROGRAMMER
	JRST	STRTPP
	CAIN	CHAR,","	;START OF PROGRAMMER
	JRST	COMMA
	CAIN	CHAR,"]"	;END OF PROGRAMMER NUMBER
	JRST	ENDPP
	CAIN	CHAR,"?"	;CONDITIONAL RUN
	JRST	CONDCD
	CAIN	CHAR,"@"	;START OF ENTRY POINT
	JRST	STRTEN
	CAIN	CHAR,"="	;START OF LOW SEGMENT LENGTH
	JRST	STRTST
	CAIN	CHAR,"K"	;MAYBE END OF LOW SEGMENT LENGTH
	JRST	ENDSTU
	CAIN	CHAR,"K"+40	;ALSO MAYBE END OF LOW SEGMENT LENGTH
	JRST	ENDSTL
	CAIGE	CHAR,"0"	;CHECK FOR DIGIT
	JRST	.+3
	CAIG	CHAR,"9"
	JRST	DIGIT
	CAIGE	CHAR,"A"	;CHECK FOR UPPER CASE LETTER
	JRST	.+3
	CAIG	CHAR,"Z"
	JRST	LETTER
	CAIGE	CHAR,"A"+40	;CHECK FOR LOWER CASE LETTER
	JRST	.+3
	CAIG	CHAR,"Z"+40
	JRST	LOWERC
UNKNOW:	MOVEI	ERROR,[ASCIZ/RUN - UNRECOGNIZABLE FILE DESCRIPTOR/]
	PUSHJ	%P,%ERROR
	EXIT

LOWERC:	TRZ	CHAR,40		;FORCE TO UPPER CASE
LETTER:	TLNE	FLAG,LOOKNM
	JRST	UNKNOW		;MUST BE LOOKING FOR NAME
	TLO	FLAG,FINDNM
	TLNE	ASSEMB,770000	;USE ONLY FIRST 6 CHARACTERS
	JRST	NEXTCH
	TRC	CHAR,40
	ROT	CHAR,-6
	ROTC	CHAR,6		;PACK IN USING SIXBIT
	JRST	NEXTCH

DIGIT:	TLNN	FLAG,LOOKDG	;ARE WE LOOKING FOR DIGIT
	JRST	LETTER		; NO, MAYBE PART OF NAME
	TLO	FLAG,FINDDG
	TLNE	FLAG,OCTAL	;TAKE CARE OF OCTAL NUMBER
	JRST	POCTAL
	CAIL	ASSEMB,^D100	;MAXIMUM OF 3 DIGITS
	JRST	UNKNOW
	IMULI	ASSEMB,^D10	;OK, PACK IN DIGIT
	ADDI	ASSEMB,-"0"(CHAR)
	JRST	NEXTCH

POCTAL:	CAIL	CHAR,"8"	;CHECK FOR LEGAL OCTAL DIGIT
	JRST	UNKNOW
	CAIL	ASSEMB,100000	;MAXIMUM OF 18 BITS
	JRST	UNKNOW
	ROT	CHAR,-3		;PACK IN
	ROTC	CHAR,3
	JRST	NEXTCH

DEVCHK:	TLOE	FLAG,LOOKDV	;LOOKING FOR DEVICE NAME
	JRST	UNKNOW
	TLZN	FLAG,FINDNM	;LOOKING FOR NAME
	JRST	UNKNOW
	TLNE	ASSEMB,770000	;LEFT JUSTIFY NAME
	JRST	.+3
	LSH	ASSEMB,6
	JRST	.-3
	MOVEM	ASSEMB,DEV	;SAVE EXPLICIT DEVICE NAME
	JRST	NEWITM

NAMCHK:	TLOE	FLAG,LOOKFL	;LOOKING FOR FILE NAME
	JRST	UNKNOW
	TLZN	FLAG,FINDNM	;LOOKING FOR NAME
	JRST	UNKNOW
	TLO	FLAG,LOOKDV	;NO MORE DEVICE NAMES
STORFL:	TLNE	ASSEMB,770000	;LEFT JUSTIFY NAME
	JRST	.+3
	LSH	ASSEMB,6
	JRST	.-3
	MOVEM	ASSEMB,NAME	;STORE IT AWAY
	JRST	NEWITM

ENDFLD:	TLOE	FLAG,PASTFL	;PAST DEV:FILE.EXT
	JRST	CHKENT
	TLO	FLAG,LOOKNM	;NO, NO MORE NAMES
	TLZN	FLAG,FINDNM
	JRST	NEWITM		;NO NAME
	TLON	FLAG,LOOKFL
	JRST	STORFL		;LOOKING FOR FILE NAME
	TLNE	ASSEMB,770000
	JRST	.+3		;NO, FOUND EXTENSION
	LSH	ASSEMB,6
	JRST	.-3
	HLLZM	ASSEMB,EXT	;SO STORE IT
	JRST	NEWITM

STRTPP:	TLNE	FLAG,LOOKPP+FINDPP+LOOKST+LOOKPG
	JRST	UNKNOWN		;NOT IN PROJ-PROG OR LOW SEG SIZE
	TLO	FLAG,LOOKDG+OCTAL+LOOKPP
	JRST	ENDFLD		;LOOK FOR OCTAL PROJECT NO.

CHKENT:	TLZN	FLAG,LOOKEN	;CHECK IN ENTRY POINT
	JRST	NEWITM
	TLZN	FLAG,FINDDG	;MUST HAVE NUMBER
	JRST	UNKNOW
	TLO	FLAG,FINDEN	;FOUND ENTRY POINT
	HRLZM	ASSEMB,ENTRY	; SO SAVE IT
	JRST	NEWITM

STRTEN:	TLNE	FLAG,LOOKEN+FINDEN
	JRST	UNKNOW		;NOT IN ENTRY AND NOT FOUND ONE
	TLO	FLAG,LOOKDG+LOOKEN+OCTAL
	TLOE	FLAG,PASTFL	;CHECK PAST FILE
	JRST	NEWITM		; IF SO, DON'T USE ENDFLD
	JRST	ENDFLD+2	; IF NOT, BYPASS CHKENT TEST

COMMA:	TLZN	FLAG,LOOKPP	;MUST BE LOOKING FOR PROJECT
	JRST	UNKNOW
	TLZN	FLAG,FINDDG	;MUST HAVE FOUND THE NUMBER
	JRST	UNKNOW
	TLO	FLAG,LOOKPG	;LOOK FOR PROGRAMMER NUMBER
	HRLZM	ASSEMB,PPNO
	JRST	NEWITM		;STORE PROJECT NUMBER

ENDPP:	TLZN	FLAG,LOOKPG	;MUST BE LOOKING FOR PROGRAMMER NO.
	JRST	UNKNOW
	TLZN	FLAG,FINDDG	;MUST HAVE FOUND THE NUMBER
	JRST	UNKNOW
	TLO	FLAG,FINDPP	;FOUND PROJECT-PROGRAMMER
	TLZ	FLAG,LOOKDG
	HRRM	ASSEMB,PPNO	;STORE IT AWAY
	JRST	NEWITM

STRTST:	TLNE	FLAG,FINDST+LOOKST+LOOKPP+LOOKPG
	JRST	UNKNOW		;MUST NOT BE IN A FIELD
	TLO	FLAG,LOOKDG+LOOKST
	TLZ	FLAG,OCTAL	;LOOK FOR DECIMAL NUMBER
	JRST	ENDFLD

ENDSTL:	TRZ	CHAR,40		;FORCE TO UPPER CASE "K"
ENDSTU:	TLZN	FLAG,LOOKST	;MUST BE IN ENTRY FIELD
	JRST	LETTER		; IF NOT, IS PART OF NAME
	TLZN	FLAG,FINDDG
	JRST	UNKNOW		;MUST HAVE FOUND NUMBER
	JUMPE	ASSEMB,UNKNOW
	CAILE	ASSEMB,^D128	;0 < SIZE <= 128
	JRST	UNKNOW
	TLO	FLAG,FINDST	;SO FOUND LOW SEGMENT SIZE
	TLZ	FLAG,LOOKDG
	LSH	ASSEMB,^D10	;SIZE IS IN MULTIPLES OF 1024
	SUBI	ASSEMB,1
	HRRZM	ASSEMB,LOWMEM	;STORE MAX ADDRESS OF LOW SEG
	JRST	NEWITM

CONDCD:	TLNE	FLAG,LOOKPP+LOOKST+LOOKPG
	JRST	UNKNOW		;NOT IN A FIELD
	TLZ	FLAG,LOOKDG
	TLO	FLAG,CONDRN	;SET CONDITIONAL RUN FLAG
	JRST	ENDFLD

GORUN:	POP	%P,-1(%P)	;CLOSE UP STACK
	POP	%P,-1(%P)
	MOVE	CHAR,ENTRY	;ENTRY POINT IN LH
	HRRI	CHAR,DEV	;ADDR OF BLOCK IN RH
	RUN	CHAR,		;ASK TO RUN IT
	TLNE	FLAG,CONDRN
	POPJ	%P,		;ERROR RETURN
	MOVEI	ERROR,[ASCIZ/RUN - $:$.$ CAN NOT BE RUN/]
	PUSHJ	%P,%ERROR	;UNCONDITIONAL RUN
	MOVE	ERROR,DEV
	PUSHJ	%P,%ERRSB	;EDIT IN DEVICE NAME
	MOVE	ERROR,NAME
	PUSHJ	%P,%ERRSB	;AND FILE NAME
	MOVE	ERROR,EXT
	PUSHJ	%P,%ERRSB	;AND EXTENSION
	EXIT

	END
	EXIT