github.com/PDP-10.its
1
0
Fork 0
mirror of https://github.com/PDP-10/its.git synced 2026-01-19 09:29:15 +00:00
Code Issues Releases Wiki Activity
PDP-10.its/src/mudsys/eval.mid.122
Lars Brinkhoff 30ab750df7 Twenex MDL 106 files.
2018-04-25 09:32:25 +01:00

4211 lines
82 KiB
Plaintext
Raw Blame History

This file contains invisible Unicode characters

This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

TITLE EVAL -- MUDDLE EVALUATOR
RELOCATABLE
; GERALD JAY SUSSMAN, 1971. REWRITTEN MANY TIMES SINCE C. REEVE (1972--1974)
.GLOBAL BINDID,LPROG,GLOBSP,GLOBASE,SPBASE,TPBASE,PTIME,SWAP,CHFRAM
.GLOBAL IGVAL,CHKARG,NXTDCL,TPOVFL,CHFRM,PROCHK,CHFSWP,VECBOT,TYPSGR
.GLOBAL ILVAL,ER1ARG,SPECBIND,MAKACT,SPECSTORE,MAKTUP,TPALOC,IBIND,SSPECS
.GLOBAL IDVAL,EVECTO,EUVECT,CHARGS,BCKTRK,CELL,ILOC,IGLOC,CHKDCL,SSPEC1
.GLOBAL PDLBUF,MESS,FACTI,CHKARG,MAKENV,PSTAT,BNDV,UNBOU,UNAS,IGDECL
.GLOBAL 1STEPR,SEGMNT,SEGLST,NAPT,EVTYPE,EVATYP,APTYPE,APLTYP,APLQ,IDVAL1
.GLOBAL TESTR,VALG,TYPG,INCR1,TMATCH,TYPMIS,SAT,MAKACT,NTPALO,SPECBND
.GLOBAL TPGROW,CHKAB,TYPSEG,NXTLM,MONCH0,CHFINI,RMONC0,IMPURIFY,ICONS,INCONS
.GLOBAL CILVAL,CISET,CIGVAL,CSETG,MAPPLY,CLLOC,CGLOC,CASSQ,CGASSQ,CBOUND
.GLOBAL IIGLOC,CHUNW,IUNWIN,UNWIN2,SPCCHK,CURFCN,TMPLNT,TD.LNT,TBINIT
.GLOBAL SPECBE,BSETG,GLOTOP,CANDP,CORP,TFA,TMA,DSTORE,PVSTOR,SPSTOR
.GLOBAL AGC,GVLINC,LVLINC,CGBOUN,IEVECT,MAKTU2,STOSTR,HIBOT,POPUNW,ISTRUC
.INSRT MUDDLE >
MONITOR
; ENTRY TO EXPAND A MACRO
MFUNCTION EXPAND,SUBR
ENTRY 1
MOVE PVP,PVSTOR+1
MOVEI A,PVLNT*2+1(PVP)
HRLI A,TFRAME
MOVE B,TBINIT+1(PVP)
HLL B,OTBSAV(B)
PUSH TP,A
PUSH TP,B
MOVEI B,-1(TP)
JRST AEVAL2
; MAIN EVAL ENTRANCE
IMFUNCTION EVAL,SUBR
ENTRY
MOVE PVP,PVSTOR+1
SKIPE C,1STEPR+1(PVP) ; BEING 1 STEPPED?
JRST 1STEPI ; YES HANDLE
EVALON: HLRZ A,AB ;GET NUMBER OF ARGS
CAIE A,-2 ;EXACTLY 1?
JRST AEVAL ;EVAL WITH AN ALIST
SEVAL: GETYP A,(AB) ;GET TYPE OF ARG
SKIPE C,EVATYP+1 ; USER TYPE TABLE?
JRST EVDISP
SEVAL1: CAIG A,NUMPRI ;PRIMITIVE?
JRST SEVAL2 ;YES-DISPATCH
SELF: MOVE A,(AB) ;TYPES WHICH EVALUATE
MOVE B,1(AB)
JRST EFINIS ;TO SELF-EG NUMBERS
SEVAL2: HRRO A,EVTYPE(A)
JRST (A)
; HERE FOR USER EVAL DISPATCH
EVDISP: ADDI C,(A) ; POINT TO SLOT
ADDI C,(A)
SKIPE (C) ; SKIP EITHER A LOSER OR JRST DISP
JRST EVDIS1 ; APPLY EVALUATOR
SKIPN C,1(C) ; GET ADDR OR GO TO PURE DISP
JRST SEVAL1
JRST (C)
EVDIS1: PUSH TP,(C)
PUSH TP,1(C)
PUSH TP,(AB)
PUSH TP,1(AB)
MCALL 2,APPLY ; APPLY HACKER TO OBJECT
JRST EFINIS
; EVAL DISPATCH TABLE
IF2,SELFS==400000,,SELF
DISTBL EVTYPE,SELFS,[[TFORM,EVFORM],[TLIST,EVLIST],[TVEC,EVECT],[TUVEC,EUVEC]
[TSEG,ILLSEG]]
;WATCH FOR SUBTLE BUG 43 LERR,LPROG OR BINDID
AEVAL:
CAIE A,-4 ;EXACTLY 2 ARGS?
JRST WNA ;NO-ERROR
GETYP A,2(AB) ;CHECK THAT WE HAVE A FRAME
CAIE A,TACT
CAIN A,TFRAME
JRST .+3
CAIE A,TENV
JRST TRYPRO ; COULD BE PROCESS
MOVEI B,2(AB) ; POINT TO FRAME
AEVAL2: PUSHJ P,CHENV ; HACK ENVIRONMENT CHANGE
AEVAL1: PUSH TP,(AB)
PUSH TP,1(AB)
MCALL 1,EVAL
AEVAL3: HRRZ 0,FSAV(TB)
CAIN 0,EVAL
JRST EFINIS
JRST FINIS
TRYPRO: CAIE A,TPVP ; SKIP IF IT IS A PROCESS
JRST WTYP2
MOVE C,3(AB) ; GET PROCESS
CAMN C,PVSTOR ; DIFFERENT FROM ME?
JRST SEVAL ; NO, NORMAL EVAL WINS
MOVE B,SPSTO+1(C) ; GET SP FOR PROCESS
MOVE D,TBSTO+1(C) ; GET TOP FRAME
HLL D,OTBSAV(D) ; TIME IT
MOVEI C,PVLNT*2+1(C) ; CONS UP POINTER TO PROC DOPE WORD
HRLI C,TFRAME ; LOOK LIK E A FRAME
PUSHJ P,SWITSP ; SPLICE ENVIRONMENT
JRST AEVAL1
; ROUTINE TO CHANGE LOOK UP PATH FOR BINDINGS
CHENV: PUSHJ P,CHFRM ; CHECK OUT FRAME
MOVE C,(B) ; POINT TO PROCESS
MOVE D,1(B) ; GET TB POINTER FROM FRAME
CAMN SP,SPSAV(D) ; CHANGE?
POPJ P, ; NO, JUST RET
MOVE B,SPSAV(D) ; GET SP OF INTEREST
SWITSP: MOVSI 0,TSKIP ; SET UP SKIP
HRRI 0,1(TP) ; POINT TO UNBIND PATH
MOVE A,PVSTOR+1
ADD A,[BINDID,,BINDID] ; BIND THE BINDING ID
PUSH TP,BNDV
PUSH TP,A
PUSH TP,$TFIX
AOS A,PTIME ; NEW ID
PUSH TP,A
MOVE E,TP ; FOR SPECBIND
PUSH TP,0
PUSH TP,B
PUSH TP,C ; SAVE PROCESS
PUSH TP,D
PUSHJ P,SPECBE ; BIND BINDID
MOVE SP,TP ; GET NEW SP
SUB SP,[3,,3] ; SET UP SP FORK
MOVEM SP,SPSTOR+1
POPJ P,
; HERE TO EVALUATE A FORM (99% OF EVAL'S WORK)
EVFORM: SKIPN C,1(AB) ; EMPTY FORM, RETURN FALSE
JRST EFALSE
GETYP A,(C) ; 1ST ELEMENT OF FORM
CAIE A,TATOM ; ATOM?
JRST EV0 ; NO, EVALUATE IT
MOVE B,1(C) ; GET ATOM
PUSHJ P,IGVAL ; GET ITS GLOBAL VALUE
; SPECIAL HACK TO SPEED UP LVAL AND GVAL CALLS
CAIE B,LVAL
CAIN B,GVAL
JRST ATMVAL ; FAST ATOM VALUE
GETYP 0,A
CAIE 0,TUNBOU ; BOUND?
JRST IAPPLY ; YES APPLY IT
MOVE C,1(AB) ; LOOK FOR LOCAL
MOVE B,1(C)
PUSHJ P,ILVAL
GETYP 0,A
CAIE 0,TUNBOU
JRST IAPPLY ; WIN, GO APPLY IT
PUSH TP,$TATOM
PUSH TP,EQUOTE UNBOUND-VARIABLE
PUSH TP,$TATOM
MOVE C,1(AB) ; FORM BACK
PUSH TP,1(C)
PUSH TP,$TATOM
PUSH TP,IMQUOTE VALUE
MCALL 3,ERROR ; REPORT THE ERROR
JRST IAPPLY
EFALSE: MOVSI A,TFALSE ; SPECIAL FALSE FOR EVAL OF EMPTY FORM
MOVEI B,0
JRST EFINIS
ATMVAL: HRRZ D,(C) ; CDR THE FORM
HRRZ 0,(D) ; AND AGAIN
JUMPN 0,IAPPLY
GETYP 0,(D) ; MAKE SURE APPLYING TO ATOM
CAIE 0,TATOM
JRST IAPPLY
MOVEI E,IGVAL ; ASSUME GLOBAAL
CAIE B,GVAL ; SKIP IF OK
MOVEI E,ILVAL ; ELSE USE LOCAL
PUSH P,B ; SAVE SUBR
MOVE B,(D)+1 ; CLR BUG #1637 (GET THE ATOM FOR THE SUBR)
PUSHJ P,(E) ; AND GET VALUE
CAME A,$TUNBOU
JRST EFINIS ; RETURN FROM EVAL
POP P,B
MOVSI A,TSUBR ; CAUSE REAL SUBR TO GET EROR
JRST IAPPLY
; HERE FOR 1ST ELEMENT NOT A FORM
EV0: PUSHJ P,FASTEV ; EVAL IT
; HERE TO APPLY THINGS IN FORMS
IAPPLY: PUSH TP,(AB) ; SAVE THE FORM
PUSH TP,1(AB)
PUSH TP,A
PUSH TP,B ; SAVE THE APPLIER
PUSH TP,$TFIX ; AND THE ARG GETTER
PUSH TP,[ARGCDR]
PUSHJ P,APLDIS ; GO TO INTERNAL APPLIER
JRST EFINIS ; LEAVE EVAL
; HERE TO EVAL 1ST ELEMENT OF A FORM
FASTEV: MOVE PVP,PVSTOR+1
SKIPE 1STEPR+1(PVP) ; BEING 1 STEPPED?
JRST EV02 ; YES, LET LOSER SEE THIS EVAL
GETYP A,(C) ; GET TYPE
SKIPE D,EVATYP+1 ; USER TABLE?
JRST EV01 ; YES, HACK IT
EV03: CAIG A,NUMPRI ; SKIP IF SELF
SKIPA A,EVTYPE(A) ; GET DISPATCH
MOVEI A,SELF ; USE SLEF
EV04: CAIE A,SELF ; IF EVAL'S TO SELF, JUST USE IT
JRST EV02
MOVSI A,TLIST
MOVE PVP,PVSTOR+1
MOVEM A,CSTO(PVP)
INTGO
SETZM CSTO(PVP)
HLLZ A,(C) ; GET IT
MOVE B,1(C)
JSP E,CHKAB ; CHECK DEFERS
POPJ P, ; AND RETURN
EV01: ADDI D,(A) ; POINT TO SLOT OF USER EVAL TABLE
ADDI D,(A)
SKIPE (D) ; EITHER NOT GIVEN OR SIMPLE
JRST EV02
SKIPN 1(D) ; SKIP IF SIMPLE
JRST EV03 ; NOT GIVEN
MOVE A,1(D)
JRST EV04
EV02: PUSH TP,(C)
HLLZS (TP) ; FIX UP LH
PUSH TP,1(C)
JSP E,CHKARG
MCALL 1,EVAL
POPJ P,
; MAPF/MAPR CALL TO APPLY
IMQUOTE APPLY
MAPPLY: JRST APPLY
; APPLY, FALLS INTO EVAL'S APPLY CODE AT APLDIS
IMFUNCTION APPLY,SUBR
ENTRY
JUMPGE AB,TFA ; MUST BE AT LEAST 1 ARGUMENT
MOVE A,AB
ADD A,[2,,2]
PUSH TP,$TAB
PUSH TP,A
PUSH TP,(AB) ; SAVE FCN
PUSH TP,1(AB)
PUSH TP,$TFIX ; AND ARG GETTER
PUSH TP,[SETZ APLARG]
PUSHJ P,APLDIS
JRST FINIS
; STACKFROM, ALSO FALLS INTO EVAL'S APPLIER AT APLDIS
IMFUNCTION STACKFORM,FSUBR
ENTRY 1
GETYP A,(AB)
CAIE A,TLIST
JRST WTYP1
MOVEI A,3 ; CHECK ALL GOODIES SUPPLIED
HRRZ B,1(AB)
JUMPE B,TFA
HRRZ B,(B) ; CDR IT
SOJG A,.-2
HRRZ C,1(AB) ; GET LIST BACK
PUSHJ P,FASTEV ; DO A FAST EVALUATION
PUSH TP,(AB)
HRRZ C,@1(AB) ; POINT TO ARG GETTING FORMS
PUSH TP,C
PUSH TP,A ; AND FCN
PUSH TP,B
PUSH TP,$TFIX
PUSH TP,[SETZ EVALRG]
PUSHJ P,APLDIS
JRST FINIS
; OFFSETS FOR TEMPORARIES ETC. USED IN APPLYING STUFF
E.FRM==0 ; POINTS TO FORM BEING EVALED (OR ARGS FOR APPLY STACKFORM)
E.FCN==2 ; FUNCTION/SUBR/RSUBR BEING APPLIED
E.ARG==4 ; POINTS TO ARG GETTING ROUTINE (<0 => MUST EVAL ARGS)
E.EXTR==6 ; CONTAINS 1ST ARG IN USER APPLY CASE
E.SEG==10 ; POINTS TO SEGMENT IN FORM BEING HACKED
E.CNT==12 ; COUNTER FOR TUPLES OF ARGS
E.DECL==14 ; POINTS TO DECLARATION LIST IN FUNCTIONS
E.ARGL==16 ; POINTS TO ARG LIST IN FUNCTIONS
E.HEW==20 ; POINTS TO HEWITT ATOM IF IT EXISTS
E.VAL==E.ARGL ; VALUE TYPE FOR RSUBRS
MINTM==E.EXTR+2 ; MIN # OF TEMPS EVER ALLOCATED
E.TSUB==E.CNT+2 ; # OF TEMPS FOR SUBR/NUMBER APPLICATION
XP.TMP==E.HEW-E.EXTR ; # EXTRA TEMPS FOR FUNCTION APPLICATION
R.TMP==4 ; TEMPS AFTER ARGS ARE BOUND
TM.OFF==E.HEW+2-R.TMP ; TEMPS TO FLUSH AFTER BIND OF ARGS
RE.FCN==0 ; AFTER BINDING CONTAINS FCN BODY
RE.ARG==2 ; ARG LIST AFTER BINDING
; GENERAL THING APPLYER
APLDIS: PUSH TP,[0] ; SLOT USED FOR USER APPLYERS
PUSH TP,[0]
APLDIX: GETYP A,E.FCN(TB) ; GET TYPE
APLDI: SKIPE D,APLTYP+1 ; USER TABLE EXISTS?
JRST APLDI1 ; YES, USE IT
APLDI2: CAILE A,NUMPRI ; SKIP IF NOT PRIM
JRST NAPT
HRRO A,APTYPE(A)
JRST (A)
APLDI1: ADDI D,(A) ; POINT TO SLOT
ADDI D,(A)
SKIPE (D) ; SKIP IF NOT GIVEN OR STANDARD
JRST APLDI3
APLDI4: SKIPE D,1(D) ; GET DISP
JRST (D)
JRST APLDI2 ; USE SYSTEM DISPATCH
APLDI3: SKIPE E.EXTR+1(TB) ; SKIP IF HAVEN'T BEEN HERE BEFORE
JRST APLDI4
MOVE A,(D) ; GET ITS HANDLER
EXCH A,E.FCN(TB) ; AND USE AS FCN
MOVEM A,E.EXTR(TB) ; SAVE
MOVE A,1(D)
EXCH A,E.FCN+1(TB)
MOVEM A,E.EXTR+1(TB) ; STASH OLD FCN AS EXTRG
GETYP A,(D) ; GET TYPE
JRST APLDI
; APPLY DISPATCH TABLE
DISTBL APTYPE,<SETZ NAPTL>,[[TSUBR,APSUBR],[TFSUBR,APFSUB],[TRSUBR,APRSUB],[TFIX,APNUM]
[TEXPR,APEXPR],[TFUNAR,APFUNARG],[TENTER,APENTR],[TMACRO,APMACR],[TOFFS,APNUM]]
; SUBR TO SAY IF TYPE IS APPLICABLE
MFUNCTION APPLIC,SUBR,[APPLICABLE?]
ENTRY 1
GETYP A,(AB)
PUSHJ P,APLQ
JRST IFALSE
JRST TRUTH
; HERE TO DETERMINE IF A TYPE IS APPLICABLE
APLQ: PUSH P,B
SKIPN B,APLTYP+1
JRST USEPUR ; USE PURE TABLE
ADDI B,(A)
ADDI B,(A) ; POINT TO SLOT
SKIPG 1(B) ; SKIP IF WINNER
SKIPE (B) ; SKIP IF POTENIAL LOSER
JRST CPPJ1B ; WIN
SKIPE 1(B) ; SKIP IF MUST USE PURE TABBLE
JRST CPOPJB
USEPUR: CAILE A,NUMPRI ; SKIP IF NOT PRIM
JRST CPOPJB
SKIPL APTYPE(A) ; SKIP IF APLLICABLE
CPPJ1B: AOS -1(P)
CPOPJB: POP P,B
POPJ P,
; FSUBR APPLYER
APFSUBR:
SKIPN E.EXTR(TB) ; IF EXTRA ARG
SKIPGE E.ARG+1(TB) ; OR APPLY/STACKFORM, LOSE
JRST BADFSB
MOVE A,E.FCN+1(TB) ; GET FCN
HRRZ C,@E.FRM+1(TB) ; GET ARG LIST
SUB TP,[MINTM,,MINTM] ; FLUSH UNWANTED TEMPS
PUSH TP,$TLIST
PUSH TP,C ; ARG TO STACK
.MCALL 1,(A) ; AND CALL
POPJ P, ; AND LEAVE
; SUBR APPLYER
APSUBR:
PUSHJ P,PSH4ZR ; SET UP ZEROED SLOTS
SKIPG E.ARG+1(TB)
AOS E.CNT(TB) ; INDICATES IF MUST EVAL ARGS
MOVSI A,400000 ; MAKE SURE OF GOOD INDIRECT
IORM A,E.ARG+1(TB)
SKIPN A,E.EXTR(TB) ; FUNNY ARGS
JRST APSUB1 ; NO, GO
MOVE B,E.EXTR+1(TB) ; YES , GET VAL
JRST APSUB2 ; AND FALL IN
APSUB1: PUSHJ P,@E.ARG+1(TB) ; EAT AN ARG
JRST APSUBD ; DONE
APSUB2: PUSH TP,A
PUSH TP,B
AOS E.CNT+1(TB) ; COUNT IT
JRST APSUB1
APSUBD: MOVE A,E.CNT+1(TB) ; FINISHED, GET COUNT
MOVE B,E.FCN+1(TB) ; AND SUBR
GETYP 0,E.FCN(TB)
CAIN 0,TENTER
JRST APENDN
PUSHJ P,BLTDN ; FLUSH CRUFT
.ACALL A,(B)
POPJ P,
BLTDN: MOVEI C,(TB) ; POINT TO DEST
HRLI C,E.TSUB(C) ; AND SOURCE
BLT C,-E.TSUB(TP) ;BL..............T
SUB TP,[E.TSUB,,E.TSUB]
POPJ P,
APENDN: PUSHJ P,BLTDN
APNDN1: .ECALL A,(B)
POPJ P,
; FLAGS FOR RSUBR HACKER
F.STR==1
F.OPT==2
F.QUO==4
F.NFST==10
; APPLY OBJECTS OF TYPE RSUBR
APENTR:
APRSUBR:
MOVE C,E.FCN+1(TB) ; GET THE RSUBR
CAML C,[-5,,] ; IS IT LONG ENOUGH FOR DECLS
JRST APSUBR ; NO TREAT AS A SUBR
GETYP 0,4(C) ; GET TYPE OF 3D ELEMENT
CAIE 0,TDECL ; DECLARATION?
JRST APSUBR ; NO, TREAT AS SUBR
PUSHJ P,PSH4ZR ; ALLOCATE SOME EXTRA ROOM
PUSH TP,$TDECL ; PUSH UP THE DECLS
PUSH TP,5(C)
PUSH TP,$TLOSE ; SAVE ROOM FOR VAL DECL
PUSH TP,[0]
SKIPG E.ARG+1(TB)
AOS E.CNT(TB) ; INDICATES IF MUST EVAL ARGS
MOVSI A,400000 ; MAKE SURE OF GOOD INDIRECT
IORM A,E.ARG+1(TB)
SKIPN E.EXTR(TB) ; "EXTRA" ARG?
JRST APRSU1 ; NO,
MOVE 0,[SETZ EXTRGT] ; CHANGE THE ACCESS FCN
EXCH 0,E.ARG+1(TB)
HRRM 0,E.ARG(TB) ; REMEMBER IT
APRSU1: MOVEI 0,0 ; INIT FLAG REGISTER
PUSH P,0 ; SAVE
APRSU2: HRRZ A,E.DECL+1(TB) ; GET DECL LIST
JUMPE A,APRSU3 ; DONE!
HRRZ B,(A) ; CDR IT
MOVEM B,E.DECL+1(TB)
PUSHJ P,NXTDCL ; IS NEXT THING A STRING?
JRST APRSU4 ; NO, BETTER BE A TYPE
CAMN B,[ASCII /VALUE/]
JRST RSBVAL ; SAVE VAL DECL
TRON 0,F.NFST ; IF NOT FIRST, LOSE
CAME B,[ASCII /CALL/] ; CALL DECL
JRST APRSU7
SKIPE E.CNT(TB) ; LEGAL?
JRST MPD
MOVE C,E.FRM(TB)
MOVE D,E.FRM+1(TB) ; GET FORM
JRST APRS10 ; HACK IT
APRSU5: TROE 0,F.STR ; STRING STRING?
JRST MPD ; LOSER
CAMN B,[<ASCII /OPT/>]
JRST .+3
CAME B,[<ASCII /OPTIO/>+1] ; OPTIONA?
JRST APRSU8
TROE 0,F.OPT ; CHECK AND SET
JRST MPD ; OPTINAL OPTIONAL LOSES
JRST APRSU2 ; TO MAIN LOOP
APRSU7: CAME B,[ASCII /QUOTE/]
JRST APRSU5
TRO 0,F.STR
TROE 0,F.QUO ; TURN ON AND CHECK QUOTE
JRST MPD ; QUOTE QUOTE LOSES
JRST APRSU2 ; GO TO END OF LOOP
APRSU8: CAME B,[ASCII /ARGS/]
JRST APRSU9
SKIPE E.CNT(TB) ; SKIP IF LEGAL
JRST MPD
HRRZ D,@E.FRM+1(TB) ; GET ARG LIST
MOVSI C,TLIST
APRS10: HRRZ A,(A) ; GET THE DECL
MOVEM A,E.DECL+1(TB) ; CLOBBER
HRRZ B,(A) ; CHECK FOR TOO MUCH
JUMPN B,MPD
MOVE B,1(A) ; GET DECL
HLLZ A,(A) ; GOT THE DECL
MOVEM 0,(P) ; SAVE FLAGS
JSP E,CHKAB ; CHECK DEFER
PUSH TP,C
PUSH TP,D ; SAVE
PUSHJ P,TMATCH
JRST WTYP
AOS E.CNT+1(TB) ; COUNT ARG
JRST APRDON ; GO CALL RSUBR
RSBVAL: HRRZ A,E.DECL+1(TB) ; GET DECL
JUMPE A,MPD
HRRZ B,(A) ; POINT TO DECL
MOVEM B,E.DECL+1(TB) ; SAVE NEW DECL POINTER
PUSHJ P,NXTDCL
JRST .+2
JRST MPD
MOVEM A,E.VAL+1(TB) ; SAVE VAL DECL
MOVSI A,TDCLI
MOVEM A,E.VAL(TB) ; SET ITS TYPE
JRST APRSU2
APRSU9: CAME B,[ASCII /TUPLE/]
JRST MPD
MOVEM 0,(P) ; SAVE FLAGS
HRRZ A,(A) ; CDR DECLS
MOVEM A,E.DECL+1(TB)
HRRZ B,(A)
JUMPN B,MPD ; LOSER
PUSH P,[0] ; COUNT ELEMENTS IN TUPLE
APRTUP: PUSHJ P,@E.ARG+1(TB) ; GOBBLE ARGS
JRST APRTPD ; DONE
PUSH TP,A
PUSH TP,B
AOS (P) ; COUNT IT
JRST APRTUP ; AND GO
APRTPD: POP P,C ; GET COUNT
ADDM C,E.CNT+1(TB) ; UPDATE MAIN COUNT
ASH C,1 ; # OF WORDS
HRLI C,TINFO ; BUILD FENCE POST
PUSH TP,C
PUSHJ P,TBTOTP ; GEN REL OFFSET TO TOP
PUSH TP,D
HRROI D,-1(TP) ; POINT TO TOP
SUBI D,(C) ; TO BASE
TLC D,-1(C)
MOVSI C,TARGS ; BUILD TYPE WORD
HLR C,OTBSAV(TB)
MOVE A,E.DECL+1(TB)
MOVE B,1(A)
HLLZ A,(A) ; TYPE/VAL
JSP E,CHKAB ; CHECK
PUSHJ P,TMATCH ; GOTO TYPE CHECKER
JRST WTYP
SUB TP,[2,,2] ; REMOVE FENCE POST
APRDON: SUB P,[1,,1] ; FLUSH CRUFT
MOVE A,E.CNT+1(TB) ; GET # OF ARGS
MOVE B,E.FCN+1(TB)
GETYP 0,E.FCN(TB) ; COULD BE ENTRY
MOVEI C,(TB) ; PREPARE TO BLT DOWN
HRLI C,E.TSUB+2(C)
BLT C,-E.TSUB+2(TP)
SUB TP,[E.TSUB+2,,E.TSUB+2]
CAIE 0,TRSUBR
JRST APNDNX
.ACALL A,(B) ; CALL THE RSUBR
JRST PFINIS
APNDNX: .ECALL A,(B)
JRST PFINIS
APRSU4: MOVEM 0,(P) ; SAVE FLAGS
MOVE B,1(A) ; GET DECL
HLLZ A,(A)
JSP E,CHKAB
MOVE 0,(P) ; RESTORE FLAGS
PUSH TP,A
PUSH TP,B ; AND SAVE
SKIPE E.CNT(TB) ; ALREADY EVAL'D
JRST APREV0
TRZN 0,F.QUO
JRST APREVA ; MUST EVAL ARG
MOVEM 0,(P)
HRRZ C,@E.FRM+1(TB) ; GET ARG?
TRNE 0,F.OPT ; OPTIONAL
JUMPE C,APRDN
JUMPE C,TFA ; NO, TOO FEW ARGS
MOVEM C,E.FRM+1(TB)
HLLZ A,(C) ; GET ARG
MOVE B,1(C)
JSP E,CHKAB ; CHECK THEM
APRTYC: MOVE C,A ; SET UP FOR TMATCH
MOVE D,B
EXCH B,(TP)
EXCH A,-1(TP) ; SAVE STUFF
APRS11: PUSHJ P,TMATCH ; CHECK TYPE
JRST WTYP
MOVE 0,(P) ; RESTORE FLAGS
TRZ 0,F.STR
AOS E.CNT+1(TB)
JRST APRSU2 ; AND GO ON
APREV0: TRNE 0,F.QUO ; ATTEMPT TO QUOTE ALREADY EVAL'D ARG ?
JRST MPD ; YES, LOSE
APREVA: PUSHJ P,@E.ARG+1(TB) ; EVAL ONE
TDZA C,C ; C=0 ==> NONE LEFT
MOVEI C,1
MOVE 0,(P) ; FLAGS
JUMPN C,APRTYC ; GO CHECK TYPE
APRDN: SUB TP,[2,,2] ; FLUSH DECL
TRNE 0,F.OPT ; OPTIONAL?
JRST APRDON ; ALL DONE
JRST TFA
APRSU3: TRNE 0,F.STR ; END IN STRING?
JRST MPD
PUSHJ P,@E.ARG+1(TB) ; SEE IF ANYMORE ARGS
JRST APRDON
JRST TMA
; STANDARD ARGUMENT GETTERS USED IN APPLYING THINGS
ARGCDR: HRRZ C,@E.FRM+1(TB) ; POINT TO ARGLIST (NOTE: POINTS 1 BEFORE WHERE ARG IS)
JUMPE C,CPOPJ ; LEAVE IF DONE
MOVEM C,E.FRM+1(TB)
GETYP 0,(C) ; GET TYPE OF ARG
CAIN 0,TSEG
JRST ARGCD1 ; SEG MENT HACK
PUSHJ P,FASTEV
JRST CPOPJ1
ARGCD1: PUSH TP,$TFORM ; PRETEND WE ARE A FORM
PUSH TP,1(C)
MCALL 1,EVAL
MOVEM A,E.SEG(TB)
MOVEM B,E.SEG+1(TB)
PUSHJ P,TYPSEG ; GET SEG TYPE CODE
HRRM C,E.ARG(TB) ; SAVE IT IN OBSCCURE PLACE
MOVE C,DSTORE ; FIX FOR TEMPLATE
MOVEM C,E.SEG(TB)
MOVE C,[SETZ SGARG]
MOVEM C,E.ARG+1(TB) ; SET NEW ARG GETTER
; FALL INTO SEGARG
SGARG: INTGO
HRRZ C,E.ARG(TB) ; SEG CODE TO C
MOVE D,E.SEG+1(TB)
MOVE A,E.SEG(TB)
MOVEM A,DSTORE
PUSHJ P,NXTLM ; GET NEXT ELEMENT
JRST SEGRG1 ; DONE
MOVEM D,E.SEG+1(TB)
MOVE D,DSTORE ; KEEP TYPE WINNING
MOVEM D,E.SEG(TB)
SETZM DSTORE
JRST CPOPJ1 ; RETURN
SEGRG1: SETZM DSTORE
MOVEI C,ARGCDR
HRRM C,E.ARG+1(TB) ; RESET ARG GETTER
JRST ARGCDR
; ARGUMENT GETTER FOR APPLY
APLARG: INTGO
SKIPL A,E.FRM+1(TB) ; ANY ARGS LEFT
POPJ P, ; NO, EXIT IMMEDIATELY
ADD A,[2,,2]
MOVEM A,E.FRM+1(TB)
MOVE B,-1(A) ; RET NEXT ARG
MOVE A,-2(A)
JRST CPOPJ1
; STACKFORM ARG GETTER
EVALRG: SKIPN C,@E.FRM+1(TB) ; ANY FORM?
POPJ P,
PUSHJ P,FASTEV
GETYP A,A ; CHECK FOR FALSE
CAIN A,TFALSE
POPJ P,
MOVE C,E.FRM+1(TB) ; GET OTHER FORM
PUSHJ P,FASTEV
JRST CPOPJ1
; HERE TO APPLY NUMBERS
APNUM: PUSHJ P,PSH4ZR ; TP SLOTS
SKIPN A,E.EXTR(TB) ; FUNNY ARG?
JRST APNUM1 ; NOPE
MOVE B,E.EXTR+1(TB) ; GET ARG
JRST APNUM2
APNUM1: PUSHJ P,@E.ARG+1(TB) ; GET ARG
JRST TFA
APNUM2: PUSH TP,A
PUSH TP,B
PUSH TP,E.FCN(TB)
PUSH TP,E.FCN+1(TB)
PUSHJ P,@E.ARG+1(TB)
JRST .+2
JRST APNUM3
PUSHJ P,BLTDN ; FLUSH JUNK
MCALL 2,NTH
POPJ P,
; HACK FOR TURNING <3 .FOO .BAR> INTO <PUT .FOO 3 .BAR>
APNUM3: PUSH TP,A
PUSH TP,B
PUSHJ P,@E.ARG+1(TB)
JRST .+2
JRST TMA
PUSHJ P,BLTDN
GETYP A,-5(TP)
PUSHJ P,ISTRUC ; STRUCTURED FIRST ARG?
JRST WTYP1
MCALL 3,PUT
POPJ P,
; HERE TO APPLY SUSSMAN FUNARGS
APFUNARG:
SKIPN C,E.FCN+1(TB)
JRST FUNERR
HRRZ D,(C) ; MUST BE AT LEAST 2 LONG
JUMPE D,FUNERR
GETYP 0,(D) ; CHECK FOR LIST
CAIE 0,TLIST
JRST FUNERR
HRRZ 0,(D) ; SHOULD BE END
JUMPN 0,FUNERR
GETYP 0,(C) ; 1ST MUST BE FCN
CAIE 0,TEXPR
JRST FUNERR
SKIPN C,1(C)
JRST NOBODY
PUSHJ P,APEXPF ; BIND THE ARGS AND AUX'S
HRRZ C,RE.FCN+1(TB) ; GET BODY OF FUNARG
MOVE B,1(C) ; GET FCN
MOVEM B,RE.FCN+1(TB) ; AND SAVE
HRRZ C,(C) ; CDR FUNARG BODY
MOVE C,1(C)
MOVSI 0,TLIST ; SET UP TYPE
MOVE PVP,PVSTOR+1
MOVEM 0,CSTO(PVP) ; FOR INTS TO WIN
FUNLP: INTGO
JUMPE C,DOF ; RUN IT
GETYP 0,(C)
CAIE 0,TLIST ; BETTER BE LIST
JRST FUNERR
PUSH TP,$TLIST
PUSH TP,C
PUSHJ P,NEXTDC ; GET POSSIBILITY
JRST FUNERR ; LOSER
CAIE A,2
JRST FUNERR
HRRZ B,(B) ; GET TO VALUE
MOVE C,(TP)
SUB TP,[2,,2]
PUSH TP,BNDA
PUSH TP,E
HLLZ A,(B) ; GET VAL
MOVE B,1(B)
JSP E,CHKAB ; HACK DEFER
PUSHJ P,PSHAB4 ; PUT VAL IN
HRRZ C,(C) ; CDR
JUMPN C,FUNLP
; HERE TO RUN FUNARG
DOF: MOVE PVP,PVSTOR+1
SETZM CSTO(PVP) ; DONT CONFUSE GC
PUSHJ P,SPECBIND ; BIND 'EM UP
JRST RUNFUN
; HERE TO DO MACROS
APMACR: HRRZ E,OTBSAV(TB)
HRRZ D,PCSAV(E) ; SEE WHERE FROM
CAIE D,EFCALL+1 ; 1STEP
JRST .+3
HRRZ E,OTBSAV(E)
HRRZ D,PCSAV(E)
CAIN D,AEVAL3 ; SKIP IF NOT RIGHT
JRST APMAC1
SKIPG E.ARG+1(TB) ; SKIP IF REAL FORM EXISTS
JRST BADMAC
MOVE A,E.FRM(TB)
MOVE B,E.FRM+1(TB)
SUB TP,[E.EXTR+2,,E.EXTR+2] ; FLUSH JUNK
PUSH TP,A
PUSH TP,B
MCALL 1,EXPAND ; EXPAND THE MACRO
PUSH TP,A
PUSH TP,B
MCALL 1,EVAL ; EVAL THE RESULT
POPJ P,
APMAC1: MOVE C,E.FCN+1(TB) ; GET MACRO BODY
GETYP A,(C)
MOVE B,1(C)
MOVSI A,(A)
JSP E,CHKAB ; FIX DEFERS
MOVEM A,E.FCN(TB)
MOVEM B,E.FCN+1(TB)
JRST APLDIX
; HERE TO APPLY EXPRS (FUNCTIONS)
APEXPR: PUSHJ P,APEXP ; BIND ARGS AND AUX'S
RUNFUN: HRRZ A,RE.FCN(TB) ; AMOUNT OF FCN TO SKIP
MOVEI C,RE.FCN+1(TB) ; POINT TO FCN
HRRZ C,(C) ; SKIP SOMETHING
SOJGE A,.-1 ; UNTIL 1ST FORM
MOVEM C,RE.FCN+1(TB) ; AND STORE
JRST DOPROG ; GO RUN PROGRAM
APEXP: SKIPN C,E.FCN+1(TB) ; CHECK FRO BODY
JRST NOBODY
APEXPF: PUSH P,[0] ; COUNT INIT CRAP
ADD TP,[XP.TMP,,XP.TMP] ; SLOTS FOR HACKING
SKIPL TP
PUSHJ P,TPOVFL
SETZM 1-XP.TMP(TP) ; ZERO OUT
MOVEI A,-XP.TMP+2(TP)
HRLI A,-1(A)
BLT A,(TP) ; ZERO SLOTS
SKIPG E.ARG+1(TB)
AOS E.CNT(TB) ; INDICATES IF MUST EVAL ARGS
MOVSI A,400000 ; MAKE E.ARG BE NEG FOR SAFE @ING
IORM A,E.ARG+1(TB)
PUSHJ P,CARATC ; SEE IF HEWITT ATOM EXISTS
JRST APEXP1 ; NO, GO LOOK FOR ARGLIST
MOVEM E,E.HEW+1(TB) ; SAVE ATOM
MOVSM 0,E.HEW(TB) ; AND TYPE
AOS (P) ; COUNT HEWITT ATOM
APEXP1: GETYP 0,(C) ; LOOK AT NEXT THING
CAIE 0,TLIST ; BETTER BE LIST!!!
JRST MPD.0 ; LOSE
MOVE B,1(C) ; GET LIST
MOVEM B,E.ARGL+1(TB) ; SAVE
MOVSM 0,E.ARGL(TB) ; WITH TYPE
HRRZ C,(C) ; CDR THE FCN
JUMPE C,NOBODY ; BODYLESS FCN
GETYP 0,(C) ; SEE IF DCL LIST SUPPLIED
CAIE 0,TDECL
JRST APEXP2 ; NO, START PROCESSING ARGS
AOS (P) ; COUNT DCL
MOVE B,1(C)
MOVEM B,E.DECL+1(TB)
MOVSM 0,E.DECL(TB)
HRRZ C,(C) ; CDR ON
JUMPE C,NOBODY
; CHECK FOR EXISTANCE OF EXTRA ARG
APEXP2: POP P,A ; GET COUNT
HRRM A,E.FCN(TB) ; AND SAVE
SKIPN E.EXTR(TB) ; SKIP IF FUNNY EXTRA ARG EXISTS
JRST APEXP3
MOVE 0,[SETZ EXTRGT]
EXCH 0,E.ARG+1(TB)
HRRM 0,E.ARG(TB) ; SAVE OLD GETTER AROUND
AOS E.CNT(TB)
; FALL THROUGH
; LOOK FOR "BIND" DECLARATION
APEXP3: PUSHJ P,UNPROG ; UNASSIGN LPROG IF NEC
APXP3A: SKIPN A,E.ARGL+1(TB) ; GET ARGLIST
JRST APEXP4 ; NONE, VERIFY NONE WERE GIVEN
PUSHJ P,NXTDCL ; SEE IF A DECL IS THERE
JRST BNDRG ; NO, GO BIND NORMAL ARGS
HRRZ C,(A) ; CDR THE DCLS
CAME B,[ASCII /BIND/]
JRST CH.CAL ; GO LOOK FOR "CALL"
PUSHJ P,CARTMC ; MUST BE AN ATOM
MOVEM C,E.ARGL+1(TB) ; AND SAVE CDR'D ARGS
PUSHJ P,MAKENV ; GENERATE AN ENVIRONMENT
PUSHJ P,PSBND1 ; PUSH THE BINDING AND CHECK THE DCL
JRST APXP3A ; IN CASE <"BIND" B "BIND" C......
; LOOK FOR "CALL" DCL
CH.CAL: CAME B,[ASCII /CALL/]
JRST CHOPT ; TRY SOMETHING ELSE
; SKIPG E.ARG+1(TB) ; DONT SKIP IF CANT WIN
SKIPE E.CNT(TB)
JRST MPD.2
PUSHJ P,CARTMC ; BETTER BE AN ATOM
MOVEM C,E.ARGL+1(TB)
MOVE A,E.FRM(TB) ; RETURN FORM
MOVE B,E.FRM+1(TB)
PUSHJ P,PSBND1 ; BIND AND CHECK
JRST APEXP5
; BIND NORMAL ARGS BY CALLING BNDEM1, RETURNS WHEN ALL DONE
BNDRG: PUSHJ P,BNDEM1 ; GO BIND THEM UP
TRNN A,4 ; SKIP IF HIT A DCL
JRST APEXP4 ; NOT A DCL, MUST BE DONE
; LOOK FOR "OPTIONAL" DECLARATION
CHOPT: CAMN B,[<ASCII /OPT/>]
JRST .+3
CAME B,[<ASCII /OPTIO/>+1]
JRST CHREST ; TRY TUPLE/ARGS
MOVEM C,E.ARGL+1(TB) ; SAVE RESTED ARGLIST
PUSHJ P,BNDEM2 ; DO ALL SUPPLIED OPTIONALS
TRNN A,4 ; SKIP IF NEW DCL READ
JRST APEXP4
; CHECK FOR "ARGS" DCL
CHREST: CAME B,[ASCII /ARGS/]
JRST CHRST1 ; GO LOOK FOR "TUPLE"
; SKIPGE E.ARG+1(TB) ; SKIP IF LEGAL
SKIPE E.CNT(TB)
JRST MPD.3
PUSHJ P,CARTMC ; GOBBLE ATOM
MOVEM C,E.ARGL+1(TB) ; SAVE CDR'D ARG
HRRZ B,@E.FRM+1(TB) ; GET ARG LIST
MOVSI A,TLIST ; GET TYPE
PUSHJ P,PSBND1
JRST APEXP5
; HERE TO CHECK FOR "TUPLE"
CHRST1: CAME B,[ASCII /TUPLE/]
JRST APXP10
PUSHJ P,CARTMC ; GOBBLE ATOM
MOVEM C,E.ARGL+1(TB)
SETZB A,B
PUSHJ P,PSHBND ; SET UP BINDING
SETZM E.CNT+1(TB) ; ZERO ARG COUNTER
TUPLP: PUSHJ P,@E.ARG+1(TB) ; GET AN ARG
JRST TUPDON ; FINIS
AOS E.CNT+1(TB)
PUSH TP,A
PUSH TP,B
JRST TUPLP
TUPDON: PUSHJ P,MAKINF ; MAKE INFO CELL
PUSH TP,$TINFO ; FENCE POST TUPLE
PUSHJ P,TBTOTP
ADDI D,TM.OFF ; COMPENSATE FOR MOVEMENT
PUSH TP,D
MOVE C,E.CNT+1(TB) ; GET COUNT
ASH C,1 ; TO WORDS
HRRM C,-1(TP) ; INTO FENCE POST
MOVEI B,-TM.OFF-1(TP) ; SETUP ARG POINTER
SUBI B,(C) ; POINT TO BASE OF TUPLE
MOVNS C ; FOR AOBJN POINTER
HRLI B,(C) ; GOOD ARGS POINTER
MOVEM A,TM.OFF-4(B) ; STORE
MOVEM B,TM.OFF-3(B)
; CHECK FOR VALID ENDING TO ARGS
APEXP5: PUSHJ P,NEXTD ; READ NEXT THING IN ARGLIST
JRST APEXP8 ; DONE
TRNN A,4 ; SKIP IF DCL
JRST MPD.4 ; LOSER
APEXP7: MOVSI A,-NWINS ; CHECK FOR A WINNER
CAME B,WINRS(A)
AOBJN A,.-1
JUMPGE A,MPD.6 ; NOT A WINNER
; HERE TO BLT THE WORLD DOWN ON TOP OF ALL THE USELESS TEMPS
APEXP8: MOVE 0,E.HEW+1(TB) ; GET HEWITT ATOM
MOVE E,E.FCN(TB) ; SAVE COUNTER
MOVE C,E.FCN+1(TB) ; FCN
MOVE B,E.ARGL+1(TB) ; ARG LIST
MOVE D,E.DECL+1(TB) ; AND DCLS
MOVEI A,R.TMP(TB) ; SET UP BLT
HRLI A,TM.OFF(A)
BLT A,-TM.OFF(TP) ; BLLLLLLLLLLLLLT
SUB TP,[TM.OFF,,TM.OFF] ; FLUSH CRUFT
MOVEM E,RE.FCN(TB)
MOVEM C,RE.FCN+1(TB)
MOVEM B,RE.ARGL+1(TB)
MOVE E,TP
PUSH TP,$TATOM
PUSH TP,0
PUSH TP,$TDECL
PUSH TP,D
GETYP A,-5(TP) ; TUPLE ON TOP?
CAIE A,TINFO ; SKIP IF YES
JRST APEXP9
HRRZ A,-5(TP) ; GET SIZE
ADDI A,2
HRLI A,(A)
SUB E,A ; POINT TO BINDINGS
SKIPE C,(TP) ; IF DCL
PUSHJ P,CHKDCL ; CHECK TYPE SPEC ON TUPLE
APEXP9: PUSHJ P,USPCBE ; DO ACTUAL BINDING
MOVE E,-2(TP) ; RESTORE HEWITT ATOM
MOVE D,(TP) ; AND DCLS
SUB TP,[4,,4]
JRST AUXBND ; GO BIND AUX'S
; HERE TO VERIFY CHECK IF ANY ARGS LEFT
APEXP4: PUSHJ P,@E.ARG+1(TB)
JRST APEXP8 ; WIN
JRST TMA ; TOO MANY ARGS
APXP10: PUSH P,B
PUSHJ P,@E.ARG+1(TB)
JRST .+2
JRST TMA
POP P,B
JRST APEXP7
; LIST OF POSSIBLE TERMINATING NAMES
WINRS:
AS.ACT: ASCII /ACT/
AS.NAM: ASCII /NAME/
AS.AUX: ASCII /AUX/
AS.EXT: ASCII /EXTRA/
NWINS==.-WINRS
; HERE TO BIND AUX VARIABLES FOR PROGS AND FCNS
AUXBND: PUSH P,E ; SAVE HEWITT ATOM ( WILL PUT ON MARKED STACK
; WHEN NECESSARY)
PUSH P,D ; SAME WITH DCL LIST
PUSH P,[-1] ; FLAG SAYING WE ARE FCN
SKIPN C,RE.ARG+1(TB) ; GET ARG LIST
JRST AUXDON
GETYP 0,(C) ; GET TYPE
CAIE 0,TDEFER ; SKIP IF CHSTR
MOVMS (P) ; SAY WE ARE IN OPTIONALS
JRST AUXB1
PRGBND: PUSH P,E
PUSH P,D
PUSH P,[0] ; WE ARE IN AUXS
AUXB1: HRRZ C,RE.ARG+1(TB) ; POINT TO ARGLIST
PUSHJ P,NEXTDC ; GET NEXT THING OFF OF ARG LIST
JRST AUXDON
TRNE A,4 ; SKIP IF SOME KIND OF ATOM
JRST TRYDCL ; COUDL BE DCL
TRNN A,1 ; SKIP IF QUOTED
JRST AUXB2
SKIPN (P) ; SKIP IF QUOTED OK
JRST MPD.11
AUXB2: PUSHJ P,PSHBND ; SET UP BINDING
PUSH TP,$TDECL ; SAVE HEWITT ATOM
PUSH TP,-1(P)
PUSH TP,$TATOM ; AND DECLS
PUSH TP,-2(P)
TRNN A,2 ; SKIP IF INIT VAL EXISTS
JRST AUXB3 ; NO, USE UNBOUND
; EVALUATE EXPRESSION
HRRZ C,(B) ; CDR ATOM OFF
; CHECK FOR SPECIAL FORMS <TUPLE ...> <ITUPLE ...>
GETYP 0,(C) ; GET TYPE OF GOODIE
CAIE 0,TFORM ; SMELLS LIKE A FORM
JRST AUXB13
HRRZ D,1(C) ; GET 1ST ELEMENT
GETYP 0,(D) ; AND ITS VAL
CAIE 0,TATOM ; FEELS LIKE THE RIGHT FORM
JRST AUXB13
MOVE 0,1(D) ; GET THE ATOM
CAME 0,IMQUOTE TUPLE
CAMN 0,MQUOTE ITUPLE
JRST DOTUPL ; SURE GLAD I DIDN'T STEP IN THAT FORM
AUXB13: PUSHJ P,FASTEV
AUXB14: MOVE E,TP
AUXB4: MOVEM A,-7(E) ; STORE VAL IN BINDING
MOVEM B,-6(E)
; HERE TO CHECK AGAINST DECLARATIONS AND COMPLETE THE BINDING
AUXB5: SUB E,[4,,4] ; POINT TO BINDING TOP
SKIPE C,-2(TP) ; POINT TO DECLARATINS
PUSHJ P,CHKDCL ; CHECK IT
PUSHJ P,USPCBE ; AND BIND UP
SKIPE C,RE.ARG+1(TB) ; CDR DCLS
HRRZ C,(C) ; IF ANY TO CDR
MOVEM C,RE.ARG+1(TB)
MOVE A,(TP) ; NOW PUT HEWITT ATOM AND DCL AWAY
MOVEM A,-2(P)
MOVE A,-2(TP)
MOVEM A,-1(P)
SUB TP,[4,,4] ; FLUSH SLOTS
JRST AUXB1
AUXB3: MOVNI B,1
MOVSI A,TUNBOU
JRST AUXB14
; HERE TO HANDLE "CALLS" TO TUPLE AND ITUPLE
DOTUPL: SKIPE E,(P) ; SKIP IF IN AUX LIST
JRST TUPLE
PUSH TP,$TLIST ; SAVE THE MAGIC FORM
PUSH TP,D
CAME 0,IMQUOTE TUPLE
JRST DOITUP ; DO AN ITUPLE
; FALL INTO A TUPLE PUSHING LOOP
DOTUP1: HRRZ C,@(TP) ; CDR THE FORM
JUMPE C,ATUPDN ; FINISHED
MOVEM C,(TP) ; SAVE CDR'D RESULT
GETYP 0,(C) ; CHECK FOR SEGMENT
CAIN 0,TSEG
JRST DTPSEG ; GO PULL IT APART
PUSHJ P,FASTEV ; EVAL IT
PUSHJ P,CNTARG ; PUSH IT UP AND COUNT THEM
JRST DOTUP1
; HERE WHEN WE FINISH
ATUPDN: SUB TP,[2,,2] ; FLUSH THE LIST
ASH E,1 ; E HAS # OF ARGS DOUBLE IT
MOVEI D,(TP) ; FIND BASE OF STACK AREA
SUBI D,(E)
MOVSI C,-3(D) ; PREPARE BLT POINTER
BLT C,C ; HEWITT ATOM AND DECL TO 0,A,B,C
; NOW PREPEARE TO BLT TUPLE DOWN
MOVEI D,-3(D) ; NEW DEST
HRLI D,4(D) ; SOURCE
BLT D,-4(TP) ; SLURP THEM DOWN
HRLI E,TINFO ; SET UP FENCE POST
MOVEM E,-3(TP) ; AND STORE
PUSHJ P,TBTOTP ; GET OFFSET
ADDI D,3 ; FUDGE FOR NOT AT TOP OF STACK
MOVEM D,-2(TP)
MOVEM 0,-1(TP) ; RESTORE HEW ATOM AND DECLS
MOVEM A,(TP)
PUSH TP,B
PUSH TP,C
PUSHJ P,MAKINF ; MAKE 1ST WORD OF FUNNYS
HRRZ E,-5(TP) ; RESTORE WORDS OF TUPLE
HRROI B,-5(TP) ; POINT TO TOP OF TUPLE
SUBI B,(E) ; NOW BASE
TLC B,-1(E) ; FIX UP AOBJN PNTR
ADDI E,2 ; COPNESATE FOR FENCE PST
HRLI E,(E)
SUBM TP,E ; E POINT TO BINDING
JRST AUXB4 ; GO CLOBBER IT IN
; HERE TO HANDLE SEGMENTS IN THESE FUNNY FORMS
DTPSEG: PUSH TP,$TFORM ; SAVE THE HACKER
PUSH TP,1(C)
MCALL 1,EVAL ; AND EVALUATE IT
MOVE D,B ; GET READY FOR A SEG LOOP
MOVEM A,DSTORE
PUSHJ P,TYPSEG ; TYPE AND CHECK IT
DTPSG1: INTGO ; DONT BLOW YOUR STACK
PUSHJ P,NXTLM ; ELEMENT TO A AND B
JRST DTPSG2 ; DONE
PUSHJ P,CNTARG ; PUSH AND COUNT
JRST DTPSG1
DTPSG2: SETZM DSTORE
HRRZ E,-1(TP) ; GET COUNT IN CASE END
JRST DOTUP1 ; REST OF ARGS STILL TO DO
; HERE TO HACK <ITUPLE .....>
DOITUP: HRRZ C,@(TP) ; GET COUNT FILED
JUMPE C,TFA
MOVEM C,(TP)
PUSHJ P,FASTEV ; EVAL IT
GETYP 0,A
CAIE 0,TFIX
JRST WTY1TP
JUMPL B,BADNUM
HRRZ C,@(TP) ; GET EXP TO EVAL
MOVEI 0,0 ; DONT LOSE IN 1 ARG CASE
HRRZ 0,(C) ; VERIFY WINNAGE
JUMPN 0,TMA ; TOO MANY
JUMPE B,DOIDON
PUSH P,B ; SAVE COUNT
PUSH P,B
JUMPE C,DOILOS
PUSHJ P,FASTEV ; EVAL IT ONCE
MOVEM A,-1(TP)
MOVEM B,(TP)
DOILP: INTGO
PUSH TP,-1(TP)
PUSH TP,-1(TP)
MCALL 1,EVAL
PUSHJ P,CNTRG
SOSLE (P)
JRST DOILP
DOIDO1: MOVE B,-1(P) ; RESTORE COUNT
SUB P,[2,,2]
DOIDON: MOVEI E,(B)
JRST ATUPDN
; FOR CASE OF NO EVALE
DOILOS: SUB TP,[2,,2]
DOILLP: INTGO
PUSH TP,[0]
PUSH TP,[0]
SOSL (P)
JRST DOILLP
JRST DOIDO1
; ROUTINE TO PUSH NEXT TUPLE ELEMENT
CNTARG: AOS E,-1(TP) ; KEEP ARG COUNT UP TO DATE IN E
CNTRG: EXCH A,-1(TP) ; STORE ELEM AND GET SAVED
EXCH B,(TP)
PUSH TP,A
PUSH TP,B
POPJ P,
; DUMMY TUPLE AND ITUPLE
IMFUNCTION TUPLE,SUBR
ENTRY
ERRUUO EQUOTE NOT-IN-AUX-LIST
MFUNCTIO ITUPLE,SUBR
JRST TUPLE
; PROCESS A DCL IN THE AUX VAR LISTS
TRYDCL: SKIPN (P) ; SKIP IF NOT IN AUX'S
JRST AUXB7
CAME B,AS.AUX ; "AUX" ?
CAMN B,AS.EXT ; OR "EXTRA"
JRST AUXB9 ; YES
CAME B,[ASCII /TUPLE/]
JRST AUXB10
PUSHJ P,MAKINF ; BUILD EMPTY TUPLE
MOVEI B,1(TP)
PUSH TP,$TINFO ; FENCE POST
PUSHJ P,TBTOTP
PUSH TP,D
AUXB6: HRRZ C,(C) ; CDR PAST DCL
MOVEM C,RE.ARG+1(TB)
AUXB8: PUSHJ P,CARTMC ; GET ATOM
AUXB12: PUSHJ P,PSHBND ; UP GOES THE BINDING
PUSH TP,$TATOM ; HIDE HEWITT ATOM AND DCL
PUSH TP,-1(P)
PUSH TP,$TDECL
PUSH TP,-2(P)
MOVE E,TP
JRST AUXB5
; CHECK FOR ARGS
AUXB10: CAME B,[ASCII /ARGS/]
JRST AUXB7
MOVEI B,0 ; NULL ARG LIST
MOVSI A,TLIST
JRST AUXB6 ; GO BIND
AUXB9: SETZM (P) ; NOW READING AUX
HRRZ C,(C)
MOVEM C,RE.ARG+1(TB)
JRST AUXB1
; CHECK FOR NAME/ACT
AUXB7: CAME B,AS.NAM
CAMN B,AS.ACT
JRST .+2
JRST MPD.12 ; LOSER
HRRZ C,(C) ; CDR ON
HRRZ 0,(C) ; BETTER BE END
JUMPN 0,MPD.13
PUSHJ P,CARTMC ; FORCE ATOM READ
SETZM RE.ARG+1(TB)
AUXB11: PUSHJ P,MAKACT ; MAKE ACTIVATION
JRST AUXB12 ; AND BIND IT
; DONE BIND HEWITT ATOM IF NECESARY
AUXDON: SKIPN E,-2(P)
JRST AUXD1
SETZM -2(P)
JRST AUXB11
; FINISHED, RETURN
AUXD1: SUB P,[3,,3]
POPJ P,
; MAKE AN ACTIVATION OR ENVIRONMNENT
MAKACT: MOVEI B,(TB)
MOVSI A,TACT
MAKAC1: MOVE PVP,PVSTOR+1
HRRI A,PVLNT*2+1(PVP) ; POINT TO PROCESS
HLL B,OTBSAV(B) ; GET TIME
POPJ P,
MAKENV: MOVSI A,TENV
HRRZ B,OTBSAV(TB)
JRST MAKAC1
; SEVERAL USEFUL LITTLE ROUTINES FOR HACKING THIS STUFF
; CARAT/CARATC/CARATM/CARTMC ALL LOOK FOR THE NEXT ATOM
CARAT: HRRZ C,E.ARGL+1(TB) ; PICK UP ARGLIST
CARATC: JUMPE C,CPOPJ ; FOUND
GETYP 0,(C) ; GET ITS TYPE
CAIE 0,TATOM
CPOPJ: POPJ P, ; RETURN, NOT ATOM
MOVE E,1(C) ; GET ATOM
HRRZ C,(C) ; CDR DCLS
JRST CPOPJ1
CARATM: HRRZ C,E.ARGL+1(TB)
CARTMC: PUSHJ P,CARATC
JRST MPD.7 ; REALLY LOSE
POPJ P,
; SUBROUTINES TO PUSH BINDINGS ETC. UP ON THE STACK
PSBND1: PUSHJ P,PSHBND ; PUSH THEBINDING
JRST CHDCL ; NOW CHECK IT AGAINST DECLARATION
PSHBND: SKIPGE SPCCHK ; SKIP IF NORMAL SPECIAL
PUSH TP,BNDA1 ; ATOM IN E
SKIPL SPCCHK ; SKIP IF NORMAL UNSPEC OR NO CHECK
PUSH TP,BNDA
PUSH TP,E ; PUSH IT
PSHAB4: PUSH TP,A
PUSH TP,B
PUSH TP,[0]
PUSH TP,[0]
POPJ P,
; ROUTINE TO PUSH 4 0'S
PSH4ZR: SETZB A,B
JRST PSHAB4
; EXTRRA ARG GOBBLER
EXTRGT: HRRZ A,E.ARG(TB) ; RESET SLOT
SETZM E.CNT(TB)
CAIE A,ARGCDR ; IF NOT ARGCDR
AOS E.CNT(TB)
TLO A,400000 ; SET FLAG
MOVEM A,E.ARG+1(TB)
MOVE A,E.EXTR(TB) ; RET ARG
MOVE B,E.EXTR+1(TB)
JRST CPOPJ1
; CHECK A/B FOR DEFER
CHKAB: GETYP 0,A
CAIE 0,TDEFER ; SKIP IF DEFER
JRST (E)
MOVE A,(B)
MOVE B,1(B) ; GET REAL THING
JRST (E)
; IF DECLARATIONS EXIST, DO THEM
CHDCL: MOVE E,TP
CHDCLE: SKIPN C,E.DECL+1(TB)
POPJ P,
JRST CHKDCL
; ROUTINE TO READ NEXT THING FROM ARGLIST
NEXTD: HRRZ C,E.ARGL+1(TB) ; GET ARG LIST
NEXTDC: MOVEI A,0
JUMPE C,CPOPJ
PUSHJ P,CARATC ; TRY FOR AN ATOM
JRST NEXTD1 ; NO
JRST CPOPJ1
NEXTD1: CAIE 0,TFORM ; FORM?
JRST NXT.L ; COULD BE LIST
PUSHJ P,CHQT ; VERIFY 'ATOM
MOVEI A,1
JRST CPOPJ1
NXT.L: CAIE 0,TLIST ; COULD BE (A <EXPRESS>) OR ('A <EXPRESS>)
JRST NXT.S ; BETTER BE A DCL
PUSHJ P,LNT.2 ; VERIFY LENGTH IS 2
JRST MPD.8
CAIE 0,TATOM ; TYPE OF 1ST RET IN 0
JRST LST.QT ; MAY BE 'ATOM
MOVE E,1(B) ; GET ATOM
MOVEI A,2
JRST CPOPJ1
LST.QT: CAIE 0,TFORM ; FORM?
JRST MPD.9 ; LOSE
PUSH P,C
MOVEI C,(B) ; VERIFY 'ATOM
PUSHJ P,CHQT
MOVEI B,(C) ; POINT BACK TO LIST
POP P,C
MOVEI A,3 ; CODE
JRST CPOPJ1
NXT.S: MOVEI A,(C) ; LET NXTDCL FIND OUT
PUSHJ P,NXTDCL
JRST MPD.3 ; LOSER
MOVEI A,4 ; SET DCL READ FLAG
JRST CPOPJ1
; ROUTINE TO CHECK LENGTH OF LIST/FORM FOR BEING 2
LNT.2: HRRZ B,1(C) ; GET LIST/FORM
JUMPE B,CPOPJ
HRRZ B,(B)
JUMPE B,CPOPJ
HRRZ B,(B) ; BETTER END HERE
JUMPN B,CPOPJ
HRRZ B,1(C) ; LIST BACK
GETYP 0,(B) ; TYPE OF 1ST ELEMENT
JRST CPOPJ1
; ROUTINE TO VERIFY FORM IS 'ATOM AND RET ATOM
CHQT: PUSHJ P,LNT.2 ; 1ST LENGTH CHECK
JRST MPD.5
CAIE 0,TATOM
JRST MPD.5
MOVE 0,1(B)
CAME 0,IMQUOTE QUOTE
JRST MPD.5 ; BETTER BE QUOTE
HRRZ E,(B) ; CDR
GETYP 0,(E) ; TYPE
CAIE 0,TATOM
JRST MPD.5
MOVE E,1(E) ; GET QUOTED ATOM
POPJ P,
; ARG BINDER FOR REGULAR ARGS AND OPTIONALS
BNDEM1: PUSH P,[0] ; REGULAR FLAG
JRST .+2
BNDEM2: PUSH P,[1]
BNDEM: PUSHJ P,NEXTD ; GET NEXT THING
JRST CCPOPJ ; END OF THINGS
TRNE A,4 ; CHECK FOR DCL
JRST BNDEM4
TRNE A,2 ; SKIP IF NOT (ATM ..) OR ('ATM ...)
SKIPE (P) ; SKIP IF REG ARGS
JRST .+2 ; WINNER, GO ON
JRST MPD.6 ; LOSER
SKIPGE SPCCHK
PUSH TP,BNDA1 ; SAVE ATOM
SKIPL SPCCHK
PUSH TP,BNDA
PUSH TP,E
; SKIPGE E.ARG+1(TB) ; ALREADY EVAL'D ARG?
SKIPE E.CNT(TB)
JRST RGLAR0
TRNN A,1 ; SKIP IF ARG QUOTED
JRST RGLARG
HRRZ D,@E.FRM+1(TB) ; GET AND CDR ARG
JUMPE D,TFACHK ; OH OH MAYBE TOO FEW ARGS
MOVEM D,E.FRM+1(TB) ; STORE WINNER
HLLZ A,(D) ; GET ARG
MOVE B,1(D)
JSP E,CHKAB ; HACK DEFER
JRST BNDEM3 ; AND GO ON
RGLAR0: TRNE A,1 ; ATTEMPT TO QUOTE ALREADY EVAL'D ARG ?
JRST MPD ; YES, LOSE
RGLARG: PUSH P,A ; SAVE FLAGS
PUSHJ P,@E.ARG+1(TB)
JRST TFACH1 ; MAY GE TOO FEW
SUB P,[1,,1]
BNDEM3: HRRZ C,@E.ARGL+1(TB) ; CDR THHE ARGS
MOVEM C,E.ARGL+1(TB)
PUSHJ P,PSHAB4 ; PUSH VALUE AND SLOTS
PUSHJ P,CHDCL ; CHECK DCLS
JRST BNDEM ; AND BIND ON!
; HERE WHEN ARGS RUN OUT, IF NOT OPTIONAL, GIVE TFA
TFACH1: POP P,A
TFACHK: SUB TP,[2,,2] ; FLUSH ATOM
SKIPN (P) ; SKIP IF OPTIONALS
JRST TFA
CCPOPJ: SUB P,[1,,1]
POPJ P,
BNDEM4: HRRZ C,@E.ARGL+1(TB) ; POINT TO REST OF ARGL
JRST CCPOPJ
; EVALUATE LISTS, VECTORS, UNIFROM VECTORS
EVLIST: PUSH P,[-1] ;-1 -- THIS IS A LIST
JRST EVL1 ;GO TO HACKER
EVECT: PUSH P,[0] ;0 -- THIS IS A GENERAL VECTOR
JRST EVL1
EUVEC: PUSH P,[1] ;1 -- THIS IS A UNIFORM VECTOR
EVL1: PUSH P,[0] ;PUSH A COUNTER
GETYPF A,(AB) ;GET FULL TYPE
PUSH TP,A
PUSH TP,1(AB) ;AND VALUE
EVL2: INTGO ;CHECK INTERRUPTS
SKIPN A,1(TB) ;ANYMORE
JRST EVL3 ;NO, QUIT
SKIPL -1(P) ;SKIP IF LIST
JUMPG A,EVL3 ;JUMP IF VECTOR EMPTY
GETYPF B,(A) ;GET FULL TYPE
SKIPGE C,-1(P) ;SKIP IF NOT LIST
HLLZS B ;CLOBBER CDR FIELD
JUMPG C,EVL7 ;HACK UNIFORM VECS
EVL8: PUSH P,B ;SAVE TYPE WORD ON P
CAMN B,$TSEG ;SEGMENT?
MOVSI B,TFORM ;FAKE OUT EVAL
PUSH TP,B ;PUSH TYPE
PUSH TP,1(A) ;AND VALUE
JSP E,CHKARG ; CHECK DEFER
MCALL 1,EVAL ;AND EVAL IT
POP P,C ;AND RESTORE REAL TYPE
CAMN C,$TSEG ;SEGMENT?
JRST DOSEG ;YES, HACK IT
AOS (P) ;COUNT ELEMENT
PUSH TP,A ;AND PUSH IT
PUSH TP,B
EVL6: SKIPGE A,-1(P) ;DONT SKIP IF LIST
HRRZ B,@1(TB) ;CDR IT
JUMPL A,ASTOTB ;AND STORE IT
MOVE B,1(TB) ;GET VECTOR POINTER
ADD B,AMNT(A) ;INCR BY APPROPRIATE AMOUNT
ASTOTB: MOVEM B,1(TB) ;AND STORE BACK
JRST EVL2 ;AND LOOP BACK
AMNT: 2,,2 ;INCR FOR GENERAL VECTOR
1,,1 ;SAME FOR UNIFORM VECTOR
CHKARG: GETYP A,-1(TP)
CAIE A,TDEFER
JRST (E)
HRRZS (TP) ;MAKE SURE INDIRECT WINS
MOVE A,@(TP)
MOVEM A,-1(TP) ;CLOBBER IN TYPE SLOT
MOVE A,(TP) ;NOW GET POINTER
MOVE A,1(A) ;GET VALUE
MOVEM A,(TP) ;CLOBBER IN
JRST (E)
EVL7: HLRE C,A ; FIND TYPE OF UVECTOR
SUBM A,C ;C POINTS TO DOPE WORD
GETYP B,(C) ;GET TYPE
MOVSI B,(B) ;TO LH NOW
SOJA A,EVL8 ;AND RETURN TO DO EVAL
EVL3: SKIPL -1(P) ;SKIP IF LIST
JRST EVL4 ;EITHER VECTOR OR UVECTOR
MOVEI B,0 ;GET A NIL
EVL9: MOVSI A,TLIST ;MAKE TYPE WIN
EVL5: SOSGE (P) ;COUNT DOWN
JRST EVL10 ;DONE, RETURN
PUSH TP,$TLIST ;SET TO CALL CONS
PUSH TP,B
MCALL 2,CONS
JRST EVL5 ;LOOP TIL DONE
EVL4: MOVEI B,EUVECT ;UNIFORM CASE
SKIPG -1(P) ;SKIP IF UNIFORM CASE
MOVEI B,EVECTO ;NO, GENERAL CASE
POP P,A ;GET COUNT
.ACALL A,(B) ;CALL CREATOR
EVL10: GETYPF A,(AB) ; USE SENT TYPE
JRST EFINIS
; PROCESS SEGMENTS FOR THESE HACKS
DOSEG: PUSHJ P,TYPSEG ; FIND WHAT IS BEING SEGMENTED
JUMPE C,LSTSEG ; CHECK END SPLICE IF LIST
SEG3: PUSHJ P,NXTELM ; GET THE NEXTE ELEMT
JRST SEG4 ; RETURN TO CALLER
AOS (P) ; COUNT
JRST SEG3 ; TRY AGAIN
SEG4: SETZM DSTORE
JRST EVL6
TYPSEG: PUSHJ P,TYPSGR
JRST ILLSEG
POPJ P,
TYPSGR: MOVE E,A ; SAVE TYPE
GETYP A,A ; TYPE TO RH
PUSHJ P,SAT ;GET STORAGE TYPE
MOVE D,B ; GOODIE TO D
MOVNI C,1 ; C <0 IF ILLEGAL
CAIN A,S2WORD ;LIST?
MOVEI C,0
CAIN A,S2NWORD ;GENERAL VECTOR?
MOVEI C,1
CAIN A,SNWORD ;UNIFORM VECTOR?
MOVEI C,2
CAIN A,SCHSTR
MOVEI C,3
CAIN A,SBYTE
MOVEI C,5
CAIN A,SSTORE ;SPECIAL AFREE STORAGE ?
MOVEI C,4 ;TREAT LIKE A UVECTOR
CAIN A,SARGS ;ARGS TUPLE?
JRST SEGARG ;NO, ERROR
CAILE A,NUMSAT ; SKIP IF NOT TEMPLATE
JRST SEGTMP
MOVE A,PTYPS(C)
CAIN A,4
MOVEI A,2 ; NOW TREAT LIKE A UVECTOR
HLL E,A
MSTOR1: JUMPL C,CPOPJ
MDSTOR: MOVEM E,DSTORE
JRST CPOPJ1
SEGTMP: MOVEI C,4
HRRI E,(A)
JRST MSTOR1
SEGARG: MOVSI A,TARGS
HRRI A,(E)
PUSH TP,A ;PREPARE TO CHECK ARGS
PUSH TP,D
MOVEI B,-1(TP) ;POINT TO SAVED COPY
PUSHJ P,CHARGS ;CHECK ARG POINTER
POP TP,D ;AND RESTORE WINNER
POP TP,E ;AND TYPE AND FALL INTO VECTOR CODE
MOVEI C,1
JRST MSTOR1
LSTSEG: SKIPL -1(P) ;SKIP IF IN A LIST
JRST SEG3 ;ELSE JOIN COMMON CODE
HRRZ A,@1(TB) ;CHECK FOR END OF LIST
JUMPN A,SEG3 ;NO, JOIN COMMON CODE
SETZM DSTORE ;CLOBBER SAVED GOODIES
JRST EVL9 ;AND FINISH UP
NXTELM: INTGO
PUSHJ P,NXTLM ; GOODIE TO A AND B
POPJ P, ; DONE
PUSH TP,A
PUSH TP,B
JRST CPOPJ1
NXTLM: XCT TESTR(C) ; SKIP IF MORE IN SEGEMNT
POPJ P,
XCT TYPG(C) ; GET THE TYPE
XCT VALG(C) ; AND VALUE
JSP E,CHKAB ; CHECK DEFERRED
XCT INCR1(C) ; AND INCREMENT TO NEXT
CPOPJ1: AOS (P) ; SKIP RETURN
POPJ P,
; TABLES FOR SEGMENT OPERATIONS (0->LIST, 1->VECTOR/ARGS, 2->UVEC, 3->STRING)
PTYPS: TLIST,,
TVEC,,
TUVEC,,
TCHSTR,,
TSTORA,,
TBYTE,,
TESTR: SKIPN D
SKIPL D
SKIPL D
PUSHJ P,CHRDON
PUSHJ P,TM1
PUSHJ P,CHRDON
TYPG: PUSHJ P,LISTYP
GETYPF A,(D)
PUSHJ P,UTYPE
MOVSI A,TCHRS
PUSHJ P,TM2
MOVSI A,TFIX
VALG: MOVE B,1(D)
MOVE B,1(D)
MOVE B,(D)
PUSHJ P,1CHGT
PUSHJ P,TM3
PUSHJ P,1CHGT
INCR1: HRRZ D,(D)
ADD D,[2,,2]
ADD D,[1,,1]
PUSHJ P,1CHINC
ADD D,[1,,]
PUSHJ P,1CHINC
TM1: HRRZ A,DSTORE
SKIPE DSTORE
HRRZ A,DSTORE ; GET SAT
SUBI A,NUMSAT+1
ADD A,TD.LNT+1
EXCH C,D
XCT (A)
HLRZ 0,C ; GET AMNT RESTED
SUB B,0
EXCH C,D
TRNE B,-1
AOS (P)
POPJ P,
TM3:
TM2: HRRZ 0,DSTORE
SKIPE DSTORE
HRRZ 0,DSTORE
PUSH P,C
PUSH P,D
PUSH P,E
MOVE B,D
MOVEI C,0 ; GET "1ST ELEMENT"
PUSHJ P,TMPLNT ; GET NTH IN A AND B
POP P,E
POP P,D
POP P,C
POPJ P,
CHRDON: HRRZ B,DSTORE
SKIPE DSTORE
HRRZ B,DSTORE ; POIT TO DOPE WORD
JUMPE B,CHRFIN
AOS (P)
CHRFIN: POPJ P,
LISTYP: GETYP A,(D)
MOVSI A,(A)
POPJ P,
1CHGT: MOVE B,D
ILDB B,B
POPJ P,
1CHINC: IBP D
SKIPN DSTORE
JRST 1CHIN1
SOS DSTORE
POPJ P,
1CHIN1: SOS DSTORE
POPJ P,
UTYPE: HLRE A,D
SUBM D,A
GETYP A,(A)
MOVSI A,(A)
POPJ P,
;COMPILER's CALL TO DOSEG
SEGMNT: PUSHJ P,TYPSEG
SEGLP1: SETZB A,B
SEGLOP: PUSHJ P,NXTELM
JRST SEGRET
AOS (P)-2 ; INCREMENT COMPILER'S COUNT
JRST SEGLOP
SEGRET: SETZM DSTORE
POPJ P,
SEGLST: PUSHJ P,TYPSEG
JUMPN C,SEGLS2
SEGLS3: SETZM DSTORE
MOVSI A,TLIST
SEGLS1: SOSGE -2(P) ; START COUNT DOWN
POPJ P,
MOVEI E,(B)
POP TP,D
POP TP,C
PUSHJ P,ICONS
JRST SEGLS1
SEGLS2: PUSHJ P,NXTELM
JRST SEGLS4
AOS -2(P)
JRST SEGLS2
SEGLS4: MOVEI B,0
JRST SEGLS3
;SPECBIND BINDS IDENTIFIERS. IT IS CALLED BY PUSHJ P,SPECBIND.
;SPECBIND IS PROVIDED WITH A CONTIGUOUS SET OF TRIPLETS ON TP.
;EACH TRIPLET IS AS FOLLOWS:
;THE FIRST ELEMENT IS THE IDENTIFIER TO BE BOUND, ITS TYPE WORD IS [TATOM,,-1],
;THE SECOND IS THE VALUE TO WHICH IT IS TO BE ASSIGNED,
;AND THE THIRD IS A PAIR OF ZEROES.
BNDA1: TATOM,,-2
BNDA: TATOM,,-1
BNDV: TVEC,,-1
USPECBIND:
MOVE E,TP
USPCBE: PUSH P,$TUBIND
JRST .+3
SPECBIND:
MOVE E,TP ;GET THE POINTER TO TOP
SPECBE: PUSH P,$TBIND
ADD E,[1,,1] ;BUMP POINTER ONCE
SETZB 0,D ;CLEAR TEMPS
PUSH P,0
MOVEI 0,(TB) ; FOR CHECKS
BINDLP: MOVE A,-4(E) ; CHECK FOR VEC BIND
CAMN A,BNDV
JRST NONID
MOVE A,-6(E) ;GET TYPE
CAME A,BNDA1 ; FOR UNSPECIAL
CAMN A,BNDA ;NORMAL ID BIND?
CAILE 0,-6(E) ; MAKE SURE NOT GOING UNDER FRAME
JRST SPECBD
SUB E,[6,,6] ;MOVE PTR
SKIPE D ;LINK?
HRRM E,(D) ;YES -- LOBBER
SKIPN (P) ;UPDATED?
MOVEM E,(P) ;NO -- DO IT
MOVE A,0(E) ;GET ATOM PTR
MOVE B,1(E)
PUSHJ P,SILOC ;GET LAST BINDING
MOVS A,OTBSAV (TB) ;GET TIME
HRL A,5(E) ; GET DECL POINTER
MOVEM A,4(E) ;CLOBBER IT AWAY
MOVE A,(E) ; SEE IF SPEC/UNSPEC
TRNN A,1 ; SKIP, ALWAYS SPEC
SKIPA A,-1(P) ; USE SUPPLIED
MOVSI A,TBIND
MOVEM A,(E) ;IDENTIFY AS BIND BLOCK
JUMPE B,SPEB10
MOVE PVP,PVSTOR+1
HRRZ C,SPBASE(PVP) ; CHECK FOR CROSS OF PROC
MOVEI A,(TP)
CAIL A,(B) ; LOSER
CAILE C,(B) ; SKIP IFF WINNER
MOVEI B,1
SPEB10: MOVEM B,5(E) ;IN RESTORE CELLS
MOVE C,1(E) ;GET ATOM PTR
SKIPE (C)
JUMPE B,.-4
MOVEI A,(C)
MOVEI B,0 ; FOR SPCUNP
CAIL A,HIBOT ; SKIP IF IMPURE ATOM
PUSHJ P,SPCUNP
MOVE PVP,PVSTOR+1
HRRZ A,BINDID+1(PVP) ;GET PROCESS NUMBER
HRLI A,TLOCI ;MAKE LOC PTR
MOVE B,E ;TO NEW VALUE
ADD B,[2,,2]
MOVEM A,(C) ;CLOBBER ITS VALUE
MOVEM B,1(C) ;CELL
MOVE D,E ;REMEMBER LINK
JRST BINDLP ;DO NEXT
NONID: CAILE 0,-4(E)
JRST SPECBD
SUB E,[4,,4]
SKIPE D
HRRM E,(D)
SKIPN (P)
MOVEM E,(P)
MOVE D,1(E) ;GET PTR TO VECTOR
MOVE C,(D) ;EXCHANGE TYPES
EXCH C,2(E)
MOVEM C,(D)
MOVE C,1(D) ;EXCHANGE DATUMS
EXCH C,3(E)
MOVEM C,1(D)
MOVEI A,TBVL
HRLM A,(E) ;IDENTIFY BIND BLOCK
MOVE D,E ;REMEMBER LINK
JRST BINDLP
SPECBD: SKIPE D
MOVE SP,SPSTOR+1
HRRM SP,(D)
SKIPE D,(P)
MOVEM D,SPSTOR+1
SUB P,[2,,2]
POPJ P,
; HERE TO IMPURIFY THE ATOM
SPCUNP: PUSH TP,$TSP
PUSH TP,E
PUSH TP,$TSP
PUSH TP,-1(P) ; LINK BACK IS AN SP
PUSH TP,$TSP
PUSH TP,B
CAIN B,1
SETZM -1(TP) ; FIXUP SOME FUNNYNESS
MOVE B,C
PUSHJ P,IMPURIFY
MOVE 0,-2(TP) ; RESTORE LINK BACK POINTER
MOVEM 0,-1(P)
MOVE E,-4(TP)
MOVE C,B
MOVE B,(TP)
SUB TP,[6,,6]
MOVEI 0,(TB)
POPJ P,
; ENTRY FROM COMPILER TO SET UP A BINDING
IBIND: MOVE SP,SPSTOR+1
SUBI E,-5(SP) ; CHANGE TO PDL POINTER
HRLI E,(E)
ADD E,SP
MOVEM C,-4(E)
MOVEM A,-3(E)
MOVEM B,-2(E)
HRLOI A,TATOM
MOVEM A,-5(E)
MOVSI A,TLIST
MOVEM A,-1(E)
MOVEM D,(E)
JRST SPECB1 ; NOW BIND IT
; "FAST CALL TO SPECBIND"
; Compiler's call to SPECBIND all atom bindings, no TBVLs etc.
SPECBND:
MOVE E,TP ; POINT TO BINDING WITH E
SPECB1: PUSH P,[0] ; SLOTS OF INTEREST
PUSH P,[0]
SUBM M,-2(P)
SPECB2: MOVEI 0,(TB) ; FOR FRAME CHECK
MOVE A,-5(E) ; LOOK AT FIRST THING
CAMN A,BNDA ; SKIP IF LOSER
CAILE 0,-5(E) ; SKIP IF REAL WINNER
JRST SPECB3
SUB E,[5,,5] ; POINT TO BINDING
SKIPE A,(P) ; LINK?
HRRM E,(A) ; YES DO IT
SKIPN -1(P) ; FIRST ONE?
MOVEM E,-1(P) ; THIS IS IT
MOVE A,1(E) ; POINT TO ATOM
MOVE PVP,PVSTOR+1
MOVE 0,BINDID+1(PVP) ; QUICK CHECK
HRLI 0,TLOCI
CAMN 0,(A) ; WINNERE?
JRST SPECB4 ; YES, GO ON
PUSH P,B ; SAVE REST OF ACS
PUSH P,C
PUSH P,D
MOVE B,A ; FOR ILOC TO WORK
PUSHJ P,SILOC ; GO LOOK IT UP
JUMPE B,SPECB9
MOVE PVP,PVSTOR+1
HRRZ C,SPBASE+1(PVP)
MOVEI A,(TP)
CAIL A,(B) ; SKIP IF LOSER
CAILE C,(B) ; SKIP IF WINNER
MOVEI B,1 ; SAY NO BACK POINTER
SPECB9: MOVE C,1(E) ; POINT TO ATOM
SKIPE (C) ; IF GLOBALLY BOUND, MAKE SURE OK
JUMPE B,.-3
MOVEI A,(C) ; PURE ATOM?
CAIGE A,HIBOT ; SKIP IF OK
JRST .+4
PUSH P,-4(P) ; MAKE HAPPINESS
PUSHJ P,SPCUNP ; IMPURIFY
POP P,-5(P)
MOVE PVP,PVSTOR+1
MOVE A,BINDID+1(PVP)
HRLI A,TLOCI
MOVEM A,(C) ; STOR POINTER INDICATOR
MOVE A,B
POP P,D
POP P,C
POP P,B
JRST SPECB5
SPECB4: MOVE A,1(A) ; GET LOCATIVE
SPECB5: EXCH A,5(E) ; CLOBBER INTO REBIND SLOT (GET DECL)
HLL A,OTBSAV(TB) ; TIME IT
MOVSM A,4(E) ; SAVE DECL AND TIME
MOVEI A,TBIND
HRLM A,(E) ; CHANGE TO A BINDING
MOVE A,1(E) ; POINT TO ATOM
MOVEM E,(P) ; REMEMBER THIS GUY
ADD E,[2,,2] ; POINT TO VAL CELL
MOVEM E,1(A) ; INTO ATOM SLOT
SUB E,[3,,3] ; POINT TO NEXT ONE
JRST SPECB2
SPECB3: SKIPE A,(P)
MOVE SP,SPSTOR+1
HRRM SP,(A) ; LINK OLD STUFF
SKIPE A,-1(P) ; NEW SP?
MOVEM A,SPSTOR+1
SUB P,[2,,2]
INTGO ; IN CASE BLEW STACK
SUBM M,(P)
POPJ P,
;SPECSTORE RESTORES THE BINDINGS SP TO THE ENVIRONMENT POINTER IN
;SPSAV (TB). IT IS CALLED BY PUSHJ P,SPECSTORE.
SPECSTORE:
PUSH P,E
HRRZ E,SPSAV (TB) ;GET TARGET POINTER
PUSHJ P,STLOOP
POP P,E
MOVE SP,SPSAV(TB) ; GET NEW SP
MOVEM SP,SPSTOR+1
POPJ P,
STLOOP: MOVE SP,SPSTOR+1
PUSH P,D
PUSH P,C
STLOO1: CAIL E,(SP) ;ARE WE DONE?
JRST STLOO2
HLRZ C,(SP) ;GET TYPE OF BIND
CAIN C,TUBIND
JRST .+3
CAIE C,TBIND ;NORMAL IDENTIFIER?
JRST ISTORE ;NO -- SPECIAL HACK
MOVE C,1(SP) ;GET TOP ATOM
MOVSI 0,TLOCI ; MAYBE LOCI OR UNBOUND
SKIPL D,5(SP)
MOVSI 0,TUNBOU
MOVE PVP,PVSTOR+1
HRR 0,BINDID+1(PVP) ;STORE SIGNATURE
SKIPN 5(SP)
MOVEI 0,0 ; TOTALLY UNBOUND IN ALL CASES
MOVEM 0,(C) ;CLOBBER INTO ATOM
MOVEM D,1(C)
SETZM 4(SP)
SPLP: HRRZ SP,(SP) ;FOLOW LINK
JUMPN SP,STLOO1 ;IF MORE
SKIPE E ; OK IF E=0
FATAL SP OVERPOP
STLOO2: MOVEM SP,SPSTOR+1
POP P,C
POP P,D
POPJ P,
ISTORE: CAIE C,TBVL
JRST CHSKIP
MOVE C,1(SP)
MOVE D,2(SP)
MOVEM D,(C)
MOVE D,3(SP)
MOVEM D,1(C)
JRST SPLP
CHSKIP: CAIN C,TSKIP
JRST SPLP
CAIE C,TUNWIN ; UNWIND HACK
FATAL BAD SP
HRRZ C,-2(P) ; WHERE FROM?
CAIE C,CHUNPC
JRST SPLP ; IGNORE
MOVEI E,(TP) ; FIXUP SP
SUBI E,(SP)
MOVSI E,(E)
HLL SP,TP
SUB SP,E
POP P,C
POP P,D
AOS (P)
POPJ P,
; ENTRY FOR FUNNY COMPILER UNBIND (1)
SSPECS: PUSH P,E
MOVEI E,(TP)
PUSHJ P,STLOOP
SSPEC2: SUBI E,(SP) ; MAKE SP BE AOBJN
MOVSI E,(E)
HLL SP,TP
SUB SP,E
MOVEM SP,SPSTOR+1
POP P,E
POPJ P,
; ENTRY FOR FUNNY COMPILER UNBIND (2)
SSPEC1: PUSH P,E
SUBI E,1 ; MAKE SURE GET CURRENT BINDING
PUSHJ P,STLOOP ; UNBIND
MOVEI E,(TP) ; NOW RESET SP
JRST SSPEC2
EFINIS: MOVE PVP,PVSTOR+1
SKIPN C,1STEPR+1(PVP) ; SKIP NIF BEING ONE PROCEEDED
JRST FINIS
PUSH TP,$TATOM
PUSH TP,MQUOTE EVLOUT
PUSH TP,A ;SAVE EVAL RESULTS
PUSH TP,B
PUSH TP,[TINFO,,2] ; FENCE POST
PUSHJ P,TBTOTP
PUSH TP,D
PUSHJ P,MAKINF ; MAKE ARG BLOCK INFO
PUSH TP,A
MOVEI B,-6(TP)
HRLI B,-4 ; AOBJN TO ARGS BLOCK
PUSH TP,B
MOVE PVP,PVSTOR+1
PUSH TP,1STEPR(PVP)
PUSH TP,1STEPR+1(PVP) ; PROCESS DOING THE 1STEPPING
MCALL 2,RESUME
MOVE A,-3(TP) ; GET BACK EVAL VALUE
MOVE B,-2(TP)
JRST FINIS
1STEPI: PUSH TP,$TATOM
PUSH TP,MQUOTE EVLIN
PUSH TP,$TAB ; PUSH EVALS ARGGS
PUSH TP,AB
PUSHJ P,MAKINF ; TURN INTO ARGS BLOCK
MOVEM A,-1(TP) ; AND CLOBBER
PUSH TP,[TINFO,,2] ; FENCE POST 2D TUPLE
PUSHJ P,TBTOTP
PUSH TP,D
PUSHJ P,MAKINF ; TURN IT INTO ARGS BLOCK
PUSH TP,A
MOVEI B,-6(TP) ; SETUP TUPLE
HRLI B,-4
PUSH TP,B
MOVE PVP,PVSTOR+1
PUSH TP,1STEPR(PVP)
PUSH TP,1STEPR+1(PVP)
MCALL 2,RESUME ; START UP 1STEPERR
SUB TP,[6,,6] ; REMOVE CRUD
GETYP A,A ; GET 1STEPPERS TYPE
CAIE A,TDISMI ; IF DISMISS, STOP 1 STEPPING
JRST EVALON
; HERE TO PUSH DOWN THE 1 STEP STATE AND RUN
MOVE D,PVP
ADD D,[1STEPR,,1STEPR] ; POINT TO 1 STEP SLOT
PUSH TP,$TSP ; SAVE CURRENT SP
PUSH TP,SPSTOR+1
PUSH TP,BNDV
PUSH TP,D ; BIND IT
PUSH TP,$TPVP
PUSH TP,[0] ; NO 1 STEPPER UNTIL POPJ
PUSHJ P,SPECBIND
; NOW PUSH THE ARGS UP TO RE-CALL EVAL
MOVEI A,0
EFARGL: JUMPGE AB,EFCALL
PUSH TP,(AB)
PUSH TP,1(AB)
ADD AB,[2,,2]
AOJA A,EFARGL
EFCALL: ACALL A,EVAL ; NOW DO THE EVAL
MOVE C,(TP) ; PRE-UNBIND
MOVE PVP,PVSTOR+1
MOVEM C,1STEPR+1(PVP)
MOVE SP,-4(TP) ; AVOID THE UNBIND
MOVEM SP,SPSTOR+1
SUB TP,[6,,6] ; AND FLUSH LOSERS
JRST EFINIS ; AND TRY TO FINISH UP
MAKINF: HLRZ A,OTBSAV(TB) ; TIME IT
HRLI A,TARGS
POPJ P,
TBTOTP: MOVEI D,(TB) ; COMPUTE REL DIST FROM TP TO TB
SUBI D,(TP)
POPJ P,
; ARRIVE HERE TO COMPLETE A COMPILER GENERATED TUPLE
; D/ LENGTH OF THE TUPLE IN WORDS
MAKTU2: MOVE D,-1(P) ; GET LENGTH
ASH D,1
PUSHJ P,MAKTUP
PUSH TP,A
PUSH TP,B
POPJ P,
MAKTUP: HRLI D,TINFO ; FIRST WORD OF FENCE POST
PUSH TP,D
HRROI B,(TP) ; TOP OF TUPLE
SUBI B,(D)
TLC B,-1(D) ; AOBJN IT
PUSHJ P,TBTOTP
PUSH TP,D
HLRZ A,OTBSAV(TB) ; TIME IT
HRLI A,TARGS
POPJ P,
; HERE TO ALLOCATE SLOTS FOR COMPILER (AMNT IN A)
TPALOC: SUBM M,(P)
;Once here ==>ADDI A,1 Bug???
HRLI A,(A)
ADD TP,A
PUSH P,A
SKIPL TP
PUSHJ P,TPOVFL ; IN CASE IT LOST
INTGO ; TAKE THE GC IF NEC
HRRI A,2(TP)
SUB A,(P)
SETZM -1(A)
HRLI A,-1(A)
BLT A,(TP)
SUB P,[1,,1]
JRST POPJM
NTPALO: PUSH TP,[0]
SOJG 0,.-1
POPJ P,
;EVALUATES A IDENTIFIER -- GETS LOCAL VALUE IF THERE IS ONE, OTHERWISE GLOBAL.
IMFUNCTION VALUE,SUBR
JSP E,CHKAT
PUSHJ P,IDVAL
JRST FINIS
IDVAL: PUSHJ P,IDVAL1
CAMN A,$TUNBOU
JRST UNBOU
POPJ P,
IDVAL1: PUSH TP,A
PUSH TP,B ;SAVE ARG IN CASE NEED TO CHECK GLOBAL VALUE
PUSHJ P,ILVAL ;LOCAL VALUE FINDER
CAME A,$TUNBOUND ;IF NOT UNBOUND OR UNASSIGNED
JRST RIDVAL ;DONE - CLEAN UP AND RETURN
POP TP,B ;GET ARG BACK
POP TP,A
JRST IGVAL
RIDVAL: SUB TP,[2,,2]
POPJ P,
;GETS THE LOCAL VALUE OF AN IDENTIFIER
IMFUNCTION LVAL,SUBR
JSP E,CHKAT
PUSHJ P,AILVAL
CAME A,$TUNBOUND
JRST FINIS
JUMPN B,UNAS
JRST UNBOU
; MAKE AN ATOM UNASSIGNED
MFUNCTION UNASSIGN,SUBR
JSP E,CHKAT ; GET ATOM ARG
PUSHJ P,AILOC
UNASIT: CAMN A,$TUNBOU ; IF UNBOUND
JRST RETATM
MOVSI A,TUNBOU
MOVEM A,(B)
SETOM 1(B) ; MAKE SURE
RETATM: MOVE B,1(AB)
MOVE A,(AB)
JRST FINIS
; UNASSIGN GLOBALLY
MFUNCTION GUNASSIGN,SUBR
JSP E,CHKAT2
PUSHJ P,IGLOC
CAMN A,$TUNBOU
JRST RETATM
MOVE B,1(AB) ; ATOM BACK
MOVEI 0,(B)
CAIL 0,HIBOT ; SKIP IF IMPURE
PUSHJ P,IMPURIFY ; YES, MAKE IT IMPURE
PUSHJ P,IGLOC ; RESTORE LOCATIVE
HRRZ 0,-2(B) ; SEE IF MANIFEST
GETYP A,(B) ; AND CURRENT TYPE
CAIN 0,-1
CAIN A,TUNBOU
JRST UNASIT
SKIPE IGDECL
JRST UNASIT
MOVE D,B
JRST MANILO
; GETS A LOCATIVE TO THE LOCAL VALUE OF AN IDENTIFIER.
MFUNCTION LLOC,SUBR
JSP E,CHKAT
PUSHJ P,AILOC
CAMN A,$TUNBOUND
JRST UNBOU
MOVSI A,TLOCD
HRR A,2(B)
JRST FINIS
;TESTS TO SEE IF AN IDENTIFIER IS LOCALLY BOUND
MFUNCTION BOUND,SUBR,[BOUND?]
JSP E,CHKAT
PUSHJ P,AILVAL
CAMN A,$TUNBOUND
JUMPE B,IFALSE
JRST TRUTH
;TESTS TO SEE IF AN IDENTIFIER IS LOCALLY ASSIGNED
MFUNCTION ASSIGP,SUBR,[ASSIGNED?]
JSP E,CHKAT
PUSHJ P,AILVAL
CAME A,$TUNBOUND
JRST TRUTH
; JUMPE B,UNBOU
JRST IFALSE
;GETS THE GLOBAL VALUE OF AN IDENTIFIER
IMFUNCTION GVAL,SUBR
JSP E,CHKAT2
PUSHJ P,IGVAL
CAMN A,$TUNBOUND
JRST UNAS
JRST FINIS
;GETS A LOCATIVE TO THE GLOBAL VALUE OF AN IDENTIFIER
MFUNCTION RGLOC,SUBR
JRST GLOC
MFUNCTION GLOC,SUBR
JUMPGE AB,TFA
CAMGE AB,[-5,,]
JRST TMA
JSP E,CHKAT1
MOVEI E,IGLOC
CAML AB,[-2,,]
JRST .+4
GETYP 0,2(AB)
CAIE 0,TFALSE
MOVEI E,IIGLOC
PUSHJ P,(E)
CAMN A,$TUNBOUND
JRST UNAS
MOVSI A,TLOCD
HRRZ 0,FSAV(TB)
CAIE 0,GLOC
MOVSI A,TLOCR
CAIE 0,GLOC
SUB B,GLOTOP+1
MOVE C,1(AB) ; GE ATOM
MOVEI 0,(C)
CAIGE 0,HIBOT ; SKIP IF PURE ATOM
JRST FINIS
; MAKE ATOM AND VALUE IMPURE IF GETTING GLOC TO IT
MOVE B,C ; ATOM TO B
PUSHJ P,IMPURIFY
JRST GLOC ; AND TRY AGAIN
;TESTS TO SEE IF AN IDENTIFIER IS GLOBALLY ASSIGNED
MFUNCTION GASSIG,SUBR,[GASSIGNED?]
JSP E,CHKAT2
PUSHJ P,IGVAL
CAMN A,$TUNBOUND
JRST IFALSE
JRST TRUTH
; TEST FOR GLOBALLY BOUND
MFUNCTION GBOUND,SUBR,[GBOUND?]
JSP E,CHKAT2
PUSHJ P,IGLOC
JUMPE B,IFALSE
JRST TRUTH
CHKAT2: ENTRY 1
CHKAT1: GETYP A,(AB)
MOVSI A,(A)
CAME A,$TATOM
JRST NONATM
MOVE B,1(AB)
JRST (E)
CHKAT: HLRE A,AB ; - # OF ARGS
ASH A,-1 ; TO ACTUAL WORDS
JUMPGE AB,TFA
MOVE C,SPSTOR+1 ; FOR BINDING LOOKUPS
AOJE A,CHKAT1 ; ONLY ONE ARG, NO ENVIRONMENT
AOJL A,TMA ; TOO MANY
GETYP A,2(AB) ; MAKE SURE OF TENV OR TFRAME
CAIE A,TFRAME
CAIN A,TENV
JRST CHKAT3
CAIN A,TACT ; FOR PFISTERS LOSSAGE
JRST CHKAT3
CAIE A,TPVP ; OR PROCESS
JRST WTYP2
MOVE B,3(AB) ; GET PROCESS
MOVE C,SPSTOR+1 ; IN CASE ITS ME
CAME B,PVSTOR+1 ; SKIP IF DIFFERENT
MOVE C,SPSTO+1(B) ; GET ITS SP
JRST CHKAT1
CHKAT3: MOVEI B,2(AB) ; POINT TO FRAME POINTER
PUSHJ P,CHFRM ; VALIDITY CHECK
MOVE B,3(AB) ; GET TB FROM FRAME
MOVE C,SPSAV(B) ; GET ENVIRONMENT POINTER
JRST CHKAT1
; SILOC--CALLS ILOC IGNORING SPECIAL CHECKING
SILOC: JFCL
;ILOC RETURNS IN A AND B A LOCATIVE TO THE LOCAL VALUE OF THE IDENTIFIER
; PASSED TO IT IN A AND B. IF THE IDENTIFIER IS LOCALLY UNBOUND IT RETURNS
; $TUNBOUND IN A AND 0 IN B, IT IS CALLED BY PUSHJ P,ILOC.
ILOC: MOVE C,SPSTOR+1 ; SETUP SEARCH START
AILOC: SKIPN (B) ; ANY KIND OF VALUE AT ALL?
JUMPN B,FUNPJ
MOVSI A,TLOCI ;MAKE A LOCATIVE TYPE CELL
PUSH P,E
PUSH P,D
MOVEI E,0 ; FLAG TO CLOBBER ATOM
JUMPE B,SCHSP ; IF LOOKING FOR SLOT, SEARCH NOW
CAME C,SPSTOR+1 ; ENVIRONMENT CHANGE?
JRST SCHSP ; YES, MUST SEARCH
MOVE PVP,PVSTOR+1
HRR A,BINDID+1(PVP) ;FOR THE CURRENT PROCESS
CAME A,(B) ;IS THERE ONE IN THE VALUE CELL?
JRST SCHLP ;NO -- SEARCH THE LOCAL BINDINGS
MOVE B,1(B) ;YES -- GET LOCATIVE POINTER
MOVE C,PVP
ILCPJ: MOVE E,SPCCHK
TRNN E,1 ; SKIP IF DOING SPEC UNSPEC CHECK
JRST ILOCPJ
HRRZ E,-2(P) ; IF IGNORING, IGNORE
HRRZ E,-1(E)
CAIN E,SILOC
JRST ILOCPJ
HLRZ E,-2(B)
CAIE E,TUBIND
JRST ILOCPJ
CAMGE B,CURFCN+1(PVP)
JRST SCHLPX
MOVEI D,-2(B)
HRRZ SP,SPSTOR+1
CAIG D,(SP)
CAMGE B,SPBASE+1(PVP)
JRST SCHLPX
MOVE C,PVSTOR+1
ILOCPJ: POP P,D
POP P,E
POPJ P, ;FROM THE VALUE CELL
SCHLPX: MOVEI E,1
MOVE C,SPSTOR+1
MOVE B,-1(B)
JRST SCHLP
SCHLP5: SETOM (P)
JRST SCHLP2
SCHLP: MOVEI D,(B)
CAIL D,HIBOT ; SKIP IF IMPURE ATOM
SCHSP: MOVEI E,1 ; DONT STORE LOCATIVE
PUSH P,E ; PUSH SWITCH
MOVE E,PVSTOR+1 ; GET PROC
SCHLP1: JUMPE C,UNPJ ;IF NO MORE -- LOSE
CAMN B,1(C) ;ARE WE POINTING AT THE WINNER?
JRST SCHFND ;YES
GETYP D,(C) ; CHECK SKIP
CAIE D,TSKIP
JRST SCHLP2
PUSH P,B ; CHECK DETOUR
MOVEI B,2(C)
PUSHJ P,CHFRAM ; NON-FATAL FRAME CHECKER
HRRZ E,2(C) ; CONS UP PROCESS
SUBI E,PVLNT*2+1
HRLI E,-2*PVLNT
JUMPE B,SCHLP3 ; LOSER, FIX IT
POP P,B
MOVEI C,1(C) ; FOLLOW LOOKUP CHAIN
SCHLP2: HRRZ C,(C) ;FOLLOW LINK
JRST SCHLP1
SCHLP3: POP P,B
HRRZ SP,SPSTOR+1
MOVEI C,(SP) ; *** NDR'S BUG ***
CAME E,PVSTOR+1 ; USE IF CURRENT PROCESS
HRRZ C,SPSTO+1(E) ; USE CURRENT SP FOR PROC
JRST SCHLP1
SCHFND: MOVE D,SPCCHK
TRNN D,1 ; SKIP IF DOING SPEC UNSPEC CHECK
JRST SCHFN1
HRRZ D,-2(P) ; IF IGNORING, IGNORE
HRRZ D,-1(D)
CAIN D,SILOC
JRST ILOCPJ
HLRZ D,(C)
CAIE D,TUBIND
JRST SCHFN1
HRRZ D,CURFCN+1(PVP)
CAIL D,(C)
JRST SCHLP5
HRRZ SP,SPSTOR+1
HRRZ D,SPBASE+1(PVP)
CAIL SP,(C)
CAIL D,(C)
JRST SCHLP5
SCHFN1: EXCH B,C ;SAVE THE ATOM PTR IN C
MOVEI B,2(B) ;MAKE UP THE LOCATIVE
SUB B,TPBASE+1(E)
HRLI B,(B)
ADD B,TPBASE+1(E)
EXCH C,E ; RET PROCESS IN C
POP P,D ; RESTORE SWITCH
JUMPN D,ILOCPJ ; DONT CLOBBER ATOM
MOVEM A,(E) ;CLOBBER IT AWAY INTO THE
MOVE D,1(E) ; GET OLD POINTER
MOVEM B,1(E) ;ATOM'S VALUE CELL
JUMPE D,ILOCPJ ; IF POINTS TO GLOBAL OR OTHER PROCES
; MAKE SURE BINDING SO INDICATES
MOVE D,B ; POINT TO BINDING
SKIPL E,3(D) ; GO TO FIRST ONE, JUST IN CASE
JRST .+3
MOVE D,E
JRST .-3 ; LOOP THROUGH
MOVEI E,1
MOVEM E,3(D) ; MAGIC INDICATION
JRST ILOCPJ
UNPJ: SUB P,[1,,1] ; FLUSH CRUFT
UNPJ1: MOVE C,E ; RET PROCESS ANYWAY
UNPJ11: POP P,D
POP P,E
UNPOPJ: MOVSI A,TUNBOUND
MOVEI B,0
POPJ P,
FUNPJ: MOVE C,PVSTOR+1
JRST UNPOPJ
;IGLOC RETURNS IN A AND B A LOCATIVE TO THE GLOBAL VALUE OF THE
;IDENTIFIER PASSED TO IT IN A AND B. IF THE IDENTIFIER IS GLOBALLY
;UNBPOUND IT RETURNS $TUNBOUND IN A AND 0 IN B. IT IS CALLED BY PUSHJ P,IGLOC.
IGLOC: MOVSI A,TLOCI ;DO WE HAVE A LOCATIVE TO
CAME A,(B) ;A PROCESS #0 VALUE?
JRST SCHGSP ;NO -- SEARCH
MOVE B,1(B) ;YES -- GET VALUE CELL
POPJ P,
SCHGSP: SKIPN (B)
JRST UNPOPJ
MOVE D,GLOBSP+1 ;GET GLOBAL SP PTR
SCHG1: JUMPGE D,UNPOPJ ;IF NO MORE, LEAVE
CAMN B,1(D) ;ARE WE FOUND?
JRST GLOCFOUND ;YES
ADD D,[4,,4] ;NO -- TRY NEXT
JRST SCHG1
GLOCFOUND:
EXCH B,D ;SAVE ATOM PTR
ADD B,[2,,2] ;MAKE LOCATIVE
MOVEI 0,(D)
CAIL 0,HIBOT
POPJ P,
MOVEM A,(D) ;CLOBBER IT AWAY
MOVEM B,1(D)
POPJ P,
IIGLOC: PUSH TP,$TATOM
PUSH TP,B
PUSHJ P,IGLOC
MOVE C,(TP)
SUB TP,[2,,2]
GETYP 0,A
CAIE 0,TUNBOU
POPJ P,
PUSH TP,$TATOM
PUSH TP,C
MOVEI 0,(C)
MOVE B,C
CAIL 0,$TLOSE
PUSHJ P,IMPURI ; IMPURIFY THE POOR ATOM
PUSHJ P,BSETG ; MAKE A SLOT
SETOM 1(B) ; UNBOUNDIFY IT
MOVSI A,TLOCD
MOVSI 0,TUNBOU
MOVEM 0,(B)
SUB TP,[2,,2]
POPJ P,
;ILVAL RETURNS IN A AND B THE LOCAL VALUE OF THE IDENTIFIER PASSED TO IT IN A AND B
;IF THE IDENTIFIER IS UNBOUND ITS VALUE IS $TUNBOUND IN A AND 0 IN B. IF
;IT IS UNASSIGNED ITS VALUE IS $TUNBOUND IN A AND -1 IN B. CALL - PUSHJ P,IVAL
AILVAL:
PUSHJ P,AILOC ; USE SUPPLIED SP
JRST CHVAL
ILVAL:
PUSHJ P,ILOC ;GET LOCATIVE TO VALUE
CHVAL: CAMN A,$TUNBOUND ;BOUND
POPJ P, ;NO -- RETURN
MOVSI A,TLOCD ; GET GOOD TYPE
HRR A,2(B) ; SHOULD BE TIME OR 0
PUSH P,0
PUSHJ P,RMONC0 ; CHECK READ MONITOR
POP P,0
MOVE A,(B) ;GET THE TYPE OF THE VALUE
MOVE B,1(B) ;GET DATUM
POPJ P,
;IGVAL -- LIKE ILVAL EXCEPT FOR GLOBAL VALUES
IGVAL: PUSHJ P,IGLOC
JRST CHVAL
; COMPILERS INTERFACE TO LVAL/GVAL/SETG/SET
CILVAL: MOVE PVP,PVSTOR+1
MOVE 0,BINDID+1(PVP) ; CURRENT BIND
HRLI 0,TLOCI
CAME 0,(B) ; HURRAY FOR SPEED
JRST CILVA1 ; TOO BAD
MOVE C,1(B) ; POINTER
MOVE A,(C) ; VAL TYPE
TLNE A,.RDMON ; MONITORS?
JRST CILVA1
GETYP 0,A
CAIN 0,TUNBOU
JRST CUNAS ; COMPILER ERROR
MOVE B,1(C) ; GOT VAL
MOVE 0,SPCCHK
TRNN 0,1
POPJ P,
HLRZ 0,-2(C) ; SPECIAL CHECK
CAIE 0,TUBIND
POPJ P, ; RETURN
MOVE PVP,PVSTOR+1
CAMGE C,CURFCN+1(PVP)
JRST CUNAS
POPJ P,
CUNAS:
CILVA1: SUBM M,(P) ; FIX (P)
PUSH TP,$TATOM ; SAVE ATOM
PUSH TP,B
MCALL 1,LVAL ; GET ERROR/MONITOR
POPJM: SUBM M,(P) ; REPAIR DAMAGE
POPJ P,
; COMPILERS INTERFACE TO SET C/ ATOM A,B/ NEW VALUE
CISET: MOVE PVP,PVSTOR+1
MOVE 0,BINDID+1(PVP) ; CURRENT BINDING ENVIRONMENT
HRLI 0,TLOCI
CAME 0,(C) ; CAN WE WIN?
JRST CISET1 ; NO, MORE HAIR
MOVE D,1(C) ; POINT TO SLOT
CISET3: HLLZ 0,(D) ; MON CHECK
TLNE 0,.WRMON
JRST CISET4 ; YES, LOSE
TLZ 0,TYPMSK
IOR A,0 ; LEAVE MONITOR ON
MOVE 0,SPCCHK
TRNE 0,1
JRST CISET5 ; SPEC/UNSPEC CHECK
CISET6: MOVEM A,(D) ; STORE
MOVEM B,1(D)
POPJ P,
CISET5: HLRZ 0,-2(D)
CAIE 0,TUBIND
JRST CISET6
MOVE PVP,PVSTOR+1
CAMGE D,CURFCN+1(PVP)
JRST CISET4
JRST CISET6
CISET1: SUBM M,(P) ; FIX ADDR
PUSH TP,$TATOM ; SAVE ATOM
PUSH TP,C
PUSH TP,A
PUSH TP,B
MOVE B,C ; GET ATOM
PUSHJ P,ILOC ; SEARCH
MOVE D,B ; POSSIBLE POINTER
GETYP E,A
MOVE 0,A
MOVE A,-1(TP) ; VAL BACK
MOVE B,(TP)
CAIE E,TUNBOU ; SKIP IF WIN
JRST CISET2 ; GO CLOBBER IT IN
MCALL 2,SET
JRST POPJM
CISET2: MOVE C,-2(TP) ; ATOM BACK
SUBM M,(P) ; RESET (P)
SUB TP,[4,,4]
JRST CISET3
; HERE TO DO A MONITORED SET
CISET4: SUBM M,(P) ; AGAIN FIX (P)
PUSH TP,$TATOM
PUSH TP,C
PUSH TP,A
PUSH TP,B
MCALL 2,SET
JRST POPJM
; COMPILER LLOC
CLLOC: MOVE PVP,PVSTOR+1
MOVE 0,BINDID+1(PVP) ; GET CURRENT LOCATIVE
HRLI 0,TLOCI
CAME 0,(B) ; WIN?
JRST CLLOC1
MOVE B,1(B)
MOVE 0,SPCCHK
TRNE 0,1 ; SKIP IF NOT CHECKING
JRST CLLOC9
CLLOC3: MOVSI A,TLOCD
HRR A,2(B) ; GET BIND TIME
POPJ P,
CLLOC1: SUBM M,(P)
PUSH TP,$TATOM
PUSH TP,B
PUSHJ P,ILOC ; LOOK IT UP
JUMPE B,CLLOC2
SUB TP,[2,,2]
CLLOC4: SUBM M,(P)
JRST CLLOC3
CLLOC2: MCALL 1,LLOC
JRST CLLOC4
CLLOC9: HLRZ 0,-2(B)
CAIE 0,TUBIND
JRST CLLOC3
MOVE PVP,PVSTOR+1
CAMGE B,CURFCN+1(PVP)
JRST CLLOC2
JRST CLLOC3
; COMPILER BOUND?
CBOUND: SUBM M,(P)
PUSHJ P,ILOC
JUMPE B,PJFALS ; IF UNBOUND RET FALSE AND NO SSKIP
PJT1: SOS (P)
MOVSI A,TATOM
MOVE B,IMQUOTE T
JRST POPJM
PJFALS: MOVEI B,0
MOVSI A,TFALSE
JRST POPJM
; COMPILER ASSIGNED?
CASSQ: SUBM M,(P)
PUSHJ P,ILOC
JUMPE B,PJFALS
GETYP 0,(B)
CAIE 0,TUNBOU
JRST PJT1
JRST PJFALS
; COMPILER GVAL B/ ATOM
CIGVAL: MOVE 0,(B) ; GLOBAL VAL HERE?
CAME 0,$TLOCI ; TIME=0 ,TYPE=TLOCI => GLOB VAL
JRST CIGVA1 ; NO, GO LOOK
MOVE C,1(B) ; POINT TO SLOT
MOVE A,(C) ; GET TYPE
TLNE A,.RDMON
JRST CIGVA1
GETYP 0,A ; CHECK FOR UNBOUND
CAIN 0,TUNBOU ; SKIP IF WINNER
JRST CGUNAS
MOVE B,1(C)
POPJ P,
CGUNAS:
CIGVA1: SUBM M,(P)
PUSH TP,$TATOM
PUSH TP,B
.MCALL 1,GVAL ; GET ERROR/MONITOR
JRST POPJM
; COMPILER INTERFACET TO SETG
CSETG: MOVE 0,(C) ; GET V CELL
CAME 0,$TLOCI ; SKIP IF FAST
JRST CSETG1
HRRZ D,1(C) ; POINT TO SLOT
MOVE 0,(D) ; OLD VAL
CSETG3: CAIG D,HIBOT ; SKIP IF PURE ATOM
TLNE 0,.WRMON ; MONITOR
JRST CSETG2
MOVEM A,(D)
MOVEM B,1(D)
POPJ P,
CSETG1: SUBM M,(P) ; FIX UP P
PUSH TP,$TATOM
PUSH TP,C
PUSH TP,A
PUSH TP,B
MOVE B,C
PUSHJ P,IGLOC ; FIND GLOB LOCATIVE
GETYP E,A
MOVE 0,A
MOVEI D,(B) ; SETUP TO RESTORE NEW VAL
MOVE A,-1(TP)
MOVE B,(TP)
CAIE E,TUNBOU
JRST CSETG4
MCALL 2,SETG
JRST POPJM
CSETG4: MOVE C,-2(TP) ; ATOM BACK
SUBM M,(P) ; RESET (P)
SUB TP,[4,,4]
JRST CSETG3
CSETG2: SUBM M,(P)
PUSH TP,$TATOM ; CAUSE A SETG MONITOR
PUSH TP,C
PUSH TP,A
PUSH TP,B
MCALL 2,SETG
JRST POPJM
; COMPILER GLOC
CGLOC: MOVE 0,(B) ; GET CURRENT GUY
CAME 0,$TLOCI ; WIN?
JRST CGLOC1 ; NOPE
HRRZ D,1(B) ; POINT TO SLOT
CAILE D,HIBOT ; PURE?
JRST CGLOC1
MOVE A,$TLOCD
MOVE B,1(B)
POPJ P,
CGLOC1: SUBM M,(P)
PUSH TP,$TATOM
PUSH TP,B
MCALL 1,GLOC
JRST POPJM
; COMPILERS GASSIGNED?
CGASSQ: MOVE 0,(B)
SUBM M,(P)
CAMN 0,$TLOCD
JRST PJT1
PUSHJ P,IGLOC
JUMPE B,PJFALS
GETYP 0,(B)
CAIE 0,TUNBOU
JRST PJT1
JRST PJFALS
; COMPILERS GBOUND?
CGBOUN: MOVE 0,(B)
SUBM M,(P)
CAMN 0,$TLOCD
JRST PJT1
PUSHJ P,IGLOC
JUMPE B,PJFALS
JRST PJT1
IMFUNCTION REP,FSUBR,[REPEAT]
JRST PROG
MFUNCTION BIND,FSUBR
JRST PROG
IMFUNCTION PROG,FSUBR
ENTRY 1
GETYP A,(AB) ;GET ARG TYPE
CAIE A,TLIST ;IS IT A LIST?
JRST WRONGT ;WRONG TYPE
SKIPN C,1(AB) ;GET AND CHECK ARGUMENT
JRST TFA ;TOO FEW ARGS
SETZB E,D ; INIT HEWITT ATOM AND DECL
PUSHJ P,CARATC ; IS 1ST THING AN ATOM
JFCL
PUSHJ P,RSATY1 ; CDR AND GET TYPE
CAIE 0,TLIST ; MUST BE LIST
JRST MPD.13
MOVE B,1(C) ; GET ARG LIST
PUSH TP,$TLIST
PUSH TP,C
PUSHJ P,RSATYP
CAIE 0,TDECL
JRST NOP.DC ; JUMP IF NO DCL
MOVE D,1(C)
MOVEM C,(TP)
PUSHJ P,RSATYP ; CDR ON
NOP.DC: PUSH TP,$TLIST
PUSH TP,B ; AND ARG LIST
PUSHJ P,PRGBND ; BIND AUX VARS
HRRZ E,FSAV(TB)
CAIE E,BIND
SKIPA E,IMQUOTE LPROG,[LPROG ]INTRUP
JRST .+3
PUSHJ P,MAKACT ; MAKE ACTIVATION
PUSHJ P,PSHBND ; BIND AND CHECK
PUSHJ P,SPECBI ; NAD BIND IT
; HERE TO RUN PROGS FUNCTIONS ETC.
DOPROG: MOVEI A,REPROG
HRLI A,TDCLI ; FLAG AS FUNNY
MOVEM A,(TB) ; WHERE TO AGAIN TO
MOVE C,1(TB)
MOVEM C,3(TB) ; RESTART POINTER
JRST .+2 ; START BY SKIPPING DECL
DOPRG1: PUSHJ P,FASTEV
HRRZ C,@1(TB) ;GET THE REST OF THE BODY
DOPRG2: MOVEM C,1(TB)
JUMPN C,DOPRG1
ENDPROG:
HRRZ C,FSAV(TB)
CAIN C,REP
REPROG: SKIPN C,@3(TB)
JRST PFINIS
HRRZM C,1(TB)
INTGO
MOVE C,1(TB)
JRST DOPRG1
PFINIS: GETYP 0,(TB)
CAIE 0,TDCLI ; DECL'D ?
JRST PFINI1
HRRZ 0,(TB) ; SEE IF RSUBR
JUMPE 0,RSBVCK ; CHECK RSUBR VALUE
HRRZ C,3(TB) ; GET START OF FCN
GETYP 0,(C) ; CHECK FOR DECL
CAIE 0,TDECL
JRST PFINI1 ; NO, JUST RETURN
MOVE E,IMQUOTE VALUE
PUSHJ P,PSHBND ; BUILD FAKE BINDING
MOVE C,1(C) ; GET DECL LIST
MOVE E,TP
PUSHJ P,CHKDCL ; AND CHECK IT
MOVE A,-3(TP) ; GET VAL BAKC
MOVE B,-2(TP)
SUB TP,[6,,6]
PFINI1: HRRZ C,FSAV(TB)
CAIE C,EVAL
JRST FINIS
JRST EFINIS
RSATYP: HRRZ C,(C)
RSATY1: JUMPE C,TFA
GETYP 0,(C)
POPJ P,
; HERE TO CHECK RSUBR VALUE
RSBVCK: PUSH TP,A
PUSH TP,B
MOVE C,A
MOVE D,B
MOVE A,1(TB) ; GET DECL
MOVE B,1(A)
HLLZ A,(A)
PUSHJ P,TMATCH
JRST RSBVC1
POP TP,B
POP TP,A
POPJ P,
RSBVC1: MOVE C,1(TB)
POP TP,B
POP TP,D
MOVE A,IMQUOTE VALUE
JRST TYPMIS
MFUNCTION MRETUR,SUBR,[RETURN]
ENTRY
HLRE A,AB ; GET # OF ARGS
ASH A,-1 ; TO NUMBER
AOJL A,RET2 ; 2 OR MORE ARGS
PUSHJ P,PROGCH ;CHECK IN A PROG
PUSH TP,A
PUSH TP,B
MOVEI B,-1(TP) ; VERIFY IT
COMRET: PUSHJ P,CHFSWP
SKIPL C ; ARGS?
MOVEI C,0 ; REAL NONE
PUSHJ P,CHUNW
JUMPN A,CHFINI ; WINNER
MOVSI A,TATOM
MOVE B,IMQUOTE T
; SEE IF MUST CHECK RETURNS TYPE
CHFINI: GETYP 0,(TB) ; SPECIAL TYPE IF SO
CAIE 0,TDCLI
JRST FINIS ; NO, JUST FINIS
MOVEI 0,PFINIS ; CAUSE TO FALL INTO FUNCTION CODE
HRRM 0,PCSAV(TB)
JRST CONTIN
RET2: AOJL A,TMA
GETYP A,(AB)+2
CAIE A,TACT ; AS FOR "EXIT" SHOULD BE ACTIVATION
JRST WTYP2
MOVEI B,(AB)+2 ; ADDRESS OF FRAME POINTER
JRST COMRET
MFUNCTION AGAIN,SUBR
ENTRY
HLRZ A,AB ;GET # OF ARGS
CAIN A,-2 ;1 ARG?
JRST NLCLA ;YES
JUMPN A,TMA ;0 ARGS?
PUSHJ P,PROGCH ;CHECK FOR IN A PROG
PUSH TP,A
PUSH TP,B
JRST AGAD
NLCLA: GETYP A,(AB)
CAIE A,TACT
JRST WTYP1
PUSH TP,(AB)
PUSH TP,1(AB)
AGAD: MOVEI B,-1(TP) ; POINT TO FRAME
PUSHJ P,CHFSWP
HRRZ C,(B) ; GET RET POINT
GOJOIN: PUSH TP,$TFIX
PUSH TP,C
MOVEI C,-1(TP)
PUSHJ P,CHUNW ; RESTORE FRAME, UNWIND IF NEC.
HRRM B,PCSAV(TB)
HRRZ 0,FSAV(TB) ; CHECK FOR RSUBR
CAIGE 0,HIBOT
CAIGE 0,STOSTR
JRST CONTIN
HRRZ E,1(TB)
PUSH TP,$TFIX
PUSH TP,B
MOVEI C,-1(TP)
MOVEI B,(TB)
PUSHJ P,CHUNW1
MOVE TP,1(TB)
MOVE SP,SPSTOR+1
MOVEM SP,SPSAV(TB)
MOVEM TP,TPSAV(TB)
MOVE C,OTBSAV(TB) ; AND RESTORE P FROM FATHER
MOVE P,PSAV(C)
MOVEM P,PSAV(TB)
SKIPGE PCSAV(TB)
HRLI B,400000+M
MOVEM B,PCSAV(TB)
JRST CONTIN
MFUNCTION GO,SUBR
ENTRY 1
GETYP A,(AB)
CAIE A,TATOM
JRST NLCLGO
PUSHJ P,PROGCH ;CHECK FOR A PROG
PUSH TP,A ;SAVE
PUSH TP,B
MOVEI B,-1(TP)
PUSHJ P,CHFSWP
PUSH TP,$TATOM
PUSH TP,1(C)
PUSH TP,2(B)
PUSH TP,3(B)
MCALL 2,MEMQ ;DOES IT HAVE THIS TAG?
JUMPE B,NXTAG ;NO -- ERROR
FNDGO: EXCH B,(TP) ;SAVE PLACE TO GO
MOVSI D,TLIST
MOVEM D,-1(TP)
JRST GODON
NLCLGO: CAIE A,TTAG ;CHECK TYPE
JRST WTYP1
MOVE B,1(AB)
MOVEI B,2(B) ; POINT TO SLOT
PUSHJ P,CHFSWP
MOVE A,1(C)
GETYP 0,(A) ; SEE IF COMPILED
CAIE 0,TFIX
JRST GODON1
MOVE C,1(A)
JRST GOJOIN
GODON1: PUSH TP,(A) ;SAVE BODY
PUSH TP,1(A)
GODON: MOVEI C,0
PUSHJ P,CHUNW ;GO BACK TO CORRECT FRAME
MOVE B,(TP) ;RESTORE ITERATION MARKER
MOVEM B,1(TB)
MOVSI A,TATOM
MOVE B,1(B)
JRST CONTIN
MFUNCTION TAG,SUBR
ENTRY
JUMPGE AB,TFA
HLRZ 0,AB
GETYP A,(AB) ;GET TYPE OF ARGUMENT
CAIE A,TFIX ; FIX ==> COMPILED
JRST ATOTAG
CAIE 0,-4
JRST WNA
GETYP A,2(AB)
CAIE A,TACT
JRST WTYP2
PUSH TP,(AB)
PUSH TP,1(AB)
PUSH TP,2(AB)
PUSH TP,3(AB)
JRST GENTV
ATOTAG: CAIE A,TATOM ;CHECK THAT IT IS AN ATOM
JRST WTYP1
CAIE 0,-2
JRST TMA
PUSHJ P,PROGCH ;CHECK PROG
PUSH TP,A ;SAVE VAL
PUSH TP,B
PUSH TP,$TATOM
PUSH TP,1(AB)
PUSH TP,2(B)
PUSH TP,3(B)
MCALL 2,MEMQ
JUMPE B,NXTAG ;IF NOT FOUND -- ERROR
EXCH A,-1(TP) ;SAVE PLACE
EXCH B,(TP)
HRLI A,TFRAME
PUSH TP,A
PUSH TP,B
GENTV: MOVEI A,2
PUSHJ P,IEVECT
MOVSI A,TTAG
JRST FINIS
PROGCH: MOVE B,IMQUOTE LPROG,[LPROG ]INTRUP
PUSHJ P,ILVAL ;GET VALUE
GETYP 0,A
CAIE 0,TACT
JRST NXPRG
POPJ P,
; HERE TO UNASSIGN LPROG IF NEC
UNPROG: MOVE B,IMQUOTE LPROG,[LPROG ]INTRUP
PUSHJ P,ILVAL
GETYP 0,A
CAIE 0,TACT ; SKIP IF MUST UNBIND
JRST UNMAP
MOVSI A,TUNBOU
MOVNI B,1
MOVE E,IMQUOTE LPROG,[LPROG ]INTRUP
PUSHJ P,PSHBND
UNMAP: HRRZ 0,FSAV(TB) ; CHECK FOR FUNNY
CAIN 0,MAPPLY ; SKIP IF NOT
POPJ P,
MOVE B,IMQUOTE LMAP,[LMAP ]INTRUP
PUSHJ P,ILVAL
GETYP 0,A
CAIE 0,TFRAME
JRST UNSPEC
MOVSI A,TUNBOU
MOVNI B,1
MOVE E,IMQUOTE LMAP,[LMAP ]INTRUP
PUSHJ P,PSHBND
UNSPEC: PUSH TP,BNDV
MOVE B,PVSTOR+1
ADD B,[CURFCN,,CURFCN]
PUSH TP,B
PUSH TP,$TSP
MOVE E,SPSTOR+1
ADD E,[3,,3]
PUSH TP,E
POPJ P,
REPEAT 0,[
MFUNCTION MEXIT,SUBR,[EXIT]
ENTRY 2
GETYP A,(AB)
CAIE A,TACT
JRST WTYP1
MOVEI B,(AB)
PUSHJ P,CHFSWP
ADD C,[2,,2]
PUSHJ P,CHUNW ;RESTORE FRAME
JRST CHFINI ; CHECK FOR WINNING VALUE
]
MFUNCTION COND,FSUBR
ENTRY 1
GETYP A,(AB)
CAIE A,TLIST
JRST WRONGT
PUSH TP,(AB)
PUSH TP,1(AB) ;CREATE UNNAMED TEMP
MOVEI B,0 ; SET TO FALSE IN CASE
CLSLUP: SKIPN C,1(TB) ;IS THE CLAUSELIST NIL?
JRST IFALS1 ;YES -- RETURN NIL
GETYP A,(C) ;NO -- GET TYPE OF CAR
CAIE A,TLIST ;IS IT A LIST?
JRST BADCLS ;
MOVE A,1(C) ;YES -- GET CLAUSE
JUMPE A,BADCLS
GETYPF B,(A)
PUSH TP,B ; EVALUATION OF
HLLZS (TP)
PUSH TP,1(A) ;THE PREDICATE
JSP E,CHKARG
MCALL 1,EVAL
GETYP 0,A
CAIN 0,TFALSE
JRST NXTCLS ;FALSE TRY NEXT CLAUSE
MOVE C,1(TB) ;IF NOT, DO FIRST CLAUSE
MOVE C,1(C)
HRRZ C,(C)
JUMPE C,FINIS ;(UNLESS DONE WITH IT)
JRST DOPRG2 ;AS THOUGH IT WERE A PROG
NXTCLS: HRRZ C,@1(TB) ;SET THE CLAUSLIST
HRRZM C,1(TB) ;TO CDR OF THE CLAUSLIST
JRST CLSLUP
IFALSE:
MOVEI B,0
IFALS1: MOVSI A,TFALSE ;RETURN FALSE
JRST FINIS
MFUNCTION UNWIND,FSUBR
ENTRY 1
GETYP 0,(AB) ; CHECK THE ARGS FOR WINNAGE
SKIPN A,1(AB) ; NONE?
JRST TFA
HRRZ B,(A) ; CHECK FOR 2D
JUMPE B,TFA
HRRZ 0,(B) ; 3D?
JUMPN 0,TMA
; Unbind LPROG and LMAPF so that nothing cute happens
PUSHJ P,UNPROG
; Push thing to do upon UNWINDing
PUSH TP,$TLIST
PUSH TP,[0]
MOVEI C,UNWIN1
PUSHJ P,IUNWIN ; GOT TO INTERNAL SET UP
; Now EVAL the first form
MOVE A,1(AB)
HRRZ 0,(A) ; SAVE POINTER TO OTHER GUY
MOVEM 0,-12(TP)
MOVE B,1(A)
GETYP A,(A)
MOVSI A,(A)
JSP E,CHKAB ; DEFER?
PUSH TP,A
PUSH TP,B
MCALL 1,EVAL ; EVAL THE LOSER
JRST FINIS
; Now push slots to hold undo info on the way down
IUNWIN: JUMPE M,NOUNRE
HLRE 0,M ; CHECK BOUNDS
SUBM M,0
ANDI 0,-1
CAIL C,(M)
CAML C,0
JRST .+2
SUBI C,(M)
NOUNRE: PUSH TP,$TTB ; DESTINATION FRAME
PUSH TP,[0]
PUSH TP,[0] ; ARGS TO WHOEVER IS DOING IT
PUSH TP,[0]
; Now bind UNWIND word
PUSH TP,$TUNWIN ; FIRST WORD OF IT
MOVE SP,SPSTOR+1
HRRM SP,(TP) ; CHAIN
MOVEM TP,SPSTOR+1
PUSH TP,TB ; AND POINT TO HERE
PUSH TP,$TTP
PUSH TP,[0]
HRLI C,TPDL
PUSH TP,C
PUSH TP,P ; SAVE PDL ALSO
MOVEM TP,-2(TP) ; SAVE FOR LATER
POPJ P,
; Do a non-local return with UNWIND checking
CHUNW: HRRZ E,SPSAV(B) ; GET DESTINATION FRAME
CHUNW1: PUSH TP,(C) ; FINAL VAL
PUSH TP,1(C)
JUMPN C,.+3 ; WAS THERE REALLY ANYTHING
SETZM (TP)
SETZM -1(TP)
PUSHJ P,STLOOP ; UNBIND
CHUNPC: SKIPA ; WILL NOT SKIP UNLESS UNWIND FOUND
JRST GOTUND
MOVEI A,(TP)
SUBI A,(SP)
MOVSI A,(A)
HLL SP,TP
SUB SP,A
MOVEM SP,SPSTOR+1
HRRI TB,(B) ; UPDATE TB
PUSHJ P,UNWFRMS
POP TP,B
POP TP,A
POPJ P,
POPUNW: MOVE SP,SPSTOR+1
HRRZ SP,(SP)
MOVEI E,(TP)
SUBI E,(SP)
MOVSI E,(E)
HLL SP,TP
SUB SP,E
MOVEM SP,SPSTOR+1
POPJ P,
UNWFRM: JUMPE FRM,CPOPJ
MOVE B,FRM
UNWFR2: JUMPE B,UNWFR1
CAMG B,TPSAV(TB)
JRST UNWFR1
MOVE B,(B)
JRST UNWFR2
UNWFR1: MOVE FRM,B
POPJ P,
; Here if an UNDO found
GOTUND: MOVE TB,1(SP) ; GET FRAME OF UNDO
MOVE A,-1(TP) ; GET FUNNY ARG FOR PASS ON
MOVE C,(TP)
MOVE TP,3(SP) ; GET FUTURE TP
MOVEM C,-6(TP) ; SAVE ARG
MOVEM A,-7(TP)
MOVE C,(TP) ; SAVED P
SUB C,[1,,1]
MOVEM C,PSAV(TB) ; MAKE CONTIN WIN
MOVEM TP,TPSAV(TB)
MOVEM SP,SPSAV(TB)
HRRZ C,(P) ; PC OF CHUNW CALLER
HRRM C,-11(TP) ; SAVE ALSO AND GET WHERE TO GO PC
MOVEM B,-10(TP) ; AND DESTINATION FRAME
HRRZ C,-1(TP) ; WHERE TO UNWIND PC
HRRZ 0,FSAV(TB) ; RSUBR?
CAIGE 0,HIBOT
CAIGE 0,STOSTR
JRST .+3
SKIPGE PCSAV(TB)
HRLI C,400000+M
MOVEM C,PCSAV(TB)
JRST CONTIN
UNWIN1: MOVE B,-12(TP) ; POINT TO THING TO DO UNWINDING
GETYP A,(B)
MOVSI A,(A)
MOVE B,1(B)
JSP E,CHKAB
PUSH TP,A
PUSH TP,B
MCALL 1,EVAL
UNWIN2: MOVEI C,-7(TP) ; POINT TO SAVED RET VALS
MOVE B,-10(TP)
HRRZ E,-11(TP)
PUSH P,E
MOVE SP,SPSTOR+1
HRRZ SP,(SP) ; UNBIND THIS GUY
MOVEI E,(TP) ; AND FIXUP SP
SUBI E,(SP)
MOVSI E,(E)
HLL SP,TP
SUB SP,E
MOVEM SP,SPSTOR+1
JRST CHUNW ; ANY MORE TO UNWIND?
; CHFSWP - CHECK FRAMES VALIDITY AND SWAP PROCESS IF NECESSARY.
; CALLED BY ALL CONTROL FLOW
; ROUTINES (GO,RETURN,EXIT,AGAIN,ERRET...)
CHFSWP: PUSHJ P,CHFRM ; CHECK FOR VALID FRAME
HRRZ D,(B) ; PROCESS VECTOR DOPE WD
HLRZ C,(D) ; LENGTH
SUBI D,-1(C) ; POINT TO TOP
MOVNS C ; NEGATE COUNT
HRLI D,2(C) ; BUILD PVP
MOVE E,PVSTOR+1
MOVE C,AB
MOVE A,(B) ; GET FRAME
MOVE B,1(B)
CAMN E,D ; SKIP IF SWAP NEEDED
POPJ P,
PUSH TP,A ; SAVE FRAME
PUSH TP,B
MOVE B,D
PUSHJ P,PROCHK ; FIX UP PROCESS LISTS
MOVE A,PSTAT+1(B) ; GET STATE
CAIE A,RESMBL
JRST NOTRES
MOVE D,B ; PREPARE TO SWAP
POP P,0 ; RET ADDR
POP TP,B
POP TP,A
JSP C,SWAP ; SWAP IN
MOVE C,ABSTO+1(E) ; GET OLD ARRGS
MOVEI A,RUNING ; FIX STATES
MOVE PVP,PVSTOR+1
MOVEM A,PSTAT+1(PVP)
MOVEI A,RESMBL
MOVEM A,PSTAT+1(E)
JRST @0
NOTRES: ERRUUO EQUOTE PROCESS-NOT-RESUMABLE
;SETG IS USED TO SET THE GLOBAL VALUE OF ITS FIRST ARGUMENT,
;AN IDENTIFIER, TO THE VALUE OF ITS SECOND ARGUMENT. ITS VALUE IS
; ITS SECOND ARGUMENT.
IMFUNCTION SETG,SUBR
ENTRY 2
GETYP A,(AB) ;GET TYPE OF FIRST ARGUMENT
CAIE A,TATOM ;CHECK THAT IT IS AN ATOM
JRST NONATM ;IF NOT -- ERROR
MOVE B,1(AB) ;GET POINTER TO ATOM
PUSH TP,$TATOM
PUSH TP,B
MOVEI 0,(B)
CAIL 0,HIBOT ; PURE ATOM?
PUSHJ P,IMPURIFY ; YES IMPURIFY
PUSHJ P,IGLOC ;GET LOCATIVE TO VALUE
CAMN A,$TUNBOUND ;IF BOUND
PUSHJ P,BSETG ;IF NOT -- BIND IT
MOVE C,2(AB) ; GET PROPOSED VVAL
MOVE D,3(AB)
MOVSI A,TLOCD ; MAKE SURE MONCH WINS
PUSHJ P,MONCH0 ; WOULD YOU BELIEVE MONITORS!!!!
EXCH D,B ;SAVE PTR
MOVE A,C
HRRZ E,-2(D) ; POINT TO POSSIBLE GDECL (OR MAINIFEST)
JUMPE E,OKSETG ; NONE ,OK
CAIE E,-1 ; MANIFEST?
JRST SETGTY
GETYP 0,(D) ; IF UNBOUND, LET IT HAPPEN
SKIPN IGDECL
CAIN 0,TUNBOU
JRST OKSETG
MANILO: GETYP C,(D)
GETYP 0,2(AB)
CAIN 0,(C)
CAME B,1(D)
JRST .+2
JRST OKSETG
PUSH TP,$TVEC
PUSH TP,D
MOVE B,IMQUOTE REDEFINE
PUSHJ P,ILVAL ; SEE IF REDEFINE OK
GETYP A,A
CAIE A,TUNBOU
CAIN A,TFALSE
JRST .+2
JRST OKSTG
PUSH TP,$TATOM
PUSH TP,EQUOTE ATTEMPT-TO-CHANGE-MANIFEST-VARIABLE
PUSH TP,$TATOM
PUSH TP,1(AB)
MOVEI A,2
JRST CALER
SETGTY: PUSH TP,$TVEC
PUSH TP,D
MOVE C,A
MOVE D,B
GETYP A,(E)
MOVSI A,(A)
MOVE B,1(E)
JSP E,CHKAB
PUSHJ P,TMATCH
JRST TYPMI3
OKSTG: MOVE D,(TP)
MOVE A,2(AB)
MOVE B,3(AB)
OKSETG: MOVEM A,(D) ;DEPOSIT INTO THE
MOVEM B,1(D) ;INDICATED VALUE CELL
JRST FINIS
TYPMI3: MOVE C,(TP)
HRRZ C,-2(C)
MOVE D,2(AB)
MOVE B,3(AB)
MOVE 0,(AB)
MOVE A,1(AB)
JRST TYPMIS
BSETG: HRRZ A,GLOBASE+1
HRRZ B,GLOBSP+1
SUB B,A
CAIL B,6
JRST SETGIT
MOVEI B,0 ; MAKE SURE OF NO EMPTY SLOTS
PUSHJ P,IGLOC
CAMN A,$TUNBOU ; SKIP IF SLOT FOUND
JRST BSETG1
MOVE C,(TP) ; GET ATOM
MOVEM C,-1(B) ; CLOBBER ATOM SLOT
HLLZS -2(B) ; CLOBBER OLD DECL
JRST BSETGX
; BSETG1: PUSH TP,GLOBASE ; MUST REALLY GROW STACK
; PUSH TP,GLOBASE+1
; PUSH TP,$TFIX
; PUSH TP,[0]
; PUSH TP,$TFIX
; PUSH TP,[100]
; MCALL 3,GROW
BSETG1: PUSH P,0
PUSH P,C
MOVE C,GLOBASE+1
HLRE B,C
SUB C,B
MOVE B,GVLINC ; GROW BY INDICATED GVAL SLOTS
DPB B,[001100,,(C)]
; MOVEM A,GLOBASE
MOVE C,[6,,4] ; INDICATOR FOR AGC
PUSHJ P,AGC
MOVE B,GLOBASE+1
MOVE 0,GVLINC ; ADJUST GLOBAL SPBASE
ASH 0,6
SUB B,0
HRLZS 0
SUB B,0
MOVEM B,GLOBASE+1
; MOVEM B,GLOBASE+1
POP P,0
POP P,C
SETGIT:
MOVE B,GLOBSP+1
SUB B,[4,,4]
MOVSI C,TGATOM
MOVEM C,(B)
MOVE C,(TP)
MOVEM C,1(B)
MOVEM B,GLOBSP+1
ADD B,[2,,2]
BSETGX: MOVSI A,TLOCI
PUSHJ P,PATSCH ; FIXUP SCHLPAGE
MOVEM A,(C)
MOVEM B,1(C)
POPJ P,
PATSCH: GETYP 0,(C)
CAIN 0,TLOCI
SKIPL D,1(C)
POPJ P,
PATL: SKIPL E,3(D) ; SKIP IF NEXT EXISTS
JRST PATL1
MOVE D,E
JRST PATL
PATL1: MOVEI E,1
MOVEM E,3(D) ; SAY GVAL ETC. EXISTS IF WE UNBIND
POPJ P,
IMFUNCTION DEFMAC,FSUBR
ENTRY 1
PUSH P,.
JRST DFNE2
IMFUNCTION DFNE,FSUBR,[DEFINE]
ENTRY 1
PUSH P,[0]
DFNE2: GETYP A,(AB)
CAIE A,TLIST
JRST WRONGT
SKIPN B,1(AB) ; GET ATOM
JRST TFA
GETYP A,(B) ; MAKE SURE ATOM
MOVSI A,(A)
PUSH TP,A
PUSH TP,1(B)
JSP E,CHKARG
MCALL 1,EVAL ; EVAL IT TO AN ATOM
CAME A,$TATOM
JRST NONATM
PUSH TP,A ; SAVE TWO COPIES
PUSH TP,B
PUSHJ P,IGVAL ; SEE IF A VALUE EXISTS
CAMN A,$TUNBOU ; SKIP IF A WINNER
JRST .+3
PUSHJ P,ASKUSR ; CHECK WITH USER
JRST DFNE1
PUSH TP,$TATOM
PUSH TP,-1(TP)
MOVE B,1(AB)
HRRZ B,(B)
MOVSI A,TEXPR
SKIPN (P) ; SKIP IF MACRO
JRST DFNE3
MOVEI D,(B) ; READY TO CONS
MOVSI C,TEXPR
PUSHJ P,INCONS
MOVSI A,TMACRO
DFNE3: PUSH TP,A
PUSH TP,B
MCALL 2,SETG
DFNE1: POP TP,B ; RETURN ATOM
POP TP,A
JRST FINIS
ASKUSR: MOVE B,IMQUOTE REDEFINE
PUSHJ P,ILVAL ; SEE IF REDEFINE OK
GETYP A,A
CAIE A,TUNBOU
CAIN A,TFALSE
JRST ASKUS1
JRST ASKUS2
ASKUS1: PUSH TP,$TATOM
PUSH TP,-1(TP)
PUSH TP,$TATOM
PUSH TP,EQUOTE ALREADY-DEFINED-ERRET-NON-FALSE-TO-REDEFINE
MCALL 2,ERROR
GETYP 0,A
CAIE 0,TFALSE
ASKUS2: AOS (P)
MOVE B,1(AB)
POPJ P,
;SET CLOBBERS THE LOCAL VALUE OF THE IDENTIFIER GIVEN BY ITS
;FIRST ARGUMENT TO THE SECOND ARG. ITS VALUE IS ITS SECOND ARGUMENT.
IMFUNCTION SET,SUBR
HLRE D,AB ; 2 TIMES # OF ARGS TO D
ASH D,-1 ; - # OF ARGS
ADDI D,2
JUMPG D,TFA ; NOT ENOUGH
MOVE B,PVSTOR+1
MOVE C,SPSTOR+1
JUMPE D,SET1 ; NO ENVIRONMENT
AOJL D,TMA ; TOO MANY
GETYP A,4(AB) ; CHECK ARG IS A FRAME OR PROCESS
CAIE A,TFRAME
CAIN A,TENV
JRST SET2 ; WINNING ENVIRONMENT/FRAME
CAIN A,TACT
JRST SET2 ; TO MAKE PFISTER HAPPY
CAIE A,TPVP
JRST WTYP2
MOVE B,5(AB) ; GET PROCESS
MOVE C,SPSTO+1(B)
JRST SET1
SET2: MOVEI B,4(AB) ; POINT TO FRAME
PUSHJ P,CHFRM ; CHECK IT OUT
MOVE B,5(AB) ; GET IT BACK
MOVE C,SPSAV(B) ; GET BINDING POINTER
HRRZ B,4(AB) ; POINT TO PROCESS
HLRZ A,(B) ; GET LENGTH
SUBI B,-1(A) ; POINT TO START THEREOF
HLL B,PVSTOR+1 ; GET -LNTRH, (ALL PROCESS VECS SAME LENGTH)
SET1: PUSH TP,$TPVP ; SAVE PROCESS
PUSH TP,B
PUSH TP,$TSP ; SAVE PATH POINTER
PUSH TP,C
GETYP A,(AB) ;GET TYPE OF FIRST
CAIE A,TATOM ;ARGUMENT --
JRST WTYP1 ;BETTER BE AN ATOM
MOVE B,1(AB) ;GET PTR TO IT
MOVEI 0,(B)
CAIL 0,HIBOT
PUSHJ P,IMPURIFY
MOVE C,(TP)
PUSHJ P,AILOC ;GET LOCATIVE TO VALUE
GOTLOC: CAMN A,$TUNBOUND ;BOUND?
PUSHJ P, BSET ;BIND IT
MOVE C,2(AB) ; GET NEW VAL
MOVE D,3(AB)
MOVSI A,TLOCD ; FOR MONCH
HRR A,2(B)
PUSHJ P,MONCH0 ; HURRAY FOR MONITORS!!!!!
MOVE E,B
HLRZ A,2(E) ; GET DECLS
JUMPE A,SET3 ; NONE, GO
PUSH TP,$TSP
PUSH TP,E
MOVE B,1(A)
HLLZ A,(A) ; GET PATTERN
PUSHJ P,TMATCH ; MATCH TMEM
JRST TYPMI2 ; LOSES
MOVE E,(TP)
SUB TP,[2,,2]
MOVE C,2(AB)
MOVE D,3(AB)
SET3: MOVEM C,(E) ;CLOBBER IDENTIFIER
MOVEM D,1(E)
MOVE A,C
MOVE B,D
MOVE C,-2(TP) ; GET PROC
HRRZ C,BINDID+1(C)
HRLI C,TLOCI
; HERE WE NOTE THAT EFFICIENCY CAN SOMETIMES GET IN THE WAY OF CORRECTNESS
; BY SETTING THE SHALLOW BINDING WE MANAGE TO CLOBBER THE TOP LEVEL LVAL
; EVEN IF WE ARE SETTING WITH RESPECT TO A DIFFERENT FRAME. TO CORRECT
; THIS GLITCH THIS ACTIVITY WILL ONLY TAKE PLACE IF THE ATOM ALREADY POINTS
; TO A BINDING
MOVE D,1(AB)
SKIPE (D)
JRST NSHALL
MOVEM C,(D)
MOVEM E,1(D)
NSHALL: SUB TP,[4,,4]
JRST FINIS
BSET:
MOVE PVP,PVSTOR+1
CAMN PVP,-2(TP) ; SKIP IF PROC DIFFERS
MOVEM C,-2(TP) ; ELSE USE RESULT FROM LOC SEARCH
MOVE B,-2(TP) ; GET PROCESS
HRRZ A,TPBASE+1(B) ;GET ACTUAL STACK BASE
HRRZ B,SPBASE+1(B) ;AND FIRST BINDING
SUB B,A ;ARE THERE 6
CAIL B,6 ;CELLS AVAILABLE?
JRST SETIT ;YES
MOVE C,(TP) ; GET POINTER BACK
MOVEI B,0 ; LOOK FOR EMPTY SLOT
PUSHJ P,AILOC
CAMN A,$TUNBOUND ; SKIP IF FOUND
JRST BSET1
MOVE E,1(AB) ; GET ATOM
MOVEM E,-1(B) ; AND STORE
JRST BSET2
BSET1: MOVE B,-2(TP) ; GET PROCESS
; PUSH TP,TPBASE(B) ;NO -- GROW THE TP
; PUSH TP,TPBASE+1(B) ;AT THE BASE END
; PUSH TP,$TFIX
; PUSH TP,[0]
; PUSH TP,$TFIX
; PUSH TP,[100]
; MCALL 3,GROW
; MOVE C,-2(TP) ; GET PROCESS
; MOVEM A,TPBASE(C) ;SAVE RESULT
PUSH P,0 ; MANUALLY GROW VECTOR
PUSH P,C
MOVE C,TPBASE+1(B)
HLRE B,C
SUB C,B
MOVEI C,1(C)
CAME C,TPGROW
ADDI C,PDLBUF
MOVE D,LVLINC
DPB D,[001100,,-1(C)]
MOVE C,[5,,3] ; SET UP INDICATORS FOR AGC
PUSHJ P,AGC
MOVE PVP,PVSTOR+1
MOVE B,TPBASE+1(PVP) ; MODIFY POINTER
MOVE 0,LVLINC ; ADJUST SPBASE POINTER
ASH 0,6
SUB B,0
HRLZS 0
SUB B,0
MOVEM B,TPBASE+1(PVP)
POP P,C
POP P,0
; MOVEM B,TPBASE+1(C)
SETIT: MOVE C,-2(TP) ; GET PROCESS
MOVE B,SPBASE+1(C)
MOVEI A,-6(B) ;MAKE UP BINDING
HRRM A,(B) ;LINK PREVIOUS BIND BLOCK
MOVSI A,TBIND
MOVEM A,-6(B)
MOVE A,1(AB)
MOVEM A,-5(B)
SUB B,[6,,6]
MOVEM B,SPBASE+1(C)
ADD B,[2,,2]
BSET2: MOVE C,-2(TP) ; GET PROC
MOVSI A,TLOCI
HRR A,BINDID+1(C)
HLRZ D,OTBSAV(TB) ; TIME IT
MOVEM D,2(B) ; AND FIX IT
POPJ P,
; HERE TO ELABORATE ON TYPE MISMATCH
TYPMI2: MOVE C,(TP) ; FIND DECLS
HLRZ C,2(C)
MOVE D,2(AB)
MOVE B,3(AB)
MOVE 0,(AB) ; GET ATOM
MOVE A,1(AB)
JRST TYPMIS
MFUNCTION NOT,SUBR
ENTRY 1
GETYP A,(AB) ; GET TYPE
CAIE A,TFALSE ;IS IT FALSE?
JRST IFALSE ;NO -- RETURN FALSE
TRUTH:
MOVSI A,TATOM ;RETURN T (VERITAS)
MOVE B,IMQUOTE T
JRST FINIS
IMFUNCTION OR,FSUBR
PUSH P,[0]
JRST ANDOR
MFUNCTION ANDA,FSUBR,AND
PUSH P,[1]
ANDOR: ENTRY 1
GETYP A,(AB)
CAIE A,TLIST
JRST WRONGT ;IF ARG DOESN'T CHECK OUT
MOVE E,(P)
SKIPN C,1(AB) ;IF NIL
JRST TF(E) ;RETURN TRUTH
PUSH TP,$TLIST ;CREATE UNNAMED TEMP
PUSH TP,C
ANDLP:
MOVE E,(P)
JUMPE C,TFI(E) ;ANY MORE ARGS?
MOVEM C,1(TB) ;STORE CRUFT
GETYP A,(C)
MOVSI A,(A)
PUSH TP,A
PUSH TP,1(C) ;ARGUMENT
JSP E,CHKARG
MCALL 1,EVAL
GETYP 0,A
MOVE E,(P)
XCT TFSKP(E)
JRST FINIS ;IF FALSE -- RETURN
HRRZ C,@1(TB) ;GET CDR OF ARGLIST
JRST ANDLP
TF: JRST IFALSE
JRST TRUTH
TFI: JRST IFALS1
JRST FINIS
TFSKP: CAIE 0,TFALSE
CAIN 0,TFALSE
IMFUNCTION FUNCTION,FSUBR
ENTRY 1
MOVSI A,TEXPR
MOVE B,1(AB)
JRST FINIS
;SUBR VERSIONS OF AND/OR
MFUNCTION ANDP,SUBR,[AND?]
JUMPGE AB,TRUTH
MOVE C,[CAIN 0,TFALSE]
JRST BOOL
MFUNCTION ORP,SUBR,[OR?]
JUMPGE AB,IFALSE
MOVE C,[CAIE 0,TFALSE]
BOOL: HLRE A,AB ; GET ARG COUNTER
MOVMS A
ASH A,-1 ; DIVIDES BY 2
MOVE D,AB
PUSHJ P,CBOOL
JRST FINIS
CANDP: SKIPA C,[CAIN 0,TFALSE]
CORP: MOVE C,[CAIE 0,TFALSE]
JUMPE A,CNOARG
MOVEI D,(A)
ASH D,1 ; TIMES 2
HRLI D,(D)
SUBB TP,D ; POINT TO ARGS & FIXUP TP PTR
AOBJP D,.+1 ; FIXUP ARG PTR AND FALL INTO CBOOL
CBOOL: GETYP 0,(D)
XCT C ; WINNER ?
JRST CBOOL1 ; YES RETURN IT
ADD D,[2,,2]
SOJG A,CBOOL ; ANY MORE ?
SUB D,[2,,2] ; NO, USE LAST
CBOOL1: MOVE A,(D)
MOVE B,(D)+1
POPJ P,
CNOARG: MOVSI 0,TFALSE
XCT C
JRST CNOAND
MOVSI A,TFALSE
MOVEI B,0
POPJ P,
CNOAND: MOVSI A,TATOM
MOVE B,IMQUOTE T
POPJ P,
MFUNCTION CLOSURE,SUBR
ENTRY
SKIPL A,AB ;ANY ARGS
JRST TFA ;NO -- LOSE
ADD A,[2,,2] ;POINT AT IDS
PUSH TP,$TAB
PUSH TP,A
PUSH P,[0] ;MAKE COUNTER
CLOLP: SKIPL A,1(TB) ;ANY MORE IDS?
JRST CLODON ;NO -- LOSE
PUSH TP,(A) ;SAVE ID
PUSH TP,1(A)
PUSH TP,(A) ;GET ITS VALUE
PUSH TP,1(A)
ADD A,[2,,2] ;BUMP POINTER
MOVEM A,1(TB)
AOS (P)
MCALL 1,VALUE
PUSH TP,A
PUSH TP,B
MCALL 2,LIST ;MAKE PAIR
PUSH TP,A
PUSH TP,B
JRST CLOLP
CLODON: POP P,A
ACALL A,LIST ;MAKE UP LIST
PUSH TP,(AB) ;GET FUNCTION
PUSH TP,1(AB)
PUSH TP,A
PUSH TP,B
MCALL 2,LIST ;MAKE LIST
MOVSI A,TFUNARG
JRST FINIS
;ERROR COMMENTS FOR EVAL
BADNUM: ERRUUO EQUOTE NEGATIVE-ARGUMENT
WTY1TP: ERRUUO EQUOTE FIRST-ARG-WRONG-TYPE
UNBOU: PUSH TP,$TATOM
PUSH TP,EQUOTE UNBOUND-VARIABLE
JRST ER1ARG
UNAS: PUSH TP,$TATOM
PUSH TP,EQUOTE UNASSIGNED-VARIABLE
JRST ER1ARG
BADENV:
ERRUUO EQUOTE BAD-ENVIRONMENT
FUNERR:
ERRUUO EQUOTE BAD-FUNARG
MPD.0:
MPD.1:
MPD.2:
MPD.3:
MPD.4:
MPD.5:
MPD.6:
MPD.7:
MPD.8:
MPD.9:
MPD.10:
MPD.11:
MPD.12:
MPD.13:
MPD: ERRUUO EQUOTE MEANINGLESS-PARAMETER-DECLARATION
NOBODY: ERRUUO EQUOTE HAS-EMPTY-BODY
BADCLS: ERRUUO EQUOTE BAD-CLAUSE
NXTAG: ERRUUO EQUOTE NON-EXISTENT-TAG
NXPRG: ERRUUO EQUOTE NOT-IN-PROG
NAPTL:
NAPT: ERRUUO EQUOTE NON-APPLICABLE-TYPE
NONEVT: ERRUUO EQUOTE NON-EVALUATEABLE-TYPE
NONATM: ERRUUO EQUOTE NON-ATOMIC-ARGUMENT
ILLFRA: ERRUUO EQUOTE FRAME-NO-LONGER-EXISTS
ILLSEG: ERRUUO EQUOTE ILLEGAL-SEGMENT
BADMAC: ERRUUO EQUOTE BAD-USE-OF-MACRO
BADFSB: ERRUUO EQUOTE APPLY-OR-STACKFORM-OF-FSUBR
ER1ARG: PUSH TP,(AB)
PUSH TP,1(AB)
MOVEI A,2
JRST CALER
END
Reference in New Issue View Git Blame Copy Permalink