github.com/PDP-10.its
1
0
Fork 0
mirror of https://github.com/PDP-10/its.git synced 2026-01-17 08:43:21 +00:00
Code Issues Releases Wiki Activity
PDP-10.its/src/mudsys/main.353
Lars Brinkhoff 7ab2f2a441 Increase symbol table size for some files.
2018-04-25 09:32:25 +01:00

2060 lines
39 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 MAIN LOOP AND GLOBALLY REFERENCED SUBROUTINES
RELOCA
.SYMTAB 3337.
.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
XMOVEI E,TOPLEV
MOVEI A,TFALSE ; IN CASE FALLS OFF PROCESS
MOVEI B,0
MOVEM 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
PUSH TP,(AB)
PUSH TP,1(AB)
PUSHJ P,CHKPRD
REHANG: MOVE A,[PUSHJ P,CHKPRH]
MOVEM A,ONINT ; CHECK PREDICATE AFTER ANY INTERRUPT
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)
PUSHJ P,CHKPRD
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
CHKPRD: 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
Reference in New Issue View Git Blame Copy Permalink