From 5ca2eca2a778193ecdf8b7e9deb2537d512f07a4 Mon Sep 17 00:00:00 2001 From: Lars Brinkhoff Date: Thu, 7 Feb 2019 12:38:39 +0100 Subject: [PATCH] LISP11 - PDP-11 Lisp. --- build/misc.tcl | 5 + doc/programs.md | 1 + src/rms/lisp11.265 | 3248 ++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 3254 insertions(+) create mode 100644 src/rms/lisp11.265 diff --git a/build/misc.tcl b/build/misc.tcl index 6d1757ff..9fe0024b 100644 --- a/build/misc.tcl +++ b/build/misc.tcl @@ -1560,6 +1560,11 @@ respond "Command" "d" respond "*" ":pdump sys1; ts dftp\r" respond "*" ":kill\r" +# PDP-11 Lisp. +respond "*" ":palx rms;_lisp11\r" +respond "System (RANDOM, SIMULATOR, LOGO, MATH, or STANFORD)?" "SIMULATOR\r" +expect ":KILL" + # Logo RUG. STUFF prefers it to be RUG; AR BIN. respond "*" ":palx rug;_ar\r" # We'll just do the Logo PDP-11/45. diff --git a/doc/programs.md b/doc/programs.md index 1c8eccf2..5abb6e9c 100644 --- a/doc/programs.md +++ b/doc/programs.md @@ -166,6 +166,7 @@ - LIMERI, print limericks. - LIMSER, Chaosnet limerick service. - LISP, Lisp interpreter and runtime library (autoloads only). +- LISP11, PDP-11 Lisp. - LIVE, PALX Game of Life. - LLOGO, Logo implemented in Maclisp. - LOADP, displays system load. diff --git a/src/rms/lisp11.265 b/src/rms/lisp11.265 new file mode 100644 index 00000000..e3ce425a --- /dev/null +++ b/src/rms/lisp11.265 @@ -0,0 +1,3248 @@ +;-*-MIDAS-*- + +versio==%fnam2 ;save version no. +dispsw==0 +.TITLE PDP11 LISP + +; Originally written by Richard Stallman +; Modified 12/6/75 by EAK to use software multiply- +; divide rather than using EAE and to use either +; the TTY or SB +; Modified 12/11/75 by EAK to include GREATERP, LESSP +; DEFUN and to predefine the atom T +; Modified 12/31/75 by EAK to implement NULL, +; PLUSP and undefined variables. +; Modified 1/21/76 - whenever by RJL to run under SITS +; Modified 2/11/76 by EAK to add GC, NOT, GET, PUTPROP +; and to redefine NIL so that (EQ NIL 'NIL) => T. +; Modified 2/12/76 by EAK to use 2 word arithmetic +; Modified 2/29/76 by EAK to change ERROR, ERRSET, and +; ERR and to add BOUNDP, REMOB, REVERSE and NREVERSE. +; Modified 11/01/76 by GLD to move functions to an atom's +; plist & otherwise make function defunition and +; application more like Maclisp. +; Modified 11/05/76 by GLD to make CAR/CDR of NIL NIL, and +; to add DEPOSIT and EXAMINE functions & BPORG variable. +; Modified 7/20/77 by EAK to merge changes made by GLD into +; old version. Also added instruction macros to make +; 11s with losing instruction sets win. Macros +; are SOB, SPL, MFPS, MTPS, MUL, DIV, ASH, XOR, SXT. +; Finally added IF and LOOP macros. +; 10/27/77 by RMS: Eliminated losing FEXPR, FSUBR, etc. +; properties intorduced by GLD, in favor of NLAMBDA again. +; Also, (LEXPR atom body) is a MACLISP-style LEXPR. +; Function definitions now live on the FUNCTION property. +; FUNCALL exists for computed functions. +; PLISTs are now ALISTs again; GET, PUTPROP and REMPROP know that. +; (DELA alist indicator) deletes all bindings of indicator +; from the alist, returning the updated alist. +; NIL is again an ordinary atom whose value is (). + + +.macro setf q,a + .if ndf a + .print "q " + .ttymac ans + .if ndf ans + setf ^"Bad input, try again:",a + .mexit + .endc + a==ans + .endm + .endc +.endm + + +; Define symbols for various systems LISP11 can run on +RANDOM==0 +MATH==1 +LOGO==2 +STANFORD==3 +SIMULATOR==4 + +setf ^"System (RANDOM, SIMULATOR, LOGO, MATH, or STANFORD)?",sys + + +; Define symbols for various operating system LISP11 can run under. +; Zero is standalone. +NONE==0 +SITS==1 +RT11==2 + + +.if eq sys-math + ts==0 ; stand alone + pdp11==10 ; PDP11/10 + top==100000 ; assume 16K + dlsw==0 ; don't use DL11 + dzsw==1 ; use DZ11 instead of DL11 +.endc + +.if eq sys-logo + ts==sits + pdp11==45 +.endc + + +.if eq sys-stanford + ts==0 + pdp11==45 + hcor=160000 ; should ask user for value + top==160000 + dlsw==0 + dzsw==0 + tt10sw==1 + vt05sw==1 +.endc + + +.if eq sys-simulator + ts==0 + pdp11==45 + top==100000 + dlsw==1 + tks==177560 + tkv==60 +.endc + + +setf ^"Operating system (NONE, SITS, RT11)?",ts + +.if eq ts-sits +top==177700 +.insrt sits;lispm > +.endc + +.if eq ts-rt11 +setf ^"Memory size (RMON address)?",top + +JSW==44 +.MACRO .EXIT + EMT 350 +.ENDM +.MACRO .TTYIN CHAR + EMT 340 + BCS .-2. +.IF NB +.IF DIF ,R0 + MOVB %0,CHAR +.ENDC +.ENDC +.ENDM +.MACRO .TTYOUT CHAR +.IF NB +.IF DIF ,R0 + MOVB CHAR,%0 +.ENDC +.ENDC + EMT 341 + BCS .-2. +.ENDM + +.endc ; rt11 + + +setf ^"PDP11 model no.?",pdp11 +setf ^"Memory size (first non-existant location)?",top + +.if eq ts + .iif ndf dlsw, dlsw==0 + .iif ndf tt10sw,tt10sw==0 + .iif ndf vt05sw,vt05sw==0 + .iif eq dlsw+tt10sw+vt05sw, dlsw==1 ; assume a DL11 type interface + .if ne dlsw + setf ^"DL11 address (177560 for console TTY)?",tks + setf ^"DL11 interrupt vector (60 for console TTY)?",tkv + tkb==tks+2 + tps==tks+4 + tpb==tks+6 + .endc +.endc + + + +R0=%0 +R1=%1 +R2=%2 +R3=%3 +R4=%4 +R5=%5 +SP=%6 +PC=%7 + +.XCREF R0,R1,R2,R3,R4,R5,SP,PC + + +.IF EQ TS + +.LIF NE PDP11-03 +PS==177776 + + +.IF NE TT10SW + RCSR10==HCOR-4 ;1011 CELL NON ZERO MEANS HAS DATA READY + RDB10==HCOR-4 + TCSR10==HCOR-2 ;1110 CELL ZERO MEANS 10 IS READY TO ACCEPT DATA + TDB10==HCOR-2 + TT10FL==HCOR-6 ;-1 FOR VT05 0 FOR PDP10 + INT10==172566 ;SETTING BIT 0 CAUSES AN INTERRUPT ON THE PDP10 +.ENDC + +.ENDC ;IF EQ TS + +.sbttl Macros + +.macro typest string + jsr r5,types + .asciz ļstringŠ .even + .endm typest + + +.macro push a0,a1,a2,a3,a4,a5,a6,a7 + .irp d, + .if idn d,#0 + clr -(sp) + .iff + .lif nb d + mov d,-(sp) + .endc + .endm + .endm push + + +.macro pop a0,a1,a2,a3,a4,a5,a6,a7 + .irp d, + .if idn d,* + tst (sp)+ + .iff + .lif nb d + mov (sp)+,d + .endc + .endm + .endm pop + +.sbttl Flow of control macros + +;IF macro: Generates code that executes the if clause +;if the specified conditon is true, the else clause if +;it is false. The else clause is not required. Example: +; if eq,< +; mov r0,r1 +; mov (r1)+,r2 +; > +; else < +; jsr pc,foo +; > + +.macro if cond,code + .nlist + gncnt===gncnt+1 + .irp foo,\gncnt + .iif p1, .word 0 + .else + %.itmp===>/2 + .iif gt %.itmp-377, .error Branch out of range + .iif lt %.itmp+377, .error Branch out of range + .iif eq &400, +%.itmp+400 + .ielse +%.itmp-400 + .endc + code +g'foo===. +ifcnt===foo + .endm .irp + .list + .endm if + +.macro else code + gncnt===gncnt+1 + .irp foo,\ifcnt + .irp bar,\gncnt + br g'bar +g'foo===. + code +g'bar===. + .endm + .endm + .endm else + +gncnt===777 ;gensym count. + + +; LOOP macro allows loops without labels. Use RPTL and EXITL +; to repeat loop and exit loop. Both take branch condition arguments. +; If condition arg is null, then BR is used, i.e. unconditional. +; End of CODE falls out of loop unless specific RPTL is used. + +;Example of LOOP macro: +;loop < cmpb r0,(r1)+ ; found char yet? +; exitl eq ; exit loop on equal +; inc r2 ; not found +; cmp r2,r5 ; too many? +; rptl lt ; no, keep going +; jmp error ; too many +; > +; ; EXITL comes here + +;Loop defines two lables around the code argument, +;the first for looping back via the RPTL macro, the +;second for exiting the loop via the EXITL macro. +;Labels are of the form %Lnv or %Xnv where n signifies +;that this is the nth use of the LOOP macro, and v is +;the level of nesting of this loop macro. Up to 7 +;levels of nesting are allowed. + %level===0 + %loopn===0 +.macro loop code + .iif eq %level, %loopn===%loopn+1 + %level===%level+1 + .if gt <10*%loopn>+%level-7777 + .error Too many loops and/or nestings. + .mexit + .endc + .if gt %level-7 + .error Too many loop nestings (7 allowed). + .mexit + .endc + .irp n,\<<10*%loopn>+%level> + %l'n===. ;loop back to here. + code + %x'n===. ;exit to here. + .endm .irp + %level===%level-1 + .endm loop + +.macro rptl cond + .if eq %level + .error RPTL not inside LOOP + .mexit + .endc + .irp n,\<<10*%loopn>+%level> + .iif b cond, br %l'n ;loop back. + .ielse b'cond %l'n + .endm .irp + .endm rptl + +; SORL expands into a SOB instruction back to the last LOOP +; point. SORL takes one arg, a register to use with the SOB +; instruction. +.macro sorl r + .if eq %level + .error SORL not inside LOOP + .mexit + .endc + .irp n,\<<10*%loopn>+%level> + sob r,%l'n + .endm .irp + .endm sorl + + +.macro exitl cond + .if eq %level + .error EXITL not inside LOOP + .mexit + .endc + .irp n,\<<10*%loopn>+%level> + .iif b cond, br %x'n ;exit. + .ielse b'cond %x'n + .endm .irp + .endm exitl + +.sbttl Instruction macros + +.if ne pdp11-03 +.if ne pdp11-34 + +; MTPS and MFPS macros simulate PS intructions on 11/03 (LSI) +; and 11/34 processors. +.macro mtps src + movb src,@#ps + .endm mtps + +.macro mfps dst + movb @#ps,dst + .endm mfps + +.endc +.endc + + +.if ne pdp11-45 +.if ne pdp11-70 + +; SPL macro changes the the priority to its argument. It +; (unfortunately) does this with a MOV, thus clobbering +; the condition codes and such. +.macro spl n + .iif ne n, mtps #n*40 + .else + .iif eq pdp11-03, mtps #0 + .ielse clrb @#ps + .endc + .endm spl + +.endc +.endc + + +.if eq pdp11-10 + +; SOB macro expands into code which performs identically to +; the SOB instruction found on more powerfull 11 processors +.macro sob r,addr + dec r + bne addr +.endm + +; RTT macro expands into a RTI. This is so RTTs can be used in +; places where they would be called for on 11/40s, 11/45s etc. +.macro rtt + rti +.endm + + +; XOR macro simulates XOR instruction on 11/45. +; Caution: this macro is not intended to work with +; (Rn)+, -(Rn) or (SP) destinations. +.macro xor r,d + mov r,-(sp) + bic d,(sp) + bic r,d + bis (sp)+,d +.endm + + +; SXT macro performs sign extend as on PDP11/45. +.macro sxt d + if mi,< + mov #-1,d + > + else < + clr d + > +.endm + + +; ASH macro generates a series of ASR or ASL instructions to +; simulate the 11/45 ASH instruction. +.macro ash src,r +.ntype %.m,r +.iif ne %.m&70, .error ASH dst must be register +.ntype %.m,src +.iif ne %.m-27, .error ASH macro must have constant shift +%.m===0'src + .if ge %.m + .rept %.m + asl r + .endr + .iff + .rept -%.m + asr r + .endr + .endc +.endm + + +; MUL macro generates call to either MUL1 or MUL2 depending upon +; whether register destination is even or odd. Simulates 11/45 MUL. +.macro mul src,r +.ntype %.m,r +.iif ne %.m&70, .error MUL dst must be register + push src,r + .iif ne %.m&1, jsr r5,mul1 + .ielse jsr r5,mul2 + pop r + .iif eq %.m&1, pop r+1 +.endm + + +; DIV macro generates call to DIV2 to simulate 11/45 DIV instruction. +.macro div src,r +.ntype %.m,r +.iif ne %.m&70, .error DIV dst must be register + push r,r+1,src + jsr r5,div2 + pop r+1,r +.endm + +.endc + +.sbttl Formats + +;Register usage +;R0 - always saved/restored across a subr call +;R1 - used to pass arg 1 in a subr call and +; to return a value on exit +;R2 - used to pass arg 2 - not saved across call +;R3 - used to pass arg 3 - not saved across call +;R4 - mashed by TRAP. Lists ptd to by R4 are +; not protected from garbage collection +;R5 - not saved across a subr call. Also not +; considered by garbage collector. + +;Format of a symbolic atom: +; _______________ _______________ +; | | | | | | +; ---> | -1 | | ---> | | value | +; |_______|_______| |_______|_______| +; | +; | +; \|/ +; _______________ +; | | | +; | | propl | +; |_______|_______| +; | +; | +; \|/ +; _______________ _______________ +; | | | | | | +; | | | ---> | | | ---> ... +; |_______|_______| |_______|_______| +; | | +; | | +; \|/ \|/ +; 1st 4 chars of pname 2nd 4 chars of pname + +;The function definition is stored in the FUNCTION property of the atom. +;For an intrpreted function, it is (LAMBDA vars body) or (NLAMBDA vars body) +; or (LEXPR nargs-atom body). vars can be a list of atoms or one atom. +;For a built-in or compiled function, it is either the address of +;the routine for a SUBR, or 1 plus the address of the routine for +;an FSUBR (takes list of args, unevalled, as its only arg). +;An LSUBR is an FSUBR whose first word is TRAP .LSUBR. +;Such functions really eval all args but take an unlimited number of them. +;Compiled calls enter after the TRAP .LSUBR, after computing and stacking the args. + +;TOP OF STACK. + .=2000 +TOPSTK: .WORD OBPCEL ;FOR GARBAGE COLLECTOR + .WORD TOPSTK,0,0,TOPERR ;RESTORED ON ERROR +TOPST1: ;REACHING TOP LEVEL ERRSET. + + +;TRAP HANDLER. +TRPX: MOV (SP)+,R4 ;GET PC AFTER CALL. + MOV R4,(SP) ;SET UP FOR RTS PC . + MOV -(R4),R4 ;DECODE TRAP INSN. + TSTB R4 ;IS THE CALL BIT SET? + IF PL,< + JMP @TRPTAB-TRAP(R4) + > + JMP CALL + + +TRPTAB: EVALA,ALLOC,ERRORA,ASSQA,INRAN1,GETNUM + NCONS,CONS,XCONS,RDCHR,GPAST,PRINT,READ0 + LSUBRA,MAKNU1,GETNUM,SFT3L,REREAD + +.EVAL==0 +.ALLOC==2 +.ERROR==4 ;ERROR CODE IN NEXT WORD. +.ASSOC==6 ;ALMOST LIKE ASSQ. +.INRN1==10 +.GTNM1==12 +.NCONS==14 +.CONS==16 +.XCONS==20 +.RDCHR==22 +.GPAST==24 +.PRINT==26 ;FOR EXTERNAL USE. +.READ==30 ;FOR EXTERNAL USE. +.LSUBR==32 ;EVAL AND STACK ARGS. +.MKNUM==34 ;CREATE NUMBER. +.GTNUM==36 ;GET VALUE OF NUMBER. +.SFT3L==40 ;INTERNAL TO PRINT, READ. +.REREA==42 ;RE-READ LAST CHAR READ. + +.if eq pdp11-10 + +; MUL1 multiplies two integers, producing a single percision product. + +; ARGS: VALS: +; SP -> A SP -> P +; B + +mul1: push r1,r2 ; save regs + mov 6(sp),r1 ; multiplicand + mov 10(sp),r2 ; multiplier + clr 10(sp) ; clear product accumulator +loop < ror r2 ; divide multiplier by 2, testing lowest bit + exitl eq ; nothing left + if cs,< + add r1,10(sp) ; if bit is 1 then add multiplicand to product + > + asl r1 ; double multiplicand + clc ; so ROR is logical shift + rptl ; and repeat. + > + if cs,< + add r1,10(sp) ; one last add necessary if low bit was 1 + > + pop r2,r1,(sp) ; restore regs, remove arg2 from stack + rts r5 + + +; MUL2 is multiplies two integers producing a double percision product. + +; ARGS: VALS: +; SP -> A SP -> P hi +; B P lo + +mul2: push r0,r1,r2 ; save regs + clr r0 ; multiplicand + mov 6(sp),r1 ; ... + mov 10(sp),r2 ; multiplier + clr 6(sp) ; clear product accumulator + clr 10(sp) ; ... +loop < ror r2 ; divide multiplier by 2, testing lowest bit + exitl eq ; nothing left + if cs,< + add r1,10(sp) ; if bit is 1 then add multiplicand to product + adc 6(sp) ; ... + add r0,6(sp) ; ... + > + asl r1 ; double multiplicand + rol r0 ; will never set carry, so ROR above is ok + rptl + > + if cs,< + add r1,10(sp) ; one last add necessary if low bit was 1 + adc 6(sp) ; ... + add r0,6(sp) + > + pop r2,r1,r0 ; restore regs + rts r5 + + +; DIV2 divides a double word quantity by a single word +; quantity yielding a quotient and remainder. It is meant +; to simulate the DIV instruction found on reasonable 11s. + +; ARGS: VALS: +; SP -> divisor SP -> remainder +; dividend lo quotient +; dividend hi + +div2: push r0,r1,r2,r3,r4 ; save regs + mov 22(sp),r0 ; dividend hi + mov 20(sp),r1 ; dividend lo + mov 16(sp),r2 ; divisor + if mi,< + neg r2 ; negate divisor and dividend + com r0 ; double word negate + neg r1 ; ... + adc r0 ; ... + > + clr r3 + mov #16.,r4 +loop < asl r3 + rol r1 + rol r0 + cmp r2,r0 + if le,< + sub r2,r0 + inc r3 + > + sorl r4 + > + mov r3,22(sp) + mov r0,20(sp) + pop r4,r3,r2,r1,r0 ; restore regs + pop (sp) + rts r5 + +.endc + +.sbttl Top level + +;ENTRY POINT TO LISP. +BEG: +.IIF EQ PDP11-45,CLR @#177774 ;SET STACK LIMIT REGISTER + MOV #TOPSTK,SP + MOV #TOPSTK,ERRSTK + CLR @#0 ; NIL + CLR @#2 + MOV #TRPX,@#34 + CLR @#36 +.IF EQ TS-RT11 + BIS #50000,@#JSW ; special TTY i/o, no upper casing +.ENDC +.IF EQ TS-SITS + JSR PC,TSINIT ; SO MANY CROCKS, DON'T WANT THEM HERE +.ENDC +.IF EQ TS + RESET +.IF NE TT10SW + MOV #CLKINT,@#%PKV + MOV #200,@#%PKV+2 + MOV #100,@#%PKCSB + MOV #111,@#%PKCSR +.ENDC ;NE TT10SW +.IF NE DLSW + MOV #TKINT,@#TKV ; SETUP TTY INTERRUPT VECTOR + MOV #200,@#TKV+2 + MOV #100,@#TKS ; SET UP TTY INPUT INTS. +.ENDC ;NE DLSW +.ENDC ;EQ TS + CLR PROGPC ; NO PROG FORMS + CLR ERRFLG + CLR ALIST + JSR PC,GC ; GARBAGE COLLECT LIST SPACE + +;ERROR AT TOP LEVEL COMES HERE. THE STUFF ABOVE +;THE TOP OF THE STACK APPEARS AS IF IT HAD BEEN SAVED BY +;AN ERRSET CALLED FROM TOPERR-2. WHEN NOT INSIDE AN ERRSET, +;ERROR WILL THINK IT'S INSIDE THAT PSEUDO-ERRSET. +TOPERR: MOV #TOPST1,SP + MOV #TOPERR,-(SP) ;SET UP TOP-LEVEL ERRSET FRAME + CLR -(SP) + CLR -(SP) + MOV #TOPSTK,-(SP) + MOV #OBPCEL,-(SP) + MOV #.P,$PLUS ; SET + TO + + MOV #STAR,R1 ; SET * TO * + +;TOP LEVEL LOOP. +TLOOP: MOV R1,$STAR + JSR PC,PRINT ; TYPE OUT LAST EVALUATION + CLR SILENT ; TURN ON OUTPUT. + JSR PC,TERPRI ; FOLLOW WITH A NEWLINE + MOV $MINUS,$PLUS ; SET LAST FORM TYPED IN + JSR PC,READ ; READ ANOTHER + MOV R1,$MINUS ; SET CURRENT FORM + JSR PC,EVALA ; EVAL IT + BR TLOOP + +;TRAP .ERROR COMES HERE. +ERRORA: MOV @(SP),R1 ; GET ERROR CODE + MOV ERRT(R1),ERRC + MOV #ERRM,R1 + +;LSUBR -- 0 TO 2 ARGS +ERROR: TRAP .LSUBR +.LIF EQ TS-SITS + JSR PC,TYI.S ;RESTORE TTY INPUT, IF NECESSARY + DEC R3 ; SEE HOW MANY ARGS + BMI ER2 ; NONE, RETURN NIL (R1) + IF NE,< + MOV (SP)+,R1 ; TWO ARGS, SECOND IS DATUM TO PRINT + JSR PC,PRIN1 ; PRINT IT, NO NEWLINE + > + MOV (SP)+,R1 ; MSG TO PRINT + JSR PC,PRINC ; PRINT MSG WITHOUT SLASHIFICATION +ER2: MOV ERRSTK,SP ; RESTORE STACK PTR + BR ER1 + + +;SUBR - CAUSE AN ERROR +ERR: MOV ERRSTK,SP ; RESTORE STACK PTR + TST R1 ; ANY ARGS? + BEQ ER1 ; NO, JUST CAUSE SIMPLE ERROR + MOV R1,R2 ; YES, FIRST IS VALUE TO RETURN + MOV (R2)+,R1 ; ... + MOV (R2),R2 ; SECOND IS FLAG + IF EQ,< + TRAP .EVAL ; EVAL ARG TO RETURN + BR ER1 + > + TST (R2) ; IF NON-NIL THEN EVAL AFTER POPPING + POP ERRFLG,ERRSTK,PROGPC,ALIST + TRAP .EVAL ; NOW EVAL ARG + RTS PC + +;FSUBR - RETURNS (CONS (EVALA ARG)) IF NO ERROR. IF ERROR, RETURNS NIL. +ERRSET: PUSH ALIST,PROGPC,ERRSTK,ERRFLG + MOV SP,ERRSTK + MOV R1,R2 + MOV (R2)+,R1 ; FORM TO EVAL + MOV (R2),R2 ; FLAG? + IF NE,< + MOV (R2),ERRFLG + > + TRAP .EVAL + TRAP .NCONS ; INDICATE NO ERROR +ER1: POP ERRFLG,ERRSTK,PROGPC,ALIST + RTS PC + + .SBTTL ALLOCATION AND GARBAGE COLLECTION + +;ALLOCATE A PAIR. PUT ADDR OF CDR IN R4. +;DON'T CLOBBER ANYTHING ELSE. +ALLOC: MOV FREEL,R4 ; GET FREE LIST PTR + IF EQ,< + JSR PC,GC ; GARBAGE COLLECT LIST SPACE + MOV FREEL,R4 ; GET FREE LIST PTR + IF EQ,< ; NOTHING RECLAIMED + TRAP .ERROR + 0 + > + > + TST (R4)+ ; POINT TO CDR. + MOV (R4),FREEL ; UPDATE FREE LIST + RTS PC + +GC: MOV R0,-(SP) ;SAVE REGS FOR MARKING. + MOV R1,-(SP) + MOV R2,-(SP) + MOV R3,-(SP) + MOV #GCBTAB,R1 ;CLEAR BIT TABLE. + MOV #GCTLEN/2,R2 +loop < CLR (R1)+ + SORL R2 + > + MOV SP,MARKSP + MOV SP,R3 ;START MARKING AT BOOTTOM OF STACK. + +MARKL: MOV (R3)+,R1 ;NEXT ITEM OFF STACK. + BIC #2,R1 +MARK1: CMP R1,#IMPLSP ;DON'T MARK IF OUT OF FS. + BLO MARKX + CMP R1,HICELL + BHI MARKX + MOV R1,R0 + SUB #IMPLSP,R0 ;GET OFFSET INTO IMPURE FS. + ROR R0 ;FLUSH 2 LOW BITS, + ASR R0 + MOV R0,R4 + BIC #-10,R4 ;GET 3 LOWEST SIGNIF BITS, + ASR R0 + ASR R0 + ASR R0 ;GET REMAINING BITS =INDEX IN BIT TAB. + MOVB MARKTB(R4),R4 ;GET OFFSET IN WD FROM LOW BITS. + BITB R4,GCBTAB(R0) ;IF MARKED, EXIT. + BNE MARKX + BISB R4,GCBTAB(R0) ;ELSE MARK. + BIT #1,R1 ;IS IT A NUMBER? + BNE MARKX ;YES, DON'T TRACE. + MOV (R1)+,R4 ;DTPR: MARK CARR NEXT, + MOV (R1),-(SP) ;SAVE CDR FOR LATER. + MOV R4,R1 + BR MARK1 + +;COME HERE AFTER MARKING A WD. +MARKX: CMP SP,MARKSP ;ANY SAVED WDS TO MARK? + BEQ MARKLN + MOV (SP)+,R1 ;YES, POP&MARK. + BR MARK1 +MARKLN: CMP R3,#TOPSTK ;ALL WDS IN PRE-GC STACK TRACED? + BLOS MARKL ;NO, DO NEXT. + +;SWEEP PHASE -- FALLS THROUGH. + MOV #GCBTAB,R1 ;ADDR OF BIT TABLE. + MOV #IMPLSP,R2 ;PTR INTO FS. + MOV #FREEL,R4 ;PTR TO TAIL OF FREE LIST. + CLR FREEN ;VARIABLE TO COUNT FREE CELLS FOR USER REFERENCE +GCSWL0: MOV (R1)+,R3 ;GET A BIT TAB WRD. +GCSWLP: ROR R3 ;LOOK AT NEXT BIT. + BCS GCSWM + MOV R2,(R4) ;NOT MKD - ADD TO FREE LIST (AT END). + CLR (R2)+ + MOV R2,R4 ;ALSO CLEAR THE CELL. + CLR (R2)+ + INC FREEN ;COUNT OF FREE CELLS + BR GCSWN +GCSWM: ADD #4,R2 ;CELL MKD - SKIP IT. +GCSWN: BIT #77,R2 + BNE GCSWLP ;USE NEXT WD, BIT. + CMP R2,HICELL ;USED UP GCBTAB WD - AT END? + BLOS GCSWL0 ;NO, BUT GET NEW GCBTAB WD. + MOV (SP)+,R3 + MOV (SP)+,R2 + MOV (SP)+,R1 + MOV (SP)+,R0 + RTS PC + +;TEST WHETHER R1 -> FREE STORAGE. +INRAN1: BIT #3,R1 + IF NE,< + SEC ;NOT MULT. OF 4, SAY NO. + RTS PC + > + CMP R1,LOCELL ;IN RANGE? + IF HIS,< + CMP HICELL,R1 + > + RTS PC + +MARKTB: .BYTE 1,2,4,10,20,40,100,200 + + .SBTTL PRINT + +;SUBR -- TYPE CRLF, ARG, SPACE. +PRINT: CLR OUTTYP ; PRINT WITH "/"S + JSR PC,TERPRI ; TYPE NEWLINE + JSR PC,PRIN1 ; TYPE ARG + TYPEST ^" " ; AND FINALLY A SPACE + RTS PC + +;SUBR -- PRINT ARGUMENT WITHOUT "/"S +PRINC: MOV PC,OUTTYP + BR PRIN + +;SUBR -- PRINT A LIST, WITH "/"S +PRIN1: CLR OUTTYP + +;PRINT LIST <- R1. DON'T CLOBBER R2, R3. +;RETURN T +PRIN: MOV R2,-(SP) + MOV R1,-(SP) + BEQ PRNIL + TRAP .GTNM1 ;IF NUMBER, PUT IT IN R1, R2. + BCC PRNUM1 + MOV (SP),R1 ;.GTNM1 CLOBBERED R1. + TRAP .INRN1 ;IF NOT IN FS, PRINT WITH "#". + BHIS PRLIS ;IF IN FS, ... + + CLR R2 + TYPEST ^"#" +PRNUM1: MOV R3,-(SP) + TST R2 + IF MI,< + TYPEST ^"-" ;NEGATIVE, TYPE THE MINUS + NEG R1 ;AND NEGATE THE NO. + ADC R2 + NEG R2 + > + MOV #10.,-(SP) ;NUM DIGITS TO HANDLE. + CLR R3 ;INDICATE ZERO SUPP. ON. + ASL R1 ;NORMALIZE. + ROL R2 + CLR R4 + ASL R1 + ROL R2 + ROL R4 + BR 3$ +2$: TRAP .SFT3L ;SHIFT TOP DIGIT INTO R4. +3$: BIS R4,R3 ;IF #0, TURN OFF ZERO SUPP. + BEQ 5$ ;IF STILL ON, DON'T PRINT. +4$: ADD #'0,R4 ;MAKE ASCII CHAR. + INC R3 ;PREVENT LOOP IF PRINTING 0. + JSR PC,TYPEC +5$: DEC (SP) ;DO 9 DIGITS. + BPL 2$ + TST R3 ;IF NUMBER WAS 0, + BEQ 4$ ;PRINT ONE 0. + TST (SP)+ + MOV (SP)+,R3 +PRRET: TST (SP)+ + MOV #T,R1 + MOV (SP)+,R2 + RTS PC + + + +;PRINT A LIST OR PAIR, ETC. +PRLIS: CMP (R1),#-1 + BEQ PRATOM ;SPECIAL STUFF FOR ATOMS. + TYPEST ^"(" +PRNEXT: MOV 2(R1),-(SP) ;SAVE CDR, PRINT CAR. + MOV (R1),R1 + JSR PC,PRIN + MOV (SP)+,R1 + BEQ PRLIS1 ;IF END OF LIST, PRINT ")". + TRAP .INRN1 + IF HIS,< ;IF ENDED BY NON-NIL, PRINT AS DOTTED PAIR. + CMP (R1),#-1 + IF NE,< + TYPEST ^" " ;SPACES BETWEEN LIST ELTS. + BR PRNEXT + > + > + TYPEST ^" . " + JSR PC,PRIN +PRLIS1: TYPEST ^")" + BR PRRET ;POP R1 AND RETURN. + +PRNIL: TYPEST ^"()" + BR PRRET + +;PRINT A LITERAL ATOM. +PRATOM: MOV @2(R1),R1 + MOV (R1),R4 ;R1 -> PNAME. + MOV #-1,OUTCSA ;IND. 1ST CHAR. + +PRATO1: MOV (R4)+,R1 ;NEXT PNAME WD. + MOV (R4),-(SP) + DEC R1 ;-> WD ITSELF (WAS A NUMBER). + MOV #4,-(SP) ;GET, PRINT 4 CHARS. +PRATO2: MOVB (R1)+,R4 ;GET, + BEQ PRATO3 + JSR PC,OUTCS ;PRINT NEXT CHAR. + DEC (SP) + BNE PRATO2 +PRATO3: TST (SP)+ + MOV (SP)+,R4 ;GET PNAME LINK. + BNE PRATO1 ;IF MORE CELLS, HANDLE THEM. + BR PRRET + +;OUTPUT THE CHAR IN R4, PUTTING IN A "/" IF NECESSARY. +OUTCS: TST OUTTYP ;PRINTING WITH "/"S ? + BNE TYPEC1 ;NO. + JSR PC,TNEEDS ;THIS CHAR NEEDS ONE? + BEQ OUTCS1 ;YES. + INC OUTCSA ;IF 1ST CHAR, + BNE TYPEC1 + CMP R4,#'# ;SEE IF NEEDS "/" IN INITIAL POS. + BEQ OUTCS1 + CMP R4,#'0 + BLO TYPEC1 + CMP R4,#'7 ;DIGITS DO. + BHI TYPEC1 +OUTCS1: MOV R4,-(SP) ;PRINT A "/". + TYPEST ^"/" + MOV (SP)+,R4 +TYPEC1: JMP TYPEC ;OUTPUT THE CHAR ITSELF. + +;GIVEN CHAR IN R4, RETURN WITH Z BIT SET IF NEEDS SLASH. +TNEEDS: CMP R4,#'/ + BEQ TSPACX +TN1: CMP R4,#'( + BEQ TSPACX + CMP R4,#') + BEQ TSPACX + CMP R4,#'. + BEQ TSPACX + CMP R4,#'' + BEQ TSPACX + CMP R4,#177 + BEQ TSPACX + +;SEE IF CHAR IS A SEPARATOR. + CMP R4,#' + BHI TSPACX ;CTL CHARS ARE SEPARATORS. + SEZ +TSPACX: RTS PC + + +GPAST: TRAP .RDCHR + CMP R4,#' ;IS SEPARATOR, READ PAST. + BLOS GPAST + RTS PC + + +;SHIFT R4-R2-R1 3 PLACES LEFT. +SFT3L: CLR R4 + ASL R1 + ROL R2 + ROL R4 + ASL R1 + ROL R2 + ROL R4 + ASL R1 + ROL R2 + ROL R4 + RTS PC + +;SUBR -- OUTPUT CRLF. +TERPRI: +.if eq ts-sits + TYPEST ^" " +.iff + typest ^" +" +.endc + RTS PC + +RUBPRT: CLR OUTTYP + TYPEST ^"\" + JSR PC,PRIN + TYPEST ^" " + RTS PC + +.SBTTL READ + +READ: +.IIF EQ TS-SITS,MOV PC,READF ;SET FLAG FOR NOT ECHOING INTO OUTPUT FILES + TRAP .READ + BEQ READ ;RETRY IF RUBBED OUT. +READX: CMP #177,THSCHR ;IF LAST CHAR WAS RUBOUT, + IF EQ,< + JSR PC,RUBPRT ;PRINT RUBBED-OUT LIST, + CLR NXTCHR + BR READ0 ;RETRY. + > +.IIF EQ TS-SITS,CLR READF + CLZ +READXT: RTS PC + +READ0: TRAP .GPAST ;TRAP .READ COMES HERE. +READ1: CMP R4,#') ;SKIP ".", ")". + BEQ READ + CMP R4,#'. + BEQ READ + CMP R4,#'' + BEQ READQT ;'LIST EQUIV. TO (QUOTE LIST). + CMP R4,#177 + BEQ READXT ;PASS THE RUBOUT TO CALLER. + CMP R4,#'( + BEQ READL0 ;IF START OF LIST. + CMP R4,#'- + BEQ RNUM ;"-" ==> NUMBER. + CMP R4,#'# ;==> PTR. + BEQ RPTR + CMP R4,#'0 + BLO .+10 + CMP R4,#'7 + BLOS RNUM ;DIGIT ==> NUMBER. + JMP RDATOM + +;READ A "'" ALREADY - READ THE QUOTED LIST. +READQT: TRAP .READ + BNE READQR + TYPEST ^"\' " ;READ A RUBOUT. + BR READ0 +READQR: MOV R2,-(SP) + MOV #QUOTE,R2 + TRAP .NCONS + TRAP .XCONS + MOV (SP)+,R2 + BR READX + +;READ A LIST - ALREADY READ THE "(". +READL0: CLR -(SP) ;PLACE TO PUT PTR TO LIST. + CLR -(SP) ;PLACE TO PUT PTR->TAIL. + MOV SP,(SP) ;ORIGINAL PTR TO TAIL. +READL: TRAP .GPAST + CMP R4,#'. + BEQ READL1 ;IF DOTTED PAIR. + CMP R4,#') + BEQ READL2 ;IF FINISHED. + JSR PC,READ1 ;READ NEXT ELT. +READL3: BEQ RDRUB + TRAP .NCONS ;NEW TAIL OF LIST. + BR READL4 + +READL1: JSR PC,READ1 ;Skip the "." and read the following Sexp. + BEQ RDRUBP ;Jump if read rubout instead. +READL4: MOV (SP),R4 + MOV R1,2(R4) ;STORE IN OLD TAIL. + MOV R1,(SP) + BR READL ;READ NEXT ELT. + +;FINISHED - READ ")". +READL2: TST (SP)+ + MOV (SP)+,R1 + BR READX + + +RDRUB: MOV 2(SP),R4 ;ENTIRE LIST RUBBED OUT? + BNE RDRUB1 + TYPEST ^"\( " ;YES, RUB OUT PAREN. + ADD #4,SP + BR READ0 + +RDRUB1: MOV (SP),R1 ;LINK TO BE REMOVED. + MOV SP,R4 ;LIST TO REMOVE FROM. +RDRUB2: CMP R1,2(R4) + BEQ RDRUB3 ;FOUND THE LINK. + MOV 2(R4),R4 + BR RDRUB2 +RDRUB3: MOV R4,(SP) ;MOVE TO PREVIOUS LINK, + CLR 2(R4) ;SET ITS CDR TO NIL. + CMP (R1),#-1 ;Were we rubbing out the atom after a dot? + BEQ RDRUB5 ;Yes => reenter after where a dot is detected. + MOV (R1),R1 ;ELT. RUBBED OUT. + CMP R1,#TOPSTK ;SEE IF INUM + IF HIS,< + BIT #1,R1 ;SEE IF NUM + IF EQ,< + CMP (R1),#-1 ;IF ELT. IS LIST, + BNE RDRUB4 ;JUST RUB OUT THE ")". + > + > + JSR PC,RUBPRT ;PRINT ATOM RUBBED OUT. + BR READL + +RDRUB4: TYPEST ^"\) " ;HERE TO RUB OUT A ")". + MOV #READL3,-(SP) + MOV R1,-(SP) ;RE-ENTER INVOC. OF READL + JSR PC,LAST ;WHICH READ IN THE LIST WHOSE ")" + MOV R1,-(SP) ;IS BEING RUBBED OUT. + TST 2(R1) ;IS THE CDR OF THIS LINK NIL? + BEQ READL ;YES => WE ARE JUST AFTER READING THE CAR OF THIS LINK. + MOV 2(R1),(SP) ;NO => THIS IS A DOTTED PAIR. PRETEND HAVE JUST READ + BR READL ;THE ATOM WHICH FOLLOWS THE DOT. + +RDRUB5: JSR PC,RUBPRT ;PRINT THE ATOM AFTER THE ".". + BR READL1 ;PREPARE TO READANOTHER. + +RDRUBP: TYPEST ^"\. " + BR READL ;RUB OUT THE "." OF DTPR. + +;READ IN A NUMBER. +RNUM: TRAP .REREA ;ALREADY READ DIGIT. + JSR PC,RPTR0 ;ASSEMBLE NUMBER IN R1. + TRAP .MKNUM + JMP READX + +;READ IN A #-PTR, ALREADY READ THE "#". +;READ IN A NUMBER, PUT IT IN R1. +RPTR: MOV #READX,-(SP) +RPTR0: CLR R1 + CLR R2 + TRAP .RDCHR + MOV R4,RPTRA ;SAVE 1ST CHAR IN CASE IT'S A "-". + CMP R4,#'- ;IF IT IS, READ NEXT CHAR. + BNE .+6 +RDNUMA: JSR PC,RATOM + CMP R4,#177 + BEQ RDNUMC + TST R4 + BEQ RDNUMC ;IF NO MORE CHARS IN NUMBER. + SUB #'0,R4 ;GET VALUE OF DIGIT. + BLO RDNUMB ;ERROR IF NOT A DIGIT. + CMP #7,R4 + BLO RDNUMB + MOV R4,-(SP) + TRAP .SFT3L ;MAKE ROOM FOR THIS DIGIT. + ADD (SP)+,R1 ;SFT3L CLOBBERS R4. + BR RDNUMA + +RDNUMC: CMP RPTRA,#'- + BNE REREAD ;IF STARTED WITH A "-", + NEG R1 + ADC R2 + NEG R2 +REREAD: MOV THSCHR,NXTCHR ;REREAD LAST CHAR. + RTS PC + +RDNUMB: TRAP .ERROR + 2 ;BAD CHAR IN NUMBER. + +RATOM: TRAP .RDCHR + CMP R4,#'/ ;"/" ==> USE NEXT CHAR INVARIABLY. + IF EQ,< + JMP RDCHR + > + JSR PC,TN1 ;IS THE CHAR AN ATOM TERMINATOR? + BNE 1$ ;NO, RETURN IT. + CMP R4,#177 ;WELL DO OWN RUBOUT PROC + IF NE,< + TRAP .REREA ;YES, DON'T READ IT, RETURN 0. + CLR R4 + > +1$: RTS PC + +;READ IN A PNAME ATOM. +RDATOM: TRAP .REREA ;CHAR JUST READ IS 1ST IN ATOM. + MOV #RDATBF,R1 ;PTR TO PNAME BUFFER. +RDAT0: JSR PC,RATOM +RDAT1: CMP R4,#177 ;RUBOUT? + BNE 3$ + CMP R1,#RDATBF ;AT BEGIN OF BUFF? + BNE 2$ + TRAP .REREA ;REREAD THE RUBOUT + CLR R4 + BR 3$ +2$: MOVB -(R1),R4 ;GET CHAR +.IF EQ TS +.IF NE DISPSW + TYPEST ^" " ;BS,SP,BS + BR RDAT0 +.ENDC ;NE DISPSW +.IF NE TT10SW + TST TT10FL + BEQ 1$ ;SAIL TERMINAL (WITHOUT BACKSPACE) +.ENDC ;NE TT10SW +.IF NE VT05SW + TYPEST ^" " ;BS,SP,BS + BR RDAT0 +.ENDC ;NE VT05SW +.ENDC +1$: JSR PC,TYPEC ;RETYPE IT + BR RDAT0 +3$: MOVB R4,(R1)+ ;STORE NEXT CHAR. + BNE RDAT0 ;KEEP GOING TILL END OF ATOM. + BIT #3,R1 ;FILL WITH 0S TO DBLWD BNDRY. + BNE RDAT1 +EXPLO2: MOV R1,RDATL ;REMEMBER 1ST UNUSED LOC. + CLR (R1)+ + CLR (R1)+ + CLR (R1)+ + MOV R2,-(SP) + MOV R3,-(SP) + TST INTTYP ;IF NO INTERNING, GO CONS ATOM. + BNE RDATMK + MOV OBLIST,R2 ;R2->OBLIST LINK. +RDAT2: MOV (R2)+,R1 ;GET NEXT ATOM. + MOV @2(R1),R1 ;GET ITS PNAME. + MOV (R1),R1 + MOV #RDATBF,R4 ;COMPARE AGAINST PNAME BUFFER. +RDAT3: MOV (R1)+,R3 + DEC R3 ;GET NEXT PNAME NUMBER. + CMP (R3)+,(R4)+ + BNE RDAT4 ;ON MISMATCH GO TO NEXT ATOM. + CMP (R3)+,(R4)+ + BNE RDAT4 + MOV (R1),R1 + BNE RDAT3 + TST (R4) ;END OF PNAME - OF BUFFER, TOO? + BNE RDAT4 ;NO, MISMATCH. + MOV -(R2),R1 ;FOUND, GET PTR TO ATOM. +RDATX: MOV (SP)+,R3 + MOV (SP)+,R2 + JMP READX + +RDAT4: MOV (R2),R2 ;TRY NEXT ATOM IN OBLIST. + BNE RDAT2 + JSR PC,RDATC ;IF NONE, CONS NEW ATOM, +INTER1: MOV OBLIST,R2 + TRAP .CONS ;ADD TO FRONT OF OBLIST. + MOV R1,OBLIST + MOV (R1),R1 + BR RDATX ;RETURN THE ATOM. + +RDATMK: JSR PC,RDATC ;JUST MAKE, RET NEW ATOM. + BR RDATX + + +;CONS ANT ATOM OUT OF PNAME BUFFER. +RDATC: CLR -(SP) ;PTR TO ACCUMULATING PNAME TAIL. + MOV RDATL,R3 ;PTR INTO BUF. +RDATC0: MOV -(R3),R2 ;GET LAST 2 UNUSED WDS. + MOV -(R3),R1 + TRAP .CONS + INC R1 ;PUT INTO NUMBER. + MOV (SP)+,R2 + TRAP .CONS ;ADD TO FORMING PNAME. + MOV R1,-(SP) + CMP R3,#RDATBF ;LOOP TILL DOWN TO BEG. OF BUF. + BNE RDATC0 + MOV (SP)+,R1 + TRAP .NCONS ;MAKE REST OF ATOM. + TRAP .NCONS + MOV #-1,2(R1) ;INITIALLY UNDEFINED + MOV #-1,R2 + JMP XCONS + +;SUBR - REPLACE PNAME OR ATOM BY THE ONE ON THE OBLIST, +;OR, IF NONE, PUT IT ON THE OBLIST. (PNAME GETS MADE INTO +;ATOM IN THAT CASE). +INTERN: MOV R3,-(SP) + MOV R2,-(SP) + MOV R1,-(SP) ;SAVE ARG. + MOV @2(R1),R1 ;GET ARG'S PNAME. + MOV (R1),-(SP) + MOV OBLIST,R3 +RATOM9: MOV (R3)+,R1 ;NEXT ATOM IN OBLIST. + MOV @2(R1),R1 + MOV (R1),R1 ;ITS PNAME. + MOV (SP),R2 ;ARG'S PNAME. + JSR PC,EQUAL + BNE RATOM8 ;FOUND ARG IN OBLIST. + MOV (R3),R3 + BNE RATOM9 ;TRY NEXT ATOM IN OBLIST. + +;NOT FOUND IN OBLIST. + TST (SP)+ + MOV (SP)+,R1 ;GET THE ARG. + BR INTER1 ;GO ADD TO FRONT OF OBLIST. + +RATOM8: MOV -(R3),R1 ;GET VALUE OUT OF OBLIST. + TST (SP)+ ;SKIP ARG & ITS PNAME. + TST (SP)+ + BR RDATX + +.SBTTL EVALUATION + +;EVAL using current ALIST. Internal routine. +EVALA: MOV R2,-(SP) + MOV ALIST,R2 + BR EV + +;SUBR -- EVAL ARG1 WITH ALIST ARG2. +EVAL: MOV R2,-(SP) + BNE EV + MOV ALIST,R2 +EV: JSR PC,INRAN1 ;IF NOT IN FS, + BLO EVRET ;RETURN AS IS. + CMP (R1),#-1 + BNE EVLIS ;IF LIST. + JSR PC,ASSQA ;PNAME ATOM-- SEARCH ALIST. + IF EQ,< + MOV 2(R1),R1 + > + MOV 2(R1),R1 ;TAKE CDR OF ALIST ENTRY, OR CDR OF ATOM. + CMP R1,#-1 ;SEE IF UNDEFINED + BEQ UNDEF ;YES, ERROR +EVRET: MOV (SP)+,R2 + RTS PC + +EVLIS: MOV R3,-(SP) + MOV R2,R3 ;ALIST ARG TO APPLY. + MOV 2(R1),R2 ;ARGLIST ARG TO APPLY. + MOV (R1),R1 ;FUNCTION ARG TO APPLY. + CLR APPLYF ;FLAG SO LAMBDA-FUNCTIONS WILL EVAL ARGS. + BR APPLY0 + +APPER1: TRAP .ERROR + 6 ;TOO FEW ARGS. +APPER2: TRAP .ERROR + 10 ;TOO MANY ARGS. +UNDEF: TRAP .ERROR + 14 ;UNDEFINED VARIABLE. +FUNERR: TRAP .ERROR + 4 ;ILLEGAL FUNCTION. + +;SUBR - CALLS FIRST ARG WITH REMAINING ARGS AS ARGS TO IT. +;WORKS ON EVALLING AND NONEVALLING FUNCTIONS BY BEHAVING LIKE (EVAL (CONS ARG1 'OTHER-ARGS)). +FUNCALL:MOV R1,R2 + MOV (R2)+,R1 ;GET FUNCTION ARG IN R1 AND LIST OF REMAINING ARGS IN R2. + MOV (R2),R2 + JSR PC,EVALA ;EVAL THE FUNCTION ARG. + CLR APPLYF ;MAKE APPLY EVAL THE REST OF THE ARGS IF FUNCTION WANTS IT. + BR APPLY2 ;GO BE LIKE EVAL CALLING APPLY. + +;SUBR - CALLS ARG1 WITH ARGS FROM ARG2, ALIST FROM ARG3. +;CLOBBERS R4, R5. RETURNS VALUE RETURNED BY ARG1. + +;ENTER APPLY2 OR APPLY0 WITH 0 IN APPLYF TO EVAL THE ARGS IN THE ARGLIST. +;EVAL CALLS THAT WAY, + +APPLY: MOV #-1,APPLYF ;NEVER EVAL ARGS IN ARGLIST WHN DOING AN APPLY. +APPLY2: MOV R2,-(SP) + MOV R3,-(SP) + IF EQ,< + MOV ALIST,R3 ;IF 3RD ARG IS NIL, USE CURRENT ALIST + > +APPLY0: MOV ALIST,-(SP) + MOV R3,-(SP) +APPLY1: JSR PC,INRAN1 ;FUNCTION IN FREE STORAGE? + BLO FUNERR ;NO, THEN IT CAN'T BE A FUNCTION + CMP (R1),#-1 ;ATOM? + BNE APPEXP + PUSH R2 + MOV #FUNCTION,R2 ;Yes, get the FUNCTION property. + JSR PC,GET + BEQ FUNERR ;None => it isn't a function. + POP R2 +;Now the LAMBDA or SUBR-object is in R1. +APPEXP: CMP R1,#TOPSTK + BLO FUNERR ;INUM NOT A FUNCTION. + CMP LOCELL,R1 + BHI APPSU1 ;IF ARG1 A SUBR, JSR TO IT. + CMP HICELL,R1 + BLO FUNERR ;IF NOT IN FS. + MOV (R1)+,R4 ;DECODE CAR, SEE TYPE OF FN. + MOV (R1),R1 + SUB #LAMBDA,R4 + BEQ APPLM ;LAMBDA, NLAMBDA, FUNARG O.K. + CMP R4,#NLAMBDA-LAMBDA + BEQ APPLM ;IF NLAMBDA. + CMP R4,#LEXPR-LAMBDA ;IF LEXPR (LIKE NOSPREAD LAMBDA BUT NEEDN'T CONS + BEQ APPLEX ;WHEN COMPILED CODE CALLS COMPILED CODE). + CMP R4,#FUNARG-LAMBDA + BNE FUNERR ;IF FUNARG, OK. ELSE, ILLEGAL FUNCTION. +;COME HERE FOR (CONS 'FUNARG (CONS ALIST FUNC)) + MOV 2(R1),R1 + MOV (R1)+,(SP) ;1ST ELT IS NEW ALIST. + MOV (R1),R1 ;CDR IS FUNCTION TO APPLY. + BR APPLY1 + +;APPLY LAMBDA OR NLAMBDA EXPRESSION. +APPLM: BIS APPLYF,R4 ;IF CALLED APPLY, PRETEND WAS NLAMBDA. + MOV R4,-(SP) ;LAMBDA/NLAMBDA FLAG. + JSR PC,INRAN1 ;CDR IN FS? + BLO APPSUB ;NO, ITS A SUBR OR FSUBR. + MOV (R1)+,R3 ;GET PARAM. LIST. + MOV (R1),-(SP) ;SAVE VALUE FORMS. + MOV R2,-(SP) ;AND ARGLIST. + +APPLM0: MOV (R3),R4 ;NEXT PARAM TO BIND. + BEQ APPLM1 + BMI APPLMF ;IF PARAM LIST ENDS WITH ATOM. + MOV (SP),R2 + BEQ APPER1 ;ERROR IF NO MORE ARGS. + MOV (R2)+,R1 + MOV (R2),(SP) ;DETACH NEXT ARG FROM LIST. + TST 4(SP) + BNE .+6 + JSR PC,EVALA ;IF WAS LAMBDA, EVAL THE ARG. + MOV (R3)+,R2 +APPLM2: JSR PC,XCONS ;BIND THE ARG. + MOV 6(SP),R2 ;ADD BINDING TO FRONT OF NEW ALIST. + JSR PC,CONS + MOV R1,6(SP) + MOV (R3),R3 + BNE APPLM0 ;HANDLE REMAINING PARAM'S. +APPLM1: TST (SP)+ + BNE APPER2 ;TOO MANY ARGS. + MOV (SP)+,R2 ;VALUE FORMS. + MOV #IMPRO1,(SP) + BR APPLM3 + +;BIND ARGLIST TO ATOM IN R3. +APPLMF: MOV (SP),R1 ;REST OF ARGLIST. + MOV R3,(SP) ;FORMAL NAME. + TST 4(SP) ;IF WAS LAMBDA, EVAL ARGS. + IF EQ,< + JSR PC,LIST + > + MOV (SP),R2 + CLR (SP) ;NO MORE ARGS. + CLR R3 + BR APPLM2 ;GO MAKE BINDING. + + + +;COME HERE IF FUNCTION IS JUST A #-PTR. +APPSU1: MOV APPLYF,-(SP) ;PRETEND HAD LAMBDA. + +;COME HERE FOR (LAMBDA.ADDR) OR (NLAMBDA.ADDR). +APPSUB: MOVB #3,(SP) ;PUT 3 IN LOW BYTE OF WORD ON SP. HIGH BYTE IS NOEVAL FLAG. + MOV (SP)+,R3 ;LOW BYTE IS # OF ARGS LEFT TO ACTUALLY GIVE TO SUBR. + CMP R1,#TOPSTK + BLO FUNERR ;ERROR IF ADDR IS INUM. + MOV R1,-(SP) ;SAVE FUNC. ADDR. + ROR R1 ;IF FN. ADDR. ODD, IT'S AN FSUBR. + BCS APPFS + MOV R2,R1 + BEQ APPSU3 ;IF NO ARGS. +APPSU2: MOV (R2)+,R1 ;GET NEXT ARG, + TST R3 + BMI $1 ;EVAL IT IF HAD LAMBDA, + JSR PC,EVALA +$1: TSTB R3 + BEQ $2 ;SAVE 1ST 3 ARGS ON STACK. + MOV R1,-(SP) +$2: DECB R3 + MOV (R2),R2 + BNE APPSU2 ;HANDLE ALL ARGS. +APPSU3: MOVB R3,R4 ;(3-(NUM. ARGS)) + CLR R3 + ASL R4 ;2*(3-(NUM. ARGS)) + ADD R4,PC ;POP THE ARGS WE GOT. + MOV (SP)+,R3 ;THE REST WILL BE (). + MOV (SP)+,R2 + MOV (SP)+,R1 + BR APPLM3 + +APPFS: MOV R2,R1 + DEC (SP) ;ADDR OF FSUBR IS ODD. + CLR R2 + CLR R3 +APPLM3: MOV (SP)+,R4 ;ADDR. OF FN. +APPLM4: MOV (SP)+,ALIST + JSR PC,(R4) + MOV (SP)+,ALIST + MOV (SP)+,R3 + MOV (SP)+,R2 + RTS PC + +;WE COME HERE WITH TOP OF STACK ==> SUPPLIED ALIST +; CURRENT ALIST +; R3 +; R2 +;ARGLIST IN R2. + +APPLEX: MOV (R1)+,R3 ;GET THE LEXPR'S ARG NAME IN R3. + MOV (R1),-(SP) ;PUSH BODY OF LEXPR. + MOV R3,-(SP) ;PUSH LEXPR ARG NAME. + MOV R2,R1 + TST APPLYF ;IF ARGS ARE BEING EVALLED, CALL LIST TO EVAL THEM. + IF EQ,< + JSR PC,LIST > + MOV R1,R3 ;SAVE EVALLED ARG LIST IN R3. + JSR PC,LENGTH ;GET ITS LENGTH IN R1 + MOV (SP)+,R2 ;RESTORE SAVED ATOM + JSR PC,XCONS ;AND BIND IT TO THE ARGNUM ON THE SUPPLIED ALIST + MOV 2(SP),R2 + JSR PC,CONS + MOV R1,2(SP) + MOV R3,R1 ;ARGLIST +APPRT1: MOV #ARGS,R2 ;SPECIAL ATOM FOR LSUBR ARGS + JSR PC,XCONS ;BIND SPECIAL ATOM TO LIST + MOV 2(SP),R2 ;ON SUPPLIED ALIST AT 2(SP) + JSR PC,CONS + MOV R1,2(SP) + MOV (SP)+,R2 ;VALUE FORMS LIST + MOV #IMPRO1,R4 ;GO EVAL THEM, WITH AN ALIST WE POP OFF THE STACK FIRST. + BR APPLM4 + + .SBTTL LISP PROGRAM FCNS + +COND1: MOV (R2),R1 ;SEQUENCE TO NEXT "COND-PAIR". + +;FSUBR -- CONDITIONAL EVALUATION +COND: MOV R1,R2 + BEQ CONDR ;IF NO MORE, RET. (). + MOV @(R2)+,R1 ;GET CAR OF NEXT ONE. + TRAP .EVAL + TST R1 + BEQ COND1 ;IF (), GO TO NEXT PAIR. + MOV -(R2),R2 ;GET THIS ARG. +IMPROG: MOV 2(R2),R2 ;IF NO MORE ELTS, + BEQ CONDR ;RET. VALUE OF LAST. +IMPRO1: MOV (R2),R1 ;EVAL THE NEXT. + JSR PC,EVALA + BR IMPROG +CONDR: RTS PC + + +;FSUBR - SET UP BINDINGS FOR LOCAL VARIABLES AND EVALUATE +;ARGUMENTS IN ORDER +PROG: MOV PROGPC,-(SP) + MOV (R1)+,R4 ;LIST OF PROG VARIABLES. + MOV (R1),R2 ;REST OF PROG. + MOV ALIST,R1 ;ALIST SAVED OVER EXECUTION OF PROG. + MOV R2,PROGPC ;THIS PROG'S PROGRAM. + MOV R4,-(SP) +;BIND EACH LABEL TO THE FOLLOWING PART OF THE PROGRAM. +PROGA: CMP #-1,@0(R2) ;IF NEXT ELT IS ATOM, + IF EQ,< + TRAP .XCONS + > + MOV 2(R2),R2 ;CHECK EACH ITEM. + BNE PROGA + MOV (SP)+,R3 ;LIST OF PROG VARIABLES. + BEQ PROG7 +PROGB: MOV R1,R2 + MOV (R3)+,R1 ;BIND EACH PROG VAR. TO (). + TRAP .NCONS + TRAP .CONS ;ADD TO ALIST. + MOV (R3),R3 + BNE PROGB +PROG7: MOV R1,ALIST +PROGL: MOV PROGPC,R4 + BEQ PROGR ;RETURN IF REACH END. + MOV (R4)+,R1 ;ELSE, FETCH NEXT INSN, + MOV (R4),PROGPC ;INCREMENT PC, + TRAP .EVAL ;EXECUTE INSN. + BR PROGL + +PROGR: MOV (SP)+,PROGPC + RTS PC + +;SUBR - SETS PROG'S PC TO ARG +GO: MOV R1,R2 + +;SUBR - SETS PROG'S PC TO ARG2 (USUALLY (), TO EXIT). RETURNS ARG1 +RETURN: MOV R2,PROGPC + RTS PC + + .SBTTL BINDING FCNS + +;FSUBR DEFUN DEFINES A FCN +DEFUN: MOV #FUNCTION,R3 + MOV (R1)+,-(SP) ;PUSH FUNCTION NAME. + MOV (R1),R1 ;GET LAMBDA ARGS AND BODY. + MOV (R1),R2 ;IF LAMBDA, NLAMBDA OR LEXPR APPEARS AFTER FN NAME, + CMP R2,#LAMBDA ;THEN KEEP IT, INSTEAD OF CONSING ON A LAMBDA. + BEQ DEFUN1 + CMP R2,#NLAMBDA + BEQ DEFUN1 + CMP R2,#LEXPR + BEQ DEFUN1 + MOV #LAMBDA,R2 + TRAP .XCONS ;GENERATE THE LAMBDA. +DEFUN1: MOV R1,R2 + MOV (SP),R1 ;RESTORE FNAME, PUT ON THE PROPERTY. + JSR PC,PUTPROP + MOV (SP)+,R1 ;RETURN THE FNAME + RTS PC + +;FSUBR - SETS ARG1 TO VALUE OF ARG2. +SETQ: MOV (R1)+,-(SP) + MOV @(R1)+,R1 ;ARG2. + TRAP .EVAL + MOV R1,R2 + MOV (SP)+,R1 + +;SUBR SETS ARG1 TO ARG2. +SET: MOV R2,-(SP) + MOV ALIST,R2 ;FIRST LOOK FOR BINDING. + TRAP .ASSOC + IF EQ,< + MOV 2(R1),R1 ;TLB IS CDDR OF ATOM, NOT CDR. + > + MOV (SP)+,R2 ;GET NEW VALUE. + MOV R2,2(R1) ;PUT IN EITHER BINDING OR ATOM. + +;SUBR - RETURNS ARG2. +PROG2: MOV R2,R1 + RTS PC + +;SUBR - SEARCH FOR ELT. IN ARG2 WHOSE CAR IS ARG1. +;RETURN THE ELT IN ARG2, OR (). +ASSQ: JSR PC,ASSQA ;SEARCH, PUT ELT IN R1 IF FOUND. + IF EQ,< + CLR R1 ;IF NOT FOUND, RETURN (). + > + RTS PC + +;TRAP .ASSOC COMES HERE. +;SETS Z BIT IF NO BINDING FOUND. +ASSQA: TST R2 ;SEE IF NULL ALIST + IF NE,< + CMP R1,@(R2)+ ;NEXT ELT'S CAR. + IF EQ,< + MOV -(R2),R1 ;RETURN THE BINDING. + RTS PC ;(Z BIT OFF). + > + MOV (R2),R2 + BNE ASSQA ;KEEP LOOKING. + > + RTS PC ;NOT FOUND (NOTE Z BIT SET). + + .SBTTL PREDICATES + +;LSUBR - T IFF ARGS IN STRICTLY ASCENDING ORDER +LESSP: TRAP .LSUBR ;PUT ARGS ON STACK + MOV #2,CMPT ;LESS THAN COMPARISON + BR CMPC + +;LSUBR - T IFF ARGS IN STRICTLY DECREASING ORDER +;CLOBBERS R2, R3, R5 +GREATERP: + TRAP .LSUBR ;PUT ARGS ON STACK + CLR CMPT ;GREATER THAN COMPARISON +CMPC: CMP R3,#2 ;ERROR IF LESS THAN 2 ARGS + BLO WNA + MOV (SP)+,R1 ;GET LAST ARG + TRAP .GTNUM + DEC R3 +LOOP < MOV R1,R5 + MOV (SP)+,R1 + TRAP .GTNUM + ADD CMPT,PC ;DETERMINE WHICH COMPARE + BR 1$ + CMP R1,R5 ;COMPARE + EXITL GE + SORL R3 ;DO FOR ALL ARGS ON STACK + BR ATRUE ;RAN OUT OF ARGS, THUS TRUE +1$: CMP R1,R5 + EXITL LE + SORL R3 + BR ATRUE + > + DEC R3 ;GET NO. OF ARGS LEFT OF STACK + ASL R3 ;AND POP THEM OFF + ADD R3,SP ;... + BR AFALSE +CMPT: 0 + +WNA: TRAP .ERROR ;WRONG NO. OF ARGUMENTS + 6 + + +;SUBR -- NONNIL IFF ARG IS ATOM. +ATOM: TRAP .INRN1 + BLO ATRUE ;ATOMIC IF NOT IN FS. + CMP #-1,(R1) + BNE AFALSE ;CAR OF A SYMBOLIC ATOM IS -1. + RTS PC + +;SUBR -- NON-NIL IFF ARG IS > 0 +PLUSP: TRAP .GTNM1 + BCS AFALSE ;NOT A NUMBER + TST R2 + BMI AFALSE + BNE ATRUE + TST R1 + BNE ATRUE + BR AFALSE + + +;SUBR -- NON() IF ARG IS NEGATIVE NUMBER. +MINUSP: TRAP .GTNM1 + BCS AFALSE ;IF NOT A NUMBER. + TST R2 ;HIGH ORDER WORD OF NUMBER. + BMI ATRUE + BR AFALSE + +;SUBR -- RETURNS NON() IF ARG IS NUMERIC 0 (=INUM 1). +ZEROP: INC R2 ;COMPARE R1 AGAINST 1. + +;SUBR NON() IF ARGS ARE IDENTICAL. +EQ: CMP R2,R1 + BEQ ATRUE + BR AFALSE + +;SUBR -- NON() IF ARG IS A NUMBER. +NUMBERP: + TRAP .GTNM1 ;THIS PUTS THE NUMBER IN R1, R2, BUT SO WHAT? + BCS AFALSE + BR ATRUE + +;SUBR -- NON-NIL IFF ARG IS BOUND ATOM +BOUNDP: CMP (R1)+,#-1 ; ATOMIC SYMBOL? + BNE NATMBR ; NO, ERROR + MOV (R1),R1 ; GET PTR TO VALUE CELL + CMP 2(R1),#-1 ; -1 IN VALUE CELL IF UNBOUND + BEQ AFALSE ; NOT BOUND + BR ATRUE + +NATMBR: JMP NATOME + +;SUBR -- NON-NIL IFF ARG IS NIL +NULL: NOT: + TST R1 + BEQ ATRUE +AFALSE: CLR R1 + RTS PC +ATRUE: MOV #T,R1 + RTS PC + +;SUBR -- NON-NIL IFF ARGS HAVE SAME STRUCTURE +EQUAL: MOV SP,R5 +EQUAL0: CMP R1,R2 + BEQ ATRUE ;EQ IMPLIES EQUAL. + BLO EQUALL + CMP R2,LOCELL ;R2 + rts pc + +;SUBR - REPLACE CAR +RPLACA: MOV R2,(R1) + RTS PC + +;SUBR - REPLACE CDR +RPLACD: MOV R2,2(R1) + RTS PC + +;SUBR -- RETURNS NUM. ELTS IN ITS ARG. +LENGTH: JSR PC,LENGT1 + CLR R2 + JMP MAKNU1 + +LENGT1: MOV R1,R4 + IF NE,< + CLR R1 ;COUNTER. +loop < INC R1 + MOV 2(R4),R4 + rptl ne + > + > + RTS PC + + +;SUBR -- CONCATENATES 2 LISTS WITHOUT COPYING. +NCONC: MOV R1,R4 ;SAVE ARG TO RETURN IT. + IF NE,< + MOV R2,R1 ;IF 1ST ARG (), RETURN 2ND. + RTS PC + > + JSR PC,LAST ;GET TO END OF 1ST. + MOV R2,2(R1) ;STICK 2ND IN. + MOV R4,R1 +LASTR: RTS PC + +;SUBR -- RETURNS LAST LINK IN ARG, A LIST. +LAST: MOV 2(R1),R2 + BEQ LASTR ;RETURN IF CDR IS NIL. + BIT #1,R2 ;RETURN IF CDR IS NUMBER. + BNE LASTR + CMP (R2),#-1 ;RETURN IF CDR IS SYMBOL. + BEQ LASTR + MOV R2,R1 ;ELSE, SEQUENCE. + BR LAST + + +;SUBRS +CDDR: TST (R1)+ +CDAR: MOV (R1),R1 +CDR: TST (R1)+ +CAR: MOV (R1),R1 + RTS PC + +CADR: TST (R1)+ +CAAR: MOV @(R1)+,R1 + RTS PC + +;SUBR - REVERSE THE ELEMENTS OF A LIST +REVERSE: + MOV R1,R3 + IF NE,< ; (REVERSE NIL) = NIL + CLR R2 + loop < MOV (R3)+,R1 ; TAKE NEXT ELT OF LIST + TRAP .CONS ; AND TACK ONTO FRONT OF NEW LIST + MOV R1,R2 + MOV (R3),R3 ; MOVE TO NEXT ELT + rptl ne + > + > + RTS PC + +;SUBR - REVERSE A LIST BY CHANGING IT +NREVERSE: + CLR R3 ; PTR TO LAST ELT PROCESSED +LOOP < MOV 2(R1),R2 ; GET LINK TO NEXT CONS + MOV R3,2(R1) ; REPLACE WITH LINK TO LAST CONS + MOV R1,R3 ; PTR TO THIS CONS TO R3 + MOV R2,R1 ; MOVE TO NEXT ELT + RPTL NE + > + MOV R3,R1 ; RETURN THE MODIFIED LIST + RTS PC + + +;SUBR -- EXIT LISP +QUIT: +.IF EQ TS + JMP @#137730 ;EXIT TO DSKLOD +.ENDC +.IF EQ TS-SITS + BPT + RTS PC +.ENDC +.IF EQ TS-RT11 + MOV #1,R0 ; allow continue + .EXIT + RTS PC +.ENDC + +;SUBR - LEAVE ARGUMENT VALUELESS +MAKUNBOUND: + CMP (R1)+,#-1 ; ARGUMENT A SYMBOLIC ATOM? + BNE NATOME ; NO, GRIPE + MOV (R1),R1 + MOV #-1,2(R1) ; SET VALUE CELL TO -1 + RTS PC + + + .SBTTL PROPERTY LISTS + +;SUBR - RETURNS PLIST OF ATOM ARG. +PLIST: JSR PC,.A + MOV 2(R4),R1 + RTS PC + +;SUBR - SETS PLIST OF ATOM ARG1 TO ARG2. +SETPLIST: + JSR PC,.A + MOV R2,2(R4) + CMP -(R1),-(R1) + RTS PC ;RETURN THE ATOM. + +;PUT IN R4 A PTR TO PLIST POINTER CELL OF ATOM IN R1. ERROR IF NOT ATOM. +.A: TRAP .INRN1 + BLO NATOME ;ERROR IF NOT IN FS. + CMP (R1)+,#-1 + BNE NATOME ;ERROR IF NOT ATOM. + MOV @(R1)+,R4 + RTS PC + +NATOME: TRAP .ERROR + 16 + +;SUBR - FIND VALUE ON PROPERTY LIST +GET: JSR PC,PLIST ; GET PLIST FOR ATOM + MOV R2,R4 + MOV R1,R2 + MOV R4,R1 + JSR PC,ASSQA ;DO (ASSQ ). + IF EQ,< + JMP AFALSE + > + MOV 2(R1),R1 ;IF FOUND, RETURN CDR OF ALIST PAIR. + RTS PC + +;SUBR - SET A PROPERTY ON A PROPERTY LIST +PUTPROP: + JSR PC,.A ; PUT PTR TO PLIST CELL OF ATOM INTO R4 + TST (R4)+ + MOV R4,-(SP) ;SAVE PLIST POINTER ADDRESS. + MOV (R4),R1 + JSR PC,SETA ;DO (SETA ) + MOV R1,@(SP)+ ;STORE NEW PLIST INTO PLIST CELL. + RTS PC + +;SUBR - 2 ARGS. REMOVES THE PROPERTY FROM THE PLIST OF +REMPROP: + JSR PC,.A + TST (R4)+ ;PUT PTR TO PLIST CELL OF ATOM INTO R4 + MOV R4,-(SP) + MOV (R4),R1 ;GET OLD PLIST. + JSR PC,DELA ;DELETE PROPERTY IN R2 FROM IT. + MOV R1,@(SP)+ ;STORE NEW PLIST. + RTS PC + +;SUBR - ASSIGNS VALUE ARG2 TO OBJECT ARG3, IN ALIST ARG1. +;ARGS IN SAME ORDER AS PUTPROP. +;IF ARG3 NOT BOUND IN ARG1, MAKES BINDING AT FRONT. +;RETURNS UPDATED ARG1. +SETA: MOV R1,-(SP) + MOV R2,-(SP) ;.ASSOC CLOBBERS R2. + MOV R1,R2 + MOV R3,R1 + TRAP .ASSOC ;SEARCH ARG1 FOR BINDING OF ARG3 + BNE SETA1 + MOV (SP)+,R2 ;UNBOUND; MAKE NEW BINDING. + TRAP .CONS + MOV (SP)+,R2 + TRAP .CONS + RTS PC + +SETA1: MOV (SP)+,2(R1) ;CHANGE VALUE IN OLD BINDING. + POP R1 + RTS PC + +;SUBR - DELETES FROM ALIST ARG1 ALL BINDINGS OF ARG2. +;RETURNS UPDATED ARG1. +DELA1: MOV (R1),R1 + BEQ DELAX +DELA: CMP R2,@(R1)+ + BEQ DELA1 ;REMOVE 1ST ELT, UPDATE ARG2. + MOV R1,R3 ;SET UP TO RETURN THIS ARG2. + TST -(R3) +DELA2: MOV (R1),R4 ;FOLLOWING LINK. + BEQ DELAX ;IF NO MORE LINKS. + CMP R2,(R4)+ ;IF THAT LINK ->ARG1, + IF EQ,< + MOV (R4),(R1) ;RPLACD IT OUT, + BR DELA2 ;AND LOOK AT LINK AFTER IT. + > + MOV R4,R1 ;ELSE, PASS IT BY. + BR DELA2 + +DELAX: MOV R3,R1 + RTS PC + + .SBTTL ARITHMETIC + +;LSUBR - SUMS ARGS +PLUS: TRAP .LSUBR + JSR R0,ARITH + ADD R1,AC ;ADDITION RTN. + ADC AC+2 + ADD R2,AC+2 + RTS PC + +;LSUBR - RETURNS FIRST ARG MINUS THE REST. +DIFFERENCE: + TRAP .LSUBR + JSR R0,ARITH + SUB R1,AC ;ARITH CALL BACK HERE. + SBC AC+2 + SUB R2,AC+2 + RTS PC + +;LSUBR MULTIPLIES ARGS +TIMES: TRAP .LSUBR + INC R1 ;IDENTITY ELT. + JSR R0,ARITH + MOV AC,R4 + MOV AC+2,R5 + CLR AC + CLR AC+2 + BR 2$ +1$: ASL R4 + ROL R5 + CLC +2$: ROR R2 + ROR R1 + BCS 3$ + BNE 1$ + RTS PC +3$: ADD R4,AC + ADC AC+2 + ADD R5,AC+2 + BR 1$ + +;SUBR -- REMAINDER OF A/B +REMAINDER: + PUSH R0,R2 ; SAVE R0 AND SECOND ARG + TRAP .GTNUM + MOV R1,R0 ; COPY DIVIDEND + MOV R2,R3 ; ... + POP R1 ; GET SECOND ARG + TRAP .GTNUM + JSR PC,IDIV ; DO THE DIVISION + MOV R4,R1 ; COPY REMAINDER INTO R1,R2 + MOV R5,R2 ; FOR MAKNU1 + POP R0 + BR MAKNU1 ; MAKE REMAINDER INTO # AND RETURN + +;LSUBR -- DIVISION ROUTINE +QUOTIENT: + TRAP .LSUBR ;EVALUATE AND STACK OUR ARGS + INC R1 ;IDENTITY ELEMENT = 1. + JSR R0,ARITH ;SETUP ARITHMETIC, DIVISOR IN R1 + PUSH R0,R3 ; SAVE R0 + MOV AC,R0 + MOV AC+2,R3 + JSR PC,IDIV ; DO THE DIVISION + POP R3,R0 + MOV R1,AC ; STORE THE QUOTIENT + MOV R2,AC+2 + RTS PC + + +; IDIV - 2 WORD DIVISION ROUTINE +; CALL: R1,R2 - DIVIDEND +; R0,R3 - DIVISOR +; RETURN: R1,R2 - QUOTIENT +; R4,R5 - REMAINDER +IDIV: CLR R4 ; REMAINDER REG (R). + CLR R5 + MOV #32.,-(SP) ; BIT COUNTER. + CLR NEGSW ; ASSUME NO NEGATING NEEDED + TST R2 ; DIVISOR NEGATIVE? + BPL 5$ ; NO, CHECK DIVIDEND + NEG R1 ; YES, MAKE POSITIVE + ADC R2 ; ... + NEG R2 ; ... + COM NEGSW ; INDICATE WE MUST NEGATE RESULT +5$: TST R3 ; DIVIDEND NEGATIVE? + BPL 3$ ; NO, START DIVIDE + NEG R0 ; YES, MAKE POSITIVE BY DOING + ADC R3 ; A DOUBLE WORD NEGATE + NEG R3 ; ... + COM NEGSW ; INDICATE WE MUST NEGATE RESULT +3$: ASL R0 ; SHIFT A LEFT INTO R. + ROL R3 + ROL R4 + ROL R5 + CMP R5,R2 ; COMPARE R WITH B (2 WORDS). + BLO 1$ ; R IS LESS. + BHI 2$ ; R IS GREATER, SO SUBTRACT. + CMP R4,R1 ; HI-ORDERS SAME, CHECK LO. + BLO 1$ ; R IS LESS. +2$: SUB R1,R4 + SBC R5 + SUB R2,R5 ; THIS WAS 2-WORD SUB. + INC R0 ; SHIFT A 1 INTO A. +1$: DEC (SP) ; DONE? + BGT 3$ ; NO, KEEP LOOPING. + TST (SP)+ ; YES. + MOV R0,R1 ; COPY INTO R1,R2 + MOV R3,R2 + TST NEGSW + BEQ 4$ + NEG R1 ; NEGATE + ADC R2 + NEG R2 +4$: RTS PC + + + +;ARITHMETIC SETUP ROUTINE +ARITH: ASL R3 ;DOUBLE NUM. ARGS. + BEQ MAKNU1 ;IF NONE, RET. DEFAULT. + MOV R3,ARITHN + ADD SP,R3 ;ADDR. OF 1ST ARG ON STACK. + MOV (R3),R1 ;GET 1ST ARG. + TRAP .GTNUM + MOV R1,AC ;INTO ACCUM. + MOV R2,AC+2 +loop < MOV -(R3),R1 ;PROCESS NEXT ARG + CMP R3,SP ;IF ALL ARGS HANDLED, + EXITL EQ + TRAP .GTNUM + JSR PC,(R0) ;PERFORM PARTICULAR OP. + RPTL ;(RESULT IN RMQ) HANDLE REST OF ARGS. + > + MOV AC,R1 ;RET. RESULT IN ACCUM. + MOV AC+2,R2 + MOV (SP)+,R0 ;RESTORE R0 + ADD ARITHN,SP ;FLUSH ARGS FROM STACK. + BR MAKNU1 + + +AC: 0 ; ARITHMETIC ACCUMULATOR + 0 +ARITHN: 0 ; 2*NUM. ARGS. +NEGSW: 0 ; USED BY IDIV TO INDICATE MUST NEGATE QUOTIENT + + +;SUBR - RETURNS ARG1+1 +ADD1: TRAP .GTNUM + ADD #1,R1 ;INC DOESN'T SET CARRY + ADC R2 + BR MAKNU1 + +;SUBR - RETURNS ARG1-1 +SUB1: TRAP .GTNUM + SUB #1,R1 ;DEC DOESN'T SET CARRY + SBC R2 ;DOUBLE WORD SUBTRACT + BR MAKNU1 + +;STORE CONTENTS OF R1 AS NUMBER, PUT NUMBER IN R1. +MAKNU1: TST R2 ;HI ORDER ZERO? + BNE 1$ ;NO, CAN'T BE INUM + CMP #TOPSTK,R1 ;SMALL ENUF FOR INUM? + BHI 2$ ;YES, JUST INCREM. +1$: JSR PC,XCONS ;NO. CONS NUMBER. +2$: INC R1 + RTS PC + +;GET THE TWO WORDS OF THE NUMBER IN R1, INTO R1, R2. +;TRAP .GTNUM CAUSES ERROR IF NON-NUMERIC ARG; +;TRAP .GTNM1 JUST SETS C-BIT. +GETNUM: CLR R2 ;CLEAR HI ORDER IN CASE INUM + DEC R1 ;GET VALUE (INUM) OR ADDR (FIXNUM). + CMP #TOPSTK,R1 ;IF INUM, RETURN IT. + BHI 2$ + JSR PC,INRAN1 ;ELSE NOW SHOULD -> CELL, + BHIS 1$ + CMP R4,#TRAP+.GTNUM + BCS 2$ ;ERROR RETURN IF CALLED .GTNM1 . + TRAP .ERROR + 12 ;NON-NUMERIC ARG. +1$: MOV (R1)+,R2 ;HIGH ORDER + MOV (R1)+,R1 ;LO ORDER +2$: RTS PC + +;SUBR - RETURNS FIRST LINK IN ARG2 WHOSE CAR IS ARG1, OR (). +MEMBER: MOV R1,-(SP) ;EQUAL CLOBBERS, OF COURSE. + MOV R2,R3 + MOV (R3),R2 + JSR PC,EQUAL ;COOMPARE WITH NEXT ELT. + BNE MEMBX-2 ;FOUND - RETURN THIS LINK. + MOV (SP),R1 + MOV 2(R3),R3 + BNE MEMBER+4 ;TRY REMAINING LINKS. + TST (SP)+ ;FLUSH SAVED ARG1. +MEMBX: MOV R3,R1 ;IS FOUND LINK OR (). + RTS PC + +;SUBR - DELETES FROM ARG2 ALL LINKS THAT -> ARG1. +;RETURNS UPDATED ARG2. +DEL1: MOV (R2),R2 + BEQ MEMBX +DELQ: CMP R1,(R2)+ + BEQ DEL1 ;REMOVE 1ST ELT, UPDATE ARG2. + MOV R2,R3 ;SET UP TO RETURN THIS ARG2. + TST -(R3) +DEL2: MOV (R2),R4 ;FOLLOWING LINK. + BEQ MEMBX ;IF NO MORE LINKS. + CMP R1,(R4)+ ;IF THAT LINK ->ARG1, + IF EQ,< + MOV (R4),(R2) ;RPLACD IT OUT, + BR DEL2 ;AND LOOK AT LINK AFTER IT. + > + MOV R4,R2 ;ELSE, PASS IT BY. + BR DEL2 + +;FSUBR - EVAL ALL ARGS UNTIL ONE RETURNS (). +AND: DEC R3 ;NOW HAS -1 + +;FSUBR - EVAL ALL ARGS UNTIL ONE RETURNS NON(). +OR: MOV R1,R2 ;FOR OR, R3 HAS (). + BEQ ANDXIT ;IF NO MORE, RETURN VALUE OF LAST ARG. + MOV (R2)+,R4 + MOV R4,R1 ;IT'S AN ARG, SO EVAL IT. + TRAP .EVAL + BIT R1,R3 ;IF DOING AND, & VALUE NON(), + BEQ ORTEST +ORNEXT: MOV (R2),R2 ;HANDLE NEXT ARG. + BR OR+2 + +ORTEST: CMP R1,R3 ;IF DOING OR & VALUE (), HANDLE NEXT. + BEQ ORNEXT +ANDXIT: RTS PC + +.SBTTL LSUBR HACKERY + +;EVALS AND STACKS ARGS IN ORDER. +;PUTS NUM. OF ARGS IN R3, () IN R1,R2. +;TRAP .LSUBR COMES HERE. + +LSUBRA: CLR R3 ;ARG. COUNTER. +loop < MOV R1,R2 ;LIST OF REMAINING ARGS. + EXITL EQ + MOV (R2)+,R1 ;EVAL NEXT ARG + BIT #1,APPLYF ;IF THIS ISN'T A CALLED APPLY + IF EQ,< + PUSH APPLYF + TRAP .EVAL + POP APPLYF + > + MOV (SP),-(SP) ;SLIP ARG UNDER RETURN ADDR. + MOV R1,2(SP) + INC R3 + MOV (R2),R1 + RPTL + > + RTS PC + + + +;SUBR -- RETURNS NTH ELEMENT OF ARGS LIST, WHERE N IS ARG'S ARGUMENT +;IF (ARG NIL) WAS CALLED, (LENGTH ARGS) IS RETURNED +ARG: MOV R1,R2 ;ARG # OR () + MOV #ARGS,R1 + JSR PC,EVALA ;GET LSUBR-ARGS LIST IN R1 + MOV R1,R3 + JSR PC,LENGT1 ;GET (LENGTH ARGS) IN R1 + TST R2 + BNE ARG1 + RTS PC +ARG1: MOV R1,-(SP) ;SAVE LENGTH + MOV R2,R1 ;ARG # + TRAP .GTNM1 ;GET REAL NUMBER IN R1,R2 + MOV (SP)+,R2 ;RESTORE LENGTH + CMP R1,R2 + BLE ARG2 +ARG3: TRAP .ERROR + 6 +ARG2: MOV R1,R2 ;ARG # + MOV R3,R1 ;ARGLIST + DEC R2 + BLT ARG3 + BEQ ARGDON +ARGL: MOV 2(R1),R1 ;SETQ R1 (CDR R1) + SOB R2,ARGL ;N TIMES +ARGDON: MOV (R1),R1 ;RETURN NTH ELEMENT + RTS PC + +.SBTTL PNAME HACKERY + +;SUBR - RETURN PNAME AS A LIST OF FIXNUMS +PNGET: JSR PC,.A ; GET PTR TO ATOM STRUCTURE + MOV (R4),R1 ; CAR IS PNAME + RTS PC + +;SUBR - CREATE AN ATOM WITH PNAME GIVEN AS LIST +PNPUT: MOV R2,-(SP) ; SAVE INTERN FLAG + JSR PC,NCONS ; NULL PROP LIST + MOV #-1,R2 ; -1 => UNBOUND + JSR PC,CONS + MOV #-1,R2 ; -1 TO INDICATE SYMBOLIC ATOM + JSR PC,XCONS + TST (SP)+ ; INTERN THIS ATOM? + IF NE,< + JSR PC,INTERN + > + RTS PC + +;SUBR - RETURN T IFF TWO ARGS HAVE SAME PNAME +SAMENAMEP: + MOV R2,-(SP) ; SAVE SECOND ARG + JSR PC,PNGET ; GET FIRST'S PNAME + MOV R1,R2 + MOV (SP)+,R1 ; SECOND ARG + JSR PC,PNGET + JSR PC,EQUAL ; SEE IF SAME LIST FOR FIXNUMS + RTS PC + + + + + + +;SUBR - MAKE LIST OF CHARS (ATOMS) THAT ARG1 WOULD PRINT AS. +EXPLODE: + CLR EXPLTY + MOV OLNK,-(SP) ;SAVE OLD OUTPUT RTN. + CLR OLNK ;OUTPUT RTN () MEANS USE EXPLO. + MOV R0,-(SP) ;POINTS TO TAIL OF LIST OF CHARS. + MOV #EXPLP-2,R0 + JSR PC,PRIN1 + MOV EXPLP,R1 + MOV (SP)+,R0 + MOV (SP)+,OLNK + RTS PC + +EXPLO: MOV R1,-(SP) + MOV R4,R1 ;R4 HAS NEXT CHAR. + INC R1 ;ASCII VALUE (INUM). + TST EXPLTY + BNE EXPLO1 ;USE IT. + MOV #RDATBF,R1 ;SET UP CONSLESS INTERN. + MOV R4,(R1)+ ;SET UP PNAME BUFF. + CLR (R1)+ + JSR PC,EXPLO2 ;GET ATOM. + +EXPLO1: TRAP .NCONS ;NEW TAIL OF VALUE LIST. + MOV R1,2(R0) + MOV R1,R0 + MOV (SP)+,R1 + RTS PC + + + +;SUBR - SAME AS MAKNAM EXCEPT INTERN THE ATOM READ IN +IMPLODE: + CLR INTTYP + BR MAK1 + +;SUBR - READ IN THE CHARS OR ASCII NOS. IN LIST ARG1. +MAKNAM: MOV PC,INTTYP +MAK1: MOV R0,-(SP) ;USED TO -> REST OF LIST OF CHARS + MOV R1,R0 ;DURING CALL TO READ. + MOV ILNK,-(SP) + CLR ILNK ;COME TO MAKNA FOR EACH CHAR READ. + TRAP .READ + MOV (SP)+,ILNK + MOV (SP)+,R0 + CLR INTTYP ;SO READ WILL INTERN AGAIN. + RTS PC + +;PUT A CHAR IN R4, FOR .RDCHR . +MAKNA: MOV (R0)+,R4 + BEQ MAKNA2 ;NO MORE CHARS IN ARG - RETURN ")". + MOV (R0),R0 + CMP R4,#200 + BLOS MAKNA3 ;AN INUM - USE AS ASCII. + MOV @2(R4),R4 ;ATOM -- GET PNAME. + MOV @(R4)+,R4 ;1ST NUMBER IN IT (ODD ADDR). + MOVB -(R4),R4 ;1ST CHAR OF PNAME. + RTS PC +MAKNA2: MOV #')+1,R4 +MAKNA3: DEC R4 + RTS PC + + +;SUBR - 0 ARGS. +GENSYM: MOV GENAME,R1 ;LAST GENSYM NAME, LIST OF ASCII #S + MOV #4,R5 ;DIGIT COUNTER +loop < INC (R1) ;INC DIGIT + CMP (R1),#'9+1 + EXITL LO + MOV #'0+1,(R1) ;IF SO, WRAP TO SNUM FOR ASCII "0" + MOV 2(R1),R1 ;TAKE CDR OF GENSYM NAME LIST + SORL R5 ;AND INC NEXT DIGIT, IF ANY + BPT ;JUST OUT OF CURIOSITY (CAN ALT-P FROM HERE) + > + MOV GENAME,R1 + JSR PC,REVERSE ;REVERSE THE NEW GENSYM NAME-LIST + JMP MAKNAM ;AND MAKE AN ATOM OUT OF IT + +;SUBR - 0 ARGS. RESET GENSYM NAME TO G0000 +GENSET: MOV GENAME,R1 ;EXPLODED GENSYM NAME LIST + MOV #4,R5 ;DIGIT COUNTER +loop < MOV #'0+1,(R1) ;LISP # FOR ASCII 0 + SORL R5 + > + RTS PC + +;SUBR - REMOVE AN ATOM FROM THE OBLIST +REMOB: MOV OBLIST,R2 ; GET OBLIST PTR + JSR PC,DELQ ; REMOVE + MOV R1,OBLIST ; UPDATE OBLIST PTR + RTS PC + + .SBTTL OUTPUT SUBRS + +;OUTPUT ASCIZ STRING FOLLOWING CALL +TYPES: MOVB (R5)+,R4 ; NEXT CHARACTER + BEQ 1$ ; NULL TERMINATES STRING + JSR PC,TYPEC + BR TYPES +1$: INC R5 ; ROUND TO WORD BOUNDARY + BIC #1,R5 + RTS R5 + + +;OUTPUT CHARACTER IN R4 + +;OUTPOS IS THE CURRENT POSITION IN THE OUTPUT LINE. +;CHRCT IS THE NUMBER OF POSITIONS REMAINING IN THE LINE. +;LINEL IS THE NUMBER OF POSITIONS IN A LINE. +;SILENT GAGS TTY OUTPUT -- SET BY TYPING ^O. CLEARED BY INPUT REQUEST. +TYPEC: TST OLNK + BEQ EXPLO + TST SILENT + BNE OUTCX + CMP R4,#15 ;CR ==> RESET CHRCT, ETC. + BEQ OUTCR + CMP R4,#11 ;TAB ==> SPACE UP TO NEXT STOP. + BEQ OUTTAB + CMP R4,#40 ;CTL CHARS ==> NO SPACING. + BLO OUTC +OUTCN: INC OUTPOS ;ORDINARY CHAR ==>1 SPACE REQUIRED. + DEC CHRCT + BNE OUTC ;IF ROOM, TYPE CHAR. + MOV R4,-(SP) + JSR PC,TERPRI ;ELSE TYPE CRLF FIRST. + MOV (SP)+,R4 + BR OUTCN +OUTCR: MOV LINEL,CHRCT ;NUM. CHARSS. ALLOWED IN LINE. + CLR OUTPOS ;CR ==> AT START OF LINE. +OUTC: +.IF EQ TS + .IFNZ TT10SW +1$: TST TT10FL + BNE 2$ + TSTB TCSR10 + BNE 1$ + MOVB R4,TDB10 + MOV #1,INT10 ;INTERRUPT THE 10 + BR OUTCX +2$: + .ENDC; TT10SW + TSTB @#TPS ;WAIT TILL PRINTER READY. + BPL OUTC + MOVB R4,@#TPB ;PRINT THE CHAR. + .IFNZ VT05SW + CMPB R4,#12 ;VT05 NEEDS NULLS AFTER LINE FEED + BNE OUTCX + CLR R4 + JSR PC,TYPEC + JSR PC,TYPEC + JSR PC,TYPEC + JSR PC,TYPEC + MOV #12,R4 + .ENDC; VT05SW +.ENDC ;.IF EQ TS +.IF EQ TS-RT11 + PUSH R0 + .TTYOUT R4 + POP R0 +.ENDC ;TS-RT11 +.IF EQ TS-SITS + MOV R4,-(SP) + MOV #OUTCAP,-(SP) + $BYTO +.ENDC +OUTCX: RTS PC + +OUTTAB: TST CHRCT + BNE 1$ + JSR PC,TERPRI ;IF NO ROOM, PRINT CRLF. +1$: TYPEST ^" " ;PRINT AT LEAST 1 SPACE, + BIT #7,OUTPOS ;KEEP GOING TO TAB STOP. + BNE 1$ + RTS PC + +;SUBR -- TAKE ASCII CODE AS ARG AND TYPE CHAR +TYO: TRAP .GTNUM ; GET NUMERIC ARGUMENT + MOV R1,R4 ; CALL TYPEC WITH ARG IN R4 + BR TYPEC + + .SBTTL INPUT SUBRS + +;SUBR - RETURN INPUT CHAR AS ASCII NUMBER. +TYI: TRAP .RDCHR + MOV R4,R1 + INC R1 ;MUST BE AN INUM. + RTS PC + +;READ NEXT INPUT CHAR. +RDCHR: MOV NXTCHR,R4 ;IF CHAR TO RE-READ, + BNE RDRTN + TST ILNK + BNE 1$ + JSR PC,MAKNA + BR RDRTN + +.IF EQ TS +1$: SPL 5 + MOV TTYCHR,R4 + BNE 2$ + CLR -(SP) + JSR PC,3$ + WAIT + BR 1$ +3$: RTT +2$: CLR TTYCHR + SPL 0 +.ENDC +.IF EQ TS-SITS +1$: MOV CRLINK,-(SP) + $BYTI + MOV (SP)+,R4 +.ENDC +.if eq ts-rt11 +1$: .ttyin r4 +.endc + CMP R4,#177 + BEQ RDRTN ;DON'T ECHO RUBOUT. + CLR SILENT ;TURN ON OUTPUT. + JSR PC,TYPEC ;ECHO. + CMP R4,#15 ;CR ==> REPLACE BY LF AND ECHO + BNE RDRTN +.if ne ts-sits + MOV #12,R4 + JSR PC,TYPEC +.endc +RDRTN: MOV R4,THSCHR ; SET CURRENT CHAR + CLR NXTCHR ; NOTHING TO REREAD YET + RTS PC + +TILNK==1 +TOLNK==1 + +.SBTTL FILE I/O + +.IF EQ TS-SITS +;SUBR - 1 ARG, ATOM WHOSE PNAME IS FILE TO MUTATE TO & READ FROM +UREAD: JSR PC,RDFNAM ;READ FILENAME INTO FILBUF + INVOK #DKDCAP,#.CPYCP,,#-1 ;COPY DEFAULT FILE CAPABILITY + MOV (SP)+,INFILE + INVOK. INFILE,#.FAMU,#FILBUF,#0 ;MUTATE TO FILE + BEQ UREADX + RTS PC + +UREADX: TRAP .ERROR + 22 + +;SUBR - 1 ARG, ATOM WHOSE PAME IS FILE TO ADD & WRITE INTO +UWRITE: JSR PC,RDFNAME ;READ FILENAME INTO FILBUF + INVOK #DKDCAP,#.CPYCP,,#-1 + MOV (SP)+,OUTFIL + INVOK. OUTFIL,#.FAAD,#FILBUF + BEQ UREADX ;IF EVERYTHING'S OK, + + +RDFNAM: MOV #FILBUF,R5 + MOV R5,FBPTR ;INIT FILBUF PTR + MOV PCHAR,-(SP) + MOV #FILER,PCHAR ;"PRINT" INTO FILBUF VIA FILER RTN + MOV #40,R4 +1$: CLR (R5)+ ;CLEAR FILBUF + SOB R4,1$ + JSR PC,PRINC ;NOW, PRINT ATOM NAME INTO FILBUF + MOV (SP)+,PCHAR + RTS PC + + +;GETS CALLED BY JSR PC,@PCHAR WITH #FILER IN PCHAR +;CHAR TO OUTPUT IS IN R4 +FILER: MOVB R4,@FBPTR + INC FBPTR + RTS PC + +FBPTR: FILBUF +FILBUF: .BLKW 40 + +.ENDC ;EQ TS-SITS + +.SBTTL INTERRUPT HANDLERS + +.IF EQ TS +.IF NE TT10SW ;STANFORD 10/11 INTERFACE DEPENDS ON CLOCK INTERUPTS +CLKINT: TST RCSR10 + BEQ INTEXI ;NO CHARACTER + PUSH R1 + MOV RDB10,R1 + CLR RDB10 + BR TKIN2 +.ENDC ;NE TT10SW + +.IF NE DLSW +TKINT: MOV R1,-(SP) + MOV @#TKB,R1 +TKIN2: BIC #177600,R1 ;THE NEW CHAR. + CMP R1,#'A + BLO TKIN1 + CMP R1,#'Z + BHI TKIN1 + BIS #40,R1 +TKIN1: INC TKINTO + BEQ TKINTX ;IF PRECEDING CHAR WAS "/". + CMP R1,#7 ;^G? + BNE 1$ + SPL 0 ;RESTORE LOW PRIORITY + TRAP .ERROR ;GIVE ERROR TO STOP WHATS DOING + 20 +1$: CMP R1,#'/ + BNE TKINTS + MOV #-1,TKINTQ ;SLASHIFY NEXT CHAR. +TKINTS: CMP R1,#3 + BNE 1$ + JMP BEG ;^C ==> RESTART. +1$: CMP R1,#'O-100 + BEQ TKINTO +TKINTX: TST TTYCHR ;IF READ IS WAITING FOR CHAR, + BNE TKINTG + MOV R1,TTYCHR ;GIVE IT THIS ONE. +TKINTG: MOV (SP)+,R1 +INTEXI: RTI + +TKINTO: COM SILENT + BR TKINTG +.ENDC +.ENDC ; EQ TS + +.SBTTL SITS SETUP STUFF + +.IF EQ TS-SITS + +OUTCAP: TTYCAP ;OUTPUT CAPABILITY, INITIALLY TTY +INCAP: TTYCAP ;INPUT " , " " + +OUTFIL: 0 ;FILE I/O CAPABILITIES +INFILE: 0 + +OUTFLG: 0 ;FLAGS SAYING TO USE IN/OUTFILE CAPS FOR I/O +INFLAG: 0 + +TSINIT: TST CRLINK ;CORE LINK EXIST? + BNE TSINI1 ;YUP + MOV #-1,-(SP) + MOV #25.,-(SP) ;A SMALL ONE + MOV #.CLCAP*400+0,-(SP) ;CREATE IN A NEW CAP + $INVOK + MOV (SP)+,CRLINK ;THE INPUT CAP + TST -(SP) ;DUMMIE + MOV #-1,-(SP) ;BECOME CONSUMER + MOV CRLINK,-(SP) + $INVOK +TSINI1: TST PRCAP ;MAIN PROCESS EXIST? + BNE TSINI2 ;YES + MOV #-1,-(SP) + TST -(SP) + MOV #.PRCAP*400+0,-(SP) ;CREATE A PROCESS + $INVOK + MOV (SP)+,PRCAP + TST -(SP) + MOV PRCAP,-(SP) + MOV #.SPPTP*400+1,-(SP) + $INVOK ;PUT PROCESS INTO SELF +TSINI2: TST -(SP) + MOV #1,-(SP) + MOV PRCAP,-(SP) + BIS #<.PRWRT!.PRSTOP>*400,(SP) + $INVOK + MOV SP,R0 + TST -(SP) + MOV R0,-(SP) + MOV PRCAP,-(SP) + BIS #<.PRWRT!.PRREG+6>*400,(SP) + $INVOK + TST -(SP) + MOV #TSINI3,-(SP) + MOV PRCAP,-(SP) + BIS #<.PRWRT!.PRREG+7>*400,(SP) + $INVOK + TST -(SP) + CLR -(SP) + MOV PRCAP,-(SP) + BIS #<.PRWRT!.PRSTOP>*400,(SP) + $INVOK + MOV #TTYPDL,SP ;FALL THRU TO TYI LOOP + + ;FALLS IN FROM ABOVE + INVOK #TTYCAP,#<.TTMOV*400>,#.TICTM ;SET TTY MODE + +TYILOP: JSR PC,@GCHAR + ASL R5 + BIT #300,R5 ;CTRL CHAR? + BEQ 1$ ;IF SO,DISPATCH + JSR PC,TYINO ;ELSE, NORMAL TYI + BR TYILOP +1$: JSR PC,@TYITAB(R5) + BR TYILOP + +TYINO: ASR R5 + MOV R5,-(SP) + MOV CRLINK,-(SP) + $BYTO + RTS PC + + +TYI.Q: TST INFILE ;IF INFILE IS NONZERO, MAKE IT THE DEFAULT INPUT SRC + BEQ 1$ + MOV INFILE,INCAP +1$: RTS PC + +TYI.R: MOV PC,OUTFLG ;ENABLE OUTPUT TO FILE DESTINATION + RTS PC + +TYI.S: MOV #TTYCAP,INCAP ;RESTORE TTY INPUT + CLR SILEN1 + RTS PC + +TYI.T: CLR OUTFLG ;DISABLE OUTPUT TO FILE DESTINATION + RTS PC + +TYI.V: CLR SILEN1 ;RESTORE TTY ECHOING + RTS PC + +TYI.W: MOV PC,SILEN1 ;FLUSH TTY ECHOING DURING FILE READS + RTS PC + +TYITAB: TYINO,TYINO,TYINO,TYINO,TYINO,TYINO,TYINO,TYINO ;0-7 + TYINO,TYINO,TYINO,TYINO,TYINO,TYINO,TYINO,TYINO ;10-17 + TYINO,TYI.Q,TYI.R,TYI.S,TYI.T,TYINO,TYINO,TYINO ;20-27 + TYINO,TYINO,TYINO,TYINO,TYINO,TYINO,TYINO,TYINO ;30-37 + +PCHAR: BYTO.. ;ADDR OF ROUTINE TO OUTPUT A CHAR WITH +GCHAR: BYTI.. ;ADDR OF ROUTINE TO INUPT A CHAR WITH +READF: 0 +SILEN1: 0 + +;CHAR TO OUTPUT IS IN R4 +BYTO..: TST SILEN1 ;THIS FLAG SEZ + BEQ 2$ + TST OUTFLG ; THAT IF OUTPUT IS GOING TO A FILE + BEQ 2$ + TST OUTFIL ; & THERE IS REALLY, A FILE TO GO TO, + BNE 3$ ; DON'T OUTPUT TO TTY +2$: MOV R4,-(SP) + MOV OUTCAP,-(SP) + $BYTO ;OUTPUT CHAR TO NORMAL OUTPUT DESTINATION +3$: TST OUTFLG ;FLAG SET FOR FILE OUTPUT? + BEQ 1$ + TST OUTFIL ;IS THERE A FILE TO OUTPUT TO? + BEQ 1$ + TST READF ;DON'T WANT TO ECHO INTO OUTPUT FILE + BEQ 1$ + MOV R4,-(SP) + MOV OUTFIL,-(SP) + $BYTO +1$: RTS PC + +BYTI..: MOV INCAP,-(SP) + .BYTI ;READ CHAR FROM CURRENT INPUT SOURCE + BEQ 1$ ;IF ANYTHING WENT WRONG, WE'LL ASSUME IT WAS AN EOF + MOV (SP)+,R5 + RTS PC +1$: TST (SP)+ ; SO FLUSH BYTI ARG + MOV #TTYCAP,INCAP ; AND REINIT INPUT CAPS + CLR INFILE + RTS PC + +PRCAP: 0 +CRLINK: 0 + .BLKW 10. +TTYPDL:: +TSINI3: RTS PC + +.ENDC ;NE TS-SITS + +.SBTTL LAP SUBRS + +;SUBR - RETURN CONTENTS OF LOCATION DESIGNATED BY ARG IN R1 +EXAMINE: + JSR PC,LAPTST + MOV (R1),R1 + TRAP .MKNUM ;MAKE CONTENTS A LISP # + RTS PC + +;SUBR - 2 ARGS - MOVE # IN R2 TO LOCATION DESIGNATED BY R1 +DEPOSIT: + MOV R2,-(SP) + JSR PC,LAPTST + MOV R1,R3 + MOV (SP),R1 + TRAP .GTNUM ;MAKE REAL NUMBER TO DEPOSIT + MOV R1,(R3) + MOV (SP)+,R1 + RTS PC + +LAPTST: TRAP .GTNUM ;MAKE (R1) A REAL NUMBER + CMP R1,#TOP + BHI LAPERR + BIT #1,R1 ;MUST BE EVEN + BNE LAPERR + RTS PC +LAPERR: TRAP .ERROR + 2 + + +;SUBR - 1 ARG. CONVERTS LISP OBJECT IN R1 INTO A LISP NUMBER +MAKNUM: CLR R2 + JMP MAKNU1 + +;SUBR - 1 ARG. CONVERTS LISP # IN R1 INTO A REAL # IN R1 (,R2) +MUNKAM: TRAP .GTNUM + RTS PC + +.SBTTL LCOMPL UTILITY ROUTINES +;TRAP TO HERE WITH R5 HOLDING THE OBJECT DESIGNATING THE FUNCTION TO BE CALLED, +;R4 HOLDS TRAP INSTR +;CLOBBERS R4,R5, PLUS WHATEVER GETS CLOBBERED BY THE CALLED ROUTINE + +CALL: MOV R1,-(SP) + MOV R2,-(SP) + MOV R5,R1 + JSR PC,INRAN1 ;FUNCTION IN NODESPACE? + BLO CALERR ;IF NOT, IT AIN'T A FUNCTION + CMP (R1),#-1 ;ATOM? + BNE CALINT ;IF NOT, CALL THE INTERPRETER + MOV R4,-(SP) + MOV #FUNCTION,R2 + JSR PC,GET ;IS THE ATOM A FUNCTION? + BEQ CALIN1 ;NO => LET INTERPRETER GENERATE ERROR. + CMP R1,#LOCELL ;DEFINITION IS A LIST => MUST INTERPRET. + BHIS CALIN1 + BIT #1,R1 + BEQ CALL2 + DEC R1 ;IF IT'S AN FSUBR, MAKE IT EVEN, + CMP (R1),LIST ;AND SEE IF IT'S AN LSUBR. + BNE CALL2 + TST (R1)+ ;IF IT IS, ENTER IT AFTER THE TRAP .LSUBR. +CALL2: MOV (SP)+,R4 + MOV R1,R5 ;FOUND A SUBR DEFINITION; PUT ADDR IN R5 + MOV 4(SP),R2 ;PTR TO RETURN ADDR FOR THIS CALL + BIT #100,R4 ;CLOBBERABLE CALL? + BNE CALNOC + BIT #10,R4 ;WAS PRECEEDING MOV ***,R5 2 WDS LONG, OR JUST 1? + BEQ CALL1 + SUB #6,R2 ;2 WDS, GO BACK PAST THE CALL, TO THE MOV + MOV #NOOP,4(R2) ;AND NOOP OUT THE CALL + BR CALL5 + +CALL1: SUB #4,R2 ;1 WD, DITTO +CALL5: BIT #40,R4 ;JMP OR JSR? + BNE CALL3 ;CLOBBER THE MOV/CALL WITH ONE OR THE OTHER + MOV #JSRPC,(R2) + BR CALL4 + +CALL3: MOV #JMPTO,(R2) +CALL4: MOV R5,2(R2) ;ADDR OF SUBR, 2ND WORD OF THE JMP/JSR INSTRUCTION +CALNOC: MOV (SP)+,R2 + MOV (SP)+,R1 + BIT #40,R4 ;JMP OR JSR TO SUBR? + BEQ 1$ + TST (SP)+ ;IF THE SUBR IS "JMP'ED" TO,RETRN ADDR SHOULD BE FLUSHED +1$: JMP (R5) + +CALIN1: +CALINT: ;THIS INTERFACE ISN'T IMPLEMENTED YET +CALERR: TRAP .ERROR + 4 + +NOOP== BR ;BR .+2 +JMPTO== JMP+37 ;JMP @#... +JSRPC== JSR+737 ;JSR PC,@#... + +;CALLED BY JSR R5, WITH ATOM TO BE BOUND AT WORD FOLLOWING THE JSR (IE @ R5), +;BINDING VALUE AT 2(SP) +;BINDS THE ATOM TO THE VALUE + +BIND: MOV R1,-(SP) + MOV R2,-(SP) + MOV 6(SP),R1 + MOV (R5)+,R2 + JSR PC,XCONS + MOV ALIST,R2 + JSR PC,CONS + MOV R1,ALIST + MOV (SP)+,R2 + MOV (SP)+,R1 + RTS R5 + + +;CALLED WITH ATOM IN R1 +;RETURN ATOM'S VALUE IN R1 +EVATOM: MOV R2,-(SP) + MOV ALIST,R2 + JSR PC,ASSQA ;SEARCH ALIST + BNE 1$ ;IF BINDING CELL IS FOUND, RETURN ITS CDR + MOV 2(R1),R1 ;IF NOT FOUND THERE, GET ATOM'S VALUE CELL +1$: MOV 2(R1),R1 + MOV (SP)+,R2 + RTS PC + +.SBTTL USER SUBR SPACE + +%BPORG: 0 + + .=.+35000 ;SUBR SPACE + +.SBTTL SEVERAL VARIABLES + +FREEL: 0 ;PTR TO FREE LIST +FREEN: 0 ;NUMBER OF FREE CELLS AFTER GC +LOCELL: LSTSP ;BOTTOM OF FREE STORAGE. +HICELL: TOP-2 ;TOP OF FREE STORAGE +PROGPC: 0 ;PTR TO NEXT FORM TO EVAL +MARKSP: 0 ;SP AT ENTRY TO MARKL. +OUTTYP: 0 ;PRINT WITH "/"'S IF 0 . +OUTCSA: 0 ;-1 BEFORE OUTPUT 1ST CHAR OF ATOM. +APPLYF: 0 ;0 IF GOT TO APPLY FROM EVAL. +RDATL: 0 ;IN RDAT0M, -> 1ST UNUSED WD IN RDATBF. +.=<.+3>/4*4 +RDATBF: .=.+100 ;PNAME OF ATOM BEING READ IN. +RPTRA: 0 ;1ST CHAR OF NUMBER BEING READ IN. +INTTYP: 0 ;0 IF READ SHOULD INTERN. +ERRFLG: 0 ;PRINT ERROR MSGS IF NIL. +ERRSTK: TOPSTK ;PTR. TO STACK INSIDE INNERMOST ERRSET. +EXPLTY: 0 ;USE NUMBERS IF NON(). +EXPLP: 0 ;POINTS TO HEAD OF LIST OF CHARS. +OLNK: TOLNK ;0 ==> EXPLODE, TOLNK ==> TTY. +SILENT: 0 ;NONZERO STOPS OUTPUT +OUTPOS: 0 +CHRCT: 79.+1 +NXTCHR: 0 +ILNK: TILNK ;TILNK ==> TTY, 0 ==> MAKNAM. +.LIF EQ TS + TTYCHR: 0 ;LAST CHAR AT INTERRUPT LEVEL (0 IF NONE SINCE LAST READ) +THSCHR: 0 ;SAVE THIS CHAR IN CASE OF REREAD. +TKINTQ: 0 + + .SBTTL INITIAL LIST STRUCTURE + +GCTLEN==<_-5>&3777 ; LENGTH OF GC TABLE +GCTLEN==/2*2 ; MAKE EVEN + +GCBTAB: .BLKB GCTLEN ; TABLE OF MARK BITS FOR GC + .=<.+3>/4*4 + +LSTSP==. ; PTR TO START OF FREE STORAGE + ; PURE LIST STRUCTURE STORED HERE + + +;MACRO TO CREATE ATOM: A-NAME, B-VALUE, C-LABEL ON HEADER. +.MACRO .ATM PNAME,VALUE,H,PROPL +PNMPTR==. + .ASCII ŠNAMEŠ .=<.+3>/4*4 +.IIF EQ <.-PNMPTR>, 0,0 +.REPT <.-PNMPTR>/4-1 + PNMPTR+1,.+2 + PNMPTR==PNMPTR+4 +.ENDR + PNMPTR+1,0 +ATMPTR==. +H -1,.+2 ;ATOM HEADER. + .+4 +VALUE ; VALUE CELL HERE. + PNMPTR+4,PROPL+0 ; PROPERTY LIST +.ENDM .ATM + + +.MACRO .ATOM PNAME,VALUE,H,PROPL +.NLIST +.ATM PNAME,VALUE,H,PROPL + ATMPTR,OBLSPT ; OBLIST LINK HERE. + OBLSPT==.-4 +.LIST +.ENDM .ATM + +.MACRO .SUBR A +.NLIST + .WORD FUNCTION,A +PLPTR==. + .WORD .-4,0 +.ATOM A,-1,,PLPTR +.LIST +.ENDM .SUBR + +.MACRO .FSUBR A +.NLIST + .WORD FUNCTION,A+1 +PLPTR==. + .WORD .-4,0 +.ATOM A,-1,,PLPTR +.LIST +.ENDM .FSUBR + +OBLSPT==0 ;PTR TO OBLIST-SO-FAR, INITIALLY NIL + +ERRM: .WORD .+4,0 + .WORD QUOTE,.+2 +ERRC: .WORD 0,0 + +;TABLE OF ERROR MESSAGES +ERRT: .WORD 1$ + .WORD 2$ + .WORD 3$ + .WORD 4$ + .WORD 5$ + .WORD 6$ + .WORD 7$ + .WORD 8$ + .WORD 9$ + + .=<.+3>/4*4 + .ATM ^"OUT OF STORAGE",-1,1$: + .ATM ^"BAD NUMBER",-1,2$: + .ATM ^"FUNCTION ERROR",-1,3$: + .ATM ^"TOO FEW ARGS",-1,4$: + .ATM ^"TOO MANY ARGS",-1,5$: + .ATM ^"NON NUMERIC ARG",-1,6$: + .ATM ^"UNDEFINED VARIABLE",-1,7$: + .ATM ^"ATOMIC SYMBOL REQUIRED",-1,8$: + .ATM ^"QUIT",-1,9$: + +QOTPLST:.WORD .+4,0 ;PLIST OF ATOMS QUOTE AND FUNCTION. + .WORD FUNCTION,CAR+1 + + .=<.+77>/100*100 ; MOVE TO ADDR DIVIS BY 100. + IMPLSP==. ; SAVE PTR TO BOTTOM OF IMPURE + ; (GCABLE) LIST SPACE + + .SBTTL INITIAL OBLIST + + .atom ,-1,args: + .atom ,gename: 2$ +2$: '0+1, .+2 + '0+1, .+2 + '0+1, .+2 + '0+1, .+2 + 'G+1,0 + .atom -,$minus:0 + .atom +,$plus:0,.p: + .atom *,$star:0,star: + .subr add1 + .fsubr and + .atom alist,alist:0 + .subr apply + .subr arg + .subr assq + .subr atom + .subr boundp + .atom bporg,<1$+1> +1$: .word 0,%bporg + .subr caar + .subr cadr + .subr car + .subr cdar + .subr cddr + .subr cdr + .fsubr cond + .subr cons + .fsubr defun + .subr dela + .subr delq + .subr deposit + .fsubr difference + .subr eq + .subr equal + .subr err + .fsubr error + .subr errset + .subr eval + .subr examine + .subr explode + .atom funarg,-1,funarg: + .fsubr funcall + .atom function,-1,function:,qotplst + .subr gc + .subr genset + .subr gensym + .subr get + .subr go + .fsubr greaterp + .subr implode + .subr intern + .atom lambda,-1,lambda: + .atom lapsyms,3$ +3$: .+5, .+6 + 0, ALIST + .+5, .+6 + 0, ARGS + .+5, .+6 + 0, BIND + .+5, .+6 + 0, EVATOM + .+5, .+6 + 0, MAKNUM + .+5, 0 + 0, T + .subr last + .subr length + .fsubr lessp + .atom lexpr,-1,lexpr: + .atom linel,linel:79.+1 + .fsubr list + .subr maknum + .subr member + .subr minusp + .subr munkam + .subr nconc + .subr ncons + .atom nil,0 + .atom nlambda,-1,nlambda: + .subr not + .subr nreverse + .subr null + .subr numberp + .atom oblist,oblist:0,obpcel: + .fsubr or + .subr plist + .fsubr plus + .subr plusp + .subr pnget + .subr pnput + .subr prin1 + .subr princ + .subr print + .fsubr prog + .subr prog2 + .subr putprop + .subr quit + .atom quote,-1,quote:,qotplst + .fsubr quotient + .subr read + .subr remainder + .subr remob + .subr remprop + .subr return + .subr reverse + .subr rplaca + .subr rplacd + .subr samenamep + .subr set + .subr seta + .fsubr setq + .subr setplist + .subr sub1 + .atom t,t,t: + .subr terpri + .fsubr times + .subr tyi + .subr tyo +.if eq ts-sits + .subr uread + .subr uwrite +.endc + .subr xcons + .subr zerop + +.=OBLIST + OBLSPT ; STORE PTR TO COMPLETE OBLIST + +.=TOP-2 + .WORD -1 ; SO SITS LOADER WILL ALLOCATE THIS HIGH + + +.END BEG