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