Google
 

Trailing-Edge - PDP-10 Archives - ap-5069b-sb - 10,6/algots.mac
There are 8 other files named algots.mac in the archive. Click here to see a list.
;
;
;
;
;
;
;	COPYRIGHT (C) 1975,1976,1977
;	DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
;
;
;	THIS SOFTWARE IS FURNISHED UNDER ALICENSE FOR USE ONLY ON A
;	SINGLE COMPUTER SYSTEM AND MAY BE COPIED ONLY WITH THE INCLUSION
;	OF THE ABOVE COPYRIGHT NOTICE.  THIS SOFTWARE, OR ANY OTHER
;	COPIES THEREOF, MAY NOT BE PROVIDED OR OTHERWISE MADE AVAILABLE
;	TO ANY OTHER PERSON EXCEPT FOR USE ON SUCH SYSTEM AND TO ONE WHO
;	AGREES TO THESE LICENSE TERMS.  TITLE TO AND OWNERSHIP OF THE
;	SOFTWARE SHALL AT ALL TIMES REMAIN IN DEC.
;
;	THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE WITHOUT
;	NOTICE AND SHOULD NOT BE CONSTRUED AS A COMMITMENT BY DIGITAL
;	EQUIPMENT CORPORATION.
;
;	DEC ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY OF ITS
;	SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DEC.
;
SUBTTL ASSEMBLY SWITCHES AND GLOBALS


	SEARCH ALGPRM,ALGSYS	; SEARCH PARAMETER FILES

	SALL

	%TITLE(ALGOTS,ALGOL OBJECT TIME SYSTEM)
	INTERNAL .JBOPS


	ENTRY %ALGDR

	IFNDEF FTOVRL,<FTOVRL==-1>	; TURN ON OVERLAYS
	FTGETCHK==0
	IFNDEF FTGETCHK,<FTGETCHK==0>	; TURN OFF HEAP-CHECKER.
	IF2, <
	IFN FTGETCHK,<PRINTX HEAP INTEGRITY CHECKER LOADED>>
	FTADMP==1
	IFNDEF	FTADMP,<FTADMP==0>	; [P70] 1 to give automatic DUMP ALL on error in batch.
PATCH(70)

	EXTERNAL .JBUUO,.JB41,.JBREL,.JBHRL,.JBSA,.JBDA,.JBSYM
	EXTERNAL .JBFF,.JBAPR,.JBCNI,.JBTPC,.JBOPC
	EXTERNAL .JBINT,.JBDDT
	EXTERNAL %ALGDD,DDINI%,BREAK%,DDBRK%,DDTOU%,DDTIN%,DDERM%,DDTER%,FNDAD%,DUMP%
	INTERNAL IPRNT%,DPRNT%,PRFPR%,STSPR%,CNCTR%,HSTPR%,HSTPR.
	INTERNAL DDCON%,DDFIN%,DDBEG%,RSTRT%,SPACE%,CRLF%,FLABL%

	MLON
	IFNDEF HPCHN,<HPCHN==10>
	IFNDEF OVLCHN,<OVLCHN==10>
SUBTTL TYPE CONVERSION MACROS

; CONVERTS ARGUMENT IN A0 OR A0,A1 INTO RESULT IN A0 OR A0,A1

; CALLING VERSIONS

	DEFINE CIR		; CONVERT INTEGER TO REAL
<	JSP	AX,IR
>

	DEFINE CILR		; CONVERT INTEGER TO LONG REAL
<	JSP	AX,ILR
>

	DEFINE CRI		; CONVERT REAL TO INTEGER
<	JSP	AX,RI
>

	DEFINE CLRI		; CONVERT LONG REAL TO INTEGER
<	JSP	AX,LRI
>

	DEFINE CLRR		; CONVERT LONG REAL TO REAL
<	JSP	AX,LRR
>

; CONVERTS ARGUMENT IN A0 OR A0,A1 INTO RESULT IN A3 OR A3,A4

	DEFINE SCIR
<	JSP	AX,SIR
>

	DEFINE SCILR
<	JSP	AX,SILR
>

	DEFINE SCRI
<	JSP	AX,SRI
>

	DEFINE SCLRI
<	JSP	AX,SLRI
>

	DEFINE SCLRR
<	JSP	AX,SLRR
>
SUBTTL DELOCATE PUSH AND RELOCATE POP MACROS

	DEFINE DPUSH(A)
<	SUBI	A,(DB)
	PUSH	SP,A
>

	DEFINE RPOP(A)
<	POP	SP,A
	ADDI	A,(DB)
>


; RE-DEFINE DOUBLE-LENGTH LOAD/STORE FOR OTS KA/KI INDEPENDENCE

	DEFINE	LRLOAD(A,B),<
	MOVE	A,B
	MOVE	1+A,1+B
>

	DEFINE	LRSTOR(A,B),<
	MOVEM	A,B
	MOVEM	1+A,1+B
>
	SUBTTL ROUTINE DIRECTORY

	%ALGDR=.		; IF THIS LABEL IS NOT DEFINED
				; REFERENCES TO IT ARE GENERATED BY
				; MACRO EXPANSIONS ON PASS 1

	DEFINE	DDDUMP,<DUMP%>	; AVOID INFINITE LOOP
	LALL
	ALGDIR			; CALL ALGDIR MACRO

	SALL
SUBTTL MASTER CONTROL ROUTINE

; ENTERED FROM ALGOBJ (IN ALGLIB) WITH
; LH(AX): BIT 0 = 0 FOR START
;	        = 1 FOR REENTER
; RH(AX) = ADDRESS OF PARAMETER BLOCK

INITIA:	RESET			; INITIALIZE IO
	HLRZ	A3,.JBSA	; HEAP ORIGIN
PATCH (2)	; RE-IMPLEMENT /D (SET HEAP SIZE) SWITCH
	HRRZ	A4,3(AX)	; GET HEAP SIZE (%HEAP)
	CAIGE	A4,DELTA1	; ENSURE IT'S AT LEAST
	MOVEI	A4,DELTA1	;   THE MINIMUM
	MOVEI	DB,(A3)
	ADDI	DB,(A4)		; DATA BASE
	HLL	DB,3(AX)	; GET FLAGS
PATCH (20)	; PASS COMPILER FLAGS TO OTS
	HRLOI	A0,377776
	AOBJN	A0,.+5		; IS IT A KI10 OR KL10?
	TLO	DB,OMC1		; YES - SET FLAG
PATCH (22)	; KL10
	MOVEI	A0,0		; TEST FOR KL10 DEPENDS ON DIFFERENT
	BLT	0,0		;  WAY THAT BLT WORKS.
	SKIPE	0		; IF AC IS NON-ZERO,
	TLO	DB,OMC2		; IT'S A KL - REMEMBER
	MOVEM	DB,.JBOPS	; SAVE COPY
	MOVEI	SP,%DBL-1(DB)	; STACK ORIGIN

INIT0:	HRRZ	A2,.JBSA	; GET CURRENT START ADDRESS
	CAIE	A2,INIT8	; AND IF WE HAVE NOT YET STARTED
	MOVEI	A2,INIT4	; TRAP START AFTER CONTROL-C FROM
	HRRM	A2,.JBSA	; ALGDDT ON INITIAL REENTER
	MOVEI	A2,2(SP)
	CAMG	A2,.JBREL	; WILL STACK FIT IN CORE?
	JRST	INIT1		; YES
	CORE	A2,		; NO - TRY TO EXPAND CORE
	JRST	[
	TTCALL	3,M201		; FAILED
	EXIT	1,	
	JRST	INIT0]		; TRY AGAIN IF "CONT"

INIT1:	HRLZI	A2,(A3)
	HRRI	A2,1(A3)
	SETZM	(A3)
	BLT	A2,@.JBREL	; CLEAR OUT DATA BASE AND STACK
PATCH (2)	; RE-IMPLEMENT /D SWITCH (1 LINE DELETED)
	HRLZM	A4,(A3)		; FILL IN HEAP SIZE
PATCH (4)	; STACK-SHIFTER STATISTICS
	MOVEM	A3,%SYS21(DB)	; SAVE HEAP ORIGIN FOR HEAP-SIZE STATISTICS
PATCH (27)	; REVISE HEAP MANAGEMENT
	HRLZI	A1,HPCHN+1	; SET UP HEAP TABLE AS A
	MOVEM	A1,(A3)		; USED HEAP PORTION
	SKIPA	A1,.+1		; SET UP A COUNTER-MODIFIER
	XWD	1-HPCHN,0
	ADDI	A1,1(A3)	; TO TABLE
	MOVEM	A1,%SYS2(DB)
	ADDI	A3,HPCHN+1	; A3 POINTS TO 1ST FREE AREA
	SUBI	A4,HPCHN+1	; AND A4 HAS ITS LENGTH
	HRLI	A3,(A4)
	MOVEM	A3,(A1)		; MAKE THE TABLE ENTRY
	HLL	A1,A3		; AND THE
	MOVEM	A1,(A3)		; BACK POINTER
	SETOM	%CHAN(DB)	; SELECT CHANNEL -1
	MOVEM	AX,%SYS0(DB)	; SAVE PARAMETER BLOCK ADDRESS
PATCH (31)	; OVERLAY HANDLER
	HRLI	A1,5(AX)	; MOVE LOAD-FILE INFO
	HRRI	A1,%IFDAT(DB)	;  TO PERMANENT HOME
	BLT	A1,%IFDAT+2(DB)	;   FOR OVERLAY-HANDLER
	SKIPN	A1,10(AX)	; [P37] GET TRACE BUFFER LENGTH
	MOVEI	A1,^D100	; [P37] DEFAULT IF ZERO (COMPILER VER < 6)
	HRL	A1,A1		; [P37]
	MOVEM	A1,%TRLNTH(DB)	; [P37] AND SAVE IT IN BOTH HALVES
PATCH (37)	; TRACE
	MOVN	A1,.JBREL
	MOVNM	A1,%SYS1(DB)	; SAVE INITIAL CORE SIZE
	ADDI	A1,(SP)
	HRLI	SP,(A1)		; SET UP COUNT FOR PUSH DOWN OVERFLOW
	HRLZI	A1,IOTTC
	HRRI	A1,%TTY(DB)
	MOVEM	A1,%IODR-1(DB)	; INITIALIZE CHANNEL -1
	HRRZ	A0,2(AX)	; GET %OWN
INIT2:	HRRZ	A1,A0		; NEXT OWN AREA
	HRRZ	A2,(A1)		; GET POINTER TO NEXT
	JUMPN	A2,INIT2A	; NOT LAST ONE
	HLRZ	A2,(A1)		; GET LENGTH
	CAILE	A2,^D10		; GREATER THAN LENGTH OF %SFILE AREA ?
	MOVEI	A2,^D10		; YES - SET TO THAT.
	ADDI	A2,%SFILE-1(DB)	; GET END OF TRANSFER
	HRLZI	A3,1(A1)	; MAKE
	HRRI	A3,%SFILE(DB)	;  POINTER
	BLT	A3,(A2)		; MOVE SYMBOL FILENAME TO DATA-BASE

INIT2A:	HLRZ	A2,(A1)		; GET ITS LENGTH
	SOJLE	A2,INIT3	; EMPTY?
	SETZM	1(A1)		; NO - ZERO FIRST FREE WORD
	SOJE	A2,INIT3	; ANY MORE
	HRLZI	A0,1(A1)	; YES
	HRRI	A0,2(A1)	; PREPARE FOR BLT
	ADDI	A2,1(A1)	; SET UP END ADDRESS
	BLT	A0,(A2)		; AND ZERO AREA

INIT3:	HRRZ	A0,(A1)
	JUMPN	A0,INIT2	; KEEP GOING IF MORE
PATCH (16)	; IMPLEMENT INFO ROUTINE
	MOVE	A2,4(AX)	; GET COMPILER VERSION WORD
	MOVEM	A2,%SYS23(DB)	; AND SAVE IT
	DATE	A2,	
	MOVEM	A2,%SYS3(DB)	; SAVE DATE IN %SYS3
	MSTIME	A0,	
	MOVEM	A0,%SYS4(DB)	; SAVE TIME OF DAY IN %SYS4
	MOVEI	A1,0
	RUNTIM	A1,	
	MOVEM	A1,%SYS5(DB)	; SAVE RUNTIME IN %SYS5
	MUL	A0,A1
	ROT	A1,(A2)
	MOVEM	A1,%RAND(DB)	; INITIALIZE %RAND
	HRROS	%DDTER(DB)	; SET REDIRECT CHAN # = -1 (TTY:)
	HRLZI	A0,%ES-%DBL
	HRRI	A0,%ES-1(DB)
	MOVEM	A0,%ESP(DB)	; SET UP EMERGENCY STACK POINTER
	MOVE	A0,[
	JRST	UUO]
	MOVEM	A0,%UUO+1(DB)
	HRLZI	A0,<JSR>B53
	HRRI	A0,%UUO(DB)
	MOVEM	A0,.JB41	; SET UP UUO TRAP
	MOVEI	A0,APRERR
	MOVEM	A0,.JBAPR	; SET APR TRAP ADDRESS
	MOVEI	A0,APRFLG
	APRENB	A0,		; AND ENABLE TRAPS
	MOVEI	A0,FM6
	MOVEM	A0,.JBREN	; SET REENTER ADDRESS
	JSP	A1,CONCTR	; SET UP CONTROL-C TRAP
	MOVEM	AX,%ACCS+AX(DB)	; [E655] SAVE THE ONLY AC THAT MATTERS !
EDIT(655)	; AX is clobbered by the debugger - make REE work.
	JUMPL	AX,FM0		; REENTER?
DDBEG%:		; LABEL DEFINED FOR ALGDDT 'START' COMMAND
INIT4:	MOVEI	A2,INIT8	; "NO SECOND START" MESSAGE.
	HRRM	A2,.JBSA	; PREVENT 2ND. START.
	PUSHJ	SP,TRSTD	; [P47] TELL TRACE IT'S THE
	[	0
		3,,12
SIXBIT/MAIN.PROGRAM/
	0]
	MOVEI	DL,(DB)		; SET UP FOR LOCAL STACK
	PUSHJ	SP,@(AX)	; AND ENTER PROGRAM
	XWD	$PRO!$N!$SIM,1

; *************************	; PROGRAM EXECUTES (HOPEFULLY!)

DDFIN%:	; LABEL DEFINED FOR ALGDDT 'FINISH' COMMAND
INIT5:	SETZM	.JBINT
	MOVE	A0,SP		; EDIT #303
	HRRI	A0,[		; SET DRT TRAPS
	PUSHJ	SP,REL0		;  FOR
	JRST	INIT7]		;  TRAPS 46 & 47
	MOVEM	A0,%TRAPS+46(DB)
	MOVEM	A0,%TRAPS+47(DB)
	MOVEI	A1,37

INIT6:	PUSHJ	SP,RELESE	; RELEASE IO CHANNELS
	JFCL	.+1

INIT7:	SOJGE	A1,INIT6
	SETOM	%CHAN(DB)	; MAKE SURE WE ARE ON CHANNEL -1!!!
	PUSHJ	SP,BRKBYT	; BREAK OUTPUT ON CHANNEL -1
	JFCL	.+1
	MOVEI	A1,END1
	PUSHJ	SP,MONIT
PATCH(46)	; REVISE JOB ENDING - NO STATS UNNLESS CONTROLLED OR CONTINUED
	PUSHJ	SP,BRKBYT
	JFCL
	MOVNI	A1,1		; FIND OUT IF CONTROLLED
	CTLJOB	A1,
	JRST	.+2		; NOT IMPLEMENTED
	SKIPGE	A1		; CONTROLLED
	EXIT	1,		; NOT CONTROLLED
	PUSHJ	SP,STSPRT	; PRINT ALL STATS
	EXIT	1,
	JRST	.-1

STSPR%:
STSPRT:	MOVE	A0,.JBREL	; CORE SIZE IN K
	LSH	A0,-12
	ADDI	A0,1
	PUSHJ	SP,IPRINT
	MOVEI	A1,END2
	PUSHJ	SP,MONIT
EDIT(675) ; DO STATISTICS, ETC. CORRECTLY
	MOVEI	A0,0		; [E675]
	RUNTIM	A0,		; [E675]	
	SUBM	A0,%SYS5(DB)	; [E675] EXECUTION TIME IN MS
	EXCH	A0,%SYS5(DB)	; [E675] GET DIFFERENCE, STORE NEW
	PUSHJ	SP,PRTIME	; [E675] PRINT IT
	MOVEI	A1,END3
	PUSHJ	SP,MONIT
	MSTIME	A0,		; [E675] GET TIME OF DAY	
	SUBM	A0,%SYS4(DB)	; [E675] ELAPSED TIME IN MS
	EXCH	A0,%SYS4(DB)	; [E675] GET DIFFERENCE, STORE NEW
	DATE	A1,		; [E675]	
	SUBM	A1,%SYS3(DB)	; [E675] ELAPSED DAYS
	EXCH	A1,%SYS3(DB)	; [E675] GET DIFFERENCE, STORE NEW
	JUMPE	A1,.+3		; NONE
	IMUL	A1,[
	EXP	^D24*^D60*^D60*^D1000]
	ADD	A0,A1		; ALLOW FOR DAYS
	PUSHJ	SP,PRTIME	; [E675] PRINT ELAPSED TIME
	MOVEI	A1,END4
	PUSHJ	SP,MONIT
	MOVEI	A0,(DB)
	SUB	A0,%SYS21(DB)	; WORK OUT CURRENT (LARGEST) HEAP-SIZE
	PUSHJ	SP,IPRINT
	MOVEI	A1,END5
	PUSHJ	SP,MONIT
	MOVE	A0,%SYS20(DB)	; NUMBER OF STACK-SHIFTS
	PUSHJ	SP,IPRINT
	IFN FTGETCHK,<
	MOVEI	A1,END6
	PUSHJ	SP,MONIT
	MOVE	A0,%SYS24(DB)
	PUSHJ	SP,IPRINT
	> ; END OF FTGETCHK
	PUSHJ	SP,DCRLF
	JRST	DCRLF		; EXIT VIA DCRLF
RSTRT%:
INIT8:	OUTSTR	[ASCIZ/
?ALGNSS ALGOL programs cannot be STARTed twice.
/]
		EXIT
END1:	ASCIZ /

End of execution.
/

END2:	ASCIZ /K core

Execution time:/

END3:	ASCIZ /
elapsed time:  /
PATCH (4)	; STACK-SHIFTER STATS
END4:	ASCIZ/
maximum heap size: /
END5:	ASCIZ/, stack-shifts: /
	IFN	FTGETCHK,<
END6:	ASCIZ/

maximum # of used words in heap-table: /
	>
SUBTTL PRTIME - PRINT TIME ROUTINE

PRTIME:	ADDI	A0,5
	IDIVI	A0,^D10		; TIME IN 1/100'THS SECS.
	IDIVI	A0,^D6000
	JUMPE	A0,PRTIM2	; ANY MINUTES?
	PUSH	SP,A1		; YES - SAVE SECONDS
	IDIVI	A0,^D60
	JUMPE	A0,PRTIM1	; ANY HOURS?
	PUSH	SP,A1		; YES - SAVE MINUTES
	PUSHJ	SP,IPRINT	; PRINT HOURS
	MOVEI	A1,PRTIM3
	PUSHJ	SP,MONIT
	POP	SP,A1		; RESTORE MINUTES

PRTIM1:	MOVE	A0,A1
	PUSHJ	SP,IPRINT	; PRINT MINUTES
	MOVEI	A1,PRTIM4
	PUSHJ	SP,MONIT
	POP	SP,A1		; RESTORE SECONDS

PRTIM2:	MOVE	A0,A1
	HRLI	A0,233000
	FDVRI	A0,207620
	MOVEI	A2,1
	MOVEI	A3,1
	MOVEI	A4,2
	PUSHJ	SP,PRINT.	; [P32] PRINT SECONDS AND 1/100'THS
	MOVEI	A1,PRTIM5
	JRST	MONIT0

PRTIM3:	ASCIZ / hrs./

PRTIM4:	ASCIZ / mins./

PRTIM5:	ASCIZ / secs.
/
SUBTTL MONIT - MONITOR ROUTINE

; ENTERED WITH A1 = ADDRESS OF MESSAGE AT
; MONIT IF BREAK NOT REQUIRED
; MONIT0 IF BREAK REQUIRED
; MONSIX IF I/P IS IN SIXBIT (NO BREAK)

DCRLF:	PUSHJ	SP,CRLF		; DOUBLE CRLF

CRLF%:
CRLF:	MOVEI	A1,MONIT4	; SPECIAL CR-LF ENTRY

MONIT0:	TDZA	A0,A0		; CLEAR NO-BREAK FLAG
MONIT:	MOVEI	A0,1		; SET NO-BREAK FLAG
	MOVNI	A2,1
	EXCH	A2,%CHAN(DB)	; FAKE CHANNEL -1
	HRLI	A1,440700	; PREPARE ASCII BYTE-POINTER
	SKIPGE	A0,		; SIXBIT ?
	TLZ	A1,000100	; YES - ADJUST BYTE-POINTER

MONIT1:	ILDB	A13,A1		; GET NEXT BYTE
	JUMPE	A13,MONIT2	; NULL?
	SKIPGE	A0,		; NO - SIXBIT ?
	ADDI	A13,40		; YES - MAKE ASCII
	PUSHJ	SP,OUBYTE	; OUTPUT IT
	JFCL	MONIT1
	JRST	MONIT1

MONIT2:	JUMPN	A0,MONIT3	; BREAK REQUIRED?
	PUSHJ	SP,BRKBYT	; YES - BREAK OUTPUT
	JFCL	MONIT3

MONIT3:	MOVEM	A2,%CHAN(DB)	; RESTORE IO CHANNELS
	POPJ	SP,0

MONIT4:	ASCIZ /
/

MONSIX:	MOVNI	A0,1
	JRST	MONIT+1
SUBTTL FAULT MONITOR

PATCH(67)	; Combine the two command scanners.
;[p67] ***removed ANSWER routine.

FM0:	MOVEI	A1,FM3		; INITIAL ENTRY ON REENTER
	MOVEI	DL,(DB)		; GIVE DEBUGGER SOMETHING TO WORK WITH.
	PUSHJ	SP,MONIT0	; [P50]
;[p67] *** Deleted 25 lines.

FM14:	MOVEI	A0,FM15
	MOVEM	A0,.JBOPC	; SET UP SO DDT CONTIN WILL RETURN HERE
	PUSH	SP,AX		; ALGDDT TENDS TO CLOBBER THIS.
	JRST	%ALGDD

FM15:	POP	SP,AX
	JRST	INIT4		; [P67]


FM3:	ASCIZ /
!ALGOL diagnostic system
!(H for Help) /

TRACE1:	ASCIZ/
%ALGNTL No trace list entries
/
TRACE2:	ASCIZ/
!
!ALGOL postmortem trace (latest first)
/
PRFMES:	ASCIZ/
Profile Print.

Count	Name
-----	----

/

PATCH(67)	; Combine the two command scanners.

CNCTR%:
CONCTR:	MOVNI	A0,1		; [P73]
	CTLJOB	A0,		; [P73] SEE IF BATCH.
	  JRST	.+2		; [P73] VERY OLD MONITOR!
	JUMPGE	A0,(A1)		; [P73] BATCH - NO ^C INTERCEPT.
PATCH(73)	; Suppress ^C intercepts in batch.
	MOVE	A0,[
	XWD	4,CONC]
	MOVEM	A0,%CONC(DB)
	MOVEI	A0,CONCF!ILLUUO!DQUOTA
	MOVEM	A0,%CONC+1(DB)
	SETZM	%CONC+2(DB)	; MONITOR REQUIRES THIS TO BE ZEROED.
	MOVEI	A0,%CONC(DB)
	MOVEM	A0,.JBINT	; SET UP CONTROL-C TRAP
	JRST	(A1)

CONC:	SETZM	.JBINT		; CONTROL-C - TURN IT OFF
	MOVEM	A0,%ACCS+A0(DB)
	HLRZ	A0,%CONC+3(DB)
	CAIE	A0,CONCF	; WAS IT CONTROL-C?
	EXIT	1,		; NO - STOP
	MOVE	A0,%CONC+2(DB)
	MOVEM	A0,.JBOPC	; SAVE PC

	HRLZI	A0,A1
	HRRI	A0,%ACCS+A1(DB)
	BLT	A0,%ACCS+SP(DB)	; SAVE AC'S
	PUSHJ	SP,BRKBYT	; FINISH OUTPUT
	  JFCL
	HRRZ	A4,.JBOPC	; GET P.C.
	TRNE	A4,400000	; IN OTS ?
	  MOVEI	A4,(AX)		; YES - ASSUME LINK IS IN AX!

	MOVEI	A1,[ASCIZ/
Stopped/]
	PUSHJ	SP,MONIT
	TLO	DB,TMPFL3	; [P77]TELL HSTPRT NOT TO TYPE IF EXPERT.
PATCH(77)	; Read SWITCH.INI for ALGDDT/EXPERT line.
	PUSHJ	SP,HSTPRT	; HISTORY PRINT.
	JRST	FM6A
FM6:	MOVEM	A0,%ACCS+A0(DB)	; LATER REENTER ENTRY
	HRLZI	A0,A1
	HRRI	A0,%ACCS+A1(DB)
	BLT	A0,%ACCS+SP(DB)	; YES - SAVE ACCUMULATORS
	PUSHJ	SP,BRKBYT	; CLEAR OUTPUT
	JFCL	.+1

FM6A:	TLZ	DB,INDDT
	SETZM	%SYS17(DB)	; INDICATE NO ERROR
	MOVEI	A1,FM3
	PUSHJ	SP,MONIT0
	JRST	%ALGDD		; [P67] JUMP TO DEBUGGER.

PATCH(67)	; Combine the two command scanners.
;[P67] *** deleted 30-odd lines.

DDCON%:	; LABEL DEFINED FOR ALGDDT 'CONTINUE' COMMAND
FM9:	SKIPE	%SYS17(DB)	; WAS IT AN ERROR
	JRST	FM9A		; YES
	JSP	A1,CONCTR	; RESTORE CONTROL-C INTERCEPT
	HRLZI	A0,%ACCS+A1(DB)
	HRRI	A0,A1
	BLT	A0,A13
	MOVE	AX,%ACCS+AX(DB)	; DON'T RESTORE DB,DL,SP.
	MOVE	A0,%ACCS+A0(DB)	; RESTORE ACCUMULATORS
	JRSTF	@.JBOPC		; AND RETURN TO PROGRAM

EDIT(741); Force "Can't continue" error message out immediately
FM9A:	MOVEI	A1,FM13
	PUSHJ	SP,MONIT0	; [E741] CANNOT CONTINUE
	JRST	%ALGDD		;[P67] JUMP TO DEBUGGER.


;[P67] *** Deleted 15 lines.
;[P67] ***deleted HELP text.
FM13:	ASCIZ /
Can't continue after this error

/
SUBTTL PARAM - PROCEDURE CALL PARAMETER HANDLER

; MAGIC PARAMETER TYPE MATCH TABLE

; LH: FORMAL PARAMETER ENTRY
; RH: ACTUAL PARAMETER ENTRY

TYPTAB:	XWD	421030,000000	; "WILD" VARIABLE
	XWD	421020,000000	; ARITHMETIC/BOOLEAN
	XWD	421022,000000	; ARITHMETIC/BOOLEAN/NONTYPE
	XWD	400020,000000	; INTEGER/BOOLEAN
	XWD	021000,000000	; "WILD" FLOATING
	XWD	000000,000000
	XWD	000000,000000
	XWD	444000,700000	; INTEGER
	XWD	000000,000000
	XWD	000000,000000
	XWD	000000,000000
	XWD	000000,000000
	XWD	000000,000000
	XWD	000000,000000
	XWD	222000,070000	; REAL
	XWD	000000,000000
	XWD	000000,000000
	XWD	000000,000000
	XWD	000000,000000
	XWD	000000,000000
	XWD	000000,000000
	XWD	111000,007000	; LONG REAL
	XWD	000000,000000
	XWD	000000,000000
	XWD	000000,000000
	XWD	000500,000600	; COMPLEX
	XWD	000240,000140	; LONG COMPLEX
	XWD	000000,000000
	XWD	000000,000000
	XWD	000000,000000
	XWD	000000,000000
	XWD	000000,000000
	XWD	421000,000000	; "WILD" ARITHMETIC
	XWD	000000,000000
	XWD	000000,000000
	XWD	000020,000020	; BOOLEAN
	XWD	000000,000000
	XWD	000000,000000
	XWD	000000,000000
	XWD	000000,000000
	XWD	000000,000000
	XWD	000000,000000
	XWD	000004,000004	; LABEL
	XWD	000000,000000
	XWD	000000,000000
	XWD	000000,000000
	XWD	000000,000000
	XWD	000000,000000
	XWD	000000,000000
	XWD	000000,000000
	XWD	000002,000002	; NON-TYPE
	XWD	000000,000000
	XWD	000000,000000
	XWD	000000,000000
	XWD	000000,000000
	XWD	000000,000000
	XWD	000010,000010	; STRING
	XWD	000000,000000
	XWD	000000,000000
	XWD	000000,000000
	XWD	000000,000000
	XWD	000000,000000
	XWD	000000,000000
	XWD	000000,000000
; PROCEDURE CALLS ARE FORMATTED AS FOLLOWS:


;		PUSHJ	SP,PROC
;		XWD	ATYPE,N+1
;		XWD	AT1,AA1
;		XWD	AT2,AA2
;
;		...............
;
;		XWD	ATN,AAN


; WHERE	N = NUMBER OF ACTUAL PARAMETERS

;	ATYPE = TYPE OF PROCEDURE REQUIRED

;	ATI = TYPE OF I'TH ACTUAL PARAMETER

;	AAI = ADDRESS OR VALUE OF I'TH ACTUAL PARAMETER



; THE PROCEDURE HEAD IS FORMATTED AS FOLLOWS:


;		XWD	DL,NA		; IF PAR0 ENTRY
;	PROC:	JSP	AX,PARAM	; OR PAR0
;		EXP	PM-BLOCK-ADDRESS
;		XWD	PL,L
;		XWD	FTYPE,M+1
;		XWD	FT1,FA1
;		XWD	FT2,FA2
;
;		...............
;
;		XWD	FTM,FAM


; WHERE	M = NUMBER OF FORMAL PARAMETERS

;	PL = PROCEDURE LEVEL

;	L = LENGTH OF FIXED STACK REQUIRED (NOT INCLUDING DISPLAY)

;	FTYPE = TYPE OF PROCEDURE

;	FTI = TYPE OF I'TH FORMAL PARAMETER

;	FAI = ADDRESS OF I'TH FORMAL PARAMETER (RELATIVE TO DL)

;	NA = ADDRESS FOR NUMBER OF ACTUAL PARAMETERS (PAR0 ONLY)
; TYPE ABBREVIATIONS:

;	I	INTEGER
;	R	REAL
;	LR	LONG REAL
;	C	COMPLEX (NOT IMPLEMENTED)
;	LC	LONG COMPLEX (NOT IMPLEMENTED)
;	B	BOOLEAN
;	S	STRING
;	L	LABEL
;	N	NON-TYPE (PROCEDURES ONLY)
SUBTTL PARAM - PROCEDURE TYPE HANDLING

PARAM:	TDZA	A1,A1		; NORMAL ENTRY
PAR0:	MOVEI	A1,1		; VARIABLE NUMBER OF PARAMETERS ENTRY
EDIT(734); Chain DL for debugger
	MOVE	A3,%DDTDL(DB)	; [E734] GET TOP-LEVEL DL
	EXCH	A3,(SP)		; [E734] STACK BEFORE PRGLNK
	MOVEI	A3,(A3)		; [E734] CLEAR PC FLAGS
	HRRZ	A0,(A3)		; NUMBER OF AP'S + 1
	CAILE	A3,(DB)
	CAILE	A3,(SP)		; IF THE LINK IS ABSOLUTE
	JRST	PAR5		; THEN LEAVE IT ALONE
	SUBI	A3,(DB)		; OTHERWISE DELOCATE IT
	HRLI	A3,DB		; AND PUT IN THE DB BITS

PAR5:	PUSH	SP,A3		; [E734] PUT PRGLNK ON STACK
	ADDM	A0,(SP)		; ADVANCE LINK OVER AP'S
	AOS	%TRLV(DB)	; UPDATE DYNAMIC BLOCK COUNT
	PUSH	SP,0(AX)	; SAVE PMB POINTER
PATCH (32)	; PLANT PM BLOCKS
	HRRZ	A2,2(AX)	; NUMBER OF FP'S + 1
	XCT	[
	CAIE	A0,(A2)
	CAILE	A0,(A2)](A1)	; CHECK ON NUMBER OF PARAMETERS
	SYSER1	10,0		; WRONG
	MOVE	A4,DL		; GET CONDL INTO A4
	SUBI	A4,(DB)		; DELOCATE AND
	PUSH	SP,A4		; SAVE CONTEXT DL
	PUSH	SP,[0]		; INITIALIZE BLOCK POINTER
	HLLZ	A5,1(AX)	; SAVE PROCEDURE LEVEL
	PUSH	SP,A5		; AND INITIALIZE BLOCK LEVEL
	MOVEI	DL,1(SP)	; SET UP NEW DL
	HLRZ	A5,A5		; PROCEDURE LEVEL
	TLNE	A4,-1		; IS THIS PROCEDURE PARAMETRIC?
	HLRZ	A4,A4		; YES - USE ENVIRONMENT
	ADDI	A4,(DB)

PAR1:	SOJL	A5,PAR2		; LEVELS EXHAUSTED?
	PUSH	SP,(A4)		; NO - COPY DISPLAY ELEMENT
	AOJA	A4,PAR1		; AND ADVANCE OLD DL

PAR2:	MOVEI	A4,(DL)
	SUBI	A4,(DB)
	TLO	A4,DB
	PUSH	SP,A4		; ADD NEW DL
	AOS	%DDTPL(DB)	; UPDATE DYNAMIC PROCEDURE LEVEL
	MOVEM	A4,%DDTDL(DB)	; [E734] REMEMBER THIS DL
	HLRZ	A5,@A3
	ANDI	A5,$TYPE
	LSH	A5,-11		; TYPE OF PROCEDURE REQUIRED
	HRLZ	A5,TYPTAB(A5)	; GET TABLE ENTRY FOR IT
	HLRZ	A6,2(AX)
	ANDI	A6,$TYPE
	LSH	A6,-11		; TYPE OF PROCEDURE
	JUMPN	A5,.+2		; ANY ACTUAL TYPE BITS?
	HRLZ	A5,TYPTAB(A6)	; NO - FIX FOR SPRO5!!!
	AND	A5,TYPTAB(A6)	; GATE TABLE ENTRIES
	JFFO	A5,PAR4		; AND SORT IT OUT!!!!!!!

PAR3:	SYSER1	7,0		; MISMATCH
PAR4:	SKIPN	A5,PAR8(A6)	; GET MATCH ENTRY
	JRST	PAR3		; NO GOOD
	PUSH	SP,A5		; YES - PLANT IN EXIT FORMAL
	HRRZ	A5,1(AX)	; GET FIXED STACK LENGTH
	CAIE	A6,16		; [E710] IS THIS A STRING PROCEDURE ?
	AOSA	A5		; [E710] NO  - RESERVE ONE MORE WORD
	PUSH	SP,[EXP 0]	; [E710] YES - INITIALIZE TO NULL STRING
	ADDI	SP,-2(A5)	; [E710] AND ADVANCE STACK
	MOVE	A5,.JBREL
	CAIG	A5,2(SP)	; STACK STILL IN CORE
	CCORE	1(A5)		; NO - TRY TO EXPAND
SUBTTL PARAM - MAIN CONTROL LOOP OF PARAMETER HANDLER

	MOVEI	A5,(SP)
	SUB	A5,.JBREL
	HRLI	SP,(A5)		; SET UP LH NEGATIVE COUNT
	MOVE	A13,SP
	SUBI	A13,(DB)
	PUSH	SP,A13		; MAKE FIRST BLOCK POINTER
	AOBJN	A13,.+1
	PUSH	SP,A13		; AND ANOTHER TO ENCLOSE VALUE ARRAYS
	AOBJN	A13,.+1
	MOVEM	A13,BLKPTR(DL)	; AND SET UP POINTER
	MOVN	A13,A0
	HRLZI	A13,(A13)
	HRRI	A13,2(AX)	; COUNTER/POINTER TO FP'S
	ADDI	A2,2(AX)
	ADDI	A3,1		; MOVE TO FIRST AP
	HRL	DL,A2		; SAVE RETURN LINK
	JUMPE	A1,PAR6		; PAR0 ENTRY?
	MOVEM	A0,@-2(AX)	; YES - FILL IN NUMBER OF AP'S

PAR6:	AOBJP	A13,PAR9	; EXIT IF NO MORE PARAMETERS
	HRRZ	A2,@A3		; GET AP ADDRESS
	MOVE	A4,(A13)	; GET FP WORD
	ADDI	A4,(DL)		; AND RELOCATE IT
	HLLZ	A5,@A3		; GET LEFT HALF OF AP WORD
	SETZB	A6,A10
	ROTC	A5,3		; SHIFT STATIC/DYNAMIC AND KIND TO A6
	EXCH	A6,A10		; AND THEN TO A10
	ROTC	A5,6		; SHIFT TYPE TO A6
	ROT	A5,3
	ANDI	A5,<$STAT>B41	; AND GET STATUS IN A5
	HLRZ	A7,A4
	HRRZ	A11,A7
	ANDI	A11,$KIND
	LSH	A11,-17		; GET KIND OF FP
	ANDI	A7,$TYPE
	LSH	A7,-11		; GET TYPE OF FP
	CAIN	A6,<$S>B44	; STRING?
	CAIE	A10,4		; YES - DYNAMIC VARIABLE?
	JRST	PAR10		; NO
	JUMPE	A5,PAR10	; SIMPLE AS WELL?
	MOVEI	A10,10		; NO - RECODE AS SPECIAL
	MOVEI	A6,<$I>B44	; - TYPE IS INTEGER
PAR10:	HRLZ	A6,TYPTAB(A6)	; GET ENTRY FOR AP TYPE
	AND	A6,TYPTAB(A7)	; GATE WITH ENTRY FOR FP TYPE
	JFFO	A6,@PAR7(A10)	; SORT IT OUT AND BRANCH!!!!!!!
	SYSER1	7,0		; MISMATCH

PAR7:	JRST	@SVAR(A11)	; STATIC, VARIABLE
	JRST	@SEXP(A11)	; STATIC, EXPRESSION
	JRST	@SARR(A11)	; STATIC, ARRAY
	JRST	@SPRO(A11)	; STATIC, PROCEDURE
	JRST	@DVAR(A11)	; DYNAMIC, VARIABLE
	JRST	@DEXP(A11)	; DYNAMIC, EXPRESSION
	JRST	PAR3		; DYNAMIC, ARRAY (IMPOSSIBLE)
	JRST	PAR3		; DYNAMIC, PROCEDURE (IMPOSSIBLE)
	JRST	@BVAR(A11)	; DYNAMIC SIMPLE VARIABLE STRING (BYTE)
SUBTTL PARAM - STATIC VARIABLE HANDLER

; LH ENTRY: BY VALUE
; RH ENTRY: BY NAME

SVARD:	XWD	SVAR32,SVAR2	; I -> I
	XWD	SVAR33,SVAR3	; I -> R
	XWD	SVAR34,SVAR7	; I -> LR
	XWD	SVAR35,SVAR11	; R -> I
	XWD	SVAR32,SVAR2	; R -> R
	XWD	SVAR36,SVAR15	; R -> LR
	XWD	SVAR37,SVAR19	; LR -> I
	XWD	SVAR38,SVAR23	; LR -> R
	XWD	SVAR39,SVAR43	; LR -> LR
	XWD	0,0		; C -> C
	XWD	0,0		; C -> LC
	XWD	0,0		; LC -> C
	XWD	0,0		; LC -> LC
	XWD	SVAR32,SVAR2	; B -> B
	XWD	SVAR40,SVAR28	; S -> S
	XWD	0,0		; L -> L [E707] LABELS HANDLED SPECIALLY
	XWD	0,0		; N -> N

SVAR:	XWD	0,SVAR0		; VARIABLE
	XWD	0,PAR3		; EXPRESSION
	XWD	0,PAR3		; ARRAY
	XWD	0,PAR3		; PROCEDURE

EDIT(707);HANDLE FORMAL LABELS CORRECTLY.
SVAR0:	CAIN	A5,<$FON>B41	; FORMAL VARIABLE?
	JRST	FSVR0		; YES - SPECIAL TREATMENT
	CAIN	A7,17		; [E707] LABEL ?
	JRST	SVAR24		; [E707] YES - SPECIAL TREATMENT
	CAIN	A5,<$OWN>B41	; FIXED VARIABLE?
	JRST	SVAR1		; YES
	HLRZ	A6,@A3
	ANDI	A6,$P		; GET VARIABLE LEVEL (P ADDRESS)
	ADD	A6,CONDL(DL)	; ADDRESS OF DISPLAY ENTRY
	ADDI	A6,(DB)		; AND RELOCATE
	ADD	A2,(A6)		; ADD TO Q ADDRESS

SVAR1:	SKIPN	A6,SVARD(A7)	; LOAD UP DISPATCH ENTRY
	JRST	PAR3		; ILLEGAL
	TLNE	A4,$VAL		; FORMAL BY VALUE?
	MOVS	A6,A6		; YES - SWAP HALVES
	JRST	(A6)		; AND DISPATCH
; I -> I, R -> R, B -> B, BY NAME

SVAR2:	TLO	A2,<MOVE	A0,0>B53
	MOVEM	A2,(A4)
	TLO	A2,<MOVEM	A0,0>B53
	MOVEM	A2,1(A4)	; PLANT DIRECT CODE IN F[0],F[1]
	AOJA	A3,PAR6

; I -> R, BY NAME

EDIT(636) ; SET UP A2 ON XCTA WHEN TYPE CONVERSION IS NEEDED
SVAR3:	LRLOAD	A5,SVAR4
	LRSTOR	A5,(A4)		; PLANT INDIRECT CODE IN F[0],F[1]
	MOVEM	A2,2(A4)	; AND ADDRESS IN F[2]
	AOJA	A3,PAR6

SVAR4:	PUSHJ	SP,SVAR5
	PUSHJ	SP,SVAR6

SVAR5:	HRRZ	A2,(SP)		; F[0] CODE
	MOVEI	A2,@-1(A2)
	MOVE	A2,2(A2)
	MOVE	A0,@A2
	CIR
	POPJ	SP,0

SVAR6:
DVAR5:	SCRI			; F[1] CODE
	MOVEM	A3,@A2
	POPJ	SP,0

; I -> LR, BY NAME

SVAR7:	LRLOAD	A5,SVAR8
	LRSTOR	A5,(A4)		; PLANT INDIRECT CODE IN F[0],F[1]
	MOVEM	A2,2(A4)	; AND ADDRESS IN F[2]
	AOJA	A3,PAR6

SVAR8:	PUSHJ	SP,SVAR9
	PUSHJ	SP,SVAR10

SVAR9:	HRRZ	A2,(SP)		; F[0] CODE
	MOVEI	A2,@-1(A2)
	MOVE	A2,2(A2)
	MOVE	A0,@A2
	CILR
	POPJ	SP,0

SVAR10:
DVAR8:	SCLRI			; F[1] CODE
	MOVEM	A3,@A2
	POPJ	SP,0
; R -> I, BY NAME

SVAR11:	LRLOAD	A5,SVAR12
	LRSTOR	A5,(A4)		; PLANT INDIRECT CODE IN F[0],F[1]
	MOVEM	A2,2(A4)	; AND ADDRESS IN F[2]
	AOJA	A3,PAR6

SVAR12:	PUSHJ	SP,SVAR13
	PUSHJ	SP,SVAR14

SVAR13:	HRRZ	A2,(SP)		; F[0] CODE
	MOVEI	A2,@-1(A2)
	MOVE	A2,2(A2)
	MOVE	A0,@A2
	CRI
	POPJ	SP,0

SVAR14:
DVAR11:	SCIR			; F[1] CODE
	MOVEM	A3,@A2
	POPJ	SP,0
; R -> LR, BY NAME

SVAR15:	LRLOAD	A5,SVAR16
	LRSTOR	A5,(A4)		; PLANT INDIRECT CODE IN F[0],F[1]
	MOVEM	A2,2(A4)	; AND ADDRESS IN F[2]
	AOJA	A3,PAR6

SVAR16:	PUSHJ	SP,SVAR17
	PUSHJ	SP,SVAR18

SVAR17:	HRRZ	A2,(SP)		; F[0] CODE
	MOVEI	A2,@-1(A2)
	MOVE	A2,2(A2)
	MOVE	A0,@A2
	MOVEI	A1,0
	POPJ	SP,0

SVAR18:
DVAR14:	SCLRR			; F[1] CODE
	MOVEM	A3,@A2
	POPJ	SP,0

; LR -> I, BY NAME

SVAR19:	LRLOAD	A5,SVAR20
	LRSTOR	A5,(A4)		; PLANT INDIRECT CODE IN F[0],F[1]
	MOVEM	A2,2(A4)	; AND ADDRESS IN F[2]
	AOJA	A3,PAR6

SVAR20:	PUSHJ	SP,SVAR21
	PUSHJ	SP,SVAR22

SVAR21:	HRRZ	A2,(SP)		; F[0] CODE
	MOVEI	A2,@-1(A2)
	MOVE	A2,2(A2)
	MOVE	A0,@A2
	ADDI	A2,1
	MOVE	A1,@A2
	SUBI	A2,1
	CLRI
	POPJ	SP,0
SVAR22:
DVAR17:	SCILR			; F[1] CODE
	MOVEI	A2,@A2
	LRSTOR	A3,(A2)
	POPJ	SP,0

; LR -> R, BY NAME

SVAR23:	LRLOAD	A5,SVAR25
	LRSTOR	A5,(A4)		; PLANT INDIRECT CODE IN F[0],F[1]
	MOVEM	A2,2(A4)	; AND ADDRESS IN F[2]
	AOJA	A3,PAR6

SVAR25:	PUSHJ	SP,SVAR26
	PUSHJ	SP,SVAR27

SVAR26:	HRRZ	A2,(SP)		; F[0] CODE
	MOVEI	A2,@-1(A2)
	MOVE	A2,2(A2)
	MOVE	A0,@A2
	ADDI	A2,1
	MOVE	A1,@A2
	SUBI	A2,1
	CLRR
	POPJ	SP,0

SVAR27:
DVAR20:	MOVEI	A2,@A2		; F[1] CODE
	MOVEM	A0,(A2)
	SETZM	1(A2)
	POPJ	SP,0
; LR -> LR, BY NAME

SVAR43:	JUMPG	DB,SVAR29	; [E711]
	TLO	A2,<DMOVE	A0,0>B53
	MOVEM	A2,(A4)
	TLO	A2,<DMOVEM	A0,0>B53
	MOVEM	A2,1(A4)
	AOJA	A3,PAR6

; S -> S, BY NAME

SVAR28:	SKIPA	A6,[PUSHJ SP,SVAR44]	; [E711] F[1] CODE FOR STRINGS
SVAR29:	MOVE	A6,[PUSHJ SP,SVAR31]	; [E711] F[1] CODE FOR LONG REALS
	MOVE	A5,[PUSHJ SP,SVAR30]	; [E711] F[0] CODE FOR EITHER
	LRSTOR	A5,(A4)		; PLANT INDIRECT CODE IN F[0],F[1]
	MOVEM	A2,2(A4)	; AND ADDRESS IN F[2]
	AOJA	A3,PAR6

SVAR30:	HRRZ	A2,(SP)		; F[0] CODE
	MOVEI	A2,@-1(A2)
	MOVE	A2,2(A2)
	MOVE	A0,@A2
	ADDI	A2,1
	MOVE	A1,@A2
	SUBI	A2,1
	POPJ	SP,0

SVAR31:
DVAR23:	MOVEI	A2,@A2		; F[1] CODE
	LRSTOR	A0,(A2)
	POPJ	SP,0

EDIT(711); REVISE ASSIGNMENT TO FORMAL STRINGS
SVAR44:	PUSH	SP,A0		; [E711] SAVE R.H. STRING ON STACK
	PUSH	SP,A1		; [E711] FOR CALL TO STRASS
	MOVEI	A1,@A2		; [E711] GET ACTUAL ADDRESS OF STRING
	LRLOAD	A0,(A1)		; [E711] AND LOAD UP STRING HEADER
	JSP	AX,STRASX	; [E711] LET STRASS DO THE WORK
	MOVEI	A2,@A2		; [E711] THEN GET HEADER ADDRESS
	LRSTOR	A0,(A2)		; [E711] AND STORE NEW STRING
	POPJ	SP,		; [E711] RETURN
; I -> I, R -> R, B -> B, BY VALUE

SVAR32:
DVAR25:	MOVE	A0,@A2

DEXP18:	MOVEM	A0,(A4)		; PLANT VALUE IN F[0]
	AOJA	A3,PAR6

; I -> R, BY VALUE

SVAR33:
DVAR26:	MOVE	A0,@A2

DEXP19:	CIR
	MOVEM	A0,(A4)		; PLANT VALUE IN F[0]
	AOJA	A3,PAR6

; I -> LR, BY VALUE

SVAR34:
DVAR27:	MOVE	A0,@A2

DEXP20:	CILR
	LRSTOR	A0,(A4)		; PLANT VALUE IN F[0],F[1]
	AOJA	A3,PAR6

; R -> I, BY VALUE

SVAR35:
DVAR29:	MOVE	A0,@A2

DEXP21:	CRI
	MOVEM	A0,(A4)		; PLANT VALUE IN F[0]
	AOJA	A3,PAR6

; R -> LR, BY VALUE

SVAR36:
DVAR30:	MOVE	A0,@A2

DEXP22:	MOVEM	A0,(A4)
	SETZM	1(A4)		; PLANT VALUE IN F[0],F[1]
	AOJA	A3,PAR6
; LR -> I, BY VALUE

SVAR37:
SEXP26:
DVAR31:	MOVEI	A2,@A2
	LRLOAD	A0,(A2)

DEXP23:	CLRI
	MOVEM	A0,(A4)		; PLANT VALUE IN F[0]
	AOJA	A3,PAR6

; LR -> R, BY VALUE

SVAR38:
SEXP27:	MOVEI	A2,@A2
	LRLOAD	A0,(A2)
	CLRR
	MOVEM	A0,(A4)		; PLANT VALUE IN F[0]
	AOJA	A3,PAR6

; LR -> LR, BY VALUE

SVAR39:
DVAR28:
SEXP29:
SARR2:	MOVEI	A2,@A2
	LRLOAD	A0,(A2)

DEXP25:	LRSTOR	A0,(A4)		; PLANT VALUE IN F[0],F[1]
	AOJA	A3,PAR6
; S -> S, BY VALUE

SVAR40:
SEXP28:	MOVEI	A2,@A2
	LRLOAD	A0,(A2)

EDIT(701); Pass strings by value correctly
DEXP26:	MOVEI	A2,(A4)		; [E701] GET LOCAL STACK ADDRESS
	SUBI	A2,(DB)		; [E701] AND DELOCATE IT
	HRLI	A2,(<Z @(DB)>)	; [E701] SET POINTER THROUGH STRING HEADER
	EXCH	A2,(SP)		; [E701] ADD TO LIST ON THE STACK
	PUSH	SP,A2		; [E701] AND MAKE NEW BLOCK POINTER
	MOVE	A2,SP		; [E701] THEN GET DELOCATED TOP OF
	SUBI	A2,(DB)		; [E701] STACK FRAME AT THIS MOMENT
	MOVEM	A2,BLKPTR(DL)	; [E701] AND SAVE IT IN DISPLAY
	PUSH	SP,A0		; [E701] PUSH POINTER TO THE ACTUAL
	PUSH	SP,A1		; [E701] STRING ONTO THE STACK
	JSP	AX,STRAS0	; [E701] GET A COPY OF THE ACTUAL BYTES
	HRRZ	A2,-1(SP)	; [E701] GET STRING HEADER ADDRESS
	ADDI	A2,(DB)		; [E701] AND RELOCATE IT
	LRSTOR	A0,(A2)		; [E701] AND POINT TO THE NEW STRING
	AOJA	A3,PAR6
; L -> L, BY NAME, BY VALUE

EDIT(707);MAKE FORMAL SWITCHES WORK PROPERLY
SVAR24:	CAIN	A5,<$FOV>B41	; [E707] FORMAL LABEL BY VALUE ?
	JRST	FSVR0		; [E707] YES - LABELS BY VALUE ARE SPECIAL
SVAR41:
DEXP17:	MOVE	A5,[
	PUSHJ	SP,SVAR42]
	MOVEM	A5,(A4)		; PLANT CODE IN F[0]
	MOVEM	A2,1(A4)	; [E707] LABEL ADDRESS IN F[1]
	HRRZ	A5,CONDL(DL)	; AND CONTEXT DL
	HRLZM	A5,2(A4)	; IN LEFT HALF OF F[2]
	AOJA	A3,PAR6

SVAR42:	HRRZ	A1,(SP)		; [E707] DONT OVERWRITE A2 YET !
	SKIPA	A1,-1(A1)	; [E707] GET XCT INSTRUCTION
	MOVE	A1,@A1		; [E707] FOLLOW XCT CHAIN
	HLRZ	A0,@A1		; [E707] GET THE TARGET INSTRUCTION
	ANDI	A0,777000	; [E707] CLEAR AC AND INDEX FIELDS
	CAIN	A0,(XCT 0,0)	; [E707] WAS THIS AN XCT INSTRUCTION ?
	JRST	.-4		; [E707] YES - FIND OUT WHAT IT POINTS TO
	MOVEI	AX,@A1		; [E707] NO  - GET FORMAL ADDRESS
	MOVE	A2,1(AX)	; [E707] NOW GET F[1]
	TRNE	A2,-1		; [E707] IF SWITCH OUT OF RANGE
	TLNE	A2,-1		; [E707] OR ALREADY A FORMAL
	POPJ	SP,		; [E707] THEN RETURN
	SUBI	AX,(DB)		; DELOCATE FORMAL ADDRESS
	HRLZI	A2,(AX)
	HRRI	A2,FORLAB	; AND PREPARE FOR FORLAB
	POPJ	SP,0
; FORMAL STATIC VARIABLES

; LH ENTRY: BY VALUE
; RH ENTRY: BY NAME

FSVARD:	XWD	DEXP18,FSVR2	; I -> I
	XWD	DEXP19,FSVR4	; I -> R
	XWD	DEXP20,FSVR7	; I -> LR
	XWD	DEXP21,FSVR10	; R -> I
	XWD	DEXP18,FSVR2	; R -> R
	XWD	DEXP22,FSVR13	; R -> LR
	XWD	DEXP23,FSVR16	; LR -> I
	XWD	DEXP24,FSVR19	; LR -> R
	XWD	DEXP25,FSVR2	; LR -> LR
	XWD	0,0		; C -> C
	XWD	0,0		; C -> LC
	XWD	0,0		; LC -> C
	XWD	0,0		; LC -> LC
	XWD	DEXP18,FSVR2	; B -> B
	XWD	DEXP26,FSVR2	; S -> S
	XWD	DEXP17,FLAB01	; L -> L
	XWD	0,0		; N -> N
FSVR0:	HLRZ	A1,@A3
	ANDI	A1,$P		; VARIABLE LEVEL (P ADDRESS)
	ADD	A1,CONDL(DL)	; ADDRESS OF DISPLAY ENTRY
	ADDI	A1,(DB)
	ADD	A2,(A1)		; ADD TO Q ADDRESS
	SKIPN	A6,FSVARD(A7)	; LOAD UP DISPATCH TABLE ENTRY
	JRST	PAR3		; ILLEGAL
	TLNN	A4,$VAL		; FORMAL BY NAME?
	JRST	FSVR1		; YES
	SKIPA	A5,A2		; NO - GET ADDRESS IN A5

DEXP14:	MOVEI	A5,[
	PUSHJ	SP,(A2)]	; DYNAMIC EXPRESSION ENTRY
	MOVS	A6,A6		; TAKE LEFT HALF OF DISPATCH ENTRY
	PUSH	SP,A6		; AND SAVE IT
	PUSH	SP,A3
	DPUSH	A4
	PUSH	SP,A13		; SAVE VALUABLE ACCUMULATORS
	MOVEI	A1,(DL)
	DPUSH	DL		; SAVE CURRENT DL
	HRRZ	DL,CONDL(A1)
	ADDI	DL,(DB)
	XCT	@A5		; EVALUATE FORMAL OR THUNK
	RPOP	DL		; RESTORE DL
	POP	SP,A13
	RPOP	A4
	POP	SP,A3		; RESTORE VALUABLE ACCUMULATORS
	POP	SP,A6		; AND DISPATCH ADDRESS
	JRST	(A6)		; DISPATCH

FSVR1:	HRL	A2,(A1)		; GET CORRECT DL

FSVR22:	MOVEM	A2,2(A4)	; AND PLANT IN F[2]
	LRLOAD	A5,(A6)
	LRSTOR	A5,(A4)		; AND CODE IN F[0],F[1]
	AOJA	A3,PAR6
; ROUTINES FOR HANDLING ACTUALS THAT ARE ARE FORMALS

FSVRC0:	MOVE	A2,-1(SP)	; INDIRECT ENTRY ON F[0]
	MOVE	A0,-1(A2)	; GET XCT ORDER
	MOVEI	A2,@A0
	MOVE	AX,2(A2)	; GET CONTEXT DL AND ADDRESS
	DPUSH	DL		; SAVE CURRENT DL
	HLRZ	DL,AX		; AND ASSUME FORMAL'S DL
	ADDI	DL,(DB)
	ADDI	AX,(DB)
	TLNE	A0,$A		; XCTA?
	JRST	FSVRCA		; YES
	XCT	(AX)		; NO - GET VALUE OF FORMAL
	RPOP	DL		; RESTORE CURRENT DL
	POPJ	SP,0

FSVRCA:	XCTA	(AX)		; GET ADDRESS OF FORMAL
	RPOP	DL		; RESTORE CURRENT DL
	POP	SP,AX		; LOSE F[0]'S LINK
	POPJ	SP,0

; N.B. A2 IS SET UP FROM FSVRCA

EDIT(735); Remember values are stored on the stack
FSVRD1:	MOVE	A3,(SP)		; [E735] DIRECT ENTRY ON F[1]
	JRST	FSVRDC		; [E735] JOIN COMMON CODE
FSVRC1:	SKIPA	A3,-2(SP)	; [E735] INDIRECT ENTRY ON F[1]
FSVRC2:	MOVE	A3,-3(SP)	; [E735] DITTO, TWO WORD VARIABLE
FSVRDC:	MOVEI	A3,@-1(A3)	; [E735] ADD LABEL FSVRDC
	MOVE	AX,1(A3)	; GET CONTEXT DL AND ADDRESS
	DPUSH	DL		; SAVE CURRENT DL
	HLRZ	DL,AX		; AND ASSUME FORMAL'S DL
	ADDI	DL,(DB)
	ADDI	AX,(DB)
	XCT	1(AX)		; STORE RESULT IN FORMAL
	RPOP	DL		; RESTORE CURRENT DL
	POPJ	SP,0
; I -> I, R -> R, LR -> LR, B -> B, S -> S, L -> L, BY NAME

FSVR2:	PUSHJ	SP,FSVR3
	PUSHJ	SP,FSVRD1	; DIRECT F[1] CODE

FSVR3:	PUSHJ	SP,FSVRC0	; INDIRECT F[0] CODE
	POPJ	SP,0

; I -> R, BY NAME

FSVR4:	PUSHJ	SP,FSVR5
	PUSHJ	SP,FSVR6

FSVR5:	PUSHJ	SP,FSVRC0	; INDIRECT F[0] CODE
	CIR
	POPJ	SP,0

FSVR6:	PUSH	SP,A0		; INDIRECT F[1] CODE
	CRI
	PUSHJ	SP,FSVRC1
	POP	SP,A0
	POPJ	SP,0

; I -> LR, BY NAME

FSVR7:	PUSHJ	SP,FSVR8
	PUSHJ	SP,FSVR9

FSVR8:	PUSHJ	SP,FSVRC0	; INDIRECT F[0] CODE
	CILR
	POPJ	SP,0

FSVR9:	PUSH	SP,A0		; INDIRECT F[1] CODE
	PUSH	SP,A1
	CLRI
	PUSHJ	SP,FSVRC2
	POP	SP,A1
	POP	SP,A0
	POPJ	SP,0
; R -> I, BY NAME

FSVR10:	PUSHJ	SP,FSVR11
	PUSHJ	SP,FSVR12

FSVR11:	PUSHJ	SP,FSVRC0	; INDIRECT F[0] CODE
	CRI
	POPJ	SP,0

FSVR12:	PUSH	SP,A0		; INDIRECT F[1] CODE
	CIR
	PUSHJ	SP,FSVRC1
	POP	SP,A0
	POPJ	SP,0

; R -> LR, BY NAME

FSVR13:	PUSHJ	SP,FSVR14
	PUSHJ	SP,FSVR15

FSVR14:	PUSHJ	SP,FSVRC0	; INDIRECT F[0] CODE
	MOVEI	A1,0
	POPJ	SP,0

FSVR15:	PUSH	SP,A0		; INDIRECT F[1] CODE
	PUSH	SP,A1
	CLRR
	PUSHJ	SP,FSVRC2
	POP	SP,A1
	POP	SP,A0
	POPJ	SP,0

; LR -> I, BY NAME

FSVR16:	PUSHJ	SP,FSVR17
	PUSHJ	SP,FSVR18

FSVR17:	PUSHJ	SP,FSVRC0	; INDIRECT F[0] CODE
	CLRI
	POPJ	SP,0

FSVR18:	PUSH	SP,A0		; INDIRECT F[1] CODE
	CILR
	PUSHJ	SP,FSVRC1
	POP	SP,A0
	POPJ	SP,0
; LR -> R, BY NAME

FSVR19:	PUSHJ	SP,FSVR20
	PUSHJ	SP,FSVR21

FSVR20:	PUSHJ	SP,FSVRC0	; INDIRECT F[0] CODE
	CLRR
	POPJ	SP,0

FSVR21:	PUSH	SP,0		; INDIRECT F[1] CODE
	MOVEI	A1,0
	PUSHJ	SP,FSVRC1
	POP	SP,A0
	POPJ	SP,0
SUBTTL PARAM - STATIC EXPRESSION HANDLER

; LH ENTRY: BY VALUE
; RH ENTRY: BY NAME

SEXPD:	XWD	SEXP21,SEXP1	; I -> I
	XWD	SEXP22,SEXP5	; I -> R
	XWD	SEXP23,SEXP6	; I -> LR
	XWD	SEXP24,SEXP13	; R -> I
	XWD	SEXP30,SEXP14	; R -> R
	XWD	SEXP25,SEXP15	; R -> LR
	XWD	SEXP26,SEXP16	; LR -> I
	XWD	SEXP27,SEXP17	; LR -> R
	XWD	SEXP29,SEXP18	; LR -> LR
	XWD	0,0		; C -> C
	XWD	0,0		; C -> LC
	XWD	0,0		; LC -> C
	XWD	0,0		; LC -> LC
	XWD	SEXP21,SEXP1	; B -> B
	XWD	SEXP28,SEXP18	; S -> S
	XWD	0,0		; L -> L
	XWD	0,0		; N -> N

SEXP:	XWD	0,SEXP0		; VARIABLE
	XWD	0,PAR3		; EXPRESSION
	XWD	0,PAR3		; ARRAY
	XWD	0,PAR3		; PROCEDURE

SEXP0:	SKIPN	A6,SEXPD(A7)	; LOAD UP DISPATCH ENTRY
	JRST	PAR3		; ILLEGAL
	TLNE	A4,$VAL		; FORMAL BY VALUE?
	MOVS	A6,A6		; YES - SWAP HALVES
	TRNE	A5,<$REG>B41	; REGULAR?
	JRST	(A6)		; YES - DISPATCH TO REGULAR ADDRESS
	JRST	1(A6)		; NO - DISPATCH TO SIMPLE ADDRESS
; I -> I, B -> B, BY NAME

SEXP1:	SKIPA	A1,(A2)		; REGULAR
	HRRZI	A1,(A2)		; SIMPLE
	MOVE	A0,A1

SEXP2:	MOVEM	A0,2(A4)	; PLANT VALUE IN F[2]
	LRLOAD	A5,SEXP3	; PLANT INDIRECT CODE IN F[0]
	LRSTOR	A5,(A4)		; PLANT DIRECT CODE IN F[1]
	AOJA	A3,PAR6

SEXP3:	PUSHJ	SP,SEXP4
	SYSER1	11,0

SEXP4:	HRRZ	A2,(SP)		; F[0] CODE
	MOVE	A0,-1(A2)
	TLNE	A0,$A		; ADDRESS REQUIRED?
	SYSER1	11,0		; YES - YOU LOSE
	MOVEI	A2,@A0
	MOVE	A0,2(A2)	; VALUE
	POPJ	SP,0

; I -> R, BY NAME

SEXP5:	SKIPA	A1,(A2)		; REGULAR
	HRRZI	A1,(A2)		; SIMPLE
	MOVE	A0,A1
	CIR
	JRST	SEXP2
; I -> LR, BY NAME

SEXP6:	JRST	SEXP10		; REGULAR
	HRRZI	A0,(A2)		; SIMPLE
	FSC	A0,233

SEXP7:	MOVEM	A0,2(A4)	; PLANT VALUE IN F[2]
	LRLOAD	A5,SEXP8	; PLANT INDIRECT CODE IN F[0]
	LRSTOR	A5,(A4)		; PLANT DIRECT CODE IN F[1]
	AOJA	A3,PAR6

SEXP8:	PUSHJ	SP,SEXP9
	SYSER1	11,0

SEXP9:	HRRZ	A2,(SP)		; F[0] CODE
	MOVE	A0,-1(A2)
	TLNE	A0,$A		; ADDRESS REQUIRED?
	SYSER1	11,0		; YES - YOU LOSE
	MOVEI	A2,@A0
	MOVE	A0,2(A2)	; VALUE
	MOVEI	A1,0
	POPJ	SP,0

SEXP10:	MOVE	A0,(A2)		; REGULAR CASE
	CILR
	JUMPE	A1,SEXP7	; EASY CASE IF NO LOW WORD
	MOVEM	A2,2(A4)	; PLANT ADDRESS IN F[2]
	LRLOAD	A5,SEXP11	; PLANT INDIRECT CODE IN F[0]
	LRSTOR	A5,(A4)		; PLANT DIRECT CODE IN F[1]

SEXP11:	PUSHJ	SP,SEXP12
	SYSER1	11,0

SEXP12:	HRRZ	A2,(SP)		; F[0] CODE
	MOVE	A0,-1(SP)
	TLNE	A0,$A		; ADDRESS REQUIRED?
	SYSER1	11,0		; YES - YOU LOSE
	MOVEI	A2,@A0
	MOVE	A0,@2(A2)	; VALUE
	CILR
	POPJ	SP,0
; R -> I, BY NAME

SEXP13:	SKIPA	A1,(A2)		; REGULAR
	MOVSI	A1,(A2)		; SIMPLE
	MOVE	A0,A1
	CRI
	JRST	SEXP2

; R -> R, BY NAME

SEXP14:	SKIPA	A1,(A2)		; REGULAR
	MOVSI	A1,(A2)		; SIMPLE
	MOVE	A0,A1
	JRST	SEXP2

; R -> LR, BY NAME

SEXP15:	SKIPA	A1,(A2)		; REGULAR
	MOVSI	A1,(A2)		; SIMPLE
	MOVE	A0,A1
	JRST	SEXP7

; LR -> I, BY NAME

SEXP16:	LRLOAD	A0,(A2)
	CLRI
	JRST	SEXP2

; LR -> R, BY NAME

SEXP17:	LRLOAD	A0,(A2)
	CLRR
	JRST	SEXP2
; LR -> LR, S -> S, BY NAME

SEXP18:	MOVEM	A2,2(A4)	; PLANT ADDRESS IN F[2]
	LRLOAD	A5,SEXP19	; PLANT INDIRECT CODE IN F[0]
	LRSTOR	A5,(A4)		; PLANT DIRECT CODE IN F[1]
	AOJA	A3,PAR6

SEXP19:	PUSHJ	SP,SEXP20
	SYSER1	11,0

SEXP20:	HRRZ	A2,(SP)		; F[0] CODE
	MOVE	A0,-1(A2)
	TLNE	A0,$A		; ADDRESS REQUIRED?
	SYSER1	11,0		; YES - YOU LOSE
	MOVEI	A2,@A0
	HRRZ	A2,2(A2)
	LRLOAD	A0,(A2)		; VALUE
	POPJ	SP,0
; I -> I, B -> B, BY VALUE

SEXP21:	SKIPA	A1,(A2)		; REGULAR
	HRRZI	A1,(A2)		; SIMPLE
	MOVEM	A1,(A4)		; PLANT VALUE IN F[0]
	AOJA	A3,PAR6

; I -> R, BY VALUE

SEXP22:	SKIPA	A1,(A2)		; REGULAR
	HRRZI	A1,(A2)		; SIMPLE
	MOVE	A0,A1
	CIR
	MOVEM	A0,(A4)		; PLANT VALUE IN F[0]
	AOJA	A3,PAR6

; I -> LR, BY VALUE

SEXP23:	SKIPA	A1,(A2)		; REGULAR
	HRRZI	A1,(A2)		; SIMPLE
	MOVE	A0,A1
	CILR
	LRSTOR	A0,(A4)		; PLANT VALUE IN F[0],F[1]
	AOJA	A3,PAR6

; R -> I, BY VALUE

SEXP24:	SKIPA	A1,(A2)		; REGULAR
	MOVSI	A1,(A2)		; SIMPLE
	MOVE	A0,A1
	CRI
	MOVEM	A0,(A4)		; PLANT VALUE IN F[0]
	AOJA	A3,PAR6

; R -> R, BY VALUE

SEXP30:	SKIPA	A1,(A2)		; REGULAR
	MOVSI	A1,(A2)		; SIMPLE
	MOVEM	A1,(A4)		; PLANT VALUE IN F[0]
	AOJA	A3,PAR6

; R -> LR, BY VALUE

SEXP25:	SKIPA	A1,(A2)		; REGULAR
	MOVSI	A1,(A2)		; SIMPLE
	MOVEM	A1,(A4)
	SETZM	1(A4)		; PLANT VALUE IN F[0],F[1]
	AOJA	A3,PAR6
SUBTTL PARAM - STATIC ARRAY HANDLER

; LH ENTRY: BY VALUE
; RH ENTRY: BY NAME

SARRD:	XWD	SARR3,SARR2	; I -> I
	XWD	SARR3,0		; I -> R
	XWD	SARR3,0		; I -> LR
	XWD	SARR3,0		; R -> I
	XWD	SARR3,SARR2	; R -> R
	XWD	SARR3,0		; R -> LR
	XWD	SARR3,0		; LR -> I
	XWD	SARR3,0		; LR -> R
	XWD	SARR3,SARR2	; LR -> LR
	XWD	0,0		; C -> C
	XWD	0,0		; C -> LC
	XWD	0,0		; LC -> C
	XWD	0,0		; LC -> LC
	XWD	SARR3,SARR2	; B -> B
EDIT(701); String arrays by value dont work, so dont let users try
	XWD	SARR4,SARR2	; S -> S
	XWD	0,0		; L -> L
	XWD	0,0		; N -> N

SARR:	XWD	0,PAR3		; VARIABLE
	XWD	0,PAR3		; EXPRESSION
	XWD	0,SARR0		; ARRAY
	XWD	0,PAR3		; PROCEDURE

SARR0:	CAIN	A5,<$OWN>B41	; FIXED VARIABLE?
	JRST	SARR1		; YES
	HLRZ	A6,@A3
	ANDI	A6,$P		; GET VARIABLE LEVEL (P ADDRESS)
	ADD	A6,CONDL(DL)	; ADDRESS OF DISPLAY ENTRY
	ADDI	A6,(DB)
	ADD	A2,(A6)		; ADD TO Q ADDRESS

SARR1:	HRRZ	A6,SARRD(A7)	; LOAD UP NAME DISPATCH ENTRY
	TLNE	A4,$VAL		; FORMAL BY VALUE
	HLRZ	A6,SARRD(A7)	; YES - LOAD UP VALUE DISPATCH ENTRY
	JUMPN	A6,(A6)		; DISPATCH UNLESS
	JRST	PAR3		; ILLEGAL
; ALL VALID COMBINATIONS, BY VALUE

EDIT(713) ; MAKE STRINS BY VALUE AS WELL IN STRING ARRAYS
SARR3:	TDZA	AX,AX		; [E713] EVERYTHING EXCEPT STRING ARRAYS
SARR4:	MOVEI	AX,1		; [E713] STRING ARRAYS - MORE DIFFICULT
	MOVEI	A1,@A2
	PUSH	SP,A3
	PUSH	SP,A13
	PUSH	SP,AX		; [E713] SAVE ARRAY TYPE FLAG
	PUSH	SP,A2		; SAVE VALUABLE ACCS. AND HEADER ADDRESS
	MOVE	A1,1(A1)	; GET SECOND WORD OF HEADER

SARR5:	PUSH	SP,(A1)		; AND COPY DOPE VECTOR TO THE STACK
	PUSH	SP,1(A1)
	ADDI	A1,1
	AOBJN	A1,SARR5
	HLRZ	A1,A4		; GET FP TYPE
	ANDCMI	A1,$STAT	; AND CLEAR STATUS BITS TO FOOL
				; $OWN TEST IN ARRAY
	MOVNI	A3,1		; ONE ARRAY
	EXCH	A2,A4		; ADDRESS OF NEW HEADER
	MOVEI	A4,@A4
	HLRE	A4,1(A4)	; -NUMBER OF DIMENSIONS
	JSP	AX,ARRAY	; LAY OUT NEW ARRAY
	POP	SP,A1		; RESTORE ADDRESS OF OLD HEADER
	MOVEI	A1,@A1		; AND MAKE IT ABSOLUTE
	SUBI	A2,2		; RETARD NEW ARRAY WORD POINTER
	PUSH	SP,A2		; [E713] KEEP HEADER ADDRESS
	PUSHJ	SP,CPYARR	; AND COPY OLD TO NEW
	POP	SP,A2		; [E713] GET HEADER ADDRESS AGAIN
	POP	SP,AX		; [E713] POP OFF POINTER LEFT BY ARRAY
	EXCH	AX,(SP)		; [E713] SWAP WITH ARRAY TYPE FLAG
	JUMPE	AX,SARR7	; [E713] CARRY ON IF NOT STRING ARRAY
	HRRZ	A1,1(A2)	; [E713] GET ADDRESS OF DOPE VECTOR
	HRRZ	A2,-2(A1)	; [E713] GET SIZE OF ILIFFE VECTOR(S)
	ADD	A2,-1(A1)	; [E713] PICK UP POINTER OVER DATA
SARR6:	PUSH	SP,STR1(A2)	; [E713] PUSH STRING HEADER
	PUSH	SP,STR2(A2)	; [E713] ONTO THE STACK
	JSP	AX,STRAS0	; [E713] FORM A COPY OF IT
	LRSTOR	A0,(A2)		; [E713] AND WRITE NEW HEADER
	ADDI	A2,1		; [E713] STEP ON TO NEXT STRING
	AOBJN	A2,SARR6	; [E713] AND REPEAT FOR ENTIRE ARRAY
SARR7:	POP	SP,A1		; SAVE THE POINTER THAT ARRAY CREATED
	POP	SP,A13
	POP	SP,A3		; RESTORE VALUABLE ACCS.
	JSP	AX,ARR16A	; [E713] ADJUST BLKPTR PROPERLY
	AOJA	A3,PAR6
SUBTTL PARAM - STATIC PROCEDURE HANDLER

SPRO:	XWD	0,SPRO0		; VARIABLE
	XWD	0,PAR3		; EXPRESSION
	XWD	0,PAR3		; ARRAY
	XWD	0,SPRO0		; PROCEDURE

EDIT(707);MAKE FORMAL SWITCHES WORK PROPERLY
SPRO0:	CAIN	A7,17		; [E707] IS THIS A SWITCH ?
	JRST	SLAB0		; [E707] YES - HANDLE IT
	CAIE	A5,<$FON>B41	; IS THE ACTUAL A FORMAL?
	JRST	SPRO1		; NO
	HLRZ	A6,@A3
	ANDI	A6,$P		; GET PROCEDURE LEVEL (P ADDRESS)
	HRRZ	A5,CONDL(DL)	; GET TRUE CONTEXT DL
	ADDI	A6,(A5)		; ADDRESS OF DISPLAY ENTRY
	ADDI	A6,(DB)
	ADD	A2,(A6)		; YES - ADD DISPLAY ELEMENT TO Q ADDRESS
	HRLI	A2,<XCT	(DB)>B53
				; AND PREPARE OPERATIONAL ORDER
	JRST	SPRO2

SPRO1:	HRLI	A2,<PUSHJ	SP,0>B53
				; IF NOT FORMAL, THIS IS THE ORDER

SPRO2:	JUMPE	A11,SPRO6	; FORMAL PARAMETER A VARIABLE?
	MOVEM	A2,1(A4)	; NO - PLANT OPERATION IN F[1]
	MOVE	A5,[
	PUSHJ	SP,SPRO3]
	MOVEM	A5,(A4)		; PLANT ENTRY IN F[0]
	MOVE	A5,CONDL(DL)
	MOVEM	A5,2(A4)	; AND CONDL IN F[2]
	AOJA	A3,PAR6
SPRO3:	HRRZ	A1,(SP)		; F[0] CODE: GET LINK
	MOVEI	A2,@-1(A1)	; GET ADDRESS OF F[0]
	HRRZ	A0,(A1)		; GET LENGTH OF AP LIST
	MOVE	A3,A1
	ADD	A3,A0		; ADVANCE LINK OVER AP'S
	CAILE	A3,(DB)
	CAILE	A3,(SP)		; IF THE LINK IS ABSOLUTE
	JRST	SPRO13		; THEN LEAVE IT ALONE
	SUBI	A3,(DB)		; OTHERWISE DELOCATE IT
	HRLI	A3,DB		; AND PUT DB BITS IN LH

SPRO13:	MOVEM	A3,(SP)		; PUT BACK LINK
	MOVE	A3,DL
	DPUSH	A3		; SAVE CURRENT DL
	HRL	DL,2(A2)	; NOTE ENVIRONMENT DL
	PUSH	SP,[0]		; MARK STACK
	PUSH	SP,1(A2)	; STACK OPERATIONAL ORDER
	MOVEI	A3,(SP)		; AND MARK IT'S POSITION

SPRO4:	PUSH	SP,(A1)		; COPY AP LIST TO STACK
	ADDI	A1,1
	SOJG	A0,SPRO4
	PUSH	SP,[
	JRST	SPRO5]		; STACK RETURN JUMP
	JRST	(A3)		; ENTER CALL SEQUENCE INTERLUDE

SPRO5:	POP	SP,A2		; UNSTACK UNWANTED DATA
	JUMPN	A2,SPRO5
	RPOP	DL		; RESTORE CURRENT DL
	POP	SP,AX
	JRST	@AX		; EXIT
; CASE OF A PARAMETERLESS PROCEDURE ASSIGNED TO A VARIABLE

SPRO6:	TLNE	A4,$VAL		; FORMAL BY VALUE?
	JRST	SPRO9		; YES
	MOVEM	A2,1(A4)	; PLANT OPERATIONAL ORDER IN F[1]
	HLLZ	A6,A4
	TLZ	A6,$KIND!$STAT
	TLO	A6,$PRO!$SIM	; CONSTRUCT MATCHED TYPE DESCRIPTOR
	HRR	A6,CONDL(DL)	; AND CONDL
	MOVEM	A6,2(A4)	; PLANT IN F[2]
	MOVE	A5,[
	PUSHJ	SP,SPRO7]
	MOVEM	A5,(A4)		; PLANT ENTRY IN F[0]
	AOJA	A3,PAR6

SPRO7:	HRRZ	A2,(SP)		; F[0] CODE: GET LINK
	MOVE	A0,-1(A2)	; GET CALLING ORDER
	TLNE	A0,$A		; ADDRESS REQUIRED?
	SYSER1	11,0		; YES - YOU LOSE
	CAILE	A2,(DB)
	CAILE	A2,(SP)		; IF THE LINK IS ABSOLUTE
	JRST	SPRO14		; THEN LEAVE IT ALONE
	SUBI	A2,(DB)		; OTHERWISE DELOCATE IT
	HRLI	A2,DB		; AND PUT THE DB BITS IN THE LH
	MOVEM	A2,(SP)

SPRO14:	MOVEI	A2,@A0		; GET ADDRESS OF F[0]
	MOVE	A3,DL
	DPUSH	A3		; SAVE CURRENT DL
	PUSH	SP,1(A2)	; STACK OPERATIONAL ORDER
	MOVE	A0,2(A2)	; GET F[2]
	HRL	DL,A0		; SET UP CORRECT DL
	HRRI	A0,1		; SET UP FOR NO ACTUALS
	PUSH	SP,A0		; AND STACK TYPE DESCRIPTOR
	PUSH	SP,[
	JRST	SPRO8]		; STACK RETURN JUMP
	JRST	-2(SP)		; AND ENTER CALL SEQUENCE INTERLUDE

SPRO8:	SUB	SP,[
	XWD	3,3]		; GET RID OF UNWANTED STACK
	RPOP	DL		; RESTORE CURRENT DL
	POP	SP,AX
	JRST	@AX		; AND EXIT
SPRO9:	PUSH	SP,A3
	DPUSH	A4
	PUSH	SP,A13		; SAVE VALUABLE ACCUMULATORS
	MOVE	A0,DL
	DPUSH	A0		; SAVE CURRENT DL
	HRRZ	DL,CONDL(DL)
	ADDI	DL,(DB)		; AND ASSUME THAT OF CONTEXT
	PUSH	SP,A2		; STACK OPERATIONAL ORDER
	TLZ	A4,$KIND!$STAT
	TLO	A4,$PRO!$SIM
	HRRI	A4,1		; MAKE TYPE DESCRIPTOR
	PUSH	SP,A4		; FROM FORMAL - AND STACK IT
	PUSH	SP,[
	JRST	SPRO10]		; STACK RETURN JUMP
	JRST	-2(SP)		; AND ENTER CALL SEQUENCE INTERLUDE

SPRO10:	SUB	SP,[
	XWD	3,3]		; GET RID OF UNWANTED STACK
	RPOP	DL		; RESTORE CURRENT DL
	POP	SP,A13
	RPOP	A4
	POP	SP,A3		; RESTORE VALUABLE ACCUMULATORS
	LRSTOR	A0,(A4)		; PLANT RESULT IN FORMAL
	AOJA	A3,PAR6
; CASE OF A SWITCH (LABEL PROCEDURE)

SLAB0:	JUMPE	A11,PAR3	; [E707] CAN'T ASSIGN SWITCH TO LABEL
	CAIE	A5,<$FON>B41	; [E707] IS THE ACTUAL A FORMAL ?
	JRST	SLAB1		; [E707] NO  - A2 CONTAINS ADDRESS OF CODE
	HLRZ	A1,@A3		; [E707] YES - GET L.H. OF LEXEME
	ANDI	A1,$P		; [E707] MASK TO P ADDRESS
	ADD	A1,CONDL(DL)	; [E707] GET ADRESS OF DISPLAY
	ADDI	A1,(DB)		; [E707] ENTRY FOR CONTEXT
	ADD	A2,(A1)		; [E707] GET Q ADDRESS
	SKIPA	A5,FLAB01	; [E707] LOAD A5 WITH "PUSHJ SP,FLABF0"
SLAB1:	MOVE	A5,[
	PUSHJ	SP,SWITCH]	; [E707] NON-FORMAL SWITCH - GET F[0] CODE
	MOVEM	A5,(A4)		; [E707] STORE INSTRUCTION IN F[0]
	HRL	A2,CONDL(DL)	; [E707] SET CONTEXT DL IN L.H. OF ADDRESS
	MOVEM	A2,2(A4)	; [E707] AND STORE IT INTO F[2]
	AOJA	A3,PAR6		; [E707] GO DEAL WITH NEXT PARAMETER

;	L -> L, SW -> SW WHEN ACTUALS ARE FORMALS

FLABL%:	; ENTRY POINT DEFINED FOR ALGDDT
FLAB01:	PUSHJ	SP,FLABF0	; [E707] F[0] CODE
	SYSER1	11,0		; [E707] F[1] CODE

FLABF0:	MOVE	A1,0(SP)	; [E707] DIRECT ENTRY ON F[0]
	SKIPA	A1,-1(A1)	; [E707] GET XCT ORDER
	MOVE	A1,@A1		; [E707] FOLLOW XCT CHAIN
	HLRZ	A0,@A1		; [E707] GET TARGET INSTRUCTION
	ANDI	A0,777000	; [E707] MASK TO OPCODE ONLY
	CAIN	A0,(XCT 0,0)	; [E707] IS THIS ANOTHER XCT ?
	JRST	.-4		; [E707] YES - REPEAT THIS STEP
	MOVEI	AX,@A1		; [E707] NO  - GET FORMAL ADDRESS
	MOVE	AX,2(AX)	; [E707] GET CONTEXT DL AND ADDRESS
	DPUSH	DL		; [E707] SAVE CURRENT DL
	HLRZ	DL,AX		; [E707] AND ASSUME FORMAL'S DL
	ADDI	DL,(DB)		; [E707] RELOCATE DL
	ADDI	AX,(DB)		; [E707] AND FORMAL ADDRESS
	XCT	(AX)		; [E707] GET VALUE OF FORMAL
	RPOP	DL		; [E707] RESTORE CURRENT DL
	POPJ	SP,0		; [E707] AND RETURN

;	ROUTINE TO EVALUATE A SWITCH PASSED AS A PARAMETER

SWITCH:	MOVE	A1,0(SP)	; [E707] DIRECT ENTRY ON F[0]
	MOVE	A1,-1(A1)	; [E707] GET XCT INSTRUCTION
	MOVEI	AX,@A1		; [E707] GET ADDRESS OF FORMAL
	MOVE	A1,AX		; [E707] AND SAVE THE ADDRESS
	DPUSH	A1		; [E707] TO SET UP F[1]
	DPUSH	DL		; [E707] SAVE CURRENT DL
	MOVE	AX,2(AX)	; [E707] GET CONTENTS OF F[2]
	HLRZ	DL,AX		; [E707] GET CONTEXT DL
	ADDI	DL,(DB)		; [E707] RELOCATE IT
	PUSHJ	SP,(AX)		; [E707] EVALUATE THE SWITCH
	RPOP	DL		; [E707] RESTORE CURRENT DL
	RPOP	AX		; [E707] AND ADDRESS OF FORMAL
	MOVEM	A2,1(AX)	; [E707] STORE VALUE IN F[1]
	TRNE	A2,-1		; [E707] IF OUT OF RANGE
	TLNE	A2,-1		; [E707] OR ALREADY A FORMAL
	POPJ	SP,		; [E707] JUST RETURN
	SUBI	AX,(DB)		; [E707] OTHERWISE GET F[0] ADDRESS
	HRLZI	A2,(AX)		; [E707] IN LEFT HALF OF A2
	HRRI	A2,FORLAB	; [E707] AND FORLAB IN RIGHT HALF
	POPJ	SP,		; [E707] AND RETURN
SUBTTL PARAM - DYNAMIC VARIABLE HANDLER

; LH ENTRY: BY VALUE
; RH ENTRY: BY NAME

DVARD:	XWD	DVAR25,DVAR1	; I -> I
	XWD	DVAR26,DVAR3	; I -> R
	XWD	DVAR27,DVAR6	; I -> LR
	XWD	DVAR29,DVAR9	; R -> I
	XWD	DVAR25,DVAR1	; R -> R
	XWD	DVAR30,DVAR12	; R -> LR
	XWD	DVAR31,DVAR15	; LR -> I
	XWD	DVAR32,DVAR18	; LR -> R
	XWD	DVAR28,DVAR21	; LR -> LR
	XWD	0,0		; C -> C
	XWD	0,0		; C -> LC
	XWD	0,0		; LC -> C
	XWD	0,0		; LC -> LC
	XWD	DVAR25,DVAR1	; B -> B
	XWD	SVAR40,DVAR44	; S -> S
	XWD	0,0		; L -> L
	XWD	0,0		; N -> N

DVAR:	XWD	0,DVAR0		; VARIABLE
	XWD	0,PAR3		; EXPRESSION
	XWD	0,PAR3		; ARRAY
	XWD	0,PAR3		; PROCEDURE

DVAR0:	SKIPN	A6,DVARD(A7)	; LOAD UP DISPATCH ENTRY
	JRST	PAR3		; ILLEGAL

DVAR33:	TLNE	A4,$VAL		; FORMAL BY VALUE?
	JRST	DVAR24		; YES
	HRL	A2,CONDL(DL)	; ADD CONTEXT DL TO THUNK ADDRESS
	JRST	FSVR22
; ROUTINE FOR EVALUATING DYNAMIC VARIABLE THUNKS

DVARC:	MOVE	A1,-1(SP)
	PUSH	SP,-1(A1)	; SAVE XCT(A) ORDER
	MOVEI	A1,@(SP)
	MOVE	A1,2(A1)	; GET THUNK'S DL AND ADDRESS
	DPUSH	DL		; SAVE CURRENT DL
	HLRZ	DL,A1		; AND ASSUME THUNK'S
	ADDI	DL,(DB)
	PUSHJ	SP,(A1)		; EVALUATE THUNK
	RPOP	DL		; RESTORE CURRENT DL
	POP	SP,A1		; RESTORE XCT(A) ORDER
	TLNE	A1,$A		; XCTA?
	POP	SP,A1		; YES - LOSE F[0]'S LINK
	POPJ	SP,0
; I -> I, R -> R, B-> B, BY NAME

DVAR1:	PUSHJ	SP,DVAR2
	MOVEM	A0,(A2)		; DIRECT F[1] CODE

DVAR2:	PUSHJ	SP,DVARC	; INDIRECT F[0] CODE
	MOVE	A0,(A2)
	POPJ	SP,0

; I -> R, BY NAME

DVAR3:	PUSHJ	SP,DVAR4
	PUSHJ	SP,DVAR5

DVAR4:	PUSHJ	SP,DVARC	; F[0] CODE
	MOVE	A0,(A2)
	CIR
	POPJ	SP,0

; I -> LR, BY NAME

DVAR6:	PUSHJ	SP,DVAR7
	PUSHJ	SP,DVAR8

DVAR7:	PUSHJ	SP,DVARC	; F[0] CODE
	MOVE	A0,(A2)
	CILR
	POPJ	SP,0

; R -> I, BY NAME

DVAR9:	PUSHJ	SP,DVAR10
	PUSHJ	SP,DVAR11

DVAR10:	PUSHJ	SP,DVARC	; F[0] CODE
	MOVE	A0,(A2)
	CRI
	POPJ	SP,0

; R -> LR, BY NAME

DVAR12:	PUSHJ	SP,DVAR13
	PUSHJ	SP,DVAR14

DVAR13:	PUSHJ	SP,DVARC	; F[0] CODE
	MOVE	A0,(A2)
	MOVEI	A1,0
	POPJ	SP,0

; LR -> I, BY NAME

DVAR15:	PUSHJ	SP,DVAR16
	PUSHJ	SP,DVAR17

DVAR16:	PUSHJ	SP,DVARC	; F[0] CODE
	LRLOAD	A0,(A2)
	CLRI
	POPJ	SP,0

; LR -> R, BY NAME

DVAR18:	PUSHJ	SP,DVAR19
	PUSHJ	SP,DVAR20

DVAR19:	PUSHJ	SP,DVARC	; F[0] CODE
	LRLOAD	A0,(A2)
	CLRR
	POPJ	SP,0

; LR -> LR, BY NAME

DVAR21:	PUSHJ	SP,DVAR22
	PUSHJ	SP,DVAR23

DVAR22:	PUSHJ	SP,DVARC	; F[0] CODE
	MOVEI	A1,@A2
	LRLOAD	A0,(A1)
	POPJ	SP,0

;S-> S, BY NAME

DVAR44:	PUSHJ	SP,DVAR22
	PUSHJ	SP,SVAR44
; FORMAL BY VALUE

EDIT(617) ; STOP EDIT 547 CLOBBERING BYTE POINTERS
DVAR24:	HLRZ	A6,A6		; [E617] TAKE LEFT HALF DISPATCH ENTRY
	PUSH	SP,A6		; AND SAVE IT
	PUSH	SP,A3
	DPUSH	A4
	PUSH	SP,A13		; SAVE VALUABLE ACCUMULATORS
	MOVE	A5,DL
	DPUSH	A5		; SAVE CONTEXT DL
	HRRZ	DL,CONDL(DL)
	ADDI	DL,(DB)		; AND USE CONTEXT DL
	PUSHJ	SP,(A2)		; EVALUATE THUNK
	RPOP	DL		; RESTORE DL
	POP	SP,A13
	RPOP	A4
	POP	SP,A3		; RESTORE VALUABLE ACCUMULATORS
	POP	SP,A6		; AND DISPATCH ADDRESS
EDIT (547) ; PREVENT MOVEI 2,@2 PRODUCING SILLY INDEXING FOR ARRAYS -
	; THIS HAPPENED FOR ARRAYS WITH LARGE LOW-BOUNDS, AND HENCE
	; NEGATIVE ORIGINS. A2 IS ALWAYS AN ABSOLUTE POINTER HERE.
	CAIGE	A6,BVAR10	; [E611] BUT IT MIGHT BE A BYTE POINTER
	TLZ	A2,-1		; [E547] CLEAR LEFT HALF OF POINTER.
	JRST	(A6)		; DISPATCH

; LR -> R, BY VALUE

DVAR32:	LRLOAD	A0,(A2)

DEXP24:	CLRR
	MOVEM	A0,(A4)		; PLANT VALUE IN F[0]
	AOJA	A3,PAR6
SUBTTL PARAM - DYNAMIC EXPRESSION HANDLER

; LH ENTRY: BY VALUE
; RH ENTRY: BY NAME

DEXPD:	XWD	DEXP18,DEXP1	; I -> I
	XWD	DEXP19,DEXP2	; I -> R
	XWD	DEXP20,DEXP4	; I -> LR
	XWD	DEXP21,DEXP6	; R -> I
	XWD	DEXP18,DEXP1	; R -> R
	XWD	DEXP22,DEXP8	; R -> LR
	XWD	DEXP23,DEXP10	; LR -> I
	XWD	DEXP24,DEXP12	; LR -> R
	XWD	DEXP25,DEXP1	; LR -> LR
	XWD	0,0		; C -> C
	XWD	0,0		; C -> LC
	XWD	0,0		; LC -> C
	XWD	0,0		; LC -> LC
	XWD	DEXP18,DEXP1	; B -> B
	XWD	DEXP26,DEXP27	; S -> S
	XWD	DEXP17,DEXP15	; L -> L
	XWD	0,0		; N -> N

DEXP:	XWD	0,DEXP0		; VARIABLE
	XWD	0,PAR3		; EXPRESSION
	XWD	0,PAR3		; ARRAY
	XWD	0,PAR3		; PROCEDURE

DEXP0:	SKIPN	A6,DEXPD(A7)	; LOAD UP DISPATCH ENTRY
	JRST	PAR3		; ILLEGAL
	TLNE	A4,$VAL		; FORMAL BY VALUE?
	JRST	DEXP14		; YES
	HRL	A2,CONDL(DL)	; ADD CONTEXT DL TO THUNK ADDRESS
	MOVEM	A2,2(A4)	; AND PLANT IN F[2]
	MOVE	A5,[
	SYSER1	11,0]
	MOVEM	A5,1(A4)	; PLANT F[1] CODE
	MOVE	A5,(A6)
	MOVEM	A5,(A4)		; PLANT F[0] CODE
	AOJA	A3,PAR6
; ROUTINE FOR EVALUATING DYNAMIC EXPRESSION THUNKS

DEXPDR:	SKIPA	A2,(SP)		; DIRECT ENTRY
DEXPC:	MOVE	A2,-1(SP)	; INDIRECT ENTRY
	MOVE	A0,-1(A2)	; GET XCT ORDER
	TLNE	A0,$A		; ADDRESS REQUIRED?
	SYSER1	11,0		; YES - YOU LOSE
	MOVEI	A2,@A0
	MOVE	A2,2(A2)	; GET CONTEXT DL AND THUNK ADDRESS
	DPUSH	DL		; SAVE CURRENT DL
	HLRZ	DL,A2		; AND ASSUME THUNK'S DL
	ADDI	DL,(DB)
	PUSHJ	SP,(A2)		; EVALUATE THUNK
	RPOP	DL		; RESTORE CURRENT DL
	POPJ	SP,0
; I -> I, R -> R, B -> B, LR -> LR, BY NAME

DEXP1:	PUSHJ	SP,DEXPDR	; DIRECT F[0] CODE

; I -> R, BY NAME

DEXP2:	PUSHJ	SP,DEXP3

DEXP3:	PUSHJ	SP,DEXPC	; F[0] CODE
	CIR
	POPJ	SP,0

; I -> LR, BY NAME

DEXP4:	PUSHJ	SP,DEXP5

DEXP5:	PUSHJ	SP,DEXPC	; F[0] CODE
	CILR
	POPJ	SP,0

; R -> I, BY NAME

DEXP6:	PUSHJ	SP,DEXP7

DEXP7:	PUSHJ	SP,DEXPC	; F[0] CODE
	CRI
	POPJ	SP,0

; R -> LR, BY NAME

DEXP8:	PUSHJ	SP,DEXP9

DEXP9:	PUSHJ	SP,DEXPC	; F[0] CODE
	MOVEI	A1,0
	POPJ	SP,0

; LR -> I, BY NAME

DEXP10:	PUSHJ	SP,DEXP11

DEXP11:	PUSHJ	SP,DEXPC	; F[0] CODE
	CLRI
	POPJ	SP,0
; LR -> R, BY NAME

DEXP12:	PUSHJ	SP,DEXP13

DEXP13:	PUSHJ	SP,DEXPC	; F[0] CODE
	CLRR
	POPJ	SP,0

; S -> S, BY NAME

DEXP27:	PUSHJ	SP,DEXP28

DEXP28:	PUSHJ	SP,DEXPC	; F[0] CODE
	MOVEI	A2,0
	POPJ	SP,0

; L -> L, BY NAME

DEXP15:	PUSHJ	SP,DEXP16

DEXP16:	HRRZ	A2,(SP)
	MOVEI	AX,@-1(A2)	; GET ADDRESS OF FORMAL
EDIT(707); SAVE ADDRESS OF F[0] IN CASE IT WAS 'XCT'-ED  BY AN "XCT (AX)"
	MOVEI	A2,(AX)		; [E707] GET PHYSICAL ADDRESS
	DPUSH	A2		; [E707] AND SAVE IT (DELOCATED)
	MOVE	AX,2(AX)	; GET THUNK'S DL AND ADDRESS
	DPUSH	DL		; SAVE CURRENT DL
	HLRZ	DL,AX		; ASSSUME DL FOR LABEL
	ADDI	DL,(DB)
	PUSHJ	SP,(AX)		; EXECUTE THUNK
	RPOP	DL		; RESTORE DL
	RPOP	AX		; [E707] RESTORE ADDRESS OF FORMAL
	MOVEM	A2,1(AX)	; AND STORE LABEL ADDRESS IN F[1]
	TRNE	A2,-1		; SWITCH OUT OF RANGE?
	TLNE	A2,-1		; NO - FORMAL?
	POPJ	SP,0		; NO
	SUBI	AX,(DB)
	HRLZI	A2,(AX)		; YES - GET ADDRESS OF F[0]
	HRRI	A2,FORLAB	; AND LET FORLAB DO THE WORK
	POPJ	SP,0		; IF REQUIRED
; BYTE VARIABLE (DYNAMIC SIMPLE VARIABLE STRING)

BVARD:	XWD	BVAR10,BVAR1	; BYTE -> I
	XWD	BVAR11,BVAR4	; BYTE -> R
	XWD	BVAR12,BVAR7	; BYTE -> LR

BVAR:	XWD	0,BVAR0		; VARIABLE
	XWD	0,PAR3		; EXPRESSION
	XWD	0,PAR3		; ARRAY
	XWD	0,PAR3		; PROCEDURE

BVAR0:	MOVE	A6,BVARD(A7)	; LOAD UP DISPATCH ENTRY
	JRST	DVAR33

; BYTE -> I, BY NAME

BVAR1:	PUSHJ	SP,BVAR2
	PUSHJ	SP,BVAR3

BVAR2:	PUSHJ	SP,DVARC	; F[0] CODE
	LDB	A0,A2
	POPJ	SP,0

BVAR3:	DPB	A0,A2		; F[1] CODE
	POPJ	SP,0
; BYTE -> R, BY NAME

BVAR4:	PUSHJ	SP,BVAR5
	PUSHJ	SP,BVAR6

BVAR5:	PUSHJ	SP,DVARC	; F[0] CODE
	LDB	A0,A2
	CIR
	POPJ	SP,0

BVAR6:	SCRI			; F[1] CODE
	DPB	A3,A2
	POPJ	SP,0

; BYTE -> LR, BY NAME

BVAR7:	PUSHJ	SP,BVAR8
	PUSHJ	SP,BVAR9

BVAR8:	PUSHJ	SP,DVARC	; F[0] CODE
	LDB	A0,A2
	CILR
	POPJ	SP,0

BVAR9:	SCLRI			; F[1] CODE
	DPB	A3,A2
	POPJ	SP,0

; BYTE -> I, BY VALUE

BVAR10:	LDB	A0,A2
	JRST	DEXP18

; BYTE -> R, BY VALUE

BVAR11:	LDB	A0,A2
	JRST	DEXP19

; BYTE -> LR, BY VALUE

BVAR12:	LDB	A0,A2
	JRST	DEXP20
; EXIT DESTINATION TABLE

EDIT(703);Do type conversion on procedure exit correctly
PAR8:	JSP	AX,FII		; [E703] I  <- I
	JSP	AX,FRI		; [E703] I  <- R
	JSP	AX,FLRI		; [E703] I  <- LR
	JSP	AX,FIR		; [E703] R  <- I
	JSP	AX,FRR		; [E703] R  <- R
	JSP	AX,FLRR		; [E703] R  <- LR
	JSP	AX,FILR		; [E703] LR <- I
	JSP	AX,FRLR		; [E703] LR <- R
	JSP	AX,FLRLR	; [E703] LR <- LR
	0			; [E703] C  <- C
	0			; [E703] C  <- LC
	0			; [E703] LC <- C
	0			; [E703] LC <- LC
	JSP	AX,FBB		; [E703] B  <- B
	JSP	AX,FSS		; [E703] S  <- S
	0			; [E703] L  <- L
	JSP	AX,FNN		; [E703] N  <- N

PAR9:	PUSHJ	SP,TRLMAN	; MAKE TRACE ENTRY [P37]
	HLRZ	AX,DL		; EXIT FROM PARAM
	MOVEI	DL,(DL)		; CLEAR LH OF DL
	JRST	(AX)
; EXIT SEQUENCES

FIR:	MOVEI	A13,IR
	JRST	FNN0

FILR:	MOVEI	A13,ILR
	JRST	FNN0

FRI:	MOVEI	A13,RI
	JRST	FNN0

FRLR:	JSP	A13,FNN0
	MOVEI	A1,0
	JRST	@AX

FLRI:	MOVEI	A13,LRI
	JRST	FNN0

FLRR:	MOVEI	A13,LRR
	JRST	FNN0

EDIT(710);RETURN VALUE CORRECTLY FROM STRING PROCEDURES
FSS:	JSP	A13,FNN0	; [E710] TIDY UP THE STACK
	TLO	A1,STRPRC	; [E710] MARK AS PROCEDURE RESULT
	SETZ	A2,		; [E710] POINT A2 TO HEADER
	JRST	@AX		; [E710] AND EXIT

FNN:	FII:	FRR:	FBB:
FLRLR:	MOVEI	A13,FX3

FNN0:	MOVEI	A0,0		; SET UP FOR GETOWN TO DELETE
	POP	SP,A1		; LOSE BLOCK POINTER
	SOS	%TRLV(DB)	; UPDATE TRACE DYNAMIC BLOCK-LEVEL [P37]
	SOS	%DDTPL(DB)	; AND PROCEDURE LEVEL

FX1:	POP	SP,A1		; UNSTACK
	JUMPL	A1,FX2		; BOTTOM BLOCK POINTER?
	TLZE	A1,(<Z 17,0>)	; [E713] IS THIS A STRING ARRAY ?
	PUSHJ	SP,DELSCN	; [E713] YES - DELETE SUB-STRINGS
	MOVEI	A1,@A1		; [E701] GET REAL ADDRESS, IF STRING
	JUMPE	A1,FX1		; [E701] DONT DELETE NULL STRING
	PUSHJ	SP,GETOWN	; NO - DELETE ITEM
	JRST	FX1
FX2:	MOVEI	SP,PRGLNK(DL)	; RESET STACK POINTER
	HRRZ	DL,CONDL(DL)	; GET CONTEXT DL
	ADDI	DL,(DB)		; AND RELOCATE IT
	MOVEI	A1,(SP)
	SUB	A1,.JBREL
	HRLI	SP,(A1)		; SET UP LH OF STACK POINTER
	LRLOAD	A0,(AX)		; GET RESULT
	POP	SP,AX		; GET LINK
	POP	SP,%DDTDL(DB)	; [E734] RESET DL CHAIN
	JRST	(A13)		; AND EXIT AS REQUIRED

FX3:	JRST	@AX
SUBTTL GOLAB - GENERAL GOTO LABEL ROUTINE

; CALLED FROM LABEL WITH LINK IN AX
; WORD FOLLOWING CALL IS FORMATTED AS FOLLOWS:

;	BITS 0 - 12:	LEVEL OF BLOCK CONTAINING LABEL
;			RELATIVE TO ENCLOSING PROCEDURE

;	BITS 13 - 17:	BITS FOR MODIFYING ADDRESS BY DL

;	BITS 18 - 35:	STATIC PROCEDURE LEVEL OF PROCEDURE
;			ENCLOSING LABEL

GOLAB:	HRRZ	A13,@(AX)	; GET DESTINATION DL
	ADDI	A13,(DB)	; AND RELOCATE IT

GOLAB0:	MOVEI	A0,0		; SET A0 FOR GETOWN TO DELETE

GOLAB1:	CAIN	A13,(DL)	; ARRIVED AT THE PROCEDURE LEVEL?
	JRST	GOLAB5		; YES
	HRRZ	A12,PLBLKL(DL)	; GET BLOCK LEVEL
	POP	SP,A1		; LOSE BLOCK POINTER

GOLAB2:	SOS	%TRLV(DB)	; ADJUST DYNAMIC BLOCK POINTER [P37]
	SOJL	A12,GOLAB4(A12)	; ANY MORE BLOCKS?

GOLAB3:	POP	SP,A1		; UNSTACK
	JUMPL	A1,GOLAB2	; BLOCK POINTER?
	TLZE	A1,(<Z 17,0>)	; [E713] IS THIS A STRING ARRAY ?
	PUSHJ	SP,DELSCN	; [E713] YES - DELETE SUB-STRINGS
	MOVEI	A1,@A1		; [E701] GET REAL ADDRESS, IF A STRING
	JUMPE	A1,GOLAB3	; [E701] DONT DELETE IF NULL
	PUSHJ	SP,GETOWN	; NO - DELETE ITEM
	JRST	GOLAB3

	SKIPA	DL,CONDL(DL)	; 2ND TIME: GET CONTEXT DL
GOLAB4:	JRST	GOLAB3		; 1ST TIME: FUDGE FOR VALUE ARRAYS
	SOS	%DDTPL(DB)	; ADJUST PROCEDURE LEVEL
	HRRM	DL,%DDTDL(DB)	; [E734] RESET DL CHAIN
	AOS	%TRLV(DB)	; AND FUDGE 'COS 1 TOO MANY SOS'S
	ADDI	DL,(DB)		; AND RELOCATE IT
	MOVE	SP,BLKPTR(DL)
	ADDI	SP,(DB)		; GET BLOCK POINTER
	JRST	GOLAB1

GOLAB5:	HLRZ	A13,(AX)
	LSH	A13,-5		; DESTINATION BLOCK LEVEL
	HRRZ	A12,PLBLKL(DL)	; CURRENT BLOCK LEVEL
	HRRM	A13,PLBLKL(DL)	; REPLACE BY LABEL BLOCK LEVEL
	SUBI	A12,(A13)	; FORM DIFFERENCE
	JUMPE	A12,1(AX)	; EXIT IF THERE
	POP	SP,A1		; LOSE BLOCK POINTER
GOLAB8:	SOS	%TRLV(DB)	; DECREMENT FOR EACH BLOCK

GOLAB6:	POP	SP,A1		; UNSTACK
	JUMPL	A1,GOLAB7	; BLOCK POINTER?
	TLZE	A1,(<Z 17,0>)	; [E713] IS THIS A STRING ARRAY ?
	PUSHJ	SP,DELSCN	; [E713] YES - DELETE SUB-STRINGS
	MOVEI	A1,@A1		; [E701] GET REAL ADDRESS, IF A STRING
	JUMPE	A1,GOLAB6	; [E701] DONT DELETE IF NULL
	PUSHJ	SP,GETOWN	; NO - DELETE ITEM
	JRST	GOLAB6

GOLAB7:	SOJG	A12,GOLAB8	; ANY MORE BLOCKS?
	PUSH	SP,A1		; AND ENTRY
	MOVE	A1,SP
	SUBI	A1,(DB)
	MOVEM	A1,BLKPTR(DL)	; RESET BLOCK POINTER
	JRST	1(AX)		; EXIT

; PRELUDE FOR GOING TO A FORMAL LABEL

FORLAB:	HLRZ	A2,A2		; GET ADDRESS OF FORMAL LABEL
	ADDI	A2,(DB)
	MOVE	A0,DL		; SAVE CURRENT DL
	HLRZ	DL,2(A2)	; GET LABEL'S DL
	ADDI	DL,(DB)		; AND RELOCATE IT
	MOVE	AX,1(A2)	; GET ADDRESS OF LABEL
	HRRZ	A13,@1(AX)	; GET DL OF DESTINATION
	ADDI	A13,(DB)	; AND RELOCATE IT
	MOVE	DL,A0		; RESTORE CURRENT DL
	AOJA	AX,GOLAB0	; AND SIMULATE JSP

EDIT(713) ; RETURN INDIVIDUAL STRING SPACE FOR STRING ARRAYS

DELSCN:	PUSH	SP,A1		; [E713] SAVE TOTAL HEAP SPACE ADDRESS
	MOVE	A3,(A1)		; [E713] GET -# OF ARRAYS,,ILIFFE VECTOR SIZE
	MOVE	A2,1(A1)	; [E713] AND -DATA AREA SIZE,,FIRST ADDRESS
	PUSH	SP,A2		; [E713] SAVE THESE ON THE STACK
DELSC1:	PUSH	SP,A3		; [E713] FOR LOOP CONTROL
	ADDI	A2,(A3)		; [E713] STEP OVER ILIFFE VECTOR(S), IF ANY
DELSC2:	MOVE	A1,STR2(A2)	; [E713] GET NUMBER OF BYTES IN THE STRING
	TDNE	A1,[77,,777777]	; [E713] IF BYTE COUNT IS ZERO
	SKIPN	A1,STR1(A2)	; [E713] OR THIS IS A REAL NULL STRING
	JRST	DELSC3		; [E713] THEN TRY THE NEXT ONE
	MOVEI	A1,(A1)		; [E713] OTHERWISE JUST GET ADDRESS
	PUSH	SP,A2		; [E713] SAVE HEADER ADDRESS
	PUSHJ	SP,GETOWN	; [E713] AND RETURN THE SPACE USED
	POP	SP,A2		; [E713] RESTORE HEADER ADDRESS
DELSC3:	ADDI	A2,1		; [E713] STEP TO NEXT HEADER, AND REPEAT
	AOBJN	A2,DELSC2	; [E713] FOR EACH STRING IN THE ARRAY
	POP	SP,A3		; [E713] THEN RESTORE COUNT OF ARRAYS
	AOBJP	A3,DELSC4	; [E713] WAS THAT THE LAST ARRAY ?
	HLL	A2,(SP)		; [E713] NO  - RESTORE COUNT OF STRINGS
	SOJA	A3,DELSC1	; [E713] AND REPEAT FOR THE NEXT ARRAY
DELSC4:	POP	SP,A2		; [E713] YES - LOSE SAVED POINTER
	POP	SP,A1		; [E713] RESTORE ADDRESS OF ARRAY SPACE
	POPJ	SP,		; [E713] AND RETURN TO DELETE THE ARRAY
SUBTTL BLKBEG/BLKEND - BLOCK ENTRY/EXIT

BLKBEG:	AOS	PLBLKL(DL)	; INCREMENT BLOCK LEVEL
	AOS	%TRLV(DB)	; AND DYNAMIC BLOCK POINTER [P37]
	PUSH	SP,BLKPTR(DL)	; MAKE NEW BLOCK POINTER
	MOVE	A0,SP
	SUBI	A0,(DB)
	MOVEM	A0,BLKPTR(DL)	; AND RESET BLOCK POINTER
	JRST	(AX)

BLKEND:	SOS	PLBLKL(DL)	; DECREMENT BLOCK LEVEL
	SOS	%TRLV(DB)	; AND DYNAMIC BLOCK LEVEL [P37]
	POP	SP,BLKPTR(DL)	; RESET BLOCK POINTER
	MOVEI	A0,0		; SET A0 FOR GETOWN

BLKE1:	POP	SP,A1		; UNSTACK
	JUMPL	A1,BLKE2	; BLOCK POINTER?
	TLZE	A1,(<Z 17,0>)	; [E713] IS THIS A STRING ARRAY ?
	PUSHJ	SP,DELSCN	; [E713] YES - DELETE SUB-STRINGS
	MOVEI	A1,@A1		; GETSTRING ITSELF, IF STRING VARIABLE.
	JUMPE	A1,BLKE1	; IF NO STRING ASSIGNED, DON'T DELETE.
PATCH (52)	; DELETE STRINGS AT BLOCK-EXIT
	PUSHJ	SP,GETOWN	; NO - DELETE ITEM
	JRST	BLKE1

BLKE2:	PUSH	SP,A1		; PUT BACK LAST BLOCK POINTER
	JRST	(AX)		; AND EXIT
SUBTTL ARRAY - ARRAY LAYOUT ROUTINE

; AN ARRAY HEADER WORD PAIR IS FORMATTED AS FOLLOWS:

; FIRST WORD:	LH:	TYPE OF ARRAY
;		RH:	POINTER TO 0TH ELEMENT OF ARRAY IF VECTOR,
;			OTHERWISE 0TH ELEMENT OF PRIMARY ILIFFE VECTOR

; SECOND WORD:	LH:	- NUMBER OF DIMENSIONS
;		RH:	POINTER TO DOPE VECTOR

; THE I'TH ELEMENT OF THE J'TH LEVEL ILIFFE VECTOR (J = 1,2, ..... N-1)
; CONTAINS THE ADDRESS OF THE 0TH ELEMENT OF THE J+1'TH ILIFFE
; VECTOR (OR N'TH ROW IF J=N-1)

; THE DOPE VECTOR CONTAINS THE BOUND PAIRS

; ARRAY - NORMAL ENTRY
; OARRAY - OWN ARRAY ENTRY
; THE BOUND PAIRS ARE ON THE STACK (DOPE VECTOR)
; AND THE LINK IS IN AX
; A1 = ARRAY TYPE (T)
; A2 = ADDRESS OF FIRST HEADER WORD (A)
; A3 = - NO. OF ARRAYS (M)
; A4 = - NO. OF DIMENSIONS (N)
ARRAY:	TDZA	A11,A11		; NORMAL ENTRY
OARRAY:	MOVEI	A11,1		; OWN ARRAY ENTRY
	MOVN	A10,A3		; SAVE NO. OF ARRAYS
	HRLI	A2,(A3)		; -M,A
	HRLZI	A3,(A4)
	ASH	A4,1
	MOVN	A13,A4		; LENGTH OF DOPE VECTOR
	HRRI	A3,1(SP)
	SUBI	A3,(A13)	; -N,DV
	JUMPN	A11,ARR10	; OWN ARRAY?

ARR1:	HRLZ	A1,A1		; T,0
	MOVE	A4,A3		; DOPE VECTOR (DV) POINTER
	SETZB	A5,A6		; A5 = SPACE ACCUMULATOR
	MOVEI	A7,1		; A6,7 = MULTIPLIER ACCUMULATOR

ARR2:	MOVM	A0,(A4)		; ABS(LB(I))
	TLNE	A0,-1		; OK?
	SYSER1	4,(AX)		; NO
	MOVM	A0,1(A4)	; ABS(UB(I))
	TLNE	A0,-1		; OK?
	SYSER1	4,(AX)		; NO
	MOVE	A0,1(A4)
	SUB	A0,(A4)		; UB(I) - LB(I)
	AOJG	A0,.+2		; FORM D(I). OK?
	SYSER1	3,(AX)		; NO
	MOVE	A6,A7
	MUL	A6,A0		; ACCUMULATE PRODUCT
	JUMPN	A6,.+2
	TLNE	A7,-1
	SYSER1	4,(AX)		; TOO LARGE
	ADD	A5,A7		; ACCUMULATE SUM OF PRODUCTS
	ADDI	A4,1
	AOBJN	A4,ARR2		; RETURN IF MORE SUBSCRIPTS
	TLNN	A1,$VAR2	; ALLOW FOR LONG REAL, ETC.
	ADD	A5,A7
	TLNE	A5,-1		; TOO BIG FOR PDP-10?
	SYSER1	4,(AX)		; UNFORTUNATELY, YES
	JRST	ARR12
ARR3:	ADDI	A13,1

ARR4:	MOVE	A5,A3		; START OF DOPE VECTOR
	MOVE	A4,1(A5)
	SUB	A4,(A5)
	ADDI	A4,1		; DIMENSION OF FIRST BOUND
	MOVE	A7,A13
	SUB	A7,(A5)		; ADDRESS OF 0TH ELEMENT
	HRRI	A1,(A7)
	ADDI	A5,1		; MOVE UP DOPE VECTOR POINTER
	AOBJN	A5,ARR5		; AND JUMP UNLESS VECTOR
	TLNE	A1,$VAR2
	JRST	ARR8		; CHECK FOR LONG REAL, ETC.
	ASH	A4,1		; DOUBLE LAST SUBSCRIPT
	MOVE	A7,-2(A5)	; GET BACK LAST  LOWER BOUND
	SUB	A1,A7		; RECALCULATE ADDRESS OF 0TH ELEMENT
	JRST	ARR8

ARR5:	MOVE	A10,A13		; NOT A VECTOR

ARR6:	ADDI	A10,(A4)	; NEXT ILIFFE VECTOR OR ARRAY
	MOVE	A6,1(A5)
	SUB	A6,(A5)
	ADDI	A6,1		; DIMENSION OF I'TH BOUND
	MOVE	A7,A10
	SUB	A7,(A5)		; ADDRESS OF 0TH ELEMENT
	ADDI	A5,1		; MOVE UP DOPE VECTOR POINTER
	AOBJN	A5,ARR7		; AND JUMP UNLESS LAST SUBSCRIPT
	TLNE	A1,$VAR2	; CHECK FOR LONG REAL, ETC.
	JRST	ARR7		; NO
	SUB	A7,-2(A5)	; ALLOW FOR DOUBLING OF SUBSCRIPT
	ASH	A6,1

ARR7:	MOVEM	A7,(A13)	; FILL IN ILIFFE VECTOR ELEMENT
	ADDI	A7,(A6)		; ADVANCE ENTRY
	ADDI	A13,1		; INCREMENT ILIFFE VECTOR
	CAIE	A13,(A10)	; COMPLETE?
	JRST	ARR7		; NO - KEEP GOING
	IMULI	A4,(A6)		; NEW PRODUCT
	TLNE	A5,-1		; ANY MORE DIMENSIONS?
	JRST	ARR6		; YES

ARR8:	ADDI	A13,(A4)	; MOVE A13 OVER ARRAY
	MOVEM	A1,(A2)
	MOVEM	A3,1(A2)	; FILL IN HEADER WORDS
	ADDI	A2,1		; MORE ARRAYS?
	AOBJN	A2,ARR4		; YES
	JUMPN	A11,ARR14	; OWN ARRAY?
ARR9:	MOVE	SP,%SYS13(DB)	; RESTORE STACK POINTER
	ADDI	SP,-1(DB)

ARR16:	MOVEI	A1,(SP)
	SUB	A1,.JBREL
	HRLI	SP,(A1)		; AND SET UP LEFT HALF
	JUMPN	A11,(AX)	; EXIT IF OWN ARRAY
	HRRZ	A1,-1(A2)	; OTHERWISE GET ADDRESS OF ARRAY
EDIT(713) ; RETURN INDIVIDUAL SPACE FOR STRING ARRAYS
	MOVE	A6,%SYS11(DB)	; [E713] GET TYPE OF ARRAY AGAIN
	TLNN	A6,$TYPE-$S	; [E713] IS IT A STRING ARRAY ?
	ADD	A1,[<Z 1,0>-2]	; [E713] YES - SET TYPE CODE INTO DESCRIPTOR

ARR16A:	EXCH	A1,(SP)		; AND ADD TO ITEM LIST ON STACK
PATCH (52)	; DELETE STRINGS AT BLOCK-EXIT.
	PUSH	SP,A1		; AND MAKE NEW BLOCK POINTER
	MOVE	A1,SP		; MAKE NEW POINTER
	SUBI	A1,(DB)
	MOVEM	A1,BLKPTR(DL)
	JRST	(AX)		; AND EXIT

ARR10:	SKIPN	A4,1(A2)	; VIRGIN ARRAY?
	JRST	ARR1		; YES - RETURN TO MAIN SEQUENCE
	MOVE	A5,A3

ARR11:	MOVE	A0,(A5)		; COMPARE NEW DOPE VECTOR WITH OLD
	CAME	A0,(A4)		; LOWER BOUNDS THE SAME?
	JRST	ARR1		; NO
	MOVE	A0,1(A5)
	CAME	A0,1(A4)	; UPPER BOUNDS THE SAME?
	JRST	ARR1		; NO
	ADDI	A5,2
	ADDI	A4,1
	AOBJN	A4,ARR11	; MOVE TO NEXT SUBSCRIPT IF ANY
	SUBI	SP,(A13)	; SAME BOUNDS - LOSE NEW DOPE VECTOR
	JRST	ARR16		; AND EXIT

ARR12:	JUMPN	A11,.+2		; UNLESS OWN ARRAY
	IMULI	A5,(A10)	; ALLOW FOR THEM ALL
	ADDI	A5,(A13)	; ALLOW FOR DOPE VECTOR
	MOVEM	A5,%SYS7(DB)	; SAVE IT
	MOVEM	A13,%SYS10(DB)	; DOPE VECTOR LENGTH
	MOVEM	A1,%SYS11(DB)	; SAVE A1
	TLNN	A1,$OWN		; IF NOT FIXED ADDRESS
	SUBI	A2,(DB)		; THEN DELOCATE
	MOVEM	A2,%SYS12(DB)	; SAVE A2
	SUBI	A3,(DB)
	MOVEM	A3,%SYS13(DB)	; SAVE A3
ARR13:	MOVE	A0,%SYS7(DB)	; SPACE REQUIRED
EDIT(713) ; RETURN INDIVIDUAL STRING SPACE FOR STRING ARRAYS
	PUSH	SP,[0]		; [E713] PUT A ZERO WORD ON THE STACK
	JUMPN	A11,ARR13A	; [E713] NOTHING TO DO IF OWN ARRAY
	MOVSI	A1,$TYPE-$S	; [E713] WHAT TYPE OF ARRAY IS THIS ?
	TDNE	A1,%SYS11(DB)	; [E713] IS IT A STRING ARRAY ?
	JRST	ARR13A		; [E713] NO  - CARRY ON
	SETOM	(SP)		; [E713] YES - SET FLAG WORD
	ADDI	A0,2		; [E713] ACCOUNT FOR EXTRA WORDS NEEDED
ARR13A:	PUSHJ	SP,GETCLR	; [E713] TRY TO GET IT (ZEROED)
	POP	SP,A4		; [E713] RESTORE TYPE-CODED WORD
	JUMPE	A4,ARR13D	; [E713] CARRY ON IF NOT STRING ARRAY
	HLLZ	A4,%SYS12(DB)	; [E713] OTHERWISE GET NUMBER OF ARRAYS
	MOVEM	A4,(A1)		; [E713] STORE IT IN LEFT HALF OF WORD 1
	HRRZ	A4,%SYS10(DB)	; [E713] GET DOPE VECTOR SIZE
	ADDI	A4,2(A1)	; [E713] AND GET ADDRESS OF NEXT WORD
	MOVEM	A4,1(A1)	; [E713] STORE THIS IN SECOND WORD
	PUSH	SP,A1		; [E713] SAVE ADDRESS
	MOVE	A1,%SYS13(DB)	; [E713] GET DOPE VECTOR POINTER
	ADDI	A1,(DB)		; [E713] AND RELOCATE IT
	SETZ	A2,		; [E713] CLEAR TOTAL ILIFFE SIZE
	MOVEI	A3,1		; [E713] AND TOTAL DATA SIZE
ARR13B:	MOVN	A4,(A1)		; [E713] GET LOWER BOUND
	ADD	A4,1(A1)	; [E713] GET DIFFERENCE
	IMULI	A3,1(A4)	; [E713] ACCUMULATE PRODUCT
	AOBJP	A1,ARR13C	; [E713] EXIT IF LAST DIMENSION
	ADD	A2,A3		; [E713] OTHERWISE ACCUMULATE TOTAL
	AOJA	A1,ARR13B	; [E713] AND LOOP FOR NEXT DIMENSION
ARR13C:	POP	SP,A1		; [E713] RESTORE DATA AREA AGAIN
	HRRM	A2,(A1)		; [E713] STORE ILIFFE VECTOR SIZE
	MOVN	A3,A3		; [E713] GET -# OF ARRAY ELEMENTS
	HRLM	A3,1(A1)	; [E713] STORE THIS IN L.H. OF WORD 2
	ADDI	A1,2		; [E713] AND STEP OVER THESE WORDS
ARR13D:	MOVE	A4,A1		; [E713] ADDRESS OF SPACE
	MOVE	A3,%SYS13(DB)	; RESTORE TEMPORARY DOPE VECTOR POINTER
	ADDI	A3,(DB)
	HRLI	A4,(A3)		; BLT POINTER
	HRRI	A3,(A4)		; POINTER TO NEW DOPE VECTOR
	MOVE	A13,%SYS10(DB)
	ADDI	A13,-1(A4)	; END OF NEW DOPE VECTOR
	BLT	A4,(A13)	; COPY TEMPORARY TO NEW DOPE VECTOR
	MOVE	A1,%SYS11(DB)	; RESTORE A1
	MOVE	A2,%SYS12(DB)
	TLNN	A1,$OWN
	ADDI	A2,(DB)		; AND A2
	JUMPE	A11,ARR3	; IF OWN ARRAY
	PUSH	SP,[0]
	PUSH	SP,[0]
	HRROI	A2,-1(SP)	; SET UP FOR NEW HEADER
	JRST	ARR3

ARR14:	MOVE	A1,%SYS12(DB)	; GET ADDRESS OF OLD HEADER
	SKIPN	1(A1)		; VIRGIN ARRAY?
	JRST	ARR15		; YES
	MOVEI	A2,-1(SP)
	PUSHJ	SP,CPYARR	; NO - COPY RELEVANT PARTS OF OLD ARRAY
	MOVEI	A11,1		; RESET OWN FLAG
	MOVE	A1,%SYS12(DB)
	HRRZ	A1,1(A1)	; GET LOCATION OF OLD ARRAY
	MOVEI	A0,0
	PUSHJ	SP,GETOWN	; AND DELETE IT

ARR15:	MOVE	A2,%SYS12(DB)	; RESTORE ADDRESS OF HEADER
	POP	SP,1(A2)
	POP	SP,(A2)		; AND COPY NEW HEADER
	ADDI	A2,1
	AOBJP	A2,ARR9		; ANY MORE ARRAYS?
	MOVEM	A2,%SYS12(DB)	; YES - MOVE TO NEXT HEADER
	JRST	ARR13		; AND DEAL WITH THE NEXT ONE
SUBTTL STRDEC - DECLARE STRINGS

; CALL IS:
;	MOVEI	A1,<STRING-VARIABLE>
;	JSP	AX,STRDEC

STRDEC:	SETZM	(A1)		; MAKE IT A NULL STRING
	CAIGE	A1,(DL)		;[E640] DYNAMIC ?
	  JRST	STRDC2		;[E640] NO.
	SUBI	A1,(DB)		;[E640] YES - 
	TLO	A1,DB		;[E640]  DELOCATE.
EDIT (640) ; MAKE STRING DELETE AT BLOCK-EXIT WORK IF STACK IS SHIFTED.

STRDC2:	TLO	A1,(@)		; SET INDIRECT BIT
	JRST	ARR16A		; LEAVE ADDRESS ON STACK FOR BLKEND

PATCH (52)	; DELETE STRINGS AT BLOCK-EXIT.
SUBTTL CHKARR - CHECK ARRAY SUBSCRIPTS ROUTINE

; ON ENTRY, THE SUBSCRIPTS ARE ON THE STACK
; A0 = NUMBER OF SUBSCRIPTS PRESENTED
; A2 = ADDRESS OF ARRAY HEADER
; THE LINK IS IN AX
; ON EXIT, THE ARRAY ELEMENT ADDRESS IS IN A2

CHKARR:	LRSTOR	A3,%SYS12(DB)	; SAVE A3,A4
	MOVE	A1,1(A2)	; GET DOPE VECTOR POINTER
	MOVE	A2,(A2)		; GET ARRAY TYPE AND ADDRESS OF 0TH WORD
	SUB	SP,A0
	MOVEI	A3,(SP)
	SUB	A3,.JBREL	; RESTORE STACK POINTER 
	HRLI	SP,(A3)		; TO POSITION BEFORE DUMPS
	MOVEI	A3,1(SP)	; POINTER TO SUBSCRIPTS

CHK1:	MOVE	A4,(A3)		; GET NEXT SUBSCRIPT
	CAML	A4,(A1)		; AND CHECK IF BETWEEN
	CAMLE	A4,1(A1)	; LOWER AND UPPER BOUNDS
	SYSER1	6,(AX)		; NO - COMPLAIN
	ADD	A2,A4		; OK - OFFSET ADDRESS BY SUBSCRIPT
	ADDI	A1,1		; ADVANCE DOPE VECTOR POINTER
	AOBJP	A1,CHK2		; ANY MORE ENTRIES IN DOPE VECTOR?
	SOJE	A0,CHK3		; YES - ANY SUBSCRIPTS LEFT?
	HRR	A2,(A2)		; YES - LOAD ILIFFE VECTOR ENTRY
	AOJA	A3,CHK1		; AND DEAL WITH NEXT SUBSCRIPT

CHK2:	SOJN	A0,CHK3		; END OF DOPE VECTOR - ANY MORE SUBSCRIPTS?
	TLNN	A2,$VAR2	; NO - TWO WORDS PER VARIABLE?
	ADD	A2,A4		; YES - DOUBLE LAST SUBSCRIPT
	LRLOAD	A3,%SYS12(DB)	; RESTORE A3,A4
	JRST	(AX)		; AND RETURN WITH ADDRESS OF ELEMENT

CHK3:	SYSER1	5,(AX)		; WRONG NUMBER OF SUBSCRIPTS
SUBTTL COMPAR - COMPARE BYTE STRINGS ROUTINE

; STRING VARIABLES ARE FORMATTED AS FOLLOWS:

; FIRST WORD:	BYTE-POINTER TO STRING (POSITION FIELD = OCTAL 44)

; SECOND WORD:	BIT 0:	WRITE PROTECT BIT (SET IN STRING CONSTANT
;			HEADERS)
;		BIT 1:	 DYNAMIC BIT (SET IN STRINGS CREATED
;			IN THE HEAP)
;		BIT 2:		1 = RESULT OF STRING-TYPE PROCEDURE
;		BITS 3-11:	SPARE
;		BITS 12-35:	NUMBER OF BYTES IN BYTE STRING
PATCH (5)	; REVISE STRING FORMATS

; ON ENTRY:
; A0,A1 CONTAIN THE VALUE OF THE FIRST STRING VARIABLE
; A2,A3 CONTAIN THE VALUE OF THE SECOND STRING VARIABLE
; THE LINK IS IN AX
; ON EXIT:
; A0 CONTAINS -1,0 OR +1 ACCORDING AS THE FIRST STRING IS LESS THAN,
; EQUAL TO OR GREATER THAN THE SECOND STRING
EDIT(736); Rewrite COMPAR to deal with trailing ASCII spaces/nulls properly

COMPAR:	PUSH	SP,A0		; Save byte-pointer 1 on the stack
	TLZ	A1,STRBCC	; Mask out unwanted bits to get length 1
	SKIPN	A0		; If this is a null string,
	TDZA	A1,A1		; Ensure length is zero
	SKIPN	A1		; Also, if length is zero,
	SETZB	A0,(SP)		; Make sure this is a null string.
	PUSH	SP,A1		; Save length 1 on the stack
	PUSH	SP,A2		; Save byte-pointer 2 on the stack
	TLZ	A3,STRBCC	; Mask out unwanted bits to get length 2
	SKIPN	A2		; If this is a null string,
	TDZA	A3,A3		; Ensure length is zero
	SKIPN	A3		; Also, if length is zero,
	SETZB	A2,(SP)		; Make sure this is a null string.
	PUSH	SP,A3		; Save length 2 on the stack
	LDB	A1,[POINT 6,A0,11] ; Get byte-size 1 into A1
	LDB	A3,[POINT 6,A2,11] ; Get byte-size 2 into A3
	SETZ	A0,		; Initialize A0 (result) to 0
	CAMN	A1,A3		; Do byte sizes match ?
	JRST	CMPR2		; Yes - compare word-at-a-time
	CAIN	A1,7		; No. If first string is ASCII (byte size = 7)
	JUMPE	A3,CMPR5	; and the second is a null string,
	CAIN	A3,7		; or vice-versa, then check for string
	JUMPE	A1,CMPR5	; consisting entirely of nulls or spaces.

; Byte-at-a-time compare. (Different byte sizes).
CMPR0:	SETZB	A1,A3		; Initialize both values to nulls
	SOSL	-2(SP)		; If string 1 has not yet run out,
	ILDB	A1,-3(SP)	; Get next byte into A1.
	SOSL	0(SP)		; Similarly, if string 2 not yet exhausted
	ILDB	A3,-1(SP)	; Get next byte into A3.
	CAME	A1,A3		; Compare the two bytes
	JRST	CMPR9		; Unequal - strings are different
	SKIPG	-2(SP)		; Equal. Continue if either string
	SKIPLE	0(SP)		; not yet exhausted (padding with nulls)
	JRST	CMPR0		; to try to find a difference

CMPR1:	SUB	SP,[		; Both strings exhausted - compare equal.
	XWD	4,4]		; Retard stack to original level
	JRST	(AX)		; & return
; Word-at-a-time compare. (Same byte-size, in A3).
CMPR2:	JUMPE	A3,CMPR1	; If byte-size zero, both are (equal) null strings
	MOVNI	A2,^D36		; Otherwise must do a real compare.
	IDIVI	A2,(A3)		; Get -(#bytes/word) in A2

CMPR3:	SETZB	A1,A3		; Initialize both words to nulls
	SKIPLE	-2(SP)		; If still some of string 1 left,
	MOVE	A1,@-3(SP)	; get next word-full into A1
	SKIPLE	0(SP)		; Similarly get next word-full of string 2
	MOVE	A3,@-1(SP)	; into A3 (unless none left).
	CAME	A1,A3		; Are the words identical ?
	JRST	CMPR4		; No.
	ADDM	A2,0(SP)	; Yes - decrement both byte-counts
	ADDM	A2,-2(SP)	;  by number of bytes/word
	AOS	-3(SP)		; And increment both addresses to
	AOS	-1(SP)		;  point to the next full word.
	SKIPG	(SP)		; If either string has some bytes left
	SKIPLE	-2(SP)		; then continue with the comparison.
	JRST	CMPR3		; Otherwise strings are identical
	JRST	CMPR1		; except for possible trailing nulls

CMPR4:	MOVN	A2,A2		; Get +(bytes/word)
	CAIE	A2,5		; Is this an ASCII comparison ?
	JRST	CMPR0		; No - check for exact match

; Comparison of ASCII strings (trailing space = trailing null)
CMPR5:	SETZB	A1,A3		; Initialize both values to nulls
	SOSL	-2(SP)		; If string 1 has not yet run out,
	ILDB	A1,-3(SP)	; Get the next byte into A1
	SOSL	0(SP)		; And similarly get next byte of
	ILDB	A3,-1(SP)	; string 2, unless exhausted
	CAMN	A1,A3		; Are the bytes identical ?
	JRST	CMPR7		; Yes - try the next pair
	CAIN	A1," "		; Allow space from first string
	JUMPE	A3,CMPR6	; to match null from second string
	CAIN	A3," "		; And allow null from first string
	JUMPE	A1,CMPR6	; to match space from second string
	JUMPN	A0,CMPR1	; Some other character. If some difference
	JRST	CMPR9		; previously encountered, the string which
				; had the space will be greater than the string
				; which had the null. Otherwise, compare these
				; (different) characters to order the strings.
CMPR6:	JUMPN	A0,CMPR8	; Jump if already found a difference
	SKIPE	A1		; Otherwise set A0 to reflect which string
	AOJA	A0,CMPR8	; had the space, and which the null.
	SOJA	A0,CMPR8	; (-1 if string 1 null, +1 if string 2)
CMPR7:	JUMPE	A1,CMPR8	; Identical characters. If they are
	CAIE	A1," "		; both nulls or spaces, continue testing
	JUMPN	A0,CMPR1	; If not, embedded spaces do not match nulls
CMPR8:	SKIPG	-2(SP)		; If only spaces or nulls found so far,
	SKIPLE	0(SP)		; repeat while either string has characters
	JRST	CMPR5		; which have not yet been examined
	SETZ	A0,		; Otherwise set result 'equal'
	JRST	CMPR1		; and return (tidying up stack first)

CMPR9:	CAML	A1,A3		; Strings differ - see which is "greater"
	AOJA	A0,CMPR1	; A0:= +1;! string 1 > string 2;
	SOJA	A0,CMPR1	; A0:= -1;! string 1 < string 2;
SUBTTL PRBYTE/PWBYTE - BYTE POINTER ROUTINES

; ON ENTRY:
; A1 = BYTE NUMBER
; A2 = ADDRESS OF STRING VARIABLE
; THE LINK IS IN AX
; ON EXIT, THE BYTE POINTER IS IN A2

; E.G.
;
;	S.[I] := S.[J]
;
; COMPILES INTO
;
;	MOVE	A1,J
;	MOVEI	A2,S
;	JSP	AX,PBYTE
;	LDB	A13,A2		; A13 := S.[J]
;	MOVE	A1,I
;	MOVEI	A2,S
;	JSP	AX,PBYTE
;	DPB	A13,A2		;  S.[I] := A13

PATCH (5)	; REVISE STRINGS
PBYTE:	MOVEI	A2,@A2
	LRSTOR	A4,%SYS11(DB)	; SAVE A4,A5
	SOJL	A1,PBYT2	; CHECK SENSIBLE BYTE NUMBER

EDIT(667) ; CHECK FOR NULL STRINGS
PBYT1:	SKIPN	STR1(A2)	; [E667] IS THIS A NULL STRING ?
	JRST	PBYT2		; [E667] YES - TELL OFF BAD USER
	MOVE	A4,STR2(A2)
	TLZ	A4,STRBCC	; NUMBER OF BYTES IN STRING
	CAMGE	A1,A4		; ENOUGH?
	JRST	PBYT3		; YES
PBYT2:	SYSER1	16,(AX)		; BYTE NUMBER OUT OF RANGE
PATCH (5)	; REVISE STRING FORMATS
PBYT3:	HLL	A2,STR1(A2)	; GET LEFT HALF OF FIRST STRING WORD
	HLRZ	A5,A2
	ANDI	A5,STRBS
	LSH	A5,-6		; AND EXTRACT BYTE SIZE
	MOVEI	A3,44
	IDIVI	A3,(A5)		; CALCULATE NUMBER OF BYTES PER WORD
	EXCH	A1,A2		; EXCHANGE BYTE NUMBER AND ADDRESS
	IDIVI	A2,(A3)		; CALCULATE WORD AND BYTE NUMBER
	HRR	A1,(A1)		; GET ADDRESS OF BYTE STRING
	ADDI	A2,(A1)		; AND GET ADDRESS OF WORD CONTAINING BYTE
	CAMG	A2,.JBREL	; GOOD ADDRESS IN LOW SEGMENT?
	JRST	PBYT4		; YES
	HRRZ	A4,.JBHRL
	CAILE	A2,(A4)		; NO - GOOD ADDRESS IN HIGH SEGMENT
	SYSER2	5,0		; NO - COMPLAIN

PBYT4:	DPB	A5,[
	POINT	6,A2,11]	; SET UP BYTE SIZE
	IMULI	A5,1(A3)
	MOVEI	A4,44
	SUBI	A4,(A5)		; POSITION OF LAST BIT IN BYTE
	DPB	A4,[
	POINT	6,A2,5]		; SET IT IN BYTE POINTER
PBYT5:	LRLOAD	A4,%SYS11(DB)	; RESTORE A4,A5
	JRST	(AX)
SUBTTL CPYSTR - COPY STRING ROUTINE

; ON ENTRY:
; A0,A1 CONTAIN THE VALUE OF THE OLD STRING VARIABLE
; A2 CONTAINS THE ADDRESS OF THE NEW STRING VARIABLE
; A4 CONTAINS THE ADDRESS OF THE NEW BYTE STRING
; A7 CONTAINS THE LOWEST BYTE NUMBER TO BE COPIED
; A10 CONTAINS THE NUMBER OF BYTES TO BE COPIED
; THE LINK IS IN AX

; A3 AND A13 ARE SACRED, AS THIS ROUTINE IS CALLED FROM PARAM

CPYSTR:	TLO	A1,STRDYN	; SET DYNAMIC BIT
	MOVE	A5,A1		; TAKE COPY OF 2ND WORD
	TLO	A5,STRPRC	; MARK AS RESULT OF STRING PROC
	MOVEM	A5,STR2(A2)	; AND SET UP SECOND WORD OF STRING
	DPB	A10,[
	POINT	24,STR2(A2),35]	; AND PLANT BYTE COUNT
	JUMPE	A10,CPYS7	; SPECIAL TREATMENT IF NULL STRING
	HLL	A4,A0
PATCH (5)	; REVISE STRINGS
	MOVEM	A4,STR1(A2)	; SET UP FIRST WORD OF STRING

CPYS1:	MOVE	A5,A0		; GET POINTER TO OLD STRING
	MOVE	A2,A1		; SAVE FLAGS
	TLZ	A1,STRBCC	; GET BYTE COUNT
	JRST	CPYS4

CPYS2:	ILDB	A6,A5
	SOJG	A7,CPYS2	; IDLE UNTIL FIRST BYTE REQUIRED

CPYS3:	IDPB	A6,A4		; YES COPY BYTE
	SOJE	A10,(AX)	; COUNT DOWN COPY

CPYS4:	SOJGE	A1,CPYS2	; COUNT DOWN BYTES
	HLRZ	A1,A0		; EXHAUSTED

CPYS7:	SETZM	STR1(A2)	; CLEAR FIRST WORD OF NULL STRING
	JRST	(AX)
SUBTTL STRASS - STRING ASSIGNMENT ROUTINE

; S:=T
; ENTERED WITH:	0(SP),-1(SP)	LEFT-HAND STRING VARIABLE
;		-2(SP),-3(SP)	RIGHT-HAND STRING VARIABLE
; ON EXIT:	A0,A1		NEW LEFT-HAND STRING VARIABLE
;				STACK CLEARED.
;
STRAS0:	PUSH	SP,A2		; [E701] SPECIAL ENTRY POINT FOR PARAM
	JRST	STRAS1		; [E701] TO INITIALIZE A VALUE STRING
STRASS:	POP	SP,A1		; GET L.H. STRING VARIABLE
	POP	SP,A0
STRASX:	CAMN	A0,-1(SP)	; [E711] IS L.H. = R.H. ? (S:=S;)
	JRST	STRAS2		;  YES - DON'T WASTE TIME
	PUSH	SP,A2		; NO - SAVE A2
	JUMPE	A0,STRAS1	; DOES L.H. STRING EXIST ?
	TLNN	A1,STRDYN	; YES - IS IT DYNAMIC ?
	JRST	STRAS1		; NO
	HRRZ	A1,A0
	SETZ	A0,
	PUSHJ	SP,GETOWN	; YES - DELETE IT

STRAS1:	SKIPE	-2(SP)		; [E701] EXTRA CHECKS FOR NULL STRINGS
	SKIPN	A2,-1(SP)	; [E701] WHICH MAY HAVE ZERO BYTE SIZE
	JRST	STRAS3		; [E701] QUICK EXIT FOR NULL STRINGS
	TLNE	A2,STRPRC	; IS R.H. THE RESULT OF A STRING PROC ?
	JRST	STRAS3		;  YES - DON'T COPY, JUST RETURN IT
	LDB	A2,[
	POINT	6,-2(SP),11]	; GET BYTE-SIZE
	MOVEI	A1,^D36
	IDIVI	A1,(A2)		; GET # BYTES/WORD
	MOVE	A0,-1(SP)	; GET LENGTH IN BYTES
	TLZ	A0,STRBCC	; ISOLATE LENGTH
	IDIVI	A0,(A1)		; TO WORDS
	SKIPE	A1
	ADDI	A0,1		; ROUND UP
EDIT(623); FIX HANDLING OF NULL STRINGS
	JUMPE	A0,STRAS3	;DONT ASK GETOWN FOR 0 WORDS
	PUSH	SP,A0		; KEEP
	PUSHJ	SP,GETOWN	; GET SPACE
	POP	SP,A2
	ADDI	A2,-1(A1)	; FORM END-OF-BLT
	HRLI	A1,@-2(SP)	; MAKE A BLT POINTER
	HRRM	A1,-2(SP)	; SET NEW ADDRESS INTO STRING-VARIABLE
	BLT	A1,(A2)		; COPY

STRAS3:	POP	SP,A2		; RESTORE A2

STRAS2:	POP	SP,A1		; GET NEW
	TLO	A1,STRDYN	;  (DYNAMIC)
	TLZ	A1,STRPRC	;   (NON-PROCEDURE RESULT)
	POP	SP,A0		;    STRING VARIABLE
	TLZ	A0,77		; CLEAR INDEX FILED
EDIT(701);Initialize null value strings properly
	SKIPE	A0		; [E701] IF ALREADY A NULL STRING
	TDNN	A1,[77,777777]	; [E701] OR ONE WITH ZERO BYTES
	SETZB	A0,A1		; [E701] CLEAR POINTER AND COUNT
	JRST	(AX)		; RETURN
SUBTTL CPYARR - COPY ARRAY ROUTINE

; ON ENTRY:
; A1 = ADDRESS OF SOURCE ARRAY (MAY BE DESTROYED)
; A2 = ADDRESS OF DESTINATION ARRAY
; THAT PART OF THE ARRAY(A1) WHICH IS COMMON WITH
; ARRAY(A2) IS COPIED, WITH APPROPRIATE TYPE CONVERSION

CPYARR:	HRLZI	AX,(AX)		; SAVE OLD LINK IN LH OF AX
	MOVE	A3,1(A1)	; DV POINTER FOR SOURCE ARRAY
	MOVE	A4,1(A2)	; DV POINTER FOR DESTINATION ARRAY
	HLLZ	A5,A3
	HRRI	A5,1(SP)	; COMMON DV POINTER
	MOVE	A13,SP		; SAVE SP

CPYA1:	MOVE	A6,(A3)
	CAMGE	A6,(A4)
	MOVE	A6,(A4)		; LC = MAX(LB(A1),LB(A2))
	MOVE	A7,1(A3)
	CAML	A7,1(A4)
	MOVE	A7,1(A4)	; UC = MIN(UB(A1),UB(A2))
	CAMGE	A7,A6		; UC >= LC?
	JRST	CPYA3		; NO - ABORT COPY
	PUSH	SP,A6		; YES -
	PUSH	SP,A7		; SET LC, UC IN COMMON DV
	ADDI	A3,2		; MOVE ALONG DV POINTERS
	ADDI	A4,1
	AOBJN	A4,CPYA1	; AND CONTINUE IF MORE SUBSCRIPTS
	HLLZ	A6,A3
	HRRI	A6,1(SP)	; WORKING SUBSCRIPTS VECTOR
	MOVE	A7,A5

CPYA2:	PUSH	SP,(A7)		; INITIALIZE WORKING VECTOR
	ADDI	A7,1
	AOBJN	A7,CPYA2	; FROM COMMON DV
	MOVE	A3,(A1)		; GET TYPE AND IV ADDRESS OF SOURCE ARRAY
	MOVE	A4,(A2)		; GET TYPE AND IV ADDRESS OF DESTINATION ARRAY
	HLRZ	A7,A3
	ANDI	A7,$TYPE
	LSH	A7,-11
	HRLZ	A7,TYPTAB(A7)	; LOOK UP SOURCE ENTRY IN PARAM'S MAGIC TABLE
	HLRZ	A10,A4
	ANDI	A10,$TYPE
	LSH	A10,-11
	AND	A7,TYPTAB(A10)	; AND GATE WITH DESTINATION'S ENTRY
	JFFO	A7,CPYA4	; AND SORT IT ALL OUT!!!!!!!
				; (MISMATCHES FALL THROUGH HERE)
CPYA3:	HLRZ	AX,AX		; RESTORE OLD LINK
	MOVE	SP,A13		; RESTORE STACK POINTER
	POPJ	SP,0		; AND EXIT

CPYA4:	ROT	A10,-1		; SHIFT AROUND ODD BIT - EDIT # 430
	JUMPGE	A10,.+2		; ODD ENTRY?
	SKIPA	A10,CPYA8(A10)	; YES - LOAD IT
	MOVS	A10,CPYA8(A10)	; NO - LOAD EVEN ENTRY

CPYA5:	MOVE	A7,A6		; TAKE COPY OF WORKING VECTOR ADDRESS
	HRRZ	A11,A3		; GET 0TH ILIFFE VECTOR ENTRY FOR SOURCE
	HRRZ	A12,A4		; AND FOR DESTINATION

CPYA6:	ADD	A11,(A7)	; ADVANCE BY NEXT SUBSCRIPT
	ADD	A12,(A7)
	AOBJP	A7,(A10)	; ANY MORE SUBSCRIPTS?
	MOVE	A11,(A11)	; YES - MOVE THROUGH ILIFFE VECTOR ENTRY
	MOVE	A12,(A12)
	JRST	CPYA6

CPYA8:	XWD	CPYA9,CPYA11	; I -> I, I -> R
	XWD	CPYA12,CPYA13	; I -> LR, R -> I
	XWD	CPYA9,CPYA14	; R -> R, R -> LR
	XWD	CPYA15,CPYA16	; LR -> I, LR -> R
	XWD	CPYA17,CPYA3	; LR -> LR, C -> C
	XWD	CPYA3,CPYA3	; C -> LC, LC -> C
	XWD	CPYA3,CPYA9	; LC -> LC, B -> B
	XWD	CPYA17,CPYA3	; S -> S, L -> L
	XWD	CPYA3,0		; N -> N

CPYA9:	MOVE	A0,(A11)	; I -> I, R -> R, B -> B

CPYA10:	MOVEM	A0,(A12)	; GENERAL SINGLE WORD STORE
	JRST	CPYA19

CPYA11:	MOVE	A0,(A11)	; I -> R
	CIR
	JRST	CPYA10

CPYA12:	MOVE	A0,(A11)	; I -> LR
	CILR
	JRST	CPYA18
CPYA13:	MOVE	A0,(A11)	; R -> I
	CRI
	JRST	CPYA10

CPYA14:	MOVE	A0,(A11)	; R -> LR
	MOVEI	A1,0
	JRST	CPYA18

CPYA15:	ADD	A11,-1(A7)	; DOUBLE LAST SUBSCRIPT OF SOURCE
	LRLOAD	A0,(A11)	; LR -> I
	CLRI
	JRST	CPYA10

CPYA16:	ADD	A11,-1(A7)	; DOUBLE LAST SUBSCRIPT OF SOURCE
				; LR -> R
	LRLOAD	A0,(A11)
	CLRR
	JRST	CPYA10

CPYA17:	ADD	A11,-1(A7)	; DOUBLE LAST SUBSCRIPT OF SOURCE
	LRLOAD	A0,(A11)	; LR -> LR, S -> S

CPYA18:	ADD	A12,-1(A7)	; DOUBLE LAST SUBSCRIPT OF DESTINATION
	LRSTOR	A0,(A12)	; GENERAL DOUBLE WORD STORE


CPYA19:	MOVEI	A11,(A6)	; REVERSE POINTER TO COMMON DV

CPYA20:	AOS	A12,-1(A7)	; GET AND INCREMENT LAST SUBSCRIPT
	CAMG	A12,-1(A11)	; GONE TOO HIGH?
	JRST	CPYA5		; NO - GO BACK FOR NEXT ELEMENT
	MOVE	A12,-2(A11)	; YES - REPLACE
	MOVEM	A12,-1(A7)	; BY MINIMUM VALUE
	SUBI	A11,2		; MOVE DOWN COMMON DV
	CAIG	A11,2(A13)	; DOWN TO FIRST SUBSCRIPT?
	JRST	CPYA3		; YES
	SOJA	A7,CPYA20	; NO - KEEP GOING
SUBTTL	GETOWN	- GET HEAP SPACE ROUTINE
PATCH (27)	; REVISE HEAP MANAGEMENT

; ON ENTRY,
; If A0 < 0, the space returned is immediately below the stack base,
; so as to be capable of extension
; If A0 = 0, A1 is the address of a space to be returned to the heap
; If A0 > 0, A0 is the number of words of heap space required.

; Where space is acquired, A1 contains the address of the first useful word

; Free heap space is referenced by a table addressed by %SYS2,
; the entries being formatted as follows:-

; 0 = null entry
; length,,pointer = free area in Heap
; The last word in a piece of table is either 0 or an AOBJN pointer
;  to another piece of table (the pieces of table are themselves in
;  the Heap).

; each heap area is preceeded by a 'chain word', formatted as follows:-

; LH = length of this area, including chain word
; RH = 0	area in use
;    = non-zero, pointer to area's entry in heap table

GETKNL:	; KERNEL OF GETOWN - A2 = TABLE POINTER (-LENGTH,,ADDR)
PATCH (31)	; OVERLAY HANDLER ROUTINES (FUNCT.)
Edit(716); Use current top of heap if possible
	PUSH	SP,A2		; [E716] SAVE TABLE POINTER
	PUSH	SP,A3		; ALL ENTRIES REQUIRE TO SAVE A3
	JUMPL	A0,GET3		; FLEX ENTRY
	JUMPE	A0,GET2		; RETURN SPACE

GET1:				; ORDINARY GET-N-WORDS ENTRY
	ADDI	A0,1		; ALLOW FOR LINK-WORD
	HRROI	A3,-1		; INITIALIZE A3 AS FLAG/COMPARE WORD

GET13:	HLRZ	A1,(A2)		; GET SIZE OF NEXT SLOT
	SUB	A1,A0		;
	JUMPL	A1,GET15	; DIFFERENCE
	JUMPN	A1,GET14	; SPOT ON
	EXCH	A1,(A2)		; CLEAR HEAP TABLE ENTRY, LOAD POINTER
	HLLZS	(A1)		; CLEAR RHS OF CHAIN WORD
	JRST	GET97

GET14:	CAIL	A1,(A3)		; LARGE ENUF - CF WITH PREV
	JRST	GET15		; NO BETTER
	MOVEI	A3,(A1)		; IMPROVEMENT
	HRLI	A3,(A2)

GET15:	AOBJN	A2,GET13	; KEEP TRYING
	SKIPE	A2,(A2)		; MORE TABLE ?
	JRST	GET13		;  YES - USE IT
	JUMPGE	A3,GET17
	MOVE	A2,-1(SP)	; [E716] GET TABLE AGAIN
	PUSH	SP,A0		; [E716] SAVE A0 (DESIRED SIZE)
	SETO	A0,		; [E716] FLAG NOTHING FOUND
	PUSHJ	SP,GETTOP	; [E716] GET TOPMOST CHUNK
	  TDZA	A1,A1		; [E716] NOT FOUND - LENGTH = 0
	HLRZ	A1,(A1)		; [E716] FOUND - GET LENGTH
	MOVN	A1,A1		; [E716] A1 = -(LENGTH OF CHUNK)
	ADD	A1,(SP)		; [E716] A1 = LENGTH TO EXTEND BY
	CCORE1	(A1)		; [E716] SHIFT THE STACK
	POP	SP,A0		; [E716] GET DESIRED LENGTH AGAIN
	MOVN	A1,A0		; [E716] GET WHERE IT WILL START
	ADDI	A1,(DB)		; [E716] BY COUNTING DOWN FROM DB
	HRLZM	A0,(A1)		; SET CHAIN-WORD
	JRST	GET97

GET17:	MOVS	A2,A3		; A2 IS LENGTH,,TABLE POINTER
	HRRZ	A1,(A2)		; BASE ADDR OF PIECE TO GIVE AWAY
	HRLZM	A0,(A1)		; SET ITS LINK WORD
	ADDB	A0,(A2)		; INCR POINTER IN TABLE
	HLLM	A2,(A2)		; SET LENGTH OF FREE PIECE
	HRRZ	A3,A0
	MOVEM	A2,(A3)		; SET ITS LINK WORD
	JRST	GET97		;  WHICH ADDS 1 TO A1 & RETURNS
GET2:				; A0 = 0 - RETURN SPACE ADDRESSED BY A1
	TLZ	DB,TMPFL1!TMPFL2; CLEAR TEMPORARY FLAG BITS
	HLRZ	A0,-1(A1)	; A0 IS LENGTH OF RETURNED PIECE
	ADDI	A0,-1(A1)	; NOW TOP ADDRESS + 1
	MOVEI	A1,-1(A1)	; GET ADDRESS OF BOTTOM OF PIECE

GET21:	SKIPN	A3,(A2)		; GET TABLE ENTRY - FREE ?
	JRST	GET24		; YES
	CAIE	A0,(A3)		; NO - PIECE IMMEDIATELY ABOVE RETURNED PIECE ?
	JRST	GET22		; NO
	HLLZ	A3,A3		; YES - MERGE. CLEAR RHS
	HRRM	A1,(A2)		; SET TABLE WORD TO POINT TO MERGED PIECES
	PUSH	SP,(A1)		; SAVE OLD BACK-POINTER
	HRRM	A2,(A1)		; AND SET BACK-POINTER TO THIS TABLE-ENTRY ADDR
	JRST	GET23

GET22:	HLRZ	A3,(A2)		; LENGTH OF TABLE'S PIECE
	ADD	A3,(A2)		; + ITS ADDR GIVES ITS TOP ADDR
	CAIE	A1,(A3)		; IMMEDIATELY BELOW RETURNED PIECE ?
	JRST	GET25		; NO
	PUSH	SP,(A1)		; SAVE OLD UPEPER TABLE POINTER
	HLLZ	A3,(A1)		; YES - MERGE. GET EXTRA LENGTH
	HRRZ	A1,(A2)		; GET LOWER ADDRESS

GET23:	ADDB	A3,(A1)		; SET NEW LENGTH INTO LINK WORD
	HLLM	A3,(A2)		;  AND INTO TABLE ENTRY
	POP	SP,A3		; GET OLD BACK-POINTER
	TRNE	A3,-1		; WAS IT FREE ?
	SETZM	(A3)		; YES - RELEASE ITS TABLE ENTRY
	TLO	DB,TMPFL1	; REMEMBER WE WON'T NEED A TABLE SLOT
	JRST	GET25

GET24:	; WE'VE FOUND A FREE TABLE SLOT
	TLON	DB,TMPFL2	; IF WE HAVEN' FOUND ONE BEFORE,
	PUSH	SP,A2		;  SAVE ITS ADDRESS

GET25:	AOBJN	A2,GET21	; GET NEXT TABLE ENTRY.
	SKIPN	(A2)		; ANY MORE BITS OF TABLE ?
	JRST	GET25A		; NO.
	MOVE	A2,(A2)
	JRST	GET21		; YES - GO USE IT

GET25A:	TLNE	DB,TMPFL2	; NEED TO DECREMENT STACK ?
	POP	SP,A3		; YES
	TLNE	DB,TMPFL1	; STILL GOT TO PLANT TABLE ENTRY ?
	JRST	GET99		; NO - ALL OVER
	TLNE	DB,TMPFL2	; WAS THERE A FREE SLOT ?
	JRST	GET26		; YES - GO USE IT
	PUSH	SP,A0		; NO FREE SPACE IN TABLE: MUST GET ANOTHER PIECE
	PUSH	SP,A1		;  & CHAIN IT ON
	PUSH	SP,A2		;   (RECURSIVE, SO SAVE EVERYTHING)
	MOVEI	A0,HPCHN
	PUSHJ	SP,GETCLR	; GET IT, ZEROED (NOTE: NO WAY WILL THIS
				;  NEED ANOTHER TABLE SLOT !!)
	POP	SP,A2		; ADDRESS OF LAST WORD OF OLD PIECE
	MOVEI	A0,1-HPCHN	; LENGTH (LESS LINK-WORD) OF NEW PIECE
	HRL	A1,A0		; FORM LINK-WORD
	MOVEM	A1,(A2)		;  AND STORE IT AT END OF OLD PIECE
	MOVEI	A3,(A1)		; ADDR OF 1ST WORD OF NEW PIECE
	POP	SP,A1
	POP	SP,A0
GET26:	HLL	A1,(A1)		; LENGTH OF SPACE
	MOVEM	A1,(A3)		; MAKE TABLE ENTRY
	HLL	A3,A1		; AND BACK-POINTER
	MOVEM	A3,(A1)
	JRST	GET97
GET3:	PUSHJ	SP,GETTOP	; [E716] GET TOPMOST CHUNK
	  JRST	GET33		; [E716] NOT AVAILABLE
	HLLZS	(A1)		; CLEAR CHAIN WORD
	JRST	GET97

GET33:	PUSH	SP,DB		; SAVE CURRENT STACK BASE
PATCH(30)	; NEW CORE UUO
	CCORE1	^D128		; SHIFT STACK 128 WORDS
	POP	SP,A1		; NOW OLD STACK BASE
	HRLZI	A2,^D128	; LOAD COUNT
	MOVEM	A2,0(A1)	; SET CHAIN WORD

GET97:	MOVEI	A1,1(A1)	; FIRST USEFUL WORD

GET99:	POP	SP,A3
	POP	SP,A2		; [E716] RESTORE A2
	POPJ	SP,

GETTOP:	HRRZ	A1,(A2)		; GET POINTER
	CAIGE	A0,(A1)		;
EDIT(630); FLEX-GETOWN ALWAYS ASKED FOR MORE CORE.
	MOVEI	A0,(A1)		; [E630] THIS ENTRY IS HIGHER
	AOBJN	A2,GETTOP
	SKIPE	A2,(A2)		; MORE TABLE ?
	JRST	GETTOP		; YES - USE IT
	JUMPL	A0,CPOPJ	; NONE FREE
	HRRZ	A1,A0		; [E630] HIGHEST ENTRY (ADDR OF SPACE)
	HLRZ	A0,(A1)		; [E630] LENGTH
	ADDI	A0,(A1)		; [E630] PLUS ADDR
	CAIE	A0,(DB)		; IS IT THE TOP ?
	POPJ	SP,		; [E716] NO  - JUST RETURN
	AOS	(SP)		; [E716] YES - SKIP RETURN
	HRRZ	A2,(A1)		; [E630] O.K.-GIVE IT AWAY
	SETZM	(A2)		; CLEAR TABLE ENTRY
CPOPJ:	POPJ	SP,		; [E716] RETURN
GETOWN:	MOVE	A2,%SYS2(DB)	; GET POINTER TO PUBLIC HEAP-TABLE
	PUSHJ	SP,GETKNL	; DO THE JOB
PATCH (31)	; OVERLAY HANDLER ROUTINES
	IFN	FTGETCHK,<
	; ***** OPTIONAL HEAP INTEGRITY CHECKER *****

	SKIPE	%SYSOV(DB)	; FUNCT PRIVATE HEAP CHANGES
	JRST	GETX9		;  FORMAT OF OUR HEAP, SO WE CAN'T CHECK IT
PATCH (31)	; OVERLAYS
	PUSH	SP,A3
	PUSH	SP,A1
	SETZ	A1,
	HRRZ	A2,%SYS2(DB)
	HLRE	A3,%SYS2(DB)	; - (LENGTH OF LIST -1)
	SUBI	A2,-1(A3)
	TLZ	A2,-1		; CLEAR LEFT HALF

GETX2:	MOVE	A3,(A2)
	TRNE	A3,-1		; ANY RIGHT HALF ?
	AOJA	A1,GETX1	; YES - UNNUSED - CHECK TABLE CONSISTENT

GETX3:	HLRZ	A0,A3		; GET SIZE
	ADD	A2,A0		; MOVE TO NEXT CHUNK
	CAIGE	A2,(DB)		; END ?
	JRST	GETX2		; NO - CHECK NEXT CHUNK
	CAIE	A2,(DB)		; EXACTLY THERE ?
	JRST	GETERR		; NO
	CAML	A1,%SYS24(DB)	; KEEP TRACK OF
	MOVEM	A1,%SYS24(DB)	;  MAX # OF USED ENTRIES

GETX4:	POP	SP,A1		;   IN HEAP TABLE
	POP	SP,A3
	JRST	GETX9		; YES - IT'S ALL OK !!!

GETX1:	HLL	A0,A3		; SIZE FROM LINK-WORD
	HRR	A0,A2		; ADDRESS OF CHUNK
	CAMN	A0,(A3)		; = TABLE-ENTRY ?
	TLNN	A0,-1		; AND NON-ZERO SIZE ?
	JRST	GETERR		; NOPE
	JRST	GETX3		; YES - OK

	>	; END OF FTGETCHK
GETX9:	SETZ	A0,		; THE OUTSIDE WORLD EXPECTS A0 = 0 (FOR DELETE)
	POPJ	SP,

	IFN	FTGETCHK,<
GETERR:	TTCALL	3,[ASCIZ/
? CONSISTENCY ERROR IN HEAP HANDLER./]
	EXIT	1,
	JRST	GETX4		; CONTINUABLE
	>	; END OF IFN FTGETCHK
SUBTTL GETCLR - GET ZERO-FILLED OWN SPACE

GETCLR:	PUSHJ	SP,GETOWN	; GET THE SPACE
	SETZM	(A1)
	HLRZ	A2,-1(A1)	; GET LENGTH OF SPACE
	SUBI	A2,2
	JUMPE	A2,GETCL2	; ONLY 1 WORD - DONE
	MOVEI	A5,1(A1)	; MAKE A
	HRL	A5,A1		;  BLT POINTER
	ADDI	A2,(A1)
	BLT	A5,(A2)		; ZEROES

GETCL2:	POPJ	SP,
SUBTTL RDOCT/PROCT - READ OCTAL WORD/PRINT OCTAL HALFWORD ROUTINES

; AN OCTAL WORD IS READ AND RETURNED IN A0

RDOCT:	SETZB	A0,A1		; CLEAR ACCUMULATOR AND DIGIT FLAG
	PUSHJ	SP,IGNICH	; IGNORE INVISIBLE  CHARACTERS
	CAIN	A13,"%"		; OCTAL MARKER?
	JRST	RDOCT1		; YES - OK

RDOCT4:	HLRZ	A1,%CHAN(DB)	; GET CHANNEL #
	IOERR	10,(A1)		; GO TO ERROR
PATCH (17)	; IMPROVE I/O ERROR MESSAGES

RDOCT1:	JSP	AX,INCHAR	; GET NEXT CHARACTER
	CAIL	A13,"0"
	CAIL	A13,"8"		; IN RANGE 0 - 7?
	JRST	RDOCT3		; NO
	TLNE	A0,700000	; YES - TOP OIT SET?

RDOCT2:	SYSER2	3,0		; YES - COMPLAIN ABOUT OVERFLOW
	LSH	A0,3		; NO - SHIFT UP
	ADDI	A0,-"0"(A13)	; AND ADD IN OIT
	JOV	RDOCT2		; AND CHECK FOR OVERFLOW
	AOJA	A1,RDOCT1	; COUNT DIGITS AND CONTINUE

RDOCT3:	JUMPE	A1,RDOCT4	; TERMINATOR - DIGIT SEEN?
	POPJ	SP,0		; YES - EXIT

; ON ENTRY, THE HALFWORD IS IN A1

SPROCT:	MOVNI	A0,1		; SPECIAL ENTRY FOR CHANNEL -1
	EXCH	A0,%CHAN(DB)
	PUSHJ	SP,PROCT
	MOVEM	A0,%CHAN(DB)	; RESTORE CHANNEL NUMBERS
	POPJ	SP,0

PROCT:	MOVE	A2,[
	POINT	3,A1,17]	; SET UP BYTE POINTER
	MOVEI	A3,6		; AND BYTE COUNT

PROCT1:	ILDB	A13,A2		; GET NEXT OIT
	ADDI	A13,"0"		; ADD ASCII OFFSET
	JSP	AX,OUCHAR	; AND PRINT IT
	SOJN	A3,PROCT1	; ANY MORE OITS?
	POPJ	SP,0		; NO - EXIT
SUBTTL IO CONTROL BITS

; INBYTE FLAG BITS (LH OF CHANNEL NUMBER)

	BYTLA=400000		; LOOK AHEAD REQUIRED (MUST BE BIT 0)

; OUBYTE FLAG BITS (LH OF CHANNEL NUMBER)

	OPTR=400000		; BREAK OUTPUT

; CHANNEL BITS (RH OF CHANNEL NUMBER)

	LOGCHN=000020		; LOGICAL CHANNEL

; CONTROL AREA OFFSETS

	STRPTR=0		; STRING POINTER
	BYTPTR=1		; BYTE POINTER
	BYTCNT=2		; BYTE COUNT
	BDDOFF=3		; BIDIRECTIONAL DEVICE OUTPUT AREA OFFSET
	DEVNAM=3		; DEVICE NAME
	FILNAM=4		; FILE NAME
	FILEXT=5		; FILE EXTENSION
	FILPRT=6		; FILE PROTECTION
	FILPP=7			; FILE PROJECT-PROGRAMMER NUMBER
	DEVCAL=4		; DEVICE CONTROL AREA LENGTH
	FILCAL=4		; FILE CONTROL AREA LENGTH
SUBTTL INBYTE - BYTE INPUT ROUTINE

; INBYTE - NORMAL ENTRY
; NXTBYT - LOOK AHEAD ENTRY
; NON-SKIP EXIT FOR END-OF-FILE
; OK SKIP EXIT WITH BYTE IN A13
; USES A10,A11,A12,A13

; READ BLOCK FROM PHYSICAL DEVICE ROUTINE

INBLK:	SUBI	A10,(DB)	; DE-RELOCATE CHANNEL NUMBER
	HRLZI	A12,<IN>B53
	DPB	A10,[
	POINT	4,A12,12]	; CONSTRUCT IN UUO
	XCT	A12		; AND READ BLOCK
	JRST	INBLK1		; OK
	MOVE	A12,[
	STATZ	0,740000]
	DPB	A10,[
	POINT	4,A12,12]	; CONSTRUCT STATZ UUO
	XCT	A12		; AND GET STATUS

INBLK2:	IOERR	7,(A10)		; ERROR - REPORT IT
PATCH (17)	; IMPROVE I/O ERROR MESSAGES
	AOS	(SP)		; EOF - SET UP SKIP RETURN
	JRST	INBLK3

INBLK1:	SKIPN	BYTCNT(A11)	; CHECK BYTE COUNT (TTY CROCK!)
	JRST	INBLK2		; NO BYTES

INBLK3:	ADDI	A10,(DB)	; RELOCATE CHANNEL NUMBER
	POPJ	SP,0

INBYTE:	TDZA	A10,A10		; NORMAL ENTRY
NXTBYT:	HRLZI	A10,BYTLA	; LOOK-AHEAD ENTRY
	HLR	A10,%CHAN(DB)	; GET CHANNEL NUMBER
	MOVEI	A13,(A10)	; SAVE FOR ERROR-MESSAGES
PATCH (17)	; IMPROVE I/O ERROR MESSAGES
	ADDI	A10,(DB)	; AND RELOCATE IN DATA BASE
	SKIPN	A11,%IODR(A10)	; CHANNEL DEFINED?
	IOERR	2,(A13)		; NO - COMPLAIN
	TLNE	A11,INEOF	; END-OF-FILE?
	POPJ	SP,0		; YES - TAKE ERROR RETURN
	TLNE	A11,TTYDEV	; TTY DEVICE?
	JRST	INBT6		; YES
	JUMPG	A11,INBT14	; LOGICAL DEVICE?
	TLNE	A11,INOK	; NO - OK TO READ?
	JRST	INBT1		; YES
	TLNN	A11,ININT	; INITED FOR INPUT?
	IOERR	2,(A13)		; NO - FORBID INPUT
	TLNN	A11,DIRDEV	; DIRECTORY DEVICE?
	JRST	.+3		; NO
	TLNN	A11,INFIL	; YES - FILE OPEN
	IOERR	3,(A13)		; NO
PATCH (17)	; IMPROVE I/O ERROR MESSAGES
	PUSHJ	SP,INBLK	; READ FIRST BLOCK
	JRST	INBT16		; NOT EOF
	TLO	A11,INEOF
	MOVEM	A11,%IODR(A10)	; EOF - SET FLAG
	POPJ	SP,0		; AND TAKE ERROR RETURN - A13 = CHAN #

INBT16:	TLO	A11,INOK	; SET INOK FLAG
	MOVEM	A11,%IODR(A10)

INBT1:	JUMPG	A10,INBT4	; LOOK AHEAD?

INBT2:	MOVE	A13,BYTPTR(A11)	; YES - GET BYTE POINTER
	ILDB	A13,A13		; AND GET NEXT BYTE

INBT3:	AOS	(SP)		; OK SKIP RETURN
	POPJ	SP,0

INBT4:	ILDB	A13,BYTPTR(A11)	; NO - GET NEXT BYTE
	SOSN	BYTCNT(A11)	; ANY BYTES LEFT IN BUFFER
	JRST	INBT5		; NO
	TLNN	A11,ABMODE	; YES - ASCII MODE?
	JRST	INBT3		; NO - EXIT

INBT17:	MOVE	A12,BYTPTR(A11)
	ILDB	A12,A12		; YES - LOOK AT NEXT BYTE
	JUMPN	A12,INBT3	; EXIT UNLESS NULL
	IBP	BYTPTR(A11)	; IF SO
	SOSE	BYTCNT(A11)	; SEARCH FOR NON-NULL
	JRST	INBT17

INBT5:	PUSHJ	SP,INBLK	; READ NEXT BLOCK
	JRST	INBT3		; OK

INBT15:	TLO	A11,INEOF	; END-OF-FILE
	MOVEM	A11,%IODR(A10)
	JRST	INBT3		; SET EOF FLAG BUT EXIT OK

INBT6:	TLNE	A11,INOK	; TTY - OK TO READ?
	JRST	INBT12		; YES
	TLNE	A11,TTYTTC	; NO - ON TTCALL?
	JRST	INBT7		; YES
	PUSHJ	SP,INBLK	; NO - READ NEXT BLOCK
	JRST	INBT11		; OK
	MOVEI	A13,CONZ	; EOF - GIVE THE USER A CONTROL-Z
	JRST	INBT15
INBT7:	HRLZI	A12,440700	; READ FROM TTCALL TTY
	HRRI	A12,%IBUFF(DB)	; SET UP INITIAL BYTE POINTER
	MOVEM	A12,%TTY+BYTPTR(DB)
EDIT(634) ; MAKE TTCALL I/O CONSISTENT WITH ALL OTHER DEVICES
	MOVEI	A11,1		; [E634] INITIALIZE BYTE COUNT
INBT8:	TTCALL	4,A13		; [E634] WAIT FOR A BYTE TO BE READ
	IDPB	A13,A12		; [E634] STORE BYTE IN BUFFER
	CAIL	A13,12		; LINE
	CAILE	A13,14		;   TERMINATOR ?
	CAIL	A11,^D80	; [E634] BUFFER FULL?
	JRST	INBT10		; YES (ONE OR THE OTHER) - DONE
PATCH (25)	; IMPROVE TTY I/O
	AOJA	A11,INBT8	; NO - KEEP GOING

INBT10:	MOVEM	A11,%TTY+BYTCNT(DB)
				; STORE BYTE COUNT
	MOVE	A11,%IODR(A10)	; RESTORE CHANNEL FLAGS

INBT11:	TLO	A11,INOK	; SET OK TO READ
	MOVEM	A11,%IODR(A10)

INBT12:	JUMPL	A10,INBT2	; LOOK AHEAD?
	ILDB	A13,BYTPTR(A11)	; NO - GET BYTE
	SOSN	BYTCNT(A11)	; AND DECREMENT BYTE COUNT
	JRST	INBT13		; END OF BUFFER
	MOVE	A12,BYTPTR(A11)
	ILDB	A12,A12		; LOOK AT NEXT BYTE
	JUMPN	A12,INBT3	; AND EXIT UNLESS NULL

INBT13:	TLZ	A11,INOK
	MOVEM	A11,%IODR(A10)	; CLEAR INOK FLAG
	JRST	INBT3		; BUT EXIT OK

INBT14:	JUMPL	A10,INBT2	; LOGICAL DEVICE - LOOK AHEAD?
	ILDB	A13,BYTPTR(A11)	; NO - GET BYTE
	SOSE	BYTCNT(A11)	; ANY MORE?
	JRST	INBT3		; YES
	JRST	INBT15		; NO
SUBTTL OUBYTE - BYTE OUTPUT ROUTINE

; ENTRY WITH BYTE IN A13
; NON-SKIP EXIT FOR END-OF-FILE
; OK SKIP EXIT
; USES A10,A11,A12,A13

; WRITE BLOCK TO PHYSICAL DEVICE ROUTINE

OUTBLK:	SUBI	A10,(DB)	; DE-RELOCATE CHANNEL NUMBER
	HRLZI	A12,<OUT>B53
	DPB	A10,[
	POINT	4,A12,12]	; CONSTRUCT OUT UUO
	XCT	A12		; AND WRITE BLOCK
	JRST	OUBLK1		; OK
	MOVE	A12,[
	STATZ	0,700000]
	DPB	A10,[
	POINT	4,A12,12]	; CONSTRUCT STATZ UUO
	XCT	A12		; AND GET STATUS

OUBLK2:	IOERR	7,(A10)		; ERROR - REPORT IT
PATCH (17)	; IMPROVE I/O ERROR MESSAGES
	AOS	(SP)		; EOF ETC. - SET UP SKIP RETURN
	JRST	OUBLK3

OUBLK1:	SKIPN	BYTCNT(A11)	; CHECK BYTE COUNT (TTY CROCK!)
	JRST	OUBLK2

OUBLK3:	ADDI	A10,(DB)	; RELOCATE IO CHANNEL NUMBER
	POPJ	SP,0

OUBYTE:	TDZA	A10,A10		; NORMAL ENTRY
BRKBYT:	HRLZI	A10,OPTR	; BREAK OUTPUT ENTRY
	HRR	A10,%CHAN(DB)	; GET CHANNEL NUMBER
	MOVEI	A12,(A10)	; SAVEE FOR ERROR MESSAGES
PATCH (17)	; IMPROVE I/O ERROR MESSAGES
	ADDI	A10,(DB)	; AND RELOCATE IN DATA BASE
	SKIPN	A11,%IODR(A10)	; CHANNEL DEFINED?
	IOERR	2,(A12)		; NO - COMPLAIN
	TLNE	A11,OUTEOF	; LOGICAL EOF?
	POPJ	SP,0		; YES - TAKE ERROR RETURN
	JUMPG	A11,OUBT6	; LOGICAL DEVICE?
	TLNE	A11,TTYDEV	; NO - TTY DEVICE?
	ADDI	A11,BDDOFF	; YES - OUTPUT OFFSET
	TLNE	A11,OUTOK	; OK TO WRITE?
	JRST	OUBT2		; YES
	TLNN	A11,OUTINT	; INITED FOR OUTPUT?
	IOERR	2,(A12)		; NO - FORBID OUTPUT
	TLNN	A11,DIRDEV	; DIRECTORY DEVICE?
	JRST	.+3		; NO
	TLNN	A11,OUTFIL	; YES - FILE OPEN?
	IOERR	3,(A12)		; NO
PATCH (17)	; IMPROVE I/O ERROR MESSAGES
	TLNE	A11,TTYTTC	; TTY ON TTCALL?
	PUSHJ	SP,OUBT10	; YES - INITIALIZE (SKIP RETURN)
	PUSHJ	SP,OUTBLK	; DO FIRST OUT
	JRST	OUBT1		; OK
	TLO	A11,OUTEOF	; EOF
	MOVEM	A11,%IODR(A10)	; SET OUTEOF FLAG
	HRRZ	A13,%CHAN(DB)	; GET CHANNEL NUMBER
PATCH (17)	; IMPROVE I/O ERROR MESSAGES
	POPJ	SP,0		; AND GIVE ERROR RETURN - A13 = CHAN #

OUBT1:	TLO	A11,OUTOK	; SET OK TO WRITE
	HLLM	A11,%IODR(A10)

OUBT2:	JUMPL	A10,OUBT4	; BREAK OUTPUT?
	IDPB	A13,BYTPTR(A11)	; NO - PLANT BYTE
	SOSN	BYTCNT(A11)	; DECREMENT BYTE COUNT
	JRST	OUBT4		; EXPIRED

OUBT3:	AOS	(SP)		; OK - SKIP RETURN
	POPJ	SP,0

OUBT4:	TLNE	A11,TTYTTC	; TTY ON TTCALL?
	JRST	OUBT5		; YES
	PUSHJ	SP,OUTBLK	; NO - WRITE BLOCK
	JRST	OUBT3		; OK
	TLO	A11,OUTEOF
	HLLM	A11,%IODR(A10)	; SET OUTEOF FLAG
	JRST	OUBT3

OUBT5:	MOVEI	A13,0
	IDPB	A13,%TTY+BDDOFF+BYTPTR(DB)
				; PLANT NULL TERMINATING BYTE
	TTCALL	3,%OBUFF(DB)	; AND OUTPUT BUFFER

OUBT10:	HRLZI	A12,440700
	HRRI	A12,%OBUFF(DB)	; SET UP INITIAL BYTE POINTER
	MOVEM	A12,%TTY+BDDOFF+BYTPTR(DB)
	MOVEI	A12,122		; AND INITIAL BYTE COUNT
	MOVEM	A12,%TTY+BDDOFF+BYTCNT(DB)
	JRST	OUBT3

OUBT6:	JUMPL	A10,OUBT7	; BREAK OUTPUT?
	IDPB	A13,BYTPTR(A11)	; NO - PLANT BYTE
	SOSE	BYTCNT(A11)	; DECREMENT BYTE COUNT
	JRST	OUBT3		; STILL OK

OUBT9:	TLO	A11,OUTEOF
	MOVEM	A11,%IODR(A10)	; SET EOF FLAG
	JRST	OUBT3

OUBT7:	MOVEI	A13,0		; BREAK OUTPUT

OUBT8:	SOSGE	BYTCNT(A11)
	JRST	OUBT9
	IDPB	A13,BYTPTR(A11)	; FILL UP WITH NULL BYTES
	JRST	OUBT8
SUBTTL READ - READ NUMBER ROUTINE

; ON ENTRY A2 = MODE REQUIRED:

;	0	INTEGER
;	1	REAL
;	2	LONG REAL
;	4	ANY (AS IT COMES)

; ON EXIT THE NUMBER IS IN

;	A0	INTEGER OR REAL
;	A0,A1	LONG REAL

; AND IF THE ENTRY WAS 'ANY', THE TYPE IS IN A2

; FLAGS (LH OF A2):

	DECPNT=400000		; DECIMAL POINT SEEN (MUST BE BIT 0)
	IGNDIG=200000		; IGNORE DIGITS
	MANDIG=100000		; DIGIT SEEN IN MANTISSA
	EXPDIG=040000		; DIGIT SEEN IN EXPONENT
	MANSGN=020000		; MANTISSA SIGN
	EXPSGN=010000		; EXPONENT SIGN
	EXPOVL=004000		; EXPONENT OVERFLOW

; TYPES (LH AND RH OF A2):

	SREAL=1			; REAL
	LREAL=2			; LONG REAL
	ANY=4			; ANY
; SERVICE ROUTINES FOR READ

; SUPPLIES ASCII BYTE IN A13
; LINK IS IN AX

INCHAR:
	TLNE	DB,INDDT	; IF DDT 
	  JRST	DDTIN%		;  LET HIM DO IT.
	PUSHJ	SP,INBYTE	; GET NEXT BYTE
	IOERR	6,(A13)		; END OF FILE - A13 = CHAN #
PATCH (17)	; IMPROVE I/O ERROR MESSAGES
	JRST	(AX)

; IGNORE INVISIBLE CHARACTERS

IGNICH:	JSP	AX,INCHAR	; GET CHARACTER
IGN0:	JUMPE	A13,IGNICH	; IGNORE NULLS
	CAIE	A13," "
	CAIN	A13,"	"
	JRST	IGNICH		; IGNORE SPACES AND TABS
	CAIL	A13,LF
	CAILE	A13,CR
	POPJ	SP,0
	JRST	IGNICH		; IGNORE CR, LF, VT AND FF
READ.:	HLRZ	A1,%CHAN(DB)	; [P32] GET CURRENT INPUT CHANNEL NUMBER
	ADDI	A1,(DB)
	MOVE	A1,%IODR(A1)	; GET CHANNEL ENTRY
	TLNN	A1,ABMODE	; ASCII OR BINARY?
	JRST	READ37		; BINARY
	SETZB	A0,A1		; CLEAR ACCUMULATORS
	SETZB	A3,A4		; CLEAR DECIMAL PLACE COUNT
				; AND BINARY EXPONENT CORRECTION
	HRL	A2,A2		; COPY FLAGS TO LH OF A2
	ANDCMI	A2,ANY		; AND CLEAR ANY FLAG IN RH
	PUSHJ	SP,IGNICH	; IGNORE INVISIBLE CHARACTERS
	CAIN	A13,"+"		; LEADING "+"?
	JRST	READ1		; YES
	CAIE	A13,"-"		; LEADING "-"?
	JRST	READ2		; NO
	TLO	A2,MANSGN	; YES - FLAG MANTISSA NEGATIVE

READ1:	JSP	AX,INCHAR	; GET NEXT CHARACTER

READ2:	CAIL	A13,"0"
	CAIL	A13,"0"+^D10	; IN RANGE 0 - 9?
	JRST	READ10		; NO
	TLNE	A2,IGNDIG	; YES - IGNORE DIGIT?
	JRST	READ8		; YES
	TLO	A2,MANDIG	; NO - FLAG DIGIT SEEN
	HLRZ	AX,READ13(A2)
	JRST	(AX)		; USE APPROPRIATE SEQUENCE

; INTEGER NUMBER SEQUENCE

READ3:	MOVE	A0,A1
	IMULI	A1,^D10		; MULTIPLY BY TEN
	JOV	READ4		; OVERFLOW?
	ADDI	A1,-"0"(A13)	; NO - ADD IN DIGIT
	JOV	READ4		; OVERFLOW NOW?
	JRST	READ1		; NO - OK

READ4:	IORI	A2,LREAL	; CONVERT TO LONG REAL
	MOVE	A1,A0		; RESTORING OLD MANTISSA
	MOVEI	A0,0		; IN LONG FORM
; LONG REAL NUMBER SEQUENCE

READ5:	MOVE	A7,A0
	MOVE	A5,A1
	MULI	A5,^D10		; MULTIPLY LOW ORDER WORD BY TEN
	IMULI	A0,^D10		; MULTIPLY HIGH ORDER WORD BY TEN
	EXCH	A6,A1		; REPLACE OLD LOW ORDER WORD BY NEW ONE,
				; AND SAVE OLD ONE
	ADD	A0,A5		; ADD CARRY INTO HIGH ORDER WORD
	TLO	A1,400000	; FLAG LOW ORDER WORD
	ADDI	A1,-"0"(A13)	; AND ADD IN DIGIT
	TLZN	A1,400000	; AND IF CARRY OCCURED
	ADDI	A0,1		; INCREMENT HIGH ORDER WORD
	TLNE	A0,777000	; NUMBER TOO LARGE?
	JRST	READ7		; YES

READ6:	JUMPGE	A2,READ1	; NO - DECIMAL POINT SEEN?
	SOJA	A3,READ1	; YES - INCREMENT DECIMAL PLACE COUNT

READ7:	TLO	A2,IGNDIG	; SET IGNORE DIGIT FLAG
	MOVE	A0,A7
	MOVE	A1,A6		; AND RESTORE OLD MANTISSA
	CAIGE	A13,"5"		; DIGIT >= 5?
	JRST	READ8		; NO
	TLO	A1,400000	; YES - FLAG LOW ORDER WORD
	ADDI	A1,1		; AND INCREMENT IT
	TLZN	A1,400000	; AND IF CARRY OCCURED
	ADDI	A0,1		; INCREMENT HIGH ORDER WORD
	TLNN	A0,777000	; TOO BIG NOW?
	JRST	READ8		; NO
	ASHC	A0,-1		; YES - SHIFT IT DOWN
	ADDI	A4,1		; AND INCREMENT BINARY EXPONENT CORRECTION

READ8:	JUMPL	A2,READ1	; DECIMAL POINT SEEN?
	AOJA	A3,READ1	; NO - DECREMENT DECIMAL PLACE COUNT
; REAL NUMBER SEQUENCE

READ9:	MOVE	A0,A1
	IMULI	A1,^D10		; MULTIPLY BY TEN
	ADDI	A1,-"0"(A13)	; AND ADD IN DIGIT
	TLNN	A1,777000	; TOO LARGE?
	JRST	READ6		; NO
	TLO	A2,IGNDIG	; YES - SET IGNORE DIGIT FLAG
	MOVE	A1,A0		; AND RESTORE OLD MANTISSA
	CAIGE	A13,"5"		; DIGIT >= 5?
	JRST	READ8		; NO
	ADDI	A1,1		; YES - INCREMENT MANTISSA
	TLNN	A1,777000	; TOO BIG NOW?
	JRST	READ8		; NO
	ASH	A1,-1		; YES - SHIFT IT DOWN
	AOJA	A4,READ8	; AND INCREMENT BINARY EXPONENT CORRECTION

READ10:	CAIE	A13,"."		; DECIMAL POINT?
	JRST	READ12		; NO
	TLOE	A2,DECPNT	; ALREADY FOUND?
	JRST	READ21		; YES - GO AND COMPLAIN
	MOVEI	AX,READ1	; SET RETURN LINK

; SMALL SUBROUTINE FOR CONVERTING INTEGER TO REAL OR LONG REAL

READ11:	TRNE	A2,SREAL!LREAL	; INTEGER TYPE?
	JRST	(AX)		; NO - RETURN
	TLNN	A1,777000	; LONG MANTISSA?
	TROA	A2,SREAL	; NO - SET REAL TYPE
	IORI	A2,LREAL	; YES - SET LONG REAL TYPE
	MOVEI	A0,0		; CLEAR HIGH ORDER WORD
	JRST	(AX)		; AND EXIT

; END OF MANTISSA SEQUENCE

READ12:	CAIE	A13,"&"		; IS IT "&"
	CAIN	A13,"@"		; OR "@"?
	JRST	READ15		; YES
	CAIE	A13,"E"		; IS IT "E" (FOR FORTRAN'S SAKE)
	CAIN	A13,"D"		; OR "D"?
	JRST	READ16		; YES
	CAIE	A13,"+"		; CHECK FOR
	CAIN	A13,"-"		; ILLEGAL TERMINATORS
	JRST	READ21		; AND COMPLAIN IF FOUND
	TLNN	A2,MANDIG	; WAS THERE A MANTISSA?
	JRST	READ21		; NO - COMPLAIN
	MOVE	A5,A0
	MOVE	A6,A1		; TAKE COPY OF MANTISSA
	HRRZ	AX,READ13(A2)
	JRST	(AX)		; AND USE APPROPRIATE SEQUENCE
READ13:	XWD	READ3,READ14	; SEQUENCE DISPATCH TABLE
	XWD	READ9,READ23
	XWD	READ5,READ27

; INTEGER TERMINAL SEQUENCE

READ14:	MOVE	A0,A1
	TLNE	A2,MANSGN	; SHOULD IT BE NEGATIVE?
	MOVN	A0,A0		; YES - NEGATE
	JRST	READ35		; PROCEDE TO EXIT SEQUENCE

; EXPONENT SEQUENCE

READ15:	JSP	AX,INCHAR	; "&" OR "@" FOUND
	CAIE	A13,"&"
	CAIN	A13,"@"		; ANOTHER ONE?
	JRST	READ16		; YES
	PUSHJ	SP,IGN0		; IGNORE ANY INVISIBLES
	JRST	.+2

READ16:	PUSHJ	SP,IGNICH	; IGNORE INVISIBLES
	JSP	AX,READ11	; FIX MANTISSA UP
	TLNN	A2,MANDIG	; DOES MANTISSA HAVE DIGITS?
	MOVEI	A1,1		; NO - FORCE A ONE
	LRLOAD	A5,A0		; SAVE MANTISSA
	SETZB	A0,A1		; CLEAR ACCUMULATORS
	CAIN	A13,"+"		; "+"?
	JRST	READ18		; YES
	CAIE	A13,"-"		; "-"?
	JRST	READ19		; NO
	TLOA	A2,EXPSGN	; YES - FLAG EXPONENT NEGATIVE (AND SKIP!)

READ17:	TLO	A2,EXPOVL	; FLAG EXPONENT OVERFLOW

READ18:	JSP	AX,INCHAR	; GET NEXT CHARACTER

READ19:	CAIL	A13,"0"
	CAIL	A13,"0"+^D10	; IN RANGE 0 - 9?
	JRST	READ20		; NO
	TLNE	A2,EXPOVL	; YES - EXPONENT OVERFLOW SET?
	JRST	INCHAR		; YES - IGNORE DIGIT
	TLO	A2,EXPDIG	; FLAG DIGIT SEEN
	MULI	A0,^D10		; MULTIPLY BY TEN
	JUMPN	A0,READ17	; OVERFLOWED?
	EXCH	A0,A1		; NO
	TLO	A0,400000	; FLAG EXPONENT
	ADDI	A0,-"0"(A13)	; AND ADD IN DIGIT
	TLZN	A0,400000	; DID IT OVERFLOW?
	JRST	READ17		; YES
	JRST	READ18		; NO - CARRY ON
READ20:	CAIE	A13,"+"		; END OF EXPONENT
	CAIN	A13,"-"		; TEST FOR ILLEGAL TERMINATORS
	JRST	READ21
	CAIE	A13,"&"
	CAIN	A13,"@"
	JRST	READ21
	CAIE	A13,"D"
	CAIN	A13,"E"
	JRST	READ21
	CAIE	A13,"."
	TLNN	A2,EXPDIG	; AND CHECK DIGITS SEEN
	JRST	READ21		; COMPLAIN - BAD CHARS
PATCH (17)	; IMPROVE I/O ERROR MESSAGES
	TLNE	A2,EXPOVL	; EXPONENT OVERFLOW?
	JRST	READ22		; YES - COMPLAIN
	TLNN	A2,EXPSGN	; SHOULD EXPONENT BE NEGATIVE?
	MOVN	A0,A0		; NO - FORM NEGATIVE EXPONENT
	SUB	A3,A0		; TRUE NEGATIVE EXPONENT
	CAILE	A3,^D38		; TOO LARGE?
	JRST	READ22		; YES - GIVE OVERFLOW
	TRNN	A2,LREAL	; LONG REAL TYPE

READ23:	TLNE	A2,LREAL	; OR LONG REAL RESULT REQUIRED?
	JRST	READ27		; YES

; REAL TERMINAL SEQUENCE

	MOVE	A0,A6		; NO - ONLY REAL
	JUMPE	A0,READ35	; ESCAPE FOR ZERO MANTISSA
	TLO	A0,233000
	FADRI	A0,000000	; STANDARDIZE MANTISSA
	FSC	A0,(A4)		; AND ALLOW FOR BINARY EXPONENT CORRECTION
	TLNE	A2,MANSGN	; SHOULD MANTISSA BE NEGATIVE?
	MOVN	A0,A0		; YES - NEGATE IT
	JUMPE	A3,READ35	; ANY EXPONENT?
	MOVM	A4,A3		; EXPONENT MAGNITUDE

READ24:	CAIG	A4,^D38		; EXPONENT VERY SMALL OR LARGE?
	JRST	READ25		; NO
	JUMPGE	A3,READ22	; IF LARGE - YOU LOSE!
	FDVR	A0,STEN38	; YES - DIVIDE BY 1.0&38
	JUMPE	A0,READ35	; AND EXIT IF UNDERFLOWED
	SUBI	A4,^D38		; OTHERWISE CUT DOWN EXPONENT
	JRST	READ24		; AND TRY AGAIN

READ25:	JUMPL	A3,READ26	; POSITIVE EXPONENT?
	FMPR	A0,STEN(A4)	; YES - MULTIPLY
	JFOV	READ22		; OVERFLOWED?
	JRST	READ35		; NO - EXIT

READ26:	FDVR	A0,STEN(A4)	; DIVIDE
	JRST	READ35		; AND EXIT

PATCH (17)	; IMPROVE I/O ERROR MESSAGES
READ21:	HLRZ	A10,%CHAN(DB)
	IOERR	10,(A10)

READ22:	HLRZ	A10,%CHAN(DB)
	IOERR	11,(A10)
; LONG REAL TERMINAL SEQUENCE

READ27:	JUMPN	A5,READ28
				; HIGH ORDER WORD = 0?
	JUMPE	A6,READ34	; YES - LOW ORDER WORD = 0

READ28:	TLNE	A5,000400	; NO - BIT 9 SET?
	JRST	READ29		; YES - OK
	ASHC	A5,1		; NO - SHIFT UP
	SOJA	A4,READ28	; AND INCREMENT BINARY EXPONENT CORRECTION

READ29:	ADDI	A4,276		; CALCULATE CORRECT EXPONENT
	DPB	A4,[
	POINT	9,A5,8]		; AND FORM HIGH WORD
	JUMPL	DB,RED30I	; JUMP IF KI10
	LSH	A6,-10		; CLEAR SPACE FOR LOW ORDER EXPONENT
	JUMPE	A6,READ30	; LOW MANTISSA ZERO?
	SUBI	A4,33		; LOW WORD EXPONENT (KA10)
	JUMPGE	A4,.+2		; TOO LOW?
	TDZA	A6,A6		; YES - CLEAR LOW WORD
	DPB	A4,[
	POINT	9,A6,8]		; NO - FORM LOW WORD

READ30:	TLNE	A2,MANSGN	; SHOULD IT BE NEGATIVE?
	DFN	A5,A6		; YES - NEGATE IT
	JRST	.+3
RED30I:	TLNE	A2,MANSGN	; SHOULD IT BE NEGATIVE (KI10)?
	DMOVN	A5,A5		; YES - NEGATE IT
	JUMPE	A3,READ34	; ANY EXPONENT?
	MOVM	A4,A3		; EXPONENT MAGNITUDE

READ31:	CAIG	A4,^D38		; EXPONENT VERY SMALL OR LARGE
	JRST	READ32		; NO
	JUMPGE	A3,READ22	; IF LARGE - YOU LOSE!
	MOVEI	A10,^D38
	JSP	AX,DFDVR	; YES - DIVIDE BY 1.0&&38
	JUMPE	A5,READ34	; EXIT IF UNDERFLOWED
	SUBI	A4,^D38		; OTHERWISE CUT DOWN EXPONENT
	JRST	READ31		; AND TRY AGAIN

READ32:	MOVE	A10,A4
	JUMPL	A3,READ33	; POSITIVE EXPONENT?
	JSP	AX,DFMPR	; YES - MULTIPLY
	JRST	READ22		; OVERFLOW?
	JRST	READ34		; NO - EXIT

READ33:	JSP	AX,DFDVR	; DIVIDE
	JRST	READ34

READ34:	LRLOAD	A0,A5
; EXIT SEQUENCE

READ35:	LDB	A3,[
	POINT	3,A2,17]
	ANDI	A2,-1		; DATA TYPE
	POP	SP,AX		; MOVE LINK TO AX
	XCT	READ36(A2)

READ36:	JRST	(AX)		; INTEGER NUMBER
	JUMPE	A3,RI		; REAL NUMBER
	JUMPE	A3,LRI		; LONG REAL NUMBER

; BINARY READ

READ37:	PUSHJ	SP,INBYTE	; READ NEXT WORD
	IOERR	6,(A13)		; EOF - CHANNEL # IN A13
PATCH (17)	; IMPROVE I/O ERROR MESSAGES
	MOVE	A0,A13
	CAIE	A2,2		; LONG REAL?
	POPJ	SP,0		; NO
	PUSHJ	SP,INBYTE	; YES - READ SECOND WORD
	IOERR	6,(A13)		; EOF - CHANNEL # IN A13
	MOVE	A1,A13
	POPJ	SP,0
SUBTTL PRINT - PRINT NUMBER ROUTINE

; ON ENTRY THE NUMBER IS IN

;	A0	INTEGER, REAL
;	A0,A1	LONG REAL

; A2 = TYPE OF VARIABLE:

;	0	INTEGER
;	1	REAL
;	2	LONG REAL

; A3,A4 = MODE OF PRINTING REQUIRED:

;	A3	NUMBER OF DIGITS BEFORE POINT (M)
;	A4	NUMBER OF DIGITS AFTER POINT (N)

;	(M,0)	INTEGER MODE
;	(M,N)	FIXED POINT MODE
;	(0,N)	FLOATING POINT MODE
;	(0,0)	'STANDARD' MODE

; SERVICE ROUTINES FOR PRINT

; PRINTS ASCII BYTE IN A13
; LINK IS IN AX

PRIN1:	SKIPA	A13,["."]	; SPECIAL ENTRY FOR DECIMAL POINT
SPACE%:	MOVEI	A13," "		; SPECIAL ENTRY FOR SPACE

OUCHAR:	PUSHJ	SP,OUBYTE	; OUTPUT BYTE
	IOERR	6,(A13)		; END OF FILE - CHAN # IN A13
PATCH (17)	; IMPROVE I/O ERROR MESSAGES
	JRST	(AX)

BRKCHR:	PUSHJ	SP,BRKBYT	; BREAKOUTPUT
	IOERR	6,(A13)		; END OF FILE
	JRST	(AX)

; PRINT SIGN ROUTINE

; PRINTS SPACE OR "-" ACCORDING AS NUMSGN IN A2 IS UNSET OR SET
; LINK IS IN AX

PRIN3:	MOVEI	A13," "
	TLNE	A2,NUMSGN	;
	MOVEI	A13,"-"		; SELECT SIGN
	TLZN	A2,NUMSGN	; IF NEGATIVE
	TLZN	A2,NOSIGN	; OR NOT NOSIGN
	AOJA	A3,OUCHAR	; THEN PRINT IT
	JRST	(AX)		; ELSE RETURN.

; OUTPUT DIGIT ROUTINE

; GETS DIGIT FROM DIGIT STACK AND PRINTS IT
; LINK IS IN AX

PRIN4:	MOVEI	A13,"0"
	TLNE	A2,DIGEXH	; DIGITS EXHAUSTED?
	JRST	OUCHAR		; YES
	ADD	A13,(A7)	; GET NEXT DIGIT
	SOJN	A6,.+2		; TOTAL COUNT EXPIRED?
	TLO	A2,DIGEXH	; YES - FLAG DIGITS EXHAUSTED
	AOJA	A7,OUCHAR	; MOVE POINTER AND PRINT DIGIT
PRINT.:	HRRZ	A5,%CHAN(DB)	; [P32] GET OUTPUT CHANNEL NUMBER
	ADDI	A5,(DB)
	MOVE	A5,%IODR(A5)	; AND GET CHANNEL ENTRY
	TLNN	A5,ABMODE	; ASCII OR BINARY?
	JRST	PRIN54		; BINARY
	JUMPN	A3,PRIN13	; ANY DIGITS BEFORE POINT?
	JUMPN	A4,PRIN13	; OR AFTER IT?
	XCT	PRIN5(A2)	; NO - 'STANDARD' MODE
	JRST	PRIN13

PRIN5:	MOVEI	A3,INTDIG	; STANDARD INTEGER FORMAT
	MOVEI	A4,SRDIG-2	; STANDARD REAL FORMAT
	MOVEI	A4,^D15		; STANDARD LONG REAL FORMAT - LESS 2 FOR BOTH

; INTEGER PRINT ROUTINE

DPRNT%:	PUSH	SP,A13		; SAVE DEBUGGER'S FLAG REGISTER.
	HRLZI	A2,NOSIGN	; INTEGER SPECIAL PRINT FOR DEBUGGER.
	MOVEI	A4,0
	MOVEI	A3,1
	PUSHJ	SP,PRIN6
	POP	SP,A13		; RESTORE DEBUGGER'S FLAGS.
	POPJ	SP,

IPRNT%:
IPRINT:	MOVEI	A3,1		; SPECIAL INTEGER PRINT
	SETZB	A2,A4

PRIN6:	JUMPGE	A0,PRIN7	; NEGATIVE?
	TLO	A2,NUMSGN	; YES - SET SIGN FLAG
	MOVN	A0,A0		; AND NEGATE
	JOV	[
	TLO	A2,INTOVL	; OVERFLOWED - SET FLAG
	MOVE	A0,[
	^D24359738368]		; AND LOAD 2^35 - 10^10
	JRST	PRIN7]

PRIN7:	MOVEI	A5,1		; SET UP DIGIT COUNT

PRIN8:	IDIVI	A0,^D10		; AND GENERATE DIGITS IN REVERSE
	PUSH	SP,A1		; AND SAVE THEM ON THE STACK
	JUMPE	A0,PRIN9	; ANY LEFT?
	AOJA	A5,PRIN8	; YES - COUNT AND CARRY ON

PRIN9:	TLNE	A2,INTOVL	; DID OVERFLOW OCCUR?
	AOS	(SP)		; YES - PRODUCE 2^35!!!

PRIN10:	CAML	A5,A3		; ANY LEADING SPACES?
	JRST	PRIN11		; NO
	JSP	AX,SPACE%	; YES - PRINT ONE
	SOJA	A3,PRIN10	; AND DECREASE M UNTIL FINISHED

PRIN11:	MOVEI	A3,(A5)		; TELL WORLD (DEBUGGER) HOW MUCH WE PRINTED.
	JSP	AX,PRIN3	; PRINT SIGN
PRIN12:	POP	SP,A13		; POP UP DIGIT
	ADDI	A13,"0"		; ADD ASCII OFFSET
	JSP	AX,OUCHAR	; AND PRINT IT
	SOJN	A5,PRIN12	; REPEAT UNTIL FINISHED
	POPJ	SP,0		; EXIT FROM ROUTINE

PRIN13:	MOVEI	A13,0		; CLEAR EXPONENT
	JUMPG	A2,PRIN17	; JUMP UNLESS INTEGER NUMBER
	JUMPE	A4,PRIN6	; USE PRIN6 IF INTEGER MODE
	JUMPE	A3,PRIN14	; JUMP IF FLOATING POINT MODE
	PUSHJ	SP,PRIN6	; FIXED POINT MODE - USE PRIN6
	JSP	AX,PRIN1	; PRINT DECIMAL POINT
	MOVEI	A13,"0"
	SOJGE	A4,OUCHAR	; AND N ZEROS
	POPJ	SP,0

PRIN14:	JUMPGE	A0,PRIN15	; FLOATING POINT MODE - NEGATIVE?
	TLO	A2,NUMSGN	; YES - SET SIGN FLAG
	MOVN	A0,A0		; AND NEGATE
	JOV	[
	MOVSI	A0,244400	; OVERFLOW - FORM 2.0^35
	JRST	PRIN18]

PRIN15:	CAML	A0,[
	^D100000000]		; 9 OR MORE DIGITS?
	JRST	PRIN16		; YES
	CIR			; NO - CONVERT TO REAL
	JRST	PRIN18

PRIN16:	CILR			; CONVERT TO LONG REAL
	TLO	A2,LNGMAN	; AND FLAG LONG MANTISSA
	JRST	PRIN28

PRIN17:	SOJG	A2,PRIN26	; JUMP IF LONG REAL NUMBER
; REAL STANDARDIZATION SEQUENCE

	FADRI	A0,000000	; ENSURE STANDARDIZED
	JFOV	[
	MOVEI	A0,0		; BAD NUMBER - ZERO IT
	JRST	PRIN22]
	JUMPGE	A0,PRIN18	; NUMBER NEGATIVE?
	TLO	A2,NUMSGN	; YES - SET SIGN FLAG
	MOVN	A0,A0		; AND NEGATE IT

PRIN18:	JUMPE	A0,PRIN22	; ESCAPE IF ZERO
	MOVE	A5,A0
	CAML	A0,STEN		; NUMBER < 1.0?
	JRST	PRIN19		; NO
	TLO	A2,NUMRNG	; YES - SET RANGE FLAG
	CAML	A0,STENM1	; NUMBER < 0.1?
	JRST	PRIN25		; NO - IN RANGE
	CAMGE	A0,[
	XWD	002663,437347]	; VERY SMALL NUMBER?
	JRST	PRIN23		; YES - SAVE OVERFLOWS!
	MOVSI	A5,(1.0)
	FDVR	A5,A0		; TAKE RECIPROCAL

PRIN19:	HRLZI	A13,-^D38	; LOAD COUNTER

PRIN20:	CAML	A5,STEN1(A13)	; COMPARE WITH TABLE
	AOBJN	A13,PRIN20	; UNTIL LARGER ENTRY FOUND
	JUMPL	A13,PRIN21	; ENTRY FOUND?
	JUMPL	A2,PRIN24	; NO - LOW RANGE?
	FDVR	A0,STEN38	; NO
	FDVR	A0,STEN1	; - DIVIDE BY 1.0&39
	AOJA	A13,PRIN25

PRIN21:	ANDI	A13,-1		; ENTRY FOUND - CLEAR OUT COUNT
	JUMPL	A2,PRIN24	; LOW RANGE?
	FDVR	A0,STEN1(A13)	; NO - DIVIDE TO BRING INTO RANGE

PRIN22:	AOJA	A13,PRIN25	; AND CORRECT EXPONENT

PRIN23:	MOVEI	A13,^D38	; DEAL WITH OVERFLOW IN RECIPROCAL

PRIN24:	FMPR	A0,STEN(A13)	; LOW RANGE - MULTIPLY TO BRING INTO RANGE
	MOVN	A13,A13		; NEGATIVE EXPONENT
PRIN25:	MOVEI	A5,SRDIG	; SET MAXIMUM SINGLE PRECISION LENGTH
	JUMPE	A0,PRIN36	; SAVE TIME FOR ZERO
	LDB	A7,[
	POINT	9,A0,8]		; EXTRACT EXPONENT
	TLZ	A0,377000	; AND CLEAR IT OUT
	ASH	A0,-170(A7)	; AND CONVERT TO FRACTIONAL FORM
	JOV	[
	MOVE	A0,[
	XWD	031463,146315]
	AOJA	A13,PRIN36]	; CORRECT IF OVERFLOWED
	JRST	PRIN36
; LONG REAL STANDARDIZATION SEQUENCE

PRIN26:	JUMPL	DB,PRN26I	; JUMP IF KI10
	FADL	A0,A1
	JUMPGE	A0,PRIN27	; LONG REAL - NUMBER NEGATIVE?
	TLO	A2,NUMSGN	; YES - SET SIGN FLAG
	DFN	A0,A1
	JRST	PRIN27

PRN26I:	DFAD	A0,LTENA	; LTENA IS DOUBLE ZERO
	JUMPGE	A0,PRIN27
	TLO	A2,NUMSGN
	DMOVN	A0,A0

PRIN27:	TLO	A2,LNGEXP	; FLAG LONG EXPONENT

PRIN28:	LDB	A5,[
	POINT	9,A0,8]
	CAIGE	A5,33		; IF SMALL HIGH WORD AND
	JUMPE	A1,PRIN18	; IF LOW ORDER WORD IS ZERO USE SINGLE PRECISION
	TLO	A2,LNGMAN	; FLAG LONG MANTISSA
	LRLOAD	A5,A0
	CAMN	A0,HTEN
	CAMGE	A1,LTENA	; SAME IN BOTH CASES
	CAML	A0,HTEN		; NUMBER < 1.0?
	JRST	PRIN30		; NO
	TLO	A2,NUMRNG	; YES - SET RANGE FLAG
	MOVE	A10,LTENI-1
	JUMPL	DB,.+2		; IF KA10
	MOVE	A10,LTENA-1	;  GET KA10 VERSION
	CAMN	A0,HTENM1
	CAMGE	A1,A10
	CAML	A0,HTENM1	; NUMBER < 0.1?
	JRST	PRIN35		; NO - IN RANGE
	CAMGE	A5,[
	XWD	002663,437347]	; VERY SMALL NUMBER?
	JRST	PRIN33		; YES - SAVE OVERFLOWS!
	MOVSI	A0,(1.0)
	FDVR	A0,A5		; TAKE SINGLE PRECISION RECIPROCAL

PRIN30:	HRLZI	A13,-^D38	; LOAD COUNTER

PRIN31:	CAML	A0,HTEN1(A13)	; COMPARE WITH TABLE
	AOBJN	A13,PRIN31	; UNTIL LARGER ENTRY FOUND
	JUMPL	A13,PRIN32	; ENTRY FOUND?
	JUMPL	A2,PRIN34	; NO - LOW RANGE?
	MOVEI	A10,^D38	; NO
	JSP	AX,DFDVR
	MOVEI	A10,^D1
	JSP	AX,DFDVR	; DIVIDE BY 1.0&&39
	AOJA	A13,PRIN35
PRIN32:	ANDI	A13,-1		; ENTRY FOUND - CLEAR OUT COUNT
	JUMPL	A2,PRIN34	; LOW RANGE?
	MOVEI	A10,1(A13)
	JSP	AX,DFDVR	; NO - DIVIDE TO BRING INTO RANGE
	AOJA	A13,PRIN35	; AND CORRECT EXPONENT

PRIN33:	MOVEI	A13,^D38	; DEAL WITH OVERFLOW IN RECIPROCAL

PRIN34:	MOVE	A10,A13		; LOW RANGE
	JSP	AX,DFMPR	; MULTIPLY TO BRING INTO RANGE
	HALT	.		; OVERFLOW CANNOT OCCUR!
	MOVN	A13,A13		; NEGATIVE EXPONENT

PRIN35:	LRLOAD	A0,A5		; RESTORE RESULT TO A0,A1
	MOVEI	A5,^D19		; SET MAXIMUM DOUBLE PRECISION LENGTH - KI10
	JUMPL	DB,.+3		; SKIP IF KI10
	SUBI	A5,3		; ADJUST FORMAT FOR KA10
	LSH	A1,10		; IF KA10, LOSE LOW ORDER EXPONENT
	LDB	A7,[
	POINT	9,A0,8]		; EXTRACT EXPONENT
	TLZ	A0,377000	; AND CLEAR IT OUT
	ASHC	A0,-170(A7)	; AND CONVERT TO FRACTIONAL FORM
	JOV	[
	MOVE	A0,[
	XWD	031463,146314]
	MOVE	A1,[
	XWD	314631,463146]
	AOJA	A13,PRIN36]	; CORRECT IF OVERFLOWED
; ROUNDING AND DIGIT GENERATION SEQUENCE

PRIN36:	MOVEI	A6,1(A4)	; NUMBER OF DIGITS TO BE PRINTED
	JUMPE	A3,PRIN37	; = N+1 IF FLOATING POINT FORMAT,
	ADD	A6,A13
	SOJGE	A6,PRIN37
	MOVEI	A6,0		; MAX (N+E, 0) IF FIXED POINT FORMAT

PRIN37:	CAILE	A6,(A5)		; BUT NEVER MORE THAN
	MOVEI	A6,(A5)		; MAXIMUM PERMITTED
	MOVE	A5,SP		; MARK BOTTOM OF DIGIT STACK
	PUSH	SP,LTENA	; AND ALLOW FOR POSSIBLE OVERFLOW
	MOVEI	A7,1(A6)	; NUMBER OF DIGITS TO BE PRODUCED
	TLNE	A2,LNGMAN	; LONG MANTISSA?
	JRST	PRIN39		; YES

PRIN38:	MULI	A0,^D10		; MULTIPLY BY 10
	PUSH	SP,A0		; STORE DIGIT ON DIGIT STACK
	MOVE	A0,A1		; AND SET UP NEW FRACTION
	SOJN	A7,PRIN38
	JRST	PRIN40

PRIN39:	MOVE	A10,A1
	MULI	A10,^D10	; MULTIPLY LOW ORDER WORD BY 10
	MOVE	A1,A11		; AND RESET LOW ORDER FRACTION
	MOVE	A11,A0
	MULI	A11,^D10	; MULTIPLY HIGH ORDER WORD BY 10
	TLO	A12,400000	; FLAG LOW ORDER SIGN BIT OF RESULT
	ADD	A12,A10		; AND ADD CARRY FROM LOW ORDER MULTIPLY
	TLZN	A12,400000	; AND IF IT OVERFLOWS
	ADDI	A11,1		; INCREMENT HIGH ORDER CARRY
	MOVE	A0,A12		; RESET HIGH ORDER FRACTION
	PUSH	SP,A11		; STORE DIGIT ON DIGIT STACK
	SOJN	A7,PRIN39

PRIN40:	MOVEI	A10,-1(SP)	; ADDRESS OF LAST DIGIT TO BE PRINTED
	MOVE	A12,1(A10)
	CAIGE	A12,5		; WOULD ROUNDING GENERATE CARRY?
	JRST	PRIN42		; NO

PRIN41:	AOS	A12,(A10)	; INCREMENT DIGIT
	CAIE	A12,^D10	; ANY CARRY?
	JRST	PRIN42		; NO
	SETZM	(A10)		; YES - REPLACE BY ZERO
	SOJA	A10,PRIN41	; KEEP GOING
PRIN42:	MOVEI	A7,1(A5)	; ADDRESS OF OVERFLOW DIGIT
	SKIPE	(A7)		; OVERFLOW OCCURRED?
	AOJA	A13,PRIN43	; YES - INCREMENT EXPONENT
	ADDI	A7,1		; NO - MOVE TO FIRST DIGIT

PRIN43:	MOVE	A0,A13		; TRANSFER EXPONENT TO SAFE PLACE
	JUMPE	A3,PRIN50	; JUMP IF FLOATING POINT MODE
; FIXED POINT PRINTING SEQUENCE

	JUMPG	A0,.+2
	JUMPL	A2,PRIN48	; JUMP IF NUMBER < 1.0
	MOVEI	AX,PRIN44

PRIN44:	CAMGE	A0,A3		; LEADING SPACES REQUIRED?
	SOJA	A3,SPACE%
	JSP	AX,PRIN3	; PRINT SIGN
	JSP	AX,PRIN4	; OUTPUT INTEGRAL DIGIT
	SOJN	A0,PRIN4	; RETURN IF MORE DIGITS
	JUMPE	A4,PRIN46	; ANY FRACTION?
	JSP	AX,PRIN1	; YES - PRINT DECIMAL POINT

PRIN45:	JSP	AX,PRIN4	; OUTPUT FRACTIONAL DIGIT
	SOJN	A4,PRIN4	; RETURN IF MORE DIGITS

PRIN46:	MOVE	SP,A5		; RESTORE STACK
	POPJ	SP,0		; EXIT

PRIN47:	JSP	AX,SPACE%	; PRINT LEADING SPACES

PRIN48:	SOJN	A3,PRIN47	; ANY LEFT?
	JSP	AX,PRIN3	; NO - PRINT SIGN
	MOVEI	A13,"0"
	JSP	AX,OUCHAR	; OUTPUT A ZERO
	JUMPE	A4,PRIN46	; FRACTION TO BE PRINTED?
	JSP	AX,PRIN1	; YES - OUTPUT DECIMAL POINT

PRIN49:	AOJG	A0,PRIN45	; OUTPUT ZEROS IF REQUIRED
	MOVEI	A13,"0"
	JSP	AX,OUCHAR
	SOJN	A4,PRIN49
	JRST	PRIN46		; NO DIGITS REQUIRED!
; FLOATING POINT PRINTING SEQUENCE

PRIN50:	JSP	AX,PRIN3	; FLOATING POINT MODE - OUTPUT SIGN
	JSP	AX,PRIN4	; OUTPUT FIRST DIGIT
	JSP	AX,PRIN1	; AND DECIMAL POINT
	JSP	AX,PRIN4	; OUTPUT FRACTIONAL DIGIT
	SOJN	A4,PRIN4	; RETURN IF MORE DIGITS
	SOJE	A0,PRIN52	; CALCULATE EXPONENT - ESCAPE IF ZERO

PRIN51:	MOVEI	A13,"&"
	JSP	AX,OUCHAR	; OUTPUT "&"
	TLZE	A2,LNGEXP
	JRST	PRIN51		; AND SECOND ONE IF LONG REAL NUMBER
	MOVEI	A3,2		; AND SET DIGIT COUNT
	MOVE	SP,A5		; RESTORE STACK POINTER
	JRST	PRIN6		; AND LET PRIN6 DO THE WORK

PRIN52:	MOVEI	A3,4		; SUPPRESS ZERO EXPONENT
	TLZE	A2,LNGEXP
	MOVEI	A3,5		; TAKING ACCOUNT OF LONG REAL
	MOVEI	AX,PRIN53

PRIN53:	SOJGE	A3,SPACE%	; AND OUTPUT SPACES
	JRST	PRIN46

; BINARY READ

PRIN54:	MOVE	A13,A0
	JSP	AX,OUCHAR	; OUTPUT FIRST WORD
	CAIE	A2,2		; LONG REAL?
	POPJ	SP,0		; NO
	MOVE	A13,A1
	JSP	AX,OUCHAR	; YES - OUTPUT SECOND WORD
	POPJ	SP,0
SUBTTL KA10/KI10 DOUBLE PRECISION MULTIPLY/DIVIDE

; ON ENTRY:
; THE LEFT HAND OPERAND IS IN A5,A6
; THE RIGHT HAND OPERAND IS IN HTEN AND LTEN, INDEXED BY A10
; THE LINK IS IN AX
; ON EXIT:
; THE RESULT IS IN A5,A6
; FOR MULTIPLY ONLY:
; ERROR RETURN IF OVERFLOW
; OK SKIP RETURN

DFMPR:	JUMPL	DB,DFMPRI	; JUMP IF KI10
	MOVE	A7,A5		; COPY HIGH WORD OF LH OPERAND
	FMPR	A7,LTENA(A10)	; FORM ONE CROSS PRODUCT IN A7
	JFOVO	(AX)		; SPECIAL UNDERFLOW HANDLING
	FMPR	A6,HTEN(A10)	; FORM OTHER CROSS PRODUCT IN A6
	JFOVO	(AX)		; SPECIAL UNDERFLOW HANDLING
	UFA	A6,A7		; ADD CROSS PRODUCTS IN A7
	FMPL	A5,HTEN(A10)	; FORM HIGH ORDER PRODUCT IN A5,A6
	JFOV	(AX)
	UFA	A6,A7		; ADD CROSS PRODUCTS SUM TO LOW PART
	FADL	A5,A7		; ADD TOGETHER LOW AND HIGH PARTS OF RESULT
	JRST	1(AX)

DFDVR:	JUMPL	DB,DFDVRI	; JUMP IF KI10
	FDVL	A5,HTEN(A10)	; GET HIGH PART OF QUOTIENT
	MOVN	A7,A5		; AND NEGATE IT
	FMPR	A7,LTENA(A10)	; MULTIPLY BY LOW PART OF DIVISOR
	JFOVO	.		; SPECIAL UNDERFLOW HANDLING
				; (OVERFLOW IMPOSSIBLE!)
	UFA	A6,A7		; ADD REMAINDER
	FDVR	A7,HTEN(A10)	; DIVIDE SUM BY HIGH PART OF DIVISOR
	FADL	A5,A7		; ADD RESULT TO ORIGINAL QUOTIENT
	JRST	(AX)

DFMPRI:	MOVE	A7,HTEN(A10)
	MOVE	A10,LTENI(A10)
	DFMP	A5,A7		; MULTIPLY
	JFOV	(AX)		; OVERFLOW?
	JRST	1(AX)		; NO

DFDVRI:	MOVE	A7,HTEN(A10)
	MOVE	A10,LTENI(A10)
	DFDV	A5,A7		; DIVIDE
	JRST	(AX)
SUBTTL SELIN/SELOUT - SELECT INPUT/OUTPUT ROUTINES

; ON ENTRY A1 = CHANNEL NUMBER TO BE SELECTED

SELIN:	JUMPL	A1,SEL1		; ALWAYS ALLOW CHANNEL -1
	MOVEI	A2,(A1)
	ADDI	A2,(DB)		; RELOCATE IO DIRECTORY
	SKIPE	A2,%IODR(A2)	; CHANNEL DEFINED?
	TLNN	A2,ININT	; YES - DEVICE INITED FOR INPUT?
	IOERR	2,(A1)		; NO - COMPLAIN
PATCH (17)	; IMPROVE I/O ERROR MESSAGES

SEL1:	HRLM	A1,%CHAN(DB)	; YES - SELECT IT
	POPJ	SP,0

SELOUT:	JUMPL	A1,SEL2		; ALWAYS ALLOW CHANNEL -1
	MOVEI	A2,(A1)
	ADDI	A2,(DB)		; RELOCATE IO DIRECTORY
	SKIPE	A2,%IODR(A2)	; CHANNEL DEFINED?
	TLNN	A2,OUTINT	; YES - DEVICE INITED FOR OUTPUT?
	IOERR	2,(A1)		; NO - COMPLAIN

SEL2:	HRRM	A1,%CHAN(DB)	; YES - SELECT IT
	POPJ	SP,0
SUBTTL INPT/OUTPT - INPUT/OUTPUT DEVICE INITIALIZATION ROUTINE

; ON ENTRY:
; A0 = DEVICE NAME (IF PHYSICAL DEVICE), OR STRING ADDRESS (IF LOGICAL DEVICE)
; LH(A1) = NUMBER OF BUFFERS REQUIRED (PHYSICAL DEVICES ONLY)
; RH(A1) = CHANNEL NUMBER
; A2 = MODE (PHYSICAL DEVICES ONLY)

; DEVCHR FLAGS (LH):

	DEVDDS=400000		; DTA DIRECTORY IN STORE
	DEVDSK=200000		; DSK
	DEVCDR=100000		; CDR/CDP
	DEVLPT=040000		; LPT
	DEVTAJ=020000		; TTY ATTACHED TO JOB
	DEVTUC=010000		; TTY IN USE AS USER'S CONSOLE
	DEVTIO=004000		; TTY IN USE FOR IO
	DEVDSP=002000		; DISPLAY
	DEVLDT=001000		; LONG DISPATCH TABLE
	DEVPTP=000400		; PTP
	DEVPTR=000200		; PTR
	DEVDTA=000100		; DTA
	DEVAA=000040		; DEVICE AVAILABLE OR ASSIGNED TO THIS JOB
	DEVMTA=000020		; MTA
	DEVTTY=000010		; TTY
	DEVDIR=000004		; DIRECTORY DEVICE
	DEVIN=000002		; DEVICE CAN DO INPUT
	DEVOUT=000001		; DEVICE CAN DO OUTPUT

; DEVTYP FLAGS (LH):

	DEVSPL=000020		; DEVICE IS SPOOLED

; IO FLAGS (LH OF A2):

	INFLG=DEVIN		; INPUT FLAG
	OUTFLG=DEVOUT		; OUTPUT FLAG
; IO DIRECTORY SETUP FLAG COMBINATIONS:

	IODSKI=PLDEV!DIRDEV!INDEV!ININT!OUTDEV
	IOCDR=PLDEV!INDEV!ININT
	IOLPT=PLDEV!OUTDEV!OUTINT
	IODSKO=PLDEV!DIRDEV!INDEV!OUTDEV!OUTINT
	IOCDP=PLDEV!OUTDEV!OUTINT
	IOPTP=PLDEV!OUTDEV!OUTINT
	IOPTR=PLDEV!INDEV!ININT
	IODTAI=PLDEV!DIRDEV!INDEV!ININT!OUTDEV
	IOMTAI=PLDEV!SPOPRN!INDEV!ININT!OUTDEV
	IOTTYI=PLDEV!TTYDEV!INDEV!ININT!OUTDEV
	IOTTYO=PLDEV!TTYDEV!INDEV!OUTDEV!OUTINT
	IOTTYB=IOTTYI!IOTTYO
PATCH (25)	; IMPROVE TTY I/O
	IODTAO=PLDEV!DIRDEV!INDEV!OUTDEV!OUTINT
	IOMTAO=PLDEV!SPOPRN!INDEV!OUTDEV!OUTINT
	IOPLT=PLDEV!PLTDEV!OUTDEV!OUTINT
	IOLOGI=INDEV!ININT!INOK
	IOLOGO=OUTDEV!OUTINT!OUTOK
	IOTTC=PLDEV!TTYDEV!TTYTTC!ABMODE!INDEV!ININT!OUTDEV!OUTINT

; JFFO IGNORE FLAGS:

	JFFFLG=DEVDDS!DEVTAJ!DEVTUC!DEVTIO!DEVLDT!DEVAA!DEVDIR!DEVIN!DEVOUT

; BUFFER LENGTHS: (USED IF DEVSIZ NOT IMPLEMENTED)

	DSKBL=203		; DSK
	CDRBL=36		; CDR
	LPTBL=37		; LPT
	CDPBL=36		; CDP
	PTPBL=43		; PTP
	PTRBL=43		; PTR
	DTABL=202		; DTA
	MTABL=203		; MTA
	TTYBL=23		; TTY
	PLTBL=46		; PLT
; MAGIC TABLE OF DEVICE PROPERTIES:

; LH = IO DIRECTORY ENTRY BITS
; RH = BUFFER LENGTH (TOTAL)

	INOU1=.-1

	XWD	IODSKI,DSKBL	; DSK (INPUT)
	XWD	IOCDR,CDRBL	; CDR
	XWD	IOLPT,LPTBL	; LPT
	XWD	0,0		; SPARE
	XWD	IODSKO,DSKBL	; DSK (OUTPUT)
	XWD	IOCDP,CDPBL	; CDP
	XWD	0,0		; DISPLAY (NOT SUPPORTED)
	XWD	0,0		; SPARE
	XWD	IOPTP,PTPBL	; PTP
	XWD	IOPTR,PTRBL	; PTR
	XWD	IODTAI,DTABL	; DTA (INPUT)
	XWD	IOPLT,PLTBL	; PLT
	XWD	IOMTAI,MTABL	; MTA (INPUT)
	XWD	IOTTYI,TTYBL	; TTY (INPUT)
	XWD	IODTAO,DTABL	; DTA (OUTPUT)
	XWD	0,0		; SPARE
	XWD	IOMTAO,MTABL	; MTA (OUTPUT)
	XWD	IOTTYO,TTYBL	; TTY (OUTPUT)
INOU15:	XWD	IOTTYB,TTYBL*2	; TTY (BOTH WAYS)
PATCH (25)	; IMPROVE TTY I/O
INPT:	TLOA	A2,INFLG	; SET INPUT FLAG
OUTPT:	TLO	A2,OUTFLG	; SET OUTPUT FLAG
	IFN	FTOVRL,<
	MOVEI	A4,(A1)
	ADDI	A4,(DB)		; CHECK THAT HE'S NOT
	MOVE	A4,%IODR(A4)	;  TRYING TO USE
	CAMN	A4,[-1]		;   OVRLAY'S CHANNEL
	IOERR	15,(A1)		; HE IS - COMPLAIN
	>
PATCH (31)	; OVERLAYS
	PUSHJ	SP,RELESE	; ENSURE CHANNEL IS RELEASED
	JFCL	.+1		; ERROR RETURN IS OK
	TRNN	A1,LOGCHN	; LOGICAL CHANNEL?
	JRST	INOU2		; NO
	PUSH	SP,A0		; YES -
	PUSH	SP,A1
	PUSH	SP,A2		; SAVE A0-A2
	MOVEI	A0,3
	PUSHJ	SP,GETOWN	; AND ASK FOR 3 WORDS
	POP	SP,A4		; RESTORE IO FLAG
	POP	SP,A2		; RESTORE CHANNEL NUMBER
	ADDI	A2,(DB)		; AND RELOCATE IT
	POP	SP,A3		; RESTORE STRING ADDRESS
	MOVEM	A3,STRPTR(A1)	; FILL IN ADDRESS OF STRING
	MOVEI	A3,@A3		; GET ABSOLUTE ADDRESS
	HLLZ	A0,STR2(A3)
	HRLI	A1,IOLOGI
	TLNE	A4,INFLG	; INPUT?
	JRST	INOU13		; YES
	TLNN	A0,STRDYN	; NO - DYNAMIC?
	SYSER1	17,0		; NO - COMPLAIN
	HRLI	A1,IOLOGO

INOU13:	HLRZ	A4,STR1(A3)	; GET BYTE SIZE & POSITION FROM STRING
PATCH (5)	; REVISE STRING
	TRZ	A4,STRBSC	; ISOLATE BYTE-SIZE
	LSH	A4,-6
	CAIE	A4,^D36		; IF NOT 36 BIT BYTES
	TLO	A1,ABMODE	; THEN SET ASCII MODE
PATCH (5)	; REVISE STRINGS
	MOVE	A0,STR1(A3)	; GET BYTE STRING POINTER
	MOVEM	A0,BYTPTR(A1)	; FILL IN BYTE POINTER
	MOVE	A0,STR2(A3)
	TLZ	A0,STRBCC	; GET BYTE COUNT FROM STRING
	MOVEM	A0,BYTCNT(A1)	; FILL IN BYTE COUNT
	JUMPG	A0,.+2
	TLO	A1,OUTEOF	; SET OUTEOF IF NO BYTES
	MOVEM	A1,%IODR(A2)	; SET UP IO DIRECTORY ENTRY
	MOVEI	A1,0		; SAY OK
PATCH (17)	; PROVIDE ERROR-RETURNS FROM I/O ROUTINES
	POPJ	SP,0
INOU2:	MOVEM	A0,%SYS10(DB)	; SAVE DEVICE NAME
	MOVE	A3,A0		; PHYSICAL DEVICE
	DEVCHR	A3,		; GET ITS CHARACTERISTICS
	JUMPE	A3,INOU3	; CHECK IT EXISTS
	SETCM	A4,A3		; GET COMPLEMENTED CHARACTERISTICS
	AND	A4,A2		; AND MASK WITH IO REQUIREMENTS
	TLNE	A3,DEVAA	; DEVICE AVAILABLE?
	TLNE	A4,INFLG!OUTFLG	; AND OK FOR IO REQUIREMENTS?
	JRST	INOU3		; NO
	HRRZ	A4,A2		; YES - GET MODE REQUIRED
	CAIL	A4,15		; DUMP MODE REQUIRED?
	JRST	INOU4		; YES - CAN'T HANDLE IT
	MOVEI	A5,1
	LSH	A5,(A4)		; AND CONSTRUCT ONE BIT MASK
	AND	A5,A3		; WITH DEVICE CHARACTERISTICS
	JUMPE	A5,INOU4	; JUMP IF ILLEGAL MODE
	HLLZ	A5,A3		; GET LH OF CHARACTERISTICS
	TLZ	A5,JFFFLG	; AND CLEAR UNWANTED FLAGS
	JFFO	A5,INOU5	; SORT IT ALL OUT
	TLNN	A3,DEVOUT	; FUNNY DEVICE
	JRST	INOU3		; CAN IT DO OUTPUT?
	MOVEI	A6,14		; YES - MUST BE A PLOTTER
	JRST	INOU7

PATCH (17)	; PROVIDE ERROR-RETURNS FROM I/O ROUTINEES
INOU3:	TDOA	A1,[
	IOERR	0,0]		; R.H. OF A1 = CHAN #

INOU4:	TDO	A1,[
	IOERR	1,0]		; WRONG MODE (0, ABOVE, = DEV NO GOOD)
	TLZ	A1,37		; CLEAR INDEX, INDIRECT BITS
	POPJ	SP,

INOU5:	TLNE	A3,DEVDSK!DEVDTA!DEVMTA!DEVTTY
				; [E542] DSK, DTA, TTY, MTA OR NUL?
EDIT (542)	; MAKE OTS UNDERSTAND INPUT NUL DEVICE
	JRST	INOU6		; YES
	TLNN	A3,DEVCDR	; NO - CDR/CDP?
	JRST	INOU7		; NO
	TLNE	A3,DEVOUT	; YES - CAN IT DO OUTPUT ?
	ADDI	A6,4		; YES - OFFSET FOR CDP
	JRST	INOU7

PATCH (25)	; IMPROVE TTY I/O

INOU6:	TLNE	A2,OUTFLG	; DSK ETC - REQUIRED FOR OUTPUT?
	ADDI	A6,4		; YES - ADD OFFSET
	TLNN	A3,DEVTAJ	; [P25] TTY CONTROLLING JOB ?
	JRST	INOU7		; [P25] NO
PATCH (25)	; IMPROVE TTY I/O

	SKIPN	A3,%TTYCH(DB)	; ANY TTY ALREADY OPEN ?
	JRST	[		; NO
	MOVEI	A6,INOU15-INOU1	; MAKE IT A "BOTH WAY" TTY
	JRST	INOU14]
	TLNE	A2,OUTFLG	; YES - NEW ONE WANTED FOR O/P ?
	MOVS	A3,A3		; NO - I/P. MAKE IT = OLD O/P,,OLD I/P
	TLNE	A3,-1		; OLD DIRECTION = NEW ?
	JRST	INOU3		; DEVICE NOT AVAILABLE ERROR
	EXCH	A1,A3		; SAVE NEW CHAN # - GET OLD ONE
	MOVEI	A7,1		; SET UP TO CLOSE I/P SIDE ONLY
	TLNE	A2,OUTFLG	; WANTED FOR O/P ?
	TRC	A7,3		; YES - CLOSE O/P SIDE ONLY (CLOSE CH,2)
	PUSHJ	SP,CLFIL5	; DO IT
	ADDI	A1,(DB)		; RELOCATE OLD CHAN-#
	MOVE	A7,%IODR(A1)	; GET DIRECTORY ENTRY
	TLNE	A2,OUTFLG	; IF NEW DIRECTION = O/P
	TLZA	A7,OUTEOF!OUTOK!OUTFIL ; CLEAR OLD O/P FLAGS
	TLZ	A7,INEOF!INOK!INFIL ; ELSE CLEAR OLD I/P FLAGS
	MOVEM	A7,%IODR(A1)	; & RETURN DIRECTORY ENTRY
	MOVE	A1,A3		; RESTORE NEW CHAN #

INOU14:	TLNN	A2,OUTFLG	; WANTED FOR O/P ?
	HRLM	A1,%TTYCH(DB)	; NO -SET I/P CHAN #
	TLNE	A2,OUTFLG
	HRRM	A1,%TTYCH(DB)	; YES - SET O/P CHAN #
INOU7:	SKIPN	A3,INOU1(A6)	; GET DEVICE PROPERTIES
	JRST	INOU3		; NO GOOD FOR ALGOL (DISPLAY, ETC.)
	CAIGE	A4,2		; ASCII MODE?
	TLO	A3,ABMODE	; YES - SET ASCII/BINARY FLAG
	MOVEM	A4,%SYS7(DB)	; SAVE DEVICE MODE
	DEVTYP	A0,		; FIND OUT MORE
	MOVEI	A0,0		; UUO NOT IMPLEMENTED
	TLNE	A0,DEVSPL	; SPOOLED DEVICE?
	TLO	A3,SPLDEV	; YES
	HLRZ	A0,A1		; GET NUMBER OF BUFFERS REQUIRED
	MOVEI	A5,%SYS7(DB)
	DEVSIZ	A5,		; GET BUFFER SIZE OF DEVICE
	JRST	INOU11		; UUO NOT IMPLEMENTED
	JUMPL	A5,[
	AOJE	A5,INOU3	; DEFENSIVE CODING
	JRST	INOU4]
	HRR	A3,A5		; GET BUFFER SIZE
	TLNE	A3,TTYDEV	; TTY TYPE DEVICE?
	ADDI	A3,(A5)		; YES - DOUBLE UP BUFFERS
	JUMPN	A0,INOU12	; ANY BUFFERS SPECIFIED?
	HLRZ	A0,A5		; NO - USE DEFAULT
	JRST	INOU12

INOU11:	JUMPN	A0,INOU12	; NO DEVSIZ - ANY BUFFERS SPECIFIED?
	MOVEI	A0,2		; NO - DEFAULT IS 2

INOU12:	MOVEM	A0,%SYS11(DB)	; SAVE NUMBER OF BUFFERS
	IMULI	A0,(A3)		; MULTIPLY BY BUFFER SIZE
	MOVN	A4,A0		; PREPARE TO CALCULATE BUFFER OFFSET
	ADDI	A0,DEVCAL	; ALLOW FOR CONTROL AREA AND DEVICE NAME
	TLNE	A3,TTYDEV	; TTY TYPE DEVICE?
	ADDI	A0,BDDOFF	; YES - ALLOW FOR SECOND CONTROL AREA
	TLNE	A3,DIRDEV!SPLDEV
				; DIRECTORY DEVICE?
	ADDI	A0,FILCAL	; YES - ALLOW FOR FILE CONTROL AREA
	ADD	A4,A0		; CALCULATE BUFFER OFFSET
	HRL	A1,A4		; AND STORE IN LH OF CHANNEL NUMBER
	MOVEM	A1,%SYS12(DB)	; SAVE CHANNEL NUMBER
	MOVEM	A3,%SYS13(DB)	; SAVE DEVICE PROPERTIES
	PUSHJ	SP,GETOWN	; GET SPACE FOR CONTROL AREAS AND BUFFERS
	MOVE	A2,%SYS13(DB)	; DEVICE PROPERTIES
	HRR	A2,A1		; ADD CONTROL AREA ADDRESS
	MOVE	A3,%SYS12(DB)	; RESTORE CHANNEL NUMBER
	HLRZ	A4,A3		; AND BUFFER OFFSET
	HRRZ	A5,A1
	HRLI	A5,BDDOFF(A1)	; PREPARE CONTROL AREA POINTERS
PATCH (25)	; IMPROVE TTY I/O
	TLNE	A2,ININT	; I/P ?
	JRST	INOU16		; YES
	TLNE	A2,TTYDEV	; NO - TTY ?
	TRZA	A5,-1		; YES: KILL I/P, LEAVING O/P AS 2ND CNTRL AREA
	HRLZ	A5,A5		; NO - KILL I/P SECTION

INOU16:	TLNN	A2,OUTINT	; OUTPUT ?
	TLZ	A5,-1		; NO - KILL O/P SECTION
INOU8:	EXCH	A5,%SYS11(DB)	; INTERCHANGE WITH NUMBER OF BUFFERS
	HRLZI	A6,<OPEN>B53
	HRRI	A6,%SYS7(DB)
	DPB	A3,[
	POINT	4,A6,12]	; PREPARE OPEN CH,
	EXCH	A3,A1		; GET CHAN # TO A1 FOR INOU3
PATCH (17)	; PROVIDE ERROR-RETURNS FROM I/O ROUTINES, & BETTER MSGS
	XCT	A6		; AND TRY TO OPEN DEVICE
	JRST	INOU3		; ALAS - FAILED
	MOVE	A0,%SYS10(DB)	; RECOVER DEVICE NAME
	ADD	A4,A3		; CALCULATE ADDRESS OF BUFFERS
	MOVEM	A4,.JBFF	; AND SET UP JOBFF
	HRRZ	A4,A2		; LOOK FOR PLACE FOR DEVICE NAME .....
	TLNN	A2,ININT	; INPUT REQUIRED?
	JRST	INOU9		; NO
	HRLI	A5,<INBUF>B53	; YES
	DPB	A1,[
	POINT	4,A5,12]	; PREPARE INBUF CH,
	XCT	A5		; AND SET UP BUFFERS

INOU9:	TLNE	A2,TTYDEV!ININT	; I/P ? OR TTY ? (TTY O/P AREA IS 2ND)
	ADDI	A4,BDDOFF	; YES - OFFSET FOR 2ND AREA
PATCH (25)	; IMPROVE TTY I/O
	TLNN	A2,OUTINT	; OUTPUT REQUIRED?
	JRST	INOU10		; NO
	HRLI	A5,<OUTBUF>B53	; YES
	DPB	A1,[
	POINT	4,A5,12]	; PREPARE OUTBUF CH,
	XCT	A5		; AND SET UP BUFFERS
	ADDI	A4,BDDOFF	; .....

INOU10:	ADDI	A1,(DB)		; RELOCATE CHANNEL NUMBER
	MOVEM	A2,%IODR(A1)	; SET UP DIRECTORY ENTRY FOR CHANNEL
	MOVEM	A0,(A4)		; STORE DEVICE NAME
	SETOM	.JBFF		; FIX JOBFF
	MOVEI	A1,0		; SAY OK
PATCH (17)	; PROVIDE ERROR-RETURNS FROM I/O ROUTINES
	POPJ	SP,0		; AND EXIT
SUBTTL RELESE - RELEASE IO CHANNEL ROUTINE

; ON ENTRY A1 = CHANNEL NUMBER TO BE RELEASED
; NON SKIP RETURN IF CHANNEL NOT DEFINED
; OK SKIP RETURN
; A0, A1 AND A2 ARE SAVED AS THIS ROUTINE IS CALLED
; FROM INPT/OUTPT

RELESE:	MOVE	A4,%TTYCH(DB)
	CAIN	A1,(A4)		; TTY O/P ON THIS CHANNEL ? [P25]
	HLLZS	%TTYCH(DB)	; [P25] YES - CLEAR IT
	MOVS	A4,A4		; [P25]
	CAIN	A1,(A4)		; [P25] SAME FOR
	HRRZS	%TTYCH(DB)	; [P25]  INPUT
PATCH (25)	; IMPROVE TTY I/O
	MOVEI	A4,(A1)
	ADDI	A4,(DB)		; RELOCATE CHANNEL NUMBER
	SKIPN	A3,%IODR(A4)	; CHANNEL DEFINED?
	POPJ	SP,0		; NO - ERROR RETURN
	CAMN	A3,[-1]		; DID CHANNEL BELONG TO OVRLAY ?
	JRST	REL5		; YES - HE DOES HIS OWN BUFFERING.
	TLNN	A3,OUTOK	; DEVICE DOING OUTPUT?
	JRST	REL1		; NO
	EXCH	A1,%CHAN(DB)	; YES - FAKE THIS CHANNEL
	PUSHJ	SP,BRKBYT	; AND BREAK OUTPUT
	JFCL	.+1
REL0:	EXCH	A1,%CHAN(DB)	; RESTORE IO CHANNELS

REL1:	SETZM	%IODR(A4)	; CLEAR IO DIRECTORY ENTRY
	TLNN	A3,ININT	; INPUT DEVICE?
	JRST	REL2		; NO
	HLRZ	A4,%CHAN(DB)	; YES - GET CURRENT INPUT CHANNEL NUMBER
	CAIN	A4,(A1)		; THIS ONE?
	HRROS	%CHAN(DB)	; YES - DESELECT IT

REL2:	TLNN	A3,OUTINT	; OUTPUT DEVICE?
	JRST	REL3		; NO
	HRRZ	A4,%CHAN(DB)	; YES - GET CURRENT OUTPUT CHANNEL NUMBER
	CAIN	A4,(A1)		; THIS ONE?
	HLLOS	%CHAN(DB)	; YES - DESELECT IT
REL3:	LRSTOR	A0,%SYS10(DB)
	LRSTOR	A2,%SYS12(DB)	; SAVE A0-A3
	HRRZ	A1,A3
	MOVEI	A0,0
	PUSHJ	SP,GETOWN	; AND DELETE CONTROL AREAS AND BUFFERS
	LRLOAD	A0,%SYS10(DB)
	LRLOAD	A2,%SYS12(DB)	; RESTORE A0-A3
	AOS	(SP)		; SKIP LINK
	TLNN	A3,PLDEV	; LOGICAL DEVICE?
	POPJ	SP,0		; YES - EXIT
	TLNN	A3,SPOPRN	; SPECIAL OPERATIONS PERMITTED?
	JRST	REL4		; NO
	HRLZI	A4,<CLOSE>B53	; YES - IT'S A MAGNETIC TAPE
	DPB	A1,[
	POINT	4,A4,12]	; PREPARE CLOSE CH,0
	XCT	A4		; AND EXECUTE IT

REL4:	HRLZI	A4,<RELEAS>B53
	DPB	A1,[
	POINT	4,A4,12]	; PREPARE RELEAS CH,
	XCT	A4		; AND RELEASE DEVICE
	POPJ	SP,0		; EXIT

REL5:	SETZM	%IODR(A4)	; OVRLAY'S CHAN - JUST CLEAR DIR. ENTRY
	AOS	(SP)		; SKIP RETURN
	POPJ	SP,
PATCH (31)	; OVERLAY HANDLER ROUTINES
SUBTTL OPFILE - OPEN FILE ROUTINE

; ON ENTRY:
; A1 = CHANNEL NUMBER
; A2 = FILE NAME
; A3 = FILE EXTENSION (LEFT HALF)
; A4 = PROTECTION (TOP 9 BITS)
; A5 = PROJECT-PROGRAMMER NUMBER

OPFILE:	MOVEI	A0,0
	MOVEI	A10,(A1)
	ADDI	A10,(DB)	; RELOCATE CHANNEL NUMBER
	SKIPN	A6,%IODR(A10)	; CHANNEL DEFINED?
	IOERR	2,(A1)		; NO
	TLNN	A6,DIRDEV!SPLDEV
				; YES - DIRECTORY DEVICE OR SPOOLED?
	POPJ	SP,0		; NO - EXIT
	MOVEM	A2,FILNAM(A6)	; STORE FILE NAME,
	MOVEM	A3,FILEXT(A6)	; EXTENSION,
	MOVEM	A4,FILPRT(A6)	; PROTECTION,
	MOVEM	A5,FILPP(A6)	; AND PROJECT-PROGRAMMER NUMBER
	TLNE	A6,INFIL!OUTFIL	; FILE OPEN?
	JRST	OPFIL2		; YES
	HRLZI	A7,<LOOKUP>B53
	TLNE	A6,OUTINT	; INPUT?
	TLOA	A6,OUTFIL	; NO
	TLOA	A6,INFIL	; YES
	HRLZI	A7,<ENTER>B53	; NO

OPFIL1:	HRRI	A7,FILNAM(A6)	; AND GET ADDRESS
	DPB	A1,[
	POINT	4,A7,12]	; FILL IN CHANNEL NUMBER
	XCT	A7		; AND ATTEMPT TO OPEN FILE
	JRST	OPFIL3		; FAILED
	TLNN	A6,INFIL	; WAS IT A LOOKUP ?
	JRST	.+3		; NO
	SKIPN	FILPP(A6)	; IS IT NULL ?
EDIT(653) ; MAKE SURE EOF FLAG IS CORRECT
	TLOA	A6,INEOF	; [E653] YES - FLAG IT.
	TLZ	A6,INEOF	; [E653] OTHERWISE CLEAR EOF FLAG
	MOVEM	A6,%IODR(A10)	; AND UPDATE IO DIRECTORY ENTRY
	POPJ	SP,0

OPFIL2:	HRLZI	A7,<RENAME>B53	; PREPARE FOR RENAME
	TLZ	A6,INFIL!OUTFIL!INOK!OUTOK
				; NO - REALLY A DELETE
	JRST	OPFIL1


PATCH (17)	; PROVIDE ERROR-RETURNS FROM I/O ROUTINES

OPFIL3:	HRRZ	A0,FILEXT(A6)	; GET ERROR-CODE
	ADDI	A0,100		; ADD 100 (0 IS A VALID ERROR-CODE !)
	POPJ	SP,		;  & RETURN IT  (CHAN # IN A1)
SUBTTL CLFILE - CLOSE FILE ROUTINE

; ON ENTRY A1 = CHANNEL NUMBER
; A0,A1,A2,A3 ARE NOT USED

CLFILE:	MOVE	A4,%TTYCH(DB)	; [P25]
	CAIN	A1,(A4)		; [P25] TTY O/P ON THIS CHANNEL ?
	HLLZS	%TTYCH(DB)	; [P25] YES - CLEAR IT
	MOVS	A4,A4		; [P25]
	CAIN	A1,(A4)		; [P25] SAME FOR
	HRRZS	%TTYCH(DB)	; [P25]  INPUT
PATCH (25)	; IMPROVE TTY I/O
	MOVEI	A4,(A1)
	ADDI	A4,(DB)		; RELOCATE CHANNEL NUMBER

CLFIL0:	SKIPN	A6,%IODR(A4)	; CHANNEL DEFINED?
	IOERR	2,(A1)		; NO - COMPLAIN
PATCH (17)	; IMPROVE I/O ERROR MESSAGES

CLFIL3:	TLNE	A6,DIRDEV!SPLDEV
				; YES - DIRECTORY DEVICE OR SPOOLED?

CLFIL4:	TLZN	A6,INFIL!OUTFIL	; FILE OPEN?
	POPJ	SP,0		; NO - EXIT
	SETZ	A7,		; [P25] YES - CLEAR ALL OF IT
	PUSHJ	SP,CLFIL5	; [P25]
	TLZ	A6,INEOF!OUTEOF!INOK!OUTOK
				; CLEAR EOF AND OK FLAGS
	MOVEM	A6,%IODR(A4)	; RESTORE DIRECTORY ENTRY
	POPJ	SP,0		; EXIT

CLFIL5:	HRLI	A7,<CLOSE>B53	; [P25]
	
	DPB	A1,[
	POINT	4,A7,12]	; PREPARE CLOSE CH,0
	XCT	A7		; AND CLOSE FILE
	MOVE	A7,[
	STATZ	0,740000]
	DPB	A1,[
	POINT	4,A7,12]	; PREPARE STATZ CH,740000
	XCT	A7		; FILE CLOSED OK?
	IOERR	12,(A1)		; NO - COMPLAIN
	POPJ	SP,		; [P25]
PATCH (25)	; IMPROVE TTY I/O
SUBTTL XFILE - TRANSFER FILE ROUTINE

; TRANSFERS FILE FROM CURRENT INPUT DEVICE
; TO CURRENT OUTPUT DEVICE.

XFILE:	PUSHJ	SP,INBYTE	; GET INPUT BYTE
	POPJ	SP,0		; END OF FILE ON INPUT
	PUSHJ	SP,OUBYTE	; OUTPUT BYTE
	POPJ	SP,0		; END OF FILE ON OUTPUT
	JRST	XFILE		; CONTINUE
SUBTTL MAGNETIC TAPE ROUTINES

; ON ENTRY, THE CHANNEL NUMBER IS IN A1

BSPACE:	TDZA	A2,A2		; BACKSPACE
ENFILE:	MOVEI	A2,1		; ENDFILE
	JRST	SO1
REWND.:	MOVEI	A2,2		; [P32] REWIND

SO1:	MOVEI	A3,(A1)
	ADDI	A3,(DB)		; RELOCATE CHANNEL NUMBER
	SKIPN	A3,%IODR(A3)	; CHANNEL DEFINED?
	IOERR	2,(A1)		; NO - COMPLAIN
PATCH (17)	; IMPROVE I/O ERROR-MESSAGES
	TLNN	A3,SPOPRN	; YES - SPECIAL OPERATIONS PERMITTED
	IOERR	13,(A1)		; NO - COMPLAIN
	JUMPN	A2,SO4		; BACKSPACE?
	TLNN	A3,ININT	; YES - OK ON INPUT?
	IOERR	13,(A1)		; NO - COMPLAIN
	MOVEI	A4,17		; SET UP FOR MTAPE

SO2:	HRLI	A4,<MTAPE>B53

SO3:	DPB	A1,[
	POINT	4,A4,12]	; PREPARE RELEVANT MTAPE
	XCT	A4		; AND EXECUTE IT
	TRZE	A4,-1		; WAS THAT CLOSE?
	XCT	A4		; NO - WAIT
	POPJ	SP,0

SO4:	SOJN	A2,SO5		; ENDFILE?
	MOVEI	A4,16
	TLNE	A3,ININT	; INPUT?
	JRST	SO2		; YES
	HRLZI	A4,<CLOSE>B53	; NO
	JRST	SO3

SO5:	MOVEI	A4,1		; REWIND
	JRST	SO2
SUBTTL ROUTINES FOR LINK'S OVERLAY-HANDLER

	IFN	FTOVRL,<
FUNCT:	MOVEM	A3,%ACCS+3(DB)
	MOVEI	A3,%ACCS(DB)
	BLT	A3,%ACCS+2(DB)
	MOVE	A2,@(AX)	; FUNCTION CODE
	CAIG	A2,FNCTLN	; LEGAL ?
	JRST	@FNCTB(A2)	; DISPATCH

FNCTIL:	SETO	A1,		; FUNCTION ILLEGAL
	JRST	FNCTER		; RETURN ERROR

FNCTB:	FNCTIL			; 0 ILLEGAL
	FNCGAD			; 1 GET CORE AT SPECIFIED ADDRESS
	FNCCOR			; 2 GET CORE ANYWHERE
	FNCRAD			; 3 RETURN CORE
	FNCGCH			; 4 GET I/O CHANNEL
	FNCRCH			; 5 RETURN I/O CHANNEL
	FNCGOT			; 6 GET OTS-CORE ANYWHERE (HEAP)
	FNCROT			; 7 RETURN OTS (HEAP) CORE
	FNCRNT			; 10 GET RUN-TIME
	FNCIFS			; 11 GET NAME ETC. OF LOAD-FILE
	FNCCBC			; 12 CUT BACK CORE

	FNCTLN==.-FNCTB

FNCGAD:	SKIPE	A1,%SYSOV(DB)	; FIRST ENTRY ?
	  JRST	  FNCG1		;   NO
	MOVEI	A0,OVLCHN	; YES...
	PUSHJ	SP,GETCLR	; ...GET CORE FOR TABLE
	HRLI	A1,1-OVLCHN	; -(LENGTH-1)
	MOVEM	A1,%SYSOV(DB)	; SET UP POINTER-WORD TO TABLE

FNCG1:	SKIPG	A3,@4(AX)	; UNDOCUMENTED -1 CALL
	 MOVEI	A3,^D200	; GIVE HIM 200 WORDS
	MOVEM	A3,@4(AX)	; AND TELL HIM SO
	MOVE	A2,@3(AX)	; ADDRESS WANTED
	CAIG	A2,(DB)		; BELOW STACK ?
	 JRST	FNCG2		; YES
	ADDI	A2,(A3)		; GET END OF AREA WANTED
	SUBI	A2,(DB)		; GET AMOUNT TO SHIFT STACK
	MOVEI	A1,1(DB)		; SAVE OLD DB
	CCORE1	(A2)		; SHIFT STACK
	MOVE	A3,@3(AX)	; ADDRESS OF TARGET
	SUBI	A3,-1(A1)
	JUMPE	A3,FNCTEX	; SPOT ON - NO SPARE PIECE
	HRLZM	A3,-1(A1)	; MAKE LINK-WORD FOR SPARE PIECE BELOW
	MOVEI	A0,0		;  AND
	MOVE	A2,%SYSOV(DB)
	PUSHJ	SP,GETKNL	;   DELETE IT
	JRST	FNCTEX		; RETURN OK
FNCG2:	TLZ	DB,TMPFL3	; SET OVL HEAP SEARCH FLAG

FNCG21:	SKIPE	A3,(A1)		; GET ENTRY FROM TABLE
	CAIGE	A2,(A3)		; COULD ADDRESS WANTED BE IN IT?
	 JRST	FNCG31		;   NO

FNCG23:	SUBI	A2,(A3)		; FREE LENGTH BELOW TARGET
	HLRZ	A0,A3		; TOTAL FREE LENGTH
	SUBI	A0,(A2)		; A0 = FREE LENGTH ABOVE TARGET
	JUMPL	A0,FNCG3	; INCLUDES TARGET ADDRESS ? N0
	SUB	A0,@4(AX)	; IS IT LONG ENOUGH ?
	JUMPL	A0,FNCG25	; NO
	HRLM	A2,(A1)		; NEW SHORT LENGTH TO TABLE
	HRLM	A2,(A3)		; AND LINK WORD
	JUMPG	A2,.+2		; SAFETY
	SETZM	(A1)		; ZERO REDUNDANT LINK WORD
	JUMPE	A0,FNCTEX	; NO FREE SPACE ABOVE - DONE
	MOVE	A1,@3(AX)	; RESTORE TARGET
	ADD	A1,@4(AX)	; PLUS LENGTH
	HRLZM	A0,(A1)		; MAKE A NEW LINK WORD
	TLNE	DB,TMPFL3	; WHOSE HEAP ?
	SKIPA	A2,%SYS2(DB)	;  REAL ONE.
	MOVE	A2,%SYSOV(DB)	; PRIVATE ONE
	AOS	A1		; FRIG FOR GETKNL
	PUSHJ	SP,GETKNL	; RETURN SPARE BIT
	JRST	FNCTEX

FNCG25:	HLRZ	A0,A3		; HERE FOR GOOD BASE, BUT TOO SHORT
	ADDI	A0,(A3)		; TOP OF FREE AREA
	CAIE	A0,(DB)		; IS IT JUST BELOW DB ?
	 JRST	FNCEX2		; NO - FATAL FLAW
	SKIPN	A2		; ANY SPARE SPACE BELOW ?
	SETZM	(A1)		; NO - ZAP TABLE-SLOT
	;
	; THIS IS IN FACT THE NORMAL CASE, BECAUSE OF THE WAY
	;  THAT OVRLAY WORKS. NON-ZERO LINK WORD WON'T MATTER.
	;
	HRLM	A2,(A1)		; FIRST PLUG LOWER FREE TABLE
	HRLM	A2,(A3)		; AND LINK WORD
	MOVE	A1,@4(AX)	; REQUIRED LENGTH
	ADD	A1,@3(AX)	; AND BASE
	SUBI	A1,(DB)		; LESS DB = AMOUNT TO SHIFT
	CCORE1	(A1)
	JRST	FNCTEX		; ALL DONE

FNCG3:	MOVE	A2,@3(AX)	; RESTORE ADDRESS WANTED

FNCG31:	AOBJN	A1,FNCG21	; NOT THIS ENTRY - TRY NEXT
	SKIPE	A1,(A1)		; NO MORE TABLE-ENTRIES - ANOTHER PIECE ?
	  JRST	  FNCG21		;   YES - USE IT
	MOVE	A1,%SYS2(DB)	; SET UP TO SEARCH REGULAR HEAP
	TLON	DB,TMPFL3	; UNLESS WE ALREADY HAVE
	JRST	FNCG21		; TRY
	JRST	FNCEX2		; NO GOOD

FNCEX2:	MOVEI	A1,2		; SAY FAIL 2
	JRST	FNCTER
FNCCOR:	; GET CORE ANYWHERE
	SKIPE	A2,%SYSOV(DB)	; FIRST ENTRY ?
	  JRST	  FNCCR1	;   NO 
	MOVEI	A0,OVLCHN	; YES...
	PUSHJ	SP,GETCLR	; ...GET CORE FOR TABLE
	MOVEI	A2,(A1)
	HRLI	A2,1-OVLCHN
	MOVEM	A2,%SYSOV(DB)	; SET UP POINTER

FNCCR1:	MOVE	A0,@4(AX)	; AMOUNT WANTED
	PUSHJ	SP,GETKNL	; GET PIECE
	JRST	FNCTST		; DONE

FNCRAD:	; RETURN CORE
	MOVE	A1,@3(AX)	; ADDR OF PIECE TO RETURN
	MOVEI	A0,0
	MOVE	A2,@4(AX)	; GET SIZE OF RETURN PIECE
	HRLZM	A2,(A1)		; AND MAKE A LINK WORD
	AOS	A1		; INCREMENT POINTER
	MOVE	A2,%SYSOV(DB)
	PUSHJ	SP,GETKNL	; RELEASE CORE
	JRST	FNCTEX		; DONE

; CUT BACK CORE - RETURN OVERLAY HEAP TO MAIN HEAP
; PIECE BY PIECE FOR INTEGRITY

FNCCBC:	SKIPN	A3,%SYSOV(DB)	; GET OVERLAY HEAP TABLE POINTER
	JRST	FNCTEX		; NO TABLE - SILLY, BUT POSSIBLE

FNCBC1:	SETZB	A0,A1		; FOR GETOWN RETURN & ENTRY KILL
	EXCH	A1,(A3)		; LOAD ENTRY & KILL IT
	JUMPE	A1,FNCBC2	; NOTHING TO DECLARE
	HLLZM	A1,(A1)		; SET UP LENGTH WORD
	MOVEI	A1,1(A1)	; SET UP POINTER
	PUSHJ	SP,GETOWN	; AND FREE IT

FNCBC2:	AOBJN	A3,FNCBC1	; HERE ONLY FOR NULL ENTRIES
	SKIPN	A3,(A3)		; GET ADDR OF NEXT BIT, IF ANY
	JRST	FNCTEX		; NONE (LEAVE LAST PIECE ALONE)
	EXCH	A3,%SYSOV(DB)	; DELETING THE BIT OF TABLE WE'VE DONE
	MOVEI	A1,(A3)		; GET ADDR OF LAST BIT OF TABLE
	PUSHJ	SP,GETOWN	; FREE IT
	MOVE	A3,%SYSOV(DB)	; ADDR OF NEXT BIT
	JRST	FNCBC1		; CARRY ON
FNCGOT:	; GET OTS (HEAP) CORE
	MOVE	A0,@4(AX)	; LENGTH
	PUSHJ	SP,GETOWN	; GET IT
	;
	; NOTE THAT, DESPITE THE DESCRIPTION IN SOME VERSIONS OF THE
	; DOCUMENTATION, THIS FUNCTION IS A "GET-CORE-ANYWHERE" TYPE
	;
	MOVEM	A1,@3(AX)	; ADDRESS OF PIECE
	JRST	FNCTEX		; DONE

FNCROT:	; RETURN OTS CORE
	MOVE	A1,@3(AX)	; ADDRESS
	MOVEI	A0,0		; (HE'D BETTER NOT CHANGE THE LENGTH!)
	PUSHJ	SP,GETOWN
	JRST	FNCTEX

FNCGCH:	; GET CHANNEL
	MOVEI	A1,17(DB)	; TRY 17 FIRST
	SKIPN	%IODR(A1)	; IS IT FREE ?
	  JRST	  FNCGC1	;   YES
	CAILE	A1,(DB)		; NO - ANY MORE ?
	  SOJA	  A1,FNCGCH+1	;   YES - KEEP TRYING
	MOVEI	A1,1		; NO CHANNELS - ERROR CODE 1
	JRST	FNCTER

FNCGC1:	SETOM	%IODR(A1)	; MARK THE IODR AS IN USE
	SUBI	A1,(DB)		; RETRIEVE CHANNEL NUMBER
	JRST	FNCTST		;  & RETURN IT

FNCRCH:	; RETURN CHANNEL
	MOVE	A1,@3(AX)	; NUMBER
	ADDI	A1,(DB)
	SETZM	%IODR(A1)	; CLEAR IODR ENTRY
	JRST	FNCTEX

FNCRNT:	; GET START RUN-TIME
	MOVE	A1,%SYS5(DB)
	JRST	FNCTST		; EASY

FNCIFS:	; GET LOAD-FILE NAME, ETC
	MOVE	A1,%IFDAT+2(DB)	; DEVICE
	MOVEM	A1,@3(AX)
	MOVE	A1,%IFDAT+1(DB)	; FILE-NAME
	MOVEM	A1,@4(AX)
	MOVE	A1,%IFDAT(DB)	; PPN
	MOVEM	A1,@5(AX)
	JRST	FNCTEX

FNCTST:	MOVEM	A1,@3(AX)	; SET ANSWER INTO ARG3

FNCTEX:	SETZM	@2(AX)		; STATUS CODE = 0
	SKIPA

FNCTER:	MOVEM	A1,@2(AX)	; RETURN ERROR-STATUS
	MOVSI	A3,%ACCS(DB)
	BLT	A3,A3		; RETORE ACCS
	POPJ	SP,

	>	; END OF IFN FTOVRL

	IFE	FTOVRL,<
FUNCT:	SYSER2	10,		; SAY NOT IMPLEMENTED.
	>

PATCH (31)	; OVERLAY-HANDLER ROUTINES (FUNCT.)
SUBTTL TRACE HANDLING ROUTINES

TRLAB:	TLNN	DB,TRLVEL!INDDT	; FORCED OFF ?
	PUSHJ	SP,TRLENT	; NO - ENTER IT
	JRST	1(AX)

TRSTD:	TLNE	DB,TRLVEL!INDDT	; TRACING ?
	JRST	TRSTD1		; NO - EXIT
	PUSH	SP,A0		; STANDARD FUNCTION TRACE.
	PUSH	SP,A1		; MUST SAVE THEIR ARGUMENTS !
	PUSH	SP,AX		; SAVE LINK !
EDIT(715); SAVE CONTENTS OF AC3
	PUSH	SP,A3		; [E715]
EDIT(651);DONT CLOBBER ACS 10-13
	PUSH	SP,A10		; [E651]
	PUSH	SP,A11		; [E651]
	PUSH	SP,A12		; [E651]
	PUSH	SP,A13		; [E651]
	AOS	%TRLV(DB)	; INCR BLOCKLEVEL - HAVE NOT BEEN THRU PARAM
	MOVE	AX,-10(SP)	; [E715] GET POINTER TO PMB 
	PUSHJ	SP,TRLENT	; DO IT
	SOS	%TRLV(DB)	; PUT DYNAMIC BLOCK-LEVEL BACK
	POP	SP,A13		; [E651]
	POP	SP,A12		; [E651]
	POP	SP,A11		; [E651]
	POP	SP,A10		; [E651]
	POP	SP,A3		; [E715]
	POP	SP,AX		; RESTORE LINK
	POP	SP,A1		; RESTORE ARGS
	POP	SP,A0

TRSTD1:	AOS	(SP)		; SKIP PMB POINTER
	POPJ	SP,		; RETURN

TRLMAN:	MOVEI	AX,PMBPTR(DL)	; GET PROCEDURE'S PMB POINTER
	TLNE	DB,TRLVEL!INDDT	; FORCED OFF ?
	POPJ	SP,

TRLENT:	SKIPE	A3,%TRPTR(DB)	; BUFFER SET UP ?
	JRST	TRLMN1		; YES
	HRRZ	A0,%TRLNTH(DB)	; GET LENGTH OF TRACE BUFFER
	PUSHJ	SP,GETCLR
	HRLZ	A3,%TRLNTH(DB)	; GET - BUFFER LENGTH
	MOVN	A3,A3		;  IN LEFT HALF
	HRR	A3,A1

TRLMN1:	SKIPN	A2,(AX)		; GET POINTER
	JRST	TRLMN3
	CAIG	A2,(DB)		; MUST BE A HI-SEG PROG
	AOS	(A2)		; ELSE UPDATE PROFILE
	AOBJN	A3,TRLMN2	; NOW UPDATE RING POINTER
	SUB	A3,%TRLNTH(DB)	; ADJUST TO TOP IF REQ'D

TRLMN2:	HRL	A2,%TRLV(DB)	; DYNAMIC BLOCK LEVEL
	MOVEM	A2,(A3)		; PLANT IT

TRLMN3:	MOVEM	A3,%TRPTR(DB)	; ANY TRACE LISTED ?
	JUMPE	A2,.+2
	TLNN	DB,STMTST	; DYNAMIC OR PM ?
	POPJ	SP,

TRDPRT:	MOVNI	A2,1		; FORCE CHANNEL -1
	EXCH	A2,%CHAN(DB)
	PUSHJ	SP,PMTPR3	; PRINT 1 ENTRY

TRDPEX:	PUSHJ	SP,BRKBYT	; FORCE IT OUT
	JFCL	.+1
	MOVEM	A2,%CHAN(DB)	; RESTORE CHANNEL
	POPJ	SP,

TRLPRT:	TLZ	DB,STMTST	; CLEAR DYNAMIC TRACE FLAG
	SKIPE	A3,%TRPTR(DB)	; ANY TRACE LISTED ?
	JRST	PMTPR1		; YES - PRINT IT
NOTRACE: MOVEI	A1,TRACE1	; ELSE MESSAGE
	JRST	MONIT0		; AND EXIT VIA MONIT

PMTPR1:	MOVEI	A1,TRACE2	; HEADER MESSAGE
	PUSHJ	SP,MONIT
	HRLZ	A2,%TRLNTH(DB)	; GET LENGTH OF BUFFER.
	ADD	A3,A2
	ADD	A3,[1,,0]
PATCH(71)	; Reverse the order of TRACE output (make it latest first.)
	MOVNI	A2,1		; FAKE CHANNEL -1
	EXCH	A2,%CHAN(DB)

PMTPR2:	PUSHJ	SP,PMTPR3
	SUB	A3,[1,,1]	; GET PREVIOUS ENTRY.
	TLNN	A3,-1		; TOP OF BUFFER ?
	  ADD	A3,%TRLNTH(DB)	; YES - GO TO BOTTOM.
	HRRZ	A1,%TRPTR(DB)	; GET ADDR OF LATEST ENTRY.
	CAIN	A1,(A3)		; GONE ALL THE WAY ROUND ?
	JRST	TRDPEX		; YES - GO HOME
	JRST	PMTPR2

PMTPR3:	SKIPN	A1,(A3)		; GET POINTER
	POPJ	SP,		; NO ENTRY
	PUSHJ	SP,PMCRLF	; TYPE CR-LF
	HLRZ	A0,A1		; GET DYNAMIC BLOCK LEVEL
	LSH	A0,1		; DOUBLE IT
	IDIVI	A0,^D60		; TOO LONG ?
	JUMPE	A0,PMTPR7	; NO
	PUSH	SP,A2
	PUSH	SP,A1		; SAVE REM
	PUSH	SP,A3
	PUSHJ	SP,IPRINT	; PRINTS NUMBER
	POP	SP,A3
	POP	SP,A1
	POP	SP,A2

PMTPR7:	TLNE	DB,STMTST	; SPECIAL FOR DYNAMIC
	SKIPA	A13,["*"]
	MOVEI	A13," "		; SPACE CHAR
	PUSHJ	SP,OUBYTE
	JFCL	.+1		; IGNORE ERRORS
	SOJG	A1,PMTPR7
	HRRZ	A1,(A3)		; NOW GET NAME
	ADD	A1,[
	XWD	440600,2]	; MAKE IT A POINTER

PMTPR4:	ILDB	A13,A1		; GET CHARACTER
	JUMPE	A13,PMTPR8	; NULL MEANS END
	ADDI	A13,40		; ASCIFII IT
	PUSHJ	SP,OUBYTE
	JFCL	.+1		; IGNORE ERRORS
	JRST	PMTPR4
PMTPR8:	MOVEI	A13," "		; ONE EXTRA SPACE
	PUSHJ	SP,OUBYTE
	JFCL	.+1
	POPJ	SP,

PMCRLF:	MOVEI	A13,15		; CR-LF
	PUSHJ	SP,OUBYTE
	JFCL	.+1
	MOVEI	A13,12
	PUSHJ	SP,OUBYTE
	JFCL	.+1
	POPJ	SP,

PRFPR%:
PRFPRT:	SKIPN	%TRPTR(DB)	; TRACING DONE ?
	JRST	NOTRACE		; NO - COMPLAIN. CAN'T DO PROFILES
	MOVEI	A1,PRFMES	; HEADING
	PUSHJ	SP,MONIT
	MOVEI	A7,.JBDA	; START OF PROGRAM
	MOVNI	A6,1
	EXCH	A6,%CHAN(DB)	; SET O/P = TTY:
	PUSH	SP,A6

PRFPR1:	CAMN	A7,%SYS21(DB)	; END OF PROGRAM ? (HEAP ORIGIN)
	JRST	PRFPR3		; YES - DONE
	HLRZ	A0,(A7)		; NO - GET WORD
	CAIE	A0,(<JSP AX,@0>) ; OTS CALL ?
	CAIN	A0,(<PUSHJ SP,@0>)
	JRST	.+2
	AOJA	A7,PRFPR1	; NO
	HRRZ	A0,(A7)		; YES - GET ADDRESS
	CAIE	A0,%ALGDR+53	; TRSTD ?
	CAIN	A0,%ALGDR+52	;  OR TRLAB ?
	JRST	PRFPR2		; YES
	CAIE	A0,%ALGDR+1	; PARAM ?
	CAIN	A0,%ALGDR+2	;  OR PAR0 ?
	JRST	PRFPR2		; YES
	AOJA	A7,PRFPR1	; NO - LOOP

PRFPR2:	SKIPN	A6,1(A7)	; GET P.M.B. POINTER
	AOJA	A7,PRFPR1	; ZERO
; HERE ADD MORE TESTS THAT A6 IS A REAL P.M.B. POINTER
	MOVE	A0,(A6)		; PROFILE COUNT
	PUSHJ	SP,IPRINT	; PRINT IT
	MOVEI	A13,"	"	; TAB
	PUSHJ	SP,OUBYTE
	JFCL
	MOVEI	A1,2(A6)	; NAME
	HRLI	A1,440600	; BYTE POINTER
	PUSHJ	SP,PMTPR4	; PRINT NAME
	PUSHJ	SP,PMCRLF	; CR-LF
	AOJA	A7,PRFPR1	; LOOP

PRFPR3:	PUSHJ	SP,BRKBYT	; DONE
	JFCL
	POP	SP,%CHAN(DB)	; RESTORE O/P CHANNEL
	POPJ	SP,

SUBTTL UUO HANDLER

UUO:	TLNE	DB,INDDT	; IN DEBUGGER ?
	  JRST	UUO9		; YES - HE TAKES CARE OF HIS OWN AC'S.
	LRSTOR	A0,%SYS16(DB)	; SAVE A0,A1 IN TEMPORARY DUMP

UUO9:	LDB	A1,[
	POINT	9,.JBUUO,8]	; AND GET FUNCTION CODE
	CAIL	A1,UUONUM	; IN ALGOL UUO RANGE?
	JRST	ERRUUO		; NO

UUOTAB:	JRST	@UUOTAB(A1)	; YES - USE TABLE
	IFN DUMP, <
	XWD	0,DUMP0>
	IFE DUMP, <
	XWD	0,ERRUUO>	; DUMP
	XWD	0,UUO2		; SYSER1
	XWD	0,UUO3		; SYSER2
	XWD	0,UUO4		; IOERR
	XWD	0,UUO5		; LIBERR
	XWD	0,CORE0		; CCORE
PATCH(30)	; NEW CORE UUO
	XWD	0,CORE2		; CCORE1
	XWD	0,BREAK%	; DDT BREAKPOINT UUO.
	XWD	0,DDTER%	; DDT ERROR UUO.

	UUONUM=.-UUOTAB

UUO2:
UUO3:
UUO4:
UUO5:	MOVE	A1,MUUO(A1)	; LOOK UP MASTER UUO TABLE
	LDB	A0,[
	POINT	4,.JBUUO,12]	; GET ACCUMULATOR NUMBER
	HRL	A0,A0
	ADD	A1,A0		; OFFSET BY ERROR NUMBER
	JUMPG	A1,ERRUUO	; AND CHECK IN RANGE
	SKIPA	A1,(A1)		; GET FLAGS AND MESSAGE ADDRESS

ERRUUO:	MOVE	A1,M2+0		; ILLEGAL UUO'S
ERRMON:
	TLNE	DB,INDDT	; IN DEBUGGER ?
	  JRST	DDERM%		; YES - LET HIM LOOK AFTER IT.

ERRMNX:	EXCH	A1,%SYS17(DB)	; SAVE FLAGS AND ERROR
	MOVE	A0,%SYS16(DB)	; RESTORE A0,A1
	MOVEM	A0,%ACCS+A0(DB)
	HRLZI	A0,A1
	HRRI	A0,%ACCS+A1(DB)
	BLT	A0,%ACCS+SP(DB)	; SAVE ACCUMULATORS
	MOVE	A1,%SYS17(DB)	; RESTORE FLAGS AND ERROR
	HLRZ	A2,A1
	ANDI	A2,TRAPNO	; GET TRAP NUMBER
	CAIE	A2,2		; FATAL PDL OVERFLOW ?
	JRST	.+4		; NO
	MOVE	SP,%ESP(DB)	; YES - USE EMERGENCY STACK.
	SKIPN	%DDTST(DB)	; AND TURN OFF DEBUGGER,
	HLLOS	%DDTST(DB)	; IF NOT ALREADY DONE
	ADDI	A2,(DB)
	SKIPN	A1,%TRAPS(A2)	; TRAP SET UP?
	JRST	.+3		; NO
	SKIPL	%SYS17(DB)	; YES - IS IT FATAL?
	JRST	ERRM4		; NO - PROCEED TO TRAP
	PUSHJ	SP,DCRLF
	MOVEI	A1,[ASCIZ /?/]
	PUSHJ	SP,MONIT	; INSERT "?" BEFORE MESSAGE
	SKIPL	%SYS17(DB)	; FATAL ERROR?
	JRST	ERRM1		; NO
	MOVEI	A1,M000		; YES
	PUSHJ	SP,MONIT	; "FATAL "

ERRM1:	MOVEI	A1,M001
	PUSHJ	SP,MONIT	; "RUN-TIME ERROR AT ADDRESS "
	HRRZ	A1,.JBUUO	; GET ADDRESS IN UUO
	HLRZ	A0,.JBUUO	; GET UUO
	TRZ	A0,777		; GET OPCODE
	CAIE	A0,(IOERR)	; IOERR OR
PATCH (17)	; IMPROVE I/O ERROR MESSAGES
	SOJG	A1,ERRM3	; ADDRESS SUPPLIED?
	HRRZ	A1,PRGLNK(DL)	; NO - GET LAST LINK
	SUBI	A1,2

ERRM2:	HLRZ	A0,(A1)		; MOVE BACK TO CALL
	ANDI	A0,777740
	CAIE	A0,<PUSHJ	SP,0>B53
	SOJG	A1,ERRM2
	HRRZ	A0,(A1)		; THEN GET EFFECTIVE ADDRESS
	JRST	ERM3A		; AND REMEMBER IT
ERRM3:	MOVEI	A0,(A1)		; GET CONTEXT ADDRESS
ERM3A:	PUSH	SP,A0		; REMEMBER IT
	PUSHJ	SP,SPROCT	; PRINT ADDRESS OF ERROR
	PUSHJ	SP,CRLF
	HRRZ	A1,%SYS17(DB)
	PUSHJ	SP,MONIT	; PRINT ERROR MESSAGE
PATCH (17)	; IMPROVE I/O ERROR MESSAGES
	HLRZ	A0,.JBUUO	; GET UUO
	TRZ	A0,777		; GET OPCODE
	CAIE	A0,(IOERR)	; IOERR ?
	JRST	ERRM7		; NO
	HRRZ	A1,.JBUUO	; YES - EFFECTIVE ADDR IS CHAN #
	ADDI	A1,(DB)		; RELOCATE
	MOVE	A4,%SYS17(DB)	; GET ERROR-MESSAGE FLAGS
	SKIPN	A3,%IODR(A1)	; GET DIRECTORY ENTRY
	JRST	ERRM8		; NOT ALLOCATED
	SETZ	A6,
	TLNN	A4,ERRDEV	; TYPE DEVICE-NAME ?
	JRST	ERRM9		; NO
	TLNN	A3,TTYDEV	; YES - TTY ?
	SKIPA	A5,3(A3)	; NO - GET DEVNAME
	MOVE	A5,6(A3)	; YES - GET DEVNAME (ALLOW FOR I & O HDRS)
	TLNE	A3,TTYTTC	; TTY ON TTCALL (CHAN -1) ?
	HRLZI	A5,(SIXBIT/TTY/) ; YES - SAY SO
	JRST	ERRM12

ERRM8:	LDB	A5,[
	POINT	4,.JBUUO,12]	; NO DIRECTORY-ENTRY - GET ERROR #
	SOJG	A5,ERRM10	; IF IT'S 0 OR 1, IT WAS ERROR IN OPEN
	MOVE	A5,%SYS10(DB)	;  AND OTS LEAVES DEV-NAME HERE

ERRM12:	MOVEI	A1,A5
	PUSHJ	SP,MONSIX	; O/P DEVICE NAME
	MOVEI	A1,[
	ASCIZ/:/]
	PUSHJ	SP,MONIT
ERRM9:	TLNE	A3,DIRDEV	; DIRECTORY DEVICE ?
	TLNN	A4,ERRFIL	; YES - TYPE FILE.EXT ?
	JRST	ERRM10		; NO
	MOVE	A5,4(A3)	; GET FILENAME
	MOVEI	A1,A5
	PUSHJ	SP,MONSIX	;  & TYPE IT
	MOVEI	A1,[
	ASCIZ/./]
	PUSHJ	SP,MONIT
	HLLZ	A5,5(A3)	; GET EXTENSION
	MOVEI	A1,A5		;  *** N.B. A6 = 0 TO STOP MONSIX !! ***
	PUSHJ	SP,MONSIX	; TYPE EXT

ERRM10:	TLNN	A4,ERR2PT	; MORE MESSAGE ?
	JRST	ERRM11		; NO
	HLRZ	A1,A4
	TRZ	A1,FATAL!ERRDEV!ERRFIL!ERR2PT!TRAPNO
				; YES - GET OFFSET OF REST OF MSG
	LSH	A1,-6
	ADDI	A1,(A4)		; ADD IT TO 1ST PART ADDR
	PUSHJ	SP,MONIT	; & TYPE

ERRM11:	MOVEI	A1,[
	ASCIZ/ channel # /]
	PUSHJ	SP,MONIT	; TYPE
	HRRE	A0,.JBUUO	; GET CHANNEL # - EXTEND SIGN FOR -1 CASE
	MOVNI	A1,1
	EXCH	A1,%CHAN(DB)	; SET O/P = TTCALL TTY
	PUSHJ	SP,IPRINT	; TYPE CHAN #
	EXCH	A1,%CHAN(DB)	; RESET O/P CHAN #
ERRM7:	POP	SP,A4		; RESTORE CONTEXT ADDRESS
	PUSHJ	SP,DCRLF
	PUSH	SP,.JBUUO	; DEBUGGER DOES UUO'S!
	HRRZ	A1,%UUO(DB)	; GET CALLERS PC
	MOVEM	A1,.JBOPC	; SAVE FOR 'CONTINUE' COMMAND
	TLO	DB,TMPFL3	; [P77] TELL HSTPRT NOT TO TYPE IF EXPERT.
PATCH(77)	; Read SWITCH.INI for ALGDDT/EXPERT line.
	PUSHJ	SP,HSTPRT	; DO HISTORY PRINT.
PATCH (37)	; TRACE
	SETZM	.JBINT		; TURN OFF CONTROL-C INTERCEPT
	MOVNI	A1,1
	CTLJOB	A1,		; FIND OUT IF CONTROLLED
	JRST	.+2
	JUMPL	A1,ERRM7A	; [P67][P45] ERROR RESTARTS
	PUSHJ	SP,TRLPRT	; [P45]
	IFN	FTADMP,<
	SETOM	%CHAN(DB)	; [P70] SET O/P  = TTY:
	MOVEI	A7,-1		; [P70] SAY "ALL"
	TLO	DB,INDDT	; [P70]
	PUSHJ	SP,DUMP%	; [P70] GIVE ALGOL DUMP.
	TLZ	DB,INDDT	; [P70]
>
PATCH(70)	; DO A "DUMP ALL" ON ERROR IN BATCH.
	JRST	INIT5		; [P45]

ERRM7A:	POP	SP,.JBUUO	; RESTORE UUO OPCODE
	JRST	%ALGDD		; [P67]GO TO DEBUGGER.
PATCH(67)	; Combine the two command scanners.

; TRAP RESTART

ERRM4:	HRRZ	AX,(A1)		; GET RESTART LABEL
	HLRZ	A2,(A1)		; AND ITS PROCEDURE LEVEL+1
	MOVEI	A3,(A2)
	ADDI	A3,(A1)
	MOVEI	A3,@(A3)	; GET DL FOR LABEL
	MOVEI	A13,(A3)	; SAVE COPY FOR GOLAB

ERRM5:	MOVE	A4,(A3)		; GET DISPLAY ELEMENT
	ADDI	A3,1
	ADDI	A1,1
	CAMN	A4,(A1)		; OK?
	SOJN	A2,ERRM5	; YES - CONTINUE
	JUMPN	A2,ERRM6	; MISMATCH
	MOVE	SP,BLKPTR(DL)	; RESTORE STACK-POINTER
	ADDI	SP,(DB)		; AND RELOCATE IT
	AOJA	AX,GOLAB0	; AND SIMULATE GOTO LABEL

ERRM6:	MOVEI	A1,MONIT4	; CRLF
	PUSHJ	SP,DDTOU%
	MOVEI	A1,[ASCIZ /?/]
	PUSHJ	SP,MONIT
	MOVE	A1,M3+7
	PUSHJ	SP,MONIT	; "TRAP LABEL OUT OF SCOPE"
	PUSHJ	SP,DCRLF
	JRST	ERRM1


HSTPR.:	; HISTORY PRINTER. (IN PROC P, CALLED FROM PROC PP ETC.)
	; ON ENTRY, A4 HAS ADDRESS OF ERROR. FIRST PART OF MSG ALREADY TYPED.
	; TMPFL3 (in DB) will be set if we're not to type if he's an EXPERT.
	TLO	DB,INDDT	; SAY WE'RE IN DDT (IN CASE OF ERRORS, UUOS)
	SETZM	%DDTBE(DB)	; CLEAR OLD CONTEXT.
	SETZM	%DDTUW(DB)	; CLEAR DYNAMIC P.L.
	HRRZM	A4,%DDTPC(DB)	; SAVE ADDRESS FOR LATER.
	SKIPN	%DDTST(DB)	; [P77] IF S.T. HAS NOT YET BEEN READ,
	  PUSHJ	SP,DDINI%	; [P77]  READ IT (ALSO READ SWITCH.INI)
	HRRZ	A1,%DDTER(DB)	; [P77] IS HE AN EXPERT ?
	SKIPN	A1		; [P77] ?
	  TLZ	DB,TMPFL3	; [P77]  NO - GIVE HIM THE TYPE-OUT.
	HRRZ	A4,%DDTPC(DB)	; [P77] RETRIEVE ADDRESS.
	SKIPG	%DDTST(DB)	; UNLESS DEBUGGING SYSTEM HAS BEEN TURNED OFF...
	  PUSHJ	SP,FNDAD%	;  CALL DDT ROUTINE TO GET LINE #
	  JRST	ERRM3F		; FAILURE.
	TLZ	DB,INDDT
	TLNE	DB,TMPFL3	; [P77] SILENT ?
	  JRST	ERRM3F		; [P77] YES.
PATCH(77)	; Read SWITCH.INI for ALGDDT/EXPERT line.
	MOVEI	A1,M002		; "ON LINE "
	PUSHJ	SP,DDTOU%
	MOVEI	A0,(A4)		;  RETURNS STMNT-#,,LINE-# IN A4
	PUSH	SP,A4		; SAVE AGAINST IPRINT
	PUSHJ	SP,IPRINT
	POP	SP,A4
	HLRZ	A0,A4		; STMNT-# WITHIN LINE.
	JUMPE	A0,ERRM3F	; ZERO.
	MOVEI	A1,M003
	PUSHJ	SP,DDTOU%
	PUSHJ	SP,IPRINT

ERRM3F:	TLZ	DB,INDDT
	PUSH	SP,DL
	SKIPN	CONDL(DL)	; MAIN PROGRAM ?
	JRST	ERRM3E		; YES - SAY SO
	SKIPN	A3,PMBPTR(DL)	; TRACED ?
	JRST	ERRM3A		; NO
	MOVEI	A1,ERRM21	; YES
	MOVEI	A7,0		; NO PREVIOUS DL.
	PUSHJ	SP,ERRM20+1	; "IN PROCEDURE"
	JRST	ERRM3B

ERRM3A:	MOVEI	A1,ERRM22	; "IN UN-NAMED PROCEDURE"
	TLNN	DB,TMPFL3	; [P77] DON'T TYPE IF SILENT.
	PUSHJ	SP,DDTOU%

ERRM3B:	MOVEI	A7,(DL)		; SAVE PREVIOUS DL.
	SKIPN	%DDTBE(DB)	; HAS FNDADR FOUND ANY CONTEXT ?
	JRST	ERRM3G		; NOT YET.
	HLRZ	A1,%DDTPC(DB)	; YES - FIRST TIME ?
	JUMPN	A1,ERRM3G	; NO.
	MOVEI	A1,(DL)		; YES - SAVE DL
	SUBI	A1,(DB)		; (DELOCATED OF COURSE)
	HRLM	A1,%DDTPC(DB)	;
;
;	The logic here is that the code at DDGTDL needs to have the
;	display appropriate to the procedure-level that it will retrieve
;	from the BLK item found by FNDADR above.
;	In most cases, the current display would do as well, (that pointed
;	to by DL), as it is copied from the outer display.
;	But in the case of external procedures, where FNDADR does not
;	establish the context within the external (perhaps it was not an
;	ALGOL procedure, or was compiled /P), the static procedure-level,
;	and hence the length of the current display, will be less than that
;	of the outer (dynamically) procedure where FNDADR established the context.
;

ERRM3G:
	MOVE	DL,CONDL(DL)	; GET NEXT DL DOWN
	ADDI	DL,(DB)		; AND RELOCATE IT
	SKIPN	CONDL(DL)	; ALL DONE ?
	JRST	ERRM3D		; YES - MAIN PROGRAM
	SKIPN	A3,PMBPTR(DL)	; GET POINTER
	JRST	ERRM3C		; NONE THERE
	PUSHJ	SP,ERRM20	; GO PRINT NAME
	JRST	ERRM3B

ERRM3C:	MOVEI	A1,ERRM24	; UN-NAME PROC
	TLNN	DB,TMPFL3	; [P77]	 IF NOT SILENT,
	PUSHJ	SP,DDTOU%
	JRST	ERRM3B

ERRM3E:	MOVEI	A1,ERRM26
	TLNN	DB,TMPFL3	; [P77]	 IF NOT SILENT,
	PUSHJ	SP,DDTOU%
	JRST	ERRM3H

ERRM3D:	MOVEI	A1,ERRM25
	TLNN	DB,TMPFL3	; [P77] IF NOT SILENT,
	PUSHJ	SP,DDTOU%	; "CALLED FROM MAIN PROGRAM"
	PUSHJ	SP,ERRM29	; TYPE LINE #

ERRM3H:	MOVEI	A1,MONIT4
	TLNN	DB,TMPFL3	; [P77]	 IF NOT SILENT,
	PUSHJ	SP,DDTOU%	; 1 CRLF
	PUSHJ	SP,DDBRK%	; GET IT ALL TYPED.
	POP	SP,DL		; RESTORE REAL DL
	POPJ	SP,
ERRM20:	MOVEI	A1,ERRM23	; "CALLED FROM PROC"
	TLNE	DB,TMPFL3	; [P77]
	  JRST	ERRM29		; [P77]
	PUSHJ	SP,DDTOU%
	HRRZ	A1,A3		; GET ADDRESS
	ADD	A1,[
	POINT	6,2]		; MAKE IT A POINTER
	PUSHJ	SP,PMTPR4	; PRINT NAME.

ERRM29:	JUMPE	A7,ERRM28	; NO PREVIOUS DL
	TLO	DB,INDDT
	HRRZ	A4,PRGLNK(A7)	; GET CALL ADDRESS.
	SKIPG	%DDTST(DB)	; UNLESS DEBUGGING SYSTEM HAS BEEN TURNED OFF,
	  PUSHJ	SP,FNDAD%	;  CALL IT TO CONVERT PC TO LINE #
	  JRST	ERRM28		; FAILURE (E.G. IN NON-ALGOL PROCEDURE)
	TLZ	DB,INDDT
	TLNE	DB,TMPFL3	; [P77]
	  JRST	ERRM28		; [P77]
	MOVEI	A1,ERRM27
	PUSHJ	SP,DDTOU%
	MOVEI	A0,(A4)		; GET LINE # ONLY.
	PUSHJ	SP,IPRINT

ERRM28:	AOS	%DDTUW(DB)	;[P64]INCREMENT DYNAMIC P.L.
	MOVE	A0,%DDTPL(DB)	; GET MAX DYNAMIC PROC LEVEL
	SUB	A0,%DDTUW(DB)	; SUBTRACT CURRENT DEPTH
	JUMPE	A0,ERM28A	; NOTHING TO DO IF MAIN !
	TLNE	DB,TMPFL3	; TYPING ?
	JRST	ERM28A		; NO - EXIT
	PUSH	SP,A0		; OTHERWISE REMEMBER VALUE
	MOVEI	A1,ERRM31	;[P64]
	PUSHJ	SP,DDTOU%	;[P64]
	POP	SP,A0		; RESTORE LEVLE
	PUSHJ	SP,IPRINT	;[P64] TYPE IT.
ERM28A:	TLZ	DB,INDDT	; MAKE SURE DDT BIT REALLY CLEAR.
	POPJ	SP,

HSTPR%:
HSTPRT:	PUSH	SP,%CHAN(DB)
	SETOM	%CHAN(DB)	; SET O/P = TTY:
	PUSHJ	SP,HSTPR.
	POP	SP,%CHAN(DB)	; RESTORE OLD CHANNELS.
	POPJ	SP,

ERRM21:	ASCIZ	/
In procedure /
ERRM22:	ASCIZ	/
In un-traced procedure/
ERRM23:	ASCIZ	/
Called from procedure /
ERRM24:	ASCIZ	/
Called from un-traced procedure/
ERRM25:	ASCIZ	/
Called from main program/
ERRM26:	ASCIZ	/
in main program/
ERRM27:	ASCIZ	/ at line /
ERRM31:	ASCIZ/, level/		;[P64]
PATCH (64) ; UNWIND COMMAND.
PATCH(30)	; NEW CORE UUO

	STKEXT=10		;Maximum stack extension

EDIT(732); FAIL PROPERLY IF CANT GET ENOUGH CORE
CORE0:	HRRZ	A0,.JBUUO	; EXTEND PROGRAM CORE
	CORE	A0,		; AND TRY TO GET IT
	 SYSER1	2,0		; [E732] FAILED
	LRLOAD	A0,%SYS16(DB)	; OK - RESTORE A0,A1
	JRST	@%UUO(DB)

CORE2:	HRRZ	A0,.JBUUO	;  SHIFT THE STACK
	ADDI	A0,STKEXT+1(SP)	; FIND CORE REQUIRED
	CAMG	A0,.JBREL	; GOT IT?
	JRST	CORE3		; YES
	CORE	A0,		; TRY TO EXPAND CORE
	 SYSER1	2,0		; [E732] FAILED

CORE3:	HLLM	DB,%ACCS+DB(DB)	; [E534] SAVE DB FLAGS
	TLZ	DB,777777	; [E534]  & CLEAR LEFT HALF
EDIT (534)	; STACK-SHIFTER FAILED TO STOP BLT'ING ON KI10
	LRSTOR	A2,%SYS14(DB)
PATCH (4)	; STACK-SHIFTER STATS
	AOS	%SYS20(DB)	; COUNT STACK-SHIFTS
	MOVEI	A0,STKEXT(SP)	; REMEMBER OLD STACK TOP
	HRRZ	A1,.JBUUO	; RESTORE SIZE OF SHIFT
	HRLI	A1,(A1)		; GET IN BOTH HALVES
	ADD	SP,A1		; MOVE UP STACK POINTER
	MOVEI	A2,(SP)
	SUB	A2,.JBREL
	HRLI	SP,(A2)		; SET UP LHS
	HRLZI	A2,(DB)		; REMEMBER OLD DB
	ADDI	DB,(A1)		; MOVE UP DB
	HRRI	A2,(DB)		; FORM BLT POINTER
	CAIL	A0,(DB)		; ONE BLT OK?
	JRST	CORE5		; ALAS, NO
	BLT	A2,STKEXT(SP)	; YES - MOVE IT ALL
CORE4:	HRRZ	A0,.JBUUO	; RESTORE SHIFT
	ADD	DL,A0		; MOVE UP DL
	ADDM	A0,%TTY+BYTPTR(DB)
	ADDM	A0,%TTY+BDDOFF+BYTPTR(DB)
	ADDM	A0,%IODR-1(DB)	; SHIFT UP CHANNEL -1 TTY
	ADDM	A0,.JB41	; SHIFT UP UUO TRAP
	ADDM	A0,.JBINT	; SHIFT UP CONTROL-C TRAP
	ADDM	A0,.JBOPS	; SHIFT UP JOBOPS
	HRRI	A0,%ES-1(DB)	; UPDATE EMERGENCY
	HRRM	A0,%ESP(DB)	; STACK POINTER
	LRLOAD	A0,%SYS16(DB)	; RESTORE
	LRLOAD	A2,%SYS14(DB)	;  ACCS.
	HLL	DB,%ACCS+DB(DB)	; [E534] RESTORE DB FLAG-BITS
EDIT (534)	; STACK-SHIFTER FAILED TO STOP BLT'ING ON KI10
	JRST	@%UUO(DB)	; RETURN

CORE5:	MOVEI	A2,STKEXT+1(SP)
	HRLI	A2,(A2)
	SUBI	A2,(A1)
	MOVS	A2,A2
	SUB	A2,A1		; LOWEST SAFE BLT
	MOVEI	A3,STKEXT(SP)	; LAST DESTINATION WORD

CORE6:	MOVE	A0,A2		; COPY BLT POINTER
	BLT	A0,(A3)		; AND MOVE A BLOCK
	SUB	A2,A1		; MOVE DOWN POINTER
	SUBI	A3,(A1)		; AND LAST ADDRESS
	CAIGE	DB,(A2)		; TOO LOW OR HOME?
	JRST	CORE6		; NO - KEEP GOING
	MOVEI	A1,(DB)
	SUBI	A1,(A2)		; GET DIFFERENCE
	HRLI	A1,(A1)
	ADD	A2,A1		; NO - CORRECT BLT POINTER
	BLT	A2,(A3)		; LAST BLT
	JRST	CORE4
SUBTTL ERROR UUO MESSAGES

	MUUO=.-2
	XWD	M2-M3,M2
	XWD	M3-M4,M3
	XWD	M4-M5,M4
	XWD	M5-M6,M5

M2:	XWD	FATAL+0,M200	; SYSER1
	XWD	FATAL+1,M201
	XWD	FATAL+2,M202
	XWD	FATAL+3,M203
	XWD	FATAL+4,M204
	XWD	FATAL+5,M205
	XWD	FATAL+6,M206
	XWD	FATAL+7,M207
	XWD	FATAL+10,M210
	XWD	FATAL+11,M211
	XWD	FATAL+12,M212
	XWD	FATAL+13,M213
	XWD	FATAL+14,M214
	XWD	FATAL+15,M215
	XWD	FATAL+16,M216
	XWD	FATAL+17,M217

M3:	XWD	FATAL+20,M300	; SYSER2
	XWD	FATAL+21,M301
	XWD	22,M302
	XWD	23,M303
	XWD	FATAL+24,M304
	XWD	FATAL+25,M305
	XWD	FATAL+26,M306
	XWD	FATAL+27,M307
	XWD	FATAL+30,M310
PATCH (31)	; OVERLAYS

M4:	XWD	ERR2PT+ERRDEV+40+<M400A-M400>_6,M400
	XWD	ERR2PT+ERRDEV+41+<M401A-M401>_6,M401
	XWD	42,M402
	XWD	ERR2PT+ERRDEV+43+<M403A-M403>_6,M403
	XWD	44,M404
	XWD	ERR2PT+ERRDEV+ERRFIL+45+<M405A-M405>_6,M405
	XWD	ERRDEV+ERRFIL+46,M406
	XWD	ERRDEV+ERRFIL+47,M407
	XWD	ERRDEV+ERRFIL+50,M410
	XWD	ERRDEV+ERRFIL+51,M411
	XWD	ERRDEV+ERRFIL+52,M412
	XWD	ERRDEV+ERRFIL+53,M413
	XWD	54,M414
	IFN	FTOVRL,<
	XWD	55,M415>
PATCH (31)	; OVERLAYS
PATCH (17)	; IMPROVE I/O ERROR MESSAGES
M5:	XWD	60,M500		; LIBERR
	XWD	61,M501
	XWD	62,M502
	XWD	63,M503
	XWD	64,M504
	XWD	65,M505
	XWD	FATAL+66,M506
	XWD	FATAL+67,M507
M6:
M000:	ASCIZ /FATAL /
M001:	ASCIZ /Run-time error at address /
M002:	ASCIZ /
On line /
M003:	ASCIZ /, statement /

	IFN	DUMP,<
M100:	ASCIZ /%DUMP COMPLETED/
	>

	IFE	DUMP,<
M100:	ASCIZ/?DUMP ROUTINE NOT LOADED
/	>
M200:	ASCIZ /ILLEGAL UUO/
M201:	ASCIZ /MORE CORE REQUIRED TO START PROGRAM/
M202:	ASCIZ /MORE CORE REQUIRED TO CONTINUE PROGRAM/
M203:	ASCIZ /LOWER BOUND > UPPER BOUND IN ARRAY DECLARATION/
M204:	ASCIZ /ARRAY TOO LARGE FOR A PDP-10/
M205:	ASCIZ /WRONG NUMBER OF ARRAY SUBSCRIPTS/
M206:	ASCIZ /ARRAY SUBSCRIPT OUT OF RANGE/
M207:	ASCIZ /INVALID ACTUAL PARAMETER IN PROCEDURE CALL/
M210:	ASCIZ /WRONG NUMBER OF ACTUAL PARAMETERS IN PROCEDURE CALL/
M211:	ASCIZ /EXPRESSION-TYPE ACTUAL PARAMETER USED ON LHS OF ASSIGNMENT/
M212:	ASCIZ /ATTEMPT TO DELETE NON-EXISTENT BYTE STRING/
M213:	ASCIZ //
M214:	ASCIZ /BYTESIZE CONFLICTION IN STRING COMPARE/
M215:	ASCIZ /ILLEGAL BYTE SIZE/
M216:	ASCIZ /BYTE SUBSCRIPT OUT OF RANGE/
M217:	ASCIZ /ATTEMPT TO MODIFY STRING CONSTANT/
M300:	ASCIZ /SOURCE LEVEL ERROR/
M301:	ASCIZ /JUMP TO NON-EXISTENT LABEL/
M302:	ASCIZ /FLOATING POINT OVERFLOW/
M303:	ASCIZ /FIXED POINT OVERFLOW/
M304:	ASCIZ /ILLEGAL INSTRUCTION/
M305:	ASCIZ /?ALGIMR ILLEGAL MEMORY REFERENCE/
M306:	ASCIZ /UNTRAPPED CLOCK INTERRUPT/
M307:	ASCIZ /TRAP LABEL OUT OF SCOPE/
M310:	ASCIZ /OVERLAYS NOT IMPLEMENTED/
PATCH (31)	; OVERLAYS
PATCH (17)	; IMPROVE I/O ERROR MESSAGES

M400:	ASCIZ	/Input or output device /
M400A:	ASCIZ	/ unavailable on/
M401:	ASCIZ	/Illegal mode for input or output device /
M401A:	ASCIZ	/ on/
M402:	ASCIZ	/Input or output on undefined/
M403:	ASCIZ	/Attempt to read or write on directory device /
M403A:	ASCIZ	/ without file open, on/
M404:	ASCIZ	//
M405:	ASCIZ	/File /
M405A:	ASCIZ	/ not available or rename failure on/
M406:	ASCIZ	/Attempt to read or write over end-of-file on /
M407:	ASCIZ	/Error condition on input or output on /
M410:	ASCIZ	/Illegal character in numeric data on /
M411:	ASCIZ	/Overflow in numeric input data on /
M412:	ASCIZ	/Error condition on closing file /
M413:	ASCIZ	/Illegal input-output operation on /
M414:	ASCIZ	/Out of range I-O/
	IFN	FTOVRL,<
M415:	ASCIZ	/Attempt to use overlay handler's />
M500:	ASCIZ /Undefine operation (SQRT argument negative)/
M501:	ASCIZ /Undefined operation (LN argument zero or negative, or 0^0)/
M502:	ASCIZ /EXP argument too large/
M503:	ASCIZ /Undefined operation (inverse maths function argument out of range)/
M504:	ASCIZ /TAN argument too large/
M505:	ASCIZ \Monitor call (GETTAB) to get date/time failed\
M506:	ASCIZ /FORTRAN subprogram moved the ALGOL stack/
M507:	ASCIZ	/Run-time error detected by FORTRAN subprogram/
SUBTTL APR ERROR HANDLER

APRERR:	MOVEM	A1,%SYS17(DB)	; SAVE A1
	MOVE	A1,.JBTPC	; AND GET PC DUMP
	TLZN	A1,PCFPU	; FLOATING POINT UNDERFLOW?
	JRST	APR6		; NO
	TLZ	A1,PCOVL	; YES - CLEAR OVERFLOW FLAGS
	MOVEM	A1,.JBTPC
	LRSTOR	A2,%SYS15(DB)	; SAVE A2 AND A3
	MOVE	A2,-1(A1)	; GET MALICIOUS ORDER

APR1:	HLRZ	A3,A2
	LSH	A3,-11		; AND EXTRACT ORDER NO.
	CAIE	A3,<XCT>B62	; XCT?
	JRST	APR2		; NO
	MOVE	A1,%SYS17(DB)	; YES
	MOVE	A3,%SYS16(DB)	; RESTORE A1 AND A3
	MOVEM	A2,%SYS14(DB)	; SAVE ORDER
	MOVE	A2,%SYS15(DB)	; RESTORE A2
	MOVE	A2,@%SYS14(DB)	; AND EXTRACT ORDER XCT'D
	JRST	APR1

APR2:	HLRZ	A1,@.JBTPC
	LSH	A1,-5		; PICK UP NEXT ORDER
	CAIE	A1,<JFOVO>B58	; JFOVO?
	JRST	APR3		; NO
	AOS	.JBTPC		; YES - SKIP IT
	HLRZ	A1,A2
	LSH	A1,-5
	ANDI	A1,000017	; GET ACCUMULATOR NUMBER
	LRLOAD	A2,%SYS15(DB)	; RESTORE A2 AND A3
	CAIN	A1,A1		; A1 INVOLVED?
	MOVEI	A1,%SYS17(DB)	; YES - REPLACE BY ITS DUMP
	MOVEM	A1,%SYS14(DB)	; AND SAVE ADDRESS OF ACCUMULATOR
	MOVE	A1,(A1)		; GET ITS VALUE
	HLRE	A2,A1		; GET EXPONENT, EXTENDING SIGN
	ASH	A2,-11
	TSCE	A2,A2		; IF NEGATIVE, COMPLEMENT EXPONENT
	TLOA	A1,777000	; NEGATIVE - SET EXPONENT ALL ONES
	TLZ	A1,777000	; POSITIVE - SET EXPONENT ALL ZEROS
	CAMGE	A2,[
	XWD	000346,000346]	; WILL ALL OF MANTISSA DISAPPEAR?
	TDZA	A1,A1		; YES - SAVE VERY LONG AND SLOW SHIFT!
	ASH	A1,400000(A2)	; DENORMALIZE FRACTION TO SUIT OLD EXPONENT!!!!!
	MOVE	A2,%SYS15(DB)	; RESTORE A2 AGAIN
	MOVEM	A1,@%SYS14(DB)	; AND RESET RELEVANT ACCUMULATOR
	MOVE	A1,%SYS17(DB)	; RESTORE A1
	JRSTF	@.JBTPC		; AND RETURN
APR3:	HLRZ	A1,A2
	LSH	A1,-5
	ANDI	A1,000017	; GET ACCUMULATOR NUMBER
	JUMPG	DB,.+3		; JUMP IF KA10
	CAIG	A3,<DFDV>B62	; DFAD, DFSB, DFMP OR DFDV?
	MOVEI	A3,1		; YES - TREAT AS FADL ETC.
	CAIN	A3,<FSC>B62	; FSC?
	TDZA	A3,A3		; YES - RECODE
	ANDI	A3,000007	; SELECT BOTTOM 3 BITS
	HLL	A1,APR5(A3)	; CONSTRUCT 1ST ORDER
	HRRE	A3,APR5(A3)
	JUMPGE	A3,APR4
	MOVE	A2,A1		; LONG ORDER
	ADDI	A2,1		; FORM ACC+1
	TRZA	A2,000020	; WITH WRAP-AROUND

APR4:	DPB	A3,[
	POINT	9,A2,8]		; CONSTRUCT 2ND ORDER
	EXCH	A1,%SYS17(DB)	; PLANT ORDERS 
	EXCH	A2,%SYS15(DB)	; RELOAD A1,A2
	MOVE	A3,%SYS16(DB)	; AND A3
	XCT	%SYS17(DB)
	XCT	%SYS15(DB)	; EXECUTE ORDERS
	JRSTF	@.JBTPC		; AND RETURN

APR5:	XWD	<SETZM>B53,<CAI>B62
	XWD	<SETZM>B53,400000
	XWD	<CAI>B53,<SETZM>B62
	XWD	<SETZM>B53,<SETZM>B62
	XWD	<SETZM>B53,<CAI>B62
	XWD	<SETZM>B53,<CAI>B62
	XWD	<CAI>B53,<SETZM>B62
	XWD	<SETZM>B53,<SETZM>B62

APR6:	TLNN	A1,PCFPO	; FLOATING POINT OVERFLOW?
	JRST	APR8		; NO
	MOVE	A1,(A1)		; PICK UP NEXT ORDER
	MOVEM	A1,%SYS16(DB)	; AND SAVE IT
	LSH	A1,-27
	ANDI	A1,017767
	CAIE	A1,<JFOV>B58	; IS IT JFOV OR JFOVO?
	JRST	APR7		; NO
	MOVE	A1,%SYS17(DB)	; YES - RESTORE A1
	JRST	@%SYS16(DB)	; AND OBEY JFOV

APR7:	MOVE	A1,%SYS17(DB)
	SYSER2	2,@.JBTPC	; YES
	JRSTF	@.JBTPC		; IN CASE OF CONTINUE.
APR8:	TLNN	A1,PCO		; FIXED POINT OVERFLOW?
	JRST	APR10		; NO
	MOVE	A1,(A1)		; PICK UP NEXT ORDER
	MOVEM	A1,%SYS16(DB)	; AND SAVE IT
	LSH	A1,-27
	CAIE	A1,<JOV>B58	; IS IT JOV?
	JRST	APR9		; NO
	MOVE	A1,%SYS17(DB)	; YES - RESTORE A1
	JRST	@%SYS16(DB)	; AND OBEY JOV

APR9:	MOVE	A1,%SYS17(DB)
	SYSER2	3,@.JBTPC	; YES
	JRSTF	@.JBTPC		; IN CASE OF CONTINUE.

APR10:	MOVE	A1,.JBCNI	; GET APR FLAGS
	TRNN	A1,APRNXM!APRMPV
				; MEMORY PROTECT VIOLATION?
	JRST	APR12		; NO
	SKIPL	DB		; SKIP IF KI10
	SOSA	A1,.JBTPC	; ELSE - LOAD DECREMENTED PC
	HRRZ	A1,.JBTPC	; NOT DECREMENTED ON KI
	ANDI	A1,-1
	CAIN	A1,-1		; NON-EXISTENT LABEL?
	SYSER2	1,0		; YES
	CAMLE	A1,.JBREL	; NO - ADDRESS OK?
	JRST	APR11		; NO - LEAVE IT ALONE
	HLRZ	A1,(A1)		; YES - GET BAD ORDER
	ANDI	A1,777017	; AND SELECT OPCODE AND INDEX
	CAIE	A1,<MOVEM	0,(SP)>B53
				; STORE AHEAD ON STACK?
	JRST	APR11		; NO
	MOVE	A1,.JBREL	; YES
	JRST	APR15

APR11:	MOVE	A1,%SYS17(DB)	; NO
	SYSER2	5,@.JBTPC

APR12:	TRNE	A1,APRPLO	; PDL OVERFLOW?
	JRST	APR13		; YES
	MOVE	A1,%SYS17(DB)
	SYSER2	6,@.JBTPC	; NO - MUST BE CLOCK FLAG

APR13:	MOVE	A1,.JBREL	; PDL OVERFLOW OR BAD MOVEM ON STACK
	CAILE	A1,(SP)		; OUT OF CORE?
	JRST	APR14		; NO
APR15:	ADDI	A1,2000
	EXCH	A1,%SYS17(DB)	; RESTORE SAVED A1
	MOVEM	DB,%SYS15(DB)	; SAVE DB
	TLZ	DB,INDDT	; AND TURN OFF "IN DDT" BIT
	CCORE	@%SYS17(DB)	; TRY TO EXPAND
	MOVE	DB,%SYS15(DB)	; PICK UP DB AGAIN

APR14:	MOVEI	A1,(SP)
	SUB	A1,.JBREL
	HRLI	SP,(A1)		; RESET LH NEGATIVE COUNT
	MOVE	A1,%SYS17(DB)	; RESTORE A1
	JRSTF	@.JBTPC		; AND RE-ENTER PROGRAM
SUBTTL Debuggiing system - object code dump routine.


; Old DUMPR UUO: give error message.
DUMP0:	MOVEI	A1,M100
	PUSHJ	SP,MONIT0	; TELL HIM NO DUMPS ALLOWED
	JRST	@%UUO(DB)	;  & RETURN
SUBTTL TYPE CONVERSION ROUTINES

; IR	INTEGER TO REAL
; ILR	INTEGER TO LONG REAL
; RI	REAL TO INTEGER
; LRI	LONG REAL TO INTEGER
; LRR	LONG REAL TO REAL

; ON ENTRY, THE ARGUMENT IS IN A0 OR A0,A1
; ON EXIT, THE RESULT IS IN A0 OR A0,A1

IR:	JUMPL	DB,IR1
	IDIVI	A0,400		; SEPARATE HIGH AND LOW HALVES
	JUMPE	A0,.+2		; ONLY 18 BITS?
	TLC	A0,243000	; NO - SET UP HIGH HALF EXPONENT
	TLC	A1,233000	; SET UP LOW HALF EXPONENT
	FADR	A0,A1		; AND ADD BITS TOGETHER
	JRST	@AX

IR1:	FLTR	A0,A0
	JRST	@AX

ILR:	IDIVI	A0,400		; SEPARATE HIGH AND LOW HALVES
	JUMPE	A0,.+2		; ONLY 18 BITS?
	TLC	A0,243000	; NO - SET UP HIGH HALF EXPONENT
	TLC	A1,233000	; SET UP LOW HALF EXPONENT
	FADL	A0,A1		; AND ADD BITS TOGETHER
	JUMPG	DB,@AX
	TLZ	A1,777000	; IF KI10, WIPE OUT LOW WORD EXPONENT
	LSH	A1,10		; AND SHIFT UP MANTISSA
	JRST	@AX

RI:	JUMPL	DB,RI1		; EDIT # 426
	FADRI	A0,200400	; RI - ADD 0.5
	MULI	A0,400		; SEPARATE EXPONENT AND MANTISSA
	EXCH	A0,A1
	TSC	A1,A1		; FIX UP EXPONENT
	ASH	A0,-243(A1)	; AND SHIFT MANTISSA TO FORM INTEGER
	JRST	@AX

RI1:	FIXR	A0,A0
	JRST	@AX
EDIT(726); Dont destroy A2 in LRI
LRI:	PUSH	SP,A2
	JUMPL	DB,LRI1
	MOVE	A2,A1		; LRI - ADD 0.5
	FADL	A0,[0.5]
	UFA	A1,A2
	FADL	A0,A2
	JRST	LRI2

LRI1:	DFAD	A0,[
	EXP	0.5,0.0]	; LRI - ADD 0.5

LRI2:	HLRZ	A2,A0
	LSH	A2,-11
	ANDI	A2,000377	; EXTRACT HIGH ORDER EXPONENT
	TLZ	A0,377000	; AND CLEAR IT OUT
	JUMPGE	A0,.+3		; NUMBER POSITIVE?
	TRC	A2,000377	; NO - COMPLEMENT EXTRACTED EXPONENT
	TLO	A0,377000	; AND SET ALL ONES
	JUMPL	DB,.+2
	LSH	A1,10		; IF KA10, SHIFT UP LOW ORDER MANTISSA
	ASHC	A0,-233(A2)	; SHIFT MANTISSA TO INTEGER
	JOV	CNVERR		; [E714] TRAP OVERFLOW
	POP	SP,A2
	JRST	@AX

EDIT(714); Allow LRI to be followed by a JOV error trap
CNVERR:	HLRZ	A2,(AX)		; [E714] GET NEXT INSTRUCTION
	TRZ	A2,37		; [E714] CLEAR INDEX & INDIRECT
	CAIE	A2,(JOV)	; [E714] OVERFLOW TRAP ?
	SYSER2	3,(AX)		; [E714] NO  - CAUSE ERROR
	POP	SP,A2		; [E726] TIDY UP THE STACK
	JRST	@(AX)		; [E714] YES - TAKE THE TRAP

LRR:	JUMPL	DB,LRR1
	FADR	A0,A1		; KA10
	JRST	@AX

LRR1:	JUMPGE	A0,LRR2		; ARGUMENT POSITIVE?
	DMOVN	A0,A0		; NO - NEGATE IT
	TLZA	A1,400000	; AND CLEAR BIT 0 FLAG

LRR2:	TLO	A1,400000	; YES - SET BIT ZERO FLAG
	TLNN	A1,200000	; ROUNDING REQUIRED?
	JRST	LRR3		; NO
	CAMN	A0,[
	XWD	377777,777777]	; YES - HIGH WORD TOO LARGE?
	SYSER2	2,0		; YES - REPORT OVERFLOW
	ADDI	A0,1		; NO
	TLO	A0,400		; CARRY

LRR3:	JUMPL	A1,@AX		; EXIT IF POSITIVE
	MOVN	A0,A0		; OTHERWISE NEGATE
	JRST	@AX
SUBTTL SPECIAL TYPE CONVERSION ROUTINES

; SIR	INTEGER TO REAL
; SILR	INTEGER TO LONG REAL
; SRI	REAL TO INTEGER
; SLRI	LONG REAL TO INTEGER
; SLRR	LONG REAL TO REAL

; ON ENTRY, THE ARGUMENT IS IN A0 OR A0,A1
; ON EXIT, THE RESULT IS IN A3 OR A3,A4

SIR:	JUMPL	DB,SIR1
	MOVE	A3,A0		; COPY ARGUMENT TO A3
	IDIVI	A3,400000	; SEPARATE HIGH AND LOW HALVES
	JUMPE	A3,.+2		; ONLY 18 BITS?
	TLC	A3,254000	; NO - SET UP HIGH HALF EXPONENT
	TLC	A4,233000	; SET UP LOW HALF EXPONENT
	FADR	A3,A4		; AND ADD BITS TOGETHER
	JRST	(AX)

SIR1:	FLTR	A3,A0
	JRST	(AX)

SILR:	MOVE	A3,A0		; COPY ARGUMENT TO A3
	IDIVI	A3,400000	; SEPARATE HIGH AND LOW HALVES
	JUMPE	A3,.+2		; ONLY 18 BITS?
	TLC	A3,254000	; NO - SET UP HIGH HALF EXPONENT
	TLC	A4,233000	; SET UP LOW HALF EXPONENT
	FADL	A3,A4		; AND ADD BITS TOGETHER
	JUMPL	DB,(AX)
	TLZ	A4,777000	; IF KI10, WIPE OUT LOW WORD EXPONENT
	LSH	A4,10		; AND SHIFT UP MANTISSA
	JRST	(AX)

SRI:	JUMPL	DB,SRI1
	MOVE	A3,A0		; COPY ARGUMENT TO A3
	FADRI	A3,200400	; RI - ADD 0.5
	MULI	A3,400		; SEPARATE EXPONENT AND MANTISSA
	EXCH	A3,A4
	TSC	A4,A4		; FIX UP EXPONENT
	ASH	A3,-243(A4)	; AND SHIFT MANTISSA TO FORM INTEGER
	JRST	(AX)

SRI1:	FIXR	A3,A0
	JRST	(AX)
SLRI:	JUMPL	DB,SLRI1
	LRLOAD	A3,A0		; COPY ARGUMENT TO A3,A4
	MOVE	A5,A4		; LRI - ADD 0.5
	FADL	A3,[0.5]
	UFA	A4,A5
	FADL	A3,A5
	JRST	SLRI2

SLRI1:	LRLOAD	A3,A0		; COPY ARGUMENT TO A3,A4
	DFAD	A3,[
	EXP	0.5,0.0]	; LRI - ADD 0.5

SLRI2:	HLRZ	A5,A3
	LSH	A5,-11
	ANDI	A5,000377	; EXTRACT HIGH ORDER EXPONENT
	TLZ	A3,377000	; AND CLEAR IT OUT
	JUMPGE	A3,.+3		; NUMBER POSITIVE?
	TRC	A5,000377	; NO - COMPLEMENT EXTRACTED EXPONENT
	TLO	A3,377000	; AND SET ALL ONES
	JUMPL	DB,.+2
	LSH	A4,10		; IF KA10, SHIFT UP LOW ORDER MANTISSA
	ASHC	A3,-233(A5)	; SHIFT MANTISSA TO INTEGER
	JRST	(AX)

SLRR:	JUMPL	DB,SLRR1
	MOVE	A3,A0		; GET HIGH ORDER WORD
	FADR	A3,A1		; ADD LOW ORDER WORD
	JRST	(AX)

SLRR1:	LRLOAD	A3,A0		; COPY ARGUMENT TO A3,A4
	JUMPGE	A3,SLRR2	; ARGUMENT POSITIVE?
	DMOVN	A3,A3		; NO - NEGATE IT
	TLZA	A4,400000	; AND CLEAR BIT ZERO FLAG

SLRR2:	TLO	A4,400000	; YES - SET BIT ZERO FLAG
	TLNN	A4,200000	; ROUNDING REQUIRED?
	JRST	SLRR3		; NO
	CAMN	A3,[
	XWD	377777,777777]	; YES - HIGH WORD TOO LARGE?
	SYSER2	2,0		; YES - REPORT OVERFLOW
	ADDI	A3,1		; NO
	TLO	A3,400		; CARRY

SLRR3:	JUMPL	A4,(AX)		; EXIT IF POSITIVE
	MOVN	A3,A3		; OTHERWISE NEGATE
	JRST	(AX)
SUBTTL SINGLE PRECISION POWERS OF TEN

STENM1:	XWD	175631,463146	; 1.0&-1
STEN:	XWD	201400,000000	; 1.0
STEN1:	XWD	204500,000000	; 1.0&1
	XWD	207620,000000	; 1.0&2
	XWD	212764,000000	; 1.0&3
	XWD	216470,400000	; 1.0&4
	XWD	221606,500000	; 1.0&5
	XWD	224750,220000	; 1.0&6
	XWD	230461,132000	; 1.0&7
	XWD	233575,360400	; 1.0&8
	XWD	236734,654500	; 1.0&9
	XWD	242452,013710	; 1.0&10
	XWD	245564,416672	; 1.0&11
	XWD	250721,522451	; 1.0&12
	XWD	254443,023471	; 1.0&13
	XWD	257553,630410	; 1.0&14
	XWD	262706,576512	; 1.0&15
	XWD	266434,157116	; 1.0&16
	XWD	271543,212741	; 1.0&17
	XWD	274674,055532	; 1.0&18
	XWD	300425,434430	; 1.0&19
	XWD	303532,743536	; 1.0&20
	XWD	306661,534466	; 1.0&21
	XWD	312417,031702	; 1.0&22
	XWD	315522,640262	; 1.0&23
	XWD	320647,410336	; 1.0&24
	XWD	324410,545213	; 1.0&25
	XWD	327512,676456	; 1.0&26
	XWD	332635,456171	; 1.0&27
	XWD	336402,374714	; 1.0&28
	XWD	341503,074077	; 1.0&29
	XWD	344623,713116	; 1.0&30
	XWD	347770,675742	; 1.0&31
	XWD	353473,426555	; 1.0&32
	XWD	356612,334311	; 1.0&33
	XWD	361755,023373	; 1.0&34
	XWD	365464,114135	; 1.0&35
	XWD	370601,137164	; 1.0&36
	XWD	373741,367021	; 1.0&37
STEN38:	XWD	377454,732313	; 1.0&38
SUBTTL DOUBLE PRECISION POWERS OF TEN

; HIGH ORDER WORDS

HTENM1:	XWD	175631,463146	; 1.0&&-1
HTEN:	XWD	201400,000000	; 1.0
HTEN1:	XWD	204500,000000	; 1.0&&1
	XWD	207620,000000	; 1.0&&2
	XWD	212764,000000	; 1.0&&3
	XWD	216470,400000	; 1.0&&4
	XWD	221606,500000	; 1.0&&5
	XWD	224750,220000	; 1.0&&6
	XWD	230461,132000	; 1.0&&7
	XWD	233575,360400	; 1.0&&8
	XWD	236734,654500	; 1.0&&9
	XWD	242452,013710	; 1.0&&10
	XWD	245564,416672	; 1.0&&11
	XWD	250721,522450	; 1.0&&12
	XWD	254443,023471	; 1.0&&13
	XWD	257553,630407	; 1.0&&14
	XWD	262706,576511	; 1.0&&15
	XWD	266434,157115	; 1.0&&16
	XWD	271543,212741	; 1.0&&17
	XWD	274674,055531	; 1.0&&18
	XWD	300425,434430	; 1.0&&19
	XWD	303532,743536	; 1.0&&20
	XWD	306661,534465	; 1.0&&21
	XWD	312417,031701	; 1.0&&22
	XWD	315522,640261	; 1.0&&23
	XWD	320647,410336	; 1.0&&24
	XWD	324410,545213	; 1.0&&25
	XWD	327512,676455	; 1.0&&26
	XWD	332635,456171	; 1.0&&27
	XWD	336402,374713	; 1.0&&28
	XWD	341503,074076	; 1.0&&29
	XWD	344623,713116	; 1.0&&30
	XWD	347770,675742	; 1.0&&31
	XWD	353473,426555	; 1.0&&32
	XWD	356612,334310	; 1.0&&33
	XWD	361755,023372	; 1.0&&34
	XWD	365464,114134	; 1.0&&35
	XWD	370601,137163	; 1.0&&36
	XWD	373741,367020	; 1.0&&37
HTEN38:	XWD	377454,732312	; 1.0&&38
; KA10 LOW ORDER WORDS

	XWD	142314,631463	; 1.0&&-1
LTENA:	XWD	000000,000000	; 1.0
	XWD	000000,000000	; 1.0&&1
	XWD	000000,000000	; 1.0&&2
	XWD	000000,000000	; 1.0&&3
	XWD	000000,000000	; 1.0&&4
	XWD	000000,000000	; 1.0&&5
	XWD	000000,000000	; 1.0&&6
	XWD	000000,000000	; 1.0&&7
	XWD	000000,000000	; 1.0&&8
	XWD	000000,000000	; 1.0&&9
	XWD	000000,000000	; 1.0&&10
	XWD	000000,000000	; 1.0&&11
	XWD	215400,000000	; 1.0&&12
	XWD	221240,000000	; 1.0&&13
	XWD	224510,000000	; 1.0&&14
	XWD	227432,000000	; 1.0&&15
	XWD	233760,200000	; 1.0&&16
	XWD	236354,240000	; 1.0&&17
	XWD	241647,310000	; 1.0&&18
	XWD	245110,475000	; 1.0&&19
	XWD	250132,614200	; 1.0&&20
	XWD	253561,357240	; 1.0&&21
	XWD	257446,725444	; 1.0&&22
	XWD	262760,512755	; 1.0&&23
	XWD	265354,635550	; 1.0&&24
	XWD	271024,002441	; 1.0&&25
	XWD	274631,003151	; 1.0&&26
	XWD	277177,204004	; 1.0&&27
	XWD	303617,422402	; 1.0&&28
	XWD	306563,327103	; 1.0&&29
	XWD	311320,214724	; 1.0&&30
	XWD	314004,260111	; 1.0&&31
	XWD	320202,556055	; 1.0&&32
	XWD	323443,311471	; 1.0&&33
	XWD	326554,174007	; 1.0&&34
	XWD	332543,515404	; 1.0&&35
	XWD	335674,440705	; 1.0&&36
	XWD	340653,551067	; 1.0&&37
	XWD	344413,241542	; 1.0&&38
; KI10 LOW ORDER WORDS

	XWD	146314,631464	; 1.0&&-1
LTENI:	XWD	000000,000000	; 1.0
	XWD	000000,000000	; 1.0&&1
	XWD	000000,000000	; 1.0&&2
	XWD	000000,000000	; 1.0&&3
	XWD	000000,000000	; 1.0&&4
	XWD	000000,000000	; 1.0&&5
	XWD	000000,000000	; 1.0&&6
	XWD	000000,000000	; 1.0&&7
	XWD	000000,000000	; 1.0&&8
	XWD	000000,000000	; 1.0&&9
	XWD	000000,000000	; 1.0&&10
	XWD	000000,000000	; 1.0&&11
	XWD	200000,000000	; 1.0&&12
	XWD	120000,000000	; 1.0&&13
	XWD	244000,000000	; 1.0&&14
	XWD	215000,000000	; 1.0&&15
	XWD	370100,000000	; 1.0&&16
	XWD	166120,000000	; 1.0&&17
	XWD	323544,000000	; 1.0&&18
	XWD	044236,400000	; 1.0&&19
	XWD	055306,100000	; 1.0&&20
	XWD	270567,520000	; 1.0&&21
	XWD	223352,622000	; 1.0&&22
	XWD	370245,366400	; 1.0&&23
	XWD	166316,664100	; 1.0&&24
	XWD	012001,220450	; 1.0&&25
	XWD	314401,464562	; 1.0&&26
	XWD	077502,001717	; 1.0&&27
	XWD	307611,201141	; 1.0&&28
	XWD	271553,441371	; 1.0&&29
	XWD	150106,351670	; 1.0&&30
	XWD	002130,044246	; 1.0&&31
	XWD	101267,026547	; 1.0&&32
	XWD	221544,634301	; 1.0&&33
	XWD	266076,003362	; 1.0&&34
	XWD	261646,602127	; 1.0&&35
	XWD	336220,342555	; 1.0&&36
	XWD	325664,433310	; 1.0&&37
	XWD	205520,661075	; 1.0&&38

	END