--- /dev/null
+TITLE EVAL -- MUDDLE EVALUATOR
+
+RELOCATABLE
+
+; GERALD JAY SUSSMAN, 1971. REWRITTEN MANY TIMES SINCE C. REEVE (1972--1974)
+
+
+.GLOBAL BINDID,LPROG,GLOBSP,GLOBASE,SPBASE,TPBASE,PTIME,SWAP,CHFRAM
+.GLOBAL IGVAL,CHKARG,NXTDCL,TPOVFL,CHFRM,PROCHK,CHFSWP,VECBOT,TYPSGR
+.GLOBAL ILVAL,ER1ARG,SPECBIND,MAKACT,SPECSTORE,MAKTUP,TPALOC,IBIND,SSPECS
+.GLOBAL IDVAL,EVECTO,EUVECT,CHARGS,BCKTRK,CELL,ILOC,IGLOC,CHKDCL,SSPEC1
+.GLOBAL PDLBUF,MESS,FACTI,CHKARG,MAKENV,PSTAT,BNDV,UNBOU,UNAS,IGDECL
+.GLOBAL 1STEPR,SEGMNT,SEGLST,NAPT,EVTYPE,EVATYP,APTYPE,APLTYP,APLQ,IDVAL1
+.GLOBAL TESTR,VALG,TYPG,INCR1,TMATCH,TYPMIS,SAT,MAKACT,NTPALO,SPECBND
+.GLOBAL TPGROW,CHKAB,TYPSEG,NXTLM,MONCH0,CHFINI,RMONC0,IMPURIFY,ICONS,INCONS
+.GLOBAL CILVAL,CISET,CIGVAL,CSETG,MAPPLY,CLLOC,CGLOC,CASSQ,CGASSQ,CBOUND
+.GLOBAL IIGLOC,CHUNW,IUNWIN,UNWIN2,SPCCHK,CURFCN,TMPLNT,TD.LNT,TBINIT
+.GLOBAL SPECBE,BSETG,GLOTOP,CANDP,CORP,TFA,TMA,DSTORE,PVSTOR,SPSTOR
+.GLOBAL AGC,GVLINC,LVLINC,CGBOUN,IEVECT,MAKTU2,STOSTR,HIBOT,POPUNW,ISTRUC
+.GLOBAL NOSET,NOSETG
+
+.INSRT MUDDLE >
+
+MONITOR
+
+\f
+; ENTRY TO EXPAND A MACRO
+
+MFUNCTION EXPAND,SUBR
+
+ ENTRY 1
+
+ MOVE PVP,PVSTOR+1
+ MOVEI A,PVLNT*2+1(PVP)
+ HRLI A,TFRAME
+ MOVE B,TBINIT+1(PVP)
+ HLL B,OTBSAV(B)
+ PUSH TP,A
+ PUSH TP,B
+ MOVEI B,-1(TP)
+ JRST AEVAL2
+
+; MAIN EVAL ENTRANCE
+
+IMFUNCTION EVAL,SUBR
+
+ ENTRY
+
+ MOVE PVP,PVSTOR+1
+ SKIPE C,1STEPR+1(PVP) ; BEING 1 STEPPED?
+ JRST 1STEPI ; YES HANDLE
+EVALON: HLRZ A,AB ;GET NUMBER OF ARGS
+ CAIE A,-2 ;EXACTLY 1?
+ JRST AEVAL ;EVAL WITH AN ALIST
+SEVAL: GETYP A,(AB) ;GET TYPE OF ARG
+ SKIPE C,EVATYP+1 ; USER TYPE TABLE?
+ JRST EVDISP
+SEVAL1: CAIG A,NUMPRI ;PRIMITIVE?
+ JRST SEVAL2 ;YES-DISPATCH
+
+SELF: MOVE A,(AB) ;TYPES WHICH EVALUATE
+ MOVE B,1(AB)
+ JRST EFINIS ;TO SELF-EG NUMBERS
+
+SEVAL2: HRRO A,EVTYPE(A)
+ JRST (A)
+
+; HERE FOR USER EVAL DISPATCH
+
+EVDISP: ADDI C,(A) ; POINT TO SLOT
+ ADDI C,(A)
+ SKIPE (C) ; SKIP EITHER A LOSER OR JRST DISP
+ JRST EVDIS1 ; APPLY EVALUATOR
+ SKIPN C,1(C) ; GET ADDR OR GO TO PURE DISP
+ JRST SEVAL1
+ JRST (C)
+
+EVDIS1: PUSH TP,(C)
+ PUSH TP,1(C)
+ PUSH TP,(AB)
+ PUSH TP,1(AB)
+ MCALL 2,APPLY ; APPLY HACKER TO OBJECT
+ JRST EFINIS
+
+
+; EVAL DISPATCH TABLE
+
+IF2,SELFS==400000,,SELF
+
+DISTBL EVTYPE,SELFS,[[TFORM,EVFORM],[TLIST,EVLIST],[TVEC,EVECT],[TUVEC,EUVEC]
+[TSEG,ILLSEG]]
+\f
+
+;WATCH FOR SUBTLE BUG 43 LERR,LPROG OR BINDID
+AEVAL:
+ CAIE A,-4 ;EXACTLY 2 ARGS?
+ JRST WNA ;NO-ERROR
+ GETYP A,2(AB) ;CHECK THAT WE HAVE A FRAME
+ CAIE A,TACT
+ CAIN A,TFRAME
+ JRST .+3
+ CAIE A,TENV
+ JRST TRYPRO ; COULD BE PROCESS
+ MOVEI B,2(AB) ; POINT TO FRAME
+AEVAL2: PUSHJ P,CHENV ; HACK ENVIRONMENT CHANGE
+AEVAL1: PUSH TP,(AB)
+ PUSH TP,1(AB)
+ MCALL 1,EVAL
+AEVAL3: HRRZ 0,FSAV(TB)
+ CAIN 0,EVAL
+ JRST EFINIS
+ JRST FINIS
+
+TRYPRO: CAIE A,TPVP ; SKIP IF IT IS A PROCESS
+ JRST WTYP2
+ MOVE C,3(AB) ; GET PROCESS
+ CAMN C,PVSTOR ; DIFFERENT FROM ME?
+ JRST SEVAL ; NO, NORMAL EVAL WINS
+ MOVE B,SPSTO+1(C) ; GET SP FOR PROCESS
+ MOVE D,TBSTO+1(C) ; GET TOP FRAME
+ HLL D,OTBSAV(D) ; TIME IT
+ MOVEI C,PVLNT*2+1(C) ; CONS UP POINTER TO PROC DOPE WORD
+ HRLI C,TFRAME ; LOOK LIK E A FRAME
+ PUSHJ P,SWITSP ; SPLICE ENVIRONMENT
+ JRST AEVAL1
+
+; ROUTINE TO CHANGE LOOK UP PATH FOR BINDINGS
+
+CHENV: PUSHJ P,CHFRM ; CHECK OUT FRAME
+ MOVE C,(B) ; POINT TO PROCESS
+ MOVE D,1(B) ; GET TB POINTER FROM FRAME
+ CAMN SP,SPSAV(D) ; CHANGE?
+ POPJ P, ; NO, JUST RET
+ MOVE B,SPSAV(D) ; GET SP OF INTEREST
+SWITSP: MOVSI 0,TSKIP ; SET UP SKIP
+ HRRI 0,1(TP) ; POINT TO UNBIND PATH
+ MOVE A,PVSTOR+1
+ ADD A,[BINDID,,BINDID] ; BIND THE BINDING ID
+ PUSH TP,BNDV
+ PUSH TP,A
+ PUSH TP,$TFIX
+ AOS A,PTIME ; NEW ID
+ PUSH TP,A
+ MOVE E,TP ; FOR SPECBIND
+ PUSH TP,0
+ PUSH TP,B
+ PUSH TP,C ; SAVE PROCESS
+ PUSH TP,D
+ PUSHJ P,SPECBE ; BIND BINDID
+ MOVE SP,TP ; GET NEW SP
+ SUB SP,[3,,3] ; SET UP SP FORK
+ MOVEM SP,SPSTOR+1
+ POPJ P,
+\f
+
+; HERE TO EVALUATE A FORM (99% OF EVAL'S WORK)
+
+EVFORM: SKIPN C,1(AB) ; EMPTY FORM, RETURN FALSE
+ JRST EFALSE
+ GETYP A,(C) ; 1ST ELEMENT OF FORM
+ CAIE A,TATOM ; ATOM?
+ JRST EV0 ; NO, EVALUATE IT
+ MOVE B,1(C) ; GET ATOM
+ PUSHJ P,IGVAL ; GET ITS GLOBAL VALUE
+
+; SPECIAL HACK TO SPEED UP LVAL AND GVAL CALLS
+
+ CAIE B,LVAL
+ CAIN B,GVAL
+ JRST ATMVAL ; FAST ATOM VALUE
+
+ GETYP 0,A
+ CAIE 0,TUNBOU ; BOUND?
+ JRST IAPPLY ; YES APPLY IT
+
+ MOVE C,1(AB) ; LOOK FOR LOCAL
+ MOVE B,1(C)
+ PUSHJ P,ILVAL
+ GETYP 0,A
+ CAIE 0,TUNBOU
+ JRST IAPPLY ; WIN, GO APPLY IT
+
+ PUSH TP,$TATOM
+ PUSH TP,EQUOTE UNBOUND-VARIABLE
+ PUSH TP,$TATOM
+ MOVE C,1(AB) ; FORM BACK
+ PUSH TP,1(C)
+ PUSH TP,$TATOM
+ PUSH TP,IMQUOTE VALUE
+ MCALL 3,ERROR ; REPORT THE ERROR
+ JRST IAPPLY
+
+EFALSE: MOVSI A,TFALSE ; SPECIAL FALSE FOR EVAL OF EMPTY FORM
+ MOVEI B,0
+ JRST EFINIS
+
+ATMVAL: HRRZ D,(C) ; CDR THE FORM
+ HRRZ 0,(D) ; AND AGAIN
+ JUMPN 0,IAPPLY
+ GETYP 0,(D) ; MAKE SURE APPLYING TO ATOM
+ CAIE 0,TATOM
+ JRST IAPPLY
+ MOVEI E,IGVAL ; ASSUME GLOBAAL
+ CAIE B,GVAL ; SKIP IF OK
+ MOVEI E,ILVAL ; ELSE USE LOCAL
+ PUSH P,B ; SAVE SUBR
+ MOVE B,(D)+1 ; CLR BUG #1637 (GET THE ATOM FOR THE SUBR)
+ PUSHJ P,(E) ; AND GET VALUE
+ CAME A,$TUNBOU
+ JRST EFINIS ; RETURN FROM EVAL
+ POP P,B
+ MOVSI A,TSUBR ; CAUSE REAL SUBR TO GET EROR
+ JRST IAPPLY
+\f
+; HERE FOR 1ST ELEMENT NOT A FORM
+
+EV0: PUSHJ P,FASTEV ; EVAL IT
+
+; HERE TO APPLY THINGS IN FORMS
+
+IAPPLY: PUSH TP,(AB) ; SAVE THE FORM
+ PUSH TP,1(AB)
+ PUSH TP,A
+ PUSH TP,B ; SAVE THE APPLIER
+ PUSH TP,$TFIX ; AND THE ARG GETTER
+ PUSH TP,[ARGCDR]
+ PUSHJ P,APLDIS ; GO TO INTERNAL APPLIER
+ JRST EFINIS ; LEAVE EVAL
+
+; HERE TO EVAL 1ST ELEMENT OF A FORM
+
+FASTEV: MOVE PVP,PVSTOR+1
+ SKIPE 1STEPR+1(PVP) ; BEING 1 STEPPED?
+ JRST EV02 ; YES, LET LOSER SEE THIS EVAL
+ GETYP A,(C) ; GET TYPE
+ SKIPE D,EVATYP+1 ; USER TABLE?
+ JRST EV01 ; YES, HACK IT
+EV03: CAIG A,NUMPRI ; SKIP IF SELF
+ SKIPA A,EVTYPE(A) ; GET DISPATCH
+ MOVEI A,SELF ; USE SLEF
+
+EV04: CAIE A,SELF ; IF EVAL'S TO SELF, JUST USE IT
+ JRST EV02
+ MOVSI A,TLIST
+ MOVE PVP,PVSTOR+1
+ MOVEM A,CSTO(PVP)
+ INTGO
+ SETZM CSTO(PVP)
+ HLLZ A,(C) ; GET IT
+ MOVE B,1(C)
+ JSP E,CHKAB ; CHECK DEFERS
+ POPJ P, ; AND RETURN
+
+EV01: ADDI D,(A) ; POINT TO SLOT OF USER EVAL TABLE
+ ADDI D,(A)
+ SKIPE (D) ; EITHER NOT GIVEN OR SIMPLE
+ JRST EV02
+ SKIPN 1(D) ; SKIP IF SIMPLE
+ JRST EV03 ; NOT GIVEN
+ MOVE A,1(D)
+ JRST EV04
+
+EV02: PUSH TP,(C)
+ HLLZS (TP) ; FIX UP LH
+ PUSH TP,1(C)
+ JSP E,CHKARG
+ MCALL 1,EVAL
+ POPJ P,
+
+\f
+; MAPF/MAPR CALL TO APPLY
+
+ IMQUOTE APPLY
+
+MAPPLY: JRST APPLY
+
+; APPLY, FALLS INTO EVAL'S APPLY CODE AT APLDIS
+
+IMFUNCTION APPLY,SUBR
+
+ ENTRY
+
+ JUMPGE AB,TFA ; MUST BE AT LEAST 1 ARGUMENT
+ MOVE A,AB
+ ADD A,[2,,2]
+ PUSH TP,$TAB
+ PUSH TP,A
+ PUSH TP,(AB) ; SAVE FCN
+ PUSH TP,1(AB)
+ PUSH TP,$TFIX ; AND ARG GETTER
+ PUSH TP,[SETZ APLARG]
+ PUSHJ P,APLDIS
+ JRST FINIS
+
+; STACKFROM, ALSO FALLS INTO EVAL'S APPLIER AT APLDIS
+
+IMFUNCTION STACKFORM,FSUBR
+
+ ENTRY 1
+
+ GETYP A,(AB)
+ CAIE A,TLIST
+ JRST WTYP1
+ MOVEI A,3 ; CHECK ALL GOODIES SUPPLIED
+ HRRZ B,1(AB)
+
+ JUMPE B,TFA
+ HRRZ B,(B) ; CDR IT
+ SOJG A,.-2
+
+ HRRZ C,1(AB) ; GET LIST BACK
+ PUSHJ P,FASTEV ; DO A FAST EVALUATION
+ PUSH TP,(AB)
+ HRRZ C,@1(AB) ; POINT TO ARG GETTING FORMS
+ PUSH TP,C
+ PUSH TP,A ; AND FCN
+ PUSH TP,B
+ PUSH TP,$TFIX
+ PUSH TP,[SETZ EVALRG]
+ PUSHJ P,APLDIS
+ JRST FINIS
+
+\f
+; OFFSETS FOR TEMPORARIES ETC. USED IN APPLYING STUFF
+
+E.FRM==0 ; POINTS TO FORM BEING EVALED (OR ARGS FOR APPLY STACKFORM)
+E.FCN==2 ; FUNCTION/SUBR/RSUBR BEING APPLIED
+E.ARG==4 ; POINTS TO ARG GETTING ROUTINE (<0 => MUST EVAL ARGS)
+E.EXTR==6 ; CONTAINS 1ST ARG IN USER APPLY CASE
+E.SEG==10 ; POINTS TO SEGMENT IN FORM BEING HACKED
+E.CNT==12 ; COUNTER FOR TUPLES OF ARGS
+E.DECL==14 ; POINTS TO DECLARATION LIST IN FUNCTIONS
+E.ARGL==16 ; POINTS TO ARG LIST IN FUNCTIONS
+E.HEW==20 ; POINTS TO HEWITT ATOM IF IT EXISTS
+
+E.VAL==E.ARGL ; VALUE TYPE FOR RSUBRS
+
+MINTM==E.EXTR+2 ; MIN # OF TEMPS EVER ALLOCATED
+E.TSUB==E.CNT+2 ; # OF TEMPS FOR SUBR/NUMBER APPLICATION
+XP.TMP==E.HEW-E.EXTR ; # EXTRA TEMPS FOR FUNCTION APPLICATION
+R.TMP==4 ; TEMPS AFTER ARGS ARE BOUND
+TM.OFF==E.HEW+2-R.TMP ; TEMPS TO FLUSH AFTER BIND OF ARGS
+
+RE.FCN==0 ; AFTER BINDING CONTAINS FCN BODY
+RE.ARG==2 ; ARG LIST AFTER BINDING
+
+; GENERAL THING APPLYER
+
+APLDIS: PUSH TP,[0] ; SLOT USED FOR USER APPLYERS
+ PUSH TP,[0]
+APLDIX: GETYP A,E.FCN(TB) ; GET TYPE
+
+APLDI: SKIPE D,APLTYP+1 ; USER TABLE EXISTS?
+ JRST APLDI1 ; YES, USE IT
+APLDI2: CAILE A,NUMPRI ; SKIP IF NOT PRIM
+ JRST NAPT
+ HRRO A,APTYPE(A)
+ JRST (A)
+
+APLDI1: ADDI D,(A) ; POINT TO SLOT
+ ADDI D,(A)
+ SKIPE (D) ; SKIP IF NOT GIVEN OR STANDARD
+ JRST APLDI3
+APLDI4: SKIPE D,1(D) ; GET DISP
+ JRST (D)
+ JRST APLDI2 ; USE SYSTEM DISPATCH
+
+APLDI3: SKIPE E.EXTR+1(TB) ; SKIP IF HAVEN'T BEEN HERE BEFORE
+ JRST APLDI4
+ MOVE A,(D) ; GET ITS HANDLER
+ EXCH A,E.FCN(TB) ; AND USE AS FCN
+ MOVEM A,E.EXTR(TB) ; SAVE
+ MOVE A,1(D)
+ EXCH A,E.FCN+1(TB)
+ MOVEM A,E.EXTR+1(TB) ; STASH OLD FCN AS EXTRG
+ GETYP A,(D) ; GET TYPE
+ JRST APLDI
+
+
+; APPLY DISPATCH TABLE
+
+DISTBL APTYPE,<SETZ NAPTL>,[[TSUBR,APSUBR],[TFSUBR,APFSUB],[TRSUBR,APRSUB],[TFIX,APNUM]
+[TEXPR,APEXPR],[TFUNAR,APFUNARG],[TENTER,APENTR],[TMACRO,APMACR],[TOFFS,APNUM]]\f
+
+; SUBR TO SAY IF TYPE IS APPLICABLE
+
+MFUNCTION APPLIC,SUBR,[APPLICABLE?]
+
+ ENTRY 1
+
+ GETYP A,(AB)
+ PUSHJ P,APLQ
+ JRST IFALSE
+ JRST TRUTH
+
+; HERE TO DETERMINE IF A TYPE IS APPLICABLE
+
+APLQ: PUSH P,B
+ SKIPN B,APLTYP+1
+ JRST USEPUR ; USE PURE TABLE
+ ADDI B,(A)
+ ADDI B,(A) ; POINT TO SLOT
+ SKIPG 1(B) ; SKIP IF WINNER
+ SKIPE (B) ; SKIP IF POTENIAL LOSER
+ JRST CPPJ1B ; WIN
+ SKIPE 1(B) ; SKIP IF MUST USE PURE TABBLE
+ JRST CPOPJB
+USEPUR: CAILE A,NUMPRI ; SKIP IF NOT PRIM
+ JRST CPOPJB
+ SKIPL APTYPE(A) ; SKIP IF APLLICABLE
+CPPJ1B: AOS -1(P)
+CPOPJB: POP P,B
+ POPJ P,
+\f
+; FSUBR APPLYER
+
+APFSUBR:
+ SKIPN E.EXTR(TB) ; IF EXTRA ARG
+ SKIPGE E.ARG+1(TB) ; OR APPLY/STACKFORM, LOSE
+ JRST BADFSB
+ MOVE A,E.FCN+1(TB) ; GET FCN
+ HRRZ C,@E.FRM+1(TB) ; GET ARG LIST
+ SUB TP,[MINTM,,MINTM] ; FLUSH UNWANTED TEMPS
+ PUSH TP,$TLIST
+ PUSH TP,C ; ARG TO STACK
+ .MCALL 1,(A) ; AND CALL
+ POPJ P, ; AND LEAVE
+
+; SUBR APPLYER
+
+APSUBR:
+ PUSHJ P,PSH4ZR ; SET UP ZEROED SLOTS
+ SKIPG E.ARG+1(TB)
+ AOS E.CNT(TB) ; INDICATES IF MUST EVAL ARGS
+ MOVSI A,400000 ; MAKE SURE OF GOOD INDIRECT
+ IORM A,E.ARG+1(TB)
+ SKIPN A,E.EXTR(TB) ; FUNNY ARGS
+ JRST APSUB1 ; NO, GO
+ MOVE B,E.EXTR+1(TB) ; YES , GET VAL
+ JRST APSUB2 ; AND FALL IN
+
+APSUB1: PUSHJ P,@E.ARG+1(TB) ; EAT AN ARG
+ JRST APSUBD ; DONE
+APSUB2: PUSH TP,A
+ PUSH TP,B
+ AOS E.CNT+1(TB) ; COUNT IT
+ JRST APSUB1
+
+APSUBD: MOVE A,E.CNT+1(TB) ; FINISHED, GET COUNT
+ MOVE B,E.FCN+1(TB) ; AND SUBR
+ GETYP 0,E.FCN(TB)
+ CAIN 0,TENTER
+ JRST APENDN
+ PUSHJ P,BLTDN ; FLUSH CRUFT
+ .ACALL A,(B)
+ POPJ P,
+
+BLTDN: MOVEI C,(TB) ; POINT TO DEST
+ HRLI C,E.TSUB(C) ; AND SOURCE
+ BLT C,-E.TSUB(TP) ;BL..............T
+ SUB TP,[E.TSUB,,E.TSUB]
+ POPJ P,
+
+APENDN: PUSHJ P,BLTDN
+APNDN1: .ECALL A,(B)
+ POPJ P,
+
+; FLAGS FOR RSUBR HACKER
+
+F.STR==1
+F.OPT==2
+F.QUO==4
+F.NFST==10
+
+; APPLY OBJECTS OF TYPE RSUBR
+
+APENTR:
+APRSUBR:
+ MOVE C,E.FCN+1(TB) ; GET THE RSUBR
+ CAML C,[-5,,] ; IS IT LONG ENOUGH FOR DECLS
+ JRST APSUBR ; NO TREAT AS A SUBR
+ GETYP 0,4(C) ; GET TYPE OF 3D ELEMENT
+ CAIE 0,TDECL ; DECLARATION?
+ JRST APSUBR ; NO, TREAT AS SUBR
+ PUSHJ P,PSH4ZR ; ALLOCATE SOME EXTRA ROOM
+ PUSH TP,$TDECL ; PUSH UP THE DECLS
+ PUSH TP,5(C)
+ PUSH TP,$TLOSE ; SAVE ROOM FOR VAL DECL
+ PUSH TP,[0]
+ SKIPG E.ARG+1(TB)
+ AOS E.CNT(TB) ; INDICATES IF MUST EVAL ARGS
+ MOVSI A,400000 ; MAKE SURE OF GOOD INDIRECT
+ IORM A,E.ARG+1(TB)
+
+ SKIPN E.EXTR(TB) ; "EXTRA" ARG?
+ JRST APRSU1 ; NO,
+ MOVE 0,[SETZ EXTRGT] ; CHANGE THE ACCESS FCN
+ EXCH 0,E.ARG+1(TB)
+ HRRM 0,E.ARG(TB) ; REMEMBER IT
+
+APRSU1: MOVEI 0,0 ; INIT FLAG REGISTER
+ PUSH P,0 ; SAVE
+
+APRSU2: HRRZ A,E.DECL+1(TB) ; GET DECL LIST
+ JUMPE A,APRSU3 ; DONE!
+ HRRZ B,(A) ; CDR IT
+ MOVEM B,E.DECL+1(TB)
+ PUSHJ P,NXTDCL ; IS NEXT THING A STRING?
+ JRST APRSU4 ; NO, BETTER BE A TYPE
+ CAMN B,[ASCII /VALUE/]
+ JRST RSBVAL ; SAVE VAL DECL
+ TRON 0,F.NFST ; IF NOT FIRST, LOSE
+ CAME B,[ASCII /CALL/] ; CALL DECL
+ JRST APRSU7
+ SKIPE E.CNT(TB) ; LEGAL?
+ JRST MPD
+ MOVE C,E.FRM(TB)
+ MOVE D,E.FRM+1(TB) ; GET FORM
+ JRST APRS10 ; HACK IT
+
+APRSU5: TROE 0,F.STR ; STRING STRING?
+ JRST MPD ; LOSER
+ CAMN B,[<ASCII /OPT/>]
+ JRST .+3
+ CAME B,[<ASCII /OPTIO/>+1] ; OPTIONA?
+ JRST APRSU8
+ TROE 0,F.OPT ; CHECK AND SET
+ JRST MPD ; OPTINAL OPTIONAL LOSES
+ JRST APRSU2 ; TO MAIN LOOP
+
+APRSU7: CAME B,[ASCII /QUOTE/]
+ JRST APRSU5
+ TRO 0,F.STR
+ TROE 0,F.QUO ; TURN ON AND CHECK QUOTE
+ JRST MPD ; QUOTE QUOTE LOSES
+ JRST APRSU2 ; GO TO END OF LOOP
+\f
+
+APRSU8: CAME B,[ASCII /ARGS/]
+ JRST APRSU9
+ SKIPE E.CNT(TB) ; SKIP IF LEGAL
+ JRST MPD
+ HRRZ D,@E.FRM+1(TB) ; GET ARG LIST
+ MOVSI C,TLIST
+
+APRS10: HRRZ A,(A) ; GET THE DECL
+ MOVEM A,E.DECL+1(TB) ; CLOBBER
+ HRRZ B,(A) ; CHECK FOR TOO MUCH
+ JUMPN B,MPD
+ MOVE B,1(A) ; GET DECL
+ HLLZ A,(A) ; GOT THE DECL
+ MOVEM 0,(P) ; SAVE FLAGS
+ JSP E,CHKAB ; CHECK DEFER
+ PUSH TP,C
+ PUSH TP,D ; SAVE
+ PUSHJ P,TMATCH
+ JRST WTYP
+ AOS E.CNT+1(TB) ; COUNT ARG
+ JRST APRDON ; GO CALL RSUBR
+
+RSBVAL: HRRZ A,E.DECL+1(TB) ; GET DECL
+ JUMPE A,MPD
+ HRRZ B,(A) ; POINT TO DECL
+ MOVEM B,E.DECL+1(TB) ; SAVE NEW DECL POINTER
+ PUSHJ P,NXTDCL
+ JRST .+2
+ JRST MPD
+ MOVEM A,E.VAL+1(TB) ; SAVE VAL DECL
+ MOVSI A,TDCLI
+ MOVEM A,E.VAL(TB) ; SET ITS TYPE
+ JRST APRSU2
+\f
+
+APRSU9: CAME B,[ASCII /TUPLE/]
+ JRST MPD
+ MOVEM 0,(P) ; SAVE FLAGS
+ HRRZ A,(A) ; CDR DECLS
+ MOVEM A,E.DECL+1(TB)
+ HRRZ B,(A)
+ JUMPN B,MPD ; LOSER
+ PUSH P,[0] ; COUNT ELEMENTS IN TUPLE
+
+APRTUP: PUSHJ P,@E.ARG+1(TB) ; GOBBLE ARGS
+ JRST APRTPD ; DONE
+ PUSH TP,A
+ PUSH TP,B
+ AOS (P) ; COUNT IT
+ JRST APRTUP ; AND GO
+
+APRTPD: POP P,C ; GET COUNT
+ ADDM C,E.CNT+1(TB) ; UPDATE MAIN COUNT
+ ASH C,1 ; # OF WORDS
+ HRLI C,TINFO ; BUILD FENCE POST
+ PUSH TP,C
+ PUSHJ P,TBTOTP ; GEN REL OFFSET TO TOP
+ PUSH TP,D
+ HRROI D,-1(TP) ; POINT TO TOP
+ SUBI D,(C) ; TO BASE
+ TLC D,-1(C)
+ MOVSI C,TARGS ; BUILD TYPE WORD
+ HLR C,OTBSAV(TB)
+ MOVE A,E.DECL+1(TB)
+ MOVE B,1(A)
+ HLLZ A,(A) ; TYPE/VAL
+ JSP E,CHKAB ; CHECK
+ PUSHJ P,TMATCH ; GOTO TYPE CHECKER
+ JRST WTYP
+
+ SUB TP,[2,,2] ; REMOVE FENCE POST
+
+APRDON: SUB P,[1,,1] ; FLUSH CRUFT
+ MOVE A,E.CNT+1(TB) ; GET # OF ARGS
+ MOVE B,E.FCN+1(TB)
+ GETYP 0,E.FCN(TB) ; COULD BE ENTRY
+ MOVEI C,(TB) ; PREPARE TO BLT DOWN
+ HRLI C,E.TSUB+2(C)
+ BLT C,-E.TSUB+2(TP)
+ SUB TP,[E.TSUB+2,,E.TSUB+2]
+ CAIE 0,TRSUBR
+ JRST APNDNX
+ .ACALL A,(B) ; CALL THE RSUBR
+ JRST PFINIS
+
+APNDNX: .ECALL A,(B)
+ JRST PFINIS
+
+\f
+
+
+APRSU4: MOVEM 0,(P) ; SAVE FLAGS
+ MOVE B,1(A) ; GET DECL
+ HLLZ A,(A)
+ JSP E,CHKAB
+ MOVE 0,(P) ; RESTORE FLAGS
+ PUSH TP,A
+ PUSH TP,B ; AND SAVE
+ SKIPE E.CNT(TB) ; ALREADY EVAL'D
+ JRST APREV0
+ TRZN 0,F.QUO
+ JRST APREVA ; MUST EVAL ARG
+ MOVEM 0,(P)
+ HRRZ C,@E.FRM+1(TB) ; GET ARG?
+ TRNE 0,F.OPT ; OPTIONAL
+ JUMPE C,APRDN
+ JUMPE C,TFA ; NO, TOO FEW ARGS
+ MOVEM C,E.FRM+1(TB)
+ HLLZ A,(C) ; GET ARG
+ MOVE B,1(C)
+ JSP E,CHKAB ; CHECK THEM
+
+APRTYC: MOVE C,A ; SET UP FOR TMATCH
+ MOVE D,B
+ EXCH B,(TP)
+ EXCH A,-1(TP) ; SAVE STUFF
+APRS11: PUSHJ P,TMATCH ; CHECK TYPE
+ JRST WTYP
+
+ MOVE 0,(P) ; RESTORE FLAGS
+ TRZ 0,F.STR
+ AOS E.CNT+1(TB)
+ JRST APRSU2 ; AND GO ON
+
+APREV0: TRNE 0,F.QUO ; ATTEMPT TO QUOTE ALREADY EVAL'D ARG ?
+ JRST MPD ; YES, LOSE
+APREVA: PUSHJ P,@E.ARG+1(TB) ; EVAL ONE
+ TDZA C,C ; C=0 ==> NONE LEFT
+ MOVEI C,1
+ MOVE 0,(P) ; FLAGS
+ JUMPN C,APRTYC ; GO CHECK TYPE
+APRDN: SUB TP,[2,,2] ; FLUSH DECL
+ TRNE 0,F.OPT ; OPTIONAL?
+ JRST APRDON ; ALL DONE
+ JRST TFA
+
+APRSU3: TRNE 0,F.STR ; END IN STRING?\b
+ JRST MPD
+ PUSHJ P,@E.ARG+1(TB) ; SEE IF ANYMORE ARGS
+ JRST APRDON
+ JRST TMA
+
+\f
+; STANDARD ARGUMENT GETTERS USED IN APPLYING THINGS
+
+ARGCDR: HRRZ C,@E.FRM+1(TB) ; POINT TO ARGLIST (NOTE: POINTS 1 BEFORE WHERE ARG IS)
+ JUMPE C,CPOPJ ; LEAVE IF DONE
+ MOVEM C,E.FRM+1(TB)
+ GETYP 0,(C) ; GET TYPE OF ARG
+ CAIN 0,TSEG
+ JRST ARGCD1 ; SEG MENT HACK
+ PUSHJ P,FASTEV
+ JRST CPOPJ1
+
+ARGCD1: PUSH TP,$TFORM ; PRETEND WE ARE A FORM
+ PUSH TP,1(C)
+ MCALL 1,EVAL
+ MOVEM A,E.SEG(TB)
+ MOVEM B,E.SEG+1(TB)
+ PUSHJ P,TYPSEG ; GET SEG TYPE CODE
+ HRRM C,E.ARG(TB) ; SAVE IT IN OBSCCURE PLACE
+ MOVE C,DSTORE ; FIX FOR TEMPLATE
+ MOVEM C,E.SEG(TB)
+ MOVE C,[SETZ SGARG]
+ MOVEM C,E.ARG+1(TB) ; SET NEW ARG GETTER
+
+; FALL INTO SEGARG
+
+SGARG: INTGO
+ HRRZ C,E.ARG(TB) ; SEG CODE TO C
+ MOVE D,E.SEG+1(TB)
+ MOVE A,E.SEG(TB)
+ MOVEM A,DSTORE
+ PUSHJ P,NXTLM ; GET NEXT ELEMENT
+ JRST SEGRG1 ; DONE
+ MOVEM D,E.SEG+1(TB)
+ MOVE D,DSTORE ; KEEP TYPE WINNING
+ MOVEM D,E.SEG(TB)
+ SETZM DSTORE
+ JRST CPOPJ1 ; RETURN
+
+SEGRG1: SETZM DSTORE
+ MOVEI C,ARGCDR
+ HRRM C,E.ARG+1(TB) ; RESET ARG GETTER
+ JRST ARGCDR
+
+; ARGUMENT GETTER FOR APPLY
+
+APLARG: INTGO
+ SKIPL A,E.FRM+1(TB) ; ANY ARGS LEFT
+ POPJ P, ; NO, EXIT IMMEDIATELY
+ ADD A,[2,,2]
+ MOVEM A,E.FRM+1(TB)
+ MOVE B,-1(A) ; RET NEXT ARG
+ MOVE A,-2(A)
+ JRST CPOPJ1
+
+; STACKFORM ARG GETTER
+
+EVALRG: SKIPN C,@E.FRM+1(TB) ; ANY FORM?
+ POPJ P,
+ PUSHJ P,FASTEV
+ GETYP A,A ; CHECK FOR FALSE
+ CAIN A,TFALSE
+ POPJ P,
+ MOVE C,E.FRM+1(TB) ; GET OTHER FORM
+ PUSHJ P,FASTEV
+ JRST CPOPJ1
+
+\f
+; HERE TO APPLY NUMBERS
+
+APNUM: PUSHJ P,PSH4ZR ; TP SLOTS
+ SKIPN A,E.EXTR(TB) ; FUNNY ARG?
+ JRST APNUM1 ; NOPE
+ MOVE B,E.EXTR+1(TB) ; GET ARG
+ JRST APNUM2
+
+APNUM1: PUSHJ P,@E.ARG+1(TB) ; GET ARG
+ JRST TFA
+APNUM2: PUSH TP,A
+ PUSH TP,B
+ PUSH TP,E.FCN(TB)
+ PUSH TP,E.FCN+1(TB)
+ PUSHJ P,@E.ARG+1(TB)
+ JRST .+2
+ JRST APNUM3
+ PUSHJ P,BLTDN ; FLUSH JUNK
+ MCALL 2,NTH
+ POPJ P,
+; HACK FOR TURNING <3 .FOO .BAR> INTO <PUT .FOO 3 .BAR>
+APNUM3: PUSH TP,A
+ PUSH TP,B
+ PUSHJ P,@E.ARG+1(TB)
+ JRST .+2
+ JRST TMA
+ PUSHJ P,BLTDN
+ GETYP A,-5(TP)
+ PUSHJ P,ISTRUC ; STRUCTURED FIRST ARG?
+ JRST WTYP1
+ MCALL 3,PUT
+ POPJ P,
+\f
+; HERE TO APPLY SUSSMAN FUNARGS
+
+APFUNARG:
+
+ SKIPN C,E.FCN+1(TB)
+ JRST FUNERR
+ HRRZ D,(C) ; MUST BE AT LEAST 2 LONG
+ JUMPE D,FUNERR
+ GETYP 0,(D) ; CHECK FOR LIST
+ CAIE 0,TLIST
+ JRST FUNERR
+ HRRZ 0,(D) ; SHOULD BE END
+ JUMPN 0,FUNERR
+ GETYP 0,(C) ; 1ST MUST BE FCN
+ CAIE 0,TEXPR
+ JRST FUNERR
+ SKIPN C,1(C)
+ JRST NOBODY
+ PUSHJ P,APEXPF ; BIND THE ARGS AND AUX'S
+ HRRZ C,RE.FCN+1(TB) ; GET BODY OF FUNARG
+ MOVE B,1(C) ; GET FCN
+ MOVEM B,RE.FCN+1(TB) ; AND SAVE
+ HRRZ C,(C) ; CDR FUNARG BODY
+ MOVE C,1(C)
+ MOVSI 0,TLIST ; SET UP TYPE
+ MOVE PVP,PVSTOR+1
+ MOVEM 0,CSTO(PVP) ; FOR INTS TO WIN
+
+FUNLP: INTGO
+ JUMPE C,DOF ; RUN IT
+ GETYP 0,(C)
+ CAIE 0,TLIST ; BETTER BE LIST
+ JRST FUNERR
+ PUSH TP,$TLIST
+ PUSH TP,C
+ PUSHJ P,NEXTDC ; GET POSSIBILITY
+ JRST FUNERR ; LOSER
+ CAIE A,2
+ JRST FUNERR
+ HRRZ B,(B) ; GET TO VALUE
+ MOVE C,(TP)
+ SUB TP,[2,,2]
+ PUSH TP,BNDA
+ PUSH TP,E
+ HLLZ A,(B) ; GET VAL
+ MOVE B,1(B)
+ JSP E,CHKAB ; HACK DEFER
+ PUSHJ P,PSHAB4 ; PUT VAL IN
+ HRRZ C,(C) ; CDR
+ JUMPN C,FUNLP
+
+; HERE TO RUN FUNARG
+
+DOF: MOVE PVP,PVSTOR+1
+ SETZM CSTO(PVP) ; DONT CONFUSE GC
+ PUSHJ P,SPECBIND ; BIND 'EM UP
+ JRST RUNFUN
+
+
+\f
+; HERE TO DO MACROS
+
+APMACR: HRRZ E,OTBSAV(TB)
+ HRRZ D,PCSAV(E) ; SEE WHERE FROM
+ CAIE D,EFCALL+1 ; 1STEP
+ JRST .+3
+ HRRZ E,OTBSAV(E)
+ HRRZ D,PCSAV(E)
+ CAIN D,AEVAL3 ; SKIP IF NOT RIGHT
+ JRST APMAC1
+ SKIPG E.ARG+1(TB) ; SKIP IF REAL FORM EXISTS
+ JRST BADMAC
+ MOVE A,E.FRM(TB)
+ MOVE B,E.FRM+1(TB)
+ SUB TP,[E.EXTR+2,,E.EXTR+2] ; FLUSH JUNK
+ PUSH TP,A
+ PUSH TP,B
+ MCALL 1,EXPAND ; EXPAND THE MACRO
+ PUSH TP,A
+ PUSH TP,B
+ MCALL 1,EVAL ; EVAL THE RESULT
+ POPJ P,
+
+APMAC1: MOVE C,E.FCN+1(TB) ; GET MACRO BODY
+ GETYP A,(C)
+ MOVE B,1(C)
+ MOVSI A,(A)
+ JSP E,CHKAB ; FIX DEFERS
+ MOVEM A,E.FCN(TB)
+ MOVEM B,E.FCN+1(TB)
+ JRST APLDIX
+
+; HERE TO APPLY EXPRS (FUNCTIONS)
+
+APEXPR: PUSHJ P,APEXP ; BIND ARGS AND AUX'S
+RUNFUN: HRRZ A,RE.FCN(TB) ; AMOUNT OF FCN TO SKIP
+ MOVEI C,RE.FCN+1(TB) ; POINT TO FCN
+ HRRZ C,(C) ; SKIP SOMETHING
+ SOJGE A,.-1 ; UNTIL 1ST FORM
+ MOVEM C,RE.FCN+1(TB) ; AND STORE
+ JRST DOPROG ; GO RUN PROGRAM
+
+APEXP: SKIPN C,E.FCN+1(TB) ; CHECK FRO BODY
+ JRST NOBODY
+APEXPF: PUSH P,[0] ; COUNT INIT CRAP
+ ADD TP,[XP.TMP,,XP.TMP] ; SLOTS FOR HACKING
+ SKIPL TP
+ PUSHJ P,TPOVFL
+ SETZM 1-XP.TMP(TP) ; ZERO OUT
+ MOVEI A,-XP.TMP+2(TP)
+ HRLI A,-1(A)
+ BLT A,(TP) ; ZERO SLOTS
+ SKIPG E.ARG+1(TB)
+ AOS E.CNT(TB) ; INDICATES IF MUST EVAL ARGS
+ MOVSI A,400000 ; MAKE E.ARG BE NEG FOR SAFE @ING
+ IORM A,E.ARG+1(TB)
+ PUSHJ P,CARATC ; SEE IF HEWITT ATOM EXISTS
+ JRST APEXP1 ; NO, GO LOOK FOR ARGLIST
+ MOVEM E,E.HEW+1(TB) ; SAVE ATOM
+ MOVSM 0,E.HEW(TB) ; AND TYPE
+ AOS (P) ; COUNT HEWITT ATOM
+APEXP1: GETYP 0,(C) ; LOOK AT NEXT THING
+ CAIE 0,TLIST ; BETTER BE LIST!!!
+ JRST MPD.0 ; LOSE
+ MOVE B,1(C) ; GET LIST
+ MOVEM B,E.ARGL+1(TB) ; SAVE
+ MOVSM 0,E.ARGL(TB) ; WITH TYPE
+ HRRZ C,(C) ; CDR THE FCN
+ JUMPE C,NOBODY ; BODYLESS FCN
+ GETYP 0,(C) ; SEE IF DCL LIST SUPPLIED
+ CAIE 0,TDECL
+ JRST APEXP2 ; NO, START PROCESSING ARGS
+ AOS (P) ; COUNT DCL
+ MOVE B,1(C)
+ MOVEM B,E.DECL+1(TB)
+ MOVSM 0,E.DECL(TB)
+ HRRZ C,(C) ; CDR ON
+ JUMPE C,NOBODY
+
+ ; CHECK FOR EXISTANCE OF EXTRA ARG
+
+APEXP2: POP P,A ; GET COUNT
+ HRRM A,E.FCN(TB) ; AND SAVE
+ SKIPN E.EXTR(TB) ; SKIP IF FUNNY EXTRA ARG EXISTS
+ JRST APEXP3
+ MOVE 0,[SETZ EXTRGT]
+ EXCH 0,E.ARG+1(TB)
+ HRRM 0,E.ARG(TB) ; SAVE OLD GETTER AROUND
+ AOS E.CNT(TB)
+
+; FALL THROUGH
+ \f
+; LOOK FOR "BIND" DECLARATION
+
+APEXP3: PUSHJ P,UNPROG ; UNASSIGN LPROG IF NEC
+APXP3A: SKIPN A,E.ARGL+1(TB) ; GET ARGLIST
+ JRST APEXP4 ; NONE, VERIFY NONE WERE GIVEN
+ PUSHJ P,NXTDCL ; SEE IF A DECL IS THERE
+ JRST BNDRG ; NO, GO BIND NORMAL ARGS
+ HRRZ C,(A) ; CDR THE DCLS
+ CAME B,[ASCII /BIND/]
+ JRST CH.CAL ; GO LOOK FOR "CALL"
+ PUSHJ P,CARTMC ; MUST BE AN ATOM
+ MOVEM C,E.ARGL+1(TB) ; AND SAVE CDR'D ARGS
+ PUSHJ P,MAKENV ; GENERATE AN ENVIRONMENT
+ PUSHJ P,PSBND1 ; PUSH THE BINDING AND CHECK THE DCL
+ JRST APXP3A ; IN CASE <"BIND" B "BIND" C......
+
+
+; LOOK FOR "CALL" DCL
+
+CH.CAL: CAME B,[ASCII /CALL/]
+ JRST CHOPT ; TRY SOMETHING ELSE
+; SKIPG E.ARG+1(TB) ; DONT SKIP IF CANT WIN
+ SKIPE E.CNT(TB)
+ JRST MPD.2
+ PUSHJ P,CARTMC ; BETTER BE AN ATOM
+ MOVEM C,E.ARGL+1(TB)
+ MOVE A,E.FRM(TB) ; RETURN FORM
+ MOVE B,E.FRM+1(TB)
+ PUSHJ P,PSBND1 ; BIND AND CHECK
+ JRST APEXP5
+ \f
+; BIND NORMAL ARGS BY CALLING BNDEM1, RETURNS WHEN ALL DONE
+
+BNDRG: PUSHJ P,BNDEM1 ; GO BIND THEM UP
+ TRNN A,4 ; SKIP IF HIT A DCL
+ JRST APEXP4 ; NOT A DCL, MUST BE DONE
+
+; LOOK FOR "OPTIONAL" DECLARATION
+
+CHOPT: CAMN B,[<ASCII /OPT/>]
+ JRST .+3
+ CAME B,[<ASCII /OPTIO/>+1]
+ JRST CHREST ; TRY TUPLE/ARGS
+ MOVEM C,E.ARGL+1(TB) ; SAVE RESTED ARGLIST
+ PUSHJ P,BNDEM2 ; DO ALL SUPPLIED OPTIONALS
+ TRNN A,4 ; SKIP IF NEW DCL READ
+ JRST APEXP4
+
+; CHECK FOR "ARGS" DCL
+
+CHREST: CAME B,[ASCII /ARGS/]
+ JRST CHRST1 ; GO LOOK FOR "TUPLE"
+; SKIPGE E.ARG+1(TB) ; SKIP IF LEGAL
+ SKIPE E.CNT(TB)
+ JRST MPD.3
+ PUSHJ P,CARTMC ; GOBBLE ATOM
+ MOVEM C,E.ARGL+1(TB) ; SAVE CDR'D ARG
+ HRRZ B,@E.FRM+1(TB) ; GET ARG LIST
+ MOVSI A,TLIST ; GET TYPE
+ PUSHJ P,PSBND1
+ JRST APEXP5
+
+; HERE TO CHECK FOR "TUPLE"
+
+CHRST1: CAME B,[ASCII /TUPLE/]
+ JRST APXP10
+ PUSHJ P,CARTMC ; GOBBLE ATOM
+ MOVEM C,E.ARGL+1(TB)
+ SETZB A,B
+ PUSHJ P,PSHBND ; SET UP BINDING
+ SETZM E.CNT+1(TB) ; ZERO ARG COUNTER
+
+TUPLP: PUSHJ P,@E.ARG+1(TB) ; GET AN ARG
+ JRST TUPDON ; FINIS
+ AOS E.CNT+1(TB)
+ PUSH TP,A
+ PUSH TP,B
+ JRST TUPLP
+
+TUPDON: PUSHJ P,MAKINF ; MAKE INFO CELL
+ PUSH TP,$TINFO ; FENCE POST TUPLE
+ PUSHJ P,TBTOTP
+ ADDI D,TM.OFF ; COMPENSATE FOR MOVEMENT
+ PUSH TP,D
+ MOVE C,E.CNT+1(TB) ; GET COUNT
+ ASH C,1 ; TO WORDS
+ HRRM C,-1(TP) ; INTO FENCE POST
+ MOVEI B,-TM.OFF-1(TP) ; SETUP ARG POINTER
+ SUBI B,(C) ; POINT TO BASE OF TUPLE
+ MOVNS C ; FOR AOBJN POINTER
+ HRLI B,(C) ; GOOD ARGS POINTER
+ MOVEM A,TM.OFF-4(B) ; STORE
+ MOVEM B,TM.OFF-3(B)
+
+\f
+; CHECK FOR VALID ENDING TO ARGS
+
+APEXP5: PUSHJ P,NEXTD ; READ NEXT THING IN ARGLIST
+ JRST APEXP8 ; DONE
+ TRNN A,4 ; SKIP IF DCL
+ JRST MPD.4 ; LOSER
+APEXP7: MOVSI A,-NWINS ; CHECK FOR A WINNER
+ CAME B,WINRS(A)
+ AOBJN A,.-1
+ JUMPGE A,MPD.6 ; NOT A WINNER
+
+; HERE TO BLT THE WORLD DOWN ON TOP OF ALL THE USELESS TEMPS
+
+APEXP8: MOVE 0,E.HEW+1(TB) ; GET HEWITT ATOM
+ MOVE E,E.FCN(TB) ; SAVE COUNTER
+ MOVE C,E.FCN+1(TB) ; FCN
+ MOVE B,E.ARGL+1(TB) ; ARG LIST
+ MOVE D,E.DECL+1(TB) ; AND DCLS
+ MOVEI A,R.TMP(TB) ; SET UP BLT
+ HRLI A,TM.OFF(A)
+ BLT A,-TM.OFF(TP) ; BLLLLLLLLLLLLLT
+ SUB TP,[TM.OFF,,TM.OFF] ; FLUSH CRUFT
+ MOVEM E,RE.FCN(TB)
+ MOVEM C,RE.FCN+1(TB)
+ MOVEM B,RE.ARGL+1(TB)
+ MOVE E,TP
+ PUSH TP,$TATOM
+ PUSH TP,0
+ PUSH TP,$TDECL
+ PUSH TP,D
+ GETYP A,-5(TP) ; TUPLE ON TOP?
+ CAIE A,TINFO ; SKIP IF YES
+ JRST APEXP9
+ HRRZ A,-5(TP) ; GET SIZE
+ ADDI A,2
+ HRLI A,(A)
+ SUB E,A ; POINT TO BINDINGS
+ SKIPE C,(TP) ; IF DCL
+ PUSHJ P,CHKDCL ; CHECK TYPE SPEC ON TUPLE
+APEXP9: PUSHJ P,USPCBE ; DO ACTUAL BINDING
+
+ MOVE E,-2(TP) ; RESTORE HEWITT ATOM
+ MOVE D,(TP) ; AND DCLS
+ SUB TP,[4,,4]
+
+ JRST AUXBND ; GO BIND AUX'S
+
+; HERE TO VERIFY CHECK IF ANY ARGS LEFT
+
+APEXP4: PUSHJ P,@E.ARG+1(TB)
+ JRST APEXP8 ; WIN
+ JRST TMA ; TOO MANY ARGS
+
+APXP10: PUSH P,B
+ PUSHJ P,@E.ARG+1(TB)
+ JRST .+2
+ JRST TMA
+ POP P,B
+ JRST APEXP7
+
+; LIST OF POSSIBLE TERMINATING NAMES
+
+WINRS:
+AS.ACT: ASCII /ACT/
+AS.NAM: ASCII /NAME/
+AS.AUX: ASCII /AUX/
+AS.EXT: ASCII /EXTRA/
+NWINS==.-WINRS
+
+ \f
+; HERE TO BIND AUX VARIABLES FOR PROGS AND FCNS
+
+AUXBND: PUSH P,E ; SAVE HEWITT ATOM ( WILL PUT ON MARKED STACK
+ ; WHEN NECESSARY)
+ PUSH P,D ; SAME WITH DCL LIST
+ PUSH P,[-1] ; FLAG SAYING WE ARE FCN
+ SKIPN C,RE.ARG+1(TB) ; GET ARG LIST
+ JRST AUXDON
+ GETYP 0,(C) ; GET TYPE
+ CAIE 0,TDEFER ; SKIP IF CHSTR
+ MOVMS (P) ; SAY WE ARE IN OPTIONALS
+ JRST AUXB1
+
+PRGBND: PUSH P,E
+ PUSH P,D
+ PUSH P,[0] ; WE ARE IN AUXS
+
+AUXB1: HRRZ C,RE.ARG+1(TB) ; POINT TO ARGLIST
+ PUSHJ P,NEXTDC ; GET NEXT THING OFF OF ARG LIST
+ JRST AUXDON
+ TRNE A,4 ; SKIP IF SOME KIND OF ATOM
+ JRST TRYDCL ; COUDL BE DCL
+ TRNN A,1 ; SKIP IF QUOTED
+ JRST AUXB2
+ SKIPN (P) ; SKIP IF QUOTED OK
+ JRST MPD.11
+AUXB2: PUSHJ P,PSHBND ; SET UP BINDING
+ PUSH TP,$TDECL ; SAVE HEWITT ATOM
+ PUSH TP,-1(P)
+ PUSH TP,$TATOM ; AND DECLS
+ PUSH TP,-2(P)
+ TRNN A,2 ; SKIP IF INIT VAL EXISTS
+ JRST AUXB3 ; NO, USE UNBOUND
+
+; EVALUATE EXPRESSION
+
+ HRRZ C,(B) ; CDR ATOM OFF
+
+; CHECK FOR SPECIAL FORMS <TUPLE ...> <ITUPLE ...>
+
+ GETYP 0,(C) ; GET TYPE OF GOODIE
+ CAIE 0,TFORM ; SMELLS LIKE A FORM
+ JRST AUXB13
+ HRRZ D,1(C) ; GET 1ST ELEMENT
+ GETYP 0,(D) ; AND ITS VAL
+ CAIE 0,TATOM ; FEELS LIKE THE RIGHT FORM
+ JRST AUXB13
+
+ MOVE 0,1(D) ; GET THE ATOM
+ CAME 0,IMQUOTE TUPLE
+ CAMN 0,MQUOTE ITUPLE
+ JRST DOTUPL ; SURE GLAD I DIDN'T STEP IN THAT FORM
+
+
+AUXB13: PUSHJ P,FASTEV
+AUXB14: MOVE E,TP
+AUXB4: MOVEM A,-7(E) ; STORE VAL IN BINDING
+ MOVEM B,-6(E)
+
+; HERE TO CHECK AGAINST DECLARATIONS AND COMPLETE THE BINDING
+
+AUXB5: SUB E,[4,,4] ; POINT TO BINDING TOP
+ SKIPE C,-2(TP) ; POINT TO DECLARATINS
+ PUSHJ P,CHKDCL ; CHECK IT
+ PUSHJ P,USPCBE ; AND BIND UP
+ SKIPE C,RE.ARG+1(TB) ; CDR DCLS
+ HRRZ C,(C) ; IF ANY TO CDR
+ MOVEM C,RE.ARG+1(TB)
+ MOVE A,(TP) ; NOW PUT HEWITT ATOM AND DCL AWAY
+ MOVEM A,-2(P)
+ MOVE A,-2(TP)
+ MOVEM A,-1(P)
+ SUB TP,[4,,4] ; FLUSH SLOTS
+ JRST AUXB1
+
+
+AUXB3: MOVNI B,1
+ MOVSI A,TUNBOU
+ JRST AUXB14
+
+\f
+
+; HERE TO HANDLE "CALLS" TO TUPLE AND ITUPLE
+
+DOTUPL: SKIPE E,(P) ; SKIP IF IN AUX LIST
+ JRST TUPLE
+ PUSH TP,$TLIST ; SAVE THE MAGIC FORM
+ PUSH TP,D
+ CAME 0,IMQUOTE TUPLE
+ JRST DOITUP ; DO AN ITUPLE
+
+; FALL INTO A TUPLE PUSHING LOOP
+
+DOTUP1: HRRZ C,@(TP) ; CDR THE FORM
+ JUMPE C,ATUPDN ; FINISHED
+ MOVEM C,(TP) ; SAVE CDR'D RESULT
+ GETYP 0,(C) ; CHECK FOR SEGMENT
+ CAIN 0,TSEG
+ JRST DTPSEG ; GO PULL IT APART
+ PUSHJ P,FASTEV ; EVAL IT
+ PUSHJ P,CNTARG ; PUSH IT UP AND COUNT THEM
+ JRST DOTUP1
+
+; HERE WHEN WE FINISH
+
+ATUPDN: SUB TP,[2,,2] ; FLUSH THE LIST
+ ASH E,1 ; E HAS # OF ARGS DOUBLE IT
+ MOVEI D,(TP) ; FIND BASE OF STACK AREA
+ SUBI D,(E)
+ MOVSI C,-3(D) ; PREPARE BLT POINTER
+ BLT C,C ; HEWITT ATOM AND DECL TO 0,A,B,C
+
+; NOW PREPEARE TO BLT TUPLE DOWN
+
+ MOVEI D,-3(D) ; NEW DEST
+ HRLI D,4(D) ; SOURCE
+ BLT D,-4(TP) ; SLURP THEM DOWN
+
+ HRLI E,TINFO ; SET UP FENCE POST
+ MOVEM E,-3(TP) ; AND STORE
+ PUSHJ P,TBTOTP ; GET OFFSET
+ ADDI D,3 ; FUDGE FOR NOT AT TOP OF STACK
+ MOVEM D,-2(TP)
+ MOVEM 0,-1(TP) ; RESTORE HEW ATOM AND DECLS
+ MOVEM A,(TP)
+ PUSH TP,B
+ PUSH TP,C
+
+ PUSHJ P,MAKINF ; MAKE 1ST WORD OF FUNNYS
+
+ HRRZ E,-5(TP) ; RESTORE WORDS OF TUPLE
+ HRROI B,-5(TP) ; POINT TO TOP OF TUPLE
+ SUBI B,(E) ; NOW BASE
+ TLC B,-1(E) ; FIX UP AOBJN PNTR
+ ADDI E,2 ; COPNESATE FOR FENCE PST
+ HRLI E,(E)
+ SUBM TP,E ; E POINT TO BINDING
+ JRST AUXB4 ; GO CLOBBER IT IN
+\f
+
+; HERE TO HANDLE SEGMENTS IN THESE FUNNY FORMS
+
+DTPSEG: PUSH TP,$TFORM ; SAVE THE HACKER
+ PUSH TP,1(C)
+ MCALL 1,EVAL ; AND EVALUATE IT
+ MOVE D,B ; GET READY FOR A SEG LOOP
+ MOVEM A,DSTORE
+ PUSHJ P,TYPSEG ; TYPE AND CHECK IT
+
+DTPSG1: INTGO ; DONT BLOW YOUR STACK
+ PUSHJ P,NXTLM ; ELEMENT TO A AND B
+ JRST DTPSG2 ; DONE
+ PUSHJ P,CNTARG ; PUSH AND COUNT
+ JRST DTPSG1
+
+DTPSG2: SETZM DSTORE
+ HRRZ E,-1(TP) ; GET COUNT IN CASE END
+ JRST DOTUP1 ; REST OF ARGS STILL TO DO
+
+; HERE TO HACK <ITUPLE .....>
+
+DOITUP: HRRZ C,@(TP) ; GET COUNT FILED
+ JUMPE C,TFA
+ MOVEM C,(TP)
+ PUSHJ P,FASTEV ; EVAL IT
+ GETYP 0,A
+ CAIE 0,TFIX
+ JRST WTY1TP
+
+ JUMPL B,BADNUM
+
+ HRRZ C,@(TP) ; GET EXP TO EVAL
+ MOVEI 0,0 ; DONT LOSE IN 1 ARG CASE
+ HRRZ 0,(C) ; VERIFY WINNAGE
+ JUMPN 0,TMA ; TOO MANY
+
+ JUMPE B,DOIDON
+ PUSH P,B ; SAVE COUNT
+ PUSH P,B
+ JUMPE C,DOILOS
+ PUSHJ P,FASTEV ; EVAL IT ONCE
+ MOVEM A,-1(TP)
+ MOVEM B,(TP)
+
+DOILP: INTGO
+ PUSH TP,-1(TP)
+ PUSH TP,-1(TP)
+ MCALL 1,EVAL
+ PUSHJ P,CNTRG
+ SOSLE (P)
+ JRST DOILP
+
+DOIDO1: MOVE B,-1(P) ; RESTORE COUNT
+ SUB P,[2,,2]
+
+DOIDON: MOVEI E,(B)
+ JRST ATUPDN
+
+; FOR CASE OF NO EVALE
+
+DOILOS: SUB TP,[2,,2]
+DOILLP: INTGO
+ PUSH TP,[0]
+ PUSH TP,[0]
+ SOSL (P)
+ JRST DOILLP
+ JRST DOIDO1
+
+; ROUTINE TO PUSH NEXT TUPLE ELEMENT
+
+CNTARG: AOS E,-1(TP) ; KEEP ARG COUNT UP TO DATE IN E
+CNTRG: EXCH A,-1(TP) ; STORE ELEM AND GET SAVED
+ EXCH B,(TP)
+ PUSH TP,A
+ PUSH TP,B
+ POPJ P,
+
+
+; DUMMY TUPLE AND ITUPLE
+
+IMFUNCTION TUPLE,SUBR
+
+ ENTRY
+ ERRUUO EQUOTE NOT-IN-AUX-LIST
+
+MFUNCTIO ITUPLE,SUBR
+ JRST TUPLE
+
+\f
+; PROCESS A DCL IN THE AUX VAR LISTS
+
+TRYDCL: SKIPN (P) ; SKIP IF NOT IN AUX'S
+ JRST AUXB7
+ CAME B,AS.AUX ; "AUX" ?
+ CAMN B,AS.EXT ; OR "EXTRA"
+ JRST AUXB9 ; YES
+ CAME B,[ASCII /TUPLE/]
+ JRST AUXB10
+ PUSHJ P,MAKINF ; BUILD EMPTY TUPLE
+ MOVEI B,1(TP)
+ PUSH TP,$TINFO ; FENCE POST
+ PUSHJ P,TBTOTP
+ PUSH TP,D
+AUXB6: HRRZ C,(C) ; CDR PAST DCL
+ MOVEM C,RE.ARG+1(TB)
+AUXB8: PUSHJ P,CARTMC ; GET ATOM
+AUXB12: PUSHJ P,PSHBND ; UP GOES THE BINDING
+ PUSH TP,$TATOM ; HIDE HEWITT ATOM AND DCL
+ PUSH TP,-1(P)
+ PUSH TP,$TDECL
+ PUSH TP,-2(P)
+ MOVE E,TP
+ JRST AUXB5
+
+; CHECK FOR ARGS
+
+AUXB10: CAME B,[ASCII /ARGS/]
+ JRST AUXB7
+ MOVEI B,0 ; NULL ARG LIST
+ MOVSI A,TLIST
+ JRST AUXB6 ; GO BIND
+
+AUXB9: SETZM (P) ; NOW READING AUX
+ HRRZ C,(C)
+ MOVEM C,RE.ARG+1(TB)
+ JRST AUXB1
+
+; CHECK FOR NAME/ACT
+
+AUXB7: CAME B,AS.NAM
+ CAMN B,AS.ACT
+ JRST .+2
+ JRST MPD.12 ; LOSER
+ HRRZ C,(C) ; CDR ON
+ HRRZ 0,(C) ; BETTER BE END
+ JUMPN 0,MPD.13
+ PUSHJ P,CARTMC ; FORCE ATOM READ
+ SETZM RE.ARG+1(TB)
+AUXB11: PUSHJ P,MAKACT ; MAKE ACTIVATION
+ JRST AUXB12 ; AND BIND IT
+
+
+; DONE BIND HEWITT ATOM IF NECESARY
+
+AUXDON: SKIPN E,-2(P)
+ JRST AUXD1
+ SETZM -2(P)
+ JRST AUXB11
+
+; FINISHED, RETURN
+
+AUXD1: SUB P,[3,,3]
+ POPJ P,
+
+
+; MAKE AN ACTIVATION OR ENVIRONMNENT
+
+MAKACT: MOVEI B,(TB)
+ MOVSI A,TACT
+MAKAC1: MOVE PVP,PVSTOR+1
+ HRRI A,PVLNT*2+1(PVP) ; POINT TO PROCESS
+ HLL B,OTBSAV(B) ; GET TIME
+ POPJ P,
+
+MAKENV: MOVSI A,TENV
+ HRRZ B,OTBSAV(TB)
+ JRST MAKAC1
+\f
+; SEVERAL USEFUL LITTLE ROUTINES FOR HACKING THIS STUFF
+
+; CARAT/CARATC/CARATM/CARTMC ALL LOOK FOR THE NEXT ATOM
+
+CARAT: HRRZ C,E.ARGL+1(TB) ; PICK UP ARGLIST
+CARATC: JUMPE C,CPOPJ ; FOUND
+ GETYP 0,(C) ; GET ITS TYPE
+ CAIE 0,TATOM
+CPOPJ: POPJ P, ; RETURN, NOT ATOM
+ MOVE E,1(C) ; GET ATOM
+ HRRZ C,(C) ; CDR DCLS
+ JRST CPOPJ1
+
+CARATM: HRRZ C,E.ARGL+1(TB)
+CARTMC: PUSHJ P,CARATC
+ JRST MPD.7 ; REALLY LOSE
+ POPJ P,
+
+
+; SUBROUTINES TO PUSH BINDINGS ETC. UP ON THE STACK
+
+PSBND1: PUSHJ P,PSHBND ; PUSH THEBINDING
+ JRST CHDCL ; NOW CHECK IT AGAINST DECLARATION
+
+PSHBND: SKIPGE SPCCHK ; SKIP IF NORMAL SPECIAL
+ PUSH TP,BNDA1 ; ATOM IN E
+ SKIPL SPCCHK ; SKIP IF NORMAL UNSPEC OR NO CHECK
+ PUSH TP,BNDA
+ PUSH TP,E ; PUSH IT
+PSHAB4: PUSH TP,A
+ PUSH TP,B
+ PUSH TP,[0]
+ PUSH TP,[0]
+ POPJ P,
+
+; ROUTINE TO PUSH 4 0'S
+
+PSH4ZR: SETZB A,B
+ JRST PSHAB4
+
+
+; EXTRRA ARG GOBBLER
+
+EXTRGT: HRRZ A,E.ARG(TB) ; RESET SLOT
+ SETZM E.CNT(TB)
+ CAIE A,ARGCDR ; IF NOT ARGCDR
+ AOS E.CNT(TB)
+ TLO A,400000 ; SET FLAG
+ MOVEM A,E.ARG+1(TB)
+ MOVE A,E.EXTR(TB) ; RET ARG
+ MOVE B,E.EXTR+1(TB)
+ JRST CPOPJ1
+
+; CHECK A/B FOR DEFER
+
+CHKAB: GETYP 0,A
+ CAIE 0,TDEFER ; SKIP IF DEFER
+ JRST (E)
+ MOVE A,(B)
+ MOVE B,1(B) ; GET REAL THING
+ JRST (E)
+; IF DECLARATIONS EXIST, DO THEM
+
+CHDCL: MOVE E,TP
+CHDCLE: SKIPN C,E.DECL+1(TB)
+ POPJ P,
+ JRST CHKDCL
+\f
+; ROUTINE TO READ NEXT THING FROM ARGLIST
+
+NEXTD: HRRZ C,E.ARGL+1(TB) ; GET ARG LIST
+NEXTDC: MOVEI A,0
+ JUMPE C,CPOPJ
+ PUSHJ P,CARATC ; TRY FOR AN ATOM
+ JRST NEXTD1 ; NO
+ JRST CPOPJ1
+
+NEXTD1: CAIE 0,TFORM ; FORM?
+ JRST NXT.L ; COULD BE LIST
+ PUSHJ P,CHQT ; VERIFY 'ATOM
+ MOVEI A,1
+ JRST CPOPJ1
+
+NXT.L: CAIE 0,TLIST ; COULD BE (A <EXPRESS>) OR ('A <EXPRESS>)
+ JRST NXT.S ; BETTER BE A DCL
+ PUSHJ P,LNT.2 ; VERIFY LENGTH IS 2
+ JRST MPD.8
+ CAIE 0,TATOM ; TYPE OF 1ST RET IN 0
+ JRST LST.QT ; MAY BE 'ATOM
+ MOVE E,1(B) ; GET ATOM
+ MOVEI A,2
+ JRST CPOPJ1
+LST.QT: CAIE 0,TFORM ; FORM?
+ JRST MPD.9 ; LOSE
+ PUSH P,C
+ MOVEI C,(B) ; VERIFY 'ATOM
+ PUSHJ P,CHQT
+ MOVEI B,(C) ; POINT BACK TO LIST
+ POP P,C
+ MOVEI A,3 ; CODE
+ JRST CPOPJ1
+
+NXT.S: MOVEI A,(C) ; LET NXTDCL FIND OUT
+ PUSHJ P,NXTDCL
+ JRST MPD.3 ; LOSER
+ MOVEI A,4 ; SET DCL READ FLAG
+ JRST CPOPJ1
+
+; ROUTINE TO CHECK LENGTH OF LIST/FORM FOR BEING 2
+
+LNT.2: HRRZ B,1(C) ; GET LIST/FORM
+ JUMPE B,CPOPJ
+ HRRZ B,(B)
+ JUMPE B,CPOPJ
+ HRRZ B,(B) ; BETTER END HERE
+ JUMPN B,CPOPJ
+ HRRZ B,1(C) ; LIST BACK
+ GETYP 0,(B) ; TYPE OF 1ST ELEMENT
+ JRST CPOPJ1
+
+; ROUTINE TO VERIFY FORM IS 'ATOM AND RET ATOM
+
+CHQT: PUSHJ P,LNT.2 ; 1ST LENGTH CHECK
+ JRST MPD.5
+ CAIE 0,TATOM
+ JRST MPD.5
+ MOVE 0,1(B)
+ CAME 0,IMQUOTE QUOTE
+ JRST MPD.5 ; BETTER BE QUOTE
+ HRRZ E,(B) ; CDR
+ GETYP 0,(E) ; TYPE
+ CAIE 0,TATOM
+ JRST MPD.5
+ MOVE E,1(E) ; GET QUOTED ATOM
+ POPJ P,
+\f
+; ARG BINDER FOR REGULAR ARGS AND OPTIONALS
+
+BNDEM1: PUSH P,[0] ; REGULAR FLAG
+ JRST .+2
+BNDEM2: PUSH P,[1]
+BNDEM: PUSHJ P,NEXTD ; GET NEXT THING
+ JRST CCPOPJ ; END OF THINGS
+ TRNE A,4 ; CHECK FOR DCL
+ JRST BNDEM4
+ TRNE A,2 ; SKIP IF NOT (ATM ..) OR ('ATM ...)
+ SKIPE (P) ; SKIP IF REG ARGS
+ JRST .+2 ; WINNER, GO ON
+ JRST MPD.6 ; LOSER
+ SKIPGE SPCCHK
+ PUSH TP,BNDA1 ; SAVE ATOM
+ SKIPL SPCCHK
+ PUSH TP,BNDA
+ PUSH TP,E
+; SKIPGE E.ARG+1(TB) ; ALREADY EVAL'D ARG?
+ SKIPE E.CNT(TB)
+ JRST RGLAR0
+ TRNN A,1 ; SKIP IF ARG QUOTED
+ JRST RGLARG
+ HRRZ D,@E.FRM+1(TB) ; GET AND CDR ARG
+ JUMPE D,TFACHK ; OH OH MAYBE TOO FEW ARGS
+ MOVEM D,E.FRM+1(TB) ; STORE WINNER
+ HLLZ A,(D) ; GET ARG
+ MOVE B,1(D)
+ JSP E,CHKAB ; HACK DEFER
+ JRST BNDEM3 ; AND GO ON
+
+RGLAR0: TRNE A,1 ; ATTEMPT TO QUOTE ALREADY EVAL'D ARG ?
+ JRST MPD ; YES, LOSE
+RGLARG: PUSH P,A ; SAVE FLAGS
+ PUSHJ P,@E.ARG+1(TB)
+ JRST TFACH1 ; MAY GE TOO FEW
+ SUB P,[1,,1]
+BNDEM3: HRRZ C,@E.ARGL+1(TB) ; CDR THHE ARGS
+ MOVEM C,E.ARGL+1(TB)
+ PUSHJ P,PSHAB4 ; PUSH VALUE AND SLOTS
+ PUSHJ P,CHDCL ; CHECK DCLS
+ JRST BNDEM ; AND BIND ON!
+
+; HERE WHEN ARGS RUN OUT, IF NOT OPTIONAL, GIVE TFA
+
+TFACH1: POP P,A
+TFACHK: SUB TP,[2,,2] ; FLUSH ATOM
+ SKIPN (P) ; SKIP IF OPTIONALS
+ JRST TFA
+CCPOPJ: SUB P,[1,,1]
+ POPJ P,
+
+BNDEM4: HRRZ C,@E.ARGL+1(TB) ; POINT TO REST OF ARGL
+ JRST CCPOPJ
+\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
+ JSP E,CHKARG ; CHECK DEFER
+ 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 EVL10 ;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
+EVL10: GETYPF A,(AB) ; USE SENT TYPE
+ JRST EFINIS
+
+\f
+; PROCESS SEGMENTS FOR THESE HACKS
+
+DOSEG: PUSHJ P,TYPSEG ; FIND WHAT IS BEING SEGMENTED
+ JUMPE C,LSTSEG ; CHECK END SPLICE IF LIST
+
+SEG3: PUSHJ P,NXTELM ; GET THE NEXTE ELEMT
+ JRST SEG4 ; RETURN TO CALLER
+ AOS (P) ; COUNT
+ JRST SEG3 ; TRY AGAIN
+SEG4: SETZM DSTORE
+ JRST EVL6
+
+TYPSEG: PUSHJ P,TYPSGR
+ JRST ILLSEG
+ POPJ P,
+
+TYPSGR: MOVE E,A ; SAVE TYPE
+ GETYP A,A ; TYPE TO RH
+ PUSHJ P,SAT ;GET STORAGE TYPE
+ MOVE D,B ; GOODIE TO D
+
+ MOVNI C,1 ; C <0 IF ILLEGAL
+ CAIN A,S2WORD ;LIST?
+ MOVEI C,0
+ CAIN A,S2NWORD ;GENERAL VECTOR?
+ MOVEI C,1
+ CAIN A,SNWORD ;UNIFORM VECTOR?
+ MOVEI C,2
+ CAIN A,SCHSTR
+ MOVEI C,3
+ CAIN A,SBYTE
+ MOVEI C,5
+ CAIN A,SSTORE ;SPECIAL AFREE STORAGE ?
+ MOVEI C,4 ;TREAT LIKE A UVECTOR
+ CAIN A,SARGS ;ARGS TUPLE?
+ JRST SEGARG ;NO, ERROR
+ CAILE A,NUMSAT ; SKIP IF NOT TEMPLATE
+ JRST SEGTMP
+ MOVE A,PTYPS(C)
+ CAIN A,4
+ MOVEI A,2 ; NOW TREAT LIKE A UVECTOR
+ HLL E,A
+MSTOR1: JUMPL C,CPOPJ
+
+MDSTOR: MOVEM E,DSTORE
+ JRST CPOPJ1
+
+SEGTMP: MOVEI C,4
+ HRRI E,(A)
+ JRST MSTOR1
+
+SEGARG: MOVSI A,TARGS
+ HRRI A,(E)
+ PUSH TP,A ;PREPARE TO CHECK ARGS
+ PUSH TP,D
+ MOVEI B,-1(TP) ;POINT TO SAVED COPY
+ PUSHJ P,CHARGS ;CHECK ARG POINTER
+ POP TP,D ;AND RESTORE WINNER
+ POP TP,E ;AND TYPE AND FALL INTO VECTOR CODE
+ MOVEI C,1
+ JRST MSTOR1
+
+LSTSEG: SKIPL -1(P) ;SKIP IF IN A LIST
+ JRST SEG3 ;ELSE JOIN COMMON CODE
+ HRRZ A,@1(TB) ;CHECK FOR END OF LIST
+ JUMPN A,SEG3 ;NO, JOIN COMMON CODE
+ SETZM DSTORE ;CLOBBER SAVED GOODIES
+ JRST EVL9 ;AND FINISH UP
+
+NXTELM: INTGO
+ PUSHJ P,NXTLM ; GOODIE TO A AND B
+ POPJ P, ; DONE
+ PUSH TP,A
+ PUSH TP,B
+ JRST CPOPJ1
+NXTLM: XCT TESTR(C) ; SKIP IF MORE IN SEGEMNT
+ POPJ P,
+ XCT TYPG(C) ; GET THE TYPE
+ XCT VALG(C) ; AND VALUE
+ JSP E,CHKAB ; CHECK DEFERRED
+ XCT INCR1(C) ; AND INCREMENT TO NEXT
+CPOPJ1: AOS (P) ; SKIP RETURN
+ POPJ P,
+
+; TABLES FOR SEGMENT OPERATIONS (0->LIST, 1->VECTOR/ARGS, 2->UVEC, 3->STRING)
+
+PTYPS: TLIST,,
+ TVEC,,
+ TUVEC,,
+ TCHSTR,,
+ TSTORA,,
+ TBYTE,,
+
+TESTR: SKIPN D
+ SKIPL D
+ SKIPL D
+ PUSHJ P,CHRDON
+ PUSHJ P,TM1
+ PUSHJ P,CHRDON
+
+TYPG: PUSHJ P,LISTYP
+ GETYPF A,(D)
+ PUSHJ P,UTYPE
+ MOVSI A,TCHRS
+ PUSHJ P,TM2
+ MOVSI A,TFIX
+
+VALG: MOVE B,1(D)
+ MOVE B,1(D)
+ MOVE B,(D)
+ PUSHJ P,1CHGT
+ PUSHJ P,TM3
+ PUSHJ P,1CHGT
+
+INCR1: HRRZ D,(D)
+ ADD D,[2,,2]
+ ADD D,[1,,1]
+ PUSHJ P,1CHINC
+ ADD D,[1,,]
+ PUSHJ P,1CHINC
+
+TM1: HRRZ A,DSTORE
+ SKIPE DSTORE
+ HRRZ A,DSTORE ; GET SAT
+ SUBI A,NUMSAT+1
+ ADD A,TD.LNT+1
+ EXCH C,D
+ XCT (A)
+ HLRZ 0,C ; GET AMNT RESTED
+ SUB B,0
+ EXCH C,D
+ TRNE B,-1
+ AOS (P)
+ POPJ P,
+
+TM3:
+TM2: HRRZ 0,DSTORE
+ SKIPE DSTORE
+ HRRZ 0,DSTORE
+ PUSH P,C
+ PUSH P,D
+ PUSH P,E
+ MOVE B,D
+ MOVEI C,0 ; GET "1ST ELEMENT"
+ PUSHJ P,TMPLNT ; GET NTH IN A AND B
+ POP P,E
+ POP P,D
+ POP P,C
+ POPJ P,
+
+CHRDON: HRRZ B,DSTORE
+ SKIPE DSTORE
+ HRRZ B,DSTORE ; POIT TO DOPE WORD
+ JUMPE B,CHRFIN
+ AOS (P)
+CHRFIN: POPJ P,
+
+LISTYP: GETYP A,(D)
+ MOVSI A,(A)
+ POPJ P,
+1CHGT: MOVE B,D
+ ILDB B,B
+ POPJ P,
+
+1CHINC: IBP D
+ SKIPN DSTORE
+ JRST 1CHIN1
+ SOS DSTORE
+ POPJ P,
+
+1CHIN1: SOS DSTORE
+ POPJ P,
+
+UTYPE: HLRE A,D
+ SUBM D,A
+ GETYP A,(A)
+ MOVSI A,(A)
+ POPJ P,
+
+
+;COMPILER's CALL TO DOSEG
+SEGMNT: PUSHJ P,TYPSEG
+SEGLP1: SETZB A,B
+SEGLOP: PUSHJ P,NXTELM
+ JRST SEGRET
+ AOS (P)-2 ; INCREMENT COMPILER'S COUNT
+ JRST SEGLOP
+
+SEGRET: SETZM DSTORE
+ POPJ P,
+
+SEGLST: PUSHJ P,TYPSEG
+ JUMPN C,SEGLS2
+SEGLS3: SETZM DSTORE
+ MOVSI A,TLIST
+SEGLS1: SOSGE -2(P) ; START COUNT DOWN
+ POPJ P,
+ MOVEI E,(B)
+ POP TP,D
+ POP TP,C
+ PUSHJ P,ICONS
+ JRST SEGLS1
+
+SEGLS2: PUSHJ P,NXTELM
+ JRST SEGLS4
+ AOS -2(P)
+ JRST SEGLS2
+
+SEGLS4: MOVEI B,0
+ JRST SEGLS3
+\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.
+
+BNDA1: TATOM,,-2
+BNDA: TATOM,,-1
+BNDV: TVEC,,-1
+
+USPECBIND:
+ MOVE E,TP
+USPCBE: PUSH P,$TUBIND
+ JRST .+3
+
+SPECBIND:
+ MOVE E,TP ;GET THE POINTER TO TOP
+SPECBE: PUSH P,$TBIND
+ ADD E,[1,,1] ;BUMP POINTER ONCE
+ SETZB 0,D ;CLEAR TEMPS
+ PUSH P,0
+ MOVEI 0,(TB) ; FOR CHECKS
+
+BINDLP: MOVE A,-4(E) ; CHECK FOR VEC BIND
+ CAMN A,BNDV
+ JRST NONID
+ MOVE A,-6(E) ;GET TYPE
+ CAME A,BNDA1 ; FOR UNSPECIAL
+ CAMN A,BNDA ;NORMAL ID BIND?
+ CAILE 0,-6(E) ; MAKE SURE NOT GOING UNDER FRAME
+ JRST SPECBD
+ SUB E,[6,,6] ;MOVE PTR
+ SKIPE D ;LINK?
+ HRRM E,(D) ;YES -- LOBBER
+ SKIPN (P) ;UPDATED?
+ MOVEM E,(P) ;NO -- DO IT
+
+ MOVE A,0(E) ;GET ATOM PTR
+ MOVE B,1(E)
+ PUSHJ P,SILOC ;GET LAST BINDING
+ MOVS A,OTBSAV (TB) ;GET TIME
+ HRL A,5(E) ; GET DECL POINTER
+ MOVEM A,4(E) ;CLOBBER IT AWAY
+ MOVE A,(E) ; SEE IF SPEC/UNSPEC
+ TRNN A,1 ; SKIP, ALWAYS SPEC
+ SKIPA A,-1(P) ; USE SUPPLIED
+ MOVSI A,TBIND
+ MOVEM A,(E) ;IDENTIFY AS BIND BLOCK
+ JUMPE B,SPEB10
+ MOVE PVP,PVSTOR+1
+ HRRZ C,SPBASE(PVP) ; CHECK FOR CROSS OF PROC
+ MOVEI A,(TP)
+ CAIL A,(B) ; LOSER
+ CAILE C,(B) ; SKIP IFF WINNER
+ MOVEI B,1
+SPEB10: MOVEM B,5(E) ;IN RESTORE CELLS
+
+ MOVE C,1(E) ;GET ATOM PTR
+ SKIPE (C)
+ JUMPE B,.-4
+ MOVEI A,(C)
+ MOVEI B,0 ; FOR SPCUNP
+ CAIL A,HIBOT ; SKIP IF IMPURE ATOM
+ PUSHJ P,SPCUNP
+ MOVE PVP,PVSTOR+1
+ HRRZ A,BINDID+1(PVP) ;GET PROCESS NUMBER
+ HRLI A,TLOCI ;MAKE LOC PTR
+ MOVE B,E ;TO NEW VALUE
+ ADD B,[2,,2]
+ MOVEM A,(C) ;CLOBBER ITS VALUE
+ MOVEM B,1(C) ;CELL
+ MOVE D,E ;REMEMBER LINK
+ JRST BINDLP ;DO NEXT
+
+NONID: CAILE 0,-4(E)
+ JRST SPECBD
+ SUB E,[4,,4]
+ SKIPE D
+ HRRM E,(D)
+ SKIPN (P)
+ MOVEM E,(P)
+
+ 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
+ MOVE SP,SPSTOR+1
+ HRRM SP,(D)
+ SKIPE D,(P)
+ MOVEM D,SPSTOR+1
+ SUB P,[2,,2]
+ POPJ P,
+
+
+; HERE TO IMPURIFY THE ATOM
+
+SPCUNP: PUSH TP,$TSP
+ PUSH TP,E
+ PUSH TP,$TSP
+ PUSH TP,-1(P) ; LINK BACK IS AN SP
+ PUSH TP,$TSP
+ PUSH TP,B
+ CAIN B,1
+ SETZM -1(TP) ; FIXUP SOME FUNNYNESS
+ MOVE B,C
+ PUSHJ P,IMPURIFY
+ MOVE 0,-2(TP) ; RESTORE LINK BACK POINTER
+ MOVEM 0,-1(P)
+ MOVE E,-4(TP)
+ MOVE C,B
+ MOVE B,(TP)
+ SUB TP,[6,,6]
+ MOVEI 0,(TB)
+ POPJ P,
+
+; ENTRY FROM COMPILER TO SET UP A BINDING
+
+IBIND: MOVE SP,SPSTOR+1
+ SUBI E,-5(SP) ; CHANGE TO PDL POINTER
+ HRLI E,(E)
+ ADD E,SP
+ MOVEM C,-4(E)
+ MOVEM A,-3(E)
+ MOVEM B,-2(E)
+ HRLOI A,TATOM
+ MOVEM A,-5(E)
+ MOVSI A,TLIST
+ MOVEM A,-1(E)
+ MOVEM D,(E)
+ JRST SPECB1 ; NOW BIND IT
+
+; "FAST CALL TO SPECBIND"
+
+
+
+; Compiler's call to SPECBIND all atom bindings, no TBVLs etc.
+
+SPECBND:
+ MOVE E,TP ; POINT TO BINDING WITH E
+SPECB1: PUSH P,[0] ; SLOTS OF INTEREST
+ PUSH P,[0]
+ SUBM M,-2(P)
+
+SPECB2: MOVEI 0,(TB) ; FOR FRAME CHECK
+ MOVE A,-5(E) ; LOOK AT FIRST THING
+ CAMN A,BNDA ; SKIP IF LOSER
+ CAILE 0,-5(E) ; SKIP IF REAL WINNER
+ JRST SPECB3
+
+ SUB E,[5,,5] ; POINT TO BINDING
+ SKIPE A,(P) ; LINK?
+ HRRM E,(A) ; YES DO IT
+ SKIPN -1(P) ; FIRST ONE?
+ MOVEM E,-1(P) ; THIS IS IT
+
+ MOVE A,1(E) ; POINT TO ATOM
+ MOVE PVP,PVSTOR+1
+ MOVE 0,BINDID+1(PVP) ; QUICK CHECK
+ HRLI 0,TLOCI
+ CAMN 0,(A) ; WINNERE?
+ JRST SPECB4 ; YES, GO ON
+
+ PUSH P,B ; SAVE REST OF ACS
+ PUSH P,C
+ PUSH P,D
+ MOVE B,A ; FOR ILOC TO WORK
+ PUSHJ P,SILOC ; GO LOOK IT UP
+ JUMPE B,SPECB9
+ MOVE PVP,PVSTOR+1
+ HRRZ C,SPBASE+1(PVP)
+ MOVEI A,(TP)
+ CAIL A,(B) ; SKIP IF LOSER
+ CAILE C,(B) ; SKIP IF WINNER
+ MOVEI B,1 ; SAY NO BACK POINTER
+SPECB9: MOVE C,1(E) ; POINT TO ATOM
+ SKIPE (C) ; IF GLOBALLY BOUND, MAKE SURE OK
+ JUMPE B,.-3
+ MOVEI A,(C) ; PURE ATOM?
+ CAIGE A,HIBOT ; SKIP IF OK
+ JRST .+4
+ PUSH P,-4(P) ; MAKE HAPPINESS
+ PUSHJ P,SPCUNP ; IMPURIFY
+ POP P,-5(P)
+ MOVE PVP,PVSTOR+1
+ MOVE A,BINDID+1(PVP)
+ HRLI A,TLOCI
+ MOVEM A,(C) ; STOR POINTER INDICATOR
+ MOVE A,B
+ POP P,D
+ POP P,C
+ POP P,B
+ JRST SPECB5
+
+SPECB4: MOVE A,1(A) ; GET LOCATIVE
+SPECB5: EXCH A,5(E) ; CLOBBER INTO REBIND SLOT (GET DECL)
+ HLL A,OTBSAV(TB) ; TIME IT
+ MOVSM A,4(E) ; SAVE DECL AND TIME
+ MOVEI A,TBIND
+ HRLM A,(E) ; CHANGE TO A BINDING
+ MOVE A,1(E) ; POINT TO ATOM
+ MOVEM E,(P) ; REMEMBER THIS GUY
+ ADD E,[2,,2] ; POINT TO VAL CELL
+ MOVEM E,1(A) ; INTO ATOM SLOT
+ SUB E,[3,,3] ; POINT TO NEXT ONE
+ JRST SPECB2
+
+SPECB3: SKIPE A,(P)
+ MOVE SP,SPSTOR+1
+ HRRM SP,(A) ; LINK OLD STUFF
+ SKIPE A,-1(P) ; NEW SP?
+ MOVEM A,SPSTOR+1
+ SUB P,[2,,2]
+ INTGO ; IN CASE BLEW STACK
+ SUBM M,(P)
+ POPJ P,
+\f
+
+;SPECSTORE RESTORES THE BINDINGS SP TO THE ENVIRONMENT POINTER IN
+;SPSAV (TB). IT IS CALLED BY PUSHJ P,SPECSTORE.
+
+SPECSTORE:
+ PUSH P,E
+ HRRZ E,SPSAV (TB) ;GET TARGET POINTER
+ PUSHJ P,STLOOP
+ POP P,E
+ MOVE SP,SPSAV(TB) ; GET NEW SP
+ MOVEM SP,SPSTOR+1
+ POPJ P,
+
+STLOOP: MOVE SP,SPSTOR+1
+ PUSH P,D
+ PUSH P,C
+
+STLOO1: CAIL E,(SP) ;ARE WE DONE?
+ JRST STLOO2
+ HLRZ C,(SP) ;GET TYPE OF BIND
+ CAIN C,TUBIND
+ JRST .+3
+ CAIE C,TBIND ;NORMAL IDENTIFIER?
+ JRST ISTORE ;NO -- SPECIAL HACK
+
+
+ MOVE C,1(SP) ;GET TOP ATOM
+ MOVSI 0,TLOCI ; MAYBE LOCI OR UNBOUND
+ SKIPL D,5(SP)
+ MOVSI 0,TUNBOU
+ MOVE PVP,PVSTOR+1
+ HRR 0,BINDID+1(PVP) ;STORE SIGNATURE
+ SKIPN 5(SP)
+ MOVEI 0,0 ; TOTALLY UNBOUND IN ALL CASES
+ MOVEM 0,(C) ;CLOBBER INTO ATOM
+ MOVEM D,1(C)
+ SETZM 4(SP)
+SPLP: HRRZ SP,(SP) ;FOLOW LINK
+ JUMPN SP,STLOO1 ;IF MORE
+ SKIPE E ; OK IF E=0
+ FATAL SP OVERPOP
+STLOO2: MOVEM SP,SPSTOR+1
+ POP P,C
+ POP P,D
+ POPJ P,
+
+ISTORE: CAIE C,TBVL
+ JRST CHSKIP
+ MOVE C,1(SP)
+ MOVE D,2(SP)
+ MOVEM D,(C)
+ MOVE D,3(SP)
+ MOVEM D,1(C)
+ JRST SPLP
+
+CHSKIP: CAIN C,TSKIP
+ JRST SPLP
+ CAIE C,TUNWIN ; UNWIND HACK
+ FATAL BAD SP
+ HRRZ C,-2(P) ; WHERE FROM?
+ CAIE C,CHUNPC
+ JRST SPLP ; IGNORE
+ MOVEI E,(TP) ; FIXUP SP
+ SUBI E,(SP)
+ MOVSI E,(E)
+ HLL SP,TP
+ SUB SP,E
+ POP P,C
+ POP P,D
+ AOS (P)
+ POPJ P,
+
+; ENTRY FOR FUNNY COMPILER UNBIND (1)
+
+SSPECS: PUSH P,E
+ PUSH P,PVP
+ PUSH P,SP
+ MOVEI E,(TP)
+ PUSHJ P,STLOOP
+SSPEC2: SUBI E,(SP) ; MAKE SP BE AOBJN
+ MOVSI E,(E)
+ HLL SP,TP
+ SUB SP,E
+ MOVEM SP,SPSTOR+1
+ POP P,SP
+ POP P,PVP
+ POP P,E
+ POPJ P,
+
+; ENTRY FOR FUNNY COMPILER UNBIND (2)
+
+SSPEC1: PUSH P,E
+ PUSH P,PVP
+ PUSH P,SP
+ SUBI E,1 ; MAKE SURE GET CURRENT BINDING
+ PUSHJ P,STLOOP ; UNBIND
+ MOVEI E,(TP) ; NOW RESET SP
+ JRST SSPEC2
+\f
+EFINIS: MOVE PVP,PVSTOR+1
+ SKIPN C,1STEPR+1(PVP) ; SKIP NIF BEING ONE PROCEEDED
+ JRST FINIS
+ PUSH TP,$TATOM
+ PUSH TP,MQUOTE EVLOUT
+ PUSH TP,A ;SAVE EVAL RESULTS
+ PUSH TP,B
+ PUSH TP,[TINFO,,2] ; FENCE POST
+ PUSHJ P,TBTOTP
+ PUSH TP,D
+ PUSHJ P,MAKINF ; MAKE ARG BLOCK INFO
+ PUSH TP,A
+ MOVEI B,-6(TP)
+ HRLI B,-4 ; AOBJN TO ARGS BLOCK
+ PUSH TP,B
+ MOVE PVP,PVSTOR+1
+ PUSH TP,1STEPR(PVP)
+ PUSH TP,1STEPR+1(PVP) ; PROCESS DOING THE 1STEPPING
+ MCALL 2,RESUME
+ MOVE A,-3(TP) ; GET BACK EVAL VALUE
+ MOVE B,-2(TP)
+ JRST FINIS
+
+1STEPI: PUSH TP,$TATOM
+ PUSH TP,MQUOTE EVLIN
+ PUSH TP,$TAB ; PUSH EVALS ARGGS
+ PUSH TP,AB
+ PUSHJ P,MAKINF ; TURN INTO ARGS BLOCK
+ MOVEM A,-1(TP) ; AND CLOBBER
+ PUSH TP,[TINFO,,2] ; FENCE POST 2D TUPLE
+ PUSHJ P,TBTOTP
+ PUSH TP,D
+ PUSHJ P,MAKINF ; TURN IT INTO ARGS BLOCK
+ PUSH TP,A
+ MOVEI B,-6(TP) ; SETUP TUPLE
+ HRLI B,-4
+ PUSH TP,B
+ MOVE PVP,PVSTOR+1
+ PUSH TP,1STEPR(PVP)
+ PUSH TP,1STEPR+1(PVP)
+ MCALL 2,RESUME ; START UP 1STEPERR
+ SUB TP,[6,,6] ; REMOVE CRUD
+ GETYP A,A ; GET 1STEPPERS TYPE
+ CAIE A,TDISMI ; IF DISMISS, STOP 1 STEPPING
+ JRST EVALON
+
+; HERE TO PUSH DOWN THE 1 STEP STATE AND RUN
+
+ MOVE D,PVP
+ ADD D,[1STEPR,,1STEPR] ; POINT TO 1 STEP SLOT
+ PUSH TP,$TSP ; SAVE CURRENT SP
+ PUSH TP,SPSTOR+1
+ PUSH TP,BNDV
+ PUSH TP,D ; BIND IT
+ PUSH TP,$TPVP
+ PUSH TP,[0] ; NO 1 STEPPER UNTIL POPJ
+ PUSHJ P,SPECBIND
+
+; NOW PUSH THE ARGS UP TO RE-CALL EVAL
+
+ MOVEI A,0
+EFARGL: JUMPGE AB,EFCALL
+ PUSH TP,(AB)
+ PUSH TP,1(AB)
+ ADD AB,[2,,2]
+ AOJA A,EFARGL
+
+EFCALL: ACALL A,EVAL ; NOW DO THE EVAL
+ MOVE C,(TP) ; PRE-UNBIND
+ MOVE PVP,PVSTOR+1
+ MOVEM C,1STEPR+1(PVP)
+ MOVE SP,-4(TP) ; AVOID THE UNBIND
+ MOVEM SP,SPSTOR+1
+ SUB TP,[6,,6] ; AND FLUSH LOSERS
+ JRST EFINIS ; AND TRY TO FINISH UP
+
+MAKINF: HLRZ A,OTBSAV(TB) ; TIME IT
+ HRLI A,TARGS
+ POPJ P,
+
+
+TBTOTP: MOVEI D,(TB) ; COMPUTE REL DIST FROM TP TO TB
+ SUBI D,(TP)
+ POPJ P,
+; ARRIVE HERE TO COMPLETE A COMPILER GENERATED TUPLE
+; D/ LENGTH OF THE TUPLE IN WORDS
+
+MAKTU2: MOVE D,-1(P) ; GET LENGTH
+ ASH D,1
+ PUSHJ P,MAKTUP
+ PUSH TP,A
+ PUSH TP,B
+ POPJ P,
+
+MAKTUP: HRLI D,TINFO ; FIRST WORD OF FENCE POST
+ PUSH TP,D
+ HRROI B,(TP) ; TOP OF TUPLE
+ SUBI B,(D)
+ TLC B,-1(D) ; AOBJN IT
+ PUSHJ P,TBTOTP
+ PUSH TP,D
+ HLRZ A,OTBSAV(TB) ; TIME IT
+ HRLI A,TARGS
+ POPJ P,
+
+; HERE TO ALLOCATE SLOTS FOR COMPILER (AMNT IN A)
+
+TPALOC: SUBM M,(P)
+ ;Once here ==>ADDI A,1 Bug???
+ HRLI A,(A)
+ ADD TP,A
+ PUSH P,A
+ SKIPL TP
+ PUSHJ P,TPOVFL ; IN CASE IT LOST
+ INTGO ; TAKE THE GC IF NEC
+ HRRI A,2(TP)
+ SUB A,(P)
+ SETZM -1(A)
+ HRLI A,-1(A)
+ BLT A,(TP)
+ SUB P,[1,,1]
+ JRST POPJM
+
+
+NTPALO: PUSH TP,[0]
+ SOJG 0,.-1
+ POPJ P,
+
+\f;EVALUATES A IDENTIFIER -- GETS LOCAL VALUE IF THERE IS ONE, OTHERWISE GLOBAL.
+
+IMFUNCTION VALUE,SUBR
+ JSP E,CHKAT
+ PUSHJ P,IDVAL
+ JRST FINIS
+
+IDVAL: PUSHJ P,IDVAL1
+ CAMN A,$TUNBOU
+ JRST UNBOU
+ POPJ P,
+
+IDVAL1: 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
+ POP TP,B ;GET ARG BACK
+ POP TP,A
+ JRST IGVAL
+RIDVAL: SUB TP,[2,,2]
+ POPJ P,
+
+;GETS THE LOCAL VALUE OF AN IDENTIFIER
+
+IMFUNCTION LVAL,SUBR
+ JSP E,CHKAT
+ PUSHJ P,AILVAL
+ CAME A,$TUNBOUND
+ JRST FINIS
+ JUMPN B,UNAS
+ JRST UNBOU
+
+; MAKE AN ATOM UNASSIGNED
+
+MFUNCTION UNASSIGN,SUBR
+ JSP E,CHKAT ; GET ATOM ARG
+ PUSHJ P,AILOC
+UNASIT: CAMN A,$TUNBOU ; IF UNBOUND
+ JRST RETATM
+ MOVSI A,TUNBOU
+ MOVEM A,(B)
+ SETOM 1(B) ; MAKE SURE
+RETATM: MOVE B,1(AB)
+ MOVE A,(AB)
+ JRST FINIS
+
+; UNASSIGN GLOBALLY
+
+MFUNCTION GUNASSIGN,SUBR
+ JSP E,CHKAT2
+ PUSHJ P,IGLOC
+ CAMN A,$TUNBOU
+ JRST RETATM
+ MOVE B,1(AB) ; ATOM BACK
+ MOVEI 0,(B)
+ CAIL 0,HIBOT ; SKIP IF IMPURE
+ PUSHJ P,IMPURIFY ; YES, MAKE IT IMPURE
+ PUSHJ P,IGLOC ; RESTORE LOCATIVE
+ HRRZ 0,-2(B) ; SEE IF MANIFEST
+ GETYP A,(B) ; AND CURRENT TYPE
+ CAIN 0,-1
+ CAIN A,TUNBOU
+ JRST UNASIT
+ SKIPE IGDECL
+ JRST UNASIT
+ MOVE D,B
+ JRST MANILO
+\f
+; GETS A LOCATIVE TO THE LOCAL VALUE OF AN IDENTIFIER.
+
+MFUNCTION LLOC,SUBR
+ JSP E,CHKAT
+ PUSHJ P,AILOC
+ 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,AILVAL
+ 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,AILVAL
+ CAME A,$TUNBOUND
+ JRST TRUTH
+; JUMPE B,UNBOU
+ JRST IFALSE
+
+;GETS THE GLOBAL VALUE OF AN IDENTIFIER
+
+IMFUNCTION GVAL,SUBR
+ JSP E,CHKAT2
+ PUSHJ P,IGVAL
+ CAMN A,$TUNBOUND
+ JRST UNAS
+ JRST FINIS
+
+;GETS A LOCATIVE TO THE GLOBAL VALUE OF AN IDENTIFIER
+
+MFUNCTION RGLOC,SUBR
+
+ JRST GLOC
+
+MFUNCTION GLOC,SUBR
+
+ JUMPGE AB,TFA
+ CAMGE AB,[-5,,]
+ JRST TMA
+ JSP E,CHKAT1
+ MOVEI E,IGLOC
+ CAML AB,[-2,,]
+ JRST .+4
+ GETYP 0,2(AB)
+ CAIE 0,TFALSE
+ MOVEI E,IIGLOC
+ PUSHJ P,(E)
+ CAMN A,$TUNBOUND
+ JRST UNAS
+ MOVSI A,TLOCD
+ HRRZ 0,FSAV(TB)
+ CAIE 0,GLOC
+ MOVSI A,TLOCR
+ CAIE 0,GLOC
+ SUB B,GLOTOP+1
+ MOVE C,1(AB) ; GE ATOM
+ MOVEI 0,(C)
+ CAIGE 0,HIBOT ; SKIP IF PURE ATOM
+ JRST FINIS
+
+; MAKE ATOM AND VALUE IMPURE IF GETTING GLOC TO IT
+
+ MOVE B,C ; ATOM TO B
+ PUSHJ P,IMPURIFY
+ JRST GLOC ; AND TRY AGAIN
+
+;TESTS TO SEE IF AN IDENTIFIER IS GLOBALLY ASSIGNED
+
+MFUNCTION GASSIG,SUBR,[GASSIGNED?]
+ JSP E,CHKAT2
+ PUSHJ P,IGVAL
+ CAMN A,$TUNBOUND
+ JRST IFALSE
+ JRST TRUTH
+
+; TEST FOR GLOBALLY BOUND
+
+MFUNCTION GBOUND,SUBR,[GBOUND?]
+
+ JSP E,CHKAT2
+ PUSHJ P,IGLOC
+ JUMPE B,IFALSE
+ JRST TRUTH
+
+\f
+
+CHKAT2: ENTRY 1
+CHKAT1: GETYP A,(AB)
+ MOVSI A,(A)
+ CAME A,$TATOM
+ JRST NONATM
+ MOVE B,1(AB)
+ JRST (E)
+
+CHKAT: HLRE A,AB ; - # OF ARGS
+ ASH A,-1 ; TO ACTUAL WORDS
+ JUMPGE AB,TFA
+ MOVE C,SPSTOR+1 ; FOR BINDING LOOKUPS
+ AOJE A,CHKAT1 ; ONLY ONE ARG, NO ENVIRONMENT
+ AOJL A,TMA ; TOO MANY
+ GETYP A,2(AB) ; MAKE SURE OF TENV OR TFRAME
+ CAIE A,TFRAME
+ CAIN A,TENV
+ JRST CHKAT3
+ CAIN A,TACT ; FOR PFISTERS LOSSAGE
+ JRST CHKAT3
+ CAIE A,TPVP ; OR PROCESS
+ JRST WTYP2
+ MOVE B,3(AB) ; GET PROCESS
+ MOVE C,SPSTOR+1 ; IN CASE ITS ME
+ CAME B,PVSTOR+1 ; SKIP IF DIFFERENT
+ MOVE C,SPSTO+1(B) ; GET ITS SP
+ JRST CHKAT1
+CHKAT3: MOVEI B,2(AB) ; POINT TO FRAME POINTER
+ PUSHJ P,CHFRM ; VALIDITY CHECK
+ MOVE B,3(AB) ; GET TB FROM FRAME
+ MOVE C,SPSAV(B) ; GET ENVIRONMENT POINTER
+ JRST CHKAT1
+
+\f
+; SILOC--CALLS ILOC IGNORING SPECIAL CHECKING
+
+SILOC: JFCL
+
+;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: MOVE C,SPSTOR+1 ; SETUP SEARCH START
+AILOC: SKIPN (B) ; ANY KIND OF VALUE AT ALL?
+ JUMPN B,FUNPJ
+ MOVSI A,TLOCI ;MAKE A LOCATIVE TYPE CELL
+ PUSH P,E
+ PUSH P,D
+ MOVEI E,0 ; FLAG TO CLOBBER ATOM
+ JUMPE B,SCHSP ; IF LOOKING FOR SLOT, SEARCH NOW
+ CAME C,SPSTOR+1 ; ENVIRONMENT CHANGE?
+ JRST SCHSP ; YES, MUST SEARCH
+ MOVE PVP,PVSTOR+1
+ HRR A,BINDID+1(PVP) ;FOR THE CURRENT PROCESS
+ CAME A,(B) ;IS THERE ONE IN THE VALUE CELL?
+ JRST SCHLP ;NO -- SEARCH THE LOCAL BINDINGS
+ MOVE B,1(B) ;YES -- GET LOCATIVE POINTER
+ MOVE C,PVP
+ILCPJ: MOVE E,SPCCHK
+ TRNN E,1 ; SKIP IF DOING SPEC UNSPEC CHECK
+ JRST ILOCPJ
+ HRRZ E,-2(P) ; IF IGNORING, IGNORE
+ HRRZ E,-1(E)
+ CAIN E,SILOC
+ JRST ILOCPJ
+ HLRZ E,-2(B)
+ CAIE E,TUBIND
+ JRST ILOCPJ
+ CAMGE B,CURFCN+1(PVP)
+ JRST SCHLPX
+ MOVEI D,-2(B)
+ HRRZ SP,SPSTOR+1
+ CAIG D,(SP)
+ CAMGE B,SPBASE+1(PVP)
+ JRST SCHLPX
+ MOVE C,PVSTOR+1
+ILOCPJ: POP P,D
+ POP P,E
+ POPJ P, ;FROM THE VALUE CELL
+
+SCHLPX: MOVEI E,1
+ MOVE C,SPSTOR+1
+ MOVE B,-1(B)
+ JRST SCHLP
+
+
+SCHLP5: SETOM (P)
+ JRST SCHLP2
+
+SCHLP: MOVEI D,(B)
+ CAIL D,HIBOT ; SKIP IF IMPURE ATOM
+SCHSP: MOVEI E,1 ; DONT STORE LOCATIVE
+
+ PUSH P,E ; PUSH SWITCH
+ MOVE E,PVSTOR+1 ; GET PROC
+SCHLP1: JUMPE C,UNPJ ;IF NO MORE -- LOSE
+ CAMN B,1(C) ;ARE WE POINTING AT THE WINNER?
+ JRST SCHFND ;YES
+ GETYP D,(C) ; CHECK SKIP
+ CAIE D,TSKIP
+ JRST SCHLP2
+ PUSH P,B ; CHECK DETOUR
+ MOVEI B,2(C)
+ PUSHJ P,CHFRAM ; NON-FATAL FRAME CHECKER
+ HRRZ E,2(C) ; CONS UP PROCESS
+ SUBI E,PVLNT*2+1
+ HRLI E,-2*PVLNT
+ JUMPE B,SCHLP3 ; LOSER, FIX IT
+ POP P,B
+ MOVEI C,1(C) ; FOLLOW LOOKUP CHAIN
+SCHLP2: HRRZ C,(C) ;FOLLOW LINK
+ JRST SCHLP1
+
+SCHLP3: POP P,B
+ HRRZ SP,SPSTOR+1
+ MOVEI C,(SP) ; *** NDR'S BUG ***
+ CAME E,PVSTOR+1 ; USE IF CURRENT PROCESS
+ HRRZ C,SPSTO+1(E) ; USE CURRENT SP FOR PROC
+ JRST SCHLP1
+
+SCHFND: MOVE D,SPCCHK
+ TRNN D,1 ; SKIP IF DOING SPEC UNSPEC CHECK
+ JRST SCHFN1
+ HRRZ D,-2(P) ; IF IGNORING, IGNORE
+ HRRZ D,-1(D)
+ CAIN D,SILOC
+ JRST ILOCPJ
+ HLRZ D,(C)
+ CAIE D,TUBIND
+ JRST SCHFN1
+ HRRZ D,CURFCN+1(PVP)
+ CAIL D,(C)
+ JRST SCHLP5
+ HRRZ SP,SPSTOR+1
+ HRRZ D,SPBASE+1(PVP)
+ CAIL SP,(C)
+ CAIL D,(C)
+ JRST SCHLP5
+
+SCHFN1: EXCH B,C ;SAVE THE ATOM PTR IN C
+ MOVEI B,2(B) ;MAKE UP THE LOCATIVE
+ SUB B,TPBASE+1(E)
+ HRLI B,(B)
+ ADD B,TPBASE+1(E)
+ EXCH C,E ; RET PROCESS IN C
+ POP P,D ; RESTORE SWITCH
+
+ JUMPN D,ILOCPJ ; DONT CLOBBER ATOM
+ MOVEM A,(E) ;CLOBBER IT AWAY INTO THE
+ MOVE D,1(E) ; GET OLD POINTER
+ MOVEM B,1(E) ;ATOM'S VALUE CELL
+ JUMPE D,ILOCPJ ; IF POINTS TO GLOBAL OR OTHER PROCES
+ ; MAKE SURE BINDING SO INDICATES
+ MOVE D,B ; POINT TO BINDING
+ SKIPL E,3(D) ; GO TO FIRST ONE, JUST IN CASE
+ JRST .+3
+ MOVE D,E
+ JRST .-3 ; LOOP THROUGH
+ MOVEI E,1
+ MOVEM E,3(D) ; MAGIC INDICATION
+ JRST ILOCPJ
+
+UNPJ: SUB P,[1,,1] ; FLUSH CRUFT
+UNPJ1: MOVE C,E ; RET PROCESS ANYWAY
+UNPJ11: POP P,D
+ POP P,E
+UNPOPJ: MOVSI A,TUNBOUND
+ MOVEI B,0
+ POPJ P,
+
+FUNPJ: MOVE C,PVSTOR+1
+ JRST UNPOPJ
+
+;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.
+
+IGLOC: 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: SKIPN (B)
+ JRST UNPOPJ
+ MOVE D,GLOBSP+1 ;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
+ MOVEI 0,(D)
+ CAIL 0,HIBOT
+ POPJ P,
+ MOVEM A,(D) ;CLOBBER IT AWAY
+ MOVEM B,1(D)
+ POPJ P,
+
+IIGLOC: PUSH TP,$TATOM
+ PUSH TP,B
+ PUSHJ P,IGLOC
+ MOVE C,(TP)
+ SUB TP,[2,,2]
+ GETYP 0,A
+ CAIE 0,TUNBOU
+ POPJ P,
+ PUSH TP,$TATOM
+ PUSH TP,C
+ MOVEI 0,(C)
+ MOVE B,C
+ CAIL 0,$TLOSE
+ PUSHJ P,IMPURI ; IMPURIFY THE POOR ATOM
+ PUSHJ P,BSETG ; MAKE A SLOT
+ SETOM 1(B) ; UNBOUNDIFY IT
+ MOVSI A,TLOCD
+ MOVSI 0,TUNBOU
+ MOVEM 0,(B)
+ SUB TP,[2,,2]
+ 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
+
+AILVAL:
+ PUSHJ P,AILOC ; USE SUPPLIED SP
+ JRST CHVAL
+ILVAL:
+ PUSHJ P,ILOC ;GET LOCATIVE TO VALUE
+CHVAL: CAMN A,$TUNBOUND ;BOUND
+ POPJ P, ;NO -- RETURN
+ MOVSI A,TLOCD ; GET GOOD TYPE
+ HRR A,2(B) ; SHOULD BE TIME OR 0
+ PUSH P,0
+ PUSHJ P,RMONC0 ; CHECK READ MONITOR
+ POP P,0
+ 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
+; COMPILERS INTERFACE TO LVAL/GVAL/SETG/SET
+
+CILVAL: MOVE PVP,PVSTOR+1
+ MOVE 0,BINDID+1(PVP) ; CURRENT BIND
+ HRLI 0,TLOCI
+ CAME 0,(B) ; HURRAY FOR SPEED
+ JRST CILVA1 ; TOO BAD
+ MOVE C,1(B) ; POINTER
+ MOVE A,(C) ; VAL TYPE
+ TLNE A,.RDMON ; MONITORS?
+ JRST CILVA1
+ GETYP 0,A
+ CAIN 0,TUNBOU
+ JRST CUNAS ; COMPILER ERROR
+ MOVE B,1(C) ; GOT VAL
+ MOVE 0,SPCCHK
+ TRNN 0,1
+ POPJ P,
+ HLRZ 0,-2(C) ; SPECIAL CHECK
+ CAIE 0,TUBIND
+ POPJ P, ; RETURN
+ MOVE PVP,PVSTOR+1
+ CAMGE C,CURFCN+1(PVP)
+ JRST CUNAS
+ POPJ P,
+
+CUNAS:
+CILVA1: SUBM M,(P) ; FIX (P)
+ PUSH TP,$TATOM ; SAVE ATOM
+ PUSH TP,B
+ MCALL 1,LVAL ; GET ERROR/MONITOR
+
+POPJM: SUBM M,(P) ; REPAIR DAMAGE
+ POPJ P,
+
+; COMPILERS INTERFACE TO SET C/ ATOM A,B/ NEW VALUE
+
+CISET: MOVE PVP,PVSTOR+1
+ MOVE 0,BINDID+1(PVP) ; CURRENT BINDING ENVIRONMENT
+ HRLI 0,TLOCI
+ CAME 0,(C) ; CAN WE WIN?
+ JRST CISET1 ; NO, MORE HAIR
+ MOVE D,1(C) ; POINT TO SLOT
+CISET3: HLLZ 0,(D) ; MON CHECK
+ TLNE 0,.WRMON
+ JRST CISET4 ; YES, LOSE
+ TLZ 0,TYPMSK
+ IOR A,0 ; LEAVE MONITOR ON
+ MOVE 0,SPCCHK
+ TRNE 0,1
+ JRST CISET5 ; SPEC/UNSPEC CHECK
+CISET6: MOVEM A,(D) ; STORE
+ MOVEM B,1(D)
+ POPJ P,
+
+CISET5: HLRZ 0,-2(D)
+ CAIE 0,TUBIND
+ JRST CISET6
+ MOVE PVP,PVSTOR+1
+ CAMGE D,CURFCN+1(PVP)
+ JRST CISET4
+ JRST CISET6
+
+CISET1: SUBM M,(P) ; FIX ADDR
+ PUSH TP,$TATOM ; SAVE ATOM
+ PUSH TP,C
+ PUSH TP,A
+ PUSH TP,B
+ MOVE B,C ; GET ATOM
+ PUSHJ P,ILOC ; SEARCH
+ MOVE D,B ; POSSIBLE POINTER
+ GETYP E,A
+ MOVE 0,A
+ MOVE A,-1(TP) ; VAL BACK
+ MOVE B,(TP)
+ CAIE E,TUNBOU ; SKIP IF WIN
+ JRST CISET2 ; GO CLOBBER IT IN
+ MCALL 2,SET
+ JRST POPJM
+
+CISET2: MOVE C,-2(TP) ; ATOM BACK
+ SUBM M,(P) ; RESET (P)
+ SUB TP,[4,,4]
+ JRST CISET3
+
+; HERE TO DO A MONITORED SET
+
+CISET4: SUBM M,(P) ; AGAIN FIX (P)
+ PUSH TP,$TATOM
+ PUSH TP,C
+ PUSH TP,A
+ PUSH TP,B
+ MCALL 2,SET
+ JRST POPJM
+
+; COMPILER LLOC
+
+CLLOC: MOVE PVP,PVSTOR+1
+ MOVE 0,BINDID+1(PVP) ; GET CURRENT LOCATIVE
+ HRLI 0,TLOCI
+ CAME 0,(B) ; WIN?
+ JRST CLLOC1
+ MOVE B,1(B)
+ MOVE 0,SPCCHK
+ TRNE 0,1 ; SKIP IF NOT CHECKING
+ JRST CLLOC9
+CLLOC3: MOVSI A,TLOCD
+ HRR A,2(B) ; GET BIND TIME
+ POPJ P,
+
+CLLOC1: SUBM M,(P)
+ PUSH TP,$TATOM
+ PUSH TP,B
+ PUSHJ P,ILOC ; LOOK IT UP
+ JUMPE B,CLLOC2
+ SUB TP,[2,,2]
+CLLOC4: SUBM M,(P)
+ JRST CLLOC3
+
+CLLOC2: MCALL 1,LLOC
+ JRST CLLOC4
+
+CLLOC9: HLRZ 0,-2(B)
+ CAIE 0,TUBIND
+ JRST CLLOC3
+ MOVE PVP,PVSTOR+1
+ CAMGE B,CURFCN+1(PVP)
+ JRST CLLOC2
+ JRST CLLOC3
+
+; COMPILER BOUND?
+
+CBOUND: SUBM M,(P)
+ PUSHJ P,ILOC
+ JUMPE B,PJFALS ; IF UNBOUND RET FALSE AND NO SSKIP
+PJT1: SOS (P)
+ MOVSI A,TATOM
+ MOVE B,IMQUOTE T
+ JRST POPJM
+
+PJFALS: MOVEI B,0
+ MOVSI A,TFALSE
+ JRST POPJM
+
+; COMPILER ASSIGNED?
+
+CASSQ: SUBM M,(P)
+ PUSHJ P,ILOC
+ JUMPE B,PJFALS
+ GETYP 0,(B)
+ CAIE 0,TUNBOU
+ JRST PJT1
+ JRST PJFALS
+\f
+
+; COMPILER GVAL B/ ATOM
+
+CIGVAL: MOVE 0,(B) ; GLOBAL VAL HERE?
+ CAME 0,$TLOCI ; TIME=0 ,TYPE=TLOCI => GLOB VAL
+ JRST CIGVA1 ; NO, GO LOOK
+ MOVE C,1(B) ; POINT TO SLOT
+ MOVE A,(C) ; GET TYPE
+ TLNE A,.RDMON
+ JRST CIGVA1
+ GETYP 0,A ; CHECK FOR UNBOUND
+ CAIN 0,TUNBOU ; SKIP IF WINNER
+ JRST CGUNAS
+ MOVE B,1(C)
+ POPJ P,
+
+CGUNAS:
+CIGVA1: SUBM M,(P)
+ PUSH TP,$TATOM
+ PUSH TP,B
+ .MCALL 1,GVAL ; GET ERROR/MONITOR
+ JRST POPJM
+
+; COMPILER INTERFACET TO SETG
+
+CSETG: MOVE 0,(C) ; GET V CELL
+ CAME 0,$TLOCI ; SKIP IF FAST
+ JRST CSETG1
+ HRRZ D,1(C) ; POINT TO SLOT
+ MOVE 0,(D) ; OLD VAL
+CSETG3: CAIG D,HIBOT ; SKIP IF PURE ATOM
+ TLNE 0,.WRMON ; MONITOR
+ JRST CSETG2
+ MOVEM A,(D)
+ MOVEM B,1(D)
+ POPJ P,
+
+CSETG1: SUBM M,(P) ; FIX UP P
+ PUSH TP,$TATOM
+ PUSH TP,C
+ PUSH TP,A
+ PUSH TP,B
+ MOVE B,C
+ PUSHJ P,IGLOC ; FIND GLOB LOCATIVE
+ GETYP E,A
+ MOVE 0,A
+ MOVEI D,(B) ; SETUP TO RESTORE NEW VAL
+ MOVE A,-1(TP)
+ MOVE B,(TP)
+ CAIE E,TUNBOU
+ JRST CSETG4
+ MCALL 2,SETG
+ JRST POPJM
+
+CSETG4: MOVE C,-2(TP) ; ATOM BACK
+ SUBM M,(P) ; RESET (P)
+ SUB TP,[4,,4]
+ JRST CSETG3
+
+CSETG2: SUBM M,(P)
+ PUSH TP,$TATOM ; CAUSE A SETG MONITOR
+ PUSH TP,C
+ PUSH TP,A
+ PUSH TP,B
+ MCALL 2,SETG
+ JRST POPJM
+
+; COMPILER GLOC
+
+CGLOC: MOVE 0,(B) ; GET CURRENT GUY
+ CAME 0,$TLOCI ; WIN?
+ JRST CGLOC1 ; NOPE
+ HRRZ D,1(B) ; POINT TO SLOT
+ CAILE D,HIBOT ; PURE?
+ JRST CGLOC1
+ MOVE A,$TLOCD
+ MOVE B,1(B)
+ POPJ P,
+
+CGLOC1: SUBM M,(P)
+ PUSH TP,$TATOM
+ PUSH TP,B
+ MCALL 1,GLOC
+ JRST POPJM
+
+; COMPILERS GASSIGNED?
+
+CGASSQ: MOVE 0,(B)
+ SUBM M,(P)
+ CAMN 0,$TLOCD
+ JRST PJT1
+ PUSHJ P,IGLOC
+ JUMPE B,PJFALS
+ GETYP 0,(B)
+ CAIE 0,TUNBOU
+ JRST PJT1
+ JRST PJFALS
+
+; COMPILERS GBOUND?
+
+CGBOUN: MOVE 0,(B)
+ SUBM M,(P)
+ CAMN 0,$TLOCD
+ JRST PJT1
+ PUSHJ P,IGLOC
+ JUMPE B,PJFALS
+ JRST PJT1
+\f
+
+IMFUNCTION REP,FSUBR,[REPEAT]
+ JRST PROG
+MFUNCTION BIND,FSUBR
+ JRST PROG
+IMFUNCTION PROG,FSUBR
+ ENTRY 1
+ GETYP A,(AB) ;GET ARG TYPE
+ CAIE A,TLIST ;IS IT A LIST?
+ JRST WRONGT ;WRONG TYPE
+ SKIPN C,1(AB) ;GET AND CHECK ARGUMENT
+ JRST TFA ;TOO FEW ARGS
+ SETZB E,D ; INIT HEWITT ATOM AND DECL
+ PUSHJ P,CARATC ; IS 1ST THING AN ATOM
+ JFCL
+ PUSHJ P,RSATY1 ; CDR AND GET TYPE
+ CAIE 0,TLIST ; MUST BE LIST
+ JRST MPD.13
+ MOVE B,1(C) ; GET ARG LIST
+ PUSH TP,$TLIST
+ PUSH TP,C
+ PUSHJ P,RSATYP
+ CAIE 0,TDECL
+ JRST NOP.DC ; JUMP IF NO DCL
+ MOVE D,1(C)
+ MOVEM C,(TP)
+ PUSHJ P,RSATYP ; CDR ON
+NOP.DC: PUSH TP,$TLIST
+ PUSH TP,B ; AND ARG LIST
+ PUSHJ P,PRGBND ; BIND AUX VARS
+ HRRZ E,FSAV(TB)
+ CAIE E,BIND
+ SKIPA E,IMQUOTE LPROG,[LPROG ]INTRUP
+ JRST .+3
+ PUSHJ P,MAKACT ; MAKE ACTIVATION
+ PUSHJ P,PSHBND ; BIND AND CHECK
+ PUSHJ P,SPECBI ; NAD BIND IT
+
+; HERE TO RUN PROGS FUNCTIONS ETC.
+
+DOPROG: MOVEI A,REPROG
+ HRLI A,TDCLI ; FLAG AS FUNNY
+ MOVEM A,(TB) ; WHERE TO AGAIN TO
+ MOVE C,1(TB)
+ MOVEM C,3(TB) ; RESTART POINTER
+ JRST .+2 ; START BY SKIPPING DECL
+
+DOPRG1: PUSHJ P,FASTEV
+ HRRZ C,@1(TB) ;GET THE REST OF THE BODY
+DOPRG2: MOVEM C,1(TB)
+ JUMPN C,DOPRG1
+ENDPROG:
+ HRRZ C,FSAV(TB)
+ CAIN C,REP
+REPROG: SKIPN C,@3(TB)
+ JRST PFINIS
+ HRRZM C,1(TB)
+ INTGO
+ MOVE C,1(TB)
+ JRST DOPRG1
+
+
+PFINIS: GETYP 0,(TB)
+ CAIE 0,TDCLI ; DECL'D ?
+ JRST PFINI1
+ HRRZ 0,(TB) ; SEE IF RSUBR
+ JUMPE 0,RSBVCK ; CHECK RSUBR VALUE
+ HRRZ C,3(TB) ; GET START OF FCN
+ GETYP 0,(C) ; CHECK FOR DECL
+ CAIE 0,TDECL
+ JRST PFINI1 ; NO, JUST RETURN
+ MOVE E,IMQUOTE VALUE
+ PUSHJ P,PSHBND ; BUILD FAKE BINDING
+ MOVE C,1(C) ; GET DECL LIST
+ MOVE E,TP
+ PUSHJ P,CHKDCL ; AND CHECK IT
+ MOVE A,-3(TP) ; GET VAL BAKC
+ MOVE B,-2(TP)
+ SUB TP,[6,,6]
+
+PFINI1: HRRZ C,FSAV(TB)
+ CAIE C,EVAL
+ JRST FINIS
+ JRST EFINIS
+
+RSATYP: HRRZ C,(C)
+RSATY1: JUMPE C,TFA
+ GETYP 0,(C)
+ POPJ P,
+
+; HERE TO CHECK RSUBR VALUE
+
+RSBVCK: PUSH TP,A
+ PUSH TP,B
+ MOVE C,A
+ MOVE D,B
+ MOVE A,1(TB) ; GET DECL
+ MOVE B,1(A)
+ HLLZ A,(A)
+ PUSHJ P,TMATCH
+ JRST RSBVC1
+ POP TP,B
+ POP TP,A
+ POPJ P,
+
+RSBVC1: MOVE C,1(TB)
+ POP TP,B
+ POP TP,D
+ MOVE A,IMQUOTE VALUE
+ JRST TYPMIS
+\f
+
+MFUNCTION MRETUR,SUBR,[RETURN]
+ ENTRY
+ HLRE A,AB ; GET # OF ARGS
+ ASH A,-1 ; TO NUMBER
+ AOJL A,RET2 ; 2 OR MORE ARGS
+ PUSHJ P,PROGCH ;CHECK IN A PROG
+ PUSH TP,A
+ PUSH TP,B
+ MOVEI B,-1(TP) ; VERIFY IT
+COMRET: PUSHJ P,CHFSWP
+ SKIPL C ; ARGS?
+ MOVEI C,0 ; REAL NONE
+ PUSHJ P,CHUNW
+ JUMPN A,CHFINI ; WINNER
+ MOVSI A,TATOM
+ MOVE B,IMQUOTE T
+
+; SEE IF MUST CHECK RETURNS TYPE
+
+CHFINI: GETYP 0,(TB) ; SPECIAL TYPE IF SO
+ CAIE 0,TDCLI
+ JRST FINIS ; NO, JUST FINIS
+ MOVEI 0,PFINIS ; CAUSE TO FALL INTO FUNCTION CODE
+ HRRM 0,PCSAV(TB)
+ JRST CONTIN
+
+
+RET2: AOJL A,TMA
+ GETYP A,(AB)+2
+ CAIE A,TACT ; AS FOR "EXIT" SHOULD BE ACTIVATION
+ JRST WTYP2
+ MOVEI B,(AB)+2 ; ADDRESS OF FRAME POINTER
+ JRST COMRET
+
+
+
+MFUNCTION AGAIN,SUBR
+ ENTRY
+ HLRZ A,AB ;GET # OF ARGS
+ CAIN A,-2 ;1 ARG?
+ JRST NLCLA ;YES
+ JUMPN A,TMA ;0 ARGS?
+ PUSHJ P,PROGCH ;CHECK FOR IN A PROG
+ PUSH TP,A
+ PUSH TP,B
+ JRST AGAD
+NLCLA: GETYP A,(AB)
+ CAIE A,TACT
+ JRST WTYP1
+ PUSH TP,(AB)
+ PUSH TP,1(AB)
+AGAD: MOVEI B,-1(TP) ; POINT TO FRAME
+ PUSHJ P,CHFSWP
+ HRRZ C,(B) ; GET RET POINT
+GOJOIN: PUSH TP,$TFIX
+ PUSH TP,C
+ MOVEI C,-1(TP)
+ PUSHJ P,CHUNW ; RESTORE FRAME, UNWIND IF NEC.
+ HRRM B,PCSAV(TB)
+ HRRZ 0,FSAV(TB) ; CHECK FOR RSUBR
+ CAIGE 0,HIBOT
+ CAIGE 0,STOSTR
+ JRST CONTIN
+ HRRZ E,1(TB)
+ PUSH TP,$TFIX
+ PUSH TP,B
+ MOVEI C,-1(TP)
+ MOVEI B,(TB)
+ PUSHJ P,CHUNW1
+ MOVE TP,1(TB)
+ MOVE SP,SPSTOR+1
+ MOVEM SP,SPSAV(TB)
+ MOVEM TP,TPSAV(TB)
+ MOVE C,OTBSAV(TB) ; AND RESTORE P FROM FATHER
+ MOVE P,PSAV(C)
+ MOVEM P,PSAV(TB)
+ SKIPGE PCSAV(TB)
+ HRLI B,400000+M
+ MOVEM B,PCSAV(TB)
+ JRST CONTIN
+
+MFUNCTION GO,SUBR
+ ENTRY 1
+ GETYP A,(AB)
+ CAIE A,TATOM
+ JRST NLCLGO
+ PUSHJ P,PROGCH ;CHECK FOR A PROG
+ PUSH TP,A ;SAVE
+ PUSH TP,B
+ MOVEI B,-1(TP)
+ PUSHJ P,CHFSWP
+ PUSH TP,$TATOM
+ PUSH TP,1(C)
+ PUSH TP,2(B)
+ PUSH TP,3(B)
+ MCALL 2,MEMQ ;DOES IT HAVE THIS TAG?
+ JUMPE B,NXTAG ;NO -- ERROR
+FNDGO: EXCH B,(TP) ;SAVE PLACE TO GO
+ MOVSI D,TLIST
+ MOVEM D,-1(TP)
+ JRST GODON
+
+NLCLGO: CAIE A,TTAG ;CHECK TYPE
+ JRST WTYP1
+ MOVE B,1(AB)
+ MOVEI B,2(B) ; POINT TO SLOT
+ PUSHJ P,CHFSWP
+ MOVE A,1(C)
+ GETYP 0,(A) ; SEE IF COMPILED
+ CAIE 0,TFIX
+ JRST GODON1
+ MOVE C,1(A)
+ JRST GOJOIN
+
+GODON1: PUSH TP,(A) ;SAVE BODY
+ PUSH TP,1(A)
+GODON: MOVEI C,0
+ PUSHJ P,CHUNW ;GO BACK TO CORRECT FRAME
+ MOVE B,(TP) ;RESTORE ITERATION MARKER
+ MOVEM B,1(TB)
+ MOVSI A,TATOM
+ MOVE B,1(B)
+ JRST CONTIN
+
+\f
+
+
+MFUNCTION TAG,SUBR
+ ENTRY
+ JUMPGE AB,TFA
+ HLRZ 0,AB
+ GETYP A,(AB) ;GET TYPE OF ARGUMENT
+ CAIE A,TFIX ; FIX ==> COMPILED
+ JRST ATOTAG
+ CAIE 0,-4
+ JRST WNA
+ GETYP A,2(AB)
+ CAIE A,TACT
+ JRST WTYP2
+ PUSH TP,(AB)
+ PUSH TP,1(AB)
+ PUSH TP,2(AB)
+ PUSH TP,3(AB)
+ JRST GENTV
+ATOTAG: CAIE A,TATOM ;CHECK THAT IT IS AN ATOM
+ JRST WTYP1
+ CAIE 0,-2
+ JRST TMA
+ PUSHJ P,PROGCH ;CHECK PROG
+ PUSH TP,A ;SAVE VAL
+ PUSH TP,B
+ PUSH TP,$TATOM
+ PUSH TP,1(AB)
+ PUSH TP,2(B)
+ PUSH TP,3(B)
+ MCALL 2,MEMQ
+ JUMPE B,NXTAG ;IF NOT FOUND -- ERROR
+ EXCH A,-1(TP) ;SAVE PLACE
+ EXCH B,(TP)
+ HRLI A,TFRAME
+ PUSH TP,A
+ PUSH TP,B
+GENTV: MOVEI A,2
+ PUSHJ P,IEVECT
+ MOVSI A,TTAG
+ JRST FINIS
+
+PROGCH: MOVE B,IMQUOTE LPROG,[LPROG ]INTRUP
+ PUSHJ P,ILVAL ;GET VALUE
+ GETYP 0,A
+ CAIE 0,TACT
+ JRST NXPRG
+ POPJ P,
+
+; HERE TO UNASSIGN LPROG IF NEC
+
+UNPROG: MOVE B,IMQUOTE LPROG,[LPROG ]INTRUP
+ PUSHJ P,ILVAL
+ GETYP 0,A
+ CAIE 0,TACT ; SKIP IF MUST UNBIND
+ JRST UNMAP
+ MOVSI A,TUNBOU
+ MOVNI B,1
+ MOVE E,IMQUOTE LPROG,[LPROG ]INTRUP
+ PUSHJ P,PSHBND
+UNMAP: HRRZ 0,FSAV(TB) ; CHECK FOR FUNNY
+ CAIN 0,MAPPLY ; SKIP IF NOT
+ POPJ P,
+ MOVE B,IMQUOTE LMAP,[LMAP ]INTRUP
+ PUSHJ P,ILVAL
+ GETYP 0,A
+ CAIE 0,TFRAME
+ JRST UNSPEC
+ MOVSI A,TUNBOU
+ MOVNI B,1
+ MOVE E,IMQUOTE LMAP,[LMAP ]INTRUP
+ PUSHJ P,PSHBND
+UNSPEC: PUSH TP,BNDV
+ MOVE B,PVSTOR+1
+ ADD B,[CURFCN,,CURFCN]
+ PUSH TP,B
+ PUSH TP,$TSP
+ MOVE E,SPSTOR+1
+ ADD E,[3,,3]
+ PUSH TP,E
+ POPJ P,
+
+REPEAT 0,[
+MFUNCTION MEXIT,SUBR,[EXIT]
+ ENTRY 2
+ GETYP A,(AB)
+ CAIE A,TACT
+ JRST WTYP1
+ MOVEI B,(AB)
+ PUSHJ P,CHFSWP
+ ADD C,[2,,2]
+ PUSHJ P,CHUNW ;RESTORE FRAME
+ JRST CHFINI ; CHECK FOR WINNING VALUE
+]
+
+MFUNCTION COND,FSUBR
+ ENTRY 1
+ GETYP A,(AB)
+ CAIE A,TLIST
+ JRST WRONGT
+ PUSH TP,(AB)
+ PUSH TP,1(AB) ;CREATE UNNAMED TEMP
+ MOVEI B,0 ; SET TO FALSE IN CASE
+
+CLSLUP: SKIPN C,1(TB) ;IS THE CLAUSELIST NIL?
+ JRST IFALS1 ;YES -- RETURN NIL
+ GETYP A,(C) ;NO -- GET TYPE OF CAR
+ CAIE A,TLIST ;IS IT A LIST?
+ JRST BADCLS ;
+ MOVE A,1(C) ;YES -- GET CLAUSE
+ JUMPE A,BADCLS
+ GETYPF B,(A)
+ PUSH TP,B ; EVALUATION OF
+ HLLZS (TP)
+ PUSH TP,1(A) ;THE PREDICATE
+ JSP E,CHKARG
+ MCALL 1,EVAL
+ GETYP 0,A
+ CAIN 0,TFALSE
+ JRST NXTCLS ;FALSE TRY NEXT CLAUSE
+ MOVE C,1(TB) ;IF NOT, DO FIRST CLAUSE
+ MOVE C,1(C)
+ HRRZ C,(C)
+ JUMPE C,FINIS ;(UNLESS DONE WITH IT)
+ JRST DOPRG2 ;AS THOUGH IT WERE A PROG
+NXTCLS: HRRZ C,@1(TB) ;SET THE CLAUSLIST
+ HRRZM C,1(TB) ;TO CDR OF THE CLAUSLIST
+ JRST CLSLUP
+
+IFALSE:
+ MOVEI B,0
+IFALS1: MOVSI A,TFALSE ;RETURN FALSE
+ JRST FINIS
+
+
+\f
+MFUNCTION UNWIND,FSUBR
+
+ ENTRY 1
+
+ GETYP 0,(AB) ; CHECK THE ARGS FOR WINNAGE
+ SKIPN A,1(AB) ; NONE?
+ JRST TFA
+ HRRZ B,(A) ; CHECK FOR 2D
+ JUMPE B,TFA
+ HRRZ 0,(B) ; 3D?
+ JUMPN 0,TMA
+
+; Unbind LPROG and LMAPF so that nothing cute happens
+
+ PUSHJ P,UNPROG
+
+; Push thing to do upon UNWINDing
+
+ PUSH TP,$TLIST
+ PUSH TP,[0]
+
+ MOVEI C,UNWIN1
+ PUSHJ P,IUNWIN ; GOT TO INTERNAL SET UP
+
+; Now EVAL the first form
+
+ MOVE A,1(AB)
+ HRRZ 0,(A) ; SAVE POINTER TO OTHER GUY
+ MOVEM 0,-12(TP)
+ MOVE B,1(A)
+ GETYP A,(A)
+ MOVSI A,(A)
+ JSP E,CHKAB ; DEFER?
+ PUSH TP,A
+ PUSH TP,B
+ MCALL 1,EVAL ; EVAL THE LOSER
+
+ JRST FINIS
+
+; Now push slots to hold undo info on the way down
+
+IUNWIN: JUMPE M,NOUNRE
+ HLRE 0,M ; CHECK BOUNDS
+ SUBM M,0
+ ANDI 0,-1
+ CAIL C,(M)
+ CAML C,0
+ JRST .+2
+ SUBI C,(M)
+
+NOUNRE: PUSH TP,$TTB ; DESTINATION FRAME
+ PUSH TP,[0]
+ PUSH TP,[0] ; ARGS TO WHOEVER IS DOING IT
+ PUSH TP,[0]
+
+; Now bind UNWIND word
+
+ PUSH TP,$TUNWIN ; FIRST WORD OF IT
+ MOVE SP,SPSTOR+1
+ HRRM SP,(TP) ; CHAIN
+ MOVEM TP,SPSTOR+1
+ PUSH TP,TB ; AND POINT TO HERE
+ PUSH TP,$TTP
+ PUSH TP,[0]
+ HRLI C,TPDL
+ PUSH TP,C
+ PUSH TP,P ; SAVE PDL ALSO
+ MOVEM TP,-2(TP) ; SAVE FOR LATER
+ POPJ P,
+
+; Do a non-local return with UNWIND checking
+
+CHUNW: HRRZ E,SPSAV(B) ; GET DESTINATION FRAME
+CHUNW1: PUSH TP,(C) ; FINAL VAL
+ PUSH TP,1(C)
+ JUMPN C,.+3 ; WAS THERE REALLY ANYTHING
+ SETZM (TP)
+ SETZM -1(TP)
+ PUSHJ P,STLOOP ; UNBIND
+CHUNPC: SKIPA ; WILL NOT SKIP UNLESS UNWIND FOUND
+ JRST GOTUND
+ MOVEI A,(TP)
+ SUBI A,(SP)
+ MOVSI A,(A)
+ HLL SP,TP
+ SUB SP,A
+ MOVEM SP,SPSTOR+1
+ HRRI TB,(B) ; UPDATE TB
+ PUSHJ P,UNWFRMS
+ POP TP,B
+ POP TP,A
+ POPJ P,
+
+POPUNW: MOVE SP,SPSTOR+1
+ HRRZ SP,(SP)
+ MOVEI E,(TP)
+ SUBI E,(SP)
+ MOVSI E,(E)
+ HLL SP,TP
+ SUB SP,E
+ MOVEM SP,SPSTOR+1
+ POPJ P,
+
+
+UNWFRM: JUMPE FRM,CPOPJ
+ MOVE B,FRM
+UNWFR2: JUMPE B,UNWFR1
+ CAMG B,TPSAV(TB)
+ JRST UNWFR1
+ MOVE B,(B)
+ JRST UNWFR2
+
+UNWFR1: MOVE FRM,B
+ POPJ P,
+
+; Here if an UNDO found
+
+GOTUND: MOVE TB,1(SP) ; GET FRAME OF UNDO
+ MOVE A,-1(TP) ; GET FUNNY ARG FOR PASS ON
+ MOVE C,(TP)
+ MOVE TP,3(SP) ; GET FUTURE TP
+ MOVEM C,-6(TP) ; SAVE ARG
+ MOVEM A,-7(TP)
+ MOVE C,(TP) ; SAVED P
+ SUB C,[1,,1]
+ MOVEM C,PSAV(TB) ; MAKE CONTIN WIN
+ MOVEM TP,TPSAV(TB)
+ MOVEM SP,SPSAV(TB)
+ HRRZ C,(P) ; PC OF CHUNW CALLER
+ HRRM C,-11(TP) ; SAVE ALSO AND GET WHERE TO GO PC
+ MOVEM B,-10(TP) ; AND DESTINATION FRAME
+ HRRZ C,-1(TP) ; WHERE TO UNWIND PC
+ HRRZ 0,FSAV(TB) ; RSUBR?
+ CAIGE 0,HIBOT
+ CAIGE 0,STOSTR
+ JRST .+3
+ SKIPGE PCSAV(TB)
+ HRLI C,400000+M
+ MOVEM C,PCSAV(TB)
+ JRST CONTIN
+
+UNWIN1: MOVE B,-12(TP) ; POINT TO THING TO DO UNWINDING
+ GETYP A,(B)
+ MOVSI A,(A)
+ MOVE B,1(B)
+ JSP E,CHKAB
+ PUSH TP,A
+ PUSH TP,B
+ MCALL 1,EVAL
+UNWIN2: MOVEI C,-7(TP) ; POINT TO SAVED RET VALS
+ MOVE B,-10(TP)
+ HRRZ E,-11(TP)
+ PUSH P,E
+ MOVE SP,SPSTOR+1
+ HRRZ SP,(SP) ; UNBIND THIS GUY
+ MOVEI E,(TP) ; AND FIXUP SP
+ SUBI E,(SP)
+ MOVSI E,(E)
+ HLL SP,TP
+ SUB SP,E
+ MOVEM SP,SPSTOR+1
+ JRST CHUNW ; ANY MORE TO UNWIND?
+
+\f
+; CHFSWP - CHECK FRAMES VALIDITY AND SWAP PROCESS IF NECESSARY.
+; CALLED BY ALL CONTROL FLOW
+; ROUTINES (GO,RETURN,EXIT,AGAIN,ERRET...)
+
+CHFSWP: PUSHJ P,CHFRM ; CHECK FOR VALID FRAME
+ HRRZ D,(B) ; PROCESS VECTOR DOPE WD
+ HLRZ C,(D) ; LENGTH
+ SUBI D,-1(C) ; POINT TO TOP
+ MOVNS C ; NEGATE COUNT
+ HRLI D,2(C) ; BUILD PVP
+ MOVE E,PVSTOR+1
+ MOVE C,AB
+ MOVE A,(B) ; GET FRAME
+ MOVE B,1(B)
+ CAMN E,D ; SKIP IF SWAP NEEDED
+ POPJ P,
+ PUSH TP,A ; SAVE FRAME
+ PUSH TP,B
+ MOVE B,D
+ PUSHJ P,PROCHK ; FIX UP PROCESS LISTS
+ MOVE A,PSTAT+1(B) ; GET STATE
+ CAIE A,RESMBL
+ JRST NOTRES
+ MOVE D,B ; PREPARE TO SWAP
+ POP P,0 ; RET ADDR
+ POP TP,B
+ POP TP,A
+ JSP C,SWAP ; SWAP IN
+ MOVE C,ABSTO+1(E) ; GET OLD ARRGS
+ MOVEI A,RUNING ; FIX STATES
+ MOVE PVP,PVSTOR+1
+ MOVEM A,PSTAT+1(PVP)
+ MOVEI A,RESMBL
+ MOVEM A,PSTAT+1(E)
+ JRST @0
+
+NOTRES: ERRUUO EQUOTE PROCESS-NOT-RESUMABLE
+\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.
+
+IMFUNCTION SETG,SUBR
+ ENTRY 2
+ GETYP A,(AB) ;GET TYPE OF FIRST ARGUMENT
+ CAIE A,TATOM ;CHECK THAT IT IS AN ATOM
+ JRST NONATM ;IF NOT -- ERROR
+ MOVE B,1(AB) ;GET POINTER TO ATOM
+ PUSH TP,$TATOM
+ PUSH TP,B
+ MOVEI 0,(B)
+ CAIL 0,HIBOT ; PURE ATOM?
+ PUSHJ P,IMPURIFY ; YES IMPURIFY
+ PUSHJ P,IGLOC ;GET LOCATIVE TO VALUE
+ CAME A,$TUNBOUND ;IF BOUND
+ JRST GOOST1
+ SKIPN NOSETG ; ALLOWED?
+ JRST GOOSTG ; YES
+ PUSH TP,$TATOM
+ PUSH TP,EQUOTE CREATING-NEW-GVAL
+ PUSH TP,$TATOM
+ PUSH TP,1(AB)
+ PUSH TP,$TATOM
+ PUSH TP,EQUOTE NON-FALSE-TO-ALLOW
+ MCALL 3,ERROR
+ GETYP 0,A
+ CAIN 0,TFALSE
+ JRST FINIS
+GOOSTG: PUSHJ P,BSETG ;IF NOT -- BIND IT
+GOOST1: MOVE C,2(AB) ; GET PROPOSED VVAL
+ MOVE D,3(AB)
+ MOVSI A,TLOCD ; MAKE SURE MONCH WINS
+ PUSHJ P,MONCH0 ; WOULD YOU BELIEVE MONITORS!!!!
+ EXCH D,B ;SAVE PTR
+ MOVE A,C
+ HRRZ E,-2(D) ; POINT TO POSSIBLE GDECL (OR MAINIFEST)
+ JUMPE E,OKSETG ; NONE ,OK
+ CAIE E,-1 ; MANIFEST?
+ JRST SETGTY
+ GETYP 0,(D) ; IF UNBOUND, LET IT HAPPEN
+ SKIPN IGDECL
+ CAIN 0,TUNBOU
+ JRST OKSETG
+MANILO: GETYP C,(D)
+ GETYP 0,2(AB)
+ CAIN 0,(C)
+ CAME B,1(D)
+ JRST .+2
+ JRST OKSETG
+ PUSH TP,$TVEC
+ PUSH TP,D
+ MOVE B,IMQUOTE REDEFINE
+ PUSHJ P,ILVAL ; SEE IF REDEFINE OK
+ GETYP A,A
+ CAIE A,TUNBOU
+ CAIN A,TFALSE
+ JRST .+2
+ JRST OKSTG
+ PUSH TP,$TATOM
+ PUSH TP,EQUOTE ATTEMPT-TO-CHANGE-MANIFEST-VARIABLE
+ PUSH TP,$TATOM
+ PUSH TP,1(AB)
+ MOVEI A,2
+ JRST CALER
+
+SETGTY: PUSH TP,$TVEC
+ PUSH TP,D
+ MOVE C,A
+ MOVE D,B
+ GETYP A,(E)
+ MOVSI A,(A)
+ MOVE B,1(E)
+ JSP E,CHKAB
+ PUSHJ P,TMATCH
+ JRST TYPMI3
+
+OKSTG: MOVE D,(TP)
+ MOVE A,2(AB)
+ MOVE B,3(AB)
+
+OKSETG: MOVEM A,(D) ;DEPOSIT INTO THE
+ MOVEM B,1(D) ;INDICATED VALUE CELL
+ JRST FINIS
+
+TYPMI3: MOVE C,(TP)
+ HRRZ C,-2(C)
+ MOVE D,2(AB)
+ MOVE B,3(AB)
+ MOVE 0,(AB)
+ MOVE A,1(AB)
+ JRST TYPMIS
+
+BSETG: HRRZ A,GLOBASE+1
+ HRRZ B,GLOBSP+1
+ SUB B,A
+ CAIL B,6
+ JRST SETGIT
+ MOVEI B,0 ; MAKE SURE OF NO EMPTY SLOTS
+ PUSHJ P,IGLOC
+ CAMN A,$TUNBOU ; SKIP IF SLOT FOUND
+ JRST BSETG1
+ MOVE C,(TP) ; GET ATOM
+ MOVEM C,-1(B) ; CLOBBER ATOM SLOT
+ HLLZS -2(B) ; CLOBBER OLD DECL
+ JRST BSETGX
+; BSETG1: PUSH TP,GLOBASE ; MUST REALLY GROW STACK
+; PUSH TP,GLOBASE+1
+; PUSH TP,$TFIX
+; PUSH TP,[0]
+; PUSH TP,$TFIX
+; PUSH TP,[100]
+; MCALL 3,GROW
+BSETG1: PUSH P,0
+ PUSH P,C
+ MOVE C,GLOBASE+1
+ HLRE B,C
+ SUB C,B
+ MOVE B,GVLINC ; GROW BY INDICATED GVAL SLOTS
+ DPB B,[001100,,(C)]
+; MOVEM A,GLOBASE
+ MOVE C,[6,,4] ; INDICATOR FOR AGC
+ PUSHJ P,AGC
+ MOVE B,GLOBASE+1
+ MOVE 0,GVLINC ; ADJUST GLOBAL SPBASE
+ ASH 0,6
+ SUB B,0
+ HRLZS 0
+ SUB B,0
+ MOVEM B,GLOBASE+1
+; MOVEM B,GLOBASE+1
+ POP P,0
+ POP P,C
+SETGIT:
+ MOVE B,GLOBSP+1
+ SUB B,[4,,4]
+ MOVSI C,TGATOM
+ MOVEM C,(B)
+ MOVE C,(TP)
+ MOVEM C,1(B)
+ MOVEM B,GLOBSP+1
+ ADD B,[2,,2]
+BSETGX: MOVSI A,TLOCI
+ PUSHJ P,PATSCH ; FIXUP SCHLPAGE
+ MOVEM A,(C)
+ MOVEM B,1(C)
+ POPJ P,
+
+PATSCH: GETYP 0,(C)
+ CAIN 0,TLOCI
+ SKIPL D,1(C)
+ POPJ P,
+
+PATL: SKIPL E,3(D) ; SKIP IF NEXT EXISTS
+ JRST PATL1
+ MOVE D,E
+ JRST PATL
+
+PATL1: MOVEI E,1
+ MOVEM E,3(D) ; SAY GVAL ETC. EXISTS IF WE UNBIND
+ POPJ P,
+
+
+IMFUNCTION DEFMAC,FSUBR
+
+ ENTRY 1
+
+ PUSH P,.
+ JRST DFNE2
+
+IMFUNCTION DFNE,FSUBR,[DEFINE]
+
+ ENTRY 1
+
+ PUSH P,[0]
+DFNE2: GETYP A,(AB)
+ CAIE A,TLIST
+ JRST WRONGT
+ SKIPN B,1(AB) ; GET ATOM
+ JRST TFA
+ GETYP A,(B) ; MAKE SURE ATOM
+ MOVSI A,(A)
+ PUSH TP,A
+ PUSH TP,1(B)
+ JSP E,CHKARG
+ MCALL 1,EVAL ; EVAL IT TO AN ATOM
+ CAME A,$TATOM
+ JRST NONATM
+ PUSH TP,A ; SAVE TWO COPIES
+ PUSH TP,B
+ PUSHJ P,IGVAL ; SEE IF A VALUE EXISTS
+ CAMN A,$TUNBOU ; SKIP IF A WINNER
+ JRST .+3
+ PUSHJ P,ASKUSR ; CHECK WITH USER
+ JRST DFNE1
+ PUSH TP,$TATOM
+ PUSH TP,-1(TP)
+ MOVE B,1(AB)
+ HRRZ B,(B)
+ MOVSI A,TEXPR
+ SKIPN (P) ; SKIP IF MACRO
+ JRST DFNE3
+ MOVEI D,(B) ; READY TO CONS
+ MOVSI C,TEXPR
+ PUSHJ P,INCONS
+ MOVSI A,TMACRO
+DFNE3: PUSH TP,A
+ PUSH TP,B
+ MCALL 2,SETG
+DFNE1: POP TP,B ; RETURN ATOM
+ POP TP,A
+ JRST FINIS
+
+
+ASKUSR: MOVE B,IMQUOTE REDEFINE
+ PUSHJ P,ILVAL ; SEE IF REDEFINE OK
+ GETYP A,A
+ CAIE A,TUNBOU
+ CAIN A,TFALSE
+ JRST ASKUS1
+ JRST ASKUS2
+ASKUS1: PUSH TP,$TATOM
+ PUSH TP,-1(TP)
+ PUSH TP,$TATOM
+ PUSH TP,EQUOTE ALREADY-DEFINED-ERRET-NON-FALSE-TO-REDEFINE
+ MCALL 2,ERROR
+ GETYP 0,A
+ CAIE 0,TFALSE
+ASKUS2: AOS (P)
+ MOVE B,1(AB)
+ 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.
+
+IMFUNCTION SET,SUBR
+ HLRE D,AB ; 2 TIMES # OF ARGS TO D
+ ASH D,-1 ; - # OF ARGS
+ ADDI D,2
+ JUMPG D,TFA ; NOT ENOUGH
+ MOVE B,PVSTOR+1
+ MOVE C,SPSTOR+1
+ JUMPE D,SET1 ; NO ENVIRONMENT
+ AOJL D,TMA ; TOO MANY
+ GETYP A,4(AB) ; CHECK ARG IS A FRAME OR PROCESS
+ CAIE A,TFRAME
+ CAIN A,TENV
+ JRST SET2 ; WINNING ENVIRONMENT/FRAME
+ CAIN A,TACT
+ JRST SET2 ; TO MAKE PFISTER HAPPY
+ CAIE A,TPVP
+ JRST WTYP2
+ MOVE B,5(AB) ; GET PROCESS
+ MOVE C,SPSTO+1(B)
+ JRST SET1
+SET2: MOVEI B,4(AB) ; POINT TO FRAME
+ PUSHJ P,CHFRM ; CHECK IT OUT
+ MOVE B,5(AB) ; GET IT BACK
+ MOVE C,SPSAV(B) ; GET BINDING POINTER
+ HRRZ B,4(AB) ; POINT TO PROCESS
+ HLRZ A,(B) ; GET LENGTH
+ SUBI B,-1(A) ; POINT TO START THEREOF
+ HLL B,PVSTOR+1 ; GET -LNTRH, (ALL PROCESS VECS SAME LENGTH)
+SET1: PUSH TP,$TPVP ; SAVE PROCESS
+ PUSH TP,B
+ PUSH TP,$TSP ; SAVE PATH POINTER
+ PUSH TP,C
+ GETYP A,(AB) ;GET TYPE OF FIRST
+ CAIE A,TATOM ;ARGUMENT --
+ JRST WTYP1 ;BETTER BE AN ATOM
+ MOVE B,1(AB) ;GET PTR TO IT
+ MOVEI 0,(B)
+ CAIL 0,HIBOT
+ PUSHJ P,IMPURIFY
+ MOVE C,(TP)
+ PUSHJ P,AILOC ;GET LOCATIVE TO VALUE
+GOTLOC: CAME A,$TUNBOUND ;IF BOUND
+ JRST GOOSE1
+ SKIPN NOSET ; ALLOWED?
+ JRST GOOSET ; YES
+ PUSH TP,$TATOM
+ PUSH TP,EQUOTE CREATING-NEW-LVAL
+ PUSH TP,$TATOM
+ PUSH TP,1(AB)
+ PUSH TP,$TATOM
+ PUSH TP,EQUOTE NON-FALSE-TO-ALLOW
+ MCALL 3,ERROR
+ GETYP 0,A
+ CAIN 0,TFALSE
+ JRST FINIS
+GOOSET: PUSHJ P,BSET ;IF NOT -- BIND IT
+GOOSE1: MOVE C,2(AB) ; GET PROPOSED VVAL
+ MOVE C,2(AB) ; GET NEW VAL
+ MOVE D,3(AB)
+ MOVSI A,TLOCD ; FOR MONCH
+ HRR A,2(B)
+ PUSHJ P,MONCH0 ; HURRAY FOR MONITORS!!!!!
+ MOVE E,B
+ HLRZ A,2(E) ; GET DECLS
+ JUMPE A,SET3 ; NONE, GO
+ PUSH TP,$TSP
+ PUSH TP,E
+ MOVE B,1(A)
+ HLLZ A,(A) ; GET PATTERN
+ PUSHJ P,TMATCH ; MATCH TMEM
+ JRST TYPMI2 ; LOSES
+ MOVE E,(TP)
+ SUB TP,[2,,2]
+ MOVE C,2(AB)
+ MOVE D,3(AB)
+SET3: MOVEM C,(E) ;CLOBBER IDENTIFIER
+ MOVEM D,1(E)
+ MOVE A,C
+ MOVE B,D
+ MOVE C,-2(TP) ; GET PROC
+ HRRZ C,BINDID+1(C)
+ HRLI C,TLOCI
+
+; HERE WE NOTE THAT EFFICIENCY CAN SOMETIMES GET IN THE WAY OF CORRECTNESS
+; BY SETTING THE SHALLOW BINDING WE MANAGE TO CLOBBER THE TOP LEVEL LVAL
+; EVEN IF WE ARE SETTING WITH RESPECT TO A DIFFERENT FRAME. TO CORRECT
+; THIS GLITCH THIS ACTIVITY WILL ONLY TAKE PLACE IF THE ATOM ALREADY POINTS
+; TO A BINDING
+
+ MOVE D,1(AB)
+ SKIPE (D)
+ JRST NSHALL
+ MOVEM C,(D)
+ MOVEM E,1(D)
+NSHALL: SUB TP,[4,,4]
+ JRST FINIS
+BSET:
+ MOVE PVP,PVSTOR+1
+ CAMN PVP,-2(TP) ; SKIP IF PROC DIFFERS
+ MOVEM C,-2(TP) ; ELSE USE RESULT FROM LOC SEARCH
+ MOVE B,-2(TP) ; GET PROCESS
+ HRRZ A,TPBASE+1(B) ;GET ACTUAL STACK BASE
+ HRRZ B,SPBASE+1(B) ;AND FIRST BINDING
+ SUB B,A ;ARE THERE 6
+ CAIL B,6 ;CELLS AVAILABLE?
+ JRST SETIT ;YES
+ MOVE C,(TP) ; GET POINTER BACK
+ MOVEI B,0 ; LOOK FOR EMPTY SLOT
+ PUSHJ P,AILOC
+ CAMN A,$TUNBOUND ; SKIP IF FOUND
+ JRST BSET1
+ MOVE E,1(AB) ; GET ATOM
+ MOVEM E,-1(B) ; AND STORE
+ JRST BSET2
+BSET1: MOVE B,-2(TP) ; GET PROCESS
+; PUSH TP,TPBASE(B) ;NO -- GROW THE TP
+; PUSH TP,TPBASE+1(B) ;AT THE BASE END
+; PUSH TP,$TFIX
+; PUSH TP,[0]
+; PUSH TP,$TFIX
+; PUSH TP,[100]
+; MCALL 3,GROW
+; MOVE C,-2(TP) ; GET PROCESS
+; MOVEM A,TPBASE(C) ;SAVE RESULT
+ PUSH P,0 ; MANUALLY GROW VECTOR
+ PUSH P,C
+ MOVE C,TPBASE+1(B)
+ HLRE B,C
+ SUB C,B
+ MOVEI C,1(C)
+ CAME C,TPGROW
+ ADDI C,PDLBUF
+ MOVE D,LVLINC
+ DPB D,[001100,,-1(C)]
+ MOVE C,[5,,3] ; SET UP INDICATORS FOR AGC
+ PUSHJ P,AGC
+ MOVE PVP,PVSTOR+1
+ MOVE B,TPBASE+1(PVP) ; MODIFY POINTER
+ MOVE 0,LVLINC ; ADJUST SPBASE POINTER
+ ASH 0,6
+ SUB B,0
+ HRLZS 0
+ SUB B,0
+ MOVEM B,TPBASE+1(PVP)
+ POP P,C
+ POP P,0
+; MOVEM B,TPBASE+1(C)
+SETIT: MOVE C,-2(TP) ; GET PROCESS
+ MOVE B,SPBASE+1(C)
+ 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)
+ SUB B,[6,,6]
+ MOVEM B,SPBASE+1(C)
+ ADD B,[2,,2]
+BSET2: MOVE C,-2(TP) ; GET PROC
+ MOVSI A,TLOCI
+ HRR A,BINDID+1(C)
+ HLRZ D,OTBSAV(TB) ; TIME IT
+ MOVEM D,2(B) ; AND FIX IT
+ POPJ P,
+
+; HERE TO ELABORATE ON TYPE MISMATCH
+
+TYPMI2: MOVE C,(TP) ; FIND DECLS
+ HLRZ C,2(C)
+ MOVE D,2(AB)
+ MOVE B,3(AB)
+ MOVE 0,(AB) ; GET ATOM
+ MOVE A,1(AB)
+ JRST TYPMIS
+
+\f
+
+MFUNCTION NOT,SUBR
+ ENTRY 1
+ GETYP A,(AB) ; GET TYPE
+ CAIE A,TFALSE ;IS IT FALSE?
+ JRST IFALSE ;NO -- RETURN FALSE
+
+TRUTH:
+ MOVSI A,TATOM ;RETURN T (VERITAS)
+ MOVE B,IMQUOTE T
+ JRST FINIS
+
+IMFUNCTION OR,FSUBR
+
+ PUSH P,[0]
+ JRST ANDOR
+
+MFUNCTION ANDA,FSUBR,AND
+
+ PUSH P,[1]
+ANDOR: ENTRY 1
+ GETYP A,(AB)
+ CAIE A,TLIST
+ JRST WRONGT ;IF ARG DOESN'T CHECK OUT
+ MOVE E,(P)
+ SKIPN C,1(AB) ;IF NIL
+ JRST TF(E) ;RETURN TRUTH
+ PUSH TP,$TLIST ;CREATE UNNAMED TEMP
+ PUSH TP,C
+ANDLP:
+ MOVE E,(P)
+ JUMPE C,TFI(E) ;ANY MORE ARGS?
+ MOVEM C,1(TB) ;STORE CRUFT
+ GETYP A,(C)
+ MOVSI A,(A)
+ PUSH TP,A
+ PUSH TP,1(C) ;ARGUMENT
+ JSP E,CHKARG
+ MCALL 1,EVAL
+ GETYP 0,A
+ MOVE E,(P)
+ XCT TFSKP(E)
+ JRST FINIS ;IF FALSE -- RETURN
+ HRRZ C,@1(TB) ;GET CDR OF ARGLIST
+ JRST ANDLP
+
+TF: JRST IFALSE
+ JRST TRUTH
+
+TFI: JRST IFALS1
+ JRST FINIS
+
+TFSKP: CAIE 0,TFALSE
+ CAIN 0,TFALSE
+
+IMFUNCTION FUNCTION,FSUBR
+
+ ENTRY 1
+
+ MOVSI A,TEXPR
+ MOVE B,1(AB)
+ JRST FINIS
+
+\f;SUBR VERSIONS OF AND/OR
+
+MFUNCTION ANDP,SUBR,[AND?]
+ JUMPGE AB,TRUTH
+ MOVE C,[CAIN 0,TFALSE]
+ JRST BOOL
+
+MFUNCTION ORP,SUBR,[OR?]
+ JUMPGE AB,IFALSE
+ MOVE C,[CAIE 0,TFALSE]
+BOOL: HLRE A,AB ; GET ARG COUNTER
+ MOVMS A
+ ASH A,-1 ; DIVIDES BY 2
+ MOVE D,AB
+ PUSHJ P,CBOOL
+ JRST FINIS
+
+CANDP: SKIPA C,[CAIN 0,TFALSE]
+CORP: MOVE C,[CAIE 0,TFALSE]
+ JUMPE A,CNOARG
+ MOVEI D,(A)
+ ASH D,1 ; TIMES 2
+ HRLI D,(D)
+ SUBB TP,D ; POINT TO ARGS & FIXUP TP PTR
+ AOBJP D,.+1 ; FIXUP ARG PTR AND FALL INTO CBOOL
+
+CBOOL: GETYP 0,(D)
+ XCT C ; WINNER ?
+ JRST CBOOL1 ; YES RETURN IT
+ ADD D,[2,,2]
+ SOJG A,CBOOL ; ANY MORE ?
+ SUB D,[2,,2] ; NO, USE LAST
+CBOOL1: MOVE A,(D)
+ MOVE B,(D)+1
+ POPJ P,
+
+
+CNOARG: MOVSI 0,TFALSE
+ XCT C
+ JRST CNOAND
+ MOVSI A,TFALSE
+ MOVEI B,0
+ POPJ P,
+CNOAND: MOVSI A,TATOM
+ MOVE B,IMQUOTE T
+ POPJ P,
+\f
+
+MFUNCTION CLOSURE,SUBR
+ ENTRY
+ SKIPL A,AB ;ANY ARGS
+ JRST TFA ;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
+
+\f
+
+;ERROR COMMENTS FOR EVAL
+
+BADNUM: ERRUUO EQUOTE NEGATIVE-ARGUMENT
+
+WTY1TP: ERRUUO EQUOTE FIRST-ARG-WRONG-TYPE
+
+UNBOU: PUSH TP,$TATOM
+ PUSH TP,EQUOTE UNBOUND-VARIABLE
+ JRST ER1ARG
+
+UNAS: PUSH TP,$TATOM
+ PUSH TP,EQUOTE UNASSIGNED-VARIABLE
+ JRST ER1ARG
+
+BADENV:
+ ERRUUO EQUOTE BAD-ENVIRONMENT
+
+FUNERR:
+ ERRUUO EQUOTE BAD-FUNARG
+
+
+MPD.0:
+MPD.1:
+MPD.2:
+MPD.3:
+MPD.4:
+MPD.5:
+MPD.6:
+MPD.7:
+MPD.8:
+MPD.9:
+MPD.10:
+MPD.11:
+MPD.12:
+MPD.13:
+MPD: ERRUUO EQUOTE MEANINGLESS-PARAMETER-DECLARATION
+
+NOBODY: ERRUUO EQUOTE HAS-EMPTY-BODY
+
+BADCLS: ERRUUO EQUOTE BAD-CLAUSE
+
+NXTAG: ERRUUO EQUOTE NON-EXISTENT-TAG
+
+NXPRG: ERRUUO EQUOTE NOT-IN-PROG
+
+NAPTL:
+NAPT: ERRUUO EQUOTE NON-APPLICABLE-TYPE
+
+NONEVT: ERRUUO EQUOTE NON-EVALUATEABLE-TYPE
+
+
+NONATM: ERRUUO EQUOTE NON-ATOMIC-ARGUMENT
+
+
+ILLFRA: ERRUUO EQUOTE FRAME-NO-LONGER-EXISTS
+
+ILLSEG: ERRUUO EQUOTE ILLEGAL-SEGMENT
+
+BADMAC: ERRUUO EQUOTE BAD-USE-OF-MACRO
+
+BADFSB: ERRUUO EQUOTE APPLY-OR-STACKFORM-OF-FSUBR
+
+
+ER1ARG: PUSH TP,(AB)
+ PUSH TP,1(AB)
+ MOVEI A,2
+ JRST CALER
+
+END
+\f
\ No newline at end of file
projects / pdp10-muddle.git / blobdiff