Trailing-Edge
-
PDP-10 Archives
-
decuslib10-01
-
43,50073/lisp.mac
There are 5 other files named lisp.mac in the archive. Click here to see a list.
SUBTTL AC DEFINITIONS AND EXTERNALS --- PAGE 1
TITLE LISP INTERPRETER
IF1,<PURGE CDR,DF>
MLON
SALL
; WHEN THE FOLLOWING TWO SWITCHES ARE OFF (0), THE ONLY DIFFERENCES FROM
; STANFORD 1.6 ARE:
; 1) OCTAL PPNS,
; 2) EXPLICIT I/O FOR SOS-LINKAGE,
; 3) THE '*' PROMPT-CHAR CAN BE DYNAMICALLY CHANGED, TO
; CONSIST OF UP TO 4 CHARACTERS;
; 4) THE SUBR CORE(N) IS USED TO INCREASE (OR PARTIALLY CUT) CORE;
; 5) THE SUBR ALLOC() JUST GOES TO LISPGO TO ALLOC NEW CORE;
; 6) A SWITCH FOR ALTMODE TO BE 33 OR 175.
TENEX==0 ;WHEN OFF, WILL ASSEMBLE FOR DECUS 10/50 LISP.
;TENEX==1 ;WHEN ON, THIS HAS THE FOLLOWING EFFECTS:
; 1) THE 10X PSI IS ENABLED FOR 10/50 ^O (SIMULATED);
; 2) THE 'SYS:' DIRECTORY IS NOT PRESUMED TO BE <SYSTEM>,
; BUT RATHER THE DEFAULT IS <LISP> ... IF THIS
; IS NOT FOUND, THE USER IS ASKED FOR A DIR-NAME.
; 3) THE SWAPOUT FOR THE SOS-LINK IS DONE AS AN INFERIOR FORK,
; WHICH RETURNS THROUGH LISPGO -- ALLOCATING ANY HI-CORE.
; 4) THE SUBR SETSYS IS USED TO DYNAMICALLY CHANGE 'SYS:';
; 5) THE INITIAL START-UP QUESTIONS ARE SLIGHTLY CHANGED.
VBP==1 ;THIS HAS THE CORRECTIVE EFFECT THAT BPS-SPACE IS NOT LIMITED TO
; <64K AS WITH STANFORD, BUT MAY EXTEND TO 128K.
; 1) BPS (VBPORG, VBPEND) USED BY: ARRAY AND LOAD, PRINCIPALLY.
; 2) EXAMINE AND DEPOSIT NOW WORK >64K LIMIT.
DECUS==1-TENEX ;THIS SETS THE ASCII CODE FOR ALTMODE.
;AN ADDITIONAL PAIR OF SUBRS ARE RDBLK AND WRBLK, USED FOR MANIPULATING
; OVERLAY-BLOCKS IN BPS-SPACE TO AND FRO DISK-FILES.
INUMIN=377777
INUM0=<INUMIN+777777>/2
BCKETS==77
INITCORE==^D11*2000-1 ;INITIAL STARTING CORE SIZE FOR TENEX.
PAGE
;accumulator definitions
;'sacred' means sacred to the interpreter
;'marked' means marked from by the garbage collector
;'protected' means protected during garbage collection
NIL=0 ;sacred, marked, protected ;atom head of NIL
A=1 ;marked, protected ;results of functions and first arg of subrs
B=A+1 ;marked, protected ;second arg of subrs
C=B+1 ;marked, protected ;third arg of subrs
AR1=4 ;marked, protected ;fourth arg of subrs
AR2A=5 ;marked, protected ;fifth arg of subrs
T=6 ;marked, protected ;minus number of args in LSUBR call
TT=7 ;marked, protected
REL=10 ;marked, protected ;rarely used
S=11 ;rarely used
D=12
R=13 ;protected
P=14 ;sacred, protected ;regular push down stack pointer
F=15 ;sacred ;free storage list pointer
FF=16 ;sacred ;full word list pointer
SP=17 ;sacred, protected ;special pushdown stack pointer
NACS==5 ;number of argument acs
X==0 ;X indicates impure (modified) code locations
TEN==^D10
PAGE
;UUO definitions
;UUOs used to call functions from compiled code
;the number of arguments is given by the ac field
;the address is a pointer either to the function
;name or the code of the function
OPDEF FCALL [34B8] ;ordinary function call-may be changed to PUSHJ
OPDEF JCALL [35B8] ;terminal function call-may be changed to JRST
OPDEF CALLF [36B8] ;like call but may not be changed to PUSHJ
OPDEF JCALLF [37B8] ;like jcall but may not be changed to JRST
;error UUOs
OPDEF ERR1 [1B8] ;ordinary lisp error ;gives backtrace
OPDEF ERR2 [2B8] ;space overflow error ;no backtrace
OPDEF ERR3 [3B8] ;ill. mem. ref.
OPDEF STRTIP [4B8] ;print error message and continue
;system UUOs
OPDEF TTYUUO [51B8]
OPDEF INCHRW [TTYUUO 0,]
OPDEF OUTCHR [TTYUUO 1,]
OPDEF OUTSTR [TTYUUO 3,]
OPDEF INCHWL [TTYUUO 4,]
OPDEF INCHSL [TTYUUO 5,]
OPDEF CLRBFI [TTYUUO 11,]
OPDEF TALK [PUSHJ P,TTYCLR] ;this is to turn off control O.
;when ttyser lets you do this
;easily, change me
IFN TENEX, <
OPDEF JSYS [104B8]
OPDEF AIC [JSYS 131]
OPDEF ATI [JSYS 137]
OPDEF CFOBF [JSYS 101]
OPDEF CFORK [JSYS 152]
OPDEF DEBRK [JSYS 136]
OPDEF DOBE [JSYS 104]
OPDEF GET [JSYS 200]
OPDEF GJINF [JSYS 13]
OPDEF GTJFN [JSYS 20]
OPDEF IIC [JSYS 132]
OPDEF KFORK [JSYS 153]
OPDEF RIR [JSYS 144]
OPDEF SFRKV [JSYS 201]
OPDEF SIR [JSYS 125]
OPDEF STDIR [JSYS 40]
OPDEF WFORK [JSYS 163]
>
PAGE
;I/O bits and constants
TTYLL==105 ;teletype linelength
LPTLL==160 ;line printer linelength
MLIOB==203 ;max length of I/O buffer
NIOB==2 ;no of I/O buffers per device
NIOCH==17 ;number of I/O channels
FSTCH==1 ;first I/O channel
TTCH==0 ;teletype I/O channel
BLKSIZE==NIOB*MLIOB+COUNT+1
INB==2
OUTB==1
AVLB==40
DIRB==4
;special ASCII characters
IFN TENEX,< ALTMOD==175 >
IFN DECUS,< ALTMOD==33 >
SPACE==40 ;space
IGCRLF==32 ;ignored cr-lf
RUBOUT==177
LF==12
CR==15
TAB==11
BELL==7
DBLQT==42 ;double quote "
;byte pointer field definitions
ACFLD==14 ;ac field
XFLD==21 ;index field
OPFLD==10 ;opcode field
ADRFLD==43 ;adress field
PAGE
;external and internal symbols
EXTERNAL JOB41 ;instruction to be executed on UUO
EXTERNAL JOBAPR ;address of APR interupt routines
EXTERNAL JOBCNI ;interupt condition flags
EXTERNAL JOBFF ;first location beyond program
EXTERNAL JOBREL ;address of last legal instruction in core image
EXTERNAL JOBREN ;reentry address
EXTERNAL JOBSA ;starting address
EXTERNAL JOBSYM ;address of symbol table
EXTERNAL JOBTPC ;program counter at time of interupt
EXTERNAL JOBUUO ;uuo is put here with effective address computed
;apr flags
PDOV==200000 ;push down list overflow
MPV==20000 ;memory protection violation
NXM==10000 ;non-existant memory referenced
APRFLG==PDOV+MPV+NXM ;any of the above
;system uuos
APRINI==16
RESET==0
STIME==27
DEVCHR==4
EXIT==12
CORE==11
PAGE
;foolst macros: these get relocated (RH addr) relative to FF.
DEFINE FOO <
XLIST
BAZ (\FOOCNT)
LIST
>
DEFINE BAZ (X)
<FOOCNT=FOOCNT+1
FOO'X:
>
FOOCNT=0
SUBTTL TOP LEVEL AND INITIALIZATION --- PAGE 2
LISPGO: SETOM RETFLG# ;enter via INITFN
JRST STRT ;go to re-allocator
DEBUGO: SETZM RETFLG ;clear return flag to allow INITFN to be changed
IFE TENEX,< ;entry point to get into read-eval-print loop
JRST LISP1X > ; without unbinding spec pdl.
IFN TENEX,< ;FIX ACS, SINCE MAY BE IN PA1050 FILE
JRST REETNX > ; AT TIME OF ^C (WITH ITS ACS).
START: CALLI RESET ;random initializations for lisp interupts
MOVE A,[JSR UUOH]
MOVEM A,JOB41
MOVEI A,APRINT
MOVEM A,JOBAPR
JSR APRSET ;SET UP INTERRUPTS (+ 10X IF USED FOR ^O).
REETNX:
HRRZI 17,1
SETZB 0,PSAV1
BLT 17,17 ;clear acs
LSPRT1: SETOM ERRSW ;print error messages
CLEARM ERRTN ;return to top level on errors
SETOM PRVCNT# ;initialize counter for errio
MOVE P,C2# ;initial reg pdl ptr
MOVE SP,SC2# ;initial spec pdl ptr
LISP1X: PUSHJ P,TTYRET ;(outc nil t)(inc nil t)return output for gc message
FOO HRROI 0,CNIL2 ;initialize nil
SKIPE HASHFG#
JRST REHASH ;rehash if necessary
SKIPN FF+X
PUSHJ P,AGC ;garbage collect only if necessary
SKIPN BSFLG# ;initial bootstrap for macros
JRST BOOTS
SKIPE RETFLG ;test for error return
JRST [ SKIPE A,INITF
CALLF (A) ;evaluate initialization function
SETZM RETFLG
JRST .+1]
LISP2: PUSHJ P,TTYRET ;return all i/o to tty
PUSHJ P,TERPRI
SKIPE GOBF# ;garbaged oblist flag
STRTIP [SIXBIT /GARBAGED OBLIST_!/]
SETZM GOBF
SKIPE BPSFLG#
JRST BINER2 ;binary program space exceeded by loader
LISP1: PUSHJ P,READ ;this is the top level of lisp
PUSHJ P,EVAL
PUSHJ P,PRINT
PUSHJ P,TERPRI
JRST LISP1
PAGE
INITFN: EXCH A,INITF#
POPJ P,
;return from lisp error or bell
LSPRET: PUSHJ P,TERPRI
SKIPE PSAV1# ;bell from alvine?
JRST [ MOVE P,PSAV1 ;yes, return to alvine
HRRZ REL,ED
JRST 1(REL)] ;improved magic
MOVE B,SC2
PUSHJ P,UBD ;unbind specpdl
SETOM RETFLG ;set return flag
JRST LSPRT1
.RSET: EXCH A,RSTSW#
POPJ P,
;bootstrapper for macro definitions
BOOTS: SETOM BSFLG
MOVEI A,BSTYI
PUSHJ P,READP1
PUSHJ P,EVAL
PUSHJ P,READ
JRST .-2
BSTYI: ILDB A,[POINT 7,[ASCII /(INC(INPUT SYS:(LISP.LSP)))/]]
POPJ P,
SUBTTL APR INTERRUPT ROUTINES --- PAGE 3
;arithmetic processor interupts
;mem. protect. violation, nonex. mem. or pdl overflow
APRINT: MOVE R,JOBCNI ;get interupt bits
TRNE R,MPV+NXM ;what kind
ERR3 @JOBTPC ;an ill mem ref-will become JRST ILLMEM
JUMPN NIL,MES21 ;a pdl overflow
STRTIP [SIXBIT /_PDL OVERFLOW FROM GC - CAN'T CONTINUE!/]
JRST START
MES21: SETZM JOBUUO
SKIPL P
STRTIP [SIXBIT /_REG !/]
SKIPL SP
STRTIP [SIXBIT /_SPEC !/]
SKIPE JOBUUO
SPDLOV: ERR2 [SIXBIT /PUSHDOWN CAPACITY EXCEEDED !/]
TRNE R,PDOV
SKIPE JOBUUO
HALT ;lisp should not be here
BINER2: SETZM BPSFLG
ERR2 [SIXBIT /BINARY PROGRAM SPACE EXCEEDED !/]
ILLMEM: LDB R,[POINT 4,@JOBTPC,XFLD] ;get index field of bad word
CAIE R,F ;does it contain f
ERR3 @JOBTPC ;no! error
PUSHJ P,AGC ;yes! garbage collect
JRST @JOBTPC ;and continue
PAGE
INTERNAL TYID,LISP1,APRSET,LISPGO ;FOR CMPBIN.MAC
APRSET: 0 ;SET UP NECESSARY INTERRUPTS.
MOVEI A,APRFLG ; (ACCS A & B ARE FREE).
CALLI A,APRINI ;THIS DOES THE 10/50 SETUP.
IFN TENEX, <
HRRZI 1,400000 ;FORK HANDLE FOR THIS FORK.
RIR ;GET THE PA1050 FILE'S LEVTAB,,CHNTAB.
MOVE 1,[XWD 1,CHANL0];LEVEL 1 TO OVERRIDE PA1050'S USAGE.
MOVEM 1,0(2) ;SET CHANNEL 0 ADDRESS.
MOVSI 1,"O"-100
ATI
MOVSI 2,(1B0) ;******* EXTEND.LAP PATCHES HERE **********
HRRZI 1,400000
AIC
SETZM OFLAG
>
JRST @APRSET
;********** CHANNEL 0 INTRP CODE **********
IFN TENEX, <
CHANL0: MOVEM 1,AC1SV
SETCMM OFLAG
HRRZI 1,101 ;FILE DESIG. FOR PRIM OUTPUT DEV.
CFOBF ;CLEAR THE OUTPUT BUFFER
MOVE 1,AC1SV
DEBRK ;DISMISS PSEUDO INTRP.
AC1SV: 0
OFLAG:: 0
>
SUBTTL UUO HANDLER AND SUBR CALL ROUTINES --- PAGE 4
UUOMIN==1
UUOMAX==4
UUOH: X ;jsr location
MOVEM T,TSV#
MOVEM TT,TTSV#
LDB T,[POINT 9,JOBUUO,OPFLD] ;get opcode
CAIGE T,34 ;is it a function call
JRST ERROR ;or a LISP error
HLRE R,@JOBUUO
AOJN R,UUOS
LDB T,[POINT 4,JOBUUO,ACFLD]
CAILE T,15
MOVEI R,-15(T)
HRRZ T,@JOBUUO
UUOH1: HLRZ TT,(T)
HRRZ T,(T)
FOO CAIN TT,SUBR
JRST @UUST(R)
FOO CAIN TT,FSUBR
JRST @UUFST(R)
FOO CAIN TT,LSUBR
JRST @UULT(R)
FOO CAIN TT,EXPR
JRST @UUET(R)
FOO CAIN TT,FEXPR
JRST @UUFET(R)
HRRZ T,(T)
JUMPN T,UUOH1
PUSH P,A
PUSH P,B
HRRZ A,JOBUUO
FOO MOVEI B,VALUE
PUSHJ P,GET
JUMPN A,[ HRRZ TT,(A)
POP P,B
POP P,A
JRST UUOEX1]
HRRZ A,JOBUUO
PUSHJ P,EPRINT
ERR1 [SIXBIT /UNDEFINED UUO!/]
PAGE
SKIPA T,TT
UUOSBR: HLRZ T,(T)
MOVE TT,JOBUUO
HRLI T,(PUSHJ P,)
TLNE TT,1000 ;1000 means no push
TLCA T,34600 ;<PUSHJ P,>xor<JRST>
PUSH P,UUOH
SOS UUOH
UUOCL: TLNN TT,2000+X ;2000 means no clobber
MOVEM T,@UUOH
MOVE TT,TTSV
EXCH T,TSV
JRST @TSV
UUOS: HRRZ TT,JOBUUO
CAILE TT,@GCPP1
CAIL TT,@GCP1
JRST UUOSBR-1
JRST .+2
UUOEXP: HLRZ TT,(T)
UUOEX1: LDB T,[POINT 5,JOBUUO,ACFLD]
TRZN T,20
PUSH P,UUOH
PUSH P,TT
JUMPE T,IAPPLY
CAIN T,17
MOVEI T,1
MOVNS T
HRLZ TT,T
PUSH P,A(TT)
AOBJN TT,.-1
JRST IAPPLY
PAGE
ARGPDL: LDB T,[POINT 4,JOBUUO,ACFLD]
MOVNS T
HRLZ R,T
ARGP1: JUMPE R,(TT)
PUSH P,A(R)
AOBJN R,.-1
JRST (TT)
QTIFY: PUSHJ P,NCONS
FOO MOVEI B,CQUOTE
JRST XCONS
QTLFY: MOVEI A,0
QTLFY1: JUMPE T,(TT)
EXCH A,(P)
PUSHJ P,QTIFY
POP P,B
PUSHJ P,CONS
AOJA T,QTLFY1
PDLARG: JRST .+NACS+2(T)
POP P,A+5
POP P,A+4
POP P,A+3
POP P,A+2
POP P,A+1
POP P,A
JRST (TT)
NOUUO: MOVSI B,(TLNN TT,)
SKIPE A
MOVSI B,(TLNA)
HLLM B,UUOCL
EXCH A,NOUUOF#
POPJ P,
PAGE
;r=0 => compiler calling a -
;r=1 => compiler calling a lsubr
;r=2 => compiler calling f type
UUST: UUOSBR
UUOS1 ;calling l its a subr
UUOS2 ;calling f
UUFST: UUOS9 ;calling - its a f
UUOS10 ;calling l
UUOSBR
UULT: UUOS7 ;calling - its a l
UUOSBR
UUOS8
UUET: UUOEXP
UUOS5 ;calling l its an expr
UUOS6 ;calling f its an expr
UUFET: UUOS3 ;calling - its a fexpr
UUOS4 ;calling l
UUOEXP
UUOS1: HLRZ R,(T)
MOVE T,TSV
JSP TT,PDLARG
JRST (R)
UUOS3: PUSH P,(T)
JSP TT,ARGPDL
UUOS4A: JSP TT,QTLFY
MOVEI TT,1
DPB TT,[POINT 4,JOBUUO,ACFLD]
UUOS6A: POP P,TT
HLRZS TT
JRST UUOEX1
UUOS4: PUSH P,(T)
MOVE T,TSV
JRST UUOS4A
PAGE
UUOS5: HLRZ R,(T)
MOVE T,TSV
JSP TT,PDLARG
MOVE TT,R
JRST UUOEX1
UUOS6: PUSH P,(T)
PUSH P,UUOH
PUSH P,JOBUUO
JSP TT,ILIST
JSP TT,PDLARG
POP P,JOBUUO
POP P,UUOH
JRST UUOS6A
UUOS8: SKIPA TT,CILIST
UUOS7: MOVEI TT,ARGPDL
HRRM TT,UUOS7A
MOVE TT,JOBUUO
TLNN TT,1000
PUSH P,UUOH
HLRZ TT,(T)
UUOS7A: JRST ARGPDL+X ;or ilist
UUOS9: PUSH P,T
JSP TT,ARGPDL
UUS10A: JSP TT,QTLFY
MOVSI T,2000
IORM T,JOBUUO
POP P,T
JRST UUOSBR
UUOS10: PUSH P,T
MOVE T,TSV
JRST UUS10A
SUBTTL ERROR HANDLER AND BACKTRACE --- PAGE 5
;subroutine to print sixbit error message
ERRSUB: MOVSI A,(POINT 6,0)
HRR A,JOBUUO
MOVEM A,ERRPTR#
ERRORB: ILDB A,ERRPTR
CAIN A,01 ;conversion from sixbit
POPJ P,
CAIN A,77
JRST [ PUSHJ P,TERPRI
JRST ERRORB]
ADDI A,40
PUSHJ P,TYO
JRST ERRORB
;subroutine to return output to previously selected device
OUTRET: SKIPL PRVCNT ;if prvcnt<0 then there was no device deselect
SOSL PRVCNT ;when prvcnt goes negative, then reselect
POPJ P,
PUSH P,PRVSEL# ;previously selected output
POP P,TYOD
POPJ P,
;subroutine to force error messages out on tty
ERRIO: MOVE B,ERRSW
CAIE B,INUM0 ;inum0 specifies to print message on selected device
AOSLE PRVCNT ;only if prvcnt already <0 does deselection occur
POPJ P,
TALK ;undo control o
MOVE B,[JRST TTYO]
EXCH B,TYOD
MOVEM B,PRVSEL
POPJ P,
ERRTN: 0 ;0 => top level *
;- => pdl to reset to - stored by errorset
;+ => string tyo pout rtn flag
ERRSW: -1 ;0 means no prnt on error *
PAGE
;subroutine to search oblist for closest function to address in r
ERSUB3:
FOO MOVEI A,QST
FOO HRROI NIL,CNIL2
HRLZ B,INT1
MOVNS B
SETZB AR2A,GOBF
PUSH P,JOBAPR
MOVEI C,[ SETOM GOBF
JRST ERRO2G]
HRRM C,JOBAPR
HLRZ C,@RHX5
ERRO2B: JUMPE C,[ AOBJN B,.-1
POP P,JOBAPR ;oblist done, restore
JRST PRINC] ;print closest match
HLRZ TT,(C)
ERRO2C: HRRZ TT,(TT)
JUMPE TT,ERRO2G
HLRZ AR1,(TT)
FOO CAIN AR1,LSUBR
JRST ERRO2H
FOO CAIE AR1,SUBR
FOO CAIN AR1,FSUBR
JRST ERRO2H
HRRZ TT,(TT)
JRST ERRO2C
ERRO2H: HRRZ TT,(TT)
HLRZ TT,(TT)
CAMLE TT,AR2A ;le to prefer car to quote
CAMLE TT,R
JRST ERRO2G
MOVE AR2A,TT
HLRZ A,(C)
ERRO2G: HRRZ C,(C)
JRST ERRO2B
PAGE
;dispatcher for error message uuos
ERROR:
IFE TENEX,< MOVEI A,APRFLG
CALLI A,APRINI > ;enable interupts
IFN TENEX,< JSR APRSET >
LDB A,[POINT 9,JOBUUO,OPFLD] ;get opcode
CAIL A,UUOMIN ;what
CAILE A,UUOMAX ;is it?
JRST ILLUUO ;an illegal opcode
JRST @ERRTAB-UUOMIN(A) ;or LISP error
ERRTAB: ERROR1 ;1 ;ordinary LISP error
ERRORG ;2 ;space overflow error
ERROR2 ;3 ;ill. mem. ref.
STRTYP ;4 ;print error message and continue
ERRORG: SKIPN P,ERRTN ;if in errset, restore p to that level
MOVE P,C2 ;else to top level
;and attempt to print message
ERROR1: SKIPN ERRSW
JRST ERREND ;dont print message, call (err nil)
PUSHJ P,ERRIO ;print message on tty
PUSHJ P,TERPRI
PUSHJ P,ERRSUB ;print the message
JRST ERRBK ;go the backtrace
STRTYP: PUSHJ P,ERRIO
PUSHJ P,ERRSUB ;print message and continue
PUSHJ P,OUTRET
JRST @UUOH
PAGE
ERROR2: HRRZ A,JOBUUO
MOVEI B,[SIXBIT / ILL MEM REF FROM !/]
JRST ERSUB2
ILLUUO: HRRZ A,UUOH
MOVEI B,[SIXBIT / ILL UUO FROM !/]
ERSUB2: SKIPN ERRSW
JRST ERREND ;dont print message
PUSH P,A
PUSH P,B
PUSHJ P,ERRIO
PUSHJ P,TERPRI
PUSHJ P,PRINL2 ;print number
POP P,A
STRTIP (A) ;print message
POP P,R
PUSHJ P,ERSUB3 ;print nearest oblist match
ERRBK: SKIPE BACTRF#
PUSHJ P,BKTRC ;print backtrace
PUSHJ P,OUTRET ;return to previous device
ERREND: MOVEI A,0 ;(err nil)
SKIPN ERRTN
JRST [CLRBFI ;clear input buffer
SKIPE RSTSW
JRST LISP2;(*rset t) goes to read-eval-print loop without unbind
JRST LSPRET] ;unbind and go to top level
ERR: SKIPN ERRTN
JRST LSPRET ;not in an errset, or bad error -- go to top level
MOVE P,ERRTN
ERR1: POP P,B
PUSHJ P,UBD ;unbind to previous errset
POP P,ERRSW
POP P,ERRTN
JRST ERRP4 ;and proceed
ERRSET: PUSH P,PA3
PUSH P,PA4
PUSH P,ERRTN
PUSH P,ERRSW
PUSH P,SP
MOVEM P,ERRTN
HRRZ C,(A)
HLRZ C,(C)
MOVEM C,ERRSW
HLRZ A,(A)
PUSHJ P,EVAL
PUSHJ P,NCONS
JRST ERR1
PAGE
;error messages
DOTERR: SETZM OLDCH
ERR1 [ SIXBIT /DOT CONTEXT ERROR!/]
UNDFUN: HLRZ A,(AR1)
PUSHJ P,EPRINT
ERR1 [SIXBIT /UNDEFINED FUNCTION!/]
UNBVAR: PUSHJ P,EPRINT
ERR1 [SIXBIT /UNBOUND VARIABLE - EVAL!/]
NONNUM: ERR1 [SIXBIT /NON-NUMERIC ARGUMENT!/]
NOPNAM: ERR1 [SIXBIT /NO PRINT NAME - INTERN!/]
NOLIST: ERR1 [SIXBIT /NO LIST-MAKNAM!/]
TOMANY: ERR1 [SIXBIT /TOO MANY ARGUMENTS SUPPLIED - APPLY!/]
TOOFEW: ERR1 [SIXBIT /TOO FEW ARGUMENTS SUPPLIED - APPLY!/]
UNDTAG: PUSHJ P,EPRINT
ERR1 [SIXBIT /UNDEFINED FUNCTION - APPLY!/]
EG1: HRRZ A,T
PUSHJ P,EPRINT
ERR1 [SIXBIT /UNDEFINED PROG TAG-GO!/]
PAGE
;backtrace subroutine
BKTRC: MOVEI D,-1(P)
MOVN A,BACTRF
ADDI A,INUM0
JUMPL A,[ ADD A,P ;backtrace specific number
JRST .+3]
SKIPN A,ERRTN ;backtrace to previous errset
MOVE A,C2 ;or top level
HRRZM A,BAKLEV#
STRTIP [SIXBIT /_BACKTRACE_!/]
BKTR2: CAMG D,BAKLEV
JRST FALSE ;done
HRRZ A,(D) ;get pdl element
FOO CAIGE A,FS
JUMPN A,.+2 ;this is (hopefully) a true program address
SOJA D,BKTR2 ;not a program address, continue
CAIN A,ILIST3
JRST BKTR1A ;argument evaluation
BKTR1B: CAIN A,CPOPJ
JRST [ HLRZ A,(D) ;calling a function
PUSHJ P,PRINC
XCT "-",CTY
STRTIP [SIXBIT /ENTER !/]
SOJA D,BKTR2]
HLRZ B,-1(A)
CAILE B,(JCALLF 17,@(17))
CAIN B,(PUSHJ P,) ;tests for various types of calls
CAIGE B,(FCALL)
SOJA D,BKTR2 ;not a proper function call
PUSH P,-1(A) ;save object of function call
MOVEI R,-1(A) ;location of function call
PUSHJ P,ERSUB3 ;print closest oblist match
MOVEI A,"-"
PUSHJ P,TYO
POP P,R
TLNE R,17
HRRZ R,ERSUB3 ;qst -- cant handle indexed calls
HRRZS R
HLRO B,(R)
AOSN B
JRST [ HRRZ A,R ;was calling an atomic function
PUSHJ P,PRINC ;print its name
JRST .+2]
PUSHJ P,ERSUB3 ;was calling a code location -- print closest match
MOVEI A," "
PUSHJ P,TYO
BKTR1: SOJA D,BKTR2 ;continue
BKTR1A: HRRZ B,-1(D)
CAIE B,EXP2
CAIN B,ESB1
JRST .+2
JRST BKTR1B ;hum, not really evaluating arguments
HLRE B,-1(D)
ADD B,D
HLRZ A,-3(B)
JUMPE A,BKTR1
PUSHJ P,PRINC
XCT "-",CTY
STRTIP [SIXBIT /EVALARGS !/]
JRST BKTR1
BAKGAG: EXCH A,BACTRF
POPJ P,
SUBTTL TYI AND TYO --- PAGE 6
;input
ITYI: PUSHJ P,TYI
FIXI: ADDI A,INUM0
POPJ P,
TYI: MOVEI AR1,1
PUSHJ P,TYIA
JUMPE A,.-1
CAME A,IGSTRT ;start of comment or ignored cr-lf
POPJ P,
PUSHJ P,COMMENT
JRST TYI+1
TYIA: SKIPE A,OLDCH
JRST TYI1
TYID:
TYI2: JRST TTYI+X ;sosg x for other device input
;other device input
JRST TYI2X
TYI3: ILDB A,X ;pointer
TYI3A: TDNN AR1,@X ;pointer
JRST TYI4
MOVE A,@TYI3A
CAMN A,[<ASCII / />+1] ;page mark for stopgap
AOSA PGNUM ;increment page number
MOVEM A,LINUM
MOVNI A,5
ADDM A,@TYI2 ;adjust character count for line number
AOS @TYI3 ;increment byte pointer over line number and tab
JRST TYI2
TYI4:
FOO SKIPN VFECHO
POPJ P,
JRST TTYO ;FILE-INPUT ECHO TO TTY.
TYI2X: INPUT X,
TYI2Y: STATZ X,740000
ERR1 AIN.8 ;input error
TYI2Z: STATO X,20000
JRST TYI3 ;continue with file
PUSH P,T ;end of file
PUSH P,C
PUSH P,R
PUSH P,AR1
MOVE A,INCH
HRRZ C,CHTAB(A) ;get location of data for this channel
HLRZ T,CHTAB(A) ;inlst -- remaining files to input
JUMPE T,TYI2E ;none left -- stop
PUSHJ P,SETIN ;start next input
POP P,AR1
POP P,R
POP P,C
POP P,T
JRST TYI
TYI2E: PUSHJ P,INCNT ;(inc nil t)
TALK ;turn off control o
FOO MOVEI A,$EOF$ ;we are done
JRST ERR
PGLINE: MOVE C,[POINT 7,LINUM]
PUSHJ P,NUM10 ;convert ascii line number to a integer
PUSHJ P,FIX1A ;(may be larger than INUM size - 99999).
MOVE B,PGNUM
ADDI B,INUM0+1
JRST XCONS
OLDCH: 0
PGNUM: 0
LINUM: 0
0 ;zero to terminate num10
PAGE
;teletype input
TTYI: SKIPE DDTIFG
JRST TTYID
INCHSL A ;single char if line has been typed
JRST [TALK ;turn off control o, this
; can be omitted when ttyser is fixed
OUTSTR PCHAR ;output THE PROMPT-CHAR(S).
INCHWL A ;wait for a line
JRST .+1]
TTYXIT: CAIN A,BELL
JRST LSPRET ;bell returns to top level
POPJ P,
TTYID: TALK ;turn off control o, remove this when ttyser works
INCHRW A ;single character input ddt submode style
CAIE A,RUBOUT
JRST TTYXIT
OUTCHR ["\"] ;echo backslash
SKIPE PSAV
JRST RDRUB ;rubout in read resets to top level of read
MOVEI A,RUBOUT
POPJ P,
PCHAR: ASCIZ /*/ ;INITIAL (DEFAULT) PROMPT-CHAR.
SETPCH: PUSHJ P,PNAMUK
MOVE A,1(SP) ;(FIRST WORD OF PNAME OF ARG).
TRZ A,377 ;(INSURE NULL AT END OF STRING).
MOVEM A,PCHAR
JRST TRUE
PAGE ;output ROUTINES.
ITYO: SUBI A,INUM0
PUSHJ P,TYO
JRST FIXI
TYO: CAIG A,CR
JRST TYO3
SOSGE CHCT
JRST TYO1
TYOD: JRST TTYO+X ;sosg x for other device
;other device output
JRST TYO2X
TYO5: IDPB A,X
POPJ P,
TYO2X: OUT X,
JRST TYO5
ERR1 [SIXBIT /OUTPUT ERROR!/]
TYO1: PUSH P,A ;linelength exceeded
MOVEI A,IGCRLF ;inored cr-lf
PUSHJ P,TYOD
PUSHJ P,TERPRI ;force out a cr-lf, with special mark
POP P,A
SOSA CHCT
TYO4: POP P,B
JRST TYOD
TYO3: CAIGE A,TAB
JUMPN A,TYO+2 ;everything between 0(null) and 11(tab) decrement chct
PUSH P,B
MOVE B,LINL
CAIN A,TAB
JRST [ SUB B,CHCT
IORI B,7 ;simulate tab effect on chct
SUB B,LINL
SETCAM B,CHCT
JRST TYO4]
CAIN A,CR
MOVEM B,CHCT ;reset chct after a cr
JRST TYO4
PAGE
LINELENGTH:
JUMPE A,LINEL1
SUBI A,INUM0
HRRM A,LINL
HRRM A,CHCT
LINEL1: HRRZ A,LINL
JRST FIXI
CHRCT: MOVE A,CHCT
JRST FIXI
LINL: TTYLL ;*
CHCT: TTYLL ;*
;teletype output
TTYO:
IFN TENEX, <SKIPE OFLAG ;IS ^O FLAG SET?
JRST CNTLOB> ; YES.
OUTCHR A ;OUTPUT SINGLE CHARACTER IN A
POPJ P,
IFN TENEX, <
CNTLOB: PUSH P,A
HRRZI 1,101 ; TO PRINCIPAL OUTPUT DEVICE (TTY)
CFOBF ;CLEAR ITS OUTPUT BUFFER
JRST POPAJ
>
PAGE
DDTIFG: TRUTH
DDTIN: EXCH A,DDTIFG
POPJ P,
TTYRET: PUSHJ P,OUTCNT
JRST INCNT
;all of this crap is to turn off control o. lose-lose-lose
TTYCLR:
IFE TENEX, <
RELEASE TTCH,
INIT TTCH,1
SIXBIT /TTY/
XWD TOBUF,0
HALT
PUSH P,A
MOVEI A,TTOBUF-1
MOVEM A,JOBFF
OUTBUF TTCH,1
OUTPUT TTCH, ;set up buffer
MOVEI A,0
IDPB A,TOBUF+1 ;plant a null character
AOS TOBUF+2
OUTPUT TTCH, ;output it
JRST POPAJ
>
IFN TENEX, < ;TURN ^O OFF IF IT'S ON
PUSH P,A
HRRZI 1,101
DOBE ;WAIT UNTIL OUTBUF EMPTY !!!!
SKIPN OFLAG ;SEE IF ^O STILL ON NOW, IF EVER.
JRST POPAJ ; OFF---READY OR NOT, BACK WE GO.
SETZM OFLAG ;TO LET TERPRI AND ANYTHING ELSE OUT.
OUTSTR [ASCIZ /
/]
JRST POPAJ
>
TOBUF: BLOCK 3
TTOBUF: BLOCK 33
TTOCH: 0 ;*
0 ;tty page number always zero
0 ;tty line number -- always zero
TTOLL: TTYLL ;*
TTOHP: TTYLL ;*
SUBTTL INPUT AND OUTPUT INITIALIZATION AND CONTROL --- PAGE 7
;convert ascii to sixbit for device initialization routines
SIXMAK: SETZM SIXMK2#
MOVE AR1,[POINT 6,SIXMK2]
HRROI R,SIXMK1
PUSHJ P,PRINTA ;use print to unpack ascii characters
MOVE A,SIXMK2
POPJ P,
SIXMK1: ADDI A,40
TLNN AR1,770000
POPJ P, ;last character position -- ignore remaining chars
CAIN A,"."+40
MOVEI A,0 ;ignore dots at end of numbers for decimal base
CAIN A,":"+40
HRLI AR1,(POINT 6,0,29) ;deposit : in last char position
IDPB A,AR1
POPJ P,
;subroutine to process next item in file name list
INXTIO: JUMPE T,NXTIO
HRRZ T,(T)
NXTIO: HLRZ A,(T)
PUSHJ P,ATOM
JUMPE A,CPOPJ ;non-atomic
HLRZ A,(T)
JRST SIXMAK ;make sixbit if atomic
;right normalize sixbit
LSH A,-6
SIXRT: TRNN A,77
JRST .-2
POPJ P,
PAGE
IOSUB: PUSHJ P,NXTIO
MOVEM T,DEVDAT#
LDB B,[POINT 6,A,35]
JUMPE A,IOPPN ;non-atomic item, must be ppn or (file.ext)
CAIE B,":"-40
JRST IOFIL ;not a device name -- must be file name
TRZ A,77 ;clear out the :
SETZM PPN
IODEV2: MOVEM A,DEV
PUSHJ P,INXTIO
IOPPN: JUMPN A,IOFIL ;not ppn or (fil.ext)
PUSHJ P,PPNEXT
JUMPN A,IOEXT ;(fil.ext)
HLRZ A,(T)
HLRZ A,(A) ;caar is project number
PUSHJ P,SIXMAK
PUSHJ P,SIXRT
PUSHJ P,IOPPNX ;**********KRK
HRLM A,PPN ;project number
HLRZ A,(T)
PUSHJ P,CADR ;cadar is programmer number
PUSHJ P,SIXMAK
PUSHJ P,SIXRT
PUSHJ P,IOPPNX ;**********KRK
HRRM A,PPN ;programmer number
HRLZI A,(SIXBIT /DSK/) ;disk is assumed
JRST IODEV2
IOPPNX: ROTC A,-3 ;**********KRK
LSH A,-3 ;**********KRK
ROTC A,-3 ;**********KRK
LSH A,-3 ;**********KRK
ROTC A,-3 ;**********KRK
CLEAR A, ;**********KRK
ROTC A,9 ;**********KRK
POPJ P, ;BASE MUST BE 8 **********KRK
; DURING INPUT INST **********KRK
IOFIL: SKIPN DEV
JRST AIN.1 ;no device named
JUMPN A,IOFIL2 ;was it an atom
JUMPE T,CPOPJ ;no, was it nil (end)
PUSHJ P,PPNEXT
JUMPE A,CPOPJ ;see a ppn, no file named
IOEXT: HLRZ A,(T) ;(file.ext)
HRRZ A,(A) ;get cdr == extension
PUSHJ P,SIXMAK
HLLM A,EXT
HLRZ A,(T)
HLRZ A,(A) ;get car = file name
PUSHJ P,SIXMAK
FIL: PUSH P,A
PUSHJ P,INXTIO
JRST POPAJ
IOFIL2: CAIN B,":"-40
POPJ P, ;saw a :,not file name
SETZM EXT ;file name -- clear extension
JRST FIL
PPNEXT: JUMPE T,CPOPJ ;end of file name list
HLRZ A,(T)
HRRZ A,(A) ;cdar
JRST ATOM ;ppn iff (not(atom(cdar l)))
CHNSUB: MOVE T,A
HLRZ A,(T)
PUSHJ P,ATOM
JUMPE A,TRUE ;non-atomic head of list -- no channel named
HLRZ A,(T)
PUSHJ P,SIXMAK
ANDI A,77
CAIN A,":"-40
JRST TRUE ;device name, assume channel name t
HLRZ A,(T) ;channel name -- return it
HRRZ T,(T)
POPJ P,
CHTAB=.-FSTCH
BLOCK NIOCH ;*
;channel data
CHNAM==0 ;name of channel
CHDEV==1 ;name of device
CHPPN==2 ;ppn for input channel
CHOCH==3 ;oldch for input channels
CHPAGE==4 ;page number for input
CHLINE==5 ;line number for input
CHDAT==6 ;device data
POINTR==7 ;byte pointer for device buffer
COUNT==10 ;character count for device buffer
CHLL==2 ;linelength for output channel
CHHP==3 ;hposit for output channels
PAGE
;search for channel name in chtab
TABSR1: MOVE A,[XWD -NIOCH,FSTCH]
MOVE C,CHTAB(A)
CAME B,CHNAM(C)
AOBJN A,.-2
CAMN B,CHNAM(C)
POPJ P, ;found it!!!
JRST FALSE ;lost
;search for channel name in chtab, and if not there find a free channel, and
;if no free channel, allocate a new buffer and channel
TABSRC: MOVE B,A
PUSHJ P,TABSR1
JUMPN A,DEVCLR ;found the channel
PUSH P,B
MOVE B,0
PUSHJ P,TABSR1 ;find a physical channel no. for a free channel
JUMPE A,[ERR1 [SIXBIT $NO I/O CHANNELS LEFT !$]]
POP P,B
JUMPN C,DEVCLR ;found free channel which had buffer space previously
PUSH P,A ;must allocate new buffer
MOVEI A,BLKSIZ
PUSHJ P,MORCOR ;expand core for buffer if necessary
MOVE C,A
POP P,A
HRRM C,CHTAB(A)
DEVCLR: HRRZ C,CHTAB(A)
HRRZM B,CHNAM(C) ;store name
HRRZM A,CHANNEL#
POPJ P,
;subroutine to reset all i/o channels -- used by excise and realloc
IOBRST: X ;jsr location
HRRZ A,JOBREL
HRLM A,JOBSA
MOVEM A,CORUSE#
MOVEM A,JOBSYM
SETZM CHTAB+FSTCH
MOVE A,[XWD CHTAB+FSTCH,CHTAB+FSTCH+1]
BLT A,CHTAB+NIOCH+FSTCH-1 ;clear channel table
JRST @IOBRST
PAGE
INPUT: PUSHJ P,CHNSUB ;determine channel name
PUSH P,A
PUSHJ P,TABSRC ;get physical channel number
PUSHJ P,SETIN ;init device
JRST POPAJ
SETIN: MOVEM A,CHANNEL
MOVE A,CHDEV(C)
MOVEM A,DEV
MOVE A,CHPPN(C)
MOVEM A,PPN
PUSHJ P,IOSUB ;get device and file name
MOVEM A,LOOKIN ;file name
MOVE A,DEV
CALLI A,DEVCHR
TLNN A,INB
JRST AIN.2 ;not input device
TLNN A,AVLB
JRST AIN.4 ;not available
MOVE A,CHANNEL
DPB A,[POINT 4,ININIT,ACFLD] ;set up channel numbers
DPB A,[POINT 4,INLOOK,ACFLD]
DPB A,[POINT 4,ININBF,ACFLD]
HRRZ B,CHTAB(A)
HRLM T,CHTAB(A) ;save remaining file name list
MOVEI A,CHDAT(B)
MOVEM A,DEV+1 ;pointer to bufdat
IFN TENEX, < ;shunt SYS: to <LISP>'s dir (or wherever).
HRLZI A,(SIXBIT /SYS/)
CAME A,DEV
JRST ININIT
HRLZI A,(SIXBIT /DSK/)
MOVEM A,DEV
MOVE A,SYSNUM#
MOVEM A,PPN
>
ININIT: INIT X,
DEV: X
X
JRST AIN.7 ;cant init
PUSH B,DEV
PUSH B,PPN
INLOOK: LOOKUP X,LOOKIN
JRST AIN.7 ;cant find file
PUSH B,[0] ;oldch
PUSH B,[0] ;line number
PUSH B,[0] ;page number
ADDI B,4
HRRM B,JOBFF
ININBF: INBUF X,NIOB
JRST TRUE
ENTR:
LOOKIN: BLOCK 4
EXT=LOOKIN+1
PPN=LOOKIN+3
PAGE
OUTPUT: PUSHJ P,CHNSUB ;get channel name
PUSH P,A
TRO A,400000 ;set bit for output
PUSHJ P,TABSRC ;get physical channel nuber
PUSHJ P,IOSUB ;get device and file name
MOVEM A,ENTR ;file name
SETZM ENTR+2 ;zero creation date
MOVE A,CHANNEL
DPB A,[POINT 4,AOUT2,ACFLD] ;setup channel numbers
DPB A,[POINT 4,OUTENT,ACFLD]
DPB A,[POINT 4,OUTOBF,ACFLD]
HRRZ B,CHTAB(A)
MOVEI A,CHDAT(B)
HRLM A,AOUT3+1
MOVE A,DEV
MOVEM A,AOUT3
CALLI A,DEVCHR
TLNN A,OUTB
JRST AOUT.2 ;not output device
TLNN A,AVLB
JRST AOUT.4 ;not available
AOUT2: INIT X,
AOUT3: X
X
JRST AOUT.4 ;cant init
PUSH B,DEV
OUTENT: ENTER X,ENTR
JRST OUTERR ;cant enter
PUSH B,[LPTLL] ;linelength
PUSH B,[LPTLL] ;chrct
ADDI B,6
HRRM B,JOBFF
OUTOBF: OUTBUF X,NIOB
JRST POPAJ
OUTERR: PUSHJ P,AIOP
LDB A,[POINT 3,ENTR+1,35]
CAIE A,2
ERR1 [SIXBIT /DIRECTORY FULL !/]
ERR1 [SIXBIT /FILE IS WRITE PROTECTED !/]
PAGE
IOSEL: MOVE C,-1(P)
JUMPE C,CPOPJ ;tty
JUMPE B,IOSELZ ;dont release
DPB C,[POINT 4,.+1,ACFLD]
RELEASE X, ;release channel
HRRZS CHTAB(C) ;release channel table entry
MOVEM 0,@CHTAB(C) ;blast channel name
SETZM -1(P)
IOSELZ: HRRZ C,CHTAB(C)
POPJ P,
PAGE
INCNT: MOVEI A,NIL ;(INC NIL T)
MOVEI B,TRUTH
INC: PUSH P,INCH#
PUSHJ P,IOSEL
JUMPN B,INC2 ;released channel
SKIPN C
MOVEI C,TTOCH-CHOCH ;tty deselect
MOVEI B,CHOCH(C)
HRLI B,OLDCH
BLT B,CHLINE(C) ;save channel data
INC2: JUMPE A,ITTYRE ;select tty
MOVE B,A
PUSHJ P,TABSR1 ;determine physical channel number
JUMPE A,[ERR1 [SIXBIT/NO INPUT - INC!/]]
HRRZM A,INCH
DPB A,[POINT 4,TYI2X,ACFLD] ;set up channel numbers
DPB A,[POINT 4,TYI2Y,ACFLD]
DPB A,[POINT 4,TYI2Z,ACFLD]
HRRZ A,CHTAB(A)
MOVEI T,COUNT(A)
HRLI T,(SOSG)
MOVEI B,POINTR(A)
HRRM B,TYI3 ;set up tyi parameters
HRRM B,TYI3A
INC3: MOVSI B,CHOCH(A)
HRRI B,OLDCH
BLT B,LINUM ;restore channel data
MOVEM T,TYID
IOEND: POP P,A
JUMPE A,CPOPJ
MOVE A,CHTAB(A) ;get channel name
HRRZ A,(A)
TRZ A,400000 ;clear output bit
POPJ P,
ITTYRE: SETZM INCH
MOVE T,[JRST TTYI] ;reselect tty
MOVEI A,TTOCH-CHOCH
JRST INC3
PAGE
OUTCNT: MOVEI A,0 ;(outc nil t)
MOVEI B,1
OUTC: PUSH P,OUTCH#
PUSHJ P,IOSEL
JUMPN B,OUTC2 ;closed this file
SKIPN C
MOVEI C,TTOLL-CHLL ;tty deselect
MOVE B,CHCT
MOVEM B,CHHP(C) ;save channel data
MOVE B,LINL
MOVEM B,CHLL(C)
OUTC2: JUMPE A,OTTYRE ;return to tty
TRO A,400000 ;set output bit
MOVE B,A
PUSHJ P,TABSR1 ;determine physical channel number
JUMPE A,[ERR1 [SIXBIT /NO OUTPUT - OUTC!/]]
DPB A,[POINT 4,TYO2X,ACFLD] ;set up tyo2 channel numbers
HRRZM A,OUTCH
HRRZ A,CHTAB(A)
MOVEI B,POINTR(A)
HRRM B,TYO5 ;set up tyo2 parameters
MOVEI T,COUNT(A)
HRLI T,(SOSG)
OUTC3: MOVE B,CHLL(A)
MOVEM B,LINL
MOVE B,CHHP(A)
MOVEM B,CHCT
MOVEM T,TYOD
JRST IOEND
OTTYRE: SETZM OUTCH
MOVE T,[JRST TTYO]
MOVEI A,TTOLL-CHLL ;tty reselect
JRST OUTC3
PAGE
AIN.1: PUSHJ P,AIOP
ERR1 [SIXBIT $ILLEGAL I/O ARG!$]
AOUT.2:
AIN.2: PUSHJ P,AIOP
ERR1 [SIXBIT /ILLEGAL DEVICE!/]
AOUT.4:
AIN.4: PUSHJ P,AIOP
ERR1 [SIXBIT /DEVICE NOT AVAILABLE !/]
AIN.7: PUSHJ P,AIOP
ERR1 [SIXBIT /CAN'T FIND FILE - INPUT!/]
AIN.8: SIXBIT /INPUT ERROR!/
AIOP: MOVE A,DEVDAT
JRST EPRINT
SUBTTL PRINT --- PAGE 8
EPRINT: SKIPN ERRSW
POPJ P,
PUSHJ P,ERRIO
PUSHJ P,PRINT
JRST OUTRET
PRINT: MOVEI R,TYO
PUSHJ P,TERPRI
PUSHJ P,PRIN1
XCT " ",CTY
POPJ P,
PRINC: SKIPA R,.+1
PRIN1: HRRZI R,TYO
PUSH P,A
PUSHJ P,PRINTA
JRST POPAJ
PRINTA: PUSH P,A
MOVEI B,PRIN3
SKIPGE R
MOVEI B,PRIN4
HRRM B,PRIN5
PUSHJ P,PATOM
JUMPN A,PRINT1
XCT "(",CTY
PRINT3: HLRZ A,@(P)
PUSHJ P,PRINTA
HRRZ A,@(P)
JUMPE A,PRINT2
MOVEM A,(P)
XCT " ",CTY
PUSHJ P,PATOM
JUMPE A,PRINT3
XCT ".",CTY
XCT " ",CTY
PUSHJ P,PRIN1A
PRINT2: XCT ")",CTY
JRST POPAJ
PRINT1: PUSHJ P,PRIN1A
JRST POPAJ
PAGE
PRIN1A: MOVE A,-1(P)
CAILE A,INUMIN
JRST PRINIC
JUMPE A,PRIN1B
CAIGE A,@GCP1
CAIGE A,@GCPP1
JRST PRINL
PRIN1B: HRRZ A,(A)
JUMPE A,PRINL
HLRZ B,(A)
HRRZ A,(A)
FOO CAIN B,PNAME
JRST PRINN
FOO CAIN B,FIXNUM
JRST PRINI1
FOO CAIN B,FLONUM
JRST PRINO
BPR: JRST PRIN1B ;bignums change here to JRST BPRINT
JRST PRIN1B
PRINL2: MOVEI R,TYO
JRST PRINL1
PRINL: XCT "#",CTY
HRRZ A,-1(P)
PRINL1: MOVEI C,8
JRST PRINI3
PRINI1: SKIPA A,(A)
PRINIC: SUBI A,INUM0
FOO HRRZ C,VBASE
SUBI C,INUM0
JUMPGE A,PRINI2
XCT "-",CTY
MOVNS A
PRINI2: MOVEI B,"."-"0"
HRLM B,(P)
CAIN C,TEN
FOO SKIPE %NOPOINT
JRST .+2
PUSH P,PRINI4
PRINI3: JUMPL A,[ MOVEI B,0 ;case of -2^35
MOVEI A,1
DIVI A,(C)
JRST .+2]
IDIVI A,0(C)
HRLM B,(P)
SKIPE A
PUSHJ P,.-3
PRINI4: JRST FP7A1
PRINN: HLRZ A,(A)
MOVEI C,2(SP)
PUSHJ P,PNAMU3
PUSH C,[0]
HRLI C,(POINT 7,0,35)
HRRI C,2(SP)
ILDB A,C
JUMPE A,CPOPJ ;special case of null character
CAIN A,DBLQT
JRST PSTR ;string
PRIN2X: LDB B,[POINT 1,CHRTAB(A),1]
JUMPL R,PRIN4 ;never slash
JRST PRIN2(B) ;1 for no slash
PRIN3: SKIPL CHRTAB(A) ;<0 for no slash
PRIN2: XCT "/",CTY
PRIN4: PUSHJ P,(R)
ILDB A,C
PRIN5: JUMPN A,PRIN3 ;prin4 for never slash
POPJ P,
PSTR: MOVS B,(C)
CAIN B,(<ASCII /"/>)
JRST PRIN2X ;special case of /"
PSTR3: SKIPL R ;dont print " if no slashify
PSTR2: PUSHJ P,(R)
ILDB A,C
CAIE A,DBLQT
JUMPN A,PSTR2
JUMPN A,PSTR3
POPJ P,
TERPRI: PUSH P,A
MOVEI A,CR
PUSHJ P,TYO
MOVEI A,LF
PUSHJ P,TYO
JRST POPAJ
CTY: JSA A,TYOI
TYOI: X
PUSH P,A
LDB A,[POINT 6,-1(A),ACFLD]
PUSHJ P,(R)
POP P,A
JRA A,(A)
PRINO: MOVE A,(A)
CLEARB B,C
JUMPG A,FP1
JUMPE A,FP3
MOVNS A
XCT "-",CTY
FP1: CAMGE A,FT01
JRST FP4
CAML A,FT8
AOJA B,FP4
FP3: MULI A,400
ASHC B,-243(A)
MOVE A,B
CLEARM FPTEM#
PUSHJ P,FP7
XCT ".",CTY
MOVNI T,8
ADD T,FPTEM
MOVE B,C
FP3A: MOVE A,B
MULI A,TEN
PUSHJ P,FP7B
SKIPE B
AOJL T,FP3A
POPJ P,
FP4: MOVNI C,6
MOVEI TT,0
FP4A: ADDI TT,1(TT)
XCT FCP(B)
TRZA TT,1
FMPR A,@FCP+1(B)
AOJN C,FP4A
PUSH P,TT
MOVNI B,-2(B)
DPB B,[POINT 2,FP4C,11]
PUSHJ P,FP3
MOVEI A,"E"
PUSHJ P,(R)
FP4C: XCT "+"+X,CTY
POP P,A
FP7: JUMPE A,FP7B
IDIVI A,TEN
AOS FPTEM
HRLM B,(P)
JUMPE A,FP7A1
PUSHJ P,FP7
FP7A1: HLRE A,(P)
FP7B: ADDI A,"0"
JRST (R)
353473426555 ;1e32
266434157116 ;1e16
FT8: 1.0E8
1.0E4
1.0E2
1.0E1
FT: 1.0E0
026637304365 ;1e-32
113715126246 ;1e-16
146527461671 ;1e-8
163643334273 ;1e-4
172507534122 ;1e-2
FT01: 175631463146 ;1e-1
FT0:
FCP: CAMLE A,FT0(C)
CAMGE A,FT(C)
XWD C,FT0
SUBTTL SUPER FAST TABLE DRIVEN READ 14-MAY-69 PAGE 9
;magic scanner table bit definitions
;bit 0=0 iff slashified as 1st id character
;bit 1=0 iff slashified as nth id character
;bits 2-5 ratab index
;bits 6-8 dotab index
;bits 9-10 strtab index
;bits 11-13 idtab index
;bits 14-16 exptab index
;bits 17-19 rdtab index
;bits 20-25 ascii to radix 50 conversion
IGSTRT: IGCRLF
IGEND: LF
RATFLD: POINT 4,CHRTAB(A),5
STRFLD: POINT 2,CHRTAB(A),10
IDFLD: POINT 3,CHRTAB(A),13
DOTFLD:
NUMFLD: POINT 3,CHRTAB(A),8
EXPFLD: POINT 3,CHRTAB(A),16
RDFLD: POINT 3,CHRTAB(A),19
R50FLD: POINT 6,CHRTAB(A),25
;magic state flags in t
EXP==1 ;exponent
NEXP==2 ;negative exponent
SAWDOT==4 ;saw a dot (.)
MINSGN==10 ;negative number
IDCLS==0 ;identifier
STRCLS==1 ;string
NUMCLS==2 ;number
DELCLS==3 ;delimiter
PAGE
;macros for scanner table
DEFINE RAD50 (X)<
IFB <X>,<R50VAL=0>
IFLE <"X"-"9">,<IFGE <"X"-"0">,<R50VAL="X"-"0"+1>>
IFIDN <"X"><".">,<R50VAL=45>
IFGE <"X"-"A">,<R50VAL="X"-"A"+13>>
DEFINE TABIN (S1,SN,R,D,S,I,E,RD,R50)<
XLIST
IRPC R50< RAD50 (R50)
BYTE (1)S1,SN(4)R(3)D(2)S(3)I,E,RD(6)R50VAL>
LIST>
DEFINE LET (X)<
TABIN (1,1,5,2,3,4,2,0,X)>
DEFINE DELIMIT (X,Y)<
TABIN (0,0,2,2,3,2,2,Y,X)>
DEFINE IGNORE (X)<
TABIN (0,0,3,2,3,2,2,0,X)>
PAGE
CHRTAB:
TABIN (0,0,1,1,1,1,1,0,< >)
;null
LET (< >)
IGNORE (< >)
;tab,lf,vtab,ff,cr
LET (< >)
;16 to 31
TABIN (0,0,0,0,0,0,0,0,< >)
;igmrk
IFN TENEX,< LET (< >) >
IFN DECUS,< DELIMIT (< >,3) >
;33 -- POTENTIAL ALTMODE.
LET (< >)
;34 to 37
IGNORE (< >)
;space
LET (< >)
;!
TABIN (0,0,9,2,2,2,2,0,< >)
;"
LET (< $% >)
;#$%&'
DELIMIT (< >,0)
DELIMIT (< >,1)
;()
LET (< >)
;*
TABIN (1,0,3,2,3,4,2,0,< >)
;+
IGNORE (< >)
;,
TABIN (1,0,6,2,3,4,2,0,< >)
;-
TABIN (0,0,7,3,3,2,2,4,<.>)
TABIN (0,0,4,2,3,3,2,0,< >)
;/
TABIN (1,0,8,5,3,4,3,0,<0123456789>)
LET (< >)
;:;<=>?
TABIN (1,0,2,2,3,4,2,5,< >)
;@
LET (<ABCD>)
TABIN (1,1,5,4,3,4,2,0,<E>)
LET (<FGHIJKLMNOPQRSTUVWXYZ>)
DELIMIT (< >,2)
;[
LET (< >)
;\
DELIMIT (< >,3)
;]
LET (< >)
;^_`
LET (<ABCDEFGHIJKLMNOPQRSTUVWXYZ>)
;lower case
LET (< >)
;{
IFN TENEX,< DELIMIT (< >,3) >
IFN DECUS,< LET (< >) >
;altmode
LET (< >)
;~
DELIMIT (< >,6)
;rubout
PAGE
READCH: PUSHJ P,TYI
MOVSI AR1,AR1
PUSHJ P,EXPL1
JRST CAR
READP1: SETZM NOINFG
READ0: PUSH P,TYID
PUSH P,OLDCH
SETZM OLDCH#
HRLI A,(JRST)
MOVEM A,TYID
PUSHJ P,READ+1
POP P,OLDCH
POP P,TYID
POPJ P,
RDRUB: MOVEI A,CR
PUSHJ P,TTYO
MOVEI A,LF
PUSHJ P,TTYO
SKIPA P,PSAV#
READ: SETZM NOINFG# ;0 means intern
MOVEM P,PSAV
PUSHJ P,READ1
SETZM PSAV
POPJ P,
READ1: PUSHJ P,RATOM
POPJ P, ;atom
XCT RDTAB2(B)
JRST READ1 ;try again
RDTAB2: JRST READ2 ;0 (
JFCL ;1 )
JRST READ4 ;2 [
JFCL ;3 ],$
JFCL ;4 .
JRST RDQT ;5 @
READ2: PUSHJ P,RATOM
JRST READ2A ;atom
XCT RDTAB(B)
READ2A: PUSH P,A
PUSHJ P,READ2
POP P,B
JRST XCONS
RDTAB: PUSHJ P,READ2 ;0 (
JRST FALSE ;1 )
PUSHJ P,READ4 ;2 [
JRST READ5 ;3 ],$
JRST RDT ;4 .
PUSHJ P,RDQT ;5 @
RDTX: PUSHJ P,RATOM
POPJ P, ;atom
XCT RDTAB2(B)
JRST DOTERR ;dot context error
RDT: PUSHJ P,RDTX
PUSH P,A
PUSHJ P,RATOM
JRST DOTERR
CAIN B,1
JRST POPAJ
CAIE B,3
JRST DOTERR
MOVEM A,OLDCH
JRST POPAJ
READ4: PUSHJ P,READ2
MOVE B,OLDCH
CAIE B,ALTMOD
TYI1: SETZM OLDCH ;kill the ]
POPJ P,
READ5: MOVEM A,OLDCH ;save ] or $
JRST FALSE ;and return nil
RDQT: PUSHJ P,READ1
JRST QTIFY
PAGE
;atom parser
COMMENT: PUSHJ P,TYID
CAME A,IGEND
JRST COMMENT
POPJ P,
RATOM: SETZB T,R
HRLI C,(POINT 7,0,35)
HRRI C,(SP)
MOVEI AR1,1
RATOM2: PUSHJ P,TYIA
LDB B,RATFLD
JRST RATAB(B)
RATAB: PUSHJ P,COMMENT ;0 comment
JRST RATOM2 ;1 null
JRST RATOM3 ;2 delimit
JRST RATOM2 ;3 ignore
PUSHJ P,TYI ;4 /
JRST RDID ;5 letter
JRST RDNMIN ;6 -
JRST RDOT ;7 .
JRST RDNUM ;8 digit
JRST RDSTR ;9 string
;a real dotted pair
RDOT2: MOVEM A,OLDCH
MOVEI A,"."
RATOM3: LDB B,RDFLD
HRRI R,DELCLS ;delimiter
AOS (P) ;non-atom (ie a delimiter)
POPJ P,
;dot handler
RDOT: PUSHJ P,TYID
LDB B,DOTFLD
JRST DOTAB(B)
DOTAB: PUSHJ P,COMMENT ;0 comment
JRST RDOT ;1 null
JRST RDOT2 ;2 delimit
JRST RDOT2 ;3 dot
JRST RDOT2 ;4 e
MOVEI B,0 ;5 digit
IDPB B,C
TLO T,SAWDOT
JRST RDNUM
PAGE
;string scanner
STRTAB: PUSHJ P,COMMENT ;0 comment
JRST RDSTR+1 ;1 null
JRST STR2 ;2 delimit
RDSTR: IDPB A,C ;3 string element
PUSHJ P,TYID
LDB B,STRFLD
JRST STRTAB(B)
STR2: MOVEI A,DBLQT
HRRI R,STRCLS ;string
IDPB A,C
NOINTR: PUSHJ P,IDEND ;no intern
PUSHJ P,IDSUB
JRST PNAMAK
;identifier scanner
IDTAB: PUSHJ P,COMMENT ;0
JRST RDID+1 ;1 null
JRST MAKID ;2 delimit
PUSHJ P,TYI ;3 /
RDID: IDPB A,C ;4 letter or digit
PUSHJ P,TYID
LDB B,IDFLD
JRST IDTAB(B)
PAGE
;number scanner
NUMTAB: PUSHJ P,COMMENT ;0 comment
JRST RDNUM+1 ;1 null
JRST NUMAK ;2 delimit
JRST RDNDOT ;3 dot
JRST RDE ;4 e
RDNUM: IDPB A,C ;5 digit
PUSHJ P,TYID
LDB B,NUMFLD
JRST NUMTAB(B)
RDNDOT: TLOE T,SAWDOT
JRST NUMAK ;two dots - delimit
MOVEI A,0
JRST RDNUM
RDNMIN: TLO T,MINSGN
JRST RDNUM+1
;exponent scanner
RDE: TLO T,EXP
MOVEI A,0
IDPB A,C
PUSHJ P,TYID
CAIN A,"-"
TLOA T,NEXP
CAIN A,"+"
JRST RDE2+1
JRST RDE2+2
EXPTAB: PUSHJ P,COMMENT ;0
JRST RDE2+1 ;1 null
JRST NUMAK ;2 delimit
RDE2: IDPB A,C ;3 digit
PUSHJ P,TYID
LDB B,EXPFLD
JRST EXPTAB(B)
PAGE
;semantic routines
;identifier interner and builder
IDEND: TDZA A,A
IDEND1: IDPB A,C
TLNE C,760000
JRST IDEND1
POPJ P,
MAKID: MOVEM A,OLDCH
PUSHJ P,IDEND
SKIPE NOINFG
JRST NOINTR ;dont intern it
INTER0: PUSHJ P,IDSUB
PUSHJ P,INTER1 ;is it in oblist
POPJ P, ;found
PUSHJ P,PNAMAK ;not there
MAKID2: MOVE C,CURBUC ;
HLRZ B,@RHX2
PUSHJ P,CONS ;cons it into the oblist
HRLM A,@RHX2
JRST CAR
CURBUC: 0
;pname unmaker
PNAMUK:
FOO MOVEI B,PNAME
PUSHJ P,GET
JUMPE A,NOPNAM
MOVE C,SP
PNAMU3: HLRZ B,(A)
PUSH C,(B)
HRRZ A,(A)
JUMPN A,PNAMU3
POPJ P,
;idsub constructs a iowd pointer for a print name
IDSUB: HRRZS C
CAML C,JRELO ;top of spec pdl
JRST SPDLOV
MOVNS C
ADDI C,(SP)
HRLI C,1(SP)
MOVSM C,IDPTR#
POPJ P,
PAGE ;identifier interner
INTER1: MOVE B,1(SP) ;get first word of pname
LSH B,-1 ;right justify it
INT1: IDIVI B,BCKETS+X ;compute hash code
RHX2:
FOO HLRZ TT,OBTBL(B+1) ;get bucket
MOVEM B+1,CURBUC ;save bucket number
MOVE T,TT
JRST MAKID1
MAKID3: MOVE TT,T ;save previous atom
HRRZ T,(T) ;get next atom
MAKID1: JUMPE T,CPOPJ1 ;not in oblist
HLRZ A,(T) ;next id in oblist
MAKID4: HRRZ A,(A)
JUMPE A,NOPNAM ;no print name
MOVE A,(A)
HLRZ C,A
FOO CAIE C,PNAME
JRST MAKID4
MOVE C,IDPTR ;found pname
HLRZ A,(A)
MAKID5: JUMPE A,MAKID3 ;not the one
MOVS A,(A)
MOVE B,(A)
ANDCAM AR1,(C) ;clear low bit
CAME B,(C)
JRST MAKID3 ;not the one
HLRZ A,A ;ok so far
AOBJN C,MAKID5
JUMPN A,MAKID3 ;not the one
HLRZ A,(T) ;this is it
HLRZ B,(TT)
HRLM A,(TT)
HRLM B,(T)
POPJ P,
;pname builder
PNAMAK: MOVE T,IDPTR
PUSHJ P,NCONS
MOVE TT,A
MOVE C,A
PNAMB: MOVE A,(T)
TRZ A,1 ;clear low bit!!!!!
PUSHJ P,FWCONS
PUSHJ P,NCONS
HRRM A,(TT)
MOVE TT,A
AOBJN T,PNAMB
MOVE A,C
HRLZS (A)
JRST PNGNK1+1
PAGE
;number builder
NUMAK: MOVEM A,OLDCH
HRRI R,NUMCLS ;number
MOVEI A,0
IDPB A,C
IDPB A,C
HRRZS C
CAML C,JRELO ;top of spec pdl
JRST SPDLOV
MOVSI C,(POINT 7,0,35)
HRRI C,(SP)
TLNE T,SAWDOT+EXP
JRST NUMAK2 ;decimal number or flt pt
FOO MOVE A,VIBASE ;ibase integrer
SUBI A,INUM0
PUSHJ P,NUM
NUMAK4:
FOO MOVEI B,FIXNUM
NUMAK6: TLNE T,MINSGN
MOVNS A
JRST MAKNUM
NUMAK2: PUSHJ P,NUM10
MOVEM A,TT
TLNN T,SAWDOT
JRST [ PUSHJ P,FLOAT ;flt pt without fraction
MOVE TT,A
JRST NUMAK3]
PUSHJ P,NUM10 ;fraction part
EXCH A,TT
TLNN T,EXP
JUMPE AR2A,NUMAK4 ;no exponent and no fraction
PUSHJ P,FLOAT
EXCH A,TT
PUSHJ P,FLOAT
MOVEI AR1,FT01
PUSHJ P,FLOSUB
FMPR A,B
FADRM A,TT
NUMAK3: PUSHJ P,NUM10 ;exponent part
MOVE AR2A,A
MOVEI AR1,FT-1
TLNE T,NEXP
MOVEI AR1,FT01 ;-exponent
PUSHJ P,FLOSUB
FMPR TT,B ;positive exponent
FOO MOVEI B,FLONUM
MOVE A,TT
JFCL 10,FLOOV
JRST NUMAK6
FLOSUB: MOVSI B,(1.0)
TRZE AR2A,1
FMPR B,(AR1)
JUMPE AR2A,CPOPJ
LSH AR2A,-1
SOJA AR1,FLOSUB+1
;variable radix integer builder
NUM10: MOVEI A,TEN
NUM: HRRM A,NUM1
JFCL 10,.+1 ;clear carry0 flag
SETZB A,AR2A
NUM2: ILDB B,C
JUMPE B,CPOPJ ;done
NUM1: IMULI A,X
ADDI A,-"0"(B)
NUM3: JFCL 10,FIXOV ;bignums change this to jfcl 10,rdbnm
AOJA AR2A,NUM2
PAGE
INTERN: MOVEM A,AR2A
PUSHJ P,PNAMUK
PUSHJ P,IDSUB
MOVEI AR1,1
PUSHJ P,INTER1 ;is it in oblist
POPJ P, ;found it
MOVE A,AR2A ;not there
JRST MAKID2 ;put it there
REMOB: JUMPE A,FALSE
MOVEI AR1,1
PUSH P,A
HLRZ A,(A)
PUSHJ P,INTERN
HLRZ B,@(P)
CAME A,B
JRST REMOB2
HRRZ B,CURBUC
RHX5:
FOO HLRZ C,OBTBL+X(B)
HLRZ T,(C)
CAMN T,A
JRST [ HRRZ TT,(C)
HRLM TT,@RHX5
JRST REMOB2]
REMOB3: MOVE TT,C
HRRZ C,(C)
HLRZ T,(C)
CAME T,A
JRST REMOB3
HRRZ T,(C)
HRRM T,(TT)
REMOB2: POP P,A
HRRZ A,(A)
JRST REMOB
SUBTTL LISP INTERPRETER SUBROUTINES --- PAGE 10
CADDDR: SKIPA A,(A)
CADDAR: HLRZ A,(A)
CADDR: SKIPA A,(A)
CADAR: HLRZ A,(A)
CADR: SKIPA A,(A)
CAAR: HLRZ A,(A)
CAR: HLRZ A,(A)
POPJ P,
CDDDDR: SKIPA A,(A)
CDDDAR: HLRZ A,(A)
CDDDR: SKIPA A,(A)
CDDAR: HLRZ A,(A)
CDDR: SKIPA A,(A)
CDAR: HLRZ A,(A)
CDR: HRRZ A,(A)
POPJ P,
CAADDR: SKIPA A,(A)
CAADAR: HLRZ A,(A)
CAADR: SKIPA A,(A)
CAAAR: HLRZ A,(A)
JRST CAAR
CDADDR: SKIPA A,(A)
CDADAR: HLRZ A,(A)
CDADR: SKIPA A,(A)
CDAAR: HLRZ A,(A)
JRST CDAR
CAAADR: SKIPA A,(A)
CAAAAR: HLRZ A,(A)
JRST CAAAR
CDDADR: SKIPA A,(A)
CDDAAR: HLRZ A,(A)
JRST CDDAR
CDAADR: SKIPA A,(A)
CDAAAR: HLRZ A,(A)
JRST CDAAR
CADADR: SKIPA A,(A)
CADAAR: HLRZ A,(A)
JRST CADAR
PAGE
QUOTE: HLRZ A,(A) ;car and quote duplicated for backtrace
POPJ P,
AASCII: PUSHJ P,NUMVAL
LSH A,^D29
PUSHJ P,FWCONS
PUSHJ P,NCONS
PNGNK1: PUSHJ P,NCONS
FOO MOVEI B,PNAME
PUSHJ P,XCONS
ACONS: TROA B,-1
NCONS: TRZA B,-1
XCONS: EXCH B,A
CONS: AOS CONSVAL
HRL B,A
SKIPN A,F
JRST [ HLR A,B
PUSHJ P,AGC
JRST .-1]
MOVE F,(F)
MOVEM B,(A)
POPJ P,
;new consing routines-not finished yet
;acons: troa b,-1
;ncons: trz b,-1
;cons: exch b,a
;xcons: hrl a,b
; exch a,(f)
; exch a,f
; popj p,
PATOM: CAIL A,@GCP1
JRST TRUE
CAIL A,@GCPP1
ATOM: CAILE A,INUMIN
JRST TRUE
HLLE A,(A)
AOJE A,TRUE
JRST FALSE
PAGE
EQ: CAMN A,B
JRST TRUE
JRST FALSE
LENGTH: MOVEI B,0
LNGTH1: CAILE A,INUMIN
JRST FIX1
HLLE C,(A)
AOJE C,FIX1
HRRZ A,(A)
AOJA B,LNGTH1
LAST: HRRZ B,(A)
CAILE B,INUMIN
POPJ P,
HLLE B,(B)
AOJE B,CPOPJ
HRRZ A,(A)
JRST LAST
RPLACA: HRLM B,(A)
POPJ P,
RPLACD: HRRM B,(A)
POPJ P,
ZEROP: PUSHJ P,NUMVAL
NOT:
NULL: JUMPN A,FALSE
TRUE:
FOO MOVEI A,TRUTH
POPJ P,
FW0CNS: MOVEI A,0
FWCONS: JUMPN FF,FWC1
EXCH A,FWC0#
PUSHJ P,AGC
EXCH A,FWC0
FWC1: EXCH A,(FF)
EXCH A,FF
POPJ P,
PAGE
SASSOC: PUSHJ P,SAS1
JCALLF 0,(C)
POPJ P,
SAS0: HLRZ B,T
SAS1: JUMPE B,CPOPJ
MOVS T,(B)
MOVS TT,(T)
CAIE A,(TT)
JRST SAS0
HRRZ A,T
CPOPJ1: AOS (P)
POPJ P,
ASSOC: PUSHJ P,SAS1
FALSE: MOVEI A,NIL
CPOPJ: POPJ P,
REVERSE: MOVE T,A
MOVEI A,0
JUMPE T,CPOPJ
HLRZ B,(T)
HRRZ T,(T)
PUSHJ P,XCONS
JUMPN T,.-3
POPJ P,
REMPROP: HRRZ T,(A)
MOVS TT,(T)
CAIN B,(TT)
JRA TT,REMP1
HLRZ A,TT
HRRZ T,(A)
JUMPN T,REMPROP+1
JRST FALSE
REMP1: HRRM TT,(A)
JRST TRUE
PAGE
GET: HRRZ A,(A)
MOVS D,(A)
CAIN B,(D)
JRST CADR
HLRZ A,D
HRRZ A,(A)
JUMPN A,GET+1
POPJ P,
GETL: HRRZ A,(A)
GETL0: HLRZ T,(A)
MOVE C,B
GETL1: MOVS TT,(C)
CAIN T,(TT)
POPJ P,
HLRZ C,TT
JUMPN C,GETL1
HRRZ A,(A)
HRRZ A,(A)
JUMPN A,GETL0
POPJ P,
NUMBERP: CAILE A,INUMIN
JRST TRUE
HLLE T,(A)
AOJN T,FALSE
HRRZ A,(A)
HLRZ A,(A)
FOO CAIE A,FIXNUM
FOO CAIN A,FLONUM
JRST TRUE
NUMBP2: JRST FALSE ;bignums change this to JRST BIGNP
PAGE
PUTPROP: MOVE T,A
HRRZ A,(A)
CSET3: MOVS TT,(A)
HLRZ A,TT
CAIN C,(TT)
JRST CSET2
HRRZ A,(A)
JUMPN A,CSET3
HRRZ A,(T)
PUSHJ P,XCONS
HRRZ B,C
PUSHJ P,XCONS
HRRM A,(T)
JRST CADR
CSET2:
FOO CAIE C,VALUE
JRST CSET1
HRRZ T,(B)
HLRZ A,(A)
HRRM T,(A)
JRST PROG2
CSET1: HRLM B,(A)
PROG2: MOVE A,B
POPJ P,
DEFPROP:
HRRZ B,(A)
HRRZ C,(B)
HLRZ A,(A)
HLRZ B,(B)
HLRZ C,(C)
PUSH P,A
PUSHJ P,PUTPROP
JRST POPAJ
PAGE
EQUAL: MOVE C,P
EQUAL1: CAMN A,B
JRST TRUE
MOVE T,A
MOVE TT,B
PUSHJ P,ATOM
EXCH A,B
PUSHJ P,ATOM
CAMN A,B
JRST EQUAL3
EQUAL4: MOVE P,C
JRST FALSE
EQUAL3: JUMPN A,EQ2
PUSH P,T
PUSH P,TT
HLRZ A,(T)
HLRZ B,(TT)
PUSHJ P,EQUAL1
JUMPE A,EQUAL4
POP P,B
POP P,A
HRRZ A,(A)
HRRZ B,(B)
JRST EQUAL1
EQ2: PUSH P,T
MOVE A,T
PUSHJ P,NUMBERP
JUMPE A,EQUAL4
MOVE A,TT
PUSHJ P,NUMBERP
JUMPE A,EQUAL4
MOVE A,(P)
MOVEM C,(P)
MOVE B,TT
JSP C,OP
JUMPL COMP3
JUMPL COMP3
COMP3: POP P,C
CAME A,TT
JRST EQUAL4
JRST TRUE
PAGE
SUBS5: HRRZ A,SUBAS
POPJ P,
SUBST: MOVEM A,SUBAS#
MOVEM B,SUBBS#
SUBS0A: MOVE A,SUBAS
MOVE B,SUBBS
PUSH P,C
MOVE A,C
PUSHJ P,EQUAL
POP P,C
JUMPN A,SUBS5
CAILE C,INUMIN
JRST EV6A
HLLE T,(C)
AOJN T,SUBS2
EV6A: MOVE A,C
POPJ P,
SUBS2: PUSH P,C
HLRZ C,(C)
PUSHJ P,SUBS0A
EXCH A,(P)
HRRZ C,(A)
PUSHJ P,SUBS0A
POP P,B
JRST XCONS
PAGE
NCONC: TDZA R,R
APPEND: MOVEI R,.APPEND-.NCONC
JUMPE T,FALSE
POP P,B
APP2: AOJE T,PROG2
POP P,A
PUSHJ P,.NCONC(R)
MOVE B,A
JRST APP2
.NCONC: JUMPE A,PROG2
MOVE TT,A
MOVE C,TT
HRRZ TT,(C)
JUMPN TT,.-2
HRRM B,(C)
POPJ P,
.APPEND: JUMPE A,PROG2
MOVEI C,AR1
MOVE TT,A
APP1: HLRZ A,(TT)
PUSH P,B
PUSHJ P,CONS ;saves b
POP P,B
HRRM A,(C)
MOVE C,A
HRRZ TT,(TT)
JUMPN TT,APP1
JRST SUBS4
PAGE
MEMBER: MOVEM A,SUBAS
MEMB1: JUMPE B,FALSE
MOVEM B,SUBBS
MOVE A,SUBAS
HLRZ B,(B)
PUSHJ P,EQUAL
JUMPN A,CPOPJ
MOVE B,SUBBS
HRRZ B,(B)
JRST MEMB1
MEMQ: JUMPE B,FALSE
MOVS C,(B)
CAIN A,(C)
JRST TRUE
HLRZ B,C
JUMPN B,MEMQ+1
JRST FALSE
AND:
FOO HRLI A,TRUTH
OR: HLRZ C,A
PUSH P,C
ANDOR: HRRZ C,A
JUMPE C,AOEND
MOVSI C,(SKIPE (P))
TLNE A,-1
MOVSI C,(SKIPN (P))
XCT C
JRST AOEND
MOVEM A,(P)
HLRZ A,(A)
PUSHJ P,EVAL
EXCH A,(P)
HRR A,(A)
JRST ANDOR
AOEND: POP P,A
SKIPE A
FOO MOVEI A,TRUTH
POPJ P,
PAGE
GENSYM: MOVE B,[POINT 7,GNUM,34]
MOVNI C,4
MOVEI TT,"0"
GENSY2: LDB T,B
AOS T
DPB T,B
CAIG T,"9"
JRST GENSY1
DPB TT,B
ADD B,[XWD 70000,0]
AOJN C,GENSY2
GENSY1: MOVE A,GNUM
PUSHJ P,FWCONS
PUSHJ P,NCONS
JRST PNGNK1
GNUM: ASCII /G0000/ ;*
CSYM: HLRZ A,(A)
PUSH P,A
FOO MOVEI B,PNAME
PUSHJ P,GET
JUMPE A,NOPNAM
HLRZ A,(A)
MOVE A,(A)
MOVEM A,GNUM
JRST POPAJ
PAGE
LIST: MOVE B,A
FOO MOVEI A,CEVAL
JRST MAPCAR
EELS: HLRZ TT,(T) ;interpret lsubr call
HRRZ A,(AR1)
ILIST: MOVEI T,0
JUMPE A,ILIST2
ILIST1: PUSH P,A
HLRZ A,(A)
PUSH P,TT
HRLM T,(P)
PUSHJ P,EVAL
ILIST3: POP P,TT
HLRE T,TT
EXCH A,(P)
HRRZ A,(A)
SOS T
JUMPN A,ILIST1
ILIST2: JRST (TT)
MAPC: TLO A,400000
MAP: TLOA A,200000
MAPCAR: TLO A,400000
MAPLIST: JUMPE B,FALSE
PUSH P,A
PUSH P,B
PUSH P,B
HRLZM P,(P)
MAPL2: MOVE A,-1(P)
SKIPGE -2(P)
HLRZ A,(A)
CALLF 1,@-2(P)
LDB C,[POINT 1,-2(P),1]
JUMPN C,MAP1
PUSHJ P,NCONS
HLR B,(P)
HRRM A,(B)
HRLM A,(P)
MAP1: HRRZ B,@-1(P)
MOVEM B,-1(P)
JUMPN B,MAPL2
POP P,AR1
SUB P,[XWD 2,2]
SUBS4: HRRZ A,AR1
POPJ P,0
PAGE
PA3: 0 ;lh=0=>rh =next prog statement *
;lh - =>rh = tag to go to
PA4: 0 ;lh=-1,rh=pntr to prog less bound var list *
;lh=+,rh return value
;2.1=>dont do unbnd
PROG: PUSH P,PA3
PUSH P,PA4
HLRZ TT,(A)
HRRZ A,(A)
HRROM A,PA4
MOVEM A,PA3
JUMPE TT,PG0
MOVSI C,1
FOO MOVEI B,VALUE
MOVEM SP,SPSV#
ANDCAM C,PA4
PG7A: HLRZ A,(TT)
MOVEI AR1,0
PUSHJ P,BIND
HRRZ TT,(TT)
JUMPN TT,PG7A
PUSH SP,SPSV
PG0: SKIPA T,PA3
PG5A: MOVE T,A
PG1: JUMPE T,PG2
HLRZ A,(T)
HRRZ T,(T)
HLLE B,(A)
AOJE B,PG1
MOVEM T,PA3
PUSHJ P,EVAL
SKIPL A,PA4
JRST PG4 ;return
SKIPL T,PA3
JRST PG1
PG5: JUMPE A,EG1
HLRZ TT,(A)
HRRZ A,(A)
CAIN TT,(T)
JRST PG5A ;found tag
JRST PG5
PG2: TDZA A,A
PG4: HRRZS A
MOVSI B,1
TDNN B,PA4
PUSHJ P,UNBIND
ERRP4: POP P,PA4
POP P,PA3
POPJ P,
GO: HLRZ A,(A)
HRROM A,PA3
HLLE B,(A)
AOJE B,FALSE
PUSHJ P,EVAL
JRST GO+1
RETURN: HLL A,PA4
TLZ A,-2
MOVEM A,PA4
POPJ P,
SETQ: HLRZ B,(A)
PUSH P,B
PUSHJ P,CADR
PUSHJ P,EVAL
MOVE B,A
POP P,A
SET: MOVE AR1,B
PUSHJ P,BIND
SUB SP,[XWD 1,1]
MOVE A,AR1
POPJ P,
CON2: HRRZ A,(T)
COND: JUMPE A,CPOPJ ;entry
PUSH P,A
HLRZ A,(A)
HLRZ A,(A)
PUSHJ P,EVAL
POP P,T
JUMPE A,CON2
HLRZ T,(T)
COND2: HRRZ T,(T)
JUMPE T,CPOPJ
PUSH P,T
HLRZ A,(T)
PUSHJ P,EVAL
POP P,T
JRST COND2
SUBTTL ARITHMETIC SUBROUTINES --- PAGE 11
;macro expander -- (foo a b c) => (*foo (*foo a b) c)
EXPAND: MOVE C,B
HRRZ A,(A)
PUSHJ P,REVERSE
JRST EXPA1
EXPN1: MOVE C,B
EXPA1: HRRZ T,(A)
HLRZ A,(A)
JUMPE T,CPOPJ
PUSH P,A
MOVE A,T
PUSHJ P,EXPA1
EXCH A,(P)
PUSHJ P,NCONS
POP P,B
PUSHJ P,XCONS
MOVE B,C
JRST XCONS
PAGE
ADD1: CAILE A,INUMIN
CAIL A,-2
SKIPA B,[INUM0+1]
AOJA A,CPOPJ
.PLUS: JSP C,OP
ADD A,TT
FADR A,TT
SUB1: CAILE A,INUMIN+1
SOJA A,CPOPJ
MOVEI B,INUM0+1
.DIF: JSP C,OP
SUB A,TT
FSBR A,TT
.TIMES: JSP C,OP
IMUL A,TT
FMPR A,TT
.QUO: CAIN B,INUM0
JRST ZERODIV
JSP C,OP
IDIV A,TT
FDVR A,TT
.GREAT: EXCH A,B
JUMPE B,FALSE
.LESS: JUMPE A,CPOPJ
JSP C,OP
JRST COMP2 ;bignums know about me
JRST COMP2
COMP2: CAML A,TT
JRST FALSE
JRST TRUE
PAGE
MAKNUM:
FOO CAIN B,FIXNUM
JRST FIX1A
FLO1A:
FOO MOVEI B,FLONUM
PUSHJ P,FWCONS
JRST ACONS-1
FIX1B: SUBI A,INUM0
FOO MOVEI B,FIXNUM
PUSHJ P,FWCONS
JRST ACONS-1
NUMVLX: JFCL 17,.+1
NUMVAL: CAIG A,INUMIN
JRST NUMAG1
SUBI A,INUM0
FOO MOVEI B,FIXNUM
POPJ P,
NUMAG1: MOVEM A,AR1
HRRZ A,(A)
HLRZ B,(A)
HRRZ A,(A)
FOO CAIE B,FIXNUM
FOO CAIN B,FLONUM
SKIPA A,(A)
NUMV4: SKIPA A,AR1
POPJ P,
NUMV2: PUSHJ P,EPRINT ;bignums know about me
JRST NONNUM
NUMV3: JRST NONNUM ;bignums change me to JRST BIGDIS
PAGE
FLOAT: IDIVI A,400000
SKIPE A
TLC A,254000
TLC B,233000
FADR A,B
POPJ P,
FIX: PUSH P,A
PUSHJ P,NUMVAL
FOO CAIE B,FLONUM
JRST POPAJ
MULI A,400
TSC A,A
JFCL 17,.+1
ASH B,-243(A)
FIX2: JFCL 10,FIXOV ;bignums change me to jfcl 10,bfix
POP P,A
FIX1: MOVE A,B
JRST FIX1A
MINUSP: PUSHJ P,NUMVAL
JUMPGE A,FALSE
JRST TRUE
MINUS: PUSHJ P,NUMVLX
MOVNS A
JFCL 10,@OPOV
JRST MAKNUM
ABS: PUSHJ P,NUMVLX
MOVMS A
JRST MINUS+2
PAGE
DIVIDE: CAIN B,INUM0
JRST ZERODIV
JSP C,OP
JUMPN RDIV ;bignums know about me
JRST ILLNUM
RDIV: IDIV A,TT
PUSH P,B
PUSHJ P,FIX1A
EXCH A,(P)
PUSHJ P,FIX1A
POP P,B
JRST XCONS
REMAINDER:
PUSHJ P,DIVIDE
JRST CDR
FIXOV: ERR1 [SIXBIT /INTEGER OVERFLOW!/]
ZERODIV:ERR1 [SIXBIT /ZERO DIVISOR!/]
FLOOV: ERR1 [SIXBIT /FLOATING OVERFLOW!/]
ILLNUM: ERR1 [SIXBIT /NON-INTEGRAL OPERAND!/]
GCD: JSP C,OP
JUMPA GCD2 ;bignums know about me
JRST ILLNUM
GCD2: MOVMS A
MOVMS TT
;euclid's algorithm
GCD3: CAMG A,TT
EXCH A,TT
JUMPE TT,FIX1A
IDIV A,TT
MOVE A,B
JRST GCD3
PAGE
;general arithmetic op code routine for mixed types
OP: CAIG A,INUMIN
JRST OPA1
SUBI A,INUM0
CAIG B,INUMIN
JRST OPA2
HRREI TT,-INUM0(B)
XCT (C) ;inum op (cannot cause overflow)
FIX1A: ADDI A,INUM0
CAILE A,INUMIN
CAIL A,-1
JRST FIX1B
POPJ P,
OPA1: HRRZ A,(A)
HLRZ T,(A)
HRRZ A,(A)
FOO CAIE T,FIXNUM
JRST OPA6
SKIPA A,(A)
OPA2:
FOO MOVEI T,FIXNUM
CAILE B,INUMIN
JRST OPB2
HRRZ B,(B)
HRRZ TT,(B)
HLRZ B,(B)
FOO CAIE B,FIXNUM
JRST OPA5
SKIPA TT,(TT)
OPB2: HRREI TT,-INUM0(B)
MOVE AR1,A
JFCL 17,.+1
XCT (C) ;fixed pt op
OPOV: JFCL 10,FIXOV ;bignums change this to jfcl 10,fixovl
JRST FIX1A
OPA6: CAILE B,INUMIN
JRST OPB7
HRRZ B,(B)
HRRZ TT,(B)
HLRZ B,(B)
FOO CAIE B,FLONUM
JRST OPB3
FOO CAIE T,FLONUM
JRST NUMV3
MOVE A,(A)
MOVE TT,(TT)
OPR: JFCL 17,.+1
XCT 1(C) ;flt pt op
JFCL 10,FLOOV
JRST FLO1A
OPA5:
FOO CAIE B,FLONUM
JRST NUMV3
PUSHJ P,FLOAT
JRST OPR-1
OPB3:
FOO CAIE B,FIXNUM
JRST NUMV3
SKIPA TT,(TT)
OPB7: HRREI TT,-INUM0(B)
FOO MOVEI B,FIXNUM
FOO CAIE T,FLONUM
JRST NUMV3
MOVE A,(A)
EXCH A,TT
PUSHJ P,FLOAT
EXCH A,TT
JRST OPR
SUBTTL EXPLODE, READLIST AND FRIENDS --- PAGE 12
FLATSIZE: HLLZS FLAT1
MOVEI R,FLAT2
PUSHJ P,PRINTA
FLAT1: MOVEI A,X ;*
JRST FIX1A
FLAT2: AOS FLAT1
POPJ P,
%EXPLODE: SKIPA R,.+1
EXPLODE: HRRZI R,EXPL1
MOVSI AR1,AR1
PUSHJ P,PRINTA
JRST SUBS4
EXPL1: PUSH P,B
PUSH P,C
ANDI A,177
CAIL A,"0"
CAILE A,"9"
JRST EXPL2
ADDI A,INUM0-"0"
JRST EXPL4
EXPL2: PUSH P,AR1
PUSH P,TT
PUSH P,T
LSH A,35
MOVE C,SP
PUSH C,A
MOVEI AR1,1
PUSHJ P,INTER0
POP P,T
POP P,TT
POP P,AR1
EXPL4: PUSHJ P,NCONS
HLR B,AR1
HRRM A,(B)
HRLM A,AR1
POP P,C
JRST POPBJ
PAGE
READLIST: TDZA T,T
MAKNAM: MOVNI T,1
MOVEM T,NOINFG
PUSH P,OLDCH
SETZM OLDCH
JUMPE A,NOLIST
HRRM A,MKNAM3
MOVEI A,MKNAM2
PUSHJ P,READ0
HRRZ T,MKNAM3
CAIE T,-1
JUMPN T,[ERR1 [SIXBIT /MORE THAN ONE S-EXPRESSION-MKNAM!/]]
POP P,OLDCH
POPJ P,
MKNAM2: PUSH P,B
PUSH P,T
PUSH P,TT
MKNAM3: MOVEI TT,X
JUMPE TT,MKNAM6
CAIN TT,-1
ERR1 [SIXBIT /READ UNHAPPY-MAKNAM!/]
HRRZ B,(TT)
HRRM B,MKNAM3
HLRZ A,(TT)
CAIGE A,INUMIN
JRST MKNAM5
SUBI A,INUM0-"0"
MKNAM4: POP P,TT
POP P,T
JRST POPBJ
MKNAM5: HLRZ A,(TT)
FOO MOVEI B,PNAME
PUSHJ P,GET
HLRZ A,(A)
LDB A,[POINT 7,(A),6]
JRST MKNAM4
MKNAM6: MOVEI A," "
HLLOS MKNAM3
JRST MKNAM4
SUBTTL EVAL APPLY -- THE INTERPRETER --- PAGE 13
EV3: HLRZ A,(AR1)
FOO MOVEI B,VALUE
PUSHJ P,GET
JUMPE A,UNDFUN ;function object has no definition
HRRZ A,(A)
UBDPTR:
FOO CAIN A,UNBOUND
JRST UNDFUN
HRRZ B,(AR1) ;eval (cons (cdr a)(cdr ar1))
PUSHJ P,CONS
JRST EVAL
OEVAL: AOJN T,AEVAL
POP P,A
EVAL: HRRZM A,AR1
CAILE A,INUMIN
JRST CPOPJ
HLRZ T,(A)
CAIN T,-1
JRST EE1 ;x is atomic
CAILE T,INUMIN
JRST UNDFUN
HLRO TT,(T)
AOJE TT,EE2 ;car (x) is atomic
JRST EXP3
EE1:
EV5: HRRZ AR1,(AR1)
JUMPE AR1,UNBVAR
HLRZ TT,(AR1)
FOO CAIE TT,FLONUM
FOO CAIN TT,FIXNUM
POPJ P,
EVBIG: HRRZ AR1,(AR1) ;bignums know about me
FOO CAIE TT,VALUE
JRST EV5
HLRZ AR1,(AR1)
HRRZ AR1,(AR1)
FOO CAIN AR1,UNBOUND
JRST UNBVAR
MOVEM AR1,A
POPJ P,
PAGE
ALIST: SKIPE A,-1(P)
PUSHJ P,NUMBERP
MOVEM SP,SPSV
JUMPN A,AEVAL7 ;number
MOVE C,SC2 ;bottom of spec pdl
MOVEM C,AEVAL5#
SETOM AEVAL2
AEVAL8: MOVE C,SP
AEVAL6: CAMN C,AEVAL5 ;bottom spec pdl
JRST AEVAL1 ;done
POP C,T ;pointer for next block
AEVAL4: CAMN C,T
JRST AEVAL6 ;thru with block
POP C,AR1
MOVSS AR1
PUSH SP,(AR1) ;save value cell
HLRZM AR1,(AR1) ;store previous value in value cell
HRLM AR1,(SP) ;save pointer to spec pdl loc
JRST AEVAL4
FNGUBD: EXCH A,(P) ;spec pdl pointer
PUSHJ P,NUMVAL
MOVE D,A
POP SP,TT ;end of block to rebind
FNGUB2: CAMN SP,TT
JRST POPAJ ;done
POP SP,T
MOVSS T ;pointer to value cell
HRLM T,(T)
SKIPGE 1(D)
AOBJN D,.-1 ;skip over spec pdl pointers
PUSH D,(T) ;put value cell in spec pdl
HLRZM T,(T) ;restore value cell
JRST FNGUB2
AEVAL: PUSHJ P,ALIST
POP P,A
MOVEI A,UNBIND
EXCH A,(P)
JRST EVAL
PAGE
AEVAL1: SKIPGE AEVAL2
SKIPN B,-1(P)
JRST ABIND3 ;done with binding
;alist binding
MOVE A,B
PUSHJ P,REVERSE
SKIPA
ABIND2: MOVE A,B
HRRZ B,(A)
HLRZ A,(A)
HRRZ AR1,(A)
HLRZ A,(A)
PUSHJ P,BIND
JUMPN B,ABIND2
ABIND3: PUSH SP,SPSV
POPJ P,
;spec pdl binding
AEVAL7: MOVE A,-1(P)
PUSHJ P,NUMVAL
CLEARM AEVAL2
MOVEM A,AEVAL5 ;point to unbind to
JRST AEVAL8
AEVAL2: 0 ;0 for number, -1 for a-list *
PAGE
EE2: HRRZ T,(T)
JUMPE T,EV3
HLRZ TT,(T)
HRRZ T,(T)
FOO CAIN TT,SUBR
JRST ESB
FOO CAIN TT,LSUBR
JRST EELS
FOO CAIN TT,EXPR
JRST AEXP
FOO CAIN TT,FSUBR
JRST EFS
FOO CAIN TT,MACRO
JRST EFM
FOO CAIE TT,FEXPR
JRST EE2
HLRZ T,(T)
HLL T,(AR1)
PUSH P,T
HRRZ A,(A)
TLO A,400000
PUSH P,A
MOVNI T,1
JRST IAPPLY
AEXP: HLRZ T,(T)
HLL T,(AR1)
EXP3: PUSH P,T
HRRZ A,(AR1)
CILIST: JSP TT,ILIST
EXP2: JRST IAPPLY
EFS: HLRZ T,(T)
HRRZ A,(AR1)
JRST (T)
PAGE
ESB: HRRZ A,(AR1)
UUOS2: HLRZ T,(T)
HLL T,(AR1)
PUSH P,T
JSP TT,ILIST
ESB1: JRST .+NACS+1(T)
POP P,A+4
POP P,A+3
POP P,A+2
POP P,A+1
POPAJ: POP P,A
POPJ P,
EFM: HLRZ T,(T)
CALLF 1,(T)
JRST EVAL
PAGE
APPLY: MOVEI TT,AP2
CAME T,[-3]
JRST PDLARG
MOVEM T,APFNG1#
PUSHJ P,ALIST
MOVE T,APFNG1
JSP TT,PDLARG
PUSH P,C ;spec pdl pointer
PUSH P,[FNGUBD]
AP2: PUSH P,A
MOVEI T,0
AP3: JUMPE B,IAPPLY ;all args pushed; b has arg list
HLRZ C,(B)
PUSH P,C ;push arg
HRRZ B,(B)
SOJA T,AP3
IAP4: JUMPGE D,TOOFEW ;special case for fexprs
AOJN R,TOOFEW
PUSH P,B
MOVE A,SP
PUSHJ P,FIX1A
EXCH A,(P)
MOVE B,A
MOVNI R,2
SOJA T,IAP5
FUNCT: PUSH P,A
MOVE A,SP
PUSHJ P,FIX1A
POP P,B
HLRZ B,(B)
PUSHJ P,XCONS
FOO MOVEI B,FUNARG
JRST XCONS
PAGE
APFNG: SOS T
MOVEM T,APFNG1
JSP TT,PDLARG ;get args and funarg list
HRRZ A,(A)
HRRZ D,(A) ;a-list pointer
HLRZ A,(A) ;function
HRLZ R,APFNG1 ;no. of args
PUSH P,D
PUSH P,[FNGUBD]
JSP TT,ARGP1 ;replace args and fn name
PUSH P,D ;a-list pointer
PUSHJ P,ALIST ;set up spec pdl
POP P,D
AOS T,APFNG1
;falls through
PAGE
;falls in
IAPPLY: MOVE C,T ;state of world at entrance
ADDI C,(P) ;t has - number of args on pdl
ILP1A: HRRZ B,(C) ;next pdl slot has function- poss fun name in lh
CAILE B,INUMIN
JRST UNDTAG
HLRZ A,(B)
CAIN A,-1
JRST IAP1 ;fn is atomic
FOO CAIN A,LAMBDA
JRST IAPLMB
FOO CAIN A,FUNARG
JRST APFNG
FOO CAIN A,LABEL
JRST APLBL
PUSH P,T
MOVE A,B
PUSHJ P,EVAL
POP P,T
MOVE C,T
ADDI C,(P)
ILP1B: MOVEM A,(C)
JRST ILP1A
IAPXPR: HLRZ A,(B)
JRST ILP1B
IAP1: HRRZ B,(B)
JUMPE B,IAP2
HLRZ TT,(B)
HRRZ B,(B)
FOO CAIN TT,EXPR
JRST IAPXPR
FOO CAIN TT,LSUBR
JRST IAP6
FOO CAIE TT,SUBR
JRST IAP1
HLRZ B,(B)
MOVEM B,(C)
JRST ESB1
PAGE
IAPLMB: HRRZ B,(B)
HLRZ TT,(B)
MOVEM SP,SPSV
HRRZ B,(B)
HLRZ D,(TT)
CAIN D,-1
JUMPN TT, IAP3
MOVE R,T
IPLMB1: JUMPE T,IPLMB2 ;no more args
JUMPE TT,TOMANY ;too many args supplied
IAP5: HLRZ A,(TT)
MOVEI AR1,1(T)
ADD AR1,P
HLLZ D,(AR1)
HRLM A,(AR1)
HRRZ TT,(TT)
AOJA T,IPLMB1
PAGE
IPLMB2: JUMPN TT,IAP4 ;too few args supplied
JUMPE R,IAP69
IPLMB4: POP P,AR1
HLRZ A,AR1
AOJG R,IPLMB3
PUSHJ P,BIND
JRST IPLMB4
IPLMB3: SKIPE BACTRF
JRST APBK1
APBK2: HLRZ A,(B)
PUSH SP,SPSV
PUSHJ P,EVAL
JRST UNBIND
IAP69: POP P,(P)
HLRZ A,(B)
JRST EVAL
APBK1: HRRI AR1,CPOPJ
TLNE AR1,-1
PUSH P,AR1
JRST APBK2
IAP6: MOVEI TT,CPOPJ
MOVEM TT,(C)
HLRZ B,(B)
JRST (B)
APLBL: MOVEM SP,SPSV
HRRZ B,(B)
HLRZ A,(B)
HRRZ B,(B)
HLRZ AR1,(B)
MOVEM AR1,(C)
PUSHJ P,BIND
MOVEI A,APLBL1
EXCH A,-1(C)
EXCH A,LBLAD#
HRLI A,LBLAD
PUSH SP,A
PUSH SP,SPSV
JRST IAPPLY
APLBL1: PUSH P,LBLAD
JRST SPECSTR
IAP2: HRRZ A,(C)
FOO MOVEI B,VALUE
PUSHJ P,GET
JUMPE A,UNDTAG
HRRZ A,(A)
FOO CAIN A,UNBOUND
JRST UNDTAG
JRST ILP1B
IAP3: MOVNI AR1,-INUM0(T) ;lexpr call
MOVE A,TT
PUSHJ P,BIND
PUSH P,ARG
SUBI C,INUM0
HRRM C,ARG
PUSH SP,SPSV
HLRZ A,(B)
PUSHJ P,EVAL
HRRZ T,ARG
POP P,ARG
SUBI T,1-INUM0(P)
HRLI T,-1(T)
ADD P,T
JRST UNBIND
ARG: HRRZ A,X(A) ;*
POPJ P,
SETARG: HRRZM B,@ARG
JRST PROG2
PAGE
BIND: PUSH P,B
HRRZM A,BIND3#
BIND2:
FOO MOVEI B,VALUE ;bind atom in a to value in ar1,save
PUSHJ P,GET ;old binding on s pdl
JUMPE A,BIND1 ;add value cell
PUSH SP,(A)
HRLM A,(SP)
HRRZM AR1,(A)
POPBJ: POP P,B
POPJ P,
BIND1:
FOO MOVEI B,UNBOUND
MOVEI A,0
PUSHJ P,CONS
HRRZ B,@BIND3
PUSHJ P,CONS
FOO MOVEI B,VALUE
PUSHJ P,XCONS
HRRM A,@BIND3
MOVE A,BIND3
JRST BIND2
UBD: CAMN SP,B
POPJ P,
PUSHJ P,UNBIND
JRST UBD
UNBIND:
SPECSTR: MOVE TT,(SP)
SUB SP,[XWD 1,1]
JUMPGE TT,.-2 ;syncronize stack
UNBND1: CAMN SP,TT
POPJ P,
POP SP,T
MOVSS T
HLRZM T,(T)
JRST UNBND1
SPECBIND: MOVE TT,SP
SPEC1: LDB R,[POINT 13,(T),ACFLD]
CAILE R,17
JRST SPECX
SKIPE R
MOVE R,(R)
EXCH R,@(T)
HRL R,(T)
PUSH SP,R
AOJA T,SPEC1
SPECX: PUSH SP,TT
JRST (T)
;random special case compiler run time routines
%AMAKE: PUSH P,A ;make alist for fsubr that requires it
MOVE A,SP
PUSHJ P,FIX1A
MOVE B,A
JRST POPAJ
%UDT: PUSHJ P,PRINT ;error print for undefined computed go tag
STRTIP [SIXBIT /UNDEFINED COMPUTED GO TAG IN !/]
HRRZ R,(P)
PUSHJ P,ERSUB3
JRST ERREND
%LCALL: MOVN A,T ;set up routine for compile lsubr
ADDI A,INUM0
ADDI T,(P)
PUSH P,T
PUSHJ P,(3)
POP P,T
SUBI T,(P)
HRLI T,-1(T)
ADD P,T
POPJ P,
SUBTTL ARRAY SUBROUTINES --- PAGE 14
ARRERR=-1
ARRAY: PUSHJ P,ARRAYS
HRRI AR2A,1(R)
MOVE A,AR2A
PUSH R,[0]
AOBJN A,.-1
ARREND: MOVE A,BPPNR#
MOVEM AR2A,-1(A)
IFE VBP,< MOVEI A,INUM0+1(R) > ;STANFORD'S SMALL-CORE METHOD.
IFN VBP,< MOVEI A,1(R)
PUSHJ P,FIX1A >
FOO MOVEM A,VBPORG
POPJ P,
ARRAYS: PUSH P,A
FOO MOVE A,VBPORG
IFE VBP,< SUBI A,INUM0 >
IFN VBP,< PUSHJ P,NUMVAL >
MOVEM A,BPPNR
FOO MOVE A,VBPEND
IFE VBP,< MOVNI A,-INUM0-2(A) >
IFN VBP,< PUSHJ P,NUMVAL
MOVN A,A
ADDI A,2 >
ADD A,BPPNR ;bporg-bpend+2
HRLM A,BPPNR
POP P,A
HRRZ AR1,(A) ;(cdr l)
HLRZ A,(A) ;(car l)name
HRRZ B,BPPNR
ADDI B,2
FOO MOVEI C,SUBR
PUSHJ P,PUTPROP
HLRZ A,(AR1) ;(cadr l)mode
PUSH P,AR1
PUSHJ P,EVAL ;eval mode
POP P,AR1
MOVEM A,AMODE#
MOVEI C,44
JUMPE A,ARRY1
MOVEI C,-INUM0(A)
CAILE A,INUMIN
JRST ARRY1
MOVEI C,22
HRRZ A,BPPNR
MOVE B,GCMKL
PUSHJ P,CONS
MOVEM A,GCMKL
ARRY1: MOVEM C,BSIZE#
MOVEI A,44
IDIV A,C
MOVEM A,NBYTES#
HRRZ A,(AR1) ;(cddr l)bound pair list
JSP TT,ILIST
AOS R,BPPNR
MOVEI AR1,1 ;ar1 is array size
MOVEI AR2A,0 ;ar2a is cumulative residue
AOJGE T,ARRYS ;single dimension
MOVEI D,A-1
SUB D,T ;d is next ac for array code generation
ARRY2: PUSHJ P,ARRB0
TLC TT,(IMULI)
DPB D,[POINT 4,TT,ACFLD]
PUSH R,TT
CAIN D,A
JRST ARRY3
MOVSI TT,(ADD)
ADDI TT,1(D)
DPB D,[POINT 4,TT,ACFLD]
PUSH R,TT
SOJA D,ARRY2
ARRB0: POP P,TT
EXCH TT,(P)
CAILE TT,INUMIN
JRST ARRB1
HLRZ A,(TT)
HRRZ TT,(TT)
SUBI TT,(A)
ADDI TT,1
JRST ARRB2
ARRB1: MOVEI A,INUM0
SUB TT,A
ARRB2: IMUL A,AR1
IMULB AR1,TT
ADDM A,AR2A
POPJ P,
ARRY3: PUSH R,[ADD A,B]
ARRYS: PUSHJ P,ARRB0
HRRZ TT,BPPNR
MOVEM AR2A,(TT)
HRLI TT,(SUB A,)
PUSH R,TT
PUSH R,[JUMPL A,ARRERR]
MOVE TT,AR1
HRLI TT,(CAIL A,)
PUSH R,TT
PUSH R,[JRST ARRERR]
IDIV AR1,NBYTES ;calc #words in array
SKIPE AR2A ;correct for remainder non-zero
ADDI AR1,1
MOVE TT,NBYTES
SOJE TT,ARRY6
ADDI TT,1
HRLI TT,(IDIVI A,)
PUSH R,TT
MOVN TT,BSIZE
LSH TT,14
HRLI TT,(IMULI B,)
PUSH R,TT
MOVEI TT,44+200
SUB TT,BSIZE
LSH TT,6
ARRY6: ADD TT,BSIZE
LSH TT,6
SKIPE AR2A,AMODE
CAIL AR2A,INUMIN
ADDI TT,40 ;mode not = t
TLC TT,(HRLZI C,)
PUSH R,TT
MOVEI TT,4(R)
HRLI TT,(ADDI C,(A))
PUSH R,TT
PUSH R,[LDB A,C]
HRLZI AR2A,(POPJ P,)
SKIPN TT,AMODE
MOVE AR2A,[JRST FLO1A]
CAIL TT,INUMIN
MOVE AR2A,[JRST FIX1A]
PUSH R,AR2A
MOVS AR2A,AR1
MOVNS AR2A
POPJ P,
PAGE
EXARRAY: PUSH P,A
HLRZ A,(A)
PUSHJ P,GETSYM
JUMPE A,POPAJ
PUSHJ P,NUMVAL
EXCH A,(P)
PUSHJ P,ARRAYS
POP P,A
HRRM A,-2(R)
HRR AR2A,A
JRST ARREND
STORE: PUSH P,A
PUSHJ P,CADR
PUSHJ P,EVAL ;value to store
EXCH A,(P)
HLRZ A,(A)
PUSHJ P,EVAL ;byte pointer returned in c
POP P,A
NSTR: PUSH P,A
TLNE C,40
PUSHJ P,NUMVAL ;numerical array
DPB A,C
POP P,A
POPJ P,
SUBTTL EXAMINE, DEPOSIT , ETC --- PAGE 15
BOOLE: MOVE TT,T
ADDI TT,2(P)
MOVE A,-1(TT)
SUBI A,INUM0
DPB A,[POINT 4,BOOLI,OPFLD-2]
PUSHJ P,BOOLG
MOVE C,A
BOOLL: PUSHJ P,BOOLG
BOOLI: CLEARB C,A
JRST BOOLL
BOOLG: CAIL TT,(P)
JRST BOOL1
MOVE A,(TT)
PUSHJ P,NUMVAL
AOJA TT,CPOPJ
BOOL1: HRLI T,-1(T)
ADD P,T
POP P,B
JRST FIX1A
EXAMINE:
IFE VBP,< MOVE A,-INUM0(A) >
IFN VBP,< PUSHJ P,NUMVAL
MOVE A,(A) >
JRST FIX1A
DEPOSIT:
IFE VBP,< MOVEI C,-INUM0(A)
MOVE A,B >
IFN VBP,< MOVE C,B
PUSHJ P,NUMVAL
EXCH A,C >
PUSHJ P,NUMVAL
MOVEM A,(C)
JRST MAKNUM
LSH: MOVEI C,-INUM0(B)
PUSHJ P,NUMVAL
LSH A,(C)
JRST FIX1A
SUBTTL GARBAGE COLLECTER --- PAGE 16
;garbage collector
GC: PUSHJ P,AGC
JRST FALSE
AGC: MOVEM R,RGC#
GCPK1: PUSH P,PA3
PUSH P,PA4
PUSH P,UBDPTR ;special atom UNBOUND; not on OBLIST
PUSH P,MKNAM3
PUSH P,GCMKL ;i/o channel input lists and arrays
PUSH P,BIND3
PUSH P,INITF
GCPK2: PUSH P,[XWD 0,GCP6] ;this is a return address
GCP4: MOVEI S,X ;pdlac, .=bottom of reg pdl + 1
GCP41: BLT S,X ;save ACs 0 through 10 at bottom of regpdl ;pdlac+n
GCP2: CLEARB 0,X ;gc indicator, init. for bit table zero
MOVE A,C3GC
GCP5: BLT A,X ;zero bit tables, .=top of bit tables
SKIPN GCGAGV
JRST GCP5A
SKIPN F
STRTIP [SIXBIT /_FREE STG EXHAUSTED_!/]
SKIPN FF
STRTIP [SIXBIT /_FULL WORD SPACE EXHAUSTED_!/]
GCP5A: MOVEI TT,1
MOVEI A,0
CALLI A,STIME ;time
MOVNS A
ADDM A,GCTIM#
GCP3: MOVEI C,X ;.=bottom of reg pdl
GCP6B: MOVE S,P
HLL C,P
MOVEI B,0
GC1: CAMN C,S
POPJ P,
HRRZ A,(C)
GCP: CAIGE A,X ;.=bottom of bit tables
GCPP1:
FOO CAIGE A,FS
JRST GCEND
GCP1: CAIL A,X ;.=bottom of full word space (fws)
JRST GCMFWS
MOVE F,(A)
LSHC A,-5
ROT B,5
MOVE AR1,GCBT(B)
GCBTP2: TDOE AR1,X(A) ;bit tab- (fs_-5), .=magic number for sync
JRST GCEND
GCBTP1: MOVEM AR1,X(A) ;bit tab- (fs_-5)
PUSH P,F
HLRZ A,F
JRST GCP
GCMFWS: MOVEI AR1,X(A) ;.=- bottom of fws
IDIVI AR1,44
MOVNS AR2A
LSH AR2A,36
ADD AR2A,C2GC
DPB TT,AR2A
GCEND: CAMN P,S
AOJA C,GC1
POP P,A
HRRZS A
JRST GCP
GCMKL: XWD 0,[XWD [XWD -NIOCH,CHTAB+FSTCH],0]
C2GC: XWD 430100+AR1,X ;.=bottom of fws bit table
C3GC: 0 ;(bottom bit table)bottom bit table+1
GCBT: XWD 400000,0
ZZ==1B1
XLIST
REPEAT ^D31,<ZZ
ZZ==ZZ/2>
LIST
GCP6: HRRZ R,SC2
GCP6C: CAIL R,(SP) ;mark sp
JRST GCP6A
PUSH P,(R)
HRRZ C,P
PUSHJ P,GCP6B
SUB P,[XWD 1,1]
AOJA R,GCP6C
GCP6A: HRRZ R,GCMKL ;mark arrays
GCP6D: JUMPE R,GCSWP
HLRZ A,(R)
MOVE D,(A)
GCP6E: PUSH P,(D)
HRRZ C,P
PUSH P,(D)
MOVSS (P)
PUSHJ P,GCP6B
SUB P,[XWD 2,2]
AOBJN D,GCP6E
HRRZ R,(R)
JRST GCP6D
GFSWPP:
PHASE 0
GFSP1==.
JUMPL S,.+3
HRRZM F,(R)
HRRZ F,R
ROT S,1
AOBJN R,.-4
MOVE S,(D)
HRLI R,-40
AOBJN D,GFSP1
LPROG==.
JRST GFSPR
DEPHASE
;garbage collector sweep
GCSWP: MOVSI R,GFSWPP
BLT R,LPROG
MOVEI F,NIL ;will become movei f,-1
MOVE D,C3GCS
FOO MOVEI R,FS
GCBTL1: HRLI R,X ;-(32-<fs&37>
MOVE S,(D)
GCBTL2: ROT S,X ;fs&37
AOBJN D,GFSP1
GFSPR: MOVE A,C1GCS
MOVE B,C2GCS
PUSHJ P,GCS0
SKIPN GCGAGV
JRST GCSP1
MOVE B,F
PUSHJ P,GCPNT
STRTIP [SIXBIT / FREE STG,!/]
MOVE B,FF
PUSHJ P,GCPNT
STRTIP [SIXBIT / FULL WORDS AVAILABLE_!/]
GCSP1: HRLZI S,X ;bottom of reg pdl+1
BLT S,NACS+3 ;reload ac's
SUB P,[XWD GCPK2-GCPK1,GCPK2-GCPK1] ;restore p
JUMPE F,[ERR2 [SIXBIT /NO FREE STG LEFT!/]]
JUMPE FF,[ERR2 [SIXBIT /NO FW STG LEFT!/]]
MOVE R,RGC
MOVEI A,0
CALLI A,STIME ;time
ADDM A,GCTIM
POPJ P,
GCS0: MOVEI FF,0
GCS1: ILDB C,B
JUMPN C,GCS2
HRRZM FF,(A)
HRRZ FF,A
GCS2: AOBJN A,GCS1
POPJ P,
C1GCS: 0 ;(- length of fws) bottom of fws
C2GCS: XWD 100,X ;.=bottom of fws bit table
C3GCS: 0 ;-n wds in bt,,bt
GCGAG: EXCH A,GCGAGV#
POPJ P,
GCTIME: MOVE A,GCTIM
JRST FIX1A
TIME: MOVEI A,0
CALLI A,STIME
JRST FIX1A
SPEAK: MOVE A,CONSVAL#
JRST FIX1A
GCPNT: MOVEI R,TTYO
MOVEI A,0
JUMPE B,PRINL1
HRRZ B,(B)
AOJA A,.-2
SUBTTL GETSYM --- PAGE 17
R50MAK: PUSHJ P,PNAMUK
PUSH C,[0]
HRLI C,700
HRRI C,(SP)
MOVEI B,0
MK3: ILDB A,C
LDB A,R50FLD
CAMGE B,[50*50*50*50*50]
SKIPN A
POPJ P,
IMULI B,50
ADD B,A
JRST MK3
GETSYM: PUSHJ P,R50MAK
TLO B,040000 ;04 for globals
MOVE C,JOBSYM
MK7: CAMN B,(C)
JRST MK10 ;found
AOBJP C,.+2
AOBJN C,MK7
TLC B,140000 ;10 for locals
TLNE B,100000
JRST MK7-1
JRST FALSE
MK10: MOVE A,1(C) ;value
JRST FIX1A
PUTSYM: PUSH P,B
PUSHJ P,R50MAK
MOVE A,B
TLO A,040000 ;make global
SKIPL JOBSYM
AOS JOBSYM ;increment initial symbol table pointer
MOVN B,[XWD 2,2]
ADDB B,JOBSYM
MOVEM A,(B) ;name
POP P,1(B) ;value
JRST FALSE
SUBTTL ALVINE AND LOADER INTERFACES --- PAGE 18
;interface to alvine
ED: MOVEI 10,X
JRST (10)
PUSH P,A
HRRZ A,CORUSE
HRRM A,LST
AOS A
HRRM A,ED
MOVSI A,(SIXBIT /ED/)
PUSHJ P,SYSINI
HRLM A,LST
MOVNS A
PUSHJ P,MORCOR
PUSHJ P,SYSINP+1
POP P,A
JRST ED
GRINDEF: PUSH P,A
PUSHJ P,ED
POP P,A
JRST 2(10)
EXCISE: MOVEI A,ED+2
HRRM A,ED
MOVE A,JRELO
SETZM LDFLG# ;initial loader symbol table flag
CALLI A,CORE
JRST .+1
JSR IOBRST
JRST TRUE
XLIST
VAR
LIT
LIST
PAGE; lisp loader interface
LOAD: AOS B,CORUSE
MOVEM B,OLDCU#
MOVEM A,LDPAR#
JUMPE A,LOAD2
IFE VBP, <
FOO MOVE B,VBPORG
SUBI B,INUM0
>
IFN VBP, <
FOO MOVE A,VBPORG
PUSHJ P,NUMVAL
MOVE B,A
>
LOAD2: MOVEM B,RVAL# ;final destination of loaded code
MOVSI A,(SIXBIT /LOD/)
PUSHJ P,SYSINI
SUBI A,150 ;extra room for locations 0 to 137 and slop
PUSH P,A
MOVNS A ;length(loader)
HRRZM A,LODSIZ#
PUSHJ P,MORCOR ;expand core for loader
MOVEM A,LOWLSP# ;location of blt'ed low lisp
MOVN B,(P) ;length(loader)
ADD B,A
MOVEM B,HVAL# ;temporary destination of loaded code
HRLI A,0
BLT A,(B) ;blt up low lisp
HLL A,NAME+3 ;-length(loader)
HRRI A,137-1
PUSHJ P,SYSINP
SKIPE LDFLG
JRST LOAD3
SETOM LDFLG
MOVSI A,(SIXBIT /SYM/)
PUSHJ P,SYSINI
MOVNS A ;length symbols
PUSHJ P,MORCOR ;expand core for symbols
SKIPGE B,JOBSYM
SOS B ;if no symbol table, use original jobsym
HLRZ A,NAME+3 ;-length(symbols)
ADDB A,B
HLL A,NAME+3 ;symbol table iowd
PUSHJ P,SYSINP
HRRM B,JOBSYM
HLLZ A,NAME+3
ADDM A,JOBSYM
SKIPA
LOAD3: SOS JOBSYM ;want jobsym to point one below 1st symbol
MOVE 3,HVAL ;h
MOVE 5,RVAL ;r
MOVE 2,3
SUB 2,5 ;x=h-r
HRLI 5,12 ;(w)
HRLI 2,11 ;(v)
SETZB 1,4
JSP 0,140 ;call the loader
MOVEM 5,RLAST# ;last location loaded(in final area)
MOVE T,OLDCU
MOVE A,JOBSYM
MOVEM A,JOBSYM(T)
MOVE A,JOBREL
MOVEM A,JOBREL(T) ;update jobrel
HRLZ 0,LOWLSP
SOS LODSIZ
AOBJN 0,.+1
BLT 0,@LODSIZ ;blt down low lisp
MOVE 0,@LOWLSP
MOVE B,RLAST
MOVE A,RVAL
HRL A,HVAL
SKIPE LDPAR
JRST BINLD
MOVE C,RLAST ;new coruse
LDRET2: BLT A,(B) ;blt down loaded code
HRRZM C,CORUSE ;top of code loaded
MOVEI B,1
ANDCAM B,JOBSYM
SUB C,JOBSYM ;length of free core
ORCMI C,776000
AOJGE C,START ;no contraction
ADD C,JOBREL ;new top of core
MOVE B,C
PUSHJ P,MOVDWN
HRLM C,JOBSA
CALLI C,CORE ;contract core
JRST .+1
JRST START
PAGE
BINLD:
IFE VBP,<
MOVEI C,INUM0(B)
FOO CAML C,VBPEND
JRST BPSERR
FOO MOVEM C,VBPORG ;update bporg
>
IFN VBP,< PUSH P,A
PUSH P,B
HRRZ A,B
PUSHJ P,FIX1A
PUSH P,A
FOO MOVE B,VBPEND
PUSHJ P,.LESS
JUMPE A,BPSERR
FOO POP P,VBPORG
POP P,B
POP P,A
>
SOS C,OLDCU ;old top of core
JRST LDRET2
BPSERR: SETOM BPSFLG ;bps exceeded
JRST START
SYSINI: MOVEM A,NAME+1
IFE TENEX, < SETZM NAME+3 >
IFN TENEX, < MOVE A,SYSNUM
MOVEM A,NAME+3 >
INIT 17
IFE TENEX, < SIXBIT /SYS/ >
IFN TENEX, < SIXBIT /DSK/ >
0
JRST AIN.4+1
LOOKUP NAME
JRST AIN.7+1
INPUT [IOWD 1,NAME+3 ;input size of file
0]
HLRO A,NAME+3
POPJ P,
NAME: SIXBIT /LISP/
0
0
0
SYSINP: MOVEM A,LST
INPUT LST
STATZ 740000
ERR1 AIN.8
RELEASE
POPJ P,
LST: 0
0
PAGE
MOVDWN: HLRZ A,JOBSYM
JUMPE A,MOVS1
ADDI A,1(B)
HRL A,JOBSYM
HRRM A,JOBSYM
BLT A,(B) ;downward blt
POPJ P,
MOVSYM: MOVE B,JOBREL
HRLM B,JOBSA
HLRE A,JOBSYM
JUMPE A,MOVS1
ADDI B,1(A) ;new bottom of symbol table
MOVNI A,1(A)
ADD A,JOBSYM ;last loc of old symbol table
HRRM B,JOBSYM
PUSH P,C
MOVE B,JOBREL ;last loc of new symbol table
MOVE C,(A) ;simulated upward blt
MOVEM C,(B)
SUBI B,1
ADDI A,-1 ;lf+1,rt-1
JUMPL A,.-4
POP P,C
POPJ P,
MOVS1: HRRZM B,JOBSYM
POPJ P,
;enter with size needed in a
;exit with pointer in a to core
MORCOR: PUSH P,B
HRRZ B,JOBSYM
SUB B,CORUSE
SUBM A,B
JUMPL B,EXPND2
ADD B,JOBREL ;new core size
CALLI B,CORE ;expand core
ERR1 [SIXBIT /CANT EXPAND CORE !/]
PUSH P,A
PUSHJ P,MOVSYM
POP P,A
EXPND2: MOVE B,CORUSE
ADDM A,CORUSE
MOVE A,B
POP P,B
POPJ P,
PAGE
SUBTTL SOSLINK INLINE WITH LISP MAIN --- PAGE 18.1
; SECTION 18.1 IS USED BY LISP.SOS (I.E., FILEIN & EDFUN) AS DESCRIBED IN THE
; 1.6 MANUAL. 10/50 USERS (DECUS) PROBABLY DO NOT HAVE AN EDITOR LINKAGE.
INTERNAL %FPAGE,%NEXTTYI ;THESE ALSO USED BY REDUCE 2.
%FPAGE: SUBI 1,INUM0 ;FIND-PAGE N, IN THE FILE.
PUSH P,1
LOOP: MOVE 1,0(P)
SOJE 1,QQEND
ILOOP: PUSHJ P,TYI
CAIE 1,14
JRST ILOOP
SOS 0(P)
JRST LOOP
QQEND: SUB P,[XWD 1,1]
POPJ P,
%NEXTTYI: PUSHJ P,TYI
MOVEM 1,OLDCH
JRST FIX1A
PAGE
INTERNAL %SOSSWAP
%SOSSWAP:
IFE TENEX,< POPJ P, >
IFN TENEX,<
HRLZM 1,DEV ;MAKES NONZERO (FOR IOFIL CHECK)
; STORES POINTER TO FILE OR TO (FILE.EXT) .
SUBI 2,INUM0 ;(PAGE # .LT. 2^16, OF COURSE).
PUSH P,2
MOVE 1,3
SUBI 4,INUM0
LSH 4,^D16 ;ERGO, 2 BECOMES 400000
MOVEM 4,AC4SAV
MOVE 4,[XWD 10700,3]
PUSHJ P,NUMVAL ;(LINE # .LT. 99999).
MKLIN1: IDIVI 1,^D10
ADDI 2,60
DPB 2,4
ADD 4,[XWD 70000,0]
TLNN 4,400000
JRST MKLIN1
MOVE 1,3
TRO 1,1
PUSH P,1
MOVEI T,DEV ;T HAS PNTR TO (PNTR . NIL) .
PUSHJ P,IOSUB ;RETURNS FILENM IN A
MOVE 2,[XWD 6,ACSAV]
BLT 2,ACSAV+11 ;SAVE ACCS 6-17 JUST IN CASE.
POP P,15
POP P,16
MOVEM P,ACSAV-6+14
MOVE 14,A
MOVE 13,EXT ;SET BY IOSUB
HRR 13,AC4SAV ;00/01/02 == GET,R-O,CREATE.
MOVEI 11,NIL
CALLI 11,24 ;GETPPN UUO
> ;******** END OF IFN TENEX. ********
;HIGH ACCS FOR SOS ARE NOW SET ... TO WIT:
;
;ACC 11 = PPN
; 12 = (UNUSED).
; 13 = EXT,,FLAGS ;BITS 18-19 = 0 (GET FILE), 1 (READ-ONLY), 2 (CREATE IT)
; 14 = FILENM
; 15 = LINE #, IN ASCID FORM (BIT 35 ON);
; 16 = PAGE #.
PAGE
IFN 0, < ;USE LABORIOUS METHOD OF MAKING CORE-IMAGE.
; == FOR 10/50 SYSTEMS...VESTIGIAL.
;SWAP IS NOT DECLARED INTERNAL/SUBR (THO IT COULD BE).
;FIRST SAVES ALL ACCUMULATORS AS FILE 'QQSVAC.TMP'
;SAV -- SWAPS OUT (EFFECTIVELY) 116 THRU MIN(LH(E+2),JOBREL)
; -- MUST GO TO THE DISK (& WILL, REGARDLESS OF DEVICE).
; -- USES 1; DOES NOT SAVE ANY HIGH SEGMENT !!!
; -- THE FORMAT IS A NON-ZERO-COMPRESS (75--END).
; -- THE ACCS ARE RESTORED IF A RUN IS NOT DONE.
;RUN -- USES THE DEC RUN-UUO WHICH DESTROYS THE ACCUMULATORS
; -- THEREFORE, IF YOU WISH TO PASS ARGUMENTS (IN THE ACCS)
; -- TO THE NEW PROGRAM, PICK THEM UP FROM THE TMP FILE.
EXTERNAL JOBCOR,JOBS41,JOBDDT
SLOC==74
JOBSDD==114
SWAP: MOVEI 1,ACBLK
BLT 1,ACBLK+17 ;CAN'T OUTPUT FROM BELOW LOC 115
MOVE 1,[XWD ACSAV,6] ;RESTORE UNCLOBBERED HI-ACCS
BLT 1,17
CALLI 1,30 ;PJOB
IDIVI 1,^D10
LSH 1,6
OR 1,2
LSH 1,^D24
OR 1,[SIXBIT/00SVAC/]
MOVEM 1,ACHEAD
ADDI 1,5460-4143 ;'LP' - 'AC'
INIT 17 ;DUMP MODE
SIXBIT /DSK/
0 ;NO BUFFERS
JRST AOUT.4+1
SETZM ACHEAD+2
SETZM ACHEAD+3
ENTER ACHEAD
ERR1 SWOUT2
OUTPUT [IOWD 20,ACBLK
0]
STATZ 740000
ERR1 SWOUT2
CLOSE
STATZ 740000
ERR1 SWOUT2
MOVEM 1,IOFILE
SETZM IOFILE+2
SETZM IOFILE+3
ENTER IOFILE
ERR1 SWOUT2
HRRZ 2,JOBCOR
MOVEM 2,OLDCOR
MOVE 2,JOBREL
HRRM 2,JOBCOR
SUBI 2,SLOC ;NOT OUTPUTTING FIRST 0-SLOC LOCS
MOVEM 2,1 ;N WORDS OF DATA
MOVN 2,2
SUBI 2,1 ;-(N+1) == DATA + NULL HEADER WORD
HRLM 2,OLIST
MOVE 2,JOBREL
HRRM 2,MVX+^D9 ;HIGHEST LOC BEFORE RELOC = DITTO BLT
ADDI 2,2000
CALLI 2,CORE ;SPACE TO RELOCATE INTO
ERR1 SWOUT2
MOVE 3,[XWD MVX,MV]
BLT 3,MVE
MOVE 3,[XWD 216,116]
JRST MV
MVX: PHASE 4
MV: MOVE 2,SLOC(1)
MOVEM 2,SLOC+100(1) ;MOVE 100 UPWARD
SOJG 1,MV
SETZM SLOC+100 ;NULL HEADER WORD
MOVE 2,JOBDDT
MOVEM 2,JOBSDD+100
MOVE 2,JOB41
MOVEM 2,JOBS41+100
OUTPUT OLIST+100 ;AT RELOCATED IOWD
BLT 3,0-0 ;MOVE BACK DOWN
MVE: JRST MVY
DEPHASE
MVY: MOVE 2,[XWD ACSAV,6]
BLT 2,17 ;RESTORE AGAIN OVER CODE
HRRZ 2,MVX+^D10
CALLI 2,CORE ;REDUCE CORE BY 1K TO PREVIOUS
STRTIP [SIXBIT/WOULDN'T REDUCE CORE_!/]
STATZ 740000 ;NOW CHECK FOR OUTPUT ERRORS
ERR1 SWOUT2
CLOSE 0,
STATZ 740000
ERR1 SWOUT2
RELEAS 0,
MOVE 2,OLDCOR
HRRM 2,JOBCOR
RUNUUO: SETZM NEWCOR
MOVSI 1,1 ;SA INC
HRRI 1,DEVC2
CLRBFI ;DELETE CR,LF IF ANY...DISTURB SOS.
CALLI 1,35 ;RUN UUO
HALT ; POSSIBLY RECOVERABLE, BUT EXIT ANYWAY
ACBLK: BLOCK 20
DEVC2: SIXBIT/SYS/
SIXBIT/SOS/
SIXBIT/SAV/
0
0
NEWCOR:
OLDCOR: 0-0
IOFILE:
ACHEAD: SIXBIT/QQSVAC/
SIXBIT/TMP/
0
0
OLIST: XWD 0-0,SLOC+100-1
0
SWOUT2: SIXBIT /COULDN'T SWAP SUCCESSFULLY_!/
> ;******** CLOSE OF IFN 0, FROM SWAP: ********.
PAGE
IFN TENEX, < ;EASIER WITH TENEX
SWAP:
HRLZI 1,1 ;SET B17
MOVE 2,[POINT 7,FILSOS]
GTJFN
JRST SOSER1
HRRZ 3,1 ;AC1(RH) NOW HAS DESIRED JFN.
HRLZI 1,40000 ;BIT 3 TO USE AC2.
MOVEI 2,0 ;VIRTUAL ADDRESS OF ACCS.
CFORK ;CREATE INFERIOR FORK.
JRST SOSER2
;AC1 HAS RELATIVE F HANDLE.
EXCH 1,3
HRL 1,3 ;SET UP (LH) WITH HANDLE
GET
HRRZ 1,3
MOVEI 2,2 ;INDEX INTO ENTRY-VEC
SFRKV ;START THAT FORK
;AC1 HAS INFERIOR-F HANDLE!
WFORK ;CURRENT FORK WAITS UNTIL THE
; INFERIOR FORK TERMINATES.
KFORK ;INF-FORK STILL EXISTS, SO!
SWAPEX: SETOM RETFLG ;START. REALLY SHOULDN'T REALLOC, BUT
JRST LISPGO ; THIS DOES SO FOR NOW.
FILSOS: ASCIZ /<SUBSYS>SOS.SAV/
SOSER1: OUTSTR FILSOS
OUTSTR [ASCIZ / NOT FOUND
/]
SOSER2: OUTSTR [ASCIZ /COULDN'T SOSSWAP/]
JRST SWAPEX
> ;CLOSE OF IFN TENEX.
AC4SAV: 0
ACSAV: BLOCK 12
PAGE
SUBTTL BPS SWAPPING ROUTINES --- PAGE 18.2
INTERNAL RDBLK, WRBLK
RDBLK:
IFE TENEX, <
SETZM PPN
HRLZI C,(SIXBIT/DSK/)
CAIE B,NIL ;NIL?
HRLZI C,(SIXBIT/SYS/)
MOVEM C,.+2
>
IFN TENEX, <
SETZ C,
CAIE B,NIL
MOVE C,SYSNUM
MOVEM C,PPN
>
INIT 17
SIXBIT /DSK/
0
JRST AIN.4+1
HRLZM A,DEV
MOVEI T,DEV
PUSHJ P,IOSUB
MOVEM A,LOOKIN
LOOKUP LOOKIN
JRST AIN.7+1
INPUT [IOWD 1,LST
0]
JRST SYSINP+1
WRBLK: INIT 17
SIXBIT /DSK/
0
JRST AOUT.4+1
HRLZM A,DEV
MOVE A,B ;IN CASE ADDRESSES OVER 64K.
PUSHJ P,NUMVAL
EXCH A,C
PUSHJ P,NUMVAL
SUBI C,1
SUBM C,A ;A_ -(A-(C-1)) == ARG1:ARG2 INCLUSIVE
HRL C,A
MOVEM C,LST
MOVEI T,DEV
PUSHJ P,IOSUB
MOVEM A,ENTR
CLEARM ENTR+2 ;CREATION DATE
ENTER ENTR
JRST OUTERR+1
OUTPUT [IOWD 1,LST
0]
OUTPUT LST
CLOSE
STATZ 740000
JRST TYO2X+2
POPJ P,
PAGE
SUBTTL TENEX AUXILIARY ROUTINES --- PAGE 18.3
INTERNAL TCORE
TALLOC: JRST LISPGO ;== DOING ^C AND START, PRESUMABLY WITH
; A CORE N, == TCORE WITHIN LISP.
TCORE: SUBI A,INUM0 ;== ^C, CORE N, REENTER.
CAIG A,0
JRST TCORE0 ;JUST RETURN CURRENT CORE SIZE(S)
CAILE A,^D124 ;LIMIT .LT. 124K OR SO, ALLOWING FOR I/O BUFFS
JRST TCORE3
LSH A,^D10
SUBI A,1
CAML A,JRELO
JRST TCORE1 ;LARGER THAN CURRENT LISP AREA ALLOC.
OUTSTR [ASCIZ /
CANT CUT CORE INTO ALLOCATED SPACE/]
JRST TCORE0+1 ;RETURN MINIMUM SIZE
TCORE0: CAIE A,0
SKIPA A,JRELO ;-1 GIVES CURRENT LISP-ALLOC AREA
TCORET: HRRZ A,JOBREL ; 0 GIVES CURRENT TOTAL CORE ASSIGNED
ADDI A,1
LSH A,-^D10
ADDI A,INUM0
POPJ P,
TCORE1: CAML A,JOBREL
JRST TCORE2 ;LARGER THAN CURRENT CORE, SO EXPAND.
PUSH P,A ; ELSE CONTRACT SOMEWHAT.
PUSHJ P,EXCISE
STRTIP [SIXBIT /EXCISED !/]
POP P,A
TCORE2: CALLI A,CORE
TCORE3: ERR1 [SIXBIT /CANT EXPAND CORE !/]
JRST TCORET
IFN TENEX, <
INTERNAL SETSYS
SETSYS: SUBI A,INUM0 ;CHANGE SYS: <DIR> NUMBER.
CAIG A,0
SKIPA A,SYSNUM
MOVEM A,SYSNUM
JRST FIXI
>
SUBTTL REALLOC CODE --- PAGE 19
;relocator code moved from strange position
STRT: MOVE A,JOBREL
HRLM A,JOBSA
MOVEM A,JOSV# ;new top of core
SUB A,JRELO# ;length of extra core
JUMPE A,RREL4 ;no expansion
SKIPG A
JRST 4,0 ;smaller core -- bitch
MOVEI F,ED+2
HRRM F,ED
MOVE F,EFWSO#
SUB F,FWSO# ;old length of fws
HRRZS B,A
ACHLOC: ASH A,-2 ;1/4 of new core to fws
ADD A,F ;new length of fws
MOVE C,B
ASH C,-6 ;1/64 of new core to each pdl
MOVE AR1,C
HRL AR1,C
HLRZ AR2A,SC2 ;-old length of spec pdl
ADD AR2A,JOSV ;new bottom of spec pdl
HLL AR2A,SC2 ;old length of spec pdl
SUB AR2A,AR1 ;new pointer for spec pdl
MOVEM AR2A,SC2
MOVNS C2 ;old reg pdl pointer
HLRZ AR1,C2 ;old length of reg pdl
ADD C,AR1 ;new length of reg pdl
HRRZ B,AR2A ;new bottom of reg pdl
SUB B,FSO#
MOVEI T,44 ;1/36 space for fws bit tables
IDIVM A,T ;new length of fws bit tables
AOS T
SUB B,T
SUB B,A
SUB B,C
MOVEI TT,41 ;1/33 space for fs bit table
IDIVM B,TT ;new length of fs bit table
SUBI B,1(TT) ;new length of fs
ADD B,FSO ;new bottom of fs
HRRM B,GCP1
MOVN SP,B ;- new bottom of fws
HRRM SP,GCMFWS
HRLZM A,C1GCS
MOVNS C1GCS ;- new length of fws
HRRM B,C1GCS
ADDI B,-1(A) ;new top of fws
AOS B
MOVE SP,FSO
LSH SP,-5
SUBM B,SP
HRRM SP,GCBTP2 ;magic number for bit table references
HRRM SP,GCBTP1
HRLM B,C3GC ;bottom of bit tables --- for bit table zeroing
HRRM B,GCP2
HRRM B,GCP
MOVNI SP,-1(TT)
HRLM SP,C3GCS
HRRM B,C3GCS ;iowd for bit table sweep
AOS B
MOVE SP,FSO
ANDI SP,37
HRRM SP,GCBTL2 ;magic number to position bit table word
SUBI SP,^D32
HRRM SP,GCBTL1
HRRM B,C3GC ;bottom of bit table
ADDI B,-1(TT)
HRRM B,C2GCS ;bottom of fws bit table
AOS B
HRRM B,C2GC
ADDI B,-1(T)
HRRM B,GCP5 ;top of bit tables
AOS B ;bottom of reg pdl
HRRZ A,RHX2 ;oblist pointer
MOVEM A,(B)
HRRM B,GCP3 ;room for acs
AOS B
HRRM B,GCSP1
HRRM B,GCP4 ;room for acs
ADDI B,10
HRRM B,GCP41 ;top of ac area
AOS B
HRRM B,C2 ;reg pdl bottom
MOVNI A,-20(C)
HRLM A,C2 ;reg pdl size
HRRZ A,JOSV
HRRZM A,JRELO ;new top of core
MOVE A,GCP1
HRRM A,.+4
MOVE A,FWSO
HRRM A,.+1
MOVE A,.(F) ;old bottom of fws *
MOVEM A,.(F) ;new bottom of fws *
SOJGE F,.-2 ;f has length (old) of fws
HRRZ AR1,GCP1
SUB AR1,FWSO ;displacement for fws
MOVE AR2A,FSO ;bottom of fs
RREL1: HLRZ A,(AR2A)
CAMG A,EFWSO
CAMGE A,FWSO
JRST RREL2
ADD A,AR1
HRLM A,(AR2A) ;fix car pointer
RREL2: HRRZ A,(AR2A)
CAMG A,EFWSO
CAMGE A,FWSO
JRST RREL3
ADD A,AR1
HRRM A,(AR2A) ;fix cdr pointer
RREL3: CAMGE AR2A,FWSO
AOJA AR2A,RREL1
MOVE A,GCP1 ;bottom of fws
HRRZM A,FWSO
MOVE A,C3GC ;bottom of bit table + 1
HRRZM A,EFWSO
RREL4: CLEARB F,DDTIFG
JSR IOBRST
JRST START
PAGE
RLOCA: MOVE B,AR1
HRLI AR1,BFWS
HRRI AR1,FS(B)
HRRZI AR2A,EFWS-BFWS(AR1)
BLT AR1,(AR2A)
MOVEI AR1,FS-BFWS(B)
MOVEI AR2A,BFWS-1
REL1: HLRZ A,(AR2A)
CAILE A,EFWS
JRST REL2
CAIGE A,BFWS
JSP R,REL4
ADD A,AR1
REL2: HRLM A,(F)
HRRZ A,(AR2A)
CAILE A,EFWS
JRST REL3
CAIGE A,BFWS
JSP R,REL4
ADD A,AR1
REL3: HRRM A,(F)
SOS F
CAILE AR2A,FS
SOJA AR2A,REL1
JRST RREL4
REL4: CAIL A,FS
ADD A,FF
JRST 1(R)
REHASH:
FOO MOVEI A,BFWS
PUSH P,A
HRRM A,RHX2
HRRM A,RHX5
RH4: MOVSI B,X ;*
FOO HRRZI A,BFWS+1(B)
FOO MOVEM A,BFWS(B)
AOBJN B,.-2
FOO SETZM BFWS(B)
MOVSI AR2A,-BCKETS
RH1:
FOO HLRZ C,OBTBL(AR2A)
RH3: JUMPE C,RH2
HLRZ A,(C)
PUSH P,C
PUSH P,AR2A
PUSHJ P,INTERN
POP P,AR2A
POP P,C
HRRZ C,(C)
JRST RH3
RH2: AOBJN AR2A,RH1
SETZM HASHFG
POP P,A
HRRM A,@GCP3
FOO MOVEM A,OBLIST
JRST START
SUBTTL LISP ATOMS AND OBLIST --- PAGE 20
VAR
LIT
FS:
DEFINE MAKBUC (A,%B)
<DEFINE OBT'A <%B=.>
XWD %B,IFN <<BCKETS-1>-A>,<.+1>
IF1 <%B=0>>
DEFINE ADDOB (A,C,%B)
<OBT'A
DEFINE OBT'A<%B=.>
IF1 <%B=0>
XWD C,%B>
DEFINE PUTOB (A,B)
<ZZ==<ASCII /A/>_<-1>
ZZ==-ZZ/BCKETS*BCKETS+ZZ
ADDOB \ZZ,B>
DEFINE PSTRCT (A)
<ZZ==[ASCII /A/]
LENGTH ZY,A
REPEAT <ZY-1>/5,<XWD ZZ,.+1
ZZ==ZZ+1>
XWD ZZ,0>
DEFINE MKAT (A,B,C,D)
<XLIST
IRP A< PUTOB A,.+1
D XWD -1,.+1
XWD B,.+1
XWD C'A,.+1
XWD PNAME,.+1
XWD .+1,0
PSTRCT A>
LIST>
DEFINE MKAT1 (A,B,C,D)
<XLIST
IRP C <PUTOB C,.+1
XWD -1,.+1
XWD B,.+1
XWD D'A,.+1
XWD PNAME,.+1
XWD .+1,0
PSTRCT C>
LIST>
DEFINE LENGTH (A,B)
<A==0
IRPC B,<A==A+1>>
DEFINE ML1 (A)<IRP A,<
V'A= INUM0+A
MKAT A,SYM,V
>>
DEFINE ML (A)<
XLIST
IRP A,<PUTOB A,.+1
A: XWD -1,.+1
XWD PNAME,.+1
XWD .+1,0
PSTRCT A>
LIST>
OBTBL:
OBLIST: ZZ==0
XLIST
REPEAT BCKETS,<MAKBUC \ZZ
ZZ==ZZ+1>
LIST
PAGE
MKAT<RPLACA,RPLACD,MINUS,TERPRI,READ,CAR,CDR,CAAR>,SUBR
MKAT<CADR,CDAR,CDDR,CAAAR,CAADR,CADAR,CADDR,CDAAR,CDADR,CDDAR,CDDDR>,SUBR
MKAT<CAAAAR,CAAADR,CAADAR,CAADDR,CADAAR,CADADR,CADDAR,CADDDR,CDAAAR>,SUBR
MKAT<CDAADR,CDADAR,CDADDR,CDDAAR,CDDADR,CDDDAR,CDDDDR,MAKNUM,CONS>,SUBR
MKAT<ATOM,EQ,PRIN1,PRINT,RETURN,EXPLODE,SASSOC,ASSOC>,SUBR
MKAT<GCGAG,CHRCT,LINELENGTH,NUMBERP,EQUAL,SUBST,GET,INTERN,MEMBER>,SUBR
MKAT<ED,LOAD,MAKNAM,READCH,NOT,NULL,GENSYM,ZEROP,DIVIDE,GCD>,SUBR
MKAT<TIME,FIX,SET,PROG2,LENGTH,READLIST,LAST,ADD1,SUB1>,SUBR
MKAT<GCTIME,REVERSE,SPEAK,MAPLIST,GC,GETL,BAKGAG,MEMQ>,SUBR
MKAT<PUTPROP,PRINC,FLATSIZE,ERR,MAPCAR,EXAMINE,DEPOSIT,LSH>,SUBR
MKAT<NCONS,XCONS,REMPROP,ARG,SETARG,NOUUO,MINUSP,MAP,MAPC>,SUBR
MKAT<OUTC,INC,DDTIN,INITFN,EXCISE,REMAINDER,ABS>,SUBR
MKAT<PGLINE>,SUBR
MKAT<%FPAGE,%NEXTTYI,%SOSSWAP,RDBLK,WRBLK,SETPCHAR>,SUBR
MKAT<CORE,ALLOC>,SUBR,T
IFN TENEX,< MKAT<SETSYS>,SUBR >
MKAT EXPLODEC,SUBR,%
MKAT TYO,SUBR,I
MKAT TYI,SUBR,I
CEVAL=.+1
MKAT1 EVAL,SUBR,*EVAL
MKAT <LIST,COND,PROG,SETQ,INPUT,OUTPUT,GRINDEF>,FSUBR
MKAT<ERRSET,REMOB,OR,GO,ARRAY,STORE>,FSUBR
MKAT<AND,DEFPROP,CSYM,EXARRAY>,FSUBR
MKAT1 QUOTE,FSUBR,FUNCTION
MKAT1 FUNCT,FSUBR,*FUNCTION
MKAT <APPEND,NCONC,BOOLE,APPLY>,LSUBR
MKAT EVAL,LSUBR,O
MKAT ASCII,SUBR,A
MKAT QUOTE,FSUBR,,CQUOTE:
MKAT INUM0,SYM
PUTOB T,.+1
TRUTH: XWD -1,.+1
XWD VALUE,.+1
XWD VTRUTH,.+1
XWD PNAME,.+1
XWD .+1,0
PSTRCT T
VTRUTH: TRUTH
PUTOB NIL,0
CNIL2: XWD VALUE,.+1
XWD VNIL,.+1
XWD PNAME,.+1
XWD .+1,0
PSTRCT NIL
VNIL: NIL
MKAT1 LCALL,SYM,*LCALL,INUM0+%
MKAT1 AMAKE,SYM,*AMAKE,INUM0+%
MKAT1 UDT,SYM,*UDT,INUM0+%
MKAT1 %NOPOINT,VALUE,*NOPOINT
%NOPOINT: NIL
UNBOUND: XWD -1,.+1
XWD PNAME,.+1
XWD .+1,0
PSTRCT UNBOUND
PAGE
MKAT1 EXPN1,SUBR,*EXPAND1
MKAT1 EXPAND,SUBR,*EXPAND
MKAT1 PLUS,SUBR,*PLUS,.
MKAT1 DIF,SUBR,*DIF,.
MKAT1 QUO,SUBR,*QUO,.
MKAT1 TIMES,SUBR,*TIMES,.
MKAT1 APPEND,SUBR,*APPEND,.
MKAT1 RSET,SUBR,*RSET,.
MKAT1 GREAT,SUBR,*GREAT,.
MKAT1 LESS,SUBR,*LESS,.
MKAT1 PUTSYM,SUBR,*PUTSYM
MKAT1 GETSYM,SUBR,*GETSYM
ML1 <SPECBIND,SPECSTR,FIX1A,NSTR>
PUTOB NUMVAL,.+1
XWD -1,.+1
XWD SUBR,.+1
XWD NUMVAL,.+1
XWD SYM,.+1
XWD NUMVAL+INUM0,.+1
XWD PNAME,.+1
XWD .+1,0
PSTRCT NUMVAL
MKAT <OBLIST,BASE,IBASE,BPEND,BPORG,FECHO>,VALUE,V
VOBLIST: OBLIST
VBASE: 8+INUM0
VIBASE: 8+INUM0
VFECHO: 0
ML <PNAME,FIXNUM,FLONUM,VALUE,LAMBDA,SUBR,FSUBR,EXPR,FEXPR,SYM>
ML <$EOF$,LABEL,FUNARG,LSUBR,MACRO>
PUTOB ?,.+1
QST: XWD -1,.+1
XWD PNAME,.+1
XWD .+1,0
PSTRCT ?
IFE VBP, <
VBPORG: INUM0
VBPEND: INUM0
>
IFN VBP, <
VBPORG: 0
VBPEND: 0
>
MKAT ACHLOC,SYM
BFWS:
XLIST
LIT
LIST
EFWS: 0
SUBTTL LISP STORAGE ALLOCATOR (ONCE ONLY) --- PAGE 21
SBPS: 2000
ALLNUM: MOVSI A,400000 ;high bit on for no digits
INCHRW C
CAIN C,RUBOUT
JRST [OUTSTR [ASCIZ /XXX /]
JRST ALLNUM]
CAIL C,"0"
CAILE C,"9"
POPJ P,
TLZ A,400000 ;turn off hi bit on digit
IMULI A,10
ADDI A,-"0"(C)
JRST ALLNUM+1
ALLPDL: BLOCK 10
ALLOC: MOVEI P,ALLPDL-1
IFN TENEX, < ;LISP.SAV SIZE LT DESIRED STARTING SIZE.
MOVEI A,INITCORE
CAMG A,JOBREL
JRST .+3 ;IF JOBREL.GT.INIT, DON'T REDUCE CORE.
CALLI A,CORE
HALT
>
MOVE A,JOBREL
HRRZM A,JRELO
HRLM A,JOBSA
IFN TENEX, <
OUTSTR [ASCIZ /
TOTAL K-CORE= /]
MOVEI A,^D10
HRRM A,ALLNUM+10 ;CHANGE INPUT RADIX TO DECIMAL.
PUSHJ P,ALLNUM
JUMPLE A,ALLTNX
ADDI A,INUM0
PUSHJ P,TCORE
MOVE A,JOBREL
HRRZM A,JRELO
HRLM A,JOBSA
ALLTNX: MOVEI A,^D8
HRRM A,ALLNUM+10 ;CHANGE BACK TO OCTAL
>
CALLI RESET
IFN TENEX, <
HRRZI 1,1 ;MATCH EXACTLY
HRROI 2,[ASCIZ/LISP/ ;(PERHAPS SHOULD PEEK FOR 'SYS:(LISP.LSP)' EARLY).
0] ;(LEAVE ROOM FOR LONGER DIR-NAME PATCH).
STDIR
JFCL
GJINF ;IN DESPERATION, USE HIS LOGIN DIR #.
HRRZM 1,SYSNUM
OUTSTR [ASCIZ /
CHANGE SYS: /]
PUSHJ P,ALLNUM
SKIPLE A
HRRM A,SYSNUM
>
OUTSTR [ASCIZ /
ALLOC? /]
INCHRW C
CAIGE C,"O"
JRST ALLC00
OUTSTR [ASCIZ /
FULL WDS=/]
PUSHJ P,ALLNUM
SKIPGE A
MOVEI A,400
HRRM A,ALLC02
OUTSTR [ASCIZ /
BIN.PROG.SP=/]
PUSHJ P,ALLNUM
SKIPGE A
MOVEI A,2000
HRRZM A,SBPS
OUTSTR [ASCIZ /
SPEC.PDL=/]
PUSHJ P,ALLNUM
SKIPGE A
MOVEI A,1000
HRRM A,ALLC20
MOVNS A
HRRM A,ALLC21
OUTSTR [ASCIZ /
REG. PDL=/]
PUSHJ P,ALLNUM
SKIPGE A
MOVEI A,1000
HRRM A,ALLC30
OUTSTR [ASCIZ /
HASH=/]
PUSHJ P,ALLNUM
CAIG A,BCKETS
JRST ALLC00
HRRM A,INT1
MOVNS A
HRRM A,RH4
SETOM HASHFG
ALLC00: MOVEI A,DEBUGO
HRRM A,JOBREN
MOVEI A,LISPGO
HRRM A,JOBSA
OUTSTR [ASCIZ /
/]
MOVEI A,FS
IFN VBP,< PUSHJ P,FIX1A >
ADDM A,VBPORG
IFN VBP,< MOVEI A,FS >
ADD A,SBPS
HRRZM A,FSO
SOS A
IFN VBP,< PUSHJ P,FIX1A >
ADDM A,VBPEND ;(IFN TENEX, VBPEND IS 0 AT LOAD TIME).
MOVE A,JRELO
ALLC20: SUBI A,1000
ALLC21: HRLI A,-1000
MOVEM A,SC2
SUB A,FSO
HRRZS B,A
ASH A,-4
ALLC02: ADDI A,400
MOVE C,B
ASH C,-6
ALLC30: ADDI C,1000
;stg order prgm bps fs fws bt btf pdlac pdl sp
MOVEI T,44
IDIVM A,T
AOS T ;size of btf
SUB B,T
SUB B,A
SUB B,C ;remaining storage
MOVEI TT,^D32+1
IDIVM B,TT ;bt size -1
SUBI B,1(TT) ;free storage size
ADD B,SBPS
HRRZ AR1,B
ADDI B,FS
HRRZM B,FWSO
HRRM B,GCP1 ;b hac top of fs
MOVN SP,B
HRRM SP,GCMFWS
HRLZM A,C1GCS ;length of fws
MOVNS C1GCS
HRRM B,C1GCS
ADDI B,-1(A) ;bottom of bt-1
AOS B
MOVE SP,FSO
MOVE FF,SBPS
MOVEI F,BFWS-1(FF)
LSH SP,-5
SUBM B,SP
HRRM SP,GCBTP2
HRRM SP,GCBTP1
HRLM B,C3GC
HRRM B,GCP2
HRRM B,GCP
HRRZM B,EFWSO
MOVNI SP,-1(TT)
HRLM SP,C3GCS
HRRM B,C3GCS
AOS B
MOVE SP,FSO
ANDI SP,37
HRRM SP,GCBTL2
SUBI SP,^D32
HRRM SP,GCBTL1
HRRM B,C3GC
ADDI B,-1(TT)
HRRM B,C2GCS
AOS B
HRRM B,C2GC
ADDI B,-1(T)
HRRM B,GCP5
AOS B
MOVEI A,OBTBL
ADD A,SBPS
MOVEM A,(B)
HRRM B,GCP3
AOS B
HRRM B,GCSP1
HRRM B,GCP4
ADDI B,10
HRRM B,GCP41
AOS B
HRRM B,C2
MOVNI A,-20(C)
HRLM A,C2
MOVEI C,FOOLST
REL5: MOVE B,(C)
HRRZ A,(B)
ADD A,FF
HRRM A,(B)
HLR B,B
HRRZ A,(B)
ADD A,FF
HRRM A,(B)
CAIGE C,EFOLST-1
AOJA C,REL5
JRST RLOCA
I=0
DEFINE GARP (A,B)
<XWD FOO'A,FOO'B>
FOO 0
FOOLST:
XLIST
REPEAT <FOOCNT/2>,<
GARP (\I,\<I+1>)
I=I+2>
LIST
EFOLST:
DEFINE MKENT (A)<
INTERNAL A>
MKENT <EVBIG,NUMBP2,OPOV,NUMV2,NUMV3,NUMV4,OPR,FLOOV,FIX2>
MKENT <NUM1,NUM3,BPR,FWCONS,FALSE,TRUE,FW0CNS,NCONS>
MKENT <READ,READP1,MAKNUM,PRIN1,PRINT,EXPLODE,SASSOC,EQUAL,SUBST>
MKENT <CHCT,LINL,OLDCH,FLATSIZE,TYI,RATOM,CHRCT,TYOD>
MKENT <GET,INTERN,REMOB,MAKNAM,GENSYM,FIX,LENGTH,READLIST,PATOM>
MKENT <LAST,INC,OUTC,FIX1A,NUMVAL,REVERSE,MAPLIST,GC,GETL,PUTPROP>
MKENT <ERR,MAPCAR,REMPROP,LIST,SETQ,ERRSET,REMOB,ARRAY,APPEND>
MKENT <SPECBIND,SPECSTR,XCONS,ATOM,READCH,SET,NCONC,PRINC>
MKENT <CONS,ACONS,CTY,FP7A1,TERPRI,LSPRET,PSAV1,BKTRC>
MKENT <TYO,ITYO,IGSTRT,NOINFG,CHRTAB,EVAL,OEVAL,.APPEND,INPUT,OUTPUT>
PAGE
END ALLOC