--- /dev/null
+TITLE EVAL -- MUDDLE EVALUATOR
+
+RELOCATABLE
+
+; GERALD JAY SUSSMAN, 1971
+
+.GLOBAL PROCID,LPROG,GLOBSP,GLOBASE,SPBASE,TPBASE,PTIME
+.GLOBAL IGVAL,CHKARG,SWAP,NXTDCL,TPOVFL,CHFRM
+.GLOBAL ILVAL,CALER,CALER1,ER1ARG,SPECBIND,SPECSTORE,WRONGT,ERRTMA
+.GLOBAL IDVAL,EVECTO,EUVECT,CHARGS
+
+.INSRT MUDDLE >
+
+ MFUNCTION EVAL,SUBR
+ INTGO
+ HLRZ A,AB ;GET NUMBER OF ARGS
+ CAIE A,-2 ;EXACTLY 1?
+ JRST AEVAL ;EVAL WITH AN ALIST
+ HLRZ A,(AB) ;GET TYPE OF ARG
+ CAILE A,NUMPRI ;PRIMITIVE?
+ JRST NONEVT ;NO
+ JRST @EVTYPT(A) ;YES-DISPATCH
+
+SELF: MOVE A,(AB) ;TYPES WHICH EVALUATE
+ MOVE B,1(AB)
+ JRST FINIS ;TO SELF-EG NUMBERS
+
+;EVALUATES A IDENTIFIER -- GETS LOCAL VALUE IF THERE IS ONE, OTHERWISE GLOBAL.
+
+MFUNCTION VALUE,SUBR
+ JSP E,CHKAT
+ PUSHJ P,IDVAL
+ JRST FINIS
+
+IDVAL: PUSH TP,A
+ PUSH TP,B ;SAVE ARG IN CASE NEED TO CHECK GLOBAL VALUE PUSHJ P,ILVAL ;LOCAL VALUE FINDER
+ CAME A,$TUNBOUND ;IF NOT UNBOUND OR UNASSIGNED
+ JRST RIDVAL ;DONE - CLEAN UP AND RETURN
+ JUMPN B,UNAS ;IF UNASSIGNED - ERROR
+ POP TP,B ;GET ARG BACK
+ POP TP,A
+ PUSHJ P,IGVAL
+ CAMN A,$TUNBOUND
+ JRST UNBOU
+ POPJ P,
+RIDVAL: SUB TP,[2,,2]
+ POPJ P,
+
+
+;GETS THE LOCAL VALUE OF AN IDENTIFIER
+
+MFUNCTION LVAL,SUBR
+ JSP E,CHKAT
+ PUSHJ P,ILVAL
+ CAME A,$TUNBOUND
+ JRST FINIS
+ JUMPN B,UNAS
+ JRST UNBOU
+
+\f
+; GETS A LOCATIVE TO THE LOCAL VALUE OF AN IDENTIFIER.
+
+MFUNCTION LLOC,SUBR
+ JSP E,CHKAT
+ PUSHJ P,ILOC
+ CAMN A,$TUNBOUND
+ JRST UNBOU
+ MOVSI A,TLOCD
+ HRR A,2(B)
+ JRST FINIS
+
+;TESTS TO SEE IF AN IDENTIFIER IS LOCALLY BOUND
+
+MFUNCTION BOUND,SUBR,[BOUND?]
+ JSP E,CHKAT
+ PUSHJ P,ILVAL
+ CAMN A,$TUNBOUND
+ JUMPE B,IFALSE
+ JRST TRUTH
+
+;TESTS TO SEE IF AN IDENTIFIER IS LOCALLY ASSIGNED
+
+MFUNCTION ASSIGP,SUBR,[ASSIGNED?]
+ JSP E,CHKAT
+ PUSHJ P,ILVAL
+ CAME A,$TUNBOUND
+ JRST TRUTH
+ JUMPE B,UNBOU
+ JRST IFALSE
+
+;GETS THE GLOBAL VALUE OF AN IDENTIFIER
+
+MFUNCTION GVAL,SUBR
+ JSP E,CHKAT
+ PUSHJ P,IGVAL
+ CAMN A,$TUNBOUND
+ JRST UNAS
+ JRST FINIS
+
+;GETS A LOCATIVE TO THE GLOBAL VALUE OF AN IDENTIFIER
+
+MFUNCTION GLOC,SUBR
+ JSP E,CHKAT
+ PUSHJ P,IGLOC
+ CAMN A,$TUNBOUND
+ JRST UNAS
+ MOVSI A,TLOCD
+ JRST FINIS
+
+;TESTS TO SEE IF AN IDENTIFIER IS GLOBALLY ASSIGNED
+
+MFUNCTION GASSIG,SUBR,[GASSIGNED?]
+ JSP E,CHKAT
+ PUSHJ P,IGVAL
+ CAMN A,$TUNBOUND
+ JRST IFALSE
+ JRST TRUTH
+
+\f
+
+CHKAT: ENTRY 1
+ HLLZ A,(AB)
+ CAME A,$TATOM
+ JRST NONATM
+ MOVE B,1(AB)
+ JRST 2,(E)
+
+;EVALUATE A FORM. IF CAR IS AN ATOM USE GLOBAL VALUE OVER LOCAL ONE.
+
+EVFORM: SKIPN C,1(AB) ;EMPTY?
+ JRST IFALSE
+ HLLZ A,(C) ;GET CAR TYPE
+ CAME A, $TATOM ;ATOMIC?
+ JRST EV0 ;NO -- CALCULATE IT
+ MOVE B,1(C) ;GET PTR TO ATOM
+ PUSHJ P,IGVAL
+ CAMN A,$TUNBOUND
+ JRST LFUN
+ PUSH TP,A
+ PUSH TP,B
+ JRST IAPPLY ;APPLY IT
+EV0: PUSH TP,A ;SET UP CAR OF FORM AND
+ PUSH TP,1(C)
+ JSP E,CHKARG
+ MCALL 1,EVAL ;EVALUATE IT
+ PUSH TP,A ;APPLY THE RESULT
+ PUSH TP,B ;AS A FUNCTION
+ JRST IAPPLY
+
+LFUN: MOVE B,1(AB)
+ PUSH TP,$TATOM
+ PUSH TP,1(B)
+ MCALL 1,VALUE
+ PUSH TP,A
+ PUSH TP,B
+ JRST IAPPLY
+
+;DISPATCH TABLE FOR EVAL
+DISTBL EVTYPT,SELF,[[TLIST,EVLIST],[TFORM,EVFORM],[TVEC,EVECT],[TSEG,ILLSEG],[TUVEC,EUVEC]]
+
+\f
+
+;WATCH FOR SUBTLE BUG 43 LERR,LPROG OR PROCID
+AEVAL:
+ CAIE A,-4 ;EXACTLY 2 ARGS?
+ JRST WNA ;NO-ERROR
+ HLRZ A,2(AB) ;CHECK THAT WE HAVE A FRAME
+ CAIN A,TFRAME
+ JRST .+3
+ CAIE A,TENV
+ JRST WTYP
+ MOVE A,3(AB)
+ HRRZ D,2(AB) ;GET POINTER TO PV DOPE WORD
+ PUSHJ P,SWAPQ ;SEE IF SWAP NECESSARY
+ PUSH TP,(D)
+ PUSH TP,1(D)
+ MCALL 1,EVAL ;NOW DO NORMAL EVALUATION
+UNSWPQ: MOVE D,1(TB) ;GET SAVED PVP
+ CAMN D,PVP ;CHANGED?
+ JRST FINIS ;NO - RETURNî PUSHJ P,SPECSTORE ;CLEAN UP
+ MOVE D,1(TB)
+ JSP C,SWAP
+ JRST FINIS
+
+
+; ROUTINE TO CHANGE PROCID AND POSSIBLY SWAP
+
+SWAPQ: HLRZ C,(D) ;GET LENGTH
+ SUBI D,-1(C) ;POINT TO START OF PV
+ MOVNS C ;NEGATE LENGTH
+ HRLI D,2(C) ;MAKE AOBJN POINTER
+ MOVE E,PVP ;COPY CURRENT PROCESS VECTOR
+ POP P,B ;GET RET ADR SO POPJ WINS IF SWAP OCCURS
+ CAME D,PVP ;IS THIS IT?
+ JSP C,SWAP ;NO, SWAP IN NEW PROCESS
+ PUSH P,B ;NOW, PUT IT BACK
+ PUSH TP,$TPVP ;SAVE PROCESS
+ PUSH TP,E
+ HLL B,OTBSAV(A) ;GET TIME FROM FRAME POINTED AT
+ HRR B,A
+ HRRZ C,A
+ CAIG C,1(TP)
+ CAME B,A ;CHECK THAT THE FRAME IS LEGIT
+ JRST ILLFRA
+ HLRZ C,FSAV(C)
+ CAIE C,TENTRY
+ JRST ILLFRA
+ CAMN SP,SPSAV(A)
+ JRST AEV1
+ MOVE SP,SPSAV(A) ;LOAD UP OLD ENVIRONMENT
+ MOVE A,PVP
+ ADD A,[PROCID,,PROCID] ;GET LOCATIVE TO PROCESS ID
+ PUSH TP,BNDV ;BIND IT TO
+ PUSH TP,A
+ AOSN A,PTIME ;A UNIQUE NUMBER
+ .VALUE [ASCIZ /TIMEOUT/]
+ PUSH TP,$TFIX
+ PUSH TP,A
+ PUSHJ P,SPECBIND
+AEV1: MOVE E,1(TB) ;GET SAVED PROCESS
+ MOVE D,AB ;COPY CURRENT ARG POINTER
+ CAME E,PVP ;HAS PROCESS CHANGED?
+ MOVE D,ABSTO+1(E) ;GET SAV AB
+ POPJ P, ;RETURN TO CALLER
+
+\f
+; STACKFRAME FUNCTION (MUDDLE'S ANSWER TO APPLY)
+
+ MQUOTE STACKFORM
+
+STFRM2: JRST NOENV ;FAKE OUT ENTRY
+
+MFUNCTION STACKFORM,FSUBR
+
+ ENTRY 1
+
+ GETYP A,(AB) ;CHECK IT IS A LIST
+ CAIE A,TLIST
+ JRST WTYP ;NO, LOSE
+
+ MOVEI A,3 ;CHECK ARG HAS AT LEAST 3 ELEMENTS
+ HRRZ B,1(AB) ;GET ARG
+ JUMPE B,TFA
+ HRRZ B,(B) ;CDR IT
+ SOJN A,.-2 ;AND COUNT
+
+ JUMPE B,NOENV ;ENVIRONMENT NOT SUPPLIED
+ HRRZ A,(B) ;CHECK NOT TOO MANY
+ JUMPN A,TMA
+
+ GETYP A,(B) ;GET TYPE OF LAST ARG
+ MOVSI A,(A) ;TYPE TO LH
+ PUSH TP,A
+ PUSH TP,1(B) ;PUSH THE ARG
+ JSP E,CHKARG ;CHECK FOR DEFERRED
+ MCALL 1,EVAL
+ HLRZ C,A ;ISOLATE TYPE IN C
+ CAIE C,TENV ;ENVIRONEMNT?
+ CAIN C,TFRAME ;OR FRAME?
+ JRST .+2
+ JRST WTYP
+
+
+ MOVEI D,(A) ;IN B AND D
+ MOVE A,B ;AND TIME,,FRAME
+ PUSHJ P,SWAPQ ;AND CHECK FOR CHANGE
+ PUSH TP,$TLIST ;SAVE THE ARG
+ PUSH TP,1(D) ;ON TP
+ .MCALL 1,STFRM2 ;NOW CALL NON-ENV STACKFORM
+ JRST UNSWPQ ;AND POSSIBLY UNSWAP
+
+NOENV: HRRZ D,1(AB) ;GET POINTER TO FIRST
+ GETYP A,(D) ;GET TYPE
+ MOVSI A,(A)
+ PUSH TP,A
+ PUSH TP,1(D) ;PUSH THE ARG, (IT SHOULD BE A FUNCTION)
+ JSP E,CHKARG ;CHECK OUT DEFERRED
+ MCALL 1,EVAL ;EVAL IT
+ HRRZ C,1(AB) ;RESTORE ARG
+ HRRZ D,(C) ;POINT TO LIST OF FORMS
+ PUSH TP,A ;SAVE FUNCTION
+ PUSH TP,B
+ HLRZS A ;NOW DISPATCH ON TYPE
+ CAIN A,TSUBR;SUBR?
+ JRST STSUBR ;YES, HACK IT
+ CAIN A,TEXPR ;FUNCTION?
+ JRST STEXPR ;YES DO IT
+ CAIN A,TFUNARG ;FUNARG
+ JRST NOTIMP
+ JRST NAPT
+
+\f
+; STACK FORM OF A SUBR
+
+STSUBR: PUSH P,[0] ;PUSH ARG COUNTER
+
+STLOO: PUSHJ P,EVALRG ;EVAL THE ARGUMENT
+ JRST MAKPTR ;DONE, FALL INTO EVAL CODE
+ AOS (P) ;COUNT
+ PUSH TP,A
+ PUSH TP,B ;SAVE THE ARGS
+ JRST STLOO
+
+; STACK FRAME OF EXPR
+
+STEXPR: MOVE C,(TP) ;GET FUNCTION
+ PUSHJ P,BINDRS ;BIND THE ARGS
+ JRST APEXP1 ;JOIN COMMON CODE
+
+\f
+
+IAPPLY:
+ HLRZ A,(TB) ;GET TYPE OF FUNCTION
+ CAIN A,TSUBR ;SUBR?
+ JRST APSUBR ;YES
+ CAIN A,TFSUBR ;NO -- FSUBR?
+ JRST APFSUBR ;YES
+ CAIN A,TEXPR ;NO -- EXPR?
+ JRST APEXPR ;YES
+ CAIN A,TFIX ;NO -- CALL TO NTH?
+ JRST APNUM ;YES
+ CAIN A,TFUNARG ;NO -- FUNARG?
+ JRST APFUNARG ;YES
+ CAIN A,TPVP ;NO -- PROCESS TO BE RESUMED?
+ JRST RESOMER ;YES
+ JRST NAPT ;NONE OF THE ABOVE
+
+
+;APFSUBR CALLS FSUBRS
+
+APFSUBR:
+ PUSH TP,$TLIST ;GET THE
+ HRRZ A,@1(AB)
+ PUSH TP,A ;ARGUMENT LIST
+ MCALL 1,@1(TB)
+ JRST FINIS
+
+;APSUBR CALLS SUBRS
+
+APSUBR:
+ HRRZ A,@1(AB) ;GET CDR OF FORM -- ARGLIST
+ PUSH TP,$TLIST ;SAVE THE ARGLIST ON
+ PUSH TP,A ;THE TP
+ PUSH P,[0] ;MAKE SLOT FOR ARGCNT
+TUPLUP:
+ SKIPN A,3(TB) ;IS IT NIL?
+ JRST MAKPTR ;YES -- DONE
+ PUSH TP,(A) ;NO -- GET CAR OF THE
+ HLLZS (TP) ;ARGLIST
+ PUSH TP,1(A)
+ JSP E,CHKARG
+ MCALL 1,EVAL ;AND EVAL IT.
+ PUSH TP,A ;SAVE THE RESULT IN
+ PUSH TP,B ;THE GROWING TUPLE
+ AOS (P) ;BUMP THE ARGCNT
+ HRRZ A,@3(TB) ;SET THE ARGLIST TO
+ MOVEM A,3(TB) ;CDR OF THE ARGLIST
+ JRST TUPLUP
+MAKPTR:
+ POP P,A
+ ACALL A,@1(TB)
+ JRST FINIS
+
+\f
+
+;APNUM INTERPRETS NUMBERS AS CALL TO FUNCTION GET
+
+APNUM:
+ HRRZ A,@1(AB) ;GET ARGLIST
+ JUMPE A,ERRTFA ;NO ARGUMENT
+ PUSH TP,(A) ;GET CAR OF ARGL
+ HLLZS (TP)
+ PUSH TP,1(A)
+ HRRZ A,(A) ;MAKE SURE ONLY ONE ARG
+ JUMPN A,ERRTMA
+ JSP E,CHKARG ;HACK DEFERRED
+ MCALL 1,EVAL
+ PUSH TP,A
+ PUSH TP,B
+ PUSH TP,(TB)
+ PUSH TP,1(TB)
+ MCALL 2,NTH
+ JRST FINIS
+
+;APEXPR APPLIES EXPRS
+;EXPRESSION IS IN 0(AB), FUNCTION IS IN 0(TB)
+
+APEXPR:
+
+ SKIPN C,1(TB) ;BODY?
+ JRST NOBODY ;NO, ERROR
+ HRRZ 0,1(AB) ;GET EXPRESSION INTO 0
+ HRRZ D,@0 ;AND ARGLIST INTO D
+ HLL 0,(AB) ;TYPE TO LH OF 0
+
+ PUSHJ P,BINDER ;DO THE BINDINGS
+
+APEXP1: HRRZ C,@1(TB) ;GET BODY BACK
+ JUMPE A,DOPROG ;NOW GO RUN IF NO ACTIVIATION
+ PUSH TP,$TLIST ;SAVE ANOTHER COPY FOR REACT
+ PUSH TP,C
+ SKIPL A ;SKIP IF NOT NAME ALA HEWITT
+ HRRZ C,(C) ;ELSE CDR AGAIN
+ JRST DOPROG
+
+\f
+
+RESOMER:
+; 0,1(TB) IS PROCESS VECTOR POINTER TO PROCESS TO BE RESUMED
+; 0,1(AB) IS A FORM CONTAINING ARGS TO SAVED FUNTION
+
+ MOVE D,1(TB) ;GET PVP OF PROCESS TO BE RESUMED
+ GETYP A,RESFUN(D) ; GET TYPE OF FUNCTION
+
+ CAIN A,TSUBR ;SUBR?
+ JRST RESSUBR ;YES
+ CAIN A,TFSUBR ;NO -- FSUBR?
+ JRST RESFSUBR ;YES
+ CAIN A,TEXPR ;NO -- EXPR?
+ JRST RESEXPR ;YES
+ CAIN A,TFIX ;NO -- CALL TO NTH?
+ JRST RESNUM ;YES
+ CAIN A,TFUNARG ;NO -- FUNARG?
+ JRST NOTIMP ;YES
+ JRST NAPT ;NONE OF THE ABOVE
+
+
+;RESFSUBR RESUMES FSUBRS
+
+RESFSUBR:
+ HRRZ A,@1(AB) ;GET THE ARG LIST
+ SUB TP,[2,,2] ;CLEAN UP
+ JSP C,SWAP ;SWAP IN NEW PROCESS
+ PUSH TP,$TLIST
+ PUSH TP,A ; PUSH THE ARG LIST
+ MCALL 1,@RESFUN+1(PVP) ; RESUME WITH THE SAVED FUNCTION
+ JRST FINIS
+
+;RESSUBR RESUMES SUBRS
+
+RESSUBR:
+ HRRZ A,@1(AB) ;GET CDR OF FORM -- ARGLIST
+ PUSH TP,$TLIST ;SAVE THE ARGLIST ON
+ PUSH TP,A ;THE TP
+ PUSH P,[0] ;MAKE SLOT FOR ARGCNT
+RESTUPLUP:
+ SKIPN A,3(TB) ;IS IT NIL?
+ JRST RESMAKPTR ;YES -- DONE
+ PUSH TP,(A) ;NO -- GET CAR OF THE
+ HLLZS (TP) ;ARGLIST
+ PUSH TP,1(A)
+ JSP E,CHKARG
+ MCALL 1,EVAL ;AND EVAL IT.
+ MOVE D,1(TB) ;GET PVP OF P.T.B.R.
+ MOVE C,TPSTO+1(D) ;GET TP OF P.T.B.R.
+ PUSH C,A ;SAVE THE RESULT IN THE GROWING
+ PUSH C,B ;TUPLE OF ARGS IN P.T.B.R.
+ MOVEM C,TPSTO+1(D) ;UPDATE TP OF P.T.B.R.
+ AOS (P) ;BUMP THE ARGCNT
+ HRRZ A,@3(TB) ;SET THE ARGLIST TO
+ MOVEM A,3(TB) ;CDR OF THE ARGLIST
+ JRST RESTUPLUP
+RESMAKPTR:
+ POP P,A ;GET NUMBER OF ARGS IN A
+ MOVE D,1(TB) ;GET PVP OF P.T.B.R.
+ SUB TP,[4,,4] ;GET RID OF GARBAGE
+ JSP C,SWAP ;SWAP IN THE NEW PROCESS
+ ACALL A,RESFUN+1(PVP) ;CALL THE SAVED FUNCTION
+ JRST FINIS
+
+
+
+;RESNUM INTERPRETS NUMBERS AS CALL TO FUNCTION GET
+
+RESNUM:
+ HRRZ A,@1(AB) ;GET ARGLIST
+ JUMPE A,ERRTFA ;NO ARGUMENT
+ PUSH TP,(A) ;GET CAR OF ARGL
+ HLLZS (TP)
+ PUSH TP,1(A)
+ HRRZ A,(A) ;MAKE SURE ONLY ONE ARG
+ JUMPN A,ERRTMA
+ JSP E,CHKARG ;HACK DEFERRED
+ MCALL 1,EVAL
+ MOVE D,1(TB) ;GET PVP OF P.T.B.R.
+ MOVE C,TPSTO+1(D) ;GET TP OF P.T.B.R.
+ PUSH C,A ;PUSH ARG
+ PUSH C,B
+ SUB TP,[2,,2] ;CLEAN UP BEFORE LEAVING
+ JSP C,SWAP ;BRING IN NEW PROCESS
+ PUSH TP,RESFUN(PVP) ;PUSH NUMBER
+ PUSH TP,RESFUN+1(PVP)
+ MCALL 2,NTH
+ JRST FINIS
+
+;RESEXPR RESUMES EXPRS
+;EXPRESSION IS IN 0(AB), FUNCTION IS IN RESFUN(PVP)
+RESEXPR:
+ SKIPN C,RESFUN+1(D);BODY?
+ JRST NOBODY ;NO, ERROR
+
+ MOVE C,TPSTO+1(D) ;GET TP OF P.T.B.R.
+ PUSH C,BNDA ;SPECIAL ATOM CROCK
+ PUSH C,MQUOTE [PPROC ]INTERR ;PPROC=PARENT PROCESS
+ MOVE B,OTBSAV(TB)
+ PUSHJ P,MAKENV ;MAKE ENVIRONMENT FOR THIS PROCESS
+ PUSH C,A
+ PUSH C,B
+ MOVEM C,TPSTO+1(D) ;UPDATE TP OF P.T.B.R.
+ HRRZ 0,1(AB) ;GET EXPRESSION INTO 0
+ HRRZ A,@0 ;AND ARGLIST INTO A
+ HLL 0,(AB) ;TYPE TO LH OF 0
+ SUB TP,[2,,2] ;CLEAN UP BEFORE LEAVING
+ JSP C,SWAP ;SWAP IN NEW PROCESS
+ PUSH P,0 ;SAVE 0
+ PUSH P,A ;SAVE A=ARGLIST
+ PUSH TP,[0]
+ PUSH TP,[0] ;COMPLETE ARGS FOR PPROC BINDING
+ PUSHJ P,SPECBIND ;BIND THE PARENT PROCESS
+ POP P,D ;POP ARGLIST INTO D
+ POP P,0 ;POP CALL HACK INTO 0
+ MOVE C,RESFUN+1(PVP) ;GET FUNCTION
+ PUSHJ P,BINDRR ;CALL BINDER FOR RESUMED EXPR HACKING
+
+ HRRZ C,@RESFUN+1(PVP) ;GET BODY BACK
+ JUMPE A,DOPROG ;NOW GO RUN IF NO ACTIVIATION
+ PUSH TP,$TLIST ;SAVE ANOTHER COPY FOR REACT
+ PUSH TP,C
+ SKIPL A ;SKIP IF NOT NAME ALA HEWITT
+ HRRZ C,(C) ;ELSE CDR AGAIN
+ JRST DOPROG
+
+\f
+; EVALUATE LISTS, VECTORS, UNIFROM VECTORS
+
+EVLIST: PUSH P,[-1] ;-1 -- THIS IS A LIST
+ JRST EVL1 ;GO TO HACKER
+
+EVECT: PUSH P,[0] ;0 -- THIS IS A GENERAL VECTOR
+ JRST EVL1
+
+EUVEC: PUSH P,[1] ;1 -- THIS IS A UNIFORM VECTOR
+
+EVL1: PUSH P,[0] ;PUSH A COUNTER
+ GETYPF A,(AB) ;GET FULL TYPE
+ PUSH TP,A
+ PUSH TP,1(AB) ;AND VALUE
+
+EVL2: INTGO ;CHECK INTERRUPTS
+ SKIPN A,1(TB) ;ANYMORE
+ JRST EVL3 ;NO, QUIT
+ SKIPL -1(P) ;SKIP IF LIST
+ JUMPG A,EVL3 ;JUMP IF VECTOR EMPTY
+ GETYPF B,(A) ;GET FULL TYPE
+ SKIPGE C,-1(P) ;SKIP IF NOT LIST
+ HLLZS B ;CLOBBER CDR FIELD
+ JUMPG C,EVL7 ;HACK UNIFORM VECS
+EVL8: PUSH P,B ;SAVE TYPE WORD ON P
+ CAMN B,$TSEG ;SEGMENT?
+ MOVSI B,TFORM ;FAKE OUT EVAL
+ PUSH TP,B ;PUSH TYPE
+ PUSH TP,1(A) ;AND VALUE
+ MCALL 1,EVAL ;AND EVAL IT
+ POP P,C ;AND RESTORE REAL TYPE
+ CAMN C,$TSEG ;SEGMENT?
+ JRST DOSEG ;YES, HACK IT
+ AOS (P) ;COUNT ELEMENT
+ PUSH TP,A ;AND PUSH IT
+ PUSH TP,B
+EVL6: SKIPGE A,-1(P) ;DONT SKIP IF LIST
+ HRRZ B,@1(TB) ;CDR IT
+ JUMPL A,ASTOTB ;AND STORE IT
+ MOVE B,1(TB) ;GET VECTOR POINTER
+ ADD B,AMNT(A) ;INCR BY APPROPRIATE AMOUNT
+ASTOTB: MOVEM B,1(TB) ;AND STORE BACK
+ JRST EVL2 ;AND LOOP BACK
+
+AMNT: 2,,2 ;INCR FOR GENERAL VECTOR
+ 1,,1 ;SAME FOR UNIFORM VECTOR
+
+CHKARG: GETYP A,-1(TP)
+ CAIE A,TDEFER
+ JRST (E)
+ HRRZS (TP) ;MAKE SURE INDIRECT WINS
+ MOVE A,@(TP)
+ MOVEM A,-1(TP) ;CLOBBER IN TYPE SLOT
+ MOVE A,(TP) ;NOW GET POINTER
+ MOVE A,1(A) ;GET VALUE
+ MOVEM A,(TP) ;CLOBBER IN
+ JRST (E)
+
+\f
+
+EVL7: HLRE C,A ;FIND TYPE OF UVECTOR
+ SUBM A,C ;C POINTS TO DOPE WORD
+ GETYP B,(C) ;GET TYPE
+ MOVSI B,(B) ;TO LH NOW
+ SOJA A,EVL8 ;AND RETURN TO DO EVAL
+
+EVL3: SKIPL -1(P) ;SKIP IF LIST
+ JRST EVL4 ;EITHER VECTOR OR UVECTOR
+
+ MOVEI B,0 ;GET A NIL
+EVL9: MOVSI A,TLIST ;MAKE TYPE WIN
+EVL5: SOSGE (P) ;COUNT DOWN
+ JRST FINIS ;DONE, RETURN
+ PUSH TP,$TLIST ;SET TO CALL CONS
+ PUSH TP,B
+ MCALL 2,CONS
+ JRST EVL5 ;LOOP TIL DONE
+
+
+EVL4: MOVEI B,EUVECT ;UNIFORM CASE
+ SKIPG -1(P) ;SKIP IF UNIFORM CASE
+ MOVEI B,EVECTO ;NO, GENERAL CASE
+ POP P,A ;GET COUNT
+ .ACALL A,(B) ;CALL CREATOR
+ JRST FINIS
+
+; PROCESS SEGMENTS FOR THESE HACKS
+
+DOSEG: MOVEM A,BSTO(PVP) ;WILL BECOME INTERRUPTABLE WITH GOODIE IN B
+ HLRZS A ;TYPE TO RH
+ PUSHJ P,SAT ;GET STORAGE TYPE
+
+ CAIN A,S2WORD ;LIST?
+ JRST LSTSEG
+ CAIN A,S2NWORD ;GENERAL VECTOR?
+ JRST VECSEG
+ CAIN A,SNWORD ;UNIFORM VECTOR?
+ JRST UVCSEG
+ CAIE A,SARGS ;ARGS TUPLE?
+ JRST ILLSEG ;NO, ERROR
+
+ PUSH TP,BSTO(PVP) ;PREPARE TO CHECK ARGS
+ PUSH TP,B
+ SETZM BSTO(PVP) ;TYPE NOT SPECIAL
+ MOVEI B,-1(TP) ;POINT TO SAVED COPY
+ PUSHJ P,CHARGS ;CHECK ARG POINTER
+ POP TP,B ;AND RESTORE WINNER
+ POP TP,BSTO(PVP) ;AND TYPE AND FALL INTO VECTOR CODE
+
+VECSEG: PUSH P,[2,,2] ;PUSH AMOUNT TO BUMP
+ JRST SEG1 ;AND JOIN COMMON CODE
+
+UVCSEG: PUSH P,[1,,1] ;AMOUNT FOR UVECTS
+ JRST SEG1
+
+\f
+
+LSTSEG: SKIPL -1(P) ;SKIP IF IN A LIST
+ JRST SEG3 ;ELSE JOIN COMMON CODE
+ HRRZ C,@1(TB) ;CHECK FOR END OF LIST
+ JUMPN C,SEG3 ;NO, JOIN COMMON CODE
+ SETZM BSTO(PVP) ;CLOBBER SAVED GOODIES
+ JRST EVL9 ;AND FINISH UP
+\f
+
+
+
+SEG3: PUSH P,[0] ;AMOUNT OF ADDING FOR LIST
+SEG1: INTGO ;CHECK OUT INTERRUPTS
+ JUMPE B,SEG2 ;DONE?
+ SKIPE C,(P) ;CHECK IF LIST OR VECTOR
+ JUMPG B,SEG2 ;END OF VECTOR
+ CAMN C,[1,,1] ;SKIP IF NOT UNIFORM
+ JRST SEG5 ;HACK UNIFORM SEGMENT
+ GETYPF A,(B) ;GET NEXT TYPE
+ SKIPGE -2(P) ;SKIP IF NOT LIST
+ HLLZS A ;CLEAR CDR
+ MOVE C,1(B) ;GET VALUE
+SEG4: PUSH TP,A ;PUSH TYPE
+ PUSH TP,C
+ PUSH P,B ;CAN USE P BECAUSE CHKARG NOT INTERRUPTABLE
+ JSP E,CHKARG ;CHECK OUT TDEFER
+ POP P,B ;RESTORE
+ SKIPG (P) ;SKIP IF NOT LIST
+ HRRZ B,(B) ;CDR THE LIST
+ ADD B,(P) ;AND BUMP IT
+ AOS -1(P) ;BUMP COUNT
+ JRST SEG1 ;AND DO IT AGAIN
+
+SEG2: SETZM BSTO(PVP) ;CLOBBER TYPE BACK
+ SUB P,[1,,1] ;POP OFF LOSSAGE
+ JRST EVL6
+
+SEG5: HLRE C,B ;FIND TYPE
+ SUBM B,C ;POINT TO DOPE WORD
+ GETYP A,(C) ;GET TYPE
+ MOVSI A,(A) ;TO LH
+ MOVE C,(B) ;NOW GET VALUE
+ JRST SEG4
+
+\f
+
+;APFUNARG APPLIES OBJECTS OF TYPE FUNARG
+
+APFUNARG:
+ HRRZ A,@1(TB) ;GET CDR OF FUNARG
+ JUMPE A,FUNERR ;NON -- NIL
+ HLRZ B,(A) ;GET TYPE OF CADR
+ CAIE B,TLIST ;BETTR BE LIST
+ JRST FUNERR
+ PUSH TP,$TLIST ;SAVE IT UP
+ PUSH TP,1(A)
+FUNLP:
+ INTGO
+ SKIPN A,3(TB) ;ANY MORE
+ JRST DOF ;NO -- APPLY IT
+ HRRZ B,(A)
+ MOVEM B,3(TB)
+ HLRZ C,(A)
+ CAIE C,TLIST
+ JRST FUNERR
+ HRRZ A,1(A)
+ HLRZ C,(A) ;GET FIRST VAR
+ CAIE C,TATOM ;MAKE SURE IT IS ATOMIC
+ JRST FUNERR
+ PUSH TP,BNDA ;SET IT UP
+ PUSH TP,1(A)
+ HRRZ A,(A)
+ PUSH TP,(A) ;SET IT UP
+ PUSH TP,1(A)
+ JSP E,CHKARG
+\r PUSH TP,[0]
+ PUSH TP,[0]
+ JRST FUNLP
+DOF:
+ PUSHJ P,SPECBIND ;BIND THEM
+ MOVE A,1(TB) ;GET GOODIE
+ HLLZ B,(A)
+ PUSH TP,B
+ PUSH TP,1(A)
+ HRRZ A,@1(AB)
+ PUSH TP,$TLIST
+ PUSH TP,A
+ MCALL 2,CONS
+ PUSH TP,$TFORM
+ PUSH TP,B
+ MCALL 1,EVAL
+ JRST FINIS
+\f
+
+;ILOC RETURNS IN A AND B A LOCATIVE TO THE LOCAL VALUE OF THE IDENTIFIER PASSED TO IT
+;IN A AND B. IF THE IDENTIFIER IS LOCALLY UNBOUND IT RETURNS $TUNBOUND IN A AND 0 IN B,
+; IT IS CALLED BY PUSHJ P,ILOC.
+
+ILOC: MOVSI A,TLOCI ;MAKE A LOCATIVE TYPE CELL
+ HRR A,PROCID+1(PVP) ;FOR THE CURRENT PROCESS
+ CAME A,(B) ;IS THERE ONE IN THE VALUE CELL?
+ JRST SCHSP ;NO -- SEARCH THE LOCAL BINDINGS
+ MOVE B,1(B) ;YES -- GET LOCATIVE POINTER
+ POPJ P, ;FROM THE VALUE CELL
+
+SCHSP: MOVE C,SP ;GET TOP OF BINDINGS
+SCHLP: JUMPE C,UNPOPJ ;IF NO MORE -- LOSE
+ CAMN B,1(C) ;ARE WE POINTING AT THE WINNER?
+ JRST SCHFND ;YES
+ HRRZ C,(C) ;FOLLOW LINK
+ JRST SCHLP
+
+SCHFND: EXCH B,C ;SAVE THE ATOM PTR IN C
+ MOVEI B,2(B) ;MAKE UP THE LOCATIVE
+ SUBI B,(TP)
+ HRLI B,-1(B)
+ ADD B,TP
+
+ MOVEM A,(C) ;CLOBBER IT AWAY INTO THE
+ MOVEM B,1(C) ;ATOM'S VALUE CELL
+ POPJ P,
+
+UNPOPJ: MOVSI A,TUNBOUND
+ MOVEI B,0
+ POPJ P,
+
+;IGLOC RETURNS IN A AND B A LOCATIVE TO THE GLOBAL VALUE OF THE
+;IDENTIFIER PASSED TO IT IN A AND B. IF THE IDENTIFIER IS GLOBALLY
+;UNBPOUND IT RETURNS $TUNBOUND IN A AND 0 IN B. IT IS CALLED BY PUSHJ P,IGLOC.
+
+\rIGLOC: MOVSI A,TLOCI ;DO WE HAVE A LOCATIVE TO
+ CAME A,(B) ;A PROCESS #0 VALUE?
+ JRST SCHGSP ;NO -- SEARCH
+ MOVE B,1(B) ;YES -- GET VALUE CELL
+ POPJ P,
+
+SCHGSP: MOVE D,GLOBSP+1(TVP) ;GET GLOBAL SP PTR
+
+SCHG1: JUMPGE D,UNPOPJ ;IF NO MORE, LEAVE
+ CAMN B,1(D) ;ARE WE FOUND?
+ JRST GLOCFOUND ;YES
+ ADD D,[4,,4] ;NO -- TRY NEXT
+ JRST SCHG1
+
+GLOCFOUND: EXCH B,D ;SAVE ATOM PTR
+ ADD B,[2,,2] ;MAKE LOCATIVE
+ MOVEM A,(D) ;CLOBBER IT AWAY
+ MOVEM B,1(D)
+ POPJ P,
+
+
+\f
+
+;ILVAL RETURNS IN A AND B THE LOCAL VALUE OF THE IDENTIFIER PASSED TO IT IN A AND B
+;IF THE IDENTIFIER IS UNBOUND ITS VALUE IS $TUNBOUND IN A AND 0 IN B. IF
+;IT IS UNASSIGNED ITS VALUE IS $TUNBOUND IN A AND -1 IN B. CALL - PUSHJ P,IVAL
+
+ILVAL:
+ PUSHJ P,ILOC ;GET LOCATIVE TO VALUE
+CHVAL: CAMN A,$TUNBOUND ;BOUND
+ POPJ P, ;NO -- RETURN
+ MOVE A,(B) ;GET THE TYPE OF THE VALUE
+ MOVE B,1(B) ;GET DATUM
+ POPJ P,
+
+;IGVAL -- LIKE ILVAL EXCEPT FOR GLOBAL VALUES
+
+IGVAL: PUSHJ P,IGLOC
+ JRST CHVAL
+
+
+\f
+
+;BINDER - THIS SUBROUTINE PROCCESSES FUNCTION DECLARATIONS AND BINDS
+; ARGUMENTS AND TEMPORARIES APPROPRIATELY.
+;
+; CALL: PUSHJ P,BINDER OR BINDRS
+;
+; BINDER - ASSUMES ARGS ARE ON A LIST
+;
+; BINDRS - ASSUMES FORMS SUPPLIED FOR GETTING ARGS
+; BINDRR - RESUME HACK - ARGS ON A LIST TO BE
+; EVALED IN PARENT PROCESS
+;
+
+; C/ POINTS TO FUNCTION BEING HACKED
+; D/ POINTS TO ARG LIST (IF <0, CALLED FROM A PROG)
+; 0/ IF NON-ZERO POINTS TO EXPRESSION GENREATING CALL
+
+BINDER: MOVEI A,0
+TBINDR: PUSH P,[ARGCDR] ;PUSH POINTER TO ARG GETTER
+ JRST BIND1
+
+BINDRR: MOVEI A,0
+TBNDRR: PUSH P,[RESARG] ; ARG GETTER FOR RESUMING FUNCTIONS
+ JRST BIND1
+
+
+BINDRS: MOVEI A,0 ;NO TOP TEMPS
+TBNDRS: PUSH P,[SETZ EVALRG] ;FOR THE STACKFORM CASE
+BIND1: PUSH P,[2] ;PUSH INITIAL STATE (NO DCLS PROCESSED)
+ PUSH P,A ;NUMBER OF TEMPS ON TP STACK
+
+ JUMPE C,NOBODY ;NO BODY IN FUNCTION, ERROR
+
+ GETYP A,(C) ;GET FIRST THING IN FUNCTION
+ CAIE A,TATOM ;ATOMIC?
+ JRST BIND2 ;NO, NO NAME ALA HEWITT GIVEN
+ PUSHJ P,TMPUP ;COUNT TEMPS ON TP
+ PUSH TP,[TATOM,,1] ;YES SAVE IT
+ PUSH TP,1(C)
+ HRRZ C,(C) ;CDR THE FUNCTION TO POINT
+ JUMPE C,NOBODY
+
+BIND2: PUSHJ P,CARLST ;MAKE SURE THE CAR IS A LIST
+ JRST BNDRET ;EXIT IMMEDIATELY
+ MOVEI A,(C) ;COPY FOR NXTDCL
+ JUMPL D,AUXDO ;PROG, HANDLE
+
+ PUSHJ P,NXTDCL ;GET A DECLARATION
+ JRST BINDRG ;NONE THERE, GO BIND ARGS
+
+ CAME B,[ASCII /BIND/] ;IS A BINDING NEEDED
+ JRST BIND3 ;NO MUST BE ANOTHER FLAVOR OF DCL
+
+ HRRZ C,(A) ;CDR THE LIST
+ JUMPE C,MPD ;LOSER
+
+ PUSHJ P,CARATM ;GET THE CAR MAKING SURE OF ATOM
+ JRST MPD
+ HRRZ B,OTBSAV(TB) ;BUILD AN ENVIRONEMNT FOR BINDING VAR
+ PUSHJ P,MAKENV
+
+ PUSHJ P,PSHBND ;PUSH THE BINDING ON THE STACK
+ HRRZ C,(C) ;CDR THE DCL LIST
+ JRST BINDRG ;GO BIND AS AN ARG
+
+\f
+
+; MAIN BINDING LOOP, DISPATCH BASED ON DECLARATION
+
+BIND4: MOVEI A,(C) ;COPY THE LIST POINTER
+ PUSHJ P,NXTDCL ;AND LOOK FOR A DECLARATION
+ JRST CHLIST ;ILLEGAL
+BIND3: TRZ B,1 ;FOR OPTIONAL TO WIN
+ MOVSI A,-DCLS ;NOW GET SET TO SEARCH TABLE
+ HRRZ C,(C) ;CDR THE DCL LIST
+ JUMPE C,MPD ;NO, CDR, ERROR
+
+ CAMN B,DCLST(A) ;SKIP IF NOT FOUND
+ JRST @DCLGO(A) ;DISPATCH BASED ON DCL
+ AOBJN A,.-2
+
+ JRST MPD
+
+DCLS==0
+
+DCLST: IRP A,,[ARGS,TUPLE,CALL,OPTIO,ACT,AUX,NAME,EXTRA]
+ DCLS==DCLS+1
+ ASCII /A/
+ TERMIN
+
+DCLS2==0
+\rDCLGO: IRP A,,[ARGDO,TUPLDO,CALDO,OPTDO,ACTDO,AUXDO,ACTDO,AUXDO]
+ A
+ DCLS2==DCLS2+1
+ TERMIN
+
+IFN <DCLS-DCLS2>,PRINTC /LOSSAGE AT DCLS
+/
+EXPUNGE DCLS2
+
+;HERE TO CHECK FOR LISTS WITHIN DECLARATIONS
+
+CHLIST: GETYP A,(C) ;GET TYPE
+ CAIE A,TLIST ;LIST?
+ JRST MPD ;NO, LOSER
+ SKIPN A,1(C) ;CHECK NON-NIL
+ JRST CALD1 ;IF NIL, IGNORE
+ PUSH TP,[TLIST,,1] ;SPECIAL TYPE
+ PUSH TP,C
+ MOVEI C,(A) ;LIST TO C
+ PUSHJ P,TMPUP ;COUNT TEMPS
+ JRST BINDRG
+
+
+\f
+
+;HANDLER FOR CALL DECLARATION
+
+CALDO: SKIPL -2(P) ;SKIP IF IN STACK-FORM
+ SOSG -1(P) ;SKIP IF FIRST DECLARATION
+ JRST MPD ;OTHERWISE MEANINGLESS
+
+ JUMPE 0,MPD ;ALSO MEANINGLESS IF NO CALLSITE GIVEN
+ PUSHJ P,CARATD ;GOBBLE THE ATOM
+
+ HLLZ A,0 ;SET UP CALL TO PUSH THE BINDING
+ HRRZ B,0
+CALD2: PUSHJ P,PSHBND ;PUSH THAT BINDING ON TO STACK
+
+CALD1: PUSH TP,$TLIST ;SAVE THE DCL LIST
+ PUSH TP,C
+ MOVEI E,-2(TP) ;POINT TO DCLS
+ SUB E,(P) ;SUBTRACT TEMPS
+CALD3: PUSHJ P,SPCBE ;DO THE BINDINGS NOW
+ MOVE C,(TP) ;RESTORE DCLS
+ SUB TP,[2,,2] ;AND POP
+ HRRZ C,(C) ;CDR THE LIST
+CALD4: SETZM -1(P) ;NEXT MUST BE EITHER AUX OR ACT
+ JUMPN C,BIND4 ;LOOP AGAIN
+
+\f
+
+BNDRET: MOVEI A,0 ;SET SWITCH
+BNDRT2: SKIPN (P) ;ANY TEMPS LEFT?
+ JRST BNDRT1
+ MOVE B,-1(TP) ;GET TYPE
+ CAMN B,[TATOM,,1] ;SPECIAL
+ JRST BNDRT3
+ CAME B,[TLIST,,1] ;STACKED LIST
+ JRST BNDRT1 ;NO, LEAVE
+
+ PUSHJ P,TMPDWN ;TEMPS DOWN
+ HRRZ C,@(TP) ;CDR THE SAVED LIST
+ SUB TP,[2,,2] ;POP OFF CRAP
+ JRST CALD4 ;AND CONTINUE PROCESSING
+
+BNDRT3: PUSHJ P,TMPDWN
+ MOVE E,(TP) ;GET ATOM
+ SUB TP,[2,,2]
+ MOVEI C,0 ;FOR ACTDO TO WIN
+ PUSHJ P,ACTD1
+ MOVEI A,1 ;SAY NAME EXISTS
+
+BNDRT1: SUB P,[3,,3]
+ POPJ P,
+
+\f
+
+; HERE TO ARGS DECLARATION
+
+ARGDO: SOSL -1(P) ;LOSE IF STATES ARE 0 OR 1
+ SKIPGE -2(P) ;ALSO LOSE IN STACK-FRAME
+ JRST MPD
+
+ PUSHJ P,CARATD ;FIND THE ATOM
+
+ MOVSI A,TLIST
+ MOVEI B,(D) ;COPY ARGL
+ JRST CALD2 ;AND FALL INTO CALL CODE
+
+;HERE TO HANDLE THE TUPLE DCL
+
+TUPLDO: SOSGE -1(P) ;CHECK STATE
+ JRST MPD
+
+ PUSHJ P,CARATD ;GET ATOM
+ PUSH TP,$TLIST ;SAVE DCL LIST
+ PUSH TP,C
+ PUSHJ P,TMPUP ;COUNT THE TEMPS
+ SETZB A,B
+
+ PUSHJ P,PSHBND ;PUSH THE BINDING FOR THIS CHOMPER
+ PUSH P,[0] ;PUSH ARG COUNTER
+
+TUPLP: PUSHJ P,@-3(P) ;CALL ARG GOBBLING SUBROUTINE
+ JRST TUPDONE ;LEAVE IF ALL DONE
+
+ PUSHJ P,PSHAB ;PUSH THE EVALED ARG
+ SOS (P) ;COUNT THE ARG
+ JRST TUPLP
+
+TUPDON: MOVSI A,TTB ;FENCE POST ARG BLOCK
+ MOVE B,TB ;WITH A FRAME POINTER
+ PUSHJ P,PSHAB ;ONTO THE STACK
+ POP P,B ;GET NUMBER OF ARGS
+ ASH B,1 ;TIMES TWO
+ SKIPE B ;WATCH FOR EMPTY TUPLE
+ HRLI B,-1(B) ;FOR ADDING TO TOA TP
+ ADDI B,-1(TP) ;FUDGE POINTER
+ SUB B,(P) ;SUBTRACT TEMPS
+ MOVEI E,-1(B) ;B WIIL GET CLOBBERED, SAVE
+ MOVSI A,TARGS ;GET THE RIGHT TYPE
+ HLR A,OTBSAV(TB) ;WITH THE TIME
+ MOVEM A,-4(B) ;CLOBBER IT AWAY
+ MOVEM B,-3(B) ;AND ARG POINTER
+
+ PUSHJ P,TMPDWN
+ JRST CALD3
+
+; HERE TO HANDLE OPTIONAL DECLARATION
+
+OPTDO: SKIPG -1(P)
+ JRST MPD ;NOT ALLOWED
+ SETZM -1(P) ;MUNG STATE
+ JRST BNDRGL ;JOIN BIND LOOP
+
+BINDRG: SKIPG -1(P) ;CHECK STATE
+ JRST MPD
+
+BNDRGL: JUMPE C,CHLST ;CHECK FOR LAST
+ PUSH TP,$TLIST ;SAVE DCLS
+ PUSH TP,C
+ PUSH TP,$TLIST ;SAVE SLOT
+ PUSH TP,D ;PUT ARGLIST THERE FOR AN INT CHECK
+ INTGO
+ MOVE D,(TP) ;INCASE INTERRUPT CLOBBERED IT
+ SETZM (TP) ;NOW CLEAR SLOT
+
+
+BNDRG3: PUSHJ P,CARATM ;CHECK FOR ATOM
+ JRST OPTDFL ;NO, MAY BE LIST OR MAY BE QUOTED
+
+ PUSH TP,$TATOM
+ PUSH TP,E ;AND ATOM
+
+ PUSHJ P,@-2(P) ;GOBBLE DOWN NEXT ARG
+ JRST USEDF ;CHECK FOR DEFAULT OT ENOUGH
+
+BNDRG2: HRRZ C,-4(TP) ;RESTORE DCLS
+ MOVE E,(TP) ;AND ATOM
+ SUB TP,[6,,6] ;FLUSH CRAP
+
+ PUSHJ P,PSHBND ;PUSH THE BINDING
+BNDRG4: HRRZ C,(C) ;CDR THE DCL LIST
+ JUMPN C,BNDRGL
+
+CHLST: PUSHJ P,@-2(P) ;CHECK FOR LAST
+ JRST .+2
+ JRST TMA
+ MOVEI E,(TP) ;PREPARE TO BIND
+ SUB E,(P)
+ PUSHJ P,SPCBE ;BIND IF STUFF EXISTS
+ JRST BNDRET ;AND RETURN
+
+\f
+
+CHQT: CAIE A,TFORM ;IST THE ARG A FORM?
+ JRST OPTDF2 ;NO, END OF ARGS
+
+ SKIPN C,1(C) ;CHECK FOR NULL BODY
+ JRST MPD
+
+ GETYP A,(C) ;TYPE OF 1ST OF FORM
+ MOVE B,1(C) ;AND VALUE
+ CAIN A,TATOM ;BETTER BE ATOM
+ CAME B,MQUOTE QUOTE
+ JRST MPD ;NAMED QUOTE OR LOSSAGE
+ HRRZ C,(C) ;CDR THE FORM
+ JUMPE C,MPD ;NO, ARG LOSE
+ GETYP A,(C)
+ CAIE A,TATOM ;ARG MUST BE ATOM
+ JRST MPD
+ HRRZ A,(C) ;AND CDR BETTER BE NIL
+ JUMPN A,MPD
+ PUSH TP,$TATOM ;AND SAVE SAME
+ PUSH TP,1(C)\r
+ SKIPGE A,-2(P) ;CHECK TYPE OF ARGS
+ JRST QUOTHK ;STACK FRAME HACK
+
+ JUMPE D,USEDF ;IF NO MORE ARGS, QUIT
+ GETYP A,(D) ;GET TYPE
+ MOVSI A,(A) ;TO LH
+ PUSH TP,A ;PUSH IT UP
+ PUSH TP,1(D) ;FOR DEFER CHECK
+ JSP E,CHKARG
+ POP TP,B ;GET BACK
+ POP TP,A
+ HRRZ D,(D) ;CDR THE ARG LIST
+ JRST BNDRG2
+
+QUOTHK: PUSHJ P,(A) ;CALL ROUTINE
+ JRST USEDF ;TOO FEW ARGS
+
+ PUSH TP,$TATOM ;QUOTE THE GOODIE
+ PUSH TP,MQUOTE QUOTE
+ PUSH TP,A
+ PUSH TP,B
+ MCALL 2,LIST ;CONS IT UP
+ MOVSI A,TFORM
+ JRST BNDRG2
+
+
+\f
+
+OPTDFL: SKIPN -1(P) ;SKIP IF CANT BE DEFAULT
+ CAIE A,TLIST ;SHOULD BE A LIST
+ JRST CHQT ;NO MORE OPTIONALS
+
+ SKIPE (TP) ;AVOID LIST OF LIST
+ JRST MPD
+ MOVE C,1(C) ;GET THE CAR
+ HRRZ A,(C) ;CDR THE LIST
+ JUMPE A,MPD ;LOSER
+ HRRZ B,(A) ;CHECK FOR NIL CDR
+ JUMPN B,MPD
+ MOVEM A,(TP) ;SAVE
+ JRST BNDRG3
+
+OPTDF2: JUMPN D,OPTDF3 ;IF D NON-ZERO, DONT BIND
+ MOVEI E,-4(TP) ;PREPARE TO BIND
+ SUBI E,@(P) ;SUBTRACT TEMPS
+ PUSHJ P,SPCBE ;DO BINDINGS MAYBE
+ MOVEI D,0 ;RESET D TO 0
+OPTDF3: MOVE C,-2(TP) ;RESTORE DCLS
+ SUB TP,[4,,4] ;POP STACK
+ MOVEI A,1 ;CLOBBER IN A NEW STATE
+ MOVEM A,-1(P)
+ JRST BIND4 ;AND RE-ENTER THE LOOP
+
+
+USEDF: SKIPE -1(P) ;SKIP IF OPTIONAL
+ JRST TFA ;ELSE TOO FEW ARGS
+ MOVEI E,-6(TP) ;SET TO DO SPECBIND
+ SUBI E,@(P)
+ PUSHJ P,SPCBE ;BIND IF THEY EXIST
+ MOVNI B,1 ;ASSUME UNASSIGNED AT FIRST
+ MOVSI A,TUNBOU
+ SKIPN C,-2(TP) ;IF A FORM TO EVAL
+ JRST OPTDF4 ;TREAT NORMALLY
+ GETYP A,(C) ;EVAL IT
+ MOVSI A,(A)
+ PUSH TP,A
+ PUSH TP,1(C)
+ JSP E,CHKARG ;CHECK FOR DEFERRED POINTERS
+ MCALL 1,EVAL ;EVAL IT
+OPTDF4: MOVE E,(TP) ;GET ATOM
+ MOVE C,-4(TP)
+ SUB TP,[6,,6] ;FLUSH JUNK
+ PUSHJ P,PSHBND ;PUSH THE BINDING
+ MOVEI D,0 ;MUNG ARG LIST
+ JRST BNDRG4
+
+\f
+
+AUXDO: SKIPGE -1(P) ;CHECK STATE
+ JRST MPD
+ SETOM -1(P) ;NOTHING BUT ACT MAY FOLLOW
+
+AUXBND: JUMPE C,BNDRET ;DONE
+ PUSHJ P,CARATM ;LOOK FOR ATOM
+ JRST AUXIN ;COULD BE LIST
+
+ MOVSI A,TUNBOU
+ MOVNI B,1
+AUXB1: PUSHJ P,PSHBND ;PUSH THE BINDING UP
+
+ MOVEI E,(TP) ;PREPARE TO BIND
+ PUSH TP,$TLIST ;SAVE DCLS
+ PUSH TP,C
+ SUB E,(P) ;FUDGE FOR TEMPS
+ PUSHJ P,SPCBE
+
+ INTGO
+ HRRZ C,@(TP) ;CDR THE LIST
+ SUB TP,[2,,2] ;AND POP
+ JRST AUXBND
+
+AUXIN: CAIE A,TLIST ;IS IT A LIST
+ JRST BIND4
+ PUSH TP,$TLIST ;SAVE DCLS
+ PUSH TP,C
+ SKIPN C,1(C) ;NIL?
+ JRST MPD ;YES, LOSE
+ PUSHJ P,CARATD ;MAKE SURE ITS AN ATOM
+ PUSH TP,$TATOM
+ PUSH TP,E
+ HRRZ C,(C) ;CDR
+ JUMPE C,MPD
+ HRRZ A,(C) ;GET NEXT CDR
+ JUMPN A,MPD ;BETTER BE NIL
+ GETYP A,(C)
+ MOVSI A,(A) ;TYPE TO LH
+ PUSH TP,A
+ PUSH TP,1(C) ;PREPARE TO EVAL
+ MCALL 1,EVAL
+ MOVE E,(TP) ;RESTORE ATOM
+ MOVE C,-2(TP) ;AND DCLS
+ SUB TP,[4,,4]
+ JRST AUXB1
+
+\f
+
+ACTDO: PUSHJ P,CARATD ;MUST BE ATOMIC
+ HRRZ C,(C) ;MUST BE END OF DCLS
+ JUMPN C,MPD
+ PUSH P,CBNDRE ;PUSH THE RIGHT RETURN
+
+ACTD1: MOVE B,TB ;MAKE ENV
+ PUSHJ P,MAKENV
+ HRLI A,TACT ;AND CHANGE TO ACTIVATION
+ POP P,D ;RESTORE RET ADR, BECAUSE PSHBND NEEDS NICE STATE
+ PUSHJ P,PSHBND ;PUSH UP THE BINDING
+ PUSH P,D ;NOW PUT IT BACK
+ MOVEI E,(TP)
+ SUBI E,@-1(P) ;NOW READY TO BIND
+ PUSHJ P,SPCBE
+ MOVNI A,1 ;SET SW
+CBNDRE: POPJ P,BNDRT2
+
+
+;INTERNAL ROUTINES FOR THE BINDER
+
+TMPUP: AOS -1(P) ;ADDS 2 TO TOP OF STACK
+ AOS -1(P)
+ POPJ P,
+
+TMPDWN: SOS -1(P) ;SUBTRACTS 2 FROM STACK
+ SOS -1(P)
+ POPJ P,
+
+CARATD: PUSHJ P,CARATM ;LOOK FOR ATOM
+ JRST MPD ;ERROR IF NONE
+ POPJ P,
+
+CARATM: GETYP A,(C) ;GETS ARG IN C, GET TYPE
+ CAIE A,TATOM ;ATOM?
+ POPJ P, ;NO, DONT SKIP
+ MOVE E,1(C) ;RETRUN ATOM IN E
+CPOPJ1: AOS (P) ;SKIP RET
+CPOPJ: POPJ P,
+
+CARLST: GETYP A,(C) ;GETS LIST IN CAR, POPS TO 2D ON STACK IF NIL
+ CAIE A,TLIST
+ JRST MPD ;NOT A LIST, FATAL
+ SKIPE C,1(C)
+ AOS (P)
+ POPJ P,
+
+
+MAKENV: PUSH P,C ;SAVE AN AC
+ HLRE C,PVP ;GET -LNTH OF PROC VECTOR
+ MOVEI A,(PVP) ;COPY PVP
+ SUBI A,-1(C) ;POINT TO DOPWD WITH A
+ HRLI A,TENV ;MAKE INTO AN ENVIRONMENT
+ HLL B,OTBSAV(B) ;TIME TO B
+ POP P,C
+ POPJ P,
+
+
+\f
+
+; ARGCDR - NORMAL ARG GETTER FOR OTHER THAN STACKFORM
+
+ARGCDR: JUMPE D,CPOPJ ;DONT SKIP IF NIL
+ PUSH TP,$TLIST
+ PUSH TP,D
+ GETYP A,(D) ;GET TYPE OF ARG
+ MOVSI A,(A) ;TO LH OF A
+ PUSH TP,A
+ PUSH TP,1(D) ;PUSH TYPE AND VALUE
+ JSP E,CHKARG ;CHECK FOR TDEFER
+ MCALL 1,EVAL
+ HRRZ D,@(TP) ;CDR THE LIST
+ SUB TP,[2,,2] ;POP STACK
+ JRST CPOPJ1 ;SKIP RETURN
+
+;EVALRG - USED TO EVAL ARGS IN STACKFORM HACK
+
+EVALRG: JUMPE D,CPOPJ ;LEAVE IMMEDIATELY
+ PUSH TP,$TLIST ;SAVE ARG LIST
+ PUSH TP,D
+ HRRZ C,(D) ;AND CDR IT
+ GETYP B,(C) ;GET TYPE OF CONDITIONAL FORM
+ MOVSI B,(B) ;TO LH
+ PUSH TP,B
+ PUSH TP,1(C) ;AND VALUE
+ JSP E,CHKARG ;CHECK DEFERRED
+ MCALL 1,EVAL ;AND EVAL IT
+ CAMN A,$TFALSE ;FALSE?
+ JRST EVALR2 ;YES, LEAVE
+ HRRZ D,(TP) ;GET ARGS BACK
+ GETYP A,(D) ;GET TYPE
+ MOVSI A,(A) ;TO LH
+ PUSH TP,A
+ PUSH TP,1(D) ;PUSH IT
+ JSP E,CHKARG ;CHECK DEFERRED
+ MCALL 1,EVAL
+ AOS (P) ;CAUSE A SKIP RETURN
+EVALR2: MOVE D,(TP) ;RESTORE ARGS
+ SUB TP,[2,,2] ;POP STACK
+ POPJ P, ;AND RETURN
+
+;RESARG - USED TO GET ARGS FOR RESUMING FUNCTIONS
+
+
+RESARG:
+ JUMPE D,CPOPJ ;DONT SKIP IF NIL - NO MORE ARGS
+ PUSH TP,$TLIST ; SAVE ARG LIST
+ PUSH TP,D
+ GETYP A,(D) ; GET TYPE OF ARG
+ MOVSI A,(A) ;TO LH
+ PUSH TP,A ;PUSH TYPE
+ PUSH TP,1(D) ;AND VALUE
+ JSP E,CHKARG ;CHECK FOR DEFERED TYPE
+ MOVE B,MQUOTE [PPROC ]INTERR
+ PUSHJ P,ILVAL ;GET ENV OF PARENT PROCESS
+ PUSH TP,A
+ PUSH TP,B ;SET UP FOR AEVAL CALL
+ MCALL 2,EVAL ;CALL EVAL WITH THE ENV
+ HRRZ D,@(TP) ;CDR ARG LIST
+ SUB TP,[2,,2] ;REMOVE SAVED ARG LIST
+ JRST CPOPJ1 ;SKIP 1 AND RETURN
+
+\f
+
+;SUBROUTINE TO PUSH A BINDING ON THE STACK
+; E/ ATOM
+; A/ TYPE
+; B/ VALUE
+
+PSHBND: PUSH P,D ;SAVE TEMPS
+ PUSH P,E
+ MOVE D,-3(P) ;GOBBLE # OF TEMPS ON STACK
+ ADD TP,[6,,6] ;ALOCATE SPACE
+ JUMPGE TP,TPLOSE ;HACK IF OVERFLOW
+PSHBN1: HRROI E,-6(TP) ;SET UP E
+ JUMPE D,NOBLT ;IF NO TEMPS, LESS WORK
+ POP E,6(E) ;USE POP TP MOVE THEM UP
+ SOJN D,.-1
+NOBLT: MOVSI D,TATOM ;SET UP BINDING
+ HLLOM D,1(E) ;CLOBBER
+ POP P,2(E) ;ATOM INTO SLOT
+ MOVEM A,3(E)
+ MOVEM B,4(E)
+ SETZM 5(E) ;CLEAR EXTRA SLOTS
+ SETZM 6(E)
+ POP P,D
+ POPJ P,
+
+TPLOSE: PUSHJ P,TPOVFL ;GO TO INT HANDLER
+ JRST PSHBN1
+
+; DO A SPECBIND IF NEEDED
+
+SPCBE: MOVE A,-5(E) ;GET TYPE
+ CAME A,BNDA
+ POPJ P,
+ MOVEI A,(TP) ;COPY POINTER
+ SUBI A,(E) ;FIND DISTANCE TO TOP
+ MOVSI A,(A) ;TO LH
+ HLL E,TP
+ SUB E,A ;FIX UP POINTER
+ JRST SPECBE ;YES, GO DO IT
+
+;ROUTINE TO SQUEEZE A PAIR ON THE STACK
+
+PSHAB: PUSH P,D
+ PUSH P,E
+ PUSH TP,[0] ;ALLOCATE SPACE
+ PUSH TP,[0]
+ MOVE D,-4(P) ;GET TEMPS COUNT
+ HRROI E,-2(TP) ;POINT TO TOP
+ JUMPE D,NOBLT1
+ POP E,2(E)
+ SOJN D,.-1
+
+NOBLT1: MOVEM A,1(E) ;CLOBBER
+ MOVEM B,2(E)
+ POP P,E
+ POP P,D
+ POPJ P,
+
+\f
+
+;SPECBIND BINDS IDENTIFIERS. IT IS CALLED BY PUSHJ P,SPECBIND.
+;SPECBIND IS PROVIDED WITH A CONTIGUOUS SET OF TRIPLETS ON TP.
+;EACH TRIPLET IS AS FOLLOWS:
+;THE FIRST ELEMENT IS THE IDENTIFIER TO BE BOUND, ITS TYPE WORD IS [TATOM,,-1],
+;THE SECOND IS THE VALUE TO WHICH IT IS TO BE ASSIGNED,
+;AND THE THIRD IS A PAIR OF ZEROES.
+
+BNDA: TATOM,,-1
+BNDV: TVEC,,-1
+
+SPECBIND: MOVE E,TP ;GET THE POINTER TO TOP
+SPECBE: ADD E,[1,,1] ;BUMP POINTER ONCE
+ SETZB 0,D ;CLEAR TEMPS
+
+BINDLP: MOVE A,-6(E) ;GET TYPE
+ CAME A,BNDA ;NORMAL ID BIND?
+ JRST NONID ;NO TRY BNDV
+
+ SUB E,[6,,6] ;MOVE PTR
+ SKIPE D ;LINK?
+ HRRM E,(D) ;YES -- LOBBER
+ SKIPN 0 ;UPDATED?
+ MOVE 0,E ;NO -- DO IT
+
+ MOVE A,0(E) ;GET ATOM PTR
+ MOVE B,1(E)
+ PUSHJ P,ILOC ;GET LAST BINDING
+ HLR A,OTBSAV (TB) ;GET TIME
+ MOVEM A,4(E) ;CLOBBER IT AWAY
+ MOVEM B,5(E) ;IN RESTORE CELLS
+
+ HRRZ A,PROCID+1(PVP) ;GET PROCESS NUMBER
+ HRLI A,TLOCI ;MAKE LOC PTR
+ MOVE B,E ;TO NEW VALUE
+ ADD B,[2,,2]
+ MOVE C,1(E) ;GET ATOM PTR
+ MOVEM A,(C) ;CLOBBER ITS VALUE
+ MOVEM B,1(C) ;CELL
+ MOVEI A,TBIND
+ HRLM A,(E) ;IDENTIFY AS BIND BLOCK
+ MOVE D,E ;REMEMBER LINK
+ JRST BINDLP ;DO NEXT
+
+NONID: MOVE A,-4(E) ;TRY TYPE BEFORE
+ CAME A,BNDV ;IS IT A SPECIAL HACK?
+ JRST SPECBD ;NO -- DONE
+ SUB E,[4,,4]
+ SKIPE D
+ HRRM E,(D)
+ SKIPN 0
+ MOVE 0,E
+
+ MOVE D,1(E) ;GET PTR TO VECTOR
+ MOVE C,(D) ;EXCHANGE TYPES
+ EXCH C,2(E)
+ MOVEM C,(D)
+
+ MOVE C,1(D) ;EXCHANGE DATUMS
+ EXCH C,3(E)
+ MOVEM C,1(D)
+
+ MOVEI A,TBVL
+ HRLM A,(E) ;IDENTIFY BIND BLOCK
+ MOVE D,E ;REMEMBER LINK
+ JRST BINDLP
+
+SPECBD: SKIPE D
+ HRRM SP,(D)
+ MOVE SP,0
+ POPJ P,
+
+\f
+
+;SPECSTORE RESTORES THE BINDINGS SP TO THE ENVIRONMENT POINTER IN
+;SPSAV (TB). IT IS CALLED BY PUSHJ P,SPECSTORE.
+
+SPECSTORE:
+ HRRZ E,SPSAV (TB) ;GET TARGET POINTER
+
+STLOOP:
+ CAIL E,(SP) ;ARE WE DONE?
+ JRST STPOPJ
+ HLRZ C,(SP) ;GET TYPE OF BIND
+ CAIE C,TBIND ;NORMAL IDENTIFIER?
+ JRST ISTORE ;NO -- SPECIAL HACK
+
+
+ MOVE C,1(SP) ;GET TOP ATOM
+ MOVE D,4(SP) ;GET STORED LOCATIVE
+\r HRR D,PROCID+1(PVP) ;STORE SIGNATURE
+ MOVEM D,(C) ;CLOBBER INTO ATOM
+ MOVE D,5(SP)
+ MOVEM D,1(C)
+ SETZM 4(SP)
+SPLP: HRRZ SP,(SP) ;FOLOW LINK
+ JUMPN SP,STLOOP ;IF MORE
+ JUMPE E,STPOPJ ;ONLY OK IF E=0
+ .VALUE [ASCIZ /SPOVERPOP/]
+
+ISTORE: CAIE C,TBVL
+ .VALUE [ASCIZ /BADSP/]
+ MOVE C,1(SP)
+ MOVE D,2(SP)
+ MOVEM D,(C)
+ MOVE D,3(SP)
+ MOVEM D,1(C)
+ JRST SPLP
+
+STPOPJ:
+ MOVE SP,SPSAV(TB)
+ POPJ P,
+
+
+\f
+
+MFUNCTION REP,FSUBR,[REPEAT]
+ JRST PROG
+MFUNCTION PROG,FSUBR
+ ENTRY 1
+ GETYP A,(AB) ;GET ARG TYPE
+ CAIE A,TLIST ;IS IT A LIST?
+ JRST WTYP ;WRONG TYPE
+ SKIPN C,1(AB) ;GET AND CHECK ARGUMENT
+ JRST ERRTFA ;TOO FEW ARGS
+ PUSH TP,$TLIST ;PUSH GOODIE
+ PUSH TP,C
+ PUSH TP,BNDA ;BIND FUNNY ATOM
+ PUSH TP,MQUOTE [LPROG ]INTERR
+ PUSH TP,$TTB
+ PUSH TP,TB ;CURRENT TB POINTER
+ PUSH TP,[0]
+ PUSH TP,[0]
+ PUSHJ P,SPECBI ;BIND THE ATOM
+ MOVE C,1(AB) ;PROG BODY
+ MOVNI D,1 ;TELL BINDER WE ARE APROG
+ PUSHJ P,BINDER
+ HRRZ C,1(AB) ;RESTORE PROG
+ SKIPLE A ;SKIP IF NO NAME ALA HEWITT
+ HRRZ C,(C)
+ JUMPE C,NOBODY
+ PUSH TP,$TLIST
+ PUSH TP,C ;SAVE FOR REPEAT, AGAIN ETC.
+ HRRZ C,(C) ;SKIP DCLS
+
+; HERE TO RUN PROGS FUNCTIONS ETC.
+
+DOPROG:
+ HRRZM C,1(TB) ;CLOBBER AWAY BODY
+ PUSH TP,(C) ;EVALUATE THE
+ HLLZS (TP)
+ PUSH TP,1(C) ;STATEMENT
+ JSP E,CHKARG
+ MCALL 1,EVAL
+ HRRZ C,@1(TB) ;GET THE REST OF THE BODY
+ JUMPN C,DOPROG ;IF MORE -- DO IT
+ENDPROG:
+ HRRZ C,FSAV(TB)
+ MOVE C,@-1(C)
+ CAME C,MQUOTE REP,REPEAT
+ JRST FINIS
+ SKIPN C,(TP) ;CHECK IT
+ JRST FINIS
+ MOVEM C,1(TB)
+ JRST CONTINUE
+
+\f
+
+MFUNCTION RETURN,SUBR
+ ENTRY 1
+ PUSHJ P,PROGCH ;CKECK IN A PROG
+ HRR TB,B ;YES, SET TB
+ MOVE A,(AB)
+ MOVE B,1(AB)
+ JRST FINIS
+
+
+MFUNCTION AGAIN,SUBR
+ ENTRY
+ HLRZ A,AB ;GET # OF ARGS
+ CAIN A,-2 ;1 ARG?
+ JRST NLCLA ;YES
+ JUMPN A,WNA ;0 ARGS?
+ PUSHJ P,PROGCH ;CHECK FOR IN A PROG
+ JRST AGAD
+NLCLA: HLRZ A,(AB)
+ CAIE A,TACT
+ JRST WTYP
+ MOVE A,1(AB)
+ HRR B,A
+ HLL B,OTBSAV (B)
+ HRRZ C,A
+ CAIG C,1(TP)
+ CAME A,B
+ JRST ILLFRA
+ HLRZ C,FSAV (C)
+ CAIE C,TENTRY
+ JRST ILLFRA
+AGAD: HRR TB,B
+ MOVE B,TPSAV(B) ;POINT TO TOP OF STACK
+ MOVE B,(B)
+ MOVEM B,1(TB)
+ JRST CONTIN
+
+MFUNCTION GO,SUBR
+ ENTRY 1
+ PUSHJ P,PROGCH ;CHECK FOR A PROG
+ PUSH TP,A ;SAVE
+ PUSH TP,B
+ MOVE A,(AB)
+ CAME A,$TATOM
+ JRST NLCLGO
+ PUSH TP,A
+ PUSH TP,1(AB)
+ MOVE B,TPSAV(B) ;GET SAVED TOP OF STACK
+ PUSH TP,-1(B)
+ PUSH TP,(B)
+ MCALL 2,MEMQ ;DOES IT HAVE THIS TAG?
+ JUMPE B,NXTAG ;NO -- ERROR
+FNDGO: MOVE TB,(TP) ;RE-GOBBLE
+ SUB TP,[2,,2] ;POP TP
+ MOVEM B,1(TB)
+ JRST GODON
+
+NLCLGO: CAME A,$TTAG ;CHECK TYPE
+ JRST WTYP
+ MOVE A,1(AB) ;GET ARG
+ HRR B,3(A)
+ HLL B,OTBSAV(B)
+ HRRZ C,B
+ CAIG C,1(TP)
+ CAME B,3(A) ;CHECK TIME
+ JRST ILLFRA
+ HLRZ C,FSAV(C)
+ CAIE C,TENTRY
+ JRST ILLFRA
+ HRR TB,3(A) ;GET NEW FRAME PTR
+ MOVE A,1(A) ;GET PLACE TO START
+ MOVEM A,1(TB) ;CLOBBER IT AWAY
+GODON: MOVE A,(AB)
+ MOVE B,1(AB)
+ JRST CONTIN
+
+\f
+
+
+MFUNCTION TAG,SUBR
+ ENTRY 1
+ HLRZ A,(AB) ;GET TYPE OF ARGUMENT
+ CAIE A,TATOM ;CHECK THAT IT IS AN ATOM
+ JRST WTYP
+ PUSHJ P,PROGCH ;CHECK PROG
+ PUSH TP,A ;SAVE VAL
+ PUSH TP,B
+ MOVE A,TPSAV(B) ;GET STACK TOP
+ PUSH TP,0(AB)
+ PUSH TP,1(AB)
+ PUSH TP,-1(A)
+ PUSH TP,(A)
+ MCALL 2,MEMQ
+ JUMPE B,NXTAG ;IF NOT FOUND -- ERROR
+ MOVEM A,-1(TP) ;SAVE PLACE
+ EXCH B,(TP)
+ MOVEI A,1(PVP)
+ HLRE C,PVP
+ SUB A,C
+ HRLI A,TFRAME
+ PUSH TP,A
+ HLL B,OTBSAV (B)
+ PUSH TP,B
+ MCALL 2,EVECTOR
+ MOVSI A,TTAG
+ JRST FINIS
+
+PROGCH: MOVE B,MQUOTE [LPROG ]INTERR
+ PUSHJ P,ILVAL ;GET VALUE
+ CAME A,$TTB ;CHECK TYPE
+ JRST NXPRG
+ POPJ P,
+
+MFUNCTION EXIT,SUBR
+ ENTRY 2
+ HLRZ A,(AB)
+ CAIE A,TACT
+ JRST WTYP
+ MOVE A,1(AB)
+ HRR B,A
+ HLL B,OTBSAV(B)
+ HRRZ C,A
+ CAIG C,1(TP)
+ CAME A,B
+ JRST ILLFRA
+ HLRZ C,FSAV(C)
+ CAIE C,TENTRY
+ JRST ILLFRA
+ HRR TB,A
+ MOVE A,2(AB)
+ MOVE B,3(AB)
+ JRST FINIS
+
+MFUNCTION COND,FSUBR
+ ENTRY 1
+ HLRZ A,(AB)
+ CAIE A,TLIST
+ JRST WTYP
+CLSLUP: SKIPN B,1(AB) ;IS THE CLAUSELIST NIL?
+ JRST IFALSE ;YES -- RETURN NIL
+ HLRZ A,(B) ;NO -- GET TYPE OF CAR
+ CAIE A,TLIST ;IS IT A LIST?
+ JRST BADCLS ;
+ MOVE A,1(B) ;YES -- GET CLAUSE
+ JUMPE A,BADCLS
+ PUSH TP,(A) ;EVALUATION OF
+ HLLZS (TP)
+ PUSH TP,1(A) ;THE PREDICATE
+ JSP E,CHKARG
+ MCALL 1,EVAL
+ CAMN A,$TFALSE ;IF THE RESULT IS
+ JRST NXTCLS ;FALSE TRY NEXT CLAUSE
+ MOVE C,1(AB) ;IF NOT, GET
+ MOVE C,1(C) ;THE CLAUSE
+ HRRZ C,(C) ;GET ITS REST
+ JUMPE C,FINIS ;IF ONLY A PREDICATE --- RETURN ITS VALUE
+ PUSH TP,$TLIST
+ PUSH TP,C ;EVALUATE THE REST OF THE CLAUSE
+ JRST DOPROG
+NXTCLS: HRRZ A,@1(AB) ;SET THE CLAUSLIST
+ HRRZM A,1(AB) ;TO CDR OF THE CLAUSLIST
+ JRST CLSLUP
+
+IFALSE:
+ MOVSI A,TFALSE ;RETURN FALSE
+ MOVEI B,0
+ JRST FINIS
+
+
+\f
+
+;SETG IS USED TO SET THE GLOBAL VALUE OF ITS FIRST ARGUMENT,
+;AN IDENTIFIER, TO THE VALUE OF ITS SECOND ARGUMENT. ITS VALUE IS
+; ITS SECOND ARGUMENT.
+
+MFUNCTION SETG,SUBR
+ ENTRY 2
+ HLLZ A,(AB) ;GET TYPE OF FIRST ARGUMENT
+ CAME A,$TATOM ;CHECK THAT IT IS AN ATOM
+ JRST NONATM ;IF NOT -- ERROR
+ MOVE B,1(AB) ;GET POINTER TO ATOM
+ PUSHJ P,IGLOC ;GET LOCATIVE TO VALUE
+ CAMN A,$TUNBOUND ;IF BOUND
+ PUSHJ P,BSETG ;IF NOT -- BIND IT
+ MOVE C,B ;SAVE PTR
+ MOVE A,2(AB) ;GET SECOND ARGUMENT
+ MOVE B,3(AB) ;INTO THE RETURN POSITION
+ MOVEM A,(C) ;DEPOSIT INTO THE
+ MOVEM B,1(C) ;INDICATED VALUE CELL
+ JRST FINIS
+
+BSETG: HRRZ A,GLOBASE+1(TVP)
+ HRRZ B,GLOBSP+1(TVP)
+ SUB B,A
+ CAIL B,6
+ JRST SETGIT
+ PUSH TP,GLOBASE(TVP)
+ PUSH TP,GLOBASE+1 (TVP)
+ PUSH TP,$TFIX
+ PUSH TP,[0]
+ PUSH TP,$TFIX
+ PUSH TP,[100]
+ MCALL 3,GROW
+ MOVEM A,GLOBASE(TVP)
+ MOVEM B,GLOBASE+1(TVP)
+SETGIT:
+ MOVE B,GLOBSP+1(TVP)
+ SUB B,[4,,4]
+ MOVE C,(AB)
+ MOVEM C,(B)
+ MOVE C,1(AB)
+ MOVEM C,1(B)
+ MOVEM B,GLOBSP+1(TVP)
+ ADD B,[2,,2]
+ MOVSI A,TLOCI
+ POPJ P,
+
+\f
+
+
+;SET CLOBBERS THE LOCAL VALUE OF THE IDENTIFIER GIVEN BY ITS
+;FIRST ARGUMENT TO THE SECOND ARG. ITS VALUE IS ITS SECOND ARGUMENT.
+
+MFUNCTION SET,SUBR
+ ENTRY 2
+ HLLZ A,(AB) ;GET TYPE OF FIRST
+ CAME A,$TATOM ;ARGUMENT --
+ JRST WTYP ;BETTER BE AN ATOM
+ MOVE B,1(AB) ;GET PTR TO IT
+ PUSHJ P,ILOC ;GET LOCATIVE TO VALUE
+ CAMN A,$TUNBOUND ;BOUND?
+ PUSHJ P, BSET ;BIND IT
+ MOVE C,B ;SAVE PTR
+ MOVE A,2(AB) ;GET SECOND ARG
+ MOVE B,3(AB) ;INTO RETURN VALUE
+ MOVEM A,(C) ;CLOBBER IDENTIFIER
+ MOVEM B,1(C)
+ JRST FINIS
+BSET:
+ HRRZ A,TPBASE+1(PVP) ;GET ACTUAL STACK BASE
+ HRRZ B,SPBASE+1(PVP) ;AND FIRST BINDING
+ SUB B,A ;ARE THERE 6
+ CAIL B,6 ;CELLS AVAILABLE?
+ JRST SETIT ;YES
+ PUSH TP,TPBASE(PVP) ;NO -- GROW THE TP
+ PUSH TP,TPBASE+1(PVP) ;AT THE BASE END
+ PUSH TP,$TFIX
+ PUSH TP,[0]
+ PUSH TP,$TFIX
+ PUSH TP,[100]
+ MCALL 3,GROW
+ MOVEM A,TPBASE(PVP) ;SAVE RESULT
+ MOVEM B,TPBASE+1(PVP)
+SETIT: MOVE B,SPBASE+1(PVP)
+ MOVEI A,-6(B) ;MAKE UP BINDING
+ HRRM A,(B) ;LINK PREVIOUS BIND BLOCK
+ MOVSI A,TBIND
+ MOVEM A,-6(B)
+ MOVE A,1(AB)
+ MOVEM A,-5(B)
+ MOVSI A,TLOCI
+ HRR A,PROCID+1(PVP)
+ SUB B,[6,,6]
+ MOVEM B,SPBASE+1(PVP)
+ ADD B,[2,,2]
+ POPJ P,
+
+\f
+
+MFUNCTION NOT,SUBR
+ ENTRY 1
+ HLRZ A,(AB) ; GET TYPE
+ CAIE A,TFALSE ;IS IT FALSE?
+ JRST IFALSE ;NO -- RETURN FALSE
+
+TRUTH:
+ MOVSI A,TATOM ;RETURN T (VERITAS)
+ MOVE B,MQUOTE T
+ JRST FINIS
+
+MFUNCTION ANDA,FSUBR,AND
+ ENTRY 1
+ HLRZ A,(AB)
+ CAIE A,TLIST
+ JRST WTYP ;IF ARG DOESN'T CHECK OUT
+ SKIPN C,1(AB) ;IF NIL
+ JRST TRUTH ;RETURN TRUTH
+ANDLP:
+ JUMPE C,FINIS ;ANY MORE ARGS?
+ MOVEM C,1(AB) ;STORE CRUFT
+ PUSH TP,(C) ;EVALUATE THE
+ HLLZS (TP) ;FIRST REMAINING
+ PUSH TP,1(C) ;ARGUMENT
+ JSP E,CHKARG
+ MCALL 1,EVAL
+ CAMN A,$TFALSE
+ JRST FINIS ;IF FALSE -- RETURN
+ HRRZ C,@1(AB) ;GET CDR OF ARGLIST
+ JRST ANDLP
+
+MFUNCTION OR,FSUBR
+ ENTRY 1
+ HLRZ A,(AB)
+ CAIE A,TLIST ;CHECK OUT ARGUMENT
+ JRST WTYP
+ MOVE C,1(AB) ;PICK IT UP TO ENTER LOOP
+ORLP:
+ JUMPE C,IFALSE ;IF NO MORE OPTIONS -- FALSE
+ MOVEM C,1(AB) ;CLOBBER IT AWAY
+ PUSH TP,(C)
+ HLLZS (TP)
+ PUSH TP,1(C) ;EVALUATE THE FIRST REMAINING
+ JSP E,CHKARG
+ MCALL 1,EVAL ;ARGUMENT
+ CAME A,$TFALSE ;IF NON-FALSE RETURN
+ JRST FINIS
+ HRRZ C,@1(AB) ;IF FALSE -- TRY AGAIN
+ JRST ORLP
+
+MFUNCTION FUNCTION,FSUBR
+ PUSH TP,(AB)
+ PUSH TP,1(AB)
+ PUSH TP,$TATOM
+ PUSH TP,MQUOTE FUNCTION
+ MCALL 2,CHTYPE
+ JRST FINIS
+
+\f
+
+MFUNCTION CLOSURE,SUBR
+ ENTRY
+ SKIPL A,AB ;ANY ARGS
+ JRST ERRTFA ;NO -- LOSE
+ ADD A,[2,,2] ;POINT AT IDS
+ PUSH TP,$TAB
+ PUSH TP,A
+ PUSH P,[0] ;MAKE COUNTER
+
+CLOLP: SKIPL A,1(TB) ;ANY MORE IDS?
+ JRST CLODON ;NO -- LOSE
+ PUSH TP,(A) ;SAVE ID
+ PUSH TP,1(A)
+ PUSH TP,(A) ;GET ITS VALUE
+ PUSH TP,1(A)
+ ADD A,[2,,2] ;BUMP POINTER
+ MOVEM A,1(TB)
+ AOS (P)
+ MCALL 1,VALUE
+ PUSH TP,A
+ PUSH TP,B
+ MCALL 2,LIST ;MAKE PAIR
+ PUSH TP,A
+ PUSH TP,B
+ JRST CLOLP
+
+CLODON: POP P,A
+ ACALL A,LIST ;MAKE UP LIST
+ PUSH TP,(AB) ;GET FUNCTION
+ PUSH TP,1(AB)
+ PUSH TP,A
+ PUSH TP,B
+ MCALL 2,LIST ;MAKE LIST
+ MOVSI A,TFUNARG
+ JRST FINIS
+
+
+MFUNCTION FALSE,SUBR
+ ENTRY
+ JUMPGE AB,IFALSE
+ HLRZ A,(AB)
+ CAIE A,TLIST
+ JRST WTYP
+ MOVSI A,TFALSE
+ MOVE B,1(AB)
+ JRST FINIS
+\f
+
+;ERROR COMMENTS FOR EVAL
+
+UNBOU: PUSH TP,$TATOM
+ PUSH TP,MQUOTE UNBOUND-VARIABLE
+ JRST ER1ARG
+
+UNAS: PUSH TP,$TATOM
+ PUSH TP,MQUOTE UNASSIGNED-VARIABLE
+ JRST ER1ARG
+
+TFA:
+ERRTFA: PUSH TP,$TATOM
+ PUSH TP,MQUOTE TOO-FEW-ARGUMENTS-SUPPLIED
+ JRST CALER1
+
+TMA:
+ERRTMA: PUSH TP,$TATOM
+ PUSH TP,MQUOTE TOO-MANY-ARGUMENTS-SUPPLIED
+ JRST CALER1
+
+BADENV:
+ PUSH TP,$TATOM
+ PUSH TP,MQUOTE BAD-ENVIRONMENT
+ JRST CALER1
+
+FUNERR:
+ PUSH TP,$TATOM
+ PUSH TP,MQUOTE BAD-FUNARG
+ JRST CALER1
+
+WRONGT:
+WTYP: PUSH TP,$TATOM
+ PUSH TP,MQUOTE WRONG-TYPE
+ JRST CALER1
+
+MPD: PUSH TP,$TATOM
+ PUSH TP,MQUOTE MEANINGLESS-PARAMETER-DECLARATION
+ JRST CALER1
+
+NOBODY: PUSH TP,$TATOM
+ PUSH TP,MQUOTE HAS-EMPTY-BODY
+ JRST CALER1
+
+BADCLS: PUSH TP,$TATOM
+ PUSH TP,MQUOTE BAD-CLAUSE
+ JRST CALER1
+
+NXTAG: PUSH TP,$TATOM
+ PUSH TP,MQUOTE NON-EXISTENT-TAG
+ JRST CALER1
+
+NXPRG: PUSH TP,$TATOM
+ PUSH TP,MQUOTE NOT-IN-PROG
+ JRST CALER1
+
+NAPT: PUSH TP,$TATOM
+ PUSH TP,MQUOTE NON-APPLICABLE-TYPE
+ JRST CALER1
+
+NONEVT: PUSH TP,$TATOM
+ PUSH TP,MQUOTE NON-EVALUATEABLE-TYPE
+ JRST CALER1
+
+
+NONATM: PUSH TP,$TATOM
+ PUSH TP,MQUOTE NON-ATOMIC-ARGUMENT
+ JRST CALER1
+
+
+ILLFRA: PUSH TP,$TATOM
+ PUSH TP,MQUOTE FRAME-NO-LONGER-EXISTS
+ JRST CALER1
+
+NOTIMP: PUSH TP,$TATOM
+ PUSH TP,MQUOTE NOT-YEST-IMPLEMENTED
+ JRST CALER1
+
+ILLSEG: PUSH TP,$TATOM
+ PUSH TP,MQUOTE ILLEGAL-SEGMENT
+ JRST CALER1
+
+ER1ARG: PUSH TP,(AB)
+ PUSH TP,1(AB)
+ MOVEI A,2
+ JRST CALER
+CALER1: MOVEI A,1
+CALER:
+ HRRZ C,FSAV(TB)
+ PUSH TP,$TATOM
+ PUSH TP,@-1(C)
+ ADDI A,1
+ ACALL A,ERROR
+ JRST FINIS
+
+END
+***\f\f\f\ 3\f
\ No newline at end of file
projects / pdp10-muddle.git / blobdiff