00100	TITLE LISP
00200	
00300	;storage allocation map.
00400	
00500		orgLSP: . 	;LISP interpreter.
00600		sizLSP:	efolst-.-1
00700		endLSP: efolst-1
00800	
00900		orgBPS: 0	;Binary Program Space.
01000		sizBPS:	2000
01100		endBPS: 0
01200		
01300		orgHWS: 0	;Half Word Space.
01400		sizHWS:	0
01500		endHWS: 0
01600	
01700		orgFWS: 0	;Full Word Space.
01800		sizFWS:	1000
01900		endFWS: 0
02000	
02100		orgHBT: 0	;Halfwords Bit Tables.
02200		sizHBT:	0
02300		endHBT: 0
02400	
02500		orgFBT: 0	;Fullwords Bit Table
02600		sizFBT:	0
02700		endFBT: 0
02800		
02900		orgPDL: 0	;regular PDL.
03000		sizPDL:	1000
03100		endPDL: 0
03200	
03300		orgSPD: 0	;special PDL.
03400		sizSPD:	1000
03500		endSPD: 0
     

00010	;SAIL JOBDAT ADDRESSES.
00020		SAI41:	0
00030		SAIAPR:	0
00100	;SAIL ACCUMULATORS.
00200		AC0:	0
00300		AC1:	0
00400		AC2:	0
00500		AC3:	0
00600		AC4:	0
00700		AC5:	0
00800		AC6:	0
00900		AC7:	0
01000		AC10:	0
01100		AC11:	0
01200		AC12:	0
01300		AC13:	0
01400		AC14:	0
01500		AC15:	0
01600		AC16:	0
01700		AC17:	0
01800	;LISP ACCUMULATORS.
01900		LISPAC:	BLOCK 20
02000	
02100	;Olde switch and pointers.
02200		EFWSO:	0
02300		RETFLG:	0
02400		BSFLG:	0	;Boot Strape initialization done.
     

00100	SUBTTL AC DEFINITIONS AND EXTERNALS 		--- PAGE 1
00200	IF1,<PURGE CDR,DF>
00300	MLON
00400	INUMIN=377777
00500	INUM0=<INUMIN+777777>/2
00600	BCKETS==177
00700	
00800	;accumulator definitions
00900	;`sacred' means sacred to the interpreter
01000	;`marked' means marked from by the garbage collector
01100	;`protected' means protected during garbage collection
01200	
01300	NIL=0	;sacred, marked, protected	;atom head of NIL
01400	A=1	;marked, protected	;results of functions and first arg of subrs
01500	B=A+1	;marked, protected	;second arg of subrs
01600	C=B+1	;marked, protected	;third arg of subrs
01700	AR1=4	;marked, protected	;fourth arg of subrs
01800	AR2A=5	;marked, protected	;fifth arg of subrs
01900	T=6	;marked, protected	;minus number of args in LSUBR call
02000	TT=7	;marked, protected
02100	REL=10	;marked, protected	;rarely used
02200	S=11	;rarely used
02300	D=12	
02400	R=13	;protected
02500	P=14	;sacred, protected	;regular push down stack pointer
02600	F=15	;sacred	;free storage list pointer
02700	FF=16	;sacred	;full word list pointer
02800	SP=17	;sacred, protected	;special pushdown stack pointer
02900	
03000	NACS==5	;number of argument acs
03100	
03200	X==0	;X indicates impure (modified) code locations
03300	TEN==↑D10
     

00100	;ALTERNATE PDP-10 MNEMONICS.
00200	
00300		OPDEF LIP[HLR]
00400		OPDEF LAP[HRR]
00500		OPDEF DIP[HRLM]
00600		OPDEF DAP[HRRM]
00700		
00800		OPDEF LIPZ[HLRZ]
00900		OPDEF LAPZ[HRRZ]
01000		OPDEF DIPZ[HRLZM]
01100		OPDEF DAPZ[HRRZM]
01200	
01300		OPDEF LAC[MOVE]
01400		OPDEF DAC[MOVEM]
01500		OPDEF LACN[MOVN]
01600		OPDEF DACN[MOVNM]
     

00100	;UUO definitions
00200	;UUOs used to call functions from compiled code
00300	;the number of arguments is given by the ac field 
00400	;the address is a pointer either to the function 
00500	;name or the code of the function
00600	OPDEF FCALL [34B8]	;ordinary function call-may be changed to PUSHJ
00700	OPDEF JCALL [35B8]	;terminal function call-may be changed to JRST
00800	OPDEF CALLF [36B8]	;like call but may not be changed to PUSHJ
00900	OPDEF JCALLF [37B8]	;like jcall but may not be changed to JRST
01000	;error UUOs 
01100	
01200	OPDEF ERR1 [1B8]	;ordinary lisp error	;gives backtrace
01300	OPDEF ERR2 [2B8]	;space overflow error	;no backtrace
01400	OPDEF ERR3 [3B8]	;ill. mem. ref.
01500	OPDEF STRTIP [4B8]	;print error message and continue
     

00100	;system UUOs
00200	
00300		OPDEF TTYUUO [51B8]
00400		OPDEF INCHRW [TTYUUO 0,]
00500		OPDEF OUTCHR [TTYUUO 1,]
00600		OPDEF OUTSTR [TTYUUO 3,]
00700		OPDEF INCHWL [TTYUUO 4,]
00800		OPDEF INCHSL [TTYUUO 5,]
00900		OPDEF CLRBFI [TTYUUO 11,]
01000		OPDEF TALK [PUSHJ P,TTYCLR]
01100	
01200	;I/O bits and constants
01300		TTYLL==105	;teletype linelength 
01400		LPTLL==160	;line printer linelength
01500		MLIOB==203	;max length of I/O buffer
01600		NIOB==2	;no of I/O buffers per device
01700		NIOCH==7	;number of I/O channels
01800		FSTCH==11	;first I/O channel
01900		TTCH==10	;teletype I/O channel
02000		BLKSIZE==NIOB*MLIOB+COUNT+1
02100		INB==2
02200		OUTB==1
02300		AVLB==40
02400		DIRB==4
02500	
02600	;special ASCII characters
02700		ALTMOD==175
02800		SPACE==40	;space
02900		IGCRLF==32	;ignored cr-lf
03000		RUBOUT==177
03100		LF==12
03200		CR==15
03300		TAB==11
03400		BELL==7
03500		DBLQT==42	;double quote "
03600	
03700	;byte pointer field definitions
03800		ACFLD==14	;ac field
03900		XFLD==21	;index field
04000		OPFLD==10	;opcode field
04100		ADRFLD==43	;adress field
04200		
04300	;external and internal symbols
04400	
04500	EXTERNAL JOB41	;instruction to be executed on UUO
04600	EXTERNAL JOBAPR	;address of APR interupt routines
04700		EXTERNAL JOBCNI	;interupt condition flags
04800		EXTERNAL JOBFF	;first location beyond program
04900		EXTERNAL JOBREL	;address of last legal instruction in core image
05000		EXTERNAL JOBREN	;reentry address
05100		EXTERNAL JOBSA	;starting address
05200		EXTERNAL JOBSYM	;address of symbol table
05300		EXTERNAL JOBTPC	;program counter at time of interupt
05400		EXTERNAL JOBUUO	;uuo is put here with effective address computed
05500	
05600	;apr flags
05700		PDOV==200000	;push down list overflow
05800		MPV==20000	;memory protection violation
05900		NXM==10000	;non-existant memory referenced
06000		APRFLG==PDOV+MPV+NXM	;any of the above
06100		
06200	;system uuos
06300		APRINI==16
06400		RESET==0
06500		STIME==27
06600		DEVCHR==4
06700		EXIT==12
06800		CORE==11
     

00100	;foolst macros
00200	DEFINE FOO <
00300	XLIST
00400	BAZ (\FOOCNT)
00500	LIST
00600		>
00700	
00800	DEFINE BAZ (X)
00900	<FOOCNT=FOOCNT+1
01000	FOO'X:
01100	>
01200	
01300	FOOCNT=0
01400	
     

00100	SUBTTL TOP LEVEL AND INITIALIZATION  --- PAGE 2
00200	
00300	START:  ;CALLI RESET
00400		LAC  [JSR UUOH]
00500		EXCH JOB41
00600		MOVEM SAI41
00610		MOVEI APRINT
00700		EXCH  JOBAPR
00710		DAC   SAIAPR
00800		MOVEI APRFLG
00900		CALLI APRINI
01000		HRRZI 17,1
01100		SETZB 0,PSAV1
01200		BLT 17,17	;clear acs 
01300	LSPRT1:	SETOM ERRSW	;print error messages
01400		CLEARM ERRTN	;return to top level on errors
01500		SETOM PRVCNT#	;initialize counter for errio
01600		MOVE P,C2#	;initial reg pdl ptr
01700		MOVE SP,SC2#	;initial spec pdl ptr
01800	LISP1X:	PUSHJ P,TTYRET	;(outc nil t)(inc nil t)return output for gc message
01900	FOO	HRROI 0,CNIL2	;initialize nil
02000		SKIPN FF+X	
02100		PUSHJ P,AGC	;garbage collect only if necessary
02200		SKIPN BSFLG#	;initial bootstrap for macros
02300		JRST BOOTS
02400		;SKIPE RETFLG	;test for error return
02500		;JRST [	SKIPE A,INITF
02600		;	CALLF (A)	;evaluate initialization function
02700		;	SETZM RETFLG
02800		;	JRST .+1]
02900	LISP2:	PUSHJ P,TTYRET		;return all i/o to tty
03000		PUSHJ P,TERPRI
03100		SKIPE GOBF#	;garbaged oblist flag
03200		STRTIP [SIXBIT /GARBAGED OBLIST←!/]
03300		SETZM GOBF
03400		SKIPE BPSFLG#
03500		JRST BINER2	;binary program space exceeded by loader
03600	LISP1:	PUSHJ P,READ	;this is the top level of lisp
03700		PUSHJ P,EVAL
03800		PUSHJ P,PRINT
03900		PUSHJ P,TERPRI
04000		JRST LISP1
     

00100	INITFN:	EXCH A,INITF#
00200		POPJ P,
00300	
00400	;return from lisp error or bell
00500	LSPRET:	PUSHJ P,TERPRI
00600		SKIPE PSAV1#	;bell from alvine?
00700		JRST [	MOVE P,PSAV1	;yes, return to alvine
00800			LAPZ REL,ED
00900			JRST 1(REL)]	;improved magic
01000		MOVE B,SC2
01100		PUSHJ P,UBD	;unbind specpdl
01200		SETOM RETFLG	;set return flag
01300		JRST LSPRT1
01400	
01500	.RSET:	EXCH A,RSTSW#
01600		POPJ P,
01700	
01800	;bootstrapper for macro definitions
01900	BOOTS:	SETOM BSFLG
02000		MOVEI A,BSTYI
02100		PUSHJ P,READP1
02200		PUSHJ P,EVAL
02300		PUSHJ P,READ
02400		JRST .-2
02500	
02600	BSTYI:	ILDB A,[POINT 7,[ASCII /(INC(INPUT DSK:(LISP.LSP)))/]]
02700		POPJ P,
     

00100	SUBTTL APR INTERRUPT ROUTINES --- PAGE 3
00200	;arithmetic processor interupts
00300	;mem. protect. violation, nonex. mem. or pdl overflow
00400	
00500	APRINT:	MOVE R,JOBCNI	;get interupt bits
00600		TRNE R,MPV+NXM	;what kind
00700		ERR3 @JOBTPC	;an ill mem ref-will become JRST ILLMEM
00800		JUMPN NIL,MES21	;a pdl overflow
00900		STRTIP [SIXBIT /←PDL OVERFLOW FROM GC - CAN'T CONTINUE!/]
01000		JRST START
01100	
01200	MES21:	SETZM JOBUUO
01300		SKIPL P
01400		STRTIP [SIXBIT /←REG !/]
01500		SKIPL SP
01600		STRTIP [SIXBIT /←SPEC !/]
01700		SKIPE JOBUUO
01800	SPDLOV:	ERR2 [SIXBIT /PUSHDOWN CAPACITY EXCEEDED !/]
01900		TRNE R,PDOV
02000		SKIPE JOBUUO
02100		HALT		;lisp should not be here
02200	BINER2:	SETZM BPSFLG
02300		ERR2 [SIXBIT /BINARY PROGRAM SPACE EXCEEDED !/]
02400	
02500	ILLMEM:	LDB R,[POINT 4,@JOBTPC,XFLD]	;get index field of bad word
02600		CAIE R,F	;does  it contain f
02700		ERR3 @JOBTPC	;no! error
02800		PUSHJ P,AGC	;yes! garbage collect
02900		JRST @JOBTPC	;and continue
     

00100	SUBTTL UUO HANDLER AND SUBR CALL ROUTINES --- PAGE 4
00200	
00300	UUOMIN==1
00400	UUOMAX==4
00500	
00600	UUOH:	X		;jsr location
00700		MOVEM T,TSV#
00800		MOVEM TT,TTSV#
00900			LDB T,[POINT 9,JOBUUO,OPFLD]	;get opcode
01000		CAIGE T,34	;is it a function call
01100		JRST ERROR	;or a LISP error
01200		HLRE R,@JOBUUO
01300		AOJN R,UUOS
01400		LDB T,[POINT 4,JOBUUO,ACFLD]
01500		CAILE T,15
01600		MOVEI R,-15(T)
01700		LAPZ T,@JOBUUO
01800	UUOH1:	LIPZ TT,(T)
01900		LAPZ T,(T)
02000	FOO	CAIN TT,SUBR
02100		JRST @UUST(R)
02200	FOO	CAIN TT,FSUBR
02300		JRST @UUFST(R)
02400	FOO	CAIN TT,LSUBR
02500		JRST @UULT(R)
02600	FOO	CAIN TT,EXPR
02700		JRST @UUET(R)
02800	FOO	CAIN TT,FEXPR
02900		JRST @UUFET(R)
03000		LAPZ T,(T)
03100		JUMPN T,UUOH1
03200		PUSH P,A
03300		PUSH P,B
03400		LAPZ A,JOBUUO
03500	FOO	MOVEI B,VALUE
03600		PUSHJ P,GET
03700		JUMPN A,[	LAPZ TT,(A)
03800				POP P,B
03900				POP P,A
04000				JRST UUOEX1]
04100		LAPZ A,JOBUUO
04200		PUSHJ P,EPRINT
04300		ERR1 [SIXBIT /UNDEFINED UUO!/]
     

00100		SKIPA T,TT
00200	UUOSBR:	LIPZ T,(T)
00300		MOVE TT,JOBUUO
00400		HRLI T,(PUSHJ P,)
00500		TLNE TT,1000	;1000 means no push
00600		TLCA T,34600	;<PUSHJ P,>xor<JRST>
00700		PUSH P,UUOH
00800		SOS UUOH
00900	UUOCL:	TLNN TT,2000+X	;2000 means no clobber
01000		MOVEM T,@UUOH
01100		MOVE TT,TTSV
01200		EXCH T,TSV
01300		JRST @TSV
01400	
01500	UUOS:	LAPZ TT,JOBUUO
01600		CAMLE TT,orgHWS
01700		CAML TT,orgFWS
01800		JRST UUOSBR-1
01900		JRST .+2
02000	UUOEXP:	LIPZ TT,(T)
02100	UUOEX1:	LDB T,[POINT 5,JOBUUO,ACFLD]
02200		TRZN T,20
02300		PUSH P,UUOH
02400		PUSH P,TT
02500		JUMPE T,IAPPLY
02600		CAIN T,17
02700		MOVEI T,1
02800		MOVNS T
02900		HRLZ TT,T
03000		PUSH P,A(TT)
03100		AOBJN TT,.-1
03200		JRST IAPPLY
     

00100	ARGPDL:	LDB T,[POINT 4,JOBUUO,ACFLD]
00200		MOVNS T
00300		HRLZ R,T
00400	ARGP1:	JUMPE R,(TT)
00500		PUSH P,A(R)
00600		AOBJN R,.-1
00700		JRST (TT)
00800	
00900	QTIFY:	PUSHJ P,NCONS
01000	FOO	MOVEI B,CQUOTE
01100		JRST XCONS
01200	
01300	QTLFY:	MOVEI A,0
01400	QTLFY1:	JUMPE T,(TT)
01500		EXCH A,(P)
01600		PUSHJ P,QTIFY
01700		POP P,B
01800		PUSHJ P,CONS
01900		AOJA T,QTLFY1
02000	
02100	PDLARG:	JRST .+NACS+2(T)
02200		POP P,A+5
02300		POP P,A+4
02400		POP P,A+3
02500		POP P,A+2
02600		POP P,A+1
02700		POP P,A
02800		JRST (TT)
02900	
03000	NOUUO:	MOVSI B,(TLNN TT,)
03100		SKIPE A
03200		MOVSI B,(TLNA)
03300		HLLM B,UUOCL
03400		EXCH A,NOUUOF#
03500		POPJ P,
     

00100	;r=0 => compiler calling a -
00200	;r=1 => compiler calling a lsubr
00300	;r=2 => compiler calling f type
00400	UUST:	UUOSBR
00500		UUOS1	;calling l its a subr
00600		UUOS2	;calling f
00700	
00800	
00900	UUFST:	UUOS9	;calling - its a f
01000		UUOS10	;calling l
01100		UUOSBR
01200	
01300	UULT:	UUOS7	;calling - its a l
01400		UUOSBR
01500		UUOS8
01600	
01700	UUET:	UUOEXP
01800		UUOS5	;calling l its an expr
01900		UUOS6	;calling f its an expr
02000	
02100	UUFET:	UUOS3	;calling - its a fexpr
02200		UUOS4	;calling l
02300		UUOEXP	
02400	
02500	UUOS1:	LIPZ R,(T)
02600		MOVE T,TSV
02700		JSP TT,PDLARG
02800		JRST (R)
02900	
03000	UUOS3:	PUSH P,(T)
03100		JSP TT,ARGPDL
03200	UUOS4A:	JSP TT,QTLFY
03300		MOVEI TT,1
03400		DPB TT,[POINT 4,JOBUUO,ACFLD]
03500	UUOS6A:	POP P,TT
03600		HLRZS TT
03700		JRST UUOEX1
03800	
03900	UUOS4:	PUSH P,(T)
04000		MOVE T,TSV
04100		JRST UUOS4A
     

00100	UUOS5:	LIPZ R,(T)
00200		MOVE T,TSV
00300		JSP TT,PDLARG
00400		MOVE TT,R
00500		JRST UUOEX1
00600	
00700	UUOS6:	PUSH P,(T)
00800		PUSH P,UUOH
00900		PUSH P,JOBUUO
01000		JSP TT,ILIST
01100		JSP TT,PDLARG
01200		POP P,JOBUUO
01300		POP P,UUOH
01400		JRST UUOS6A
01500	UUOS8:	SKIPA TT,CILIST
01600	UUOS7:	MOVEI TT,ARGPDL
01700		DAP TT,UUOS7A
01800		MOVE TT,JOBUUO
01900		TLNN TT,1000
02000		PUSH P,UUOH
02100		LIPZ TT,(T)
02200	UUOS7A:	JRST ARGPDL+X	;or ilist
02300	
02400	UUOS9:	PUSH P,T
02500		JSP TT,ARGPDL
02600	UUS10A:	JSP TT,QTLFY
02700		MOVSI T,2000
02800		IORM T,JOBUUO
02900		POP P,T
03000		JRST UUOSBR
03100	
03200	UUOS10:	PUSH P,T
03300		MOVE T,TSV
03400		JRST UUS10A
03500	
     

00100	SUBTTL ERROR HANDLER AND BACKTRACE --- PAGE 5
00200	;subroutine to print sixbit error message
00300	ERRSUB:	MOVSI A,(POINT 6,0)
00400		HRR A,JOBUUO
00500		MOVEM A,ERRPTR#
00600	ERRORB:	ILDB A,ERRPTR
00700		CAIN A,01	;conversion from sixbit
00800		POPJ P,
00900		CAIN A,77
01000		JRST [	PUSHJ P,TERPRI
01100			JRST ERRORB]
01200		ADDI A,40
01300		PUSHJ P,TYO
01400		JRST ERRORB
01500	
01600	;subroutine to return output to previously selected device
01700	OUTRET:	SKIPL PRVCNT	;if prvcnt<0 then there was no device deselect
01800		SOSL PRVCNT	;when prvcnt goes negative, then reselect
01900		POPJ P,
02000		PUSH P,PRVSEL#		;previously selected output
02100		POP P,TYOD
02200		POPJ P,
02300	
02400	;subroutine to force error messages out on tty
02500	ERRIO:	MOVE B,ERRSW
02600		CAIE B,INUM0	;inum0 specifies to print message on selected device
02700		AOSLE PRVCNT	;only if prvcnt already <0 does deselection occur
02800		POPJ P,	
02900		TALK		;undo control o
03000		MOVE B,[JRST TTYO]
03100		EXCH B,TYOD
03200		MOVEM B,PRVSEL
03300		POPJ P,
03400	
03500	ERRTN:	0	;0 => top level				*
03600		;- => pdl to reset to - stored by errorset
03700		;+ => string tyo pout rtn flag
03800	ERRSW:	-1	;0 means no prnt on error		*
     

00100	;subroutine to search oblist for closest function to address in r
00200	ERSUB3:
00300	FOO	MOVEI A,QST
00400	FOO	HRROI NIL,CNIL2
00500		HRLZ B,INT1
00600		MOVNS B
00700		SETZB AR2A,GOBF
00800		PUSH P,JOBAPR
00900		MOVEI C,[	SETOM GOBF
01000				JRST ERRO2G]
01100		DAP C,JOBAPR
01200		LIPZ C,@RHX5
01300	ERRO2B:	JUMPE C,[	AOBJN B,.-1
01400				POP P,JOBAPR	;oblist done, restore
01500				JRST PRINC]	;print closest match
01600		LIPZ TT,(C)
01700	ERRO2C:	LAPZ TT,(TT)
01800		JUMPE TT,ERRO2G
01900		LIPZ AR1,(TT)
02000	FOO	CAIN AR1,LSUBR
02100		JRST ERRO2H
02200	FOO	CAIE AR1,SUBR
02300	FOO	CAIN AR1,FSUBR
02400		JRST ERRO2H
02500		LAPZ TT,(TT)
02600		JRST ERRO2C
02700	
02800	ERRO2H:	LAPZ TT,(TT)
02900		LIPZ TT,(TT)
03000		CAMLE TT,AR2A	;le to prefer car to quote
03100		CAMLE TT,R
03200		JRST ERRO2G
03300		MOVE AR2A,TT
03400		LIPZ A,(C)
03500	ERRO2G:	LAPZ C,(C)
03600		JRST ERRO2B
     

00100	;dispatcher for error message uuos
00200	ERROR:	MOVEI A,APRFLG
00300		CALLI A,APRINI	;enable interupts
00400		LDB A,[POINT 9,JOBUUO,OPFLD]	;get opcode
00500		CAIL A,UUOMIN	;what
00600		CAILE A,UUOMAX	;is it?
00700		JRST ILLUUO	;an illegal opcode
00800		JRST @ERRTAB-UUOMIN(A)	;or LISP error
00900	ERRTAB:	ERROR1	;1	;ordinary LISP error
01000		ERRORG	;2	;space overflow error
01100		ERROR2	;3	;ill. mem. ref.
01200		STRTYP	;4	;print error message and continue
01300	ERRORG:	SKIPN P,ERRTN	;if in errset, restore p to that level
01400		MOVE P,C2	;else to top level
01500				;and attempt to print message
01600	
01700	ERROR1:	SKIPN ERRSW
01800		JRST ERREND	;dont print message, call (err nil)
01900		PUSHJ P,ERRIO	;print message on tty
02000		PUSHJ P,TERPRI
02100		PUSHJ P,ERRSUB	;print the message
02200		JRST ERRBK	;go the backtrace
02300	
02400	STRTYP:	PUSHJ P,ERRIO
02500		PUSHJ P,ERRSUB	;print message and continue
02600		PUSHJ P,OUTRET
02700		JRST @UUOH
     

00100	ERROR2:	LAPZ A,JOBUUO
00200		MOVEI B,[SIXBIT / ILL MEM REF FROM !/]
00300		JRST ERSUB2
00400	
00500	ILLUUO:	LAPZ A,UUOH
00600		MOVEI B,[SIXBIT / ILL UUO FROM !/]
00700	ERSUB2:	SKIPN ERRSW
00800		JRST ERREND	;dont print message
00900		PUSH P,A
01000		PUSH P,B
01100		PUSHJ P,ERRIO
01200		PUSHJ P,TERPRI
01300		PUSHJ P,PRINL2	;print number
01400		POP P,A
01500		STRTIP (A)	;print message
01600		POP P,R
01700		PUSHJ P,ERSUB3	;print nearest oblist match
01800	ERRBK:	SKIPE BACTRF#
01900		PUSHJ P,BKTRC	;print backtrace
02000		PUSHJ P,OUTRET	;return to previous device
02100	ERREND:	MOVEI A,0	;(err nil)
02200		SKIPN ERRTN
02300		JRST	[CLRBFI	;clear INPOT buffer
02400			SKIPE RSTSW
02500			JRST LISP2;(*rset t) goes to read-eval-print loop without unbind
02600			JRST LSPRET]	;unbind and go to top level
02700	ERR:	SKIPN ERRTN
02800		JRST LSPRET	;not in an errset, or bad error -- go to top level
02900		MOVE P,ERRTN
03000	ERR1:	POP P,B
03100		PUSHJ P,UBD	;unbind to previous errset
03200		POP P,ERRSW
03300		POP P,ERRTN
03400		JRST ERRP4	;and proceed
03500	
03600	ERRSET:	PUSH P,PA3
03700		PUSH P,PA4
03800		PUSH P,ERRTN
03900		PUSH P,ERRSW
04000		PUSH P,SP
04100		MOVEM P,ERRTN
04200		LAPZ C,(A)
04300		LIPZ C,(C)
04400		MOVEM C,ERRSW
04500		LIPZ A,(A)
04600		PUSHJ P,EVAL
04700		PUSHJ P,NCONS
04800		JRST ERR1
     

00100	;error messages
00200	
00300	DOTERR:	SETZM OLDCH
00400		ERR1 [	SIXBIT /DOT CONTEXT ERROR!/]
00500	UNDFUN:	LIPZ A,(AR1)
00600		PUSHJ P,EPRINT
00700		ERR1 [SIXBIT /UNDEFINED FUNCTION!/]
00800	UNBVAR:	PUSHJ P,EPRINT
00900		ERR1 [SIXBIT /UNBOUND VARIABLE - EVAL!/]
01000	NONNUM:	ERR1 [SIXBIT /NON-NUMERIC ARGUMENT!/]
01100	NOPNAM:	ERR1 [SIXBIT /NO PRINT NAME - INTERN!/]
01200	NOLIST:	ERR1 [SIXBIT /NO LIST-MAKNAM!/]
01300	TOMANY:	ERR1 [SIXBIT /TOO MANY ARGUMENTS SUPPLIED - APPLY!/]
01400	TOOFEW:	ERR1 [SIXBIT /TOO FEW ARGUMENTS SUPPLIED - APPLY!/]
01500	UNDTAG:	PUSHJ P,EPRINT
01600		ERR1 [SIXBIT /UNDEFINED FUNCTION - APPLY!/]
01700	EG1:	LAPZ A,T
01800		PUSHJ P,EPRINT
01900		ERR1 [SIXBIT /UNDEFINED PROG TAG-GO!/]
     

00100	;backtrace subroutine
00200	BKTRC:	MOVEI D,-1(P)
00300		MOVN A,BACTRF
00400		ADDI A,INUM0
00500		JUMPL A,[	ADD A,P	;backtrace specific number 
00600				JRST .+3]
00700		SKIPN A,ERRTN	;backtrace to previous errset
00800		MOVE A,C2	;or top level
00900		DAPZ A,BAKLEV#
01000		STRTIP [SIXBIT /←BACKTRACE←!/]
01100	BKTR2:	CAMG D,BAKLEV
01200		JRST FALSE	;done 
01300		LAPZ A,(D)	;get pdl element
01400	FOO	CAIGE A,FS
01500		JUMPN A,.+2	;this is (hopefully) a true program address
01600		SOJA D,BKTR2	;not a program address, continue
01700		CAIN A,ILIST3
01800		JRST BKTR1A	;argument evaluation 
01900	BKTR1B:	CAIN A,CPOPJ
02000		JRST [	LIPZ A,(D)	;calling a function
02100			PUSHJ P,PRINC
02200			XCT "-",CTY
02300			STRTIP [SIXBIT /ENTER !/]
02400			SOJA D,BKTR2]
02500		LIPZ B,-1(A)
02600		CAILE B,(JCALLF 17,@(17))
02700		CAIN B,(PUSHJ P,)	;tests for various types of calls
02800		CAIGE B,(FCALL)
02900		SOJA D,BKTR2		;not a proper function call
03000		PUSH P,-1(A)	;save object of function call
03100		MOVEI R,-1(A)	;location of function call
03200		PUSHJ P,ERSUB3		;print closest oblist match
03300		MOVEI A,"-"
03400		PUSHJ P,TYO
03500		POP P,R
03600		TLNE R,17
03700		LAPZ R,ERSUB3	;qst -- cant handle indexed calls
03800		HRRZS R
03900		HLRO B,(R)
04000		AOSN B
04100		JRST [	LAPZ A,R	;was calling an atomic function
04200			PUSHJ P,PRINC	;print its name
04300			JRST .+2]
04400		PUSHJ P,ERSUB3	;was calling a code location -- print closest match
04500		MOVEI A," "
04600		PUSHJ P,TYO
04700	BKTR1:	SOJA D,BKTR2	;continue
04800	
04900	BKTR1A:	LAPZ B,-1(D)
05000		CAIE B,EXP2
05100		CAIN B,ESB1
05200		JRST .+2
05300		JRST BKTR1B	;hum, not really evaluating arguments
05400		HLRE B,-1(D)
05500		ADD B,D
05600		LIPZ A,-3(B)
05700		JUMPE A,BKTR1
05800		PUSHJ P,PRINC
05900		XCT "-",CTY
06000		STRTIP [SIXBIT /EVALARGS !/]
06100		JRST BKTR1
06200	
06300	BAKGAG:	EXCH A,BACTRF
06400		POPJ P,