X-Git-Url: https://jxself.org/git/?p=pdp10-muddle.git;a=blobdiff_plain;f=%3Cmdl.int%3E%2Feval.mid.122;fp=%3Cmdl.int%3E%2Feval.mid.122;h=bf171810ddedd9933bfd619a836980ca4c688f2e;hp=0000000000000000000000000000000000000000;hb=bab072f950a643ac109660a223b57e635492ac25;hpb=233a3c5245f8274882cc9d27a3c20e9b3678000c diff --git a//eval.mid.122 b//eval.mid.122 new file mode 100644 index 0000000..bf17181 --- /dev/null +++ b//eval.mid.122 @@ -0,0 +1,4211 @@ +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 + \ No newline at end of file