--- /dev/null
+TITLE EVAL -- MUDDLE EVALUATOR
+
+RELOCATABLE
+
+.SYMTAB 3337.
+
+; GERALD JAY SUSSMAN, 1971. REWRITTEN MANY TIMES SINCE C. REEVE (1972--1974)
+
+
+.GLOBAL BINDID,LPROG,GLOBSP,GLOBASE,SPBASE,TPBASE,PTIME,SWAP,CHFRAM
+.GLOBAL IGVAL,CHKARG,NXTDCL,TPOVFL,CHFRM,PROCHK,CHFSWP,VECBOT,TYPSGR
+.GLOBAL ILVAL,ER1ARG,SPECBIND,MAKACT,SPECSTORE,MAKTUP,TPALOC,IBIND,SSPECS
+.GLOBAL IDVAL,EVECTO,EUVECT,CHARGS,BCKTRK,CELL,ILOC,IGLOC,CHKDCL,SSPEC1
+.GLOBAL PDLBUF,MESS,FACTI,CHKARG,MAKENV,PSTAT,BNDV,UNBOU,UNAS,IGDECL
+.GLOBAL 1STEPR,SEGMNT,SEGLST,NAPT,EVTYPE,EVATYP,APTYPE,APLTYP,APLQ,IDVAL1
+.GLOBAL TESTR,VALG,TYPG,INCR1,TMATCH,TYPMIS,SAT,MAKACT,NTPALO,SPECBND
+.GLOBAL TPGROW,CHKAB,TYPSEG,NXTLM,MONCH0,CHFINI,RMONC0,IMPURIFY,ICONS,INCONS
+.GLOBAL CILVAL,CISET,CIGVAL,CSETG,MAPPLY,CLLOC,CGLOC,CASSQ,CGASSQ,CBOUND
+.GLOBAL IIGLOC,CHUNW,IUNWIN,UNWIN2,SPCCHK,CURFCN,TMPLNT,TD.LNT,TBINIT
+.GLOBAL SPECBE,BSETG,GLOTOP,CANDP,CORP,TFA,TMA,DSTORE,PVSTOR,SPSTOR
+.GLOBAL AGC,GVLINC,LVLINC,CGBOUN,IEVECT,MAKTU2,STOSTR,HIBOT,POPUNW,ISTRUC
+.GLOBAL NOSET,NOSETG
+
+.INSRT MUDDLE >
+
+MONITOR
+
+\f
+; ENTRY TO EXPAND A MACRO
+
+MFUNCTION EXPAND,SUBR
+
+ ENTRY 1
+
+ MOVE PVP,PVSTOR+1
+ MOVEI A,PVLNT*2+1(PVP)
+ HRLI A,TFRAME
+ MOVE B,TBINIT+1(PVP)
+ HLL B,OTBSAV(B)
+ PUSH TP,A
+ PUSH TP,B
+ MOVEI B,-1(TP)
+ JRST AEVAL2
+
+; MAIN EVAL ENTRANCE
+
+IMFUNCTION EVAL,SUBR
+
+ ENTRY
+
+ MOVE PVP,PVSTOR+1
+ SKIPE C,1STEPR+1(PVP) ; BEING 1 STEPPED?
+ JRST 1STEPI ; YES HANDLE
+EVALON: HLRZ A,AB ;GET NUMBER OF ARGS
+ CAIE A,-2 ;EXACTLY 1?
+ JRST AEVAL ;EVAL WITH AN ALIST
+SEVAL: GETYP A,(AB) ;GET TYPE OF ARG
+ SKIPE C,EVATYP+1 ; USER TYPE TABLE?
+ JRST EVDISP
+SEVAL1: CAIG A,NUMPRI ;PRIMITIVE?
+ JRST SEVAL2 ;YES-DISPATCH
+
+SELF: MOVE A,(AB) ;TYPES WHICH EVALUATE
+ MOVE B,1(AB)
+ JRST EFINIS ;TO SELF-EG NUMBERS
+
+SEVAL2: HRRO A,EVTYPE(A)
+ JRST (A)
+
+; HERE FOR USER EVAL DISPATCH
+
+EVDISP: ADDI C,(A) ; POINT TO SLOT
+ ADDI C,(A)
+ SKIPE (C) ; SKIP EITHER A LOSER OR JRST DISP
+ JRST EVDIS1 ; APPLY EVALUATOR
+ SKIPN C,1(C) ; GET ADDR OR GO TO PURE DISP
+ JRST SEVAL1
+ JRST (C)
+
+EVDIS1: PUSH TP,(C)
+ PUSH TP,1(C)
+ PUSH TP,(AB)
+ PUSH TP,1(AB)
+ MCALL 2,APPLY ; APPLY HACKER TO OBJECT
+ JRST EFINIS
+
+
+; EVAL DISPATCH TABLE
+
+IF2,SELFS==400000,,SELF
+
+DISTBL EVTYPE,SELFS,[[TFORM,EVFORM],[TLIST,EVLIST],[TVEC,EVECT],[TUVEC,EUVEC]
+[TSEG,ILLSEG]]
+\f
+
+;WATCH FOR SUBTLE BUG 43 LERR,LPROG OR BINDID
+AEVAL:
+ CAIE A,-4 ;EXACTLY 2 ARGS?
+ JRST WNA ;NO-ERROR
+ GETYP A,2(AB) ;CHECK THAT WE HAVE A FRAME
+ CAIE A,TACT
+ CAIN A,TFRAME
+ JRST .+3
+ CAIE A,TENV
+ JRST TRYPRO ; COULD BE PROCESS
+ MOVEI B,2(AB) ; POINT TO FRAME
+AEVAL2: PUSHJ P,CHENV ; HACK ENVIRONMENT CHANGE
+AEVAL1: PUSH TP,(AB)
+ PUSH TP,1(AB)
+ MCALL 1,EVAL
+AEVAL3: HRRZ 0,FSAV(TB)
+ CAIN 0,EVAL
+ JRST EFINIS
+ JRST FINIS
+
+TRYPRO: CAIE A,TPVP ; SKIP IF IT IS A PROCESS
+ JRST WTYP2
+ MOVE C,3(AB) ; GET PROCESS
+ CAMN C,PVSTOR ; DIFFERENT FROM ME?
+ JRST SEVAL ; NO, NORMAL EVAL WINS
+ MOVE B,SPSTO+1(C) ; GET SP FOR PROCESS
+ MOVE D,TBSTO+1(C) ; GET TOP FRAME
+ HLL D,OTBSAV(D) ; TIME IT
+ MOVEI C,PVLNT*2+1(C) ; CONS UP POINTER TO PROC DOPE WORD
+ HRLI C,TFRAME ; LOOK LIK E A FRAME
+ PUSHJ P,SWITSP ; SPLICE ENVIRONMENT
+ JRST AEVAL1
+
+; ROUTINE TO CHANGE LOOK UP PATH FOR BINDINGS
+
+CHENV: PUSHJ P,CHFRM ; CHECK OUT FRAME
+ MOVE C,(B) ; POINT TO PROCESS
+ MOVE D,1(B) ; GET TB POINTER FROM FRAME
+ CAMN SP,SPSAV(D) ; CHANGE?
+ POPJ P, ; NO, JUST RET
+ MOVE B,SPSAV(D) ; GET SP OF INTEREST
+SWITSP: MOVSI 0,TSKIP ; SET UP SKIP
+ HRRI 0,1(TP) ; POINT TO UNBIND PATH
+ MOVE A,PVSTOR+1
+ ADD A,[BINDID,,BINDID] ; BIND THE BINDING ID
+ PUSH TP,BNDV
+ PUSH TP,A
+ PUSH TP,$TFIX
+ AOS A,PTIME ; NEW ID
+ PUSH TP,A
+ MOVE E,TP ; FOR SPECBIND
+ PUSH TP,0
+ PUSH TP,B
+ PUSH TP,C ; SAVE PROCESS
+ PUSH TP,D
+ PUSHJ P,SPECBE ; BIND BINDID
+ MOVE SP,TP ; GET NEW SP
+ SUB SP,[3,,3] ; SET UP SP FORK
+ MOVEM SP,SPSTOR+1
+ POPJ P,
+\f
+
+; HERE TO EVALUATE A FORM (99% OF EVAL'S WORK)
+
+EVFORM: SKIPN C,1(AB) ; EMPTY FORM, RETURN FALSE
+ JRST EFALSE
+ GETYP A,(C) ; 1ST ELEMENT OF FORM
+ CAIE A,TATOM ; ATOM?
+ JRST EV0 ; NO, EVALUATE IT
+ MOVE B,1(C) ; GET ATOM
+ PUSHJ P,IGVAL ; GET ITS GLOBAL VALUE
+
+; SPECIAL HACK TO SPEED UP LVAL AND GVAL CALLS
+
+ CAIE B,LVAL
+ CAIN B,GVAL
+ JRST ATMVAL ; FAST ATOM VALUE
+
+ GETYP 0,A
+ CAIE 0,TUNBOU ; BOUND?
+ JRST IAPPLY ; YES APPLY IT
+
+ MOVE C,1(AB) ; LOOK FOR LOCAL
+ MOVE B,1(C)
+ PUSHJ P,ILVAL
+ GETYP 0,A
+ CAIE 0,TUNBOU
+ JRST IAPPLY ; WIN, GO APPLY IT
+
+ PUSH TP,$TATOM
+ PUSH TP,EQUOTE UNBOUND-VARIABLE
+ PUSH TP,$TATOM
+ MOVE C,1(AB) ; FORM BACK
+ PUSH TP,1(C)
+ PUSH TP,$TATOM
+ PUSH TP,IMQUOTE VALUE
+ MCALL 3,ERROR ; REPORT THE ERROR
+ JRST IAPPLY
+
+EFALSE: MOVSI A,TFALSE ; SPECIAL FALSE FOR EVAL OF EMPTY FORM
+ MOVEI B,0
+ JRST EFINIS
+
+ATMVAL: HRRZ D,(C) ; CDR THE FORM
+ HRRZ 0,(D) ; AND AGAIN
+ JUMPN 0,IAPPLY
+ GETYP 0,(D) ; MAKE SURE APPLYING TO ATOM
+ CAIE 0,TATOM
+ JRST IAPPLY
+ MOVEI E,IGVAL ; ASSUME GLOBAAL
+ CAIE B,GVAL ; SKIP IF OK
+ MOVEI E,ILVAL ; ELSE USE LOCAL
+ PUSH P,B ; SAVE SUBR
+ MOVE B,(D)+1 ; CLR BUG #1637 (GET THE ATOM FOR THE SUBR)
+ PUSHJ P,(E) ; AND GET VALUE
+ CAME A,$TUNBOU
+ JRST EFINIS ; RETURN FROM EVAL
+ POP P,B
+ MOVSI A,TSUBR ; CAUSE REAL SUBR TO GET EROR
+ JRST IAPPLY
+\f
+; HERE FOR 1ST ELEMENT NOT A FORM
+
+EV0: PUSHJ P,FASTEV ; EVAL IT
+
+; HERE TO APPLY THINGS IN FORMS
+
+IAPPLY: PUSH TP,(AB) ; SAVE THE FORM
+ PUSH TP,1(AB)
+ PUSH TP,A
+ PUSH TP,B ; SAVE THE APPLIER
+ PUSH TP,$TFIX ; AND THE ARG GETTER
+ PUSH TP,[ARGCDR]
+ PUSHJ P,APLDIS ; GO TO INTERNAL APPLIER
+ JRST EFINIS ; LEAVE EVAL
+
+; HERE TO EVAL 1ST ELEMENT OF A FORM
+
+FASTEV: MOVE PVP,PVSTOR+1
+ SKIPE 1STEPR+1(PVP) ; BEING 1 STEPPED?
+ JRST EV02 ; YES, LET LOSER SEE THIS EVAL
+ GETYP A,(C) ; GET TYPE
+ SKIPE D,EVATYP+1 ; USER TABLE?
+ JRST EV01 ; YES, HACK IT
+EV03: CAIG A,NUMPRI ; SKIP IF SELF
+ SKIPA A,EVTYPE(A) ; GET DISPATCH
+ MOVEI A,SELF ; USE SLEF
+
+EV04: CAIE A,SELF ; IF EVAL'S TO SELF, JUST USE IT
+ JRST EV02
+ MOVSI A,TLIST
+ MOVE PVP,PVSTOR+1
+ MOVEM A,CSTO(PVP)
+ INTGO
+ SETZM CSTO(PVP)
+ HLLZ A,(C) ; GET IT
+ MOVE B,1(C)
+ JSP E,CHKAB ; CHECK DEFERS
+ POPJ P, ; AND RETURN
+
+EV01: ADDI D,(A) ; POINT TO SLOT OF USER EVAL TABLE
+ ADDI D,(A)
+ SKIPE (D) ; EITHER NOT GIVEN OR SIMPLE
+ JRST EV02
+ SKIPN 1(D) ; SKIP IF SIMPLE
+ JRST EV03 ; NOT GIVEN
+ MOVE A,1(D)
+ JRST EV04
+
+EV02: PUSH TP,(C)
+ HLLZS (TP) ; FIX UP LH
+ PUSH TP,1(C)
+ JSP E,CHKARG
+ MCALL 1,EVAL
+ POPJ P,
+
+\f
+; MAPF/MAPR CALL TO APPLY
+
+ IMQUOTE APPLY
+
+MAPPLY: JRST APPLY
+
+; APPLY, FALLS INTO EVAL'S APPLY CODE AT APLDIS
+
+IMFUNCTION APPLY,SUBR
+
+ ENTRY
+
+ JUMPGE AB,TFA ; MUST BE AT LEAST 1 ARGUMENT
+ MOVE A,AB
+ ADD A,[2,,2]
+ PUSH TP,$TAB
+ PUSH TP,A
+ PUSH TP,(AB) ; SAVE FCN
+ PUSH TP,1(AB)
+ PUSH TP,$TFIX ; AND ARG GETTER
+ PUSH TP,[SETZ APLARG]
+ PUSHJ P,APLDIS
+ JRST FINIS
+
+; STACKFROM, ALSO FALLS INTO EVAL'S APPLIER AT APLDIS
+
+IMFUNCTION STACKFORM,FSUBR
+
+ ENTRY 1
+
+ GETYP A,(AB)
+ CAIE A,TLIST
+ JRST WTYP1
+ MOVEI A,3 ; CHECK ALL GOODIES SUPPLIED
+ HRRZ B,1(AB)
+
+ JUMPE B,TFA
+ HRRZ B,(B) ; CDR IT
+ SOJG A,.-2
+
+ HRRZ C,1(AB) ; GET LIST BACK
+ PUSHJ P,FASTEV ; DO A FAST EVALUATION
+ PUSH TP,(AB)
+ HRRZ C,@1(AB) ; POINT TO ARG GETTING FORMS
+ PUSH TP,C
+ PUSH TP,A ; AND FCN
+ PUSH TP,B
+ PUSH TP,$TFIX
+ PUSH TP,[SETZ EVALRG]
+ PUSHJ P,APLDIS
+ JRST FINIS
+
+\f
+; OFFSETS FOR TEMPORARIES ETC. USED IN APPLYING STUFF
+
+E.FRM==0 ; POINTS TO FORM BEING EVALED (OR ARGS FOR APPLY STACKFORM)
+E.FCN==2 ; FUNCTION/SUBR/RSUBR BEING APPLIED
+E.ARG==4 ; POINTS TO ARG GETTING ROUTINE (<0 => MUST EVAL ARGS)
+E.EXTR==6 ; CONTAINS 1ST ARG IN USER APPLY CASE
+E.SEG==10 ; POINTS TO SEGMENT IN FORM BEING HACKED
+E.CNT==12 ; COUNTER FOR TUPLES OF ARGS
+E.DECL==14 ; POINTS TO DECLARATION LIST IN FUNCTIONS
+E.ARGL==16 ; POINTS TO ARG LIST IN FUNCTIONS
+E.HEW==20 ; POINTS TO HEWITT ATOM IF IT EXISTS
+
+E.VAL==E.ARGL ; VALUE TYPE FOR RSUBRS
+
+MINTM==E.EXTR+2 ; MIN # OF TEMPS EVER ALLOCATED
+E.TSUB==E.CNT+2 ; # OF TEMPS FOR SUBR/NUMBER APPLICATION
+XP.TMP==E.HEW-E.EXTR ; # EXTRA TEMPS FOR FUNCTION APPLICATION
+R.TMP==4 ; TEMPS AFTER ARGS ARE BOUND
+TM.OFF==E.HEW+2-R.TMP ; TEMPS TO FLUSH AFTER BIND OF ARGS
+
+RE.FCN==0 ; AFTER BINDING CONTAINS FCN BODY
+RE.ARG==2 ; ARG LIST AFTER BINDING
+
+; GENERAL THING APPLYER
+
+APLDIS: PUSH TP,[0] ; SLOT USED FOR USER APPLYERS
+ PUSH TP,[0]
+APLDIX: GETYP A,E.FCN(TB) ; GET TYPE
+
+APLDI: SKIPE D,APLTYP+1 ; USER TABLE EXISTS?
+ JRST APLDI1 ; YES, USE IT
+APLDI2: CAILE A,NUMPRI ; SKIP IF NOT PRIM
+ JRST NAPT
+ HRRO A,APTYPE(A)
+ JRST (A)
+
+APLDI1: ADDI D,(A) ; POINT TO SLOT
+ ADDI D,(A)
+ SKIPE (D) ; SKIP IF NOT GIVEN OR STANDARD
+ JRST APLDI3
+APLDI4: SKIPE D,1(D) ; GET DISP
+ JRST (D)
+ JRST APLDI2 ; USE SYSTEM DISPATCH
+
+APLDI3: SKIPE E.EXTR+1(TB) ; SKIP IF HAVEN'T BEEN HERE BEFORE
+ JRST APLDI4
+ MOVE A,(D) ; GET ITS HANDLER
+ EXCH A,E.FCN(TB) ; AND USE AS FCN
+ MOVEM A,E.EXTR(TB) ; SAVE
+ MOVE A,1(D)
+ EXCH A,E.FCN+1(TB)
+ MOVEM A,E.EXTR+1(TB) ; STASH OLD FCN AS EXTRG
+ GETYP A,(D) ; GET TYPE
+ JRST APLDI
+
+
+; APPLY DISPATCH TABLE
+
+DISTBL APTYPE,<SETZ NAPTL>,[[TSUBR,APSUBR],[TFSUBR,APFSUB],[TRSUBR,APRSUB],[TFIX,APNUM]
+[TEXPR,APEXPR],[TFUNAR,APFUNARG],[TENTER,APENTR],[TMACRO,APMACR],[TOFFS,APNUM]]\f
+
+; SUBR TO SAY IF TYPE IS APPLICABLE
+
+MFUNCTION APPLIC,SUBR,[APPLICABLE?]
+
+ ENTRY 1
+
+ GETYP A,(AB)
+ PUSHJ P,APLQ
+ JRST IFALSE
+ JRST TRUTH
+
+; HERE TO DETERMINE IF A TYPE IS APPLICABLE
+
+APLQ: PUSH P,B
+ SKIPN B,APLTYP+1
+ JRST USEPUR ; USE PURE TABLE
+ ADDI B,(A)
+ ADDI B,(A) ; POINT TO SLOT
+ SKIPG 1(B) ; SKIP IF WINNER
+ SKIPE (B) ; SKIP IF POTENIAL LOSER
+ JRST CPPJ1B ; WIN
+ SKIPE 1(B) ; SKIP IF MUST USE PURE TABBLE
+ JRST CPOPJB
+USEPUR: CAILE A,NUMPRI ; SKIP IF NOT PRIM
+ JRST CPOPJB
+ SKIPL APTYPE(A) ; SKIP IF APLLICABLE
+CPPJ1B: AOS -1(P)
+CPOPJB: POP P,B
+ POPJ P,
+\f
+; FSUBR APPLYER
+
+APFSUBR:
+ SKIPN E.EXTR(TB) ; IF EXTRA ARG
+ SKIPGE E.ARG+1(TB) ; OR APPLY/STACKFORM, LOSE
+ JRST BADFSB
+ MOVE A,E.FCN+1(TB) ; GET FCN
+ HRRZ C,@E.FRM+1(TB) ; GET ARG LIST
+ SUB TP,[MINTM,,MINTM] ; FLUSH UNWANTED TEMPS
+ PUSH TP,$TLIST
+ PUSH TP,C ; ARG TO STACK
+ .MCALL 1,(A) ; AND CALL
+ POPJ P, ; AND LEAVE
+
+; SUBR APPLYER
+
+APSUBR:
+ PUSHJ P,PSH4ZR ; SET UP ZEROED SLOTS
+ SKIPG E.ARG+1(TB)
+ AOS E.CNT(TB) ; INDICATES IF MUST EVAL ARGS
+ MOVSI A,400000 ; MAKE SURE OF GOOD INDIRECT
+ IORM A,E.ARG+1(TB)
+ SKIPN A,E.EXTR(TB) ; FUNNY ARGS
+ JRST APSUB1 ; NO, GO
+ MOVE B,E.EXTR+1(TB) ; YES , GET VAL
+ JRST APSUB2 ; AND FALL IN
+
+APSUB1: PUSHJ P,@E.ARG+1(TB) ; EAT AN ARG
+ JRST APSUBD ; DONE
+APSUB2: PUSH TP,A
+ PUSH TP,B
+ AOS E.CNT+1(TB) ; COUNT IT
+ JRST APSUB1
+
+APSUBD: MOVE A,E.CNT+1(TB) ; FINISHED, GET COUNT
+ MOVE B,E.FCN+1(TB) ; AND SUBR
+ GETYP 0,E.FCN(TB)
+ CAIN 0,TENTER
+ JRST APENDN
+ PUSHJ P,BLTDN ; FLUSH CRUFT
+ .ACALL A,(B)
+ POPJ P,
+
+BLTDN: MOVEI C,(TB) ; POINT TO DEST
+ HRLI C,E.TSUB(C) ; AND SOURCE
+ BLT C,-E.TSUB(TP) ;BL..............T
+ SUB TP,[E.TSUB,,E.TSUB]
+ POPJ P,
+
+APENDN: PUSHJ P,BLTDN
+APNDN1: .ECALL A,(B)
+ POPJ P,
+
+; FLAGS FOR RSUBR HACKER
+
+F.STR==1
+F.OPT==2
+F.QUO==4
+F.NFST==10
+
+; APPLY OBJECTS OF TYPE RSUBR
+
+APENTR:
+APRSUBR:
+ MOVE C,E.FCN+1(TB) ; GET THE RSUBR
+ CAML C,[-5,,] ; IS IT LONG ENOUGH FOR DECLS
+ JRST APSUBR ; NO TREAT AS A SUBR
+ GETYP 0,4(C) ; GET TYPE OF 3D ELEMENT
+ CAIE 0,TDECL ; DECLARATION?
+ JRST APSUBR ; NO, TREAT AS SUBR
+ PUSHJ P,PSH4ZR ; ALLOCATE SOME EXTRA ROOM
+ PUSH TP,$TDECL ; PUSH UP THE DECLS
+ PUSH TP,5(C)
+ PUSH TP,$TLOSE ; SAVE ROOM FOR VAL DECL
+ PUSH TP,[0]
+ SKIPG E.ARG+1(TB)
+ AOS E.CNT(TB) ; INDICATES IF MUST EVAL ARGS
+ MOVSI A,400000 ; MAKE SURE OF GOOD INDIRECT
+ IORM A,E.ARG+1(TB)
+
+ SKIPN E.EXTR(TB) ; "EXTRA" ARG?
+ JRST APRSU1 ; NO,
+ MOVE 0,[SETZ EXTRGT] ; CHANGE THE ACCESS FCN
+ EXCH 0,E.ARG+1(TB)
+ HRRM 0,E.ARG(TB) ; REMEMBER IT
+
+APRSU1: MOVEI 0,0 ; INIT FLAG REGISTER
+ PUSH P,0 ; SAVE
+
+APRSU2: HRRZ A,E.DECL+1(TB) ; GET DECL LIST
+ JUMPE A,APRSU3 ; DONE!
+ HRRZ B,(A) ; CDR IT
+ MOVEM B,E.DECL+1(TB)
+ PUSHJ P,NXTDCL ; IS NEXT THING A STRING?
+ JRST APRSU4 ; NO, BETTER BE A TYPE
+ CAMN B,[ASCII /VALUE/]
+ JRST RSBVAL ; SAVE VAL DECL
+ TRON 0,F.NFST ; IF NOT FIRST, LOSE
+ CAME B,[ASCII /CALL/] ; CALL DECL
+ JRST APRSU7
+ SKIPE E.CNT(TB) ; LEGAL?
+ JRST MPD
+ MOVE C,E.FRM(TB)
+ MOVE D,E.FRM+1(TB) ; GET FORM
+ JRST APRS10 ; HACK IT
+
+APRSU5: TROE 0,F.STR ; STRING STRING?
+ JRST MPD ; LOSER
+ CAMN B,[<ASCII /OPT/>]
+ JRST .+3
+ CAME B,[<ASCII /OPTIO/>+1] ; OPTIONA?
+ JRST APRSU8
+ TROE 0,F.OPT ; CHECK AND SET
+ JRST MPD ; OPTINAL OPTIONAL LOSES
+ JRST APRSU2 ; TO MAIN LOOP
+
+APRSU7: CAME B,[ASCII /QUOTE/]
+ JRST APRSU5
+ TRO 0,F.STR
+ TROE 0,F.QUO ; TURN ON AND CHECK QUOTE
+ JRST MPD ; QUOTE QUOTE LOSES
+ JRST APRSU2 ; GO TO END OF LOOP
+\f
+
+APRSU8: CAME B,[ASCII /ARGS/]
+ JRST APRSU9
+ SKIPE E.CNT(TB) ; SKIP IF LEGAL
+ JRST MPD
+ HRRZ D,@E.FRM+1(TB) ; GET ARG LIST
+ MOVSI C,TLIST
+
+APRS10: HRRZ A,(A) ; GET THE DECL
+ MOVEM A,E.DECL+1(TB) ; CLOBBER
+ HRRZ B,(A) ; CHECK FOR TOO MUCH
+ JUMPN B,MPD
+ MOVE B,1(A) ; GET DECL
+ HLLZ A,(A) ; GOT THE DECL
+ MOVEM 0,(P) ; SAVE FLAGS
+ JSP E,CHKAB ; CHECK DEFER
+ PUSH TP,C
+ PUSH TP,D ; SAVE
+ PUSHJ P,TMATCH
+ JRST WTYP
+ AOS E.CNT+1(TB) ; COUNT ARG
+ JRST APRDON ; GO CALL RSUBR
+
+RSBVAL: HRRZ A,E.DECL+1(TB) ; GET DECL
+ JUMPE A,MPD
+ HRRZ B,(A) ; POINT TO DECL
+ MOVEM B,E.DECL+1(TB) ; SAVE NEW DECL POINTER
+ PUSHJ P,NXTDCL
+ JRST .+2
+ JRST MPD
+ MOVEM A,E.VAL+1(TB) ; SAVE VAL DECL
+ MOVSI A,TDCLI
+ MOVEM A,E.VAL(TB) ; SET ITS TYPE
+ JRST APRSU2
+\f
+
+APRSU9: CAME B,[ASCII /TUPLE/]
+ JRST MPD
+ MOVEM 0,(P) ; SAVE FLAGS
+ HRRZ A,(A) ; CDR DECLS
+ MOVEM A,E.DECL+1(TB)
+ HRRZ B,(A)
+ JUMPN B,MPD ; LOSER
+ PUSH P,[0] ; COUNT ELEMENTS IN TUPLE
+
+APRTUP: PUSHJ P,@E.ARG+1(TB) ; GOBBLE ARGS
+ JRST APRTPD ; DONE
+ PUSH TP,A
+ PUSH TP,B
+ AOS (P) ; COUNT IT
+ JRST APRTUP ; AND GO
+
+APRTPD: POP P,C ; GET COUNT
+ ADDM C,E.CNT+1(TB) ; UPDATE MAIN COUNT
+ ASH C,1 ; # OF WORDS
+ HRLI C,TINFO ; BUILD FENCE POST
+ PUSH TP,C
+ PUSHJ P,TBTOTP ; GEN REL OFFSET TO TOP
+ PUSH TP,D
+ HRROI D,-1(TP) ; POINT TO TOP
+ SUBI D,(C) ; TO BASE
+ TLC D,-1(C)
+ MOVSI C,TARGS ; BUILD TYPE WORD
+ HLR C,OTBSAV(TB)
+ MOVE A,E.DECL+1(TB)
+ MOVE B,1(A)
+ HLLZ A,(A) ; TYPE/VAL
+ JSP E,CHKAB ; CHECK
+ PUSHJ P,TMATCH ; GOTO TYPE CHECKER
+ JRST WTYP
+
+ SUB TP,[2,,2] ; REMOVE FENCE POST
+
+APRDON: SUB P,[1,,1] ; FLUSH CRUFT
+ MOVE A,E.CNT+1(TB) ; GET # OF ARGS
+ MOVE B,E.FCN+1(TB)
+ GETYP 0,E.FCN(TB) ; COULD BE ENTRY
+ MOVEI C,(TB) ; PREPARE TO BLT DOWN
+ HRLI C,E.TSUB+2(C)
+ BLT C,-E.TSUB+2(TP)
+ SUB TP,[E.TSUB+2,,E.TSUB+2]
+ CAIE 0,TRSUBR
+ JRST APNDNX
+ .ACALL A,(B) ; CALL THE RSUBR
+ JRST PFINIS
+
+APNDNX: .ECALL A,(B)
+ JRST PFINIS
+
+\f
+
+
+APRSU4: MOVEM 0,(P) ; SAVE FLAGS
+ MOVE B,1(A) ; GET DECL
+ HLLZ A,(A)
+ JSP E,CHKAB
+ MOVE 0,(P) ; RESTORE FLAGS
+ PUSH TP,A
+ PUSH TP,B ; AND SAVE
+ SKIPE E.CNT(TB) ; ALREADY EVAL'D
+ JRST APREV0
+ TRZN 0,F.QUO
+ JRST APREVA ; MUST EVAL ARG
+ MOVEM 0,(P)
+ HRRZ C,@E.FRM+1(TB) ; GET ARG?
+ TRNE 0,F.OPT ; OPTIONAL
+ JUMPE C,APRDN
+ JUMPE C,TFA ; NO, TOO FEW ARGS
+ MOVEM C,E.FRM+1(TB)
+ HLLZ A,(C) ; GET ARG
+ MOVE B,1(C)
+ JSP E,CHKAB ; CHECK THEM
+
+APRTYC: MOVE C,A ; SET UP FOR TMATCH
+ MOVE D,B
+ EXCH B,(TP)
+ EXCH A,-1(TP) ; SAVE STUFF
+APRS11: PUSHJ P,TMATCH ; CHECK TYPE
+ JRST WTYP
+
+ MOVE 0,(P) ; RESTORE FLAGS
+ TRZ 0,F.STR
+ AOS E.CNT+1(TB)
+ JRST APRSU2 ; AND GO ON
+
+APREV0: TRNE 0,F.QUO ; ATTEMPT TO QUOTE ALREADY EVAL'D ARG ?
+ JRST MPD ; YES, LOSE
+APREVA: PUSHJ P,@E.ARG+1(TB) ; EVAL ONE
+ TDZA C,C ; C=0 ==> NONE LEFT
+ MOVEI C,1
+ MOVE 0,(P) ; FLAGS
+ JUMPN C,APRTYC ; GO CHECK TYPE
+APRDN: SUB TP,[2,,2] ; FLUSH DECL
+ TRNE 0,F.OPT ; OPTIONAL?
+ JRST APRDON ; ALL DONE
+ JRST TFA
+
+APRSU3: TRNE 0,F.STR ; END IN STRING?\b
+ JRST MPD
+ PUSHJ P,@E.ARG+1(TB) ; SEE IF ANYMORE ARGS
+ JRST APRDON
+ JRST TMA
+
+\f
+; STANDARD ARGUMENT GETTERS USED IN APPLYING THINGS
+
+ARGCDR: HRRZ C,@E.FRM+1(TB) ; POINT TO ARGLIST (NOTE: POINTS 1 BEFORE WHERE ARG IS)
+ JUMPE C,CPOPJ ; LEAVE IF DONE
+ MOVEM C,E.FRM+1(TB)
+ GETYP 0,(C) ; GET TYPE OF ARG
+ CAIN 0,TSEG
+ JRST ARGCD1 ; SEG MENT HACK
+ PUSHJ P,FASTEV
+ JRST CPOPJ1
+
+ARGCD1: PUSH TP,$TFORM ; PRETEND WE ARE A FORM
+ PUSH TP,1(C)
+ MCALL 1,EVAL
+ MOVEM A,E.SEG(TB)
+ MOVEM B,E.SEG+1(TB)
+ PUSHJ P,TYPSEG ; GET SEG TYPE CODE
+ HRRM C,E.ARG(TB) ; SAVE IT IN OBSCCURE PLACE
+ MOVE C,DSTORE ; FIX FOR TEMPLATE
+ MOVEM C,E.SEG(TB)
+ MOVE C,[SETZ SGARG]
+ MOVEM C,E.ARG+1(TB) ; SET NEW ARG GETTER
+
+; FALL INTO SEGARG
+
+SGARG: INTGO
+ HRRZ C,E.ARG(TB) ; SEG CODE TO C
+ MOVE D,E.SEG+1(TB)
+ MOVE A,E.SEG(TB)
+ MOVEM A,DSTORE
+ PUSHJ P,NXTLM ; GET NEXT ELEMENT
+ JRST SEGRG1 ; DONE
+ MOVEM D,E.SEG+1(TB)
+ MOVE D,DSTORE ; KEEP TYPE WINNING
+ MOVEM D,E.SEG(TB)
+ SETZM DSTORE
+ JRST CPOPJ1 ; RETURN
+
+SEGRG1: SETZM DSTORE
+ MOVEI C,ARGCDR
+ HRRM C,E.ARG+1(TB) ; RESET ARG GETTER
+ JRST ARGCDR
+
+; ARGUMENT GETTER FOR APPLY
+
+APLARG: INTGO
+ SKIPL A,E.FRM+1(TB) ; ANY ARGS LEFT
+ POPJ P, ; NO, EXIT IMMEDIATELY
+ ADD A,[2,,2]
+ MOVEM A,E.FRM+1(TB)
+ MOVE B,-1(A) ; RET NEXT ARG
+ MOVE A,-2(A)
+ JRST CPOPJ1
+
+; STACKFORM ARG GETTER
+
+EVALRG: SKIPN C,@E.FRM+1(TB) ; ANY FORM?
+ POPJ P,
+ PUSHJ P,FASTEV
+ GETYP A,A ; CHECK FOR FALSE
+ CAIN A,TFALSE
+ POPJ P,
+ MOVE C,E.FRM+1(TB) ; GET OTHER FORM
+ PUSHJ P,FASTEV
+ JRST CPOPJ1
+
+\f
+; HERE TO APPLY NUMBERS
+
+APNUM: PUSHJ P,PSH4ZR ; TP SLOTS
+ SKIPN A,E.EXTR(TB) ; FUNNY ARG?
+ JRST APNUM1 ; NOPE
+ MOVE B,E.EXTR+1(TB) ; GET ARG
+ JRST APNUM2
+
+APNUM1: PUSHJ P,@E.ARG+1(TB) ; GET ARG
+ JRST TFA
+APNUM2: PUSH TP,A
+ PUSH TP,B
+ PUSH TP,E.FCN(TB)
+ PUSH TP,E.FCN+1(TB)
+ PUSHJ P,@E.ARG+1(TB)
+ JRST .+2
+ JRST APNUM3
+ PUSHJ P,BLTDN ; FLUSH JUNK
+ MCALL 2,NTH
+ POPJ P,
+; HACK FOR TURNING <3 .FOO .BAR> INTO <PUT .FOO 3 .BAR>
+APNUM3: PUSH TP,A
+ PUSH TP,B
+ PUSHJ P,@E.ARG+1(TB)
+ JRST .+2
+ JRST TMA
+ PUSHJ P,BLTDN
+ GETYP A,-5(TP)
+ PUSHJ P,ISTRUC ; STRUCTURED FIRST ARG?
+ JRST WTYP1
+ MCALL 3,PUT
+ POPJ P,
+\f
+; HERE TO APPLY SUSSMAN FUNARGS
+
+APFUNARG:
+
+ SKIPN C,E.FCN+1(TB)
+ JRST FUNERR
+ HRRZ D,(C) ; MUST BE AT LEAST 2 LONG
+ JUMPE D,FUNERR
+ GETYP 0,(D) ; CHECK FOR LIST
+ CAIE 0,TLIST
+ JRST FUNERR
+ HRRZ 0,(D) ; SHOULD BE END
+ JUMPN 0,FUNERR
+ GETYP 0,(C) ; 1ST MUST BE FCN
+ CAIE 0,TEXPR
+ JRST FUNERR
+ SKIPN C,1(C)
+ JRST NOBODY
+ PUSHJ P,APEXPF ; BIND THE ARGS AND AUX'S
+ HRRZ C,RE.FCN+1(TB) ; GET BODY OF FUNARG
+ MOVE B,1(C) ; GET FCN
+ MOVEM B,RE.FCN+1(TB) ; AND SAVE
+ HRRZ C,(C) ; CDR FUNARG BODY
+ MOVE C,1(C)
+ MOVSI 0,TLIST ; SET UP TYPE
+ MOVE PVP,PVSTOR+1
+ MOVEM 0,CSTO(PVP) ; FOR INTS TO WIN
+
+FUNLP: INTGO
+ JUMPE C,DOF ; RUN IT
+ GETYP 0,(C)
+ CAIE 0,TLIST ; BETTER BE LIST
+ JRST FUNERR
+ PUSH TP,$TLIST
+ PUSH TP,C
+ PUSHJ P,NEXTDC ; GET POSSIBILITY
+ JRST FUNERR ; LOSER
+ CAIE A,2
+ JRST FUNERR
+ HRRZ B,(B) ; GET TO VALUE
+ MOVE C,(TP)
+ SUB TP,[2,,2]
+ PUSH TP,BNDA
+ PUSH TP,E
+ HLLZ A,(B) ; GET VAL
+ MOVE B,1(B)
+ JSP E,CHKAB ; HACK DEFER
+ PUSHJ P,PSHAB4 ; PUT VAL IN
+ HRRZ C,(C) ; CDR
+ JUMPN C,FUNLP
+
+; HERE TO RUN FUNARG
+
+DOF: MOVE PVP,PVSTOR+1
+ SETZM CSTO(PVP) ; DONT CONFUSE GC
+ PUSHJ P,SPECBIND ; BIND 'EM UP
+ JRST RUNFUN
+
+
+\f
+; HERE TO DO MACROS
+
+APMACR: HRRZ E,OTBSAV(TB)
+ HRRZ D,PCSAV(E) ; SEE WHERE FROM
+ CAIE D,EFCALL+1 ; 1STEP
+ JRST .+3
+ HRRZ E,OTBSAV(E)
+ HRRZ D,PCSAV(E)
+ CAIN D,AEVAL3 ; SKIP IF NOT RIGHT
+ JRST APMAC1
+ SKIPG E.ARG+1(TB) ; SKIP IF REAL FORM EXISTS
+ JRST BADMAC
+ MOVE A,E.FRM(TB)
+ MOVE B,E.FRM+1(TB)
+ SUB TP,[E.EXTR+2,,E.EXTR+2] ; FLUSH JUNK
+ PUSH TP,A
+ PUSH TP,B
+ MCALL 1,EXPAND ; EXPAND THE MACRO
+ PUSH TP,A
+ PUSH TP,B
+ MCALL 1,EVAL ; EVAL THE RESULT
+ POPJ P,
+
+APMAC1: MOVE C,E.FCN+1(TB) ; GET MACRO BODY
+ GETYP A,(C)
+ MOVE B,1(C)
+ MOVSI A,(A)
+ JSP E,CHKAB ; FIX DEFERS
+ MOVEM A,E.FCN(TB)
+ MOVEM B,E.FCN+1(TB)
+ JRST APLDIX
+
+; HERE TO APPLY EXPRS (FUNCTIONS)
+
+APEXPR: PUSHJ P,APEXP ; BIND ARGS AND AUX'S
+RUNFUN: HRRZ A,RE.FCN(TB) ; AMOUNT OF FCN TO SKIP
+ MOVEI C,RE.FCN+1(TB) ; POINT TO FCN
+ HRRZ C,(C) ; SKIP SOMETHING
+ SOJGE A,.-1 ; UNTIL 1ST FORM
+ MOVEM C,RE.FCN+1(TB) ; AND STORE
+ JRST DOPROG ; GO RUN PROGRAM
+
+APEXP: SKIPN C,E.FCN+1(TB) ; CHECK FRO BODY
+ JRST NOBODY
+APEXPF: PUSH P,[0] ; COUNT INIT CRAP
+ ADD TP,[XP.TMP,,XP.TMP] ; SLOTS FOR HACKING
+ SKIPL TP
+ PUSHJ P,TPOVFL
+ SETZM 1-XP.TMP(TP) ; ZERO OUT
+ MOVEI A,-XP.TMP+2(TP)
+ HRLI A,-1(A)
+ BLT A,(TP) ; ZERO SLOTS
+ SKIPG E.ARG+1(TB)
+ AOS E.CNT(TB) ; INDICATES IF MUST EVAL ARGS
+ MOVSI A,400000 ; MAKE E.ARG BE NEG FOR SAFE @ING
+ IORM A,E.ARG+1(TB)
+ PUSHJ P,CARATC ; SEE IF HEWITT ATOM EXISTS
+ JRST APEXP1 ; NO, GO LOOK FOR ARGLIST
+ MOVEM E,E.HEW+1(TB) ; SAVE ATOM
+ MOVSM 0,E.HEW(TB) ; AND TYPE
+ AOS (P) ; COUNT HEWITT ATOM
+APEXP1: GETYP 0,(C) ; LOOK AT NEXT THING
+ CAIE 0,TLIST ; BETTER BE LIST!!!
+ JRST MPD.0 ; LOSE
+ MOVE B,1(C) ; GET LIST
+ MOVEM B,E.ARGL+1(TB) ; SAVE
+ MOVSM 0,E.ARGL(TB) ; WITH TYPE
+ HRRZ C,(C) ; CDR THE FCN
+ JUMPE C,NOBODY ; BODYLESS FCN
+ GETYP 0,(C) ; SEE IF DCL LIST SUPPLIED
+ CAIE 0,TDECL
+ JRST APEXP2 ; NO, START PROCESSING ARGS
+ AOS (P) ; COUNT DCL
+ MOVE B,1(C)
+ MOVEM B,E.DECL+1(TB)
+ MOVSM 0,E.DECL(TB)
+ HRRZ C,(C) ; CDR ON
+ JUMPE C,NOBODY
+
+ ; CHECK FOR EXISTANCE OF EXTRA ARG
+
+APEXP2: POP P,A ; GET COUNT
+ HRRM A,E.FCN(TB) ; AND SAVE
+ SKIPN E.EXTR(TB) ; SKIP IF FUNNY EXTRA ARG EXISTS
+ JRST APEXP3
+ MOVE 0,[SETZ EXTRGT]
+ EXCH 0,E.ARG+1(TB)
+ HRRM 0,E.ARG(TB) ; SAVE OLD GETTER AROUND
+ AOS E.CNT(TB)
+
+; FALL THROUGH
+ \f
+; LOOK FOR "BIND" DECLARATION
+
+APEXP3: PUSHJ P,UNPROG ; UNASSIGN LPROG IF NEC
+APXP3A: SKIPN A,E.ARGL+1(TB) ; GET ARGLIST
+ JRST APEXP4 ; NONE, VERIFY NONE WERE GIVEN
+ PUSHJ P,NXTDCL ; SEE IF A DECL IS THERE
+ JRST BNDRG ; NO, GO BIND NORMAL ARGS
+ HRRZ C,(A) ; CDR THE DCLS
+ CAME B,[ASCII /BIND/]
+ JRST CH.CAL ; GO LOOK FOR "CALL"
+ PUSHJ P,CARTMC ; MUST BE AN ATOM
+ MOVEM C,E.ARGL+1(TB) ; AND SAVE CDR'D ARGS
+ PUSHJ P,MAKENV ; GENERATE AN ENVIRONMENT
+ PUSHJ P,PSBND1 ; PUSH THE BINDING AND CHECK THE DCL
+ JRST APXP3A ; IN CASE <"BIND" B "BIND" C......
+
+
+; LOOK FOR "CALL" DCL
+
+CH.CAL: CAME B,[ASCII /CALL/]
+ JRST CHOPT ; TRY SOMETHING ELSE
+; SKIPG E.ARG+1(TB) ; DONT SKIP IF CANT WIN
+ SKIPE E.CNT(TB)
+ JRST MPD.2
+ PUSHJ P,CARTMC ; BETTER BE AN ATOM
+ MOVEM C,E.ARGL+1(TB)
+ MOVE A,E.FRM(TB) ; RETURN FORM
+ MOVE B,E.FRM+1(TB)
+ PUSHJ P,PSBND1 ; BIND AND CHECK
+ JRST APEXP5
+ \f
+; BIND NORMAL ARGS BY CALLING BNDEM1, RETURNS WHEN ALL DONE
+
+BNDRG: PUSHJ P,BNDEM1 ; GO BIND THEM UP
+ TRNN A,4 ; SKIP IF HIT A DCL
+ JRST APEXP4 ; NOT A DCL, MUST BE DONE
+
+; LOOK FOR "OPTIONAL" DECLARATION
+
+CHOPT: CAMN B,[<ASCII /OPT/>]
+ JRST .+3
+ CAME B,[<ASCII /OPTIO/>+1]
+ JRST CHREST ; TRY TUPLE/ARGS
+ MOVEM C,E.ARGL+1(TB) ; SAVE RESTED ARGLIST
+ PUSHJ P,BNDEM2 ; DO ALL SUPPLIED OPTIONALS
+ TRNN A,4 ; SKIP IF NEW DCL READ
+ JRST APEXP4
+
+; CHECK FOR "ARGS" DCL
+
+CHREST: CAME B,[ASCII /ARGS/]
+ JRST CHRST1 ; GO LOOK FOR "TUPLE"
+; SKIPGE E.ARG+1(TB) ; SKIP IF LEGAL
+ SKIPE E.CNT(TB)
+ JRST MPD.3
+ PUSHJ P,CARTMC ; GOBBLE ATOM
+ MOVEM C,E.ARGL+1(TB) ; SAVE CDR'D ARG
+ HRRZ B,@E.FRM+1(TB) ; GET ARG LIST
+ MOVSI A,TLIST ; GET TYPE
+ PUSHJ P,PSBND1
+ JRST APEXP5
+
+; HERE TO CHECK FOR "TUPLE"
+
+CHRST1: CAME B,[ASCII /TUPLE/]
+ JRST APXP10
+ PUSHJ P,CARTMC ; GOBBLE ATOM
+ MOVEM C,E.ARGL+1(TB)
+ SETZB A,B
+ PUSHJ P,PSHBND ; SET UP BINDING
+ SETZM E.CNT+1(TB) ; ZERO ARG COUNTER
+
+TUPLP: PUSHJ P,@E.ARG+1(TB) ; GET AN ARG
+ JRST TUPDON ; FINIS
+ AOS E.CNT+1(TB)
+ PUSH TP,A
+ PUSH TP,B
+ JRST TUPLP
+
+TUPDON: PUSHJ P,MAKINF ; MAKE INFO CELL
+ PUSH TP,$TINFO ; FENCE POST TUPLE
+ PUSHJ P,TBTOTP
+ ADDI D,TM.OFF ; COMPENSATE FOR MOVEMENT
+ PUSH TP,D
+ MOVE C,E.CNT+1(TB) ; GET COUNT
+ ASH C,1 ; TO WORDS
+ HRRM C,-1(TP) ; INTO FENCE POST
+ MOVEI B,-TM.OFF-1(TP) ; SETUP ARG POINTER
+ SUBI B,(C) ; POINT TO BASE OF TUPLE
+ MOVNS C ; FOR AOBJN POINTER
+ HRLI B,(C) ; GOOD ARGS POINTER
+ MOVEM A,TM.OFF-4(B) ; STORE
+ MOVEM B,TM.OFF-3(B)
+
+\f
+; CHECK FOR VALID ENDING TO ARGS
+
+APEXP5: PUSHJ P,NEXTD ; READ NEXT THING IN ARGLIST
+ JRST APEXP8 ; DONE
+ TRNN A,4 ; SKIP IF DCL
+ JRST MPD.4 ; LOSER
+APEXP7: MOVSI A,-NWINS ; CHECK FOR A WINNER
+ CAME B,WINRS(A)
+ AOBJN A,.-1
+ JUMPGE A,MPD.6 ; NOT A WINNER
+
+; HERE TO BLT THE WORLD DOWN ON TOP OF ALL THE USELESS TEMPS
+
+APEXP8: MOVE 0,E.HEW+1(TB) ; GET HEWITT ATOM
+ MOVE E,E.FCN(TB) ; SAVE COUNTER
+ MOVE C,E.FCN+1(TB) ; FCN
+ MOVE B,E.ARGL+1(TB) ; ARG LIST
+ MOVE D,E.DECL+1(TB) ; AND DCLS
+ MOVEI A,R.TMP(TB) ; SET UP BLT
+ HRLI A,TM.OFF(A)
+ BLT A,-TM.OFF(TP) ; BLLLLLLLLLLLLLT
+ SUB TP,[TM.OFF,,TM.OFF] ; FLUSH CRUFT
+ MOVEM E,RE.FCN(TB)
+ MOVEM C,RE.FCN+1(TB)
+ MOVEM B,RE.ARGL+1(TB)
+ MOVE E,TP
+ PUSH TP,$TATOM
+ PUSH TP,0
+ PUSH TP,$TDECL
+ PUSH TP,D
+ GETYP A,-5(TP) ; TUPLE ON TOP?
+ CAIE A,TINFO ; SKIP IF YES
+ JRST APEXP9
+ HRRZ A,-5(TP) ; GET SIZE
+ ADDI A,2
+ HRLI A,(A)
+ SUB E,A ; POINT TO BINDINGS
+ SKIPE C,(TP) ; IF DCL
+ PUSHJ P,CHKDCL ; CHECK TYPE SPEC ON TUPLE
+APEXP9: PUSHJ P,USPCBE ; DO ACTUAL BINDING
+
+ MOVE E,-2(TP) ; RESTORE HEWITT ATOM
+ MOVE D,(TP) ; AND DCLS
+ SUB TP,[4,,4]
+
+ JRST AUXBND ; GO BIND AUX'S
+
+; HERE TO VERIFY CHECK IF ANY ARGS LEFT
+
+APEXP4: PUSHJ P,@E.ARG+1(TB)
+ JRST APEXP8 ; WIN
+ JRST TMA ; TOO MANY ARGS
+
+APXP10: PUSH P,B
+ PUSHJ P,@E.ARG+1(TB)
+ JRST .+2
+ JRST TMA
+ POP P,B
+ JRST APEXP7
+
+; LIST OF POSSIBLE TERMINATING NAMES
+
+WINRS:
+AS.ACT: ASCII /ACT/
+AS.NAM: ASCII /NAME/
+AS.AUX: ASCII /AUX/
+AS.EXT: ASCII /EXTRA/
+NWINS==.-WINRS
+
+ \f
+; HERE TO BIND AUX VARIABLES FOR PROGS AND FCNS
+
+AUXBND: PUSH P,E ; SAVE HEWITT ATOM ( WILL PUT ON MARKED STACK
+ ; WHEN NECESSARY)
+ PUSH P,D ; SAME WITH DCL LIST
+ PUSH P,[-1] ; FLAG SAYING WE ARE FCN
+ SKIPN C,RE.ARG+1(TB) ; GET ARG LIST
+ JRST AUXDON
+ GETYP 0,(C) ; GET TYPE
+ CAIE 0,TDEFER ; SKIP IF CHSTR
+ MOVMS (P) ; SAY WE ARE IN OPTIONALS
+ JRST AUXB1
+
+PRGBND: PUSH P,E
+ PUSH P,D
+ PUSH P,[0] ; WE ARE IN AUXS
+
+AUXB1: HRRZ C,RE.ARG+1(TB) ; POINT TO ARGLIST
+ PUSHJ P,NEXTDC ; GET NEXT THING OFF OF ARG LIST
+ JRST AUXDON
+ TRNE A,4 ; SKIP IF SOME KIND OF ATOM
+ JRST TRYDCL ; COUDL BE DCL
+ TRNN A,1 ; SKIP IF QUOTED
+ JRST AUXB2
+ SKIPN (P) ; SKIP IF QUOTED OK
+ JRST MPD.11
+AUXB2: PUSHJ P,PSHBND ; SET UP BINDING
+ PUSH TP,$TATOM ; SAVE HEWITT ATOM
+ PUSH TP,-1(P)
+ PUSH TP,$TDECL ; AND DECLS
+ PUSH TP,-2(P)
+ TRNN A,2 ; SKIP IF INIT VAL EXISTS
+ JRST AUXB3 ; NO, USE UNBOUND
+
+; EVALUATE EXPRESSION
+
+ HRRZ C,(B) ; CDR ATOM OFF
+
+; CHECK FOR SPECIAL FORMS <TUPLE ...> <ITUPLE ...>
+
+ GETYP 0,(C) ; GET TYPE OF GOODIE
+ CAIE 0,TFORM ; SMELLS LIKE A FORM
+ JRST AUXB13
+ HRRZ D,1(C) ; GET 1ST ELEMENT
+ GETYP 0,(D) ; AND ITS VAL
+ CAIE 0,TATOM ; FEELS LIKE THE RIGHT FORM
+ JRST AUXB13
+
+ MOVE 0,1(D) ; GET THE ATOM
+ CAME 0,IMQUOTE TUPLE
+ CAMN 0,MQUOTE ITUPLE
+ JRST DOTUPL ; SURE GLAD I DIDN'T STEP IN THAT FORM
+
+
+AUXB13: PUSHJ P,FASTEV
+AUXB14: MOVE E,TP
+AUXB4: MOVEM A,-7(E) ; STORE VAL IN BINDING
+ MOVEM B,-6(E)
+
+; HERE TO CHECK AGAINST DECLARATIONS AND COMPLETE THE BINDING
+
+AUXB5: SUB E,[4,,4] ; POINT TO BINDING TOP
+ SKIPE C,-2(TP) ; POINT TO DECLARATINS
+ PUSHJ P,CHKDCL ; CHECK IT
+ PUSHJ P,USPCBE ; AND BIND UP
+ SKIPE C,RE.ARG+1(TB) ; CDR DCLS
+ HRRZ C,(C) ; IF ANY TO CDR
+ MOVEM C,RE.ARG+1(TB)
+ MOVE A,(TP) ; NOW PUT HEWITT ATOM AND DCL AWAY
+ MOVEM A,-2(P)
+ MOVE A,-2(TP)
+ MOVEM A,-1(P)
+ SUB TP,[4,,4] ; FLUSH SLOTS
+ JRST AUXB1
+
+
+AUXB3: MOVNI B,1
+ MOVSI A,TUNBOU
+ JRST AUXB14
+
+\f
+
+; HERE TO HANDLE "CALLS" TO TUPLE AND ITUPLE
+
+DOTUPL: SKIPE E,(P) ; SKIP IF IN AUX LIST
+ JRST TUPLE
+ PUSH TP,$TLIST ; SAVE THE MAGIC FORM
+ PUSH TP,D
+ CAME 0,IMQUOTE TUPLE
+ JRST DOITUP ; DO AN ITUPLE
+
+; FALL INTO A TUPLE PUSHING LOOP
+
+DOTUP1: HRRZ C,@(TP) ; CDR THE FORM
+ JUMPE C,ATUPDN ; FINISHED
+ MOVEM C,(TP) ; SAVE CDR'D RESULT
+ GETYP 0,(C) ; CHECK FOR SEGMENT
+ CAIN 0,TSEG
+ JRST DTPSEG ; GO PULL IT APART
+ PUSHJ P,FASTEV ; EVAL IT
+ PUSHJ P,CNTARG ; PUSH IT UP AND COUNT THEM
+ JRST DOTUP1
+
+; HERE WHEN WE FINISH
+
+ATUPDN: SUB TP,[2,,2] ; FLUSH THE LIST
+ ASH E,1 ; E HAS # OF ARGS DOUBLE IT
+ MOVEI D,(TP) ; FIND BASE OF STACK AREA
+ SUBI D,(E)
+ MOVSI C,-3(D) ; PREPARE BLT POINTER
+ BLT C,C ; HEWITT ATOM AND DECL TO 0,A,B,C
+
+; NOW PREPEARE TO BLT TUPLE DOWN
+
+ MOVEI D,-3(D) ; NEW DEST
+ HRLI D,4(D) ; SOURCE
+ BLT D,-4(TP) ; SLURP THEM DOWN
+
+ HRLI E,TINFO ; SET UP FENCE POST
+ MOVEM E,-3(TP) ; AND STORE
+ PUSHJ P,TBTOTP ; GET OFFSET
+ ADDI D,3 ; FUDGE FOR NOT AT TOP OF STACK
+ MOVEM D,-2(TP)
+ MOVEM 0,-1(TP) ; RESTORE HEW ATOM AND DECLS
+ MOVEM A,(TP)
+ PUSH TP,B
+ PUSH TP,C
+
+ PUSHJ P,MAKINF ; MAKE 1ST WORD OF FUNNYS
+
+ HRRZ E,-5(TP) ; RESTORE WORDS OF TUPLE
+ HRROI B,-5(TP) ; POINT TO TOP OF TUPLE
+ SUBI B,(E) ; NOW BASE
+ TLC B,-1(E) ; FIX UP AOBJN PNTR
+ ADDI E,2 ; COPNESATE FOR FENCE PST
+ HRLI E,(E)
+ SUBM TP,E ; E POINT TO BINDING
+ JRST AUXB4 ; GO CLOBBER IT IN
+\f
+
+; HERE TO HANDLE SEGMENTS IN THESE FUNNY FORMS
+
+DTPSEG: PUSH TP,$TFORM ; SAVE THE HACKER
+ PUSH TP,1(C)
+ MCALL 1,EVAL ; AND EVALUATE IT
+ MOVE D,B ; GET READY FOR A SEG LOOP
+ MOVEM A,DSTORE
+ PUSHJ P,TYPSEG ; TYPE AND CHECK IT
+
+DTPSG1: INTGO ; DONT BLOW YOUR STACK
+ PUSHJ P,NXTLM ; ELEMENT TO A AND B
+ JRST DTPSG2 ; DONE
+ PUSHJ P,CNTARG ; PUSH AND COUNT
+ JRST DTPSG1
+
+DTPSG2: SETZM DSTORE
+ HRRZ E,-1(TP) ; GET COUNT IN CASE END
+ JRST DOTUP1 ; REST OF ARGS STILL TO DO
+
+; HERE TO HACK <ITUPLE .....>
+
+DOITUP: HRRZ C,@(TP) ; GET COUNT FILED
+ JUMPE C,TFA
+ MOVEM C,(TP)
+ PUSHJ P,FASTEV ; EVAL IT
+ GETYP 0,A
+ CAIE 0,TFIX
+ JRST WTY1TP
+
+ JUMPL B,BADNUM
+
+ HRRZ C,@(TP) ; GET EXP TO EVAL
+ MOVEI 0,0 ; DONT LOSE IN 1 ARG CASE
+ HRRZ 0,(C) ; VERIFY WINNAGE
+ JUMPN 0,TMA ; TOO MANY
+
+ JUMPE B,DOIDON
+ PUSH P,B ; SAVE COUNT
+ PUSH P,B
+ JUMPE C,DOILOS
+ PUSHJ P,FASTEV ; EVAL IT ONCE
+ MOVEM A,-1(TP)
+ MOVEM B,(TP)
+
+DOILP: INTGO
+ PUSH TP,-1(TP)
+ PUSH TP,-1(TP)
+ MCALL 1,EVAL
+ PUSHJ P,CNTRG
+ SOSLE (P)
+ JRST DOILP
+
+DOIDO1: MOVE B,-1(P) ; RESTORE COUNT
+ SUB P,[2,,2]
+
+DOIDON: MOVEI E,(B)
+ JRST ATUPDN
+
+; FOR CASE OF NO EVALE
+
+DOILOS: SUB TP,[2,,2]
+DOILLP: INTGO
+ PUSH TP,[0]
+ PUSH TP,[0]
+ SOSL (P)
+ JRST DOILLP
+ JRST DOIDO1
+
+; ROUTINE TO PUSH NEXT TUPLE ELEMENT
+
+CNTARG: AOS E,-1(TP) ; KEEP ARG COUNT UP TO DATE IN E
+CNTRG: EXCH A,-1(TP) ; STORE ELEM AND GET SAVED
+ EXCH B,(TP)
+ PUSH TP,A
+ PUSH TP,B
+ POPJ P,
+
+
+; DUMMY TUPLE AND ITUPLE
+
+IMFUNCTION TUPLE,SUBR
+
+ ENTRY
+ ERRUUO EQUOTE NOT-IN-AUX-LIST
+
+MFUNCTIO ITUPLE,SUBR
+ JRST TUPLE
+
+\f
+; PROCESS A DCL IN THE AUX VAR LISTS
+
+TRYDCL: SKIPN (P) ; SKIP IF NOT IN AUX'S
+ JRST AUXB7
+ CAME B,AS.AUX ; "AUX" ?
+ CAMN B,AS.EXT ; OR "EXTRA"
+ JRST AUXB9 ; YES
+ CAME B,[ASCII /TUPLE/]
+ JRST AUXB10
+ PUSHJ P,MAKINF ; BUILD EMPTY TUPLE
+ MOVEI B,1(TP)
+ PUSH TP,$TINFO ; FENCE POST
+ PUSHJ P,TBTOTP
+ PUSH TP,D
+AUXB6: HRRZ C,(C) ; CDR PAST DCL
+ MOVEM C,RE.ARG+1(TB)
+AUXB8: PUSHJ P,CARTMC ; GET ATOM
+AUXB12: PUSHJ P,PSHBND ; UP GOES THE BINDING
+ PUSH TP,$TATOM ; HIDE HEWITT ATOM AND DCL
+ PUSH TP,-1(P)
+ PUSH TP,$TDECL
+ PUSH TP,-2(P)
+ MOVE E,TP
+ JRST AUXB5
+
+; CHECK FOR ARGS
+
+AUXB10: CAME B,[ASCII /ARGS/]
+ JRST AUXB7
+ MOVEI B,0 ; NULL ARG LIST
+ MOVSI A,TLIST
+ JRST AUXB6 ; GO BIND
+
+AUXB9: SETZM (P) ; NOW READING AUX
+ HRRZ C,(C)
+ MOVEM C,RE.ARG+1(TB)
+ JRST AUXB1
+
+; CHECK FOR NAME/ACT
+
+AUXB7: CAME B,AS.NAM
+ CAMN B,AS.ACT
+ JRST .+2
+ JRST MPD.12 ; LOSER
+ HRRZ C,(C) ; CDR ON
+ HRRZ 0,(C) ; BETTER BE END
+ JUMPN 0,MPD.13
+ PUSHJ P,CARTMC ; FORCE ATOM READ
+ SETZM RE.ARG+1(TB)
+AUXB11: PUSHJ P,MAKACT ; MAKE ACTIVATION
+ JRST AUXB12 ; AND BIND IT
+
+
+; DONE BIND HEWITT ATOM IF NECESARY
+
+AUXDON: SKIPN E,-2(P)
+ JRST AUXD1
+ SETZM -2(P)
+ JRST AUXB11
+
+; FINISHED, RETURN
+
+AUXD1: SUB P,[3,,3]
+ POPJ P,
+
+
+; MAKE AN ACTIVATION OR ENVIRONMNENT
+
+MAKACT: MOVEI B,(TB)
+ MOVSI A,TACT
+MAKAC1: MOVE PVP,PVSTOR+1
+ HRRI A,PVLNT*2+1(PVP) ; POINT TO PROCESS
+ HLL B,OTBSAV(B) ; GET TIME
+ POPJ P,
+
+MAKENV: MOVSI A,TENV
+ HRRZ B,OTBSAV(TB)
+ JRST MAKAC1
+\f
+; SEVERAL USEFUL LITTLE ROUTINES FOR HACKING THIS STUFF
+
+; CARAT/CARATC/CARATM/CARTMC ALL LOOK FOR THE NEXT ATOM
+
+CARAT: HRRZ C,E.ARGL+1(TB) ; PICK UP ARGLIST
+CARATC: JUMPE C,CPOPJ ; FOUND
+ GETYP 0,(C) ; GET ITS TYPE
+ CAIE 0,TATOM
+CPOPJ: POPJ P, ; RETURN, NOT ATOM
+ MOVE E,1(C) ; GET ATOM
+ HRRZ C,(C) ; CDR DCLS
+ JRST CPOPJ1
+
+CARATM: HRRZ C,E.ARGL+1(TB)
+CARTMC: PUSHJ P,CARATC
+ JRST MPD.7 ; REALLY LOSE
+ POPJ P,
+
+
+; SUBROUTINES TO PUSH BINDINGS ETC. UP ON THE STACK
+
+PSBND1: PUSHJ P,PSHBND ; PUSH THEBINDING
+ JRST CHDCL ; NOW CHECK IT AGAINST DECLARATION
+
+PSHBND: SKIPGE SPCCHK ; SKIP IF NORMAL SPECIAL
+ PUSH TP,BNDA1 ; ATOM IN E
+ SKIPL SPCCHK ; SKIP IF NORMAL UNSPEC OR NO CHECK
+ PUSH TP,BNDA
+ PUSH TP,E ; PUSH IT
+PSHAB4: PUSH TP,A
+ PUSH TP,B
+ PUSH TP,[0]
+ PUSH TP,[0]
+ POPJ P,
+
+; ROUTINE TO PUSH 4 0'S
+
+PSH4ZR: SETZB A,B
+ JRST PSHAB4
+
+
+; EXTRRA ARG GOBBLER
+
+EXTRGT: HRRZ A,E.ARG(TB) ; RESET SLOT
+ SETZM E.CNT(TB)
+ CAIE A,ARGCDR ; IF NOT ARGCDR
+ AOS E.CNT(TB)
+ TLO A,400000 ; SET FLAG
+ MOVEM A,E.ARG+1(TB)
+ MOVE A,E.EXTR(TB) ; RET ARG
+ MOVE B,E.EXTR+1(TB)
+ JRST CPOPJ1
+
+; CHECK A/B FOR DEFER
+
+CHKAB: GETYP 0,A
+ CAIE 0,TDEFER ; SKIP IF DEFER
+ JRST (E)
+ MOVE A,(B)
+ MOVE B,1(B) ; GET REAL THING
+ JRST (E)
+; IF DECLARATIONS EXIST, DO THEM
+
+CHDCL: MOVE E,TP
+CHDCLE: SKIPN C,E.DECL+1(TB)
+ POPJ P,
+ JRST CHKDCL
+\f
+; ROUTINE TO READ NEXT THING FROM ARGLIST
+
+NEXTD: HRRZ C,E.ARGL+1(TB) ; GET ARG LIST
+NEXTDC: MOVEI A,0
+ JUMPE C,CPOPJ
+ PUSHJ P,CARATC ; TRY FOR AN ATOM
+ JRST NEXTD1 ; NO
+ JRST CPOPJ1
+
+NEXTD1: CAIE 0,TFORM ; FORM?
+ JRST NXT.L ; COULD BE LIST
+ PUSHJ P,CHQT ; VERIFY 'ATOM
+ MOVEI A,1
+ JRST CPOPJ1
+
+NXT.L: CAIE 0,TLIST ; COULD BE (A <EXPRESS>) OR ('A <EXPRESS>)
+ JRST NXT.S ; BETTER BE A DCL
+ PUSHJ P,LNT.2 ; VERIFY LENGTH IS 2
+ JRST MPD.8
+ CAIE 0,TATOM ; TYPE OF 1ST RET IN 0
+ JRST LST.QT ; MAY BE 'ATOM
+ MOVE E,1(B) ; GET ATOM
+ MOVEI A,2
+ JRST CPOPJ1
+LST.QT: CAIE 0,TFORM ; FORM?
+ JRST MPD.9 ; LOSE
+ PUSH P,C
+ MOVEI C,(B) ; VERIFY 'ATOM
+ PUSHJ P,CHQT
+ MOVEI B,(C) ; POINT BACK TO LIST
+ POP P,C
+ MOVEI A,3 ; CODE
+ JRST CPOPJ1
+
+NXT.S: MOVEI A,(C) ; LET NXTDCL FIND OUT
+ PUSHJ P,NXTDCL
+ JRST MPD.3 ; LOSER
+ MOVEI A,4 ; SET DCL READ FLAG
+ JRST CPOPJ1
+
+; ROUTINE TO CHECK LENGTH OF LIST/FORM FOR BEING 2
+
+LNT.2: HRRZ B,1(C) ; GET LIST/FORM
+ JUMPE B,CPOPJ
+ HRRZ B,(B)
+ JUMPE B,CPOPJ
+ HRRZ B,(B) ; BETTER END HERE
+ JUMPN B,CPOPJ
+ HRRZ B,1(C) ; LIST BACK
+ GETYP 0,(B) ; TYPE OF 1ST ELEMENT
+ JRST CPOPJ1
+
+; ROUTINE TO VERIFY FORM IS 'ATOM AND RET ATOM
+
+CHQT: PUSHJ P,LNT.2 ; 1ST LENGTH CHECK
+ JRST MPD.5
+ CAIE 0,TATOM
+ JRST MPD.5
+ MOVE 0,1(B)
+ CAME 0,IMQUOTE QUOTE
+ JRST MPD.5 ; BETTER BE QUOTE
+ HRRZ E,(B) ; CDR
+ GETYP 0,(E) ; TYPE
+ CAIE 0,TATOM
+ JRST MPD.5
+ MOVE E,1(E) ; GET QUOTED ATOM
+ POPJ P,
+\f
+; ARG BINDER FOR REGULAR ARGS AND OPTIONALS
+
+BNDEM1: PUSH P,[0] ; REGULAR FLAG
+ JRST .+2
+BNDEM2: PUSH P,[1]
+BNDEM: PUSHJ P,NEXTD ; GET NEXT THING
+ JRST CCPOPJ ; END OF THINGS
+ TRNE A,4 ; CHECK FOR DCL
+ JRST BNDEM4
+ TRNE A,2 ; SKIP IF NOT (ATM ..) OR ('ATM ...)
+ SKIPE (P) ; SKIP IF REG ARGS
+ JRST .+2 ; WINNER, GO ON
+ JRST MPD.6 ; LOSER
+ SKIPGE SPCCHK
+ PUSH TP,BNDA1 ; SAVE ATOM
+ SKIPL SPCCHK
+ PUSH TP,BNDA
+ PUSH TP,E
+; SKIPGE E.ARG+1(TB) ; ALREADY EVAL'D ARG?
+ SKIPE E.CNT(TB)
+ JRST RGLAR0
+ TRNN A,1 ; SKIP IF ARG QUOTED
+ JRST RGLARG
+ HRRZ D,@E.FRM+1(TB) ; GET AND CDR ARG
+ JUMPE D,TFACHK ; OH OH MAYBE TOO FEW ARGS
+ MOVEM D,E.FRM+1(TB) ; STORE WINNER
+ HLLZ A,(D) ; GET ARG
+ MOVE B,1(D)
+ JSP E,CHKAB ; HACK DEFER
+ JRST BNDEM3 ; AND GO ON
+
+RGLAR0: TRNE A,1 ; ATTEMPT TO QUOTE ALREADY EVAL'D ARG ?
+ JRST MPD ; YES, LOSE
+RGLARG: PUSH P,A ; SAVE FLAGS
+ PUSHJ P,@E.ARG+1(TB)
+ JRST TFACH1 ; MAY GE TOO FEW
+ SUB P,[1,,1]
+BNDEM3: HRRZ C,@E.ARGL+1(TB) ; CDR THHE ARGS
+ MOVEM C,E.ARGL+1(TB)
+ PUSHJ P,PSHAB4 ; PUSH VALUE AND SLOTS
+ PUSHJ P,CHDCL ; CHECK DCLS
+ JRST BNDEM ; AND BIND ON!
+
+; HERE WHEN ARGS RUN OUT, IF NOT OPTIONAL, GIVE TFA
+
+TFACH1: POP P,A
+TFACHK: SUB TP,[2,,2] ; FLUSH ATOM
+ SKIPN (P) ; SKIP IF OPTIONALS
+ JRST TFA
+CCPOPJ: SUB P,[1,,1]
+ POPJ P,
+
+BNDEM4: HRRZ C,@E.ARGL+1(TB) ; POINT TO REST OF ARGL
+ JRST CCPOPJ
+\f
+
+; EVALUATE LISTS, VECTORS, UNIFROM VECTORS
+
+EVLIST: PUSH P,[-1] ;-1 -- THIS IS A LIST
+ JRST EVL1 ;GO TO HACKER
+
+EVECT: PUSH P,[0] ;0 -- THIS IS A GENERAL VECTOR
+ JRST EVL1
+
+EUVEC: PUSH P,[1] ;1 -- THIS IS A UNIFORM VECTOR
+
+EVL1: PUSH P,[0] ;PUSH A COUNTER
+ GETYPF A,(AB) ;GET FULL TYPE
+ PUSH TP,A
+ PUSH TP,1(AB) ;AND VALUE
+
+EVL2: INTGO ;CHECK INTERRUPTS
+ SKIPN A,1(TB) ;ANYMORE
+ JRST EVL3 ;NO, QUIT
+ SKIPL -1(P) ;SKIP IF LIST
+ JUMPG A,EVL3 ;JUMP IF VECTOR EMPTY
+ GETYPF B,(A) ;GET FULL TYPE
+ SKIPGE C,-1(P) ;SKIP IF NOT LIST
+ HLLZS B ;CLOBBER CDR FIELD
+ JUMPG C,EVL7 ;HACK UNIFORM VECS
+EVL8: PUSH P,B ;SAVE TYPE WORD ON P
+ CAMN B,$TSEG ;SEGMENT?
+ MOVSI B,TFORM ;FAKE OUT EVAL
+ PUSH TP,B ;PUSH TYPE
+ PUSH TP,1(A) ;AND VALUE
+ JSP E,CHKARG ; CHECK DEFER
+ MCALL 1,EVAL ;AND EVAL IT
+ POP P,C ;AND RESTORE REAL TYPE
+ CAMN C,$TSEG ;SEGMENT?
+ JRST DOSEG ;YES, HACK IT
+ AOS (P) ;COUNT ELEMENT
+ PUSH TP,A ;AND PUSH IT
+ PUSH TP,B
+EVL6: SKIPGE A,-1(P) ;DONT SKIP IF LIST
+ HRRZ B,@1(TB) ;CDR IT
+ JUMPL A,ASTOTB ;AND STORE IT
+ MOVE B,1(TB) ;GET VECTOR POINTER
+ ADD B,AMNT(A) ;INCR BY APPROPRIATE AMOUNT
+ASTOTB: MOVEM B,1(TB) ;AND STORE BACK
+ JRST EVL2 ;AND LOOP BACK
+
+AMNT: 2,,2 ;INCR FOR GENERAL VECTOR
+ 1,,1 ;SAME FOR UNIFORM VECTOR
+
+CHKARG: GETYP A,-1(TP)
+ CAIE A,TDEFER
+ JRST (E)
+ HRRZS (TP) ;MAKE SURE INDIRECT WINS
+ MOVE A,@(TP)
+ MOVEM A,-1(TP) ;CLOBBER IN TYPE SLOT
+ MOVE A,(TP) ;NOW GET POINTER
+ MOVE A,1(A) ;GET VALUE
+ MOVEM A,(TP) ;CLOBBER IN
+ JRST (E)
+
+\f
+
+EVL7: HLRE C,A ; FIND TYPE OF UVECTOR
+ SUBM A,C ;C POINTS TO DOPE WORD
+ GETYP B,(C) ;GET TYPE
+ MOVSI B,(B) ;TO LH NOW
+ SOJA A,EVL8 ;AND RETURN TO DO EVAL
+
+EVL3: SKIPL -1(P) ;SKIP IF LIST
+ JRST EVL4 ;EITHER VECTOR OR UVECTOR
+
+ MOVEI B,0 ;GET A NIL
+EVL9: MOVSI A,TLIST ;MAKE TYPE WIN
+EVL5: SOSGE (P) ;COUNT DOWN
+ JRST EVL10 ;DONE, RETURN
+ PUSH TP,$TLIST ;SET TO CALL CONS
+ PUSH TP,B
+ MCALL 2,CONS
+ JRST EVL5 ;LOOP TIL DONE
+
+
+EVL4: MOVEI B,EUVECT ;UNIFORM CASE
+ SKIPG -1(P) ;SKIP IF UNIFORM CASE
+ MOVEI B,EVECTO ;NO, GENERAL CASE
+ POP P,A ;GET COUNT
+ .ACALL A,(B) ;CALL CREATOR
+EVL10: GETYPF A,(AB) ; USE SENT TYPE
+ JRST EFINIS
+
+\f
+; PROCESS SEGMENTS FOR THESE HACKS
+
+DOSEG: PUSHJ P,TYPSEG ; FIND WHAT IS BEING SEGMENTED
+ JUMPE C,LSTSEG ; CHECK END SPLICE IF LIST
+
+SEG3: PUSHJ P,NXTELM ; GET THE NEXTE ELEMT
+ JRST SEG4 ; RETURN TO CALLER
+ AOS (P) ; COUNT
+ JRST SEG3 ; TRY AGAIN
+SEG4: SETZM DSTORE
+ JRST EVL6
+
+TYPSEG: PUSHJ P,TYPSGR
+ JRST ILLSEG
+ POPJ P,
+
+TYPSGR: MOVE E,A ; SAVE TYPE
+ GETYP A,A ; TYPE TO RH
+ PUSHJ P,SAT ;GET STORAGE TYPE
+ MOVE D,B ; GOODIE TO D
+
+ MOVNI C,1 ; C <0 IF ILLEGAL
+ CAIN A,S2WORD ;LIST?
+ MOVEI C,0
+ CAIN A,S2NWORD ;GENERAL VECTOR?
+ MOVEI C,1
+ CAIN A,SNWORD ;UNIFORM VECTOR?
+ MOVEI C,2
+ CAIN A,SCHSTR
+ MOVEI C,3
+ CAIN A,SBYTE
+ MOVEI C,5
+ CAIN A,SSTORE ;SPECIAL AFREE STORAGE ?
+ MOVEI C,4 ;TREAT LIKE A UVECTOR
+ CAIN A,SARGS ;ARGS TUPLE?
+ JRST SEGARG ;NO, ERROR
+ CAILE A,NUMSAT ; SKIP IF NOT TEMPLATE
+ JRST SEGTMP
+ MOVE A,PTYPS(C)
+ CAIN A,4
+ MOVEI A,2 ; NOW TREAT LIKE A UVECTOR
+ HLL E,A
+MSTOR1: JUMPL C,CPOPJ
+
+MDSTOR: MOVEM E,DSTORE
+ JRST CPOPJ1
+
+SEGTMP: MOVEI C,4
+ HRRI E,(A)
+ JRST MSTOR1
+
+SEGARG: MOVSI A,TARGS
+ HRRI A,(E)
+ PUSH TP,A ;PREPARE TO CHECK ARGS
+ PUSH TP,D
+ MOVEI B,-1(TP) ;POINT TO SAVED COPY
+ PUSHJ P,CHARGS ;CHECK ARG POINTER
+ POP TP,D ;AND RESTORE WINNER
+ POP TP,E ;AND TYPE AND FALL INTO VECTOR CODE
+ MOVEI C,1
+ JRST MSTOR1
+
+LSTSEG: SKIPL -1(P) ;SKIP IF IN A LIST
+ JRST SEG3 ;ELSE JOIN COMMON CODE
+ HRRZ A,@1(TB) ;CHECK FOR END OF LIST
+ JUMPN A,SEG3 ;NO, JOIN COMMON CODE
+ SETZM DSTORE ;CLOBBER SAVED GOODIES
+ JRST EVL9 ;AND FINISH UP
+
+NXTELM: INTGO
+ PUSHJ P,NXTLM ; GOODIE TO A AND B
+ POPJ P, ; DONE
+ PUSH TP,A
+ PUSH TP,B
+ JRST CPOPJ1
+NXTLM: XCT TESTR(C) ; SKIP IF MORE IN SEGEMNT
+ POPJ P,
+ XCT TYPG(C) ; GET THE TYPE
+ XCT VALG(C) ; AND VALUE
+ JSP E,CHKAB ; CHECK DEFERRED
+ XCT INCR1(C) ; AND INCREMENT TO NEXT
+CPOPJ1: AOS (P) ; SKIP RETURN
+ POPJ P,
+
+; TABLES FOR SEGMENT OPERATIONS (0->LIST, 1->VECTOR/ARGS, 2->UVEC, 3->STRING)
+
+PTYPS: TLIST,,
+ TVEC,,
+ TUVEC,,
+ TCHSTR,,
+ TSTORA,,
+ TBYTE,,
+
+TESTR: SKIPN D
+ SKIPL D
+ SKIPL D
+ PUSHJ P,CHRDON
+ PUSHJ P,TM1
+ PUSHJ P,CHRDON
+
+TYPG: PUSHJ P,LISTYP
+ GETYPF A,(D)
+ PUSHJ P,UTYPE
+ MOVSI A,TCHRS
+ PUSHJ P,TM2
+ MOVSI A,TFIX
+
+VALG: MOVE B,1(D)
+ MOVE B,1(D)
+ MOVE B,(D)
+ PUSHJ P,1CHGT
+ PUSHJ P,TM3
+ PUSHJ P,1CHGT
+
+INCR1: HRRZ D,(D)
+ ADD D,[2,,2]
+ ADD D,[1,,1]
+ PUSHJ P,1CHINC
+ ADD D,[1,,]
+ PUSHJ P,1CHINC
+
+TM1: HRRZ A,DSTORE
+ SKIPE DSTORE
+ HRRZ A,DSTORE ; GET SAT
+ SUBI A,NUMSAT+1
+ ADD A,TD.LNT+1
+ EXCH C,D
+ XCT (A)
+ HLRZ 0,C ; GET AMNT RESTED
+ SUB B,0
+ EXCH C,D
+ TRNE B,-1
+ AOS (P)
+ POPJ P,
+
+TM3:
+TM2: HRRZ 0,DSTORE
+ SKIPE DSTORE
+ HRRZ 0,DSTORE
+ PUSH P,C
+ PUSH P,D
+ PUSH P,E
+ MOVE B,D
+ MOVEI C,0 ; GET "1ST ELEMENT"
+ PUSHJ P,TMPLNT ; GET NTH IN A AND B
+ POP P,E
+ POP P,D
+ POP P,C
+ POPJ P,
+
+CHRDON: HRRZ B,DSTORE
+ SKIPE DSTORE
+ HRRZ B,DSTORE ; POIT TO DOPE WORD
+ JUMPE B,CHRFIN
+ AOS (P)
+CHRFIN: POPJ P,
+
+LISTYP: GETYP A,(D)
+ MOVSI A,(A)
+ POPJ P,
+1CHGT: MOVE B,D
+ ILDB B,B
+ POPJ P,
+
+1CHINC: IBP D
+ SKIPN DSTORE
+ JRST 1CHIN1
+ SOS DSTORE
+ POPJ P,
+
+1CHIN1: SOS DSTORE
+ POPJ P,
+
+UTYPE: HLRE A,D
+ SUBM D,A
+ GETYP A,(A)
+ MOVSI A,(A)
+ POPJ P,
+
+
+;COMPILER's CALL TO DOSEG
+SEGMNT: PUSHJ P,TYPSEG
+SEGLP1: SETZB A,B
+SEGLOP: PUSHJ P,NXTELM
+ JRST SEGRET
+ AOS (P)-2 ; INCREMENT COMPILER'S COUNT
+ JRST SEGLOP
+
+SEGRET: SETZM DSTORE
+ POPJ P,
+
+SEGLST: PUSHJ P,TYPSEG
+ JUMPN C,SEGLS2
+SEGLS3: SETZM DSTORE
+ MOVSI A,TLIST
+SEGLS1: SOSGE -2(P) ; START COUNT DOWN
+ POPJ P,
+ MOVEI E,(B)
+ POP TP,D
+ POP TP,C
+ PUSHJ P,ICONS
+ JRST SEGLS1
+
+SEGLS2: PUSHJ P,NXTELM
+ JRST SEGLS4
+ AOS -2(P)
+ JRST SEGLS2
+
+SEGLS4: MOVEI B,0
+ JRST SEGLS3
+\f
+
+;SPECBIND BINDS IDENTIFIERS. IT IS CALLED BY PUSHJ P,SPECBIND.
+;SPECBIND IS PROVIDED WITH A CONTIGUOUS SET OF TRIPLETS ON TP.
+;EACH TRIPLET IS AS FOLLOWS:
+;THE FIRST ELEMENT IS THE IDENTIFIER TO BE BOUND, ITS TYPE WORD IS [TATOM,,-1],
+;THE SECOND IS THE VALUE TO WHICH IT IS TO BE ASSIGNED,
+;AND THE THIRD IS A PAIR OF ZEROES.
+
+BNDA1: TATOM,,-2
+BNDA: TATOM,,-1
+BNDV: TVEC,,-1
+
+USPECBIND:
+ MOVE E,TP
+USPCBE: PUSH P,$TUBIND
+ JRST .+3
+
+SPECBIND:
+ MOVE E,TP ;GET THE POINTER TO TOP
+SPECBE: PUSH P,$TBIND
+ ADD E,[1,,1] ;BUMP POINTER ONCE
+ SETZB 0,D ;CLEAR TEMPS
+ PUSH P,0
+ MOVEI 0,(TB) ; FOR CHECKS
+
+BINDLP: MOVE A,-4(E) ; CHECK FOR VEC BIND
+ CAMN A,BNDV
+ JRST NONID
+ MOVE A,-6(E) ;GET TYPE
+ CAME A,BNDA1 ; FOR UNSPECIAL
+ CAMN A,BNDA ;NORMAL ID BIND?
+ CAILE 0,-6(E) ; MAKE SURE NOT GOING UNDER FRAME
+ JRST SPECBD
+ SUB E,[6,,6] ;MOVE PTR
+ SKIPE D ;LINK?
+ HRRM E,(D) ;YES -- LOBBER
+ SKIPN (P) ;UPDATED?
+ MOVEM E,(P) ;NO -- DO IT
+
+ MOVE A,0(E) ;GET ATOM PTR
+ MOVE B,1(E)
+ PUSHJ P,SILOC ;GET LAST BINDING
+ MOVS A,OTBSAV (TB) ;GET TIME
+ HRL A,5(E) ; GET DECL POINTER
+ MOVEM A,4(E) ;CLOBBER IT AWAY
+ MOVE A,(E) ; SEE IF SPEC/UNSPEC
+ TRNN A,1 ; SKIP, ALWAYS SPEC
+ SKIPA A,-1(P) ; USE SUPPLIED
+ MOVSI A,TBIND
+ MOVEM A,(E) ;IDENTIFY AS BIND BLOCK
+ JUMPE B,SPEB10
+ MOVE PVP,PVSTOR+1
+ HRRZ C,SPBASE(PVP) ; CHECK FOR CROSS OF PROC
+ MOVEI A,(TP)
+ CAIL A,(B) ; LOSER
+ CAILE C,(B) ; SKIP IFF WINNER
+ MOVEI B,1
+SPEB10: MOVEM B,5(E) ;IN RESTORE CELLS
+
+ MOVE C,1(E) ;GET ATOM PTR
+ SKIPE (C)
+ JUMPE B,.-4
+ MOVEI A,(C)
+ MOVEI B,0 ; FOR SPCUNP
+ CAIL A,HIBOT ; SKIP IF IMPURE ATOM
+ PUSHJ P,SPCUNP
+ MOVE PVP,PVSTOR+1
+ HRRZ A,BINDID+1(PVP) ;GET PROCESS NUMBER
+ HRLI A,TLOCI ;MAKE LOC PTR
+ MOVE B,E ;TO NEW VALUE
+ ADD B,[2,,2]
+ MOVEM A,(C) ;CLOBBER ITS VALUE
+ MOVEM B,1(C) ;CELL
+ MOVE D,E ;REMEMBER LINK
+ JRST BINDLP ;DO NEXT
+
+NONID: CAILE 0,-4(E)
+ JRST SPECBD
+ SUB E,[4,,4]
+ SKIPE D
+ HRRM E,(D)
+ SKIPN (P)
+ MOVEM E,(P)
+
+ MOVE D,1(E) ;GET PTR TO VECTOR
+ MOVE C,(D) ;EXCHANGE TYPES
+ EXCH C,2(E)
+ MOVEM C,(D)
+
+ MOVE C,1(D) ;EXCHANGE DATUMS
+ EXCH C,3(E)
+ MOVEM C,1(D)
+
+ MOVEI A,TBVL
+ HRLM A,(E) ;IDENTIFY BIND BLOCK
+ MOVE D,E ;REMEMBER LINK
+ JRST BINDLP
+
+SPECBD: SKIPE D
+ MOVE SP,SPSTOR+1
+ HRRM SP,(D)
+ SKIPE D,(P)
+ MOVEM D,SPSTOR+1
+ SUB P,[2,,2]
+ POPJ P,
+
+
+; HERE TO IMPURIFY THE ATOM
+
+SPCUNP: PUSH TP,$TSP
+ PUSH TP,E
+ PUSH TP,$TSP
+ PUSH TP,-1(P) ; LINK BACK IS AN SP
+ PUSH TP,$TSP
+ PUSH TP,B
+ CAIN B,1
+ SETZM -1(TP) ; FIXUP SOME FUNNYNESS
+ MOVE B,C
+ PUSHJ P,IMPURIFY
+ MOVE 0,-2(TP) ; RESTORE LINK BACK POINTER
+ MOVEM 0,-1(P)
+ MOVE E,-4(TP)
+ MOVE C,B
+ MOVE B,(TP)
+ SUB TP,[6,,6]
+ MOVEI 0,(TB)
+ POPJ P,
+
+; ENTRY FROM COMPILER TO SET UP A BINDING
+
+IBIND: MOVE SP,SPSTOR+1
+ SUBI E,-5(SP) ; CHANGE TO PDL POINTER
+ HRLI E,(E)
+ ADD E,SP
+ MOVEM C,-4(E)
+ MOVEM A,-3(E)
+ MOVEM B,-2(E)
+ HRLOI A,TATOM
+ MOVEM A,-5(E)
+ MOVSI A,TLIST
+ MOVEM A,-1(E)
+ MOVEM D,(E)
+ JRST SPECB1 ; NOW BIND IT
+
+; "FAST CALL TO SPECBIND"
+
+
+
+; Compiler's call to SPECBIND all atom bindings, no TBVLs etc.
+
+SPECBND:
+ MOVE E,TP ; POINT TO BINDING WITH E
+SPECB1: PUSH P,[0] ; SLOTS OF INTEREST
+ PUSH P,[0]
+ SUBM M,-2(P)
+
+SPECB2: MOVEI 0,(TB) ; FOR FRAME CHECK
+ MOVE A,-5(E) ; LOOK AT FIRST THING
+ CAMN A,BNDA ; SKIP IF LOSER
+ CAILE 0,-5(E) ; SKIP IF REAL WINNER
+ JRST SPECB3
+
+ SUB E,[5,,5] ; POINT TO BINDING
+ SKIPE A,(P) ; LINK?
+ HRRM E,(A) ; YES DO IT
+ SKIPN -1(P) ; FIRST ONE?
+ MOVEM E,-1(P) ; THIS IS IT
+
+ MOVE A,1(E) ; POINT TO ATOM
+ MOVE PVP,PVSTOR+1
+ MOVE 0,BINDID+1(PVP) ; QUICK CHECK
+ HRLI 0,TLOCI
+ CAMN 0,(A) ; WINNERE?
+ JRST SPECB4 ; YES, GO ON
+
+ PUSH P,B ; SAVE REST OF ACS
+ PUSH P,C
+ PUSH P,D
+ MOVE B,A ; FOR ILOC TO WORK
+ PUSHJ P,SILOC ; GO LOOK IT UP
+ JUMPE B,SPECB9
+ MOVE PVP,PVSTOR+1
+ HRRZ C,SPBASE+1(PVP)
+ MOVEI A,(TP)
+ CAIL A,(B) ; SKIP IF LOSER
+ CAILE C,(B) ; SKIP IF WINNER
+ MOVEI B,1 ; SAY NO BACK POINTER
+SPECB9: MOVE C,1(E) ; POINT TO ATOM
+ SKIPE (C) ; IF GLOBALLY BOUND, MAKE SURE OK
+ JUMPE B,.-3
+ MOVEI A,(C) ; PURE ATOM?
+ CAIGE A,HIBOT ; SKIP IF OK
+ JRST .+4
+ PUSH P,-4(P) ; MAKE HAPPINESS
+ PUSHJ P,SPCUNP ; IMPURIFY
+ POP P,-5(P)
+ MOVE PVP,PVSTOR+1
+ MOVE A,BINDID+1(PVP)
+ HRLI A,TLOCI
+ MOVEM A,(C) ; STOR POINTER INDICATOR
+ MOVE A,B
+ POP P,D
+ POP P,C
+ POP P,B
+ JRST SPECB5
+
+SPECB4: MOVE A,1(A) ; GET LOCATIVE
+SPECB5: EXCH A,5(E) ; CLOBBER INTO REBIND SLOT (GET DECL)
+ HLL A,OTBSAV(TB) ; TIME IT
+ MOVSM A,4(E) ; SAVE DECL AND TIME
+ MOVEI A,TBIND
+ HRLM A,(E) ; CHANGE TO A BINDING
+ MOVE A,1(E) ; POINT TO ATOM
+ MOVEM E,(P) ; REMEMBER THIS GUY
+ ADD E,[2,,2] ; POINT TO VAL CELL
+ MOVEM E,1(A) ; INTO ATOM SLOT
+ SUB E,[3,,3] ; POINT TO NEXT ONE
+ JRST SPECB2
+
+SPECB3: SKIPE A,(P)
+ MOVE SP,SPSTOR+1
+ HRRM SP,(A) ; LINK OLD STUFF
+ SKIPE A,-1(P) ; NEW SP?
+ MOVEM A,SPSTOR+1
+ SUB P,[2,,2]
+ INTGO ; IN CASE BLEW STACK
+ SUBM M,(P)
+ POPJ P,
+\f
+
+;SPECSTORE RESTORES THE BINDINGS SP TO THE ENVIRONMENT POINTER IN
+;SPSAV (TB). IT IS CALLED BY PUSHJ P,SPECSTORE.
+
+SPECSTORE:
+ PUSH P,E
+ HRRZ E,SPSAV (TB) ;GET TARGET POINTER
+ PUSHJ P,STLOOP
+ POP P,E
+ MOVE SP,SPSAV(TB) ; GET NEW SP
+ MOVEM SP,SPSTOR+1
+ POPJ P,
+
+STLOOP: MOVE SP,SPSTOR+1
+ PUSH P,D
+ PUSH P,C
+
+STLOO1: CAIL E,(SP) ;ARE WE DONE?
+ JRST STLOO2
+ HLRZ C,(SP) ;GET TYPE OF BIND
+ CAIN C,TUBIND
+ JRST .+3
+ CAIE C,TBIND ;NORMAL IDENTIFIER?
+ JRST ISTORE ;NO -- SPECIAL HACK
+
+
+ MOVE C,1(SP) ;GET TOP ATOM
+ MOVSI 0,TLOCI ; MAYBE LOCI OR UNBOUND
+ SKIPL D,5(SP)
+ MOVSI 0,TUNBOU
+ MOVE PVP,PVSTOR+1
+ HRR 0,BINDID+1(PVP) ;STORE SIGNATURE
+ SKIPN 5(SP)
+ MOVEI 0,0 ; TOTALLY UNBOUND IN ALL CASES
+ MOVEM 0,(C) ;CLOBBER INTO ATOM
+ MOVEM D,1(C)
+ SETZM 4(SP)
+SPLP: HRRZ SP,(SP) ;FOLOW LINK
+ JUMPN SP,STLOO1 ;IF MORE
+ SKIPE E ; OK IF E=0
+ FATAL SP OVERPOP
+STLOO2: MOVEM SP,SPSTOR+1
+ POP P,C
+ POP P,D
+ POPJ P,
+
+ISTORE: CAIE C,TBVL
+ JRST CHSKIP
+ MOVE C,1(SP)
+ MOVE D,2(SP)
+ MOVEM D,(C)
+ MOVE D,3(SP)
+ MOVEM D,1(C)
+ JRST SPLP
+
+CHSKIP: CAIN C,TSKIP
+ JRST SPLP
+ CAIE C,TUNWIN ; UNWIND HACK
+ FATAL BAD SP
+ HRRZ C,-2(P) ; WHERE FROM?
+ CAIE C,CHUNPC
+ JRST SPLP ; IGNORE
+ MOVEI E,(TP) ; FIXUP SP
+ SUBI E,(SP)
+ MOVSI E,(E)
+ HLL SP,TP
+ SUB SP,E
+ POP P,C
+ POP P,D
+ AOS (P)
+ POPJ P,
+
+; ENTRY FOR FUNNY COMPILER UNBIND (1)
+
+SSPECS: PUSH P,E
+ PUSH P,PVP
+ PUSH P,SP
+ MOVEI E,(TP)
+ PUSHJ P,STLOOP
+SSPEC2: SUBI E,(SP) ; MAKE SP BE AOBJN
+ MOVSI E,(E)
+ HLL SP,TP
+ SUB SP,E
+ MOVEM SP,SPSTOR+1
+ POP P,SP
+ POP P,PVP
+ POP P,E
+ POPJ P,
+
+; ENTRY FOR FUNNY COMPILER UNBIND (2)
+
+SSPEC1: PUSH P,E
+ PUSH P,PVP
+ PUSH P,SP
+ SUBI E,1 ; MAKE SURE GET CURRENT BINDING
+ PUSHJ P,STLOOP ; UNBIND
+ MOVEI E,(TP) ; NOW RESET SP
+ JRST SSPEC2
+\f
+EFINIS: MOVE PVP,PVSTOR+1
+ SKIPN C,1STEPR+1(PVP) ; SKIP NIF BEING ONE PROCEEDED
+ JRST FINIS
+ PUSH TP,$TATOM
+ PUSH TP,MQUOTE EVLOUT
+ PUSH TP,A ;SAVE EVAL RESULTS
+ PUSH TP,B
+ PUSH TP,[TINFO,,2] ; FENCE POST
+ PUSHJ P,TBTOTP
+ PUSH TP,D
+ PUSHJ P,MAKINF ; MAKE ARG BLOCK INFO
+ PUSH TP,A
+ MOVEI B,-6(TP)
+ HRLI B,-4 ; AOBJN TO ARGS BLOCK
+ PUSH TP,B
+ MOVE PVP,PVSTOR+1
+ PUSH TP,1STEPR(PVP)
+ PUSH TP,1STEPR+1(PVP) ; PROCESS DOING THE 1STEPPING
+ MCALL 2,RESUME
+ MOVE A,-3(TP) ; GET BACK EVAL VALUE
+ MOVE B,-2(TP)
+ JRST FINIS
+
+1STEPI: PUSH TP,$TATOM
+ PUSH TP,MQUOTE EVLIN
+ PUSH TP,$TAB ; PUSH EVALS ARGGS
+ PUSH TP,AB
+ PUSHJ P,MAKINF ; TURN INTO ARGS BLOCK
+ MOVEM A,-1(TP) ; AND CLOBBER
+ PUSH TP,[TINFO,,2] ; FENCE POST 2D TUPLE
+ PUSHJ P,TBTOTP
+ PUSH TP,D
+ PUSHJ P,MAKINF ; TURN IT INTO ARGS BLOCK
+ PUSH TP,A
+ MOVEI B,-6(TP) ; SETUP TUPLE
+ HRLI B,-4
+ PUSH TP,B
+ MOVE PVP,PVSTOR+1
+ PUSH TP,1STEPR(PVP)
+ PUSH TP,1STEPR+1(PVP)
+ MCALL 2,RESUME ; START UP 1STEPERR
+ SUB TP,[6,,6] ; REMOVE CRUD
+ GETYP A,A ; GET 1STEPPERS TYPE
+ CAIE A,TDISMI ; IF DISMISS, STOP 1 STEPPING
+ JRST EVALON
+
+; HERE TO PUSH DOWN THE 1 STEP STATE AND RUN
+
+ MOVE D,PVP
+ ADD D,[1STEPR,,1STEPR] ; POINT TO 1 STEP SLOT
+ PUSH TP,$TSP ; SAVE CURRENT SP
+ PUSH TP,SPSTOR+1
+ PUSH TP,BNDV
+ PUSH TP,D ; BIND IT
+ PUSH TP,$TPVP
+ PUSH TP,[0] ; NO 1 STEPPER UNTIL POPJ
+ PUSHJ P,SPECBIND
+
+; NOW PUSH THE ARGS UP TO RE-CALL EVAL
+
+ MOVEI A,0
+EFARGL: JUMPGE AB,EFCALL
+ PUSH TP,(AB)
+ PUSH TP,1(AB)
+ ADD AB,[2,,2]
+ AOJA A,EFARGL
+
+EFCALL: ACALL A,EVAL ; NOW DO THE EVAL
+ MOVE C,(TP) ; PRE-UNBIND
+ MOVE PVP,PVSTOR+1
+ MOVEM C,1STEPR+1(PVP)
+ MOVE SP,-4(TP) ; AVOID THE UNBIND
+ MOVEM SP,SPSTOR+1
+ SUB TP,[6,,6] ; AND FLUSH LOSERS
+ JRST EFINIS ; AND TRY TO FINISH UP
+
+MAKINF: HLRZ A,OTBSAV(TB) ; TIME IT
+ HRLI A,TARGS
+ POPJ P,
+
+
+TBTOTP: MOVEI D,(TB) ; COMPUTE REL DIST FROM TP TO TB
+ SUBI D,(TP)
+ POPJ P,
+; ARRIVE HERE TO COMPLETE A COMPILER GENERATED TUPLE
+; D/ LENGTH OF THE TUPLE IN WORDS
+
+MAKTU2: MOVE D,-1(P) ; GET LENGTH
+ ASH D,1
+ PUSHJ P,MAKTUP
+ PUSH TP,A
+ PUSH TP,B
+ POPJ P,
+
+MAKTUP: HRLI D,TINFO ; FIRST WORD OF FENCE POST
+ PUSH TP,D
+ HRROI B,(TP) ; TOP OF TUPLE
+ SUBI B,(D)
+ TLC B,-1(D) ; AOBJN IT
+ PUSHJ P,TBTOTP
+ PUSH TP,D
+ HLRZ A,OTBSAV(TB) ; TIME IT
+ HRLI A,TARGS
+ POPJ P,
+
+; HERE TO ALLOCATE SLOTS FOR COMPILER (AMNT IN A)
+
+TPALOC: SUBM M,(P)
+ ;Once here ==>ADDI A,1 Bug???
+ HRLI A,(A)
+ ADD TP,A
+ PUSH P,A
+ SKIPL TP
+ PUSHJ P,TPOVFL ; IN CASE IT LOST
+ INTGO ; TAKE THE GC IF NEC
+ HRRI A,2(TP)
+ SUB A,(P)
+ SETZM -1(A)
+ HRLI A,-1(A)
+ BLT A,(TP)
+ SUB P,[1,,1]
+ JRST POPJM
+
+
+NTPALO: PUSH TP,[0]
+ SOJG 0,.-1
+ POPJ P,
+
+\f;EVALUATES A IDENTIFIER -- GETS LOCAL VALUE IF THERE IS ONE, OTHERWISE GLOBAL.
+
+IMFUNCTION VALUE,SUBR
+ JSP E,CHKAT
+ PUSHJ P,IDVAL
+ JRST FINIS
+
+IDVAL: PUSHJ P,IDVAL1
+ CAMN A,$TUNBOU
+ JRST UNBOU
+ POPJ P,
+
+IDVAL1: PUSH TP,A
+ PUSH TP,B ;SAVE ARG IN CASE NEED TO CHECK GLOBAL VALUE
+ PUSHJ P,ILVAL ;LOCAL VALUE FINDER
+ CAME A,$TUNBOUND ;IF NOT UNBOUND OR UNASSIGNED
+ JRST RIDVAL ;DONE - CLEAN UP AND RETURN
+ POP TP,B ;GET ARG BACK
+ POP TP,A
+ JRST IGVAL
+RIDVAL: SUB TP,[2,,2]
+ POPJ P,
+
+;GETS THE LOCAL VALUE OF AN IDENTIFIER
+
+IMFUNCTION LVAL,SUBR
+ JSP E,CHKAT
+ PUSHJ P,AILVAL
+ CAME A,$TUNBOUND
+ JRST FINIS
+ JUMPN B,UNAS
+ JRST UNBOU
+
+; MAKE AN ATOM UNASSIGNED
+
+MFUNCTION UNASSIGN,SUBR
+ JSP E,CHKAT ; GET ATOM ARG
+ PUSHJ P,AILOC
+UNASIT: CAMN A,$TUNBOU ; IF UNBOUND
+ JRST RETATM
+ MOVSI A,TUNBOU
+ MOVEM A,(B)
+ SETOM 1(B) ; MAKE SURE
+RETATM: MOVE B,1(AB)
+ MOVE A,(AB)
+ JRST FINIS
+
+; UNASSIGN GLOBALLY
+
+MFUNCTION GUNASSIGN,SUBR
+ JSP E,CHKAT2
+ PUSHJ P,IGLOC
+ CAMN A,$TUNBOU
+ JRST RETATM
+ MOVE B,1(AB) ; ATOM BACK
+ MOVEI 0,(B)
+ CAIL 0,HIBOT ; SKIP IF IMPURE
+ PUSHJ P,IMPURIFY ; YES, MAKE IT IMPURE
+ PUSHJ P,IGLOC ; RESTORE LOCATIVE
+ HRRZ 0,-2(B) ; SEE IF MANIFEST
+ GETYP A,(B) ; AND CURRENT TYPE
+ CAIN 0,-1
+ CAIN A,TUNBOU
+ JRST UNASIT
+ SKIPE IGDECL
+ JRST UNASIT
+ MOVE D,B
+ JRST MANILO
+\f
+; GETS A LOCATIVE TO THE LOCAL VALUE OF AN IDENTIFIER.
+
+MFUNCTION LLOC,SUBR
+ JSP E,CHKAT
+ PUSHJ P,AILOC
+ CAMN A,$TUNBOUND
+ JRST UNBOU
+ MOVSI A,TLOCD
+ HRR A,2(B)
+ JRST FINIS
+
+;TESTS TO SEE IF AN IDENTIFIER IS LOCALLY BOUND
+
+MFUNCTION BOUND,SUBR,[BOUND?]
+ JSP E,CHKAT
+ PUSHJ P,AILVAL
+ CAMN A,$TUNBOUND
+ JUMPE B,IFALSE
+ JRST TRUTH
+
+;TESTS TO SEE IF AN IDENTIFIER IS LOCALLY ASSIGNED
+
+MFUNCTION ASSIGP,SUBR,[ASSIGNED?]
+ JSP E,CHKAT
+ PUSHJ P,AILVAL
+ CAME A,$TUNBOUND
+ JRST TRUTH
+; JUMPE B,UNBOU
+ JRST IFALSE
+
+;GETS THE GLOBAL VALUE OF AN IDENTIFIER
+
+IMFUNCTION GVAL,SUBR
+ JSP E,CHKAT2
+ PUSHJ P,IGVAL
+ CAMN A,$TUNBOUND
+ JRST UNAS
+ JRST FINIS
+
+;GETS A LOCATIVE TO THE GLOBAL VALUE OF AN IDENTIFIER
+
+MFUNCTION RGLOC,SUBR
+
+ JRST GLOC
+
+MFUNCTION GLOC,SUBR
+
+ JUMPGE AB,TFA
+ CAMGE AB,[-5,,]
+ JRST TMA
+ JSP E,CHKAT1
+ MOVEI E,IGLOC
+ CAML AB,[-2,,]
+ JRST .+4
+ GETYP 0,2(AB)
+ CAIE 0,TFALSE
+ MOVEI E,IIGLOC
+ PUSHJ P,(E)
+ CAMN A,$TUNBOUND
+ JRST UNAS
+ MOVSI A,TLOCD
+ HRRZ 0,FSAV(TB)
+ CAIE 0,GLOC
+ MOVSI A,TLOCR
+ CAIE 0,GLOC
+ SUB B,GLOTOP+1
+ MOVE C,1(AB) ; GE ATOM
+ MOVEI 0,(C)
+ CAIGE 0,HIBOT ; SKIP IF PURE ATOM
+ JRST FINIS
+
+; MAKE ATOM AND VALUE IMPURE IF GETTING GLOC TO IT
+
+ MOVE B,C ; ATOM TO B
+ PUSHJ P,IMPURIFY
+ JRST GLOC ; AND TRY AGAIN
+
+;TESTS TO SEE IF AN IDENTIFIER IS GLOBALLY ASSIGNED
+
+MFUNCTION GASSIG,SUBR,[GASSIGNED?]
+ JSP E,CHKAT2
+ PUSHJ P,IGVAL
+ CAMN A,$TUNBOUND
+ JRST IFALSE
+ JRST TRUTH
+
+; TEST FOR GLOBALLY BOUND
+
+MFUNCTION GBOUND,SUBR,[GBOUND?]
+
+ JSP E,CHKAT2
+ PUSHJ P,IGLOC
+ JUMPE B,IFALSE
+ JRST TRUTH
+
+\f
+
+CHKAT2: ENTRY 1
+CHKAT1: GETYP A,(AB)
+ MOVSI A,(A)
+ CAME A,$TATOM
+ JRST NONATM
+ MOVE B,1(AB)
+ JRST (E)
+
+CHKAT: HLRE A,AB ; - # OF ARGS
+ ASH A,-1 ; TO ACTUAL WORDS
+ JUMPGE AB,TFA
+ MOVE C,SPSTOR+1 ; FOR BINDING LOOKUPS
+ AOJE A,CHKAT1 ; ONLY ONE ARG, NO ENVIRONMENT
+ AOJL A,TMA ; TOO MANY
+ GETYP A,2(AB) ; MAKE SURE OF TENV OR TFRAME
+ CAIE A,TFRAME
+ CAIN A,TENV
+ JRST CHKAT3
+ CAIN A,TACT ; FOR PFISTERS LOSSAGE
+ JRST CHKAT3
+ CAIE A,TPVP ; OR PROCESS
+ JRST WTYP2
+ MOVE B,3(AB) ; GET PROCESS
+ MOVE C,SPSTOR+1 ; IN CASE ITS ME
+ CAME B,PVSTOR+1 ; SKIP IF DIFFERENT
+ MOVE C,SPSTO+1(B) ; GET ITS SP
+ JRST CHKAT1
+CHKAT3: MOVEI B,2(AB) ; POINT TO FRAME POINTER
+ PUSHJ P,CHFRM ; VALIDITY CHECK
+ MOVE B,3(AB) ; GET TB FROM FRAME
+ MOVE C,SPSAV(B) ; GET ENVIRONMENT POINTER
+ JRST CHKAT1
+
+\f
+; SILOC--CALLS ILOC IGNORING SPECIAL CHECKING
+
+SILOC: JFCL
+
+;ILOC RETURNS IN A AND B A LOCATIVE TO THE LOCAL VALUE OF THE IDENTIFIER
+; PASSED TO IT IN A AND B. IF THE IDENTIFIER IS LOCALLY UNBOUND IT RETURNS
+; $TUNBOUND IN A AND 0 IN B, IT IS CALLED BY PUSHJ P,ILOC.
+
+ILOC: MOVE C,SPSTOR+1 ; SETUP SEARCH START
+AILOC: SKIPN (B) ; ANY KIND OF VALUE AT ALL?
+ JUMPN B,FUNPJ
+ MOVSI A,TLOCI ;MAKE A LOCATIVE TYPE CELL
+ PUSH P,E
+ PUSH P,D
+ MOVEI E,0 ; FLAG TO CLOBBER ATOM
+ JUMPE B,SCHSP ; IF LOOKING FOR SLOT, SEARCH NOW
+ CAME C,SPSTOR+1 ; ENVIRONMENT CHANGE?
+ JRST SCHSP ; YES, MUST SEARCH
+ MOVE PVP,PVSTOR+1
+ HRR A,BINDID+1(PVP) ;FOR THE CURRENT PROCESS
+ CAME A,(B) ;IS THERE ONE IN THE VALUE CELL?
+ JRST SCHLP ;NO -- SEARCH THE LOCAL BINDINGS
+ MOVE B,1(B) ;YES -- GET LOCATIVE POINTER
+ MOVE C,PVP
+ILCPJ: MOVE E,SPCCHK
+ TRNN E,1 ; SKIP IF DOING SPEC UNSPEC CHECK
+ JRST ILOCPJ
+ HRRZ E,-2(P) ; IF IGNORING, IGNORE
+ HRRZ E,-1(E)
+ CAIN E,SILOC
+ JRST ILOCPJ
+ HLRZ E,-2(B)
+ CAIE E,TUBIND
+ JRST ILOCPJ
+ CAMGE B,CURFCN+1(PVP)
+ JRST SCHLPX
+ MOVEI D,-2(B)
+ HRRZ SP,SPSTOR+1
+ CAIG D,(SP)
+ CAMGE B,SPBASE+1(PVP)
+ JRST SCHLPX
+ MOVE C,PVSTOR+1
+ILOCPJ: POP P,D
+ POP P,E
+ POPJ P, ;FROM THE VALUE CELL
+
+SCHLPX: MOVEI E,1
+ MOVE C,SPSTOR+1
+ MOVE B,-1(B)
+ JRST SCHLP
+
+
+SCHLP5: SETOM (P)
+ JRST SCHLP2
+
+SCHLP: MOVEI D,(B)
+ CAIL D,HIBOT ; SKIP IF IMPURE ATOM
+SCHSP: MOVEI E,1 ; DONT STORE LOCATIVE
+
+ PUSH P,E ; PUSH SWITCH
+ MOVE E,PVSTOR+1 ; GET PROC
+SCHLP1: JUMPE C,UNPJ ;IF NO MORE -- LOSE
+ CAMN B,1(C) ;ARE WE POINTING AT THE WINNER?
+ JRST SCHFND ;YES
+ GETYP D,(C) ; CHECK SKIP
+ CAIE D,TSKIP
+ JRST SCHLP2
+ PUSH P,B ; CHECK DETOUR
+ MOVEI B,2(C)
+ PUSHJ P,CHFRAM ; NON-FATAL FRAME CHECKER
+ HRRZ E,2(C) ; CONS UP PROCESS
+ SUBI E,PVLNT*2+1
+ HRLI E,-2*PVLNT
+ JUMPE B,SCHLP3 ; LOSER, FIX IT
+ POP P,B
+ MOVEI C,1(C) ; FOLLOW LOOKUP CHAIN
+SCHLP2: HRRZ C,(C) ;FOLLOW LINK
+ JRST SCHLP1
+
+SCHLP3: POP P,B
+ HRRZ SP,SPSTOR+1
+ MOVEI C,(SP) ; *** NDR'S BUG ***
+ CAME E,PVSTOR+1 ; USE IF CURRENT PROCESS
+ HRRZ C,SPSTO+1(E) ; USE CURRENT SP FOR PROC
+ JRST SCHLP1
+
+SCHFND: MOVE D,SPCCHK
+ TRNN D,1 ; SKIP IF DOING SPEC UNSPEC CHECK
+ JRST SCHFN1
+ HRRZ D,-2(P) ; IF IGNORING, IGNORE
+ HRRZ D,-1(D)
+ CAIN D,SILOC
+ JRST ILOCPJ
+ HLRZ D,(C)
+ CAIE D,TUBIND
+ JRST SCHFN1
+ HRRZ D,CURFCN+1(PVP)
+ CAIL D,(C)
+ JRST SCHLP5
+ HRRZ SP,SPSTOR+1
+ HRRZ D,SPBASE+1(PVP)
+ CAIL SP,(C)
+ CAIL D,(C)
+ JRST SCHLP5
+
+SCHFN1: EXCH B,C ;SAVE THE ATOM PTR IN C
+ MOVEI B,2(B) ;MAKE UP THE LOCATIVE
+ SUB B,TPBASE+1(E)
+ HRLI B,(B)
+ ADD B,TPBASE+1(E)
+ EXCH C,E ; RET PROCESS IN C
+ POP P,D ; RESTORE SWITCH
+
+ JUMPN D,ILOCPJ ; DONT CLOBBER ATOM
+ MOVEM A,(E) ;CLOBBER IT AWAY INTO THE
+ MOVE D,1(E) ; GET OLD POINTER
+ MOVEM B,1(E) ;ATOM'S VALUE CELL
+ JUMPE D,ILOCPJ ; IF POINTS TO GLOBAL OR OTHER PROCES
+ ; MAKE SURE BINDING SO INDICATES
+ MOVE D,B ; POINT TO BINDING
+ SKIPL E,3(D) ; GO TO FIRST ONE, JUST IN CASE
+ JRST .+3
+ MOVE D,E
+ JRST .-3 ; LOOP THROUGH
+ MOVEI E,1
+ MOVEM E,3(D) ; MAGIC INDICATION
+ JRST ILOCPJ
+
+UNPJ: SUB P,[1,,1] ; FLUSH CRUFT
+UNPJ1: MOVE C,E ; RET PROCESS ANYWAY
+UNPJ11: POP P,D
+ POP P,E
+UNPOPJ: MOVSI A,TUNBOUND
+ MOVEI B,0
+ POPJ P,
+
+FUNPJ: MOVE C,PVSTOR+1
+ JRST UNPOPJ
+
+;IGLOC RETURNS IN A AND B A LOCATIVE TO THE GLOBAL VALUE OF THE
+;IDENTIFIER PASSED TO IT IN A AND B. IF THE IDENTIFIER IS GLOBALLY
+;UNBPOUND IT RETURNS $TUNBOUND IN A AND 0 IN B. IT IS CALLED BY PUSHJ P,IGLOC.
+
+IGLOC: MOVSI A,TLOCI ;DO WE HAVE A LOCATIVE TO
+ CAME A,(B) ;A PROCESS #0 VALUE?
+ JRST SCHGSP ;NO -- SEARCH
+ MOVE B,1(B) ;YES -- GET VALUE CELL
+ POPJ P,
+
+SCHGSP: SKIPN (B)
+ JRST UNPOPJ
+ MOVE D,GLOBSP+1 ;GET GLOBAL SP PTR
+
+SCHG1: JUMPGE D,UNPOPJ ;IF NO MORE, LEAVE
+ CAMN B,1(D) ;ARE WE FOUND?
+ JRST GLOCFOUND ;YES
+ ADD D,[4,,4] ;NO -- TRY NEXT
+ JRST SCHG1
+
+GLOCFOUND:
+ EXCH B,D ;SAVE ATOM PTR
+ ADD B,[2,,2] ;MAKE LOCATIVE
+ MOVEI 0,(D)
+ CAIL 0,HIBOT
+ POPJ P,
+ MOVEM A,(D) ;CLOBBER IT AWAY
+ MOVEM B,1(D)
+ POPJ P,
+
+IIGLOC: PUSH TP,$TATOM
+ PUSH TP,B
+ PUSHJ P,IGLOC
+ MOVE C,(TP)
+ SUB TP,[2,,2]
+ GETYP 0,A
+ CAIE 0,TUNBOU
+ POPJ P,
+ PUSH TP,$TATOM
+ PUSH TP,C
+ MOVEI 0,(C)
+ MOVE B,C
+ CAIL 0,$TLOSE
+ PUSHJ P,IMPURI ; IMPURIFY THE POOR ATOM
+ PUSHJ P,BSETG ; MAKE A SLOT
+ SETOM 1(B) ; UNBOUNDIFY IT
+ MOVSI A,TLOCD
+ MOVSI 0,TUNBOU
+ MOVEM 0,(B)
+ SUB TP,[2,,2]
+ POPJ P,
+
+\f
+
+;ILVAL RETURNS IN A AND B THE LOCAL VALUE OF THE IDENTIFIER PASSED TO IT IN A AND B
+;IF THE IDENTIFIER IS UNBOUND ITS VALUE IS $TUNBOUND IN A AND 0 IN B. IF
+;IT IS UNASSIGNED ITS VALUE IS $TUNBOUND IN A AND -1 IN B. CALL - PUSHJ P,IVAL
+
+AILVAL:
+ PUSHJ P,AILOC ; USE SUPPLIED SP
+ JRST CHVAL
+ILVAL:
+ PUSHJ P,ILOC ;GET LOCATIVE TO VALUE
+CHVAL: CAMN A,$TUNBOUND ;BOUND
+ POPJ P, ;NO -- RETURN
+ MOVSI A,TLOCD ; GET GOOD TYPE
+ HRR A,2(B) ; SHOULD BE TIME OR 0
+ PUSH P,0
+ PUSHJ P,RMONC0 ; CHECK READ MONITOR
+ POP P,0
+ MOVE A,(B) ;GET THE TYPE OF THE VALUE
+ MOVE B,1(B) ;GET DATUM
+ POPJ P,
+
+;IGVAL -- LIKE ILVAL EXCEPT FOR GLOBAL VALUES
+
+IGVAL: PUSHJ P,IGLOC
+ JRST CHVAL
+
+
+\f
+; COMPILERS INTERFACE TO LVAL/GVAL/SETG/SET
+
+CILVAL: MOVE PVP,PVSTOR+1
+ MOVE 0,BINDID+1(PVP) ; CURRENT BIND
+ HRLI 0,TLOCI
+ CAME 0,(B) ; HURRAY FOR SPEED
+ JRST CILVA1 ; TOO BAD
+ MOVE C,1(B) ; POINTER
+ MOVE A,(C) ; VAL TYPE
+ TLNE A,.RDMON ; MONITORS?
+ JRST CILVA1
+ GETYP 0,A
+ CAIN 0,TUNBOU
+ JRST CUNAS ; COMPILER ERROR
+ MOVE B,1(C) ; GOT VAL
+ MOVE 0,SPCCHK
+ TRNN 0,1
+ POPJ P,
+ HLRZ 0,-2(C) ; SPECIAL CHECK
+ CAIE 0,TUBIND
+ POPJ P, ; RETURN
+ MOVE PVP,PVSTOR+1
+ CAMGE C,CURFCN+1(PVP)
+ JRST CUNAS
+ POPJ P,
+
+CUNAS:
+CILVA1: SUBM M,(P) ; FIX (P)
+ PUSH TP,$TATOM ; SAVE ATOM
+ PUSH TP,B
+ MCALL 1,LVAL ; GET ERROR/MONITOR
+
+POPJM: SUBM M,(P) ; REPAIR DAMAGE
+ POPJ P,
+
+; COMPILERS INTERFACE TO SET C/ ATOM A,B/ NEW VALUE
+
+CISET: MOVE PVP,PVSTOR+1
+ MOVE 0,BINDID+1(PVP) ; CURRENT BINDING ENVIRONMENT
+ HRLI 0,TLOCI
+ CAME 0,(C) ; CAN WE WIN?
+ JRST CISET1 ; NO, MORE HAIR
+ MOVE D,1(C) ; POINT TO SLOT
+CISET3: HLLZ 0,(D) ; MON CHECK
+ TLNE 0,.WRMON
+ JRST CISET4 ; YES, LOSE
+ TLZ 0,TYPMSK
+ IOR A,0 ; LEAVE MONITOR ON
+ MOVE 0,SPCCHK
+ TRNE 0,1
+ JRST CISET5 ; SPEC/UNSPEC CHECK
+CISET6: MOVEM A,(D) ; STORE
+ MOVEM B,1(D)
+ POPJ P,
+
+CISET5: HLRZ 0,-2(D)
+ CAIE 0,TUBIND
+ JRST CISET6
+ MOVE PVP,PVSTOR+1
+ CAMGE D,CURFCN+1(PVP)
+ JRST CISET4
+ JRST CISET6
+
+CISET1: SUBM M,(P) ; FIX ADDR
+ PUSH TP,$TATOM ; SAVE ATOM
+ PUSH TP,C
+ PUSH TP,A
+ PUSH TP,B
+ MOVE B,C ; GET ATOM
+ PUSHJ P,ILOC ; SEARCH
+ MOVE D,B ; POSSIBLE POINTER
+ GETYP E,A
+ MOVE 0,A
+ MOVE A,-1(TP) ; VAL BACK
+ MOVE B,(TP)
+ CAIE E,TUNBOU ; SKIP IF WIN
+ JRST CISET2 ; GO CLOBBER IT IN
+ MCALL 2,SET
+ JRST POPJM
+
+CISET2: MOVE C,-2(TP) ; ATOM BACK
+ SUBM M,(P) ; RESET (P)
+ SUB TP,[4,,4]
+ JRST CISET3
+
+; HERE TO DO A MONITORED SET
+
+CISET4: SUBM M,(P) ; AGAIN FIX (P)
+ PUSH TP,$TATOM
+ PUSH TP,C
+ PUSH TP,A
+ PUSH TP,B
+ MCALL 2,SET
+ JRST POPJM
+
+; COMPILER LLOC
+
+CLLOC: MOVE PVP,PVSTOR+1
+ MOVE 0,BINDID+1(PVP) ; GET CURRENT LOCATIVE
+ HRLI 0,TLOCI
+ CAME 0,(B) ; WIN?
+ JRST CLLOC1
+ MOVE B,1(B)
+ MOVE 0,SPCCHK
+ TRNE 0,1 ; SKIP IF NOT CHECKING
+ JRST CLLOC9
+CLLOC3: MOVSI A,TLOCD
+ HRR A,2(B) ; GET BIND TIME
+ POPJ P,
+
+CLLOC1: SUBM M,(P)
+ PUSH TP,$TATOM
+ PUSH TP,B
+ PUSHJ P,ILOC ; LOOK IT UP
+ JUMPE B,CLLOC2
+ SUB TP,[2,,2]
+CLLOC4: SUBM M,(P)
+ JRST CLLOC3
+
+CLLOC2: MCALL 1,LLOC
+ JRST CLLOC4
+
+CLLOC9: HLRZ 0,-2(B)
+ CAIE 0,TUBIND
+ JRST CLLOC3
+ MOVE PVP,PVSTOR+1
+ CAMGE B,CURFCN+1(PVP)
+ JRST CLLOC2
+ JRST CLLOC3
+
+; COMPILER BOUND?
+
+CBOUND: SUBM M,(P)
+ PUSHJ P,ILOC
+ JUMPE B,PJFALS ; IF UNBOUND RET FALSE AND NO SSKIP
+PJT1: SOS (P)
+ MOVSI A,TATOM
+ MOVE B,IMQUOTE T
+ JRST POPJM
+
+PJFALS: MOVEI B,0
+ MOVSI A,TFALSE
+ JRST POPJM
+
+; COMPILER ASSIGNED?
+
+CASSQ: SUBM M,(P)
+ PUSHJ P,ILOC
+ JUMPE B,PJFALS
+ GETYP 0,(B)
+ CAIE 0,TUNBOU
+ JRST PJT1
+ JRST PJFALS
+\f
+
+; COMPILER GVAL B/ ATOM
+
+CIGVAL: MOVE 0,(B) ; GLOBAL VAL HERE?
+ CAME 0,$TLOCI ; TIME=0 ,TYPE=TLOCI => GLOB VAL
+ JRST CIGVA1 ; NO, GO LOOK
+ MOVE C,1(B) ; POINT TO SLOT
+ MOVE A,(C) ; GET TYPE
+ TLNE A,.RDMON
+ JRST CIGVA1
+ GETYP 0,A ; CHECK FOR UNBOUND
+ CAIN 0,TUNBOU ; SKIP IF WINNER
+ JRST CGUNAS
+ MOVE B,1(C)
+ POPJ P,
+
+CGUNAS:
+CIGVA1: SUBM M,(P)
+ PUSH TP,$TATOM
+ PUSH TP,B
+ .MCALL 1,GVAL ; GET ERROR/MONITOR
+ JRST POPJM
+
+; COMPILER INTERFACET TO SETG
+
+CSETG: MOVE 0,(C) ; GET V CELL
+ CAME 0,$TLOCI ; SKIP IF FAST
+ JRST CSETG1
+ HRRZ D,1(C) ; POINT TO SLOT
+ MOVE 0,(D) ; OLD VAL
+CSETG3: CAIG D,HIBOT ; SKIP IF PURE ATOM
+ TLNE 0,.WRMON ; MONITOR
+ JRST CSETG2
+ MOVEM A,(D)
+ MOVEM B,1(D)
+ POPJ P,
+
+CSETG1: SUBM M,(P) ; FIX UP P
+ PUSH TP,$TATOM
+ PUSH TP,C
+ PUSH TP,A
+ PUSH TP,B
+ MOVE B,C
+ PUSHJ P,IGLOC ; FIND GLOB LOCATIVE
+ GETYP E,A
+ MOVE 0,A
+ MOVEI D,(B) ; SETUP TO RESTORE NEW VAL
+ MOVE A,-1(TP)
+ MOVE B,(TP)
+ CAIE E,TUNBOU
+ JRST CSETG4
+ MCALL 2,SETG
+ JRST POPJM
+
+CSETG4: MOVE C,-2(TP) ; ATOM BACK
+ SUBM M,(P) ; RESET (P)
+ SUB TP,[4,,4]
+ JRST CSETG3
+
+CSETG2: SUBM M,(P)
+ PUSH TP,$TATOM ; CAUSE A SETG MONITOR
+ PUSH TP,C
+ PUSH TP,A
+ PUSH TP,B
+ MCALL 2,SETG
+ JRST POPJM
+
+; COMPILER GLOC
+
+CGLOC: MOVE 0,(B) ; GET CURRENT GUY
+ CAME 0,$TLOCI ; WIN?
+ JRST CGLOC1 ; NOPE
+ HRRZ D,1(B) ; POINT TO SLOT
+ CAILE D,HIBOT ; PURE?
+ JRST CGLOC1
+ MOVE A,$TLOCD
+ MOVE B,1(B)
+ POPJ P,
+
+CGLOC1: SUBM M,(P)
+ PUSH TP,$TATOM
+ PUSH TP,B
+ MCALL 1,GLOC
+ JRST POPJM
+
+; COMPILERS GASSIGNED?
+
+CGASSQ: MOVE 0,(B)
+ SUBM M,(P)
+ CAMN 0,$TLOCD
+ JRST PJT1
+ PUSHJ P,IGLOC
+ JUMPE B,PJFALS
+ GETYP 0,(B)
+ CAIE 0,TUNBOU
+ JRST PJT1
+ JRST PJFALS
+
+; COMPILERS GBOUND?
+
+CGBOUN: MOVE 0,(B)
+ SUBM M,(P)
+ CAMN 0,$TLOCD
+ JRST PJT1
+ PUSHJ P,IGLOC
+ JUMPE B,PJFALS
+ JRST PJT1
+\f
+
+IMFUNCTION REP,FSUBR,[REPEAT]
+ JRST PROG
+MFUNCTION BIND,FSUBR
+ JRST PROG
+IMFUNCTION PROG,FSUBR
+ ENTRY 1
+ GETYP A,(AB) ;GET ARG TYPE
+ CAIE A,TLIST ;IS IT A LIST?
+ JRST WRONGT ;WRONG TYPE
+ SKIPN C,1(AB) ;GET AND CHECK ARGUMENT
+ JRST TFA ;TOO FEW ARGS
+ SETZB E,D ; INIT HEWITT ATOM AND DECL
+ PUSHJ P,CARATC ; IS 1ST THING AN ATOM
+ JFCL
+ PUSHJ P,RSATY1 ; CDR AND GET TYPE
+ CAIE 0,TLIST ; MUST BE LIST
+ JRST MPD.13
+ MOVE B,1(C) ; GET ARG LIST
+ PUSH TP,$TLIST
+ PUSH TP,C
+ PUSHJ P,RSATYP
+ CAIE 0,TDECL
+ JRST NOP.DC ; JUMP IF NO DCL
+ MOVE D,1(C)
+ MOVEM C,(TP)
+ PUSHJ P,RSATYP ; CDR ON
+NOP.DC: PUSH TP,$TLIST
+ PUSH TP,B ; AND ARG LIST
+ PUSHJ P,PRGBND ; BIND AUX VARS
+ HRRZ E,FSAV(TB)
+ CAIE E,BIND
+ SKIPA E,IMQUOTE LPROG,[LPROG ]INTRUP
+ JRST .+3
+ PUSHJ P,MAKACT ; MAKE ACTIVATION
+ PUSHJ P,PSHBND ; BIND AND CHECK
+ PUSHJ P,SPECBI ; NAD BIND IT
+
+; HERE TO RUN PROGS FUNCTIONS ETC.
+
+DOPROG: MOVEI A,REPROG
+ HRLI A,TDCLI ; FLAG AS FUNNY
+ MOVEM A,(TB) ; WHERE TO AGAIN TO
+ MOVE C,1(TB)
+ MOVEM C,3(TB) ; RESTART POINTER
+ JRST .+2 ; START BY SKIPPING DECL
+
+DOPRG1: PUSHJ P,FASTEV
+ HRRZ C,@1(TB) ;GET THE REST OF THE BODY
+DOPRG2: MOVEM C,1(TB)
+ JUMPN C,DOPRG1
+ENDPROG:
+ HRRZ C,FSAV(TB)
+ CAIN C,REP
+REPROG: SKIPN C,@3(TB)
+ JRST PFINIS
+ HRRZM C,1(TB)
+ INTGO
+ MOVE C,1(TB)
+ JRST DOPRG1
+
+
+PFINIS: GETYP 0,(TB)
+ CAIE 0,TDCLI ; DECL'D ?
+ JRST PFINI1
+ HRRZ 0,(TB) ; SEE IF RSUBR
+ JUMPE 0,RSBVCK ; CHECK RSUBR VALUE
+ HRRZ C,3(TB) ; GET START OF FCN
+ GETYP 0,(C) ; CHECK FOR DECL
+ CAIE 0,TDECL
+ JRST PFINI1 ; NO, JUST RETURN
+ MOVE E,IMQUOTE VALUE
+ PUSHJ P,PSHBND ; BUILD FAKE BINDING
+ MOVE C,1(C) ; GET DECL LIST
+ MOVE E,TP
+ PUSHJ P,CHKDCL ; AND CHECK IT
+ MOVE A,-3(TP) ; GET VAL BAKC
+ MOVE B,-2(TP)
+ SUB TP,[6,,6]
+
+PFINI1: HRRZ C,FSAV(TB)
+ CAIE C,EVAL
+ JRST FINIS
+ JRST EFINIS
+
+RSATYP: HRRZ C,(C)
+RSATY1: JUMPE C,TFA
+ GETYP 0,(C)
+ POPJ P,
+
+; HERE TO CHECK RSUBR VALUE
+
+RSBVCK: PUSH TP,A
+ PUSH TP,B
+ MOVE C,A
+ MOVE D,B
+ MOVE A,1(TB) ; GET DECL
+ MOVE B,1(A)
+ HLLZ A,(A)
+ PUSHJ P,TMATCH
+ JRST RSBVC1
+ POP TP,B
+ POP TP,A
+ POPJ P,
+
+RSBVC1: MOVE C,1(TB)
+ POP TP,B
+ POP TP,D
+ MOVE A,IMQUOTE VALUE
+ JRST TYPMIS
+\f
+
+MFUNCTION MRETUR,SUBR,[RETURN]
+ ENTRY
+ HLRE A,AB ; GET # OF ARGS
+ ASH A,-1 ; TO NUMBER
+ AOJL A,RET2 ; 2 OR MORE ARGS
+ PUSHJ P,PROGCH ;CHECK IN A PROG
+ PUSH TP,A
+ PUSH TP,B
+ MOVEI B,-1(TP) ; VERIFY IT
+COMRET: PUSHJ P,CHFSWP
+ SKIPL C ; ARGS?
+ MOVEI C,0 ; REAL NONE
+ PUSHJ P,CHUNW
+ JUMPN A,CHFINI ; WINNER
+ MOVSI A,TATOM
+ MOVE B,IMQUOTE T
+
+; SEE IF MUST CHECK RETURNS TYPE
+
+CHFINI: GETYP 0,(TB) ; SPECIAL TYPE IF SO
+ CAIE 0,TDCLI
+ JRST FINIS ; NO, JUST FINIS
+ MOVEI 0,PFINIS ; CAUSE TO FALL INTO FUNCTION CODE
+ HRRM 0,PCSAV(TB)
+ JRST CONTIN
+
+
+RET2: AOJL A,TMA
+ GETYP A,(AB)+2
+ CAIE A,TACT ; AS FOR "EXIT" SHOULD BE ACTIVATION
+ JRST WTYP2
+ MOVEI B,(AB)+2 ; ADDRESS OF FRAME POINTER
+ JRST COMRET
+
+
+
+MFUNCTION AGAIN,SUBR
+ ENTRY
+ HLRZ A,AB ;GET # OF ARGS
+ CAIN A,-2 ;1 ARG?
+ JRST NLCLA ;YES
+ JUMPN A,TMA ;0 ARGS?
+ PUSHJ P,PROGCH ;CHECK FOR IN A PROG
+ PUSH TP,A
+ PUSH TP,B
+ JRST AGAD
+NLCLA: GETYP A,(AB)
+ CAIE A,TACT
+ JRST WTYP1
+ PUSH TP,(AB)
+ PUSH TP,1(AB)
+AGAD: MOVEI B,-1(TP) ; POINT TO FRAME
+ PUSHJ P,CHFSWP
+ HRRZ C,(B) ; GET RET POINT
+GOJOIN: PUSH TP,$TFIX
+ PUSH TP,C
+ MOVEI C,-1(TP)
+ PUSHJ P,CHUNW ; RESTORE FRAME, UNWIND IF NEC.
+ HRRM B,PCSAV(TB)
+ HRRZ 0,FSAV(TB) ; CHECK FOR RSUBR
+ CAIGE 0,HIBOT
+ CAIGE 0,STOSTR
+ JRST CONTIN
+ HRRZ E,1(TB)
+ PUSH TP,$TFIX
+ PUSH TP,B
+ MOVEI C,-1(TP)
+ MOVEI B,(TB)
+ PUSHJ P,CHUNW1
+ MOVE TP,1(TB)
+ MOVE SP,SPSTOR+1
+ MOVEM SP,SPSAV(TB)
+ MOVEM TP,TPSAV(TB)
+ MOVE C,OTBSAV(TB) ; AND RESTORE P FROM FATHER
+ MOVE P,PSAV(C)
+ MOVEM P,PSAV(TB)
+ SKIPGE PCSAV(TB)
+ HRLI B,400000+M
+ MOVEM B,PCSAV(TB)
+ JRST CONTIN
+
+MFUNCTION GO,SUBR
+ ENTRY 1
+ GETYP A,(AB)
+ CAIE A,TATOM
+ JRST NLCLGO
+ PUSHJ P,PROGCH ;CHECK FOR A PROG
+ PUSH TP,A ;SAVE
+ PUSH TP,B
+ MOVEI B,-1(TP)
+ PUSHJ P,CHFSWP
+ PUSH TP,$TATOM
+ PUSH TP,1(C)
+ PUSH TP,2(B)
+ PUSH TP,3(B)
+ MCALL 2,MEMQ ;DOES IT HAVE THIS TAG?
+ JUMPE B,NXTAG ;NO -- ERROR
+FNDGO: EXCH B,(TP) ;SAVE PLACE TO GO
+ MOVSI D,TLIST
+ MOVEM D,-1(TP)
+ JRST GODON
+
+NLCLGO: CAIE A,TTAG ;CHECK TYPE
+ JRST WTYP1
+ MOVE B,1(AB)
+ MOVEI B,2(B) ; POINT TO SLOT
+ PUSHJ P,CHFSWP
+ MOVE A,1(C)
+ GETYP 0,(A) ; SEE IF COMPILED
+ CAIE 0,TFIX
+ JRST GODON1
+ MOVE C,1(A)
+ JRST GOJOIN
+
+GODON1: PUSH TP,(A) ;SAVE BODY
+ PUSH TP,1(A)
+GODON: MOVEI C,0
+ PUSHJ P,CHUNW ;GO BACK TO CORRECT FRAME
+ MOVE B,(TP) ;RESTORE ITERATION MARKER
+ MOVEM B,1(TB)
+ MOVSI A,TATOM
+ MOVE B,1(B)
+ JRST CONTIN
+
+\f
+
+
+MFUNCTION TAG,SUBR
+ ENTRY
+ JUMPGE AB,TFA
+ HLRZ 0,AB
+ GETYP A,(AB) ;GET TYPE OF ARGUMENT
+ CAIE A,TFIX ; FIX ==> COMPILED
+ JRST ATOTAG
+ CAIE 0,-4
+ JRST WNA
+ GETYP A,2(AB)
+ CAIE A,TACT
+ JRST WTYP2
+ PUSH TP,(AB)
+ PUSH TP,1(AB)
+ PUSH TP,2(AB)
+ PUSH TP,3(AB)
+ JRST GENTV
+ATOTAG: CAIE A,TATOM ;CHECK THAT IT IS AN ATOM
+ JRST WTYP1
+ CAIE 0,-2
+ JRST TMA
+ PUSHJ P,PROGCH ;CHECK PROG
+ PUSH TP,A ;SAVE VAL
+ PUSH TP,B
+ PUSH TP,$TATOM
+ PUSH TP,1(AB)
+ PUSH TP,2(B)
+ PUSH TP,3(B)
+ MCALL 2,MEMQ
+ JUMPE B,NXTAG ;IF NOT FOUND -- ERROR
+ EXCH A,-1(TP) ;SAVE PLACE
+ EXCH B,(TP)
+ HRLI A,TFRAME
+ PUSH TP,A
+ PUSH TP,B
+GENTV: MOVEI A,2
+ PUSHJ P,IEVECT
+ MOVSI A,TTAG
+ JRST FINIS
+
+PROGCH: MOVE B,IMQUOTE LPROG,[LPROG ]INTRUP
+ PUSHJ P,ILVAL ;GET VALUE
+ GETYP 0,A
+ CAIE 0,TACT
+ JRST NXPRG
+ POPJ P,
+
+; HERE TO UNASSIGN LPROG IF NEC
+
+UNPROG: MOVE B,IMQUOTE LPROG,[LPROG ]INTRUP
+ PUSHJ P,ILVAL
+ GETYP 0,A
+ CAIE 0,TACT ; SKIP IF MUST UNBIND
+ JRST UNMAP
+ MOVSI A,TUNBOU
+ MOVNI B,1
+ MOVE E,IMQUOTE LPROG,[LPROG ]INTRUP
+ PUSHJ P,PSHBND
+UNMAP: HRRZ 0,FSAV(TB) ; CHECK FOR FUNNY
+ CAIN 0,MAPPLY ; SKIP IF NOT
+ POPJ P,
+ MOVE B,IMQUOTE LMAP,[LMAP ]INTRUP
+ PUSHJ P,ILVAL
+ GETYP 0,A
+ CAIE 0,TFRAME
+ JRST UNSPEC
+ MOVSI A,TUNBOU
+ MOVNI B,1
+ MOVE E,IMQUOTE LMAP,[LMAP ]INTRUP
+ PUSHJ P,PSHBND
+UNSPEC: PUSH TP,BNDV
+ MOVE B,PVSTOR+1
+ ADD B,[CURFCN,,CURFCN]
+ PUSH TP,B
+ PUSH TP,$TSP
+ MOVE E,SPSTOR+1
+ ADD E,[3,,3]
+ PUSH TP,E
+ POPJ P,
+
+REPEAT 0,[
+MFUNCTION MEXIT,SUBR,[EXIT]
+ ENTRY 2
+ GETYP A,(AB)
+ CAIE A,TACT
+ JRST WTYP1
+ MOVEI B,(AB)
+ PUSHJ P,CHFSWP
+ ADD C,[2,,2]
+ PUSHJ P,CHUNW ;RESTORE FRAME
+ JRST CHFINI ; CHECK FOR WINNING VALUE
+]
+
+MFUNCTION COND,FSUBR
+ ENTRY 1
+ GETYP A,(AB)
+ CAIE A,TLIST
+ JRST WRONGT
+ PUSH TP,(AB)
+ PUSH TP,1(AB) ;CREATE UNNAMED TEMP
+ MOVEI B,0 ; SET TO FALSE IN CASE
+
+CLSLUP: SKIPN C,1(TB) ;IS THE CLAUSELIST NIL?
+ JRST IFALS1 ;YES -- RETURN NIL
+ GETYP A,(C) ;NO -- GET TYPE OF CAR
+ CAIE A,TLIST ;IS IT A LIST?
+ JRST BADCLS ;
+ MOVE A,1(C) ;YES -- GET CLAUSE
+ JUMPE A,BADCLS
+ GETYPF B,(A)
+ PUSH TP,B ; EVALUATION OF
+ HLLZS (TP)
+ PUSH TP,1(A) ;THE PREDICATE
+ JSP E,CHKARG
+ MCALL 1,EVAL
+ GETYP 0,A
+ CAIN 0,TFALSE
+ JRST NXTCLS ;FALSE TRY NEXT CLAUSE
+ MOVE C,1(TB) ;IF NOT, DO FIRST CLAUSE
+ MOVE C,1(C)
+ HRRZ C,(C)
+ JUMPE C,FINIS ;(UNLESS DONE WITH IT)
+ JRST DOPRG2 ;AS THOUGH IT WERE A PROG
+NXTCLS: HRRZ C,@1(TB) ;SET THE CLAUSLIST
+ HRRZM C,1(TB) ;TO CDR OF THE CLAUSLIST
+ JRST CLSLUP
+
+IFALSE:
+ MOVEI B,0
+IFALS1: MOVSI A,TFALSE ;RETURN FALSE
+ JRST FINIS
+
+
+\f
+MFUNCTION UNWIND,FSUBR
+
+ ENTRY 1
+
+ GETYP 0,(AB) ; CHECK THE ARGS FOR WINNAGE
+ SKIPN A,1(AB) ; NONE?
+ JRST TFA
+ HRRZ B,(A) ; CHECK FOR 2D
+ JUMPE B,TFA
+ HRRZ 0,(B) ; 3D?
+ JUMPN 0,TMA
+
+; Unbind LPROG and LMAPF so that nothing cute happens
+
+ PUSHJ P,UNPROG
+
+; Push thing to do upon UNWINDing
+
+ PUSH TP,$TLIST
+ PUSH TP,[0]
+
+ MOVEI C,UNWIN1
+ PUSHJ P,IUNWIN ; GOT TO INTERNAL SET UP
+
+; Now EVAL the first form
+
+ MOVE A,1(AB)
+ HRRZ 0,(A) ; SAVE POINTER TO OTHER GUY
+ MOVEM 0,-12(TP)
+ MOVE B,1(A)
+ GETYP A,(A)
+ MOVSI A,(A)
+ JSP E,CHKAB ; DEFER?
+ PUSH TP,A
+ PUSH TP,B
+ MCALL 1,EVAL ; EVAL THE LOSER
+
+ JRST FINIS
+
+; Now push slots to hold undo info on the way down
+
+IUNWIN: JUMPE M,NOUNRE
+ HLRE 0,M ; CHECK BOUNDS
+ SUBM M,0
+ ANDI 0,-1
+ CAIL C,(M)
+ CAML C,0
+ JRST .+2
+ SUBI C,(M)
+
+NOUNRE: PUSH TP,$TTB ; DESTINATION FRAME
+ PUSH TP,[0]
+ PUSH TP,[0] ; ARGS TO WHOEVER IS DOING IT
+ PUSH TP,[0]
+
+; Now bind UNWIND word
+
+ PUSH TP,$TUNWIN ; FIRST WORD OF IT
+ MOVE SP,SPSTOR+1
+ HRRM SP,(TP) ; CHAIN
+ MOVEM TP,SPSTOR+1
+ PUSH TP,TB ; AND POINT TO HERE
+ PUSH TP,$TTP
+ PUSH TP,[0]
+ HRLI C,TPDL
+ PUSH TP,C
+ PUSH TP,P ; SAVE PDL ALSO
+ MOVEM TP,-2(TP) ; SAVE FOR LATER
+ POPJ P,
+
+; Do a non-local return with UNWIND checking
+
+CHUNW: HRRZ E,SPSAV(B) ; GET DESTINATION FRAME
+CHUNW1: PUSH TP,(C) ; FINAL VAL
+ PUSH TP,1(C)
+ JUMPN C,.+3 ; WAS THERE REALLY ANYTHING
+ SETZM (TP)
+ SETZM -1(TP)
+ PUSHJ P,STLOOP ; UNBIND
+CHUNPC: SKIPA ; WILL NOT SKIP UNLESS UNWIND FOUND
+ JRST GOTUND
+ MOVEI A,(TP)
+ SUBI A,(SP)
+ MOVSI A,(A)
+ HLL SP,TP
+ SUB SP,A
+ MOVEM SP,SPSTOR+1
+ HRRI TB,(B) ; UPDATE TB
+ PUSHJ P,UNWFRMS
+ POP TP,B
+ POP TP,A
+ POPJ P,
+
+POPUNW: MOVE SP,SPSTOR+1
+ HRRZ SP,(SP)
+ MOVEI E,(TP)
+ SUBI E,(SP)
+ MOVSI E,(E)
+ HLL SP,TP
+ SUB SP,E
+ MOVEM SP,SPSTOR+1
+ POPJ P,
+
+
+UNWFRM: JUMPE FRM,CPOPJ
+ MOVE B,FRM
+UNWFR2: JUMPE B,UNWFR1
+ CAMG B,TPSAV(TB)
+ JRST UNWFR1
+ MOVE B,(B)
+ JRST UNWFR2
+
+UNWFR1: MOVE FRM,B
+ POPJ P,
+
+; Here if an UNDO found
+
+GOTUND: MOVE TB,1(SP) ; GET FRAME OF UNDO
+ MOVE A,-1(TP) ; GET FUNNY ARG FOR PASS ON
+ MOVE C,(TP)
+ MOVE TP,3(SP) ; GET FUTURE TP
+ MOVEM C,-6(TP) ; SAVE ARG
+ MOVEM A,-7(TP)
+ MOVE C,(TP) ; SAVED P
+ SUB C,[1,,1]
+ MOVEM C,PSAV(TB) ; MAKE CONTIN WIN
+ MOVEM TP,TPSAV(TB)
+ MOVEM SP,SPSAV(TB)
+ HRRZ C,(P) ; PC OF CHUNW CALLER
+ HRRM C,-11(TP) ; SAVE ALSO AND GET WHERE TO GO PC
+ MOVEM B,-10(TP) ; AND DESTINATION FRAME
+ HRRZ C,-1(TP) ; WHERE TO UNWIND PC
+ HRRZ 0,FSAV(TB) ; RSUBR?
+ CAIGE 0,HIBOT
+ CAIGE 0,STOSTR
+ JRST .+3
+ SKIPGE PCSAV(TB)
+ HRLI C,400000+M
+ MOVEM C,PCSAV(TB)
+ JRST CONTIN
+
+UNWIN1: MOVE B,-12(TP) ; POINT TO THING TO DO UNWINDING
+ GETYP A,(B)
+ MOVSI A,(A)
+ MOVE B,1(B)
+ JSP E,CHKAB
+ PUSH TP,A
+ PUSH TP,B
+ MCALL 1,EVAL
+UNWIN2: MOVEI C,-7(TP) ; POINT TO SAVED RET VALS
+ MOVE B,-10(TP)
+ HRRZ E,-11(TP)
+ PUSH P,E
+ MOVE SP,SPSTOR+1
+ HRRZ SP,(SP) ; UNBIND THIS GUY
+ MOVEI E,(TP) ; AND FIXUP SP
+ SUBI E,(SP)
+ MOVSI E,(E)
+ HLL SP,TP
+ SUB SP,E
+ MOVEM SP,SPSTOR+1
+ JRST CHUNW ; ANY MORE TO UNWIND?
+
+\f
+; CHFSWP - CHECK FRAMES VALIDITY AND SWAP PROCESS IF NECESSARY.
+; CALLED BY ALL CONTROL FLOW
+; ROUTINES (GO,RETURN,EXIT,AGAIN,ERRET...)
+
+CHFSWP: PUSHJ P,CHFRM ; CHECK FOR VALID FRAME
+ HRRZ D,(B) ; PROCESS VECTOR DOPE WD
+ HLRZ C,(D) ; LENGTH
+ SUBI D,-1(C) ; POINT TO TOP
+ MOVNS C ; NEGATE COUNT
+ HRLI D,2(C) ; BUILD PVP
+ MOVE E,PVSTOR+1
+ MOVE C,AB
+ MOVE A,(B) ; GET FRAME
+ MOVE B,1(B)
+ CAMN E,D ; SKIP IF SWAP NEEDED
+ POPJ P,
+ PUSH TP,A ; SAVE FRAME
+ PUSH TP,B
+ MOVE B,D
+ PUSHJ P,PROCHK ; FIX UP PROCESS LISTS
+ MOVE A,PSTAT+1(B) ; GET STATE
+ CAIE A,RESMBL
+ JRST NOTRES
+ MOVE D,B ; PREPARE TO SWAP
+ POP P,0 ; RET ADDR
+ POP TP,B
+ POP TP,A
+ JSP C,SWAP ; SWAP IN
+ MOVE C,ABSTO+1(E) ; GET OLD ARRGS
+ MOVEI A,RUNING ; FIX STATES
+ MOVE PVP,PVSTOR+1
+ MOVEM A,PSTAT+1(PVP)
+ MOVEI A,RESMBL
+ MOVEM A,PSTAT+1(E)
+ JRST @0
+
+NOTRES: ERRUUO EQUOTE PROCESS-NOT-RESUMABLE
+\f
+
+;SETG IS USED TO SET THE GLOBAL VALUE OF ITS FIRST ARGUMENT,
+;AN IDENTIFIER, TO THE VALUE OF ITS SECOND ARGUMENT. ITS VALUE IS
+; ITS SECOND ARGUMENT.
+
+IMFUNCTION SETG,SUBR
+ ENTRY 2
+ GETYP A,(AB) ;GET TYPE OF FIRST ARGUMENT
+ CAIE A,TATOM ;CHECK THAT IT IS AN ATOM
+ JRST NONATM ;IF NOT -- ERROR
+ MOVE B,1(AB) ;GET POINTER TO ATOM
+ PUSH TP,$TATOM
+ PUSH TP,B
+ MOVEI 0,(B)
+ CAIL 0,HIBOT ; PURE ATOM?
+ PUSHJ P,IMPURIFY ; YES IMPURIFY
+ PUSHJ P,IGLOC ;GET LOCATIVE TO VALUE
+ CAME A,$TUNBOUND ;IF BOUND
+ JRST GOOST1
+ SKIPN NOSETG ; ALLOWED?
+ JRST GOOSTG ; YES
+ PUSH TP,$TATOM
+ PUSH TP,EQUOTE CREATING-NEW-GVAL
+ PUSH TP,$TATOM
+ PUSH TP,1(AB)
+ PUSH TP,$TATOM
+ PUSH TP,EQUOTE NON-FALSE-TO-ALLOW
+ MCALL 3,ERROR
+ GETYP 0,A
+ CAIN 0,TFALSE
+ JRST FINIS
+GOOSTG: PUSHJ P,BSETG ;IF NOT -- BIND IT
+GOOST1: MOVE C,2(AB) ; GET PROPOSED VVAL
+ MOVE D,3(AB)
+ MOVSI A,TLOCD ; MAKE SURE MONCH WINS
+ PUSHJ P,MONCH0 ; WOULD YOU BELIEVE MONITORS!!!!
+ EXCH D,B ;SAVE PTR
+ MOVE A,C
+ HRRZ E,-2(D) ; POINT TO POSSIBLE GDECL (OR MAINIFEST)
+ JUMPE E,OKSETG ; NONE ,OK
+ CAIE E,-1 ; MANIFEST?
+ JRST SETGTY
+ GETYP 0,(D) ; IF UNBOUND, LET IT HAPPEN
+ SKIPN IGDECL
+ CAIN 0,TUNBOU
+ JRST OKSETG
+MANILO: GETYP C,(D)
+ GETYP 0,2(AB)
+ CAIN 0,(C)
+ CAME B,1(D)
+ JRST .+2
+ JRST OKSETG
+ PUSH TP,$TVEC
+ PUSH TP,D
+ MOVE B,IMQUOTE REDEFINE
+ PUSHJ P,ILVAL ; SEE IF REDEFINE OK
+ GETYP A,A
+ CAIE A,TUNBOU
+ CAIN A,TFALSE
+ JRST .+2
+ JRST OKSTG
+ PUSH TP,$TATOM
+ PUSH TP,EQUOTE ATTEMPT-TO-CHANGE-MANIFEST-VARIABLE
+ PUSH TP,$TATOM
+ PUSH TP,1(AB)
+ MOVEI A,2
+ JRST CALER
+
+SETGTY: PUSH TP,$TVEC
+ PUSH TP,D
+ MOVE C,A
+ MOVE D,B
+ GETYP A,(E)
+ MOVSI A,(A)
+ MOVE B,1(E)
+ JSP E,CHKAB
+ PUSHJ P,TMATCH
+ JRST TYPMI3
+
+OKSTG: MOVE D,(TP)
+ MOVE A,2(AB)
+ MOVE B,3(AB)
+
+OKSETG: MOVEM A,(D) ;DEPOSIT INTO THE
+ MOVEM B,1(D) ;INDICATED VALUE CELL
+ JRST FINIS
+
+TYPMI3: MOVE C,(TP)
+ HRRZ C,-2(C)
+ MOVE D,2(AB)
+ MOVE B,3(AB)
+ MOVE 0,(AB)
+ MOVE A,1(AB)
+ JRST TYPMIS
+
+BSETG: HRRZ A,GLOBASE+1
+ HRRZ B,GLOBSP+1
+ SUB B,A
+ CAIL B,6
+ JRST SETGIT
+ MOVEI B,0 ; MAKE SURE OF NO EMPTY SLOTS
+ PUSHJ P,IGLOC
+ CAMN A,$TUNBOU ; SKIP IF SLOT FOUND
+ JRST BSETG1
+ MOVE C,(TP) ; GET ATOM
+ MOVEM C,-1(B) ; CLOBBER ATOM SLOT
+ HLLZS -2(B) ; CLOBBER OLD DECL
+ JRST BSETGX
+; BSETG1: PUSH TP,GLOBASE ; MUST REALLY GROW STACK
+; PUSH TP,GLOBASE+1
+; PUSH TP,$TFIX
+; PUSH TP,[0]
+; PUSH TP,$TFIX
+; PUSH TP,[100]
+; MCALL 3,GROW
+BSETG1: PUSH P,0
+ PUSH P,C
+ MOVE C,GLOBASE+1
+ HLRE B,C
+ SUB C,B
+ MOVE B,GVLINC ; GROW BY INDICATED GVAL SLOTS
+ DPB B,[001100,,(C)]
+; MOVEM A,GLOBASE
+ MOVE C,[6,,4] ; INDICATOR FOR AGC
+ PUSHJ P,AGC
+ MOVE B,GLOBASE+1
+ MOVE 0,GVLINC ; ADJUST GLOBAL SPBASE
+ ASH 0,6
+ SUB B,0
+ HRLZS 0
+ SUB B,0
+ MOVEM B,GLOBASE+1
+; MOVEM B,GLOBASE+1
+ POP P,0
+ POP P,C
+SETGIT:
+ MOVE B,GLOBSP+1
+ SUB B,[4,,4]
+ MOVSI C,TGATOM
+ MOVEM C,(B)
+ MOVE C,(TP)
+ MOVEM C,1(B)
+ MOVEM B,GLOBSP+1
+ ADD B,[2,,2]
+BSETGX: MOVSI A,TLOCI
+ PUSHJ P,PATSCH ; FIXUP SCHLPAGE
+ MOVEM A,(C)
+ MOVEM B,1(C)
+ POPJ P,
+
+PATSCH: GETYP 0,(C)
+ CAIN 0,TLOCI
+ SKIPL D,1(C)
+ POPJ P,
+
+PATL: SKIPL E,3(D) ; SKIP IF NEXT EXISTS
+ JRST PATL1
+ MOVE D,E
+ JRST PATL
+
+PATL1: MOVEI E,1
+ MOVEM E,3(D) ; SAY GVAL ETC. EXISTS IF WE UNBIND
+ POPJ P,
+
+
+IMFUNCTION DEFMAC,FSUBR
+
+ ENTRY 1
+
+ PUSH P,.
+ JRST DFNE2
+
+IMFUNCTION DFNE,FSUBR,[DEFINE]
+
+ ENTRY 1
+
+ PUSH P,[0]
+DFNE2: GETYP A,(AB)
+ CAIE A,TLIST
+ JRST WRONGT
+ SKIPN B,1(AB) ; GET ATOM
+ JRST TFA
+ GETYP A,(B) ; MAKE SURE ATOM
+ MOVSI A,(A)
+ PUSH TP,A
+ PUSH TP,1(B)
+ JSP E,CHKARG
+ MCALL 1,EVAL ; EVAL IT TO AN ATOM
+ CAME A,$TATOM
+ JRST NONATM
+ PUSH TP,A ; SAVE TWO COPIES
+ PUSH TP,B
+ PUSHJ P,IGVAL ; SEE IF A VALUE EXISTS
+ CAMN A,$TUNBOU ; SKIP IF A WINNER
+ JRST .+3
+ PUSHJ P,ASKUSR ; CHECK WITH USER
+ JRST DFNE1
+ PUSH TP,$TATOM
+ PUSH TP,-1(TP)
+ MOVE B,1(AB)
+ HRRZ B,(B)
+ MOVSI A,TEXPR
+ SKIPN (P) ; SKIP IF MACRO
+ JRST DFNE3
+ MOVEI D,(B) ; READY TO CONS
+ MOVSI C,TEXPR
+ PUSHJ P,INCONS
+ MOVSI A,TMACRO
+DFNE3: PUSH TP,A
+ PUSH TP,B
+ MCALL 2,SETG
+DFNE1: POP TP,B ; RETURN ATOM
+ POP TP,A
+ JRST FINIS
+
+
+ASKUSR: MOVE B,IMQUOTE REDEFINE
+ PUSHJ P,ILVAL ; SEE IF REDEFINE OK
+ GETYP A,A
+ CAIE A,TUNBOU
+ CAIN A,TFALSE
+ JRST ASKUS1
+ JRST ASKUS2
+ASKUS1: PUSH TP,$TATOM
+ PUSH TP,-1(TP)
+ PUSH TP,$TATOM
+ PUSH TP,EQUOTE ALREADY-DEFINED-ERRET-NON-FALSE-TO-REDEFINE
+ MCALL 2,ERROR
+ GETYP 0,A
+ CAIE 0,TFALSE
+ASKUS2: AOS (P)
+ MOVE B,1(AB)
+ POPJ P,
+\f
+
+
+;SET CLOBBERS THE LOCAL VALUE OF THE IDENTIFIER GIVEN BY ITS
+;FIRST ARGUMENT TO THE SECOND ARG. ITS VALUE IS ITS SECOND ARGUMENT.
+
+IMFUNCTION SET,SUBR
+ HLRE D,AB ; 2 TIMES # OF ARGS TO D
+ ASH D,-1 ; - # OF ARGS
+ ADDI D,2
+ JUMPG D,TFA ; NOT ENOUGH
+ MOVE B,PVSTOR+1
+ MOVE C,SPSTOR+1
+ JUMPE D,SET1 ; NO ENVIRONMENT
+ AOJL D,TMA ; TOO MANY
+ GETYP A,4(AB) ; CHECK ARG IS A FRAME OR PROCESS
+ CAIE A,TFRAME
+ CAIN A,TENV
+ JRST SET2 ; WINNING ENVIRONMENT/FRAME
+ CAIN A,TACT
+ JRST SET2 ; TO MAKE PFISTER HAPPY
+ CAIE A,TPVP
+ JRST WTYP2
+ MOVE B,5(AB) ; GET PROCESS
+ MOVE C,SPSTO+1(B)
+ JRST SET1
+SET2: MOVEI B,4(AB) ; POINT TO FRAME
+ PUSHJ P,CHFRM ; CHECK IT OUT
+ MOVE B,5(AB) ; GET IT BACK
+ MOVE C,SPSAV(B) ; GET BINDING POINTER
+ HRRZ B,4(AB) ; POINT TO PROCESS
+ HLRZ A,(B) ; GET LENGTH
+ SUBI B,-1(A) ; POINT TO START THEREOF
+ HLL B,PVSTOR+1 ; GET -LNTRH, (ALL PROCESS VECS SAME LENGTH)
+SET1: PUSH TP,$TPVP ; SAVE PROCESS
+ PUSH TP,B
+ PUSH TP,$TSP ; SAVE PATH POINTER
+ PUSH TP,C
+ GETYP A,(AB) ;GET TYPE OF FIRST
+ CAIE A,TATOM ;ARGUMENT --
+ JRST WTYP1 ;BETTER BE AN ATOM
+ MOVE B,1(AB) ;GET PTR TO IT
+ MOVEI 0,(B)
+ CAIL 0,HIBOT
+ PUSHJ P,IMPURIFY
+ MOVE C,(TP)
+ PUSHJ P,AILOC ;GET LOCATIVE TO VALUE
+GOTLOC: CAME A,$TUNBOUND ;IF BOUND
+ JRST GOOSE1
+ SKIPN NOSET ; ALLOWED?
+ JRST GOOSET ; YES
+ PUSH TP,$TATOM
+ PUSH TP,EQUOTE CREATING-NEW-LVAL
+ PUSH TP,$TATOM
+ PUSH TP,1(AB)
+ PUSH TP,$TATOM
+ PUSH TP,EQUOTE NON-FALSE-TO-ALLOW
+ MCALL 3,ERROR
+ GETYP 0,A
+ CAIN 0,TFALSE
+ JRST FINIS
+GOOSET: PUSHJ P,BSET ;IF NOT -- BIND IT
+GOOSE1: MOVE C,2(AB) ; GET PROPOSED VVAL
+ MOVE C,2(AB) ; GET NEW VAL
+ MOVE D,3(AB)
+ MOVSI A,TLOCD ; FOR MONCH
+ HRR A,2(B)
+ PUSHJ P,MONCH0 ; HURRAY FOR MONITORS!!!!!
+ MOVE E,B
+ HLRZ A,2(E) ; GET DECLS
+ JUMPE A,SET3 ; NONE, GO
+ PUSH TP,$TSP
+ PUSH TP,E
+ MOVE B,1(A)
+ HLLZ A,(A) ; GET PATTERN
+ PUSHJ P,TMATCH ; MATCH TMEM
+ JRST TYPMI2 ; LOSES
+ MOVE E,(TP)
+ SUB TP,[2,,2]
+ MOVE C,2(AB)
+ MOVE D,3(AB)
+SET3: MOVEM C,(E) ;CLOBBER IDENTIFIER
+ MOVEM D,1(E)
+ MOVE A,C
+ MOVE B,D
+ MOVE C,-2(TP) ; GET PROC
+ HRRZ C,BINDID+1(C)
+ HRLI C,TLOCI
+
+; HERE WE NOTE THAT EFFICIENCY CAN SOMETIMES GET IN THE WAY OF CORRECTNESS
+; BY SETTING THE SHALLOW BINDING WE MANAGE TO CLOBBER THE TOP LEVEL LVAL
+; EVEN IF WE ARE SETTING WITH RESPECT TO A DIFFERENT FRAME. TO CORRECT
+; THIS GLITCH THIS ACTIVITY WILL ONLY TAKE PLACE IF THE ATOM ALREADY POINTS
+; TO A BINDING
+
+ MOVE D,1(AB)
+ SKIPE (D)
+ JRST NSHALL
+ MOVEM C,(D)
+ MOVEM E,1(D)
+NSHALL: SUB TP,[4,,4]
+ JRST FINIS
+BSET:
+ MOVE PVP,PVSTOR+1
+ CAMN PVP,-2(TP) ; SKIP IF PROC DIFFERS
+ MOVEM C,-2(TP) ; ELSE USE RESULT FROM LOC SEARCH
+ MOVE B,-2(TP) ; GET PROCESS
+ HRRZ A,TPBASE+1(B) ;GET ACTUAL STACK BASE
+ HRRZ B,SPBASE+1(B) ;AND FIRST BINDING
+ SUB B,A ;ARE THERE 6
+ CAIL B,6 ;CELLS AVAILABLE?
+ JRST SETIT ;YES
+ MOVE C,(TP) ; GET POINTER BACK
+ MOVEI B,0 ; LOOK FOR EMPTY SLOT
+ PUSHJ P,AILOC
+ CAMN A,$TUNBOUND ; SKIP IF FOUND
+ JRST BSET1
+ MOVE E,1(AB) ; GET ATOM
+ MOVEM E,-1(B) ; AND STORE
+ JRST BSET2
+BSET1: MOVE B,-2(TP) ; GET PROCESS
+; PUSH TP,TPBASE(B) ;NO -- GROW THE TP
+; PUSH TP,TPBASE+1(B) ;AT THE BASE END
+; PUSH TP,$TFIX
+; PUSH TP,[0]
+; PUSH TP,$TFIX
+; PUSH TP,[100]
+; MCALL 3,GROW
+; MOVE C,-2(TP) ; GET PROCESS
+; MOVEM A,TPBASE(C) ;SAVE RESULT
+ PUSH P,0 ; MANUALLY GROW VECTOR
+ PUSH P,C
+ MOVE C,TPBASE+1(B)
+ HLRE B,C
+ SUB C,B
+ MOVEI C,1(C)
+ CAME C,TPGROW
+ ADDI C,PDLBUF
+ MOVE D,LVLINC
+ DPB D,[001100,,-1(C)]
+ MOVE C,[5,,3] ; SET UP INDICATORS FOR AGC
+ PUSHJ P,AGC
+ MOVE PVP,PVSTOR+1
+ MOVE B,TPBASE+1(PVP) ; MODIFY POINTER
+ MOVE 0,LVLINC ; ADJUST SPBASE POINTER
+ ASH 0,6
+ SUB B,0
+ HRLZS 0
+ SUB B,0
+ MOVEM B,TPBASE+1(PVP)
+ POP P,C
+ POP P,0
+; MOVEM B,TPBASE+1(C)
+SETIT: MOVE C,-2(TP) ; GET PROCESS
+ MOVE B,SPBASE+1(C)
+ MOVEI A,-6(B) ;MAKE UP BINDING
+ HRRM A,(B) ;LINK PREVIOUS BIND BLOCK
+ MOVSI A,TBIND
+ MOVEM A,-6(B)
+ MOVE A,1(AB)
+ MOVEM A,-5(B)
+ SUB B,[6,,6]
+ MOVEM B,SPBASE+1(C)
+ ADD B,[2,,2]
+BSET2: MOVE C,-2(TP) ; GET PROC
+ MOVSI A,TLOCI
+ HRR A,BINDID+1(C)
+ HLRZ D,OTBSAV(TB) ; TIME IT
+ MOVEM D,2(B) ; AND FIX IT
+ POPJ P,
+
+; HERE TO ELABORATE ON TYPE MISMATCH
+
+TYPMI2: MOVE C,(TP) ; FIND DECLS
+ HLRZ C,2(C)
+ MOVE D,2(AB)
+ MOVE B,3(AB)
+ MOVE 0,(AB) ; GET ATOM
+ MOVE A,1(AB)
+ JRST TYPMIS
+
+\f
+
+MFUNCTION NOT,SUBR
+ ENTRY 1
+ GETYP A,(AB) ; GET TYPE
+ CAIE A,TFALSE ;IS IT FALSE?
+ JRST IFALSE ;NO -- RETURN FALSE
+
+TRUTH:
+ MOVSI A,TATOM ;RETURN T (VERITAS)
+ MOVE B,IMQUOTE T
+ JRST FINIS
+
+IMFUNCTION OR,FSUBR
+
+ PUSH P,[0]
+ JRST ANDOR
+
+MFUNCTION ANDA,FSUBR,AND
+
+ PUSH P,[1]
+ANDOR: ENTRY 1
+ GETYP A,(AB)
+ CAIE A,TLIST
+ JRST WRONGT ;IF ARG DOESN'T CHECK OUT
+ MOVE E,(P)
+ SKIPN C,1(AB) ;IF NIL
+ JRST TF(E) ;RETURN TRUTH
+ PUSH TP,$TLIST ;CREATE UNNAMED TEMP
+ PUSH TP,C
+ANDLP:
+ MOVE E,(P)
+ JUMPE C,TFI(E) ;ANY MORE ARGS?
+ MOVEM C,1(TB) ;STORE CRUFT
+ GETYP A,(C)
+ MOVSI A,(A)
+ PUSH TP,A
+ PUSH TP,1(C) ;ARGUMENT
+ JSP E,CHKARG
+ MCALL 1,EVAL
+ GETYP 0,A
+ MOVE E,(P)
+ XCT TFSKP(E)
+ JRST FINIS ;IF FALSE -- RETURN
+ HRRZ C,@1(TB) ;GET CDR OF ARGLIST
+ JRST ANDLP
+
+TF: JRST IFALSE
+ JRST TRUTH
+
+TFI: JRST IFALS1
+ JRST FINIS
+
+TFSKP: CAIE 0,TFALSE
+ CAIN 0,TFALSE
+
+IMFUNCTION FUNCTION,FSUBR
+
+ ENTRY 1
+
+ MOVSI A,TEXPR
+ MOVE B,1(AB)
+ JRST FINIS
+
+\f;SUBR VERSIONS OF AND/OR
+
+MFUNCTION ANDP,SUBR,[AND?]
+ JUMPGE AB,TRUTH
+ MOVE C,[CAIN 0,TFALSE]
+ JRST BOOL
+
+MFUNCTION ORP,SUBR,[OR?]
+ JUMPGE AB,IFALSE
+ MOVE C,[CAIE 0,TFALSE]
+BOOL: HLRE A,AB ; GET ARG COUNTER
+ MOVMS A
+ ASH A,-1 ; DIVIDES BY 2
+ MOVE D,AB
+ PUSHJ P,CBOOL
+ JRST FINIS
+
+CANDP: SKIPA C,[CAIN 0,TFALSE]
+CORP: MOVE C,[CAIE 0,TFALSE]
+ JUMPE A,CNOARG
+ MOVEI D,(A)
+ ASH D,1 ; TIMES 2
+ HRLI D,(D)
+ SUBB TP,D ; POINT TO ARGS & FIXUP TP PTR
+ AOBJP D,.+1 ; FIXUP ARG PTR AND FALL INTO CBOOL
+
+CBOOL: GETYP 0,(D)
+ XCT C ; WINNER ?
+ JRST CBOOL1 ; YES RETURN IT
+ ADD D,[2,,2]
+ SOJG A,CBOOL ; ANY MORE ?
+ SUB D,[2,,2] ; NO, USE LAST
+CBOOL1: MOVE A,(D)
+ MOVE B,(D)+1
+ POPJ P,
+
+
+CNOARG: MOVSI 0,TFALSE
+ XCT C
+ JRST CNOAND
+ MOVSI A,TFALSE
+ MOVEI B,0
+ POPJ P,
+CNOAND: MOVSI A,TATOM
+ MOVE B,IMQUOTE T
+ POPJ P,
+\f
+
+MFUNCTION CLOSURE,SUBR
+ ENTRY
+ SKIPL A,AB ;ANY ARGS
+ JRST TFA ;NO -- LOSE
+ ADD A,[2,,2] ;POINT AT IDS
+ PUSH TP,$TAB
+ PUSH TP,A
+ PUSH P,[0] ;MAKE COUNTER
+
+CLOLP: SKIPL A,1(TB) ;ANY MORE IDS?
+ JRST CLODON ;NO -- LOSE
+ PUSH TP,(A) ;SAVE ID
+ PUSH TP,1(A)
+ PUSH TP,(A) ;GET ITS VALUE
+ PUSH TP,1(A)
+ ADD A,[2,,2] ;BUMP POINTER
+ MOVEM A,1(TB)
+ AOS (P)
+ MCALL 1,VALUE
+ PUSH TP,A
+ PUSH TP,B
+ MCALL 2,LIST ;MAKE PAIR
+ PUSH TP,A
+ PUSH TP,B
+ JRST CLOLP
+
+CLODON: POP P,A
+ ACALL A,LIST ;MAKE UP LIST
+ PUSH TP,(AB) ;GET FUNCTION
+ PUSH TP,1(AB)
+ PUSH TP,A
+ PUSH TP,B
+ MCALL 2,LIST ;MAKE LIST
+ MOVSI A,TFUNARG
+ JRST FINIS
+
+\f
+
+;ERROR COMMENTS FOR EVAL
+
+BADNUM: ERRUUO EQUOTE NEGATIVE-ARGUMENT
+
+WTY1TP: ERRUUO EQUOTE FIRST-ARG-WRONG-TYPE
+
+UNBOU: PUSH TP,$TATOM
+ PUSH TP,EQUOTE UNBOUND-VARIABLE
+ JRST ER1ARG
+
+UNAS: PUSH TP,$TATOM
+ PUSH TP,EQUOTE UNASSIGNED-VARIABLE
+ JRST ER1ARG
+
+BADENV:
+ ERRUUO EQUOTE BAD-ENVIRONMENT
+
+FUNERR:
+ ERRUUO EQUOTE BAD-FUNARG
+
+
+MPD.0:
+MPD.1:
+MPD.2:
+MPD.3:
+MPD.4:
+MPD.5:
+MPD.6:
+MPD.7:
+MPD.8:
+MPD.9:
+MPD.10:
+MPD.11:
+MPD.12:
+MPD.13:
+MPD: ERRUUO EQUOTE MEANINGLESS-PARAMETER-DECLARATION
+
+NOBODY: ERRUUO EQUOTE HAS-EMPTY-BODY
+
+BADCLS: ERRUUO EQUOTE BAD-CLAUSE
+
+NXTAG: ERRUUO EQUOTE NON-EXISTENT-TAG
+
+NXPRG: ERRUUO EQUOTE NOT-IN-PROG
+
+NAPTL:
+NAPT: ERRUUO EQUOTE NON-APPLICABLE-TYPE
+
+NONEVT: ERRUUO EQUOTE NON-EVALUATEABLE-TYPE
+
+
+NONATM: ERRUUO EQUOTE NON-ATOMIC-ARGUMENT
+
+
+ILLFRA: ERRUUO EQUOTE FRAME-NO-LONGER-EXISTS
+
+ILLSEG: ERRUUO EQUOTE ILLEGAL-SEGMENT
+
+BADMAC: ERRUUO EQUOTE BAD-USE-OF-MACRO
+
+BADFSB: ERRUUO EQUOTE APPLY-OR-STACKFORM-OF-FSUBR
+
+
+ER1ARG: PUSH TP,(AB)
+ PUSH TP,1(AB)
+ MOVEI A,2
+ JRST CALER
+
+END
+\f
\ No newline at end of file
--- /dev/null
+TITLE OPEN - CHANNEL OPENER FOR MUDDLE
+
+RELOCATABLE
+
+;C. REEVE MARCH 1973
+
+.INSRT MUDDLE >
+
+SYSQ
+
+FNAMS==1
+F==E+1
+G==F+1
+
+IFE ITS,[
+IF1, .INSRT STENEX >
+]
+;THIS PROGRAM HAS ENTRIES: FOPEN, FCLOSE, RENAME, READB, PRINTB, FILECOPY, READSTRING,
+; PRINTSTRING, NETSTATE, NETACC, NETS, ACCESS, AND FILE-EXISTS?
+
+;THESE SUBROUTINES HANDLE I/O STREAMS FOR THE MUDDLE SYSTEM.
+
+; FOPEN - OPENS A FILE FOR EITHER READING OR WRITING. IT TAKES
+; FIVE OPTINAL ARGUMENTS AS FOLLOWS:
+
+; FOPEN (<DIR>,<FILE NAME1>,<FILE NAME2>,<DEVICE>,<SYSTEM NAME>)
+;
+; <DIR> - DIRECTION EITHER READ (INPUT) OR PRINT (OUPUT). DEFAULT IS READ
+
+; <FILE NAME1> - FIRST FILE NAME. DEFAULT INPUT OR OUTPUT.
+
+; <FILE NAME2> - SECOND FILE NAME. DEFAULT MUDDLE.
+
+; <DEVICE> - DEVICE FROM WHICH TO OPEN. DEFAULT IS DSK.
+
+; <SNAME> - SYSTEM (DIRECTORY) NAME. DEFAULT UNAME.
+
+; FOPEN RETURNS AN OBJECT OF TYPE CHANNEL IF IT SUCCEEDS OTHERWISE NIL
+
+
+; FCLOSE - CLOSES A FILE. TAKES A CHANNEL OBJECT AS ITS ARGUMENT. IT ALSO TAKES
+; ACCESS - DOES A .ACCESS ON A CHARACTER BASIS FOR CHARACTER FILES
+
+
+; A CHANNEL OBJECT IS A VECTOR CONTAINIG THE FOLLOWING INFORMATION
+
+; CHANNO ;ITS I/O CHANNEL NUMBER. 0 MEANS NOT A REAL CHANNEL.
+; DIRECT ;DIRECTION (EITHER READ OR PRINT)
+; NAME1 ;FIRST NAME OF FILE AS OPENED.
+; NAME2 ;SECOND NAME OF FILE
+; DEVICE ;DEVICE UPON WHICH THE CHANNEL IS OPEN
+; SNAME ;DIRECTORY NAME
+; RNAME1 ;REAL FIRST NAME (AS RETURNED BY READING CHANNEL STATUS)
+; RNAME2 ;REAL SECOND NAME
+; RDEVIC ;REAL DEVICE
+; RSNAME ;SYSTEM OR DIRECTORY NAME
+; STATUS ;VARIOUS STATUS BITS
+; IOINS ;INSTRUCTION EXECUTED TO INPUT OR OUTPUT ONE CHARACTER
+; ACCESS ;ACCESS POINTER FOR RAND ACCESS (OR USED FOR DISPLAY INFO)
+; RADX ;RADIX FOR CHANNELS NUMBER CONVERSION
+
+; *** THE FOLLOWING FIELDS FOR OUTPUT ONLY ***
+; LINLN ;LENGTH OF A LINE IN CHARACTERS FOR THIS DEVICE
+; CHRPOS ;CURRENT POSITION ON CURRENT LINE
+; PAGLN ;LENGTH OF A PAGE
+; LINPOS ;CURRENT LINE BEING WRITTEN ON
+
+; *** THE FOLLOWING FILEDS FOR INPUT ONLY ***
+; EOFCND ;GETS EVALUATED ON EOF
+; LSTCH ;BACKUP CHARACTER
+; WAITNS ;FOR TTY INPUT, BECOMES A .SLEEP WHEN WAITING
+; EXBUFR ;FOR TTY INPUT, CONTAINS A WAITING BUFFER LIST
+; BUFSTR ;A CHARACTER STRING USED AS BUFFER FOR NON-TTY DEVICES
+
+; THIS DEFINES THE LENGTH OF THE NON-TTY BUFFER
+BUFLNT==100
+
+;THIS DEFINES BLOCK MODE BIT FOR OPENING
+BLOCKM==2 ;DEFINED IN THE LEFT HALF
+IMAGEM==4
+
+\f
+;THIS IRP DEFINES THE FIELDS AT ASSEMBLY TIME
+
+ CHANLNT==4 ;INITIAL CHANNEL LENGTH
+
+; BUILD A PROTOTYPE CHANNEL AND DEFINE FILEDS
+BUFRIN==-1 ;SPECIAL HACK SO LOSERS WON'T SEE TTY BUFFER
+SCRPTO==-3 ;SPECIAL HACK FOR SCRIPT CHANNELS
+PROCHN:
+
+IRP A,,[[CHANNO,FIX],[DIRECT,CHSTR]
+[NAME1,CHSTR],[NAME2,CHSTR],[DEVICE,CHSTR],[SNAME,CHSTR]
+[RNAME1,CHSTR],[RNAME2,CHSTR],[RDEVIC,CHSTR],[RSNAME,CHSTR]
+[STATUS,FIX],[IOINS,FIX],[LINLN,FIX],[CHRPOS,FIX],[PAGLN,FIX],[LINPOS,FIX]
+[ACCESS,FIX],[RADX,FIX],[BUFSTR,CHSTR]]
+
+ IRP B,C,[A]
+ B==CHANLNT-3
+ T!C,,0
+ 0
+ .ISTOP
+ TERMIN
+ CHANLNT==CHANLNT+2
+TERMIN
+
+
+; EQUIVALANCES FOR CHANNELS
+
+EOFCND==LINLN
+LSTCH==CHRPOS
+WAITNS==PAGLN
+EXBUFR==LINPOS
+DISINF==BUFSTR ;DISPLAY INFO
+INTFCN==BUFSTR ;FUNCTION (OR SUBR, OR RSUBR) TO BE APPLIED FOR INTERNAL CHNLS
+
+
+;DEFINE VARIABLES ASSOCIATED WITH TTY BUFFERS
+
+IRP A,,[IOIN2,ECHO,CHRCNT,ERASCH,KILLCH,BRKCH,ESCAP,SYSCHR,BRFCHR,BRFCH2,BYTPTR]
+A==.IRPCNT
+TERMIN
+
+EXTBFR==BYTPTR+1+<100./5> ;LENGTH OF ADD'L BUFFER
+
+
+
+
+.GLOBAL IPNAME,MOPEN,MCLOSE,MIOT,ILOOKU,6TOCHS,ICLOS,OCLOS,RGPARS,RGPRS
+.GLOBAL OPNCHN,CHMAK,READC,TYO,SYSCHR,BRFCHR,LSTCH,BRFCH2,EXTBFR
+.GLOBAL CHRWRD,STRTO6,TTYBLK,WAITNS,EXBUFR,TTICHN,TTOCHN,GETCHR,IILIST
+.GLOBAL CHANNO,STATUS,LINPOS,PAGLN,CHRPOS,LINLN,IOINS,ACCESS,ADDNUL
+.GLOBAL DIRECT,DISINF,RADX,EOFCND,BUFSTR,MODE1,MODE2,GCHACK,GMTYO,INMTYO
+.GLOBAL T.CHAN,NAME1,BFCLOS,DOIOTI,DOIOTO,DOACCS,NOTTY,DEMFLG,BYTDOP,TNXIN
+.GLOBAL DISOPN,DISROP,DISCLS,DCHAR,DISLNL,DISPGL,INSTAT,MTYO,CIREST
+.GLOBAL ECHO,ERASCH,KILLCH,BRKCH,BYTPTR,SYSCHR,CHRCNT,ESCAP,N.CHNS
+.GLOBAL REOPN,QUITTE,CHNL0,CHNL1,BUFRIN,IOIN2,IFALSE,GFALS,IDVAL,PVSTOR,SPSTOR
+.GLOBAL BADCHN,WRONGD,CHNCLS,GSNAME,GIBLOK,APLQ,NAPT,ICONS,INCONS,IBLOCK,IDVAL1
+.GLOBAL GRB,GWB,R1CHAR,W1CHAR,BFCLS1,TTYOP2,MPOPJ,COMPER,R1C,W1C,WXCT,RXCT
+.GLOBAL TMTNXS,TNXSTR,RDEVIC,CPCH1,RCYCHN,CGFALS,CISTNG,CFILLE,FRSTCH
+.GLOBAL TGFALS,ONINT
+\f
+.VECT.==40000
+
+; PAIR MOVING MACRO
+
+DEFINE PMOVEM A,B
+ MOVE 0,A
+ MOVEM 0,B
+ MOVE 0,A+1
+ MOVEM 0,B+1
+ TERMIN
+
+; DEFINITIONS OF THE OFFSETS INTO THE TP STACK FOR OPEN
+
+T.SPDL==0 ; SAVES P STACK BASE
+T.DIR==2 ; CONTAINS DIRECTION AND MODE
+T.NM1==4 ; NAME 1 OF FILE
+T.NM2==6 ; NAME 2 OF FILE
+T.DEV==10 ; DEVICE NAME
+T.SNM==12 ; SNAME
+T.XT==14 ; EXTRA CRUFT IF NECESSARY
+T.CHAN==16 ; CHANNEL AS GENERATED
+
+; OFFSETS FROM PSTACK BASE (USED FOR OPENS, .RCHST AND .FDELES)
+
+S.DIR==0 ; CODE FOR DIRECTION 0-IN, 1-OUT, 2-BIN, 3-BOUT,4-DISPLAY
+ ; S.DIR(P) = <control word>,,<direction>
+IFN ITS,[
+S.DEV==1 ; SIXBIT DEVICE RIGHT JUSTIFIED
+S.NM1==2 ; SIXBIT NAME1
+S.NM2==3 ; SIXBIT NAME2
+S.SNM==4 ; SIXBIT SNAME
+S.X1==5 ; TEMPS
+S.X2==6
+S.X3==7
+]
+
+IFE ITS,[
+S.DEV==1
+S.X1==2
+S.X2==3
+S.X3==4
+]
+
+
+; FLAGS SPECIFYING STATE OF THE WORLD AT VARIOUS TIMES
+
+NOSTOR==400000 ; ON MEANS DONT BUILD NEW STRINGS
+MSTNET==200000 ; ON MEANS ONLY THE "NET" DEVICE CAN WIN
+SNSET==100000 ; FLAG, SNAME SUPPLIED
+DVSET==040000 ; FLAG, DEV SUPPLIED
+N2SET==020000 ; FLAG, NAME2 SET
+N1SET==010000 ; FLAG, NAME1 SET
+4ARG==004000 ; FLAG, CONSIDER ARGS TO BE 4 STRINGS
+
+RMT [EXPUNGE N1SET,N2SET,DVSET,SNSET,MSTNET,NOSTOR
+]
+
+; TABLE OF LEGAL MODES
+
+MODES: IRP A,,[READ,PRINT,READB,PRINTB,PRINTO,PRINAO]
+ SIXBIT /A/
+ TERMIN
+NMODES==.-MODES
+
+MODCOD: 0?1?2?3?3?1
+; TABLE OF KNOWN DEVICES AND A POINTER TO THEIR OPENERS
+
+IFN ITS,[
+DEVSTB: IRP A,,[DSK,TTY,USR,STY,ST,NET,INT,PTP,PTR,UT,T,NUL]
+ SIXBIT /A/ ; DEVICE NAMES
+ TERMIN
+
+DEVS: IRP B,,[ODSK,OTTY,OUSR,OSTY,OSTY,ONET,OINT,OPTP,OPTP,OUTN,OTTY,ONUL]
+ SETZ B ; POINTERS
+ TERMIN
+]
+
+IFE ITS,[
+DEVSTB: IRP A,,[PS,SS,SRC,DSK,TTY,INT,NET]
+ SIXBIT /A/
+ TERMIN
+
+DEVS: IRP B,,[ODSK,ODSK,ODSK,ODSK,OTTY,OINT,ONET]
+ SETZ B
+ TERMIN
+]
+NDEVS==.-DEVS
+
+
+\f
+;SUBROUTINE TO DO OPENING BEGINS HERE
+
+MFUNCTION NFOPEN,SUBR,[OPEN-NR]
+
+ JRST FOPEN1
+
+MFUNCTION FOPEN,SUBR,[OPEN]
+
+FOPEN1: ENTRY
+ PUSHJ P,MAKCHN ;MAKE THE CHANNEL
+ PUSHJ P,OPNCH ;NOW OPEN IT
+ JUMPL B,FINIS
+ SUB D,[4,,4] ; TOP THE CHANNEL
+ MOVEM D,RCYCHN+1 ; RECYCLE DEAD CHANNEL
+ SETZM (D) ; ZAP IT
+ MOVEI C,1(D)
+ HRLI C,(D)
+ BLT C,CHANLNT-1(D)
+ JRST FINIS
+
+; SUBR TO JUST CREATE A CHANNEL
+
+IMFUNCTION CHANNEL,SUBR
+
+ ENTRY
+ PUSHJ P,MAKCHN
+ MOVSI A,TCHAN
+ JRST FINIS
+
+
+\f
+
+; THIS ROUTINE PARSES ARGUMENTS TO FOPEN ETC. AND BUILDS A CHANNEL BUT DOESN'T OPEN IT
+
+MAKCHN: PUSH TP,$TPDL
+ PUSH TP,P ; POINT AT CURRENT STACK BASE
+ PUSH TP,$TCHSTR
+ PUSH TP,CHQUOTE READ
+ MOVEI E,10 ; SLOTS OF TP NEEDED
+ PUSH TP,[0]
+ SOJG E,.-1
+ MOVEI E,0
+ EXCH E,(P) ; GET RET ADDR IN E
+IFE ITS, PUSH P,[0]
+IRP ATM,,[DEV,NM1,NM2,SNM]MDF,,[DSK,INPUT,>,[ ]]TMDF,,[DSK,INPUT,MUD,[ ]]
+ MOVE B,IMQUOTE ATM
+IFN ITS, PUSH P,E
+ PUSHJ P,IDVAL1
+ GETYP 0,A
+ CAIN 0,TCHSTR
+ JRST MAK!ATM
+
+ MOVE A,$TCHSTR
+IFN ITS, MOVE B,CHQUOTE MDF
+IFE ITS, MOVE B,CHQUOTE TMDF
+MAK!ATM:
+ MOVEM A,T.!ATM(TB)
+ MOVEM B,T.!ATM+1(TB)
+IFN ITS,[
+ POP P,E
+ PUSHJ P,STRTO6 ; RESULT LEFT ON P STACK AS DESIRED
+]
+ TERMIN
+ PUSH TP,[0] ; PUSH SLOTS
+ PUSH TP,[0]
+
+ PUSH P,[0] ; EXT SLOTS
+ PUSH P,[0]
+ PUSH P,[0]
+ PUSH P,E ; PUSH RETURN ADDRESS
+ MOVEI A,0
+
+ JUMPGE AB,MAKCH0 ; NO ARGS, ALREADY DONE
+ GETYP 0,(AB) ; 1ST ARG MUST BE A STRING
+ CAIE 0,TCHSTR
+ JRST WTYP1
+ MOVE A,(AB) ; GET ARG
+ MOVE B,1(AB)
+ PUSHJ P,CHMODE ; CHECK OUT OPEN MODE
+
+ PMOVEM (AB),T.DIR(TB) ; SAVE MODE NAME IN TEMPS
+ ADD AB,[2,,2] ; BUMP PAST DIRECTION
+ MOVEM AB,ABSAV(TB)
+ MOVEI A,0
+ JUMPGE AB,MAKCH0 ; CHECK NAME1 BASED ON JUST MODE
+
+ MOVEI 0,0 ; FLAGS PRESET
+ PUSHJ P,RGPARS ; PARSE THE STRING(S)
+ JRST TMA
+
+; ARGUMENTS PARSED, DO FINAL CHECKS AND BUILD CHANNEL
+
+MAKCH0:
+IFN ITS,[
+ MOVE C,T.SPDL+1(TB)
+ MOVE D,S.DEV(C) ; GET DEV
+]
+IFE ITS,[
+ MOVE A,T.DEV(TB)
+ MOVE B,T.DEV+1(TB)
+ PUSHJ P,STRTO6
+ POP P,D
+ HLRZS D
+ MOVE C,T.SPDL+1(TB)
+ MOVEM D,S.DEV(C)
+]
+IFE ITS, CAIE D,(SIXBIT /INT/);INTERNAL?
+IFN ITS, CAME D,[SIXBIT /INT /]
+ JRST CHNET ; NO, MAYBE NET
+ SKIPN T.XT+1(TB) ; WAS FCN SUPPLIED?
+ JRST TFA
+
+; FALLS TROUGH IF SKIP
+
+\f
+
+; NOW BUILD THE CHANNEL
+
+ARGSOK: MOVEI A,CHANLNT ; GET LENGTH
+ SKIPN B,RCYCHN+1 ; RECYCLE?
+ PUSHJ P,GIBLOK ; GET A BLOCK OF STUFF
+ SETZM RCYCHN+1
+ ADD B,[4,,4] ; HIDE THE TTY BUFFER SLOT
+ PUSH TP,$TCHAN
+ PUSH TP,B
+ HRLI C,PROCHN ; POINT TO PROTOTYPE
+ HRRI C,(B) ; AND NEW ONE
+ BLT C,CHANLN-5(B) ; CLOBBER
+ MOVSI C,TLIST ; TO GIVE HIM A CLEAN LIST OF SCRIPT CHANS
+ HLLM C,SCRPTO-1(B)
+
+; NOW BLT IN STUFF FROM THE STACK
+
+ MOVSI C,T.DIR(TB) ; DIRECTION
+ HRRI C,DIRECT-1(B)
+ BLT C,SNAME(B)
+ MOVEI C,RNAME1-1(B) ; NOW "REAL" SLOTS
+ HRLI C,T.NM1(TB)
+ BLT C,RSNAME(B)
+ MOVE B,IMQUOTE MODE
+ PUSHJ P,IDVAL1
+ GETYP 0,A
+ CAIN 0,TFIX
+ JRST .+3
+ MOVE B,(TP)
+ POPJ P,
+
+ MOVE C,(TP)
+IFE ITS,[
+ ANDI B,403776 ; ONLY ALLOW NON-CRITICAL BITSS
+]
+ HRRM B,-4(C) ; HIDE BITS
+ MOVE B,C
+ POPJ P,
+
+; HERE TO VALIDIFY ARGUMENTS FOR A NET OPEN
+
+CHNET:
+IFN ITS,[
+ CAME D,[SIXBIT /NET /] ; IS IT NET
+ JRST MAKCH1]
+IFE ITS,[
+ CAIE D,(SIXBIT /NET/) ; IS IT NET
+ JRST ARGSOK]
+ MOVSI D,TFIX ; FOR TYPES
+ MOVEI B,T.NM1(TB) ; MAKE SURE ALL ARE FIXED
+ PUSHJ P,CHFIX
+ MOVEI B,T.NM2(TB)
+ PUSHJ P,CHFIX
+ MOVEI B,T.SNM(TB)
+ LSH A,-1 ; SKIP DEV FLAG
+ PUSHJ P,CHFIX
+ JRST ARGSOK
+
+MAKCH1: TRNN A,MSTNET ; CANT HAVE SEEN A FIX
+ JRST ARGSOK
+ JRST WRONGT
+
+IFN ITS,[
+CHFIX: TRNE A,N1SET ; SKIP IF NOT SPECIFIED
+ JRST CHFIX1
+ SETOM 1(B) ; SET TO -1
+ SETOM S.NM1(C)
+ MOVEM D,(B) ; CORRECT TYPE
+]
+IFE ITS,CHFIX:
+ GETYP 0,(B)
+ CAIE 0,TFIX
+ JRST PARSQ
+CHFIX1: ADDI C,1 ; POINT TO NEXT FIELD
+ LSH A,-1 ; AND NEXT FLAG
+ POPJ P,
+PARSQ: CAIE 0,TCHSTR
+ JRST WRONGT
+IFE ITS, POPJ P,
+IFN ITS,[
+ PUSH P,A
+ PUSH P,C
+ PUSH TP,(B)
+ PUSH TP,1(B)
+ SUBI B,(TB)
+ PUSH P,B
+ MCALL 1,PARSE
+ GETYP 0,A
+ CAIE 0,TFIX
+ JRST WRONGT
+ POP P,C
+ ADDI C,(TB)
+ MOVEM A,(C)
+ MOVEM B,1(C)
+ POP P,C
+ POP P,A
+ POPJ P,
+]
+\f
+
+; SUBROUTINE TO CHECK VALIDITY OF MODE AND SAVE A CODE
+
+CHMODE: PUSHJ P,CHMOD ; DO IT
+ MOVE C,T.SPDL+1(TB)
+ HRRZM A,S.DIR(C)
+ POPJ P,
+
+CHMOD: PUSHJ P,STRTO6 ; TO SIXBIT
+ POP P,B ; VALUE ENDSUP ON STACK, RESTORE IT
+
+ MOVSI A,-NMODES ; SCAN TO SEE IF LEGAL MODE
+ CAME B,MODES(A)
+ AOBJN A,.-1
+ JUMPGE A,WRONGD ; ILLEGAL MODE NAME
+ MOVE A,MODCOD(A)
+ POPJ P,
+\f
+
+IFN ITS,[
+; RGPARS -- PARSE THE STRINGS COMPRISING FILE NAMES INTO STANDARD ITS GOODIES
+
+RGPRS: MOVEI 0,NOSTOR ; DONT STORE STRINGS IF ENTER HERE
+
+RGPARS: CAMGE AB,[-7,,] ; MULTI-STRING CASE POSSIBLE?
+ IORI 0,4ARG ; 4 STRING CASE
+ HRLM 0,(P) ; LH IS FLAGS FOR THIS PROG
+ MOVSI E,-4 ; FIELDS TO FILL
+
+RPARGL: GETYP 0,(AB) ; GET TYPE
+ CAIE 0,TCHSTR ; STRING?
+ JRST ARGCLB ; NO, JUST CLOBBER IT IN RAW
+ JUMPGE E,CPOPJ ; DON'T DO ANY MORE
+ PUSH TP,(AB) ; GET AN ARG
+ PUSH TP,1(AB)
+
+FPARS: PUSH TP,-1(TP) ; ANOTHER COPY
+ PUSH TP,-1(TP)
+ HLRZ 0,(P)
+ TRNN 0,4ARG
+ PUSHJ P,FLSSP ; NO LEADING SPACES
+ MOVEI A,0 ; WILL HOLD SIXBIT
+ MOVEI B,6 ; CHARS PER 6BIT WORD
+ MOVE C,[440600,,A] ; BYTE POINTER INTO A
+
+FPARSL: HRRZ 0,-1(TP) ; GET COUNT
+ JUMPE 0,PARSD ; DONE
+ SOS -1(TP) ; COUNT
+ ILDB 0,(TP) ; CHAR TO 0
+
+ CAIE 0,"\11 ; FILE NAME QUOTE?
+ JRST NOCNTQ
+ HRRZ 0,-1(TP)
+ JUMPE 0,PARSD
+ SOS -1(TP)
+ ILDB 0,(TP) ; USE THIS
+ JRST GOTCNQ
+
+NOCNTQ: HLL 0,(P)
+ TLNE 0,4ARG
+ JRST GOTCNQ
+ ANDI 0,177
+ CAIG 0,40 ; SPACE?
+ JRST NDFLD ; YES, TERMINATE THIS FIELD
+ CAIN 0,": ; DEVICE ENDED?
+ JRST GOTDEV
+ CAIN 0,"; ; SNAME ENDED
+ JRST GOTSNM
+
+GOTCNQ: ANDI 0,177
+ PUSHJ P,A0TO6 ; CONVERT TO 6BIT AND CHECK
+
+ JUMPE B,FPARSL ; IGNORE IF AREADY HAVE 6
+ IDPB 0,C
+ SOJA B,FPARSL
+
+; HERE IF SPACE ENCOUNTERED
+
+NDFLD: MOVEI D,(E) ; COPY GOODIE
+ PUSHJ P,FLSSP ; FLUSH REDUNDANT SPACES
+ JUMPE 0,PARSD ; NO CHARS LEFT
+
+NFL0: PUSH P,A ; SAVE SIXBIT WORD
+ SKIPGE -1(P) ; SKIP IF STRING TO BE STORED
+ JRST NFL1
+ PUSH TP,$TAB ; PREVENT AB LOSSAGE
+ PUSH TP,AB
+ PUSHJ P,6TOCHS ; CONVERT TO STRING
+ MOVE AB,(TP)
+ SUB TP,[2,,2]
+NFL1: HRRZ 0,-1(TP) ; RESTORE CHAR COUNT
+
+NFL2: MOVEI C,(D) ; COPY REL PNTR
+ SKIPGE -1(P) ; SKIP IF STRINGS TO BE STORED
+ JRST NFL3
+ ASH D,1 ; TIMES 2
+ ADDI D,T.NM1(TB)
+ MOVEM A,(D) ; STORE
+ MOVEM B,1(D)
+NFL3: MOVSI A,N1SET ; FLAG IT
+ LSH A,(C)
+ IORM A,-1(P) ; AND CLOBBER
+ MOVE D,T.SPDL+1(TB) ; GET P BASE
+ POP P,@SIXTBL(C) ; AND STORE SIXBIT OF IT
+
+ POP TP,-2(TP) ; MAKE NEW STRING POINTER
+ POP TP,-2(TP)
+ JUMPE 0,.+3 ; SKIP IF NO MORE CHARS
+ AOBJN E,FPARS ; MORE TO PARSE?
+CPOPJ: POPJ P, ; RETURN, ALL DONE
+
+ SUB TP,[2,,2] ; FLUSH OLD STRING
+ ADD E,[1,,1]
+ ADD AB,[2,,2] ; BUMP ARG
+ MOVEM AB,ABSAV(TB)
+ JUMPL AB,RPARGL ; AND GO ON
+CPOPJ1: AOS A,(P) ; PREPARE TO WIN
+ HLRZS A
+ POPJ P,
+
+\f
+
+; HERE IF STRING HAS ENDED
+
+PARSD: PUSH P,A ; SAVE 6 BIT
+ MOVE A,-3(TP) ; CAN USE ARG STRING
+ MOVE B,-2(TP)
+ MOVEI D,(E)
+ JRST NFL2 ; AND CONTINUE
+
+; HERE IF JUST READ DEV
+
+GOTDEV: MOVEI D,2 ; CODE FOR DEVICE
+ JRST GOTFLD ; GOT A FIELD
+
+; HERE IF JUST READ SNAME
+
+GOTSNM: MOVEI D,3
+GOTFLD: PUSHJ P,FLSSP
+ SOJA E,NFL0
+
+
+; HERE FOR NON STRING ARG ENCOUNTERED
+
+ARGCLB: SKIPGE (P) ; IF NOT STORING, CONSIDER THIS THE END
+
+ POPJ P,
+ MOVE C,T.SPDL+1(TB) ; GET P-BASE
+ MOVE A,S.DEV(C) ; GET DEVICE
+ CAME A,[SIXBIT /INT /]; IS IT THE INTERNAL DEVICE
+ JRST TRYNET ; NO, COUD BE NET
+ MOVE A,0 ; OFFNEDING TYPE TO A
+ PUSHJ P,APLQ ; IS IT APPLICABLE
+ JRST NAPT ; NO, LOSE
+ PMOVEM (AB),T.XT(TB)
+ ADD AB,[2,,2] ; MUST BE LAST ARG
+ MOVEM AB,ABSAV(TB)
+ JUMPL AB,TMA
+ JRST CPOPJ1 ; ELSE SUCCESSFUL RETURN
+TRYNET: CAIE 0,TFIX ; FOR NET DEV, ARGS MUST BE FIX
+ JRST WRONGT ; TREAT AS WRONG TYPE
+ MOVSI A,MSTNET ; BETTER BE NET EVENTUALLY
+ IORM A,(P) ; STORE FLAGS
+ MOVSI A,TFIX
+ MOVE B,1(AB) ; GET NUMBER
+ MOVEI 0,(E) ; MAKE SURE NOT DEVICE
+ CAIN 0,2
+ JRST WRONGT
+ PUSH P,B ; SAVE NUMBER
+ MOVEI D,(E) ; SET FOR TABLE OFFSETS
+ MOVEI 0,0
+ ADD TP,[4,,4]
+ JRST NFL2 ; GO CLOBBER IT AWAY
+]
+\f
+
+; ROUTINE TO FLUSH LEADING SPACES FROM A FIELD
+
+FLSSP: HRRZ 0,-1(TP) ; GET CHR COUNNT
+ JUMPE 0,CPOPJ ; FINISHED STRING
+FLSS1: MOVE B,(TP) ; GET BYTR
+ ILDB C,B ; GETCHAR
+ CAIE C,^Q ; DONT FLUSH CNTL-Q
+ CAILE C,40
+ JRST FLSS2
+ MOVEM B,(TP) ; UPDATE BYTE POINTER
+ SOJN 0,FLSS1
+
+FLSS2: HRRM 0,-1(TP) ; UPDATE STRING
+ POPJ P,
+
+IFN ITS,[
+;TABLE FOR STFUFFING SIXBITS AWAY
+
+SIXTBL: SETZ S.NM1(D)
+ SETZ S.NM2(D)
+ SETZ S.DEV(D)
+ SETZ S.SNM(D)
+ SETZ S.X1(D)
+]
+
+RDTBL: SETZ RDEVIC(B)
+ SETZ RNAME1(B)
+ SETZ RNAME2(B)
+ SETZ RSNAME(B)
+
+
+\f
+IFE ITS,[
+
+; TENEX VERSION OF FILE NAME PARSER (ONLY ACCEPT ARGS IN SINGLE STRING)
+
+
+RGPRS: MOVEI 0,NOSTOR
+
+RGPARS: HRLM 0,(P) ; SAVE FOR STORE CHECKING
+ CAMGE AB,[-2,,] ; MULTI-STRING CASE POSSIBLE?
+ JRST TN.MLT ; YES, GO PROCESS
+RGPRSS: GETYP 0,(AB) ; CHECK ARG TYPE
+ CAIE 0,TCHSTR
+ JRST WRONGT ; FOR NOW ONLY STRING ARGS WIN
+ PUSH TP,(AB)
+ PUSH TP,1(AB)
+ PUSHJ P,FLSSP ; FLUSH LEADING SPACES
+ PUSHJ P,RGPRS1
+ ADD AB,[2,,2]
+ MOVEM AB,ABSAV(TB)
+CHKLST: JUMPGE AB,CPOPJ1
+ SKIPGE (P) ; IF FROM OPEN, ALLOW ONE MORE
+ POPJ P,
+ PMOVEM (AB),T.XT(TB)
+ ADD AB,[2,,2]
+ MOVEM AB,ABSAV(TB)
+ JUMPL AB,TMA
+CPOPJ1: AOS (P)
+ POPJ P,
+
+RGPRS1: PUSH P,[0] ; ALLOW A DEVICE SPEC
+TN.SNM: MOVE A,(TP)
+ HRRZ 0,-1(TP)
+ JUMPE 0,RPDONE
+ ILDB A,A
+ CAIE A,"< ; START "DIRECTORY" ?
+ JRST TN.N1 ; NO LOOK FOR NAME1
+ SETOM (P) ; DEV NOT ALLOWED
+ IBP (TP) ; SKIP CHAR
+ SOS -1(TP)
+ PUSHJ P,TN.CNT ; COUNT CHARS TO ">" OR "."
+ JUMPE B,ILLNAM ; RAN OUT
+ CAIE A,".
+ JRST TN.SN3
+ PUSH TP,0
+ PUSH TP,C
+TN.SN1: PUSHJ P,TN.CNT ; COUNT CHARS TO ">"
+ JUMPE B,ILLNAM ; RAN OUT
+ CAIE A,".
+ JRST TN.SN2
+ MOVEM 0,-1(TP)
+ MOVEM C,(TP)
+ JRST TN.SN1
+TN.SN2: HRRZ B,-3(TP)
+ SUB B,0
+ SUBI B,1
+ SUB TP,[2,,2]
+TN.SN3: CAIE A,"> ; SKIP IF WINS
+ JRST ILLNAM
+ PUSHJ P,TN.CPS ; COPY TO NEW STRING
+ HLLOS T.SPDL(TB)
+ MOVEM A,T.SNM(TB)
+ MOVEM B,T.SNM+1(TB)
+
+TN.N1: PUSHJ P,TN.CNT
+ JUMPE B,RPDONE
+ CAIE A,": ; GOT A DEVICE
+ JRST TN.N11
+ SKIPE (P)
+ JRST ILLNAM
+ SETOM (P)
+ PUSHJ P,TN.CPS
+ MOVEM A,T.DEV(TB)
+ MOVEM B,T.DEV+1(TB)
+ JRST TN.SNM ; NOW LOOK FOR SNAME
+
+TN.N11: CAIE A,">
+ CAIN A,"<
+ JRST ILLNAM
+ MOVEM A,(P) ; SAVE END CHAR
+ PUSHJ P,TN.CPS ; GEN STRING
+ MOVEM A,T.NM1(TB)
+ MOVEM B,T.NM1+1(TB)
+
+TN.N2: SKIPN A,(P) ; GET CHAR BACK
+ JRST RPDONE
+ CAIN A,"; ; START VERSION?
+ JRST .+3
+ CAIE A,". ; START NAME2?
+ JRST ILLNAM ; I GIVE UP!!!
+ HRRZ B,-1(TP) ; GET RMAINS OF STRING
+ PUSHJ P,TN.CPS ; AND COPY IT
+ MOVEM A,T.NM2(TB)
+ MOVEM B,T.NM2+1(TB)
+RPDONE: SUB P,[1,,1] ; FLUSH TEMP
+ SUB TP,[2,,2]
+CPOPJ: POPJ P,
+
+TN.CNT: HRRZ 0,-1(TP) ; CHAR COUNT
+ MOVE C,(TP) ; BPTR
+ MOVEI B,0 ; INIT COUNT TO 0
+
+TN.CN1: MOVEI A,0 ; IN CASE RUN OUT
+ SOJL 0,CPOPJ ; RUN OUT?
+ ILDB A,C ; TRY ONE
+ CAIE A,"\16 ; TNEX FILE QUOTE?
+ JRST TN.CN2
+ SOJL 0,CPOPJ
+ IBP C ; SKIP QUOTED CHAT
+ ADDI B,2
+ JRST TN.CN1
+
+TN.CN2: CAIE A,"<
+ CAIN A,">
+ POPJ P,
+
+ CAIE A,".
+ CAIN A,";
+ POPJ P,
+ CAIN A,":
+ POPJ P,
+ AOJA B,TN.CN1
+
+TN.CPS: PUSH P,B ; # OF CHARS
+ MOVEI A,4(B) ; ADD 4 TO B IN A
+ IDIVI A,5
+ PUSHJ P,IBLOCK ; GET BLOCK OF WORDS FOR STRING
+
+ POP P,C ; CHAR COUNT BACK
+ HRLI B,010700
+ SUBI B,1
+ MOVSI A,TCHSTR
+ HRRI A,(C) ; CHAR STRING
+ MOVE D,B ; COPY BYTER
+
+ JUMPE C,CPOPJ
+ ILDB 0,(TP) ; GET CHAR
+ IDPB 0,D ; AND STROE
+ SOJG C,.-2
+
+ MOVNI C,(A) ; - LENGTH TO C
+ ADDB C,-1(TP) ; DECREMENT WORDS COUNT
+ TRNN C,-1 ; SKIP IF EMPTY
+ POPJ P,
+ IBP (TP)
+ SOS -1(TP) ; ELSE FLUSH TERMINATOR
+ POPJ P,
+
+ILLNAM: ERRUUO EQUOTE ILLEGAL-TENEX-FILE-NAME
+
+TN.MLT: MOVE A,AB ; AOBJN POINTER TO ARGS IN A
+
+TN.ML1: GETYP 0,(A) ; IS THIS ARG OF RIGHT TYPE
+ CAIE 0,TFIX
+ CAIN 0,TCHSTR
+ JRST .+2
+ JRST RGPRSS ; ASSUME SINGLE STRING
+ ADD A,[2,,2]
+ JUMPL A,TN.ML1 ; TRY NEXT ARG IF ANY LEFT
+
+ MOVEI 0,T.NM1(TB) ; 1ST WORD OF DESTINATION
+ HLRO A,AB ; MINUS NUMBER OF ARGS IN A
+ MOVN A,A ; NUMBER OF ARGS IN A
+ SUBI A,1
+ CAMGE AB,[-10,,0]
+ MOVEI A,7 ; IF MORE THAN 10 ARGS, PUT 7
+ ADD A,0 ; LAST WORD OF DESTINATION
+ HRLI 0,(AB)
+ BLT 0,(A) ; BLT 'EM IN
+ ADD AB,[10,,10] ; SKIP THESE GUYS
+ MOVEM AB,ABSAV(TB)
+ JRST CHKLST
+
+]
+\f
+
+; ROUTINE TO OPEN A CHANNEL FOR ANY DEVICE. NAMES ARE ASSUMED TO ALREADY
+; BE ON BOTH TP STACK AND P STACK
+
+OPNCH: MOVE C,T.SPDL+1(TB) ; GET PDL BASE
+ HRRZ A,S.DIR(C)
+ ANDI A,1 ; JUST WANT I AND O
+IFE ITS,[
+ HRLM A,S.DEV(C)
+; .TRANS S.DEV(C) ; UNDO ANY TRANSLATIONS
+; JRST TRLOST ; COMPLAIN
+]
+IFN ITS,[
+ HRLM A,S.DIR(C)
+]
+
+IFN ITS,[
+ MOVE A,S.DEV(C) ; GET SIXBIT DEVICE CODE
+]
+
+IFE ITS,[HRLZS A,S.DEV(C)
+]
+
+ MOVSI B,-NDEVS ; AOBJN COUNTER
+DEVLP: SETO D,
+ MOVE 0,DEVSTB(B) ; GET ONE FROM TABLE
+ MOVE E,A
+DEVLP1: AND E,D ; FLUSH POSSIBLE DIGITNESS
+ CAMN 0,E
+ JRST CHDIGS ; MAKE SURE REST IS DIGITS
+ LSH D,6
+ JUMPN D,DEVLP1 ; KEEP TRUCKING UNTIL DONE
+
+; WASN'T THAT DEVICE, MOVE TO NEXT
+NXTDEV: AOBJN B,DEVLP
+ JRST ODSK ; UNKNOWN DEVICE IS ASSUMED TO BE DISK
+
+IFN ITS,[
+OUSR: HRRZ A,S.DIR(C) ; BLOCK OR UNIT?
+ TRNE A,2 ; SKIP IF UNIT
+ JRST ODSK
+ PUSHJ P,OPEN1 ; OPEN IT
+ PUSHJ P,FIXREA ; AND READCHST IT
+ MOVE B,T.CHAN+1(TB) ; RESTORE CHANNEL
+ MOVE 0,[PUSHJ P,DOIOT] ; GET AN IOINS
+ MOVEM 0,IOINS(B)
+ MOVE C,T.SPDL+1(TB)
+ HRRZ A,S.DIR(C)
+ TRNN A,1
+ JRST EOFMAK
+ MOVEI 0,80.
+ MOVEM 0,LINLN(B)
+ JRST OPNWIN
+
+OSTY: HLRZ A,S.DIR(C)
+ IORI A,10 ; THE DONT LOSE BIT (DONT HANG ON INPUT DO ON OUTPUT)
+ HRLM A,S.DIR(C)
+ JRST OUSR
+]
+
+; MAKE SURE DIGITS EXIST
+
+CHDIGS: SETCA D,
+ JUMPE D,DISPA ; NO DIGITS, WIN IMMEDIATE
+ MOVE E,A
+ AND E,D ; LEAVES ONLY DIGITS, IF WINNING
+ LSH E,6
+ LSH D,6
+ JUMPG D,.-2 ; KEEP GOING TIL DIGITS LEFT SHIFTED
+ JRST CHDIGN
+
+CHDIG1: CAIG D,'9
+ CAIGE D,'0
+ JRST NXTDEV ; NOT A DIGIT, LOSE
+ JUMPE E,DISPA ; IF THAT'S ALL THE CHARACTERS, WIN!
+CHDIGN: SETZ D,
+ ROTC D,6 ; GET NEXT CHARACTER INTO D
+ JRST CHDIG1 ; GO TEST?
+
+; HERE TO DISPATCH IF SUCCESSFUL
+
+DISPA: JRST @DEVS(B)
+
+\f
+IFN ITS,[
+
+; DISK DEVICE OPNER COME HERE
+
+ODSK: MOVE A,S.SNM(C) ; GET SNAME
+ .SUSET [.SSNAM,,A] ; CLOBBER IT
+ PUSHJ P,OPEN0 ; DO REAL LIVE OPEN
+]
+IFE ITS,[
+
+; TENEX DISK FILE OPENER
+
+ODSK: MOVE B,T.CHAN+1(TB) ; GET CHANNEL
+ PUSHJ P,STSTK ; EXPAND STRING ONTO STACK (E POINTS TO OLD P)
+ MOVE A,DIRECT-1(B)
+ MOVE B,DIRECT(B)
+ PUSHJ P,STRTO6 ; GET DIR NAME
+ MOVE C,(P)
+ MOVE D,T.SPDL+1(TB)
+ HRRZ D,S.DIR(D)
+ CAME C,[SIXBIT /PRINAO/]
+ CAMN C,[SIXBIT /PRINTO/]
+ IORI D,100 ; TURN ON BIT TO SAY USE OLD FILE
+ MOVSI A,101 ; START SETTING UP BITS EXTRA BIT FOR MSB
+ TRNE D,1 ; SKIP IF INPUT
+ TRNE D,100 ; WITE OVER?
+ TLOA A,100000 ; FORCE OLD VERSION
+ TLO A,600000 ; FORCE NEW VERSION
+ HRROI B,1(E) ; POINT TO STRING
+ GTJFN
+ TDZA 0,0 ; SAVE FACT OF NO SKIP
+ MOVEI 0,1 ; INDICATE SKIPPED
+ POP P,C ; RECOVER OPEN MODE SIXBIT
+ MOVE P,E ; RESTORE PSTACK
+ JUMPE 0,GTJLOS ; FIND OUT WHAT HAPPENED
+
+ MOVE B,T.CHAN+1(TB) ; GET CHANNEL
+ HRRZ 0,-4(B) ; FUNNY MODE BITS
+ HRRZM A,CHANNO(B) ; SAVE IT
+ ANDI A,-1 ; READ Y TO DO OPEN
+ MOVSI B,440000 ; USE 36. BIT BYES
+ HRRI B,200000 ; ASSUME READ
+; CAMN C,[SIXBIT /READB/]
+; TRO B,2000 ; TURN ON THAWED IF READB
+ IOR B,0
+ TRNE D,1 ; SKIP IF READ
+ HRRI B,300000 ; WRITE BIT
+ HRRZ 0,FSAV(TB) ; SEE IF REF DATE HACK
+ CAIN 0,NFOPEN
+ TRO B,400 ; SET DON'T MUNG REF DATE BIT
+ MOVE E,B ; SAVE BITS FOR REOPENS
+ OPENF
+ JRST OPFLOS
+ MOVE B,[2,,11] ; GET LENGTH & BYTE SIZE
+ PUSH P,[0]
+ PUSH P,[0]
+ MOVEI C,-1(P)
+ GTFDB
+ LDB 0,[300600,,-1(P)] ; GET BYTE SIZE
+ MOVE B,(P)
+ SUB P,[2,,2]
+ CAIN 0,7
+ JRST SIZASC
+ CAIN 0,36.
+ SIZEF ; USE OPENED SIZE
+ JFCL
+ IMULI B,5 ; TO BYTES
+SIZASC: MOVEI 0,C.OPN+C.READ+C.DISK
+ TRNE D,1 ; SKIP FOR READ
+ MOVEI 0,C.OPN+C.PRIN+C.DISK
+ TRNE D,2 ; SKIP IF NOT BINARY FILE
+ TRO 0,C.BIN
+ HRL 0,B
+ MOVE B,T.CHAN+1(TB)
+ TRNE D,1
+ HLRM 0,LSTCH-1(B) ; SAVE CURRENT LENGTH
+ MOVEM E,STATUS(B)
+ HRRM 0,-2(B) ; MUNG THOSE BITS
+ ASH A,1 ; POINT TO SLOT
+ ADDI A,CHNL0 ; TO REAL SLOT
+ MOVEM B,1(A) ; SAVE CHANNEL
+ PUSHJ P,TMTNXS ; GET STRING FROM TENEX
+ MOVE B,CHANNO(B) ; JFN TO A
+ HRROI A,1(E) ; BASE OF STRING
+ MOVE C,[111111,,140001] ; WEIRD CONTROL BITS
+ JFNS ; GET STRING
+ MOVEI B,1(E) ; POINT TO START OF STRING
+ SUBM P,E ; RELATIVIZE E
+ PUSHJ P,TNXSTR ; MAKE INTO A STRING
+ SUB P,E ; BACK TO NORMAL
+ PUSH TP,A
+ PUSH TP,B
+ PUSHJ P,RGPRS1 ; PARSE INTO FIELDS
+ MOVE B,T.CHAN+1(TB)
+ MOVEI C,RNAME1-1(B)
+ HRLI C,T.NM1(TB)
+ BLT C,RSNAME(B)
+ JRST OPBASC
+OPFLOS: MOVEI C,(A) ; SAVE ERROR CODE
+ MOVE B,T.CHAN+1(TB)
+ HRRZ A,CHANNO(B) ; JFN BACK TO A
+ RLJFN ; TRY TO RELEASE IT
+ JFCL
+ MOVEI A,(C) ; ERROR CODE BACK TO A
+
+GTJLOS: MOVE B,T.CHAN+1(TB)
+ PUSHJ P,TGFALS ; GET A FALSE WITH REASON
+ JRST OPNRET
+
+STSTK: PUSH TP,$TCHAN
+ PUSH TP,B
+ MOVEI A,4+5 ; COUNT CHARS NEEDED (NEED LAST 0 BYTE)
+ MOVE B,(TP)
+ ADD A,RDEVIC-1(B)
+ ADD A,RNAME1-1(B)
+ ADD A,RNAME2-1(B)
+ ADD A,RSNAME-1(B)
+ ANDI A,-1 ; TO 18 BITS
+ MOVEI 0,A(A)
+ IDIVI A,5 ; TO WORDS NEEDED
+ POP P,C ; SAVE RET ADDR
+ MOVE E,P ; SAVE POINTER
+ PUSH P,[0] ; ALOCATE SLOTS
+ SOJG A,.-1
+ PUSH P,C ; RET ADDR BACK
+ INTGO ; IN CASE OVERFLEW
+ PUSH P,0
+ MOVE B,(TP) ; IN CASE GC'D
+ MOVE D,[440700,,1(E)] ; BYTE POINTER TO IT
+ MOVEI A,RDEVIC-1(B)
+ PUSHJ P,MOVSTR ; FLUSH IT ON
+ HRRZ A,T.SPDL(TB)
+ JUMPN A,NLNMS ; USER GAVE NAME, USE IT (CAREFUL, RELIES ON
+ ; A BEING NON ZERO)
+ PUSH P,B
+ PUSH P,C
+ MOVEI A,0 ; HERE TO SEE IF THIS IS REALLY L.N.
+ HRROI B,1(E)
+ HRROI C,1(P)
+ LNMST ; LOOK UP LOGICAL NAME
+ MOVNI A,1 ; NOT A LOGICAL NAME
+ POP P,C
+ POP P,B
+NLNMS: MOVEI 0,":
+ IDPB 0,D
+ JUMPE A,ST.NM1 ; LOGICAL NAME, FLUSH SNAME
+ HRRZ A,RSNAME-1(B) ; ANY SNAME AT ALL?
+ JUMPE A,ST.NM1 ; NOPE, CANT HACK WITH IT
+ MOVEI A,"<
+ IDPB A,D
+ MOVEI A,RSNAME-1(B)
+ PUSHJ P,MOVSTR ; SNAME UP
+ MOVEI A,">
+ IDPB A,D
+ST.NM1: MOVEI A,RNAME1-1(B)
+ PUSHJ P,MOVSTR
+ MOVEI A,".
+ IDPB A,D
+ MOVEI A,RNAME2-1(B)
+ PUSHJ P,MOVSTR
+ SUB TP,[2,,2]
+ POP P,A
+ POPJ P,
+
+MOVSTR: HRRZ 0,(A) ; CHAR COUNT
+ MOVE A,1(A) ; BYTE POINTER
+ SOJL 0,CPOPJ
+ ILDB C,A ; GET CHAR
+ IDPB C,D ; MUNG IT UP
+ JRST .-3
+
+; MAKE A TENEX ERROR MESSAGE STRING
+
+TGFALS: PUSH TP,$TCHAN
+ PUSH TP,B
+ PUSH P,A ; SAVE ERROR CODE
+ PUSHJ P,TMTNXS ; STRING ON STACK
+ HRROI A,1(E) ; POINT TO SPACE
+ MOVE B,(E) ; ERROR CODE
+ HRLI B,400000 ; FOR ME
+ MOVSI C,-100. ; MAX CHARS
+ ERSTR ; GET TENEX STRING
+ JRST TGFLS1
+ JRST TGFLS1
+
+ MOVEI B,1(E) ; A AND B BOUND STRING
+ SUBM P,E ; RELATIVIZE E
+ PUSHJ P,TNXSTR ; BUILD STRING
+ SUB P,E ; P BACK TO NORMAL
+TGFLS2:
+IFE FNAMS, SUB P,[1,,1] ; FLUSH ERROR CODE SLOT
+IFN FNAMS,[
+ PUSH TP,A
+ PUSH TP,B
+ SKIPN B,-2(TP)
+ JRST TGFLS3
+ PUSHJ P,STSTK
+ MOVEI B,1(E)
+ SUBM P,E
+ MOVSI A,440700
+ HRRI A,(P)
+ MOVEI C,5
+ ILDB 0,A
+ JUMPE 0,.+2
+ SOJG C,.-2
+
+ PUSHJ P,TNXSTR
+ PUSH TP,A
+ PUSH TP,B
+ SUB P,E
+TGFLS3: POP P,A
+ PUSH TP,$TFIX
+ PUSH TP,A
+ MOVEI A,3
+ SKIPN B
+ MOVEI A,2
+]
+IFE FNAMS,[
+ MOVEI A,1
+]
+ PUSHJ P,IILIST ; BUILD LIST
+ MOVSI A,TFALSE ; MAKE IT FALSE
+ SUB TP,[2,,2]
+ POPJ P,
+
+TGFLS1: MOVE P,E ; RESET STACK
+ MOVE A,$TCHSTR
+ MOVE B,CHQUOTE UNKNOWN PROBLEM IN I/O
+ JRST TGFLS2
+
+]
+; OTHER BUFFERED DEVICES JOIN HERE
+
+OPDSK1:
+IFN ITS,[
+ PUSHJ P,FIXREA ; STORE THE "REAL" NAMES INTO THE CHANNEL
+]
+OPBASC: MOVE C,T.SPDL+1(TB) ; C WAS CLOBBERED, GET IT BACK
+ HRRZ A,S.DIR(C) ; FIND OUT IF OPEN IS ASCII OR WORD
+ TRZN A,2 ; SKIP IF BINARY
+ PUSHJ P,OPASCI ; DO IT FOR ASCII
+
+; NOW SET UP IO INSTRUCTION FOR CHANNEL
+
+MAKION: MOVE B,T.CHAN+1(TB)
+ MOVEI C,GETCHR
+ JUMPE A,MAKIO1 ; JUMP IF INPUT
+ MOVEI C,PUTCHR ; ELSE GET INPUT
+ MOVEI 0,80. ; DEFAULT LINE LNTH
+ MOVEM 0,LINLN(B)
+ MOVSI 0,TFIX
+ MOVEM 0,LINLN-1(B)
+MAKIO1:
+ HRLI C,(PUSHJ P,)
+ MOVEM C,IOINS(B) ; STORE IT
+ JUMPN A,OPNWIN ; GET AN EOF FORM FOR INPUT CHANNEL
+
+; HERE TO CONS UP <ERROR END-OF-FILE>
+
+EOFMAK: MOVSI C,TATOM
+ MOVE D,EQUOTE END-OF-FILE
+ PUSHJ P,INCONS
+ MOVEI E,(B)
+ MOVSI C,TATOM
+ MOVE D,IMQUOTE ERROR
+ PUSHJ P,ICONS
+ MOVE D,T.CHAN+1(TB) ; RESTORE CHANNEL
+ MOVSI 0,TFORM
+ MOVEM 0,EOFCND-1(D)
+ MOVEM B,EOFCND(D)
+
+OPNWIN: MOVEI 0,10. ; SET UP RADIX
+ MOVSI A,TCHAN ; OPEN SUCCEEDED, RET CHANNEL
+ MOVE B,T.CHAN+1(TB)
+ MOVEM 0,RADX(B)
+
+OPNRET: MOVE D,T.CHAN+1(TB) ; IN CASE WE RECYCLE IT
+ MOVE C,(P) ; RET ADDR
+ SUB P,[S.X3+2,,S.X3+2]
+ SUB TP,[T.CHAN+2,,T.CHAN+2]
+ JRST (C)
+\f
+
+; HERE TO CREATE CHARACTER BUFFERS FOR ASCII I/O
+
+OPASCI: PUSH P,A ; CONTAINS MODE, SAVE IT
+ MOVEI A,BUFLNT ; GET SIZE OF BUFFER
+ PUSHJ P,IBLOCK ; GET STORAGE
+ MOVSI 0,TWORD+.VECT. ; SET UTYPE
+ MOVEM 0,BUFLNT(B) ; AND STORE
+ MOVSI A,TCHSTR
+ SKIPE (P) ; SKIP IF INPUT
+ JRST OPASCO
+ MOVEI D,BUFLNT-1(B) ; REST BYTE POINTER
+OPASCA: HRLI D,010700
+ MOVE B,T.CHAN+1(TB) ; GET CHANNEL BACK
+ MOVEI 0,C.BUF
+ IORM 0,-2(B) ; TURN ON BUFFER BIT
+ MOVEM A,BUFSTR-1(B)
+ MOVEM D,BUFSTR(B) ; CLOBBER
+ POP P,A
+ POPJ P,
+
+OPASCO: HRROI C,777776
+ MOVEM C,(B) ; -1 THE BUFFER (LEAVE OFF LOW BIT)
+ MOVSI C,(B)
+ HRRI C,1(B) ; BUILD BLT POINTER
+ BLT C,BUFLNT-1(B) ; ZAP
+ MOVEI D,-1(B) ; START MAKING STRING POINTER
+ HRRI A,BUFLNT*5 ; SET UP CHAR COUNT
+ JRST OPASCA
+\f
+
+; OPEN NON FILE ORIENTED DEVICES (NUL, PTR, PTP ETC.)
+
+IFN ITS,[
+ONUL:
+OPTP:
+OPTR: PUSHJ P,OPEN0 ; SET UP MODE AND OPEN
+ SETZM S.NM1(C) ; CLOBBER UNINTERESTING FIELDS
+ SETZM S.NM2(C)
+ SETZM S.SNM(C)
+ JRST OPDSK1
+
+; OPEN DEVICES THAT IGNORE SNAME
+
+OUTN: PUSHJ P,OPEN0
+ SETZM S.SNM(C)
+ JRST OPDSK1
+
+]
+
+; INTERNAL CHANNEL OPENER
+
+OINT: HRRZ A,S.DIR(C) ; CHECK DIR
+ CAIL A,2 ; READ/PRINT?
+ JRST WRONGD ; NO, LOSE
+
+ MOVE 0,INTINS(A) ; GET INS
+ MOVE D,T.CHAN+1(TB) ; AND CHANNEL
+ MOVEM 0,IOINS(D) ; AND CLOBBER
+ MOVEI 0,C.OPN+C.READ
+ TRNE A,1
+ MOVEI 0,C.OPN+C.PRIN
+ HRRM 0,-2(D)
+ SETOM STATUS(D) ; MAKE SURE NOT AA TTY
+ PMOVEM T.XT(TB),INTFCN-1(D)
+
+; HERE TO SAVE PSEUDO CHANNELS
+
+SAVCHN: HRRZ E,CHNL0+1 ; POINT TO CURRENT LIST
+ MOVSI C,TCHAN
+ PUSHJ P,ICONS ; CONS IT ON
+ HRRZM B,CHNL0+1
+ JRST OPNWIN
+
+; INT DEVICE I/O INS
+
+INTINS: PUSHJ P,GTINTC
+ PUSHJ P,PTINTC
+\f
+
+; HERE TO OPEN THE NET DEVICE (I.E. THE ARPA NET)
+
+IFN ITS,[
+ONET: HRRZ A,S.DIR(C) ; DIRECTION CODE
+ CAILE A,1 ; ASCII ?
+ IORI A,4 ; TURN ON IMAGE BIT
+ SKIPGE S.NM1(C) ; NAME1 I.E. LOCAL HOST GIVEN
+ IORI A,10 ; NO, WE WILL LET ITS GIVE US ONE
+ SKIPGE S.NM2(C) ; NORMAL OR "LISTEN"
+ IORI A,20 ; TURN ON LISTEN BIT
+ MOVEI 0,7 ; DEFAULT BYTE SIZE
+ TRNE A,2 ; UNLESS
+ MOVEI 0,36. ; IMAGE WHICH IS 36
+ SKIPN T.XT(TB) ; BYTE SIZE GIVEN?
+ MOVEM 0,S.X1(C) ; NO, STORE DEFAULT
+ SKIPG D,S.X1(C) ; BYTE SIZE REASONABLE?
+ JRST RBYTSZ ; NO <0, COMPLAIN
+ TRNE A,2 ; SKIP TO CHECK ASCII
+ JRST ONET2 ; CHECK IMAGE
+ CAIN D,7 ; 7-BIT WINS
+ JRST ONET1
+ CAIE D,44 ; 36-BIT INDICATES BLOCK ASCII MODE
+ JRST .+3
+ IORI A,2 ; SET BLOCK FLAG
+ JRST ONET1
+ IORI A,40 ; USE 8-BIT MODE
+ CAIN D,10 ; IS IT RIGHT
+ JRST ONET1 ; YES
+]
+
+RBYTSZ: ERRUUO EQUOTE BYTE-SIZE-BAD
+
+IFN ITS,[
+ONET2: CAILE D,36. ; IMAGE SIZE REASONABLE?
+ JRST RBYTSZ ; NO
+ CAIN D,36. ; NORMAL
+ JRST ONET1 ; YES, DONT SET FIELD
+
+ ASH D,9. ; POSITION FOR FIELD
+ IORI A,40(D) ; SET IT AND ITS BIT
+
+ONET1: HRLM A,S.DIR(C) ; CLOBBER OPEN BLOCK
+ MOVE E,A ; SAVE BLOCK MODE INFO
+ PUSHJ P,OPEN1 ; DO THE OPEN
+ PUSH P,E
+
+; CLOBBER REAL SLOTS FOR THE OPEN
+
+ MOVEI A,3 ; GET STATE VECTOR
+ PUSHJ P,IBLOCK
+ MOVSI A,TUVEC
+ MOVE D,T.CHAN+1(TB)
+ HLLM A,BUFRIN-1(D)
+ MOVEM B,BUFRIN(D)
+ MOVSI A,TFIX+.VECT. ; SET U TYPE
+ MOVEM A,3(B)
+ MOVE C,T.SPDL+1(TB)
+ MOVE B,T.CHAN+1(TB)
+
+ PUSHJ P,INETST ; GET STATE
+
+ POP P,A ; IS THIS BLOCK MODE
+ MOVEI 0,80. ; POSSIBLE LINE LENGTH
+ TRNE A,1 ; SKIP IF INPUT
+ MOVEM 0,LINLN(B)
+ TRNN A,2 ; BLOCK MODE?
+ JRST .+3
+ TRNN A,4 ; ASCII MODE?
+ JRST OPBASC ; GO SETUP BLOCK ASCII
+ MOVE 0,[PUSHJ P,DOIOT]
+ MOVEM 0,IOINS(B)
+
+ JRST OPNWIN
+
+; INTERNAL ROUTINE TO GET THE CURRENT STATE OF THE NETWROK CHANNEL
+
+INETST: MOVE A,S.NM1(C)
+ MOVEM A,RNAME1(B)
+ MOVE A,S.NM2(C)
+ MOVEM A,RNAME2(B)
+ LDB A,[1100,,S.SNM(C)]
+ MOVEM A,RSNAME(B)
+
+ MOVE E,BUFRIN(B) ; GET STATE BLOCK
+INTST1: HRRE 0,S.X1(C)
+ MOVEM 0,(E)
+ ADDI C,1
+ AOBJN E,INTST1
+
+ POPJ P,
+\f
+
+; ACCEPT A CONNECTION
+
+MFUNCTION NETACC,SUBR
+
+ PUSHJ P,ARGNET ; CHECK THAT ARG IS AN OPEN NET CHANNEL
+ MOVE A,CHANNO(B) ; GET CHANNEL
+ LSH A,23. ; TO AC FIELD
+ IOR A,[.NETACC]
+ XCT A
+ JRST IFALSE ; RETURN FALSE
+NETRET: MOVE A,(AB)
+ MOVE B,1(AB)
+ JRST FINIS
+
+; FORCE SYSTEM NETWORK BUFFERS TO BE SENT
+
+MFUNCTION NETS,SUBR
+
+ PUSHJ P,ARGNET
+ CAME A,MODES+1
+ CAMN A,MODES+3
+ SKIPA A,CHANNO(B) ; GET CHANNEL
+ JRST WRONGD
+ LSH A,23.
+ IOR A,[.NETS]
+ XCT A
+ JRST NETRET
+
+; SUBR TO RETURN UPDATED NET STATE
+
+MFUNCTION NETSTATE,SUBR
+
+ PUSHJ P,ARGNET ; IS IT A NET CHANNEL
+ PUSHJ P,INSTAT
+ JRST FINIS
+
+; INTERNAL NETSTATE ROUTINE
+
+INSTAT: MOVE C,P ; GET PDL BASE
+ MOVEI 0,S.X3 ; # OF SLOTS NEEDED
+ PUSH P,[0]
+ SOJN 0,.-1
+; RESTORED FROM MUDDLE 54. IT SEEMED TO WORK THERE, AND THE STUFF
+; COMMENTED OUT HERE CERTAINLY DOESN'T.
+ MOVEI D,S.DEV(C)
+ HRL D,CHANNO(B)
+ .RCHST D,
+; HRR D,CHANNO(B) ; SETUP FOR RFNAME CALL
+; DOTCAL RFNAME,[D,[2003,,S.DEV],[2003,,S.NM1],[2003,,S.NM2],[2003,,S.SNM]]
+; .LOSE %LSFIL ; THIS MAY NOT BE DESIRABLE, BUT I ASSUME WE CARE IF
+ ; LOSSAGE
+ PUSHJ P,INETST ; INTO VECTOR
+ SUB P,[S.X3,,S.X3]
+ MOVE B,BUFRIN(B)
+ MOVSI A,TUVEC
+ POPJ P,
+]
+; INTERNAL ROUTINE TO CHECK FOR CORRECT CHANNEL TYPE
+
+ARGNET: ENTRY 1
+ GETYP 0,(AB)
+ CAIE 0,TCHAN
+ JRST WTYP1
+ MOVE B,1(AB) ; GET CHANNEL
+ SKIPN CHANNO(B) ; OPEN?
+ JRST CHNCLS
+ MOVE A,RDEVIC-1(B) ; GET DEV NAME
+ MOVE B,RDEVIC(B)
+ PUSHJ P,STRTO6
+ POP P,A
+ CAME A,[SIXBIT /NET /]
+ JRST NOTNET
+ MOVE B,1(AB)
+ MOVE A,DIRECT-1(B) ; CHECK FOR A READ SOCKET
+ MOVE B,DIRECT(B)
+ PUSHJ P,STRTO6
+ MOVE B,1(AB) ; RESTORE CHANNEL
+ POP P,A
+ POPJ P,
+\f
+IFE ITS,[
+
+; TENEX NETWRK OPENING CODE
+
+ONET: MOVE B,T.CHAN+1(TB) ; GET CHANNEL
+ MOVSI C,100700
+ HRRI C,1(P)
+ MOVE E,P
+ PUSH P,[ASCII /NET:/] ; FOR STRINGS
+ GETYP 0,RNAME1-1(B) ; CHECK TYPE
+ CAIE 0,TFIX ; SKIP IF # SUPPLIED
+ JRST ONET1
+ MOVE 0,RNAME1(B) ; GET IT
+ PUSHJ P,FIXSTK
+ JFCL
+ JRST ONET2
+ONET1: CAIE 0,TCHSTR
+ JRST WRONGT
+ HRRZ 0,RNAME1-1(B)
+ MOVE B,RNAME1(B)
+ JUMPE 0,ONET2
+ ILDB A,B
+ JSP D,ONETCH
+ SOJA 0,.-3
+ONET2: MOVEI A,".
+ JSP D,ONETCH
+ MOVE B,T.CHAN+1(TB)
+ GETYP 0,RNAME2-1(B)
+ CAIE 0,TFIX
+ JRST ONET3
+ GETYP 0,RSNAME-1(B)
+ CAIE 0,TFIX
+ JRST WRONGT
+ MOVE 0,RSNAME(B)
+ CAIG 0,377 ;NEW STYLE 32 BIT HOST NUMBER?
+ JRST ONET2A
+;CONVERT HOSTS2 HOST NUMBERS TO INTERNET (TOPS-20) HOST NUMBERS
+ MOVEI A,0
+ LDB B,[001100,,0] ;HOST NUMBER: 1.1-1.9 ->
+ DPB B,[201000,,A] ; 2.8-3.6
+ LDB B,[111100,,0] ;IMP LOW BITS: 2.1-2.9 ->
+ DPB B,[001000,,A] ; 1.1-1.8
+ LDB B,[221100,,0] ;IMP HIGH BITS: 3.1-3.9 ->
+ DPB B,[101000,,A] ; 1.9-2.7
+ LDB B,[331100,,0] ;NETWORK: 4.1-4.9 ->
+ DPB B,[301000,,A] ; 3.7-4.5
+ MOVE 0,A
+ONET2A: PUSHJ P,FIXSTK
+ JRST ONET4
+ MOVE B,T.CHAN+1(TB)
+ MOVEI A,"-
+ JSP D,ONETCH
+ MOVE 0,RNAME2(B)
+ PUSHJ P,FIXSTK
+ JRST WRONGT
+ JRST ONET4
+ONET3: CAIE 0,TCHSTR
+ JRST WRONGT
+ HRRZ 0,RNAME2-1(B)
+ MOVE B,RNAME2(B)
+ JUMPE 0,ONET4
+ ILDB A,B
+ JSP D,ONETCH
+ SOJA 0,.-3
+
+ONET4:
+ONET5: MOVE B,T.CHAN+1(TB)
+ GETYP 0,RNAME2-1(B)
+ CAIN 0,TCHSTR
+ JRST ONET6
+ MOVEI A,";
+ JSP D,ONETCH
+ MOVEI A,"T
+ JSP D,ONETCH
+ONET6: MOVSI A,1
+ HRROI B,1(E) ; STRING POINTER
+ GTJFN ; GET THE G.D JFN
+ TDZA 0,0 ; REMEMBER FAILURE
+ MOVEI 0,1
+ MOVE P,E ; RESTORE P
+ JUMPE 0,GTJLOS ; CONS UP ERROR STRING
+
+ MOVE B,T.CHAN+1(TB)
+ HRRZM A,CHANNO(B) ; SAVE THE JFN
+
+ MOVE C,T.SPDL+1(TB)
+ MOVE D,S.DIR(C)
+ MOVEI B,10
+ TRNE D,2
+ MOVEI B,36.
+ SKIPE T.XT(TB)
+ MOVE B,T.XT+1(TB)
+ JUMPL B,RBYTSZ
+ CAILE B,36.
+ JRST RBYTSZ
+ ROT B,-6
+ TLO B,3400
+ HRRI B,200000
+ TRNE D,1 ; SKIP FOR INPUT
+ HRRI B,100000
+ ANDI A,-1 ; ISOLATE JFCN
+ OPENF
+ JRST OPFLOS ; REPORT ERROR
+ MOVE B,T.CHAN+1(TB)
+ ASH A,1 ; POINT TO SLOT
+ ADDI A,CHNL0 ; TO REAL SLOT
+ MOVEM B,1(A) ; SAVE CHANNEL
+ MOVE C,T.SPDL+1(TB) ; POINT TO P BASE
+ HRRZ A,S.DIR(C) ; 0/ 0 FOR READ 0/ 1 FOR PRINT
+ MOVEI 0,C.OPN+C.READ
+ TRNE A,1
+ MOVEI 0,C.OPN+C.PRIN
+ TRNE A,2
+ TRO 0,C.BIN
+ HRRM 0,-2(B)
+ MOVE A,CHANNO(B)
+ CVSKT ; GET ABS SOCKET #
+ FATAL NETWORK BITES THE BAG!
+ MOVE D,B
+ MOVE B,T.CHAN+1(TB)
+ MOVEM D,RNAME1(B)
+ MOVSI 0,TFIX
+ MOVEM 0,RNAME1-1(B)
+
+ MOVSI 0,TFIX
+ MOVEM 0,RNAME2-1(B)
+ MOVEM 0,RSNAME-1(B)
+ MOVE C,T.SPDL+1(TB)
+ MOVE C,S.DIR(C)
+ MOVE 0,[PUSHJ P,DONETO]
+ TRNN C,1 ; SKIP FOR OUTPUT
+ MOVE 0,[PUSHJ P,DONETI]
+ MOVEM 0,IOINS(B)
+ MOVEI 0,80. ; LINELENGTH
+ TRNE C,1 ; SKIP FOR INPUT
+ MOVEM 0,LINLN(B)
+ MOVEI A,3 ; GET STATE UVECTOR
+ PUSHJ P,IBLOCK
+ MOVSI 0,TFIX+.VECT.
+ MOVEM 0,3(B)
+ MOVE C,B
+ MOVE B,T.CHAN+1(TB)
+ MOVEM C,BUFRIN(B)
+ MOVSI 0,TUVEC
+ HLLM 0,BUFRIN-1(B)
+ MOVE B,CHANNO(B) ; GET JFN
+ MOVEI A,4 ; CODE FOR GTNCP
+ MOVEI C,1(P)
+ ADJSP P,4 ; ROOM FOR DATA
+ MOVE D,[-4,,1] ; GET FHOST, LOC SOC, F SOC
+ GTNCP
+ FATAL NET LOSSAGE ; GET STATE
+ MOVE B,(P)
+ MOVE D,-1(P)
+ MOVE C,-3(P)
+ ADJSP P,-4
+ MOVE E,T.CHAN+1(TB)
+ MOVEM D,RNAME2(E)
+ MOVEM C,RSNAME(E)
+ MOVE C,BUFRIN(E)
+ MOVEM B,(C) ; INITIAL STATE STORED
+ MOVE B,E
+ JRST OPNWIN
+
+; DOIOT FOR TENEX NETWRK
+
+DONETO: PUSH P,0
+ MOVE 0,[BOUT]
+ JRST .+3
+
+DONETI: PUSH P,0
+ MOVE 0,[BIN]
+ PUSH P,0
+ PUSH TP,$TCHAN
+ PUSH TP,B
+ MOVEI 0,(A) ; POSSIBLE OUTPUT CHAR TO 0
+ MOVE A,CHANNO(B)
+ MOVE B,0
+ ENABLE
+ XCT (P)
+ DISABLE
+ MOVEI A,(B) ; RET CHAR IN A
+ MOVE B,(TP)
+ MOVE 0,-1(P)
+ SUB P,[2,,2]
+ SUB TP,[2,,2]
+ POPJ P,
+
+NETPRS: MOVEI D,0
+ HRRZ 0,(C)
+ MOVE C,1(C)
+
+ONETL: ILDB A,C
+ CAIN A,"#
+ POPJ P,
+ SUBI A,60
+ ASH D,3
+ IORI D,(A)
+ SOJG 0,ONETL
+ AOS (P)
+ POPJ P,
+
+FIXSTK: CAMN 0,[-1]
+ POPJ P,
+ JFFO 0,FIXS3 ; PUT OCTAL DIGITS INTO STIRNG
+ MOVEI A,"0
+ POP P,D
+ AOJA D,ONETCH
+FIXS3: IDIVI A,3
+ MOVEI B,12.
+ SUBI B,(A)
+ HRLM B,(P)
+ IMULI A,3
+ LSH 0,(A)
+ POP P,B
+FIXS2: MOVEI A,0
+ ROTC 0,3 ; NEXT DIGIT
+ ADDI A,60
+ JSP D,ONETCH
+ SUB B,[1,,0]
+ TLNN B,-1
+ JRST 1(B)
+ JRST FIXS2
+
+ONETCH: IDPB A,C
+ TLNE C,760000 ; SKIP IF NEW WORD
+ JRST (D)
+ PUSH P,[0]
+ JRST (D)
+
+INSTAT: MOVE E,B
+ MOVE B,CHANNO(B) ; GET JFN
+ MOVEI A,4 ; CODE FOR GTNCP
+ MOVEI C,1(P)
+ ADJSP P,4 ; ROOM FOR DATA
+ MOVE D,[-4,,1] ; GET FHOST, LOC SOC, F SOC
+ GTNCP
+ FATAL NET LOSSAGE ; GET STATE
+ MOVE B,(P)
+ MOVE D,-1(P)
+ MOVE C,-3(P)
+ ADJSP P,-4
+ MOVEM D,RNAME2(E) ; UPDATE FOREIGN SOCHKET
+ MOVEM C,RSNAME(E) ; AND HOST
+ MOVE C,BUFRIN(E)
+ XCT ITSTRN(B) ; XLATE TO LOOK MORE LIKE ITS
+ MOVEM B,(C) ; STORE STATE
+ MOVE B,E
+ POPJ P,
+\r
+ITSTRN: MOVEI B,0\r
+ JRST NLOSS\r
+ JRST NLOSS\r
+ MOVEI B,1\r
+ MOVEI B,2\r
+ JRST NLOSS\r
+ MOVEI B,4\r
+ PUSHJ P,NOPND\r
+ MOVEI B,0\r
+ JRST NLOSS\r
+ JRST NLOSS\r
+ PUSHJ P,NCLSD\r
+ MOVEI B,0\r
+ JRST NLOSS\r
+ MOVEI B,0
+
+NLOSS: FATAL ILLEGAL NETWORK STATE
+
+NOPND: MOVE B,DIRECT(E) ; SEE IF READ OR PRINT
+ ILDB B,B ; GET 1ST CHAR
+ CAIE B,"R ; SKIP FOR READ
+ JRST NOPNDW
+ SIBE ; SEE IF INPUT EXISTS
+ JRST .+3
+ MOVEI B,5
+ POPJ P,
+ MOVEM B,2(C) ; STORE BYTES IN STATE VECTOR
+ MOVEI B,11 ; RETURN DATA PRESENT STATE
+ POPJ P,
+
+NOPNDW: SOBE ; SEE IF OUTPUT PRESENT
+ JRST .+3
+ MOVEI B,5
+ POPJ P,
+
+ MOVEI B,6
+ POPJ P,
+
+NCLSD: MOVE B,DIRECT(E)
+ ILDB B,B
+ CAIE B,"R
+ JRST RET0
+ SIBE
+ JRST .+2
+ JRST RET0
+ MOVEI B,10
+ POPJ P,
+
+RET0: MOVEI B,0
+ POPJ P,
+
+
+MFUNCTION NETSTATE,SUBR
+
+ PUSHJ P,ARGNET
+ PUSHJ P,INSTAT
+ MOVE B,BUFRIN(B)
+ MOVSI A,TUVEC
+ JRST FINIS
+
+MFUNCTION NETS,SUBR
+
+ PUSHJ P,ARGNET
+ CAME A,MODES+1 ; PRINT OR PRINTB?
+ CAMN A,MODES+3
+ SKIPA A,CHANNO(B)
+ JRST WRONGD
+ MOVEI B,21
+ MTOPR
+NETRET: MOVE B,1(AB)
+ MOVSI A,TCHAN
+ JRST FINIS
+
+MFUNCTION NETACC,SUBR
+
+ PUSHJ P,ARGNET
+ MOVE A,CHANNO(B)
+ MOVEI B,20
+ MTOPR
+ JRST NETRET
+
+]
+\f
+; HERE TO OPEN TELETYPE DEVICES
+
+OTTY: HRRZ A,S.DIR(C) ; GET DIR CODE
+ TRNE A,2 ; SKIP IF NOT READB/PRINTB
+ JRST WRONGD ; CANT DO THAT
+
+IFN ITS,[
+ MOVE A,S.NM1(C) ; CHECK FOR A DIR
+ MOVE 0,S.NM2(C)
+ CAMN A,[SIXBIT /.FILE./]
+ CAME 0,[SIXBIT /(DIR)/]
+ SKIPA E,[-15.*2,,]
+ JRST OUTN ; DO IT THAT WAY
+
+ HRRZ A,S.DIR(C) ; CHECK DIR
+ TRNE A,1
+ JRST TTYLP2
+ HRRI E,CHNL1
+ PUSH P,S.DEV(C) ; SAVE THE SIXBIT DEV NAME
+ ; HRLZS (P) ; POSTITION DEVICE NAME
+
+TTYLP: SKIPN D,1(E) ; CHANNEL OPEN?
+ JRST TTYLP1 ; NO, GO TO NEXT
+ MOVE A,RDEVIC-1(D) ; GET DEV NAME
+ MOVE B,RDEVIC(D)
+ PUSHJ P,STRTO6 ; TO 6 BIT
+ POP P,A ; GET RESULT
+ CAMN A,(P) ; SAME?
+ JRST SAMTYQ ; COULD BE THE SAME
+TTYLP1: ADD E,[2,,2]
+ JUMPL E,TTYLP
+ SUB P,[1,,1] ; THIS ONE MUST BE UNIQUE
+TTYLP2: MOVE C,T.SPDL+1(TB) ; POINT TO P BASE
+ HRRZ A,S.DIR(C) ; GET DIR OF OPEN
+ SKIPE A ; IF OUTPUT,
+ IORI A,20 ; THEN USE DISPLAY MODE
+ HRLM A,S.DIR(C) ; STORE IN OPEN BLOCK
+ PUSHJ P,OPEN2 ; OPEN THE TTY
+ MOVE A,S.DEV(C) ; GET DEVICE NAME
+ PUSHJ P,6TOCHS ; TO A STRING
+ MOVE D,T.CHAN+1(TB) ; POINT TO CHANNEL
+ MOVEM A,RDEVIC-1(D)
+ MOVEM B,RDEVIC(D)
+ MOVE C,T.SPDL+1(TB) ; RESTORE PDL BASE
+ MOVE B,D ; CHANNEL TO B
+ HRRZ 0,S.DIR(C) ; AND DIR
+ JUMPE 0,TTYSPC
+TTY1: DOTCAL TTYGET,[CHANNO(B),[2000,,0],[2000,,A],[2000,,D]]
+ .LOSE %LSSYS
+ DOTCAL TTYSET,[CHANNO(B),MODE1,MODE2,D]
+ .LOSE %LSSYS
+ MOVE A,[PUSHJ P,GMTYO]
+ MOVEM A,IOINS(B)
+ DOTCAL RSSIZE,[CHANNO(B),[2000,,A],[2000,,D]]
+ .LOSE %LSSYS
+ MOVEM D,LINLN(B)
+ MOVEM A,PAGLN(B)
+ JRST OPNWIN
+
+; MAKE AN IOT
+
+IOTMAK: HRLZ A,CHANNO(B) ; GET CHANNEL
+ ROT A,5
+ IOR A,[.IOT A] ; BUILD IOT
+ MOVEM A,IOINS(B) ; AND STORE IT
+ POPJ P,
+\f
+
+; HERE IF POSSIBLY OPENING AN ALREADY OPEN TTY
+
+SAMTYQ: MOVE D,1(E) ; RESTORE CURRENT CHANNEL
+ MOVE A,DIRECT-1(D) ; GET DIR
+ MOVE B,DIRECT(D)
+ PUSHJ P,STRTO6
+ POP P,A ; GET SIXBIT
+ MOVE C,T.SPDL+1(TB)
+ HRRZ C,S.DIR(C)
+ CAME A,MODES(C) ; SKIP IF DIFFERENT DIRECTION
+ JRST TTYLP1
+
+; HERE IF A RE-OPEN ON A TTY
+
+ HRRZ 0,FSAV(TB) ; IS IT FROM A FOPEN
+ CAIN 0,FOPEN
+ JRST RETOLD ; RET OLD CHANNEL
+
+ PUSH TP,$TCHAN
+ PUSH TP,1(E) ; PUSH OLD CHANNEL
+ PUSH TP,$TFIX
+ PUSH TP,T.CHAN+1(TB)
+ MOVE A,[PUSHJ P,CHNFIX]
+ MOVEI PVP,0 ; SAY MIGHT BE NON-ATOMS
+ PUSHJ P,GCHACK
+ SUB TP,[4,,4]
+
+RETOLD: MOVE B,1(E) ; GET CHANNEL
+ AOS CHANNO-1(B) ; AOS REF COUNT
+ MOVSI A,TCHAN
+ SUB P,[1,,1] ; CLEAN UP STACK
+ JRST OPNRET ; AND LEAVE
+
+
+; ROUTINE TO PASS TO GCHACK TO FIX UP CHANNEL POINTER
+
+CHNFIX: CAIN C,TCHAN
+ CAME D,(TP)
+ POPJ P,
+ MOVE D,-2(TP) ; GET REPLACEMENT
+ SKIPE B
+ MOVEM D,1(B) ; CLOBBER IT AWAY
+ POPJ P,
+]\f
+
+IFE ITS,[
+ MOVE C,T.SPDL+1(TB) ; POINT TO P BASE
+ HRRZ 0,S.DIR(C) ; 0/ 0 FOR READ 0/ 1 FOR PRINT
+ MOVE A,[PUSHJ P,INMTYO]
+ MOVE B,T.CHAN+1(TB)
+ MOVEM A,IOINS(B)
+ MOVEI A,100 ; PRIM INPUT JFN
+ JUMPN 0,TNXTY1
+ MOVEI E,C.OPN+C.READ+C.TTY
+ HRRM E,-2(B)
+ MOVEM B,CHNL0+2*100+1
+ JRST TNXTY2
+TNXTY1: MOVEM B,CHNL0+2*101+1
+ MOVEI A,101 ; PRIM OUTPUT JFN
+ MOVEI E,C.OPN+C.PRIN+C.TTY
+ HRRM E,-2(B)
+TNXTY2: MOVEM A,CHANNO(B)
+ JUMPN 0,OPNWIN
+]
+; SETUP FUNNY BUFFER FOR TTY INPUT DEVICES
+
+TTYSPC: MOVEI A,EXTBFR ; GET EXTRA BUFFER
+ PUSHJ P,IBLOCK ; GET BLOCK
+ MOVE D,T.CHAN+1(TB) ;RESTORE CHANNEL POINTER
+IFN ITS,[
+ MOVE A,CHANNO(D)
+ LSH A,23.
+ IOR A,[.IOT A]
+ MOVEM A,IOIN2(B)
+]
+IFE ITS,[
+ MOVE A,[PBIN]
+ MOVEM A,IOIN2(B)
+]
+ MOVSI A,TLIST
+ MOVEM A,EXBUFR-1(D) ; FOR WAITING TTY BUFFERS
+ SETZM EXBUFR(D) ; NIL LIST
+ MOVEM B,BUFRIN(D) ;STORE IN CHANNEL
+ MOVSI A,TUVEC ;MAKE SURE TYPE IS UNIFORM VECTOR
+ HLLM A,BUFRIN-1(D)
+ MOVEI A,177 ;SET ERASER TO RUBOUT
+ MOVEM A,ERASCH(B)
+IFE ITS,[
+ MOVEI A,25
+ MOVEM A,KILLCH(B)
+]
+IFN ITS,[
+ SETZM KILLCH(B) ;NO KILL CHARACTER NEEDED
+]
+ MOVEI A,33 ;BREAKCHR TO C.R.
+ MOVEM A,BRKCH(B)
+ MOVEI A,"\ ;ESCAPER TO \
+ MOVEM A,ESCAP(B)
+ MOVE A,[010700,,BYTPTR(E)] ;RELATIVE BYTE POINTER
+ MOVEM A,BYTPTR(B)
+ MOVEI A,14 ;BARF BACK CHARACTER FF
+ MOVEM A,BRFCHR(B)
+ MOVEI A,^D
+ MOVEM A,BRFCH2(B)
+
+; SETUP DEFAULT TTY INTERRUPT HANDLER
+
+ PUSH TP,$TATOM
+ PUSH TP,MQUOTE CHAR,CHAR,INTRUP
+ PUSH TP,$TFIX
+ PUSH TP,[10] ; PRIORITY OF CHAR INT
+ PUSH TP,$TCHAN
+ PUSH TP,D
+ MCALL 3,EVENT ; 1ST MAKE AN EVENT EXIST
+ PUSH TP,A
+ PUSH TP,B
+ PUSH TP,$TSUBR
+ PUSH TP,[QUITTER] ; DEFAULT HANDLER IS QUITTER
+ MCALL 2,HANDLER
+
+; BUILD A NULL STRING
+
+ MOVEI A,0
+ PUSHJ P,IBLOCK ; USE A BLOCK
+ MOVE D,T.CHAN+1(TB)
+ MOVEI 0,C.BUF
+ IORM 0,-2(D)
+ HRLI B,010700
+ SUBI B,1
+ MOVSI A,TCHSTR
+ MOVEM A,BUFSTR-1(D)
+ MOVEM B,BUFSTR(D)
+ MOVEI A,0
+ MOVE B,D ; CHANNEL TO B
+ JRST MAKION
+\f
+
+; ROUTINE TO OPEN ITS CHANNEL WITHOUT .RCHST
+
+IFN ITS,[
+OPEN2: MOVEI A,S.DIR(C) ; POINT TO OPEN BLOCK
+ PUSHJ P,MOPEN ; OPEN THE FILE
+ JRST OPNLOS
+ MOVE B,T.CHAN+1(TB) ; GET CHANNEL BACK
+ MOVEM A,CHANNO(B) ; SAVE THE CHANNEL
+ JRST OPEN3
+
+; FIX UP MODE AND FALL INTO OPEN
+
+OPEN0: HRRZ A,S.DIR(C) ; GET DIR
+ TRNE A,2 ; SKIP IF NOT BLOCK
+ IORI A,4 ; TURN ON IMAGE
+ IORI A,2 ; AND BLOCK
+
+ PUSH P,A
+ PUSH TP,$TPDL
+ PUSH TP,C ; SAVE CRUFT TO CHECK FOR PRINTO, HA HA
+ MOVE B,T.CHAN+1(TB)
+ MOVE A,DIRECT-1(B)
+ MOVE B,DIRECT(B) ; THIS KLUDGE THE MESS OF NDR
+ PUSHJ P,STRTO6
+ MOVE C,(TP)
+ POP P,D ; THE SIXBIT FOR KLUDGE
+ POP P,A ; GET BACK THE RANDOM BITS
+ SUB TP,[2,,2]
+ CAME D,[SIXBIT /PRINAO/]
+ CAMN D,[SIXBIT /PRINTO/]
+ IORI A,100000 ; WRITEOVER BIT
+ HRRZ 0,FSAV(TB)
+ CAIN 0,NFOPEN
+ IORI A,10 ; DON'T CHANGE REF DATE
+OPEN9: HRLM A,S.DIR(C) ; AND STORE IT
+
+; ROUTINE TO ATTEMPT TO OPEN A REAL ITS CHANNEL
+
+OPEN1: MOVEI A,S.DIR(C) ; POINT TO OPEN BLOCK
+ PUSHJ P,MOPEN
+ JRST OPNLOS
+ MOVE B,T.CHAN+1(TB) ; GET CHANNEL BACK
+ MOVEM A,CHANNO(B) ; CLOBBER INTO CHANNEL
+ DOTCAL RFNAME,[A,[2003,,S.DEV],[2003,,S.NM1],[2003,,S.NM2],[2003,,S.SNM]]
+ JFCL
+
+; NOW CLOBBER THE TVP SLOT FOR THIS CHANNEL
+
+OPEN3: MOVE A,S.DIR(C)
+ MOVEI 0,C.OPN+C.READ
+ TRNE A,1
+ MOVEI 0,C.OPN+C.PRIN
+ TRNE A,2
+ TRO 0,C.BIN
+ HRRM 0,-2(B)
+ MOVE A,CHANNO(B) ; GET CHANNEL #
+ ASH A,1
+ ADDI A,CHNL0 ; POINT TO SLOT
+ MOVEM B,1(A) ; NOT: TYPE ALREADY SETUP
+
+; NOW GET STATUS WORD
+
+DOSTAT: HRRZ A,CHANNO(B) ; NOW GET STATUS WORD
+ DOTCAL STATUS,[A,[2002,,STATUS]]
+ JFCL
+ POPJ P,
+\f
+
+; HERE IF OPEN FAILS (CHANNEL IS IN A)
+
+OPNLOS: JUMPL A,NOCHAN ; ALL CHANNELS ARE IN USE
+ LSH A,23. ; DO A .STATUS
+ IOR A,[.STATUS A]
+ XCT A ; STATUS TO A
+ MOVE B,T.CHAN+1(TB)
+ PUSHJ P,GFALS ; GET A FALSE WITH A MESSAGE
+ SUB P,[1,,1] ; EXTRA RET ADDR FLUSHED
+ JRST OPNRET ; AND RETURN
+]
+
+CGFALS: SUBM M,(P)
+ MOVEI B,0
+IFN ITS, PUSHJ P,GFALS
+IFE ITS, PUSHJ P,TGFALS
+ JRST MPOPJ
+
+; ROUTINE TO CONS UP FALSE WITH REASON
+IFN ITS,[
+GFALS: PUSH TP,$TCHAN
+ PUSH TP,B
+ PUSH P,[SIXBIT / ERR/] ; SET UP OPEN TO ERR DEV
+ PUSH P,[3] ; SAY ITS FOR CHANNEL
+ PUSH P,A
+ .OPEN 0,-2(P) ; USE CHANNEL 0 FOR THIS
+ FATAL CAN'T OPEN ERROR DEVICE
+ SUB P,[3,,3] ; DONT WANT OPEN BLOCK NOW
+IFN FNAMS, PUSH P,A
+ MOVEI A,0 ; PREPARE TO BUILD STRING ON STACK
+EL1: PUSH P,[0] ; WHERE IT WILL GO
+ MOVSI B,(<440700,,(P)>) ; BYTE POINTER TO TOP OF STACK
+EL2: .IOT 0,0 ; GET A CHAR
+ JUMPL 0,EL3 ; JUMP ON -1,,3
+ CAIN 0,3 ; EOF?
+ JRST EL3 ; YES, MAKE STRING
+ CAIN 0,14 ; IGNORE FORM FEEDS
+ JRST EL2 ; IGNORE FF
+ CAIE 0,15 ; IGNORE CR & LF
+ CAIN 0,12
+ JRST EL2
+ IDPB 0,B ; STUFF IT
+ TLNE B,760000 ; SIP IF WORD FULL
+ AOJA A,EL2
+ AOJA A,EL1 ; COUNT WORD AND GO
+
+EL3:
+IFN FNAMS,[
+ SKIPN (P)
+ SUB P,[1,,1]
+ PUSH P,A
+ .CLOSE 0,
+ PUSHJ P,CHMAK
+ PUSH TP,A
+ PUSH TP,B
+ SKIPN B,-2(TP)
+ JRST EL4
+ MOVEI A,0
+ MOVSI B,(<440700,,(P)>)
+ PUSH P,[0]
+ IRP XX,,[RDEVIC,RSNAME,RNAME1,RNAME2]YY,,[0,72,73,40]
+IFSN YY,0,[
+ MOVEI 0,YY
+ JSP E,1PUSH
+]
+ MOVE E,-2(TP)
+ MOVE C,XX(E)
+ HRRZ D,XX-1(E)
+ JSP E,PUSHIT
+ TERMIN
+]
+ SKIPN (P) ; ANY CHARS AT END?
+ SUB P,[1,,1] ; FLUSH XTRA
+ PUSH P,A ; PUT UP COUNT
+ .CLOSE 0, ; CLOSE THE ERR DEVICE
+ PUSHJ P,CHMAK ; MAKE STRING
+ PUSH TP,A
+ PUSH TP,B
+IFN FNAMS,[
+EL4: POP P,A
+ PUSH TP,$TFIX
+ PUSH TP,A]
+IFE FNAMS, MOVEI A,1
+IFN FNAMS,[
+ MOVEI A,3
+ SKIPN B
+ MOVEI A,2
+]
+ PUSHJ P,IILIST
+ MOVSI A,TFALSE ; MAKEIT A FALSE
+IFN FNAMS, SUB TP,[2,,2]
+ POPJ P,
+
+IFN FNAMS,[
+1PUSH: MOVEI D,0
+ JRST PUSHI2
+PUSHI1: PUSH P,[0]
+ MOVSI B,(<440700,,(P)>)
+PUSHIT: SOJL D,(E)
+ ILDB 0,C
+PUSHI2: IDPB 0,B
+ TLNE B,760000
+ AOJA A,PUSHIT
+ AOJA A,PUSHI1
+]
+]
+\f
+
+; ROUTINE TO FILL IN THE "REAL" SLOTS FOR THE CHANNEL
+
+FIXREA:
+IFE ITS, HRLZS S.DEV(C) ; KILL MODE BITS
+ MOVE D,[-4,,S.DEV]
+
+FIXRE1: MOVEI A,(D) ; COPY REL POINTER
+ ADD A,T.SPDL+1(TB) ; POINT TO SLOT
+ SKIPN A,(A) ; SKIP IF GOODIE THERE
+ JRST FIXRE2
+ PUSHJ P,6TOCHS ; MAKE INOT A STRING
+ MOVE C,RDTBL-S.DEV(D); GET OFFSET
+ ADD C,T.CHAN+1(TB)
+ MOVEM A,-1(C)
+ MOVEM B,(C)
+FIXRE2: AOBJN D,FIXRE1
+ POPJ P,
+
+IFN ITS,[
+DOOPN: HRLZ A,A
+ HRR A,CHANNO(B) ; GET CHANNEL
+ DOTCAL OPEN,[A,-3(P),-2(P),-1(P),(P)]
+ SKIPA
+ AOS -1(P)
+ POPJ P,
+]
+\f
+;THIS ROUTINE CONVERTS MUDDLE CHARACTER STRINGS TO SIXBIT FILE NAMES
+STRTO6: PUSH TP,A
+ PUSH TP,B
+ PUSH P,E ;SAVE USEFUL FROB
+ MOVEI E,(A) ; CHAR COUNT TO E
+ GETYP A,A
+ CAIE A,TCHSTR ; IS IT ONE WORD?
+ JRST WRONGT ;NO
+ CAILE E,6 ; SKIP IF L=? 6 CHARS
+ MOVEI E,6
+CHREAD: MOVEI A,0 ;INITIALIZE OUTPUT WORD
+ MOVE D,[440600,,A] ;AND BYTE POINTER TO IT
+NEXCHR: SOJL E,SIXDON
+ ILDB 0,B ; GET NEXT CHAR
+ CAIN 0,^Q ; CNTL-Q, QUOTES NEXT CHAR
+ JRST NEXCHR
+ JUMPE 0,SIXDON ;IF NULL, WE ARE FINISHED
+ PUSHJ P,A0TO6 ; CONVERT TO SIXBIT
+ IDPB 0,D ;DEPOSIT INTO SIX BIT
+ JRST NEXCHR ; NO, GET NEXT
+SIXDON: SUB TP,[2,,2] ;FIX UP TP
+ POP P,E
+ EXCH A,(P) ;LEAVE RESULT ON P-STACK
+ JRST (A) ;NOW RETURN
+
+
+;SUBROUTINE TO CONVERT SIXBIT TO ATOM
+
+6TOCHS: PUSH P,E
+ PUSH P,D
+ MOVEI B,0 ;MAX NUMBER OF CHARACTERS
+ PUSH P,[0] ;STRING WILL GO ON P SATCK
+ JUMPE A,GETATM ; EMPTY, LEAVE
+ MOVEI E,-1(P) ;WILL BE BYTE POINTER
+ HRLI E,10700 ;SET IT UP
+ PUSH P,[0] ;SECOND POSSIBLE WORD
+ MOVE D,[440600,,A] ;INPUT BYTE POINTER
+6LOOP: ILDB 0,D ;START CHAR GOBBLING
+ ADDI 0,40 ;CHANGET TOASCII
+ IDPB 0,E ;AND STORE IT
+ TLNN D,770000 ; SKIP IF NOT DONE
+ JRST 6LOOP1
+ TDNN A,MSKS(B) ; CHECK IF JUST SPACES LEFT
+ AOJA B,GETATM ; YES, DONE
+ AOJA B,6LOOP ;KEEP LOOKING
+6LOOP1: PUSH P,[6] ;IF ARRIVE HERE, STRING IS 2 WORDS
+ JRST .+2
+GETATM: MOVEM B,(P) ;SET STRING LENGTH=1
+ PUSHJ P,CHMAK ;MAKE A MUDDLE STRING
+ POP P,D
+ POP P,E
+ POPJ P,
+
+MSKS: 7777,,-1
+ 77,,-1
+ ,,-1
+ 7777
+ 77
+
+
+; CONVERT ONE CHAR
+
+A0TO6: CAIL 0,141 ;IF IT IS GREATER OR EQUAL TO LOWER A
+ CAILE 0,172 ;BUT LESS THAN OR EQUAL TO LOWER Z
+ JRST .+2 ;THEN
+ SUBI 0,40 ;CONVERT TO UPPER CASE
+ SUBI 0,40 ;NOW TO SIX BIT
+ JUMPL 0,BAD6 ;CHECK FOR A WINNER
+ CAILE 0,77
+ JRST BAD6
+ POPJ P,
+\f
+; SUBR TO TEST THE EXISTENCE OF FILES
+
+MFUNCTION FEXIST,SUBR,[FILE-EXISTS?]
+
+ ENTRY
+
+ JUMPGE AB,TFA
+ PUSH TP,$TPDL
+ PUSH TP,P ; SAVE P-STACK BASE
+ ADD TP,[2,,2]
+ MOVSI E,-4 ; 4 THINGS TO PUSH
+EXIST:
+IFN ITS, MOVE B,@RNMTBL(E)
+IFE ITS, MOVE B,@FETBL(E)
+ PUSH P,E
+ PUSHJ P,IDVAL1
+ POP P,E
+ GETYP 0,A
+ CAIE 0,TCHSTR ; SKIP IF WINS
+ JRST EXIST1
+
+IFN ITS, PUSHJ P,STRTO6 ; CONVERT TO SIXBIT
+IFE ITS,[
+; PUSH P,E
+; PUSHJ P,ADDNUL ; NOT NEEDED, SINCE CONSED INTO ONE STRING-TAA
+; POP P,E
+ PUSH TP,A ; DEFAULT TYPE AND VALUE GIVEN BY USER
+ PUSH TP,B ; IN VALUE OF DEV, SNM, NM1, NM2
+ ]
+IFN ITS, JRST .+2
+IFE ITS, JRST .+3
+
+EXIST1:
+IFN ITS, PUSH P,EXISTS(E) ; USE DEFAULT
+IFE ITS,[
+ PUSH TP,FETYP(E) ; DEFAULT TYPE AND VALUE IF NO
+ PUSH TP,FEVAL(E) ; DEFAULT GIVEN BY USER
+ ]
+ AOBJN E,EXIST
+
+ PUSHJ P,RGPRS ; PARSE THE ARGS
+ JRST TMA ; TOO MANY ARGUMENTS
+
+IFN ITS,[
+ MOVE 0,-3(P) ; GET SIXBIT DEV NAME
+ MOVEI B,0
+ CAMN 0,[SIXBITS /DSK /]
+ MOVSI B,10 ; DONT SET REF DATE IF DISK DEV
+ .IOPUSH
+ DOTCAL OPEN,[B,[17,,-3],[17,,-2],[17,,-1],[17,,0]]
+ JRST .+3
+ .IOPOP
+ JRST FDLWON ; WON!!!
+ .STATUS 0,A ; FIND THE STATUS OF CHANNEL BEFORE POPING
+ .IOPOP
+ JRST FDLST1]
+
+IFE ITS,[
+ MOVE B,TB
+ SUBI B,10 ; GET B TO POINT CORRECTLY TO ARGS
+ PUSHJ P,STSTK ; GET FILE NAME IN A STRING
+ HRROI B,1(E) ; POINT B TO THE STRING
+ MOVSI A,100001
+ GTJFN
+ JRST TDLLOS ; FILE DOES NOT EXIST
+ RLJFN ; FILE EXIST SO RETURN JFN
+ JFCL
+ JRST FDLWON ; SUCCESS
+ ]
+
+IFN ITS,[
+EXISTS: SIXBITS /DSK INPUT > /
+ ]
+IFE ITS,[
+FETBL: SETZ IMQUOTE NM1
+ SETZ IMQUOTE NM2
+ SETZ IMQUOTE DEV
+ SETZ IMQUOTE SNM
+
+FETYP: TCHSTR,,5
+ TCHSTR,,3
+ TCHSTR,,3
+ TCHSTR,,0
+
+FEVAL: 440700,,[ASCIZ /INPUT/]
+ 440700,,[ASCIZ /MUD/]
+ 440700,,[ASCIZ /DSK/]
+ 0
+ ]
+\f
+; SUBR TO DELETE AND RENAME FILES
+
+MFUNCTION RENAME,SUBR
+
+ ENTRY
+
+ JUMPGE AB,TFA
+ PUSH TP,$TPDL
+ PUSH TP,P ; SAVE P-STACK BASE
+ GETYP 0,(AB) ; GET 1ST ARG TYPE
+IFN ITS,[
+ CAIN 0,TCHAN ; CHANNEL?
+ JRST CHNRNM ; MUST BE RENAME WHILE OPEN FOR WRITING
+]
+IFE ITS,[
+ PUSH P,[100000,,-2]
+ PUSH P,[377777,,377777]
+]
+ MOVSI E,-4 ; 4 THINGS TO PUSH
+RNMALP: MOVE B,@RNMTBL(E)
+ PUSH P,E
+ PUSHJ P,IDVAL1
+ POP P,E
+ GETYP 0,A
+ CAIE 0,TCHSTR ; SKIP IF WINS
+ JRST RNMLP1
+
+IFN ITS, PUSHJ P,STRTO6 ; CONVERT TO SIXBIT
+IFE ITS,[
+ PUSH P,E
+ PUSHJ P,ADDNUL
+ EXCH B,(P)
+ MOVE E,B
+]
+ JRST .+2
+
+RNMLP1: PUSH P,RNSTBL(E) ; USE DEFAULT
+ AOBJN E,RNMALP
+
+IFN ITS,[
+ PUSHJ P,RGPRS ; PARSE THE ARGS
+ JRST RNM1 ; COULD BE A RENAME
+
+; HERE TO DELETE A FILE
+
+DELFIL: MOVE A,(P) ; AND GET SNAME
+ .SUSET [.SSNAM,,A]
+ DOTCAL DELETE,[[17,,-3],[17,,-2],[17,,-1],[17,,0]]
+ JRST FDLST ; ANALYSE ERROR
+
+FDLWON: MOVSI A,TATOM
+ MOVE B,IMQUOTE T
+ JRST FINIS
+]
+IFE ITS,[
+ MOVE A,(AB)
+ MOVE B,1(AB)
+ PUSHJ P,ADDNUL
+ MOVE A,(TP) ; GET BASE OF PDL
+ MOVEI A,1(A) ; POINT TO CRAP
+ CAMGE AB,[-3,,] ; SKIP IF DELETE
+ HLLZS (A) ; RESET DEFAULT
+ PUSH P,[0]
+ PUSH P,[0]
+ PUSH P,[0]
+ GTJFN ; GET A JFN
+ JRST TDLLOS ; LOST
+ ADD AB,[2,,2] ; PAST ARG
+ MOVEM AB,ABSAV(TB)
+ JUMPL AB,RNM1 ; GO TRY FOR RENAME
+ MOVE P,(TP) ; RESTORE P STACK
+ MOVEI C,(A) ; FOR RELEASE
+ DELF ; ATTEMPT DELETE
+ JRST DELLOS ; LOSER
+ RLJFN ; MAKE SURE FLUSHED
+ JFCL
+
+FDLWON: MOVSI A,TATOM
+ MOVE B,IMQUOTE T
+ JRST FINIS
+
+RNMLOS: PUSH P,A
+ MOVEI A,(B)
+ RLJFN
+ JFCL
+DELLO1: MOVEI A,(C)
+ RLJFN
+ JFCL
+ POP P,A ; ERR NUMBER BACK
+TDLLOS: MOVEI B,0
+ PUSHJ P,TGFALS ; GET FALSE WITH REASON
+ JRST FINIS
+
+DELLOS: PUSH P,A ; SAVE ERROR
+ JRST DELLO1
+]
+
+;TABLE OF REANMAE DEFAULTS
+IFN ITS,[
+RNMTBL: IMQUOTE DEV
+ IMQUOTE NM1
+ IMQUOTE NM2
+ IMQUOTE SNM
+
+RNSTBL: SIXBIT /DSK _MUDS_> /
+]
+IFE ITS,[
+RNMTBL: SETZ IMQUOTE DEV
+ SETZ IMQUOTE SNM
+ SETZ IMQUOTE NM1
+ SETZ IMQUOTE NM2
+
+RNSTBL: -1,,[ASCIZ /DSK/]
+ 0
+ -1,,[ASCIZ /_MUDS_/]
+ -1,,[ASCIZ /MUD/]
+]
+; HERE TO DO A RENAME
+
+RNM1: JUMPGE AB,TMA ; IF ARGS EXHAUSTED, MUST BE TOO MUCH STRING
+ GETYP 0,(AB)
+ MOVE C,1(AB) ; GET ARG
+ CAIN 0,TATOM ; IS IT "TO"
+ CAME C,IMQUOTE TO
+ JRST WRONGT ; NO, LOSE
+ ADD AB,[2,,2] ; BUMP PAST "TO"
+ MOVEM AB,ABSAV(TB)
+ JUMPGE AB,TFA
+IFN ITS,[
+ MOVEM P,T.SPDL+1(TB) ; SAVE NEW P-BASE
+
+ MOVEI 0,4 ; FOUR DEFAULTS
+ PUSH P,-3(P) ; DEFAULT DEVICE IS CURRENT
+ SOJN 0,.-1
+
+ PUSHJ P,RGPRS ; PARSE THE NEXT STRING
+ JRST TMA
+
+ MOVE A,-7(P) ; FIX AND GET DEV1
+ MOVE B,-3(P) ; SAME FOR DEV2
+ CAME A,B ; SAME?
+ JRST DEVDIF
+
+ POP P,A ; GET SNAME 2
+ CAME A,(P)-3 ; SNAME 1
+ JRST DEVDIF
+ .SUSET [.SSNAM,,A]
+ POP P,-2(P) ; MOVE NAMES DOWN
+ POP P,-2(P)
+ DOTCAL RENAME,[[17,,-4],[17,,-3],[17,,-2],A,[17,,-1],(P)]
+ JRST FDLST
+ JRST FDLWON
+
+; HERE FOR RENAME WHILE OPEN FOR WRITING
+
+CHNRNM: ADD AB,[2,,2] ; NEXT ARG
+ MOVEM AB,ABSAV(TB)
+ JUMPGE AB,TFA
+ MOVE B,-1(AB) ; GET CHANNEL
+ SKIPN CHANNO(B) ; SKIP IF OPEN
+ JRST BADCHN
+ MOVE A,DIRECT-1(B) ; CHECK DIRECTION
+ MOVE B,DIRECT(B)
+ PUSHJ P,STRTO6 ; TO 6 BIT
+ POP P,A
+ CAME A,[SIXBIT /PRINT/]
+ CAMN A,[SIXBIT /PRINTB/]
+ JRST CHNRN1
+ CAMN A,[SIXBIT /PRINAO/]
+ JRST CHNRN1
+ CAME A,[SIXBIT /PRINTO/]
+ JRST WRONGD
+
+; SET UP .FDELE BLOCK
+
+CHNRN1: PUSH P,[0]
+ PUSH P,[0]
+ MOVEM P,T.SPDL+1(TB)
+ PUSH P,[0]
+ PUSH P,[SIXBIT /_MUDL_/]
+ PUSH P,[SIXBIT />/]
+ PUSH P,[0]
+
+ PUSHJ P,RGPRS ; PARSE THESE
+ JRST TMA
+
+ SUB P,[1,,1] ; SNAME/DEV IGNORED
+ MOVE AB,ABSAV(TB) ; GET ORIG ARG POINTER
+ MOVE B,1(AB)
+ MOVE A,CHANNO(B) ; ITS CHANNEL #
+ DOTCAL RENMWO,[A,[17,,-1],(P)]
+ JRST FDLST
+ MOVE A,CHANNO(B) ; ITS CHANNEL #
+ DOTCAL RFNAME,[A,[2017,,-4],[2017,,-3],[2017,,-2],[2017,,-1]]
+ JFCL
+ MOVE A,-3(P) ; UPDATE CHANNEL
+ PUSHJ P,6TOCHS ; GET A STRING
+ MOVE C,1(AB)
+ MOVEM A,RNAME1-1(C)
+ MOVEM B,RNAME1(C)
+ MOVE A,-2(P)
+ PUSHJ P,6TOCHS
+ MOVE C,1(AB)
+ MOVEM A,RNAME2-1(C)
+ MOVEM B,RNAME2(C)
+ MOVE B,1(AB)
+ MOVSI A,TCHAN\b
+ JRST FINIS
+]
+IFE ITS,[
+ PUSH P,A
+ MOVE A,(AB)
+ MOVE B,1(AB)
+ PUSHJ P,ADDNUL
+ MOVE A,(TP) ; PBASE BACK
+ PUSH A,[400000,,0]
+ MOVEI A,(A)
+ GTJFN
+ JRST TDLLOS
+ POP P,B
+ EXCH A,B
+ MOVEI C,(A) ; FOR RELEASE ATTEMPT
+ RNAMF
+ JRST RNMLOS
+ MOVEI A,(B)
+ RLJFN ; FLUSH JFN
+ JFCL
+ MOVEI A,(C) ; MAKE SURR OTHER IS FLUSHED
+ RLJFN
+ JFCL
+ JRST FDLWON
+
+
+ADDNUL: PUSH TP,A
+ PUSH TP,B
+ MOVEI A,(A) ; LNTH OF STRING
+ IDIVI A,5
+ JUMPN B,NONUAD ; DONT NEED TO ADD ONE
+
+ PUSH TP,$TCHRS
+ PUSH TP,[0]
+ MOVEI A,2
+ PUSHJ P,CISTNG ; COPY OF STRING
+ POPJ P,
+
+NONUAD: POP TP,B
+ POP TP,A
+ POPJ P,
+]
+; HERE FOR LOSING .FDELE
+
+IFN ITS,[
+FDLST: .STATUS 0,A ; GET STATUS
+FDLST1: MOVEI B,0
+ PUSHJ P,GFALS ; ANALYZE IT
+ JRST FINIS
+]
+
+; SOME .FDELE ERRORS
+
+DEVDIF: ERRUUO EQUOTE DEVICE-OR-SNAME-DIFFERS
+
+\f; HERE TO RESET A READ CHANNEL
+
+MFUNCTION FRESET,SUBR,RESET
+
+ ENTRY 1
+ GETYP A,(AB)
+ CAIE A,TCHAN
+ JRST WTYP1
+ MOVE B,1(AB) ;GET CHANNEL
+ SKIPN IOINS(B) ; OPEN?
+ JRST REOPE1 ; NO, IGNORE CHECKS
+IFN ITS,[
+ MOVE A,STATUS(B) ;GET STATUS
+ ANDI A,77
+ JUMPE A,REOPE1 ;IF IT CLOSED, JUST REOPEN IT, MAYBE?
+ CAILE A,2 ;SKIPS IF TTY FLAVOR
+ JRST REOPEN
+]
+IFE ITS,[
+ MOVE A,CHANNO(B)
+ CAIE A,100 ; TTY-IN
+ CAIN A,101 ; TTY-OUT
+ JRST .+2
+ JRST REOPEN
+]
+ CAME B,TTICHN+1
+ CAMN B,TTOCHN+1
+ JRST REATTY
+REATT1: MOVEI B,DIRECT-1(B) ;POINT TO DIRECTION
+ PUSHJ P,CHRWRD ;CONVERT TO A WORD
+ JFCL
+ CAME B,[ASCII /READ/]
+ JRST TTYOPN
+ MOVE B,1(AB) ;RESTORE CHANNEL
+ PUSHJ P,RRESET" ;DO REAL RESET
+ JRST TTYOPN
+
+REOPEN: PUSH TP,(AB) ;FIRST CLOSE IT
+ PUSH TP,(AB)+1
+ MCALL 1,FCLOSE
+ MOVE B,1(AB) ;RESTORE CHANNEL
+
+; SET UP TEMPS FOR OPNCH
+
+REOPE1: PUSH P,[0] ; WILL HOLD DIR CODE
+ PUSH TP,$TPDL
+ PUSH TP,P
+ IRP A,,[DIRECT,RNAME1,RNAME2,RDEVIC,RSNAME,ACCESS]
+ PUSH TP,A-1(B)
+ PUSH TP,A(B)
+ TERMIN
+
+ PUSH TP,$TCHAN
+ PUSH TP,1(AB)
+
+ MOVE A,T.DIR(TB)
+ MOVE B,T.DIR+1(TB) ; GET DIRECTION
+ PUSHJ P,CHMOD ; CHECK THE MODE
+ MOVEM A,(P) ; AND STORE IT
+
+; NOW SET UP OPEN BLOCK IN SIXBIT
+
+IFN ITS,[
+ MOVSI E,-4 ; AOBN PNTR
+FRESE2: MOVE B,T.CHAN+1(TB)
+ MOVEI A,@RDTBL(E) ; GET ITEM POINTER
+ GETYP 0,-1(A) ; GET ITS TYPE
+ CAIE 0,TCHSTR
+ JRST FRESE1
+ MOVE B,(A) ; GET STRING
+ MOVE A,-1(A)
+ PUSHJ P,STRTO6
+FRESE3: AOBJN E,FRESE2
+]
+IFE ITS,[
+ MOVE B,T.CHAN+1(TB)
+ MOVE A,RDEVIC-1(B)
+ MOVE B,RDEVIC(B)
+ PUSHJ P,STRTO6 ; RESULT ON STACK
+ HLRZS (P)
+]
+
+ PUSH P,[0] ; PUSH UP SOME DUMMIES
+ PUSH P,[0]
+ PUSH P,[0]
+ PUSHJ P,OPNCH ; ATTEMPT TO DO THEOPEN
+ GETYP 0,A
+ CAIE 0,TCHAN
+ JRST FINIS ; LEAVE IF FALSE OR WHATEVER
+
+DRESET: MOVE A,(AB)
+ MOVE B,1(AB)
+ SETZM CHRPOS(B) ;INITIALIZE THESE PARAMETERS
+ SETZM LINPOS(B)
+ SETZM ACCESS(B)
+ JRST FINIS
+
+TTYOPN:
+IFN ITS,[
+ MOVE B,1(AB)
+ CAME B,TTOCHN+1
+ CAMN B,TTICHN+1
+ PUSHJ P,TTYOP2
+ PUSHJ P,DOSTAT
+ DOTCAL RSSIZE,[CHANNO(B),[2000,,C],[2000,,D]]
+ .LOSE %LSSYS
+ MOVEM C,PAGLN(B)
+ MOVEM D,LINLN(B)
+]
+ JRST DRESET
+
+IFN ITS,[
+FRESE1: CAIE 0,TFIX
+ JRST BADCHN
+ PUSH P,(A)
+ JRST FRESE3
+]
+
+; INTERFACE TO REOPEN CLOSED CHANNELS
+
+OPNCHN: PUSH TP,$TCHAN
+ PUSH TP,B
+ MCALL 1,FRESET
+ POPJ P,
+
+REATTY: PUSHJ P,TTYOP2
+IFE ITS, SKIPN DEMFLG ; SKIP IF DEMONFLAG IS ON
+ SKIPE NOTTY
+ JRST DRESET
+ MOVE B,1(AB)
+ JRST REATT1
+\f
+; FUNCTION TO LIST ALL CHANNELS
+
+MFUNCTION CHANLIST,SUBR
+
+ ENTRY 0
+
+ MOVEI A,N.CHNS-1 ;MAX # OF REAL CHANNELS
+ MOVEI C,0
+ MOVEI B,CHNL1 ;POINT TO FIRST REAL CHANNEL
+
+CHNLP: SKIPN 1(B) ;OPEN?
+ JRST NXTCHN ;NO, SKIP
+ HRRE E,(B) ; ABOUT TO FLUSH?
+ JUMPL E,NXTCHN ; YES, FORGET IT
+ MOVE D,1(B) ; GET CHANNEL
+ HRRZ E,CHANNO-1(D) ; GET REF COUNT
+ PUSH TP,(B)
+ PUSH TP,1(B)
+ ADDI C,1 ;COUNT WINNERS
+ SOJGE E,.-3 ; COUNT THEM
+NXTCHN: ADDI B,2
+ SOJN A,CHNLP
+
+ SKIPN B,CHNL0+1 ;NOW HACK LIST OF PSUEDO CHANNELS
+ JRST MAKLST
+CHNLS: PUSH TP,(B)
+ PUSH TP,(B)+1
+ ADDI C,1
+ HRRZ B,(B)
+ JUMPN B,CHNLS
+
+MAKLST: ACALL C,LIST
+ JRST FINIS
+
+\f; ROUTINE TO RESTORE A CLOSED CHANNEL TO ITS PREVIOUS STATE
+
+
+REOPN: PUSH TP,$TCHAN
+ PUSH TP,B
+ SKIPN CHANNO(B) ; ONLY REAL CHANNELS
+ JRST PSUEDO
+
+IFN ITS,[
+ MOVSI E,-4 ; SET UP POINTER FOR NAMES
+
+GETOPB: MOVE B,(TP) ; GET CHANNEL
+ MOVEI A,@RDTBL(E) ; GET POINTER
+ MOVE B,(A) ; NOW STRING
+ MOVE A,-1(A)
+ PUSHJ P,STRTO6 ; LEAVES SIXBIT ON STACK
+ AOBJN E,GETOPB
+]
+IFE ITS,[
+ MOVE A,RDEVIC-1(B)
+ MOVE B,RDEVIC(B)
+ PUSHJ P,STRTO6 ; GET DEV NAME IN SIXBIT
+]
+ MOVE B,(TP) ; RESTORE CHANNEL
+ MOVE A,DIRECT-1(B)
+ MOVE B,DIRECT(B)
+ PUSHJ P,CHMOD ; CHECK FOR A VALID MODE
+
+IFN ITS, MOVE E,-3(P) ; GET DEVICE IN PROPER PLACE
+IFE ITS, HLRZS E,(P)
+ MOVE B,(TP) ; RESTORE CHANNEL
+IFN ITS, CAMN E,[SIXBIT /DSK /]
+IFE ITS,[
+ CAIE E,(SIXBIT /PS /)
+ CAIN E,(SIXBIT /DSK/)
+ JRST DISKH ; DISK WINS IMMEIDATELY
+ CAIE E,(SIXBIT /SS /)
+ CAIN E,(SIXBIT /SRC/)
+ JRST DISKH ; DISK WINS IMMEIDATELY
+]
+IFN ITS, CAMN E,[SIXBIT /TTY /] ; NO NEED TO RE-OPEN THE TTY
+IFE ITS, CAIN E,(SIXBIT /TTY/)
+ JRST REOPD1
+IFN ITS,[
+ AND E,[777700,,0] ; COULD BE "UTn"
+ MOVE D,CHANNO(B) ; GET CHANNEL
+ ASH D,1
+ ADDI D,CHNL0 ; DON'T SEEM TO BE OPEN
+ SETZM 1(D)
+ SETZM CHANNO(B)
+ CAMN E,[SIXBIT /UT /]
+ JRST REOPD ; CURRENTLY, CANT RESTORE UTAPE CHANNLES
+ CAMN E,[SIXBIT /AI /]
+ JRST REOPD ; CURRENTLY CANT RESTORE AI CHANNELS
+ CAMN E,[SIXBIT /ML /]
+ JRST REOPD ; CURRENTLY CANT RESTORE ML CHANNELS
+ CAMN E,[SIXBIT /DM /]
+ JRST REOPD ; CURRENTLY CANT RESTORE DM CHANNELS
+]
+ PUSH TP,$TCHAN ; TRY TO RESET IT
+ PUSH TP,B
+ MCALL 1,FRESET
+
+IFN ITS,[
+REOPD1: AOS -4(P)
+REOPD: SUB P,[4,,4]
+]
+IFE ITS,[
+REOPD1: AOS -1(P)
+REOPD: SUB P,[1,,1]
+]
+REOPD0: SUB TP,[2,,2]
+ POPJ P,
+
+IFN ITS,[
+DISKH: MOVE C,(P) ; SNAME
+ .SUSET [.SSNAM,,C]
+]
+IFE ITS,[
+DISKH: MOVEM A,(P) ; SAVE MODE WORD
+ PUSHJ P,STSTK ; STRING TO STACK
+ MOVE A,(E) ; RESTORE MODE WORD
+ PUSH TP,$TPDL
+ PUSH TP,E ; SAVE PDL BASE
+ MOVE B,-2(TP) ; CHANNEL BACK TO B
+]
+ MOVE C,ACCESS(B) ; GET CHANNELS ACCESS
+ TRNN A,2 ; SKIP IF NOT ASCII CHANNEL
+ JRST DISKH1
+ HRRZ D,ACCESS-1(B) ; IF PARTIAL WORD OUT
+ IMULI C,5 ; TO CHAR ACCESS
+ JUMPE D,DISKH1 ; NO SWEAT
+ ADDI C,(D)
+ SUBI C,5
+DISKH1: HRRZ D,BUFSTR-1(B) ; ANY CHARS IN MUDDLE BUFFER
+ JUMPE D,DISKH2
+ TRNN A,1 ; SKIP IF OUTPUT CHANNEL
+ JRST DISKH2
+ PUSH P,A
+ PUSH P,C
+ MOVEI C,BUFSTR-1(B)
+ PUSHJ P,BYTDOP ; FIND LENGTH OF WHOLE BUFFER
+ HLRZ D,(A) ; LENGTH + 2 TO D
+ SUBI D,2
+ IMULI D,5 ; TO CHARS
+ SUB D,BUFSTR-1(B)
+ POP P,C
+ POP P,A
+DISKH2: SUBI C,(D) ; UPDATE CHAR ACCESS
+ IDIVI C,5 ; BACK TO WORD ACCESS
+IFN ITS,[
+ IORI A,6 ; BLOCK IMAGE
+ TRNE A,1
+ IORI A,100000 ; WRITE OVER BIT
+ PUSHJ P,DOOPN
+ JRST REOPD
+ MOVE A,C ; ACCESS TO A
+ PUSHJ P,GETFLN ; CHECK LENGTH
+ CAIGE 0,(A) ; CHECK BOUNDS
+ JRST .+3 ; COMPLAIN
+ PUSHJ P,DOACCS ; AND ACESS
+ JRST REOPD1 ; SUCCESS
+
+ MOVE A,CHANNO(B) ; CLOSE THE G.D. CHANNEL
+ PUSHJ P,MCLOSE
+ JRST REOPD
+
+DOACCS: PUSH P,A
+ HRRZ A,CHANNO(B)
+ DOTCAL ACCESS,[A,(P)]
+ JFCL
+ POP P,A
+ POPJ P,
+
+DOIOTO:
+DOIOTI:
+DOIOT:
+ PUSH P,0
+ MOVSI 0,TCHAN
+ MOVE PVP,PVSTOR+1
+ MOVEM 0,BSTO(PVP) ; IN CASE OF INTERRUPT
+ ENABLE
+ HRRZ 0,CHANNO(B)
+ DOTCAL IOT,[0,A]
+ JFCL
+ DISABLE
+ MOVE PVP,PVSTOR+1
+ SETZM BSTO(PVP)
+ POP P,0
+ POPJ P,
+
+GETFLN: MOVE 0,CHANNO(B) ; GET CHANNEL
+ .CALL FILBLK ; READ LNTH
+ .VALUE
+ POPJ P,
+
+FILBLK: SETZ
+ SIXBIT /FILLEN/
+ 0
+ 402000,,0 ; STUFF RESULT IN 0
+]
+IFE ITS,[
+ MOVEI A,CHNL0
+ ADD A,CHANNO(B)
+ ADD A,CHANNO(B)
+ SETZM 1(A) ; MAY GET A DIFFERENT JFN
+ HRROI B,1(E) ; TENEX STRING POINTER
+ MOVSI A,400001 ; MAKE SURE
+ GTJFN ; GO GET IT
+ JRST RGTJL ; COMPLAIN
+ MOVE D,-2(TP)
+ HRRZM A,CHANNO(D) ; COULD HAVE CHANGED
+ MOVE P,(TP) ; RESTORE P
+ MOVEI B,CHNL0
+ ASH A,1 ; MUNG ITS SLOT
+ ADDI A,(B)
+ MOVEM D,1(A)
+ HLLOS (A) ; MARK CHANNEL NOT TO BE RELOOKED AT
+ MOVE A,(P) ; MODE WORD BACK
+ MOVE B,[440000,,200000] ; FLAG BITS
+ TRNE A,1 ; SKIP FOR INPUT
+ TRC B,300000 ; CHANGE TO WRITE
+ MOVE A,CHANNO(D) ; GET JFN
+ OPENF
+ JRST ROPFLS
+ MOVE E,C ; LENGTH TO E
+ SIZEF ; GET CURRENT LENGTH
+ JRST ROPFLS
+ CAMGE B,E ; STILL A WINNER
+ JRST ROPFLS
+ MOVE A,CHANNO(D) ; JFN
+ MOVE B,C
+ SFPTR
+ JRST ROPFLS
+ SUB TP,[2,,2] ; FLUSH PDL POINTER
+ JRST REOPD1
+
+ROPFLS: MOVE A,-2(TP)
+ MOVE A,CHANNO(A)
+ CLOSF ; ATTEMPT TO CLOSE
+ JFCL ; IGNORE FAILURE
+ SKIPA
+
+RGTJL: MOVE P,(TP)
+ SUB TP,[2,,2]
+ JRST REOPD
+
+DOACCS: PUSH P,B
+ EXCH A,B
+ MOVE A,CHANNO(A)
+ SFPTR
+ JRST ACCFAI
+ POP P,B
+ POPJ P,
+]
+PSUEDO: AOS (P) ; ASSUME SUCCESS FOR NOW
+ MOVEI B,RDEVIC-1(B) ; SEE WHAT DEVICE IS
+ PUSHJ P,CHRWRD
+ JFCL
+ JRST REOPD0 ; NO, RETURN HAPPY
+IFN 0,[ CAME B,[ASCII /E&S/] ; DISPLAY ?
+ CAMN B,[ASCII /DIS/]
+ SKIPA B,(TP) ; YES, REGOBBLE CHANNEL AND CONTINUE
+ JRST REOPD0 ; NO, RETURN HAPPY
+ PUSHJ P,DISROP
+ SOS (P) ; DISPLAY DID NOT REOPEN, UNDO ASSUMPTION OF SUCCESS
+ JRST REOPD0]
+
+\f;THIS PROGRAM CLOSES THE SPECIFIED CHANNEL
+
+MFUNCTION FCLOSE,SUBR,[CLOSE]
+
+ ENTRY 1 ;ONLY ONE ARG
+ GETYP A,(AB) ;CHECK ARGS
+ CAIE A,TCHAN ;IS IT A CHANNEL
+ JRST WTYP1
+ MOVE B,1(AB) ;PICK UP THE CHANNEL
+ HRRZ A,CHANNO-1(B) ; GET REF COUNT
+ SOJGE A,CFIN5 ; NOT READY TO REALLY CLOSE
+ CAME B,TTICHN+1 ; CHECK FOR TTY
+ CAMN B,TTOCHN+1
+ JRST CLSTTY
+ MOVE A,[JRST CHNCLS]
+ MOVEM A,IOINS(B) ;CLOBBER THE IO INS
+ MOVE A,RDEVIC-1(B) ;GET THE NAME OF THE DEVICE
+ MOVE B,RDEVIC(B)
+ PUSHJ P,STRTO6
+IFN ITS, MOVE A,(P)
+IFE ITS, HLRZS A,(P)
+ MOVE B,1(AB) ; RESTORE CHANNEL
+IFN 0,[
+ CAME A,[SIXBIT /E&S /]
+ CAMN A,[SIXBIT /DIS /]
+ PUSHJ P,DISCLS]
+ MOVE B,1(AB) ; IN CASE CLOBBERED BY DISCLS
+ SKIPN A,CHANNO(B) ;ANY REAL CHANNEL?
+ JRST REMOV ; NO, EITHER CLOSED OR PSEUDO CHANNEL
+
+ MOVE A,DIRECT-1(B) ; POINT TO DIRECTION
+ MOVE B,DIRECT(B)
+ PUSHJ P,STRTO6 ; CONVERT TO WORD
+ POP P,A
+IFN ITS, LDB E,[360600,,(P)] ; FIRST CHAR OD DEV NAME
+IFE ITS, LDB E,[140600,,(P)] ; FIRST CHAR OD DEV NAME
+ CAIE E,'T ; SKIP IF TTY
+ JRST CFIN4
+ CAME A,[SIXBIT /READ/] ; SKIP IF WINNER
+ JRST CFIN1
+IFN ITS,[
+ MOVE B,1(AB) ; IN ITS CHECK STATUS
+ LDB A,[600,,STATUS(B)]
+ CAILE A,2
+ JRST CFIN1
+]
+ PUSH TP,$TCHSTR
+ PUSH TP,CHQUOTE CHAR
+ PUSH TP,(AB)
+ PUSH TP,1(AB)
+ MCALL 2,OFF ; TURN OFF INTERRUPT
+CFIN1: MOVE B,1(AB)
+ MOVE A,CHANNO(B)
+IFN ITS,[
+ PUSHJ P,MCLOSE
+]
+IFE ITS,[
+ TLZ A,400000 ; FOR JFN RELEASE
+ CLOSF ; CLOSE THE FILE AND RELEASE THE JFN
+ JFCL
+ MOVE A,CHANNO(B)
+]
+CFIN: LSH A,1
+ ADDI A,CHNL0+1 ;POINT TO THIS CHANNELS LSOT
+ SETZM CHANNO(B)
+ SETZM (A) ;AND CLOBBER IT
+ HLLZS BUFSTR-1(B)
+ SETZM BUFSTR(B)
+ HLLZS ACCESS-1(B)
+CFIN2: HLLZS -2(B)
+ MOVSI A,TCHAN ;RETURN THE CHANNEL
+ JRST FINIS
+
+CLSTTY: ERRUUO EQUOTE ATTEMPT-TO-CLOSE-TTY-CHANNEL
+
+
+REMOV: MOVEI D,CHNL0+1 ;ATTEMPT TO REMOVE FROM PSUEDO CHANNEL LIST
+REMOV0: SKIPN C,D ;FOUND ON LIST ?
+ JRST CFIN2 ;NO, JUST IGNORE THIS CLOSED CHANNEL
+ HRRZ D,(C) ;GET POINTER TO NEXT
+ CAME B,(D)+1 ;FOUND ?
+ JRST REMOV0
+ HRRZ D,(D) ;YES, SPLICE IT OUT
+ HRRM D,(C)
+ JRST CFIN2
+
+
+; CLOSE UP ANY LEFTOVER BUFFERS
+
+CFIN4:
+; CAME A,[SIXBIT /PRINTO/]
+; CAMN A,[SIXBIT /PRINTB/]
+; JRST .+3
+; CAME A,[SIXBIT /PRINT/]
+; JRST CFIN1
+ MOVE B,1(AB) ; GET CHANNEL
+ HRRZ A,-2(B) ;GET MODE BITS
+ TRNN A,C.PRIN
+ JRST CFIN1
+ GETYP 0,BUFSTR-1(B) ; IS THERE AN OUTPUT BUFFER
+ SKIPN BUFSTR(B)
+ JRST CFIN1
+ CAIE 0,TCHSTR
+ JRST CFINX1
+ PUSHJ P,BFCLOS
+IFE ITS,[
+ MOVE A,CHANNO(B)
+ MOVEI B,7
+ SFBSZ
+ JFCL
+ CLOSF
+ JFCL
+]
+ HLLZS BUFSTR-1(B)
+ SETZM BUFSTR(B)
+CFINX1: HLLZS ACCESS-1(B)
+ JRST CFIN1
+
+CFIN5: HRRM A,CHANNO-1(B)
+ JRST CFIN2
+\f;SUBR TO DO .ACCESS ON A READ CHANNEL
+;FORM: <ACCESS CHANNEL FIX-NUMBER>
+;POSITIONS CHANNEL AT CHARACTER POSN FIX-NUMBER
+;H. BRODIE 7/26/72
+
+MFUNCTION MACCESS,SUBR,[ACCESS]
+ ENTRY 2 ;ARGS: CHANNEL AND FIX-NUMBER
+
+;CHECK ARGUMENT TYPES
+ GETYP A,(AB)
+ CAIE A,TCHAN ;FIRST ARG SHOULD BE CHANNEL
+ JRST WTYP1
+ GETYP A,2(AB) ;TYPE OF SECOND
+ CAIE A,TFIX ;SHOULD BE FIX
+ JRST WTYP2
+
+;CHECK DIRECTION OF CHANNEL
+ MOVE B,1(AB) ;B GETS PNTR TO CHANNEL
+; MOVEI B,DIRECT-1(B) ;GET DIRECTION OF CHANNEL
+; PUSHJ P,CHRWRD ;GRAB THE CHAR STRNG
+; JFCL
+; CAME B,[<ASCII /PRINT/>+1]
+ HRRZ A,-2(B) ; GET MODE BITS
+ TRNN A,C.PRIN
+ JRST MACCA
+ MOVE B,1(AB)
+ SKIPE C,BUFSTR(B) ;SEE IF WE MUST FLUSH PART BUFFER
+ PUSHJ P,BFCLOS
+ JRST MACC
+MACCA:
+; CAMN B,[ASCIZ /READ/]
+; JRST .+4
+; CAME B,[ASCIZ /READB/] ; READB CHANNEL?
+; JRST WRONGD
+; AOS (P) ; SET INDICATOR FOR BINARY MODE
+
+;CHECK THAT THE CHANNEL IS OPEN
+MACC: MOVE B,1(AB) ;GET BACK PTR TO CHANNEL
+ HRRZ E,-2(B)
+ TRNN E,C.OPN
+ JRST CHNCLS ;IF CHNL CLOSED => ERROR
+
+;COMPUTE ACCESS PNTR TO ACCESS WORD CHAR IS IN
+;REMAINDER IS NUMBER OF TIMES TO INCR BYTE POINTER
+ADEVOK: SKIPGE C,3(AB) ;GET CHAR POSN
+ ERRUUO EQUOTE NEGATIVE-ARGUMENT
+MACC1: MOVEI D,0
+ TRNN E,C.BIN ; SKIP FOR BINARY FILE
+ IDIVI C,5
+
+;SETUP THE .ACCESS
+ TRNN E,C.PRIN
+ JRST NLSTCH
+ HRRZ 0,LSTCH-1(B)
+ MOVE A,ACCESS(B)
+ TRNN E,C.BIN
+ JRST LSTCH1
+ IMULI A,5
+ ADD A,ACCESS-1(B)
+ ANDI A,-1
+LSTCH1: CAIG 0,(A)
+ MOVE 0,A
+ MOVE A,C
+ IMULI A,5
+ ADDI A,(D)
+ CAML A,0
+ MOVE 0,A
+ HRRM 0,LSTCH-1(B) ; UPDATE "LARGEST"
+NLSTCH: MOVE A,CHANNO(B) ;A GETS REAL CHANNEL NUMBER
+IFN ITS,[
+ DOTCAL ACCESS,[A,C]
+ .LOSE %LSFIL ;PRESUMABLY LOSSAGE MATTERS
+]
+
+IFE ITS,[
+ MOVE B,C
+ SFPTR ; DO IT IN TENEX
+ JRST ACCFAI
+ MOVE B,1(AB) ; RESTORE CHANNEL
+]
+; POP P,E ; CHECK FOR READB MODE
+ TRNN E,C.READ
+ JRST ACCOUT ; PRINT TYPE CHANNEL, GO DO IT
+ SKIPE BUFSTR(B) ; IS THERE A READ BUFFER TO FLUSH
+ JRST .+3
+ SETZM LSTCH(B) ; CLEAR OUT POSSIBLE EOF INDICATOR
+ JRST DONADV
+
+;NOW FORCE GETCHR TO DO A .IOT FIRST THING
+ MOVEI C,BUFSTR-1(B) ; FIND END OF STRING
+ PUSHJ P,BYTDOP"
+ SUBI A,2 ; LAST REAL WORD
+ HRLI A,010700
+ MOVEM A,BUFSTR(B)
+ HLLZS BUFSTR-1(B) ; CLOBBER CHAR COUNT
+ SETZM LSTCH(B) ;CLOBBER READ'S HIDDEN CHARACTER
+
+;NOW DO THE APPROPRIATE NUM OF BYTE ADVANCEMENTS
+ JUMPLE D,DONADV
+ADVPTR: PUSHJ P,GETCHR
+ MOVE B,1(AB) ;RESTORE IN CASE CLOBBERED
+ SOJG D,ADVPTR
+
+DONADV: MOVE C,3(AB) ;FIXUP ACCESS SLOT IN CHNL
+ HLLZS ACCESS-1(B)
+ MOVEM C,ACCESS(B)
+ MOVE A,$TCHAN ;TYPE OF RESULT = "CHANNEL"
+ JRST FINIS ;DONE...B CONTAINS CHANNEL
+
+IFE ITS,[
+ACCFAI: ERRUUO EQUOTE ACCESS-FAILURE
+]
+ACCOUT: SKIPN C,BUFSTR(B) ; FIXUP BUFFER?
+ JRST ACCOU1
+ HRRZ F,BUFSTR-1(B)
+ ADD F,[-BUFLNT*5-4]
+ IDIVI F,5
+ ADD F,BUFSTR(B)
+ HRLI F,010700
+ MOVEM F,BUFSTR(B)
+ MOVEI F,BUFLNT*5
+ HRRM F,BUFSTR-1(B)
+ACCOU1: TRNE E,C.BIN ; FINISHED FOR BINARY CHANNELS
+ JRST DONADV
+
+ JUMPE D,DONADV ; THIS CASE OK
+IFE ITS,[
+ MOVE A,CHANNO(B) ; GET LAST WORD
+ RFPTR
+ JFCL
+ PUSH P,B
+ MOVNI C,1
+ MOVE B,[444400,,E] ; READ THE WORD
+ SIN
+ JUMPL C,ACCFAI
+ POP P,B
+ SFPTR
+ JFCL
+ MOVE B,1(AB) ; CHANNEL BACK
+ MOVE C,[440700,,E]
+ ILDB 0,C
+ IDPB 0,BUFSTR(B)
+ SOS BUFSTR-1(B)
+ SOJG D,.-3
+ JRST DONADV
+]
+IFN ITS, ERRUUO EQUOTE CANT-ACCESS-ASCII-ON-ITS
+
+
+;WRONG TYPE OF DEVICE ERROR
+WRDEV: ERRUUO EQUOTE NON-DSK-DEVICE
+\f
+; BINARY READ AND PRINT ROUTINES
+
+MFUNCTION PRINTB,SUBR
+
+ ENTRY
+
+PBFL: PUSH P,. ; PUSH NON-ZERONESS
+ MOVEI A,-7
+ JRST BINI1
+
+MFUNCTION READB,SUBR
+
+ ENTRY
+
+ PUSH P,[0]
+ MOVEI A,-11
+BINI1: HLRZ 0,AB
+ CAILE 0,-3
+ JRST TFA
+ CAIG 0,(A)
+ JRST TMA
+
+ GETYP 0,(AB) ; SHOULD BE UVEC OR STORE
+ CAIE 0,TSTORAGE
+ CAIN 0,TUVEC
+ JRST BINI2
+ CAIE 0,TCHSTR
+ CAIN 0,TBYTE
+ JRST BYTOK
+ JRST WTYP1 ; ELSE LOSE
+BINI2: MOVE B,1(AB) ; GET IT
+ HLRE C,B
+ SUBI B,(C) ; POINT TO DOPE
+ GETYP A,(B)
+ PUSHJ P,SAT" ; GET ITS ST.ALOC.TYPE
+ CAIE A,S1WORD
+ JRST WTYP1
+BYTOK: GETYP 0,2(AB)
+ CAIE 0,TCHAN ; BETTER BE A CHANNEL
+ JRST WTYP2
+ MOVE B,3(AB) ; GET IT
+; MOVEI B,DIRECT-1(B) ; GET DIRECTION OF
+; PUSHJ P,CHRWRD ; INTO 1 WORD
+; JFCL
+; MOVNI E,1
+; CAMN B,[ASCII /READB/]
+; MOVEI E,0
+; CAMN B,[<ASCII /PRINT/>+1]
+ HRRZ A,-2(B) ; MODE BITS
+ TRNN A,C.BIN ; IF NOT BINARY
+ JRST WRONGD
+ MOVEI E,0
+ TRNE A,C.PRIN
+ MOVE E,PBFL
+; JUMPL E,WRONGD ; LOSER
+ CAME E,(P) ; CHECK WINNGE
+ JRST WRONGD
+ MOVE B,3(AB) ; GET CHANNEL BACK
+ SKIPN A,IOINS(B) ; OPEN?
+ PUSHJ P,OPENIT ; LOSE
+ CAMN A,[JRST CHNCLS]
+ JRST CHNCLS ; LOSE, CLOSED
+ JUMPN E,BUFOU1 ; JUMP FOR OUTPUT
+ MOVEI C,0
+ CAML AB,[-5,,] ; SKIP IF EOF GIVEN
+ JRST BINI5
+ MOVE 0,4(AB)
+ MOVEM 0,EOFCND-1(B)
+ MOVE 0,5(AB)
+ MOVEM 0,EOFCND(B)
+ CAML AB,[-7,,]
+ JRST BINI5
+ GETYP 0,6(AB)
+ CAIE 0,TFIX
+ JRST WTYP
+ MOVE C,7(AB)
+BINI5: SKIPE LSTCH(B) ; INDICATES IF EOF HIT
+ JRST BINEOF
+ GETYP 0,(AB) ; BRANCH BASED ON BYTE SIZE
+ CAIE 0,TCHSTR
+ CAIN 0,TBYTE
+ JRST BYTI
+ MOVE A,1(AB) ; GET VECTOR
+ PUSHJ P,PGBIOI ; READ IT
+ HLRE C,A ; GET COUNT DONE
+ HLRE D,1(AB) ; AND FULL COUNT
+ SUB C,D ; C=> TOTAL READ
+ ADDM C,ACCESS(B)
+ JUMPGE A,BINIOK ; NOT EOF YET
+ SETOM LSTCH(B)
+BINIOK: MOVE B,C
+ MOVSI A,TFIX ; RETURN AMOUNT ACTUALLY READ
+ JRST FINIS
+
+BYTI:
+IFE ITS,[
+ MOVE A,1(B)
+ RFBSZ
+ FATAL RFBSZ-LOST
+ PUSH P,B
+ LDB B,[300600,,1(AB)]
+ SFBSZ
+ FATAL SFBSZ-LOST
+ MOVE B,3(AB)
+ HRRZ A,(AB) ; GET BYTE STRING LENGTH
+ MOVNS A
+ MOVSS A ; MAKE FUNNY BYTE POINTER
+ HRR A,1(AB)
+ ADDI A,1
+ PUSH P,C
+ HLL C,1(AB) ; GET START OF BPTR
+ MOVE D,[SIN]
+ PUSHJ P,PGBIOT
+ HLRE C,A ; GET COUNT DONE
+ POP P,D
+ SKIPN D
+ HRRZ D,(AB) ; AND FULL COUNT
+ ADD D,C ; C=> TOTAL READ
+ LDB E,[300600,,1(AB)]
+ MOVEI A,36.
+ IDIVM A,E
+ IDIVM D,E
+ ADDM E,ACCESS(B)
+ SKIPGE C ; NOT EOF YET
+ SETOM LSTCH(B)
+ MOVE A,1(B)
+ POP P,B
+ SFBSZ
+ FATAL SFBSZ-LOST
+ MOVE C,D
+ JRST BINIOK
+]
+BUFOU1: SKIPE BUFSTR(B) ; ANY BUFFERS AROUND?
+ PUSHJ P,BFCLS1 ; GET RID OF SAME
+ MOVEI C,0
+ CAML AB,[-5,,]
+ JRST BINO5
+ GETYP 0,4(AB)
+ CAIE 0,TFIX
+ JRST WTYP
+ MOVE C,5(AB)
+BINO5: MOVE A,1(AB)
+ GETYP 0,(AB) ; BRANCH BASED ON BYTE SIZE
+ CAIE 0,TCHSTR
+ CAIN 0,TBYTE
+ JRST BYTO
+ PUSH P,C
+ PUSHJ P,PGBIOO
+ POP P,C
+ JUMPE C,.+3
+ HLRE C,1(AB)
+ MOVNS C
+ ADDM C,ACCESS(B)
+BYTO1: MOVE A,(AB) ; RET VECTOR ETC.
+ MOVE B,1(AB)
+ JRST FINIS
+
+BYTO:
+IFE ITS,[
+ MOVE A,1(B)
+ RFBSZ
+ FATAL RFBSZ-FAILURE
+ PUSH P,B
+ LDB B,[300600,,1(AB)]
+ SFBSZ
+ FATAL SFBSZ-FAILURE
+ MOVE B,3(AB)
+ HRRZ A,(AB) ; GET BYTE SIZE
+ MOVNS A
+ MOVSS A ; MAKE FUNNY BYTE POINTER
+ HRR A,1(AB)
+ ADDI A,1 ; COMPENSATE FOR PGBIOT DOING THE WRONG THING
+ HLL C,1(AB) ; GET START OF BPTR
+ MOVE D,[SOUT]
+ PUSHJ P,PGBIOT
+ LDB D,[300600,,1(AB)]
+ MOVEI C,36.
+ IDIVM C,D
+ HRRZ C,(AB)
+ IDIVI C,(D)
+ ADDM C,ACCESS(B)
+ MOVE A,1(B)
+ POP P,B
+ SFBSZ
+ FATAL SFBSZ-FAILURE
+ JRST BYTO1
+]
+
+BINEOF: PUSH TP,EOFCND-1(B)
+ PUSH TP,EOFCND(B)
+ PUSH TP,$TCHAN
+ PUSH TP,B
+ MCALL 1,FCLOSE ; CLOSE THE LOSER
+ MCALL 1,EVAL
+ JRST FINIS
+
+OPENIT: PUSH P,E
+ PUSHJ P,OPNCHN ;TRY TO OPEN THE LOSER
+ JUMPE B,CHNCLS ;FAIL
+ POP P,E
+ POPJ P,
+\f; THESE SUBROUTINES BY NDR 9/16/73 TO FACILITATE THE
+; TYPES OF IO NECESSARY TO MAKE MORE EFFICIENT USE OF
+; THE NETWORK AND DO RELATED FILE TRANSFER TYPE OF JOBS.
+
+R1CHAR: SKIPN A,LSTCH(B) ; CHAR READING ROUTINE FOR FCOPY
+ PUSHJ P,RXCT
+ TLO A,200000 ; ^@ BUG
+ MOVEM A,LSTCH(B)
+ TLZ A,200000
+ JUMPL A,.+2 ; IN CASE OF -1 ON STY
+ TRZN A,400000 ; EXCL HACKER
+ JRST .+4
+ MOVEM A,LSTCH(B) ; SAVE DE-EXCLED CHAR
+ MOVEI A,"!
+ JRST .+2
+ SETZM LSTCH(B)
+ PUSH P,C
+ HRRZ C,DIRECT-1(B)
+ CAIE C,5 ; IF DIRECTION IS 5 LONG THEN READB
+ JRST R1CH1
+ AOS C,ACCESS-1(B)
+ CAMN C,[TFIX,,1]
+ AOS ACCESS(B) ; EVERY FIFTY INCREMENT
+ CAMN C,[TFIX,,5]
+ HLLZS ACCESS-1(B)
+ JRST .+2
+R1CH1: AOS ACCESS(B)
+ POP P,C
+ POPJ P,
+
+W1CHAR: CAIE A,15 ; CHAR WRITING ROUTINE, TEST FOR CR
+ JRST .+3
+ SETOM CHRPOS(B)
+ AOSA LINPOS(B)
+ CAIE A,12 ; TEST FOR LF
+ AOS CHRPOS(B) ; IF NOT LF AOS CHARACTE5R POSITION
+ CAIE A,14 ; TEST FOR FORM FEED
+ JRST .+3
+ SETZM CHRPOS(B) ; IF FORM FEED ZERO CHARACTER POSITION
+ SETZM LINPOS(B) ; AND LINE POSITION
+ CAIE A,11 ; IS THIS A TAB?
+ JRST .+6
+ MOVE C,CHRPOS(B)
+ ADDI C,7
+ IDIVI C,8.
+ IMULI C,8. ; FIX UP CHAR POS FOR TAB
+ MOVEM C,CHRPOS(B) ; AND SAVE
+ PUSH P,C
+ HRRZ C,-2(B) ; GET BITS
+ TRNN C,C.BIN ; SIX LONG MUST BE PRINTB
+ JRST W1CH1
+ AOS C,ACCESS-1(B)
+ CAMN C,[TFIX,,1]
+ AOS ACCESS(B)
+ CAMN C,[TFIX,,5]
+ HLLZS ACCESS-1(B)
+ JRST .+2
+W1CH1: AOS ACCESS(B)
+ PUSH P,A
+ PUSHJ P,WXCT
+ POP P,A
+ POP P,C
+ POPJ P,
+
+R1C: SUBM M,(P) ;LITTLE ENTRY FOR COMPILED STUFF
+; PUSH TP,$TCHAN ;SAVE THE CHANNEL TO BLESS IT
+; PUSH TP,B
+; MOVEI B,DIRECT-1(B)
+; PUSHJ P,CHRWRD
+; JFCL
+; CAME B,[ASCIZ /READ/]
+; CAMN B,[ASCII /READB/]
+; JRST .+2
+; JRST BADCHN
+ HRRZ A,-2(B) ; GET MODE BITS
+ TRNN A,C.READ
+ JRST BADCHN
+ SKIPN IOINS(B) ; IS THE CHANNEL OPEN
+ PUSHJ P,OPENIT ; NO, GO DO IT
+ PUSHJ P,GRB ; MAKE SURE WE HAVE A READ BUFFER
+ PUSHJ P,R1CHAR ; AND GET HIM A CHARACTER
+ JRST MPOPJ ; THATS ALL FOLKS
+
+W1C: SUBM M,(P)
+ PUSHJ P,W1CI
+ JRST MPOPJ
+
+W1CI:
+; PUSH TP,$TCHAN
+; PUSH TP,B
+ PUSH P,A ; ASSEMBLER ENTRY TO OUTPUT 1 CHAR
+; MOVEI B,DIRECT-1(B)
+; PUSHJ P,CHRWRD ; INTERNAL CALL TO W1CHAR
+; JFCL
+; CAME B,[ASCII /PRINT/]
+; CAMN B,[<ASCII /PRINT/>+1]
+; JRST .+2
+; JRST BADCHN
+; POP TP,B
+; POP TP,(TP)
+ HRRZ A,-2(B)
+ TRNN A,C.PRIN
+ JRST BADCHN
+ SKIPN IOINS(B) ; MAKE SURE THAT IT IS OPEN
+ PUSHJ P,OPENIT
+ PUSHJ P,GWB
+ POP P,A ; GET THE CHAR TO DO
+ JRST W1CHAR
+
+; ROUTINES TO REPLACE XCT IOINS(B) FOR INPUT AND OUTPUT
+; THEY DO THE XCT THEN CHECK OUT POSSIBLE SCRIPTAGE--BLECH.
+
+
+WXCT:
+RXCT: XCT IOINS(B) ; READ IT
+ SKIPN SCRPTO(B)
+ POPJ P,
+
+DOSCPT: PUSH TP,$TCHAN
+ PUSH TP,B
+ PUSH P,A ; AND SAVE THE CHAR AROUND
+
+ SKIPN SCRPTO(B) ; IF ZERO FORGET IT
+ JRST SCPTDN ; THATS ALL THERE IS TO IT
+ PUSH P,C ; SAVE AN ACCUMULATOR FOR CLEANLINESS
+ GETYP C,SCRPTO-1(B) ; IS IT A LIST
+ CAIE C,TLIST
+ JRST BADCHN
+ PUSH TP,$TLIST
+ PUSH TP,[0] ; SAVE A SLOT FOR THE LIST
+ MOVE C,SCRPTO(B) ; GET THE LIST OF SCRIPT CHANNELS
+SCPT1: GETYP B,(C) ; GET THE TYPE OF THIS SCRIPT CHAN
+ CAIE B,TCHAN
+ JRST BADCHN ; IF IT ISN'T A CHANNEL, COMPLAIN
+ HRRZ B,(C) ; GET THE REST OF THE LIST IN B
+ MOVEM B,(TP) ; AND STORE ON STACK
+ MOVE B,1(C) ; GET THE CHANNEL IN B
+ MOVE A,-1(P) ; AND THE CHARACTER IN A
+ PUSHJ P,W1CI ; GO TO INTERNAL W1C, IT BLESSES GOODIES
+ SKIPE C,(TP) ; GET THE REST OF LIST OF CHANS
+ JRST SCPT1 ; AND CYCLE THROUGH
+ SUB TP,[2,,2] ; CLEAN OFF THE LIST OF CHANS
+ POP P,C ; AND RESTORE ACCUMULATOR C
+SCPTDN: POP P,A ; RESTORE THE CHARACTER
+ POP TP,B ; AND THE ORIGINAL CHANNEL
+ POP TP,(TP)
+ POPJ P, ; AND THATS ALL
+
+
+; SUBROUTINE TO COPY FROM INCHAN TO OUTCHAN UNTIL EOF HIT
+; ON THE INPUT CHANNEL
+; CALL IS <FILECOPY IN OUT> WHERE DEFAULTS ARE INCHAN AND OUTCHAN
+
+ MFUNCTION FCOPY,SUBR,[FILECOPY]
+
+ ENTRY
+ HLRE 0,AB
+ CAMGE 0,[-4]
+ JRST WNA ; TAKES FROM 0 TO 2 ARGS
+
+ JUMPE 0,.+4 ; NO FIRST ARG?
+ PUSH TP,(AB)
+ PUSH TP,1(AB) ; SAVE IN CHAN
+ JRST .+6
+ MOVE A,$TATOM
+ MOVE B,IMQUOTE INCHAN
+ PUSHJ P,IDVAL
+ PUSH TP,A
+ PUSH TP,B
+ HLRE 0,AB ; CHECK FOR SECOND ARG
+ CAML 0,[-2] ; WAS THERE MORE THAN ONE ARG?
+ JRST .+4
+ PUSH TP,2(AB) ; SAVE SECOND ARG
+ PUSH TP,3(AB)
+ JRST .+6
+ MOVE A,$TATOM ; LOOK UP OUTCHAN AS DEFAULT
+ MOVE B,IMQUOTE OUTCHAN
+ PUSHJ P,IDVAL
+ PUSH TP,A
+ PUSH TP,B ; AND SAVE IT
+
+ MOVE A,-3(TP)
+ MOVE B,-2(TP) ; INPUT CHANNEL
+ MOVEI 0,C.READ ; INDICATE INPUT
+ PUSHJ P,CHKCHN ; CHECK FOR GOOD CHANNEL
+ MOVE A,-1(TP)
+ MOVE B,(TP) ; GET OUT CHAN
+ MOVEI 0,C.PRIN ; INDICATE OUT CHAN
+ PUSHJ P,CHKCHN ; CHECK FOR GOOD OUT CHAN
+
+ PUSH P,[0] ; COUNT OF CHARS OUTPUT
+
+ MOVE B,-2(TP)
+ PUSHJ P,GRB ; MAKE SURE WE HAVE READ BUFF
+ MOVE B,(TP)
+ PUSHJ P,GWB ; MAKE SURE WE HAVE WRITE BUFF
+
+FCLOOP: INTGO
+ MOVE B,-2(TP)
+ PUSHJ P,R1CHAR ; GET A CHAR
+ JUMPL A,FCDON ; IF A NEG NUMBER WE GOT EOF
+ MOVE B,(TP) ; GET OUT CHAN
+ PUSHJ P,W1CHAR ; SPIT IT OUT
+ AOS (P) ; INCREMENT COUNT
+ JRST FCLOOP
+
+FCDON: SUB TP,[2,,2] ; POP OFF OUTCHAN
+ MCALL 1,FCLOSE ; CLOSE INCHAN
+ MOVE A,$TFIX
+ POP P,B ; GET CHAR COUNT TO RETURN
+ JRST FINIS
+
+CHKCHN: PUSH P,0 ; CHECK FOR GOOD TASTING CHANNEL
+ PUSH TP,A
+ PUSH TP,B
+ GETYP C,A
+ CAIE C,TCHAN
+ JRST CHKBDC ; GO COMPLAIN IN RIGHT WAY
+; MOVEI B,DIRECT-1(B)
+; PUSHJ P,CHRWRD
+; JRST CHKBDC
+; MOVE C,(P) ; GET CHAN DIRECT
+ HRRZ C,-2(B) ; MODE BITS
+ TDNN C,0
+ JRST CHKBDC
+; CAMN B,CHKT(C)
+; JRST .+4
+; ADDI C,2 ; TEST FOR READB OR PRINTB ALSO
+; CAME B,CHKT(C) ; TEST FOR CORRECT DIRECT
+; JRST CHKBDC
+ MOVE B,(TP)
+ SKIPN IOINS(B) ; MAKE SURE IT IS OPEN
+ PUSHJ P,OPENIT ; IF ZERO IOINS GO OPEN IT
+ SUB TP,[2,,2]
+ POP P, ; CLEAN UP STACKS
+ POPJ P,
+
+CHKT: ASCIZ /READ/
+ ASCII /PRINT/
+ ASCII /READB/
+ <ASCII /PRINT/>+1
+
+CHKBDC: POP P,E
+ MOVNI D,2
+ IMULI D,1(E)
+ HLRE 0,AB
+ CAMLE 0,D ; SEE IF THIS WAS HIS ARG OF DEFAULT
+ JRST BADCHN
+ JUMPE E,WTYP1
+ JRST WTYP2
+
+\f; FUNCTIONS READSTRING AND PRINTSTRING WORK LIKE READB AND PRINTB,
+; THAT IS THEY READ INTO AND OUT OF STRINGS. IN ADDITION BOTH ACCEPT
+; AN ADDITIONAL ARGUMENT WHICH IS THE NUMBER OF CHARS TO READ OR PRINT, IF
+; IT IS DESIRED FOR THIS TO BE DIFFERENT THAN THE LENGTH OF THE STRING.
+
+; FORMAT IS <READSTRING .STRING .INCHANNEL .EOFCOND .MAXCHARS>
+; AND BOTH SUBRS RETURN THE NUMBER OF CHARS READ OR WRITTEN
+
+; FORMAT FOR PRINTSTRING IS <PRINTSTRING .STRING .OUTCHANNEL .MAXCHARS>
+
+; THESE WERE CODED 9/16/73 BY NEAL D. RYAN
+
+ MFUNCTION RSTRNG,SUBR,READSTRING
+
+ ENTRY
+ PUSH P,[0] ; FLAG TO INDICATE READING
+ HLRE 0,AB
+ CAMG 0,[-1]
+ CAMG 0,[-9]
+ JRST WNA ; CHECK THAT IT HAS FROM 1 TO 4 ARGS
+ JRST STRIO1
+
+ MFUNCTION PSTRNG,SUBR,PRINTSTRING
+
+ ENTRY
+ PUSH P,[1] ; FLAG TO INDICATE WRITING
+ HLRE 0,AB
+ CAMG 0,[-1]
+ CAMG 0,[-7]
+ JRST WNA ; CHECK THAT IT HAS FROM 1 TO 3 ARGS
+
+STRIO1: PUSH TP,[0] ; SAVE SLOT ON STACK
+ PUSH TP,[0]
+ GETYP 0,(AB)
+ CAIE 0,TCHSTR ; MAKE SURE WE GOT STRING
+ JRST WTYP1
+ HRRZ 0,(AB) ; CHECK FOR EMPTY STRING
+ SKIPN (P)
+ JUMPE 0,MTSTRN
+ HLRE 0,AB
+ CAML 0,[-2] ; WAS A CHANNEL GIVEN
+ JRST STRIO2
+ GETYP 0,2(AB)
+ SKIPN (P) ; SKIP IF PRINT
+ JRST TESTIN
+ CAIN 0,TTP ; SEE IF FLATSIZE HACK
+ JRST STRIO9
+TESTIN: CAIE 0,TCHAN
+ JRST WTYP2 ; SECOND ARG NOT CHANNEL
+ MOVE B,3(AB)
+ HRRZ B,-2(B)
+ MOVNI E,1 ; CHECKING FOR GOOD DIRECTION
+ TRNE B,C.READ ; SKIP IF NOT READ
+ MOVEI E,0
+ TRNE B,C.PRIN ; SKIP IF NOT PRINT
+ MOVEI E,1
+ CAME E,(P)
+ JRST WRONGD ; MAKE SURE CHANNEL IS OPEN IN RIGHT MODE
+STRIO9: PUSH TP,2(AB)
+ PUSH TP,3(AB) ; PUSH ON CHANNEL
+ JRST STRIO3
+STRIO2: MOVE B,IMQUOTE INCHAN
+ MOVSI A,TCHAN
+ SKIPE (P)
+ MOVE B,IMQUOTE OUTCHAN
+ PUSHJ P,IDVAL
+ GETYP 0,A
+ SKIPN (P) ; SKIP IF PRINTSTRING
+ JRST TESTI2
+ CAIN 0,TTP ; SKIP IF NOT FLATSIZE HACK
+ JRST STRIO8
+TESTI2: CAIE 0,TCHAN
+ JRST BADCHN ; MAKE SURE WE GOT A GOOD DEFAULT CHANNEL
+STRIO8: PUSH TP,A
+ PUSH TP,B
+STRIO3: MOVE B,(TP) ; GET CHANNEL
+ SKIPN E,IOINS(B)
+ PUSHJ P,OPENIT ; IF NOT GO OPEN
+ MOVE E,IOINS(B)
+ CAMN E,[JRST CHNCLS]
+ JRST CHNCLS ; CHECK TO SEE THAT CHANNEL ISNT ALREADY CLOSED
+STRIO4: HLRE 0,AB
+ CAML 0,[-4]
+ JRST STRIO5 ; NO COUNT TO WORRY ABOUT
+ GETYP 0,4(AB)
+ MOVE E,4(AB)
+ MOVE C,5(AB)
+ CAIE 0,TCHSTR
+ CAIN 0,TFIX ; BETTER BE A FIXED NUMBER
+ JRST .+2
+ JRST WTYP3
+ HRRZ D,(AB) ; GET ACTUAL STRING LENGTH
+ CAIN 0,TFIX
+ JRST .+7
+ SKIPE (P) ; TEST FOR WRITING
+ JRST .-7 ; IF WRITING WE GOT TROUBLE
+ PUSH P,D ; ACTUAL STRING LENGTH
+ MOVEM E,(TB) ; STUFF HIS FUNNY DELIM STRING
+ MOVEM C,1(TB)
+ JRST STRIO7
+ CAML D,C ; MAKE SURE THE STRING IS LONG ENOUGH
+ JRST .+2 ; WIN
+ ERRUUO EQUOTE COUNT-GREATER-THAN-STRING-SIZE
+ PUSH P,C ; PUSH ON MAX COUNT
+ JRST STRIO7
+STRIO5:
+STRIO6: HRRZ C,(AB) ; GET CHAR COUNT
+ PUSH P,C ; AND PUSH IT ON STACK AS NO MAX COUNT GIVEN
+STRIO7: HLRE 0,AB
+ CAML 0,[-6]
+ JRST .+6
+ MOVE B,(TP) ; GET THE CHANNEL
+ MOVE 0,6(AB)
+ MOVEM 0,EOFCND-1(B) ; STUFF IN SLOT IN CHAN
+ MOVE 0,7(AB)
+ MOVEM 0,EOFCND(B)
+ PUSH TP,(AB) ; PUSH ON STRING
+ PUSH TP,1(AB)
+ PUSH P,[0] ; PUSH ON CURRENT COUNT OF CHARS DONE
+ MOVE 0,-2(P) ; GET READ OR WRITE FLAG
+ JUMPN 0,OUTLOP ; GO WRITE STUFF
+
+ MOVE B,-2(TP) ; GET CHANNEL
+ PUSHJ P,GRB ; MAKE SURE WE HAVE BUFF
+ SKIPGE A,LSTCH(B) ; CHECK FOR EOF ALREADY READ PREVIOUSLY
+ JRST SRDOEF ; GO DOES HIS EOF HACKING
+INLOP: INTGO
+ MOVE B,-2(TP) ; GET CHANNEL
+ MOVE C,-1(P) ; MAX COUNT
+ CAMG C,(P) ; COMPARE WITH COUNT DONE
+ JRST STREOF ; WE HAVE FINISHED
+ PUSHJ P,R1CHAR ; GET A CHAR
+ JUMPL A,INEOF ; EOF HIT
+ MOVE C,1(TB)
+ HRRZ E,(TB) ; DO WE HAVE A STRING TO WORRY US?
+ SOJL E,INLNT ; GO FINISH STUFFING
+ ILDB D,C
+ CAME D,A
+ JRST .-3
+ JRST INEOF
+INLNT: IDPB A,(TP) ; STUFF IN STRING
+ SOS -1(TP) ; DECREMENT STRING COUNT
+ AOS (P) ; INCREMENT CHAR COUNT
+ JRST INLOP
+
+INEOF: SKIPE C,LSTCH(B) ; IS THIS AN ! AND IS THERE A CHAR THERE
+ JRST .+3 ; YES
+ MOVEM A,LSTCH(B) ; NO SAVE THE CHAR
+ JRST .+3
+ ADDI C,400000
+ MOVEM C,LSTCH(B)
+ MOVSI C,200000
+ IORM C,LSTCH(B)
+ HRRZ C,DIRECT-1(B) ; GET THE TYPE OF CHAN
+ CAIN C,5 ; IS IT READB?
+ JRST .+3
+ SOS ACCESS(B) ; FIX UP ACCESS FOR READ CHANNEL
+ JRST STREOF ; AND THATS IT
+ HRRZ C,ACCESS-1(B) ; FOR A READB ITS WORSE
+ MOVEI D,5
+ SKIPG C
+ HRRM D,ACCESS-1(B) ; CHANGE A 0 TO A FIVE
+ SOS C,ACCESS-1(B)
+ CAMN C,[TFIX,,0]
+ SOS ACCESS(B) ; AND SOS THE WORD COUNT MAYBE
+ JRST STREOF
+
+SRDOEF: SETZM LSTCH(B) ; IN CASE OF -1, FLUSH IT
+ AOJE A,INLOP ; SKIP OVER -1 ON PTY'S
+ SUB TP,[6,,6]
+ SUB P,[3,,3] ; POP JUNK OFF STACKS
+ PUSH TP,EOFCND-1(B)
+ PUSH TP,EOFCND(B) ; WHAT WE NEED TO EVAL
+ PUSH TP,$TCHAN
+ PUSH TP,B
+ MCALL 1,FCLOSE ; CLOSE THE LOOSING CHANNEL
+ MCALL 1,EVAL ; EVAL HIS EOF JUNK
+ JRST FINIS
+
+OUTLOP: MOVE B,-2(TP)
+OUTLP1: INTGO
+ MOVE A,-3(TP) ; GET CHANNEL
+ MOVE B,-2(TP)
+ MOVE C,-1(P) ; MAX COUNT TO DO
+ CAMG C,(P) ; HAVE WE DONE ENOUGH
+ JRST STREOF
+ ILDB D,(TP) ; GET THE CHAR
+ SOS -1(TP) ; SUBTRACT FROM STRING LENGTH
+ AOS (P) ; INC COUNT OF CHARS DONE
+ PUSHJ P,CPCH1 ; GO STUFF CHAR
+ JRST OUTLP1
+
+STREOF: MOVE A,$TFIX
+ POP P,B ; RETURN THE LOOSER A COUNT OF WHAT WAS DONE
+ SUB P,[2,,2]
+ SUB TP,[6,,6]
+ JRST FINIS
+
+
+GWB: SKIPE BUFSTR(B)
+ POPJ P,
+ PUSH TP,$TCHAN
+ PUSH TP,B ; GET US A WRITE BUFFER ON PRINTB CHAN
+ MOVEI A,BUFLNT
+ PUSHJ P,IBLOCK
+ MOVSI A,TWORD+.VECT.
+ MOVEM A,BUFLNT(B)
+ SETOM (B)
+ MOVEI C,1(B)
+ HRLI C,(B)
+ BLT C,BUFLNT-1(B)
+ MOVEI C,-1(B)
+ HRLI C,010700
+ MOVE B,(TP)
+ MOVEI 0,C.BUF
+ IORM 0,-2(B)
+ MOVEM C,BUFSTR(B)
+ MOVE C,[TCHSTR,,BUFLNT*5]
+ MOVEM C,BUFSTR-1(B)
+ SUB TP,[2,,2]
+ POPJ P,
+
+
+GRB: SKIPE BUFSTR(B)
+ POPJ P,
+ PUSH TP,$TCHAN
+ PUSH TP,B ; GET US A READ BUFFER
+ MOVEI A,BUFLNT
+ PUSHJ P,IBLOCK
+ MOVEI C,BUFLNT-1(B)
+ POP TP,B
+ MOVEI 0,C.BUF
+ IORM 0,-2(B)
+ HRLI C,010700
+ MOVEM C,BUFSTR(B)
+ MOVSI C,TCHSTR
+ MOVEM C,BUFSTR-1(B)
+ SUB TP,[1,,1]
+ POPJ P,
+
+MTSTRN: ERRUUO EQUOTE EMPTY-STRING
+
+\f; INPUT UNBUFFERING ROUTINE. THIS DOES THE CHARACTER UNBUFFERING
+; FOR INPUT. THE OPEN ROUTINE SETUPS A PUSHJ P, TO
+; THIS ROUTINE AS THE IOINS FOR A CHANNEL OPEN TO A NON-TTY DEVICE.
+
+; H. BRODIE 7/19/72
+
+; CALLING SEQ:
+; PUSHJ P,GETCHR
+; B/ AOBJN PNTR TO CHANNEL VECTOR
+; RETURNS NEXT CHARACTER IN AC A.
+; ON ENCOUNTERING EITHER ^C OR NUL(^@) IT ASSUMES EOF AND
+; TRANSMITS ONLY ^C ON SUCCESSIVE CALLS
+
+
+GETCHR:
+; FIRST GRAB THE BUFFER
+; GETYP A,BUFSTR-1(B) ; GET TYPE WORD
+; CAIN A,TCHSTR ; SKIPS IF NOT CHSTR (I.E. IF BAD BUFFER)
+; JRST GTGBUF ; IS GOOD BUFFER...SKIP ERROR RETURN
+GTGBUF: HRRZ A,BUFSTR-1(B) ; GET LENGTH OF STRING
+ SOJGE A,GTGCHR ; JUMP IF STILL MORE
+
+; HERE IF THE BUFFER WAS EXHAUSTED (BYTE PNTR POINTS INTO DOPE WDS)
+; GENERATE AN .IOT POINTER
+;FIRST SAVE C AND D AS I WILL CLOBBER THEM
+NEWBUF: PUSH P,C
+ PUSH P,D
+IFN ITS,[
+ LDB C,[600,,STATUS(B)] ; GET TYPE
+ CAIG C,2 ; SKIP IF NOT TTY
+]
+IFE ITS,[
+ SKIPE BUFRIN(B)
+]
+ JRST GETTTY ; GET A TTY BUFFER
+
+ PUSHJ P,PGBUFI ; RE-FILL BUFFER
+
+IFE ITS, MOVEI C,-1
+ JUMPGE A,BUFGOO ;SKIPS IF IOT COMPLETED...FIX UP CHANNEL
+IFN ITS,[
+ MOVEI C,1 ; MAKE SURE LAST EOF REALLY ENDS IT
+ ANDCAM C,-1(A)
+]
+ MOVSI C,014000 ; GET A ^C
+ MOVEM C,(A) ;FAKE AN EOF
+
+IFE ITS,[
+ HLRE C,A ; HOW MUCH LEFT
+ ADDI C,BUFLNT ; # OF WORDS TO C
+ IMULI C,5 ; TO CHARS
+ PUSH P,0
+ MOVEI 0,1
+ SKIPE C
+ ANDCAM 0,-1(1)
+ POP P,0
+ MOVE A,-2(B) ; GET BITS
+ TRNE A,C.BIN ; CAN'T HELP A BINARY CHANNEL
+ JRST BUFGOO
+ MOVE A,CHANNO(B)
+ PUSH P,B
+ PUSH P,D
+ PUSH P,C
+ PUSH P,[0]
+ PUSH P,[0]
+ MOVEI C,-1(P)
+ MOVE B,[2,,11] ; READ WORD CONTAINING BYTE SIZE
+ GTFDB
+ LDB D,[300600,,-1(P)] ; GET BYTE SIZE
+ MOVE B,(P)
+ SUB P,[2,,2]
+ POP P,C
+ CAIE D,7 ; SEVEN BIT BYTES?
+ JRST BUFGO1 ; NO, DONT HACK
+ MOVE D,C
+ IDIVI B,5 ; C IS NUMBER IN LAST WORD IF NOT EVEN
+ SKIPN C
+ MOVEI C,5
+ ADDI C,-5(D) ; FIXUP C FOR WINNAGE
+BUFGO1: POP P,D
+ POP P,B
+]
+; RESET THE BYTE POINTER IN THE CHANNEL.
+; BUILD ONE USING THE PTR TO BEG OF BUFFER SAVED IN D
+BUFGOO: HRLI D,010700 ; GENERATE VIRGIN LH
+ SUBI D,1
+
+ MOVEM D,BUFSTR(B) ; STASH IN THE BUFFER BYTE PNTR SLOT
+IFE ITS, HRRM C,LSTCH-1(B) ; SAVE IT
+ MOVEI A,BUFLNT*5-1
+BUFROK: POP P,D ;RESTORE D
+ POP P,C ;RESTORE C
+
+
+; HERE IF THERE ARE CHARS IN BUFFER
+GTGCHR: HRRM A,BUFSTR-1(B)
+ ILDB A,BUFSTR(B) ; GET A CHAR FROM BUFFER
+
+IFN ITS,[
+ CAIE A,3 ; EOF?
+ POPJ P, ; AND RETURN
+ LDB A,[600,,STATUS(B)] ; CHECK FOR TTY
+ CAILE A,2 ; SKIP IF TTY
+]
+IFE ITS,[
+ PUSH P,0
+ HRRZ 0,LSTCH-1(B)
+ SOJL 0,.+4
+ HRRM 0,LSTCH-1(B)
+ POP P,0
+ POPJ P,
+
+ POP P,0
+ MOVSI A,-1
+ SKIPN BUFRIN(B)
+]
+ JRST .+3
+RETEO1: HRRI A,3
+ POPJ P,
+
+ HRRZ A,BUFSTR(B) ; SEE IF RSUBR START BIT IS ON
+ HRRZ A,(A)
+ TRNN A,1
+ MOVSI A,-1
+ JRST RETEO1
+
+IFN ITS,[
+PGBUFO:
+PGBUFI:
+]
+IFE ITS,[
+PGBUFO: SKIPA D,[SOUT]
+PGBUFI: MOVE D,[SIN]
+]
+ SKIPGE A,BUFSTR(B) ; POINT TO CURRENT BUFFER POSIT
+ SUBI A,1 ; FOR 440700 AND 010700 START
+ SUBI A,BUFLNT-1 ; CALCULATE PNTR TO BEG OF BUFFER
+ HRLI A,-BUFLNT ; IOT (AOBJN) PNTR IN A
+ MOVSI C,004400
+IFN ITS,[
+PGBIOO:
+PGBIOI: MOVE D,A ; COPY FOR LATER
+ MOVSI C,TUVEC ; PREPARE TO HANDDLE INTS
+ MOVE PVP,PVSTOR+1
+ MOVEM C,DSTO(PVP)
+ MOVEM C,ASTO(PVP)
+ MOVSI C,TCHAN
+ MOVEM C,BSTO(PVP)
+
+; BUILD .IOT INSTR
+ MOVE C,CHANNO(B) ; CHANNEL NUMBER IN C
+ ROT C,23. ; MOVE INTO AC FIELD
+ IOR C,[.IOT 0,A] ; IOR IN SKELETON .IOT
+
+; DO THE .IOT
+ ENABLE ; ALLOW INTS
+ XCT C ; EXECUTE THE .IOT INSTR
+ DISABLE
+ MOVE PVP,PVSTOR+1
+ SETZM BSTO(PVP)
+ SETZM ASTO(PVP)
+ SETZM DSTO(PVP)
+ POPJ P,
+]
+
+IFE ITS,[
+PGBIOT: PUSH P,D
+ PUSH TP,$TCHAN
+ PUSH TP,B
+ PUSH P,C
+ HRRZS (P)
+ HRRI C,-1(A) ; POINT TO BUFFER
+ HLRE D,A ; XTRA POINTER
+ MOVNS D
+ HRLI D,TCHSTR
+ MOVE PVP,PVSTOR+1
+ MOVEM D,BSTO(PVP)
+ MOVE D,[PUSHJ P,FIXACS]
+ MOVEM D,ONINT
+ MOVSI D,TUVEC
+ MOVEM D,DSTO(PVP)
+ MOVE D,A
+ MOVE A,CHANNO(B) ; FILE JFN
+ MOVE B,C
+ HLRE C,D ; - COUNT TO C
+ SKIPE (P)
+ MOVN C,(P) ; REAL DESIRED COUNT
+ SUB P,[1,,1]
+ ENABLE
+ XCT (P) ; DO IT TO IT
+ DISABLE
+ MOVE PVP,PVSTOR+1
+ SETZM BSTO(PVP)
+ SETZM DSTO(PVP)
+ SETZM ONINT
+ MOVEI A,1(B)
+ MOVE B,(TP)
+ SUB TP,[2,,2]
+ SUB P,[1,,1]
+ JUMPGE C,CPOPJ ; NO EOF YET
+ HRLI A,(C) ; LOOK LIKE AN AOBJN PNTR
+ POPJ P,
+
+FIXACS: PUSH P,PVP
+ MOVE PVP,PVSTOR+1
+ MOVNS C
+ HRRM C,BSTO(PVP)
+ MOVNS C
+ POP P,PVP
+ POPJ P,
+
+PGBIOO: SKIPA D,[SOUT]
+PGBIOI: MOVE D,[SIN]
+ HRLI C,004400
+ JRST PGBIOT
+DOIOTO: PUSH P,[SOUT]
+DOIOTC: PUSH P,B
+ PUSH P,C
+ EXCH A,B
+ MOVE A,CHANNO(A)
+ HLRE C,B
+ HRLI B,444400
+ XCT -2(P)
+ HRL B,C
+ MOVE A,B
+DOIOTE: POP P,C
+ POP P,B
+ SUB P,[1,,1]
+ POPJ P,
+DOIOTI: PUSH P,[SIN]
+ JRST DOIOTC
+]
+\f
+; OUTPUT BUFFERING ROUTINES SIMILAR TO INPUT BUFFERING ROUTINES OF PREV PAGE
+
+PUTCHR: PUSH P,A
+ GETYP A,BUFSTR-1(B) ; CHECK TYPE OF ARG
+ CAIE A,TCHSTR ; MUST BE STRING
+ JRST BDCHAN
+
+ HRRZ A,BUFSTR-1(B) ; GET CHAR COUNT
+ JUMPE A,REBUFF ; PREV RESET BUFF, UNDO SAME
+
+PUTCH1: POP P,A ; RESTORE CHAR
+ CAMN A,[-1] ; SPECIAL HACK?
+ JRST PUTCH2 ; YES GO HANDLE
+ IDPB A,BUFSTR(B) ; STUFF IT
+PUTCH3: SOS A,BUFSTR-1(B) ; COUNT DOWN STRING
+ TRNE A,-1 ; SKIP IF FULL
+ POPJ P,
+
+; HERE TO FLUSH OUT A BUFFER
+
+ PUSH P,C
+ PUSH P,D
+ PUSHJ P,PGBUFO ; SETUP AND DO IOT
+ HRLI D,010700 ; POINT INTO BUFFER
+ SUBI D,1
+ MOVEM D,BUFSTR(B) ; STORE IT
+ MOVEI A,BUFLNT*5 ; RESET COUNT
+ HRRM A,BUFSTR-1(B)
+ POP P,D
+ POP P,C
+ POPJ P,
+
+;HERE TO DA ^C AND TURN ON MAGIC BIT
+
+PUTCH2: MOVEI A,3
+ IDPB A,BUFSTR(B) ; ZAP OUT THE ^C
+ MOVEI A,1 ; GET BIT
+IFE ITS,[
+ PUSH P,C
+ HRRZ C,BUFSTR(B)
+ IORM A,(C)
+ POP P,C
+]
+IFN ITS,[
+ IORM A,@BUFSTR(B) ; ON GOES THE BIT
+]
+ JRST PUTCH3
+
+; RESET A FUNNY BUF
+
+REBUFF: MOVEI A,BUFLNT*5 ; 1ST COUNT
+ HRRM A,BUFSTR-1(B)
+ HRRZ A,BUFSTR(B) ; NOW POINTER
+ SUBI A,BUFLNT+1
+ HRLI A,010700
+ MOVEM A,BUFSTR(B) ; STORE BACK
+ JRST PUTCH1
+
+
+; HERE TO FLUSH FINAL BUFFER
+
+BFCLOS: HRRZ C,-2(B) ; THIS BUFFER FLUSHER THE WORK OF NDR
+ MOVEI A,0
+ TRNE C,C.TTY
+ POPJ P,
+ TRNE C,C.DISK
+ MOVEI A,1
+ PUSH P,A ; SAVE THE RESULT OF OUR TEST
+ JUMPN A,BFCLNN ; DONT HAVE TO CHECK NET STATE
+ PUSH TP,$TCHAN
+ PUSH TP,B ; SAVE CHANNEL
+ PUSHJ P,INSTAT ; GET CURRENT NETWORK STATE
+ MOVE A,(B) ; GET FIRST ELEMENT OF STATE UVECTOR WHICH IS CUR STATE
+ POP TP,B ; RESTORE B
+ POP TP,
+ CAIE A,5 ; IS NET IN OPEN STATE?
+ CAIN A,6 ; OR ELSE IS IT IN RFNM WAIT STATE
+ JRST BFCLNN ; IF SO TO THE IOT
+ POP P, ; ELSE FLUSH CRUFT AND DONT IOT
+ POPJ P, ; RETURN DOING NO IOT
+BFCLNN: MOVEI C,BUFLNT*5 ; NEW BUFFER FLUSHER BY NDR
+ HRRZ D,BUFSTR-1(B) ; SO THAT NET ALSO WORKS RIGHT
+ SUBI C,(D) ; GET NUMBER OF CHARS
+ IDIVI C,5 ; NUMBER OF FULL WORDS AND REST
+ PUSH P,D ; SAVE NUMBER OF ODD CHARS
+ SKIPGE A,BUFSTR(B) ; GET CURRENT BUF POSITION
+ SUBI A,1 ; FIX FOR 440700 BYTE POINTER
+IFE ITS,[
+ HRRO D,A
+ PUSH P,(D)
+]
+IFN ITS,[
+ PUSH P,(A) ; SAVE THE ODD WORD OF BUFFER
+]
+ MOVEI D,BUFLNT
+ SUBI D,(C)
+ SKIPE -1(P)
+ SUBI A,1
+ ADDI D,1(A) ; FIX UP FOR POSSIBLE ODD CHARS
+ PUSH TP,$TUVEC
+ PUSH TP,D ; PUSH THE DOPE VECTOR ONTO THE STACK
+ JUMPE C,BFCLSR ; IN CASE THERE ARE NO FULL WORDS TO DO
+ HRL A,C
+ TLO A,400000
+ MOVE E,[SETZ BUFLNT(A)]
+ SUBI E,(C) ; FIX UP FOR BACKWARDS BLT
+ POP A,@E ; AMAZING GRACE
+ TLNE A,377777
+ JRST .-2
+ HRRO A,D ; SET UP AOBJN POINTER
+ SUBI A,(C)
+ TLC A,-1(C)
+ PUSHJ P,PGBIOO ; DO THE IOT OF ALL THE FULL WORDS
+BFCLSR: HRRO A,(TP) ; GET IOT PTR FOR REST OF JUNK
+ SUBI A,1 ; POINT TO WORD BEFORE DOPE WORDS
+ POP P,0 ; GET BACK ODD WORD
+ POP P,C ; GET BACK ODD CHAR COUNT
+ POP P,D ; FLAG FOR NET OR DSK
+ JUMPN D,BFCDSK ; GO FINISH OFF DSK
+ JUMPE C,BFCLSD ; IF NO ODD CHARS FINISH UP
+ MOVEI D,7
+ IMULI D,(C) ; FIND NO OF BITS TO SHIFT
+ LSH 0,-43(D) ; SHIFT BITS TO RIGHT PLACE
+ MOVEM 0,(A) ; STORE IN STRING
+ SUBI C,5 ; HOW MANY CHAR POSITIONS TO SKIP
+ MOVNI C,(C) ; MAKE C POSITIVE
+ LSH C,17
+ TLC A,(C) ; MUNG THE AOBJN POINTER TO KLUDGE
+ PUSHJ P,PGBIOO ; DO IOT OF ODD CHARS
+ MOVEI C,0
+BFCLSD: HRRZ A,(TP) ; GET PTR TO DOPE WORD
+ SUBI A,BUFLNT+1
+ JUMPLE C,.+3
+ SKIPE ACCESS(B)
+ MOVEM 0,1(A) ; LAST WORD BACK IN BFR
+ HRLI A,010700 ; AOBJN POINTER TO FIRST OF BUFFER
+ MOVEM A,BUFSTR(B)
+ MOVEI A,BUFLNT*5
+ HRRM A,BUFSTR-1(B)
+ SKIPN ACCESS(B)
+ JRST BFCLSY
+ JUMPL C,BFCLSY
+ JUMPE C,BFCLSZ
+ IBP BUFSTR(B)
+ SOS BUFSTR-1(B)
+ SOJG C,.-2
+BFCLSY: MOVE A,CHANNO(B)
+ MOVE C,B
+IFE ITS,[
+ RFPTR
+ FATAL RFPTR FAILED
+ HRRZ F,LSTCH-1(C) ; PREVIOUS HIGH
+ MOVE G,C ; SAVE CHANNEL
+ MOVE C,B
+ CAML F,B
+ MOVE C,F
+ MOVE F,B
+ HRLI A,400000
+ CLOSF
+ JFCL
+ MOVNI B,1
+ HRLI A,12
+ CHFDB
+ MOVE B,STATUS(G)
+ ANDI A,-1
+ OPENF
+ FATAL OPENF LOSES
+ MOVE C,F
+ IDIVI C,5
+ MOVE B,C
+ SFPTR
+ FATAL SFPTR FAILED
+ MOVE B,G
+]
+IFN ITS,[
+ DOTCAL RFPNTR,[A,[2000,,B]]
+ .LOSE %LSFIL ;PRESUMABLY LOSSAGE MATTERS
+ SUBI B,1
+ DOTCAL ACCESS,[A,B]
+ .LOSE %LSFIL ;PRESUMABLY LOSSAGE MATTERS
+ MOVE B,C
+]
+BFCLSZ: SUB TP,[2,,2]
+ POPJ P,
+
+BFCDSK: TRZ 0,1
+ PUSH P,C
+IFE ITS,[
+ PUSH TP,$TCHAN
+ PUSH TP,B
+ PUSH P,0 ; WORD OF CHARS
+ MOVE A,CHANNO(B)
+ MOVEI B,7 ; MAKE BYTE SIZE 7
+ SFBSZ
+ JFCL
+ HRROI B,(P)
+ MOVNS C
+ SKIPE C
+ SOUT
+ MOVE B,(TP)
+ SUB P,[1,,1]
+ SUB TP,[2,,2]
+]
+IFN ITS,[
+ MOVE D,[440700,,A]
+ DOTCAL SIOT,[CHANNO(B),D,C]
+ .LOSE %LSFIL ;PRESUMABLY LOSSAGE MATTERS
+]
+ POP P,C
+ JUMPN C,BFCLSD
+BFCDS1: MOVNI C,1 ; INDICATE NOT TOHACK BUFFER
+ JRST BFCLSD
+
+BFCLS1: HRRZ C,DIRECT-1(B)
+ MOVSI 0,(JFCL)
+ CAIE C,6
+ MOVE 0,[AOS ACCESS(B)]
+ PUSH P,0
+ HRRZ C,BUFSTR-1(B)
+ IDIVI C,5
+ JUMPE D,BCLS11
+ MOVEI A,40 ; PAD WITH SPACES
+ PUSHJ P,PUTCHR
+ XCT (P) ; AOS ACCESS IF NECESSARY
+ SOJG D,.-3 ; TO END OF WORD\r
+BCLS11: POP P,0
+ HLLZS ACCESS-1(B)
+ HRRZ C,BUFSTR-1(B)
+ CAIE C,BUFLNT*5
+ PUSHJ P,BFCLOS
+ POPJ P,
+
+\f
+; HERE TO GET A TTY BUFFER
+
+GETTTY: SKIPN C,EXBUFR(B) ; SKIP IF BUFFERS BACKED UP
+ JRST TTYWAI
+ HRRZ D,(C) ; CDR THE LIST
+ GETYP A,(C) ; CHECK TYPE
+ CAIE A,TDEFER ; MUST BE DEFERRED
+ JRST BDCHAN
+ MOVE C,1(C) ; GET DEFERRED GOODIE
+ GETYP A,(C) ; BETTER BE CHSTR
+ CAIE A,TCHSTR
+ JRST BDCHAN
+ MOVE A,(C) ; GET FULL TYPE WORD
+ MOVE C,1(C)
+ MOVEM D,EXBUFR(B) ; STORE CDR'D LIST
+ MOVEM A,BUFSTR-1(B) ; MAKE CURRENT BUFFER
+ MOVEM C,BUFSTR(B)
+ HRRM A,LSTCH-1(B)
+ SOJA A,BUFROK
+
+TTYWAI: PUSHJ P,TTYBLK ; BLOCKED FOR TTY I/O
+ JRST GETTTY ; SHOULD ONLY RETURN HAPPILY
+
+\f;INTERNAL DEVICE READ ROUTINE.
+
+;FOR INTERNAL DEVICES THIS ROUTINE APPLIES THE GIVEN OBJECT,
+;CHECKS THAT THE RETURNED VALUE IS OF TYPE CHARACTER,
+;AND RETURNS THAT AS THE NEXT CHARACTER IN THE "FILE"
+
+;H. BRODIE 8/31/72
+
+GTINTC: PUSH TP,$TCHAN ;SAVE THE CHANNEL...WE'LL CLOBBER B
+ PUSH TP,B
+ PUSH P,C ;AND SAVE THE OTHER ACS
+ PUSH P,D
+ PUSH P,E
+ PUSH P,0
+ PUSH TP,$TCHAN
+ PUSH TP,B
+ MCALL 1,INTFCN-1(B)
+ GETYP A,A
+ CAIE A,TCHRS
+ JRST BADRET
+ MOVE A,B
+INTRET: POP P,0 ;RESTORE THE ACS
+ POP P,E
+ POP P,D
+ POP P,C
+ POP TP,B ;RESTORE THE CHANNEL
+ SUB TP,[1,,1] ;FLUSH $TCHAN...WE DON'T NEED IT
+ POPJ P,
+
+
+BADRET: ERRUUO EQUOTE INT-DEVICE-WRONG-TYPE-EVALUATION-RESULT
+
+;INTERNAL DEVICE PRINT ROUTINE.
+
+;FOR INTERNAL DEVICES THIS ROUTINE APPLIES THE GIVEN OBJECT,(FUNCTION, SUBR, OR RSUBR)
+;TO THE CURRENT CHARACTER BEING "PRINTED".
+
+PTINTC: PUSH TP,$TCHAN ;SAVE THE CHANNEL...WE'LL CLOBBER B
+ PUSH TP,B
+ PUSH P,C ;AND SAVE THE OTHER ACS
+ PUSH P,D
+ PUSH P,E
+ PUSH P,0
+ PUSH TP,$TCHRS ;PUSH THE TYPE "CHARACTER"
+ PUSH TP,A ;PUSH THE CHAR
+ PUSH TP,$TCHAN ;PUSH THE CHANNEL
+ PUSH TP,B
+ MCALL 2,INTFCN-1(B) ;APPLY THE FUNCTION TO THE CHAR
+ JRST INTRET
+
+
+\f
+; ROUTINE TO FLUSH OUT A PRINT BUFFER
+
+MFUNCTION BUFOUT,SUBR
+
+ ENTRY 1
+
+ GETYP 0,(AB)
+ CAIE 0,TCHAN
+ JRST WTYP1
+
+ MOVE B,1(AB)
+; MOVEI B,DIRECT-1(B)
+; PUSHJ P,CHRWRD ; GET DIR NAME
+; JFCL
+; CAMN B,[ASCII /PRINT/]
+; JRST .+3
+; CAME B,[<ASCII /PRINT/>+1]
+; JRST WRONGD
+; TRNE B,1 ; SKIP IF PRINT
+; PUSH P,[JFCL]
+; TRNN B,1 ; SKIP IF PRINTB
+; PUSH P,[AOS ACCESS(B)]
+ HRRZ 0,-2(B)
+ TRNN 0,C.PRIN
+ JRST WRONGD
+; TRNE 0,C.BIN ; SKIP IF PRINT
+; PUSH P,[JFCL]
+; TRNN 0,C.BIN ; SKIP IF PRINTB
+; PUSH P,[AOS ACCESS(B)]
+; MOVE B,1(AB)
+; GETYP 0,BUFSTR-1(B)
+; CAIN 0,TCHSTR
+; SKIPN A,BUFSTR(B) ; BYTE POINTER?
+; JRST BFIN1
+; HRRZ C,BUFSTR-1(B) ; CHARS LEFT
+; IDIVI C,5 ; MULTIPLE OF 5?
+; JUMPE D,BFIN2 ; YUP NO EXTRAS
+
+; MOVEI A,40 ; PAD WITH SPACES
+; PUSHJ P,PUTCHR ; OUT IT GOES
+; XCT (P) ; MAYBE BUMP ACCESS
+; SOJG D,.-3 ; FILL
+
+BFIN2: PUSHJ P,BFCLOS ; WRITE OUT BUFFER
+
+BFIN1: MOVSI A,TCHAN
+ JRST FINIS
+
+
+
+; FUNCTION TO GET THE FILE LENGTH OF A READ CHANNEL
+
+MFUNCTION FILLNT,SUBR,[FILE-LENGTH]
+ ENTRY 1
+
+ GETYP 0,(AB)
+ CAIE 0,TCHAN
+ JRST WTYP1
+ MOVE B,1(AB)
+ PUSHJ P,CFILLE
+ JRST FINIS
+
+CFILLE:
+IFN 0,[
+ MOVEI B,DIRECT-1(B) ; GET CHANNEL TYPE
+ PUSHJ P,CHRWRD
+ JFCL
+ CAME B,[ASCIZ /READ/]
+ JRST .+3
+ PUSH P,[5] ; MULTIPLICATIVE FACTOR FOR READ
+ JRST .+4
+ CAME B,[ASCII /READB/]
+ JRST WRONGD
+ PUSH P,[1] ; MULTIPLICATIVE FACTOR FOR READ
+]
+ MOVE C,-2(B) ; GET BITS
+ MOVEI D,5 ; ASSUME ASCII
+ TRNE C,C.BIN ; SKIP IF NOT BINARY
+ MOVEI D,1
+ PUSH P,D
+ MOVE C,B
+IFN ITS,[
+ .CALL FILL1
+ JRST FILLOS ; GIVE HIM A NICE FALSE
+]
+IFE ITS,[
+ MOVE A,CHANNO(C)
+ PUSH P,[0]
+ MOVEI C,(P)
+ MOVE B,[1,,11] ; READ WORD CONTAINING BYTE SIZE
+ GTFDB
+ LDB D,[300600,,(P)] ; GET BYTE SIZE
+ JUMPN D,.+2
+ MOVEI D,36. ; HANDLE "0" BYTE SIZE
+ SUB P,[1,,1]
+ SIZEF
+ JRST FILLOS
+]
+ POP P,C
+IFN ITS, IMUL B,C
+IFE ITS,[
+ CAIN C,5
+ CAIE D,7
+ JRST NOTASC
+]
+YESASC: MOVE A,$TFIX
+ POPJ P,
+
+IFE ITS,[
+NOTASC: MOVEI 0,36.
+ IDIV 0,D ; BYTES PER WORD
+ IDIVM B,0
+ IMUL C,0
+ MOVE B,C
+ JRST YESASC
+]
+
+IFN ITS,[
+FILL1: SETZ ; BLOCK FOR .CALL TO FILLEN
+ SIXBIT /FILLEN/
+ CHANNO (C)
+ SETZM B
+
+FILLOS: MOVE A,CHANNO(C)
+ MOVE B,[.STATUS A] ;MAKE A CALL TO STATUS TO FIND REASON
+ LSH A,23. ;SHIFT THE CHANNEL NUMBER INTO RIGHT PLACE
+ IOR B,A ;FIX UP .STATUS
+ XCT B
+ MOVE B,C
+ PUSHJ P,GFALS
+ POP P,
+ POPJ P,
+]
+IFE ITS,[
+FILLOS: MOVE B,C
+ PUSHJ P,TGFALS
+ POP P,
+ POPJ P,
+]
+
+
+\f; MCHAN LOW-LEVEL I/O GARBAGE (PDL)-ORIGINAL (LIM)-ADDITIONS
+
+;CALLING ROUTINE: AC-A contains pointer to block of SIXBIT data
+; DIR ? DEV ? FNM1 ? FNM2 ? SNM
+;RETURNED VALUE : AC-A = <channel #, or -1 if no channel available>
+IFN ITS,[
+MOPEN: PUSH P,B
+ PUSH P,C
+ MOVE C,FRSTCH ; skip gc and tty channels
+CNLP: DOTCAL STATUS,[C,[2000,,B]]
+ .LOSE %LSFIL
+ ANDI B,77
+ JUMPE B,CHNFND ; found unused channel ?
+ ADDI C,1 ; try another channel
+ CAIG C,17 ; are all the channels used ?
+ JRST CNLP
+ SETO C, ; all channels used so C = -1
+ JRST CHNFUL
+CHNFND: MOVEI B,(C)
+ HLL B,(A) ; M.DIR slot
+ DOTCAL OPEN,[B,1(A),2(A),3(A),4(A)]
+ SKIPA
+ AOS -2(P) ; successful skip when returning
+CHNFUL: MOVE A,C
+ POP P,C
+ POP P,B
+ POPJ P,
+
+MIOT: DOTCAL IOT,[A,B]
+ JFCL
+ POPJ P,
+
+MCLOSE: DOTCAL CLOSE,[A]
+ JFCL
+ POPJ P,
+
+IMPURE
+
+FRSTCH: 1
+
+PURE
+]
+\f;THREE GENERALLY USEFUL ERROR ROUTINES FOR I/O
+
+NOTNET:
+BADCHN: ERRUUO EQUOTE BAD-CHANNEL
+BDCHAN: ERRUUO EQUOTE BAD-INPUT-BUFFER
+
+WRONGD: ERRUUO EQUOTE WRONG-DIRECTION-CHANNEL
+
+CHNCLS: ERRUUO EQUOTE CHANNEL-CLOSED
+
+BAD6: ERRUUO EQUOTE NON-6-BIT-CHARACTER-IN-FILE-NAME
+
+DISLOS: MOVE C,$TCHSTR
+ MOVE D,CHQUOTE [DISPLAY NOT AVAILABLE]
+ PUSHJ P,INCONS
+ MOVSI A,TFALSE
+ JRST OPNRET
+
+NOCHAN: ERRUUO EQUOTE ITS-CHANNELS-EXHAUSTED
+
+MODE1: 232020,,202020
+MODE2: 232023,,330320
+
+END
+
+\f
\ No newline at end of file
--- /dev/null
+TITLE LOADGC MODULE TO LOAD THE GARBAGE COLLECTOR
+
+RELOCA
+
+.INSRT MUDDLE >
+SYSQ
+IFE ITS,[
+.INSRT STENEX >
+XJRST==JRST 5,
+]
+IFN ITS, PGSZ==10.
+IFE ITS, PGSZ==9.
+
+; ROUTINES TO GET THE GC DO PDL OVERFLOWS IN GC AND ALLOCATE SPECIAL
+; BUFFERS.
+
+; IMPORTANT VARAIBLES
+
+.GLOBAL PAGEGC ; STARTING PAGE OF GARBAGE COLLECTOR (PAGES)
+.GLOBAL LENGC ; LENGTH OF GARBAGE COLLECTOR (PAGES)
+.GLOBAL SLENGC ; LENGTH OF MARK/SWEEP GARBAGE COLLECTOR
+.GLOBAL MRKPDL ; STARTING LOCATION OF MARK PDL (WORDS)
+.GLOBAL STRBUF ; START OF BUFFER LOCATIONS (WORDS)
+.GLOBAL SWAPGC ; WHICH GARBAGE COLLECTOR TO LOAD
+
+.GLOBAL MARK2G ; GENERAL MARKING ROUTINE FOR TEMPLATE STUFF
+.GLOBAL MARK2A,MARK2S ; SPECIFIC MARKERS IN SGC/AGC
+.GLOBAL SECLEN ; LENGTH OF SECTION GC GUY
+.GLOBAL MULTSG
+.GLOBAL SECBLK,DECBLK,GCDEBU,DEBUGC,NDEBUG
+.GLOBAL FRETOP,PURBOT,PURTOP,GCPDL,LPUR,STRPAG,CKPUR,INPLOD,GETPAG,CURPLN,SGCLBK,PGCNT
+.GLOBAL LODGC,CKFILE,SLEEPR,KILGC,GETBUF,KILBUF,GPDLOV,GCDIR,INTDIR,GCLDBK
+.GLOBAL OPBLK,SJFNS,IJFNS,OPSYS,IJFNS1,RBLDM,ILDBLK,TILDBL
+.GLOBAL TMTNXS,C%1
+
+IFN ITS,[
+IMAPCH==0 ; INTERNAL MAPPING CHANNEL
+MAPCHN==1000,,IMAPCH ; CORBLK CHANNEL
+FME==1000,,-1 ; BITS FOR CURRENT JOB
+FLS==1000,,0 ; BITS TO FLUSH A PAGE
+RDTP==1000,,200000 ; BITS TO MAP IN IN READ-ONLY
+WRTP==1000,,100000
+CRJB==1000,,400001 ; BITS TO ALLOCATE CORE
+CWRITE==1000,,4000
+]
+IFE ITS,[
+MFORK==400000
+CTREAD==100000 ; READ BIT
+CTEXEC==20000 ; EXECUTE BIT
+CTWRIT==40000 ; WRITE BIT
+CTCW==400 ; COPY ON WRITE
+SGJF==1 ; USE SHORT JFN (LH FLAG)
+OLDF==100000 ; REQUIRE OLD (EXISTING FILE) (LH FLAG)
+FREAD==200000 ; READ BIT FOR OPENF
+FEXEC==40000 ; EXEC BIT FOR OPENF
+FTHAW==2000
+]
+; GENERAL MARK ROUTINE FOR TEMPLATE STUFF. GOES TO RIGHT PLACE IN
+; WHICHEVER GC'ER WE'RE USING AT THE MOMENT
+MARK2G: SKIPN SWAPGC
+ JRST MARK2A ; INTO AGC
+ JRST MARK2S ; INTO SGC
+
+; ROUTINE TO LOAD THE GARBAGE COLLECTOR
+
+LODGC:
+IFN ITS,[
+ MOVEI 0,GCLDBK
+ SKIPE SWAPGC ; SKIP IF SWAPPED GARBAGE COLLECTOR
+ MOVEI 0,SGCLBK
+ MOVEM 0,OPBLK
+
+
+ .SUSET [.RSNAM,,SAVSNM] ; SAVE OLD SNAME
+ .SUSET [.SSNAM,,GCDIR] ; SET SNAME TO APP DIR
+ .OPEN IMAPCH,@OPBLK ; OPEN CHANNEL TO FILE
+ PUSHJ P,CKFILE ; SEE IF REALLY LOSING
+ HRLZI A,-LENGC+3
+ SKIPE SWAPGC
+ HRLZI A,-SLENGC
+ MOVE B,A ; B WILL CONTAIN PTR TO CORE
+ HRRI B,PAGEGC
+ DOTCAL CORBLK,[[RDTP],[FME],B,[MAPCHN],A]
+ PUSHJ P,SLEEPR
+ HRLI B,-1
+ SKIPN SWAPGC ; IF SWAP 1 PAGE FOR CORBLK ELSE 3
+ HRLI B,-3
+GETIT: DOTCAL CORBLK,[[WRTP],[FME],B,[CRJB]]
+ PUSHJ P,SLEEPR
+ .CLOSE IMAPCH,
+ MOVEI A,LENGC ; SMASH PAGECOUNT
+ SKIPE SWAPGC
+ MOVEI A,SLENGC+1 ; PSTACK
+ MOVEM A,PGCNT
+ POPJ P,
+
+; SEE WHY OPEN FAILED
+
+CKFILE: .STATUS IMAPCH,0 ; GET STATUS BITS INTO 0
+ HRLZS 0
+ ANDI 0,77 ; AND OF EXTRANEOUS BITS
+ CAIN 0,4 ; SKIP IF NOT FNF
+ FATAL CANT OPEN AGC FILE
+
+SLEEPR: MOVEI 0,1 ; SLEEP FOR A WHILE
+ .SLEEP
+ SOS (P) ; TRY AGAIN
+ SOS (P)
+ POPJ P, ; BYE
+]
+
+IFE ITS,[
+ HRRZ A,IJFNS1
+ SKIPN MULTSG
+ HLRZ A,IJFNS
+ SKIPE SWAPGC
+ HLRZ A,IJFNS1
+ JUMPN A,GOTJFN
+
+; HERE TO GET GC JFNS
+; GET STRING NAME OF MDL INTERPRETER FILE
+ HRRZ A,IJFNS ; INTERPRETER JFN
+ MOVE B,A ; SET UP FOR JFNS
+ PUSHJ P,TMTNXS ; MAKES A STRING ON P STACK
+ MOVE D,E ; SAVED VALUE OF P STACK
+ HRROI A,1(E) ; STRING FOR RESULT
+ MOVE C,[211000,,1] ; GET "DEV:<DIR>NM1" FROM JFNS
+ JFNS
+ MOVE C,A ; SAVE TO REUSE FOR ".SGC"
+; GET JFN TO AGC FILE
+ MOVEI B,[ASCIZ /.AGC/]
+ SKIPN MULTSG
+ JRST .+4
+ MOVEI B,[ASCIZ /.DEC/]
+ SKIPN GCDEBU
+ MOVEI B,[ASCIZ /.SEC/]
+ SKIPE SWAPGC
+ MOVEI B,[ASCIZ /.SGC/]
+ HRLI B,440700
+ ILDB B
+ IDPB A
+ JUMPN .-2 ; COPY ".AGC" INTO STRING
+ HRROI B,1(E) ; GTJFN STRING
+ MOVSI A,SGJF+OLDF ; GTJFN CONTROL BITSS
+ GTJFN
+ FATAL AGC GARBAGE COLLECTOR IS MISSING
+ SKIPN SWAPGC
+ JRST .+3
+ HRLM A,IJFNS1
+ JRST JFNIN
+ SKIPE MULTSG
+ HRRM A,IJFNS1
+ SKIPN MULTSG
+ HRLM A,IJFNS
+JFNIN: MOVE B,[440000,,FREAD+FEXEC]
+ OPENF
+ FATAL CANT OPEN AGC FILE
+ MOVE P,E
+GOTJFN:
+ MOVEI D,SECLEN+SECLEN-2
+ SKIPN MULTSG
+ MOVEI D,LENGC+LENGC-6 ; # OF TENEX PAGES TO GET IT
+ SKIPE SWAPGC
+ MOVEI D,SLENGC+SLENGC
+ MOVSI A,(A) ; JFN TO LH
+ MOVE B,[MFORK,,PAGEGC+PAGEGC]
+ MOVSI C,CTREAD+CTEXEC
+
+LDLP: PMAP
+ ADDI A,1
+ ADDI B,1
+ SOJG D,LDLP
+
+ MOVEI C,0
+ MOVEI D,6 ; THESE PAGES WILL BE THE GC PDL
+ SKIPN MULTSG
+ SKIPE SWAPGC
+ MOVEI D,2 ; PDL BUT NO FRONT OR WINDOW
+ MOVNI A,1
+
+LDLP1: PMAP
+ ADDI B,1
+ SOJG D,LDLP1
+
+ MOVEI A,SECLEN+1
+ SKIPN MULTSG
+ MOVEI A,LENGC ; SMASH PAGECOUNT
+ SKIPE SWAPGC
+ MOVEI A,SLENGC+1
+ MOVEM A,PGCNT
+ POPJ P,
+
+;ROUTINE TO "SLEEP" FOR A WHILE ON 10X/20X HA HA
+SLEEPR: SOS (P)
+ POPJ P,
+]
+
+; ROUTINE TO LOAD THE INTERPRETER
+; C=>LENGTH OF PAGES
+; D=>START OF PAGES
+
+LODINT:
+IFN ITS,[
+ .SUSET [.RSNAME,,SAVSNM]
+LODIN1: .IOPUS IMAPCH,
+ .SUSET [.SSNAM,,INTDIR]
+ .OPEN IMAPCH,ILDBLK ; OPEN FILE TO INTERPRETER BLOCK
+ PUSHJ P,CKFILE
+ HLRE B,TP ; MAKE SURE BIG ENOUGJ
+ MOVNS B ; SEE IF WE WIN
+ CAIGE B,400 ; SKIP IF WINNING
+ FATAL NO ROOM FOR PAGE MAP
+ MOVSI A,-400
+ HRRI A,1(TP)
+ .ACCES IMAPCH,C%1
+ .IOT IMAPCH,A ; GET IN PAGE MAP
+ MOVEI A,1 ; INITIALIZE FILE PAGE COUNT
+ MOVEI B,0 ; CORE PAGE COUNT
+ MOVEI E,1(TP)
+LOPFND: HRRZ 0,(E)
+ JUMPE 0,NOPAG ; IF 0 FORGET IT
+ ADDI A,1 ; AOS FILE MAP
+NOPAG: ADDI B,1 ; AOS PAGE MAP
+ CAIE B,(D) ; SKIP IF DONE
+ AOJA E,LOPFND
+ MOVNI 0,(C) ; GET PAGE-COUNT
+ HRL A,0 ; BUILD FILE PAGE POINTER
+ HRL B,0 ; BUILD CORE PAGE POINTER
+ DOTCAL CORBLK,[[RDTP],[FME],B,[MAPCHN],A]
+ PUSHJ P,SLEEPR ; GO TO SLEEP FOR A WHILE
+ .CLOSE IMAPCH,
+ .IOPOP IMAPCH,
+ .SUSET [.SSNAM,,SAVSNM]
+ POPJ P, ; DONE
+]
+IFE ITS,[
+ HRRZ E,IJFNS
+ MOVEI A,(E) ; FIND OUT LENGTH OF MAP
+ MOVEI B,0
+ SFPTR
+ FATAL CANNOT RESET FILE POINTER
+ MOVEI A,(E)
+ BIN ; GET LENGTH WORD
+ MOVEI A,(B) ; ISOLATE SIZE OF MAP
+ HLRZ 0,B
+ HLRE B,TP ; MUST BE SPACE FOR CRUFT
+ MOVNS B
+ CAIGE B,(A) ; ROOM?
+ FATAL NO ROOM FOR PAGE MAP (GULP)
+ PUSH P,C ; SAVE # PAGES WANTED
+ MOVN C,A
+ MOVEI A,(E) ; READY TO READ IN MAP
+ MOVEI B,1(TP) ; ONTO TP STACK
+ HRLI B,444400
+ SIN ; SNARF IT IN
+
+ MOVEI A,1(TP)
+ CAIE 0,1000 ; CHECK FOR TENEX
+ JRST TOPS20
+ LDB 0,[221100,,(A)] ; GET FORK PAGE
+ CAIE 0,(D) ; GOT IT?
+ AOJA A,.-2
+ HRRZ A,(A)
+ JRST GOTPG
+
+TOPS21: ADDI A,2
+TOPS20: HRRZ 0,1(A) ; GET PAGE IN PROCESS
+ LDB B,[331100,,1(A)] ; GET REPT COUNT
+ ADD B,0 ; LAST PAGE IN BLOCK
+ CAIG 0,(D)
+ CAIGE B,(D) ; WITHIN RANGE?
+ JRST TOPS21
+ SUBM D,0
+ HRRZ A,(A)
+ ADD A,0
+
+GOTPG: HRLI A,(E)
+ MOVEI B,(D)
+ HRLI B,MFORK
+ MOVSI C,CTREAD+CTEXEC ; BITS
+ POP P,D ; PAGES
+ ASH D,1 ; FOR TENEX
+
+MPLP: PMAP
+ ADDI A,1
+ ADDI B,1
+ SOJG D,MPLP ; MAP-EM IN
+
+ POPJ P,
+]
+
+; ROUTINE TO MAP IN OVER GARBAGE COLLECTOR EXPLICITLY
+
+KILGC:
+IFN ITS,[
+ MOVEI D,PAGEGC
+ MOVE C,PGCNT
+ JRST LODIN1
+]
+IFE ITS,[
+ MOVEI D,PAGEGC+PAGEGC
+ MOVE C,PGCNT
+ JRST LODINT
+]
+
+; ROUTINE TO TRY TO ALLOCATE A BUFFER
+; 1) IT FIRSTS LOOKS BETWEEN FRETOP AND PURBOT
+; 2) LOOKS AT THE INTERPRETER
+; A=>NUMBER OF BUFFER PAGES (CURRENTLY ALWAYS 1)
+; B=>BUFFER
+; BUFFER SAVED IN BUFPTR
+
+GETBUF: ASH A,10. ; CONVERT TO WORDS
+ MOVE B,PURBOT ; LOOK FOR ROOM IN GCS
+ SUB B,FRETOP
+ CAMGE B,A ; SKIP IF WINNING
+ JRST NOBUF1
+ MOVE B,FRETOP ; BUFFER IN B
+ MOVEM B,BUFPTR ; SAVE BUFFER
+ ASH A,-10. ; TO PAGES
+ MOVEM A,BUFLT ; LENGTH OF BUFFER
+ POPJ P,
+NOBUF1: ASH A,-10. ; BACK TO WORDS
+ SKIPE INPLOD ; SKIP IF NOT IN MAPPUR
+ JRST INTBUF
+ PUSH P,A
+ PUSH P,E
+ JSP E,CKPUR
+ POP P,E
+ POP P,A
+ MOVE B,PURTOP
+ SUB B,PURBOT
+ SUB B,CURPLN
+ ASH B,-10. ; CALCULATE AVAILABLE ROOM
+ CAIGE B,(A) ; SEE IF ENOUGH
+ JRST INTBUF ; LOSE LOSE GET BUFFER FROM INTERPRETER
+IFE ITS, ASH A,1 ; TENEX PAGES
+ PUSH P,C
+ PUSH P,D
+ PUSH P,E
+ PUSHJ P,GETPAG ; GET THOSE PAGES
+ FATAL GETPAG FAILED
+ POP P,E
+ POP P,D
+ POP P,C
+IFE ITS, ASH A,-1
+ JRST GETBUF ; TRY AGAIN
+INTBUF: MOVEM A,BUFLT
+IFN ITS,[
+ MOVNS A ; NEGATE
+ HRLZS A ; SWAP
+ HRRI A,STRPAG ; AOBJN TO PAGE
+ MOVE B,A
+ DOTCAL CORBLK,[[FLS],[FME],A]
+ FATAL CANT FLUSH PAGE
+ DOTCAL CORBLK,[[WRTP],[FME],B,[CRJB]]
+ PUSHJ P,SLEEPR
+]
+
+IFE ITS,[
+ PUSH P,C
+ MOVEI C,(A) ; PAGES TO FLUSH
+ ASH C,1
+ MOVNI A,1 ; FLUSH PAGES
+ MOVE B,[MFORK,,STRPAG+STRPAG] ; WHICH ONES
+FLSLP: PMAP
+ ADDI B,1
+ SOJG C,FLSLP
+ POP P,C
+]
+ MOVEI B,STRBUF ; START OF BUFFER
+ MOVEM B,BUFPTR ; SAVE IN BUFPTR
+ PUSHJ P,RBLDM
+ POPJ P,
+
+; ROUTINE TO FLUSH A BUFFER WHEN DONE WITH IT
+
+KILBUF: SKIPN B,BUFPTR ; SEE IF BUFPTR EXISTS
+ POPJ P,
+IFE ITS, JRST @[.+1] ; RUN IN SECTION 0
+ CAIL B,HIBOT ; SKIP IF NOT PART OF INTERPRETER
+ JRST HIBUF ; INTERPRETER
+IFN ITS,[
+ ASH B,-10.
+ MOVN A,BUFLT ; GET LENGTH
+ HRLI B,(A) ; BUILD PAGE AOBJN
+ DOTCAL CORBLK,[[FLS],[FME],B]
+ FATAL CANT FLUSH PAGES
+]
+IFE ITS,[
+ ASH B,-9. ; TO PAGES
+ HRLI B,MFORK
+ MOVNI A,1
+ MOVE D,BUFLT
+ LSH D,1 ; TO TENEX PAGES
+ PUSH P,C ; SAVE C
+ MOVEI C,0 ; C CONTAINS SOME FLAGS
+
+FLSLP1: PMAP
+ ADDI B,1
+ SOJG D,FLSLP1
+
+ POP P,C ; RESTORE C
+]
+
+FLEXIT: SETZM BUFPTR
+ SETZM BUFLT
+IFE ITS,[
+ PUSH P,A
+ HLRZ A,SJFNS
+ JUMPE A,.+3
+ CLOSF
+ JFCL
+ SETZM SJFNS
+ POP P,A
+ SKIPN MULTSG
+ POPJ P,
+ POP P,21
+ SETZM 20
+ XJRST 20
+]
+IFN ITS,[
+ POPJ P,
+]
+HIBUF: MOVE C,BUFLT
+ MOVE D,BUFPTR
+IFN ITS, ASH D,-10.
+IFE ITS, ASH D,-9.
+ PUSHJ P,LODINT
+ JRST FLEXIT
+
+; HERE TO HANDLE GC PDL OVERFLOW. ROUTINE USES A,B AND ASSUMES GCPDL IS THE PDL
+
+GPDLOV: HRRZ A,PGCNT ; # OF PAGES TO A
+ ADDI A,PAGEGC ; SEE IF ROOM
+ ASH A,10. ; TO WORDS
+ CAIL A,LPUR ; HAVE WE LOST
+ FATAL NO ROOM FOR GCPDL
+IFN ITS,[
+ ASH A,-10. ; GET PAGE NUMBER
+ AOS PGCNT ; AOS
+ DOTCAL CORBLK,[[FLS],[FME],A]
+ FATAL CANT FLUSH PAGE
+ DOTCAL CORBLK,[[WRTP],[FME],A,[CRJB]]
+ PUSHJ P,SLEEPR
+]
+IFE ITS,[
+ ASH A,-9.
+ AOS PGCNT
+ MOVE B,A
+ MOVNI A,1
+ HRLI B,MFORK
+ PUSH P,C ; BETTER HAVE A PDL HERE
+ MOVEI C,0
+ PMAP
+ ADDI B,1
+ PMAP
+ POP P,C
+
+]
+ HRRI A,-2000 ; SMASH PDL
+ HRLM A,GCPDL
+ POPJ P, ; EXIT
+
+IFN ITS,[
+
+
+GCDIR: SIXBIT /MUDSAV/
+INTDIR: SIXBIT /MUDSAV/
+GCLDBK: SIXBIT / &DSK/
+ SIXBIT /AGC/
+ 0 ; FILLED IN BY INITM
+
+SGCLBK: SIXBIT / &DSK/
+ SIXBIT /SGC/
+ 0
+
+ILDBLK: SIXBIT / &DSK/
+ SIXBIT /TS/
+ 0 ; FILLED IN BY INITM
+]
+
+
+IFE ITS,[
+NDEBUG: SETZM GCDEBU
+ CAIA
+DEBUGC: SETOM GCDEBU
+ HRRZ A,IJFNS1 ; GET GC JFN
+ SKIPE A
+ CLOSF
+ JFCL
+ POPJ P,
+]
+
+IMPURE
+GCDEBU: 0
+BUFPTR: 0 ; POINTER TO CURRENTLY ACTIVE BUFFER (WORD)
+BUFLT: 0 ; LENGTH OF CURRENTLY ACTIVE BUFFER (PAGES)
+PGCNT: 0 ; # OF PAGES OF MAPPED OUT INTERPRETER
+SAVSNM: 0
+OPBLK: 0 ; BLOCK USED FOR OPEN
+
+PURE
+
+END
+\f
\ No newline at end of file
--- /dev/null
+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
+\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
+ 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,
+
+\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
--- /dev/null
+
+TITLE MAPURE-PAGE LOADER
+
+RELOCATABLE
+
+MAPCH==0 ; channel for MAPing
+XJRST==JRST 5,
+
+.GLOBAL PURVEC,PURTOP,PURBOT,P.TOP,GCSTOP,FRETOP,MUDSTR,STRTO6,PLOAD,AGC,GCDOWN
+.GLOBAL SQUTOA,IGVAL,IBLOCK,PURCLN,MOVPUR,GETPAG,GCFLG,NOSHUF,DIR,NDIRS,SQUPNT
+.GLOBAL PLODR,SQUKIL,GETBUF,KILBUF,INPLOD,SQKIL,PVSTOR,TVSTOR,DSTOREM,SLEEPR
+.GLOBAL OPSYS,SJFNS,MULTSG,PURBTB,SFIX,NSEGS
+.GLOBAL C%11,C%22,C%33,C%44,C%55,C%66,C%0,C%1,C%2,C%3,C%M1,C%M2,C%M10
+.GLOBAL C%M20,C%M30,C%M40,C%M60
+.GLOBAL MAPJFN,DIRCHN
+
+.INSRT MUDDLE >
+SPCFXU==1
+SYSQ
+
+IFE ITS,[
+IF1, .INSRT STENEX >
+]
+
+F==PVP
+G==TVP
+H==SP
+RDTP==1000,,200000
+FME==1000,,-1
+
+
+IFN ITS,[
+PGMSK==1777
+PGSHFT==10.
+]
+
+IFE ITS,[
+FLUSHP==0
+PGMSK==777
+PGSHFT==9.
+]
+
+LNTBYT==340700
+ELN==4 ; LENGTH OF SLOT
+FB.NAM==0 ; NAME SLOT IN TABLE
+FB.PTR==1 ; Pointer to core pages
+FB.AGE==2 ; age,,chain
+FB.PGS==3 ; PTR AND LENGTH OF PAGE IN FILE
+FB.AMK==37777777 ; extended address mask
+FB.CNT==<-1>#<FB.AMK> ; page count mask
+EOC==400000 ; END OF PURVEC CHAIN
+
+IFE ITS,[
+.FHSLF==400000 ; THIS FORK
+%GJSHT==000001 ; SHORT FORM GTJFN
+%GJOLD==100000
+ ;PMAP BITS
+PM%CNT==400000 ; PMAP WITH REPEAT COUNT
+PM%RD==100000 ; PMAP WITH READ ACCESS
+PM%EX==20000 ; PMAP WITH EXECUTE ACCESS (NO-OP ON 20X)
+PM%CPY==400 ; PMAP WITH COPY-ON-WRITE ACCESS
+PM%WR==40000 ; PMAP WITH WRITE ACCESS
+
+ ;OPENF BITS
+OF%RD==200000 ; OPEN IN READ MODE
+OF%WR==100000 ; OPEN IN WRITE MODE
+OF%EX==040000 ; OPEN IN EXECUTE MODE (TENEX CARES)
+OF%THW==02000 ; OPEN IN THAWED MODE
+OF%DUD==00020 ; DON'T UPDATE THAWED PAGES
+]
+; THIS ROUTINE TAKES A SLOT OFFSET IN REGISTER A AND MAPS IN THE ASSOCIATED
+; FILE. IT CLOBBERS ALL ACs AND SKIP RETURNS IF IT WINS.
+
+OFF==-5 ; OFFSET INTO PURVEC OF SLOT
+NAM==-4 ; SIXBIT NAME OF THING BEING LOADED
+LASTC==-3 ; LAST CHARACTER OF THE NAME
+DIR==-2 ; SAVED POINTER TO DIRECTORY
+SPAG==-1 ; FIRST PAGE IN FILE
+PGNO==0 ; FIRST PAGE IN CORE
+VER==-6 ; VERSION NUMBER OF MUDDLE TO USE IN OPENING FILES
+FLEN==-7 ; LENGTH OF THE FILE
+TEMP==-10 ; GENERAL TEMPORARY SLOT
+WRT==-11 ; INDICATION IF OPEN IS FOR WRITING OR READING
+CADDR==-12 ; ADDRESS OF CORE IMAGE LOCATION OF FILE
+NSLOTS==13
+
+; IT FIRST LOOKS TO SEE IF IT HAS THE PAGE NUMBER OF THE FILE
+
+PLOAD: ADD P,[NSLOTS,,NSLOTS]
+ SKIPL P
+ JRST PDLOV
+ MOVEM A,OFF(P)
+ PUSH TP,C%0 ; [0]
+ PUSH TP,C%0 ; [0]
+IFE ITS,[
+ SKIPN MAPJFN
+ PUSHJ P,OPSAV
+]
+
+PLOADX: PUSHJ P,SQKIL
+ MOVE A,OFF(P)
+ ADD A,PURVEC+1 ; GET TO SLOT
+ SKIPE B,FB.PGS(A) ; SKIP IF PAGE NUMBER
+ JRST GETIT
+ MOVE B,FB.NAM(A)
+ MOVEM B,NAM(P)
+ MOVE 0,B
+ MOVEI A,6 ; FIND LAST CHARACTER
+ TRNE 0,77 ; SKIP IF NOT DONE
+ JRST .+3
+ LSH 0,-6 ; BACK A CHAR
+ SOJG A,.-3 ; NOW CHAR IS BACKED OUT
+ ANDI 0,77 ; LASTCHR
+ MOVEM 0,LASTC(P)
+
+; NOT TO TRY TO FIND FILE IN MAIN DATA BASE.
+; THE GC'S WINDOW IS USED IN THIS CASE.
+
+IFN ITS,[
+ .CALL MNBLK ; OPEN CHANNEL TO MAIN FILE
+ JRST NTHERE
+ PUSHJ P,TRAGN ; TRY OPENING UP CHANNEL AGAIN IF POSSIBLE
+]
+IFE ITS,[
+ SKIPN E,MAPJFN
+ JRST NTHERE ;who cares if no SAV.FILE?
+ MOVEM E,DIRCHN
+]
+ MOVE D,NAM(P)
+ MOVE 0,LASTC(P)
+ PUSHJ P,GETDIR
+ MOVEM E,DIR(P)
+ PUSHJ P,GENVN ; GET VERSION # AS FIX
+ MOVE E,DIR(P)
+ MOVE D,NAM(P)
+ MOVE A,B
+ PUSHJ P,DIRSRC ; SEARCH DIRECTORY
+ JRST NTHERE ; GO TRY FIXING UP ITS NOT THERE
+ ANDI A,-1 ; WIN IN MULT SEG CASE
+ MOVE B,OFF(P) ; GET SLOT NUMBER
+ ADD B,PURVEC+1 ; POINT TO SLOT
+ HRRZ C,1(A) ; GET BLOCK NUMBER
+ HRRM C,FB.PGS(B) ; SMASH INTO SLOT
+ LDB C,[LNTBYT,,1(A)] ; SMASH IN LENGTH
+ HRLM C,FB.PGS(B) ; SMASH IN LENGTH
+ JRST PLOADX
+
+; NOW TRY TO FIND FILE IN WORKING DIRECTORY
+
+NTHERE: PUSHJ P,KILBUF
+ MOVE A,OFF(P) ; GET POINTER TO PURVEC SLOT
+ ADD A,PURVEC+1
+ PUSHJ P,GENVN ; GET VERSION NUMBER
+ HRRZM B,VER(P)
+ PUSHJ P,OPMFIL ; OPEN FILE
+ JRST FIXITU
+
+; NUMBER OF PAGES ARE IN A
+; STARTING PAGE NUMBER IN SPAG(P)
+
+PLOD1: PUSHJ P,ALOPAG ; get the necessary pages
+ JRST MAPLS2
+ MOVE E,SPAG(P) ; E starting page in file
+ MOVEM B,PGNO(P)
+IFN ITS,[
+ MOVN A,FLEN(P) ; get neg count
+ MOVSI A,(A) ; build aobjn pointer
+ HRR A,PGNO(P) ; get page to start
+ MOVE B,A ; save for later
+ HRRI 0,(E) ; page pointer for file
+ DOTCAL CORBLK,[[1000,,200000],[1000,,-1],A,[1000,,MAPCH],0]
+ .LOSE %LSSYS
+ .CLOSE MAPCH, ; no need to have file open anymore
+]
+IFE ITS,[
+ MOVEI A,(E) ; First page on rh of A
+ HRL A,DIRCHN ; JFN to lh of A
+ HRLI B,.FHSLF ; specify this fork
+ MOVSI C,PM%RD+PM%EX ; bits for read/execute
+ MOVE D,FLEN(P) ; # of pages to D
+ HRROI E,(B) ; build page aobjn for later
+ TLC E,-1(D) ; sexy way of doing lh
+
+ SKIPN OPSYS
+ JRST BLMAP ; if tops-20 can block PMAP
+ PMAP
+ ADDI A,1
+ ADDI B,1
+ SOJG D,.-3 ; map 'em all
+ MOVE B,E
+ JRST PLOAD1
+
+BLMAP: HRRI C,(D)
+ TLO C,PM%CNT ; say it is counted
+ PMAP ; one PMAP does the trick
+ MOVE B,E
+]
+; now try to smash slot in PURVEC
+
+PLOAD1: MOVE A,PURVEC+1 ; get pointer to it
+ ASH B,PGSHFT ; convert to aobjn pointer to words
+ MOVE C,OFF(P) ; get slot offset
+ ADDI C,(A) ; point to slot
+ MOVEM B,FB.PTR(C) ; clobber it in
+ TLZ B,(FB.CNT) ; isolate address of page
+ HRRZ D,PURVEC ; get offset into vector for start of chain
+ TRNE D,EOC ; skip if not end marker
+ JRST SCHAIN
+ HRLI D,400000+A ; set up indexed pointer
+ ADDI D,1
+IFN ITS, HRRZ 0,@D ; get its address
+IFE ITS,[
+ MOVE 0,@D
+ TLZ 0,(FB.CNT)
+]
+ JUMPE 0,SCHAIN ; no chain exists, start one
+ CAMLE 0,B ; skip if new one should be first
+ AOJA D,INLOOP ; jump into the loop
+
+ SUBI D,1 ; undo ADDI
+FCLOB: MOVE E,OFF(P) ; get offset for this guy
+ HRRM D,FB.AGE(C) ; link up
+ HRRM E,PURVEC ; store him away
+ JRST PLOADD
+
+SCHAIN: MOVEI D,EOC ; get end of chain indicator
+ JRST FCLOB ; and clobber it in
+
+INLOOP: MOVE E,D ; save in case of later link up
+ HRR D,@D ; point to next table entry
+ TRNE D,EOC ; 400000 is the end of chain bit
+ JRST SLFOUN ; found a slot, leave loop
+ ADDI D,1 ; point to address of progs
+IFN ITS, HRRZ 0,@D ; get address of block
+IFE ITS,[
+ MOVE 0,@D
+ TLZ 0,(FB.CNT)
+]
+ CAMLE 0,B ; skip if still haven't fit it in
+ AOJA D,INLOOP ; back to loop start and point to chain link
+ SUBI D,1 ; point back to start of slot
+
+SLFOUN: MOVE 0,OFF(P) ; get offset into vector of this guy
+ HRRM 0,@E ; make previous point to us
+ HRRM D,FB.AGE(C) ; link it in
+
+
+PLOADD: AOS -NSLOTS(P) ; skip return
+ MOVE B,FB.PTR(C)
+
+MAPLOS: SUB P,[NSLOTS,,NSLOTS] ; flush stack crap
+ SUB TP,C%22
+ POPJ P,
+
+
+MAPLS0: ERRUUO EQUOTE NO-SAV-FILE
+ JRST MAPLOS
+
+MAPLS1: ERRUUO EQUOTE NO-FIXUP-FILE
+ JRST MAPLOS
+
+MAPLS2: ERRUUO EQUOTE NO-ROOM-AVAILABLE
+ JRST MAPLOS
+
+FIXITU:
+
+;OPEN FIXUP FILE ON MUDSAV
+
+IFN ITS,[
+ .CALL FIXBLK ; OPEN UP FIXUP FILE
+ PUSHJ P,TRAGN ; SEE IF TOTALLY LOSING
+]
+IFE ITS,[
+ MOVSI A,%GJSHT ; GTJFN BITS
+ HRROI B,FXSTR
+ SKIPE OPSYS
+ HRROI B,TFXSTR
+ GTJFN
+ FATAL FIXUP FILE NOT FOUND
+ MOVEM A,DIRCHN
+ MOVE B,[440000,,OF%RD+OF%EX]
+ OPENF
+ FATAL FIXUP FILE CANT BE OPENED
+]
+
+ MOVE 0,LASTC(P) ; GET DIRECTORY
+ PUSHJ P,GETDIR
+ MOVE D,NAM(P)
+ PUSHJ P,DIRSR1 ; SEARCH DIRECTORY FOR FIXUP
+ JRST NOFXUP ; NO FIXUP IN MAIN DIRECTORY
+ ANDI A,-1 ; WIN IN MULTI SEGS
+ HRRZ A,1(A) ; GET BLOCK NUMBER OF START
+ ASH A,8. ; CONVERT TO WORDS
+IFN ITS,[
+ .ACCES MAPCH,A ; ACCESS FILE
+]
+
+IFE ITS,[
+ MOVEI B,(A)
+ MOVE A,DIRCHN
+ SFPTR
+ JFCL
+]
+ PUSHJ P,KILBUF
+FIXT1: PUSHJ P,RFXUP ; READ IN THE FIXUP FILE
+
+IFN ITS,[
+ .CALL MNBLK ; REOPEN SAV FILE
+ PUSHJ P,TRAGN
+]
+
+IFE ITS,[
+ MOVE A,MAPJFN ; SET UP DIRCHAN AGAIN
+ MOVEM A,DIRCHN
+]
+
+; NOW TRY TO LOCATE SAV FILE
+
+ MOVE 0,LASTC(P) ; GET LASTCHR
+ PUSHJ P,GETDIR ; GET DIRECTORY
+ HRRZ A,VER(P) ; GET VERSION #
+ MOVE D,NAM(P) ; GET NAME OF FILE
+ PUSHJ P,DIRSRC ; SEARCH DIRECTORY
+ JRST MAPLS1 ; NO SAV FILE THERE
+ ANDI A,-1
+ HRRZ E,1(A) ; GET STARTING BLOCK #
+ LDB A,[LNTBYT,,1(A)] ; GET LENGTH INTO A
+ MOVEM A,FLEN(P) ; SAVE LENGTH
+ MOVEM E,SPAG(P) ; SAVE STARTING BLOCK NUMBER
+ PUSHJ P,KILBUF
+ PUSHJ P,RSAV ; READ IN CODE
+; now to do fixups
+
+FXUPGO: MOVE A,(TP) ; pointer to them
+ SETOM INPLOD ; ABSOLUTE CLUDGE TO PREVENT BUFFER FROM
+ ; SCREWING US
+IFE ITS,[
+ SKIPN MULTSG
+ JRST FIXMLT
+]
+ HRRZ D,B ; this codes gets us running in the correct
+ ; segment
+ ASH D,PGSHFT
+ HRRI D,FIXMLT
+ MOVEI C,0
+ XJRST C ; good bye cruel segment (will work if we fell
+ ; into segment 0)
+FIXMLT: ASH B,PGSHFT ; aobjn to program
+
+FIX1: SKIPL E,(A) ; read one hopefully squoze
+ FATAL ATTEMPT TO TYPE FIX PURE
+ TLZ E,740000
+
+NOPV1: PUSHJ P,SQUTOA ; look it up
+ FATAL BAD FIXUPS
+
+; N.B. THE VALUE IN THE FIXUPS FOR AN ADDRESS CAN BE NEGATIVE. IF THIS HAPPENS
+; IT MEANS THAT THE LEFT HALF CONTAINS THE VALUE INSTEAD OF THE RIGHT HALF
+NOPV2: AOBJP A,FIX2
+ HLRZ D,(A) ; get old value
+ HRRZS E
+ SUBM E,D ; D is diff between old and new
+ HRLM E,(A) ; fixup the fixups
+NOPV3: MOVEI 0,0 ; flag for which half
+FIX4: JUMPE 0,FIXRH ; jump if getting rh
+ MOVEI 0,0 ; next time will get rh
+ AOBJP A,FIX2 ; done?
+ HLRE C,(A) ; get lh
+ JUMPE C,FIX3 ; 0 terminates
+FIX5: SKIPGE C ; If C is negative then left half garbage
+ JRST FIX6
+ ADDI C,(B) ; access the code
+
+NOPV4: ADDM D,-1(C) ; and fix it up
+ JRST FIX4
+
+; FOR LEFT HALF CASE
+
+FIX6: MOVNS C ; GET TO ADRESS
+ ADDI C,(B) ; ACCESS TO CODE
+ HLRZ E,-1(C) ; GET OUT WORD
+ ADDM D,E ; FIX IT UP
+ HRLM E,-1(C)
+ JRST FIX4
+
+FIXRH: MOVEI 0,1 ; change flag
+ HRRE C,(A) ; get it and
+ JUMPN C,FIX5
+
+FIX3: AOBJN A,FIX1 ; do next one
+
+IFN SPCFXU,[
+ MOVE C,B
+ PUSHJ P,SFIX
+]
+ PUSHJ P,SQUKIL ; KILL SQUOZE TABLE
+ SETZM INPLOD
+FIX2:
+ HRRZS VER(P) ; INDICATE SAV FILE
+ MOVEM B,CADDR(P)
+ PUSHJ P,GENVN
+ HRRM B,VER(P)
+ PUSHJ P,OPWFIL
+ FATAL MAP FIXUP LOSSAGE
+IFN ITS,[
+ MOVE B,CADDR(P)
+ .IOT MAPCH,B ; write out the goodie
+ .CLOSE MAPCH,
+ PUSHJ P,OPMFIL
+ FATAL WHERE DID THE FILE GO?
+ MOVE E,CADDR(P)
+ ASH E,-PGSHFT ; to page AOBJN
+ DOTCAL CORBLK,[[1000,,200000],[1000,,-1],E,[1000,,MAPCH],0]
+ .LOSE %LSSYS
+ .CLOSE MAPCH,
+]
+
+
+IFE ITS,[
+ MOVE A,DIRCHN ; GET JFN
+ MOVE B,CADDR(P) ; ready to write it out
+ HRLI B,444400
+ HLRE C,CADDR(P)
+ SOUT ; zap it out
+ TLO A,400000 ; dont recycle the JFN
+ CLOSF
+ JFCL
+ ANDI A,-1 ; kill sign bit
+ MOVE B,[440000,,240000]
+ OPENF
+ FATAL MAP FIXUP LOSSAGE
+ MOVE B,CADDR(P)
+ ASH B,-PGSHFT ; aobjn to pages
+ HLRE D,B ; -count
+ HRLI B,.FHSLF
+ MOVSI A,(A)
+ MOVSI C,PM%RD+PM%EX
+ PMAP
+ ADDI A,1
+ ADDI B,1
+ AOJN D,.-3
+]
+
+ SKIPGE MUDSTR+2
+ JRST EFIX2 ; exp vers, dont write out
+IFE ITS,[
+ HRRZ A,SJFNS ; get last jfn from savxxx file
+ JUMPE A,.+4 ; oop
+ CAME A,MAPJFN
+ CLOSF ; close it
+ JFCL
+ HLLZS SJFNS ; zero the slot
+]
+ MOVEI 0,1 ; INDICATE FIXUP
+ HRLM 0,VER(P)
+ PUSHJ P,OPWFIL
+ FATAL CANT WRITE FIXUPS
+
+IFN ITS,[
+ MOVE E,(TP)
+ HLRE A,E ; get length
+ MOVNS A
+ ADDI A,2 ; account for these 2 words
+ MOVE 0,[-2,,A] ; write version and length
+ .IOT MAPCH,0
+ .IOT MAPCH,E ; out go the fixups
+ SETZB 0,A
+ MOVEI B,MAPCH
+ .CLOSE MAPCH,
+]
+
+IFE ITS,[
+ MOVE A,DIRCHN
+ HLRE B,(TP) ; length of fixup vector
+ MOVNS B
+ ADDI B,2 ; for length and version words
+ BOUT
+ PUSHJ P,GENVN
+ BOUT
+ MOVSI B,444400 ; byte pointer to fixups
+ HRR B,(TP)
+ HLRE C,(TP)
+ SOUT
+ CLOSF
+ JFCL
+]
+
+EFIX2: MOVE B,CADDR(P)
+ ASH B,-PGSHFT
+ JRST PLOAD1
+
+; Here to try to get a free page block for new thing
+; A/ # of pages to get
+
+ALOPAG: MOVE C,GCSTOP ; FOOL GETPAG
+ ADDI C,3777
+ ASH C,-PGSHFT
+ MOVE B,PURBOT
+IFE ITS,[
+ SKIPN MULTSG ; skip if multi-segments
+ JRST ALOPA1
+; Compute the "highest" PURBOT (i.e. find the least busy segment)
+
+ PUSH P,E
+ PUSH P,A
+ MOVN A,NSEGS ; aobjn pntr to table
+ HRLZS A
+ MOVEI B,0
+ALOPA3: CAML B,PURBTB(A) ; if this one is larger
+ JRST ALOPA2
+ MOVE B,PURBTB(A) ; use it
+ MOVEI E,FSEG(A) ; and the segment #
+ALOPA2: AOBJN A,ALOPA3
+ POP P,A
+]
+
+ALOPA1: ASH B,-PGSHFT
+ SUBM B,C ; SEE IF ROOM
+ CAIL C,(A)
+ JRST ALOPGW
+ PUSHJ P,GETPAX ; try to get enough pages
+IFE ITS, JRST EPOPJ
+IFN ITS, POPJ P,
+
+ALOPGW:
+IFN ITS, AOS (P) ; won skip return
+IFE ITS,[
+ SKIPE MULTSG
+ AOS -1(P) ; ret addr
+ SKIPN MULTSG
+ AOS (P)
+]
+ MOVE 0,PURBOT
+IFE ITS,[
+ SKIPE MULTSG
+ MOVE 0,PURBTB-FSEG(E)
+]
+ ASH 0,-PGSHFT
+ SUBI 0,(A)
+ MOVE B,0
+IFE ITS,[
+ SKIPN MULTSG
+ JRST ALOPW1
+ ASH 0,PGSHFT
+ HRRZM 0,PURBTB-FSEG(E)
+ ASH E,PGSHFT ; INTO POSITION
+ IORI B,(E) ; include segment in address
+ POP P,E
+ JRST ALOPW2
+]
+ALOPW1: ASH 0,PGSHFT
+ALOPW2: CAMGE 0,PURBOT
+ MOVEM 0,PURBOT
+ CAML 0,P.TOP
+ POPJ P,
+IFE ITS,[
+ SUBI 0,1777
+ ANDCMI 0,1777
+]
+ MOVEM 0,P.TOP
+ POPJ P,
+
+EPOPJ: SKIPE MULTSG
+ POP P,E
+ POPJ P,
+IFE ITS,[
+GETPAX: TDZA B,B ; here if other segs ok
+GETPAG: MOVEI B,1 ; here for only main segment
+ JRST @[.+1] ; run in sect 0
+ MOVNI E,1
+]
+IFN ITS,[
+GETPAX:
+GETPAG:
+]
+ MOVE C,P.TOP ; top of GC space
+ ASH C,-PGSHFT ; to page number
+IFE ITS,[
+ SKIPN MULTSG
+ JRST GETPA9
+ JUMPN B,GETPA9 ; if really wan all segments,
+ ; must force all to be free
+ PUSH P,A
+ MOVN A,NSEGS ; aobjn pntr to table
+ HRLZS A
+ MOVE B,P.TOP
+GETPA8: CAMLE B,PURBTB(A) ; if this one is larger (or the same)
+ JRST GETPA7
+ MOVE B,PURBTB(A) ; use it
+ MOVEI E,FSEG(A) ; and the segment #
+GETPA7: AOBJN A,GETPA8
+ POP P,A
+ JRST .+2
+]
+GETPA9: MOVE B,PURBOT
+ ASH B,-PGSHFT ; also to pages
+ SUBM B,C ; pages available ==> C
+ CAMGE C,A ; skip if have enough already
+ JRST GETPG1 ; no, try to shuffle around
+ SUBI B,(A) ; B/ first new page
+CPOPJ1: AOS (P)
+IFN ITS, POPJ P,
+IFE ITS,[
+SPOPJ: SKIPN MULTSG
+ POPJ P, ; return with new free page in B
+ ; (and seg# in E?)
+ POP P,21
+ SETZM 20
+ XJRST 20
+]
+; Here if shuffle must occur or gc must be done to make room
+
+GETPG1: MOVEI 0,0
+ SKIPE NOSHUF ; if can't shuffle, then ask gc
+ JRST ASKAGC
+ MOVE 0,PURTOP ; get top of mapped pure area
+ SUB 0,P.TOP
+ ASH 0,-PGSHFT ; to pages
+ CAMGE 0,A ; skip if winnage possible
+ JRST ASKAGC ; please AGC give me some room!!
+ SUBM A,C ; C/ amount we must flush to make room
+
+IFE ITS,[
+ SKIPE MULTSG ; if multi and getting in all segs
+ JUMPL E,LPGL1 ; check out each and every segment
+
+ PUSHJ P,GL1
+
+ SKIPE MULTSG
+ PUSHJ P,PURTBU ; update PURBOT in multi case
+
+ JRST GETPAX
+
+LPGL1: PUSH P,A
+ PUSH P,[FSEG-1]
+
+LPGL2: AOS E,(P) ; count segments
+ MOVE B,NSEGS
+ ADDI B,FSEG
+ CAML E,B
+ JRST LPGL3
+ PUSH P,C
+ MOVE C,PURBOT ; fudge so look for appropriate amt
+ SUB C,PURBTB-FSEG(E)
+ ASH C,-PGSHFT ; to pages
+ ADD C,(P)
+ SKIPLE C ; none to flush
+ PUSHJ P,GL1
+ HRRZ E,-1(P) ; fet section again
+ HRRZ B,PURBOT
+ HRRZ C,PURBTB-FSEG(E) ; lets share with 0 again
+ SUB C,B
+ HRL B,E ; get segment
+ MOVEI A,(B)
+ ASH B,-PGSHFT
+ ASH A,-PGSHFT
+ HRLI A,.FHSLF
+ HRLI B,.FHSLF
+ ASH C,-PGSHFT
+ HRLI C,PM%CNT+PM%RD+PM%WR+PM%EX
+ PMAP
+LPGL4: POP P,C
+ JRST LPGL2
+
+LPGL3: SUB P,C%11
+ POP P,A
+
+ SKIPE MULTSG
+ PUSHJ P,PURTBU ; update PURBOT in multi case
+
+ JRST GETPAG
+]
+; Here to find pages for flush using LRU algorithm (in multi seg mode, only
+; care about the segment in E)
+
+GL1: MOVE B,PURVEC+1 ; get pointer to pure sr vector
+ MOVEI 0,-1 ; get very large age
+
+GL2: SKIPL FB.PTR(B) ; skip if not already flushed
+ JRST GL3
+IFE ITS,[
+ SKIPN MULTSG
+ JRST GLX
+ LDB D,[220500,,FB.PTR(B)] ; get segment #
+ CAIE D,(E)
+ JRST GL3 ; wrong swegment, ignore
+]
+GLX: HLRZ D,FB.AGE(B) ; get this ones age
+ CAMLE D,0 ; skip if this is a candidate
+ JRST GL3
+ MOVE F,B ; point to table entry with E
+ MOVEI 0,(D) ; and use as current best
+GL3: ADD B,[ELN,,ELN] ; look at next
+ JUMPL B,GL2
+
+ HLRE B,FB.PTR(F) ; get length of flushee
+ ASH B,-PGSHFT ; to negative # of pages
+ ADD C,B ; update amount needed
+IFN ITS,SETZM FB.PTR(F) ; indicate it will be gone
+IFE ITS,MOVNS FB.PTR(F) ; save page info for flushing pages
+ JUMPG C,GL1 ; jump if more to get
+
+; Now compact pure space
+
+ PUSH P,A ; need all acs
+ HRRZ D,PURVEC ; point to first in core addr order
+ HRRZ C,PURTOP
+IFE ITS,[
+ SKIPE MULTSG
+ HRLI C,(E) ; adjust for segment
+]
+ ASH C,-PGSHFT ; to page number
+ SETZB F,A
+
+CL1: ADD D,PURVEC+1 ; to real pointer
+ SKIPGE FB.PTR(D) ; skip if this one is a flushee
+ JRST CL2 ; this one stays
+
+IFE ITS,[
+ PUSH P,C
+ PUSH P,D
+ HRRZ C,FB.PGS(D) ; is this from SAV FILE?
+ JUMPN C,CLFOUT ; yes. don't bother flushing pages
+ MOVN C,FB.PTR(D) ; get aobjn pointer to code in C
+ SETZM FB.PTR(D) ; and flush this because it works (sorry)
+ ASH C,-PGSHFT ; pages speak louder than words
+ HLRE D,C ; # of pages saved here for unmap
+ HRLI C,.FHSLF ; C now contains myfork,,lowpage
+ MOVE A,C ; put that in A for RMAP
+ RMAP ; A now contains JFN in left half
+ MOVE B,C ; ac roulette: get fork,,page into B for PMAP
+ HLRZ C,A ; hold JFN in C for future CLOSF
+ MOVNI A,1 ; say this page to be unmapped
+CLFLP: PMAP ; do the unmapping
+ ADDI B,1 ; next page
+ AOJL D,CLFLP ; continue for all pages
+ MOVE A,C ; restore JFN
+ CLOSF ; and close it, throwing away the JFN
+ JFCL ; should work in 95/100 cases
+CLFOU1: POP P,D ; fatal error if can't close
+ POP P,C
+]
+ HRRZ D,FB.AGE(D) ; point to next one in chain
+ JUMPN F,CL3 ; jump if not first one
+ HRRM D,PURVEC ; and use its next as first
+ JRST CL4
+
+IFE ITS,[
+CLFOUT: SETZM FB.PTR(D) ; zero the code pointer
+ JRST CLFOU1
+]
+
+CL3: HRRM D,FB.AGE(F) ; link up
+ JRST CL4
+
+; Found a stayer, move it if necessary
+
+CL2:
+IFE ITS,[
+ SKIPN MULTSG
+ JRST CL9
+ LDB F,[220500,,FB.PTR(D)] ; check segment
+ CAIE E,(F)
+ JRST CL6X ; no other segs move at all
+]
+CL9: MOVEI F,(D) ; another pointer to slot
+ HLRE B,FB.PTR(D) ; - length of block
+IFE ITS,[
+ TRZ B,<-1>#<(FB.CNT)>
+ MOVE D,FB.PTR(D) ; pointer to block
+ TLZ D,(FB.CNT) ; kill count bits
+]
+IFN ITS, HRRZ D,FB.PTR(D)
+ SUB D,B ; point to top of block
+ ASH D,-PGSHFT ; to page number
+ CAMN D,C ; if not moving, jump
+ JRST CL6
+
+ ASH B,-PGSHFT ; to pages
+IFN ITS,[
+CL5: SUBI C,1 ; move to pointer and from pointer
+ SUBI D,1
+ DOTCAL CORBLK,[[1000,,200000],[1000,,-1],C,[1000,,-1],D]
+ .LOSE %LSSYS
+ AOJL B,CL5 ; count down
+]
+IFE ITS,[
+ PUSH P,B ; save # of pages
+ MOVEI A,-1(D) ; copy from pointer
+ HRLI A,.FHSLF ; get this fork code
+ RMAP ; get a JFN (hopefully)
+ EXCH D,(P) ; D # of pages (save from)
+ ADDM D,(P) ; update from
+ MOVEI B,-1(C) ; to pointer in B
+ HRLI B,.FHSLF
+ MOVSI C,PM%RD+PM%EX ; read/execute modes
+
+ SKIPN OPSYS
+ JRST CCL1
+ PMAP ; move a page
+ SUBI A,1
+ SUBI B,1
+ AOJL D,.-3 ; move them all
+ AOJA B,CCL2
+
+CCL1: TLO C,PM%CNT
+ MOVNS D
+ SUBI B,-1(D)
+ SUBI A,-1(D)
+ HRRI C,(D)
+ PMAP
+
+CCL2: MOVEI C,(B)
+ POP P,D
+]
+; Update the table address for this loser
+
+ SUBM C,D ; compute offset (in pages)
+ ASH D,PGSHFT ; to words
+ ADDM D,FB.PTR(F) ; update it
+CL7: HRRZ D,FB.AGE(F) ; chain on
+CL4: TRNN D,EOC ; skip if end of chain
+ JRST CL1
+
+ ASH C,PGSHFT ; to words
+IFN ITS, MOVEM C,PURBOT ; reset pur bottom
+IFE ITS,[
+ SKIPN MULTSG
+ JRST CLXX
+
+ HRRZM C,PURBTB-FSEG(E)
+ CAIA
+CLXX: MOVEM C,PURBOT ; reset pur bottom
+]
+ POP P,A
+ POPJ P,
+
+IFE ITS,[
+CL6X: MOVEI F,(D) ; chain on
+ JRST CL7
+]
+CL6:
+IFN ITS, HRRZ C,FB.PTR(F) ; get new top of world
+IFE ITS,[
+ MOVE C,FB.PTR(F)
+ TLZ C,(FB.CNT)
+]
+ ASH C,-PGSHFT ; to page #
+ JRST CL7
+
+IFE ITS,[
+PURTBU: PUSH P,A
+ PUSH P,B
+
+ MOVN B,NSEGS
+ HRLZS B
+ MOVE A,PURTOP
+
+PURTB2: CAMGE A,PURBTB(B)
+ JRST PURTB1
+ MOVE A,PURBTB(B)
+ MOVEM A,PURBOT
+PURTB1: AOBJN B,PURTB2
+
+ POP P,B
+ POP P,A
+ POPJ P,
+]
+
+\f; SUBR to create an entry in the vector for one of these guys
+
+MFUNCTION PCODE,SUBR
+
+ ENTRY 2
+
+ GETYP 0,(AB) ; check 1st arg is string
+ CAIE 0,TCHSTR
+ JRST WTYP1
+ GETYP 0,2(AB) ; second must be fix
+ CAIE 0,TFIX
+ JRST WTYP2
+
+ MOVE A,(AB) ; convert name of program to sixbit
+ MOVE B,1(AB)
+ PUSHJ P,STRTO6
+PCODE4: MOVE C,(P) ; get name in sixbit
+
+; Now look for either this one or an empty slot
+
+ MOVEI E,0
+ MOVE B,PURVEC+1
+
+PCODE2: CAMN C,FB.NAM(B) ; skip if this is not it
+ JRST PCODE1 ; found it, drop out of loop
+ JUMPN E,.+3 ; dont record another empty if have one
+ SKIPN FB.NAM(B) ; skip if slot filled
+ MOVE E,B ; remember pointer
+ ADD B,[ELN,,ELN]
+ JUMPL B,PCODE2 ; jump if more to look at
+
+ JUMPE E,PCODE3 ; if E=0, error no room
+ MOVEM C,FB.NAM(E) ; else stash away name and zero rest
+ SETZM FB.PTR(E)
+ SETZM FB.AGE(E)
+ CAIA
+PCODE1: MOVE E,B ; build <slot #>,,<offset>
+ MOVEI 0,0 ; flag whether new slot
+ SKIPE FB.PTR(E) ; skip if mapped already
+ MOVEI 0,1
+ MOVE B,3(AB)
+ HLRE D,E
+ HLRE E,PURVEC+1
+ SUB D,E
+ HRLI B,(D)
+ MOVSI A,TPCODE
+ SKIPN NOSHUF ; skip if not shuffling
+ JRST FINIS
+ JUMPN 0,FINIS ; jump if winner
+ PUSH TP,A
+ PUSH TP,B
+ HLRZ A,B
+ PUSHJ P,PLOAD
+ JRST PCOERR
+ POP TP,B
+ POP TP,A
+ JRST FINIS
+
+PCOERR: ERRUUO EQUOTE PURE-LOAD-FAILURE
+
+PCODE3: HLRE A,PURVEC+1 ; get current length
+ MOVNS A
+ ADDI A,10*ELN ; add 10(8) more entry slots
+ PUSHJ P,IBLOCK
+ EXCH B,PURVEC+1 ; store new one and get old
+ HLRE A,B ; -old length to A
+ MOVSI B,(B) ; start making BLT pointer
+ HRR B,PURVEC+1
+ SUBM B,A ; final dest to A
+IFE ITS, HRLI A,-1 ; force local index
+ BLT B,-1(A)
+ JRST PCODE4
+
+; Here if must try to GC for some more core
+
+ASKAGC: SKIPE GCFLG ; if already in GC, lose
+IFN ITS, POPJ P,
+IFE ITS, JRST SPOPJ
+ MOVEM A,0 ; amount required to 0
+ ASH 0,PGSHFT ; TO WORDS
+ MOVEM 0,GCDOWN ; pass as funny arg to AGC
+ EXCH A,C ; save A from gc's destruction
+IFN ITS,.IOPUSH MAPCH, ; gc uses same channel
+ PUSH P,C
+ SETOM PLODR
+ MOVE C,[8,,9.] ; SET UP INDICATORS FOR GC
+ PUSHJ P,AGC
+ SETZM PLODR
+ POP P,C
+IFN ITS,.IOPOP MAPCH,
+ EXCH C,A
+IFE ITS,[
+ JUMPL C,.+3
+ JUMPL E,GETPAG
+ JRST GETPAX
+]
+IFN ITS, JUMPGE C,GETPAG
+ ERRUUO EQUOTE NO-MORE-PAGES
+
+; Here to clean up pure space by flushing all shared stuff
+
+PURCLN: SKIPE NOSHUF
+ POPJ P,
+ MOVEI B,EOC
+ HRRM B,PURVEC ; flush chain pointer
+ MOVE D,PURVEC+1 ; get pointer to table
+CLN1:
+IFE ITS,[
+ SKIPN A,FB.PTR(D)
+ JRST NOCL
+ ASH A,-PGSHFT
+ HRLI A,.FHSLF
+ RMAP
+ HLRZS A
+ CLOSF
+ JFCL
+]
+NOCL: SETZM FB.PTR(D) ; zero pointer entry
+ SETZM FB.AGE(D) ; zero link and age slots
+ SETZM FB.PGS(D)
+ ADD D,[ELN,,ELN] ; go to next slot
+ JUMPL D,CLN1 ; do til exhausted
+ MOVE B,PURBOT ; now return pages
+ SUB B,PURTOP ; compute page AOBJN pointer
+IFE ITS, SETZM MAPJFN ; make sure zero mapjfn
+ JUMPE B,CPOPJ ; no pure pages?
+ MOVSI B,(B)
+ HRR B,PURBOT
+ ASH B,-PGSHFT
+IFN ITS,[
+ DOTCAL CORBLK,[[1000,,0],[1000,,-1],B]
+ .LOSE %LSSYS
+]
+IFE ITS,[
+
+ SKIPE MULTSG
+ JRST CLN2
+ HLRE D,B ; - # of pges to flush
+ HRLI B,.FHSLF ; specify hacking hom fork
+ MOVNI A,1
+ MOVEI C,0
+
+ PMAP
+ ADDI B,1
+ AOJL D,.-2
+]
+
+ MOVE B,PURTOP ; now fix up pointers
+ MOVEM B,PURBOT ; to indicate no pure
+CPOPJ: POPJ P,
+
+IFE ITS,[
+CLN2: HLRE C,B ; compute pos no. pages
+ HRLI B,.FHSLF
+ MOVNS C
+ MOVNI A,1 ; flushing pages
+ HRLI C,PM%CNT
+ MOVE D,NSEGS
+ MOVE E,PURTOP ; for munging table
+ ADDI B,<FSEG>_9. ; do it to the correct segment
+ PMAP
+ ADDI B,1_9. ; cycle through segments
+ HRRZM E,PURBTB(D) ; mung table
+ SOJG D,.-3
+
+ MOVEM E,PURBOT
+ POPJ P,
+]
+
+; Here to move the entire pure space.
+; A/ # and direction of pages to move (+ ==> up)
+
+MOVPUR: SKIPE NOSHUF
+ FATAL CANT MOVE PURE SPACE AROUND
+IFE ITS,ASH A,1
+ SKIPN B,A ; zero movement, ignore call
+ POPJ P,
+
+ ASH B,PGSHFT ; convert to words for pointer update
+ MOVE C,PURVEC+1 ; loop through updating non-zero entries
+ SKIPE 1(C)
+ ADDM B,1(C)
+ ADD C,[ELN,,ELN]
+ JUMPL C,.-3
+
+ MOVE C,PURTOP ; found pages at top and bottom of pure
+ ASH C,-PGSHFT
+ MOVE D,PURBOT
+ ASH D,-PGSHFT
+ ADDM B,PURTOP ; update to new boundaries
+ ADDM B,PURBOT
+IFE ITS,[
+ SKIPN MULTSG ; in multi-seg mode, must mung whole table
+ JRST MOVPU1
+ MOVN E,NSEGS
+ HRLZS E
+ ADDM PURBTB(E)
+ AOBJN E,.-1
+]
+MOVPU1: CAIN C,(D) ; differ?
+ POPJ P,
+ JUMPG A,PUP ; if moving up, go do separate CORBLKs
+
+IFN ITS,[
+ SUBM D,C ; -size of area to C (in pages)
+ MOVEI E,(D) ; build pointer to bottom of destination
+ ADD E,A
+ HRLI E,(C)
+ HRLI D,(C)
+ DOTCAL CORBLK,[[1000,,200000],[1000,,-1],E,[1000,,-1],D]
+ .LOSE %LSSYS
+ POPJ P,
+
+PUP: SUBM C,D ; pages to move to D
+ ADDI A,(C) ; point to new top
+
+PUPL: SUBI C,1
+ SUBI A,1
+ DOTCAL CORBLK,[[1000,,200000],[1000,,-1],A,[1000,,-1],C]
+ .LOSE %LSSYS
+ SOJG D,PUPL
+ POPJ P,
+]
+IFE ITS,[
+ SUBM D,C ; pages to move to D
+ MOVSI E,(C) ; build aobjn pointer
+ HRRI E,(D) ; point to lowest
+ ADD D,A ; D==> new lowest page
+ MOVEI F,0 ; seg info
+ SKIPN MULTSG
+ JRST XPLS3
+ MOVEI F,FSEG-1
+ ADD F,NSEGS
+ ASH F,9.
+XPLS3: MOVE G,E
+ MOVE H,D ; save for outer loop
+
+PURCL1: MOVSI A,.FHSLF ; specify here
+ HRRI A,(E) ; get a page
+ IORI A,(F) ; hack seg i
+ RMAP ; get a real handle on it
+ MOVE B,D ; where to go
+ HRLI B,.FHSLF
+ MOVSI C,PM%RD+PM%EX
+ IORI A,(F)
+ PMAP
+ ADDI D,1
+ AOBJN E,PURCL1
+ SKIPN MULTSG
+ POPJ P,
+ SUBI F,1_9.
+ CAIGE F,FSEG_9.
+ POPJ P,
+ MOVE E,G
+ MOVE D,H
+ JRST PURCL1
+
+PUP: SUB D,C ; - count to D
+ MOVSI E,(D) ; start building AOBJN
+ HRRI E,(C) ; aobjn to top
+ ADD C,A ; C==> new top
+ MOVE D,C
+ MOVEI F,0 ; seg info
+ SKIPN MULTSG
+ JRST XPLS31
+ MOVEI F,FSEG
+ ADD F,NSEGS
+ ASH F,9.
+XPLS31: MOVE G,E
+ MOVE H,D ; save for outer loop
+
+PUPL: MOVSI A,.FHSLF
+ HRRI A,(E)
+ IORI A,(F) ; segment
+ RMAP ; get real handle
+ MOVE B,D
+ HRLI B,.FHSLF
+ IORI B,(F)
+ MOVSI C,PM%RD+PM%EX
+ PMAP
+ SUBI E,2
+ SUBI D,1
+ AOBJN E,PUPL
+ SKIPN MULTSG
+ POPJ P,
+ SUBI F,1_9.
+ CAIGE F,FSEG_9.
+ POPJ P,
+ MOVE E,G
+ MOVE D,H
+ JRST PUPL
+
+ POPJ P,
+]
+IFN ITS,[
+.GLOBAL CSIXBT
+CSIXBT: MOVEI 0,5
+ PUSH P,[440700,,C]
+ PUSH P,[440600,,D]
+ MOVEI D,0
+CSXB2: ILDB E,-1(P)
+ CAIN E,177
+ JRST CSXB1
+ SUBI E,40
+ IDPB E,(P)
+ SOJG 0,CSXB2
+CSXB1: SUB P,C%22
+ MOVE C,D
+ POPJ P,
+]
+GENVN: MOVE C,[440700,,MUDSTR+2]
+ MOVEI D,5
+ MOVEI B,0
+VNGEN: ILDB 0,C
+ CAIN 0,177
+ POPJ P,
+ IMULI B,10.
+ SUBI 0,60
+ ADD B,0
+ SOJG D,VNGEN
+ POPJ P,
+
+IFE ITS,[
+MSKS: 774000,,0
+ 777760,,0
+ 777777,,700000
+ 777777,,777400
+ 777777,,777776
+]
+
+\f; THESE ARE DIRECTORY SEARCH ROUTINES
+
+
+; THIS ROUTINE DOES A BINARY SEARCH ON A DIRECTORY AND RETURNS A POINTER
+; RESTED DOWN TO THE APPROPRIATE SLOT IN THE DIRECTORY.
+; ARGS: E==DIR POINTER D==FILE-NAME 1 A==VERSION #
+; RETS: A==RESTED DOWN DIRECTORY
+
+DIRSR1: TLOA 0,400000 ; INDICATION OF ONE ARGUMENT SEARCH
+DIRSRC: TLZ 0,400000 ; INDICATOR OF 2 ARGUMENT SEARCH
+ PUSH P,A ; SAVE VERSION #
+ HLRE B,E ; GET LENGTH INTO B
+ MOVNS B
+ MOVE A,E
+ HRLS B ; GET BOTH SIDES
+UP: ASH B,-1 ; HALVE TABLE
+ AND B,[-2,,-2] ; FORCE DIVIS BY 2
+ MOVE C,A ; COPY POINTER
+ JUMPLE B,LSTHLV ; CANT GET SMALLER
+ ADD C,B
+IFE ITS, HRRZ F,C ; avoid lossage in multi-sections
+IFN ITS, CAMLE D,(C) ; SKIP IF EITHER FOUND OR IN TOP
+IFE ITS, CAMLE D,(F) ; SKIP IF EITHER FOUND OR IN TOP
+ MOVE A,C ; POINT TO SECOND HALF
+IFN ITS, CAMN D,(C) ; SKIP IF NOT FOUND
+IFE ITS, CAMN D,(F) ; SKIP IF NOT FOUND
+ JRST WON
+IFN ITS, CAML D,(C) ; SKIP IF IN TOP HALF
+IFE ITS, CAML D,(F) ; SKIP IF IN TOP HALF
+ JRST UP
+ HLLZS C ; FIX UP POINTER
+ SUB A,C
+ JRST UP
+
+WON: JUMPL 0,SUPWIN
+ MOVEI 0,0 ; DOWN FLAG
+WON1: LDB A,[221200,,1(C)] ; GET VERSION NUMBER
+ CAMN A,(P) ; SKIP IF NOT EQUAL
+ JRST SUPWIN
+ CAMG A,(P) ; SKIP IF LT
+ JRST SUBIT
+ SETO 0,
+ SUB C,C%22 ; GET NEW C
+ JRST SUBIT1
+
+SUBIT: ADD C,C%22 ; SUBTRACT
+ JUMPN 0,C1POPJ
+SUBIT1:
+IFN ITS, CAMN D,(C) ; SEE WHETHER WERE STILL WINNING
+IFE ITS,[
+ HRRZ F,C
+ CAMN D,(F)
+]
+ JRST WON1
+C1POPJ: SUB P,C%11 ; GET RID OF VERSION #
+ POPJ P, ; LOSE LOSE LOSE
+SUPWIN: MOVE A,C ; RETURN ARGUMENT IN A
+ AOS -1(P) ; SKIP RETURN INDICATES IT WAS FOUND
+ JRST C1POPJ
+
+LSTHLV:
+IFN ITS, CAMN D,(C) ; LINEAR SEARCH REST
+IFE ITS,[
+ HRRZ F,C
+ CAMN D,(F) ; LINEAR SEARCH REST
+]
+ JRST WON
+ ADD C,C%22
+ JUMPL C,LSTHLV
+ JRST C1POPJ
+
+\f; ROUTINE TO GET A DIRECTORY. ASSUMES MAPCH IS OPEN TO FIXUP OR SAV FILE AND 0 IS THE
+; LAST CHAR TO BE HASHED. RETURNS POINTER TO DIRECTORY IN E
+
+IFN ITS,[
+GETDIR: PUSH P,C
+ PUSH P,0
+ PUSHJ P,SQKIL
+ MOVEI A,1 ; GET A BUFFER
+ PUSHJ P,GETBUF
+ MOVEI C,(B)
+ ASH C,-10.
+ DOTCAL CORBLK,[[RDTP],[FME],C,[1000,,MAPCH],[1000,,0]]
+ PUSHJ P,SLEEPR
+ POP P,0
+ IDIV 0,(B) ; A NOW CONTAINS THE DIRECTORY NUMBER
+ ADDI A,1(B)
+ DOTCAL CORBLK,[[RDTP],[FME],C,[1000,,MAPCH],(A)]
+ PUSHJ P,SLEEPR
+ MOVN E,(B) ; GET -LENGTH OF DIRECTORY
+ HRLZS E ; BUILD AOBJN PTR TO DIR
+ HRRI E,1(B)
+ POP P,C
+ POPJ P,
+]
+; IN WONDERFUL TOPS20 VERSION DIRCHN CONTAINS THE JFN
+
+IFE ITS,[
+GETDIR: JRST @[.+1]
+ PUSH P,C
+ PUSH P,0
+ PUSHJ P,SQKIL
+ MOVEI A,1 ; GET A BUFFER
+ PUSHJ P,GETBUF
+ HRROI E,(B)
+ ASH B,-9.
+ HRLI B,.FHSLF ; SET UP DESTINATION (CORE)
+ MOVS A,DIRCHN ; SET UP SOURCE (FILE)
+ MOVSI C,PM%RD+PM%EX ; READ+EXEC ACCESS
+ PMAP
+ POP P,0
+ IDIV 0,(E) ; A NOW CONTAINS THE DIRECTORY NUMBER
+ ADDI A,1(E) ; POINT TO THE DIRECTORY ENTRY
+ MOVE A,(A) ; GET THE PAGE NUMBER
+ HRL A,DIRCHN ; SET UP SOURCE (FILE)
+ PMAP ; AGAIN READ IN DIRECTORY
+ MOVEI A,(E)
+ MOVN E,(E) ; GET -LENGTH OF DIRECTORY
+ HRLZS E ; BUILD AOBJN PTR TO DIR
+ HRRI E,1(A)
+ POP P,C
+ SKIPN MULTSG
+ POPJ P,
+ POP P,21
+ SETZM 20
+ XJRST 20
+]
+; HERE IF CAN'T FIND FIXUP FILE IN MAIN DIRECTORY
+
+NOFXUP:
+IFE ITS,[
+ MOVE A,DIRCHN ; JFN FOR FIXUP FILE
+ CLOSF ; CLOSE IT
+ JFCL
+]
+ MOVE A,FXTBL ; GET AOBJN POINTER TO FIXUP TABLE
+NOFXU1: HRRZ B,(A) ; GET VERSION TO TRY
+ HRRM B,VER(P) ; STUFF IN VERSION
+ MOVEI B,1 ; DUMP IN FIXUP INDICATOR
+ HRLM B,VER(P)
+ MOVEM A,TEMP(P) ; SAVE POINTER TO FXTBL
+ PUSHJ P,OPXFIL ; LOOK FOR FIXUP FILE
+ JRST NOFXU2
+ PUSHJ P,RFXUP ; READ IN THE FIXUP FILE
+ HRRZS VER(P) ; INDICATE SAV FILE
+ PUSHJ P,OPXFIL ; TRY OPENING IT
+ JRST MAPLS0 ; GIVE UP NO SAV FILE TO BE HAD
+ PUSHJ P,RSAV
+ JRST FXUPGO ; GO FIXUP THE WORLD
+NOFXU2: MOVE A,TEMP(P) ; GET BACK POINTER
+ AOBJN A,NOFXU1 ; TRY NEXT
+ JRST MAPLS1 ; NO FILE TO BE HAD
+
+GETIT: HRRZM B,SPAG(P) ; GET BLOCK OF START
+ HLRZM B,FLEN(P) ; DAMMIT SAVE THIS!
+ HLRZ A,B ; GET LENGTH\r
+IFN ITS,[
+ .CALL MNBLK
+ PUSHJ P,TRAGN
+]
+IFE ITS,[
+ MOVE E,MAPJFN
+ MOVEM E,DIRCHN
+]
+
+ JRST PLOD1
+
+; ROUTINE TO SEE IF FILE IS NOT OPEN BECAUSE OF FNF AND FATAL IF SO
+
+IFN ITS,[
+TRAGN: PUSH P,0 ; SAVE 0
+ .STATUS MAPCH,0 ; GET STATUS BITS
+ LDB 0,[220600,,0]
+ CAIN 0,4 ; SKIP IF NOT FNF
+ FATAL MAJOR FILE NOT FOUND
+ POP P,0
+ SOS (P)
+ SOS (P) ; RETRY OPEN
+ POPJ P,
+]
+IFE ITS,[
+OPSAV: MOVSI A,%GJSHT+%GJOLD ; BITS FOR GTJFN
+ HRROI B,SAVSTR ; STRING POINTER
+ SKIPE OPSYS
+ HRROI B,TSAVST
+ GTJFN
+ FATAL CANT FIND SAV FILE
+ MOVEM A,MAPJFN ; STORE THE JFN
+ MOVE B,[440000,,OF%RD+OF%EX+OF%THW+OF%DUD]
+ OPENF
+ FATAL CANT OPEN SAV FILE
+ POPJ P,
+]
+
+; OPMFIL IS USED TO OPEN A FILE ON MUDTMP. IT CAN OPEN EITHER A SAV OR FIXUP FILE
+; AND THE VERSION NUMBER IS SPECIFIED. THE ARGUMENTS ARE
+; NAM-1(P) HAS SIXBIT OF FILE NAME
+; VER-1(P) HAS 0,,VERSION # FOR SAV FILE AND 1,,VERSION# FOR FIXUP FILE
+; RETURNS LENGTH OF FILE IN SLEN AND
+
+; OPXFIL IS A KLUDGE FOR GETTING SAV AND FIXUP FILES OFF OF THE MDLLIB
+; DIRECTORY DURING THE CHANGEOVER TO PRE- AND POST- MUDSAV WORLDS
+
+OPXFIL: MOVEI 0,1
+ MOVEM 0,WRT-1(P)
+ JRST OPMFIL+1
+
+OPWFIL: SETOM WRT-1(P)
+ SKIPA
+OPMFIL: SETZM WRT-1(P)
+
+IFN ITS,[
+ HRRZ C,VER-1(P) ; GET VERSION NUMBER
+ PUSHJ P,NTOSIX ; CONVERT TO SIXBIT
+ HRLI C,(SIXBIT /SAV/) ; BUILD SECOND FILE NAME
+ HLRZ 0,VER-1(P)
+ SKIPE 0 ; SKIP IF SAV
+ HRLI C,(SIXBIT/FIX/)
+ MOVE B,NAM-1(P) ; GET NAME
+ MOVSI A,7 ; WRITE MODE
+ SKIPL WRT-1(P)
+ MOVSI A,6 ; READ MODE
+RETOPN: .CALL FOPBLK
+ JRST OPCHK ; SEE IF FIXUP IS NECESSARY OR JUST REOPENING
+ DOTCAL FILLEN,[[1000,,MAPCH],[2000,,A]]
+ .LOSE 1000
+ ADDI A,PGMSK ; ROUND
+ ASH A,-PGSHFT ; TO PAGES
+ MOVEM A,FLEN-1(P)
+ SETZM SPAG-1(P)
+ AOS (P) ; SKIP RETURN TO SHOW SUCCESS
+ POPJ P,
+
+OPCHK: .STATUS MAPCH,0 ; GET STATUS BITS
+ LDB 0,[220600,,0]
+ CAIE 0,4 ; SKIP IF FNF
+ JRST OPCHK1 ; RETRY
+ POPJ P,
+
+OPCHK1: MOVEI 0,1 ; SLEEP FOR A WHILE
+ .SLEEP
+ JRST OPCHK
+
+; NTOSIX GETS NUMBER IN C AND CONVERTS IT TO SIXBIT AND RETURNS RESULT IN C
+
+NTOSIX: PUSH P,A ; SAVE A AND B
+ PUSH P,B
+ PUSH P,D
+ MOVE D,[220600,,C]
+ MOVEI A,(C) ; GET NUMBER
+ MOVEI C,0
+ IDIVI A,100. ; GET RESULT OF DIVISION
+ SKIPN A
+ JRST ALADD
+ ADDI A,20 ; CONVERT TO DIGIT
+ IDPB A,D
+ALADD: MOVEI A,(B)
+ IDIVI A,10. ; GET TENS DIGIT
+ SKIPN C
+ SKIPE A ; IF BOTH 0 BLANK DIGIT
+ ADDI A,20
+ IDPB A,D
+ SKIPN C
+ SKIPE B
+ ADDI B,20
+ IDPB B,D
+ POP P,D
+ POP P,B
+ POP P,A
+ POPJ P,
+
+]
+
+IFE ITS,[
+ MOVE E,P ; save pdl base
+ MOVE B,NAM-1(E) ; GET FIRST NAME
+ PUSH P,C%0 ; [0]; slots for building strings
+ PUSH P,C%0 ; [0]
+ MOVE A,[440700,,1(E)]
+ MOVE C,[440600,,B]
+
+; DUMP OUT SIXBIT NAME
+
+ MOVEI D,6
+ ILDB 0,C
+ JUMPE 0,.+4 ; violate cardinal ".+ rule"
+ ADDI 0,40 ; to ASCII
+ IDPB 0,A
+ SOJG D,.-4
+
+ MOVE 0,[ASCII / SAV/]
+ HLRZ C,VER-1(E) ; GET SAV/FIXUP FLAG
+ SKIPE C
+ MOVE 0,[ASCII / FIX/]
+ PUSH P,0
+ HRRZ C,VER-1(E) ; get ascii of vers no.
+ PUSHJ P,NTOSEV ; CONVERT TO STRING LEFT JUSTIFIED
+ PUSH P,C
+ MOVEI B,-1(P) ; point to it
+ HRLI B,260700
+ HRROI D,1(E) ; point to name
+ MOVEI A,1(P)
+ MOVSI 0,100000 ; INPUT FILE (GJ%OLD)
+ SKIPGE WRT-1(E)
+ MOVSI 0,400000 ; OUTPUT FILE (GJ%FOU)
+ PUSH P,0
+ PUSH P,[377777,,377777]
+ MOVE 0,[-1,,[ASCIZ /DSK/]]
+ SKIPN OPSYS
+ MOVE 0,[-1,,[ASCIZ /PS/]]
+ PUSH P,0
+ HRROI 0,[ASCIZ /MDL/]
+ SKIPLE WRT-1(E)
+ HRROI 0,[ASCIZ /MDLLIB/] ; USE MDLLIB FOR SPECIAL CASE
+ PUSH P,0
+ PUSH P,D
+ PUSH P,B
+ PUSH P,C%0 ; [0]
+ PUSH P,C%0 ; [0]
+ PUSH P,C%0 ; [0]
+ MOVEI B,0
+ MOVE D,4(E) ; save final version string
+ GTJFN
+ JRST OPMLOS ; FAILURE
+ MOVEM A,DIRCHN
+ MOVE B,[440000,,OF%RD+OF%EX]
+ SKIPGE WRT-1(E)
+ MOVE B,[440000,,OF%RD+OF%WR]
+ OPENF
+ FATAL OPENF FAILED
+ MOVE P,E ; flush crap
+ PUSH P,A
+ SIZEF ; get length
+ JRST MAPLOS
+ SKIPL WRT-1(E)
+ MOVEM C,FLEN-1(E) ; ONLY SAVE LENGTH FOR READ JFNS
+ SETZM SPAG-1(E)
+
+; RESTORE STACK AND LEAVE
+
+ MOVE P,E
+ MOVE A,C ; NUMBER OF PAGES IN A, DAMN!
+ AOS (P)
+ POPJ P,
+
+OPMLOS: MOVE P,E
+ POPJ P,
+
+; CONVERT A NUMBER IN C TO AN ASCII STRING LEFT JUSTIFIED IN C
+
+NTOSEV: PUSH P,A ; SAVE A AND B
+ PUSH P,B
+ PUSH P,D
+ MOVE D,[440700,,C]
+ MOVEI A,(C) ; GET NUMBER
+ MOVEI C,0
+ IDIVI A,100. ; GET RESULT OF DIVISION
+ JUMPE A,ALADD
+ ADDI A,60 ; CONVERT TO DIGIT
+ IDPB A,D
+ALADD: MOVEI A,(B)
+ IDIVI A,10. ; GET TENS DIGIT
+ ADDI A,60
+ IDPB A,D
+ALADD1: ADDI B,60
+ IDPB B,D
+ POP P,D
+ POP P,B
+ POP P,A
+ POPJ P,
+
+]
+
+; ROUTINE TO READ IN THE FIXUPS FROM DIRCHN OR MAPCH WORKS
+; FOR FIXUP FILE OR FIXUPS IN A SEPERATE FILE AS LONG AS THE
+; CHANNEL IS OPENED AND ACCESSED TO THE RIGHT PLACE
+
+RFXUP:
+IFN ITS,[
+ MOVE 0,[-2,,A] ; PREPARE TO READ VERSION AND LENGTH
+ .IOT MAPCH,0 ; READ IT IN
+ SKIPGE 0 ; SKIP IF NOT HIT EOF
+ FATAL BAD FIXUP FILE
+ MOVEI A,-2(A) ; COUNT FOR FIRST 2 WORDS
+ HRRM B,VER-1(P) ; SAVE VERSION #
+ .IOPUS MAPCH, ; PUSH THE MAPPING CHANNEL
+ SETOM PLODR
+ PUSHJ P,IBLOCK ; GET A UVECTOR OF APPROPRIATE SIZE
+ SETZM PLODR
+ .IOPOP MAPCH,
+ MOVE 0,$TUVEC
+ MOVEM 0,-1(TP) ; SAVE UVECTOR
+ MOVEM B,(TP)
+ MOVE A,B ; GET AOBJN POINTER TO UVECTOR FOR IOT
+ .IOT MAPCH,A ; GET FIXUPS
+ .CLOSE MAPCH,
+ POPJ P,
+]
+
+IFE ITS,[
+ MOVE A,DIRCHN
+ BIN ; GET LENGTH OF FIXUP
+ MOVE C,B
+ MOVE A,DIRCHN
+ BIN ; GET VERSION NUMBER
+ HRRM B,VER-1(P)
+ SETOM PLODR
+ MOVEI A,-2(C)
+ PUSHJ P,IBLOCK
+ SETZM PLODR
+ MOVSI 0,$TUVEC
+ MOVEM 0,-1(TP)
+ MOVEM B,(TP)
+ MOVE A,DIRCHN
+ HLRE C,B
+; SKIPE OPSYS ; SKIP IF TOPS20 SINCE C MUST BE NEGETIVE
+; MOVNS C ; C IS POSITIVE FOR TENEX ?????
+ HRLI B,444400
+ SIN
+ MOVE A,DIRCHN
+ CLOSF
+ FATAL CANT CLOSE FIXUP FILE
+ RLJFN
+ JFCL
+ POPJ P,
+]
+
+; ROUTINE TO READ IN THE CODE
+
+RSAV: MOVE A,FLEN-1(P)
+ PUSHJ P,ALOPAG ; GET PAGES
+ JRST MAPLS2
+ MOVE E,SPAG-1(P)
+
+IFN ITS,[
+ MOVN A,FLEN-1(P) ; build aobjn pointer
+ MOVSI A,(A)
+ HRRI A,(B)
+ MOVE B,A
+ HRRI 0,(E)
+ DOTCAL CORBLK,[[1000,,104000],[1000,,-1],A,[1000,,MAPCH],0]
+ .LOSE %LSSYS
+ .CLOSE MAPCH,
+ POPJ P,
+]
+IFE ITS,[
+ PUSH P,B ; SAVE PAGE #
+ MOVS A,DIRCHN ; SOURCE (MUDSAV)
+ HLRM A,SJFNS ; SAVE POINTER FOR FUTURE CLOSING
+ HRR A,E
+ HRLI B,.FHSLF ; DESTINATION (FORK)
+ MOVSI C,PM%RD+PM%CPY ; MAKE COPY ON WRITE
+ SKIPE OPSYS
+ JRST RSAV1 ; HANDLE TENEX
+ TLO C,PM%CNT ; REPEAT COUNT BIT FOR TOPS20
+ HRR C,FLEN-2(P) ; PAGE (FOR PUSHJ AND PUSHED B)
+ PMAP
+RSAVDN: POP P,B
+ MOVN 0,FLEN-1(P)
+ HRL B,0
+ POPJ P,
+
+RSAV1: HRRZ D,FLEN-2(P) ; GET IN PAGE COUNT
+RSAV2: PMAP
+ ADDI A,1 ; NEXT PAGE
+ ADDI B,1
+ SOJN D,RSAV2 ; LOOP
+ JRST RSAVDN
+]
+
+PDLOV: SUB P,[NSLOTS,,NSLOTS]
+ PUSH P,C%0 ; [0]; CAUSE A PDL OVERFLOW
+ JRST .-1
+
+; CONSTANTS RELATED TO DATA BASE
+DEV: SIXBIT /DSK/
+MODE: 6,,0
+MNDIR: SIXBIT /MUDSAV/ ; DIR OF MAIN DATA BASE FILES
+WRKDIR: SIXBIT /MUDTMP/ ; DIRECTORY OF UPDATE FILES
+
+IFN ITS,[
+MNBLK: SETZ
+ SIXBIT /OPEN/
+ MODE
+ DEV
+ [SIXBIT /SAV/]
+ [SIXBIT /FILE/]
+ SETZ MNDIR
+
+
+FIXBLK: SETZ
+ SIXBIT /OPEN/
+ MODE
+ DEV
+ [SIXBIT /FIXUP/]
+ [SIXBIT /FILE/]
+ SETZ MNDIR
+
+FOPBLK: SETZ
+ SIXBIT /OPEN/
+ A
+ DEV
+ B
+ C
+ SETZ WRKDIR
+
+FXTBL: -2,,.+1
+ 55.
+ 54.
+]
+IFE ITS,[
+
+FXSTR: ASCIZ /PS:<MDL>FIXUP.FILE/
+SAVSTR: ASCIZ /PS:<MDL>SAV.FILE/
+TFXSTR: ASCIZ /DSK:<MDL>FIXUP.FILE/
+TSAVST: ASCIZ /DSK:<MDL>SAV.FILE/
+
+FXTBL: -3,,.+1
+ 55.
+ 54.
+ 104.
+]
+IFN SPCFXU,[
+
+;This code does two things to code for FBIN;
+; 1) Makes dispatches win in multi seg mode
+; 2) Makes OBLIST? work with "new" atom format
+; 3) Makes LENGTH win in multi seg mode
+; 4) Gets AOBJN pointer to code vector in C
+
+SFIX: PUSH P,A
+ PUSH P,B
+ PUSH P,C ; for referring back
+
+SFIX1: MOVSI B,-MLNT ; for looping through tables
+
+SFIX2: MOVE A,(C) ; get code word
+
+ AND A,SMSKS(B)
+ CAMN A,SPECS(B) ; do we match
+ JRST @SFIXR(B)
+
+ AOBJN B,SFIX2
+
+SFIX3: AOBJN C,SFIX1 ; do all of code
+SFIX4: POP P,C
+ POP P,B
+ POP P,A
+ POPJ P,
+
+SMSKS: -1
+ 777000,,-1
+ -1,,0
+ 777037,,0
+MLNT==.-SMSKS
+
+SPECS: HLRES A ; begin of arg diaptch table
+ SKIPN 2 ; old compiled OBLIST?
+ JRST (M) ; compiled LENGTH
+ ADDI (M) ; begin a case dispatch
+
+SFIXR: SETZ DFIX
+ SETZ OBLFIX
+ SETZ LFIX
+ SETZ CFIX
+
+DFIX: AOBJP C,SFIX4 ; make sure dont run out
+ MOVE A,(C) ; next ins
+ CAME A,[ASH A,-1] ; still winning?
+ JRST SFIX3 ; false alarm
+ AOBJP C,SFIX4 ; make sure dont run out
+ HLRZ A,(C) ; next ins
+ CAIE A,(ADDI A,(M)) ; still winning?
+ JRST SFIX3 ; false alarm
+ AOBJP C,SFIX4
+ HLRZ A,(C)
+ CAIE A,(PUSHJ P,@(A)) ; last one to check
+ JRST SFIX3
+ AOBJP C,SFIX4
+ MOVE A,(C)
+ CAME A,[JRST FINIS] ; extra check
+ JRST SFIX3
+
+ MOVSI B,(SETZ)
+SFIX5: AOBJP C,SFIX4
+ HLRZ A,(C)
+ CAIN A,(SUBM M,(P))
+ JRST SFIX3
+ CAIE A,M ; dispatch entry?
+ JRST SFIX3 ; maybe already fixed
+ IORM B,(C) ; fix it
+ JRST SFIX5
+
+OBLFIX: PUSH P,[-TLN,,TPTR]
+ PUSH P,C
+ MOVE B,-1(P)
+
+OBLFXY: PUSH P,1(B)
+ PUSH P,(B)
+
+OBLFI1: AOBJP C,OBLFXX
+ MOVE A,(C)
+ AOS B,(P)
+ AND A,(B)
+ MOVE B,-1(P)
+ CAME A,(B)
+ JRST OBLFXX
+ AOBJP B,DOOBFX
+ MOVEM B,-1(P)
+ JRST OBLFI1
+
+OBLFXX: SUB P,C%22 ; for checking more ins
+ MOVE B,-1(P)
+ ADD B,C%22
+ JUMPGE B,OBLFX1
+ MOVEM B,-1(P)
+ MOVE C,(P)
+ JRST OBLFXY
+
+
+INSBP==331100 ; byte pointer for ins field
+ACBP==270400 ; also for ac
+INDXBP==220400
+
+DOOBFX: MOVE C,-2(P)
+ SUB P,C%44
+ MOVEI B,<<(HRRZ)>_<-9>> ; change em
+ DPB B,[INSBP,,(C)] ; SKIPN==>HRRZ
+ LDB A,[ACBP,,(C)] ; get AC field
+ MOVEI B,<<(JUMPE)>_<-9>>
+ DPB B,[INSBP,,1(C)]
+ DPB A,[ACBP,,1(C)]
+ AOS 1(C) ; JRST FOO==>JUMPE ac,FOO+1
+ MOVE B,[CAMG VECBOT]
+ DPB A,[ACBP,,B]
+ MOVEM B,2(C) ; JUMPL ==> CAMG ac,VECBOT
+ HRRZ A,3(C) ; get indicator of existence of ADD AC,TVP
+ CAIE A,TVP ; skip if extra ins exists
+ JRST NOATVP
+ MOVSI A,(JFCL)
+ EXCH A,4(C)
+ MOVEM A,3(C)
+ ADD C,C%11
+NOATVP: TLC B,(CAMG#HRLI) ; change CAMG to HRLI (preserving AC)
+ HRRZ A,4(C) ; see if moves in type
+ CAIE A,$TOBLS
+ SUB C,[1,,1] ; fudge it
+ HLLOM B,5(C) ; in goes HRLI -1
+ CAIE A,$TOBLS ; do we need a skip?
+ JRST NOOB$
+ MOVSI B,(CAIA) ; skipper
+ EXCH B,6(C)
+ MOVEM B,7(C)
+ ADD C,[7,,7]
+ JRST SFIX3
+
+NOOB$: MOVSI B,(JFCL)
+ MOVEM B,6(C)
+ ADD C,C%66
+ JRST SFIX3
+
+OBLFX1: MOVE C,(P)
+ SUB P,C%22
+ JRST SFIX3
+
+; Here to fixup compiled LENGTH
+
+LFIX: MOVSI B,-LLN ; for checking other LENGTH ins
+ PUSH P,C
+
+LFIX1: AOBJP C,LFIXY
+ MOVE A,(C)
+ AND A,LMSK(B)
+ CAME A,LINS(B)
+ JRST LFIXY
+ AOBJN B,LFIX1
+
+ POP P,C ; restore code pointer
+ MOVE A,(C) ; save jump for its addr
+ MOVE B,[MOVSI 400000]
+ MOVEM B,(C) ; JRST .+2 ==> MOVSI 0,400000
+ LDB B,[ACBP,,1(C)] ; B==> AC of interest
+ ADDI A,2
+ DPB B,[ACBP,,A]
+ MOVEI B,<<(JUMPE)>_<-9.>>
+ DPB B,[INSBP,,A]
+ EXCH A,1(C)
+ TLC A,(HRR#HRRZ) ; HRR==>HRRZ
+ HLLZM A,2(C) ; TRNN AC,-1 ==> HRRZ AC,(AC)
+ MOVEI B,(AOBJN (M))
+ HRLM B,3(C) ; AOBJP AC,.-2 ==> AOBJN 0,.-2
+ MOVE B,2(C) ; get HRRZ AC,(AC)
+ TLZ B,17 ; kill (AC) part
+ MOVEM B,4(C) ; HLRZS AC ==> HRRZ AC,0
+ ADD C,C%44
+ JRST SFIX3
+
+LFIXY: POP P,C
+ JRST SFIX3
+
+; Fixup a CASE dispatch
+
+ CFIX: LDB A,[ACBP,,(C)]
+ AOBJP C,SFIX4
+ HLRZ B,(C) ; Next ins
+ ANDI B,777760
+ CAIE B,(JRST @)
+ JRST SFIX3
+ LDB B,[INDXBP,,(C)]
+ CAIE A,(B)
+ JRST SFIX3
+ MOVE A,(C) ; ok, fix it up
+ TLZ A,20 ; kill indirection
+ MOVEM A,(C)
+ HRRZ B,-1(C) ; point to table
+ ADD B,(P) ; point to code to change
+
+CFIXLP: HLRZ A,(B) ; check one out
+ TRZ A,400000 ; kill bit
+ CAIE A,M ; check for just index (or index with SETZ)
+ JRST SFIX3
+ MOVEI A,(JRST (M))
+ HRLM A,(B)
+ AOJA B,CFIXLP
+
+DEFINE FOO LBL,LNT,LBL2,L
+LBL:
+ IRP A,,[L]
+ IRP B,C,[A]
+ B
+ .ISTOP
+ TERMIN
+ TERMIN
+LNT==.-LBL
+LBL2:
+ IRP A,,[L]
+ IRP B,C,[A]
+ C
+ .ISTOP
+ TERMIN
+ TERMIN
+TERMIN
+
+IMSK==777017,,0
+AIMSK==777000,,-1
+
+FOO OINS,OLN,OMSK,[[<JRST (M)>,IMSK],[<JUMPL (M)>,IMSK],[MOVE,AIMSK]
+ [<MOVE $TOBLS>,AIMSK],[<JRST (M)>,IMSK]
+ [<MOVE $TFALSE>,AIMSK],[MOVEI,AIMSK]]
+
+FOO OINS3,OLN3,OMSK3,[[<JRST (M)>,IMSK],[<JUMPL (M)>,IMSK],[MOVE,AIMSK]
+ [<JRST (M)>,IMSK],[MOVEI,AIMSK]]
+
+FOO OINS2,OLN2,OMSK2,[[<JRST (M)>,IMSK],[<JUMPL (M)>,IMSK],[<ADD TVP>,AIMSK]
+ [MOVE,AIMSK],[<MOVE $TOBLS>,AIMSK],[<JRST (M)>,IMSK]
+ [<MOVE $TFALSE>,AIMSK],[MOVEI,AIMSK]]
+
+FOO OINS4,OLN4,OMSK4,[[<JRST (M)>,IMSK],[<JUMPL (M)>,IMSK],[<ADD TVP>,AIMSK]
+ [MOVE,AIMSK],[<JRST (M)>,IMSK],[MOVEI,AIMSK]]
+
+TPTR: -OLN,,OINS
+ OMSK-1
+ -OLN2,,OINS2
+ OMSK2-1
+ -OLN3,,OINS3
+ OMSK3-1
+ -OLN4,,OINS4
+ OMSK4-1
+TLN==.-TPTR
+
+FOO LINS,LLN,LMSK,[[<HRR -1>,AIMSK],[<TRNE -1>,AIMSK],[<AOBJP (M)>,IMSK]
+ [<HLRZS>,<-1,,777760>]]
+
+]
+IMPURE
+
+SAVSNM: 0 ; SAVED SNAME
+INPLOD: 0 ; FLAG SAYING WE ARE IN MAPPUR
+
+IFE ITS,[
+MAPJFN: 0 ; JFN OF <MDL>SAV FILE
+DIRCHN: 0 ; JFN USED BY GETDIR
+]
+
+PURE
+
+END
+
--- /dev/null
+; THE FOLLOWING INFORMATION IS MEANT AS GUIDE TO THE CARE AND FEEDING
+; OF MUDDLE. IT ATTEMPTS TO SPECIFY PROGRAMMING CONVENTIONS AND
+; SUPPLY SYMBOLS AND MACROS NEEDED BY ALL MODULES IN A MUDDLE.
+
+; FOR EFFICIENCY THE STANDARD MODE OF RUNNING IS UNINTERRUPTABLE.
+; WITH EXPLICIT CHECKS FOR PENDING INTERRUPTS. THE INTGO MACRO
+; PERFORMS THE APPROPRIATE CHECK
+
+; FOR INTERRUPTS TO WORK IN INTERRUPTABLE CODE, IT MUST
+; BE ABSOLUTELY PURE. BETWEEN ANY TWO INSTRUCTIONS OF
+; INTERRUPTABLE CODE THERE MAY BE AN INTERUPT IN WHICH
+; A COMPACTING GARBAGE COLLECTION MAY OCCUR.
+; NOTE: A SCRATCH AC MAY CONTAIN POINTERS TO GC SPACE IN
+; INTERRUPTABLE CODE OR DURING AN INTGO IF THE TYPE CODE FOR THAT AC'S
+; SLOT IN THE PROCESS VECTOR IS SET TO REFLECT ITS CONTENTS.
+
+; ALL ATOM POINTERS WILL BE REFERRED TO IN ASSEMBLED CODE BY
+; MQUOTE <PNAME> -- FOR NORMAL ATOMS
+; EQUOTE <PNAME> -- FOR ERROR COMMENT ATOMS
+
+; FUNCTION CALLS TO INITIAL FUNCTIONS WILL BE CALLED USING THE FOLLOWING:
+
+; MCALL N,<PNAME> ;SEE MCALL MACRO
+; ACALL AC,<PNAME> ; SEE ACALL MACRO
+
+; UNLESS PNAME IS NOT A VALID MIDAS SYMBOL, IN WHICH CASE ANOTHER INTERNAL
+; NAME WILL BE USED
+
+; WHEN CALLING A SUBR THROUGH AN INDEX OR INDIRECT, THE UUOS GENERATED
+; BY THE MACROS SHOULLD BE USED.
+; THESE ARE .MCALL AND .ACALL -- EXAMPLE:
+; .ACALL A,@(B)
+
+
+
+
+
+\f; ORGANIZATION OF CORE STORAGE IN THE MUDDLE SYSTEM (ENVIRONMENT)
+
+; 20: SPECIAL CODE FOR UUO AND INTERUPTS
+
+;CODBOT: WORD CONTAINING LOCATION OF BOTTOMMOST WORD OF IMPURE CODE
+
+; --IMPURE CODE--
+
+;CODTOP: WORD CONTAINING LOCATION OFWORD AFTER LAST WORD OF CODE
+
+;PARBOT: WORD CONTAINING LOCATION OFBOTTOMMOST LIST
+
+; --PAIRSS--
+
+;PARTOP: WORD CONTAINING LOCATION OFWORD AFTER LAST PAIR WORD
+
+;VECBOT: WORD CONTAINING LOCATION OFFIRST WORD OF VECTORS
+
+; --VECTORS--
+
+;VECTOP: WORD CONTAINING LOCATION OFWORD AFTER TOPMOST VECTOR
+; THE WORD BEFORE VECTOP IS THE DOPE FOR THE LAST VECTOR
+
+; --GC MARK PDL (SOMETIMES NOT THERE)--
+
+;CORTOP: TOP OF LOW-SEGMENT/IMPURE CORE
+
+;600000: START OF PURE CODE (SHARED ALSO)
+
+; --PURE CODE--
+
+;
+
+
+\f; BASIC DATA TYPES PRE-DEFINED IN MUDDLE
+
+; PRIMITIVE DATA TYPES
+; IF T IS A DATA TYPE THEN $T=[T,,0]
+
+; DATA TYPES ARE ASSIGNED BY THE TYPMAK MACRO IN SOME ARBITRARY ORDER
+
+
+;TLOSE ;ILLEGAL TYPE (USED PRIMARILY FOR ERRORS)
+;TFIX ;FIXED POINT
+;TFLOAT ;FLOATING POINT
+;TCHRS ;WORD OF UP TO 5 ASCII CHARACTERS
+;TENTRY ; MARKS BEGINNING OF A FRAME ON TP STACK
+;TSUBR ;BUILT IN FUNCTION WITH EVALUATED ARGS
+;TFSUBR ;BUILT IN FUNCTION WITH UN-EVALUATED ARGS
+;TUNBOU ;TYPE GIVEN TO UNBOUND OR UNASSIGNED ATOM
+;TBIND ;MARKS BEGINNING OF BINDING BLOCK ON TP STACK
+;TILLEG ;POINTER PREVIOUSLY HERE NOW ILLEGAL
+;TTIME ;UNIQUE NUMBER (SEE FLOAD)
+;TLIST ;POINTER TO LIST ELEMENT
+;TFORM ;POINTER TO LIST ELEMENT BUT USED AS AN EXPRESSION
+;TSEG ;SAME AS FORM BUT VALUE IS MUST BE STRUCTURED AND IS USED
+; ;AS A SEGMENT
+;TEXPR ;POINTER TO LIST ELEMENT BUT USED AS AN INTERPRETIVE FUNCTION
+;TFUNAR ;LIKE TEXPR BUT HAS PARTIALLY EVALUATED ARGS
+;TLOCL ;LOCATIVE TO LIST ELEMENT (SEE AT,IN AND SETLOC)
+;TFALSE ;NOT TRUTH
+;TDEFER ;POINTER TO REAL VALUE (ONLY APPEARS AS CAR OF LIST)
+;TUVEC ;AOBJN POINTER TO UNIFORM VECTOR
+;TOBLS ;AOBJN TO UVEC OF LISTS OF ATOMS. USED AS SYMBOL TABLE
+;TVEC ;VECTOR (AOBJN POINTER TO GENERALIZED VECTOR)
+;TCHAN ;VECTOR OF INFO DESCRIBING AN I/O CHANNEL
+;TLOCV ;LOCATIVE TO GENERAL VECTOR (SEE AT,IN AND SETLOC)
+;TTVP ;POINTER TO TRANSFER VECTOR
+;TBVL ;BEGINS A VECTOR BINDING ON THE TP STACK
+;TTAG ;VECTOR OF INFO SPECIFYING A GENERALIZED TAG
+;TPVP ;POINTER TO PROCESS VECTOR
+;TLOCI ;POINTER TO ATOM VALUE ON STACK (INTERNAL NOT SEEN BY USER)
+;TTP ;POINTER TO MAIN MARKED STACK
+;TSP ;POINTER TO CURRENT BINDINGS ON STACK
+;TLOCS ;LOCATIVE TO STACK (NOT CURRENTLY USED)
+;TPP ;POINTER TO PLANNER PDL (NOT CURRENTLY USED)
+;TPLD ;POINTER TO P-STACK (UNMARKED)
+;TARGS ;POINTER TO AN ARG BLOCK (HAIRY KLUDGE)
+;TAB ;SAVED AB (NOT GIVEN TO USER)
+;TTB ;SAVED TB (NOT GIVEN TO USER)
+;TFRAME ;USER POINTER TO STACK FRAME
+;TCHSTR ;BYTE POINTER TO STRING OF CHARS (COUNT ALSO INCLUDED)
+;TATOM ;POINTER TO ATOM
+;TLOCD ;USER LOCATIVE TO ATOM VALUE
+;TBYTE :POINTER TO ARBITRARY BYTE STRING (NOT CURRENTLY USED)
+;TENV ;USER POINTER TO FRAME USED AS AN ENVIRONMENT
+;TACT ;USER POINTER TO FRAME FOR A NAMED ACTIVATION
+;TASOC ;ASSOCIATION TRIPLE
+;TLOCU ;LOCATIVE TO UVECTOR ELEMENT (SEE AT,IN AND SETLOC)
+;TLOCS ;LOCATIVE TO A BYTE IN A CHAR STRING (SEE AT,IN AND SETLOC)
+;TLOCA ;LOCATIVE TO ELEMENT IN ARG BLOCK
+;TENTS ;NOT USED
+;TBS ; ""
+;TPLDS ; ""
+;TPC ; ""
+;TINFO ;POINTER TO LIST ELEMENT USED WITH ARG POINTERS
+;TNBS ;NOT USED
+;TBVLS ;NOT USED
+;TCSUBR ;CARE SUBR (USED ONLY WITH CUDDLE SEE -- WJL)
+;TWORD ;36-BIT WORD
+;TRSUBR ;COMPILED PROGRAM (ACTUALLY A VECTOR POINTER)
+;TCODE ;UNIFORM VECTOR OF INSTRUCTIONS
+;TCLIST ;NOT USED
+;TBITS ;GENERAL BYTE POINTER
+;TSTORA ;POINTER TO NON GC IMPURE STUFF
+;TPICTU ;E&S CODE IN NON GC SPACE
+;TSKIP ;ENVIRONMENT SPLICE
+;TLINK ;LEXICAL LINK
+;TINTH ;INTERRUPT HEADER
+;THAND ;INTERRUPT HANDLER
+;TLOCN ;LOCATIVE TO ASSOCIATION
+;TDECL ;POINTER TO LIST OF ATOMS AND TYPE DECLARATIONS
+;TDISMI ;TYPE MEANING DONT RUN REST OF HANDLERS
+;TDCLI ; INTERNAL TYPE FOR SAVED FUNCTION BODY
+;TMENT ; POINTER TO MAIN ENTRY OF WHICH THIS IS PART
+;TENTER ; NON-MAIN ENTRY TO AN RSUBR
+;TSPLICE ; RETURN FROM READ MACRO MEANS SPLICE SUBELEMENTS IN
+;TPCODE ; PURE CODE POINTER IN FUNNY FORMAT
+;TTYPEW : TYPE WORD
+;TTYPEC ; TYPE CODE
+;TGATOM ; ATOM WITH GVALUE
+;TREADA ; READ ACTIVATION HACK
+;TUNWIN ; INTERNAL FOR UNWIND SPEC ON STACK
+;TUBIND ; BINDING OF UNSPECIAL ATOM
+;TMACRO ; EVAL MACRO
+;TOFFS ; OFFSET FOR NTHING AND PUTTING
+\f
+; STORGE ALLOCATION TYPES. ALLOCATED BY AN "IRP" LATER IN THIS FILE
+
+
+;S1WORD ;UNMARKED STUFF OF NO INTEREST TO AGC
+;S2WORD ;POINTERS TO ELEMENTS IN PAIR SPACE (LIST, FORM, EXPR ETC.)
+;S2DEFR ;DEFERRED LIST VALUES
+;SNWORD ;POINTERS TO UNIFORM VECTORS
+;S2NWOR ;POINTERS TO GENERAL VECTORS
+;STPSTK ;STACK POINTERS
+;SPSTK ;UNMARKED STACK POINTERS
+;SARGS ;POINTERS TO ARG BLOCKS (USER)
+;SABASE ;POINTER TO ARG BLOCK (INTERNAL)
+;STBASE ;POINTER TO FRAME (INTERNAL)
+;SFRAME ;POINTER TO FRAME (USER)
+;SBYTE ;GENERAL BYTE POINTER
+;SATOM ;POINTER TO ATOM
+;SLOCID ;POINTER TO VALUE CELL OF ATOM
+;SPVP ;PROCESS VECTORS
+;SCHSTR ;ASCII BYTE POINTER
+;SASOC ;POINTER TO ASSOCIATION BLOCK
+;SINFO ;LIST CELL CONTAINING EXTRA ARGBLOCK INFO
+;SSTORE ;NON GC STORGAGE POINTER
+;SLOCA ;ARG BLOCK LOCATIVE
+;SLOCD ;USER VALUE CELL LOCATIVE
+;SLOCS ;LOCATIVE TO STRING
+;SLOCU ;LOCATIVE TO UVECTOR
+;SLOCV ;LOCATIVE TO GENERAL VECTOR
+;SLOCL ;LOCATIVE TO LIST ELEENT
+;SLOCN ;LOCATIVE TO ASSOCIATION
+;SGATOM ;REALLY ATOM BUT SPECIAL GC HACK
+;SOFFS ;OFFSET (SAT BECAUSE LIST IN LH, FIX IN RH)
+
+;NOTE: TO FIND OUT IF A GIVEN STORAGE ALLOCATION TYPE NEEDS TO BE DEFERRED, REFER TO
+;LOCATION "MKTBS:" OFFSET BY THE STORAGE TYPE. IF IT IS <0, THAT SAT NEEDS TO BE DEFERRED.
+;
+;ONE WAY TO DO THIS IS TO PUT A REAL TYPE CODE IN AC A AND PUHSJ P,NWORDT
+; A WILL CONTAIN 1 IF NO DEFERRED NEEDED OR 2 IF DEFER IS NEEDED
+
+\f; SOME MUDDLE DATA FORMATS
+
+; FORMAT OF LIST ELEMENT
+
+; WORD 1: SIGN BIT, RESERVED FOR GARBAGE COLLECTOR
+; BITS 1-17 TYPE OF FIRST ELEMENT OF LIST
+; BITS 18-35 POINTS TO REST OF LIST (ALWAYS ANOTHER LIST OR 0)
+;
+; WORD 2: DATUM OF FIRST ELEMENT OF LIST OF TYPE SPECIFIED
+;
+; IF DATUM REQUIRES 54 BITS TO SPECIFY, TYPE WILL BE "TDEFER" AND
+; VALUE WILL BE AN 18 BIT POINTER TO FULL 2 WORD PAIR
+
+
+
+;FORMAT OF GENERAL VECTOR (OF N ELEMENTS)
+;POINTED INTO BY AOBJN POINTER
+;A GENERAL VECTOR HAS FEWER THAN 2^16 ELEMENTS
+
+
+; TYPE<1> TYPE OF FIRST OBJECT (THE RIGHT HALF OF THE TYPE WORD MIGHT BE NONZERO)
+; OBJ<1> OBJECT OF SPECIFIED TYPE
+; TYPE<2>
+; OBJ<2>
+; .
+; .
+; .
+; TYPE<N>
+; OBJ<N>
+; VD(1)-VECTOR DOPE--SIGN-NOT UNIFORM, BITS 1-17 TYPE,,18-35 GROWTH/SHRINKAGE
+; VD(2)-VECTOR DOPE--SIGN-G.C.; BITS 1-17 ARE 2*N+1,,18-35 G.C. RELOCATION EITHER UP OR DOWN
+
+
+\f;SPECIAL VECTORS IN THE INITIAL SYSTEM
+
+;THE SYSTEM KEEPS RELEVANT INFORMATION CONCERNING ALL TYPES
+;IN A TYPE VECTOR, TYPVEC, WHICH MAY BE INDEXED BY THE TYPE NUMBER
+;FOUND IN THE TYPE FIELD OF ANY GOODIE. TABLES APLTYP AND EVLTYP ALSO EXIST
+;THEY SPECIFY HOW DIFFERENT TYPES EVAL AND APPLY.
+
+;TYPE IN AC A, PUSHJ P,SAT RETURNS STORAGE TYPE IN A
+
+;TYPE TO NAME OF TYPE TRANSLATION TABLE
+
+; TATOM,,<STORAGE ALLOCATION TYPE>+CHBIT+TMPLBT
+
+; ATOMIC NAME
+
+; CHBIT ON MEANS YOU CANT RANDOMLY CHTYPE INTO THIS TYPE
+; TMPLBT ON MEANS A TEMPLATE EXISTS DESCRIBING THIS
+
+;AN ATOM IS A BLOCK IN VECTOR SPACE WITH THE FOLLOWING FORMAT
+
+; <TUNBOU OR TLOCI>,,<0 OR BINDID> ; TLOCI MEANS VAL EXISTS.
+ ; 0 MEANS GLOBAL
+; ; BINDID SPECS ENV IN
+ ; WHICH LOCAL VAL EXISTS
+; <LOCATIVE TO VALUE OR 0>
+; <POINTER TO OBLIST OR 0>
+; <ASCII /PNAME/>
+; <400000+SATOM,,0>
+; <LNTH>,,0 (SIGN BIT FOR G.C. RH FOR G.C. RELOCATION)
+
+;POINTERS TO INITIAL STRUCTURES AND ATOMS NEEDED BY COMPILED CODE
+;WILL BE POINTED TO BY THE TRANSFER VECTOR
+;A POINTER TO THIS VECTOR ALWAYS EXISTS IN AC TVP
+;THE FORMAT OF THIS VECTOR IS:
+
+; TYPE,,0
+; VALUE
+; .
+; .
+; .
+; TV DOPE WORDS
+
+
+;INFORMATION CONCERNING EACH PROCESS IS KEPT IN THE PROCESS VECTOR
+;A POINTER TO THE CURRENT PROCESS ALWAYS EXISTS IN AC PVP
+;THE FORMAT OF A PROCESS VECTOR IS:
+
+; TFIX,,0
+; PROCID ;UNIQUE ID OF THIS PROCESS
+
+; 20 ELEMENTS (I.E. 40 WORDS) CONTAINIG SAVED ACS
+; CAN BE REFERENCED SYMBOLICALLY USING SYMBOLS
+; OF THE FORM AC!STO(PVP)
+
+; OTHER PROCESS LOCAL INFO LIKE LEXICAL STATE, PROCESS STATE,LAST RESUMER
+; .
+; .
+; .
+; PV DOPE WORDS
+
+
+
+
+;FORMAT OF PUSH DOWN STACKS USED AND CONVENTIONS
+
+\fIF1 [
+PRINTC /MUDDLE - INSERT FILE FOR ALL PROGRAMS
+/
+]
+
+IF2 [PRINTC /MUDDLE
+/
+]
+;AC ASSIGNMNETS
+
+P"=17 ;THE UNMARKED PDL POINTER (USED BY THE OUTSIDE WORLD AND MUDDLE)
+R"=16 ;REFERENCE BASE FOR RSUBRS
+M"=15 ;CODE BASE FOR RSUBRS
+SP"=10 ;SPECIAL PDL (USED BY MUDDLE FOR VARIABLE BINDINGS)(SPECIAL PDL IS PART OF TP)
+TP"=13 ;MARKED PDL (USED BY MUDDLE FOR ARGS TO FUNCTIONS
+ ;AND MARKED TEMPORARIES)
+TB"=12 ;MARKED PDL BASE POINTER AND CURRENT FRAME POINTER
+AB"=11 ;ARGUMENT PDL BASE (MARKED)
+ ;AB IS AN AOBJN POINTER TO THE ARGUMENTS
+FRM"=14 ;FUNNY FRAME POINTER
+TVP"=7 ;TRANSFER VECTOR POINTER
+PVP"=6 ;PROCESS VECTOR POINTER
+
+;THE FOLLOWING ACS ARE 'SCRATCH' FOR MUDDLE
+
+A"=1 ; A AND B CONTAIN TYPE AND VALUE UPON FUNCTION RETURNS
+B"=2
+C"=3
+D"=4
+E"=5
+
+NIL"=0 ;END OF LIST MARKER
+
+;MACRO TO DEFINE MAIN IF NOT DEFINED
+
+IF1 [
+DEFINE SYSQ
+ ITS==1
+; IFE <<<.AFNM1>_-24.>-<SIXBIT / T./>>,ITS==0
+ IFN ITS,[PRINTC /ITS VERSION
+/]
+ IFE ITS,[PRINTC /TENEX VERSION
+/]
+
+ TERMIN
+
+; SEGMENT INFO IF TOPS 20
+
+FSEG==1
+MAXSEG==30
+GCSEG==36 ; GC COPY SEGMENT
+STATM==40 ; STORED IN GC DUMP BYTE POINTER TO SAY
+ ; ITS AN ATOM (LH)
+DEFINE DEFMAI ARG,\D
+ D==.TYPE ARG
+ IFE <D-17>,ARG==0
+ EXPUNGE D
+ TERMIN
+]
+
+DEFMAI MAIN
+DEFMAI READER
+
+IF2,EXPUNGE DEFMAI
+
+\f;DEFINE TYPES AND $TYPES AND IF MAIN NOT 0, MAKE THE $TYPE WORDS
+
+
+IFN MAIN,NUMPRI==-1
+
+IF1 [
+NUMPRI==-1 ;NUMBER OF PRIMITIVE TYPES
+
+DEFINE TYPMAK SAT,LIST
+IRP A,,[LIST]
+NUMPRI==NUMPRI+1
+IRP B,,[A]
+T!B==NUMPRI
+.GLOBAL $!T!B
+IFN MAIN,[$!T!B=[T!B,,0]
+]
+.ISTOP
+TERMIN
+IFN MAIN,[
+RMT [ADDTYP SAT,A
+]]
+TERMIN
+TERMIN
+
+;MACRO TO ADD STUFF TO TYPE VECTOR
+
+IFN MAIN,[
+DEFINE ADDTYP SAT,TYPE,NAME,CHF,IMP,\CH
+ IFSE [CHF],CH==0
+ IFSN [CHF],CH==CHBIT
+ IFSE [NAME]IN,CH==CHBIT
+ TATOM,,CH+SAT
+ IFSN [NAME],[IFSE [NAME]IN,MQUOTE INTERNAL
+ IFSN [NAME]IN,[IFSE [IMP],MQUOTE [NAME]
+ IFSN [IMP],IMQUOTE [NAME]
+ ]
+ ]
+ IFSE [NAME],[IFSE [IMP],MQUOTE TYPE
+ IFSN [IMP],IMQUOTE TYPE
+ ]
+ TERMIN
+]
+]
+IF2 [IFE MAIN,[DEFINE TYPMAK SAT,LIST
+ RMT [EXPUN [LIST]
+]
+ TERMIN
+]
+]
+
+;DEFINE THE STORAGE ALLOCATION TYPES IN THE WORLD
+
+
+NUMSAT==0
+GENERAL==440000,,0 ;FLAG FOR BEING A GENERAL VECTOR
+.VECT.==40000
+
+IF1 [
+DEFINE PRMACR HACKER
+
+IRP A,,[1WORD,2WORD,2DEFRD,NWORD,2NWORD,TPSTK,PSTK,ARGS
+ABASE,TBASE,FRAME,BYTE,ATOM,LOCID,PVP,CHSTR,ASOC,INFO,STORE
+LOCA,LOCD,LOCS,LOCU,LOCV,LOCL,LOCN,GATOM,LOCR,LOCT,RDTB,LOCB
+DEFQ,OFFS]
+
+HACKER A
+
+TERMIN
+TERMIN
+
+
+
+DEFINE DEFINR B
+ NUMSAT==NUMSAT+1
+ S!B==NUMSAT
+ TERMIN
+]
+
+PRMACR DEFINR
+
+STMPLT==NUMSAT+1
+
+;MACRO FOR SAVING STUFF TO DO LATER
+
+.GSSET 4
+
+DEFINE HERE G00002,G00003
+G00002!G00003!TERMIN
+
+IF1 [
+DEFINE RMT A
+HERE [DEFINE HERE G00002,G00003
+G00002!][A!G00003!TERMIN]
+TERMIN
+]
+
+
+RMT [EXPUNGE GENERAL,NUMSTA
+]
+
+DEFINE XPUNGR A
+ EXPUNGE S!A
+ TERMIN
+
+IFE MAIN,[
+RMT [PRMACR XPUNGR
+]
+]
+
+C.BUF==1
+C.PRIN==2
+C.BIN==4
+C.OPN==10
+C.READ==40
+C.LAST==100
+C.INTL==200 ; INTERRUPT ON LINE FEEDS
+C.ASCII==400
+C.DISK==1000
+C.RAND==2000
+C.TTY==4000
+
+; FLAG INDICATING VECTOR FOR GCHACK
+
+.VECT.==40000
+
+; DEFINE SYMBLOS FOR VARIOUS OBLISTS
+
+SYSTEM==0 ;MAIN SYSTEM OBLIST
+ERRORS==1 ;ERROR COMMENT OBLIST
+INTRUP==2 ;INERRUPT OBLIST
+MUDDLE==3 ;MUDDLE GLOBAL SYMBOLS (ADDRESSES)
+
+RMT [EXPUNGE SYSTEM,ERRORS,INTRUP
+]
+; DEFINE SYMBOLS FOR PROCESS STATES
+
+RUNABL==1
+RESMBL==2
+RUNING==3
+DEAD==4
+BLOCKED==5
+
+IFE MAIN,[RMT [EXPUNGE RESMBL,RUNABL,RUNING,DEAD,BLOCKED
+]
+]\f;BUILD THE TYPE CODES AND ADD STUFF TO TYPVEC AND DEFINE $!TYPE)
+
+IFN MAIN,[RMT [SAVE==.
+ LOC TYPVLC
+ ]
+ ]
+
+
+TYPMAK S1WORD,[[LOSE],[FIX,,,1],[FLOAT,,,1],[CHRS,CHARACTER,,1],[ENTRY,IN],[SUBR,,1]]
+TYPMAK S1WORD,[[FSUBR,,1]]
+TYPMAK S1WORD,[[UNBOUND,,1],[BIND,IN],[ILLEGAL,,1],TIME]
+TYPMAK S2WORD,[[LIST,,,1],[FORM,,,1],[SEG,SEGMENT,,1],[EXPR,FUNCTION,,1]]
+TYPMAK S2WORD,[[FUNARG,CLOSURE]]
+TYPMAK SLOCL,[[LOCL,,,1]]
+TYPMAK S2WORD,[[FALSE,,,1]]
+TYPMAK S2DEFRD,[[DEFER,IN]]
+TYPMAK SNWORD,[[UVEC,UVECTOR,,1],[OBLS,OBLIST,1,1]]
+TYPMAK S2NWORD,[[VEC,VECTOR,,1],[CHAN,CHANNEL,1,1]]
+TYPMAK SLOCV,[[LOCV,,,1]]
+TYPMAK S2NWORD,[[TVP,IN],[BVL,IN],[TAG,,1]]
+TYPMAK SPVP,[[PVP,PROCESS]]
+TYPMAK STPSTK,[[LOCI,IN],[TP,IN],[SP,IN],[LOCS,IN]]
+TYPMAK S2WORD,[[MACRO]]
+TYPMAK SPSTK,[[PDL,IN]]
+TYPMAK SARGS,[[ARGS,TUPLE,1,1]]
+TYPMAK SABASE,[[AB,IN]]
+TYPMAK STBASE,[[TB,IN]]
+TYPMAK SFRAME,[[FRAME,,,1]]
+TYPMAK SCHSTR,[[CHSTR,STRING,,1]]
+TYPMAK SATOM,[[ATOM,,,1]]
+TYPMAK SLOCID,[[LOCD,,,1]]
+TYPMAK SBYTE,[[BYTE,BYTES]]
+TYPMAK SFRAME,[[ENV,ENVIRONMENT],[ACT,ACTIVATION,1,1]]
+TYPMAK SASOC,[ASOC]
+TYPMAK SLOCU,[[LOCU,,,1]]
+TYPMAK SLOCS,[[LOCS,,,1]]
+TYPMAK SLOCA,[[LOCA,,,1]]
+TYPMAK S1WORD,[[CBLK,IN]]
+TYPMAK STMPLT,[[TMPLT,TEMPLATE,1,1]]
+TYPMAK SLOCT,[[LOCT]]
+TYPMAK SLOCR,[[LOCR,,,1]]
+TYPMAK SINFO,[[INFO,IN]]
+TYPMAK S2NWORD,[[QRSUBR,QUICK-RSUBR,1],[QENT,QUICK-ENTRY,1]]
+TYPMAK SRDTB,[[RDTB,IN]]
+
+TYPMAK S1WORD,[[WORD,,,1]]
+TYPMAK S2NWORD,[[RSUBR,,,1]]
+TYPMAK SNWORD,[[CODE,,,1]]
+TYPMAK S1WORD,[[SATC,PRIMTYPE-C,1]]
+TYPMAK S1WORD,[[BITS]]
+TYPMAK SSTORE,[[STORAGE,,,1],PICTURE]
+TYPMAK STPSTK,[[SKIP,IN]]
+TYPMAK SATOM,[[LINK,,1]]
+TYPMAK S2NWORD,[[INTH,IHEADER,1],[HAND,HANDLER,1]]
+TYPMAK SLOCN,[[LOCN,LOCAS,,1]]
+TYPMAK S2WORD,[[DECL,,,1]]
+TYPMAK SATOM,[DISMISS]
+TYPMAK S2WORD,[[DCLI,IN]]
+TYPMAK S2NWORD,[[ENTER,RSUBR-ENTRY,1,1]]
+TYPMAK S2WORD,[SPLICE]
+TYPMAK S1WORD,[[PCODE,PCODE,1],[TYPEW,TYPE-W,1],[TYPEC,TYPE-C,1]]
+TYPMAK SGATOM,[[GATOM,IN]]
+TYPMAK SFRAME,[[READA,,1]]
+TYPMAK STBASE,[[UNWIN,IN]]
+TYPMAK S1WORD,[[UBIND,IN]]
+TYPMAK SLOCB,[LOCB]
+TYPMAK SDEFQ,[[DEFQ,IN]]
+TYPMAK SOFFS,[[OFFS,OFFSET]]
+IFN MAIN,[RMT [LOC SAVE
+ ]
+ ]
+IF2,EXPUNGE TYPMAK,DOTYPS
+\f
+RMT [EQUALS XP EXPUNGE
+IF2,XP STMPLT
+]
+IF1 [
+
+DEFINE EXPUN LIST
+ IRP A,,[LIST]
+ IRP B,,[A]
+ EXPUNGE T!B
+ .ISTOP
+ TERMIN
+ TERMIN
+ TERMIN
+]
+
+
+TYPMSK==17777
+MONMSK==TYPMSK#777777
+SATMSK==777
+CHBIT==1000
+TMPLBT==2000
+
+IF1 [
+DEFINE GETYP AC,ADR
+ LDB AC,[221500,,ADR]
+ TERMIN
+
+DEFINE PUTYP AC,ADR
+ DPB AC,[221500,,ADR]
+ TERMIN
+
+DEFINE GETYPF AC,ADR
+ LDB AC,[003700,,ADR]
+ TERMIN
+
+DEFINE MONITO
+ .WRMON==200000
+ .RDMON==100000
+ .EXMON== 40000
+ .GLOBAL .MONWR,.MONRD,.MONEX
+ RMT [IF2 IFE MAIN, XP .WRMON,.RDMON,.EXMON
+]
+ TERMIN
+]
+
+IFN MAIN,MONITO
+
+IFE MAIN,[RMT [XP SATMSK,TYPMSK,MONMSK,CHBIT
+]
+]
+\f;MUDDLE WIDE GLOBALS
+
+;DEFINE ENTRIES IN PROCESS VECTOR AS BEING GLOBAL
+
+IF1 [
+IRP A,,[0,A,B,C,D,E,PVP,TVP,TP,TB,AB,P,PB,SP,M,R,FRM]
+.GLOBAL A!STO
+TERMIN
+
+.GLOBAL CALER1,FINIS,VECTOP,VECBOT,INTFLG
+
+;GLOBALS FOR MACROS IN VECTOR AND PAIR SPACE
+
+.GLOBAL VECLOC,PARLOC,TVBASE,TVLOC,PVLOC,PVBASE,SQUTBL,SQULOC
+.GLOBAL PARTOP,CODTOP,HITOP,HIBOT,SPECBIND,LCKINT
+.GLOBAL GETWNA,WNA,TFA,TMA,WRONGT,WTYP,WTYP1,WTYP2,WTYP3,CALER,CALER1
+]
+
+
+;STORAGE ALLOCATIN SPECIFICATION GLOBALS
+
+NSUBRS==600. ; ESTIMATE OF # OF SUBRS IN WOLD
+TPLNT"==2000 ;TEMP PDL LENGTHH
+GSPLNT==2000 ;INITIAL GLOBAL SP
+GCPLNT"==100. ;GARBAGE COLLECTOR'S PDL LENGTH
+PVLNT"==100 ;LENGTH OF INITIAL PROCESS VECTOR
+TVLNT"==6000 ;MAX TRANSFER VECTOR
+ITPLNT"==100 ;TP FOR GC
+PLNT"==1000 ;PDL FOR USER PROCESS
+
+;LOCATIONS OF VARIOUS STORAGE AREAS
+
+PARBASE"==32000 ;START OF PAIR SPACE
+VECBASE"==44000 ;START OF VECTOR SPACE
+IFN MAIN,[PARLOC"==PARBASE
+VECLOC"==VECBASE
+]
+\f
+;INITIAL MACROS
+
+;SYMBLOS ASSOCIATED WITH STACK FRAMES
+;TB POINTS TO CURRENT FRAME, THE SYMBOLS BELOW ARE OFFSETS ON TB
+
+FRAMLN==7 ;LENGTH OF A FRAME
+FSAV==-7 ;POINT TO CALLED FUNCTION
+OTBSAV==-6 ;POINT TO PREVIOUS FRAME AND CONTAINS TIME
+ABSAV==-5 ;ARGUMENT POINTER
+SPSAV==-4 ;BINDING POINTER
+PSAV==-3 ;SAVED P-STACK
+TPSAV==-2 ;TOP OF STACK POINTER
+PCSAV==-1 ;PCWORD
+
+RMT [EXPUNGE FRAMLN
+]
+IFE MAIN,[RMT [EXPUNGE PCSAV TPSAV SPSAV PSAV ABSAV FSAV OTBSAV
+]
+]
+
+;CALL MACRO
+; ARGS ARE PUSHED ON THE STACK AS TYPE VALUE PAIRS
+
+.GLOBAL .MCALL,.ACALL,FINIS,CONTIN,.ECALL,FATINS,.ERRUU
+
+; CALL WITH AN ASSEMBLE TIME KNOWN NUMBER OF ARGUMENTS
+
+IF1 [
+DEFINE ERRUUO X
+ .ERRUU X
+ TERMIN
+
+DEFINE MCALL N,F
+ .GLOBAL F
+ IFGE <17-N>,.MCALL N,F
+ IFL <17-N>,[PRINTC /LOSSAGE AT MCALL - TOO MANY ARGS
+/
+ .MCALL F
+ ]
+ TERMIN
+
+; CALL WITH RUN TIME KNOWN NUMBER OF ARGS IN AC SPECIFIED BY N
+
+DEFINE ACALL N,F
+ .GLOBAL F
+ .ACALL N,F
+ TERMIN
+
+; STANDARD SUBROUTINE RETURN
+
+; JRST FINIS
+
+; ARGUMENTS WILL NO LONGER BE ON THE STACK WHEN RETURN HAS HAPPENED
+; VALUE SHOULD BE IN A AND B
+
+;CHECK THAT THE ENTRY POINT WAS CALLED WITH N ARGUMENTS
+
+DEFINE ENTRY N
+ IFSN N,,[
+ HLRZ A,AB
+ CAIE A,-2*N
+ JSP E,GETWNA]
+TERMIN
+\f
+
+; MACROS ASSOCIATED WIT INTERRUPT PROCESSING
+;INTERRUPT IF THERE IS A WAITING INTERRUPT
+
+DEFINE INTGO
+ SKIPGE INTFLG
+ JSR LCKINT
+TERMIN
+
+;TO BECOME INTERRUPTABLE
+
+DEFINE ENABLE
+ AOSN INTFLG
+ JSR LCKINT
+TERMIN
+
+;TO BECOME UNITERRUPTABLE
+
+DEFINE DISABLE
+ SETZM INTFLG
+TERMIN
+]
+\fIF1 [
+;MACRO TO BUILD TYPE DISPATCH TABLES EASILY
+
+DEFINE TBLDIS NAME,DEFAULT,LIST,LNTH,LH,\NN,FLG
+
+NN==0
+
+NAME:
+ REPEAT LNTH+1,[
+ FLG==0
+ IRP A,,[LIST]
+ IRP TYPE,LOCN,[A]
+ IFE <NN-TYPE>,[FLG==1
+ IFE LH,<LOCN>
+ IFN LH,<LH,,LOCN>
+]
+ .ISTOP
+ TERMIN
+ TERMIN
+ IFE FLG,[
+ IFE LH,<DEFAULT>
+ IFN LH,<LH,,DEFAULT>
+ ]
+ NN==NN+1
+] LOC NAME+LNTH+1
+TERMIN
+
+; DISPATCH FOR NUMPRI GOODIES
+
+DEFINE DISTBL NAME,DEFAULT,LIST
+ TBLDIS NAME,DEFAULT,[LIST]NUMPRI,0
+ TERMIN
+
+DEFINE DISTBS NAME,DEFAULT,LIST
+ TBLDIS NAME,DEFAULT,[LIST]NUMSAT,0
+ TERMIN
+
+DEFINE DISTB2 NAME,DEFAULT,LIST
+ TBLDIS NAME,DEFAULT,[LIST]NUMSAT,400000
+ TERMIN
+]
+\f
+
+VECFLG==0
+PARFLG==0
+
+;MACROS FOR INITIIAL MUDDLE LIST STRUCTURE
+
+;CHAR STRING MAKER, RETURNS POINTER AND TYPE
+
+IF1 [
+DEFINE MACHAR NAME,TYPE,VAL,\LNT,WHERE,LAST
+ TYPE==TCHSTR
+ VECTGO WHERE
+ LNT==.LENGTH \NAME!\
+ ASCII \NAME!\
+ LAST==$."
+ TCHRS,,0
+ $."-WHERE+1,,0
+ VAL==LNT,,WHERE
+ VECRET
+
+TERMIN
+;MACRO TO DEFINE ATOMS
+
+DEFINE MAKAT NAME,TYAT,VALU,OBLIS,REFER,LOCN,\TVENT,FIRST
+ FIRST==.
+ TYAT,,OBLIS
+ VALU
+ 0
+ ASCII \NAME!\
+ 400000+SATOM,,0
+ .-FIRST+1,,0
+ TVENT==FIRST-.+2,,FIRST
+ IFSN [LOCN],LOCN==TVENT
+ ADDTV TATOM,TVENT,REFER
+ TERMIN
+
+
+
+\f;MACROS TO SWITCH BACK AND FORTH INTO AND OUT OF VECTOR AND PAIR SPACE
+;GENERAL SWITCHER
+
+DEFINE LOCSET LOCN,RETNAM,NEWLOC,OTHLOC,F1,F2,TOPWRD,\SAVE,SAVEF1,SAVEF2,NEW
+
+ IFE F1,[SAVE==.
+ LOC NEWLOC
+ SAVEF2==F2
+ IFN F2,OTHLOC==SAVE
+ F2==0
+ DEFINE RETNAM
+ F1==F1-1
+ IFE F1,[NEWLOC==.
+ F2==SAVEF2
+ LOC TOPWRD
+ NEWLOC
+ LOC SAVE
+ ]
+ TERMIN
+ ]
+
+ IFN F1,[F1==F1+1
+ ]
+
+ IFSN LOCN,,LOCN==.
+ IFE F1,F1==1
+
+TERMIN
+
+
+DEFINE VECTGO LOCN
+ LOCSET LOCN,VECRET,VECLOC,PARLOC,VECFLG,PARFLG,VECTOP
+ TERMIN
+
+DEFINE PARGO LOCN
+ LOCSET LOCN,PARRET,PARLOC,VECLOC,PARFLG,VECFLG,PARTOP
+ TERMIN
+
+DEFINE ADDSQU NAME,\SAVE
+ SAVE==.
+ LOC SQULOC
+ SQUOZE 0,NAME
+ NAME
+ SQULOC==.
+ LOC SAVE
+ TERMIN
+
+DEFINE ADDTV TYPE,GOODIE,REFER,\SAVE
+ SAVE==.
+ LOC TVLOC
+ TVOFF==.-TVBASE+1
+ TYPE,,REFER
+ GOODIE
+ TVLOC==.
+ LOC SAVE
+ TERMIN
+
+;MACRO TO ADD TO PROCESS VECTOR
+
+DEFINE ADDPV TYPE,GOODIE,OFFS,\SAVE
+ SAVE==.
+ LOC PVLOC
+ PVOFF==.-PVBASE
+ IFSN OFFS,,OFFS==PVOFF
+ TYPE,,0
+ GOODIE
+ PVLOC==.
+ LOC SAVE
+ TERMIN
+
+
+
+
+\f
+;MACRO TO DEFINE A FUNCTION ATOM
+
+DEFINE MFUNCTION NAME,TYPE,PNAME
+ XMFUNCTION NAME,TYPE,PNAME,0
+ TERMIN
+
+DEFINE IMFUNCTION NAME,TYPE,PNAME
+ XMFUNCTION NAME,TYPE,PNAME,400000
+ TERMIN
+
+DEFINE XMFUNCTION NAME,TYPE,PNAME,IMP
+ (TVP)
+NAME":
+ VECTGO DUMMY1
+ ADDSQU NAME
+ IFSE [PNAME],MAKAT NAME,T!TYPE+IMP,NAME,SYSTEM,<NAME-1>
+ IFSN [PNAME],MAKAT [PNAME]T!TYPE+IMP,NAME,SYSTEM,<NAME-1>
+ VECRET
+ TERMIN
+
+; VERSION OF MQUOTE WITH IMPURE BIT ON
+
+DEFINE IMQUOTE ARG,PNAME,OBLIS,\LOCN
+ (TVP)
+
+ LOCN==.-1
+ VECTGO DUMMY1
+ IFSE [PNAME],MAKAT [ARG]<400000+TUNBOU>,0,OBLIS,LOCN
+
+ IFSN [PNAME],MAKAT [PNAME]<400000+TUNBOU>,0,OBLIS,LOCN
+ VECRET
+ TERMIN
+
+;MACRO TO DEFINE QUOTED GOODIE
+
+DEFINE MQUOTE ARG,PNAME,OBLIS,\LOCN
+ (TVP)
+
+ LOCN==.-1
+ VECTGO DUMMY1
+ IFSE [PNAME],MAKAT [ARG]TUNBOU,0,OBLIS,LOCN
+ IFSN [PNAME],MAKAT [PNAME]TUNBOU,0,OBLIS,LOCN
+ VECRET
+ TERMIN
+
+
+
+
+DEFINE CHQUOTE NAME,\LOCN,TYP,VAL
+ (TVP)
+ LOCN==.-1
+ MACHAR [NAME]TYP,VAL
+ ADDTV TYP,VAL,LOCN
+
+ TERMIN
+
+
+; SPECIAL ERROR MQUOTE
+
+DEFINE EQUOTE ARG,PNAME
+ MQUOTE ARG,[PNAME]ERRORS TERMIN
+
+
+; MACRO DO .CALL UUOS
+
+DEFINE DOTCAL NM,LIST,\LOCN
+ .CALL LOCN
+ RMT [LOCN==.
+ SETZ
+ SIXBIT /NM/
+ IRP Q,R,[LIST]
+ IFSN [R][][Q
+ ]
+
+ IFSE [R][][<SETZ>\<Q>
+ ]
+ TERMIN
+ ]
+TERMIN
+
+; MACRO TO HANDLE FATAL ERRORS
+
+DEFINE FATAL MSG/
+ FATINS [ASCIZ /:\e FATAL ERROR MSG \e\r/]
+ TERMIN
+]
+\f
+CHRWD==5
+
+IFN READER,[
+NCHARS==377
+;CHARACTER TABLE GENERATING MACROS
+
+DEFINE SETSYM WRDL,BYTL,COD
+ WRD!WRDL==<WRD!WRDL>&<MSK!BYTL>
+ WRD!WRDL==<WRD!WRDL>\<<COD&177>_<<4-BYTL>*7+1>>
+ TERMIN
+
+DEFINE INIWRD N,INIT
+ WRD!N==INIT
+ TERMIN
+
+DEFINE OUTWRD N
+ WRD!N
+ TERMIN
+
+;MACRO TO KILL THESE SYMBOLS LATER
+
+DEFINE KILLWD N
+ EXPUNGE WRD!N
+ TERMIN
+DEFINE SETMSK N
+ MSK!N==<177_<<4-N>*7+1>>#<-1>
+ TERMIN
+
+;MACRO TO KILL MASKS LATER
+
+DEFINE KILMSK N
+ EXPUNGE MSK!N
+ TERMIN
+
+NWRDS==<NCHARS+CHRWD-1>/CHRWD
+
+REPEAT CHRWD,SETMSK \.RPCNT
+
+REPEAT NWRDS,INIWRD \.RPCNT,004020100402
+
+DEFINE OUTTBL
+ REPEAT NWRDS,OUTWRD \.RPCNT
+ TERMIN
+
+
+;MACRO TO GENERATE THE DUMMIES EASLILIER
+
+DEFINE INITCH \DUM1,DUM2,DUM3
+
+
+DEFINE SETCOD COD,LIST
+ IRP CHAR,,[LIST]
+ DUM1==<CHAR+CHROFF>/5
+ DUM2==CHROFF+CHAR-DUM1*5
+ SETSYM \DUM1,\DUM2,COD
+ IFE CHROFF,[DUM1==<CHAR+200>/5
+ DUM2==<CHAR+200-<DUM1*5>>
+ SETSYM \DUM1,\DUM2,COD
+ ]
+ TERMIN
+ TERMIN
+
+DEFINE SETCHR COD,LIST
+ IRPC CHAR,,[LIST]
+ DUM3==<"CHAR>+CHROFF
+ DUM1==DUM3/5
+ DUM2==DUM3-DUM1*5
+ SETSYM \DUM1,\DUM2,COD
+ IFE CHROFF,[DUM3==DUM3+200
+ DUM1==DUM3/5
+ DUM2==DUM3-DUM1*5
+ SETSYM \DUM1,\DUM2,COD
+ ]
+ TERMIN
+ TERMIN
+
+DEFINE INCRCO OCOD,LIST
+ IRP CHAR,,[LIST]
+ DUM1==<CHAR+CHROFF>/5
+ DUM2==CHROFF+CHAR-DUM1*5
+ SETSYM \DUM1,\DUM2,\<OCOD+.IRPCN>
+ IFE CHROFF,[DUM1==<CHAR+200>/5
+ DUM2==<CHAR+200-<DUM1*5>>
+ SETSYM \DUM1,\DUM2,<OCOD.IRPCN>
+ ]
+ TERMIN
+ TERMIN
+
+DEFINE INCRCH OCOD,LIST
+ IRPC CHAR,,[LIST]
+ DUM3==<"CHAR>+CHROFF
+ DUM1==DUM3/5
+ DUM2==DUM3-DUM1*5
+ SETSYM \DUM1,\DUM2,\<OCOD+.IRPCN>
+ IFE CHROFF,[DUM3==DUM3+200
+ DUM1==DUM3/5
+ DUM2==DUM3-DUM1*5
+ SETSYM \DUM1,\DUM2,<OCOD+.IRPCN>
+ ]
+ TERMIN
+ TERMIN
+ RMT [EXPUNGE DUM1,DUM2,DUM3
+ REPEAT NWRDS,KILLWD \.RPCNT
+ REPEAT CHRWD,KILMSK \.RPCNT
+]
+
+TERMIN
+
+INITCH
+]
+\f
+;REDEFINE END DO ALL THE REMOTES (ON LAST PASS ONLY)
+
+EQUALS E.END END
+EXPUNG END
+
+DEFINE END ARG
+ EQUALS END E.END
+ CONSTANTS
+
+ IMPURE
+ VARIABLES
+ PURE
+ HERE
+ .LNKOT
+ IF2 GEXPUN
+ CONSTANTS
+ IMPURE
+ VARIABLES
+ CODEND==.
+ LOC CODTOP
+ CODEND
+ LOC CODEND
+ PURE
+ CODEND==.
+ LOC HITOP
+ CODEND
+ LOC CODEND
+ IF2 EXPUNGE PARFLG,VECFLG,CHRWD,NN,NUMPRI,PURITY,EAD,ACD,PUSHED
+ IF2 EXPUNGE INSTNT,DUMMY1,PRIM,PPLNT,GSPLNT,MEDIAT
+ END ARG
+ TERMIN
+
+
+;MACROS TO PRINT VERSIONS OF PROGRAMS DURING ASSEMBLY
+
+IF1 [
+DEFINE NUMGEN SYM,\REST,N
+ NN==NN-1
+ N==<SYM_-30.>&77
+ REST==<SYM_6>
+ IFN N,IFGE <31-N>,IFGE <N-20>,TOTAL==TOTAL*10.+<N-20>
+ IFN NN,NUMGEN REST
+ EXPUNGE N,REST
+ TERMIN
+
+DEFINE VERSIO N
+ PRINTC /VERSION = N
+/
+ TERMIN
+]
+
+TOTAL==0
+NN==7
+
+NUMGEN .FNAM2
+
+IF1 [
+RADIX 10.
+
+VERSIO \TOTAL
+
+RADIX 8
+PROGVN==TOTAL
+
+
+DEFINE VATOM SYM,\LOCN,TV,A,B
+ VECTGO
+ LOCN==.
+ TFIX,,MUDDLE
+ PROGVN
+ 0
+ A==<<<<SYM_-30.>&77>+40>_29.>
+ B==<<SYM_-24.>&77>
+ IFN B,A==A+<<B+40>_22.>
+ B==<<SYM_-18.>&77>
+ IFN B,A==A+<<B+40>_15.>
+ B==<<SYM_-12.>&77>
+ IFN B,A==A+<<B+40>_8.>
+ B==<<SYM_-6.>&77>
+ IFN B,A==A+<<B+40>_1.>
+ A
+ IFN <SYM&77>,<<SYM&77>+40>_29.
+ 400000+SATOM,,
+ .-LOCN+1,,0
+ TV==LOCN-.+2,,LOCN
+ ADDTV TATOM,TV,0
+ VECRET
+ TERMIN
+
+;VATOM .FNAM1 ;"HACK REMOVED FOR EFFICIENCY"
+
+
+;MACRO TO REMMVE SYMBOLS OF THE FORM "GXXXXX"
+
+DEFINE GEXPUN \SYM
+ NN==7
+ TOTAL==0
+ NUMGEN \<SIXBIT /SYM!/>
+ RADIX 10.
+ .GSSET 0
+ REPEAT TOTAL,XXP
+ RADIX 8
+TERMIN
+
+DEFINE XXP \A
+ EXPUNGE A
+ TERMIN
+
+
+DEFINE ..LOC NEW,OLD
+ .LIFS .LPUR"+.LIMPU"
+ OLD!"==$."
+ LOC NEW!"
+ .ELDC
+ .LIFS -.LPUR"
+ LOC $."
+ .ELDC
+ .LIFS -.LIMPU
+ LOC $."
+ .ELDC
+ TERMIN
+
+
+; PURE - MACRO TO SWITCH LOADING TO PURE CORE.
+
+DEFINE PURE
+ IFE PURITY-1, ..LOC .LPUR,.LIMPU
+ PURITY==0
+ TERMIN
+
+; IMPURE - MACRO TO SWITCH LOADING TO IMPURE CORE.
+
+DEFINE IMPURE
+ IFE PURITY, ..LOC .LIMPU,.LPUR
+ PURITY==1
+ TERMIN
+]
+PURITY==0
+; BLOCK MACRO
+
+DEFINE SPBLOK N
+ OFFSET 0
+ LOC .+N
+ OFFSET OFFS
+ TERMIN
+
--- /dev/null
+TITLE READCH TELETYPE DEVICE HANDLER FOR MUDDLE
+
+RELOCATABLE
+
+.INSRT MUDDLE >
+
+SYSQ
+
+IF1,[
+IFE ITS,.INSRT STENEX >
+]
+
+.GLOBAL BUFRIN,CHRCNT,SYSCHR,ECHO,BYTPTR,ERASCH,KILLCH,BRKCH,AGC,CHRWRD,W1CHAR,GWB
+.GLOBAL IOIN2,READC,WRONGC,BRFCHR,ESCAP,TTYOPE,MTYI,MTYO,IMTYO,INMTYO,NOTTY,DEMFLG,TTYOP2,OPSYS
+.GLOBAL IBLOCK,PVSTOR,SPSTOR
+.GLOBAL RRESET,TTICHN,TTOCHN,CHANNO,STATUS,BRFCH2,TTYBLK,TTYUNB,WAITNS
+.GLOBAL EXBUFR,INCHAR,BYTDOP,BUFSTR,LSTCH,CHNCNT,DIRECT,IOINS,IBLOCK,INCONS
+.GLOBAL BADCHN,WRONGD,CHNLOS,MODE1,MODE2,GMTYO,IDVAL,GETCHR,PAGLN,LINLN
+.GLOBAL RDEVIC,DEMFLG,READ,MAKACT,CITOP,MPOPJ,CIMAGE,GTLPOS,LINPOS
+.GLOBAL NTTYPE,CLRSTR
+
+TTYOUT==1
+TTYIN==2
+
+; FLAGS CONCERNING TTY CHANNEL STATE
+
+N.ECHO==1 ; NO INPUT ECHO
+N.CNTL==2 ; NO RUBOUT ^L ^D ECHO
+N.IMED==4 ; ALL CHARS WAKE UP
+N.IME1==10 ; SOON WILL BE N.IMED
+CNTLPC==20 ; USE ^P CODE MODE IOT
+N.ESC==40
+
+; OPEN BLOCK MODE BITS
+OUT==1
+IMAGEM==4
+ASCIIM==0
+UNIT==0
+
+IFE ITS,[
+
+DP%AG1==200000,,0
+DP%AG2==100000,,0
+
+TC%MOV==400000,,0
+TC%CLR==40000,,0
+
+.VTUP==3
+.VTMOV==7
+.VTCLR==15
+.VTCEL==17
+.VTBEC==21
+]
+
+; READC IS CALLED BY PUSHJ P,READC
+; B POINTS TO A TTY FLAVOR CHANNEL
+; ONE CHARACTER IS RETURNED IN A
+; BECOMES INTERRUPTABLE IF NO CHARACTERS EXISTS
+
+; HERE TO ASK SYSTEM FOR SOME CHARACTERS
+
+INCHAR: IRP A,,[0,C,D,E] ;SAVE ACS
+ PUSH P,A
+ TERMIN
+ MOVE E,BUFRIN(B) ; GET AUX BUFFER
+ MOVE D,BYTPTR(E)
+ HLRE 0,E ;FIND END OF BUFFER
+ SUBM E,0
+ ANDI 0,-1 ;ISOLATE RH
+ MOVE C,SYSCHR(E) ; GET FLAGS
+
+INCHR1: TRNE C,N.IMED+N.CNTL ; SKIP IF NOT IMMEDIATE
+ JRST DONE
+ LDB C,D ; GET PREV CHAR
+ CAMN C,ESCAP(E) ; SKIP IF NOT ESCAPED
+ JRST INCHR2 ; ESCAPED
+ CAMN A,BRFCH2(E)
+ JRST BRF
+ CAMN A,BRFCHR(E) ;BUFFER PRINT CHAR
+ JRST CLEARQ ;MAYBE CLEAR SCREEN
+ CAMN A,BRKCH(E) ;IS THIS A BREAK?
+ JRST DONE ;YES, DONE
+ CAMN A,ERASCH(E) ;ARE IS IT ERASE?
+ JRST ERASE ;YES, GO PROCESS
+ CAMN A,KILLCH(E) ;OR KILL
+ JRST KILL
+
+INCHR2: PUSHJ P,PUTCHR ;PUT ACHAR IN BUFFER
+INCHR3: MOVEM D,BYTPTR(E)
+ JRST DONE1
+
+DONE: SKIPL A ; IF JUST BUFFER FORCE, SKIP
+ PUSHJ P,PUTCHR ; STORE CHAR
+ MOVEI A,N.IMED ; TURN OFF IMEDIACY
+ ANDCAM A,SYSCHR(E)
+ MOVEM D,BYTPTR(E)
+ PUSH TP,$TCHAN ; SAVE CHANNEL
+ PUSH TP,B
+ MOVE A,CHRCNT(E) ; GET # OF CHARS
+ SETZM CHRCNT(E)
+ PUSH P,A
+ ADDI A,4 ; ROUND UP
+ IDIVI A,5 ; AND DOWN
+ PUSHJ P,IBLOCK ; GET CORE
+ HLRE A,B ; FIND D.W.
+ SUBM B,A
+ MOVSI 0,TCHRS+.VECT. ; GET TYPE
+ MOVEM 0,(A) ; AND STORE
+ MOVEI D,-1(B) ; COPY PNTR
+ MOVE C,(P) ; CHAR COUNT
+ HRLI D,010700
+ HRLI C,TCHSTR
+ PUSH TP,$TUVEC
+ PUSH TP,B
+ PUSHJ P,INCONS ; CONS IT ON
+ MOVE C,-2(TP) ; GET CHAN BACK
+ MOVEI D,EXBUFR(C) ; POINT TO BUFFER LIST
+ HRRZ 0,(D) ; LAST?
+ JUMPE 0,.+3
+ MOVE D,0
+ JRST .-3 ; GO UNTIL END
+ HRRM B,(D) ; SPLICE
+
+; HERE TO BLT IN BUFFER
+
+ MOVE D,BUFRIN(C) ; POINT TO COMPLETED BUFFER
+ HRRZ C,(TP) ; START OF NEW STRING
+ HRLI C,BYTPTR+1(D) ; 1ST WORD OF CHARS
+ MOVE E,[010700,,BYTPTR(E)]
+ EXCH E,BYTPTR(D) ; END OF STRING
+ MOVEI E,-BYTPTR(E)
+ ADD E,(TP) ; ADD TO START
+ BLT C,-1(E)
+ MOVE B,-2(TP) ; CHANNEL BACK
+ POP P,C
+ SOJG C,.+3
+ MOVE E,BUFRIN(B)
+ SETZM BYTPTR+1(E)
+ SUB TP,[4,,4] ; FLUSH JUNK
+ PUSHJ P,TTYUNB ; UNBLOCK THIS TTY
+DONE1: IRP A,,[E,D,C,0]
+ POP P,A
+ TERMIN
+ POPJ P,
+\f
+; HERE TO ERASE A CHARACTER
+
+BARFC1: PUSHJ P,RUBALT ; CAN WE RUBOUT AN ALTMODE?
+ JRST BARFCR ; NO, C.R.
+ JRST ERASAL
+
+ERASE: SKIPN CHRCNT(E) ;ANYTHING IN BUFFER?
+ JRST BARFC1 ;NO, MAYBE TYPE CR
+
+ERASAL: SOS CHRCNT(E) ;DELETE FROM COUNT
+ LDB A,D ;RE-GOBBLE LAST CHAR
+IFN ITS,[
+ LDB C,[600,,STATUS(B)] ; CHECK FOR DISPLAY
+ CAIE C,2 ; SKIP IF IT IS
+]
+IFE ITS,[
+ HLRE C,STATUS(B) ; CONTAINS RESULT OF GTTYP
+ SKIPN DELSTR(C) ; INTERESTING DELETION METHOD?
+]
+ JUMPGE C,TYPCHR ; DELETE BY ECHOING DELETED CHAR
+ SKIPN ECHO(E) ; SKIP IF ECHOABLE
+ JRST NECHO
+ PUSHJ P,CHRTYP ; FOUND OUT DISPLAY BEHAVIOR
+ SKIPGE C,FIXIM2(C) ; METHOD OF FLUSHING THIS CHARACTER
+ JRST (C) ; DISPATCH TO FUNNY ONES
+
+NOTFUN: PUSHJ P,DELCHR ; DELETE ONE CHARACTER
+ SOJG C,.-1 ; AND LOOP UNTIL GOT THEM ALL
+
+; REJOINS HERE TO UPDATE BUFFER POINTER, ETC.
+NECHO: ADD D,[70000,,0] ;DECREMENT BYTE POINTER
+ JUMPGE D,INCHR3 ;AND GO ON, UNLESS BYTE POINTER LOST
+ SUB D,[430000,,1] ;FIX UP BYTE POINTER
+ JRST INCHR3
+\f
+; RUB OUT A CHARACTER BY ECHOING IT (NON-DISPLAYS)
+TYPCHR: SKIPE C,ECHO(E)
+ XCT C
+ JRST NECHO
+
+; SPECIAL HACKS FOR RUBBING OUT ON DISPLAYS
+
+; RUB OUT A LINE FEED
+LFKILL: PUSHJ P,LNSTRV
+ JRST NECHO
+
+LNSTRV: PUSH P,0 ; STORE USEFUL DATA
+IFN ITS,[
+ TLO 0,CNTLPC ; SWITCH ON TEMPORARY ^P MODE
+ MOVEI A,20 ; ^P
+ XCT ECHO(E)
+ MOVEI A,"U ; U , MOVE UP ONE LINE
+ XCT ECHO(E)
+]
+IFE ITS,[
+ PUSH P,B
+ MOVE B,TTOCHN+1
+ HLRE A,STATUS(B) ; terminal type
+ JUMPGE A,UPCRF
+ MOVE A,1(B) ; DISPLAY IN VTS MODE
+ MOVEI B,.VTUP
+ VTSOP
+ JRST UPCXIT
+UPCRF: PUSHJ P,GETPOS ; HERE FOR DISPLAY STUFF IN IMAGE MODE
+ SOS LINPOS(B)
+ PUSHJ P,SETPOS
+UPCXIT: POP P,B
+]
+ POP P,0 ; RESTORE USEFUL DATA
+ POPJ P,
+
+; RUB OUT A BACK SPACE
+BSKILL: PUSHJ P,GETPOS ; CURRENT POSITION TO A
+ PUSHJ P,SETPOS ; POSITION DISPLAY CURSOR
+ PUSH P,0 ; STORE USEFUL DATA
+IFN ITS,[
+ TLO 0,CNTLPC ; SWITCH ON TEMPORARY ^P MODE
+ MOVEI A,20 ; ^P
+ XCT ECHO(E)
+ MOVEI A,"L ; L , DELETE TO END OF LINE
+ XCT ECHO(E)
+]
+IFE ITS,[
+ HLRE A,STATUS(B)
+ JUMPGE A,CLECRF
+ PUSH P,B
+ MOVE A,1(B)
+ MOVEI B,.VTCEL
+ VTSOP
+ POP P,B
+ JRST CLEXIT
+
+CLECRF: MOVEI 0,EOLSTR(A)
+ PUSHJ P,STBOUT
+]
+CLEXIT: POP P,0 ; RESTORE USEFUL DATA
+ JRST NECHO
+
+; RUB OUT A TAB
+TBKILL: PUSHJ P,GETPOS
+ ANDI A,7
+ SUBI A,10 ; A -NUMBER OF DELS TO DO
+ PUSH P,A
+ PUSHJ P,DELCHR
+ AOSE (P)
+ JRST .-2
+ SUB P,[1,,1]
+ JRST NECHO
+
+; ROUTINE TO DEL CHAR ON DISPLAY
+DELCHR: PUSH P,0 ; STORE USEFUL DATA
+IFN ITS,[
+ TLO 0,CNTLPC ; SWITCH ON TEMPORARY ^P MODE
+ MOVEI A,20
+ XCT ECHO(E)
+ MOVEI A,"X
+ XCT ECHO(E)
+]
+IFE ITS,[
+ HLRE A,STATUS(B)
+ JUMPGE A,DELCRF
+ PUSH P,B
+ MOVE A,1(B)
+ MOVEI B,.VTBEC ;BACKSPACE AND ERASE
+ VTSOP
+ POP P,B
+ JRST DELXIT
+DELCRF: MOVEI 0,DELSTR(A)
+ PUSHJ P,STBOUT
+]
+DELXIT: POP P,0 ;RESTORE USEFUL DATA
+ POPJ P,
+
+; DELETE FOUR-CHARACTER LOSSAGES
+FOURQ: PUSH P,CNOTFU
+FOURQ2: MOVEI C,2 ; FOR ^Z AND ^_
+ CAMN B,TTICHN+1 ; SKIP IF NOT CONSOLE TTY
+ MOVEI C,4
+CNOTFU: POPJ P,NOTFUN
+
+; HERE IF KILLING A C.R., RE-POSITION CURSOR
+CRKILL: PUSHJ P,GETPOS ; COMPUTE LINE POS
+ PUSHJ P,SETPOS
+ JRST NECHO
+\f
+; HERE TO SET CURRENT CURSOR POSITION, USUALLY TO END OF LINE
+; A/ POSITION TO GO TO
+SETPOS: PUSH P,0 ; STORE USEFUL DATA
+IFN ITS,[
+ TLO 0,CNTLPC ; SWITCH ON TEMPORARY ^P MODE
+ PUSH P,A ; SAVE POS
+ MOVEI A,20
+ XCT ECHO(E)
+ MOVEI A,"H
+ XCT ECHO(E)
+ POP P,A
+ ADDI A,10 ; MINIMUM CURSOR POS
+ XCT ECHO(E) ; HORIZ POSIT AT END OF LINE
+]
+IFE ITS,[
+ HLRE 0,STATUS(B)
+ JUMPGE ABPCRF
+
+ PUSH P,B ; VTS ABSOLUTE POSITIONING
+ PUSH P,C
+ PUSH P,A
+ PUSHJ P,GTLPOS
+ HRL C,A ; LINE NUMBER
+ POP P,A
+ HRR C,A ; COLUMN NUMBER
+ MOVE A,1(B)
+ MOVEI B,.VTMOV
+ HRLI B,(DP%AG1+DP%AG2)
+ VTSOP
+ POP P,C
+ POP P,B
+ JRST ABPXIT
+
+ABPCRF: ADD 0,[SETZ POSTAB]
+ XCT @0 ; ROUTINES FOR ABSOLUTE POSITIONING (UGH)
+]
+ABPXIT: POP P,0 ; RESTORE USEFUL DATA
+ POPJ P,
+
+; HERE TO CALCULATE CURRENT CURSOR POSITION
+; RETURNS A/ CURSOR POS (CORRESPONDS TO EOL, TOO)
+GETPOS: PUSH P,0
+ MOVEI 0,0 ; COUNT OF CHARACTER POSITIONS
+ PUSH P,[010700,,BYTPTR(E)] ; POINT TO BUFFER
+ PUSH P,CHRCNT(E) ; NUMBER THEREOF
+
+GETPO1: SOSGE (P) ; COUNT DOWN
+ JRST GETPO2
+ ILDB A,-1(P) ; CHAR FROM BUFFER
+ CAIN A,15 ; SKIP IF NOT CR
+ MOVEI 0,0 ; C.R., RESET COUNT
+ PUSHJ P,CHRTYP ; GET TYPE
+ XCT FIXIM3(C) ; GET FIXED COUNT
+ ADD 0,C
+ JRST GETPO1
+
+GETPO2: MOVE A,0 ; RET COUNT
+ MOVE 0,-2(P) ; RESTORE AC 0
+ SUB P,[3,,3]
+ POPJ P,
+
+; FIGURE OUT HOW MANY CHARACTER POSITIONS A CHARACTER TAKES
+CHRTYP: MOVEI C,0 ; NUMBER OF FLUSHEES
+ CAILE A,37 ; SKIP IF CONTROL CHAR
+ POPJ P,
+ PUSH TP,$TCHAN
+ PUSH TP,B ; SAVE CHAN
+ IDIVI A,12. ; FIND SPECIAL HACKS
+ MOVE A,FIXIML(A) ; GET CONT WORD
+ IMULI B,3
+ ROTC A,3(B) ; GET CODE IN B
+ ANDI B,7
+ MOVEI C,(B)
+ MOVE B,(TP) ; RESTORE CHAN
+ SUB TP,[2,,2]
+ POPJ P,
+
+; TABLE OF HOW MANY OR HOW TO FIND OUT
+FIXIM2: 1
+ 2
+ SETZ FOURQ
+ SETZ CRKILL
+ SETZ LFKILL
+ SETZ BSKILL
+ SETZ TBKILL
+
+; TABLE OF WHAT TO ADD TO HPOS ON ENCOUNTERING CHARACTER
+FIXIM3: MOVEI C,1
+ MOVEI C,2
+ PUSHJ P,FOURQ2
+ MOVEI C,0
+ MOVEI C,0
+ MOVNI C,1
+ PUSHJ P,CNTTAB
+
+; HORRIBLE KLUDGE TO COUNT SPACES FOR A TAB
+CNTTAB: ANDCMI 0,7 ; GET COUNT INCUDING TAB HACK
+ ADDI 0,10
+ MOVEI C,0
+ POPJ P,
+
+; TYPE TABLE FOR EACH CONTROL CHARACTER
+FIXIML: 111111,,115641 ; CNTL @ABCDE,,FGHIJK
+ 131111,,111111 ; LMNOPQ,,RSTUVW
+ 112011,,120000 ; XYZ LBRAK \ RBRAK,,^ _
+\f
+; HERE TO KILL THE WHOLE BUFFER
+
+KILL: PUSHJ P,RUBALT ; COULD WE RUB OUT ALT MODE
+ JFCL
+ CLEARM CHRCNT(E) ;NONE LEFT NOW
+ MOVE D,[010700,,BYTPTR(E)] ;RESET POINTER
+
+BARFCR:
+IFN ITS,[
+ MOVE A,ERASCH(E) ;GET THE ERASE CHAR
+ CAIN A,177 ;IS IT RUBOUT?
+]
+ PUSHJ P,CRLF1 ; PRINT CR-LF
+ JRST INCHR3
+
+; SKIP IF CAN RUB OUT AN ALTMODE
+RUBALT: PUSH TP,$TCHAN
+ PUSH TP,B
+ HRRZ A,FSAV(TB) ; ARE WE IN READ ?
+ CAIE A,READ
+ JRST RUBAL1
+ MOVEI A,(TP)
+ SUBI A,(TB)
+IFN ITS,CAIG A,53 ; SOMEWHAT HEURISTIC (WATCH OUT IN NEW VERSIONS!!!!!!)
+IFE ITS,CAIG A,17
+ JRST RUBAL1
+ HRRZ A,BUFSTR-1(B) ; IS BUFFER OF SAME RUN OUT?
+ JUMPN A,RUBAL1 ; NO
+ MOVE B,IMQUOTE INCHAN
+ PUSHJ P,IDVAL ; REALLY CHECK IT OUT
+ MOVE C,(TP)
+ CAME C,B
+ JRST RUBAL1
+ MOVE A,BUFSTR-1(B)
+ MOVE B,BUFSTR(B)
+ PUSHJ P,CITOP
+ ANDI A,-1
+ MOVE D,[10700,,BYTPTR(E)]
+ MOVE E,(TP)
+ MOVE E,BUFRIN(E)
+ MOVEM A,CHRCNT(E)
+; CHECK WINNAGE OF BUFFER
+ ILDB 0,D
+ ILDB C,B
+ CAIE 0,(C)
+ JRST RUBAL1
+ SOJG A,.-4
+ MOVE B,(TP)
+ MOVEM D,BYTPTR(E)
+ MOVE A,[JRST RETREA]
+ MOVEM A,WAITNS(B)
+ AOS (P)
+ SUB TP,[2,,2]
+ POPJ P,
+
+RUBAL1: MOVE B,(TP)
+ MOVE D,[010700,,BYTPTR(E)]
+ SETZM CHRCNT(E)
+ SUB TP,[2,,2]
+ POPJ P,
+
+RETREA: PUSHJ P,MAKACT
+ HRLI A,TFRAME
+ PUSH TP,A
+ PUSH TP,B
+ MCALL 1,RETRY
+ JRST TTYBLK
+\f
+; HERE TO CLEAR SCREEN AND RETYPE BUFFER
+
+CLEARQ:
+IFN ITS,[
+ MOVE A,STATUS(B) ; FIGURE OUT CONSOLE TYPE
+ ANDI A,77
+ CAIN A,2 ; DISPLAY?
+]
+IFE ITS,[
+ HLRE A,STATUS(B)
+ SKIPE CLRSTR(A) ; TRY IT ONLY ON DISPLAYS
+]
+ PUSHJ P,CLR ; CLEAR SCREEN
+
+; HERE TO RETYPE BUFFER
+
+BRF: MOVE C,[010700,,BYTPTR(E)] ;POINT TO START OF BUFFER
+ SKIPN ECHO(E) ;ANY ECHO INS?
+ JRST NECHO
+IFE ITS,PUSH P,B
+ MOVE B,TTOCHN+1
+ PUSHJ P,CRLF2
+IFE ITS,AOS LINPOS(B)
+ PUSH P,CHRCNT(E)
+BRF1: SOSGE (P)
+ JRST DECHO
+ ILDB A,C ;GOBBLE CHAR
+ XCT ECHO(E) ;ECHO IT
+IFE ITS,[
+ CAIN A,12
+ AOS LINPOS(B)
+]
+ JRST BRF1 ;DO FOR ENTIRE BUFFER
+
+DECHO: SUB P,[1,,1]
+IFE ITS,POP P,B
+ JRST INCHR3
+
+; ROUTINE TO CRLF ON ANY TTY
+
+CRLF1: SKIPN ECHO(E)
+ POPJ P, ; NO ECHO INS
+CRLF2: MOVEI A,15
+ XCT ECHO(E)
+ MOVEI A,12
+ XCT ECHO(E)
+ POPJ P,
+
+; CLEAR SCREEN
+CLR: SKIPN C,ECHO(E) ;ONLY IF INS EXISTS
+ POPJ P,
+ PUSH P,0
+IFN ITS,[
+ TLO 0,CNTLPC ;SWITCH ON TEMPORARY ^P MODE
+ MOVEI A,20 ;ERASE SCREEN
+ XCT C
+ MOVEI A,103
+ XCT C
+]
+IFE ITS,[
+ JUMPGE A,CLRCRF
+ PUSH P,B
+ MOVE A,1(B)
+ MOVEI B,.VTCLR
+ VTSOP
+ POP P,B
+ JRST CLRXIT
+
+CLRCRF: MOVEI 0,CLRSTR(A)
+ PUSHJ P,STBOUT
+ PUSH P,B
+ MOVE B,TTOCHN+1
+ SETZM LINPOS(B)
+ POP P,B
+]
+CLRXIT: POP P,0 ;RESTORE USEFUL DATA
+ POPJ P,
+
+IFE ITS,[
+
+STBOUT: PUSH P,B
+ SKIPE IMAGFL
+ JRST STBOU1
+ MOVE A,1(B)
+ HRRZ B,STATUS(B)
+ TRZ B,300
+ SFMOD
+STBOU1: HRLI 0,440700
+ ILDB A,0
+ JUMPE A,STBOUX
+ PBOUT
+ JRST .-3
+
+STBOUX: SKIPE IMAGFL
+ JRST STBOU2
+ MOVE B,(P)
+ MOVE A,1(B)
+ HRRZ B,STATUS(B)
+ SFMOD
+STBOU2: POP P,B
+ POPJ P,
+\f
+; SPECIAL CASE GOODIES FOR DISPLAY TERMINALS
+
+NTTYPE==40 ; MAX TERMINAL TYPES SUPPORTED
+
+
+; HOW TO CLEAR SCREENS ON TOPS-20/TENEX
+CLRSTR: 0
+ 0
+ 0
+ 0
+ ASCII /\7f\12/ ; ITS SOFTWARE
+ ASCII /\1d\1e/ ; DATAMEDIA
+ ASCII /\eH\eJ/ ; HP2640
+ 0
+ 0
+ 0
+ 0
+ ASCII /\eH\eJ/ ; VT50
+ 0
+ ASCII /\e(\7f/ ; GT40
+ 0
+ ASCII /\eH\eJ/ ; VT52
+ 0
+ 0
+ ASCII /\eH\eJ/ ; VT100
+ ASCII /\eH\eJ/ ; TELERAY
+ ASCII /\eH\eJ/ ; H19
+ 0
+ 0
+ 0
+ 0
+ 0
+ 0
+ 0
+ 0
+ 0
+ 0
+ 0
+IFN <.-CLRSTR>-NTTYPE,PRINTC /ERROR -- CLEAR SCREEN TABLE LOSES
+/
+
+; HOW TO RUB OUT ON VARIOUS TERMINALS
+DELSTR: 0
+ 0
+ 0
+ 0
+ ASCII /\7f\v\7f\ 6/ ; ITS SOFTWARE DISPLAY
+ 0
+ ASCII /\eD\eK/ ; HP2640
+ 0
+ 0
+ 0
+ 0
+ ASCII /\eD\eK/ ; VT50
+ 0
+ 0
+ 0
+ ASCII /\eD\eK/ ; VT52
+ 0
+ 0
+ ASCII /\eD\eK/ ; VT100
+ ASCII /\eD\eK/ ; TELERAY
+ ASCII /\eD\eK/ ; H19
+ 0
+ 0
+ 0
+ 0
+ 0
+ 0
+ 0
+ 0
+ 0
+ 0
+ 0
+IFN <.-DELSTR>-NTTYPE,PRINTC /ERROR -- DELETE TABLE LOSES
+/
+
+; CLEAR TO EOL
+EOLSTR: 0
+ 0
+ 0
+ 0
+ ASCII /\7f\ 5/ ; ITS SOFTWARE DISPLAY
+ 0
+ ASCII /\eK/ ; HP2640
+ 0
+ 0
+ 0
+ 0
+ ASCII /\eK/ ; VT50
+ 0
+ 0
+ 0
+ ASCII /\eK/ ; VT52
+ 0
+ 0
+ ASCII /\eK/ ; VT100
+ ASCII /\eK/ ; TELERAY
+ ASCII /\eK/ ; H19
+ 0
+ 0
+ 0
+ 0
+ 0
+ 0
+ 0
+ 0
+ 0
+ 0
+ 0
+IFN <.-EOLSTR>-NTTYPE,PRINTC /ERROR -- END OF LINE TABLE LOSES
+/
+
+POSTAB: JFCL
+ JFCL
+ JFCL
+ JFCL
+ PUSHJ P,PSOFT ; ITS SOFTWARE
+ JFCL
+ PUSHJ P,PVT52 ; HP2640
+ JFCL
+ JFCL
+ JFCL
+ JFCL
+ PUSHJ P,PVT52 ; VT50
+ JFCL
+ JFCL
+ JFCL
+ PUSHJ P,PVT52 ; VT52
+ JFCL
+ JFCL
+ PUSHJ P,PVT52 ; VT100
+ PUSHJ P,PVT52 ; TELERAY
+ PUSHJ P,PVT52 ; H19
+ JFCL
+ JFCL
+ JFCL
+ JFCL
+ JFCL
+ JFCL
+ JFCL
+ JFCL
+ JFCL
+ JFCL
+ JFCL
+IFN <.-POSTAB>-NTTYPE,PRINTC /ERROR -- ABSOLUTE POSITION TABLE LOSES
+/
+
+
+
+\f
+; ROUTINES FOR ABSOLUTE POSITIONING ON TENEX/TOPS-20
+
+PSOFT: PUSH P,A
+ PUSHJ P,TNXIMG
+ MOVEI A,177
+ XCT ECHO(E)
+ MOVEI A,21
+ XCT ECHO(E)
+ PUSHJ P,GTLPOS
+ XCT ECHO(E)
+ POP P,A
+ XCT ECHO(E)
+ PUSHJ P,TNXASC
+ POPJ P,
+
+PVT52: PUSH P,A
+ PUSHJ P,TNXIMG
+ MOVEI A,33
+ XCT ECHO(E)
+ MOVEI A,"Y
+ XCT ECHO(E)
+ PUSHJ P,GTLPOS
+ ADDI A,40 ; MUDDLE PAGES START AT 0, VT52 AT 1
+ XCT ECHO(E)
+ POP P,A
+ ADDI A,40 ; DITTO COLUMNS
+ XCT ECHO(E)
+ PUSHJ P,TNXASC
+ POPJ P,
+
+TNXIMG: PUSH P,B
+ MOVE A,1(B)
+ MOVE B,STATUS(B)
+ TRZ B,300
+ SFMOD
+ POP P,B
+ POPJ P,
+
+TNXASC: PUSH P,B
+ MOVE A,1(B)
+ HRRZ B,STATUS(B)
+ SFMOD
+ POP P,B
+ POPJ P,
+]
+\f
+PUTCHR: AOS CHRCNT(E) ;COUNT THIS CHARACTER
+ IBP D ;BUMP BYTE POINTER
+IFE ITS,[
+ HRRZ C,D
+ ADDI C,(E)
+ CAIG 0,(C) ;DONT SKIP IF BUFFER FULL
+]
+IFN ITS, CAIG 0,@D ;DONT SKIP IF BUFFER FULL
+ PUSHJ P,BUFULL ;GROW BUFFER
+IFE ITS,[
+ CAIN A,37 ; CHANGE EOL TO CRLF
+ MOVEI A,15
+]
+ DPB A,D ;CLOBBER BYTE POINTER IN
+ MOVE C,SYSCHR(E) ; FLAGS
+IFE ITS,[
+ POPJ P,
+]
+IFN ITS,[
+ TRNN C,N.IMED+N.CNTL
+ CAIE A,15 ; IF CR INPUT, FOLLOW WITH LF
+ POPJ P,
+ MOVEI A,12 ; GET LF
+ JRST PUTCHR
+]
+; BUFFER FULL, GROW THE BUFFER
+
+BUFULL: MOVEM D,BYTPTR(E)
+ PUSH TP,$TCHAN ;SAVE B
+ PUSH TP,B
+ PUSH P,A ; SAVE CURRENT CHAR
+ HLRE A,BUFRIN(B)
+ MOVNS A
+ ADDI A,100 ; MAKE ONE LONGER
+ PUSHJ P,IBLOCK ; GET IT
+ MOVE A,(TP) ;RESTORE CHANNEL POINTER
+ SUB TP,[2,,2] ;AND REMOVE CRUFT
+ MOVE E,BUFRIN(A) ;GET AUX BUFFER POINTER
+ MOVEM B,BUFRIN(A)
+ HLRE 0,E ;RECOMPUTE 0
+ MOVSI E,(E)
+ HRRI E,(B) ; POINT TO DEST
+ SUB B,0
+ BLT E,(B)
+ MOVEI 0,100-2(B)
+ MOVE B,A
+ MOVE E,BUFRIN(B)
+ POP P,A
+ MOVE D,BYTPTR(E)
+ POPJ P,
+
+; SUBROUTINE TO FLUSH BUFFER
+
+RRESET: SETZM LSTCH(B) ; CLOBBER RE-USE CHAR
+ MOVE E,BUFRIN(B) ;GET AUX BUFFER
+ SETZM CHRCNT(E)
+ MOVEI D,N.IMED+N.IME1
+ ANDCAM D,SYSCHR(E)
+ MOVE D,[010700,,BYTPTR(E)] ;RESET BYTE POINTER
+ MOVEM D,BYTPTR(E)
+ MOVE D,CHANNO(B) ;GOBBLE CHANNEL
+IFN ITS,[
+ SETZM CHNCNT(D) ; FLUSH COUNTERS
+ LSH D,23. ;POSITION
+ IOR D,[.RESET 0]
+ XCT D ;RESET ITS CHANNEL
+]
+IFE ITS,[
+ MOVEI A,100 ; TTY IN JFN
+ CFIBF
+]
+ SETZM EXBUFR(B) ; CLOBBER STAKED BUFFS
+ MOVEI C,BUFSTR-1(B) ; FIND D.W.
+ PUSHJ P,BYTDOP
+ SUBI A,2
+ HRLI A,010700
+ MOVEM A,BUFSTR(B)
+ HLLZS BUFSTR-1(B)
+ POPJ P,
+\f
+; SUBROUTINE TO ESTABLISH ECHO IOINS
+
+MFUNCTION ECHOPAIR,SUBR
+
+ ENTRY 2
+
+ GETYP A,(AB) ;CHECK ARG TYPES
+ GETYP C,2(AB)
+ CAIN A,TCHAN ;IS A CHANNEL
+ CAIE C,TCHAN ;IS C ALSO
+ JRST WRONGT ;NO, ONE OF THEM LOSES
+
+ MOVE A,1(AB) ;GET CHANNEL
+ PUSHJ P,TCHANC ; VERIFY TTY IN
+ MOVE D,3(AB) ;GET OTHER CHANNEL
+ HRRZ 0,-2(D) ; GET BITS
+ TRC 0,C.OPN+C.PRIN
+ TRNE 0,C.OPN+C.PRIN
+ JRST WRONGD
+
+ MOVE B,BUFRIN(A) ;GET A'S AUX BUFFER
+IFN ITS,[
+ HRLZ C,CHANNO(D) ; GET CHANNEL
+ LSH C,5
+ IOR C,[.IOT A] ; BUILD AN IOT
+ MOVEM C,ECHO(B) ;CLOBBER
+]
+CHANRT: MOVE A,(AB)
+ MOVE B,1(AB) ;RETURN 1ST ARG
+ JRST FINIS
+
+TCHANC: HRRZ 0,-2(A) ; GET BITS
+ TRC 0,C.OPN+C.READ
+ TRNE 0,C.OPN+C.READ
+ JRST BADCHN
+IFN ITS,[
+ LDB C,[600,,STATUS(A)] ;GET A CODE
+ CAILE C,2 ;MAKE SURE A TTY FLAVOR DEVICE
+ JRST WRONGC
+ POPJ P,
+]
+IFE ITS,[
+ PUSH P,A
+ MOVE A,1(A)
+ DVCHR
+ LDB A,[221100,,B] ;DEVICE TYPE FIELD
+ CAIE A,12 ;TTY
+ CAIN A,13 ;PTY
+ SKIPA
+ JRST WRONGC ;NOT A TTY, HOPE WE DON'T GET HERE IN LISTEN
+ POP P,A
+ POPJ P,
+]
+\f
+; TTY OPEN
+
+IFE ITS,[
+TTYOPEN:
+TTYOP2: SKIPE DEMFLG
+ POPJ P,
+ MOVE C,TTOCHN+1
+ HLLZS IOINS-1(C)
+ MOVEI A,-1 ; TERMINAL; STAYS HERE THROUGHOUT ROUTINE
+ MOVEI 2,175100 ; MAGIC BITS (SEE TENEX MANUAL)
+ SFMOD ; ZAP
+ RFMOD ; LETS FIND SCREEN SIZE
+ MOVEM B,STATUS(C)
+ LDB B,[220700,,B] ; GET PAGE WIDTH
+ JUMPG B,.+2
+ MOVEI B,80. ; MUST BE VIRTUAL, SO MAKE IT 80.
+ MOVEM B,LINLN(C)
+ LDB B,[310700,,STATUS(C)] ; AND LENGTH
+ MOVEM B,PAGLN(C)
+ SKIPE OPSYS ; CHECK FOR TOPS-20
+ JRST NONVTS ; ONLY TOPS-20 CAN HAVE VTS
+ RTCHR
+ ERJMP NONVTS ; NO RTCHR JSYS, HENCE NO VTS
+ TLNN B,(TC%MOV+TC%CLR) ; HAS MINIMAL CHARACTERISTICS?
+ JRST NONVTS ; NO GOOD ENOUGH FOR US
+ MOVNI B,1 ; TERMINAL TYPE -1 IS VTS DISPLAY
+ JRST HASVTS ; WINS
+
+NONVTS: PUSH P,C ; IDIOT GETTYP CLOBBERS C
+ GTTYP ; FIND TERMINAL TYPE
+ POP P,C
+HASVTS: HRLM B,STATUS(C) ; USED TO FIGURE OUT DISPLAY STUFF
+ MOVE B,STATUS(C)
+ MOVE C,TTICHN+1
+ MOVEM B,STATUS(C) ; SET UP INCHAN TOO
+ RFCOC ; GET CURRENT
+ AND B,[036377,,-1] ; CHANGE FOR ^@, ^A AND ^D (FOR NOW)
+ SFCOC ; AND RESUSE IT
+
+ POPJ P,
+]
+
+IFN ITS,[
+TTYOP2: .SUSET [.RTTY,,C]
+ SETZM NOTTY
+ JUMPL C,TTYNO ; DONT HAVE TTY
+
+TTYOPEN:
+ SKIPE NOTTY
+ POPJ P,
+ .CALL [SETZ
+ SIXBIT /OPEN/
+ [1000,,TTYIN]
+ SETZ [[SIXBIT /TTY /]]]
+ JRST TTYNO
+ DOTCAL OPEN,[[1000,,TTYOUT],[[SIXBIT /TTY /]],[5000,,1]]
+ FATAL CANT OPEN TTY
+ DOTCAL TTYGET,[[1000,,TTYOUT],[2000,,0],[2000,,A],[2000,,B]]
+ FATAL .CALL FAILURE
+ DOTCAL TTYSET,[[1000,,TTYOUT],MODE1,MODE2,B]
+ FATAL .CALL FAILURE
+
+SETCHN: MOVE B,TTICHN+1 ;GET CHANNEL
+ MOVEI C,TTYIN ;GET ITS CHAN #
+ MOVEM C,CHANNO(B)
+ .STATUS TTYIN,STATUS(B) ;CLOBBER STATUS
+
+ MOVE B,TTOCHN+1 ;GET OUT CHAN
+ MOVEI C,TTYOUT
+ MOVEM C,CHANNO(B)
+ .STATUS TTYOUT,STATUS(B)
+ SETZM IMAGFL ;RESET IMAGE MODE FLAG
+ HLLZS IOINS-1(B)
+ DOTCAL RSSIZE,[[1000,,TTYOUT],[2000,,C],[2000,,D]]
+ FATAL .CALL RSSIZE LOSSAGE
+ MOVEM C,PAGLN(B)
+ MOVEM D,LINLN(B)
+ POPJ P,
+
+; HERE IF TTY WONT OPEN
+
+TTYNO: SETOM NOTTY
+ POPJ P,
+]
+
+GTLPOS:
+IFN ITS,[
+ DOTCAL RCPOS,[[CHANNO(B)],[2000,,A]]
+ JFCL
+ HLRZS A
+ POPJ P,
+]
+IFE ITS,[
+ PUSH P,B
+ MOVE B,TTOCHN+1
+ HLRE A,STATUS(B)
+ JUMPGE A,GETCRF
+ MOVE A,1(B)
+ RFPOS
+ HLRZ A,B
+ SKIPA
+GETCRF: MOVE A,LINPOS(B)
+ POP P,B
+ POPJ P,
+]
+
+MTYI: SKIPN DEMFLG ; SKIP IF DEMON
+ SKIPE NOTTY ; SKIP IF HAVE TTY
+ FATAL TRIED TO USE NON-EXISTANT TTY
+
+; TRY TO AVOID HANGING IN .IOT TO TTY
+
+IFN ITS,[
+ DOTCAL IOT,[[1000,,TTYIN],[A],[5000,,1000]]
+ JFCL
+]
+IFE ITS,[
+
+MTYI1: PBIN
+]
+ POPJ P,
+
+INMTYO: ; BOTH ARE INTERRUPTABLE
+MTYO: ENABLE
+ PUSHJ P,IMTYO
+ DISABLE
+ POPJ P,
+
+; NON-INTERRUPTABLE VERSION, FOR ECHO INSTRUCTION AND SUCHLIKE
+IMTYO: SKIPE NOTTY
+ POPJ P, ; IGNORE, DONT HAVE TTY
+
+IFN ITS,[
+ CAIN A,177 ;DONT OUTPUT A DELETE
+ POPJ P,
+ PUSH P,B
+ MOVEI B,0 ; SETUP CONTROL BITS
+ TLNE 0,CNTLPC ; SKIP IF ^P MODE SWITCH IS OFF
+ MOVEI B,%TJDIS ; SWITCH ON TEMPORARY ^P MODE
+ DOTCAL IOT,[[1000,,TTYOUT],[A],[4000,,B]]
+ JFCL
+ POP P,B
+]
+IFE ITS, PBOUT
+ POPJ P,
+
+; HERE FOR TYO TO ANY TTY FLAVOR DEVICE
+IFN ITS,[
+GMTYO: PUSH P,0
+IFE ITS,[
+ HRRZ 0,IOINS-1(B) ; GET FLAG
+ SKIPE 0
+ PUSHJ P,REASCI ; RE-OPEN TTY
+]
+ HRLZ 0,CHANNO(B)
+ ASH 0,5
+ IOR 0,[.IOT A]
+ CAIE A,177 ; DONE OUTPUT A DELETE
+ XCT 0
+ POP P,0
+ POPJ P,
+
+REASCI: PUSH P,A
+ PUSH P,C
+IFE ITS,[
+ PUSH P,B
+ MOVE A,1(B)
+ RFMOD
+ TRO B,102
+ SFMOD
+ STPAR
+ POP P,B ]
+
+ POP P,C
+ POP P,A
+ HLLZS IOINS-1(B)
+ CAMN B,TTOCHN+1
+ SETZM IMAGFL
+ POPJ P,
+]
+
+
+WRONGC: FATAL TTYECHO--NOT ON A TTY-TYPE CHANNEL
+
+
+
+; HERE TO HANDLE TTY BLOCKING AND UNBLOCKING
+
+TTYBLK: PUSH TP,$TCHAN
+ PUSH TP,B
+ PUSH P,0
+ PUSH P,E ; SAVE SOME ACS
+IFN ITS,[
+ MOVE A,CHANNO(B) ; GET CHANNEL NUMBER
+ SOSG CHNCNT(A) ; ANY PENDING CHARS
+ JRST TTYBL1
+ SETZM CHNCNT(A)
+ MOVEI 0,1
+ LSH 0,(A)
+ .SUSET [.SIFPI,,0] ; SLAM AN INT ON
+]
+TTYBL1: MOVE C,BUFRIN(B)
+ MOVE A,SYSCHR(C) ; GET FLAGS
+ TRZ A,N.IMED
+ TRZE A,N.IME1 ; IF WILL BE
+ TRO A,N.IMED ; THE MAKE IT
+ MOVEM A,SYSCHR(C)
+IFN ITS,[
+ MOVE A,[.CALL TTYIOT] ; NON-BUSY WAIT (IF CHAR READ, LEAVE IN BUFFER
+ ; TO LET IT BE READ AT INTERRUPT LEVEL)
+ SKIPE NOTTY
+ MOVE A,[.SLEEP A,]
+]
+IFE ITS,[
+ MOVE A,[PUSHJ P,TNXIN]
+]
+ MOVEM A,WAITNS(B)
+ PUSH TP,$TCHSTR
+ PUSH TP,CHQUOTE BLOCKED
+ PUSH TP,$TPVP
+ PUSH TP,PVSTOR+1
+ MCALL 2,INTERRUPT
+ MOVSI A,TCHAN
+ MOVE PVP,PVSTOR+1
+ MOVEM A,BSTO(PVP)
+ MOVE B,(TP)
+ ENABLE
+REBLK: MOVEI A,-1 ; IN CASE SLEEPING
+ XCT WAITNS(B) ; NOW WAIT
+ JFCL
+IFE ITS, JRST .-3
+IFN ITS, JRST CHRSNR ; SNARF CHAR
+REBLK1: DISABLE ; FALL THROUG=> UNBLOCKED
+ MOVE PVP,PVSTOR+1
+ SETZM BSTO(PVP)
+ POP P,E
+ POP P,0
+ MOVE B,(TP)
+ SUB TP,[2,,2]
+ POPJ P,
+IFN ITS,[
+CHRSNR: SKIPN DEMFLG ; SKIP IF DEMON
+ SKIPE NOTTY ; TTY?
+ JRST REBLK ; NO, JUST RESET AND BLOCK
+ .SUSET [.SIFPI,,[1_<TTYIN>]]
+ JRST REBLK ; AND GO BACK
+
+TTYIOT: SETZ
+ SIXBIT /IOT/
+ 1000,,TTYIN
+ 0
+ 405000,,20000
+]
+; HERE TO UNBLOCK TTY
+
+TTYUNB: MOVE A,WAITNS(B) ; GET INS
+ CAMN A,[JRST REBLK1]
+ JRST TTYUN1
+ MOVE A,[JRST REBLK1] ; LEAVE THE SLEEP
+ MOVEM A,WAITNS(B)
+ PUSH TP,$TCHAN
+ PUSH TP,B
+ PUSH TP,$TCHSTR
+ PUSH TP,CHQUOTE UNBLOCKED
+ PUSH TP,$TCHAN
+ PUSH TP,B
+ MCALL 2,INTERRUPT
+ MOVE B,(TP) ; RESTORE CHANNEL
+ SUB TP,[2,,2]
+TTYUN1: POPJ P,
+
+IFE ITS,[
+; TENEX BASIC TTY I/O ROUTINE
+
+TNXIN: PUSHJ P,MTYI
+ DISABLE
+ PUSHJ P,INCHAR
+ ENABLE
+ POPJ P,
+]
+MFUNCTION TTYECHO,SUBR
+
+ ENTRY 2
+
+ GETYP 0,(AB)
+ CAIE 0,TCHAN
+ JRST WTYP1
+ MOVE A,1(AB) ; GET CHANNEL
+ PUSHJ P,TCHANC ; MAKE SURE IT IS TTY INPUT
+ MOVE E,BUFRIN(A) ; EXTRA INFO BUFFER
+IFN ITS,[
+ DOTCAL TTYGET,[CHANNO(A),[2000,,B],[2000,,C],[2000,,0]]
+ FATAL .CALL FAILURE
+]
+IFE ITS,[
+ MOVEI A,100 ; TTY JFN
+ RFMOD ; MODE IN B
+ TRZ B,6000 ; TURN OFF ECHO
+]
+ GETYP D,2(AB) ; ARG 2
+ CAIE D,TFALSE ; SKIP IF WANT ECHO OFF
+ JRST ECHOON
+
+IFN ITS,[
+ ANDCM B,[606060,,606060]
+ ANDCM C,[606060,,606060]
+
+ DOTCAL TTYSET,[CHANNO(A),B,C,0]
+ FATAL .CALL FAILURE
+]
+IFE ITS,[
+ SFMOD
+]
+
+ MOVEI B,N.ECHO+N.CNTL ; SET FLAGS
+ IORM B,SYSCHR(E)
+
+ JRST CHANRT
+
+ECHOON:
+IFN ITS,[
+ IOR B,[202020,,202020]
+ IOR C,[202020,,200020]
+ DOTCAL TTYSET,[CHANNO(A),B,C,0]
+ FATAL .CALL FAILURE
+]
+IFE ITS,[
+ TRO B,4000
+ SFMOD
+]
+ MOVEI A,N.ECHO+N.CNTL
+ ANDCAM A,SYSCHR(E)
+ JRST CHANRT
+
+
+
+; USER SUBR FOR INSTANT CHARACTER SNARFING
+
+MFUNCTION UTYI,SUBR,TYI
+
+ ENTRY
+ CAMGE AB,[-3,,]
+ JRST TMA
+ MOVE A,(AB)
+ MOVE B,1(AB)
+ JUMPL AB,.+3
+ MOVE B,IMQUOTE INCHAN
+ PUSHJ P,IDVAL ; USE INCHAN
+ GETYP 0,A ; GET TYPE
+ CAIE 0,TCHAN
+ JRST WTYP1
+IFN ITS,[
+ LDB 0,[600,,STATUS(B)]
+ CAILE 0,2
+ JRST WTYP1
+ SKIPN A,LSTCH(B) ; ANY READ AHEAD CHAR
+ JRST UTYI1 ; NO, SKIP
+ ANDI A,-1
+ SETZM LSTCH(B)
+ TLZN A,400000 ; ! HACK?
+ JRST UTYI2 ; NO, OK
+ HRRM A,LSTCH(B) ; YES SAVE
+ MOVEI A,"! ; RET AN !
+ JRST UTYI2
+
+UTYI1: MOVE 0,IOINS(B)
+ CAME 0,[PUSHJ P,GETCHR]
+ JRST WTYP1
+ PUSH TP,$TCHAN
+ PUSH TP,B
+ MOVE C,BUFRIN(B)
+ MOVEI D,N.IME1+N.IMED
+ IORM D,SYSCHR(C) ; CLOBBER IT IN
+ DOTCAL TTYGET,[CHANNO(B),[2000,,A],[2000,,D],[2000,,0]]
+ FATAL .CALL FAILURE
+ PUSH P,A
+ PUSH P,0
+ PUSH P,D ; SAVE THEM
+ IOR D,[030303,,030303]
+ IOR A,[030303,,030303]
+ DOTCAL TTYSET,[CHANNO(B),A,D,0]
+ FATAL .CALL FAILURE
+ MOVNI A,1
+ SKIPE CHRCNT(C) ; ALREADY SOME?
+ PUSHJ P,INCHAR
+ MOVE C,BUFRIN(B) ; GET BUFFER BACK
+ MOVEI D,N.IME1
+ IORM D,SYSCHR(C)
+ PUSHJ P,GETCHR
+ MOVE B,1(TB)
+ MOVE C,BUFRIN(B)
+ MOVEI D,N.IME1+N.IMED
+ ANDCAM D,SYSCHR(C)
+ POP P,D
+ POP P,0
+ POP P,C
+ DOTCAL TTYSET,[CHANNO(B),C,D,0]
+ FATAL .CALL FAILURE
+UTYI2: MOVEI B,(A) ]
+IFE ITS,[
+ MOVE A,1(B) ;GET JFN FOR INPUT
+ ENABLE
+ BIN ;SNARF A CHARACTER
+ DISABLE
+]
+ MOVSI A,TCHRS
+ JRST FINIS
+
+MFUNCTION IMAGE,SUBR
+ ENTRY
+ JUMPGE AB,TFA ; 1 OR 2 ARGS NEEDED
+ GETYP A,(AB) ;GET THE TYPE OF THE ARG
+ CAIE A,TFIX ;CHECK IT FOR CORRECT TYPE
+ JRST WTYP1 ;WAS WRONG...ERROR EXIT
+ HLRZ 0,AB
+ CAIL 0,-2
+ JRST USEOTC
+ CAIE 0,-4
+ JRST TMA
+ GETYP 0,2(AB)
+ CAIE 0,TCHAN
+ JRST WTYP2
+ MOVE B,3(AB) ; GET CHANNEL
+IMAGE1: MOVE A,1(AB)
+ PUSHJ P,CIMAGE
+ JRST FINIS
+
+CIMAGE: SUBM M,(P)
+IFN ITS,[
+ LDB 0,[600,,STATUS(B)]
+ CAILE 0,2 ; MUST BE TTY
+ JRST IMAGFO
+ MOVE 0,IOINS(B)
+ CAMN 0,[PUSHJ P,MTYO]
+ JRST .+3
+ CAME 0,[PUSHJ P,GMTYO]
+ JRST WRONGD ]
+IFE ITS,[
+ MOVE 0,CHANNO(B) ; SEE IF TTY
+ CAIE 0,101
+ JRST IMAGFO
+]
+
+IFN ITS,[
+ DOTCAL IOT,[[5000,,2000],[CHANNO(B)],[A]]
+ JFCL
+ MOVE B,A
+]
+IFE ITS,[
+ SKIPE IMAGFL
+ JRST IMGOK
+
+ PUSH P,A
+ PUSH P,B
+ MOVSI A,1
+ HRROI B,[ASCIZ /TTY:/]
+ GTJFN
+ HALTF
+ MOVE B,[074000,,102000]
+ OPENF
+ HALTF
+ HRRZM A,IMAGFL
+ POP P,B
+ POP P,A
+IMGOK: MOVE B,IMAGFL
+ EXCH A,B
+ BOUT
+]
+
+IMGEXT: MOVSI A,TFIX
+ JRST MPOPJ
+
+
+IMAGFO: PUSH TP,$TCHAN ;IMAGE OUTPUT FOR NON TTY
+ PUSH TP,B
+ PUSH P,A
+ HRRZ 0,-2(B) ; GET BITS
+ TRC 0,C.OPN+C.PRIN
+ TRNE 0,C.OPN+C.PRIN
+ JRST BADCHN
+ MOVE B,(TP)
+ PUSHJ P,GWB ; MAKE SURE CHANNEL HAS BUFFER
+ MOVE A,(P) ; GET THE CHARACTER TO DO
+ PUSHJ P,W1CHAR
+ POP P,B
+ MOVSI A,TFIX
+ SUB TP,[2,,2]
+ JRST MPOPJ
+
+
+USEOTC: MOVSI A,TATOM
+ MOVE B,IMQUOTE OUTCHAN
+ PUSHJ P,IDVAL
+ GETYP 0,A
+ CAIE 0,TCHAN
+ MOVE B,TTOCHN+1
+ MOVE A,1(B)
+ JRST IMAGE1
+
+IFN ITS,[
+IMGBLK: OUT+IMAGEM+UNIT,,(SIXBIT /TTY/)
+ 0
+ 0
+]
+
+
+IMPURE
+IMAGFL: 0
+PURE
+
+
+END
+\f
\ No newline at end of file
--- /dev/null
+TITLE SAVE AND RESTORE STATE OF A MUDDLE
+
+RELOCATABLE
+
+.INSRT DSK:MUDDLE >
+
+SYSQ
+
+
+UNTAST==0
+IFE ITS,[
+IF1,[
+.INSRT STENEX >
+EXPUNGE SAVE
+]
+]
+.GLOBAL MOPEN,MIOT,MCLOSE,MUDSTR,SWAP,STRTO6,GCPDL,RGPRS,ADDNUL,GCSTOP,PHIBOT
+.GLOBAL CHNL0,CHNL1,REOPN,AGC,SWAPIN,MASK1,MASK2,IPCBLS,DEMFLG,FSTART,CKVRS
+.GLOBAL P.CORE,P.TOP,SGSNAM,%RUNAM,%RSNAM,%RJNAM,INTINT,CLOSAL,TTYOPE,PURBOT,CHKPGI
+.GLOBAL NOTTY,PURCLN,6TOCHS,DISXTR,IDVAL1,N.CHNS,PMAPB,PURTOP,HITOP,FRETOP,FREMIN
+.GLOBAL SQKIL,SFRK,GETJS,IJFNS,IJFNS1,MULTSG,MULTI,NOMULT,THIBOT
+.GLOBAL MAPJFN,DIRCHN
+
+FME==1000,,-1
+FLS==1000,,
+MFORK==400000
+
+MFUNCTION FSAVE,SUBR
+
+ ENTRY
+
+ JRST SAVE1
+
+MFUNCTION SAVE,SUBR
+
+ ENTRY
+SAVE1: PUSHJ P,SQKIL
+IFE ITS,[
+ SKIPE MULTSG
+ PUSHJ P,NOMULT
+]
+ PUSH P,.
+ PUSH P,[0] ; GC OR NOT?
+IFE ITS,[
+ MOVE B,[400600,,]
+ MOVE C,[440000,,100000]
+]
+ PUSHJ P,GTFNM ; GET THE FILE NAME ONTO P
+ JRST .+2
+ JRST SAVEON
+ JUMPGE AB,TMA ; TOO MUCH STRING
+ GETYP 0,(AB) ; WHAT IS ARG
+ CAMGE AB,[-3,,0] ; NOT TOO MANY
+ JRST TMA
+ CAIN 0,TFALSE
+IFN ITS, SETOM -6(P) ; GC FLAG
+IFE ITS, SETOM (P)
+SAVEON:
+IFN ITS,[
+ MOVSI A,7 ; IMAGE BLOCK OUT
+ MOVEM A,-4(P) ; DIRECTION
+ PUSH P,A
+ PUSH P,-4(P) ; DEVICE
+ PUSH P,[SIXBIT /_MUDS_/]
+ PUSH P,[SIXBIT />/]
+ PUSH P,-4(P) ; SNAME
+ MOVEI A,-4(P) ; POINT TO BLOCK
+ PUSHJ P,MOPEN ; ATTEMPT TO OPEN
+ JRST CANTOP
+ SUB P,[5,,5] ; FLUSH OPEN BLOCK
+ PUSH P,-6(P) ; GC FLAG TO TOP OF STACK (-4 --> -6 TAA)
+]
+ EXCH A,(P) ; CHAN TO STACK GC TO A
+ JUMPL A,NOGC
+ PUSH TP,$TFIX ; CAUSE HAIRY GC TO OCCUR
+ PUSH TP,[0]
+ PUSH TP,$TATOM
+ PUSH TP,IMQUOTE T
+ MCALL 2,GC
+NOGC: PUSHJ P,PURCLN
+
+; NOW GET VERSION OF MUDDLE FOR COMPARISON
+
+ MOVE A,MUDSTR+2 ; GET #
+ MOVEI B,177 ; CHANGE ALL RUBOUT CHARACTERS
+ MOVEI C,40 ; ----- TO SPACES
+ PUSHJ P,HACKV
+
+ PUSHJ P,WRDOUT
+ MOVE A,P.TOP ; GET TOP OF CORD
+ PUSHJ P,WRDOUT
+ MOVEI A,0 ; WRITE ZERO IF FAST
+IFN ITS, SKIPE -8(P) ; -6 --> -8 TAA
+IFE ITS, SKIPE -1(P)
+ PUSHJ P,WRDOUT
+ MOVE A,VECTOP ; CORE REQUIREMENTS FOR THIS SAVED MUDDLE
+ PUSHJ P,WRDOUT
+
+IFN ITS,[
+ SETZB A,B ; FIRST, ALL INTS OFF
+ .SETM2 A,
+
+; IF FAST SAVE JUMP OFF HERE
+
+ SKIPE -6(P)
+ JRST FSAVE1
+
+]
+
+IFE ITS,[
+ MOVEI A,400000 ; FOR THIS PROCESS
+ DIR ; TURN OFF INT SYSTEM
+
+; IF FAST, LEAVE HERE
+
+ SKIPE -1(P)
+ JRST FSAVE1
+
+; NOW DUMP OUT GC SPACE
+
+]
+IFN ITS,[
+
+DMPDN2: SETZB A,B ; SET UP RENAME WHILE OPEN ETC.
+ MOVE E,-1(P)
+ MOVE D,-2(P)
+ LDB C,[270400,,0] ; GET CHANNEL
+ .FDELE A ; RENAME IT
+ FATAL SAVE RENAME FAILED
+ XOR 0,[<.IOT A>#<.CLOSE>] ; CHANGE TO A CLOSE
+ XCT 0
+
+ MOVE A,MASK1 ; TURN INTS BACK ON
+ MOVE B,MASK2
+ .SETM2 A,
+]
+
+IFE ITS,[
+
+DMPDN2: MOVE A,0
+ CLOSF
+ FATAL CANT CLOSE SAVE FILE
+ CIS ; CLEAR IT SYSTEM
+ MOVEI A,400000
+ EIR ; AND RE-ENABLE
+]
+
+SDONE: MOVE A,$TCHSTR
+ MOVE B,CHQUOTE SAVED
+ JRST FINIS
+
+; SCAN FOR MANY OCCURENCES OF THE SAME THING
+
+
+; HERE TO WRITE OUT FAST SAVE FILE
+
+FSAVE1:
+IFN UNTAST,[
+ PUSHJ P,PUCHK
+]
+ MOVE A,PARTOP ; DONT WRITE OUT "HOLE"
+ ADDI A,1777
+ ANDCMI A,1777
+ MOVEI E,(A)
+ PUSHJ P,WRDOUT
+ MOVE 0,(P) ; CHANNEL TO 0
+IFN ITS,[
+ ASH 0,23. ; TO AC FIELS
+ IOR 0,[.IOT A]
+ MOVEI A,5 ; START AT WORD 5
+]
+IFE ITS,[
+ MOVE A,[-<P-E>,,E]
+ PUSH P,(A)
+ AOBJN A,.-1
+ MOVE A,0
+ MOVE B,P ; WRITE OUT P FOR WIINAGE
+ BOUT
+ MOVE B,[444400,,20]
+ MOVNI C,20-6
+ SOUT ; MAKE PAGE BOUNDARIES WIN
+ MOVEI A,20 ; START AT 20
+]
+ MOVEI B,(E) ; PARTOP TO B
+ PUSHJ P,FOUT ; WRITE OUT UP TO PAIR TOP
+ PUSHJ P,PUROUT
+ SUB P,[1,,1] ; CLEAN OFF STACK
+ JRST DMPDN2
+
+IFN ITS,[
+FOUT: MOVEI D,(A) ; SAVE START
+ SUB A,B ; COMPUTE LH OF IOT PNTR
+ MOVSI A,(A)
+ SKIPL A ; IF + MEANS GROSS CORE SIZE
+ MOVSI A,400000 ; USE BIGGEST
+ HRRI A,(D)
+ XCT 0 ; ZAP, OUT IT GOES
+ CAMGE A,B ; SKIP IF ALL WENT
+ JRST FOUT ; DO THE REST
+ POPJ P, ; GO CLOSE FILE
+]
+IFE ITS,[
+FOUT: MOVEI C,(A)
+ SUBI C,(B) ; # OF BYTES TP C
+ MOVEI B,(A) ; START TO B
+ HRLI B,444400
+ MOVE A,0
+ SOUT ; WRITE IT OUT
+ POPJ P,
+]
+
+
+; HERE TO ATTEMPT TO RESTORE A SAVED STATE
+
+MFUNCTION RESTORE,SUBR
+
+ ENTRY
+ PUSHJ P,SQKIL
+IFE ITS,[
+ MOVE B,[100600,,]
+ MOVE C,[440000,,240000]
+]
+ PUSHJ P,GTFNM
+ JRST TMA
+IFN ITS,[
+ MOVSI A,6 ; READ/IMAGE/BLOCK
+ MOVEM A,-4(P)
+ MOVEI A,-4(P)
+ PUSHJ P,MOPEN ; OPEN THE LOSER
+ JRST FNF
+ SUB P,[6,,6] ; REMOVE OPEN BLOCK
+
+ PUSH P,A ; SAVE CHANNEL
+ PUSHJ P,SGSNAM ; SAVE SNAME IN SYSTEM
+]
+IFE ITS, PUSH P,A ; SAVE JFN
+ PUSHJ P,CKVRS ; CHECK THE VERSION NUMBER
+
+IFN ITS, MCALL 0,IPCOFF ; CLOSE ALL IPC CHANS
+ PUSHJ P,CLOSAL ; CLOSE CHANNELS
+IFN ITS,[
+ SETZB A,B ; KILL ALL POSSIBLE INTERRUPTION
+ .SETM2 A,
+ DOTCAL UNLOCK,[[1000,,-1]]
+ .VALUE ; UNLOCK LOCKS
+]
+IFE ITS,[
+ MOVEI A,400000 ; DISABLE INTS
+ DIR ; INTS OFF
+
+; LOOP TO CLOSE ALL RANDOM JFNS
+
+ MOVE E,[-JFNLNT,,JFNTBL]
+
+JFNLP: HRRZ A,@(E)
+ SKIPE A
+ CLOSF
+ JFCL
+ HLRZ A,@(E)
+ SKIPE A
+ CLOSF
+ JFCL
+ SETZM @(E)
+ AOBJN E,JFNLP
+
+]
+ PUSHJ P,PURCLN ; DONT KEEP PURE SHAREDNESS
+
+ POP P,E
+IFE ITS,[
+ MOVEI C,0
+ MOVNI A,1
+ MOVE B,[MFORK,,1]
+ MOVEI D,THIBOT-1
+ PMAP
+ ADDI B,1
+ SOJG D,.-2
+ SKIPLE A,SFRK ; IF WE HAVE AN INFERIOR, KILL IT
+ KFORK
+]
+ MOVE A,E
+FSTART: MOVE P,GCPDL
+ PUSH P,A
+IFN ITS,[
+ MOVE 0,[1-PHIBOT,,1]
+ DOTCAL CORBLK,[[FLS],[FME],0]
+ FATAL CANT FLUSH PURE PAGES
+]
+ PUSHJ P,WRDIN ; GET P.TOP
+ ASH A,-10.
+ MOVE E,A
+ PUSHJ P,WRDIN ; READ A WORD (VECTOP) OR 0==>FAST I.E. MAP RESTORE
+ JUMPE A,FASTR
+
+IFE ITS,[
+FASTR1: MOVEI A,P-1
+ MOVEI B,P-1-E
+ POP P,(A)
+ SUBI A,1
+ SOJG B,.-2
+]
+
+IFN ITS,[
+FASTR1:
+]
+IFN ITS, MOVEM E,NOTTY ; SAVE TTY FLAG
+IFE ITS,[
+ MOVEM E,DEMFLG
+ PUSHJ P,GETJS
+ HRRZS IJFNS
+ SETZM IJFNS1
+]
+ PUSHJ P,PURCLN ; IN CASE RESTORED THING HAD PURE STUFF
+ PUSHJ P,INTINT ; USE NEW INTRRRUPTS
+
+IFN ITS,[
+ .SUSET [.RSNAM,,A]
+ PUSH P,A
+]
+
+; NOW CYCLE THROUGH CHANNELS
+ MOVE C,[-<N.CHNS+N.CHNS>,,CHNL1] ; POINT TO REAL CHANNELS SLOTS
+ PUSH TP,$TVEC
+ PUSH TP,C
+ PUSH P,[N.CHNS]
+
+CHNLP: HRRE A,(C) ; SEE IF NEW VALUE
+ JUMPL A,NXTCHN
+ SKIPN B,1(C) ; GET CHANNEL
+ JRST NXTCHN
+ PUSHJ P,REOPN
+ PUSHJ P,CHNLOS
+ MOVE C,(TP) ; GET POINTER
+NXTCHN: ADD C,[2,,2] ; AND BUMP
+ MOVEM C,(TP)
+ SOSE (P)
+ JRST CHNLP
+
+ SKIPN C,CHNL0+1 ; ANY PSUEDO CHANNELS
+ JRST RDONE ; NO, JUST GO AWAY
+ MOVSI A,TLIST ; YES, REOPEN THEM
+ MOVEM A,(TP)-1
+CHNLP1: MOVEM C,(TP) ; SAVE POINTER
+ SKIPE B,(C)+1 ; GET CHANNEL
+ PUSHJ P,REOPN
+ PUSHJ P,CHNLO1
+ MOVE C,(TP) ; GOBBLE POINTER
+ HRRZ C,(C) ; REST LIST OF PSUEDO CHANNELS
+ JUMPN C,CHNLP1
+
+RDONE: MOVE A,VECTOP
+ CAMN A,P.TOP
+ JRST NOCOR
+ SETZM (A)
+ HRLS A
+ ADDI A,1 ; SET UP BLT POINTER
+ MOVE B,P.TOP
+ BLT A,-1(B) ; TO THE TOP OF THE WORLD
+NOCOR: SUB TP,[2,,2]
+ SUB P,[1,,1]
+ PUSHJ P,TTYOPE
+IFN ITS,[
+ PUSHJ P,IPCBLS ;BLESS ALL THE IPC CHANNELS
+ PUSHJ P,SGSNAM ; GET SNAME
+ SKIPN A
+ MOVE A,(P) ; GET OLD SNAME
+ SUB P,[1,,1]
+ PUSHJ P,6TOCHS ; TO STRING
+]
+IFE ITS,[
+ PUSHJ P,SGSNMQ ; SKIPS IF SNAME IS NON-NIL
+ PUSHJ P,%RSNAM ; ELSE GETS "REAL" SNAME
+ PUSH TP,A
+ PUSH TP,B
+ MCALL 1,SNAME
+ SETOM SFRK
+]
+ PUSHJ P,%RUNAM
+ PUSHJ P,%RJNAM
+
+IFE ITS,[
+ MOVEI A,400000
+ MOVE B,[1,,ILLUUO]
+ MOVE C,[40,,UUOH]
+ SCVEC
+]
+ MOVE A,$TCHSTR
+ MOVE B,CHQUOTE RESTORED
+ JRST FINIS
+
+IFE ITS,[
+;SKIPS IF THERE IS AN SNAME, RETURNING IT
+SGSNMQ: MOVE B,IMQUOTE SNM
+ PUSHJ P,IDVAL1
+ GETYP 0,A
+ CAIE 0,TCHSTR
+ JRST CPOPJ
+ HRRZ 0,A
+ JUMPE CPOPJ
+ JRST CPOPJ1
+]
+
+FASTR:
+IFN ITS,[
+ PUSHJ P,WRDIN
+ ADDI A,1777
+ ANDCMI A,1777 ; ROUND AND TO PAGE BOUNDRY
+ ASH A,-10. ; TO PAGES
+ MOVNS A
+ MOVSI A,(A) ; TO PAGE AOBJN
+ MOVE C,A ; COPY OF POINTER
+ MOVE 0,NOTTY ; SAVE NOTTY FLAG AROUND
+ MOVE D,(P) ; CHANNEL
+ DOTCAL CORBLK,[[1000,,104000],[1000,,-1],A,D,C]
+ FATAL CORBLK ON RESTORE LOSSAGE
+ PUSHJ P,PURIN ; GET PURIFIED STRUCTURE
+ MOVSI A,(D) ; GET CHANNLEL BACK
+ ASH A,5
+ MOVEI B,E ; WHERE TO STRAT IN FILE
+ IOR A,[.ACCESS B]
+ XCT A ; ACCESS TO RIGHT ACS
+ XOR A,[<.IOT B>#<.ACCESS B>]
+ MOVE B,[D-P-1,,E]
+ XCT A ; GET ACS
+ MOVE E,0 ; NO TTY FLAG BACK
+ XOR A,[<.IOT B>#<.CLOSE>]
+ XCT A
+ MOVE A,GCSTOP ; GET CORE AND FOOL P.CORE
+ ADDI A,1777
+ ANDCMI A,1777
+ EXCH A,P.TOP ; GET P.TOP
+ ASH A,-10. ; TO PAGES
+ PUSHJ P,P.CORE
+ PUSHJ P,NOCORE
+ JRST FASTR1
+]
+
+IFE ITS,[
+FASTR: POP P,A ; JFN TO A
+ BIN ; CORE TOP TO B
+ MOVE E,B ; SAVE
+ BIN ; PARTOP
+ MOVE D,B
+ BIN ; SAVED P
+ MOVE P,B
+ MOVE 0,DEMFLG ; SAVE DEMFLG FLAG AROUND
+ HRL E,C ; SAVE VECTOP
+ MOVSI A,(A) ; JFN TO LH
+ MOVSI B,400000 ; FOR ME
+ MOVSI C,120400 ; FLAGS
+ ASH D,-9. ; PAGES TO D
+ PMAP
+ ADDI A,1
+ ADDI B,1
+ SOJG D,.-3
+
+ PUSHJ P,PURIN
+
+ HLRZS A
+ CLOSF
+ JFCL
+ MOVE E,0 ; DEMFLG TO E
+ JRST FASTR1
+]
+
+; HERE TO GROCK FILE NAME FROM ARGS
+
+GTFNM:
+IFN ITS,[
+ PUSH P,[0] ; DIRECTION
+ PUSH TP,$TPDL
+ PUSH TP,P
+ IRP A,,[DSK,MUDDLE,SAVE]
+ PUSH P,[SIXBIT /A/]
+ TERMIN
+ PUSHJ P,SGSNAM ; GET SNAME
+ PUSH P,A ; SAVE SNAME
+ JUMPGE AB,GTFNM1
+ PUSHJ P,RGPRS ; PARSE THESE ARGS
+ JRST .+2
+GTFNM1: AOS -5(P) ; SKIP RETURN
+ MOVE A,(P) ; GET SNAME
+ .SUSET [.SSNAM,,A]
+ MOVE A,-5(P) ; GET RET ADDR
+ SUB TP,[2,,2]
+ JRST (A)
+
+; HERE TO OUTPUT 1 WORD
+
+WRDOUT: PUSH P,B
+ PUSH P,A
+ HRROI B,(P) ; POINT AT C(A)
+ MOVE A,-3(P) ; CHANNEL
+ PUSHJ P,MIOT ;WRITE IT
+POPJB: POP P,A
+ POP P,B
+ POPJ P,
+
+; HERE TO READ 1 WORD
+WRDIN==WRDOUT
+]
+IFE ITS,[
+ PUSH P,C
+ PUSH P,B
+ MOVE B,IMQUOTE SNM
+ PUSHJ P,IDVAL1
+ GETYP 0,A
+ CAIN 0,TUNBOU
+ JRST GTFNM0
+ TRNN A,-1 ;ANY LENGTH?
+ PUSHJ P,%RSNAM ;IF <SNAME> IS "", GET REAL ONE
+ PUSHJ P,ADDNUL
+ SKIPA
+GTFNM0: MOVEI B,0
+ PUSH P,[377777,,377777]
+ PUSH P,[-1,,[ASCIZ /DSK/]]
+ PUSH P,B
+ PUSH P,[-1,,[ASCIZ /MUDDLE/]]
+ PUSH P,[-1,,[ASCIZ /SAVE/]]
+ PUSH P,[0]
+ PUSH P,[0]
+ PUSH P,[77] ; USE AN OBSCURE JFN IF POSSIBLE
+ MOVE A,(AB)
+ MOVE B,1(AB)
+ PUSHJ P,ADDNUL
+ MOVEI A,-10(P)
+ GTJFN
+ JRST FNF
+ SUB P,[9.,,9.]
+ POP P,B
+ OPENF
+ JRST FNF
+ ADD AB,[2,,2]
+ SKIPL AB
+CPOPJ1: AOS (P)
+CPOPJ: POPJ P,
+
+WRDIN: PUSH P,B
+ MOVE A,-2(P) ; JFN TO A
+ BIN
+ MOVE A,B
+ POP P,B
+ POPJ P,
+
+WRDOUT: PUSH P,B
+ MOVE B,-2(P)
+ EXCH A,B
+ BOUT
+ EXCH A,B
+ POP P,B
+ POPJ P,
+]
+
+
+;REPLACE ALL OCCURANCES OF CHARACTER (B) TO CHARACTER (C) IN A
+HACKV: PUSH P,D
+ PUSH P,E
+ MOVE D,[440700,,A]
+ MOVEI E,5
+HACKV1: ILDB 0,D
+ CAIN 0,(B) ; MATCH ?
+ DPB C,D ; YES, CLOBBER
+ SOJG E,HACKV1
+ POP P,E
+ POP P,D
+ POPJ P,
+
+
+CANTOP: ERRUUO EQUOTE CANT-OPEN-OUTPUT-FILE
+
+FNF: ERRUUO EQUOTE FILE-NOT-FOUND
+
+BADVRS: ERRUUO EQUOTE MUDDLE-VERSIONS-DIFFER
+
+
+CHNLO1: MOVE C,(TP)
+ SETZM 1(C)
+ JRST CHNLO2
+
+CHNLOS: MOVE C,(TP)
+ MOVE B,1(C)
+ SETZM 1(B) ; CLOBBER CHANNEL #
+ SETZM 1(C)
+CHNLO2: MOVEI B,[ASCIZ /
+CHANNEL-NOT-RESTORED
+/]
+ JRST MSGTYP"
+
+IFN ITS,[
+NOCORE: PUSH P,A
+ PUSH P,B
+ MOVEI B,[ASCIZ /
+WAIT, CORE NOT YET HERE
+/]
+ PUSHJ P,MSGTYP"
+ MOVE A,-1(P) ; RESTORE BLOCKS NEEDED
+ MOVEI B,1
+ .SLEEP B,
+ PUSHJ P,P.CORE
+ JRST .-4
+ MOVEI B,[ASCIZ /
+CORE ARRIVED
+/]
+ PUSHJ P,MSGTYP
+ POP P,B
+ POP P,A
+ POPJ P,
+]
+IFN UNTAST,[
+PUCHK: MOVEI E,HIBOT ; COMPUTE REAL START OF INTERPRETER
+ ASH E,-10. ; TO PAGES
+ MOVE A,PURTOP ; GET START TO POSSIBLE AREA CONTAINING P.S.
+ ASH A,-10. ; TO PAGES
+PURCH1: PUSHJ P,CHKPGI ; SEE IF PAGE IS PURIFIED
+ JFCL
+ ADDI A,1 ; INCREMENT PAGE COUNTER
+ CAMG A,E ; SKIP IF DONE
+ JRST PURCH1
+ POPJ P,
+]
+
+; THESE ROUTINES ARE USED BY SAVE AND RESTORE TO GET PAGES OF PURE STRUCTURE
+; INTO A SAVE FILE.
+
+PUROUT: MOVEI E,HIBOT ; COMPUTE REAL START OF INTERPRETER
+ ASH E,-10. ; TO PAGES
+ MOVE A,PURTOP ; GET START TO POSSIBLE AREA CONTAINING P.S.
+ ASH A,-10. ; TO PAGES
+PUROU2: PUSHJ P,CHKPGI ; SEE IF PAGE IS PURIFIED
+ JRST INCPUT
+ PUSH P,A ; SAVE A
+ ASH A,10. ; TO WORDS
+ HRLI A,-2000 ; MAKE UP AOBJN PTR FOR IOT
+ MOVE B,-2(P) ; RESTORE CHN #
+IFN ITS,[
+ DOTCAL IOT,[B,A]
+ FATAL SAVE--IOT FAILED
+]
+IFE ITS,[
+ PUSH P,C ; SAVE C
+ MOVE B,A ; SET UP BYTE POINTER
+ MOVE A,0 ; CHANNEL TO A
+ HRLI B,444400 ; SET UP BYTE POINTER
+ MOVNI C,2000
+ SOUT ; OUT IT GOES
+ POP P,C
+]
+
+ POP P,A ; RESTORE PAGE #
+INCPUT: ADDI A,1 ; INCREMENT PAGE COUNTER
+ CAMG A,E ; SKIP IF DONE
+ JRST PUROU2
+ POPJ P,
+
+
+IFN UNTAST,[
+
+CHKPGJ: TDZA 0,0
+]
+CHKPGI:
+IFN UNTAST,[
+ MOVEI 0,1
+]
+ PUSH P,A ; SAVE IT
+ IDIVI A,16. ; FIND ENTRY IN PMAP TABLE
+ MOVE C,PMAPB(A) ; GET WORD CONTAINING ENTRY
+ HRLZI D,400000 ; SET UP TEST WORD
+ IMULI B,2
+ MOVNS B
+ LSH D,(B) ; GET TO CHECK PAIR
+ LSH D,-1 ; TO BIT INDICATING SAVE
+ TDON C,D ; SKIP IF PAGE CONTAINS P.S
+ JRST PUROU1
+ POP P,A
+ AOS (P) ; SKIP ITS A WINNER
+IFN UNTAST,[
+ JUMPN 0,.+4
+ LSH D,1
+ TDNN C,D
+ AOS (P)
+] POPJ P, ; EXIT
+PUROU1:
+IFN UNTAST,[
+ JUMPE 0,CHKPG2
+IFN ITS,[
+ PUSH P,A
+ DOTCAL CORTYP,[A,[2000,,A],[2000,,0]]
+ FATAL DOTCAL FAILURE
+ SKIPN A
+ MOVEI 0,0
+ POP P,A
+ JUMPGE 0,CHKPG2
+]
+IFE ITS,[
+ PUSH P,A
+ PUSH P,B
+ LSH A,1
+ HRLI A,400000
+ RPACS
+ MOVE 0,B
+ POP P,B
+ POP P,A
+ TLC 0,150400
+ TRNE 0,150400
+ JRST CHKPG2
+]
+ LSH D,1
+ TDO C,D
+ MOVEM C,PMAPB(A)
+ AOS -1(P)
+CHKPG2:]
+ POP P,A
+ POPJ P,
+
+
+; ROUTINE TO READ IN PURE STRUCTURE PAGES
+
+IFN ITS,[
+PURIN: PUSH P,D ; SAVE CHANNEL #
+ MOVEI E,HIBOT ; COMPUTE REAL START OF INTERPRETER
+ ASH E,-10. ; TO PAGES
+ MOVE A,PURTOP ; GET START TO POSSIBLE AREA CONTAINING P.S.
+ ASH A,-10. ; TO WORDS
+PURIN1:
+IFN UNTAST, PUSHJ P,CHKPGJ ; SEE IF PURE PAGE EXISTS
+IFE UNTAST, PUSHJ P,CHKPGI ; SEE IF PURE PAGE EXISTS
+ JRST NXPGPN
+IFN UNTAST,[
+ SKIPA D,[200000]
+ MOVEI D,[104000]
+ MOVSI 0,(D)
+]
+ PUSH P,A ; SAVE A
+ MOVE D,-1(P) ; RESTORE CHANNEL #
+ HRLI A,-1 ; SET UP AOBJN POINTER FOR DOTCAL
+IFN UNTAST,[
+ DOTCAL CORBLK,[0,[1000,,-1],A,D]
+]
+IFE UNTAST,[
+ DOTCAL CORBLK,[[1000,,200000],[1000,,-1],A,D]
+]
+ FATAL SAVE--CORBLK FAILED
+ POP P,A ; RESTORE A
+NXPGPN: ADDI A,1
+ CAMG A,E ; SKIP IF DONE
+ JRST PURIN1
+ POP P,D ; RESTORE CHANNEL
+ POPJ P,
+]
+IFE ITS,[
+PURIN: PUSH P,A ; SAVE CHANNEL
+ MOVEI E,HIBOT ; TOP OF SCAN
+ ASH E,-10.
+ MOVE A,PURBOT ; BOTTOM OF SCAN
+ ASH A,-10. ; TO PAGES
+PURIN1: PUSHJ P,CHKPGI ; SEE IF PAGE IS NEEDED
+ JRST NXTPGN
+ SKIPA C,[120000]
+ MOVEI C,120400
+ PUSH P,A
+ MOVE B,A ; COPY TO B
+ ASH B,1 ; FOR TEXEX PAGES
+ HRLI B,MFORK ; SET UP ARGS TO PMAP
+ MOVSI C,(C)
+ MOVE A,-1(P) ; GET FILE POINTER
+ PMAP ; IN IT COMES
+ ADDI B,1 ; INCREMENT B
+ ADDI A,1 ; AND A
+ PMAP ; SECOND HALF OF ITS PAGE
+ ADDI A,1
+ MOVEM A,-1(P) ; SAVE FILE PAGE
+ POP P,A
+NXTPGN: ADDI A,1
+ CAMG A,E ; SKIP IF DONE
+ JRST PURIN1
+ POP P,A ; RESTOR CHANNEL
+ POPJ P, ;EXIT
+]
+CKVRS: PUSH P,-1(P)
+ PUSHJ P,WRDIN ; READ MUDDLE VERSION
+ MOVEI B,40 ; CHANGE ALL SPACES
+ MOVEI C,177 ; ----- TO RUBOUT CHARACTERS
+ PUSHJ P,HACKV
+ CAME A,MUDSTR+2 ; AGREE ?
+ JRST BADVRS
+ SUB P,[1,,1] ; POP OFF CHANNEL #
+ POPJ P,
+
+IFE ITS,[
+JFNTBL: SETZ IJFNS
+ SETZ IJFNS1
+ SETZ MAPJFN
+ SETZ DIRCHN
+
+JFNLNT==.-JFNTBL
+]
+END
+
+\f
\ No newline at end of file
--- /dev/null
+
+TITLE SECAGC MUDDLE GARBAGE COLLECTOR FOR MULTI SECTIONS
+
+;SYSTEM WIDE DEFINITIONS GO HERE
+
+RELOCATABLE
+.SYMTAB 3337.
+GCST==$.
+TOPGRO==111100
+BOTGRO==001100
+MFORK==400000
+.GLOBAL SHRRM,SHRLM,SMOVEM,SSETZM,SXBLT,SHLRZ
+.GLOBAL RCL,VECTOP,GCSTOP,GCSBOT,FRETOP,GCSNEW,VECBOT,PARTOP,PARBOT,HITOP,HIBOT,GETPAG
+.GLOBAL PDLBUF,PDLEX,PDLEXP,GCFLG,GCPDL,GETNUM,PARNEW,MOVPUR,RCLV,RCLVEC,PGCNT
+.GLOBAL PGROW,TPGROW,MAINPR,%SLEEP,MSGTYP,PURTOP,PURBOT,STOSTR,GCSET,CKPUR
+.GLOBAL MTYI,UPLO,FRMUNG,BYTDOP,GLOBSP,FREDIF,FREMIN,GCHAPN,INTFLG,FINAGC,NGCS,INQAGC
+.GLOBAL SAT,TTOCHN,TYPVEC,ICONS,INCONS,IBLOCK,IEUVEC,IEVECTI,CELL2,MKTBS,RLENGC
+.GLOBAL GIBLOK,REHASH,IBLOK1,IILIST,IIFORM,CIVEC,CIUVEC,CICONS,CPOPJ,RBLDM
+.GLOBAL SPBASE,OUTRNG,CISTNG,CBYTES,%RUNAM,PURVEC,GCDOWN,N.CHNS,CHNL1,PLODR
+.GLOBAL CAFRE,CAFRET,STOGC,GCHN,WNDP,FRNP,FRONT,%GCJOB,%SHWND,%INFMP,%GETIP,CHKPGI
+.GLOBAL TD.PUT,TD.GET,TD.AGC,TD.AGC,TD.LNT,GLOTOP,UBIT,FLGSET,PURMNG,RPURBT,%IFMP2
+.GLOBAL CTIME,IMTYO,ILOC,NODES,GPURFL,GCDANG,GCHACK,LPUR,HITOP,BADCHN,IMPURX,PURCLN
+.GLOBAL GCTIM,GCCAUS,GCCALL,IAAGC,LVLINC,STORIC,GVLINC,TYPIC,GCRSET,ACCESS,NOSHUF,SQUPNT
+; GLOBALS ASSOCIATE WITH THE ASSOCIATION VECTOR
+
+.GLOBAL ASOVEC,ASOLNT,ITEM,INDIC,VAL,NWORDT,NODPNT,PNTRS,DSTORE,HASHTB
+.GLOBAL CELL,BINDID,GCFLCH,TYPBOT,GLOBAS,TPBASE,NOWLVL,CURPLN,PVSTOR,SPSTOR
+.GLOBAL ISECGC,SECLEN,RSECLE
+.GLOBAL P.TOP,P.CORE,PMAPB,IGET,CIGTPR,ROOT,STBL,CAFREE,%MPIN1,%PURIF,%MPINX,GCHK10
+.GLOBAL %SAVRP,%RSTRP,LENGC,AGCLD,PAGEGC,REALGC
+.GLOBAL %MPINT,%GBINT,%CLSMP,%CLSM1,PINIT,PGFIND,NPRFLG
+.GLOBAL GCKNUM,CORTOP,GCHPN,INTAGC,WNDP,WNDBOT,BUFGC,WIND,GCDFLG,SAVM,AGC,GCSET
+
+.GLOBAL INBLOT,RSLENG
+
+NOPAGS==1 ; NUMBER OF WINDOWS
+EOFBIT==1000
+PDLBUF=100
+NTPMAX==20000 ; NORMAL MAX TP SIZE
+NTPGOO==4000 ; NORMAL GOOD TP
+ETPMAX==2000 ; TPMAX IN AN EMERGENCY (I.E. GC RECALL)
+ETPGOO==2000 ; GOOD TP IN EMERGENCY
+
+
+GCHN==0 ; CHANNEL FOR FUNNNY INFERIOR
+STATNO==19. ; # OF STATISTICS FOR BLOAT-STAT
+STATGC==8. ; # OF GC-STATISTICS FOR BLOAT-STAT
+
+
+LOC REALGC+RLENGC+RSLENG
+OFFS==AGCLD-$.
+OFFSET OFFS
+
+.INSRT MUDDLE >
+
+.INSRT STENEX >
+
+PGSZ==9.
+
+F==E+1 ; THESE 3 ACS OFTEN USED FOR XBLT
+G==F+1
+FPTR==G+1
+
+TYPNT==FPTR+1 ; SPECIAL AC USAGE DURING GC
+EXTAC==TYPNT+1 ; ALSO SPECIAL DURING GC
+LPVP==EXTAC+1 ; SPECIAL FOR GC, HOLDS POINTER TO PROCESS
+ ; CHAIN
+.LIST.==400000
+.GLOBAL %FXUPS,%FXEND
+\f
+
+
+DEFINE DOMULT INS
+ FOOIT [INS]
+TERMIN
+
+DEFINE FOOIT INS,\LCN
+ LCN==.-OFFS
+ INS
+ RMT [
+ TBLADD LCN
+ ]
+TERMIN
+
+RMT [%FXLIN==0
+]
+
+DEFINE TBLADD LCN,\FOO
+ FOO==.-OFFS
+ %FXLIN,,LCN
+ %FXLIN==FOO
+ %FXUPS==FOO
+ TERMIN
+
+
+RMT [XBLT==123000,,%XXBLT
+]
+
+\f
+
+ISECGC:
+
+;SET FLAG FOR INTERRUPT HANDLER
+ SETZB M,RCL ; CLEAR OUT RECYCLE LIST CELLS, AND RSUBR BASE
+ ; PNTR
+ EXCH P,GCPDL ; IN CASE CURRENT PDL LOSES
+ PUSH P,B
+ PUSH P,A
+ PUSH P,C ; SAVE C
+
+; HERE TO CLEAN UP ANY POSSIBLE PURENESS IN GC SPACE BEFORE COLLECTING
+
+ MOVE A,NOWFRE
+ ADD A,GCSTOP ; ADJUSTMENT TO KEEP FREE REAL
+ SUB A,FRETOP
+ MOVEM A,NOWFRE
+ MOVE A,NOWP ; ADJUSTMENTS FOR STACKS
+ SUB A,CURP
+ MOVEM A,NOWP
+ MOVE A,NOWTP
+ SUB A,CURTP
+ MOVEM A,NOWTP
+
+ MOVEI B,[ASCIZ /SGIN /]
+ SKIPE GCMONF ; MONITORING
+ PUSHJ P,MSGTYP
+NOMON1: HRRZ C,(P) ; GET CAUSE OF GC INDICATOR
+ MOVE B,GCNO(C) ; ADD 1 TO COUNT OF GC'S CAUSED BY GIVEN REASON
+ ADDI B,1
+ MOVEM B,GCNO(C)
+ MOVEM C,GCCAUS ; SAVE CAUSE OF GC
+ SKIPN GCMONF ; MONITORING
+ JRST NOMON2
+ MOVE B,MSGGCT(C) ; GET CAUSE MESSAGE
+ PUSHJ P,MSGTYP
+NOMON2: HLRZ C,(P) ; FIND OUT WHO CAUSED THE GC
+ MOVEM C,GCCALL ; SAVE CALLER OF GC
+ SKIPN GCMONF ; MONITORING
+ JRST NOMON3
+ MOVE B,MSGGFT(C)
+ PUSHJ P,MSGTYP
+NOMON3: ADJSP P,-1 ; POP OFF C
+ POP P,A
+ POP P,B
+ EXCH P,GCPDL
+ HLLZS SQUPNT ; FLUSH SQUOZE TABLE
+INITGC: SETOM GCFLG
+ SETZM RCLV
+
+;SAVE AC'S
+ EXCH PVP,PVSTOR+1
+ IRP AC,,[0,A,B,C,D,E,P,R,M,SP,TP,TB,AB,TVP,FRM]
+ MOVEM AC,AC!STO"+1(PVP)
+ TERMIN
+
+ MOVE 0,PVSTOR+1
+ MOVEM 0,PVPSTO+1(PVP)
+ MOVEM PVP,PVSTOR+1
+ MOVE D,DSTORE
+ MOVEM D,DSTO(PVP)
+ JSP E,CKPUR ; CHECK FOR PURE RSUBR
+
+;SET UP E TO POINT TO TYPE VECTOR
+
+ GETYP E,TYPVEC
+ CAIE E,TVEC
+ JRST AGCE1
+ HRRZ TYPNT,TYPVEC+1
+ HRLI TYPNT,400000+B ; LOCAL INDEX
+
+CHPDL: MOVE D,P ; SAVE FOR LATER
+CORGET: MOVE P,[GCSEG,,MRKPDL] ; USE GCSEG FOR PDL
+
+;FENCE POST PDLS AND CHECK IF ANY SHOULD BE SHRUNK
+
+ HRRZ A,TB ;POINT TO CURRENT FRAME IN PROCESS
+ PUSHJ P,FRMUNG ;AND MUNG IT
+ MOVE A,TP ;THEN TEMPORARY PDL
+ PUSHJ P,PDLCHK
+ MOVE PVP,PVSTOR+1
+ MOVE A,PSTO+1(PVP) ;AND UNMARKED P STACK
+ PUSHJ P,PDLCHP
+
+\f; FIRST CREATE INFERIOR TO HOLD NEW PAGES
+
+INFCRT: MOVE A,PARBOT ; GENERATE NEW PARBOT AND PARNEW
+ ADD A,PARNEW
+ ADDI A,1777
+ ANDCMI A,1777 ; EVEN PAGE BOUNDARY
+ MOVEM A,NPARBO
+ MOVE FPTR,A
+ HRLI FPTR,GCSEG
+
+; NOW ZERO OUT NEW SPACE USING XBLT
+
+; DOMULT [SETZM (FPTR)]
+; MOVEI 0,777777-1
+; SUBI 0,(FPTR) ; FROM VECBOT UP
+; MOVE A,FPTR
+; MOVE B,A
+; ADDI B,1
+; DOMULT [XBLT 0,]
+
+; USE PMAP TO FLUSH GC SPACE PAGES
+
+ MOVNI A,1
+ MOVE B,[MFORK,,GCSEG_9.]
+ MOVE C,[SETZ 777]
+ PMAP
+
+;MARK PHASE: MARK ALL LISTS AND VECTORS
+;POINTED TO WITH ONE BIT IN SIGN BIT
+;START AT TRANSFER VECTOR
+NOMAP: MOVE A,GLOBSP+1 ; GET GLOBSP TO SAVE
+ MOVEM A,GCGBSP
+ MOVE A,ASOVEC+1 ; ALSO SAVE FOR USE BY GC
+ MOVEM A,GCASOV
+ MOVE A,NODES+1 ; SAVE FOR ASSOCIATION UPDATE AND MOVEMENT
+ ; PHASE
+ MOVEM A,GCNOD
+ MOVE A,GLOTOP+1 ; GET GLOTOP FOR LOCR HACKS
+ MOVEM A,GLTOP
+ MOVE A,PURVEC+1 ; SAVE PURE VECTOR FOR GETPAG
+ MOVEM A,PURSVT
+ MOVE A,HASHTB+1
+ MOVEM A,GCHSHT
+
+ SETZ LPVP, ;CLEAR NUMBER OF PAIRS
+ MOVE 0,NGCS ; SEE IF NEED HAIR
+ SOSGE GCHAIR
+ MOVEM 0,GCHAIR ; RESUME COUNTING
+ MOVSI D,400000 ;SIGN BIT FOR MARKING
+ MOVE A,ASOVEC+1 ;MARK ASSOC. VECTOR NOW
+ PUSHJ P,PRMRK ; PRE-MARK
+ MOVE A,GLOBSP+1
+ PUSHJ P,PRMRK
+ MOVE A,HASHTB+1
+ PUSHJ P,PRMRK
+OFFSET 0
+
+ MOVE A,IMQUOTE THIS-PROCESS
+
+OFFSET OFFS
+
+ MOVEM A,GCATM
+
+; HAIR TO DO AUTO CHANNEL CLOSE
+
+ MOVEI 0,N.CHNS-1 ; NUMBER OF CHANNELS
+ MOVEI A,CHNL1 ; 1ST SLOT
+
+ SKIPE 1(A) ; NOW A CHANNEL?
+ SETZM (A) ; DON'T MARK AS CHANNELS
+ ADDI A,2
+ SOJG 0,.-3
+
+ MOVEI C,PVSTOR
+ MOVEI B,TPVP
+ MOVE A,PVSTOR+1 ; MARK MAIN PROCES EVEN IF SWAPPED OUT
+ PUSHJ P,MARK
+ MOVEI C,MAINPR-1
+ MOVEI B,TPVP
+ MOVE A,MAINPR ; MARK MAIN PROCES EVEN IF SWAPPED OUT
+ PUSHJ P,MARK
+ MOVEM A,MAINPR ; ADJUST PTR
+
+; ASSOCIATION AND VALUE FLUSHING PHASE
+
+ SKIPN GCHAIR ; ONLY IF HAIR
+ PUSHJ P,VALFLS
+
+ SKIPN GCHAIR
+ PUSHJ P,ATCLEA ; CLEAN UP ATOM TABLE
+
+ SKIPE GCHAIR ; IF NOT HAIR, DO CHANNELS NOW
+ PUSHJ P,CHNFLS
+
+ PUSHJ P,ASSOUP ; UPDATE AND MOVE ASSOCIATIONS
+ PUSHJ P,CHFIX ; SEND OUT CHANNELS AND MARK LOSERS
+ PUSHJ P,STOGC ; FIX UP FROZEN WORLD
+ MOVE P,GCPDL ; SWITCH PDLS IN CASE THIS ONE DISSAPPEARS
+
+ MOVE A,NPARBO ; UPDATE GCSBOT
+ MOVEM A,GCSBOT
+ MOVE A,PURSVT
+ PUSH P,PURVEC+1
+ MOVEM A,PURVEC+1 ; RESTORE PURVEC
+ PUSHJ P,CORADJ ; ADJUST CORE SIZE
+ POP P,PURVEC+1
+
+
+
+\f
+; MOVE NEW GC SPACE IN
+
+NOMAP1: MOVE A,P.TOP
+ SUBI A,1
+ MOVE C,PARBOT
+ MOVE B,C
+ SUB A,B
+ HRLI B,GCSEG
+ DOMULT [XBLT A,]
+
+\f
+; NOW REHASH THE ASSOCIATIONS BASED ON VALUES
+GARZR1: PUSHJ P,REHASH
+
+
+\f;RESTORE AC'S
+TRYCOX: SKIPN GCMONF
+ JRST NOMONO
+ MOVEI B,[ASCIZ /GOUT /]
+ PUSHJ P,MSGTYP
+NOMONO: MOVE PVP,PVSTOR+1
+ IRP AC,,[0,A,B,C,D,E,P,R,M,SP,TP,TB,AB,TVP,FRM]
+ MOVE AC,AC!STO+1(PVP)
+ TERMIN
+ SKIPN DSTORE
+ SETZM DSTO(PVP)
+ MOVE PVP,PVPSTO+1(PVP)
+
+; CLOSING ROUTINE FOR G-C
+ PUSH P,A ; SAVE AC'C
+ PUSH P,B
+ PUSH P,C
+ PUSH P,D
+
+ MOVE A,FRETOP ; ADJUST BLOAT-STAT PARAMETERS
+ SUB A,GCSTOP
+ ADDM A,NOWFRE
+ PUSHJ P,GCSET ; FIX UP BLOAT-STAT PARAMETERS
+ MOVE A,CURTP
+ ADDM A,NOWTP
+ MOVE A,CURP
+ ADDM A,NOWP
+
+ PUSHJ P,CTIME
+ FSBR B,GCTIM ; GET TIME ELAPSED
+ SKIPN INBLOT ; STORE TIME ONLY IF NO RETRY
+ SKIPN GCDANG
+ MOVEM B,GCTIM ; SAVE ELAPSED TIME FOR INT-HANDLER
+ SKIPN GCMONF ; SEE IF MONITORING
+ JRST GCCONT
+ PUSHJ P,FIXSEN ; OUTPUT TIME
+ MOVEI A,15 ; OUTPUT C/R LINE-FEED
+ PUSHJ P,IMTYO
+ MOVEI A,12
+ PUSHJ P,IMTYO
+GCCONT: MOVE C,[NTPGOO,,NTPMAX] ; MAY FIX UP TP PARAMS TO ENCOURAGE
+ ; SHRINKAGE FOR EXTRA ROOM
+ SKIPE GCDANG
+ MOVE C,[ETPGOO,,ETPMAX]
+ HLRZM C,TPGOOD
+ HRRZM C,TPMAX
+ POP P,D ; RESTORE AC'C
+ POP P,C
+ POP P,B
+ POP P,A
+ MOVE A,GCDANG
+ JUMPE A,AGCWIN ; IF ZERO THE GC WORKED
+ SKIPN GCHAIR ; SEE IF HAIRY GC
+ JRST BTEST
+REAGCX: MOVEI A,1 ; PREPARE FOR A HAIRY GC
+ MOVEM A,GCHAIR
+ SETZM GCDANG
+ MOVE C,[11,,10.] ; REASON FOR GC
+ JRST ISECGC
+
+BTEST: SKIPE INBLOT
+ JRST AGCWIN
+ FATAL AGC--NO CORE AVAILABLE TO SATISFY REQUESTS
+ JRST REAGCX
+
+AGCWIN: SETZM PARNEW ;CLEAR FOR NEXT AGC CALL
+ SETZM GETNUM ;ALSO CLEAR THIS
+ SETZM INBLOT
+ SETZM GCFLG
+
+ SETZM PGROW ; CLEAR GROWTH
+ SETZM TPGROW
+ SETOM GCHAPN ; INDICATE A GC HAS HAPPENED
+ SETOM GCHPN
+ SETOM INTFLG ; AND REQUEST AN INTERRUPT
+ SETZM GCDOWN
+ PUSHJ P,RBLDM
+ JUMPE R,FINAGC
+ JUMPN M,FINAGC ; IF M 0, RUNNING RSUBR SWAPPED OUT
+ SKIPE PLODR ; IF LOADING ONE, IT MIGHT NOT HAVE ARRIVED
+ JRST FINAGC
+
+ FATAL AGC--RUNNING RSUBR WENT AWAY
+
+AGCE1: FATAL AGC--TYPE VECTOR NOT OF TYPE VECTOR
+
+\f; CORE ADJUSTMENT PHASE
+
+CORADJ: MOVE A,PURTOP
+ SUB A,CURPLN ; ADJUST FOR RSUBR
+ MOVEM A,RPTOP
+ HRRZ A,FPTR ; NEW GCSTOP
+ ADDI A,1777 ; GCPDL AND ROUND
+ ANDCMI A,1777 ; TO PAGE BOUNDRY
+ MOVEM A,CORTOP ; TAKE CARE OF POSSIBLE LATER LOSSAGE
+ CAMLE A,RPTOP ; SEE IF WE CAN MAP THE WORLD BACK IN
+ FATAL AGC--UNABLE TO MAP GC-SPACE INTO CORE
+ CAMG A,PURBOT ; SEE IF WE HAVE TO PUNT SOME PURE TO DO IT
+ JRST CORAD0 ; DON'T HAVE TO PUNT SOME PURE
+ PUSHJ P,MAPOUT ; GET THE CORE
+ FATAL AGC--PAGES NOT AVAILABLE
+
+; NOW THAT WE ARE ABLE TO MAP TO GCS INTO CORE WE WILL TRY TO HONOR SOME REQUESTS
+; FIRST LETS SEE IF WE HAVE TO CORE DOWN.
+; GCDOWN IS DEFINED AS AMOUNT FROM FRETOP TO PURBOT NEEDED
+
+CORAD0: SKIPN B,GCDOWN ; CORE DOWN?
+ JRST CORAD1 ; NO, LETS GET CORE REQUIREMENTS
+ ADDI A,(B) ; AMOUNT+ONE FREE BLOCK
+ CAMGE A,RPTOP ; CAN WE WIN
+ JRST CORAD3 ; POSSIBLY
+
+; THIS IS A EXIT FOR LOSSAGE WITHOUT A FATAL ERROR
+CORAD2: SETOM GCDANG ; INDICATE LOSSAGE
+
+; CALCULATE PARAMETERS BEFORE LEAVING
+CORAD6: MOVE A,PURSVT ; GET PURE TABLE
+ PUSHJ P,SPCOUT ; OUT IT GOES IN CASE IT WAS CHANGED
+ HRRZ A,FPTR ; GCSTOP
+ MOVEM A,GCSTOP
+ MOVE A,CORTOP ; ADJUST CORE IMAGE
+ ASH A,-10. ; TO PAGES
+TRYPCO: PUSHJ P,P.CORE
+ FATAL NO CORE?
+ MOVE A,CORTOP ; GET IT BACK
+ ANDCMI A,1777
+ MOVEM A,FRETOP
+ MOVEM A,RFRETP
+ POPJ P,
+
+
+; TRIES TO SATISFY REQUEST FOR CORE
+CORAD1: MOVEM A,CORTOP
+ HRRZ A,FPTR
+ ADD A,GETNUM ; ADD MINIMUM CORE NEEDED
+ ADDI A,1777 ; ONE BLOCK+ROUND
+ ANDCMI A,1777 ; TO BLOCK BOUNDRY
+ CAMLE A,RPTOP ; CAN WE WIN
+ JRST CORAD2 ; LOSE
+ CAMGE A,PURBOT
+ JRST CORAD7 ; DON'T HAVE TO MAP OUT PURE
+ PUSHJ P,MAPOUT
+ JRST CORAD2 ; LOSS
+
+; NOW TRY TO GET SLOP SPACE. NOT NECESSARY BUT NICE
+CORAD7: MOVEM A,CORTOP ; STORE POSSIBLE VALUE
+ MOVE B,RPTOP ; GET REAL PURTOP
+ SUB B,PURMIN ; KEEP PURMIN
+ CAMG B,CORTOP ; SEE IF CORTOP IS ALREADY HIGH
+ MOVE B,CORTOP ; DONT GIVE BACK WHAT WE GOT
+ MOVEM B,RPTOP ; FOOL CORE HACKING
+ ADD A,FREMIN
+ ANDCMI A,1777 ; TO PAGE BOUNDRY
+ CAMGE A,RPTOP ; DO WE WIN TOTALLY
+ JRST CORAD4
+ MOVE A,RPTOP ; GET AS MUCH CORE AS POSSIBLE
+ PUSHJ P,MAPOUT
+ JRST CORAD6 ; LOSE, BUT YOU CAN'T HAVE EVERYTHING
+CORAD4: CAMG A,PURBOT ; DO WE HAVE TO PUNT SOME PURE
+ JRST CORAD8
+ PUSHJ P,MAPOUT ; GET IT
+ JRST CORAD6
+ MOVEM A,CORTOP ; ADJUST PARAMETER
+ JRST CORAD6 ; WIN TOTALLY
+CORAD8: MOVEM A,CORTOP ; NEW CORTOP
+ JRST CORAD6
+
+; WE CAN CORE DOWN NOW TO SEE IF WE CAN GET SOME SLOP SPACE
+
+CORAD3: ADD A,FREMIN
+ ANDCMI A,1777
+ CAMGE A,PURBOT ; CAN WE WIN
+ JRST CORAD9
+ MOVE A,RPTOP
+CORAD9: SUB A,GCDOWN ; SATISFY GCDOWN REQUEST
+ JRST CORAD4 ; GO CHECK ALLOCATION
+
+MAPOUT: PUSH P,A ; SAVE A
+ SUB A,P.TOP ; AMOUNT TO GET
+ ADDI A,1777 ; ROUND
+ ANDCMI A,1777 ; TO PAGE BOUNDRY
+ ASH A,-PGSZ ; TO PAGES
+ PUSHJ P,GETPAG ; GET THEN
+ JRST MAPLOS ; LOSSAGE
+ AOS -1(P) ; INDICATE WINNAGE
+MAPLOS: POP P,A
+ POPJ P,
+
+
+
+\f; CONVERSION FROM FLOAT TO DECIMAL. X 100 AND SEND OUT WITH APPROPRIATELY PLACED DECIMAL
+; POINT.
+
+FIXSEN: PUSH P,B ; SAVE TIME
+ MOVEI B,[ASCIZ /TIME= /]
+ PUSHJ P,MSGTYP ; PRINT OUT MESSAGE
+ POP P,B ; RESTORE B
+ FMPRI B,(100.0) ; CONVERT TO FIX
+ MULI B,400
+ TSC B,B
+ ASH C,-163.(B)
+ MOVEI A,1 ; INITIALIZE COUNT OF CHARACTERS FOR PUTTING OUT TIME
+ PUSH P,C
+ IDIVI C,10. ; START COUNTING
+ JUMPLE C,.+2
+ AOJA A,.-2
+ POP P,C
+ CAIN A,1 ; SEE IF THERE IS ONLY ONE CHARACTER
+ JRST DOT1
+FIXOUT: IDIVI C,10. ; RECOVER NUMBER
+ HRLM D,(P)
+ SKIPE C
+ PUSHJ P,FIXOUT
+ PUSH P,A ; SAVE A
+ CAIN A,2 ; DECIMAL POINT HERE?
+ JRST DOT2
+FIX1: HLRZ A,(P)-1 ; GET NUMBER
+ ADDI A,60 ; MAKE IT A CHARACTER
+ PUSHJ P,IMTYO ; OUT IT GOES
+ MOVEI A,FSEG
+ HRLM A,-1(P)
+ POP P,A
+ SOJ A,
+ POPJ P,
+DOT1: MOVEI A,". ; OUTPUT DECIMAL POINT AND PADDING 0
+ PUSHJ P,IMTYO
+ MOVEI A,"0
+ PUSHJ P,IMTYO
+ JRST FIXOUT ; CONTINUE
+DOT2: MOVEI A,". ; OUTPUT DECIMAL POINT
+ PUSHJ P,IMTYO
+ JRST FIX1
+
+
+\f; SUBROUTINE TO CHECK SIZE OF PDLS AND DO FENCEPOSTING
+
+PDLCHK: JUMPGE A,CPOPJ
+ HLRE B,A ;GET NEGATIVE COUNT
+ MOVE C,A ;SAVE A COPY OF PDL POINTER
+ SUBI A,-1(B) ;LOCATE DOPE WORD PAIR
+ HRRZS A ; ISOLATE POINTER
+ CAME A,TPGROW ;GROWING?
+ ADDI A,PDLBUF ;NO, POINT TO REAL DOPE WORD
+ MOVMS B
+ CAIN A,2(C)
+ JRST NOFENC
+ SETOM 1(C) ; START FENECE POST
+ CAIN A,3(C)
+ JRST NOFENC
+ MOVSI D,1(C) ;YES, SET UP TO BLT FENCE POSTS
+ HRRI D,2(C)
+ BLT D,-2(A) ;FENCE POST ALL EXCEPT DOPE WORDS
+
+
+NOFENC: CAMG B,TPMAX ;NOW CHECK SIZE
+ CAMG B,TPMIN
+ JRST MUNGTP ;TOO BIG OR TOO SMALL
+ POPJ P,
+
+MUNGTP: SUB B,TPGOOD ;FIND DELTA TP
+MUNG3: MOVE C,-1(A) ;IS GROWTH ALREADY SPECIFIED
+ TRNE C,777000 ;SKIP IF NOT
+ POPJ P, ;ASSUME GROWTH GIVEN WILL WIN
+
+ ASH B,-6 ;CONVERT TO NUMBER OF BLOCKS
+ JUMPLE B,MUNGT1
+ CAILE B,377 ; SKIP IF BELOW MAX
+ MOVEI B,377 ; ELSE USE MAX
+ TRO B,400 ;TURN ON SHRINK BIT
+ JRST MUNGT2
+MUNGT1: MOVMS B
+ ANDI B,377
+MUNGT2: DPB B,[TOPGRO,,-1(A)] ;STORE IN DOPE WORD
+ POPJ P,
+
+; CHECK UNMARKED STACK (NO NEED TO FENCE POST)
+
+PDLCHP: HLRE B,A ;-LENGTH TO B
+ MOVE C,A
+ SUBI A,-1(B) ;POINT TO DOPE WORD
+ HRRZS A ;ISOLATE POINTER
+ CAME A,PGROW ;GROWING?
+ ADDI A,PDLBUF ;NO, POINT TO REAL DOPE WORD
+ MOVMS B
+ CAIN A,2(C)
+ JRST NOPF
+ SETOM 1(C) ; START FENECE POST
+ CAIN A,3(C)
+ JRST NOPF
+ MOVSI D,1(C)
+ HRRI D,2(C)
+ BLT D,-2(A)
+
+NOPF: CAMG B,PMAX ;TOO BIG?
+ CAMG B,PMIN ;OR TOO LITTLE
+ JRST .+2 ;YES, MUNG IT
+ POPJ P,
+ SUB B,PGOOD
+ JRST MUNG3
+
+
+; ROUTINE TO PRE MARK SPECIAL HACKS
+
+PRMRK: SKIPE GCHAIR ; FLUSH IF NO HAIR
+ POPJ P,
+PRMRK2: HLRE B,A
+ SUBI A,(B) ;POINT TO DOPE WORD
+ HLRZ EXTAC,1(A) ; GET LNTH
+ LDB 0,[TOPGRO,,(A)] ; GET GROWTHS
+ TRZE 0,400 ; SIGN HACK
+ MOVNS 0
+ ASH 0,6 ; TO WORDS
+ ADD EXTAC,0
+ LDB 0,[BOTGRO,,(A)]
+ TRZE 0,400
+ MOVNS 0
+ ASH 0,6
+ ADD EXTAC,0
+ PUSHJ P,ALLOGC
+ HRRM 0,1(A) ; NEW RELOCATION FIELD
+ IORM D,1(A) ;AND MARK
+ POPJ P,
+
+
+\f;GENERAL MARK SUBROUTINE. CALLED TO MARK ALL THINGS
+; A/ GOODIE TO MARK FROM
+; B/ TYPE OF A (IN RH)
+; C/ TYPE,DATUM PAIR POINTER
+
+MARK2A:
+MARK2: HLRZ B,(C) ;GET TYPE
+MARK1: MOVE A,1(C) ;GET GOODIE
+MARK: JUMPE A,CPOPJ ; NEVER MARK 0
+ MOVEI 0,1(A)
+ CAML 0,PURBOT
+ JRST GCRETD
+MARCON: PUSH P,C
+ PUSH P,A
+ ANDI B,TYPMSK ; FLUSH MONITORS
+ LSH B,1 ;TIMES 2 TO GET SAT
+ HRRZ B,@TYPNT ;GET SAT
+ ANDI B,SATMSK
+ JUMPE A,GCRET
+ CAILE B,NUMSAT ; SKIP IF TEMPLATE DATA
+ JRST TD.MRK
+ JRST @SMKTBS(B)
+
+SMKTBS:
+
+OFFSET 0
+
+TBLDIS DUM2,GCRET,[[S2WORD,PAIRMK],[S2DEFR,DEFMK],[SNWORD,VECTMK],[STBASE,TBMK]
+[STPSTK,TPMK],[SARGS,ARGMK],[S2NWORD,VECTMK],[SPSTK,TPMK],[SSTORE,VECTMK]
+[SFRAME,FRMK],[SBYTE,BYTMK],[SATOM,ATOMK],[SPVP,VECTMK],[SGATOM,GATOMK]
+[SLOCID,LOCMK],[SCHSTR,BYTMK],[SASOC,ASMRK],[SLOCL,PAIRMK],[SABASE,ABMK]
+[SLOCA,ARGMK],[SLOCV,VECTMK],[SLOCU,VECTMK],[SLOCS,BYTMK],[SLOCN,ASMRK]
+[SLOCR,LOCRMK],[SRDTB,GCRDMK],[SLOCB,BYTMK],[SDEFQ,DEFQMK],[SOFFS,OFFSMK]]NUMSAT,400000
+
+OFFSET OFFS
+
+; HERE TO MARK A POSSIBLE DEFER POINTER
+
+DEFQMK: GETYP B,(A) ; GET ITS TYPE
+ LSH B,1
+ HRRZ B,@TYPNT
+ ANDI B,SATMSK ; AND TO SAT
+ SKIPGE MKTBS(B)
+
+;HERE TO MARK THAT WHICH IS POINTED TO BY A DEFERRED POINTER
+
+DEFMK: SETOM GENFLG ; SET FLAG SAYING DEFERRED
+ CAIA
+
+;HERE TO MARK LIST ELEMENTS
+
+PAIRMK: SETZM GENFLG ;TURN OF DEFER BIT
+ PUSH P,[0] ; WILL HOLD BACK PNTR
+ MOVEI C,(A) ; POINT TO LIST
+PAIRM1: CAMGE C,PARTOP ;CHECK FOR BEING IN BOUNDS
+ CAMGE C,PARBOT
+ FATAL AGC--MARKED PAIR OUTSIDE PAIR SPACE
+ SKIPGE B,(C) ;SKIP IF NOT MARKED
+ JRST RETNEW ;ALREADY MARKED, RETURN
+ IORM D,(C) ;MARK IT
+ DOMULT [MOVEM B,(FPTR)]
+ MOVE 0,1(C) ; AND 2D
+ DOMULT [MOVEM 0,1(FPTR)]
+ ADDI FPTR,2 ; MOVE ALONG IN NEW SPACE
+
+PAIRM2: MOVEI A,-2(FPTR) ; GET INF ADDR
+ HRRM A,(C) ; LEAVE A POINTER TO NEW HOME
+ HRRZ E,(P) ; GET BACK POINTER
+ JUMPE E,PAIRM7 ; 1ST ONE, NEW FIXUP
+ HRLI E,GCSEG
+ DOMULT [HRRM A,(E)] ; CLOBBER
+PAIRM4: MOVEM A,(P) ; NEW BACK POINTER
+ SKIPGE GENFLG
+ JRST DEFDO ;GO HANDLE DEFERRED POINTER
+ HRLM B,(P) ; SAVE OLD CDR
+ PUSHJ P,MARK2 ;MARK THIS DATUM
+ HRRZ E,(P) ; SMASH CAR IN CASE CHANGED
+ HRLI E,GCSEG
+ DOMULT [MOVEM A,1(E)]
+ HLRZ C,(P) ;GET CDR OF LIST
+ CAIGE C,@PURBOT ; SKIP IF PURE (I.E. DONT MARK)
+ JUMPN C,PAIRM1 ;IF NOT NIL, MARK IT
+GCRETP: ADJSP P,-1
+
+GCRET: SETZM GENFLG ;FOR PAIRMKS BENEFIT
+ POP P,A ;RESTORE C AND A
+ POP P,C
+ POPJ P, ;AND RETURN TO CALLER
+
+GCRETD: ANDI B,TYPMSK ; TURN OFF MONITORS
+ CAIN B,TLOCR ; SEE IF A LOCR
+ JRST MARCON
+ POPJ P,
+
+;HERE TO MARK DEFERRED POINTER
+
+DEFDO: PUSH P,B ; PUSH OLD PAIR ON STACK
+ PUSH P,1(C)
+ MOVEI C,-1(P) ; USE AS NEW DATUM
+ HRLI C,GCSEG ; KEEP IN CORRECT SECTION
+ PUSHJ P,MARK2 ;MARK THE DATUM
+ HRRZ E,-2(P) ; GET POINTER IN INF CORE
+ HRLI E,GCSEG
+ DOMULT [MOVEM A,1(E)]
+ MOVE A,-1(P)
+ DOMULT [HRRM A,(E)]
+ ADJSP P,-3
+ JRST GCRET ;AND RETURN
+
+
+PAIRM7: MOVEM A,-1(P) ; SAVE NEW VAL FOR RETURN
+ JRST PAIRM4
+
+RETNEW: HRRZ A,(C) ; POINT TO NEW WORLD LOCN
+ HRRZ E,(P) ; BACK POINTER
+ JUMPE E,RETNW1 ; NONE
+ HRLI E,GCSEG
+ DOMULT [HRRM A,(E)]
+ JRST GCRETP
+
+RETNW1: MOVEM A,-1(P)
+ JRST GCRETP
+
+
+\f; VECTOR AND TP MARKER, SIGN OF TYPNT IS SET BASED ON WHICH ONE
+
+TPMK: SETOM GENFLG ;SET TP MARK FLAG
+ CAIA
+VECTMK: SETZM GENFLG
+ PUSH P,FPTR
+ MOVEI E,(A) ;SAVE A POINTER TO THE VECTOR
+ HLRE B,A ;GET -LNTH
+ SUB A,B ;LOCATE DOPE WORD
+ MOVEI A,1(A) ;ZERO LH AND POINT TO 2ND DOPE WORD
+ CAIL A,STOSTR ; CHECK IN VECTOR SPACE
+ CAMLE A,GCSTOP
+ JRST VECTB1 ;LOSE, COMPLAIN
+
+ MOVE 0,GENFLG
+ HLLM 0,(P) ; SAVE TP VS VECT INDICATOR
+ JUMPE 0,NOBUFR ;IF A VECTOR, NO BUFFER CHECK
+ CAME A,PGROW ;IS THIS THE BLOWN P
+ CAMN A,TPGROW ;IS THIS THE GROWING PDL
+ JRST NOBUFR ;YES, DONT ADD BUFFER
+ ADDI A,PDLBUF ;POINT TO REAL DOPE WORD
+ MOVSI 0,-PDLBUF ;ALSO FIX UP POINTER
+ ADD 0,1(C)
+ MOVEM 0,-1(P) ; FIXUP RET'D PNTR
+
+NOBUFR: HLRE B,(A) ;GET LENGTH FROM DOPE WORD
+ JUMPL B,EXVECT ; MARKED, LEAVE
+ LDB B,[TOPGRO,,-1(A)] ; GET TOP GROWTH
+ TRZE B,400 ; HACK SIGN BIT
+ MOVNS B
+ ASH B,6 ; CONVERT TO WORDS
+ PUSH P,B ; SAVE TOP GROWTH
+ LDB 0,[BOTGRO,,-1(A)] ;GET GROWTH FACTOR
+ TRZE 0,400 ;KILL SIGN BIT AND SKIP IF +
+ MOVNS 0 ;NEGATE
+ ASH 0,6 ;CONVERT TO NUMBER OF WORDS
+ PUSH P,0 ; SAVE BOTTOM GROWTH
+ ADD B,0 ;TOTAL GROWTH TO B
+VECOK: HLRE E,(A) ;GET LENGTH AND MARKING
+ MOVEI EXTAC,(E) ;SAVE A COPY
+ ADD EXTAC,B ;ADD GROWTH
+ SUBI E,2 ;- DOPE WORD LENGTH
+ IORM D,(A) ;MAKE SURE NOW MARKED
+ PUSHJ P,ALLOGC ; ALLOCATE SPACE FOR VECTOR IN THE INF
+ HRRM 0,(A)
+VECOK1: JUMPLE E,MOVEC2 ; ZERO LENGTH, LEAVE
+ PUSH P,A ; SAVE POINTER TO DOPE WORD
+ MOVE EXTAC,GENFLG
+ SKIPGE B,-1(A) ;SKIP IF UNIFORM
+ TLNE B,377777-.VECT. ;SKIP IF NOT SPECIAL
+ JUMPE EXTAC,NOTGEN ;JUMP IF NOT A GENERAL VECTOR
+
+GENRAL: HLRZ 0,B ;CHECK FOR PSTACK
+ TRZ 0,.VECT.
+ JUMPE 0,NOTGEN ;IT ISN'T GENERAL
+ JUMPN EXTAC,TPMK1 ; JUMP IF TP
+ MOVEI C,(A)
+ SUBI C,1(E) ; C POINTS TO BEGINNING OF VECTOR
+
+\f; LOOP TO MARK ELEMENTS IN A GENERAL VECTOR
+VECTM2: HLRE B,(C) ;GET TYPE AND MARKING
+ JUMPL B,UMOVEC ;RETURN, (EITHER DOPE WORD OR FENCE POST)
+ MOVE A,1(C) ;DATUM TO A
+
+
+VECTM3: PUSHJ P,MARK ;MARK DATUM
+ MOVEM A,1(C) ; IN CASE WAS FIXED
+VECTM4: ADDI C,2
+ JRST VECTM2
+
+UMOVEC: POP P,A
+MOVEC2: POP P,C ; RESTORE BOTTOM GROWTH
+ CAMGE A,GCSBOT ; DONT DO THIS STUFF IF THIS IS FROZEN
+ JRST EXVEC1
+ HRRZ B,-1(P) ; GET POINTER INTO INF
+ JUMPLE C,MOVEC3
+ ADD B,C ; GROW IT
+MOVEC3: HLLZ 0,-1(A) ; MODIFY DOPE WORD AND PLACE IN INF
+ TLO 0,.VECT.
+ HRRZ EXTAC,(A) ; DESTINATION OF DOPEWORDS (SORT OF)
+ HRLI EXTAC,GCSEG ; MAKE INTO CORRECT KIND OF ADDR
+ DOMULT [MOVEM 0,-1(EXTAC)]
+ HLRZ 0,(A)
+ ANDI 0,377777 ; KILL MARK BIT
+ SKIPG C
+ ADD 0,C ; COMPENSATE FOR SHRINKAGE
+ MOVE EXTAC,A
+ SUB A,0
+ ADDI A,1
+ SKIPGE (P) ; ACCOUNT FOR OTHER END SHRINKAGE
+ ADD 0,(P)
+ HRLI B,GCSEG
+ SUBI 0,2 ; AVOID RE-SENDING DOPE WORDS
+ DOMULT [XBLT 0,] ; MOVE VECTOR TO OTHER IMAGE
+ MOVE A,EXTAC
+EXVEC1: ADJSP P,-1
+
+EXVECT: HLRZ B,(P)
+ ADJSP P,-1 ; GET RID OF FPTR
+ PUSHJ P,RELATE ; RELATIVIZE
+ JUMPE B,GCRET
+ MOVSI 0,PDLBUF ; FIX UP STACK PTR
+ ADDM 0,(P)
+ JRST GCRET ; EXIT
+
+VECLOS: JUMPL C,CCRET ;JUMP IF CAN'T MUNG TYPE
+ HLLZ 0,(C) ;GET TYPE
+ MOVEI B,TILLEG ;GET ILLEGAL TYPE
+ HRLM B,(C)
+ MOVEM 0,1(C) ;AND STORE OLD TYPE AS VALUE
+ JRST UMOVEC ;RETURN WITHOUT MARKING VECTOR
+
+CCRET: CLEARM 1(C) ;CLOBBER THE DATUM
+ JRST GCRET
+
+\f
+; ROUTINE TO MARK A TP. IT SCANS THE TP. IT MARKS ALL THE ITEMS AND IT MAPS AN
+; UPDATED VERSION INTO THE INFERIOR WITHOUT CHANGING THE ORIGINAL.
+
+TPMK1:
+TPMK2: POP P,A ; RESTORE DW POINTER
+ POP P,C ; AND BOTTOM GROWTH
+ HRRZ E,-1(P) ; FIX UP PARAMS
+ ADDI E,(C)
+ PUSH P,A ; REPUSH A
+ HRRZ B,(A) ; CALCULATE RELOCATION
+ SUB B,A
+ MOVE C,-1(P) ; ADJUST FOR GROWTH
+ SUB B,C
+ HRLZS C
+ HRLI E,GCSEG
+ PUSH P,C
+ PUSH P,B
+ PUSH P,E
+ PUSH P,[0]
+TPMK3: HLRZ E,(A) ; GET LENGTH
+ TRZ E,400000 ; GET RID OF MARK BIT
+ SUBI A,-1(E) ;POINT TO FIRST ELEMENT
+ MOVEI C,(A) ;POINT TO FIRST ELEMENT WITH C
+TPMK4: HLRE B,(C) ;GET TYPE AND MARKING
+ JUMPL B,TPMK7 ;RETURN, (EITHER DOPE WORD OR FENCE POST)
+ HRRZ A,(C) ;DATUM TO A
+ ANDI B,TYPMSK ; FLUSH MONITORS
+ CAIE B,TCBLK
+ CAIN B,TENTRY ;IS THIS A STACK FRAME
+ JRST MFRAME ;YES, MARK IT
+ CAIE B,TUBIND ; BIND
+ CAIN B,TBIND ;OR A BINDING BLOCK
+ JRST MBIND
+ CAIE B,TBVL ; CHECK FOR OTHER BINDING HACKS
+ CAIN B,TUNWIN
+ SKIPA ; FIX UP SP-CHAIN
+ CAIN B,TSKIP ; OTHER BINDING HACK
+ PUSHJ P,FIXBND
+
+TPMK5: PUSH P,(C) ; SAVE BECAUSE FRAMES MIGHT MUNG IT
+ HRRM A,(C) ; FIX UP IN CASE OF SP CHAIN
+ PUSHJ P,MARK1 ;MARK DATUM
+ MOVE R,A ; SAVE A
+ POP P,M
+ MOVE A,(C)
+ AOS E,-1(P) ; MOVE OUT TYPE
+ DOMULT [MOVEM A,-1(E)]
+ DOMULT [MOVEM R,(E)]
+ AOS -1(P)
+ MOVEM M,(C) ; RESTORE TO OLD VALUE
+TPMK6: ADDI C,2
+ JRST TPMK4
+
+MFRAME: HRRZ 0,1(C) ; SET UP RELITIVIZATION OF PTR TO PREVIOUS
+ ; FRAME
+ HRROI C,FRAMLN+FSAV-1(C) ;POINT TO FUNCTION
+ HRRZ A,1(C) ; GET IT
+ CAIL A,STOSTR ; CHECK IN VECTOR SPACE
+ CAMLE A,GCSTOP
+ JRST MFRAM1 ; IGNORE, NOT IN VECTOR SPACE
+ HRL A,(A) ; GET LENGTH
+ MOVEI B,TVEC
+ PUSHJ P,MARK ; AND MARK IT
+MFRAM1: HLL A,1(C)
+ MOVE E,-1(P)
+ DOMULT [MOVEM A,(E)]
+ HRRZ A,OTBSAV-FSAV+1(C) ; POINT TO TB TO PREVIOUS FRAME
+ SKIPE A
+ ADD A,-2(P) ; RELOCATE IF NOT 0
+ HLL A,2(C)
+ DOMULT [MOVEM A,1(E)]
+ MOVE A,-2(P) ; ADJUST AB SLOT
+ ADD A,ABSAV-FSAV+1(C) ; POINT TO SAVED AB
+ DOMULT [MOVEM A,2(E)]
+ MOVE A,-2(P) ; ADJUST SP SLOT
+ ADD A,SPSAV-FSAV+1(C) ;POINT TO SAVED SP
+ SUB A,-3(P) ; ADJUSTMENT OF LENGTH IF GROWTH
+ DOMULT [MOVEM A,3(E)]
+ HRROI C,PSAV-FSAV(C) ;POINT TO SAVED P
+ MOVEI B,TPDL
+ ADDI E,FRAMLN ; UPDATE OUT ADDR
+ MOVEM E,-1(P)
+ PUSHJ P,MARK1 ;AND MARK IT
+ MOVE E,-1(P)
+ DOMULT [MOVEM A,-3(E)] ; STORE UPDATED P
+ HLRE 0,TPSAV-PSAV+1(C)
+ MOVE A,TPSAV-PSAV+1(C)
+ SUB A,0
+ MOVEI 0,1(A)
+ MOVE A,TPSAV-PSAV+1(C)
+ CAME 0,TPGROW ; SEE IF BLOWN
+ JRST MFRAM9
+ MOVSI 0,PDLBUF
+ ADD A,0
+MFRAM9: ADD A,-2(P)
+ SUB A,-3(P) ; ADJUST
+ DOMULT [MOVEM A,-2(E)] ; AND UPDATED TP
+ MOVE A,PCSAV-PSAV+1(C)
+ DOMULT [MOVEM A,-1(E)] ; DONT FORGET SAVED PC
+ HRROI C,-PSAV+1(C) ; POINT PAST THE FRAME
+ JRST TPMK4 ;AND DO MORE MARKING
+
+MBIND: PUSHJ P,FIXBND
+ MOVEI B,TATOM ;FIRST MARK ATOM
+ SKIPN GCHAIR ; IF NO HAIR, MARK ALL NOW
+ SKIPE (P) ; PASSED MARKER, IF SO DONT SKIP
+ JRST MBIND2 ; GO MARK
+ MOVE A,1(C) ; RESTORE A
+ CAME A,GCATM
+ JRST MBIND1 ; NOT IT, CONTINUE SKIPPING
+ HRRM LPVP,2(C) ; SAVE IN RH OF TPVP,,0
+ MOVE 0,-4(P) ; RECOVER PTR TO DOPE WORD
+ HRLM 0,2(C) ; SAVE FOR MOVEMENT
+ MOVEI B,TATOM ; MARK THE BINDING TO THIS PROCESS
+ PUSHJ P,MARK1 ; MARK THE ATOM
+ MOVEI LPVP,(C) ; POINT
+ SETOM (P) ; INDICATE PASSAGE
+MBIND1: ADDI C,6 ; SKIP BINDING
+ MOVEI 0,6
+ SKIPE -1(P) ; ONLY UPDATE IF SENDING OVER
+ ADDM 0,-1(P)
+ JRST TPMK4
+
+MBIND2: HLL A,(C)
+ AOS E,-1(P) ; FIX UP CHAIN
+ DOMULT [MOVEM A,-1(E)]
+ MOVEI B,TATOM ; RESTORE IN CASE SMASHED
+ PUSHJ P,MARK1 ; MARK ATOM
+ AOS E,-1(P) ; SEND IT OUT
+ DOMULT [MOVEM A,-1(E)]
+ ADDI C,2
+ PUSH P,(C) ; SAVE BECAUSE FRAMES MIGHT MUNG IT
+ PUSHJ P,MARK2 ;MARK DATUM
+ MOVE R,A ; SAVE A
+ POP P,M
+ MOVE A,(C)
+ AOS E,-1(P) ; SEND IT OUT
+ DOMULT [MOVEM A,-1(E)]
+ MOVE A,R
+ DOMULT [MOVEM A,(E)] ; SEND OUT VALUE
+ AOS -1(P)
+ MOVEM M,(C) ; RESTORE TO OLD VALUE
+ ADDI C,2
+ MOVEI B,TLIST ; POINT TO DECL SPECS
+ HLRZ A,(C)
+ PUSHJ P,MARK ; AND MARK IT
+ HRR A,(C) ; LIST FIX UP
+ AOS E,-1(P) ; SEND IT OUT
+ DOMULT [MOVEM A,-1(E)]
+ SKIPL A,1(C) ; PREV LOC?
+ JRST NOTLCI
+ MOVEI B,TLOCI ; NOW MARK LOCATIVE
+ PUSHJ P,MARK1
+NOTLCI: AOS E,-1(P) ; SEND IT OUT
+ DOMULT [MOVEM A,-1(E)]
+ ADDI C,2
+ JRST TPMK4
+
+FIXBND: HRRZ A,(C) ; GET PTR TO CHAIN
+ SKIPE A ; DO NOTHING IF EMPTY
+ ADD A,-3(P)
+ POPJ P,
+TPMK7:
+TPMK8: MOVNI A,1 ; FENCE-POST THE STACK
+ AOS E,-1(P) ; SEND IT OUT
+ DOMULT [MOVEM A,-1(E)]
+ ADDI C,1 ; INCREMENT C FOR FENCE-POST
+ ADJSP P,-1 ; CLEAN UP STACK
+ POP P,E ; GET UPDATED PTR TO INF
+ ADJSP P,-2 ; POP OFF RELOCATION
+ HRRZ A,(P)
+ HLRZ B,(A)
+ TRZ B,400000
+ SUBI A,-1(B)
+ SUBI C,(A) ; GET # OF WORDS TRANSFERED
+ SUB B,C ; GET # LEFT
+ ADDI E,-2(B) ; ADJUST POINTER TO INF
+ POP P,A
+ POP P,C ; IS THERE TOP GROWH
+ ADD E,C ; MAKE ADJUSTMENT FOR TOP GROWTH
+ ANDI E,-1
+ HLLZ 0,-1(A) ; MODIFY DOPE WORD AND PLACE IN INF
+ TLO 0,.VECT.
+ HRRZ EXTAC,(A) ; DESTINATION OF DOPEWORDS (SORT OF)
+ HRLI EXTAC,GCSEG ; MAKE INTO CORRECT KIND OF ADDR
+ DOMULT [MOVEM 0,-1(EXTAC)]
+ JRST EXVECT
+\f
+; ROUTINE TO ALLOCATE ROOM FOR VECTORS IN INFERIOR
+; EXTAC= # OF WORDS TO ALLOCATE
+
+ALLOGC: HRRZS A ; GET ABS VALUE
+ CAML A,GCSBOT ; SKIP IF IN STORAGE
+ JRST ALOGC2 ; JUMP IF ALLOCATING
+ HRRZ 0,A
+ POPJ P,
+ALOGC2:
+ALOGC1: ADDI FPTR,(EXTAC)
+ MOVEI 0,-1(FPTR)
+ DOMULT [HRRM 0,-1(FPTR)]
+ DOMULT [HRLM EXTAC,-1(FPTR)]
+ POPJ P,
+
+\f; RELATE RELATAVIZES A POINTER TO A VECTOR
+; B IS THE POINTER A==> DOPE WORD
+
+RELATE: CAMGE A,GCSBOT ; SEE IF IN VECTOR SPACE
+ POPJ P, ; IF NOT EXIT
+ MOVE C,-1(P)
+ HLRE EXTAC,C ; GET LENGTH
+ HRRZ 0,-1(A) ; CHECK FO GROWTH
+ JUMPE A,RELAT1
+ LDB 0,[TOPGRO,,-1(A)] ; GET TOP GROWTH
+ TRZE 0,400 ; HACK SIGN BIT
+ MOVNS 0
+ ASH 0,6 ; CONVERT TO WORDS
+ SUB EXTAC,0 ; ACCOUNT FOR GROWTH
+RELAT1: HRLM EXTAC,C ; PLACE CORRECTED LENGTH BACK IN POINTER
+ HRRZ EXTAC,(A) ; GET RELOCATED ADDR
+ SUBI EXTAC,(A) ; FIND RELATIVIZATION AMOUNT
+ ADD C,EXTAC ; ADJUST POINTER
+ SUB C,0 ; ACCOUNT FOR GROWTH
+ MOVEM C,-1(P)
+ POPJ P,
+
+
+\f; MARK TB POINTERS
+TBMK: HRRZS A ; CHECK FOR NIL POINTER
+ SKIPN A
+ JRST GCRET ; IF POINTING TO NIL THEN RETURN
+ HLRE B,TPSAV(A) ; MAKE POINTER LOOK LIKE A TP POINTER
+ HRRZ C,TPSAV(A) ; GET TO DOPE WORD
+TBMK2: SUB C,B ; POINT TO FIRST DOPE WORD
+ HRRZ A,(P) ; GET PTR TO FRAME
+ SUB A,C ; GET PTR TO FRAME
+ HRLS A
+ HRR A,(P)
+ MOVE C,P
+ PUSH P,A
+ MOVEI B,TTP
+ PUSHJ P,MARK
+ ADJSP P,-1
+ HRRM A,(P)
+ JRST GCRET
+ABMK: HLRE B,A ; FIX UP TO GET TO FRAME
+ SUB A,B
+ HLRE B,FRAMLN+TPSAV(A) ; FIX UP TO LOOK LIKE TP
+ HRRZ C,FRAMLN+TPSAV(A)
+ JRST TBMK2
+
+\f
+; MARK ARG POINTERS
+
+ARGMK: HRRZ A,1(C) ; GET POINTER
+ HLRE B,1(C) ; AND LNTH
+ SUB A,B ; POINT TO BASE
+ CAIL A,STOSTR ; CHECK IN VECTOR SPACE
+ CAMLE A,GCSTOP
+ JRST ARGMK0
+ HLRZ 0,(A) ; GET TYPE
+ ANDI 0,TYPMSK
+ CAIN 0,TCBLK
+ JRST ARGMK1
+ CAIE 0,TENTRY ; IS NEXT A WINNER?
+ CAIN 0,TINFO
+ JRST ARGMK1 ; YES, GO ON TO WIN CODE
+
+ARGMK0: SETZB A,1(C) ; CLOBBER THE CELL
+ SETZM (P) ; AND SAVED COPY
+ JRST GCRET
+
+ARGMK1: MOVE B,1(A) ; ASSUME TTB
+ ADDI B,(A) ; POINT TO FRAME
+ CAIE 0,TINFO ; IS IT?
+ MOVEI B,FRAMLN(A) ; NO, USE OTHER GOODIE
+ HLRZ 0,OTBSAV(B) ; GET TIME
+ HRRZ A,(C) ; AND FROM POINTER
+ CAIE 0,(A) ; SKIP IF WINNER
+ JRST ARGMK0
+ MOVE A,TPSAV(B) ; GET A RELATAVIZED TP
+ HRROI C,TPSAV-1(B)
+ MOVEI B,TTP
+ PUSHJ P,MARK1
+ SUB A,1(C) ; AMOUNT TO RELATAVIZE ARGS
+ HRRZ B,(P)
+ ADD B,A
+ HRRM B,(P) ; PUT RELATAVIZED PTR BACK
+ JRST GCRET
+
+\f
+; MARK FRAME POINTERS
+
+FRMK: HLRZ B,A ; GET TIME FROM FRAME PTR
+ HLRZ EXTAC,OTBSAV(A) ; GET TIME FROM FRAME
+ CAME B,EXTAC ; SEE IF EQUAL
+ JRST GCRET
+ SUBI C,1 ;PREPARE TO MARK PROCESS VECTOR
+ HRRZ A,1(C) ;USE AS DATUM
+ SUBI A,1 ;FUDGE FOR VECTMK
+ MOVEI B,TPVP ;IT IS A VECTRO
+ PUSHJ P,MARK ;MARK IT
+ ADDI A,1 ; READJUST PTR
+ HRRM A,1(C) ; FIX UP PROCESS SLOT
+ MOVEI C,1(C) ; SET UP FOR TBMK
+ HRRZ A,(P)
+ JRST TBMK ; MARK LIKE TB
+
+\f
+; MARK BYTE POINTER
+
+BYTMK: PUSHJ P,BYTDOP ; GET DOPE WORD IN A
+ HLRZ EXTAC,-1(A) ; GET THE TYPE
+ ANDI EXTAC,SATMSK ; FLUSH MONITOR BITS
+ CAIN EXTAC,SATOM ; SEE IF ATOM
+ JRST ATMSET
+ HLRE EXTAC,(A) ; GET MARKING
+ JUMPL EXTAC,BYTREL ; JUMP IF MARKED
+ HLRZ EXTAC,(A) ; GET LENGTH
+ PUSHJ P,ALLOGC ; ALLOCATE FOR IT
+ HRRM 0,(A) ; SMASH IT IN
+ MOVE B,0
+ HLRZ 0,(A)
+ SUBI 0,1 ; DONT RESEND DW
+ SUBI B,-1(EXTAC) ; ADJUST INF POINTER
+ MOVE E,A
+ SUBI A,-1(EXTAC)
+ HRLI B,GCSEG
+ DOMULT [XBLT 0,]
+ IORM D,(E)
+ MOVE A,E
+BYTREL: HRRZ E,(A)
+ SUBI E,(A)
+ ADDM E,(P) ; RELATAVIZE
+ JRST GCRET
+
+ATMSET: PUSH P,A ; SAVE A
+ HLRZ B,(A) ; GET LENGTH
+ TRZ B,400000 ; GET RID OF MARK BIT
+ MOVNI B,-2(B) ; GET LENGTH
+ ADDI A,-1(B) ; CALCULATE POINTER
+ HRLI A,(B)
+ MOVEI B,TATOM ; TYPE
+ PUSHJ P,MARK
+ POP P,A ; RESTORE A
+ JRST BYTREL ; TO BYTREL
+\f
+
+; MARK OFFSET
+
+OFFSMK: HLRZS A
+ PUSH P,$TLIST
+ MOVE C,P
+ PUSH P,A ; PUSH LIST POINTER ON THE STACK
+ PUSHJ P,MARK2 ; MARK THE LIST
+ HRLM A,-2(P) ; UPDATE POINTER IN OFFSET
+ ADJSP P,-2
+ JRST GCRET
+\f
+
+; MARK ATOMS IN GVAL STACK
+
+GATOMK: HRRZ B,(C) ; POINT TO POSSIBLE GDECL
+ JUMPE B,ATOMK
+ CAIN B,-1
+ JRST ATOMK
+ MOVEI A,(B) ; POINT TO DECL FOR MARK
+ MOVEI B,TLIST
+ MOVEI C,0
+ PUSHJ P,MARK
+ MOVE C,-1(P) ; RESTORE HOME POINTER
+ HRRM A,(C) ; CLOBBER UPDATED LIST IN
+ MOVE A,1(C) ; RESTORE ATOM POINTER
+
+; MARK ATOMS
+
+ATOMK:
+ MOVEI 0,(FPTR)
+ PUSH P,0 ; SAVE POINTER TO INF
+ SETOM .ATOM. ; SAY ATOM WAS MARKED
+ MOVEI C,1(A)
+ PUSHJ P,GETLNT ;GET LENGTH AND CHECK BOUNDS
+ JRST ATMRL1 ; ALREADY MARKED
+ PUSH P,A ; SAVE DOPE WORD PTR FOR LATER
+ HLRZ C,(A) ; FIND REAL ATOM PNTR
+ SUBI C,400001 ; KILL MARK BIT AND ADJUST
+ HRLI C,-1(C)
+ SUBM A,C ; NOW TOP OF ATOM
+MRKOBL: MOVEI B,TOBLS
+ HRRZ A,2(C) ; IF > 0, NOT OBL
+ CAMG A,VECBOT
+ JRST .+3
+ HRLI A,-1
+ PUSHJ P,MARK ; AND MARK IT
+ HRRM A,2(C)
+ SKIPN GCHAIR
+ JRST NOMKNX
+ HLRZ A,2(C)
+ MOVEI B,TATOM
+ PUSHJ P,MARK
+ HRLM A,2(C)
+NOMKNX: HLRZ B,(C) ; SEE IF UNBOUND
+ TRZ B,400000 ; TURN OFF MARK BIT
+ SKIPE B
+ CAIN B,TUNBOUND
+ JRST ATOMK1 ; IT IS UNBOUND
+ HRRZ 0,(C) ; SEE IF VECTOR OR TP POINTER
+ MOVEI B,TVEC ; ASSUME VECTOR
+ SKIPE 0
+ MOVEI B,TTP ; ITS A LOCAL VALUE
+ PUSHJ P,MARK1 ; MARK IT
+ MOVEM A,1(C) ; SMASH INTO SLOT
+ATOMK1: HRRZ 0,2(C) ; CHECK IF NOT ON ANY OBLIST
+ POP P,B ; RESTORE A
+ POP P,C ; GET POINTER INTO INF
+ MOVE A,B
+ SKIPN GCHAIR
+ JUMPN 0,ATMREL ; ALWAYS SEND OUT ATOMS ON NO OBLIST
+
+; HERE WITH B POINT TO CURRENT DW AND C TO NEW DW, DO IT TO IT
+
+ATMOVX: PUSHJ P,XBLTR
+ATMREL: HRRZ E,(A) ; RELATAVIZE
+ SUBI E,(A)
+ ADDM E,(P)
+ JRST GCRET
+ATMRL1: ADJSP P,-1 ; POP OFF STACK
+ JRST ATMREL
+
+; HERE TO MOVE STUFF TO OTHER SEGMENT
+; B==> CURRENT DW, C==> START OF NEW OBJECT (A MUST SURVIVE)
+XBLTR: CAMGE B,GCSBOT
+ POPJ P,
+ MOVE EXTAC,A
+ HRRZ E,(B) ; NEW DW LOC
+ HRLI E,GCSEG
+ DOMULT [HLRZ A,(E)]
+ SUBI A,1
+ SUBI B,(A)
+ HRLI C,GCSEG
+ DOMULT [XBLT A,]
+ MOVE A,EXTAC ; BACK TO A
+ POPJ P,
+\f
+GETLNT: HLRE B,A ;GET -LNTH
+ SUB A,B ;POINT TO 1ST DOPE WORD
+ MOVEI A,1(A) ;POINT TO 2ND DOPE WORD
+ CAIL A,STOSTR ; CHECK IN VECTOR SPACE
+ CAMLE A,GCSTOP
+ JRST VECTB1 ;BAD VECTOR, COMPLAIN
+ HLRE B,(A) ;GET LENGTH AND MARKING
+ IORM D,(A) ;MAKE SURE MARKED
+ JUMPL B,AMTKE
+ MOVEI EXTAC,(B) ; AMOUNT TO ALLOCATE
+ PUSHJ P,ALLOGC ;ALLOCATE ROOM
+ HRRM 0,(A) ; RELATIVIZE
+AMTK1: AOS (P) ; A NON MARKED ITEM
+AMTKE: POPJ P, ;AND RETURN
+
+GCRET1: ADJSP P,-1 ;FLUSH RETURN ADDRESS
+ JRST GCRET
+
+
+\f
+; MARK NON-GENERAL VECTORS
+
+NOTGEN: CAMN B,[GENERAL+<SPVP,,0>]
+ JRST GENRAL ;YES, MARK AS A VECTOR
+ JUMPL B,SPECLS ; COMPLAIN IF A SPECIAL HACK
+ SUBI A,1(E) ;POINT TO TOP OF A UNIFORM VECTOR
+ HLRZS B ;ISOLATE TYPE
+ ANDI B,TYPMSK
+ MOVE EXTAC,B ; AND COPY IT
+ LSH B,1 ;FIND OUT WHERE IT WILL GO
+ HRRZ B,@TYPNT ;GET SAT IN B
+ ANDI B,SATMSK
+ HRRZ C,SMKTBS(B) ;POINT TO MARK SR
+ CAIN C,GCRET ;IF NOT A MARKED FROM GOODIE, IGNORE
+ JRST UMOVEC
+ MOVEI C,-1(A) ;POINT 1 PRIOR TO VECTOR START
+ PUSH P,E ;SAVE NUMBER OF ELEMENTS
+ PUSH P,EXTAC ;AND UNIFORM TYPE
+
+UNLOOP: MOVE B,(P) ;GET TYPE
+ MOVE A,1(C) ;AND GOODIE
+ TLO C,400000 ;CAN'T MUNG TYPE
+ PUSHJ P,MARK ;MARK THIS ONE
+ MOVEM A,1(C) ; LIST FIXUP
+ SOSE -1(P) ;COUNT
+ AOJA C,UNLOOP ;IF MORE, DO NEXT
+
+ ADJSP P,-2 ;REMOVE STACK CRAP
+ JRST UMOVEC
+
+
+SPECLS: FATAL AGC--UNRECOGNIZED SPECIAL VECTOR
+ ADJSP P,-4 ; REOVER
+ JRST AFIXUP
+
+
+\f
+; ROUTINE TO MARK THE GC-READ TABLE. MARKS THE ATOMS AT THE DOPE WORDS
+; AND UPDATES PTR TO THE TABLE.
+
+GCRDMK: PUSH P,A ; SAVE PTR TO TOP
+ MOVEI 0,(FPTR) ; SAVE PTR TO INF
+ PUSH P,0
+ PUSHJ P,GETLNT ; GET TO D.W. AND CHECK MARKING
+ JRST GCRDRL ; RELATIVIZE
+ PUSH P,A ; SAVE D.W POINTER
+ SUBI A,2
+ MOVE B,ABOTN ; GET TOP OF ATOM TABLE
+ HRRZ 0,-2(P)
+ ADD B,0 ; GET BOTTOM OF ATOM TABLE
+GCRD1: CAMG A,B ; DON'T SKIP IF DONE
+ JRST GCRD2
+ HLRZ C,(A) ; GET MARKING
+ TRZN C,400000 ; SKIP IF MARKED
+ JRST GCRD3
+ MOVEI E,(A)
+ SUBI A,(C) ; GO BACK ONE ATOM
+ PUSH P,B ; SAVE B
+ PUSH P,A ; SAVE POINTER
+ MOVEI C,-2(E) ; SET UP POINTER
+ MOVEI B,TATOM ; GO TO MARK
+ MOVE A,1(C)
+ PUSHJ P,MARK
+ MOVEM A,1(C) ; SMASH FIXED UP ATOM BACK IN
+ POP P,A
+ POP P,B
+ JRST GCRD1
+GCRD3: SUBI A,(C) ; TO NEXT ATOM
+ JRST GCRD1
+GCRD2: POP P,B ; GET PTR TO D.W.
+ POP P,C ; GET PTR TO INF
+ ADJSP P,-1 ; GET RID OF TOP
+ MOVE A,B
+ JRST ATMOVX ; RELATIVIZE AND LEAVE
+
+GCRDRL: POP P,A ; GET PTR TO D.W
+ ADJSP P,-2 ; GET RID OF TOP AND PTR TO INF
+ JRST ATMREL ; RELATAVIZE
+
+\f
+;MARK RELATAVIZED GLOC HACKS
+
+LOCRMK: SKIPE GCHAIR
+ JRST GCRET
+LOCRDP: PUSH P,C ; SAVE C
+ MOVEI C,-2(A) ; RELATAVIZED PTR TO ATOM
+ ADD C,GLTOP ; ADD GLOTOP TO GET TO ATOM
+ MOVEI B,TATOM ; ITS AN ATOM
+ SKIPL (C)
+ PUSHJ P,MARK1
+ POP P,C ; RESTORE C
+ MOVE A,1(C) ; GET RELATIVIZATION
+ MOVEM A,(P) ; IT STAYS THE SAVE
+ JRST GCRET
+
+;MARK LOCID TYPE GOODIES
+
+LOCMK: HRRZ B,(C) ;GET TIME
+ JUMPE B,LOCMK1 ; SKIP LEGAL CHECK FOR GLOBAL
+ HRRZ 0,2(A) ; GET OTHER TIME
+ CAIE 0,(B) ; SAME?
+ SETZB A,(P) ; NO, SMASH LOCATIVE
+ JUMPE A,GCRET ; LEAVE IF DONE
+LOCMK1: PUSH P,C
+ MOVEI B,TATOM ; MARK ATOM
+ MOVEI C,-2(A) ; POINT TO ATOM
+ MOVE E,(C) ; SEE IF BLOCK IS MARKED
+ TLNE E,400000 ; SKIP IF MARKED
+ JRST LOCMK2 ; SKIP OVER BLOCK
+ SKIPN GCHAIR ; DO NOT MARK IF NOT HAIRY (WILL BE MARKED)
+ PUSHJ P,MARK1 ; LET LOCATIVE SAVE THE ATOM
+LOCMK2: POP P,C
+ HRRZ E,(C) ; TIME BACK
+ MOVEI B,TVEC ; ASSUME GLOBAL
+ SKIPE E
+ MOVEI B,TTP ; ITS LOCAL
+ PUSHJ P,MARK1 ; MARK IT
+ MOVEM A,(P)
+ JRST GCRET
+
+\f
+; MARK ASSOCIATION BLOCKS
+
+ASMRK: PUSH P,A
+ASMRK1: HRLI A,-ASOLNT ;LOOK LIKE A VECTOR POINTER
+ PUSHJ P,GETLNT ;GET LENGTH AND CHECK BOUNDS
+ JRST ASTREL ; ALREADY MARKED
+ MOVEI C,-ASOLNT-1(A) ;COPY POINTER
+ PUSHJ P,MARK2 ;MARK ITEM CELL
+ MOVEM A,1(C)
+ ADDI C,INDIC-ITEM ;POINT TO INDICATOR
+ PUSHJ P,MARK2
+ MOVEM A,1(C)
+ ADDI C,VAL-INDIC
+ PUSHJ P,MARK2
+ MOVEM A,1(C)
+ SKIPN GCHAIR ; IF NO HAIR, MARK ALL FRIENDS
+ JRST ASTREL
+ HRRZ A,NODPNT-VAL(C) ; NEXT
+ JUMPN A,ASMRK1 ; IF EXISTS, GO
+ASTREL: POP P,A ; RESTORE PTR TO ASSOCIATION
+ MOVEI A,ASOLNT+1(A) ; POINT TO D.W.
+ SKIPN NODPNT-ASOLNT-1(A) ; SEE IF EMPTY NODPTR
+ JRST ASTX ; JUMP TO SEND OUT
+ASTR1: HRRZ E,(A) ; RELATAVIZE
+ SUBI E,(A)
+ ADDM E,(P)
+ JRST GCRET ; EXIT
+ASTX: HRRZ C,(A) ; GET PTR IN FRONTEIR
+ SUBI C,ASOLNT+1 ; ADJUST TO POINT TO BEGINNING
+ MOVE B,A
+ PUSHJ P,XBLTR
+ JRST ASTR1
+
+;HERE WHEN A VECTOR POINTER IS BAD
+
+VECTB1:FATAL AGC--VECTOR POINTS OUTSIDE OF VECTOR SPACE
+ ADJSP P,-1 ; RECOVERY
+AFIXUP: SETZM (P) ; CLOBBER SLOT
+ JRST GCRET ; CONTINUE
+
+
+VECTB2: FATAL AGC--VECTOR POINTS OUT OF VECTOR SPACE
+ ADJSP P,-2
+ JRST AFIXUP ; RECOVER
+
+PARERR: FATAL AGC--PAIR POINTS OUT OF PAIR SPACE
+ ADJSP P,-1 ; RECOVER
+ JRST AFIXUP
+
+
+\f; HERE TO MARK TEMPLATE DATA STRUCTURES
+
+TD.MRK: MOVEI 0,(FPTR) ; SAVE PTR TO INF
+ PUSH P,0
+ HLRZ B,(A) ; GET REAL SPEC TYPE
+ ANDI B,37777 ; KILL SIGN BIT
+ MOVEI E,-NUMSAT-1(B) ; GET REL POINTER TO TABLE
+ HRLI E,(E)
+ ADD E,TD.AGC+1
+ HRRZS C,A ; FLUSH COUNT AND SAVE
+ SKIPL E ; WITHIN BOUNDS
+ FATAL BAD SAT IN AGC
+ PUSHJ P,GETLNT ; GOODIE IS NOW MARKED
+ JRST TMPREL ; ALREADY MARKED
+
+ SKIPE (E)
+ JRST USRAGC
+ SUB E,TD.AGC+1 ; POINT TO LENGTH
+ ADD E,TD.LNT+1
+ XCT (E) ; RET # OF ELEMENTS IN B
+
+ HLRZ D,B ; GET POSSIBLE "BASIC LENGTH" FOR RESTS
+ PUSH P,[0] ; TEMP USED IF RESTS EXIST
+ PUSH P,D
+ MOVEI B,(B) ; ZAP TO ONLY LENGTH
+ PUSH P,C ; SAVE POINTER TO TEMPLATE STRUCTURE
+ PUSH P,[0] ; HOME FOR VALUES
+ PUSH P,[0] ; SLOT FOR TEMP
+ PUSH P,B ; SAVE
+ SUB E,TD.LNT+1
+ PUSH P,E ; SAVE FOR FINDING OTHER TABLES
+ JUMPE D,TD.MR2 ; NO REPEATING SEQ
+ ADD E,TD.GET+1 ; COMP LNTH OF REPEATING SEQ
+ HLRE E,(E) ; E ==> - LNTH OF TEMPLATE
+ ADDI E,(D) ; E ==> -LENGTH OF REP SEQ
+ MOVNS E
+ HRLM E,-5(P) ; SAVE IT AND BASIC
+
+TD.MR2: SKIPG D,-1(P) ; ANY LEFT?
+ JRST TD.MR1
+
+ MOVE E,TD.GET+1
+ ADD E,(P)
+ MOVE E,(E) ; POINTER TO VECTOR IN E
+ MOVEM D,-6(P) ; SAVE ELMENT #
+ SKIPN B,-5(P) ; SKIP IF "RESTS" EXIST
+ SOJA D,TD.MR3
+
+ MOVEI 0,(B) ; BASIC LNT TO 0
+ SUBI 0,(D) ; SEE IF PAST BASIC
+ JUMPGE 0,.-3 ; JUMP IF O.K.
+ MOVSS B ; REP LNT TO RH, BASIC TO LH
+ IDIVI 0,(B) ; A==> -WHICH REPEATER
+ MOVNS A
+ ADD A,-5(P) ; PLUS BASIC
+ ADDI A,1 ; AND FUDGE
+ MOVEM A,-6(P) ; SAVE FOR PUTTER
+ ADDI E,-1(A) ; POINT
+ SOJA D,.+2
+
+TD.MR3: ADDI E,(D) ; POINT TO SLOT
+ XCT (E) ; GET THIS ELEMENT INTO A AND B
+ JFCL ; NO-OP FOR ANY CASE
+ MOVEM A,-3(P) ; SAVE TYPE FOR LATER PUT
+ MOVEM B,-2(P)
+ EXCH A,B ; REARRANGE
+ GETYP B,B
+ MOVEI C,-3(P) ; TELL OTHER GUYS THEY CANT DIRECTLY MUNG
+ MOVSI D,400000 ; RESET FOR MARK
+ PUSHJ P,MARK ; AND MARK THIS GUY (RET FIXED POINTER IN A)
+ MOVE C,-4(P) ; REGOBBLE POINTER TO TEMPLATE
+ MOVE E,TD.PUT+1
+ MOVE B,-6(P) ; RESTORE COUNT
+ ADD E,(P)
+ MOVE E,(E) ; POINTER TO VECTOR IN E
+ ADDI E,(B)-1 ; POINT TO SLOT
+ MOVE B,-3(P) ; RESTORE TYPE WORD
+ EXCH A,B
+ SOS D,-1(P) ; GET ELEMENT #
+ XCT (E) ; SMASH IT BACK
+ FATAL TEMPLATE LOSSAGE
+ MOVE C,-4(P) ; RESTORE POINTER IN CASE MUNGED
+ JRST TD.MR2
+
+TD.MR1: MOVE A,-8(P) ; PTR TO DOPE WORD
+ MOVE B,-7(P) ; RESTORE PTR TO FRONTEIR
+ ADJSP P,-7 ; CLEAN UP STACK
+USRAG1: ADDI A,1 ; POINT TO SECOND D.W.
+ MOVSI D,400000 ; SET UP MARK BIT
+ MOVE B,A
+ HRRZ C,(A) ; DEST DW
+ DOMULT [HLRZ E,(C)] ; LENGTH
+ SUBI C,-1(E)
+ PUSHJ P,XBLTR
+TMPREL: ADJSP P,-1
+ HRRZ D,(A)
+ SUBI D,(A)
+ ADDM D,(P)
+ MOVSI D,400000 ; RESTORE MARK/UNMARK BIT
+ JRST GCRET
+
+USRAGC: HRRZ E,(E) ; MARK THE TEMPLATE
+ PUSHJ P,(E)
+ MOVE A,-1(P) ; POINTER TO D.W
+ MOVE B,(P) ; TOINTER TO FRONTIER
+ JRST USRAG1
+
+; This phase attempts to remove any unwanted associations. The program
+; loops through the structure marking values of associations. It can only
+; stop when no new values (potential items and/or indicators) are marked.
+
+VALFLS: PUSH P,LPVP ; SAVE LPVP FOR LATER
+ PUSH P,[0] ; INDICATE WHETHER ANY ON THIS PASS
+ PUSH P,[0] ; OR THIS BUCKET
+ASOMK1: MOVE A,GCASOV ; GET VECTOR POINTER
+ SETOM -1(P) ; INITIALIZE FLAG
+
+ASOM6: SKIPG C,(A) ; SKIP IF BUCKET TO BE SCANNED
+ JRST ASOM1
+ SETOM (P) ; SAY BUCKET NOT CHANGED
+
+ASOM2: MOVEI EXTAC,(C) ; COPY POINTER
+ SKIPG ASOLNT+1(C) ; SKIP IF NOT ALREADY MARKED
+ JRST ASOM4 ; MARKED, GO ON
+ PUSHJ P,MARKQ ; SEE IF ITEM IS MARKED
+ JRST ASOM3 ; IT IS NOT, IGNORE IT
+ MOVEI EXTAC,(C) ; IN CASE CLOBBERED BY MARK2
+ MOVEI C,INDIC(C) ; POINT TO INDICATOR SLOT
+ PUSHJ P,MARKQ
+ JRST ASOM3 ; NOT MARKED
+
+ PUSH P,A ; HERE TO MARK VALUE
+ PUSH P,EXTAC
+ HLRE EXTAC,ASOLNT-INDIC+1(C) ; GET LENGTH
+ JUMPL EXTAC,.+3 ; SKIP IF MARKED
+ CAMGE C,VECBOT ; SKIP IF IN VECT SPACE
+ JRST ASOM20
+ HRRM FPTR,ASOLNT-INDIC+1(C) ; PUT IN RELATIVISATION
+ MOVEI EXTAC,12 ; AMOUNT TO ALLOCATE IN INF
+ PUSHJ P,ALLOGC
+ HRRM 0,5(C) ; STICK IN RELOCATION
+
+ASOM20: PUSHJ P,MARK2 ; AND MARK
+ MOVEM A,1(C) ; LIST FIX UP
+ ADDI C,ITEM-INDIC ; POINT TO ITEM
+ PUSHJ P,MARK2
+ MOVEM A,1(C)
+ ADDI C,VAL-ITEM ; POINT TO VALUE
+ PUSHJ P,MARK2
+ MOVEM A,1(C)
+ IORM D,ASOLNT-VAL+1(C) ; MARK ASOC BLOCK
+ POP P,EXTAC
+ POP P,A
+ AOSA -1(P) ; INDICATE A MARK TOOK PLACE
+
+ASOM3: AOS (P) ; INDICATE AN UNMARKED IN THIS BUCKET
+ASOM4: HRRZ C,ASOLNT-1(EXTAC) ; POINT TO NEXT IN BUCKET
+ JUMPN C,ASOM2 ; IF NOT EMPTY, CONTINUE
+ SKIPGE (P) ; SKIP IF ANY NOT MARKED
+ HRROS (A) ; MARK BUCKET AS NOT INTERESTING
+ASOM1: AOBJN A,ASOM6 ; GO TO NEXT BUCKET
+ MOVE 0,.ATOM.
+ SETZM .ATOM.
+ JUMPN 0,VALFLA ; YES, CHECK VALUES
+VALFL8:
+
+; NOW SEE WHICH CHANNELS STILL POINTED TO
+
+CHNFL3: MOVEI 0,N.CHNS-1
+ MOVEI A,CHNL1 ; SLOTS
+ HRLI E,TCHAN ; TYPE HERE TOO
+
+CHNFL2: SKIPN B,1(A)
+ JRST CHNFL1
+ HLRE C,B
+ SUBI B,(C) ; POINT TO DOPE
+ HLLM E,(A) ; PUT TYPE BACK
+ HRRE EXTAC,(A) ; SEE IF ALREADY MARKED
+ JUMPN EXTAC,CHNFL1
+ SKIPGE 1(B)
+ JRST CHNFL8
+ HLLOS (A) ; MARK AS A LOSER
+ SETZM -1(P)
+ JRST CHNFL1
+CHNFL8: MOVEI EXTAC,1 ; MARK A GOOD CHANNEL
+ HRRM EXTAC,(A)
+CHNFL1: ADDI A,2
+ SOJG 0,CHNFL2
+
+ SKIPE GCHAIR ; IF NOT HAIRY CASE
+ POPJ P, ; LEAVE
+
+ SKIPL -1(P) ; SKIP IF NOTHING NEW MARKED
+ JRST ASOMK1
+
+ ADJSP P,-2 ; REMOVE FLAGS
+
+
+
+; HERE TO REEMOVE UNUSED ASSOCIATIONS
+
+ MOVE A,GCASOV ; GET ASOVEC BACK FOR FLUSHES
+
+ASOFL1: SKIPN C,(A) ; SKIP IF BUCKET NOT EMPTY
+ JRST ASOFL2 ; EMPTY BUCKET, IGNORE
+ HRRZS (A) ; UNDO DAMAGE OF BEFORE
+
+ASOFL5: SKIPGE ASOLNT+1(C) ; SKIP IF UNMARKED
+ JRST ASOFL6 ; MARKED, DONT FLUSH
+
+ HRRZ B,ASOLNT-1(C) ; GET FORWARD POINTER
+ HLRZ E,ASOLNT-1(C) ; AND BACK POINTER
+ JUMPN E,ASOFL4 ; JUMP IF NO BACK POINTER (FIRST IN BUCKET)
+ HRRZM B,(A) ; FIX BUCKET
+ JRST .+2
+
+ASOFL4: HRRM B,ASOLNT-1(E) ; FIX UP PREVIOUS
+ JUMPE B,.+2 ; JUMP IF NO NEXT POINTER
+ HRLM E,ASOLNT-1(B) ; FIX NEXT'S BACK POINTER
+ HRRZ B,NODPNT(C) ; SPLICE OUT THRAD
+ HLRZ E,NODPNT(C)
+ SKIPE E
+ HRRM B,NODPNT(E)
+ SKIPE B
+ HRLM E,NODPNT(B)
+
+ASOFL3: HRRZ C,ASOLNT-1(C) ; GO TO NEXT
+ JUMPN C,ASOFL5
+ASOFL2: AOBJN A,ASOFL1
+
+
+\f
+; NOW CLOBBER UNMARKED LOCAL NAD GLOBAL VALUES
+
+ MOVE A,GCGBSP ; GET GLOBAL PDL
+
+GLOFLS: SKIPGE (A) ; SKIP IF NOT ALREADY MARKED
+ JRST SVDCL
+ MOVSI B,-3
+ PUSHJ P,ZERSLT ; CLOBBER THE SLOT
+ HLLZS (A)
+SVDCL: ANDCAM D,(A) ; UNMARK
+ ADD A,[4,,4]
+ JUMPL A,GLOFLS ; MORE?, KEEP LOOPING
+
+ MOVEM LPVP,(P)
+LOCFL1: HRRZ A,(LPVP) ; NOW CLOBBER LOCAL SLOTS
+ HRRZ C,2(LPVP)
+ MOVEI LPVP,(C)
+ JUMPE A,LOCFL2 ; NONE TO FLUSH
+
+LOCFLS: SKIPGE (A) ; MARKDE?
+ JRST .+3
+ MOVSI B,-5
+ PUSHJ P,ZERSLT
+ ANDCAM D,(A) ;UNMARK
+ HRRZ A,(A) ; GO ON
+ JUMPN A,LOCFLS
+LOCFL2: JUMPN LPVP,LOCFL1 ; JUMP IF MORE PROCESS
+
+; AT THIS POINT THE LOCALS ARE FINALLY SENT OUT.
+; THIS ROUTINE UPDATES THE THIS-PROCESS BINDING.
+; IT FIXES UP THE SP-CHAIN AND IT
+; SENDS OUT THE ATOMS.
+
+LOCFL3: MOVE C,(P)
+ MOVEI B,TATOM ; MARK THE BINDING TO THIS PROCESS
+ PUSHJ P,MARK1 ; MARK THE ATOM
+ MOVEM A,1(C) ; NEW HOME
+ MOVEI C,2(C) ; MARK VALUE
+ MOVEI B,TPVP ; IT IS A PROCESS VECTOR POINTER
+ PUSHJ P,MARK1 ; MARK IT
+ MOVEM A,1(C)
+ POP P,R
+NEXPRO: MOVEI 0,TPVP ; FIX UP SLOT
+ HLRZ A,2(R) ; GET PTR TO NEXT PROCESS
+ HRLM 0,2(R)
+ HRRZ E,(A) ; ADRESS IN INF
+ HRRZ B,(A) ; CALCULATE RELOCATION
+ SUB B,A
+ PUSH P,B
+ HRRZ EXTAC,A ; CALCULATE START OF TP IN EXTAC
+ HLRZ B,(A) ; ADJUST INF PTR
+ TRZ B,400000
+ SUBI EXTAC,-1(B)
+ LDB M,[TOPGRO,,-1(A)] ; CALCULATE TOP GROWTH
+ TRZE M,400 ; FUDGE SIGN
+ MOVNS M
+ ASH M,6
+ ADD B,M ; FIX UP LENGTH
+ EXCH M,(P)
+ SUBM M,(P) ; FIX RELOCATION TO TAKE INTO ACCOUNT
+ ; CHANGE IN LENGTH
+ MOVE M,R ; GET A COPY OF R
+NEXP1: HRRZ C,(M) ; GET PTR TO NEXT IN CHAIN
+ JUMPE C,NEXP2 ; EXIT IF END OF CHAIN
+ MOVE 0,C ; GET COPY OF CHAIN PTR TO UPDATE
+ ADD 0,(P) ; UPDATE
+ HRRM 0,(M) ; PUT IN
+ MOVE M,C ; NEXT
+ JRST NEXP1
+NEXP2: ADJSP P,-1 ; CLEAN UP STACK
+ SUBI E,-1(B)
+ MOVEI A,6(R) ; POINT AFTER THE BINDING
+ MOVE 0,EXTAC ; CALCULATE # OF WORDS TO SEND OUT
+ SUBM A,0
+ HRRZ A,EXTAC
+ MOVE B,E
+ HRLI B,GCSEG
+ DOMULT [XBLT 0,]
+ HRRZS R,2(R) ; GET THE NEXT PROCESS
+ JUMPE R,.+3
+ PUSH P,R
+ JRST LOCFL3
+ MOVE A,GCGBSP ; PTR TO GLOBAL STACK
+ PUSHJ P,SPCOUT ; SEND IT OUT
+ MOVE A,GCASOV
+ PUSHJ P,SPCOUT ; SEND IT OUT
+ POPJ P,
+
+; THIS ROUTINE MARKS ALL THE CHANNELS
+; IT THEN SENDS OUT A COPY OF THE TVP
+
+CHFIX: MOVEI 0,N.CHNS-1
+ MOVEI A,CHNL1 ; SLOTS
+ HRLI E,TCHAN ; TYPE HERE TOO
+
+DHNFL2: SKIPN B,1(A)
+ JRST DHNFL1
+ MOVEI C,(A) ; MARK THE CHANNEL
+ PUSH P,0 ; SAVE 0
+ PUSH P,A ; SAVE A
+ PUSHJ P,MARK2
+ MOVEM A,1(C) ; ADJUST PTR
+ POP P,A ; RESTORE A
+ POP P,0 ; RESTORE
+DHNFL1: ADDI A,2
+ SOJG 0,DHNFL2
+ POPJ P,
+
+
+; ROUTINE TO SEND OUT STUFF - SPCOUX--DONT LOOK AT GROWTH
+; SPCOUT--LOOK AT GROWTH
+
+SPCOUX: TDZA C,C ; ZERO C AS FLAG
+
+SPCOUT: MOVEI C,1
+ HLRE B,A
+ SUB A,B
+ MOVEI A,1(A) ; POINT TO DOPE WORD
+ CAMGE A,GCSBOT
+ POPJ P,
+ HLLZ 0,-1(A) ; MODIFY DOPE WORD AND PLACE IN INF
+ TLO 0,.VECT.
+ HRRZ B,(A) ; DESTINATION OF DOPEWORDS (SORT OF)
+ HRLI B,GCSEG ; MAKE INTO CORRECT KIND OF ADDR
+ DOMULT [MOVEM 0,-1(B)]
+ JUMPE C,SPCOUY ; JUMP IF NO GROWTH STUFF
+ LDB C,[BOTGRO,,-1(A)]
+ TRZE C,400
+ MOVNS C
+ ASH C,6
+SPCOUY: DOMULT [HLRZ 0,(B)]
+ ADD 0,C ; COMPENSATE FOR SHRINKAGE
+ SUBI 0,1 ; DONT RESEND DW
+ SUB A,0
+ SUB B,0
+ DOMULT [XBLT 0,] ; MOVE VECTOR TO OTHER IMAGE
+ POPJ P, ;RETURN
+
+ASOFL6: HLRZ E,ASOLNT-1(C) ; SEE IF FIRST IN BUCKET
+ JUMPN E,ASOFL3 ; IF NOT CONTINUE
+ HRRZ E,ASOLNT+1(C) ; GET PTR FROM DOPE WORD
+ SUBI E,ASOLNT+1 ; ADJUST TO POINT TO BEGINNING OF ALSSOCIATION
+ HRRZM E,(A) ; SMASH IT IN
+ JRST ASOFL3
+
+
+MARK23: PUSH P,A ; SAVE BUCKET POINTER
+ PUSH P,EXTAC
+ PUSHJ P,MARK2
+ MOVEM A,1(C)
+ POP P,EXTAC
+ POP P,A
+ AOS -2(P) ; MARKING HAS OCCURRED
+ IORM D,ASOLNT+1(C) ; MARK IT
+ JRST MKD
+
+\f; CHANNEL FLUSHER FOR NON HAIRY GC
+
+CHNFLS: PUSH P,[-1]
+ SETOM (P) ; RESET FOR RETRY
+ PUSHJ P,CHNFL3
+ SKIPL (P)
+ JRST .-3 ; REDO
+ ADJSP P,-1
+ POPJ P,
+
+; VALUE FLUSHING PHASE, HACKS BOTTOM OF TP AND GLOBAL SP
+
+VALFLA: MOVE C,GCGBSP ; GET POINTER TO GLOBAL STACK
+VALFL1: SKIPL (C) ; SKIP IF NOT MARKED
+ PUSHJ P,MARKQ ; SEE IF ATOM IS MARKED
+ JRST VALFL2
+ PUSH P,C
+ MOVEI B,TATOM ; UPDATE ATOM SLOT
+ PUSHJ P,MARK1
+ MOVEM A,1(C)
+ IORM D,(C)
+ AOS -2(P) ; INDICATE MARK OCCURRED
+ HRRZ B,(C) ; GET POSSIBLE GDECL
+ JUMPE B,VLFL10 ; NONE
+ CAIN B,-1 ; MAINFIFEST
+ JRST VLFL10
+ MOVEI A,(B)
+ MOVEI B,TLIST
+ MOVEI C,0
+ PUSHJ P,MARK ; MARK IT
+ MOVE C,(P) ; POINT
+ HRRM A,(C) ; CLOBBER UPDATE IN
+VLFL10: ADD C,[2,,2] ; BUMP TO VALUE
+ PUSHJ P,MARK2 ; MARK VALUE
+ MOVEM A,1(C)
+ POP P,C
+VALFL2: ADD C,[4,,4]
+ JUMPL C,VALFL1 ; JUMP IF MORE
+
+ HRLM LPVP,(P) ; SAVE POINTER
+VALFL7: MOVEI C,(LPVP)
+ MOVEI LPVP,0
+VALFL6: HRRM C,(P)
+
+VALFL5: HRRZ C,(C) ; CHAIN
+ JUMPE C,VALFL4
+ MOVEI B,TATOM ; TREAT LIKE AN ATOM
+ SKIPL (C) ; MARKED?
+ PUSHJ P,MARKQ1 ; NO, SEE
+ JRST VALFL5 ; LOOP
+ AOS -1(P) ; MARK WILL OCCUR
+ MOVEI B,TATOM ; RELATAVIZE
+ PUSHJ P,MARK1
+ MOVEM A,1(C)
+ IORM D,(C)
+ ADD C,[2,,2] ; POINT TO VALUE
+ PUSHJ P,MARK2 ; MARK VALUE
+ MOVEM A,1(C)
+ SUBI C,2
+ JRST VALFL5
+
+VALFL4: HRRZ C,(P) ; GET SAVED LPVP
+ MOVEI A,(C)
+ HRRZ C,2(C) ; POINT TO NEXT
+ JUMPN C,VALFL6
+ JUMPE LPVP,VALFL9
+
+ HRRM LPVP,2(A) ; NEW PROCESS WAS MARKED
+ JRST VALFL7
+
+ZERSLT: HRRI B,(A) ; COPY POINTER
+ SETZM 1(B)
+ AOBJN B,.-1
+ POPJ P,
+
+VALFL9: HLRZ LPVP,(P) ; RESTORE CHAIN
+ JRST VALFL8
+
+\f;SUBROUTINE TO SEE IF A GOODIE IS MARKED
+;RECEIVES POINTER IN C
+;SKIPS IF MARKED NOT OTHERWISE
+
+MARKQ: HLRZ B,(C) ;TYPE TO B
+MARKQ1: MOVE E,1(C) ;DATUM TO C
+ MOVEI 0,(E)
+ CAIL 0,@PURBOT ; DONT CHACK PURE
+ JRST MKD ; ALWAYS MARKED
+ ANDI B,TYPMSK ; FLUSH MONITORS
+ LSH B,1
+ HRRZ B,@TYPNT ;GOBBLE SAT
+ ANDI B,SATMSK
+ CAIG B,NUMSAT ; SKIP FOR TEMPLATE
+ JRST @MQTBS(B) ;DISPATCH
+ ANDI E,-1 ; FLUSH REST HACKS
+ JRST VECMQ
+
+
+MQTBS:
+
+OFFSET 0
+
+DISTB2 DUM3,MKD,[[S2WORD,PAIRMQ],[S2DEFR,PAIRMQ],[SNWORD,VECMQ],[S2NWORD,VECMQ]
+[STPSTK,VECMQ],[SARGS,ARGMQ],[SPSTK,VECMQ],[SFRAME,FRMQ],[SLOCID,LOCMQ]
+[SATOM,ATMMQ],[SPVP,VECMQ],[SCHSTR,BYTMQ],[SLOCA,ARGMQ],[SLOCU,VECMQ]
+[SLOCV,VECMQ],[SLOCS,BYTMQ],[SLOCN,ASMQ],[SASOC,ASMQ],[SLOCL,PAIRMQ],[SGATOM,ATMMQ]
+[SBYTE,BYTMQ],[SLOCB,BYTMQ],[SDEFQ,PAIRMQ],[SOFFS,OFFSMQ]]
+
+OFFSET OFFS
+
+PAIRMQ: JUMPE E,MKD ; NIL ALWAYS MARKED
+ SKIPL (E) ; SKIP IF MARKED
+ POPJ P,
+ARGMQ:
+MKD: AOS (P)
+ POPJ P,
+
+BYTMQ: PUSH P,A ; SAVE A
+ PUSHJ P,BYTDOP ; GET PTR TO DOPE WORD
+ MOVE E,A ; COPY POINTER
+ POP P,A ; RESTORE A
+ SKIPGE (E) ; SKIP IF NOT MARKED
+ AOS (P)
+ POPJ P, ; EXIT
+
+FRMQ: HRRZ E,(C) ; POINT TO PV DOPE WORD
+ SOJA E,VECMQ1
+
+ATMMQ: CAML 0,GCSBOT ; ALWAYS KEEP FROZEN ATOMS
+ JRST VECMQ
+ AOS (P)
+ POPJ P,
+
+VECMQ: HLRE 0,E ;GET LENGTH
+ SUB E,0 ;POINT TO DOPE WORDS
+
+VECMQ1: SKIPGE 1(E) ;SKIP IF NOT MARKED
+ AOS (P) ;MARKED, CAUSE SKIP RETURN
+ POPJ P,
+
+ASMQ: SUBI E,ASOLNT
+ JRST VECMQ1
+
+LOCMQ: HRRZ 0,(C) ; GET TIME
+ JUMPE 0,VECMQ ; GLOBAL, LIKE VECTOR
+ HLRE 0,E ; FIND DOPE
+ SUB E,0
+ MOVEI E,1(E) ; POINT TO LAST DOPE
+ CAMN E,TPGROW ; GROWING?
+ SOJA E,VECMQ1 ; YES, CHECK
+ ADDI E,PDLBUF ; FUDGE
+ MOVSI 0,-PDLBUF
+ ADDM 0,1(C)
+ SOJA E,VECMQ1
+
+OFFSMQ: HLRZS E ; POINT TO LIST STRUCTURE
+ SKIPGE (E) ; MARKED?
+ AOS (P) ; YES
+ POPJ P,
+
+\f; SUBROUTINE TO UPDATE ASSOCIATIONS AND MOVE THEM INTO THE INF
+
+ASSOUP: MOVE A,GCNOD ; RECOVER PTR TO START OF CHAIN
+ASSOP1: HRRZ B,NODPNT(A)
+ PUSH P,B ; SAVE NEXT ON CHAIN
+ PUSH P,A ; SAVE IT
+ HRRZ B,ASOLNT-1(A) ;POINT TO NEXT
+ JUMPE B,ASOUP1
+ HRRZ C,ASOLNT+1(B) ;AND GET ITS RELOC IN C
+ SUBI C,ASOLNT+1(B) ; RELATIVIZE
+ ADDM C,ASOLNT-1(A) ;C NOW HAS UPDATED POINTER
+ASOUP1: HLRZ B,ASOLNT-1(A) ;GET PREV BLOCK POINTER
+ JUMPE B,ASOUP2
+ HRRZ EXTAC,ASOLNT+1(B) ;AND ITS RELOCATION
+ SUBI EXTAC,ASOLNT+1(B) ; RELATIVIZE
+ MOVSI EXTAC,(EXTAC)
+ ADDM EXTAC,ASOLNT-1(A) ;RELOCATE
+ASOUP2: HRRZ B,NODPNT(A) ;UPDATE NODE CHAIN
+ JUMPE B,ASOUP4
+ HRRZ C,ASOLNT+1(B) ;GET RELOC
+ SUBI C,ASOLNT+1(B) ; RELATIVIZE
+ ADDM C,NODPNT(A) ;AND UPDATE
+ASOUP4: HLRZ B,NODPNT(A) ;GET PREV POINTER
+ JUMPE B,ASOUP5
+ HRRZ EXTAC,ASOLNT+1(B) ;RELOC
+ SUBI EXTAC,ASOLNT+1(B)
+ MOVSI EXTAC,(EXTAC)
+ ADDM EXTAC,NODPNT(A)
+ASOUP5: POP P,A ; RECOVER PTR TO DOPE WORD
+ MOVEI A,ASOLNT(A)
+ PUSHJ P,SPCOUX
+ POP P,A ; RECOVER PTR TO ASSOCIATION
+ JUMPN A,ASSOP1 ; IF NOT ZERO CONTINUP
+ POPJ P, ; DONE
+
+\f
+; HERE TO CLEAN UP ATOM HASH TABLE
+
+ATCLEA: MOVE A,GCHSHT ; GET TABLE POINTER
+
+ATCLE1: MOVEI B,0
+ SKIPE C,(A) ; GET NEXT
+ JRST ATCLE2 ; GOT ONE
+
+ATCLE3: PUSHJ P,OUTATM
+ AOBJN A,ATCLE1
+
+ MOVE A,GCHSHT ; MOVE OUT TABLE
+ PUSHJ P,SPCOUT
+ POPJ P,
+
+; HAVE AN ATOM IN C
+
+ATCLE2: MOVEI B,0
+
+ATCLE5: CAIL C,HIBOT
+ JRST ATCLE3
+ CAMG C,VECBOT ; FROZEN ATOMS ALWAYS MARKED
+ JRST .+3
+ SKIPL 1(C) ; SKIP IF ATOM MARKED
+ JRST ATCLE6
+
+ HRRZ 0,1(C) ; GET DESTINATION
+ CAIN 0,-1 ; FROZEN/MAGIC ATOM
+ MOVEI 0,1(C) ; USE CURRENT POSN
+ SUBI 0,1 ; POINT TO CORRECT DOPE
+ JUMPN B,ATCLE7 ; JUMP IF GOES INTO ATOM
+
+ HRRZM 0,(A) ; INTO HASH TABLE
+ JRST ATCLE8
+
+ATCLE7: HRLM 0,2(B) ; INTO PREV ATOM
+ PUSHJ P,OUTATM
+
+ATCLE8: HLRZ B,1(C)
+ ANDI B,377777 ; KILL MARK BIT
+ SUBI B,2
+ HRLI B,(B)
+ SUBM C,B
+ HLRZ C,2(B)
+ JUMPE C,ATCLE3 ; DONE WITH BUCKET
+ JRST ATCLE5
+
+; HERE TO PASS OVER LOST ATOM
+
+ATCLE6: HLRZ EXTAC,1(C) ; FIND NEXT ATOM
+ SUBI C,-2(EXTAC)
+ HLRZ C,2(C)
+ JUMPE B,ATCLE9
+ HRLM C,2(B)
+ JRST .+2
+ATCLE9: HRRZM C,(A)
+ JUMPE C,ATCLE3
+ JRST ATCLE5
+
+OUTATM: JUMPE B,CPOPJ
+ PUSH P,A
+ PUSH P,C
+ HLRE A,B
+ SUBM B,A
+ ANDI A,-1
+ PUSHJ P,SPCOUX
+ POP P,C
+ POP P,A ; RECOVER PTR TO ASSOCIATION
+ POPJ P,
+
+\f
+VCMLOS: FATAL AGC--VECTOR WITH ZERO IN DOPE WORD LENGTH
+
+
+; THESE ARE THE MESSAGES INDICATING THE CAUSE OF THE GC
+
+MSGGCT: [ASCIZ /USER CALLED- /]
+ [ASCIZ /FREE STORAGE- /]
+ [ASCIZ /TP-STACK- /]
+ [ASCIZ /TOP-LEVEL LOCALS- /]
+ [ASCIZ /GLOBAL VALUES- /]
+ [ASCIZ /TYPES- /]
+ [ASCIZ /STATIONARY IMPURE STORAGE- /]
+ [ASCIZ /P-STACK /]
+ [ASCIZ /BOTH STACKS BLOWN- /]
+ [ASCIZ /PURE STORAGE- /]
+ [ASCIZ /GC-RCALL- /]
+
+; THESE ARE MESSAGES INDICATING WHO CAUSED THE GC
+
+GCPAT: SPBLOK 100
+EGCPAT: -1
+%XXBLT: 020000,,
+
+MSGGFT: [ASCIZ /GC-READ /]
+ [ASCIZ /BLOAT /]
+ [ASCIZ /GROW /]
+ [ASCIZ /LIST /]
+ [ASCIZ /VECTOR /]
+ [ASCIZ /SET /]
+ [ASCIZ /SETG /]
+ [ASCIZ /FREEZE /]
+ [ASCIZ /PURE-PAGE LOADER /]
+ [ASCIZ /GC /]
+ [ASCIZ /INTERRUPT-HANDLER /]
+ [ASCIZ /NEWTYPE /]
+ [ASCIZ /PURIFY /]
+
+
+.GLOBAL GCNO,BSTGC,BSTAT,NOWFRE,CURFRE,MAXFRE,USEFRE,NOWTP,CURTP,CTPMX,NOWLFL
+.GLOBAL CURLVL,NOWGVL,CURGVL,NOWTYP,CURTYP,NOWSTO,CURSTO,CURMAX,NOWP,CURP,CPMX
+.GLOBAL GCCAUS,GCCALL,LVLINC,GVLINC,TYPIC,STORIC,RCL,RCLV,GCDANG,GETNUM,RPTOP,CORTOP
+.GLOBAL TPGROW,PPGROW,PGROW,PMAIN,PGOOD,PMAX,TPGOOD,TPMIN,TPMAX,RFRETP,TYPTAB
+.GLOBAL NNPRI,NNSAT,TYPSAV,BUFGC,GCTIM,GPURFL,GCDFLG,DUMFLG
+.GLOBAL TPBINC,GBLINC,TYPINC,CONADJ,OGCSTP,ABOTN,MAXLEN
+.GLOBAL PURMIN,GCMONF,.LIST.,FPAG,PMIN,GLBINC,INCORF,PURCOR,GCHAIR
+
+\f
+;LOCAL VARIABLES
+
+OFFSET 0
+
+IMPURE
+; LOCACTIONS USED BY THE PAGE HACKER
+
+
+
+;VARIABLES WHICH DETERMIN WHEN MUDDLE WILL ASK FOR MORE CORE,
+;AND WHEN IT WILL GET UNHAPPY
+
+;IN GC FLAG
+
+GCHSHT: 0 ; SAVED ATOM TABLE
+PURSVT: 0 ; SAVED PURVEC TABLE
+GLTOP: 0 ; SAVE GLOTOP
+GCNOD: 0 ; PTR TO START OF ASSOCIATION CHAIN
+GCGBSP: 0 ; SAVED GLOBAL SP
+GCASOV: 0 ; SAVED PTR TO ASSOCIATION VECTOR
+GCATM: 0 ; PTR TO IMQUOT THIS-PROCESS
+NPARBO: 0 ; SAVED PARBOT
+
+
+; CONSTANTS FOR DUMPER,READER AND PURIFYER
+
+GENFLG: 0
+.ATOM.: 0
+
+
+; VARIABLE USED BY MARK SWEEP GARBAGE COLLECTOR
+
+
+PURE
+
+OFFSET OFFS
+
+CONSTANTS
+
+HERE
+DEFINE HERE G00002,G00003
+G00002!G00003!TERMIN
+
+CONSTANTS
+
+OFFSET 0
+
+ZZ==$.+1777
+
+.LOP ANDCM ZZ 1777
+
+ZZ1==.LVAL1
+
+LOC ZZ1
+
+
+OFFSET OFFS
+
+MRKPD: SPBLOK 1777
+ENDPDL: -1
+
+MRKPDL=MRKPD-1
+
+SENDGC:
+
+OFFSET 0
+
+ZZ2==SENDGC-AGCLD
+.LOP <ASH @> ZZ2 <,-10.>
+SECLEN==.LVAL1
+
+.LOP <ASH @> SECLEN <,10.>
+RSECLE==.LVAL1
+
+.LOP <ASH @> AGCLD <,-10.>
+PAGESC==.LVAL1
+
+OFFSET 0
+
+LOC GCST
+.LPUR==$.
+
+END
+
--- /dev/null
+TITLE UUO HANDLER FOR MUDDLE AND HYDRA
+RELOCATABLE
+.INSRT MUDDLE >
+
+SYSQ
+XJRST=JRST 5,
+;XBLT=123000,,[020000,,0]
+
+IFE ITS,.INSRT STENEX >
+
+;GLOBALS FOR THIS PROGRAM
+
+.GLOBAL BACKTR,PRINT,PDLBUF,TPGROW,SPECSTO,TIMOUT,AGC,VECBOT,VECTOP
+.GLOBAL BCKTRK,TPOVFL,.MONWR,.MONRD,.MONEX,MAKACT,IGVAL,ILVAL,BFRAME
+.GLOBAL FLGSET,QMPOPJ,SAVM,STBL,FMPOPJ,PVSTOR,SPSTOR,POPUNW,RMCALL
+.GLOBAL PURTOP,PURBOT,PLOAD,PURVEC,STOSTR,MSGTYP,UUOH,ILLUUO,RSTACK,IBLOCK
+.GLOBAL NFPOPJ,NSPOPJ,MULTSG,MLTUUP
+.GLOBAL SHRRM,SHRLM,SMOVEM,SSETZM,SXBLT,SHLRZ
+.GLOBAL C%11,C%22,C%33,C%44,C%55,C%66,C%0,C%1,C%2,C%3,C%M1,C%M2,C%M10
+.GLOBAL C%M20,C%M30,C%M40,C%M60
+
+;SETUP UUO DISPATCH TABLE HERE
+UUOLOC==40
+F==PVP
+G==F+1
+
+UUOTBL: ILLUUO
+
+IRP UUOS,,[[DP,DODP],[.MCALL,DMCALL],[.ACALL,DACALL],[.ECALL,DECALL],[.SAVAC,DSAVAC]
+[.FATAL,DFATAL],[.ERRUU,DOERR],[.POPUN,DPOPUN],[.LSAVA,DLSAVA]
+[SHRRM,DHRRM],[SHRLM,DHRLM],[SXBLT,DXBLT],[SMOVEM,DMOVEM],[SHLRZ,DHLRZ],[SSETZM,DSETZM],[SMOVE,DMOVE]]
+UUFOO==.IRPCNT+1
+IRP UUO,DISP,[UUOS]
+.GLOBAL UUO
+UUO=UUFOO_33
+SETZ DISP
+.ISTOP
+TERMIN
+TERMIN
+
+;SINCE CHECKING HAPPENS IN UUOH, NO LONGER NEED TABLE FULL OF ILLUUOS
+;REPEAT 100-UUFOO,[ILLUUO
+;]
+
+
+RMT [
+IMPURE
+
+UUOH:
+LOC 41
+ JSR UUOH
+LOC UUOH
+ 0
+IFE ITS,[
+ JRST UUOPUR
+PURE
+UUOPUR:
+]
+ MOVEM C,SAVEC
+ALLUUO: LDB C,[331100,,UUOLOC] ;GET OPCODE
+ SKIPE C
+ CAILE C,UUFOO
+ CAIA ;SKIP IF ILLEGAL UUO
+ JRST @UUOTBL(C) ;DISPATCH TO SUITABLE HANDLER
+IFN ITS,[
+ .SUSET [.RJPC,,SAVJPC]
+]
+ MOVE C,SAVEC
+ILLUUO: FATAL ILLEGAL UUO
+; THIS WILL LEAVE .JPC FOR DEBUGGING AND SUCH
+IFE ITS,[
+IMPURE
+]
+SAVJPC: 0 ; SAVE JPC IN CASE OF LOSS
+SAVEC: 0 ; USED TO SAVE WORKING AC
+NOLINK: 0
+IFE ITS,[
+MLTUUP: 0 ; HOLDS UUO (SWAPPED SORT OF)
+MLTPC: 0 ; 23 BIT PC
+MLTEA: 0 ; EFF ADDR OF UUO INSTRUCTION
+MLTUUH: FSEG,,MLTUOP ; RUN IN "FSEG"
+]
+PURE
+]
+
+;SEPARATION OF PURE FROM IMPURE CODE HERE
+
+;UUOPUR: MOVEM C,SAVEC ; SAVE AC
+; LDB C,[330900,,UUOLOC]
+; JRST @UUOTBL(C) ;DISPATCH BASED ON THE UUO
+\f
+; HANDLER FOR UUOS IN MULTI SEG MODE
+IFE ITS,[
+MLTUOP: MOVEM C,SAVEC
+ MOVE C,MLTPC
+ MOVEM C,UUOH ; SO MANY THINGS WIN IMMEDIATE
+ HRLZ C,MLTUUP
+ TLZ C,37
+ HRR C,MLTEA
+ MOVEM C,UUOLOC ; GET INS CODE
+ JRST ALLUUO
+]
+
+
+\f;CALL HANDLER
+
+IMQUOTE CALLER
+CALLER:
+
+DMCALL":
+ SETZB D,R ; FLAG NOT ENTRY CALL
+ LDB C,[270400,,UUOLOC] ; GET AC FIELD OF UUO
+COMCAL: LSH C,1 ; TIMES 2
+ MOVN AB,C ; GET NEGATED # OF ARGS
+ HRLI C,(C) ; TO BOTH SIDES
+ SUBM TP,C ; NOW HAVE TP TO SAVE
+ MOVEM C,TPSAV(TB) ; SAVE IT
+ MOVSI AB,(AB) ; BUILD THE AB POINTER
+ HRRI AB,1(C) ; POINT TO ARGS
+ HRRZ C,UUOH ; GET PC OF CALL
+ CAIL C,HIBOT ; SKIP IF NOT IN GC SPACE
+ JRST .+3
+ SUBI C,(M) ; RELATIVIZE THE PC
+ TLOA C,400000+M ; FOR RETURNER TO WIN
+ TLO C,400000
+ SKIPE SAVM
+ MOVEI C,(C)
+ MOVEM C,PCSAV(TB)
+ MOVE SP,SPSTOR+1
+ MOVEM SP,SPSAV(TB) ; SAVE BINDING GOODIE
+ MOVSI C,TENTRY ; SET UP ENTRY WORD
+ HRR C,UUOLOC ; POINT TO CALLED SR
+ ADD TP,[FRAMLN,,FRAMLN] ; ALLOCATE NEW FRAME
+ JUMPGE TP,TPLOSE
+CALDON: MOVEM C,FSAV+1(TP) ; CLOBBER THE FRAME
+ MOVEM TB,OTBSAV+1(TP)
+ MOVEM AB,ABSAV+1(TP) ; FRAME BUILT
+ MOVEM P,PSAV(TB)
+ HRRI TB,(TP) ; SETUP NEW TB
+ MOVEI C,(C)
+ SETZB M,SAVM ; ZERO M AND SAVM FOR GC WINNAGE
+ CAILE C,HIBOT ; SKIP IF RSUBR
+ JRST CALLS
+ GETYP A,(C) ; GET CONTENTS OF SLOT
+ JUMPN D,EVCALL ; EVAL CALLING ENTRY ?
+ CAIE A,TRSUBR ; RSUBR CALLING RSUBR ?
+ JRST RCHECK ; NO
+ MOVE R,(C)+1 ; YES, SETUP R
+CALLR0: HRRM R,FSAV+1(TB) ; FIXUP THE PROPER FSAV
+
+CALLR1: SKIPL M,(R)+1 ; SETUP M
+ JRST SETUPM ; JUMP IF A PURE RSUBR IN QUESTION
+IFN ITS, AOBJP TB,.+1 ; GO TO CALLED RSUBR
+IFE ITS,[
+ AOBJP TB,MCHK
+]
+MCHK1: INTGO ; CHECK FOR INTERRUPTS
+ JRST (M)
+
+IFE ITS,[
+MCHK: SKIPE MULTSG
+ HRLI TB,400000 ; KEEP TB NEGATIVE
+ JRST MCHK1
+]
+CALLS:
+IFN ITS, AOBJP TB,.+1 ; GO TO CALLED SUBR
+IFE ITS, AOBJP TB,MCHK3
+MCHK4: INTGO ; CHECK FOR INTERRUPTS
+IFE ITS, SKIPN MULTSG
+ JRST @C ; WILL DO "RIGHT THING IN MULTI SEG"
+IFE ITS,[
+ HRLI C,FSEG
+ JRST (C)
+
+
+MCHK3: SKIPE MULTSG
+ HRLI TB,400000 ; KEEP TB NEGATIVE
+ JRST MCHK4
+]
+
+
+\f
+; HERE TO HANDLE A PURE RSUBR (LOAD IF PUNTED OR OTHERWISE FLUSHED)
+
+SETUPM: MOVEI C,0 ; OFFSET (FOR MAIN ENTRIES)
+STUPM1: MOVEI D,(M) ; GET OFFSET INTO CODE
+ HLRS M ; GET VECTOR OFFSET IN BOTH HALVES
+ ADD M,PURVEC+1 ; GET IT
+ SKIPL M
+ FATAL LOSING PURE RSUBR POINTER
+ HLLM TB,2(M) ; MARK FOR LRU ALGORITHM
+ SKIPN M,1(M) ; POINT TO CORE IF LOADED
+ AOJA TB,STUPM2 ; GO LOAD IT
+STUPM3: ADDI M,(D) ; POINT TO REAL THING
+IFN ITS,[
+ HRLI C,M
+ AOBJP TB,MCHK7
+ INTGO
+MCHK7: JRST @C
+]
+IFE ITS,[
+ AOBJP TB,MCHK7
+MCHK8: INTGO
+ ADD C,M ; POINT TO START PC
+ SKIPE MULTSG
+ TLZ C,777400 ; KILL COUNT
+
+ SKIPN MULTSG
+ JRST (C)
+ MOVEI B,0 ; AVOID FLAG MUNG
+ XJRST B ; EXTENDED JRST HACK
+
+MCHK7: SKIPE MULTSG
+ HRLI TB,400000 ; KEEP TB NEGATIVE
+ JRST MCHK8
+]
+
+STUPM2: HLRZ A,1(R) ; SET UP TO CALL LOADER
+ PUSH P,D
+ PUSH P,C
+ PUSHJ P,PLOAD ; LOAD IT
+ JRST PCANT1
+ POP P,C
+ POP P,D
+ MOVE M,B ; GET LOCATION
+ SOJA TB,STUPM3
+
+RCHECK: CAIN A,TPCODE ; PURE RSUBR?
+ JRST .+3
+ CAIE A,TCODE ; EVALUATOR CALLING RSUBR ?
+ JRST SCHECK ; NO
+ MOVS R,(C) ; YES, SETUP R
+ HRRI R,(C)
+ JRST CALLR1 ; GO FINISH THE RSUBR CALL
+
+
+SCHECK: CAIE A,TSUBR ; RSUBR CALLING SUBR AS REFERENCE ?
+ CAIN A,TFSUBR
+ SKIPA C,(C)+1 ; SKIP AND GET ROUTINE'S ADDRESS
+ JRST ECHECK
+ HRRM C,FSAV+1(TB) ; FIXUP THE PROPER FSAV
+IFE ITS, SKIPN MULTSG
+ JRST CALLS ; GO FINISH THE SUBR CALL
+IFE ITS,[
+ HRLI C,FSEG ; FOR SEG #1
+ JRST CALLS
+]
+ECHECK: CAIE A,TENTER ; SKIP IF SUB ENTRY OF RSUBR
+ JRST ACHECK ; COULD BE EVAL CALLING ONE
+ MOVE C,1(C) ; POINT TO SUB ENTRY BLOCK
+ECHCK3: GETYP A,(C) ; SEE IF LINKED TO ITS MAIN ENTRY
+ MOVE B,1(C)
+ CAIN A,TRSUBR
+ JRST ECHCK2
+
+; CHECK IF CAN LINK ATOM
+
+ CAIE A,TATOM
+ JRST BENTRY ; LOSER , COMPLAIN
+ECHCK4: MOVE B,1(C) ; GET ATOM
+ PUSH TP,$TVEC
+ PUSH TP,C
+ PUSHJ P,IGVAL ; TRY GLOBAL VALUE
+ HRRZ C,(TP)
+ SUB TP,C%22
+ GETYP 0,A
+ CAIN 0,TUNBOU
+ JRST BADVAL
+ CAIE 0,TRSUBR ; IS IT A WINNER
+ JRST BENTRY
+ CAMGE C,PURTOP ; DONT TRY TO SMASH PURE
+ SKIPE NOLINK
+ JRST ECHCK2
+ HLLM A,(C) ; FIXUP LINKAGE
+ MOVEM B,1(C)
+ JRST ECHCK2
+
+EVCALL: CAIN A,TATOM ; EVAL CALLING ENTRY?
+ JRST ECHCK4 ; COULD BE MUST FIXUP
+ CAIE A,TRSUBR ; YES THIS IS ONE
+ JRST BENTRY
+ MOVE B,1(C)
+ECHCK2: MOVE R,B ; SET UP R
+ HRRM C,FSAV+1(TB) ; SET POINTER INTO FRAME
+ HRRZ C,2(C) ; FIND OFFSET INTO SAME
+ SKIPL M,1(R) ; POINT TO START OF RSUBR
+ JRST STUPM1 ; JUMP IF A LOSER
+ ADDI C,(M)
+IFE ITS, SKIPN MULTSG
+ JRST CALLS ; GO TO SR
+IFE ITS,[
+CALLSX: HRLI C,FSEG
+ JRST CALLS
+]
+ACHECK: CAIE A,TATOM ; RSUBR CALLING THROUGH REFERENCE ATOM ?
+ JRST DOAPP3 ; TRY APPLYING IT
+ MOVE A,(C)
+ MOVE B,(C)+1
+ PUSHJ P,IGVAL
+ HRRZ C,UUOLOC ; REGOBBLE POINTER TO SLOT
+ GETYP 0,A ; GET TYPE
+ CAIN 0,TUNBOUND
+ JRST TRYLCL
+SAVEIT: CAIE 0,TRSUBR
+ CAIN 0,TENTER
+ JRST SAVEI1 ; WINNER
+ CAIE 0,TSUBR
+ CAIN 0,TFSUBR
+ JRST SUBRIT
+ JRST BADVAL ; SOMETHING STRANGE
+SAVEI1: CAMGE C,PURTOP ; SKIP IF PURE RSUBR VECTOR (NEVER LINKED)
+ SKIPE NOLINK
+ JRST .+3
+ MOVEM A,(C) ; CLOBBER NEW VALUE
+ MOVEM B,(C)+1
+ CAIN 0,TENTER
+ JRST ENTRIT ; HACK ENTRY TO SUB RSUBR
+ MOVE R,B ; SETUP R
+ JRST CALLR0 ; GO FINISH THE RSUBR CALL
+
+ENTRIT: MOVE C,B
+ JRST ECHCK3
+
+SUBRIT: CAMGE C,PURBOT
+ SKIPE NOLINK
+ JRST .+3
+ MOVEM A,(C)
+ MOVEM B,1(C)
+ HRRM B,FSAV+1(TB) ; FIXUP THE PROPER FSAV
+ MOVEI C,(B)
+IFN ITS, JRST CALLS ; GO FINISH THE SUBR CALL
+IFE ITS, JRST CALLSX
+
+TRYLCL: MOVE A,(C)
+ MOVE B,(C)+1
+ PUSHJ P,ILVAL
+ GETYP 0,A
+ CAIE 0,TUNBOUND
+ JRST SAVEIT
+ SKIPA D,EQUOTE UNBOUND-VARIABLE
+BADVAL: MOVEI D,0
+ERCALX:
+IFN ITS,[
+ AOBJP TB,.+1 ; MAKE TB A LIGIT FRAME PNTR
+]
+IFE ITS,[
+ AOBJP TB,MCHK5
+]
+MCHK6: MOVEI E,CALLER
+ HRRM E,FSAV(TB) ; SET A WINNING FSAV
+ HRRZ C,UUOLOC ; REGOBBLE POINTER TO SLOT
+ JUMPE D,DOAPPL
+ PUSH TP,$TATOM
+ PUSH TP,D
+ PUSH TP,(C)
+ PUSH TP,(C)+1
+ PUSH TP,$TATOM
+ PUSH TP,IMQUOTE CALLER
+ MCALL 3,ERROR
+ GETYP 0,A
+ MOVEI C,-1
+ SOJA TB,SAVEIT
+
+BENTRY: MOVE D,EQUOTE BAD-ENTRY-BLOCK
+ JRST ERCALX
+
+IFE ITS,[
+MCHK5: SKIPN MULTSG
+ JRST MCHK6
+ HRLI TB,400000 ; KEEP TB NEGATIVE
+ JRST MCHK6
+]
+
+
+;HANDLER FOR CALL WHERE SPECIFIES NUMBER OF ARGS
+
+DACALL":
+ LDB C,[270400,,UUOLOC] ; GOBBLE THE AC LOCN INTO C
+ EXCH C,SAVEC ; C TO SAVE LOC RESTORE C
+ MOVE C,@SAVEC ; C NOW HAS NUMBER OF ARGS
+ MOVEI D,0 ; FLAG NOT E CALL
+ JRST COMCAL ; JOIN MCALL
+
+; CALL TO ENTRY FROM EVAL (LIKE ACALL)
+
+DECALL: LDB C,[270400,,UUOLOC] ; GET NAME OF AC
+ EXCH C,SAVEC ; STORE NAME
+ MOVE C,@SAVEC ; C NOW HAS NUM OF ARGS
+ MOVEI D,1 ; FLAG THIS
+ JRST COMCAL
+
+;HANDLE OVERFLOW IN THE TP
+
+TPLOSE: PUSHJ P,TPOVFL
+ JRST CALDON
+
+; RSUBR HAS POSSIBLY BEEN REPLACED BY A FUNCTION OR WHATEVER, DO AN APPLY
+
+DOAPPL: PUSH TP,A ; PUSH THE THING TO APPLY
+ PUSH TP,B
+ MOVEI A,1
+DOAPP2: JUMPGE AB,DOAPP1 ; ARGS DONE
+
+ PUSH TP,(AB)
+ PUSH TP,1(AB)
+ ADD AB,C%22
+ AOJA A,DOAPP2
+
+DOAPP1: ACALL A,APPLY ; APPLY THE LOSER
+ JRST FINIS
+
+DOAPP3: MOVE A,(C) ; GET VAL
+ MOVE B,1(C)
+ JRST BADVAL ; GET SETUP FOR APPLY CALL
+\f
+; ENTRY TO BUILD A FRAME (USED BY SOME COMPILED PROG/REPEAT)
+
+BFRAME: SKIPN SAVM
+ HRLI A,400000+M ; RELATIVIZE PC
+ MOVEM A,PCSAV(TB) ; CLOBBER PC IN
+ MOVEM TP,TPSAV(TB) ; SAVE STATE
+ MOVE SP,SPSTOR+1
+ MOVEM SP,SPSAV(TB)
+ ADD TP,[FRAMLN,,FRAMLN]
+ SKIPL TP
+ PUSHJ TPOVFL ; HACK BLOWN PDL
+ MOVSI A,TCBLK ; FUNNY FRAME
+ HRRI A,(R)
+ MOVEM A,FSAV+1(TP) ; CLOBBER
+ MOVEM TB,OTBSAV+1(TP)
+ MOVEM AB,ABSAV+1(TP)
+ POP P,A ; RET ADDR TO A
+ MOVEM P,PSAV(TB)
+ HRRI TB,(TP)
+IFN ITS, AOBJN TB,.+1
+IFE ITS, AOBJP TB,.+2
+ JRST (A)
+
+IFE ITS,[
+ SKIPN MULTSG
+ JRST (A)
+ HRLI TB,400000 ; KEEP TB NEGATIVE
+ JRST (A)
+]
+
+\f;SUBROUTINE TERMINATION CODE (NOT A UUO BUT HERE FOR COMPLETENENSS)
+
+FINIS:
+CNTIN1: HRRZS C,OTBSAV(TB) ; RESTORE BASE
+ HRRI TB,(C)
+CONTIN: MOVE TP,TPSAV(TB) ; START HERE FOR FUNNY RESTART
+ MOVE P,PSAV(TB)
+ MOVE SP,SPSTOR+1
+ CAME SP,SPSAV(TB) ; ANY RESTORATION NEEDED
+ PUSHJ P,SPECSTO ; YES, GO UNRAVEL THE WORLDS BINDINGS
+ MOVE AB,ABSAV(TB) ; AND GET OLD ARG POINTER
+ HRRZ C,FSAV(TB) ; CHECK FOR RSUBR
+ MOVEI M,0 ; UNSETUP M FOR GC WINNAGE
+ CAILE C,HIBOT ; SKIP IF ANY FLAVOR OF RSUBR
+IFN ITS, JRST @PCSAV(TB) ; AND RETURN
+IFE ITS, JRST MRET
+ GETYP 0,(C) ; RETURN TO MAIN OR SUB ENTRY?
+ CAIN 0,TCODE
+ JRST .+3
+ CAIE 0,TPCODE
+ JRST FINIS1
+ MOVS R,(C)
+ HRRI R,(C) ; RESET R
+ SKIPL M,1(R) ; GET LOC OF REAL SUBR
+ JRST FINIS2
+
+;HERE TO RETURN TO NBIN
+
+RETNBI: HLRZ 0,PCSAV(TB) ; GET FUNNY STUFF
+ JUMPN 0,@PCSAV(TB)
+ MOVEM M,SAVM
+ MOVEI M,0
+ JRST @PCSAV(TB)
+
+FINIS1: CAIE 0,TRSUBR
+ JRST FINISA ; MAY HAVE BEEN PUT BACK TO ATOM
+ MOVE R,1(C)
+FINIS9: SKIPGE M,1(R)
+ JRST RETNBI
+
+FINIS2: MOVEI C,(M) ; COMPUTE REAL M FOR PURE RSUBR
+ HLRS M
+ ADD M,PURVEC+1
+ SKIPN M,1(M) ; SKIP IF LOADED
+ JRST FINIS3
+ ADDI M,(C) ; POINT TO SUB PART
+PCREST: HLRZ 0,PCSAV(TB)
+IFN ITS, JUMPN @PCSAV(TB)
+IFE ITS,[
+ JUMPE 0,NOMULT
+ SKIPN MULTSG
+ JRST NOMULT
+ HRRZ G,PCSAV(TB)
+ CAML G,PURBOT
+ JRST MRET
+ ADD G,M
+ TLZ G,777400
+ MOVEI F,0
+ XJRST F
+NOMULT: JUMPN 0,MRET
+]
+ MOVEM M,SAVM
+ MOVEI M,0
+IFN ITS, JRST @PCSAV(TB)
+IFE ITS,[
+MRET: SKIPN MULTSG
+ JRST @PCSAV(TB)
+ MOVE D,PCSAV(TB)
+ HRLI D,FSEG
+ MOVEI C,0
+ XJRST C
+]
+
+FINIS3: PUSH TP,A
+ PUSH TP,B
+ HLRZ A,1(R) ; RELOAD IT
+ PUSHJ P,PLOAD
+ JRST PCANT
+ POP TP,B
+ POP TP,A
+ MOVE M,1(R)
+ JRST FINIS2
+
+FINISA: CAIE 0,TATOM
+ JRST BADENT
+ PUSH TP,A
+ PUSH TP,B
+ PUSH TP,$TENTER
+ HRL C,(C)
+ PUSH TP,C
+ MOVE B,1(C) ; GET ATOM
+ PUSHJ P,IGVAL ; GET VAL
+ GETYP 0,A
+ CAIE 0,TRSUBR
+ JRST BADENT
+ HRRZ C,(TP)
+ MOVE R,B
+ CAMLE C,PURTOP ; SKIP IF CAN LINK UP
+ JRST .+3
+ HLLM A,(C)
+ MOVEM B,1(C)
+ MOVE A,-3(TP)
+ MOVE B,-2(TP)
+ SUB TP,C%44
+ JRST FINIS9
+
+BADENT: ERRUUO EQUOTE RSUBR-ENTRY-UNLINKED
+
+PCANT1: ADD TB,[1,,]
+PCANT: ERRUUO EQUOTE PURE-LOAD-FAILURE
+
+REPEAT 0,[
+BCKTR1: PUSH TP,A ; SAVE VALUE TO BE RETURNED
+ PUSH TP,B ; SAVE FRAME ON PP
+ PUSHJ P,BCKTRK
+ POP TP,B
+ POP TP,A
+ JRST CNTIN1
+]
+\f
+; SUBR TO ENABLE AND DISABLE LINKING OF RSUBRS AT RUN TIME
+
+MFUNCTION %RLINK,SUBR,[RSUBR-LINK]
+
+ ENTRY
+
+ HRROI E,NOLINK
+ JRST FLGSET
+
+;HANDLER FOR DEBUGGING CALL TO PRINT
+
+DODP":
+ PUSH P,0
+ MOVSI 0,7777400
+ ANDCAM 0,UUOLOC
+ PUSH TP, @UUOLOC
+ AOS UUOLOC
+ PUSH TP,@UUOLOC
+ PUSH P,A
+ PUSH P,B
+ PUSH P,SAVEC
+ PUSH P,D
+ PUSH P,E
+ PUSH P,PVP
+ PUSH P,TVP
+ PUSH P,SP
+ PUSH P,UUOLOC
+ PUSH P,UUOH
+ MCALL 1,PRINT
+ POP P,UUOH
+ POP P,UUOLOC
+ POP P,SP
+ POP P,TVP
+ POP P,PVP
+ POP P,E
+ POP P,D
+ POP P,C
+ POP P,B
+ POP P,A
+ POP P,0
+ JRST UUOH
+
+
+DFATAL:
+IFE ITS,[
+ MOVEM A,20
+ HRRO A,UUOLOC
+ ESOUT
+ HALTF
+ MOVE A,20
+ MOVE C,SAVEC
+ JRST @UUOH
+]
+REPEAT 0,[
+; QUICK CALL HANDLER
+
+DQCALL: GETYP C,@40 ; SEE IF THIS GUY IS A QRSUBR OR QENT
+ CAIN C,TQENT
+ JRST DQCALE
+ CAIN C,TQRSUB
+ JRST DQCALR
+
+; NOT A QENT OR QRSUBR, MAYBE AN ATOM THAT LINKS TO ONE
+
+ SKIPN NOLINK
+ CAIE C,TATOM ; SKIP IF ATOM
+ JRST DMCALL ; PRETEND TO BE AN MCALL
+
+ MOVE C,UUOH ; GET PC OF CALL
+ SUBI C,(M) ; RELATIVIZE
+ PUSH P,C ; AND SAVE
+ LDB C,[270400,,40] ; GET # OF ARGS
+ PUSH P,C
+ HRRZ C,40 ; POINT TO RSUBR SLOT
+ MOVE B,1(C) ; GET ATOM
+ SUBI C,(R) ; RELATIVIZE IT
+ HRLI C,(C)
+ ADD C,R ; C IS NOW A VECTOR POINTER
+ PUSH TP,$TVEC
+ PUSH TP,C
+ PUSH TP,$TATOM
+ PUSH TP,B
+ PUSHJ P,IGVAL ; SEE IF IT HAS A VALUE
+ GETYP 0,A ; IS IT A WINNER
+ CAIE 0,TUNBOU
+ JRST DQCAL2
+ MOVE B,(TP)
+ PUSHJ P,ILVAL ; LOCAL?
+ GETYP 0,A
+ CAIE 0,TUNBOU
+ JRST DQCAL2 ; MAY BE A WINNER
+
+ PUSH TP,$TATOM
+ PUSH TP,EQUOTE UNBOUND-VARIABLE
+ PUSH TP,$TATOM
+ PUSH TP,-3(TP)
+ PUSH TP,$TATOM
+ PUSH TP,IMQUOTE CALLER
+ MCALL 3,ERROR
+ GETYP 0,A
+DQCAL2: PUSH TP,$TENTE ; IN CASE RSUBR ENTRY
+ PUSH TP,C%0
+ CAIN 0,TRSUBR ; RSUBR?
+ JRST DQRSB ; YES, WIN
+ CAIN 0,TENTER
+ JRST DQENT
+
+DQMCAL: HRRZ C,-6(TP) ; PRETEND WE WERE AN MCALL
+ HRRM C,40
+ POP P,C
+ DPB C,[270400,,40]
+ POP P,C
+ ADDI C,(M) ; AND PC
+ MOVEM C,UUOH
+ SUB TP,[10,,10]
+ JRST DMCALL ; FALL INTO MCALL CODE
+
+DQENT: MOVEM B,(TP) ; SAVE IT
+ GETYP 0,(B) ; LINKED UP?
+ MOVE B,1(B)
+ CAIN 0,TRSUBR
+ JRST DQENT1
+DQENT2: CAIE 0,TATOM ; BETTER BE ATOM
+ JRST BENTRY
+ PUSHJ P,IGVAL ; TRY TO LINK IT UP
+ GETYP 0,A
+ CAIE 0,TRSUBR
+ JRST BENTRY ; LOSER!
+ MOVE C,(TP)
+ HLLM A,(C)
+ MOVEM B,1(C)
+
+DQENT1:
+DQRSB: PUSH TP,$TRSUBR
+ PUSH TP,B
+
+ PUSH TP,$TUVEC
+ PUSH TP,M
+
+ SKIPL M,1(B)
+ PUSHJ P,DQCALQ ; MAP ONE IN
+
+ MOVEI E,0 ; GET OFFSET
+ SKIPL 1(B)
+ HLRZ E,1(B)
+ HLRE B,M ; FIND END OF CODE VECTOR
+ SUBM M,B
+ MOVE M,(TP)
+ SUB TP,C%22
+ HLRZ A,-1(B) ; GET LENGTH OF ENTRY VECTOR
+ HRRZ C,-1(B) ; GET LENGTH OF DDT SYMBOL TABLE
+ ADDI C,(A) ; TOTAL LENGTH OF RANDOM CRUFT AT THE END OF CODE
+ SUBI B,1(C) ; POINT TO FIRST ELEMENT IN ENTRY VECTOR
+
+SL2: HRRZ D,(B)
+ CAIL D,(E) ; IN RANGE?
+ JRST SL1
+ ADDI B,1
+ SOJG A,SL2
+ JRST DQMCAL
+
+SL1: HLRE D,(B) ; GET NEXT
+ JUMPL D,DQMCAL
+ CAMN D,(P)
+ JRST .+4
+ ADDI B,1
+ SOJG A,.-4
+ JRST DQMCAL
+
+ HRRZ C,(B) ; GET OFFSET
+ MOVE R,(TP) ; SETUP R
+ SKIPN B,-2(TP) ; SKIP IF RSUBR ENTRY
+ JRST DQRSB1
+
+ ADD C,2(B)
+ HRLI C,TQENT
+ JRST DQMUNG
+
+DQRSB1: MOVE B,(TP)
+ HRLI C,TQRSUB
+
+DQMUNG: HRRZ D,-6(TP) ; GET CALLING RVECTOR
+ CAILE D,@PURTOP ; SMASHABLE?
+ JRST DQLOSS ; NO LOSE
+
+ MOVEM C,(D) ; SMASH
+ MOVEM B,1(D)
+
+DQLOSS: SUB P,C%11
+ POP P,E ; RESTORE PC
+ ADDI E,(M)
+ MOVEM E,UUOH
+ SUB TP,[10,,10]
+ MOVEI E,C
+ JRST DQCAL1
+
+DQCALE: MOVE E,40
+ MOVE B,1(E) ; GET RSUBR ENTRY
+ MOVE R,1(B)
+ JRST DQCAL1
+
+DQCALR: MOVE E,40
+ MOVE B,1(E)
+ MOVE R,B
+
+DQCAL1: HRRZ E,(E)
+ HRRZ C,RSTACK(PVP)
+ HRLI C,(C)
+ ADD C,RSTACK+1(PVP)
+ JUMPGE C,QCOPY
+ HRRZ A,FSAV(TB)
+ HRL A,(A)
+ MOVEM A,(C) ; SAVE IT
+ AOS C,RSTACK(PVP)
+ HRRM B,FSAV(TB) ; FOR FUTURE MCALLS
+ HRLI C,-1(C)
+ HRR C,UUOH
+ SUBI C,(M) ; RELATIVIZE
+ PUSH P,C ; SAVE BOTH
+ SKIPL M,1(R) ; MAYBE LINK UP?
+ PUSHJ P,DQCALP
+ ADDI E,1(M)
+ JRST (E) ; GO
+
+DQCALP: MOVE B,R
+DQCALQ: HLRS M ; GET VECTOR OFFSET IN BOTH HALVES
+ ADD M,PURVEC+1 ; GET IT
+ SKIPL M
+ FATAL LOSING PURE RSUBR POINTER
+ SKIPE M,1(M)
+ POPJ P,
+
+DQCLP1: PUSH TP,$TRSUBR
+ PUSH TP,B
+ PUSH P,E
+ HLRZ A,1(B) ; SET UP TO CALL LOADER
+ PUSHJ P,PLOAD ; LOAD IT
+ JRST PCANT
+ POP P,E
+ MOVE M,B ; GET LOCATION
+ MOVE B,(TP)
+ SUB TP,C%22
+ POPJ P,
+
+QCOPY: PUSH TP,$TVEC
+ PUSH TP,B
+ HRRZ C,UUOH
+ SUBI C,(M)
+ PUSH P,C
+ PUSH P,E
+ HLRE A,RSTACK+1(PVP)
+ MOVNS A
+ ADDI A,100
+ PUSHJ P,IBLOCK ; GET BLOCK
+ MOVEI A,.VECT.+TRSUBR
+ HLRE C,B
+ SUBM B,C
+ MOVEM A,(C)
+ HRLZ A,RSTACK+1(PVP)
+ JUMPE A,.+3
+ HRRI A,(B)
+ BLT A,-101(C) ; COPY IT
+ MOVEM B,RSTACK+1(PVP)
+ MOVE B,(TP)
+ SUB TP,C%22
+ POP P,E
+ POP P,C
+ ADDI C,(M)
+ HRRM C,UUOH
+ JRST DQCAL1
+
+QMPOPJ: SKIPL E,(P)
+ JRST QFINIS
+ SUBM M,(P)
+ POPJ P,
+
+QFINIS: POP P,D
+ HLRZS D
+ HRRM D,RSTACK(PVP)
+ ADD D,RSTACK+1(PVP)
+ MOVE R,(D) ; GET R OR WHATEVER
+ HRRM R,FSAV(TB)
+ GETYP 0,(R) ; TYPE
+ CAIN 0,TRSUBR ; RSUBR?
+ MOVE R,1(R)
+ SKIPL M,1(R) ; RSUBR IN CORE ETC
+ JRST QRLD
+
+QRLD2: ADDI E,(M)
+ JRST (E)
+
+QRLD: HLRS M
+ ADD M,PURVEC+1
+ SKIPE M,1(M) ; SKIP IF LOADED
+ JRST QRLD2
+ PUSH TP,A
+ PUSH TP,B
+ HLRZ A,1(R) ; RELOAD IT
+ PUSHJ P,PLOAD
+ JRST PCANT
+ POP TP,B
+ POP TP,A
+ MOVE M,1(R)
+ JRST QRLD2
+
+]
+; THIS IS A UUO TO CALL ERROR WITH ONE ARGUMENT
+
+DOERR: PUSH P,UUOH
+ PUSH TP,$TATOM
+ MOVSI 0,7777400
+ ANDCAM 0,UUOLOC
+ PUSH TP,@UUOLOC
+ JRST CALER1
+
+; ROUTINE TO DO AN RCALL FOR SUBRIFIED GOODIES
+
+RMCALL: MOVEM M,SAVM ; SAVE M
+ SUBM M,(P)
+ MOVEI M,0
+ PUSHJ P,@0
+ MOVE M,SAVM
+ SETZM SAVM
+ SUBM M,(P)
+ POPJ P,
+
+
+; ROUTINE USED BY COMPILED CODE TO SAVE ACS CALL AN INTERRUPT AND RESTORE ACS.
+; THIS UUO TAKES A LOCATION FROM WHICH TO FIND A DESCRIPTION OF HOW ACS ARE TO
+; BE SAVED.
+; .SAVAC LOC
+; LOC POINTS TO A BLOCK WHICH CAN BE ONE OR MORE WORDS LONG DEPENDING ON BOTH
+; THE NUMBER OF SCRATCH AC'S (CURRENTLY 5) AND THE NUMBER OF AC'S CONTAINING
+; TEMPLATE TYPES.
+; THE FIRST PART OF THE BLOCK CONTAINS THE AC DECRIPTIONS. EACH AC IS DESCRIBED
+; BY A SIX BIT FIELD WITH THE EXCEPTION OF AC'S CONTAINING TEMPLATES.
+; THE SIX BIT FIELD CAN BE
+;
+; 0 EITHER A TYPE WORD OR NOTHING
+; 1 -> 8 THE NUMBER OF THE AC CONTAINING THE TYPE
+; 9 -> 62 THE SAT OF THE THING CONTAINED IN THE AC (+ 8)
+; 63 A TEMPLATE LOOK AT THE BLOCK AFTER TO FIND A POINTER TO THE TYPE WORD
+;
+; TEMPLATE DESCRIPTIONS ARE FOUND AFTER THE AC DESCRIPTION BLOCK. THESE ARE FOUND
+; IN SUCESSIVE WORDS CONTAINING POINTERS INTO THE R VECTOR
+
+NOACS==10
+TMPPTR==2
+
+ONOACS==5
+OTMPPT==1
+
+DLSAVA: PUSH P,[SETZ NOACS]
+ PUSH P,[SETZ TMPPTR]
+ JRST DSAVA1
+
+DSAVAC: PUSH P,[SETZ ONOACS]
+ PUSH P,[SETZ OTMPPT]
+DSAVA1:
+IFN ITS, MOVE 0,UUOH ; GET PC
+IFE ITS,[
+ MOVE 0,UUOH
+ SKIPE MULTSG
+ MOVE 0,MLTPC
+]
+ PUSH P,0
+ ANDI 0,-1
+ PUSH P,UUOLOC ; SAVE UUO
+ CAMG 0,PURTOP
+ CAMGE 0,VECBOT
+ JRST DONREL
+ SUBI 0,(M) ; M IS BASE REG
+IFN ITS, TLO 0,M ; INDEX IT OFF M
+IFE ITS,[
+ HRLI 0,400000+M
+]
+ MOVEM 0,-1(P) ; AND RESTORE TO STACK
+; MOVE 0,UUOLOC ; GET REL POINTER TO TBL - REDUNDANT
+; MOVEM 0,(P) ; AND SAVE IT - REDUNDANT PTR ALREADY PUSHED
+DONREL: MOVE C,SAVEC
+ MOVE 0,[A,,ACSAV]
+ BLT 0,ACSAV+NOACS-1
+ HRRZ 0,-3(P) ; NUMBER OF ACS
+; MOVE A,[440620,,UUOLOC] ; BYTE POINTER INDIRECTED TO 40
+IFN ITS,[
+ MOVE A,UUOLOC ; GET THE INSTRUCTION
+ HRLI A,440640 ; OR IN THE BYTE POINTER
+]
+IFE ITS,[
+ MOVSI A,440600+B ; OR IN THE BYTE POINTER
+ SKIPN MULTSG
+ HRRZ B,UUOLOC
+ SKIPE MULTSG
+ MOVE B,MLTEA
+]
+ MOVE D,-2(P) ; POINTER TO TEMPLATE BLOCK
+IFN ITS,[
+ MOVSI C,7777400
+ ANDCAM C,UUOLOC
+ ADD D,UUOLOC ; GET TO BLOCK
+]
+IFE ITS,[
+ SKIPE MULTSG
+ JRST XXXYYY
+ MOVSI C,7777400
+ ANDCAM C,UUOLOC
+ ADD D,UUOLOC
+ CAIA
+
+XXXYYY: ADD D,MLTEA
+]
+ HRROI C,1
+LOPSAV: ILDB E,A ; GET A DESCRIPTOR
+ JUMPE E,NOAC1 ; ZERO==TYPE WORD
+ CAIE E,77 ; IF 63. THEN TEMPLATE HANDLE SPECIALLY
+ JRST NOTEM ; NOT A TEMPLATE
+ PUSH TP,@(D) ; IT IS A TEMPLATE POINTER SO PUSH TYPE
+ ADDI D,1 ; AOS B
+LOPPUS: PUSH TP,ACSAV-1(C) ; PUSH AC
+LPSVDN: ADDI C,1
+ SOJG 0,LOPSAV ; LOOP BACK
+ MOVE 0,[ACSAV,,A]
+ BLT 0,NOACS
+ JSR LCKINT ; GO INTERRUPT
+ HRRZ B,-3(P) ; NUMBER OF ACS
+LOPPOP: POP TP,ACSAV-1(B)
+LOPBAR: SUB TP,C%11
+LOPFOO: SOJG B,LOPPOP
+ JUMPE R,LOPBLT ; OK, NOT RSUBR
+ SKIPL 1(R) ; NOT PURE RSUBR
+ SKIPN MULTSG
+ JRST LOPBLT
+
+ MOVE B,M
+ TLZ B,77740
+ MOVEI A,0
+ HRRI B,LOPBLT
+ XJRST A
+
+LOPBLT: MOVE 0,[ACSAV,,A]
+ BLT 0,@-3(P) ; RESTORE AC'S
+ MOVE 0,-1(P)
+ SUB P,C%44 ; RETURN ADDRESS, (M)
+ JRST @0
+
+NOTEM: CAILE E,8. ; SKIP IF AC IS TO BE PUSHED
+ JRST NOAC
+IFE ITS, TLO E,400000 ; MAKE LOCAL INDEX
+ PUSH TP,ACSAV-1(E)
+ JRST LOPPUS ; FINISH PUSHING
+NOAC: SUBI E,8 ; COMPENSATE FOR ADDED AMOUNT
+NOAC1:
+IFE ITS, TLO E,400000 ; MAKE LOCAL INDEX
+ MOVE E,@STBL(E)
+ HLRE F,E ; GET NEGATIVE
+ SUB E,F
+ HRLZ E,(E) ; GET TYPE CODE
+ TLZ E,400000+<0,,<-1>#<TYPMSK>> ; KILL SIGN BIT
+ PUSH TP,E ; PUSH TYPE
+ JRST LOPPUS ; FINISH PUSHING
+
+FMPOPJ: MOVE TP,FRM
+ MOVE FRM,(TP)
+ HRLS C,-1(TP)
+ SUB TP,C
+ SUBM M,(P)
+ POPJ P,
+
+
+NFPOPJ: MOVE TP,FRM ; CLEAR OFF FRM
+ MOVE FRM,(TP)
+ HRLS C,-1(TP)
+ SUB TP,C
+
+; THIS WEIRD PIECE OF CODE IS USED TO DO AN MPOPJ IN SUBRIFIED CODE THAT
+; DOES A SKIP/NON SKIP RETURN.
+
+NSPOPJ: EXCH (P)
+ TLNE 37
+ MOVNS 0
+ EXCH (P)
+ POPJ P,
+
+
+DPOPUN: PUSHJ P,POPUNW
+ JRST @UUOH
+
+; HERE FOR MULTI SEG SIMULATION STUFF
+
+DMOVE: MOVSI C,(MOVE)
+ JRST MEX
+DHRRM: MOVSI C,(HRRM)
+ JRST MEX
+DHRLM: MOVSI C,(HRLM)
+ JRST MEX
+DMOVEM: MOVSI C,(MOVEM)
+ JRST MEX
+DHLRZ: MOVSI C,(HLRZ)
+ JRST MEX
+DSETZM: MOVSI C,(SETZM)
+ JRST MEX
+DXBLT: MOVE C,[123000,,[020000,,]]
+
+MEX: MOVEM A,20
+ MOVE A,UUOH ; GET LOC OF INS
+ MOVE A,-1(A)
+ TLZ A,777000
+ IOR A,C
+ XJRST .+1
+ 0
+ FSEG,,.+1
+ MOVE C,SAVEC
+ EXCH A,20
+ XCT 20
+ XJRST .+1
+ 0
+ .+1
+ JRST @UUOH
+
+
+IMPURE
+
+SAVM: 0 ; SAVED M FOR SUBRIFY HACKERS
+
+ACSAV: BLOCK NOACS
+
+
+PURE
+
+END
+\f
\ No newline at end of file
projects / pdp10-muddle.git / commitdiff