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)
2206 SSPEC2: SUBI E,(SP) ; MAKE SP BE AOBJN
2216 ; ENTRY FOR FUNNY COMPILER UNBIND (2)
2221 SUBI E,1 ; MAKE SURE GET CURRENT BINDING
2222 PUSHJ P,STLOOP ; UNBIND
2223 MOVEI E,(TP) ; NOW RESET SP
2226 EFINIS: MOVE PVP,PVSTOR+1
2227 SKIPN C,1STEPR+1(PVP) ; SKIP NIF BEING ONE PROCEEDED
2230 PUSH TP,MQUOTE EVLOUT
2231 PUSH TP,A ;SAVE EVAL RESULTS
2233 PUSH TP,[TINFO,,2] ; FENCE POST
2236 PUSHJ P,MAKINF ; MAKE ARG BLOCK INFO
2239 HRLI B,-4 ; AOBJN TO ARGS BLOCK
2243 PUSH TP,1STEPR+1(PVP) ; PROCESS DOING THE 1STEPPING
2245 MOVE A,-3(TP) ; GET BACK EVAL VALUE
2249 1STEPI: PUSH TP,$TATOM
2250 PUSH TP,MQUOTE EVLIN
2251 PUSH TP,$TAB ; PUSH EVALS ARGGS
2253 PUSHJ P,MAKINF ; TURN INTO ARGS BLOCK
2254 MOVEM A,-1(TP) ; AND CLOBBER
2255 PUSH TP,[TINFO,,2] ; FENCE POST 2D TUPLE
2258 PUSHJ P,MAKINF ; TURN IT INTO ARGS BLOCK
2260 MOVEI B,-6(TP) ; SETUP TUPLE
2265 PUSH TP,1STEPR+1(PVP)
2266 MCALL 2,RESUME ; START UP 1STEPERR
2267 SUB TP,[6,,6] ; REMOVE CRUD
2268 GETYP A,A ; GET 1STEPPERS TYPE
2269 CAIE A,TDISMI ; IF DISMISS, STOP 1 STEPPING
2272 ; HERE TO PUSH DOWN THE 1 STEP STATE AND RUN
2275 ADD D,[1STEPR,,1STEPR] ; POINT TO 1 STEP SLOT
2276 PUSH TP,$TSP ; SAVE CURRENT SP
2281 PUSH TP,[0] ; NO 1 STEPPER UNTIL POPJ
2284 ; NOW PUSH THE ARGS UP TO RE-CALL EVAL
2287 EFARGL: JUMPGE AB,EFCALL
2293 EFCALL: ACALL A,EVAL ; NOW DO THE EVAL
2294 MOVE C,(TP) ; PRE-UNBIND
2296 MOVEM C,1STEPR+1(PVP)
2297 MOVE SP,-4(TP) ; AVOID THE UNBIND
2299 SUB TP,[6,,6] ; AND FLUSH LOSERS
2300 JRST EFINIS ; AND TRY TO FINISH UP
2302 MAKINF: HLRZ A,OTBSAV(TB) ; TIME IT
2307 TBTOTP: MOVEI D,(TB) ; COMPUTE REL DIST FROM TP TO TB
2310 ; ARRIVE HERE TO COMPLETE A COMPILER GENERATED TUPLE
2311 ; D/ LENGTH OF THE TUPLE IN WORDS
2313 MAKTU2: MOVE D,-1(P) ; GET LENGTH
2320 MAKTUP: HRLI D,TINFO ; FIRST WORD OF FENCE POST
2322 HRROI B,(TP) ; TOP OF TUPLE
2324 TLC B,-1(D) ; AOBJN IT
2327 HLRZ A,OTBSAV(TB) ; TIME IT
2331 ; HERE TO ALLOCATE SLOTS FOR COMPILER (AMNT IN A)
2334 ;Once here ==>ADDI A,1 Bug???
2339 PUSHJ P,TPOVFL ; IN CASE IT LOST
2340 INTGO ; TAKE THE GC IF NEC
2354 \f;EVALUATES A IDENTIFIER -- GETS LOCAL VALUE IF THERE IS ONE, OTHERWISE GLOBAL.
2356 IMFUNCTION VALUE,SUBR
2361 IDVAL: PUSHJ P,IDVAL1
2367 PUSH TP,B ;SAVE ARG IN CASE NEED TO CHECK GLOBAL VALUE
2368 PUSHJ P,ILVAL ;LOCAL VALUE FINDER
2369 CAME A,$TUNBOUND ;IF NOT UNBOUND OR UNASSIGNED
2370 JRST RIDVAL ;DONE - CLEAN UP AND RETURN
2371 POP TP,B ;GET ARG BACK
2374 RIDVAL: SUB TP,[2,,2]
2377 ;GETS THE LOCAL VALUE OF AN IDENTIFIER
2379 IMFUNCTION LVAL,SUBR
2387 ; MAKE AN ATOM UNASSIGNED
2389 MFUNCTION UNASSIGN,SUBR
2390 JSP E,CHKAT ; GET ATOM ARG
2392 UNASIT: CAMN A,$TUNBOU ; IF UNBOUND
2396 SETOM 1(B) ; MAKE SURE
2397 RETATM: MOVE B,1(AB)
2403 MFUNCTION GUNASSIGN,SUBR
2408 MOVE B,1(AB) ; ATOM BACK
2410 CAIL 0,HIBOT ; SKIP IF IMPURE
2411 PUSHJ P,IMPURIFY ; YES, MAKE IT IMPURE
2412 PUSHJ P,IGLOC ; RESTORE LOCATIVE
2413 HRRZ 0,-2(B) ; SEE IF MANIFEST
2414 GETYP A,(B) ; AND CURRENT TYPE
2423 ; GETS A LOCATIVE TO THE LOCAL VALUE OF AN IDENTIFIER.
2434 ;TESTS TO SEE IF AN IDENTIFIER IS LOCALLY BOUND
2436 MFUNCTION BOUND,SUBR,[BOUND?]
2443 ;TESTS TO SEE IF AN IDENTIFIER IS LOCALLY ASSIGNED
2445 MFUNCTION ASSIGP,SUBR,[ASSIGNED?]
2453 ;GETS THE GLOBAL VALUE OF AN IDENTIFIER
2455 IMFUNCTION GVAL,SUBR
2462 ;GETS A LOCATIVE TO THE GLOBAL VALUE OF AN IDENTIFIER
2464 MFUNCTION RGLOC,SUBR
2489 MOVE C,1(AB) ; GE ATOM
2491 CAIGE 0,HIBOT ; SKIP IF PURE ATOM
2494 ; MAKE ATOM AND VALUE IMPURE IF GETTING GLOC TO IT
2496 MOVE B,C ; ATOM TO B
2498 JRST GLOC ; AND TRY AGAIN
2500 ;TESTS TO SEE IF AN IDENTIFIER IS GLOBALLY ASSIGNED
2502 MFUNCTION GASSIG,SUBR,[GASSIGNED?]
2509 ; TEST FOR GLOBALLY BOUND
2511 MFUNCTION GBOUND,SUBR,[GBOUND?]
2521 CHKAT1: GETYP A,(AB)
2528 CHKAT: HLRE A,AB ; - # OF ARGS
2529 ASH A,-1 ; TO ACTUAL WORDS
2531 MOVE C,SPSTOR+1 ; FOR BINDING LOOKUPS
2532 AOJE A,CHKAT1 ; ONLY ONE ARG, NO ENVIRONMENT
2533 AOJL A,TMA ; TOO MANY
2534 GETYP A,2(AB) ; MAKE SURE OF TENV OR TFRAME
2538 CAIN A,TACT ; FOR PFISTERS LOSSAGE
2540 CAIE A,TPVP ; OR PROCESS
2542 MOVE B,3(AB) ; GET PROCESS
2543 MOVE C,SPSTOR+1 ; IN CASE ITS ME
2544 CAME B,PVSTOR+1 ; SKIP IF DIFFERENT
2545 MOVE C,SPSTO+1(B) ; GET ITS SP
2547 CHKAT3: MOVEI B,2(AB) ; POINT TO FRAME POINTER
2548 PUSHJ P,CHFRM ; VALIDITY CHECK
2549 MOVE B,3(AB) ; GET TB FROM FRAME
2550 MOVE C,SPSAV(B) ; GET ENVIRONMENT POINTER
2554 ; SILOC--CALLS ILOC IGNORING SPECIAL CHECKING
2558 ;ILOC RETURNS IN A AND B A LOCATIVE TO THE LOCAL VALUE OF THE IDENTIFIER
2559 ; PASSED TO IT IN A AND B. IF THE IDENTIFIER IS LOCALLY UNBOUND IT RETURNS
2560 ; $TUNBOUND IN A AND 0 IN B, IT IS CALLED BY PUSHJ P,ILOC.
2562 ILOC: MOVE C,SPSTOR+1 ; SETUP SEARCH START
2563 AILOC: SKIPN (B) ; ANY KIND OF VALUE AT ALL?
2565 MOVSI A,TLOCI ;MAKE A LOCATIVE TYPE CELL
2568 MOVEI E,0 ; FLAG TO CLOBBER ATOM
2569 JUMPE B,SCHSP ; IF LOOKING FOR SLOT, SEARCH NOW
2570 CAME C,SPSTOR+1 ; ENVIRONMENT CHANGE?
2571 JRST SCHSP ; YES, MUST SEARCH
2573 HRR A,BINDID+1(PVP) ;FOR THE CURRENT PROCESS
2574 CAME A,(B) ;IS THERE ONE IN THE VALUE CELL?
2575 JRST SCHLP ;NO -- SEARCH THE LOCAL BINDINGS
2576 MOVE B,1(B) ;YES -- GET LOCATIVE POINTER
2578 ILCPJ: MOVE E,SPCCHK
2579 TRNN E,1 ; SKIP IF DOING SPEC UNSPEC CHECK
2581 HRRZ E,-2(P) ; IF IGNORING, IGNORE
2588 CAMGE B,CURFCN+1(PVP)
2593 CAMGE B,SPBASE+1(PVP)
2598 POPJ P, ;FROM THE VALUE CELL
2610 CAIL D,HIBOT ; SKIP IF IMPURE ATOM
2611 SCHSP: MOVEI E,1 ; DONT STORE LOCATIVE
2613 PUSH P,E ; PUSH SWITCH
2614 MOVE E,PVSTOR+1 ; GET PROC
2615 SCHLP1: JUMPE C,UNPJ ;IF NO MORE -- LOSE
2616 CAMN B,1(C) ;ARE WE POINTING AT THE WINNER?
2618 GETYP D,(C) ; CHECK SKIP
2621 PUSH P,B ; CHECK DETOUR
2623 PUSHJ P,CHFRAM ; NON-FATAL FRAME CHECKER
2624 HRRZ E,2(C) ; CONS UP PROCESS
2627 JUMPE B,SCHLP3 ; LOSER, FIX IT
2629 MOVEI C,1(C) ; FOLLOW LOOKUP CHAIN
2630 SCHLP2: HRRZ C,(C) ;FOLLOW LINK
2635 MOVEI C,(SP) ; *** NDR'S BUG ***
2636 CAME E,PVSTOR+1 ; USE IF CURRENT PROCESS
2637 HRRZ C,SPSTO+1(E) ; USE CURRENT SP FOR PROC
2640 SCHFND: MOVE D,SPCCHK
2641 TRNN D,1 ; SKIP IF DOING SPEC UNSPEC CHECK
2643 HRRZ D,-2(P) ; IF IGNORING, IGNORE
2650 HRRZ D,CURFCN+1(PVP)
2654 HRRZ D,SPBASE+1(PVP)
2659 SCHFN1: EXCH B,C ;SAVE THE ATOM PTR IN C
2660 MOVEI B,2(B) ;MAKE UP THE LOCATIVE
2664 EXCH C,E ; RET PROCESS IN C
2665 POP P,D ; RESTORE SWITCH
2667 JUMPN D,ILOCPJ ; DONT CLOBBER ATOM
2668 MOVEM A,(E) ;CLOBBER IT AWAY INTO THE
2669 MOVE D,1(E) ; GET OLD POINTER
2670 MOVEM B,1(E) ;ATOM'S VALUE CELL
2671 JUMPE D,ILOCPJ ; IF POINTS TO GLOBAL OR OTHER PROCES
2672 ; MAKE SURE BINDING SO INDICATES
2673 MOVE D,B ; POINT TO BINDING
2674 SKIPL E,3(D) ; GO TO FIRST ONE, JUST IN CASE
2677 JRST .-3 ; LOOP THROUGH
2679 MOVEM E,3(D) ; MAGIC INDICATION
2682 UNPJ: SUB P,[1,,1] ; FLUSH CRUFT
2683 UNPJ1: MOVE C,E ; RET PROCESS ANYWAY
2686 UNPOPJ: MOVSI A,TUNBOUND
2690 FUNPJ: MOVE C,PVSTOR+1
2693 ;IGLOC RETURNS IN A AND B A LOCATIVE TO THE GLOBAL VALUE OF THE
2694 ;IDENTIFIER PASSED TO IT IN A AND B. IF THE IDENTIFIER IS GLOBALLY
2695 ;UNBPOUND IT RETURNS $TUNBOUND IN A AND 0 IN B. IT IS CALLED BY PUSHJ P,IGLOC.
2697 IGLOC: MOVSI A,TLOCI ;DO WE HAVE A LOCATIVE TO
2698 CAME A,(B) ;A PROCESS #0 VALUE?
2699 JRST SCHGSP ;NO -- SEARCH
2700 MOVE B,1(B) ;YES -- GET VALUE CELL
2705 MOVE D,GLOBSP+1 ;GET GLOBAL SP PTR
2707 SCHG1: JUMPGE D,UNPOPJ ;IF NO MORE, LEAVE
2708 CAMN B,1(D) ;ARE WE FOUND?
2710 ADD D,[4,,4] ;NO -- TRY NEXT
2714 EXCH B,D ;SAVE ATOM PTR
2715 ADD B,[2,,2] ;MAKE LOCATIVE
2719 MOVEM A,(D) ;CLOBBER IT AWAY
2723 IIGLOC: PUSH TP,$TATOM
2736 PUSHJ P,IMPURI ; IMPURIFY THE POOR ATOM
2737 PUSHJ P,BSETG ; MAKE A SLOT
2738 SETOM 1(B) ; UNBOUNDIFY IT
2747 ;ILVAL RETURNS IN A AND B THE LOCAL VALUE OF THE IDENTIFIER PASSED TO IT IN A AND B
2748 ;IF THE IDENTIFIER IS UNBOUND ITS VALUE IS $TUNBOUND IN A AND 0 IN B. IF
2749 ;IT IS UNASSIGNED ITS VALUE IS $TUNBOUND IN A AND -1 IN B. CALL - PUSHJ P,IVAL
2752 PUSHJ P,AILOC ; USE SUPPLIED SP
2755 PUSHJ P,ILOC ;GET LOCATIVE TO VALUE
2756 CHVAL: CAMN A,$TUNBOUND ;BOUND
2757 POPJ P, ;NO -- RETURN
2758 MOVSI A,TLOCD ; GET GOOD TYPE
2759 HRR A,2(B) ; SHOULD BE TIME OR 0
2761 PUSHJ P,RMONC0 ; CHECK READ MONITOR
2763 MOVE A,(B) ;GET THE TYPE OF THE VALUE
2764 MOVE B,1(B) ;GET DATUM
2767 ;IGVAL -- LIKE ILVAL EXCEPT FOR GLOBAL VALUES
2769 IGVAL: PUSHJ P,IGLOC
2774 ; COMPILERS INTERFACE TO LVAL/GVAL/SETG/SET
2776 CILVAL: MOVE PVP,PVSTOR+1
2777 MOVE 0,BINDID+1(PVP) ; CURRENT BIND
2779 CAME 0,(B) ; HURRAY FOR SPEED
2780 JRST CILVA1 ; TOO BAD
2781 MOVE C,1(B) ; POINTER
2782 MOVE A,(C) ; VAL TYPE
2783 TLNE A,.RDMON ; MONITORS?
2787 JRST CUNAS ; COMPILER ERROR
2788 MOVE B,1(C) ; GOT VAL
2792 HLRZ 0,-2(C) ; SPECIAL CHECK
2796 CAMGE C,CURFCN+1(PVP)
2801 CILVA1: SUBM M,(P) ; FIX (P)
2802 PUSH TP,$TATOM ; SAVE ATOM
2804 MCALL 1,LVAL ; GET ERROR/MONITOR
2806 POPJM: SUBM M,(P) ; REPAIR DAMAGE
2809 ; COMPILERS INTERFACE TO SET C/ ATOM A,B/ NEW VALUE
2811 CISET: MOVE PVP,PVSTOR+1
2812 MOVE 0,BINDID+1(PVP) ; CURRENT BINDING ENVIRONMENT
2814 CAME 0,(C) ; CAN WE WIN?
2815 JRST CISET1 ; NO, MORE HAIR
2816 MOVE D,1(C) ; POINT TO SLOT
2817 CISET3: HLLZ 0,(D) ; MON CHECK
2819 JRST CISET4 ; YES, LOSE
2821 IOR A,0 ; LEAVE MONITOR ON
2824 JRST CISET5 ; SPEC/UNSPEC CHECK
2825 CISET6: MOVEM A,(D) ; STORE
2829 CISET5: HLRZ 0,-2(D)
2833 CAMGE D,CURFCN+1(PVP)
2837 CISET1: SUBM M,(P) ; FIX ADDR
2838 PUSH TP,$TATOM ; SAVE ATOM
2843 PUSHJ P,ILOC ; SEARCH
2844 MOVE D,B ; POSSIBLE POINTER
2847 MOVE A,-1(TP) ; VAL BACK
2849 CAIE E,TUNBOU ; SKIP IF WIN
2850 JRST CISET2 ; GO CLOBBER IT IN
2854 CISET2: MOVE C,-2(TP) ; ATOM BACK
2855 SUBM M,(P) ; RESET (P)
2859 ; HERE TO DO A MONITORED SET
2861 CISET4: SUBM M,(P) ; AGAIN FIX (P)
2871 CLLOC: MOVE PVP,PVSTOR+1
2872 MOVE 0,BINDID+1(PVP) ; GET CURRENT LOCATIVE
2878 TRNE 0,1 ; SKIP IF NOT CHECKING
2880 CLLOC3: MOVSI A,TLOCD
2881 HRR A,2(B) ; GET BIND TIME
2887 PUSHJ P,ILOC ; LOOK IT UP
2893 CLLOC2: MCALL 1,LLOC
2896 CLLOC9: HLRZ 0,-2(B)
2900 CAMGE B,CURFCN+1(PVP)
2908 JUMPE B,PJFALS ; IF UNBOUND RET FALSE AND NO SSKIP
2918 ; COMPILER ASSIGNED?
2929 ; COMPILER GVAL B/ ATOM
2931 CIGVAL: MOVE 0,(B) ; GLOBAL VAL HERE?
2932 CAME 0,$TLOCI ; TIME=0 ,TYPE=TLOCI => GLOB VAL
2933 JRST CIGVA1 ; NO, GO LOOK
2934 MOVE C,1(B) ; POINT TO SLOT
2935 MOVE A,(C) ; GET TYPE
2938 GETYP 0,A ; CHECK FOR UNBOUND
2939 CAIN 0,TUNBOU ; SKIP IF WINNER
2948 .MCALL 1,GVAL ; GET ERROR/MONITOR
2951 ; COMPILER INTERFACET TO SETG
2953 CSETG: MOVE 0,(C) ; GET V CELL
2954 CAME 0,$TLOCI ; SKIP IF FAST
2956 HRRZ D,1(C) ; POINT TO SLOT
2957 MOVE 0,(D) ; OLD VAL
2958 CSETG3: CAIG D,HIBOT ; SKIP IF PURE ATOM
2959 TLNE 0,.WRMON ; MONITOR
2965 CSETG1: SUBM M,(P) ; FIX UP P
2971 PUSHJ P,IGLOC ; FIND GLOB LOCATIVE
2974 MOVEI D,(B) ; SETUP TO RESTORE NEW VAL
2982 CSETG4: MOVE C,-2(TP) ; ATOM BACK
2983 SUBM M,(P) ; RESET (P)
2988 PUSH TP,$TATOM ; CAUSE A SETG MONITOR
2997 CGLOC: MOVE 0,(B) ; GET CURRENT GUY
2998 CAME 0,$TLOCI ; WIN?
3000 HRRZ D,1(B) ; POINT TO SLOT
3001 CAILE D,HIBOT ; PURE?
3013 ; COMPILERS GASSIGNED?
3037 IMFUNCTION REP,FSUBR,[REPEAT]
3039 MFUNCTION BIND,FSUBR
3041 IMFUNCTION PROG,FSUBR
3043 GETYP A,(AB) ;GET ARG TYPE
3044 CAIE A,TLIST ;IS IT A LIST?
3045 JRST WRONGT ;WRONG TYPE
3046 SKIPN C,1(AB) ;GET AND CHECK ARGUMENT
3047 JRST TFA ;TOO FEW ARGS
3048 SETZB E,D ; INIT HEWITT ATOM AND DECL
3049 PUSHJ P,CARATC ; IS 1ST THING AN ATOM
3051 PUSHJ P,RSATY1 ; CDR AND GET TYPE
3052 CAIE 0,TLIST ; MUST BE LIST
3054 MOVE B,1(C) ; GET ARG LIST
3059 JRST NOP.DC ; JUMP IF NO DCL
3062 PUSHJ P,RSATYP ; CDR ON
3063 NOP.DC: PUSH TP,$TLIST
3064 PUSH TP,B ; AND ARG LIST
3065 PUSHJ P,PRGBND ; BIND AUX VARS
3068 SKIPA E,IMQUOTE LPROG,[LPROG ]INTRUP
3070 PUSHJ P,MAKACT ; MAKE ACTIVATION
3071 PUSHJ P,PSHBND ; BIND AND CHECK
3072 PUSHJ P,SPECBI ; NAD BIND IT
3074 ; HERE TO RUN PROGS FUNCTIONS ETC.
3076 DOPROG: MOVEI A,REPROG
3077 HRLI A,TDCLI ; FLAG AS FUNNY
3078 MOVEM A,(TB) ; WHERE TO AGAIN TO
3080 MOVEM C,3(TB) ; RESTART POINTER
3081 JRST .+2 ; START BY SKIPPING DECL
3083 DOPRG1: PUSHJ P,FASTEV
3084 HRRZ C,@1(TB) ;GET THE REST OF THE BODY
3085 DOPRG2: MOVEM C,1(TB)
3090 REPROG: SKIPN C,@3(TB)
3098 PFINIS: GETYP 0,(TB)
3099 CAIE 0,TDCLI ; DECL'D ?
3101 HRRZ 0,(TB) ; SEE IF RSUBR
3102 JUMPE 0,RSBVCK ; CHECK RSUBR VALUE
3103 HRRZ C,3(TB) ; GET START OF FCN
3104 GETYP 0,(C) ; CHECK FOR DECL
3106 JRST PFINI1 ; NO, JUST RETURN
3107 MOVE E,IMQUOTE VALUE
3108 PUSHJ P,PSHBND ; BUILD FAKE BINDING
3109 MOVE C,1(C) ; GET DECL LIST
3111 PUSHJ P,CHKDCL ; AND CHECK IT
3112 MOVE A,-3(TP) ; GET VAL BAKC
3116 PFINI1: HRRZ C,FSAV(TB)
3126 ; HERE TO CHECK RSUBR VALUE
3132 MOVE A,1(TB) ; GET DECL
3141 RSBVC1: MOVE C,1(TB)
3144 MOVE A,IMQUOTE VALUE
3148 MFUNCTION MRETUR,SUBR,[RETURN]
3150 HLRE A,AB ; GET # OF ARGS
3151 ASH A,-1 ; TO NUMBER
3152 AOJL A,RET2 ; 2 OR MORE ARGS
3153 PUSHJ P,PROGCH ;CHECK IN A PROG
3156 MOVEI B,-1(TP) ; VERIFY IT
3157 COMRET: PUSHJ P,CHFSWP
3159 MOVEI C,0 ; REAL NONE
3161 JUMPN A,CHFINI ; WINNER
3165 ; SEE IF MUST CHECK RETURNS TYPE
3167 CHFINI: GETYP 0,(TB) ; SPECIAL TYPE IF SO
3169 JRST FINIS ; NO, JUST FINIS
3170 MOVEI 0,PFINIS ; CAUSE TO FALL INTO FUNCTION CODE
3177 CAIE A,TACT ; AS FOR "EXIT" SHOULD BE ACTIVATION
3179 MOVEI B,(AB)+2 ; ADDRESS OF FRAME POINTER
3184 MFUNCTION AGAIN,SUBR
3186 HLRZ A,AB ;GET # OF ARGS
3189 JUMPN A,TMA ;0 ARGS?
3190 PUSHJ P,PROGCH ;CHECK FOR IN A PROG
3199 AGAD: MOVEI B,-1(TP) ; POINT TO FRAME
3201 HRRZ C,(B) ; GET RET POINT
3202 GOJOIN: PUSH TP,$TFIX
3205 PUSHJ P,CHUNW ; RESTORE FRAME, UNWIND IF NEC.
3207 HRRZ 0,FSAV(TB) ; CHECK FOR RSUBR
3221 MOVE C,OTBSAV(TB) ; AND RESTORE P FROM FATHER
3234 PUSHJ P,PROGCH ;CHECK FOR A PROG
3243 MCALL 2,MEMQ ;DOES IT HAVE THIS TAG?
3244 JUMPE B,NXTAG ;NO -- ERROR
3245 FNDGO: EXCH B,(TP) ;SAVE PLACE TO GO
3250 NLCLGO: CAIE A,TTAG ;CHECK TYPE
3253 MOVEI B,2(B) ; POINT TO SLOT
3256 GETYP 0,(A) ; SEE IF COMPILED
3262 GODON1: PUSH TP,(A) ;SAVE BODY
3265 PUSHJ P,CHUNW ;GO BACK TO CORRECT FRAME
3266 MOVE B,(TP) ;RESTORE ITERATION MARKER
3279 GETYP A,(AB) ;GET TYPE OF ARGUMENT
3280 CAIE A,TFIX ; FIX ==> COMPILED
3292 ATOTAG: CAIE A,TATOM ;CHECK THAT IT IS AN ATOM
3296 PUSHJ P,PROGCH ;CHECK PROG
3304 JUMPE B,NXTAG ;IF NOT FOUND -- ERROR
3305 EXCH A,-1(TP) ;SAVE PLACE
3315 PROGCH: MOVE B,IMQUOTE LPROG,[LPROG ]INTRUP
3316 PUSHJ P,ILVAL ;GET VALUE
3322 ; HERE TO UNASSIGN LPROG IF NEC
3324 UNPROG: MOVE B,IMQUOTE LPROG,[LPROG ]INTRUP
3327 CAIE 0,TACT ; SKIP IF MUST UNBIND
3331 MOVE E,IMQUOTE LPROG,[LPROG ]INTRUP
3333 UNMAP: HRRZ 0,FSAV(TB) ; CHECK FOR FUNNY
3334 CAIN 0,MAPPLY ; SKIP IF NOT
3336 MOVE B,IMQUOTE LMAP,[LMAP ]INTRUP
3343 MOVE E,IMQUOTE LMAP,[LMAP ]INTRUP
3345 UNSPEC: PUSH TP,BNDV
3347 ADD B,[CURFCN,,CURFCN]
3356 MFUNCTION MEXIT,SUBR,[EXIT]
3364 PUSHJ P,CHUNW ;RESTORE FRAME
3365 JRST CHFINI ; CHECK FOR WINNING VALUE
3368 MFUNCTION COND,FSUBR
3374 PUSH TP,1(AB) ;CREATE UNNAMED TEMP
3375 MOVEI B,0 ; SET TO FALSE IN CASE
3377 CLSLUP: SKIPN C,1(TB) ;IS THE CLAUSELIST NIL?
3378 JRST IFALS1 ;YES -- RETURN NIL
3379 GETYP A,(C) ;NO -- GET TYPE OF CAR
3380 CAIE A,TLIST ;IS IT A LIST?
3382 MOVE A,1(C) ;YES -- GET CLAUSE
3385 PUSH TP,B ; EVALUATION OF
3387 PUSH TP,1(A) ;THE PREDICATE
3392 JRST NXTCLS ;FALSE TRY NEXT CLAUSE
3393 MOVE C,1(TB) ;IF NOT, DO FIRST CLAUSE
3396 JUMPE C,FINIS ;(UNLESS DONE WITH IT)
3397 JRST DOPRG2 ;AS THOUGH IT WERE A PROG
3398 NXTCLS: HRRZ C,@1(TB) ;SET THE CLAUSLIST
3399 HRRZM C,1(TB) ;TO CDR OF THE CLAUSLIST
3404 IFALS1: MOVSI A,TFALSE ;RETURN FALSE
3409 MFUNCTION UNWIND,FSUBR
3413 GETYP 0,(AB) ; CHECK THE ARGS FOR WINNAGE
3414 SKIPN A,1(AB) ; NONE?
3416 HRRZ B,(A) ; CHECK FOR 2D
3421 ; Unbind LPROG and LMAPF so that nothing cute happens
3425 ; Push thing to do upon UNWINDing
3431 PUSHJ P,IUNWIN ; GOT TO INTERNAL SET UP
3433 ; Now EVAL the first form
3436 HRRZ 0,(A) ; SAVE POINTER TO OTHER GUY
3441 JSP E,CHKAB ; DEFER?
3444 MCALL 1,EVAL ; EVAL THE LOSER
3448 ; Now push slots to hold undo info on the way down
3450 IUNWIN: JUMPE M,NOUNRE
3451 HLRE 0,M ; CHECK BOUNDS
3459 NOUNRE: PUSH TP,$TTB ; DESTINATION FRAME
3461 PUSH TP,[0] ; ARGS TO WHOEVER IS DOING IT
3464 ; Now bind UNWIND word
3466 PUSH TP,$TUNWIN ; FIRST WORD OF IT
3468 HRRM SP,(TP) ; CHAIN
3470 PUSH TP,TB ; AND POINT TO HERE
3475 PUSH TP,P ; SAVE PDL ALSO
3476 MOVEM TP,-2(TP) ; SAVE FOR LATER
3479 ; Do a non-local return with UNWIND checking
3481 CHUNW: HRRZ E,SPSAV(B) ; GET DESTINATION FRAME
3482 CHUNW1: PUSH TP,(C) ; FINAL VAL
3484 JUMPN C,.+3 ; WAS THERE REALLY ANYTHING
3487 PUSHJ P,STLOOP ; UNBIND
3488 CHUNPC: SKIPA ; WILL NOT SKIP UNLESS UNWIND FOUND
3496 HRRI TB,(B) ; UPDATE TB
3502 POPUNW: MOVE SP,SPSTOR+1
3513 UNWFRM: JUMPE FRM,CPOPJ
3515 UNWFR2: JUMPE B,UNWFR1
3524 ; Here if an UNDO found
3526 GOTUND: MOVE TB,1(SP) ; GET FRAME OF UNDO
3527 MOVE A,-1(TP) ; GET FUNNY ARG FOR PASS ON
3529 MOVE TP,3(SP) ; GET FUTURE TP
3530 MOVEM C,-6(TP) ; SAVE ARG
3532 MOVE C,(TP) ; SAVED P
3534 MOVEM C,PSAV(TB) ; MAKE CONTIN WIN
3537 HRRZ C,(P) ; PC OF CHUNW CALLER
3538 HRRM C,-11(TP) ; SAVE ALSO AND GET WHERE TO GO PC
3539 MOVEM B,-10(TP) ; AND DESTINATION FRAME
3540 HRRZ C,-1(TP) ; WHERE TO UNWIND PC
3541 HRRZ 0,FSAV(TB) ; RSUBR?
3550 UNWIN1: MOVE B,-12(TP) ; POINT TO THING TO DO UNWINDING
3558 UNWIN2: MOVEI C,-7(TP) ; POINT TO SAVED RET VALS
3563 HRRZ SP,(SP) ; UNBIND THIS GUY
3564 MOVEI E,(TP) ; AND FIXUP SP
3570 JRST CHUNW ; ANY MORE TO UNWIND?
3573 ; CHFSWP - CHECK FRAMES VALIDITY AND SWAP PROCESS IF NECESSARY.
3574 ; CALLED BY ALL CONTROL FLOW
3575 ; ROUTINES (GO,RETURN,EXIT,AGAIN,ERRET...)
3577 CHFSWP: PUSHJ P,CHFRM ; CHECK FOR VALID FRAME
3578 HRRZ D,(B) ; PROCESS VECTOR DOPE WD
3580 SUBI D,-1(C) ; POINT TO TOP
3581 MOVNS C ; NEGATE COUNT
3582 HRLI D,2(C) ; BUILD PVP
3585 MOVE A,(B) ; GET FRAME
3587 CAMN E,D ; SKIP IF SWAP NEEDED
3589 PUSH TP,A ; SAVE FRAME
3592 PUSHJ P,PROCHK ; FIX UP PROCESS LISTS
3593 MOVE A,PSTAT+1(B) ; GET STATE
3596 MOVE D,B ; PREPARE TO SWAP
3600 JSP C,SWAP ; SWAP IN
3601 MOVE C,ABSTO+1(E) ; GET OLD ARRGS
3602 MOVEI A,RUNING ; FIX STATES
3604 MOVEM A,PSTAT+1(PVP)
3609 NOTRES: ERRUUO EQUOTE PROCESS-NOT-RESUMABLE
3612 ;SETG IS USED TO SET THE GLOBAL VALUE OF ITS FIRST ARGUMENT,
3613 ;AN IDENTIFIER, TO THE VALUE OF ITS SECOND ARGUMENT. ITS VALUE IS
3614 ; ITS SECOND ARGUMENT.
3616 IMFUNCTION SETG,SUBR
3618 GETYP A,(AB) ;GET TYPE OF FIRST ARGUMENT
3619 CAIE A,TATOM ;CHECK THAT IT IS AN ATOM
3620 JRST NONATM ;IF NOT -- ERROR
3621 MOVE B,1(AB) ;GET POINTER TO ATOM
3625 CAIL 0,HIBOT ; PURE ATOM?
3626 PUSHJ P,IMPURIFY ; YES IMPURIFY
3627 PUSHJ P,IGLOC ;GET LOCATIVE TO VALUE
3628 CAMN A,$TUNBOUND ;IF BOUND
3629 PUSHJ P,BSETG ;IF NOT -- BIND IT
3630 MOVE C,2(AB) ; GET PROPOSED VVAL
3632 MOVSI A,TLOCD ; MAKE SURE MONCH WINS
3633 PUSHJ P,MONCH0 ; WOULD YOU BELIEVE MONITORS!!!!
3636 HRRZ E,-2(D) ; POINT TO POSSIBLE GDECL (OR MAINIFEST)
3637 JUMPE E,OKSETG ; NONE ,OK
3638 CAIE E,-1 ; MANIFEST?
3640 GETYP 0,(D) ; IF UNBOUND, LET IT HAPPEN
3652 MOVE B,IMQUOTE REDEFINE
3653 PUSHJ P,ILVAL ; SEE IF REDEFINE OK
3660 PUSH TP,EQUOTE ATTEMPT-TO-CHANGE-MANIFEST-VARIABLE
3666 SETGTY: PUSH TP,$TVEC
3681 OKSETG: MOVEM A,(D) ;DEPOSIT INTO THE
3682 MOVEM B,1(D) ;INDICATED VALUE CELL
3693 BSETG: HRRZ A,GLOBASE+1
3698 MOVEI B,0 ; MAKE SURE OF NO EMPTY SLOTS
3700 CAMN A,$TUNBOU ; SKIP IF SLOT FOUND
3702 MOVE C,(TP) ; GET ATOM
3703 MOVEM C,-1(B) ; CLOBBER ATOM SLOT
3704 HLLZS -2(B) ; CLOBBER OLD DECL
3706 ; BSETG1: PUSH TP,GLOBASE ; MUST REALLY GROW STACK
3718 MOVE B,GVLINC ; GROW BY INDICATED GVAL SLOTS
3721 MOVE C,[6,,4] ; INDICATOR FOR AGC
3724 MOVE 0,GVLINC ; ADJUST GLOBAL SPBASE
3742 BSETGX: MOVSI A,TLOCI
3743 PUSHJ P,PATSCH ; FIXUP SCHLPAGE
3753 PATL: SKIPL E,3(D) ; SKIP IF NEXT EXISTS
3759 MOVEM E,3(D) ; SAY GVAL ETC. EXISTS IF WE UNBIND
3763 IMFUNCTION DEFMAC,FSUBR
3770 IMFUNCTION DFNE,FSUBR,[DEFINE]
3778 SKIPN B,1(AB) ; GET ATOM
3780 GETYP A,(B) ; MAKE SURE ATOM
3785 MCALL 1,EVAL ; EVAL IT TO AN ATOM
3788 PUSH TP,A ; SAVE TWO COPIES
3790 PUSHJ P,IGVAL ; SEE IF A VALUE EXISTS
3791 CAMN A,$TUNBOU ; SKIP IF A WINNER
3793 PUSHJ P,ASKUSR ; CHECK WITH USER
3800 SKIPN (P) ; SKIP IF MACRO
3802 MOVEI D,(B) ; READY TO CONS
3809 DFNE1: POP TP,B ; RETURN ATOM
3814 ASKUSR: MOVE B,IMQUOTE REDEFINE
3815 PUSHJ P,ILVAL ; SEE IF REDEFINE OK
3821 ASKUS1: PUSH TP,$TATOM
3824 PUSH TP,EQUOTE ALREADY-DEFINED-ERRET-NON-FALSE-TO-REDEFINE
3834 ;SET CLOBBERS THE LOCAL VALUE OF THE IDENTIFIER GIVEN BY ITS
3835 ;FIRST ARGUMENT TO THE SECOND ARG. ITS VALUE IS ITS SECOND ARGUMENT.
3838 HLRE D,AB ; 2 TIMES # OF ARGS TO D
3839 ASH D,-1 ; - # OF ARGS
3841 JUMPG D,TFA ; NOT ENOUGH
3844 JUMPE D,SET1 ; NO ENVIRONMENT
3845 AOJL D,TMA ; TOO MANY
3846 GETYP A,4(AB) ; CHECK ARG IS A FRAME OR PROCESS
3849 JRST SET2 ; WINNING ENVIRONMENT/FRAME
3851 JRST SET2 ; TO MAKE PFISTER HAPPY
3854 MOVE B,5(AB) ; GET PROCESS
3857 SET2: MOVEI B,4(AB) ; POINT TO FRAME
3858 PUSHJ P,CHFRM ; CHECK IT OUT
3859 MOVE B,5(AB) ; GET IT BACK
3860 MOVE C,SPSAV(B) ; GET BINDING POINTER
3861 HRRZ B,4(AB) ; POINT TO PROCESS
3862 HLRZ A,(B) ; GET LENGTH
3863 SUBI B,-1(A) ; POINT TO START THEREOF
3864 HLL B,PVSTOR+1 ; GET -LNTRH, (ALL PROCESS VECS SAME LENGTH)
3865 SET1: PUSH TP,$TPVP ; SAVE PROCESS
3867 PUSH TP,$TSP ; SAVE PATH POINTER
3869 GETYP A,(AB) ;GET TYPE OF FIRST
3870 CAIE A,TATOM ;ARGUMENT --
3871 JRST WTYP1 ;BETTER BE AN ATOM
3872 MOVE B,1(AB) ;GET PTR TO IT
3877 PUSHJ P,AILOC ;GET LOCATIVE TO VALUE
3878 GOTLOC: CAMN A,$TUNBOUND ;BOUND?
3879 PUSHJ P, BSET ;BIND IT
3880 MOVE C,2(AB) ; GET NEW VAL
3882 MOVSI A,TLOCD ; FOR MONCH
3884 PUSHJ P,MONCH0 ; HURRAY FOR MONITORS!!!!!
3886 HLRZ A,2(E) ; GET DECLS
3887 JUMPE A,SET3 ; NONE, GO
3891 HLLZ A,(A) ; GET PATTERN
3892 PUSHJ P,TMATCH ; MATCH TMEM
3898 SET3: MOVEM C,(E) ;CLOBBER IDENTIFIER
3902 MOVE C,-2(TP) ; GET PROC
3906 ; HERE WE NOTE THAT EFFICIENCY CAN SOMETIMES GET IN THE WAY OF CORRECTNESS
3907 ; BY SETTING THE SHALLOW BINDING WE MANAGE TO CLOBBER THE TOP LEVEL LVAL
3908 ; EVEN IF WE ARE SETTING WITH RESPECT TO A DIFFERENT FRAME. TO CORRECT
3909 ; THIS GLITCH THIS ACTIVITY WILL ONLY TAKE PLACE IF THE ATOM ALREADY POINTS
3917 NSHALL: SUB TP,[4,,4]
3921 CAMN PVP,-2(TP) ; SKIP IF PROC DIFFERS
3922 MOVEM C,-2(TP) ; ELSE USE RESULT FROM LOC SEARCH
3923 MOVE B,-2(TP) ; GET PROCESS
3924 HRRZ A,TPBASE+1(B) ;GET ACTUAL STACK BASE
3925 HRRZ B,SPBASE+1(B) ;AND FIRST BINDING
3926 SUB B,A ;ARE THERE 6
3927 CAIL B,6 ;CELLS AVAILABLE?
3929 MOVE C,(TP) ; GET POINTER BACK
3930 MOVEI B,0 ; LOOK FOR EMPTY SLOT
3932 CAMN A,$TUNBOUND ; SKIP IF FOUND
3934 MOVE E,1(AB) ; GET ATOM
3935 MOVEM E,-1(B) ; AND STORE
3937 BSET1: MOVE B,-2(TP) ; GET PROCESS
3938 ; PUSH TP,TPBASE(B) ;NO -- GROW THE TP
3939 ; PUSH TP,TPBASE+1(B) ;AT THE BASE END
3945 ; MOVE C,-2(TP) ; GET PROCESS
3946 ; MOVEM A,TPBASE(C) ;SAVE RESULT
3947 PUSH P,0 ; MANUALLY GROW VECTOR
3956 DPB D,[001100,,-1(C)]
3957 MOVE C,[5,,3] ; SET UP INDICATORS FOR AGC
3960 MOVE B,TPBASE+1(PVP) ; MODIFY POINTER
3961 MOVE 0,LVLINC ; ADJUST SPBASE POINTER
3966 MOVEM B,TPBASE+1(PVP)
3969 ; MOVEM B,TPBASE+1(C)
3970 SETIT: MOVE C,-2(TP) ; GET PROCESS
3972 MOVEI A,-6(B) ;MAKE UP BINDING
3973 HRRM A,(B) ;LINK PREVIOUS BIND BLOCK
3981 BSET2: MOVE C,-2(TP) ; GET PROC
3984 HLRZ D,OTBSAV(TB) ; TIME IT
3985 MOVEM D,2(B) ; AND FIX IT
3988 ; HERE TO ELABORATE ON TYPE MISMATCH
3990 TYPMI2: MOVE C,(TP) ; FIND DECLS
3994 MOVE 0,(AB) ; GET ATOM
4002 GETYP A,(AB) ; GET TYPE
4003 CAIE A,TFALSE ;IS IT FALSE?
4004 JRST IFALSE ;NO -- RETURN FALSE
4007 MOVSI A,TATOM ;RETURN T (VERITAS)
4016 MFUNCTION ANDA,FSUBR,AND
4022 JRST WRONGT ;IF ARG DOESN'T CHECK OUT
4024 SKIPN C,1(AB) ;IF NIL
4025 JRST TF(E) ;RETURN TRUTH
4026 PUSH TP,$TLIST ;CREATE UNNAMED TEMP
4030 JUMPE C,TFI(E) ;ANY MORE ARGS?
4031 MOVEM C,1(TB) ;STORE CRUFT
4035 PUSH TP,1(C) ;ARGUMENT
4041 JRST FINIS ;IF FALSE -- RETURN
4042 HRRZ C,@1(TB) ;GET CDR OF ARGLIST
4051 TFSKP: CAIE 0,TFALSE
4054 IMFUNCTION FUNCTION,FSUBR
4062 \f;SUBR VERSIONS OF AND/OR
4064 MFUNCTION ANDP,SUBR,[AND?]
4066 MOVE C,[CAIN 0,TFALSE]
4069 MFUNCTION ORP,SUBR,[OR?]
4071 MOVE C,[CAIE 0,TFALSE]
4072 BOOL: HLRE A,AB ; GET ARG COUNTER
4074 ASH A,-1 ; DIVIDES BY 2
4079 CANDP: SKIPA C,[CAIN 0,TFALSE]
4080 CORP: MOVE C,[CAIE 0,TFALSE]
4085 SUBB TP,D ; POINT TO ARGS & FIXUP TP PTR
4086 AOBJP D,.+1 ; FIXUP ARG PTR AND FALL INTO CBOOL
4090 JRST CBOOL1 ; YES RETURN IT
4092 SOJG A,CBOOL ; ANY MORE ?
4093 SUB D,[2,,2] ; NO, USE LAST
4099 CNOARG: MOVSI 0,TFALSE
4105 CNOAND: MOVSI A,TATOM
4110 MFUNCTION CLOSURE,SUBR
4112 SKIPL A,AB ;ANY ARGS
4113 JRST TFA ;NO -- LOSE
4114 ADD A,[2,,2] ;POINT AT IDS
4117 PUSH P,[0] ;MAKE COUNTER
4119 CLOLP: SKIPL A,1(TB) ;ANY MORE IDS?
4120 JRST CLODON ;NO -- LOSE
4121 PUSH TP,(A) ;SAVE ID
4123 PUSH TP,(A) ;GET ITS VALUE
4125 ADD A,[2,,2] ;BUMP POINTER
4131 MCALL 2,LIST ;MAKE PAIR
4137 ACALL A,LIST ;MAKE UP LIST
4138 PUSH TP,(AB) ;GET FUNCTION
4142 MCALL 2,LIST ;MAKE LIST
4148 ;ERROR COMMENTS FOR EVAL
4150 BADNUM: ERRUUO EQUOTE NEGATIVE-ARGUMENT
4152 WTY1TP: ERRUUO EQUOTE FIRST-ARG-WRONG-TYPE
4154 UNBOU: PUSH TP,$TATOM
4155 PUSH TP,EQUOTE UNBOUND-VARIABLE
4158 UNAS: PUSH TP,$TATOM
4159 PUSH TP,EQUOTE UNASSIGNED-VARIABLE
4163 ERRUUO EQUOTE BAD-ENVIRONMENT
4166 ERRUUO EQUOTE BAD-FUNARG
4183 MPD: ERRUUO EQUOTE MEANINGLESS-PARAMETER-DECLARATION
4185 NOBODY: ERRUUO EQUOTE HAS-EMPTY-BODY
4187 BADCLS: ERRUUO EQUOTE BAD-CLAUSE
4189 NXTAG: ERRUUO EQUOTE NON-EXISTENT-TAG
4191 NXPRG: ERRUUO EQUOTE NOT-IN-PROG
4194 NAPT: ERRUUO EQUOTE NON-APPLICABLE-TYPE
4196 NONEVT: ERRUUO EQUOTE NON-EVALUATEABLE-TYPE
4199 NONATM: ERRUUO EQUOTE NON-ATOMIC-ARGUMENT
4202 ILLFRA: ERRUUO EQUOTE FRAME-NO-LONGER-EXISTS
4204 ILLSEG: ERRUUO EQUOTE ILLEGAL-SEGMENT
4206 BADMAC: ERRUUO EQUOTE BAD-USE-OF-MACRO
4208 BADFSB: ERRUUO EQUOTE APPLY-OR-STACKFORM-OF-FSUBR
4211 ER1ARG: PUSH TP,(AB)