1 TITLE EVAL -- MUDDLE EVALUATOR
5 ; GERALD JAY SUSSMAN, 1971. REWRITTEN MANY TIMES SINCE C. REEVE (1972--1974)
8 .GLOBAL BINDID,LPROG,GLOBSP,GLOBASE,SPBASE,TPBASE,PTIME,SWAP,CHFRAM
9 .GLOBAL IGVAL,CHKARG,NXTDCL,TPOVFL,CHFRM,PROCHK,CHFSWP,VECBOT,TYPSGR
10 .GLOBAL ILVAL,ER1ARG,SPECBIND,MAKACT,SPECSTORE,MAKTUP,TPALOC,IBIND,SSPECS
11 .GLOBAL IDVAL,EVECTO,EUVECT,CHARGS,BCKTRK,CELL,ILOC,IGLOC,CHKDCL,SSPEC1
12 .GLOBAL PDLBUF,MESS,FACTI,CHKARG,MAKENV,PSTAT,BNDV,UNBOU,UNAS,IGDECL
13 .GLOBAL 1STEPR,SEGMNT,SEGLST,NAPT,EVTYPE,EVATYP,APTYPE,APLTYP,APLQ,IDVAL1
14 .GLOBAL TESTR,VALG,TYPG,INCR1,TMATCH,TYPMIS,SAT,MAKACT,NTPALO,SPECBND
15 .GLOBAL TPGROW,CHKAB,TYPSEG,NXTLM,MONCH0,CHFINI,RMONC0,IMPURIFY,ICONS,INCONS
16 .GLOBAL CILVAL,CISET,CIGVAL,CSETG,MAPPLY,CLLOC,CGLOC,CASSQ,CGASSQ,CBOUND
17 .GLOBAL IIGLOC,CHUNW,IUNWIN,UNWIN2,SPCCHK,CURFCN,TMPLNT,TD.LNT,TBINIT
18 .GLOBAL SPECBE,BSETG,GLOTOP,CANDP,CORP,TFA,TMA,DSTORE,PVSTOR,SPSTOR
19 .GLOBAL AGC,GVLINC,LVLINC,CGBOUN,IEVECT,MAKTU2,STOSTR,HIBOT,POPUNW,ISTRUC
27 ; ENTRY TO EXPAND A MACRO
34 MOVEI A,PVLNT*2+1(PVP)
50 SKIPE C,1STEPR+1(PVP) ; BEING 1 STEPPED?
51 JRST 1STEPI ; YES HANDLE
52 EVALON: HLRZ A,AB ;GET NUMBER OF ARGS
54 JRST AEVAL ;EVAL WITH AN ALIST
55 SEVAL: GETYP A,(AB) ;GET TYPE OF ARG
56 SKIPE C,EVATYP+1 ; USER TYPE TABLE?
58 SEVAL1: CAIG A,NUMPRI ;PRIMITIVE?
59 JRST SEVAL2 ;YES-DISPATCH
61 SELF: MOVE A,(AB) ;TYPES WHICH EVALUATE
63 JRST EFINIS ;TO SELF-EG NUMBERS
65 SEVAL2: HRRO A,EVTYPE(A)
68 ; HERE FOR USER EVAL DISPATCH
70 EVDISP: ADDI C,(A) ; POINT TO SLOT
72 SKIPE (C) ; SKIP EITHER A LOSER OR JRST DISP
73 JRST EVDIS1 ; APPLY EVALUATOR
74 SKIPN C,1(C) ; GET ADDR OR GO TO PURE DISP
82 MCALL 2,APPLY ; APPLY HACKER TO OBJECT
88 IF2,SELFS==400000,,SELF
90 DISTBL EVTYPE,SELFS,[[TFORM,EVFORM],[TLIST,EVLIST],[TVEC,EVECT],[TUVEC,EUVEC]
94 ;WATCH FOR SUBTLE BUG 43 LERR,LPROG OR BINDID
96 CAIE A,-4 ;EXACTLY 2 ARGS?
98 GETYP A,2(AB) ;CHECK THAT WE HAVE A FRAME
103 JRST TRYPRO ; COULD BE PROCESS
104 MOVEI B,2(AB) ; POINT TO FRAME
105 AEVAL2: PUSHJ P,CHENV ; HACK ENVIRONMENT CHANGE
109 AEVAL3: HRRZ 0,FSAV(TB)
114 TRYPRO: CAIE A,TPVP ; SKIP IF IT IS A PROCESS
116 MOVE C,3(AB) ; GET PROCESS
117 CAMN C,PVSTOR ; DIFFERENT FROM ME?
118 JRST SEVAL ; NO, NORMAL EVAL WINS
119 MOVE B,SPSTO+1(C) ; GET SP FOR PROCESS
120 MOVE D,TBSTO+1(C) ; GET TOP FRAME
121 HLL D,OTBSAV(D) ; TIME IT
122 MOVEI C,PVLNT*2+1(C) ; CONS UP POINTER TO PROC DOPE WORD
123 HRLI C,TFRAME ; LOOK LIK E A FRAME
124 PUSHJ P,SWITSP ; SPLICE ENVIRONMENT
127 ; ROUTINE TO CHANGE LOOK UP PATH FOR BINDINGS
129 CHENV: PUSHJ P,CHFRM ; CHECK OUT FRAME
130 MOVE C,(B) ; POINT TO PROCESS
131 MOVE D,1(B) ; GET TB POINTER FROM FRAME
132 CAMN SP,SPSAV(D) ; CHANGE?
133 POPJ P, ; NO, JUST RET
134 MOVE B,SPSAV(D) ; GET SP OF INTEREST
135 SWITSP: MOVSI 0,TSKIP ; SET UP SKIP
136 HRRI 0,1(TP) ; POINT TO UNBIND PATH
138 ADD A,[BINDID,,BINDID] ; BIND THE BINDING ID
144 MOVE E,TP ; FOR SPECBIND
147 PUSH TP,C ; SAVE PROCESS
149 PUSHJ P,SPECBE ; BIND BINDID
150 MOVE SP,TP ; GET NEW SP
151 SUB SP,[3,,3] ; SET UP SP FORK
156 ; HERE TO EVALUATE A FORM (99% OF EVAL'S WORK)
158 EVFORM: SKIPN C,1(AB) ; EMPTY FORM, RETURN FALSE
160 GETYP A,(C) ; 1ST ELEMENT OF FORM
162 JRST EV0 ; NO, EVALUATE IT
163 MOVE B,1(C) ; GET ATOM
164 PUSHJ P,IGVAL ; GET ITS GLOBAL VALUE
166 ; SPECIAL HACK TO SPEED UP LVAL AND GVAL CALLS
170 JRST ATMVAL ; FAST ATOM VALUE
173 CAIE 0,TUNBOU ; BOUND?
174 JRST IAPPLY ; YES APPLY IT
176 MOVE C,1(AB) ; LOOK FOR LOCAL
181 JRST IAPPLY ; WIN, GO APPLY IT
184 PUSH TP,EQUOTE UNBOUND-VARIABLE
186 MOVE C,1(AB) ; FORM BACK
189 PUSH TP,IMQUOTE VALUE
190 MCALL 3,ERROR ; REPORT THE ERROR
193 EFALSE: MOVSI A,TFALSE ; SPECIAL FALSE FOR EVAL OF EMPTY FORM
197 ATMVAL: HRRZ D,(C) ; CDR THE FORM
198 HRRZ 0,(D) ; AND AGAIN
200 GETYP 0,(D) ; MAKE SURE APPLYING TO ATOM
203 MOVEI E,IGVAL ; ASSUME GLOBAAL
204 CAIE B,GVAL ; SKIP IF OK
205 MOVEI E,ILVAL ; ELSE USE LOCAL
207 MOVE B,(D)+1 ; CLR BUG #1637 (GET THE ATOM FOR THE SUBR)
208 PUSHJ P,(E) ; AND GET VALUE
210 JRST EFINIS ; RETURN FROM EVAL
212 MOVSI A,TSUBR ; CAUSE REAL SUBR TO GET EROR
215 ; HERE FOR 1ST ELEMENT NOT A FORM
217 EV0: PUSHJ P,FASTEV ; EVAL IT
219 ; HERE TO APPLY THINGS IN FORMS
221 IAPPLY: PUSH TP,(AB) ; SAVE THE FORM
224 PUSH TP,B ; SAVE THE APPLIER
225 PUSH TP,$TFIX ; AND THE ARG GETTER
227 PUSHJ P,APLDIS ; GO TO INTERNAL APPLIER
228 JRST EFINIS ; LEAVE EVAL
230 ; HERE TO EVAL 1ST ELEMENT OF A FORM
232 FASTEV: MOVE PVP,PVSTOR+1
233 SKIPE 1STEPR+1(PVP) ; BEING 1 STEPPED?
234 JRST EV02 ; YES, LET LOSER SEE THIS EVAL
235 GETYP A,(C) ; GET TYPE
236 SKIPE D,EVATYP+1 ; USER TABLE?
237 JRST EV01 ; YES, HACK IT
238 EV03: CAIG A,NUMPRI ; SKIP IF SELF
239 SKIPA A,EVTYPE(A) ; GET DISPATCH
240 MOVEI A,SELF ; USE SLEF
242 EV04: CAIE A,SELF ; IF EVAL'S TO SELF, JUST USE IT
251 JSP E,CHKAB ; CHECK DEFERS
254 EV01: ADDI D,(A) ; POINT TO SLOT OF USER EVAL TABLE
256 SKIPE (D) ; EITHER NOT GIVEN OR SIMPLE
258 SKIPN 1(D) ; SKIP IF SIMPLE
259 JRST EV03 ; NOT GIVEN
264 HLLZS (TP) ; FIX UP LH
271 ; MAPF/MAPR CALL TO APPLY
277 ; APPLY, FALLS INTO EVAL'S APPLY CODE AT APLDIS
279 IMFUNCTION APPLY,SUBR
283 JUMPGE AB,TFA ; MUST BE AT LEAST 1 ARGUMENT
288 PUSH TP,(AB) ; SAVE FCN
290 PUSH TP,$TFIX ; AND ARG GETTER
291 PUSH TP,[SETZ APLARG]
295 ; STACKFROM, ALSO FALLS INTO EVAL'S APPLIER AT APLDIS
297 IMFUNCTION STACKFORM,FSUBR
304 MOVEI A,3 ; CHECK ALL GOODIES SUPPLIED
311 HRRZ C,1(AB) ; GET LIST BACK
312 PUSHJ P,FASTEV ; DO A FAST EVALUATION
314 HRRZ C,@1(AB) ; POINT TO ARG GETTING FORMS
319 PUSH TP,[SETZ EVALRG]
324 ; OFFSETS FOR TEMPORARIES ETC. USED IN APPLYING STUFF
326 E.FRM==0 ; POINTS TO FORM BEING EVALED (OR ARGS FOR APPLY STACKFORM)
327 E.FCN==2 ; FUNCTION/SUBR/RSUBR BEING APPLIED
328 E.ARG==4 ; POINTS TO ARG GETTING ROUTINE (<0 => MUST EVAL ARGS)
329 E.EXTR==6 ; CONTAINS 1ST ARG IN USER APPLY CASE
330 E.SEG==10 ; POINTS TO SEGMENT IN FORM BEING HACKED
331 E.CNT==12 ; COUNTER FOR TUPLES OF ARGS
332 E.DECL==14 ; POINTS TO DECLARATION LIST IN FUNCTIONS
333 E.ARGL==16 ; POINTS TO ARG LIST IN FUNCTIONS
334 E.HEW==20 ; POINTS TO HEWITT ATOM IF IT EXISTS
336 E.VAL==E.ARGL ; VALUE TYPE FOR RSUBRS
338 MINTM==E.EXTR+2 ; MIN # OF TEMPS EVER ALLOCATED
339 E.TSUB==E.CNT+2 ; # OF TEMPS FOR SUBR/NUMBER APPLICATION
340 XP.TMP==E.HEW-E.EXTR ; # EXTRA TEMPS FOR FUNCTION APPLICATION
341 R.TMP==4 ; TEMPS AFTER ARGS ARE BOUND
342 TM.OFF==E.HEW+2-R.TMP ; TEMPS TO FLUSH AFTER BIND OF ARGS
344 RE.FCN==0 ; AFTER BINDING CONTAINS FCN BODY
345 RE.ARG==2 ; ARG LIST AFTER BINDING
347 ; GENERAL THING APPLYER
349 APLDIS: PUSH TP,[0] ; SLOT USED FOR USER APPLYERS
351 APLDIX: GETYP A,E.FCN(TB) ; GET TYPE
353 APLDI: SKIPE D,APLTYP+1 ; USER TABLE EXISTS?
354 JRST APLDI1 ; YES, USE IT
355 APLDI2: CAILE A,NUMPRI ; SKIP IF NOT PRIM
360 APLDI1: ADDI D,(A) ; POINT TO SLOT
362 SKIPE (D) ; SKIP IF NOT GIVEN OR STANDARD
364 APLDI4: SKIPE D,1(D) ; GET DISP
366 JRST APLDI2 ; USE SYSTEM DISPATCH
368 APLDI3: SKIPE E.EXTR+1(TB) ; SKIP IF HAVEN'T BEEN HERE BEFORE
370 MOVE A,(D) ; GET ITS HANDLER
371 EXCH A,E.FCN(TB) ; AND USE AS FCN
372 MOVEM A,E.EXTR(TB) ; SAVE
375 MOVEM A,E.EXTR+1(TB) ; STASH OLD FCN AS EXTRG
376 GETYP A,(D) ; GET TYPE
380 ; APPLY DISPATCH TABLE
382 DISTBL APTYPE,<SETZ NAPTL>,[[TSUBR,APSUBR],[TFSUBR,APFSUB],[TRSUBR,APRSUB],[TFIX,APNUM]
383 [TEXPR,APEXPR],[TFUNAR,APFUNARG],[TENTER,APENTR],[TMACRO,APMACR],[TOFFS,APNUM]]
\f
385 ; SUBR TO SAY IF TYPE IS APPLICABLE
387 MFUNCTION APPLIC,SUBR,[APPLICABLE?]
396 ; HERE TO DETERMINE IF A TYPE IS APPLICABLE
400 JRST USEPUR ; USE PURE TABLE
402 ADDI B,(A) ; POINT TO SLOT
403 SKIPG 1(B) ; SKIP IF WINNER
404 SKIPE (B) ; SKIP IF POTENIAL LOSER
406 SKIPE 1(B) ; SKIP IF MUST USE PURE TABBLE
408 USEPUR: CAILE A,NUMPRI ; SKIP IF NOT PRIM
410 SKIPL APTYPE(A) ; SKIP IF APLLICABLE
418 SKIPN E.EXTR(TB) ; IF EXTRA ARG
419 SKIPGE E.ARG+1(TB) ; OR APPLY/STACKFORM, LOSE
421 MOVE A,E.FCN+1(TB) ; GET FCN
422 HRRZ C,@E.FRM+1(TB) ; GET ARG LIST
423 SUB TP,[MINTM,,MINTM] ; FLUSH UNWANTED TEMPS
425 PUSH TP,C ; ARG TO STACK
426 .MCALL 1,(A) ; AND CALL
432 PUSHJ P,PSH4ZR ; SET UP ZEROED SLOTS
434 AOS E.CNT(TB) ; INDICATES IF MUST EVAL ARGS
435 MOVSI A,400000 ; MAKE SURE OF GOOD INDIRECT
437 SKIPN A,E.EXTR(TB) ; FUNNY ARGS
439 MOVE B,E.EXTR+1(TB) ; YES , GET VAL
440 JRST APSUB2 ; AND FALL IN
442 APSUB1: PUSHJ P,@E.ARG+1(TB) ; EAT AN ARG
446 AOS E.CNT+1(TB) ; COUNT IT
449 APSUBD: MOVE A,E.CNT+1(TB) ; FINISHED, GET COUNT
450 MOVE B,E.FCN+1(TB) ; AND SUBR
454 PUSHJ P,BLTDN ; FLUSH CRUFT
458 BLTDN: MOVEI C,(TB) ; POINT TO DEST
459 HRLI C,E.TSUB(C) ; AND SOURCE
460 BLT C,-E.TSUB(TP) ;BL..............T
461 SUB TP,[E.TSUB,,E.TSUB]
464 APENDN: PUSHJ P,BLTDN
468 ; FLAGS FOR RSUBR HACKER
475 ; APPLY OBJECTS OF TYPE RSUBR
479 MOVE C,E.FCN+1(TB) ; GET THE RSUBR
480 CAML C,[-5,,] ; IS IT LONG ENOUGH FOR DECLS
481 JRST APSUBR ; NO TREAT AS A SUBR
482 GETYP 0,4(C) ; GET TYPE OF 3D ELEMENT
483 CAIE 0,TDECL ; DECLARATION?
484 JRST APSUBR ; NO, TREAT AS SUBR
485 PUSHJ P,PSH4ZR ; ALLOCATE SOME EXTRA ROOM
486 PUSH TP,$TDECL ; PUSH UP THE DECLS
488 PUSH TP,$TLOSE ; SAVE ROOM FOR VAL DECL
491 AOS E.CNT(TB) ; INDICATES IF MUST EVAL ARGS
492 MOVSI A,400000 ; MAKE SURE OF GOOD INDIRECT
495 SKIPN E.EXTR(TB) ; "EXTRA" ARG?
497 MOVE 0,[SETZ EXTRGT] ; CHANGE THE ACCESS FCN
499 HRRM 0,E.ARG(TB) ; REMEMBER IT
501 APRSU1: MOVEI 0,0 ; INIT FLAG REGISTER
504 APRSU2: HRRZ A,E.DECL+1(TB) ; GET DECL LIST
505 JUMPE A,APRSU3 ; DONE!
508 PUSHJ P,NXTDCL ; IS NEXT THING A STRING?
509 JRST APRSU4 ; NO, BETTER BE A TYPE
510 CAMN B,[ASCII /VALUE/]
511 JRST RSBVAL ; SAVE VAL DECL
512 TRON 0,F.NFST ; IF NOT FIRST, LOSE
513 CAME B,[ASCII /CALL/] ; CALL DECL
515 SKIPE E.CNT(TB) ; LEGAL?
518 MOVE D,E.FRM+1(TB) ; GET FORM
519 JRST APRS10 ; HACK IT
521 APRSU5: TROE 0,F.STR ; STRING STRING?
523 CAMN B,[<ASCII /OPT/>]
525 CAME B,[<ASCII /OPTIO/>+1] ; OPTIONA?
527 TROE 0,F.OPT ; CHECK AND SET
528 JRST MPD ; OPTINAL OPTIONAL LOSES
529 JRST APRSU2 ; TO MAIN LOOP
531 APRSU7: CAME B,[ASCII /QUOTE/]
534 TROE 0,F.QUO ; TURN ON AND CHECK QUOTE
535 JRST MPD ; QUOTE QUOTE LOSES
536 JRST APRSU2 ; GO TO END OF LOOP
539 APRSU8: CAME B,[ASCII /ARGS/]
541 SKIPE E.CNT(TB) ; SKIP IF LEGAL
543 HRRZ D,@E.FRM+1(TB) ; GET ARG LIST
546 APRS10: HRRZ A,(A) ; GET THE DECL
547 MOVEM A,E.DECL+1(TB) ; CLOBBER
548 HRRZ B,(A) ; CHECK FOR TOO MUCH
550 MOVE B,1(A) ; GET DECL
551 HLLZ A,(A) ; GOT THE DECL
552 MOVEM 0,(P) ; SAVE FLAGS
553 JSP E,CHKAB ; CHECK DEFER
558 AOS E.CNT+1(TB) ; COUNT ARG
559 JRST APRDON ; GO CALL RSUBR
561 RSBVAL: HRRZ A,E.DECL+1(TB) ; GET DECL
563 HRRZ B,(A) ; POINT TO DECL
564 MOVEM B,E.DECL+1(TB) ; SAVE NEW DECL POINTER
568 MOVEM A,E.VAL+1(TB) ; SAVE VAL DECL
570 MOVEM A,E.VAL(TB) ; SET ITS TYPE
574 APRSU9: CAME B,[ASCII /TUPLE/]
576 MOVEM 0,(P) ; SAVE FLAGS
577 HRRZ A,(A) ; CDR DECLS
581 PUSH P,[0] ; COUNT ELEMENTS IN TUPLE
583 APRTUP: PUSHJ P,@E.ARG+1(TB) ; GOBBLE ARGS
590 APRTPD: POP P,C ; GET COUNT
591 ADDM C,E.CNT+1(TB) ; UPDATE MAIN COUNT
593 HRLI C,TINFO ; BUILD FENCE POST
595 PUSHJ P,TBTOTP ; GEN REL OFFSET TO TOP
597 HRROI D,-1(TP) ; POINT TO TOP
600 MOVSI C,TARGS ; BUILD TYPE WORD
604 HLLZ A,(A) ; TYPE/VAL
606 PUSHJ P,TMATCH ; GOTO TYPE CHECKER
609 SUB TP,[2,,2] ; REMOVE FENCE POST
611 APRDON: SUB P,[1,,1] ; FLUSH CRUFT
612 MOVE A,E.CNT+1(TB) ; GET # OF ARGS
614 GETYP 0,E.FCN(TB) ; COULD BE ENTRY
615 MOVEI C,(TB) ; PREPARE TO BLT DOWN
618 SUB TP,[E.TSUB+2,,E.TSUB+2]
621 .ACALL A,(B) ; CALL THE RSUBR
630 APRSU4: MOVEM 0,(P) ; SAVE FLAGS
631 MOVE B,1(A) ; GET DECL
634 MOVE 0,(P) ; RESTORE FLAGS
637 SKIPE E.CNT(TB) ; ALREADY EVAL'D
640 JRST APREVA ; MUST EVAL ARG
642 HRRZ C,@E.FRM+1(TB) ; GET ARG?
643 TRNE 0,F.OPT ; OPTIONAL
645 JUMPE C,TFA ; NO, TOO FEW ARGS
649 JSP E,CHKAB ; CHECK THEM
651 APRTYC: MOVE C,A ; SET UP FOR TMATCH
654 EXCH A,-1(TP) ; SAVE STUFF
655 APRS11: PUSHJ P,TMATCH ; CHECK TYPE
658 MOVE 0,(P) ; RESTORE FLAGS
661 JRST APRSU2 ; AND GO ON
663 APREV0: TRNE 0,F.QUO ; ATTEMPT TO QUOTE ALREADY EVAL'D ARG ?
665 APREVA: PUSHJ P,@E.ARG+1(TB) ; EVAL ONE
666 TDZA C,C ; C=0 ==> NONE LEFT
669 JUMPN C,APRTYC ; GO CHECK TYPE
670 APRDN: SUB TP,[2,,2] ; FLUSH DECL
671 TRNE 0,F.OPT ; OPTIONAL?
672 JRST APRDON ; ALL DONE
675 APRSU3: TRNE 0,F.STR ; END IN STRING?
\b
677 PUSHJ P,@E.ARG+1(TB) ; SEE IF ANYMORE ARGS
682 ; STANDARD ARGUMENT GETTERS USED IN APPLYING THINGS
684 ARGCDR: HRRZ C,@E.FRM+1(TB) ; POINT TO ARGLIST (NOTE: POINTS 1 BEFORE WHERE ARG IS)
685 JUMPE C,CPOPJ ; LEAVE IF DONE
687 GETYP 0,(C) ; GET TYPE OF ARG
689 JRST ARGCD1 ; SEG MENT HACK
693 ARGCD1: PUSH TP,$TFORM ; PRETEND WE ARE A FORM
698 PUSHJ P,TYPSEG ; GET SEG TYPE CODE
699 HRRM C,E.ARG(TB) ; SAVE IT IN OBSCCURE PLACE
700 MOVE C,DSTORE ; FIX FOR TEMPLATE
703 MOVEM C,E.ARG+1(TB) ; SET NEW ARG GETTER
708 HRRZ C,E.ARG(TB) ; SEG CODE TO C
712 PUSHJ P,NXTLM ; GET NEXT ELEMENT
715 MOVE D,DSTORE ; KEEP TYPE WINNING
722 HRRM C,E.ARG+1(TB) ; RESET ARG GETTER
725 ; ARGUMENT GETTER FOR APPLY
728 SKIPL A,E.FRM+1(TB) ; ANY ARGS LEFT
729 POPJ P, ; NO, EXIT IMMEDIATELY
732 MOVE B,-1(A) ; RET NEXT ARG
736 ; STACKFORM ARG GETTER
738 EVALRG: SKIPN C,@E.FRM+1(TB) ; ANY FORM?
741 GETYP A,A ; CHECK FOR FALSE
744 MOVE C,E.FRM+1(TB) ; GET OTHER FORM
749 ; HERE TO APPLY NUMBERS
751 APNUM: PUSHJ P,PSH4ZR ; TP SLOTS
752 SKIPN A,E.EXTR(TB) ; FUNNY ARG?
754 MOVE B,E.EXTR+1(TB) ; GET ARG
757 APNUM1: PUSHJ P,@E.ARG+1(TB) ; GET ARG
766 PUSHJ P,BLTDN ; FLUSH JUNK
769 ; HACK FOR TURNING <3 .FOO .BAR> INTO <PUT .FOO 3 .BAR>
777 PUSHJ P,ISTRUC ; STRUCTURED FIRST ARG?
782 ; HERE TO APPLY SUSSMAN FUNARGS
788 HRRZ D,(C) ; MUST BE AT LEAST 2 LONG
790 GETYP 0,(D) ; CHECK FOR LIST
793 HRRZ 0,(D) ; SHOULD BE END
795 GETYP 0,(C) ; 1ST MUST BE FCN
800 PUSHJ P,APEXPF ; BIND THE ARGS AND AUX'S
801 HRRZ C,RE.FCN+1(TB) ; GET BODY OF FUNARG
802 MOVE B,1(C) ; GET FCN
803 MOVEM B,RE.FCN+1(TB) ; AND SAVE
804 HRRZ C,(C) ; CDR FUNARG BODY
806 MOVSI 0,TLIST ; SET UP TYPE
808 MOVEM 0,CSTO(PVP) ; FOR INTS TO WIN
813 CAIE 0,TLIST ; BETTER BE LIST
817 PUSHJ P,NEXTDC ; GET POSSIBILITY
821 HRRZ B,(B) ; GET TO VALUE
828 JSP E,CHKAB ; HACK DEFER
829 PUSHJ P,PSHAB4 ; PUT VAL IN
835 DOF: MOVE PVP,PVSTOR+1
836 SETZM CSTO(PVP) ; DONT CONFUSE GC
837 PUSHJ P,SPECBIND ; BIND 'EM UP
844 APMACR: HRRZ E,OTBSAV(TB)
845 HRRZ D,PCSAV(E) ; SEE WHERE FROM
846 CAIE D,EFCALL+1 ; 1STEP
850 CAIN D,AEVAL3 ; SKIP IF NOT RIGHT
852 SKIPG E.ARG+1(TB) ; SKIP IF REAL FORM EXISTS
856 SUB TP,[E.EXTR+2,,E.EXTR+2] ; FLUSH JUNK
859 MCALL 1,EXPAND ; EXPAND THE MACRO
862 MCALL 1,EVAL ; EVAL THE RESULT
865 APMAC1: MOVE C,E.FCN+1(TB) ; GET MACRO BODY
869 JSP E,CHKAB ; FIX DEFERS
874 ; HERE TO APPLY EXPRS (FUNCTIONS)
876 APEXPR: PUSHJ P,APEXP ; BIND ARGS AND AUX'S
877 RUNFUN: HRRZ A,RE.FCN(TB) ; AMOUNT OF FCN TO SKIP
878 MOVEI C,RE.FCN+1(TB) ; POINT TO FCN
879 HRRZ C,(C) ; SKIP SOMETHING
880 SOJGE A,.-1 ; UNTIL 1ST FORM
881 MOVEM C,RE.FCN+1(TB) ; AND STORE
882 JRST DOPROG ; GO RUN PROGRAM
884 APEXP: SKIPN C,E.FCN+1(TB) ; CHECK FRO BODY
886 APEXPF: PUSH P,[0] ; COUNT INIT CRAP
887 ADD TP,[XP.TMP,,XP.TMP] ; SLOTS FOR HACKING
890 SETZM 1-XP.TMP(TP) ; ZERO OUT
891 MOVEI A,-XP.TMP+2(TP)
893 BLT A,(TP) ; ZERO SLOTS
895 AOS E.CNT(TB) ; INDICATES IF MUST EVAL ARGS
896 MOVSI A,400000 ; MAKE E.ARG BE NEG FOR SAFE @ING
898 PUSHJ P,CARATC ; SEE IF HEWITT ATOM EXISTS
899 JRST APEXP1 ; NO, GO LOOK FOR ARGLIST
900 MOVEM E,E.HEW+1(TB) ; SAVE ATOM
901 MOVSM 0,E.HEW(TB) ; AND TYPE
902 AOS (P) ; COUNT HEWITT ATOM
903 APEXP1: GETYP 0,(C) ; LOOK AT NEXT THING
904 CAIE 0,TLIST ; BETTER BE LIST!!!
906 MOVE B,1(C) ; GET LIST
907 MOVEM B,E.ARGL+1(TB) ; SAVE
908 MOVSM 0,E.ARGL(TB) ; WITH TYPE
909 HRRZ C,(C) ; CDR THE FCN
910 JUMPE C,NOBODY ; BODYLESS FCN
911 GETYP 0,(C) ; SEE IF DCL LIST SUPPLIED
913 JRST APEXP2 ; NO, START PROCESSING ARGS
921 ; CHECK FOR EXISTANCE OF EXTRA ARG
923 APEXP2: POP P,A ; GET COUNT
924 HRRM A,E.FCN(TB) ; AND SAVE
925 SKIPN E.EXTR(TB) ; SKIP IF FUNNY EXTRA ARG EXISTS
929 HRRM 0,E.ARG(TB) ; SAVE OLD GETTER AROUND
934 ; LOOK FOR "BIND" DECLARATION
936 APEXP3: PUSHJ P,UNPROG ; UNASSIGN LPROG IF NEC
937 APXP3A: SKIPN A,E.ARGL+1(TB) ; GET ARGLIST
938 JRST APEXP4 ; NONE, VERIFY NONE WERE GIVEN
939 PUSHJ P,NXTDCL ; SEE IF A DECL IS THERE
940 JRST BNDRG ; NO, GO BIND NORMAL ARGS
941 HRRZ C,(A) ; CDR THE DCLS
942 CAME B,[ASCII /BIND/]
943 JRST CH.CAL ; GO LOOK FOR "CALL"
944 PUSHJ P,CARTMC ; MUST BE AN ATOM
945 MOVEM C,E.ARGL+1(TB) ; AND SAVE CDR'D ARGS
946 PUSHJ P,MAKENV ; GENERATE AN ENVIRONMENT
947 PUSHJ P,PSBND1 ; PUSH THE BINDING AND CHECK THE DCL
948 JRST APXP3A ; IN CASE <"BIND" B "BIND" C......
951 ; LOOK FOR "CALL" DCL
953 CH.CAL: CAME B,[ASCII /CALL/]
954 JRST CHOPT ; TRY SOMETHING ELSE
955 ; SKIPG E.ARG+1(TB) ; DONT SKIP IF CANT WIN
958 PUSHJ P,CARTMC ; BETTER BE AN ATOM
960 MOVE A,E.FRM(TB) ; RETURN FORM
962 PUSHJ P,PSBND1 ; BIND AND CHECK
965 ; BIND NORMAL ARGS BY CALLING BNDEM1, RETURNS WHEN ALL DONE
967 BNDRG: PUSHJ P,BNDEM1 ; GO BIND THEM UP
968 TRNN A,4 ; SKIP IF HIT A DCL
969 JRST APEXP4 ; NOT A DCL, MUST BE DONE
971 ; LOOK FOR "OPTIONAL" DECLARATION
973 CHOPT: CAMN B,[<ASCII /OPT/>]
975 CAME B,[<ASCII /OPTIO/>+1]
976 JRST CHREST ; TRY TUPLE/ARGS
977 MOVEM C,E.ARGL+1(TB) ; SAVE RESTED ARGLIST
978 PUSHJ P,BNDEM2 ; DO ALL SUPPLIED OPTIONALS
979 TRNN A,4 ; SKIP IF NEW DCL READ
982 ; CHECK FOR "ARGS" DCL
984 CHREST: CAME B,[ASCII /ARGS/]
985 JRST CHRST1 ; GO LOOK FOR "TUPLE"
986 ; SKIPGE E.ARG+1(TB) ; SKIP IF LEGAL
989 PUSHJ P,CARTMC ; GOBBLE ATOM
990 MOVEM C,E.ARGL+1(TB) ; SAVE CDR'D ARG
991 HRRZ B,@E.FRM+1(TB) ; GET ARG LIST
992 MOVSI A,TLIST ; GET TYPE
996 ; HERE TO CHECK FOR "TUPLE"
998 CHRST1: CAME B,[ASCII /TUPLE/]
1000 PUSHJ P,CARTMC ; GOBBLE ATOM
1001 MOVEM C,E.ARGL+1(TB)
1003 PUSHJ P,PSHBND ; SET UP BINDING
1004 SETZM E.CNT+1(TB) ; ZERO ARG COUNTER
1006 TUPLP: PUSHJ P,@E.ARG+1(TB) ; GET AN ARG
1013 TUPDON: PUSHJ P,MAKINF ; MAKE INFO CELL
1014 PUSH TP,$TINFO ; FENCE POST TUPLE
1016 ADDI D,TM.OFF ; COMPENSATE FOR MOVEMENT
1018 MOVE C,E.CNT+1(TB) ; GET COUNT
1020 HRRM C,-1(TP) ; INTO FENCE POST
1021 MOVEI B,-TM.OFF-1(TP) ; SETUP ARG POINTER
1022 SUBI B,(C) ; POINT TO BASE OF TUPLE
1023 MOVNS C ; FOR AOBJN POINTER
1024 HRLI B,(C) ; GOOD ARGS POINTER
1025 MOVEM A,TM.OFF-4(B) ; STORE
1029 ; CHECK FOR VALID ENDING TO ARGS
1031 APEXP5: PUSHJ P,NEXTD ; READ NEXT THING IN ARGLIST
1033 TRNN A,4 ; SKIP IF DCL
1035 APEXP7: MOVSI A,-NWINS ; CHECK FOR A WINNER
1038 JUMPGE A,MPD.6 ; NOT A WINNER
1040 ; HERE TO BLT THE WORLD DOWN ON TOP OF ALL THE USELESS TEMPS
1042 APEXP8: MOVE 0,E.HEW+1(TB) ; GET HEWITT ATOM
1043 MOVE E,E.FCN(TB) ; SAVE COUNTER
1044 MOVE C,E.FCN+1(TB) ; FCN
1045 MOVE B,E.ARGL+1(TB) ; ARG LIST
1046 MOVE D,E.DECL+1(TB) ; AND DCLS
1047 MOVEI A,R.TMP(TB) ; SET UP BLT
1049 BLT A,-TM.OFF(TP) ; BLLLLLLLLLLLLLT
1050 SUB TP,[TM.OFF,,TM.OFF] ; FLUSH CRUFT
1052 MOVEM C,RE.FCN+1(TB)
1053 MOVEM B,RE.ARGL+1(TB)
1059 GETYP A,-5(TP) ; TUPLE ON TOP?
1060 CAIE A,TINFO ; SKIP IF YES
1062 HRRZ A,-5(TP) ; GET SIZE
1065 SUB E,A ; POINT TO BINDINGS
1066 SKIPE C,(TP) ; IF DCL
1067 PUSHJ P,CHKDCL ; CHECK TYPE SPEC ON TUPLE
1068 APEXP9: PUSHJ P,USPCBE ; DO ACTUAL BINDING
1070 MOVE E,-2(TP) ; RESTORE HEWITT ATOM
1071 MOVE D,(TP) ; AND DCLS
1074 JRST AUXBND ; GO BIND AUX'S
1076 ; HERE TO VERIFY CHECK IF ANY ARGS LEFT
1078 APEXP4: PUSHJ P,@E.ARG+1(TB)
1080 JRST TMA ; TOO MANY ARGS
1083 PUSHJ P,@E.ARG+1(TB)
1089 ; LIST OF POSSIBLE TERMINATING NAMES
1093 AS.NAM: ASCII /NAME/
1095 AS.EXT: ASCII /EXTRA/
1099 ; HERE TO BIND AUX VARIABLES FOR PROGS AND FCNS
1101 AUXBND: PUSH P,E ; SAVE HEWITT ATOM ( WILL PUT ON MARKED STACK
1103 PUSH P,D ; SAME WITH DCL LIST
1104 PUSH P,[-1] ; FLAG SAYING WE ARE FCN
1105 SKIPN C,RE.ARG+1(TB) ; GET ARG LIST
1107 GETYP 0,(C) ; GET TYPE
1108 CAIE 0,TDEFER ; SKIP IF CHSTR
1109 MOVMS (P) ; SAY WE ARE IN OPTIONALS
1114 PUSH P,[0] ; WE ARE IN AUXS
1116 AUXB1: HRRZ C,RE.ARG+1(TB) ; POINT TO ARGLIST
1117 PUSHJ P,NEXTDC ; GET NEXT THING OFF OF ARG LIST
1119 TRNE A,4 ; SKIP IF SOME KIND OF ATOM
1120 JRST TRYDCL ; COUDL BE DCL
1121 TRNN A,1 ; SKIP IF QUOTED
1123 SKIPN (P) ; SKIP IF QUOTED OK
1125 AUXB2: PUSHJ P,PSHBND ; SET UP BINDING
1126 PUSH TP,$TATOM ; SAVE HEWITT ATOM
1128 PUSH TP,$TDECL ; AND DECLS
1130 TRNN A,2 ; SKIP IF INIT VAL EXISTS
1131 JRST AUXB3 ; NO, USE UNBOUND
1133 ; EVALUATE EXPRESSION
1135 HRRZ C,(B) ; CDR ATOM OFF
1137 ; CHECK FOR SPECIAL FORMS <TUPLE ...> <ITUPLE ...>
1139 GETYP 0,(C) ; GET TYPE OF GOODIE
1140 CAIE 0,TFORM ; SMELLS LIKE A FORM
1142 HRRZ D,1(C) ; GET 1ST ELEMENT
1143 GETYP 0,(D) ; AND ITS VAL
1144 CAIE 0,TATOM ; FEELS LIKE THE RIGHT FORM
1147 MOVE 0,1(D) ; GET THE ATOM
1148 CAME 0,IMQUOTE TUPLE
1149 CAMN 0,MQUOTE ITUPLE
1150 JRST DOTUPL ; SURE GLAD I DIDN'T STEP IN THAT FORM
1153 AUXB13: PUSHJ P,FASTEV
1155 AUXB4: MOVEM A,-7(E) ; STORE VAL IN BINDING
1158 ; HERE TO CHECK AGAINST DECLARATIONS AND COMPLETE THE BINDING
1160 AUXB5: SUB E,[4,,4] ; POINT TO BINDING TOP
1161 SKIPE C,-2(TP) ; POINT TO DECLARATINS
1162 PUSHJ P,CHKDCL ; CHECK IT
1163 PUSHJ P,USPCBE ; AND BIND UP
1164 SKIPE C,RE.ARG+1(TB) ; CDR DCLS
1165 HRRZ C,(C) ; IF ANY TO CDR
1166 MOVEM C,RE.ARG+1(TB)
1167 MOVE A,(TP) ; NOW PUT HEWITT ATOM AND DCL AWAY
1171 SUB TP,[4,,4] ; FLUSH SLOTS
1181 ; HERE TO HANDLE "CALLS" TO TUPLE AND ITUPLE
1183 DOTUPL: SKIPE E,(P) ; SKIP IF IN AUX LIST
1185 PUSH TP,$TLIST ; SAVE THE MAGIC FORM
1187 CAME 0,IMQUOTE TUPLE
1188 JRST DOITUP ; DO AN ITUPLE
1190 ; FALL INTO A TUPLE PUSHING LOOP
1192 DOTUP1: HRRZ C,@(TP) ; CDR THE FORM
1193 JUMPE C,ATUPDN ; FINISHED
1194 MOVEM C,(TP) ; SAVE CDR'D RESULT
1195 GETYP 0,(C) ; CHECK FOR SEGMENT
1197 JRST DTPSEG ; GO PULL IT APART
1198 PUSHJ P,FASTEV ; EVAL IT
1199 PUSHJ P,CNTARG ; PUSH IT UP AND COUNT THEM
1202 ; HERE WHEN WE FINISH
1204 ATUPDN: SUB TP,[2,,2] ; FLUSH THE LIST
1205 ASH E,1 ; E HAS # OF ARGS DOUBLE IT
1206 MOVEI D,(TP) ; FIND BASE OF STACK AREA
1208 MOVSI C,-3(D) ; PREPARE BLT POINTER
1209 BLT C,C ; HEWITT ATOM AND DECL TO 0,A,B,C
1211 ; NOW PREPEARE TO BLT TUPLE DOWN
1213 MOVEI D,-3(D) ; NEW DEST
1214 HRLI D,4(D) ; SOURCE
1215 BLT D,-4(TP) ; SLURP THEM DOWN
1217 HRLI E,TINFO ; SET UP FENCE POST
1218 MOVEM E,-3(TP) ; AND STORE
1219 PUSHJ P,TBTOTP ; GET OFFSET
1220 ADDI D,3 ; FUDGE FOR NOT AT TOP OF STACK
1222 MOVEM 0,-1(TP) ; RESTORE HEW ATOM AND DECLS
1227 PUSHJ P,MAKINF ; MAKE 1ST WORD OF FUNNYS
1229 HRRZ E,-5(TP) ; RESTORE WORDS OF TUPLE
1230 HRROI B,-5(TP) ; POINT TO TOP OF TUPLE
1231 SUBI B,(E) ; NOW BASE
1232 TLC B,-1(E) ; FIX UP AOBJN PNTR
1233 ADDI E,2 ; COPNESATE FOR FENCE PST
1235 SUBM TP,E ; E POINT TO BINDING
1236 JRST AUXB4 ; GO CLOBBER IT IN
1239 ; HERE TO HANDLE SEGMENTS IN THESE FUNNY FORMS
1241 DTPSEG: PUSH TP,$TFORM ; SAVE THE HACKER
1243 MCALL 1,EVAL ; AND EVALUATE IT
1244 MOVE D,B ; GET READY FOR A SEG LOOP
1246 PUSHJ P,TYPSEG ; TYPE AND CHECK IT
1248 DTPSG1: INTGO ; DONT BLOW YOUR STACK
1249 PUSHJ P,NXTLM ; ELEMENT TO A AND B
1251 PUSHJ P,CNTARG ; PUSH AND COUNT
1254 DTPSG2: SETZM DSTORE
1255 HRRZ E,-1(TP) ; GET COUNT IN CASE END
1256 JRST DOTUP1 ; REST OF ARGS STILL TO DO
1258 ; HERE TO HACK <ITUPLE .....>
1260 DOITUP: HRRZ C,@(TP) ; GET COUNT FILED
1263 PUSHJ P,FASTEV ; EVAL IT
1270 HRRZ C,@(TP) ; GET EXP TO EVAL
1271 MOVEI 0,0 ; DONT LOSE IN 1 ARG CASE
1272 HRRZ 0,(C) ; VERIFY WINNAGE
1273 JUMPN 0,TMA ; TOO MANY
1276 PUSH P,B ; SAVE COUNT
1279 PUSHJ P,FASTEV ; EVAL IT ONCE
1291 DOIDO1: MOVE B,-1(P) ; RESTORE COUNT
1297 ; FOR CASE OF NO EVALE
1299 DOILOS: SUB TP,[2,,2]
1307 ; ROUTINE TO PUSH NEXT TUPLE ELEMENT
1309 CNTARG: AOS E,-1(TP) ; KEEP ARG COUNT UP TO DATE IN E
1310 CNTRG: EXCH A,-1(TP) ; STORE ELEM AND GET SAVED
1317 ; DUMMY TUPLE AND ITUPLE
1319 IMFUNCTION TUPLE,SUBR
1322 ERRUUO EQUOTE NOT-IN-AUX-LIST
1324 MFUNCTIO ITUPLE,SUBR
1328 ; PROCESS A DCL IN THE AUX VAR LISTS
1330 TRYDCL: SKIPN (P) ; SKIP IF NOT IN AUX'S
1332 CAME B,AS.AUX ; "AUX" ?
1333 CAMN B,AS.EXT ; OR "EXTRA"
1335 CAME B,[ASCII /TUPLE/]
1337 PUSHJ P,MAKINF ; BUILD EMPTY TUPLE
1339 PUSH TP,$TINFO ; FENCE POST
1342 AUXB6: HRRZ C,(C) ; CDR PAST DCL
1343 MOVEM C,RE.ARG+1(TB)
1344 AUXB8: PUSHJ P,CARTMC ; GET ATOM
1345 AUXB12: PUSHJ P,PSHBND ; UP GOES THE BINDING
1346 PUSH TP,$TATOM ; HIDE HEWITT ATOM AND DCL
1355 AUXB10: CAME B,[ASCII /ARGS/]
1357 MOVEI B,0 ; NULL ARG LIST
1359 JRST AUXB6 ; GO BIND
1361 AUXB9: SETZM (P) ; NOW READING AUX
1363 MOVEM C,RE.ARG+1(TB)
1366 ; CHECK FOR NAME/ACT
1368 AUXB7: CAME B,AS.NAM
1373 HRRZ 0,(C) ; BETTER BE END
1375 PUSHJ P,CARTMC ; FORCE ATOM READ
1377 AUXB11: PUSHJ P,MAKACT ; MAKE ACTIVATION
1378 JRST AUXB12 ; AND BIND IT
1381 ; DONE BIND HEWITT ATOM IF NECESARY
1383 AUXDON: SKIPN E,-2(P)
1394 ; MAKE AN ACTIVATION OR ENVIRONMNENT
1396 MAKACT: MOVEI B,(TB)
1398 MAKAC1: MOVE PVP,PVSTOR+1
1399 HRRI A,PVLNT*2+1(PVP) ; POINT TO PROCESS
1400 HLL B,OTBSAV(B) ; GET TIME
1403 MAKENV: MOVSI A,TENV
1407 ; SEVERAL USEFUL LITTLE ROUTINES FOR HACKING THIS STUFF
1409 ; CARAT/CARATC/CARATM/CARTMC ALL LOOK FOR THE NEXT ATOM
1411 CARAT: HRRZ C,E.ARGL+1(TB) ; PICK UP ARGLIST
1412 CARATC: JUMPE C,CPOPJ ; FOUND
1413 GETYP 0,(C) ; GET ITS TYPE
1415 CPOPJ: POPJ P, ; RETURN, NOT ATOM
1416 MOVE E,1(C) ; GET ATOM
1417 HRRZ C,(C) ; CDR DCLS
1420 CARATM: HRRZ C,E.ARGL+1(TB)
1421 CARTMC: PUSHJ P,CARATC
1422 JRST MPD.7 ; REALLY LOSE
1426 ; SUBROUTINES TO PUSH BINDINGS ETC. UP ON THE STACK
1428 PSBND1: PUSHJ P,PSHBND ; PUSH THEBINDING
1429 JRST CHDCL ; NOW CHECK IT AGAINST DECLARATION
1431 PSHBND: SKIPGE SPCCHK ; SKIP IF NORMAL SPECIAL
1432 PUSH TP,BNDA1 ; ATOM IN E
1433 SKIPL SPCCHK ; SKIP IF NORMAL UNSPEC OR NO CHECK
1442 ; ROUTINE TO PUSH 4 0'S
1448 ; EXTRRA ARG GOBBLER
1450 EXTRGT: HRRZ A,E.ARG(TB) ; RESET SLOT
1452 CAIE A,ARGCDR ; IF NOT ARGCDR
1454 TLO A,400000 ; SET FLAG
1456 MOVE A,E.EXTR(TB) ; RET ARG
1460 ; CHECK A/B FOR DEFER
1463 CAIE 0,TDEFER ; SKIP IF DEFER
1466 MOVE B,1(B) ; GET REAL THING
1468 ; IF DECLARATIONS EXIST, DO THEM
1471 CHDCLE: SKIPN C,E.DECL+1(TB)
1475 ; ROUTINE TO READ NEXT THING FROM ARGLIST
1477 NEXTD: HRRZ C,E.ARGL+1(TB) ; GET ARG LIST
1480 PUSHJ P,CARATC ; TRY FOR AN ATOM
1484 NEXTD1: CAIE 0,TFORM ; FORM?
1485 JRST NXT.L ; COULD BE LIST
1486 PUSHJ P,CHQT ; VERIFY 'ATOM
1490 NXT.L: CAIE 0,TLIST ; COULD BE (A <EXPRESS>) OR ('A <EXPRESS>)
1491 JRST NXT.S ; BETTER BE A DCL
1492 PUSHJ P,LNT.2 ; VERIFY LENGTH IS 2
1494 CAIE 0,TATOM ; TYPE OF 1ST RET IN 0
1495 JRST LST.QT ; MAY BE 'ATOM
1496 MOVE E,1(B) ; GET ATOM
1499 LST.QT: CAIE 0,TFORM ; FORM?
1502 MOVEI C,(B) ; VERIFY 'ATOM
1504 MOVEI B,(C) ; POINT BACK TO LIST
1509 NXT.S: MOVEI A,(C) ; LET NXTDCL FIND OUT
1512 MOVEI A,4 ; SET DCL READ FLAG
1515 ; ROUTINE TO CHECK LENGTH OF LIST/FORM FOR BEING 2
1517 LNT.2: HRRZ B,1(C) ; GET LIST/FORM
1521 HRRZ B,(B) ; BETTER END HERE
1523 HRRZ B,1(C) ; LIST BACK
1524 GETYP 0,(B) ; TYPE OF 1ST ELEMENT
1527 ; ROUTINE TO VERIFY FORM IS 'ATOM AND RET ATOM
1529 CHQT: PUSHJ P,LNT.2 ; 1ST LENGTH CHECK
1534 CAME 0,IMQUOTE QUOTE
1535 JRST MPD.5 ; BETTER BE QUOTE
1540 MOVE E,1(E) ; GET QUOTED ATOM
1543 ; ARG BINDER FOR REGULAR ARGS AND OPTIONALS
1545 BNDEM1: PUSH P,[0] ; REGULAR FLAG
1548 BNDEM: PUSHJ P,NEXTD ; GET NEXT THING
1549 JRST CCPOPJ ; END OF THINGS
1550 TRNE A,4 ; CHECK FOR DCL
1552 TRNE A,2 ; SKIP IF NOT (ATM ..) OR ('ATM ...)
1553 SKIPE (P) ; SKIP IF REG ARGS
1554 JRST .+2 ; WINNER, GO ON
1557 PUSH TP,BNDA1 ; SAVE ATOM
1561 ; SKIPGE E.ARG+1(TB) ; ALREADY EVAL'D ARG?
1564 TRNN A,1 ; SKIP IF ARG QUOTED
1566 HRRZ D,@E.FRM+1(TB) ; GET AND CDR ARG
1567 JUMPE D,TFACHK ; OH OH MAYBE TOO FEW ARGS
1568 MOVEM D,E.FRM+1(TB) ; STORE WINNER
1569 HLLZ A,(D) ; GET ARG
1571 JSP E,CHKAB ; HACK DEFER
1572 JRST BNDEM3 ; AND GO ON
1574 RGLAR0: TRNE A,1 ; ATTEMPT TO QUOTE ALREADY EVAL'D ARG ?
1575 JRST MPD ; YES, LOSE
1576 RGLARG: PUSH P,A ; SAVE FLAGS
1577 PUSHJ P,@E.ARG+1(TB)
1578 JRST TFACH1 ; MAY GE TOO FEW
1580 BNDEM3: HRRZ C,@E.ARGL+1(TB) ; CDR THHE ARGS
1581 MOVEM C,E.ARGL+1(TB)
1582 PUSHJ P,PSHAB4 ; PUSH VALUE AND SLOTS
1583 PUSHJ P,CHDCL ; CHECK DCLS
1584 JRST BNDEM ; AND BIND ON!
1586 ; HERE WHEN ARGS RUN OUT, IF NOT OPTIONAL, GIVE TFA
1589 TFACHK: SUB TP,[2,,2] ; FLUSH ATOM
1590 SKIPN (P) ; SKIP IF OPTIONALS
1592 CCPOPJ: SUB P,[1,,1]
1595 BNDEM4: HRRZ C,@E.ARGL+1(TB) ; POINT TO REST OF ARGL
1599 ; EVALUATE LISTS, VECTORS, UNIFROM VECTORS
1601 EVLIST: PUSH P,[-1] ;-1 -- THIS IS A LIST
1602 JRST EVL1 ;GO TO HACKER
1604 EVECT: PUSH P,[0] ;0 -- THIS IS A GENERAL VECTOR
1607 EUVEC: PUSH P,[1] ;1 -- THIS IS A UNIFORM VECTOR
1609 EVL1: PUSH P,[0] ;PUSH A COUNTER
1610 GETYPF A,(AB) ;GET FULL TYPE
1612 PUSH TP,1(AB) ;AND VALUE
1614 EVL2: INTGO ;CHECK INTERRUPTS
1615 SKIPN A,1(TB) ;ANYMORE
1617 SKIPL -1(P) ;SKIP IF LIST
1618 JUMPG A,EVL3 ;JUMP IF VECTOR EMPTY
1619 GETYPF B,(A) ;GET FULL TYPE
1620 SKIPGE C,-1(P) ;SKIP IF NOT LIST
1621 HLLZS B ;CLOBBER CDR FIELD
1622 JUMPG C,EVL7 ;HACK UNIFORM VECS
1623 EVL8: PUSH P,B ;SAVE TYPE WORD ON P
1624 CAMN B,$TSEG ;SEGMENT?
1625 MOVSI B,TFORM ;FAKE OUT EVAL
1626 PUSH TP,B ;PUSH TYPE
1627 PUSH TP,1(A) ;AND VALUE
1628 JSP E,CHKARG ; CHECK DEFER
1629 MCALL 1,EVAL ;AND EVAL IT
1630 POP P,C ;AND RESTORE REAL TYPE
1631 CAMN C,$TSEG ;SEGMENT?
1632 JRST DOSEG ;YES, HACK IT
1633 AOS (P) ;COUNT ELEMENT
1634 PUSH TP,A ;AND PUSH IT
1636 EVL6: SKIPGE A,-1(P) ;DONT SKIP IF LIST
1637 HRRZ B,@1(TB) ;CDR IT
1638 JUMPL A,ASTOTB ;AND STORE IT
1639 MOVE B,1(TB) ;GET VECTOR POINTER
1640 ADD B,AMNT(A) ;INCR BY APPROPRIATE AMOUNT
1641 ASTOTB: MOVEM B,1(TB) ;AND STORE BACK
1642 JRST EVL2 ;AND LOOP BACK
1644 AMNT: 2,,2 ;INCR FOR GENERAL VECTOR
1645 1,,1 ;SAME FOR UNIFORM VECTOR
1647 CHKARG: GETYP A,-1(TP)
1650 HRRZS (TP) ;MAKE SURE INDIRECT WINS
1652 MOVEM A,-1(TP) ;CLOBBER IN TYPE SLOT
1653 MOVE A,(TP) ;NOW GET POINTER
1654 MOVE A,1(A) ;GET VALUE
1655 MOVEM A,(TP) ;CLOBBER IN
1660 EVL7: HLRE C,A ; FIND TYPE OF UVECTOR
1661 SUBM A,C ;C POINTS TO DOPE WORD
1662 GETYP B,(C) ;GET TYPE
1663 MOVSI B,(B) ;TO LH NOW
1664 SOJA A,EVL8 ;AND RETURN TO DO EVAL
1666 EVL3: SKIPL -1(P) ;SKIP IF LIST
1667 JRST EVL4 ;EITHER VECTOR OR UVECTOR
1669 MOVEI B,0 ;GET A NIL
1670 EVL9: MOVSI A,TLIST ;MAKE TYPE WIN
1671 EVL5: SOSGE (P) ;COUNT DOWN
1672 JRST EVL10 ;DONE, RETURN
1673 PUSH TP,$TLIST ;SET TO CALL CONS
1676 JRST EVL5 ;LOOP TIL DONE
1679 EVL4: MOVEI B,EUVECT ;UNIFORM CASE
1680 SKIPG -1(P) ;SKIP IF UNIFORM CASE
1681 MOVEI B,EVECTO ;NO, GENERAL CASE
1683 .ACALL A,(B) ;CALL CREATOR
1684 EVL10: GETYPF A,(AB) ; USE SENT TYPE
1688 ; PROCESS SEGMENTS FOR THESE HACKS
1690 DOSEG: PUSHJ P,TYPSEG ; FIND WHAT IS BEING SEGMENTED
1691 JUMPE C,LSTSEG ; CHECK END SPLICE IF LIST
1693 SEG3: PUSHJ P,NXTELM ; GET THE NEXTE ELEMT
1694 JRST SEG4 ; RETURN TO CALLER
1696 JRST SEG3 ; TRY AGAIN
1700 TYPSEG: PUSHJ P,TYPSGR
1704 TYPSGR: MOVE E,A ; SAVE TYPE
1705 GETYP A,A ; TYPE TO RH
1706 PUSHJ P,SAT ;GET STORAGE TYPE
1707 MOVE D,B ; GOODIE TO D
1709 MOVNI C,1 ; C <0 IF ILLEGAL
1710 CAIN A,S2WORD ;LIST?
1712 CAIN A,S2NWORD ;GENERAL VECTOR?
1714 CAIN A,SNWORD ;UNIFORM VECTOR?
1720 CAIN A,SSTORE ;SPECIAL AFREE STORAGE ?
1721 MOVEI C,4 ;TREAT LIKE A UVECTOR
1722 CAIN A,SARGS ;ARGS TUPLE?
1723 JRST SEGARG ;NO, ERROR
1724 CAILE A,NUMSAT ; SKIP IF NOT TEMPLATE
1728 MOVEI A,2 ; NOW TREAT LIKE A UVECTOR
1730 MSTOR1: JUMPL C,CPOPJ
1732 MDSTOR: MOVEM E,DSTORE
1739 SEGARG: MOVSI A,TARGS
1741 PUSH TP,A ;PREPARE TO CHECK ARGS
1743 MOVEI B,-1(TP) ;POINT TO SAVED COPY
1744 PUSHJ P,CHARGS ;CHECK ARG POINTER
1745 POP TP,D ;AND RESTORE WINNER
1746 POP TP,E ;AND TYPE AND FALL INTO VECTOR CODE
1750 LSTSEG: SKIPL -1(P) ;SKIP IF IN A LIST
1751 JRST SEG3 ;ELSE JOIN COMMON CODE
1752 HRRZ A,@1(TB) ;CHECK FOR END OF LIST
1753 JUMPN A,SEG3 ;NO, JOIN COMMON CODE
1754 SETZM DSTORE ;CLOBBER SAVED GOODIES
1755 JRST EVL9 ;AND FINISH UP
1758 PUSHJ P,NXTLM ; GOODIE TO A AND B
1763 NXTLM: XCT TESTR(C) ; SKIP IF MORE IN SEGEMNT
1765 XCT TYPG(C) ; GET THE TYPE
1766 XCT VALG(C) ; AND VALUE
1767 JSP E,CHKAB ; CHECK DEFERRED
1768 XCT INCR1(C) ; AND INCREMENT TO NEXT
1769 CPOPJ1: AOS (P) ; SKIP RETURN
1772 ; TABLES FOR SEGMENT OPERATIONS (0->LIST, 1->VECTOR/ARGS, 2->UVEC, 3->STRING)
1788 TYPG: PUSHJ P,LISTYP
1811 HRRZ A,DSTORE ; GET SAT
1816 HLRZ 0,C ; GET AMNT RESTED
1831 MOVEI C,0 ; GET "1ST ELEMENT"
1832 PUSHJ P,TMPLNT ; GET NTH IN A AND B
1838 CHRDON: HRRZ B,DSTORE
1840 HRRZ B,DSTORE ; POIT TO DOPE WORD
1868 ;COMPILER's CALL TO DOSEG
1869 SEGMNT: PUSHJ P,TYPSEG
1871 SEGLOP: PUSHJ P,NXTELM
1873 AOS (P)-2 ; INCREMENT COMPILER'S COUNT
1876 SEGRET: SETZM DSTORE
1879 SEGLST: PUSHJ P,TYPSEG
1881 SEGLS3: SETZM DSTORE
1883 SEGLS1: SOSGE -2(P) ; START COUNT DOWN
1891 SEGLS2: PUSHJ P,NXTELM
1900 ;SPECBIND BINDS IDENTIFIERS. IT IS CALLED BY PUSHJ P,SPECBIND.
1901 ;SPECBIND IS PROVIDED WITH A CONTIGUOUS SET OF TRIPLETS ON TP.
1902 ;EACH TRIPLET IS AS FOLLOWS:
1903 ;THE FIRST ELEMENT IS THE IDENTIFIER TO BE BOUND, ITS TYPE WORD IS [TATOM,,-1],
1904 ;THE SECOND IS THE VALUE TO WHICH IT IS TO BE ASSIGNED,
1905 ;AND THE THIRD IS A PAIR OF ZEROES.
1913 USPCBE: PUSH P,$TUBIND
1917 MOVE E,TP ;GET THE POINTER TO TOP
1918 SPECBE: PUSH P,$TBIND
1919 ADD E,[1,,1] ;BUMP POINTER ONCE
1920 SETZB 0,D ;CLEAR TEMPS
1922 MOVEI 0,(TB) ; FOR CHECKS
1924 BINDLP: MOVE A,-4(E) ; CHECK FOR VEC BIND
1927 MOVE A,-6(E) ;GET TYPE
1928 CAME A,BNDA1 ; FOR UNSPECIAL
1929 CAMN A,BNDA ;NORMAL ID BIND?
1930 CAILE 0,-6(E) ; MAKE SURE NOT GOING UNDER FRAME
1932 SUB E,[6,,6] ;MOVE PTR
1934 HRRM E,(D) ;YES -- LOBBER
1936 MOVEM E,(P) ;NO -- DO IT
1938 MOVE A,0(E) ;GET ATOM PTR
1940 PUSHJ P,SILOC ;GET LAST BINDING
1941 MOVS A,OTBSAV (TB) ;GET TIME
1942 HRL A,5(E) ; GET DECL POINTER
1943 MOVEM A,4(E) ;CLOBBER IT AWAY
1944 MOVE A,(E) ; SEE IF SPEC/UNSPEC
1945 TRNN A,1 ; SKIP, ALWAYS SPEC
1946 SKIPA A,-1(P) ; USE SUPPLIED
1948 MOVEM A,(E) ;IDENTIFY AS BIND BLOCK
1951 HRRZ C,SPBASE(PVP) ; CHECK FOR CROSS OF PROC
1954 CAILE C,(B) ; SKIP IFF WINNER
1956 SPEB10: MOVEM B,5(E) ;IN RESTORE CELLS
1958 MOVE C,1(E) ;GET ATOM PTR
1962 MOVEI B,0 ; FOR SPCUNP
1963 CAIL A,HIBOT ; SKIP IF IMPURE ATOM
1966 HRRZ A,BINDID+1(PVP) ;GET PROCESS NUMBER
1967 HRLI A,TLOCI ;MAKE LOC PTR
1968 MOVE B,E ;TO NEW VALUE
1970 MOVEM A,(C) ;CLOBBER ITS VALUE
1972 MOVE D,E ;REMEMBER LINK
1973 JRST BINDLP ;DO NEXT
1975 NONID: CAILE 0,-4(E)
1983 MOVE D,1(E) ;GET PTR TO VECTOR
1984 MOVE C,(D) ;EXCHANGE TYPES
1988 MOVE C,1(D) ;EXCHANGE DATUMS
1993 HRLM A,(E) ;IDENTIFY BIND BLOCK
1994 MOVE D,E ;REMEMBER LINK
2006 ; HERE TO IMPURIFY THE ATOM
2008 SPCUNP: PUSH TP,$TSP
2011 PUSH TP,-1(P) ; LINK BACK IS AN SP
2015 SETZM -1(TP) ; FIXUP SOME FUNNYNESS
2018 MOVE 0,-2(TP) ; RESTORE LINK BACK POINTER
2027 ; ENTRY FROM COMPILER TO SET UP A BINDING
2029 IBIND: MOVE SP,SPSTOR+1
2030 SUBI E,-5(SP) ; CHANGE TO PDL POINTER
2041 JRST SPECB1 ; NOW BIND IT
2043 ; "FAST CALL TO SPECBIND"
2047 ; Compiler's call to SPECBIND all atom bindings, no TBVLs etc.
2050 MOVE E,TP ; POINT TO BINDING WITH E
2051 SPECB1: PUSH P,[0] ; SLOTS OF INTEREST
2055 SPECB2: MOVEI 0,(TB) ; FOR FRAME CHECK
2056 MOVE A,-5(E) ; LOOK AT FIRST THING
2057 CAMN A,BNDA ; SKIP IF LOSER
2058 CAILE 0,-5(E) ; SKIP IF REAL WINNER
2061 SUB E,[5,,5] ; POINT TO BINDING
2063 HRRM E,(A) ; YES DO IT
2064 SKIPN -1(P) ; FIRST ONE?
2065 MOVEM E,-1(P) ; THIS IS IT
2067 MOVE A,1(E) ; POINT TO ATOM
2069 MOVE 0,BINDID+1(PVP) ; QUICK CHECK
2071 CAMN 0,(A) ; WINNERE?
2072 JRST SPECB4 ; YES, GO ON
2074 PUSH P,B ; SAVE REST OF ACS
2077 MOVE B,A ; FOR ILOC TO WORK
2078 PUSHJ P,SILOC ; GO LOOK IT UP
2081 HRRZ C,SPBASE+1(PVP)
2083 CAIL A,(B) ; SKIP IF LOSER
2084 CAILE C,(B) ; SKIP IF WINNER
2085 MOVEI B,1 ; SAY NO BACK POINTER
2086 SPECB9: MOVE C,1(E) ; POINT TO ATOM
2087 SKIPE (C) ; IF GLOBALLY BOUND, MAKE SURE OK
2089 MOVEI A,(C) ; PURE ATOM?
2090 CAIGE A,HIBOT ; SKIP IF OK
2092 PUSH P,-4(P) ; MAKE HAPPINESS
2093 PUSHJ P,SPCUNP ; IMPURIFY
2096 MOVE A,BINDID+1(PVP)
2098 MOVEM A,(C) ; STOR POINTER INDICATOR
2105 SPECB4: MOVE A,1(A) ; GET LOCATIVE
2106 SPECB5: EXCH A,5(E) ; CLOBBER INTO REBIND SLOT (GET DECL)
2107 HLL A,OTBSAV(TB) ; TIME IT
2108 MOVSM A,4(E) ; SAVE DECL AND TIME
2110 HRLM A,(E) ; CHANGE TO A BINDING
2111 MOVE A,1(E) ; POINT TO ATOM
2112 MOVEM E,(P) ; REMEMBER THIS GUY
2113 ADD E,[2,,2] ; POINT TO VAL CELL
2114 MOVEM E,1(A) ; INTO ATOM SLOT
2115 SUB E,[3,,3] ; POINT TO NEXT ONE
2120 HRRM SP,(A) ; LINK OLD STUFF
2121 SKIPE A,-1(P) ; NEW SP?
2124 INTGO ; IN CASE BLEW STACK
2129 ;SPECSTORE RESTORES THE BINDINGS SP TO THE ENVIRONMENT POINTER IN
2130 ;SPSAV (TB). IT IS CALLED BY PUSHJ P,SPECSTORE.
2134 HRRZ E,SPSAV (TB) ;GET TARGET POINTER
2137 MOVE SP,SPSAV(TB) ; GET NEW SP
2141 STLOOP: MOVE SP,SPSTOR+1
2145 STLOO1: CAIL E,(SP) ;ARE WE DONE?
2147 HLRZ C,(SP) ;GET TYPE OF BIND
2150 CAIE C,TBIND ;NORMAL IDENTIFIER?
2151 JRST ISTORE ;NO -- SPECIAL HACK
2154 MOVE C,1(SP) ;GET TOP ATOM
2155 MOVSI 0,TLOCI ; MAYBE LOCI OR UNBOUND
2159 HRR 0,BINDID+1(PVP) ;STORE SIGNATURE
2161 MOVEI 0,0 ; TOTALLY UNBOUND IN ALL CASES
2162 MOVEM 0,(C) ;CLOBBER INTO ATOM
2165 SPLP: HRRZ SP,(SP) ;FOLOW LINK
2166 JUMPN SP,STLOO1 ;IF MORE
2169 STLOO2: MOVEM SP,SPSTOR+1
2183 CHSKIP: CAIN C,TSKIP
2185 CAIE C,TUNWIN ; UNWIND HACK
2187 HRRZ C,-2(P) ; WHERE FROM?
2190 MOVEI E,(TP) ; FIXUP SP
2200 ; ENTRY FOR FUNNY COMPILER UNBIND (1)
2207 SSPEC2: SUBI E,(SP) ; MAKE SP BE AOBJN
2217 ; ENTRY FOR FUNNY COMPILER UNBIND (2)
2222 SUBI E,1 ; MAKE SURE GET CURRENT BINDING
2223 PUSHJ P,STLOOP ; UNBIND
2224 MOVEI E,(TP) ; NOW RESET SP
2227 EFINIS: MOVE PVP,PVSTOR+1
2228 SKIPN C,1STEPR+1(PVP) ; SKIP NIF BEING ONE PROCEEDED
2231 PUSH TP,MQUOTE EVLOUT
2232 PUSH TP,A ;SAVE EVAL RESULTS
2234 PUSH TP,[TINFO,,2] ; FENCE POST
2237 PUSHJ P,MAKINF ; MAKE ARG BLOCK INFO
2240 HRLI B,-4 ; AOBJN TO ARGS BLOCK
2244 PUSH TP,1STEPR+1(PVP) ; PROCESS DOING THE 1STEPPING
2246 MOVE A,-3(TP) ; GET BACK EVAL VALUE
2250 1STEPI: PUSH TP,$TATOM
2251 PUSH TP,MQUOTE EVLIN
2252 PUSH TP,$TAB ; PUSH EVALS ARGGS
2254 PUSHJ P,MAKINF ; TURN INTO ARGS BLOCK
2255 MOVEM A,-1(TP) ; AND CLOBBER
2256 PUSH TP,[TINFO,,2] ; FENCE POST 2D TUPLE
2259 PUSHJ P,MAKINF ; TURN IT INTO ARGS BLOCK
2261 MOVEI B,-6(TP) ; SETUP TUPLE
2266 PUSH TP,1STEPR+1(PVP)
2267 MCALL 2,RESUME ; START UP 1STEPERR
2268 SUB TP,[6,,6] ; REMOVE CRUD
2269 GETYP A,A ; GET 1STEPPERS TYPE
2270 CAIE A,TDISMI ; IF DISMISS, STOP 1 STEPPING
2273 ; HERE TO PUSH DOWN THE 1 STEP STATE AND RUN
2276 ADD D,[1STEPR,,1STEPR] ; POINT TO 1 STEP SLOT
2277 PUSH TP,$TSP ; SAVE CURRENT SP
2282 PUSH TP,[0] ; NO 1 STEPPER UNTIL POPJ
2285 ; NOW PUSH THE ARGS UP TO RE-CALL EVAL
2288 EFARGL: JUMPGE AB,EFCALL
2294 EFCALL: ACALL A,EVAL ; NOW DO THE EVAL
2295 MOVE C,(TP) ; PRE-UNBIND
2297 MOVEM C,1STEPR+1(PVP)
2298 MOVE SP,-4(TP) ; AVOID THE UNBIND
2300 SUB TP,[6,,6] ; AND FLUSH LOSERS
2301 JRST EFINIS ; AND TRY TO FINISH UP
2303 MAKINF: HLRZ A,OTBSAV(TB) ; TIME IT
2308 TBTOTP: MOVEI D,(TB) ; COMPUTE REL DIST FROM TP TO TB
2311 ; ARRIVE HERE TO COMPLETE A COMPILER GENERATED TUPLE
2312 ; D/ LENGTH OF THE TUPLE IN WORDS
2314 MAKTU2: MOVE D,-1(P) ; GET LENGTH
2321 MAKTUP: HRLI D,TINFO ; FIRST WORD OF FENCE POST
2323 HRROI B,(TP) ; TOP OF TUPLE
2325 TLC B,-1(D) ; AOBJN IT
2328 HLRZ A,OTBSAV(TB) ; TIME IT
2332 ; HERE TO ALLOCATE SLOTS FOR COMPILER (AMNT IN A)
2335 ;Once here ==>ADDI A,1 Bug???
2340 PUSHJ P,TPOVFL ; IN CASE IT LOST
2341 INTGO ; TAKE THE GC IF NEC
2355 \f;EVALUATES A IDENTIFIER -- GETS LOCAL VALUE IF THERE IS ONE, OTHERWISE GLOBAL.
2357 IMFUNCTION VALUE,SUBR
2362 IDVAL: PUSHJ P,IDVAL1
2368 PUSH TP,B ;SAVE ARG IN CASE NEED TO CHECK GLOBAL VALUE
2369 PUSHJ P,ILVAL ;LOCAL VALUE FINDER
2370 CAME A,$TUNBOUND ;IF NOT UNBOUND OR UNASSIGNED
2371 JRST RIDVAL ;DONE - CLEAN UP AND RETURN
2372 POP TP,B ;GET ARG BACK
2375 RIDVAL: SUB TP,[2,,2]
2378 ;GETS THE LOCAL VALUE OF AN IDENTIFIER
2380 IMFUNCTION LVAL,SUBR
2388 ; MAKE AN ATOM UNASSIGNED
2390 MFUNCTION UNASSIGN,SUBR
2391 JSP E,CHKAT ; GET ATOM ARG
2393 UNASIT: CAMN A,$TUNBOU ; IF UNBOUND
2397 SETOM 1(B) ; MAKE SURE
2398 RETATM: MOVE B,1(AB)
2404 MFUNCTION GUNASSIGN,SUBR
2409 MOVE B,1(AB) ; ATOM BACK
2411 CAIL 0,HIBOT ; SKIP IF IMPURE
2412 PUSHJ P,IMPURIFY ; YES, MAKE IT IMPURE
2413 PUSHJ P,IGLOC ; RESTORE LOCATIVE
2414 HRRZ 0,-2(B) ; SEE IF MANIFEST
2415 GETYP A,(B) ; AND CURRENT TYPE
2424 ; GETS A LOCATIVE TO THE LOCAL VALUE OF AN IDENTIFIER.
2435 ;TESTS TO SEE IF AN IDENTIFIER IS LOCALLY BOUND
2437 MFUNCTION BOUND,SUBR,[BOUND?]
2444 ;TESTS TO SEE IF AN IDENTIFIER IS LOCALLY ASSIGNED
2446 MFUNCTION ASSIGP,SUBR,[ASSIGNED?]
2454 ;GETS THE GLOBAL VALUE OF AN IDENTIFIER
2456 IMFUNCTION GVAL,SUBR
2463 ;GETS A LOCATIVE TO THE GLOBAL VALUE OF AN IDENTIFIER
2465 MFUNCTION RGLOC,SUBR
2490 MOVE C,1(AB) ; GE ATOM
2492 CAIGE 0,HIBOT ; SKIP IF PURE ATOM
2495 ; MAKE ATOM AND VALUE IMPURE IF GETTING GLOC TO IT
2497 MOVE B,C ; ATOM TO B
2499 JRST GLOC ; AND TRY AGAIN
2501 ;TESTS TO SEE IF AN IDENTIFIER IS GLOBALLY ASSIGNED
2503 MFUNCTION GASSIG,SUBR,[GASSIGNED?]
2510 ; TEST FOR GLOBALLY BOUND
2512 MFUNCTION GBOUND,SUBR,[GBOUND?]
2522 CHKAT1: GETYP A,(AB)
2529 CHKAT: HLRE A,AB ; - # OF ARGS
2530 ASH A,-1 ; TO ACTUAL WORDS
2532 MOVE C,SPSTOR+1 ; FOR BINDING LOOKUPS
2533 AOJE A,CHKAT1 ; ONLY ONE ARG, NO ENVIRONMENT
2534 AOJL A,TMA ; TOO MANY
2535 GETYP A,2(AB) ; MAKE SURE OF TENV OR TFRAME
2539 CAIN A,TACT ; FOR PFISTERS LOSSAGE
2541 CAIE A,TPVP ; OR PROCESS
2543 MOVE B,3(AB) ; GET PROCESS
2544 MOVE C,SPSTOR+1 ; IN CASE ITS ME
2545 CAME B,PVSTOR+1 ; SKIP IF DIFFERENT
2546 MOVE C,SPSTO+1(B) ; GET ITS SP
2548 CHKAT3: MOVEI B,2(AB) ; POINT TO FRAME POINTER
2549 PUSHJ P,CHFRM ; VALIDITY CHECK
2550 MOVE B,3(AB) ; GET TB FROM FRAME
2551 MOVE C,SPSAV(B) ; GET ENVIRONMENT POINTER
2555 ; SILOC--CALLS ILOC IGNORING SPECIAL CHECKING
2559 ;ILOC RETURNS IN A AND B A LOCATIVE TO THE LOCAL VALUE OF THE IDENTIFIER
2560 ; PASSED TO IT IN A AND B. IF THE IDENTIFIER IS LOCALLY UNBOUND IT RETURNS
2561 ; $TUNBOUND IN A AND 0 IN B, IT IS CALLED BY PUSHJ P,ILOC.
2563 ILOC: MOVE C,SPSTOR+1 ; SETUP SEARCH START
2564 AILOC: SKIPN (B) ; ANY KIND OF VALUE AT ALL?
2566 MOVSI A,TLOCI ;MAKE A LOCATIVE TYPE CELL
2569 MOVEI E,0 ; FLAG TO CLOBBER ATOM
2570 JUMPE B,SCHSP ; IF LOOKING FOR SLOT, SEARCH NOW
2571 CAME C,SPSTOR+1 ; ENVIRONMENT CHANGE?
2572 JRST SCHSP ; YES, MUST SEARCH
2574 HRR A,BINDID+1(PVP) ;FOR THE CURRENT PROCESS
2575 CAME A,(B) ;IS THERE ONE IN THE VALUE CELL?
2576 JRST SCHLP ;NO -- SEARCH THE LOCAL BINDINGS
2577 MOVE B,1(B) ;YES -- GET LOCATIVE POINTER
2579 ILCPJ: MOVE E,SPCCHK
2580 TRNN E,1 ; SKIP IF DOING SPEC UNSPEC CHECK
2582 HRRZ E,-2(P) ; IF IGNORING, IGNORE
2589 CAMGE B,CURFCN+1(PVP)
2594 CAMGE B,SPBASE+1(PVP)
2599 POPJ P, ;FROM THE VALUE CELL
2611 CAIL D,HIBOT ; SKIP IF IMPURE ATOM
2612 SCHSP: MOVEI E,1 ; DONT STORE LOCATIVE
2614 PUSH P,E ; PUSH SWITCH
2615 MOVE E,PVSTOR+1 ; GET PROC
2616 SCHLP1: JUMPE C,UNPJ ;IF NO MORE -- LOSE
2617 CAMN B,1(C) ;ARE WE POINTING AT THE WINNER?
2619 GETYP D,(C) ; CHECK SKIP
2622 PUSH P,B ; CHECK DETOUR
2624 PUSHJ P,CHFRAM ; NON-FATAL FRAME CHECKER
2625 HRRZ E,2(C) ; CONS UP PROCESS
2628 JUMPE B,SCHLP3 ; LOSER, FIX IT
2630 MOVEI C,1(C) ; FOLLOW LOOKUP CHAIN
2631 SCHLP2: HRRZ C,(C) ;FOLLOW LINK
2636 MOVEI C,(SP) ; *** NDR'S BUG ***
2637 CAME E,PVSTOR+1 ; USE IF CURRENT PROCESS
2638 HRRZ C,SPSTO+1(E) ; USE CURRENT SP FOR PROC
2641 SCHFND: MOVE D,SPCCHK
2642 TRNN D,1 ; SKIP IF DOING SPEC UNSPEC CHECK
2644 HRRZ D,-2(P) ; IF IGNORING, IGNORE
2651 HRRZ D,CURFCN+1(PVP)
2655 HRRZ D,SPBASE+1(PVP)
2660 SCHFN1: EXCH B,C ;SAVE THE ATOM PTR IN C
2661 MOVEI B,2(B) ;MAKE UP THE LOCATIVE
2665 EXCH C,E ; RET PROCESS IN C
2666 POP P,D ; RESTORE SWITCH
2668 JUMPN D,ILOCPJ ; DONT CLOBBER ATOM
2669 MOVEM A,(E) ;CLOBBER IT AWAY INTO THE
2670 MOVE D,1(E) ; GET OLD POINTER
2671 MOVEM B,1(E) ;ATOM'S VALUE CELL
2672 JUMPE D,ILOCPJ ; IF POINTS TO GLOBAL OR OTHER PROCES
2673 ; MAKE SURE BINDING SO INDICATES
2674 MOVE D,B ; POINT TO BINDING
2675 SKIPL E,3(D) ; GO TO FIRST ONE, JUST IN CASE
2678 JRST .-3 ; LOOP THROUGH
2680 MOVEM E,3(D) ; MAGIC INDICATION
2683 UNPJ: SUB P,[1,,1] ; FLUSH CRUFT
2684 UNPJ1: MOVE C,E ; RET PROCESS ANYWAY
2687 UNPOPJ: MOVSI A,TUNBOUND
2691 FUNPJ: MOVE C,PVSTOR+1
2694 ;IGLOC RETURNS IN A AND B A LOCATIVE TO THE GLOBAL VALUE OF THE
2695 ;IDENTIFIER PASSED TO IT IN A AND B. IF THE IDENTIFIER IS GLOBALLY
2696 ;UNBPOUND IT RETURNS $TUNBOUND IN A AND 0 IN B. IT IS CALLED BY PUSHJ P,IGLOC.
2698 IGLOC: MOVSI A,TLOCI ;DO WE HAVE A LOCATIVE TO
2699 CAME A,(B) ;A PROCESS #0 VALUE?
2700 JRST SCHGSP ;NO -- SEARCH
2701 MOVE B,1(B) ;YES -- GET VALUE CELL
2706 MOVE D,GLOBSP+1 ;GET GLOBAL SP PTR
2708 SCHG1: JUMPGE D,UNPOPJ ;IF NO MORE, LEAVE
2709 CAMN B,1(D) ;ARE WE FOUND?
2711 ADD D,[4,,4] ;NO -- TRY NEXT
2715 EXCH B,D ;SAVE ATOM PTR
2716 ADD B,[2,,2] ;MAKE LOCATIVE
2720 MOVEM A,(D) ;CLOBBER IT AWAY
2724 IIGLOC: PUSH TP,$TATOM
2737 PUSHJ P,IMPURI ; IMPURIFY THE POOR ATOM
2738 PUSHJ P,BSETG ; MAKE A SLOT
2739 SETOM 1(B) ; UNBOUNDIFY IT
2748 ;ILVAL RETURNS IN A AND B THE LOCAL VALUE OF THE IDENTIFIER PASSED TO IT IN A AND B
2749 ;IF THE IDENTIFIER IS UNBOUND ITS VALUE IS $TUNBOUND IN A AND 0 IN B. IF
2750 ;IT IS UNASSIGNED ITS VALUE IS $TUNBOUND IN A AND -1 IN B. CALL - PUSHJ P,IVAL
2753 PUSHJ P,AILOC ; USE SUPPLIED SP
2756 PUSHJ P,ILOC ;GET LOCATIVE TO VALUE
2757 CHVAL: CAMN A,$TUNBOUND ;BOUND
2758 POPJ P, ;NO -- RETURN
2759 MOVSI A,TLOCD ; GET GOOD TYPE
2760 HRR A,2(B) ; SHOULD BE TIME OR 0
2762 PUSHJ P,RMONC0 ; CHECK READ MONITOR
2764 MOVE A,(B) ;GET THE TYPE OF THE VALUE
2765 MOVE B,1(B) ;GET DATUM
2768 ;IGVAL -- LIKE ILVAL EXCEPT FOR GLOBAL VALUES
2770 IGVAL: PUSHJ P,IGLOC
2775 ; COMPILERS INTERFACE TO LVAL/GVAL/SETG/SET
2777 CILVAL: MOVE PVP,PVSTOR+1
2778 MOVE 0,BINDID+1(PVP) ; CURRENT BIND
2780 CAME 0,(B) ; HURRAY FOR SPEED
2781 JRST CILVA1 ; TOO BAD
2782 MOVE C,1(B) ; POINTER
2783 MOVE A,(C) ; VAL TYPE
2784 TLNE A,.RDMON ; MONITORS?
2788 JRST CUNAS ; COMPILER ERROR
2789 MOVE B,1(C) ; GOT VAL
2793 HLRZ 0,-2(C) ; SPECIAL CHECK
2797 CAMGE C,CURFCN+1(PVP)
2802 CILVA1: SUBM M,(P) ; FIX (P)
2803 PUSH TP,$TATOM ; SAVE ATOM
2805 MCALL 1,LVAL ; GET ERROR/MONITOR
2807 POPJM: SUBM M,(P) ; REPAIR DAMAGE
2810 ; COMPILERS INTERFACE TO SET C/ ATOM A,B/ NEW VALUE
2812 CISET: MOVE PVP,PVSTOR+1
2813 MOVE 0,BINDID+1(PVP) ; CURRENT BINDING ENVIRONMENT
2815 CAME 0,(C) ; CAN WE WIN?
2816 JRST CISET1 ; NO, MORE HAIR
2817 MOVE D,1(C) ; POINT TO SLOT
2818 CISET3: HLLZ 0,(D) ; MON CHECK
2820 JRST CISET4 ; YES, LOSE
2822 IOR A,0 ; LEAVE MONITOR ON
2825 JRST CISET5 ; SPEC/UNSPEC CHECK
2826 CISET6: MOVEM A,(D) ; STORE
2830 CISET5: HLRZ 0,-2(D)
2834 CAMGE D,CURFCN+1(PVP)
2838 CISET1: SUBM M,(P) ; FIX ADDR
2839 PUSH TP,$TATOM ; SAVE ATOM
2844 PUSHJ P,ILOC ; SEARCH
2845 MOVE D,B ; POSSIBLE POINTER
2848 MOVE A,-1(TP) ; VAL BACK
2850 CAIE E,TUNBOU ; SKIP IF WIN
2851 JRST CISET2 ; GO CLOBBER IT IN
2855 CISET2: MOVE C,-2(TP) ; ATOM BACK
2856 SUBM M,(P) ; RESET (P)
2860 ; HERE TO DO A MONITORED SET
2862 CISET4: SUBM M,(P) ; AGAIN FIX (P)
2872 CLLOC: MOVE PVP,PVSTOR+1
2873 MOVE 0,BINDID+1(PVP) ; GET CURRENT LOCATIVE
2879 TRNE 0,1 ; SKIP IF NOT CHECKING
2881 CLLOC3: MOVSI A,TLOCD
2882 HRR A,2(B) ; GET BIND TIME
2888 PUSHJ P,ILOC ; LOOK IT UP
2894 CLLOC2: MCALL 1,LLOC
2897 CLLOC9: HLRZ 0,-2(B)
2901 CAMGE B,CURFCN+1(PVP)
2909 JUMPE B,PJFALS ; IF UNBOUND RET FALSE AND NO SSKIP
2919 ; COMPILER ASSIGNED?
2930 ; COMPILER GVAL B/ ATOM
2932 CIGVAL: MOVE 0,(B) ; GLOBAL VAL HERE?
2933 CAME 0,$TLOCI ; TIME=0 ,TYPE=TLOCI => GLOB VAL
2934 JRST CIGVA1 ; NO, GO LOOK
2935 MOVE C,1(B) ; POINT TO SLOT
2936 MOVE A,(C) ; GET TYPE
2939 GETYP 0,A ; CHECK FOR UNBOUND
2940 CAIN 0,TUNBOU ; SKIP IF WINNER
2949 .MCALL 1,GVAL ; GET ERROR/MONITOR
2952 ; COMPILER INTERFACET TO SETG
2954 CSETG: MOVE 0,(C) ; GET V CELL
2955 CAME 0,$TLOCI ; SKIP IF FAST
2957 HRRZ D,1(C) ; POINT TO SLOT
2958 MOVE 0,(D) ; OLD VAL
2959 CSETG3: CAIG D,HIBOT ; SKIP IF PURE ATOM
2960 TLNE 0,.WRMON ; MONITOR
2966 CSETG1: SUBM M,(P) ; FIX UP P
2972 PUSHJ P,IGLOC ; FIND GLOB LOCATIVE
2975 MOVEI D,(B) ; SETUP TO RESTORE NEW VAL
2983 CSETG4: MOVE C,-2(TP) ; ATOM BACK
2984 SUBM M,(P) ; RESET (P)
2989 PUSH TP,$TATOM ; CAUSE A SETG MONITOR
2998 CGLOC: MOVE 0,(B) ; GET CURRENT GUY
2999 CAME 0,$TLOCI ; WIN?
3001 HRRZ D,1(B) ; POINT TO SLOT
3002 CAILE D,HIBOT ; PURE?
3014 ; COMPILERS GASSIGNED?
3038 IMFUNCTION REP,FSUBR,[REPEAT]
3040 MFUNCTION BIND,FSUBR
3042 IMFUNCTION PROG,FSUBR
3044 GETYP A,(AB) ;GET ARG TYPE
3045 CAIE A,TLIST ;IS IT A LIST?
3046 JRST WRONGT ;WRONG TYPE
3047 SKIPN C,1(AB) ;GET AND CHECK ARGUMENT
3048 JRST TFA ;TOO FEW ARGS
3049 SETZB E,D ; INIT HEWITT ATOM AND DECL
3050 PUSHJ P,CARATC ; IS 1ST THING AN ATOM
3052 PUSHJ P,RSATY1 ; CDR AND GET TYPE
3053 CAIE 0,TLIST ; MUST BE LIST
3055 MOVE B,1(C) ; GET ARG LIST
3060 JRST NOP.DC ; JUMP IF NO DCL
3063 PUSHJ P,RSATYP ; CDR ON
3064 NOP.DC: PUSH TP,$TLIST
3065 PUSH TP,B ; AND ARG LIST
3066 PUSHJ P,PRGBND ; BIND AUX VARS
3069 SKIPA E,IMQUOTE LPROG,[LPROG ]INTRUP
3071 PUSHJ P,MAKACT ; MAKE ACTIVATION
3072 PUSHJ P,PSHBND ; BIND AND CHECK
3073 PUSHJ P,SPECBI ; NAD BIND IT
3075 ; HERE TO RUN PROGS FUNCTIONS ETC.
3077 DOPROG: MOVEI A,REPROG
3078 HRLI A,TDCLI ; FLAG AS FUNNY
3079 MOVEM A,(TB) ; WHERE TO AGAIN TO
3081 MOVEM C,3(TB) ; RESTART POINTER
3082 JRST .+2 ; START BY SKIPPING DECL
3084 DOPRG1: PUSHJ P,FASTEV
3085 HRRZ C,@1(TB) ;GET THE REST OF THE BODY
3086 DOPRG2: MOVEM C,1(TB)
3091 REPROG: SKIPN C,@3(TB)
3099 PFINIS: GETYP 0,(TB)
3100 CAIE 0,TDCLI ; DECL'D ?
3102 HRRZ 0,(TB) ; SEE IF RSUBR
3103 JUMPE 0,RSBVCK ; CHECK RSUBR VALUE
3104 HRRZ C,3(TB) ; GET START OF FCN
3105 GETYP 0,(C) ; CHECK FOR DECL
3107 JRST PFINI1 ; NO, JUST RETURN
3108 MOVE E,IMQUOTE VALUE
3109 PUSHJ P,PSHBND ; BUILD FAKE BINDING
3110 MOVE C,1(C) ; GET DECL LIST
3112 PUSHJ P,CHKDCL ; AND CHECK IT
3113 MOVE A,-3(TP) ; GET VAL BAKC
3117 PFINI1: HRRZ C,FSAV(TB)
3127 ; HERE TO CHECK RSUBR VALUE
3133 MOVE A,1(TB) ; GET DECL
3142 RSBVC1: MOVE C,1(TB)
3145 MOVE A,IMQUOTE VALUE
3149 MFUNCTION MRETUR,SUBR,[RETURN]
3151 HLRE A,AB ; GET # OF ARGS
3152 ASH A,-1 ; TO NUMBER
3153 AOJL A,RET2 ; 2 OR MORE ARGS
3154 PUSHJ P,PROGCH ;CHECK IN A PROG
3157 MOVEI B,-1(TP) ; VERIFY IT
3158 COMRET: PUSHJ P,CHFSWP
3160 MOVEI C,0 ; REAL NONE
3162 JUMPN A,CHFINI ; WINNER
3166 ; SEE IF MUST CHECK RETURNS TYPE
3168 CHFINI: GETYP 0,(TB) ; SPECIAL TYPE IF SO
3170 JRST FINIS ; NO, JUST FINIS
3171 MOVEI 0,PFINIS ; CAUSE TO FALL INTO FUNCTION CODE
3178 CAIE A,TACT ; AS FOR "EXIT" SHOULD BE ACTIVATION
3180 MOVEI B,(AB)+2 ; ADDRESS OF FRAME POINTER
3185 MFUNCTION AGAIN,SUBR
3187 HLRZ A,AB ;GET # OF ARGS
3190 JUMPN A,TMA ;0 ARGS?
3191 PUSHJ P,PROGCH ;CHECK FOR IN A PROG
3200 AGAD: MOVEI B,-1(TP) ; POINT TO FRAME
3202 HRRZ C,(B) ; GET RET POINT
3203 GOJOIN: PUSH TP,$TFIX
3206 PUSHJ P,CHUNW ; RESTORE FRAME, UNWIND IF NEC.
3208 HRRZ 0,FSAV(TB) ; CHECK FOR RSUBR
3222 MOVE C,OTBSAV(TB) ; AND RESTORE P FROM FATHER
3235 PUSHJ P,PROGCH ;CHECK FOR A PROG
3244 MCALL 2,MEMQ ;DOES IT HAVE THIS TAG?
3245 JUMPE B,NXTAG ;NO -- ERROR
3246 FNDGO: EXCH B,(TP) ;SAVE PLACE TO GO
3251 NLCLGO: CAIE A,TTAG ;CHECK TYPE
3254 MOVEI B,2(B) ; POINT TO SLOT
3257 GETYP 0,(A) ; SEE IF COMPILED
3263 GODON1: PUSH TP,(A) ;SAVE BODY
3266 PUSHJ P,CHUNW ;GO BACK TO CORRECT FRAME
3267 MOVE B,(TP) ;RESTORE ITERATION MARKER
3280 GETYP A,(AB) ;GET TYPE OF ARGUMENT
3281 CAIE A,TFIX ; FIX ==> COMPILED
3293 ATOTAG: CAIE A,TATOM ;CHECK THAT IT IS AN ATOM
3297 PUSHJ P,PROGCH ;CHECK PROG
3305 JUMPE B,NXTAG ;IF NOT FOUND -- ERROR
3306 EXCH A,-1(TP) ;SAVE PLACE
3316 PROGCH: MOVE B,IMQUOTE LPROG,[LPROG ]INTRUP
3317 PUSHJ P,ILVAL ;GET VALUE
3323 ; HERE TO UNASSIGN LPROG IF NEC
3325 UNPROG: MOVE B,IMQUOTE LPROG,[LPROG ]INTRUP
3328 CAIE 0,TACT ; SKIP IF MUST UNBIND
3332 MOVE E,IMQUOTE LPROG,[LPROG ]INTRUP
3334 UNMAP: HRRZ 0,FSAV(TB) ; CHECK FOR FUNNY
3335 CAIN 0,MAPPLY ; SKIP IF NOT
3337 MOVE B,IMQUOTE LMAP,[LMAP ]INTRUP
3344 MOVE E,IMQUOTE LMAP,[LMAP ]INTRUP
3346 UNSPEC: PUSH TP,BNDV
3348 ADD B,[CURFCN,,CURFCN]
3357 MFUNCTION MEXIT,SUBR,[EXIT]
3365 PUSHJ P,CHUNW ;RESTORE FRAME
3366 JRST CHFINI ; CHECK FOR WINNING VALUE
3369 MFUNCTION COND,FSUBR
3375 PUSH TP,1(AB) ;CREATE UNNAMED TEMP
3376 MOVEI B,0 ; SET TO FALSE IN CASE
3378 CLSLUP: SKIPN C,1(TB) ;IS THE CLAUSELIST NIL?
3379 JRST IFALS1 ;YES -- RETURN NIL
3380 GETYP A,(C) ;NO -- GET TYPE OF CAR
3381 CAIE A,TLIST ;IS IT A LIST?
3383 MOVE A,1(C) ;YES -- GET CLAUSE
3386 PUSH TP,B ; EVALUATION OF
3388 PUSH TP,1(A) ;THE PREDICATE
3393 JRST NXTCLS ;FALSE TRY NEXT CLAUSE
3394 MOVE C,1(TB) ;IF NOT, DO FIRST CLAUSE
3397 JUMPE C,FINIS ;(UNLESS DONE WITH IT)
3398 JRST DOPRG2 ;AS THOUGH IT WERE A PROG
3399 NXTCLS: HRRZ C,@1(TB) ;SET THE CLAUSLIST
3400 HRRZM C,1(TB) ;TO CDR OF THE CLAUSLIST
3405 IFALS1: MOVSI A,TFALSE ;RETURN FALSE
3410 MFUNCTION UNWIND,FSUBR
3414 GETYP 0,(AB) ; CHECK THE ARGS FOR WINNAGE
3415 SKIPN A,1(AB) ; NONE?
3417 HRRZ B,(A) ; CHECK FOR 2D
3422 ; Unbind LPROG and LMAPF so that nothing cute happens
3426 ; Push thing to do upon UNWINDing
3432 PUSHJ P,IUNWIN ; GOT TO INTERNAL SET UP
3434 ; Now EVAL the first form
3437 HRRZ 0,(A) ; SAVE POINTER TO OTHER GUY
3442 JSP E,CHKAB ; DEFER?
3445 MCALL 1,EVAL ; EVAL THE LOSER
3449 ; Now push slots to hold undo info on the way down
3451 IUNWIN: JUMPE M,NOUNRE
3452 HLRE 0,M ; CHECK BOUNDS
3460 NOUNRE: PUSH TP,$TTB ; DESTINATION FRAME
3462 PUSH TP,[0] ; ARGS TO WHOEVER IS DOING IT
3465 ; Now bind UNWIND word
3467 PUSH TP,$TUNWIN ; FIRST WORD OF IT
3469 HRRM SP,(TP) ; CHAIN
3471 PUSH TP,TB ; AND POINT TO HERE
3476 PUSH TP,P ; SAVE PDL ALSO
3477 MOVEM TP,-2(TP) ; SAVE FOR LATER
3480 ; Do a non-local return with UNWIND checking
3482 CHUNW: HRRZ E,SPSAV(B) ; GET DESTINATION FRAME
3483 CHUNW1: PUSH TP,(C) ; FINAL VAL
3485 JUMPN C,.+3 ; WAS THERE REALLY ANYTHING
3488 PUSHJ P,STLOOP ; UNBIND
3489 CHUNPC: SKIPA ; WILL NOT SKIP UNLESS UNWIND FOUND
3497 HRRI TB,(B) ; UPDATE TB
3503 POPUNW: MOVE SP,SPSTOR+1
3514 UNWFRM: JUMPE FRM,CPOPJ
3516 UNWFR2: JUMPE B,UNWFR1
3525 ; Here if an UNDO found
3527 GOTUND: MOVE TB,1(SP) ; GET FRAME OF UNDO
3528 MOVE A,-1(TP) ; GET FUNNY ARG FOR PASS ON
3530 MOVE TP,3(SP) ; GET FUTURE TP
3531 MOVEM C,-6(TP) ; SAVE ARG
3533 MOVE C,(TP) ; SAVED P
3535 MOVEM C,PSAV(TB) ; MAKE CONTIN WIN
3538 HRRZ C,(P) ; PC OF CHUNW CALLER
3539 HRRM C,-11(TP) ; SAVE ALSO AND GET WHERE TO GO PC
3540 MOVEM B,-10(TP) ; AND DESTINATION FRAME
3541 HRRZ C,-1(TP) ; WHERE TO UNWIND PC
3542 HRRZ 0,FSAV(TB) ; RSUBR?
3551 UNWIN1: MOVE B,-12(TP) ; POINT TO THING TO DO UNWINDING
3559 UNWIN2: MOVEI C,-7(TP) ; POINT TO SAVED RET VALS
3564 HRRZ SP,(SP) ; UNBIND THIS GUY
3565 MOVEI E,(TP) ; AND FIXUP SP
3571 JRST CHUNW ; ANY MORE TO UNWIND?
3574 ; CHFSWP - CHECK FRAMES VALIDITY AND SWAP PROCESS IF NECESSARY.
3575 ; CALLED BY ALL CONTROL FLOW
3576 ; ROUTINES (GO,RETURN,EXIT,AGAIN,ERRET...)
3578 CHFSWP: PUSHJ P,CHFRM ; CHECK FOR VALID FRAME
3579 HRRZ D,(B) ; PROCESS VECTOR DOPE WD
3581 SUBI D,-1(C) ; POINT TO TOP
3582 MOVNS C ; NEGATE COUNT
3583 HRLI D,2(C) ; BUILD PVP
3586 MOVE A,(B) ; GET FRAME
3588 CAMN E,D ; SKIP IF SWAP NEEDED
3590 PUSH TP,A ; SAVE FRAME
3593 PUSHJ P,PROCHK ; FIX UP PROCESS LISTS
3594 MOVE A,PSTAT+1(B) ; GET STATE
3597 MOVE D,B ; PREPARE TO SWAP
3601 JSP C,SWAP ; SWAP IN
3602 MOVE C,ABSTO+1(E) ; GET OLD ARRGS
3603 MOVEI A,RUNING ; FIX STATES
3605 MOVEM A,PSTAT+1(PVP)
3610 NOTRES: ERRUUO EQUOTE PROCESS-NOT-RESUMABLE
3613 ;SETG IS USED TO SET THE GLOBAL VALUE OF ITS FIRST ARGUMENT,
3614 ;AN IDENTIFIER, TO THE VALUE OF ITS SECOND ARGUMENT. ITS VALUE IS
3615 ; ITS SECOND ARGUMENT.
3617 IMFUNCTION SETG,SUBR
3619 GETYP A,(AB) ;GET TYPE OF FIRST ARGUMENT
3620 CAIE A,TATOM ;CHECK THAT IT IS AN ATOM
3621 JRST NONATM ;IF NOT -- ERROR
3622 MOVE B,1(AB) ;GET POINTER TO ATOM
3626 CAIL 0,HIBOT ; PURE ATOM?
3627 PUSHJ P,IMPURIFY ; YES IMPURIFY
3628 PUSHJ P,IGLOC ;GET LOCATIVE TO VALUE
3629 CAME A,$TUNBOUND ;IF BOUND
3631 SKIPN NOSETG ; ALLOWED?
3634 PUSH TP,EQUOTE CREATING-NEW-GVAL
3638 PUSH TP,EQUOTE NON-FALSE-TO-ALLOW
3643 GOOSTG: PUSHJ P,BSETG ;IF NOT -- BIND IT
3644 GOOST1: MOVE C,2(AB) ; GET PROPOSED VVAL
3646 MOVSI A,TLOCD ; MAKE SURE MONCH WINS
3647 PUSHJ P,MONCH0 ; WOULD YOU BELIEVE MONITORS!!!!
3650 HRRZ E,-2(D) ; POINT TO POSSIBLE GDECL (OR MAINIFEST)
3651 JUMPE E,OKSETG ; NONE ,OK
3652 CAIE E,-1 ; MANIFEST?
3654 GETYP 0,(D) ; IF UNBOUND, LET IT HAPPEN
3666 MOVE B,IMQUOTE REDEFINE
3667 PUSHJ P,ILVAL ; SEE IF REDEFINE OK
3674 PUSH TP,EQUOTE ATTEMPT-TO-CHANGE-MANIFEST-VARIABLE
3680 SETGTY: PUSH TP,$TVEC
3695 OKSETG: MOVEM A,(D) ;DEPOSIT INTO THE
3696 MOVEM B,1(D) ;INDICATED VALUE CELL
3707 BSETG: HRRZ A,GLOBASE+1
3712 MOVEI B,0 ; MAKE SURE OF NO EMPTY SLOTS
3714 CAMN A,$TUNBOU ; SKIP IF SLOT FOUND
3716 MOVE C,(TP) ; GET ATOM
3717 MOVEM C,-1(B) ; CLOBBER ATOM SLOT
3718 HLLZS -2(B) ; CLOBBER OLD DECL
3720 ; BSETG1: PUSH TP,GLOBASE ; MUST REALLY GROW STACK
3732 MOVE B,GVLINC ; GROW BY INDICATED GVAL SLOTS
3735 MOVE C,[6,,4] ; INDICATOR FOR AGC
3738 MOVE 0,GVLINC ; ADJUST GLOBAL SPBASE
3756 BSETGX: MOVSI A,TLOCI
3757 PUSHJ P,PATSCH ; FIXUP SCHLPAGE
3767 PATL: SKIPL E,3(D) ; SKIP IF NEXT EXISTS
3773 MOVEM E,3(D) ; SAY GVAL ETC. EXISTS IF WE UNBIND
3777 IMFUNCTION DEFMAC,FSUBR
3784 IMFUNCTION DFNE,FSUBR,[DEFINE]
3792 SKIPN B,1(AB) ; GET ATOM
3794 GETYP A,(B) ; MAKE SURE ATOM
3799 MCALL 1,EVAL ; EVAL IT TO AN ATOM
3802 PUSH TP,A ; SAVE TWO COPIES
3804 PUSHJ P,IGVAL ; SEE IF A VALUE EXISTS
3805 CAMN A,$TUNBOU ; SKIP IF A WINNER
3807 PUSHJ P,ASKUSR ; CHECK WITH USER
3814 SKIPN (P) ; SKIP IF MACRO
3816 MOVEI D,(B) ; READY TO CONS
3823 DFNE1: POP TP,B ; RETURN ATOM
3828 ASKUSR: MOVE B,IMQUOTE REDEFINE
3829 PUSHJ P,ILVAL ; SEE IF REDEFINE OK
3835 ASKUS1: PUSH TP,$TATOM
3838 PUSH TP,EQUOTE ALREADY-DEFINED-ERRET-NON-FALSE-TO-REDEFINE
3848 ;SET CLOBBERS THE LOCAL VALUE OF THE IDENTIFIER GIVEN BY ITS
3849 ;FIRST ARGUMENT TO THE SECOND ARG. ITS VALUE IS ITS SECOND ARGUMENT.
3852 HLRE D,AB ; 2 TIMES # OF ARGS TO D
3853 ASH D,-1 ; - # OF ARGS
3855 JUMPG D,TFA ; NOT ENOUGH
3858 JUMPE D,SET1 ; NO ENVIRONMENT
3859 AOJL D,TMA ; TOO MANY
3860 GETYP A,4(AB) ; CHECK ARG IS A FRAME OR PROCESS
3863 JRST SET2 ; WINNING ENVIRONMENT/FRAME
3865 JRST SET2 ; TO MAKE PFISTER HAPPY
3868 MOVE B,5(AB) ; GET PROCESS
3871 SET2: MOVEI B,4(AB) ; POINT TO FRAME
3872 PUSHJ P,CHFRM ; CHECK IT OUT
3873 MOVE B,5(AB) ; GET IT BACK
3874 MOVE C,SPSAV(B) ; GET BINDING POINTER
3875 HRRZ B,4(AB) ; POINT TO PROCESS
3876 HLRZ A,(B) ; GET LENGTH
3877 SUBI B,-1(A) ; POINT TO START THEREOF
3878 HLL B,PVSTOR+1 ; GET -LNTRH, (ALL PROCESS VECS SAME LENGTH)
3879 SET1: PUSH TP,$TPVP ; SAVE PROCESS
3881 PUSH TP,$TSP ; SAVE PATH POINTER
3883 GETYP A,(AB) ;GET TYPE OF FIRST
3884 CAIE A,TATOM ;ARGUMENT --
3885 JRST WTYP1 ;BETTER BE AN ATOM
3886 MOVE B,1(AB) ;GET PTR TO IT
3891 PUSHJ P,AILOC ;GET LOCATIVE TO VALUE
3892 GOTLOC: CAME A,$TUNBOUND ;IF BOUND
3894 SKIPN NOSET ; ALLOWED?
3897 PUSH TP,EQUOTE CREATING-NEW-LVAL
3901 PUSH TP,EQUOTE NON-FALSE-TO-ALLOW
3906 GOOSET: PUSHJ P,BSET ;IF NOT -- BIND IT
3907 GOOSE1: MOVE C,2(AB) ; GET PROPOSED VVAL
3908 MOVE C,2(AB) ; GET NEW VAL
3910 MOVSI A,TLOCD ; FOR MONCH
3912 PUSHJ P,MONCH0 ; HURRAY FOR MONITORS!!!!!
3914 HLRZ A,2(E) ; GET DECLS
3915 JUMPE A,SET3 ; NONE, GO
3919 HLLZ A,(A) ; GET PATTERN
3920 PUSHJ P,TMATCH ; MATCH TMEM
3926 SET3: MOVEM C,(E) ;CLOBBER IDENTIFIER
3930 MOVE C,-2(TP) ; GET PROC
3934 ; HERE WE NOTE THAT EFFICIENCY CAN SOMETIMES GET IN THE WAY OF CORRECTNESS
3935 ; BY SETTING THE SHALLOW BINDING WE MANAGE TO CLOBBER THE TOP LEVEL LVAL
3936 ; EVEN IF WE ARE SETTING WITH RESPECT TO A DIFFERENT FRAME. TO CORRECT
3937 ; THIS GLITCH THIS ACTIVITY WILL ONLY TAKE PLACE IF THE ATOM ALREADY POINTS
3945 NSHALL: SUB TP,[4,,4]
3949 CAMN PVP,-2(TP) ; SKIP IF PROC DIFFERS
3950 MOVEM C,-2(TP) ; ELSE USE RESULT FROM LOC SEARCH
3951 MOVE B,-2(TP) ; GET PROCESS
3952 HRRZ A,TPBASE+1(B) ;GET ACTUAL STACK BASE
3953 HRRZ B,SPBASE+1(B) ;AND FIRST BINDING
3954 SUB B,A ;ARE THERE 6
3955 CAIL B,6 ;CELLS AVAILABLE?
3957 MOVE C,(TP) ; GET POINTER BACK
3958 MOVEI B,0 ; LOOK FOR EMPTY SLOT
3960 CAMN A,$TUNBOUND ; SKIP IF FOUND
3962 MOVE E,1(AB) ; GET ATOM
3963 MOVEM E,-1(B) ; AND STORE
3965 BSET1: MOVE B,-2(TP) ; GET PROCESS
3966 ; PUSH TP,TPBASE(B) ;NO -- GROW THE TP
3967 ; PUSH TP,TPBASE+1(B) ;AT THE BASE END
3973 ; MOVE C,-2(TP) ; GET PROCESS
3974 ; MOVEM A,TPBASE(C) ;SAVE RESULT
3975 PUSH P,0 ; MANUALLY GROW VECTOR
3984 DPB D,[001100,,-1(C)]
3985 MOVE C,[5,,3] ; SET UP INDICATORS FOR AGC
3988 MOVE B,TPBASE+1(PVP) ; MODIFY POINTER
3989 MOVE 0,LVLINC ; ADJUST SPBASE POINTER
3994 MOVEM B,TPBASE+1(PVP)
3997 ; MOVEM B,TPBASE+1(C)
3998 SETIT: MOVE C,-2(TP) ; GET PROCESS
4000 MOVEI A,-6(B) ;MAKE UP BINDING
4001 HRRM A,(B) ;LINK PREVIOUS BIND BLOCK
4009 BSET2: MOVE C,-2(TP) ; GET PROC
4012 HLRZ D,OTBSAV(TB) ; TIME IT
4013 MOVEM D,2(B) ; AND FIX IT
4016 ; HERE TO ELABORATE ON TYPE MISMATCH
4018 TYPMI2: MOVE C,(TP) ; FIND DECLS
4022 MOVE 0,(AB) ; GET ATOM
4030 GETYP A,(AB) ; GET TYPE
4031 CAIE A,TFALSE ;IS IT FALSE?
4032 JRST IFALSE ;NO -- RETURN FALSE
4035 MOVSI A,TATOM ;RETURN T (VERITAS)
4044 MFUNCTION ANDA,FSUBR,AND
4050 JRST WRONGT ;IF ARG DOESN'T CHECK OUT
4052 SKIPN C,1(AB) ;IF NIL
4053 JRST TF(E) ;RETURN TRUTH
4054 PUSH TP,$TLIST ;CREATE UNNAMED TEMP
4058 JUMPE C,TFI(E) ;ANY MORE ARGS?
4059 MOVEM C,1(TB) ;STORE CRUFT
4063 PUSH TP,1(C) ;ARGUMENT
4069 JRST FINIS ;IF FALSE -- RETURN
4070 HRRZ C,@1(TB) ;GET CDR OF ARGLIST
4079 TFSKP: CAIE 0,TFALSE
4082 IMFUNCTION FUNCTION,FSUBR
4090 \f;SUBR VERSIONS OF AND/OR
4092 MFUNCTION ANDP,SUBR,[AND?]
4094 MOVE C,[CAIN 0,TFALSE]
4097 MFUNCTION ORP,SUBR,[OR?]
4099 MOVE C,[CAIE 0,TFALSE]
4100 BOOL: HLRE A,AB ; GET ARG COUNTER
4102 ASH A,-1 ; DIVIDES BY 2
4107 CANDP: SKIPA C,[CAIN 0,TFALSE]
4108 CORP: MOVE C,[CAIE 0,TFALSE]
4113 SUBB TP,D ; POINT TO ARGS & FIXUP TP PTR
4114 AOBJP D,.+1 ; FIXUP ARG PTR AND FALL INTO CBOOL
4118 JRST CBOOL1 ; YES RETURN IT
4120 SOJG A,CBOOL ; ANY MORE ?
4121 SUB D,[2,,2] ; NO, USE LAST
4127 CNOARG: MOVSI 0,TFALSE
4133 CNOAND: MOVSI A,TATOM
4138 MFUNCTION CLOSURE,SUBR
4140 SKIPL A,AB ;ANY ARGS
4141 JRST TFA ;NO -- LOSE
4142 ADD A,[2,,2] ;POINT AT IDS
4145 PUSH P,[0] ;MAKE COUNTER
4147 CLOLP: SKIPL A,1(TB) ;ANY MORE IDS?
4148 JRST CLODON ;NO -- LOSE
4149 PUSH TP,(A) ;SAVE ID
4151 PUSH TP,(A) ;GET ITS VALUE
4153 ADD A,[2,,2] ;BUMP POINTER
4159 MCALL 2,LIST ;MAKE PAIR
4165 ACALL A,LIST ;MAKE UP LIST
4166 PUSH TP,(AB) ;GET FUNCTION
4170 MCALL 2,LIST ;MAKE LIST
4176 ;ERROR COMMENTS FOR EVAL
4178 BADNUM: ERRUUO EQUOTE NEGATIVE-ARGUMENT
4180 WTY1TP: ERRUUO EQUOTE FIRST-ARG-WRONG-TYPE
4182 UNBOU: PUSH TP,$TATOM
4183 PUSH TP,EQUOTE UNBOUND-VARIABLE
4186 UNAS: PUSH TP,$TATOM
4187 PUSH TP,EQUOTE UNASSIGNED-VARIABLE
4191 ERRUUO EQUOTE BAD-ENVIRONMENT
4194 ERRUUO EQUOTE BAD-FUNARG
4211 MPD: ERRUUO EQUOTE MEANINGLESS-PARAMETER-DECLARATION
4213 NOBODY: ERRUUO EQUOTE HAS-EMPTY-BODY
4215 BADCLS: ERRUUO EQUOTE BAD-CLAUSE
4217 NXTAG: ERRUUO EQUOTE NON-EXISTENT-TAG
4219 NXPRG: ERRUUO EQUOTE NOT-IN-PROG
4222 NAPT: ERRUUO EQUOTE NON-APPLICABLE-TYPE
4224 NONEVT: ERRUUO EQUOTE NON-EVALUATEABLE-TYPE
4227 NONATM: ERRUUO EQUOTE NON-ATOMIC-ARGUMENT
4230 ILLFRA: ERRUUO EQUOTE FRAME-NO-LONGER-EXISTS
4232 ILLSEG: ERRUUO EQUOTE ILLEGAL-SEGMENT
4234 BADMAC: ERRUUO EQUOTE BAD-USE-OF-MACRO
4236 BADFSB: ERRUUO EQUOTE APPLY-OR-STACKFORM-OF-FSUBR
4239 ER1ARG: PUSH TP,(AB)