1 TITLE EVAL -- MUDDLE EVALUATOR
7 ; GERALD JAY SUSSMAN, 1971. REWRITTEN MANY TIMES SINCE C. REEVE (1972--1974)
10 .GLOBAL BINDID,LPROG,GLOBSP,GLOBASE,SPBASE,TPBASE,PTIME,SWAP,CHFRAM
11 .GLOBAL IGVAL,CHKARG,NXTDCL,TPOVFL,CHFRM,PROCHK,CHFSWP,VECBOT,TYPSGR
12 .GLOBAL ILVAL,ER1ARG,SPECBIND,MAKACT,SPECSTORE,MAKTUP,TPALOC,IBIND,SSPECS
13 .GLOBAL IDVAL,EVECTO,EUVECT,CHARGS,BCKTRK,CELL,ILOC,IGLOC,CHKDCL,SSPEC1
14 .GLOBAL PDLBUF,MESS,FACTI,CHKARG,MAKENV,PSTAT,BNDV,UNBOU,UNAS,IGDECL
15 .GLOBAL 1STEPR,SEGMNT,SEGLST,NAPT,EVTYPE,EVATYP,APTYPE,APLTYP,APLQ,IDVAL1
16 .GLOBAL TESTR,VALG,TYPG,INCR1,TMATCH,TYPMIS,SAT,MAKACT,NTPALO,SPECBND
17 .GLOBAL TPGROW,CHKAB,TYPSEG,NXTLM,MONCH0,CHFINI,RMONC0,IMPURIFY,ICONS,INCONS
18 .GLOBAL CILVAL,CISET,CIGVAL,CSETG,MAPPLY,CLLOC,CGLOC,CASSQ,CGASSQ,CBOUND
19 .GLOBAL IIGLOC,CHUNW,IUNWIN,UNWIN2,SPCCHK,CURFCN,TMPLNT,TD.LNT,TBINIT
20 .GLOBAL SPECBE,BSETG,GLOTOP,CANDP,CORP,TFA,TMA,DSTORE,PVSTOR,SPSTOR
21 .GLOBAL AGC,GVLINC,LVLINC,CGBOUN,IEVECT,MAKTU2,STOSTR,HIBOT,POPUNW,ISTRUC
29 ; ENTRY TO EXPAND A MACRO
36 MOVEI A,PVLNT*2+1(PVP)
52 SKIPE C,1STEPR+1(PVP) ; BEING 1 STEPPED?
53 JRST 1STEPI ; YES HANDLE
54 EVALON: HLRZ A,AB ;GET NUMBER OF ARGS
56 JRST AEVAL ;EVAL WITH AN ALIST
57 SEVAL: GETYP A,(AB) ;GET TYPE OF ARG
58 SKIPE C,EVATYP+1 ; USER TYPE TABLE?
60 SEVAL1: CAIG A,NUMPRI ;PRIMITIVE?
61 JRST SEVAL2 ;YES-DISPATCH
63 SELF: MOVE A,(AB) ;TYPES WHICH EVALUATE
65 JRST EFINIS ;TO SELF-EG NUMBERS
67 SEVAL2: HRRO A,EVTYPE(A)
70 ; HERE FOR USER EVAL DISPATCH
72 EVDISP: ADDI C,(A) ; POINT TO SLOT
74 SKIPE (C) ; SKIP EITHER A LOSER OR JRST DISP
75 JRST EVDIS1 ; APPLY EVALUATOR
76 SKIPN C,1(C) ; GET ADDR OR GO TO PURE DISP
84 MCALL 2,APPLY ; APPLY HACKER TO OBJECT
90 IF2,SELFS==400000,,SELF
92 DISTBL EVTYPE,SELFS,[[TFORM,EVFORM],[TLIST,EVLIST],[TVEC,EVECT],[TUVEC,EUVEC]
96 ;WATCH FOR SUBTLE BUG 43 LERR,LPROG OR BINDID
98 CAIE A,-4 ;EXACTLY 2 ARGS?
100 GETYP A,2(AB) ;CHECK THAT WE HAVE A FRAME
105 JRST TRYPRO ; COULD BE PROCESS
106 MOVEI B,2(AB) ; POINT TO FRAME
107 AEVAL2: PUSHJ P,CHENV ; HACK ENVIRONMENT CHANGE
111 AEVAL3: HRRZ 0,FSAV(TB)
116 TRYPRO: CAIE A,TPVP ; SKIP IF IT IS A PROCESS
118 MOVE C,3(AB) ; GET PROCESS
119 CAMN C,PVSTOR ; DIFFERENT FROM ME?
120 JRST SEVAL ; NO, NORMAL EVAL WINS
121 MOVE B,SPSTO+1(C) ; GET SP FOR PROCESS
122 MOVE D,TBSTO+1(C) ; GET TOP FRAME
123 HLL D,OTBSAV(D) ; TIME IT
124 MOVEI C,PVLNT*2+1(C) ; CONS UP POINTER TO PROC DOPE WORD
125 HRLI C,TFRAME ; LOOK LIK E A FRAME
126 PUSHJ P,SWITSP ; SPLICE ENVIRONMENT
129 ; ROUTINE TO CHANGE LOOK UP PATH FOR BINDINGS
131 CHENV: PUSHJ P,CHFRM ; CHECK OUT FRAME
132 MOVE C,(B) ; POINT TO PROCESS
133 MOVE D,1(B) ; GET TB POINTER FROM FRAME
134 CAMN SP,SPSAV(D) ; CHANGE?
135 POPJ P, ; NO, JUST RET
136 MOVE B,SPSAV(D) ; GET SP OF INTEREST
137 SWITSP: MOVSI 0,TSKIP ; SET UP SKIP
138 HRRI 0,1(TP) ; POINT TO UNBIND PATH
140 ADD A,[BINDID,,BINDID] ; BIND THE BINDING ID
146 MOVE E,TP ; FOR SPECBIND
149 PUSH TP,C ; SAVE PROCESS
151 PUSHJ P,SPECBE ; BIND BINDID
152 MOVE SP,TP ; GET NEW SP
153 SUB SP,[3,,3] ; SET UP SP FORK
158 ; HERE TO EVALUATE A FORM (99% OF EVAL'S WORK)
160 EVFORM: SKIPN C,1(AB) ; EMPTY FORM, RETURN FALSE
162 GETYP A,(C) ; 1ST ELEMENT OF FORM
164 JRST EV0 ; NO, EVALUATE IT
165 MOVE B,1(C) ; GET ATOM
166 PUSHJ P,IGVAL ; GET ITS GLOBAL VALUE
168 ; SPECIAL HACK TO SPEED UP LVAL AND GVAL CALLS
172 JRST ATMVAL ; FAST ATOM VALUE
175 CAIE 0,TUNBOU ; BOUND?
176 JRST IAPPLY ; YES APPLY IT
178 MOVE C,1(AB) ; LOOK FOR LOCAL
183 JRST IAPPLY ; WIN, GO APPLY IT
186 PUSH TP,EQUOTE UNBOUND-VARIABLE
188 MOVE C,1(AB) ; FORM BACK
191 PUSH TP,IMQUOTE VALUE
192 MCALL 3,ERROR ; REPORT THE ERROR
195 EFALSE: MOVSI A,TFALSE ; SPECIAL FALSE FOR EVAL OF EMPTY FORM
199 ATMVAL: HRRZ D,(C) ; CDR THE FORM
200 HRRZ 0,(D) ; AND AGAIN
202 GETYP 0,(D) ; MAKE SURE APPLYING TO ATOM
205 MOVEI E,IGVAL ; ASSUME GLOBAAL
206 CAIE B,GVAL ; SKIP IF OK
207 MOVEI E,ILVAL ; ELSE USE LOCAL
209 MOVE B,(D)+1 ; CLR BUG #1637 (GET THE ATOM FOR THE SUBR)
210 PUSHJ P,(E) ; AND GET VALUE
212 JRST EFINIS ; RETURN FROM EVAL
214 MOVSI A,TSUBR ; CAUSE REAL SUBR TO GET EROR
217 ; HERE FOR 1ST ELEMENT NOT A FORM
219 EV0: PUSHJ P,FASTEV ; EVAL IT
221 ; HERE TO APPLY THINGS IN FORMS
223 IAPPLY: PUSH TP,(AB) ; SAVE THE FORM
226 PUSH TP,B ; SAVE THE APPLIER
227 PUSH TP,$TFIX ; AND THE ARG GETTER
229 PUSHJ P,APLDIS ; GO TO INTERNAL APPLIER
230 JRST EFINIS ; LEAVE EVAL
232 ; HERE TO EVAL 1ST ELEMENT OF A FORM
234 FASTEV: MOVE PVP,PVSTOR+1
235 SKIPE 1STEPR+1(PVP) ; BEING 1 STEPPED?
236 JRST EV02 ; YES, LET LOSER SEE THIS EVAL
237 GETYP A,(C) ; GET TYPE
238 SKIPE D,EVATYP+1 ; USER TABLE?
239 JRST EV01 ; YES, HACK IT
240 EV03: CAIG A,NUMPRI ; SKIP IF SELF
241 SKIPA A,EVTYPE(A) ; GET DISPATCH
242 MOVEI A,SELF ; USE SLEF
244 EV04: CAIE A,SELF ; IF EVAL'S TO SELF, JUST USE IT
253 JSP E,CHKAB ; CHECK DEFERS
256 EV01: ADDI D,(A) ; POINT TO SLOT OF USER EVAL TABLE
258 SKIPE (D) ; EITHER NOT GIVEN OR SIMPLE
260 SKIPN 1(D) ; SKIP IF SIMPLE
261 JRST EV03 ; NOT GIVEN
266 HLLZS (TP) ; FIX UP LH
273 ; MAPF/MAPR CALL TO APPLY
279 ; APPLY, FALLS INTO EVAL'S APPLY CODE AT APLDIS
281 IMFUNCTION APPLY,SUBR
285 JUMPGE AB,TFA ; MUST BE AT LEAST 1 ARGUMENT
290 PUSH TP,(AB) ; SAVE FCN
292 PUSH TP,$TFIX ; AND ARG GETTER
293 PUSH TP,[SETZ APLARG]
297 ; STACKFROM, ALSO FALLS INTO EVAL'S APPLIER AT APLDIS
299 IMFUNCTION STACKFORM,FSUBR
306 MOVEI A,3 ; CHECK ALL GOODIES SUPPLIED
313 HRRZ C,1(AB) ; GET LIST BACK
314 PUSHJ P,FASTEV ; DO A FAST EVALUATION
316 HRRZ C,@1(AB) ; POINT TO ARG GETTING FORMS
321 PUSH TP,[SETZ EVALRG]
326 ; OFFSETS FOR TEMPORARIES ETC. USED IN APPLYING STUFF
328 E.FRM==0 ; POINTS TO FORM BEING EVALED (OR ARGS FOR APPLY STACKFORM)
329 E.FCN==2 ; FUNCTION/SUBR/RSUBR BEING APPLIED
330 E.ARG==4 ; POINTS TO ARG GETTING ROUTINE (<0 => MUST EVAL ARGS)
331 E.EXTR==6 ; CONTAINS 1ST ARG IN USER APPLY CASE
332 E.SEG==10 ; POINTS TO SEGMENT IN FORM BEING HACKED
333 E.CNT==12 ; COUNTER FOR TUPLES OF ARGS
334 E.DECL==14 ; POINTS TO DECLARATION LIST IN FUNCTIONS
335 E.ARGL==16 ; POINTS TO ARG LIST IN FUNCTIONS
336 E.HEW==20 ; POINTS TO HEWITT ATOM IF IT EXISTS
338 E.VAL==E.ARGL ; VALUE TYPE FOR RSUBRS
340 MINTM==E.EXTR+2 ; MIN # OF TEMPS EVER ALLOCATED
341 E.TSUB==E.CNT+2 ; # OF TEMPS FOR SUBR/NUMBER APPLICATION
342 XP.TMP==E.HEW-E.EXTR ; # EXTRA TEMPS FOR FUNCTION APPLICATION
343 R.TMP==4 ; TEMPS AFTER ARGS ARE BOUND
344 TM.OFF==E.HEW+2-R.TMP ; TEMPS TO FLUSH AFTER BIND OF ARGS
346 RE.FCN==0 ; AFTER BINDING CONTAINS FCN BODY
347 RE.ARG==2 ; ARG LIST AFTER BINDING
349 ; GENERAL THING APPLYER
351 APLDIS: PUSH TP,[0] ; SLOT USED FOR USER APPLYERS
353 APLDIX: GETYP A,E.FCN(TB) ; GET TYPE
355 APLDI: SKIPE D,APLTYP+1 ; USER TABLE EXISTS?
356 JRST APLDI1 ; YES, USE IT
357 APLDI2: CAILE A,NUMPRI ; SKIP IF NOT PRIM
362 APLDI1: ADDI D,(A) ; POINT TO SLOT
364 SKIPE (D) ; SKIP IF NOT GIVEN OR STANDARD
366 APLDI4: SKIPE D,1(D) ; GET DISP
368 JRST APLDI2 ; USE SYSTEM DISPATCH
370 APLDI3: SKIPE E.EXTR+1(TB) ; SKIP IF HAVEN'T BEEN HERE BEFORE
372 MOVE A,(D) ; GET ITS HANDLER
373 EXCH A,E.FCN(TB) ; AND USE AS FCN
374 MOVEM A,E.EXTR(TB) ; SAVE
377 MOVEM A,E.EXTR+1(TB) ; STASH OLD FCN AS EXTRG
378 GETYP A,(D) ; GET TYPE
382 ; APPLY DISPATCH TABLE
384 DISTBL APTYPE,<SETZ NAPTL>,[[TSUBR,APSUBR],[TFSUBR,APFSUB],[TRSUBR,APRSUB],[TFIX,APNUM]
385 [TEXPR,APEXPR],[TFUNAR,APFUNARG],[TENTER,APENTR],[TMACRO,APMACR],[TOFFS,APNUM]]
\f
387 ; SUBR TO SAY IF TYPE IS APPLICABLE
389 MFUNCTION APPLIC,SUBR,[APPLICABLE?]
398 ; HERE TO DETERMINE IF A TYPE IS APPLICABLE
402 JRST USEPUR ; USE PURE TABLE
404 ADDI B,(A) ; POINT TO SLOT
405 SKIPG 1(B) ; SKIP IF WINNER
406 SKIPE (B) ; SKIP IF POTENIAL LOSER
408 SKIPE 1(B) ; SKIP IF MUST USE PURE TABBLE
410 USEPUR: CAILE A,NUMPRI ; SKIP IF NOT PRIM
412 SKIPL APTYPE(A) ; SKIP IF APLLICABLE
420 SKIPN E.EXTR(TB) ; IF EXTRA ARG
421 SKIPGE E.ARG+1(TB) ; OR APPLY/STACKFORM, LOSE
423 MOVE A,E.FCN+1(TB) ; GET FCN
424 HRRZ C,@E.FRM+1(TB) ; GET ARG LIST
425 SUB TP,[MINTM,,MINTM] ; FLUSH UNWANTED TEMPS
427 PUSH TP,C ; ARG TO STACK
428 .MCALL 1,(A) ; AND CALL
434 PUSHJ P,PSH4ZR ; SET UP ZEROED SLOTS
436 AOS E.CNT(TB) ; INDICATES IF MUST EVAL ARGS
437 MOVSI A,400000 ; MAKE SURE OF GOOD INDIRECT
439 SKIPN A,E.EXTR(TB) ; FUNNY ARGS
441 MOVE B,E.EXTR+1(TB) ; YES , GET VAL
442 JRST APSUB2 ; AND FALL IN
444 APSUB1: PUSHJ P,@E.ARG+1(TB) ; EAT AN ARG
448 AOS E.CNT+1(TB) ; COUNT IT
451 APSUBD: MOVE A,E.CNT+1(TB) ; FINISHED, GET COUNT
452 MOVE B,E.FCN+1(TB) ; AND SUBR
456 PUSHJ P,BLTDN ; FLUSH CRUFT
460 BLTDN: MOVEI C,(TB) ; POINT TO DEST
461 HRLI C,E.TSUB(C) ; AND SOURCE
462 BLT C,-E.TSUB(TP) ;BL..............T
463 SUB TP,[E.TSUB,,E.TSUB]
466 APENDN: PUSHJ P,BLTDN
470 ; FLAGS FOR RSUBR HACKER
477 ; APPLY OBJECTS OF TYPE RSUBR
481 MOVE C,E.FCN+1(TB) ; GET THE RSUBR
482 CAML C,[-5,,] ; IS IT LONG ENOUGH FOR DECLS
483 JRST APSUBR ; NO TREAT AS A SUBR
484 GETYP 0,4(C) ; GET TYPE OF 3D ELEMENT
485 CAIE 0,TDECL ; DECLARATION?
486 JRST APSUBR ; NO, TREAT AS SUBR
487 PUSHJ P,PSH4ZR ; ALLOCATE SOME EXTRA ROOM
488 PUSH TP,$TDECL ; PUSH UP THE DECLS
490 PUSH TP,$TLOSE ; SAVE ROOM FOR VAL DECL
493 AOS E.CNT(TB) ; INDICATES IF MUST EVAL ARGS
494 MOVSI A,400000 ; MAKE SURE OF GOOD INDIRECT
497 SKIPN E.EXTR(TB) ; "EXTRA" ARG?
499 MOVE 0,[SETZ EXTRGT] ; CHANGE THE ACCESS FCN
501 HRRM 0,E.ARG(TB) ; REMEMBER IT
503 APRSU1: MOVEI 0,0 ; INIT FLAG REGISTER
506 APRSU2: HRRZ A,E.DECL+1(TB) ; GET DECL LIST
507 JUMPE A,APRSU3 ; DONE!
510 PUSHJ P,NXTDCL ; IS NEXT THING A STRING?
511 JRST APRSU4 ; NO, BETTER BE A TYPE
512 CAMN B,[ASCII /VALUE/]
513 JRST RSBVAL ; SAVE VAL DECL
514 TRON 0,F.NFST ; IF NOT FIRST, LOSE
515 CAME B,[ASCII /CALL/] ; CALL DECL
517 SKIPE E.CNT(TB) ; LEGAL?
520 MOVE D,E.FRM+1(TB) ; GET FORM
521 JRST APRS10 ; HACK IT
523 APRSU5: TROE 0,F.STR ; STRING STRING?
525 CAMN B,[<ASCII /OPT/>]
527 CAME B,[<ASCII /OPTIO/>+1] ; OPTIONA?
529 TROE 0,F.OPT ; CHECK AND SET
530 JRST MPD ; OPTINAL OPTIONAL LOSES
531 JRST APRSU2 ; TO MAIN LOOP
533 APRSU7: CAME B,[ASCII /QUOTE/]
536 TROE 0,F.QUO ; TURN ON AND CHECK QUOTE
537 JRST MPD ; QUOTE QUOTE LOSES
538 JRST APRSU2 ; GO TO END OF LOOP
541 APRSU8: CAME B,[ASCII /ARGS/]
543 SKIPE E.CNT(TB) ; SKIP IF LEGAL
545 HRRZ D,@E.FRM+1(TB) ; GET ARG LIST
548 APRS10: HRRZ A,(A) ; GET THE DECL
549 MOVEM A,E.DECL+1(TB) ; CLOBBER
550 HRRZ B,(A) ; CHECK FOR TOO MUCH
552 MOVE B,1(A) ; GET DECL
553 HLLZ A,(A) ; GOT THE DECL
554 MOVEM 0,(P) ; SAVE FLAGS
555 JSP E,CHKAB ; CHECK DEFER
560 AOS E.CNT+1(TB) ; COUNT ARG
561 JRST APRDON ; GO CALL RSUBR
563 RSBVAL: HRRZ A,E.DECL+1(TB) ; GET DECL
565 HRRZ B,(A) ; POINT TO DECL
566 MOVEM B,E.DECL+1(TB) ; SAVE NEW DECL POINTER
570 MOVEM A,E.VAL+1(TB) ; SAVE VAL DECL
572 MOVEM A,E.VAL(TB) ; SET ITS TYPE
576 APRSU9: CAME B,[ASCII /TUPLE/]
578 MOVEM 0,(P) ; SAVE FLAGS
579 HRRZ A,(A) ; CDR DECLS
583 PUSH P,[0] ; COUNT ELEMENTS IN TUPLE
585 APRTUP: PUSHJ P,@E.ARG+1(TB) ; GOBBLE ARGS
592 APRTPD: POP P,C ; GET COUNT
593 ADDM C,E.CNT+1(TB) ; UPDATE MAIN COUNT
595 HRLI C,TINFO ; BUILD FENCE POST
597 PUSHJ P,TBTOTP ; GEN REL OFFSET TO TOP
599 HRROI D,-1(TP) ; POINT TO TOP
602 MOVSI C,TARGS ; BUILD TYPE WORD
606 HLLZ A,(A) ; TYPE/VAL
608 PUSHJ P,TMATCH ; GOTO TYPE CHECKER
611 SUB TP,[2,,2] ; REMOVE FENCE POST
613 APRDON: SUB P,[1,,1] ; FLUSH CRUFT
614 MOVE A,E.CNT+1(TB) ; GET # OF ARGS
616 GETYP 0,E.FCN(TB) ; COULD BE ENTRY
617 MOVEI C,(TB) ; PREPARE TO BLT DOWN
620 SUB TP,[E.TSUB+2,,E.TSUB+2]
623 .ACALL A,(B) ; CALL THE RSUBR
632 APRSU4: MOVEM 0,(P) ; SAVE FLAGS
633 MOVE B,1(A) ; GET DECL
636 MOVE 0,(P) ; RESTORE FLAGS
639 SKIPE E.CNT(TB) ; ALREADY EVAL'D
642 JRST APREVA ; MUST EVAL ARG
644 HRRZ C,@E.FRM+1(TB) ; GET ARG?
645 TRNE 0,F.OPT ; OPTIONAL
647 JUMPE C,TFA ; NO, TOO FEW ARGS
651 JSP E,CHKAB ; CHECK THEM
653 APRTYC: MOVE C,A ; SET UP FOR TMATCH
656 EXCH A,-1(TP) ; SAVE STUFF
657 APRS11: PUSHJ P,TMATCH ; CHECK TYPE
660 MOVE 0,(P) ; RESTORE FLAGS
663 JRST APRSU2 ; AND GO ON
665 APREV0: TRNE 0,F.QUO ; ATTEMPT TO QUOTE ALREADY EVAL'D ARG ?
667 APREVA: PUSHJ P,@E.ARG+1(TB) ; EVAL ONE
668 TDZA C,C ; C=0 ==> NONE LEFT
671 JUMPN C,APRTYC ; GO CHECK TYPE
672 APRDN: SUB TP,[2,,2] ; FLUSH DECL
673 TRNE 0,F.OPT ; OPTIONAL?
674 JRST APRDON ; ALL DONE
677 APRSU3: TRNE 0,F.STR ; END IN STRING?
\b
679 PUSHJ P,@E.ARG+1(TB) ; SEE IF ANYMORE ARGS
684 ; STANDARD ARGUMENT GETTERS USED IN APPLYING THINGS
686 ARGCDR: HRRZ C,@E.FRM+1(TB) ; POINT TO ARGLIST (NOTE: POINTS 1 BEFORE WHERE ARG IS)
687 JUMPE C,CPOPJ ; LEAVE IF DONE
689 GETYP 0,(C) ; GET TYPE OF ARG
691 JRST ARGCD1 ; SEG MENT HACK
695 ARGCD1: PUSH TP,$TFORM ; PRETEND WE ARE A FORM
700 PUSHJ P,TYPSEG ; GET SEG TYPE CODE
701 HRRM C,E.ARG(TB) ; SAVE IT IN OBSCCURE PLACE
702 MOVE C,DSTORE ; FIX FOR TEMPLATE
705 MOVEM C,E.ARG+1(TB) ; SET NEW ARG GETTER
710 HRRZ C,E.ARG(TB) ; SEG CODE TO C
714 PUSHJ P,NXTLM ; GET NEXT ELEMENT
717 MOVE D,DSTORE ; KEEP TYPE WINNING
724 HRRM C,E.ARG+1(TB) ; RESET ARG GETTER
727 ; ARGUMENT GETTER FOR APPLY
730 SKIPL A,E.FRM+1(TB) ; ANY ARGS LEFT
731 POPJ P, ; NO, EXIT IMMEDIATELY
734 MOVE B,-1(A) ; RET NEXT ARG
738 ; STACKFORM ARG GETTER
740 EVALRG: SKIPN C,@E.FRM+1(TB) ; ANY FORM?
743 GETYP A,A ; CHECK FOR FALSE
746 MOVE C,E.FRM+1(TB) ; GET OTHER FORM
751 ; HERE TO APPLY NUMBERS
753 APNUM: PUSHJ P,PSH4ZR ; TP SLOTS
754 SKIPN A,E.EXTR(TB) ; FUNNY ARG?
756 MOVE B,E.EXTR+1(TB) ; GET ARG
759 APNUM1: PUSHJ P,@E.ARG+1(TB) ; GET ARG
768 PUSHJ P,BLTDN ; FLUSH JUNK
771 ; HACK FOR TURNING <3 .FOO .BAR> INTO <PUT .FOO 3 .BAR>
779 PUSHJ P,ISTRUC ; STRUCTURED FIRST ARG?
784 ; HERE TO APPLY SUSSMAN FUNARGS
790 HRRZ D,(C) ; MUST BE AT LEAST 2 LONG
792 GETYP 0,(D) ; CHECK FOR LIST
795 HRRZ 0,(D) ; SHOULD BE END
797 GETYP 0,(C) ; 1ST MUST BE FCN
802 PUSHJ P,APEXPF ; BIND THE ARGS AND AUX'S
803 HRRZ C,RE.FCN+1(TB) ; GET BODY OF FUNARG
804 MOVE B,1(C) ; GET FCN
805 MOVEM B,RE.FCN+1(TB) ; AND SAVE
806 HRRZ C,(C) ; CDR FUNARG BODY
808 MOVSI 0,TLIST ; SET UP TYPE
810 MOVEM 0,CSTO(PVP) ; FOR INTS TO WIN
815 CAIE 0,TLIST ; BETTER BE LIST
819 PUSHJ P,NEXTDC ; GET POSSIBILITY
823 HRRZ B,(B) ; GET TO VALUE
830 JSP E,CHKAB ; HACK DEFER
831 PUSHJ P,PSHAB4 ; PUT VAL IN
837 DOF: MOVE PVP,PVSTOR+1
838 SETZM CSTO(PVP) ; DONT CONFUSE GC
839 PUSHJ P,SPECBIND ; BIND 'EM UP
846 APMACR: HRRZ E,OTBSAV(TB)
847 HRRZ D,PCSAV(E) ; SEE WHERE FROM
848 CAIE D,EFCALL+1 ; 1STEP
852 CAIN D,AEVAL3 ; SKIP IF NOT RIGHT
854 SKIPG E.ARG+1(TB) ; SKIP IF REAL FORM EXISTS
858 SUB TP,[E.EXTR+2,,E.EXTR+2] ; FLUSH JUNK
861 MCALL 1,EXPAND ; EXPAND THE MACRO
864 MCALL 1,EVAL ; EVAL THE RESULT
867 APMAC1: MOVE C,E.FCN+1(TB) ; GET MACRO BODY
871 JSP E,CHKAB ; FIX DEFERS
876 ; HERE TO APPLY EXPRS (FUNCTIONS)
878 APEXPR: PUSHJ P,APEXP ; BIND ARGS AND AUX'S
879 RUNFUN: HRRZ A,RE.FCN(TB) ; AMOUNT OF FCN TO SKIP
880 MOVEI C,RE.FCN+1(TB) ; POINT TO FCN
881 HRRZ C,(C) ; SKIP SOMETHING
882 SOJGE A,.-1 ; UNTIL 1ST FORM
883 MOVEM C,RE.FCN+1(TB) ; AND STORE
884 JRST DOPROG ; GO RUN PROGRAM
886 APEXP: SKIPN C,E.FCN+1(TB) ; CHECK FRO BODY
888 APEXPF: PUSH P,[0] ; COUNT INIT CRAP
889 ADD TP,[XP.TMP,,XP.TMP] ; SLOTS FOR HACKING
892 SETZM 1-XP.TMP(TP) ; ZERO OUT
893 MOVEI A,-XP.TMP+2(TP)
895 BLT A,(TP) ; ZERO SLOTS
897 AOS E.CNT(TB) ; INDICATES IF MUST EVAL ARGS
898 MOVSI A,400000 ; MAKE E.ARG BE NEG FOR SAFE @ING
900 PUSHJ P,CARATC ; SEE IF HEWITT ATOM EXISTS
901 JRST APEXP1 ; NO, GO LOOK FOR ARGLIST
902 MOVEM E,E.HEW+1(TB) ; SAVE ATOM
903 MOVSM 0,E.HEW(TB) ; AND TYPE
904 AOS (P) ; COUNT HEWITT ATOM
905 APEXP1: GETYP 0,(C) ; LOOK AT NEXT THING
906 CAIE 0,TLIST ; BETTER BE LIST!!!
908 MOVE B,1(C) ; GET LIST
909 MOVEM B,E.ARGL+1(TB) ; SAVE
910 MOVSM 0,E.ARGL(TB) ; WITH TYPE
911 HRRZ C,(C) ; CDR THE FCN
912 JUMPE C,NOBODY ; BODYLESS FCN
913 GETYP 0,(C) ; SEE IF DCL LIST SUPPLIED
915 JRST APEXP2 ; NO, START PROCESSING ARGS
923 ; CHECK FOR EXISTANCE OF EXTRA ARG
925 APEXP2: POP P,A ; GET COUNT
926 HRRM A,E.FCN(TB) ; AND SAVE
927 SKIPN E.EXTR(TB) ; SKIP IF FUNNY EXTRA ARG EXISTS
931 HRRM 0,E.ARG(TB) ; SAVE OLD GETTER AROUND
936 ; LOOK FOR "BIND" DECLARATION
938 APEXP3: PUSHJ P,UNPROG ; UNASSIGN LPROG IF NEC
939 APXP3A: SKIPN A,E.ARGL+1(TB) ; GET ARGLIST
940 JRST APEXP4 ; NONE, VERIFY NONE WERE GIVEN
941 PUSHJ P,NXTDCL ; SEE IF A DECL IS THERE
942 JRST BNDRG ; NO, GO BIND NORMAL ARGS
943 HRRZ C,(A) ; CDR THE DCLS
944 CAME B,[ASCII /BIND/]
945 JRST CH.CAL ; GO LOOK FOR "CALL"
946 PUSHJ P,CARTMC ; MUST BE AN ATOM
947 MOVEM C,E.ARGL+1(TB) ; AND SAVE CDR'D ARGS
948 PUSHJ P,MAKENV ; GENERATE AN ENVIRONMENT
949 PUSHJ P,PSBND1 ; PUSH THE BINDING AND CHECK THE DCL
950 JRST APXP3A ; IN CASE <"BIND" B "BIND" C......
953 ; LOOK FOR "CALL" DCL
955 CH.CAL: CAME B,[ASCII /CALL/]
956 JRST CHOPT ; TRY SOMETHING ELSE
957 ; SKIPG E.ARG+1(TB) ; DONT SKIP IF CANT WIN
960 PUSHJ P,CARTMC ; BETTER BE AN ATOM
962 MOVE A,E.FRM(TB) ; RETURN FORM
964 PUSHJ P,PSBND1 ; BIND AND CHECK
967 ; BIND NORMAL ARGS BY CALLING BNDEM1, RETURNS WHEN ALL DONE
969 BNDRG: PUSHJ P,BNDEM1 ; GO BIND THEM UP
970 TRNN A,4 ; SKIP IF HIT A DCL
971 JRST APEXP4 ; NOT A DCL, MUST BE DONE
973 ; LOOK FOR "OPTIONAL" DECLARATION
975 CHOPT: CAMN B,[<ASCII /OPT/>]
977 CAME B,[<ASCII /OPTIO/>+1]
978 JRST CHREST ; TRY TUPLE/ARGS
979 MOVEM C,E.ARGL+1(TB) ; SAVE RESTED ARGLIST
980 PUSHJ P,BNDEM2 ; DO ALL SUPPLIED OPTIONALS
981 TRNN A,4 ; SKIP IF NEW DCL READ
984 ; CHECK FOR "ARGS" DCL
986 CHREST: CAME B,[ASCII /ARGS/]
987 JRST CHRST1 ; GO LOOK FOR "TUPLE"
988 ; SKIPGE E.ARG+1(TB) ; SKIP IF LEGAL
991 PUSHJ P,CARTMC ; GOBBLE ATOM
992 MOVEM C,E.ARGL+1(TB) ; SAVE CDR'D ARG
993 HRRZ B,@E.FRM+1(TB) ; GET ARG LIST
994 MOVSI A,TLIST ; GET TYPE
998 ; HERE TO CHECK FOR "TUPLE"
1000 CHRST1: CAME B,[ASCII /TUPLE/]
1002 PUSHJ P,CARTMC ; GOBBLE ATOM
1003 MOVEM C,E.ARGL+1(TB)
1005 PUSHJ P,PSHBND ; SET UP BINDING
1006 SETZM E.CNT+1(TB) ; ZERO ARG COUNTER
1008 TUPLP: PUSHJ P,@E.ARG+1(TB) ; GET AN ARG
1015 TUPDON: PUSHJ P,MAKINF ; MAKE INFO CELL
1016 PUSH TP,$TINFO ; FENCE POST TUPLE
1018 ADDI D,TM.OFF ; COMPENSATE FOR MOVEMENT
1020 MOVE C,E.CNT+1(TB) ; GET COUNT
1022 HRRM C,-1(TP) ; INTO FENCE POST
1023 MOVEI B,-TM.OFF-1(TP) ; SETUP ARG POINTER
1024 SUBI B,(C) ; POINT TO BASE OF TUPLE
1025 MOVNS C ; FOR AOBJN POINTER
1026 HRLI B,(C) ; GOOD ARGS POINTER
1027 MOVEM A,TM.OFF-4(B) ; STORE
1031 ; CHECK FOR VALID ENDING TO ARGS
1033 APEXP5: PUSHJ P,NEXTD ; READ NEXT THING IN ARGLIST
1035 TRNN A,4 ; SKIP IF DCL
1037 APEXP7: MOVSI A,-NWINS ; CHECK FOR A WINNER
1040 JUMPGE A,MPD.6 ; NOT A WINNER
1042 ; HERE TO BLT THE WORLD DOWN ON TOP OF ALL THE USELESS TEMPS
1044 APEXP8: MOVE 0,E.HEW+1(TB) ; GET HEWITT ATOM
1045 MOVE E,E.FCN(TB) ; SAVE COUNTER
1046 MOVE C,E.FCN+1(TB) ; FCN
1047 MOVE B,E.ARGL+1(TB) ; ARG LIST
1048 MOVE D,E.DECL+1(TB) ; AND DCLS
1049 MOVEI A,R.TMP(TB) ; SET UP BLT
1051 BLT A,-TM.OFF(TP) ; BLLLLLLLLLLLLLT
1052 SUB TP,[TM.OFF,,TM.OFF] ; FLUSH CRUFT
1054 MOVEM C,RE.FCN+1(TB)
1055 MOVEM B,RE.ARGL+1(TB)
1061 GETYP A,-5(TP) ; TUPLE ON TOP?
1062 CAIE A,TINFO ; SKIP IF YES
1064 HRRZ A,-5(TP) ; GET SIZE
1067 SUB E,A ; POINT TO BINDINGS
1068 SKIPE C,(TP) ; IF DCL
1069 PUSHJ P,CHKDCL ; CHECK TYPE SPEC ON TUPLE
1070 APEXP9: PUSHJ P,USPCBE ; DO ACTUAL BINDING
1072 MOVE E,-2(TP) ; RESTORE HEWITT ATOM
1073 MOVE D,(TP) ; AND DCLS
1076 JRST AUXBND ; GO BIND AUX'S
1078 ; HERE TO VERIFY CHECK IF ANY ARGS LEFT
1080 APEXP4: PUSHJ P,@E.ARG+1(TB)
1082 JRST TMA ; TOO MANY ARGS
1085 PUSHJ P,@E.ARG+1(TB)
1091 ; LIST OF POSSIBLE TERMINATING NAMES
1095 AS.NAM: ASCII /NAME/
1097 AS.EXT: ASCII /EXTRA/
1101 ; HERE TO BIND AUX VARIABLES FOR PROGS AND FCNS
1103 AUXBND: PUSH P,E ; SAVE HEWITT ATOM ( WILL PUT ON MARKED STACK
1105 PUSH P,D ; SAME WITH DCL LIST
1106 PUSH P,[-1] ; FLAG SAYING WE ARE FCN
1107 SKIPN C,RE.ARG+1(TB) ; GET ARG LIST
1109 GETYP 0,(C) ; GET TYPE
1110 CAIE 0,TDEFER ; SKIP IF CHSTR
1111 MOVMS (P) ; SAY WE ARE IN OPTIONALS
1116 PUSH P,[0] ; WE ARE IN AUXS
1118 AUXB1: HRRZ C,RE.ARG+1(TB) ; POINT TO ARGLIST
1119 PUSHJ P,NEXTDC ; GET NEXT THING OFF OF ARG LIST
1121 TRNE A,4 ; SKIP IF SOME KIND OF ATOM
1122 JRST TRYDCL ; COUDL BE DCL
1123 TRNN A,1 ; SKIP IF QUOTED
1125 SKIPN (P) ; SKIP IF QUOTED OK
1127 AUXB2: PUSHJ P,PSHBND ; SET UP BINDING
1128 PUSH TP,$TATOM ; SAVE HEWITT ATOM
1130 PUSH TP,$TDECL ; AND DECLS
1132 TRNN A,2 ; SKIP IF INIT VAL EXISTS
1133 JRST AUXB3 ; NO, USE UNBOUND
1135 ; EVALUATE EXPRESSION
1137 HRRZ C,(B) ; CDR ATOM OFF
1139 ; CHECK FOR SPECIAL FORMS <TUPLE ...> <ITUPLE ...>
1141 GETYP 0,(C) ; GET TYPE OF GOODIE
1142 CAIE 0,TFORM ; SMELLS LIKE A FORM
1144 HRRZ D,1(C) ; GET 1ST ELEMENT
1145 GETYP 0,(D) ; AND ITS VAL
1146 CAIE 0,TATOM ; FEELS LIKE THE RIGHT FORM
1149 MOVE 0,1(D) ; GET THE ATOM
1150 CAME 0,IMQUOTE TUPLE
1151 CAMN 0,MQUOTE ITUPLE
1152 JRST DOTUPL ; SURE GLAD I DIDN'T STEP IN THAT FORM
1155 AUXB13: PUSHJ P,FASTEV
1157 AUXB4: MOVEM A,-7(E) ; STORE VAL IN BINDING
1160 ; HERE TO CHECK AGAINST DECLARATIONS AND COMPLETE THE BINDING
1162 AUXB5: SUB E,[4,,4] ; POINT TO BINDING TOP
1163 SKIPE C,-2(TP) ; POINT TO DECLARATINS
1164 PUSHJ P,CHKDCL ; CHECK IT
1165 PUSHJ P,USPCBE ; AND BIND UP
1166 SKIPE C,RE.ARG+1(TB) ; CDR DCLS
1167 HRRZ C,(C) ; IF ANY TO CDR
1168 MOVEM C,RE.ARG+1(TB)
1169 MOVE A,(TP) ; NOW PUT HEWITT ATOM AND DCL AWAY
1173 SUB TP,[4,,4] ; FLUSH SLOTS
1183 ; HERE TO HANDLE "CALLS" TO TUPLE AND ITUPLE
1185 DOTUPL: SKIPE E,(P) ; SKIP IF IN AUX LIST
1187 PUSH TP,$TLIST ; SAVE THE MAGIC FORM
1189 CAME 0,IMQUOTE TUPLE
1190 JRST DOITUP ; DO AN ITUPLE
1192 ; FALL INTO A TUPLE PUSHING LOOP
1194 DOTUP1: HRRZ C,@(TP) ; CDR THE FORM
1195 JUMPE C,ATUPDN ; FINISHED
1196 MOVEM C,(TP) ; SAVE CDR'D RESULT
1197 GETYP 0,(C) ; CHECK FOR SEGMENT
1199 JRST DTPSEG ; GO PULL IT APART
1200 PUSHJ P,FASTEV ; EVAL IT
1201 PUSHJ P,CNTARG ; PUSH IT UP AND COUNT THEM
1204 ; HERE WHEN WE FINISH
1206 ATUPDN: SUB TP,[2,,2] ; FLUSH THE LIST
1207 ASH E,1 ; E HAS # OF ARGS DOUBLE IT
1208 MOVEI D,(TP) ; FIND BASE OF STACK AREA
1210 MOVSI C,-3(D) ; PREPARE BLT POINTER
1211 BLT C,C ; HEWITT ATOM AND DECL TO 0,A,B,C
1213 ; NOW PREPEARE TO BLT TUPLE DOWN
1215 MOVEI D,-3(D) ; NEW DEST
1216 HRLI D,4(D) ; SOURCE
1217 BLT D,-4(TP) ; SLURP THEM DOWN
1219 HRLI E,TINFO ; SET UP FENCE POST
1220 MOVEM E,-3(TP) ; AND STORE
1221 PUSHJ P,TBTOTP ; GET OFFSET
1222 ADDI D,3 ; FUDGE FOR NOT AT TOP OF STACK
1224 MOVEM 0,-1(TP) ; RESTORE HEW ATOM AND DECLS
1229 PUSHJ P,MAKINF ; MAKE 1ST WORD OF FUNNYS
1231 HRRZ E,-5(TP) ; RESTORE WORDS OF TUPLE
1232 HRROI B,-5(TP) ; POINT TO TOP OF TUPLE
1233 SUBI B,(E) ; NOW BASE
1234 TLC B,-1(E) ; FIX UP AOBJN PNTR
1235 ADDI E,2 ; COPNESATE FOR FENCE PST
1237 SUBM TP,E ; E POINT TO BINDING
1238 JRST AUXB4 ; GO CLOBBER IT IN
1241 ; HERE TO HANDLE SEGMENTS IN THESE FUNNY FORMS
1243 DTPSEG: PUSH TP,$TFORM ; SAVE THE HACKER
1245 MCALL 1,EVAL ; AND EVALUATE IT
1246 MOVE D,B ; GET READY FOR A SEG LOOP
1248 PUSHJ P,TYPSEG ; TYPE AND CHECK IT
1250 DTPSG1: INTGO ; DONT BLOW YOUR STACK
1251 PUSHJ P,NXTLM ; ELEMENT TO A AND B
1253 PUSHJ P,CNTARG ; PUSH AND COUNT
1256 DTPSG2: SETZM DSTORE
1257 HRRZ E,-1(TP) ; GET COUNT IN CASE END
1258 JRST DOTUP1 ; REST OF ARGS STILL TO DO
1260 ; HERE TO HACK <ITUPLE .....>
1262 DOITUP: HRRZ C,@(TP) ; GET COUNT FILED
1265 PUSHJ P,FASTEV ; EVAL IT
1272 HRRZ C,@(TP) ; GET EXP TO EVAL
1273 MOVEI 0,0 ; DONT LOSE IN 1 ARG CASE
1274 HRRZ 0,(C) ; VERIFY WINNAGE
1275 JUMPN 0,TMA ; TOO MANY
1278 PUSH P,B ; SAVE COUNT
1281 PUSHJ P,FASTEV ; EVAL IT ONCE
1293 DOIDO1: MOVE B,-1(P) ; RESTORE COUNT
1299 ; FOR CASE OF NO EVALE
1301 DOILOS: SUB TP,[2,,2]
1309 ; ROUTINE TO PUSH NEXT TUPLE ELEMENT
1311 CNTARG: AOS E,-1(TP) ; KEEP ARG COUNT UP TO DATE IN E
1312 CNTRG: EXCH A,-1(TP) ; STORE ELEM AND GET SAVED
1319 ; DUMMY TUPLE AND ITUPLE
1321 IMFUNCTION TUPLE,SUBR
1324 ERRUUO EQUOTE NOT-IN-AUX-LIST
1326 MFUNCTIO ITUPLE,SUBR
1330 ; PROCESS A DCL IN THE AUX VAR LISTS
1332 TRYDCL: SKIPN (P) ; SKIP IF NOT IN AUX'S
1334 CAME B,AS.AUX ; "AUX" ?
1335 CAMN B,AS.EXT ; OR "EXTRA"
1337 CAME B,[ASCII /TUPLE/]
1339 PUSHJ P,MAKINF ; BUILD EMPTY TUPLE
1341 PUSH TP,$TINFO ; FENCE POST
1344 AUXB6: HRRZ C,(C) ; CDR PAST DCL
1345 MOVEM C,RE.ARG+1(TB)
1346 AUXB8: PUSHJ P,CARTMC ; GET ATOM
1347 AUXB12: PUSHJ P,PSHBND ; UP GOES THE BINDING
1348 PUSH TP,$TATOM ; HIDE HEWITT ATOM AND DCL
1357 AUXB10: CAME B,[ASCII /ARGS/]
1359 MOVEI B,0 ; NULL ARG LIST
1361 JRST AUXB6 ; GO BIND
1363 AUXB9: SETZM (P) ; NOW READING AUX
1365 MOVEM C,RE.ARG+1(TB)
1368 ; CHECK FOR NAME/ACT
1370 AUXB7: CAME B,AS.NAM
1375 HRRZ 0,(C) ; BETTER BE END
1377 PUSHJ P,CARTMC ; FORCE ATOM READ
1379 AUXB11: PUSHJ P,MAKACT ; MAKE ACTIVATION
1380 JRST AUXB12 ; AND BIND IT
1383 ; DONE BIND HEWITT ATOM IF NECESARY
1385 AUXDON: SKIPN E,-2(P)
1396 ; MAKE AN ACTIVATION OR ENVIRONMNENT
1398 MAKACT: MOVEI B,(TB)
1400 MAKAC1: MOVE PVP,PVSTOR+1
1401 HRRI A,PVLNT*2+1(PVP) ; POINT TO PROCESS
1402 HLL B,OTBSAV(B) ; GET TIME
1405 MAKENV: MOVSI A,TENV
1409 ; SEVERAL USEFUL LITTLE ROUTINES FOR HACKING THIS STUFF
1411 ; CARAT/CARATC/CARATM/CARTMC ALL LOOK FOR THE NEXT ATOM
1413 CARAT: HRRZ C,E.ARGL+1(TB) ; PICK UP ARGLIST
1414 CARATC: JUMPE C,CPOPJ ; FOUND
1415 GETYP 0,(C) ; GET ITS TYPE
1417 CPOPJ: POPJ P, ; RETURN, NOT ATOM
1418 MOVE E,1(C) ; GET ATOM
1419 HRRZ C,(C) ; CDR DCLS
1422 CARATM: HRRZ C,E.ARGL+1(TB)
1423 CARTMC: PUSHJ P,CARATC
1424 JRST MPD.7 ; REALLY LOSE
1428 ; SUBROUTINES TO PUSH BINDINGS ETC. UP ON THE STACK
1430 PSBND1: PUSHJ P,PSHBND ; PUSH THEBINDING
1431 JRST CHDCL ; NOW CHECK IT AGAINST DECLARATION
1433 PSHBND: SKIPGE SPCCHK ; SKIP IF NORMAL SPECIAL
1434 PUSH TP,BNDA1 ; ATOM IN E
1435 SKIPL SPCCHK ; SKIP IF NORMAL UNSPEC OR NO CHECK
1444 ; ROUTINE TO PUSH 4 0'S
1450 ; EXTRRA ARG GOBBLER
1452 EXTRGT: HRRZ A,E.ARG(TB) ; RESET SLOT
1454 CAIE A,ARGCDR ; IF NOT ARGCDR
1456 TLO A,400000 ; SET FLAG
1458 MOVE A,E.EXTR(TB) ; RET ARG
1462 ; CHECK A/B FOR DEFER
1465 CAIE 0,TDEFER ; SKIP IF DEFER
1468 MOVE B,1(B) ; GET REAL THING
1470 ; IF DECLARATIONS EXIST, DO THEM
1473 CHDCLE: SKIPN C,E.DECL+1(TB)
1477 ; ROUTINE TO READ NEXT THING FROM ARGLIST
1479 NEXTD: HRRZ C,E.ARGL+1(TB) ; GET ARG LIST
1482 PUSHJ P,CARATC ; TRY FOR AN ATOM
1486 NEXTD1: CAIE 0,TFORM ; FORM?
1487 JRST NXT.L ; COULD BE LIST
1488 PUSHJ P,CHQT ; VERIFY 'ATOM
1492 NXT.L: CAIE 0,TLIST ; COULD BE (A <EXPRESS>) OR ('A <EXPRESS>)
1493 JRST NXT.S ; BETTER BE A DCL
1494 PUSHJ P,LNT.2 ; VERIFY LENGTH IS 2
1496 CAIE 0,TATOM ; TYPE OF 1ST RET IN 0
1497 JRST LST.QT ; MAY BE 'ATOM
1498 MOVE E,1(B) ; GET ATOM
1501 LST.QT: CAIE 0,TFORM ; FORM?
1504 MOVEI C,(B) ; VERIFY 'ATOM
1506 MOVEI B,(C) ; POINT BACK TO LIST
1511 NXT.S: MOVEI A,(C) ; LET NXTDCL FIND OUT
1514 MOVEI A,4 ; SET DCL READ FLAG
1517 ; ROUTINE TO CHECK LENGTH OF LIST/FORM FOR BEING 2
1519 LNT.2: HRRZ B,1(C) ; GET LIST/FORM
1523 HRRZ B,(B) ; BETTER END HERE
1525 HRRZ B,1(C) ; LIST BACK
1526 GETYP 0,(B) ; TYPE OF 1ST ELEMENT
1529 ; ROUTINE TO VERIFY FORM IS 'ATOM AND RET ATOM
1531 CHQT: PUSHJ P,LNT.2 ; 1ST LENGTH CHECK
1536 CAME 0,IMQUOTE QUOTE
1537 JRST MPD.5 ; BETTER BE QUOTE
1542 MOVE E,1(E) ; GET QUOTED ATOM
1545 ; ARG BINDER FOR REGULAR ARGS AND OPTIONALS
1547 BNDEM1: PUSH P,[0] ; REGULAR FLAG
1550 BNDEM: PUSHJ P,NEXTD ; GET NEXT THING
1551 JRST CCPOPJ ; END OF THINGS
1552 TRNE A,4 ; CHECK FOR DCL
1554 TRNE A,2 ; SKIP IF NOT (ATM ..) OR ('ATM ...)
1555 SKIPE (P) ; SKIP IF REG ARGS
1556 JRST .+2 ; WINNER, GO ON
1559 PUSH TP,BNDA1 ; SAVE ATOM
1563 ; SKIPGE E.ARG+1(TB) ; ALREADY EVAL'D ARG?
1566 TRNN A,1 ; SKIP IF ARG QUOTED
1568 HRRZ D,@E.FRM+1(TB) ; GET AND CDR ARG
1569 JUMPE D,TFACHK ; OH OH MAYBE TOO FEW ARGS
1570 MOVEM D,E.FRM+1(TB) ; STORE WINNER
1571 HLLZ A,(D) ; GET ARG
1573 JSP E,CHKAB ; HACK DEFER
1574 JRST BNDEM3 ; AND GO ON
1576 RGLAR0: TRNE A,1 ; ATTEMPT TO QUOTE ALREADY EVAL'D ARG ?
1577 JRST MPD ; YES, LOSE
1578 RGLARG: PUSH P,A ; SAVE FLAGS
1579 PUSHJ P,@E.ARG+1(TB)
1580 JRST TFACH1 ; MAY GE TOO FEW
1582 BNDEM3: HRRZ C,@E.ARGL+1(TB) ; CDR THHE ARGS
1583 MOVEM C,E.ARGL+1(TB)
1584 PUSHJ P,PSHAB4 ; PUSH VALUE AND SLOTS
1585 PUSHJ P,CHDCL ; CHECK DCLS
1586 JRST BNDEM ; AND BIND ON!
1588 ; HERE WHEN ARGS RUN OUT, IF NOT OPTIONAL, GIVE TFA
1591 TFACHK: SUB TP,[2,,2] ; FLUSH ATOM
1592 SKIPN (P) ; SKIP IF OPTIONALS
1594 CCPOPJ: SUB P,[1,,1]
1597 BNDEM4: HRRZ C,@E.ARGL+1(TB) ; POINT TO REST OF ARGL
1601 ; EVALUATE LISTS, VECTORS, UNIFROM VECTORS
1603 EVLIST: PUSH P,[-1] ;-1 -- THIS IS A LIST
1604 JRST EVL1 ;GO TO HACKER
1606 EVECT: PUSH P,[0] ;0 -- THIS IS A GENERAL VECTOR
1609 EUVEC: PUSH P,[1] ;1 -- THIS IS A UNIFORM VECTOR
1611 EVL1: PUSH P,[0] ;PUSH A COUNTER
1612 GETYPF A,(AB) ;GET FULL TYPE
1614 PUSH TP,1(AB) ;AND VALUE
1616 EVL2: INTGO ;CHECK INTERRUPTS
1617 SKIPN A,1(TB) ;ANYMORE
1619 SKIPL -1(P) ;SKIP IF LIST
1620 JUMPG A,EVL3 ;JUMP IF VECTOR EMPTY
1621 GETYPF B,(A) ;GET FULL TYPE
1622 SKIPGE C,-1(P) ;SKIP IF NOT LIST
1623 HLLZS B ;CLOBBER CDR FIELD
1624 JUMPG C,EVL7 ;HACK UNIFORM VECS
1625 EVL8: PUSH P,B ;SAVE TYPE WORD ON P
1626 CAMN B,$TSEG ;SEGMENT?
1627 MOVSI B,TFORM ;FAKE OUT EVAL
1628 PUSH TP,B ;PUSH TYPE
1629 PUSH TP,1(A) ;AND VALUE
1630 JSP E,CHKARG ; CHECK DEFER
1631 MCALL 1,EVAL ;AND EVAL IT
1632 POP P,C ;AND RESTORE REAL TYPE
1633 CAMN C,$TSEG ;SEGMENT?
1634 JRST DOSEG ;YES, HACK IT
1635 AOS (P) ;COUNT ELEMENT
1636 PUSH TP,A ;AND PUSH IT
1638 EVL6: SKIPGE A,-1(P) ;DONT SKIP IF LIST
1639 HRRZ B,@1(TB) ;CDR IT
1640 JUMPL A,ASTOTB ;AND STORE IT
1641 MOVE B,1(TB) ;GET VECTOR POINTER
1642 ADD B,AMNT(A) ;INCR BY APPROPRIATE AMOUNT
1643 ASTOTB: MOVEM B,1(TB) ;AND STORE BACK
1644 JRST EVL2 ;AND LOOP BACK
1646 AMNT: 2,,2 ;INCR FOR GENERAL VECTOR
1647 1,,1 ;SAME FOR UNIFORM VECTOR
1649 CHKARG: GETYP A,-1(TP)
1652 HRRZS (TP) ;MAKE SURE INDIRECT WINS
1654 MOVEM A,-1(TP) ;CLOBBER IN TYPE SLOT
1655 MOVE A,(TP) ;NOW GET POINTER
1656 MOVE A,1(A) ;GET VALUE
1657 MOVEM A,(TP) ;CLOBBER IN
1662 EVL7: HLRE C,A ; FIND TYPE OF UVECTOR
1663 SUBM A,C ;C POINTS TO DOPE WORD
1664 GETYP B,(C) ;GET TYPE
1665 MOVSI B,(B) ;TO LH NOW
1666 SOJA A,EVL8 ;AND RETURN TO DO EVAL
1668 EVL3: SKIPL -1(P) ;SKIP IF LIST
1669 JRST EVL4 ;EITHER VECTOR OR UVECTOR
1671 MOVEI B,0 ;GET A NIL
1672 EVL9: MOVSI A,TLIST ;MAKE TYPE WIN
1673 EVL5: SOSGE (P) ;COUNT DOWN
1674 JRST EVL10 ;DONE, RETURN
1675 PUSH TP,$TLIST ;SET TO CALL CONS
1678 JRST EVL5 ;LOOP TIL DONE
1681 EVL4: MOVEI B,EUVECT ;UNIFORM CASE
1682 SKIPG -1(P) ;SKIP IF UNIFORM CASE
1683 MOVEI B,EVECTO ;NO, GENERAL CASE
1685 .ACALL A,(B) ;CALL CREATOR
1686 EVL10: GETYPF A,(AB) ; USE SENT TYPE
1690 ; PROCESS SEGMENTS FOR THESE HACKS
1692 DOSEG: PUSHJ P,TYPSEG ; FIND WHAT IS BEING SEGMENTED
1693 JUMPE C,LSTSEG ; CHECK END SPLICE IF LIST
1695 SEG3: PUSHJ P,NXTELM ; GET THE NEXTE ELEMT
1696 JRST SEG4 ; RETURN TO CALLER
1698 JRST SEG3 ; TRY AGAIN
1702 TYPSEG: PUSHJ P,TYPSGR
1706 TYPSGR: MOVE E,A ; SAVE TYPE
1707 GETYP A,A ; TYPE TO RH
1708 PUSHJ P,SAT ;GET STORAGE TYPE
1709 MOVE D,B ; GOODIE TO D
1711 MOVNI C,1 ; C <0 IF ILLEGAL
1712 CAIN A,S2WORD ;LIST?
1714 CAIN A,S2NWORD ;GENERAL VECTOR?
1716 CAIN A,SNWORD ;UNIFORM VECTOR?
1722 CAIN A,SSTORE ;SPECIAL AFREE STORAGE ?
1723 MOVEI C,4 ;TREAT LIKE A UVECTOR
1724 CAIN A,SARGS ;ARGS TUPLE?
1725 JRST SEGARG ;NO, ERROR
1726 CAILE A,NUMSAT ; SKIP IF NOT TEMPLATE
1730 MOVEI A,2 ; NOW TREAT LIKE A UVECTOR
1732 MSTOR1: JUMPL C,CPOPJ
1734 MDSTOR: MOVEM E,DSTORE
1741 SEGARG: MOVSI A,TARGS
1743 PUSH TP,A ;PREPARE TO CHECK ARGS
1745 MOVEI B,-1(TP) ;POINT TO SAVED COPY
1746 PUSHJ P,CHARGS ;CHECK ARG POINTER
1747 POP TP,D ;AND RESTORE WINNER
1748 POP TP,E ;AND TYPE AND FALL INTO VECTOR CODE
1752 LSTSEG: SKIPL -1(P) ;SKIP IF IN A LIST
1753 JRST SEG3 ;ELSE JOIN COMMON CODE
1754 HRRZ A,@1(TB) ;CHECK FOR END OF LIST
1755 JUMPN A,SEG3 ;NO, JOIN COMMON CODE
1756 SETZM DSTORE ;CLOBBER SAVED GOODIES
1757 JRST EVL9 ;AND FINISH UP
1760 PUSHJ P,NXTLM ; GOODIE TO A AND B
1765 NXTLM: XCT TESTR(C) ; SKIP IF MORE IN SEGEMNT
1767 XCT TYPG(C) ; GET THE TYPE
1768 XCT VALG(C) ; AND VALUE
1769 JSP E,CHKAB ; CHECK DEFERRED
1770 XCT INCR1(C) ; AND INCREMENT TO NEXT
1771 CPOPJ1: AOS (P) ; SKIP RETURN
1774 ; TABLES FOR SEGMENT OPERATIONS (0->LIST, 1->VECTOR/ARGS, 2->UVEC, 3->STRING)
1790 TYPG: PUSHJ P,LISTYP
1813 HRRZ A,DSTORE ; GET SAT
1818 HLRZ 0,C ; GET AMNT RESTED
1833 MOVEI C,0 ; GET "1ST ELEMENT"
1834 PUSHJ P,TMPLNT ; GET NTH IN A AND B
1840 CHRDON: HRRZ B,DSTORE
1842 HRRZ B,DSTORE ; POIT TO DOPE WORD
1870 ;COMPILER's CALL TO DOSEG
1871 SEGMNT: PUSHJ P,TYPSEG
1873 SEGLOP: PUSHJ P,NXTELM
1875 AOS (P)-2 ; INCREMENT COMPILER'S COUNT
1878 SEGRET: SETZM DSTORE
1881 SEGLST: PUSHJ P,TYPSEG
1883 SEGLS3: SETZM DSTORE
1885 SEGLS1: SOSGE -2(P) ; START COUNT DOWN
1893 SEGLS2: PUSHJ P,NXTELM
1902 ;SPECBIND BINDS IDENTIFIERS. IT IS CALLED BY PUSHJ P,SPECBIND.
1903 ;SPECBIND IS PROVIDED WITH A CONTIGUOUS SET OF TRIPLETS ON TP.
1904 ;EACH TRIPLET IS AS FOLLOWS:
1905 ;THE FIRST ELEMENT IS THE IDENTIFIER TO BE BOUND, ITS TYPE WORD IS [TATOM,,-1],
1906 ;THE SECOND IS THE VALUE TO WHICH IT IS TO BE ASSIGNED,
1907 ;AND THE THIRD IS A PAIR OF ZEROES.
1915 USPCBE: PUSH P,$TUBIND
1919 MOVE E,TP ;GET THE POINTER TO TOP
1920 SPECBE: PUSH P,$TBIND
1921 ADD E,[1,,1] ;BUMP POINTER ONCE
1922 SETZB 0,D ;CLEAR TEMPS
1924 MOVEI 0,(TB) ; FOR CHECKS
1926 BINDLP: MOVE A,-4(E) ; CHECK FOR VEC BIND
1929 MOVE A,-6(E) ;GET TYPE
1930 CAME A,BNDA1 ; FOR UNSPECIAL
1931 CAMN A,BNDA ;NORMAL ID BIND?
1932 CAILE 0,-6(E) ; MAKE SURE NOT GOING UNDER FRAME
1934 SUB E,[6,,6] ;MOVE PTR
1936 HRRM E,(D) ;YES -- LOBBER
1938 MOVEM E,(P) ;NO -- DO IT
1940 MOVE A,0(E) ;GET ATOM PTR
1942 PUSHJ P,SILOC ;GET LAST BINDING
1943 MOVS A,OTBSAV (TB) ;GET TIME
1944 HRL A,5(E) ; GET DECL POINTER
1945 MOVEM A,4(E) ;CLOBBER IT AWAY
1946 MOVE A,(E) ; SEE IF SPEC/UNSPEC
1947 TRNN A,1 ; SKIP, ALWAYS SPEC
1948 SKIPA A,-1(P) ; USE SUPPLIED
1950 MOVEM A,(E) ;IDENTIFY AS BIND BLOCK
1953 HRRZ C,SPBASE(PVP) ; CHECK FOR CROSS OF PROC
1956 CAILE C,(B) ; SKIP IFF WINNER
1958 SPEB10: MOVEM B,5(E) ;IN RESTORE CELLS
1960 MOVE C,1(E) ;GET ATOM PTR
1964 MOVEI B,0 ; FOR SPCUNP
1965 CAIL A,HIBOT ; SKIP IF IMPURE ATOM
1968 HRRZ A,BINDID+1(PVP) ;GET PROCESS NUMBER
1969 HRLI A,TLOCI ;MAKE LOC PTR
1970 MOVE B,E ;TO NEW VALUE
1972 MOVEM A,(C) ;CLOBBER ITS VALUE
1974 MOVE D,E ;REMEMBER LINK
1975 JRST BINDLP ;DO NEXT
1977 NONID: CAILE 0,-4(E)
1985 MOVE D,1(E) ;GET PTR TO VECTOR
1986 MOVE C,(D) ;EXCHANGE TYPES
1990 MOVE C,1(D) ;EXCHANGE DATUMS
1995 HRLM A,(E) ;IDENTIFY BIND BLOCK
1996 MOVE D,E ;REMEMBER LINK
2008 ; HERE TO IMPURIFY THE ATOM
2010 SPCUNP: PUSH TP,$TSP
2013 PUSH TP,-1(P) ; LINK BACK IS AN SP
2017 SETZM -1(TP) ; FIXUP SOME FUNNYNESS
2020 MOVE 0,-2(TP) ; RESTORE LINK BACK POINTER
2029 ; ENTRY FROM COMPILER TO SET UP A BINDING
2031 IBIND: MOVE SP,SPSTOR+1
2032 SUBI E,-5(SP) ; CHANGE TO PDL POINTER
2043 JRST SPECB1 ; NOW BIND IT
2045 ; "FAST CALL TO SPECBIND"
2049 ; Compiler's call to SPECBIND all atom bindings, no TBVLs etc.
2052 MOVE E,TP ; POINT TO BINDING WITH E
2053 SPECB1: PUSH P,[0] ; SLOTS OF INTEREST
2057 SPECB2: MOVEI 0,(TB) ; FOR FRAME CHECK
2058 MOVE A,-5(E) ; LOOK AT FIRST THING
2059 CAMN A,BNDA ; SKIP IF LOSER
2060 CAILE 0,-5(E) ; SKIP IF REAL WINNER
2063 SUB E,[5,,5] ; POINT TO BINDING
2065 HRRM E,(A) ; YES DO IT
2066 SKIPN -1(P) ; FIRST ONE?
2067 MOVEM E,-1(P) ; THIS IS IT
2069 MOVE A,1(E) ; POINT TO ATOM
2071 MOVE 0,BINDID+1(PVP) ; QUICK CHECK
2073 CAMN 0,(A) ; WINNERE?
2074 JRST SPECB4 ; YES, GO ON
2076 PUSH P,B ; SAVE REST OF ACS
2079 MOVE B,A ; FOR ILOC TO WORK
2080 PUSHJ P,SILOC ; GO LOOK IT UP
2083 HRRZ C,SPBASE+1(PVP)
2085 CAIL A,(B) ; SKIP IF LOSER
2086 CAILE C,(B) ; SKIP IF WINNER
2087 MOVEI B,1 ; SAY NO BACK POINTER
2088 SPECB9: MOVE C,1(E) ; POINT TO ATOM
2089 SKIPE (C) ; IF GLOBALLY BOUND, MAKE SURE OK
2091 MOVEI A,(C) ; PURE ATOM?
2092 CAIGE A,HIBOT ; SKIP IF OK
2094 PUSH P,-4(P) ; MAKE HAPPINESS
2095 PUSHJ P,SPCUNP ; IMPURIFY
2098 MOVE A,BINDID+1(PVP)
2100 MOVEM A,(C) ; STOR POINTER INDICATOR
2107 SPECB4: MOVE A,1(A) ; GET LOCATIVE
2108 SPECB5: EXCH A,5(E) ; CLOBBER INTO REBIND SLOT (GET DECL)
2109 HLL A,OTBSAV(TB) ; TIME IT
2110 MOVSM A,4(E) ; SAVE DECL AND TIME
2112 HRLM A,(E) ; CHANGE TO A BINDING
2113 MOVE A,1(E) ; POINT TO ATOM
2114 MOVEM E,(P) ; REMEMBER THIS GUY
2115 ADD E,[2,,2] ; POINT TO VAL CELL
2116 MOVEM E,1(A) ; INTO ATOM SLOT
2117 SUB E,[3,,3] ; POINT TO NEXT ONE
2122 HRRM SP,(A) ; LINK OLD STUFF
2123 SKIPE A,-1(P) ; NEW SP?
2126 INTGO ; IN CASE BLEW STACK
2131 ;SPECSTORE RESTORES THE BINDINGS SP TO THE ENVIRONMENT POINTER IN
2132 ;SPSAV (TB). IT IS CALLED BY PUSHJ P,SPECSTORE.
2136 HRRZ E,SPSAV (TB) ;GET TARGET POINTER
2139 MOVE SP,SPSAV(TB) ; GET NEW SP
2143 STLOOP: MOVE SP,SPSTOR+1
2147 STLOO1: CAIL E,(SP) ;ARE WE DONE?
2149 HLRZ C,(SP) ;GET TYPE OF BIND
2152 CAIE C,TBIND ;NORMAL IDENTIFIER?
2153 JRST ISTORE ;NO -- SPECIAL HACK
2156 MOVE C,1(SP) ;GET TOP ATOM
2157 MOVSI 0,TLOCI ; MAYBE LOCI OR UNBOUND
2161 HRR 0,BINDID+1(PVP) ;STORE SIGNATURE
2163 MOVEI 0,0 ; TOTALLY UNBOUND IN ALL CASES
2164 MOVEM 0,(C) ;CLOBBER INTO ATOM
2167 SPLP: HRRZ SP,(SP) ;FOLOW LINK
2168 JUMPN SP,STLOO1 ;IF MORE
2171 STLOO2: MOVEM SP,SPSTOR+1
2185 CHSKIP: CAIN C,TSKIP
2187 CAIE C,TUNWIN ; UNWIND HACK
2189 HRRZ C,-2(P) ; WHERE FROM?
2192 MOVEI E,(TP) ; FIXUP SP
2202 ; ENTRY FOR FUNNY COMPILER UNBIND (1)
2209 SSPEC2: SUBI E,(SP) ; MAKE SP BE AOBJN
2219 ; ENTRY FOR FUNNY COMPILER UNBIND (2)
2224 SUBI E,1 ; MAKE SURE GET CURRENT BINDING
2225 PUSHJ P,STLOOP ; UNBIND
2226 MOVEI E,(TP) ; NOW RESET SP
2229 EFINIS: MOVE PVP,PVSTOR+1
2230 SKIPN C,1STEPR+1(PVP) ; SKIP NIF BEING ONE PROCEEDED
2233 PUSH TP,MQUOTE EVLOUT
2234 PUSH TP,A ;SAVE EVAL RESULTS
2236 PUSH TP,[TINFO,,2] ; FENCE POST
2239 PUSHJ P,MAKINF ; MAKE ARG BLOCK INFO
2242 HRLI B,-4 ; AOBJN TO ARGS BLOCK
2246 PUSH TP,1STEPR+1(PVP) ; PROCESS DOING THE 1STEPPING
2248 MOVE A,-3(TP) ; GET BACK EVAL VALUE
2252 1STEPI: PUSH TP,$TATOM
2253 PUSH TP,MQUOTE EVLIN
2254 PUSH TP,$TAB ; PUSH EVALS ARGGS
2256 PUSHJ P,MAKINF ; TURN INTO ARGS BLOCK
2257 MOVEM A,-1(TP) ; AND CLOBBER
2258 PUSH TP,[TINFO,,2] ; FENCE POST 2D TUPLE
2261 PUSHJ P,MAKINF ; TURN IT INTO ARGS BLOCK
2263 MOVEI B,-6(TP) ; SETUP TUPLE
2268 PUSH TP,1STEPR+1(PVP)
2269 MCALL 2,RESUME ; START UP 1STEPERR
2270 SUB TP,[6,,6] ; REMOVE CRUD
2271 GETYP A,A ; GET 1STEPPERS TYPE
2272 CAIE A,TDISMI ; IF DISMISS, STOP 1 STEPPING
2275 ; HERE TO PUSH DOWN THE 1 STEP STATE AND RUN
2278 ADD D,[1STEPR,,1STEPR] ; POINT TO 1 STEP SLOT
2279 PUSH TP,$TSP ; SAVE CURRENT SP
2284 PUSH TP,[0] ; NO 1 STEPPER UNTIL POPJ
2287 ; NOW PUSH THE ARGS UP TO RE-CALL EVAL
2290 EFARGL: JUMPGE AB,EFCALL
2296 EFCALL: ACALL A,EVAL ; NOW DO THE EVAL
2297 MOVE C,(TP) ; PRE-UNBIND
2299 MOVEM C,1STEPR+1(PVP)
2300 MOVE SP,-4(TP) ; AVOID THE UNBIND
2302 SUB TP,[6,,6] ; AND FLUSH LOSERS
2303 JRST EFINIS ; AND TRY TO FINISH UP
2305 MAKINF: HLRZ A,OTBSAV(TB) ; TIME IT
2310 TBTOTP: MOVEI D,(TB) ; COMPUTE REL DIST FROM TP TO TB
2313 ; ARRIVE HERE TO COMPLETE A COMPILER GENERATED TUPLE
2314 ; D/ LENGTH OF THE TUPLE IN WORDS
2316 MAKTU2: MOVE D,-1(P) ; GET LENGTH
2323 MAKTUP: HRLI D,TINFO ; FIRST WORD OF FENCE POST
2325 HRROI B,(TP) ; TOP OF TUPLE
2327 TLC B,-1(D) ; AOBJN IT
2330 HLRZ A,OTBSAV(TB) ; TIME IT
2334 ; HERE TO ALLOCATE SLOTS FOR COMPILER (AMNT IN A)
2337 ;Once here ==>ADDI A,1 Bug???
2342 PUSHJ P,TPOVFL ; IN CASE IT LOST
2343 INTGO ; TAKE THE GC IF NEC
2357 \f;EVALUATES A IDENTIFIER -- GETS LOCAL VALUE IF THERE IS ONE, OTHERWISE GLOBAL.
2359 IMFUNCTION VALUE,SUBR
2364 IDVAL: PUSHJ P,IDVAL1
2370 PUSH TP,B ;SAVE ARG IN CASE NEED TO CHECK GLOBAL VALUE
2371 PUSHJ P,ILVAL ;LOCAL VALUE FINDER
2372 CAME A,$TUNBOUND ;IF NOT UNBOUND OR UNASSIGNED
2373 JRST RIDVAL ;DONE - CLEAN UP AND RETURN
2374 POP TP,B ;GET ARG BACK
2377 RIDVAL: SUB TP,[2,,2]
2380 ;GETS THE LOCAL VALUE OF AN IDENTIFIER
2382 IMFUNCTION LVAL,SUBR
2390 ; MAKE AN ATOM UNASSIGNED
2392 MFUNCTION UNASSIGN,SUBR
2393 JSP E,CHKAT ; GET ATOM ARG
2395 UNASIT: CAMN A,$TUNBOU ; IF UNBOUND
2399 SETOM 1(B) ; MAKE SURE
2400 RETATM: MOVE B,1(AB)
2406 MFUNCTION GUNASSIGN,SUBR
2411 MOVE B,1(AB) ; ATOM BACK
2413 CAIL 0,HIBOT ; SKIP IF IMPURE
2414 PUSHJ P,IMPURIFY ; YES, MAKE IT IMPURE
2415 PUSHJ P,IGLOC ; RESTORE LOCATIVE
2416 HRRZ 0,-2(B) ; SEE IF MANIFEST
2417 GETYP A,(B) ; AND CURRENT TYPE
2426 ; GETS A LOCATIVE TO THE LOCAL VALUE OF AN IDENTIFIER.
2437 ;TESTS TO SEE IF AN IDENTIFIER IS LOCALLY BOUND
2439 MFUNCTION BOUND,SUBR,[BOUND?]
2446 ;TESTS TO SEE IF AN IDENTIFIER IS LOCALLY ASSIGNED
2448 MFUNCTION ASSIGP,SUBR,[ASSIGNED?]
2456 ;GETS THE GLOBAL VALUE OF AN IDENTIFIER
2458 IMFUNCTION GVAL,SUBR
2465 ;GETS A LOCATIVE TO THE GLOBAL VALUE OF AN IDENTIFIER
2467 MFUNCTION RGLOC,SUBR
2492 MOVE C,1(AB) ; GE ATOM
2494 CAIGE 0,HIBOT ; SKIP IF PURE ATOM
2497 ; MAKE ATOM AND VALUE IMPURE IF GETTING GLOC TO IT
2499 MOVE B,C ; ATOM TO B
2501 JRST GLOC ; AND TRY AGAIN
2503 ;TESTS TO SEE IF AN IDENTIFIER IS GLOBALLY ASSIGNED
2505 MFUNCTION GASSIG,SUBR,[GASSIGNED?]
2512 ; TEST FOR GLOBALLY BOUND
2514 MFUNCTION GBOUND,SUBR,[GBOUND?]
2524 CHKAT1: GETYP A,(AB)
2531 CHKAT: HLRE A,AB ; - # OF ARGS
2532 ASH A,-1 ; TO ACTUAL WORDS
2534 MOVE C,SPSTOR+1 ; FOR BINDING LOOKUPS
2535 AOJE A,CHKAT1 ; ONLY ONE ARG, NO ENVIRONMENT
2536 AOJL A,TMA ; TOO MANY
2537 GETYP A,2(AB) ; MAKE SURE OF TENV OR TFRAME
2541 CAIN A,TACT ; FOR PFISTERS LOSSAGE
2543 CAIE A,TPVP ; OR PROCESS
2545 MOVE B,3(AB) ; GET PROCESS
2546 MOVE C,SPSTOR+1 ; IN CASE ITS ME
2547 CAME B,PVSTOR+1 ; SKIP IF DIFFERENT
2548 MOVE C,SPSTO+1(B) ; GET ITS SP
2550 CHKAT3: MOVEI B,2(AB) ; POINT TO FRAME POINTER
2551 PUSHJ P,CHFRM ; VALIDITY CHECK
2552 MOVE B,3(AB) ; GET TB FROM FRAME
2553 MOVE C,SPSAV(B) ; GET ENVIRONMENT POINTER
2557 ; SILOC--CALLS ILOC IGNORING SPECIAL CHECKING
2561 ;ILOC RETURNS IN A AND B A LOCATIVE TO THE LOCAL VALUE OF THE IDENTIFIER
2562 ; PASSED TO IT IN A AND B. IF THE IDENTIFIER IS LOCALLY UNBOUND IT RETURNS
2563 ; $TUNBOUND IN A AND 0 IN B, IT IS CALLED BY PUSHJ P,ILOC.
2565 ILOC: MOVE C,SPSTOR+1 ; SETUP SEARCH START
2566 AILOC: SKIPN (B) ; ANY KIND OF VALUE AT ALL?
2568 MOVSI A,TLOCI ;MAKE A LOCATIVE TYPE CELL
2571 MOVEI E,0 ; FLAG TO CLOBBER ATOM
2572 JUMPE B,SCHSP ; IF LOOKING FOR SLOT, SEARCH NOW
2573 CAME C,SPSTOR+1 ; ENVIRONMENT CHANGE?
2574 JRST SCHSP ; YES, MUST SEARCH
2576 HRR A,BINDID+1(PVP) ;FOR THE CURRENT PROCESS
2577 CAME A,(B) ;IS THERE ONE IN THE VALUE CELL?
2578 JRST SCHLP ;NO -- SEARCH THE LOCAL BINDINGS
2579 MOVE B,1(B) ;YES -- GET LOCATIVE POINTER
2581 ILCPJ: MOVE E,SPCCHK
2582 TRNN E,1 ; SKIP IF DOING SPEC UNSPEC CHECK
2584 HRRZ E,-2(P) ; IF IGNORING, IGNORE
2591 CAMGE B,CURFCN+1(PVP)
2596 CAMGE B,SPBASE+1(PVP)
2601 POPJ P, ;FROM THE VALUE CELL
2613 CAIL D,HIBOT ; SKIP IF IMPURE ATOM
2614 SCHSP: MOVEI E,1 ; DONT STORE LOCATIVE
2616 PUSH P,E ; PUSH SWITCH
2617 MOVE E,PVSTOR+1 ; GET PROC
2618 SCHLP1: JUMPE C,UNPJ ;IF NO MORE -- LOSE
2619 CAMN B,1(C) ;ARE WE POINTING AT THE WINNER?
2621 GETYP D,(C) ; CHECK SKIP
2624 PUSH P,B ; CHECK DETOUR
2626 PUSHJ P,CHFRAM ; NON-FATAL FRAME CHECKER
2627 HRRZ E,2(C) ; CONS UP PROCESS
2630 JUMPE B,SCHLP3 ; LOSER, FIX IT
2632 MOVEI C,1(C) ; FOLLOW LOOKUP CHAIN
2633 SCHLP2: HRRZ C,(C) ;FOLLOW LINK
2638 MOVEI C,(SP) ; *** NDR'S BUG ***
2639 CAME E,PVSTOR+1 ; USE IF CURRENT PROCESS
2640 HRRZ C,SPSTO+1(E) ; USE CURRENT SP FOR PROC
2643 SCHFND: MOVE D,SPCCHK
2644 TRNN D,1 ; SKIP IF DOING SPEC UNSPEC CHECK
2646 HRRZ D,-2(P) ; IF IGNORING, IGNORE
2653 HRRZ D,CURFCN+1(PVP)
2657 HRRZ D,SPBASE+1(PVP)
2662 SCHFN1: EXCH B,C ;SAVE THE ATOM PTR IN C
2663 MOVEI B,2(B) ;MAKE UP THE LOCATIVE
2667 EXCH C,E ; RET PROCESS IN C
2668 POP P,D ; RESTORE SWITCH
2670 JUMPN D,ILOCPJ ; DONT CLOBBER ATOM
2671 MOVEM A,(E) ;CLOBBER IT AWAY INTO THE
2672 MOVE D,1(E) ; GET OLD POINTER
2673 MOVEM B,1(E) ;ATOM'S VALUE CELL
2674 JUMPE D,ILOCPJ ; IF POINTS TO GLOBAL OR OTHER PROCES
2675 ; MAKE SURE BINDING SO INDICATES
2676 MOVE D,B ; POINT TO BINDING
2677 SKIPL E,3(D) ; GO TO FIRST ONE, JUST IN CASE
2680 JRST .-3 ; LOOP THROUGH
2682 MOVEM E,3(D) ; MAGIC INDICATION
2685 UNPJ: SUB P,[1,,1] ; FLUSH CRUFT
2686 UNPJ1: MOVE C,E ; RET PROCESS ANYWAY
2689 UNPOPJ: MOVSI A,TUNBOUND
2693 FUNPJ: MOVE C,PVSTOR+1
2696 ;IGLOC RETURNS IN A AND B A LOCATIVE TO THE GLOBAL VALUE OF THE
2697 ;IDENTIFIER PASSED TO IT IN A AND B. IF THE IDENTIFIER IS GLOBALLY
2698 ;UNBPOUND IT RETURNS $TUNBOUND IN A AND 0 IN B. IT IS CALLED BY PUSHJ P,IGLOC.
2700 IGLOC: MOVSI A,TLOCI ;DO WE HAVE A LOCATIVE TO
2701 CAME A,(B) ;A PROCESS #0 VALUE?
2702 JRST SCHGSP ;NO -- SEARCH
2703 MOVE B,1(B) ;YES -- GET VALUE CELL
2708 MOVE D,GLOBSP+1 ;GET GLOBAL SP PTR
2710 SCHG1: JUMPGE D,UNPOPJ ;IF NO MORE, LEAVE
2711 CAMN B,1(D) ;ARE WE FOUND?
2713 ADD D,[4,,4] ;NO -- TRY NEXT
2717 EXCH B,D ;SAVE ATOM PTR
2718 ADD B,[2,,2] ;MAKE LOCATIVE
2722 MOVEM A,(D) ;CLOBBER IT AWAY
2726 IIGLOC: PUSH TP,$TATOM
2739 PUSHJ P,IMPURI ; IMPURIFY THE POOR ATOM
2740 PUSHJ P,BSETG ; MAKE A SLOT
2741 SETOM 1(B) ; UNBOUNDIFY IT
2750 ;ILVAL RETURNS IN A AND B THE LOCAL VALUE OF THE IDENTIFIER PASSED TO IT IN A AND B
2751 ;IF THE IDENTIFIER IS UNBOUND ITS VALUE IS $TUNBOUND IN A AND 0 IN B. IF
2752 ;IT IS UNASSIGNED ITS VALUE IS $TUNBOUND IN A AND -1 IN B. CALL - PUSHJ P,IVAL
2755 PUSHJ P,AILOC ; USE SUPPLIED SP
2758 PUSHJ P,ILOC ;GET LOCATIVE TO VALUE
2759 CHVAL: CAMN A,$TUNBOUND ;BOUND
2760 POPJ P, ;NO -- RETURN
2761 MOVSI A,TLOCD ; GET GOOD TYPE
2762 HRR A,2(B) ; SHOULD BE TIME OR 0
2764 PUSHJ P,RMONC0 ; CHECK READ MONITOR
2766 MOVE A,(B) ;GET THE TYPE OF THE VALUE
2767 MOVE B,1(B) ;GET DATUM
2770 ;IGVAL -- LIKE ILVAL EXCEPT FOR GLOBAL VALUES
2772 IGVAL: PUSHJ P,IGLOC
2777 ; COMPILERS INTERFACE TO LVAL/GVAL/SETG/SET
2779 CILVAL: MOVE PVP,PVSTOR+1
2780 MOVE 0,BINDID+1(PVP) ; CURRENT BIND
2782 CAME 0,(B) ; HURRAY FOR SPEED
2783 JRST CILVA1 ; TOO BAD
2784 MOVE C,1(B) ; POINTER
2785 MOVE A,(C) ; VAL TYPE
2786 TLNE A,.RDMON ; MONITORS?
2790 JRST CUNAS ; COMPILER ERROR
2791 MOVE B,1(C) ; GOT VAL
2795 HLRZ 0,-2(C) ; SPECIAL CHECK
2799 CAMGE C,CURFCN+1(PVP)
2804 CILVA1: SUBM M,(P) ; FIX (P)
2805 PUSH TP,$TATOM ; SAVE ATOM
2807 MCALL 1,LVAL ; GET ERROR/MONITOR
2809 POPJM: SUBM M,(P) ; REPAIR DAMAGE
2812 ; COMPILERS INTERFACE TO SET C/ ATOM A,B/ NEW VALUE
2814 CISET: MOVE PVP,PVSTOR+1
2815 MOVE 0,BINDID+1(PVP) ; CURRENT BINDING ENVIRONMENT
2817 CAME 0,(C) ; CAN WE WIN?
2818 JRST CISET1 ; NO, MORE HAIR
2819 MOVE D,1(C) ; POINT TO SLOT
2820 CISET3: HLLZ 0,(D) ; MON CHECK
2822 JRST CISET4 ; YES, LOSE
2824 IOR A,0 ; LEAVE MONITOR ON
2827 JRST CISET5 ; SPEC/UNSPEC CHECK
2828 CISET6: MOVEM A,(D) ; STORE
2832 CISET5: HLRZ 0,-2(D)
2836 CAMGE D,CURFCN+1(PVP)
2840 CISET1: SUBM M,(P) ; FIX ADDR
2841 PUSH TP,$TATOM ; SAVE ATOM
2846 PUSHJ P,ILOC ; SEARCH
2847 MOVE D,B ; POSSIBLE POINTER
2850 MOVE A,-1(TP) ; VAL BACK
2852 CAIE E,TUNBOU ; SKIP IF WIN
2853 JRST CISET2 ; GO CLOBBER IT IN
2857 CISET2: MOVE C,-2(TP) ; ATOM BACK
2858 SUBM M,(P) ; RESET (P)
2862 ; HERE TO DO A MONITORED SET
2864 CISET4: SUBM M,(P) ; AGAIN FIX (P)
2874 CLLOC: MOVE PVP,PVSTOR+1
2875 MOVE 0,BINDID+1(PVP) ; GET CURRENT LOCATIVE
2881 TRNE 0,1 ; SKIP IF NOT CHECKING
2883 CLLOC3: MOVSI A,TLOCD
2884 HRR A,2(B) ; GET BIND TIME
2890 PUSHJ P,ILOC ; LOOK IT UP
2896 CLLOC2: MCALL 1,LLOC
2899 CLLOC9: HLRZ 0,-2(B)
2903 CAMGE B,CURFCN+1(PVP)
2911 JUMPE B,PJFALS ; IF UNBOUND RET FALSE AND NO SSKIP
2921 ; COMPILER ASSIGNED?
2932 ; COMPILER GVAL B/ ATOM
2934 CIGVAL: MOVE 0,(B) ; GLOBAL VAL HERE?
2935 CAME 0,$TLOCI ; TIME=0 ,TYPE=TLOCI => GLOB VAL
2936 JRST CIGVA1 ; NO, GO LOOK
2937 MOVE C,1(B) ; POINT TO SLOT
2938 MOVE A,(C) ; GET TYPE
2941 GETYP 0,A ; CHECK FOR UNBOUND
2942 CAIN 0,TUNBOU ; SKIP IF WINNER
2951 .MCALL 1,GVAL ; GET ERROR/MONITOR
2954 ; COMPILER INTERFACET TO SETG
2956 CSETG: MOVE 0,(C) ; GET V CELL
2957 CAME 0,$TLOCI ; SKIP IF FAST
2959 HRRZ D,1(C) ; POINT TO SLOT
2960 MOVE 0,(D) ; OLD VAL
2961 CSETG3: CAIG D,HIBOT ; SKIP IF PURE ATOM
2962 TLNE 0,.WRMON ; MONITOR
2968 CSETG1: SUBM M,(P) ; FIX UP P
2974 PUSHJ P,IGLOC ; FIND GLOB LOCATIVE
2977 MOVEI D,(B) ; SETUP TO RESTORE NEW VAL
2985 CSETG4: MOVE C,-2(TP) ; ATOM BACK
2986 SUBM M,(P) ; RESET (P)
2991 PUSH TP,$TATOM ; CAUSE A SETG MONITOR
3000 CGLOC: MOVE 0,(B) ; GET CURRENT GUY
3001 CAME 0,$TLOCI ; WIN?
3003 HRRZ D,1(B) ; POINT TO SLOT
3004 CAILE D,HIBOT ; PURE?
3016 ; COMPILERS GASSIGNED?
3040 IMFUNCTION REP,FSUBR,[REPEAT]
3042 MFUNCTION BIND,FSUBR
3044 IMFUNCTION PROG,FSUBR
3046 GETYP A,(AB) ;GET ARG TYPE
3047 CAIE A,TLIST ;IS IT A LIST?
3048 JRST WRONGT ;WRONG TYPE
3049 SKIPN C,1(AB) ;GET AND CHECK ARGUMENT
3050 JRST TFA ;TOO FEW ARGS
3051 SETZB E,D ; INIT HEWITT ATOM AND DECL
3052 PUSHJ P,CARATC ; IS 1ST THING AN ATOM
3054 PUSHJ P,RSATY1 ; CDR AND GET TYPE
3055 CAIE 0,TLIST ; MUST BE LIST
3057 MOVE B,1(C) ; GET ARG LIST
3062 JRST NOP.DC ; JUMP IF NO DCL
3065 PUSHJ P,RSATYP ; CDR ON
3066 NOP.DC: PUSH TP,$TLIST
3067 PUSH TP,B ; AND ARG LIST
3068 PUSHJ P,PRGBND ; BIND AUX VARS
3071 SKIPA E,IMQUOTE LPROG,[LPROG ]INTRUP
3073 PUSHJ P,MAKACT ; MAKE ACTIVATION
3074 PUSHJ P,PSHBND ; BIND AND CHECK
3075 PUSHJ P,SPECBI ; NAD BIND IT
3077 ; HERE TO RUN PROGS FUNCTIONS ETC.
3079 DOPROG: MOVEI A,REPROG
3080 HRLI A,TDCLI ; FLAG AS FUNNY
3081 MOVEM A,(TB) ; WHERE TO AGAIN TO
3083 MOVEM C,3(TB) ; RESTART POINTER
3084 JRST .+2 ; START BY SKIPPING DECL
3086 DOPRG1: PUSHJ P,FASTEV
3087 HRRZ C,@1(TB) ;GET THE REST OF THE BODY
3088 DOPRG2: MOVEM C,1(TB)
3093 REPROG: SKIPN C,@3(TB)
3101 PFINIS: GETYP 0,(TB)
3102 CAIE 0,TDCLI ; DECL'D ?
3104 HRRZ 0,(TB) ; SEE IF RSUBR
3105 JUMPE 0,RSBVCK ; CHECK RSUBR VALUE
3106 HRRZ C,3(TB) ; GET START OF FCN
3107 GETYP 0,(C) ; CHECK FOR DECL
3109 JRST PFINI1 ; NO, JUST RETURN
3110 MOVE E,IMQUOTE VALUE
3111 PUSHJ P,PSHBND ; BUILD FAKE BINDING
3112 MOVE C,1(C) ; GET DECL LIST
3114 PUSHJ P,CHKDCL ; AND CHECK IT
3115 MOVE A,-3(TP) ; GET VAL BAKC
3119 PFINI1: HRRZ C,FSAV(TB)
3129 ; HERE TO CHECK RSUBR VALUE
3135 MOVE A,1(TB) ; GET DECL
3144 RSBVC1: MOVE C,1(TB)
3147 MOVE A,IMQUOTE VALUE
3151 MFUNCTION MRETUR,SUBR,[RETURN]
3153 HLRE A,AB ; GET # OF ARGS
3154 ASH A,-1 ; TO NUMBER
3155 AOJL A,RET2 ; 2 OR MORE ARGS
3156 PUSHJ P,PROGCH ;CHECK IN A PROG
3159 MOVEI B,-1(TP) ; VERIFY IT
3160 COMRET: PUSHJ P,CHFSWP
3162 MOVEI C,0 ; REAL NONE
3164 JUMPN A,CHFINI ; WINNER
3168 ; SEE IF MUST CHECK RETURNS TYPE
3170 CHFINI: GETYP 0,(TB) ; SPECIAL TYPE IF SO
3172 JRST FINIS ; NO, JUST FINIS
3173 MOVEI 0,PFINIS ; CAUSE TO FALL INTO FUNCTION CODE
3180 CAIE A,TACT ; AS FOR "EXIT" SHOULD BE ACTIVATION
3182 MOVEI B,(AB)+2 ; ADDRESS OF FRAME POINTER
3187 MFUNCTION AGAIN,SUBR
3189 HLRZ A,AB ;GET # OF ARGS
3192 JUMPN A,TMA ;0 ARGS?
3193 PUSHJ P,PROGCH ;CHECK FOR IN A PROG
3202 AGAD: MOVEI B,-1(TP) ; POINT TO FRAME
3204 HRRZ C,(B) ; GET RET POINT
3205 GOJOIN: PUSH TP,$TFIX
3208 PUSHJ P,CHUNW ; RESTORE FRAME, UNWIND IF NEC.
3210 HRRZ 0,FSAV(TB) ; CHECK FOR RSUBR
3224 MOVE C,OTBSAV(TB) ; AND RESTORE P FROM FATHER
3237 PUSHJ P,PROGCH ;CHECK FOR A PROG
3246 MCALL 2,MEMQ ;DOES IT HAVE THIS TAG?
3247 JUMPE B,NXTAG ;NO -- ERROR
3248 FNDGO: EXCH B,(TP) ;SAVE PLACE TO GO
3253 NLCLGO: CAIE A,TTAG ;CHECK TYPE
3256 MOVEI B,2(B) ; POINT TO SLOT
3259 GETYP 0,(A) ; SEE IF COMPILED
3265 GODON1: PUSH TP,(A) ;SAVE BODY
3268 PUSHJ P,CHUNW ;GO BACK TO CORRECT FRAME
3269 MOVE B,(TP) ;RESTORE ITERATION MARKER
3282 GETYP A,(AB) ;GET TYPE OF ARGUMENT
3283 CAIE A,TFIX ; FIX ==> COMPILED
3295 ATOTAG: CAIE A,TATOM ;CHECK THAT IT IS AN ATOM
3299 PUSHJ P,PROGCH ;CHECK PROG
3307 JUMPE B,NXTAG ;IF NOT FOUND -- ERROR
3308 EXCH A,-1(TP) ;SAVE PLACE
3318 PROGCH: MOVE B,IMQUOTE LPROG,[LPROG ]INTRUP
3319 PUSHJ P,ILVAL ;GET VALUE
3325 ; HERE TO UNASSIGN LPROG IF NEC
3327 UNPROG: MOVE B,IMQUOTE LPROG,[LPROG ]INTRUP
3330 CAIE 0,TACT ; SKIP IF MUST UNBIND
3334 MOVE E,IMQUOTE LPROG,[LPROG ]INTRUP
3336 UNMAP: HRRZ 0,FSAV(TB) ; CHECK FOR FUNNY
3337 CAIN 0,MAPPLY ; SKIP IF NOT
3339 MOVE B,IMQUOTE LMAP,[LMAP ]INTRUP
3346 MOVE E,IMQUOTE LMAP,[LMAP ]INTRUP
3348 UNSPEC: PUSH TP,BNDV
3350 ADD B,[CURFCN,,CURFCN]
3359 MFUNCTION MEXIT,SUBR,[EXIT]
3367 PUSHJ P,CHUNW ;RESTORE FRAME
3368 JRST CHFINI ; CHECK FOR WINNING VALUE
3371 MFUNCTION COND,FSUBR
3377 PUSH TP,1(AB) ;CREATE UNNAMED TEMP
3378 MOVEI B,0 ; SET TO FALSE IN CASE
3380 CLSLUP: SKIPN C,1(TB) ;IS THE CLAUSELIST NIL?
3381 JRST IFALS1 ;YES -- RETURN NIL
3382 GETYP A,(C) ;NO -- GET TYPE OF CAR
3383 CAIE A,TLIST ;IS IT A LIST?
3385 MOVE A,1(C) ;YES -- GET CLAUSE
3388 PUSH TP,B ; EVALUATION OF
3390 PUSH TP,1(A) ;THE PREDICATE
3395 JRST NXTCLS ;FALSE TRY NEXT CLAUSE
3396 MOVE C,1(TB) ;IF NOT, DO FIRST CLAUSE
3399 JUMPE C,FINIS ;(UNLESS DONE WITH IT)
3400 JRST DOPRG2 ;AS THOUGH IT WERE A PROG
3401 NXTCLS: HRRZ C,@1(TB) ;SET THE CLAUSLIST
3402 HRRZM C,1(TB) ;TO CDR OF THE CLAUSLIST
3407 IFALS1: MOVSI A,TFALSE ;RETURN FALSE
3412 MFUNCTION UNWIND,FSUBR
3416 GETYP 0,(AB) ; CHECK THE ARGS FOR WINNAGE
3417 SKIPN A,1(AB) ; NONE?
3419 HRRZ B,(A) ; CHECK FOR 2D
3424 ; Unbind LPROG and LMAPF so that nothing cute happens
3428 ; Push thing to do upon UNWINDing
3434 PUSHJ P,IUNWIN ; GOT TO INTERNAL SET UP
3436 ; Now EVAL the first form
3439 HRRZ 0,(A) ; SAVE POINTER TO OTHER GUY
3444 JSP E,CHKAB ; DEFER?
3447 MCALL 1,EVAL ; EVAL THE LOSER
3451 ; Now push slots to hold undo info on the way down
3453 IUNWIN: JUMPE M,NOUNRE
3454 HLRE 0,M ; CHECK BOUNDS
3462 NOUNRE: PUSH TP,$TTB ; DESTINATION FRAME
3464 PUSH TP,[0] ; ARGS TO WHOEVER IS DOING IT
3467 ; Now bind UNWIND word
3469 PUSH TP,$TUNWIN ; FIRST WORD OF IT
3471 HRRM SP,(TP) ; CHAIN
3473 PUSH TP,TB ; AND POINT TO HERE
3478 PUSH TP,P ; SAVE PDL ALSO
3479 MOVEM TP,-2(TP) ; SAVE FOR LATER
3482 ; Do a non-local return with UNWIND checking
3484 CHUNW: HRRZ E,SPSAV(B) ; GET DESTINATION FRAME
3485 CHUNW1: PUSH TP,(C) ; FINAL VAL
3487 JUMPN C,.+3 ; WAS THERE REALLY ANYTHING
3490 PUSHJ P,STLOOP ; UNBIND
3491 CHUNPC: SKIPA ; WILL NOT SKIP UNLESS UNWIND FOUND
3499 HRRI TB,(B) ; UPDATE TB
3505 POPUNW: MOVE SP,SPSTOR+1
3516 UNWFRM: JUMPE FRM,CPOPJ
3518 UNWFR2: JUMPE B,UNWFR1
3527 ; Here if an UNDO found
3529 GOTUND: MOVE TB,1(SP) ; GET FRAME OF UNDO
3530 MOVE A,-1(TP) ; GET FUNNY ARG FOR PASS ON
3532 MOVE TP,3(SP) ; GET FUTURE TP
3533 MOVEM C,-6(TP) ; SAVE ARG
3535 MOVE C,(TP) ; SAVED P
3537 MOVEM C,PSAV(TB) ; MAKE CONTIN WIN
3540 HRRZ C,(P) ; PC OF CHUNW CALLER
3541 HRRM C,-11(TP) ; SAVE ALSO AND GET WHERE TO GO PC
3542 MOVEM B,-10(TP) ; AND DESTINATION FRAME
3543 HRRZ C,-1(TP) ; WHERE TO UNWIND PC
3544 HRRZ 0,FSAV(TB) ; RSUBR?
3553 UNWIN1: MOVE B,-12(TP) ; POINT TO THING TO DO UNWINDING
3561 UNWIN2: MOVEI C,-7(TP) ; POINT TO SAVED RET VALS
3566 HRRZ SP,(SP) ; UNBIND THIS GUY
3567 MOVEI E,(TP) ; AND FIXUP SP
3573 JRST CHUNW ; ANY MORE TO UNWIND?
3576 ; CHFSWP - CHECK FRAMES VALIDITY AND SWAP PROCESS IF NECESSARY.
3577 ; CALLED BY ALL CONTROL FLOW
3578 ; ROUTINES (GO,RETURN,EXIT,AGAIN,ERRET...)
3580 CHFSWP: PUSHJ P,CHFRM ; CHECK FOR VALID FRAME
3581 HRRZ D,(B) ; PROCESS VECTOR DOPE WD
3583 SUBI D,-1(C) ; POINT TO TOP
3584 MOVNS C ; NEGATE COUNT
3585 HRLI D,2(C) ; BUILD PVP
3588 MOVE A,(B) ; GET FRAME
3590 CAMN E,D ; SKIP IF SWAP NEEDED
3592 PUSH TP,A ; SAVE FRAME
3595 PUSHJ P,PROCHK ; FIX UP PROCESS LISTS
3596 MOVE A,PSTAT+1(B) ; GET STATE
3599 MOVE D,B ; PREPARE TO SWAP
3603 JSP C,SWAP ; SWAP IN
3604 MOVE C,ABSTO+1(E) ; GET OLD ARRGS
3605 MOVEI A,RUNING ; FIX STATES
3607 MOVEM A,PSTAT+1(PVP)
3612 NOTRES: ERRUUO EQUOTE PROCESS-NOT-RESUMABLE
3615 ;SETG IS USED TO SET THE GLOBAL VALUE OF ITS FIRST ARGUMENT,
3616 ;AN IDENTIFIER, TO THE VALUE OF ITS SECOND ARGUMENT. ITS VALUE IS
3617 ; ITS SECOND ARGUMENT.
3619 IMFUNCTION SETG,SUBR
3621 GETYP A,(AB) ;GET TYPE OF FIRST ARGUMENT
3622 CAIE A,TATOM ;CHECK THAT IT IS AN ATOM
3623 JRST NONATM ;IF NOT -- ERROR
3624 MOVE B,1(AB) ;GET POINTER TO ATOM
3628 CAIL 0,HIBOT ; PURE ATOM?
3629 PUSHJ P,IMPURIFY ; YES IMPURIFY
3630 PUSHJ P,IGLOC ;GET LOCATIVE TO VALUE
3631 CAME A,$TUNBOUND ;IF BOUND
3633 SKIPN NOSETG ; ALLOWED?
3636 PUSH TP,EQUOTE CREATING-NEW-GVAL
3640 PUSH TP,EQUOTE NON-FALSE-TO-ALLOW
3645 GOOSTG: PUSHJ P,BSETG ;IF NOT -- BIND IT
3646 GOOST1: MOVE C,2(AB) ; GET PROPOSED VVAL
3648 MOVSI A,TLOCD ; MAKE SURE MONCH WINS
3649 PUSHJ P,MONCH0 ; WOULD YOU BELIEVE MONITORS!!!!
3652 HRRZ E,-2(D) ; POINT TO POSSIBLE GDECL (OR MAINIFEST)
3653 JUMPE E,OKSETG ; NONE ,OK
3654 CAIE E,-1 ; MANIFEST?
3656 GETYP 0,(D) ; IF UNBOUND, LET IT HAPPEN
3668 MOVE B,IMQUOTE REDEFINE
3669 PUSHJ P,ILVAL ; SEE IF REDEFINE OK
3676 PUSH TP,EQUOTE ATTEMPT-TO-CHANGE-MANIFEST-VARIABLE
3682 SETGTY: PUSH TP,$TVEC
3697 OKSETG: MOVEM A,(D) ;DEPOSIT INTO THE
3698 MOVEM B,1(D) ;INDICATED VALUE CELL
3709 BSETG: HRRZ A,GLOBASE+1
3714 MOVEI B,0 ; MAKE SURE OF NO EMPTY SLOTS
3716 CAMN A,$TUNBOU ; SKIP IF SLOT FOUND
3718 MOVE C,(TP) ; GET ATOM
3719 MOVEM C,-1(B) ; CLOBBER ATOM SLOT
3720 HLLZS -2(B) ; CLOBBER OLD DECL
3722 ; BSETG1: PUSH TP,GLOBASE ; MUST REALLY GROW STACK
3734 MOVE B,GVLINC ; GROW BY INDICATED GVAL SLOTS
3737 MOVE C,[6,,4] ; INDICATOR FOR AGC
3740 MOVE 0,GVLINC ; ADJUST GLOBAL SPBASE
3758 BSETGX: MOVSI A,TLOCI
3759 PUSHJ P,PATSCH ; FIXUP SCHLPAGE
3769 PATL: SKIPL E,3(D) ; SKIP IF NEXT EXISTS
3775 MOVEM E,3(D) ; SAY GVAL ETC. EXISTS IF WE UNBIND
3779 IMFUNCTION DEFMAC,FSUBR
3786 IMFUNCTION DFNE,FSUBR,[DEFINE]
3794 SKIPN B,1(AB) ; GET ATOM
3796 GETYP A,(B) ; MAKE SURE ATOM
3801 MCALL 1,EVAL ; EVAL IT TO AN ATOM
3804 PUSH TP,A ; SAVE TWO COPIES
3806 PUSHJ P,IGVAL ; SEE IF A VALUE EXISTS
3807 CAMN A,$TUNBOU ; SKIP IF A WINNER
3809 PUSHJ P,ASKUSR ; CHECK WITH USER
3816 SKIPN (P) ; SKIP IF MACRO
3818 MOVEI D,(B) ; READY TO CONS
3825 DFNE1: POP TP,B ; RETURN ATOM
3830 ASKUSR: MOVE B,IMQUOTE REDEFINE
3831 PUSHJ P,ILVAL ; SEE IF REDEFINE OK
3837 ASKUS1: PUSH TP,$TATOM
3840 PUSH TP,EQUOTE ALREADY-DEFINED-ERRET-NON-FALSE-TO-REDEFINE
3850 ;SET CLOBBERS THE LOCAL VALUE OF THE IDENTIFIER GIVEN BY ITS
3851 ;FIRST ARGUMENT TO THE SECOND ARG. ITS VALUE IS ITS SECOND ARGUMENT.
3854 HLRE D,AB ; 2 TIMES # OF ARGS TO D
3855 ASH D,-1 ; - # OF ARGS
3857 JUMPG D,TFA ; NOT ENOUGH
3860 JUMPE D,SET1 ; NO ENVIRONMENT
3861 AOJL D,TMA ; TOO MANY
3862 GETYP A,4(AB) ; CHECK ARG IS A FRAME OR PROCESS
3865 JRST SET2 ; WINNING ENVIRONMENT/FRAME
3867 JRST SET2 ; TO MAKE PFISTER HAPPY
3870 MOVE B,5(AB) ; GET PROCESS
3873 SET2: MOVEI B,4(AB) ; POINT TO FRAME
3874 PUSHJ P,CHFRM ; CHECK IT OUT
3875 MOVE B,5(AB) ; GET IT BACK
3876 MOVE C,SPSAV(B) ; GET BINDING POINTER
3877 HRRZ B,4(AB) ; POINT TO PROCESS
3878 HLRZ A,(B) ; GET LENGTH
3879 SUBI B,-1(A) ; POINT TO START THEREOF
3880 HLL B,PVSTOR+1 ; GET -LNTRH, (ALL PROCESS VECS SAME LENGTH)
3881 SET1: PUSH TP,$TPVP ; SAVE PROCESS
3883 PUSH TP,$TSP ; SAVE PATH POINTER
3885 GETYP A,(AB) ;GET TYPE OF FIRST
3886 CAIE A,TATOM ;ARGUMENT --
3887 JRST WTYP1 ;BETTER BE AN ATOM
3888 MOVE B,1(AB) ;GET PTR TO IT
3893 PUSHJ P,AILOC ;GET LOCATIVE TO VALUE
3894 GOTLOC: CAME A,$TUNBOUND ;IF BOUND
3896 SKIPN NOSET ; ALLOWED?
3899 PUSH TP,EQUOTE CREATING-NEW-LVAL
3903 PUSH TP,EQUOTE NON-FALSE-TO-ALLOW
3908 GOOSET: PUSHJ P,BSET ;IF NOT -- BIND IT
3909 GOOSE1: MOVE C,2(AB) ; GET PROPOSED VVAL
3910 MOVE C,2(AB) ; GET NEW VAL
3912 MOVSI A,TLOCD ; FOR MONCH
3914 PUSHJ P,MONCH0 ; HURRAY FOR MONITORS!!!!!
3916 HLRZ A,2(E) ; GET DECLS
3917 JUMPE A,SET3 ; NONE, GO
3921 HLLZ A,(A) ; GET PATTERN
3922 PUSHJ P,TMATCH ; MATCH TMEM
3928 SET3: MOVEM C,(E) ;CLOBBER IDENTIFIER
3932 MOVE C,-2(TP) ; GET PROC
3936 ; HERE WE NOTE THAT EFFICIENCY CAN SOMETIMES GET IN THE WAY OF CORRECTNESS
3937 ; BY SETTING THE SHALLOW BINDING WE MANAGE TO CLOBBER THE TOP LEVEL LVAL
3938 ; EVEN IF WE ARE SETTING WITH RESPECT TO A DIFFERENT FRAME. TO CORRECT
3939 ; THIS GLITCH THIS ACTIVITY WILL ONLY TAKE PLACE IF THE ATOM ALREADY POINTS
3947 NSHALL: SUB TP,[4,,4]
3951 CAMN PVP,-2(TP) ; SKIP IF PROC DIFFERS
3952 MOVEM C,-2(TP) ; ELSE USE RESULT FROM LOC SEARCH
3953 MOVE B,-2(TP) ; GET PROCESS
3954 HRRZ A,TPBASE+1(B) ;GET ACTUAL STACK BASE
3955 HRRZ B,SPBASE+1(B) ;AND FIRST BINDING
3956 SUB B,A ;ARE THERE 6
3957 CAIL B,6 ;CELLS AVAILABLE?
3959 MOVE C,(TP) ; GET POINTER BACK
3960 MOVEI B,0 ; LOOK FOR EMPTY SLOT
3962 CAMN A,$TUNBOUND ; SKIP IF FOUND
3964 MOVE E,1(AB) ; GET ATOM
3965 MOVEM E,-1(B) ; AND STORE
3967 BSET1: MOVE B,-2(TP) ; GET PROCESS
3968 ; PUSH TP,TPBASE(B) ;NO -- GROW THE TP
3969 ; PUSH TP,TPBASE+1(B) ;AT THE BASE END
3975 ; MOVE C,-2(TP) ; GET PROCESS
3976 ; MOVEM A,TPBASE(C) ;SAVE RESULT
3977 PUSH P,0 ; MANUALLY GROW VECTOR
3986 DPB D,[001100,,-1(C)]
3987 MOVE C,[5,,3] ; SET UP INDICATORS FOR AGC
3990 MOVE B,TPBASE+1(PVP) ; MODIFY POINTER
3991 MOVE 0,LVLINC ; ADJUST SPBASE POINTER
3996 MOVEM B,TPBASE+1(PVP)
3999 ; MOVEM B,TPBASE+1(C)
4000 SETIT: MOVE C,-2(TP) ; GET PROCESS
4002 MOVEI A,-6(B) ;MAKE UP BINDING
4003 HRRM A,(B) ;LINK PREVIOUS BIND BLOCK
4011 BSET2: MOVE C,-2(TP) ; GET PROC
4014 HLRZ D,OTBSAV(TB) ; TIME IT
4015 MOVEM D,2(B) ; AND FIX IT
4018 ; HERE TO ELABORATE ON TYPE MISMATCH
4020 TYPMI2: MOVE C,(TP) ; FIND DECLS
4024 MOVE 0,(AB) ; GET ATOM
4032 GETYP A,(AB) ; GET TYPE
4033 CAIE A,TFALSE ;IS IT FALSE?
4034 JRST IFALSE ;NO -- RETURN FALSE
4037 MOVSI A,TATOM ;RETURN T (VERITAS)
4046 MFUNCTION ANDA,FSUBR,AND
4052 JRST WRONGT ;IF ARG DOESN'T CHECK OUT
4054 SKIPN C,1(AB) ;IF NIL
4055 JRST TF(E) ;RETURN TRUTH
4056 PUSH TP,$TLIST ;CREATE UNNAMED TEMP
4060 JUMPE C,TFI(E) ;ANY MORE ARGS?
4061 MOVEM C,1(TB) ;STORE CRUFT
4065 PUSH TP,1(C) ;ARGUMENT
4071 JRST FINIS ;IF FALSE -- RETURN
4072 HRRZ C,@1(TB) ;GET CDR OF ARGLIST
4081 TFSKP: CAIE 0,TFALSE
4084 IMFUNCTION FUNCTION,FSUBR
4092 \f;SUBR VERSIONS OF AND/OR
4094 MFUNCTION ANDP,SUBR,[AND?]
4096 MOVE C,[CAIN 0,TFALSE]
4099 MFUNCTION ORP,SUBR,[OR?]
4101 MOVE C,[CAIE 0,TFALSE]
4102 BOOL: HLRE A,AB ; GET ARG COUNTER
4104 ASH A,-1 ; DIVIDES BY 2
4109 CANDP: SKIPA C,[CAIN 0,TFALSE]
4110 CORP: MOVE C,[CAIE 0,TFALSE]
4115 SUBB TP,D ; POINT TO ARGS & FIXUP TP PTR
4116 AOBJP D,.+1 ; FIXUP ARG PTR AND FALL INTO CBOOL
4120 JRST CBOOL1 ; YES RETURN IT
4122 SOJG A,CBOOL ; ANY MORE ?
4123 SUB D,[2,,2] ; NO, USE LAST
4129 CNOARG: MOVSI 0,TFALSE
4135 CNOAND: MOVSI A,TATOM
4140 MFUNCTION CLOSURE,SUBR
4142 SKIPL A,AB ;ANY ARGS
4143 JRST TFA ;NO -- LOSE
4144 ADD A,[2,,2] ;POINT AT IDS
4147 PUSH P,[0] ;MAKE COUNTER
4149 CLOLP: SKIPL A,1(TB) ;ANY MORE IDS?
4150 JRST CLODON ;NO -- LOSE
4151 PUSH TP,(A) ;SAVE ID
4153 PUSH TP,(A) ;GET ITS VALUE
4155 ADD A,[2,,2] ;BUMP POINTER
4161 MCALL 2,LIST ;MAKE PAIR
4167 ACALL A,LIST ;MAKE UP LIST
4168 PUSH TP,(AB) ;GET FUNCTION
4172 MCALL 2,LIST ;MAKE LIST
4178 ;ERROR COMMENTS FOR EVAL
4180 BADNUM: ERRUUO EQUOTE NEGATIVE-ARGUMENT
4182 WTY1TP: ERRUUO EQUOTE FIRST-ARG-WRONG-TYPE
4184 UNBOU: PUSH TP,$TATOM
4185 PUSH TP,EQUOTE UNBOUND-VARIABLE
4188 UNAS: PUSH TP,$TATOM
4189 PUSH TP,EQUOTE UNASSIGNED-VARIABLE
4193 ERRUUO EQUOTE BAD-ENVIRONMENT
4196 ERRUUO EQUOTE BAD-FUNARG
4213 MPD: ERRUUO EQUOTE MEANINGLESS-PARAMETER-DECLARATION
4215 NOBODY: ERRUUO EQUOTE HAS-EMPTY-BODY
4217 BADCLS: ERRUUO EQUOTE BAD-CLAUSE
4219 NXTAG: ERRUUO EQUOTE NON-EXISTENT-TAG
4221 NXPRG: ERRUUO EQUOTE NOT-IN-PROG
4224 NAPT: ERRUUO EQUOTE NON-APPLICABLE-TYPE
4226 NONEVT: ERRUUO EQUOTE NON-EVALUATEABLE-TYPE
4229 NONATM: ERRUUO EQUOTE NON-ATOMIC-ARGUMENT
4232 ILLFRA: ERRUUO EQUOTE FRAME-NO-LONGER-EXISTS
4234 ILLSEG: ERRUUO EQUOTE ILLEGAL-SEGMENT
4236 BADMAC: ERRUUO EQUOTE BAD-USE-OF-MACRO
4238 BADFSB: ERRUUO EQUOTE APPLY-OR-STACKFORM-OF-FSUBR
4241 ER1ARG: PUSH TP,(AB)