.TITLE	ERROR		
; JEFFREY KODOSKY	ARL	NOV75
;
; SUBR
; ENTRY:	1 ARG		<S>
; EXIT:		N/A
; ERRORS:	GENERATES A RECOVERABLE ERROR
;		(KILL--NON-RECOVERABLE)
; CALLS:	PRNT
;		PRIN1
;		MAINLOOP
;		OCO
; TRANSFERRS TO GENERAL ERROR AND TRACEBACK HANDLER
	.GLOBL	ADERST,ADPROG,QPRNT,QPRIN1,QMAINLOOP,LASTPR
	.GLOBL	ERROR,ZERROR,KILL,ZKILL,ENDLSP,SSTART,LSPXT
	.GLOBL	FCTLOW,FCTDTL,FCTATM,FCTSIZ,QOCO,OUTSYS,INSYS,$ALIST
ERROR:	MOV	(R5)+,-(SP)	;SAVE ARG
	MOV	#BUFE,-(SP)	;BLANK BUFFER
	BR	ERRORH
ZERROR=.-ERROR
;
KILL:	MOV	(R5)+,-(SP)	;SAVE ARG
	MOV	#BUFE,-(SP)	;BLANK BUFFER
KILLH:	MOV	#BUFK,-(SP)
	MOV	ENDLSP,R5	;FLUSH ARG STACK
	TST	-(R5)		;(LEAVE OBLIST ON?)
	MOV	#3,FLAG		;FORCE EXIT AND PRINTING
	BR	ERR02
ZKILL=.-KILL
	.PAGE
ERRORH:	MOV	#7,FLAG	;INIT TO ALLOW RE-ENTRY AND PRINTING
	MOV	#BUF,-(SP)
	MOV	R4,R0	;LOOK FOR MARKED ARG WITH ERRSET PC
ERR01:	BIT	#1,(R5)+
	BNE	ERR03	;JUMP IF MARKED ARG FOUND
	CMP	R5,ENDLSP	;HIT TOP OF ARG STACK?
	BLO	ERR01	;NO: LOOP BACK
	BHI	T2ERR	;JUMP IF OVER TOP (SHOULD NEVER HAPPEN!)
	TST	-(R5)	;LEAVE OBLIST ON STACK
ERR02:	MOV	SSTART,R0	;R0 POINTS TO 1ST ITEM TO REMAIN
	CMP	@R0,#LSPXT	;ON SUBR STACK (SHOULD ALWAYS
	BNE	T2ERR	;BE LSPXT...IF NOT THEN FATAL ERROR)
	JMP	ERR10
ERR03:	CMP	-(R0),#ADERST	;LOOK FOR ERRSET RETURN PC
	BEQ	ERR04	;JUMP IF FOUND
	CMP	@R0,#ADPROG
	BEQ	ERR01	;JUMP IF IT WAS PROG  AND CONTINUE
	CMP	R0,SSTART	;TO LOOK FOR ERRSET
	BHI	ERR03
	BR	T3ERR	;JUMP IF HIT BOTTOM OF SUBR STACK
ERR04:	TST	-(R0)	;POP ERRSET ADDR OFF SUBR STACK
	TST	-(R5)	;POINT TO <BOOL1>
	ASR	FLAG	;NO RESTART FLAG:=3
	DEC	(R5)+
	BNE	ERR05	;JUMP IF <BOOL1>:=T
	CLR	FLAG	;FLAG NO PRINTING OF ERROR MSG OR TRACEBK
ERR05:	TST	(R5)+
	BNE	ERR10	;JUMP IF <BOOL2>:=T
	BIC	#2,FLAG	;FLAG NO PRINT TRACEBACK
	BR	ERR10
; FATAL SYSTEM ERRORS
	.GLOBL	T1ERR,T2ERR,T3ERR,O1ERR,O2ERR
T1ERR:	CLR	-(SP)		;ILLEGAL TRAP CODE
	MOV	#BUFT1,-(SP)
	BR	KILLH
T2ERR:	MOV	SSTART,R0	;CORRUPTED STACKS
	MOV	#LSPXT,@R0
	TST	(R0)+
	CMP	R4,R0
	BHIS	.+4
	MOV	R0,R4
	CLR	-(SP)
	MOV	#BUFT2,-(SP)
	BR	KILLH
T3ERR:	CLR	-(SP)		;MARKED ITEM OCCURS WITHOUT
	MOV	#BUFT3,-(SP)	;PROG OR ERRSET
	BR	KILLH
O1ERR:	CLR	-(SP)		;INPUT ERROR
	MOV	#BUFO1,-(SP)
	BR	KILLH
O2ERR:	CLR	-(SP)		;OUTPUT ERROR
	MOV	#BUFO2,-(SP)
	BR	KILLH
; RECOVERABLE ERRORS
	.GLOBL	A1ERR,A2ERR,A3ERR,A4ERR,A5ERR,A6ERR,A7ERR,A8ERR
	.GLOBL	A9ERR,A10ERR,F1ERR,F2ERR,G1ERR,G2ERR,GC1ERR
	.GLOBL	GC2ERR,I1ERR,I2ERR,I3ERR,I4ERR,I5ERR,R1ERR,R2ERR
	.GLOBL	R3ERR,R4ERR,R5ERR,R6ERR
	.GLOBL	IO1ERR,IO2ERR,IO3ERR,IO4ERR
A1ERR:	BR	T1ERR		;<UNUSED>
A2ERR:	MOV	#BUFA2,-(SP)	;FUNCTION OBJECT HAS NO
	BR	ERRARG		;DEFINITION--APPLY
A3ERR:	BR	T1ERR		;<UNUSED>
A4ERR:	MOV	#BUFA4,-(SP)	;RETURN OCCURS OUTSIDE PROG
	BR	ERRNOA		;CONTEXT
A5ERR:	MOV	#BUFA5,-(SP)	;GO OCCURS OUTSIDE PROG CONTEXT
	BR	ERRNOA
A6ERR:	MOV	#BUFA6,-(SP)	;GO REFERS TO UNASSIGNED LABEL
	BR	ERRARG
A7ERR:	MOV	#BUFA7,-(SP)	;ILLEGAL FIRST ARG TO SET
	BR	ERRARG
A8ERR:	MOV	#BUFA8,-(SP)	;UNBOUND VARIABLE--EVAL
	BR	ERRARG
A9ERR:	MOV	#BUFA9,-(SP)	;FUNCTION OBJECT HAS NO
	BR	ERRARG		;DEFINITION--EVAL
A10ERR:	MOV	#BUFA10,-(SP)	;CAR OR CDR OF ATOM
	BR	ERRARG
F1ERR:	MOV	#BUFF1,-(SP)	;IMPROPER NUMBER OF SUBR ARGS
	BR	ERRNOA
F2ERR:	MOV	#BUFF2,-(SP)	;IMPROPER NUMBER OF EXPR ARGS
	BR	ERRARG		;?
G1ERR:	BR	T1ERR		;<UNUSED>
G2ERR:	MOV	#BUFG2,-(SP)	;RECURSION LIMIT EXCEEDED
	BR	ERRNOA
ERRARG:	MOV	@SP,-(SP)	;INSERT ARG
	MOV	(R5)+,2(SP)
	BR	ERRORH
ERRNOA:	MOV	@SP,-(SP)	;NO ARG
	CLR	2(SP)
	BR	ERRORH
GC1ERR:	BR	T1ERR		;<UNUSED>
GC2ERR:	MOV	#BUFGC2,-(SP)	;FREE SPACE EXHAUSTED
	BR	ERRNOA
I1ERR:	MOV	#BUFI1,-(SP)	;ARRAY SPACE EXHAUSTED
	BR	ERRARG
I2ERR:	MOV	#BUFI2,-(SP)	;IMPROPER ARG FOR NUMERIC
	BR	ERRARG		;FUNCTION
I3ERR:	BR	T1ERR		;<UNUSED>
I4ERR:	MOV	#BUFI4,-(SP)	;UNDEFINED ARITHMETIC OPERATION
	BR	ERRNOA
I5ERR:	MOV	#BUFI5,-(SP)	;IMPROPER ARGUMENT TO ARRAY
	BR	ERRARG		;FUNCTION
IO1ERR:	MOV	#BUFIO1,-(SP)	;ILLEGAL FILE SPECIFICATION OR
	BR	ERRARG		;CHANNEL NUMBER
IO2ERR:	MOV	#BUFIO2,-(SP)	;ATTEMPT TO OPEN TOO MANY CHANNELS
	BR	ERRNOA
IO3ERR:	MOV	#BUFIO3,-(SP)	;DEVICE HANDLER AND I/O BUFFER
	BR	ERRNOA		;SPACE EXHAUSTED
IO4ERR:	MOV	#BUFIO4,-(SP)	;ATTEMPT TO CLOSE SYSOUT
	BR	ERRNOA
R1ERR:	MOV	#BUFR1,-(SP)	;,)] OUT OF CONTEXT
	BR	ERRNOA
R2ERR:	MOV	#BUFR2,-(SP)	;. OUT OF CONTEXT
	BR	ERRNOA
R3ERR:	MOV	#BUFR3,-(SP)	;UNMATCHED (
	BR	ERRNOA
R4ERR:	MOV	#BUFR4,-(SP)	;TOO MANY ( OR [
	BR	ERRNOA
R5ERR:	MOV	#BUFR5,-(SP)	;UNDECODABLE NUMBER
	BR	ERRNOA
R6ERR:	MOV	#BUFR6,-(SP)	;STRING OR PNAME TOO LONG
	BR	ERRNOA
ERR10:	MOV	R0,R0TMP	;SAVE STACK RESET
	MOVB	#-1,OUTSYS+1	;RESTORE SYSIN AND SYSOUT
	MOVB	#-1,INSYS+1
	ASR	FLAG
	BCC	ERR12	;JUMP IF NO PRINT ERROR MESSAGE
	MOV	(SP)+,R3
	QPRNT		;PRINT HEADER
	MOV	(SP)+,R3
	QPRNT		;PRINT ERROR CODE
	MOV	(SP)+,-(R5)
	BEQ	ERR11
	CLR	LASTPR	;FORCE A DELIMITER TO BE PRINTED
	QPRIN1		;PRINT NON-NULL ARG
ERR11:	TST	(R5)+	;POP RESULT OF PRINT
	MOV	#BUFCLS+1,R3	;PRINT CRLF
	QPRNT
	BR	ERR13
ERR12:	ADD	#6,SP	;POP ARGS
ERR13:	ASR	FLAG
	BCC	ERR20	;JUMP IF NO PRINT TRACEBACK
	MOV	#BUFOPN,R3	;PRINT (
	QPRNT
	MOV	#1,LASTPR	;NO DELIMITER NOW
ERR15:	MOV	-(R4),R0;POP ANOTHER RETURN PC
	CMP	R4,R0TMP
	BEQ	ERR19	;JUMP IF DONE
	BHIS	.+6
	JMP	T2ERR
	MOV	#FCTLOW,R1
	MOV	#FCTSIZ,R2
ERR16:	CMP	R0,@R1	;CHECK AGAINST FCT LO LIMIT
	BLO	ERR17	;JUMP IF TOO LOW
	MOV	@R2,-(SP)
	ADD	@R1,@SP
	CMP	R0,(SP)+;CHECK AGAINST HI LIMIT
	BLO	ERR18	;JUMP IF WITHIN LIMITS
ERR17:	CMP	(R1)+,(R2)+	;BUMP TO NEXT FCT
	CMP	R1,#FCTDTL	;END OF TABLE?
	BLO	ERR16
	MOV	#BUFOCT,-(SP)	;YES: PRINT ADDRESS IN OCTAL
	MOV	#6,-(SP)
	MOV	R0,-(SP)
	QOCO
	MOV	#BUFOCT,R3
	QPRNT
	BR	ERR15
ERR18:	SUB	#FCTLOW,R1	;GET FCT ATOM POINTER
	ADD	#FCTATM,R1
	MOV	@R1,-(R5)
	QPRIN1		;PRINT IT
	TST	(R5)+	;POP IT
	BR	ERR15
ERR19:	TST	(R4)+	;LEAVE LSPXT OR ERRSET CALLER ON STACK
	MOV	#BUFCLS,R3	;PRINT ) CR-LF
	QPRNT
ERR20:	MOV	@#42,SP	;RESET SP STACK
	CMP	-(SP),-(SP)
	ASR	FLAG	;RESTART?
	BCS	ERR21
	CLR	-(R5)	;NO: RETURN A NIL
	JMP	@-(R4)	;JUMP TO ERRSET CALLER OR LSPXT
ERR21:	CLR	$ALIST
	QMAINLOOP	;YES: RECALL MAINLOOP
	.WORD	0
	.NLIST	BEX
FLAG:	.WORD	0
R0TMP:	.WORD	0
BUF:	.BYTE	15,12
	.ASCIZ	/***** ERROR /
BUFE=.-2
BUFK:	.BYTE	15,12
	.ASCIZ	/***** KILLED /
BUFT1:	.ASCIZ	/T1/
BUFT2:	.ASCIZ	/T2/
BUFT3:	.ASCIZ	/T3/
BUFO1:	.ASCIZ	/O1/
BUFO2:	.ASCIZ	/O2/
BUFA1:	.ASCIZ	/A1/
BUFA2:	.ASCIZ	/A2/
BUFA3:	.ASCIZ	/A3/
BUFA4:	.ASCIZ	/A4/
BUFA5:	.ASCIZ	/A5/
BUFA6:	.ASCIZ	/A6/
BUFA7:	.ASCIZ	/A7/
BUFA8:	.ASCIZ	/A8/
BUFA9:	.ASCIZ	/A9/
BUFA10:	.ASCIZ	/A10/
BUFF1:	.ASCIZ	/F1/
BUFF2:	.ASCIZ	/F2/
BUFG1:	.ASCIZ	/G1/
BUFG2:	.ASCIZ	/G2/
BUFGC1:	.ASCIZ	/GC1/
BUFGC2:	.ASCIZ	/GC2/
BUFI1:	.ASCIZ	/I1/
BUFI2:	.ASCIZ	/I2/
BUFI3:	.ASCIZ	/I3/
BUFI4:	.ASCIZ	/I4/
BUFI5:	.ASCIZ	/I5/
BUFIO1:	.ASCIZ	/IO1/
BUFIO2:	.ASCIZ	/IO2/
BUFIO3:	.ASCIZ	/IO3/
BUFIO4:	.ASCIZ	/IO4/
BUFR1:	.ASCIZ	/R1/
BUFR2:	.ASCIZ	/R2/
BUFR3:	.ASCIZ	/R3/
BUFR4:	.ASCIZ	/R4/
BUFR5:	.ASCIZ	/R5/
BUFR6:	.ASCIZ	/R6/
BUFCLS:	.BYTE	'),15,12,0
BUFOPN:	.BYTE	'(,0
BUFOCT:	.BLKB	6
BUFSPC:	.ASCIZ	/ /
	.EVEN
	.LIST	BEX
	.END