--- /dev/null
+TITLE MAIN LOOP AND GLOBALLY REFERENCED SUBROUTINES
+
+RELOCA
+
+.GLOBAL TBINIT,PIDSTO,PROCID,PTIME,GCPDL,PBASE,TYPTOP,RERR,FRMSTK,EMERGE
+.GLOBAL PDLBUF,INTINT,START,SWAP,ICR,SPBASE,TPBASE,TPBAS,CURPRI,CHFINI,MKTBS
+.GLOBAL TOPLEVEL,INTOBL,INITIA,ERROBL,MAINPR,RESFUN,STATUS,TYPVEC,ROOT,TTICHN,TTOCHN
+.GLOBAL TTYOPE,MOPEN,MCLOSE,MIOT,ILVAL,MESS,ERROR,CHFRM,IGVAL,TYPBOT,ASOVEC
+.GLOBAL PRINT,PRIN1,PRINC,MUDSTR,VECBOT,CSTACK,IFALSE,TYPLOO,RCALL,SWAPIN,CTMPLT
+.GLOBAL IDPROC,CHFSWP,ILOC,MAKACT,BNDV,SPECSTORE,BINDID,IGLOC,MTYO,MSGTYP,CAFRE1,CPOPJ
+.GLOBAL EVATYP,EVTYPE,APLTYP,APTYPE,PRNTYP,PRTYPE,AGC,SGSNAM,NAPT,APLQ,STRTO6
+.GLOBAL 6TOCHS,TYPFND,STBL,CHNL0,N.CHNS,CLOSAL,%LOGOUT,%SSNAM,%RSNAM,%KILLM,SAT
+.GLOBAL MAKINF,%VALRET,COMPERR,IPUT,IGET,TMATCH,INITIZ,IPCINI,%UNAM,%JNAM,%RUNAM,%RJNAM,%RXUNA,%RXJNA,%VALFI
+.GLOBAL NOTTY,DEMFLG,CFRAME,CARGS,CFUNCT,CITYPE,CTYPEQ,CPTYPE,CTYPEP,CUTYPE,
+.GLOBAL CCHUTY,RTFALS,PGINT,PURCLN,CTYPEC,CTYPEW,IDVAL1,CALLTY,MESSAG,INITFL,WHOAMI
+.GLOBAL %SLEEP,%HANG,%TOPLQ,ONINT,CHUNW,CURFCN,BUFRIN,TD.LNT,TD.GET,TD.AGC,TD.PUT,MPOPJ
+.GLOBAL PURVEC,PLOAD,SSPECS,OUTRNG,CVTYPE,FSTART,CKVRS,CPRTYC,PVSTOR,SPSTOR
+.GLOBAL TYPIC,CISET,LSTUF,IMPURI,REALTV
+.INSRT MUDDLE >
+
+;MAIN LOOP AND STARTUP
+
+START: MOVEI 0,0 ; SET NO HACKS
+ JUMPE 0,START1
+ TLNE 0,-1 ; SEE IF CHANNEL
+ JRST START1
+ MOVE P,GCPDL
+ MOVE A,0
+ PUSH P,A
+ PUSHJ P,CKVRS ; CHECK VERSION NUMBERS
+ POP P,A
+ JRST FSTART ; GO RESTORE
+START1: MOVEM 0,WHOAMI ; HACK FOR TS FOO linked to TS MUDDLE
+ MOVE PVP,MAINPR ; MAKE SURE WE START IN THE MAIN PROCESS
+ JUMPE 0,INITIZ ; MIGHT BE RESTART
+ MOVE P,PSTO+1(PVP) ; SET UP FOR BOOTSTRAP HACK
+ MOVE TP,TPSTO+1(PVP)
+INITIZ: MOVE PVP,MAINPR
+ SKIPN P ; IF NO CURRENT P
+ MOVE P,PSTO+1(PVP) ; PDL TO GET OFF THE GROUND
+ SKIPN TP ; SAME FOR TP
+ MOVE TP,TPSTO+1(PVP) ; GET A TP TO WORK WITH
+ SETZB R,M ; RESET RSUBR AC'S
+ PUSHJ P,%RUNAM
+ JFCL
+ PUSHJ P,%RJNAM
+ PUSHJ P,TTYOPE ;OPEN THE TTY
+ MOVEI B,MUDSTR
+ SKIPE WHOAMI ; SKIP IF THIS IS MUDDLE
+ JRST NODEMT ; ELSE NO MESSAGE
+ SKIPE DEMFLG ; SKIP IF NOT DEMON
+ JRST NODEMT
+ SKIPN NOTTY ; IF NO TTY, IGNORE
+ PUSHJ P,MSGTYP ;TYPE OUT TO USER
+
+NODEMT: XCT MESSAG ;MAYBE PRINT A MESSAGE
+ PUSHJ P,INTINT ;INITIALIZE INTERRUPT HANDLER
+ XCT IPCINI
+ PUSHJ P,PURCLN ; CLEAN UP PURE SHARED AREA
+RESTART: ;RESTART A PROCESS
+STP: MOVEI C,0
+ MOVE PVP,PVSTOR+1
+ MOVE B,TBINIT+1(PVP) ;POINT INTO STACK AT START
+ PUSHJ P,CHUNW ; LEAVE WHILE DOING UNWIND CHECK
+ MOVEI E,TOPLEV
+ MOVEI A,TFALSE ; IN CASE FALLS OFF PROCESS
+ MOVEI B,0
+ HRRM E,-1(TB)
+ JRST CONTIN
+
+ IMQUOTE TOPLEVEL
+TOPLEVEL:
+ MCALL 0,LISTEN
+ JRST TOPLEVEL
+\f
+
+IMFUNCTION LISTEN,SUBR
+
+ ENTRY
+ PUSH P,[0] ;FLAG: DON'T PRINT ERROR MSG
+ JRST ER1
+
+; USER SUPPLIED ERROR HANDLER, TEMPORARY KLUDGE
+ IMQUOTE ERROR
+
+ERROR: MOVE B,IMQUOTE ERROR
+ PUSHJ P,IGVAL ; GET VALUE
+ GETYP C,A
+ CAIN C,TSUBR ; CHECK FOR NO CHANGE
+ CAIE B,RERR1 ; SKIP IF NOT CHANGED
+ JRST .+2
+ JRST RERR1 ; GO TO THE DEFAULT
+ PUSH TP,A ; SAVE VALUE
+ PUSH TP,B
+ MOVE C,AB ; SAVE AB
+ MOVEI D,1 ; AND COUNTER
+USER1: PUSH TP,(C) ; PUSH THEM
+ PUSH TP,1(C)
+ ADD C,[2,,2] ; BUMP
+ ADDI D,1
+ JUMPL C,USER1
+ ACALL D,APPLY ; EVAL USERS ERROR
+ JRST FINIS
+
+
+
+IMFUNCTION ERROR%,SUBR,ERROR
+
+RERR1: ENTRY
+ PUSH TP,$TATOM
+ PUSH TP,MQUOTE ERROR,ERROR,INTRUP
+ PUSHJ P,FRMSTK ; PUT ERROR'S FRAME ON STACK
+ MOVEI D,2
+ MOVE C,AB
+RERR2: JUMPGE C,RERR22
+ PUSH TP,(C)
+ PUSH TP,1(C)
+ ADD C,[2,,2]
+ AOJA D,RERR2
+RERR22: ACALL D,EMERGENCY
+ JRST RERR
+
+IMQUOTE ERROR
+RERR: ENTRY
+ PUSH P,[-1] ;PRINT ERROR FLAG
+
+ER1: MOVE B,IMQUOTE INCHAN
+ PUSHJ P,ILVAL ; CHECK INPUT CHANNEL IS SOME KIND OF TTY
+ GETYP A,A
+ CAIE A,TCHAN ; SKIP IF IT IS A CHANNEL
+ JRST ER2 ; NO, MUST REBIND
+ CAMN B,TTICHN+1
+ JRST NOTINC
+ER2: MOVE B,IMQUOTE INCHAN
+ MOVEI C,TTICHN ; POINT TO VALU
+ PUSHJ P,PUSH6 ; PUSH THE BINDING
+ MOVE B,TTICHN+1 ; GET IN CHAN
+NOTINC: SKIPN DEMFLG ; SKIP IF DEMON
+ SKIPE NOTTY
+ JRST NOECHO
+ PUSH TP,$TCHAN
+ PUSH TP,B
+ PUSH TP,$TATOM
+ PUSH TP,IMQUOTE T
+ MCALL 2,TTYECH ; ECHO INPUT
+NOECHO: MOVE B,IMQUOTE OUTCHAN
+ PUSHJ P,ILVAL ; GET THE VALUE
+ GETYP A,A
+ CAIE A,TCHAN ; SKIP IF OK CHANNEL
+ JRST ER3 ; NOT CHANNEL, MUST REBIND
+ CAMN B,TTOCHN+1
+ JRST NOTOUT
+ER3: MOVE B,IMQUOTE OUTCHAN
+ MOVEI C,TTOCHN
+ PUSHJ P,PUSH6 ; PUSH THE BINDINGS
+NOTOUT: MOVE B,IMQUOTE OBLIST
+ PUSHJ P,ILVAL ; GET THE VALUE OF OBLIST
+ PUSHJ P,OBCHK ; IS IT A WINNER ?
+ SKIPA A,$TATOM ; NO, SKIP AND CONTINUE
+ JRST NOTOBL ; YES, DO NOT DO REBINDING
+ MOVE B,IMQUOTE OBLIST
+ PUSHJ P,IGLOC
+ GETYP 0,A
+ CAIN 0,TUNBOU
+ JRST MAKOB ; NO GLOBAL OBLIST, MAKE ONE
+ MOVEI C,(B) ; COPY ADDRESS
+ MOVE A,(C) ; GET THE GVAL
+ MOVE B,(C)+1
+ PUSHJ P,OBCHK ; IS IT A WINNER ?
+ JRST MAKOB ; NO, GO MAKE A NEW ONE
+ MOVE B,IMQUOTE OBLIST
+ PUSHJ P,PUSH6
+
+NOTOBL: PUSH TP,[TATOM,,-1] ;FOR BINDING
+ PUSH TP,IMQUOTE LER,[LERR ]INTRUP
+ PUSHJ P,MAKACT
+ HRLI A,TFRAME ; CORRCT TYPE
+ PUSH TP,A
+ PUSH TP,B
+ PUSH TP,[0]
+ PUSH TP,[0]
+ MOVE A,PVSTOR+1 ; GET PROCESS
+ ADD A,[PROCID,,PROCID] ; POINT TO ID (ALSO LEVEL)
+ PUSH TP,BNDV
+ PUSH TP,A
+ MOVE A,PROCID(PVP)
+ ADDI A,1 ; BUMP ERROR LEVEL
+ PUSH TP,A
+ PUSH TP,PROCID+1(PVP)
+ PUSH P,A
+
+ MOVE B,IMQUOTE READ-TABLE
+ PUSHJ P,IGVAL
+ PUSH TP,[TATOM,,-1]
+ PUSH TP,IMQUOTE READ-TABLE
+ GETYP C,A ; TO GVAL OF READ-TABLE ON ERROR AND
+ CAIE C,TVEC ; TOP ERRET'S
+ JRST .+4
+ PUSH TP,A
+ PUSH TP,B
+ JRST .+3
+ PUSH TP,$TUNBOUND
+ PUSH TP,[-1]
+ PUSH TP,[0]
+ PUSH TP,[0]
+
+ PUSHJ P,SPECBIND ;BIND THE CRETANS
+ MOVE A,-1(P) ;RESTORE SWITHC
+ JUMPE A,NOERR ;IF 0, DONT PRINT ERROR MESS
+ PUSH TP,$TATOM
+ PUSH TP,EQUOTE *ERROR*
+ MCALL 0,TERPRI
+ MCALL 1,PRINC ;PRINT THE MESSAGE
+NOERR: MOVE C,AB ;GET A COPY OF AB
+
+ERRLP: JUMPGE C,LEVPRT ;IF NONE, RE-ENTER READ-EVAL-PRINT LOOP
+ PUSH TP,$TAB
+ PUSH TP,C
+ MOVEI B,PRIN1
+ GETYP A,(C) ; GET ARGS TYPE
+ CAIE A,TATOM
+ JRST ERROK
+ MOVE A,1(C) ; GET ATOM
+ HRRO A,2(A)
+ CAME A,[-1,,ERROBL+1]
+ CAMN A,ERROBL+1 ; DONT SKIP IF IN ERROR OBLIST
+ MOVEI B,PRINC ; DONT PRINT TRAILER
+ERROK: PUSH P,B ; SAVE ROUTINE POINTER
+ PUSH TP,(C)
+ PUSH TP,1(C)
+ MCALL 0,TERPRI ; CRLF
+ POP P,B ; GET ROUTINE BACK
+ .MCALL 1,(B)
+ POP TP,C
+ SUB TP,[1,,1]
+ ADD C,[2,,2] ;BUMP SAVED AB
+ JRST ERRLP ;AND CONTINUE
+
+
+LEVPRT: XCT INITFL ;LOAD MUDDLE INIT FILE IF FIRST TIME
+ MCALL 0,TERPRI
+ PUSH TP,$TATOM
+ PUSH TP,EQUOTE [LISTENING-AT-LEVEL ]
+ MCALL 1,PRINC ;PRINT LEVEL
+ PUSH TP,$TFIX ;READY TO PRINT LEVEL
+ HRRZ A,(P) ;GET LEVEL
+ SUB P,[2,,2] ;AND POP STACK
+ PUSH TP,A
+ MCALL 1,PRIN1 ;PRINT WITHOUT SPACES ETC.
+ PUSH TP,$TATOM ;NOW PROCESS
+ PUSH TP,EQUOTE [ PROCESS ]
+ MCALL 1,PRINC ;DONT SLASHIFY SPACES
+ MOVE PVP,PVSTOR+1
+ PUSH TP,PROCID(PVP) ;NOW ID
+ PUSH TP,PROCID+1(PVP)
+ MCALL 1,PRIN1
+ SKIPN C,CURPRI
+ JRST MAINLP
+ PUSH TP,$TFIX
+ PUSH TP,C
+ PUSH TP,$TATOM
+ PUSH TP,EQUOTE [ INT-LEVEL ]
+ MCALL 1,PRINC
+ MCALL 1,PRIN1
+ JRST MAINLP ; FALL INTO MAIN LOOP
+
+\f;ROUTINES FOR ERROR-LISTEN
+
+OBCHK: GETYP 0,A
+ CAIN 0,TOBLS
+ JRST CPOPJ1 ; WIN FOR SINGLE OBLIST
+ CAIE 0,TLIST ; IF LIST, MAKE SURE EACH IS AN OBLIST
+ JRST CPOPJ ; ELSE, LOSE
+
+ JUMPE B,CPOPJ ; NIL ,LOSE
+ PUSH TP,A
+ PUSH TP,B
+ PUSH P,[0] ;FLAG FOR DEFAULT CHECKING
+ MOVEI 0,1000 ; VERY BIG NUMBER FOR CIRCULARITY TEST
+
+OBCHK0: INTGO
+ SOJE 0,OBLOSE ; CIRCULARITY TEST
+ HRRZ B,(TP) ; GET LIST POINTER
+ GETYP A,(B)
+ CAIE A,TOBLS ; SKIP IF WINNER
+ JRST DEFCHK ; CHECK FOR SPECIAL ATOM DEFAULT
+ HRRZ B,(B)
+ MOVEM B,(TP)
+ JUMPN B,OBCHK0
+OBWIN: AOS (P)-1
+OBLOSE: SUB TP,[2,,2]
+ SUB P,[1,,1]
+ POPJ P,
+
+DEFCHK: SKIPN (P) ; BEEN HERE BEFORE ?
+ CAIE A,TATOM ; OR, NOT AN ATOM ?
+ JRST OBLOSE ; YES, LOSE
+ MOVE A,(B)+1
+ CAME A,MQUOTE DEFAULT
+ JRST OBLOSE ; LOSE
+ SETOM (P) ; SET FLAG
+ HRRZ B,(B) ; CHECK FOR END OF LIST
+ MOVEM B,(TP)
+ JUMPN B,OBCHK0 ; NOT THE END, CONTINUE LOOKING
+ JRST OBLOSE ; LOSE FOR DEFAULT AT THE END
+
+
+
+PUSH6: PUSH TP,[TATOM,,-1]
+ PUSH TP,B
+ PUSH TP,(C)
+ PUSH TP,1(C)
+ PUSH TP,[0]
+ PUSH TP,[0]
+ POPJ P,
+
+
+MAKOB: PUSH TP,INITIAL
+ PUSH TP,INITIAL+1
+ PUSH TP,ROOT
+ PUSH TP,ROOT+1
+ MCALL 2,LIST
+ PUSH TP,$TATOM
+ PUSH TP,IMQUOTE OBLIST
+ PUSH TP,A
+ PUSH TP,B
+ MCALL 2,SETG
+ PUSH TP,[TATOM,,-1]
+ PUSH TP,IMQUOTE OBLIST
+ PUSH TP,A
+ PUSH TP,B
+ PUSH TP,[0]
+ PUSH TP,[0]
+ JRST NOTOBL
+\f
+
+;THIS IS IT FOLKS...THE MAIN LOOP. READ, EVAL, PRINT
+
+MAINLP: MOVE A,$TATOM ;KLUDGE BY NDR LIKE ERROR TO LET LOOSER REDEFINE
+ MOVE B,IMQUOTE REP
+ PUSHJ P,ILVAL ;GET ITS LVAL TO SEE IF REDEFINED
+ GETYP C,A
+ CAIE C,TUNBOUND
+ JRST REPCHK
+ MOVE A,$TATOM ;SEE IF IT HAS GVAL SINCE NO LVAL
+ MOVE B,IMQUOTE REP
+ PUSHJ P,IGVAL
+ GETYP C,A
+ CAIN C,TUNBOUN
+ JRST IREPER
+REPCHK: CAIN C,TSUBR
+ CAIE B,REPER
+ JRST .+2
+ JRST IREPER
+REREPE: PUSH TP,A
+ PUSH TP,B
+ GETYP A,-1(TP)
+ PUSHJ P,APLQ
+ JRST ERRREP
+ MCALL 1,APPLY ;LOOSER HAS REDEFINED SO CALL HIS
+ JRST MAINLP
+IREPER: PUSH P,[0] ;INDICATE FALL THROUGH
+ JRST REPERF
+
+ERRREP: PUSH TP,[TATOM,,-1]
+ PUSH TP,IMQUOTE REP
+ PUSH TP,$TSUBR
+ PUSH TP,[REPER]
+ PUSH TP,[0]
+ PUSH TP,[0]
+ PUSHJ P,SPECBIN
+ PUSH TP,$TATOM
+ PUSH TP,EQUOTE NON-APPLICABLE-REP
+ PUSH TP,-11(TP)
+ PUSH TP,-11(TP)
+ MCALL 2,ERROR
+ SUB TP,[6,,6]
+ PUSHJ P,SSPECS
+ JRST REREPE
+
+
+IMFUNCTION REPER,SUBR,REP
+REPER: ENTRY 0
+ PUSH P,[1] ;INDICATE DIRECT CALL
+REPERF: MCALL 0,TERPRI
+ MCALL 0,READ
+ PUSH TP,A
+ PUSH TP,B
+ MOVE B,IMQUOTE L-INS
+ PUSHJ P,ILVAL ; ASSIGNED?
+ GETYP 0,A
+ CAIN 0,TLIST
+
+ PUSHJ P,LSTTOF ; PUT LAST AS FIRST
+ MCALL 0,TERPRI
+ MCALL 1,EVAL
+ MOVE C,IMQUOTE LAST-OUT
+ PUSHJ P,CISET
+ PUSH TP,A
+ PUSH TP,B
+ MOVE B,IMQUOTE L-OUTS
+ PUSHJ P,ILVAL ; ASSIGNED?
+ GETYP 0,A
+ CAIN 0,TLIST
+
+ CAME B,(TP) ; DONT STUFF IT INTO ITSELF
+ JRST STUFIT ; STUFF IT IN
+ GETYP 0,-1(TP)
+ CAIE 0,TLIST ; IF A LIST THE L-OUTS
+STUFIT: PUSHJ P,LSTTOF ; PUT LAST AS FIRST
+ MCALL 1,PRIN1
+ POP P,C ;FLAG FOR FALL THROUGH OR CALL
+ JUMPN C,FINIS ;IN CASE LOOSER CALLED REP
+ JRST MAINLP
+
+LSTTOF: SKIPN A,B
+ POPJ P,
+
+ HRRZ C,(A)
+ JUMPE C,LSTTO2
+ MOVEI D,(C) ; SAVE PTR TO 2ND ELEMENT
+ MOVEI 0,-1 ; LET THE LOSER LOSE (HA HA HA)
+
+LSTTO1: HRRZ C,(C) ; START SCAN
+ JUMPE C,GOTIT
+ HRRZ A,(A)
+ SOJG 0,LSTTO1
+
+GOTIT: HRRZ C,(A)
+ HLLZS (A)
+ CAIE D,(C) ; AVOID CIRCULARITY
+ HRRM D,(C)
+ HRRM C,(B)
+ MOVE D,1(B)
+ MOVEM D,1(C)
+ GETYP D,(B)
+ PUTYP D,(C)
+
+LSTTO2: MOVSI A,TLIST
+ MOVE C,-1(TP)
+ MOVE D,(TP)
+ JRST LSTUF
+\f
+;FUNCTION TO RETRY A PREVIOUS FUNCTION CALL
+
+MFUNCTION RETRY,SUBR
+
+ ENTRY
+ JUMPGE AB,RETRY1 ; USE MOST RECENT
+ CAMGE AB,[-2,,0]
+ JRST TMA
+ GETYP A,(AB) ; CHECK TYPE
+ CAIE A,TFRAME
+ JRST WTYP1
+ MOVEI B,(AB) ; POINT TO ARG
+ JRST RETRY2
+RETRY1: MOVE B,IMQUOTE LER,[LERR ]INTRUP
+ PUSHJ P,ILOC ; LOCATIVE TO FRAME
+RETRY2: PUSHJ P,CHFSWP ; CHECK VALIDITY AND SWAP IF NECESSARY
+ HRRZ 0,OTBSAV(B) ; CHECK FOR TOP
+ JUMPE 0,RESTAR ; YES RE-ENTER TOP LEVEL
+ PUSH TP,$TTB
+ PUSH TP,B ; SAVE FRAME
+ MOVE B,OTBSAV(B) ; GET PRVIOUS FOR UNBIND HACK
+ MOVEI C,-1(TP)
+ PUSHJ P,CHUNW ; CHECK ANY UNWINDING
+ CAME SP,SPSAV(TB) ; UNBINDING NEEDED?
+ PUSHJ P,SPECSTORE
+ MOVE P,PSAV(TB) ; GET OTHER STUFF
+ MOVE AB,ABSAV(B)
+ HLRE A,AB ; COMPUTE # OF ARGS
+ MOVNI A,-FRAMLN(A) ; MAKE TP POINT PAST FRAME
+ HRLI A,(A)
+ MOVE C,TPSAV(TB) ; COMPUTE TP
+ ADD C,A
+ MOVE TP,C
+ MOVE TB,B ; FIX UP TB
+ HRRZ C,FSAV(TB) ; GET FUNCTION
+ CAIL C,HIBOT
+ JRST (C) ; GO
+ GETYP 0,(C) ; RSUBR OR ENTRY?
+ CAIE 0,TATOM
+ CAIN 0,TRSUBR
+ JRST RETRNT
+ MOVS R,(C) ; SET UP R
+ HRRI R,(C)
+ MOVEI C,0
+ JRST RETRN3
+
+RETRNT: CAIE 0,TRSUBR
+ JRST RETRN1
+ MOVE R,1(C)
+RETRN4: HRRZ C,2(C) ; OFFSET
+RETRN3: SKIPL M,1(R)
+ JRST RETRN5
+RETRN7: ADDI C,(M)
+ JRST (C)
+
+RETRN5: MOVEI D,(M) ; TOTAL OFFSET
+ MOVSS M
+ ADD M,PURVEC+1
+ SKIPL M,1(M)
+ JRST RETRN6
+ ADDI M,(D)
+ JRST RETRN7
+
+RETRN6: HLRZ A,1(R)
+ PUSH P,D
+ PUSH P,C
+ PUSHJ P,PLOAD
+ JRST RETRER ; LOSER
+ POP P,C
+ POP P,D
+ MOVE M,B
+ JRST RETRN7
+
+RETRN1: HRL C,(C) ; FIX LH
+ MOVE B,1(C)
+ PUSH TP,$TVEC
+ PUSH TP,C
+ PUSHJ P,IGVAL
+ GETYP 0,A
+ MOVE C,(TP)
+ SUB TP,[2,,2]
+ CAIE 0,TRSUBR
+ JRST RETRN2
+ MOVE R,B
+ JRST RETRN4
+
+RETRN2: ERRUUO EQUOTE CANT-RETRY-ENTRY-GONE
+
+RETRER: ERRUUO EQUOTE PURE-LOAD-FAILURE
+
+\f
+;FUNCTION TO DO ERROR RETURN
+
+IMFUNCTION ERRET,SUBR
+
+ ENTRY
+ HLRE A,AB ; -2*# OF ARGS
+ JUMPGE A,STP ; RESTART PROCESS
+ ASH A,-1 ; -# OF ARGS
+ AOJE A,ERRET2 ; NO FRAME SUPPLIED
+ AOJL A,TMA
+ ADD AB,[2,,2]
+ PUSHJ P,OKFRT
+ JRST WTYP2
+ SUB AB,[2,,2]
+ PUSHJ P,CHPROC ; POINT TO FRAME SLOT
+ JRST ERRET3
+ERRET2: MOVE B,IMQUOTE LER,[LERR ]INTRUP
+ PUSHJ P,ILVAL ; GET ITS VALUE
+ERRET3: PUSH TP,A
+ PUSH TP,B
+ MOVEI B,-1(TP)
+ PUSHJ P,CHFSWP ; CHECK VALIDITY AND SWAP IF NECESSARY
+ HRRZ 0,OTBSAV(B) ; TOP LEVEL?
+ JUMPE 0,TOPLOS
+ PUSHJ P,CHUNW ; ANY UNWINDING
+ JRST CHFINIS
+
+
+; FUNCTION TO RETURN LAST ERROR FRAME OR PREVIOUS FRAME
+
+IMFUNCTION FRAME,SUBR
+ ENTRY
+ SETZB A,B
+ JUMPGE AB,FRM1 ; DEFAULT CASE
+ CAMG AB,[-3,,0] ; SKIP IF OK ARGS
+ JRST TMA
+ PUSHJ P,OKFRT ; A FRAME OR SIMILAR THING?
+ JRST WTYP1
+
+FRM1: PUSHJ P,CFRAME ; GO TO INTERNAL
+ JRST FINIS
+
+CFRAME: JUMPN A,FRM2 ; ARG SUPPLIED?
+ MOVE B,IMQUOTE LER,[LERR ]INTRUP
+ PUSHJ P,ILVAL
+ JRST FRM3
+FRM2: PUSHJ P,CHPROC ; CHECK FOR PROCESS
+ PUSH TP,A
+ PUSH TP,B
+ MOVEI B,-1(TP) ; POINT TO SLOT
+ PUSHJ P,CHFRM ; CHECK IT
+ MOVE C,(TP) ; GET FRAME BACK
+ MOVE B,OTBSAV(C) ;GET PREVIOUS FRAME
+ SUB TP,[2,,2]
+ TRNN B,-1 ; SKIP IF OK
+ JRST TOPLOSE
+
+FRM3: JUMPN B,FRM4 ; JUMP IF WINNER
+ MOVE B,IMQUOTE THIS-PROCESS
+ PUSHJ P,ILVAL ; GET PROCESS OF INTEREST
+ GETYP A,A ; CHECK IT
+ CAIN A,TUNBOU
+ MOVE B,PVSTOR+1 ; USE CURRENT
+ MOVEI A,PVLNT*2+1(B) ; POINT TO DOPE WORDS
+ MOVE B,TBINIT+1(B) ; AND BASE FRAME
+FRM4: HLL B,OTBSAV(B) ;TIME
+ HRLI A,TFRAME
+ POPJ P,
+
+OKFRT: AOS (P) ;ASSUME WINNAGE
+ GETYP 0,(AB)
+ MOVE A,(AB)
+ MOVE B,1(AB)
+ CAIE 0,TFRAME
+ CAIN 0,TENV
+ POPJ P,
+ CAIE 0,TPVP
+ CAIN 0,TACT
+ POPJ P,
+ SOS (P)
+ POPJ P,
+
+CHPROC: GETYP 0,A ; TYPE
+ CAIE 0,TPVP
+ POPJ P, ; OK
+ MOVEI A,PVLNT*2+1(B)
+ CAMN B,PVSTOR+1 ; THIS PROCESS?
+ JRST CHPRO1
+ MOVE B,TBSTO+1(B)
+ JRST FRM4
+
+CHPRO1: MOVE B,OTBSAV(TB)
+ JRST FRM4
+
+; FUNCTION TO RETURN ARGS TUPLE FOR A FRAME
+
+MFUNCTION ARGS,SUBR
+ ENTRY 1
+ PUSHJ P,OKFRT ; CHECK FRAME TYPE
+ JRST WTYP1
+ PUSHJ P,CARGS
+ JRST FINIS
+
+CARGS: PUSHJ P,CHPROC
+ PUSH TP,A
+ PUSH TP,B
+ MOVEI B,-1(TP) ; POINT TO FRAME SLOT
+ PUSHJ P,CHFRM ; AND CHECK FOR VALIDITY
+ MOVE C,(TP) ; FRAME BACK
+ MOVSI A,TARGS
+CARGS1: GETYP 0,FSAV(C) ; IS THIS A FUNNY ONE
+ CAIE 0,TCBLK ; SKIP IF FUNNY
+ JRST .+3 ; NO NORMAL
+ MOVE C,OTBSAV(C) ; ASSOCIATE WITH PREVIOUS FRAME
+ JRST CARGS1
+ HLR A,OTBSAV(C) ; TIME IT AND
+ MOVE B,ABSAV(C) ; GET POINTER
+ SUB TP,[2,,2] ; FLUSH CRAP
+ POPJ P,
+
+; FUNCTION TO RETURN FUNCTION ASSOCIATED WITH A FRAME
+
+MFUNCTION FUNCT,SUBR
+ ENTRY 1 ; FRAME ARGUMENT
+ PUSHJ P,OKFRT ; CHECK TYPE
+ JRST WTYP1
+ PUSHJ P,CFUNCT
+ JRST FINIS
+
+CFUNCT: PUSHJ P,CHPROC
+ PUSH TP,A
+ PUSH TP,B
+ MOVEI B,-1(TP)
+ PUSHJ P,CHFRM ; CHECK IT
+ MOVE C,(TP) ; RESTORE FRAME
+ HRRZ A,FSAV(C) ;FUNCTION POINTER
+ CAIL A,HIBOT
+ SKIPA B,@-1(A) ;NO, GET SUBR'S NAME POINTER
+ MOVE B,(A)+3 ;YES, GET RSUBR'S NAME ENTRY
+ MOVSI A,TATOM
+ SUB TP,[2,,2]
+ POPJ P,
+
+BADFRAME:
+ ERRUUO EQUOTE FRAME-NO-LONGER-EXISTS
+
+
+TOPLOSE:
+ ERRUUO EQUOTE TOP-LEVEL-FRAME
+
+
+\f
+\f
+; ROUTINE TO HANG INDEFINITELY WITH INTERRUPTS ENABLED
+
+MFUNCTION HANG,SUBR
+
+ ENTRY
+
+ JUMPGE AB,HANG1 ; NO PREDICATE
+ CAMGE AB,[-3,,]
+ JRST TMA
+REHANG: MOVE A,[PUSHJ P,CHKPRH]
+ MOVEM A,ONINT ; CHECK PREDICATE AFTER ANY INTERRUPT
+ PUSH TP,(AB)
+ PUSH TP,1(AB)
+HANG1: ENABLE ;LET OURSELVES BE INTERRUPTED OUT
+ PUSHJ P,%HANG
+ DISABLE ;PREVENT INTERRUPTS AT RANDOM TIMES
+ SETZM ONINT
+ MOVE A,$TATOM
+ MOVE B,IMQUOTE T
+ JRST FINIS
+
+
+; ROUTINE TO SLEEP FOR POSITIVE NUMBER OF SECONDS WITH INTERRUPTS ENABLED
+; ARGUMENT SHOULD BE OF TYPE FIX OR FLOAT AND NON-NEGATIVE
+
+MFUNCTION SLEEP,SUBR
+
+ ENTRY
+
+ JUMPGE AB,TFA
+ CAML AB,[-3,,]
+ JRST SLEEP1
+ CAMGE AB,[-5,,]
+ JRST TMA
+ PUSH TP,2(AB)
+ PUSH TP,3(AB)
+SLEEP1: GETYP 0,(AB)
+ CAIE 0,TFIX
+ JRST .+5
+ MOVE B,1(AB)
+ JUMPL B,OUTRNG ;ARG SHOULDNT BE NEGATIVE
+ IMULI B,30. ;CONVERT TO # OF THIRTIETHS OF A SECOND
+ JRST SLEEPR ;GO SLEEP
+ CAIE 0,TFLOAT ;IF IT WASNT FIX MAKE SURE IT IS FLOAT
+ JRST WTYP1 ;WRONG TYPE ARG
+ MOVE B,1(AB)
+ FMPR B,[30.0] ;CONVERT TO FLOATING # OF THIRTIETHS OF A SECOND
+ MULI B,400 ;KLUDGE TO FIX IT
+ TSC B,B
+ ASH C,(B)-243
+ MOVE B,C ;MOVE THE FIXED NUMBER INTO B
+ JUMPL B,OUTRNG ;CHECK TO SEE THAT WE HAVE POSITIVE NUMBER
+SLEEPR: MOVE A,B
+RESLEE: MOVE B,[PUSHJ P,CHKPRS]
+ CAMGE AB,[-3,,]
+ MOVEM B,ONINT
+ ENABLE
+ PUSHJ P,%SLEEP
+ DISABLE
+ SETZM ONINT
+ MOVE A,$TATOM
+ MOVE B,IMQUOTE T
+ JRST FINIS
+
+CHKPRH: PUSH P,B
+ MOVEI B,HANGP
+ JRST .+3
+
+CHKPRS: PUSH P,B
+ MOVEI B,SLEEPP
+ HRRM B,LCKINT
+ SETZM ONINT ; TURN OFF FEATURE FOR NOW
+ POP P,B
+ POPJ P,
+
+HANGP: SKIPA B,[REHANG]
+SLEEPP: MOVEI B,RESLEE
+ PUSH P,B
+ PUSH P,A
+ DISABLE
+ PUSH TP,(TB)
+ PUSH TP,1(TB)
+ MCALL 1,EVAL
+ GETYP 0,A
+ CAIE 0,TFALSE
+ JRST FINIS
+ POP P,A
+ POPJ P,
+
+MFUNCTION VALRET,SUBR
+; SUBR TO VALRET A STRING TO SUPERIOR ITS PROCESS
+
+ ENTRY 1
+ GETYP A,(AB) ; GET TYPE OF ARGUMENT
+ CAIN A,TFIX ; FIX?
+ JRST VALRT1
+ CAIE A,TCHSTR ; IS IT A CHR STRING?
+ JRST WTYP1 ; NO...ERROR WRONG TYPE
+ PUSHJ P,CSTACK ; COPY THE CHR STRING TO THE STACK
+ ; CSTACK IS IN ATOMHK
+ MOVEI B,0 ; ASCIZ TERMINATOR
+ EXCH B,(P) ; STORE AND RETRIEVE COUNT
+
+; CALCULATE THE BEGINNING ADDR OF THE STRING
+ MOVEI A,-1(P) ; GET ADDR OF TOP OF STACK
+ SUBI A,-1(B) ; GET STARTING ADDR
+ PUSHJ P,%VALRE ; PASS UP TO MONITOR
+ JRST IFALSE ; IF HE RETURNS, RETURN FALSE
+
+VALRT1: MOVE A,1(AB)
+ PUSHJ P,%VALFI
+ JRST IFALSE
+
+MFUNCTION LOGOUT,SUBR
+
+; SUBR TO DO A .LOGOUT (VALID ONLY AT TOP LEVEL)
+ ENTRY 0
+ PUSHJ P,%TOPLQ ; SKIP IF AT TOP LEVEL
+ JRST IFALSE
+ PUSHJ P,CLOSAL
+ PUSHJ P,%LOGOUT ; TRY TO FLUSH
+ JRST IFALSE ; COULDN'T DO IT...RETURN FALSE
+
+; FUNCTS TO GET UNAME AND JNAME
+
+; GET XUNAME (REAL UNAME)
+MFUNCTION XUNAME,SUBR
+
+ ENTRY 0
+
+ PUSHJ P,%RXUNA
+ JRST RSUJNM
+ JRST FINIS ; 10X ROUTINES SKIP
+
+MFUNCTION UNAME,SUBR
+
+ ENTRY 0
+
+ PUSHJ P,%RUNAM
+ JRST RSUJNM
+ JRST FINIS
+
+; REAL JNAME
+MFUNCTION XJNAME,SUBR
+
+ ENTRY 0
+
+ PUSHJ P,%RXJNA
+ JRST RSUJNM
+
+MFUNCTION JNAME,SUBR
+
+ ENTRY 0
+
+ PUSHJ P,%RJNAM
+ JRST RSUJNM
+
+; FUNCTION TO SET AND READ GLOBAL SNAME
+
+MFUNCTION SNAME,SUBR
+
+ ENTRY
+
+ JUMPGE AB,SNAME1
+ CAMG AB,[-3,,]
+ JRST TMA
+ GETYP A,(AB) ; ARG MUST BE STRING
+ CAIE A,TCHSTR
+ JRST WTYP1
+ PUSH TP,$TATOM
+ PUSH TP,IMQUOTE SNM
+ PUSH TP,(AB)
+ PUSH TP,1(AB)
+ MCALL 2,SETG
+ JRST FINIS
+
+SNAME1: MOVE B,IMQUOTE SNM
+ PUSHJ P,IDVAL1
+ GETYP 0,A
+ CAIN 0,TCHSTR
+ JRST FINIS
+ MOVE A,$TCHSTR
+ MOVE B,CHQUOTE
+ JRST FINIS
+
+RSUJNM: PUSHJ P,6TOCHS ; CONVERT IT
+ JRST FINIS
+
+
+SGSNAM: MOVE B,IMQUOTE SNM
+ PUSHJ P,IDVAL1
+ GETYP 0,A
+ CAIE 0,TCHSTR
+ JRST SGSN1
+
+ PUSH TP,A
+ PUSH TP,B
+ PUSHJ P,STRTO6
+ POP P,A
+ SUB TP,[2,,2]
+ JRST .+2
+
+SGSN1: MOVEI A,0
+ PUSHJ P,%SSNAM ; SET SNAME IN SYSTEM
+ POPJ P,
+
+\f
+
+;THIS SUBROUTINE ALLOCATES A NEW PROCESS
+;TAKES TP-STACK SIZE (2*WORDS) IN A AND P-STACK SIZE (WORDS) IN B
+;IS CALLED BY PUSHJ P,. RETURNS IN A AND B A NEW PROCESS.
+
+ICR: PUSH P,A
+ PUSH P,B
+ MOVEI A,PVLNT ;SETUP CALL TO VECTOR FOR PVP
+ PUSHJ P,IVECT ;GOBBLE A VECTOR
+ HRLI C,PVBASE ;SETUP A BLT POINTER
+ HRRI C,(B) ;GET INTO ADDRESS
+ BLT C,PVLNT*2-1(B) ;COPY A PROTOTYPE INTO NEW PVP
+ MOVSI C,400000+SPVP+.VECT. ;SET SPECIAL TYPE
+ MOVEM C,PVLNT*2(B) ;CLOBBER IT IN
+ PUSH TP,A ;SAVE THE RESULTS OF VECTOR
+ PUSH TP,B
+
+ PUSH TP,$TFIX ;GET A UNIFORM VECTOR
+ POP P,B
+ PUSH TP,B
+ MCALL 1,UVECTOR
+ ADD B,[PDLBUF-2,,-1] ;FUDGE WITH BUFFER
+ MOVE C,(TP) ;REGOBBLE PROCESS POINTER
+ MOVEM B,PSTO+1(C) ;STORE IN ALL HOMES
+ MOVEM B,PBASE+1(C)
+
+
+ POP P,A ;PREPARE TO CREATE A TEMPORARY PDL
+ PUSHJ P,IVECT ;GET THE TEMP PDL
+ ADD B,[PDLBUF,,0] ;PDL GROWTH HACK
+ MOVE C,(TP) ;RE-GOBBLE NEW PVP
+ SUB B,[1,,1] ;FIX FOR STACK
+ MOVEM B,TPBASE+1(C)
+
+;SETUP INITIAL BINDING
+
+ PUSH B,$TBIND
+ MOVEM B,SPBASE+1(C) ;SAVE AS BASE OF SP
+ MOVEM B,SPSTO+1(C) ;AND CURRENT THEREOF
+ MOVEM B,CURFCN+1(C) ; AND AS CURRENT FCN FOR SPEC/UNSPEC LOGIC
+ PUSH B,IMQUOTE THIS-PROCESS
+ PUSH B,$TPVP ;GIVE IT PROCESS AS VALUE
+ PUSH B,C
+ ADD B,[2,,2] ;FINISH FRAME
+ MOVEM B,TPSTO+1(C) ;MAKE THIS THE CURRENT STACK POINTER
+ MOVEM C,PVPSTO+1(C) ;SAVE THE NEW PVP ITSELF
+ AOS A,IDPROC ;GOBBLE A UNIQUE PROCESS I.D.
+ MOVEM A,PROCID+1(C) ;SAVE THAT ALSO
+ AOS A,PTIME ; GET A UNIQUE BINDING ID
+ MOVEM A,BINDID+1(C)
+
+ MOVSI A,TPVP ;CLOBBER THE TYPE
+ MOVE B,(TP) ;AND POINTER TO PROCESS
+ SUB TP,[2,,2]
+ POPJ P,
+
+;MINI ROUTINE TO CALL VECTOR WITH COUNT IN A
+
+IVECT: PUSH TP,$TFIX
+ PUSH TP,A
+ MCALL 1,VECTOR ;GOBBLE THE VECTOR
+ POPJ P,
+
+
+;SUBROUTINE TO SWAP A PROCESS IN
+;CALLED WITH JSP A,SWAP AND NEW PVP IN B
+
+SWAP: ;FIRST STORE ALL THE ACS
+
+ MOVE PVP,PVSTOR+1
+ MOVE SP,$TSP ; STORE SPSAVE
+ MOVEM SP,SPSTO(PVP)
+ MOVE SP,SPSTOR+1
+ IRP A,,[SP,AB,TB,TP,P,M,R,FRM]
+ MOVEM A,A!STO+1(PVP)
+ TERMIN
+
+ SETOM 1(TP) ; FENCE POST MAIN STACK
+ MOVEM TP,TPSAV(TB) ; CORRECT FRAME
+ SETZM PSAV(TB) ; CLEAN UP CURRENT FRAME
+ SETZM SPSAV(TB)
+ SETZM PCSAV(TB)
+
+ MOVE E,PVP ;RETURN OLD PROCESS IN E
+ MOVE PVP,D ;AND MAKE NEW ONE BE D
+ MOVEM PVP,PVSTOR+1
+
+SWAPIN:
+ ;NOW RESTORE NEW PROCESSES AC'S
+
+ MOVE PVP,PVSTOR+1
+ IRP A,,[AB,TB,SP,TP,P,M,R,FRM]
+ MOVE A,A!STO+1(PVP)
+ TERMIN
+
+ SETZM SPSTO(PVP)
+ MOVEM SP,SPSTOR+1
+ JRST (C) ;AND RETURN
+
+
+\f
+
+;SUBRS ASSOCIATED WITH TYPES
+
+;TYPE (ITYPE) ARE FUNCTIONS TO RETURN THE ATOMIC NAME OF THE
+;TYPE OF A GOODIE. TYPE TAKES ITS ARGS ON AP AND RETURNS IN A AND B.
+;ITYPE TAKES ITS ARGS IN A AND B AND RETURNS IN SAME (B=0) FOR INVALID
+;TYPECODE.
+MFUNCTION TYPE,SUBR
+
+ ENTRY 1
+ GETYP A,(AB) ;TYPE INTO A
+TYPE1: PUSHJ P,ITYPE ;GO TO INTERNAL
+ JUMPN B,FINIS ;GOOD RETURN
+TYPERR: ERRUUO EQUOTE TYPE-UNDEFINED
+
+CITYPE: GETYP A,A ; GET TYPE FOR COMPILER CALL
+ITYPE: LSH A,1 ;TIMES 2
+ HRLS A ;TO BOTH SIDES
+ ADD A,TYPVEC+1 ;GET ACTUAL LOCATION
+ JUMPGE A,TYPERR ;LOST, TYPE OUT OF BOUNDS
+ MOVE B,1(A) ;PICKUP TYPE
+ HLLZ A,(A)
+ POPJ P,
+
+; PREDICATE -- IS OBJECT OF TYPE SPECIFIED
+
+MFUNCTION %TYPEQ,SUBR,[TYPE?]
+
+ ENTRY
+
+ MOVE D,AB ; GET ARGS
+ ADD D,[2,,2]
+ JUMPGE D,TFA
+ MOVE A,(AB)
+ HLRE C,D
+ MOVMS C
+ ASH C,-1 ; FUDGE
+ PUSHJ P,ITYPQ ; GO INTERNAL
+ JFCL
+ JRST FINIS
+
+ITYPQ: GETYP A,A ; OBJECT
+ PUSHJ P,ITYPE
+TYPEQ0: SOJL C,CIFALS
+ GETYP 0,(D)
+ CAIE 0,TATOM ; Type name must be an atom
+ JRST WRONGT
+ CAMN B,1(D) ; Same as the OBJECT?
+ JRST CPOPJ1 ; Yes, return type name
+ ADD D,[2,,2]
+ JRST TYPEQ0 ; No, continue comparing
+
+CIFALS: MOVEI B,0
+ MOVSI A,TFALSE
+ POPJ P,
+
+CTYPEQ: SOJE A,CIFALS ; TREAT NO ARGS AS FALSE
+ MOVEI D,1(A) ; FIND BASE OF ARGS
+ ASH D,1
+ HRLI D,(D)
+ SUBM TP,D ; D POINTS TO BASE
+ MOVE E,D ; SAVE FOR TP RESTORE
+ ADD D,[3,,3] ; FUDGE
+ MOVEI C,(A) ; NUMBER OF TYPES
+ MOVE A,-2(D)
+ PUSHJ P,ITYPQ
+ JFCL ; IGNORE SKIP FOR NOW
+ MOVE TP,E ; SET TP BACK
+ JUMPL B,CPOPJ1 ; SKIP
+ POPJ P,
+\f
+; Entries to get type codes for types for fixing up RSUBRs and assembling
+
+MFUNCTION %TYPEC,SUBR,[TYPE-C]
+
+ ENTRY
+
+ JUMPGE AB,TFA
+ GETYP 0,(AB)
+ CAIE 0,TATOM
+ JRST WTYP1
+ MOVE B,1(AB)
+ CAMGE AB,[-3,,0] ; skip if only type name given
+ JRST GTPTYP
+ MOVE C,IMQUOTE ANY
+
+TYPEC1: PUSHJ P,CTYPEC ; go to internal
+ JRST FINIS
+
+GTPTYP: CAMGE AB,[-5,,0]
+ JRST TMA
+ GETYP 0,2(AB)
+ CAIE 0,TATOM
+ JRST WTYP2
+ MOVE C,3(AB)
+ JRST TYPEC1
+
+CTYPEC: PUSH P,C ; save primtype checker
+ PUSHJ P,TYPFND ; search type vector
+ JRST CTPEC2 ; create the poor loser
+ POP P,B
+ CAMN B,IMQUOTE ANY
+ JRST CTPEC1
+ CAMN B,IMQUOTE TEMPLATE
+ JRST TCHK
+ PUSH P,D
+ HRRZ A,(A)
+ ANDI A,SATMSK
+ PUSH P,A
+ PUSHJ P,TYPLOO
+ HRRZ 0,(A)
+ ANDI 0,SATMSK
+ CAME 0,(P)
+ JRST TYPDIF
+ MOVE D,-1(P)
+ SUB P,[2,,2]
+CTPEC1: MOVEI B,(D)
+ MOVSI A,TTYPEC
+ POPJ P,
+TCHK: PUSH P,D ; SAVE TYPE
+ MOVE A,D ; GO TO SAT
+ PUSHJ P,SAT
+ CAIG A,NUMSAT ; SKIP IF A TEMPLATE
+ JRST TYPDIF
+ POP P,D ; RESTORE TYPE
+ JRST CTPEC1
+
+CTPEC2: POP P,C ; GET BACK PRIMTYPE
+ SUBM M,(P)
+ PUSH TP,$TATOM
+ PUSH TP,B
+ CAMN C,IMQUOTE ANY
+ JRST CTPEC3
+ PUSH TP,$TATOM
+ PUSH TP,C
+ MCALL 2,NEWTYPE ; CREATE THE POOR GUY
+ MOVE C,IMQUOTE ANY
+ SUBM M,(P) ; UNRELATIVIZE
+ JRST CTYPEC
+
+CTPEC3: HRRZ 0,FSAV(TB)
+ CAIE 0,%TYPEC
+ CAIN 0,%TYPEW
+ JRST TYPERR
+
+ MCALL 1,%TYPEC
+ JRST MPOPJ
+
+MFUNCTION %TYPEW,SUBR,[TYPE-W]
+
+ ENTRY
+
+ JUMPGE AB,TFA
+ GETYP 0,(AB)
+ CAIE 0,TATOM
+ JRST WTYP1
+ MOVEI D,0
+ MOVE C,IMQUOTE ANY
+ MOVE B,1(AB)
+ CAMGE AB,[-3,,0]
+ JRST CTYPW1
+
+CTYPW3: PUSHJ P,CTYPEW
+ JRST FINIS
+
+CTYPW1: GETYP 0,2(AB)
+ CAIE 0,TATOM
+ JRST WTYP2
+ CAMGE AB,[-5,,0] ; JUMP IF RH IS GIVEN
+ JRST CTYPW2
+CTYPW5: MOVE C,3(AB)
+ JRST CTYPW3
+
+CTYPW2: CAMGE AB,[-7,,0]
+ JRST TMA
+ GETYP 0,4(AB)
+ CAIE 0,TFIX
+ JRST WRONGT
+ MOVE D,5(AB)
+ JRST CTYPW5
+
+CTYPEW: PUSH P,D
+ PUSHJ P,CTYPEC ; GET CODE IN B
+ POP P,B
+ HRLI B,(D)
+ MOVSI A,TTYPEW
+ POPJ P,
+
+MFUNCTION %VTYPE,SUBR,[VALID-TYPE?]
+
+ ENTRY 1
+
+ GETYP 0,(AB)
+ CAIE 0,TATOM
+ JRST WTYP1
+ MOVE B,1(AB)
+
+ PUSHJ P,CVTYPE
+ JFCL
+ JRST FINIS
+
+CVTYPE: PUSHJ P,TYPFND ; LOOK IT UP
+ JRST PFALS
+
+ MOVEI B,(D)
+ MOVSI A,TTYPEC
+ JRST CPOPJ1
+
+PFALS: MOVEI B,0
+ MOVSI A,TFALSE
+ POPJ P,
+\f
+;PRIMTTYPE RETURNS THE TYPE ATOM OF A PRIMITIVE TYPE IN A CLASS
+
+STBL: REPEAT NUMSAT,SETZ MQUOTE INTERNAL-TYPE
+
+LOC STBL
+
+IRP A,,[[1WORD,WORD],[2WORD,LIST],[NWORD,UVECTOR],[2NWORD,VECTOR],[STORE,STORAGE]
+[ARGS,TUPLE],[FRAME,FRAME],[ATOM,ATOM],[LOCID,LOCD],[CHSTR,STRING],[OFFS,OFFSET,1]
+[PVP,PROCESS,1],[ASOC,ASOC,1],[LOCA,LOCA],[LOCS,LOCS],[LOCU,LOCU],[LOCV,LOCV]
+[LOCL,LOCL],[LOCN,LOCAS],[LOCT,LOCT,1],[LOCR,LOCR],[LOCB,LOCB,1],[BYTE,BYTES,1]]
+IRP B,C,[A]
+LOC STBL+S!B
+IRP X,Y,[C]
+IFSE [Y],SETZ IMQUOTE X
+IFSN [Y],SETZ MQUOTE X
+.ISTOP
+TERMIN
+.ISTOP
+
+TERMIN
+TERMIN
+
+LOC STBL+NUMSAT+1
+
+
+MFUNCTION TYPEPRIM,SUBR
+
+ ENTRY 1
+ GETYP A,(AB)
+ CAIE A,TATOM
+ JRST NOTATOM
+ MOVE B,1(AB)
+ PUSHJ P,CTYPEP
+ JRST FINIS
+
+CTYPEP: PUSHJ P,TYPLOO ; CONVERT ATOM TO CODE
+ HRRZ A,(A) ; SAT TO A
+ ANDI A,SATMSK
+ JRST PTYP1
+
+MFUNCTION PTSATC,SUBR,[PRIMTYPE-C]
+
+ ENTRY 1
+
+ GETYP A,(AB)
+ CAIE A,TATOM
+ JRST WTYP1
+ MOVE B,1(AB)
+ PUSHJ P,CPRTYC
+ JRST FINIS
+
+CPRTYC: PUSHJ P,TYPLOO
+ MOVE B,(A)
+ ANDI B,SATMSK
+ MOVSI A,TSATC
+ POPJ P,
+
+
+IMFUNCTION PRIMTYPE,SUBR
+
+ ENTRY 1
+
+ MOVE A,(AB) ;GET TYPE
+ PUSHJ P,CPTYPE
+ JRST FINIS
+
+CPTYPE: GETYP A,A
+ PUSHJ P,SAT ;GET SAT
+PTYP1: JUMPE A,TYPERR
+ MOVE B,IMQUOTE TEMPLATE
+ CAIG A,NUMSAT ; IF BIG SAT, THEN TEMPLATE
+ MOVE B,@STBL(A)
+ MOVSI A,TATOM
+ POPJ P,
+\f
+
+; RSUBR MAKES A VECTOR INTO AN OBJECT OF TYPE RSUBR, ALSO SLIGHTLY MUNGING IT
+
+IMFUNCTION RSUBR,SUBR
+ ENTRY 1
+
+ GETYP A,(AB)
+ CAIE A,TVEC ; MUST BE VECTOR
+ JRST WTYP1
+ MOVE B,1(AB) ; GET IT
+ GETYP A,(B) ; CHECK 1ST ELEMENTS TYPE
+ CAIN A,TPCODE ; PURE CODE
+ JRST .+3
+ CAIE A,TCODE
+ JRST NRSUBR
+ HLRM B,(B) ; CLOBEER SPECIAL COUNT FIELD
+ MOVSI A,TRSUBR
+ JRST FINIS
+
+NRSUBR: ERRUUO EQUOTE FIRST-ELEMENT-OF-VECTOR-NOT-CODE
+
+; ROUTINE TO GENERATE ENTRYY OTHER THAN FIRST TO RSUBRR
+
+IMFUNCTION MENTRY,SUBR,[RSUBR-ENTRY]
+
+ ENTRY 2
+
+ GETYP 0,(AB) ; TYPE OF ARG
+ CAIE 0,TVEC ; BETTER BE VECTOR
+ JRST WTYP1
+ GETYP 0,2(AB)
+ CAIE 0,TFIX
+ JRST WTYP2
+ MOVE B,1(AB) ; GET VECTOR
+ CAML B,[-3,,0]
+ JRST BENTRY
+ GETYP 0,(B) ; FIRST ELEMENT
+ CAIE 0,TRSUBR
+ JRST MENTR1
+MENTR2: GETYP 0,2(B)
+ CAIE 0,TATOM
+ JRST BENTRY
+ MOVE C,3(AB)
+ HRRM C,2(B) ; OFFSET INTO VECTOR
+ HLRM B,(B)
+ MOVSI A,TENTER
+ JRST FINIS
+
+MENTR1: CAIE 0,TATOM
+ JRST BENTRY
+ MOVE B,1(B) ; GET ATOM
+ PUSHJ P,IGVAL ; GET VAL
+ GETYP 0,A
+ CAIE 0,TRSUBR
+ JRST BENTRY
+ MOVE C,1(AB) ; RESTORE B
+ MOVEM A,(C)
+ MOVEM B,1(C)
+ MOVE B,C
+ JRST MENTR2
+
+BENTRY: ERRUUO EQUOTE BAD-VECTOR
+
+; SUBR TO GET ENTRIES OFFSET
+
+MFUNCTION LENTRY,SUBR,[ENTRY-LOC]
+
+ ENTRY 1
+
+ GETYP 0,(AB)
+ CAIE 0,TENTER
+ JRST WTYP1
+ MOVE B,1(AB)
+ HRRZ B,2(B)
+ MOVSI A,TFIX
+ JRST FINIS
+
+; RETURN FALSE
+
+RTFALS: MOVSI A,TFALSE
+ MOVEI B,0
+ POPJ P,
+
+;SUBROUTINE CALL FOR RSUBRs
+RCALL: SUBM M,(P) ;CALCULATE PC's OFFSET IN THE RSUBR
+ HRLI 0,400000 ; DONT LOSE IN MULTI SEG MODE
+
+ PUSHJ P,@0 ;GO TO THE PROPER SUBROUTINE
+ SUBM M,(P) ;RECONSTITUTE THE RSUBR's PC
+ POPJ P,
+
+
+
+;CHTYPE TAKES TWO ARGUMENTS. ANY GOODIE AND A AN ATOMIC TYPE NAME
+;IT CHECKS THE STORAGE ALLOCATION TYPES OF THE TWO ARE THE SAME AND
+;IF THEY ARE CHANGES THE TYPE OF THE FIRST TO THAT NAME D IN THE SECOND
+
+MFUNCTION CHTYPE,SUBR
+
+ ENTRY 2
+ GETYP A,2(AB) ;FIRST CHECK THAT ARG 2 IS AN ATOM
+ CAIE A,TATOM
+ JRST NOTATOM
+ MOVE B,3(AB) ;AND TYPE NAME
+ PUSHJ P,TYPLOO ;GO LOOKUP TYPE
+TFOUND: HRRZ B,(A) ;GOBBLE THE SAT
+ TRNE B,CHBIT ; SKIP IF CHTYPABLE
+ JRST CANTCH
+ TRNE B,TMPLBT ; TEMPLAT
+ HRLI B,-1
+ AND B,[-1,,SATMSK]
+ GETYP A,(AB) ;NOW GET TYPE TO HACK
+ PUSHJ P,SAT ;FIND OUT ITS SAT
+ JUMPE A,TYPERR ;COMPLAIN
+ CAILE A,NUMSAT
+ JRST CHTMPL ; JUMP IF TEMPLATE DATA
+ CAIE A,(B) ;DO THEY AGREE?
+ JRST TYPDIF ;NO, COMPLAIN
+CHTMP1: MOVSI A,(D) ;GET NEW TYPE
+ HRR A,(AB) ; FOR DEFERRED GOODIES
+ JUMPL B,CHMATC ; CHECK IT
+ MOVE B,1(AB) ;AND VALUE
+ JRST FINIS
+
+CHTMPL: MOVE E,1(AB) ; GET ARG
+ HLRZ A,(E)
+ ANDI A,SATMSK
+ MOVE 0,3(AB) ; SEE IF TO "TEMPLATE"
+ CAMN 0,IMQUOTE TEMPLATE
+ JRST CHTMP1
+ TLNN E,-1 ; SKIP IF RESTED
+ CAIE A,(B)
+ JRST TYPDIF
+ JRST CHTMP1
+
+CHMATC: PUSH TP,A
+ PUSH TP,1(AB) ; SAVE GOODIE
+ MOVSI A,TATOM
+ MOVE B,3(AB)
+ MOVSI C,TATOM
+ MOVE D,IMQUOTE DECL
+ PUSHJ P,IGET ; FIND THE DECL
+ PUSH TP,A
+ PUSH TP,B
+ MOVE C,(AB)
+ MOVE D,1(AB) ; NOW GGO TO MATCH
+ PUSHJ P,TMATCH
+ JRST CHMAT1
+ SUB TP,[2,,2]
+CHMAT2: POP TP,B
+ POP TP,A
+ JRST FINIS
+
+CHMAT1: POP TP,B
+ POP TP,A
+ MOVE C,-1(TP)
+ MOVE D,(TP)
+ PUSHJ P,TMATCH
+ JRST TMPLVI
+ JRST CHMAT2
+
+TYPLOO: PUSHJ P,TYPFND
+ ERRUUO EQUOTE BAD-TYPE-NAME
+ POPJ P,
+
+TYPFND: HLRE A,B ; FIND DOPE WORDS
+ SUBM B,A ; A POINTS TO IT
+ HRRE D,(A) ; TYPE-CODE TO D
+ JUMPE D,CPOPJ
+ ANDI D,TYPMSK ; FLUSH FUNNY BITS
+ MOVEI A,(D)
+ ASH A,1
+ HRLI A,(A)
+ ADD A,TYPVEC+1
+CPOPJ1: AOS (P)
+ POPJ P,
+
+
+REPEAT 0,[
+ MOVE A,TYPVEC+1 ;GOBBLE DOWN TYPE VECTOR
+ MOVEI D,0 ;INITIALIZE TYPE COUNTER
+TLOOK: CAMN B,1(A) ;CHECK THIS ONE
+ JRST CPOPJ1
+ ADDI D,1 ;BUMP COUNTER
+ AOBJP A,.+2 ;COUTN DOWN ON VECTOR
+ AOBJN A,TLOOK
+ POPJ P,
+CPOPJ1: AOS (P)
+ POPJ P,
+]
+
+TYPDIF: ERRUUO EQUOTE STORAGE-TYPES-DIFFER
+
+
+TMPLVI: ERRUUO EQUOTE DECL-VIOLATION
+\f
+
+; FUNCTION TO ADD A NEW TYPE TO THE WORLD WITH GIVEN PRIMITIVE TYPE
+
+MFUNCTION NEWTYPE,SUBR
+
+ ENTRY
+
+ HLRZ 0,AB ; CHEC # OF ARGS
+ CAILE 0,-4 ; AT LEAST 2
+ JRST TFA
+ CAIGE 0,-6
+ JRST TMA ; NOT MORE THAN 3
+ GETYP A,(AB) ; GET 1ST ARGS TYPE (SHOULD BE ATOM)
+ GETYP C,2(AB) ; SAME WITH SECOND
+ CAIN A,TATOM ; CHECK
+ CAIE C,TATOM
+ JRST NOTATOM
+
+ MOVE B,3(AB) ; GET PRIM TYPE NAME
+ PUSHJ P,TYPLOO ; LOOK IT UP
+ HRRZ A,(A) ; GOBBLE SAT
+ ANDI A,SATMSK
+ HRLI A,TATOM ; MAKE NEW TYPE
+ PUSH P,A ; AND SAVE
+ MOVE B,1(AB) ; SEE IF PREV EXISTED
+ PUSHJ P,TYPFND
+ JRST NEWTOK ; DID NOT EXIST BEFORE
+ MOVEI B,2(A) ; FOR POSSIBLE TMPLAT BIT
+ HRRZ A,(A) ; GET SAT
+ HRRZ 0,(P) ; AND PROPOSED
+ ANDI A,SATMSK
+ ANDI 0,SATMSK
+ CAIN 0,(A) ; SKIP IF LOSER
+ JRST NEWTFN ; O.K.
+
+ ERRUUO EQUOTE TYPE-ALREADY-EXISTS
+
+NEWTOK: POP P,A
+ MOVE B,1(AB) ; NEWTYPE NAME
+ PUSHJ P,INSNT ; MUNG IN NEW TYPE
+
+NEWTFN: CAML AB,[-5,,] ; SKIP IF TEMPLAT SUPPLIED
+ JRST NEWTF1
+ MOVEI 0,TMPLBT ; GET THE BIT
+ IORM 0,-2(B) ; INTO WORD
+ MOVE A,(AB) ; GET TYPE NAME
+ MOVE B,1(AB)
+ MOVSI C,TATOM
+ MOVE D,IMQUOTE DECL
+ PUSH TP,4(AB) ; GET TEMLAT
+ PUSH TP,5(AB)
+ PUSHJ P,IPUT
+NEWTF1: MOVE A,(AB)
+ MOVE B,1(AB) ; RETURN NAME
+ JRST FINIS
+
+; SET UP GROWTH FIELDS
+
+IGROWT: SKIPA A,[111100,,(C)]
+IGROWB: MOVE A,[001100,,(C)]
+ HLRE B,C
+ SUB C,B ; POINT TO DOPE WORD
+ MOVE B,TYPIC ; INDICATED GROW BLOCK
+ DPB B,A
+ POPJ P,
+
+INSNT: PUSH TP,A
+ PUSH TP,B ; SAVE NAME OF NEWTYPE
+ MOVE C,TYPBOT+1 ; CHECK GROWTH NEED
+ CAMGE C,TYPVEC+1
+ JRST ADDIT ; STILL ROOM
+GAGN: PUSHJ P,IGROWB ; SETUP BOTTOM GROWTH
+ SKIPE C,EVATYP+1
+ PUSHJ P,IGROWT ; SET UP TOP GROWTH
+ SKIPE C,APLTYP+1
+ PUSHJ P,IGROWT
+ SKIPE C,PRNTYP+1
+ PUSHJ P,IGROWT
+ MOVE C,[11.,,5] ; SET UP INDICATOR FOR AGC
+ PUSHJ P,AGC ; GROW THE WORLD
+ AOJL A,GAGN ; BAD AGC LOSSAGE
+ MOVE 0,[-101,,-100]
+ ADDM 0,TYPBOT+1 ; FIX UP POINTER
+
+ADDIT: MOVE C,TYPVEC+1
+ SUB C,[2,,2] ; ALLOCATE ROOM
+ MOVEM C,TYPVEC+1
+ HLRE B,C ; PREPARE TO BLT
+ SUBM C,B ; C POINTS DOPE WORD END
+ HRLI C,2(C) ; GET BLT AC READY
+ BLT C,-3(B)
+ POP TP,-1(B) ; CLOBBER IT IN
+ POP TP,-2(B)
+ HLRE C,TYPVEC+1 ; GET CODE
+ MOVNS C
+ ASH C,-1
+ SUBI C,1
+ MOVE D,-1(B) ; B HAS POINTER TO TYPE VECTOR DOPE WORDS
+ MOVEI 0,(D)
+ CAIG 0,HIBOT ; IS ATOM PURE?
+ JRST ADDNOI ; NO, SO NO HACKING REQUIRED
+ PUSH P,C
+ MOVE B,D
+ PUSHJ P,IMPURIF ; DO IMPURE OF ATOM
+ MOVE C,TYPVEC+1
+ HLRE B,C
+ SUBM C,B ; RESTORE B
+ POP P,C
+ MOVE D,-1(B) ; RESTORE D
+ADDNOI: HLRE A,D
+ SUBM D,A
+ TLO C,400000
+ HRRM C,(A) ; INTO "GROWTH" FIELD
+ POPJ P,
+
+\f
+; Interface to interpreter for setting up tables associated with
+; template data structures.
+; A/ <\b-name of type>\b-
+; B/ <\b-length ins>\b-
+; C/ <\b-uvector of garbage collector code or 0>
+; D/ <\b-uvector of GETTERs>\b-
+; E/ <\b-uvector of PUTTERs>\b-
+
+CTMPLT: SUBM M,(P) ; could possibly gc during this stuff
+ PUSH TP,$TATOM ; save name of type
+ PUSH TP,A
+ PUSH P,B ; save length instr
+ HLRE A,TD.LNT+1 ; check for template slots left?
+ HRRZ B,TD.LNT+1
+ SUB B,A ; point to dope words
+ HLRZ B,1(B) ; get real length
+ ADDI A,-2(B)
+ JUMPG A,GOODRM ; jump if ok
+
+ PUSH TP,$TUVEC ; save getters and putters
+ PUSH TP,C
+ PUSH TP,$TUVEC ; save getters and putters
+ PUSH TP,D
+ PUSH TP,$TUVEC
+ PUSH TP,E
+ MOVEI A,10-2(B) ; grow it 10 by copying remember d.w. length
+ PUSH P,A ; save new length
+ PUSHJ P,CAFRE1 ; get frozen uvector
+ ADD B,[10,,10] ; rest it down some
+ HRL C,TD.LNT+1 ; prepare to BLT in
+ MOVEM B,TD.LNT+1 ; and save as new length vector
+ HRRI C,(B) ; destination
+ ADD B,(P) ; final destination address
+ BLT C,-12(B)
+ MOVE A,(P) ; length for new getters
+ PUSHJ P,CAFRE1
+ HRL C,TD.GET+1 ; get old for copy
+ MOVEM B,TD.GET+1
+ PUSHJ P,DOBLTS ; go fixup new uvector
+ MOVE A,(P) ; finally putters
+ PUSHJ P,CAFRE1
+ HRL C,TD.PUT+1
+ MOVEM B,TD.PUT+1
+ PUSHJ P,DOBLTS ; go fixup new uvector
+ MOVE A,(P) ; finally putters
+ PUSHJ P,CAFRE1
+ HRL C,TD.AGC+1
+ MOVEM B,TD.AGC+1
+ PUSHJ P,DOBLTS ; go fixup new uvector
+ SUB P,[1,,1] ; flush stack craft
+ MOVE E,(TP)
+ MOVE D,-2(TP)
+ MOVE C,-4(TP) ;GET TD.AGC
+ SUB TP,[6,,6]
+
+GOODRM: MOVE B,TD.LNT+1 ; move down to fit new guy
+ SUB B,[1,,1] ; will always win due to prev checks
+ MOVEM B,TD.LNT+1
+ HRLI B,1(B)
+ HLRE A,TD.LNT+1
+ MOVNS A
+ ADDI A,-1(B) ; A/ final destination
+ BLT B,-1(A)
+ POP P,(A) ; new length ins munged in
+ HLRE A,TD.LNT+1
+ MOVNS A ; A/ offset for other guys
+ PUSH P,A ; save it
+ ADD A,TD.GET+1 ; point for storing uvs of ins
+ MOVEM D,-1(A)
+ MOVE A,(P)
+ ADD A,TD.PUT+1
+ MOVEM E,-1(A) ; store putter also
+ MOVE A,(P)
+ ADD A,TD.AGC+1
+ MOVEM C,-1(A) ; store putter also
+ POP P,A ; compute primtype
+ ADDI A,NUMSAT
+ PUSH P,A
+ MOVE B,(TP) ; ready to mung type vector
+ SUB TP,[2,,2]
+ PUSHJ P,TYPFND ; CHECK TO SEE WHETHER TEMPLATE EXISTS
+ JRST NOTEM
+ POP P,C ; GET SAT
+ HRRM C,(A)
+ JRST MPOPJ
+NOTEM: POP P,A ; RESTORE SAT
+ HRLI A,TATOM ; GET TYPE
+ PUSHJ P,INSNT ; INSERT INTO VECTOR
+ JRST MPOPJ
+
+; this routine copies GET and PUT vectors into new ones
+
+DOBLTS: HRRI C,(B)
+ ADD B,-1(P)
+ BLT C,-11(B) ; zap those guys in
+ MOVEI A,TUVEC ; mung in uniform type
+ PUTYP A,(B)
+ MOVEI C,-7(B) ; zero out remainder of uvector
+ HRLI C,-10(B)
+ SETZM -1(C)
+ BLT C,-1(B)
+ POPJ P,
+\f
+
+; FUNCTIONS TO SET UP EVALUATION AND APPLICATION RULES FOR DATA TYPES
+
+MFUNCTION EVALTYPE,SUBR
+
+ ENTRY
+
+ PUSHJ P,CHKARG ; VERIFY WINNAGE IN ARGS
+ MOVEI A,EVATYP ; POINT TO TABLE
+ MOVEI E,EVTYPE ; POINT TO PURE VERSION
+ MOVEI 0,EVAL
+TBLCAL: PUSHJ P,TBLSET ; SETUP TABLE ENTRY
+ JRST FINIS
+
+MFUNCTION APPLYTYPE,SUBR
+
+ ENTRY
+
+ PUSHJ P,CHKARG
+ MOVEI A,APLTYP ; POINT TO APPLY TABLE
+ MOVEI E,APTYPE ; PURE TABLE
+ MOVEI 0,APPLY
+ JRST TBLCAL
+
+
+MFUNCTION PRINTTYPE,SUBR
+
+ ENTRY
+
+ PUSHJ P,CHKARG
+ MOVEI A,PRNTYP ; POINT TO APPLY TABLE
+ MOVEI E,PRTYPE ; PURE TABLE
+ MOVEI 0,PRINT
+ JRST TBLCAL
+
+; CHECK ARGS AND SETUP FOR TABLE HACKER
+
+CHKARG: JUMPGE AB,TFA
+ CAMGE AB,[-5,,]
+ JRST TMA
+ GETYP A,(AB) ; 1ST MUST BE TYPE NAME
+ CAIE A,TATOM
+ JRST WTYP1
+ MOVE B,1(AB) ; GET ATOM
+ PUSHJ P,TYPLOO ; VERIFY THAT IT IS A TYPE
+ PUSH P,D ; SAVE TYPE NO.
+ MOVEI D,-1 ; INDICATE FUNNYNESS
+ CAML AB,[-3,,] ; SKIP IF 2 OR MORE
+ JRST TY1AR
+ HRRZ A,(A) ; GET SAT
+ ANDI A,SATMSK
+ PUSH P,A
+ GETYP A,2(AB) ; GET 2D TYPE
+ CAIE A,TATOM ; EITHER TYPE OR APPLICABLE
+ JRST TRYAPL ; TRY APPLICABLE
+ MOVE B,3(AB) ; VERIFY IT IS A TYPE
+ PUSHJ P,TYPLOO
+ HRRZ A,(A) ; GET SAT
+ ANDI A,SATMSK
+ POP P,C ; RESTORE SAVED SAT
+ CAIE A,(C) ; SKIP IF A WINNER
+ JRST TYPDIF ; REPORT ERROR
+TY1AR: POP P,C ; GET SAVED TYPE
+ MOVEI B,0 ; TELL THAT WE ARE A TYPE
+ POPJ P,
+
+TRYAPL: PUSHJ P,APLQ ; IS THIS APPLICABLE
+ JRST NAPT
+ SUB P,[1,,1]
+ MOVE B,2(AB) ; RETURN SAME
+ MOVE D,3(AB)
+ POP P,C
+ POPJ P,
+
+\f
+; HERE TO PUT ENTRY IN APPROPRIATE TABLE
+
+TBLSET: PUSH TP,B
+ PUSH TP,D ; SAVE VALUE
+ PUSH TP,$TFIX
+ PUSH TP,A
+ PUSH P,C ; SAVE TYPE BEING HACKED
+ PUSH P,E
+ SKIPE B,1(A) ; SKIP IF VECTOR DOESN'T EXIST YET
+ JRST TBL.OK
+ MOVE B,-2(TP) ; CHECK FOR RETURN IT HACK
+ SKIPN -3(TP)
+ CAIE B,-1
+ JRST .+2
+ JRST RETPM2
+ HLRE A,TYPBOT+1 ; GET CURRENT TABLE LNTH
+ MOVNS A
+ ASH A,-1
+ PUSH P,0
+ PUSHJ P,IVECT ; GET VECTOR
+ POP P,0
+ MOVE C,(TP) ; POINT TO RETURN POINT
+ MOVEM B,1(C) ; SAVE VECTOR
+
+TBL.OK: POP P,E
+ POP P,C ; RESTORE TYPE
+ SUB TP,[2,,2]
+ POP TP,D
+ POP TP,A
+ JUMPN A,TBLOK1 ; JUMP IF FUNCTION ETC. SUPPLIED
+ CAIN D,-1
+ JRST TBLOK1
+ CAILE D,NUMPRI ; SKIP IF ORIGINAL TYPE
+ MOVNI E,(D) ; CAUSE E TO ENDUP 0
+ ADDI E,(D) ; POINT TO PURE SLOT
+TBLOK1: ADDI C,(C) ; POINT TO VECTOR SLOT
+ ADDI C,(B)
+ CAIN D,-1
+ JRST RETCUR
+ JUMPN A,OK.SET ; OK TO CLOBBER
+ ADDI B,(D) ; POINT TO TARGET TYPE'S SLOT
+ ADDI B,(D) ; POINT TO TARGET TYPE'S SLOT
+ SKIPN A,(B) ; SKIP IF WINNER
+ SKIPE 1(B) ; SKIP IF LOSER
+ SKIPA D,1(B) ; SETUP D
+ JRST CH.PTB ; CHECK PURE TABLE
+
+OK.SET: CAIN 0,(D) ; SKIP ON RESET
+ SETZB A,D
+ MOVEM A,(C) ; STORE
+ MOVEM D,1(C)
+RETAR1: MOVE A,(AB) ; RET TYPE
+ MOVE B,1(AB)
+ JRST FINIS
+
+CH.PTB: MOVEI A,0
+ MOVE D,[SETZ NAPT]
+ JUMPE E,OK.SET
+ MOVE D,(E)
+ JRST OK.SET
+
+RETPM2: SUB TP,[4,,4]
+ SUB P,[2,,2]
+ ASH C,1
+ SOJA E,RETPM4
+
+RETCUR: SKIPN A,(C)
+ SKIPE 1(C)
+ SKIPA B,1(C)
+ JRST RETPRM
+
+ JUMPN A,CPOPJ
+RETPM1: MOVEI A,0
+ JUMPL B,RTFALS
+ CAMN B,1(E)
+ JRST .+3
+ ADDI A,2
+ AOJA E,.-3
+
+RETPM3: ADD A,TYPVEC+1
+ MOVE B,3(A)
+ MOVE A,2(A)
+ POPJ P,
+
+RETPRM: SUBI C,(B) ; UNDO BADNESS
+RETPM4: CAIG C,NUMPRI*2
+ SKIPG 1(E)
+ JRST RTFALS
+
+ MOVEI A,-2(C)
+ JRST RETPM3
+
+CALLTY: MOVE A,TYPVEC
+ MOVE B,TYPVEC+1
+ POPJ P,
+
+MFUNCTION ALLTYPES,SUBR
+
+ ENTRY 0
+
+ MOVE A,TYPVEC
+ MOVE B,TYPVEC+1
+ JRST FINIS
+
+;\f
+
+;FUNCTION TO RETURN TYPE OF ELEMENTS IN A UVECTOR
+
+MFUNCTION UTYPE,SUBR
+
+ ENTRY 1
+
+ GETYP A,(AB) ;GET U VECTOR
+ PUSHJ P,SAT
+ CAIE A,SNWORD
+ JRST WTYP1
+ MOVE B,1(AB) ; GET UVECTOR
+ PUSHJ P,CUTYPE
+ JRST FINIS
+
+CUTYPE: HLRE A,B ;GET -LENGTH
+ HRRZS B
+ SUB B,A ;POINT TO TYPE WORD
+ GETYP A,(B)
+ JRST ITYPE ; GET NAME OF TYPE
+
+; FUNCTION TO CHANGE UNIFORM TYPE OF A VECTOR
+
+MFUNCTION CHUTYPE,SUBR
+
+ ENTRY 2
+
+ GETYP A,2(AB) ;GET 2D TYPE
+ CAIE A,TATOM
+ JRST NOTATO
+ GETYP A,(AB) ; CALL WITH UVECTOR?
+ PUSHJ P,SAT
+ CAIE A,SNWORD
+ JRST WTYP1
+ MOVE A,1(AB) ; GET UV POINTER
+ MOVE B,3(AB) ;GET ATOM
+ PUSHJ P,CCHUTY
+ MOVE A,(AB) ; RETURN UVECTOR
+ MOVE B,1(AB)
+ JRST FINIS
+
+CCHUTY: PUSH TP,$TUVEC
+ PUSH TP,A
+ PUSHJ P,TYPLOO ;LOOK IT UP
+ HRRZ B,(A) ;GET SAT
+ TRNE B,CHBIT
+ JRST CANTCH
+ ANDI B,SATMSK
+ SKIPGE MKTBS(B)
+ JRST CANTCH
+ HLRE C,(TP) ;-LENGTH
+ HRRZ E,(TP)
+ SUB E,C ;POINT TO TYPE
+ GETYP A,(E) ;GET TYPE
+ JUMPE A,WIN0 ;ALLOW TYPE "LOSE" TO CHANGE TO ANYTHING
+ PUSHJ P,SAT ;GET SAT
+ JUMPE A,TYPERR
+ CAIE A,(B) ;COMPARE
+ JRST TYPDIF
+WIN0: ADDI D,.VECT.
+ HRLM D,(E) ;CLOBBER NEW ONE
+ POP TP,B
+ POP TP,A
+ POPJ P,
+
+CANTCH: PUSH TP,$TATOM
+ PUSH TP,EQUOTE CANT-CHTYPE-INTO
+ PUSH TP,2(AB)
+ PUSH TP,3(AB)
+ MOVEI A,2
+ JRST CALER
+
+NOTATOM:
+ PUSH TP,$TATOM
+ PUSH TP,EQUOTE NON-ATOMIC-ARGUMENT
+ PUSH TP,(AB)
+ PUSH TP,1(AB)
+ MOVEI A,2
+ JRST CALER
+
+
+\f
+; SUBROUTINE TO LEAVE MUDDLE CLOSING ALL CHANNELS ON THE WAY
+
+MFUNCTION QUIT,SUBR
+
+ ENTRY 0
+
+
+ PUSHJ P,CLOSAL ; DO THE CLOSES
+ PUSHJ P,%KILLM
+ JRST IFALSE ; JUST IN CASE
+
+CLOSAL: MOVEI B,CHNL0+2 ; POINT TO 1ST (NOT INCLUDING TTY I/O)
+ MOVE PVP,PVSTOR+1
+ MOVE TVP,REALTV+1(PVP)
+ SUBI B,(TVP)
+ HRLS B
+ ADD B,TVP
+ PUSH TP,$TVEC
+ PUSH TP,B
+ PUSH P,[N.CHNS-1] ; MAX NO. OF CHANS
+
+CLOSA1: MOVE B,(TP)
+ ADD B,[2,,2]
+ MOVEM B,(TP)
+ HLLZS -2(B)
+ SKIPN C,-1(B) ; THIS ONE OPEN?
+ JRST CLOSA4 ; NO
+ CAME C,TTICHN+1
+ CAMN C,TTOCHN+1
+ JRST CLOSA4
+ PUSH TP,-2(B) ; PUSH IT
+ PUSH TP,-1(B)
+ MCALL 1,FCLOSE ; CLOSE IT
+CLOSA4: SOSLE (P) ; COUNT DOWN
+ JRST CLOSA1
+
+
+ SUB TP,[2,,2]
+ SUB P,[1,,1]
+
+CLOSA3: SKIPN B,CHNL0+1
+ POPJ P,
+ PUSH TP,(B)
+ HLLZS (TP)
+ PUSH TP,1(B)
+ HRRZ B,(B)
+ MOVEM B,CHNL0+1
+ MCALL 1,FCLOSE
+ JRST CLOSA3
+\f
+
+IMPURE
+
+WHOAMI: 0 ; SYAYS WHETHER I AM REALLY A MUDDLE OR SOME HACK
+
+
+;GARBAGE COLLECTORS PDLS
+
+
+GCPDL: -GCPLNT,,GCPDL
+
+ BLOCK GCPLNT
+
+
+PURE
+
+MUDSTR: ASCII /MUDDLE \7f\7f\7f/
+STRNG: -1
+ -1
+ -1
+ ASCIZ / IN OPERATION./
+
+;MARKED PDLS FOR GC PROCESS
+
+VECTGO
+; DUMMY FRAME FOR INITIALIZER CALLS
+
+ TENTRY,,LISTEN
+ 0
+ .-3
+ 0
+ 0
+ -ITPLNT,,TPBAS-1
+ 0
+
+TPBAS: BLOCK ITPLNT+PDLBUF
+ GENERAL
+ ITPLNT+2+PDLBUF+7,,0
+
+
+VECRET
+
+
+$TMATO: TATOM,,-1
+
+END
+\f
\ No newline at end of file
projects / pdp10-muddle.git / blobdiff