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
26 ; ENTRY TO EXPAND A MACRO
33 MOVEI A,PVLNT*2+1(PVP)
49 SKIPE C,1STEPR+1(PVP) ; BEING 1 STEPPED?
50 JRST 1STEPI ; YES HANDLE
51 EVALON: HLRZ A,AB ;GET NUMBER OF ARGS
53 JRST AEVAL ;EVAL WITH AN ALIST
54 SEVAL: GETYP A,(AB) ;GET TYPE OF ARG
55 SKIPE C,EVATYP+1 ; USER TYPE TABLE?
57 SEVAL1: CAIG A,NUMPRI ;PRIMITIVE?
58 JRST SEVAL2 ;YES-DISPATCH
60 SELF: MOVE A,(AB) ;TYPES WHICH EVALUATE
62 JRST EFINIS ;TO SELF-EG NUMBERS
64 SEVAL2: HRRO A,EVTYPE(A)
67 ; HERE FOR USER EVAL DISPATCH
69 EVDISP: ADDI C,(A) ; POINT TO SLOT
71 SKIPE (C) ; SKIP EITHER A LOSER OR JRST DISP
72 JRST EVDIS1 ; APPLY EVALUATOR
73 SKIPN C,1(C) ; GET ADDR OR GO TO PURE DISP
81 MCALL 2,APPLY ; APPLY HACKER TO OBJECT
87 IF2,SELFS==400000,,SELF
89 DISTBL EVTYPE,SELFS,[[TFORM,EVFORM],[TLIST,EVLIST],[TVEC,EVECT],[TUVEC,EUVEC]
93 ;WATCH FOR SUBTLE BUG 43 LERR,LPROG OR BINDID
95 CAIE A,-4 ;EXACTLY 2 ARGS?
97 GETYP A,2(AB) ;CHECK THAT WE HAVE A FRAME
102 JRST TRYPRO ; COULD BE PROCESS
103 MOVEI B,2(AB) ; POINT TO FRAME
104 AEVAL2: PUSHJ P,CHENV ; HACK ENVIRONMENT CHANGE
108 AEVAL3: HRRZ 0,FSAV(TB)
113 TRYPRO: CAIE A,TPVP ; SKIP IF IT IS A PROCESS
115 MOVE C,3(AB) ; GET PROCESS
116 CAMN C,PVSTOR ; DIFFERENT FROM ME?
117 JRST SEVAL ; NO, NORMAL EVAL WINS
118 MOVE B,SPSTO+1(C) ; GET SP FOR PROCESS
119 MOVE D,TBSTO+1(C) ; GET TOP FRAME
120 HLL D,OTBSAV(D) ; TIME IT
121 MOVEI C,PVLNT*2+1(C) ; CONS UP POINTER TO PROC DOPE WORD
122 HRLI C,TFRAME ; LOOK LIK E A FRAME
123 PUSHJ P,SWITSP ; SPLICE ENVIRONMENT
126 ; ROUTINE TO CHANGE LOOK UP PATH FOR BINDINGS
128 CHENV: PUSHJ P,CHFRM ; CHECK OUT FRAME
129 MOVE C,(B) ; POINT TO PROCESS
130 MOVE D,1(B) ; GET TB POINTER FROM FRAME
131 CAMN SP,SPSAV(D) ; CHANGE?
132 POPJ P, ; NO, JUST RET
133 MOVE B,SPSAV(D) ; GET SP OF INTEREST
134 SWITSP: MOVSI 0,TSKIP ; SET UP SKIP
135 HRRI 0,1(TP) ; POINT TO UNBIND PATH
137 ADD A,[BINDID,,BINDID] ; BIND THE BINDING ID
143 MOVE E,TP ; FOR SPECBIND
146 PUSH TP,C ; SAVE PROCESS
148 PUSHJ P,SPECBE ; BIND BINDID
149 MOVE SP,TP ; GET NEW SP
150 SUB SP,[3,,3] ; SET UP SP FORK
155 ; HERE TO EVALUATE A FORM (99% OF EVAL'S WORK)
157 EVFORM: SKIPN C,1(AB) ; EMPTY FORM, RETURN FALSE
159 GETYP A,(C) ; 1ST ELEMENT OF FORM
161 JRST EV0 ; NO, EVALUATE IT
162 MOVE B,1(C) ; GET ATOM
163 PUSHJ P,IGVAL ; GET ITS GLOBAL VALUE
165 ; SPECIAL HACK TO SPEED UP LVAL AND GVAL CALLS
169 JRST ATMVAL ; FAST ATOM VALUE
172 CAIE 0,TUNBOU ; BOUND?
173 JRST IAPPLY ; YES APPLY IT
175 MOVE C,1(AB) ; LOOK FOR LOCAL
180 JRST IAPPLY ; WIN, GO APPLY IT
183 PUSH TP,EQUOTE UNBOUND-VARIABLE
185 MOVE C,1(AB) ; FORM BACK
188 PUSH TP,IMQUOTE VALUE
189 MCALL 3,ERROR ; REPORT THE ERROR
192 EFALSE: MOVSI A,TFALSE ; SPECIAL FALSE FOR EVAL OF EMPTY FORM
196 ATMVAL: HRRZ D,(C) ; CDR THE FORM
197 HRRZ 0,(D) ; AND AGAIN
199 GETYP 0,(D) ; MAKE SURE APPLYING TO ATOM
202 MOVEI E,IGVAL ; ASSUME GLOBAAL
203 CAIE B,GVAL ; SKIP IF OK
204 MOVEI E,ILVAL ; ELSE USE LOCAL
206 MOVE B,(D)+1 ; CLR BUG #1637 (GET THE ATOM FOR THE SUBR)
207 PUSHJ P,(E) ; AND GET VALUE
209 JRST EFINIS ; RETURN FROM EVAL
211 MOVSI A,TSUBR ; CAUSE REAL SUBR TO GET EROR
214 ; HERE FOR 1ST ELEMENT NOT A FORM
216 EV0: PUSHJ P,FASTEV ; EVAL IT
218 ; HERE TO APPLY THINGS IN FORMS
220 IAPPLY: PUSH TP,(AB) ; SAVE THE FORM
223 PUSH TP,B ; SAVE THE APPLIER
224 PUSH TP,$TFIX ; AND THE ARG GETTER
226 PUSHJ P,APLDIS ; GO TO INTERNAL APPLIER
227 JRST EFINIS ; LEAVE EVAL
229 ; HERE TO EVAL 1ST ELEMENT OF A FORM
231 FASTEV: MOVE PVP,PVSTOR+1
232 SKIPE 1STEPR+1(PVP) ; BEING 1 STEPPED?
233 JRST EV02 ; YES, LET LOSER SEE THIS EVAL
234 GETYP A,(C) ; GET TYPE
235 SKIPE D,EVATYP+1 ; USER TABLE?
236 JRST EV01 ; YES, HACK IT
237 EV03: CAIG A,NUMPRI ; SKIP IF SELF
238 SKIPA A,EVTYPE(A) ; GET DISPATCH
239 MOVEI A,SELF ; USE SLEF
241 EV04: CAIE A,SELF ; IF EVAL'S TO SELF, JUST USE IT
250 JSP E,CHKAB ; CHECK DEFERS
253 EV01: ADDI D,(A) ; POINT TO SLOT OF USER EVAL TABLE
255 SKIPE (D) ; EITHER NOT GIVEN OR SIMPLE
257 SKIPN 1(D) ; SKIP IF SIMPLE
258 JRST EV03 ; NOT GIVEN
263 HLLZS (TP) ; FIX UP LH
270 ; MAPF/MAPR CALL TO APPLY
276 ; APPLY, FALLS INTO EVAL'S APPLY CODE AT APLDIS
278 IMFUNCTION APPLY,SUBR
282 JUMPGE AB,TFA ; MUST BE AT LEAST 1 ARGUMENT
287 PUSH TP,(AB) ; SAVE FCN
289 PUSH TP,$TFIX ; AND ARG GETTER
290 PUSH TP,[SETZ APLARG]
294 ; STACKFROM, ALSO FALLS INTO EVAL'S APPLIER AT APLDIS
296 IMFUNCTION STACKFORM,FSUBR
303 MOVEI A,3 ; CHECK ALL GOODIES SUPPLIED
310 HRRZ C,1(AB) ; GET LIST BACK
311 PUSHJ P,FASTEV ; DO A FAST EVALUATION
313 HRRZ C,@1(AB) ; POINT TO ARG GETTING FORMS
318 PUSH TP,[SETZ EVALRG]
323 ; OFFSETS FOR TEMPORARIES ETC. USED IN APPLYING STUFF
325 E.FRM==0 ; POINTS TO FORM BEING EVALED (OR ARGS FOR APPLY STACKFORM)
326 E.FCN==2 ; FUNCTION/SUBR/RSUBR BEING APPLIED
327 E.ARG==4 ; POINTS TO ARG GETTING ROUTINE (<0 => MUST EVAL ARGS)
328 E.EXTR==6 ; CONTAINS 1ST ARG IN USER APPLY CASE
329 E.SEG==10 ; POINTS TO SEGMENT IN FORM BEING HACKED
330 E.CNT==12 ; COUNTER FOR TUPLES OF ARGS
331 E.DECL==14 ; POINTS TO DECLARATION LIST IN FUNCTIONS
332 E.ARGL==16 ; POINTS TO ARG LIST IN FUNCTIONS
333 E.HEW==20 ; POINTS TO HEWITT ATOM IF IT EXISTS
335 E.VAL==E.ARGL ; VALUE TYPE FOR RSUBRS
337 MINTM==E.EXTR+2 ; MIN # OF TEMPS EVER ALLOCATED
338 E.TSUB==E.CNT+2 ; # OF TEMPS FOR SUBR/NUMBER APPLICATION
339 XP.TMP==E.HEW-E.EXTR ; # EXTRA TEMPS FOR FUNCTION APPLICATION
340 R.TMP==4 ; TEMPS AFTER ARGS ARE BOUND
341 TM.OFF==E.HEW+2-R.TMP ; TEMPS TO FLUSH AFTER BIND OF ARGS
343 RE.FCN==0 ; AFTER BINDING CONTAINS FCN BODY
344 RE.ARG==2 ; ARG LIST AFTER BINDING
346 ; GENERAL THING APPLYER
348 APLDIS: PUSH TP,[0] ; SLOT USED FOR USER APPLYERS
350 APLDIX: GETYP A,E.FCN(TB) ; GET TYPE
352 APLDI: SKIPE D,APLTYP+1 ; USER TABLE EXISTS?
353 JRST APLDI1 ; YES, USE IT
354 APLDI2: CAILE A,NUMPRI ; SKIP IF NOT PRIM
359 APLDI1: ADDI D,(A) ; POINT TO SLOT
361 SKIPE (D) ; SKIP IF NOT GIVEN OR STANDARD
363 APLDI4: SKIPE D,1(D) ; GET DISP
365 JRST APLDI2 ; USE SYSTEM DISPATCH
367 APLDI3: SKIPE E.EXTR+1(TB) ; SKIP IF HAVEN'T BEEN HERE BEFORE
369 MOVE A,(D) ; GET ITS HANDLER
370 EXCH A,E.FCN(TB) ; AND USE AS FCN
371 MOVEM A,E.EXTR(TB) ; SAVE
374 MOVEM A,E.EXTR+1(TB) ; STASH OLD FCN AS EXTRG
375 GETYP A,(D) ; GET TYPE
379 ; APPLY DISPATCH TABLE
381 DISTBL APTYPE,<SETZ NAPTL>,[[TSUBR,APSUBR],[TFSUBR,APFSUB],[TRSUBR,APRSUB],[TFIX,APNUM]
382 [TEXPR,APEXPR],[TFUNAR,APFUNARG],[TENTER,APENTR],[TMACRO,APMACR],[TOFFS,APNUM]]
\f
384 ; SUBR TO SAY IF TYPE IS APPLICABLE
386 MFUNCTION APPLIC,SUBR,[APPLICABLE?]
395 ; HERE TO DETERMINE IF A TYPE IS APPLICABLE
399 JRST USEPUR ; USE PURE TABLE
401 ADDI B,(A) ; POINT TO SLOT
402 SKIPG 1(B) ; SKIP IF WINNER
403 SKIPE (B) ; SKIP IF POTENIAL LOSER
405 SKIPE 1(B) ; SKIP IF MUST USE PURE TABBLE
407 USEPUR: CAILE A,NUMPRI ; SKIP IF NOT PRIM
409 SKIPL APTYPE(A) ; SKIP IF APLLICABLE
417 SKIPN E.EXTR(TB) ; IF EXTRA ARG
418 SKIPGE E.ARG+1(TB) ; OR APPLY/STACKFORM, LOSE
420 MOVE A,E.FCN+1(TB) ; GET FCN
421 HRRZ C,@E.FRM+1(TB) ; GET ARG LIST
422 SUB TP,[MINTM,,MINTM] ; FLUSH UNWANTED TEMPS
424 PUSH TP,C ; ARG TO STACK
425 .MCALL 1,(A) ; AND CALL
431 PUSHJ P,PSH4ZR ; SET UP ZEROED SLOTS
433 AOS E.CNT(TB) ; INDICATES IF MUST EVAL ARGS
434 MOVSI A,400000 ; MAKE SURE OF GOOD INDIRECT
436 SKIPN A,E.EXTR(TB) ; FUNNY ARGS
438 MOVE B,E.EXTR+1(TB) ; YES , GET VAL
439 JRST APSUB2 ; AND FALL IN
441 APSUB1: PUSHJ P,@E.ARG+1(TB) ; EAT AN ARG
445 AOS E.CNT+1(TB) ; COUNT IT
448 APSUBD: MOVE A,E.CNT+1(TB) ; FINISHED, GET COUNT
449 MOVE B,E.FCN+1(TB) ; AND SUBR
453 PUSHJ P,BLTDN ; FLUSH CRUFT
457 BLTDN: MOVEI C,(TB) ; POINT TO DEST
458 HRLI C,E.TSUB(C) ; AND SOURCE
459 BLT C,-E.TSUB(TP) ;BL..............T
460 SUB TP,[E.TSUB,,E.TSUB]
463 APENDN: PUSHJ P,BLTDN
467 ; FLAGS FOR RSUBR HACKER
474 ; APPLY OBJECTS OF TYPE RSUBR
478 MOVE C,E.FCN+1(TB) ; GET THE RSUBR
479 CAML C,[-5,,] ; IS IT LONG ENOUGH FOR DECLS
480 JRST APSUBR ; NO TREAT AS A SUBR
481 GETYP 0,4(C) ; GET TYPE OF 3D ELEMENT
482 CAIE 0,TDECL ; DECLARATION?
483 JRST APSUBR ; NO, TREAT AS SUBR
484 PUSHJ P,PSH4ZR ; ALLOCATE SOME EXTRA ROOM
485 PUSH TP,$TDECL ; PUSH UP THE DECLS
487 PUSH TP,$TLOSE ; SAVE ROOM FOR VAL DECL
490 AOS E.CNT(TB) ; INDICATES IF MUST EVAL ARGS
491 MOVSI A,400000 ; MAKE SURE OF GOOD INDIRECT
494 SKIPN E.EXTR(TB) ; "EXTRA" ARG?
496 MOVE 0,[SETZ EXTRGT] ; CHANGE THE ACCESS FCN
498 HRRM 0,E.ARG(TB) ; REMEMBER IT
500 APRSU1: MOVEI 0,0 ; INIT FLAG REGISTER
503 APRSU2: HRRZ A,E.DECL+1(TB) ; GET DECL LIST
504 JUMPE A,APRSU3 ; DONE!
507 PUSHJ P,NXTDCL ; IS NEXT THING A STRING?
508 JRST APRSU4 ; NO, BETTER BE A TYPE
509 CAMN B,[ASCII /VALUE/]
510 JRST RSBVAL ; SAVE VAL DECL
511 TRON 0,F.NFST ; IF NOT FIRST, LOSE
512 CAME B,[ASCII /CALL/] ; CALL DECL
514 SKIPE E.CNT(TB) ; LEGAL?
517 MOVE D,E.FRM+1(TB) ; GET FORM
518 JRST APRS10 ; HACK IT
520 APRSU5: TROE 0,F.STR ; STRING STRING?
522 CAMN B,[<ASCII /OPT/>]
524 CAME B,[<ASCII /OPTIO/>+1] ; OPTIONA?
526 TROE 0,F.OPT ; CHECK AND SET
527 JRST MPD ; OPTINAL OPTIONAL LOSES
528 JRST APRSU2 ; TO MAIN LOOP
530 APRSU7: CAME B,[ASCII /QUOTE/]
533 TROE 0,F.QUO ; TURN ON AND CHECK QUOTE
534 JRST MPD ; QUOTE QUOTE LOSES
535 JRST APRSU2 ; GO TO END OF LOOP
538 APRSU8: CAME B,[ASCII /ARGS/]
540 SKIPE E.CNT(TB) ; SKIP IF LEGAL
542 HRRZ D,@E.FRM+1(TB) ; GET ARG LIST
545 APRS10: HRRZ A,(A) ; GET THE DECL
546 MOVEM A,E.DECL+1(TB) ; CLOBBER
547 HRRZ B,(A) ; CHECK FOR TOO MUCH
549 MOVE B,1(A) ; GET DECL
550 HLLZ A,(A) ; GOT THE DECL
551 MOVEM 0,(P) ; SAVE FLAGS
552 JSP E,CHKAB ; CHECK DEFER
557 AOS E.CNT+1(TB) ; COUNT ARG
558 JRST APRDON ; GO CALL RSUBR
560 RSBVAL: HRRZ A,E.DECL+1(TB) ; GET DECL
562 HRRZ B,(A) ; POINT TO DECL
563 MOVEM B,E.DECL+1(TB) ; SAVE NEW DECL POINTER
567 MOVEM A,E.VAL+1(TB) ; SAVE VAL DECL
569 MOVEM A,E.VAL(TB) ; SET ITS TYPE
573 APRSU9: CAME B,[ASCII /TUPLE/]
575 MOVEM 0,(P) ; SAVE FLAGS
576 HRRZ A,(A) ; CDR DECLS
580 PUSH P,[0] ; COUNT ELEMENTS IN TUPLE
582 APRTUP: PUSHJ P,@E.ARG+1(TB) ; GOBBLE ARGS
589 APRTPD: POP P,C ; GET COUNT
590 ADDM C,E.CNT+1(TB) ; UPDATE MAIN COUNT
592 HRLI C,TINFO ; BUILD FENCE POST
594 PUSHJ P,TBTOTP ; GEN REL OFFSET TO TOP
596 HRROI D,-1(TP) ; POINT TO TOP
599 MOVSI C,TARGS ; BUILD TYPE WORD
603 HLLZ A,(A) ; TYPE/VAL
605 PUSHJ P,TMATCH ; GOTO TYPE CHECKER
608 SUB TP,[2,,2] ; REMOVE FENCE POST
610 APRDON: SUB P,[1,,1] ; FLUSH CRUFT
611 MOVE A,E.CNT+1(TB) ; GET # OF ARGS
613 GETYP 0,E.FCN(TB) ; COULD BE ENTRY
614 MOVEI C,(TB) ; PREPARE TO BLT DOWN
617 SUB TP,[E.TSUB+2,,E.TSUB+2]
620 .ACALL A,(B) ; CALL THE RSUBR
629 APRSU4: MOVEM 0,(P) ; SAVE FLAGS
630 MOVE B,1(A) ; GET DECL
633 MOVE 0,(P) ; RESTORE FLAGS
636 SKIPE E.CNT(TB) ; ALREADY EVAL'D
639 JRST APREVA ; MUST EVAL ARG
641 HRRZ C,@E.FRM+1(TB) ; GET ARG?
642 TRNE 0,F.OPT ; OPTIONAL
644 JUMPE C,TFA ; NO, TOO FEW ARGS
648 JSP E,CHKAB ; CHECK THEM
650 APRTYC: MOVE C,A ; SET UP FOR TMATCH
653 EXCH A,-1(TP) ; SAVE STUFF
654 APRS11: PUSHJ P,TMATCH ; CHECK TYPE
657 MOVE 0,(P) ; RESTORE FLAGS
660 JRST APRSU2 ; AND GO ON
662 APREV0: TRNE 0,F.QUO ; ATTEMPT TO QUOTE ALREADY EVAL'D ARG ?
664 APREVA: PUSHJ P,@E.ARG+1(TB) ; EVAL ONE
665 TDZA C,C ; C=0 ==> NONE LEFT
668 JUMPN C,APRTYC ; GO CHECK TYPE
669 APRDN: SUB TP,[2,,2] ; FLUSH DECL
670 TRNE 0,F.OPT ; OPTIONAL?
671 JRST APRDON ; ALL DONE
674 APRSU3: TRNE 0,F.STR ; END IN STRING?
\b
676 PUSHJ P,@E.ARG+1(TB) ; SEE IF ANYMORE ARGS
681 ; STANDARD ARGUMENT GETTERS USED IN APPLYING THINGS
683 ARGCDR: HRRZ C,@E.FRM+1(TB) ; POINT TO ARGLIST (NOTE: POINTS 1 BEFORE WHERE ARG IS)
684 JUMPE C,CPOPJ ; LEAVE IF DONE
686 GETYP 0,(C) ; GET TYPE OF ARG
688 JRST ARGCD1 ; SEG MENT HACK
692 ARGCD1: PUSH TP,$TFORM ; PRETEND WE ARE A FORM
697 PUSHJ P,TYPSEG ; GET SEG TYPE CODE
698 HRRM C,E.ARG(TB) ; SAVE IT IN OBSCCURE PLACE
699 MOVE C,DSTORE ; FIX FOR TEMPLATE
702 MOVEM C,E.ARG+1(TB) ; SET NEW ARG GETTER
707 HRRZ C,E.ARG(TB) ; SEG CODE TO C
711 PUSHJ P,NXTLM ; GET NEXT ELEMENT
714 MOVE D,DSTORE ; KEEP TYPE WINNING
721 HRRM C,E.ARG+1(TB) ; RESET ARG GETTER
724 ; ARGUMENT GETTER FOR APPLY
727 SKIPL A,E.FRM+1(TB) ; ANY ARGS LEFT
728 POPJ P, ; NO, EXIT IMMEDIATELY
731 MOVE B,-1(A) ; RET NEXT ARG
735 ; STACKFORM ARG GETTER
737 EVALRG: SKIPN C,@E.FRM+1(TB) ; ANY FORM?
740 GETYP A,A ; CHECK FOR FALSE
743 MOVE C,E.FRM+1(TB) ; GET OTHER FORM
748 ; HERE TO APPLY NUMBERS
750 APNUM: PUSHJ P,PSH4ZR ; TP SLOTS
751 SKIPN A,E.EXTR(TB) ; FUNNY ARG?
753 MOVE B,E.EXTR+1(TB) ; GET ARG
756 APNUM1: PUSHJ P,@E.ARG+1(TB) ; GET ARG
765 PUSHJ P,BLTDN ; FLUSH JUNK
768 ; HACK FOR TURNING <3 .FOO .BAR> INTO <PUT .FOO 3 .BAR>
776 PUSHJ P,ISTRUC ; STRUCTURED FIRST ARG?
781 ; HERE TO APPLY SUSSMAN FUNARGS
787 HRRZ D,(C) ; MUST BE AT LEAST 2 LONG
789 GETYP 0,(D) ; CHECK FOR LIST
792 HRRZ 0,(D) ; SHOULD BE END
794 GETYP 0,(C) ; 1ST MUST BE FCN
799 PUSHJ P,APEXPF ; BIND THE ARGS AND AUX'S
800 HRRZ C,RE.FCN+1(TB) ; GET BODY OF FUNARG
801 MOVE B,1(C) ; GET FCN
802 MOVEM B,RE.FCN+1(TB) ; AND SAVE
803 HRRZ C,(C) ; CDR FUNARG BODY
805 MOVSI 0,TLIST ; SET UP TYPE
807 MOVEM 0,CSTO(PVP) ; FOR INTS TO WIN
812 CAIE 0,TLIST ; BETTER BE LIST
816 PUSHJ P,NEXTDC ; GET POSSIBILITY
820 HRRZ B,(B) ; GET TO VALUE
827 JSP E,CHKAB ; HACK DEFER
828 PUSHJ P,PSHAB4 ; PUT VAL IN
834 DOF: MOVE PVP,PVSTOR+1
835 SETZM CSTO(PVP) ; DONT CONFUSE GC
836 PUSHJ P,SPECBIND ; BIND 'EM UP
843 APMACR: HRRZ E,OTBSAV(TB)
844 HRRZ D,PCSAV(E) ; SEE WHERE FROM
845 CAIE D,EFCALL+1 ; 1STEP
849 CAIN D,AEVAL3 ; SKIP IF NOT RIGHT
851 SKIPG E.ARG+1(TB) ; SKIP IF REAL FORM EXISTS
855 SUB TP,[E.EXTR+2,,E.EXTR+2] ; FLUSH JUNK
858 MCALL 1,EXPAND ; EXPAND THE MACRO
861 MCALL 1,EVAL ; EVAL THE RESULT
864 APMAC1: MOVE C,E.FCN+1(TB) ; GET MACRO BODY
868 JSP E,CHKAB ; FIX DEFERS
873 ; HERE TO APPLY EXPRS (FUNCTIONS)
875 APEXPR: PUSHJ P,APEXP ; BIND ARGS AND AUX'S
876 RUNFUN: HRRZ A,RE.FCN(TB) ; AMOUNT OF FCN TO SKIP
877 MOVEI C,RE.FCN+1(TB) ; POINT TO FCN
878 HRRZ C,(C) ; SKIP SOMETHING
879 SOJGE A,.-1 ; UNTIL 1ST FORM
880 MOVEM C,RE.FCN+1(TB) ; AND STORE
881 JRST DOPROG ; GO RUN PROGRAM
883 APEXP: SKIPN C,E.FCN+1(TB) ; CHECK FRO BODY
885 APEXPF: PUSH P,[0] ; COUNT INIT CRAP
886 ADD TP,[XP.TMP,,XP.TMP] ; SLOTS FOR HACKING
889 SETZM 1-XP.TMP(TP) ; ZERO OUT
890 MOVEI A,-XP.TMP+2(TP)
892 BLT A,(TP) ; ZERO SLOTS
894 AOS E.CNT(TB) ; INDICATES IF MUST EVAL ARGS
895 MOVSI A,400000 ; MAKE E.ARG BE NEG FOR SAFE @ING
897 PUSHJ P,CARATC ; SEE IF HEWITT ATOM EXISTS
898 JRST APEXP1 ; NO, GO LOOK FOR ARGLIST
899 MOVEM E,E.HEW+1(TB) ; SAVE ATOM
900 MOVSM 0,E.HEW(TB) ; AND TYPE
901 AOS (P) ; COUNT HEWITT ATOM
902 APEXP1: GETYP 0,(C) ; LOOK AT NEXT THING
903 CAIE 0,TLIST ; BETTER BE LIST!!!
905 MOVE B,1(C) ; GET LIST
906 MOVEM B,E.ARGL+1(TB) ; SAVE
907 MOVSM 0,E.ARGL(TB) ; WITH TYPE
908 HRRZ C,(C) ; CDR THE FCN
909 JUMPE C,NOBODY ; BODYLESS FCN
910 GETYP 0,(C) ; SEE IF DCL LIST SUPPLIED
912 JRST APEXP2 ; NO, START PROCESSING ARGS
920 ; CHECK FOR EXISTANCE OF EXTRA ARG
922 APEXP2: POP P,A ; GET COUNT
923 HRRM A,E.FCN(TB) ; AND SAVE
924 SKIPN E.EXTR(TB) ; SKIP IF FUNNY EXTRA ARG EXISTS
928 HRRM 0,E.ARG(TB) ; SAVE OLD GETTER AROUND
933 ; LOOK FOR "BIND" DECLARATION
935 APEXP3: PUSHJ P,UNPROG ; UNASSIGN LPROG IF NEC
936 APXP3A: SKIPN A,E.ARGL+1(TB) ; GET ARGLIST
937 JRST APEXP4 ; NONE, VERIFY NONE WERE GIVEN
938 PUSHJ P,NXTDCL ; SEE IF A DECL IS THERE
939 JRST BNDRG ; NO, GO BIND NORMAL ARGS
940 HRRZ C,(A) ; CDR THE DCLS
941 CAME B,[ASCII /BIND/]
942 JRST CH.CAL ; GO LOOK FOR "CALL"
943 PUSHJ P,CARTMC ; MUST BE AN ATOM
944 MOVEM C,E.ARGL+1(TB) ; AND SAVE CDR'D ARGS
945 PUSHJ P,MAKENV ; GENERATE AN ENVIRONMENT
946 PUSHJ P,PSBND1 ; PUSH THE BINDING AND CHECK THE DCL
947 JRST APXP3A ; IN CASE <"BIND" B "BIND" C......
950 ; LOOK FOR "CALL" DCL
952 CH.CAL: CAME B,[ASCII /CALL/]
953 JRST CHOPT ; TRY SOMETHING ELSE
954 ; SKIPG E.ARG+1(TB) ; DONT SKIP IF CANT WIN
957 PUSHJ P,CARTMC ; BETTER BE AN ATOM
959 MOVE A,E.FRM(TB) ; RETURN FORM
961 PUSHJ P,PSBND1 ; BIND AND CHECK
964 ; BIND NORMAL ARGS BY CALLING BNDEM1, RETURNS WHEN ALL DONE
966 BNDRG: PUSHJ P,BNDEM1 ; GO BIND THEM UP
967 TRNN A,4 ; SKIP IF HIT A DCL
968 JRST APEXP4 ; NOT A DCL, MUST BE DONE
970 ; LOOK FOR "OPTIONAL" DECLARATION
972 CHOPT: CAMN B,[<ASCII /OPT/>]
974 CAME B,[<ASCII /OPTIO/>+1]
975 JRST CHREST ; TRY TUPLE/ARGS
976 MOVEM C,E.ARGL+1(TB) ; SAVE RESTED ARGLIST
977 PUSHJ P,BNDEM2 ; DO ALL SUPPLIED OPTIONALS
978 TRNN A,4 ; SKIP IF NEW DCL READ
981 ; CHECK FOR "ARGS" DCL
983 CHREST: CAME B,[ASCII /ARGS/]
984 JRST CHRST1 ; GO LOOK FOR "TUPLE"
985 ; SKIPGE E.ARG+1(TB) ; SKIP IF LEGAL
988 PUSHJ P,CARTMC ; GOBBLE ATOM
989 MOVEM C,E.ARGL+1(TB) ; SAVE CDR'D ARG
990 HRRZ B,@E.FRM+1(TB) ; GET ARG LIST
991 MOVSI A,TLIST ; GET TYPE
995 ; HERE TO CHECK FOR "TUPLE"
997 CHRST1: CAME B,[ASCII /TUPLE/]
999 PUSHJ P,CARTMC ; GOBBLE ATOM
1000 MOVEM C,E.ARGL+1(TB)
1002 PUSHJ P,PSHBND ; SET UP BINDING
1003 SETZM E.CNT+1(TB) ; ZERO ARG COUNTER
1005 TUPLP: PUSHJ P,@E.ARG+1(TB) ; GET AN ARG
1012 TUPDON: PUSHJ P,MAKINF ; MAKE INFO CELL
1013 PUSH TP,$TINFO ; FENCE POST TUPLE
1015 ADDI D,TM.OFF ; COMPENSATE FOR MOVEMENT
1017 MOVE C,E.CNT+1(TB) ; GET COUNT
1019 HRRM C,-1(TP) ; INTO FENCE POST
1020 MOVEI B,-TM.OFF-1(TP) ; SETUP ARG POINTER
1021 SUBI B,(C) ; POINT TO BASE OF TUPLE
1022 MOVNS C ; FOR AOBJN POINTER
1023 HRLI B,(C) ; GOOD ARGS POINTER
1024 MOVEM A,TM.OFF-4(B) ; STORE
1028 ; CHECK FOR VALID ENDING TO ARGS
1030 APEXP5: PUSHJ P,NEXTD ; READ NEXT THING IN ARGLIST
1032 TRNN A,4 ; SKIP IF DCL
1034 APEXP7: MOVSI A,-NWINS ; CHECK FOR A WINNER
1037 JUMPGE A,MPD.6 ; NOT A WINNER
1039 ; HERE TO BLT THE WORLD DOWN ON TOP OF ALL THE USELESS TEMPS
1041 APEXP8: MOVE 0,E.HEW+1(TB) ; GET HEWITT ATOM
1042 MOVE E,E.FCN(TB) ; SAVE COUNTER
1043 MOVE C,E.FCN+1(TB) ; FCN
1044 MOVE B,E.ARGL+1(TB) ; ARG LIST
1045 MOVE D,E.DECL+1(TB) ; AND DCLS
1046 MOVEI A,R.TMP(TB) ; SET UP BLT
1048 BLT A,-TM.OFF(TP) ; BLLLLLLLLLLLLLT
1049 SUB TP,[TM.OFF,,TM.OFF] ; FLUSH CRUFT
1051 MOVEM C,RE.FCN+1(TB)
1052 MOVEM B,RE.ARGL+1(TB)
1058 GETYP A,-5(TP) ; TUPLE ON TOP?
1059 CAIE A,TINFO ; SKIP IF YES
1061 HRRZ A,-5(TP) ; GET SIZE
1064 SUB E,A ; POINT TO BINDINGS
1065 SKIPE C,(TP) ; IF DCL
1066 PUSHJ P,CHKDCL ; CHECK TYPE SPEC ON TUPLE
1067 APEXP9: PUSHJ P,USPCBE ; DO ACTUAL BINDING
1069 MOVE E,-2(TP) ; RESTORE HEWITT ATOM
1070 MOVE D,(TP) ; AND DCLS
1073 JRST AUXBND ; GO BIND AUX'S
1075 ; HERE TO VERIFY CHECK IF ANY ARGS LEFT
1077 APEXP4: PUSHJ P,@E.ARG+1(TB)
1079 JRST TMA ; TOO MANY ARGS
1082 PUSHJ P,@E.ARG+1(TB)
1088 ; LIST OF POSSIBLE TERMINATING NAMES
1092 AS.NAM: ASCII /NAME/
1094 AS.EXT: ASCII /EXTRA/
1098 ; HERE TO BIND AUX VARIABLES FOR PROGS AND FCNS
1100 AUXBND: PUSH P,E ; SAVE HEWITT ATOM ( WILL PUT ON MARKED STACK
1102 PUSH P,D ; SAME WITH DCL LIST
1103 PUSH P,[-1] ; FLAG SAYING WE ARE FCN
1104 SKIPN C,RE.ARG+1(TB) ; GET ARG LIST
1106 GETYP 0,(C) ; GET TYPE
1107 CAIE 0,TDEFER ; SKIP IF CHSTR
1108 MOVMS (P) ; SAY WE ARE IN OPTIONALS
1113 PUSH P,[0] ; WE ARE IN AUXS
1115 AUXB1: HRRZ C,RE.ARG+1(TB) ; POINT TO ARGLIST
1116 PUSHJ P,NEXTDC ; GET NEXT THING OFF OF ARG LIST
1118 TRNE A,4 ; SKIP IF SOME KIND OF ATOM
1119 JRST TRYDCL ; COUDL BE DCL
1120 TRNN A,1 ; SKIP IF QUOTED
1122 SKIPN (P) ; SKIP IF QUOTED OK
1124 AUXB2: PUSHJ P,PSHBND ; SET UP BINDING
1125 PUSH TP,$TDECL ; SAVE HEWITT ATOM
1127 PUSH TP,$TATOM ; AND DECLS
1129 TRNN A,2 ; SKIP IF INIT VAL EXISTS
1130 JRST AUXB3 ; NO, USE UNBOUND
1132 ; EVALUATE EXPRESSION
1134 HRRZ C,(B) ; CDR ATOM OFF
1136 ; CHECK FOR SPECIAL FORMS <TUPLE ...> <ITUPLE ...>
1138 GETYP 0,(C) ; GET TYPE OF GOODIE
1139 CAIE 0,TFORM ; SMELLS LIKE A FORM
1141 HRRZ D,1(C) ; GET 1ST ELEMENT
1142 GETYP 0,(D) ; AND ITS VAL
1143 CAIE 0,TATOM ; FEELS LIKE THE RIGHT FORM
1146 MOVE 0,1(D) ; GET THE ATOM
1147 CAME 0,IMQUOTE TUPLE
1148 CAMN 0,MQUOTE ITUPLE
1149 JRST DOTUPL ; SURE GLAD I DIDN'T STEP IN THAT FORM
1152 AUXB13: PUSHJ P,FASTEV
1154 AUXB4: MOVEM A,-7(E) ; STORE VAL IN BINDING
1157 ; HERE TO CHECK AGAINST DECLARATIONS AND COMPLETE THE BINDING
1159 AUXB5: SUB E,[4,,4] ; POINT TO BINDING TOP
1160 SKIPE C,-2(TP) ; POINT TO DECLARATINS
1161 PUSHJ P,CHKDCL ; CHECK IT
1162 PUSHJ P,USPCBE ; AND BIND UP
1163 SKIPE C,RE.ARG+1(TB) ; CDR DCLS
1164 HRRZ C,(C) ; IF ANY TO CDR
1165 MOVEM C,RE.ARG+1(TB)
1166 MOVE A,(TP) ; NOW PUT HEWITT ATOM AND DCL AWAY
1170 SUB TP,[4,,4] ; FLUSH SLOTS
1180 ; HERE TO HANDLE "CALLS" TO TUPLE AND ITUPLE
1182 DOTUPL: SKIPE E,(P) ; SKIP IF IN AUX LIST
1184 PUSH TP,$TLIST ; SAVE THE MAGIC FORM
1186 CAME 0,IMQUOTE TUPLE
1187 JRST DOITUP ; DO AN ITUPLE
1189 ; FALL INTO A TUPLE PUSHING LOOP
1191 DOTUP1: HRRZ C,@(TP) ; CDR THE FORM
1192 JUMPE C,ATUPDN ; FINISHED
1193 MOVEM C,(TP) ; SAVE CDR'D RESULT
1194 GETYP 0,(C) ; CHECK FOR SEGMENT
1196 JRST DTPSEG ; GO PULL IT APART
1197 PUSHJ P,FASTEV ; EVAL IT
1198 PUSHJ P,CNTARG ; PUSH IT UP AND COUNT THEM
1201 ; HERE WHEN WE FINISH
1203 ATUPDN: SUB TP,[2,,2] ; FLUSH THE LIST
1204 ASH E,1 ; E HAS # OF ARGS DOUBLE IT
1205 MOVEI D,(TP) ; FIND BASE OF STACK AREA
1207 MOVSI C,-3(D) ; PREPARE BLT POINTER
1208 BLT C,C ; HEWITT ATOM AND DECL TO 0,A,B,C
1210 ; NOW PREPEARE TO BLT TUPLE DOWN
1212 MOVEI D,-3(D) ; NEW DEST
1213 HRLI D,4(D) ; SOURCE
1214 BLT D,-4(TP) ; SLURP THEM DOWN
1216 HRLI E,TINFO ; SET UP FENCE POST
1217 MOVEM E,-3(TP) ; AND STORE
1218 PUSHJ P,TBTOTP ; GET OFFSET
1219 ADDI D,3 ; FUDGE FOR NOT AT TOP OF STACK
1221 MOVEM 0,-1(TP) ; RESTORE HEW ATOM AND DECLS
1226 PUSHJ P,MAKINF ; MAKE 1ST WORD OF FUNNYS
1228 HRRZ E,-5(TP) ; RESTORE WORDS OF TUPLE
1229 HRROI B,-5(TP) ; POINT TO TOP OF TUPLE
1230 SUBI B,(E) ; NOW BASE
1231 TLC B,-1(E) ; FIX UP AOBJN PNTR
1232 ADDI E,2 ; COPNESATE FOR FENCE PST
1234 SUBM TP,E ; E POINT TO BINDING
1235 JRST AUXB4 ; GO CLOBBER IT IN
1238 ; HERE TO HANDLE SEGMENTS IN THESE FUNNY FORMS
1240 DTPSEG: PUSH TP,$TFORM ; SAVE THE HACKER
1242 MCALL 1,EVAL ; AND EVALUATE IT
1243 MOVE D,B ; GET READY FOR A SEG LOOP
1245 PUSHJ P,TYPSEG ; TYPE AND CHECK IT
1247 DTPSG1: INTGO ; DONT BLOW YOUR STACK
1248 PUSHJ P,NXTLM ; ELEMENT TO A AND B
1250 PUSHJ P,CNTARG ; PUSH AND COUNT
1253 DTPSG2: SETZM DSTORE
1254 HRRZ E,-1(TP) ; GET COUNT IN CASE END
1255 JRST DOTUP1 ; REST OF ARGS STILL TO DO
1257 ; HERE TO HACK <ITUPLE .....>
1259 DOITUP: HRRZ C,@(TP) ; GET COUNT FILED
1262 PUSHJ P,FASTEV ; EVAL IT
1269 HRRZ C,@(TP) ; GET EXP TO EVAL
1270 MOVEI 0,0 ; DONT LOSE IN 1 ARG CASE
1271 HRRZ 0,(C) ; VERIFY WINNAGE
1272 JUMPN 0,TMA ; TOO MANY
1275 PUSH P,B ; SAVE COUNT
1278 PUSHJ P,FASTEV ; EVAL IT ONCE
1290 DOIDO1: MOVE B,-1(P) ; RESTORE COUNT
1296 ; FOR CASE OF NO EVALE
1298 DOILOS: SUB TP,[2,,2]
1306 ; ROUTINE TO PUSH NEXT TUPLE ELEMENT
1308 CNTARG: AOS E,-1(TP) ; KEEP ARG COUNT UP TO DATE IN E
1309 CNTRG: EXCH A,-1(TP) ; STORE ELEM AND GET SAVED
1316 ; DUMMY TUPLE AND ITUPLE
1318 IMFUNCTION TUPLE,SUBR
1321 ERRUUO EQUOTE NOT-IN-AUX-LIST
1323 MFUNCTIO ITUPLE,SUBR
1327 ; PROCESS A DCL IN THE AUX VAR LISTS
1329 TRYDCL: SKIPN (P) ; SKIP IF NOT IN AUX'S
1331 CAME B,AS.AUX ; "AUX" ?
1332 CAMN B,AS.EXT ; OR "EXTRA"
1334 CAME B,[ASCII /TUPLE/]
1336 PUSHJ P,MAKINF ; BUILD EMPTY TUPLE
1338 PUSH TP,$TINFO ; FENCE POST
1341 AUXB6: HRRZ C,(C) ; CDR PAST DCL
1342 MOVEM C,RE.ARG+1(TB)
1343 AUXB8: PUSHJ P,CARTMC ; GET ATOM
1344 AUXB12: PUSHJ P,PSHBND ; UP GOES THE BINDING
1345 PUSH TP,$TATOM ; HIDE HEWITT ATOM AND DCL
1354 AUXB10: CAME B,[ASCII /ARGS/]
1356 MOVEI B,0 ; NULL ARG LIST
1358 JRST AUXB6 ; GO BIND
1360 AUXB9: SETZM (P) ; NOW READING AUX
1362 MOVEM C,RE.ARG+1(TB)
1365 ; CHECK FOR NAME/ACT
1367 AUXB7: CAME B,AS.NAM
1372 HRRZ 0,(C) ; BETTER BE END
1374 PUSHJ P,CARTMC ; FORCE ATOM READ
1376 AUXB11: PUSHJ P,MAKACT ; MAKE ACTIVATION
1377 JRST AUXB12 ; AND BIND IT
1380 ; DONE BIND HEWITT ATOM IF NECESARY
1382 AUXDON: SKIPN E,-2(P)
1393 ; MAKE AN ACTIVATION OR ENVIRONMNENT
1395 MAKACT: MOVEI B,(TB)
1397 MAKAC1: MOVE PVP,PVSTOR+1
1398 HRRI A,PVLNT*2+1(PVP) ; POINT TO PROCESS
1399 HLL B,OTBSAV(B) ; GET TIME
1402 MAKENV: MOVSI A,TENV
1406 ; SEVERAL USEFUL LITTLE ROUTINES FOR HACKING THIS STUFF
1408 ; CARAT/CARATC/CARATM/CARTMC ALL LOOK FOR THE NEXT ATOM
1410 CARAT: HRRZ C,E.ARGL+1(TB) ; PICK UP ARGLIST
1411 CARATC: JUMPE C,CPOPJ ; FOUND
1412 GETYP 0,(C) ; GET ITS TYPE
1414 CPOPJ: POPJ P, ; RETURN, NOT ATOM
1415 MOVE E,1(C) ; GET ATOM
1416 HRRZ C,(C) ; CDR DCLS
1419 CARATM: HRRZ C,E.ARGL+1(TB)
1420 CARTMC: PUSHJ P,CARATC
1421 JRST MPD.7 ; REALLY LOSE
1425 ; SUBROUTINES TO PUSH BINDINGS ETC. UP ON THE STACK
1427 PSBND1: PUSHJ P,PSHBND ; PUSH THEBINDING
1428 JRST CHDCL ; NOW CHECK IT AGAINST DECLARATION
1430 PSHBND: SKIPGE SPCCHK ; SKIP IF NORMAL SPECIAL
1431 PUSH TP,BNDA1 ; ATOM IN E
1432 SKIPL SPCCHK ; SKIP IF NORMAL UNSPEC OR NO CHECK
1441 ; ROUTINE TO PUSH 4 0'S
1447 ; EXTRRA ARG GOBBLER
1449 EXTRGT: HRRZ A,E.ARG(TB) ; RESET SLOT
1451 CAIE A,ARGCDR ; IF NOT ARGCDR
1453 TLO A,400000 ; SET FLAG
1455 MOVE A,E.EXTR(TB) ; RET ARG
1459 ; CHECK A/B FOR DEFER
1462 CAIE 0,TDEFER ; SKIP IF DEFER
1465 MOVE B,1(B) ; GET REAL THING
1467 ; IF DECLARATIONS EXIST, DO THEM
1470 CHDCLE: SKIPN C,E.DECL+1(TB)
1474 ; ROUTINE TO READ NEXT THING FROM ARGLIST
1476 NEXTD: HRRZ C,E.ARGL+1(TB) ; GET ARG LIST
1479 PUSHJ P,CARATC ; TRY FOR AN ATOM
1483 NEXTD1: CAIE 0,TFORM ; FORM?
1484 JRST NXT.L ; COULD BE LIST
1485 PUSHJ P,CHQT ; VERIFY 'ATOM
1489 NXT.L: CAIE 0,TLIST ; COULD BE (A <EXPRESS>) OR ('A <EXPRESS>)
1490 JRST NXT.S ; BETTER BE A DCL
1491 PUSHJ P,LNT.2 ; VERIFY LENGTH IS 2
1493 CAIE 0,TATOM ; TYPE OF 1ST RET IN 0
1494 JRST LST.QT ; MAY BE 'ATOM
1495 MOVE E,1(B) ; GET ATOM
1498 LST.QT: CAIE 0,TFORM ; FORM?
1501 MOVEI C,(B) ; VERIFY 'ATOM
1503 MOVEI B,(C) ; POINT BACK TO LIST
1508 NXT.S: MOVEI A,(C) ; LET NXTDCL FIND OUT
1511 MOVEI A,4 ; SET DCL READ FLAG
1514 ; ROUTINE TO CHECK LENGTH OF LIST/FORM FOR BEING 2
1516 LNT.2: HRRZ B,1(C) ; GET LIST/FORM
1520 HRRZ B,(B) ; BETTER END HERE
1522 HRRZ B,1(C) ; LIST BACK
1523 GETYP 0,(B) ; TYPE OF 1ST ELEMENT
1526 ; ROUTINE TO VERIFY FORM IS 'ATOM AND RET ATOM
1528 CHQT: PUSHJ P,LNT.2 ; 1ST LENGTH CHECK
1533 CAME 0,IMQUOTE QUOTE
1534 JRST MPD.5 ; BETTER BE QUOTE
1539 MOVE E,1(E) ; GET QUOTED ATOM
1542 ; ARG BINDER FOR REGULAR ARGS AND OPTIONALS
1544 BNDEM1: PUSH P,[0] ; REGULAR FLAG
1547 BNDEM: PUSHJ P,NEXTD ; GET NEXT THING
1548 JRST CCPOPJ ; END OF THINGS
1549 TRNE A,4 ; CHECK FOR DCL
1551 TRNE A,2 ; SKIP IF NOT (ATM ..) OR ('ATM ...)
1552 SKIPE (P) ; SKIP IF REG ARGS
1553 JRST .+2 ; WINNER, GO ON
1556 PUSH TP,BNDA1 ; SAVE ATOM
1560 ; SKIPGE E.ARG+1(TB) ; ALREADY EVAL'D ARG?
1563 TRNN A,1 ; SKIP IF ARG QUOTED
1565 HRRZ D,@E.FRM+1(TB) ; GET AND CDR ARG
1566 JUMPE D,TFACHK ; OH OH MAYBE TOO FEW ARGS
1567 MOVEM D,E.FRM+1(TB) ; STORE WINNER
1568 HLLZ A,(D) ; GET ARG
1570 JSP E,CHKAB ; HACK DEFER
1571 JRST BNDEM3 ; AND GO ON
1573 RGLAR0: TRNE A,1 ; ATTEMPT TO QUOTE ALREADY EVAL'D ARG ?
1574 JRST MPD ; YES, LOSE
1575 RGLARG: PUSH P,A ; SAVE FLAGS
1576 PUSHJ P,@E.ARG+1(TB)
1577 JRST TFACH1 ; MAY GE TOO FEW
1579 BNDEM3: HRRZ C,@E.ARGL+1(TB) ; CDR THHE ARGS
1580 MOVEM C,E.ARGL+1(TB)
1581 PUSHJ P,PSHAB4 ; PUSH VALUE AND SLOTS
1582 PUSHJ P,CHDCL ; CHECK DCLS
1583 JRST BNDEM ; AND BIND ON!
1585 ; HERE WHEN ARGS RUN OUT, IF NOT OPTIONAL, GIVE TFA
1588 TFACHK: SUB TP,[2,,2] ; FLUSH ATOM
1589 SKIPN (P) ; SKIP IF OPTIONALS
1591 CCPOPJ: SUB P,[1,,1]
1594 BNDEM4: HRRZ C,@E.ARGL+1(TB) ; POINT TO REST OF ARGL
1598 ; EVALUATE LISTS, VECTORS, UNIFROM VECTORS
1600 EVLIST: PUSH P,[-1] ;-1 -- THIS IS A LIST
1601 JRST EVL1 ;GO TO HACKER
1603 EVECT: PUSH P,[0] ;0 -- THIS IS A GENERAL VECTOR
1606 EUVEC: PUSH P,[1] ;1 -- THIS IS A UNIFORM VECTOR
1608 EVL1: PUSH P,[0] ;PUSH A COUNTER
1609 GETYPF A,(AB) ;GET FULL TYPE
1611 PUSH TP,1(AB) ;AND VALUE
1613 EVL2: INTGO ;CHECK INTERRUPTS
1614 SKIPN A,1(TB) ;ANYMORE
1616 SKIPL -1(P) ;SKIP IF LIST
1617 JUMPG A,EVL3 ;JUMP IF VECTOR EMPTY
1618 GETYPF B,(A) ;GET FULL TYPE
1619 SKIPGE C,-1(P) ;SKIP IF NOT LIST
1620 HLLZS B ;CLOBBER CDR FIELD
1621 JUMPG C,EVL7 ;HACK UNIFORM VECS
1622 EVL8: PUSH P,B ;SAVE TYPE WORD ON P
1623 CAMN B,$TSEG ;SEGMENT?
1624 MOVSI B,TFORM ;FAKE OUT EVAL
1625 PUSH TP,B ;PUSH TYPE
1626 PUSH TP,1(A) ;AND VALUE
1627 JSP E,CHKARG ; CHECK DEFER
1628 MCALL 1,EVAL ;AND EVAL IT
1629 POP P,C ;AND RESTORE REAL TYPE
1630 CAMN C,$TSEG ;SEGMENT?
1631 JRST DOSEG ;YES, HACK IT
1632 AOS (P) ;COUNT ELEMENT
1633 PUSH TP,A ;AND PUSH IT
1635 EVL6: SKIPGE A,-1(P) ;DONT SKIP IF LIST
1636 HRRZ B,@1(TB) ;CDR IT
1637 JUMPL A,ASTOTB ;AND STORE IT
1638 MOVE B,1(TB) ;GET VECTOR POINTER
1639 ADD B,AMNT(A) ;INCR BY APPROPRIATE AMOUNT
1640 ASTOTB: MOVEM B,1(TB) ;AND STORE BACK
1641 JRST EVL2 ;AND LOOP BACK
1643 AMNT: 2,,2 ;INCR FOR GENERAL VECTOR
1644 1,,1 ;SAME FOR UNIFORM VECTOR
1646 CHKARG: GETYP A,-1(TP)
1649 HRRZS (TP) ;MAKE SURE INDIRECT WINS
1651 MOVEM A,-1(TP) ;CLOBBER IN TYPE SLOT
1652 MOVE A,(TP) ;NOW GET POINTER
1653 MOVE A,1(A) ;GET VALUE
1654 MOVEM A,(TP) ;CLOBBER IN
1659 EVL7: HLRE C,A ; FIND TYPE OF UVECTOR
1660 SUBM A,C ;C POINTS TO DOPE WORD
1661 GETYP B,(C) ;GET TYPE
1662 MOVSI B,(B) ;TO LH NOW
1663 SOJA A,EVL8 ;AND RETURN TO DO EVAL
1665 EVL3: SKIPL -1(P) ;SKIP IF LIST
1666 JRST EVL4 ;EITHER VECTOR OR UVECTOR
1668 MOVEI B,0 ;GET A NIL
1669 EVL9: MOVSI A,TLIST ;MAKE TYPE WIN
1670 EVL5: SOSGE (P) ;COUNT DOWN
1671 JRST EVL10 ;DONE, RETURN
1672 PUSH TP,$TLIST ;SET TO CALL CONS
1675 JRST EVL5 ;LOOP TIL DONE
1678 EVL4: MOVEI B,EUVECT ;UNIFORM CASE
1679 SKIPG -1(P) ;SKIP IF UNIFORM CASE
1680 MOVEI B,EVECTO ;NO, GENERAL CASE
1682 .ACALL A,(B) ;CALL CREATOR
1683 EVL10: GETYPF A,(AB) ; USE SENT TYPE
1687 ; PROCESS SEGMENTS FOR THESE HACKS
1689 DOSEG: PUSHJ P,TYPSEG ; FIND WHAT IS BEING SEGMENTED
1690 JUMPE C,LSTSEG ; CHECK END SPLICE IF LIST
1692 SEG3: PUSHJ P,NXTELM ; GET THE NEXTE ELEMT
1693 JRST SEG4 ; RETURN TO CALLER
1695 JRST SEG3 ; TRY AGAIN
1699 TYPSEG: PUSHJ P,TYPSGR
1703 TYPSGR: MOVE E,A ; SAVE TYPE
1704 GETYP A,A ; TYPE TO RH
1705 PUSHJ P,SAT ;GET STORAGE TYPE
1706 MOVE D,B ; GOODIE TO D
1708 MOVNI C,1 ; C <0 IF ILLEGAL
1709 CAIN A,S2WORD ;LIST?
1711 CAIN A,S2NWORD ;GENERAL VECTOR?
1713 CAIN A,SNWORD ;UNIFORM VECTOR?
1719 CAIN A,SSTORE ;SPECIAL AFREE STORAGE ?
1720 MOVEI C,4 ;TREAT LIKE A UVECTOR
1721 CAIN A,SARGS ;ARGS TUPLE?
1722 JRST SEGARG ;NO, ERROR
1723 CAILE A,NUMSAT ; SKIP IF NOT TEMPLATE
1727 MOVEI A,2 ; NOW TREAT LIKE A UVECTOR
1729 MSTOR1: JUMPL C,CPOPJ
1731 MDSTOR: MOVEM E,DSTORE
1738 SEGARG: MOVSI A,TARGS
1740 PUSH TP,A ;PREPARE TO CHECK ARGS
1742 MOVEI B,-1(TP) ;POINT TO SAVED COPY
1743 PUSHJ P,CHARGS ;CHECK ARG POINTER
1744 POP TP,D ;AND RESTORE WINNER
1745 POP TP,E ;AND TYPE AND FALL INTO VECTOR CODE
1749 LSTSEG: SKIPL -1(P) ;SKIP IF IN A LIST
1750 JRST SEG3 ;ELSE JOIN COMMON CODE
1751 HRRZ A,@1(TB) ;CHECK FOR END OF LIST
1752 JUMPN A,SEG3 ;NO, JOIN COMMON CODE
1753 SETZM DSTORE ;CLOBBER SAVED GOODIES
1754 JRST EVL9 ;AND FINISH UP
1757 PUSHJ P,NXTLM ; GOODIE TO A AND B
1762 NXTLM: XCT TESTR(C) ; SKIP IF MORE IN SEGEMNT
1764 XCT TYPG(C) ; GET THE TYPE
1765 XCT VALG(C) ; AND VALUE
1766 JSP E,CHKAB ; CHECK DEFERRED
1767 XCT INCR1(C) ; AND INCREMENT TO NEXT
1768 CPOPJ1: AOS (P) ; SKIP RETURN
1771 ; TABLES FOR SEGMENT OPERATIONS (0->LIST, 1->VECTOR/ARGS, 2->UVEC, 3->STRING)
1787 TYPG: PUSHJ P,LISTYP
1810 HRRZ A,DSTORE ; GET SAT
1815 HLRZ 0,C ; GET AMNT RESTED
1830 MOVEI C,0 ; GET "1ST ELEMENT"
1831 PUSHJ P,TMPLNT ; GET NTH IN A AND B
1837 CHRDON: HRRZ B,DSTORE
1839 HRRZ B,DSTORE ; POIT TO DOPE WORD
1867 ;COMPILER's CALL TO DOSEG
1868 SEGMNT: PUSHJ P,TYPSEG
1870 SEGLOP: PUSHJ P,NXTELM
1872 AOS (P)-2 ; INCREMENT COMPILER'S COUNT
1875 SEGRET: SETZM DSTORE
1878 SEGLST: PUSHJ P,TYPSEG
1880 SEGLS3: SETZM DSTORE
1882 SEGLS1: SOSGE -2(P) ; START COUNT DOWN
1890 SEGLS2: PUSHJ P,NXTELM
1899 ;SPECBIND BINDS IDENTIFIERS. IT IS CALLED BY PUSHJ P,SPECBIND.
1900 ;SPECBIND IS PROVIDED WITH A CONTIGUOUS SET OF TRIPLETS ON TP.
1901 ;EACH TRIPLET IS AS FOLLOWS:
1902 ;THE FIRST ELEMENT IS THE IDENTIFIER TO BE BOUND, ITS TYPE WORD IS [TATOM,,-1],
1903 ;THE SECOND IS THE VALUE TO WHICH IT IS TO BE ASSIGNED,
1904 ;AND THE THIRD IS A PAIR OF ZEROES.
1912 USPCBE: PUSH P,$TUBIND
1916 MOVE E,TP ;GET THE POINTER TO TOP
1917 SPECBE: PUSH P,$TBIND
1918 ADD E,[1,,1] ;BUMP POINTER ONCE
1919 SETZB 0,D ;CLEAR TEMPS
1921 MOVEI 0,(TB) ; FOR CHECKS
1923 BINDLP: MOVE A,-4(E) ; CHECK FOR VEC BIND
1926 MOVE A,-6(E) ;GET TYPE
1927 CAME A,BNDA1 ; FOR UNSPECIAL
1928 CAMN A,BNDA ;NORMAL ID BIND?
1929 CAILE 0,-6(E) ; MAKE SURE NOT GOING UNDER FRAME
1931 SUB E,[6,,6] ;MOVE PTR
1933 HRRM E,(D) ;YES -- LOBBER
1935 MOVEM E,(P) ;NO -- DO IT
1937 MOVE A,0(E) ;GET ATOM PTR
1939 PUSHJ P,SILOC ;GET LAST BINDING
1940 MOVS A,OTBSAV (TB) ;GET TIME
1941 HRL A,5(E) ; GET DECL POINTER
1942 MOVEM A,4(E) ;CLOBBER IT AWAY
1943 MOVE A,(E) ; SEE IF SPEC/UNSPEC
1944 TRNN A,1 ; SKIP, ALWAYS SPEC
1945 SKIPA A,-1(P) ; USE SUPPLIED
1947 MOVEM A,(E) ;IDENTIFY AS BIND BLOCK
1950 HRRZ C,SPBASE(PVP) ; CHECK FOR CROSS OF PROC
1953 CAILE C,(B) ; SKIP IFF WINNER
1955 SPEB10: MOVEM B,5(E) ;IN RESTORE CELLS
1957 MOVE C,1(E) ;GET ATOM PTR
1961 MOVEI B,0 ; FOR SPCUNP
1962 CAIL A,HIBOT ; SKIP IF IMPURE ATOM
1965 HRRZ A,BINDID+1(PVP) ;GET PROCESS NUMBER
1966 HRLI A,TLOCI ;MAKE LOC PTR
1967 MOVE B,E ;TO NEW VALUE
1969 MOVEM A,(C) ;CLOBBER ITS VALUE
1971 MOVE D,E ;REMEMBER LINK
1972 JRST BINDLP ;DO NEXT
1974 NONID: CAILE 0,-4(E)
1982 MOVE D,1(E) ;GET PTR TO VECTOR
1983 MOVE C,(D) ;EXCHANGE TYPES
1987 MOVE C,1(D) ;EXCHANGE DATUMS
1992 HRLM A,(E) ;IDENTIFY BIND BLOCK
1993 MOVE D,E ;REMEMBER LINK
2005 ; HERE TO IMPURIFY THE ATOM
2007 SPCUNP: PUSH TP,$TSP
2010 PUSH TP,-1(P) ; LINK BACK IS AN SP
2014 SETZM -1(TP) ; FIXUP SOME FUNNYNESS
2017 MOVE 0,-2(TP) ; RESTORE LINK BACK POINTER
2026 ; ENTRY FROM COMPILER TO SET UP A BINDING
2028 IBIND: MOVE SP,SPSTOR+1
2029 SUBI E,-5(SP) ; CHANGE TO PDL POINTER
2040 JRST SPECB1 ; NOW BIND IT
2042 ; "FAST CALL TO SPECBIND"
2046 ; Compiler's call to SPECBIND all atom bindings, no TBVLs etc.
2049 MOVE E,TP ; POINT TO BINDING WITH E
2050 SPECB1: PUSH P,[0] ; SLOTS OF INTEREST
2054 SPECB2: MOVEI 0,(TB) ; FOR FRAME CHECK
2055 MOVE A,-5(E) ; LOOK AT FIRST THING
2056 CAMN A,BNDA ; SKIP IF LOSER
2057 CAILE 0,-5(E) ; SKIP IF REAL WINNER
2060 SUB E,[5,,5] ; POINT TO BINDING
2062 HRRM E,(A) ; YES DO IT
2063 SKIPN -1(P) ; FIRST ONE?
2064 MOVEM E,-1(P) ; THIS IS IT
2066 MOVE A,1(E) ; POINT TO ATOM
2068 MOVE 0,BINDID+1(PVP) ; QUICK CHECK
2070 CAMN 0,(A) ; WINNERE?
2071 JRST SPECB4 ; YES, GO ON
2073 PUSH P,B ; SAVE REST OF ACS
2076 MOVE B,A ; FOR ILOC TO WORK
2077 PUSHJ P,SILOC ; GO LOOK IT UP
2080 HRRZ C,SPBASE+1(PVP)
2082 CAIL A,(B) ; SKIP IF LOSER
2083 CAILE C,(B) ; SKIP IF WINNER
2084 MOVEI B,1 ; SAY NO BACK POINTER
2085 SPECB9: MOVE C,1(E) ; POINT TO ATOM
2086 SKIPE (C) ; IF GLOBALLY BOUND, MAKE SURE OK
2088 MOVEI A,(C) ; PURE ATOM?
2089 CAIGE A,HIBOT ; SKIP IF OK
2091 PUSH P,-4(P) ; MAKE HAPPINESS
2092 PUSHJ P,SPCUNP ; IMPURIFY
2095 MOVE A,BINDID+1(PVP)
2097 MOVEM A,(C) ; STOR POINTER INDICATOR
2104 SPECB4: MOVE A,1(A) ; GET LOCATIVE
2105 SPECB5: EXCH A,5(E) ; CLOBBER INTO REBIND SLOT (GET DECL)
2106 HLL A,OTBSAV(TB) ; TIME IT
2107 MOVSM A,4(E) ; SAVE DECL AND TIME
2109 HRLM A,(E) ; CHANGE TO A BINDING
2110 MOVE A,1(E) ; POINT TO ATOM
2111 MOVEM E,(P) ; REMEMBER THIS GUY
2112 ADD E,[2,,2] ; POINT TO VAL CELL
2113 MOVEM E,1(A) ; INTO ATOM SLOT
2114 SUB E,[3,,3] ; POINT TO NEXT ONE
2119 HRRM SP,(A) ; LINK OLD STUFF
2120 SKIPE A,-1(P) ; NEW SP?
2123 INTGO ; IN CASE BLEW STACK
2128 ;SPECSTORE RESTORES THE BINDINGS SP TO THE ENVIRONMENT POINTER IN
2129 ;SPSAV (TB). IT IS CALLED BY PUSHJ P,SPECSTORE.
2133 HRRZ E,SPSAV (TB) ;GET TARGET POINTER
2136 MOVE SP,SPSAV(TB) ; GET NEW SP
2140 STLOOP: MOVE SP,SPSTOR+1
2144 STLOO1: CAIL E,(SP) ;ARE WE DONE?
2146 HLRZ C,(SP) ;GET TYPE OF BIND
2149 CAIE C,TBIND ;NORMAL IDENTIFIER?
2150 JRST ISTORE ;NO -- SPECIAL HACK
2153 MOVE C,1(SP) ;GET TOP ATOM
2154 MOVSI 0,TLOCI ; MAYBE LOCI OR UNBOUND
2158 HRR 0,BINDID+1(PVP) ;STORE SIGNATURE
2160 MOVEI 0,0 ; TOTALLY UNBOUND IN ALL CASES
2161 MOVEM 0,(C) ;CLOBBER INTO ATOM
2164 SPLP: HRRZ SP,(SP) ;FOLOW LINK
2165 JUMPN SP,STLOO1 ;IF MORE
2168 STLOO2: MOVEM SP,SPSTOR+1
2182 CHSKIP: CAIN C,TSKIP
2184 CAIE C,TUNWIN ; UNWIND HACK
2186 HRRZ C,-2(P) ; WHERE FROM?
2189 MOVEI E,(TP) ; FIXUP SP
2199 ; ENTRY FOR FUNNY COMPILER UNBIND (1)
2204 SSPEC2: SUBI E,(SP) ; MAKE SP BE AOBJN
2212 ; ENTRY FOR FUNNY COMPILER UNBIND (2)
2215 SUBI E,1 ; MAKE SURE GET CURRENT BINDING
2216 PUSHJ P,STLOOP ; UNBIND
2217 MOVEI E,(TP) ; NOW RESET SP
2220 EFINIS: MOVE PVP,PVSTOR+1
2221 SKIPN C,1STEPR+1(PVP) ; SKIP NIF BEING ONE PROCEEDED
2224 PUSH TP,MQUOTE EVLOUT
2225 PUSH TP,A ;SAVE EVAL RESULTS
2227 PUSH TP,[TINFO,,2] ; FENCE POST
2230 PUSHJ P,MAKINF ; MAKE ARG BLOCK INFO
2233 HRLI B,-4 ; AOBJN TO ARGS BLOCK
2237 PUSH TP,1STEPR+1(PVP) ; PROCESS DOING THE 1STEPPING
2239 MOVE A,-3(TP) ; GET BACK EVAL VALUE
2243 1STEPI: PUSH TP,$TATOM
2244 PUSH TP,MQUOTE EVLIN
2245 PUSH TP,$TAB ; PUSH EVALS ARGGS
2247 PUSHJ P,MAKINF ; TURN INTO ARGS BLOCK
2248 MOVEM A,-1(TP) ; AND CLOBBER
2249 PUSH TP,[TINFO,,2] ; FENCE POST 2D TUPLE
2252 PUSHJ P,MAKINF ; TURN IT INTO ARGS BLOCK
2254 MOVEI B,-6(TP) ; SETUP TUPLE
2259 PUSH TP,1STEPR+1(PVP)
2260 MCALL 2,RESUME ; START UP 1STEPERR
2261 SUB TP,[6,,6] ; REMOVE CRUD
2262 GETYP A,A ; GET 1STEPPERS TYPE
2263 CAIE A,TDISMI ; IF DISMISS, STOP 1 STEPPING
2266 ; HERE TO PUSH DOWN THE 1 STEP STATE AND RUN
2269 ADD D,[1STEPR,,1STEPR] ; POINT TO 1 STEP SLOT
2270 PUSH TP,$TSP ; SAVE CURRENT SP
2275 PUSH TP,[0] ; NO 1 STEPPER UNTIL POPJ
2278 ; NOW PUSH THE ARGS UP TO RE-CALL EVAL
2281 EFARGL: JUMPGE AB,EFCALL
2287 EFCALL: ACALL A,EVAL ; NOW DO THE EVAL
2288 MOVE C,(TP) ; PRE-UNBIND
2290 MOVEM C,1STEPR+1(PVP)
2291 MOVE SP,-4(TP) ; AVOID THE UNBIND
2293 SUB TP,[6,,6] ; AND FLUSH LOSERS
2294 JRST EFINIS ; AND TRY TO FINISH UP
2296 MAKINF: HLRZ A,OTBSAV(TB) ; TIME IT
2301 TBTOTP: MOVEI D,(TB) ; COMPUTE REL DIST FROM TP TO TB
2304 ; ARRIVE HERE TO COMPLETE A COMPILER GENERATED TUPLE
2305 ; D/ LENGTH OF THE TUPLE IN WORDS
2307 MAKTU2: MOVE D,-1(P) ; GET LENGTH
2314 MAKTUP: HRLI D,TINFO ; FIRST WORD OF FENCE POST
2316 HRROI B,(TP) ; TOP OF TUPLE
2318 TLC B,-1(D) ; AOBJN IT
2321 HLRZ A,OTBSAV(TB) ; TIME IT
2325 ; HERE TO ALLOCATE SLOTS FOR COMPILER (AMNT IN A)
2328 ;Once here ==>ADDI A,1 Bug???
2333 PUSHJ P,TPOVFL ; IN CASE IT LOST
2334 INTGO ; TAKE THE GC IF NEC
2348 \f;EVALUATES A IDENTIFIER -- GETS LOCAL VALUE IF THERE IS ONE, OTHERWISE GLOBAL.
2350 IMFUNCTION VALUE,SUBR
2355 IDVAL: PUSHJ P,IDVAL1
2361 PUSH TP,B ;SAVE ARG IN CASE NEED TO CHECK GLOBAL VALUE
2362 PUSHJ P,ILVAL ;LOCAL VALUE FINDER
2363 CAME A,$TUNBOUND ;IF NOT UNBOUND OR UNASSIGNED
2364 JRST RIDVAL ;DONE - CLEAN UP AND RETURN
2365 POP TP,B ;GET ARG BACK
2368 RIDVAL: SUB TP,[2,,2]
2371 ;GETS THE LOCAL VALUE OF AN IDENTIFIER
2373 IMFUNCTION LVAL,SUBR
2381 ; MAKE AN ATOM UNASSIGNED
2383 MFUNCTION UNASSIGN,SUBR
2384 JSP E,CHKAT ; GET ATOM ARG
2386 UNASIT: CAMN A,$TUNBOU ; IF UNBOUND
2390 SETOM 1(B) ; MAKE SURE
2391 RETATM: MOVE B,1(AB)
2397 MFUNCTION GUNASSIGN,SUBR
2402 MOVE B,1(AB) ; ATOM BACK
2404 CAIL 0,HIBOT ; SKIP IF IMPURE
2405 PUSHJ P,IMPURIFY ; YES, MAKE IT IMPURE
2406 PUSHJ P,IGLOC ; RESTORE LOCATIVE
2407 HRRZ 0,-2(B) ; SEE IF MANIFEST
2408 GETYP A,(B) ; AND CURRENT TYPE
2417 ; GETS A LOCATIVE TO THE LOCAL VALUE OF AN IDENTIFIER.
2428 ;TESTS TO SEE IF AN IDENTIFIER IS LOCALLY BOUND
2430 MFUNCTION BOUND,SUBR,[BOUND?]
2437 ;TESTS TO SEE IF AN IDENTIFIER IS LOCALLY ASSIGNED
2439 MFUNCTION ASSIGP,SUBR,[ASSIGNED?]
2447 ;GETS THE GLOBAL VALUE OF AN IDENTIFIER
2449 IMFUNCTION GVAL,SUBR
2456 ;GETS A LOCATIVE TO THE GLOBAL VALUE OF AN IDENTIFIER
2458 MFUNCTION RGLOC,SUBR
2483 MOVE C,1(AB) ; GE ATOM
2485 CAIGE 0,HIBOT ; SKIP IF PURE ATOM
2488 ; MAKE ATOM AND VALUE IMPURE IF GETTING GLOC TO IT
2490 MOVE B,C ; ATOM TO B
2492 JRST GLOC ; AND TRY AGAIN
2494 ;TESTS TO SEE IF AN IDENTIFIER IS GLOBALLY ASSIGNED
2496 MFUNCTION GASSIG,SUBR,[GASSIGNED?]
2503 ; TEST FOR GLOBALLY BOUND
2505 MFUNCTION GBOUND,SUBR,[GBOUND?]
2515 CHKAT1: GETYP A,(AB)
2522 CHKAT: HLRE A,AB ; - # OF ARGS
2523 ASH A,-1 ; TO ACTUAL WORDS
2525 MOVE C,SPSTOR+1 ; FOR BINDING LOOKUPS
2526 AOJE A,CHKAT1 ; ONLY ONE ARG, NO ENVIRONMENT
2527 AOJL A,TMA ; TOO MANY
2528 GETYP A,2(AB) ; MAKE SURE OF TENV OR TFRAME
2532 CAIN A,TACT ; FOR PFISTERS LOSSAGE
2534 CAIE A,TPVP ; OR PROCESS
2536 MOVE B,3(AB) ; GET PROCESS
2537 MOVE C,SPSTOR+1 ; IN CASE ITS ME
2538 CAME B,PVSTOR+1 ; SKIP IF DIFFERENT
2539 MOVE C,SPSTO+1(B) ; GET ITS SP
2541 CHKAT3: MOVEI B,2(AB) ; POINT TO FRAME POINTER
2542 PUSHJ P,CHFRM ; VALIDITY CHECK
2543 MOVE B,3(AB) ; GET TB FROM FRAME
2544 MOVE C,SPSAV(B) ; GET ENVIRONMENT POINTER
2548 ; SILOC--CALLS ILOC IGNORING SPECIAL CHECKING
2552 ;ILOC RETURNS IN A AND B A LOCATIVE TO THE LOCAL VALUE OF THE IDENTIFIER
2553 ; PASSED TO IT IN A AND B. IF THE IDENTIFIER IS LOCALLY UNBOUND IT RETURNS
2554 ; $TUNBOUND IN A AND 0 IN B, IT IS CALLED BY PUSHJ P,ILOC.
2556 ILOC: MOVE C,SPSTOR+1 ; SETUP SEARCH START
2557 AILOC: SKIPN (B) ; ANY KIND OF VALUE AT ALL?
2559 MOVSI A,TLOCI ;MAKE A LOCATIVE TYPE CELL
2562 MOVEI E,0 ; FLAG TO CLOBBER ATOM
2563 JUMPE B,SCHSP ; IF LOOKING FOR SLOT, SEARCH NOW
2564 CAME C,SPSTOR+1 ; ENVIRONMENT CHANGE?
2565 JRST SCHSP ; YES, MUST SEARCH
2567 HRR A,BINDID+1(PVP) ;FOR THE CURRENT PROCESS
2568 CAME A,(B) ;IS THERE ONE IN THE VALUE CELL?
2569 JRST SCHLP ;NO -- SEARCH THE LOCAL BINDINGS
2570 MOVE B,1(B) ;YES -- GET LOCATIVE POINTER
2572 ILCPJ: MOVE E,SPCCHK
2573 TRNN E,1 ; SKIP IF DOING SPEC UNSPEC CHECK
2575 HRRZ E,-2(P) ; IF IGNORING, IGNORE
2582 CAMGE B,CURFCN+1(PVP)
2587 CAMGE B,SPBASE+1(PVP)
2592 POPJ P, ;FROM THE VALUE CELL
2604 CAIL D,HIBOT ; SKIP IF IMPURE ATOM
2605 SCHSP: MOVEI E,1 ; DONT STORE LOCATIVE
2607 PUSH P,E ; PUSH SWITCH
2608 MOVE E,PVSTOR+1 ; GET PROC
2609 SCHLP1: JUMPE C,UNPJ ;IF NO MORE -- LOSE
2610 CAMN B,1(C) ;ARE WE POINTING AT THE WINNER?
2612 GETYP D,(C) ; CHECK SKIP
2615 PUSH P,B ; CHECK DETOUR
2617 PUSHJ P,CHFRAM ; NON-FATAL FRAME CHECKER
2618 HRRZ E,2(C) ; CONS UP PROCESS
2621 JUMPE B,SCHLP3 ; LOSER, FIX IT
2623 MOVEI C,1(C) ; FOLLOW LOOKUP CHAIN
2624 SCHLP2: HRRZ C,(C) ;FOLLOW LINK
2629 MOVEI C,(SP) ; *** NDR'S BUG ***
2630 CAME E,PVSTOR+1 ; USE IF CURRENT PROCESS
2631 HRRZ C,SPSTO+1(E) ; USE CURRENT SP FOR PROC
2634 SCHFND: MOVE D,SPCCHK
2635 TRNN D,1 ; SKIP IF DOING SPEC UNSPEC CHECK
2637 HRRZ D,-2(P) ; IF IGNORING, IGNORE
2644 HRRZ D,CURFCN+1(PVP)
2648 HRRZ D,SPBASE+1(PVP)
2653 SCHFN1: EXCH B,C ;SAVE THE ATOM PTR IN C
2654 MOVEI B,2(B) ;MAKE UP THE LOCATIVE
2658 EXCH C,E ; RET PROCESS IN C
2659 POP P,D ; RESTORE SWITCH
2661 JUMPN D,ILOCPJ ; DONT CLOBBER ATOM
2662 MOVEM A,(E) ;CLOBBER IT AWAY INTO THE
2663 MOVE D,1(E) ; GET OLD POINTER
2664 MOVEM B,1(E) ;ATOM'S VALUE CELL
2665 JUMPE D,ILOCPJ ; IF POINTS TO GLOBAL OR OTHER PROCES
2666 ; MAKE SURE BINDING SO INDICATES
2667 MOVE D,B ; POINT TO BINDING
2668 SKIPL E,3(D) ; GO TO FIRST ONE, JUST IN CASE
2671 JRST .-3 ; LOOP THROUGH
2673 MOVEM E,3(D) ; MAGIC INDICATION
2676 UNPJ: SUB P,[1,,1] ; FLUSH CRUFT
2677 UNPJ1: MOVE C,E ; RET PROCESS ANYWAY
2680 UNPOPJ: MOVSI A,TUNBOUND
2684 FUNPJ: MOVE C,PVSTOR+1
2687 ;IGLOC RETURNS IN A AND B A LOCATIVE TO THE GLOBAL VALUE OF THE
2688 ;IDENTIFIER PASSED TO IT IN A AND B. IF THE IDENTIFIER IS GLOBALLY
2689 ;UNBPOUND IT RETURNS $TUNBOUND IN A AND 0 IN B. IT IS CALLED BY PUSHJ P,IGLOC.
2691 IGLOC: MOVSI A,TLOCI ;DO WE HAVE A LOCATIVE TO
2692 CAME A,(B) ;A PROCESS #0 VALUE?
2693 JRST SCHGSP ;NO -- SEARCH
2694 MOVE B,1(B) ;YES -- GET VALUE CELL
2699 MOVE D,GLOBSP+1 ;GET GLOBAL SP PTR
2701 SCHG1: JUMPGE D,UNPOPJ ;IF NO MORE, LEAVE
2702 CAMN B,1(D) ;ARE WE FOUND?
2704 ADD D,[4,,4] ;NO -- TRY NEXT
2708 EXCH B,D ;SAVE ATOM PTR
2709 ADD B,[2,,2] ;MAKE LOCATIVE
2713 MOVEM A,(D) ;CLOBBER IT AWAY
2717 IIGLOC: PUSH TP,$TATOM
2730 PUSHJ P,IMPURI ; IMPURIFY THE POOR ATOM
2731 PUSHJ P,BSETG ; MAKE A SLOT
2732 SETOM 1(B) ; UNBOUNDIFY IT
2741 ;ILVAL RETURNS IN A AND B THE LOCAL VALUE OF THE IDENTIFIER PASSED TO IT IN A AND B
2742 ;IF THE IDENTIFIER IS UNBOUND ITS VALUE IS $TUNBOUND IN A AND 0 IN B. IF
2743 ;IT IS UNASSIGNED ITS VALUE IS $TUNBOUND IN A AND -1 IN B. CALL - PUSHJ P,IVAL
2746 PUSHJ P,AILOC ; USE SUPPLIED SP
2749 PUSHJ P,ILOC ;GET LOCATIVE TO VALUE
2750 CHVAL: CAMN A,$TUNBOUND ;BOUND
2751 POPJ P, ;NO -- RETURN
2752 MOVSI A,TLOCD ; GET GOOD TYPE
2753 HRR A,2(B) ; SHOULD BE TIME OR 0
2755 PUSHJ P,RMONC0 ; CHECK READ MONITOR
2757 MOVE A,(B) ;GET THE TYPE OF THE VALUE
2758 MOVE B,1(B) ;GET DATUM
2761 ;IGVAL -- LIKE ILVAL EXCEPT FOR GLOBAL VALUES
2763 IGVAL: PUSHJ P,IGLOC
2768 ; COMPILERS INTERFACE TO LVAL/GVAL/SETG/SET
2770 CILVAL: MOVE PVP,PVSTOR+1
2771 MOVE 0,BINDID+1(PVP) ; CURRENT BIND
2773 CAME 0,(B) ; HURRAY FOR SPEED
2774 JRST CILVA1 ; TOO BAD
2775 MOVE C,1(B) ; POINTER
2776 MOVE A,(C) ; VAL TYPE
2777 TLNE A,.RDMON ; MONITORS?
2781 JRST CUNAS ; COMPILER ERROR
2782 MOVE B,1(C) ; GOT VAL
2786 HLRZ 0,-2(C) ; SPECIAL CHECK
2790 CAMGE C,CURFCN+1(PVP)
2795 CILVA1: SUBM M,(P) ; FIX (P)
2796 PUSH TP,$TATOM ; SAVE ATOM
2798 MCALL 1,LVAL ; GET ERROR/MONITOR
2800 POPJM: SUBM M,(P) ; REPAIR DAMAGE
2803 ; COMPILERS INTERFACE TO SET C/ ATOM A,B/ NEW VALUE
2805 CISET: MOVE PVP,PVSTOR+1
2806 MOVE 0,BINDID+1(PVP) ; CURRENT BINDING ENVIRONMENT
2808 CAME 0,(C) ; CAN WE WIN?
2809 JRST CISET1 ; NO, MORE HAIR
2810 MOVE D,1(C) ; POINT TO SLOT
2811 CISET3: HLLZ 0,(D) ; MON CHECK
2813 JRST CISET4 ; YES, LOSE
2815 IOR A,0 ; LEAVE MONITOR ON
2818 JRST CISET5 ; SPEC/UNSPEC CHECK
2819 CISET6: MOVEM A,(D) ; STORE
2823 CISET5: HLRZ 0,-2(D)
2827 CAMGE D,CURFCN+1(PVP)
2831 CISET1: SUBM M,(P) ; FIX ADDR
2832 PUSH TP,$TATOM ; SAVE ATOM
2837 PUSHJ P,ILOC ; SEARCH
2838 MOVE D,B ; POSSIBLE POINTER
2841 MOVE A,-1(TP) ; VAL BACK
2843 CAIE E,TUNBOU ; SKIP IF WIN
2844 JRST CISET2 ; GO CLOBBER IT IN
2848 CISET2: MOVE C,-2(TP) ; ATOM BACK
2849 SUBM M,(P) ; RESET (P)
2853 ; HERE TO DO A MONITORED SET
2855 CISET4: SUBM M,(P) ; AGAIN FIX (P)
2865 CLLOC: MOVE PVP,PVSTOR+1
2866 MOVE 0,BINDID+1(PVP) ; GET CURRENT LOCATIVE
2872 TRNE 0,1 ; SKIP IF NOT CHECKING
2874 CLLOC3: MOVSI A,TLOCD
2875 HRR A,2(B) ; GET BIND TIME
2881 PUSHJ P,ILOC ; LOOK IT UP
2887 CLLOC2: MCALL 1,LLOC
2890 CLLOC9: HLRZ 0,-2(B)
2894 CAMGE B,CURFCN+1(PVP)
2902 JUMPE B,PJFALS ; IF UNBOUND RET FALSE AND NO SSKIP
2912 ; COMPILER ASSIGNED?
2923 ; COMPILER GVAL B/ ATOM
2925 CIGVAL: MOVE 0,(B) ; GLOBAL VAL HERE?
2926 CAME 0,$TLOCI ; TIME=0 ,TYPE=TLOCI => GLOB VAL
2927 JRST CIGVA1 ; NO, GO LOOK
2928 MOVE C,1(B) ; POINT TO SLOT
2929 MOVE A,(C) ; GET TYPE
2932 GETYP 0,A ; CHECK FOR UNBOUND
2933 CAIN 0,TUNBOU ; SKIP IF WINNER
2942 .MCALL 1,GVAL ; GET ERROR/MONITOR
2945 ; COMPILER INTERFACET TO SETG
2947 CSETG: MOVE 0,(C) ; GET V CELL
2948 CAME 0,$TLOCI ; SKIP IF FAST
2950 HRRZ D,1(C) ; POINT TO SLOT
2951 MOVE 0,(D) ; OLD VAL
2952 CSETG3: CAIG D,HIBOT ; SKIP IF PURE ATOM
2953 TLNE 0,.WRMON ; MONITOR
2959 CSETG1: SUBM M,(P) ; FIX UP P
2965 PUSHJ P,IGLOC ; FIND GLOB LOCATIVE
2968 MOVEI D,(B) ; SETUP TO RESTORE NEW VAL
2976 CSETG4: MOVE C,-2(TP) ; ATOM BACK
2977 SUBM M,(P) ; RESET (P)
2982 PUSH TP,$TATOM ; CAUSE A SETG MONITOR
2991 CGLOC: MOVE 0,(B) ; GET CURRENT GUY
2992 CAME 0,$TLOCI ; WIN?
2994 HRRZ D,1(B) ; POINT TO SLOT
2995 CAILE D,HIBOT ; PURE?
3007 ; COMPILERS GASSIGNED?
3031 IMFUNCTION REP,FSUBR,[REPEAT]
3033 MFUNCTION BIND,FSUBR
3035 IMFUNCTION PROG,FSUBR
3037 GETYP A,(AB) ;GET ARG TYPE
3038 CAIE A,TLIST ;IS IT A LIST?
3039 JRST WRONGT ;WRONG TYPE
3040 SKIPN C,1(AB) ;GET AND CHECK ARGUMENT
3041 JRST TFA ;TOO FEW ARGS
3042 SETZB E,D ; INIT HEWITT ATOM AND DECL
3043 PUSHJ P,CARATC ; IS 1ST THING AN ATOM
3045 PUSHJ P,RSATY1 ; CDR AND GET TYPE
3046 CAIE 0,TLIST ; MUST BE LIST
3048 MOVE B,1(C) ; GET ARG LIST
3053 JRST NOP.DC ; JUMP IF NO DCL
3056 PUSHJ P,RSATYP ; CDR ON
3057 NOP.DC: PUSH TP,$TLIST
3058 PUSH TP,B ; AND ARG LIST
3059 PUSHJ P,PRGBND ; BIND AUX VARS
3062 SKIPA E,IMQUOTE LPROG,[LPROG ]INTRUP
3064 PUSHJ P,MAKACT ; MAKE ACTIVATION
3065 PUSHJ P,PSHBND ; BIND AND CHECK
3066 PUSHJ P,SPECBI ; NAD BIND IT
3068 ; HERE TO RUN PROGS FUNCTIONS ETC.
3070 DOPROG: MOVEI A,REPROG
3071 HRLI A,TDCLI ; FLAG AS FUNNY
3072 MOVEM A,(TB) ; WHERE TO AGAIN TO
3074 MOVEM C,3(TB) ; RESTART POINTER
3075 JRST .+2 ; START BY SKIPPING DECL
3077 DOPRG1: PUSHJ P,FASTEV
3078 HRRZ C,@1(TB) ;GET THE REST OF THE BODY
3079 DOPRG2: MOVEM C,1(TB)
3084 REPROG: SKIPN C,@3(TB)
3092 PFINIS: GETYP 0,(TB)
3093 CAIE 0,TDCLI ; DECL'D ?
3095 HRRZ 0,(TB) ; SEE IF RSUBR
3096 JUMPE 0,RSBVCK ; CHECK RSUBR VALUE
3097 HRRZ C,3(TB) ; GET START OF FCN
3098 GETYP 0,(C) ; CHECK FOR DECL
3100 JRST PFINI1 ; NO, JUST RETURN
3101 MOVE E,IMQUOTE VALUE
3102 PUSHJ P,PSHBND ; BUILD FAKE BINDING
3103 MOVE C,1(C) ; GET DECL LIST
3105 PUSHJ P,CHKDCL ; AND CHECK IT
3106 MOVE A,-3(TP) ; GET VAL BAKC
3110 PFINI1: HRRZ C,FSAV(TB)
3120 ; HERE TO CHECK RSUBR VALUE
3126 MOVE A,1(TB) ; GET DECL
3135 RSBVC1: MOVE C,1(TB)
3138 MOVE A,IMQUOTE VALUE
3142 MFUNCTION MRETUR,SUBR,[RETURN]
3144 HLRE A,AB ; GET # OF ARGS
3145 ASH A,-1 ; TO NUMBER
3146 AOJL A,RET2 ; 2 OR MORE ARGS
3147 PUSHJ P,PROGCH ;CHECK IN A PROG
3150 MOVEI B,-1(TP) ; VERIFY IT
3151 COMRET: PUSHJ P,CHFSWP
3153 MOVEI C,0 ; REAL NONE
3155 JUMPN A,CHFINI ; WINNER
3159 ; SEE IF MUST CHECK RETURNS TYPE
3161 CHFINI: GETYP 0,(TB) ; SPECIAL TYPE IF SO
3163 JRST FINIS ; NO, JUST FINIS
3164 MOVEI 0,PFINIS ; CAUSE TO FALL INTO FUNCTION CODE
3171 CAIE A,TACT ; AS FOR "EXIT" SHOULD BE ACTIVATION
3173 MOVEI B,(AB)+2 ; ADDRESS OF FRAME POINTER
3178 MFUNCTION AGAIN,SUBR
3180 HLRZ A,AB ;GET # OF ARGS
3183 JUMPN A,TMA ;0 ARGS?
3184 PUSHJ P,PROGCH ;CHECK FOR IN A PROG
3193 AGAD: MOVEI B,-1(TP) ; POINT TO FRAME
3195 HRRZ C,(B) ; GET RET POINT
3196 GOJOIN: PUSH TP,$TFIX
3199 PUSHJ P,CHUNW ; RESTORE FRAME, UNWIND IF NEC.
3201 HRRZ 0,FSAV(TB) ; CHECK FOR RSUBR
3215 MOVE C,OTBSAV(TB) ; AND RESTORE P FROM FATHER
3228 PUSHJ P,PROGCH ;CHECK FOR A PROG
3237 MCALL 2,MEMQ ;DOES IT HAVE THIS TAG?
3238 JUMPE B,NXTAG ;NO -- ERROR
3239 FNDGO: EXCH B,(TP) ;SAVE PLACE TO GO
3244 NLCLGO: CAIE A,TTAG ;CHECK TYPE
3247 MOVEI B,2(B) ; POINT TO SLOT
3250 GETYP 0,(A) ; SEE IF COMPILED
3256 GODON1: PUSH TP,(A) ;SAVE BODY
3259 PUSHJ P,CHUNW ;GO BACK TO CORRECT FRAME
3260 MOVE B,(TP) ;RESTORE ITERATION MARKER
3273 GETYP A,(AB) ;GET TYPE OF ARGUMENT
3274 CAIE A,TFIX ; FIX ==> COMPILED
3286 ATOTAG: CAIE A,TATOM ;CHECK THAT IT IS AN ATOM
3290 PUSHJ P,PROGCH ;CHECK PROG
3298 JUMPE B,NXTAG ;IF NOT FOUND -- ERROR
3299 EXCH A,-1(TP) ;SAVE PLACE
3309 PROGCH: MOVE B,IMQUOTE LPROG,[LPROG ]INTRUP
3310 PUSHJ P,ILVAL ;GET VALUE
3316 ; HERE TO UNASSIGN LPROG IF NEC
3318 UNPROG: MOVE B,IMQUOTE LPROG,[LPROG ]INTRUP
3321 CAIE 0,TACT ; SKIP IF MUST UNBIND
3325 MOVE E,IMQUOTE LPROG,[LPROG ]INTRUP
3327 UNMAP: HRRZ 0,FSAV(TB) ; CHECK FOR FUNNY
3328 CAIN 0,MAPPLY ; SKIP IF NOT
3330 MOVE B,IMQUOTE LMAP,[LMAP ]INTRUP
3337 MOVE E,IMQUOTE LMAP,[LMAP ]INTRUP
3339 UNSPEC: PUSH TP,BNDV
3341 ADD B,[CURFCN,,CURFCN]
3350 MFUNCTION MEXIT,SUBR,[EXIT]
3358 PUSHJ P,CHUNW ;RESTORE FRAME
3359 JRST CHFINI ; CHECK FOR WINNING VALUE
3362 MFUNCTION COND,FSUBR
3368 PUSH TP,1(AB) ;CREATE UNNAMED TEMP
3369 MOVEI B,0 ; SET TO FALSE IN CASE
3371 CLSLUP: SKIPN C,1(TB) ;IS THE CLAUSELIST NIL?
3372 JRST IFALS1 ;YES -- RETURN NIL
3373 GETYP A,(C) ;NO -- GET TYPE OF CAR
3374 CAIE A,TLIST ;IS IT A LIST?
3376 MOVE A,1(C) ;YES -- GET CLAUSE
3379 PUSH TP,B ; EVALUATION OF
3381 PUSH TP,1(A) ;THE PREDICATE
3386 JRST NXTCLS ;FALSE TRY NEXT CLAUSE
3387 MOVE C,1(TB) ;IF NOT, DO FIRST CLAUSE
3390 JUMPE C,FINIS ;(UNLESS DONE WITH IT)
3391 JRST DOPRG2 ;AS THOUGH IT WERE A PROG
3392 NXTCLS: HRRZ C,@1(TB) ;SET THE CLAUSLIST
3393 HRRZM C,1(TB) ;TO CDR OF THE CLAUSLIST
3398 IFALS1: MOVSI A,TFALSE ;RETURN FALSE
3403 MFUNCTION UNWIND,FSUBR
3407 GETYP 0,(AB) ; CHECK THE ARGS FOR WINNAGE
3408 SKIPN A,1(AB) ; NONE?
3410 HRRZ B,(A) ; CHECK FOR 2D
3415 ; Unbind LPROG and LMAPF so that nothing cute happens
3419 ; Push thing to do upon UNWINDing
3425 PUSHJ P,IUNWIN ; GOT TO INTERNAL SET UP
3427 ; Now EVAL the first form
3430 HRRZ 0,(A) ; SAVE POINTER TO OTHER GUY
3435 JSP E,CHKAB ; DEFER?
3438 MCALL 1,EVAL ; EVAL THE LOSER
3442 ; Now push slots to hold undo info on the way down
3444 IUNWIN: JUMPE M,NOUNRE
3445 HLRE 0,M ; CHECK BOUNDS
3453 NOUNRE: PUSH TP,$TTB ; DESTINATION FRAME
3455 PUSH TP,[0] ; ARGS TO WHOEVER IS DOING IT
3458 ; Now bind UNWIND word
3460 PUSH TP,$TUNWIN ; FIRST WORD OF IT
3462 HRRM SP,(TP) ; CHAIN
3464 PUSH TP,TB ; AND POINT TO HERE
3469 PUSH TP,P ; SAVE PDL ALSO
3470 MOVEM TP,-2(TP) ; SAVE FOR LATER
3473 ; Do a non-local return with UNWIND checking
3475 CHUNW: HRRZ E,SPSAV(B) ; GET DESTINATION FRAME
3476 CHUNW1: PUSH TP,(C) ; FINAL VAL
3478 JUMPN C,.+3 ; WAS THERE REALLY ANYTHING
3481 PUSHJ P,STLOOP ; UNBIND
3482 CHUNPC: SKIPA ; WILL NOT SKIP UNLESS UNWIND FOUND
3490 HRRI TB,(B) ; UPDATE TB
3496 POPUNW: MOVE SP,SPSTOR+1
3507 UNWFRM: JUMPE FRM,CPOPJ
3509 UNWFR2: JUMPE B,UNWFR1
3518 ; Here if an UNDO found
3520 GOTUND: MOVE TB,1(SP) ; GET FRAME OF UNDO
3521 MOVE A,-1(TP) ; GET FUNNY ARG FOR PASS ON
3523 MOVE TP,3(SP) ; GET FUTURE TP
3524 MOVEM C,-6(TP) ; SAVE ARG
3526 MOVE C,(TP) ; SAVED P
3528 MOVEM C,PSAV(TB) ; MAKE CONTIN WIN
3531 HRRZ C,(P) ; PC OF CHUNW CALLER
3532 HRRM C,-11(TP) ; SAVE ALSO AND GET WHERE TO GO PC
3533 MOVEM B,-10(TP) ; AND DESTINATION FRAME
3534 HRRZ C,-1(TP) ; WHERE TO UNWIND PC
3535 HRRZ 0,FSAV(TB) ; RSUBR?
3544 UNWIN1: MOVE B,-12(TP) ; POINT TO THING TO DO UNWINDING
3552 UNWIN2: MOVEI C,-7(TP) ; POINT TO SAVED RET VALS
3557 HRRZ SP,(SP) ; UNBIND THIS GUY
3558 MOVEI E,(TP) ; AND FIXUP SP
3564 JRST CHUNW ; ANY MORE TO UNWIND?
3567 ; CHFSWP - CHECK FRAMES VALIDITY AND SWAP PROCESS IF NECESSARY.
3568 ; CALLED BY ALL CONTROL FLOW
3569 ; ROUTINES (GO,RETURN,EXIT,AGAIN,ERRET...)
3571 CHFSWP: PUSHJ P,CHFRM ; CHECK FOR VALID FRAME
3572 HRRZ D,(B) ; PROCESS VECTOR DOPE WD
3574 SUBI D,-1(C) ; POINT TO TOP
3575 MOVNS C ; NEGATE COUNT
3576 HRLI D,2(C) ; BUILD PVP
3579 MOVE A,(B) ; GET FRAME
3581 CAMN E,D ; SKIP IF SWAP NEEDED
3583 PUSH TP,A ; SAVE FRAME
3586 PUSHJ P,PROCHK ; FIX UP PROCESS LISTS
3587 MOVE A,PSTAT+1(B) ; GET STATE
3590 MOVE D,B ; PREPARE TO SWAP
3594 JSP C,SWAP ; SWAP IN
3595 MOVE C,ABSTO+1(E) ; GET OLD ARRGS
3596 MOVEI A,RUNING ; FIX STATES
3598 MOVEM A,PSTAT+1(PVP)
3603 NOTRES: ERRUUO EQUOTE PROCESS-NOT-RESUMABLE
3606 ;SETG IS USED TO SET THE GLOBAL VALUE OF ITS FIRST ARGUMENT,
3607 ;AN IDENTIFIER, TO THE VALUE OF ITS SECOND ARGUMENT. ITS VALUE IS
3608 ; ITS SECOND ARGUMENT.
3610 IMFUNCTION SETG,SUBR
3612 GETYP A,(AB) ;GET TYPE OF FIRST ARGUMENT
3613 CAIE A,TATOM ;CHECK THAT IT IS AN ATOM
3614 JRST NONATM ;IF NOT -- ERROR
3615 MOVE B,1(AB) ;GET POINTER TO ATOM
3619 CAIL 0,HIBOT ; PURE ATOM?
3620 PUSHJ P,IMPURIFY ; YES IMPURIFY
3621 PUSHJ P,IGLOC ;GET LOCATIVE TO VALUE
3622 CAMN A,$TUNBOUND ;IF BOUND
3623 PUSHJ P,BSETG ;IF NOT -- BIND IT
3624 MOVE C,2(AB) ; GET PROPOSED VVAL
3626 MOVSI A,TLOCD ; MAKE SURE MONCH WINS
3627 PUSHJ P,MONCH0 ; WOULD YOU BELIEVE MONITORS!!!!
3630 HRRZ E,-2(D) ; POINT TO POSSIBLE GDECL (OR MAINIFEST)
3631 JUMPE E,OKSETG ; NONE ,OK
3632 CAIE E,-1 ; MANIFEST?
3634 GETYP 0,(D) ; IF UNBOUND, LET IT HAPPEN
3646 MOVE B,IMQUOTE REDEFINE
3647 PUSHJ P,ILVAL ; SEE IF REDEFINE OK
3654 PUSH TP,EQUOTE ATTEMPT-TO-CHANGE-MANIFEST-VARIABLE
3660 SETGTY: PUSH TP,$TVEC
3675 OKSETG: MOVEM A,(D) ;DEPOSIT INTO THE
3676 MOVEM B,1(D) ;INDICATED VALUE CELL
3687 BSETG: HRRZ A,GLOBASE+1
3692 MOVEI B,0 ; MAKE SURE OF NO EMPTY SLOTS
3694 CAMN A,$TUNBOU ; SKIP IF SLOT FOUND
3696 MOVE C,(TP) ; GET ATOM
3697 MOVEM C,-1(B) ; CLOBBER ATOM SLOT
3698 HLLZS -2(B) ; CLOBBER OLD DECL
3700 ; BSETG1: PUSH TP,GLOBASE ; MUST REALLY GROW STACK
3712 MOVE B,GVLINC ; GROW BY INDICATED GVAL SLOTS
3715 MOVE C,[6,,4] ; INDICATOR FOR AGC
3718 MOVE 0,GVLINC ; ADJUST GLOBAL SPBASE
3736 BSETGX: MOVSI A,TLOCI
3737 PUSHJ P,PATSCH ; FIXUP SCHLPAGE
3747 PATL: SKIPL E,3(D) ; SKIP IF NEXT EXISTS
3753 MOVEM E,3(D) ; SAY GVAL ETC. EXISTS IF WE UNBIND
3757 IMFUNCTION DEFMAC,FSUBR
3764 IMFUNCTION DFNE,FSUBR,[DEFINE]
3772 SKIPN B,1(AB) ; GET ATOM
3774 GETYP A,(B) ; MAKE SURE ATOM
3779 MCALL 1,EVAL ; EVAL IT TO AN ATOM
3782 PUSH TP,A ; SAVE TWO COPIES
3784 PUSHJ P,IGVAL ; SEE IF A VALUE EXISTS
3785 CAMN A,$TUNBOU ; SKIP IF A WINNER
3787 PUSHJ P,ASKUSR ; CHECK WITH USER
3794 SKIPN (P) ; SKIP IF MACRO
3796 MOVEI D,(B) ; READY TO CONS
3803 DFNE1: POP TP,B ; RETURN ATOM
3808 ASKUSR: MOVE B,IMQUOTE REDEFINE
3809 PUSHJ P,ILVAL ; SEE IF REDEFINE OK
3815 ASKUS1: PUSH TP,$TATOM
3818 PUSH TP,EQUOTE ALREADY-DEFINED-ERRET-NON-FALSE-TO-REDEFINE
3828 ;SET CLOBBERS THE LOCAL VALUE OF THE IDENTIFIER GIVEN BY ITS
3829 ;FIRST ARGUMENT TO THE SECOND ARG. ITS VALUE IS ITS SECOND ARGUMENT.
3832 HLRE D,AB ; 2 TIMES # OF ARGS TO D
3833 ASH D,-1 ; - # OF ARGS
3835 JUMPG D,TFA ; NOT ENOUGH
3838 JUMPE D,SET1 ; NO ENVIRONMENT
3839 AOJL D,TMA ; TOO MANY
3840 GETYP A,4(AB) ; CHECK ARG IS A FRAME OR PROCESS
3843 JRST SET2 ; WINNING ENVIRONMENT/FRAME
3845 JRST SET2 ; TO MAKE PFISTER HAPPY
3848 MOVE B,5(AB) ; GET PROCESS
3851 SET2: MOVEI B,4(AB) ; POINT TO FRAME
3852 PUSHJ P,CHFRM ; CHECK IT OUT
3853 MOVE B,5(AB) ; GET IT BACK
3854 MOVE C,SPSAV(B) ; GET BINDING POINTER
3855 HRRZ B,4(AB) ; POINT TO PROCESS
3856 HLRZ A,(B) ; GET LENGTH
3857 SUBI B,-1(A) ; POINT TO START THEREOF
3858 HLL B,PVSTOR+1 ; GET -LNTRH, (ALL PROCESS VECS SAME LENGTH)
3859 SET1: PUSH TP,$TPVP ; SAVE PROCESS
3861 PUSH TP,$TSP ; SAVE PATH POINTER
3863 GETYP A,(AB) ;GET TYPE OF FIRST
3864 CAIE A,TATOM ;ARGUMENT --
3865 JRST WTYP1 ;BETTER BE AN ATOM
3866 MOVE B,1(AB) ;GET PTR TO IT
3871 PUSHJ P,AILOC ;GET LOCATIVE TO VALUE
3872 GOTLOC: CAMN A,$TUNBOUND ;BOUND?
3873 PUSHJ P, BSET ;BIND IT
3874 MOVE C,2(AB) ; GET NEW VAL
3876 MOVSI A,TLOCD ; FOR MONCH
3878 PUSHJ P,MONCH0 ; HURRAY FOR MONITORS!!!!!
3880 HLRZ A,2(E) ; GET DECLS
3881 JUMPE A,SET3 ; NONE, GO
3885 HLLZ A,(A) ; GET PATTERN
3886 PUSHJ P,TMATCH ; MATCH TMEM
3892 SET3: MOVEM C,(E) ;CLOBBER IDENTIFIER
3896 MOVE C,-2(TP) ; GET PROC
3900 ; HERE WE NOTE THAT EFFICIENCY CAN SOMETIMES GET IN THE WAY OF CORRECTNESS
3901 ; BY SETTING THE SHALLOW BINDING WE MANAGE TO CLOBBER THE TOP LEVEL LVAL
3902 ; EVEN IF WE ARE SETTING WITH RESPECT TO A DIFFERENT FRAME. TO CORRECT
3903 ; THIS GLITCH THIS ACTIVITY WILL ONLY TAKE PLACE IF THE ATOM ALREADY POINTS
3911 NSHALL: SUB TP,[4,,4]
3915 CAMN PVP,-2(TP) ; SKIP IF PROC DIFFERS
3916 MOVEM C,-2(TP) ; ELSE USE RESULT FROM LOC SEARCH
3917 MOVE B,-2(TP) ; GET PROCESS
3918 HRRZ A,TPBASE+1(B) ;GET ACTUAL STACK BASE
3919 HRRZ B,SPBASE+1(B) ;AND FIRST BINDING
3920 SUB B,A ;ARE THERE 6
3921 CAIL B,6 ;CELLS AVAILABLE?
3923 MOVE C,(TP) ; GET POINTER BACK
3924 MOVEI B,0 ; LOOK FOR EMPTY SLOT
3926 CAMN A,$TUNBOUND ; SKIP IF FOUND
3928 MOVE E,1(AB) ; GET ATOM
3929 MOVEM E,-1(B) ; AND STORE
3931 BSET1: MOVE B,-2(TP) ; GET PROCESS
3932 ; PUSH TP,TPBASE(B) ;NO -- GROW THE TP
3933 ; PUSH TP,TPBASE+1(B) ;AT THE BASE END
3939 ; MOVE C,-2(TP) ; GET PROCESS
3940 ; MOVEM A,TPBASE(C) ;SAVE RESULT
3941 PUSH P,0 ; MANUALLY GROW VECTOR
3950 DPB D,[001100,,-1(C)]
3951 MOVE C,[5,,3] ; SET UP INDICATORS FOR AGC
3954 MOVE B,TPBASE+1(PVP) ; MODIFY POINTER
3955 MOVE 0,LVLINC ; ADJUST SPBASE POINTER
3960 MOVEM B,TPBASE+1(PVP)
3963 ; MOVEM B,TPBASE+1(C)
3964 SETIT: MOVE C,-2(TP) ; GET PROCESS
3966 MOVEI A,-6(B) ;MAKE UP BINDING
3967 HRRM A,(B) ;LINK PREVIOUS BIND BLOCK
3975 BSET2: MOVE C,-2(TP) ; GET PROC
3978 HLRZ D,OTBSAV(TB) ; TIME IT
3979 MOVEM D,2(B) ; AND FIX IT
3982 ; HERE TO ELABORATE ON TYPE MISMATCH
3984 TYPMI2: MOVE C,(TP) ; FIND DECLS
3988 MOVE 0,(AB) ; GET ATOM
3996 GETYP A,(AB) ; GET TYPE
3997 CAIE A,TFALSE ;IS IT FALSE?
3998 JRST IFALSE ;NO -- RETURN FALSE
4001 MOVSI A,TATOM ;RETURN T (VERITAS)
4010 MFUNCTION ANDA,FSUBR,AND
4016 JRST WRONGT ;IF ARG DOESN'T CHECK OUT
4018 SKIPN C,1(AB) ;IF NIL
4019 JRST TF(E) ;RETURN TRUTH
4020 PUSH TP,$TLIST ;CREATE UNNAMED TEMP
4024 JUMPE C,TFI(E) ;ANY MORE ARGS?
4025 MOVEM C,1(TB) ;STORE CRUFT
4029 PUSH TP,1(C) ;ARGUMENT
4035 JRST FINIS ;IF FALSE -- RETURN
4036 HRRZ C,@1(TB) ;GET CDR OF ARGLIST
4045 TFSKP: CAIE 0,TFALSE
4048 IMFUNCTION FUNCTION,FSUBR
4056 \f;SUBR VERSIONS OF AND/OR
4058 MFUNCTION ANDP,SUBR,[AND?]
4060 MOVE C,[CAIN 0,TFALSE]
4063 MFUNCTION ORP,SUBR,[OR?]
4065 MOVE C,[CAIE 0,TFALSE]
4066 BOOL: HLRE A,AB ; GET ARG COUNTER
4068 ASH A,-1 ; DIVIDES BY 2
4073 CANDP: SKIPA C,[CAIN 0,TFALSE]
4074 CORP: MOVE C,[CAIE 0,TFALSE]
4079 SUBB TP,D ; POINT TO ARGS & FIXUP TP PTR
4080 AOBJP D,.+1 ; FIXUP ARG PTR AND FALL INTO CBOOL
4084 JRST CBOOL1 ; YES RETURN IT
4086 SOJG A,CBOOL ; ANY MORE ?
4087 SUB D,[2,,2] ; NO, USE LAST
4093 CNOARG: MOVSI 0,TFALSE
4099 CNOAND: MOVSI A,TATOM
4104 MFUNCTION CLOSURE,SUBR
4106 SKIPL A,AB ;ANY ARGS
4107 JRST TFA ;NO -- LOSE
4108 ADD A,[2,,2] ;POINT AT IDS
4111 PUSH P,[0] ;MAKE COUNTER
4113 CLOLP: SKIPL A,1(TB) ;ANY MORE IDS?
4114 JRST CLODON ;NO -- LOSE
4115 PUSH TP,(A) ;SAVE ID
4117 PUSH TP,(A) ;GET ITS VALUE
4119 ADD A,[2,,2] ;BUMP POINTER
4125 MCALL 2,LIST ;MAKE PAIR
4131 ACALL A,LIST ;MAKE UP LIST
4132 PUSH TP,(AB) ;GET FUNCTION
4136 MCALL 2,LIST ;MAKE LIST
4142 ;ERROR COMMENTS FOR EVAL
4144 BADNUM: ERRUUO EQUOTE NEGATIVE-ARGUMENT
4146 WTY1TP: ERRUUO EQUOTE FIRST-ARG-WRONG-TYPE
4148 UNBOU: PUSH TP,$TATOM
4149 PUSH TP,EQUOTE UNBOUND-VARIABLE
4152 UNAS: PUSH TP,$TATOM
4153 PUSH TP,EQUOTE UNASSIGNED-VARIABLE
4157 ERRUUO EQUOTE BAD-ENVIRONMENT
4160 ERRUUO EQUOTE BAD-FUNARG
4177 MPD: ERRUUO EQUOTE MEANINGLESS-PARAMETER-DECLARATION
4179 NOBODY: ERRUUO EQUOTE HAS-EMPTY-BODY
4181 BADCLS: ERRUUO EQUOTE BAD-CLAUSE
4183 NXTAG: ERRUUO EQUOTE NON-EXISTENT-TAG
4185 NXPRG: ERRUUO EQUOTE NOT-IN-PROG
4188 NAPT: ERRUUO EQUOTE NON-APPLICABLE-TYPE
4190 NONEVT: ERRUUO EQUOTE NON-EVALUATEABLE-TYPE
4193 NONATM: ERRUUO EQUOTE NON-ATOMIC-ARGUMENT
4196 ILLFRA: ERRUUO EQUOTE FRAME-NO-LONGER-EXISTS
4198 ILLSEG: ERRUUO EQUOTE ILLEGAL-SEGMENT
4200 BADMAC: ERRUUO EQUOTE BAD-USE-OF-MACRO
4202 BADFSB: ERRUUO EQUOTE APPLY-OR-STACKFORM-OF-FSUBR
4205 ER1ARG: PUSH TP,(AB)