1 TITLE EVAL -- MUDDLE EVALUATOR
5 ; GERALD JAY SUSSMAN, 1971
7 .GLOBAL PROCID,LPROG,GLOBSP,GLOBASE,SPBASE,TPBASE,PTIME
8 .GLOBAL IGVAL,CHKARG,SWAP,NXTDCL,TPOVFL,CHFRM
9 .GLOBAL ILVAL,CALER,CALER1,ER1ARG,SPECBIND,SPECSTORE,WRONGT,ERRTMA
10 .GLOBAL IDVAL,EVECTO,EUVECT,CHARGS
16 HLRZ A,AB ;GET NUMBER OF ARGS
18 JRST AEVAL ;EVAL WITH AN ALIST
19 HLRZ A,(AB) ;GET TYPE OF ARG
20 CAILE A,NUMPRI ;PRIMITIVE?
22 JRST @EVTYPT(A) ;YES-DISPATCH
24 SELF: MOVE A,(AB) ;TYPES WHICH EVALUATE
26 JRST FINIS ;TO SELF-EG NUMBERS
28 ;EVALUATES A IDENTIFIER -- GETS LOCAL VALUE IF THERE IS ONE, OTHERWISE GLOBAL.
36 PUSH TP,B ;SAVE ARG IN CASE NEED TO CHECK GLOBAL VALUE PUSHJ P,ILVAL ;LOCAL VALUE FINDER
37 CAME A,$TUNBOUND ;IF NOT UNBOUND OR UNASSIGNED
38 JRST RIDVAL ;DONE - CLEAN UP AND RETURN
39 JUMPN B,UNAS ;IF UNASSIGNED - ERROR
40 POP TP,B ;GET ARG BACK
50 ;GETS THE LOCAL VALUE OF AN IDENTIFIER
61 ; GETS A LOCATIVE TO THE LOCAL VALUE OF AN IDENTIFIER.
72 ;TESTS TO SEE IF AN IDENTIFIER IS LOCALLY BOUND
74 MFUNCTION BOUND,SUBR,[BOUND?]
81 ;TESTS TO SEE IF AN IDENTIFIER IS LOCALLY ASSIGNED
83 MFUNCTION ASSIGP,SUBR,[ASSIGNED?]
91 ;GETS THE GLOBAL VALUE OF AN IDENTIFIER
100 ;GETS A LOCATIVE TO THE GLOBAL VALUE OF AN IDENTIFIER
110 ;TESTS TO SEE IF AN IDENTIFIER IS GLOBALLY ASSIGNED
112 MFUNCTION GASSIG,SUBR,[GASSIGNED?]
128 ;EVALUATE A FORM. IF CAR IS AN ATOM USE GLOBAL VALUE OVER LOCAL ONE.
130 EVFORM: SKIPN C,1(AB) ;EMPTY?
132 HLLZ A,(C) ;GET CAR TYPE
133 CAME A, $TATOM ;ATOMIC?
134 JRST EV0 ;NO -- CALCULATE IT
135 MOVE B,1(C) ;GET PTR TO ATOM
141 JRST IAPPLY ;APPLY IT
142 EV0: PUSH TP,A ;SET UP CAR OF FORM AND
145 MCALL 1,EVAL ;EVALUATE IT
146 PUSH TP,A ;APPLY THE RESULT
147 PUSH TP,B ;AS A FUNCTION
158 ;DISPATCH TABLE FOR EVAL
159 DISTBL EVTYPT,SELF,[[TLIST,EVLIST],[TFORM,EVFORM],[TVEC,EVECT],[TSEG,ILLSEG],[TUVEC,EUVEC]]
163 ;WATCH FOR SUBTLE BUG 43 LERR,LPROG OR PROCID
165 CAIE A,-4 ;EXACTLY 2 ARGS?
167 HLRZ A,2(AB) ;CHECK THAT WE HAVE A FRAME
173 HRRZ D,2(AB) ;GET POINTER TO PV DOPE WORD
174 PUSHJ P,SWAPQ ;SEE IF SWAP NECESSARY
177 MCALL 1,EVAL ;NOW DO NORMAL EVALUATION
178 UNSWPQ: MOVE D,1(TB) ;GET SAVED PVP
180 JRST FINIS ;NO - RETURNĂ® PUSHJ P,SPECSTORE ;CLEAN UP
186 ; ROUTINE TO CHANGE PROCID AND POSSIBLY SWAP
188 SWAPQ: HLRZ C,(D) ;GET LENGTH
189 SUBI D,-1(C) ;POINT TO START OF PV
190 MOVNS C ;NEGATE LENGTH
191 HRLI D,2(C) ;MAKE AOBJN POINTER
192 MOVE E,PVP ;COPY CURRENT PROCESS VECTOR
193 POP P,B ;GET RET ADR SO POPJ WINS IF SWAP OCCURS
194 CAME D,PVP ;IS THIS IT?
195 JSP C,SWAP ;NO, SWAP IN NEW PROCESS
196 PUSH P,B ;NOW, PUT IT BACK
197 PUSH TP,$TPVP ;SAVE PROCESS
199 HLL B,OTBSAV(A) ;GET TIME FROM FRAME POINTED AT
203 CAME B,A ;CHECK THAT THE FRAME IS LEGIT
210 MOVE SP,SPSAV(A) ;LOAD UP OLD ENVIRONMENT
212 ADD A,[PROCID,,PROCID] ;GET LOCATIVE TO PROCESS ID
213 PUSH TP,BNDV ;BIND IT TO
215 AOSN A,PTIME ;A UNIQUE NUMBER
216 .VALUE [ASCIZ /TIMEOUT/]
220 AEV1: MOVE E,1(TB) ;GET SAVED PROCESS
221 MOVE D,AB ;COPY CURRENT ARG POINTER
222 CAME E,PVP ;HAS PROCESS CHANGED?
223 MOVE D,ABSTO+1(E) ;GET SAV AB
224 POPJ P, ;RETURN TO CALLER
227 ; STACKFRAME FUNCTION (MUDDLE'S ANSWER TO APPLY)
231 STFRM2: JRST NOENV ;FAKE OUT ENTRY
233 MFUNCTION STACKFORM,FSUBR
237 GETYP A,(AB) ;CHECK IT IS A LIST
241 MOVEI A,3 ;CHECK ARG HAS AT LEAST 3 ELEMENTS
242 HRRZ B,1(AB) ;GET ARG
245 SOJN A,.-2 ;AND COUNT
247 JUMPE B,NOENV ;ENVIRONMENT NOT SUPPLIED
248 HRRZ A,(B) ;CHECK NOT TOO MANY
251 GETYP A,(B) ;GET TYPE OF LAST ARG
252 MOVSI A,(A) ;TYPE TO LH
254 PUSH TP,1(B) ;PUSH THE ARG
255 JSP E,CHKARG ;CHECK FOR DEFERRED
257 HLRZ C,A ;ISOLATE TYPE IN C
258 CAIE C,TENV ;ENVIRONEMNT?
259 CAIN C,TFRAME ;OR FRAME?
264 MOVEI D,(A) ;IN B AND D
265 MOVE A,B ;AND TIME,,FRAME
266 PUSHJ P,SWAPQ ;AND CHECK FOR CHANGE
267 PUSH TP,$TLIST ;SAVE THE ARG
269 .MCALL 1,STFRM2 ;NOW CALL NON-ENV STACKFORM
270 JRST UNSWPQ ;AND POSSIBLY UNSWAP
272 NOENV: HRRZ D,1(AB) ;GET POINTER TO FIRST
273 GETYP A,(D) ;GET TYPE
276 PUSH TP,1(D) ;PUSH THE ARG, (IT SHOULD BE A FUNCTION)
277 JSP E,CHKARG ;CHECK OUT DEFERRED
278 MCALL 1,EVAL ;EVAL IT
279 HRRZ C,1(AB) ;RESTORE ARG
280 HRRZ D,(C) ;POINT TO LIST OF FORMS
281 PUSH TP,A ;SAVE FUNCTION
283 HLRZS A ;NOW DISPATCH ON TYPE
285 JRST STSUBR ;YES, HACK IT
286 CAIN A,TEXPR ;FUNCTION?
287 JRST STEXPR ;YES DO IT
288 CAIN A,TFUNARG ;FUNARG
293 ; STACK FORM OF A SUBR
295 STSUBR: PUSH P,[0] ;PUSH ARG COUNTER
297 STLOO: PUSHJ P,EVALRG ;EVAL THE ARGUMENT
298 JRST MAKPTR ;DONE, FALL INTO EVAL CODE
301 PUSH TP,B ;SAVE THE ARGS
304 ; STACK FRAME OF EXPR
306 STEXPR: MOVE C,(TP) ;GET FUNCTION
307 PUSHJ P,BINDRS ;BIND THE ARGS
308 JRST APEXP1 ;JOIN COMMON CODE
313 HLRZ A,(TB) ;GET TYPE OF FUNCTION
316 CAIN A,TFSUBR ;NO -- FSUBR?
318 CAIN A,TEXPR ;NO -- EXPR?
320 CAIN A,TFIX ;NO -- CALL TO NTH?
322 CAIN A,TFUNARG ;NO -- FUNARG?
324 CAIN A,TPVP ;NO -- PROCESS TO BE RESUMED?
326 JRST NAPT ;NONE OF THE ABOVE
329 ;APFSUBR CALLS FSUBRS
332 PUSH TP,$TLIST ;GET THE
334 PUSH TP,A ;ARGUMENT LIST
341 HRRZ A,@1(AB) ;GET CDR OF FORM -- ARGLIST
342 PUSH TP,$TLIST ;SAVE THE ARGLIST ON
344 PUSH P,[0] ;MAKE SLOT FOR ARGCNT
346 SKIPN A,3(TB) ;IS IT NIL?
347 JRST MAKPTR ;YES -- DONE
348 PUSH TP,(A) ;NO -- GET CAR OF THE
352 MCALL 1,EVAL ;AND EVAL IT.
353 PUSH TP,A ;SAVE THE RESULT IN
354 PUSH TP,B ;THE GROWING TUPLE
355 AOS (P) ;BUMP THE ARGCNT
356 HRRZ A,@3(TB) ;SET THE ARGLIST TO
357 MOVEM A,3(TB) ;CDR OF THE ARGLIST
366 ;APNUM INTERPRETS NUMBERS AS CALL TO FUNCTION GET
369 HRRZ A,@1(AB) ;GET ARGLIST
370 JUMPE A,ERRTFA ;NO ARGUMENT
371 PUSH TP,(A) ;GET CAR OF ARGL
374 HRRZ A,(A) ;MAKE SURE ONLY ONE ARG
376 JSP E,CHKARG ;HACK DEFERRED
385 ;APEXPR APPLIES EXPRS
386 ;EXPRESSION IS IN 0(AB), FUNCTION IS IN 0(TB)
391 JRST NOBODY ;NO, ERROR
392 HRRZ 0,1(AB) ;GET EXPRESSION INTO 0
393 HRRZ D,@0 ;AND ARGLIST INTO D
394 HLL 0,(AB) ;TYPE TO LH OF 0
396 PUSHJ P,BINDER ;DO THE BINDINGS
398 APEXP1: HRRZ C,@1(TB) ;GET BODY BACK
399 JUMPE A,DOPROG ;NOW GO RUN IF NO ACTIVIATION
400 PUSH TP,$TLIST ;SAVE ANOTHER COPY FOR REACT
402 SKIPL A ;SKIP IF NOT NAME ALA HEWITT
403 HRRZ C,(C) ;ELSE CDR AGAIN
409 ; 0,1(TB) IS PROCESS VECTOR POINTER TO PROCESS TO BE RESUMED
410 ; 0,1(AB) IS A FORM CONTAINING ARGS TO SAVED FUNTION
412 MOVE D,1(TB) ;GET PVP OF PROCESS TO BE RESUMED
413 GETYP A,RESFUN(D) ; GET TYPE OF FUNCTION
417 CAIN A,TFSUBR ;NO -- FSUBR?
419 CAIN A,TEXPR ;NO -- EXPR?
421 CAIN A,TFIX ;NO -- CALL TO NTH?
423 CAIN A,TFUNARG ;NO -- FUNARG?
425 JRST NAPT ;NONE OF THE ABOVE
428 ;RESFSUBR RESUMES FSUBRS
431 HRRZ A,@1(AB) ;GET THE ARG LIST
432 SUB TP,[2,,2] ;CLEAN UP
433 JSP C,SWAP ;SWAP IN NEW PROCESS
435 PUSH TP,A ; PUSH THE ARG LIST
436 MCALL 1,@RESFUN+1(PVP) ; RESUME WITH THE SAVED FUNCTION
439 ;RESSUBR RESUMES SUBRS
442 HRRZ A,@1(AB) ;GET CDR OF FORM -- ARGLIST
443 PUSH TP,$TLIST ;SAVE THE ARGLIST ON
445 PUSH P,[0] ;MAKE SLOT FOR ARGCNT
447 SKIPN A,3(TB) ;IS IT NIL?
448 JRST RESMAKPTR ;YES -- DONE
449 PUSH TP,(A) ;NO -- GET CAR OF THE
453 MCALL 1,EVAL ;AND EVAL IT.
454 MOVE D,1(TB) ;GET PVP OF P.T.B.R.
455 MOVE C,TPSTO+1(D) ;GET TP OF P.T.B.R.
456 PUSH C,A ;SAVE THE RESULT IN THE GROWING
457 PUSH C,B ;TUPLE OF ARGS IN P.T.B.R.
458 MOVEM C,TPSTO+1(D) ;UPDATE TP OF P.T.B.R.
459 AOS (P) ;BUMP THE ARGCNT
460 HRRZ A,@3(TB) ;SET THE ARGLIST TO
461 MOVEM A,3(TB) ;CDR OF THE ARGLIST
464 POP P,A ;GET NUMBER OF ARGS IN A
465 MOVE D,1(TB) ;GET PVP OF P.T.B.R.
466 SUB TP,[4,,4] ;GET RID OF GARBAGE
467 JSP C,SWAP ;SWAP IN THE NEW PROCESS
468 ACALL A,RESFUN+1(PVP) ;CALL THE SAVED FUNCTION
473 ;RESNUM INTERPRETS NUMBERS AS CALL TO FUNCTION GET
476 HRRZ A,@1(AB) ;GET ARGLIST
477 JUMPE A,ERRTFA ;NO ARGUMENT
478 PUSH TP,(A) ;GET CAR OF ARGL
481 HRRZ A,(A) ;MAKE SURE ONLY ONE ARG
483 JSP E,CHKARG ;HACK DEFERRED
485 MOVE D,1(TB) ;GET PVP OF P.T.B.R.
486 MOVE C,TPSTO+1(D) ;GET TP OF P.T.B.R.
489 SUB TP,[2,,2] ;CLEAN UP BEFORE LEAVING
490 JSP C,SWAP ;BRING IN NEW PROCESS
491 PUSH TP,RESFUN(PVP) ;PUSH NUMBER
492 PUSH TP,RESFUN+1(PVP)
496 ;RESEXPR RESUMES EXPRS
497 ;EXPRESSION IS IN 0(AB), FUNCTION IS IN RESFUN(PVP)
499 SKIPN C,RESFUN+1(D);BODY?
500 JRST NOBODY ;NO, ERROR
502 MOVE C,TPSTO+1(D) ;GET TP OF P.T.B.R.
503 PUSH C,BNDA ;SPECIAL ATOM CROCK
504 PUSH C,MQUOTE [PPROC ]INTERR ;PPROC=PARENT PROCESS
506 PUSHJ P,MAKENV ;MAKE ENVIRONMENT FOR THIS PROCESS
509 MOVEM C,TPSTO+1(D) ;UPDATE TP OF P.T.B.R.
510 HRRZ 0,1(AB) ;GET EXPRESSION INTO 0
511 HRRZ A,@0 ;AND ARGLIST INTO A
512 HLL 0,(AB) ;TYPE TO LH OF 0
513 SUB TP,[2,,2] ;CLEAN UP BEFORE LEAVING
514 JSP C,SWAP ;SWAP IN NEW PROCESS
516 PUSH P,A ;SAVE A=ARGLIST
518 PUSH TP,[0] ;COMPLETE ARGS FOR PPROC BINDING
519 PUSHJ P,SPECBIND ;BIND THE PARENT PROCESS
520 POP P,D ;POP ARGLIST INTO D
521 POP P,0 ;POP CALL HACK INTO 0
522 MOVE C,RESFUN+1(PVP) ;GET FUNCTION
523 PUSHJ P,BINDRR ;CALL BINDER FOR RESUMED EXPR HACKING
525 HRRZ C,@RESFUN+1(PVP) ;GET BODY BACK
526 JUMPE A,DOPROG ;NOW GO RUN IF NO ACTIVIATION
527 PUSH TP,$TLIST ;SAVE ANOTHER COPY FOR REACT
529 SKIPL A ;SKIP IF NOT NAME ALA HEWITT
530 HRRZ C,(C) ;ELSE CDR AGAIN
534 ; EVALUATE LISTS, VECTORS, UNIFROM VECTORS
536 EVLIST: PUSH P,[-1] ;-1 -- THIS IS A LIST
537 JRST EVL1 ;GO TO HACKER
539 EVECT: PUSH P,[0] ;0 -- THIS IS A GENERAL VECTOR
542 EUVEC: PUSH P,[1] ;1 -- THIS IS A UNIFORM VECTOR
544 EVL1: PUSH P,[0] ;PUSH A COUNTER
545 GETYPF A,(AB) ;GET FULL TYPE
547 PUSH TP,1(AB) ;AND VALUE
549 EVL2: INTGO ;CHECK INTERRUPTS
550 SKIPN A,1(TB) ;ANYMORE
552 SKIPL -1(P) ;SKIP IF LIST
553 JUMPG A,EVL3 ;JUMP IF VECTOR EMPTY
554 GETYPF B,(A) ;GET FULL TYPE
555 SKIPGE C,-1(P) ;SKIP IF NOT LIST
556 HLLZS B ;CLOBBER CDR FIELD
557 JUMPG C,EVL7 ;HACK UNIFORM VECS
558 EVL8: PUSH P,B ;SAVE TYPE WORD ON P
559 CAMN B,$TSEG ;SEGMENT?
560 MOVSI B,TFORM ;FAKE OUT EVAL
562 PUSH TP,1(A) ;AND VALUE
563 MCALL 1,EVAL ;AND EVAL IT
564 POP P,C ;AND RESTORE REAL TYPE
565 CAMN C,$TSEG ;SEGMENT?
566 JRST DOSEG ;YES, HACK IT
567 AOS (P) ;COUNT ELEMENT
568 PUSH TP,A ;AND PUSH IT
570 EVL6: SKIPGE A,-1(P) ;DONT SKIP IF LIST
571 HRRZ B,@1(TB) ;CDR IT
572 JUMPL A,ASTOTB ;AND STORE IT
573 MOVE B,1(TB) ;GET VECTOR POINTER
574 ADD B,AMNT(A) ;INCR BY APPROPRIATE AMOUNT
575 ASTOTB: MOVEM B,1(TB) ;AND STORE BACK
576 JRST EVL2 ;AND LOOP BACK
578 AMNT: 2,,2 ;INCR FOR GENERAL VECTOR
579 1,,1 ;SAME FOR UNIFORM VECTOR
581 CHKARG: GETYP A,-1(TP)
584 HRRZS (TP) ;MAKE SURE INDIRECT WINS
586 MOVEM A,-1(TP) ;CLOBBER IN TYPE SLOT
587 MOVE A,(TP) ;NOW GET POINTER
588 MOVE A,1(A) ;GET VALUE
589 MOVEM A,(TP) ;CLOBBER IN
594 EVL7: HLRE C,A ;FIND TYPE OF UVECTOR
595 SUBM A,C ;C POINTS TO DOPE WORD
596 GETYP B,(C) ;GET TYPE
597 MOVSI B,(B) ;TO LH NOW
598 SOJA A,EVL8 ;AND RETURN TO DO EVAL
600 EVL3: SKIPL -1(P) ;SKIP IF LIST
601 JRST EVL4 ;EITHER VECTOR OR UVECTOR
604 EVL9: MOVSI A,TLIST ;MAKE TYPE WIN
605 EVL5: SOSGE (P) ;COUNT DOWN
606 JRST FINIS ;DONE, RETURN
607 PUSH TP,$TLIST ;SET TO CALL CONS
610 JRST EVL5 ;LOOP TIL DONE
613 EVL4: MOVEI B,EUVECT ;UNIFORM CASE
614 SKIPG -1(P) ;SKIP IF UNIFORM CASE
615 MOVEI B,EVECTO ;NO, GENERAL CASE
617 .ACALL A,(B) ;CALL CREATOR
620 ; PROCESS SEGMENTS FOR THESE HACKS
622 DOSEG: MOVEM A,BSTO(PVP) ;WILL BECOME INTERRUPTABLE WITH GOODIE IN B
624 PUSHJ P,SAT ;GET STORAGE TYPE
628 CAIN A,S2NWORD ;GENERAL VECTOR?
630 CAIN A,SNWORD ;UNIFORM VECTOR?
632 CAIE A,SARGS ;ARGS TUPLE?
633 JRST ILLSEG ;NO, ERROR
635 PUSH TP,BSTO(PVP) ;PREPARE TO CHECK ARGS
637 SETZM BSTO(PVP) ;TYPE NOT SPECIAL
638 MOVEI B,-1(TP) ;POINT TO SAVED COPY
639 PUSHJ P,CHARGS ;CHECK ARG POINTER
640 POP TP,B ;AND RESTORE WINNER
641 POP TP,BSTO(PVP) ;AND TYPE AND FALL INTO VECTOR CODE
643 VECSEG: PUSH P,[2,,2] ;PUSH AMOUNT TO BUMP
644 JRST SEG1 ;AND JOIN COMMON CODE
646 UVCSEG: PUSH P,[1,,1] ;AMOUNT FOR UVECTS
651 LSTSEG: SKIPL -1(P) ;SKIP IF IN A LIST
652 JRST SEG3 ;ELSE JOIN COMMON CODE
653 HRRZ C,@1(TB) ;CHECK FOR END OF LIST
654 JUMPN C,SEG3 ;NO, JOIN COMMON CODE
655 SETZM BSTO(PVP) ;CLOBBER SAVED GOODIES
656 JRST EVL9 ;AND FINISH UP
661 SEG3: PUSH P,[0] ;AMOUNT OF ADDING FOR LIST
662 SEG1: INTGO ;CHECK OUT INTERRUPTS
664 SKIPE C,(P) ;CHECK IF LIST OR VECTOR
665 JUMPG B,SEG2 ;END OF VECTOR
666 CAMN C,[1,,1] ;SKIP IF NOT UNIFORM
667 JRST SEG5 ;HACK UNIFORM SEGMENT
668 GETYPF A,(B) ;GET NEXT TYPE
669 SKIPGE -2(P) ;SKIP IF NOT LIST
671 MOVE C,1(B) ;GET VALUE
672 SEG4: PUSH TP,A ;PUSH TYPE
674 PUSH P,B ;CAN USE P BECAUSE CHKARG NOT INTERRUPTABLE
675 JSP E,CHKARG ;CHECK OUT TDEFER
677 SKIPG (P) ;SKIP IF NOT LIST
678 HRRZ B,(B) ;CDR THE LIST
679 ADD B,(P) ;AND BUMP IT
680 AOS -1(P) ;BUMP COUNT
681 JRST SEG1 ;AND DO IT AGAIN
683 SEG2: SETZM BSTO(PVP) ;CLOBBER TYPE BACK
684 SUB P,[1,,1] ;POP OFF LOSSAGE
687 SEG5: HLRE C,B ;FIND TYPE
688 SUBM B,C ;POINT TO DOPE WORD
689 GETYP A,(C) ;GET TYPE
691 MOVE C,(B) ;NOW GET VALUE
696 ;APFUNARG APPLIES OBJECTS OF TYPE FUNARG
699 HRRZ A,@1(TB) ;GET CDR OF FUNARG
700 JUMPE A,FUNERR ;NON -- NIL
701 HLRZ B,(A) ;GET TYPE OF CADR
702 CAIE B,TLIST ;BETTR BE LIST
704 PUSH TP,$TLIST ;SAVE IT UP
708 SKIPN A,3(TB) ;ANY MORE
709 JRST DOF ;NO -- APPLY IT
716 HLRZ C,(A) ;GET FIRST VAR
717 CAIE C,TATOM ;MAKE SURE IT IS ATOMIC
719 PUSH TP,BNDA ;SET IT UP
722 PUSH TP,(A) ;SET IT UP
729 PUSHJ P,SPECBIND ;BIND THEM
730 MOVE A,1(TB) ;GET GOODIE
744 ;ILOC RETURNS IN A AND B A LOCATIVE TO THE LOCAL VALUE OF THE IDENTIFIER PASSED TO IT
745 ;IN A AND B. IF THE IDENTIFIER IS LOCALLY UNBOUND IT RETURNS $TUNBOUND IN A AND 0 IN B,
746 ; IT IS CALLED BY PUSHJ P,ILOC.
748 ILOC: MOVSI A,TLOCI ;MAKE A LOCATIVE TYPE CELL
749 HRR A,PROCID+1(PVP) ;FOR THE CURRENT PROCESS
750 CAME A,(B) ;IS THERE ONE IN THE VALUE CELL?
751 JRST SCHSP ;NO -- SEARCH THE LOCAL BINDINGS
752 MOVE B,1(B) ;YES -- GET LOCATIVE POINTER
753 POPJ P, ;FROM THE VALUE CELL
755 SCHSP: MOVE C,SP ;GET TOP OF BINDINGS
756 SCHLP: JUMPE C,UNPOPJ ;IF NO MORE -- LOSE
757 CAMN B,1(C) ;ARE WE POINTING AT THE WINNER?
759 HRRZ C,(C) ;FOLLOW LINK
762 SCHFND: EXCH B,C ;SAVE THE ATOM PTR IN C
763 MOVEI B,2(B) ;MAKE UP THE LOCATIVE
768 MOVEM A,(C) ;CLOBBER IT AWAY INTO THE
769 MOVEM B,1(C) ;ATOM'S VALUE CELL
772 UNPOPJ: MOVSI A,TUNBOUND
776 ;IGLOC RETURNS IN A AND B A LOCATIVE TO THE GLOBAL VALUE OF THE
777 ;IDENTIFIER PASSED TO IT IN A AND B. IF THE IDENTIFIER IS GLOBALLY
778 ;UNBPOUND IT RETURNS $TUNBOUND IN A AND 0 IN B. IT IS CALLED BY PUSHJ P,IGLOC.
780 \rIGLOC: MOVSI A,TLOCI ;DO WE HAVE A LOCATIVE TO
781 CAME A,(B) ;A PROCESS #0 VALUE?
782 JRST SCHGSP ;NO -- SEARCH
783 MOVE B,1(B) ;YES -- GET VALUE CELL
786 SCHGSP: MOVE D,GLOBSP+1(TVP) ;GET GLOBAL SP PTR
788 SCHG1: JUMPGE D,UNPOPJ ;IF NO MORE, LEAVE
789 CAMN B,1(D) ;ARE WE FOUND?
791 ADD D,[4,,4] ;NO -- TRY NEXT
794 GLOCFOUND: EXCH B,D ;SAVE ATOM PTR
795 ADD B,[2,,2] ;MAKE LOCATIVE
796 MOVEM A,(D) ;CLOBBER IT AWAY
803 ;ILVAL RETURNS IN A AND B THE LOCAL VALUE OF THE IDENTIFIER PASSED TO IT IN A AND B
804 ;IF THE IDENTIFIER IS UNBOUND ITS VALUE IS $TUNBOUND IN A AND 0 IN B. IF
805 ;IT IS UNASSIGNED ITS VALUE IS $TUNBOUND IN A AND -1 IN B. CALL - PUSHJ P,IVAL
808 PUSHJ P,ILOC ;GET LOCATIVE TO VALUE
809 CHVAL: CAMN A,$TUNBOUND ;BOUND
810 POPJ P, ;NO -- RETURN
811 MOVE A,(B) ;GET THE TYPE OF THE VALUE
812 MOVE B,1(B) ;GET DATUM
815 ;IGVAL -- LIKE ILVAL EXCEPT FOR GLOBAL VALUES
823 ;BINDER - THIS SUBROUTINE PROCCESSES FUNCTION DECLARATIONS AND BINDS
824 ; ARGUMENTS AND TEMPORARIES APPROPRIATELY.
826 ; CALL: PUSHJ P,BINDER OR BINDRS
828 ; BINDER - ASSUMES ARGS ARE ON A LIST
830 ; BINDRS - ASSUMES FORMS SUPPLIED FOR GETTING ARGS
831 ; BINDRR - RESUME HACK - ARGS ON A LIST TO BE
832 ; EVALED IN PARENT PROCESS
835 ; C/ POINTS TO FUNCTION BEING HACKED
836 ; D/ POINTS TO ARG LIST (IF <0, CALLED FROM A PROG)
837 ; 0/ IF NON-ZERO POINTS TO EXPRESSION GENREATING CALL
840 TBINDR: PUSH P,[ARGCDR] ;PUSH POINTER TO ARG GETTER
844 TBNDRR: PUSH P,[RESARG] ; ARG GETTER FOR RESUMING FUNCTIONS
848 BINDRS: MOVEI A,0 ;NO TOP TEMPS
849 TBNDRS: PUSH P,[SETZ EVALRG] ;FOR THE STACKFORM CASE
850 BIND1: PUSH P,[2] ;PUSH INITIAL STATE (NO DCLS PROCESSED)
851 PUSH P,A ;NUMBER OF TEMPS ON TP STACK
853 JUMPE C,NOBODY ;NO BODY IN FUNCTION, ERROR
855 GETYP A,(C) ;GET FIRST THING IN FUNCTION
856 CAIE A,TATOM ;ATOMIC?
857 JRST BIND2 ;NO, NO NAME ALA HEWITT GIVEN
858 PUSHJ P,TMPUP ;COUNT TEMPS ON TP
859 PUSH TP,[TATOM,,1] ;YES SAVE IT
861 HRRZ C,(C) ;CDR THE FUNCTION TO POINT
864 BIND2: PUSHJ P,CARLST ;MAKE SURE THE CAR IS A LIST
865 JRST BNDRET ;EXIT IMMEDIATELY
866 MOVEI A,(C) ;COPY FOR NXTDCL
867 JUMPL D,AUXDO ;PROG, HANDLE
869 PUSHJ P,NXTDCL ;GET A DECLARATION
870 JRST BINDRG ;NONE THERE, GO BIND ARGS
872 CAME B,[ASCII /BIND/] ;IS A BINDING NEEDED
873 JRST BIND3 ;NO MUST BE ANOTHER FLAVOR OF DCL
875 HRRZ C,(A) ;CDR THE LIST
878 PUSHJ P,CARATM ;GET THE CAR MAKING SURE OF ATOM
880 HRRZ B,OTBSAV(TB) ;BUILD AN ENVIRONEMNT FOR BINDING VAR
883 PUSHJ P,PSHBND ;PUSH THE BINDING ON THE STACK
884 HRRZ C,(C) ;CDR THE DCL LIST
885 JRST BINDRG ;GO BIND AS AN ARG
889 ; MAIN BINDING LOOP, DISPATCH BASED ON DECLARATION
891 BIND4: MOVEI A,(C) ;COPY THE LIST POINTER
892 PUSHJ P,NXTDCL ;AND LOOK FOR A DECLARATION
894 BIND3: TRZ B,1 ;FOR OPTIONAL TO WIN
895 MOVSI A,-DCLS ;NOW GET SET TO SEARCH TABLE
896 HRRZ C,(C) ;CDR THE DCL LIST
897 JUMPE C,MPD ;NO, CDR, ERROR
899 CAMN B,DCLST(A) ;SKIP IF NOT FOUND
900 JRST @DCLGO(A) ;DISPATCH BASED ON DCL
907 DCLST: IRP A,,[ARGS,TUPLE,CALL,OPTIO,ACT,AUX,NAME,EXTRA]
913 \rDCLGO: IRP A,,[ARGDO,TUPLDO,CALDO,OPTDO,ACTDO,AUXDO,ACTDO,AUXDO]
918 IFN <DCLS-DCLS2>,PRINTC /LOSSAGE AT DCLS
922 ;HERE TO CHECK FOR LISTS WITHIN DECLARATIONS
924 CHLIST: GETYP A,(C) ;GET TYPE
927 SKIPN A,1(C) ;CHECK NON-NIL
928 JRST CALD1 ;IF NIL, IGNORE
929 PUSH TP,[TLIST,,1] ;SPECIAL TYPE
931 MOVEI C,(A) ;LIST TO C
932 PUSHJ P,TMPUP ;COUNT TEMPS
938 ;HANDLER FOR CALL DECLARATION
940 CALDO: SKIPL -2(P) ;SKIP IF IN STACK-FORM
941 SOSG -1(P) ;SKIP IF FIRST DECLARATION
942 JRST MPD ;OTHERWISE MEANINGLESS
944 JUMPE 0,MPD ;ALSO MEANINGLESS IF NO CALLSITE GIVEN
945 PUSHJ P,CARATD ;GOBBLE THE ATOM
947 HLLZ A,0 ;SET UP CALL TO PUSH THE BINDING
949 CALD2: PUSHJ P,PSHBND ;PUSH THAT BINDING ON TO STACK
951 CALD1: PUSH TP,$TLIST ;SAVE THE DCL LIST
953 MOVEI E,-2(TP) ;POINT TO DCLS
954 SUB E,(P) ;SUBTRACT TEMPS
955 CALD3: PUSHJ P,SPCBE ;DO THE BINDINGS NOW
956 MOVE C,(TP) ;RESTORE DCLS
957 SUB TP,[2,,2] ;AND POP
958 HRRZ C,(C) ;CDR THE LIST
959 CALD4: SETZM -1(P) ;NEXT MUST BE EITHER AUX OR ACT
960 JUMPN C,BIND4 ;LOOP AGAIN
964 BNDRET: MOVEI A,0 ;SET SWITCH
965 BNDRT2: SKIPN (P) ;ANY TEMPS LEFT?
967 MOVE B,-1(TP) ;GET TYPE
968 CAMN B,[TATOM,,1] ;SPECIAL
970 CAME B,[TLIST,,1] ;STACKED LIST
971 JRST BNDRT1 ;NO, LEAVE
973 PUSHJ P,TMPDWN ;TEMPS DOWN
974 HRRZ C,@(TP) ;CDR THE SAVED LIST
975 SUB TP,[2,,2] ;POP OFF CRAP
976 JRST CALD4 ;AND CONTINUE PROCESSING
978 BNDRT3: PUSHJ P,TMPDWN
979 MOVE E,(TP) ;GET ATOM
981 MOVEI C,0 ;FOR ACTDO TO WIN
983 MOVEI A,1 ;SAY NAME EXISTS
990 ; HERE TO ARGS DECLARATION
992 ARGDO: SOSL -1(P) ;LOSE IF STATES ARE 0 OR 1
993 SKIPGE -2(P) ;ALSO LOSE IN STACK-FRAME
996 PUSHJ P,CARATD ;FIND THE ATOM
999 MOVEI B,(D) ;COPY ARGL
1000 JRST CALD2 ;AND FALL INTO CALL CODE
1002 ;HERE TO HANDLE THE TUPLE DCL
1004 TUPLDO: SOSGE -1(P) ;CHECK STATE
1007 PUSHJ P,CARATD ;GET ATOM
1008 PUSH TP,$TLIST ;SAVE DCL LIST
1010 PUSHJ P,TMPUP ;COUNT THE TEMPS
1013 PUSHJ P,PSHBND ;PUSH THE BINDING FOR THIS CHOMPER
1014 PUSH P,[0] ;PUSH ARG COUNTER
1016 TUPLP: PUSHJ P,@-3(P) ;CALL ARG GOBBLING SUBROUTINE
1017 JRST TUPDONE ;LEAVE IF ALL DONE
1019 PUSHJ P,PSHAB ;PUSH THE EVALED ARG
1020 SOS (P) ;COUNT THE ARG
1023 TUPDON: MOVSI A,TTB ;FENCE POST ARG BLOCK
1024 MOVE B,TB ;WITH A FRAME POINTER
1025 PUSHJ P,PSHAB ;ONTO THE STACK
1026 POP P,B ;GET NUMBER OF ARGS
1028 SKIPE B ;WATCH FOR EMPTY TUPLE
1029 HRLI B,-1(B) ;FOR ADDING TO TOA TP
1030 ADDI B,-1(TP) ;FUDGE POINTER
1031 SUB B,(P) ;SUBTRACT TEMPS
1032 MOVEI E,-1(B) ;B WIIL GET CLOBBERED, SAVE
1033 MOVSI A,TARGS ;GET THE RIGHT TYPE
1034 HLR A,OTBSAV(TB) ;WITH THE TIME
1035 MOVEM A,-4(B) ;CLOBBER IT AWAY
1036 MOVEM B,-3(B) ;AND ARG POINTER
1041 ; HERE TO HANDLE OPTIONAL DECLARATION
1044 JRST MPD ;NOT ALLOWED
1045 SETZM -1(P) ;MUNG STATE
1046 JRST BNDRGL ;JOIN BIND LOOP
1048 BINDRG: SKIPG -1(P) ;CHECK STATE
1051 BNDRGL: JUMPE C,CHLST ;CHECK FOR LAST
1052 PUSH TP,$TLIST ;SAVE DCLS
1054 PUSH TP,$TLIST ;SAVE SLOT
1055 PUSH TP,D ;PUT ARGLIST THERE FOR AN INT CHECK
1057 MOVE D,(TP) ;INCASE INTERRUPT CLOBBERED IT
1058 SETZM (TP) ;NOW CLEAR SLOT
1061 BNDRG3: PUSHJ P,CARATM ;CHECK FOR ATOM
1062 JRST OPTDFL ;NO, MAY BE LIST OR MAY BE QUOTED
1067 PUSHJ P,@-2(P) ;GOBBLE DOWN NEXT ARG
1068 JRST USEDF ;CHECK FOR DEFAULT OT ENOUGH
1070 BNDRG2: HRRZ C,-4(TP) ;RESTORE DCLS
1071 MOVE E,(TP) ;AND ATOM
1072 SUB TP,[6,,6] ;FLUSH CRAP
1074 PUSHJ P,PSHBND ;PUSH THE BINDING
1075 BNDRG4: HRRZ C,(C) ;CDR THE DCL LIST
1078 CHLST: PUSHJ P,@-2(P) ;CHECK FOR LAST
1081 MOVEI E,(TP) ;PREPARE TO BIND
1083 PUSHJ P,SPCBE ;BIND IF STUFF EXISTS
1084 JRST BNDRET ;AND RETURN
1088 CHQT: CAIE A,TFORM ;IST THE ARG A FORM?
1089 JRST OPTDF2 ;NO, END OF ARGS
1091 SKIPN C,1(C) ;CHECK FOR NULL BODY
1094 GETYP A,(C) ;TYPE OF 1ST OF FORM
1095 MOVE B,1(C) ;AND VALUE
1096 CAIN A,TATOM ;BETTER BE ATOM
1098 JRST MPD ;NAMED QUOTE OR LOSSAGE
1099 HRRZ C,(C) ;CDR THE FORM
1100 JUMPE C,MPD ;NO, ARG LOSE
1102 CAIE A,TATOM ;ARG MUST BE ATOM
1104 HRRZ A,(C) ;AND CDR BETTER BE NIL
1106 PUSH TP,$TATOM ;AND SAVE SAME
1108 SKIPGE A,-2(P) ;CHECK TYPE OF ARGS
1109 JRST QUOTHK ;STACK FRAME HACK
1111 JUMPE D,USEDF ;IF NO MORE ARGS, QUIT
1112 GETYP A,(D) ;GET TYPE
1114 PUSH TP,A ;PUSH IT UP
1115 PUSH TP,1(D) ;FOR DEFER CHECK
1119 HRRZ D,(D) ;CDR THE ARG LIST
1122 QUOTHK: PUSHJ P,(A) ;CALL ROUTINE
1123 JRST USEDF ;TOO FEW ARGS
1125 PUSH TP,$TATOM ;QUOTE THE GOODIE
1126 PUSH TP,MQUOTE QUOTE
1129 MCALL 2,LIST ;CONS IT UP
1136 OPTDFL: SKIPN -1(P) ;SKIP IF CANT BE DEFAULT
1137 CAIE A,TLIST ;SHOULD BE A LIST
1138 JRST CHQT ;NO MORE OPTIONALS
1140 SKIPE (TP) ;AVOID LIST OF LIST
1142 MOVE C,1(C) ;GET THE CAR
1143 HRRZ A,(C) ;CDR THE LIST
1145 HRRZ B,(A) ;CHECK FOR NIL CDR
1150 OPTDF2: JUMPN D,OPTDF3 ;IF D NON-ZERO, DONT BIND
1151 MOVEI E,-4(TP) ;PREPARE TO BIND
1152 SUBI E,@(P) ;SUBTRACT TEMPS
1153 PUSHJ P,SPCBE ;DO BINDINGS MAYBE
1154 MOVEI D,0 ;RESET D TO 0
1155 OPTDF3: MOVE C,-2(TP) ;RESTORE DCLS
1156 SUB TP,[4,,4] ;POP STACK
1157 MOVEI A,1 ;CLOBBER IN A NEW STATE
1159 JRST BIND4 ;AND RE-ENTER THE LOOP
1162 USEDF: SKIPE -1(P) ;SKIP IF OPTIONAL
1163 JRST TFA ;ELSE TOO FEW ARGS
1164 MOVEI E,-6(TP) ;SET TO DO SPECBIND
1166 PUSHJ P,SPCBE ;BIND IF THEY EXIST
1167 MOVNI B,1 ;ASSUME UNASSIGNED AT FIRST
1169 SKIPN C,-2(TP) ;IF A FORM TO EVAL
1170 JRST OPTDF4 ;TREAT NORMALLY
1171 GETYP A,(C) ;EVAL IT
1175 JSP E,CHKARG ;CHECK FOR DEFERRED POINTERS
1176 MCALL 1,EVAL ;EVAL IT
1177 OPTDF4: MOVE E,(TP) ;GET ATOM
1179 SUB TP,[6,,6] ;FLUSH JUNK
1180 PUSHJ P,PSHBND ;PUSH THE BINDING
1181 MOVEI D,0 ;MUNG ARG LIST
1186 AUXDO: SKIPGE -1(P) ;CHECK STATE
1188 SETOM -1(P) ;NOTHING BUT ACT MAY FOLLOW
1190 AUXBND: JUMPE C,BNDRET ;DONE
1191 PUSHJ P,CARATM ;LOOK FOR ATOM
1192 JRST AUXIN ;COULD BE LIST
1196 AUXB1: PUSHJ P,PSHBND ;PUSH THE BINDING UP
1198 MOVEI E,(TP) ;PREPARE TO BIND
1199 PUSH TP,$TLIST ;SAVE DCLS
1201 SUB E,(P) ;FUDGE FOR TEMPS
1205 HRRZ C,@(TP) ;CDR THE LIST
1206 SUB TP,[2,,2] ;AND POP
1209 AUXIN: CAIE A,TLIST ;IS IT A LIST
1211 PUSH TP,$TLIST ;SAVE DCLS
1215 PUSHJ P,CARATD ;MAKE SURE ITS AN ATOM
1220 HRRZ A,(C) ;GET NEXT CDR
1221 JUMPN A,MPD ;BETTER BE NIL
1223 MOVSI A,(A) ;TYPE TO LH
1225 PUSH TP,1(C) ;PREPARE TO EVAL
1227 MOVE E,(TP) ;RESTORE ATOM
1228 MOVE C,-2(TP) ;AND DCLS
1234 ACTDO: PUSHJ P,CARATD ;MUST BE ATOMIC
1235 HRRZ C,(C) ;MUST BE END OF DCLS
1237 PUSH P,CBNDRE ;PUSH THE RIGHT RETURN
1239 ACTD1: MOVE B,TB ;MAKE ENV
1241 HRLI A,TACT ;AND CHANGE TO ACTIVATION
1242 POP P,D ;RESTORE RET ADR, BECAUSE PSHBND NEEDS NICE STATE
1243 PUSHJ P,PSHBND ;PUSH UP THE BINDING
1244 PUSH P,D ;NOW PUT IT BACK
1246 SUBI E,@-1(P) ;NOW READY TO BIND
1249 CBNDRE: POPJ P,BNDRT2
1252 ;INTERNAL ROUTINES FOR THE BINDER
1254 TMPUP: AOS -1(P) ;ADDS 2 TO TOP OF STACK
1258 TMPDWN: SOS -1(P) ;SUBTRACTS 2 FROM STACK
1262 CARATD: PUSHJ P,CARATM ;LOOK FOR ATOM
1263 JRST MPD ;ERROR IF NONE
1266 CARATM: GETYP A,(C) ;GETS ARG IN C, GET TYPE
1268 POPJ P, ;NO, DONT SKIP
1269 MOVE E,1(C) ;RETRUN ATOM IN E
1270 CPOPJ1: AOS (P) ;SKIP RET
1273 CARLST: GETYP A,(C) ;GETS LIST IN CAR, POPS TO 2D ON STACK IF NIL
1275 JRST MPD ;NOT A LIST, FATAL
1281 MAKENV: PUSH P,C ;SAVE AN AC
1282 HLRE C,PVP ;GET -LNTH OF PROC VECTOR
1283 MOVEI A,(PVP) ;COPY PVP
1284 SUBI A,-1(C) ;POINT TO DOPWD WITH A
1285 HRLI A,TENV ;MAKE INTO AN ENVIRONMENT
1286 HLL B,OTBSAV(B) ;TIME TO B
1293 ; ARGCDR - NORMAL ARG GETTER FOR OTHER THAN STACKFORM
1295 ARGCDR: JUMPE D,CPOPJ ;DONT SKIP IF NIL
1298 GETYP A,(D) ;GET TYPE OF ARG
1299 MOVSI A,(A) ;TO LH OF A
1301 PUSH TP,1(D) ;PUSH TYPE AND VALUE
1302 JSP E,CHKARG ;CHECK FOR TDEFER
1304 HRRZ D,@(TP) ;CDR THE LIST
1305 SUB TP,[2,,2] ;POP STACK
1306 JRST CPOPJ1 ;SKIP RETURN
1308 ;EVALRG - USED TO EVAL ARGS IN STACKFORM HACK
1310 EVALRG: JUMPE D,CPOPJ ;LEAVE IMMEDIATELY
1311 PUSH TP,$TLIST ;SAVE ARG LIST
1313 HRRZ C,(D) ;AND CDR IT
1314 GETYP B,(C) ;GET TYPE OF CONDITIONAL FORM
1317 PUSH TP,1(C) ;AND VALUE
1318 JSP E,CHKARG ;CHECK DEFERRED
1319 MCALL 1,EVAL ;AND EVAL IT
1320 CAMN A,$TFALSE ;FALSE?
1321 JRST EVALR2 ;YES, LEAVE
1322 HRRZ D,(TP) ;GET ARGS BACK
1323 GETYP A,(D) ;GET TYPE
1326 PUSH TP,1(D) ;PUSH IT
1327 JSP E,CHKARG ;CHECK DEFERRED
1329 AOS (P) ;CAUSE A SKIP RETURN
1330 EVALR2: MOVE D,(TP) ;RESTORE ARGS
1331 SUB TP,[2,,2] ;POP STACK
1334 ;RESARG - USED TO GET ARGS FOR RESUMING FUNCTIONS
1338 JUMPE D,CPOPJ ;DONT SKIP IF NIL - NO MORE ARGS
1339 PUSH TP,$TLIST ; SAVE ARG LIST
1341 GETYP A,(D) ; GET TYPE OF ARG
1343 PUSH TP,A ;PUSH TYPE
1344 PUSH TP,1(D) ;AND VALUE
1345 JSP E,CHKARG ;CHECK FOR DEFERED TYPE
1346 MOVE B,MQUOTE [PPROC ]INTERR
1347 PUSHJ P,ILVAL ;GET ENV OF PARENT PROCESS
1349 PUSH TP,B ;SET UP FOR AEVAL CALL
1350 MCALL 2,EVAL ;CALL EVAL WITH THE ENV
1351 HRRZ D,@(TP) ;CDR ARG LIST
1352 SUB TP,[2,,2] ;REMOVE SAVED ARG LIST
1353 JRST CPOPJ1 ;SKIP 1 AND RETURN
1357 ;SUBROUTINE TO PUSH A BINDING ON THE STACK
1362 PSHBND: PUSH P,D ;SAVE TEMPS
1364 MOVE D,-3(P) ;GOBBLE # OF TEMPS ON STACK
1365 ADD TP,[6,,6] ;ALOCATE SPACE
1366 JUMPGE TP,TPLOSE ;HACK IF OVERFLOW
1367 PSHBN1: HRROI E,-6(TP) ;SET UP E
1368 JUMPE D,NOBLT ;IF NO TEMPS, LESS WORK
1369 POP E,6(E) ;USE POP TP MOVE THEM UP
1371 NOBLT: MOVSI D,TATOM ;SET UP BINDING
1372 HLLOM D,1(E) ;CLOBBER
1373 POP P,2(E) ;ATOM INTO SLOT
1376 SETZM 5(E) ;CLEAR EXTRA SLOTS
1381 TPLOSE: PUSHJ P,TPOVFL ;GO TO INT HANDLER
1384 ; DO A SPECBIND IF NEEDED
1386 SPCBE: MOVE A,-5(E) ;GET TYPE
1389 MOVEI A,(TP) ;COPY POINTER
1390 SUBI A,(E) ;FIND DISTANCE TO TOP
1393 SUB E,A ;FIX UP POINTER
1394 JRST SPECBE ;YES, GO DO IT
1396 ;ROUTINE TO SQUEEZE A PAIR ON THE STACK
1400 PUSH TP,[0] ;ALLOCATE SPACE
1402 MOVE D,-4(P) ;GET TEMPS COUNT
1403 HRROI E,-2(TP) ;POINT TO TOP
1408 NOBLT1: MOVEM A,1(E) ;CLOBBER
1416 ;SPECBIND BINDS IDENTIFIERS. IT IS CALLED BY PUSHJ P,SPECBIND.
1417 ;SPECBIND IS PROVIDED WITH A CONTIGUOUS SET OF TRIPLETS ON TP.
1418 ;EACH TRIPLET IS AS FOLLOWS:
1419 ;THE FIRST ELEMENT IS THE IDENTIFIER TO BE BOUND, ITS TYPE WORD IS [TATOM,,-1],
1420 ;THE SECOND IS THE VALUE TO WHICH IT IS TO BE ASSIGNED,
1421 ;AND THE THIRD IS A PAIR OF ZEROES.
1426 SPECBIND: MOVE E,TP ;GET THE POINTER TO TOP
1427 SPECBE: ADD E,[1,,1] ;BUMP POINTER ONCE
1428 SETZB 0,D ;CLEAR TEMPS
1430 BINDLP: MOVE A,-6(E) ;GET TYPE
1431 CAME A,BNDA ;NORMAL ID BIND?
1432 JRST NONID ;NO TRY BNDV
1434 SUB E,[6,,6] ;MOVE PTR
1436 HRRM E,(D) ;YES -- LOBBER
1438 MOVE 0,E ;NO -- DO IT
1440 MOVE A,0(E) ;GET ATOM PTR
1442 PUSHJ P,ILOC ;GET LAST BINDING
1443 HLR A,OTBSAV (TB) ;GET TIME
1444 MOVEM A,4(E) ;CLOBBER IT AWAY
1445 MOVEM B,5(E) ;IN RESTORE CELLS
1447 HRRZ A,PROCID+1(PVP) ;GET PROCESS NUMBER
1448 HRLI A,TLOCI ;MAKE LOC PTR
1449 MOVE B,E ;TO NEW VALUE
1451 MOVE C,1(E) ;GET ATOM PTR
1452 MOVEM A,(C) ;CLOBBER ITS VALUE
1455 HRLM A,(E) ;IDENTIFY AS BIND BLOCK
1456 MOVE D,E ;REMEMBER LINK
1457 JRST BINDLP ;DO NEXT
1459 NONID: MOVE A,-4(E) ;TRY TYPE BEFORE
1460 CAME A,BNDV ;IS IT A SPECIAL HACK?
1461 JRST SPECBD ;NO -- DONE
1468 MOVE D,1(E) ;GET PTR TO VECTOR
1469 MOVE C,(D) ;EXCHANGE TYPES
1473 MOVE C,1(D) ;EXCHANGE DATUMS
1478 HRLM A,(E) ;IDENTIFY BIND BLOCK
1479 MOVE D,E ;REMEMBER LINK
1489 ;SPECSTORE RESTORES THE BINDINGS SP TO THE ENVIRONMENT POINTER IN
1490 ;SPSAV (TB). IT IS CALLED BY PUSHJ P,SPECSTORE.
1493 HRRZ E,SPSAV (TB) ;GET TARGET POINTER
1496 CAIL E,(SP) ;ARE WE DONE?
1498 HLRZ C,(SP) ;GET TYPE OF BIND
1499 CAIE C,TBIND ;NORMAL IDENTIFIER?
1500 JRST ISTORE ;NO -- SPECIAL HACK
1503 MOVE C,1(SP) ;GET TOP ATOM
1504 MOVE D,4(SP) ;GET STORED LOCATIVE
1505 \r HRR D,PROCID+1(PVP) ;STORE SIGNATURE
1506 MOVEM D,(C) ;CLOBBER INTO ATOM
1510 SPLP: HRRZ SP,(SP) ;FOLOW LINK
1511 JUMPN SP,STLOOP ;IF MORE
1512 JUMPE E,STPOPJ ;ONLY OK IF E=0
1513 .VALUE [ASCIZ /SPOVERPOP/]
1516 .VALUE [ASCIZ /BADSP/]
1531 MFUNCTION REP,FSUBR,[REPEAT]
1533 MFUNCTION PROG,FSUBR
1535 GETYP A,(AB) ;GET ARG TYPE
1536 CAIE A,TLIST ;IS IT A LIST?
1537 JRST WTYP ;WRONG TYPE
1538 SKIPN C,1(AB) ;GET AND CHECK ARGUMENT
1539 JRST ERRTFA ;TOO FEW ARGS
1540 PUSH TP,$TLIST ;PUSH GOODIE
1542 PUSH TP,BNDA ;BIND FUNNY ATOM
1543 PUSH TP,MQUOTE [LPROG ]INTERR
1545 PUSH TP,TB ;CURRENT TB POINTER
1548 PUSHJ P,SPECBI ;BIND THE ATOM
1549 MOVE C,1(AB) ;PROG BODY
1550 MOVNI D,1 ;TELL BINDER WE ARE APROG
1552 HRRZ C,1(AB) ;RESTORE PROG
1553 SKIPLE A ;SKIP IF NO NAME ALA HEWITT
1557 PUSH TP,C ;SAVE FOR REPEAT, AGAIN ETC.
1558 HRRZ C,(C) ;SKIP DCLS
1560 ; HERE TO RUN PROGS FUNCTIONS ETC.
1563 HRRZM C,1(TB) ;CLOBBER AWAY BODY
1564 PUSH TP,(C) ;EVALUATE THE
1566 PUSH TP,1(C) ;STATEMENT
1569 HRRZ C,@1(TB) ;GET THE REST OF THE BODY
1570 JUMPN C,DOPROG ;IF MORE -- DO IT
1574 CAME C,MQUOTE REP,REPEAT
1576 SKIPN C,(TP) ;CHECK IT
1583 MFUNCTION RETURN,SUBR
1585 PUSHJ P,PROGCH ;CKECK IN A PROG
1586 HRR TB,B ;YES, SET TB
1592 MFUNCTION AGAIN,SUBR
1594 HLRZ A,AB ;GET # OF ARGS
1597 JUMPN A,WNA ;0 ARGS?
1598 PUSHJ P,PROGCH ;CHECK FOR IN A PROG
1614 MOVE B,TPSAV(B) ;POINT TO TOP OF STACK
1621 PUSHJ P,PROGCH ;CHECK FOR A PROG
1629 MOVE B,TPSAV(B) ;GET SAVED TOP OF STACK
1632 MCALL 2,MEMQ ;DOES IT HAVE THIS TAG?
1633 JUMPE B,NXTAG ;NO -- ERROR
1634 FNDGO: MOVE TB,(TP) ;RE-GOBBLE
1635 SUB TP,[2,,2] ;POP TP
1639 NLCLGO: CAME A,$TTAG ;CHECK TYPE
1641 MOVE A,1(AB) ;GET ARG
1646 CAME B,3(A) ;CHECK TIME
1651 HRR TB,3(A) ;GET NEW FRAME PTR
1652 MOVE A,1(A) ;GET PLACE TO START
1653 MOVEM A,1(TB) ;CLOBBER IT AWAY
1663 HLRZ A,(AB) ;GET TYPE OF ARGUMENT
1664 CAIE A,TATOM ;CHECK THAT IT IS AN ATOM
1666 PUSHJ P,PROGCH ;CHECK PROG
1669 MOVE A,TPSAV(B) ;GET STACK TOP
1675 JUMPE B,NXTAG ;IF NOT FOUND -- ERROR
1676 MOVEM A,-1(TP) ;SAVE PLACE
1689 PROGCH: MOVE B,MQUOTE [LPROG ]INTERR
1690 PUSHJ P,ILVAL ;GET VALUE
1691 CAME A,$TTB ;CHECK TYPE
1715 MFUNCTION COND,FSUBR
1720 CLSLUP: SKIPN B,1(AB) ;IS THE CLAUSELIST NIL?
1721 JRST IFALSE ;YES -- RETURN NIL
1722 HLRZ A,(B) ;NO -- GET TYPE OF CAR
1723 CAIE A,TLIST ;IS IT A LIST?
1725 MOVE A,1(B) ;YES -- GET CLAUSE
1727 PUSH TP,(A) ;EVALUATION OF
1729 PUSH TP,1(A) ;THE PREDICATE
1732 CAMN A,$TFALSE ;IF THE RESULT IS
1733 JRST NXTCLS ;FALSE TRY NEXT CLAUSE
1734 MOVE C,1(AB) ;IF NOT, GET
1735 MOVE C,1(C) ;THE CLAUSE
1736 HRRZ C,(C) ;GET ITS REST
1737 JUMPE C,FINIS ;IF ONLY A PREDICATE --- RETURN ITS VALUE
1739 PUSH TP,C ;EVALUATE THE REST OF THE CLAUSE
1741 NXTCLS: HRRZ A,@1(AB) ;SET THE CLAUSLIST
1742 HRRZM A,1(AB) ;TO CDR OF THE CLAUSLIST
1746 MOVSI A,TFALSE ;RETURN FALSE
1753 ;SETG IS USED TO SET THE GLOBAL VALUE OF ITS FIRST ARGUMENT,
1754 ;AN IDENTIFIER, TO THE VALUE OF ITS SECOND ARGUMENT. ITS VALUE IS
1755 ; ITS SECOND ARGUMENT.
1759 HLLZ A,(AB) ;GET TYPE OF FIRST ARGUMENT
1760 CAME A,$TATOM ;CHECK THAT IT IS AN ATOM
1761 JRST NONATM ;IF NOT -- ERROR
1762 MOVE B,1(AB) ;GET POINTER TO ATOM
1763 PUSHJ P,IGLOC ;GET LOCATIVE TO VALUE
1764 CAMN A,$TUNBOUND ;IF BOUND
1765 PUSHJ P,BSETG ;IF NOT -- BIND IT
1767 MOVE A,2(AB) ;GET SECOND ARGUMENT
1768 MOVE B,3(AB) ;INTO THE RETURN POSITION
1769 MOVEM A,(C) ;DEPOSIT INTO THE
1770 MOVEM B,1(C) ;INDICATED VALUE CELL
1773 BSETG: HRRZ A,GLOBASE+1(TVP)
1774 HRRZ B,GLOBSP+1(TVP)
1778 PUSH TP,GLOBASE(TVP)
1779 PUSH TP,GLOBASE+1 (TVP)
1785 MOVEM A,GLOBASE(TVP)
1786 MOVEM B,GLOBASE+1(TVP)
1788 MOVE B,GLOBSP+1(TVP)
1794 MOVEM B,GLOBSP+1(TVP)
1802 ;SET CLOBBERS THE LOCAL VALUE OF THE IDENTIFIER GIVEN BY ITS
1803 ;FIRST ARGUMENT TO THE SECOND ARG. ITS VALUE IS ITS SECOND ARGUMENT.
1807 HLLZ A,(AB) ;GET TYPE OF FIRST
1808 CAME A,$TATOM ;ARGUMENT --
1809 JRST WTYP ;BETTER BE AN ATOM
1810 MOVE B,1(AB) ;GET PTR TO IT
1811 PUSHJ P,ILOC ;GET LOCATIVE TO VALUE
1812 CAMN A,$TUNBOUND ;BOUND?
1813 PUSHJ P, BSET ;BIND IT
1815 MOVE A,2(AB) ;GET SECOND ARG
1816 MOVE B,3(AB) ;INTO RETURN VALUE
1817 MOVEM A,(C) ;CLOBBER IDENTIFIER
1821 HRRZ A,TPBASE+1(PVP) ;GET ACTUAL STACK BASE
1822 HRRZ B,SPBASE+1(PVP) ;AND FIRST BINDING
1823 SUB B,A ;ARE THERE 6
1824 CAIL B,6 ;CELLS AVAILABLE?
1826 PUSH TP,TPBASE(PVP) ;NO -- GROW THE TP
1827 PUSH TP,TPBASE+1(PVP) ;AT THE BASE END
1833 MOVEM A,TPBASE(PVP) ;SAVE RESULT
1834 MOVEM B,TPBASE+1(PVP)
1835 SETIT: MOVE B,SPBASE+1(PVP)
1836 MOVEI A,-6(B) ;MAKE UP BINDING
1837 HRRM A,(B) ;LINK PREVIOUS BIND BLOCK
1845 MOVEM B,SPBASE+1(PVP)
1853 HLRZ A,(AB) ; GET TYPE
1854 CAIE A,TFALSE ;IS IT FALSE?
1855 JRST IFALSE ;NO -- RETURN FALSE
1858 MOVSI A,TATOM ;RETURN T (VERITAS)
1862 MFUNCTION ANDA,FSUBR,AND
1866 JRST WTYP ;IF ARG DOESN'T CHECK OUT
1867 SKIPN C,1(AB) ;IF NIL
1868 JRST TRUTH ;RETURN TRUTH
1870 JUMPE C,FINIS ;ANY MORE ARGS?
1871 MOVEM C,1(AB) ;STORE CRUFT
1872 PUSH TP,(C) ;EVALUATE THE
1873 HLLZS (TP) ;FIRST REMAINING
1874 PUSH TP,1(C) ;ARGUMENT
1878 JRST FINIS ;IF FALSE -- RETURN
1879 HRRZ C,@1(AB) ;GET CDR OF ARGLIST
1885 CAIE A,TLIST ;CHECK OUT ARGUMENT
1887 MOVE C,1(AB) ;PICK IT UP TO ENTER LOOP
1889 JUMPE C,IFALSE ;IF NO MORE OPTIONS -- FALSE
1890 MOVEM C,1(AB) ;CLOBBER IT AWAY
1893 PUSH TP,1(C) ;EVALUATE THE FIRST REMAINING
1895 MCALL 1,EVAL ;ARGUMENT
1896 CAME A,$TFALSE ;IF NON-FALSE RETURN
1898 HRRZ C,@1(AB) ;IF FALSE -- TRY AGAIN
1901 MFUNCTION FUNCTION,FSUBR
1905 PUSH TP,MQUOTE FUNCTION
1911 MFUNCTION CLOSURE,SUBR
1913 SKIPL A,AB ;ANY ARGS
1914 JRST ERRTFA ;NO -- LOSE
1915 ADD A,[2,,2] ;POINT AT IDS
1918 PUSH P,[0] ;MAKE COUNTER
1920 CLOLP: SKIPL A,1(TB) ;ANY MORE IDS?
1921 JRST CLODON ;NO -- LOSE
1922 PUSH TP,(A) ;SAVE ID
1924 PUSH TP,(A) ;GET ITS VALUE
1926 ADD A,[2,,2] ;BUMP POINTER
1932 MCALL 2,LIST ;MAKE PAIR
1938 ACALL A,LIST ;MAKE UP LIST
1939 PUSH TP,(AB) ;GET FUNCTION
1943 MCALL 2,LIST ;MAKE LIST
1948 MFUNCTION FALSE,SUBR
1959 ;ERROR COMMENTS FOR EVAL
1961 UNBOU: PUSH TP,$TATOM
1962 PUSH TP,MQUOTE UNBOUND-VARIABLE
1965 UNAS: PUSH TP,$TATOM
1966 PUSH TP,MQUOTE UNASSIGNED-VARIABLE
1970 ERRTFA: PUSH TP,$TATOM
1971 PUSH TP,MQUOTE TOO-FEW-ARGUMENTS-SUPPLIED
1975 ERRTMA: PUSH TP,$TATOM
1976 PUSH TP,MQUOTE TOO-MANY-ARGUMENTS-SUPPLIED
1981 PUSH TP,MQUOTE BAD-ENVIRONMENT
1986 PUSH TP,MQUOTE BAD-FUNARG
1990 WTYP: PUSH TP,$TATOM
1991 PUSH TP,MQUOTE WRONG-TYPE
1995 PUSH TP,MQUOTE MEANINGLESS-PARAMETER-DECLARATION
1998 NOBODY: PUSH TP,$TATOM
1999 PUSH TP,MQUOTE HAS-EMPTY-BODY
2002 BADCLS: PUSH TP,$TATOM
2003 PUSH TP,MQUOTE BAD-CLAUSE
2006 NXTAG: PUSH TP,$TATOM
2007 PUSH TP,MQUOTE NON-EXISTENT-TAG
2010 NXPRG: PUSH TP,$TATOM
2011 PUSH TP,MQUOTE NOT-IN-PROG
2014 NAPT: PUSH TP,$TATOM
2015 PUSH TP,MQUOTE NON-APPLICABLE-TYPE
2018 NONEVT: PUSH TP,$TATOM
2019 PUSH TP,MQUOTE NON-EVALUATEABLE-TYPE
2023 NONATM: PUSH TP,$TATOM
2024 PUSH TP,MQUOTE NON-ATOMIC-ARGUMENT
2028 ILLFRA: PUSH TP,$TATOM
2029 PUSH TP,MQUOTE FRAME-NO-LONGER-EXISTS
2032 NOTIMP: PUSH TP,$TATOM
2033 PUSH TP,MQUOTE NOT-YEST-IMPLEMENTED
2036 ILLSEG: PUSH TP,$TATOM
2037 PUSH TP,MQUOTE ILLEGAL-SEGMENT
2040 ER1ARG: PUSH TP,(AB)