perm filename AAA[LSP,BGB]1 blob
sn#001393 filedate 1972-11-05 generic text, type T, neo UTF8
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
00100 ;SAIL JOBDAT ADDRESSES.
00200 SAI41: 0
00300 SAIAPR: 0
00400 ;SAIL ACCUMULATORS.
00500 AC0: 0
00600 AC1: 0
00700 AC2: 0
00800 AC3: 0
00900 AC4: 0
01000 AC5: 0
01100 AC6: 0
01200 AC7: 0
01300 AC10: 0
01400 AC11: 0
01500 AC12: 0
01600 AC13: 0
01700 AC14: 0
01800 AC15: 0
01900 AC16: 0
02000 AC17: 0
02100 ;LISP ACCUMULATORS.
02200 LISPAC: BLOCK 20
02300
02400 ;Olde switch and pointers.
02500 EFWSO: 0
02600 RETFLG: 0
02700 BSFLG: 0 ;Boot Strape initialization done.
00100 SUBTTL AC DEFINITIONS AND EXTERNALS --- PAGE 1
00200 INUMIN←377777
00300 INUM0←<INUMIN+777777>/2
00400 BCKETS←←177
00500
00600 ;accumulator definitions
00700 ;`sacred' means sacred to the interpreter
00800 ;`marked' means marked from by the garbage collector
00900 ;`protected' means protected during garbage collection
01000
01100 NIL←0 ;sacred, marked, protected ;atom head of NIL
01200 A←1 ;marked, protected ;1st arg & function result.
01300 B←A+1 ;marked, protected ;second arg of subrs
01400 C←B+1 ;marked, protected ;third arg of subrs
01500 AR1←4 ;marked, protected ;fourth arg of subrs
01600 AR2A←5 ;marked, protected ;fifth arg of subrs
01700 T←6 ;marked, protected ;minus number of args in LSUBR call
01800 TT←7 ;marked, protected
01900 REL←10 ;marked, protected ;rarely used
02000 S←11 ;rarely used
02100 D←12
02200 R←13 ;protected
02300 P←14 ;sacred, protected ;regular push down stack pointer
02400 F←15 ;sacred ;free storage list pointer
02500 FF←16 ;sacred ;full word list pointer
02600 SP←17 ;sacred, protected ;special pushdown stack pointer
02700
02800 NACS←←5 ;number of argument acs
02900
03000 X←←0 ;X indicates impure (modified) code locations
03100 TEN←←=10
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]
01700
01800 ;The foolst macro marks LISP Space References.
01900
02000 DEFINE FOO <
02100 XLIST
02200 BAZ(→FOOCNT)
02300 LIST
02400 >
02500
02600 DEFINE BAZ '(X)
02700 <FOOCNT←FOOCNT+1
02800 FOO'X:
02900 >
03000
03100 FOOCNT←0
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
00700 OPDEF FCALL [34B8] ;ordinary function call, like PUSHJ
00800 OPDEF JCALL [35B8] ;terminal function call, like JRST
00900 OPDEF CALLF [36B8] ;like call but may not be changed to PUSHJ
01000 OPDEF JCALLF [37B8] ;like jcall but may not be changed to JRST
01100
01200 ;error UUOs
01300
01400 OPDEF ERR1 [1B8] ;ordinary lisp error ;gives backtrace
01500 OPDEF ERR2 [2B8] ;space overflow error ;no backtrace
01600 OPDEF ERR3 [3B8] ;ill. mem. ref.
01700 OPDEF STRTIP [4B8] ;print error message and continue
01800
01900 ;external and internal symbols
02000
02100 EXTERNAL JOB41 ;instruction to be executed on UUO
02200 EXTERNAL JOBAPR ;address of APR interupt routines
02300 EXTERNAL JOBCNI ;interupt condition flags
02400 EXTERNAL JOBFF ;first location beyond program
02500 EXTERNAL JOBREL ;top of core image.
02600 EXTERNAL JOBREN ;reentry address
02700 EXTERNAL JOBSA ;starting address
02800 EXTERNAL JOBSYM ;address of symbol table
02900 EXTERNAL JOBTPC ;program counter at time of interupt
03000 EXTERNAL JOBUUO ;uuo with its effective address.
03100
03200 ;apr flags
03300
03400 PDOV←←200000 ;push down list overflow
03500 MPV←←20000 ;memory protection violation
03600 NXM←←10000 ;non-existant memory referenced
03700 APRFLG←←PDOV+MPV+NXM ;any of the above
03800
03900 ;system uuos
04000 APRINI←←16
04100 RESET←←0
04200 STIME←←27
04300 DEVCHR←←4
04400 EXIT←←12
04500 CORE←←11
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 DEFINE TALK{PUSHJ P,TTYCLR}
01100
01200 ;I/O bits and constants
01300
01400 TTYLL←←105 ;teletype linelength
01500 LPTLL←←160 ;line printer linelength
01600 MLIOB←←203 ;max length of I/O buffer
01700 NIOB←←2 ;no of I/O buffers per device
01800 NIOCH←←7 ;number of I/O channels
01900 FSTCH←←11 ;first I/O channel
02000 TTCH←←10 ;teletype I/O channel
02100 COUNT←←10
02200 BLKSIZE←←NIOB*MLIOB+COUNT+1
02300 INB←←2
02400 OUTB←←1
02500 AVLB←←40
02600 DIRB←←4
02700
02800 ;special ASCII characters
02900 ALTMOD←←175
03000 SPACE←←40 ;space
03100 IGCRLF←←32 ;ignored cr-lf
03200 RUBOUT←←177
03300 LF←←12
03400 CR←←15
03500 TAB←←11
03600 BELL←←7
03700 DBLQT←←42 ;double quote "
03800
03900 ;byte pointer field definitions
04000 ACFLD←←14 ;ac field
04100 XFLD←←21 ;index field
04200 OPFLD←←10 ;opcode field
04300 ADRFLD←←43 ;adress field
04400
00100 SUBTTL LISP STORAGE ALLOCATOR --- PAGE 21
00200
00300
00400 ALLNUM: 0
00500 MOVSI A,400000 ;high bit on for no digits
00600 INCHRW C
00700 CAIN C,RUBOUT
00800 JRST [OUTSTR [ASCIZ /XXX /]
00900 JRST ALLNUM+1]
01000 CAIL C,"0"
01100 CAILE C,"9"
01200 JRST @ALLNUM
01300 TLZ A,400000 ;turn off hi bit on digit
01400 IMULI A,10
01500 ADDI A,-"0"(C)
01600 JRST ALLNUM+2
00100 ;ALLOCATION DIALOGUE SUBROUTINE.
00200
00300 ALLOCD: 0
00400
00500 OUTSTR [ASCIZ /
00600 ALLOC? /]
00700 INCHRW C
00800 CAIGE C,"O"
00900 JRST @ALLOCD
01000
01100 OUTSTR [ASCIZ /
01200 FULL WDS=/]
01300 JSR ALLNUM
01400 SKIPGE A
01500 MOVEI A,400
01600 DAC A,sizFWS
01700
01800 OUTSTR [ASCIZ /
01900 BIN.PROG.SP=/]
02000 JSR ALLNUM
02100 SKIPGE A
02200 MOVEI A,2000
02300 DAC A,sizBPS
02400
02500 OUTSTR [ASCIZ /
02600 SPEC.PDL=/]
02700 JSR ALLNUM
02800 SKIPGE A
02900 MOVEI A,1000
03000 DAC A,sizSPD
03100
03200 OUTSTR [ASCIZ /REG. PDL=
03300 /]
03400 JSR ALLNUM
03500 SKIPGE A
03600 MOVEI A,1000
03700 DAC A,sizPDL
03800 JRST @ALLOCD
00100 ;LISP TO SAIL.
00200 INTERN SAIL
00300 SAIL: LAC SAI41
00400 DAC JOB41
00500 LAC SAIAPR
00600 DAC JOBAPR
00700 LAC 0,[XWD AC1,1]
00800 BLT 0,17
00900 LAC 0,AC0
01000 SUB 17,[XWD 2,2]
01100 JRST @2(17)
00100 ;SAIL TO LISP.
00200 INTERN LISP
00300 EXTERN CORGET
00400 ;ACCUMULATOR-2 POINTER TO FIRST WORD OF SAIL MEMORY BLOCK.
00500 ;ACCUMULATOR-3 SIZE OF SAIL MEMORY BLOCK.
00600 LISP: DAC 0,AC0
00700 LAC 0,[XWD 1,AC1]
00800 BLT 0,AC17
00900 LAC 3,-1(17)
01000 PUSHJ 17,CORGET
01100 JFCL
01200 ;JSR ALLOCD ;Allocation dialogue.
01300 OUTSTR [ASCIZ/
01400 /]
01500
01600 ;Bottom, Size & Top of LISP memory space.
01700 lac B,2
01800 lac S,3
01900 lac T,B
02000 addi T,-1(S)
02100
02200 ;Take BPS off the bottom
02300 dac B,orgBPS
02400 add B,sizBPS
02500 dac B,endBPS
02600 sos endBPS
02700 sub S,sizBPS
02800
02900 ;Take SPD off the top.
03000 dac T,endSPD
03100 sub T,sizSPD
03200 dac T,orgSPD
03300 aos orgSPD
03400 sub S,sizSPD
03500
03600 ;Compute FWS size ← 400+S/16.
03700 lac A,S
03800 ash A,-4
03900 addb A,sizFWS
04000
04100 ;Compute FBT size.
04200 idivi A,44
04300 aos A
04400 dac A,sizFBT
04500
04600 ;Compute PDL size.
04700 lac A,S
04800 ash A,-6
04900 addm A,sizPDL
00100 ;Compute size of Halfword Bit Table and Half Word Space.
00150
00200 sub S,sizFBT
00300 sub S,sizFWS
00400 sub S,sizPDL
00500 lac A,S
00600 idivi A,41
00700 aos A
00800 dac A,sizHBT
00900 sub S,A
01000 dac S,sizHWS
01100
01200 ;Take Half Word Space, HWS, off the bottom.
01250
01300 lac T,endBPS
01400 movei B,1(T)
01500 dac B,orgHWS
01600 add B,sizHWS
01700 add T,sizHWS
01800 dac T,endHWS
01900
02000 ;allocate Full Word Space, FWS above HWS.
02050
02100 dac B,orgFWS
02200 add B,sizFWS
02300 add T,sizFWS
02400 dac T,endFWS
02500
02600 ;allocate Halfword Bit Table, HBT above FWS.
02650
02700 dac B,orgHBT
02800 add B,sizHBT
02900 add T,sizHBT
03000 dac T,endHBT
03100
03200 ;allocate Fullword Bit Table, FBT above HBT.
03250
03300 dac B,orgFBT
03400 add B,sizFBT
03500 add T,sizFBT
03600 dac T,endFBT
03700
03800 ;allocate Push Down List, PDL above FBT.
03850
03900 dac B,orgPDL
04000 add B,sizPDL
04100 add T,sizPDL
04200 dac T,endPDL
00100 ;Initialize the values of the BPORG & BPEND atoms.
00150
00200 LAC A,orgBPS
00300 ADDM A,VBPORG ;value of BPORG.
00400 LAC A,endBPS
00500 ADDM A,VBPEND ;value of BPEND.
00600
00700 ;Setup Special PDL pointer.
00750
00800 LACN A,SIZSPD
00900 hrlz A,A
01000 lap A,orgSPD
01100 sos A
01200 dac A,SC2
01300
01400 ;lowest word of PDL holds pointer to OBLIST.
01450
01500 LAC B,orgPDL
01600 LAC A,orgHWS
01700 DAC A,(B)
01800
01900 ;setup regular PDL pointer.
01950
02000 ADDI B,12
02100 DAP B,C2
02200 LACN C,SIZPDL
02300 ADDI C,20
02400 DIP C,C2
02500
02600 ;Fixup references to HWS.
02650
02700 lac FF,orgHWS
02800 subi FF,OBLIST ;HWS displacement.
02900 MOVEI C,FOOLST
03000 REL5: LAC B,(C)
03100 LAPZ A,(B)
03200 ADD A,FF
03300 DAP A,(B)
03400 LIP B,B
03500 LAPZ A,(B)
03600 ADD A,FF
03700 DAP A,(B)
03800 CAIGE C,EFOLST-1
03900 AOJA C,REL5
00100 ;Blit prenatal FWS into its allocated space.
00200
00300 hrli A,BFWS ;from here.
00400 lap A,orgFWS ;to there.
00500 hrrzi B,EFWS-BFWS(A) ;new top+1.
00600 blt A,(B)
00700
00800 ;Move prenatal HWS into its allocated space.
00900
01000 movei F,OBLIST ;from here.
01100 lac T,orgHWS ;to there.
01200 lac B,orgHWS
01300 subi B,OBLIST ;HWS displacement.
01400 lac C,orgFWS
01500 subi C,BFWS ;FWS displacement.
01600
01700 ;Relocate CAR portion of a word.
01750
01800 REL1: lipz A,(F)
01900 caig A,EFWS
02000 caige A,OBLIST
02100 jrst .+5 ; A too high or low.
02200 move D,B ; A ≥ OBLIST.
02300 cail A,BFWS
02400 lac D,C ; A ≥ BFWS.
02500 add A,D
02600 dip A,(T)
02700
02800 ;Relocate CDR portion of a word.
02850
02900 lapz A,(F)
03000 caig A,EFWS
03100 caige A,OBLIST
03200 jrst .+5 ; A too high or low.
03300 move D,B ; A ≥ OBLIST.
03400 cail A,BFWS
03500 lac D,C ; A ≥ BFWS.
03600 add A,D
03700 dap A,(T)
03800
03900 ;advance From and To Pointers.
03950
04000 aos F
04100 caige F,BFWS
04200 aoja T,REL1
04300
04400 setzb F,DDTIFG
04500 JSR IOBRST
04600 JRST START
00100 SUBTTL TOP LEVEL AND INITIALIZATION --- PAGE 2
00200
00300 START: ;CALLI RESET
00400 LAC [JSR UUOH]
00500 EXCH JOB41
00600 MOVEM SAI41
00700 MOVEI APRINT
00800 EXCH JOBAPR
00900 DAC SAIAPR
01000 MOVEI APRFLG
01100 CALLI APRINI
01200 HRRZI 17,1
01300 SETZB 0,PSAV1
01400 BLT 17,17 ;clear acs
01500 LSPRT1: SETOM ERRSW ;print error messages
01600 SETZM ERRTN ;return to top level on errors
01700 SETOM PRVCNT# ;initialize counter for errio
01800 MOVE P,C2# ;initial reg pdl ptr
01900 MOVE SP,SC2# ;initial spec pdl ptr
02000 LISP1X: PUSHJ P,TTYRET ;(outc nil t)(inc nil t).
02100 FOO HRROI 0,CNIL2 ;initialize nil
02200 SKIPN FF+X
02300 PUSHJ P,AGC ;garbage collect only if necessary
02400 SKIPN BSFLG# ;initial bootstrap for macros
02500 JRST BOOTS
02600 ;SKIPE RETFLG ;test for error return
02700 ;JRST [ SKIPE A,INITF
02800 ; CALLF (A) ;evaluate initialization function
02900 ; SETZM RETFLG
03000 ; JRST .+1]
03100 LISP2: PUSHJ P,TTYRET ;return all i/o to tty
03200 PUSHJ P,TERPRI
03300 SKIPE GOBF# ;garbaged oblist flag
03400 STRTIP [SIXBIT /GARBAGED OBLIST←!/]
03500 SETZM GOBF
03600 SKIPE BPSFLG#
03700 JRST BINER2 ;binary program space exceeded by loader
03800 LISP1: PUSHJ P,READ ;this is the top level of lisp
03900 PUSHJ P,EVAL
04000 PUSHJ P,PRINT
04100 PUSHJ P,TERPRI
04200 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 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 means use selected device.
02700 AOSLE PRVCNT ;if prvcnt<0 then deselect.
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
02600 ;read-eval-print loop without unbinding.
02700 JRST LSPRET] ;unbind and go to top level
02800 ERR: SKIPN ERRTN
02900 JRST LSPRET ;not in an errset, or bad error -
03000 ; - go to top level
03100 MOVE P,ERRTN
03200 ERR1: POP P,B
03300 PUSHJ P,UBD ;unbind to previous errset
03400 POP P,ERRSW
03500 POP P,ERRTN
03600 JRST ERRP4 ;and proceed
03700
03800 ERRSET: PUSH P,PA3
03900 PUSH P,PA4
04000 PUSH P,ERRTN
04100 PUSH P,ERRSW
04200 PUSH P,SP
04300 MOVEM P,ERRTN
04400 LAPZ C,(A)
04500 LIPZ C,(C)
04600 MOVEM C,ERRSW
04700 LIPZ A,(A)
04800 PUSHJ P,EVAL
04900 PUSHJ P,NCONS
05000 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 -
04500 ; - print closest match
04600 MOVEI A," "
04700 PUSHJ P,TYO
04800 BKTR1: SOJA D,BKTR2 ;continue
04900
05000 BKTR1A: LAPZ B,-1(D)
05100 CAIE B,EXP2
05200 CAIN B,ESB1
05300 JRST .+2
05400 JRST BKTR1B ;hum, not really evaluating arguments
05500 HLRE B,-1(D)
05600 ADD B,D
05700 LIPZ A,-3(B)
05800 JUMPE A,BKTR1
05900 PUSHJ P,PRINC
06000 XCT "-",CTY
06100 STRTIP [SIXBIT /EVALARGS !/]
06200 JRST BKTR1
06300
06400 BAKGAG: EXCH A,BACTRF
06500 POPJ P,