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,SPCSTE,CNTIN2
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 MOVEI B,ARGNEV ;ARGS NOT EVALED
360 IAPPLY: MOVSI A,TLIST
364 HRRZ 0,1(AB) ;0 _ CALL
365 MOVEI B,ARGEV ;ARGS TO BE EVALED
369 CAIN A,TFSUBR ;NO -- FSUBR?
371 CAIN A,TFUNARG ;NO -- FUNARG?
373 CAIN A,TPVP ;NO -- PROCESS TO BE RESUMED?
375 SUBI B,ARGNEV ;B _ 0 IFF NO EVALUATION
376 PUSH P,B ;PUSH SWITCH
377 CAIN A,TSUBR ;NO -- SUBR?
379 CAIN A,TFIX ;NO -- CALL TO NTH?
381 CAIN A,TACT ;NO -- ACTIVATION?
383 JRST NAPT ;NONE OF THE ABOVE
386 ;APFSUBR CALLS FSUBRS
394 APSUBR: PUSH P,[0] ;MAKE SLOT FOR ARGCNT
396 SKIPN A,3(TB) ;IS IT NIL?
397 JRST MAKPTR ;YES -- DONE
398 PUSH TP,(A) ;NO -- GET CAR OF THE
404 MCALL 1,EVAL ;AND EVAL IT.
405 PUSH TP,A ;SAVE THE RESULT IN
406 PUSH TP,B ;THE GROWING TUPLE
407 BUMP: AOS (P) ;BUMP THE ARGCNT
408 HRRZ A,@3(TB) ;SET THE ARGLIST TO
409 MOVEM A,3(TB) ;CDR OF THE ARGLIST
416 ;APACT INTERPRETS ACTIVATIONS AS CALLS TO FUNCTION EXIT
418 APACT: MOVE A,(TP) ;A _ ARGLIST
420 GETYP B,(A) ;SETUP SECOND ARGUMENT
424 HRRZ A,(A) ;MAKE SURE ONLY ONE
427 SKIPN (P) ;IF ARGUMENT AS YET UNEVALED,
429 MCALL 1,EVAL ;EVAL IT
432 MCALL 2,EXIT ;AND EXIT GIVEN ACTIVATION
\f
434 ;APNUM INTERPRETS NUMBERS AS CALL TO FUNCTION GET
437 MOVE A,(TP) ;GET ARLIST
438 JUMPE A,ERRTFA ;NO ARGUMENT
439 PUSH TP,(A) ;GET CAR OF ARGL
442 HRRZ A,(A) ;MAKE SURE ONLY ONE ARG
444 JSP E,CHKARG ;HACK DEFERRED
455 ;APEXPR APPLIES EXPRS
456 ;EXPRESSION IS IN 0(AB), FUNCTION IS IN 0(TB)
461 JRST NOBODY ;NO, ERROR
462 MOVE D,(TP) ;D _ ARG LIST
463 SETZM (TP) ;ZERO (TP) FOR BODY
464 PUSH P,[0] ;SWITCHES OFF
465 PUSH P,B ;ARGS EVALER OR NON-EVALER
466 PUSHJ P,BINDER ;DO THE BINDINGS
468 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
869 CAIN A,TFALSE ;CAN BE #FALSE OR LIST
870 JRST DOBI ;IF <>, AUXILIARY BINDINGS
871 PUSHJ P,SAT ;OTHERWISE, TAKE SECOND ARG AS ARGLIST
874 MOVEI D,(B) ;D _ DECLARATIONS
875 SETZM (P) ;CLEAR SWITCHES
876 DOBI: POP TP,C ;RESTORE C _ FIRST ARG
882 HRRZ C,(C) ;C _ <REST <REST .ARG>>
883 JRST BIPROG ;NOW EXECUTE BODY AS PROG
\f;BINDER - THIS SUBROUTINE PROCESSES FUNCTION DECLARATIONS AND BINDS
884 ; ARGUMENTS AND TEMPORARIES APPROPRIATELY.
886 ; CALL: PUSHJ P,BINDER OR BINDRR
888 ; BINDER - TAKES SWITCHES AND EVALER AS ARGS ON P
890 ; BINDEV - 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
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
911 STC==40 ;ON IFF "STACK" APPEARS IN DECLARATIONS
912 BINDEV: POP P,A ;A _ RETURN ADDRESS
917 BIND1: PUSH P,A ;REPUSH ADDRESS
918 BINDER: PUSH TP,$TLIST
919 PUSH TP,0 ;SAVE CALL, IF ANY
920 PUSHJ P,BNDVEC ;E _ TOP OF BINDING STACK
922 CAIE A,TATOM ;HEWITT ATOM?
925 MOVEM A,-6(B) ;BUILD BIND BLOCK FOR ATOM
926 MOVE A,1(C) ;A _ HEWITT ATOM
929 HLL A,OTBSAV(TB) ;A _ POINTER TO THIS ACTIVATION
933 SUBI 0,-1(A) ;0 _ PROCESS VEC DOPE WORD
934 HRLI 0,TACT ;0 IS FIRST WORD OF ACT VALUE
935 MOVEM 0,-4(B) ;STORED IN BIND BLOCK
936 HRRZ C,(C) ;CDR THE FUNCTION
937 BIND2: POP TP,0 ;0 _ CALLING EXPRESSION
939 PUSHJ P,CARLST ;C _ DECLS LIST
940 JRST BINDC ;IF (), QUIT
942 TRNE B,STC ;CDR PAST "STACK" IF IT APPEARS
945 JRST AUXDO ;IN CASE OF PROG, GO TO AUXDO
947 JUMPE A,BINDC ;IF NO DECLS, TRY QUITTING
948 PUSHJ P,NXTDCL ;B _ NEXT STRING
949 JRST BINDRG ;ATOM INSTEAD
950 HRRZ C,(C) ;CDR DECLS
955 CAME B,[ASCII /BIND/ ]
957 JUMPE C,MPD ;GOT "BIND", NOW...
958 PUSHJ P,CARATE ;GET ATOM & START BIND BLOCK
960 MOVE B,1(SP) ;B _ ENV BEFORE BNDVEC
961 PUSHJ P,PSHBND ;FINISH BIND BLOCK
963 JUMPE C,BINDC ;MAY BE DONE
965 PUSHJ P,NXTDCL ;NEXT ONE
966 JRST BINDRG ;ATOM INSTEAD
967 HRRZ C,(C) ;CDR DECLS
971 CHCALL: CAME B,[ASCII /CALL/ ]
972 JRST CHOPTI ;GO INTO MAIN BINDING LOOP
973 JUMPE 0,MPD ;GOT "CALL", SO 0 MUST BE CALL
975 PUSHJ P,CARATE ;GET ATOM & START BIND BLOCK
\f MOVE B,0 ;B _ CALL
977 PUSHJ P,PSHBND ;MAKE BIND BLOCK
978 HRRZ C,(C) ;CDR PAST "CALL" ATOM
979 JUMPE C,BINDC ;IF DONE, QUIT
981 ;DECLLP IS THE MAIN BINDING LOOP FOR HANDLING FUNCTIONAL ARGUMENTS AND
982 ;THE STRINGS SCATTERED THEREIN
985 PUSHJ P,NXTDCL ;NEXT STRING...
986 JRST BINDRG ;...UNLESS SOMETHING ELSE
987 HRRZ C,(C) ;CDR DECLARATIONS
988 CHOPTI: TRZ B,1 ;GOD KNOWS WHY TRZ B,1 (SOMETHING TO DO WITH OPTIO)
990 ;CHECK FOR "OPTIONAL"
992 CAME B,[ASCII /OPTIO/]
994 MOVE 0,SWTCHS(P) ;OPT _ ON
998 PUSHJ P,EBINDS ;BIND ALL PREVIOUS ARGUMENTS
1003 CHREST: MOVE 0,SWTCHS(P) ;0 _ SWITCHES
1004 TRZ 0,OPT ;OPT _ OFF
1007 CAME B,[ASCII /REST/]
1009 PUSHJ P,NXTDCL ;GOT "REST"-- LOOK AT NEXT THING
1011 JRST MPD ;WHICH CAN'T BE STRING
1012 PUSHJ P,BINDB ;GET NEXT ATOM
1014 JRST ARGSDO ;YES-- JUST USE ARGS
1019 CHTUPL: CAME B,[ASCII /TUPLE/]
1021 PUSHJ P,NXTDCL ;GOT "TUPLE"-- LOOK AT NEXT THING
1024 PUSHJ P,CARATE ;WHICH BETTER BE ATOM
1026 TUPLDO: PUSH TP,$TLIST ;SAVE STUFF
1030 PUSH P,[0] ;ARG COUNTER
\f;THIS LOOP BUILDS A TUPLE ON THE STACK, ON THE TOP OF THE ENTITIES
1031 ;JUST SAVED-- DON'T WORRY; THEY'RE SAFE
1033 TUPLP: JUMPE D,TUPDON ;IF NO MORE ARGS, DONE
1034 INTGO ;WATCH OUT FOR BIG TUPLES AND SMALL STACKS
1035 PUSH TP,$TLIST ;SAVE D
1037 GETYP A,(D) ;GET NEXT ARG
1041 TRZ 0,DEF ;OFF DEFAULT
1042 PUSHJ P,@EVALER-1(P)
1045 PUSH TP,A ;BUILD TUPLE
1047 SOS (P) ;COUNT ELEMENTS
1048 HRRZ D,(D) ;CDR THE ARGS
1050 TUPDON: PUSHJ P,MRKTUP ;MAKE A TUPLE OF (P) ENTRIES
1051 SUB P,[1,,1] ;FLUSH COUNTER
1052 JRST BNDRST
\f;CHECK FOR "ARGS"
1054 CHARG: CAME B,[ASCII /ARGS/]
1056 PUSHJ P,NXTDCL ;GOT "ARGS"-- CHECK NEXT THING
1059 PUSHJ P,CARATE ;WHICH MUST BE ATOM
1061 ;HERE TO BIND AN ATOM TO THE REMAINING ARGS, UNEVALUATED
1063 ARGSDO: MOVSI A,TLIST ;(A,B) _ CURRENT ARGS LEFT
1067 ;BNDRST COMPLETES THE BIND BLOCK FOR BOTH TUPLES AND ARGS
1069 BNDRST: PUSHJ P,PSHBND
1070 HRRZ C,(C) ;CDR THE DECLS
1073 PUSHJ P,NXTDCL ;WHAT NEXT?
1074 JRST MPD ;MUST BE A STRING OR ELSE
1075 HRRZ C,(C) ;CDR DECLS
1079 CHAUX: CAME B,[ASCII /AUX/]
1081 JUMPG D,TMA ;ARGS MUST BE USED UP BY NOW
1082 PUSH P,C ;SAVE C ON P (NO GC POSSIBLE)
1083 PUSHJ P,EBIND ;BIND ALL ARG ATOMS
1086 ;HERE FOR AUXIES OF "AUX" OR PROG VARIETY
1088 AUXDO: MOVE 0,SWTCHS(P)
1089 TRO 0,AUX\OPT\DEF ;OPTIONALS OBVIOUSLY ALLOWED
1091 AUXLP: JUMPE C,BNDHAT ;IF NO MORE, QUIT
1093 PUSHJ P,NXTDCL ;GET NEXT DECLARATION STRING
1094 JRST AUXIE ;INSTEAD, ANOTHER AUXIE-- DO IT
1095 HRRZ C,(C) ;CDR PAST STRING
1096 JRST CHACT1 ;...WHICH MUST BE "ACT"
1098 ;NORMAL AUXILIARY DECLARATION HANDLER
1100 AUXIE: MOVE 0,SWTCHS(P)
1101 PUSH TP,$TLIST ;SAVE C
1103 PUSHJ P,BINDB ;PUSH NEXT ATOM ONTO E
1104 MOVE A,$TVEC ;SAVE E UNDER DEFAULT VALUE
1107 PUSH TP,A ;(DEFAULT VALUE MUST BE REPUSHED)
1109 PUSHJ P,@EVALER(P) ;EVAL THE VALUE IT IS TO RECEIVE
1112 PUSHJ P,PSHBND ;COMPLETE BINDING BLOCK WITH VALUE
1113 PUSHJ P,EBIND ;BIND THE ATOM
1116 HRRZ C,(C) ;CDR THE DECLARATIONS
1118 \f;"ACT" CAN OCCUR ONLY AT THE END, HEWITT ATOMS NOTWITHSTANDING
1120 CHACT1: MOVEI D, ;MAKE IT CLEAR THAT THERE ARE NO ARGS
1121 CHACT: CAME B,[ASCII /ACT/] ;ONLY THING POSSIBLE
1123 JUMPE C,MPD ;BETTER HAVE AN ATOM TO BIND TO ACT
1124 PUSHJ P,CARATE ;START BIND BLOCK WITH IT
1127 SUBI A,-1(B) ;A _ PROCESS VEC DOPE WORD
1130 HLL B,OTBSAV(TB) ;(A,B) _ ACTIVATION POINTER
1132 HRRZ C,(C) ;"ACT" MUST HAVE BEEN LAST
1135 ;AT THIS POINT, ALL ENTRIES ARE FINAL AND ALL THINGS LOOSED
1136 ;IN E SHALL BE BOUND IN E, EVENTUALLY
1138 BINDC: JUMPG D,TMA ;ARGS SHOULD BE USED UP BY NOW
1139 PUSHJ P,EBIND ;BIND EVERYTHING NOT BOUND
1140 BNDHAT: MOVE 0,SWTCHS(P) ;EVEN THE HEWITT ATOM
1141 TRNN 0,H ;IF THERE IS ONE
1143 ADD E,[2,,2] ;E _ POINTER TO SECOND WORD OF NEXT BLOCK
1144 PUSHJ P,COMBLK ;CHAIN THIS BLOCK TO PREVIOUS THING IN VECTOR
1145 ADD E,[4,,4] ;E _ LAST WORD OF BINDING VECTOR
1146 PUSHJ P,EBIND ;BIND THE HEWITT ATOM
1148 ;THIS IS THE WAY OUT OF THE BINDER
1150 BNDRET: SUB P,[2,,2] ;FLUSH EVALER
1151 POP P,A ;A _ SWITCHES
1152 JRST @3(P) ;RETURN FROM BINDER
\f;TO BIND A PERFECTLY ORDINARY ARGUMENT SPECIFICATION
1153 ;FOUND IN A DECLS LIST, JUMP HERE
1155 BINDRG: MOVE 0,SWTCHS(P)
1156 PUSHJ P,BINDB ;GET ATOM IN THE NEXT DECL
1157 JUMPE D,CHOPT3 ;IF ARG EXISTS,
1159 SUB TP,[2,,2] ;PITCH ANY DEFAULT THAT MAY EXIST
1160 GETYP A,(D) ;(A,B) _ NEXT ARG
1163 HRRZ D,(D) ;CDR THE ARGS
1164 TRZN 0,QUO ;ARG QUOTED?
1165 JRST BNDRG1 ;NO-- GO EVAL
1166 CHDEFR: MOVEM 0,SWTCHS(P)
1167 CAME A,$TDEFER ;QUOTED-- PUNT ANY TDEFER'S YOU FIND
1169 GETYP A,(B) ;(A,B) _ REAL POINTER, NOT DEFERRED
1171 JRST DCLCDR ;AND FINISH BIND BLOCK
1175 CHOPT3: TRNN 0,OPT ;IF NO ARG, BETTER BE OPTIONAL
1177 POP TP,B ;(A,B) _ DEFAULT VALUE
1179 TRZE 0,QUO ;IF QUOTED,
1180 JRST CHDEFR ;JUST PUSH
1181 TRO 0,DEF ;ON DEFAULT
1183 ;EVALUATE WHATEVER YOU HAVE AT THIS POINT
1185 BNDRG1: PUSH TP,$TLIST ;SAVE STUFF
1193 PUSHJ P,@EVALER(P) ;(A,B) _ <EVAL (A,B)>
1194 MOVE E,(TP) ;RESTORE C, D, & E
1198 MOVE 0,SWTCHS(P) ;RESTORE 0
1201 ;FINISH THE BIND BLOCK WITH (A,B) AND GO ON
1203 DCLCDR: PUSHJ P,PSHBND
1204 TRNE 0,OPT ;IF OPTIONAL,
1205 PUSHJ P,EBINDS ;BIND IT
1207 JUMPE C,BINDC ;IF NO MORE DECLS, QUIT
1208 JRST DECLLP
\f;THIS ROUTINE CREATES THE BIND BLOCK BINDER USES; IT ALLOCATES
1209 ;THREE SLOTS PER NON-STRING DECLARATION (I.E., ATOM TO BE BOUND),
1210 ;THREE FOR A HEWITT ATOM IF IT FINDS ONE, AND ONE FOR THE ACCESS
1211 ;TYPE-TSP POINTER TO SP.
1213 ;THE BLOCK IS ALLOCATED AS A TUPLE IF "STACK" APPEARS
1214 ;FIRST IN THE DECLARATIONS, AS A VECTOR OTHERWISE
1217 ;BNDVEC SETS E TO THE CURRENT TOP OF THE BLOCK; IT FILLS IN
1218 ;ACCESS SLOT WITH SP, AND SETS SP TO POINT TO
1219 ;THE START OF THIS BLOCK. IT SETS B TO POINT TO THE DOPE CELL
1220 ;OF THE TUPLE OR VECTOR. IT MAY SET SWITCHES H OR STC TO ON,
1221 ;IFF IT FINDS A HEWITT ATOM OR A "STACK". IT CLOBBERS A,
1222 ;RESTORES C & D, AND LEAVES THE SWITCHES IN 0
1224 ;IF BNDVEC FINDS NO DECLARATIONS, IT TAKES THE LIBERTY OF EXITING
1225 ;FROM THE BINDER WITHOUT DISTURBING SP. BNDVEC DOES SOME ERROR
1226 ;CHECKING, BUT NOT ALL, AS IT DOES NOT LOOK AT THE ARGS IN D.
1227 ;THIS EXPLAINS WHY BINDER OMITS SOME.
1229 BNDVEC: PUSH TP,$TLIST ;SAVE C & D
1234 MOVE 0,SWTCHS-1(P) ;UNBURY THE SWITCHES
1235 MOVEI D, ;D = COUNTER _ 0
1236 GETYP A,(C) ;A _ FIRST THING
1237 CAIE A,TATOM ;HEWITT ATOM?
1239 TRO 0,H ;TURN SWITCH H ON
1240 ADDI D,3 ;YES-- SAVE 3 SLOTS FOR IT
1241 HRRZ C,(C) ;CDR THE FUNCTION
1243 NOHATM: PUSHJ P,CARLST ;C _ <1 .C>
1244 JRST CNTRET ;IF (), ALL COUNTED
1245 MOVEI A,(C) ;A _ DECLS
1246 PUSHJ P,NXTDCL ;LOOK FOR "STACK"
1247 JRST DINC ;NO STRING
1249 CAMN B,[ASCII /STACK/]
1250 TRO 0,STC ;TURN ON STACK SWITCH
1252 ;HERE IS THE QUICK LOOP THROUGH THE DECLARATIONS
1254 DCNTLP: HRRZ A,(A) ;CDR DECLS
1255 JUMPE A,CNTRET ;IF NO MORE, DONE
1256 PUSHJ P,NXTDCL ;SKIP IF NEXT ONE IS A STRING
1257 DINC: ADDI D,3 ;3 SLOTS FOR AN ATOM
1260 ;IF ANYTHING WAS FOUND, INITIALIZE THE VECTOR
1262 CNTRET: JUMPE D,NODCLS ;OTHERWISE, BIND NOTHING
1263 AOJ D, ;DON'T FORGET ACCESS SLOT
1264 MOVEM 0,SWTCHS-1(P) ;SAVE SWITCHES
1265 TRNE 0,STC ;FOUND "STACK"?
1269 MCALL 1,VECTOR ;B _ <VECTOR .D>
1270 MOVE E,B ;FROM NOW ON, E _ BIND VECTOR TOP
1272 SUB B,C ;B _ VECTOR DOPE CELL ADDRESS
1275 MOVEM 0,(E) ;FILL ACCESS SLOT
1277 MOVE SP,A ;SP NOW POINTS THROUGH THIS VECTOR
1278 MOVE D,(TP) ;RESTORE C & D
1283 ;IF THERE ARE NO DECLS (E.G. <FUNCTION ()...>), JUST QUIT
1285 NODCLS: MOVE D,(TP) ;RESTORE C & D
1288 SUB P,[1,,1] ;PITCH RETURN ADDRESS
1289 JRST BNDRET
\f;HERE TO BIND BUGGERS ON STACK
1291 TUPBND: LSH D,1 ;D _ 2*NUMBER OF CELLS
1292 MOVN C,D ;SAVE -D ON P
1294 ADDI D,2 ;2 MORE FOR TTB MARKER
1297 ADD TP,D ;TP _ ADDRESS OF LAST TUPLE WORD
1298 ADD C,[1,,1] ;C _ ADDRESS OF FIRST WORD OF TUPLE
1300 MOVEM 0,CSTO(PVP) ;IN CASE OF GC
1304 ADDI D,1 ;ZERO ENTIRE TUPLE SPACE
1306 HLRE B,TP ; IF TP BLOWN,
1307 SKIPLE B ; ZERO ONLY UP TO END OF PDL
1311 PUSHJ P,NBLOTP ;NOW SAFE TO UNBLOW IT
1315 BLT D,(TP) ;MOVE SAVED 0, C & D TO TOP OF STACK
1317 HRLI D,TTB ;D _ [TTB,,-LENGTH]
1318 MOVEI B,-7(TP) ;B _ POINTER TO TUPLE DOPE CELL
1320 MOVEM TB,1(B) ;FENCEPOST TUPLE
1321 MOVE E,C ;E _ POINTER TO TUPLE START
1322 SUB E,[6,,6] ; ON TP STACK
1324 SUB C,D ;C = DOPE WORD POINTER?
1326 ADD E,[-PDLBUF,,0] ;MAKE E TRUE VECTOR POINTER
1327 JRST SETSP
\f;THIS ROUTINE CREATES A POINTER TO THE TUPLE RESTING ON TOP OF
1328 ;TP. IT TAKES ITS NEGATIVE LENGTH (IN CELLS) IN (P). IT ASSUMES
1329 ;THERE ARE TWO TEMPORARY CELLS BENEATH IT, AND RESTORES
1330 ;THEM INTO C AND E, MOVING THE TUPLE OVER THE TEMPORARY
1331 ;SLOTS. IT RETURNS A CORRECT TARGS POINTER TO THE TUPLE IN A AND B
1333 MRKTUP: MOVSI A,TTB ;FENCE-POST TUPLE
1336 MOVEI A,2 ;B_ADDRESS OF INFO CELL
1337 PUSHJ P,CELL" ;MAY CALL AGC
1340 MOVEI A,(TP) ;GENERATE DOPE WORD POINTER
1343 CAME A,TPGROW" ;ALLOWING FOR BLOWN PDL
1345 HRLZI A,-1(A) ;A HAS 1ST DW PTR IN LEFT HALF
1346 HLR A,OTBSAV(TB) ;TIME TO RIGHT
1347 MOVEM A,1(B) ;TO SECOND WORD OF CELL
1348 EXCH B,-1(P) ;B _ - ARG COUNT
1350 HRRM B,-1(TP) ;STORE IN TTB FENCEPOST
1352 ADD A,B ;A _ ADR OF TUPLE
1353 HRLI A,(B) ;A _ TUPLE POINTER
1355 HRLI A,4(A) ;LH A _ CURRENT PLACE OF TUPLE
1356 MOVE C,1(A) ;RESTORE C AND E
1358 BLT A,-4(TP) ;MOVE TUPLE OVER OLD C, E COPIES
1361 HRLI A,TARGS ;A _ FIRST WORD OF ARGS TUPLE VALUE
1362 POPJ P,
\f;THIS ROUTINE, GIVEN SWTCHS IN 0 AND DECLARATIONS LIST POINTER
1363 ;IN C, PUSHES ATOM IN THE FIRST DECLARATION ONTO E. IT MAY SET
1364 ;SWITCHES OPT AND QUO, AND LEAVES SWITCHES IN 0. IFF OPT = ON,
1365 ;BINDB PUSHES A DEFAULT VALUE (EVEN IF ?()) ONTO TP. A & B ARE
1366 ;CLOBBERED. C IS NOT ALTERED.
1368 BINDB: MOVE A,C ;A _ C
1370 CAIE B,TLIST ;A = ((...)...) ?
1372 TRNN 0,OPT ;YES-- OPT MUST BE ON
1374 MOVEM 0,SWTCHS-1(P) ;SAVE SWITCHES
1375 MOVE A,1(A) ;A _ <1 .A> = (...)
1376 JUMPE A,MPD ;A = () NOT ALLOWED
1377 HRRZ B,(A) ;B _ <REST .A>
1378 JUMPE B,MPD ;B = () NOT ALLOWED
1379 PUSH TP,(B) ;SAVE <1 .B> AS DEFAULT
1380 PUSH TP,1(B) ;VALUE OF ATOM IN A
1382 JUMPN B,MPD ;<REST .B> MUST = ()
1384 JRST CHFORM ;GO SEE WHAT <1 .A> IS
1386 CHOPT1: TRNN 0,OPT ;IF OPT = ON
1388 PUSH TP,$TUNAS ;DEFAULT VALUE IS ?()
1391 ;AT THIS POINT, <1 .A> MUST BE ATOM OR <QUOTE ATOM>
1393 CHFORM: TRNE 0,AUX ;NO QUOTES ALLOWED IN AUXIES
1397 MOVE A,1(A) ;A _ <1 .A> = <...>
1398 JUMPE A,MPD ;A = <> NOT ALLOWED
1399 MOVE B,1(A) ;B _ <1 .A>
1401 JRST MPD ;ONLY A = <QUOTE...> ALLOWED
1404 HRRZ A,(A) ;A _ <REST .A>
1405 JUMPE A,MPD ;<QUOTE> NOT ALLOWED
1408 ;AT THIS POINT WE HAVE THE ATOM OR AN ERROR
1410 CHATOM: CAIE B,TATOM ;<1 .A> MUST BE ATOM
1412 MOVE A,1(A) ;A _ THE ATOM!!!
1413 JRST PSHATM ;WHICH MUST BE PUSHED ONTO E
1417 ;THE FOLLOWING LITTLE ROUTINE ACCEPTS THE NEXT DECLARATION ONLY
1418 ;IF IT IS ATOMIC, AND PUSHES IT ONTO E
1423 MOVE A,1(C) ;A _ ATOM
1425 PSHATM: PUSH E,$TBIND ;FILL FIRST TWO SLOTS OF BIND BLOCK
1428 ;EACH BIND BLOCK MUST POINT TO THE PREVIOUS ONE OR TO AN ACCESS
1429 ;POINTER TO ANOTHER VECTOR ALTOGETHER. COMBLK MAKES SURE IT DOES.
1431 COMBLK: GETYP B,-7(E) ;LOOK FOR PREVIOUS BIND
1432 CAIE B,TBIND ;IF FOUND, MAKE NORMAL LINK
1434 MOVEI B,-7(E) ;IN MOST CASES, SEVEN
1435 MAKLNK: HRRM B,-1(E) ;MAKE THE LINK
1437 ABNORM: MOVEI B,-3(E)
1439 \f;THIS ROUTINE COMPLETES A BIND BLOCK BEGUN BY CARATE OR BINDB
1440 ;WITH THE VALUE (A,B)
1444 ADD E,[2,,2] ;ASSUME BIND VECTOR IS FULL OF 0'S
1447 ;THIS ONE DOES AN EBIND, SAVING C & D:
1449 EBINDS: PUSH P,C ;SAVE C & D (NO DANGER OF GC)
1451 PUSHJ P,EBIND ;BIND ALL NON-OPTIONAL ARGUMENTS
1453 POP P,C ;RESTORE C & D
1457 ;THE FOLLOWING RETURNS THE CAR OF C IN C, SKIPPING IF
1458 ;<EMPTY? <1 .C>>, AND ERRING IF <NOT <==? <TYPE <1 .C>> LIST>>
1462 JRST MPD ;NOT A LIST, FATAL
1468 ;...AND THERE ARE A FEW PEOPLE STILL CALLING THE FOLLOWING:
1470 MAKENV: PUSH P,C ;SAVE AN AC
1471 HLRE C,PVP ;GET -LNTH OF PROC VECTOR
1472 MOVEI A,(PVP) ;COPY PVP
1473 SUBI A,-1(C) ;POINT TO DOPWD WITH A
1474 HRLI A,TFRAME ;MAKE INTO A FRAME
1475 HLL B,OTBSAV(B) ;TIME TO B
1481 \f;THESE ROUTINES ARE CALLED TO EVALUATE THE VALUE PUSHED
1482 ;ON TP ****THEY ARE ASSUMED TO CLOBBER EVERYTHING****
1491 ;WHEN APPLY-ING, ARGS ARE ALREADY EVALUATED
1493 ARGNEV: JSP E,CHKARG ;PITCH ANY TDEFERS
1494 TRNN 0,DEF ;DEFAULT VALUES...
1496 MCALL 1,EVAL ;...ARE ALWAYS EVALUATED
1498 NOEV: POP TP,B ;OTHERWISE,
1499 POP TP,A ;JUST RESTORE A&B
1500 POPJ P,
\f;SPECBIND BINDS IDENTIFIERS. IT IS CALLED BY PUSHJ P,SPECBIND.
1501 ;SPECBIND IS PROVIDED WITH A CONTIGUOUS SET OF TRIPLETS ON TP.
1502 ;EACH TRIPLET IS AS FOLLOWS:
1503 ;THE FIRST ELEMENT IS THE IDENTIFIER TO BE BOUND, ITS TYPE WORD IS [TATOM,,-1],
1504 ;THE SECOND IS THE VALUE TO WHICH IT IS TO BE ASSIGNED,
1505 ;AND THE THIRD IS A PAIR OF ZEROES.
1506 ;FOR ENTRY SPECB1, REGISTER 0 CONTAINS SWITCHES. ONLY RELEVANT ONE
1512 SPECBIND: MOVEI 0, ;DEFAULT IS STC _ OFF
1513 SPECB1: MOVE E,TP ;GET THE POINTER TO TOP
1514 ADD E,[1,,1] ;BUMP POINTER ONCE
1515 MOVEI B, ;ZERO COUNTER
1517 SZLOOP: MOVE A,-6(D) ;COUNT ATOM BLOCKS AS 3
1520 SUB D,[6,,6] ;D _ ADDRESS OF BOTTOM BLOCK
1523 GETVEC: JUMPE B,DEGEN
1524 TRNE 0,STC ;IF STC IS ON,
1525 JRST TPSPCB ; LEAVE BLOCKS ON TP
1534 MCALL 1,VECTOR ;<VECTOR .B>
1535 POP TP,D ;RESTORE D = POINTER TO BOTTOM TRIPLE
1537 MOVE A,$TSP ;MAKE THIS BLOCK POINT TO PREVIOUS
1542 ;MOVE TRIPLES TO VECTOR
1544 POP P,E ;E _ LENGTH - 1
1546 ADDI E,(B) ;E _ POINTER TO VECTOR DOPE WORD
1549 BLT A,-1(E) ;MOVE BIND TRIPLES TO VECTOR
1551 ;CHANGE ALL [TATOM,,-1]'S TO [TBIND,,LINK TO PREVIOUS BLOCK]
1553 HRRZI B,(B) ;ZERO LEFT HALF OF B
1554 HRRI C,-2(B) ;C = LINK _ ADR OF FIRST OF VECTOR
1556 LNKBLK: HRLI C,TBIND
1557 FIXLP: MOVEM C,(B) ;STORE LINK TO PREVIOUS BLOCK IN BLOCK B
1558 HRRI C,(B) ;C _ LINK TO THIS BLOCK
1560 CAIE B,(E) ;GOT TO DOPE WORD?
1568 CAMLE C,TP ;ANYTHING ABOVE TRIPLES?
1570 SUBI TP,(C) ;TP _ NUMBER THERE
1571 HRLS TP ;IN BOTH HALVES
1574 BLT D,(TP) ;BLLLLLLLLT!
1576 DEGEN: SUB TP,[2,,2]
1578 NOBLT2: MOVE TP,D ;OR JUST RESTORE IT
1582 ;HERE TO JUST BIND THE LOSERS ON THIS STACK
1585 PUSH TP,$TSP ;PUSH ACCESS POINTER
1591 PUSH TP,B ;FENCEPOST BIND TRIPLES AS TUPLE
1595 PUSHJ P,LNKBLK ;LINK BIND BLOCKS TOGETHER
1596 HLRE C,D ;MAKE E A REAL VECTOR POINTER
1598 CAME C,TPGROW" ;BY FINDING REAL DOPE WORD
1601 \f;HERE TO BIND EVERYTHING IN BLOCK WITH DOPE WORD (E)
1603 SPCBE2: SUB E,[1,,1] ;E _ LAST WORD OF LAST BLOCK
1605 ;EBIND BINDS THE ATOMS SPECIFIED BY THE BLOCK WHOSE LAST WORD
1606 ;E POINTS TO, THEN THE BLOCK LINKED TO IT, ETC., UNTIL
1607 ;IT FINDS ONE ALREADY BOUND, WHEN IT RESTORES E AND EXITS.
1608 ;IT RESETS SP TO POINT TO THE FIRST ONE BOUND. IT CLOBBERS
1609 ;ALL OTHER REGISTERS
1612 SKIPE A ;ALREADY BOUND?
1613 POPJ P, ;YES-- EBIND IS A NO-OP
1614 MOVEI D, ;D WILL BE THE NEW SP
1618 BINDLP: HLRZ A,-1(E)
1619 SKIPE A ;HAS THIS BLOCK BEEN BOUND ALREADY?
1620 JRST SPECBD ;YES, RESTORE AND QUIT
1621 DOBIND: SUB E,[6,,6]
1622 SKIPN D ;HAS NEW SP ALREADY BEEN SET?
1623 MOVE D,E ;NO, SET TO THIS BLOCK FOR NOW
1626 PUSHJ P,ILOC ;(A,B) _ LOCATIVE OF (A,B)
1628 MOVEM A,5(E) ;CLOBBER IT AWAY
1629 MOVEM B,6(E) ;IN RESTORE CELLS
1631 HRRZ A,PROCID+1(PVP) ;GET PROCESS NUMBER
1632 HRLI A,TLOCI ;MAKE LOC PTR
1633 MOVE B,E ;TO NEW VALUE
1635 MOVE C,2(E) ;GET ATOM PTR
1636 MOVEM A,(C) ;CLOBBER ITS VALUE
1640 SPECBD: MOVE SP,D ;SP _ D
1641 ADD SP,[1,,1] ;FIX SP
1642 POP P,E ;RESTORE E TO TOP OF BIND VECTOR
1647 ;SPECSTORE RESTORES THE BINDINGS SP TO THE ENVIRONMENT POINTER IN
1648 ;SPSAV (TB). IT IS CALLED BY PUSHJ P,SPECSTORE.
1651 MOVE E,SPSAV (TB) ;GET TARGET POINTER
1652 SPCSTE: HRRZ SP,SP ;CLEAR LEFT HALF OF SP
1654 CAIN SP,(E) ;ARE WE DONE?
1656 HLRZ C,(SP) ;GET TYPE OF BIND
1657 CAIE C,TBIND ;NORMAL IDENTIFIER?
1658 JRST JBVEC ;NO-- FIND & FOLLOW REBIND POINTER
1661 MOVE C,1(SP) ;GET TOP ATOM
1662 MOVE D,4(SP) ;GET STORED LOCATIVE
1663 \r HRR D,PROCID+1(PVP) ;STORE SIGNATURE
1664 MOVEM D,(C) ;CLOBBER INTO ATOM
1667 HRRZS 4(SP) ;NOW LOOKS LIKE A VIRGIN BLOCK
1669 HRRZ SP,(SP) ;GET NEXT BLOCK
1672 ;IN JUMPING TO A NEW BIND VECTOR, FOLLOW
1673 ;REBIND POINTER IF IT DIFFERS FROM ACCESS POINTER
1675 JBVEC: CAIE C,TSP ;THIS JUST BETTER BE TRUE, THAT'S ALL
1676 .VALUE [ASCIZ /BADSP/]
1677 GETYP D,2(SP) ;REBIND POINTER?
1679 JRST XCHVEC ;NO-- USE ACCESS
1680 MOVE D,5(SP) ;YES-- RESTORE PROCID
1681 EXCH D,PROCID+1(PVP)
1682 MOVEM D,5(SP) ;SAVING CURRENT ONE FOR LATER FAILURES
1685 ;IF WE JUST RAN OFF THE END OF THE ENVIRONMENT CHAIN, BARF
1687 XCHVEC: HRRZ SP,1(SP)
1689 JUMPE E,STPOPJ ;UNLESS THAT'S AS FAR AS WE WANTED TO GO
1690 .VALUE [ASCIZ /SPOVERPOP/]
1699 MFUNCTION REP,FSUBR,[REPEAT]
1701 MFUNCTION PROG,FSUBR
1703 GETYP A,(AB) ;GET ARG TYPE
1704 CAIE A,TLIST ;IS IT A LIST?
1705 JRST WTYP ;WRONG TYPE
1706 SKIPN C,1(AB) ;GET AND CHECK ARGUMENT
1707 JRST ERRTFA ;TOO FEW ARGS
1708 PUSH TP,$TLIST ;PUSH GOODIE
1710 BIPROG: PUSH TP,$TLIST
1711 PUSH TP,C ;SLOT FOR WHOLE BODY
1712 MOVE C,3(TB) ;PROG BODY
1714 PUSH P,[AUX] ;TELL BINDER WE ARE APROG
1716 HRRZ C,3(TB) ;RESTORE PROG
1717 TRNE A,H ;SKIP IF NO NAME ALA HEWITT
1720 MOVEM C,3(TB) ;SAVE FOR AGAIN, ETC.
1721 MOVE 0,A ;SWITCHES TO 0
1722 BLPROG: PUSHJ P,PROGAT ;BIND OBSCURE ATOM
1724 STPROG: HRRZ C,(C) ;SKIP DCLS
1727 ; HERE TO RUN PROGS FUNCTIONS ETC.
1730 HRRZM C,1(TB) ;CLOBBER AWAY BODY
1731 PUSH TP,(C) ;EVALUATE THE
1733 PUSH TP,1(C) ;STATEMENT
1736 HRRZ C,@1(TB) ;GET THE REST OF THE BODY
1737 JUMPN C,DOPROG ;IF MORE -- DO IT
1741 CAME C,MQUOTE REP,REPEAT
1743 SKIPN C,3(TB) ;CHECK IT
1748 ;HERE TO BIND PROG ATOM (AND ANYTHING ELSE ON STACK)
1750 PROGAT: PUSH TP,BNDA
1751 PUSH TP,MQUOTE [LPROG ],INTRUP
1753 PUSHJ P,MAKENV ;B _ POINTER TO CURRENT FRAME
1760 MFUNCTION RETURN,SUBR
1762 PUSHJ P,PROGCH ;CKECK IN A PROG
1763 PUSHJ P,SAVE ;RESTORE PROG'S FRAME, BCKTRKING IF NECESSARY
1769 MFUNCTION AGAIN,SUBR
1771 HLRZ A,AB ;GET # OF ARGS
1774 JUMPN A,WNA ;0 ARGS?
1775 PUSHJ P,PROGCH ;CHECK FOR IN A PROG
1790 AGAD: PUSHJ P,SAVE ;RESTORE FRAME TO REPEAT
1797 PUSHJ P,PROGCH ;CHECK FOR A PROG
1807 MCALL 2,MEMQ ;DOES IT HAVE THIS TAG?
1808 JUMPE B,NXTAG ;NO -- ERROR
1809 FNDGO: EXCH B,(TP) ;SAVE PLACE TO GO
1814 NLCLGO: CAME A,$TTAG ;CHECK TYPE
1816 MOVE A,1(AB) ;GET ARG
1821 CAME B,3(A) ;CHECK TIME
1826 PUSH TP,(A) ;SAVE BODY
1828 GODON: PUSHJ P,SAVE ;GO BACK TO CORRECT FRAME
1829 MOVE B,(TP) ;RESTORE ITERATION MARKER
1840 HLRZ A,(AB) ;GET TYPE OF ARGUMENT
1841 CAIE A,TATOM ;CHECK THAT IT IS AN ATOM
1843 PUSHJ P,PROGCH ;CHECK PROG
1851 JUMPE B,NXTAG ;IF NOT FOUND -- ERROR
1852 EXCH A,-1(TP) ;SAVE PLACE
1854 PUSH TP,A ;UNDER PROG FRAME
1860 PROGCH: MOVE B,MQUOTE [LPROG ],INTRUP
1861 PUSHJ P,ILVAL ;GET VALUE
1865 MOVE C,B ;CHECK TIME
1879 PUSHJ P,TILLFM ;TEST FRAME
1880 PUSHJ P,SAVE ;RESTORE FRAME
1883 ;IF GIVEN, RETURN SECOND ARGUMENT
1885 RETRG2: MOVE A,2(AB)
1887 MOVE AB,ABSAV(TB) ;IN CASE OF GC
1890 MFUNCTION COND,FSUBR
1896 PUSH TP,1(AB) ;CREATE UNNAMED TEMP
1897 CLSLUP: SKIPN B,1(TB) ;IS THE CLAUSELIST NIL?
1898 JRST IFALSE ;YES -- RETURN NIL
1899 HLRZ A,(B) ;NO -- GET TYPE OF CAR
1900 CAIE A,TLIST ;IS IT A LIST?
1902 MOVE A,1(B) ;YES -- GET CLAUSE
1904 PUSH TP,(A) ;EVALUATION OF
1906 PUSH TP,1(A) ;THE PREDICATE
1909 CAMN A,$TFALSE ;IF THE RESULT IS
1910 JRST NXTCLS ;FALSE TRY NEXT CLAUSE
1911 MOVE C,1(TB) ;IF NOT, DO FIRST CLAUSE
1914 JUMPE C,FINIS ;(UNLESS DONE WITH IT)
1915 JRST DOPROG ;AS THOUGH IT WERE A PROG
1916 NXTCLS: HRRZ A,@1(TB) ;SET THE CLAUSLIST
1917 HRRZM A,1(TB) ;TO CDR OF THE CLAUSLIST
1921 MOVSI A,TFALSE ;RETURN FALSE
1928 ;RESTORE TB TO STACK FRAME POINTED TO BY B, SAVING INTERMEDIATE FRAMES ON THE PLANNER PDL
1929 ;IF NECESSARY; CLOBBERS EVERYTHING BUT B
1930 SAVE: MOVE E,SPSAV(B)
1931 PUSHJ P,SPCSTE ;RESTORE BINDINGS IF NECESSARY
1932 SKIPN C,OTBSAV(B) ;PREVIOUS FRAME?
1934 CAMN PP,PPSAV(C) ;ANYTHING HAPPEN TO PP BETWEEN B AND HERE?
1935 JRST QWKRET ;NO-- JUST RETURN
1941 HRRZ C,OTBSAV(TB) ;ANYTHING TO SAVE YET?
1943 PUSHJ P,BCKTRK ;DO IT
1944 HRR TB,OTBSAV(TB) ;AND POP UP
1946 QWKRET: HRR TB,B ;SKIP OVER EVERYTHING
1948 SVRET: SUB TP,[2,,2] ;POP CRAP OFF TP
1951 ;SETG IS USED TO SET THE GLOBAL VALUE OF ITS FIRST ARGUMENT,
1952 ;AN IDENTIFIER, TO THE VALUE OF ITS SECOND ARGUMENT. ITS VALUE IS
1953 ; ITS SECOND ARGUMENT.
1957 HLLZ A,(AB) ;GET TYPE OF FIRST ARGUMENT
1958 CAME A,$TATOM ;CHECK THAT IT IS AN ATOM
1959 JRST NONATM ;IF NOT -- ERROR
1960 MOVE B,1(AB) ;GET POINTER TO ATOM
1961 PUSHJ P,IGLOC ;GET LOCATIVE TO VALUE
1962 CAMN A,$TUNBOUND ;IF BOUND
1963 PUSHJ P,BSETG ;IF NOT -- BIND IT
1965 MOVE A,2(AB) ;GET SECOND ARGUMENT
1966 MOVE B,3(AB) ;INTO THE RETURN POSITION
1967 MOVEM A,(C) ;DEPOSIT INTO THE
1968 MOVEM B,1(C) ;INDICATED VALUE CELL
1971 BSETG: HRRZ A,GLOBASE+1(TVP)
1972 HRRZ B,GLOBSP+1(TVP)
1976 PUSH TP,GLOBASE(TVP)
1977 PUSH TP,GLOBASE+1 (TVP)
1983 MOVEM A,GLOBASE(TVP)
1984 MOVEM B,GLOBASE+1(TVP)
1986 MOVE B,GLOBSP+1(TVP)
1992 MOVEM B,GLOBSP+1(TVP)
2000 ;SET CLOBBERS THE LOCAL VALUE OF THE IDENTIFIER GIVEN BY ITS
2001 ;FIRST ARGUMENT TO THE SECOND ARG. ITS VALUE IS ITS SECOND ARGUMENT.
2005 HLLZ A,(AB) ;GET TYPE OF FIRST
2006 CAME A,$TATOM ;ARGUMENT --
2007 JRST WTYP ;BETTER BE AN ATOM
2008 MOVE B,1(AB) ;GET PTR TO IT
2009 PUSHJ P,ILOC ;GET LOCATIVE TO VALUE
2010 CAMN A,$TUNBOUND ;BOUND?
2011 PUSHJ P, BSET ;BIND IT
2013 MOVE A,2(AB) ;GET SECOND ARG
2014 MOVE B,3(AB) ;INTO RETURN VALUE
2015 MOVEM A,(C) ;CLOBBER IDENTIFIER
2020 MCALL 1,VECTOR ;GET NEW BIND VECTOR
2022 MOVEM A,(B) ;MARK IT
2026 MOVEM A,2(B) ;CHAIN FIRST BLOCK
2027 MOVE A,1(AB) ;A _ ATOM
2029 MOVE C,SPBASE+1(PVP) ;CHAIN TO PREVIOUS BIND VECTOR
2030 MOVEM B,SPBASE+1(PVP) ;SET NEW TOP
2033 ADD B,[2,,2] ;POINT TO LOCATIVE
2035 HRR A,PROCID+1(PVP) ;WHICH MAKE
2036 MOVE C,1(AB) ;C _ ATOM _ VALUE CELL ADDRESS
2038 MOVEM B,1(C) ;CLOBBER LOCATIVE SLOT
2044 HLRZ A,(AB) ; GET TYPE
2045 CAIE A,TFALSE ;IS IT FALSE?
2046 JRST IFALSE ;NO -- RETURN FALSE
2049 MOVSI A,TATOM ;RETURN T (VERITAS)
2053 MFUNCTION ANDA,FSUBR,AND
2057 JRST WTYP ;IF ARG DOESN'T CHECK OUT
2058 SKIPN C,1(AB) ;IF NIL
2059 JRST TRUTH ;RETURN TRUTH
2060 PUSH TP,$TLIST ;CREATE UNNAMED TEMP
2063 JUMPE C,FINIS ;ANY MORE ARGS?
2064 MOVEM C,1(TB) ;STORE CRUFT
2065 PUSH TP,(C) ;EVALUATE THE
2066 HLLZS (TP) ;FIRST REMAINING
2067 PUSH TP,1(C) ;ARGUMENT
2071 JRST FINIS ;IF FALSE -- RETURN
2072 HRRZ C,@1(TB) ;GET CDR OF ARGLIST
2078 CAIE A,TLIST ;CHECK OUT ARGUMENT
2080 MOVE C,1(AB) ;PICK IT UP TO ENTER LOOP
2081 PUSH TP,$TLIST ;CREATE UNNAMED TEMP
2084 JUMPE C,IFALSE ;IF NO MORE OPTIONS -- FALSE
2085 MOVEM C,1(TB) ;CLOBBER IT AWAY
2088 PUSH TP,1(C) ;EVALUATE THE FIRST REMAINING
2090 MCALL 1,EVAL ;ARGUMENT
2091 CAME A,$TFALSE ;IF NON-FALSE RETURN
2093 HRRZ C,@1(TB) ;IF FALSE -- TRY AGAIN
2096 MFUNCTION FUNCTION,FSUBR
2100 PUSH TP,MQUOTE FUNCTION
2106 MFUNCTION CLOSURE,SUBR
2108 SKIPL A,AB ;ANY ARGS
2109 JRST ERRTFA ;NO -- LOSE
2110 ADD A,[2,,2] ;POINT AT IDS
2113 PUSH P,[0] ;MAKE COUNTER
2115 CLOLP: SKIPL A,1(TB) ;ANY MORE IDS?
2116 JRST CLODON ;NO -- LOSE
2117 PUSH TP,(A) ;SAVE ID
2119 PUSH TP,(A) ;GET ITS VALUE
2121 ADD A,[2,,2] ;BUMP POINTER
2127 MCALL 2,LIST ;MAKE PAIR
2133 ACALL A,LIST ;MAKE UP LIST
2134 PUSH TP,(AB) ;GET FUNCTION
2138 MCALL 2,LIST ;MAKE LIST
2143 MFUNCTION FALSE,SUBR
2152 \f;BCKTRK SAVES THINGS ON PP
2154 ;IT AND ITS FRIENDS FLAG PP "FRAMES" WITH MARKERS OF FORM "TTP,,SWITCHES", WHERE SWITCHES INCLUDES
2156 COP==1 ;ON IFF CALL TO BCKTRK IS TO COPY FRAME (TB) AS WELL
2158 SAV==2 ;ON IFF TUPLES OF (TB) ARE TO BE SAVED; COP IMPLIES
2160 TUP==4 ;ON IFF (TB) CONTAINS ANY TUPLES BESIDES ARGS
2161 ON==10 ;ON IFF THIS FRAME OR FAILPOINT "RESTS ON TOP OF"
2162 ;FRAME DESIGNATED BY TTP POINTER, OR IS INTENDED TO
2165 ;BELOW THE TTP POINTER IS ONE OR TWO BLOCKS FLAGGED BY A TFIX
2166 ;VALUE. IF ON=ON AND TUP=ON IN THE RIGHT HALF OF THE TFIX,
2167 ;THE TFIX BEGINS A BLOCK OF TUPLE DEBRIS; OTHERWISE,
2168 ;IT BEGINS A SAVED TP FRAME.
2171 BCKTRK: HRRZ A,-1(PP) ;SLOT LEFT BY FAILPOINT?
2172 TRNN A,COP ;(I.E., TO BE COPIED?)
2174 MOVE E,TB ;YES-- FIRST SAVE THIS FRAME
2181 ;SAVE TUPLES OF FRAME ON TOP OF PP
2183 NBCK1: MOVSI B,TTP ;FAKE OUT GC
2188 MOVE B,(PP) ;B _ TPIFIED TB POINTER
2189 SUB PP,[2,,2] ;CLEAN OFF POINTER TO MAKE ROOM FOR ARGS
2191 MOVE C,PP ;C _ E _ PP
2192 SUB C,(PP) ;C _ ADDRESS OF SAVED OTB
2193 HLRE D,1(C) ;D _ NO. OF ARGS
2195 SUB B,[FRAMLN,,FRAMLN] ;B _ FIRST OF SAVE BLOCK
2198 SUB B,D ;B _ FIRST OF ARGS
2200 PUSH PP,(B) ;MOVE NEXT
2205 ADD B,[FRAMLN,,FRAMLN] ;B _ TB ADDRESS
2207 NOARGS: TRNN A,TUP ;ANY OTHER TUPLES?
2209 MVTUPS: ADD C,[FRAMLN-1,,FRAMLN-1] ;C _ PP TB SLOT
2210 SUB E,[1,,1] ;E _ TFIX SLOT ADDRESS
2211 MTOLP: CAML C,E ;C REACHED E?
2212 JRST MTDON ;YES-- ALL TUPLES FOUND
2215 CAIE A,TTBS ;LOOK FOR TUPLE
2217 HRRE D,(C) ;D _ NO. OF ELEMENTS
2218 MTILP: JUMPGE D,ARND22
2225 ARND22: ADD B,[2,,2] ;ADVANCE IN STEP
2230 SUBI C,1(E) ;C _ NO. OF THINGS MOVED
2232 PUSH PP,[TFIX,,TUP] ;MARK AS TUPLE CRUFT
2235 RMARK: MOVE E,OTBSAV(TB) ;SAVE PREVIOUS FRAME
2244 MOVSI B,TFIX ;RESTORE B TYPE
2247 ;BCKTRE SAVE CONTENTS OF FRAME E OF TP ON PLANNER PDL
2249 BCKTRE: MOVSI A,TPDL ;FOR AGC
2256 ;MOVE P BLOCK OF PREVIOUS FRAME TO PP
2258 MOVE C,PSAV(E) ;C _ LAST OF P "FRAME"
2260 MOVE A,PSAV(A) ;A _ LAST OF PREVIOUS P "FRAME"
2262 MVPB: CAMLE A,C ;IF BLOCK EMPTY,
2263 JRST MVTPB ;DO NOTHING
2265 SUBI D,-1(A) ;ELSE, SET COUNTER
2266 PUSH PP,$TPDLS ;MARK BLOCK
2276 PUSH PP,[0] ;PUSH BLOCK COUNTER
2278 ;NOW DO SIMILAR THING FOR TP
2279 MVTPB: MOVSI A,TTP ;FOR AGC
2281 MOVE C,TPSAV(E) ;C POINT TO LAST OF BLOCK
2282 PUSH TP,$TPP ;SAVE INITIAL PP
2283 PUSH TP,PP ;FOR SUBTRACTION
2284 HRRZ A,E ;A _ TPIFIED E
2292 .VALUE [ASCIZ /TPFUCKED/]
2293 ;MOVE THE SAVE BLOCK
2295 MSVBLK: MOVSI D,TENTS ;MAKE TYPE TENTS
2298 HLLZ D,OTBSAV(E) ;RELATIVIZE OTB AND AB POINTERS
2307 MOVEI 0, ;0 _ 0 (NO TUPLES)
2314 PUSH PP,(A) ;NO, JUST MOVE IT
2318 MRKFIX: HRRZ C,(TP) ;C _ PREVIOUS PP POINTER
2320 HRRZ D,PP ;D _ CURRENT PP TOP
2321 SUBI D,(C) ;D _ DIFFERENCE
2323 PUSH PP,$TFIX ;PUSH BLOCK COUNTER
2327 ;NOW SAVE LOCATION OF THIS FRAME
2334 ADD E,B ;CONVERSION TO TTP
2336 TRO 0,SAV ;PUSH A TTP MARKER WITH SAV & MAYBE TUP ON
2348 ;RELATIVIZE A TB POINTER
2350 MVTB: HRRE D,(A) ;D _ - LENGTH OF TUPLE
2352 HRLS D ;D _ LENGTH,,LENGTH
2353 SUB PP,D ;THROW TUPLE AWAY!!!
2362 \fMFUNCTION FAIL,SUBR
2364 ;SINCE FAILURES ARE NOT INTERRUPTIBLE FOR ANYTHING BUT GARBAGE
2365 ;COLLECTIONS, THE FOLLOWING MACRO REPLACES INTGO FOR STACK-BUILDING
2377 CAILE A,4 ;AT MOST 2 ARGS
2379 CAIGE A,2 ;IF FIRST ARG NOT GIVEN,
2380 JRST MFALS ;ASSUME <>
2381 MOVE B,(AB) ;OTHERWISE, FIRST ARG IS MESSAGE
2386 CAIE A,4 ;PLACE TO FAIL TO GIVEN?
2389 CAIE A,TACT ;CAN ONLY FAIL TO AN ACTIVATION
2391 SAVACT: MOVE B,2(AB) ;TRANSMIT ACTIVATION TO FAILPOINT
2392 MOVEM B,FACTI(PVP) ;VIA PVP
2394 MOVEM B,FACTI+1(PVP)
2395 ;NOW REBUILD TP FROM PP
2396 IFAIL: SETOM FLFLG ;FLFLG _ ON
2397 HRRZ A,(PP) ;GET FRAME TO NESTLE IN
2399 HRRZ 0,-1(PP) ;0 _ SWITCHES FOR FRAME
2402 GETYP B,FACTI(PVP) ;IF FALSE ACTIVATION,
2403 CAIN B,TFALSE ;JUST GO TO FRAME
2405 HRRZI B,(TB) ;OTHERWISE, CHECK TO SEE IF WE ARE LEAVING
2407 ALOOP: CAIN B,(A) ; FRAME FACTI(PVP)
2408 JRST POPFS ;NO-- IT'S ABOVE FAILPOINT (A)
2409 CAIN B,(D) ;FOUND FACTI?
2410 JRST AFALS2 ;YES-- CLOBBER FACTI TO #FALSE()
2411 HRRZ B,OTBSAV(B) ;NO-- KEEP LOOKING
2413 AFALS2: MOVSI B,TFALSE ;SET IT TO FALSE FROM HERE ON
2415 SETZB D,FACTI+1(PVP)
2416 POPFS: HRR TB,A ;MAY TAKE MORE WORK
2417 RSTFRM: MOVE P,PSAV(TB)
2426 ;MOVE A TP BLOCK FROM PP TO TP
2431 SUB A,(PP) ;A POINTS TO BOTTOM OF BLOCK
2432 TRNN 0,ON ;"ON" BLOCK?
2434 ONBLK: CAME SP,SPSAV(TB) ;YES-- FIX UP ENVIRONMENT
2437 HRRZ 0,-1(PP) ;ANY TUPLES?
2439 JRST USVBLK ;NO-- GO MOVE SAVE BLOCK
2440 SUB A,[2,,2] ;A _ BLOCK UNDER THIS ONE
2444 CAIE B,TENTS ;LOOK IN SAVE BLOCK
2446 HLRE D,FRAMLN+ABSAV-1(A)
2449 ;MOVE SAVE BLOCK BACK TO TP
2451 USVBLK: ADD A,[FRAMLN,,FRAMLN]
2455 MOVEI AB,(TP) ;REGENERATE AB & OTBSAV
2471 PSHLP4: CAML TP,TPSAV(TB)
2475 CAIN B,TTBS ;FOUND A TUPLE?
2477 PUSH TP,-1(A) ;NO-- JUST MOVE IT
2479 ARND12: ADD A,[2,,2] ;BUMP POINTER
2483 MOVE D,-1(A) ;UNRELATIVIZE A TTB
2490 USTPDN: MOVE 0,-1(PP) ;IF TUPLES,
2493 SUB PP,(PP) ;SKIP OVER TUPLE DEBRIS
2495 USTPD3: CAME TP,TPSAV(TB) ;BETTER HAVE WORKED
2497 CAMN SP,SPSAV(TB) ;PLEASE GOD, NO MORE BINDINGS
2498 JRST USV2 ;PRAYER CAN MOVE MOUNTAINS
2499 MOVEI E, ;E _ 0 = INITIAL LOWER BIND BLOCK
2500 MOVE C,SPSAV(TB) ;C _ SPSAV = INITIAL UPPER BLOCK
2502 ;REBIND EVERYTHING IN THIS FRAME-- FIRST, FIND THE TOPMOST BLOCK,
2503 ;SINCE THEY MUST BE REBOUND IN THE ORDER BOUND
2506 CAIE D,TBIND ;C POINTS TO BIND BLOCK?
2508 ADD C,[5,,5] ;YES-- C _ ADDRESS OF ITS LAST WORD
2509 MOVEM E,(C) ;(C) _ E = LOWER BIND POINTER
2511 SKIPA D,-5(C) ;FIND REBIND POINTER
2512 BLOOP5: HRRZ D,(D) ;D _ NEXT BIND BLOCK
2514 CAIE 0,TSP ;LOOK FOR REBINDER
2516 MOVE C,1(D) ;C _ REBIND BLOCK
2518 SPLBLK: GETYP D,2(C)
2521 ADD C,[1,,1] ;C _ REBIND POINTER ADDRESS
2522 MOVE D,(C) ;D _ HIGHER BLOCK
2523 MOVEM E,(C) ;(C) _ E
2525 MOVE C,D ;C _ D = HIGHER BIND BLOCK
2526 JBVEC3: CAME SP,C ;GOT TO SP YET?
2530 ;NOW REBIND EVERYTHING, RESET PROCID'S PROPERLY, ETC.;
2531 ;THIS MUST BE DONE IN PROPER ORDER, FROM TOPMOST BLOCK DOWN
2533 BLOOP2: HLRZ D,-1(E) ;WHAT DOES E POINT TO?
2535 JUMPN D,TUGSP ;IF NON-ZERO, MUST BE REBIND SLOT
2536 PUSHJ P,EBIND ;OTHERWISE, BIND BLOCK TO BE REBOUND
2538 TUGSP: MOVEM SP,(E) ;RECONNECT UPPER BLOCK
2543 SUB SP,[1,,1] ;TUG SP DOWN
2544 CAIE 0,TSP ;ID SWAP?
2546 MOVE 0,PROCID+1(PVP)
2548 MOVEM 0,PROCID+1(PVP)
2549 DOWNBL: POP P,E ;E _ LOWER BLOCK
2552 RBDON: CAME SP,SPSAV(TB) ;ALL THAT BETTER HAVE WORKED
2556 ;RESTORE A BLOCK "INTO" TB
2558 INBLK: ADD A,[FRAMLN,,FRAMLN]
2563 BLT C,-1(TB) ;RESTORE ALL OF SAVE BLOCK BUT FSAV,
2564 MOVEI C,-1(TB) ; OTBSAV, AND ABSAV
2570 ADD C,D ;C _ "-1(TB)"TPIFIED
2573 GETYP B,-1(A) ;GOT TUPLE?
2575 JRST SKTUPL ;YES-- SKIP IT
2579 MOVE TP,C ;PROTECT STACK FROM GARBAGE COLLECTION
2583 SKTUPL: HRRE D,-1(A) ;D _ - LENGTH OF TUPLE
2587 ADD C,[2,,2] ;AND DON'T FORGET TTB
2589 TPDON: MOVE TP,C ;IN CASE TP TOO BIG
2590 CAME TP,TPSAV(TB) ;CHECK THAT INBLK WORKED
2592 MOVE C,OTBSAV(TB) ;RESTORE P STARTING FROM PREVIOUS
2593 MOVE P,PSAV(C) ;FRAME
2595 ;MOVE A P BLOCK BACK TO P
2600 SUB PP,[2,,2] ;NOW BACK BEYOND TP BLOCK
2602 CAIE A,TFIX ;GET P BLOCK...
2603 JRST CHPC2 ;...IF ANY
2605 SUB A,(PP) ;A POINTS TO FIRST
2606 PSHLP5: PUSH P,-1(A) ;MOVE BLOCK
2612 SUB PP,[3,,3] ;NOW AT NEXT PP "FRAME"
2614 CHPC2: CAME P,PSAV(TB) ;MAKE SURE P RESTORED OKAY
2620 ;FRAME IS ALREADY ON THE STACK--- BINDINGS ONLY HASSLE
2622 MHFRAM: MOVE AB,ABSAV(TB) ;RESTORE ARGS POINTER
2623 CAME SP,SPSAV(TB) ;AND ENVIRONMENT
2627 SETZM FLFLG ;FLFLG _ OFF
2628 INTGO ;HANDLE POSTPONED INTERRUPTS
2632 ;HERE TO PUSH TUPLE STARTING AT (C), OF LENGTH -D
2643 ;DEFAULT MESSAGE IS <>
2645 MFALS: MOVSI B,TFALSE ;TYPE FALSE
2650 ;DEFAULT ACTIVATION IS <>, ALSO
2651 AFALS1: MOVSI B,TFALSE
2653 \r SETZM FACTI+1(PVP)
2656 ;FALSE IS ALLOWED EXPLICITLY
2658 TAFALS: CAIE A,TFALSE
2663 ;FLAG FOR INTERRUPT SYSTEM
2671 SUBI E,-PDLBUF-1(P) ;E _ ADR OF REAL 2ND DOPE WORD
2673 JRST PDLOSS ;SORRY, ONLY ONE GROWTH PER FAMILY
2674 HRRM E,PGROW ;SET PGROW
2679 NBLOTP: HRRZ E,TP ;MORE OR LESS THE SAME
2681 SUBI E,-PDLBUF-1(TP)
2685 NBLO2: MOVEI B,PDLGRO_-6
2686 DPB B,[111100,,-1(E)]
2688 \fMFUNCTION FINALIZE,SUBR,[FINALIZE]
2690 SKIPL AB ;IF NOARGS;
2691 JRST GETTOP ;FINALIZE ALL FAILPOINTS
2692 HLRE A,AB ;AT MOST ONE ARG
2695 PUSHJ P,TILLFM ;MAKE SURE ARG IS LEGAL
2696 HRR B,OTBSAV(B) ;B _ FRAME BEFORE ACTIVATION
2697 RESTPP: MOVE PP,PPSAV(B) ;RESTORE PP
2698 HRRZ A,TB ;IN EVERY FRAME
2699 FLOOP: CAIN A,(B) ;FOR EACH ONE,
2704 FDONE: MOVE A,$TFALSE
2708 ;TILLFM SETS B _ FIRST ARGUMENT IFF IT IS A LEGAL ACTIVATION
2710 TILLFM: HLRZ A,(AB) ;FIRST ARG MUST BE ACTIVATION
2713 MOVE A,1(AB) ;WITH RIGHT TIME
2720 GETYP C,FSAV(C) ;AND STRUCTURE
2726 ;LET B BE TOP LEVEL FRAME
2728 GETTOP: MOVE B,TPBASE+1(PVP) ;B _ BOTTOM OF TP
2729 MOVEI B,FRAMLN+1(B) ;B _ TOP LEVEL FRAME
2730 JRST RESTPP
\fMFUNCTION FAILPOINT,FSUBR,[FAILPOINT]
2732 GETYP A,(AB) ;ARGUMENT MUST BE LIST
2735 SKIPN C,1(AB) ;NON-NIL
2737 PUSH TP,$TLIST ;SLOT FOR BODY
2742 PUSH TP,TP ;SAVE SLOT FOR PRE-(MESS ACT) ENV
2743 MOVE C,1(AB) ;GET SET TO CALL BINDER
2745 PUSH P,[AUX] ;---AS A PROG
2746 PUSHJ P,BINDEV ;AND GO
2747 HRRZ C,1(AB) ;SKIP OVER THINGS BOUND
2748 TRNE A,H ;INCLUDING HEWITT ATOM IF THERE
2751 HRRZ C,(C) ;C _ (EXPR (MESS ACT) -FAIL-BODY-)
2753 HRRZ A,(C) ;A _ ((MESS ACT) -FAIL-BODY-)
2757 PUSH PP,$TPC ;ESTABLISH FAIL POINT
2759 PUSH PP,[TTP,,COP\ON]
2760 PUSH PP,A ;SAVE LOCATION OF THIS FRAME
2765 MCALL 1,EVAL ;EVALUATE EXPR
2766 JRST FINIS ;IF SUCCESSFUL, DO NORMAL FINIS
2768 ;FAIL TO HERE--BIND MESSAGE AND ACTIVATION
2770 FP: MOVEM SP,5(TB) ;SAVE SP BEFORE MESS AND ACT BOUND
2771 HRRZ A,3(TB) ;A _ ((MESS ACT) -BODY-)
2776 HRRZ A,1(A) ;C _ (MESS ACT)
2777 JUMPE A,TFMESS ;IF (), THINGS MUST BE <>
2778 PUSHJ P,NXTDCL ;CHECK FOR "STACK"
2781 CAME B,[ASCII /STACK/]
2783 TRO 0,STC ;FOUND, TURN ON STC SWITCH
2785 JUMPE C,TFMESS ;IF ONLY "STACK", MUST HAVE FALSE MESSAGE
2786 NOSTAC: PUSHJ P,CARATM ;E _ MESS
2788 PUSH TP,BNDA ;ELSE BIND IT
2794 HRRZ C,(C) ;C _ (ACT)
2795 JUMPE C,TFACT ;IF (), ACT MUST BE <>
2796 PUSHJ P,CARATM ;E _ ACT
2798 PUSH TP,BNDA ;BIND IT
2801 PUSH TP,FACTI+1(PVP)
2805 TFMESS: GETYP A,MESS(PVP)
2808 TFACT: GETYP A,FACTI(PVP)
2813 ;THIS ROUTINE SETS E TO THE NEXT THING IN THE LIST C POINTS TO,
2814 ;SKIPPING IFF IT IS AN ATOM
2824 MFUNCTION RESTORE,SUBR,[RESTORE]
2829 CAIG A,4 ;1 OR 2 ARGUMENTS
2832 PUSHJ P,TILLFM ;B _ FRAME TO RESTORE (IF LEGAL)
2834 CAIE C,FAILPO ;ONLY FAILPOINTS RESTORABLE
2836 PUSHJ P,SAVE ;RESTORE IT
2837 SKIPN D,5(TB) ;ARE WE IN EXPR INSTEAD OF BODY?
2838 JRST EXIT2 ;YES-- EXIT
2840 PUSHJ P,SPECSTO ;UNBIND MESS AND ACT
2851 ADD E,B ;CONVERSION TO TTP
2852 PUSH PP,[TTP,,COP\ON] ;REESTABLISH FAILPOINT
2856 CAIN C,4 ;VALUE GIVEN?
2857 JRST RETRG2 ;YES-- RETURN IT
2858 MOVE AB,ABSAV(TB) ;IN CASE OF GARBAGE COLLECTION
2861 ;ERROR COMMENTS FOR EVAL
2863 UNBOU: PUSH TP,$TATOM
2864 PUSH TP,MQUOTE UNBOUND-VARIABLE
2867 UNAS: PUSH TP,$TATOM
2868 PUSH TP,MQUOTE UNASSIGNED-VARIABLE
2872 ERRTFA: PUSH TP,$TATOM
2873 PUSH TP,MQUOTE TOO-FEW-ARGUMENTS-SUPPLIED
2877 ERRTMA: PUSH TP,$TATOM
2878 PUSH TP,MQUOTE TOO-MANY-ARGUMENTS-SUPPLIED
2883 PUSH TP,MQUOTE BAD-ENVIRONMENT
2888 PUSH TP,MQUOTE BAD-FUNARG
2892 WTYP: PUSH TP,$TATOM
2893 PUSH TP,MQUOTE WRONG-TYPE
2897 PUSH TP,MQUOTE MEANINGLESS-PARAMETER-DECLARATION
2900 NOBODY: PUSH TP,$TATOM
2901 PUSH TP,MQUOTE HAS-EMPTY-BODY
2904 BADCLS: PUSH TP,$TATOM
2905 PUSH TP,MQUOTE BAD-CLAUSE
2908 NXTAG: PUSH TP,$TATOM
2909 PUSH TP,MQUOTE NON-EXISTENT-TAG
2912 NXPRG: PUSH TP,$TATOM
2913 PUSH TP,MQUOTE NOT-IN-PROG
2916 NAPT: PUSH TP,$TATOM
2917 PUSH TP,MQUOTE NON-APPLICABLE-TYPE
2920 NONEVT: PUSH TP,$TATOM
2921 PUSH TP,MQUOTE NON-EVALUATEABLE-TYPE
2925 NONATM: PUSH TP,$TATOM
2926 PUSH TP,MQUOTE NON-ATOMIC-ARGUMENT
2930 ILLFRA: PUSH TP,$TATOM
2931 PUSH TP,MQUOTE FRAME-NO-LONGER-EXISTS
2934 NOTIMP: PUSH TP,$TATOM
2935 PUSH TP,MQUOTE NOT-YET-IMPLEMENTED
2938 ILLSEG: PUSH TP,$TATOM
2939 PUSH TP,MQUOTE ILLEGAL-SEGMENT
2942 BADPP: PUSH TP,$TATOM
2943 PUSH TP,MQUOTE PP-IN-ILLEGAL-CONFIGURATION
2947 BDFAIL: PUSH TP,$TATOM
2948 PUSH TP,MQUOTE OVERPOP--FAIL
2952 ER1ARG: PUSH TP,(AB)