1 TITLE EVAL -- MUDDLE EVALUATOR
5 ; GERALD JAY SUSSMAN, 1971
8 .GLOBAL PROCID,LPROG,GLOBSP,GLOBASE,SPBASE,TPBASE,PTIME,SWAP
9 .GLOBAL IGVAL,CHKARG,NXTDCL,TPOVFL,CHFRM
10 .GLOBAL ILVAL,CALER,CALER1,ER1ARG,SPECBIND,SPECSTORE,WRONGT,ERRTMA
11 .GLOBAL IDVAL,EVECTO,EUVECT,CHARGS,BCKTRK,CELL
12 .GLOBAL PDLBUF,MESS,FACTI,ITRUTH,FLFLG,PDLOSS,AGC
13 .GLOBAL PGROW,TPGROW,PDLGRO
19 HLRZ A,AB ;GET NUMBER OF ARGS
21 JRST AEVAL ;EVAL WITH AN ALIST
22 NORMEV: HLRZ A,(AB) ;GET TYPE OF ARG
23 CAILE A,NUMPRI ;PRIMITIVE?
25 JRST @EVTYPT(A) ;YES-DISPATCH
27 SELF: MOVE A,(AB) ;TYPES WHICH EVALUATE
29 JRST FINIS ;TO SELF-EG NUMBERS
31 ;EVALUATES A IDENTIFIER -- GETS LOCAL VALUE IF THERE IS ONE, OTHERWISE GLOBAL.
39 PUSH TP,B ;SAVE ARG IN CASE NEED TO CHECK GLOBAL VALUE
40 PUSHJ P,ILVAL ;LOCAL VALUE FINDER
43 CAME A,$TUNBOUND ;IF NOT UNBOUND OR UNASSIGNED
44 JRST RIDVAL ;DONE - CLEAN UP AND RETURN
45 POP TP,B ;GET ARG BACK
54 ;GETS THE LOCAL VALUE OF AN IDENTIFIER
71 PUSH TP,(AB) ;IF UNBOUND,
72 PUSH TP,1(AB) ;BIND IT GLOBALLY TO ?()
79 MFUNCTION UNASSP,SUBR,[UNASSIGNED?]
88 ; GETS A LOCATIVE TO THE LOCAL VALUE OF AN IDENTIFIER.
99 ;TESTS TO SEE IF AN IDENTIFIER IS LOCALLY BOUND
101 MFUNCTION BOUND,SUBR,[BOUND?]
108 ;TESTS TO SEE IF AN IDENTIFIER IS LOCALLY ASSIGNED
110 MFUNCTION ASSIGP,SUBR,[ASSIGNED?]
119 ;GETS THE GLOBAL VALUE OF AN IDENTIFIER
128 ;GETS A LOCATIVE TO THE GLOBAL VALUE OF AN IDENTIFIER
138 ;TESTS TO SEE IF AN IDENTIFIER IS GLOBALLY ASSIGNED
140 MFUNCTION GASSIG,SUBR,[GASSIGNED?]
156 ;EVALUATE A FORM. IF CAR IS AN ATOM USE GLOBAL VALUE OVER LOCAL ONE.
158 EVFORM: SKIPN C,1(AB) ;EMPTY?
160 HLLZ A,(C) ;GET CAR TYPE
161 CAME A, $TATOM ;ATOMIC?
162 JRST EV0 ;NO -- CALCULATE IT
163 MOVE B,1(C) ;GET PTR TO ATOM
165 JRST EVATOM ;".X" EVALUATED QUICKLY
166 EVFRM1: PUSHJ P,IGVAL
171 JRST IAPPLY ;APPLY IT
172 EV0: PUSH TP,A ;SET UP CAR OF FORM AND
175 MCALL 1,EVAL ;EVALUATE IT
176 PUSH TP,A ;APPLY THE RESULT
177 PUSH TP,B ;AS A FUNCTION
188 ;HERE TO EVALUATE AN ATOM
190 EVATOM: HRRZ D,(C) ;D _ REST OF FORM
191 MOVE A,(D) ;A _ TYPE OF ARG
194 MOVE B,1(D) ;B _ ATOM POINTER
195 JRST LVAL2 ;SIMULATE .MCALL TO LVAL
197 ;DISPATCH TABLE FOR EVAL
198 DISTBL EVTYPT,SELF,[[TLIST,EVLIST],[TFORM,EVFORM],[TVEC,EVECT],[TSEG,ILLSEG],[TUVEC,EUVEC]]
200 \f;AEVAL DOES RELATIVE EVALUATIONS WITH RESPECT TO
201 ;AN ENVIRONMENT OR FRAME. A FALSE ENVIRONMENT IS EQUIVALENT TO THE
204 AEVAL: CAIE A,-4 ;EXACTLY 2 ARGS?
206 HLRZ A,2(AB) ;CHECK THAT WE HAVE AN ENV OR FRAME
214 MOVE A,3(AB) ;A _ FRAME POINTER
216 HLL B,OTBSAV(A) ;CHECK ITS TIME...
220 CAIE C,TENTRY ;...AND CONTENTS
223 EWRTFM: MOVE B,SPSAV(A) ;NOW USE THE NITTY-GRITTY
224 CAMN SP,B ;NAMELY, THE FRAME'S ACCESS ENVIRONMENT
225 JRST NORMEV ;UNLESS IT ISN'T NEW
226 PUSH TP,2(AB) ;NOW SIMULATE AN EWRTNV ON A TENV
233 POP TP,3(AB) ;RESTORE WITH FRAME
235 JRST NORMEV
\fMFUNCTION SPLICE,SUBR
236 ENTRY 2 ;<SPLICE CURRENT NEW>
239 JRST ITRUTH ;IF .NEW = <>, EASY;
241 JRST WTYP ;OTHERWISE,
242 GETYP A,(AB) ;TWO ENVIRONMENTS NEEDED
245 MOVE A,1(AB) ;.CURRENT = .NEW?
247 JRST ITRUTH ;HOPEFULLY
249 PUSH TP,SP ;SAVE CURRENT SP
251 .VALUE [ASCIZ /TIMEOUT/]
252 PUSHJ P,FINDSP ;SP _ A, AMONG OTHER THINGS
253 PUSHJ P,ISPLIC ;SPLICE IT
254 EXCH SP,1(TB) ;RESTORE SP,
256 MOVE SP,1(TB) ;UNLESS SPLICE DONE TO TOP OF SP
257 MOVEM SP,SPSAV(TB) ;SPSAV SLOT CLOBBERED BY FINDSP
258 PUSH TP,$TFIX ;SAVE OLD PROCID
260 FPOINT UNSPLI,4 ;SET FAILPOINT
265 UNSPLI: MOVE A,1(TB) ;A _ SPLICE VECTOR ADDRESS
266 MOVEM SP,1(TB) ;SAVE SP
267 MOVE E,3(TB) ;E _ OLD PROCID
268 PUSHJ P,FINDSP ;SP _ SPLICE VECTOR
269 MOVEM E,PROCID+1(PVP) ;RESET OLD PROCID
270 MOVE SP,3(SP) ;SP _ REBIND ENVIRONMENT
271 JUMPE C,IFAIL ;IF C = 0, KEEP FAILING
272 MOVEM SP,1(C) ;RECLOBBER ACCESS TO REBIND
273 MOVE SP,1(TB) ;IF NOTHING LOWER, SP _ SAME AS BEFORE
277 ;SPECIAL CASE FOR EVAL WITH ENVIRONMENT
279 EWRTNV: CAMN SP,3(AB) ;ALREADY GOT?
282 .VALUE [ASCIZ /TIMEOUT/]
287 ;SEARCH FOR A THROUGH ENVIRONMENTS, SETTING SP AS YOU GO
288 ;CLOBBER ALL PROCID'S OF BOUND ATOMS TO E, AND CLOBBER
289 ;LOCATIVES IN ALL BIND BLOCKS EXCEPT FOR LAST VECTOR
297 .VALUE [ASCIZ /SPOVERPOP/]
300 ;CLOBBER ALL LOCATIVES IN LAST BIND VECTOR
305 MOVEI C,TFALSE ;MAKE FALSE LOCATIVE
310 JBVEC2: HRRZ B,SP ;B _ SP
311 MOVE C,SP ;C _ BIND BLOCK ADDRESS = SP
312 BLOOP4: GETYP D,(C) ;SEARCH THROUGH BLOCKS ON THIS VECTOR
314 JRST SPLOOP ;GOT TO END
315 MOVE D,1(C) ;ALTER PROCID OF BOUND ATOM
317 HRRZ C,(C) ;NEXT BLOCK
320 ;SPLICE 3(AB) INTO SP
322 ISPLIC: PUSH TP,$TVEC ;SAVE C
328 MCALL 1,VECTOR ;B _ <VECTOR 3>
333 MOVEM D,1(B) ;<PUT .B 1 <3 .AB>>
334 MOVEM SP,3(B) ;<PUT .B 2 .SP>
337 MOVEM D,4(SP) ;GET SET TO STORE NEW PROCID
338 MOVE E,(TP) ;E _ NEW PROCID
339 EXCH E,PROCID+1(PVP) ;E _ OLD PROCID
340 MOVEM E,5(SP) ;SAVE OLD PROCID IN BIND VECTOR
342 SKIPE C,2(TP) ;RECOVER C
343 MOVEM SP,1(C) ;COMPLETE SPLICE
344 POPJ P,
\fMFUNCTION APPLY,SUBR
346 MOVE A,(AB) ;SAVE FUNCTION
350 GETYP A,2(AB) ;AND ARG LIST
352 JRST WTYP ;WHICH SHOULD BE LIST
357 PUSH P,[0] ;"UNEVAL" MARKER
360 IAPPLY: MOVSI A,TLIST
364 HRRZ 0,1(AB) ;0 _ CALL
365 PUSH P,[-1] ;"EVAL" MARKER
369 CAIN A,TSUBR ;NO -- SUBR?
371 CAIN A,TFSUBR ;NO -- FSUBR?
373 CAIN A,TFIX ;NO -- CALL TO NTH?
375 CAIN A,TACT ;NO -- ACTIVATION?
377 CAIN A,TFUNARG ;NO -- FUNARG?
379 CAIN A,TPVP ;NO -- PROCESS TO BE RESUMED?
381 JRST NAPT ;NONE OF THE ABOVE
384 ;APFSUBR CALLS FSUBRS
393 PUSH P,[0] ;MAKE SLOT FOR ARGCNT
395 SKIPN A,3(TB) ;IS IT NIL?
396 JRST MAKPTR ;YES -- DONE
397 PUSH TP,(A) ;NO -- GET CAR OF THE
403 MCALL 1,EVAL ;AND EVAL IT.
404 PUSH TP,A ;SAVE THE RESULT IN
405 PUSH TP,B ;THE GROWING TUPLE
406 BUMP: AOS (P) ;BUMP THE ARGCNT
407 HRRZ A,@3(TB) ;SET THE ARGLIST TO
408 MOVEM A,3(TB) ;CDR OF THE ARGLIST
415 ;APACT INTERPRETS ACTIVATIONS AS CALLS TO FUNCTION EXIT
417 APACT: MOVE A,(TP) ;A _ ARGLIST
419 GETYP B,(A) ;SETUP SECOND ARGUMENT
423 HRRZ A,(A) ;MAKE SURE ONLY ONE
426 SKIPN (P) ;IF ARGUMENT AS YET UNEVALED,
428 MCALL 1,EVAL ;EVAL IT
431 MCALL 2,EXIT ;AND EXIT GIVEN ACTIVATION
\f
433 ;APNUM INTERPRETS NUMBERS AS CALL TO FUNCTION GET
436 MOVE A,(TP) ;GET ARLIST
437 JUMPE A,ERRTFA ;NO ARGUMENT
438 PUSH TP,(A) ;GET CAR OF ARGL
441 HRRZ A,(A) ;MAKE SURE ONLY ONE ARG
443 JSP E,CHKARG ;HACK DEFERRED
454 ;APEXPR APPLIES EXPRS
455 ;EXPRESSION IS IN 0(AB), FUNCTION IS IN 0(TB)
463 JRST NOBODY ;NO, ERROR
464 MOVE D,(TP) ;D _ ARG LIST
465 SETZM (TP) ;ZERO (TP) FOR BODY
466 PUSHJ P,BINDAP ;DO THE BINDINGS
468 APEXP1: HRRZ C,1(TB) ;GET BODY BACK
469 TRNE A,H ;SKIP IF NO HEWITT ATOM
470 HRRZ C,(C) ;ELSE CDR AGAIN
474 ;MAKE SURE ARGUMENT PUSHED ON STACK IS NOT OF TYPE DEFER
477 CHKARG: GETYP A,-1(TP)
480 HRRZS (TP) ;MAKE SURE INDIRECT WINS
482 MOVEM A,-1(TP) ;CLOBBER IN TYPE SLOT
483 MOVE A,(TP) ;NOW GET POINTER
484 MOVE A,1(A) ;GET VALUE
485 MOVEM A,(TP) ;CLOBBER IN
489 EVLIST: PUSHJ P,PSHRG1 ;EVALUATE EVERYTHING
490 PUSH P,C ;SAVE COUNTER
491 EVLIS1: JUMPE C,EVLDON ;IF C=0, DONE
492 PUSH TP,A ;ELSE, CONS
494 MCALL 2,CONS ;(A,B) _ ((TP) !(A,B))
495 SOS C,(P) ;DECREMENT COUNTER
503 EVECT: PUSH P,[0] ;COUNTER
504 GETYPF A,(AB) ;COPY INPUT VECTOR POINTER
509 SKIPL A,1(TB) ;IF VECTOR EMPTY,
510 JRST MAKVEC ;GO MAKE ITS VALUE
511 GETYPF C,(A) ;C _ TYPE OF NEXT ELEMENT
514 MOVSI C,TFORM ;EVALUATE SEGMENTS LIKE FORMS
517 ADD A,[2,,2] ;TO NEXT VALUE
519 MCALL 1,EVAL ;(A,B) _ VALUE OF NEXT ELEMENT
521 CAME C,$TSEG ;IF SEGMENT,
523 PUSHJ P,PSHSEG ;PUSH ITS ELEMENTS
525 EVCT1: PUSH TP,A ;ELSE PUSH IT
527 AOS (P) ;BUMP COUNTER
530 MAKVEC: POP P,A ;A _ COUNTER
531 .ACALL A,EVECTOR ;CALL VECTOR CONSTRUCTOR
535 ;UNIFORM VECTOR EVALUATOR
537 EUVEC: GETYPF A,(AB) ;COPY INPUT VECTOR POINTER
540 HLRE C,1(TB) ;C _ - NO. OF WORDS: TO DOPE WORD
542 SUBM A,C ;C _ ADDRESS OF DOPE WORD
544 PUSH P,A ;-1(P) _ TYPE OF UVECTOR
545 PUSH P,[0] ;0(P) _ COUNTER
547 SKIPL A,1(TB) ;IF VECTOR EMPTY,
548 JRST MAKUVC ;GO MAKE ITS VALUE
549 MOVE C,-1(P) ;C _ TYPE
551 MOVSI C,TFORM ;EVALUATE SEGMENTS LIKE FORMS
554 ADD A,[1,,1] ;TO NEXT VALUE
556 MCALL 1,EVAL ;(A,B) _ VALUE OF NEXT ELEMENT
558 CAME C,$TSEG ;IF SEGMENT,
560 PUSHJ P,PSHSEG ;PUSH ITS ELEMENTS
562 EUVCT1: PUSH TP,A ;ELSE PUSH IT
564 AOS (P) ;BUMP COUNTER
567 MAKUVC: POP P,A ;A _ COUNTER
568 .ACALL A,EUVECT ;CALL VECTOR CONSTRUCTOR
569 SUB P,[1,,1] ;FLUSH TYPE
571 \f;ENTRY POINT FOR PUSHING ALL BUT LAST SEGMENT, IF ANY,
572 ;WHICH IS IN (A,B) INSTEAD OF ON STACK. IF NO LAST SEGMENT
573 ;(OR IT IS NOT A LIST), (A,B) = () INSTEAD.
575 PSHSW=-1 ;SWITCH BENEATH COUNTER ON STACK
576 CPYLST==1 ;SWITCH ON IFF LAST SEGMENT TO BE COPIED LIKE OTHERS
578 PSHRG1: PUSH P,[0] ;DON'T COPY LAST SEGMENT
581 ;INTERNAL ARG LIST PUSHER-- ACCEPTS SEGMENTS, LEAVES COUNTER OF
584 PSHRGL: PUSH P,[1] ;COPY FINAL SEGMENT
585 PSHRG2: PUSH P,[0] ;(P) IS A COUNTER
586 GETYPF A,(AB) ;COPY ARGLIST POINTER
591 SKIPN A,1(TB) ;A _ NEXT LIST CELL ADDRESS
592 JRST ARGSDN ;IF 0, DONE
593 HRRZ B,(A) ;CDR THE ARGS
595 GETYP C,(A) ;C _ TRUE TYPE OF CELL ELEMENT
597 CAME C,$TDEFER ;DON'T ACCEPT DEFERREDS
601 IEVL3: PUSH P,C ;SAVE TYPE
602 CAMN C,$TSEG ;IF SEGMENT
603 MOVSI C,TFORM ;EVALUATE IT LIKE A FORM
606 MCALL 1,EVAL ;(A,B) _ VALUE OF NEXT ELEMENT
608 CAME C,$TSEG ;IF SEGMENT,
610 CAMN A,$TLIST ;THAT TURNED OUT TO BE A LIST,
611 SKIPE 1(TB) ;CHECK IF LAST
612 JRST IEVL1 ;IF NOT, COPY IT
613 MOVE 0,PSHSW(P) ;IF SO, AND "COPY LAST"
614 TRNN 0,CPYLST ; SWITCH IS OFF
615 JRST IEVL5 ;DON'T COPY
616 IEVL1: PUSHJ P,PSHSEG ;PUSH SEGMENT'S ELEMENTS
618 IEVL4: PUSH TP,A ;ELSE PUSH IT
620 AOS (P) ;BUMP COUNTER
623 ARGSDN: MOVE B,PSHSW(P) ;B _ SWITCH WORD
624 TRNN B,CPYLST ;IF COPY LAST SWITCH OFF,
625 MOVSI A,TLIST ; (A,B) _ ()
626 IEVL5: POP P,C ;C _ FINAL COUNT
627 SUB P,[1,,1] ;PITCH SWITCH WORD
628 POPJ P,
\f;THIS FUNCTION PUSHES THE ELEMENTS OF THE STRUCTURE (A,B) ONTO
629 ;TP; (P) = RETURN ADDRESS; -1(P) = COUNTER (SET UP BY CALLER)
631 PSHSEG: MOVEM A,BSTO(PVP) ;TYPE FOR AGC
633 PUSHJ P,SAT ;A _ PRIMITIVE TYPE OF (A,B)
635 JRST PSHLST ;YES-- DO IT!
636 HLRE C,B ;MUST BE SOME KIND OF VECTOR OR TUPLE
637 MOVNS C ;C _ NUMBER OF WORDS TO DOPE WORD
638 CAIN A,SNWORD ;UVECTOR?
639 JRST PSHUVC ;YES-- DO IT!!
640 ASH C,-1 ;NO-- C _ C/2 = NUMBER OF ELEMENTS
641 ADDM C,-1(P) ;BUMP COUNTER
642 CAIN A,S2NWORD ;VECTOR?
643 JRST PSHVEC ;YES-- DO IT!!!
644 CAIE A,SARGS ;ARGS TUPLE?
645 JRST ILLSEG ;NO-- DO IT!!!!
646 PUSH TP,BSTO(PVP) ;YES-- CHECK FOR LEGALITY
649 MOVEI B,-1(TP) ;B _ ARGS POINTER ADDRESS
650 PUSHJ P,CHARGS ;CHECK IT OUT
651 POP TP,B ;RESTORE WORLD
655 JUMPGE B,SEGDON ;IF B = [], QUIT
656 PUSH TP,(B) ;PUSH NEXT ELEMENT
658 ADD B,[2,,2] ;B _ <REST .B>
661 PSHUVC: ADDM C,-1(P) ;BUMP COUNTER
662 ADDM B,C ;C _ DOPE WORD ADDRESS
663 GETYP A,(C) ;A _ UVECTOR ELEMENTS TYPE
666 JUMPGE B,SEGDON ;IF B = ![], QUIT
667 PUSH TP,A ;PUSH NEXT ELEMENT WITH TYPE
669 ADD B,[1,,1] ;B _ <REST .B>
673 JUMPE B,SEGDON ;IF B = (), QUIT
675 MOVSI A,(A) ;PUSH NEXT ELEMENT
678 JSP E,CHKARG ;KILL TDEFERS
679 AOS -1(P) ;COUNT ELEMENT
683 SEGDON: SETZM BSTO(PVP) ;FIX TYPE
684 POPJ P,
\f;THESE THREE CONSTRUCTOR FUNCTIONS ARE USED
685 ;TO SIMULATE "VARIABLE BRACKETS"; FOR EXAMPLE, <CONSV ...>
690 MFUNCTION CONSL,FSUBR
691 JRST EVLIST ;DEGENERATE CASE
695 MFUNCTION CONSV,FSUBR
696 PUSHJ P,PSHRGL ;EVALUATE ARGS
697 .ACALL C,EVECTOR ;AND CALL EVECTOR ON THEM
702 MFUNCTION CONSU,FSUBR
703 PUSHJ P,PSHRGL ;VERY SIMILAR
704 .ACALL C,EUVECT ;BUT CALL EUVECT INSTEAD
707 ;APFUNARG APPLIES OBJECTS OF TYPE FUNARG
710 HRRZ A,@1(TB) ;GET CDR OF FUNARG
711 JUMPE A,FUNERR ;NON -- NIL
712 HLRZ B,(A) ;GET TYPE OF CADR
713 CAIE B,TLIST ;BETTR BE LIST
715 PUSH TP,$TLIST ;SAVE IT UP
719 SKIPN A,3(TB) ;ANY MORE
720 JRST DOF ;NO -- APPLY IT
727 HLRZ C,(A) ;GET FIRST VAR
728 CAIE C,TATOM ;MAKE SURE IT IS ATOMIC
730 PUSH TP,BNDA ;SET IT UP
733 PUSH TP,(A) ;SET IT UP
740 PUSHJ P,SPECBIND ;BIND THEM
741 MOVE A,1(TB) ;GET GOODIE
745 HRRZ A,3(TB) ;A _ ARG LIST
755 ;ILOC RETURNS IN A AND B A LOCATIVE TO THE LOCAL VALUE OF THE IDENTIFIER PASSED TO IT
756 ;IN A AND B. IF THE IDENTIFIER IS LOCALLY UNBOUND IT RETURNS $TUNBOUND IN A AND 0 IN B,
757 ; IT IS CALLED BY PUSHJ P,ILOC. IT CLOBBERS A, B, C, & 0
759 ILOC: MOVSI A,TLOCI ;MAKE A LOCATIVE TYPE CELL
760 HRR A,PROCID+1(PVP) ;FOR THE CURRENT PROCESS
761 CAME A,(B) ;IS THERE ONE IN THE VALUE CELL?
762 JRST SCHSP ;NO -- SEARCH THE LOCAL BINDINGS
763 MOVE B,1(B) ;YES -- GET LOCATIVE POINTER
764 POPJ P, ;FROM THE VALUE CELL
766 SCHSP: PUSH P,0 ;SAVE 0
767 MOVE C,SP ;GET TOP OF BINDINGS
768 SCHLP: JUMPE C,NPOPJ ;IF NO MORE, LOSE
770 CAIN 0,TSP ;INDIRECT LINK TO NEXT BIND BLOCK?
772 CAMN B,1(C) ;FOUND ATOM?
774 HRR C,(C) ;FOLLOW CHAIN
777 NXVEC2: MOVE C,1(C) ;GET NEXT BLOCK
780 SCHFND: EXCH B,C ;SAVE THE ATOM PTR IN C
781 ADD B,[2,,2] ;MAKE UP THE LOCATIVE
783 MOVEM A,(C) ;CLOBBER IT AWAY INTO THE
784 MOVEM B,1(C) ;ATOM'S VALUE CELL
785 SCHPOP: POP P,0 ;RESTORE 0
788 NPOPJ: POP P,0 ;RESTORE 0
789 UNPOPJ: MOVSI A,TUNBOUND
793 ;IGLOC RETURNS IN A AND B A LOCATIVE TO THE GLOBAL VALUE OF THE
794 ;IDENTIFIER PASSED TO IT IN A AND B. IF THE IDENTIFIER IS GLOBALLY
795 ;UNBPOUND IT RETURNS $TUNBOUND IN A AND 0 IN B. IT IS CALLED BY PUSHJ P,IGLOC.
797 \rIGLOC: MOVSI A,TLOCI ;DO WE HAVE A LOCATIVE TO
798 CAME A,(B) ;A PROCESS #0 VALUE?
799 JRST SCHGSP ;NO -- SEARCH
800 MOVE B,1(B) ;YES -- GET VALUE CELL
803 SCHGSP: MOVE D,GLOBSP+1(TVP) ;GET GLOBAL SP PTR
805 SCHG1: JUMPGE D,UNPOPJ ;IF NO MORE, LEAVE
806 CAMN B,1(D) ;ARE WE FOUND?
808 ADD D,[4,,4] ;NO -- TRY NEXT
811 GLOCFOUND: EXCH B,D ;SAVE ATOM PTR
812 ADD B,[2,,2] ;MAKE LOCATIVE
813 MOVEM A,(D) ;CLOBBER IT AWAY
820 ;ILVAL RETURNS IN A AND B THE LOCAL VALUE OF THE IDENTIFIER PASSED TO IT IN A AND B
821 ;IF THE IDENTIFIER IS UNBOUND ITS VALUE IS $TUNBOUND IN A AND 0 IN B. IF
822 ;IT IS UNASSIGNED ITS VALUE IS $TUNBOUND IN A AND -1 IN B. CALL - PUSHJ P,IVAL
825 PUSHJ P,ILOC ;GET LOCATIVE TO VALUE
826 CHVAL: CAMN A,$TUNBOUND ;BOUND
827 POPJ P, ;NO -- RETURN
828 MOVE A,(B) ;GET THE TYPE OF THE VALUE
829 MOVE B,1(B) ;GET DATUM
832 ;IGVAL -- LIKE ILVAL EXCEPT FOR GLOBAL VALUES
838 \fMFUNCTION BIND,FSUBR
841 CAIE A,TLIST ;ARG MUST BE LIST
843 SKIPN C,1(AB) ;C _ BODY
847 PUSH TP,(C) ;EVAL FIRST ELEMENT
853 PUSH TP,B ;SAVE VALUE
854 GETYP A,A ;WHICH MUST BE LIST
858 HRRZ C,-2(TP) ;C _ <REST .C>
860 JUMPE C,NOBODY ;MUST NOT BE EMPTY
861 PUSH TP,(C) ;EVALUATE FIRST ELEMENT
868 CAIN A,TFALSE ;CAN BE #FALSE OR LIST
869 JRST DOBI ;IF <>, AUXILIARY BINDINGS
873 MOVEI D,(B) ;D _ DECLARATIONS
874 DOBI: POP TP,C ;RESTORE C _ FIRST ARG
880 HRRZ C,(C) ;C _ <REST <REST .ARG>>
881 JRST BIPROG ;NOW EXECUTE BODY AS PROG
\f
883 ;BINDER - THIS SUBROUTINE PROCESSES FUNCTION DECLARATIONS AND BINDS
884 ; ARGUMENTS AND TEMPORARIES APPROPRIATELY.
886 ; CALL: PUSHJ P,BINDER OR BINDRR
888 ; BINDAP - ARGS ARE ON A LIST, EVALED IFF (P) NOT = 0
890 ; BINDER - ASSUMES ARGS ARE TO BE EVALED
892 ; BINDRR - RESUME HACK - ARGS ON A LIST TO BE
893 ; EVALED IN PARENT PROCESS
896 ; C/ POINTS TO FUNCTION BEING HACKED
897 ; D/ POINTS TO ARG LIST (IF <0, CALLED FROM A PROG)
898 ; 0/ IF NON-ZERO POINTS TO EXPRESSION GENREATING CALL
900 ;EVALER IS STORED ON THE STACK P AND USED TO EVALUATE ARGS WHEN NEEDED
903 ;SWTCHS,STORED ON THE STACK, HOLDS MANY SWITCHES:
906 OPT==1 ;ON IFF ARGUMENTS MAY BE OMITTED
907 QUO==2 ;ON IFF ARGUMENT IS TO BE QUOTED
908 AUX==4 ;ON IFF BINDING "AUX" VARS
909 H==10 ;ON IFF THERE EXISTS A HEWITT ATOM
910 DEF==20 ;ON IFF DEFAULT VALUE OF AN ARG HAS BEEN TAKEN
913 BINDAP: MOVE A,[ARGNEV]
916 POP P,-1(P) ;FLUSH EVAL MARKER
919 BINDER: PUSH P,[ARGEV]
921 BINDRR: PUSH P,[NOTIMP]
922 BIND1: PUSH P,[0] ;OPT _ QUO _ AUX _ H _ OFF
923 PUSH P,0 ;SAVE CALL, IF ANY
924 PUSHJ P,BNDVEC ;E _ TOP OF BINDING STACK
926 CAIE A,TATOM ;HEWITT ATOM?
930 SUB B,A ;B _ FIRST DOPE WORD OF E
932 MOVEM A,-6(B) ;BUILD BIND BLOCK FOR ATOM
933 MOVE A,1(C) ;A _ HEWITT ATOM
936 HLL A,OTBSAV(TB) ;A _ POINTER TO THIS ACTIVATION
940 SUBI 0,-1(A) ;0 _ PROCESS VEC DOPE WORD
941 HRLI 0,TACT ;0 IS FIRST WORD OF ACT VALUE
942 MOVEM 0,-4(B) ;STORED IN BIND BLOCK
943 HRRZ C,(C) ;CDR THE FUNCTION
944 BIND2: POP P,0 ;0 _ CALLING EXPRESSION
945 PUSHJ P,CARLST ;C _ DECLS LIST
946 JRST BINDC ;IF (), QUIT
947 JUMPL D,AUXDO ;IN CASE OF PROG
949 PUSHJ P,NXTDCL ;B _ NEXT STRING
950 JRST BINDRG ;ATOM INSTEAD
951 HRRZ C,(C) ;CDR DECLS
956 CAME B,[ASCII /BIND/ ]
958 JUMPE C,MPD ;GOT "BIND", NOW...
959 PUSHJ P,CARATE ;GET ATOM & START BIND BLOCK
961 MOVE B,1(SP) ;B _ ENV BEFORE BNDVEC
962 PUSHJ P,PSHBND ;FINISH BIND BLOCK
964 JUMPE C,BINDC ;MAY BE DONE
966 PUSHJ P,NXTDCL ;NEXT ONE
967 JRST BINDRG ;ATOM INSTEAD
968 HRRZ C,(C) ;CDR DECLS
972 CHCALL: CAME B,[ASCII /CALL/ ]
973 JRST CHOPTI ;GO INTO MAIN BINDING LOOP
974 JUMPE 0,MPD ;GOT "CALL", SO 0 MUST BE CALL
976 PUSHJ P,CARATE ;GET ATOM & START BIND BLOCK
\f MOVE B,0 ;B _ CALL
978 PUSHJ P,PSHBND ;MAKE BIND BLOCK
979 HRRZ C,(C) ;CDR PAST "CALL" ATOM
980 JUMPE C,BINDC ;IF DONE, QUIT
982 ;DECLLP IS THE MAIN BINDING LOOP FOR HANDLING FUNCTIONAL ARGUMENTS AND
983 ;THE STRINGS SCATTERED THEREIN
986 PUSHJ P,NXTDCL ;NEXT STRING...
987 JRST BINDRG ;...UNLESS SOMETHING ELSE
988 HRRZ C,(C) ;CDR DECLARATIONS
989 CHOPTI: TRZ B,1 ;GOD KNOWS WHY TRZ B,1 (SOMETHING TO DO WITH OPTIO)
991 ;CHECK FOR "OPTIONAL"
993 CAME B,[ASCII /OPTIO/]
995 MOVE 0,SWTCHS(P) ;OPT _ ON
999 PUSHJ P,EBINDS ;BIND ALL PREVIOUS ARGUMENTS
1004 CHREST: MOVE 0,SWTCHS(P) ;0 _ SWITCHES
1005 TRZ 0,OPT ;OPT _ OFF
1008 CAME B,[ASCII /REST/]
1010 PUSHJ P,NXTDCL ;GOT "REST"-- LOOK AT NEXT THING
1012 JRST MPD ;WHICH CAN'T BE STRING
1013 PUSHJ P,BINDB ;GET NEXT ATOM
1015 JRST ARGSDO ;YES-- JUST USE ARGS
1020 CHTUPL: CAME B,[ASCII /TUPLE/]
1022 PUSHJ P,NXTDCL ;GOT "TUPLE"-- LOOK AT NEXT THING
1025 PUSHJ P,CARATE ;WHICH BETTER BE ATOM
1027 TUPLDO: PUSH TP,$TLIST ;SAVE STUFF
1031 PUSH P,[0] ;ARG COUNTER
\f;THIS LOOP BUILDS A TUPLE ON THE STACK, ON THE TOP OF THE ENTITIES
1032 ;JUST SAVED-- DON'T WORRY; THEY'RE SAFE
1034 TUPLP: JUMPE D,TUPDON ;IF NO MORE ARGS, DONE
1035 INTGO ;WATCH OUT FOR BIG TUPLES AND SMALL STACKS
1036 PUSH TP,$TLIST ;SAVE D
1038 GETYP A,(D) ;GET NEXT ARG
1042 TRZ 0,DEF ;OFF DEFAULT
1043 PUSHJ P,@EVALER-1(P)
1046 PUSH TP,A ;BUILD TUPLE
1048 SOS (P) ;COUNT ELEMENTS
1049 HRRZ D,(D) ;CDR THE ARGS
1051 TUPDON: PUSHJ P,MRKTUP ;MAKE A TUPLE OF (P) ENTRIES
1052 SUB P,[1,,1] ;FLUSH COUNTER
1053 JRST BNDRST
\f;CHECK FOR "ARGS"
1055 CHARG: CAME B,[ASCII /ARGS/]
1057 PUSHJ P,NXTDCL ;GOT "ARGS"-- CHECK NEXT THING
1060 PUSHJ P,CARATE ;WHICH MUST BE ATOM
1062 ;HERE TO BIND AN ATOM TO THE REMAINING ARGS, UNEVALUATED
1064 ARGSDO: MOVSI A,TLIST ;(A,B) _ CURRENT ARGS LEFT
1068 ;BNDRST COMPLETES THE BIND BLOCK FOR BOTH TUPLES AND ARGS
1070 BNDRST: PUSHJ P,PSHBND
1071 HRRZ C,(C) ;CDR THE DECLS
1074 PUSHJ P,NXTDCL ;WHAT NEXT?
1075 JRST MPD ;MUST BE A STRING OR ELSE
1076 HRRZ C,(C) ;CDR DECLS
1080 CHAUX: CAME B,[ASCII /AUX/]
1082 JUMPG D,TMA ;ARGS MUST BE USED UP BY NOW
1083 PUSH P,C ;SAVE C ON P (NO GC POSSIBLE)
1084 PUSHJ P,EBIND ;BIND ALL ARG ATOMS
1087 ;HERE FOR AUXIES OF "AUX" OR PROG VARIETY
1089 AUXDO: MOVE 0,SWTCHS(P)
1090 TRO 0,AUX\OPT\DEF ;OPTIONALS OBVIOUSLY ALLOWED
1092 AUXLP: JUMPE C,BNDHAT ;IF NO MORE, QUIT
1094 PUSHJ P,NXTDCL ;GET NEXT DECLARATION STRING
1095 JRST AUXIE ;INSTEAD, ANOTHER AUXIE-- DO IT
1096 HRRZ C,(C) ;CDR PAST STRING
1097 JRST CHACT1 ;...WHICH MUST BE "ACT"
1099 ;NORMAL AUXILIARY DECLARATION HANDLER
1101 AUXIE: MOVE 0,SWTCHS(P)
1102 PUSH TP,$TLIST ;SAVE C
1104 PUSHJ P,BINDB ;PUSH NEXT ATOM ONTO E
1105 MOVE A,$TVEC ;SAVE E UNDER DEFAULT VALUE
1108 PUSH TP,A ;(DEFAULT VALUE MUST BE REPUSHED)
1110 PUSHJ P,@EVALER(P) ;EVAL THE VALUE IT IS TO RECEIVE
1113 PUSHJ P,PSHBND ;COMPLETE BINDING BLOCK WITH VALUE
1114 PUSHJ P,EBIND ;BIND THE ATOM
1117 HRRZ C,(C) ;CDR THE DECLARATIONS
1119 \f;"ACT" CAN OCCUR ONLY AT THE END, HEWITT ATOMS NOTWITHSTANDING
1121 CHACT1: MOVEI D, ;MAKE IT CLEAR THAT THERE ARE NO ARGS
1122 CHACT: CAME B,[ASCII /ACT/] ;ONLY THING POSSIBLE
1124 JUMPE C,MPD ;BETTER HAVE AN ATOM TO BIND TO ACT
1125 PUSHJ P,CARATE ;START BIND BLOCK WITH IT
1128 SUBI A,-1(B) ;A _ PROCESS VEC DOPE WORD
1131 HLL B,OTBSAV(TB) ;(A,B) _ ACTIVATION POINTER
1133 HRRZ C,(C) ;"ACT" MUST HAVE BEEN LAST
1136 ;AT THIS POINT, ALL ENTRIES ARE FINAL AND ALL THINGS LOOSED
1137 ;IN E SHALL BE BOUND IN E, EVENTUALLY
1139 BINDC: JUMPG D,TMA ;ARGS SHOULD BE USED UP BY NOW
1140 PUSHJ P,EBIND ;BIND EVERYTHING NOT BOUND
1141 BNDHAT: MOVE 0,SWTCHS(P) ;EVEN THE HEWITT ATOM
1142 TRNN 0,H ;IF THERE IS ONE
1146 SUB E,B ;E _ DOPE WORD OF BINDING VECTOR
1147 SUB E,[5,,5] ;E _ POINTER TO HEWITT ATOM SLOT
1148 PUSHJ P,COMBLK ;CHAIN THIS BLOCK TO PREVIOUS THING IN VECTOR
1149 ADD E,[4,,4] ;E _ LAST WORD OF BINDING VECTOR
1150 PUSHJ P,EBIND ;BIND THE HEWITT ATOM
1152 ;THIS IS THE WAY OUT OF THE BINDER
1154 BNDRET: POP P,A ;A _ SWITCHES
1155 SUB P,[1,,1] ;FLUSH EVALER
1156 POPJ P, ;RETURN FROM BINDER
\f;TO BIND A PERFECTLY ORDINARY ARGUMENT SPECIFICATION
1157 ;FOUND IN A DECLS LIST, JUMP HERE
1159 BINDRG: MOVE 0,SWTCHS(P)
1160 PUSHJ P,BINDB ;GET ATOM IN THE NEXT DECL
1161 JUMPE D,CHOPT3 ;IF ARG EXISTS,
1163 SUB TP,[2,,2] ;PITCH ANY DEFAULT THAT MAY EXIST
1164 GETYP A,(D) ;(A,B) _ NEXT ARG
1167 HRRZ D,(D) ;CDR THE ARGS
1168 TRZN 0,QUO ;ARG QUOTED?
1169 JRST BNDRG1 ;NO-- GO EVAL
1170 CHDEFR: MOVEM 0,SWTCHS(P)
1171 CAME A,$TDEFER ;QUOTED-- PUNT ANY TDEFER'S YOU FIND
1173 GETYP A,(B) ;(A,B) _ REAL POINTER, NOT DEFERRED
1175 JRST DCLCDR ;AND FINISH BIND BLOCK
1179 CHOPT3: TRNN 0,OPT ;IF NO ARG, BETTER BE OPTIONAL
1181 POP TP,B ;(A,B) _ DEFAULT VALUE
1183 TRZE 0,QUO ;IF QUOTED,
1184 JRST CHDEFR ;JUST PUSH
1185 TRO 0,DEF ;ON DEFAULT
1187 ;EVALUATE WHATEVER YOU HAVE AT THIS POINT
1189 BNDRG1: PUSH TP,$TLIST ;SAVE STUFF
1197 PUSHJ P,@EVALER(P) ;(A,B) _ <EVAL (A,B)>
1198 MOVE E,(TP) ;RESTORE C, D, & E
1202 MOVE 0,SWTCHS(P) ;RESTORE 0
1205 ;FINISH THE BIND BLOCK WITH (A,B) AND GO ON
1207 DCLCDR: PUSHJ P,PSHBND
1208 TRNE 0,OPT ;IF OPTIONAL,
1209 PUSHJ P,EBINDS ;BIND IT
1211 JUMPE C,BINDC ;IF NO MORE DECLS, QUIT
1212 JRST DECLLP
\f;THIS ROUTINE CREATES THE BIND VECTOR BINDER USES; IT ALLOCATES
1213 ;THREE SLOTS PER NON-STRING DECLARATION (I.E., ATOM TO BE BOUND),
1214 ;THREE FOR A HEWITT ATOM IF IT FINDS ONE, AND ONE FOR THE ACCESS
1215 ;TYPE-TSP POINTER TO SP.
1217 ;IT SETS E TO THE CURRENT TOP OF THE VECTOR; IT FILLS IN
1218 ;ACCESS SLOT WITH SP, AND SETS SP TO POINT TO
1219 ;THE START OF THIS VECTOR. IT MAY SET SWITCH H TO ON, IFF IT FINDS
1220 ;A HEWITT ATOM. IT CLOBBERS A & B, RESTORES C & D, AND LEAVES THE
1223 ;IF BNDVEC FINDS NO DECLARATIONS, IT TAKES THE LIBERTY OF EXITING
1224 ;FROM THE BINDER WITHOUT DISTURBING SP. BNDVEC DOES SOME ERROR
1225 ;CHECKING, BUT NOT ALL, AS IT DOES NOT LOOK AT THE ARGS IN D.
1226 ;THIS EXPLAINS WHY BINDER OMITS SOME.
1228 BNDVEC: PUSH TP,$TLIST ;SAVE C & D
1233 MOVE 0,SWTCHS-2(P) ;UNBURY THE SWITCHES
1234 MOVEI D, ;D = COUNTER _ 0
1235 GETYP A,(C) ;A _ FIRST THING
1236 CAIE A,TATOM ;HEWITT ATOM?
1238 TRO 0,H ;TURN SWITCH H ON
1239 ADDI D,3 ;YES-- SAVE 3 SLOTS FOR IT
1240 HRRZ C,(C) ;CDR THE FUNCTION
1242 NOHATM: PUSHJ P,CARLST ;C _ <1 .C>
1243 JRST CNTRET ;IF (), ALL COUNTED
1244 MOVEI A,(C) ;A _ DECLS
1246 ;HERE IS THE QUICK LOOP THROUGH THE DECLARATIONS
1248 DCNTLP: PUSHJ P,NXTDCL ;SKIP IF NEXT ONE IS A STRING
1249 DINC: ADDI D,3 ;3 SLOTS FOR AN ATOM
1250 HRRZ A,(A) ;GO AROUND AGAIN
1253 ;IF ANYTHING WAS FOUND, INITIALIZE THE VECTOR
1255 CNTRET: JUMPE D,NODCLS ;OTHERWISE, BIND NOTHING
1256 AOJ D, ;DON'T FORGET ACCESS SLOT
1257 MOVEM 0,SWTCHS-2(P) ;SAVE SWITCHES
1260 MCALL 1,VECTOR ;B _ <VECTOR .D>
1261 MOVE D,(TP) ;RESTORE C & D
1264 MOVE E,B ;FROM NOW ON, E _ BIND VECTOR TOP
1267 MOVEM B,(E) ;FILL ACCESS SLOT
1269 MOVE SP,A ;SP NOW POINTS THROUGH THIS VECTOR
1272 ;IF THERE ARE NO DECLS (E.G. <FUNCTION ()...>), JUST QUIT
1274 NODCLS: MOVE D,(TP) ;RESTORE C & D
1277 SUB P,[2,,2] ;PITCH RETURN ADDRESS AND CALL
1278 JRST BNDRET
\f;THIS ROUTINE CREATES A POINTER TO THE TUPLE RESTING ON TOP OF
1279 ;TP. IT TAKES ITS NEGATIVE LENGTH (IN CELLS) IN (P). IT ASSUMES
1280 ;THERE ARE TWO TEMPORARY CELLS BENEATH IT, AND RESTORES
1281 ;THEM INTO C AND E, MOVING THE TUPLE OVER THE TEMPORARY
1282 ;SLOTS. IT RETURNS A CORRECT TARGS POINTER TO THE TUPLE IN A AND B
1284 MRKTUP: MOVSI A,TTB ;FENCE-POST TUPLE
1287 MOVEI A,2 ;B_ADDRESS OF INFO CELL
1288 PUSHJ P,CELL" ;MAY CALL AGC
1291 MOVEI A,(TP) ;GENERATE DOPE WORD POINTER
1294 CAME A,TPGROW" ;ALLOWING FOR BLOWN PDL
1296 HRLZI A,-1(A) ;A HAS 1ST DW PTR IN LEFT HALF
1297 HLR A,OTBSAV(TB) ;TIME TO RIGHT
1298 MOVEM A,1(B) ;TO SECOND WORD OF CELL
1299 EXCH B,-1(P) ;B _ - ARG COUNT
1301 HRRM B,-1(TP) ;STORE IN TTB FENCEPOST
1303 ADD A,B ;A _ ADR OF TUPLE
1304 HRLI A,(B) ;A _ TUPLE POINTER
1306 HRLI A,4(A) ;LH A _ CURRENT PLACE OF TUPLE
1307 MOVE C,1(A) ;RESTORE C AND E
1309 BLT A,-4(TP) ;MOVE TUPLE OVER OLD C, E COPIES
1312 HRLI A,TARGS ;A _ FIRST WORD OF ARGS TUPLE VALUE
1313 POPJ P,
\f;THIS ROUTINE, GIVEN SWTCHS IN 0 AND DECLARATIONS LIST POINTER
1314 ;IN C, PUSHES ATOM IN THE FIRST DECLARATION ONTO E. IT MAY SET
1315 ;SWITCHES OPT AND QUO, AND LEAVES SWITCHES IN 0. IFF OPT = ON,
1316 ;BINDB PUSHES A DEFAULT VALUE (EVEN IF ?()) ONTO TP. A & B ARE
1317 ;CLOBBERED. C IS NOT ALTERED.
1319 BINDB: MOVE A,C ;A _ C
1321 CAIE B,TLIST ;A = ((...)...) ?
1323 TRNN 0,OPT ;YES-- OPT MUST BE ON
1325 MOVEM 0,SWTCHS-1(P) ;SAVE SWITCHES
1326 MOVE A,1(A) ;A _ <1 .A> = (...)
1327 JUMPE A,MPD ;A = () NOT ALLOWED
1328 HRRZ B,(A) ;B _ <REST .A>
1329 JUMPE B,MPD ;B = () NOT ALLOWED
1330 PUSH TP,(B) ;SAVE <1 .B> AS DEFAULT
1331 PUSH TP,1(B) ;VALUE OF ATOM IN A
1333 JUMPN B,MPD ;<REST .B> MUST = ()
1335 JRST CHFORM ;GO SEE WHAT <1 .A> IS
1337 CHOPT1: TRNN 0,OPT ;IF OPT = ON
1339 PUSH TP,$TUNAS ;DEFAULT VALUE IS ?()
1342 ;AT THIS POINT, <1 .A> MUST BE ATOM OR <QUOTE ATOM>
1344 CHFORM: TRNE 0,AUX ;NO QUOTES ALLOWED IN AUXIES
1348 MOVE A,1(A) ;A _ <1 .A> = <...>
1349 JUMPE A,MPD ;A = <> NOT ALLOWED
1350 MOVE B,1(A) ;B _ <1 .A>
1352 JRST MPD ;ONLY A = <QUOTE...> ALLOWED
1355 HRRZ A,(A) ;A _ <REST .A>
1356 JUMPE A,MPD ;<QUOTE> NOT ALLOWED
1359 ;AT THIS POINT WE HAVE THE ATOM OR AN ERROR
1361 CHATOM: CAIE B,TATOM ;<1 .A> MUST BE ATOM
1363 MOVE A,1(A) ;A _ THE ATOM!!!
1364 JRST PSHATM ;WHICH MUST BE PUSHED ONTO E
1368 ;THE FOLLOWING LITTLE ROUTINE ACCEPTS THE NEXT DECLARATION ONLY
1369 ;IF IT IS ATOMIC, AND PUSHES IT ONTO E
1374 MOVE A,1(C) ;A _ ATOM
1376 PSHATM: PUSH E,$TBIND ;FILL FIRST TWO SLOTS OF BIND BLOCK
1379 ;EACH BIND BLOCK MUST POINT TO THE PREVIOUS ONE OR TO AN ACCESS
1380 ;POINTER TO ANOTHER VECTOR ALTOGETHER. COMBLK MAKES SURE IT DOES.
1382 COMBLK: GETYP B,-7(E) ;LOOK FOR PREVIOUS BIND
1383 CAIE B,TBIND ;IF FOUND, MAKE NORMAL LINK
1385 MOVEI B,-7(E) ;IN MOST CASES, SEVEN
1386 MAKLNK: HRRM B,-1(E) ;MAKE THE LINK
1388 ABNORM: MOVEI B,-3(E)
1390 \f;THIS ROUTINE COMPLETES A BIND BLOCK BEGUN BY CARATE OR BINDB
1391 ;WITH THE VALUE (A,B)
1395 ADD E,[2,,2] ;ASSUME BIND VECTOR IS FULL OF 0'S
1398 ;THIS ONE DOES AN EBIND, SAVING C & D:
1400 EBINDS: PUSH P,C ;SAVE C & D (NO DANGER OF GC)
1402 PUSHJ P,EBIND ;BIND ALL NON-OPTIONAL ARGUMENTS
1404 POP P,C ;RESTORE C & D
1408 ;THE FOLLOWING RETURNS THE CAR OF C IN C, SKIPPING IF
1409 ;<EMPTY? <1 .C>>, AND ERRING IF <NOT <==? <TYPE <1 .C>> LIST>>
1413 JRST MPD ;NOT A LIST, FATAL
1419 ;...AND THERE ARE A FEW PEOPLE STILL CALLING THE FOLLOWING:
1421 MAKENV: PUSH P,C ;SAVE AN AC
1422 HLRE C,PVP ;GET -LNTH OF PROC VECTOR
1423 MOVEI A,(PVP) ;COPY PVP
1424 SUBI A,-1(C) ;POINT TO DOPWD WITH A
1425 HRLI A,TFRAME ;MAKE INTO A FRAME
1426 HLL B,OTBSAV(B) ;TIME TO B
1432 \f;THESE ROUTINES ARE CALLED TO EVALUATE THE VALUE PUSHED
1433 ;ON TP ****THEY ARE ASSUMED TO CLOBBER EVERYTHING****
1442 ;WHEN APPLY-ING, ARGS ARE ALREADY EVALUATED
1444 ARGNEV: JSP E,CHKARG ;PITCH ANY TDEFERS
1445 TRNN 0,DEF ;DEFAULT VALUES...
1447 MCALL 1,EVAL ;...ARE ALWAYS EVALUATED
1449 NOEV: POP TP,B ;OTHERWISE,
1450 POP TP,A ;JUST RESTORE A&B
1453 ;SPECBIND BINDS IDENTIFIERS. IT IS CALLED BY PUSHJ P,SPECBIND.
1454 ;SPECBIND IS PROVIDED WITH A CONTIGUOUS SET OF TRIPLETS ON TP.
1455 ;EACH TRIPLET IS AS FOLLOWS:
1456 ;THE FIRST ELEMENT IS THE IDENTIFIER TO BE BOUND, ITS TYPE WORD IS [TATOM,,-1],
1457 ;THE SECOND IS THE VALUE TO WHICH IT IS TO BE ASSIGNED,
1458 ;AND THE THIRD IS A PAIR OF ZEROES.
1462 SPECBIND: MOVE E,TP ;GET THE POINTER TO TOP
1463 ADD E,[1,,1] ;BUMP POINTER ONCE
1466 MOVEI B, ;ZERO COUNTER
1468 SZLOOP: MOVE A,-6(D) ;COUNT ATOM BLOCKS AS 3
1474 GETVEC: JUMPE B,DEGEN
1481 MCALL 1,VECTOR ;<VECTOR .B>
1482 POP TP,D ;RESTORE D = POINTER TO BOTTOM TRIPLE
1484 MOVE A,$TSP ;MAKE THIS BLOCK POINT TO PREVIOUS
1489 ;MOVE TRIPLES TO VECTOR
1491 POP P,E ;E _ LENGTH - 1
1493 ADDI E,(B) ;E _ POINTER TO VECTOR DOPE WORD
1496 BLT A,-1(E) ;MOVE BIND TRIPLES TO VECTOR
1498 ;CHANGE ALL [TATOM,,-1]'S TO [TBIND,,LINK TO PREVIOUS BLOCK]
1500 HRRZI B,(B) ;ZERO LEFT HALF OF B
1502 HRRI C,-2(B) ;C = LINK _ ADR OF FIRST OF VECTOR
1503 FIXLP: MOVEM C,(B) ;STORE LINK TO PREVIOUS BLOCK IN BLOCK B
1504 HRRI C,(B) ;C _ LINK TO THIS BLOCK
1506 CAIE B,(E) ;GOT TO DOPE WORD?
1513 CAMLE C,TP ;ANYTHING ABOVE TRIPLES?
1515 SUBI TP,(C) ;TP _ NUMBER THERE
1516 HRLS TP ;IN BOTH HALVES
1519 BLT D,(TP) ;BLLLLLLLLT!
1521 DEGEN: SUB TP,[2,,2]
1523 NOBLT2: MOVE TP,D ;OR JUST RESTORE IT
1526 ;HERE TO BIND EVERYTHING IN VECTOR WITH DOPE WORD (E)
1528 SPCBE2: SUB E,[1,,1] ;E _ LAST WORD OF LAST BLOCK
1530 ;EBIND BINDS THE ATOMS SPECIFIED BY THE BLOCK WHOSE LAST WORD
1531 ;E POINTS TO, THEN THE BLOCK LINKED TO IT, ETC., UNTIL
1532 ;IT FINDS ONE ALREADY BOUND, WHEN IT RESTORES E AND EXITS.
1533 ;IT RESETS SP TO POINT TO THE FIRST ONE BOUND. IT CLOBBERS
1534 ;ALL OTHER REGISTERS
1537 SKIPE A ;ALREADY BOUND?
1538 POPJ P, ;YES-- EBIND IS A NO-OP
1539 MOVEI D, ;D WILL BE THE NEW SP
1543 BINDLP: HLRZ A,-1(E)
1544 SKIPE A ;HAS THIS BLOCK BEEN BOUND ALREADY?
1545 JRST SPECBD ;YES, RESTORE AND QUIT
1546 DOBIND: SUB E,[6,,6]
1547 SKIPN D ;HAS NEW SP ALREADY BEEN SET?
1548 MOVE D,E ;NO, SET TO THIS BLOCK FOR NOW
1551 PUSHJ P,ILOC ;(A,B) _ LOCATIVE OF (A,B)
1553 MOVEM A,5(E) ;CLOBBER IT AWAY
1554 MOVEM B,6(E) ;IN RESTORE CELLS
1556 HRRZ A,PROCID+1(PVP) ;GET PROCESS NUMBER
1557 HRLI A,TLOCI ;MAKE LOC PTR
1558 MOVE B,E ;TO NEW VALUE
1560 MOVE C,2(E) ;GET ATOM PTR
1561 MOVEM A,(C) ;CLOBBER ITS VALUE
1565 SPECBD: MOVE SP,D ;SP _ D
1566 ADD SP,[1,,1] ;FIX SP
1567 POP P,E ;RESTORE E TO TOP OF BIND VECTOR
1572 ;SPECSTORE RESTORES THE BINDINGS SP TO THE ENVIRONMENT POINTER IN
1573 ;SPSAV (TB). IT IS CALLED BY PUSHJ P,SPECSTORE.
1576 HRRZ E,SPSAV (TB) ;GET TARGET POINTER
1579 CAIN E,(SP) ;ARE WE DONE?
1581 HLRZ C,(SP) ;GET TYPE OF BIND
1582 CAIE C,TBIND ;NORMAL IDENTIFIER?
1583 JRST JBVEC ;NO-- FIND & FOLLOW REBIND POINTER
1586 MOVE C,1(SP) ;GET TOP ATOM
1587 MOVE D,4(SP) ;GET STORED LOCATIVE
1588 \r HRR D,PROCID+1(PVP) ;STORE SIGNATURE
1589 MOVEM D,(C) ;CLOBBER INTO ATOM
1592 HRRZS 4(SP) ;NOW LOOKS LIKE A VIRGIN BLOCK
1594 HRRZ SP,(SP) ;GET NEXT BLOCK
1597 ;IN JUMPING TO A NEW BIND VECTOR, FOLLOW
1598 ;REBIND POINTER IF IT DIFFERS FROM ACCESS POINTER
1600 JBVEC: CAIE C,TSP ;THIS JUST BETTER BE TRUE, THAT'S ALL
1601 .VALUE [ASCIZ /BADSP/]
1602 GETYP D,2(SP) ;REBIND POINTER?
1604 JRST XCHVEC ;NO-- USE ACCESS
1605 MOVE D,5(SP) ;YES-- RESTORE PROCID
1606 EXCH D,PROCID+1(PVP)
1607 MOVEM D,5(SP) ;SAVING CURRENT ONE FOR LATER FAILURES
1610 ;IF WE JUST RAN OFF THE END OF THE ENVIRONMENT CHAIN, BARF
1612 XCHVEC: SKIPE SP,1(SP)
1614 JUMPE E,STPOPJ ;UNLESS THAT'S AS FAR AS WE WANTED TO GO
1615 .VALUE [ASCIZ /SPOVERPOP/]
1624 MFUNCTION REP,FSUBR,[REPEAT]
1626 MFUNCTION PROG,FSUBR
1628 GETYP A,(AB) ;GET ARG TYPE
1629 CAIE A,TLIST ;IS IT A LIST?
1630 JRST WTYP ;WRONG TYPE
1631 SKIPN C,1(AB) ;GET AND CHECK ARGUMENT
1632 JRST ERRTFA ;TOO FEW ARGS
1633 PUSH TP,$TLIST ;PUSH GOODIE
1635 BIPROG: PUSH TP,$TLIST
1636 PUSH TP,C ;SLOT FOR WHOLE BODY
1637 PUSHJ P,PROGAT ;BIND FUNNY PROG MARKER
1638 MOVE C,3(TB) ;PROG BODY
1639 MOVNI D,1 ;TELL BINDER WE ARE APROG
1641 HRRZ C,3(TB) ;RESTORE PROG
1642 TRNE A,H ;SKIP IF NO NAME ALA HEWITT
1645 MOVEM C,3(TB) ;SAVE FOR AGAIN, ETC.
1646 STPROG: HRRZ C,(C) ;SKIP DCLS
1649 ; HERE TO RUN PROGS FUNCTIONS ETC.
1652 HRRZM C,1(TB) ;CLOBBER AWAY BODY
1653 PUSH TP,(C) ;EVALUATE THE
1655 PUSH TP,1(C) ;STATEMENT
1658 HRRZ C,@1(TB) ;GET THE REST OF THE BODY
1659 JUMPN C,DOPROG ;IF MORE -- DO IT
1663 CAME C,MQUOTE REP,REPEAT
1665 SKIPN C,3(TB) ;CHECK IT
1670 ;HERE TO BIND PROG ATOM (AND ANYTHING ELSE ON STACK)
1672 PROGAT: PUSH TP,BNDA
1673 PUSH TP,MQUOTE [LPROG ],INTRUP
1675 PUSHJ P,MAKENV ;B _ POINTER TO CURRENT FRAME
1682 MFUNCTION RETURN,SUBR
1684 PUSHJ P,PROGCH ;CKECK IN A PROG
1685 PUSHJ P,SAVE ;RESTORE PROG'S FRAME, BCKTRKING IF NECESSARY
1691 MFUNCTION AGAIN,SUBR
1693 HLRZ A,AB ;GET # OF ARGS
1696 JUMPN A,WNA ;0 ARGS?
1697 PUSHJ P,PROGCH ;CHECK FOR IN A PROG
1712 AGAD: PUSHJ P,SAVE ;RESTORE FRAME TO REPEAT
1719 PUSHJ P,PROGCH ;CHECK FOR A PROG
1729 MCALL 2,MEMQ ;DOES IT HAVE THIS TAG?
1730 JUMPE B,NXTAG ;NO -- ERROR
1731 FNDGO: EXCH B,(TP) ;SAVE PLACE TO GO
1736 NLCLGO: CAME A,$TTAG ;CHECK TYPE
1738 MOVE A,1(AB) ;GET ARG
1743 CAME B,3(A) ;CHECK TIME
1748 PUSH TP,(A) ;SAVE BODY
1750 GODON: PUSHJ P,SAVE ;GO BACK TO CORRECT FRAME
1751 MOVE B,(TP) ;RESTORE ITERATION MARKER
1762 HLRZ A,(AB) ;GET TYPE OF ARGUMENT
1763 CAIE A,TATOM ;CHECK THAT IT IS AN ATOM
1765 PUSHJ P,PROGCH ;CHECK PROG
1773 JUMPE B,NXTAG ;IF NOT FOUND -- ERROR
1774 EXCH A,-1(TP) ;SAVE PLACE
1776 PUSH TP,A ;UNDER PROG FRAME
1782 PROGCH: MOVE B,MQUOTE [LPROG ],INTRUP
1783 PUSHJ P,ILVAL ;GET VALUE
1787 MOVE C,B ;CHECK TIME
1801 PUSHJ P,TILLFM ;TEST FRAME
1802 PUSHJ P,SAVE ;RESTORE FRAME
1805 ;IF GIVEN, RETURN SECOND ARGUMENT
1807 RETRG2: MOVE A,2(AB)
1809 MOVE AB,ABSAV(TB) ;IN CASE OF GC
1812 MFUNCTION COND,FSUBR
1818 PUSH TP,1(AB) ;CREATE UNNAMED TEMP
1819 CLSLUP: SKIPN B,1(TB) ;IS THE CLAUSELIST NIL?
1820 JRST IFALSE ;YES -- RETURN NIL
1821 HLRZ A,(B) ;NO -- GET TYPE OF CAR
1822 CAIE A,TLIST ;IS IT A LIST?
1824 MOVE A,1(B) ;YES -- GET CLAUSE
1826 PUSH TP,(A) ;EVALUATION OF
1828 PUSH TP,1(A) ;THE PREDICATE
1831 CAMN A,$TFALSE ;IF THE RESULT IS
1832 JRST NXTCLS ;FALSE TRY NEXT CLAUSE
1833 MOVE C,1(TB) ;IF NOT, DO FIRST CLAUSE
1836 JUMPE C,FINIS ;(UNLESS DONE WITH IT)
1837 JRST DOPROG ;AS THOUGH IT WERE A PROG
1838 NXTCLS: HRRZ A,@1(TB) ;SET THE CLAUSLIST
1839 HRRZM A,1(TB) ;TO CDR OF THE CLAUSLIST
1843 MOVSI A,TFALSE ;RETURN FALSE
1850 ;RESTORE TB TO STACK FRAME POINTED TO BY B, SAVING INTERMEDIATE FRAMES ON THE PLANNER PDL
1851 ;IF NECESSARY; CLOBBERS EVERYTHING BUT B
1852 SAVE: SKIPN C,OTBSAV(B) ;PREVIOUS FRAME?
1854 CAMN PP,PPSAV(C) ;ANYTHING HAPPEN TO PP BETWEEN B AND HERE?
1855 JRST QWKRET ;NO-- JUST RETURN
1861 HRRZ C,OTBSAV(TB) ;ANYTHING TO SAVE YET?
1863 PUSHJ P,BCKTRK ;DO IT
1864 HRR TB,OTBSAV(TB) ;AND POP UP
1866 QWKRET: HRR TB,B ;SKIP OVER EVERYTHING
1868 SVRET: SUB TP,[2,,2] ;POP CRAP OFF TP
1871 ;SETG IS USED TO SET THE GLOBAL VALUE OF ITS FIRST ARGUMENT,
1872 ;AN IDENTIFIER, TO THE VALUE OF ITS SECOND ARGUMENT. ITS VALUE IS
1873 ; ITS SECOND ARGUMENT.
1877 HLLZ A,(AB) ;GET TYPE OF FIRST ARGUMENT
1878 CAME A,$TATOM ;CHECK THAT IT IS AN ATOM
1879 JRST NONATM ;IF NOT -- ERROR
1880 MOVE B,1(AB) ;GET POINTER TO ATOM
1881 PUSHJ P,IGLOC ;GET LOCATIVE TO VALUE
1882 CAMN A,$TUNBOUND ;IF BOUND
1883 PUSHJ P,BSETG ;IF NOT -- BIND IT
1885 MOVE A,2(AB) ;GET SECOND ARGUMENT
1886 MOVE B,3(AB) ;INTO THE RETURN POSITION
1887 MOVEM A,(C) ;DEPOSIT INTO THE
1888 MOVEM B,1(C) ;INDICATED VALUE CELL
1891 BSETG: HRRZ A,GLOBASE+1(TVP)
1892 HRRZ B,GLOBSP+1(TVP)
1896 PUSH TP,GLOBASE(TVP)
1897 PUSH TP,GLOBASE+1 (TVP)
1903 MOVEM A,GLOBASE(TVP)
1904 MOVEM B,GLOBASE+1(TVP)
1906 MOVE B,GLOBSP+1(TVP)
1912 MOVEM B,GLOBSP+1(TVP)
1920 ;SET CLOBBERS THE LOCAL VALUE OF THE IDENTIFIER GIVEN BY ITS
1921 ;FIRST ARGUMENT TO THE SECOND ARG. ITS VALUE IS ITS SECOND ARGUMENT.
1925 HLLZ A,(AB) ;GET TYPE OF FIRST
1926 CAME A,$TATOM ;ARGUMENT --
1927 JRST WTYP ;BETTER BE AN ATOM
1928 MOVE B,1(AB) ;GET PTR TO IT
1929 PUSHJ P,ILOC ;GET LOCATIVE TO VALUE
1930 CAMN A,$TUNBOUND ;BOUND?
1931 PUSHJ P, BSET ;BIND IT
1933 MOVE A,2(AB) ;GET SECOND ARG
1934 MOVE B,3(AB) ;INTO RETURN VALUE
1935 MOVEM A,(C) ;CLOBBER IDENTIFIER
1940 MCALL 1,VECTOR ;GET NEW BIND VECTOR
1942 MOVEM A,(B) ;MARK IT
1946 MOVEM A,2(B) ;CHAIN FIRST BLOCK
1947 MOVE A,1(AB) ;A _ ATOM
1949 MOVE C,SPBASE+1(PVP) ;CHAIN TO PREVIOUS BIND VECTOR
1950 MOVEM B,SPBASE+1(PVP) ;SET NEW TOP
1953 ADD B,[2,,2] ;POINT TO LOCATIVE
1955 HRR A,PROCID+1(PVP) ;WHICH MAKE
1956 MOVE C,1(AB) ;C _ ATOM _ VALUE CELL ADDRESS
1958 MOVEM B,1(C) ;CLOBBER LOCATIVE SLOT
1964 HLRZ A,(AB) ; GET TYPE
1965 CAIE A,TFALSE ;IS IT FALSE?
1966 JRST IFALSE ;NO -- RETURN FALSE
1969 MOVSI A,TATOM ;RETURN T (VERITAS)
1973 MFUNCTION ANDA,FSUBR,AND
1977 JRST WTYP ;IF ARG DOESN'T CHECK OUT
1978 SKIPN C,1(AB) ;IF NIL
1979 JRST TRUTH ;RETURN TRUTH
1980 PUSH TP,$TLIST ;CREATE UNNAMED TEMP
1983 JUMPE C,FINIS ;ANY MORE ARGS?
1984 MOVEM C,1(TB) ;STORE CRUFT
1985 PUSH TP,(C) ;EVALUATE THE
1986 HLLZS (TP) ;FIRST REMAINING
1987 PUSH TP,1(C) ;ARGUMENT
1991 JRST FINIS ;IF FALSE -- RETURN
1992 HRRZ C,@1(TB) ;GET CDR OF ARGLIST
1998 CAIE A,TLIST ;CHECK OUT ARGUMENT
2000 MOVE C,1(AB) ;PICK IT UP TO ENTER LOOP
2001 PUSH TP,$TLIST ;CREATE UNNAMED TEMP
2004 JUMPE C,IFALSE ;IF NO MORE OPTIONS -- FALSE
2005 MOVEM C,1(TB) ;CLOBBER IT AWAY
2008 PUSH TP,1(C) ;EVALUATE THE FIRST REMAINING
2010 MCALL 1,EVAL ;ARGUMENT
2011 CAME A,$TFALSE ;IF NON-FALSE RETURN
2013 HRRZ C,@1(TB) ;IF FALSE -- TRY AGAIN
2016 MFUNCTION FUNCTION,FSUBR
2020 PUSH TP,MQUOTE FUNCTION
2026 MFUNCTION CLOSURE,SUBR
2028 SKIPL A,AB ;ANY ARGS
2029 JRST ERRTFA ;NO -- LOSE
2030 ADD A,[2,,2] ;POINT AT IDS
2033 PUSH P,[0] ;MAKE COUNTER
2035 CLOLP: SKIPL A,1(TB) ;ANY MORE IDS?
2036 JRST CLODON ;NO -- LOSE
2037 PUSH TP,(A) ;SAVE ID
2039 PUSH TP,(A) ;GET ITS VALUE
2041 ADD A,[2,,2] ;BUMP POINTER
2047 MCALL 2,LIST ;MAKE PAIR
2053 ACALL A,LIST ;MAKE UP LIST
2054 PUSH TP,(AB) ;GET FUNCTION
2058 MCALL 2,LIST ;MAKE LIST
2063 MFUNCTION FALSE,SUBR
2072 \f;BCKTRK SAVES THINGS ON PP
2074 ;IT AND ITS FRIENDS FLAG PP "FRAMES" WITH MARKERS OF FORM "TTP,,SWITCHES", WHERE SWITCHES INCLUDES
2076 COP==1 ;ON IFF CALL TO BCKTRK IS TO COPY FRAME (TB) AS WELL
2078 SAV==2 ;ON IFF TUPLES OF (TB) ARE TO BE SAVED; COP IMPLIES
2080 TUP==4 ;ON IFF (TB) CONTAINS ANY TUPLES BESIDES ARGS
2081 ON==10 ;ON IFF THIS FRAME OR FAILPOINT "RESTS ON TOP OF"
2082 ;FRAME DESIGNATED BY TTP POINTER, OR IS INTENDED TO
2085 ;BELOW THE TTP POINTER IS ONE OR TWO BLOCKS FLAGGED BY A TFIX
2086 ;VALUE. IF ON=ON AND TUP=ON IN THE RIGHT HALF OF THE TFIX,
2087 ;THE TFIX BEGINS A BLOCK OF TUPLE DEBRIS; OTHERWISE,
2088 ;IT BEGINS A SAVED TP FRAME.
2091 BCKTRK: HRRZ A,-1(PP) ;SLOT LEFT BY FAILPOINT?
2092 TRNN A,COP ;(I.E., TO BE COPIED?)
2094 MOVE E,TB ;YES-- FIRST SAVE THIS FRAME
2101 ;SAVE TUPLES OF FRAME ON TOP OF PP
2103 NBCK1: MOVSI B,TTP ;FAKE OUT GC
2108 MOVE B,(PP) ;B _ TPIFIED TB POINTER
2109 SUB PP,[2,,2] ;CLEAN OFF POINTER TO MAKE ROOM FOR ARGS
2111 MOVE C,PP ;C _ E _ PP
2112 SUB C,(PP) ;C _ ADDRESS OF SAVED OTB
2113 HLRE D,1(C) ;D _ NO. OF ARGS
2115 SUB B,[FRAMLN,,FRAMLN] ;B _ FIRST OF SAVE BLOCK
2118 SUB B,D ;B _ FIRST OF ARGS
2120 PUSH PP,(B) ;MOVE NEXT
2125 ADD B,[FRAMLN,,FRAMLN] ;B _ TB ADDRESS
2127 NOARGS: TRNN A,TUP ;ANY OTHER TUPLES?
2129 MVTUPS: ADD C,[FRAMLN-1,,FRAMLN-1] ;C _ PP TB SLOT
2130 SUB E,[1,,1] ;E _ TFIX SLOT ADDRESS
2131 MTOLP: CAML C,E ;C REACHED E?
2132 JRST MTDON ;YES-- ALL TUPLES FOUND
2135 CAIE A,TTBS ;LOOK FOR TUPLE
2137 HRRE D,(C) ;D _ NO. OF ELEMENTS
2138 MTILP: JUMPGE D,ARND22
2145 ARND22: ADD B,[2,,2] ;ADVANCE IN STEP
2150 SUBI C,1(E) ;C _ NO. OF THINGS MOVED
2152 PUSH PP,[TFIX,,TUP] ;MARK AS TUPLE CRUFT
2155 RMARK: MOVE E,OTBSAV(TB) ;SAVE PREVIOUS FRAME
2164 MOVSI B,TFIX ;RESTORE B TYPE
2167 ;BCKTRE SAVE CONTENTS OF FRAME E OF TP ON PLANNER PDL
2169 BCKTRE: MOVSI A,TPDL ;FOR AGC
2176 ;MOVE P BLOCK OF PREVIOUS FRAME TO PP
2178 MOVE C,PSAV(E) ;C _ LAST OF P "FRAME"
2180 MOVE A,PSAV(A) ;A _ LAST OF PREVIOUS P "FRAME"
2182 MVPB: CAMLE A,C ;IF BLOCK EMPTY,
2183 JRST MVTPB ;DO NOTHING
2185 SUBI D,-1(A) ;ELSE, SET COUNTER
2186 PUSH PP,$TPDLS ;MARK BLOCK
2196 PUSH PP,[0] ;PUSH BLOCK COUNTER
2198 ;NOW DO SIMILAR THING FOR TP
2199 MVTPB: MOVSI A,TTP ;FOR AGC
2201 MOVE C,TPSAV(E) ;C POINT TO LAST OF BLOCK
2202 PUSH TP,$TPP ;SAVE INITIAL PP
2203 PUSH TP,PP ;FOR SUBTRACTION
2204 HRRZ A,E ;A _ TPIFIED E
2212 .VALUE [ASCIZ /TPFUCKED/]
2213 ;MOVE THE SAVE BLOCK
2215 MSVBLK: MOVSI D,TENTS ;MAKE TYPE TENTS
2218 HLLZ D,OTBSAV(E) ;RELATIVIZE OTB AND AB POINTERS
2227 MOVEI 0, ;0 _ 0 (NO TUPLES)
2234 PUSH PP,(A) ;NO, JUST MOVE IT
2238 MRKFIX: HRRZ C,(TP) ;C _ PREVIOUS PP POINTER
2240 HRRZ D,PP ;D _ CURRENT PP TOP
2241 SUBI D,(C) ;D _ DIFFERENCE
2243 PUSH PP,$TFIX ;PUSH BLOCK COUNTER
2247 ;NOW SAVE LOCATION OF THIS FRAME
2254 ADD E,B ;CONVERSION TO TTP
2256 TRO 0,SAV ;PUSH A TTP MARKER WITH SAV & MAYBE TUP ON
2268 ;RELATIVIZE A TB POINTER
2270 MVTB: HRRE D,(A) ;D _ - LENGTH OF TUPLE
2272 HRLS D ;D _ LENGTH,,LENGTH
2273 SUB PP,D ;THROW TUPLE AWAY!!!
2282 \fMFUNCTION FAIL,SUBR
2284 ;SINCE FAILURES ARE NOT INTERRUPTIBLE FOR ANYTHING BUT GARBAGE
2285 ;COLLECTIONS, THE FOLLOWING MACRO REPLACES INTGO FOR STACK-BUILDING
2297 CAILE A,4 ;AT MOST 2 ARGS
2299 CAIGE A,2 ;IF FIRST ARG NOT GIVEN,
2300 JRST MFALS ;ASSUME <>
2301 MOVE B,(AB) ;OTHERWISE, FIRST ARG IS MESSAGE
2306 CAIE A,4 ;PLACE TO FAIL TO GIVEN?
2309 CAIE A,TACT ;CAN ONLY FAIL TO AN ACTIVATION
2311 SAVACT: MOVE B,2(AB) ;TRANSMIT ACTIVATION TO FAILPOINT
2312 MOVEM B,FACTI(PVP) ;VIA PVP
2314 MOVEM B,FACTI+1(PVP)
2315 ;NOW REBUILD TP FROM PP
2316 IFAIL: SETOM FLFLG ;FLFLG _ ON
2317 HRRZ A,(PP) ;GET FRAME TO NESTLE IN
2319 HRRZ 0,-1(PP) ;0 _ SWITCHES FOR FRAME
2322 GETYP B,FACTI(PVP) ;IF FALSE ACTIVATION,
2323 CAIN B,TFALSE ;JUST GO TO FRAME
2325 HRRZI B,(TB) ;OTHERWISE, CHECK TO SEE IF WE ARE LEAVING
2327 ALOOP: CAIN B,(A) ; FRAME FACTI(PVP)
2328 JRST POPFS ;NO-- IT'S ABOVE FAILPOINT (A)
2329 CAIN B,(D) ;FOUND FACTI?
2330 JRST AFALS2 ;YES-- CLOBBER FACTI TO #FALSE()
2331 HRRZ B,OTBSAV(B) ;NO-- KEEP LOOKING
2333 AFALS2: MOVSI B,TFALSE ;SET IT TO FALSE FROM HERE ON
2335 SETZB D,FACTI+1(PVP)
2336 POPFS: HRR TB,A ;MAY TAKE MORE WORK
2337 RSTFRM: MOVE P,PSAV(TB)
2346 ;MOVE A TP BLOCK FROM PP TO TP
2351 SUB A,(PP) ;A POINTS TO BOTTOM OF BLOCK
2352 TRNN 0,ON ;"ON" BLOCK?
2354 ONBLK: CAME SP,SPSAV(TB) ;YES-- FIX UP ENVIRONMENT
2357 HRRZ 0,-1(PP) ;ANY TUPLES?
2359 JRST USVBLK ;NO-- GO MOVE SAVE BLOCK
2360 SUB A,[2,,2] ;A _ BLOCK UNDER THIS ONE
2364 CAIE B,TENTS ;LOOK IN SAVE BLOCK
2366 HLRE D,FRAMLN+ABSAV-1(A)
2369 ;MOVE SAVE BLOCK BACK TO TP
2371 USVBLK: ADD A,[FRAMLN,,FRAMLN]
2375 MOVEI AB,(TP) ;REGENERATE AB & OTBSAV
2391 PSHLP4: CAML TP,TPSAV(TB)
2395 CAIN B,TTBS ;FOUND A TUPLE?
2397 PUSH TP,-1(A) ;NO-- JUST MOVE IT
2399 ARND12: ADD A,[2,,2] ;BUMP POINTER
2403 MOVE D,-1(A) ;UNRELATIVIZE A TTB
2410 USTPDN: MOVE 0,-1(PP) ;IF TUPLES,
2413 SUB PP,(PP) ;SKIP OVER TUPLE DEBRIS
2415 USTPD3: CAME TP,TPSAV(TB) ;BETTER HAVE WORKED
2417 CAMN SP,SPSAV(TB) ;PLEASE GOD, NO MORE BINDINGS
2418 JRST USV2 ;PRAYER CAN MOVE MOUNTAINS
2419 MOVEI E, ;E _ 0 = INITIAL LOWER BIND BLOCK
2420 MOVE C,SPSAV(TB) ;C _ SPSAV = INITIAL UPPER BLOCK
2422 ;REBIND EVERYTHING IN THIS FRAME-- FIRST, FIND THE TOPMOST BLOCK,
2423 ;SINCE THEY MUST BE REBOUND IN THE ORDER BOUND
2426 CAIE D,TBIND ;C POINTS TO BIND BLOCK?
2428 ADD C,[5,,5] ;YES-- C _ ADDRESS OF ITS LAST WORD
2429 MOVEM E,(C) ;(C) _ E = LOWER BIND POINTER
2432 SUB C,D ;C _ ADDRESS OF DOPE WORD
2435 SUBM C,D ;D _ FIRST WORD ADDRESS
2436 MOVE C,1(D) ;C _ REBIND BLOCK
2438 SPLBLK: GETYP D,2(C)
2441 ADD C,[1,,1] ;C _ REBIND POINTER ADDRESS
2442 MOVE D,(C) ;D _ HIGHER BLOCK
2443 MOVEM E,(C) ;(C) _ E
2445 MOVE C,D ;C _ D = HIGHER BIND BLOCK
2446 JBVEC3: CAME SP,C ;GOT TO SP YET?
2450 ;NOW REBIND EVERYTHING, RESET PROCID'S PROPERLY, ETC.;
2451 ;THIS MUST BE DONE IN PROPER ORDER, FROM TOPMOST BLOCK DOWN
2453 BLOOP2: HLRZ D,-1(E) ;WHAT DOES E POINT TO?
2455 JUMPN D,TUGSP ;IF NON-ZERO, MUST BE REBIND SLOT
2456 PUSHJ P,EBIND ;OTHERWISE, BIND BLOCK TO BE REBOUND
2458 TUGSP: MOVEM SP,(E) ;RECONNECT UPPER BLOCK
2463 SUB SP,[1,,1] ;TUG SP DOWN
2464 CAIE 0,TSP ;ID SWAP?
2466 MOVE 0,PROCID+1(PVP)
2468 MOVEM 0,PROCID+1(PVP)
2469 DOWNBL: POP P,E ;E _ LOWER BLOCK
2472 RBDON: CAME SP,SPSAV(TB) ;ALL THAT BETTER HAVE WORKED
2476 ;RESTORE A BLOCK "INTO" TB
2478 INBLK: ADD A,[FRAMLN,,FRAMLN]
2483 BLT C,-1(TB) ;RESTORE ALL OF SAVE BLOCK BUT FSAV,
2484 MOVEI C,-1(TB) ; OTBSAV, AND ABSAV
2490 ADD C,D ;C _ "-1(TB)"TPIFIED
2493 GETYP B,-1(A) ;GOT TUPLE?
2495 JRST SKTUPL ;YES-- SKIP IT
2499 MOVE TP,C ;PROTECT STACK FROM GARBAGE COLLECTION
2503 SKTUPL: HRRE D,-1(A) ;D _ - LENGTH OF TUPLE
2507 ADD C,[2,,2] ;AND DON'T FORGET TTB
2509 TPDON: MOVE TP,C ;IN CASE TP TOO BIG
2510 CAME TP,TPSAV(TB) ;CHECK THAT INBLK WORKED
2512 MOVE C,OTBSAV(TB) ;RESTORE P STARTING FROM PREVIOUS
2513 MOVE P,PSAV(C) ;FRAME
2515 ;MOVE A P BLOCK BACK TO P
2520 SUB PP,[2,,2] ;NOW BACK BEYOND TP BLOCK
2522 CAIE A,TFIX ;GET P BLOCK...
2523 JRST CHPC2 ;...IF ANY
2525 SUB A,(PP) ;A POINTS TO FIRST
2526 PSHLP5: PUSH P,-1(A) ;MOVE BLOCK
2532 SUB PP,[3,,3] ;NOW AT NEXT PP "FRAME"
2534 CHPC2: CAME P,PSAV(TB) ;MAKE SURE P RESTORED OKAY
2540 ;FRAME IS ALREADY ON THE STACK--- BINDINGS ONLY HASSLE
2542 MHFRAM: MOVE AB,ABSAV(TB) ;RESTORE ARGS POINTER
2543 CAME SP,SPSAV(TB) ;AND ENVIRONMENT
2547 SETZM FLFLG ;FLFLG _ OFF
2548 INTGO ;HANDLE POSTPONED INTERRUPTS
2552 ;HERE TO PUSH TUPLE STARTING AT (C), OF LENGTH -D
2564 ;DEFAULT MESSAGE IS <>
2566 MFALS: MOVSI B,TFALSE ;TYPE FALSE
2571 ;DEFAULT ACTIVATION IS <>, ALSO
2572 AFALS1: MOVSI B,TFALSE
2574 \r SETZM FACTI+1(PVP)
2577 ;FALSE IS ALLOWED EXPLICITLY
2579 TAFALS: CAIE A,TFALSE
2584 ;FLAG FOR INTERRUPT SYSTEM
2592 SUBI E,-PDLBUF-1(P) ;E _ ADR OF REAL 2ND DOPE WORD
2594 JRST PDLOSS ;SORRY, ONLY ONE GROWTH PER FAMILY
2595 HRRM E,PGROW ;SET PGROW
2600 NBLOTP: HRRZ E,TP ;MORE OR LESS THE SAME
2602 SUBI E,-PDLBUF-1(TP)
2606 NBLO2: MOVEI B,PDLGRO_-6
2607 DPB B,[111100,,-1(E)]
2609 \fMFUNCTION FINALIZE,SUBR,[FINALIZE]
2611 SKIPL AB ;IF NOARGS;
2612 JRST GETTOP ;FINALIZE ALL FAILPOINTS
2613 HLRE A,AB ;AT MOST ONE ARG
2616 PUSHJ P,TILLFM ;MAKE SURE ARG IS LEGAL
2617 HRR B,OTBSAV(B) ;B _ FRAME BEFORE ACTIVATION
2618 RESTPP: MOVE PP,PPSAV(B) ;RESTORE PP
2619 HRRZ A,TB ;IN EVERY FRAME
2620 FLOOP: CAIN A,(B) ;FOR EACH ONE,
2625 FDONE: MOVE A,$TFALSE
2629 ;TILLFM SETS B _ FIRST ARGUMENT IFF IT IS A LEGAL ACTIVATION
2631 TILLFM: HLRZ A,(AB) ;FIRST ARG MUST BE ACTIVATION
2634 MOVE A,1(AB) ;WITH RIGHT TIME
2641 GETYP C,FSAV(C) ;AND STRUCTURE
2647 ;LET B BE TOP LEVEL FRAME
2649 GETTOP: MOVE B,TPBASE+1(PVP) ;B _ BOTTOM OF TP
2650 MOVEI B,FRAMLN+1(B) ;B _ TOP LEVEL FRAME
2651 JRST RESTPP
\fMFUNCTION FAILPOINT,FSUBR,[FAILPOINT]
2653 GETYP A,(AB) ;ARGUMENT MUST BE LIST
2656 SKIPN C,1(AB) ;NON-NIL
2658 PUSH TP,$TLIST ;SLOT FOR BODY
2663 PUSH TP,[0] ;SAVE SLOT FOR PRE-(MESS ACT) ENV
2664 MOVE C,1(AB) ;GET SET TO CALL BINDER
2665 MOVNI D,1 ;---AS A PROG
2666 PUSHJ P,BINDER ;AND GO
2667 HRRZ C,1(AB) ;SKIP OVER THINGS BOUND
2668 TRNE A,H ;INCLUDING HEWITT ATOM IF THERE
2671 HRRZ C,(C) ;C _ (EXPR (MESS ACT) -FAIL-BODY-)
2673 HRRZ A,(C) ;A _ ((MESS ACT) -FAIL-BODY-)
2674 MOVEM A,1(AB) ;SAVE FOR FAILURE
2678 PUSH PP,$TPC ;ESTABLISH FAIL POINT
2680 PUSH PP,[TTP,,COP\ON]
2681 PUSH PP,A ;SAVE LOCATION OF THIS FRAME
2686 MCALL 1,EVAL ;EVALUATE EXPR
2687 JRST FINIS ;IF SUCCESSFUL, DO NORMAL FINIS
2689 ;FAIL TO HERE--BIND MESSAGE AND ACTIVATION
2691 FP: MOVEM SP,5(TB) ;SAVE SP BEFORE MESS AND ACT BOUND
2692 HRRZ A,1(AB) ;A _ ((MESS ACT) -BODY-)
2696 HRRZ C,1(A) ;C _ (MESS ACT)
2697 JUMPE C,TFMESS ;IF (), THINGS MUST BE <>
2698 PUSHJ P,CARATM ;E _ MESS
2700 PUSH TP,BNDA ;ELSE BIND IT
2706 HRRZ C,(C) ;C _ (ACT)
2707 JUMPE C,TFACT ;IF (), ACT MUST BE <>
2708 PUSHJ P,CARATM ;E _ ACT
2710 PUSH TP,BNDA ;BIND IT
2713 PUSH TP,FACTI+1(PVP)
2716 BLPROG: PUSHJ P,PROGAT
2719 TFMESS: GETYP A,MESS(PVP)
2722 TFACT: GETYP A,FACTI(PVP)
2727 ;THIS ROUTINE SETS E TO THE NEXT THING IN THE LIST C POINTS TO,
2728 ;SKIPPING IFF IT IS AN ATOM
2738 MFUNCTION RESTORE,SUBR,[RESTORE]
2743 CAIG A,4 ;1 OR 2 ARGUMENTS
2746 PUSHJ P,TILLFM ;B _ FRAME TO RESTORE (IF LEGAL)
2748 CAIE C,FAILPO ;ONLY FAILPOINTS RESTORABLE
2750 PUSHJ P,SAVE ;RESTORE IT
2751 SKIPN D,5(TB) ;ARE WE IN EXPR INSTEAD OF BODY?
2752 JRST EXIT2 ;YES-- EXIT
2754 PUSHJ P,SPECSTO ;UNBIND MESS AND ACT
2761 PUSH PP,[TTP,,COP\ON] ;REESTABLISH FAILPOINT
2765 CAIN C,4 ;VALUE GIVEN?
2766 JRST RETRG2 ;YES-- RETURN IT
2767 MOVE AB,ABSAV(TB) ;IN CASE OF GARBAGE COLLECTION
2770 ;ERROR COMMENTS FOR EVAL
2772 UNBOU: PUSH TP,$TATOM
2773 PUSH TP,MQUOTE UNBOUND-VARIABLE
2776 UNAS: PUSH TP,$TATOM
2777 PUSH TP,MQUOTE UNASSIGNED-VARIABLE
2781 ERRTFA: PUSH TP,$TATOM
2782 PUSH TP,MQUOTE TOO-FEW-ARGUMENTS-SUPPLIED
2786 ERRTMA: PUSH TP,$TATOM
2787 PUSH TP,MQUOTE TOO-MANY-ARGUMENTS-SUPPLIED
2792 PUSH TP,MQUOTE BAD-ENVIRONMENT
2797 PUSH TP,MQUOTE BAD-FUNARG
2801 WTYP: PUSH TP,$TATOM
2802 PUSH TP,MQUOTE WRONG-TYPE
2806 PUSH TP,MQUOTE MEANINGLESS-PARAMETER-DECLARATION
2809 NOBODY: PUSH TP,$TATOM
2810 PUSH TP,MQUOTE HAS-EMPTY-BODY
2813 BADCLS: PUSH TP,$TATOM
2814 PUSH TP,MQUOTE BAD-CLAUSE
2817 NXTAG: PUSH TP,$TATOM
2818 PUSH TP,MQUOTE NON-EXISTENT-TAG
2821 NXPRG: PUSH TP,$TATOM
2822 PUSH TP,MQUOTE NOT-IN-PROG
2825 NAPT: PUSH TP,$TATOM
2826 PUSH TP,MQUOTE NON-APPLICABLE-TYPE
2829 NONEVT: PUSH TP,$TATOM
2830 PUSH TP,MQUOTE NON-EVALUATEABLE-TYPE
2834 NONATM: PUSH TP,$TATOM
2835 PUSH TP,MQUOTE NON-ATOMIC-ARGUMENT
2839 ILLFRA: PUSH TP,$TATOM
2840 PUSH TP,MQUOTE FRAME-NO-LONGER-EXISTS
2843 NOTIMP: PUSH TP,$TATOM
2844 PUSH TP,MQUOTE NOT-YET-IMPLEMENTED
2847 ILLSEG: PUSH TP,$TATOM
2848 PUSH TP,MQUOTE ILLEGAL-SEGMENT
2851 BADPP: PUSH TP,$TATOM
2852 PUSH TP,MQUOTE PP-IN-ILLEGAL-CONFIGURATION
2856 BDFAIL: PUSH TP,$TATOM
2857 PUSH TP,MQUOTE OVERPOP--FAIL
2861 ER1ARG: PUSH TP,(AB)