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 .INSRT MUDDLE > MONITOR ; 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]] ;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, ; 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 ; 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, ; 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 ; 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,,[[TSUBR,APSUBR],[TFSUBR,APFSUB],[TRSUBR,APRSUB],[TFIX,APNUM] [TEXPR,APEXPR],[TFUNAR,APFUNARG],[TENTER,APENTR],[TMACRO,APMACR],[TOFFS,APNUM]] ; 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, ; 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,[] JRST .+3 CAME B,[+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 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 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 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? JRST MPD PUSHJ P,@E.ARG+1(TB) ; SEE IF ANYMORE ARGS JRST APRDON JRST TMA ; 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 ; 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 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, ; 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 ; 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 ; 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 ; 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,[] JRST .+3 CAME B,[+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) ; 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 ; 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 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 ; 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 ; 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 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 ; 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 ; 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 ; 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 ) OR ('A ) 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, ; 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 ; 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) 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 ; 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 ;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, ;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 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,E POPJ P, ; ENTRY FOR FUNNY COMPILER UNBIND (2) SSPEC1: PUSH P,E SUBI E,1 ; MAKE SURE GET CURRENT BINDING PUSHJ P,STLOOP ; UNBIND MOVEI E,(TP) ; NOW RESET SP JRST SSPEC2 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, ;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 ; 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 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 ; 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, ;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 ; 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 ; 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 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 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 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 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? ; 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 ;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 CAMN A,$TUNBOUND ;IF BOUND PUSHJ P,BSETG ;IF NOT -- BIND IT 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, ;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: CAMN A,$TUNBOUND ;BOUND? PUSHJ P, BSET ;BIND IT 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 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 ;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, 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 ;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