mirror of
https://github.com/PDP-10/its.git
synced 2026-02-28 17:29:10 +00:00
26c6e4faa2
Most of these are the same as before. For UUOH, I've taken the fixed ITS conditionals from uuoh.mid.181 (16th March 1981). For MAPPUR, I've put the Tenex conditional around the whole of the segment-switching code since none of it is needed on ITS. Note in particular that the BOT patch is no longer needed -- this version of Muddle works happily with the pure region at 700000.
2056 lines
39 KiB
Plaintext
2056 lines
39 KiB
Plaintext
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
|
||
|
||
|
||
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
|
||
|
||
;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
|
||
|
||
|
||
;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
|
||
|
||
;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
|
||
|
||
|
||
;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
|
||
|
||
|
||
|
||
|
||
; 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,
|
||
|
||
|
||
|
||
;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
|
||
|
||
|
||
|
||
|
||
;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,
|
||
|
||
; 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,
|
||
|
||
;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,
|
||
|
||
|
||
; 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
|
||
|
||
|
||
; 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,
|
||
|
||
|
||
; Interface to interpreter for setting up tables associated with
|
||
; template data structures.
|
||
; A/ <-name of type>-
|
||
; B/ <-length ins>-
|
||
; C/ <-uvector of garbage collector code or 0>
|
||
; D/ <-uvector of GETTERs>-
|
||
; E/ <-uvector of PUTTERs>-
|
||
|
||
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,
|
||
|
||
|
||
; 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,
|
||
|
||
|
||
; 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
|
||
|
||
;
|
||
|
||
;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
|
||
|
||
|
||
|
||
; 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
|
||
|
||
|
||
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 <20><>
|
||
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
|
||
|