--- /dev/null
+TITLE AGC MUDDLE GARBAGE COLLECTOR
+
+;SYSTEM WIDE DEFINITIONS GO HERE
+
+RELOCATABLE
+GCST==$.
+
+
+.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,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,GCOFFS
+.GLOBAL SPBASE,OUTRNG,CISTNG,CBYTES,%RUNAM,PURVEC,GCDOWN,N.CHNS,CHNL1,PLODR,MRKPDL
+.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 P.TOP,P.CORE,PMAPB,IGET,CIGTPR,ROOT,STBL,CAFREE,%MPIN1,%PURIF,%MPINX,GCHK10
+.GLOBAL %SAVRP,%RSTRP,LENGC,AGCLD,PAGEGC,REALGC,MARK
+.GLOBAL %MPINT,%GBINT,%CLSMP,%CLSM1,PINIT,PGFIND,NPRFLG
+.GLOBAL GCKNUM,CORTOP,GCHPN,INTAGC,WNDP,WNDBOT,BUFGC,WIND,GCDFLG,SAVM,AGC,GCSET
+
+.GLOBAL GCRET,PAIRMK,DEFMK,VECTMK,TBMK,TPMK,ARGMK,VECTMK,FRMK,BYTMK,ATOMK,GATOMK
+.GLOBAL BYTMK,ABMK,LOCRMK,GCRDMK,DEFQMK,ASMRK,LOCMK,OFFSMK,INBLOT,MARK2A
+
+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
+
+.ATOM.==200000 ; FLAG SAYING ATOMS MARKED (FOR VAL FLUSH LOGIC)
+
+GCHN==0 ; CHANNEL FOR FUNNNY INFERIOR
+STATNO==19. ; # OF STATISTICS FOR BLOAT-STAT
+STATGC==8. ; # OF GC-STATISTICS FOR BLOAT-STAT
+
+
+LOC REALGC
+OFFS==AGCLD-$.
+GCOFFS=OFFS
+OFFSET OFFS
+
+.INSRT MUDDLE >
+SYSQ
+IFE ITS,[
+.INSRT STENEX >
+]
+IFN ITS, PGSZ==10.
+IFE ITS, PGSZ==9.
+
+TYPNT=AB ;SPECIAL AC USAGE DURING GC
+F=TP ;ALSO SPECIAL DURING GC
+LPVP=SP ;SPECIAL FOR GC, HOLDS POINTER TO PROCESS CHAIN
+FPTR=TB ; POINT TO CURRENT FRONTIER OF INFERIOR
+
+
+; WINDOW AND FRONTIER PAGES
+
+MAPCH==0 ; MAPPING CHANNEL
+.LIST.==400000
+FPAG==2000 ; START OF PAGES FOR GC-READ AND GCDUMP
+CONADJ==5 ; ADJUSTMENT OF DUMPERS CONSTANT TABLE
+
+\f
+; INTERNAL GCDUMP ROUTINE
+.GLOBAL GODUMP,EGCDUM,EPURIF,ERRKIL,IPURIF
+
+GODUMP: MOVE PVP,PVSTOR+1
+ MOVEM P,PSTO+1(PVP) ; SAVE P
+ MOVE P,GCPDL
+ PUSH P,AB
+ PUSHJ P,INFSU1 ; SET UP INFERIORS
+
+; MARK PHASE
+ SETZM PURMNG ; INITIALIZE FLAG INDICATING IF PURIFIED PAGES
+ ; WERE MUNGED
+ MOVEI 0,HIBOT ; SET UP NEW PURBOT TO CONVINCE THE GARBAGE COLLECTOR
+ ; TO COLLECT PURIFIED STRUCTURES
+ EXCH 0,PURBOT
+ MOVEM 0,RPURBT ; SAVE THE OLD PURBOT
+ MOVEI 0,HIBOT
+ EXCH 0,GCSTOP
+ MOVEM 0,RGCSTP ; SAVE THE OLD GCSTOP
+ POP P,C ; SET UP PTR TO TYPE/VALUE PAIR
+ MOVE P,A ; GET NEW PDL PTR
+ SETOM DUMFLG ; FLAG INDICATING IN DUMPER
+ MOVE A,TYPVEC+1
+ MOVEM A,TYPSAV
+ ADD FPTR,[7,,7] ; ADJUST FOR FIRST STATUS WORDS
+ PUSHJ P,MARK2
+ MOVEI E,FPAG+6 ; SEND OUT PAIR
+ PUSH P,C ; SAVE C
+ MOVE C,A
+ PUSHJ P,ADWD
+ POP P,C ; RESTORE C
+ MOVEI E,FPAG+5
+ MOVE C,(C) ; SEND OUT UPDATED PTR
+ PUSHJ P,ADWD
+
+ MOVEI 0,@BOTNEW ; CALCULATE START OF TYPE-TABLE
+ MOVEM 0,TYPTAB
+ MOVE 0,RPURBT ; RESTORE PURBOT
+ MOVEM 0,PURBOT
+ MOVE 0,RGCSTP ; RESTORE GCSTOP
+ MOVEM 0,GCSTOP
+
+
+; ROUTINE TO SCAN THE TYPE-VECTOR FOR MARKED TYPE SLOTS AND BUILD A TYPE-TABLE OUT OF
+; THEM
+
+ MOVE A,TYPSAV ; GET AOBJN POINTER TO TYPE-VECTOR
+ MOVEI B,0 ; INITIALIZE TYPE COUNT
+TYPLP2: HLRE C,(A) ; GET MARKING
+ JUMPGE C,TYPLP1 ; IF NOT MARKED DON'T OUTPUT
+ MOVE C,(A) ; GET FIRST WORD
+ HRL C,B ; FIX UP SO TYPE-NUMBER REPLACES TYPE-CELL
+ PUSH P,A
+ SKIPL FPTR
+ PUSHJ P,MOVFNT
+ MOVEM C,FRONT(FPTR)
+ AOBJN FPTR,.+2
+ PUSHJ P,MOVFNT ; EXTEND THE FRONTIER
+ POP P,A
+ MOVE C,1(A) ; OUTPUT SECOND WORD
+ MOVEM C,FRONT(FPTR)
+ ADD FPTR,[1,,1]
+TYPLP1: ADDI B,1 ; INCREMENT TYPE COUNT
+ ADD A,[2,,2] ; POINT TO NEXT SLOT
+ JUMPL A,TYPLP2 ; LOOP
+
+; ROUTINE TO BUILD UP ATOM TABLE USING LPVP CHAIN
+
+ HRRZ F,ABOTN
+ MOVEI 0,@BOTNEW ; GET CURRENT BEGINNING OF TRANSFER
+ MOVEM 0,ABOTN ; SAVE IT
+ PUSHJ P,ALLOGC ; ALLOCATE ROOM FOR ATOMS
+ MOVSI D,400000 ; SET UP UNMARK BIT
+SPOUT: JUMPE LPVP,DPGC4 ; END OF CHAIN
+ MOVEI F,(LPVP) ; GET COPY OF LPVP
+ HRRZ LPVP,-1(LPVP) ; LPVP POINTS TO NEXT ON CHAIN
+ ANDCAM D,(F) ; UNMARK IT
+ HLRZ C,(F) ; GET LENGTH
+ HRRZ E,(F) ; POINTER INTO INF
+ ADD E,ABOTN
+ SUBI C,2 ; WE'RE NOT SENDING OUT THE VALUE PAIR
+ HRLM C,(F) ; ADJUSTED LENGTH
+ MOVE 0,C ; COPY C FOR TRBLKX
+ SUBI E,(C) ; ADJUST PTRS FOR SENDOUT\r
+ SUBI F,-1(C)
+ PUSHJ P,TRBLKX ; OUT IT GOES
+ JRST SPOUT
+
+
+; HERE TO SEND OUT DELIMITER INFORMATION
+DPGC4: SKIPN INCORF ; SKIP IF TRANSFREING TO UVECTOR IN CORE
+ JRST CONSTO
+ SKIPL FPTR ; SEE IF ROOM IN FRONTEIR
+ PUSHJ P,MOVFNT ; EXTEND FRONTEIR
+ MOVSI A,.VECT.
+ MOVEM A,FRONT(FPTR)
+ AOBJN FPTR,.+2
+ PUSHJ P,MOVFNT
+ MOVEI A,@BOTNEW ; LENGTH
+ SUBI A,FPAG
+ HRLM A,FRONT(FPTR)
+ ADD FPTR,[1,,1]
+
+
+CONSTO: MOVEI E,FPAG
+ MOVE C,ABOTN ; START OF ATOMS
+ SUBI C,FPAG+CONADJ ; ADJUSTMENT FOR STARTING ON PAGE ONE
+ PUSHJ P,ADWD ; OUT IT GOES
+ MOVEI E,FPAG+1
+ MOVEI C,@BOTNEW
+ SUBI C,FPAG+CONADJ
+ SKIPE INCORF ; SKIP IF TO CHANNEL
+ SUBI C,2 ; SUBTRACT FOR DOPE WORDS
+ PUSHJ P,ADWD
+ SKIPE INCORF
+ ADDI C,2 ; RESTORE C TO REAL ABOTN
+ ADDI C,CONADJ
+ PUSH P,C
+ MOVE C,TYPTAB
+ SUBI C,FPAG+CONADJ
+ MOVEI E,FPAG+2 ; SEND OUT START OF TYPE TABLE
+ PUSHJ P,ADWD
+ ADDI E,1 ; SEND OUT NUMPRI
+ MOVEI C,NUMPRI
+ PUSHJ P,ADWD
+ ADDI E,1 ; SEND OUT NUMSAT
+ MOVEI C,NUMSAT
+ PUSHJ P,ADWD
+
+
+
+; FINAL CLOSING OF INFERIORS
+
+DPCLS: PUSH P,PGCNT
+ PUSHJ P,INFCL1
+ POP P,PGCNT
+ POP P,A ; LENGTH OF CODE
+
+; RESTORE AC'S
+ MOVE PVP,PVSTOR+1
+ IRP AC,,[P,TP,TB,AB,FRM]
+ MOVE AC,AC!STO+1(PVP)
+ TERMIN
+
+ SETZB M,R
+ SETZM DUMFLG
+ SETZM GCDFLG ; ZERO FLAG INDICATING IN DUMPER
+ SETZM GCFLG ; AND INDICTOR TO INTERRUPT HANDLER THAT AGC IS ON
+ PUSH P,A
+ MOVE A,INF2 ; GET POINTER TO PURE MAPPED OUT
+ PUSHJ P,%GBINT
+
+ POP P,A
+ JRST EGCDUM
+
+
+ERDP: PUSH P,B
+ PUSHJ P,INFCLS
+ PUSHJ P,INFCL1
+ SETZM GCFLG
+ SETZM GPURFL ; PURE FLAG
+ SETZM DUMFLG
+ SETZM GCDFLG
+ POP P,A
+
+; RESTORE AC'S
+ MOVE PVP,PVSTOR+1
+ IRP AC,,[P,R,M,TP,TB,AB,FRM]
+ MOVE AC,AC!STO+1(PVP)
+ TERMIN
+
+ERDUMP: PUSH TP,$TATOM
+
+OFFSET 0
+
+ PUSH TP,EQUOTE STRUCTURE-CONTAINS-UNDUMPABLE-TYPE
+
+OFFSET OFFS
+
+ PUSH TP,$TATOM ; PUSH ON PRIMTYPE
+ PUSH TP,@STBL(A) ; PUSH ON PRIMTYPE
+ MOVEI A,2
+ JRST ERRKIL
+
+; ALTERNATE ATOM MARKER FOR DUMPER
+
+DATOMK: SKIPE GPURFL ; SKIP IF NOT IN PURIFIER
+ JRST PATOMK
+ CAILE A,0 ; SEE IF ALREADY MARKED
+ JRST GCRET
+ PUSH P,A ; SAVE PTR TO ATOM
+ HLRE B,A ; POINT TO DOPE WORD
+ SUB A,B ; TO FIRST DOPE WORD
+ MOVEI A,1(A) ; TO SECOND
+ PUSH P,A ; SAVE PTR TO DOPE WORD
+ HLRZ B,(A) ; GET LENGTH AND MARKING
+ TRZE B,400000 ; TURN OFF BIT AND SKIP IF UNMARKED
+ JRST DATMK1
+ IORM D,(A) ; MARK IT
+ MOVE 0,ABOTN ; GET CURRENT TOP OF ATOM TABLE
+ ADDI 0,-2(B) ; PLACE OF DOPE WORD IN TABLE
+ HRRM 0,(A) ; PUT IN RELOCATION
+ MOVEM 0,ABOTN ; FIXUP TOP OF TABLE
+ HRRM LPVP,-1(A) ; FIXUP CHAIN
+ MOVEI LPVP,(A)
+ MOVE A,-1(P) ; GET POINTER TO ATOM BACK
+ HRRZ B,2(A) ; GET OBLIST POINTER
+ JUMPE B,NOOB ; IF ZERO ON NO OBLIST
+ CAMG B,VECBOT ; DON'T SKIP IF OFFSET FROM TVP
+ MOVE B,(B)
+ HRLI B,-1
+DATMK3: MOVE A,$TOBLS ; SET UP FOR GET
+ MOVE C,$TATOM
+
+OFFSET 0
+ MOVE D,IMQUOTE OBLIST
+
+OFFSET OFFS
+
+ PUSH P,TP ; SAVE FPTR
+ MOVE TP,MAINPR
+ MOVE TP,TPSTO+1(TP) ; GET TP
+ PUSHJ P,IGET
+ POP P,TP ; RESTORE FPTR
+ MOVE C,-1(P) ; RECOVER PTR TO ATOM
+ ADDI C,1 ; SET UP TO MARK OBLIST ATOM
+ MOVSI D,400000 ; RESTORE MARK WORD
+
+OFFSET 0
+
+ CAMN B,MQUOTE ROOT
+
+OFFSET OFFS
+
+ JRST RTSET
+ MOVEM B,1(C)
+ MOVEI B,TATOM
+ PUSHJ P,MARK1 ; MARK IT
+ MOVEM A,1(C) ; SMASH IN ITS ID
+DATMK1:
+NOOB: POP P,A ; GET PTR TO DOPE WORD BACK
+ HRRZ A,(A) ; RETURN ID
+ SUB P,[1,,1] ; CLEAN OFF STACK
+ MOVEM A,(P)
+ JRST GCRET ; EXIT
+
+; HERE FOR A ROOT ATOM
+RTSET: SETOM 1(C) ; INDICATOR OF ROOT ATOM
+ JRST NOOB ; CONTINUE
+
+\f
+; INTERNAL PURIFY ROUTINE
+; SAVE AC's
+
+IPURIF: PUSHJ P,PURCLN ; GET RID OF PURE MAPPED
+ MOVE PVP,PVSTOR+1
+ IRP AC,,[P,R,M,TP,TB,AB,FRM]
+ MOVEM AC,AC!STO"+1(PVP)
+ TERMIN
+
+
+; HERE TO CREATE INFERIORS AND MARK THE ITEM
+PURIT1: MOVE PVP,PVSTOR+1
+ MOVEM P,PSTO+1(PVP) ; SAVE P
+ SETOM GPURFL ; INDICATE PURIFICATION IS TAKING PLACE
+ MOVE C,AB ; ARG PAIR
+ MOVEM C,SAVRS1 ; SAV PTR TO PAIR
+ MOVE P,GCPDL
+ PUSHJ P,INFSUP ; GET INFERIORS
+ MOVE P,A ; GET NEW PDL PTR
+ PUSHJ P,%SAVRP ; SAVE RPMAP TABLE FOR TENEX
+ MOVE C,SAVRS1 ; SET UP FOR MARKING
+ MOVE A,(C) ; GET TYPE WORD
+ MOVEM A,SAVRE2
+PURIT3: PUSH P,C
+ PUSHJ P,MARK2
+PURIT4: POP P,C ; RESTORE C
+ ADD C,[2,,2] ; TO NEXT ARG
+ JUMPL C,PURIT3
+ MOVEM A,SAVRES ; SAVE UPDATED POINTER
+
+; FIX UP IMPURE PART OF ATOM CHAIN
+
+ PUSH P,[0] ; FLAG INDICATING NON PURE SCAN
+ PUSHJ P,FIXATM
+ SUB P,[1,,1] ; CLEAN OFF STACK
+
+; NOW TO GET PURE STORAGE
+
+PURIT2: MOVEI A,@BOTNEW ; GET BOTNEW
+ SUBI A,2000-1777 ; START AT PAGE 1 AND ROUND
+ ANDCMI A,1777
+ ASH A,-10. ; TO PAGES
+ SETZ M,
+ PUSH P,A
+ PUSHJ P,PGFIND ; FIND THEM
+ JUMPL B,LOSLP2 ; LOST GO TO CAUSE AGC
+ HRRZ 0,BUFGC ;GET BUFFER PAGE
+ ASH 0,-10.
+ MOVEI A,(B) ; GET LOWER PORTION OF PAGES
+ MOVN C,(P)
+ SUBM A,C ; GET END PAGE
+ CAIL 0,(A) ; L? LOWER
+ CAILE 0,(C) ; G? HIGER
+ JRST NOREMP ; DON'T GET NEW BUFFER
+ PUSHJ P,%FDBUF ; GET A NEW BUFFER PAGE
+NOREMP: MOVN A,(P) ; SET UP AOBJN PTR FOR MAPIN
+ MOVE C,B ; SAVE B
+ HRL B,A
+ HRLZS A
+ ADDI A,1
+ MOVEM B,INF3 ; SAVE PTR FOR PURIFICATION
+ PUSHJ P,%MPIN1 ; MAP IT INTO PURE
+ ASH C,10. ; TO WORDS
+ MOVEM C,MAPUP
+ SUB P,[1,,1] ; CLEAN OFF STACK
+
+DONMAP:
+; RESTORE AC's
+ MOVE PVP,PVSTOR+1
+ MOVE P,PSTO+1(PVP) ; GET REAL P
+ PUSH P,LPVP
+ MOVEI A,@BOTNEW
+ MOVEM A,NABOTN
+
+ IRP AC,,[M,TP,TB,R,FRM]
+ MOVE AC,AC!STO+1(PVP)
+ TERMIN
+ MOVE A,INF1
+
+; NOW FIX UP POINTERS IN PURE STRUCTURE
+ MOVE 0,GCSBOT
+ MOVEM 0,OGCSTP
+ PUSH P,GCSBOT ; SAVE GCSBOT AND GCSTOP
+ PUSH P,GCSTOP
+ MOVE A,MAPUP ; NEW GCSBOT AND TOP TO FOOL GCHACK
+ MOVEM A,GCSBOT
+ ADD A,NABOTN
+ SUBI A,2000 ; ADJUSTMENT FOR START ON PAGE ONE
+ MOVEM A,GCSTOP
+ MOVE A,[PUSHJ P,NPRFIX]
+ MOVEI PVP,0 ; SAY MIGHT BE NON-ATOMS
+ PUSHJ P,GCHK10
+ POP P,GCSTOP
+ POP P,GCSBOT
+
+; NOW FIX UP POINTERS TO PURIFIED STRUCTURE
+
+ MOVE A,[PUSHJ P,PURFIX]
+ MOVEI PVP,0 ; SAY MIGHT BE NON-ATOMS
+ PUSHJ P,GCHACK
+
+ SETZM GCDFLG
+ SETZM DUMFLG
+ SETZM GCFLG
+
+ POP P,LPVP ; GET BACK LPVP
+ MOVE A,INF1
+ PUSHJ P,%KILJB ; KILL IMAGE SAVING INFERIOR
+ PUSH P,[-1] ; INDICATION OF PURE ATOM SCAN
+ PUSHJ P,FIXATM
+
+; SET UP PMAP SO THAT NEW PURE PAGES ARE INDICATED
+
+ MOVE A,INF3 ; GET AOBJN PTR TO PAGES
+FIXPMP: HRRZ B,A ; GET A PAGE
+ IDIVI B,16. ; DIVIDE SO AS TO PT TO PMAP WORD
+ PUSHJ P,PINIT ; SET UP PARAMETER
+ LSH D,-1
+ TDO E,D ; FIX UP WORD
+ MOVEM E,PMAPB(B) ; SEND IT BACK
+ AOBJN A,FIXPMP
+
+ SUB P,[1,,1]
+ MOVE A,[PUSHJ P,PURTFX] ; FIX UP PURE ATOM POINTERS
+ MOVEI PVP,1 ; SAY MIGHT BE NON-ATOMS
+ PUSHJ P,GCHACK
+
+; NOW FIX UP POINTERS IN PURE STRUCTURE
+ PUSH P,GCSBOT ; SAVE GCSBOT AND GCSTOP
+ PUSH P,GCSTOP
+ MOVE A,MAPUP ; NEW GCSBOT AND TOP TO FOOL GCHACK
+ MOVEM A,GCSBOT
+ ADD A,NABOTN
+ SUBI A,2000 ; ADJUSTMENT FOR START ON PAGE ONE
+ MOVEM A,GCSTOP
+ MOVE A,[PUSHJ P,PURTFX]
+ MOVEI PVP,1 ; SAY MIGHT BE NON-ATOMS
+ PUSHJ P,GCHK10
+ POP P,GCSTOP
+ POP P,GCSBOT
+
+; HERE TO FIX UP ATOMS WITH TYPES HACKED INTO THEIR GROWTH FIELD
+
+ MOVE A,TYPVEC+1 ; GET TYPE VECTOR
+ MOVEI B,400000 ; TLOSE==0
+TTFIX: HRRZ D,1(A) ; GET ADDR
+ HLRE C,1(A)
+ SUB D,C
+ HRRM B,(D) ; SMASH IT IN
+NOTFIX: ADDI B,1 ; NEXT TYPE
+ ADD A,[2,,2]
+ JUMPL A,TTFIX
+
+; NOW CLOSE UP INFERIORS AND RETURN
+
+PURCLS: MOVE P,[-2000,,MRKPDL]
+ PUSHJ P,%RSTRP ;RESETORE RPMAP TABLE FOR TENEX
+ PUSHJ P,INFCLS
+
+ MOVE PVP,PVSTOR+1
+ MOVE P,PSTO+1(PVP) ; RESTORE P
+ MOVE AB,ABSTO+1(PVP) ; RESTORE R
+
+ MOVE A,INF3 ; GET PTR TO PURIFIED STRUCTURE
+ SKIPN NPRFLG
+ PUSHJ P,%PURIF ; PURIFY
+
+ SETZM GPURFL
+ JRST EPURIF ; FINISH UP
+
+NPRFIX: PUSH P,A
+ PUSH P,B
+ PUSH P,C
+ EXCH A,C
+ PUSHJ P,SAT ; GET STORAGE ALLOCATION TYPE
+ MOVE C,MAPUP ; FIXUP AMOUNT
+ SUBI C,FPAG ; ADJUST FOR START ON FIRST PAGE
+ CAIE A,SLOCR ; DONT HACK TLOCRS
+ CAIN A,S1WORD ; SKIP IF NOT OF PRIMTYPE WORD
+ JRST LSTFXP
+ CAIN A,SATOM
+ JRST ATMFXP
+ CAIN A,SOFFS
+ JRST OFFFXP ; FIXUP OFFSETS
+ HRRZ D,1(B)
+ JUMPE D,LSTFXP ; SKIP IF NIL
+ CAMG D,PURTOP ; SEE IF ALREADY PURE
+ ADDM C,1(B)
+LSTFXP: TLNN B,.LIST. ; SKIP IF NOT A PAIR
+ JRST LSTEX1
+ HRRZ D,(B) ; GET REST OF LIST
+ SKIPE D ; SKIP IF POINTS TO NIL
+ PUSHJ P,RLISTQ
+ JRST LSTEX1
+ CAMG D,PURTOP ; SKIP IF ALREADY PURE
+ ADDM C,(B) ; FIX UP LIST
+LSTEX1: POP P,C
+ POP P,B ; RESTORE GCHACK AC'S
+ POP P,A
+ POPJ P,
+
+OFFFXP: HLRZ 0,D ; POINT TO LIST
+ JUMPE 0,LSTFXP ; POINTS TO NIL
+ CAML 0,PURTOP ; ALREADY PURE?
+ JRST LSTFXP ; YES
+ ADD 0,C ; UPDATE THE POINTER
+ HRLM 0,1(B) ; STUFF IT OUT
+ JRST LSTFXP ; DONE
+
+ATMFXP: HLRE 0,D ; GET LENGTH
+ SUB D,0 ; POINT TO FIRST DOPE WORD
+ HRRZS D
+ CAML D,OGCSTP
+ CAIL D,HIBOT ; SKIP IF IMPURE
+ JRST LSTFXP
+ HRRZ 0,1(D) ; GET RELOCATION
+ SUBI 0,1(D)
+ ADDM 0,1(B) ; FIX UP PTR IN STRUCTURE
+ JRST LSTFXP
+
+; FIXUP OF PURE ATOM POINTERS
+
+PURTFX: CAIE C,TATOM ; SKIP IF ATOM POINTER
+ POPJ P,
+ HLRE E,D ; GET TO DOPE WORD
+ SUBM D,E
+ SKIPL 1(E) ; SKIP IF MARKED
+ POPJ P,
+ HRRZ 0,1(E) ; RELATAVIZE PTR
+ SUBI 0,1(E)
+ ADD D,0 ; FIX UP PASSED POINTER
+ SKIPE B ; AND IF APPROPRIATE MUNG POINTER
+ ADDM 0,1(B) ; FIX UP POINTER
+ POPJ P,
+
+PURFIX: PUSH P,D
+ PUSH P,A
+ PUSH P,B
+ PUSH P,C ; SAVE AC'S FOR GCHACK
+ EXCH A,C ; GET TYPE IN A
+ CAIN A,TATOM ; CHECK FOR ATOM
+ JRST ATPFX
+ PUSHJ P,SAT
+
+ CAILE A,NUMSAT ; SKIP IF TEMPLATE
+ JRST TLFX
+IFN ITS, JRST @PURDSP(A)
+IFE ITS,[
+ HRRZ 0,PURDSP(A)
+ HRLI 0,400000
+ JRST @0
+]
+PURDSP:
+
+OFFSET 0
+
+DISTBS DUM1,TLFX,[[S2WORD,LPLSTF],[S2DEFR,LPLSTF],[SNWORD,VECFX],
+[S2NWORD,VECFX],[SSTORE,VECFX],[SBYTE,STRFX],[SATOM,ATPFX],[SLOCB,STRFX]
+[SCHSTR,STRFX],[SLOCL,LPLSTF],[SLOCV,VECFX],[SLOCU,VECFX],[SLOCS,VECFX],[SOFFS,OFFSFX]]
+
+OFFSET OFFS
+
+VECFX: HLRE 0,D ; GET LENGTH
+ SUB D,0 ; POINT TO D.W.
+ SKIPL 1(D) ; SKIP IF MARKED
+ JRST TLFX
+ HRRZ C,1(D)
+ SUBI C,1(D) ; CALCULATE RELOCATION
+ ADD C,MAPUP ; ADJUSTMENT
+ SUBI C,FPAG
+ ADDM C,1(B)
+TLFX: TLNN B,.LIST. ; SEE IF PAIR
+ JRST LVPUR ; LEAVE IF NOT
+ PUSHJ P,RLISTQ
+ JRST LVPUR
+ HRRZ D,(B) ; GET CDR
+ SKIPN D ; SKIP IF NOT ZERO
+ JRST LVPUR
+ MOVE D,(D) ; GET CADR
+ SKIPL D ; SKIP IF MARKED
+ JRST LVPUR
+ ADD D,MAPUP
+ SUBI D,FPAG
+ HRRM D,(B) ; FIX UP
+LVPUR: POP P,C
+ POP P,B
+ POP P,A
+ POP P,D
+ POPJ P,
+
+STRFX: MOVE C,B ; GET ARG FOR BYTDOP
+ PUSHJ P,BYTDOP
+ SKIPL (A) ; SKIP IF MARKED
+ JRST TLFX
+ HRRZ 0,(A) ; GET PTR IN NEW STRUCTURE
+ SUBI 0,(A) ; RELATAVIZE
+ ADD 0,MAPUP ; ADJUST
+ SUBI 0,FPAG
+ ADDM 0,1(B) ; FIX UP PTR
+ JRST TLFX
+
+ATPFX: HLRE C,D
+ SUBM D,C
+ SKIPL 1(C) ; SKIP IF MARKED
+ JRST TLFX
+ HRRZS C ; SEE IF PURE
+ CAIL C,HIBOT ; SKIP IF NOT PURE
+ JRST TLFX
+ HRRZ 0,1(C) ; GET PTR TO NEW ATOM
+ SUBI 0,1(C) ; RELATAVIZE
+ ADD D,0
+ JUMPE B,TLFX
+ ADDM 0,1(B) ; FIX UP
+ JRST TLFX
+
+LPLSTF: SKIPN D ; SKIP IF NOT PTR TO NIL
+ JRST TLFX
+ SKIPL (D) ; SKIP IF MARKED
+ JRST TLFX
+ HRRZ D,(D) ; GET UPDATED POINTER
+ ADD D,MAPUP ; ADJUSTMENT
+ SUBI D,FPAG
+ HRRM D,1(B)
+ JRST TLFX
+
+OFFSFX: HLRZS D ; LIST POINTER
+ JUMPE D,TLFX ; NIL
+ SKIPL (D) ; MARKED?
+ JRST TLFX ; NO
+ ADD D,MAPUP
+ SUBI D,FPAG ; ADJUST
+ HRLM D,1(B)
+ JRST TLFX ; RETURN
+
+; ROUTINES TO CAUSE A GARBAGE COLLECT WHEN EFFORTS TO GET STORAGE FAIL
+
+LOSLP1: MOVE A,ABOTN
+ MOVEM A,PARNEW ; SET UP GC PARAMS
+ MOVE C,[12.,,6]
+ JRST PURLOS
+
+LOSLP2: MOVEI A,@BOTNEW ; TOTAL AMOUNT NEEDED
+ ADDI A,1777
+ ANDCMI A,1777 ; CALCULATE PURE PAGES NEEDED
+ MOVEM A,GCDOWN
+ MOVE C,[12.,,8.]
+ JRST PURLOS
+
+PURLOS: MOVE P,[-2000,,MRKPDL]
+ PUSH P,GCDOWN
+ PUSH P,PARNEW
+ MOVE R,C ; GET A COPY OF A
+ PUSHJ P,INFCLS ; CLOSE INFERIORS AND FIX UP WORLD
+ PUSHJ P,INFCL2
+PURLS1: POP P,PARNEW
+ POP P,GCDOWN
+ MOVE C,R
+
+; RESTORE AC'S
+ MOVE PVP,PVSTOR+1
+ IRP AC,,[P,R,M,TP,TB,AB,FRM]
+ MOVE AC,AC!STO+1(PVP)
+ TERMIN
+
+ SETZM GCDFLG ; ZERO OUT FLAGS
+ SETZM DUMFLG
+ SETZM GPURFL
+ SETZM GCDANG
+
+ PUSHJ P,AGC ; GARBAGE COLLECT
+ JRST PURIT1 ; TRY AGAIN
+
+; PURIFIER ATOM MARKER
+
+PATOMK: HRRZ 0,A
+ CAMG 0,PARBOT
+ JRST GCRET ; DONE IF FROZEN
+ HLRE B,A ; GET TO D.W.
+ SUB A,B
+ SKIPG 1(A) ; SKIP IF NOT MARKED
+ JRST GCRET
+ HLRZ B,1(A)
+ IORM D,1(A) ; MARK THE ATOM
+ ADDM B,ABOTN
+ HRRM LPVP,(A) ; LINK ONTO CHAIN
+ MOVEI LPVP,1(A)
+ JRST GCRET ; EXIT
+
+\f
+.GLOBAL %LDRDO,%MPRDO
+
+; ROUTINES TO ALLOW GC-DUMPING OF PURIFIED STRUCTURES.
+
+; PROPUR MAPS PAGES CONTAINING PURIFIED STUFF INTO THE AGD INFERIOR SO THAT IN CASE
+; THE PAGES ARE MUNGED THEY CAN BE RESTORED USING MAPPING
+
+; REPURE REMAPS ANY PAGES THAT WERE MUNGED BY GC-DUMP BY RELOADING THEM FROM THE AGD
+; INFERIOR IN READ/EXEC MODE
+
+REPURE: PUSH P,[PUSHJ P,%LDRDO] ; INSTRUCTION FOR MAPPING IN PAGES FROM AGD INF
+ SKIPA
+PROPUR: PUSH P,[PUSHJ P,%MPRDO] ; INSTRUCTION FOR MAPPING PAGES TO AGD INF
+ MOVE A,PURBOT ; GET STARTING PAGE OF PURENESS
+ ASH A,-10. ; CONVERT TO PAGES
+ MOVEI C,HIBOT ; GET ENDING PAGE
+ ASH C,-10. ; CONVERT TO PAGES
+ PUSH P,A ; SAVE PAGE POINTER
+ PUSH P,C ; SAVE END OF PURENESS POINTER
+PROLOP: CAML A,(P) ; SKIP IF STILL PURE PAGES TO CHECK
+ JRST PRODON ; DONE MAPPING PAGES
+ PUSHJ P,CHKPGI ; SKIP IF PAGE IS PURE
+ JRST NOTPUR ; IT IS NOT
+ MOVE A,-1(P) ; GET PAGE TO MAP
+ XCT -2(P) ; MAP IN/OUT TO AGD INFERIOR IN READ/EXEC MODE
+NOTPUR: AOS A,-1(P) ; INCREMENT PAGE POINTER AND LOAD
+ JRST PROLOP ; LOOP BACK
+PRODON: SUB P,[3,,3] ; CLEAN OFF STACK
+ POPJ P, ; EXIT
+
+
+\f
+.GLOBAL %SAVIN,STOSTR,%CLMP1,%IMSAV,%IMSV1,ILOOKC,PSHGCF,BSETG,%GCJB1
+.GLOBAL %CLSJB,%KILJB,%IFMP1,%OPGFX,%FDBUF
+INFSU1: PUSH P,[-1] ; ENTRY USED BY GC-DUMP
+ SKIPA
+INFSUP: PUSH P,[0]
+ MOVE A,GLOTOP+1 ; GET GLOTOP FOR LOCR HACKS
+ MOVEM A,GLTOP
+ PUSHJ P,%FDBUF ; GET A BUFFER FOR C/W HACKS
+ SETOM GCDFLG
+ SETOM GCFLG
+ HLLZS SQUPNT
+ HRRZ TYPNT,TYPVEC+1 ; SETUP TYPNT
+ HRLI TYPNT,B
+ MOVEI A,STOSTR
+ ANDCMI A,1777 ; TO PAGE BOUNDRY
+ SUB A,GCSTOP ; SET UP AOBJN POINTER FOR C/W HACK
+ ASH A,-10. ; TO PAGES
+ HRLZS A
+ MOVEI B,STOSTR ; GET START OF MAPPING
+ ASH B,-10.
+ ADDI A,(B)
+ MOVEM A,INF1
+ PUSHJ P,%SAVIN ; PROTECT THE CORE IMAGE
+ SKIPGE (P) ; IF < 0 GC-DUMP CALL
+ PUSHJ P,PROPUR ; PROTECT PURE PAGES
+ SUB P,[1,,1] ; CLEAN OFF PSTACK
+ PUSHJ P,%CLSJB ; CLOSE INFERIOR
+
+ MOVSI D,400000 ; CREATE MARK WORD
+ SETZB LPVP,ABOTN ; ZERO ATOM COUNTER
+ MOVEI A,2000 ; MARKED INF STARTS AT PAGE ONE
+ HRRM A,BOTNEW
+ SETZM WNDBOT
+ SETZM WNDTOP
+ HRRZM A,FNTBOT
+ ADDI A,2000 ; WNDTOP
+ MOVEI A,1 ; TO PAGES
+ PUSHJ P,%GCJB1 ; CREATE THE JOB
+ MOVSI FPTR,-2000
+ MOVEI A,LPUR ; SAVE THE PURE CORE IMAGE
+ ANDCMI A,1777 ; TO PAGE BOUNDRY
+ MOVE 0,A ; COPY TO 0
+ ASH 0,-10. ; TO PAGES
+ SUB A,HITOP ; SUBTRACT TOP OF CORE
+ ASH A,-10.
+ HRLZS A
+ ADD A,0
+ MOVEM A,INF2
+ PUSHJ P,%IMSV1 ; MAP OUT INTERPRETER
+ PUSHJ P,%OPGFX
+
+; CREATE A PDL TO USE FOR THESE DUMPING FUNCTIONS
+
+ MOVE A,[-2000,,MRKPDL]
+ POPJ P,
+
+; ROUTINE TO CLOSE GC's INFERIOR
+
+
+INFCLS: MOVE A,INF2 ; GET POINTER TO PURE MAPPED OUT
+ PUSHJ P,%CLSMP
+ POPJ P,
+
+; CLOSE INFERIOR PROTECTING CORE IMAGE FOR GCDUMP
+
+INFCL2: PUSHJ P,%IFMP1 ; OPEN AGD INF TO RESTORE PAGES
+INFCL3: MOVE A,INF1 ; RESTORE OPENING POINTER
+ PUSH P,INF2
+ MOVE B,A ; SATIFY MUDITS
+ PUSHJ P,%IFMP2 ; MAP IN GC PAGES AND CLOSE INFERIOR
+ POP P,INF2 ; RESTOR INF2 PARAMETER
+ POPJ P,
+
+INFCL1: PUSHJ P,%IFMP1 ; OPEN AGD INF TO RESTORE PAGES
+ SKIPGE PURMNG ; SKIP IF NO PURE PAGES WERE MUNGED
+ PUSHJ P,REPURE ; REPURIFY MUNGED PAGES
+ JRST INFCL3
+
+\f
+
+; ROUTINE TO DO TYPE HACKING FOR GC-DUMP. IT MARKS THE TYPE-WORD OF THE
+; SLOT IN THE TYPE VECTOR. IT ALSO MARKS THE ATOM REPLACING THE I.D. IN
+; THE RIGHT HALF OF THE ATOM SLOT. IF THE TYPE IS A TEMPLATE THE FIRST
+; USE OF THE SAT HAS ITS ATOM MARKED AND THE I.D. IS PLACED IN THE LEFT
+; HALF OF THE ATOM SLOT (IT GETS THE REAL PRIMTYPE).
+
+TYPHK: CAILE B,NUMPRI ; SKIP IF A MUDDLE TYPE
+ JRST TYPHKR ; ITS A NEWTYPE SO GO TO TYPHACKER
+ CAIN B,TTYPEC ; SKIP IF NOT TYPE-C
+ JRST TYPCHK ; GO TO HACK TYPE-C
+ CAIE B,TTYPEW ; SKIP IF TYPE-W
+ POPJ P,
+ PUSH P,B
+ HLRZ B,A ; GET TYPE
+ JRST TYPHKA ; GO TO TYPE-HACKER
+TYPCHK: PUSH P,B ; SAVE TYPE-WORD
+ HRRZ B,A
+ JRST TYPHKA
+
+; GENERAL TYPE-HACKER FOR GC-DUMP
+
+TYPHKR: PUSH P,B ; SAVE AC'S
+TYPHKA: PUSH P,A
+ PUSH P,C
+ LSH B,1 ; GET OFFSET TO SLOT IN TYPE VECTOR
+ MOVEI C,(TYPNT) ; GET TO SLOT
+ ADDI C,(B)
+ SKIPGE (C)
+ JRST EXTYP
+ IORM D,(C) ; MARK THE SLOT
+ MOVEI B,TATOM ; NOW MARK THE ATOM SLOT
+ PUSHJ P,MARK1 ; MARK IT
+ HRRM A,1(C) ; SMASH IN ID
+ HRRZS 1(C) ; MAKE SURE THAT THATS ALL THATS THERE
+ HRRZ B,(C) ; GET SAT
+ ANDI B,SATMSK ; GET RID OF MAGIC BITS
+ HRRM B,(C) ; SMASH SAT BACK IN
+ CAIG B,NUMSAT ; SKIP IF TEMPLATE
+ JRST EXTYP
+ MOVE A,TYPSAV ; GET POINTER TO TYPE VECTOR
+ ADDI A,NUMPRI*2 ; GET TO NEWTYPES SLOTS
+ HRLI 0,NUMPRI*2
+ HLLZS 0 ; MAKE SURE ONLY LEFT HALF
+ ADD A,0
+TYPHK1: HRRZ E,(A) ; GET SAT OF SLOT
+ CAMN E,B ; SKIP IF NOT EQUAL
+ JRST TYPHK2 ; GOT IT
+ ADDI A,2 ; TO NEXT
+ JRST TYPHK1
+TYPHK2: PUSH P,C ; SAVE POINTER TO ORIGINAL SLOT
+ MOVE C,A ; COPY A
+ MOVEI B,TATOM ; SET UP FOR MARK
+ MOVE A,1(C) ; ASSUME MARK DOESN'T HAVE TO TAKE PLACE
+ SKIPL (C) ; DON'T MARK IF ALREADY MARKED
+ PUSHJ P,MARK
+ POP P,C ; RESTORE C
+ HRLM A,1(C) ; SMASH IN PRIMTYPE OF TEMPLATE
+EXTYP: POP P,C ; RESTORE AC'S
+ POP P,A
+ POP P,B
+ POPJ P, ; EXIT
+
+
+; A ROUTINE TO DISTINGUISH BETWEEN A DEFERRED AND A LIST POINTER
+RLISTQ: PUSH P,A
+ GETYP A,(B) ; GET TYPE
+ PUSHJ P,SAT ; GET SAT
+ CAIG A,NUMSAT ; NOT DEFERRED IF TEMPLATE
+ SKIPL MKTBS(A)
+ AOS -1(P) ; SKIP IF NOT DEFFERED
+ POP P,A
+ POPJ P, ; EXIT
+
+
+; DISPATCH TABLE FOR MARK PHASE ("SETZ'D" ENTRIES MUST BE DEFERRED)
+
+GCDISP:
+
+OFFSET 0
+
+DISTBS DUM2,GCRET,[[S2WORD,PAIRMK],[S2DEFR,DEFMK],[SNWORD,VECTMK],[STBASE,ERDP]
+[STPSTK,ERDP],[SARGS,ERDP],[S2NWORD,VECTMK],[SPSTK,ERDP],[SSTORE,VECTMK]
+[SFRAME,ERDP],[SBYTE,<SETZ BYTMK>],[SATOM,DATOMK],[SPVP,ERDP],[SGATOM,ERDP]
+[SLOCID,ERDP],[SCHSTR,<SETZ BYTMK>],[SASOC,ERDP],[SLOCL,PAIRMK],[SABASE,ERDP]
+[SLOCA,ERDP],[SLOCV,VECTMK],[SLOCU,VECTMK],[SLOCS,<SETZ BYTMK>],[SLOCN,ERDP]
+[SLOCB,<SETZ BYTMK>],[SLOCR,LOCRDP],[SOFFS,OFFSMK]]
+
+OFFSET OFFS
+
+\f
+; THIS SUBROUTINE IMPURIFIES A PURE ATOM TO ALLOW MODIFICATION OF SYSTEM SUBRS
+
+IMPRF: PUSH P,A
+ PUSH P,LPVP
+ PUSH TP,$TATOM
+ HLRZ C,(A) ; GET LENGTH
+ TRZ C,400000 ; TURN OF 400000 BIT
+ SUBI A,-1(C) ; POINT TO START OF ATOM
+ MOVNI C,-2(C) ; MAKE IT LOOK LIKE AN ATOM POINTER
+ HRL A,C
+ PUSH TP,A
+ MOVE C,A
+ MOVEI 0,(C)
+ PUSH P,AB
+ MOVE PVP,PVSTOR+1
+ MOVE AB,ABSTO+1(PVP)
+ PUSHJ P,IMPURX
+ POP P,AB
+ POP P,LPVP ; RESTORE A
+ POP P,A
+ POPJ P,
+
+FIXATM: PUSH P,[0]
+FIXTM5: JUMPE LPVP,FIXTM4
+ MOVEI B,(LPVP) ; GET PTR TO ATOMS DOPE WORD
+ HRRZ LPVP,-1(B) ; SET UP LPVP FOR NEXT IN CHAIN
+ SKIPE -2(P) ; SEE IF PURE SCAN
+ JRST FIXTM2
+ CAIL B,HIBOT
+ JRST FIXTM3
+FIXTM2: CAMG B,PARBOT ; SKIP IF NOT FROZEN
+ JRST FIXTM1
+ HLRZ A,(B)
+ TRZ A,400000 ; GET RID OF MARK BIT
+ MOVE D,A ; GET A COPY OF LENGTH
+ SKIPE -2(P)
+ JRST PFATM
+ PUSHJ P,CAFREE ; GET STORAGE
+ SKIPE GCDANG ; SEE IF WON
+ JRST LOSLP1 ; GO TO CAUSE GC
+ JRST FIXT10
+PFATM: PUSH P,AB
+ MOVE PVP,PVSTOR+1
+ MOVE AB,ABSTO+1(PVP)
+ SETZM GPURFL
+ PUSHJ P,CAFREE
+ SETOM GPURFL
+ POP P,AB
+FIXT10: SUBM D,ABOTN
+ MOVNS ABOTN
+ SUBI B,-1(D) ; POINT TO START OF ATOM
+ HRLZ C,B ; SET UP FOR BLT
+ HRRI C,(A)
+ ADDI A,-1(D) ; FIX UP TO POINT TO NEW DOPE WORD
+ BLT C,(A)
+ HLLZS -1(A)
+ HLLOS (A) ; -1 IN RELOCATION FIELD SINCE ITS NOT GARBAGE
+ ADDI B,-1(D) ; B POINTS TO SECOND D.W.
+ HRRM A,(B) ; PUT IN RELOCATION
+ MOVSI D,400000 ; UNMARK ATOM
+ ANDCAM D,(A)
+ CAIL B,HIBOT ; SKIP IF IMPURE
+ PUSHJ P,IMPRF
+ JRST FIXTM5 ; CONTINE FIXUP
+
+FIXTM4: POP P,LPVP ; FIX UP LPVP TO POINT TO NEW CHAIN
+ POPJ P, ; EXIT
+
+FIXTM1: HRRM B,(B) ; SMASH IN RELOCATION
+ MOVSI D,400000
+ ANDCAM D,(B) ; CLEAR MARK BIT
+ JRST FIXTM5
+
+FIXTM3: MOVE 0,(P)
+ HRRM 0,-1(B)
+ MOVEM B,(P) ; FIX UP CHAIN
+ JRST FIXTM5
+
+
+\f
+IAGC":
+
+;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 /GIN /]
+ 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: SUB P,[1,,1] ; POP OFF C
+ POP P,A
+ POP P,B
+ EXCH P,GCPDL
+ JRST .+1
+IAAGC:
+ HLLZS SQUPNT ; FLUSH SQUOZE TABLE
+ SETZB M,RCL ; ALTERNATE GC-ENTRY POINT FOR INITIALIZATION
+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,B
+
+CHPDL: MOVE D,P ; SAVE FOR LATER
+CORGET: MOVE P,[-2000,,MRKPDL]
+
+;FENCE POST PDLS AND CHECK IF ANY SHOULD BE SHRUNK
+
+ MOVEI 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
+ HRRM A,BOTNEW ; INTO POINTER WORD
+ HRRZM A,FNTBOT
+ SETZM WNDBOT
+ SETZM WNDTOP
+ MOVEM A,NPARBO
+ HRRZ A,BOTNEW ; GET PAGE TO START INF AT
+ ASH A,-10. ; TO PAGES
+ MOVEI R,(A) ; COPY A
+ PUSHJ P,%GCJOB ; GET PAGE HOLDER
+ MOVSI FPTR,-2000 ; FIX UP FRONTIER POINTER
+ MOVE A,WNDBOT
+ ADDI A,2000 ; FIND WNDTOP
+ MOVEM A,WNDTOP
+
+;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; MAP NEW PAIR SPACE IN FOR PAIR SPACE UPDATE
+
+NOMAP1: MOVEI A,@BOTNEW
+ ADDI A,1777 ; TO PAGE BOUNDRY
+ ANDCMI A,1777
+ MOVE B,A
+DOMAP: ASH B,-10. ; TO PAGES
+ MOVE A,PARBOT
+ MOVEI C,(A) ; COMPUTE HIS TOP
+ ASH C,-10.
+ ASH A,-10.
+ SUBM A,B ; B==> - # OF PAGES
+ HRLI A,(B) ; AOBJN TO SOURCE AND DEST
+ MOVE B,A ; IN CASE OF FUNNY
+ HRRI B,(C) ; MAP HIS POSSIBLE HIGHER OR LOWER PAGES
+ PUSHJ P,%INFMP ; NOW FLUSH INF AND MAKE HIS CORE MINE
+ JRST GARZER
+
+\f; CORE ADJUSTMENT PHASE
+
+CORADJ: MOVE A,PURTOP
+ SUB A,CURPLN ; ADJUST FOR RSUBR
+ ANDCMI A,1777 ; ROUND DOWN
+ MOVEM A,RPTOP
+ MOVEI A,@BOTNEW ; 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
+ MOVEI A,@BOTNEW ; GCSTOP
+ MOVEM A,GCSTOP
+ MOVE A,CORTOP ; ADJUST CORE IMAGE
+ ASH A,-10. ; TO PAGES
+TRYPCO: PUSHJ P,P.CORE
+ FATAL AGC--CORE SCREW UP
+ 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
+ MOVEI A,@BOTNEW
+ 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
+CORAD8: MOVEM A,CORTOP ; ADJUST PARAMETER
+ JRST CORAD6 ; WIN TOTALLY
+
+; 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;GARBAGE ZEROING PHASE
+GARZER: MOVE A,GCSTOP ;FIRST WORD OF GARBAGE IS AFTER PAIR SPACE
+ MOVE B,FRETOP ;LAST ADDRESS OF GARBAGE + 1
+ CAIL A,(B)
+ JRST GARZR1
+ CLEARM (A) ;ZERO THE FIRST WORD
+ CAIL A,-1(B) ; ARE WE AT THE TOP OF THE WORLD (FORMERLY CAML A,FRETOP)
+ JRST GARZR1 ; DON'T BLT
+IFE ITS,[
+ MOVEI B,777(A)
+ ANDCMI B,777
+]
+ HRLS A
+ ADDI A,1 ;MAKE A A BLT POINTER
+ BLT A,-1(B) ;AND COPY ZEROES INTO REST OF AREA
+IFE ITS,[
+
+; MAP UNWANTED PAGES OUT ON TWENEX (AFTER ZEROING REST OF LAST PAGE)
+
+ MOVE D,PURBOT
+ ASH D,-PGSZ
+ ASH B,-PGSZ
+ MOVNI A,1
+ MOVEI C,0
+ HRLI B,400000
+
+GARZR2: CAIG D,(B)
+ JRST GARZR1
+
+ PMAP
+ AOJA B,GARZR2
+]
+
+
+; 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
+ 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 IAGC
+
+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 ; LOADING ONE, M = 0 IS OK
+ JRST FINAGC
+
+ FATAL AGC--RUNNING RSUBR WENT AWAY
+
+AGCE1: FATAL AGC--TYPE VECTOR NOT OF TYPE VECTOR
+
+\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
+ 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,[111100,,-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 F,1(A) ; GET LNTH
+ LDB 0,[111100,,(A)] ; GET GROWTHS
+ TRZE 0,400 ; SIGN HACK
+ MOVNS 0
+ ASH 0,6 ; TO WORDS
+ ADD F,0
+ LDB 0,[001100,,(A)]
+ TRZE 0,400
+ MOVNS 0
+ ASH 0,6
+ ADD F,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: SKIPN DUMFLG
+ JUMPE A,CPOPJ ; NEVER MARK 0
+ MOVEI 0,1(A)
+ CAIL 0,@PURBOT
+ JRST GCRETD
+MARCON: PUSH P,A
+ HRLM C,-1(P) ;AND POINTER TO IT
+ ANDI B,TYPMSK ; FLUSH MONITORS
+ SKIPE DUMFLG ; SKIP IF NOT IN DUMPER
+ PUSHJ P,TYPHK ; HACK SOME TYPES
+ 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
+ SKIPN GCDFLG
+IFN ITS,[
+ JRST @MKTBS(B) ;AND GO MARK
+ JRST @GCDISP(B) ; DISPATCH FOR DUMPERS
+]
+IFE ITS,[
+ SKIPA E,MKTBS(B)
+ MOVE E,GCDISP(B)
+ HRLI E,-1
+ JRST (E)
+]
+; 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: TLOA TYPNT,400000 ;USE SIGN BIT AS FLAG
+
+;HERE TO MARK LIST ELEMENTS
+
+PAIRMK: TLZ TYPNT,400000 ;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
+ SKIPL FPTR ; SEE IF IN FRONTEIR
+ PUSHJ P,MOVFNT ; EXPAND THE FRONTEIR
+ MOVEM B,FRONT(FPTR)
+ MOVE 0,1(C) ; AND 2D
+ AOBJN FPTR,.+2 ; AOS AND CHECK FRONTEIR
+ PUSHJ P,MOVFNT ; EXPAND FRONTEIR
+ MOVEM 0,FRONT(FPTR)
+ ADD FPTR,[1,,1] ; MOVE ALONG IN FRONTIER
+
+
+PAIRM2: MOVEI A,@BOTNEW ; GET INF ADDR
+ SUBI A,2
+ HRRM A,(C) ; LEAVE A POINTER TO NEW HOME
+ HRRZ E,(P) ; GET BACK POINTER
+ JUMPE E,PAIRM7 ; 1ST ONE, NEW FIXUP
+ MOVSI 0,(HRRM) ; INS FOR CLOBBER
+ PUSHJ P,SMINF ; SMASH INF'S CORE IMAGE
+PAIRM4: MOVEM A,(P) ; NEW BACK POINTER
+ JUMPL TYPNT,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
+ ADDI E,1
+ MOVSI 0,(MOVEM)
+ PUSHJ P,SMINF
+ 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: SUB P,[1,,1]
+
+GCRET: TLZ TYPNT,400000 ;FOR PAIRMKS BENEFIT
+ HLRZ C,-1(P) ;RESTORE C
+ POP P,A
+ POPJ P, ;AND RETURN TO CALLER
+
+GCRETD: ANDI B,TYPMSK ; TURN OFF MONITORS
+ CAIN B,TLOCR ; SEE IF A LOCR
+ JRST MARCON
+ SKIPN GCDFLG ; SKIP IF IN PURIFIER OR DUMPER
+ POPJ P,
+ CAIE B,TATOM ; WE MARK PURE ATOMS
+ CAIN B,TCHSTR ; AND STRINGS
+ 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
+ PUSHJ P,MARK2 ;MARK THE DATUM
+ HRRZ E,-2(P) ; GET POINTER IN INF CORE
+ ADDI E,1
+ MOVSI 0,(MOVEM)
+ PUSHJ P,SMINF ; AND CLOBBER
+ HRRZ E,-2(P)
+ MOVE A,-1(P)
+ MOVSI 0,(HRRM) ; SMASH IN RIGHT HALF
+ PUSHJ P,SMINF
+ SUB P,[3,,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
+ MOVSI 0,(HRRM)
+ PUSHJ P,SMINF
+ JRST GCRETP
+
+RETNW1: MOVEM A,-1(P)
+ JRST GCRETP
+
+; ROUTINE TO EXPAND THE FRONTEIR
+
+MOVFNT: PUSH P,B ; SAVE REG B
+ HRRZ A,BOTNEW ; CURRENT BOTTOM OF WINDOW
+ ADDI A,2000 ; MOVE IT UP
+ HRRM A,BOTNEW
+ HRRZM A,FNTBOT ; BOTTOM OF FRONTEIR
+ MOVEI B,FRNP
+ ASH A,-10. ; TO PAGES
+ PUSHJ P,%GETIP
+ PUSHJ P,%SHWND ; SHARE THE PAGE
+ MOVSI FPTR,-2000 ; FIX UP FPTR
+ POP P,B
+ POPJ P,
+
+
+; ROUTINE TO SMASH INFERIORS PPAGES
+; E/ ADDR IN INF, A/ THING TO SMASH ,0/ INS TO USE
+
+SMINF: CAMGE E,FNTBOT
+ JRST SMINF1 ; NOT IN FRONTEIR
+ SUB E,FNTBOT ; ADJUST POINTER
+ IOR 0,[0 A,FRONT(E)] ; BUILD INSTRUCTION
+ XCT 0 ; XCT IT
+ POPJ P, ; EXIT
+SMINF1: CAML E,WNDBOT
+ CAML E,WNDTOP ; SEE IF IN WINDOW
+ JRST SMINF2
+SMINF3: SUB E,WNDBOT ; FIX UP
+ IOR 0,[0 A,WIND(E)] ; FIX INS
+ XCT 0
+ POPJ P,
+SMINF2: PUSH P,A ; SAVE E
+ PUSH P,B ; SAVE B
+ HRRZ A,E ; E SOMETIMES HAS STUFF IN LH
+ ASH A,-10.
+ MOVEI B,WNDP ; WINDOW PAGE
+ PUSHJ P,%SHWND ; SHARE IT
+ ASH A,10. ; TO PAGES
+ MOVEM A,WNDBOT ; UPDATE POINTERS
+ ADDI A,2000
+ MOVEM A,WNDTOP
+ POP P,B ; RESTORE ACS
+ POP P,A
+ JRST SMINF3 ; FIX UP INF
+
+
+
+\f; VECTOR AND TP MARKER, SIGN OF TYPNT IS SET BASED ON WHICH ONE
+
+TPMK: TLOA TYPNT,400000 ;SET TP MARK FLAG
+VECTMK: TLZ TYPNT,400000
+ MOVEI 0,@BOTNEW ; POINTER TO INF
+ PUSH P,0
+ 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
+
+ HLLM TYPNT,(P) ; SAVE MARKER INDICATING STACK
+ JUMPGE TYPNT,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,[111100,,-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,[001100,,-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 F,(E) ;SAVE A COPY
+ ADD F,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
+ SKIPGE B,-1(A) ;SKIP IF UNIFORM
+ TLNE B,377777-.VECT. ;SKIP IF NOT SPECIAL
+ JUMPGE TYPNT,NOTGEN ;JUMP IF NOT A GENERAL VECTOR
+
+GENRAL: HLRZ 0,B ;CHECK FOR PSTACK
+ TRZ 0,.VECT.
+ JUMPE 0,NOTGEN ;IT ISN'T GENERAL
+ JUMPL TYPNT,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
+ HRRZ E,-1(P) ; GET POINTER INTO INF
+ SKIPN C ; SKIP IF NO BOTTOM GROWTH
+ JRST MOVEC3
+ JUMPL C,.+3 ; SEE IF BOTTOM SHRINKAGE
+ ADD E,C ; GROW IT
+ JRST MOVEC3 ; CONTINUE
+ HRLM C,E ; MOVE SHRINKAGE FOR TRANSFER PHASE
+MOVEC3: PUSHJ P,DOPMOD ; MODIFY DOPE WORD AND PLACE IN INF
+ PUSHJ P,TRBLKV ; SEND VECTOR INTO INF
+TGROT: CAMGE A,PARBOT ; SKIP IF NOT STORAGE
+ JRST TGROT1
+ MOVE C,DOPSV1 ; RESTORE DOPE WORD
+ SKIPN (P) ; DON'T RESTORE D.W.'S YET IF THERE IS GROWTH
+ MOVEM C,-1(A)
+TGROT1: POP P,C ; IS THERE TOP GROWH
+ SKIPN C ; SEE IF ANY GROWTH
+ JRST DOPEAD
+ SUBI E,2
+ SKIPG C
+ JRST OUTDOP
+ PUSH P,C ; SAVE C
+ SETZ C, ; ZERO C
+ PUSHJ P,ADWD
+ ADDI E,1
+ SETZ C, ; ZERO WHERE OLD DOPE WORDS WERE
+ PUSHJ P,ADWD
+ POP P,C
+ ADDI E,-1(C) ; MAKE ADJUSTMENT FOR TOP GROWTH
+OUTDOP: PUSHJ P,DOPOUT
+DOPEAD:
+EXVECT: HLRZ B,(P)
+ SUB P,[1,,1] ; GET RID OF FPTR
+ PUSHJ P,RELATE ; RELATIVIZE
+ TRNN B,400000 ; WAS THIS A STACK
+ JRST 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
+ POP P,C
+ 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
+ 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)
+ PUSHJ P,OUTTP ; MOVE OUT TYPE
+ MOVE A,R
+ PUSHJ P,OUTTP ; SEND OUT VALUE
+ 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)
+ PUSHJ P,OUTTP ; SEND IT OUT
+ 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)
+ PUSHJ P,OUTTP ; SEND IT OUT
+ MOVE A,-2(P) ; ADJUST AB SLOT
+ ADD A,ABSAV-FSAV+1(C) ; POINT TO SAVED AB
+ PUSHJ P,OUTTP ; SEND IT OUT
+ 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
+ PUSHJ P,OUTTP ; SEND IT OUT
+ HRROI C,PSAV-FSAV(C) ;POINT TO SAVED P
+ MOVEI B,TPDL
+ PUSHJ P,MARK1 ;AND MARK IT
+ PUSHJ P,OUTTP ; SEND IT OUT
+ 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
+ PUSHJ P,OUTTP
+ MOVE A,PCSAV-PSAV+1(C)
+ PUSHJ P,OUTTP
+ 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)
+ PUSHJ P,OUTTP ; FIX UP CHAIN
+ MOVEI B,TATOM ; RESTORE IN CASE SMASHED
+ PUSHJ P,MARK1 ; MARK ATOM
+ PUSHJ P,OUTTP ; SEND IT OUT
+ 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)
+ PUSHJ P,OUTTP ; MOVE OUT TYPE
+ MOVE A,R
+ PUSHJ P,OUTTP ; SEND OUT VALUE
+ 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
+ PUSHJ P,OUTTP
+ SKIPL A,1(C) ; PREV LOC?
+ JRST NOTLCI
+ MOVEI B,TLOCI ; NOW MARK LOCATIVE
+ PUSHJ P,MARK1
+NOTLCI: PUSHJ P,OUTTP
+ 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
+ PUSHJ P,OUTTP
+ ADDI C,1 ; INCREMENT C FOR FENCE-POST
+ SUB P,[1,,1] ; CLEAN UP STACK
+ POP P,E ; GET UPDATED PTR TO INF
+ SUB P,[2,,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
+ PUSHJ P,DOPMOD ; FIX UP DOPE WORDS
+ PUSHJ P,DOPOUT ; SEND THEM OUT
+ JRST DOPEAD
+
+
+\f; ROUTINE TO ALLOCATE ROOM FOR VECTORS IN INFERIOR
+; F= # OF WORDS TO ALLOCATE
+
+ALLOGC: HRRZS A ; GET ABS VALUE
+ SKIPN GCDFLG ; SKIP IF IN DUMPER
+ CAML A,GCSBOT ; SKIP IF IN STORAGE
+ JRST ALOGC2 ; JUMP IF ALLOCATING
+ HRRZ 0,A
+ POPJ P,
+ALOGC2: PUSH P,A ; SAVE A
+ALOGC1: HLRE 0,FPTR ; GET ROOM LEFT
+ ADD 0,F ; SEE IF ITS ENOUGH
+ JUMPL 0,ALOCOK
+ MOVE F,0 ; MODIFY F
+ PUSH P,F
+ PUSHJ P,MOVFNT ; MOVE UP FRONTEIR
+ POP P,F
+ JRST ALOGC1 ; CONTINUE
+ALOCOK: ADD FPTR,F ; MODIFY FPTR
+ HRLZS F
+ ADD FPTR,F
+ POP P,A ; RESTORE A
+ MOVEI 0,@BOTNEW
+ SUBI 0,1 ; RELOCATION PTR
+ POPJ P, ; EXIT
+
+
+
+
+; TRBLK MOVES A VECTOR INTO THE INFERIOR
+; E= STARTING ADDR IN INF A= DOPE WORD OF VECTOR
+
+TRBLK: HRRZS A
+ SKIPE GCDFLG
+ JRST TRBLK7
+ CAMGE A,GCSBOT ; SEE IF IN GC-SPACE
+ JRST FIXDOP
+TRBLK7: PUSH P,A
+ HLRZ 0,(A)
+ TRZ 0,400000 ; TURN OFF GC FLAG
+ HRRZ F,A
+ HLRE A,E ; GET SHRINKAGE
+ ADD 0,A ; MUNG LENGTH
+ SUB F,0
+ ADDI F,1 ; F POINTS TO START OF VECTOR
+TRBLK2: HRRZ R,E ; SAVE POINTER TO INFERIOR
+ ADD E,0 ; E NOW POINTS TO FINAL ADDRESS+1
+ MOVE M,E ;SAVE E
+TRBLK1: MOVE 0,R
+ SUBI E,1
+ CAMGE R,FNTBOT ; SEE IF IN FRONTEIR
+ JRST TRBL10
+ SUB E,FNTBOT ; ADJUST E
+ SUB 0,FNTBOT ; ADJ START
+ MOVEI A,FRONT+1777
+ JRST TRBLK4
+TRBL10: CAML R,WNDBOT
+ CAML R,WNDTOP ; SEE IF IN WINDOW
+ JRST TRBLK5 ; NO
+ SUB E,WNDBOT
+ SUB 0,WNDBOT
+ MOVEI A,WIND+1777
+TRBLK4: ADDI 0,-1777(A) ; CALCULATE START IN WINDOW OR FRONTEIR
+ CAIL E,2000
+ JRST TRNSWD
+ ADDI E,-1777(A) ; SUBTRACT WINDBOT
+ HRL 0,F ; SET UP FOR BLT
+ BLT 0,(E)
+ POP P,A
+
+FIXDOP: IORM D,(A)
+ MOVE E,M ; GET END OF WORD
+ POPJ P,
+TRNSWD: PUSH P,B
+ MOVEI B,1(A) ; GET TOP OF WORLD
+ SUB B,0
+ HRL 0,F
+ BLT 0,(A)
+ ADD F,B ; ADJUST F
+ ADD R,B
+ POP P,B
+ MOVE E,M ; RESTORE E
+ JRST TRBLK1 ; CONTINUE
+TRBLK5: HRRZ A,R ; COPY E
+ ASH A,-10. ; TO PAGES
+ PUSH P,B ; SAVE B
+ MOVEI B,WNDP ; IT IS WINDOW
+ PUSHJ P,%SHWND
+ ASH A,10. ; TO PAGES
+ MOVEM A,WNDBOT ; UPDATE POINTERS
+ ADDI A,2000
+ MOVEM A,WNDTOP
+ POP P,B ; RESTORE B
+ JRST TRBL10
+
+
+
+
+; ALTERNATE ENTRY FOR VECTORS WHICH TAKES CARE OF SHRINKAGE
+
+TRBLKV: HRRZS A
+ SKIPE GCDFLG ; SKIP IF NOT IN DUMPER
+ JRST TRBLV2
+ CAMGE A,GCSBOT ; SEE IF IN GC-SPACE
+ JRST FIXDOP
+TRBLV2: PUSH P,A ; SAVE A
+ HLRZ 0,DOPSV2
+ TRZ 0,400000
+ HRRZ F,A
+ HLRE A,E ; GET SHRINKAGE
+ ADD 0,A ; MUNG LENGTH
+ SUB F,0
+ ADDI F,1 ; F POINTS TO START OF VECTOR
+ SKIPGE -2(P) ; SEE IF SHRINKAGE
+ ADD 0,-2(P) ; IF SO COMPENSATE
+ JRST TRBLK2 ; CONTINUE
+
+; ALTERNATE ENTRY POINT TO TRBLK A==> OBJECT TO SEND IN 0= # OF WORDS
+
+TRBLK3: PUSH P,A ; SAVE A
+ MOVE F,A
+ JRST TRBLK2
+
+; FINAL ALTERNATE ENTRY POINT TO TRBLK A==> OBJECT
+; F==> START OF TRANSFER IN GCS 0= # OF WORDS
+
+TRBLKX: PUSH P,A ; SAVE A
+ JRST TRBLK2 ; SEND IT OUT
+
+
+; OUTTP IS THE ROUTINE THAT TPMK USES TO SEND OUT ELEMENTS FOR THE SCAN
+; -2(P) CONTAINS THE ADDR IN THE INF AND IT IS UPDATED
+; A CONTAINS THE WORD TO BE SENT OUT
+
+OUTTP: AOS E,-2(P) ; INCREMENT PLACE
+ MOVSI 0,(MOVEM) ; INS FOR SMINF
+ SOJA E,SMINF
+
+
+; ADWD PLACES ONE WORD IN THE INF
+; E ==> INF C IS THE WORD
+
+ADWD: PUSH P,E ; SAVE AC'S
+ PUSH P,A
+ MOVE A,C ; GET WORD
+ MOVSI 0,(MOVEM) ; INS FOR SMINF
+ PUSHJ P,SMINF ; SMASH IT IN
+ POP P,A
+ POP P,E
+ POPJ P, ; EXIT
+
+; DOPOUT IS USED TO SEND OUT THE DOPE WORDS IN UNUSUAL CALSE
+; SUCH AS THE TP AND GROWTH
+
+
+DOPOUT: MOVE C,-1(A)
+ PUSHJ P,ADWD
+ ADDI E,1
+ MOVE C,(A) ; GET SECOND DOPE WORD
+ TLZ C,400000 ; TURN OFF POSSIBLE MARK BIT
+ PUSHJ P,ADWD
+ MOVE C,DOPSV1 ; FIX UP FIRST DOPE WORD
+ MOVEM C,-1(A)
+ MOVE C,DOPSV2
+ MOVEM C,(A) ; RESTORE SECOND D.W.
+ POPJ P,
+
+; DOPMOD MODIFIES THE DOPE WORD OF A VECTOR AND PLACES A NEW DOPE-WORD IN INF
+; A ==> DOPE WORD E==> INF
+
+DOPMOD: SKIPE GCDFLG ; CHECK TO SEE IF IN DUMPER AND PURIFY
+ JRST .+3
+ CAMG A,GCSBOT
+ POPJ P, ; EXIT IF NOT IN GCS
+ MOVE C,-1(A) ; GET FIRST DOPE WORD
+ MOVEM C,DOPSV1
+ HLLZS C ; CLEAR OUT GROWTH
+ TLO C,.VECT. ; FIX UP FOR GCHACK
+ PUSH P,C
+ MOVE C,(A) ; GET SECOND DOPE WORD
+ HLRZ B,(A) ; GET LENGTH
+ TRZ B,400000 ; TURN OFF MARK BIT
+ MOVEM C,DOPSV2
+ HRRZ 0,-1(A) ; CHECK FOR GROWTH
+ JUMPE 0,DOPMD1
+ LDB 0,[111100,,-1(A)] ; MODIFY WITH GROWTH
+ TRZE 0,400
+ MOVNS 0
+ ASH 0,6
+ ADD B,0
+ LDB 0,[001100,,-1(A)]
+ TRZE 0,400
+ MOVNS 0
+ ASH 0,6
+ ADD B,0
+DOPMD1: HRL C,B ; FIX IT UP
+ MOVEM C,(A) ; FIX IT UP
+ POP P,-1(A)
+ POPJ P,
+
+ADPMOD: CAMG A,GCSBOT
+ POPJ P, ; EXIT IF NOT IN GCS
+ MOVE C,-1(A) ; GET FIRST DOPE WORD
+ TLO C,.VECT. ; FIX UP FOR GCHACK
+ MOVEM C,-1(A)
+ MOVE C,(A) ; GET SECOND DOPE WORD
+ TLZ C,400000 ; TURN OFF PARK BIT
+ MOVEM C,(A)
+ POPJ P,
+
+
+
+
+\f; RELATE RELATAVIZES A POINTER TO A VECTOR
+; B IS THE POINTER A==> DOPE WORD
+
+RELATE: SKIPE GCDFLG ; SEE IF DUMPER OR PURIFIER
+ JRST .+3
+ CAMGE A,GCSBOT ; SEE IF IN VECTOR SPACE
+ POPJ P, ; IF NOT EXIT
+ MOVE C,-1(P)
+ HLRE F,C ; GET LENGTH
+ HRRZ 0,-1(A) ; CHECK FO GROWTH
+ JUMPE A,RELAT1
+ LDB 0,[111100,,-1(A)] ; GET TOP GROWTH
+ TRZE 0,400 ; HACK SIGN BIT
+ MOVNS 0
+ ASH 0,6 ; CONVERT TO WORDS
+ SUB F,0 ; ACCOUNT FOR GROWTH
+RELAT1: HRLM F,C ; PLACE CORRECTED LENGTH BACK IN POINTER
+ HRRZ F,(A) ; GET RELOCATED ADDR
+ SUBI F,(A) ; FIND RELATIVIZATION AMOUNT
+ ADD C,F ; 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)
+ PUSH P,A
+ MOVEI C,-1(P)
+ MOVEI B,TTP
+ PUSHJ P,MARK
+ SUB P,[1,,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 F,OTBSAV(A) ; GET TIME FROM FRAME
+ CAME B,F ; 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 F,-1(A) ; GET THE TYPE
+ ANDI F,SATMSK ; FLUSH MONITOR BITS
+ CAIN F,SATOM ; SEE IF ATOM
+ JRST ATMSET
+ HLRE F,(A) ; GET MARKING
+ JUMPL F,BYTREL ; JUMP IF MARKED
+ HLRZ F,(A) ; GET LENGTH
+ PUSHJ P,ALLOGC ; ALLOCATE FOR IT
+ HRRM 0,(A) ; SMASH IT IN
+ MOVE E,0
+ HLRZ F,(A)
+ SUBI E,-1(F) ; ADJUST INF POINTER
+ IORM D,(A)
+ PUSHJ P,ADPMOD
+ PUSHJ P,TRBLK
+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
+ SKIPN DUMFLG
+ JRST BYTREL
+ HRRM A,(P)
+ MOVSI E,STATM ; GET "STRING IS ATOM BIT"
+ IORM E,(P)
+ JRST BYTREL ; TO BYTREL
+\f
+
+; MARK OFFSET
+
+OFFSMK: HLRZS A
+ PUSH P,$TLIST
+ PUSH P,A ; PUSH LIST POINTER ON THE STACK
+ MOVEI C,-1(P) ; POINTER TO PAIR
+ PUSHJ P,MARK2 ; MARK THE LIST
+ HRLM A,-2(P) ; UPDATE POINTER IN OFFSET
+ SUB P,[2,,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
+ HLRZ 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,@BOTNEW
+ PUSH P,0 ; SAVE POINTER TO INF
+ TLO TYPNT,.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) ; MAKE SURE ATOMS NOT ON OBLISTS GET SENT
+ POP P,A ; RESTORE A
+ POP P,E ; GET POINTER INTO INF
+ SKIPN GCHAIR
+ JUMPN 0,ATMREL
+ PUSHJ P,ADPMOD
+ PUSHJ P,TRBLK
+ATMREL: HRRZ E,(A) ; RELATAVIZE
+ SUBI E,(A)
+ ADDM E,(P)
+ JRST GCRET
+ATMRL1: SUB P,[1,,1] ; POP OFF STACK
+ JRST ATMREL
+
+\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 F,(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: SUB P,[1,,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
+ PUSH P,E
+ SKIPE DUMFLG ; SKIP IF NOT IN DUMPER
+ PUSHJ P,TYPHK ; HACK WITH TYPE IF SPECIAL
+ POP P,E ; RESTORE LENGTH
+ MOVE F,B ; AND COPY IT
+ LSH B,1 ;FIND OUT WHERE IT WILL GO
+ HRRZ B,@TYPNT ;GET SAT IN B
+ ANDI B,SATMSK
+ MOVEI C,@MKTBS(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,F ;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
+
+ SUB P,[2,,2] ;REMOVE STACK CRAP
+ JRST UMOVEC
+
+
+SPECLS: FATAL AGC--UNRECOGNIZED SPECIAL VECTOR
+ SUB P,[4,,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,@BOTNEW ; 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,A ; GET PTR TO D.W.
+ POP P,E ; GET PTR TO INF
+ SUB P,[1,,1] ; GET RID OF TOP
+ PUSHJ P,ADPMOD ; FIX UP D.W.
+ PUSHJ P,TRBLK ; SEND IT OUT
+ JRST ATMREL ; RELATIVIZE AND LEAVE
+GCRDRL: POP P,A ; GET PTR TO D.W
+ SUB P,[2,,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
+ SKIPN DUMFLG ; IF GC-DUMP, WILL STORE ATOM FOR LOCR
+ JRST LOCRDD
+ MOVEI B,1
+ IORM B,3(A) ; MUNG ATOM TO SAY IT IS LOCR
+ CAIA
+LOCRDD: 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 E,(A) ; GET PTR IN FRONTEIR
+ SUBI E,ASOLNT+1 ; ADJUST TO POINT TO BEGINNING
+ PUSHJ P,ADPMOD
+ PUSHJ P,TRBLK
+ JRST ASTR1
+
+;HERE WHEN A VECTOR POINTER IS BAD
+
+VECTB1:FATAL AGC--VECTOR POINTS OUTSIDE OF VECTOR SPACE
+ SUB P,[1,,1] ; RECOVERY
+AFIXUP: SETZM (P) ; CLOBBER SLOT
+ JRST GCRET ; CONTINUE
+
+
+VECTB2: FATAL AGC--VECTOR POINTS OUT OF VECTOR SPACE
+ SUB P,[2,,2]
+ JRST AFIXUP ; RECOVER
+
+PARERR: FATAL AGC--PAIR POINTS OUT OF PAIR SPACE
+ SUB P,[1,,1] ; RECOVER
+ JRST AFIXUP
+
+
+\f; HERE TO MARK TEMPLATE DATA STRUCTURES
+
+TD.MRK: MOVEI 0,@BOTNEW ; 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 E,-7(P) ; RESTORE PTR TO FRONTEIR
+ SUB P,[7,,7] ; CLEAN UP STACK
+USRAG1: ADDI A,1 ; POINT TO SECOND D.W.
+ MOVSI D,400000 ; SET UP MARK BIT
+ PUSHJ P,ADPMOD
+ PUSHJ P,TRBLK ; SEND IT OUT
+TMPREL: SUB P,[1,,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 E,(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 F,(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 F,(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,F
+ HLRE F,ASOLNT-INDIC+1(C) ; GET LENGTH
+ JUMPL F,.+3 ; SKIP IF MARKED
+ CAMGE C,VECBOT ; SKIP IF IN VECT SPACE
+ JRST ASOM20
+ HRRM FPTR,ASOLNT-INDIC+1(C) ; PUT IN RELATIVISATION
+ MOVEI F,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,F
+ 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(F) ; 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
+ TLZE TYPNT,.ATOM. ; ANY ATOMS MARKED?
+ JRST VALFLA ; YES, CHECK VALUES
+VALFL8:
+
+; NOW SEE WHICH CHANNELS STILL POINTED TO
+
+CHNFL3: MOVEI 0,N.CHNS-1
+ MOVEI A,CHNL1 ; SLOTS
+ HRLI A,TCHAN ; TYPE HERE TOO
+
+CHNFL2: SKIPN B,1(A)
+ JRST CHNFL1
+ HLRE C,B
+ SUBI B,(C) ; POINT TO DOPE
+ HLLM A,(A) ; PUT TYPE BACK
+ HRRE F,(A) ; SEE IF ALREADY MARKED
+ JUMPN F,CHNFL1
+ SKIPGE 1(B)
+ JRST CHNFL8
+ HLLOS (A) ; MARK AS A LOSER
+ SETZM -1(P)
+ JRST CHNFL1
+CHNFL8: MOVEI F,1 ; MARK A GOOD CHANNEL
+ HRRM F,(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
+
+ SUB P,[2,,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 F,A ; CALCULATE START OF TP IN F
+ HLRZ B,(A) ; ADJUST INF PTR
+ TRZ B,400000
+ SUBI F,-1(B)
+ LDB M,[111100,,-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: SUB P,[1,,1] ; CLEAN UP STACK
+ SUBI E,-1(B)
+ HRRI B,(R) ; GET POINTER TO THIS-PROCESS BINDING
+ MOVEI B,6(B) ; POINT AFTER THE BINDING
+ MOVE 0,F ; CALCULATE # OF WORDS TO SEND OUT
+ SUBM B,0
+ PUSH P,R ; PRESERVE R
+ PUSHJ P,TRBLKX ; SEND IT OUT
+ POP P,R ; RESTORE R
+ HRRZS R,2(R) ; GET THE NEXT PROCESS
+ SKIPN R
+ JRST .+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 A,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 SPECIAL STUFF FROM GCHAIR
+
+SPCOUT: HLRE B,A
+ SUB A,B
+ MOVEI A,1(A) ; POINT TO DOPE WORD
+ LDB 0,[001100,,-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
+ PUSHJ P,DOPMOD
+ HRRZ E,(A) ; GET PTR TO INF
+ HLRZ B,(A) ; LENGTH
+ TRZ B,400000 ; GET RID OF MARK BIT
+ SUBI E,-1(B)
+ ADD E,0
+ PUSH P,0 ; DUMMY FOR TRBLKV
+ PUSHJ P,TRBLKV ; OUT IT GOES
+ SUB P,[1,,1]
+ 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,F
+ PUSHJ P,MARK2
+ MOVEM A,1(C)
+ POP P,F
+ 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
+ SUB P,[1,,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: ADDI 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 F,ASOLNT+1(B) ;AND ITS RELOCATION
+ SUBI F,ASOLNT+1(B) ; RELATIVIZE
+ MOVSI F,(F)
+ ADDM F,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 F,ASOLNT+1(B) ;RELOC
+ SUBI F,ASOLNT+1(B)
+ MOVSI F,(F)
+ ADDM F,NODPNT(A)
+ASOUP5: POP P,A ; RECOVER PTR TO DOPE WORD
+ MOVEI A,ASOLNT+1(A)
+ MOVSI B,400000 ;UNMARK IT
+ XORM B,(A)
+ HRRZ E,(A) ; SET UP PTR TO INF
+ HLRZ B,(A)
+ SUBI E,-1(B) ; ADJUST PTR
+ PUSHJ P,ADPMOD
+ PUSHJ P,TRBLK ; OUT IT GOES
+ 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 F,1(C) ; FIND NEXT ATOM
+ SUBI C,-2(F)
+ 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
+ MOVSI D,400000 ;UNMARK IT
+ XORM D,1(A)
+ HRRZ E,1(A) ; SET UP PTR TO INF
+ HLRZ B,1(A)
+ SUBI E,-1(B) ; ADJUST PTR
+ MOVEI A,1(A)
+ PUSHJ P,ADPMOD
+ PUSHJ P,TRBLK ; OUT IT GOES
+ 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
+
+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
+
+DOPSV1: 0 ;SAVED FIRST D.W.
+DOPSV2: 0 ; SAVED LENGTH
+
+
+; LOCATIONS USED BY BLOAT-STAT TO HELP THE USER PICK BLOAT SPECIFICATIONS.
+;
+
+GCNO: 0 ; USER-CALLED GC
+BSTGC: 0 ; FREE STORAGE
+ 0 ; BLOWN TP
+ 0 ; TOP-LEVEL LVALS
+ 0 ; GVALS
+ 0 ; TYPE
+ 0 ; STORAGE
+ 0 ; P-STACK
+ 0 ; BOTH STATCKS BLOWN
+ 0 ; STORAGE
+
+BSTAT:
+NOWFRE: 0 ; FREE STORAGE FROM LAST GC
+CURFRE: 0 ; STORAGE USED SINCE LAST GC
+MAXFRE: 0 ; MAXIMUM FREE STORAGE ALLOCATED
+USEFRE: 0 ; TOTAL FREE STORAGE USED
+NOWTP: 0 ; TP LENGTH FROM LAST GC
+CURTP: 0 ; # WORDS ON TP
+CTPMX: 0 ; MAXIMUM SIZE OF TP SO FAR
+NOWLVL: 0 ; # OF TOP-LEVEL LVAL-SLOTS
+CURLVL: 0 ; # OF TOP-LEVEL LVALS
+NOWGVL: 0 ; # OF GVAL SLOTS
+CURGVL: 0 ; # OF GVALS
+NOWTYP: 0 ; SIZE OF TYPE-VECTOR
+CURTYP: 0 ; # OF TYPES
+NOWSTO: 0 ; SIZE OF STATIONARY STORAGE
+CURSTO: 0 ; STATIONARY STORAGE IN USE
+CURMAX: 0 ; MAXIMUM BLOCK OF CONTIGUOUS STORAGE
+NOWP: 0 ; SIZE OF P-STACK
+CURP: 0 ; #WORDS ON P
+CPMX: 0 ; MAXIMUM P-STACK LENGTH SO FAR
+GCCAUS: 0 ; INDICATOR FOR CAUSE OF GC
+GCCALL: 0 ; INDICATOR FOR CALLER OF GC
+
+
+; THIS GROUP OF VARIABLES DETERMINES HOW THINGS GROW
+LVLINC: 6 ; LVAL INCREMENT ASSUMED TO BE 64 SLOTS
+GVLINC: 4 ; GVAL INCREMENT ASSUMED TO BE 64 SLOTS
+TYPIC: 1 ; TYPE INCREMENT ASSUMED TO BE 32 TYPES
+STORIC: 2000 ; STORAGE INCREMENT USED BY NFREE (MINIMUM BLOCK-SIZE)
+
+
+RCL: 0 ; POINTER TO LIST OF RECYCLEABLE LIST CELLS
+RCLV: 0 ; POINTER TO RECYCLED VECTORS
+GCMONF: 0 ; NON-ZERO SAY GIN/GOUT
+GCDANG: 0 ; NON-ZERO, STORAGE IS LOW
+INBLOT: 0 ; INDICATE THAT WE ARE RUNNING OIN A BLOAT
+GETNUM: 0 ;NO OF WORDS TO GET
+RFRETP:
+RPTOP: 0 ;NO OF BLOCKS OF CORE, IF GIVING CORE AWAY
+CORTOP: 0 ;CURRENT TOP OF CORE, EXCLUDING ANY TO BE GIVEN AWAY
+NGCS: 8 ; NUMBER OF GARBAGE COLLECTS BETWEEN HAIRY GCS
+
+;VARIABLES WHICH DETERMIN WHEN MUDDLE WILL ASK FOR MORE CORE,
+;AND WHEN IT WILL GET UNHAPPY
+
+FREMIN: 20000 ;MINIMUM FREE WORDS
+
+;POINTER TO GROWING PDL
+
+TPGROW: 0 ;POINTS TO A BLOWN TP
+PPGROW: 0 ;POINTS TO A BLOWN PP
+PGROW: 0 ;POINTS TO A BLOWN P
+
+;IN GC FLAG
+
+GCFLG: 0
+GCFLCH: 0 ; TELL INT HANDLER TO ITIC CHARS
+GCHAIR: 1 ; COUNTS GCS AND TELLS WHEN TO HAIRIFY
+GCDOWN: 0 ; AMOUNT TO TRY AND MOVE DOWN
+CURPLN: 0 ; LENGTH OF CURRENTLY RUNNING PURE RSUBR
+PURMIN: 0 ; MINIMUM PURE STORAGE
+
+; VARS ASSOCIATED WITH BLOAT LOGIC
+PMIN: 200 ; MINIMUM FOR PSTACK
+PGOOD: 1000 ; GOOD SIZE FOR PSTACK
+PMAX: 4000 ; MAX SIZE FOR PSTACK
+TPMIN: 1000 ; MINIMUM SIZE FOR TP
+TPGOOD: NTPGOO ; GOOD SIZE OF TP
+TPMAX: NTPMAX ; MAX SIZE OF TP
+
+TPBINC: 0
+GLBINC: 0
+TYPINC: 0
+
+; VARS FOR PAGE WINDOW HACKS
+
+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
+FNTBOT: 0 ; BOTTOM OF FRONTEIR
+WNDBOT: 0 ; BOTTOM OF WINDOW
+WNDTOP: 0
+BOTNEW: (FPTR) ; POINTER TO FRONTIER
+GCTIM: 0
+NPARBO: 0 ; SAVED PARBOT
+
+; FLAGS TO INDICATE DUMPER IS IN USE
+
+GPURFL: 0 ; INDICATE PURIFIER IS RUNNING
+GCDFLG: 0 ; INDICATE EITHER GCDUMP OR PURIFIER IS RUNNING
+DUMFLG: 0 ; FLAG INDICATING DUMPER IS RUNNING
+
+; CONSTANTS FOR DUMPER,READER AND PURIFYER
+
+ABOTN: 0 ; COUNTER FOR ATOMS
+NABOTN: 0 ; POINTER USED BY PURIFY
+OGCSTP: 0 ; CONTAINS OLD GCSTOP FOR READER
+MAPUP: 0 ; BEGINNING OF MAPPED UP PURE STUFF
+SAVRES: 0 ; SAVED UPDATED ITEM OF PURIFIER
+SAVRE2: 0 ; SAVED TYPE WORD
+SAVRS1: 0 ; SAVED PTR TO OBJECT
+INF1: 0 ; AOBJN PTR USED IN CREATING PROTECTION INF
+INF2: 0 ; AOBJN PTR USED IN CREATING SECOND INF
+INF3: 0 ; AOBJN PTR USED TO PURIFY A STRUCTURE
+
+; VARIABLES USED BY GC INTERRUPT HANDLER
+
+GCHPN: 0 ; SET TO -1 EVERYTIME A GC HAS OCCURED
+GCKNUM: 0 ; NUMBER OF WORDS OF REQUEST TO INTERRUPT
+
+; VARIABLE TO INDICATE WHETHER AGC HAS PUSHED THE MAPPING CHANNEL TO WIN
+
+PSHGCF: 0
+
+; VARIABLES USED BY DUMPER AND READER TO HANDLE NEWTYPES
+
+TYPTAB: 0 ; POINTER TO TYPE TABLE
+NNPRI: 0 ; NUMPRI FROM DUMPED OBJECT
+NNSAT: 0 ; NUMSAT FROM DUMPED OBJECT
+TYPSAV: 0 ; SAVE PTR TO TYPE VECTOR
+
+; VARIABLES USED BY GC-DUMP FOR COPY-WRITE MAPPING
+
+BUFGC: 0 ; BUFFER FOR COPY ON WRITE HACKING
+PURMNG: 0 ; FLAG INDICATING IF A PURIFIED PAGE WAS MUNGED DURING GC-DUMP
+RPURBT: 0 ; SAVED VALUE OF PURTOP
+RGCSTP: 0 ; SAVED GCSTOP
+
+; VARIABLES USED TO DETERMINE WHERE THE GC-DUMPED STRUCTURE SHOULD GO
+
+INCORF: 0 ; INDICATION OF UVECTOR HACKS FOR GC-DUMP
+PURCOR: 0 ; INDICATION OF UVECTOR TO PURE CORE
+ ; ARE NOT GENERATED
+
+
+PLODR: 0 ; INDICATE A PLOAD IS IN OPERATION
+NPRFLG: 0
+
+; VARIABLE USED BY MARK SWEEP GARBAGE COLLECTOR
+
+MAXLEN: 0 ; MAXIMUM RECLAIMED SLOT
+
+PURE
+
+OFFSET OFFS
+
+CONSTANTS
+
+HERE
+
+CONSTANTS
+
+OFFSET 0
+
+ZZ==$.+1777
+
+.LOP ANDCM ZZ 1777
+
+ZZ1==.LVAL1
+
+LOC ZZ1
+
+
+OFFSET OFFS
+
+WIND: SPBLOK 2000
+FRONT: SPBLOK 2000
+MRKPD: SPBLOK 1777
+ENDPDL: -1
+
+MRKPDL=MRKPD-1
+
+ENDGC:
+
+OFFSET 0
+
+.LOP <ASH @> WIND <,-10.>
+WNDP==.LVAL1
+
+.LOP <ASH @> FRONT <,-10.>
+FRNP==.LVAL1
+
+ZZ2==ENDGC-AGCLD
+.LOP <ASH @> ZZ2 <,-10.>
+LENGC==.LVAL1
+
+.LOP <ASH @> LENGC <,10.>
+RLENGC==.LVAL1
+
+.LOP <ASH @> AGCLD <,-10.>
+PAGEGC==.LVAL1
+
+OFFSET 0
+
+LOC GCST
+.LPUR==$.
+
+END
+
--- /dev/null
+TITLE AGC MUDDLE GARBAGE COLLECTOR
+
+;SYSTEM WIDE DEFINITIONS GO HERE
+
+RELOCATABLE
+GCST==$.
+
+
+.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,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,GCOFFS
+.GLOBAL SPBASE,OUTRNG,CISTNG,CBYTES,%RUNAM,PURVEC,GCDOWN,N.CHNS,CHNL1,PLODR,MRKPDL
+.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 P.TOP,P.CORE,PMAPB,IGET,CIGTPR,ROOT,STBL,CAFREE,%MPIN1,%PURIF,%MPINX,GCHK10
+.GLOBAL %SAVRP,%RSTRP,LENGC,AGCLD,PAGEGC,REALGC,MARK
+.GLOBAL %MPINT,%GBINT,%CLSMP,%CLSM1,PINIT,PGFIND,NPRFLG,%PURMD
+.GLOBAL GCKNUM,CORTOP,GCHPN,INTAGC,WNDP,WNDBOT,BUFGC,WIND,GCDFLG,SAVM,AGC,GCSET
+
+.GLOBAL GCRET,PAIRMK,DEFMK,VECTMK,TBMK,TPMK,ARGMK,VECTMK,FRMK,BYTMK,ATOMK,GATOMK
+.GLOBAL BYTMK,ABMK,LOCRMK,GCRDMK,DEFQMK,ASMRK,LOCMK,OFFSMK,INBLOT,MARK2A
+
+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
+
+.ATOM.==200000 ; FLAG SAYING ATOMS MARKED (FOR VAL FLUSH LOGIC)
+
+GCHN==0 ; CHANNEL FOR FUNNNY INFERIOR
+STATNO==19. ; # OF STATISTICS FOR BLOAT-STAT
+STATGC==8. ; # OF GC-STATISTICS FOR BLOAT-STAT
+
+
+LOC REALGC
+OFFS==AGCLD-$.
+GCOFFS=OFFS
+OFFSET OFFS
+
+.INSRT MUDDLE >
+SYSQ
+IFE ITS,[
+.INSRT STENEX >
+]
+IFN ITS, PGSZ==10.
+IFE ITS, PGSZ==9.
+
+TYPNT=AB ;SPECIAL AC USAGE DURING GC
+F=TP ;ALSO SPECIAL DURING GC
+LPVP=SP ;SPECIAL FOR GC, HOLDS POINTER TO PROCESS CHAIN
+FPTR=TB ; POINT TO CURRENT FRONTIER OF INFERIOR
+
+
+; WINDOW AND FRONTIER PAGES
+
+MAPCH==0 ; MAPPING CHANNEL
+.LIST.==400000
+FPAG==2000 ; START OF PAGES FOR GC-READ AND GCDUMP
+CONADJ==5 ; ADJUSTMENT OF DUMPERS CONSTANT TABLE
+
+\f
+; INTERNAL GCDUMP ROUTINE
+.GLOBAL GODUMP,EGCDUM,EPURIF,ERRKIL,IPURIF
+
+GODUMP: MOVE PVP,PVSTOR+1
+ MOVEM P,PSTO+1(PVP) ; SAVE P
+ MOVE P,GCPDL
+ PUSH P,AB
+ PUSHJ P,INFSU1 ; SET UP INFERIORS
+
+; MARK PHASE
+ SETZM PURMNG ; INITIALIZE FLAG INDICATING IF PURIFIED PAGES
+ ; WERE MUNGED
+ MOVEI 0,HIBOT ; SET UP NEW PURBOT TO CONVINCE THE GARBAGE COLLECTOR
+ ; TO COLLECT PURIFIED STRUCTURES
+ EXCH 0,PURBOT
+ MOVEM 0,RPURBT ; SAVE THE OLD PURBOT
+ MOVEI 0,HIBOT
+ EXCH 0,GCSTOP
+ MOVEM 0,RGCSTP ; SAVE THE OLD GCSTOP
+ POP P,C ; SET UP PTR TO TYPE/VALUE PAIR
+ MOVE P,A ; GET NEW PDL PTR
+ SETOM DUMFLG ; FLAG INDICATING IN DUMPER
+ MOVE A,TYPVEC+1
+ MOVEM A,TYPSAV
+ ADD FPTR,[7,,7] ; ADJUST FOR FIRST STATUS WORDS
+ PUSHJ P,MARK2
+ MOVEI E,FPAG+6 ; SEND OUT PAIR
+ PUSH P,C ; SAVE C
+ MOVE C,A
+ PUSHJ P,ADWD
+ POP P,C ; RESTORE C
+ MOVEI E,FPAG+5
+ MOVE C,(C) ; SEND OUT UPDATED PTR
+ PUSHJ P,ADWD
+
+ MOVEI 0,@BOTNEW ; CALCULATE START OF TYPE-TABLE
+ MOVEM 0,TYPTAB
+ MOVE 0,RPURBT ; RESTORE PURBOT
+ MOVEM 0,PURBOT
+ MOVE 0,RGCSTP ; RESTORE GCSTOP
+ MOVEM 0,GCSTOP
+
+
+; ROUTINE TO SCAN THE TYPE-VECTOR FOR MARKED TYPE SLOTS AND BUILD A TYPE-TABLE OUT OF
+; THEM
+
+ MOVE A,TYPSAV ; GET AOBJN POINTER TO TYPE-VECTOR
+ MOVEI B,0 ; INITIALIZE TYPE COUNT
+TYPLP2: HLRE C,(A) ; GET MARKING
+ JUMPGE C,TYPLP1 ; IF NOT MARKED DON'T OUTPUT
+ MOVE C,(A) ; GET FIRST WORD
+ HRL C,B ; FIX UP SO TYPE-NUMBER REPLACES TYPE-CELL
+ PUSH P,A
+ SKIPL FPTR
+ PUSHJ P,MOVFNT
+ MOVEM C,FRONT(FPTR)
+ AOBJN FPTR,.+2
+ PUSHJ P,MOVFNT ; EXTEND THE FRONTIER
+ POP P,A
+ MOVE C,1(A) ; OUTPUT SECOND WORD
+ MOVEM C,FRONT(FPTR)
+ ADD FPTR,[1,,1]
+TYPLP1: ADDI B,1 ; INCREMENT TYPE COUNT
+ ADD A,[2,,2] ; POINT TO NEXT SLOT
+ JUMPL A,TYPLP2 ; LOOP
+
+; ROUTINE TO BUILD UP ATOM TABLE USING LPVP CHAIN
+
+ HRRZ F,ABOTN
+ MOVEI 0,@BOTNEW ; GET CURRENT BEGINNING OF TRANSFER
+ MOVEM 0,ABOTN ; SAVE IT
+ PUSHJ P,ALLOGC ; ALLOCATE ROOM FOR ATOMS
+ MOVSI D,400000 ; SET UP UNMARK BIT
+SPOUT: JUMPE LPVP,DPGC4 ; END OF CHAIN
+ MOVEI F,(LPVP) ; GET COPY OF LPVP
+ HRRZ LPVP,-1(LPVP) ; LPVP POINTS TO NEXT ON CHAIN
+ ANDCAM D,(F) ; UNMARK IT
+ HLRZ C,(F) ; GET LENGTH
+ HRRZ E,(F) ; POINTER INTO INF
+ ADD E,ABOTN
+ SUBI C,2 ; WE'RE NOT SENDING OUT THE VALUE PAIR
+ HRLM C,(F) ; ADJUSTED LENGTH
+ MOVE 0,C ; COPY C FOR TRBLKX
+ SUBI E,(C) ; ADJUST PTRS FOR SENDOUT\r
+ SUBI F,-1(C)
+ PUSHJ P,TRBLKX ; OUT IT GOES
+ JRST SPOUT
+
+
+; HERE TO SEND OUT DELIMITER INFORMATION
+DPGC4: SKIPN INCORF ; SKIP IF TRANSFREING TO UVECTOR IN CORE
+ JRST CONSTO
+ SKIPL FPTR ; SEE IF ROOM IN FRONTEIR
+ PUSHJ P,MOVFNT ; EXTEND FRONTEIR
+ MOVSI A,.VECT.
+ MOVEM A,FRONT(FPTR)
+ AOBJN FPTR,.+2
+ PUSHJ P,MOVFNT
+ MOVEI A,@BOTNEW ; LENGTH
+ SUBI A,FPAG
+ HRLM A,FRONT(FPTR)
+ ADD FPTR,[1,,1]
+
+
+CONSTO: MOVEI E,FPAG
+ MOVE C,ABOTN ; START OF ATOMS
+ SUBI C,FPAG+CONADJ ; ADJUSTMENT FOR STARTING ON PAGE ONE
+ PUSHJ P,ADWD ; OUT IT GOES
+ MOVEI E,FPAG+1
+ MOVEI C,@BOTNEW
+ SUBI C,FPAG+CONADJ
+ SKIPE INCORF ; SKIP IF TO CHANNEL
+ SUBI C,2 ; SUBTRACT FOR DOPE WORDS
+ PUSHJ P,ADWD
+ SKIPE INCORF
+ ADDI C,2 ; RESTORE C TO REAL ABOTN
+ ADDI C,CONADJ
+ PUSH P,C
+ MOVE C,TYPTAB
+ SUBI C,FPAG+CONADJ
+ MOVEI E,FPAG+2 ; SEND OUT START OF TYPE TABLE
+ PUSHJ P,ADWD
+ ADDI E,1 ; SEND OUT NUMPRI
+ MOVEI C,NUMPRI
+ PUSHJ P,ADWD
+ ADDI E,1 ; SEND OUT NUMSAT
+ MOVEI C,NUMSAT
+ PUSHJ P,ADWD
+
+
+
+; FINAL CLOSING OF INFERIORS
+
+DPCLS: PUSH P,PGCNT
+ PUSHJ P,INFCL1
+ POP P,PGCNT
+ POP P,A ; LENGTH OF CODE
+
+; RESTORE AC'S
+ MOVE PVP,PVSTOR+1
+ IRP AC,,[P,TP,TB,AB,FRM]
+ MOVE AC,AC!STO+1(PVP)
+ TERMIN
+
+ SETZB M,R
+ SETZM DUMFLG
+ SETZM GCDFLG ; ZERO FLAG INDICATING IN DUMPER
+ SETZM GCFLG ; AND INDICTOR TO INTERRUPT HANDLER THAT AGC IS ON
+ PUSH P,A
+ MOVE A,INF2 ; GET POINTER TO PURE MAPPED OUT
+ PUSHJ P,%GBINT
+
+ POP P,A
+ JRST EGCDUM
+
+
+ERDP: PUSH P,B
+ PUSHJ P,INFCLS
+ PUSHJ P,INFCL1
+ SETZM GCFLG
+ SETZM GPURFL ; PURE FLAG
+ SETZM DUMFLG
+ SETZM GCDFLG
+ POP P,A
+
+; RESTORE AC'S
+ MOVE PVP,PVSTOR+1
+ IRP AC,,[P,R,M,TP,TB,AB,FRM]
+ MOVE AC,AC!STO+1(PVP)
+ TERMIN
+
+ERDUMP: PUSH TP,$TATOM
+
+OFFSET 0
+
+ PUSH TP,EQUOTE STRUCTURE-CONTAINS-UNDUMPABLE-TYPE
+
+OFFSET OFFS
+
+ PUSH TP,$TATOM ; PUSH ON PRIMTYPE
+ PUSH TP,@STBL(A) ; PUSH ON PRIMTYPE
+ MOVEI A,2
+ JRST ERRKIL
+
+; ALTERNATE ATOM MARKER FOR DUMPER
+
+DATOMK: SKIPE GPURFL ; SKIP IF NOT IN PURIFIER
+ JRST PATOMK
+ CAILE A,0 ; SEE IF ALREADY MARKED
+ JRST GCRET
+ PUSH P,A ; SAVE PTR TO ATOM
+ HLRE B,A ; POINT TO DOPE WORD
+ SUB A,B ; TO FIRST DOPE WORD
+ MOVEI A,1(A) ; TO SECOND
+ PUSH P,A ; SAVE PTR TO DOPE WORD
+ HLRZ B,(A) ; GET LENGTH AND MARKING
+ TRZE B,400000 ; TURN OFF BIT AND SKIP IF UNMARKED
+ JRST DATMK1
+ IORM D,(A) ; MARK IT
+ MOVE 0,ABOTN ; GET CURRENT TOP OF ATOM TABLE
+ ADDI 0,-2(B) ; PLACE OF DOPE WORD IN TABLE
+ HRRM 0,(A) ; PUT IN RELOCATION
+ MOVEM 0,ABOTN ; FIXUP TOP OF TABLE
+ HRRM LPVP,-1(A) ; FIXUP CHAIN
+ MOVEI LPVP,(A)
+ MOVE A,-1(P) ; GET POINTER TO ATOM BACK
+ HRRZ B,2(A) ; GET OBLIST POINTER
+ JUMPE B,NOOB ; IF ZERO ON NO OBLIST
+ CAMG B,VECBOT ; DON'T SKIP IF OFFSET FROM TVP
+ MOVE B,(B)
+ HRLI B,-1
+DATMK3: MOVE A,$TOBLS ; SET UP FOR GET
+ MOVE C,$TATOM
+
+OFFSET 0
+ MOVE D,IMQUOTE OBLIST
+
+OFFSET OFFS
+
+ PUSH P,TP ; SAVE FPTR
+ MOVE TP,MAINPR
+ MOVE TP,TPSTO+1(TP) ; GET TP
+ PUSHJ P,IGET
+ POP P,TP ; RESTORE FPTR
+ MOVE C,-1(P) ; RECOVER PTR TO ATOM
+ ADDI C,1 ; SET UP TO MARK OBLIST ATOM
+ MOVSI D,400000 ; RESTORE MARK WORD
+
+OFFSET 0
+
+ CAMN B,MQUOTE ROOT
+
+OFFSET OFFS
+
+ JRST RTSET
+ MOVEM B,1(C)
+ MOVEI B,TATOM
+ PUSHJ P,MARK1 ; MARK IT
+ MOVEM A,1(C) ; SMASH IN ITS ID
+DATMK1:
+NOOB: POP P,A ; GET PTR TO DOPE WORD BACK
+ HRRZ A,(A) ; RETURN ID
+ SUB P,[1,,1] ; CLEAN OFF STACK
+ MOVEM A,(P)
+ JRST GCRET ; EXIT
+
+; HERE FOR A ROOT ATOM
+RTSET: SETOM 1(C) ; INDICATOR OF ROOT ATOM
+ JRST NOOB ; CONTINUE
+
+\f
+; INTERNAL PURIFY ROUTINE
+; SAVE AC's
+
+IPURIF: PUSHJ P,PURCLN ; GET RID OF PURE MAPPED
+ MOVE PVP,PVSTOR+1
+ IRP AC,,[P,R,M,TP,TB,AB,FRM]
+ MOVEM AC,AC!STO"+1(PVP)
+ TERMIN
+
+
+; HERE TO CREATE INFERIORS AND MARK THE ITEM
+PURIT1: MOVE PVP,PVSTOR+1
+ MOVEM P,PSTO+1(PVP) ; SAVE P
+ SETOM GPURFL ; INDICATE PURIFICATION IS TAKING PLACE
+ MOVE C,AB ; ARG PAIR
+ MOVEM C,SAVRS1 ; SAV PTR TO PAIR
+ MOVE P,GCPDL
+ PUSHJ P,INFSUP ; GET INFERIORS
+ MOVE P,A ; GET NEW PDL PTR
+ PUSHJ P,%SAVRP ; SAVE RPMAP TABLE FOR TENEX
+ MOVE C,SAVRS1 ; SET UP FOR MARKING
+ MOVE A,(C) ; GET TYPE WORD
+ MOVEM A,SAVRE2
+PURIT3: PUSH P,C
+ PUSHJ P,MARK2
+PURIT4: POP P,C ; RESTORE C
+ ADD C,[2,,2] ; TO NEXT ARG
+ JUMPL C,PURIT3
+ MOVEM A,SAVRES ; SAVE UPDATED POINTER
+
+; FIX UP IMPURE PART OF ATOM CHAIN
+
+ PUSH P,[0] ; FLAG INDICATING NON PURE SCAN
+ PUSHJ P,FIXATM
+ SUB P,[1,,1] ; CLEAN OFF STACK
+
+; NOW TO GET PURE STORAGE
+
+PURIT2: MOVEI A,@BOTNEW ; GET BOTNEW
+ SUBI A,2000-1777 ; START AT PAGE 1 AND ROUND
+ ANDCMI A,1777
+ ASH A,-10. ; TO PAGES
+ SETZ M,
+ PUSH P,A
+ PUSHJ P,PGFIND ; FIND THEM
+ JUMPL B,LOSLP2 ; LOST GO TO CAUSE AGC
+ HRRZ 0,BUFGC ;GET BUFFER PAGE
+ ASH 0,-10.
+ MOVEI A,(B) ; GET LOWER PORTION OF PAGES
+ MOVN C,(P)
+ SUBM A,C ; GET END PAGE
+ CAIL 0,(A) ; L? LOWER
+ CAILE 0,(C) ; G? HIGER
+ JRST NOREMP ; DON'T GET NEW BUFFER
+ PUSHJ P,%FDBUF ; GET A NEW BUFFER PAGE
+NOREMP: MOVN A,(P) ; SET UP AOBJN PTR FOR MAPIN
+ MOVE C,B ; SAVE B
+ HRL B,A
+ HRLZS A
+ ADDI A,1
+ MOVEM B,INF3 ; SAVE PTR FOR PURIFICATION
+ PUSHJ P,%MPIN1 ; MAP IT INTO PURE
+ ASH C,10. ; TO WORDS
+ MOVEM C,MAPUP
+ SUB P,[1,,1] ; CLEAN OFF STACK
+
+DONMAP:
+; RESTORE AC's
+ MOVE PVP,PVSTOR+1
+ MOVE P,PSTO+1(PVP) ; GET REAL P
+ PUSH P,LPVP
+ MOVEI A,@BOTNEW
+ MOVEM A,NABOTN
+
+ IRP AC,,[M,TP,TB,R,FRM]
+ MOVE AC,AC!STO+1(PVP)
+ TERMIN
+ MOVE A,INF1
+
+; NOW FIX UP POINTERS IN PURE STRUCTURE
+ MOVE 0,GCSBOT
+ MOVEM 0,OGCSTP
+ PUSH P,GCSBOT ; SAVE GCSBOT AND GCSTOP
+ PUSH P,GCSTOP
+ MOVE A,MAPUP ; NEW GCSBOT AND TOP TO FOOL GCHACK
+ MOVEM A,GCSBOT
+ ADD A,NABOTN
+ SUBI A,2000 ; ADJUSTMENT FOR START ON PAGE ONE
+ MOVEM A,GCSTOP
+ MOVE A,[PUSHJ P,NPRFIX]
+ MOVEI PVP,0 ; SAY MIGHT BE NON-ATOMS
+ PUSHJ P,GCHK10
+ POP P,GCSTOP
+ POP P,GCSBOT
+
+; NOW FIX UP POINTERS TO PURIFIED STRUCTURE
+
+ MOVE A,[PUSHJ P,PURFIX]
+ MOVEI PVP,0 ; SAY MIGHT BE NON-ATOMS
+ PUSHJ P,GCHACK
+
+ SETZM GCDFLG
+ SETZM DUMFLG
+ SETZM GCFLG
+
+ POP P,LPVP ; GET BACK LPVP
+ MOVE A,INF1
+ PUSHJ P,%KILJB ; KILL IMAGE SAVING INFERIOR
+ PUSH P,[-1] ; INDICATION OF PURE ATOM SCAN
+ PUSHJ P,FIXATM
+
+; SET UP PMAP SO THAT NEW PURE PAGES ARE INDICATED
+
+ MOVE A,INF3 ; GET AOBJN PTR TO PAGES
+FIXPMP: HRRZ B,A ; GET A PAGE
+ IDIVI B,16. ; DIVIDE SO AS TO PT TO PMAP WORD
+ PUSHJ P,PINIT ; SET UP PARAMETER
+ LSH D,-1
+ TDO E,D ; FIX UP WORD
+ MOVEM E,PMAPB(B) ; SEND IT BACK
+ AOBJN A,FIXPMP
+
+ SUB P,[1,,1]
+ MOVE A,[PUSHJ P,PURTFX] ; FIX UP PURE ATOM POINTERS
+ MOVEI PVP,1 ; SAY MIGHT BE NON-ATOMS
+ PUSHJ P,GCHACK
+
+; NOW FIX UP POINTERS IN PURE STRUCTURE
+ PUSH P,GCSBOT ; SAVE GCSBOT AND GCSTOP
+ PUSH P,GCSTOP
+ MOVE A,MAPUP ; NEW GCSBOT AND TOP TO FOOL GCHACK
+ MOVEM A,GCSBOT
+ ADD A,NABOTN
+ SUBI A,2000 ; ADJUSTMENT FOR START ON PAGE ONE
+ MOVEM A,GCSTOP
+ MOVE A,[PUSHJ P,PURTFX]
+ MOVEI PVP,1 ; SAY MIGHT BE NON-ATOMS
+ PUSHJ P,GCHK10
+ POP P,GCSTOP
+ POP P,GCSBOT
+
+; HERE TO FIX UP ATOMS WITH TYPES HACKED INTO THEIR GROWTH FIELD
+
+ MOVE A,TYPVEC+1 ; GET TYPE VECTOR
+ MOVEI B,400000 ; TLOSE==0
+TTFIX: HRRZ D,1(A) ; GET ADDR
+ HLRE C,1(A)
+ SUB D,C
+ HRRM B,(D) ; SMASH IT IN
+NOTFIX: ADDI B,1 ; NEXT TYPE
+ ADD A,[2,,2]
+ JUMPL A,TTFIX
+
+; NOW CLOSE UP INFERIORS AND RETURN
+
+PURCLS: MOVE P,[-2000,,MRKPDL]
+ PUSHJ P,%RSTRP ;RESETORE RPMAP TABLE FOR TENEX
+ PUSHJ P,INFCLS
+
+ MOVE PVP,PVSTOR+1
+ MOVE P,PSTO+1(PVP) ; RESTORE P
+ MOVE AB,ABSTO+1(PVP) ; RESTORE R
+
+ MOVE A,INF3 ; GET PTR TO PURIFIED STRUCTURE
+ SKIPN NPRFLG
+ PUSHJ P,%PURIF ; PURIFY
+ PUSHJ P,%PURMD
+
+ SETZM GPURFL
+ JRST EPURIF ; FINISH UP
+
+NPRFIX: PUSH P,A
+ PUSH P,B
+ PUSH P,C
+ EXCH A,C
+ PUSHJ P,SAT ; GET STORAGE ALLOCATION TYPE
+ MOVE C,MAPUP ; FIXUP AMOUNT
+ SUBI C,FPAG ; ADJUST FOR START ON FIRST PAGE
+ CAIE A,SLOCR ; DONT HACK TLOCRS
+ CAIN A,S1WORD ; SKIP IF NOT OF PRIMTYPE WORD
+ JRST LSTFXP
+ CAIN A,SCHSTR
+ JRST STRFXP
+ CAIN A,SATOM
+ JRST ATMFXP
+ CAIN A,SOFFS
+ JRST OFFFXP ; FIXUP OFFSETS
+STRFXQ: HRRZ D,1(B)
+ JUMPE D,LSTFXP ; SKIP IF NIL
+ CAMG D,PURTOP ; SEE IF ALREADY PURE
+ ADDM C,1(B)
+LSTFXP: TLNN B,.LIST. ; SKIP IF NOT A PAIR
+ JRST LSTEX1
+ HRRZ D,(B) ; GET REST OF LIST
+ SKIPE D ; SKIP IF POINTS TO NIL
+ PUSHJ P,RLISTQ
+ JRST LSTEX1
+ CAMG D,PURTOP ; SKIP IF ALREADY PURE
+ ADDM C,(B) ; FIX UP LIST
+LSTEX1: POP P,C
+ POP P,B ; RESTORE GCHACK AC'S
+ POP P,A
+ POPJ P,
+
+OFFFXP: HLRZ 0,D ; POINT TO LIST
+ JUMPE 0,LSTFXP ; POINTS TO NIL
+ CAML 0,PURTOP ; ALREADY PURE?
+ JRST LSTFXP ; YES
+ ADD 0,C ; UPDATE THE POINTER
+ HRLM 0,1(B) ; STUFF IT OUT
+ JRST LSTFXP ; DONE
+
+STRFXP: TLZN D,STATM ; SKIP IF REALLY ATOM
+ JRST STRFXQ
+ MOVEM D,1(B)
+ PUSH P,C
+ MOVE C,B ; GET ARG FOR BYTDOP
+ PUSHJ P,BYTDOP
+ POP P,C
+ MOVEI D,-1(A)
+ JRST ATMFXQ
+
+ATMFXP: HLRE 0,D ; GET LENGTH
+ SUB D,0 ; POINT TO FIRST DOPE WORD
+ HRRZS D
+ATMFXQ: CAML D,OGCSTP
+ CAIL D,HIBOT ; SKIP IF IMPURE
+ JRST LSTFXP
+ HRRZ 0,1(D) ; GET RELOCATION
+ SUBI 0,1(D)
+ ADDM 0,1(B) ; FIX UP PTR IN STRUCTURE
+ JRST LSTFXP
+
+; FIXUP OF PURE ATOM POINTERS
+
+PURTFX: CAIE C,TATOM ; SKIP IF ATOM POINTER
+ JRST PURSFX
+ HLRE E,D ; GET TO DOPE WORD
+ SUBM D,E
+PURSF1: SKIPL 1(E) ; SKIP IF MARKED
+ POPJ P,
+ HRRZ 0,1(E) ; RELATAVIZE PTR
+ SUBI 0,1(E)
+ ADD D,0 ; FIX UP PASSED POINTER
+ SKIPE B ; AND IF APPROPRIATE MUNG POINTER
+ ADDM 0,1(B) ; FIX UP POINTER
+ POPJ P,
+
+PURSFX: CAIE C,TCHSTR
+ POPJ P,
+ MOVE C,B ; GET ARG FOR BYTDOP
+ PUSHJ P,BYTDOP
+ GETYP 0,-1(A)
+ MOVEI E,-1(A)
+ MOVE A,[PUSHJ P,PURTFX]
+ CAIE 0,SATOM
+ POPJ P,
+ JRST PURSF1
+
+PURFIX: PUSH P,D
+ PUSH P,A
+ PUSH P,B
+ PUSH P,C ; SAVE AC'S FOR GCHACK
+ EXCH A,C ; GET TYPE IN A
+ CAIN A,TATOM ; CHECK FOR ATOM
+ JRST ATPFX
+ PUSHJ P,SAT
+
+ CAILE A,NUMSAT ; SKIP IF TEMPLATE
+ JRST TLFX
+IFN ITS, JRST @PURDSP(A)
+IFE ITS,[
+ HRRZ 0,PURDSP(A)
+ HRLI 0,400000
+ JRST @0
+]
+PURDSP:
+
+OFFSET 0
+
+DISTBS DUM1,TLFX,[[S2WORD,LPLSTF],[S2DEFR,LPLSTF],[SNWORD,VECFX],
+[S2NWORD,VECFX],[SSTORE,VECFX],[SBYTE,STRFX],[SATOM,ATPFX],[SLOCB,STRFX]
+[SCHSTR,STRFX],[SLOCL,LPLSTF],[SLOCV,VECFX],[SLOCU,VECFX],[SLOCS,VECFX],[SOFFS,OFFSFX]]
+
+OFFSET OFFS
+
+VECFX: HLRE 0,D ; GET LENGTH
+ SUB D,0 ; POINT TO D.W.
+ SKIPL 1(D) ; SKIP IF MARKED
+ JRST TLFX
+ HRRZ C,1(D)
+ SUBI C,1(D) ; CALCULATE RELOCATION
+ ADD C,MAPUP ; ADJUSTMENT
+ SUBI C,FPAG
+ ADDM C,1(B)
+TLFX: TLNN B,.LIST. ; SEE IF PAIR
+ JRST LVPUR ; LEAVE IF NOT
+ PUSHJ P,RLISTQ
+ JRST LVPUR
+ HRRZ D,(B) ; GET CDR
+ SKIPN D ; SKIP IF NOT ZERO
+ JRST LVPUR
+ MOVE D,(D) ; GET CADR
+ SKIPL D ; SKIP IF MARKED
+ JRST LVPUR
+ ADD D,MAPUP
+ SUBI D,FPAG
+ HRRM D,(B) ; FIX UP
+LVPUR: POP P,C
+ POP P,B
+ POP P,A
+ POP P,D
+ POPJ P,
+
+STRFX: MOVE C,B ; GET ARG FOR BYTDOP
+ PUSHJ P,BYTDOP
+ SKIPL (A) ; SKIP IF MARKED
+ JRST TLFX
+ GETYP 0,-1(A)
+ MOVE D,1(B)
+ MOVEI C,-1(A)
+ CAIN 0,SATOM ; REALLY ATOM?
+ JRST ATPFX1
+ HRRZ 0,(A) ; GET PTR IN NEW STRUCTURE
+ SUBI 0,(A) ; RELATAVIZE
+ ADD 0,MAPUP ; ADJUST
+ SUBI 0,FPAG
+ ADDM 0,1(B) ; FIX UP PTR
+ JRST TLFX
+
+ATPFX: HLRE C,D
+ SUBM D,C
+ SKIPL 1(C) ; SKIP IF MARKED
+ JRST TLFX
+ATPFX1: HRRZS C ; SEE IF PURE
+ CAIL C,HIBOT ; SKIP IF NOT PURE
+ JRST TLFX
+ HRRZ 0,1(C) ; GET PTR TO NEW ATOM
+ SUBI 0,1(C) ; RELATAVIZE
+ ADD D,0
+ JUMPE B,TLFX
+ ADDM 0,1(B) ; FIX UP
+ JRST TLFX
+
+LPLSTF: SKIPN D ; SKIP IF NOT PTR TO NIL
+ JRST TLFX
+ SKIPL (D) ; SKIP IF MARKED
+ JRST TLFX
+ HRRZ D,(D) ; GET UPDATED POINTER
+ ADD D,MAPUP ; ADJUSTMENT
+ SUBI D,FPAG
+ HRRM D,1(B)
+ JRST TLFX
+
+OFFSFX: HLRZS D ; LIST POINTER
+ JUMPE D,TLFX ; NIL
+ SKIPL (D) ; MARKED?
+ JRST TLFX ; NO
+ ADD D,MAPUP
+ SUBI D,FPAG ; ADJUST
+ HRLM D,1(B)
+ JRST TLFX ; RETURN
+
+; ROUTINES TO CAUSE A GARBAGE COLLECT WHEN EFFORTS TO GET STORAGE FAIL
+
+LOSLP1: MOVE A,ABOTN
+ MOVEM A,PARNEW ; SET UP GC PARAMS
+ MOVE C,[12.,,6]
+ JRST PURLOS
+
+LOSLP2: MOVEI A,@BOTNEW ; TOTAL AMOUNT NEEDED
+ ADDI A,1777
+ ANDCMI A,1777 ; CALCULATE PURE PAGES NEEDED
+ MOVEM A,GCDOWN
+ MOVE C,[12.,,8.]
+ JRST PURLOS
+
+PURLOS: MOVE P,[-2000,,MRKPDL]
+ PUSH P,GCDOWN
+ PUSH P,PARNEW
+ MOVE R,C ; GET A COPY OF A
+ PUSHJ P,INFCLS ; CLOSE INFERIORS AND FIX UP WORLD
+ PUSHJ P,INFCL2
+PURLS1: POP P,PARNEW
+ POP P,GCDOWN
+ MOVE C,R
+
+; RESTORE AC'S
+ MOVE PVP,PVSTOR+1
+ IRP AC,,[P,R,M,TP,TB,AB,FRM]
+ MOVE AC,AC!STO+1(PVP)
+ TERMIN
+
+ SETZM GCDFLG ; ZERO OUT FLAGS
+ SETZM DUMFLG
+ SETZM GPURFL
+ SETZM GCDANG
+
+ PUSHJ P,AGC ; GARBAGE COLLECT
+ JRST PURIT1 ; TRY AGAIN
+
+; PURIFIER ATOM MARKER
+
+PATOMK: HRRZ 0,A
+ CAMG 0,PARBOT
+ JRST GCRET ; DONE IF FROZEN
+ HLRE B,A ; GET TO D.W.
+ SUB A,B
+ SKIPG 1(A) ; SKIP IF NOT MARKED
+ JRST GCRET
+ HLRZ B,1(A)
+ IORM D,1(A) ; MARK THE ATOM
+ ADDM B,ABOTN
+ HRRM LPVP,(A) ; LINK ONTO CHAIN
+ MOVEI LPVP,1(A)
+ JRST GCRET ; EXIT
+
+\f
+.GLOBAL %LDRDO,%MPRDO
+
+; ROUTINES TO ALLOW GC-DUMPING OF PURIFIED STRUCTURES.
+
+; PROPUR MAPS PAGES CONTAINING PURIFIED STUFF INTO THE AGD INFERIOR SO THAT IN CASE
+; THE PAGES ARE MUNGED THEY CAN BE RESTORED USING MAPPING
+
+; REPURE REMAPS ANY PAGES THAT WERE MUNGED BY GC-DUMP BY RELOADING THEM FROM THE AGD
+; INFERIOR IN READ/EXEC MODE
+
+REPURE: PUSH P,[PUSHJ P,%LDRDO] ; INSTRUCTION FOR MAPPING IN PAGES FROM AGD INF
+ SKIPA
+PROPUR: PUSH P,[PUSHJ P,%MPRDO] ; INSTRUCTION FOR MAPPING PAGES TO AGD INF
+ MOVE A,PURBOT ; GET STARTING PAGE OF PURENESS
+ ASH A,-10. ; CONVERT TO PAGES
+ MOVEI C,HIBOT ; GET ENDING PAGE
+ ASH C,-10. ; CONVERT TO PAGES
+ PUSH P,A ; SAVE PAGE POINTER
+ PUSH P,C ; SAVE END OF PURENESS POINTER
+PROLOP: CAML A,(P) ; SKIP IF STILL PURE PAGES TO CHECK
+ JRST PRODON ; DONE MAPPING PAGES
+ PUSHJ P,CHKPGI ; SKIP IF PAGE IS PURE
+ JRST NOTPUR ; IT IS NOT
+ MOVE A,-1(P) ; GET PAGE TO MAP
+ XCT -2(P) ; MAP IN/OUT TO AGD INFERIOR IN READ/EXEC MODE
+NOTPUR: AOS A,-1(P) ; INCREMENT PAGE POINTER AND LOAD
+ JRST PROLOP ; LOOP BACK
+PRODON: SUB P,[3,,3] ; CLEAN OFF STACK
+ POPJ P, ; EXIT
+
+
+\f
+.GLOBAL %SAVIN,STOSTR,%CLMP1,%IMSAV,%IMSV1,ILOOKC,PSHGCF,BSETG,%GCJB1
+.GLOBAL %CLSJB,%KILJB,%IFMP1,%OPGFX,%FDBUF
+INFSU1: PUSH P,[-1] ; ENTRY USED BY GC-DUMP
+ SKIPA
+INFSUP: PUSH P,[0]
+ MOVE A,GLOTOP+1 ; GET GLOTOP FOR LOCR HACKS
+ MOVEM A,GLTOP
+ PUSHJ P,%FDBUF ; GET A BUFFER FOR C/W HACKS
+ SETOM GCDFLG
+ SETOM GCFLG
+ HLLZS SQUPNT
+ HRRZ TYPNT,TYPVEC+1 ; SETUP TYPNT
+ HRLI TYPNT,B
+ MOVEI A,STOSTR
+ ANDCMI A,1777 ; TO PAGE BOUNDRY
+ SUB A,GCSTOP ; SET UP AOBJN POINTER FOR C/W HACK
+ ASH A,-10. ; TO PAGES
+ HRLZS A
+ MOVEI B,STOSTR ; GET START OF MAPPING
+ ASH B,-10.
+ ADDI A,(B)
+ MOVEM A,INF1
+ PUSHJ P,%SAVIN ; PROTECT THE CORE IMAGE
+ SKIPGE (P) ; IF < 0 GC-DUMP CALL
+ PUSHJ P,PROPUR ; PROTECT PURE PAGES
+ SUB P,[1,,1] ; CLEAN OFF PSTACK
+ PUSHJ P,%CLSJB ; CLOSE INFERIOR
+
+ MOVSI D,400000 ; CREATE MARK WORD
+ SETZB LPVP,ABOTN ; ZERO ATOM COUNTER
+ MOVEI A,2000 ; MARKED INF STARTS AT PAGE ONE
+ HRRM A,BOTNEW
+ SETZM WNDBOT
+ SETZM WNDTOP
+ HRRZM A,FNTBOT
+ ADDI A,2000 ; WNDTOP
+ MOVEI A,1 ; TO PAGES
+ PUSHJ P,%GCJB1 ; CREATE THE JOB
+ MOVSI FPTR,-2000
+ MOVEI A,LPUR ; SAVE THE PURE CORE IMAGE
+ ANDCMI A,1777 ; TO PAGE BOUNDRY
+ MOVE 0,A ; COPY TO 0
+ ASH 0,-10. ; TO PAGES
+ SUB A,HITOP ; SUBTRACT TOP OF CORE
+ ASH A,-10.
+ HRLZS A
+ ADD A,0
+ MOVEM A,INF2
+ PUSHJ P,%IMSV1 ; MAP OUT INTERPRETER
+ PUSHJ P,%OPGFX
+
+; CREATE A PDL TO USE FOR THESE DUMPING FUNCTIONS
+
+ MOVE A,[-2000,,MRKPDL]
+ POPJ P,
+
+; ROUTINE TO CLOSE GC's INFERIOR
+
+
+INFCLS: MOVE A,INF2 ; GET POINTER TO PURE MAPPED OUT
+ PUSHJ P,%CLSMP
+ POPJ P,
+
+; CLOSE INFERIOR PROTECTING CORE IMAGE FOR GCDUMP
+
+INFCL2: PUSHJ P,%IFMP1 ; OPEN AGD INF TO RESTORE PAGES
+INFCL3: MOVE A,INF1 ; RESTORE OPENING POINTER
+ PUSH P,INF2
+ MOVE B,A ; SATIFY MUDITS
+ PUSHJ P,%IFMP2 ; MAP IN GC PAGES AND CLOSE INFERIOR
+ POP P,INF2 ; RESTOR INF2 PARAMETER
+ POPJ P,
+
+INFCL1: PUSHJ P,%IFMP1 ; OPEN AGD INF TO RESTORE PAGES
+ SKIPGE PURMNG ; SKIP IF NO PURE PAGES WERE MUNGED
+ PUSHJ P,REPURE ; REPURIFY MUNGED PAGES
+ JRST INFCL3
+
+\f
+
+; ROUTINE TO DO TYPE HACKING FOR GC-DUMP. IT MARKS THE TYPE-WORD OF THE
+; SLOT IN THE TYPE VECTOR. IT ALSO MARKS THE ATOM REPLACING THE I.D. IN
+; THE RIGHT HALF OF THE ATOM SLOT. IF THE TYPE IS A TEMPLATE THE FIRST
+; USE OF THE SAT HAS ITS ATOM MARKED AND THE I.D. IS PLACED IN THE LEFT
+; HALF OF THE ATOM SLOT (IT GETS THE REAL PRIMTYPE).
+
+TYPHK: CAILE B,NUMPRI ; SKIP IF A MUDDLE TYPE
+ JRST TYPHKR ; ITS A NEWTYPE SO GO TO TYPHACKER
+ CAIN B,TTYPEC ; SKIP IF NOT TYPE-C
+ JRST TYPCHK ; GO TO HACK TYPE-C
+ CAIE B,TTYPEW ; SKIP IF TYPE-W
+ POPJ P,
+ PUSH P,B
+ HLRZ B,A ; GET TYPE
+ JRST TYPHKA ; GO TO TYPE-HACKER
+TYPCHK: PUSH P,B ; SAVE TYPE-WORD
+ HRRZ B,A
+ JRST TYPHKA
+
+; GENERAL TYPE-HACKER FOR GC-DUMP
+
+TYPHKR: PUSH P,B ; SAVE AC'S
+TYPHKA: PUSH P,A
+ PUSH P,C
+ LSH B,1 ; GET OFFSET TO SLOT IN TYPE VECTOR
+ MOVEI C,(TYPNT) ; GET TO SLOT
+ ADDI C,(B)
+ SKIPGE (C)
+ JRST EXTYP
+ IORM D,(C) ; MARK THE SLOT
+ MOVEI B,TATOM ; NOW MARK THE ATOM SLOT
+ PUSHJ P,MARK1 ; MARK IT
+ HRRM A,1(C) ; SMASH IN ID
+ HRRZS 1(C) ; MAKE SURE THAT THATS ALL THATS THERE
+ HRRZ B,(C) ; GET SAT
+ ANDI B,SATMSK ; GET RID OF MAGIC BITS
+ HRRM B,(C) ; SMASH SAT BACK IN
+ CAIG B,NUMSAT ; SKIP IF TEMPLATE
+ JRST EXTYP
+ MOVE A,TYPSAV ; GET POINTER TO TYPE VECTOR
+ ADDI A,NUMPRI*2 ; GET TO NEWTYPES SLOTS
+ HRLI 0,NUMPRI*2
+ HLLZS 0 ; MAKE SURE ONLY LEFT HALF
+ ADD A,0
+TYPHK1: HRRZ E,(A) ; GET SAT OF SLOT
+ CAMN E,B ; SKIP IF NOT EQUAL
+ JRST TYPHK2 ; GOT IT
+ ADDI A,2 ; TO NEXT
+ JRST TYPHK1
+TYPHK2: PUSH P,C ; SAVE POINTER TO ORIGINAL SLOT
+ MOVE C,A ; COPY A
+ MOVEI B,TATOM ; SET UP FOR MARK
+ MOVE A,1(C) ; ASSUME MARK DOESN'T HAVE TO TAKE PLACE
+ SKIPL (C) ; DON'T MARK IF ALREADY MARKED
+ PUSHJ P,MARK
+ POP P,C ; RESTORE C
+ HRLM A,1(C) ; SMASH IN PRIMTYPE OF TEMPLATE
+EXTYP: POP P,C ; RESTORE AC'S
+ POP P,A
+ POP P,B
+ POPJ P, ; EXIT
+
+
+; A ROUTINE TO DISTINGUISH BETWEEN A DEFERRED AND A LIST POINTER
+RLISTQ: PUSH P,A
+ GETYP A,(B) ; GET TYPE
+ PUSHJ P,SAT ; GET SAT
+ CAIG A,NUMSAT ; NOT DEFERRED IF TEMPLATE
+ SKIPL MKTBS(A)
+ AOS -1(P) ; SKIP IF NOT DEFFERED
+ POP P,A
+ POPJ P, ; EXIT
+
+
+; DISPATCH TABLE FOR MARK PHASE ("SETZ'D" ENTRIES MUST BE DEFERRED)
+
+GCDISP:
+
+OFFSET 0
+
+DISTBS DUM2,GCRET,[[S2WORD,PAIRMK],[S2DEFR,DEFMK],[SNWORD,VECTMK],[STBASE,ERDP]
+[STPSTK,ERDP],[SARGS,ERDP],[S2NWORD,VECTMK],[SPSTK,ERDP],[SSTORE,VECTMK]
+[SFRAME,ERDP],[SBYTE,<SETZ BYTMK>],[SATOM,DATOMK],[SPVP,ERDP],[SGATOM,ERDP]
+[SLOCID,ERDP],[SCHSTR,<SETZ BYTMK>],[SASOC,ERDP],[SLOCL,PAIRMK],[SABASE,ERDP]
+[SLOCA,ERDP],[SLOCV,VECTMK],[SLOCU,VECTMK],[SLOCS,<SETZ BYTMK>],[SLOCN,ERDP]
+[SLOCB,<SETZ BYTMK>],[SLOCR,LOCRDP],[SOFFS,OFFSMK]]
+
+OFFSET OFFS
+
+\f
+; THIS SUBROUTINE IMPURIFIES A PURE ATOM TO ALLOW MODIFICATION OF SYSTEM SUBRS
+
+IMPRF: PUSH P,A
+ PUSH P,LPVP
+ PUSH TP,$TATOM
+ HLRZ C,(A) ; GET LENGTH
+ TRZ C,400000 ; TURN OF 400000 BIT
+ SUBI A,-1(C) ; POINT TO START OF ATOM
+ MOVNI C,-2(C) ; MAKE IT LOOK LIKE AN ATOM POINTER
+ HRL A,C
+ PUSH TP,A
+ MOVE C,A
+ MOVEI 0,(C)
+ PUSH P,AB
+ MOVE PVP,PVSTOR+1
+ MOVE AB,ABSTO+1(PVP)
+ PUSHJ P,IMPURX
+ POP P,AB
+ POP P,LPVP ; RESTORE A
+ POP P,A
+ POPJ P,
+
+FIXATM: PUSH P,[0]
+FIXTM5: JUMPE LPVP,FIXTM4
+ MOVEI B,(LPVP) ; GET PTR TO ATOMS DOPE WORD
+ HRRZ LPVP,-1(B) ; SET UP LPVP FOR NEXT IN CHAIN
+ SKIPE -2(P) ; SEE IF PURE SCAN
+ JRST FIXTM2
+ CAIL B,HIBOT
+ JRST FIXTM3
+FIXTM2: CAMG B,PARBOT ; SKIP IF NOT FROZEN
+ JRST FIXTM1
+ HLRZ A,(B)
+ TRZ A,400000 ; GET RID OF MARK BIT
+ MOVE D,A ; GET A COPY OF LENGTH
+ SKIPE -2(P)
+ JRST PFATM
+ PUSHJ P,CAFREE ; GET STORAGE
+ SKIPE GCDANG ; SEE IF WON
+ JRST LOSLP1 ; GO TO CAUSE GC
+ JRST FIXT10
+PFATM: PUSH P,AB
+ MOVE PVP,PVSTOR+1
+ MOVE AB,ABSTO+1(PVP)
+ SETZM GPURFL
+ PUSHJ P,CAFREE
+ SETOM GPURFL
+ POP P,AB
+FIXT10: SUBM D,ABOTN
+ MOVNS ABOTN
+ SUBI B,-1(D) ; POINT TO START OF ATOM
+ HRLZ C,B ; SET UP FOR BLT
+ HRRI C,(A)
+ ADDI A,-1(D) ; FIX UP TO POINT TO NEW DOPE WORD
+ BLT C,(A)
+ HLLZS -1(A)
+ HLLOS (A) ; -1 IN RELOCATION FIELD SINCE ITS NOT GARBAGE
+ ADDI B,-1(D) ; B POINTS TO SECOND D.W.
+ HRRM A,(B) ; PUT IN RELOCATION
+ MOVSI D,400000 ; UNMARK ATOM
+ ANDCAM D,(A)
+ CAIL B,HIBOT ; SKIP IF IMPURE
+ PUSHJ P,IMPRF
+ JRST FIXTM5 ; CONTINE FIXUP
+
+FIXTM4: POP P,LPVP ; FIX UP LPVP TO POINT TO NEW CHAIN
+ POPJ P, ; EXIT
+
+FIXTM1: HRRM B,(B) ; SMASH IN RELOCATION
+ MOVSI D,400000
+ ANDCAM D,(B) ; CLEAR MARK BIT
+ JRST FIXTM5
+
+FIXTM3: MOVE 0,(P)
+ HRRM 0,-1(B)
+ MOVEM B,(P) ; FIX UP CHAIN
+ JRST FIXTM5
+
+
+\f
+IAGC":
+
+;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 /GIN /]
+ 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: SUB P,[1,,1] ; POP OFF C
+ POP P,A
+ POP P,B
+ EXCH P,GCPDL
+ JRST .+1
+IAAGC:
+ HLLZS SQUPNT ; FLUSH SQUOZE TABLE
+ SETZB M,RCL ; ALTERNATE GC-ENTRY POINT FOR INITIALIZATION
+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,B
+
+CHPDL: MOVE D,P ; SAVE FOR LATER
+CORGET: MOVE P,[-2000,,MRKPDL]
+
+;FENCE POST PDLS AND CHECK IF ANY SHOULD BE SHRUNK
+
+ MOVEI 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
+ HRRM A,BOTNEW ; INTO POINTER WORD
+ HRRZM A,FNTBOT
+ SETZM WNDBOT
+ SETZM WNDTOP
+ MOVEM A,NPARBO
+ HRRZ A,BOTNEW ; GET PAGE TO START INF AT
+ ASH A,-10. ; TO PAGES
+ MOVEI R,(A) ; COPY A
+ PUSHJ P,%GCJOB ; GET PAGE HOLDER
+ MOVSI FPTR,-2000 ; FIX UP FRONTIER POINTER
+ MOVE A,WNDBOT
+ ADDI A,2000 ; FIND WNDTOP
+ MOVEM A,WNDTOP
+
+;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; MAP NEW PAIR SPACE IN FOR PAIR SPACE UPDATE
+
+NOMAP1: MOVEI A,@BOTNEW
+ ADDI A,1777 ; TO PAGE BOUNDRY
+ ANDCMI A,1777
+ MOVE B,A
+DOMAP: ASH B,-10. ; TO PAGES
+ MOVE A,PARBOT
+ MOVEI C,(A) ; COMPUTE HIS TOP
+ ASH C,-10.
+ ASH A,-10.
+ SUBM A,B ; B==> - # OF PAGES
+ HRLI A,(B) ; AOBJN TO SOURCE AND DEST
+ MOVE B,A ; IN CASE OF FUNNY
+ HRRI B,(C) ; MAP HIS POSSIBLE HIGHER OR LOWER PAGES
+ PUSHJ P,%INFMP ; NOW FLUSH INF AND MAKE HIS CORE MINE
+ JRST GARZER
+
+\f; CORE ADJUSTMENT PHASE
+
+CORADJ: MOVE A,PURTOP
+ SUB A,CURPLN ; ADJUST FOR RSUBR
+ ANDCMI A,1777 ; ROUND DOWN
+ MOVEM A,RPTOP
+ MOVEI A,@BOTNEW ; 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
+ MOVEI A,@BOTNEW ; GCSTOP
+ MOVEM A,GCSTOP
+ MOVE A,CORTOP ; ADJUST CORE IMAGE
+ ASH A,-10. ; TO PAGES
+TRYPCO: PUSHJ P,P.CORE
+ FATAL AGC--CORE SCREW UP
+ 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
+ MOVEI A,@BOTNEW
+ 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
+CORAD8: MOVEM A,CORTOP ; ADJUST PARAMETER
+ JRST CORAD6 ; WIN TOTALLY
+
+; 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;GARBAGE ZEROING PHASE
+GARZER: MOVE A,GCSTOP ;FIRST WORD OF GARBAGE IS AFTER PAIR SPACE
+ MOVE B,FRETOP ;LAST ADDRESS OF GARBAGE + 1
+ CAIL A,(B)
+ JRST GARZR1
+ CLEARM (A) ;ZERO THE FIRST WORD
+ CAIL A,-1(B) ; ARE WE AT THE TOP OF THE WORLD (FORMERLY CAML A,FRETOP)
+ JRST GARZR1 ; DON'T BLT
+IFE ITS,[
+ MOVEI B,777(A)
+ ANDCMI B,777
+]
+ HRLS A
+ ADDI A,1 ;MAKE A A BLT POINTER
+ BLT A,-1(B) ;AND COPY ZEROES INTO REST OF AREA
+IFE ITS,[
+
+; MAP UNWANTED PAGES OUT ON TWENEX (AFTER ZEROING REST OF LAST PAGE)
+
+ MOVE D,PURBOT
+ ASH D,-PGSZ
+ ASH B,-PGSZ
+ MOVNI A,1
+ MOVEI C,0
+ HRLI B,400000
+
+GARZR2: CAIG D,(B)
+ JRST GARZR1
+
+ PMAP
+ AOJA B,GARZR2
+]
+
+
+; 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
+ 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 IAGC
+
+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 ; LOADING ONE, M = 0 IS OK
+ JRST FINAGC
+
+ FATAL AGC--RUNNING RSUBR WENT AWAY
+
+AGCE1: FATAL AGC--TYPE VECTOR NOT OF TYPE VECTOR
+
+\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
+ 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,[111100,,-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 F,1(A) ; GET LNTH
+ LDB 0,[111100,,(A)] ; GET GROWTHS
+ TRZE 0,400 ; SIGN HACK
+ MOVNS 0
+ ASH 0,6 ; TO WORDS
+ ADD F,0
+ LDB 0,[001100,,(A)]
+ TRZE 0,400
+ MOVNS 0
+ ASH 0,6
+ ADD F,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: SKIPN DUMFLG
+ JUMPE A,CPOPJ ; NEVER MARK 0
+ MOVEI 0,1(A)
+ CAIL 0,@PURBOT
+ JRST GCRETD
+MARCON: PUSH P,A
+ HRLM C,-1(P) ;AND POINTER TO IT
+ ANDI B,TYPMSK ; FLUSH MONITORS
+ SKIPE DUMFLG ; SKIP IF NOT IN DUMPER
+ PUSHJ P,TYPHK ; HACK SOME TYPES
+ 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
+ SKIPN GCDFLG
+IFN ITS,[
+ JRST @MKTBS(B) ;AND GO MARK
+ JRST @GCDISP(B) ; DISPATCH FOR DUMPERS
+]
+IFE ITS,[
+ SKIPA E,MKTBS(B)
+ MOVE E,GCDISP(B)
+ HRLI E,-1
+ JRST (E)
+]
+; 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: TLOA TYPNT,400000 ;USE SIGN BIT AS FLAG
+
+;HERE TO MARK LIST ELEMENTS
+
+PAIRMK: TLZ TYPNT,400000 ;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
+ SKIPL FPTR ; SEE IF IN FRONTEIR
+ PUSHJ P,MOVFNT ; EXPAND THE FRONTEIR
+ MOVEM B,FRONT(FPTR)
+ MOVE 0,1(C) ; AND 2D
+ AOBJN FPTR,.+2 ; AOS AND CHECK FRONTEIR
+ PUSHJ P,MOVFNT ; EXPAND FRONTEIR
+ MOVEM 0,FRONT(FPTR)
+ ADD FPTR,[1,,1] ; MOVE ALONG IN FRONTIER
+
+
+PAIRM2: MOVEI A,@BOTNEW ; GET INF ADDR
+ SUBI A,2
+ HRRM A,(C) ; LEAVE A POINTER TO NEW HOME
+ HRRZ E,(P) ; GET BACK POINTER
+ JUMPE E,PAIRM7 ; 1ST ONE, NEW FIXUP
+ MOVSI 0,(HRRM) ; INS FOR CLOBBER
+ PUSHJ P,SMINF ; SMASH INF'S CORE IMAGE
+PAIRM4: MOVEM A,(P) ; NEW BACK POINTER
+ JUMPL TYPNT,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
+ ADDI E,1
+ MOVSI 0,(MOVEM)
+ PUSHJ P,SMINF
+ 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: SUB P,[1,,1]
+
+GCRET: TLZ TYPNT,400000 ;FOR PAIRMKS BENEFIT
+ HLRZ C,-1(P) ;RESTORE C
+ POP P,A
+ POPJ P, ;AND RETURN TO CALLER
+
+GCRETD: ANDI B,TYPMSK ; TURN OFF MONITORS
+ CAIN B,TLOCR ; SEE IF A LOCR
+ JRST MARCON
+ SKIPN GCDFLG ; SKIP IF IN PURIFIER OR DUMPER
+ POPJ P,
+ CAIE B,TATOM ; WE MARK PURE ATOMS
+ CAIN B,TCHSTR ; AND STRINGS
+ 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
+ PUSHJ P,MARK2 ;MARK THE DATUM
+ HRRZ E,-2(P) ; GET POINTER IN INF CORE
+ ADDI E,1
+ MOVSI 0,(MOVEM)
+ PUSHJ P,SMINF ; AND CLOBBER
+ HRRZ E,-2(P)
+ MOVE A,-1(P)
+ MOVSI 0,(HRRM) ; SMASH IN RIGHT HALF
+ PUSHJ P,SMINF
+ SUB P,[3,,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
+ MOVSI 0,(HRRM)
+ PUSHJ P,SMINF
+ JRST GCRETP
+
+RETNW1: MOVEM A,-1(P)
+ JRST GCRETP
+
+; ROUTINE TO EXPAND THE FRONTEIR
+
+MOVFNT: PUSH P,B ; SAVE REG B
+ HRRZ A,BOTNEW ; CURRENT BOTTOM OF WINDOW
+ ADDI A,2000 ; MOVE IT UP
+ HRRM A,BOTNEW
+ HRRZM A,FNTBOT ; BOTTOM OF FRONTEIR
+ MOVEI B,FRNP
+ ASH A,-10. ; TO PAGES
+ PUSHJ P,%GETIP
+ PUSHJ P,%SHWND ; SHARE THE PAGE
+ MOVSI FPTR,-2000 ; FIX UP FPTR
+ POP P,B
+ POPJ P,
+
+
+; ROUTINE TO SMASH INFERIORS PPAGES
+; E/ ADDR IN INF, A/ THING TO SMASH ,0/ INS TO USE
+
+SMINF: CAMGE E,FNTBOT
+ JRST SMINF1 ; NOT IN FRONTEIR
+ SUB E,FNTBOT ; ADJUST POINTER
+ IOR 0,[0 A,FRONT(E)] ; BUILD INSTRUCTION
+ XCT 0 ; XCT IT
+ POPJ P, ; EXIT
+SMINF1: CAML E,WNDBOT
+ CAML E,WNDTOP ; SEE IF IN WINDOW
+ JRST SMINF2
+SMINF3: SUB E,WNDBOT ; FIX UP
+ IOR 0,[0 A,WIND(E)] ; FIX INS
+ XCT 0
+ POPJ P,
+SMINF2: PUSH P,A ; SAVE E
+ PUSH P,B ; SAVE B
+ HRRZ A,E ; E SOMETIMES HAS STUFF IN LH
+ ASH A,-10.
+ MOVEI B,WNDP ; WINDOW PAGE
+ PUSHJ P,%SHWND ; SHARE IT
+ ASH A,10. ; TO PAGES
+ MOVEM A,WNDBOT ; UPDATE POINTERS
+ ADDI A,2000
+ MOVEM A,WNDTOP
+ POP P,B ; RESTORE ACS
+ POP P,A
+ JRST SMINF3 ; FIX UP INF
+
+
+
+\f; VECTOR AND TP MARKER, SIGN OF TYPNT IS SET BASED ON WHICH ONE
+
+TPMK: TLOA TYPNT,400000 ;SET TP MARK FLAG
+VECTMK: TLZ TYPNT,400000
+ MOVEI 0,@BOTNEW ; POINTER TO INF
+ PUSH P,0
+ 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
+
+ HLLM TYPNT,(P) ; SAVE MARKER INDICATING STACK
+ JUMPGE TYPNT,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,[111100,,-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,[001100,,-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 F,(E) ;SAVE A COPY
+ ADD F,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
+ SKIPGE B,-1(A) ;SKIP IF UNIFORM
+ TLNE B,377777-.VECT. ;SKIP IF NOT SPECIAL
+ JUMPGE TYPNT,NOTGEN ;JUMP IF NOT A GENERAL VECTOR
+
+GENRAL: HLRZ 0,B ;CHECK FOR PSTACK
+ TRZ 0,.VECT.
+ JUMPE 0,NOTGEN ;IT ISN'T GENERAL
+ JUMPL TYPNT,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
+ HRRZ E,-1(P) ; GET POINTER INTO INF
+ SKIPN C ; SKIP IF NO BOTTOM GROWTH
+ JRST MOVEC3
+ JUMPL C,.+3 ; SEE IF BOTTOM SHRINKAGE
+ ADD E,C ; GROW IT
+ JRST MOVEC3 ; CONTINUE
+ HRLM C,E ; MOVE SHRINKAGE FOR TRANSFER PHASE
+MOVEC3: PUSHJ P,DOPMOD ; MODIFY DOPE WORD AND PLACE IN INF
+ PUSHJ P,TRBLKV ; SEND VECTOR INTO INF
+TGROT: CAMGE A,PARBOT ; SKIP IF NOT STORAGE
+ JRST TGROT1
+ MOVE C,DOPSV1 ; RESTORE DOPE WORD
+ SKIPN (P) ; DON'T RESTORE D.W.'S YET IF THERE IS GROWTH
+ MOVEM C,-1(A)
+TGROT1: POP P,C ; IS THERE TOP GROWH
+ SKIPN C ; SEE IF ANY GROWTH
+ JRST DOPEAD
+ SUBI E,2
+ SKIPG C
+ JRST OUTDOP
+ PUSH P,C ; SAVE C
+ SETZ C, ; ZERO C
+ PUSHJ P,ADWD
+ ADDI E,1
+ SETZ C, ; ZERO WHERE OLD DOPE WORDS WERE
+ PUSHJ P,ADWD
+ POP P,C
+ ADDI E,-1(C) ; MAKE ADJUSTMENT FOR TOP GROWTH
+OUTDOP: PUSHJ P,DOPOUT
+DOPEAD:
+EXVECT: HLRZ B,(P)
+ SUB P,[1,,1] ; GET RID OF FPTR
+ PUSHJ P,RELATE ; RELATIVIZE
+ TRNN B,400000 ; WAS THIS A STACK
+ JRST 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
+ POP P,C
+ 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
+ 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)
+ PUSHJ P,OUTTP ; MOVE OUT TYPE
+ MOVE A,R
+ PUSHJ P,OUTTP ; SEND OUT VALUE
+ 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)
+ PUSHJ P,OUTTP ; SEND IT OUT
+ 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)
+ PUSHJ P,OUTTP ; SEND IT OUT
+ MOVE A,-2(P) ; ADJUST AB SLOT
+ ADD A,ABSAV-FSAV+1(C) ; POINT TO SAVED AB
+ PUSHJ P,OUTTP ; SEND IT OUT
+ 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
+ PUSHJ P,OUTTP ; SEND IT OUT
+ HRROI C,PSAV-FSAV(C) ;POINT TO SAVED P
+ MOVEI B,TPDL
+ PUSHJ P,MARK1 ;AND MARK IT
+ PUSHJ P,OUTTP ; SEND IT OUT
+ 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
+ PUSHJ P,OUTTP
+ MOVE A,PCSAV-PSAV+1(C)
+ PUSHJ P,OUTTP
+ 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)
+ PUSHJ P,OUTTP ; FIX UP CHAIN
+ MOVEI B,TATOM ; RESTORE IN CASE SMASHED
+ PUSHJ P,MARK1 ; MARK ATOM
+ PUSHJ P,OUTTP ; SEND IT OUT
+ 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)
+ PUSHJ P,OUTTP ; MOVE OUT TYPE
+ MOVE A,R
+ PUSHJ P,OUTTP ; SEND OUT VALUE
+ 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
+ PUSHJ P,OUTTP
+ SKIPL A,1(C) ; PREV LOC?
+ JRST NOTLCI
+ MOVEI B,TLOCI ; NOW MARK LOCATIVE
+ PUSHJ P,MARK1
+NOTLCI: PUSHJ P,OUTTP
+ 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
+ PUSHJ P,OUTTP
+ ADDI C,1 ; INCREMENT C FOR FENCE-POST
+ SUB P,[1,,1] ; CLEAN UP STACK
+ POP P,E ; GET UPDATED PTR TO INF
+ SUB P,[2,,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
+ PUSHJ P,DOPMOD ; FIX UP DOPE WORDS
+ PUSHJ P,DOPOUT ; SEND THEM OUT
+ JRST DOPEAD
+
+
+\f; ROUTINE TO ALLOCATE ROOM FOR VECTORS IN INFERIOR
+; F= # OF WORDS TO ALLOCATE
+
+ALLOGC: HRRZS A ; GET ABS VALUE
+ SKIPN GCDFLG ; SKIP IF IN DUMPER
+ CAML A,GCSBOT ; SKIP IF IN STORAGE
+ JRST ALOGC2 ; JUMP IF ALLOCATING
+ HRRZ 0,A
+ POPJ P,
+ALOGC2: PUSH P,A ; SAVE A
+ALOGC1: HLRE 0,FPTR ; GET ROOM LEFT
+ ADD 0,F ; SEE IF ITS ENOUGH
+ JUMPL 0,ALOCOK
+ MOVE F,0 ; MODIFY F
+ PUSH P,F
+ PUSHJ P,MOVFNT ; MOVE UP FRONTEIR
+ POP P,F
+ JRST ALOGC1 ; CONTINUE
+ALOCOK: ADD FPTR,F ; MODIFY FPTR
+ HRLZS F
+ ADD FPTR,F
+ POP P,A ; RESTORE A
+ MOVEI 0,@BOTNEW
+ SUBI 0,1 ; RELOCATION PTR
+ POPJ P, ; EXIT
+
+
+
+
+; TRBLK MOVES A VECTOR INTO THE INFERIOR
+; E= STARTING ADDR IN INF A= DOPE WORD OF VECTOR
+
+TRBLK: HRRZS A
+ SKIPE GCDFLG
+ JRST TRBLK7
+ CAMGE A,GCSBOT ; SEE IF IN GC-SPACE
+ JRST FIXDOP
+TRBLK7: PUSH P,A
+ HLRZ 0,(A)
+ TRZ 0,400000 ; TURN OFF GC FLAG
+ HRRZ F,A
+ HLRE A,E ; GET SHRINKAGE
+ ADD 0,A ; MUNG LENGTH
+ SUB F,0
+ ADDI F,1 ; F POINTS TO START OF VECTOR
+TRBLK2: HRRZ R,E ; SAVE POINTER TO INFERIOR
+ ADD E,0 ; E NOW POINTS TO FINAL ADDRESS+1
+ MOVE M,E ;SAVE E
+TRBLK1: MOVE 0,R
+ SUBI E,1
+ CAMGE R,FNTBOT ; SEE IF IN FRONTEIR
+ JRST TRBL10
+ SUB E,FNTBOT ; ADJUST E
+ SUB 0,FNTBOT ; ADJ START
+ MOVEI A,FRONT+1777
+ JRST TRBLK4
+TRBL10: CAML R,WNDBOT
+ CAML R,WNDTOP ; SEE IF IN WINDOW
+ JRST TRBLK5 ; NO
+ SUB E,WNDBOT
+ SUB 0,WNDBOT
+ MOVEI A,WIND+1777
+TRBLK4: ADDI 0,-1777(A) ; CALCULATE START IN WINDOW OR FRONTEIR
+ CAIL E,2000
+ JRST TRNSWD
+ ADDI E,-1777(A) ; SUBTRACT WINDBOT
+ HRL 0,F ; SET UP FOR BLT
+ BLT 0,(E)
+ POP P,A
+
+FIXDOP: IORM D,(A)
+ MOVE E,M ; GET END OF WORD
+ POPJ P,
+TRNSWD: PUSH P,B
+ MOVEI B,1(A) ; GET TOP OF WORLD
+ SUB B,0
+ HRL 0,F
+ BLT 0,(A)
+ ADD F,B ; ADJUST F
+ ADD R,B
+ POP P,B
+ MOVE E,M ; RESTORE E
+ JRST TRBLK1 ; CONTINUE
+TRBLK5: HRRZ A,R ; COPY E
+ ASH A,-10. ; TO PAGES
+ PUSH P,B ; SAVE B
+ MOVEI B,WNDP ; IT IS WINDOW
+ PUSHJ P,%SHWND
+ ASH A,10. ; TO PAGES
+ MOVEM A,WNDBOT ; UPDATE POINTERS
+ ADDI A,2000
+ MOVEM A,WNDTOP
+ POP P,B ; RESTORE B
+ JRST TRBL10
+
+
+
+
+; ALTERNATE ENTRY FOR VECTORS WHICH TAKES CARE OF SHRINKAGE
+
+TRBLKV: HRRZS A
+ SKIPE GCDFLG ; SKIP IF NOT IN DUMPER
+ JRST TRBLV2
+ CAMGE A,GCSBOT ; SEE IF IN GC-SPACE
+ JRST FIXDOP
+TRBLV2: PUSH P,A ; SAVE A
+ HLRZ 0,DOPSV2
+ TRZ 0,400000
+ HRRZ F,A
+ HLRE A,E ; GET SHRINKAGE
+ ADD 0,A ; MUNG LENGTH
+ SUB F,0
+ ADDI F,1 ; F POINTS TO START OF VECTOR
+ SKIPGE -2(P) ; SEE IF SHRINKAGE
+ ADD 0,-2(P) ; IF SO COMPENSATE
+ JRST TRBLK2 ; CONTINUE
+
+; ALTERNATE ENTRY POINT TO TRBLK A==> OBJECT TO SEND IN 0= # OF WORDS
+
+TRBLK3: PUSH P,A ; SAVE A
+ MOVE F,A
+ JRST TRBLK2
+
+; FINAL ALTERNATE ENTRY POINT TO TRBLK A==> OBJECT
+; F==> START OF TRANSFER IN GCS 0= # OF WORDS
+
+TRBLKX: PUSH P,A ; SAVE A
+ JRST TRBLK2 ; SEND IT OUT
+
+
+; OUTTP IS THE ROUTINE THAT TPMK USES TO SEND OUT ELEMENTS FOR THE SCAN
+; -2(P) CONTAINS THE ADDR IN THE INF AND IT IS UPDATED
+; A CONTAINS THE WORD TO BE SENT OUT
+
+OUTTP: AOS E,-2(P) ; INCREMENT PLACE
+ MOVSI 0,(MOVEM) ; INS FOR SMINF
+ SOJA E,SMINF
+
+
+; ADWD PLACES ONE WORD IN THE INF
+; E ==> INF C IS THE WORD
+
+ADWD: PUSH P,E ; SAVE AC'S
+ PUSH P,A
+ MOVE A,C ; GET WORD
+ MOVSI 0,(MOVEM) ; INS FOR SMINF
+ PUSHJ P,SMINF ; SMASH IT IN
+ POP P,A
+ POP P,E
+ POPJ P, ; EXIT
+
+; DOPOUT IS USED TO SEND OUT THE DOPE WORDS IN UNUSUAL CALSE
+; SUCH AS THE TP AND GROWTH
+
+
+DOPOUT: MOVE C,-1(A)
+ PUSHJ P,ADWD
+ ADDI E,1
+ MOVE C,(A) ; GET SECOND DOPE WORD
+ TLZ C,400000 ; TURN OFF POSSIBLE MARK BIT
+ PUSHJ P,ADWD
+ MOVE C,DOPSV1 ; FIX UP FIRST DOPE WORD
+ MOVEM C,-1(A)
+ MOVE C,DOPSV2
+ MOVEM C,(A) ; RESTORE SECOND D.W.
+ POPJ P,
+
+; DOPMOD MODIFIES THE DOPE WORD OF A VECTOR AND PLACES A NEW DOPE-WORD IN INF
+; A ==> DOPE WORD E==> INF
+
+DOPMOD: SKIPE GCDFLG ; CHECK TO SEE IF IN DUMPER AND PURIFY
+ JRST .+3
+ CAMG A,GCSBOT
+ POPJ P, ; EXIT IF NOT IN GCS
+ MOVE C,-1(A) ; GET FIRST DOPE WORD
+ MOVEM C,DOPSV1
+ HLLZS C ; CLEAR OUT GROWTH
+ TLO C,.VECT. ; FIX UP FOR GCHACK
+ PUSH P,C
+ MOVE C,(A) ; GET SECOND DOPE WORD
+ HLRZ B,(A) ; GET LENGTH
+ TRZ B,400000 ; TURN OFF MARK BIT
+ MOVEM C,DOPSV2
+ HRRZ 0,-1(A) ; CHECK FOR GROWTH
+ JUMPE 0,DOPMD1
+ LDB 0,[111100,,-1(A)] ; MODIFY WITH GROWTH
+ TRZE 0,400
+ MOVNS 0
+ ASH 0,6
+ ADD B,0
+ LDB 0,[001100,,-1(A)]
+ TRZE 0,400
+ MOVNS 0
+ ASH 0,6
+ ADD B,0
+DOPMD1: HRL C,B ; FIX IT UP
+ MOVEM C,(A) ; FIX IT UP
+ POP P,-1(A)
+ POPJ P,
+
+ADPMOD: CAMG A,GCSBOT
+ POPJ P, ; EXIT IF NOT IN GCS
+ MOVE C,-1(A) ; GET FIRST DOPE WORD
+ TLO C,.VECT. ; FIX UP FOR GCHACK
+ MOVEM C,-1(A)
+ MOVE C,(A) ; GET SECOND DOPE WORD
+ TLZ C,400000 ; TURN OFF PARK BIT
+ MOVEM C,(A)
+ POPJ P,
+
+
+
+
+\f; RELATE RELATAVIZES A POINTER TO A VECTOR
+; B IS THE POINTER A==> DOPE WORD
+
+RELATE: SKIPE GCDFLG ; SEE IF DUMPER OR PURIFIER
+ JRST .+3
+ CAMGE A,GCSBOT ; SEE IF IN VECTOR SPACE
+ POPJ P, ; IF NOT EXIT
+ MOVE C,-1(P)
+ HLRE F,C ; GET LENGTH
+ HRRZ 0,-1(A) ; CHECK FO GROWTH
+ JUMPE A,RELAT1
+ LDB 0,[111100,,-1(A)] ; GET TOP GROWTH
+ TRZE 0,400 ; HACK SIGN BIT
+ MOVNS 0
+ ASH 0,6 ; CONVERT TO WORDS
+ SUB F,0 ; ACCOUNT FOR GROWTH
+RELAT1: HRLM F,C ; PLACE CORRECTED LENGTH BACK IN POINTER
+ HRRZ F,(A) ; GET RELOCATED ADDR
+ SUBI F,(A) ; FIND RELATIVIZATION AMOUNT
+ ADD C,F ; 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)
+ PUSH P,A
+ MOVEI C,-1(P)
+ MOVEI B,TTP
+ PUSHJ P,MARK
+ SUB P,[1,,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 F,OTBSAV(A) ; GET TIME FROM FRAME
+ CAME B,F ; 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 F,-1(A) ; GET THE TYPE
+ ANDI F,SATMSK ; FLUSH MONITOR BITS
+ CAIN F,SATOM ; SEE IF ATOM
+ JRST ATMSET
+ HLRE F,(A) ; GET MARKING
+ JUMPL F,BYTREL ; JUMP IF MARKED
+ HLRZ F,(A) ; GET LENGTH
+ PUSHJ P,ALLOGC ; ALLOCATE FOR IT
+ HRRM 0,(A) ; SMASH IT IN
+ MOVE E,0
+ HLRZ F,(A)
+ SUBI E,-1(F) ; ADJUST INF POINTER
+ IORM D,(A)
+ PUSHJ P,ADPMOD
+ PUSHJ P,TRBLK
+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
+ SKIPN GCDFLG
+ JRST BYTREL
+ MOVSI E,STATM ; GET "STRING IS ATOM BIT"
+ IORM E,(P)
+ SKIPN DUMFLG
+ JRST GCRET
+ HRRM A,(P)
+ JRST BYTREL ; TO BYTREL
+\f
+
+; MARK OFFSET
+
+OFFSMK: HLRZS A
+ PUSH P,$TLIST
+ PUSH P,A ; PUSH LIST POINTER ON THE STACK
+ MOVEI C,-1(P) ; POINTER TO PAIR
+ PUSHJ P,MARK2 ; MARK THE LIST
+ HRLM A,-2(P) ; UPDATE POINTER IN OFFSET
+ SUB P,[2,,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
+ HLRZ 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,@BOTNEW
+ PUSH P,0 ; SAVE POINTER TO INF
+ TLO TYPNT,.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) ; MAKE SURE ATOMS NOT ON OBLISTS GET SENT
+ POP P,A ; RESTORE A
+ POP P,E ; GET POINTER INTO INF
+ SKIPN GCHAIR
+ JUMPN 0,ATMREL
+ PUSHJ P,ADPMOD
+ PUSHJ P,TRBLK
+ATMREL: HRRZ E,(A) ; RELATAVIZE
+ SUBI E,(A)
+ ADDM E,(P)
+ JRST GCRET
+ATMRL1: SUB P,[1,,1] ; POP OFF STACK
+ JRST ATMREL
+
+\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 F,(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: SUB P,[1,,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
+ PUSH P,E
+ SKIPE DUMFLG ; SKIP IF NOT IN DUMPER
+ PUSHJ P,TYPHK ; HACK WITH TYPE IF SPECIAL
+ POP P,E ; RESTORE LENGTH
+ MOVE F,B ; AND COPY IT
+ LSH B,1 ;FIND OUT WHERE IT WILL GO
+ HRRZ B,@TYPNT ;GET SAT IN B
+ ANDI B,SATMSK
+ MOVEI C,@MKTBS(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,F ;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
+
+ SUB P,[2,,2] ;REMOVE STACK CRAP
+ JRST UMOVEC
+
+
+SPECLS: FATAL AGC--UNRECOGNIZED SPECIAL VECTOR
+ SUB P,[4,,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,@BOTNEW ; 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,A ; GET PTR TO D.W.
+ POP P,E ; GET PTR TO INF
+ SUB P,[1,,1] ; GET RID OF TOP
+ PUSHJ P,ADPMOD ; FIX UP D.W.
+ PUSHJ P,TRBLK ; SEND IT OUT
+ JRST ATMREL ; RELATIVIZE AND LEAVE
+GCRDRL: POP P,A ; GET PTR TO D.W
+ SUB P,[2,,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
+ SKIPN DUMFLG ; IF GC-DUMP, WILL STORE ATOM FOR LOCR
+ JRST LOCRDD
+ MOVEI B,1
+ IORM B,3(A) ; MUNG ATOM TO SAY IT IS LOCR
+ CAIA
+LOCRDD: 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 E,(A) ; GET PTR IN FRONTEIR
+ SUBI E,ASOLNT+1 ; ADJUST TO POINT TO BEGINNING
+ PUSHJ P,ADPMOD
+ PUSHJ P,TRBLK
+ JRST ASTR1
+
+;HERE WHEN A VECTOR POINTER IS BAD
+
+VECTB1:FATAL AGC--VECTOR POINTS OUTSIDE OF VECTOR SPACE
+ SUB P,[1,,1] ; RECOVERY
+AFIXUP: SETZM (P) ; CLOBBER SLOT
+ JRST GCRET ; CONTINUE
+
+
+VECTB2: FATAL AGC--VECTOR POINTS OUT OF VECTOR SPACE
+ SUB P,[2,,2]
+ JRST AFIXUP ; RECOVER
+
+PARERR: FATAL AGC--PAIR POINTS OUT OF PAIR SPACE
+ SUB P,[1,,1] ; RECOVER
+ JRST AFIXUP
+
+
+\f; HERE TO MARK TEMPLATE DATA STRUCTURES
+
+TD.MRK: MOVEI 0,@BOTNEW ; 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 E,-7(P) ; RESTORE PTR TO FRONTEIR
+ SUB P,[7,,7] ; CLEAN UP STACK
+USRAG1: ADDI A,1 ; POINT TO SECOND D.W.
+ MOVSI D,400000 ; SET UP MARK BIT
+ PUSHJ P,ADPMOD
+ PUSHJ P,TRBLK ; SEND IT OUT
+TMPREL: SUB P,[1,,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 E,(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 F,(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 F,(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,F
+ HLRE F,ASOLNT-INDIC+1(C) ; GET LENGTH
+ JUMPL F,.+3 ; SKIP IF MARKED
+ CAMGE C,VECBOT ; SKIP IF IN VECT SPACE
+ JRST ASOM20
+ HRRM FPTR,ASOLNT-INDIC+1(C) ; PUT IN RELATIVISATION
+ MOVEI F,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,F
+ 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(F) ; 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
+ TLZE TYPNT,.ATOM. ; ANY ATOMS MARKED?
+ JRST VALFLA ; YES, CHECK VALUES
+VALFL8:
+
+; NOW SEE WHICH CHANNELS STILL POINTED TO
+
+CHNFL3: MOVEI 0,N.CHNS-1
+ MOVEI A,CHNL1 ; SLOTS
+ HRLI A,TCHAN ; TYPE HERE TOO
+
+CHNFL2: SKIPN B,1(A)
+ JRST CHNFL1
+ HLRE C,B
+ SUBI B,(C) ; POINT TO DOPE
+ HLLM A,(A) ; PUT TYPE BACK
+ HRRE F,(A) ; SEE IF ALREADY MARKED
+ JUMPN F,CHNFL1
+ SKIPGE 1(B)
+ JRST CHNFL8
+ HLLOS (A) ; MARK AS A LOSER
+ SETZM -1(P)
+ JRST CHNFL1
+CHNFL8: MOVEI F,1 ; MARK A GOOD CHANNEL
+ HRRM F,(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
+
+ SUB P,[2,,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 F,A ; CALCULATE START OF TP IN F
+ HLRZ B,(A) ; ADJUST INF PTR
+ TRZ B,400000
+ SUBI F,-1(B)
+ LDB M,[111100,,-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: SUB P,[1,,1] ; CLEAN UP STACK
+ SUBI E,-1(B)
+ HRRI B,(R) ; GET POINTER TO THIS-PROCESS BINDING
+ MOVEI B,6(B) ; POINT AFTER THE BINDING
+ MOVE 0,F ; CALCULATE # OF WORDS TO SEND OUT
+ SUBM B,0
+ PUSH P,R ; PRESERVE R
+ PUSHJ P,TRBLKX ; SEND IT OUT
+ POP P,R ; RESTORE R
+ HRRZS R,2(R) ; GET THE NEXT PROCESS
+ SKIPN R
+ JRST .+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 A,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 SPECIAL STUFF FROM GCHAIR
+
+SPCOUT: HLRE B,A
+ SUB A,B
+ MOVEI A,1(A) ; POINT TO DOPE WORD
+ LDB 0,[001100,,-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
+ PUSHJ P,DOPMOD
+ HRRZ E,(A) ; GET PTR TO INF
+ HLRZ B,(A) ; LENGTH
+ TRZ B,400000 ; GET RID OF MARK BIT
+ SUBI E,-1(B)
+ ADD E,0
+ PUSH P,0 ; DUMMY FOR TRBLKV
+ PUSHJ P,TRBLKV ; OUT IT GOES
+ SUB P,[1,,1]
+ 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,F
+ PUSHJ P,MARK2
+ MOVEM A,1(C)
+ POP P,F
+ 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
+ SUB P,[1,,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: ADDI 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 F,ASOLNT+1(B) ;AND ITS RELOCATION
+ SUBI F,ASOLNT+1(B) ; RELATIVIZE
+ MOVSI F,(F)
+ ADDM F,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 F,ASOLNT+1(B) ;RELOC
+ SUBI F,ASOLNT+1(B)
+ MOVSI F,(F)
+ ADDM F,NODPNT(A)
+ASOUP5: POP P,A ; RECOVER PTR TO DOPE WORD
+ MOVEI A,ASOLNT+1(A)
+ MOVSI B,400000 ;UNMARK IT
+ XORM B,(A)
+ HRRZ E,(A) ; SET UP PTR TO INF
+ HLRZ B,(A)
+ SUBI E,-1(B) ; ADJUST PTR
+ PUSHJ P,ADPMOD
+ PUSHJ P,TRBLK ; OUT IT GOES
+ 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 F,1(C) ; FIND NEXT ATOM
+ SUBI C,-2(F)
+ 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
+ MOVSI D,400000 ;UNMARK IT
+ XORM D,1(A)
+ HRRZ E,1(A) ; SET UP PTR TO INF
+ HLRZ B,1(A)
+ SUBI E,-1(B) ; ADJUST PTR
+ MOVEI A,1(A)
+ PUSHJ P,ADPMOD
+ PUSHJ P,TRBLK ; OUT IT GOES
+ 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
+
+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
+
+DOPSV1: 0 ;SAVED FIRST D.W.
+DOPSV2: 0 ; SAVED LENGTH
+
+
+; LOCATIONS USED BY BLOAT-STAT TO HELP THE USER PICK BLOAT SPECIFICATIONS.
+;
+
+GCNO: 0 ; USER-CALLED GC
+BSTGC: 0 ; FREE STORAGE
+ 0 ; BLOWN TP
+ 0 ; TOP-LEVEL LVALS
+ 0 ; GVALS
+ 0 ; TYPE
+ 0 ; STORAGE
+ 0 ; P-STACK
+ 0 ; BOTH STATCKS BLOWN
+ 0 ; STORAGE
+
+BSTAT:
+NOWFRE: 0 ; FREE STORAGE FROM LAST GC
+CURFRE: 0 ; STORAGE USED SINCE LAST GC
+MAXFRE: 0 ; MAXIMUM FREE STORAGE ALLOCATED
+USEFRE: 0 ; TOTAL FREE STORAGE USED
+NOWTP: 0 ; TP LENGTH FROM LAST GC
+CURTP: 0 ; # WORDS ON TP
+CTPMX: 0 ; MAXIMUM SIZE OF TP SO FAR
+NOWLVL: 0 ; # OF TOP-LEVEL LVAL-SLOTS
+CURLVL: 0 ; # OF TOP-LEVEL LVALS
+NOWGVL: 0 ; # OF GVAL SLOTS
+CURGVL: 0 ; # OF GVALS
+NOWTYP: 0 ; SIZE OF TYPE-VECTOR
+CURTYP: 0 ; # OF TYPES
+NOWSTO: 0 ; SIZE OF STATIONARY STORAGE
+CURSTO: 0 ; STATIONARY STORAGE IN USE
+CURMAX: 0 ; MAXIMUM BLOCK OF CONTIGUOUS STORAGE
+NOWP: 0 ; SIZE OF P-STACK
+CURP: 0 ; #WORDS ON P
+CPMX: 0 ; MAXIMUM P-STACK LENGTH SO FAR
+GCCAUS: 0 ; INDICATOR FOR CAUSE OF GC
+GCCALL: 0 ; INDICATOR FOR CALLER OF GC
+
+
+; THIS GROUP OF VARIABLES DETERMINES HOW THINGS GROW
+LVLINC: 6 ; LVAL INCREMENT ASSUMED TO BE 64 SLOTS
+GVLINC: 4 ; GVAL INCREMENT ASSUMED TO BE 64 SLOTS
+TYPIC: 1 ; TYPE INCREMENT ASSUMED TO BE 32 TYPES
+STORIC: 2000 ; STORAGE INCREMENT USED BY NFREE (MINIMUM BLOCK-SIZE)
+
+
+RCL: 0 ; POINTER TO LIST OF RECYCLEABLE LIST CELLS
+RCLV: 0 ; POINTER TO RECYCLED VECTORS
+GCMONF: 0 ; NON-ZERO SAY GIN/GOUT
+GCDANG: 0 ; NON-ZERO, STORAGE IS LOW
+INBLOT: 0 ; INDICATE THAT WE ARE RUNNING OIN A BLOAT
+GETNUM: 0 ;NO OF WORDS TO GET
+RFRETP:
+RPTOP: 0 ;NO OF BLOCKS OF CORE, IF GIVING CORE AWAY
+CORTOP: 0 ;CURRENT TOP OF CORE, EXCLUDING ANY TO BE GIVEN AWAY
+NGCS: 8 ; NUMBER OF GARBAGE COLLECTS BETWEEN HAIRY GCS
+
+;VARIABLES WHICH DETERMIN WHEN MUDDLE WILL ASK FOR MORE CORE,
+;AND WHEN IT WILL GET UNHAPPY
+
+FREMIN: 20000 ;MINIMUM FREE WORDS
+
+;POINTER TO GROWING PDL
+
+TPGROW: 0 ;POINTS TO A BLOWN TP
+PPGROW: 0 ;POINTS TO A BLOWN PP
+PGROW: 0 ;POINTS TO A BLOWN P
+
+;IN GC FLAG
+
+GCFLG: 0
+GCFLCH: 0 ; TELL INT HANDLER TO ITIC CHARS
+GCHAIR: 1 ; COUNTS GCS AND TELLS WHEN TO HAIRIFY
+GCDOWN: 0 ; AMOUNT TO TRY AND MOVE DOWN
+CURPLN: 0 ; LENGTH OF CURRENTLY RUNNING PURE RSUBR
+PURMIN: 0 ; MINIMUM PURE STORAGE
+
+; VARS ASSOCIATED WITH BLOAT LOGIC
+PMIN: 200 ; MINIMUM FOR PSTACK
+PGOOD: 1000 ; GOOD SIZE FOR PSTACK
+PMAX: 4000 ; MAX SIZE FOR PSTACK
+TPMIN: 1000 ; MINIMUM SIZE FOR TP
+TPGOOD: NTPGOO ; GOOD SIZE OF TP
+TPMAX: NTPMAX ; MAX SIZE OF TP
+
+TPBINC: 0
+GLBINC: 0
+TYPINC: 0
+
+; VARS FOR PAGE WINDOW HACKS
+
+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
+FNTBOT: 0 ; BOTTOM OF FRONTEIR
+WNDBOT: 0 ; BOTTOM OF WINDOW
+WNDTOP: 0
+BOTNEW: (FPTR) ; POINTER TO FRONTIER
+GCTIM: 0
+NPARBO: 0 ; SAVED PARBOT
+
+; FLAGS TO INDICATE DUMPER IS IN USE
+
+GPURFL: 0 ; INDICATE PURIFIER IS RUNNING
+GCDFLG: 0 ; INDICATE EITHER GCDUMP OR PURIFIER IS RUNNING
+DUMFLG: 0 ; FLAG INDICATING DUMPER IS RUNNING
+
+; CONSTANTS FOR DUMPER,READER AND PURIFYER
+
+ABOTN: 0 ; COUNTER FOR ATOMS
+NABOTN: 0 ; POINTER USED BY PURIFY
+OGCSTP: 0 ; CONTAINS OLD GCSTOP FOR READER
+MAPUP: 0 ; BEGINNING OF MAPPED UP PURE STUFF
+SAVRES: 0 ; SAVED UPDATED ITEM OF PURIFIER
+SAVRE2: 0 ; SAVED TYPE WORD
+SAVRS1: 0 ; SAVED PTR TO OBJECT
+INF1: 0 ; AOBJN PTR USED IN CREATING PROTECTION INF
+INF2: 0 ; AOBJN PTR USED IN CREATING SECOND INF
+INF3: 0 ; AOBJN PTR USED TO PURIFY A STRUCTURE
+
+; VARIABLES USED BY GC INTERRUPT HANDLER
+
+GCHPN: 0 ; SET TO -1 EVERYTIME A GC HAS OCCURED
+GCKNUM: 0 ; NUMBER OF WORDS OF REQUEST TO INTERRUPT
+
+; VARIABLE TO INDICATE WHETHER AGC HAS PUSHED THE MAPPING CHANNEL TO WIN
+
+PSHGCF: 0
+
+; VARIABLES USED BY DUMPER AND READER TO HANDLE NEWTYPES
+
+TYPTAB: 0 ; POINTER TO TYPE TABLE
+NNPRI: 0 ; NUMPRI FROM DUMPED OBJECT
+NNSAT: 0 ; NUMSAT FROM DUMPED OBJECT
+TYPSAV: 0 ; SAVE PTR TO TYPE VECTOR
+
+; VARIABLES USED BY GC-DUMP FOR COPY-WRITE MAPPING
+
+BUFGC: 0 ; BUFFER FOR COPY ON WRITE HACKING
+PURMNG: 0 ; FLAG INDICATING IF A PURIFIED PAGE WAS MUNGED DURING GC-DUMP
+RPURBT: 0 ; SAVED VALUE OF PURTOP
+RGCSTP: 0 ; SAVED GCSTOP
+
+; VARIABLES USED TO DETERMINE WHERE THE GC-DUMPED STRUCTURE SHOULD GO
+
+INCORF: 0 ; INDICATION OF UVECTOR HACKS FOR GC-DUMP
+PURCOR: 0 ; INDICATION OF UVECTOR TO PURE CORE
+ ; ARE NOT GENERATED
+
+
+PLODR: 0 ; INDICATE A PLOAD IS IN OPERATION
+NPRFLG: 0
+
+; VARIABLE USED BY MARK SWEEP GARBAGE COLLECTOR
+
+MAXLEN: 0 ; MAXIMUM RECLAIMED SLOT
+
+PURE
+
+OFFSET OFFS
+
+CONSTANTS
+
+HERE
+
+CONSTANTS
+
+OFFSET 0
+
+ZZ==$.+1777
+
+.LOP ANDCM ZZ 1777
+
+ZZ1==.LVAL1
+
+LOC ZZ1
+
+
+OFFSET OFFS
+
+WIND: SPBLOK 2000
+FRONT: SPBLOK 2000
+MRKPD: SPBLOK 1777
+ENDPDL: -1
+
+MRKPDL=MRKPD-1
+
+ENDGC:
+
+OFFSET 0
+
+.LOP <ASH @> WIND <,-10.>
+WNDP==.LVAL1
+
+.LOP <ASH @> FRONT <,-10.>
+FRNP==.LVAL1
+
+ZZ2==ENDGC-AGCLD
+.LOP <ASH @> ZZ2 <,-10.>
+LENGC==.LVAL1
+
+.LOP <ASH @> LENGC <,10.>
+RLENGC==.LVAL1
+
+.LOP <ASH @> AGCLD <,-10.>
+PAGEGC==.LVAL1
+
+OFFSET 0
+
+LOC GCST
+.LPUR==$.
+
+END
+
--- /dev/null
+TITLE AGC MUDDLE GARBAGE COLLECTOR
+
+;SYSTEM WIDE DEFINITIONS GO HERE
+
+RELOCATABLE
+GCST==$.
+
+
+.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,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,GCOFFS
+.GLOBAL SPBASE,OUTRNG,CISTNG,CBYTES,%RUNAM,PURVEC,GCDOWN,N.CHNS,CHNL1,PLODR,MRKPDL
+.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 P.TOP,P.CORE,PMAPB,IGET,CIGTPR,ROOT,STBL,CAFREE,%MPIN1,%PURIF,%MPINX,GCHK10
+.GLOBAL %SAVRP,%RSTRP,LENGC,AGCLD,PAGEGC,REALGC,MARK
+.GLOBAL %MPINT,%GBINT,%CLSMP,%CLSM1,PINIT,PGFIND,NPRFLG,%PURMD
+.GLOBAL GCKNUM,CORTOP,GCHPN,INTAGC,WNDP,WNDBOT,BUFGC,WIND,GCDFLG,SAVM,AGC,GCSET
+
+.GLOBAL GCRET,PAIRMK,DEFMK,VECTMK,TBMK,TPMK,ARGMK,VECTMK,FRMK,BYTMK,ATOMK,GATOMK
+.GLOBAL BYTMK,ABMK,LOCRMK,GCRDMK,DEFQMK,ASMRK,LOCMK,OFFSMK,INBLOT,MARK2A
+
+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
+
+.ATOM.==200000 ; FLAG SAYING ATOMS MARKED (FOR VAL FLUSH LOGIC)
+
+GCHN==0 ; CHANNEL FOR FUNNNY INFERIOR
+STATNO==19. ; # OF STATISTICS FOR BLOAT-STAT
+STATGC==8. ; # OF GC-STATISTICS FOR BLOAT-STAT
+
+
+LOC REALGC
+OFFS==AGCLD-$.
+GCOFFS=OFFS
+OFFSET OFFS
+
+.INSRT MUDDLE >
+SYSQ
+IFE ITS,[
+.INSRT STENEX >
+]
+IFN ITS, PGSZ==10.
+IFE ITS, PGSZ==9.
+
+TYPNT=AB ;SPECIAL AC USAGE DURING GC
+F=TP ;ALSO SPECIAL DURING GC
+LPVP=SP ;SPECIAL FOR GC, HOLDS POINTER TO PROCESS CHAIN
+FPTR=TB ; POINT TO CURRENT FRONTIER OF INFERIOR
+
+
+; WINDOW AND FRONTIER PAGES
+
+MAPCH==0 ; MAPPING CHANNEL
+.LIST.==400000
+FPAG==2000 ; START OF PAGES FOR GC-READ AND GCDUMP
+CONADJ==5 ; ADJUSTMENT OF DUMPERS CONSTANT TABLE
+
+\f
+; INTERNAL GCDUMP ROUTINE
+.GLOBAL GODUMP,EGCDUM,EPURIF,ERRKIL,IPURIF
+
+GODUMP: MOVE PVP,PVSTOR+1
+ MOVEM P,PSTO+1(PVP) ; SAVE P
+ MOVE P,GCPDL
+ PUSH P,AB
+ PUSHJ P,INFSU1 ; SET UP INFERIORS
+
+; MARK PHASE
+ SETZM PURMNG ; INITIALIZE FLAG INDICATING IF PURIFIED PAGES
+ ; WERE MUNGED
+ MOVEI 0,HIBOT ; SET UP NEW PURBOT TO CONVINCE THE GARBAGE COLLECTOR
+ ; TO COLLECT PURIFIED STRUCTURES
+ EXCH 0,PURBOT
+ MOVEM 0,RPURBT ; SAVE THE OLD PURBOT
+ MOVEI 0,HIBOT
+ EXCH 0,GCSTOP
+ MOVEM 0,RGCSTP ; SAVE THE OLD GCSTOP
+ POP P,C ; SET UP PTR TO TYPE/VALUE PAIR
+ MOVE P,A ; GET NEW PDL PTR
+ SETOM DUMFLG ; FLAG INDICATING IN DUMPER
+ MOVE A,TYPVEC+1
+ MOVEM A,TYPSAV
+ ADD FPTR,[7,,7] ; ADJUST FOR FIRST STATUS WORDS
+ PUSHJ P,MARK2
+ MOVEI E,FPAG+6 ; SEND OUT PAIR
+ PUSH P,C ; SAVE C
+ MOVE C,A
+ PUSHJ P,ADWD
+ POP P,C ; RESTORE C
+ MOVEI E,FPAG+5
+ MOVE C,(C) ; SEND OUT UPDATED PTR
+ PUSHJ P,ADWD
+
+ MOVEI 0,@BOTNEW ; CALCULATE START OF TYPE-TABLE
+ MOVEM 0,TYPTAB
+ MOVE 0,RPURBT ; RESTORE PURBOT
+ MOVEM 0,PURBOT
+ MOVE 0,RGCSTP ; RESTORE GCSTOP
+ MOVEM 0,GCSTOP
+
+
+; ROUTINE TO SCAN THE TYPE-VECTOR FOR MARKED TYPE SLOTS AND BUILD A TYPE-TABLE OUT OF
+; THEM
+
+ MOVE A,TYPSAV ; GET AOBJN POINTER TO TYPE-VECTOR
+ MOVEI B,0 ; INITIALIZE TYPE COUNT
+TYPLP2: HLRE C,(A) ; GET MARKING
+ JUMPGE C,TYPLP1 ; IF NOT MARKED DON'T OUTPUT
+ MOVE C,(A) ; GET FIRST WORD
+ HRL C,B ; FIX UP SO TYPE-NUMBER REPLACES TYPE-CELL
+ PUSH P,A
+ SKIPL FPTR
+ PUSHJ P,MOVFNT
+ MOVEM C,FRONT(FPTR)
+ AOBJN FPTR,.+2
+ PUSHJ P,MOVFNT ; EXTEND THE FRONTIER
+ POP P,A
+ MOVE C,1(A) ; OUTPUT SECOND WORD
+ MOVEM C,FRONT(FPTR)
+ ADD FPTR,[1,,1]
+TYPLP1: ADDI B,1 ; INCREMENT TYPE COUNT
+ ADD A,[2,,2] ; POINT TO NEXT SLOT
+ JUMPL A,TYPLP2 ; LOOP
+
+; ROUTINE TO BUILD UP ATOM TABLE USING LPVP CHAIN
+
+ HRRZ F,ABOTN
+ MOVEI 0,@BOTNEW ; GET CURRENT BEGINNING OF TRANSFER
+ MOVEM 0,ABOTN ; SAVE IT
+ PUSHJ P,ALLOGC ; ALLOCATE ROOM FOR ATOMS
+ MOVSI D,400000 ; SET UP UNMARK BIT
+SPOUT: JUMPE LPVP,DPGC4 ; END OF CHAIN
+ MOVEI F,(LPVP) ; GET COPY OF LPVP
+ HRRZ LPVP,-1(LPVP) ; LPVP POINTS TO NEXT ON CHAIN
+ ANDCAM D,(F) ; UNMARK IT
+ HLRZ C,(F) ; GET LENGTH
+ HRRZ E,(F) ; POINTER INTO INF
+ ADD E,ABOTN
+ SUBI C,2 ; WE'RE NOT SENDING OUT THE VALUE PAIR
+ HRLM C,(F) ; ADJUSTED LENGTH
+ MOVE 0,C ; COPY C FOR TRBLKX
+ SUBI E,(C) ; ADJUST PTRS FOR SENDOUT\r
+ SUBI F,-1(C)
+ PUSHJ P,TRBLKX ; OUT IT GOES
+ JRST SPOUT
+
+
+; HERE TO SEND OUT DELIMITER INFORMATION
+DPGC4: SKIPN INCORF ; SKIP IF TRANSFREING TO UVECTOR IN CORE
+ JRST CONSTO
+ SKIPL FPTR ; SEE IF ROOM IN FRONTEIR
+ PUSHJ P,MOVFNT ; EXTEND FRONTEIR
+ MOVSI A,.VECT.
+ MOVEM A,FRONT(FPTR)
+ AOBJN FPTR,.+2
+ PUSHJ P,MOVFNT
+ MOVEI A,@BOTNEW ; LENGTH
+ SUBI A,FPAG
+ HRLM A,FRONT(FPTR)
+ ADD FPTR,[1,,1]
+
+
+CONSTO: MOVEI E,FPAG
+ MOVE C,ABOTN ; START OF ATOMS
+ SUBI C,FPAG+CONADJ ; ADJUSTMENT FOR STARTING ON PAGE ONE
+ PUSHJ P,ADWD ; OUT IT GOES
+ MOVEI E,FPAG+1
+ MOVEI C,@BOTNEW
+ SUBI C,FPAG+CONADJ
+ SKIPE INCORF ; SKIP IF TO CHANNEL
+ SUBI C,2 ; SUBTRACT FOR DOPE WORDS
+ PUSHJ P,ADWD
+ SKIPE INCORF
+ ADDI C,2 ; RESTORE C TO REAL ABOTN
+ ADDI C,CONADJ
+ PUSH P,C
+ MOVE C,TYPTAB
+ SUBI C,FPAG+CONADJ
+ MOVEI E,FPAG+2 ; SEND OUT START OF TYPE TABLE
+ PUSHJ P,ADWD
+ ADDI E,1 ; SEND OUT NUMPRI
+ MOVEI C,NUMPRI
+ PUSHJ P,ADWD
+ ADDI E,1 ; SEND OUT NUMSAT
+ MOVEI C,NUMSAT
+ PUSHJ P,ADWD
+
+
+
+; FINAL CLOSING OF INFERIORS
+
+DPCLS: PUSH P,PGCNT
+ PUSHJ P,INFCL1
+ POP P,PGCNT
+ POP P,A ; LENGTH OF CODE
+
+; RESTORE AC'S
+ MOVE PVP,PVSTOR+1
+ IRP AC,,[P,TP,TB,AB,FRM]
+ MOVE AC,AC!STO+1(PVP)
+ TERMIN
+
+ SETZB M,R
+ SETZM DUMFLG
+ SETZM GCDFLG ; ZERO FLAG INDICATING IN DUMPER
+ SETZM GCFLG ; AND INDICTOR TO INTERRUPT HANDLER THAT AGC IS ON
+ PUSH P,A
+ MOVE A,INF2 ; GET POINTER TO PURE MAPPED OUT
+ PUSHJ P,%GBINT
+
+ POP P,A
+ JRST EGCDUM
+
+
+ERDP: PUSH P,B
+ PUSHJ P,INFCLS
+ PUSHJ P,INFCL1
+ SETZM GCFLG
+ SETZM GPURFL ; PURE FLAG
+ SETZM DUMFLG
+ SETZM GCDFLG
+ POP P,A
+
+; RESTORE AC'S
+ MOVE PVP,PVSTOR+1
+ IRP AC,,[P,R,M,TP,TB,AB,FRM]
+ MOVE AC,AC!STO+1(PVP)
+ TERMIN
+
+ERDUMP: PUSH TP,$TATOM
+
+OFFSET 0
+
+ PUSH TP,EQUOTE STRUCTURE-CONTAINS-UNDUMPABLE-TYPE
+
+OFFSET OFFS
+
+ PUSH TP,$TATOM ; PUSH ON PRIMTYPE
+ PUSH TP,@STBL(A) ; PUSH ON PRIMTYPE
+ MOVEI A,2
+ JRST ERRKIL
+
+; ALTERNATE ATOM MARKER FOR DUMPER
+
+DATOMK: SKIPE GPURFL ; SKIP IF NOT IN PURIFIER
+ JRST PATOMK
+ CAILE A,0 ; SEE IF ALREADY MARKED
+ JRST GCRET
+ PUSH P,A ; SAVE PTR TO ATOM
+ HLRE B,A ; POINT TO DOPE WORD
+ SUB A,B ; TO FIRST DOPE WORD
+ MOVEI A,1(A) ; TO SECOND
+ PUSH P,A ; SAVE PTR TO DOPE WORD
+ HLRZ B,(A) ; GET LENGTH AND MARKING
+ TRZE B,400000 ; TURN OFF BIT AND SKIP IF UNMARKED
+ JRST DATMK1
+ IORM D,(A) ; MARK IT
+ MOVE 0,ABOTN ; GET CURRENT TOP OF ATOM TABLE
+ ADDI 0,-2(B) ; PLACE OF DOPE WORD IN TABLE
+ HRRM 0,(A) ; PUT IN RELOCATION
+ MOVEM 0,ABOTN ; FIXUP TOP OF TABLE
+ HRRM LPVP,-1(A) ; FIXUP CHAIN
+ MOVEI LPVP,(A)
+ MOVE A,-1(P) ; GET POINTER TO ATOM BACK
+ HRRZ B,2(A) ; GET OBLIST POINTER
+ JUMPE B,NOOB ; IF ZERO ON NO OBLIST
+ CAMG B,VECBOT ; DON'T SKIP IF OFFSET FROM TVP
+ MOVE B,(B)
+ HRLI B,-1
+DATMK3: MOVE A,$TOBLS ; SET UP FOR GET
+ MOVE C,$TATOM
+
+OFFSET 0
+ MOVE D,IMQUOTE OBLIST
+
+OFFSET OFFS
+
+ PUSH P,TP ; SAVE FPTR
+ MOVE TP,MAINPR
+ MOVE TP,TPSTO+1(TP) ; GET TP
+ PUSHJ P,IGET
+ POP P,TP ; RESTORE FPTR
+ MOVE C,-1(P) ; RECOVER PTR TO ATOM
+ ADDI C,1 ; SET UP TO MARK OBLIST ATOM
+ MOVSI D,400000 ; RESTORE MARK WORD
+
+OFFSET 0
+
+ CAMN B,MQUOTE ROOT
+
+OFFSET OFFS
+
+ JRST RTSET
+ MOVEM B,1(C)
+ MOVEI B,TATOM
+ PUSHJ P,MARK1 ; MARK IT
+ MOVEM A,1(C) ; SMASH IN ITS ID
+DATMK1:
+NOOB: POP P,A ; GET PTR TO DOPE WORD BACK
+ HRRZ A,(A) ; RETURN ID
+ SUB P,[1,,1] ; CLEAN OFF STACK
+ MOVEM A,(P)
+ JRST GCRET ; EXIT
+
+; HERE FOR A ROOT ATOM
+RTSET: SETOM 1(C) ; INDICATOR OF ROOT ATOM
+ JRST NOOB ; CONTINUE
+
+\f
+; INTERNAL PURIFY ROUTINE
+; SAVE AC's
+
+IPURIF: PUSHJ P,PURCLN ; GET RID OF PURE MAPPED
+ MOVE PVP,PVSTOR+1
+ IRP AC,,[P,R,M,TP,TB,AB,FRM]
+ MOVEM AC,AC!STO"+1(PVP)
+ TERMIN
+
+
+; HERE TO CREATE INFERIORS AND MARK THE ITEM
+PURIT1: MOVE PVP,PVSTOR+1
+ MOVEM P,PSTO+1(PVP) ; SAVE P
+ SETOM GPURFL ; INDICATE PURIFICATION IS TAKING PLACE
+ MOVE C,AB ; ARG PAIR
+ MOVEM C,SAVRS1 ; SAV PTR TO PAIR
+ MOVE P,GCPDL
+ PUSHJ P,INFSUP ; GET INFERIORS
+ MOVE P,A ; GET NEW PDL PTR
+ PUSHJ P,%SAVRP ; SAVE RPMAP TABLE FOR TENEX
+ MOVE C,SAVRS1 ; SET UP FOR MARKING
+ MOVE A,(C) ; GET TYPE WORD
+ MOVEM A,SAVRE2
+PURIT3: PUSH P,C
+ PUSHJ P,MARK2
+PURIT4: POP P,C ; RESTORE C
+ ADD C,[2,,2] ; TO NEXT ARG
+ JUMPL C,PURIT3
+ MOVEM A,SAVRES ; SAVE UPDATED POINTER
+
+; FIX UP IMPURE PART OF ATOM CHAIN
+
+ PUSH P,[0] ; FLAG INDICATING NON PURE SCAN
+ PUSHJ P,FIXATM
+ SUB P,[1,,1] ; CLEAN OFF STACK
+
+; NOW TO GET PURE STORAGE
+
+PURIT2: MOVEI A,@BOTNEW ; GET BOTNEW
+ SUBI A,2000-1777 ; START AT PAGE 1 AND ROUND
+ ANDCMI A,1777
+ ASH A,-10. ; TO PAGES
+ SETZ M,
+ PUSH P,A
+ PUSHJ P,PGFIND ; FIND THEM
+ JUMPL B,LOSLP2 ; LOST GO TO CAUSE AGC
+ HRRZ 0,BUFGC ;GET BUFFER PAGE
+ ASH 0,-10.
+ MOVEI A,(B) ; GET LOWER PORTION OF PAGES
+ MOVN C,(P)
+ SUBM A,C ; GET END PAGE
+ CAIL 0,(A) ; L? LOWER
+ CAILE 0,(C) ; G? HIGER
+ JRST NOREMP ; DON'T GET NEW BUFFER
+ PUSHJ P,%FDBUF ; GET A NEW BUFFER PAGE
+NOREMP: MOVN A,(P) ; SET UP AOBJN PTR FOR MAPIN
+ MOVE C,B ; SAVE B
+ HRL B,A
+ HRLZS A
+ ADDI A,1
+ MOVEM B,INF3 ; SAVE PTR FOR PURIFICATION
+ PUSHJ P,%MPIN1 ; MAP IT INTO PURE
+ ASH C,10. ; TO WORDS
+ MOVEM C,MAPUP
+ SUB P,[1,,1] ; CLEAN OFF STACK
+
+DONMAP:
+; RESTORE AC's
+ MOVE PVP,PVSTOR+1
+ MOVE P,PSTO+1(PVP) ; GET REAL P
+ PUSH P,LPVP
+ MOVEI A,@BOTNEW
+ MOVEM A,NABOTN
+
+ IRP AC,,[M,TP,TB,R,FRM]
+ MOVE AC,AC!STO+1(PVP)
+ TERMIN
+ MOVE A,INF1
+
+; NOW FIX UP POINTERS IN PURE STRUCTURE
+ MOVE 0,GCSBOT
+ MOVEM 0,OGCSTP
+ PUSH P,GCSBOT ; SAVE GCSBOT AND GCSTOP
+ PUSH P,GCSTOP
+ MOVE A,MAPUP ; NEW GCSBOT AND TOP TO FOOL GCHACK
+ MOVEM A,GCSBOT
+ ADD A,NABOTN
+ SUBI A,2000 ; ADJUSTMENT FOR START ON PAGE ONE
+ MOVEM A,GCSTOP
+ MOVE A,[PUSHJ P,NPRFIX]
+ MOVEI PVP,0 ; SAY MIGHT BE NON-ATOMS
+ PUSHJ P,GCHK10
+ POP P,GCSTOP
+ POP P,GCSBOT
+
+; NOW FIX UP POINTERS TO PURIFIED STRUCTURE
+
+ MOVE A,[PUSHJ P,PURFIX]
+ MOVEI PVP,0 ; SAY MIGHT BE NON-ATOMS
+ PUSHJ P,GCHACK
+
+ SETZM GCDFLG
+ SETZM DUMFLG
+ SETZM GCFLG
+
+ POP P,LPVP ; GET BACK LPVP
+ MOVE A,INF1
+ PUSHJ P,%KILJB ; KILL IMAGE SAVING INFERIOR
+ PUSH P,[-1] ; INDICATION OF PURE ATOM SCAN
+ PUSHJ P,FIXATM
+
+; SET UP PMAP SO THAT NEW PURE PAGES ARE INDICATED
+
+ MOVE A,INF3 ; GET AOBJN PTR TO PAGES
+FIXPMP: HRRZ B,A ; GET A PAGE
+ IDIVI B,16. ; DIVIDE SO AS TO PT TO PMAP WORD
+ PUSHJ P,PINIT ; SET UP PARAMETER
+ LSH D,-1
+ TDO E,D ; FIX UP WORD
+ MOVEM E,PMAPB(B) ; SEND IT BACK
+ AOBJN A,FIXPMP
+
+ SUB P,[1,,1]
+ MOVE A,[PUSHJ P,PURTFX] ; FIX UP PURE ATOM POINTERS
+ MOVEI PVP,1 ; SAY MIGHT BE NON-ATOMS
+ PUSHJ P,GCHACK
+
+; NOW FIX UP POINTERS IN PURE STRUCTURE
+ PUSH P,GCSBOT ; SAVE GCSBOT AND GCSTOP
+ PUSH P,GCSTOP
+ MOVE A,MAPUP ; NEW GCSBOT AND TOP TO FOOL GCHACK
+ MOVEM A,GCSBOT
+ ADD A,NABOTN
+ SUBI A,2000 ; ADJUSTMENT FOR START ON PAGE ONE
+ MOVEM A,GCSTOP
+ MOVE A,[PUSHJ P,PURTFX]
+ MOVEI PVP,1 ; SAY MIGHT BE NON-ATOMS
+ PUSHJ P,GCHK10
+ POP P,GCSTOP
+ POP P,GCSBOT
+
+; HERE TO FIX UP ATOMS WITH TYPES HACKED INTO THEIR GROWTH FIELD
+
+ MOVE A,TYPVEC+1 ; GET TYPE VECTOR
+ MOVEI B,400000 ; TLOSE==0
+TTFIX: HRRZ D,1(A) ; GET ADDR
+ HLRE C,1(A)
+ SUB D,C
+ HRRM B,(D) ; SMASH IT IN
+NOTFIX: ADDI B,1 ; NEXT TYPE
+ ADD A,[2,,2]
+ JUMPL A,TTFIX
+
+; NOW CLOSE UP INFERIORS AND RETURN
+
+PURCLS: MOVE P,[-2000,,MRKPDL]
+ PUSHJ P,%RSTRP ;RESETORE RPMAP TABLE FOR TENEX
+ PUSHJ P,INFCLS
+
+ MOVE PVP,PVSTOR+1
+ MOVE P,PSTO+1(PVP) ; RESTORE P
+ MOVE AB,ABSTO+1(PVP) ; RESTORE R
+
+ MOVE A,INF3 ; GET PTR TO PURIFIED STRUCTURE
+ SKIPN NPRFLG
+ PUSHJ P,%PURIF ; PURIFY
+ PUSHJ P,%PURMD
+
+ SETZM GPURFL
+ JRST EPURIF ; FINISH UP
+
+NPRFIX: PUSH P,A
+ PUSH P,B
+ PUSH P,C
+ EXCH A,C
+ PUSHJ P,SAT ; GET STORAGE ALLOCATION TYPE
+ MOVE C,MAPUP ; FIXUP AMOUNT
+ SUBI C,FPAG ; ADJUST FOR START ON FIRST PAGE
+ CAIE A,SLOCR ; DONT HACK TLOCRS
+ CAIN A,S1WORD ; SKIP IF NOT OF PRIMTYPE WORD
+ JRST LSTFXP
+ CAIN A,SCHSTR
+ JRST STRFXP
+ CAIN A,SATOM
+ JRST ATMFXP
+ CAIN A,SOFFS
+ JRST OFFFXP ; FIXUP OFFSETS
+STRFXQ: HRRZ D,1(B)
+ JUMPE D,LSTFXP ; SKIP IF NIL
+ CAMG D,PURTOP ; SEE IF ALREADY PURE
+ ADDM C,1(B)
+LSTFXP: TLNN B,.LIST. ; SKIP IF NOT A PAIR
+ JRST LSTEX1
+ HRRZ D,(B) ; GET REST OF LIST
+ SKIPE D ; SKIP IF POINTS TO NIL
+ PUSHJ P,RLISTQ
+ JRST LSTEX1
+ CAMG D,PURTOP ; SKIP IF ALREADY PURE
+ ADDM C,(B) ; FIX UP LIST
+LSTEX1: POP P,C
+ POP P,B ; RESTORE GCHACK AC'S
+ POP P,A
+ POPJ P,
+
+OFFFXP: HLRZ 0,D ; POINT TO LIST
+ JUMPE 0,LSTFXP ; POINTS TO NIL
+ CAML 0,PURTOP ; ALREADY PURE?
+ JRST LSTFXP ; YES
+ ADD 0,C ; UPDATE THE POINTER
+ HRLM 0,1(B) ; STUFF IT OUT
+ JRST LSTFXP ; DONE
+
+STRFXP: TLZN D,STATM ; SKIP IF REALLY ATOM
+ JRST STRFXQ
+ MOVEM D,1(B)
+ PUSH P,C
+ MOVE C,B ; GET ARG FOR BYTDOP
+ PUSHJ P,BYTDOP
+ POP P,C
+ MOVEI D,-1(A)
+ JRST ATMFXQ
+
+ATMFXP: HLRE 0,D ; GET LENGTH
+ SUB D,0 ; POINT TO FIRST DOPE WORD
+ HRRZS D
+ATMFXQ: CAML D,OGCSTP
+ CAIL D,HIBOT ; SKIP IF IMPURE
+ JRST LSTFXP
+ HRRZ 0,1(D) ; GET RELOCATION
+ SUBI 0,1(D)
+ ADDM 0,1(B) ; FIX UP PTR IN STRUCTURE
+ JRST LSTFXP
+
+; FIXUP OF PURE ATOM POINTERS
+
+PURTFX: CAIE C,TATOM ; SKIP IF ATOM POINTER
+ JRST PURSFX
+ HLRE E,D ; GET TO DOPE WORD
+ SUBM D,E
+PURSF1: SKIPL 1(E) ; SKIP IF MARKED
+ POPJ P,
+ HRRZ 0,1(E) ; RELATAVIZE PTR
+ SUBI 0,1(E)
+ ADD D,0 ; FIX UP PASSED POINTER
+ SKIPE B ; AND IF APPROPRIATE MUNG POINTER
+ ADDM 0,1(B) ; FIX UP POINTER
+ POPJ P,
+
+PURSFX: CAIE C,TCHSTR
+ POPJ P,
+ MOVE C,B ; GET ARG FOR BYTDOP
+ PUSHJ P,BYTDOP
+ GETYP 0,-1(A)
+ MOVEI E,-1(A)
+ MOVE A,[PUSHJ P,PURTFX]
+ CAIE 0,SATOM
+ POPJ P,
+ JRST PURSF1
+
+PURFIX: PUSH P,D
+ PUSH P,A
+ PUSH P,B
+ PUSH P,C ; SAVE AC'S FOR GCHACK
+ EXCH A,C ; GET TYPE IN A
+ CAIN A,TATOM ; CHECK FOR ATOM
+ JRST ATPFX
+ PUSHJ P,SAT
+
+ CAILE A,NUMSAT ; SKIP IF TEMPLATE
+ JRST TLFX
+IFN ITS, JRST @PURDSP(A)
+IFE ITS,[
+ HRRZ 0,PURDSP(A)
+ HRLI 0,400000
+ JRST @0
+]
+PURDSP:
+
+OFFSET 0
+
+DISTBS DUM1,TLFX,[[S2WORD,LPLSTF],[S2DEFR,LPLSTF],[SNWORD,VECFX],
+[S2NWORD,VECFX],[SSTORE,VECFX],[SBYTE,STRFX],[SATOM,ATPFX],[SLOCB,STRFX]
+[SCHSTR,STRFX],[SLOCL,LPLSTF],[SLOCV,VECFX],[SLOCU,VECFX],[SLOCS,VECFX],[SOFFS,OFFSFX]]
+
+OFFSET OFFS
+
+VECFX: HLRE 0,D ; GET LENGTH
+ SUB D,0 ; POINT TO D.W.
+ SKIPL 1(D) ; SKIP IF MARKED
+ JRST TLFX
+ HRRZ C,1(D)
+ SUBI C,1(D) ; CALCULATE RELOCATION
+ ADD C,MAPUP ; ADJUSTMENT
+ SUBI C,FPAG
+ ADDM C,1(B)
+TLFX: TLNN B,.LIST. ; SEE IF PAIR
+ JRST LVPUR ; LEAVE IF NOT
+ PUSHJ P,RLISTQ
+ JRST LVPUR
+ HRRZ D,(B) ; GET CDR
+ SKIPN D ; SKIP IF NOT ZERO
+ JRST LVPUR
+ MOVE D,(D) ; GET CADR
+ SKIPL D ; SKIP IF MARKED
+ JRST LVPUR
+ ADD D,MAPUP
+ SUBI D,FPAG
+ HRRM D,(B) ; FIX UP
+LVPUR: POP P,C
+ POP P,B
+ POP P,A
+ POP P,D
+ POPJ P,
+
+STRFX: MOVE C,B ; GET ARG FOR BYTDOP
+ PUSHJ P,BYTDOP
+ SKIPL (A) ; SKIP IF MARKED
+ JRST TLFX
+ GETYP 0,-1(A)
+ MOVE D,1(B)
+ MOVEI C,-1(A)
+ CAIN 0,SATOM ; REALLY ATOM?
+ JRST ATPFX1
+ HRRZ 0,(A) ; GET PTR IN NEW STRUCTURE
+ SUBI 0,(A) ; RELATAVIZE
+ ADD 0,MAPUP ; ADJUST
+ SUBI 0,FPAG
+ ADDM 0,1(B) ; FIX UP PTR
+ JRST TLFX
+
+ATPFX: HLRE C,D
+ SUBM D,C
+ SKIPL 1(C) ; SKIP IF MARKED
+ JRST TLFX
+ATPFX1: HRRZS C ; SEE IF PURE
+ CAIL C,HIBOT ; SKIP IF NOT PURE
+ JRST TLFX
+ HRRZ 0,1(C) ; GET PTR TO NEW ATOM
+ SUBI 0,1(C) ; RELATAVIZE
+ ADD D,0
+ JUMPE B,TLFX
+ ADDM 0,1(B) ; FIX UP
+ JRST TLFX
+
+LPLSTF: SKIPN D ; SKIP IF NOT PTR TO NIL
+ JRST TLFX
+ SKIPL (D) ; SKIP IF MARKED
+ JRST TLFX
+ HRRZ D,(D) ; GET UPDATED POINTER
+ ADD D,MAPUP ; ADJUSTMENT
+ SUBI D,FPAG
+ HRRM D,1(B)
+ JRST TLFX
+
+OFFSFX: HLRZS D ; LIST POINTER
+ JUMPE D,TLFX ; NIL
+ SKIPL (D) ; MARKED?
+ JRST TLFX ; NO
+ ADD D,MAPUP
+ SUBI D,FPAG ; ADJUST
+ HRLM D,1(B)
+ JRST TLFX ; RETURN
+
+; ROUTINES TO CAUSE A GARBAGE COLLECT WHEN EFFORTS TO GET STORAGE FAIL
+
+LOSLP1: MOVE A,ABOTN
+ MOVEM A,PARNEW ; SET UP GC PARAMS
+ MOVE C,[12.,,6]
+ JRST PURLOS
+
+LOSLP2: MOVEI A,@BOTNEW ; TOTAL AMOUNT NEEDED
+ ADDI A,1777
+ ANDCMI A,1777 ; CALCULATE PURE PAGES NEEDED
+ MOVEM A,GCDOWN
+ MOVE C,[12.,,8.]
+ JRST PURLOS
+
+PURLOS: MOVE P,[-2000,,MRKPDL]
+ PUSH P,GCDOWN
+ PUSH P,PARNEW
+ MOVE R,C ; GET A COPY OF A
+ PUSHJ P,INFCLS ; CLOSE INFERIORS AND FIX UP WORLD
+ PUSHJ P,INFCL2
+PURLS1: POP P,PARNEW
+ POP P,GCDOWN
+ MOVE C,R
+
+; RESTORE AC'S
+ MOVE PVP,PVSTOR+1
+ IRP AC,,[P,R,M,TP,TB,AB,FRM]
+ MOVE AC,AC!STO+1(PVP)
+ TERMIN
+
+ SETZM GCDFLG ; ZERO OUT FLAGS
+ SETZM DUMFLG
+ SETZM GPURFL
+ SETZM GCDANG
+
+ PUSHJ P,AGC ; GARBAGE COLLECT
+ JRST PURIT1 ; TRY AGAIN
+
+; PURIFIER ATOM MARKER
+
+PATOMK: HRRZ 0,A
+ CAMG 0,PARBOT
+ JRST GCRET ; DONE IF FROZEN
+ HLRE B,A ; GET TO D.W.
+ SUB A,B
+ SKIPG 1(A) ; SKIP IF NOT MARKED
+ JRST GCRET
+ HLRZ B,1(A)
+ IORM D,1(A) ; MARK THE ATOM
+ ADDM B,ABOTN
+ HRRM LPVP,(A) ; LINK ONTO CHAIN
+ MOVEI LPVP,1(A)
+ JRST GCRET ; EXIT
+
+\f
+.GLOBAL %LDRDO,%MPRDO
+
+; ROUTINES TO ALLOW GC-DUMPING OF PURIFIED STRUCTURES.
+
+; PROPUR MAPS PAGES CONTAINING PURIFIED STUFF INTO THE AGD INFERIOR SO THAT IN CASE
+; THE PAGES ARE MUNGED THEY CAN BE RESTORED USING MAPPING
+
+; REPURE REMAPS ANY PAGES THAT WERE MUNGED BY GC-DUMP BY RELOADING THEM FROM THE AGD
+; INFERIOR IN READ/EXEC MODE
+
+REPURE: PUSH P,[PUSHJ P,%LDRDO] ; INSTRUCTION FOR MAPPING IN PAGES FROM AGD INF
+ SKIPA
+PROPUR: PUSH P,[PUSHJ P,%MPRDO] ; INSTRUCTION FOR MAPPING PAGES TO AGD INF
+ MOVE A,PURBOT ; GET STARTING PAGE OF PURENESS
+ ASH A,-10. ; CONVERT TO PAGES
+ MOVEI C,HIBOT ; GET ENDING PAGE
+ ASH C,-10. ; CONVERT TO PAGES
+ PUSH P,A ; SAVE PAGE POINTER
+ PUSH P,C ; SAVE END OF PURENESS POINTER
+PROLOP: CAML A,(P) ; SKIP IF STILL PURE PAGES TO CHECK
+ JRST PRODON ; DONE MAPPING PAGES
+ PUSHJ P,CHKPGI ; SKIP IF PAGE IS PURE
+ JRST NOTPUR ; IT IS NOT
+ MOVE A,-1(P) ; GET PAGE TO MAP
+ XCT -2(P) ; MAP IN/OUT TO AGD INFERIOR IN READ/EXEC MODE
+NOTPUR: AOS A,-1(P) ; INCREMENT PAGE POINTER AND LOAD
+ JRST PROLOP ; LOOP BACK
+PRODON: SUB P,[3,,3] ; CLEAN OFF STACK
+ POPJ P, ; EXIT
+
+
+\f
+.GLOBAL %SAVIN,STOSTR,%CLMP1,%IMSAV,%IMSV1,ILOOKC,PSHGCF,BSETG,%GCJB1
+.GLOBAL %CLSJB,%KILJB,%IFMP1,%OPGFX,%FDBUF
+INFSU1: PUSH P,[-1] ; ENTRY USED BY GC-DUMP
+ SKIPA
+INFSUP: PUSH P,[0]
+ MOVE A,GLOTOP+1 ; GET GLOTOP FOR LOCR HACKS
+ MOVEM A,GLTOP
+ PUSHJ P,%FDBUF ; GET A BUFFER FOR C/W HACKS
+ SETOM GCDFLG
+ SETOM GCFLG
+ HLLZS SQUPNT
+ HRRZ TYPNT,TYPVEC+1 ; SETUP TYPNT
+ HRLI TYPNT,B
+ MOVEI A,STOSTR
+ ANDCMI A,1777 ; TO PAGE BOUNDRY
+ SUB A,GCSTOP ; SET UP AOBJN POINTER FOR C/W HACK
+ ASH A,-10. ; TO PAGES
+ HRLZS A
+ MOVEI B,STOSTR ; GET START OF MAPPING
+ ASH B,-10.
+ ADDI A,(B)
+ MOVEM A,INF1
+ PUSHJ P,%SAVIN ; PROTECT THE CORE IMAGE
+ SKIPGE (P) ; IF < 0 GC-DUMP CALL
+ PUSHJ P,PROPUR ; PROTECT PURE PAGES
+ SUB P,[1,,1] ; CLEAN OFF PSTACK
+ PUSHJ P,%CLSJB ; CLOSE INFERIOR
+
+ MOVSI D,400000 ; CREATE MARK WORD
+ SETZB LPVP,ABOTN ; ZERO ATOM COUNTER
+ MOVEI A,2000 ; MARKED INF STARTS AT PAGE ONE
+ HRRM A,BOTNEW
+ SETZM WNDBOT
+ SETZM WNDTOP
+ HRRZM A,FNTBOT
+ ADDI A,2000 ; WNDTOP
+ MOVEI A,1 ; TO PAGES
+ PUSHJ P,%GCJB1 ; CREATE THE JOB
+ MOVSI FPTR,-2000
+ MOVEI A,LPUR ; SAVE THE PURE CORE IMAGE
+ ANDCMI A,1777 ; TO PAGE BOUNDRY
+ MOVE 0,A ; COPY TO 0
+ ASH 0,-10. ; TO PAGES
+ SUB A,HITOP ; SUBTRACT TOP OF CORE
+ ASH A,-10.
+ HRLZS A
+ ADD A,0
+ MOVEM A,INF2
+ PUSHJ P,%IMSV1 ; MAP OUT INTERPRETER
+ PUSHJ P,%OPGFX
+
+; CREATE A PDL TO USE FOR THESE DUMPING FUNCTIONS
+
+ MOVE A,[-2000,,MRKPDL]
+ POPJ P,
+
+; ROUTINE TO CLOSE GC's INFERIOR
+
+
+INFCLS: MOVE A,INF2 ; GET POINTER TO PURE MAPPED OUT
+ PUSHJ P,%CLSMP
+ POPJ P,
+
+; CLOSE INFERIOR PROTECTING CORE IMAGE FOR GCDUMP
+
+INFCL2: PUSHJ P,%IFMP1 ; OPEN AGD INF TO RESTORE PAGES
+INFCL3: MOVE A,INF1 ; RESTORE OPENING POINTER
+ PUSH P,INF2
+ MOVE B,A ; SATIFY MUDITS
+ PUSHJ P,%IFMP2 ; MAP IN GC PAGES AND CLOSE INFERIOR
+ POP P,INF2 ; RESTOR INF2 PARAMETER
+ POPJ P,
+
+INFCL1: PUSHJ P,%IFMP1 ; OPEN AGD INF TO RESTORE PAGES
+ SKIPGE PURMNG ; SKIP IF NO PURE PAGES WERE MUNGED
+ PUSHJ P,REPURE ; REPURIFY MUNGED PAGES
+ JRST INFCL3
+
+\f
+
+; ROUTINE TO DO TYPE HACKING FOR GC-DUMP. IT MARKS THE TYPE-WORD OF THE
+; SLOT IN THE TYPE VECTOR. IT ALSO MARKS THE ATOM REPLACING THE I.D. IN
+; THE RIGHT HALF OF THE ATOM SLOT. IF THE TYPE IS A TEMPLATE THE FIRST
+; USE OF THE SAT HAS ITS ATOM MARKED AND THE I.D. IS PLACED IN THE LEFT
+; HALF OF THE ATOM SLOT (IT GETS THE REAL PRIMTYPE).
+
+TYPHK: CAILE B,NUMPRI ; SKIP IF A MUDDLE TYPE
+ JRST TYPHKR ; ITS A NEWTYPE SO GO TO TYPHACKER
+ CAIN B,TTYPEC ; SKIP IF NOT TYPE-C
+ JRST TYPCHK ; GO TO HACK TYPE-C
+ CAIE B,TTYPEW ; SKIP IF TYPE-W
+ POPJ P,
+ PUSH P,B
+ HLRZ B,A ; GET TYPE
+ JRST TYPHKA ; GO TO TYPE-HACKER
+TYPCHK: PUSH P,B ; SAVE TYPE-WORD
+ HRRZ B,A
+ JRST TYPHKA
+
+; GENERAL TYPE-HACKER FOR GC-DUMP
+
+TYPHKR: PUSH P,B ; SAVE AC'S
+TYPHKA: PUSH P,A
+ PUSH P,C
+ LSH B,1 ; GET OFFSET TO SLOT IN TYPE VECTOR
+ MOVEI C,(TYPNT) ; GET TO SLOT
+ ADDI C,(B)
+ SKIPGE (C)
+ JRST EXTYP
+ IORM D,(C) ; MARK THE SLOT
+ MOVEI B,TATOM ; NOW MARK THE ATOM SLOT
+ PUSHJ P,MARK1 ; MARK IT
+ HRRM A,1(C) ; SMASH IN ID
+ HRRZS 1(C) ; MAKE SURE THAT THATS ALL THATS THERE
+ HRRZ B,(C) ; GET SAT
+ ANDI B,SATMSK ; GET RID OF MAGIC BITS
+ HRRM B,(C) ; SMASH SAT BACK IN
+ CAIG B,NUMSAT ; SKIP IF TEMPLATE
+ JRST EXTYP
+ MOVE A,TYPSAV ; GET POINTER TO TYPE VECTOR
+ ADDI A,NUMPRI*2 ; GET TO NEWTYPES SLOTS
+ HRLI 0,NUMPRI*2
+ HLLZS 0 ; MAKE SURE ONLY LEFT HALF
+ ADD A,0
+TYPHK1: HRRZ E,(A) ; GET SAT OF SLOT
+ CAMN E,B ; SKIP IF NOT EQUAL
+ JRST TYPHK2 ; GOT IT
+ ADDI A,2 ; TO NEXT
+ JRST TYPHK1
+TYPHK2: PUSH P,C ; SAVE POINTER TO ORIGINAL SLOT
+ MOVE C,A ; COPY A
+ MOVEI B,TATOM ; SET UP FOR MARK
+ MOVE A,1(C) ; ASSUME MARK DOESN'T HAVE TO TAKE PLACE
+ SKIPL (C) ; DON'T MARK IF ALREADY MARKED
+ PUSHJ P,MARK
+ POP P,C ; RESTORE C
+ HRLM A,1(C) ; SMASH IN PRIMTYPE OF TEMPLATE
+EXTYP: POP P,C ; RESTORE AC'S
+ POP P,A
+ POP P,B
+ POPJ P, ; EXIT
+
+
+; A ROUTINE TO DISTINGUISH BETWEEN A DEFERRED AND A LIST POINTER
+RLISTQ: PUSH P,A
+ GETYP A,(B) ; GET TYPE
+ PUSHJ P,SAT ; GET SAT
+ CAIG A,NUMSAT ; NOT DEFERRED IF TEMPLATE
+ SKIPL MKTBS(A)
+ AOS -1(P) ; SKIP IF NOT DEFFERED
+ POP P,A
+ POPJ P, ; EXIT
+
+
+; DISPATCH TABLE FOR MARK PHASE ("SETZ'D" ENTRIES MUST BE DEFERRED)
+
+GCDISP:
+
+OFFSET 0
+
+DISTBS DUM2,GCRET,[[S2WORD,PAIRMK],[S2DEFR,DEFMK],[SNWORD,VECTMK],[STBASE,ERDP]
+[STPSTK,ERDP],[SARGS,ERDP],[S2NWORD,VECTMK],[SPSTK,ERDP],[SSTORE,VECTMK]
+[SFRAME,ERDP],[SBYTE,<SETZ BYTMK>],[SATOM,DATOMK],[SPVP,ERDP],[SGATOM,ERDP]
+[SLOCID,ERDP],[SCHSTR,<SETZ BYTMK>],[SASOC,ERDP],[SLOCL,PAIRMK],[SABASE,ERDP]
+[SLOCA,ERDP],[SLOCV,VECTMK],[SLOCU,VECTMK],[SLOCS,<SETZ BYTMK>],[SLOCN,ERDP]
+[SLOCB,<SETZ BYTMK>],[SLOCR,LOCRDP],[SOFFS,OFFSMK]]
+
+OFFSET OFFS
+
+\f
+; THIS SUBROUTINE IMPURIFIES A PURE ATOM TO ALLOW MODIFICATION OF SYSTEM SUBRS
+
+IMPRF: PUSH P,A
+ PUSH P,LPVP
+ PUSH TP,$TATOM
+ HLRZ C,(A) ; GET LENGTH
+ TRZ C,400000 ; TURN OF 400000 BIT
+ SUBI A,-1(C) ; POINT TO START OF ATOM
+ MOVNI C,-2(C) ; MAKE IT LOOK LIKE AN ATOM POINTER
+ HRL A,C
+ PUSH TP,A
+ MOVE C,A
+ MOVEI 0,(C)
+ PUSH P,AB
+ MOVE PVP,PVSTOR+1
+ MOVE AB,ABSTO+1(PVP)
+ PUSHJ P,IMPURX
+ POP P,AB
+ POP P,LPVP ; RESTORE A
+ POP P,A
+ POPJ P,
+
+FIXATM: PUSH P,[0]
+FIXTM5: JUMPE LPVP,FIXTM4
+ MOVEI B,(LPVP) ; GET PTR TO ATOMS DOPE WORD
+ HRRZ LPVP,-1(B) ; SET UP LPVP FOR NEXT IN CHAIN
+ SKIPE -2(P) ; SEE IF PURE SCAN
+ JRST FIXTM2
+ CAIL B,HIBOT
+ JRST FIXTM3
+FIXTM2: CAMG B,PARBOT ; SKIP IF NOT FROZEN
+ JRST FIXTM1
+ HLRZ A,(B)
+ TRZ A,400000 ; GET RID OF MARK BIT
+ MOVE D,A ; GET A COPY OF LENGTH
+ SKIPE -2(P)
+ JRST PFATM
+ PUSHJ P,CAFREE ; GET STORAGE
+ SKIPE GCDANG ; SEE IF WON
+ JRST LOSLP1 ; GO TO CAUSE GC
+ JRST FIXT10
+PFATM: PUSH P,AB
+ MOVE PVP,PVSTOR+1
+ MOVE AB,ABSTO+1(PVP)
+ SETZM GPURFL
+ PUSHJ P,CAFREE
+ SETOM GPURFL
+ POP P,AB
+FIXT10: SUBM D,ABOTN
+ MOVNS ABOTN
+ SUBI B,-1(D) ; POINT TO START OF ATOM
+ HRLZ C,B ; SET UP FOR BLT
+ HRRI C,(A)
+ ADDI A,-1(D) ; FIX UP TO POINT TO NEW DOPE WORD
+ BLT C,(A)
+ HLLZS -1(A)
+ HLLOS (A) ; -1 IN RELOCATION FIELD SINCE ITS NOT GARBAGE
+ ADDI B,-1(D) ; B POINTS TO SECOND D.W.
+ HRRM A,(B) ; PUT IN RELOCATION
+ MOVSI D,400000 ; UNMARK ATOM
+ ANDCAM D,(A)
+ CAIL B,HIBOT ; SKIP IF IMPURE
+ PUSHJ P,IMPRF
+ JRST FIXTM5 ; CONTINE FIXUP
+
+FIXTM4: POP P,LPVP ; FIX UP LPVP TO POINT TO NEW CHAIN
+ POPJ P, ; EXIT
+
+FIXTM1: HRRM B,(B) ; SMASH IN RELOCATION
+ MOVSI D,400000
+ ANDCAM D,(B) ; CLEAR MARK BIT
+ JRST FIXTM5
+
+FIXTM3: MOVE 0,(P)
+ HRRM 0,-1(B)
+ MOVEM B,(P) ; FIX UP CHAIN
+ JRST FIXTM5
+
+
+\f
+IAGC":
+
+;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 /GIN /]
+ 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: SUB P,[1,,1] ; POP OFF C
+ POP P,A
+ POP P,B
+ EXCH P,GCPDL
+ JRST .+1
+IAAGC:
+ HLLZS SQUPNT ; FLUSH SQUOZE TABLE
+ SETZB M,RCL ; ALTERNATE GC-ENTRY POINT FOR INITIALIZATION
+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,B
+
+CHPDL: MOVE D,P ; SAVE FOR LATER
+CORGET: MOVE P,[-2000,,MRKPDL]
+
+;FENCE POST PDLS AND CHECK IF ANY SHOULD BE SHRUNK
+
+ MOVEI 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
+ HRRM A,BOTNEW ; INTO POINTER WORD
+ HRRZM A,FNTBOT
+ SETZM WNDBOT
+ SETZM WNDTOP
+ MOVEM A,NPARBO
+ HRRZ A,BOTNEW ; GET PAGE TO START INF AT
+ ASH A,-10. ; TO PAGES
+ MOVEI R,(A) ; COPY A
+ PUSHJ P,%GCJOB ; GET PAGE HOLDER
+ MOVSI FPTR,-2000 ; FIX UP FRONTIER POINTER
+ MOVE A,WNDBOT
+ ADDI A,2000 ; FIND WNDTOP
+ MOVEM A,WNDTOP
+
+;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; MAP NEW PAIR SPACE IN FOR PAIR SPACE UPDATE
+
+NOMAP1: MOVEI A,@BOTNEW
+ ADDI A,1777 ; TO PAGE BOUNDRY
+ ANDCMI A,1777
+ MOVE B,A
+DOMAP: ASH B,-10. ; TO PAGES
+ MOVE A,PARBOT
+ MOVEI C,(A) ; COMPUTE HIS TOP
+ ASH C,-10.
+ ASH A,-10.
+ SUBM A,B ; B==> - # OF PAGES
+ HRLI A,(B) ; AOBJN TO SOURCE AND DEST
+ MOVE B,A ; IN CASE OF FUNNY
+ HRRI B,(C) ; MAP HIS POSSIBLE HIGHER OR LOWER PAGES
+ PUSHJ P,%INFMP ; NOW FLUSH INF AND MAKE HIS CORE MINE
+ JRST GARZER
+
+\f; CORE ADJUSTMENT PHASE
+
+CORADJ: MOVE A,PURTOP
+ SUB A,CURPLN ; ADJUST FOR RSUBR
+ ANDCMI A,1777 ; ROUND DOWN
+ MOVEM A,RPTOP
+ MOVEI A,@BOTNEW ; 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
+ MOVEI A,@BOTNEW ; GCSTOP
+ MOVEM A,GCSTOP
+ MOVE A,CORTOP ; ADJUST CORE IMAGE
+ ASH A,-10. ; TO PAGES
+TRYPCO: PUSHJ P,P.CORE
+ FATAL AGC--CORE SCREW UP
+ 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
+ MOVEI A,@BOTNEW
+ 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
+CORAD8: MOVEM A,CORTOP ; ADJUST PARAMETER
+ JRST CORAD6 ; WIN TOTALLY
+
+; 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;GARBAGE ZEROING PHASE
+GARZER: MOVE A,GCSTOP ;FIRST WORD OF GARBAGE IS AFTER PAIR SPACE
+ MOVE B,FRETOP ;LAST ADDRESS OF GARBAGE + 1
+ CAIL A,(B)
+ JRST GARZR1
+ CLEARM (A) ;ZERO THE FIRST WORD
+ CAIL A,-1(B) ; ARE WE AT THE TOP OF THE WORLD (FORMERLY CAML A,FRETOP)
+ JRST GARZR1 ; DON'T BLT
+IFE ITS,[
+ MOVEI B,777(A)
+ ANDCMI B,777
+]
+ HRLS A
+ ADDI A,1 ;MAKE A A BLT POINTER
+ BLT A,-1(B) ;AND COPY ZEROES INTO REST OF AREA
+IFE ITS,[
+
+; MAP UNWANTED PAGES OUT ON TWENEX (AFTER ZEROING REST OF LAST PAGE)
+
+ MOVE D,PURBOT
+ ASH D,-PGSZ
+ ASH B,-PGSZ
+ MOVNI A,1
+ MOVEI C,0
+ HRLI B,400000
+
+GARZR2: CAIG D,(B)
+ JRST GARZR1
+
+ PMAP
+ AOJA B,GARZR2
+]
+
+
+; 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
+ 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 IAGC
+
+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 ; LOADING ONE, M = 0 IS OK
+ JRST FINAGC
+
+ FATAL AGC--RUNNING RSUBR WENT AWAY
+
+AGCE1: FATAL AGC--TYPE VECTOR NOT OF TYPE VECTOR
+
+\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
+ 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,[111100,,-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 F,1(A) ; GET LNTH
+ LDB 0,[111100,,(A)] ; GET GROWTHS
+ TRZE 0,400 ; SIGN HACK
+ MOVNS 0
+ ASH 0,6 ; TO WORDS
+ ADD F,0
+ LDB 0,[001100,,(A)]
+ TRZE 0,400
+ MOVNS 0
+ ASH 0,6
+ ADD F,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: SKIPN DUMFLG
+ JUMPE A,CPOPJ ; NEVER MARK 0
+ MOVEI 0,1(A)
+ CAIL 0,@PURBOT
+ JRST GCRETD
+MARCON: PUSH P,A
+ HRLM C,-1(P) ;AND POINTER TO IT
+ ANDI B,TYPMSK ; FLUSH MONITORS
+ SKIPE DUMFLG ; SKIP IF NOT IN DUMPER
+ PUSHJ P,TYPHK ; HACK SOME TYPES
+ 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
+ SKIPN GCDFLG
+IFN ITS,[
+ JRST @MKTBS(B) ;AND GO MARK
+ JRST @GCDISP(B) ; DISPATCH FOR DUMPERS
+]
+IFE ITS,[
+ SKIPA E,MKTBS(B)
+ MOVE E,GCDISP(B)
+ HRLI E,-1
+ JRST (E)
+]
+; 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: TLOA TYPNT,400000 ;USE SIGN BIT AS FLAG
+
+;HERE TO MARK LIST ELEMENTS
+
+PAIRMK: TLZ TYPNT,400000 ;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
+ SKIPL FPTR ; SEE IF IN FRONTEIR
+ PUSHJ P,MOVFNT ; EXPAND THE FRONTEIR
+ MOVEM B,FRONT(FPTR)
+ MOVE 0,1(C) ; AND 2D
+ AOBJN FPTR,.+2 ; AOS AND CHECK FRONTEIR
+ PUSHJ P,MOVFNT ; EXPAND FRONTEIR
+ MOVEM 0,FRONT(FPTR)
+ ADD FPTR,[1,,1] ; MOVE ALONG IN FRONTIER
+
+
+PAIRM2: MOVEI A,@BOTNEW ; GET INF ADDR
+ SUBI A,2
+ HRRM A,(C) ; LEAVE A POINTER TO NEW HOME
+ HRRZ E,(P) ; GET BACK POINTER
+ JUMPE E,PAIRM7 ; 1ST ONE, NEW FIXUP
+ MOVSI 0,(HRRM) ; INS FOR CLOBBER
+ PUSHJ P,SMINF ; SMASH INF'S CORE IMAGE
+PAIRM4: MOVEM A,(P) ; NEW BACK POINTER
+ JUMPL TYPNT,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
+ ADDI E,1
+ MOVSI 0,(MOVEM)
+ PUSHJ P,SMINF
+ 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: SUB P,[1,,1]
+
+GCRET: TLZ TYPNT,400000 ;FOR PAIRMKS BENEFIT
+ HLRZ C,-1(P) ;RESTORE C
+ POP P,A
+ POPJ P, ;AND RETURN TO CALLER
+
+GCRETD: ANDI B,TYPMSK ; TURN OFF MONITORS
+ CAIN B,TLOCR ; SEE IF A LOCR
+ JRST MARCON
+ SKIPN GCDFLG ; SKIP IF IN PURIFIER OR DUMPER
+ POPJ P,
+ CAIE B,TATOM ; WE MARK PURE ATOMS
+ CAIN B,TCHSTR ; AND STRINGS
+ 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
+ PUSHJ P,MARK2 ;MARK THE DATUM
+ HRRZ E,-2(P) ; GET POINTER IN INF CORE
+ ADDI E,1
+ MOVSI 0,(MOVEM)
+ PUSHJ P,SMINF ; AND CLOBBER
+ HRRZ E,-2(P)
+ MOVE A,-1(P)
+ MOVSI 0,(HRRM) ; SMASH IN RIGHT HALF
+ PUSHJ P,SMINF
+ SUB P,[3,,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
+ MOVSI 0,(HRRM)
+ PUSHJ P,SMINF
+ JRST GCRETP
+
+RETNW1: MOVEM A,-1(P)
+ JRST GCRETP
+
+; ROUTINE TO EXPAND THE FRONTEIR
+
+MOVFNT: PUSH P,B ; SAVE REG B
+ HRRZ A,BOTNEW ; CURRENT BOTTOM OF WINDOW
+ ADDI A,2000 ; MOVE IT UP
+ HRRM A,BOTNEW
+ HRRZM A,FNTBOT ; BOTTOM OF FRONTEIR
+ MOVEI B,FRNP
+ ASH A,-10. ; TO PAGES
+ PUSHJ P,%GETIP
+ PUSHJ P,%SHWND ; SHARE THE PAGE
+ MOVSI FPTR,-2000 ; FIX UP FPTR
+ POP P,B
+ POPJ P,
+
+
+; ROUTINE TO SMASH INFERIORS PPAGES
+; E/ ADDR IN INF, A/ THING TO SMASH ,0/ INS TO USE
+
+SMINF: CAMGE E,FNTBOT
+ JRST SMINF1 ; NOT IN FRONTEIR
+ SUB E,FNTBOT ; ADJUST POINTER
+ IOR 0,[0 A,FRONT(E)] ; BUILD INSTRUCTION
+ XCT 0 ; XCT IT
+ POPJ P, ; EXIT
+SMINF1: CAML E,WNDBOT
+ CAML E,WNDTOP ; SEE IF IN WINDOW
+ JRST SMINF2
+SMINF3: SUB E,WNDBOT ; FIX UP
+ IOR 0,[0 A,WIND(E)] ; FIX INS
+ XCT 0
+ POPJ P,
+SMINF2: PUSH P,A ; SAVE E
+ PUSH P,B ; SAVE B
+ HRRZ A,E ; E SOMETIMES HAS STUFF IN LH
+ ASH A,-10.
+ MOVEI B,WNDP ; WINDOW PAGE
+ PUSHJ P,%SHWND ; SHARE IT
+ ASH A,10. ; TO PAGES
+ MOVEM A,WNDBOT ; UPDATE POINTERS
+ ADDI A,2000
+ MOVEM A,WNDTOP
+ POP P,B ; RESTORE ACS
+ POP P,A
+ JRST SMINF3 ; FIX UP INF
+
+
+
+\f; VECTOR AND TP MARKER, SIGN OF TYPNT IS SET BASED ON WHICH ONE
+
+TPMK: TLOA TYPNT,400000 ;SET TP MARK FLAG
+VECTMK: TLZ TYPNT,400000
+ MOVEI 0,@BOTNEW ; POINTER TO INF
+ PUSH P,0
+ 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
+
+ HLLM TYPNT,(P) ; SAVE MARKER INDICATING STACK
+ JUMPGE TYPNT,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,[111100,,-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,[001100,,-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 F,(E) ;SAVE A COPY
+ ADD F,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
+ SKIPGE B,-1(A) ;SKIP IF UNIFORM
+ TLNE B,377777-.VECT. ;SKIP IF NOT SPECIAL
+ JUMPGE TYPNT,NOTGEN ;JUMP IF NOT A GENERAL VECTOR
+
+GENRAL: HLRZ 0,B ;CHECK FOR PSTACK
+ TRZ 0,.VECT.
+ JUMPE 0,NOTGEN ;IT ISN'T GENERAL
+ JUMPL TYPNT,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
+ HRRZ E,-1(P) ; GET POINTER INTO INF
+ SKIPN C ; SKIP IF NO BOTTOM GROWTH
+ JRST MOVEC3
+ JUMPL C,.+3 ; SEE IF BOTTOM SHRINKAGE
+ ADD E,C ; GROW IT
+ JRST MOVEC3 ; CONTINUE
+ HRLM C,E ; MOVE SHRINKAGE FOR TRANSFER PHASE
+MOVEC3: PUSHJ P,DOPMOD ; MODIFY DOPE WORD AND PLACE IN INF
+ PUSHJ P,TRBLKV ; SEND VECTOR INTO INF
+TGROT: CAMGE A,PARBOT ; SKIP IF NOT STORAGE
+ JRST TGROT1
+ MOVE C,DOPSV1 ; RESTORE DOPE WORD
+ SKIPN (P) ; DON'T RESTORE D.W.'S YET IF THERE IS GROWTH
+ MOVEM C,-1(A)
+TGROT1: POP P,C ; IS THERE TOP GROWH
+ SKIPN C ; SEE IF ANY GROWTH
+ JRST DOPEAD
+ SUBI E,2
+ SKIPG C
+ JRST OUTDOP
+ PUSH P,C ; SAVE C
+ SETZ C, ; ZERO C
+ PUSHJ P,ADWD
+ ADDI E,1
+ SETZ C, ; ZERO WHERE OLD DOPE WORDS WERE
+ PUSHJ P,ADWD
+ POP P,C
+ ADDI E,-1(C) ; MAKE ADJUSTMENT FOR TOP GROWTH
+OUTDOP: PUSHJ P,DOPOUT
+DOPEAD:
+EXVECT: HLRZ B,(P)
+ SUB P,[1,,1] ; GET RID OF FPTR
+ PUSHJ P,RELATE ; RELATIVIZE
+ TRNN B,400000 ; WAS THIS A STACK
+ JRST 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
+ POP P,C
+ 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
+ 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)
+ PUSHJ P,OUTTP ; MOVE OUT TYPE
+ MOVE A,R
+ PUSHJ P,OUTTP ; SEND OUT VALUE
+ 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)
+ PUSHJ P,OUTTP ; SEND IT OUT
+ 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)
+ PUSHJ P,OUTTP ; SEND IT OUT
+ MOVE A,-2(P) ; ADJUST AB SLOT
+ ADD A,ABSAV-FSAV+1(C) ; POINT TO SAVED AB
+ PUSHJ P,OUTTP ; SEND IT OUT
+ 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
+ PUSHJ P,OUTTP ; SEND IT OUT
+ HRROI C,PSAV-FSAV(C) ;POINT TO SAVED P
+ MOVEI B,TPDL
+ PUSHJ P,MARK1 ;AND MARK IT
+ PUSHJ P,OUTTP ; SEND IT OUT
+ 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
+ PUSHJ P,OUTTP
+ MOVE A,PCSAV-PSAV+1(C)
+ PUSHJ P,OUTTP
+ 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)
+ PUSHJ P,OUTTP ; FIX UP CHAIN
+ MOVEI B,TATOM ; RESTORE IN CASE SMASHED
+ PUSHJ P,MARK1 ; MARK ATOM
+ PUSHJ P,OUTTP ; SEND IT OUT
+ 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)
+ PUSHJ P,OUTTP ; MOVE OUT TYPE
+ MOVE A,R
+ PUSHJ P,OUTTP ; SEND OUT VALUE
+ 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
+ PUSHJ P,OUTTP
+ SKIPL A,1(C) ; PREV LOC?
+ JRST NOTLCI
+ MOVEI B,TLOCI ; NOW MARK LOCATIVE
+ PUSHJ P,MARK1
+NOTLCI: PUSHJ P,OUTTP
+ 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
+ PUSHJ P,OUTTP
+ ADDI C,1 ; INCREMENT C FOR FENCE-POST
+ SUB P,[1,,1] ; CLEAN UP STACK
+ POP P,E ; GET UPDATED PTR TO INF
+ SUB P,[2,,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
+ PUSHJ P,DOPMOD ; FIX UP DOPE WORDS
+ PUSHJ P,DOPOUT ; SEND THEM OUT
+ JRST DOPEAD
+
+
+\f; ROUTINE TO ALLOCATE ROOM FOR VECTORS IN INFERIOR
+; F= # OF WORDS TO ALLOCATE
+
+ALLOGC: HRRZS A ; GET ABS VALUE
+ SKIPN GCDFLG ; SKIP IF IN DUMPER
+ CAML A,GCSBOT ; SKIP IF IN STORAGE
+ JRST ALOGC2 ; JUMP IF ALLOCATING
+ HRRZ 0,A
+ POPJ P,
+ALOGC2: PUSH P,A ; SAVE A
+ALOGC1: HLRE 0,FPTR ; GET ROOM LEFT
+ ADD 0,F ; SEE IF ITS ENOUGH
+ JUMPL 0,ALOCOK
+ MOVE F,0 ; MODIFY F
+ PUSH P,F
+ PUSHJ P,MOVFNT ; MOVE UP FRONTEIR
+ POP P,F
+ JRST ALOGC1 ; CONTINUE
+ALOCOK: ADD FPTR,F ; MODIFY FPTR
+ HRLZS F
+ ADD FPTR,F
+ POP P,A ; RESTORE A
+ MOVEI 0,@BOTNEW
+ SUBI 0,1 ; RELOCATION PTR
+ POPJ P, ; EXIT
+
+
+
+
+; TRBLK MOVES A VECTOR INTO THE INFERIOR
+; E= STARTING ADDR IN INF A= DOPE WORD OF VECTOR
+
+TRBLK: HRRZS A
+ SKIPE GCDFLG
+ JRST TRBLK7
+ CAMGE A,GCSBOT ; SEE IF IN GC-SPACE
+ JRST FIXDOP
+TRBLK7: PUSH P,A
+ HLRZ 0,(A)
+ TRZ 0,400000 ; TURN OFF GC FLAG
+ HRRZ F,A
+ HLRE A,E ; GET SHRINKAGE
+ ADD 0,A ; MUNG LENGTH
+ SUB F,0
+ ADDI F,1 ; F POINTS TO START OF VECTOR
+TRBLK2: HRRZ R,E ; SAVE POINTER TO INFERIOR
+ ADD E,0 ; E NOW POINTS TO FINAL ADDRESS+1
+ MOVE M,E ;SAVE E
+TRBLK1: MOVE 0,R
+ SUBI E,1
+ CAMGE R,FNTBOT ; SEE IF IN FRONTEIR
+ JRST TRBL10
+ SUB E,FNTBOT ; ADJUST E
+ SUB 0,FNTBOT ; ADJ START
+ MOVEI A,FRONT+1777
+ JRST TRBLK4
+TRBL10: CAML R,WNDBOT
+ CAML R,WNDTOP ; SEE IF IN WINDOW
+ JRST TRBLK5 ; NO
+ SUB E,WNDBOT
+ SUB 0,WNDBOT
+ MOVEI A,WIND+1777
+TRBLK4: ADDI 0,-1777(A) ; CALCULATE START IN WINDOW OR FRONTEIR
+ CAIL E,2000
+ JRST TRNSWD
+ ADDI E,-1777(A) ; SUBTRACT WINDBOT
+ HRL 0,F ; SET UP FOR BLT
+ BLT 0,(E)
+ POP P,A
+
+FIXDOP: IORM D,(A)
+ MOVE E,M ; GET END OF WORD
+ POPJ P,
+TRNSWD: PUSH P,B
+ MOVEI B,1(A) ; GET TOP OF WORLD
+ SUB B,0
+ HRL 0,F
+ BLT 0,(A)
+ ADD F,B ; ADJUST F
+ ADD R,B
+ POP P,B
+ MOVE E,M ; RESTORE E
+ JRST TRBLK1 ; CONTINUE
+TRBLK5: HRRZ A,R ; COPY E
+ ASH A,-10. ; TO PAGES
+ PUSH P,B ; SAVE B
+ MOVEI B,WNDP ; IT IS WINDOW
+ PUSHJ P,%SHWND
+ ASH A,10. ; TO PAGES
+ MOVEM A,WNDBOT ; UPDATE POINTERS
+ ADDI A,2000
+ MOVEM A,WNDTOP
+ POP P,B ; RESTORE B
+ JRST TRBL10
+
+
+
+
+; ALTERNATE ENTRY FOR VECTORS WHICH TAKES CARE OF SHRINKAGE
+
+TRBLKV: HRRZS A
+ SKIPE GCDFLG ; SKIP IF NOT IN DUMPER
+ JRST TRBLV2
+ CAMGE A,GCSBOT ; SEE IF IN GC-SPACE
+ JRST FIXDOP
+TRBLV2: PUSH P,A ; SAVE A
+ HLRZ 0,DOPSV2
+ TRZ 0,400000
+ HRRZ F,A
+ HLRE A,E ; GET SHRINKAGE
+ ADD 0,A ; MUNG LENGTH
+ SUB F,0
+ ADDI F,1 ; F POINTS TO START OF VECTOR
+ SKIPGE -2(P) ; SEE IF SHRINKAGE
+ ADD 0,-2(P) ; IF SO COMPENSATE
+ JRST TRBLK2 ; CONTINUE
+
+; ALTERNATE ENTRY POINT TO TRBLK A==> OBJECT TO SEND IN 0= # OF WORDS
+
+TRBLK3: PUSH P,A ; SAVE A
+ MOVE F,A
+ JRST TRBLK2
+
+; FINAL ALTERNATE ENTRY POINT TO TRBLK A==> OBJECT
+; F==> START OF TRANSFER IN GCS 0= # OF WORDS
+
+TRBLKX: PUSH P,A ; SAVE A
+ JRST TRBLK2 ; SEND IT OUT
+
+
+; OUTTP IS THE ROUTINE THAT TPMK USES TO SEND OUT ELEMENTS FOR THE SCAN
+; -2(P) CONTAINS THE ADDR IN THE INF AND IT IS UPDATED
+; A CONTAINS THE WORD TO BE SENT OUT
+
+OUTTP: AOS E,-2(P) ; INCREMENT PLACE
+ MOVSI 0,(MOVEM) ; INS FOR SMINF
+ SOJA E,SMINF
+
+
+; ADWD PLACES ONE WORD IN THE INF
+; E ==> INF C IS THE WORD
+
+ADWD: PUSH P,E ; SAVE AC'S
+ PUSH P,A
+ MOVE A,C ; GET WORD
+ MOVSI 0,(MOVEM) ; INS FOR SMINF
+ PUSHJ P,SMINF ; SMASH IT IN
+ POP P,A
+ POP P,E
+ POPJ P, ; EXIT
+
+; DOPOUT IS USED TO SEND OUT THE DOPE WORDS IN UNUSUAL CALSE
+; SUCH AS THE TP AND GROWTH
+
+
+DOPOUT: MOVE C,-1(A)
+ PUSHJ P,ADWD
+ ADDI E,1
+ MOVE C,(A) ; GET SECOND DOPE WORD
+ TLZ C,400000 ; TURN OFF POSSIBLE MARK BIT
+ PUSHJ P,ADWD
+ MOVE C,DOPSV1 ; FIX UP FIRST DOPE WORD
+ MOVEM C,-1(A)
+ MOVE C,DOPSV2
+ MOVEM C,(A) ; RESTORE SECOND D.W.
+ POPJ P,
+
+; DOPMOD MODIFIES THE DOPE WORD OF A VECTOR AND PLACES A NEW DOPE-WORD IN INF
+; A ==> DOPE WORD E==> INF
+
+DOPMOD: SKIPE GCDFLG ; CHECK TO SEE IF IN DUMPER AND PURIFY
+ JRST .+3
+ CAMG A,GCSBOT
+ POPJ P, ; EXIT IF NOT IN GCS
+ MOVE C,-1(A) ; GET FIRST DOPE WORD
+ MOVEM C,DOPSV1
+ HLLZS C ; CLEAR OUT GROWTH
+ TLO C,.VECT. ; FIX UP FOR GCHACK
+ PUSH P,C
+ MOVE C,(A) ; GET SECOND DOPE WORD
+ HLRZ B,(A) ; GET LENGTH
+ TRZ B,400000 ; TURN OFF MARK BIT
+ MOVEM C,DOPSV2
+ HRRZ 0,-1(A) ; CHECK FOR GROWTH
+ JUMPE 0,DOPMD1
+ LDB 0,[111100,,-1(A)] ; MODIFY WITH GROWTH
+ TRZE 0,400
+ MOVNS 0
+ ASH 0,6
+ ADD B,0
+ LDB 0,[001100,,-1(A)]
+ TRZE 0,400
+ MOVNS 0
+ ASH 0,6
+ ADD B,0
+DOPMD1: HRL C,B ; FIX IT UP
+ MOVEM C,(A) ; FIX IT UP
+ POP P,-1(A)
+ POPJ P,
+
+ADPMOD: CAMG A,GCSBOT
+ POPJ P, ; EXIT IF NOT IN GCS
+ MOVE C,-1(A) ; GET FIRST DOPE WORD
+ TLO C,.VECT. ; FIX UP FOR GCHACK
+ MOVEM C,-1(A)
+ MOVE C,(A) ; GET SECOND DOPE WORD
+ TLZ C,400000 ; TURN OFF PARK BIT
+ MOVEM C,(A)
+ POPJ P,
+
+
+
+
+\f; RELATE RELATAVIZES A POINTER TO A VECTOR
+; B IS THE POINTER A==> DOPE WORD
+
+RELATE: SKIPE GCDFLG ; SEE IF DUMPER OR PURIFIER
+ JRST .+3
+ CAMGE A,GCSBOT ; SEE IF IN VECTOR SPACE
+ POPJ P, ; IF NOT EXIT
+ MOVE C,-1(P)
+ HLRE F,C ; GET LENGTH
+ HRRZ 0,-1(A) ; CHECK FO GROWTH
+ JUMPE A,RELAT1
+ LDB 0,[111100,,-1(A)] ; GET TOP GROWTH
+ TRZE 0,400 ; HACK SIGN BIT
+ MOVNS 0
+ ASH 0,6 ; CONVERT TO WORDS
+ SUB F,0 ; ACCOUNT FOR GROWTH
+RELAT1: HRLM F,C ; PLACE CORRECTED LENGTH BACK IN POINTER
+ HRRZ F,(A) ; GET RELOCATED ADDR
+ SUBI F,(A) ; FIND RELATIVIZATION AMOUNT
+ ADD C,F ; 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)
+ PUSH P,A
+ MOVEI C,-1(P)
+ MOVEI B,TTP
+ PUSHJ P,MARK
+ SUB P,[1,,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 F,OTBSAV(A) ; GET TIME FROM FRAME
+ CAME B,F ; 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 F,-1(A) ; GET THE TYPE
+ ANDI F,SATMSK ; FLUSH MONITOR BITS
+ CAIN F,SATOM ; SEE IF ATOM
+ JRST ATMSET
+ HLRE F,(A) ; GET MARKING
+ JUMPL F,BYTREL ; JUMP IF MARKED
+ HLRZ F,(A) ; GET LENGTH
+ PUSHJ P,ALLOGC ; ALLOCATE FOR IT
+ HRRM 0,(A) ; SMASH IT IN
+ MOVE E,0
+ HLRZ F,(A)
+ SUBI E,-1(F) ; ADJUST INF POINTER
+ IORM D,(A)
+ PUSHJ P,ADPMOD
+ PUSHJ P,TRBLK
+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
+ SKIPN GCDFLG
+ JRST BYTREL
+ MOVSI E,STATM ; GET "STRING IS ATOM BIT"
+ IORM E,(P)
+ SKIPN DUMFLG
+ JRST GCRET
+ HRRM A,(P)
+ JRST BYTREL ; TO BYTREL
+\f
+
+; MARK OFFSET
+
+OFFSMK: HLRZS A
+ PUSH P,$TLIST
+ PUSH P,A ; PUSH LIST POINTER ON THE STACK
+ MOVEI C,-1(P) ; POINTER TO PAIR
+ PUSHJ P,MARK2 ; MARK THE LIST
+ HRLM A,-2(P) ; UPDATE POINTER IN OFFSET
+ SUB P,[2,,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
+ HLRZ 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,@BOTNEW
+ PUSH P,0 ; SAVE POINTER TO INF
+ TLO TYPNT,.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) ; MAKE SURE ATOMS NOT ON OBLISTS GET SENT
+ POP P,A ; RESTORE A
+ POP P,E ; GET POINTER INTO INF
+ SKIPN GCHAIR
+ JUMPN 0,ATMREL
+ PUSHJ P,ADPMOD
+ PUSHJ P,TRBLK
+ATMREL: HRRZ E,(A) ; RELATAVIZE
+ SUBI E,(A)
+ ADDM E,(P)
+ JRST GCRET
+ATMRL1: SUB P,[1,,1] ; POP OFF STACK
+ JRST ATMREL
+
+\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 F,(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: SUB P,[1,,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
+ PUSH P,E
+ SKIPE DUMFLG ; SKIP IF NOT IN DUMPER
+ PUSHJ P,TYPHK ; HACK WITH TYPE IF SPECIAL
+ POP P,E ; RESTORE LENGTH
+ MOVE F,B ; AND COPY IT
+ LSH B,1 ;FIND OUT WHERE IT WILL GO
+ HRRZ B,@TYPNT ;GET SAT IN B
+ ANDI B,SATMSK
+ MOVEI C,@MKTBS(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,F ;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
+
+ SUB P,[2,,2] ;REMOVE STACK CRAP
+ JRST UMOVEC
+
+
+SPECLS: FATAL AGC--UNRECOGNIZED SPECIAL VECTOR
+ SUB P,[4,,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,@BOTNEW ; 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,A ; GET PTR TO D.W.
+ POP P,E ; GET PTR TO INF
+ SUB P,[1,,1] ; GET RID OF TOP
+ PUSHJ P,ADPMOD ; FIX UP D.W.
+ PUSHJ P,TRBLK ; SEND IT OUT
+ JRST ATMREL ; RELATIVIZE AND LEAVE
+GCRDRL: POP P,A ; GET PTR TO D.W
+ SUB P,[2,,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
+ SKIPN DUMFLG ; IF GC-DUMP, WILL STORE ATOM FOR LOCR
+ JRST LOCRDD
+ MOVEI B,1
+ IORM B,3(A) ; MUNG ATOM TO SAY IT IS LOCR
+ CAIA
+LOCRDD: 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 E,(A) ; GET PTR IN FRONTEIR
+ SUBI E,ASOLNT+1 ; ADJUST TO POINT TO BEGINNING
+ PUSHJ P,ADPMOD
+ PUSHJ P,TRBLK
+ JRST ASTR1
+
+;HERE WHEN A VECTOR POINTER IS BAD
+
+VECTB1:FATAL AGC--VECTOR POINTS OUTSIDE OF VECTOR SPACE
+ SUB P,[1,,1] ; RECOVERY
+AFIXUP: SETZM (P) ; CLOBBER SLOT
+ JRST GCRET ; CONTINUE
+
+
+VECTB2: FATAL AGC--VECTOR POINTS OUT OF VECTOR SPACE
+ SUB P,[2,,2]
+ JRST AFIXUP ; RECOVER
+
+PARERR: FATAL AGC--PAIR POINTS OUT OF PAIR SPACE
+ SUB P,[1,,1] ; RECOVER
+ JRST AFIXUP
+
+
+\f; HERE TO MARK TEMPLATE DATA STRUCTURES
+
+TD.MRK: MOVEI 0,@BOTNEW ; 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 E,-7(P) ; RESTORE PTR TO FRONTEIR
+ SUB P,[7,,7] ; CLEAN UP STACK
+USRAG1: ADDI A,1 ; POINT TO SECOND D.W.
+ MOVSI D,400000 ; SET UP MARK BIT
+ PUSHJ P,ADPMOD
+ PUSHJ P,TRBLK ; SEND IT OUT
+TMPREL: SUB P,[1,,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 E,(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 F,(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 F,(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,F
+ HLRE F,ASOLNT-INDIC+1(C) ; GET LENGTH
+ JUMPL F,.+3 ; SKIP IF MARKED
+ CAMGE C,VECBOT ; SKIP IF IN VECT SPACE
+ JRST ASOM20
+ HRRM FPTR,ASOLNT-INDIC+1(C) ; PUT IN RELATIVISATION
+ MOVEI F,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,F
+ 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(F) ; 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
+ TLZE TYPNT,.ATOM. ; ANY ATOMS MARKED?
+ JRST VALFLA ; YES, CHECK VALUES
+VALFL8:
+
+; NOW SEE WHICH CHANNELS STILL POINTED TO
+
+CHNFL3: MOVEI 0,N.CHNS-1
+ MOVEI A,CHNL1 ; SLOTS
+ HRLI A,TCHAN ; TYPE HERE TOO
+
+CHNFL2: SKIPN B,1(A)
+ JRST CHNFL1
+ HLRE C,B
+ SUBI B,(C) ; POINT TO DOPE
+ HLLM A,(A) ; PUT TYPE BACK
+ HRRE F,(A) ; SEE IF ALREADY MARKED
+ JUMPN F,CHNFL1
+ SKIPGE 1(B)
+ JRST CHNFL8
+ HLLOS (A) ; MARK AS A LOSER
+ SETZM -1(P)
+ JRST CHNFL1
+CHNFL8: MOVEI F,1 ; MARK A GOOD CHANNEL
+ HRRM F,(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
+
+ SUB P,[2,,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 F,A ; CALCULATE START OF TP IN F
+ HLRZ B,(A) ; ADJUST INF PTR
+ TRZ B,400000
+ SUBI F,-1(B)
+ LDB M,[111100,,-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: SUB P,[1,,1] ; CLEAN UP STACK
+ SUBI E,-1(B)
+ HRRI B,(R) ; GET POINTER TO THIS-PROCESS BINDING
+ MOVEI B,6(B) ; POINT AFTER THE BINDING
+ MOVE 0,F ; CALCULATE # OF WORDS TO SEND OUT
+ SUBM B,0
+ PUSH P,R ; PRESERVE R
+ PUSHJ P,TRBLKX ; SEND IT OUT
+ POP P,R ; RESTORE R
+ HRRZS R,2(R) ; GET THE NEXT PROCESS
+ SKIPN R
+ JRST .+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 A,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 SPECIAL STUFF FROM GCHAIR
+
+SPCOUT: HLRE B,A
+ SUB A,B
+ MOVEI A,1(A) ; POINT TO DOPE WORD
+ LDB 0,[001100,,-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
+ PUSHJ P,DOPMOD
+ HRRZ E,(A) ; GET PTR TO INF
+ HLRZ B,(A) ; LENGTH
+ TRZ B,400000 ; GET RID OF MARK BIT
+ SUBI E,-1(B)
+ ADD E,0
+ PUSH P,0 ; DUMMY FOR TRBLKV
+ PUSHJ P,TRBLKV ; OUT IT GOES
+ SUB P,[1,,1]
+ 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,F
+ PUSHJ P,MARK2
+ MOVEM A,1(C)
+ POP P,F
+ 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
+ SUB P,[1,,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: ADDI 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 F,ASOLNT+1(B) ;AND ITS RELOCATION
+ SUBI F,ASOLNT+1(B) ; RELATIVIZE
+ MOVSI F,(F)
+ ADDM F,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 F,ASOLNT+1(B) ;RELOC
+ SUBI F,ASOLNT+1(B)
+ MOVSI F,(F)
+ ADDM F,NODPNT(A)
+ASOUP5: POP P,A ; RECOVER PTR TO DOPE WORD
+ MOVEI A,ASOLNT+1(A)
+ MOVSI B,400000 ;UNMARK IT
+ XORM B,(A)
+ HRRZ E,(A) ; SET UP PTR TO INF
+ HLRZ B,(A)
+ SUBI E,-1(B) ; ADJUST PTR
+ PUSHJ P,ADPMOD
+ PUSHJ P,TRBLK ; OUT IT GOES
+ 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 F,1(C) ; FIND NEXT ATOM
+ SUBI C,-2(F)
+ 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
+ MOVSI D,400000 ;UNMARK IT
+ XORM D,1(A)
+ HRRZ E,1(A) ; SET UP PTR TO INF
+ HLRZ B,1(A)
+ SUBI E,-1(B) ; ADJUST PTR
+ MOVEI A,1(A)
+ PUSHJ P,ADPMOD
+ PUSHJ P,TRBLK ; OUT IT GOES
+ 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
+
+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
+
+DOPSV1: 0 ;SAVED FIRST D.W.
+DOPSV2: 0 ; SAVED LENGTH
+
+
+; LOCATIONS USED BY BLOAT-STAT TO HELP THE USER PICK BLOAT SPECIFICATIONS.
+;
+
+GCNO: 0 ; USER-CALLED GC
+BSTGC: 0 ; FREE STORAGE
+ 0 ; BLOWN TP
+ 0 ; TOP-LEVEL LVALS
+ 0 ; GVALS
+ 0 ; TYPE
+ 0 ; STORAGE
+ 0 ; P-STACK
+ 0 ; BOTH STATCKS BLOWN
+ 0 ; STORAGE
+
+BSTAT:
+NOWFRE: 0 ; FREE STORAGE FROM LAST GC
+CURFRE: 0 ; STORAGE USED SINCE LAST GC
+MAXFRE: 0 ; MAXIMUM FREE STORAGE ALLOCATED
+USEFRE: 0 ; TOTAL FREE STORAGE USED
+NOWTP: 0 ; TP LENGTH FROM LAST GC
+CURTP: 0 ; # WORDS ON TP
+CTPMX: 0 ; MAXIMUM SIZE OF TP SO FAR
+NOWLVL: 0 ; # OF TOP-LEVEL LVAL-SLOTS
+CURLVL: 0 ; # OF TOP-LEVEL LVALS
+NOWGVL: 0 ; # OF GVAL SLOTS
+CURGVL: 0 ; # OF GVALS
+NOWTYP: 0 ; SIZE OF TYPE-VECTOR
+CURTYP: 0 ; # OF TYPES
+NOWSTO: 0 ; SIZE OF STATIONARY STORAGE
+CURSTO: 0 ; STATIONARY STORAGE IN USE
+CURMAX: 0 ; MAXIMUM BLOCK OF CONTIGUOUS STORAGE
+NOWP: 0 ; SIZE OF P-STACK
+CURP: 0 ; #WORDS ON P
+CPMX: 0 ; MAXIMUM P-STACK LENGTH SO FAR
+GCCAUS: 0 ; INDICATOR FOR CAUSE OF GC
+GCCALL: 0 ; INDICATOR FOR CALLER OF GC
+
+
+; THIS GROUP OF VARIABLES DETERMINES HOW THINGS GROW
+LVLINC: 6 ; LVAL INCREMENT ASSUMED TO BE 64 SLOTS
+GVLINC: 4 ; GVAL INCREMENT ASSUMED TO BE 64 SLOTS
+TYPIC: 1 ; TYPE INCREMENT ASSUMED TO BE 32 TYPES
+STORIC: 2000 ; STORAGE INCREMENT USED BY NFREE (MINIMUM BLOCK-SIZE)
+
+
+RCL: 0 ; POINTER TO LIST OF RECYCLEABLE LIST CELLS
+RCLV: 0 ; POINTER TO RECYCLED VECTORS
+GCMONF: 0 ; NON-ZERO SAY GIN/GOUT
+GCDANG: 0 ; NON-ZERO, STORAGE IS LOW
+INBLOT: 0 ; INDICATE THAT WE ARE RUNNING OIN A BLOAT
+GETNUM: 0 ;NO OF WORDS TO GET
+RFRETP:
+RPTOP: 0 ;NO OF BLOCKS OF CORE, IF GIVING CORE AWAY
+CORTOP: 0 ;CURRENT TOP OF CORE, EXCLUDING ANY TO BE GIVEN AWAY
+NGCS: 8 ; NUMBER OF GARBAGE COLLECTS BETWEEN HAIRY GCS
+
+;VARIABLES WHICH DETERMIN WHEN MUDDLE WILL ASK FOR MORE CORE,
+;AND WHEN IT WILL GET UNHAPPY
+
+FREMIN: 20000 ;MINIMUM FREE WORDS
+
+;POINTER TO GROWING PDL
+
+TPGROW: 0 ;POINTS TO A BLOWN TP
+PPGROW: 0 ;POINTS TO A BLOWN PP
+PGROW: 0 ;POINTS TO A BLOWN P
+
+;IN GC FLAG
+
+GCFLG: 0
+GCFLCH: 0 ; TELL INT HANDLER TO ITIC CHARS
+GCHAIR: 1 ; COUNTS GCS AND TELLS WHEN TO HAIRIFY
+GCDOWN: 0 ; AMOUNT TO TRY AND MOVE DOWN
+CURPLN: 0 ; LENGTH OF CURRENTLY RUNNING PURE RSUBR
+PURMIN: 0 ; MINIMUM PURE STORAGE
+
+; VARS ASSOCIATED WITH BLOAT LOGIC
+PMIN: 200 ; MINIMUM FOR PSTACK
+PGOOD: 1000 ; GOOD SIZE FOR PSTACK
+PMAX: 4000 ; MAX SIZE FOR PSTACK
+TPMIN: 1000 ; MINIMUM SIZE FOR TP
+TPGOOD: NTPGOO ; GOOD SIZE OF TP
+TPMAX: NTPMAX ; MAX SIZE OF TP
+
+TPBINC: 0
+GLBINC: 0
+TYPINC: 0
+
+; VARS FOR PAGE WINDOW HACKS
+
+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
+FNTBOT: 0 ; BOTTOM OF FRONTEIR
+WNDBOT: 0 ; BOTTOM OF WINDOW
+WNDTOP: 0
+BOTNEW: (FPTR) ; POINTER TO FRONTIER
+GCTIM: 0
+NPARBO: 0 ; SAVED PARBOT
+
+; FLAGS TO INDICATE DUMPER IS IN USE
+
+GPURFL: 0 ; INDICATE PURIFIER IS RUNNING
+GCDFLG: 0 ; INDICATE EITHER GCDUMP OR PURIFIER IS RUNNING
+DUMFLG: 0 ; FLAG INDICATING DUMPER IS RUNNING
+
+; CONSTANTS FOR DUMPER,READER AND PURIFYER
+
+ABOTN: 0 ; COUNTER FOR ATOMS
+NABOTN: 0 ; POINTER USED BY PURIFY
+OGCSTP: 0 ; CONTAINS OLD GCSTOP FOR READER
+MAPUP: 0 ; BEGINNING OF MAPPED UP PURE STUFF
+SAVRES: 0 ; SAVED UPDATED ITEM OF PURIFIER
+SAVRE2: 0 ; SAVED TYPE WORD
+SAVRS1: 0 ; SAVED PTR TO OBJECT
+INF1: 0 ; AOBJN PTR USED IN CREATING PROTECTION INF
+INF2: 0 ; AOBJN PTR USED IN CREATING SECOND INF
+INF3: 0 ; AOBJN PTR USED TO PURIFY A STRUCTURE
+
+; VARIABLES USED BY GC INTERRUPT HANDLER
+
+GCHPN: 0 ; SET TO -1 EVERYTIME A GC HAS OCCURED
+GCKNUM: 0 ; NUMBER OF WORDS OF REQUEST TO INTERRUPT
+
+; VARIABLE TO INDICATE WHETHER AGC HAS PUSHED THE MAPPING CHANNEL TO WIN
+
+PSHGCF: 0
+
+; VARIABLES USED BY DUMPER AND READER TO HANDLE NEWTYPES
+
+TYPTAB: 0 ; POINTER TO TYPE TABLE
+NNPRI: 0 ; NUMPRI FROM DUMPED OBJECT
+NNSAT: 0 ; NUMSAT FROM DUMPED OBJECT
+TYPSAV: 0 ; SAVE PTR TO TYPE VECTOR
+
+; VARIABLES USED BY GC-DUMP FOR COPY-WRITE MAPPING
+
+BUFGC: 0 ; BUFFER FOR COPY ON WRITE HACKING
+PURMNG: 0 ; FLAG INDICATING IF A PURIFIED PAGE WAS MUNGED DURING GC-DUMP
+RPURBT: 0 ; SAVED VALUE OF PURTOP
+RGCSTP: 0 ; SAVED GCSTOP
+
+; VARIABLES USED TO DETERMINE WHERE THE GC-DUMPED STRUCTURE SHOULD GO
+
+INCORF: 0 ; INDICATION OF UVECTOR HACKS FOR GC-DUMP
+PURCOR: 0 ; INDICATION OF UVECTOR TO PURE CORE
+ ; ARE NOT GENERATED
+
+
+PLODR: 0 ; INDICATE A PLOAD IS IN OPERATION
+NPRFLG: 0
+
+; VARIABLE USED BY MARK SWEEP GARBAGE COLLECTOR
+
+MAXLEN: 0 ; MAXIMUM RECLAIMED SLOT
+
+PURE
+
+OFFSET OFFS
+
+CONSTANTS
+
+HERE
+
+CONSTANTS
+
+OFFSET 0
+
+ZZ==$.+1777
+
+.LOP ANDCM ZZ 1777
+
+ZZ1==.LVAL1
+
+LOC ZZ1
+
+
+OFFSET OFFS
+
+WIND: SPBLOK 2000
+FRONT: SPBLOK 2000
+MRKPD: SPBLOK 1777
+ENDPDL: -1
+
+MRKPDL=MRKPD-1
+
+ENDGC:
+
+OFFSET 0
+
+.LOP <ASH @> WIND <,-10.>
+WNDP==.LVAL1
+
+.LOP <ASH @> FRONT <,-10.>
+FRNP==.LVAL1
+
+ZZ2==ENDGC-AGCLD
+.LOP <ASH @> ZZ2 <,-10.>
+LENGC==.LVAL1
+
+.LOP <ASH @> LENGC <,10.>
+RLENGC==.LVAL1
+
+.LOP <ASH @> AGCLD <,-10.>
+PAGEGC==.LVAL1
+
+OFFSET 0
+
+LOC GCST
+.LPUR==$.
+
+END
+
--- /dev/null
+TITLE AGC MUDDLE GARBAGE COLLECTOR
+
+;SYSTEM WIDE DEFINITIONS GO HERE
+
+RELOCATABLE
+GCST==$.
+
+
+.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,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,GCOFFS
+.GLOBAL SPBASE,OUTRNG,CISTNG,CBYTES,%RUNAM,PURVEC,GCDOWN,N.CHNS,CHNL1,PLODR,MRKPDL
+.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 P.TOP,P.CORE,PMAPB,IGET,CIGTPR,ROOT,STBL,CAFREE,%MPIN1,%PURIF,%MPINX,GCHK10
+.GLOBAL %SAVRP,%RSTRP,LENGC,AGCLD,PAGEGC,REALGC,MARK
+.GLOBAL %MPINT,%GBINT,%CLSMP,%CLSM1,PINIT,PGFIND,NPRFLG,%PURMD
+.GLOBAL GCKNUM,CORTOP,GCHPN,INTAGC,WNDP,WNDBOT,BUFGC,WIND,GCDFLG,SAVM,AGC,GCSET
+
+.GLOBAL GCRET,PAIRMK,DEFMK,VECTMK,TBMK,TPMK,ARGMK,VECTMK,FRMK,BYTMK,ATOMK,GATOMK
+.GLOBAL BYTMK,ABMK,LOCRMK,GCRDMK,DEFQMK,ASMRK,LOCMK,OFFSMK,INBLOT,MARK2A
+
+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
+
+.ATOM.==200000 ; FLAG SAYING ATOMS MARKED (FOR VAL FLUSH LOGIC)
+
+GCHN==0 ; CHANNEL FOR FUNNNY INFERIOR
+STATNO==19. ; # OF STATISTICS FOR BLOAT-STAT
+STATGC==8. ; # OF GC-STATISTICS FOR BLOAT-STAT
+
+
+LOC REALGC
+OFFS==AGCLD-$.
+GCOFFS=OFFS
+OFFSET OFFS
+
+.INSRT MUDDLE >
+SYSQ
+IFE ITS,[
+.INSRT STENEX >
+]
+IFN ITS, PGSZ==10.
+IFE ITS, PGSZ==9.
+
+TYPNT=AB ;SPECIAL AC USAGE DURING GC
+F=TP ;ALSO SPECIAL DURING GC
+LPVP=SP ;SPECIAL FOR GC, HOLDS POINTER TO PROCESS CHAIN
+FPTR=TB ; POINT TO CURRENT FRONTIER OF INFERIOR
+
+
+; WINDOW AND FRONTIER PAGES
+
+MAPCH==0 ; MAPPING CHANNEL
+.LIST.==400000
+FPAG==2000 ; START OF PAGES FOR GC-READ AND GCDUMP
+CONADJ==5 ; ADJUSTMENT OF DUMPERS CONSTANT TABLE
+
+\f
+; INTERNAL GCDUMP ROUTINE
+.GLOBAL GODUMP,EGCDUM,EPURIF,ERRKIL,IPURIF
+
+GODUMP: MOVE PVP,PVSTOR+1
+ MOVEM P,PSTO+1(PVP) ; SAVE P
+ MOVE P,GCPDL
+ PUSH P,AB
+ PUSHJ P,INFSU1 ; SET UP INFERIORS
+
+; MARK PHASE
+ SETZM PURMNG ; INITIALIZE FLAG INDICATING IF PURIFIED PAGES
+ ; WERE MUNGED
+ MOVEI 0,HIBOT ; SET UP NEW PURBOT TO CONVINCE THE GARBAGE COLLECTOR
+ ; TO COLLECT PURIFIED STRUCTURES
+ EXCH 0,PURBOT
+ MOVEM 0,RPURBT ; SAVE THE OLD PURBOT
+ MOVEI 0,HIBOT
+ EXCH 0,GCSTOP
+ MOVEM 0,RGCSTP ; SAVE THE OLD GCSTOP
+ POP P,C ; SET UP PTR TO TYPE/VALUE PAIR
+ MOVE P,A ; GET NEW PDL PTR
+ SETOM DUMFLG ; FLAG INDICATING IN DUMPER
+ MOVE A,TYPVEC+1
+ MOVEM A,TYPSAV
+ ADD FPTR,[7,,7] ; ADJUST FOR FIRST STATUS WORDS
+ PUSHJ P,MARK2
+ MOVEI E,FPAG+6 ; SEND OUT PAIR
+ PUSH P,C ; SAVE C
+ MOVE C,A
+ PUSHJ P,ADWD
+ POP P,C ; RESTORE C
+ MOVEI E,FPAG+5
+ MOVE C,(C) ; SEND OUT UPDATED PTR
+ PUSHJ P,ADWD
+
+ MOVEI 0,@BOTNEW ; CALCULATE START OF TYPE-TABLE
+ MOVEM 0,TYPTAB
+ MOVE 0,RPURBT ; RESTORE PURBOT
+ MOVEM 0,PURBOT
+ MOVE 0,RGCSTP ; RESTORE GCSTOP
+ MOVEM 0,GCSTOP
+
+
+; ROUTINE TO SCAN THE TYPE-VECTOR FOR MARKED TYPE SLOTS AND BUILD A TYPE-TABLE OUT OF
+; THEM
+
+ MOVE A,TYPSAV ; GET AOBJN POINTER TO TYPE-VECTOR
+ MOVEI B,0 ; INITIALIZE TYPE COUNT
+TYPLP2: HLRE C,(A) ; GET MARKING
+ JUMPGE C,TYPLP1 ; IF NOT MARKED DON'T OUTPUT
+ MOVE C,(A) ; GET FIRST WORD
+ HRL C,B ; FIX UP SO TYPE-NUMBER REPLACES TYPE-CELL
+ PUSH P,A
+ SKIPL FPTR
+ PUSHJ P,MOVFNT
+ MOVEM C,FRONT(FPTR)
+ AOBJN FPTR,.+2
+ PUSHJ P,MOVFNT ; EXTEND THE FRONTIER
+ POP P,A
+ MOVE C,1(A) ; OUTPUT SECOND WORD
+ MOVEM C,FRONT(FPTR)
+ ADD FPTR,[1,,1]
+TYPLP1: ADDI B,1 ; INCREMENT TYPE COUNT
+ ADD A,[2,,2] ; POINT TO NEXT SLOT
+ JUMPL A,TYPLP2 ; LOOP
+
+; ROUTINE TO BUILD UP ATOM TABLE USING LPVP CHAIN
+
+ HRRZ F,ABOTN
+ MOVEI 0,@BOTNEW ; GET CURRENT BEGINNING OF TRANSFER
+ MOVEM 0,ABOTN ; SAVE IT
+ PUSHJ P,ALLOGC ; ALLOCATE ROOM FOR ATOMS
+ MOVSI D,400000 ; SET UP UNMARK BIT
+SPOUT: JUMPE LPVP,DPGC4 ; END OF CHAIN
+ MOVEI F,(LPVP) ; GET COPY OF LPVP
+ HRRZ LPVP,-1(LPVP) ; LPVP POINTS TO NEXT ON CHAIN
+ ANDCAM D,(F) ; UNMARK IT
+ HLRZ C,(F) ; GET LENGTH
+ HRRZ E,(F) ; POINTER INTO INF
+ ADD E,ABOTN
+ SUBI C,2 ; WE'RE NOT SENDING OUT THE VALUE PAIR
+ HRLM C,(F) ; ADJUSTED LENGTH
+ MOVE 0,C ; COPY C FOR TRBLKX
+ SUBI E,(C) ; ADJUST PTRS FOR SENDOUT\r
+ SUBI F,-1(C)
+ PUSHJ P,TRBLKX ; OUT IT GOES
+ JRST SPOUT
+
+
+; HERE TO SEND OUT DELIMITER INFORMATION
+DPGC4: SKIPN INCORF ; SKIP IF TRANSFREING TO UVECTOR IN CORE
+ JRST CONSTO
+ SKIPL FPTR ; SEE IF ROOM IN FRONTEIR
+ PUSHJ P,MOVFNT ; EXTEND FRONTEIR
+ MOVSI A,.VECT.
+ MOVEM A,FRONT(FPTR)
+ AOBJN FPTR,.+2
+ PUSHJ P,MOVFNT
+ MOVEI A,@BOTNEW ; LENGTH
+ SUBI A,FPAG
+ HRLM A,FRONT(FPTR)
+ ADD FPTR,[1,,1]
+
+
+CONSTO: MOVEI E,FPAG
+ MOVE C,ABOTN ; START OF ATOMS
+ SUBI C,FPAG+CONADJ ; ADJUSTMENT FOR STARTING ON PAGE ONE
+ PUSHJ P,ADWD ; OUT IT GOES
+ MOVEI E,FPAG+1
+ MOVEI C,@BOTNEW
+ SUBI C,FPAG+CONADJ
+ SKIPE INCORF ; SKIP IF TO CHANNEL
+ SUBI C,2 ; SUBTRACT FOR DOPE WORDS
+ PUSHJ P,ADWD
+ SKIPE INCORF
+ ADDI C,2 ; RESTORE C TO REAL ABOTN
+ ADDI C,CONADJ
+ PUSH P,C
+ MOVE C,TYPTAB
+ SUBI C,FPAG+CONADJ
+ MOVEI E,FPAG+2 ; SEND OUT START OF TYPE TABLE
+ PUSHJ P,ADWD
+ ADDI E,1 ; SEND OUT NUMPRI
+ MOVEI C,NUMPRI
+ PUSHJ P,ADWD
+ ADDI E,1 ; SEND OUT NUMSAT
+ MOVEI C,NUMSAT
+ PUSHJ P,ADWD
+
+
+
+; FINAL CLOSING OF INFERIORS
+
+DPCLS: PUSH P,PGCNT
+ PUSHJ P,INFCL1
+ POP P,PGCNT
+ POP P,A ; LENGTH OF CODE
+
+; RESTORE AC'S
+ MOVE PVP,PVSTOR+1
+ IRP AC,,[P,TP,TB,AB,FRM]
+ MOVE AC,AC!STO+1(PVP)
+ TERMIN
+
+ SETZB M,R
+ SETZM DUMFLG
+ SETZM GCDFLG ; ZERO FLAG INDICATING IN DUMPER
+ SETZM GCFLG ; AND INDICTOR TO INTERRUPT HANDLER THAT AGC IS ON
+ PUSH P,A
+ MOVE A,INF2 ; GET POINTER TO PURE MAPPED OUT
+ PUSHJ P,%GBINT
+
+ POP P,A
+ JRST EGCDUM
+
+
+ERDP: PUSH P,B
+ PUSHJ P,INFCLS
+ PUSHJ P,INFCL1
+ SETZM GCFLG
+ SETZM GPURFL ; PURE FLAG
+ SETZM DUMFLG
+ SETZM GCDFLG
+ POP P,A
+
+; RESTORE AC'S
+ MOVE PVP,PVSTOR+1
+ IRP AC,,[P,R,M,TP,TB,AB,FRM]
+ MOVE AC,AC!STO+1(PVP)
+ TERMIN
+
+ERDUMP: PUSH TP,$TATOM
+
+OFFSET 0
+
+ PUSH TP,EQUOTE STRUCTURE-CONTAINS-UNDUMPABLE-TYPE
+
+OFFSET OFFS
+
+ PUSH TP,$TATOM ; PUSH ON PRIMTYPE
+ PUSH TP,@STBL(A) ; PUSH ON PRIMTYPE
+ MOVEI A,2
+ JRST ERRKIL
+
+; ALTERNATE ATOM MARKER FOR DUMPER
+
+DATOMK: SKIPE GPURFL ; SKIP IF NOT IN PURIFIER
+ JRST PATOMK
+ CAILE A,0 ; SEE IF ALREADY MARKED
+ JRST GCRET
+ PUSH P,A ; SAVE PTR TO ATOM
+ HLRE B,A ; POINT TO DOPE WORD
+ SUB A,B ; TO FIRST DOPE WORD
+ MOVEI A,1(A) ; TO SECOND
+ PUSH P,A ; SAVE PTR TO DOPE WORD
+ HLRZ B,(A) ; GET LENGTH AND MARKING
+ TRZE B,400000 ; TURN OFF BIT AND SKIP IF UNMARKED
+ JRST DATMK1
+ IORM D,(A) ; MARK IT
+ MOVE 0,ABOTN ; GET CURRENT TOP OF ATOM TABLE
+ ADDI 0,-2(B) ; PLACE OF DOPE WORD IN TABLE
+ HRRM 0,(A) ; PUT IN RELOCATION
+ MOVEM 0,ABOTN ; FIXUP TOP OF TABLE
+ HRRM LPVP,-1(A) ; FIXUP CHAIN
+ MOVEI LPVP,(A)
+ MOVE A,-1(P) ; GET POINTER TO ATOM BACK
+ HRRZ B,2(A) ; GET OBLIST POINTER
+ JUMPE B,NOOB ; IF ZERO ON NO OBLIST
+ CAMG B,VECBOT ; DON'T SKIP IF OFFSET FROM TVP
+ MOVE B,(B)
+ HRLI B,-1
+DATMK3: MOVE A,$TOBLS ; SET UP FOR GET
+ MOVE C,$TATOM
+
+OFFSET 0
+ MOVE D,IMQUOTE OBLIST
+
+OFFSET OFFS
+
+ PUSH P,TP ; SAVE FPTR
+ MOVE TP,MAINPR
+ MOVE TP,TPSTO+1(TP) ; GET TP
+ PUSHJ P,IGET
+ POP P,TP ; RESTORE FPTR
+ MOVE C,-1(P) ; RECOVER PTR TO ATOM
+ ADDI C,1 ; SET UP TO MARK OBLIST ATOM
+ MOVSI D,400000 ; RESTORE MARK WORD
+
+OFFSET 0
+
+ CAMN B,MQUOTE ROOT
+
+OFFSET OFFS
+
+ JRST RTSET
+ MOVEM B,1(C)
+ MOVEI B,TATOM
+ PUSHJ P,MARK1 ; MARK IT
+ MOVEM A,1(C) ; SMASH IN ITS ID
+DATMK1:
+NOOB: POP P,A ; GET PTR TO DOPE WORD BACK
+ HRRZ A,(A) ; RETURN ID
+ SUB P,[1,,1] ; CLEAN OFF STACK
+ MOVEM A,(P)
+ JRST GCRET ; EXIT
+
+; HERE FOR A ROOT ATOM
+RTSET: SETOM 1(C) ; INDICATOR OF ROOT ATOM
+ JRST NOOB ; CONTINUE
+
+\f
+; INTERNAL PURIFY ROUTINE
+; SAVE AC's
+
+IPURIF: PUSHJ P,PURCLN ; GET RID OF PURE MAPPED
+ MOVE PVP,PVSTOR+1
+ IRP AC,,[P,R,M,TP,TB,AB,FRM]
+ MOVEM AC,AC!STO"+1(PVP)
+ TERMIN
+
+
+; HERE TO CREATE INFERIORS AND MARK THE ITEM
+PURIT1: MOVE PVP,PVSTOR+1
+ MOVEM P,PSTO+1(PVP) ; SAVE P
+ SETOM GPURFL ; INDICATE PURIFICATION IS TAKING PLACE
+ MOVE C,AB ; ARG PAIR
+ MOVEM C,SAVRS1 ; SAV PTR TO PAIR
+ MOVE P,GCPDL
+ PUSHJ P,INFSUP ; GET INFERIORS
+ MOVE P,A ; GET NEW PDL PTR
+ PUSHJ P,%SAVRP ; SAVE RPMAP TABLE FOR TENEX
+ MOVE C,SAVRS1 ; SET UP FOR MARKING
+ MOVE A,(C) ; GET TYPE WORD
+ MOVEM A,SAVRE2
+PURIT3: PUSH P,C
+ PUSHJ P,MARK2
+PURIT4: POP P,C ; RESTORE C
+ ADD C,[2,,2] ; TO NEXT ARG
+ JUMPL C,PURIT3
+ MOVEM A,SAVRES ; SAVE UPDATED POINTER
+
+; FIX UP IMPURE PART OF ATOM CHAIN
+
+ PUSH P,[0] ; FLAG INDICATING NON PURE SCAN
+ PUSHJ P,FIXATM
+ SUB P,[1,,1] ; CLEAN OFF STACK
+
+; NOW TO GET PURE STORAGE
+
+PURIT2: MOVEI A,@BOTNEW ; GET BOTNEW
+ SUBI A,2000-1777 ; START AT PAGE 1 AND ROUND
+ ANDCMI A,1777
+ ASH A,-10. ; TO PAGES
+ SETZ M,
+ PUSH P,A
+ PUSHJ P,PGFIND ; FIND THEM
+ JUMPL B,LOSLP2 ; LOST GO TO CAUSE AGC
+ HRRZ 0,BUFGC ;GET BUFFER PAGE
+ ASH 0,-10.
+ MOVEI A,(B) ; GET LOWER PORTION OF PAGES
+ MOVN C,(P)
+ SUBM A,C ; GET END PAGE
+ CAIL 0,(A) ; L? LOWER
+ CAILE 0,(C) ; G? HIGER
+ JRST NOREMP ; DON'T GET NEW BUFFER
+ PUSHJ P,%FDBUF ; GET A NEW BUFFER PAGE
+NOREMP: MOVN A,(P) ; SET UP AOBJN PTR FOR MAPIN
+ MOVE C,B ; SAVE B
+ HRL B,A
+ HRLZS A
+ ADDI A,1
+ MOVEM B,INF3 ; SAVE PTR FOR PURIFICATION
+ PUSHJ P,%MPIN1 ; MAP IT INTO PURE
+ ASH C,10. ; TO WORDS
+ MOVEM C,MAPUP
+ SUB P,[1,,1] ; CLEAN OFF STACK
+
+DONMAP:
+; RESTORE AC's
+ MOVE PVP,PVSTOR+1
+ MOVE P,PSTO+1(PVP) ; GET REAL P
+ PUSH P,LPVP
+ MOVEI A,@BOTNEW
+ MOVEM A,NABOTN
+
+ IRP AC,,[M,TP,TB,R,FRM]
+ MOVE AC,AC!STO+1(PVP)
+ TERMIN
+ MOVE A,INF1
+
+; NOW FIX UP POINTERS IN PURE STRUCTURE
+ MOVE 0,GCSBOT
+ MOVEM 0,OGCSTP
+ PUSH P,GCSBOT ; SAVE GCSBOT AND GCSTOP
+ PUSH P,GCSTOP
+ MOVE A,MAPUP ; NEW GCSBOT AND TOP TO FOOL GCHACK
+ MOVEM A,GCSBOT
+ ADD A,NABOTN
+ SUBI A,2000 ; ADJUSTMENT FOR START ON PAGE ONE
+ MOVEM A,GCSTOP
+ MOVE A,[PUSHJ P,NPRFIX]
+ MOVEI PVP,0 ; SAY MIGHT BE NON-ATOMS
+ PUSHJ P,GCHK10
+ POP P,GCSTOP
+ POP P,GCSBOT
+
+; NOW FIX UP POINTERS TO PURIFIED STRUCTURE
+
+ MOVE A,[PUSHJ P,PURFIX]
+ MOVEI PVP,0 ; SAY MIGHT BE NON-ATOMS
+ PUSHJ P,GCHACK
+
+ SETZM GCDFLG
+ SETZM DUMFLG
+ SETZM GCFLG
+
+ POP P,LPVP ; GET BACK LPVP
+ MOVE A,INF1
+ PUSHJ P,%KILJB ; KILL IMAGE SAVING INFERIOR
+ PUSH P,[-1] ; INDICATION OF PURE ATOM SCAN
+ PUSHJ P,FIXATM
+
+; SET UP PMAP SO THAT NEW PURE PAGES ARE INDICATED
+
+ MOVE A,INF3 ; GET AOBJN PTR TO PAGES
+FIXPMP: HRRZ B,A ; GET A PAGE
+ IDIVI B,16. ; DIVIDE SO AS TO PT TO PMAP WORD
+ PUSHJ P,PINIT ; SET UP PARAMETER
+ LSH D,-1
+ TDO E,D ; FIX UP WORD
+ MOVEM E,PMAPB(B) ; SEND IT BACK
+ AOBJN A,FIXPMP
+
+ SUB P,[1,,1]
+ MOVE A,[PUSHJ P,PURTFX] ; FIX UP PURE ATOM POINTERS
+ MOVEI PVP,1 ; SAY MIGHT BE NON-ATOMS
+ PUSHJ P,GCHACK
+
+; NOW FIX UP POINTERS IN PURE STRUCTURE
+ PUSH P,GCSBOT ; SAVE GCSBOT AND GCSTOP
+ PUSH P,GCSTOP
+ MOVE A,MAPUP ; NEW GCSBOT AND TOP TO FOOL GCHACK
+ MOVEM A,GCSBOT
+ ADD A,NABOTN
+ SUBI A,2000 ; ADJUSTMENT FOR START ON PAGE ONE
+ MOVEM A,GCSTOP
+ MOVE A,[PUSHJ P,PURTFX]
+ MOVEI PVP,1 ; SAY MIGHT BE NON-ATOMS
+ PUSHJ P,GCHK10
+ POP P,GCSTOP
+ POP P,GCSBOT
+
+; HERE TO FIX UP ATOMS WITH TYPES HACKED INTO THEIR GROWTH FIELD
+
+ MOVE A,TYPVEC+1 ; GET TYPE VECTOR
+ MOVEI B,400000 ; TLOSE==0
+TTFIX: HRRZ D,1(A) ; GET ADDR
+ HLRE C,1(A)
+ SUB D,C
+ HRRM B,(D) ; SMASH IT IN
+NOTFIX: ADDI B,1 ; NEXT TYPE
+ ADD A,[2,,2]
+ JUMPL A,TTFIX
+
+; NOW CLOSE UP INFERIORS AND RETURN
+
+PURCLS: MOVE P,[-2000,,MRKPDL]
+ PUSHJ P,%RSTRP ;RESETORE RPMAP TABLE FOR TENEX
+ PUSHJ P,INFCLS
+
+ MOVE PVP,PVSTOR+1
+ MOVE P,PSTO+1(PVP) ; RESTORE P
+ MOVE AB,ABSTO+1(PVP) ; RESTORE R
+
+ MOVE A,INF3 ; GET PTR TO PURIFIED STRUCTURE
+ SKIPN NPRFLG
+ PUSHJ P,%PURIF ; PURIFY
+ PUSHJ P,%PURMD
+
+ SETZM GPURFL
+ JRST EPURIF ; FINISH UP
+
+NPRFIX: PUSH P,A
+ PUSH P,B
+ PUSH P,C
+ EXCH A,C
+ PUSHJ P,SAT ; GET STORAGE ALLOCATION TYPE
+ MOVE C,MAPUP ; FIXUP AMOUNT
+ SUBI C,FPAG ; ADJUST FOR START ON FIRST PAGE
+ CAIE A,SLOCR ; DONT HACK TLOCRS
+ CAIN A,S1WORD ; SKIP IF NOT OF PRIMTYPE WORD
+ JRST LSTFXP
+ CAIN A,SCHSTR
+ JRST STRFXP
+ CAIN A,SATOM
+ JRST ATMFXP
+ CAIN A,SOFFS
+ JRST OFFFXP ; FIXUP OFFSETS
+STRFXQ: HRRZ D,1(B)
+ JUMPE D,LSTFXP ; SKIP IF NIL
+ CAMG D,PURTOP ; SEE IF ALREADY PURE
+ ADDM C,1(B)
+LSTFXP: TLNN B,.LIST. ; SKIP IF NOT A PAIR
+ JRST LSTEX1
+ HRRZ D,(B) ; GET REST OF LIST
+ SKIPE D ; SKIP IF POINTS TO NIL
+ PUSHJ P,RLISTQ
+ JRST LSTEX1
+ CAMG D,PURTOP ; SKIP IF ALREADY PURE
+ ADDM C,(B) ; FIX UP LIST
+LSTEX1: POP P,C
+ POP P,B ; RESTORE GCHACK AC'S
+ POP P,A
+ POPJ P,
+
+OFFFXP: HLRZ 0,D ; POINT TO LIST
+ JUMPE 0,LSTFXP ; POINTS TO NIL
+ CAML 0,PURTOP ; ALREADY PURE?
+ JRST LSTFXP ; YES
+ ADD 0,C ; UPDATE THE POINTER
+ HRLM 0,1(B) ; STUFF IT OUT
+ JRST LSTFXP ; DONE
+
+STRFXP: TLZN D,STATM ; SKIP IF REALLY ATOM
+ JRST STRFXQ
+ MOVEM D,1(B)
+ PUSH P,C
+ MOVE C,B ; GET ARG FOR BYTDOP
+ PUSHJ P,BYTDOP
+ POP P,C
+ MOVEI D,-1(A)
+ JRST ATMFXQ
+
+ATMFXP: HLRE 0,D ; GET LENGTH
+ SUB D,0 ; POINT TO FIRST DOPE WORD
+ HRRZS D
+ATMFXQ: CAML D,OGCSTP
+ CAIL D,HIBOT ; SKIP IF IMPURE
+ JRST LSTFXP
+ HRRZ 0,1(D) ; GET RELOCATION
+ SUBI 0,1(D)
+ ADDM 0,1(B) ; FIX UP PTR IN STRUCTURE
+ JRST LSTFXP
+
+; FIXUP OF PURE ATOM POINTERS
+
+PURTFX: CAIE C,TATOM ; SKIP IF ATOM POINTER
+ JRST PURSFX
+ HLRE E,D ; GET TO DOPE WORD
+ SUBM D,E
+PURSF1: SKIPL 1(E) ; SKIP IF MARKED
+ POPJ P,
+ HRRZ 0,1(E) ; RELATAVIZE PTR
+ SUBI 0,1(E)
+ ADD D,0 ; FIX UP PASSED POINTER
+ SKIPE B ; AND IF APPROPRIATE MUNG POINTER
+ ADDM 0,1(B) ; FIX UP POINTER
+ POPJ P,
+
+PURSFX: CAIE C,TCHSTR
+ POPJ P,
+ MOVE C,B ; GET ARG FOR BYTDOP
+ PUSHJ P,BYTDOP
+ GETYP 0,-1(A)
+ MOVEI E,-1(A)
+ MOVE A,[PUSHJ P,PURTFX]
+ CAIE 0,SATOM
+ POPJ P,
+ JRST PURSF1
+
+PURFIX: PUSH P,D
+ PUSH P,A
+ PUSH P,B
+ PUSH P,C ; SAVE AC'S FOR GCHACK
+ EXCH A,C ; GET TYPE IN A
+ CAIN A,TATOM ; CHECK FOR ATOM
+ JRST ATPFX
+ PUSHJ P,SAT
+
+ CAILE A,NUMSAT ; SKIP IF TEMPLATE
+ JRST TLFX
+IFN ITS, JRST @PURDSP(A)
+IFE ITS,[
+ HRRZ 0,PURDSP(A)
+ HRLI 0,400000
+ JRST @0
+]
+PURDSP:
+
+OFFSET 0
+
+DISTBS DUM1,TLFX,[[S2WORD,LPLSTF],[S2DEFR,LPLSTF],[SNWORD,VECFX],
+[S2NWORD,VECFX],[SSTORE,VECFX],[SBYTE,STRFX],[SATOM,ATPFX],[SLOCB,STRFX]
+[SCHSTR,STRFX],[SLOCL,LPLSTF],[SLOCV,VECFX],[SLOCU,VECFX],[SLOCS,VECFX],[SOFFS,OFFSFX]]
+
+OFFSET OFFS
+
+VECFX: HLRE 0,D ; GET LENGTH
+ SUB D,0 ; POINT TO D.W.
+ SKIPL 1(D) ; SKIP IF MARKED
+ JRST TLFX
+ HRRZ C,1(D)
+ SUBI C,1(D) ; CALCULATE RELOCATION
+ ADD C,MAPUP ; ADJUSTMENT
+ SUBI C,FPAG
+ ADDM C,1(B)
+TLFX: TLNN B,.LIST. ; SEE IF PAIR
+ JRST LVPUR ; LEAVE IF NOT
+ PUSHJ P,RLISTQ
+ JRST LVPUR
+ HRRZ D,(B) ; GET CDR
+ SKIPN D ; SKIP IF NOT ZERO
+ JRST LVPUR
+ MOVE D,(D) ; GET CADR
+ SKIPL D ; SKIP IF MARKED
+ JRST LVPUR
+ ADD D,MAPUP
+ SUBI D,FPAG
+ HRRM D,(B) ; FIX UP
+LVPUR: POP P,C
+ POP P,B
+ POP P,A
+ POP P,D
+ POPJ P,
+
+STRFX: MOVE C,B ; GET ARG FOR BYTDOP
+ PUSHJ P,BYTDOP
+ SKIPL (A) ; SKIP IF MARKED
+ JRST TLFX
+ GETYP 0,-1(A)
+ MOVE D,1(B)
+ MOVEI C,-1(A)
+ CAIN 0,SATOM ; REALLY ATOM?
+ JRST ATPFX1
+ HRRZ 0,(A) ; GET PTR IN NEW STRUCTURE
+ SUBI 0,(A) ; RELATAVIZE
+ ADD 0,MAPUP ; ADJUST
+ SUBI 0,FPAG
+ ADDM 0,1(B) ; FIX UP PTR
+ JRST TLFX
+
+ATPFX: HLRE C,D
+ SUBM D,C
+ SKIPL 1(C) ; SKIP IF MARKED
+ JRST TLFX
+ATPFX1: HRRZS C ; SEE IF PURE
+ CAIL C,HIBOT ; SKIP IF NOT PURE
+ JRST TLFX
+ HRRZ 0,1(C) ; GET PTR TO NEW ATOM
+ SUBI 0,1(C) ; RELATAVIZE
+ ADD D,0
+ JUMPE B,TLFX
+ ADDM 0,1(B) ; FIX UP
+ JRST TLFX
+
+LPLSTF: SKIPN D ; SKIP IF NOT PTR TO NIL
+ JRST TLFX
+ SKIPL (D) ; SKIP IF MARKED
+ JRST TLFX
+ HRRZ D,(D) ; GET UPDATED POINTER
+ ADD D,MAPUP ; ADJUSTMENT
+ SUBI D,FPAG
+ HRRM D,1(B)
+ JRST TLFX
+
+OFFSFX: HLRZS D ; LIST POINTER
+ JUMPE D,TLFX ; NIL
+ SKIPL (D) ; MARKED?
+ JRST TLFX ; NO
+ ADD D,MAPUP
+ SUBI D,FPAG ; ADJUST
+ HRLM D,1(B)
+ JRST TLFX ; RETURN
+
+; ROUTINES TO CAUSE A GARBAGE COLLECT WHEN EFFORTS TO GET STORAGE FAIL
+
+LOSLP1: MOVE A,ABOTN
+ MOVEM A,PARNEW ; SET UP GC PARAMS
+ MOVE C,[12.,,6]
+ JRST PURLOS
+
+LOSLP2: MOVEI A,@BOTNEW ; TOTAL AMOUNT NEEDED
+ ADDI A,1777
+ ANDCMI A,1777 ; CALCULATE PURE PAGES NEEDED
+ MOVEM A,GCDOWN
+ MOVE C,[12.,,8.]
+ JRST PURLOS
+
+PURLOS: MOVE P,[-2000,,MRKPDL]
+ PUSH P,GCDOWN
+ PUSH P,PARNEW
+ MOVE R,C ; GET A COPY OF A
+ PUSHJ P,INFCLS ; CLOSE INFERIORS AND FIX UP WORLD
+ PUSHJ P,INFCL2
+PURLS1: POP P,PARNEW
+ POP P,GCDOWN
+ MOVE C,R
+
+; RESTORE AC'S
+ MOVE PVP,PVSTOR+1
+ IRP AC,,[P,R,M,TP,TB,AB,FRM]
+ MOVE AC,AC!STO+1(PVP)
+ TERMIN
+
+ SETZM GCDFLG ; ZERO OUT FLAGS
+ SETZM DUMFLG
+ SETZM GPURFL
+ SETZM GCDANG
+
+ PUSHJ P,AGC ; GARBAGE COLLECT
+ JRST PURIT1 ; TRY AGAIN
+
+; PURIFIER ATOM MARKER
+
+PATOMK: HRRZ 0,A
+ CAMG 0,PARBOT
+ JRST GCRET ; DONE IF FROZEN
+ HLRE B,A ; GET TO D.W.
+ SUB A,B
+ SKIPG 1(A) ; SKIP IF NOT MARKED
+ JRST GCRET
+ HLRZ B,1(A)
+ IORM D,1(A) ; MARK THE ATOM
+ ADDM B,ABOTN
+ HRRM LPVP,(A) ; LINK ONTO CHAIN
+ MOVEI LPVP,1(A)
+ JRST GCRET ; EXIT
+
+\f
+.GLOBAL %LDRDO,%MPRDO
+
+; ROUTINES TO ALLOW GC-DUMPING OF PURIFIED STRUCTURES.
+
+; PROPUR MAPS PAGES CONTAINING PURIFIED STUFF INTO THE AGD INFERIOR SO THAT IN CASE
+; THE PAGES ARE MUNGED THEY CAN BE RESTORED USING MAPPING
+
+; REPURE REMAPS ANY PAGES THAT WERE MUNGED BY GC-DUMP BY RELOADING THEM FROM THE AGD
+; INFERIOR IN READ/EXEC MODE
+
+REPURE: PUSH P,[PUSHJ P,%LDRDO] ; INSTRUCTION FOR MAPPING IN PAGES FROM AGD INF
+ SKIPA
+PROPUR: PUSH P,[PUSHJ P,%MPRDO] ; INSTRUCTION FOR MAPPING PAGES TO AGD INF
+ MOVE A,PURBOT ; GET STARTING PAGE OF PURENESS
+ ASH A,-10. ; CONVERT TO PAGES
+ MOVEI C,HIBOT ; GET ENDING PAGE
+ ASH C,-10. ; CONVERT TO PAGES
+ PUSH P,A ; SAVE PAGE POINTER
+ PUSH P,C ; SAVE END OF PURENESS POINTER
+PROLOP: CAML A,(P) ; SKIP IF STILL PURE PAGES TO CHECK
+ JRST PRODON ; DONE MAPPING PAGES
+ PUSHJ P,CHKPGI ; SKIP IF PAGE IS PURE
+ JRST NOTPUR ; IT IS NOT
+ MOVE A,-1(P) ; GET PAGE TO MAP
+ XCT -2(P) ; MAP IN/OUT TO AGD INFERIOR IN READ/EXEC MODE
+NOTPUR: AOS A,-1(P) ; INCREMENT PAGE POINTER AND LOAD
+ JRST PROLOP ; LOOP BACK
+PRODON: SUB P,[3,,3] ; CLEAN OFF STACK
+ POPJ P, ; EXIT
+
+
+\f
+.GLOBAL %SAVIN,STOSTR,%CLMP1,%IMSAV,%IMSV1,ILOOKC,PSHGCF,BSETG,%GCJB1
+.GLOBAL %CLSJB,%KILJB,%IFMP1,%OPGFX,%FDBUF
+INFSU1: PUSH P,[-1] ; ENTRY USED BY GC-DUMP
+ SKIPA
+INFSUP: PUSH P,[0]
+ MOVE A,GLOTOP+1 ; GET GLOTOP FOR LOCR HACKS
+ MOVEM A,GLTOP
+ PUSHJ P,%FDBUF ; GET A BUFFER FOR C/W HACKS
+ SETOM GCDFLG
+ SETOM GCFLG
+ HLLZS SQUPNT
+ HRRZ TYPNT,TYPVEC+1 ; SETUP TYPNT
+ HRLI TYPNT,B
+ MOVEI A,STOSTR
+ ANDCMI A,1777 ; TO PAGE BOUNDRY
+ SUB A,GCSTOP ; SET UP AOBJN POINTER FOR C/W HACK
+ ASH A,-10. ; TO PAGES
+ HRLZS A
+ MOVEI B,STOSTR ; GET START OF MAPPING
+ ASH B,-10.
+ ADDI A,(B)
+ MOVEM A,INF1
+ PUSHJ P,%SAVIN ; PROTECT THE CORE IMAGE
+ SKIPGE (P) ; IF < 0 GC-DUMP CALL
+ PUSHJ P,PROPUR ; PROTECT PURE PAGES
+ SUB P,[1,,1] ; CLEAN OFF PSTACK
+ PUSHJ P,%CLSJB ; CLOSE INFERIOR
+
+ MOVSI D,400000 ; CREATE MARK WORD
+ SETZB LPVP,ABOTN ; ZERO ATOM COUNTER
+ MOVEI A,2000 ; MARKED INF STARTS AT PAGE ONE
+ HRRM A,BOTNEW
+ SETZM WNDBOT
+ SETZM WNDTOP
+ HRRZM A,FNTBOT
+ ADDI A,2000 ; WNDTOP
+ MOVEI A,1 ; TO PAGES
+ PUSHJ P,%GCJB1 ; CREATE THE JOB
+ MOVSI FPTR,-2000
+ MOVEI A,LPUR ; SAVE THE PURE CORE IMAGE
+ ANDCMI A,1777 ; TO PAGE BOUNDRY
+ MOVE 0,A ; COPY TO 0
+ ASH 0,-10. ; TO PAGES
+ SUB A,HITOP ; SUBTRACT TOP OF CORE
+ ASH A,-10.
+ HRLZS A
+ ADD A,0
+ MOVEM A,INF2
+ PUSHJ P,%IMSV1 ; MAP OUT INTERPRETER
+ PUSHJ P,%OPGFX
+
+; CREATE A PDL TO USE FOR THESE DUMPING FUNCTIONS
+
+ MOVE A,[-2000,,MRKPDL]
+ POPJ P,
+
+; ROUTINE TO CLOSE GC's INFERIOR
+
+
+INFCLS: MOVE A,INF2 ; GET POINTER TO PURE MAPPED OUT
+ PUSHJ P,%CLSMP
+ POPJ P,
+
+; CLOSE INFERIOR PROTECTING CORE IMAGE FOR GCDUMP
+
+INFCL2: PUSHJ P,%IFMP1 ; OPEN AGD INF TO RESTORE PAGES
+INFCL3: MOVE A,INF1 ; RESTORE OPENING POINTER
+ PUSH P,INF2
+ MOVE B,A ; SATIFY MUDITS
+ PUSHJ P,%IFMP2 ; MAP IN GC PAGES AND CLOSE INFERIOR
+ POP P,INF2 ; RESTOR INF2 PARAMETER
+ POPJ P,
+
+INFCL1: PUSHJ P,%IFMP1 ; OPEN AGD INF TO RESTORE PAGES
+ SKIPGE PURMNG ; SKIP IF NO PURE PAGES WERE MUNGED
+ PUSHJ P,REPURE ; REPURIFY MUNGED PAGES
+ JRST INFCL3
+
+\f
+
+; ROUTINE TO DO TYPE HACKING FOR GC-DUMP. IT MARKS THE TYPE-WORD OF THE
+; SLOT IN THE TYPE VECTOR. IT ALSO MARKS THE ATOM REPLACING THE I.D. IN
+; THE RIGHT HALF OF THE ATOM SLOT. IF THE TYPE IS A TEMPLATE THE FIRST
+; USE OF THE SAT HAS ITS ATOM MARKED AND THE I.D. IS PLACED IN THE LEFT
+; HALF OF THE ATOM SLOT (IT GETS THE REAL PRIMTYPE).
+
+TYPHK: CAILE B,NUMPRI ; SKIP IF A MUDDLE TYPE
+ JRST TYPHKR ; ITS A NEWTYPE SO GO TO TYPHACKER
+ CAIN B,TTYPEC ; SKIP IF NOT TYPE-C
+ JRST TYPCHK ; GO TO HACK TYPE-C
+ CAIE B,TTYPEW ; SKIP IF TYPE-W
+ POPJ P,
+ PUSH P,B
+ HLRZ B,A ; GET TYPE
+ JRST TYPHKA ; GO TO TYPE-HACKER
+TYPCHK: PUSH P,B ; SAVE TYPE-WORD
+ HRRZ B,A
+ JRST TYPHKA
+
+; GENERAL TYPE-HACKER FOR GC-DUMP
+
+TYPHKR: PUSH P,B ; SAVE AC'S
+TYPHKA: PUSH P,A
+ PUSH P,C
+ LSH B,1 ; GET OFFSET TO SLOT IN TYPE VECTOR
+ MOVEI C,(TYPNT) ; GET TO SLOT
+ ADDI C,(B)
+ SKIPGE (C)
+ JRST EXTYP
+ IORM D,(C) ; MARK THE SLOT
+ MOVEI B,TATOM ; NOW MARK THE ATOM SLOT
+ PUSHJ P,MARK1 ; MARK IT
+ HRRM A,1(C) ; SMASH IN ID
+ HRRZS 1(C) ; MAKE SURE THAT THATS ALL THATS THERE
+ HRRZ B,(C) ; GET SAT
+ ANDI B,SATMSK ; GET RID OF MAGIC BITS
+ HRRM B,(C) ; SMASH SAT BACK IN
+ CAIG B,NUMSAT ; SKIP IF TEMPLATE
+ JRST EXTYP
+ MOVE A,TYPSAV ; GET POINTER TO TYPE VECTOR
+ ADDI A,NUMPRI*2 ; GET TO NEWTYPES SLOTS
+ HRLI 0,NUMPRI*2
+ HLLZS 0 ; MAKE SURE ONLY LEFT HALF
+ ADD A,0
+TYPHK1: HRRZ E,(A) ; GET SAT OF SLOT
+ CAMN E,B ; SKIP IF NOT EQUAL
+ JRST TYPHK2 ; GOT IT
+ ADDI A,2 ; TO NEXT
+ JRST TYPHK1
+TYPHK2: PUSH P,C ; SAVE POINTER TO ORIGINAL SLOT
+ MOVE C,A ; COPY A
+ MOVEI B,TATOM ; SET UP FOR MARK
+ MOVE A,1(C) ; ASSUME MARK DOESN'T HAVE TO TAKE PLACE
+ SKIPL (C) ; DON'T MARK IF ALREADY MARKED
+ PUSHJ P,MARK
+ POP P,C ; RESTORE C
+ HRLM A,1(C) ; SMASH IN PRIMTYPE OF TEMPLATE
+EXTYP: POP P,C ; RESTORE AC'S
+ POP P,A
+ POP P,B
+ POPJ P, ; EXIT
+
+
+; A ROUTINE TO DISTINGUISH BETWEEN A DEFERRED AND A LIST POINTER
+RLISTQ: PUSH P,A
+ GETYP A,(B) ; GET TYPE
+ PUSHJ P,SAT ; GET SAT
+ CAIG A,NUMSAT ; NOT DEFERRED IF TEMPLATE
+ SKIPL MKTBS(A)
+ AOS -1(P) ; SKIP IF NOT DEFFERED
+ POP P,A
+ POPJ P, ; EXIT
+
+
+; DISPATCH TABLE FOR MARK PHASE ("SETZ'D" ENTRIES MUST BE DEFERRED)
+
+GCDISP:
+
+OFFSET 0
+
+DISTBS DUM2,GCRET,[[S2WORD,PAIRMK],[S2DEFR,DEFMK],[SNWORD,VECTMK],[STBASE,ERDP]
+[STPSTK,ERDP],[SARGS,ERDP],[S2NWORD,VECTMK],[SPSTK,ERDP],[SSTORE,VECTMK]
+[SFRAME,ERDP],[SBYTE,<SETZ BYTMK>],[SATOM,DATOMK],[SPVP,ERDP],[SGATOM,ERDP]
+[SLOCID,ERDP],[SCHSTR,<SETZ BYTMK>],[SASOC,ERDP],[SLOCL,PAIRMK],[SABASE,ERDP]
+[SLOCA,ERDP],[SLOCV,VECTMK],[SLOCU,VECTMK],[SLOCS,<SETZ BYTMK>],[SLOCN,ERDP]
+[SLOCB,<SETZ BYTMK>],[SLOCR,LOCRDP],[SOFFS,OFFSMK]]
+
+OFFSET OFFS
+
+\f
+; THIS SUBROUTINE IMPURIFIES A PURE ATOM TO ALLOW MODIFICATION OF SYSTEM SUBRS
+
+IMPRF: PUSH P,A
+ PUSH P,LPVP
+ PUSH TP,$TATOM
+ HLRZ C,(A) ; GET LENGTH
+ TRZ C,400000 ; TURN OF 400000 BIT
+ SUBI A,-1(C) ; POINT TO START OF ATOM
+ MOVNI C,-2(C) ; MAKE IT LOOK LIKE AN ATOM POINTER
+ HRL A,C
+ PUSH TP,A
+ MOVE C,A
+ MOVEI 0,(C)
+ PUSH P,AB
+ MOVE PVP,PVSTOR+1
+ MOVE AB,ABSTO+1(PVP)
+ PUSHJ P,IMPURX
+ POP P,AB
+ POP P,LPVP ; RESTORE A
+ POP P,A
+ POPJ P,
+
+FIXATM: PUSH P,[0]
+FIXTM5: JUMPE LPVP,FIXTM4
+ MOVEI B,(LPVP) ; GET PTR TO ATOMS DOPE WORD
+ HRRZ LPVP,-1(B) ; SET UP LPVP FOR NEXT IN CHAIN
+ SKIPE -2(P) ; SEE IF PURE SCAN
+ JRST FIXTM2
+ CAIL B,HIBOT
+ JRST FIXTM3
+FIXTM2: CAMG B,PARBOT ; SKIP IF NOT FROZEN
+ JRST FIXTM1
+ HLRZ A,(B)
+ TRZ A,400000 ; GET RID OF MARK BIT
+ MOVE D,A ; GET A COPY OF LENGTH
+ SKIPE -2(P)
+ JRST PFATM
+ PUSHJ P,CAFREE ; GET STORAGE
+ SKIPE GCDANG ; SEE IF WON
+ JRST LOSLP1 ; GO TO CAUSE GC
+ JRST FIXT10
+PFATM: PUSH P,AB
+ MOVE PVP,PVSTOR+1
+ MOVE AB,ABSTO+1(PVP)
+ SETZM GPURFL
+ PUSHJ P,CAFREE
+ SETOM GPURFL
+ POP P,AB
+FIXT10: SUBM D,ABOTN
+ MOVNS ABOTN
+ SUBI B,-1(D) ; POINT TO START OF ATOM
+ HRLZ C,B ; SET UP FOR BLT
+ HRRI C,(A)
+ ADDI A,-1(D) ; FIX UP TO POINT TO NEW DOPE WORD
+ BLT C,(A)
+ HLLZS -1(A)
+ HLLOS (A) ; -1 IN RELOCATION FIELD SINCE ITS NOT GARBAGE
+ ADDI B,-1(D) ; B POINTS TO SECOND D.W.
+ HRRM A,(B) ; PUT IN RELOCATION
+ MOVSI D,400000 ; UNMARK ATOM
+ ANDCAM D,(A)
+ CAIL B,HIBOT ; SKIP IF IMPURE
+ PUSHJ P,IMPRF
+ JRST FIXTM5 ; CONTINE FIXUP
+
+FIXTM4: POP P,LPVP ; FIX UP LPVP TO POINT TO NEW CHAIN
+ POPJ P, ; EXIT
+
+FIXTM1: HRRM B,(B) ; SMASH IN RELOCATION
+ MOVSI D,400000
+ ANDCAM D,(B) ; CLEAR MARK BIT
+ JRST FIXTM5
+
+FIXTM3: MOVE 0,(P)
+ HRRM 0,-1(B)
+ MOVEM B,(P) ; FIX UP CHAIN
+ JRST FIXTM5
+
+
+\f
+IAGC":
+
+;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 /GIN /]
+ 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: SUB P,[1,,1] ; POP OFF C
+ POP P,A
+ POP P,B
+ EXCH P,GCPDL
+ JRST .+1
+IAAGC:
+ HLLZS SQUPNT ; FLUSH SQUOZE TABLE
+ SETZB M,RCL ; ALTERNATE GC-ENTRY POINT FOR INITIALIZATION
+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,B
+
+CHPDL: MOVE D,P ; SAVE FOR LATER
+CORGET: MOVE P,[-2000,,MRKPDL]
+
+;FENCE POST PDLS AND CHECK IF ANY SHOULD BE SHRUNK
+
+ MOVEI 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
+ HRRM A,BOTNEW ; INTO POINTER WORD
+ HRRZM A,FNTBOT
+ SETZM WNDBOT
+ SETZM WNDTOP
+ MOVEM A,NPARBO
+ HRRZ A,BOTNEW ; GET PAGE TO START INF AT
+ ASH A,-10. ; TO PAGES
+ MOVEI R,(A) ; COPY A
+ PUSHJ P,%GCJOB ; GET PAGE HOLDER
+ MOVSI FPTR,-2000 ; FIX UP FRONTIER POINTER
+ MOVE A,WNDBOT
+ ADDI A,2000 ; FIND WNDTOP
+ MOVEM A,WNDTOP
+
+;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; MAP NEW PAIR SPACE IN FOR PAIR SPACE UPDATE
+
+NOMAP1: MOVEI A,@BOTNEW
+ ADDI A,1777 ; TO PAGE BOUNDRY
+ ANDCMI A,1777
+ MOVE B,A
+DOMAP: ASH B,-10. ; TO PAGES
+ MOVE A,PARBOT
+ MOVEI C,(A) ; COMPUTE HIS TOP
+ ASH C,-10.
+ ASH A,-10.
+ SUBM A,B ; B==> - # OF PAGES
+ HRLI A,(B) ; AOBJN TO SOURCE AND DEST
+ MOVE B,A ; IN CASE OF FUNNY
+ HRRI B,(C) ; MAP HIS POSSIBLE HIGHER OR LOWER PAGES
+ PUSHJ P,%INFMP ; NOW FLUSH INF AND MAKE HIS CORE MINE
+ JRST GARZER
+
+\f; CORE ADJUSTMENT PHASE
+
+CORADJ: MOVE A,PURTOP
+ SUB A,CURPLN ; ADJUST FOR RSUBR
+ ANDCMI A,1777 ; ROUND DOWN
+ MOVEM A,RPTOP
+ MOVEI A,@BOTNEW ; 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
+ MOVEI A,@BOTNEW ; GCSTOP
+ MOVEM A,GCSTOP
+ MOVE A,CORTOP ; ADJUST CORE IMAGE
+ ASH A,-10. ; TO PAGES
+TRYPCO: PUSHJ P,P.CORE
+ FATAL AGC--CORE SCREW UP
+ 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
+ MOVEI A,@BOTNEW
+ 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
+CORAD8: MOVEM A,CORTOP ; ADJUST PARAMETER
+ JRST CORAD6 ; WIN TOTALLY
+
+; 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;GARBAGE ZEROING PHASE
+GARZER: MOVE A,GCSTOP ;FIRST WORD OF GARBAGE IS AFTER PAIR SPACE
+ MOVE B,FRETOP ;LAST ADDRESS OF GARBAGE + 1
+ CAIL A,(B)
+ JRST GARZR1
+ CLEARM (A) ;ZERO THE FIRST WORD
+ CAIL A,-1(B) ; ARE WE AT THE TOP OF THE WORLD (FORMERLY CAML A,FRETOP)
+ JRST GARZR1 ; DON'T BLT
+IFE ITS,[
+ MOVEI B,777(A)
+ ANDCMI B,777
+]
+ HRLS A
+ ADDI A,1 ;MAKE A A BLT POINTER
+ BLT A,-1(B) ;AND COPY ZEROES INTO REST OF AREA
+IFE ITS,[
+
+; MAP UNWANTED PAGES OUT ON TWENEX (AFTER ZEROING REST OF LAST PAGE)
+
+ MOVE D,PURBOT
+ ASH D,-PGSZ
+ ASH B,-PGSZ
+ MOVNI A,1
+ MOVEI C,0
+ HRLI B,400000
+
+GARZR2: CAIG D,(B)
+ JRST GARZR1
+
+ PMAP
+ AOJA B,GARZR2
+]
+
+
+; 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 IAGC
+
+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 ; LOADING ONE, M = 0 IS OK
+ JRST FINAGC
+
+ FATAL AGC--RUNNING RSUBR WENT AWAY
+
+AGCE1: FATAL AGC--TYPE VECTOR NOT OF TYPE VECTOR
+
+\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
+ 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,[111100,,-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 F,1(A) ; GET LNTH
+ LDB 0,[111100,,(A)] ; GET GROWTHS
+ TRZE 0,400 ; SIGN HACK
+ MOVNS 0
+ ASH 0,6 ; TO WORDS
+ ADD F,0
+ LDB 0,[001100,,(A)]
+ TRZE 0,400
+ MOVNS 0
+ ASH 0,6
+ ADD F,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: SKIPN DUMFLG
+ JUMPE A,CPOPJ ; NEVER MARK 0
+ MOVEI 0,1(A)
+ CAIL 0,@PURBOT
+ JRST GCRETD
+MARCON: PUSH P,A
+ HRLM C,-1(P) ;AND POINTER TO IT
+ ANDI B,TYPMSK ; FLUSH MONITORS
+ SKIPE DUMFLG ; SKIP IF NOT IN DUMPER
+ PUSHJ P,TYPHK ; HACK SOME TYPES
+ 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
+ SKIPN GCDFLG
+IFN ITS,[
+ JRST @MKTBS(B) ;AND GO MARK
+ JRST @GCDISP(B) ; DISPATCH FOR DUMPERS
+]
+IFE ITS,[
+ SKIPA E,MKTBS(B)
+ MOVE E,GCDISP(B)
+ HRLI E,-1
+ JRST (E)
+]
+; 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: TLOA TYPNT,400000 ;USE SIGN BIT AS FLAG
+
+;HERE TO MARK LIST ELEMENTS
+
+PAIRMK: TLZ TYPNT,400000 ;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
+ SKIPL FPTR ; SEE IF IN FRONTEIR
+ PUSHJ P,MOVFNT ; EXPAND THE FRONTEIR
+ MOVEM B,FRONT(FPTR)
+ MOVE 0,1(C) ; AND 2D
+ AOBJN FPTR,.+2 ; AOS AND CHECK FRONTEIR
+ PUSHJ P,MOVFNT ; EXPAND FRONTEIR
+ MOVEM 0,FRONT(FPTR)
+ ADD FPTR,[1,,1] ; MOVE ALONG IN FRONTIER
+
+
+PAIRM2: MOVEI A,@BOTNEW ; GET INF ADDR
+ SUBI A,2
+ HRRM A,(C) ; LEAVE A POINTER TO NEW HOME
+ HRRZ E,(P) ; GET BACK POINTER
+ JUMPE E,PAIRM7 ; 1ST ONE, NEW FIXUP
+ MOVSI 0,(HRRM) ; INS FOR CLOBBER
+ PUSHJ P,SMINF ; SMASH INF'S CORE IMAGE
+PAIRM4: MOVEM A,(P) ; NEW BACK POINTER
+ JUMPL TYPNT,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
+ ADDI E,1
+ MOVSI 0,(MOVEM)
+ PUSHJ P,SMINF
+ 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: SUB P,[1,,1]
+
+GCRET: TLZ TYPNT,400000 ;FOR PAIRMKS BENEFIT
+ HLRZ C,-1(P) ;RESTORE C
+ POP P,A
+ POPJ P, ;AND RETURN TO CALLER
+
+GCRETD: ANDI B,TYPMSK ; TURN OFF MONITORS
+ CAIN B,TLOCR ; SEE IF A LOCR
+ JRST MARCON
+ SKIPN GCDFLG ; SKIP IF IN PURIFIER OR DUMPER
+ POPJ P,
+ CAIE B,TATOM ; WE MARK PURE ATOMS
+ CAIN B,TCHSTR ; AND STRINGS
+ 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
+ PUSHJ P,MARK2 ;MARK THE DATUM
+ HRRZ E,-2(P) ; GET POINTER IN INF CORE
+ ADDI E,1
+ MOVSI 0,(MOVEM)
+ PUSHJ P,SMINF ; AND CLOBBER
+ HRRZ E,-2(P)
+ MOVE A,-1(P)
+ MOVSI 0,(HRRM) ; SMASH IN RIGHT HALF
+ PUSHJ P,SMINF
+ SUB P,[3,,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
+ MOVSI 0,(HRRM)
+ PUSHJ P,SMINF
+ JRST GCRETP
+
+RETNW1: MOVEM A,-1(P)
+ JRST GCRETP
+
+; ROUTINE TO EXPAND THE FRONTEIR
+
+MOVFNT: PUSH P,B ; SAVE REG B
+ HRRZ A,BOTNEW ; CURRENT BOTTOM OF WINDOW
+ ADDI A,2000 ; MOVE IT UP
+ HRRM A,BOTNEW
+ HRRZM A,FNTBOT ; BOTTOM OF FRONTEIR
+ MOVEI B,FRNP
+ ASH A,-10. ; TO PAGES
+ PUSHJ P,%GETIP
+ PUSHJ P,%SHWND ; SHARE THE PAGE
+ MOVSI FPTR,-2000 ; FIX UP FPTR
+ POP P,B
+ POPJ P,
+
+
+; ROUTINE TO SMASH INFERIORS PPAGES
+; E/ ADDR IN INF, A/ THING TO SMASH ,0/ INS TO USE
+
+SMINF: CAMGE E,FNTBOT
+ JRST SMINF1 ; NOT IN FRONTEIR
+ SUB E,FNTBOT ; ADJUST POINTER
+ IOR 0,[0 A,FRONT(E)] ; BUILD INSTRUCTION
+ XCT 0 ; XCT IT
+ POPJ P, ; EXIT
+SMINF1: CAML E,WNDBOT
+ CAML E,WNDTOP ; SEE IF IN WINDOW
+ JRST SMINF2
+SMINF3: SUB E,WNDBOT ; FIX UP
+ IOR 0,[0 A,WIND(E)] ; FIX INS
+ XCT 0
+ POPJ P,
+SMINF2: PUSH P,A ; SAVE E
+ PUSH P,B ; SAVE B
+ HRRZ A,E ; E SOMETIMES HAS STUFF IN LH
+ ASH A,-10.
+ MOVEI B,WNDP ; WINDOW PAGE
+ PUSHJ P,%SHWND ; SHARE IT
+ ASH A,10. ; TO PAGES
+ MOVEM A,WNDBOT ; UPDATE POINTERS
+ ADDI A,2000
+ MOVEM A,WNDTOP
+ POP P,B ; RESTORE ACS
+ POP P,A
+ JRST SMINF3 ; FIX UP INF
+
+
+
+\f; VECTOR AND TP MARKER, SIGN OF TYPNT IS SET BASED ON WHICH ONE
+
+TPMK: TLOA TYPNT,400000 ;SET TP MARK FLAG
+VECTMK: TLZ TYPNT,400000
+ MOVEI 0,@BOTNEW ; POINTER TO INF
+ PUSH P,0
+ 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
+
+ HLLM TYPNT,(P) ; SAVE MARKER INDICATING STACK
+ JUMPGE TYPNT,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,[111100,,-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,[001100,,-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 F,(E) ;SAVE A COPY
+ ADD F,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
+ SKIPGE B,-1(A) ;SKIP IF UNIFORM
+ TLNE B,377777-.VECT. ;SKIP IF NOT SPECIAL
+ JUMPGE TYPNT,NOTGEN ;JUMP IF NOT A GENERAL VECTOR
+
+GENRAL: HLRZ 0,B ;CHECK FOR PSTACK
+ TRZ 0,.VECT.
+ JUMPE 0,NOTGEN ;IT ISN'T GENERAL
+ JUMPL TYPNT,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
+ HRRZ E,-1(P) ; GET POINTER INTO INF
+ SKIPN C ; SKIP IF NO BOTTOM GROWTH
+ JRST MOVEC3
+ JUMPL C,.+3 ; SEE IF BOTTOM SHRINKAGE
+ ADD E,C ; GROW IT
+ JRST MOVEC3 ; CONTINUE
+ HRLM C,E ; MOVE SHRINKAGE FOR TRANSFER PHASE
+MOVEC3: PUSHJ P,DOPMOD ; MODIFY DOPE WORD AND PLACE IN INF
+ PUSHJ P,TRBLKV ; SEND VECTOR INTO INF
+TGROT: CAMGE A,PARBOT ; SKIP IF NOT STORAGE
+ JRST TGROT1
+ MOVE C,DOPSV1 ; RESTORE DOPE WORD
+ SKIPN (P) ; DON'T RESTORE D.W.'S YET IF THERE IS GROWTH
+ MOVEM C,-1(A)
+TGROT1: POP P,C ; IS THERE TOP GROWH
+ SKIPN C ; SEE IF ANY GROWTH
+ JRST DOPEAD
+ SUBI E,2
+ SKIPG C
+ JRST OUTDOP
+ PUSH P,C ; SAVE C
+ SETZ C, ; ZERO C
+ PUSHJ P,ADWD
+ ADDI E,1
+ SETZ C, ; ZERO WHERE OLD DOPE WORDS WERE
+ PUSHJ P,ADWD
+ POP P,C
+ ADDI E,-1(C) ; MAKE ADJUSTMENT FOR TOP GROWTH
+OUTDOP: PUSHJ P,DOPOUT
+DOPEAD:
+EXVECT: HLRZ B,(P)
+ SUB P,[1,,1] ; GET RID OF FPTR
+ PUSHJ P,RELATE ; RELATIVIZE
+ TRNN B,400000 ; WAS THIS A STACK
+ JRST 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
+ POP P,C
+ 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
+ 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)
+ PUSHJ P,OUTTP ; MOVE OUT TYPE
+ MOVE A,R
+ PUSHJ P,OUTTP ; SEND OUT VALUE
+ 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)
+ PUSHJ P,OUTTP ; SEND IT OUT
+ 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)
+ PUSHJ P,OUTTP ; SEND IT OUT
+ MOVE A,-2(P) ; ADJUST AB SLOT
+ ADD A,ABSAV-FSAV+1(C) ; POINT TO SAVED AB
+ PUSHJ P,OUTTP ; SEND IT OUT
+ 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
+ PUSHJ P,OUTTP ; SEND IT OUT
+ HRROI C,PSAV-FSAV(C) ;POINT TO SAVED P
+ MOVEI B,TPDL
+ PUSHJ P,MARK1 ;AND MARK IT
+ PUSHJ P,OUTTP ; SEND IT OUT
+ 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
+ PUSHJ P,OUTTP
+ MOVE A,PCSAV-PSAV+1(C)
+ PUSHJ P,OUTTP
+ 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)
+ PUSHJ P,OUTTP ; FIX UP CHAIN
+ MOVEI B,TATOM ; RESTORE IN CASE SMASHED
+ PUSHJ P,MARK1 ; MARK ATOM
+ PUSHJ P,OUTTP ; SEND IT OUT
+ 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)
+ PUSHJ P,OUTTP ; MOVE OUT TYPE
+ MOVE A,R
+ PUSHJ P,OUTTP ; SEND OUT VALUE
+ 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
+ PUSHJ P,OUTTP
+ SKIPL A,1(C) ; PREV LOC?
+ JRST NOTLCI
+ MOVEI B,TLOCI ; NOW MARK LOCATIVE
+ PUSHJ P,MARK1
+NOTLCI: PUSHJ P,OUTTP
+ 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
+ PUSHJ P,OUTTP
+ ADDI C,1 ; INCREMENT C FOR FENCE-POST
+ SUB P,[1,,1] ; CLEAN UP STACK
+ POP P,E ; GET UPDATED PTR TO INF
+ SUB P,[2,,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
+ PUSHJ P,DOPMOD ; FIX UP DOPE WORDS
+ PUSHJ P,DOPOUT ; SEND THEM OUT
+ JRST DOPEAD
+
+
+\f; ROUTINE TO ALLOCATE ROOM FOR VECTORS IN INFERIOR
+; F= # OF WORDS TO ALLOCATE
+
+ALLOGC: HRRZS A ; GET ABS VALUE
+ SKIPN GCDFLG ; SKIP IF IN DUMPER
+ CAML A,GCSBOT ; SKIP IF IN STORAGE
+ JRST ALOGC2 ; JUMP IF ALLOCATING
+ HRRZ 0,A
+ POPJ P,
+ALOGC2: PUSH P,A ; SAVE A
+ALOGC1: HLRE 0,FPTR ; GET ROOM LEFT
+ ADD 0,F ; SEE IF ITS ENOUGH
+ JUMPL 0,ALOCOK
+ MOVE F,0 ; MODIFY F
+ PUSH P,F
+ PUSHJ P,MOVFNT ; MOVE UP FRONTEIR
+ POP P,F
+ JRST ALOGC1 ; CONTINUE
+ALOCOK: ADD FPTR,F ; MODIFY FPTR
+ HRLZS F
+ ADD FPTR,F
+ POP P,A ; RESTORE A
+ MOVEI 0,@BOTNEW
+ SUBI 0,1 ; RELOCATION PTR
+ POPJ P, ; EXIT
+
+
+
+
+; TRBLK MOVES A VECTOR INTO THE INFERIOR
+; E= STARTING ADDR IN INF A= DOPE WORD OF VECTOR
+
+TRBLK: HRRZS A
+ SKIPE GCDFLG
+ JRST TRBLK7
+ CAMGE A,GCSBOT ; SEE IF IN GC-SPACE
+ JRST FIXDOP
+TRBLK7: PUSH P,A
+ HLRZ 0,(A)
+ TRZ 0,400000 ; TURN OFF GC FLAG
+ HRRZ F,A
+ HLRE A,E ; GET SHRINKAGE
+ ADD 0,A ; MUNG LENGTH
+ SUB F,0
+ ADDI F,1 ; F POINTS TO START OF VECTOR
+TRBLK2: HRRZ R,E ; SAVE POINTER TO INFERIOR
+ ADD E,0 ; E NOW POINTS TO FINAL ADDRESS+1
+ MOVE M,E ;SAVE E
+TRBLK1: MOVE 0,R
+ SUBI E,1
+ CAMGE R,FNTBOT ; SEE IF IN FRONTEIR
+ JRST TRBL10
+ SUB E,FNTBOT ; ADJUST E
+ SUB 0,FNTBOT ; ADJ START
+ MOVEI A,FRONT+1777
+ JRST TRBLK4
+TRBL10: CAML R,WNDBOT
+ CAML R,WNDTOP ; SEE IF IN WINDOW
+ JRST TRBLK5 ; NO
+ SUB E,WNDBOT
+ SUB 0,WNDBOT
+ MOVEI A,WIND+1777
+TRBLK4: ADDI 0,-1777(A) ; CALCULATE START IN WINDOW OR FRONTEIR
+ CAIL E,2000
+ JRST TRNSWD
+ ADDI E,-1777(A) ; SUBTRACT WINDBOT
+ HRL 0,F ; SET UP FOR BLT
+ BLT 0,(E)
+ POP P,A
+
+FIXDOP: IORM D,(A)
+ MOVE E,M ; GET END OF WORD
+ POPJ P,
+TRNSWD: PUSH P,B
+ MOVEI B,1(A) ; GET TOP OF WORLD
+ SUB B,0
+ HRL 0,F
+ BLT 0,(A)
+ ADD F,B ; ADJUST F
+ ADD R,B
+ POP P,B
+ MOVE E,M ; RESTORE E
+ JRST TRBLK1 ; CONTINUE
+TRBLK5: HRRZ A,R ; COPY E
+ ASH A,-10. ; TO PAGES
+ PUSH P,B ; SAVE B
+ MOVEI B,WNDP ; IT IS WINDOW
+ PUSHJ P,%SHWND
+ ASH A,10. ; TO PAGES
+ MOVEM A,WNDBOT ; UPDATE POINTERS
+ ADDI A,2000
+ MOVEM A,WNDTOP
+ POP P,B ; RESTORE B
+ JRST TRBL10
+
+
+
+
+; ALTERNATE ENTRY FOR VECTORS WHICH TAKES CARE OF SHRINKAGE
+
+TRBLKV: HRRZS A
+ SKIPE GCDFLG ; SKIP IF NOT IN DUMPER
+ JRST TRBLV2
+ CAMGE A,GCSBOT ; SEE IF IN GC-SPACE
+ JRST FIXDOP
+TRBLV2: PUSH P,A ; SAVE A
+ HLRZ 0,DOPSV2
+ TRZ 0,400000
+ HRRZ F,A
+ HLRE A,E ; GET SHRINKAGE
+ ADD 0,A ; MUNG LENGTH
+ SUB F,0
+ ADDI F,1 ; F POINTS TO START OF VECTOR
+ SKIPGE -2(P) ; SEE IF SHRINKAGE
+ ADD 0,-2(P) ; IF SO COMPENSATE
+ JRST TRBLK2 ; CONTINUE
+
+; ALTERNATE ENTRY POINT TO TRBLK A==> OBJECT TO SEND IN 0= # OF WORDS
+
+TRBLK3: PUSH P,A ; SAVE A
+ MOVE F,A
+ JRST TRBLK2
+
+; FINAL ALTERNATE ENTRY POINT TO TRBLK A==> OBJECT
+; F==> START OF TRANSFER IN GCS 0= # OF WORDS
+
+TRBLKX: PUSH P,A ; SAVE A
+ JRST TRBLK2 ; SEND IT OUT
+
+
+; OUTTP IS THE ROUTINE THAT TPMK USES TO SEND OUT ELEMENTS FOR THE SCAN
+; -2(P) CONTAINS THE ADDR IN THE INF AND IT IS UPDATED
+; A CONTAINS THE WORD TO BE SENT OUT
+
+OUTTP: AOS E,-2(P) ; INCREMENT PLACE
+ MOVSI 0,(MOVEM) ; INS FOR SMINF
+ SOJA E,SMINF
+
+
+; ADWD PLACES ONE WORD IN THE INF
+; E ==> INF C IS THE WORD
+
+ADWD: PUSH P,E ; SAVE AC'S
+ PUSH P,A
+ MOVE A,C ; GET WORD
+ MOVSI 0,(MOVEM) ; INS FOR SMINF
+ PUSHJ P,SMINF ; SMASH IT IN
+ POP P,A
+ POP P,E
+ POPJ P, ; EXIT
+
+; DOPOUT IS USED TO SEND OUT THE DOPE WORDS IN UNUSUAL CALSE
+; SUCH AS THE TP AND GROWTH
+
+
+DOPOUT: MOVE C,-1(A)
+ PUSHJ P,ADWD
+ ADDI E,1
+ MOVE C,(A) ; GET SECOND DOPE WORD
+ TLZ C,400000 ; TURN OFF POSSIBLE MARK BIT
+ PUSHJ P,ADWD
+ MOVE C,DOPSV1 ; FIX UP FIRST DOPE WORD
+ MOVEM C,-1(A)
+ MOVE C,DOPSV2
+ MOVEM C,(A) ; RESTORE SECOND D.W.
+ POPJ P,
+
+; DOPMOD MODIFIES THE DOPE WORD OF A VECTOR AND PLACES A NEW DOPE-WORD IN INF
+; A ==> DOPE WORD E==> INF
+
+DOPMOD: SKIPE GCDFLG ; CHECK TO SEE IF IN DUMPER AND PURIFY
+ JRST .+3
+ CAMG A,GCSBOT
+ POPJ P, ; EXIT IF NOT IN GCS
+ MOVE C,-1(A) ; GET FIRST DOPE WORD
+ MOVEM C,DOPSV1
+ HLLZS C ; CLEAR OUT GROWTH
+ TLO C,.VECT. ; FIX UP FOR GCHACK
+ PUSH P,C
+ MOVE C,(A) ; GET SECOND DOPE WORD
+ HLRZ B,(A) ; GET LENGTH
+ TRZ B,400000 ; TURN OFF MARK BIT
+ MOVEM C,DOPSV2
+ HRRZ 0,-1(A) ; CHECK FOR GROWTH
+ JUMPE 0,DOPMD1
+ LDB 0,[111100,,-1(A)] ; MODIFY WITH GROWTH
+ TRZE 0,400
+ MOVNS 0
+ ASH 0,6
+ ADD B,0
+ LDB 0,[001100,,-1(A)]
+ TRZE 0,400
+ MOVNS 0
+ ASH 0,6
+ ADD B,0
+DOPMD1: HRL C,B ; FIX IT UP
+ MOVEM C,(A) ; FIX IT UP
+ POP P,-1(A)
+ POPJ P,
+
+ADPMOD: CAMG A,GCSBOT
+ POPJ P, ; EXIT IF NOT IN GCS
+ MOVE C,-1(A) ; GET FIRST DOPE WORD
+ TLO C,.VECT. ; FIX UP FOR GCHACK
+ MOVEM C,-1(A)
+ MOVE C,(A) ; GET SECOND DOPE WORD
+ TLZ C,400000 ; TURN OFF PARK BIT
+ MOVEM C,(A)
+ POPJ P,
+
+
+
+
+\f; RELATE RELATAVIZES A POINTER TO A VECTOR
+; B IS THE POINTER A==> DOPE WORD
+
+RELATE: SKIPE GCDFLG ; SEE IF DUMPER OR PURIFIER
+ JRST .+3
+ CAMGE A,GCSBOT ; SEE IF IN VECTOR SPACE
+ POPJ P, ; IF NOT EXIT
+ MOVE C,-1(P)
+ HLRE F,C ; GET LENGTH
+ HRRZ 0,-1(A) ; CHECK FO GROWTH
+ JUMPE A,RELAT1
+ LDB 0,[111100,,-1(A)] ; GET TOP GROWTH
+ TRZE 0,400 ; HACK SIGN BIT
+ MOVNS 0
+ ASH 0,6 ; CONVERT TO WORDS
+ SUB F,0 ; ACCOUNT FOR GROWTH
+RELAT1: HRLM F,C ; PLACE CORRECTED LENGTH BACK IN POINTER
+ HRRZ F,(A) ; GET RELOCATED ADDR
+ SUBI F,(A) ; FIND RELATIVIZATION AMOUNT
+ ADD C,F ; 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)
+ PUSH P,A
+ MOVEI C,-1(P)
+ MOVEI B,TTP
+ PUSHJ P,MARK
+ SUB P,[1,,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 F,OTBSAV(A) ; GET TIME FROM FRAME
+ CAME B,F ; 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 F,-1(A) ; GET THE TYPE
+ ANDI F,SATMSK ; FLUSH MONITOR BITS
+ CAIN F,SATOM ; SEE IF ATOM
+ JRST ATMSET
+ HLRE F,(A) ; GET MARKING
+ JUMPL F,BYTREL ; JUMP IF MARKED
+ HLRZ F,(A) ; GET LENGTH
+ PUSHJ P,ALLOGC ; ALLOCATE FOR IT
+ HRRM 0,(A) ; SMASH IT IN
+ MOVE E,0
+ HLRZ F,(A)
+ SUBI E,-1(F) ; ADJUST INF POINTER
+ IORM D,(A)
+ PUSHJ P,ADPMOD
+ PUSHJ P,TRBLK
+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
+ SKIPN GCDFLG
+ JRST BYTREL
+ MOVSI E,STATM ; GET "STRING IS ATOM BIT"
+ IORM E,(P)
+ SKIPN DUMFLG
+ JRST GCRET
+ HRRM A,(P)
+ JRST BYTREL ; TO BYTREL
+\f
+
+; MARK OFFSET
+
+OFFSMK: HLRZS A
+ PUSH P,$TLIST
+ PUSH P,A ; PUSH LIST POINTER ON THE STACK
+ MOVEI C,-1(P) ; POINTER TO PAIR
+ PUSHJ P,MARK2 ; MARK THE LIST
+ HRLM A,-2(P) ; UPDATE POINTER IN OFFSET
+ SUB P,[2,,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
+ HLRZ 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,@BOTNEW
+ PUSH P,0 ; SAVE POINTER TO INF
+ TLO TYPNT,.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) ; MAKE SURE ATOMS NOT ON OBLISTS GET SENT
+ POP P,A ; RESTORE A
+ POP P,E ; GET POINTER INTO INF
+ SKIPN GCHAIR
+ JUMPN 0,ATMREL
+ PUSHJ P,ADPMOD
+ PUSHJ P,TRBLK
+ATMREL: HRRZ E,(A) ; RELATAVIZE
+ SUBI E,(A)
+ ADDM E,(P)
+ JRST GCRET
+ATMRL1: SUB P,[1,,1] ; POP OFF STACK
+ JRST ATMREL
+
+\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 F,(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: SUB P,[1,,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
+ PUSH P,E
+ SKIPE DUMFLG ; SKIP IF NOT IN DUMPER
+ PUSHJ P,TYPHK ; HACK WITH TYPE IF SPECIAL
+ POP P,E ; RESTORE LENGTH
+ MOVE F,B ; AND COPY IT
+ LSH B,1 ;FIND OUT WHERE IT WILL GO
+ HRRZ B,@TYPNT ;GET SAT IN B
+ ANDI B,SATMSK
+ MOVEI C,@MKTBS(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,F ;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
+
+ SUB P,[2,,2] ;REMOVE STACK CRAP
+ JRST UMOVEC
+
+
+SPECLS: FATAL AGC--UNRECOGNIZED SPECIAL VECTOR
+ SUB P,[4,,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,@BOTNEW ; 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,A ; GET PTR TO D.W.
+ POP P,E ; GET PTR TO INF
+ SUB P,[1,,1] ; GET RID OF TOP
+ PUSHJ P,ADPMOD ; FIX UP D.W.
+ PUSHJ P,TRBLK ; SEND IT OUT
+ JRST ATMREL ; RELATIVIZE AND LEAVE
+GCRDRL: POP P,A ; GET PTR TO D.W
+ SUB P,[2,,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
+ SKIPN DUMFLG ; IF GC-DUMP, WILL STORE ATOM FOR LOCR
+ JRST LOCRDD
+ MOVEI B,1
+ IORM B,3(A) ; MUNG ATOM TO SAY IT IS LOCR
+ CAIA
+LOCRDD: 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 E,(A) ; GET PTR IN FRONTEIR
+ SUBI E,ASOLNT+1 ; ADJUST TO POINT TO BEGINNING
+ PUSHJ P,ADPMOD
+ PUSHJ P,TRBLK
+ JRST ASTR1
+
+;HERE WHEN A VECTOR POINTER IS BAD
+
+VECTB1:FATAL AGC--VECTOR POINTS OUTSIDE OF VECTOR SPACE
+ SUB P,[1,,1] ; RECOVERY
+AFIXUP: SETZM (P) ; CLOBBER SLOT
+ JRST GCRET ; CONTINUE
+
+
+VECTB2: FATAL AGC--VECTOR POINTS OUT OF VECTOR SPACE
+ SUB P,[2,,2]
+ JRST AFIXUP ; RECOVER
+
+PARERR: FATAL AGC--PAIR POINTS OUT OF PAIR SPACE
+ SUB P,[1,,1] ; RECOVER
+ JRST AFIXUP
+
+
+\f; HERE TO MARK TEMPLATE DATA STRUCTURES
+
+TD.MRK: MOVEI 0,@BOTNEW ; 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 E,-7(P) ; RESTORE PTR TO FRONTEIR
+ SUB P,[7,,7] ; CLEAN UP STACK
+USRAG1: ADDI A,1 ; POINT TO SECOND D.W.
+ MOVSI D,400000 ; SET UP MARK BIT
+ PUSHJ P,ADPMOD
+ PUSHJ P,TRBLK ; SEND IT OUT
+TMPREL: SUB P,[1,,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 E,(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 F,(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 F,(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,F
+ HLRE F,ASOLNT-INDIC+1(C) ; GET LENGTH
+ JUMPL F,.+3 ; SKIP IF MARKED
+ CAMGE C,VECBOT ; SKIP IF IN VECT SPACE
+ JRST ASOM20
+ HRRM FPTR,ASOLNT-INDIC+1(C) ; PUT IN RELATIVISATION
+ MOVEI F,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,F
+ 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(F) ; 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
+ TLZE TYPNT,.ATOM. ; ANY ATOMS MARKED?
+ JRST VALFLA ; YES, CHECK VALUES
+VALFL8:
+
+; NOW SEE WHICH CHANNELS STILL POINTED TO
+
+CHNFL3: MOVEI 0,N.CHNS-1
+ MOVEI A,CHNL1 ; SLOTS
+ HRLI A,TCHAN ; TYPE HERE TOO
+
+CHNFL2: SKIPN B,1(A)
+ JRST CHNFL1
+ HLRE C,B
+ SUBI B,(C) ; POINT TO DOPE
+ HLLM A,(A) ; PUT TYPE BACK
+ HRRE F,(A) ; SEE IF ALREADY MARKED
+ JUMPN F,CHNFL1
+ SKIPGE 1(B)
+ JRST CHNFL8
+ HLLOS (A) ; MARK AS A LOSER
+ SETZM -1(P)
+ JRST CHNFL1
+CHNFL8: MOVEI F,1 ; MARK A GOOD CHANNEL
+ HRRM F,(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
+
+ SUB P,[2,,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 F,A ; CALCULATE START OF TP IN F
+ HLRZ B,(A) ; ADJUST INF PTR
+ TRZ B,400000
+ SUBI F,-1(B)
+ LDB M,[111100,,-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: SUB P,[1,,1] ; CLEAN UP STACK
+ SUBI E,-1(B)
+ HRRI B,(R) ; GET POINTER TO THIS-PROCESS BINDING
+ MOVEI B,6(B) ; POINT AFTER THE BINDING
+ MOVE 0,F ; CALCULATE # OF WORDS TO SEND OUT
+ SUBM B,0
+ PUSH P,R ; PRESERVE R
+ PUSHJ P,TRBLKX ; SEND IT OUT
+ POP P,R ; RESTORE R
+ HRRZS R,2(R) ; GET THE NEXT PROCESS
+ SKIPN R
+ JRST .+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 A,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 SPECIAL STUFF FROM GCHAIR
+
+SPCOUT: HLRE B,A
+ SUB A,B
+ MOVEI A,1(A) ; POINT TO DOPE WORD
+ LDB 0,[001100,,-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
+ PUSHJ P,DOPMOD
+ HRRZ E,(A) ; GET PTR TO INF
+ HLRZ B,(A) ; LENGTH
+ TRZ B,400000 ; GET RID OF MARK BIT
+ SUBI E,-1(B)
+ ADD E,0
+ PUSH P,0 ; DUMMY FOR TRBLKV
+ PUSHJ P,TRBLKV ; OUT IT GOES
+ SUB P,[1,,1]
+ 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,F
+ PUSHJ P,MARK2
+ MOVEM A,1(C)
+ POP P,F
+ 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
+ SUB P,[1,,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: ADDI 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 F,ASOLNT+1(B) ;AND ITS RELOCATION
+ SUBI F,ASOLNT+1(B) ; RELATIVIZE
+ MOVSI F,(F)
+ ADDM F,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 F,ASOLNT+1(B) ;RELOC
+ SUBI F,ASOLNT+1(B)
+ MOVSI F,(F)
+ ADDM F,NODPNT(A)
+ASOUP5: POP P,A ; RECOVER PTR TO DOPE WORD
+ MOVEI A,ASOLNT+1(A)
+ MOVSI B,400000 ;UNMARK IT
+ XORM B,(A)
+ HRRZ E,(A) ; SET UP PTR TO INF
+ HLRZ B,(A)
+ SUBI E,-1(B) ; ADJUST PTR
+ PUSHJ P,ADPMOD
+ PUSHJ P,TRBLK ; OUT IT GOES
+ 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 F,1(C) ; FIND NEXT ATOM
+ SUBI C,-2(F)
+ 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
+ MOVSI D,400000 ;UNMARK IT
+ XORM D,1(A)
+ HRRZ E,1(A) ; SET UP PTR TO INF
+ HLRZ B,1(A)
+ SUBI E,-1(B) ; ADJUST PTR
+ MOVEI A,1(A)
+ PUSHJ P,ADPMOD
+ PUSHJ P,TRBLK ; OUT IT GOES
+ 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
+
+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
+
+DOPSV1: 0 ;SAVED FIRST D.W.
+DOPSV2: 0 ; SAVED LENGTH
+
+
+; LOCATIONS USED BY BLOAT-STAT TO HELP THE USER PICK BLOAT SPECIFICATIONS.
+;
+
+GCNO: 0 ; USER-CALLED GC
+BSTGC: 0 ; FREE STORAGE
+ 0 ; BLOWN TP
+ 0 ; TOP-LEVEL LVALS
+ 0 ; GVALS
+ 0 ; TYPE
+ 0 ; STORAGE
+ 0 ; P-STACK
+ 0 ; BOTH STATCKS BLOWN
+ 0 ; STORAGE
+
+BSTAT:
+NOWFRE: 0 ; FREE STORAGE FROM LAST GC
+CURFRE: 0 ; STORAGE USED SINCE LAST GC
+MAXFRE: 0 ; MAXIMUM FREE STORAGE ALLOCATED
+USEFRE: 0 ; TOTAL FREE STORAGE USED
+NOWTP: 0 ; TP LENGTH FROM LAST GC
+CURTP: 0 ; # WORDS ON TP
+CTPMX: 0 ; MAXIMUM SIZE OF TP SO FAR
+NOWLVL: 0 ; # OF TOP-LEVEL LVAL-SLOTS
+CURLVL: 0 ; # OF TOP-LEVEL LVALS
+NOWGVL: 0 ; # OF GVAL SLOTS
+CURGVL: 0 ; # OF GVALS
+NOWTYP: 0 ; SIZE OF TYPE-VECTOR
+CURTYP: 0 ; # OF TYPES
+NOWSTO: 0 ; SIZE OF STATIONARY STORAGE
+CURSTO: 0 ; STATIONARY STORAGE IN USE
+CURMAX: 0 ; MAXIMUM BLOCK OF CONTIGUOUS STORAGE
+NOWP: 0 ; SIZE OF P-STACK
+CURP: 0 ; #WORDS ON P
+CPMX: 0 ; MAXIMUM P-STACK LENGTH SO FAR
+GCCAUS: 0 ; INDICATOR FOR CAUSE OF GC
+GCCALL: 0 ; INDICATOR FOR CALLER OF GC
+
+
+; THIS GROUP OF VARIABLES DETERMINES HOW THINGS GROW
+LVLINC: 6 ; LVAL INCREMENT ASSUMED TO BE 64 SLOTS
+GVLINC: 4 ; GVAL INCREMENT ASSUMED TO BE 64 SLOTS
+TYPIC: 1 ; TYPE INCREMENT ASSUMED TO BE 32 TYPES
+STORIC: 2000 ; STORAGE INCREMENT USED BY NFREE (MINIMUM BLOCK-SIZE)
+
+
+RCL: 0 ; POINTER TO LIST OF RECYCLEABLE LIST CELLS
+RCLV: 0 ; POINTER TO RECYCLED VECTORS
+GCMONF: 0 ; NON-ZERO SAY GIN/GOUT
+GCDANG: 0 ; NON-ZERO, STORAGE IS LOW
+INBLOT: 0 ; INDICATE THAT WE ARE RUNNING OIN A BLOAT
+GETNUM: 0 ;NO OF WORDS TO GET
+RFRETP:
+RPTOP: 0 ;NO OF BLOCKS OF CORE, IF GIVING CORE AWAY
+CORTOP: 0 ;CURRENT TOP OF CORE, EXCLUDING ANY TO BE GIVEN AWAY
+NGCS: 8 ; NUMBER OF GARBAGE COLLECTS BETWEEN HAIRY GCS
+
+;VARIABLES WHICH DETERMIN WHEN MUDDLE WILL ASK FOR MORE CORE,
+;AND WHEN IT WILL GET UNHAPPY
+
+FREMIN: 20000 ;MINIMUM FREE WORDS
+
+;POINTER TO GROWING PDL
+
+TPGROW: 0 ;POINTS TO A BLOWN TP
+PPGROW: 0 ;POINTS TO A BLOWN PP
+PGROW: 0 ;POINTS TO A BLOWN P
+
+;IN GC FLAG
+
+GCFLG: 0
+GCFLCH: 0 ; TELL INT HANDLER TO ITIC CHARS
+GCHAIR: 1 ; COUNTS GCS AND TELLS WHEN TO HAIRIFY
+GCDOWN: 0 ; AMOUNT TO TRY AND MOVE DOWN
+CURPLN: 0 ; LENGTH OF CURRENTLY RUNNING PURE RSUBR
+PURMIN: 0 ; MINIMUM PURE STORAGE
+
+; VARS ASSOCIATED WITH BLOAT LOGIC
+PMIN: 200 ; MINIMUM FOR PSTACK
+PGOOD: 1000 ; GOOD SIZE FOR PSTACK
+PMAX: 4000 ; MAX SIZE FOR PSTACK
+TPMIN: 1000 ; MINIMUM SIZE FOR TP
+TPGOOD: NTPGOO ; GOOD SIZE OF TP
+TPMAX: NTPMAX ; MAX SIZE OF TP
+
+TPBINC: 0
+GLBINC: 0
+TYPINC: 0
+
+; VARS FOR PAGE WINDOW HACKS
+
+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
+FNTBOT: 0 ; BOTTOM OF FRONTEIR
+WNDBOT: 0 ; BOTTOM OF WINDOW
+WNDTOP: 0
+BOTNEW: (FPTR) ; POINTER TO FRONTIER
+GCTIM: 0
+NPARBO: 0 ; SAVED PARBOT
+
+; FLAGS TO INDICATE DUMPER IS IN USE
+
+GPURFL: 0 ; INDICATE PURIFIER IS RUNNING
+GCDFLG: 0 ; INDICATE EITHER GCDUMP OR PURIFIER IS RUNNING
+DUMFLG: 0 ; FLAG INDICATING DUMPER IS RUNNING
+
+; CONSTANTS FOR DUMPER,READER AND PURIFYER
+
+ABOTN: 0 ; COUNTER FOR ATOMS
+NABOTN: 0 ; POINTER USED BY PURIFY
+OGCSTP: 0 ; CONTAINS OLD GCSTOP FOR READER
+MAPUP: 0 ; BEGINNING OF MAPPED UP PURE STUFF
+SAVRES: 0 ; SAVED UPDATED ITEM OF PURIFIER
+SAVRE2: 0 ; SAVED TYPE WORD
+SAVRS1: 0 ; SAVED PTR TO OBJECT
+INF1: 0 ; AOBJN PTR USED IN CREATING PROTECTION INF
+INF2: 0 ; AOBJN PTR USED IN CREATING SECOND INF
+INF3: 0 ; AOBJN PTR USED TO PURIFY A STRUCTURE
+
+; VARIABLES USED BY GC INTERRUPT HANDLER
+
+GCHPN: 0 ; SET TO -1 EVERYTIME A GC HAS OCCURED
+GCKNUM: 0 ; NUMBER OF WORDS OF REQUEST TO INTERRUPT
+
+; VARIABLE TO INDICATE WHETHER AGC HAS PUSHED THE MAPPING CHANNEL TO WIN
+
+PSHGCF: 0
+
+; VARIABLES USED BY DUMPER AND READER TO HANDLE NEWTYPES
+
+TYPTAB: 0 ; POINTER TO TYPE TABLE
+NNPRI: 0 ; NUMPRI FROM DUMPED OBJECT
+NNSAT: 0 ; NUMSAT FROM DUMPED OBJECT
+TYPSAV: 0 ; SAVE PTR TO TYPE VECTOR
+
+; VARIABLES USED BY GC-DUMP FOR COPY-WRITE MAPPING
+
+BUFGC: 0 ; BUFFER FOR COPY ON WRITE HACKING
+PURMNG: 0 ; FLAG INDICATING IF A PURIFIED PAGE WAS MUNGED DURING GC-DUMP
+RPURBT: 0 ; SAVED VALUE OF PURTOP
+RGCSTP: 0 ; SAVED GCSTOP
+
+; VARIABLES USED TO DETERMINE WHERE THE GC-DUMPED STRUCTURE SHOULD GO
+
+INCORF: 0 ; INDICATION OF UVECTOR HACKS FOR GC-DUMP
+PURCOR: 0 ; INDICATION OF UVECTOR TO PURE CORE
+ ; ARE NOT GENERATED
+
+
+PLODR: 0 ; INDICATE A PLOAD IS IN OPERATION
+NPRFLG: 0
+
+; VARIABLE USED BY MARK SWEEP GARBAGE COLLECTOR
+
+MAXLEN: 0 ; MAXIMUM RECLAIMED SLOT
+
+PURE
+
+OFFSET OFFS
+
+CONSTANTS
+
+HERE
+
+CONSTANTS
+
+OFFSET 0
+
+ZZ==$.+1777
+
+.LOP ANDCM ZZ 1777
+
+ZZ1==.LVAL1
+
+LOC ZZ1
+
+
+OFFSET OFFS
+
+WIND: SPBLOK 2000
+FRONT: SPBLOK 2000
+MRKPD: SPBLOK 1777
+ENDPDL: -1
+
+MRKPDL=MRKPD-1
+
+ENDGC:
+
+OFFSET 0
+
+.LOP <ASH @> WIND <,-10.>
+WNDP==.LVAL1
+
+.LOP <ASH @> FRONT <,-10.>
+FRNP==.LVAL1
+
+ZZ2==ENDGC-AGCLD
+.LOP <ASH @> ZZ2 <,-10.>
+LENGC==.LVAL1
+
+.LOP <ASH @> LENGC <,10.>
+RLENGC==.LVAL1
+
+.LOP <ASH @> AGCLD <,-10.>
+PAGEGC==.LVAL1
+
+OFFSET 0
+
+LOC GCST
+.LPUR==$.
+
+END
+
--- /dev/null
+TITLE AGCMRK ESTABLISH AGC LOADING POINT
+
+RELOCA
+
+.GLOBAL AGCLD
+
+XX==$.+1777
+
+.LOP ANDCM XX,1777
+
+AGCLD=.LVAL1
+
+END
+\f
\ No newline at end of file
--- /dev/null
+TITLE AMSGC MUDDLE MARK SWEEP GARBAGE COLLECTOR
+
+RELOCATABLE
+
+.GLOBAL RCL,RCLV,IAMSGC,MAXLEN,REALGC,RGCLEN,GCFLG,SQUPNT,GCMONF,MSGTYP,GCCAUS
+.GLOBAL GCCALL,PVSTOR,DSTORE,TYPVEC,N.CHNS,CHNL1,MAINPR,STOGC,CTIME,GCTIM,IMTYO
+.GLOBAL FNMSGC,SATMSK,NUMSAT,NUMPRI,PURBOT,GCSTOP,GCSBOT,STOSTR,TYPMSK,PDLBUF,ITEM,INDIC
+.GLOBAL VAL,NODPNT,UBIT,ASOLNT,GCHAPN,RBLDM,TOTCNT,MARK2S,MKTBS
+.GLOBAL FRMUNG,BYTDOP,TD.GET,TD.LNT,TD.AGC,ABOTN,SLENGC,LENGC,REALGC,AGCLD,RLENGC
+.GLOBAL RSLENG
+
+GCST=$.
+
+LOC REALGC+RLENGC
+
+OFFS=AGCLD-$.
+OFFSET OFFS
+
+.INSRT MUDDLE >
+
+TYPNT==AB
+F==PVP
+
+
+; THIS IS THE MUDDLE MARK SWEEP GARBAGE COLLECTOR. IT IS MUCH FASTER THAN THE COPYING
+; GARBAGE COLLECTOR BUT DOESN'T COMPACT. IT CONSES FREE THINGS ONTO RCL AND RCLV.
+; THIS GARBAGE COLLECTOR CAN ONLY BE USED IF THE GARBAGE COLLECT IS A FREE STORAGE
+; GARBAGE COLLECT
+
+\f
+; FIRST INITIALIZE VARIABLES
+
+IAMSGC: SETZB M,RCL ; CLEAR OUT LIST RECYCLE AND RSUBR BASE
+ SETZM RCLV ; CLEAR VECTOR RECYCLE
+ SETZM MAXLEN ; CLEAR MAXIMUM LENGTH FOUND TO RECYCLE
+ SETOM GCFLG ; A GC HAS HAPPENED
+ SETZM TOTCNT
+ HLLZS SQUPNT ; CLEAR OUT SQUOZE TABLE
+
+; SET UP MESSAGE PRINTING AND SAVE CAUSE AND CAUSER
+
+ PUSH P,A
+ PUSH P,B
+ PUSH P,C ; SAVE ACS
+ MOVEI B,[ASCIZ /MSGIN / ] ; PRINT GIN IF WINNING
+ SKIPE GCMONF
+ PUSHJ P,MSGTYP
+ HRRZ C,(P) ; GET CAUSE INDICATOR
+ ADDI B,1 ; AOS TO GET REAL CAUS
+ MOVEM B,GCCAUS
+ SKIPN GCMONF
+ 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
+ SKIPN GCMONF ; PRINT IF GCMON IS ON
+ JRST NOMON3
+ MOVE B,MSGGFT(C) ; GET POINTER TO MESSAGE
+ PUSHJ P,MSGTYP
+NOMON3: SUB P,[1,,1]
+ POP P,B ; RESTORE ACS
+ POP P,A
+
+; MOVE ACS INTO THE PVP
+
+ EXCH PVP,PVSTOR+1 ; GET REAL PROCESS VECTOR
+
+ IRP AC,,[0,A,B,C,D,E,TVP,SP,AB,TB,TP,FRM,M,R,P]
+ MOVEM AC,AC!STO+1(PVP)
+ TERMIN
+
+ MOVE 0,PVSTOR+1 ; GET OLD VALUE OF PVP
+ MOVEM 0,PVPSTO+1(PVP) ; SAVE PVP
+ MOVE 0,DSTORE ; SAVE D'S TYPE
+ MOVEM 0,DSTO(PVP)
+ MOVEM PVP,PVSTOR+1
+
+; SET UP TYPNT TO POINT TO TYPE VECTOR
+
+ GETYP E,TYPVEC ; FIRST SEE IF TYPVEC IS A VECTOR
+ CAIE E,TVEC
+ FATAL TYPE VECTOR NOT OF TYPE VECTOR
+ HRRZ TYPNT,TYPVEC+1
+ HRLI TYPNT,B ; TYPNT IS NOW TYPEVECTOR(B)
+
+; NOW SET UP GCPDL AND FENCE POST PDL'S
+
+ MOVEI A,(TB)
+ MOVE D,P ; SAVE P POINTER
+ PUSHJ P,FRMUNG
+ MOVE P,[-2000,,MRKPDL] ; SET UP MARK PDL
+ MOVEI A,(TB) ; FIXUP TOP FRAME
+ SETOM 1(TP) ; FENCEPOST TP
+ SETOM 1(D) ; FENCEPOST P
+
+; NOW SETUP AUTO CHANNEL CLOSE
+
+ MOVEI 0,N.CHNS-1 ; NUMBER OF CHANNELS
+ MOVEI A,CHNL1 ; FIRST CHANNEL SLOT
+CHNCLR: SKIPE 1(A) ; IS IT A CHANNEL
+ SETZM (A) ; CLEAR UP TYPE SLOT
+ ADDI A,2
+ SOJG 0,CHNCLR
+
+; NOW DO MARK AND SWEEP PHASES
+
+ MOVSI D,400000 ; MARK BIT
+ MOVEI B,TPVP ; GET TYPE
+ MOVE A,PVSTOR+1 ; GET VALUE OF CURRENT PROCESS VECTOR
+ PUSHJ P,MARK
+ MOVEI B,TPVP ; GET TYPE OF MAIN PROCESS VECTOR
+ MOVE A,MAINPR
+ PUSHJ P,MARK ; MARK
+ PUSHJ P,CHNFLS ; DO CHANNEL FLUSHING
+ PUSHJ P,STOGC ; FIX UP FROZEN WORLD
+ PUSHJ P,SWEEP ; SWEEP WORLD
+
+; PRINT GOUT
+
+ MOVEI B,[ASCIZ /MSGOUT /] ; PRINT OUT ENDING MESSAGE IF GCMONING
+ SKIPE GCMONF
+ PUSHJ P,MSGTYP
+
+; RESTORE ACS
+
+ MOVE PVP,PVSTOR+1 ; GET PVP
+ IRP AC,,[0,A,B,C,D,E,TVP,SP,AB,TB,TP,FRM,M,R,P]
+ MOVE AC,AC!STO+1(PVP)
+ TERMIN
+
+ SKIPN DSTORE ; CLEAR OUT TYPE IF NO TYPE THERE
+ SETZM DSTO(PVP)
+ MOVE PVP,PVPSTO+1(PVP)
+
+; PRINT TIME
+
+ PUSH P,A ; SAVE ACS
+ PUSH P,B
+ PUSH P,C
+ PUSH P,D
+ PUSHJ P,CTIME ; GET CURRENT CPU TIME
+ FSBR B,GCTIM ; COMPUTE TIME ELAPSED
+ MOVEM B,GCTIM ; SAVE TIME AWAY
+ SKIPN GCMONF ; PRINT IT OUT?
+ JRST GCCONT
+ PUSHJ P,FIXSEN
+ MOVEI A,15 ; OUTPUT CR/LF
+ PUSHJ P,IMTYO
+ MOVEI A,12
+ PUSHJ P,IMTYO
+GCCONT: POP P,D ; RESTORE ACS
+ POP P,C
+ POP P,B
+ POP P,A
+ SETZM GCFLG
+ SETOM GCHAPN
+ SETOM INTFLG
+ PUSHJ P,RBLDM
+ JRST FNMSGC ; DONE
+
+\f
+; THIS IS THE MARK PHASE
+
+; GENERAL MARK ROUTINE, CALLED TO MARK ALL THINGS
+; /A POINTER TO GOODIE
+; /B TYPE OF GOODIE
+; FOR MARK2, MARK1 /C POINTER TO PAIR NOT NEEDED FOR CALLS DIRECTLY TO MARK
+
+MARK2S:
+MARK2: HLRZ B,(C) ; TYPE
+MARK1: MOVE A,1(C) ; VALUE
+MARK: JUMPE A,CPOPJ ; DONE IF ZERO
+ MOVEI 0,1(A) ; SEE IF PURE
+ CAML 0,PURBOT
+ JRST CPOPJ
+ ANDI B,TYPMSK ; FLUSH MONITORS
+ HRLM C,(P)
+ CAIG B,NUMPRI ; IS A BASIC TYPE
+ JRST @MTYTBS(B) ; TYPE DISPATCH
+ LSH B,1 ; NOW GET PRIMTYPE
+ HRRZ B,@TYPNT ; GET PRIMTYPE
+ ANDI B,SATMSK ; FLUSH DOWN TO SAT
+ CAIG B,NUMSAT ; SKIP IF TEMPLATE DATA
+ JRST @MSATBS(B) ; JUMP OFF SAT TABLE
+ JRST TD.MK
+
+GCRET: HLRZ C,(P) ; GET SAVED C
+CPOPJ: POPJ P,
+
+; TYPE DISPATCH TABLE
+MTYTBS:
+
+OFFSET 0
+
+DUM1:
+
+IRP XX,,[[TLOSE,GCRET],[TFIX,GCRET],[TFLOAT,GCRET],[TCHRS,GCRET]
+[TENTRY,GCRET],[TSUBR,GCRET],[TFSUBR,GCRET],[TILLEG,GCRET],[TUNBOU,GCRET]
+[TBIND,GCRET],[TTIME,GCRET],[TLIST,PAIRMK],[TFORM,PAIRMK],[TSEG,PAIRMK]
+[TEXPR,PAIRMK],[TFUNAR,PAIRMK],[TLOCL,PAIRMK],[TFALSE,PAIRMK],[TDEFER,DEFQMK]
+[TUVEC,UVMK],[TOBLS,UVMK],[TVEC,VECMK],[TCHAN,VECMK] ,[TLOCV,VECMK]
+[TTVP,VECMK],[TBVL,VECMK],[TTAG,VECMK],[TPVP,VECMK],[TLOCI,TPMK],[TTP,TPMK]
+[TSP,TPMK],[TMACRO,PAIRMK],[TPDL,PMK],[TARGS,ARGMK],[TAB,ABMK]
+[TTB,TBMK],[TFRAME,FRMK],[TCHSTR,BYTMK],[TATOM,ATOMK],[TLOCD,LOCMK],[TBYTE,BYTMK]
+[TENV,FRMK],[TACT,FRMK],[TASOC,ASMK],[TLOCU,UVMK],[TLOCS,BYTMK],[TLOCA,ASMK]
+[TCBLK,GCRET],[TTMPLT,TD.MK],[TLOCT,TD.MK],[TLOCR,GCRET],[TINFO,GCRET]
+[TRDTB,GCRDMK],[TWORD,GCRET],[TRSUBR,VECMK],[TCODE,UVMK],[TSATC,GCRET]
+[TBITS,GCRET],[TSTORA,UVMK],[TPICTU,UVMK],[TSKIP,TPMK],[TLINK,ATOMK]
+[TDECL,PAIRMK],[TENTER,VECMK],[THAND,VECMK],[TINTH,VECMK],[TDISMI,ATOMK]
+[TDCLI,PAIRMK],[TPCODE,GCRET],[TTYPEW,GCRET],[TTYPEC,GCRET]
+[TGATOM,GATOMK],[TREADA,FRMK],[TUBIND,GCRET],[TUNWIN,TBMK],[TLOCB,BYTMK]
+[TDEFQ,DEFQMK],[TSPLIC,PAIRMK],[TLOCN,ASMK],[TOFFS,OFFSMK]]
+ IRP A,B,[XX]
+ LOC DUM1+A
+ SETZ B
+ .ISTOP
+ TERMIN
+TERMIN
+
+LOC DUM1+NUMPRI+1
+
+OFFSET OFFS
+
+; SAT DISPATCH TABLE
+
+MSATBS:
+
+OFFSET 0
+
+DISTB2 DUM2,GCRET,[[S2WORD,PAIRMK],[S2DEFR,DEFMK],[SNWORD,UVMK],[STBASE,TBMK]
+[STPSTK,TPMK],[SARGS,<SETZ ARGMK>],[S2NWORD,VECMK],[SPSTK,TPMK],[SSTORE,UVMK]
+[SFRAME,<SETZ FRMK>],[SBYTE,<SETZ BYTMK>],[SATOM,ATOMK],[SPVP,VECMK],[SGATOM,GATOMK]
+[SLOCID,<SETZ LOCMK>],[SCHSTR,<SETZ BYTMK>],[SASOC,ASMK],[SLOCL,PAIRMK],[SABASE,ABMK]
+[SLOCA,<SETZ ARGMK>],[SLOCV,VECMK],[SLOCU,UVMK],[SLOCS,<SETZ BYTMK>],[SLOCN,ASMK]
+[SRDTB,GCRDMK],[SLOCB,<SETZ BYTMK>],[SDEFQ,DEFQMK],[SOFFS,OFFSMK]]
+
+OFFSET OFFS
+
+\f
+; ROUTINE TO MARK PAIRS
+
+PAIRMK: MOVEI C,(A)
+PAIRM1: CAMG C,GCSTOP ; SEE IF IN RANGE
+ CAIGE C,STOSTR
+ JRST BADPTR ; FATAL ERROR
+ HLRE B,(C) ; SKIP IF NOT MARKED
+ JUMPL B,GCRET
+ IORM D,(C) ; MARK IT
+ PUSHJ P,MARK1 ; MARK THE ITEM
+ HRRZ C,(C) ; GET NEXT ELEMENT OF LIST
+ JUMPE C,GCRET
+ CAML C,PURBOT
+ JRST GCRET
+ JRST PAIRM1
+
+; ROUTINE TO MARK DEFERS
+
+DEFMK: HLRE B,(A)
+ JUMPL B,GCRET
+ MOVEI C,(A)
+ IORM D,(C)
+ PUSHJ P,MARK1
+ JRST GCRET
+
+; ROUTINE TO MARK POSSIBLE DEFERS DEF?
+
+DEFQMK: GETYP B,(A) ; GET THE TYPE OF THE OBJECT
+ LSH B,1 ; COMPUTE THE SAT
+ HRRZ B,@TYPNT
+ ANDI B,SATMSK
+ SKIPL MKTBS(B) ; SKIP IF NOT DEFERED
+ JRST PAIRMK
+ JRST DEFMK ; GO TO DEFMK
+
+\f
+; ROUTINE TO MARK VECTORS
+
+VECMK: HLRE B,A ; GET LENGTH
+ SUB A,B
+ MOVEI C,1(A) ; POINT TO SECOND DOPE WORD
+ CAIL C,STOSTR ; CHECK FOR IN RANGE
+ CAMLE C,GCSTOP
+ JRST BADPTR
+ HLRE B,(C)
+ JUMPL B,GCRET
+ IORM D,(C) ; MARK IT
+ SUBI C,-1(B) ; GET TO BEGINNING
+VECMK1: HLRE B,(C) ; GET TYPE AND SKIP IF NOT DOPE WORD
+ JUMPL B,GCRET ; DONE
+ PUSHJ P,MARK1 ; MARK IT
+ ADDI C,2 ; NEXT ELEMENT
+ JRST VECMK1
+
+; ROUTINE TO MARK UVECTORS
+
+UVMK: HLRE B,A ; GET LENGTH
+ SUB A,B ; A POINTS TO FIRST DOPE WORD
+ MOVEI C,1(A) ; C POINTS TO SECOND DOPE WORD
+ CAIL C,STOSTR ; CHECK FOR IN RANGE
+ CAMLE C,GCSTOP
+ JRST BADPTR
+ HLRE F,(C) ; GET LENGTH
+ JUMPL F,GCRET
+ IORM D,(C) ; MARK IT
+ GETYP B,-1(C) ; GET TYPE
+ MOVEI E,(B) ; COPY TYPE FOR SAT COMPUTATION
+ LSH B,1
+ HRRZ B,@TYPNT ; GET SAT
+ ANDI B,SATMSK
+ MOVEI B,@MSATBS(B) ; GET JUMP LOCATION
+ CAIN B,GCRET
+ JRST GCRET
+ SUBI C,(F) ; POINT TO BEGINNING OF UVECTOR
+ SUBI F,2
+ JUMPE F,GCRET
+ PUSH P,F ; SAVE LENGTH
+ PUSH P,E
+UNLOOP: MOVE B,(P)
+ MOVE A,1(C) ; GET VALUE POINTER
+ PUSHJ P,MARK
+ SOSE -1(P) ; SKIP IF NON-ZERO
+ AOJA C,UNLOOP ; GO BACK AGAIN
+ SUB P,[2,,2] ; CLEAN OFF STACK
+ JRST GCRET
+
+; ROUTINE TO INDICATE A BAD POINTER
+
+BADPTR: FATAL POINTER POINTS OUT OF GARBAGE COLLECTED SPACE
+ JRST GCRET
+
+\f
+; ROUTINE TO MARK A TPSTACK
+
+TPMK: HLRE B,A ; GET LENGTH
+ SUB A,B ; A POINTS TO FIRST DOPE WORD
+ MOVEI C,PDLBUF+1(A) ; C POINTS TO SECOND DOPE WORD
+ CAIL C,STOSTR ; CHECK FOR IN RANGE
+ CAMLE C,GCSTOP
+ JRST BADPTR
+ HLRE A,(C)
+ JUMPL A,GCRET
+ IORM D,(C) ; MARK IT
+ SUBI C,-1(A) ; GO TO BEGINNING
+
+TPLP: HLRE B,(C) ; GET TYPE AND MARKING
+ JUMPL B,GCRET ; EXIT ON FENCE-POST
+ ANDI B,TYPMSK ; FLUSH MONITORS
+ CAIE B,TCBLK ; CHECK FOR FRAME
+ CAIN B,TENTRY
+ JRST MFRAME ; MARK THE FRAME
+ CAIE B,TUBIND ; BINDING BLOCK
+ CAIN B,TBIND
+ JRST MBIND
+ PUSHJ P,MARK1 ; NOTHING SPECIAL SO MARK IT
+ ADDI C,2 ; POINT TO NEXT OBJECT
+ JRST TPLP ; MARK IT
+
+; MARK A FRAME ON THE STACK, [I.E. ITS FSAV AND PSAV SLOTS]
+
+MFRAME: HRROI C,FRAMLN+FSAV-1(C) ; POINT TO FUNCTION
+ HRRZ A,1(C) ; GET POINTER
+ CAIL A,STOSTR ; SEE IF IN GC SPACE
+ CAMLE A,GCSTOP
+ JRST MFRAM1 ; SKIP OVER IT, NOT IN GC-SPACE
+ HRL A,(A) ; GET LENGTH
+ MOVEI B,TVEC ; TYPE IS VECTOR [RSUBR OR RSUBR-ENTRY]
+ PUSHJ P,MARK
+MFRAM1: MOVE A,PSAV-FSAV+1(C) ; MARK THE PSTACK
+ MOVEI B,TPDL
+ PUSHJ P,MARK
+ HRROI C,-FSAV+1(C) ; POINT PAST FRAME
+ JRST TPLP ; GO BACK TO START OF LOOP
+
+; MARK A BINDING ON THE STACK [I.E. THE ATOM, VALUE, DECL, AND PREVIOUS BINDING]
+
+MBIND: MOVEI B,TATOM ; START BY MARKING THE ATOM
+ PUSHJ P,MARK1 ; MARK IT
+ ADDI C,2 ; POINT TO VALUE SLOT
+ PUSHJ P,MARK2 ; MARK THE VALUE
+ ADDI C,2 ; POINT TO DECL AND PREV BINDING
+ MOVEI B,TLIST ; MARK DECL
+ HLRZ A,(C)
+ PUSHJ P,MARK
+ SKIPL A,1(C) ; SKIP IF PREVIOUS BINDING
+ JRST NOTLCI
+ MOVEI B,TLOCI ; GET TYPE
+ PUSHJ P,MARK
+NOTLCI: ADDI C,2 ; POINT PAST BINDING
+ JRST TPLP
+
+
+PMK: HLRE B,A ; GET LENGTH
+ SUB A,B ; A POINTS TO FIRST DOPE WORD
+ MOVEI C,PDLBUF+1(A) ; C POINTS TO SECOND DOPE WORD
+ CAIL C,STOSTR ; CHECK FOR IN RANGE
+ CAMLE C,GCSTOP
+ JRST BADPTR
+ IORM D,(C) ; MARK IT
+ JRST GCRET
+\f
+; ROUTINE TO MARK TB POINTER
+
+TBMK: HRRZS A ; CHECK FOR NIL POINTER
+ SKIPN A
+ JRST GCRET
+ MOVE A,TPSAV(A) ; GET A TP POINTER
+ MOVEI B,TTP ; TYPE WORD
+ PUSHJ P,MARK
+ JRST GCRET
+
+; ROUTINE TO MARK AB POINTERS
+
+ABMK: HLRE B,A ; GET TO FRAME
+ SUB A,B
+ MOVE A,FRAMLN+TPSAV(A) ; GET A TP POINTER
+ MOVEI B,TTP ; TYPE WORD
+ PUSHJ P,MARK
+ JRST GCRET
+
+; ROUTINE TO MARK FRAME POINTERS
+
+FRMK: HRLZ B,A ; GET THE TIME
+ HLRZ F,OTBSAV(A) ; GET TIME FROM FRAME
+ CAIE B,(F) ; SKIP IF TIMES AGREE
+ JRST GCRET ; IGNORE POINTER IF THEY DONT
+ HRRZ A,(C) ; GET POINTER TO PROCESS
+ SUBI A,1 ; FUDGE FOR VECTOR MARKING
+ MOVEI B,TPVP ; TYPE WORD
+ PUSHJ P,MARK
+ HRRZ A,1(C) ; GET POINTER TO FRAME
+ JRST TBMK ; MARK IT
+
+; ROUTINE TO MARK ARGUMENT BLOCKS [TUPLES]
+
+ARGMK: HLRE B,A ; GET LENGTH
+ SUB A,B ; POINT PAST BLOCK
+ CAIL A,STOSTR
+ CAMLE A,GCSTOP ; SEE IF IN GCSPACE
+ JRST GCRET
+ HRLZ 0,(A) ; GET TYPE
+ ANDI 0,TYPMSK ; FLUSH MONITORS
+ CAIE 0,TENTRY
+ CAIN 0,TCBLK
+ JRST ARGMK1 ; AT FRAME
+ CAIE 0,TINFO ; AT FRAME
+ JRST GCRET ; NOT A LEGAL TYPE GO AWAY
+ HRRZ A,1(A) ; POINTING TO FRAME
+ HRL A,(C) ; GET TIME
+ JRST TBMK
+ARGMK1: HRRI A,FRAMLN(A) ; MAKE POINTER
+ HRL A,(C) ; GET TIME
+ JRST TBMK
+\f
+
+; ROUTINE TO MARK GLOBAL SLOTS
+
+GATOMK: HRRZ B,(C) ; GET POSSIBLE GDECL
+ JUMPE B,ATOMK ; NONE GO TO MARK ATOM
+ CAIN B,-1 ; SKIP IF NOT MANIFEST
+ JRST ATOMK
+ PUSH P,A ; I DOUBT THIS IS RIGHT, BUT IT WORKED ONCE--TAA
+ MOVEI C,(A)
+ MOVEI A,(B)
+ MOVEI B,TLIST ; TYPE WORD LIST
+ PUSHJ P,MARK ; MARK IT
+ POP P,A
+ JRST ATOMK5
+
+ATOMK:
+ATOMK5: HLRE B,A
+ SUB A,B ; A POINTS TO DOPE WORD
+ SKIPGE 1(A) ; SKIP IF NOT MARKED
+ JRST GCRET ; EXIT IF MARKED
+ HLRZ B,1(A)
+ SUBI B,3
+ HRLI B,1(B)
+ MOVEI C,-1(A)
+ SUB C,B ; IN CASE WAS DW
+ IORM D,1(A) ; MARK IT
+ HRRZ A,2(C) ; MARK OBLIST
+ CAMG A,VECBOT
+ JRST NOOBL ; NO IMPURE OBLIST
+ HRLI A,-1
+ MOVEI B,TOBLS ; MARK THE OBLIST
+ PUSHJ P,MARK
+NOOBL: HLRZ A,2(C) ; GET NEXT ATOM
+ MOVEI B,TATOM
+ PUSHJ P,MARK
+ HLRZ B,(C) ; GET VALUE SLOT
+ TRZ B,400000 ; TURN OFF MARK BIT
+ SKIPE B ; SEE IF 0
+ CAIN B,TUNBOUN ; SEE IF UNBOUND
+ JRST GCRET
+ HRRZ 0,(C) ; SEE IF VECTOR OR TP POINTER
+ MOVEI B,TVEC ; ASSUME VECTOR
+ SKIPE 0 ; SKIP IF VECTOR
+ MOVEI B,TTP ; IT IS A TP POINTER
+ PUSHJ P,MARK1 ; GO MARK IT
+ JRST GCRET
+\f
+; ROUTINE TO MARK BYTE AND STRING POINTERS
+
+BYTMK: PUSHJ P,BYTDOP ; GET TO DOPE WORD INTO A
+ HRLZ F,-1(A) ; SEE IF SPECIAL ATOM [SPNAME]
+ ANDI F,SATMSK ; GET SAT
+ CAIN F,SATOM
+ JRST ATMSET ; IT IS AN ATOM
+ IORM D,(A) ; MARK IT
+ JRST GCRET
+
+ATMSET: HLRZ B,(A) ; GET LENGTH
+ TRZ B,400000 ; TURN OFF POSSIBLE MARK BIT
+ MOVNI B,-2(B) ; GENERATE AOBJN POINTER
+ ADDI A,-1(B) ; GET BACK TO BEGINNING
+ HRLI A,(B) ; PUT IN LEFT HALF
+ MOVEI B,TATOM ; MARK AS AN ATOM
+ PUSHJ P,MARK ; GO MARK
+ JRST GCRET
+
+; MARK LOCID GOODIES
+
+LOCMK: HRRZ B,(C) ; CHECK FOR TIME
+ JUMPE B,LOCMK1 ; SKIP LEGAL CHECK FOR GLOBAL
+ HRRZ 0,2(A) ; GET OTHER TIME
+ CAIE 0,(B) ; SAME?
+ JRST GCRET
+ MOVEI B,TTP
+ PUSHJ P,MARK1
+ JRST GCRET
+LOCMK1: MOVEI B,TVEC ; GLOBAL
+ PUSHJ P,MARK1 ; MARK VALUE
+ JRST GCRET
+
+; MARK ASSOCIATION BLOCK
+
+ASMK: MOVEI C,(A) ; SAVE POINTER TO BEGINNING OF ASSOCATION
+ ADDI A,ASOLNT ; POINT TO DOPE WORD
+ HLRE B,1(A) ; GET SECOND D.W.
+ JUMPL B,GCRET ; MARKED SO LEAVE
+ IORM D,1(A) ; MARK ASSOCATION
+ PUSHJ P,MARK2 ; MARK ITEM
+ MOVEI C,INDIC(C)
+ PUSHJ P,MARK2
+ MOVEI C,VAL-INDIC(C)
+ PUSHJ P,MARK2
+ HRRZ A,NODPNT-VAL(C) ; GET NEXT IN CHAIN
+ JUMPN A,ASMK ; GO MARK IT
+ JRST GCRET
+\f
+; MARK OFFSETS
+
+OFFSMK: PUSH P,$TLIST
+ HLRZ 0,1(C) ; PICK UP LIST POINTER
+ PUSH P,0
+ MOVEI C,-1(P)
+ PUSHJ P,MARK2 ; MARK THE LIST
+ SUB P,[2,,2]
+ JRST GCRET ; AND RETURN
+\f
+; HERE TO MARK TEMPLATE DATA STRUCTURES
+
+TD.MK: 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
+ SKIPL 1(A) ; SEE IF MARKED
+ JRST GCRET ; IF MARKED LEAVE
+ IORM D,1(A)
+
+ 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,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,-3(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,-4(P) ; SAVE ELMENT #
+ SKIPN B,-3(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,-3(P) ; PLUS BASIC
+ ADDI A,1 ; AND FUDGE
+ MOVEM A,-4(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
+ EXCH A,B ; REARRANGE
+ HLRZS B
+ MOVSI D,400000 ; RESET FOR MARK
+ PUSHJ P,MARK ; AND MARK THIS GUY (RET FIXED POINTER IN A)
+ MOVE C,-2(P) ; RESTORE POINTER IN CASE MUNGED
+ JRST TD.MR2
+
+TD.MR1: SUB P,[5,,5]
+ JRST GCRET
+
+USRAGC: XCT (E) ; MARK THE TEMPLATE
+ JRST GCRET
+
+\f
+; ROUTINE TO MARK THE GC-READ TABLE. MARKS THE ATOMS AT THE DOPE WORDS
+; AND UPDATES PTR TO THE TABLE.
+
+GCRDMK: MOVEI C,(A) ; SAVE POINTER TO GCREAD TABLE
+ HLRE B,A ; GET TO DOPE WORD
+ SUB A,B
+ SKIPGE 1(A) ; SKIP IF NOT MARKED
+ JRST GCRET
+ SUBI A,2
+ MOVE B,ABOTN ; GET TOP OF ATOM TABLE
+ ADD B,0 ; GET BOTTOM OF ATOM TABLE
+GCRD1: CAMG A,B ; DON'T SKIP IF DONE
+ JRST GCRET
+ 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
+ POP P,A
+ POP P,B
+ JRST GCRD1
+GCRD3: SUBI A,(C) ; TO NEXT ATOM
+ JRST GCRD1
+
+
+; ROUTINE TO FIX UP CHANNELS
+
+CHNFLS: MOVEI 0,N.CHNS-1
+ MOVE A,[TCHAN,,CHNL1] ; SET UP POINTER
+CHFL1: SKIPN B,1(A) ; GET POINTER TO CHANNEL
+ JRST CHFL2 ; NO CHANNEL LOOP TO NEXT
+ HLRE C,B ; POINT TO DOPE WORD OF CHANNEL
+ SUBI B,(C)
+ HLLM A,(A) ; PUT TYPE BACK
+ SKIPL 1(B) ; SKIP IF MARKED
+ JRST FLSCH ; FLUSH THE CHANNEL
+ MOVEI F,1 ; MARK THE CHANNEL AS GOOD
+ HRRM F,(A) ; SMASH IT IN
+CHFL2: ADDI A,2
+ SOJG 0,CHFL1
+ POPJ P, ; EXIT
+FLSCH: HLLOS F,(A) ; -1 INTO SLOT INDICATES LOSSAGE
+ JRST CHFL2
+
+
+
+\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
+ 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
+; ROUTINE TO SEEP THROUGH GC SPACE LOOKING FOR FREE SLOTS. PAIRS ARE PLACED ON THE
+; RCL LIST, VECTORS ON THE RCLV LIST.
+
+SWEEP: MOVE C,GCSTOP ; GET TOP OF GC SPACE
+ SUBI C,1 ; POINT TO FIRST OBJECT
+ SETZB E,F ; CURRENT SLOT AND CURRENT LENGTH
+LSWEEP: CAMG C,GCSBOT ; SKIP IF ABOVE GCSBOT
+ JRST ESWEEP ; DONE
+ HLRE A,-1(C) ; SEE IF LIST OR VECTOR
+ TRNE A,UBIT ; SKIP IF LIST
+ JRST VSWEEP ; IT IS A VECTOR
+ JUMPGE A,LSWP1 ; JUMP IF NOT MARKED
+ ANDCAM D,-1(C) ; TURN OFF MARK BIT
+ PUSHJ P,SWCONS ; CONS ON CURRENT OBJECT
+ SUBI C,2 ; SKIP OVER LIST
+ JRST LSWEEP
+LSWP1: ADDI F,2 ; ADD TO CURRENT OBJECT COUNT
+ JUMPN E,LSWP2 ; JUMP IF CURRENT OBJECT EXISTS
+ MOVEI E,(C) ; GET ADDRESS
+LSWP2: SUBI C,2
+ JRST LSWEEP
+
+VSWEEP: HLRE A,(C) ; GET LENGTH
+ JUMPGE A,VSWP1 ; SKIP IF MARKED
+ ANDCAM D,(C) ; TURN OFF MARK BIT
+ PUSHJ P,SWCONS
+ ANDI A,377777 ; GET LENGTH PART
+ SUBI C,(A) ; GO PAST VECTOR
+ JRST LSWEEP
+VSWP1: ADDI F,(A) ; ADD LENGTH
+ JUMPN E,VSWP2
+ MOVEI E,(C) ; GET NEW OBJECT LOCATION
+VSWP2: SUBI C,(A) ; GO BACK PAST VECTOR
+ JRST LSWEEP
+
+ESWEEP:
+SWCONS: JUMPE E,CPOPJ
+ ADDM F,TOTCNT ; HACK TOTCNT
+ CAMLE F,MAXLEN ; SEE IF NEW MAXIMUM
+ MOVEM F,MAXLEN
+ CAIGE F,2 ; MAKE SURE AT LEAST TWO LONG
+ FATAL SWEEP FAILURE
+ CAIN F,2
+ JRST LCONS
+ SETZM (E)
+ MOVEI 0,(E)
+ SUBI 0,-1(F)
+ SETZM @0
+ HRLS 0
+ ADDI 0,1
+ BLT 0,-2(E)
+ HRRZ 0,RCLV ; GET VECTOR RECYCLE
+ HRRM 0,(E) ; SMASH INTO LINKING SLOT
+ HRRZM E,RCLV ; NEW RECYCLE SLOT
+ HRLM F,(E)
+ MOVSI F,UBIT
+ MOVEM F,-1(E)
+ SETZB E,F
+ POPJ P, ; DONE
+LCONS: SETZM (E)
+ SUBI E,1
+ HRRZ 0,RCL ; GET RECYCLE LIST
+ HRRZM 0,(E) ; SMASH IN
+ HRRZM E,RCL
+ SETZB E,F
+ POPJ P,
+
+\f
+; 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
+
+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 /]
+
+CONSTANTS
+
+HERE
+
+CONSTANTS
+
+OFFSET 0
+
+ZZ==$.+1777
+
+.LOP ANDCM ZZ 1777
+
+ZZ1==.LVAL1
+
+LOC ZZ1
+
+OFFSET OFFS
+
+MRKPDL==.-1
+
+ENDGC:
+
+OFFSET 0
+
+ZZ2==ENDGC-AGCLD
+
+.LOP <ASH @> ZZ2 <,-10.>
+SLENGC==.LVAL1
+.LOP <ASH @> SLENGC <10.>
+RSLENG==.LVAL1
+LOC GCST
+
+.LPUR=$.
+
+END
--- /dev/null
+TITLE AMSGC MUDDLE MARK SWEEP GARBAGE COLLECTOR
+
+RELOCATABLE
+
+.GLOBAL RCL,RCLV,IAMSGC,MAXLEN,REALGC,RGCLEN,GCFLG,SQUPNT,GCMONF,MSGTYP,GCCAUS
+.GLOBAL GCCALL,PVSTOR,DSTORE,TYPVEC,N.CHNS,CHNL1,MAINPR,STOGC,CTIME,GCTIM,IMTYO
+.GLOBAL FNMSGC,SATMSK,NUMSAT,NUMPRI,PURBOT,GCSTOP,GCSBOT,STOSTR,TYPMSK,PDLBUF,ITEM,INDIC
+.GLOBAL VAL,NODPNT,UBIT,ASOLNT,GCHAPN,RBLDM,TOTCNT,MARK2S,MKTBS
+.GLOBAL FRMUNG,BYTDOP,TD.GET,TD.LNT,TD.AGC,ABOTN,SLENGC,LENGC,REALGC,AGCLD,RLENGC
+.GLOBAL RSLENG
+
+GCST=$.
+
+LOC REALGC+RLENGC
+
+OFFS=AGCLD-$.
+OFFSET OFFS
+
+.INSRT MUDDLE >
+
+TYPNT==AB
+F==PVP
+
+
+; THIS IS THE MUDDLE MARK SWEEP GARBAGE COLLECTOR. IT IS MUCH FASTER THAN THE COPYING
+; GARBAGE COLLECTOR BUT DOESN'T COMPACT. IT CONSES FREE THINGS ONTO RCL AND RCLV.
+; THIS GARBAGE COLLECTOR CAN ONLY BE USED IF THE GARBAGE COLLECT IS A FREE STORAGE
+; GARBAGE COLLECT
+
+\f
+; FIRST INITIALIZE VARIABLES
+
+IAMSGC: SETZB M,RCL ; CLEAR OUT LIST RECYCLE AND RSUBR BASE
+ SETZM RCLV ; CLEAR VECTOR RECYCLE
+ SETZM MAXLEN ; CLEAR MAXIMUM LENGTH FOUND TO RECYCLE
+ SETOM GCFLG ; A GC HAS HAPPENED
+ SETZM TOTCNT
+ HLLZS SQUPNT ; CLEAR OUT SQUOZE TABLE
+
+; SET UP MESSAGE PRINTING AND SAVE CAUSE AND CAUSER
+
+ PUSH P,A
+ PUSH P,B
+ PUSH P,C ; SAVE ACS
+ MOVEI B,[ASCIZ /MSGIN / ] ; PRINT GIN IF WINNING
+ SKIPE GCMONF
+ PUSHJ P,MSGTYP
+ HRRZ C,(P) ; GET CAUSE INDICATOR
+ ADDI B,1 ; AOS TO GET REAL CAUS
+ MOVEM B,GCCAUS
+ SKIPN GCMONF
+ 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
+ SKIPN GCMONF ; PRINT IF GCMON IS ON
+ JRST NOMON3
+ MOVE B,MSGGFT(C) ; GET POINTER TO MESSAGE
+ PUSHJ P,MSGTYP
+NOMON3: SUB P,[1,,1]
+ POP P,B ; RESTORE ACS
+ POP P,A
+
+; MOVE ACS INTO THE PVP
+
+ EXCH PVP,PVSTOR+1 ; GET REAL PROCESS VECTOR
+
+ IRP AC,,[0,A,B,C,D,E,TVP,SP,AB,TB,TP,FRM,M,R,P]
+ MOVEM AC,AC!STO+1(PVP)
+ TERMIN
+
+ MOVE 0,PVSTOR+1 ; GET OLD VALUE OF PVP
+ MOVEM 0,PVPSTO+1(PVP) ; SAVE PVP
+ MOVE 0,DSTORE ; SAVE D'S TYPE
+ MOVEM 0,DSTO(PVP)
+ MOVEM PVP,PVSTOR+1
+
+; SET UP TYPNT TO POINT TO TYPE VECTOR
+
+ GETYP E,TYPVEC ; FIRST SEE IF TYPVEC IS A VECTOR
+ CAIE E,TVEC
+ FATAL TYPE VECTOR NOT OF TYPE VECTOR
+ HRRZ TYPNT,TYPVEC+1
+ HRLI TYPNT,B ; TYPNT IS NOW TYPEVECTOR(B)
+
+; NOW SET UP GCPDL AND FENCE POST PDL'S
+
+ MOVEI A,(TB)
+ MOVE D,P ; SAVE P POINTER
+ PUSHJ P,FRMUNG
+ MOVE P,[-2000,,MRKPDL] ; SET UP MARK PDL
+ MOVEI A,(TB) ; FIXUP TOP FRAME
+ SETOM 1(TP) ; FENCEPOST TP
+ SETOM 1(D) ; FENCEPOST P
+
+; NOW SETUP AUTO CHANNEL CLOSE
+
+ MOVEI 0,N.CHNS-1 ; NUMBER OF CHANNELS
+ MOVEI A,CHNL1 ; FIRST CHANNEL SLOT
+CHNCLR: SKIPE 1(A) ; IS IT A CHANNEL
+ SETZM (A) ; CLEAR UP TYPE SLOT
+ ADDI A,2
+ SOJG 0,CHNCLR
+
+; NOW DO MARK AND SWEEP PHASES
+
+ MOVSI D,400000 ; MARK BIT
+ MOVEI B,TPVP ; GET TYPE
+ MOVE A,PVSTOR+1 ; GET VALUE OF CURRENT PROCESS VECTOR
+ PUSHJ P,MARK
+ MOVEI B,TPVP ; GET TYPE OF MAIN PROCESS VECTOR
+ MOVE A,MAINPR
+ PUSHJ P,MARK ; MARK
+ PUSHJ P,CHNFLS ; DO CHANNEL FLUSHING
+ PUSHJ P,CHFIX
+ PUSHJ P,STOGC ; FIX UP FROZEN WORLD
+ PUSHJ P,SWEEP ; SWEEP WORLD
+
+; PRINT GOUT
+
+ MOVEI B,[ASCIZ /MSGOUT /] ; PRINT OUT ENDING MESSAGE IF GCMONING
+ SKIPE GCMONF
+ PUSHJ P,MSGTYP
+
+; RESTORE ACS
+
+ MOVE PVP,PVSTOR+1 ; GET PVP
+ IRP AC,,[0,A,B,C,D,E,TVP,SP,AB,TB,TP,FRM,M,R,P]
+ MOVE AC,AC!STO+1(PVP)
+ TERMIN
+
+ SKIPN DSTORE ; CLEAR OUT TYPE IF NO TYPE THERE
+ SETZM DSTO(PVP)
+ MOVE PVP,PVPSTO+1(PVP)
+
+; PRINT TIME
+
+ PUSH P,A ; SAVE ACS
+ PUSH P,B
+ PUSH P,C
+ PUSH P,D
+ PUSHJ P,CTIME ; GET CURRENT CPU TIME
+ FSBR B,GCTIM ; COMPUTE TIME ELAPSED
+ MOVEM B,GCTIM ; SAVE TIME AWAY
+ SKIPN GCMONF ; PRINT IT OUT?
+ JRST GCCONT
+ PUSHJ P,FIXSEN
+ MOVEI A,15 ; OUTPUT CR/LF
+ PUSHJ P,IMTYO
+ MOVEI A,12
+ PUSHJ P,IMTYO
+GCCONT: POP P,D ; RESTORE ACS
+ POP P,C
+ POP P,B
+ POP P,A
+ SETZM GCFLG
+ SETOM GCHAPN
+ SETOM INTFLG
+ PUSHJ P,RBLDM
+ JRST FNMSGC ; DONE
+
+\f
+; THIS IS THE MARK PHASE
+
+; GENERAL MARK ROUTINE, CALLED TO MARK ALL THINGS
+; /A POINTER TO GOODIE
+; /B TYPE OF GOODIE
+; FOR MARK2, MARK1 /C POINTER TO PAIR NOT NEEDED FOR CALLS DIRECTLY TO MARK
+
+MARK2S:
+MARK2: HLRZ B,(C) ; TYPE
+MARK1: MOVE A,1(C) ; VALUE
+MARK: JUMPE A,CPOPJ ; DONE IF ZERO
+ MOVEI 0,1(A) ; SEE IF PURE
+ CAML 0,PURBOT
+ JRST CPOPJ
+ ANDI B,TYPMSK ; FLUSH MONITORS
+ HRLM C,(P)
+ CAIG B,NUMPRI ; IS A BASIC TYPE
+ JRST @MTYTBS(B) ; TYPE DISPATCH
+ LSH B,1 ; NOW GET PRIMTYPE
+ HRRZ B,@TYPNT ; GET PRIMTYPE
+ ANDI B,SATMSK ; FLUSH DOWN TO SAT
+ CAIG B,NUMSAT ; SKIP IF TEMPLATE DATA
+ JRST @MSATBS(B) ; JUMP OFF SAT TABLE
+ JRST TD.MK
+
+GCRET: HLRZ C,(P) ; GET SAVED C
+CPOPJ: POPJ P,
+
+; TYPE DISPATCH TABLE
+MTYTBS:
+
+OFFSET 0
+
+DUM1:
+
+IRP XX,,[[TLOSE,GCRET],[TFIX,GCRET],[TFLOAT,GCRET],[TCHRS,GCRET]
+[TENTRY,GCRET],[TSUBR,GCRET],[TFSUBR,GCRET],[TILLEG,GCRET],[TUNBOU,GCRET]
+[TBIND,GCRET],[TTIME,GCRET],[TLIST,PAIRMK],[TFORM,PAIRMK],[TSEG,PAIRMK]
+[TEXPR,PAIRMK],[TFUNAR,PAIRMK],[TLOCL,PAIRMK],[TFALSE,PAIRMK],[TDEFER,DEFQMK]
+[TUVEC,UVMK],[TOBLS,UVMK],[TVEC,VECMK],[TCHAN,VECMK] ,[TLOCV,VECMK]
+[TTVP,VECMK],[TBVL,VECMK],[TTAG,VECMK],[TPVP,VECMK],[TLOCI,TPMK],[TTP,TPMK]
+[TSP,TPMK],[TMACRO,PAIRMK],[TPDL,PMK],[TARGS,ARGMK],[TAB,ABMK]
+[TTB,TBMK],[TFRAME,FRMK],[TCHSTR,BYTMK],[TATOM,ATOMK],[TLOCD,LOCMK],[TBYTE,BYTMK]
+[TENV,FRMK],[TACT,FRMK],[TASOC,ASMK],[TLOCU,UVMK],[TLOCS,BYTMK],[TLOCA,ASMK]
+[TCBLK,GCRET],[TTMPLT,TD.MK],[TLOCT,TD.MK],[TLOCR,GCRET],[TINFO,GCRET]
+[TRDTB,GCRDMK],[TWORD,GCRET],[TRSUBR,VECMK],[TCODE,UVMK],[TSATC,GCRET]
+[TBITS,GCRET],[TSTORA,UVMK],[TPICTU,UVMK],[TSKIP,TPMK],[TLINK,ATOMK]
+[TDECL,PAIRMK],[TENTER,VECMK],[THAND,VECMK],[TINTH,VECMK],[TDISMI,ATOMK]
+[TDCLI,PAIRMK],[TPCODE,GCRET],[TTYPEW,GCRET],[TTYPEC,GCRET]
+[TGATOM,GATOMK],[TREADA,FRMK],[TUBIND,GCRET],[TUNWIN,TBMK],[TLOCB,BYTMK]
+[TDEFQ,DEFQMK],[TSPLIC,PAIRMK],[TLOCN,ASMK],[TOFFS,OFFSMK]]
+ IRP A,B,[XX]
+ LOC DUM1+A
+ SETZ B
+ .ISTOP
+ TERMIN
+TERMIN
+
+LOC DUM1+NUMPRI+1
+
+OFFSET OFFS
+
+; SAT DISPATCH TABLE
+
+MSATBS:
+
+OFFSET 0
+
+DISTB2 DUM2,GCRET,[[S2WORD,PAIRMK],[S2DEFR,DEFMK],[SNWORD,UVMK],[STBASE,TBMK]
+[STPSTK,TPMK],[SARGS,<SETZ ARGMK>],[S2NWORD,VECMK],[SPSTK,TPMK],[SSTORE,UVMK]
+[SFRAME,<SETZ FRMK>],[SBYTE,<SETZ BYTMK>],[SATOM,ATOMK],[SPVP,VECMK],[SGATOM,GATOMK]
+[SLOCID,<SETZ LOCMK>],[SCHSTR,<SETZ BYTMK>],[SASOC,ASMK],[SLOCL,PAIRMK],[SABASE,ABMK]
+[SLOCA,<SETZ ARGMK>],[SLOCV,VECMK],[SLOCU,UVMK],[SLOCS,<SETZ BYTMK>],[SLOCN,ASMK]
+[SRDTB,GCRDMK],[SLOCB,<SETZ BYTMK>],[SDEFQ,DEFQMK],[SOFFS,OFFSMK]]
+
+OFFSET OFFS
+
+\f
+; ROUTINE TO MARK PAIRS
+
+PAIRMK: MOVEI C,(A)
+PAIRM1: CAMG C,GCSTOP ; SEE IF IN RANGE
+ CAIGE C,STOSTR
+ JRST BADPTR ; FATAL ERROR
+ HLRE B,(C) ; SKIP IF NOT MARKED
+ JUMPL B,GCRET
+ IORM D,(C) ; MARK IT
+ PUSHJ P,MARK1 ; MARK THE ITEM
+ HRRZ C,(C) ; GET NEXT ELEMENT OF LIST
+ JUMPE C,GCRET
+ CAML C,PURBOT
+ JRST GCRET
+ JRST PAIRM1
+
+; ROUTINE TO MARK DEFERS
+
+DEFMK: HLRE B,(A)
+ JUMPL B,GCRET
+ MOVEI C,(A)
+ IORM D,(C)
+ PUSHJ P,MARK1
+ JRST GCRET
+
+; ROUTINE TO MARK POSSIBLE DEFERS DEF?
+
+DEFQMK: GETYP B,(A) ; GET THE TYPE OF THE OBJECT
+ LSH B,1 ; COMPUTE THE SAT
+ HRRZ B,@TYPNT
+ ANDI B,SATMSK
+ SKIPL MKTBS(B) ; SKIP IF NOT DEFERED
+ JRST PAIRMK
+ JRST DEFMK ; GO TO DEFMK
+
+\f
+; ROUTINE TO MARK VECTORS
+
+VECMK: HLRE B,A ; GET LENGTH
+ SUB A,B
+ MOVEI C,1(A) ; POINT TO SECOND DOPE WORD
+ CAIL C,STOSTR ; CHECK FOR IN RANGE
+ CAMLE C,GCSTOP
+ JRST BADPTR
+ HLRE B,(C)
+ JUMPL B,GCRET
+ IORM D,(C) ; MARK IT
+ SUBI C,-1(B) ; GET TO BEGINNING
+VECMK1: HLRE B,(C) ; GET TYPE AND SKIP IF NOT DOPE WORD
+ JUMPL B,GCRET ; DONE
+ PUSHJ P,MARK1 ; MARK IT
+ ADDI C,2 ; NEXT ELEMENT
+ JRST VECMK1
+
+; ROUTINE TO MARK UVECTORS
+
+UVMK: HLRE B,A ; GET LENGTH
+ SUB A,B ; A POINTS TO FIRST DOPE WORD
+ MOVEI C,1(A) ; C POINTS TO SECOND DOPE WORD
+ CAIL C,STOSTR ; CHECK FOR IN RANGE
+ CAMLE C,GCSTOP
+ JRST BADPTR
+ HLRE F,(C) ; GET LENGTH
+ JUMPL F,GCRET
+ IORM D,(C) ; MARK IT
+ GETYP B,-1(C) ; GET TYPE
+ MOVEI E,(B) ; COPY TYPE FOR SAT COMPUTATION
+ LSH B,1
+ HRRZ B,@TYPNT ; GET SAT
+ ANDI B,SATMSK
+ MOVEI B,@MSATBS(B) ; GET JUMP LOCATION
+ CAIN B,GCRET
+ JRST GCRET
+ SUBI C,(F) ; POINT TO BEGINNING OF UVECTOR
+ SUBI F,2
+ JUMPE F,GCRET
+ PUSH P,F ; SAVE LENGTH
+ PUSH P,E
+UNLOOP: MOVE B,(P)
+ MOVE A,1(C) ; GET VALUE POINTER
+ PUSHJ P,MARK
+ SOSE -1(P) ; SKIP IF NON-ZERO
+ AOJA C,UNLOOP ; GO BACK AGAIN
+ SUB P,[2,,2] ; CLEAN OFF STACK
+ JRST GCRET
+
+; ROUTINE TO INDICATE A BAD POINTER
+
+BADPTR: FATAL POINTER POINTS OUT OF GARBAGE COLLECTED SPACE
+ JRST GCRET
+
+\f
+; ROUTINE TO MARK A TPSTACK
+
+TPMK: HLRE B,A ; GET LENGTH
+ SUB A,B ; A POINTS TO FIRST DOPE WORD
+ MOVEI C,PDLBUF+1(A) ; C POINTS TO SECOND DOPE WORD
+ CAIL C,STOSTR ; CHECK FOR IN RANGE
+ CAMLE C,GCSTOP
+ JRST BADPTR
+ HLRE A,(C)
+ JUMPL A,GCRET
+ IORM D,(C) ; MARK IT
+ SUBI C,-1(A) ; GO TO BEGINNING
+
+TPLP: HLRE B,(C) ; GET TYPE AND MARKING
+ JUMPL B,GCRET ; EXIT ON FENCE-POST
+ ANDI B,TYPMSK ; FLUSH MONITORS
+ CAIE B,TCBLK ; CHECK FOR FRAME
+ CAIN B,TENTRY
+ JRST MFRAME ; MARK THE FRAME
+ CAIE B,TUBIND ; BINDING BLOCK
+ CAIN B,TBIND
+ JRST MBIND
+ PUSHJ P,MARK1 ; NOTHING SPECIAL SO MARK IT
+ ADDI C,2 ; POINT TO NEXT OBJECT
+ JRST TPLP ; MARK IT
+
+; MARK A FRAME ON THE STACK, [I.E. ITS FSAV AND PSAV SLOTS]
+
+MFRAME: HRROI C,FRAMLN+FSAV-1(C) ; POINT TO FUNCTION
+ HRRZ A,1(C) ; GET POINTER
+ CAIL A,STOSTR ; SEE IF IN GC SPACE
+ CAMLE A,GCSTOP
+ JRST MFRAM1 ; SKIP OVER IT, NOT IN GC-SPACE
+ HRL A,(A) ; GET LENGTH
+ MOVEI B,TVEC ; TYPE IS VECTOR [RSUBR OR RSUBR-ENTRY]
+ PUSHJ P,MARK
+MFRAM1: MOVE A,PSAV-FSAV+1(C) ; MARK THE PSTACK
+ MOVEI B,TPDL
+ PUSHJ P,MARK
+ HRROI C,-FSAV+1(C) ; POINT PAST FRAME
+ JRST TPLP ; GO BACK TO START OF LOOP
+
+; MARK A BINDING ON THE STACK [I.E. THE ATOM, VALUE, DECL, AND PREVIOUS BINDING]
+
+MBIND: MOVEI B,TATOM ; START BY MARKING THE ATOM
+ PUSHJ P,MARK1 ; MARK IT
+ ADDI C,2 ; POINT TO VALUE SLOT
+ PUSHJ P,MARK2 ; MARK THE VALUE
+ ADDI C,2 ; POINT TO DECL AND PREV BINDING
+ MOVEI B,TLIST ; MARK DECL
+ HLRZ A,(C)
+ PUSHJ P,MARK
+ SKIPL A,1(C) ; SKIP IF PREVIOUS BINDING
+ JRST NOTLCI
+ MOVEI B,TLOCI ; GET TYPE
+ PUSHJ P,MARK
+NOTLCI: ADDI C,2 ; POINT PAST BINDING
+ JRST TPLP
+
+
+PMK: HLRE B,A ; GET LENGTH
+ SUB A,B ; A POINTS TO FIRST DOPE WORD
+ MOVEI C,PDLBUF+1(A) ; C POINTS TO SECOND DOPE WORD
+ CAIL C,STOSTR ; CHECK FOR IN RANGE
+ CAMLE C,GCSTOP
+ JRST BADPTR
+ IORM D,(C) ; MARK IT
+ JRST GCRET
+\f
+; ROUTINE TO MARK TB POINTER
+
+TBMK: HRRZS A ; CHECK FOR NIL POINTER
+ SKIPN A
+ JRST GCRET
+ MOVE A,TPSAV(A) ; GET A TP POINTER
+ MOVEI B,TTP ; TYPE WORD
+ PUSHJ P,MARK
+ JRST GCRET
+
+; ROUTINE TO MARK AB POINTERS
+
+ABMK: HLRE B,A ; GET TO FRAME
+ SUB A,B
+ MOVE A,FRAMLN+TPSAV(A) ; GET A TP POINTER
+ MOVEI B,TTP ; TYPE WORD
+ PUSHJ P,MARK
+ JRST GCRET
+
+; ROUTINE TO MARK FRAME POINTERS
+
+FRMK: HRLZ B,A ; GET THE TIME
+ HLRZ F,OTBSAV(A) ; GET TIME FROM FRAME
+ CAIE B,(F) ; SKIP IF TIMES AGREE
+ JRST GCRET ; IGNORE POINTER IF THEY DONT
+ HRRZ A,(C) ; GET POINTER TO PROCESS
+ SUBI A,1 ; FUDGE FOR VECTOR MARKING
+ MOVEI B,TPVP ; TYPE WORD
+ PUSHJ P,MARK
+ HRRZ A,1(C) ; GET POINTER TO FRAME
+ JRST TBMK ; MARK IT
+
+; ROUTINE TO MARK ARGUMENT BLOCKS [TUPLES]
+
+ARGMK: HLRE B,A ; GET LENGTH
+ SUB A,B ; POINT PAST BLOCK
+ CAIL A,STOSTR
+ CAMLE A,GCSTOP ; SEE IF IN GCSPACE
+ JRST GCRET
+ HRLZ 0,(A) ; GET TYPE
+ ANDI 0,TYPMSK ; FLUSH MONITORS
+ CAIE 0,TENTRY
+ CAIN 0,TCBLK
+ JRST ARGMK1 ; AT FRAME
+ CAIE 0,TINFO ; AT FRAME
+ JRST GCRET ; NOT A LEGAL TYPE GO AWAY
+ HRRZ A,1(A) ; POINTING TO FRAME
+ HRL A,(C) ; GET TIME
+ JRST TBMK
+ARGMK1: HRRI A,FRAMLN(A) ; MAKE POINTER
+ HRL A,(C) ; GET TIME
+ JRST TBMK
+\f
+
+; ROUTINE TO MARK GLOBAL SLOTS
+
+GATOMK: HRRZ B,(C) ; GET POSSIBLE GDECL
+ JUMPE B,ATOMK ; NONE GO TO MARK ATOM
+ CAIN B,-1 ; SKIP IF NOT MANIFEST
+ JRST ATOMK
+ PUSH P,A ; I DOUBT THIS IS RIGHT, BUT IT WORKED ONCE--TAA
+ MOVEI C,(A)
+ MOVEI A,(B)
+ MOVEI B,TLIST ; TYPE WORD LIST
+ PUSHJ P,MARK ; MARK IT
+ POP P,A
+ JRST ATOMK5
+
+ATOMK:
+ATOMK5: HLRE B,A
+ SUB A,B ; A POINTS TO DOPE WORD
+ SKIPGE 1(A) ; SKIP IF NOT MARKED
+ JRST GCRET ; EXIT IF MARKED
+ HLRZ B,1(A)
+ SUBI B,3
+ HRLI B,1(B)
+ MOVEI C,-1(A)
+ SUB C,B ; IN CASE WAS DW
+ IORM D,1(A) ; MARK IT
+ HRRZ A,2(C) ; MARK OBLIST
+ CAMG A,VECBOT
+ JRST NOOBL ; NO IMPURE OBLIST
+ HRLI A,-1
+ MOVEI B,TOBLS ; MARK THE OBLIST
+ PUSHJ P,MARK
+NOOBL: HLRZ A,2(C) ; GET NEXT ATOM
+ MOVEI B,TATOM
+ PUSHJ P,MARK
+ HLRZ B,(C) ; GET VALUE SLOT
+ TRZ B,400000 ; TURN OFF MARK BIT
+ SKIPE B ; SEE IF 0
+ CAIN B,TUNBOUN ; SEE IF UNBOUND
+ JRST GCRET
+ HRRZ 0,(C) ; SEE IF VECTOR OR TP POINTER
+ MOVEI B,TVEC ; ASSUME VECTOR
+ SKIPE 0 ; SKIP IF VECTOR
+ MOVEI B,TTP ; IT IS A TP POINTER
+ PUSHJ P,MARK1 ; GO MARK IT
+ JRST GCRET
+\f
+; ROUTINE TO MARK BYTE AND STRING POINTERS
+
+BYTMK: PUSHJ P,BYTDOP ; GET TO DOPE WORD INTO A
+ HRLZ F,-1(A) ; SEE IF SPECIAL ATOM [SPNAME]
+ ANDI F,SATMSK ; GET SAT
+ CAIN F,SATOM
+ JRST ATMSET ; IT IS AN ATOM
+ IORM D,(A) ; MARK IT
+ JRST GCRET
+
+ATMSET: HLRZ B,(A) ; GET LENGTH
+ TRZ B,400000 ; TURN OFF POSSIBLE MARK BIT
+ MOVNI B,-2(B) ; GENERATE AOBJN POINTER
+ ADDI A,-1(B) ; GET BACK TO BEGINNING
+ HRLI A,(B) ; PUT IN LEFT HALF
+ MOVEI B,TATOM ; MARK AS AN ATOM
+ PUSHJ P,MARK ; GO MARK
+ JRST GCRET
+
+; MARK LOCID GOODIES
+
+LOCMK: HRRZ B,(C) ; CHECK FOR TIME
+ JUMPE B,LOCMK1 ; SKIP LEGAL CHECK FOR GLOBAL
+ HRRZ 0,2(A) ; GET OTHER TIME
+ CAIE 0,(B) ; SAME?
+ JRST GCRET
+ MOVEI B,TTP
+ PUSHJ P,MARK1
+ JRST GCRET
+LOCMK1: MOVEI B,TVEC ; GLOBAL
+ PUSHJ P,MARK1 ; MARK VALUE
+ JRST GCRET
+
+; MARK ASSOCIATION BLOCK
+
+ASMK: MOVEI C,(A) ; SAVE POINTER TO BEGINNING OF ASSOCATION
+ ADDI A,ASOLNT ; POINT TO DOPE WORD
+ HLRE B,1(A) ; GET SECOND D.W.
+ JUMPL B,GCRET ; MARKED SO LEAVE
+ IORM D,1(A) ; MARK ASSOCATION
+ PUSHJ P,MARK2 ; MARK ITEM
+ MOVEI C,INDIC(C)
+ PUSHJ P,MARK2
+ MOVEI C,VAL-INDIC(C)
+ PUSHJ P,MARK2
+ HRRZ A,NODPNT-VAL(C) ; GET NEXT IN CHAIN
+ JUMPN A,ASMK ; GO MARK IT
+ JRST GCRET
+\f
+; MARK OFFSETS
+
+OFFSMK: PUSH P,$TLIST
+ HLRZ 0,1(C) ; PICK UP LIST POINTER
+ PUSH P,0
+ MOVEI C,-1(P)
+ PUSHJ P,MARK2 ; MARK THE LIST
+ SUB P,[2,,2]
+ JRST GCRET ; AND RETURN
+\f
+; HERE TO MARK TEMPLATE DATA STRUCTURES
+
+TD.MK: 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
+ SKIPL 1(A) ; SEE IF MARKED
+ JRST GCRET ; IF MARKED LEAVE
+ IORM D,1(A)
+
+ 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,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,-3(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,-4(P) ; SAVE ELMENT #
+ SKIPN B,-3(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,-3(P) ; PLUS BASIC
+ ADDI A,1 ; AND FUDGE
+ MOVEM A,-4(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
+ EXCH A,B ; REARRANGE
+ HLRZS B
+ MOVSI D,400000 ; RESET FOR MARK
+ PUSHJ P,MARK ; AND MARK THIS GUY (RET FIXED POINTER IN A)
+ MOVE C,-2(P) ; RESTORE POINTER IN CASE MUNGED
+ JRST TD.MR2
+
+TD.MR1: SUB P,[5,,5]
+ JRST GCRET
+
+USRAGC: XCT (E) ; MARK THE TEMPLATE
+ JRST GCRET
+
+\f
+; ROUTINE TO MARK THE GC-READ TABLE. MARKS THE ATOMS AT THE DOPE WORDS
+; AND UPDATES PTR TO THE TABLE.
+
+GCRDMK: MOVEI C,(A) ; SAVE POINTER TO GCREAD TABLE
+ HLRE B,A ; GET TO DOPE WORD
+ SUB A,B
+ SKIPGE 1(A) ; SKIP IF NOT MARKED
+ JRST GCRET
+ SUBI A,2
+ MOVE B,ABOTN ; GET TOP OF ATOM TABLE
+ ADD B,0 ; GET BOTTOM OF ATOM TABLE
+GCRD1: CAMG A,B ; DON'T SKIP IF DONE
+ JRST GCRET
+ 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
+ POP P,A
+ POP P,B
+ JRST GCRD1
+GCRD3: SUBI A,(C) ; TO NEXT ATOM
+ JRST GCRD1
+
+
+; ROUTINE TO FIX UP CHANNELS
+
+CHNFLS: MOVEI 0,N.CHNS-1
+ MOVEI A,,CHNL1 ; SET UP POINTER
+CHFL1: SKIPN B,1(A) ; GET POINTER TO CHANNEL
+ JRST CHFL2 ; NO CHANNEL LOOP TO NEXT
+ HLRE C,B ; POINT TO DOPE WORD OF CHANNEL
+ SUBI B,(C)
+ MOVEI F,TCHAN
+ HRLM F,(A) ; PUT TYPE BACK
+ SKIPL 1(B) ; SKIP IF MARKED
+ JRST FLSCH ; FLUSH THE CHANNEL
+ MOVEI F,1 ; MARK THE CHANNEL AS GOOD
+ HRRM F,(A) ; SMASH IT IN
+CHFL2: ADDI A,2
+ SOJG 0,CHFL1
+ POPJ P, ; EXIT
+FLSCH: HLLOS F,(A) ; -1 INTO SLOT INDICATES LOSSAGE
+ JRST CHFL2
+
+
+; THIS ROUTINE MARKS ALL THE CHANNELS
+
+CHFIX: MOVEI 0,N.CHNS-1
+ MOVEI A,CHNL1 ; SLOTS
+
+DHNFL2: SKIPN 1(A)
+ JRST DHNFL1
+ PUSH P,0 ; SAVE 0
+ PUSH P,A ; SAVE A
+ MOVEI C,(A)
+ MOVE A,1(A)
+ MOVEI B,TCHAN
+ PUSHJ P,MARK
+ POP P,A ; RESTORE A
+ POP P,0 ; RESTORE
+DHNFL1: ADDI A,2
+ SOJG 0,DHNFL2
+ 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
+ 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
+; ROUTINE TO SEEP THROUGH GC SPACE LOOKING FOR FREE SLOTS. PAIRS ARE PLACED ON THE
+; RCL LIST, VECTORS ON THE RCLV LIST.
+
+SWEEP: MOVE C,GCSTOP ; GET TOP OF GC SPACE
+ SUBI C,1 ; POINT TO FIRST OBJECT
+ SETZB E,F ; CURRENT SLOT AND CURRENT LENGTH
+LSWEEP: CAMG C,GCSBOT ; SKIP IF ABOVE GCSBOT
+ JRST ESWEEP ; DONE
+ HLRE A,-1(C) ; SEE IF LIST OR VECTOR
+ TRNE A,UBIT ; SKIP IF LIST
+ JRST VSWEEP ; IT IS A VECTOR
+ JUMPGE A,LSWP1 ; JUMP IF NOT MARKED
+ ANDCAM D,-1(C) ; TURN OFF MARK BIT
+ PUSHJ P,SWCONS ; CONS ON CURRENT OBJECT
+ SUBI C,2 ; SKIP OVER LIST
+ JRST LSWEEP
+LSWP1: ADDI F,2 ; ADD TO CURRENT OBJECT COUNT
+ JUMPN E,LSWP2 ; JUMP IF CURRENT OBJECT EXISTS
+ MOVEI E,(C) ; GET ADDRESS
+LSWP2: SUBI C,2
+ JRST LSWEEP
+
+VSWEEP: HLRE A,(C) ; GET LENGTH
+ JUMPGE A,VSWP1 ; SKIP IF MARKED
+ ANDCAM D,(C) ; TURN OFF MARK BIT
+ PUSHJ P,SWCONS
+ ANDI A,377777 ; GET LENGTH PART
+ SUBI C,(A) ; GO PAST VECTOR
+ JRST LSWEEP
+VSWP1: ADDI F,(A) ; ADD LENGTH
+ JUMPN E,VSWP2
+ MOVEI E,(C) ; GET NEW OBJECT LOCATION
+VSWP2: SUBI C,(A) ; GO BACK PAST VECTOR
+ JRST LSWEEP
+
+ESWEEP:
+SWCONS: JUMPE E,CPOPJ
+ ADDM F,TOTCNT ; HACK TOTCNT
+ CAMLE F,MAXLEN ; SEE IF NEW MAXIMUM
+ MOVEM F,MAXLEN
+ CAIGE F,2 ; MAKE SURE AT LEAST TWO LONG
+ FATAL SWEEP FAILURE
+ CAIN F,2
+ JRST LCONS
+ SETZM (E)
+ MOVEI 0,(E)
+ SUBI 0,-1(F)
+ SETZM @0
+ HRLS 0
+ ADDI 0,1
+ BLT 0,-2(E)
+ HRRZ 0,RCLV ; GET VECTOR RECYCLE
+ HRRM 0,(E) ; SMASH INTO LINKING SLOT
+ HRRZM E,RCLV ; NEW RECYCLE SLOT
+ HRLM F,(E)
+ MOVSI F,UBIT
+ MOVEM F,-1(E)
+ SETZB E,F
+ POPJ P, ; DONE
+LCONS: SETZM (E)
+ SUBI E,1
+ HRRZ 0,RCL ; GET RECYCLE LIST
+ HRRZM 0,(E) ; SMASH IN
+ HRRZM E,RCL
+ SETZB E,F
+ POPJ P,
+
+\f
+; 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
+
+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 /]
+
+CONSTANTS
+
+HERE
+
+CONSTANTS
+
+OFFSET 0
+
+ZZ==$.+1777
+
+.LOP ANDCM ZZ 1777
+
+ZZ1==.LVAL1
+
+LOC ZZ1
+
+OFFSET OFFS
+
+MRKPDL==.-1
+
+ENDGC:
+
+OFFSET 0
+
+ZZ2==ENDGC-AGCLD
+
+.LOP <ASH @> ZZ2 <,-10.>
+SLENGC==.LVAL1
+.LOP <ASH @> SLENGC <10.>
+RSLENG==.LVAL1
+LOC GCST
+
+.LPUR=$.
+
+END
--- /dev/null
+TITLE AMSGC MUDDLE MARK SWEEP GARBAGE COLLECTOR
+
+RELOCATABLE
+
+.GLOBAL RCL,RCLV,IAMSGC,MAXLEN,REALGC,RGCLEN,GCFLG,SQUPNT,GCMONF,MSGTYP,GCCAUS
+.GLOBAL GCCALL,PVSTOR,DSTORE,TYPVEC,N.CHNS,CHNL1,MAINPR,STOGC,CTIME,GCTIM,IMTYO
+.GLOBAL FNMSGC,SATMSK,NUMSAT,NUMPRI,PURBOT,GCSTOP,GCSBOT,STOSTR,TYPMSK,PDLBUF,ITEM,INDIC
+.GLOBAL VAL,NODPNT,UBIT,ASOLNT,GCHAPN,RBLDM,TOTCNT,MARK2S,MKTBS
+.GLOBAL FRMUNG,BYTDOP,TD.GET,TD.LNT,TD.AGC,ABOTN,SLENGC,LENGC,REALGC,AGCLD,RLENGC
+.GLOBAL RSLENG
+
+GCST=$.
+
+LOC REALGC+RLENGC
+
+OFFS=AGCLD-$.
+OFFSET OFFS
+
+.INSRT MUDDLE >
+
+TYPNT==AB
+F==PVP
+
+
+; THIS IS THE MUDDLE MARK SWEEP GARBAGE COLLECTOR. IT IS MUCH FASTER THAN THE COPYING
+; GARBAGE COLLECTOR BUT DOESN'T COMPACT. IT CONSES FREE THINGS ONTO RCL AND RCLV.
+; THIS GARBAGE COLLECTOR CAN ONLY BE USED IF THE GARBAGE COLLECT IS A FREE STORAGE
+; GARBAGE COLLECT
+
+\f
+; FIRST INITIALIZE VARIABLES
+
+IAMSGC: SETZB M,RCL ; CLEAR OUT LIST RECYCLE AND RSUBR BASE
+ SETZM RCLV ; CLEAR VECTOR RECYCLE
+ SETZM MAXLEN ; CLEAR MAXIMUM LENGTH FOUND TO RECYCLE
+ SETOM GCFLG ; A GC HAS HAPPENED
+ SETZM TOTCNT
+ HLLZS SQUPNT ; CLEAR OUT SQUOZE TABLE
+
+; SET UP MESSAGE PRINTING AND SAVE CAUSE AND CAUSER
+
+ PUSH P,A
+ PUSH P,B
+ PUSH P,C ; SAVE ACS
+ MOVEI B,[ASCIZ /MSGIN / ] ; PRINT GIN IF WINNING
+ SKIPE GCMONF
+ PUSHJ P,MSGTYP
+ HRRZ C,(P) ; GET CAUSE INDICATOR
+ ADDI B,1 ; AOS TO GET REAL CAUS
+ MOVEM B,GCCAUS
+ SKIPN GCMONF
+ 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
+ SKIPN GCMONF ; PRINT IF GCMON IS ON
+ JRST NOMON3
+ MOVE B,MSGGFT(C) ; GET POINTER TO MESSAGE
+ PUSHJ P,MSGTYP
+NOMON3: SUB P,[1,,1]
+ POP P,B ; RESTORE ACS
+ POP P,A
+
+; MOVE ACS INTO THE PVP
+
+ EXCH PVP,PVSTOR+1 ; GET REAL PROCESS VECTOR
+
+ IRP AC,,[0,A,B,C,D,E,TVP,SP,AB,TB,TP,FRM,M,R,P]
+ MOVEM AC,AC!STO+1(PVP)
+ TERMIN
+
+ MOVE 0,PVSTOR+1 ; GET OLD VALUE OF PVP
+ MOVEM 0,PVPSTO+1(PVP) ; SAVE PVP
+ MOVE 0,DSTORE ; SAVE D'S TYPE
+ MOVEM 0,DSTO(PVP)
+ MOVEM PVP,PVSTOR+1
+
+; SET UP TYPNT TO POINT TO TYPE VECTOR
+
+ GETYP E,TYPVEC ; FIRST SEE IF TYPVEC IS A VECTOR
+ CAIE E,TVEC
+ FATAL TYPE VECTOR NOT OF TYPE VECTOR
+ HRRZ TYPNT,TYPVEC+1
+ HRLI TYPNT,B ; TYPNT IS NOW TYPEVECTOR(B)
+
+; NOW SET UP GCPDL AND FENCE POST PDL'S
+
+ MOVEI A,(TB)
+ MOVE D,P ; SAVE P POINTER
+ PUSHJ P,FRMUNG
+ MOVE P,[-2000,,MRKPDL] ; SET UP MARK PDL
+ MOVEI A,(TB) ; FIXUP TOP FRAME
+ SETOM 1(TP) ; FENCEPOST TP
+ SETOM 1(D) ; FENCEPOST P
+
+; NOW SETUP AUTO CHANNEL CLOSE
+
+ MOVEI 0,N.CHNS-1 ; NUMBER OF CHANNELS
+ MOVEI A,CHNL1 ; FIRST CHANNEL SLOT
+CHNCLR: SKIPE 1(A) ; IS IT A CHANNEL
+ SETZM (A) ; CLEAR UP TYPE SLOT
+ ADDI A,2
+ SOJG 0,CHNCLR
+
+; NOW DO MARK AND SWEEP PHASES
+
+ MOVSI D,400000 ; MARK BIT
+ MOVEI B,TPVP ; GET TYPE
+ MOVE A,PVSTOR+1 ; GET VALUE OF CURRENT PROCESS VECTOR
+ PUSHJ P,MARK
+ MOVEI B,TPVP ; GET TYPE OF MAIN PROCESS VECTOR
+ MOVE A,MAINPR
+ PUSHJ P,MARK ; MARK
+ PUSHJ P,CHNFLS ; DO CHANNEL FLUSHING
+ PUSHJ P,CHFIX
+ PUSHJ P,STOGC ; FIX UP FROZEN WORLD
+ PUSHJ P,SWEEP ; SWEEP WORLD
+
+; PRINT GOUT
+
+ MOVEI B,[ASCIZ /MSGOUT /] ; PRINT OUT ENDING MESSAGE IF GCMONING
+ SKIPE GCMONF
+ PUSHJ P,MSGTYP
+
+; RESTORE ACS
+
+ MOVE PVP,PVSTOR+1 ; GET PVP
+ IRP AC,,[0,A,B,C,D,E,TVP,SP,AB,TB,TP,FRM,M,R,P]
+ MOVE AC,AC!STO+1(PVP)
+ TERMIN
+
+ SKIPN DSTORE ; CLEAR OUT TYPE IF NO TYPE THERE
+ SETZM DSTO(PVP)
+ MOVE PVP,PVPSTO+1(PVP)
+
+; PRINT TIME
+
+ PUSH P,A ; SAVE ACS
+ PUSH P,B
+ PUSH P,C
+ PUSH P,D
+ PUSHJ P,CTIME ; GET CURRENT CPU TIME
+ FSBR B,GCTIM ; COMPUTE TIME ELAPSED
+ MOVEM B,GCTIM ; SAVE TIME AWAY
+ SKIPN GCMONF ; PRINT IT OUT?
+ JRST GCCONT
+ PUSHJ P,FIXSEN
+ MOVEI A,15 ; OUTPUT CR/LF
+ PUSHJ P,IMTYO
+ MOVEI A,12
+ PUSHJ P,IMTYO
+GCCONT: POP P,D ; RESTORE ACS
+ POP P,C
+ POP P,B
+ POP P,A
+ SETZM GCFLG
+ SETOM GCHAPN
+ SETOM INTFLG
+ PUSHJ P,RBLDM
+ JRST FNMSGC ; DONE
+
+\f
+; THIS IS THE MARK PHASE
+
+; GENERAL MARK ROUTINE, CALLED TO MARK ALL THINGS
+; /A POINTER TO GOODIE
+; /B TYPE OF GOODIE
+; FOR MARK2, MARK1 /C POINTER TO PAIR NOT NEEDED FOR CALLS DIRECTLY TO MARK
+
+MARK2S:
+MARK2: HLRZ B,(C) ; TYPE
+MARK1: MOVE A,1(C) ; VALUE
+MARK: JUMPE A,CPOPJ ; DONE IF ZERO
+ MOVEI 0,1(A) ; SEE IF PURE
+ CAML 0,PURBOT
+ JRST CPOPJ
+ ANDI B,TYPMSK ; FLUSH MONITORS
+ HRLM C,(P)
+ CAIG B,NUMPRI ; IS A BASIC TYPE
+ JRST @MTYTBS(B) ; TYPE DISPATCH
+ LSH B,1 ; NOW GET PRIMTYPE
+ HRRZ B,@TYPNT ; GET PRIMTYPE
+ ANDI B,SATMSK ; FLUSH DOWN TO SAT
+ CAIG B,NUMSAT ; SKIP IF TEMPLATE DATA
+ JRST @MSATBS(B) ; JUMP OFF SAT TABLE
+ JRST TD.MK
+
+GCRET: HLRZ C,(P) ; GET SAVED C
+CPOPJ: POPJ P,
+
+; TYPE DISPATCH TABLE
+MTYTBS:
+
+OFFSET 0
+
+DUM1:
+
+IRP XX,,[[TLOSE,GCRET],[TFIX,GCRET],[TFLOAT,GCRET],[TCHRS,GCRET]
+[TENTRY,GCRET],[TSUBR,GCRET],[TFSUBR,GCRET],[TILLEG,GCRET],[TUNBOU,GCRET]
+[TBIND,GCRET],[TTIME,GCRET],[TLIST,PAIRMK],[TFORM,PAIRMK],[TSEG,PAIRMK]
+[TEXPR,PAIRMK],[TFUNAR,PAIRMK],[TLOCL,PAIRMK],[TFALSE,PAIRMK],[TDEFER,DEFQMK]
+[TUVEC,UVMK],[TOBLS,UVMK],[TVEC,VECMK],[TCHAN,VECMK] ,[TLOCV,VECMK]
+[TTVP,VECMK],[TBVL,VECMK],[TTAG,VECMK],[TPVP,VECMK],[TLOCI,TPMK],[TTP,TPMK]
+[TSP,TPMK],[TMACRO,PAIRMK],[TPDL,PMK],[TARGS,ARGMK],[TAB,ABMK]
+[TTB,TBMK],[TFRAME,FRMK],[TCHSTR,BYTMK],[TATOM,ATOMK],[TLOCD,LOCMK],[TBYTE,BYTMK]
+[TENV,FRMK],[TACT,FRMK],[TASOC,ASMK],[TLOCU,UVMK],[TLOCS,BYTMK],[TLOCA,ARGMK]
+[TCBLK,GCRET],[TTMPLT,TD.MK],[TLOCT,TD.MK],[TLOCR,GCRET],[TINFO,GCRET]
+[TRDTB,GCRDMK],[TWORD,GCRET],[TRSUBR,VECMK],[TCODE,UVMK],[TSATC,GCRET]
+[TBITS,GCRET],[TSTORA,UVMK],[TPICTU,UVMK],[TSKIP,TPMK],[TLINK,ATOMK]
+[TDECL,PAIRMK],[TENTER,VECMK],[THAND,VECMK],[TINTH,VECMK],[TDISMI,ATOMK]
+[TDCLI,PAIRMK],[TPCODE,GCRET],[TTYPEW,GCRET],[TTYPEC,GCRET]
+[TGATOM,GATOMK],[TREADA,FRMK],[TUBIND,GCRET],[TUNWIN,TBMK],[TLOCB,BYTMK]
+[TDEFQ,DEFQMK],[TSPLIC,PAIRMK],[TLOCN,ASMK],[TOFFS,OFFSMK]]
+ IRP A,B,[XX]
+ LOC DUM1+A
+ SETZ B
+ .ISTOP
+ TERMIN
+TERMIN
+
+LOC DUM1+NUMPRI+1
+
+OFFSET OFFS
+
+; SAT DISPATCH TABLE
+
+MSATBS:
+
+OFFSET 0
+
+DISTB2 DUM2,GCRET,[[S2WORD,PAIRMK],[S2DEFR,DEFMK],[SNWORD,UVMK],[STBASE,TBMK]
+[STPSTK,TPMK],[SARGS,<SETZ ARGMK>],[S2NWORD,VECMK],[SPSTK,TPMK],[SSTORE,UVMK]
+[SFRAME,<SETZ FRMK>],[SBYTE,<SETZ BYTMK>],[SATOM,ATOMK],[SPVP,VECMK],[SGATOM,GATOMK]
+[SLOCID,<SETZ LOCMK>],[SCHSTR,<SETZ BYTMK>],[SASOC,ASMK],[SLOCL,PAIRMK],[SABASE,ABMK]
+[SLOCA,<SETZ ARGMK>],[SLOCV,VECMK],[SLOCU,UVMK],[SLOCS,<SETZ BYTMK>],[SLOCN,ASMK]
+[SRDTB,GCRDMK],[SLOCB,<SETZ BYTMK>],[SDEFQ,DEFQMK],[SOFFS,OFFSMK]]
+
+OFFSET OFFS
+
+\f
+; ROUTINE TO MARK PAIRS
+
+PAIRMK: MOVEI C,(A)
+PAIRM1: CAMG C,GCSTOP ; SEE IF IN RANGE
+ CAIGE C,STOSTR
+ JRST BADPTR ; FATAL ERROR
+ HLRE B,(C) ; SKIP IF NOT MARKED
+ JUMPL B,GCRET
+ IORM D,(C) ; MARK IT
+ PUSHJ P,MARK1 ; MARK THE ITEM
+ HRRZ C,(C) ; GET NEXT ELEMENT OF LIST
+ JUMPE C,GCRET
+ CAML C,PURBOT
+ JRST GCRET
+ JRST PAIRM1
+
+; ROUTINE TO MARK DEFERS
+
+DEFMK: HLRE B,(A)
+ JUMPL B,GCRET
+ MOVEI C,(A)
+ IORM D,(C)
+ PUSHJ P,MARK1
+ JRST GCRET
+
+; ROUTINE TO MARK POSSIBLE DEFERS DEF?
+
+DEFQMK: GETYP B,(A) ; GET THE TYPE OF THE OBJECT
+ LSH B,1 ; COMPUTE THE SAT
+ HRRZ B,@TYPNT
+ ANDI B,SATMSK
+ SKIPL MKTBS(B) ; SKIP IF NOT DEFERED
+ JRST PAIRMK
+ JRST DEFMK ; GO TO DEFMK
+
+\f
+; ROUTINE TO MARK VECTORS
+
+VECMK: HLRE B,A ; GET LENGTH
+ SUB A,B
+ MOVEI C,1(A) ; POINT TO SECOND DOPE WORD
+ CAIL C,STOSTR ; CHECK FOR IN RANGE
+ CAMLE C,GCSTOP
+ JRST BADPTR
+ HLRE B,(C)
+ JUMPL B,GCRET
+ IORM D,(C) ; MARK IT
+ SUBI C,-1(B) ; GET TO BEGINNING
+VECMK1: HLRE B,(C) ; GET TYPE AND SKIP IF NOT DOPE WORD
+ JUMPL B,GCRET ; DONE
+ PUSHJ P,MARK1 ; MARK IT
+ ADDI C,2 ; NEXT ELEMENT
+ JRST VECMK1
+
+; ROUTINE TO MARK UVECTORS
+
+UVMK: HLRE B,A ; GET LENGTH
+ SUB A,B ; A POINTS TO FIRST DOPE WORD
+ MOVEI C,1(A) ; C POINTS TO SECOND DOPE WORD
+ CAIL C,STOSTR ; CHECK FOR IN RANGE
+ CAMLE C,GCSTOP
+ JRST BADPTR
+ HLRE F,(C) ; GET LENGTH
+ JUMPL F,GCRET
+ IORM D,(C) ; MARK IT
+ GETYP B,-1(C) ; GET TYPE
+ MOVEI E,(B) ; COPY TYPE FOR SAT COMPUTATION
+ LSH B,1
+ HRRZ B,@TYPNT ; GET SAT
+ ANDI B,SATMSK
+ MOVEI B,@MSATBS(B) ; GET JUMP LOCATION
+ CAIN B,GCRET
+ JRST GCRET
+ SUBI C,(F) ; POINT TO BEGINNING OF UVECTOR
+ SUBI F,2
+ JUMPE F,GCRET
+ PUSH P,F ; SAVE LENGTH
+ PUSH P,E
+UNLOOP: MOVE B,(P)
+ MOVE A,1(C) ; GET VALUE POINTER
+ PUSHJ P,MARK
+ SOSE -1(P) ; SKIP IF NON-ZERO
+ AOJA C,UNLOOP ; GO BACK AGAIN
+ SUB P,[2,,2] ; CLEAN OFF STACK
+ JRST GCRET
+
+; ROUTINE TO INDICATE A BAD POINTER
+
+BADPTR: FATAL POINTER POINTS OUT OF GARBAGE COLLECTED SPACE
+ JRST GCRET
+
+\f
+; ROUTINE TO MARK A TPSTACK
+
+TPMK: HLRE B,A ; GET LENGTH
+ SUB A,B ; A POINTS TO FIRST DOPE WORD
+ MOVEI C,PDLBUF+1(A) ; C POINTS TO SECOND DOPE WORD
+ CAIL C,STOSTR ; CHECK FOR IN RANGE
+ CAMLE C,GCSTOP
+ JRST BADPTR
+ HLRE A,(C)
+ JUMPL A,GCRET
+ IORM D,(C) ; MARK IT
+ SUBI C,-1(A) ; GO TO BEGINNING
+
+TPLP: HLRE B,(C) ; GET TYPE AND MARKING
+ JUMPL B,GCRET ; EXIT ON FENCE-POST
+ ANDI B,TYPMSK ; FLUSH MONITORS
+ CAIE B,TCBLK ; CHECK FOR FRAME
+ CAIN B,TENTRY
+ JRST MFRAME ; MARK THE FRAME
+ CAIE B,TUBIND ; BINDING BLOCK
+ CAIN B,TBIND
+ JRST MBIND
+ PUSHJ P,MARK1 ; NOTHING SPECIAL SO MARK IT
+ ADDI C,2 ; POINT TO NEXT OBJECT
+ JRST TPLP ; MARK IT
+
+; MARK A FRAME ON THE STACK, [I.E. ITS FSAV AND PSAV SLOTS]
+
+MFRAME: HRROI C,FRAMLN+FSAV-1(C) ; POINT TO FUNCTION
+ HRRZ A,1(C) ; GET POINTER
+ CAIL A,STOSTR ; SEE IF IN GC SPACE
+ CAMLE A,GCSTOP
+ JRST MFRAM1 ; SKIP OVER IT, NOT IN GC-SPACE
+ HRL A,(A) ; GET LENGTH
+ MOVEI B,TVEC ; TYPE IS VECTOR [RSUBR OR RSUBR-ENTRY]
+ PUSHJ P,MARK
+MFRAM1: MOVE A,PSAV-FSAV+1(C) ; MARK THE PSTACK
+ MOVEI B,TPDL
+ PUSHJ P,MARK
+ HRROI C,-FSAV+1(C) ; POINT PAST FRAME
+ JRST TPLP ; GO BACK TO START OF LOOP
+
+; MARK A BINDING ON THE STACK [I.E. THE ATOM, VALUE, DECL, AND PREVIOUS BINDING]
+
+MBIND: MOVEI B,TATOM ; START BY MARKING THE ATOM
+ PUSHJ P,MARK1 ; MARK IT
+ ADDI C,2 ; POINT TO VALUE SLOT
+ PUSHJ P,MARK2 ; MARK THE VALUE
+ ADDI C,2 ; POINT TO DECL AND PREV BINDING
+ MOVEI B,TLIST ; MARK DECL
+ HLRZ A,(C)
+ PUSHJ P,MARK
+ SKIPL A,1(C) ; SKIP IF PREVIOUS BINDING
+ JRST NOTLCI
+ MOVEI B,TLOCI ; GET TYPE
+ PUSHJ P,MARK
+NOTLCI: ADDI C,2 ; POINT PAST BINDING
+ JRST TPLP
+
+
+PMK: HLRE B,A ; GET LENGTH
+ SUB A,B ; A POINTS TO FIRST DOPE WORD
+ MOVEI C,PDLBUF+1(A) ; C POINTS TO SECOND DOPE WORD
+ CAIL C,STOSTR ; CHECK FOR IN RANGE
+ CAMLE C,GCSTOP
+ JRST BADPTR
+ IORM D,(C) ; MARK IT
+ JRST GCRET
+\f
+; ROUTINE TO MARK TB POINTER
+
+TBMK: HRRZS A ; CHECK FOR NIL POINTER
+ SKIPN A
+ JRST GCRET
+ MOVE A,TPSAV(A) ; GET A TP POINTER
+ MOVEI B,TTP ; TYPE WORD
+ PUSHJ P,MARK
+ JRST GCRET
+
+; ROUTINE TO MARK AB POINTERS
+
+ABMK: HLRE B,A ; GET TO FRAME
+ SUB A,B
+ MOVE A,FRAMLN+TPSAV(A) ; GET A TP POINTER
+ MOVEI B,TTP ; TYPE WORD
+ PUSHJ P,MARK
+ JRST GCRET
+
+; ROUTINE TO MARK FRAME POINTERS
+
+FRMK: HRLZ B,A ; GET THE TIME
+ HLRZ F,OTBSAV(A) ; GET TIME FROM FRAME
+ CAIE B,(F) ; SKIP IF TIMES AGREE
+ JRST GCRET ; IGNORE POINTER IF THEY DONT
+ HRRZ A,(C) ; GET POINTER TO PROCESS
+ SUBI A,1 ; FUDGE FOR VECTOR MARKING
+ MOVEI B,TPVP ; TYPE WORD
+ PUSHJ P,MARK
+ HRRZ A,1(C) ; GET POINTER TO FRAME
+ JRST TBMK ; MARK IT
+
+; ROUTINE TO MARK ARGUMENT BLOCKS [TUPLES]
+
+ARGMK: HLRE B,A ; GET LENGTH
+ SUB A,B ; POINT PAST BLOCK
+ CAIL A,STOSTR
+ CAMLE A,GCSTOP ; SEE IF IN GCSPACE
+ JRST GCRET
+ HRLZ 0,(A) ; GET TYPE
+ ANDI 0,TYPMSK ; FLUSH MONITORS
+ CAIE 0,TENTRY
+ CAIN 0,TCBLK
+ JRST ARGMK1 ; AT FRAME
+ CAIE 0,TINFO ; AT FRAME
+ JRST GCRET ; NOT A LEGAL TYPE GO AWAY
+ HRRZ A,1(A) ; POINTING TO FRAME
+ HRL A,(C) ; GET TIME
+ JRST TBMK
+ARGMK1: HRRI A,FRAMLN(A) ; MAKE POINTER
+ HRL A,(C) ; GET TIME
+ JRST TBMK
+\f
+
+; ROUTINE TO MARK GLOBAL SLOTS
+
+GATOMK: HRRZ B,(C) ; GET POSSIBLE GDECL
+ JUMPE B,ATOMK ; NONE GO TO MARK ATOM
+ CAIN B,-1 ; SKIP IF NOT MANIFEST
+ JRST ATOMK
+ PUSH P,A ; I DOUBT THIS IS RIGHT, BUT IT WORKED ONCE--TAA
+ MOVEI C,(A)
+ MOVEI A,(B)
+ MOVEI B,TLIST ; TYPE WORD LIST
+ PUSHJ P,MARK ; MARK IT
+ POP P,A
+ JRST ATOMK5
+
+ATOMK:
+ATOMK5: HLRE B,A
+ SUB A,B ; A POINTS TO DOPE WORD
+ SKIPGE 1(A) ; SKIP IF NOT MARKED
+ JRST GCRET ; EXIT IF MARKED
+ HLRZ B,1(A)
+ SUBI B,3
+ HRLI B,1(B)
+ MOVEI C,-1(A)
+ SUB C,B ; IN CASE WAS DW
+ IORM D,1(A) ; MARK IT
+ HRRZ A,2(C) ; MARK OBLIST
+ CAMG A,VECBOT
+ JRST NOOBL ; NO IMPURE OBLIST
+ HRLI A,-1
+ MOVEI B,TOBLS ; MARK THE OBLIST
+ PUSHJ P,MARK
+NOOBL: HLRZ A,2(C) ; GET NEXT ATOM
+ MOVEI B,TATOM
+ PUSHJ P,MARK
+ HLRZ B,(C) ; GET VALUE SLOT
+ TRZ B,400000 ; TURN OFF MARK BIT
+ SKIPE B ; SEE IF 0
+ CAIN B,TUNBOUN ; SEE IF UNBOUND
+ JRST GCRET
+ HRRZ 0,(C) ; SEE IF VECTOR OR TP POINTER
+ MOVEI B,TVEC ; ASSUME VECTOR
+ SKIPE 0 ; SKIP IF VECTOR
+ MOVEI B,TTP ; IT IS A TP POINTER
+ PUSHJ P,MARK1 ; GO MARK IT
+ JRST GCRET
+\f
+; ROUTINE TO MARK BYTE AND STRING POINTERS
+
+BYTMK: PUSHJ P,BYTDOP ; GET TO DOPE WORD INTO A
+ HRLZ F,-1(A) ; SEE IF SPECIAL ATOM [SPNAME]
+ ANDI F,SATMSK ; GET SAT
+ CAIN F,SATOM
+ JRST ATMSET ; IT IS AN ATOM
+ IORM D,(A) ; MARK IT
+ JRST GCRET
+
+ATMSET: HLRZ B,(A) ; GET LENGTH
+ TRZ B,400000 ; TURN OFF POSSIBLE MARK BIT
+ MOVNI B,-2(B) ; GENERATE AOBJN POINTER
+ ADDI A,-1(B) ; GET BACK TO BEGINNING
+ HRLI A,(B) ; PUT IN LEFT HALF
+ MOVEI B,TATOM ; MARK AS AN ATOM
+ PUSHJ P,MARK ; GO MARK
+ JRST GCRET
+
+; MARK LOCID GOODIES
+
+LOCMK: HRRZ B,(C) ; CHECK FOR TIME
+ JUMPE B,LOCMK1 ; SKIP LEGAL CHECK FOR GLOBAL
+ HRRZ 0,2(A) ; GET OTHER TIME
+ CAIE 0,(B) ; SAME?
+ JRST GCRET
+ MOVEI B,TTP
+ PUSHJ P,MARK1
+ JRST GCRET
+LOCMK1: MOVEI B,TVEC ; GLOBAL
+ PUSHJ P,MARK1 ; MARK VALUE
+ JRST GCRET
+
+; MARK ASSOCIATION BLOCK
+
+ASMK: MOVEI C,(A) ; SAVE POINTER TO BEGINNING OF ASSOCATION
+ ADDI A,ASOLNT ; POINT TO DOPE WORD
+ HLRE B,1(A) ; GET SECOND D.W.
+ JUMPL B,GCRET ; MARKED SO LEAVE
+ IORM D,1(A) ; MARK ASSOCATION
+ PUSHJ P,MARK2 ; MARK ITEM
+ MOVEI C,INDIC(C)
+ PUSHJ P,MARK2
+ MOVEI C,VAL-INDIC(C)
+ PUSHJ P,MARK2
+ HRRZ A,NODPNT-VAL(C) ; GET NEXT IN CHAIN
+ JUMPN A,ASMK ; GO MARK IT
+ JRST GCRET
+\f
+; MARK OFFSETS
+
+OFFSMK: PUSH P,$TLIST
+ HLRZ 0,1(C) ; PICK UP LIST POINTER
+ PUSH P,0
+ MOVEI C,-1(P)
+ PUSHJ P,MARK2 ; MARK THE LIST
+ SUB P,[2,,2]
+ JRST GCRET ; AND RETURN
+\f
+; HERE TO MARK TEMPLATE DATA STRUCTURES
+
+TD.MK: 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
+ SKIPL 1(A) ; SEE IF MARKED
+ JRST GCRET ; IF MARKED LEAVE
+ IORM D,1(A)
+
+ 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,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,-3(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,-4(P) ; SAVE ELMENT #
+ SKIPN B,-3(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,-3(P) ; PLUS BASIC
+ ADDI A,1 ; AND FUDGE
+ MOVEM A,-4(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
+ EXCH A,B ; REARRANGE
+ HLRZS B
+ MOVSI D,400000 ; RESET FOR MARK
+ PUSHJ P,MARK ; AND MARK THIS GUY (RET FIXED POINTER IN A)
+ MOVE C,-2(P) ; RESTORE POINTER IN CASE MUNGED
+ JRST TD.MR2
+
+TD.MR1: SUB P,[5,,5]
+ JRST GCRET
+
+USRAGC: XCT (E) ; MARK THE TEMPLATE
+ JRST GCRET
+
+\f
+; ROUTINE TO MARK THE GC-READ TABLE. MARKS THE ATOMS AT THE DOPE WORDS
+; AND UPDATES PTR TO THE TABLE.
+
+GCRDMK: MOVEI C,(A) ; SAVE POINTER TO GCREAD TABLE
+ HLRE B,A ; GET TO DOPE WORD
+ SUB A,B
+ SKIPGE 1(A) ; SKIP IF NOT MARKED
+ JRST GCRET
+ SUBI A,2
+ MOVE B,ABOTN ; GET TOP OF ATOM TABLE
+ ADD B,0 ; GET BOTTOM OF ATOM TABLE
+GCRD1: CAMG A,B ; DON'T SKIP IF DONE
+ JRST GCRET
+ 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
+ POP P,A
+ POP P,B
+ JRST GCRD1
+GCRD3: SUBI A,(C) ; TO NEXT ATOM
+ JRST GCRD1
+
+
+; ROUTINE TO FIX UP CHANNELS
+
+CHNFLS: MOVEI 0,N.CHNS-1
+ MOVEI A,,CHNL1 ; SET UP POINTER
+CHFL1: SKIPN B,1(A) ; GET POINTER TO CHANNEL
+ JRST CHFL2 ; NO CHANNEL LOOP TO NEXT
+ HLRE C,B ; POINT TO DOPE WORD OF CHANNEL
+ SUBI B,(C)
+ MOVEI F,TCHAN
+ HRLM F,(A) ; PUT TYPE BACK
+ SKIPL 1(B) ; SKIP IF MARKED
+ JRST FLSCH ; FLUSH THE CHANNEL
+ MOVEI F,1 ; MARK THE CHANNEL AS GOOD
+ HRRM F,(A) ; SMASH IT IN
+CHFL2: ADDI A,2
+ SOJG 0,CHFL1
+ POPJ P, ; EXIT
+FLSCH: HLLOS F,(A) ; -1 INTO SLOT INDICATES LOSSAGE
+ JRST CHFL2
+
+
+; THIS ROUTINE MARKS ALL THE CHANNELS
+
+CHFIX: MOVEI 0,N.CHNS-1
+ MOVEI A,CHNL1 ; SLOTS
+
+DHNFL2: SKIPN 1(A)
+ JRST DHNFL1
+ PUSH P,0 ; SAVE 0
+ PUSH P,A ; SAVE A
+ MOVEI C,(A)
+ MOVE A,1(A)
+ MOVEI B,TCHAN
+ PUSHJ P,MARK
+ POP P,A ; RESTORE A
+ POP P,0 ; RESTORE
+DHNFL1: ADDI A,2
+ SOJG 0,DHNFL2
+ 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
+ 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
+; ROUTINE TO SEEP THROUGH GC SPACE LOOKING FOR FREE SLOTS. PAIRS ARE PLACED ON THE
+; RCL LIST, VECTORS ON THE RCLV LIST.
+
+SWEEP: MOVE C,GCSTOP ; GET TOP OF GC SPACE
+ SUBI C,1 ; POINT TO FIRST OBJECT
+ SETZB E,F ; CURRENT SLOT AND CURRENT LENGTH
+LSWEEP: CAMG C,GCSBOT ; SKIP IF ABOVE GCSBOT
+ JRST ESWEEP ; DONE
+ HLRE A,-1(C) ; SEE IF LIST OR VECTOR
+ TRNE A,UBIT ; SKIP IF LIST
+ JRST VSWEEP ; IT IS A VECTOR
+ JUMPGE A,LSWP1 ; JUMP IF NOT MARKED
+ ANDCAM D,-1(C) ; TURN OFF MARK BIT
+ PUSHJ P,SWCONS ; CONS ON CURRENT OBJECT
+ SUBI C,2 ; SKIP OVER LIST
+ JRST LSWEEP
+LSWP1: ADDI F,2 ; ADD TO CURRENT OBJECT COUNT
+ JUMPN E,LSWP2 ; JUMP IF CURRENT OBJECT EXISTS
+ MOVEI E,(C) ; GET ADDRESS
+LSWP2: SUBI C,2
+ JRST LSWEEP
+
+VSWEEP: HLRE A,(C) ; GET LENGTH
+ JUMPGE A,VSWP1 ; SKIP IF MARKED
+ ANDCAM D,(C) ; TURN OFF MARK BIT
+ PUSHJ P,SWCONS
+ ANDI A,377777 ; GET LENGTH PART
+ SUBI C,(A) ; GO PAST VECTOR
+ JRST LSWEEP
+VSWP1: ADDI F,(A) ; ADD LENGTH
+ JUMPN E,VSWP2
+ MOVEI E,(C) ; GET NEW OBJECT LOCATION
+VSWP2: SUBI C,(A) ; GO BACK PAST VECTOR
+ JRST LSWEEP
+
+ESWEEP:
+SWCONS: JUMPE E,CPOPJ
+ ADDM F,TOTCNT ; HACK TOTCNT
+ CAMLE F,MAXLEN ; SEE IF NEW MAXIMUM
+ MOVEM F,MAXLEN
+ CAIGE F,2 ; MAKE SURE AT LEAST TWO LONG
+ FATAL SWEEP FAILURE
+ CAIN F,2
+ JRST LCONS
+ SETZM (E)
+ MOVEI 0,(E)
+ SUBI 0,-1(F)
+ SETZM @0
+ HRLS 0
+ ADDI 0,1
+ BLT 0,-2(E)
+ HRRZ 0,RCLV ; GET VECTOR RECYCLE
+ HRRM 0,(E) ; SMASH INTO LINKING SLOT
+ HRRZM E,RCLV ; NEW RECYCLE SLOT
+ HRLM F,(E)
+ MOVSI F,UBIT
+ MOVEM F,-1(E)
+ SETZB E,F
+ POPJ P, ; DONE
+LCONS: SETZM (E)
+ SUBI E,1
+ HRRZ 0,RCL ; GET RECYCLE LIST
+ HRRZM 0,(E) ; SMASH IN
+ HRRZM E,RCL
+ SETZB E,F
+ POPJ P,
+
+\f
+; 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
+
+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 /]
+
+CONSTANTS
+
+HERE
+
+CONSTANTS
+
+OFFSET 0
+
+ZZ==$.+1777
+
+.LOP ANDCM ZZ 1777
+
+ZZ1==.LVAL1
+
+LOC ZZ1
+
+OFFSET OFFS
+
+MRKPDL==.-1
+
+ENDGC:
+
+OFFSET 0
+
+ZZ2==ENDGC-AGCLD
+
+.LOP <ASH @> ZZ2 <,-10.>
+SLENGC==.LVAL1
+.LOP <ASH @> SLENGC <10.>
+RSLENG==.LVAL1
+LOC GCST
+
+.LPUR=$.
+
+END
--- /dev/null
+TITLE AMSGC MUDDLE MARK SWEEP GARBAGE COLLECTOR
+
+RELOCATABLE
+
+.GLOBAL RCL,RCLV,IAMSGC,MAXLEN,REALGC,RGCLEN,GCFLG,SQUPNT,GCMONF,MSGTYP,GCCAUS
+.GLOBAL GCCALL,PVSTOR,DSTORE,TYPVEC,N.CHNS,CHNL1,MAINPR,STOGC,CTIME,GCTIM,IMTYO
+.GLOBAL FNMSGC,SATMSK,NUMSAT,NUMPRI,PURBOT,GCSTOP,GCSBOT,STOSTR,TYPMSK,PDLBUF,ITEM,INDIC
+.GLOBAL VAL,NODPNT,UBIT,ASOLNT,GCHAPN,RBLDM,TOTCNT,MARK2S,MKTBS
+.GLOBAL FRMUNG,BYTDOP,TD.GET,TD.LNT,TD.AGC,ABOTN,SLENGC,LENGC,REALGC,AGCLD,RLENGC
+.GLOBAL RSLENG
+
+GCST=$.
+
+LOC REALGC+RLENGC
+
+OFFS=AGCLD-$.
+OFFSET OFFS
+
+.INSRT MUDDLE >
+
+TYPNT==AB
+F==PVP
+
+
+; THIS IS THE MUDDLE MARK SWEEP GARBAGE COLLECTOR. IT IS MUCH FASTER THAN THE COPYING
+; GARBAGE COLLECTOR BUT DOESN'T COMPACT. IT CONSES FREE THINGS ONTO RCL AND RCLV.
+; THIS GARBAGE COLLECTOR CAN ONLY BE USED IF THE GARBAGE COLLECT IS A FREE STORAGE
+; GARBAGE COLLECT
+
+\f
+; FIRST INITIALIZE VARIABLES
+
+IAMSGC: SETZB M,RCL ; CLEAR OUT LIST RECYCLE AND RSUBR BASE
+ SETZM RCLV ; CLEAR VECTOR RECYCLE
+ SETZM MAXLEN ; CLEAR MAXIMUM LENGTH FOUND TO RECYCLE
+ SETOM GCFLG ; A GC HAS HAPPENED
+ SETZM TOTCNT
+ HLLZS SQUPNT ; CLEAR OUT SQUOZE TABLE
+
+; SET UP MESSAGE PRINTING AND SAVE CAUSE AND CAUSER
+
+ PUSH P,A
+ PUSH P,B
+ PUSH P,C ; SAVE ACS
+ MOVEI B,[ASCIZ /MSGIN / ] ; PRINT GIN IF WINNING
+ SKIPE GCMONF
+ PUSHJ P,MSGTYP
+ HRRZ C,(P) ; GET CAUSE INDICATOR
+ ADDI B,1 ; AOS TO GET REAL CAUS
+ MOVEM B,GCCAUS
+ SKIPN GCMONF
+ 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
+ SKIPN GCMONF ; PRINT IF GCMON IS ON
+ JRST NOMON3
+ MOVE B,MSGGFT(C) ; GET POINTER TO MESSAGE
+ PUSHJ P,MSGTYP
+NOMON3: SUB P,[1,,1]
+ POP P,B ; RESTORE ACS
+ POP P,A
+
+; MOVE ACS INTO THE PVP
+
+ EXCH PVP,PVSTOR+1 ; GET REAL PROCESS VECTOR
+
+ IRP AC,,[0,A,B,C,D,E,TVP,SP,AB,TB,TP,FRM,M,R,P]
+ MOVEM AC,AC!STO+1(PVP)
+ TERMIN
+
+ MOVE 0,PVSTOR+1 ; GET OLD VALUE OF PVP
+ MOVEM 0,PVPSTO+1(PVP) ; SAVE PVP
+ MOVE 0,DSTORE ; SAVE D'S TYPE
+ MOVEM 0,DSTO(PVP)
+ MOVEM PVP,PVSTOR+1
+
+; SET UP TYPNT TO POINT TO TYPE VECTOR
+
+ GETYP E,TYPVEC ; FIRST SEE IF TYPVEC IS A VECTOR
+ CAIE E,TVEC
+ FATAL TYPE VECTOR NOT OF TYPE VECTOR
+ HRRZ TYPNT,TYPVEC+1
+ HRLI TYPNT,B ; TYPNT IS NOW TYPEVECTOR(B)
+
+; NOW SET UP GCPDL AND FENCE POST PDL'S
+
+ MOVEI A,(TB)
+ MOVE D,P ; SAVE P POINTER
+ PUSHJ P,FRMUNG
+ MOVE P,[-2000,,MRKPDL] ; SET UP MARK PDL
+ MOVEI A,(TB) ; FIXUP TOP FRAME
+ SETOM 1(TP) ; FENCEPOST TP
+ SETOM 1(D) ; FENCEPOST P
+
+; NOW SETUP AUTO CHANNEL CLOSE
+
+ MOVEI 0,N.CHNS-1 ; NUMBER OF CHANNELS
+ MOVEI A,CHNL1 ; FIRST CHANNEL SLOT
+CHNCLR: SKIPE 1(A) ; IS IT A CHANNEL
+ SETZM (A) ; CLEAR UP TYPE SLOT
+ ADDI A,2
+ SOJG 0,CHNCLR
+
+; NOW DO MARK AND SWEEP PHASES
+
+ MOVSI D,400000 ; MARK BIT
+ MOVEI B,TPVP ; GET TYPE
+ MOVE A,PVSTOR+1 ; GET VALUE OF CURRENT PROCESS VECTOR
+ PUSHJ P,MARK
+ MOVEI B,TPVP ; GET TYPE OF MAIN PROCESS VECTOR
+ MOVE A,MAINPR
+ PUSHJ P,MARK ; MARK
+ PUSHJ P,CHNFLS ; DO CHANNEL FLUSHING
+ PUSHJ P,CHFIX
+ PUSHJ P,STOGC ; FIX UP FROZEN WORLD
+ PUSHJ P,SWEEP ; SWEEP WORLD
+
+; PRINT GOUT
+
+ MOVEI B,[ASCIZ /MSGOUT /] ; PRINT OUT ENDING MESSAGE IF GCMONING
+ SKIPE GCMONF
+ PUSHJ P,MSGTYP
+
+; RESTORE ACS
+
+ MOVE PVP,PVSTOR+1 ; GET PVP
+ IRP AC,,[0,A,B,C,D,E,TVP,SP,AB,TB,TP,FRM,M,R,P]
+ MOVE AC,AC!STO+1(PVP)
+ TERMIN
+
+ SKIPN DSTORE ; CLEAR OUT TYPE IF NO TYPE THERE
+ SETZM DSTO(PVP)
+ MOVE PVP,PVPSTO+1(PVP)
+
+; PRINT TIME
+
+ PUSH P,A ; SAVE ACS
+ PUSH P,B
+ PUSH P,C
+ PUSH P,D
+ PUSHJ P,CTIME ; GET CURRENT CPU TIME
+ FSBR B,GCTIM ; COMPUTE TIME ELAPSED
+ MOVEM B,GCTIM ; SAVE TIME AWAY
+ SKIPN GCMONF ; PRINT IT OUT?
+ JRST GCCONT
+ PUSHJ P,FIXSEN
+ MOVEI A,15 ; OUTPUT CR/LF
+ PUSHJ P,IMTYO
+ MOVEI A,12
+ PUSHJ P,IMTYO
+GCCONT: POP P,D ; RESTORE ACS
+ POP P,C
+ POP P,B
+ POP P,A
+ SETZM GCFLG
+ SETOM GCHAPN
+ SETOM INTFLG
+ PUSHJ P,RBLDM
+ JRST FNMSGC ; DONE
+
+\f
+; THIS IS THE MARK PHASE
+
+; GENERAL MARK ROUTINE, CALLED TO MARK ALL THINGS
+; /A POINTER TO GOODIE
+; /B TYPE OF GOODIE
+; FOR MARK2, MARK1 /C POINTER TO PAIR NOT NEEDED FOR CALLS DIRECTLY TO MARK
+
+MARK2S:
+MARK2: HLRZ B,(C) ; TYPE
+MARK1: MOVE A,1(C) ; VALUE
+MARK: JUMPE A,CPOPJ ; DONE IF ZERO
+ MOVEI 0,1(A) ; SEE IF PURE
+ CAML 0,PURBOT
+ JRST CPOPJ
+ ANDI B,TYPMSK ; FLUSH MONITORS
+ HRLM C,(P)
+ CAIG B,NUMPRI ; IS A BASIC TYPE
+ JRST @MTYTBS(B) ; TYPE DISPATCH
+ LSH B,1 ; NOW GET PRIMTYPE
+ HRRZ B,@TYPNT ; GET PRIMTYPE
+ ANDI B,SATMSK ; FLUSH DOWN TO SAT
+ CAIG B,NUMSAT ; SKIP IF TEMPLATE DATA
+ JRST @MSATBS(B) ; JUMP OFF SAT TABLE
+ JRST TD.MK
+
+GCRET: HLRZ C,(P) ; GET SAVED C
+CPOPJ: POPJ P,
+
+; TYPE DISPATCH TABLE
+MTYTBS:
+
+OFFSET 0
+
+DUM1:
+
+IRP XX,,[[TLOSE,GCRET],[TFIX,GCRET],[TFLOAT,GCRET],[TCHRS,GCRET]
+[TENTRY,GCRET],[TSUBR,GCRET],[TFSUBR,GCRET],[TILLEG,GCRET],[TUNBOU,GCRET]
+[TBIND,GCRET],[TTIME,GCRET],[TLIST,PAIRMK],[TFORM,PAIRMK],[TSEG,PAIRMK]
+[TEXPR,PAIRMK],[TFUNAR,PAIRMK],[TLOCL,PAIRMK],[TFALSE,PAIRMK],[TDEFER,DEFQMK]
+[TUVEC,UVMK],[TOBLS,UVMK],[TVEC,VECMK],[TCHAN,VECMK] ,[TLOCV,VECMK]
+[TTVP,VECMK],[TBVL,VECMK],[TTAG,VECMK],[TPVP,VECMK],[TLOCI,TPMK],[TTP,TPMK]
+[TSP,TPMK],[TMACRO,PAIRMK],[TPDL,PMK],[TARGS,ARGMK],[TAB,ABMK]
+[TTB,TBMK],[TFRAME,FRMK],[TCHSTR,BYTMK],[TATOM,ATOMK],[TLOCD,LOCMK],[TBYTE,BYTMK]
+[TENV,FRMK],[TACT,FRMK],[TASOC,ASMK],[TLOCU,UVMK],[TLOCS,BYTMK],[TLOCA,ARGMK]
+[TCBLK,GCRET],[TTMPLT,TD.MK],[TLOCT,TD.MK],[TLOCR,GCRET],[TINFO,GCRET]
+[TRDTB,GCRDMK],[TWORD,GCRET],[TRSUBR,VECMK],[TCODE,UVMK],[TSATC,GCRET]
+[TBITS,GCRET],[TSTORA,UVMK],[TPICTU,UVMK],[TSKIP,TPMK],[TLINK,ATOMK]
+[TDECL,PAIRMK],[TENTER,VECMK],[THAND,VECMK],[TINTH,VECMK],[TDISMI,ATOMK]
+[TDCLI,PAIRMK],[TPCODE,GCRET],[TTYPEW,GCRET],[TTYPEC,GCRET]
+[TGATOM,GATOMK],[TREADA,FRMK],[TUBIND,GCRET],[TUNWIN,TBMK],[TLOCB,BYTMK]
+[TDEFQ,DEFQMK],[TSPLIC,PAIRMK],[TLOCN,ASMK],[TOFFS,OFFSMK]]
+ IRP A,B,[XX]
+ LOC DUM1+A
+ SETZ B
+ .ISTOP
+ TERMIN
+TERMIN
+
+LOC DUM1+NUMPRI+1
+
+OFFSET OFFS
+
+; SAT DISPATCH TABLE
+
+MSATBS:
+
+OFFSET 0
+
+DISTB2 DUM2,GCRET,[[S2WORD,PAIRMK],[S2DEFR,DEFMK],[SNWORD,UVMK],[STBASE,TBMK]
+[STPSTK,TPMK],[SARGS,<SETZ ARGMK>],[S2NWORD,VECMK],[SPSTK,TPMK],[SSTORE,UVMK]
+[SFRAME,<SETZ FRMK>],[SBYTE,<SETZ BYTMK>],[SATOM,ATOMK],[SPVP,VECMK],[SGATOM,GATOMK]
+[SLOCID,<SETZ LOCMK>],[SCHSTR,<SETZ BYTMK>],[SASOC,ASMK],[SLOCL,PAIRMK],[SABASE,ABMK]
+[SLOCA,<SETZ ARGMK>],[SLOCV,VECMK],[SLOCU,UVMK],[SLOCS,<SETZ BYTMK>],[SLOCN,ASMK]
+[SRDTB,GCRDMK],[SLOCB,<SETZ BYTMK>],[SDEFQ,DEFQMK],[SOFFS,OFFSMK]]
+
+OFFSET OFFS
+
+\f
+; ROUTINE TO MARK PAIRS
+
+PAIRMK: MOVEI C,(A)
+PAIRM1: CAMG C,GCSTOP ; SEE IF IN RANGE
+ CAIGE C,STOSTR
+ JRST BADPTR ; FATAL ERROR
+ HLRE B,(C) ; SKIP IF NOT MARKED
+ JUMPL B,GCRET
+ IORM D,(C) ; MARK IT
+ PUSHJ P,MARK1 ; MARK THE ITEM
+ HRRZ C,(C) ; GET NEXT ELEMENT OF LIST
+ JUMPE C,GCRET
+ CAML C,PURBOT
+ JRST GCRET
+ JRST PAIRM1
+
+; ROUTINE TO MARK DEFERS
+
+DEFMK: HLRE B,(A)
+ JUMPL B,GCRET
+ MOVEI C,(A)
+ IORM D,(C)
+ PUSHJ P,MARK1
+ JRST GCRET
+
+; ROUTINE TO MARK POSSIBLE DEFERS DEF?
+
+DEFQMK: GETYP B,(A) ; GET THE TYPE OF THE OBJECT
+ LSH B,1 ; COMPUTE THE SAT
+ HRRZ B,@TYPNT
+ ANDI B,SATMSK
+ SKIPL MKTBS(B) ; SKIP IF NOT DEFERED
+ JRST PAIRMK
+ JRST DEFMK ; GO TO DEFMK
+
+\f
+; ROUTINE TO MARK VECTORS
+
+VECMK: HLRE B,A ; GET LENGTH
+ SUB A,B
+ MOVEI C,1(A) ; POINT TO SECOND DOPE WORD
+ CAIL C,STOSTR ; CHECK FOR IN RANGE
+ CAMLE C,GCSTOP
+ JRST BADPTR
+ HLRE B,(C)
+ JUMPL B,GCRET
+ IORM D,(C) ; MARK IT
+ SUBI C,-1(B) ; GET TO BEGINNING
+VECMK1: HLRE B,(C) ; GET TYPE AND SKIP IF NOT DOPE WORD
+ JUMPL B,GCRET ; DONE
+ PUSHJ P,MARK1 ; MARK IT
+ ADDI C,2 ; NEXT ELEMENT
+ JRST VECMK1
+
+; ROUTINE TO MARK UVECTORS
+
+UVMK: HLRE B,A ; GET LENGTH
+ SUB A,B ; A POINTS TO FIRST DOPE WORD
+ MOVEI C,1(A) ; C POINTS TO SECOND DOPE WORD
+ CAIL C,STOSTR ; CHECK FOR IN RANGE
+ CAMLE C,GCSTOP
+ JRST BADPTR
+ HLRE F,(C) ; GET LENGTH
+ JUMPL F,GCRET
+ IORM D,(C) ; MARK IT
+ GETYP B,-1(C) ; GET TYPE
+ MOVEI E,(B) ; COPY TYPE FOR SAT COMPUTATION
+ LSH B,1
+ HRRZ B,@TYPNT ; GET SAT
+ ANDI B,SATMSK
+ MOVEI B,@MSATBS(B) ; GET JUMP LOCATION
+ CAIN B,GCRET
+ JRST GCRET
+ SUBI C,(F) ; POINT TO BEGINNING OF UVECTOR
+ SUBI F,2
+ JUMPE F,GCRET
+ PUSH P,F ; SAVE LENGTH
+ PUSH P,E
+UNLOOP: MOVE B,(P)
+ MOVE A,1(C) ; GET VALUE POINTER
+ PUSHJ P,MARK
+ SOSE -1(P) ; SKIP IF NON-ZERO
+ AOJA C,UNLOOP ; GO BACK AGAIN
+ SUB P,[2,,2] ; CLEAN OFF STACK
+ JRST GCRET
+
+; ROUTINE TO INDICATE A BAD POINTER
+
+BADPTR: FATAL POINTER POINTS OUT OF GARBAGE COLLECTED SPACE
+ JRST GCRET
+
+\f
+; ROUTINE TO MARK A TPSTACK
+
+TPMK: HLRE B,A ; GET LENGTH
+ SUB A,B ; A POINTS TO FIRST DOPE WORD
+ MOVEI C,PDLBUF+1(A) ; C POINTS TO SECOND DOPE WORD
+ CAIL C,STOSTR ; CHECK FOR IN RANGE
+ CAMLE C,GCSTOP
+ JRST BADPTR
+ HLRE A,(C)
+ JUMPL A,GCRET
+ IORM D,(C) ; MARK IT
+ SUBI C,-1(A) ; GO TO BEGINNING
+
+TPLP: HLRE B,(C) ; GET TYPE AND MARKING
+ JUMPL B,GCRET ; EXIT ON FENCE-POST
+ ANDI B,TYPMSK ; FLUSH MONITORS
+ CAIE B,TCBLK ; CHECK FOR FRAME
+ CAIN B,TENTRY
+ JRST MFRAME ; MARK THE FRAME
+ CAIE B,TUBIND ; BINDING BLOCK
+ CAIN B,TBIND
+ JRST MBIND
+ PUSHJ P,MARK1 ; NOTHING SPECIAL SO MARK IT
+ ADDI C,2 ; POINT TO NEXT OBJECT
+ JRST TPLP ; MARK IT
+
+; MARK A FRAME ON THE STACK, [I.E. ITS FSAV AND PSAV SLOTS]
+
+MFRAME: HRROI C,FRAMLN+FSAV-1(C) ; POINT TO FUNCTION
+ HRRZ A,1(C) ; GET POINTER
+ CAIL A,STOSTR ; SEE IF IN GC SPACE
+ CAMLE A,GCSTOP
+ JRST MFRAM1 ; SKIP OVER IT, NOT IN GC-SPACE
+ HRL A,(A) ; GET LENGTH
+ MOVEI B,TVEC ; TYPE IS VECTOR [RSUBR OR RSUBR-ENTRY]
+ PUSHJ P,MARK
+MFRAM1: MOVE A,PSAV-FSAV+1(C) ; MARK THE PSTACK
+ MOVEI B,TPDL
+ PUSHJ P,MARK
+ HRROI C,-FSAV+1(C) ; POINT PAST FRAME
+ JRST TPLP ; GO BACK TO START OF LOOP
+
+; MARK A BINDING ON THE STACK [I.E. THE ATOM, VALUE, DECL, AND PREVIOUS BINDING]
+
+MBIND: MOVEI B,TATOM ; START BY MARKING THE ATOM
+ PUSHJ P,MARK1 ; MARK IT
+ ADDI C,2 ; POINT TO VALUE SLOT
+ PUSHJ P,MARK2 ; MARK THE VALUE
+ ADDI C,2 ; POINT TO DECL AND PREV BINDING
+ MOVEI B,TLIST ; MARK DECL
+ HLRZ A,(C)
+ PUSHJ P,MARK
+ SKIPL A,1(C) ; SKIP IF PREVIOUS BINDING
+ JRST NOTLCI
+ MOVEI B,TLOCI ; GET TYPE
+ PUSHJ P,MARK
+NOTLCI: ADDI C,2 ; POINT PAST BINDING
+ JRST TPLP
+
+
+PMK: HLRE B,A ; GET LENGTH
+ SUB A,B ; A POINTS TO FIRST DOPE WORD
+ MOVEI C,PDLBUF+1(A) ; C POINTS TO SECOND DOPE WORD
+ CAIL C,STOSTR ; CHECK FOR IN RANGE
+ CAMLE C,GCSTOP
+ JRST BADPTR
+ IORM D,(C) ; MARK IT
+ JRST GCRET
+\f
+; ROUTINE TO MARK TB POINTER
+
+TBMK: HRRZS A ; CHECK FOR NIL POINTER
+ SKIPN A
+ JRST GCRET
+ MOVE A,TPSAV(A) ; GET A TP POINTER
+ MOVEI B,TTP ; TYPE WORD
+ PUSHJ P,MARK
+ JRST GCRET
+
+; ROUTINE TO MARK AB POINTERS
+
+ABMK: HLRE B,A ; GET TO FRAME
+ SUB A,B
+ MOVE A,FRAMLN+TPSAV(A) ; GET A TP POINTER
+ MOVEI B,TTP ; TYPE WORD
+ PUSHJ P,MARK
+ JRST GCRET
+
+; ROUTINE TO MARK FRAME POINTERS
+
+FRMK: HRLZ B,A ; GET THE TIME
+ HLRZ F,OTBSAV(A) ; GET TIME FROM FRAME
+ CAIE B,(F) ; SKIP IF TIMES AGREE
+ JRST GCRET ; IGNORE POINTER IF THEY DONT
+ HRRZ A,(C) ; GET POINTER TO PROCESS
+ SUBI A,1 ; FUDGE FOR VECTOR MARKING
+ MOVEI B,TPVP ; TYPE WORD
+ PUSHJ P,MARK
+ HRRZ A,1(C) ; GET POINTER TO FRAME
+ JRST TBMK ; MARK IT
+
+; ROUTINE TO MARK ARGUMENT BLOCKS [TUPLES]
+
+ARGMK: HLRE B,A ; GET LENGTH
+ SUB A,B ; POINT PAST BLOCK
+ CAIL A,STOSTR
+ CAMLE A,GCSTOP ; SEE IF IN GCSPACE
+ JRST GCRET
+ HRLZ 0,(A) ; GET TYPE
+ ANDI 0,TYPMSK ; FLUSH MONITORS
+ CAIE 0,TENTRY
+ CAIN 0,TCBLK
+ JRST ARGMK1 ; AT FRAME
+ CAIE 0,TINFO ; AT FRAME
+ JRST GCRET ; NOT A LEGAL TYPE GO AWAY
+ HRRZ A,1(A) ; POINTING TO FRAME
+ HRL A,(C) ; GET TIME
+ JRST TBMK
+ARGMK1: HRRI A,FRAMLN(A) ; MAKE POINTER
+ HRL A,(C) ; GET TIME
+ JRST TBMK
+\f
+
+; ROUTINE TO MARK GLOBAL SLOTS
+
+GATOMK: HRRZ B,(C) ; GET POSSIBLE GDECL
+ JUMPE B,ATOMK ; NONE GO TO MARK ATOM
+ CAIN B,-1 ; SKIP IF NOT MANIFEST
+ JRST ATOMK
+ PUSH P,A ; I DOUBT THIS IS RIGHT, BUT IT WORKED ONCE--TAA
+ MOVEI C,(A)
+ MOVEI A,(B)
+ MOVEI B,TLIST ; TYPE WORD LIST
+ PUSHJ P,MARK ; MARK IT
+ POP P,A
+ JRST ATOMK5
+
+ATOMK:
+ATOMK5: HLRE B,A
+ SUB A,B ; A POINTS TO DOPE WORD
+ SKIPGE 1(A) ; SKIP IF NOT MARKED
+ JRST GCRET ; EXIT IF MARKED
+ HLRZ B,1(A)
+ SUBI B,3
+ HRLI B,1(B)
+ MOVEI C,-1(A)
+ SUB C,B ; IN CASE WAS DW
+ IORM D,1(A) ; MARK IT
+ HRRZ A,2(C) ; MARK OBLIST
+ CAMG A,VECBOT
+ JRST NOOBL ; NO IMPURE OBLIST
+ HRLI A,-1
+ MOVEI B,TOBLS ; MARK THE OBLIST
+ PUSHJ P,MARK
+NOOBL: HLRZ A,2(C) ; GET NEXT ATOM
+ MOVEI B,TATOM
+ PUSHJ P,MARK
+ HLRZ B,(C) ; GET VALUE SLOT
+ TRZ B,400000 ; TURN OFF MARK BIT
+ SKIPE B ; SEE IF 0
+ CAIN B,TUNBOUN ; SEE IF UNBOUND
+ JRST GCRET
+ HRRZ 0,(C) ; SEE IF VECTOR OR TP POINTER
+ MOVEI B,TVEC ; ASSUME VECTOR
+ SKIPE 0 ; SKIP IF VECTOR
+ MOVEI B,TTP ; IT IS A TP POINTER
+ PUSHJ P,MARK1 ; GO MARK IT
+ JRST GCRET
+\f
+; ROUTINE TO MARK BYTE AND STRING POINTERS
+
+BYTMK: PUSHJ P,BYTDOP ; GET TO DOPE WORD INTO A
+ HRLZ F,-1(A) ; SEE IF SPECIAL ATOM [SPNAME]
+ ANDI F,SATMSK ; GET SAT
+ CAIN F,SATOM
+ JRST ATMSET ; IT IS AN ATOM
+ IORM D,(A) ; MARK IT
+ JRST GCRET
+
+ATMSET: HLRZ B,(A) ; GET LENGTH
+ TRZ B,400000 ; TURN OFF POSSIBLE MARK BIT
+ MOVNI B,-2(B) ; GENERATE AOBJN POINTER
+ ADDI A,-1(B) ; GET BACK TO BEGINNING
+ HRLI A,(B) ; PUT IN LEFT HALF
+ MOVEI B,TATOM ; MARK AS AN ATOM
+ PUSHJ P,MARK ; GO MARK
+ JRST GCRET
+
+; MARK LOCID GOODIES
+
+LOCMK: HRRZ B,(C) ; CHECK FOR TIME
+ JUMPE B,LOCMK1 ; SKIP LEGAL CHECK FOR GLOBAL
+ HRRZ 0,2(A) ; GET OTHER TIME
+ CAIE 0,(B) ; SAME?
+ JRST GCRET
+ MOVEI B,TTP
+ PUSHJ P,MARK1
+ JRST GCRET
+LOCMK1: MOVEI B,TVEC ; GLOBAL
+ PUSHJ P,MARK1 ; MARK VALUE
+ JRST GCRET
+
+; MARK ASSOCIATION BLOCK
+
+ASMK: MOVEI C,(A) ; SAVE POINTER TO BEGINNING OF ASSOCATION
+ ADDI A,ASOLNT ; POINT TO DOPE WORD
+ HLRE B,1(A) ; GET SECOND D.W.
+ JUMPL B,GCRET ; MARKED SO LEAVE
+ IORM D,1(A) ; MARK ASSOCATION
+ PUSHJ P,MARK2 ; MARK ITEM
+ MOVEI C,INDIC(C)
+ PUSHJ P,MARK2
+ MOVEI C,VAL-INDIC(C)
+ PUSHJ P,MARK2
+ HRRZ A,NODPNT-VAL(C) ; GET NEXT IN CHAIN
+ JUMPN A,ASMK ; GO MARK IT
+ JRST GCRET
+\f
+; MARK OFFSETS
+
+OFFSMK: PUSH P,$TLIST
+ HLRZ 0,1(C) ; PICK UP LIST POINTER
+ PUSH P,0
+ MOVEI C,-1(P)
+ PUSHJ P,MARK2 ; MARK THE LIST
+ SUB P,[2,,2]
+ JRST GCRET ; AND RETURN
+\f
+; HERE TO MARK TEMPLATE DATA STRUCTURES
+
+TD.MK: 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
+ SKIPL 1(A) ; SEE IF MARKED
+ JRST GCRET ; IF MARKED LEAVE
+ IORM D,1(A)
+
+ 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,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,-3(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,-4(P) ; SAVE ELMENT #
+ SKIPN B,-3(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,-3(P) ; PLUS BASIC
+ ADDI A,1 ; AND FUDGE
+ MOVEM A,-4(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
+ EXCH A,B ; REARRANGE
+ HLRZS B
+ MOVSI D,400000 ; RESET FOR MARK
+ PUSHJ P,MARK ; AND MARK THIS GUY (RET FIXED POINTER IN A)
+ MOVE C,-2(P) ; RESTORE POINTER IN CASE MUNGED
+ JRST TD.MR2
+
+TD.MR1: SUB P,[5,,5]
+ JRST GCRET
+
+USRAGC: XCT (E) ; MARK THE TEMPLATE
+ JRST GCRET
+
+\f
+; ROUTINE TO MARK THE GC-READ TABLE. MARKS THE ATOMS AT THE DOPE WORDS
+; AND UPDATES PTR TO THE TABLE.
+
+GCRDMK: MOVEI C,(A) ; SAVE POINTER TO GCREAD TABLE
+ HLRE B,A ; GET TO DOPE WORD
+ SUB A,B
+ SKIPGE 1(A) ; SKIP IF NOT MARKED
+ JRST GCRET
+ IORM D,1(A) ; MARK THE CHOMPER!!!
+ SUBI A,2
+ MOVE B,ABOTN ; GET TOP OF ATOM TABLE
+ ADD B,0 ; GET BOTTOM OF ATOM TABLE
+GCRD1: CAMG A,B ; DON'T SKIP IF DONE
+ JRST GCRET
+ 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
+ POP P,A
+ POP P,B
+ JRST GCRD1
+GCRD3: SUBI A,(C) ; TO NEXT ATOM
+ JRST GCRD1
+
+
+; ROUTINE TO FIX UP CHANNELS
+
+CHNFLS: MOVEI 0,N.CHNS-1
+ MOVEI A,,CHNL1 ; SET UP POINTER
+CHFL1: SKIPN B,1(A) ; GET POINTER TO CHANNEL
+ JRST CHFL2 ; NO CHANNEL LOOP TO NEXT
+ HLRE C,B ; POINT TO DOPE WORD OF CHANNEL
+ SUBI B,(C)
+ MOVEI F,TCHAN
+ HRLM F,(A) ; PUT TYPE BACK
+ SKIPL 1(B) ; SKIP IF MARKED
+ JRST FLSCH ; FLUSH THE CHANNEL
+ MOVEI F,1 ; MARK THE CHANNEL AS GOOD
+ HRRM F,(A) ; SMASH IT IN
+CHFL2: ADDI A,2
+ SOJG 0,CHFL1
+ POPJ P, ; EXIT
+FLSCH: HLLOS F,(A) ; -1 INTO SLOT INDICATES LOSSAGE
+ JRST CHFL2
+
+
+; THIS ROUTINE MARKS ALL THE CHANNELS
+
+CHFIX: MOVEI 0,N.CHNS-1
+ MOVEI A,CHNL1 ; SLOTS
+
+DHNFL2: SKIPN 1(A)
+ JRST DHNFL1
+ PUSH P,0 ; SAVE 0
+ PUSH P,A ; SAVE A
+ MOVEI C,(A)
+ MOVE A,1(A)
+ MOVEI B,TCHAN
+ PUSHJ P,MARK
+ POP P,A ; RESTORE A
+ POP P,0 ; RESTORE
+DHNFL1: ADDI A,2
+ SOJG 0,DHNFL2
+ 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
+ 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
+; ROUTINE TO SEEP THROUGH GC SPACE LOOKING FOR FREE SLOTS. PAIRS ARE PLACED ON THE
+; RCL LIST, VECTORS ON THE RCLV LIST.
+
+SWEEP: MOVE C,GCSTOP ; GET TOP OF GC SPACE
+ SUBI C,1 ; POINT TO FIRST OBJECT
+ SETZB E,F ; CURRENT SLOT AND CURRENT LENGTH
+LSWEEP: CAMG C,GCSBOT ; SKIP IF ABOVE GCSBOT
+ JRST ESWEEP ; DONE
+ HLRE A,-1(C) ; SEE IF LIST OR VECTOR
+ TRNE A,UBIT ; SKIP IF LIST
+ JRST VSWEEP ; IT IS A VECTOR
+ JUMPGE A,LSWP1 ; JUMP IF NOT MARKED
+ ANDCAM D,-1(C) ; TURN OFF MARK BIT
+ PUSHJ P,SWCONS ; CONS ON CURRENT OBJECT
+ SUBI C,2 ; SKIP OVER LIST
+ JRST LSWEEP
+LSWP1: ADDI F,2 ; ADD TO CURRENT OBJECT COUNT
+ JUMPN E,LSWP2 ; JUMP IF CURRENT OBJECT EXISTS
+ MOVEI E,(C) ; GET ADDRESS
+LSWP2: SUBI C,2
+ JRST LSWEEP
+
+VSWEEP: HLRE A,(C) ; GET LENGTH
+ JUMPGE A,VSWP1 ; SKIP IF MARKED
+ ANDCAM D,(C) ; TURN OFF MARK BIT
+ PUSHJ P,SWCONS
+ ANDI A,377777 ; GET LENGTH PART
+ SUBI C,(A) ; GO PAST VECTOR
+ JRST LSWEEP
+VSWP1: ADDI F,(A) ; ADD LENGTH
+ JUMPN E,VSWP2
+ MOVEI E,(C) ; GET NEW OBJECT LOCATION
+VSWP2: SUBI C,(A) ; GO BACK PAST VECTOR
+ JRST LSWEEP
+
+ESWEEP:
+SWCONS: JUMPE E,CPOPJ
+ ADDM F,TOTCNT ; HACK TOTCNT
+ CAMLE F,MAXLEN ; SEE IF NEW MAXIMUM
+ MOVEM F,MAXLEN
+ CAIGE F,2 ; MAKE SURE AT LEAST TWO LONG
+ FATAL SWEEP FAILURE
+ CAIN F,2
+ JRST LCONS
+ SETZM (E)
+ MOVEI 0,(E)
+ SUBI 0,-1(F)
+ SETZM @0
+ HRLS 0
+ ADDI 0,1
+ BLT 0,-2(E)
+ HRRZ 0,RCLV ; GET VECTOR RECYCLE
+ HRRM 0,(E) ; SMASH INTO LINKING SLOT
+ HRRZM E,RCLV ; NEW RECYCLE SLOT
+ HRLM F,(E)
+ MOVSI F,UBIT
+ MOVEM F,-1(E)
+ SETZB E,F
+ POPJ P, ; DONE
+LCONS: SETZM (E)
+ SUBI E,1
+ HRRZ 0,RCL ; GET RECYCLE LIST
+ HRRZM 0,(E) ; SMASH IN
+ HRRZM E,RCL
+ SETZB E,F
+ POPJ P,
+
+\f
+; 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
+
+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 /]
+
+CONSTANTS
+
+HERE
+
+CONSTANTS
+
+OFFSET 0
+
+ZZ==$.+1777
+
+.LOP ANDCM ZZ 1777
+
+ZZ1==.LVAL1
+
+LOC ZZ1
+
+OFFSET OFFS
+
+MRKPDL==.-1
+
+ENDGC:
+
+OFFSET 0
+
+ZZ2==ENDGC-AGCLD
+
+.LOP <ASH @> ZZ2 <,-10.>
+SLENGC==.LVAL1
+.LOP <ASH @> SLENGC <10.>
+RSLENG==.LVAL1
+LOC GCST
+
+.LPUR=$.
+
+END
--- /dev/null
+TITLE ARITHMETIC PRIMITIVES FOR MUDDLE
+
+.GLOBAL HI,RLOW,CPLUS,CMINUS,CTIMES,CDIVID,CFIX,CFLOAT
+.GLOBAL CLQ,CGQ,CLEQ,CGEQ,C1Q,C0Q,CMAX,CMIN,CABS,CMOD,CCOS,CSIN,CATAN,CLOG
+.GLOBAL CEXP,CSQRT,CTIME,CORB,CXORB,CANDB,CEQVB,CRAND,CLSH,CROT,
+.GLOBAL SAT,BFLOAT,FLGSET
+
+;BKD
+
+;DEFINES MUDDLE PRIMITIVES: FIX,FLOAT,ATAN,IEXP,LOG,
+; G?,L?,0?,1?,+,-,*,/,MAX,MIN,ABS,SIN,COS,SQRT,RANDOM,
+; TIME,SORT.
+
+RELOCATABLE
+
+.INSRT MUDDLE >
+
+O=0
+
+
+DEFINE TYP1
+ (AB) TERMIN
+DEFINE VAL1
+ (AB)+1 TERMIN
+
+DEFINE TYP2
+ (AB)+2 TERMIN
+DEFINE VAL2
+ (AB)+3 TERMIN
+
+DEFINE TYP3
+ (AB)+4 TERMIN
+DEFINE VAL3
+ (AB)+5 TERMIN
+
+DEFINE TYPN
+ (D) TERMIN
+DEFINE VALN
+ (D)+1 TERMIN
+
+
+YES: MOVSI A,TATOM ;RETURN PATH FOR 'TRUE'
+ MOVE B,IMQUOTE T
+ AOS (P)
+ POPJ P,
+
+NO: MOVSI A,TFALSE ;RETURN PATH FOR 'FALSE'
+ MOVEI B,NIL
+ POPJ P,
+
+\f;ERROR RETURNS AND OTHER UTILITY ROUTINES
+
+OVRFLW==10
+OVRFLD: ERRUUO EQUOTE OVERFLOW
+
+CARGCH: GETYP 0,A ; GET TYPE
+ CAIN 0,TFLOAT
+ POPJ P,
+ JSP A,BFLOAT
+ POPJ P,
+
+ARGCHK: ;CHECK FOR SINGLE FIXED OR FLOATING
+ ;ARGUMENT IF FIXED CONVERT TO FLOATING
+ ;RETURN FLOATING ARGRUMENT IN B ALWAYS
+ ENTRY 1
+ GETYP C,TYP1
+ MOVE B,VAL1
+ CAIN C,TFLOAT ;FLOATING?
+ POPJ P, ;YES, RETURN
+ CAIE C,TFIX ;FIXED?
+ JRST WTYP1 ;NO, ERROR
+ JSP A,BFLOAT ;YES, CONVERT TO FLOATING AND RETURN
+ POPJ P,
+
+OUTRNG: ERRUUO EQUOTE ARGUMENT-OUT-OF-RANGE
+
+NSQRT: ERRUUO EQUOTE NEGATIVE-ARGUMENT
+
+DEFINE MFLOAT AC
+ IDIVI AC,400000
+ FSC AC+1,233
+ FSC AC,254
+ FADR AC,AC+1
+ TERMIN
+
+BFLOAT: MFLOAT B
+ JRST (A)
+
+OFLOAT: MFLOAT O
+ JRST (C)
+
+BFIX: MULI B,400
+ TSC B,B
+ ASH C,(B)-243
+ MOVE B,C
+ JRST (A)
+
+\f;DISPATCH TABLES USED TO CONTROL THE FLOW OF THE VARIOUS PRIMITIVES
+
+TABLE2: SETZ NO ;TABLE2 (0)
+TABLE3: SETZ YES ;TABLE2 (1) & TABLE3 (0)
+ SETZ NO ;TABLE2 (2)
+ SETZ YES
+ SETZ NO
+
+TABLE4: SETZ NO
+ SETZ NO
+ SETZ YES
+ SETZ YES
+
+
+
+FUNC: JSP A,BFIX
+ JSP A,BFLOAT
+ SUB B,VALN
+ IDIV B,VALN
+ ADD B,VALN
+ IMUL B,VALN
+ JSP C,SWITCH
+ JSP C,SWITCH
+
+
+
+FLFUNC==.-2
+ FSBR B,O
+ FDVR B,O
+ FADR B,O
+ FMPR B,O
+ JSP C,FLSWCH
+ JSP C,FLSWCH
+
+DEFVAL==.-2
+ 0
+ 1
+ 0
+ 1
+ 377777,,-1
+ 400000,,1
+
+DEFTYP==.-2
+ TFIX,,
+ TFIX,,
+ TFIX,,
+ TFIX,,
+ TFLOAT,,
+ TFLOAT,,
+\f;PRIMITIVES FLOAT AND FIX
+
+IMFUNCTION FIX,SUBR
+
+ ENTRY 1
+
+ JSP C,FXFL
+ MOVE B,1(AB)
+ CAIE A,TFIX
+ JSP A,BFIX
+ MOVSI A,TFIX
+ JRST FINIS
+
+IMFUNCTION FLOAT,SUBR
+
+ ENTRY 1
+
+ JSP C,FXFL
+ MOVE B,1(AB)
+ CAIE A,TFLOAT
+ JSP A,BFLOAT
+ MOVSI A,TFLOAT
+ JRST FINIS
+
+CFIX: GETYP 0,A
+ CAIN 0,TFIX
+ POPJ P,
+ JSP A,BFIX
+ MOVSI A,TFIX
+ POPJ P,
+
+CFLOAT: GETYP 0,A
+ CAIN 0,TFLOAT
+ POPJ P,
+ JSP A,BFLOAT
+ MOVSI A,TFLOAT
+ POPJ P,
+
+FXFL: GETYP A,(AB)
+ CAIE A,TFIX
+ CAIN A,TFLOAT
+ JRST (C)
+ JRST WTYP1
+
+
+MFUNCTION ABS,SUBR
+ ENTRY 1
+ GETYP A,TYP1
+ CAIE A,TFIX
+ CAIN A,TFLOAT
+ JRST MOVIT
+ JRST WTYP1
+MOVIT: MOVM B,VAL1 ;GET ABSOLUTE VALUE OF ARGUMENT
+AFINIS: HRLZS A ;MOVE TYPE CODE INTO LEFT HALF
+ JRST FINIS
+
+
+
+MFUNCTION MOD,SUBR
+ ENTRY 2
+ GETYP A,TYP1
+ CAIE A,TFIX ;FIRST ARG FIXED ?
+ JRST WTYP1
+ GETYP A,TYP2
+ CAIE A,TFIX ;SECOND ARG FIXED ?
+ JRST WTYP2
+ MOVE A,VAL1
+ IDIV A,VAL2 ;FORM QUOTIENT & REMAINDER
+ JUMPGE B,.+2 ;Only return positive remainders
+ ADD B,VAL2
+ MOVSI A,TFIX
+ JRST FINIS
+\f;PRIMITIVES PLUS, DIFFERENCE, TIMES, DIVIDE, MIN, AND MAX
+
+MFUNCTION MIN,SUBR
+
+ ENTRY
+
+ MOVEI E,6
+ JRST GOPT
+
+IMFUNCTION MAX,SUBR
+
+ ENTRY
+
+ MOVEI E,7
+ JRST GOPT
+
+MFUNCTION DIVIDE,SUBR,[/]
+
+ ENTRY
+
+ MOVEI E,3
+ JRST GOPT
+
+MFUNCTION DIFFERENCE,SUBR,[-]
+
+ ENTRY
+
+ MOVEI E,2
+ JRST GOPT
+
+IMFUNCTION TIMES,SUBR,[*]
+
+ ENTRY
+
+ MOVEI E,5
+ JRST GOPT
+
+MFUNCTION PLUS,SUBR,[+]
+
+ ENTRY
+
+ MOVEI E,4
+
+GOPT: MOVE D,AB ;ARGUMENT POINTER
+ HLRE A,AB
+ MOVMS A
+ ASH A,-1
+ PUSHJ P,CARITH
+ JRST FINIS
+
+; BUILD COMPILER ENTRIES TO THESE ROUTINES
+
+IRP NAME,,[CMINUS,CDIVID,CPLUS,CTIMES,CMIN,CMAX]CODE,,[2,3,4,5,6,7]
+
+NAME: MOVEI E,CODE
+ JRST CARIT1
+TERMIN
+\f
+CARIT1: MOVEI D,(A)
+ ASH D,1 ; TIMES 2
+ HRLI D,(D)
+ SUBM TP,D ; POINT TO ARGS
+ PUSH TP,$TTP
+ AOBJN D,.+1
+ PUSH TP,D
+ PUSHJ P,CARITH
+ MOVE TP,(TP)
+ SUB TP,[1,,1]
+ POPJ P,
+
+CARITH: MOVE B,DEFVAL(E) ; GET VAL
+ JFCL OVRFLW,.+1
+ MOVEI 0,TFIX ; FIX UNTIL CHANGE
+ JUMPN A,ARITH0 ; AT LEAST ONE ARG
+ MOVE A,DEFTYP(E)
+ POPJ P,
+
+ARITH0: SOJE A,ARITH1 ; FALL IN WITH ONE ARG
+ MOVE B,1(D)
+ GETYP C,(D) ; TYPE OF 1ST ARG
+ ADD D,[2,,2] ; GO TO NEXT
+ CAIN C,TFLOAT
+ JRST ARITH3
+ CAIN C,TFIX
+ JRST ARITH1
+ JRST WRONGT
+
+ARITH1: GETYP C,0(D) ; GET NEXT TYPE
+ CAIE C,TFIX
+ JRST ARITH2 ; TO FLOAT LOOP
+ XCT FUNC(E) ; DO IT
+ ADD D,[2,,2]
+ SOJG A,ARITH1 ; KEEP ADDING OR WHATEVER
+ SKIPE OVFLG
+ JFCL OVRFLW,OVRFLD
+ MOVSI A,TFIX
+ POPJ P,
+
+ARITH3: GETYP C,0(D)
+ MOVE 0,1(D) ; GET ARG
+ CAIE C,TFIX
+ JRST ARITH4
+ PUSH P,A
+ JSP C,OFLOAT ; FLOAT IT
+ POP P,A
+ JRST ARITH5
+ARITH4: CAIE C,TFLOAT
+ JRST WRONGT
+ JRST ARITH5
+
+ARITH2: CAIE C,TFLOAT ; FLOATER?
+ JRST WRONGT
+ PUSH P,A
+ JSP A,BFLOAT
+ POP P,A
+ MOVE 0,1(D)
+
+ARITH5: XCT FLFUNC(E)
+ ADD D,[2,,2]
+ SOJG A,ARITH3
+
+ SKIPE OVFLG
+ JFCL OVRFLW,OVRFLD
+ MOVSI A,TFLOAT
+ POPJ P,
+
+SWITCH: XCT COMPAR(E) ;FOR MAX & MIN TESTING
+ MOVE B,VALN
+ JRST (C)
+COMPAR==.-6
+ CAMLE B,VALN
+ CAMGE B,VALN
+
+
+
+FLSWCH: XCT FLCMPR(E)
+ MOVE B,O
+ JRST (C)
+FLCMPR==.-6
+ CAMLE B,O
+ CAMGE B,O
+\f;PRIMITIVES ONEP AND ZEROP
+
+MFUNCTION ONEP,SUBR,[1?]
+ MOVEI E,1
+ JRST JOIN
+
+MFUNCTION ZEROP,SUBR,[0?]
+ MOVEI E,
+
+JOIN: ENTRY 1
+ GETYP A,TYP1
+ CAIN A,TFIX ;fixed ?
+ JRST TESTFX
+ CAIE A,TFLOAT ;floating ?
+ JRST WTYP1
+ MOVE B,VAL1
+ CAMN B,NUMBR(E) ;equal to correct value ?
+ JRST YES1
+ JRST NO1
+
+TESTFX: CAMN E,VAL1 ;equal to correct value ?
+ JRST YES1
+
+NO1: MOVSI A,TFALSE
+ MOVEI B,0
+ JRST FINIS
+
+YES1: MOVSI A,TATOM
+ MOVE B,IMQUOTE T
+ JRST FINIS
+
+NUMBR: 0 ;FLOATING PT ZERO
+ 201400,,0 ;FLOATING PT ONE
+\f;PRIMITIVES LESSP AND GREATERP
+
+MFUNCTION LEQP,SUBR,[L=?]
+ MOVEI E,3
+ JRST ARGS
+
+MFUNCTION GEQP,SUBR,[G=?]
+ MOVEI E,2
+ JRST ARGS
+
+
+MFUNCTION LESSP,SUBR,[L?]
+ MOVEI E,1
+ JRST ARGS
+
+MFUNCTION GREATERP,SUBR,[G?]
+ MOVEI E,0
+
+ARGS: ENTRY 2
+ MOVE B,VAL1
+ MOVE A,TYP1
+ GETYP 0,A
+ PUSHJ P,CMPTYP
+ JRST WTYP1
+ MOVE D,VAL2
+ MOVE C,TYP2
+ GETYP 0,C
+ PUSHJ P,CMPTYP
+ JRST WTYP2
+ PUSHJ P,ACOMPS
+ JFCL
+ JRST FINIS
+
+; COMPILERS ENTRIES TO THESE GUYS
+
+IRP NAME,,[CGQ,CLQ,CGEQ,CLEQ]COD,,[0,1,2,3]
+
+NAME: MOVEI E,COD
+ JRST ACOMPS
+TERMIN
+
+ACOMPS: GETYP A,A
+ GETYP 0,C
+ CAIE 0,(A)
+ JRST COMPD ; COMPARING FIX AND FLOAT
+TEST: CAMN B,D
+ JRST @TABLE4(E)
+ CAMG B,D
+ JRST @TABLE2(E)
+ JRST @TABLE3(E)
+
+CMPTYP: CAIE 0,TFIX
+ CAIN 0,TFLOAT
+ AOS (P)
+ POPJ P,
+COMPD: EXCH B,D
+ CAIN A,TFLOAT
+ JSP A,BFLOAT
+ EXCH B,D
+ CAIN 0,TFLOAT
+ JSP A,BFLOAT
+COMPF: JRST TEST
+
+MFUNCTION RANDOM,SUBR
+ ENTRY
+ HLRE A,AB
+ CAMGE A,[-4] ;At most two arguments to random to set seeds
+ JRST TMA
+ JRST RANDGO(A)
+ MOVE B,VAL2 ;Set second seed
+ MOVEM B,RLOW
+ MOVE A,VAL1 ;Set first seed
+ MOVEM A,RHI
+RANDGO: PUSHJ P,CRAND
+ JRST FINIS
+
+CRAND: MOVE A,RHI
+ MOVE B,RLOW
+ MOVEM A,RLOW ;Update Low seed
+ LSHC A,-1 ;Shift both right one bit
+ XORB B,RHI ;Generate output and update High seed
+ MOVSI A,TFIX
+ POPJ P,
+
+
+\fMFUNCTION SQRT,SUBR
+ PUSHJ P,ARGCHK
+ JUMPL B,NSQRT
+ PUSHJ P,ISQRT
+ JRST FINIS
+
+ISQRT: MOVE A,B
+ ASH B,-1
+ FSC B,100
+SQ2: MOVE C,B ;NEWTON'S METHOD, SPECINER'S HACK.
+ FDVRM A,B
+ FADRM C,B
+ FSC B,-1
+ CAME C,B
+ JRST SQ2
+ MOVSI A,TFLOAT
+ POPJ P,
+
+MFUNCTION COS,SUBR
+ PUSHJ P,ARGCHK
+ FADR B,[1.570796326] ;COS(X)=SIN (X+PI/2)
+ PUSHJ P,.SIN
+ MOVSI A,TFLOAT
+ JRST FINIS
+
+MFUNCTION SIN,SUBR
+ PUSHJ P,ARGCHK
+ PUSHJ P,.SIN
+ MOVSI A,TFLOAT
+ JRST FINIS
+
+.SIN: MOVM A,B
+ CAMG A,[.0001]
+ POPJ P, ;GOSPER'S RECURSIVE SIN.
+ FDVR B,[-3.0] ;SIN(X)=4*SIN(X/-3)**3-3*SIN(X/-3)
+ PUSHJ P,.SIN
+ FSC A,1
+ FMPR A,A
+ FADR A,[-3.0]
+ FMPRB A,B
+ POPJ P,
+
+CSQRT: PUSHJ P,CARGCH
+ JUMPL B,NSQRT
+ JRST ISQRT
+
+CSIN: PUSHJ P,CARGCH
+CSIN1: PUSHJ P,.SIN
+ MOVSI A,TFLOAT
+ POPJ P,
+
+CCOS: PUSHJ P,CARGCH
+ FADR B,[1.570796326]
+ JRST CSIN1
+\fMFUNCTION LOG,SUBR
+ PUSHJ P,ARGCHK ;LEAVES ARGUMENT IN B
+ PUSHJ P,ILOG
+ JRST FINIS
+
+CLOG: PUSHJ P,CARGCH
+
+ILOG: JUMPLE B,OUTRNG
+ LDB D,[331100,,B] ;GRAB EXPONENT
+ SUBI D,201 ;REMOVE BIAS
+ TLZ B,777000 ;SET EXPONENT
+ TLO B,201000 ; TO 1
+ MOVE A,B
+ FSBR A,RT2
+ FADR B,RT2
+ FDVB A,B
+ FMPR B,B
+ MOVE C,[0.434259751]
+ FMPR C,B
+ FADR C,[0.576584342]
+ FMPR C,B
+ FADR C,[0.961800762]
+ FMPR C,B
+ FADR C,[2.88539007]
+ FMPR C,A
+ FADR C,[0.5]
+ MOVE B,D
+ FSC B,233
+ FADR B,C
+ FMPR B,[0.693147180] ;LOG E OF 2
+ MOVSI A,TFLOAT
+ POPJ P,
+
+RT2: 1.41421356
+\fMFUNCTION ATAN,SUBR
+ PUSHJ P,ARGCHK
+ PUSHJ P,IATAN
+ JRST FINIS
+
+CATAN: PUSHJ P,CARGCH
+
+IATAN: PUSH P,B
+ MOVM D,B
+ CAMG D,[0.4^-8] ;SMALL ENOUGH SO ATAN(X)=X?
+ JRST ATAN3 ;YES
+ CAML D,[7.0^7] ;LARGE ENOUGH SO THAT ATAN(X)=PI/2?
+ JRST ATAN1 ;YES
+ MOVN C,[1.0]
+ CAMLE D,[1.0] ;IS ABS(X)<1.0?
+ FDVM C,D ;NO,SCALE IT DOWN
+ MOVE B,D
+ FMPR B,B
+ MOVE C,[1.44863154]
+ FADR C,B
+ MOVE A,[-0.264768620]
+ FDVM A,C
+ FADR C,B
+ FADR C,[3.31633543]
+ MOVE A,[-7.10676005]
+ FDVM A,C
+ FADR C,B
+ FADR C,[6.76213924]
+ MOVE B,[3.70925626]
+ FDVR B,C
+ FADR B,[0.174655439]
+ FMPR B,D
+ JUMPG D,ATAN2 ;WAS ARG SCALED?
+ FADR B,PI2 ;YES, ATAN(X)=PI/2-ATAN(1/X)
+ JRST ATAN2
+ATAN1: MOVE B,PI2
+ATAN2: SKIPGE (P) ;WAS INPUT NEGATIVE?
+ MOVNS B ;YES,COMPLEMENT
+ATAN3: MOVSI A,TFLOAT
+ SUB P,[1,,1]
+ POPJ P,
+
+PI2: 1.57079632
+\fMFUNCTION IEXP,SUBR,[EXP]
+ PUSHJ P,ARGCHK ;LEAVE FLOATING POINT ARG IN B
+ PUSHJ P,IIEXP
+ JRST FINIS
+
+CEXP: PUSHJ P,CARGCH
+
+IIEXP: PUSH P,B
+ MOVM A,B
+ SETZM B
+ FMPR A,[0.434294481] ;LOG BASE 10 OF E
+ MOVE D,[1.0]
+ CAMG A,D
+ JRST RATEX
+ MULI A,400
+ ASHC B,-243(A)
+ CAILE B,43
+ JRST OUTRNG
+ CAILE B,7
+ JRST EXPR2
+EXPR1: FMPR D,FLOAP1(B)
+ LDB A,[103300,,C]
+ SKIPE A
+ TLO A,177000
+ FADR A,A
+RATEX: MOVEI B,7
+ SETZM C
+RATEY: FADR C,COEF2-1(B)
+ FMPR C,A
+ SOJN B,RATEY
+ FADR C,[1.0]
+ FMPR C,C
+ FMPR D,C
+ MOVE B,[1.0]
+ SKIPL (P) ;SKIP IF INPUT NEGATIVE
+ SKIPN B,D
+ FDVR B,D
+ MOVSI A,TFLOAT
+ SUB P,[1,,1]
+ POPJ P,
+
+EXPR2: LDB E,[030300,,B]
+ ANDI B,7
+ MOVE D,FLOAP1(E)
+ FMPR D,D ;TO THE 8TH POWER
+ FMPR D,D
+ FMPR D,D
+ JRST EXPR1
+
+COEF2: 1.15129278
+ 0.662730884
+ 0.254393575
+ 0.0729517367
+ 0.0174211199
+ 2.55491796^-3
+ 9.3264267^-4
+
+FLOAP1: 1.0
+ 10.0
+ 100.0
+ 1000.0
+ 10000.0
+ 100000.0
+ 1000000.0
+ 10000000.0
+\f
+;LSH AND ROT (ERB WOULD BE PLEASED) PDL 2/22/79
+
+MFUNCTION %LSH,SUBR,LSH
+ ENTRY 2
+ MOVE C,[LSH B,(A)]
+ JRST LSHROT
+
+MFUNCTION %ROT,SUBR,ROT
+ ENTRY 2
+ MOVE C,[ROT B,(A)]
+LSHROT: GETYP A,(AB)
+ PUSHJ P,SAT
+ CAIE A,S1WORD
+ JRST WRONGT
+ GETYP A,2(AB)
+ CAIE A,TFIX
+ JRST WTYP2
+ MOVE A,3(AB)
+ MOVE B,1(AB)
+ XCT C
+ MOVE A,$TWORD
+ JRST FINIS
+
+;BITWISE BOOLEAN FUNCTIONS
+
+MFUNCTION %ANDB,SUBR,ANDB
+ ENTRY
+ HRREI B,-1 ;START ANDING WITH ALL ONES
+ MOVE D,[AND B,A] ;LOGICAL INSTRUCTION
+ JRST LOGFUN ;DO THE OPERATION
+
+MFUNCTION %ORB,SUBR,ORB
+ ENTRY
+ MOVEI B,0
+ MOVE D,[IOR B,A]
+ JRST LOGFUN
+
+MFUNCTION %XORB,SUBR,XORB
+ ENTRY
+ MOVEI B,0
+ MOVE D,[XOR B,A]
+ JRST LOGFUN
+
+MFUNCTION %EQVB,SUBR,EQVB
+ ENTRY
+ HRREI B,-1
+ MOVE D,[EQV B,A]
+
+LOGFUN: JUMPGE AB,ZROARG
+LOGTYP: GETYP A,(AB) ;GRAB THE TYPE
+ PUSHJ P,SAT ;STORAGE ALLOCATION TYPE
+ CAIE A,S1WORD
+ JRST WRONGT ;WRONG TYPE...LOSE
+ MOVE A,1(AB) ;LOAD ARG INTO A
+ XCT D ;DO THE LOGICAL OPERATION
+ AOBJP AB,.+2 ;ADD ONE TO BOTH HALVES
+ AOBJN AB,LOGTYP ;ADD AGAIN AND LOOP IF NEEDED
+
+ZROARG: MOVE A,$TWORD
+ JRST FINIS
+\fREPEAT 0,[
+;routine to sort lists or vectors of either fixed point or floating numbers
+;the components are interchanged repeatedly to acheive the sort
+;first arg: the structure to be sorted
+;if no second arg sort in descending order
+;second arg: if false then sort in ascending order
+; else sort in descending order
+
+MFUNCTION SORT,SUBR
+ ENTRY
+ HLRZ A,AB
+ CAIGE A,-4 ;Only two arguments allowed
+ JRST TMA
+ MOVE O,DESCEND ;Set up "O" to test for descending order as default condition
+ CAIE A,-4 ;Optional second argument?
+ JRST .+4
+ GETYP B,TYP2 ;See if it is other than false
+ CAIN B,TFALSE
+ MOVE O,ASCEND ;Set up "O" to test for ascending order
+ GETYP A,TYP1 ;CHECK TYPE OF FIRST ARGUMENT
+ CAIN A,TLIST
+ JRST LSORT
+ CAIN A,TVEC
+ JRST VSORT
+ JRST WTYP1
+
+
+
+
+GOBACK: MOVE A,TYP1 ;RETURN THE SORTED ARGUMENT AS VALUE
+ MOVE B,VAL1
+ JRST FINIS
+
+DESCEND: CAMG C,(A)+1
+ASCEND: CAML C,(A)+1
+\f;ROUTINE TO SORT LISTS IN NUMERICAL ORDER
+
+LSORT: MOVE A,VAL1
+ JUMPE A,GOBACK ;EMPTY LIST?
+ HLRZ B,(A) ;TYPE OF FIRST COMPONENT
+ CAIE B,TFIX
+ CAIN B,TFLOAT
+ SKIPA
+ JRST WRONGT
+ MOVEI E,0 ;FOR COUNT OF LENGTH OF LIST
+LCOUNT: JUMPE A,LLSORT ;REACHED END OF LIST?
+ MOVE A,(A) ;NEXT COMPONENT
+ TLZ A,(B) ;SAME TYPE AS FIRST COMPONENT?
+ TLNE A,-1
+ JRST WRONGT
+ AOJA E,LCOUNT ;INCREMENT COUNT AND CONTINUE
+
+LLSORT: SOJE E,GOBACK ;FINISHED WITH SORTING?
+ HRRZ A,VAL1 ;START THIS LOOP OF SORTING AT THE BEGINNING
+ MOVEM E,(P)+1 ;Save the iteration depth
+CLSORT: HRRZ B,(A) ;NEXT COMPONENT
+ MOVE C,(B)+1 ;ITS VALUE
+ XCT O ;ARE THESE TWO COMPONENTS IN ORDER?
+ JRST .+4
+ MOVE D,(A)+1 ;INTERCHANGE THEM
+ MOVEM D,(B)+1
+ MOVEM C,(A)+1
+ MOVE A,B ;MAKE THE COMPONENT IN "B" THE CURRENT ONE
+ SOJG E,CLSORT
+ MOVE E,(P)+1 ;Restore the iteration depth
+ JRST LLSORT
+\f;ROUTINE TO SORT VECTORS IN NUMERICAL ORDER
+
+VSORT: HLRE D,VAL1 ;GET COUNT FIELD OF VECTOR
+ IDIV D,[-2] ;LENGTH
+ JUMPE D,GOBACK ;EMPTY VECTOR?
+ MOVE E,D ;SAVE LENGTH IN "E"
+ HRRZ A,VAL1 ;POINTER TO VECTOR
+ MOVE B,(A) ;TYPE OF FIRST COMPONENT
+ CAME B,$TFIX
+ CAMN B,$TFLOAT
+ SKIPA
+ JRST WRONGT
+ SOJLE D,GOBACK ;IF ONLY ONE COMPONENT THEN FINISHED
+VCOUNT: ADDI A,2 ;CHECK NEXT COMPONENT
+ CAME B,(A) ;SAME TYPE AS FIRST COMPONENT?
+ JRST WRONGT
+ SOJG D,VCOUNT ;CONTINUE WITH NEXT COMPONENT
+
+VVSORT: SOJE E,GOBACK ;FINISHED SORTING?
+ HRRZ A,VAL1 ;START THIS LOOP OF SORTING AT THE BEGINNING
+ MOVEM E,(P)+1 ;Save the iteration depth
+CVSORT: MOVE C,(A)+3 ;VALUE OF NEXT COMPONENT
+ XCT O ;ARE THESE TWO COMPONENTS IN ORDER?
+ JRST .+4
+ MOVE D,(A)+1 ;INTERCHANGE THEM
+ MOVEM D,(A)+3
+ MOVEM C,(A)+1
+ ADDI A,2 ;UPDATE THE CURRENT COMPONENT
+ SOJG E,CVSORT
+ MOVE E,(P)+1 ;Restore the iteration depth
+ JRST VVSORT
+]
+
+MFUNCTION OVERFLOW,SUBR
+
+ ENTRY
+
+ MOVEI E,OVFLG
+ JRST FLGSET
+
+
+MFUNCTION TIME,SUBR
+ ENTRY
+ PUSHJ P,CTIME
+ JRST FINIS
+
+IMPURE
+
+RHI: 267762113337
+RLOW: 155256071112
+OVFLG: -1
+PURE
+
+
+END
+\f\f
\ No newline at end of file
--- /dev/null
+LOGIN CLR\ 5t
+CONN INT:
+MIDAS
+AGC BIN_AGC MID
+RESET MIDAS
+MIDAS
+AGCMRK BIN_AGCMRK MID
+RESET MIDAS
+MIDAS
+AMSGC BIN_AMSGC MID
+RESET MIDAS
+MIDAS
+ARITH BIN_ARITH MID
+RESET MIDAS
+MIDAS
+ATOMHK BIN_ATOMHK MID
+RESET MIDAS
+MIDAS
+BUFMOD BIN_BUFMOD MID
+RESET MIDAS
+MIDAS
+CORE BIN_CORE MID
+RESET MIDAS
+MIDAS
+CREATE BIN_CREATE MID
+RESET MIDAS
+MIDAS
+DECL BIN_DECL MID
+RESET MIDAS
+MIDAS
+EVAL BIN_EVAL MID
+RESET MIDAS
+MIDAS
+FOPEN BIN_FOPEN MID
+RESET MIDAS
+MIDAS
+GCHACK BIN_GCHACK MID
+RESET MIDAS
+MIDAS
+INITM BIN_INITM MID
+RESET MIDAS
+MIDAS
+INTERR BIN_INTERR MID
+RESET MIDAS
+MIDAS
+IPC BIN_IPC MID
+RESET MIDAS
+MIDAS
+LDGC BIN_LDGC MID
+RESET MIDAS
+MIDAS
+MAIN BIN_MAIN MID
+RESET MIDAS
+MIDAS
+MAPPUR BIN_MAPPUR MID
+RESET MIDAS
+MIDAS
+MAPS BIN_MAPS MID
+RESET MIDAS
+MIDAS
+MUDEX BIN_MUDEX MID
+RESET MIDAS
+MIDAS
+MUDITS BIN_MUDITS MID
+RESET MIDAS
+MIDAS
+MUDSQU BIN_MUDSQU MID
+RESET MIDAS
+MIDAS
+NFREE BIN_NFREE MID
+RESET MIDAS
+MIDAS
+PRIMIT BIN_PRIMIT MID
+RESET MIDAS
+MIDAS
+PRINT BIN_PRINT MID
+RESET MIDAS
+MIDAS
+PURE BIN_PURE MID
+RESET MIDAS
+MIDAS
+PUTGET BIN_PUTGET MID
+RESET MIDAS
+MIDAS
+PXCORE BIN_PXCORE MID
+RESET MIDAS
+MIDAS
+READCH BIN_READCH MID
+RESET MIDAS
+MIDAS
+READER BIN_READER MID
+RESET MIDAS
+MIDAS
+SAVE BIN_SAVE MID
+RESET MIDAS
+MIDAS
+SPECS BIN_SPECS MID
+RESET MIDAS
+MIDAS
+STBUIL BIN_STBUIL MID
+RESET MIDAS
+MIDAS
+STENEX BIN_STENEX MID
+RESET MIDAS
+MIDAS
+TMUDV BIN_TMUDV MID
+RESET MIDAS
+MIDAS
+TXPURE BIN_TXPURE MID
+RESET MIDAS
+MIDAS
+UTILIT BIN_UTILIT MID
+RESET MIDAS
+MIDAS
+UUOH BIN_UUOH MID
--- /dev/null
+
+TITLE ATOMHACKER FOR MUDDLE
+
+RELOCATABLE
+
+.INSRT MUDDLE >
+.GLOBAL RLOOKU,CHMAK,OBLNT,ROOT,INTOBL,ERROBL,IFALSE,PVSTOR,SPSTOR
+.GLOBAL .BLOCK,IDVAL,NXTDCL,CHRWRD,CSTACK,CSTAK,ILOOKC,IGVAL,BYTDOP,HASHTB
+.GLOBAL ICONS,INCONS,IBLOCK,INSRTX,GCHACK,IMPURIFY,BSETG,TYPVEC,IGET,IPUT
+.GLOBAL CINSER,CIRMV,CLOOKU,CATOM,CIPNAM,MPOPJ,CSETG,CSPNAM,GPURFL,IMPURX
+
+LPVP==SP
+TYPNT==AB
+LNKBIT==200000
+
+; FUNCTION TO GENERATE AN EMPTY OBLIST
+
+MFUNCTION MOBLIST,SUBR
+
+ ENTRY
+ CAMGE AB,[-5,,0] ;CHECK NUMBER OF ARGS
+ JRST TMA
+ JUMPGE AB,MOBL2 ; NO ARGS
+ MOVE A,(AB)
+ MOVE B,1(AB)
+ MOVSI C,TATOM
+ MOVE D,IMQUOTE OBLIST
+ PUSHJ P,IGET ; CHECK IF IT EXISTS ALREADY
+ CAMN A,$TOBLS
+ JRST FINIS
+MOBL2:
+ MOVEI A,1
+ PUSHJ P,IBLOCK ;GET A UNIFORM VECTOR
+ MOVSI C,TLIST+.VECT. ;IT IS OF TYPE LIST
+ HLRE D,B ;-LENGTH TO D
+ SUBM B,D ;D POINTS TO DOPE WORD
+ MOVEM C,(D) ;CLOBBER TYPE IN
+ MOVSI A,TOBLS
+ JUMPGE AB,FINIS ; IF NO ARGS, DONE
+ GETYP A,(AB)
+ CAIE A,TATOM
+ JRST WTYP1
+ MOVSI A,TOBLS
+ PUSH TP,$TOBLS
+ PUSH TP,B
+ MOVSI C,TATOM
+ MOVE D,IMQUOTE OBLIST
+ PUSH TP,(AB)
+ PUSH TP,1(AB)
+ PUSHJ P,IPUT ; PUT THE NAME ON THE OBLIST
+ MOVE A,(AB)
+ MOVE B,1(AB)
+ MOVSI C,TATOM
+ MOVE D,IMQUOTE OBLIST
+ PUSH TP,(TB)
+ PUSH TP,1(TB)
+ PUSHJ P,IPUT ; PUT THE OBLIST ON THE NAME
+
+ POP TP,B
+ POP TP,A
+ JRST FINIS
+
+MFUNCTION GROOT,SUBR,ROOT
+ ENTRY 0
+ MOVE A,ROOT
+ MOVE B,ROOT+1
+ JRST FINIS
+
+MFUNCTION GINTS,SUBR,INTERRUPTS
+ ENTRY 0
+ MOVE A,INTOBL
+ MOVE B,INTOBL+1
+ JRST FINIS
+
+MFUNCTION GERRS,SUBR,ERRORS
+ ENTRY 0
+ MOVE A,ERROBL
+ MOVE B,ERROBL+1
+ JRST FINIS
+
+
+COBLQ: SKIPN B,2(B) ; SKIP IF EXISTS
+ JRST IFLS
+ MOVSI A,TOBLS
+
+ ANDI B,-1
+ CAMG B,VECBOT ; TVP IS IN FROZEN SPACE, NEVER OBLISTS
+ MOVE B,(B)
+ HRLI B,-1
+
+CPOPJ1: AOS (P)
+ POPJ P,
+
+IFLS: MOVEI B,0
+ MOVSI A,TFALSE
+ POPJ P,
+
+MFUNCTION OBLQ,SUBR,[OBLIST?]
+
+ ENTRY 1
+ GETYP A,(AB)
+ CAIE A,TATOM
+ JRST WTYP1
+ MOVE B,1(AB) ; GET ATOM
+ PUSHJ P,COBLQ
+ JFCL
+ JRST FINIS
+
+\f; FUNCTION TO FIND AN ATOM ON A GIVEN OBLIST WITH A GIVEN PNAME
+
+MFUNCTION LOOKUP,SUBR
+
+ ENTRY 2
+ PUSHJ P,ILOOKU ;CALL INTERNAL ROUTINE
+ JRST FINIS
+
+CLOOKU: SUBM M,(P)
+ PUSH TP,A
+ PUSH TP,B
+ MOVEI B,-1(TP)
+ PUSH TP,$TOBLS
+ PUSH TP,C
+ GETYP A,A
+ PUSHJ P,CSTAK
+ MOVE B,(TP)
+ MOVSI A,TOBLS ; THIS IS AN OBLIST
+ PUSHJ P,ILOOK
+ POP P,D
+ HRLI D,(D)
+ SUB P,D
+ SKIPE B
+ SOS (P)
+ SUB TP,[4,,4]
+ JRST MPOPJ
+
+ILOOKU: PUSHJ P,ARGCHK ;CHECK ARGS
+ PUSHJ P,CSTACK ;PUT CHARACTERS ON THE STACK
+
+CALLIT: MOVE B,3(AB) ;GET OBLIST
+ MOVSI A,TOBLS
+ILOOKC: PUSHJ P,ILOOK ;LOOK IT UP
+ POP P,D ;RESTORE COUNT
+ HRLI D,(D) ;TO BOTH SIDES
+ SUB P,D
+ POPJ P,
+
+;THIS ROUTINE CHECKS ARG TYPES
+
+ARGCHK: GETYP A,(AB) ;GET TYPES
+ GETYP C,2(AB)
+ CAIE A,TCHRS ;IS IT EITHER CHAR STRING
+ CAIN A,TCHSTR
+ CAIE C,TOBLS ;IS 2ND AN OBLIST
+ JRST WRONGT ;TYPES ARE WRONG
+ POPJ P,
+
+;THIS SUBROUTINE PUTS CHARACTERS ON THE STACK (P WILL BE CHANGED)
+
+
+CSTACK: MOVEI B,(AB)
+CSTAK: POP P,D ;RETURN ADDRESS TO D
+ CAIE A,TCHRS ;IMMEDIATE?
+ JRST NOTIMM ;NO, HAIR
+ MOVE A,1(B) ; GET CHAR
+ LSH A,29. ; POSITION
+ PUSH P,A ;ONTO P
+ PUSH P,[1] ;WITH NUMBER
+ JRST (D) ;GO CALL SEARCHER
+
+NOTIMM: MOVEI A,1 ; CLEAR CHAR COUNT
+ MOVE C,(B) ; GET COUNT OF CHARS
+ TRNN C,-1
+ JRST NULST ; FLUSH NULL STRING
+ MOVE PVP,PVSTOR+1
+ MOVEM C,BSTO(PVP)
+ ANDI C,-1
+ MOVE B,1(B) ;GET BYTE POINTER
+
+CLOOP1: PUSH P,[0] ; STORE CHARS ON STACK
+ MOVSI E,(<440700,,(P)>) ; SETUP BYTE POINTER
+CLOOP: SKIPL INTFLG ; SO CAN WIN WITH INTERRUPTS
+ JRST CLOOP2
+ MOVE PVP,PVSTOR+1
+ HRRM C,BSTO(PVP) ;SAVE STRING LENGTH
+ JSR LCKINT
+CLOOP2: ILDB 0,B ;GET A CHARACTER
+ IDPB 0,E ;STORE IT
+ SOJE C,CDONE ; ANY MORE?
+ TLNE E,760000 ; WORD FULL
+ JRST CLOOP ;NO CONTINUE
+ AOJA A,CLOOP1 ;AND CONTINUE
+
+CDONE:
+CDONE1: MOVE PVP,PVSTOR+1
+ SETZM BSTO(PVP)
+ PUSH P,A ;AND NUMBER OF WORDS
+ JRST (D) ;RETURN
+
+
+NULST: ERRUUO EQUOTE NULL-STRING
+\f; THIS FUNCTION LOOKS FOR ATOMS. CALLED BY PUSHJ P,ILOOK
+; A,B/ OBLIST POINTER (CAN BE LIST OF SAME)
+; -1(P)/ LENGTH IN WORDS OF CHARACTER BLOCK
+; CHAR STRING IS ON THE STACK
+; IF ATOM EXISTS RETURNS:
+; B/ THE ATOM
+; C/ THE BUCKET
+; 0/ THE PREVIOUS BUCKET
+;
+; IF NOT
+; B/ 0
+; 0/ PREV IF ONE WITH SAME PNAME, ELSE 0
+; C/ BUCKET
+
+ILOOK: PUSH TP,A
+ PUSH TP,B
+
+ MOVN A,-1(P) ;GET -LENGTH
+ HRLI A,-1(A) ;<-LENGTH-1>,,-LENGTH
+ PUSH TP,$TFIX ;SAVE
+ PUSH TP,A
+ ADDI A,-1(P) ;HAVE AOBJN POINTER TO CHARS
+ MOVE 0,[202622077324] ;HASH WORD
+ ROT 0,1
+ TSC 0,(A)
+ AOBJN A,.-2 ;XOR THEM ALL TOGETHER
+ HLRE A,HASHTB+1
+ MOVNS A
+ MOVMS 0 ; MAKE SURE + HASH CODE
+ IDIVI 0,(A) ;DIVIDE
+ HRLI A,(A) ;TO BOTH HALVES
+ ADD A,HASHTB+1
+
+ MOVE C,A
+ HRRZ A,(A) ; POINT TO FIRST ATOM
+ SETZB E,0 ; INDICATE NO ATOM
+
+ JUMPE A,NOTFND
+LOOK2: HLRZ E,1(A) ; PREPARE TO BUILD AOBJN
+ ANDI E,377777 ; SIGN MIGHT BE ON IF IN PURIFY ETC.
+ SUBI E,2
+ HRLS E
+ SUBB A,E
+
+ ADD A,[3,,3] ;POINT TO ATOMS PNAME
+ MOVE D,(TP) ;GET PSEUDO AOBJN POINTER TO CHARS
+ ADDI D,-1(P) ;NOW ITS A REAL AOBJN POINTER
+ JUMPE D,CHECK0 ;ONE IS EMPTY
+LOOK1:
+ MOVE SP,(D)
+ CAME SP,(A)
+
+ JRST NEXT1 ;THIS ONE DOESN'T MATCH
+ AOBJP D,CHECK ;ONE RAN OUT
+ AOBJN A,LOOK1 ;JUMP IF STILL MIGHT WIN
+
+NEXT1: HRRZ A,-1(TP) ; SEE IF WE'VE ALREADY SEEN THIS NAME
+ GETYP D,-3(TP) ; SEE IF LIST OF OBLISTS
+ CAIN D,TLIST
+ JUMPN A,CHECK3 ; DON'T LOOK FURTHER
+ JUMPN A,NOTFND
+NEXT:
+ MOVE 0,E
+ HLRZ A,2(E) ; NEXT ATOM
+ JUMPN A,LOOK2
+ HRRZ A,-1(TP)
+ JUMPN A,NEXT1
+
+ SETZB E,0
+
+NOTFND:
+ MOVEI B,0
+ MOVSI A,TFALSE
+CPOPJT:
+
+ SUB TP,[4,,4]
+ POPJ P,
+
+CHECK0: JUMPN A,NEXT1 ;JUMP IF NOT ALSO EMPTY
+ SKIPA
+CHECK: AOBJN A,NEXT1 ;JUMP IF NO MATCH
+
+CHECK5: HRRZ A,-1(TP) ; SEE IF FIRST SHOT AT THIS GUY?
+ SKIPN A
+ MOVE B,0 ; REMEMBER ATOM FOR FALL BACK
+ HLLOS -1(TP) ; INDICATE NAME MATCH HAS OCCURRED
+ HRRZ A,2(E) ; COMPUTE OBLIST POINTER
+ CAMGE A,VECBOT
+ MOVE A,(A)
+ HRROS A
+ GETYP D,-3(TP) ; SEE IF LIST OF OBLISTS OR
+ CAIE D,TOBLS
+ JRST CHECK1
+ CAME A,-2(TP) ; DO OBLISTS MATCH?
+ JRST NEXT
+
+CHECK2: MOVE B,E ; RETURN ATOM
+ MOVSI A,TATOM
+ JRST CPOPJT
+
+CHECK1: MOVE D,-2(TP) ; ANY LEFT?
+ CAMN A,1(D) ; MATCH
+ JRST CHECK2
+ JRST NEXT
+
+CHECK3: MOVE D,-2(TP)
+ HRRZ D,(D)
+ MOVEM D,-2(TP)
+ JUMPE D,NOTFND
+ JUMPE B,CHECK6
+ HLRZ E,2(B)
+CHECK7: HLRZ A,1(E)
+ ANDI A,377777 ; SIGN MIGHT BE ON IF IN PURIFY ETC.
+ SUBI A,2
+ HRLS A
+ SUBB E,A
+ JRST CHECK5
+
+CHECK6: HRRZ E,(C)
+ JRST CHECK7
+
+\f; FUNCTION TO INSERT AN ATOM ON AN OBLIST
+
+MFUNCTION INSERT,SUBR
+
+ ENTRY 2
+ GETYP A,2(AB)
+ CAIE A,TOBLS
+ JRST WTYP2
+ MOVE A,(AB)
+ MOVE B,1(AB)
+ MOVE C,3(AB)
+ PUSHJ P,IINSRT
+ JRST FINIS
+
+CINSER: SUBM M,(P)
+ PUSHJ P,IINSRT
+ JRST MPOPJ
+
+IINSRT: PUSH TP,A
+ PUSH TP,B
+ PUSH TP,$TOBLS
+ PUSH TP,C
+ GETYP A,A
+ CAIN A,TATOM
+ JRST INSRT0
+
+;INSERT WITH A GIVEN PNAME
+
+ CAIE A,TCHRS
+ CAIN A,TCHSTR
+ JRST .+2
+ JRST WTYP1
+
+ PUSH TP,$TFIX ;FLAG CALL
+ PUSH TP,[0]
+ MOVEI B,-5(TP)
+ PUSHJ P,CSTAK ;COPY ONTO STACK
+ MOVE B,-2(TP)
+ MOVSI A,TOBLS
+ PUSHJ P,ILOOK ;LOOK IT UP (BUCKET RETURNS IN C)
+ SETZM -4(TP)
+ SETZM -5(TP) ; KILL STRING POINTER TO KEEP FROM CONFUSING GC
+ JUMPN B,ALRDY ;EXISTS, LOSE
+ MOVE D,-2(TP) ; GET OBLIST BACK
+INSRT1: PUSH TP,$TATOM
+ PUSH TP,0 ; PREV ATOM
+ PUSH TP,$TUVEC ;SAVE BUCKET POINTER
+ PUSH TP,C
+ PUSH TP,$TOBLS
+ PUSH TP,D ; SAVE OBLIST
+INSRT3: PUSHJ P,IATOM ; MAKE AN ATOM
+ HLRE A,B ; FIND DOPE WORD
+ SUBM B,A
+ ANDI A,-1
+ SKIPN E,-4(TP) ; AFTER AN ATOM?
+ JRST INSRT7 ; NO, FIRST IN BUCKET
+ MOVEI 0,(E) ; CHECK IF PURE
+ CAIG 0,HIBOT
+ JRST INSRNP
+ PUSH TP,$TATOM ; SAVE NEW ATOM
+ PUSH TP,B
+ MOVE B,E
+ PUSHJ P,IMPURIF
+ MOVE B,(TP)
+ MOVE E,-6(TP)
+ SUB TP,[2,,2]
+ HLRE A,B ; FIND DOPE WORD
+ SUBM B,A
+ ANDI A,-1
+
+INSRNP: HLRZ 0,2(E) ; NEXT
+ HRLM A,2(E) ; SPLICE
+ HRLM 0,2(B)
+ JRST INSRT8
+
+INSRT7: MOVE E,-2(TP)
+ EXCH A,(E)
+ HRLM A,2(B) ; IN CASE OLD ONE
+
+INSRT8: MOVE E,(TP) ; GET OBLIST
+ HRRM E,2(B) ; STORE OBLIST
+ MOVE E,(E) ; POINT TO LIST OF ATOMS
+ PUSHJ P,LINKCK
+ PUSHJ P,ICONS
+ MOVE E,(TP)
+ HRRM B,(E) ;INTO NEW BUCKET
+ MOVSI A,TATOM
+ MOVE B,1(B) ;GET ATOM BACK
+ MOVE C,-6(TP) ;GET FLAG
+ SUB TP,[8,,8] ;POP STACK
+ JUMPN C,(C)
+ SUB TP,[4,,4]
+ POPJ P,
+
+;INSERT WITH GIVEN ATOM
+INSRT0: MOVE A,-2(TP) ;GOBBLE PNAME
+ SKIPE 2(A) ; SKIP IF NOT ON AN OBLIST
+ JRST ONOBL
+ ADD A,[3,,3]
+ HLRE C,A
+ MOVNS C
+ PUSH P,(A) ;FLUSH PNAME ONTO P STACK
+ AOBJN A,.-1
+ PUSH P,C
+ MOVE B,(TP) ; GET OBLIST FOR LOOKUP
+ MOVSI A,TOBLS
+ PUSHJ P,ILOOK ;ALREADY THERE?
+ JUMPN B,ALRDY
+ MOVE D,-2(TP)
+
+ HLRE A,-2(TP) ; FIND DOPE WORD
+ SUBM D,A ; TO A
+ JUMPE 0,INSRT9 ; NO CURRENT ATOM
+ MOVE E,0
+ MOVEI 0,(E)
+ CAIGE 0,HIBOT ; PURE?
+ JRST INSRPN
+ PUSH TP,$TATOM
+ PUSH TP,E
+ PUSH TP,$TATOM
+ PUSH TP,D
+ MOVE B,E
+ PUSHJ P,IMPURIF
+ MOVE D,(TP)
+ MOVE E,-2(TP)
+ SUB TP,[4,,4]
+ HLRE A,D
+ SUBM D,A
+
+
+INSRPN: HLRZ 0,2(E) ; POINT TO NEXT
+ HRLM A,2(E) ; CLOBBER NEW GUY IN
+ HRLM 0,2(D) ; FINISH SLPICE
+ JRST INSRT6
+
+INSRT9: ANDI A,-1
+ EXCH A,(C) ; INTO BUCKET
+ HRLM A,2(D)
+
+INSRT6: HRRZ E,(TP)
+ HRRZ E,(E)
+ MOVE B,D
+ PUSHJ P,LINKCK
+ PUSHJ P,ICONS
+ MOVE C,(TP) ;RESTORE OBLIST
+ HRRZM B,(C)
+ MOVE B,-2(TP) ; GET BACK ATOM
+ HRRM C,2(B) ; CLOBBER OBLIST IN
+ MOVSI A,TATOM
+ SUB TP,[4,,4]
+ POP P,C
+ HRLI C,(C)
+ SUB P,C
+ POPJ P,
+
+LINKCK: HRRZ C,FSAV(TB) ;CALLER'S NAME
+ MOVE D,B
+ CAIE C,LINK
+ SKIPA C,$TATOM ;LET US INSERT A LINK INSTEAD OF AN ATOM
+ SKIPA C,$TLINK ;GET REAL ATOM FOR CALL TO ICONS
+ POPJ P,
+ HLRE A,D
+ SUBM D,A
+ MOVEI B,LNKBIT
+ IORM B,(A)
+ POPJ P,
+
+
+ALRDY: ERRUUO EQUOTE ATOM-ALREADY-THERE
+
+ONOBL: ERRUUO EQUOTE ON-AN-OBLIST-ALREADY
+
+; INTERNAL INSERT CALL
+
+INSRTX: POP P,0 ; GET RET ADDR
+ PUSH TP,$TFIX
+ PUSH TP,0
+ PUSH TP,$TATOM
+ PUSH TP,[0]
+ PUSH TP,$TUVEC
+ PUSH TP,[0]
+ PUSH TP,$TOBLS
+ PUSH TP,B
+ MOVSI A,TOBLS
+ PUSHJ P,ILOOK
+ JUMPN B,INSRXT
+ MOVEM 0,-4(TP)
+ MOVEM C,-2(TP)
+ JRST INSRT3 ; INTO INSERT CODE
+
+INSRXT: PUSH P,-4(TP)
+ SUB TP,[6,,6]
+ POPJ P,
+ JRST IATM1
+\f
+; FUNCTION TO REMOVE AN ATOM FROM AN OBLIST
+
+MFUNCTION REMOVE,SUBR
+
+ ENTRY
+
+ JUMPGE AB,TFA
+ CAMGE AB,[-5,,]
+ JRST TMA
+ MOVEI C,0
+ CAML AB,[-3,,] ; SKIP IF OBLIST GIVEN
+ JRST .+5
+ GETYP 0,2(AB)
+ CAIE 0,TOBLS
+ JRST WTYP2
+ MOVE C,3(AB)
+ MOVE A,(AB)
+ MOVE B,1(AB)
+ PUSHJ P,IRMV
+ JRST FINIS
+
+CIRMV: SUBM M,(P)
+ PUSHJ P,IRMV
+ JRST MPOPJ
+
+IRMV: PUSH TP,A
+ PUSH TP,B
+ PUSH TP,$TOBLS
+ PUSH TP,C
+IRMV1: GETYP 0,A ; CHECK 1ST ARG
+ CAIN 0,TLINK
+ JRST .+3
+ CAIE 0,TATOM ; ATOM, TREAT ACCORDINGLY
+ JRST RMV1
+
+ HRRZ D,2(B) ; SKIP IF ON OBLIST AND GET SAME
+ JUMPE D,RMVDON
+ CAMG D,VECBOT ; SKIP IF REAL OBLIST
+ HRRZ D,(D) ; NO, REF, GET IT
+
+ JUMPGE C,GOTOBL
+ CAIE D,(C) ; BETTER BE THE SAME
+ JRST ONOTH
+
+GOTOBL: ADD B,[3,,3] ; POINT TO PNAME
+ HLRE A,B
+ MOVNS A
+ PUSH P,(B) ; PUSH PNAME
+ AOBJN B,.-1
+ PUSH P,A
+ HRROM D,(TP) ; SAVE OBLIST
+ JRST RMV3
+
+RMV1: JUMPGE C,TFA
+ CAIE 0,TCHRS
+ CAIN 0,TCHSTR
+ SKIPA A,0
+ JRST WTYP1
+ MOVEI B,-3(TP)
+ PUSHJ P,CSTAK
+RMV3: MOVE B,(TP)
+ MOVSI A,TOBLS
+ PUSHJ P,ILOOK
+ POP P,D
+ HRLI D,(D)
+ SUB P,D
+ JUMPE B,RMVDON
+
+ MOVEI A,(B)
+ CAIGE A,HIBOT ; SKIP IF PURE
+ JRST RMV2
+ PUSH TP,$TATOM
+ PUSH TP,0
+ PUSHJ P,IMPURIFY
+ MOVE 0,(TP)
+ SUB TP,[2,,2]
+ MOVE A,-3(TP)
+ MOVE B,-2(TP)
+ MOVE C,(TP)
+ JRST IRMV1
+
+RMV2: JUMPN 0,RMV9 ; JUMP IF FIRST NOT IN BUCKET
+ HLRZ 0,2(B) ; POINT TO NEXT
+ MOVEM 0,(C)
+ JRST RMV8
+
+RMV9: MOVE C,0 ; C IS PREV ATOM
+ HLRZ 0,2(B) ; NEXT
+ HRLM 0,2(C)
+
+RMV8: SETZM 2(B) ; CLOBBER OBLIST SLOT
+ MOVE C,(TP) ; GET OBLIST FOR SPLICE OUT
+ MOVEI 0,-1
+ HRRZ E,(C)
+
+RMV7: JUMPE E,RMVDON
+ CAMN B,1(E) ; SEARCH OBLIST
+ JRST RMV6
+ MOVE C,E
+ HRRZ E,(C)
+ SOJG 0,RMV7
+
+RMVDON: SUB TP,[4,,4]
+ MOVSI A,TATOM
+ POPJ P,
+
+RMV6: HRRZ E,(E)
+ HRRM E,(C) ; SMASH IN
+ JRST RMVDON
+
+\f
+;INTERNAL CALL FROM THE READER
+
+RLOOKU: PUSH TP,$TFIX ;PUSH A FLAG
+ POP P,C ;POP OFF RET ADR
+ PUSH TP,C ;AND USE AS A FLAG FOR INTERNAL
+ MOVE C,(P) ; CHANGE CHAR COUNT TO WORD
+ ADDI C,4
+ IDIVI C,5
+ MOVEM C,(P)
+ GETYP D,A
+
+ CAIN D,TOBLS ;IS IT ONE OBLIST?
+ JRST .+3
+ CAIE D,TLIST ;IS IT A LIST
+ JRST BADOBL
+
+ JUMPE B,BADLST
+ PUSH TP,$TUVEC ; SLOT FOR REMEBERIG
+ PUSH TP,[0]
+ PUSH TP,$TOBLS
+ PUSH TP,[0]
+ PUSH TP,A
+ PUSH TP,B
+ CAIE D,TLIST
+ JRST RLOOK1
+
+ PUSH TP,$TLIST
+ PUSH TP,B
+RLOOK2: GETYP A,(B) ;CHECK THIS IS AN OBLIST
+ CAIE A,TOBLS
+ JRST DEFALT
+
+ SKIPE -4(TP) ; SKIP IF DEFAULT NOT STORED
+ JRST RLOOK4
+ MOVE D,1(B) ; OBLIST
+ MOVEM D,-4(TP)
+RLOOK4: INTGO
+ HRRZ B,@(TP) ;CDR THE LIST
+ HRRZM B,(TP)
+ JUMPN B,RLOOK2
+ SUB TP,[2,,2]
+ JRST .+3
+
+RLOOK1: MOVE B,(TP)
+ MOVEM B,-2(TP)
+ MOVE A,-1(TP)
+ MOVE B,(TP)
+ PUSHJ P,ILOOK
+ JUMPN B,RLOOK3
+ SKIPN D,-2(TP) ; RESTORE FOR INSERT
+ JRST BADDEF ; NO DEFAULT, USER LOST ON SPECIFICATION
+ SUB TP,[6,,6] ; FLUSH CRAP
+ JRST INSRT1
+
+DEFFLG==1 ;SPECIAL FLAG USED TO INDICATE THAT A DEFAULT HAS ALREADY BEEN
+ ; SPECIFIED
+DEFALT: MOVE 0,1(B)
+ CAIN A,TATOM ;SPECIAL DEFAULT INDICATING ATOM ?
+ CAME 0,MQUOTE DEFAULT
+ JRST BADDEF ;NO, LOSE
+ MOVEI A,DEFFLG
+ XORB A,-11(TP) ;SET AND TEST FLAG
+ TRNN A,DEFFLG ; HAVE WE BEEN HERE BEFORE ?
+ JRST BADDEF ; YES, LOSE
+ SETZM -6(TP) ;ZERO OUT PREVIOUS DEFAULT
+ SETZM -4(TP)
+ JRST RLOOK4 ;CONTINUE
+
+
+INSRT2: JRST .+2 ;
+RLOOK3: SUB TP,[6,,6] ;POP OFF LOSSAGE
+ PUSHJ P,ILINK ;IF THIS IS A LINK FOLLOW IT
+ PUSH P,(TP) ;GET BACK RET ADR
+ SUB TP,[2,,2] ;POP TP
+ JRST IATM1 ;AND RETURN
+
+
+BADOBL: ERRUUO EQUOTE BAD-OBLIST-OR-LIST-THEREOF
+
+BADDEF: ERRUUO EQUOTE BAD-DEFAULT-OBLIST-SPECIFICATION
+
+ONOTH: ERRUUO EQUOTE ATOM-ON-DIFFERENT-OBLIST
+\f;SUBROUTINE TO MAKE AN ATOM
+
+IMFUNCTION ATOM,SUBR
+
+ ENTRY 1
+
+ MOVE A,(AB)
+ MOVE B,1(AB)
+ PUSHJ P,IATOMI
+ JRST FINIS
+
+CATOM: SUBM M,(P)
+ PUSHJ P,IATOMI
+ JRST MPOPJ
+
+IATOMI: GETYP 0,A ;CHECK ARG TYPE
+ CAIE 0,TCHRS
+ CAIN 0,TCHSTR
+ JRST .+2 ;JUMP IF WINNERS
+ JRST WTYP1
+
+ PUSH TP,A
+ PUSH TP,B
+ MOVEI B,-1(TP)
+ MOVE A,0
+ PUSHJ P,CSTAK ;COPY ONTO STACK
+ PUSHJ P,IATOM ;NOW MAKE THE ATOM
+ SUB TP,[2,,2]
+ POPJ P,
+
+;INTERNAL ATOM MAKER
+
+IATOM: MOVE A,-1(P) ;GET WORDS IN PNAME
+ ADDI A,3 ;FOR VALUE CELL
+ PUSHJ P,IBLOCK ; GET BLOCK
+ MOVSI C,<(GENERAL)>+SATOM ;FOR TYPE FIELD
+ MOVE D,-1(P) ;RE-GOBBLE LENGTH
+ ADDI D,3(B) ;POINT TO DOPE WORD
+ MOVEM C,(D)
+ SKIPG -1(P) ;EMPTY PNAME ?
+ JRST IATM0 ;YES, NO CHARACTERS TO MOVE
+ MOVE E,B ;COPY ATOM POINTER
+ ADD E,[3,,3] ;POINT TO PNAME AREA
+ MOVEI C,-1(P)
+ SUB C,-1(P) ;POINT TO STRING ON STACK
+ MOVE D,(C) ;GET SOME CHARS
+ MOVEM D,(E) ;AND COPY THEM
+ ADDI C,1
+ AOBJN E,.-3
+IATM0: MOVSI A,TATOM ;TYPE TO ATOM
+IATM1: POP P,D ;RETURN ADR
+ POP P,C
+ HRLI C,(C)
+ SUB P,C
+ JRST (D) ;RETURN
+
+\f;SUBROUTINE TO GET AN ATOM'S PNAME
+
+MFUNCTION PNAME,SUBR
+
+ ENTRY 1
+
+ GETYP A,(AB)
+ CAIE A,TATOM ;CHECK TYPE IS ATOM
+ JRST WTYP1
+ MOVE A,1(AB)
+ PUSHJ P,IPNAME
+ JRST FINIS
+
+CIPNAM: SUBM M,(P)
+ PUSHJ P,IPNAME
+ JRST MPOPJ
+
+IPNAME: ADD A,[3,,3]
+ HLRE B,A
+ MOVM B,B
+ PUSH P,(A) ;FLUSH PNAME ONTO P
+ AOBJN A,.-1
+ MOVE 0,(P) ; LAST WORD
+ PUSHJ P,PNMCNT
+ PUSH P,B
+ PUSHJ P,CHMAK ;MAKE A STRING
+ POPJ P,
+
+PNMCNT: IMULI B,5 ; CHARS TO B
+ MOVE A,0
+ SUBI A,1 ; FIND LAST 1
+ ANDCM 0,A ; 0 HAS 1ST 1
+ JFFO 0,.+1
+ HRREI 0,-34.(A) ; FIND HOW MUCH TO ADD
+ IDIVI 0,7
+ ADD B,0
+ POPJ P,
+
+MFUNCTION SPNAME,SUBR
+
+ ENTRY 1
+
+ GETYP 0,(AB)
+ CAIE 0,TATOM
+ JRST WTYP1
+
+ MOVE B,1(AB)
+ PUSHJ P,CSPNAM
+ JRST FINIS
+
+CSPNAM: ADD B,[3,,3]
+ MOVEI D,(B)
+ HLRE A,B
+ SUBM B,A
+ MOVE 0,-1(A)
+ HLRES B
+ MOVMS B
+ PUSHJ P,PNMCNT
+ MOVSI A,TCHSTR
+ HRRI A,(B)
+ MOVSI B,010700
+ HRRI B,-1(D)
+ POPJ P,
+
+\f; BLOCK STRUCTURE SUBROUTINES FOR MUDDLE
+
+IMFUNCTION BLK,SUBR,BLOCK
+
+ ENTRY 1
+
+ GETYP A,(AB) ;CHECK TYPE OF ARG
+ CAIE A,TOBLS ;IS IT AN OBLIST
+ CAIN A,TLIST ;OR A LIAT
+ JRST .+2
+ JRST WTYP1
+ MOVSI A,TATOM ;LOOK UP OBLIST
+ MOVE B,IMQUOTE OBLIST
+ PUSHJ P,IDVAL ;GET VALUE
+ PUSH TP,A
+ PUSH TP,B
+ MOVE PVP,PVSTOR+1
+ PUSH TP,.BLOCK(PVP) ;HACK THE LIST
+ PUSH TP,.BLOCK+1(PVP)
+ MCALL 2,CONS ;CONS THE LIST
+ MOVE PVP,PVSTOR+1
+ MOVEM A,.BLOCK(PVP) ;STORE IT BACK
+ MOVEM B,.BLOCK+1(PVP)
+ PUSH TP,$TATOM
+ PUSH TP,IMQUOTE OBLIST
+ PUSH TP,(AB)
+ PUSH TP,1(AB)
+ MCALL 2,SET ;SET OBLIST TO ARG
+ JRST FINIS
+
+MFUNCTION ENDBLOCK,SUBR
+
+ ENTRY 0
+
+ MOVE PVP,PVSTOR+1
+ SKIPN B,.BLOCK+1(PVP) ;IS THE LIST NIL?
+ JRST BLKERR ;YES, LOSE
+ HRRZ C,(B) ;CDR THE LIST
+ HRRZM C,.BLOCK+1(PVP)
+ PUSH TP,$TATOM ;NOW RESET OBLIST
+ PUSH TP,IMQUOTE OBLIST
+ HLLZ A,(B) ;PUSH THE TYPE OF THE CAR
+ PUSH TP,A
+ PUSH TP,1(B) ;AND VALUE OF CAR
+ MCALL 2,SET
+ JRST FINIS
+
+BLKERR: ERRUUO EQUOTE UNMATCHED
+
+BADLST: ERRUUO EQUOTE NIL-LIST-OF-OBLISTS
+\f;SUBROUTINE TO CREATE CHARACTER STRING GOODIE
+
+CHMAK: MOVE A,-1(P)
+ ADDI A,4
+ IDIVI A,5
+ PUSHJ P,IBLOCK
+ MOVEI C,-1(P) ;FIND START OF CHARS
+ HLRE E,B ; - LENGTH
+ ADD C,E ;C POINTS TO START
+ MOVE D,B ;COPY VECTOR RESULT
+ JUMPGE D,NULLST ;JUMP IF EMPTY
+ MOVE A,(C) ;GET ONE
+ MOVEM A,(D)
+ ADDI C,1 ;BUMP POINTER
+ AOBJN D,.-3 ;COPY
+NULLST: MOVSI C,TCHRS+.VECT. ;GET TYPE
+ MOVEM C,(D) ;CLOBBER IT IN
+ MOVE A,-1(P) ; # WORDS
+ HRLI A,TCHSTR
+ HRLI B,010700
+ MOVMM E,-1(P) ; SO IATM1 WORKS
+ SOJA B,IATM1 ;RETURN
+
+; SUBROUTINE TO READ FIVE CHARS FROM STRING.
+; TWO CALLS, ONE WITH A POINTING TO LIST ELEMENT,
+; THE OTHER WITH B POINTING TO PAIR. SKIPS IF WINNER, ELSE DOESNT
+
+NXTDCL: GETYP B,(A) ;CHECK TYPE
+ CAIE B,TDEFER ;LOSE IF NOT DEFERRED
+ POPJ P,
+
+ MOVE B,1(A) ;GET REAL BYTE POINTER
+CHRWRD: PUSH P,C
+ GETYP C,(B) ;CHECK IT IS CHSTR
+ CAIE C,TCHSTR
+ JRST CPOPJC ;NO, QUIT
+ PUSH P,D
+ PUSH P,E
+ PUSH P,0
+ MOVEI E,0 ;INITIALIZE DESTINATION
+ HRRZ C,(B) ; GET CHAR COUNT
+ JUMPE C,GOTDCL ; NULL, FINISHED
+ MOVE B,1(B) ;GET BYTE POINTER
+ MOVE D,[440700,,E] ;BYTE POINT TO E
+CHLOOP: ILDB 0,B ; GET A CHR
+ IDPB 0,D ;CLOBBER AWAY
+ SOJE C,GOTDCL ; JUMP IF DONE
+ TLNE D,760000 ; SKIP IF WORD FULL
+ JRST CHLOOP ; MORE THAN 5 CHARS
+ TRO E,1 ; TURN ON FLAG
+
+GOTDCL: MOVE B,E ;RESULT TO B
+ AOS -4(P) ;SKIP RETURN
+CPOPJ0: POP P,0
+ POP P,E
+ POP P,D
+CPOPJC: POP P,C
+ POPJ P,
+
+\f;ROUTINES TO DEFINE AND HANDLE LINKS
+
+MFUNCTION LINK,SUBR
+ ENTRY
+ CAML AB,[-6,,0] ;NO MORE THAN 3 ARGS
+ CAML AB,[-2,,0] ;NO LESS THAN 2 ARGS
+ JRST WNA
+ CAML AB,[-4,,0] ;ONLY TWO ARGS SUPPLIED ?
+ JRST GETOB ;YES, GET OBLIST FROM CURRENT PATH
+ MOVE A,2(AB)
+ MOVE B,3(AB)
+ MOVE C,5(AB)
+ JRST LINKIN
+GETOB: MOVSI A,TATOM
+ MOVE B,IMQUOTE OBLIST
+ PUSHJ P,IDVAL
+ CAMN A,$TOBLS
+ JRST LINKP
+ CAME A,$TLIST
+ JRST BADOBL
+ JUMPE B,BADLST
+ GETYPF A,(B)
+ MOVE B,(B)+1
+LINKP: MOVE C,B
+ MOVE A,2(AB)
+ MOVE B,3(AB)
+LINKIN: PUSHJ P,IINSRT
+ CAMN A,$TFALSE ;LINK NAME ALREADY USED ?
+ JRST ALRDY ;YES, LOSE
+ MOVE C,B
+ MOVE A,(AB)
+ MOVE B,1(AB)
+ PUSHJ P,CSETG
+ JRST FINIS
+
+
+ILINK: HLRE A,B
+ SUBM B,A ;FOUND A LINK ?
+ MOVE A,(A)
+ TRNE A,LNKBIT
+ JRST .+3
+ MOVSI A,TATOM
+ POPJ P, ;NO, FINISHED
+ MOVSI A,TATOM
+ PUSHJ P,IGVAL ;GET THE LINK'S DESTINATION
+ CAME A,$TUNBOUND ;WELL FORMED LINK ?
+ POPJ P, ;YES
+ ERRUUO EQUOTE BAD-LINK
+
+\f
+; THIS SUBROUTINE IMPURIFIES A PURE ATOM TO ALLOW MODIFICATION OF SYSTEM SUBRS
+
+IMPURIFY:
+ PUSH TP,$TATOM
+ PUSH TP,B
+ MOVE C,B
+ MOVEI 0,(C)
+ CAIGE 0,HIBOT
+ JRST RTNATM ; NOT PURE, RETURN
+ JRST IMPURX
+
+; ROUTINE PASSED TO GCHACK
+
+ATFIX: CAME D,(TP)
+ CAMN D,-2(TP)
+ JRST .+2
+ POPJ P,
+
+ ASH C,1
+ ADD C,TYPVEC+1 ; COMPUTE SAT
+ HRRZ C,(C)
+ ANDI C,SATMSK
+ CAIE C,SATOM
+CPOPJ: POPJ P,
+
+ SUB D,-2(TP)
+ ADD D,-4(TP)
+ SKIPE B
+ MOVEM D,1(B)
+ POPJ P,
+
+
+; SUBROUTINE TO FIND A BYTE STRINGS DOPE WORD
+; RECEIVES POINTER TO PAIR CONNTAINIGN CHSTR IN C, RETURNS DOPE WORD IN A
+
+BYTDOP: PUSH P,B ; SAVE SOME ACS
+ PUSH P,D
+ PUSH P,E
+ MOVE B,1(C) ; GET BYTE POINTER
+ LDB D,[360600,,B] ; POSITION TO D
+ LDB E,[300600,,B] ; AND BYTE SIZE
+ MOVEI A,(E) ; A COPY IN A
+ IDIVI D,(E) ; D=> # OF BYTES IN WORD 1
+ HRRZ E,(C) ; GET LENGTH
+ SUBM E,D ; # OF BYTES IN OTHER WORDS
+ JUMPL D,BYTDO1 ; NEAR DOPE WORD
+ MOVEI B,36. ; COMPUTE BYTES PER WORD
+ IDIVM B,A
+ ADDI D,-1(A) ; NOW COMPUTE WORDS
+ IDIVI D,(A) ; D/ # NO. OF WORDS PAST 1ST
+ ADD D,1(C) ; D POINTS TO DOPE WORD
+ MOVEI A,2(D)
+
+BYTDO2: POP P,E
+ POP P,D
+ POP P,B
+ POPJ P,
+BYTDO1: MOVEI A,2(B)
+ JRST BYTDO2
+
+; 1) IMPURIFY ITS OBLIST LIST
+
+IMPURX: HRRZ B,2(C) ; PICKUP OBLIST IF IT EXISTS
+ JUMPE B,IMPUR0 ; NOT ON ONE, IGNORE THIS CODE
+
+ HRRO E,(B)
+ PUSH TP,$TOBLS ; SAVE BUCKET
+ PUSH TP,E
+
+ MOVE B,(E) ; GET NEXT ONE
+IMPUR4: MOVEI 0,(B)
+ MOVE D,1(B)
+ CAME D,-2(TP)
+ JRST .+3
+ SKIPE GPURFL ; IF PURIFY SMASH THE OBLIST SLOT TO PROTECT
+ ; ATOM
+ HRRM D,1(B)
+ CAIGE 0,HIBOT ; SKIP IF PURE
+ JRST IMPUR3 ; FOUND IMPURE NESS, SKIP IT
+ HLLZ C,(B) ; SET UP ICONS CALL
+ HRRZ E,(B)
+IMPR1: PUSHJ P,ICONS ; CONS IT UP
+IMPR2: HRRZ E,(TP) ; RETRV PREV
+ HRRM B,(E) ; AND CLOBBER
+IMPUR3: MOVE D,1(B)
+ CAMN D,-2(TP) ; HAVE GOTTEN TO OUR SLOT?
+ JRST IMPPR3
+ MOVSI 0,TLIST
+ MOVEM 0,-1(TP) ; FIX TYPE
+ HRRZM B,(TP) ; STORE GOODIE
+ HRRZ B,(B) ; CDR IT
+ JUMPN B,IMPUR4 ; LOOP
+IMPPR3: SUB TP,[2,,2] ; FLUSH TP CRUFT
+
+; 1.5) IMPURIFY GLOBAL HASH BUCKET, A REAL PAIN
+
+IMPUR0: MOVE C,(TP) ; GET ATOM
+
+ HRRZ B,2(C)
+ MOVE B,(B)
+ ADD C,[3,,3] ; POINT TO PNAME
+ HLRE A,C ; GET LNTH IN WORDS OF PNAME
+ MOVNS A
+ PUSH P,[IMPUR2] ; FAKE OUT ILOOKC
+ PUSH P,(C) ; PUSH UP THE PNAME
+ AOBJN C,.-1
+ PUSH P,A ; NOW THE COUNT
+ MOVSI A,TOBLS
+ JRST ILOOKC ; GO FIND BUCKET
+
+IMPUR2: JUMPE B,IMPUR1
+ JUMPE 0,IMPUR1 ; YUP, DONE
+ HRRZ C,0
+ CAIG C,HIBOT ; SKIP IF PREV IS PURE
+ JRST IMPUR1
+
+ MOVE B,0
+ PUSH P,GPURFL ; PRERTEND OUT OF PURIFY
+ SETZM GPURFL
+ PUSHJ P,IMPURIF ; RECURSE
+ POP P,GPURFL
+ MOVE B,(TP) ; AND RETURN ORIGINAL
+
+; 2) GENERATE A DUPLICATE ATOM
+
+IMPUR1: SKIPE GPURFL ; SEE IF IN PURIFY
+ JRST IMPUR7
+ HLRE A,(TP) ; GET LNTH OF ATOM
+ MOVNS A
+ PUSH P,A
+ PUSHJ P,IBLOCK ; GET NEW BLOCK FOR ATOM
+ PUSH TP,$TATOM
+ PUSH TP,B
+ HRL B,-2(TP) ; SETUP BLT
+ POP P,A
+ ADDI A,(B) ; END OF BLT
+ BLT B,(A) ; CLOBBER NEW ATOM
+ MOVSI B,.VECT. ; TURN ON BIT FOR GCHACK
+ IORM B,(A)
+
+; 3) NOW COPY GLOBAL VALUE
+
+IMPUR7: MOVE B,(TP) ; ATOM BACK
+ GETYP 0,(B)
+ SKIPE A,1(B) ; NON-ZER POINTER?
+ CAIN 0,TUNBOU ; BOUND?
+ JRST IMPUR5 ; NO, DONT COPY GLOB VAL
+ PUSH TP,(A)
+ PUSH TP,1(A)
+ PUSH TP,$TATOM
+ PUSH TP,B
+ SETZM (B)
+ SETZM 1(B)
+ SKIPN GPURFL ; HERE IS SOME CODE NEEDED FOR PURIFY
+ JRST IMPUR8
+ PUSH P,LPVP
+ MOVE PVP,PVSTOR+1
+ PUSH P,AB ; GET AB BACK
+ MOVE AB,ABSTO+1(PVP)
+IMPUR8: PUSHJ P,BSETG ; SETG IT
+ SKIPN GPURFL
+ JRST .+3 ; RESTORE SP AND AB FOR PURIFY
+ POP P,TYPNT
+ POP P,SP
+ SUB TP,[2,,2] ; KILL ATOM SLOTS ON TP
+ POP TP,C ;POP OFF VALUE SLOTS
+ POP TP,A
+ MOVEM A,(B) ; FILL IN SLOTS ON GLOBAL STACK
+ MOVEM C,1(B)
+IMPUR5: SKIPE GPURFL ; FINISH OFF DIFFERENTLY FOR PURIFY
+ JRST IMPUR9
+
+ PUSH TP,$TFIX ;SAVE OLD ATOM WITH FUNNY TYPE TO AVOID LOSSAGE
+ PUSH TP,-3(TP)
+ PUSH TP,$TFIX ; OTHER KIND OF POINTER ALSO
+ HLRE 0,-1(TP)
+ HRRZ A,-1(TP)
+ SUB A,0
+ PUSH TP,A
+
+; 4) UPDATE ALL POINTERS TO THIS ATOM
+
+ MOVE A,[PUSHJ P,ATFIX] ; INS TO PASS TO GCHACK
+ MOVEI PVP,1 ; SAY MIGHT BE NON-ATOMS
+ PUSHJ P,GCHACK
+ SUB TP,[6,,6]
+
+RTNATM: POP TP,B
+ POP TP,A
+ POPJ P,
+
+IMPUR9: SUB TP,[2,,2]
+ POPJ P, ; RESTORE AND GO
+
+
+
+END
--- /dev/null
+
+TITLE ATOMHACKER FOR MUDDLE
+
+RELOCATABLE
+
+.INSRT MUDDLE >
+.GLOBAL RLOOKU,CHMAK,OBLNT,ROOT,INTOBL,ERROBL,IFALSE,PVSTOR,SPSTOR
+.GLOBAL .BLOCK,IDVAL,NXTDCL,CHRWRD,CSTACK,CSTAK,ILOOKC,IGVAL,BYTDOP,HASHTB
+.GLOBAL ICONS,INCONS,IBLOCK,INSRTX,GCHACK,IMPURIFY,BSETG,TYPVEC,IGET,IPUT
+.GLOBAL CINSER,CIRMV,CLOOKU,CATOM,CIPNAM,MPOPJ,CSETG,CSPNAM,GPURFL,IMPURX
+
+LPVP==SP
+TYPNT==AB
+LNKBIT==200000
+
+; FUNCTION TO GENERATE AN EMPTY OBLIST
+
+MFUNCTION MOBLIST,SUBR
+
+ ENTRY
+ CAMGE AB,[-5,,0] ;CHECK NUMBER OF ARGS
+ JRST TMA
+ JUMPGE AB,MOBL2 ; NO ARGS
+ MOVE A,(AB)
+ MOVE B,1(AB)
+ MOVSI C,TATOM
+ MOVE D,IMQUOTE OBLIST
+ PUSHJ P,IGET ; CHECK IF IT EXISTS ALREADY
+ CAMN A,$TOBLS
+ JRST FINIS
+MOBL2:
+ MOVEI A,1
+ PUSHJ P,IBLOCK ;GET A UNIFORM VECTOR
+ MOVSI C,TLIST+.VECT. ;IT IS OF TYPE LIST
+ HLRE D,B ;-LENGTH TO D
+ SUBM B,D ;D POINTS TO DOPE WORD
+ MOVEM C,(D) ;CLOBBER TYPE IN
+ MOVSI A,TOBLS
+ JUMPGE AB,FINIS ; IF NO ARGS, DONE
+ GETYP A,(AB)
+ CAIE A,TATOM
+ JRST WTYP1
+ MOVSI A,TOBLS
+ PUSH TP,$TOBLS
+ PUSH TP,B
+ MOVSI C,TATOM
+ MOVE D,IMQUOTE OBLIST
+ PUSH TP,(AB)
+ PUSH TP,1(AB)
+ PUSHJ P,IPUT ; PUT THE NAME ON THE OBLIST
+ MOVE A,(AB)
+ MOVE B,1(AB)
+ MOVSI C,TATOM
+ MOVE D,IMQUOTE OBLIST
+ PUSH TP,(TB)
+ PUSH TP,1(TB)
+ PUSHJ P,IPUT ; PUT THE OBLIST ON THE NAME
+
+ POP TP,B
+ POP TP,A
+ JRST FINIS
+
+MFUNCTION GROOT,SUBR,ROOT
+ ENTRY 0
+ MOVE A,ROOT
+ MOVE B,ROOT+1
+ JRST FINIS
+
+MFUNCTION GINTS,SUBR,INTERRUPTS
+ ENTRY 0
+ MOVE A,INTOBL
+ MOVE B,INTOBL+1
+ JRST FINIS
+
+MFUNCTION GERRS,SUBR,ERRORS
+ ENTRY 0
+ MOVE A,ERROBL
+ MOVE B,ERROBL+1
+ JRST FINIS
+
+
+COBLQ: SKIPN B,2(B) ; SKIP IF EXISTS
+ JRST IFLS
+ MOVSI A,TOBLS
+
+ ANDI B,-1
+ CAMG B,VECBOT ; TVP IS IN FROZEN SPACE, NEVER OBLISTS
+ MOVE B,(B)
+ HRLI B,-1
+
+CPOPJ1: AOS (P)
+ POPJ P,
+
+IFLS: MOVEI B,0
+ MOVSI A,TFALSE
+ POPJ P,
+
+MFUNCTION OBLQ,SUBR,[OBLIST?]
+
+ ENTRY 1
+ GETYP A,(AB)
+ CAIE A,TATOM
+ JRST WTYP1
+ MOVE B,1(AB) ; GET ATOM
+ PUSHJ P,COBLQ
+ JFCL
+ JRST FINIS
+
+\f; FUNCTION TO FIND AN ATOM ON A GIVEN OBLIST WITH A GIVEN PNAME
+
+MFUNCTION LOOKUP,SUBR
+
+ ENTRY 2
+ PUSHJ P,ILOOKU ;CALL INTERNAL ROUTINE
+ JRST FINIS
+
+CLOOKU: SUBM M,(P)
+ PUSH TP,A
+ PUSH TP,B
+ MOVEI B,-1(TP)
+ PUSH TP,$TOBLS
+ PUSH TP,C
+ GETYP A,A
+ PUSHJ P,CSTAK
+ MOVE B,(TP)
+ MOVSI A,TOBLS ; THIS IS AN OBLIST
+ PUSHJ P,ILOOK
+ POP P,D
+ HRLI D,(D)
+ SUB P,D
+ SKIPE B
+ SOS (P)
+ SUB TP,[4,,4]
+ JRST MPOPJ
+
+ILOOKU: PUSHJ P,ARGCHK ;CHECK ARGS
+ PUSHJ P,CSTACK ;PUT CHARACTERS ON THE STACK
+
+CALLIT: MOVE B,3(AB) ;GET OBLIST
+ MOVSI A,TOBLS
+ILOOKC: PUSHJ P,ILOOK ;LOOK IT UP
+ POP P,D ;RESTORE COUNT
+ HRLI D,(D) ;TO BOTH SIDES
+ SUB P,D
+ POPJ P,
+
+;THIS ROUTINE CHECKS ARG TYPES
+
+ARGCHK: GETYP A,(AB) ;GET TYPES
+ GETYP C,2(AB)
+ CAIE A,TCHRS ;IS IT EITHER CHAR STRING
+ CAIN A,TCHSTR
+ CAIE C,TOBLS ;IS 2ND AN OBLIST
+ JRST WRONGT ;TYPES ARE WRONG
+ POPJ P,
+
+;THIS SUBROUTINE PUTS CHARACTERS ON THE STACK (P WILL BE CHANGED)
+
+
+CSTACK: MOVEI B,(AB)
+CSTAK: POP P,D ;RETURN ADDRESS TO D
+ CAIE A,TCHRS ;IMMEDIATE?
+ JRST NOTIMM ;NO, HAIR
+ MOVE A,1(B) ; GET CHAR
+ LSH A,29. ; POSITION
+ PUSH P,A ;ONTO P
+ PUSH P,[1] ;WITH NUMBER
+ JRST (D) ;GO CALL SEARCHER
+
+NOTIMM: MOVEI A,1 ; CLEAR CHAR COUNT
+ MOVE C,(B) ; GET COUNT OF CHARS
+ TRNN C,-1
+ JRST NULST ; FLUSH NULL STRING
+ MOVE PVP,PVSTOR+1
+ MOVEM C,BSTO(PVP)
+ ANDI C,-1
+ MOVE B,1(B) ;GET BYTE POINTER
+
+CLOOP1: PUSH P,[0] ; STORE CHARS ON STACK
+ MOVSI E,(<440700,,(P)>) ; SETUP BYTE POINTER
+CLOOP: SKIPL INTFLG ; SO CAN WIN WITH INTERRUPTS
+ JRST CLOOP2
+ MOVE PVP,PVSTOR+1
+ HRRM C,BSTO(PVP) ;SAVE STRING LENGTH
+ JSR LCKINT
+CLOOP2: ILDB 0,B ;GET A CHARACTER
+ IDPB 0,E ;STORE IT
+ SOJE C,CDONE ; ANY MORE?
+ TLNE E,760000 ; WORD FULL
+ JRST CLOOP ;NO CONTINUE
+ AOJA A,CLOOP1 ;AND CONTINUE
+
+CDONE:
+CDONE1: MOVE PVP,PVSTOR+1
+ SETZM BSTO(PVP)
+ PUSH P,A ;AND NUMBER OF WORDS
+ JRST (D) ;RETURN
+
+
+NULST: ERRUUO EQUOTE NULL-STRING
+\f; THIS FUNCTION LOOKS FOR ATOMS. CALLED BY PUSHJ P,ILOOK
+; A,B/ OBLIST POINTER (CAN BE LIST OF SAME)
+; -1(P)/ LENGTH IN WORDS OF CHARACTER BLOCK
+; CHAR STRING IS ON THE STACK
+; IF ATOM EXISTS RETURNS:
+; B/ THE ATOM
+; C/ THE BUCKET
+; 0/ THE PREVIOUS BUCKET
+;
+; IF NOT
+; B/ 0
+; 0/ PREV IF ONE WITH SAME PNAME, ELSE 0
+; C/ BUCKET
+
+ILOOK: PUSH TP,A
+ PUSH TP,B
+
+ MOVN A,-1(P) ;GET -LENGTH
+ HRLI A,-1(A) ;<-LENGTH-1>,,-LENGTH
+ PUSH TP,$TFIX ;SAVE
+ PUSH TP,A
+ ADDI A,-1(P) ;HAVE AOBJN POINTER TO CHARS
+ MOVE 0,[202622077324] ;HASH WORD
+ ROT 0,1
+ TSC 0,(A)
+ AOBJN A,.-2 ;XOR THEM ALL TOGETHER
+ HLRE A,HASHTB+1
+ MOVNS A
+ MOVMS 0 ; MAKE SURE + HASH CODE
+ IDIVI 0,(A) ;DIVIDE
+ HRLI A,(A) ;TO BOTH HALVES
+ ADD A,HASHTB+1
+
+ MOVE C,A
+ HRRZ A,(A) ; POINT TO FIRST ATOM
+ SETZB E,0 ; INDICATE NO ATOM
+
+ JUMPE A,NOTFND
+LOOK2: HLRZ E,1(A) ; PREPARE TO BUILD AOBJN
+ ANDI E,377777 ; SIGN MIGHT BE ON IF IN PURIFY ETC.
+ SUBI E,2
+ HRLS E
+ SUBB A,E
+
+ ADD A,[3,,3] ;POINT TO ATOMS PNAME
+ MOVE D,(TP) ;GET PSEUDO AOBJN POINTER TO CHARS
+ ADDI D,-1(P) ;NOW ITS A REAL AOBJN POINTER
+ JUMPE D,CHECK0 ;ONE IS EMPTY
+LOOK1:
+ MOVE SP,(D)
+ CAME SP,(A)
+
+ JRST NEXT1 ;THIS ONE DOESN'T MATCH
+ AOBJP D,CHECK ;ONE RAN OUT
+ AOBJN A,LOOK1 ;JUMP IF STILL MIGHT WIN
+
+NEXT1: HRRZ A,-1(TP) ; SEE IF WE'VE ALREADY SEEN THIS NAME
+ GETYP D,-3(TP) ; SEE IF LIST OF OBLISTS
+ CAIN D,TLIST
+ JUMPN A,CHECK3 ; DON'T LOOK FURTHER
+ JUMPN A,NOTFND
+NEXT:
+ MOVE 0,E
+ HLRZ A,2(E) ; NEXT ATOM
+ JUMPN A,LOOK2
+ HRRZ A,-1(TP)
+ JUMPN A,NEXT1
+
+ SETZB E,0
+
+NOTFND:
+ MOVEI B,0
+ MOVSI A,TFALSE
+CPOPJT:
+
+ SUB TP,[4,,4]
+ POPJ P,
+
+CHECK0: JUMPN A,NEXT1 ;JUMP IF NOT ALSO EMPTY
+ SKIPA
+CHECK: AOBJN A,NEXT1 ;JUMP IF NO MATCH
+
+CHECK5: HRRZ A,-1(TP) ; SEE IF FIRST SHOT AT THIS GUY?
+ SKIPN A
+ MOVE B,0 ; REMEMBER ATOM FOR FALL BACK
+ HLLOS -1(TP) ; INDICATE NAME MATCH HAS OCCURRED
+ HRRZ A,2(E) ; COMPUTE OBLIST POINTER
+ CAMGE A,VECBOT
+ MOVE A,(A)
+ HRROS A
+ GETYP D,-3(TP) ; SEE IF LIST OF OBLISTS OR
+ CAIE D,TOBLS
+ JRST CHECK1
+ CAME A,-2(TP) ; DO OBLISTS MATCH?
+ JRST NEXT
+
+CHECK2: MOVE B,E ; RETURN ATOM
+ MOVSI A,TATOM
+ JRST CPOPJT
+
+CHECK1: MOVE D,-2(TP) ; ANY LEFT?
+ CAMN A,1(D) ; MATCH
+ JRST CHECK2
+ JRST NEXT
+
+CHECK3: MOVE D,-2(TP)
+ HRRZ D,(D)
+ MOVEM D,-2(TP)
+ JUMPE D,NOTFND
+ JUMPE B,CHECK6
+ HLRZ E,2(B)
+CHECK7: HLRZ A,1(E)
+ ANDI A,377777 ; SIGN MIGHT BE ON IF IN PURIFY ETC.
+ SUBI A,2
+ HRLS A
+ SUBB E,A
+ JRST CHECK5
+
+CHECK6: HRRZ E,(C)
+ JRST CHECK7
+
+\f; FUNCTION TO INSERT AN ATOM ON AN OBLIST
+
+MFUNCTION INSERT,SUBR
+
+ ENTRY 2
+ GETYP A,2(AB)
+ CAIE A,TOBLS
+ JRST WTYP2
+ MOVE A,(AB)
+ MOVE B,1(AB)
+ MOVE C,3(AB)
+ PUSHJ P,IINSRT
+ JRST FINIS
+
+CINSER: SUBM M,(P)
+ PUSHJ P,IINSRT
+ JRST MPOPJ
+
+IINSRT: PUSH TP,A
+ PUSH TP,B
+ PUSH TP,$TOBLS
+ PUSH TP,C
+ GETYP A,A
+ CAIN A,TATOM
+ JRST INSRT0
+
+;INSERT WITH A GIVEN PNAME
+
+ CAIE A,TCHRS
+ CAIN A,TCHSTR
+ JRST .+2
+ JRST WTYP1
+
+ PUSH TP,$TFIX ;FLAG CALL
+ PUSH TP,[0]
+ MOVEI B,-5(TP)
+ PUSHJ P,CSTAK ;COPY ONTO STACK
+ MOVE B,-2(TP)
+ MOVSI A,TOBLS
+ PUSHJ P,ILOOK ;LOOK IT UP (BUCKET RETURNS IN C)
+ SETZM -4(TP)
+ SETZM -5(TP) ; KILL STRING POINTER TO KEEP FROM CONFUSING GC
+ JUMPN B,ALRDY ;EXISTS, LOSE
+ MOVE D,-2(TP) ; GET OBLIST BACK
+INSRT1: PUSH TP,$TATOM
+ PUSH TP,0 ; PREV ATOM
+ PUSH TP,$TUVEC ;SAVE BUCKET POINTER
+ PUSH TP,C
+ PUSH TP,$TOBLS
+ PUSH TP,D ; SAVE OBLIST
+INSRT3: PUSHJ P,IATOM ; MAKE AN ATOM
+ HLRE A,B ; FIND DOPE WORD
+ SUBM B,A
+ ANDI A,-1
+ SKIPN E,-4(TP) ; AFTER AN ATOM?
+ JRST INSRT7 ; NO, FIRST IN BUCKET
+ MOVEI 0,(E) ; CHECK IF PURE
+ CAIG 0,HIBOT
+ JRST INSRNP
+ PUSH TP,$TATOM ; SAVE NEW ATOM
+ PUSH TP,B
+ MOVE B,E
+ PUSHJ P,IMPURIF
+ MOVE B,(TP)
+ MOVE E,-6(TP)
+ SUB TP,[2,,2]
+ HLRE A,B ; FIND DOPE WORD
+ SUBM B,A
+ ANDI A,-1
+
+INSRNP: HLRZ 0,2(E) ; NEXT
+ HRLM A,2(E) ; SPLICE
+ HRLM 0,2(B)
+ JRST INSRT8
+
+INSRT7: MOVE E,-2(TP)
+ EXCH A,(E)
+ HRLM A,2(B) ; IN CASE OLD ONE
+
+INSRT8: MOVE E,(TP) ; GET OBLIST
+ HRRM E,2(B) ; STORE OBLIST
+ MOVE E,(E) ; POINT TO LIST OF ATOMS
+ PUSHJ P,LINKCK
+ PUSHJ P,ICONS
+ MOVE E,(TP)
+ HRRM B,(E) ;INTO NEW BUCKET
+ MOVSI A,TATOM
+ MOVE B,1(B) ;GET ATOM BACK
+ MOVE C,-6(TP) ;GET FLAG
+ SUB TP,[8,,8] ;POP STACK
+ JUMPN C,(C)
+ SUB TP,[4,,4]
+ POPJ P,
+
+;INSERT WITH GIVEN ATOM
+INSRT0: MOVE A,-2(TP) ;GOBBLE PNAME
+ SKIPE 2(A) ; SKIP IF NOT ON AN OBLIST
+ JRST ONOBL
+ ADD A,[3,,3]
+ HLRE C,A
+ MOVNS C
+ PUSH P,(A) ;FLUSH PNAME ONTO P STACK
+ AOBJN A,.-1
+ PUSH P,C
+ MOVE B,(TP) ; GET OBLIST FOR LOOKUP
+ MOVSI A,TOBLS
+ PUSHJ P,ILOOK ;ALREADY THERE?
+ JUMPN B,ALRDY
+ MOVE D,-2(TP)
+
+ HLRE A,-2(TP) ; FIND DOPE WORD
+ SUBM D,A ; TO A
+ JUMPE 0,INSRT9 ; NO CURRENT ATOM
+ MOVE E,0
+ MOVEI 0,(E)
+ CAIGE 0,HIBOT ; PURE?
+ JRST INSRPN
+ PUSH TP,$TATOM
+ PUSH TP,E
+ PUSH TP,$TATOM
+ PUSH TP,D
+ MOVE B,E
+ PUSHJ P,IMPURIF
+ MOVE D,(TP)
+ MOVE E,-2(TP)
+ SUB TP,[4,,4]
+ HLRE A,D
+ SUBM D,A
+
+
+INSRPN: HLRZ 0,2(E) ; POINT TO NEXT
+ HRLM A,2(E) ; CLOBBER NEW GUY IN
+ HRLM 0,2(D) ; FINISH SLPICE
+ JRST INSRT6
+
+INSRT9: ANDI A,-1
+ EXCH A,(C) ; INTO BUCKET
+ HRLM A,2(D)
+
+INSRT6: HRRZ E,(TP)
+ HRRZ E,(E)
+ MOVE B,D
+ PUSHJ P,LINKCK
+ PUSHJ P,ICONS
+ MOVE C,(TP) ;RESTORE OBLIST
+ HRRZM B,(C)
+ MOVE B,-2(TP) ; GET BACK ATOM
+ HRRM C,2(B) ; CLOBBER OBLIST IN
+ MOVSI A,TATOM
+ SUB TP,[4,,4]
+ POP P,C
+ HRLI C,(C)
+ SUB P,C
+ POPJ P,
+
+LINKCK: HRRZ C,FSAV(TB) ;CALLER'S NAME
+ MOVE D,B
+ CAIE C,LINK
+ SKIPA C,$TATOM ;LET US INSERT A LINK INSTEAD OF AN ATOM
+ SKIPA C,$TLINK ;GET REAL ATOM FOR CALL TO ICONS
+ POPJ P,
+ HLRE A,D
+ SUBM D,A
+ MOVEI B,LNKBIT
+ IORM B,(A)
+ POPJ P,
+
+
+ALRDY: ERRUUO EQUOTE ATOM-ALREADY-THERE
+
+ONOBL: ERRUUO EQUOTE ON-AN-OBLIST-ALREADY
+
+; INTERNAL INSERT CALL
+
+INSRTX: POP P,0 ; GET RET ADDR
+ PUSH TP,$TFIX
+ PUSH TP,0
+ PUSH TP,$TATOM
+ PUSH TP,[0]
+ PUSH TP,$TUVEC
+ PUSH TP,[0]
+ PUSH TP,$TOBLS
+ PUSH TP,B
+ MOVSI A,TOBLS
+ PUSHJ P,ILOOK
+ JUMPN B,INSRXT
+ MOVEM 0,-4(TP)
+ MOVEM C,-2(TP)
+ JRST INSRT3 ; INTO INSERT CODE
+
+INSRXT: PUSH P,-4(TP)
+ SUB TP,[6,,6]
+ POPJ P,
+ JRST IATM1
+\f
+; FUNCTION TO REMOVE AN ATOM FROM AN OBLIST
+
+MFUNCTION REMOVE,SUBR
+
+ ENTRY
+
+ JUMPGE AB,TFA
+ CAMGE AB,[-5,,]
+ JRST TMA
+ MOVEI C,0
+ CAML AB,[-3,,] ; SKIP IF OBLIST GIVEN
+ JRST .+5
+ GETYP 0,2(AB)
+ CAIE 0,TOBLS
+ JRST WTYP2
+ MOVE C,3(AB)
+ MOVE A,(AB)
+ MOVE B,1(AB)
+ PUSHJ P,IRMV
+ JRST FINIS
+
+CIRMV: SUBM M,(P)
+ PUSHJ P,IRMV
+ JRST MPOPJ
+
+IRMV: PUSH TP,A
+ PUSH TP,B
+ PUSH TP,$TOBLS
+ PUSH TP,C
+IRMV1: GETYP 0,A ; CHECK 1ST ARG
+ CAIN 0,TLINK
+ JRST .+3
+ CAIE 0,TATOM ; ATOM, TREAT ACCORDINGLY
+ JRST RMV1
+
+ HRRZ D,2(B) ; SKIP IF ON OBLIST AND GET SAME
+ JUMPE D,RMVDON
+ CAMG D,VECBOT ; SKIP IF REAL OBLIST
+ HRRZ D,(D) ; NO, REF, GET IT
+
+ JUMPGE C,GOTOBL
+ CAIE D,(C) ; BETTER BE THE SAME
+ JRST ONOTH
+
+GOTOBL: ADD B,[3,,3] ; POINT TO PNAME
+ HLRE A,B
+ MOVNS A
+ PUSH P,(B) ; PUSH PNAME
+ AOBJN B,.-1
+ PUSH P,A
+ HRROM D,(TP) ; SAVE OBLIST
+ JRST RMV3
+
+RMV1: JUMPGE C,TFA
+ CAIE 0,TCHRS
+ CAIN 0,TCHSTR
+ SKIPA A,0
+ JRST WTYP1
+ MOVEI B,-3(TP)
+ PUSHJ P,CSTAK
+RMV3: MOVE B,(TP)
+ MOVSI A,TOBLS
+ PUSHJ P,ILOOK
+ POP P,D
+ HRLI D,(D)
+ SUB P,D
+ JUMPE B,RMVDON
+
+ MOVEI A,(B)
+ CAIGE A,HIBOT ; SKIP IF PURE
+ JRST RMV2
+ PUSH TP,$TATOM
+ PUSH TP,0
+ PUSHJ P,IMPURIFY
+ MOVE 0,(TP)
+ SUB TP,[2,,2]
+ MOVE A,-3(TP)
+ MOVE B,-2(TP)
+ MOVE C,(TP)
+ JRST IRMV1
+
+RMV2: JUMPN 0,RMV9 ; JUMP IF FIRST NOT IN BUCKET
+ HLRZ 0,2(B) ; POINT TO NEXT
+ MOVEM 0,(C)
+ JRST RMV8
+
+RMV9: MOVE C,0 ; C IS PREV ATOM
+ HLRZ 0,2(B) ; NEXT
+ HRLM 0,2(C)
+
+RMV8: SETZM 2(B) ; CLOBBER OBLIST SLOT
+ MOVE C,(TP) ; GET OBLIST FOR SPLICE OUT
+ MOVEI 0,-1
+ HRRZ E,(C)
+
+RMV7: JUMPE E,RMVDON
+ CAMN B,1(E) ; SEARCH OBLIST
+ JRST RMV6
+ MOVE C,E
+ HRRZ E,(C)
+ SOJG 0,RMV7
+
+RMVDON: SUB TP,[4,,4]
+ MOVSI A,TATOM
+ POPJ P,
+
+RMV6: HRRZ E,(E)
+ HRRM E,(C) ; SMASH IN
+ JRST RMVDON
+
+\f
+;INTERNAL CALL FROM THE READER
+
+RLOOKU: PUSH TP,$TFIX ;PUSH A FLAG
+ POP P,C ;POP OFF RET ADR
+ PUSH TP,C ;AND USE AS A FLAG FOR INTERNAL
+ MOVE C,(P) ; CHANGE CHAR COUNT TO WORD
+ ADDI C,4
+ IDIVI C,5
+ MOVEM C,(P)
+ GETYP D,A
+
+ CAIN D,TOBLS ;IS IT ONE OBLIST?
+ JRST .+3
+ CAIE D,TLIST ;IS IT A LIST
+ JRST BADOBL
+
+ JUMPE B,BADLST
+ PUSH TP,$TUVEC ; SLOT FOR REMEBERIG
+ PUSH TP,[0]
+ PUSH TP,$TOBLS
+ PUSH TP,[0]
+ PUSH TP,A
+ PUSH TP,B
+ CAIE D,TLIST
+ JRST RLOOK1
+
+ PUSH TP,$TLIST
+ PUSH TP,B
+RLOOK2: GETYP A,(B) ;CHECK THIS IS AN OBLIST
+ CAIE A,TOBLS
+ JRST DEFALT
+
+ SKIPE -4(TP) ; SKIP IF DEFAULT NOT STORED
+ JRST RLOOK4
+ MOVE D,1(B) ; OBLIST
+ MOVEM D,-4(TP)
+RLOOK4: INTGO
+ HRRZ B,@(TP) ;CDR THE LIST
+ HRRZM B,(TP)
+ JUMPN B,RLOOK2
+ SUB TP,[2,,2]
+ JRST .+3
+
+RLOOK1: MOVE B,(TP)
+ MOVEM B,-2(TP)
+ MOVE A,-1(TP)
+ MOVE B,(TP)
+ PUSHJ P,ILOOK
+ JUMPN B,RLOOK3
+ SKIPN D,-2(TP) ; RESTORE FOR INSERT
+ JRST BADDEF ; NO DEFAULT, USER LOST ON SPECIFICATION
+ SUB TP,[6,,6] ; FLUSH CRAP
+ SKIPN NOATMS
+ JRST INSRT1
+ JRST INSRT1
+
+DEFFLG==1 ;SPECIAL FLAG USED TO INDICATE THAT A DEFAULT HAS ALREADY BEEN
+ ; SPECIFIED
+DEFALT: MOVE 0,1(B)
+ CAIN A,TATOM ;SPECIAL DEFAULT INDICATING ATOM ?
+ CAME 0,MQUOTE DEFAULT
+ JRST BADDEF ;NO, LOSE
+ MOVEI A,DEFFLG
+ XORB A,-11(TP) ;SET AND TEST FLAG
+ TRNN A,DEFFLG ; HAVE WE BEEN HERE BEFORE ?
+ JRST BADDEF ; YES, LOSE
+ SETZM -6(TP) ;ZERO OUT PREVIOUS DEFAULT
+ SETZM -4(TP)
+ JRST RLOOK4 ;CONTINUE
+
+
+INSRT2: JRST .+2 ;
+RLOOK3: SUB TP,[6,,6] ;POP OFF LOSSAGE
+ PUSHJ P,ILINK ;IF THIS IS A LINK FOLLOW IT
+ PUSH P,(TP) ;GET BACK RET ADR
+ SUB TP,[2,,2] ;POP TP
+ JRST IATM1 ;AND RETURN
+
+
+BADOBL: ERRUUO EQUOTE BAD-OBLIST-OR-LIST-THEREOF
+
+BADDEF: ERRUUO EQUOTE BAD-DEFAULT-OBLIST-SPECIFICATION
+
+ONOTH: ERRUUO EQUOTE ATOM-ON-DIFFERENT-OBLIST
+\f;SUBROUTINE TO MAKE AN ATOM
+
+IMFUNCTION ATOM,SUBR
+
+ ENTRY 1
+
+ MOVE A,(AB)
+ MOVE B,1(AB)
+ PUSHJ P,IATOMI
+ JRST FINIS
+
+CATOM: SUBM M,(P)
+ PUSHJ P,IATOMI
+ JRST MPOPJ
+
+IATOMI: GETYP 0,A ;CHECK ARG TYPE
+ CAIE 0,TCHRS
+ CAIN 0,TCHSTR
+ JRST .+2 ;JUMP IF WINNERS
+ JRST WTYP1
+
+ PUSH TP,A
+ PUSH TP,B
+ MOVEI B,-1(TP)
+ MOVE A,0
+ PUSHJ P,CSTAK ;COPY ONTO STACK
+ PUSHJ P,IATOM ;NOW MAKE THE ATOM
+ SUB TP,[2,,2]
+ POPJ P,
+
+;INTERNAL ATOM MAKER
+
+IATOM: MOVE A,-1(P) ;GET WORDS IN PNAME
+ ADDI A,3 ;FOR VALUE CELL
+ PUSHJ P,IBLOCK ; GET BLOCK
+ MOVSI C,<(GENERAL)>+SATOM ;FOR TYPE FIELD
+ MOVE D,-1(P) ;RE-GOBBLE LENGTH
+ ADDI D,3(B) ;POINT TO DOPE WORD
+ MOVEM C,(D)
+ SKIPG -1(P) ;EMPTY PNAME ?
+ JRST IATM0 ;YES, NO CHARACTERS TO MOVE
+ MOVE E,B ;COPY ATOM POINTER
+ ADD E,[3,,3] ;POINT TO PNAME AREA
+ MOVEI C,-1(P)
+ SUB C,-1(P) ;POINT TO STRING ON STACK
+ MOVE D,(C) ;GET SOME CHARS
+ MOVEM D,(E) ;AND COPY THEM
+ ADDI C,1
+ AOBJN E,.-3
+IATM0: MOVSI A,TATOM ;TYPE TO ATOM
+IATM1: POP P,D ;RETURN ADR
+ POP P,C
+ HRLI C,(C)
+ SUB P,C
+ JRST (D) ;RETURN
+
+\f;SUBROUTINE TO GET AN ATOM'S PNAME
+
+MFUNCTION PNAME,SUBR
+
+ ENTRY 1
+
+ GETYP A,(AB)
+ CAIE A,TATOM ;CHECK TYPE IS ATOM
+ JRST WTYP1
+ MOVE A,1(AB)
+ PUSHJ P,IPNAME
+ JRST FINIS
+
+CIPNAM: SUBM M,(P)
+ PUSHJ P,IPNAME
+ JRST MPOPJ
+
+IPNAME: ADD A,[3,,3]
+ HLRE B,A
+ MOVM B,B
+ PUSH P,(A) ;FLUSH PNAME ONTO P
+ AOBJN A,.-1
+ MOVE 0,(P) ; LAST WORD
+ PUSHJ P,PNMCNT
+ PUSH P,B
+ PUSHJ P,CHMAK ;MAKE A STRING
+ POPJ P,
+
+PNMCNT: IMULI B,5 ; CHARS TO B
+ MOVE A,0
+ SUBI A,1 ; FIND LAST 1
+ ANDCM 0,A ; 0 HAS 1ST 1
+ JFFO 0,.+1
+ HRREI 0,-34.(A) ; FIND HOW MUCH TO ADD
+ IDIVI 0,7
+ ADD B,0
+ POPJ P,
+
+MFUNCTION SPNAME,SUBR
+
+ ENTRY 1
+
+ GETYP 0,(AB)
+ CAIE 0,TATOM
+ JRST WTYP1
+
+ MOVE B,1(AB)
+ PUSHJ P,CSPNAM
+ JRST FINIS
+
+CSPNAM: ADD B,[3,,3]
+ MOVEI D,(B)
+ HLRE A,B
+ SUBM B,A
+ MOVE 0,-1(A)
+ HLRES B
+ MOVMS B
+ PUSHJ P,PNMCNT
+ MOVSI A,TCHSTR
+ HRRI A,(B)
+ MOVSI B,010700
+ HRRI B,-1(D)
+ POPJ P,
+
+\f; BLOCK STRUCTURE SUBROUTINES FOR MUDDLE
+
+IMFUNCTION BLK,SUBR,BLOCK
+
+ ENTRY 1
+
+ GETYP A,(AB) ;CHECK TYPE OF ARG
+ CAIE A,TOBLS ;IS IT AN OBLIST
+ CAIN A,TLIST ;OR A LIAT
+ JRST .+2
+ JRST WTYP1
+ MOVSI A,TATOM ;LOOK UP OBLIST
+ MOVE B,IMQUOTE OBLIST
+ PUSHJ P,IDVAL ;GET VALUE
+ PUSH TP,A
+ PUSH TP,B
+ MOVE PVP,PVSTOR+1
+ PUSH TP,.BLOCK(PVP) ;HACK THE LIST
+ PUSH TP,.BLOCK+1(PVP)
+ MCALL 2,CONS ;CONS THE LIST
+ MOVE PVP,PVSTOR+1
+ MOVEM A,.BLOCK(PVP) ;STORE IT BACK
+ MOVEM B,.BLOCK+1(PVP)
+ PUSH TP,$TATOM
+ PUSH TP,IMQUOTE OBLIST
+ PUSH TP,(AB)
+ PUSH TP,1(AB)
+ MCALL 2,SET ;SET OBLIST TO ARG
+ JRST FINIS
+
+MFUNCTION ENDBLOCK,SUBR
+
+ ENTRY 0
+
+ MOVE PVP,PVSTOR+1
+ SKIPN B,.BLOCK+1(PVP) ;IS THE LIST NIL?
+ JRST BLKERR ;YES, LOSE
+ HRRZ C,(B) ;CDR THE LIST
+ HRRZM C,.BLOCK+1(PVP)
+ PUSH TP,$TATOM ;NOW RESET OBLIST
+ PUSH TP,IMQUOTE OBLIST
+ HLLZ A,(B) ;PUSH THE TYPE OF THE CAR
+ PUSH TP,A
+ PUSH TP,1(B) ;AND VALUE OF CAR
+ MCALL 2,SET
+ JRST FINIS
+
+BLKERR: ERRUUO EQUOTE UNMATCHED
+
+BADLST: ERRUUO EQUOTE NIL-LIST-OF-OBLISTS
+\f;SUBROUTINE TO CREATE CHARACTER STRING GOODIE
+
+CHMAK: MOVE A,-1(P)
+ ADDI A,4
+ IDIVI A,5
+ PUSHJ P,IBLOCK
+ MOVEI C,-1(P) ;FIND START OF CHARS
+ HLRE E,B ; - LENGTH
+ ADD C,E ;C POINTS TO START
+ MOVE D,B ;COPY VECTOR RESULT
+ JUMPGE D,NULLST ;JUMP IF EMPTY
+ MOVE A,(C) ;GET ONE
+ MOVEM A,(D)
+ ADDI C,1 ;BUMP POINTER
+ AOBJN D,.-3 ;COPY
+NULLST: MOVSI C,TCHRS+.VECT. ;GET TYPE
+ MOVEM C,(D) ;CLOBBER IT IN
+ MOVE A,-1(P) ; # WORDS
+ HRLI A,TCHSTR
+ HRLI B,010700
+ MOVMM E,-1(P) ; SO IATM1 WORKS
+ SOJA B,IATM1 ;RETURN
+
+; SUBROUTINE TO READ FIVE CHARS FROM STRING.
+; TWO CALLS, ONE WITH A POINTING TO LIST ELEMENT,
+; THE OTHER WITH B POINTING TO PAIR. SKIPS IF WINNER, ELSE DOESNT
+
+NXTDCL: GETYP B,(A) ;CHECK TYPE
+ CAIE B,TDEFER ;LOSE IF NOT DEFERRED
+ POPJ P,
+
+ MOVE B,1(A) ;GET REAL BYTE POINTER
+CHRWRD: PUSH P,C
+ GETYP C,(B) ;CHECK IT IS CHSTR
+ CAIE C,TCHSTR
+ JRST CPOPJC ;NO, QUIT
+ PUSH P,D
+ PUSH P,E
+ PUSH P,0
+ MOVEI E,0 ;INITIALIZE DESTINATION
+ HRRZ C,(B) ; GET CHAR COUNT
+ JUMPE C,GOTDCL ; NULL, FINISHED
+ MOVE B,1(B) ;GET BYTE POINTER
+ MOVE D,[440700,,E] ;BYTE POINT TO E
+CHLOOP: ILDB 0,B ; GET A CHR
+ IDPB 0,D ;CLOBBER AWAY
+ SOJE C,GOTDCL ; JUMP IF DONE
+ TLNE D,760000 ; SKIP IF WORD FULL
+ JRST CHLOOP ; MORE THAN 5 CHARS
+ TRO E,1 ; TURN ON FLAG
+
+GOTDCL: MOVE B,E ;RESULT TO B
+ AOS -4(P) ;SKIP RETURN
+CPOPJ0: POP P,0
+ POP P,E
+ POP P,D
+CPOPJC: POP P,C
+ POPJ P,
+
+\f;ROUTINES TO DEFINE AND HANDLE LINKS
+
+MFUNCTION LINK,SUBR
+ ENTRY
+ CAML AB,[-6,,0] ;NO MORE THAN 3 ARGS
+ CAML AB,[-2,,0] ;NO LESS THAN 2 ARGS
+ JRST WNA
+ CAML AB,[-4,,0] ;ONLY TWO ARGS SUPPLIED ?
+ JRST GETOB ;YES, GET OBLIST FROM CURRENT PATH
+ MOVE A,2(AB)
+ MOVE B,3(AB)
+ MOVE C,5(AB)
+ JRST LINKIN
+GETOB: MOVSI A,TATOM
+ MOVE B,IMQUOTE OBLIST
+ PUSHJ P,IDVAL
+ CAMN A,$TOBLS
+ JRST LINKP
+ CAME A,$TLIST
+ JRST BADOBL
+ JUMPE B,BADLST
+ GETYPF A,(B)
+ MOVE B,(B)+1
+LINKP: MOVE C,B
+ MOVE A,2(AB)
+ MOVE B,3(AB)
+LINKIN: PUSHJ P,IINSRT
+ CAMN A,$TFALSE ;LINK NAME ALREADY USED ?
+ JRST ALRDY ;YES, LOSE
+ MOVE C,B
+ MOVE A,(AB)
+ MOVE B,1(AB)
+ PUSHJ P,CSETG
+ JRST FINIS
+
+
+ILINK: HLRE A,B
+ SUBM B,A ;FOUND A LINK ?
+ MOVE A,(A)
+ TRNE A,LNKBIT
+ JRST .+3
+ MOVSI A,TATOM
+ POPJ P, ;NO, FINISHED
+ MOVSI A,TATOM
+ PUSHJ P,IGVAL ;GET THE LINK'S DESTINATION
+ CAME A,$TUNBOUND ;WELL FORMED LINK ?
+ POPJ P, ;YES
+ ERRUUO EQUOTE BAD-LINK
+
+\f
+; THIS SUBROUTINE IMPURIFIES A PURE ATOM TO ALLOW MODIFICATION OF SYSTEM SUBRS
+
+IMPURIFY:
+ PUSH TP,$TATOM
+ PUSH TP,B
+ MOVE C,B
+ MOVEI 0,(C)
+ CAIGE 0,HIBOT
+ JRST RTNATM ; NOT PURE, RETURN
+ JRST IMPURX
+
+; ROUTINE PASSED TO GCHACK
+
+ATFIX: CAME D,(TP)
+ CAMN D,-2(TP)
+ JRST .+2
+ POPJ P,
+
+ ASH C,1
+ ADD C,TYPVEC+1 ; COMPUTE SAT
+ HRRZ C,(C)
+ ANDI C,SATMSK
+ CAIE C,SATOM
+CPOPJ: POPJ P,
+
+ SUB D,-2(TP)
+ ADD D,-4(TP)
+ SKIPE B
+ MOVEM D,1(B)
+ POPJ P,
+
+
+; SUBROUTINE TO FIND A BYTE STRINGS DOPE WORD
+; RECEIVES POINTER TO PAIR CONNTAINIGN CHSTR IN C, RETURNS DOPE WORD IN A
+
+BYTDOP: PUSH P,B ; SAVE SOME ACS
+ PUSH P,D
+ PUSH P,E
+ MOVE B,1(C) ; GET BYTE POINTER
+ LDB D,[360600,,B] ; POSITION TO D
+ LDB E,[300600,,B] ; AND BYTE SIZE
+ MOVEI A,(E) ; A COPY IN A
+ IDIVI D,(E) ; D=> # OF BYTES IN WORD 1
+ HRRZ E,(C) ; GET LENGTH
+ SUBM E,D ; # OF BYTES IN OTHER WORDS
+ JUMPL D,BYTDO1 ; NEAR DOPE WORD
+ MOVEI B,36. ; COMPUTE BYTES PER WORD
+ IDIVM B,A
+ ADDI D,-1(A) ; NOW COMPUTE WORDS
+ IDIVI D,(A) ; D/ # NO. OF WORDS PAST 1ST
+ ADD D,1(C) ; D POINTS TO DOPE WORD
+ MOVEI A,2(D)
+
+BYTDO2: POP P,E
+ POP P,D
+ POP P,B
+ POPJ P,
+BYTDO1: MOVEI A,2(B)
+ JRST BYTDO2
+
+; 1) IMPURIFY ITS OBLIST LIST
+
+IMPURX: HRRZ B,2(C) ; PICKUP OBLIST IF IT EXISTS
+ JUMPE B,IMPUR0 ; NOT ON ONE, IGNORE THIS CODE
+
+ HRRO E,(B)
+ PUSH TP,$TOBLS ; SAVE BUCKET
+ PUSH TP,E
+
+ MOVE B,(E) ; GET NEXT ONE
+IMPUR4: MOVEI 0,(B)
+ MOVE D,1(B)
+ CAME D,-2(TP)
+ JRST .+3
+ SKIPE GPURFL ; IF PURIFY SMASH THE OBLIST SLOT TO PROTECT
+ ; ATOM
+ HRRM D,1(B)
+ CAIGE 0,HIBOT ; SKIP IF PURE
+ JRST IMPUR3 ; FOUND IMPURE NESS, SKIP IT
+ HLLZ C,(B) ; SET UP ICONS CALL
+ HRRZ E,(B)
+IMPR1: PUSHJ P,ICONS ; CONS IT UP
+IMPR2: HRRZ E,(TP) ; RETRV PREV
+ HRRM B,(E) ; AND CLOBBER
+IMPUR3: MOVE D,1(B)
+ CAMN D,-2(TP) ; HAVE GOTTEN TO OUR SLOT?
+ JRST IMPPR3
+ MOVSI 0,TLIST
+ MOVEM 0,-1(TP) ; FIX TYPE
+ HRRZM B,(TP) ; STORE GOODIE
+ HRRZ B,(B) ; CDR IT
+ JUMPN B,IMPUR4 ; LOOP
+IMPPR3: SUB TP,[2,,2] ; FLUSH TP CRUFT
+
+; 1.5) IMPURIFY GLOBAL HASH BUCKET, A REAL PAIN
+
+IMPUR0: MOVE C,(TP) ; GET ATOM
+
+ HRRZ B,2(C)
+ MOVE B,(B)
+ ADD C,[3,,3] ; POINT TO PNAME
+ HLRE A,C ; GET LNTH IN WORDS OF PNAME
+ MOVNS A
+; PUSH P,[SETZ IMPUR2] ; FAKE OUT ILOOKC
+ XMOVEI 0,IMPUR2
+ PUSH P,0
+ PUSH P,(C) ; PUSH UP THE PNAME
+ AOBJN C,.-1
+ PUSH P,A ; NOW THE COUNT
+ MOVSI A,TOBLS
+ JRST ILOOKC ; GO FIND BUCKET
+
+IMPUR2: JUMPE B,IMPUR1
+ JUMPE 0,IMPUR1 ; YUP, DONE
+ HRRZ C,0
+ CAIG C,HIBOT ; SKIP IF PREV IS PURE
+ JRST IMPUR1
+
+ MOVE B,0
+ PUSH P,GPURFL ; PRERTEND OUT OF PURIFY
+ HLRE C,B
+ SUBM B,C
+ HRRZ C,(C) ; ARE WE ON PURIFY LIST
+ CAIG C,HIBOT ; IF SO, WE ARE STILL PURIFY
+ SETZM GPURFL
+ PUSHJ P,IMPURIF ; RECURSE
+ POP P,GPURFL
+ MOVE B,(TP) ; AND RETURN ORIGINAL
+
+; 2) GENERATE A DUPLICATE ATOM
+
+IMPUR1: SKIPE GPURFL ; SEE IF IN PURIFY
+ JRST IMPUR7
+ HLRE A,(TP) ; GET LNTH OF ATOM
+ MOVNS A
+ PUSH P,A
+ PUSHJ P,IBLOCK ; GET NEW BLOCK FOR ATOM
+ PUSH TP,$TATOM
+ PUSH TP,B
+ HRL B,-2(TP) ; SETUP BLT
+ POP P,A
+ ADDI A,(B) ; END OF BLT
+ BLT B,(A) ; CLOBBER NEW ATOM
+ MOVSI B,.VECT. ; TURN ON BIT FOR GCHACK
+ IORM B,(A)
+
+; 3) NOW COPY GLOBAL VALUE
+
+IMPUR7: MOVE B,(TP) ; ATOM BACK
+ GETYP 0,(B)
+ SKIPE A,1(B) ; NON-ZER POINTER?
+ CAIN 0,TUNBOU ; BOUND?
+ JRST IMPUR5 ; NO, DONT COPY GLOB VAL
+ PUSH TP,(A)
+ PUSH TP,1(A)
+ PUSH TP,$TATOM
+ PUSH TP,B
+ SETZM (B)
+ SETZM 1(B)
+ SKIPN GPURFL ; HERE IS SOME CODE NEEDED FOR PURIFY
+ JRST IMPUR8
+ PUSH P,LPVP
+ MOVE PVP,PVSTOR+1
+ PUSH P,AB ; GET AB BACK
+ MOVE AB,ABSTO+1(PVP)
+IMPUR8: PUSHJ P,BSETG ; SETG IT
+ SKIPN GPURFL
+ JRST .+3 ; RESTORE SP AND AB FOR PURIFY
+ POP P,TYPNT
+ POP P,SP
+ SUB TP,[2,,2] ; KILL ATOM SLOTS ON TP
+ POP TP,C ;POP OFF VALUE SLOTS
+ POP TP,A
+ MOVEM A,(B) ; FILL IN SLOTS ON GLOBAL STACK
+ MOVEM C,1(B)
+IMPUR5: SKIPE GPURFL ; FINISH OFF DIFFERENTLY FOR PURIFY
+ JRST IMPUR9
+
+ PUSH TP,$TFIX ;SAVE OLD ATOM WITH FUNNY TYPE TO AVOID LOSSAGE
+ PUSH TP,-3(TP)
+ PUSH TP,$TFIX ; OTHER KIND OF POINTER ALSO
+ HLRE 0,-1(TP)
+ HRRZ A,-1(TP)
+ SUB A,0
+ PUSH TP,A
+
+; 4) UPDATE ALL POINTERS TO THIS ATOM
+
+ MOVE A,[PUSHJ P,ATFIX] ; INS TO PASS TO GCHACK
+ MOVEI PVP,1 ; SAY MIGHT BE NON-ATOMS
+ PUSHJ P,GCHACK
+ SUB TP,[6,,6]
+
+RTNATM: POP TP,B
+ POP TP,A
+ POPJ P,
+
+IMPUR9: SUB TP,[2,,2]
+ POPJ P, ; RESTORE AND GO
+
+
+
+END
--- /dev/null
+
+TITLE ATOMHACKER FOR MUDDLE
+
+RELOCATABLE
+
+.INSRT MUDDLE >
+.GLOBAL RLOOKU,CHMAK,OBLNT,ROOT,INTOBL,ERROBL,IFALSE,PVSTOR,SPSTOR
+.GLOBAL .BLOCK,IDVAL,NXTDCL,CHRWRD,CSTACK,CSTAK,ILOOKC,IGVAL,BYTDOP,HASHTB
+.GLOBAL ICONS,INCONS,IBLOCK,INSRTX,GCHACK,IMPURIFY,BSETG,TYPVEC,IGET,IPUT
+.GLOBAL CINSER,CIRMV,CLOOKU,CATOM,CIPNAM,MPOPJ,CSETG,CSPNAM,GPURFL,IMPURX
+
+LPVP==SP
+TYPNT==AB
+LNKBIT==200000
+
+; FUNCTION TO GENERATE AN EMPTY OBLIST
+
+MFUNCTION MOBLIST,SUBR
+
+ ENTRY
+ CAMGE AB,[-5,,0] ;CHECK NUMBER OF ARGS
+ JRST TMA
+ JUMPGE AB,MOBL2 ; NO ARGS
+ MOVE A,(AB)
+ MOVE B,1(AB)
+ MOVSI C,TATOM
+ MOVE D,IMQUOTE OBLIST
+ PUSHJ P,IGET ; CHECK IF IT EXISTS ALREADY
+ CAMN A,$TOBLS
+ JRST FINIS
+MOBL2:
+ MOVEI A,1
+ PUSHJ P,IBLOCK ;GET A UNIFORM VECTOR
+ MOVSI C,TLIST+.VECT. ;IT IS OF TYPE LIST
+ HLRE D,B ;-LENGTH TO D
+ SUBM B,D ;D POINTS TO DOPE WORD
+ MOVEM C,(D) ;CLOBBER TYPE IN
+ MOVSI A,TOBLS
+ JUMPGE AB,FINIS ; IF NO ARGS, DONE
+ GETYP A,(AB)
+ CAIE A,TATOM
+ JRST WTYP1
+ MOVSI A,TOBLS
+ PUSH TP,$TOBLS
+ PUSH TP,B
+ MOVSI C,TATOM
+ MOVE D,IMQUOTE OBLIST
+ PUSH TP,(AB)
+ PUSH TP,1(AB)
+ PUSHJ P,IPUT ; PUT THE NAME ON THE OBLIST
+ MOVE A,(AB)
+ MOVE B,1(AB)
+ MOVSI C,TATOM
+ MOVE D,IMQUOTE OBLIST
+ PUSH TP,(TB)
+ PUSH TP,1(TB)
+ PUSHJ P,IPUT ; PUT THE OBLIST ON THE NAME
+
+ POP TP,B
+ POP TP,A
+ JRST FINIS
+
+MFUNCTION GROOT,SUBR,ROOT
+ ENTRY 0
+ MOVE A,ROOT
+ MOVE B,ROOT+1
+ JRST FINIS
+
+MFUNCTION GINTS,SUBR,INTERRUPTS
+ ENTRY 0
+ MOVE A,INTOBL
+ MOVE B,INTOBL+1
+ JRST FINIS
+
+MFUNCTION GERRS,SUBR,ERRORS
+ ENTRY 0
+ MOVE A,ERROBL
+ MOVE B,ERROBL+1
+ JRST FINIS
+
+
+COBLQ: SKIPN B,2(B) ; SKIP IF EXISTS
+ JRST IFLS
+ MOVSI A,TOBLS
+
+ ANDI B,-1
+ CAMG B,VECBOT ; TVP IS IN FROZEN SPACE, NEVER OBLISTS
+ MOVE B,(B)
+ HRLI B,-1
+
+CPOPJ1: AOS (P)
+ POPJ P,
+
+IFLS: MOVEI B,0
+ MOVSI A,TFALSE
+ POPJ P,
+
+MFUNCTION OBLQ,SUBR,[OBLIST?]
+
+ ENTRY 1
+ GETYP A,(AB)
+ CAIE A,TATOM
+ JRST WTYP1
+ MOVE B,1(AB) ; GET ATOM
+ PUSHJ P,COBLQ
+ JFCL
+ JRST FINIS
+
+\f; FUNCTION TO FIND AN ATOM ON A GIVEN OBLIST WITH A GIVEN PNAME
+
+MFUNCTION LOOKUP,SUBR
+
+ ENTRY 2
+ PUSHJ P,ILOOKU ;CALL INTERNAL ROUTINE
+ JRST FINIS
+
+CLOOKU: SUBM M,(P)
+ PUSH TP,A
+ PUSH TP,B
+ MOVEI B,-1(TP)
+ PUSH TP,$TOBLS
+ PUSH TP,C
+ GETYP A,A
+ PUSHJ P,CSTAK
+ MOVE B,(TP)
+ MOVSI A,TOBLS ; THIS IS AN OBLIST
+ PUSHJ P,ILOOK
+ POP P,D
+ HRLI D,(D)
+ SUB P,D
+ SKIPE B
+ SOS (P)
+ SUB TP,[4,,4]
+ JRST MPOPJ
+
+ILOOKU: PUSHJ P,ARGCHK ;CHECK ARGS
+ PUSHJ P,CSTACK ;PUT CHARACTERS ON THE STACK
+
+CALLIT: MOVE B,3(AB) ;GET OBLIST
+ MOVSI A,TOBLS
+ILOOKC: PUSHJ P,ILOOK ;LOOK IT UP
+ POP P,D ;RESTORE COUNT
+ HRLI D,(D) ;TO BOTH SIDES
+ SUB P,D
+ POPJ P,
+
+;THIS ROUTINE CHECKS ARG TYPES
+
+ARGCHK: GETYP A,(AB) ;GET TYPES
+ GETYP C,2(AB)
+ CAIE A,TCHRS ;IS IT EITHER CHAR STRING
+ CAIN A,TCHSTR
+ CAIE C,TOBLS ;IS 2ND AN OBLIST
+ JRST WRONGT ;TYPES ARE WRONG
+ POPJ P,
+
+;THIS SUBROUTINE PUTS CHARACTERS ON THE STACK (P WILL BE CHANGED)
+
+
+CSTACK: MOVEI B,(AB)
+CSTAK: POP P,D ;RETURN ADDRESS TO D
+ CAIE A,TCHRS ;IMMEDIATE?
+ JRST NOTIMM ;NO, HAIR
+ MOVE A,1(B) ; GET CHAR
+ LSH A,29. ; POSITION
+ PUSH P,A ;ONTO P
+ PUSH P,[1] ;WITH NUMBER
+ JRST (D) ;GO CALL SEARCHER
+
+NOTIMM: MOVEI A,1 ; CLEAR CHAR COUNT
+ MOVE C,(B) ; GET COUNT OF CHARS
+ TRNN C,-1
+ JRST NULST ; FLUSH NULL STRING
+ MOVE PVP,PVSTOR+1
+ MOVEM C,BSTO(PVP)
+ ANDI C,-1
+ MOVE B,1(B) ;GET BYTE POINTER
+
+CLOOP1: PUSH P,[0] ; STORE CHARS ON STACK
+ MOVSI E,(<440700,,(P)>) ; SETUP BYTE POINTER
+CLOOP: SKIPL INTFLG ; SO CAN WIN WITH INTERRUPTS
+ JRST CLOOP2
+ MOVE PVP,PVSTOR+1
+ HRRM C,BSTO(PVP) ;SAVE STRING LENGTH
+ JSR LCKINT
+CLOOP2: ILDB 0,B ;GET A CHARACTER
+ IDPB 0,E ;STORE IT
+ SOJE C,CDONE ; ANY MORE?
+ TLNE E,760000 ; WORD FULL
+ JRST CLOOP ;NO CONTINUE
+ AOJA A,CLOOP1 ;AND CONTINUE
+
+CDONE:
+CDONE1: MOVE PVP,PVSTOR+1
+ SETZM BSTO(PVP)
+ PUSH P,A ;AND NUMBER OF WORDS
+ JRST (D) ;RETURN
+
+
+NULST: ERRUUO EQUOTE NULL-STRING
+\f; THIS FUNCTION LOOKS FOR ATOMS. CALLED BY PUSHJ P,ILOOK
+; A,B/ OBLIST POINTER (CAN BE LIST OF SAME)
+; -1(P)/ LENGTH IN WORDS OF CHARACTER BLOCK
+; CHAR STRING IS ON THE STACK
+; IF ATOM EXISTS RETURNS:
+; B/ THE ATOM
+; C/ THE BUCKET
+; 0/ THE PREVIOUS BUCKET
+;
+; IF NOT
+; B/ 0
+; 0/ PREV IF ONE WITH SAME PNAME, ELSE 0
+; C/ BUCKET
+
+ILOOK: PUSH TP,A
+ PUSH TP,B
+
+ MOVN A,-1(P) ;GET -LENGTH
+ HRLI A,-1(A) ;<-LENGTH-1>,,-LENGTH
+ PUSH TP,$TFIX ;SAVE
+ PUSH TP,A
+ ADDI A,-1(P) ;HAVE AOBJN POINTER TO CHARS
+ MOVE 0,[202622077324] ;HASH WORD
+ ROT 0,1
+ TSC 0,(A)
+ AOBJN A,.-2 ;XOR THEM ALL TOGETHER
+ HLRE A,HASHTB+1
+ MOVNS A
+ MOVMS 0 ; MAKE SURE + HASH CODE
+ IDIVI 0,(A) ;DIVIDE
+ HRLI A,(A) ;TO BOTH HALVES
+ ADD A,HASHTB+1
+
+ MOVE C,A
+ HRRZ A,(A) ; POINT TO FIRST ATOM
+ SETZB E,0 ; INDICATE NO ATOM
+
+ JUMPE A,NOTFND
+LOOK2: HLRZ E,1(A) ; PREPARE TO BUILD AOBJN
+ ANDI E,377777 ; SIGN MIGHT BE ON IF IN PURIFY ETC.
+ SUBI E,2
+ HRLS E
+ SUBB A,E
+
+ ADD A,[3,,3] ;POINT TO ATOMS PNAME
+ MOVE D,(TP) ;GET PSEUDO AOBJN POINTER TO CHARS
+ ADDI D,-1(P) ;NOW ITS A REAL AOBJN POINTER
+ JUMPE D,CHECK0 ;ONE IS EMPTY
+LOOK1:
+ MOVE SP,(D)
+ CAME SP,(A)
+
+ JRST NEXT1 ;THIS ONE DOESN'T MATCH
+ AOBJP D,CHECK ;ONE RAN OUT
+ AOBJN A,LOOK1 ;JUMP IF STILL MIGHT WIN
+
+NEXT1: HRRZ A,-1(TP) ; SEE IF WE'VE ALREADY SEEN THIS NAME
+ GETYP D,-3(TP) ; SEE IF LIST OF OBLISTS
+ CAIN D,TLIST
+ JUMPN A,CHECK3 ; DON'T LOOK FURTHER
+ JUMPN A,NOTFND
+NEXT:
+ MOVE 0,E
+ HLRZ A,2(E) ; NEXT ATOM
+ JUMPN A,LOOK2
+ HRRZ A,-1(TP)
+ JUMPN A,NEXT1
+
+ SETZB E,0
+
+NOTFND:
+ MOVEI B,0
+ MOVSI A,TFALSE
+CPOPJT:
+
+ SUB TP,[4,,4]
+ POPJ P,
+
+CHECK0: JUMPN A,NEXT1 ;JUMP IF NOT ALSO EMPTY
+ SKIPA
+CHECK: AOBJN A,NEXT1 ;JUMP IF NO MATCH
+
+CHECK5: HRRZ A,-1(TP) ; SEE IF FIRST SHOT AT THIS GUY?
+ SKIPN A
+ MOVE B,0 ; REMEMBER ATOM FOR FALL BACK
+ HLLOS -1(TP) ; INDICATE NAME MATCH HAS OCCURRED
+ HRRZ A,2(E) ; COMPUTE OBLIST POINTER
+ CAMGE A,VECBOT
+ MOVE A,(A)
+ HRROS A
+ GETYP D,-3(TP) ; SEE IF LIST OF OBLISTS OR
+ CAIE D,TOBLS
+ JRST CHECK1
+ CAME A,-2(TP) ; DO OBLISTS MATCH?
+ JRST NEXT
+
+CHECK2: MOVE B,E ; RETURN ATOM
+ HLRE A,B
+ SUBM B,A
+ MOVE A,(A)
+ TRNE A,LNKBIT
+ SKIPA A,$TLINK
+ MOVSI A,TATOM
+ JRST CPOPJT
+
+CHECK1: MOVE D,-2(TP) ; ANY LEFT?
+ CAMN A,1(D) ; MATCH
+ JRST CHECK2
+ JRST NEXT
+
+CHECK3: MOVE D,-2(TP)
+ HRRZ D,(D)
+ MOVEM D,-2(TP)
+ JUMPE D,NOTFND
+ JUMPE B,CHECK6
+ HLRZ E,2(B)
+CHECK7: HLRZ A,1(E)
+ ANDI A,377777 ; SIGN MIGHT BE ON IF IN PURIFY ETC.
+ SUBI A,2
+ HRLS A
+ SUBB E,A
+ JRST CHECK5
+
+CHECK6: HRRZ E,(C)
+ JRST CHECK7
+
+\f; FUNCTION TO INSERT AN ATOM ON AN OBLIST
+
+MFUNCTION INSERT,SUBR
+
+ ENTRY 2
+ GETYP A,2(AB)
+ CAIE A,TOBLS
+ JRST WTYP2
+ MOVE A,(AB)
+ MOVE B,1(AB)
+ MOVE C,3(AB)
+ PUSHJ P,IINSRT
+ JRST FINIS
+
+CINSER: SUBM M,(P)
+ PUSHJ P,IINSRT
+ JRST MPOPJ
+
+IINSRT: PUSH TP,A
+ PUSH TP,B
+ PUSH TP,$TOBLS
+ PUSH TP,C
+ GETYP A,A
+ CAIN A,TATOM
+ JRST INSRT0
+
+;INSERT WITH A GIVEN PNAME
+
+ CAIE A,TCHRS
+ CAIN A,TCHSTR
+ JRST .+2
+ JRST WTYP1
+
+ PUSH TP,$TFIX ;FLAG CALL
+ PUSH TP,[0]
+ MOVEI B,-5(TP)
+ PUSHJ P,CSTAK ;COPY ONTO STACK
+ MOVE B,-2(TP)
+ MOVSI A,TOBLS
+ PUSHJ P,ILOOK ;LOOK IT UP (BUCKET RETURNS IN C)
+ SETZM -4(TP)
+ SETZM -5(TP) ; KILL STRING POINTER TO KEEP FROM CONFUSING GC
+ JUMPN B,ALRDY ;EXISTS, LOSE
+ MOVE D,-2(TP) ; GET OBLIST BACK
+INSRT1: PUSH TP,$TATOM
+ PUSH TP,0 ; PREV ATOM
+ PUSH TP,$TUVEC ;SAVE BUCKET POINTER
+ PUSH TP,C
+ PUSH TP,$TOBLS
+ PUSH TP,D ; SAVE OBLIST
+INSRT3: PUSHJ P,IATOM ; MAKE AN ATOM
+ HLRE A,B ; FIND DOPE WORD
+ SUBM B,A
+ ANDI A,-1
+ SKIPN E,-4(TP) ; AFTER AN ATOM?
+ JRST INSRT7 ; NO, FIRST IN BUCKET
+ MOVEI 0,(E) ; CHECK IF PURE
+ CAIG 0,HIBOT
+ JRST INSRNP
+ PUSH TP,$TATOM ; SAVE NEW ATOM
+ PUSH TP,B
+ MOVE B,E
+ PUSHJ P,IMPURIF
+ MOVE B,(TP)
+ MOVE E,-6(TP)
+ SUB TP,[2,,2]
+ HLRE A,B ; FIND DOPE WORD
+ SUBM B,A
+ ANDI A,-1
+
+INSRNP: HLRZ 0,2(E) ; NEXT
+ HRLM A,2(E) ; SPLICE
+ HRLM 0,2(B)
+ JRST INSRT8
+
+INSRT7: MOVE E,-2(TP)
+ EXCH A,(E)
+ HRLM A,2(B) ; IN CASE OLD ONE
+
+INSRT8: MOVE E,(TP) ; GET OBLIST
+ HRRM E,2(B) ; STORE OBLIST
+ MOVE E,(E) ; POINT TO LIST OF ATOMS
+ PUSHJ P,LINKCK
+ PUSHJ P,ICONS
+ MOVE E,(TP)
+ HRRM B,(E) ;INTO NEW BUCKET
+ MOVSI A,TATOM
+ MOVE B,1(B) ;GET ATOM BACK
+ MOVE C,-6(TP) ;GET FLAG
+ SUB TP,[8,,8] ;POP STACK
+ JUMPN C,(C)
+ SUB TP,[4,,4]
+ POPJ P,
+
+;INSERT WITH GIVEN ATOM
+INSRT0: MOVE A,-2(TP) ;GOBBLE PNAME
+ SKIPE 2(A) ; SKIP IF NOT ON AN OBLIST
+ JRST ONOBL
+ ADD A,[3,,3]
+ HLRE C,A
+ MOVNS C
+ PUSH P,(A) ;FLUSH PNAME ONTO P STACK
+ AOBJN A,.-1
+ PUSH P,C
+ MOVE B,(TP) ; GET OBLIST FOR LOOKUP
+ MOVSI A,TOBLS
+ PUSHJ P,ILOOK ;ALREADY THERE?
+ JUMPN B,ALRDY
+ MOVE D,-2(TP)
+
+ HLRE A,-2(TP) ; FIND DOPE WORD
+ SUBM D,A ; TO A
+ JUMPE 0,INSRT9 ; NO CURRENT ATOM
+ MOVE E,0
+ MOVEI 0,(E)
+ CAIGE 0,HIBOT ; PURE?
+ JRST INSRPN
+ PUSH TP,$TATOM
+ PUSH TP,E
+ PUSH TP,$TATOM
+ PUSH TP,D
+ MOVE B,E
+ PUSHJ P,IMPURIF
+ MOVE D,(TP)
+ MOVE E,-2(TP)
+ SUB TP,[4,,4]
+ HLRE A,D
+ SUBM D,A
+
+
+INSRPN: HLRZ 0,2(E) ; POINT TO NEXT
+ HRLM A,2(E) ; CLOBBER NEW GUY IN
+ HRLM 0,2(D) ; FINISH SLPICE
+ JRST INSRT6
+
+INSRT9: ANDI A,-1
+ EXCH A,(C) ; INTO BUCKET
+ HRLM A,2(D)
+
+INSRT6: HRRZ E,(TP)
+ HRRZ E,(E)
+ MOVE B,D
+ PUSHJ P,LINKCK
+ PUSHJ P,ICONS
+ MOVE C,(TP) ;RESTORE OBLIST
+ HRRZM B,(C)
+ MOVE B,-2(TP) ; GET BACK ATOM
+ HRRM C,2(B) ; CLOBBER OBLIST IN
+ MOVSI A,TATOM
+ SUB TP,[4,,4]
+ POP P,C
+ HRLI C,(C)
+ SUB P,C
+ POPJ P,
+
+LINKCK: HRRZ C,FSAV(TB) ;CALLER'S NAME
+ MOVE D,B
+ CAIE C,LINK
+ SKIPA C,$TATOM ;LET US INSERT A LINK INSTEAD OF AN ATOM
+ SKIPA C,$TLINK ;GET REAL ATOM FOR CALL TO ICONS
+ POPJ P,
+ HLRE A,D
+ SUBM D,A
+ MOVEI B,LNKBIT
+ IORM B,(A)
+ POPJ P,
+
+
+ALRDY: ERRUUO EQUOTE ATOM-ALREADY-THERE
+
+ONOBL: ERRUUO EQUOTE ON-AN-OBLIST-ALREADY
+
+; INTERNAL INSERT CALL
+
+INSRTX: POP P,0 ; GET RET ADDR
+ PUSH TP,$TFIX
+ PUSH TP,0
+ PUSH TP,$TATOM
+ PUSH TP,[0]
+ PUSH TP,$TUVEC
+ PUSH TP,[0]
+ PUSH TP,$TOBLS
+ PUSH TP,B
+ MOVSI A,TOBLS
+ PUSHJ P,ILOOK
+ JUMPN B,INSRXT
+ MOVEM 0,-4(TP)
+ MOVEM C,-2(TP)
+ JRST INSRT3 ; INTO INSERT CODE
+
+INSRXT: PUSH P,-4(TP)
+ SUB TP,[6,,6]
+ POPJ P,
+ JRST IATM1
+\f
+; FUNCTION TO REMOVE AN ATOM FROM AN OBLIST
+
+MFUNCTION REMOVE,SUBR
+
+ ENTRY
+
+ JUMPGE AB,TFA
+ CAMGE AB,[-5,,]
+ JRST TMA
+ MOVEI C,0
+ CAML AB,[-3,,] ; SKIP IF OBLIST GIVEN
+ JRST .+5
+ GETYP 0,2(AB)
+ CAIE 0,TOBLS
+ JRST WTYP2
+ MOVE C,3(AB)
+ MOVE A,(AB)
+ MOVE B,1(AB)
+ PUSHJ P,IRMV
+ JRST FINIS
+
+CIRMV: SUBM M,(P)
+ PUSHJ P,IRMV
+ JRST MPOPJ
+
+IRMV: PUSH TP,A
+ PUSH TP,B
+ PUSH TP,$TOBLS
+ PUSH TP,C
+IRMV1: GETYP 0,A ; CHECK 1ST ARG
+ CAIN 0,TLINK
+ JRST .+3
+ CAIE 0,TATOM ; ATOM, TREAT ACCORDINGLY
+ JRST RMV1
+
+ HRRZ D,2(B) ; SKIP IF ON OBLIST AND GET SAME
+ JUMPE D,RMVDON
+ CAMG D,VECBOT ; SKIP IF REAL OBLIST
+ HRRZ D,(D) ; NO, REF, GET IT
+
+ JUMPGE C,GOTOBL
+ CAIE D,(C) ; BETTER BE THE SAME
+ JRST ONOTH
+
+GOTOBL: ADD B,[3,,3] ; POINT TO PNAME
+ HLRE A,B
+ MOVNS A
+ PUSH P,(B) ; PUSH PNAME
+ AOBJN B,.-1
+ PUSH P,A
+ HRROM D,(TP) ; SAVE OBLIST
+ JRST RMV3
+
+RMV1: JUMPGE C,TFA
+ CAIE 0,TCHRS
+ CAIN 0,TCHSTR
+ SKIPA A,0
+ JRST WTYP1
+ MOVEI B,-3(TP)
+ PUSHJ P,CSTAK
+RMV3: MOVE B,(TP)
+ MOVSI A,TOBLS
+ PUSHJ P,ILOOK
+ POP P,D
+ HRLI D,(D)
+ SUB P,D
+ JUMPE B,RMVDON
+
+ MOVEI A,(B)
+ CAIGE A,HIBOT ; SKIP IF PURE
+ JRST RMV2
+ PUSH TP,$TATOM
+ PUSH TP,0
+ PUSHJ P,IMPURIFY
+ MOVE 0,(TP)
+ SUB TP,[2,,2]
+ MOVE A,-3(TP)
+ MOVE B,-2(TP)
+ MOVE C,(TP)
+ JRST IRMV1
+
+RMV2: JUMPN 0,RMV9 ; JUMP IF FIRST NOT IN BUCKET
+ HLRZ 0,2(B) ; POINT TO NEXT
+ MOVEM 0,(C)
+ JRST RMV8
+
+RMV9: MOVE C,0 ; C IS PREV ATOM
+ HLRZ 0,2(B) ; NEXT
+ HRLM 0,2(C)
+
+RMV8: SETZM 2(B) ; CLOBBER OBLIST SLOT
+ MOVE C,(TP) ; GET OBLIST FOR SPLICE OUT
+ MOVEI 0,-1
+ HRRZ E,(C)
+
+RMV7: JUMPE E,RMVDON
+ CAMN B,1(E) ; SEARCH OBLIST
+ JRST RMV6
+ MOVE C,E
+ HRRZ E,(C)
+ SOJG 0,RMV7
+
+RMVDON: SUB TP,[4,,4]
+ MOVSI A,TATOM
+ POPJ P,
+
+RMV6: HRRZ E,(E)
+ HRRM E,(C) ; SMASH IN
+ JRST RMVDON
+
+\f
+;INTERNAL CALL FROM THE READER
+
+RLOOKU: PUSH TP,$TFIX ;PUSH A FLAG
+ POP P,C ;POP OFF RET ADR
+ PUSH TP,C ;AND USE AS A FLAG FOR INTERNAL
+ MOVE C,(P) ; CHANGE CHAR COUNT TO WORD
+ ADDI C,4
+ IDIVI C,5
+ MOVEM C,(P)
+ GETYP D,A
+
+ CAIN D,TOBLS ;IS IT ONE OBLIST?
+ JRST .+3
+ CAIE D,TLIST ;IS IT A LIST
+ JRST BADOBL
+
+ JUMPE B,BADLST
+ PUSH TP,$TUVEC ; SLOT FOR REMEBERIG
+ PUSH TP,[0]
+ PUSH TP,$TOBLS
+ PUSH TP,[0]
+ PUSH TP,A
+ PUSH TP,B
+ CAIE D,TLIST
+ JRST RLOOK1
+
+ PUSH TP,$TLIST
+ PUSH TP,B
+RLOOK2: GETYP A,(B) ;CHECK THIS IS AN OBLIST
+ CAIE A,TOBLS
+ JRST DEFALT
+
+ SKIPE -4(TP) ; SKIP IF DEFAULT NOT STORED
+ JRST RLOOK4
+ MOVE D,1(B) ; OBLIST
+ MOVEM D,-4(TP)
+RLOOK4: INTGO
+ HRRZ B,@(TP) ;CDR THE LIST
+ HRRZM B,(TP)
+ JUMPN B,RLOOK2
+ SUB TP,[2,,2]
+ JRST .+3
+
+RLOOK1: MOVE B,(TP)
+ MOVEM B,-2(TP)
+ MOVE A,-1(TP)
+ MOVE B,(TP)
+ PUSHJ P,ILOOK
+ JUMPN B,RLOOK3
+ SKIPN D,-2(TP) ; RESTORE FOR INSERT
+ JRST BADDEF ; NO DEFAULT, USER LOST ON SPECIFICATION
+ SUB TP,[6,,6] ; FLUSH CRAP
+ SKIPN NOATMS
+ JRST INSRT1
+ JRST INSRT1
+
+DEFFLG==1 ;SPECIAL FLAG USED TO INDICATE THAT A DEFAULT HAS ALREADY BEEN
+ ; SPECIFIED
+DEFALT: MOVE 0,1(B)
+ CAIN A,TATOM ;SPECIAL DEFAULT INDICATING ATOM ?
+ CAME 0,MQUOTE DEFAULT
+ JRST BADDEF ;NO, LOSE
+ MOVEI A,DEFFLG
+ XORB A,-11(TP) ;SET AND TEST FLAG
+ TRNN A,DEFFLG ; HAVE WE BEEN HERE BEFORE ?
+ JRST BADDEF ; YES, LOSE
+ SETZM -6(TP) ;ZERO OUT PREVIOUS DEFAULT
+ SETZM -4(TP)
+ JRST RLOOK4 ;CONTINUE
+
+
+INSRT2: JRST .+2 ;
+RLOOK3: SUB TP,[6,,6] ;POP OFF LOSSAGE
+ PUSHJ P,ILINK ;IF THIS IS A LINK FOLLOW IT
+ PUSH P,(TP) ;GET BACK RET ADR
+ SUB TP,[2,,2] ;POP TP
+ JRST IATM1 ;AND RETURN
+
+
+BADOBL: ERRUUO EQUOTE BAD-OBLIST-OR-LIST-THEREOF
+
+BADDEF: ERRUUO EQUOTE BAD-DEFAULT-OBLIST-SPECIFICATION
+
+ONOTH: ERRUUO EQUOTE ATOM-ON-DIFFERENT-OBLIST
+\f;SUBROUTINE TO MAKE AN ATOM
+
+IMFUNCTION ATOM,SUBR
+
+ ENTRY 1
+
+ MOVE A,(AB)
+ MOVE B,1(AB)
+ PUSHJ P,IATOMI
+ JRST FINIS
+
+CATOM: SUBM M,(P)
+ PUSHJ P,IATOMI
+ JRST MPOPJ
+
+IATOMI: GETYP 0,A ;CHECK ARG TYPE
+ CAIE 0,TCHRS
+ CAIN 0,TCHSTR
+ JRST .+2 ;JUMP IF WINNERS
+ JRST WTYP1
+
+ PUSH TP,A
+ PUSH TP,B
+ MOVEI B,-1(TP)
+ MOVE A,0
+ PUSHJ P,CSTAK ;COPY ONTO STACK
+ PUSHJ P,IATOM ;NOW MAKE THE ATOM
+ SUB TP,[2,,2]
+ POPJ P,
+
+;INTERNAL ATOM MAKER
+
+IATOM: MOVE A,-1(P) ;GET WORDS IN PNAME
+ ADDI A,3 ;FOR VALUE CELL
+ PUSHJ P,IBLOCK ; GET BLOCK
+ MOVSI C,<(GENERAL)>+SATOM ;FOR TYPE FIELD
+ MOVE D,-1(P) ;RE-GOBBLE LENGTH
+ ADDI D,3(B) ;POINT TO DOPE WORD
+ MOVEM C,(D)
+ SKIPG -1(P) ;EMPTY PNAME ?
+ JRST IATM0 ;YES, NO CHARACTERS TO MOVE
+ MOVE E,B ;COPY ATOM POINTER
+ ADD E,[3,,3] ;POINT TO PNAME AREA
+ MOVEI C,-1(P)
+ SUB C,-1(P) ;POINT TO STRING ON STACK
+ MOVE D,(C) ;GET SOME CHARS
+ MOVEM D,(E) ;AND COPY THEM
+ ADDI C,1
+ AOBJN E,.-3
+IATM0: MOVSI A,TATOM ;TYPE TO ATOM
+IATM1: POP P,D ;RETURN ADR
+ POP P,C
+ HRLI C,(C)
+ SUB P,C
+ JRST (D) ;RETURN
+
+\f;SUBROUTINE TO GET AN ATOM'S PNAME
+
+MFUNCTION PNAME,SUBR
+
+ ENTRY 1
+
+ GETYP A,(AB)
+ CAIE A,TATOM ;CHECK TYPE IS ATOM
+ JRST WTYP1
+ MOVE A,1(AB)
+ PUSHJ P,IPNAME
+ JRST FINIS
+
+CIPNAM: SUBM M,(P)
+ PUSHJ P,IPNAME
+ JRST MPOPJ
+
+IPNAME: ADD A,[3,,3]
+ HLRE B,A
+ MOVM B,B
+ PUSH P,(A) ;FLUSH PNAME ONTO P
+ AOBJN A,.-1
+ MOVE 0,(P) ; LAST WORD
+ PUSHJ P,PNMCNT
+ PUSH P,B
+ PUSHJ P,CHMAK ;MAKE A STRING
+ POPJ P,
+
+PNMCNT: IMULI B,5 ; CHARS TO B
+ MOVE A,0
+ SUBI A,1 ; FIND LAST 1
+ ANDCM 0,A ; 0 HAS 1ST 1
+ JFFO 0,.+1
+ HRREI 0,-34.(A) ; FIND HOW MUCH TO ADD
+ IDIVI 0,7
+ ADD B,0
+ POPJ P,
+
+MFUNCTION SPNAME,SUBR
+
+ ENTRY 1
+
+ GETYP 0,(AB)
+ CAIE 0,TATOM
+ JRST WTYP1
+
+ MOVE B,1(AB)
+ PUSHJ P,CSPNAM
+ JRST FINIS
+
+CSPNAM: ADD B,[3,,3]
+ MOVEI D,(B)
+ HLRE A,B
+ SUBM B,A
+ MOVE 0,-1(A)
+ HLRES B
+ MOVMS B
+ PUSHJ P,PNMCNT
+ MOVSI A,TCHSTR
+ HRRI A,(B)
+ MOVSI B,010700
+ HRRI B,-1(D)
+ POPJ P,
+
+\f; BLOCK STRUCTURE SUBROUTINES FOR MUDDLE
+
+IMFUNCTION BLK,SUBR,BLOCK
+
+ ENTRY 1
+
+ GETYP A,(AB) ;CHECK TYPE OF ARG
+ CAIE A,TOBLS ;IS IT AN OBLIST
+ CAIN A,TLIST ;OR A LIAT
+ JRST .+2
+ JRST WTYP1
+ MOVSI A,TATOM ;LOOK UP OBLIST
+ MOVE B,IMQUOTE OBLIST
+ PUSHJ P,IDVAL ;GET VALUE
+ PUSH TP,A
+ PUSH TP,B
+ MOVE PVP,PVSTOR+1
+ PUSH TP,.BLOCK(PVP) ;HACK THE LIST
+ PUSH TP,.BLOCK+1(PVP)
+ MCALL 2,CONS ;CONS THE LIST
+ MOVE PVP,PVSTOR+1
+ MOVEM A,.BLOCK(PVP) ;STORE IT BACK
+ MOVEM B,.BLOCK+1(PVP)
+ PUSH TP,$TATOM
+ PUSH TP,IMQUOTE OBLIST
+ PUSH TP,(AB)
+ PUSH TP,1(AB)
+ MCALL 2,SET ;SET OBLIST TO ARG
+ JRST FINIS
+
+MFUNCTION ENDBLOCK,SUBR
+
+ ENTRY 0
+
+ MOVE PVP,PVSTOR+1
+ SKIPN B,.BLOCK+1(PVP) ;IS THE LIST NIL?
+ JRST BLKERR ;YES, LOSE
+ HRRZ C,(B) ;CDR THE LIST
+ HRRZM C,.BLOCK+1(PVP)
+ PUSH TP,$TATOM ;NOW RESET OBLIST
+ PUSH TP,IMQUOTE OBLIST
+ HLLZ A,(B) ;PUSH THE TYPE OF THE CAR
+ PUSH TP,A
+ PUSH TP,1(B) ;AND VALUE OF CAR
+ MCALL 2,SET
+ JRST FINIS
+
+BLKERR: ERRUUO EQUOTE UNMATCHED
+
+BADLST: ERRUUO EQUOTE NIL-LIST-OF-OBLISTS
+\f;SUBROUTINE TO CREATE CHARACTER STRING GOODIE
+
+CHMAK: MOVE A,-1(P)
+ ADDI A,4
+ IDIVI A,5
+ PUSHJ P,IBLOCK
+ MOVEI C,-1(P) ;FIND START OF CHARS
+ HLRE E,B ; - LENGTH
+ ADD C,E ;C POINTS TO START
+ MOVE D,B ;COPY VECTOR RESULT
+ JUMPGE D,NULLST ;JUMP IF EMPTY
+ MOVE A,(C) ;GET ONE
+ MOVEM A,(D)
+ ADDI C,1 ;BUMP POINTER
+ AOBJN D,.-3 ;COPY
+NULLST: MOVSI C,TCHRS+.VECT. ;GET TYPE
+ MOVEM C,(D) ;CLOBBER IT IN
+ MOVE A,-1(P) ; # WORDS
+ HRLI A,TCHSTR
+ HRLI B,010700
+ MOVMM E,-1(P) ; SO IATM1 WORKS
+ SOJA B,IATM1 ;RETURN
+
+; SUBROUTINE TO READ FIVE CHARS FROM STRING.
+; TWO CALLS, ONE WITH A POINTING TO LIST ELEMENT,
+; THE OTHER WITH B POINTING TO PAIR. SKIPS IF WINNER, ELSE DOESNT
+
+NXTDCL: GETYP B,(A) ;CHECK TYPE
+ CAIE B,TDEFER ;LOSE IF NOT DEFERRED
+ POPJ P,
+
+ MOVE B,1(A) ;GET REAL BYTE POINTER
+CHRWRD: PUSH P,C
+ GETYP C,(B) ;CHECK IT IS CHSTR
+ CAIE C,TCHSTR
+ JRST CPOPJC ;NO, QUIT
+ PUSH P,D
+ PUSH P,E
+ PUSH P,0
+ MOVEI E,0 ;INITIALIZE DESTINATION
+ HRRZ C,(B) ; GET CHAR COUNT
+ JUMPE C,GOTDCL ; NULL, FINISHED
+ MOVE B,1(B) ;GET BYTE POINTER
+ MOVE D,[440700,,E] ;BYTE POINT TO E
+CHLOOP: ILDB 0,B ; GET A CHR
+ IDPB 0,D ;CLOBBER AWAY
+ SOJE C,GOTDCL ; JUMP IF DONE
+ TLNE D,760000 ; SKIP IF WORD FULL
+ JRST CHLOOP ; MORE THAN 5 CHARS
+ TRO E,1 ; TURN ON FLAG
+
+GOTDCL: MOVE B,E ;RESULT TO B
+ AOS -4(P) ;SKIP RETURN
+CPOPJ0: POP P,0
+ POP P,E
+ POP P,D
+CPOPJC: POP P,C
+ POPJ P,
+
+\f;ROUTINES TO DEFINE AND HANDLE LINKS
+
+MFUNCTION LINK,SUBR
+ ENTRY
+ CAML AB,[-6,,0] ;NO MORE THAN 3 ARGS
+ CAML AB,[-2,,0] ;NO LESS THAN 2 ARGS
+ JRST WNA
+ CAML AB,[-4,,0] ;ONLY TWO ARGS SUPPLIED ?
+ JRST GETOB ;YES, GET OBLIST FROM CURRENT PATH
+ MOVE A,2(AB)
+ MOVE B,3(AB)
+ MOVE C,5(AB)
+ JRST LINKIN
+GETOB: MOVSI A,TATOM
+ MOVE B,IMQUOTE OBLIST
+ PUSHJ P,IDVAL
+ CAMN A,$TOBLS
+ JRST LINKP
+ CAME A,$TLIST
+ JRST BADOBL
+ JUMPE B,BADLST
+ GETYPF A,(B)
+ MOVE B,(B)+1
+LINKP: MOVE C,B
+ MOVE A,2(AB)
+ MOVE B,3(AB)
+LINKIN: PUSHJ P,IINSRT
+ CAMN A,$TFALSE ;LINK NAME ALREADY USED ?
+ JRST ALRDY ;YES, LOSE
+ MOVE C,B
+ MOVE A,(AB)
+ MOVE B,1(AB)
+ PUSHJ P,CSETG
+ JRST FINIS
+
+
+ILINK: HLRE A,B
+ SUBM B,A ;FOUND A LINK ?
+ MOVE A,(A)
+ TRNE A,LNKBIT
+ JRST .+3
+ MOVSI A,TATOM
+ POPJ P, ;NO, FINISHED
+ MOVSI A,TATOM
+ PUSHJ P,IGVAL ;GET THE LINK'S DESTINATION
+ CAME A,$TUNBOUND ;WELL FORMED LINK ?
+ POPJ P, ;YES
+ ERRUUO EQUOTE BAD-LINK
+
+\f
+; THIS SUBROUTINE IMPURIFIES A PURE ATOM TO ALLOW MODIFICATION OF SYSTEM SUBRS
+
+IMPURIFY:
+ PUSH TP,$TATOM
+ PUSH TP,B
+ MOVE C,B
+ MOVEI 0,(C)
+ CAIGE 0,HIBOT
+ JRST RTNATM ; NOT PURE, RETURN
+ JRST IMPURX
+
+; ROUTINE PASSED TO GCHACK
+
+ATFIX: CAME D,(TP)
+ CAMN D,-2(TP)
+ JRST .+2
+ POPJ P,
+
+ ASH C,1
+ ADD C,TYPVEC+1 ; COMPUTE SAT
+ HRRZ C,(C)
+ ANDI C,SATMSK
+ CAIE C,SATOM
+CPOPJ: POPJ P,
+
+ SUB D,-2(TP)
+ ADD D,-4(TP)
+ SKIPE B
+ MOVEM D,1(B)
+ POPJ P,
+
+
+; SUBROUTINE TO FIND A BYTE STRINGS DOPE WORD
+; RECEIVES POINTER TO PAIR CONNTAINIGN CHSTR IN C, RETURNS DOPE WORD IN A
+
+BYTDOP: PUSH P,B ; SAVE SOME ACS
+ PUSH P,D
+ PUSH P,E
+ MOVE B,1(C) ; GET BYTE POINTER
+ LDB D,[360600,,B] ; POSITION TO D
+ LDB E,[300600,,B] ; AND BYTE SIZE
+ MOVEI A,(E) ; A COPY IN A
+ IDIVI D,(E) ; D=> # OF BYTES IN WORD 1
+ HRRZ E,(C) ; GET LENGTH
+ SUBM E,D ; # OF BYTES IN OTHER WORDS
+ JUMPL D,BYTDO1 ; NEAR DOPE WORD
+ MOVEI B,36. ; COMPUTE BYTES PER WORD
+ IDIVM B,A
+ ADDI D,-1(A) ; NOW COMPUTE WORDS
+ IDIVI D,(A) ; D/ # NO. OF WORDS PAST 1ST
+ ADD D,1(C) ; D POINTS TO DOPE WORD
+ MOVEI A,2(D)
+
+BYTDO2: POP P,E
+ POP P,D
+ POP P,B
+ POPJ P,
+BYTDO1: MOVEI A,2(B)
+ JRST BYTDO2
+
+; 1) IMPURIFY ITS OBLIST LIST
+
+IMPURX: HRRZ B,2(C) ; PICKUP OBLIST IF IT EXISTS
+ JUMPE B,IMPUR0 ; NOT ON ONE, IGNORE THIS CODE
+
+ HRRO E,(B)
+ PUSH TP,$TOBLS ; SAVE BUCKET
+ PUSH TP,E
+
+ MOVE B,(E) ; GET NEXT ONE
+IMPUR4: MOVEI 0,(B)
+ MOVE D,1(B)
+ CAME D,-2(TP)
+ JRST .+3
+ SKIPE GPURFL ; IF PURIFY SMASH THE OBLIST SLOT TO PROTECT
+ ; ATOM
+ HRRM D,1(B)
+ CAIGE 0,HIBOT ; SKIP IF PURE
+ JRST IMPUR3 ; FOUND IMPURE NESS, SKIP IT
+ HLLZ C,(B) ; SET UP ICONS CALL
+ HRRZ E,(B)
+IMPR1: PUSHJ P,ICONS ; CONS IT UP
+IMPR2: HRRZ E,(TP) ; RETRV PREV
+ HRRM B,(E) ; AND CLOBBER
+IMPUR3: MOVE D,1(B)
+ CAMN D,-2(TP) ; HAVE GOTTEN TO OUR SLOT?
+ JRST IMPPR3
+ MOVSI 0,TLIST
+ MOVEM 0,-1(TP) ; FIX TYPE
+ HRRZM B,(TP) ; STORE GOODIE
+ HRRZ B,(B) ; CDR IT
+ JUMPN B,IMPUR4 ; LOOP
+IMPPR3: SUB TP,[2,,2] ; FLUSH TP CRUFT
+
+; 1.5) IMPURIFY GLOBAL HASH BUCKET, A REAL PAIN
+
+IMPUR0: MOVE C,(TP) ; GET ATOM
+
+ HRRZ B,2(C)
+ MOVE B,(B)
+ ADD C,[3,,3] ; POINT TO PNAME
+ HLRE A,C ; GET LNTH IN WORDS OF PNAME
+ MOVNS A
+; PUSH P,[SETZ IMPUR2] ; FAKE OUT ILOOKC
+ XMOVEI 0,IMPUR2
+ PUSH P,0
+ PUSH P,(C) ; PUSH UP THE PNAME
+ AOBJN C,.-1
+ PUSH P,A ; NOW THE COUNT
+ MOVSI A,TOBLS
+ JRST ILOOKC ; GO FIND BUCKET
+
+IMPUR2: JUMPE B,IMPUR1
+ JUMPE 0,IMPUR1 ; YUP, DONE
+ HRRZ C,0
+ CAIG C,HIBOT ; SKIP IF PREV IS PURE
+ JRST IMPUR1
+
+ MOVE B,0
+ PUSH P,GPURFL ; PRERTEND OUT OF PURIFY
+ HLRE C,B
+ SUBM B,C
+ HRRZ C,(C) ; ARE WE ON PURIFY LIST
+ CAIG C,HIBOT ; IF SO, WE ARE STILL PURIFY
+ SETZM GPURFL
+ PUSHJ P,IMPURIF ; RECURSE
+ POP P,GPURFL
+ MOVE B,(TP) ; AND RETURN ORIGINAL
+
+; 2) GENERATE A DUPLICATE ATOM
+
+IMPUR1: SKIPE GPURFL ; SEE IF IN PURIFY
+ JRST IMPUR7
+ HLRE A,(TP) ; GET LNTH OF ATOM
+ MOVNS A
+ PUSH P,A
+ PUSHJ P,IBLOCK ; GET NEW BLOCK FOR ATOM
+ PUSH TP,$TATOM
+ PUSH TP,B
+ HRL B,-2(TP) ; SETUP BLT
+ POP P,A
+ ADDI A,(B) ; END OF BLT
+ BLT B,(A) ; CLOBBER NEW ATOM
+ MOVSI B,.VECT. ; TURN ON BIT FOR GCHACK
+ IORM B,(A)
+
+; 3) NOW COPY GLOBAL VALUE
+
+IMPUR7: MOVE B,(TP) ; ATOM BACK
+ GETYP 0,(B)
+ SKIPE A,1(B) ; NON-ZER POINTER?
+ CAIN 0,TUNBOU ; BOUND?
+ JRST IMPUR5 ; NO, DONT COPY GLOB VAL
+ PUSH TP,(A)
+ PUSH TP,1(A)
+ PUSH TP,$TATOM
+ PUSH TP,B
+ SETZM (B)
+ SETZM 1(B)
+ SKIPN GPURFL ; HERE IS SOME CODE NEEDED FOR PURIFY
+ JRST IMPUR8
+ PUSH P,LPVP
+ MOVE PVP,PVSTOR+1
+ PUSH P,AB ; GET AB BACK
+ MOVE AB,ABSTO+1(PVP)
+IMPUR8: PUSHJ P,BSETG ; SETG IT
+ SKIPN GPURFL
+ JRST .+3 ; RESTORE SP AND AB FOR PURIFY
+ POP P,TYPNT
+ POP P,SP
+ SUB TP,[2,,2] ; KILL ATOM SLOTS ON TP
+ POP TP,C ;POP OFF VALUE SLOTS
+ POP TP,A
+ MOVEM A,(B) ; FILL IN SLOTS ON GLOBAL STACK
+ MOVEM C,1(B)
+IMPUR5: SKIPE GPURFL ; FINISH OFF DIFFERENTLY FOR PURIFY
+ JRST IMPUR9
+
+ PUSH TP,$TFIX ;SAVE OLD ATOM WITH FUNNY TYPE TO AVOID LOSSAGE
+ PUSH TP,-3(TP)
+ PUSH TP,$TFIX ; OTHER KIND OF POINTER ALSO
+ HLRE 0,-1(TP)
+ HRRZ A,-1(TP)
+ SUB A,0
+ PUSH TP,A
+
+; 4) UPDATE ALL POINTERS TO THIS ATOM
+
+ MOVE A,[PUSHJ P,ATFIX] ; INS TO PASS TO GCHACK
+ MOVEI PVP,1 ; SAY MIGHT BE NON-ATOMS
+ PUSHJ P,GCHACK
+ SUB TP,[6,,6]
+
+RTNATM: POP TP,B
+ POP TP,A
+ POPJ P,
+
+IMPUR9: SUB TP,[2,,2]
+ POPJ P, ; RESTORE AND GO
+
+
+
+END
--- /dev/null
+TITLE BUFMOD BUFFER MODULE
+
+RELOCA
+
+; HERE TO DEFINE MUDDLES BUFFER SPACE
+
+.GLOBAL STRBUF,STRPAG
+
+HERE==$.+1777
+
+.LOP ANDCM HERE 1777
+
+STRBUF==.LVAL1
+.LOP <ASH @> STRBUF <,-10.>
+STRPAG==.LVAL1
+
+END
+\f\ 3\ 3\ 3\ 3
\ No newline at end of file
--- /dev/null
+%% 30 December 1980 23:47:54
+Type ? for help.
+White to move: p-k4
+Black to move: pb
+1. ... P-K4 ; (1.0 85%)
+White to move: p-q3
+2. ... P-Q4 ; (1.7 93%)
+White to move: n-kb4
+; Impossible
+White to move: n-kb3
+; T-reject B-Q3
+3. ... N-QB3 ; (3.8 91%)
+White to move: b-k2
+4. ... P-Q5 ; (3.0 94%)
+White to move: o-o
+; T-reject N-QN5
+5. ... B-Q3 ; (6.9 94%)
+White to move: p-qb3
+; Foo!
+6. ... PxP ; (3.0 91%)
+White to move: nxp(qb3)
+; T-reject N-Q5
+7. ... B-QN5 ; (8.3 88%)
+White to move: b-n5
+8. ... N-KB3 ; (3.4 91%)
+White to move: p-qr3
+9. ... B-QB4 ; (5.1 95%)
+White to move: p-qn4
+10. ... B-QN3 ; (5.4 92%)
+White to move: q-r4
+11. ... O-O ; (4.4 92%)
+White to move: p-n5
+; T-reject N-Q5 N-QR4 N-QN1 ...
+; Foo!
+12. ... N-Q5 ; (11.6 90%)
+White to move: r-k1
+; Ambiguous
+White to move: r(b1)-k1
+13. ... NxB+ ; (3.9 94%)
+White to move: rxn
+14. ... QxP ; (4.6 77%)
+White to move: q-b2
+15. ... Q-Q3 ; (6.3 87%)
+White to move: r-q1
+; T-reject QxP
+16. ... Q-QB4 ; (9.5 91%)
+White to move: r(k2)-q2
+; T-reject QxP(QR6)
+17. ... B-QR4 ; (7.0 92%)
+White to move: r-q8
+18. ... QxN ; (6.1 95%)
+White to move: qxq
+19. ... BxQ ; (3.5 92%)
+White to move: b-k3
+20. ... NxP ; (5.4 90%)
+White to move: nxp
+21. ... BxN ; (4.5 91%)
+White to move: p-b3
+22. ... N-QB6 ; (4.6 95%)
+White to move: r-q2
+; Ambiguous
+White to move: r(q1)-q2
+; T-reject NxP
+; M-reject RxR
+23. ... NxP ; (6.3 86%)
+White to move: b-b5
+; M-reject RxR
+24. ... B-Q3 ; (19.7 91%)
+White to move: bxb
+25. ... RxR ; (2.8 92%)
+White to move: u
+Black to move: u
+White to move: rxr
+Black to move: pb
+25. ... BxR ; (1.6 95%)
+White to move: bxb
+26. ... KxB ; (2.2 94%)
+White to move: r-q8
+27. ... K-K2 ; (0.0 92%)
+White to move: r-r8
+28. ... NxP ; (1.6 94%)
+White to move: rxp
+29. ... P-KN4 ; (3.2 91%)
+White to move: r-r6
+30. ... R-QN1 ; (1.9 90%)
+White to move: k-b2
+31. ... K-Q2 ; (3.2 89%)
+White to move: r-b6
+; Ambiguous
+White to move: r-kb6
+32. ... K-K2 ; (1.6 93%)
+White to move: r-b5
+33. ... BxR ; (1.4 96%)
+White to move: u
+Black to move: u
+White to move: r-r6
+; Ambiguous
+White to move: r-kr6
+Black to move: pb
+33. ... K-Q2 ; (3.2 95%)
+White to move: k-k3
+34. ... P-QB4 ; (5.0 91%)
+White to move: k-q3
+35. ... K-QB2 ; (1.8 88%)
+White to move: k-b3
+36. ... P-QB5 ; (2.2 87%)
+White to move: k-n4
+; T-reject N-QN8 N-QB7+
+; Foo!
+37. ... N-QN8 ; (3.2 88%)
+White to move: kxp
+38. ... P-QN4+ ; (1.8 96%)
+White to move: k-n4
+; T-reject K-QN2 R-QR1
+39. ... P-KB4 ; (3.4 92%)
+White to move: r-kn6
+40. ... P-KN5 ; (2.0 76%)
+White to move: pxp
+41. ... PxP ; (1.8 95%)
+White to move: r-n7
+42. ... K-QN3 ; (1.2 96%)
+White to move: r-b7
+; Ambiguous
+White to move: r-kb7
+43. ... R-QR1 ; (2.3 95%)
+White to move: r-b1
+44. ... N-Q7 ; (2.4 85%)
+White to move: r-q1
+45. ... N-K5 ; (3.7 72%)
+White to move: p-r3
+46. ... PxP ; (2.7 95%)
+White to move: pxp
+47. ... BxP ; (2.5 90%)
+White to move: r-q3
+48. ... N-KB7 ; (4.4 87%)
+White to move: rq-6
+; Move what??
+White to move: r-q6
+; T-reject K-QB2 K-QN2
+; Foo!
+49. ... K-QB2 ; (2.2 85%)
+White to move: r-kr6
+50. ... P-QR3 ; (2.3 92%)
+White to move: r-r7
+51. ... K-QN3 ; (1.4 95%)
+White to move: r-kb7
+52. ... N-K5 ; (5.0 93%)
+White to move: r-b5
+53. ... BxR ; (2.0 92%)
+White to move: u
+Black to move: u
+White to move: r-b4
+Black to move: pb
+53. ... N-Q7 ; (4.6 95%)
+White to move: r-b6
+54. ... K-QN2 ; (1.3 88%)
+White to move: k-r5
+55. ... N-K5 ; (2.9 94%)
+White to move: r-b7
+56. ... K-QB3 ; (1.0 95%)
+White to move: r-r7
+; Ambiguous
+White to move: r-kr7
+57. ... N-KN4 ; (2.8 93%)
+White to move: r-r5
+; T-reject N-KB6 N-K5 N-K3 ...
+; Foo!
+58. ... R-KN1 ; (4.4 85%)
+White to move: kxp
+59. ... R-QR1+ ; (0.7 8%)
+; Checkmate.
--- /dev/null
+
+
+<SETG DECL-RESTED 1>
+
+<SETG DECL-ELEMENT 2>
+
+<SETG DECL-ITEM-COUNT 3>
+
+<SETG DECL-IN-REST 4>
+
+<SETG DECL-IN-COUNT-VEC 5>
+
+<SETG DECL-REST-VEC 6>
+
+<MANIFEST DECL-RESTED
+ DECL-ELEMENT
+ DECL-ITEM-COUNT
+ DECL-IN-REST
+ DECL-IN-COUNT-VEC
+ DECL-REST-VEC>
+
+<SETG HIGHBOUND 2>
+
+<SETG LOWBOUND 1>
+
+<MANIFEST HIGHBOUND LOWBOUND>
+
+<SETG ALLWORDS '<PRIMTYPE WORD>>
+
+<DEFINE TASTEFUL-DECL (D "AUX" TEM)
+ <COND (<OR <NOT .D> <==? .D NO-RETURN>> ANY)
+ (<AND <TYPE? .D ATOM> <VALID-TYPE? .D>> .D)
+ (<AND <OR <TYPE? <SET TEM .D> ATOM> <SET TEM <ISTYPE? .D>>>
+ <GET .TEM DECL>>
+ .TEM)
+ (<TYPE? .D FORM SEGMENT>
+ <COND (<LENGTH? .D 1>
+ <OR <AND <EMPTY? .D> ANY> <TASTEFUL-DECL <1 .D>>>)
+ (<==? <1 .D> FIX> FIX)
+ (<AND <==? <LENGTH .D> 2> <==? <1 .D> NOT>> ANY)
+ (<TYPE? .D SEGMENT>
+ <CHTYPE <MAPF ,LIST ,TASTEFUL-DECL .D> SEGMENT>)
+ (ELSE <CHTYPE <MAPF ,LIST ,TASTEFUL-DECL .D> FORM>)>)
+ (<TYPE? .D VECTOR>
+ [<COND (<==? <1 .D> OPT> OPTIONAL) (ELSE <1 .D>)>
+ !<MAPF ,LIST ,TASTEFUL-DECL <REST .D>>])
+ (ELSE .D)>>
+
+<DEFINE TMERGE (P1 P2)
+ <COND (<OR <AND <TYPE? .P1 FORM SEGMENT>
+ <==? <LENGTH .P1> 2>
+ <TYPE? <2 .P1> LIST>>
+ <AND <TYPE? .P2 FORM SEGMENT>
+ <==? <LENGTH .P2> 2>
+ <TYPE? <2 .P2> LIST>>
+ <CTMATCH .P1 .P2 <> <> T>>
+ <CTMATCH .P1 .P2 T T <>>)
+ (<=? .P1 '<NOT ANY>> .P2)
+ (<=? .P2 '<NOT ANY>> .P1)
+ (ELSE <CHTYPE (OR !<PUT-IN <PUT-IN () .P1> .P2>) FORM>)>>
+
+<DEFINE TYPE-AND (P1 P2) <CTMATCH .P1 .P2 T <> <>>>
+
+<DEFINE TMATCH (P1 P2) <CTMATCH .P1 .P2 <> <> <>>>
+
+<DEFINE CTMATCH (P1 P2 ANDF ORF MAYBEF)
+ #DECL ((ANDF ORF MAYBEF) <SPECIAL <OR FALSE ATOM>>)
+ <DTMATCH .P1 .P2>>
+
+<DEFINE DTMATCH (PAT1 PAT2)
+ <OR .PAT1 <SET PAT1 ANY>>
+ <OR .PAT2 <SET PAT2 ANY>>
+ <COND (<=? .PAT1 .PAT2> .PAT1)
+ (<TYPE? <SET PAT1 <VTS .PAT1>> ATOM> <TYPMAT .PAT1 <VTS .PAT2>>)
+ (<TYPE? <SET PAT2 <VTS .PAT2>> ATOM> <TYPMAT .PAT2 .PAT1>)
+ (<AND <TYPE? .PAT1 FORM SEGMENT> <TYPE? .PAT2 FORM SEGMENT>>
+ <TEXP1 .PAT1 .PAT2>)
+ (ELSE #FALSE (BAD-SYNTAX!-ERRORS))>>
+
+<DEFINE VTS (X)
+ <OR <AND <TYPE? .X ATOM>
+ <OR <VALID-TYPE? .X>
+ <MEMQ .X '![STRUCTURED LOCATIVE APPLICABLE ANY!]>>
+ .X>
+ <AND <TYPE? .X ATOM> <GET .X DECL>>
+ .X>>
+
+<DEFINE 2-ELEM (OBJ)
+ #DECL ((OBJ) <PRIMTYPE LIST>)
+ <AND <NOT <EMPTY? .OBJ>> <NOT <EMPTY? <REST .OBJ>>>>>
+
+<DEFINE TYPMAT (TYP PAT "AUX" TEM)
+ #DECL ((TYP) ATOM)
+ <OR <SET TEM
+ <COND (<TYPE? .PAT ATOM>
+ <OR <AND <==? .PAT ANY> <COND (.ORF ANY) (ELSE .TYP)>>
+ <AND <==? .TYP ANY> <COND (.ORF ANY) (ELSE .PAT)>>
+ <AND <=? .PAT .TYP> .TYP>
+ <STRUC .TYP .PAT T>
+ <STRUC .PAT .TYP <>>>)
+ (<TYPE? .PAT FORM SEGMENT> <TEXP1 .PAT .TYP>)
+ (ELSE #FALSE (BAD-SYNTAX!-ERRORS))>>
+ <AND <EMPTY? .TEM>
+ <OR <AND <N==? <SET TEM <VTS .TYP>> .TYP> <DTMATCH .TEM .PAT>>
+ <AND <N==? <SET TEM <VTS .PAT>> .PAT>
+ <TYPMAT .TYP .TEM>>>>>>
+
+"\f"
+
+<DEFINE TEXP1 (FORT PAT)
+ #DECL ((FORT) <OR FORM SEGMENT>)
+ <COND (<EMPTY? .FORT> #FALSE (EMPTY-TYPE-FORM!-ERRORS))
+ (<MEMQ <1 .FORT> '![OR AND NOT PRIMTYPE!]> <ACTORT .FORT .PAT>)
+ (<AND <==? <1 .FORT> QUOTE> <2-ELEM .FORT>>
+ <DTMATCH <GEN-DECL <2 .FORT>> .PAT>)
+ (ELSE <FORMATCH .FORT .PAT>)>>
+
+<DEFINE ACTORT (FORT PAT "AUX" (ACTOR <1 .FORT>) TEM1)
+ #DECL ((FORT) <PRIMTYPE LIST>)
+ <COND
+ (<==? .ACTOR OR>
+ <COND
+ (<EMPTY? <SET FORT <REST .FORT>>>
+ #FALSE (EMPTY-OR-MATCH!-ERRORS))
+ (ELSE
+ <REPEAT (TEM (AL ()))
+ #DECL ((AL) LIST)
+ <COND
+ (<OR <AND <TYPE? <SET TEM <1 .FORT>> ATOM>
+ <PROG ()
+ <COND (<VALID-TYPE? .TEM>)
+ (<SET TEM1 <GET .TEM DECL>>
+ <SET TEM .TEM1>
+ <AND <TYPE? .TEM ATOM> <AGAIN>>)
+ (ELSE T)>>
+ <SET TEM <TYPMAT .TEM .PAT>>>
+ <AND <TYPE? .TEM FORM SEGMENT> <SET TEM <TEXP1 .TEM .PAT>>>>
+ <COND (<==? .ACTOR OR>
+ <COND (.ANDF
+ <COND (.TEM
+ <COND (<==? .TEM ANY> <RETURN ANY>)>
+ <COND (.ORF <SET AL <PUT-IN .AL .TEM>>)
+ (ELSE
+ <OR <MEMBER .TEM .AL>
+ <SET AL (.TEM !.AL)>>)>)>)
+ (ELSE <RETURN T>)>)>)
+ (<NOT <EMPTY? .TEM>> <RETURN .TEM>)>
+ <COND (<EMPTY? <SET FORT <REST .FORT>>>
+ <RETURN <AND <NOT <EMPTY? .AL>>
+ <COND (<EMPTY? <REST .AL>> <1 .AL>)
+ (ELSE
+ <ORSORT <CHTYPE (.ACTOR !.AL)
+ FORM>>)>>>)>>)>)
+ (<==? .ACTOR NOT> <NOT-IT .FORT .PAT>)
+ (ELSE <PTACT .FORT .PAT>)>>
+
+<DEFINE PTACT (FORTYP PAT)
+ <COND (<TYPE? .FORTYP FORM SEGMENT>
+ <COND (<AND <2-ELEM .FORTYP> <==? <1 .FORTYP> PRIMTYPE>>
+ <PRIMATCH .FORTYP .PAT>)
+ (ELSE #FALSE (BAD-SYNTAX!-ERRORS))>)
+ (<TYPE? .FORTYP ATOM> <TYPMAT .FORTYP .PAT>)
+ (ELSE #FALSE (BAD-SYNTAX!-ERRORS))>>
+
+"\f"
+
+<DEFINE STRUC (WRD TYP ACTAND)
+ #DECL ((TYP) ATOM)
+ <PROG ()
+ <COND (<COND (<==? .WRD STRUCTURED>
+ <COND (<==? .TYP LOCATIVE> <>)
+ (<==? .TYP APPLICABLE>
+ <RETURN <COND (.ORF '<OR APPLICABLE STRUCTURED>)
+ (ELSE
+ '<OR RSUBR RSUBR-ENTRY FUNCTION CLOSURE MACRO>)>>)
+ (<AND <VALID-TYPE? .TYP>
+ <MEMQ <TYPEPRIM .TYP>
+ '![LIST VECTOR UVECTOR TEMPLATE STRING TUPLE
+ STORAGE BYTES!]>>)>)
+ (<==? .WRD LOCATIVE>
+ <MEMQ .TYP '![LOCL LOCAS LOCD LOCV LOCU LOCS LOCA!]>)
+ (<==? .WRD APPLICABLE>
+ <COND (<==? .TYP LOCATIVE> <RETURN <>>)
+ (<==? .TYP STRUCTURED>
+ <RETURN <STRUC .TYP .WRD .ACTAND>>)
+ (<MEMQ .TYP
+ '![RSUBR SUBR FIX FSUBR FUNCTION
+ RSUBR-ENTRY MACRO CLOSURE
+ OFFSET!]>)>)>
+ <COND (.ORF .WRD) (ELSE .TYP)>)
+ (ELSE
+ <COND (<AND .ORF <NOT .ACTAND>> <ORSORT <FORM OR .WRD .TYP>>)
+ (ELSE <>)>)>>>
+
+<DEFINE PRIMATCH (PTYP PAT "AUX" PAT1 ACTOR TEM)
+ #DECL ((PAT1) <PRIMTYPE LIST>
+ (PTYP) <OR <FORM ANY ANY> <SEGMENT ANY ANY>>)
+ <COND (<AND <TYPE? .PAT FORM SEGMENT>
+ <SET PAT1 .PAT>
+ <==? <LENGTH .PAT1> 2>
+ <==? <1 .PAT1> PRIMTYPE>>
+ <COND (<==? <2 .PAT1> <2 .PTYP>> .PAT1)
+ (ELSE <COND (.ORF <ORSORT <FORM OR .PAT1 .PTYP>>)>)>)
+ (<TYPE? .PAT ATOM>
+ <COND (<==? .PAT ANY> <COND (.ORF ANY) (.ANDF .PTYP) (ELSE T)>)
+ (<MEMQ .PAT '![STRUCTURED LOCATIVE APPLICABLE!]>
+ <COND (<STRUC .PAT <2 .PTYP> T>
+ <COND (.ORF .PAT) (ELSE .PTYP)>)
+ (ELSE <COND (.ORF <ORSORT <FORM OR .PAT .PTYP>>)>)>)
+ (<AND <VALID-TYPE? .PAT>
+ <==? <TYPEPRIM .PAT> <2 .PTYP>>
+ <COND (.ORF .PTYP) (ELSE .PAT)>>)
+ (ELSE <COND (.ORF <ORSORT <FORM OR .PTYP .PAT>>)>)>)
+ (<AND <TYPE? .PAT FORM SEGMENT>
+ <SET PAT1 .PAT>
+ <NOT <EMPTY? .PAT1>>>
+ <COND (<==? <SET ACTOR <1 .PAT1>> OR> <ACTORT .PAT .PTYP>)
+ (<==? .ACTOR NOT>
+ <COND (.ORF <NOT-IT .PAT .PTYP>)
+ (ELSE
+ <SET TEM <PRIMATCH .PTYP <2 .PAT1>>>
+ <COND (<AND <NOT .TEM> <EMPTY? .TEM>> .PTYP)
+ (<NOT .TEM> .TEM)
+ (<N=? .TEM .PTYP> ANY)>)>)
+ (<SET TEM <PRIMATCH .PTYP <1 .PAT1>>>
+ <COND (.ORF .TEM)
+ (.ANDF <COND (<TYPE? .PAT FORM>
+ <FORM .TEM !<REST .PAT1>>)
+ (ELSE
+ <CHTYPE (.TEM !<REST .PAT1>) SEGMENT>)>)
+ (ELSE T)>)>)>>
+
+"\f"
+
+<DEFINE NOT-IT (NF PAT "AUX" T1)
+ #DECL ((NF) <OR FORM SEGMENT>)
+ <COND (<AND <TYPE? .PAT FORM SEGMENT>
+ <NOT <EMPTY? .PAT>>
+ <OR <==? <1 .PAT> OR> <==? <1 .PAT> AND>>>
+ <ACTORT .PAT .NF>)
+ (ELSE
+ <COND (<==? <LENGTH .NF> 2>
+ <COND (<NOT <SET T1 <TYPE-AND <2 .NF> .PAT>>>
+ <COND (.ORF .NF) (.ANDF .PAT) (ELSE T)>)
+ (<==? <2 .NF> ANY> <COND (.ORF .PAT)>)
+ (<AND <N==? .T1 .PAT>
+ <N=? .T1 .PAT>
+ <N=? <CANONICAL-DECL .PAT>
+ <CANONICAL-DECL .T1>>>
+ <COND (<OR .ANDF .ORF> ANY) (ELSE T)>)
+ (.ORF ANY)>)
+ (ELSE #FALSE (BAD-SYNTAX!-ERRORS))>)>>
+
+<DEFINE NOTIFY (D)
+ <COND (<AND <TYPE? .D FORM SEGMENT>
+ <==? <LENGTH .D> 2>
+ <==? <1 .D> NOT>>
+ <2 .D>)
+ (ELSE <FORM NOT .D>)>>
+"\f"
+
+<DEFINE FORMATCH (FRM RPAT "AUX" TEM (PAT .RPAT) EX)
+ #DECL ((FRM) <OR <FORM ANY> <SEGMENT ANY>>
+ (RPAT) <OR ATOM FORM LIST SEGMENT VECTOR FIX>)
+ <COND
+ (<AND <TYPE? .RPAT ATOM> <TYPE? <1 .FRM> ATOM> <==? <1 .FRM> .RPAT>>
+ <COND (.ORF .RPAT) (ELSE .FRM)>)
+ (ELSE
+ <COND (<TYPE? .RPAT ATOM> <SET PAT <SET EX <GET .RPAT DECL '.RPAT>>>)
+ (ELSE <SET RPAT <1 .PAT>>)>
+ <COND
+ (<TYPE? .PAT ATOM>
+ <SET TEM
+ <COND (<AND .ORF <NOT <CTMATCH .PAT <1 .FRM> <> <> T>>>
+ <ORSORT <FORM OR .RPAT .FRM>>)
+ (ELSE
+ <COND (<TYPE? <1 .FRM> ATOM> <TYPMAT <1 .FRM> .PAT>)
+ (<TYPE? <1 .FRM> FORM> <ACTORT <1 .FRM> .PAT>)>)>>
+ <COND (<AND .ANDF <NOT .ORF> .TEM>
+ <COND (<TYPE? .FRM FORM> <CHTYPE (.TEM !<REST .FRM>) FORM>)
+ (ELSE <CHTYPE (.TEM !<REST .FRM>) SEGMENT>)>)
+ (ELSE .TEM)>)
+ (<TYPE? .PAT FORM SEGMENT>
+ <COND (<MEMQ <1 .PAT> '![OR AND NOT PRIMTYPE!]> <ACTORT .PAT .FRM>)
+ (ELSE
+ <COND (<AND <==? <LENGTH .PAT> 2> <TYPE? <2 .PAT> LIST>>
+ <WRDFX .PAT .FRM .RPAT>)
+ (<AND <G=? <LENGTH .PAT> 2> <TYPE? <2 .PAT> FIX>>
+ <BYTES-HACK .PAT .FRM .RPAT>)
+ (<AND <G=? <LENGTH .FRM> 2> <TYPE? <2 .FRM> FIX>>
+ <BYTES-HACK .FRM .PAT <1 .FRM>>)
+ (<AND .ORF
+ <ASSIGNED? EX>
+ <NOT <CTMATCH .RPAT .FRM <> <> T>>>
+ <ORSORT <FORM OR .RPAT .FRM>>)
+ (<AND .ORF <NOT <CTMATCH .PAT .FRM <> <> T>>>
+ <ORSORT <FORM OR .PAT .FRM>>)
+ (ELSE
+ <SET TEM <ELETYPE .PAT .FRM .RPAT>>
+ <AND <ASSIGNED? EX>
+ <TYPE? .TEM FORM SEGMENT>
+ <G? <LENGTH .TEM> 1>
+ <==? <1 .TEM> OR>
+ <MAPR <>
+ <FUNCTION (EL)
+ <AND <=? <1 .EL> .EX>
+ <PUT .EL 1 .RPAT>
+ <MAPLEAVE>>>
+ <REST .TEM>>>
+ .TEM)>)>)>)>>
+
+"\f"
+
+<DEFINE BYTES-HACK (F1 F2 RPAT "AUX" FST TL TEM SEGF MLF1 MLF2)
+ #DECL ((F1 F2) <OR FORM SEGMENT> (MLF1 MLF2) FIX)
+ <SET SEGF <SEGANDOR .F1 .F2 .ORF>>
+ <COND (<OR <EMPTY? .F1> <EMPTY? .F2>> #FALSE (EMPTY-FORM-IN-DECL!-ERRORS))>
+ <SET FST
+ <COND (<TYPE? .RPAT ATOM>
+ <COND (<TYPE? <1 .F2> ATOM> <TYPMAT <1 .F2> .RPAT>)
+ (<TYPE? <1 .F2> FORM> <ACTORT <1 .F2> .RPAT>)
+ (ELSE #FALSE (BAD-SYNTAX!-ERRORS))>)
+ (<TYPE? .RPAT FORM> <ACTORT .RPAT <1 .F2>>)
+ (ELSE #FALSE (BAD-SYNTAX!-ERRORS))>>
+ <COND
+ (<NOT .FST> .FST)
+ (ELSE
+ <COND
+ (<CTMATCH .RPAT '<PRIMTYPE BYTES> <> <> <>>
+ <SET MLF1 <MINL .F1>>
+ <SET MLF2 <MINL .F2>>
+ <COND (<AND <G=? <LENGTH .F2> 2> <TYPE? <2 .F2> FIX>>
+ <COND (<CTMATCH <1 .F2> '<PRIMTYPE BYTES> <> <> <>>
+ <COND (.ORF
+ <COND (<==? <2 .F2> <2 .F1>>
+ <FOSE .SEGF .FST <2 .F1> <MIN .MLF1 .MLF2>>)
+ (ELSE <ORSORT <FORM OR .F1 .F2>>)>)
+ (<AND <==? <2 .F2> <2 .F1>>
+ <NOT <AND <TYPE? .F1 SEGMENT>
+ <TYPE? .F2 SEGMENT>
+ <N==? <2 .F1> <2 .F2>>>>>
+ <FOSE .SEGF .FST <2 .F1> <MAX .MLF1 .MLF2>>)>)
+ (ELSE #FALSE (BAD-SYNTAX!-ERRORS))>)
+ (<TMATCH .F2 '<PRIMTYPE BYTES>>
+ <COND (.ORF
+ <COND (<TMATCH .F2
+ <SET TEM
+ <COND (<0? .MLF1>
+ <FOSE .SEGF
+ <1 .F1>
+ '[REST FIX]>)
+ (ELSE
+ <FOSE .SEGF
+ <1 .F1>
+ [.MLF1 FIX]
+ '[REST FIX]>)>>>
+ <TYPE-MERGE .TEM .F2>)
+ (ELSE <ORSORT <FORM .F1 .F2>>)>)
+ (<TMATCH .F2
+ <COND (<0? .MLF1>
+ <FOSE .SEGF STRUCTURED '[REST FIX]>)
+ (ELSE
+ <FOSE .SEGF
+ STRUCTURED
+ [.MLF1 FIX]
+ '[REST FIX]>)>>
+ <FOSE .SEGF .FST <2 .F1> <MAX .MLF2 .MLF1>>)>)
+ (ELSE <COND (.ORF <ORSORT <FORM OR .F1 .F2>>) (ELSE <>)>)>)
+ (ELSE #FALSE (BAD-SYNTAX!-ERRORS))>)>>
+
+<DEFINE FOSE ("TUPLE" TUP "AUX" (FLG <1 .TUP>))
+ <COND (.FLG <CHTYPE (!<REST .TUP>) SEGMENT>)
+ (ELSE <CHTYPE (!<REST .TUP>) FORM>)>>
+
+<DEFINE SEGANDOR (F1 F2 ORF)
+ <COND (.ORF <AND <TYPE? .F1 SEGMENT> <TYPE? .F2 SEGMENT>>)
+ (ELSE <OR <TYPE? .F1 SEGMENT> <TYPE? .F2 SEGMENT>>)>>
+
+<DEFINE WRDFX (F1 F2 RPAT "AUX" FST TL)
+ #DECL ((F1 F2) <OR FORM SEGMENT>)
+ <COND (<OR <EMPTY? <SET F1 <CHTYPE .F1 FORM>>>
+ <EMPTY? <SET F2 <CHTYPE .F2 FORM>>>>
+ #FALSE (EMPTY-FORM-IN-DECL!-ERRORS))>
+ <SET FST
+ <COND (<TYPE? .RPAT ATOM>
+ <COND (<TYPE? <1 .F2> ATOM> <TYPMAT <1 .F2> .RPAT>)
+ (<TYPE? <1 .F2> FORM> <ACTORT <1 .F2> .RPAT>)
+ (ELSE #FALSE (BAD-SYNTAX!-ERRORS))>)
+ (<TYPE? .RPAT FORM> <ACTORT .RPAT <1 .F2>>)
+ (ELSE #FALSE (BAD-SYNTAX!-ERRORS))>>
+ <COND
+ (<NOT .FST> .FST)
+ (ELSE
+ <COND (<CTMATCH .RPAT ,ALLWORDS <> <> <>>
+ <COND (<AND <LENGTH? .F2 2> <TYPE? <2 .F2> LIST>>
+ <COND (<CTMATCH <1 .F2> ,ALLWORDS <> <><>>
+ <COND (.ORF
+ <SET TL <MAP-MERGE !<2 .F1> !<2 .F2>>>
+ <COND (<EMPTY? .TL> .FST)
+ (ELSE <FORM .FST .TL>)>)
+ (<SET TL <AND-MERGE <2 .F1> <2 .F2>>>
+ <FORM .FST .TL>)>)
+ (ELSE #FALSE (BAD-SYNTAX!-ERRORS))>)
+ (ELSE <COND (.ORF <ORSORT <FORM OR .F1 .F2>>) (ELSE <>)>)>)
+ (ELSE #FALSE (BAD-SYNTAX!-ERRORS))>)>>
+
+<DEFINE MAP-MERGE ("TUPLE" PAIRS "AUX" (HIGH <2 .PAIRS>) (LOW <1 .PAIRS>))
+ #DECL ((PAIRS) <TUPLE [REST FIX]> (HIGH LOW) FIX)
+ <REPEAT ()
+ <COND (<EMPTY? <SET PAIRS <REST .PAIRS 2>>> <RETURN>)>
+ <SET HIGH <MAX .HIGH <2 .PAIRS>>>
+ <SET LOW <MIN .LOW <1 .PAIRS>>>>
+ <COND (<AND <==? .HIGH <CHTYPE <MIN> FIX>>
+ <==? .LOW <CHTYPE <MAX> FIX>>>
+ ())
+ (ELSE (.LOW .HIGH))>>
+
+
+<DEFINE AND-MERGE (L1 L2 "AUX" (FLG <>) HIGH LOW TEM (L (0)) (LL .L))
+ #DECL ((L LL L1 L2) <LIST [REST FIX]> (HIGH LOW) FIX)
+ <COND (<G? <LENGTH .L1> <LENGTH .L2>>
+ <SET TEM .L1>
+ <SET L1 .L2>
+ <SET L2 .TEM>)>
+ <REPEAT ()
+ <SET LOW <1 .L2>>
+ <SET HIGH <2 .L2>>
+ <REPEAT ((L1 .L1) LO HI)
+ #DECL ((L1) <LIST [REST FIX]> (LO HI) FIX)
+ <COND (<EMPTY? .L1> <RETURN>)>
+ <SET HI <2 .L1>>
+ <COND (<OR <AND <G=? <SET LO <1 .L1>> .LOW>
+ <L=? .LO .HIGH>>
+ <AND <L=? .HI .HIGH> <G=? .HI .LOW>>
+ <AND <G=? .LOW .LO> <L=? .LOW .HI>>
+ <AND <L=? .HIGH .HI> <G=? .HIGH .LO>>>
+ <SET LOW <MAX .LOW .LO>>
+ <SET HIGH <MIN .HIGH .HI>>
+ <SET L <REST <PUTREST .L (.LOW .HIGH)> 2>>
+ <SET FLG T>
+ <RETURN>)>
+ <SET L1 <REST .L1 2>>>
+ <COND (<EMPTY? <SET L2 <REST .L2 2>>>
+ <RETURN <COND (.FLG <REST .LL>) (ELSE <>)>>)>>>
+
+"\f"
+
+<DEFINE GET-RANGE (L1 "AUX" TT)
+ <COND (<AND <TYPE? .L1 FORM>
+ <TMATCH .L1 ,ALLWORDS>
+ <TYPE? <2 .L1> LIST>>
+ <COND (<NOT <EMPTY? <SET TT <MAP-MERGE !<2 .L1>>>>> .TT)>)>>
+
+"\f"
+
+<DEFINE ELETYPE (F1 F2 RTYP
+ "AUX" (S1 <VECTOR .F1 <> 0 <> <> '[]>) (FAIL <>) (INOPT <>)
+ (S2 <VECTOR .F2 <> 0 <> <> '[]>) (FL ()) (FP '<>) FSTL
+ SEGF RTEM)
+ #DECL ((S1 S2) <VECTOR <PRIMTYPE LIST> ANY FIX ANY ANY ANY>
+ (F1 F2) <PRIMTYPE LIST> (FP) <OR FORM SEGMENT> (FL) LIST)
+ <SET SEGF <SEGANDOR .F1 .F2 .ORF>>
+ <COND
+ (<OR <EMPTY? .F1> <EMPTY? .F2>> #FALSE (EMPTY-FORM-IN-DECL!-ERRORS))
+ (<AND .ANDF .ORF <NOT <TMATCH <1 .F2> .RTYP>>> <ORSORT <FORM OR .F1 .F2>>)
+ (ELSE
+ <COND
+ (<SET FSTL
+ <COND (<TYPE? .RTYP ATOM>
+ <COND (<TYPE? <1 .F2> ATOM> <TYPMAT .RTYP <1 .F2>>)
+ (<TYPE? <1 .F2> FORM> <ACTORT <1 .F2> .RTYP>)
+ (ELSE #FALSE (BAD-SYNTAX!-ERRORS))>)
+ (<TYPE? .RTYP FORM> <ACTORT .RTYP <1 .F2>>)
+ (ELSE #FALSE (BAD-SYNTAX!-ERRORS))>>
+ <COND (.ANDF
+ <SET FL
+ <CHTYPE <SET FP
+ <COND (.SEGF <CHTYPE (.FSTL) SEGMENT>)
+ (ELSE <FORM .FSTL>)>>
+ LIST>>)>
+ <PUT .S1 ,DECL-RESTED <REST .F1>>
+ <PUT .S2 ,DECL-RESTED <REST .F2>>
+ <REPEAT ((TEM1 <>) (TEM2 <>) T1 T2 TEM TT)
+ #DECL ((TT) <VECTOR FIX ANY>)
+ <SET T1 <SET T2 <>>>
+ <COND
+ (<AND <OR <AND <SET TEM1 <NEXTP .S1>> <SET T1 <DECL-ELEMENT .S1>>>
+ <AND <EMPTY? .TEM1> <SET T1 ANY>>>
+ <OR <AND <SET TEM2 <NEXTP .S2>> <SET T2 <DECL-ELEMENT .S2>>>
+ <AND .TEM1 <EMPTY? .TEM2> <SET T2 ANY>>>>
+ <COND (<AND .ORF <OR <NOT .TEM1> <NOT .TEM2>>>
+ <RETURN <COND (<LENGTH? .FP 1> <1 .FP>) (ELSE .FP)>>)>
+ <OR <SET RTEM
+ <SET TEM
+ <COND (<NOT .TEM1>
+ <COND (<OR <TYPE? .F1 FORM> <DECL-IN-REST .S2>>
+ .T2)
+ (ELSE <SET FAIL T> <>)>)
+ (<NOT .TEM2>
+ <COND (<OR <TYPE? .F2 FORM> <DECL-IN-REST .S1>>
+ .T1)
+ (ELSE <SET FAIL T> <>)>)
+ (ELSE <DTMATCH .T1 .T2>)>>>
+ <COND (.ORF <SET TEM <ORSORT <FORM OR .T1 .T2>>>)
+ (.MAYBEF <COND (.FAIL <RETURN <>>) (ELSE <SET FAIL T>)>)
+ (ELSE <RETURN <>>)>>
+ <COND (<AND <NOT .INOPT>
+ <OR <AND .ORF
+ <OR <DECL-IN-COUNT-VEC .S1>
+ <DECL-IN-COUNT-VEC .S2>>>
+ <AND .ANDF
+ <NOT .ORF>
+ <DECL-IN-COUNT-VEC .S1>
+ <DECL-IN-COUNT-VEC .S2>>>>
+ <SET INOPT <COND (.ANDF (OPTIONAL .TEM)) (ELSE ())>>)
+ (<AND .INOPT .ANDF>
+ <PUTREST <REST .INOPT <- <LENGTH .INOPT> 1>> (.TEM)>)>
+ <COND (<AND .INOPT
+ <OR <AND .ORF
+ <OR <0? <DECL-ITEM-COUNT .S1>>
+ <0? <DECL-ITEM-COUNT .S2>>>>
+ <AND .ANDF
+ <0? <DECL-ITEM-COUNT .S1>>
+ <0? <DECL-ITEM-COUNT .S2>>>>>
+ <AND .ANDF <SET TEM [!.INOPT]>>
+ <SET INOPT <>>)>
+ <COND
+ (<OR <AND .ORF
+ <OR <AND <DECL-IN-REST .S1> <EMPTY? <DECL-RESTED .S2>>>
+ <AND <DECL-IN-REST .S2> <EMPTY? <DECL-RESTED .S1>>>>>
+ <AND <OR <DECL-IN-REST .S1>
+ <AND .ANDF <OR <NOT .TEM1> <DECL-IN-COUNT-VEC .S1>>>>
+ <OR <DECL-IN-REST .S2>
+ <AND .ANDF
+ <OR <NOT .TEM2> <DECL-IN-COUNT-VEC .S2>>>>>>
+ <COND
+ (<OR .ORF .ANDF>
+ <COND (<N==? 0
+ <SET T1
+ <RESTER? .S1
+ .S2
+ .FL
+ .RTEM
+ <TYPE? .F2 SEGMENT>>>>
+ <COND (<==? .T1 T>
+ <RETURN <COND (<LENGTH? .FP 1> <1 .FP>)
+ (ELSE .FP)>>)
+ (ELSE
+ <RETURN <COND (<AND <TYPE? .T1 FORM SEGMENT>
+ <LENGTH? .FP 1>>
+ <1 .T1>)
+ (ELSE .T1)>>)>)
+ (<N==? 0
+ <SET T1
+ <RESTER? .S2
+ .S1
+ .FL
+ .RTEM
+ <TYPE? .F1 SEGMENT>>>>
+ <COND (<==? .T1 T>
+ <RETURN <COND (<LENGTH? .FP 1> <1 .FP>)
+ (ELSE .FP)>>)
+ (ELSE
+ <RETURN <COND (<AND <TYPE? .T1 FORM SEGMENT>
+ <LENGTH? .FP 1>>
+ <1 .T1>)
+ (ELSE .T1)>>)>)>)
+ (ELSE <RETURN T>)>)
+ (<AND <NOT .ANDF>
+ <OR <DECL-IN-REST .S1> <NOT .TEM1>>
+ <OR <DECL-IN-REST .S2> <NOT .TEM2>>>
+ <RETURN T>)>
+ <COND (<AND <NOT .INOPT>
+ .ANDF
+ <OR <NOT .ORF>
+ <NOT <OR <DECL-IN-REST .S1> <DECL-IN-REST .S2>>>>>
+ <COND (<AND <TYPE? <1 .FL> VECTOR>
+ <=? <2 <SET TT <1 .FL>>> .TEM>>
+ <PUT .TT 1 <+ <1 .TT> 1>>)
+ (<AND <N==? <CHTYPE .FP LIST> .FL> <=? .TEM <1 .FL>>>
+ <PUT .FL 1 [2 .TEM]>)
+ (ELSE <SET FL <REST <PUTREST .FL (.TEM)>>>)>)>)
+ (ELSE
+ <COND (<AND <EMPTY? .TEM1> <EMPTY? <SET TEM1 .TEM2>>>
+ <COND (.ANDF
+ <RETURN <COND (<LENGTH? .FP 1> <1 .FP>) (ELSE .FP)>>)
+ (ELSE <RETURN T>)>)
+ (ELSE <RETURN .TEM1>)>)>>)>)>>
+
+"\f"
+
+<DEFINE RESTER? (S1 S2 FL FST SEGF
+ "AUX" (TT <DECL-REST-VEC .S1>) (TEM1 T) (TEM2 T) (OPTIT <>))
+ #DECL ((S1 S2) <VECTOR ANY ANY ANY ANY ANY VECTOR> (FL) <LIST ANY>
+ (TT) VECTOR)
+ <COND (<AND <OR .ORF <DECL-IN-COUNT-VEC .S2>>
+ <EMPTY? <DECL-RESTED .S2>> <NOT <DECL-IN-REST .S2>>>
+ <SET OPTIT T>)>
+ <COND
+ (<AND .SEGF <NOT .ORF> <OR <NOT <DECL-IN-REST .S1>>
+ <NOT <DECL-IN-REST .S2>>>> T)
+ (<AND <NOT <EMPTY? .TT>>
+ <OR <NOT <DECL-IN-REST .S2>> <G=? <LENGTH .TT>
+ <LENGTH <REST <TOP <DECL-REST-VEC .S2>>>>>>>
+ <SET TT <REST <TOP .TT>>>
+ <MAPR <>
+ <FUNCTION (SO "AUX" T1)
+ #DECL ((SO) <VECTOR ANY>)
+ <SET T1
+ <OR <AND <SET TEM1 <NEXTP .S2>> <DECL-ELEMENT .S2>>
+ <AND <EMPTY? .TEM1>
+ <COND (.ORF <MAPLEAVE>) (ELSE ANY)>>>>
+ <AND <OR .ORF <DECL-IN-COUNT-VEC .S2>>
+ <EMPTY? <DECL-RESTED .S2>>
+ <NOT <DECL-IN-REST .S2>>
+ <SET OPTIT T>>
+ <COND (<NOT .TEM1> <AND <EMPTY? .TEM1> <SET TEM1 T>>)>
+ <COND (.T1
+ <PUT .SO
+ 1
+ <SET TEM2
+ <DTMATCH <AND <NEXTP .S1>
+ <DECL-ELEMENT .S1>> .T1>>>)>
+ <AND <OR <NOT .T1> <NOT .TEM2>> <MAPLEAVE>>>
+ <REST <SET TT [REST .FST !<REST .TT>]> 2>>
+ <COND (.OPTIT <PUT .TT 1 OPTIONAL>)
+ (ELSE <SET TT <UNIQUE-VECTOR-CHECK .TT>>)>
+ <COND (<AND .TEM1 .TEM2> <PUTREST .FL (.TT)> T)
+ (<AND <NOT .TEM1> <NOT <EMPTY? .TEM1>>> .TEM1)
+ (ELSE .TEM2)>)
+ (ELSE 0)>>
+
+<DEFINE UNIQUE-VECTOR-CHECK (V "AUX" (FRST <2 .V>))
+ #DECL ((V) <VECTOR [2 ANY]>)
+ <COND (<MAPF <>
+ <FUNCTION (X) <COND (<N=? .X .FRST> <MAPLEAVE .V>)>>
+ <REST .V 2>>)
+ (ELSE [REST .FRST])>>
+
+
+<DEFINE NEXTP (S "AUX" TEM TT N)
+ #DECL ((S) <VECTOR <PRIMTYPE LIST> ANY FIX ANY ANY ANY> (N) FIX
+ (TT) VECTOR)
+ <COND (<0? <DECL-ITEM-COUNT .S>> <PUT .S ,DECL-IN-COUNT-VEC <>>)>
+ <COND (<DECL-IN-REST .S> <NTHREST .S>)
+ (<NOT <0? <DECL-ITEM-COUNT .S>>>
+ <PUT .S ,DECL-ITEM-COUNT <- <DECL-ITEM-COUNT .S> 1>>
+ <NTHREST .S>)
+ (<EMPTY? <SET TEM <DECL-RESTED .S>>> <>)
+ (<TYPE? <1 .TEM> ATOM FORM SEGMENT>
+ <SET TEM <1 .TEM>>
+ <PUT .S ,DECL-RESTED <REST <DECL-RESTED .S>>>
+ <PUT .S ,DECL-ELEMENT .TEM>)
+ (<TYPE? <1 .TEM> VECTOR>
+ <SET TT <1 .TEM>>
+ <PUT .S ,DECL-RESTED <REST <DECL-RESTED .S>>>
+ <PUT .S ,DECL-REST-VEC <REST .TT>>
+ <COND (<G? <LENGTH .TT> 1>
+ <COND (<==? <1 .TT> REST>
+ <COND (<AND <==? <LENGTH .TT> 2>
+ <==? <2 .TT> ANY>>
+ <>)
+ (ELSE
+ <PUT .S ,DECL-IN-REST T>
+ <PUT .S
+ ,DECL-ELEMENT
+ <DECL-ELEMENT .TT>>)>)
+ (<OR <AND <TYPE? <1 .TT> FIX> <SET N <1 .TT>>>
+ <AND <MEMQ <1 .TT> '![OPT OPTIONAL!]>
+ <SET N 1>>>
+ <OR <TYPE? <1 .TT> FIX>
+ <PUT .S ,DECL-IN-COUNT-VEC T>>
+ <PUT .S
+ ,DECL-ITEM-COUNT
+ <- <* .N <- <LENGTH .TT> 1>> 1>>
+ <PUT .S ,DECL-ELEMENT <2 .TT>>
+ <COND (<L=? .N 0> <>) (ELSE .S)>)
+ (#FALSE (BAD-VECTOR-SYNTAX!-ERRORS))>)
+ (ELSE #FALSE (BAD-FORM-SYNTAX!-ERRORS))>)
+ (ELSE #FALSE (BAD-FORM-SYNTAX!-ERRORS))>>
+
+"\f"
+
+<DEFINE NTHREST (S "AUX" (TEM <REST <DECL-REST-VEC .S>>))
+ #DECL ((S) <VECTOR ANY ANY ANY ANY ANY VECTOR> (TEM) VECTOR)
+ <COND (<EMPTY? .TEM> <SET TEM <REST <TOP .TEM>>>)>
+ <PUT .S ,DECL-REST-VEC .TEM>
+ <PUT .S ,DECL-ELEMENT <1 .TEM>>>
+"\f"
+
+<DEFINE GET-ELE-TYPE (DCL2 NN
+ "OPTIONAL" (RST <>) (PT <>)
+ "AUX" (LN 0) (CNT 0) ITYP DC SDC DCL (N 0) DC1 (QOK <>)
+ (FMOK <>) STRU (GD '<>) (GP ()) (K 0) (DCL1 .DCL2)
+ (SEGF <>) TEM)
+ #DECL ((LN CNT K N) FIX (DCL) <PRIMTYPE LIST> (SDC DC) VECTOR
+ (GD) <OR FORM SEGMENT> (GP) LIST)
+ <PROG ()
+ <COND (<AND .PT <SET TEM <ISTYPE? .DCL1>>>
+ <SET PT <TYPE-AND <GET-ELE-TYPE .TEM .NN> .PT>>)>
+ <AND <TYPE? .DCL1 ATOM> <SET DCL1 <GET .DCL1 DECL '.DCL1>>>
+ <COND (<TYPE? .DCL1 SEGMENT> <SET SEGF T>)>
+ <COND (<==? <STRUCTYP .DCL2> BYTES>
+ <RETURN <GET-ELE-BYTE .DCL2 .NN .RST .PT>>)>
+ <COND (.RST <SET STRU <COND (<STRUCTYP .DCL1>) (ELSE STRUCTURED)>>)
+ (.PT
+ <SET STRU
+ <COND (<ISTYPE? .DCL2>)
+ (<SET STRU <STRUCTYP .DCL1>> <FORM PRIMTYPE .STRU>)
+ (ELSE STRUCTURED)>>)>
+ <COND
+ (<AND <TYPE? .DCL1 FORM SEGMENT>
+ <SET DCL .DCL1>
+ <G? <SET LN <LENGTH .DCL>> 1>
+ <NOT <SET FMOK <MEMQ <1 .DCL> '![OR AND NOT!]>>>
+ <NOT <SET QOK <==? <1 .DCL> QUOTE>>>
+ <NOT <==? <1 .DCL> PRIMTYPE>>>
+ <COND
+ (<==? .NN ALL>
+ <AND .PT <SET GP <CHTYPE <SET GD <FOSE .SEGF .STRU>> LIST>>>
+ <OR
+ <AND <TYPE? <SET DC1 <2 .DCL>> VECTOR>
+ <SET DC .DC1>
+ <G=? <LENGTH .DC> 2>
+ <==? <1 .DC> REST>
+ <COND (<==? <LENGTH .DC> 2>
+ <COND (.RST <FORM .STRU [REST <2 .DC>]>)
+ (.PT <FORM .STRU [REST <TYPE-MERGE <2 .DC> .PT>]>)
+ (ELSE <2 .DC>)>)
+ (.RST <FORM .STRU [REST <TYPE-MERGE !<REST .DC>>]>)
+ (.PT
+ <FORM .STRU
+ [REST
+ <MAPF ,TYPE-MERGE
+ <FUNCTION (D) <TYPE-MERGE .D .PT>>
+ <REST .DC>>]>)
+ (ELSE <TYPE-MERGE !<REST .DC>>)>>
+ <REPEAT (TT (CK <DCX <SET TT <2 .DCL>>>) (D .DCL) TEM)
+ #DECL ((D) <PRIMTYPE LIST>)
+ <COND (<EMPTY? <SET D <REST .D>>>
+ <SET TEM
+ <OR .SEGF
+ <AND <TYPE? .TT VECTOR> <==? <1 .TT> REST>>>>
+ <RETURN <COND (.TEM
+ <COND (.RST <FORM .STRU [REST .CK]>)
+ (.PT .GD)
+ (ELSE .CK)>)
+ (.PT .GD)
+ (.RST .STRU)
+ (ELSE ANY)>>)>
+ <SET CK <TYPE-MERGE .CK <DCX <SET TT <1 .D>>>>>
+ <AND .PT
+ <SET GP
+ <REST
+ <PUTREST .GP
+ (<COND (<TYPE? .TT VECTOR>
+ [<1 .TT>
+ !<MAPF ,LIST
+ <FUNCTION (X)
+ <TYPE-MERGE .X .PT>>
+ <REST .TT>>])
+ (ELSE
+ <TYPE-MERGE .PT .TT>)>)>>>>>>)
+ (ELSE
+ <SET N .NN>
+ <AND .PT <SET GP <CHTYPE <SET GD <FOSE .SEGF .STRU>> LIST>>>
+ <AND .RST <SET N <+ .N 1>>>
+ <COND (<EMPTY? <SET DCL <REST .DCL>>>
+ <RETURN <COND (.RST .STRU)
+ (.PT <FOSE .SEGF .STRU !<ANY-PAT <- .N 1>> .PT>)
+ (ELSE ANY)>>)>
+ <REPEAT ()
+ <COND
+ (<NOT <0? .CNT>>
+ <COND
+ (<EMPTY? <SET SDC <REST .SDC>>>
+ <SET SDC <REST .DC>>
+ <AND
+ <0? <SET CNT <- .CNT 1>>>
+ <COND (<EMPTY? <SET DCL <REST .DCL>>>
+ <RETURN <COND (.RST .STRU)
+ (.PT
+ <PUTREST .GP (!<ANY-PAT <- .N 1>> .PT)>
+ .GD)
+ (ELSE ANY)>>)
+ (ELSE <AGAIN>)>>)>
+ <SET ITYP <1 .SDC>>)
+ (<TYPE? <1 .DCL> ATOM FORM SEGMENT>
+ <SET ITYP <1 .DCL>>
+ <SET DCL <REST .DCL>>)
+ (<TYPE? <SET DC1 <1 .DCL>> VECTOR>
+ <SET DC .DC1>
+ <COND
+ (<==? <1 .DC> REST>
+ <AND <OR <AND .RST <NOT <1? .N>>> .PT>
+ <==? 2 <LENGTH .DC>>
+ <=? <2 .DC> '<NOT ANY>>
+ <RETURN <>>>
+ <SET K <MOD <- .N 1> <- <LENGTH .DC> 1>>>
+ <SET N </ <- .N 1> <- <LENGTH .DC> 1>>>
+ <RETURN
+ <COND
+ (.RST
+ <FOSE .SEGF
+ .STRU
+ <COND (<0? .K> .DC)
+ (ELSE [REST <TYPE-MERGE !<REST .DC>>])>>)
+ (.PT
+ <PUTREST
+ .GP
+ (!<COND (<L=? .N 0> ())
+ (<1? .N> (!<REST .DC>))
+ (ELSE ([.N !<REST .DC>]))>
+ !<MAPF ,LIST
+ <FUNCTION (O)
+ <COND (<==? <SET K <- .K 1>> -1> .PT)
+ (ELSE .O)>>
+ <REST .DC>>
+ .DC)>
+ .GD)
+ (ELSE <NTH .DC <+ .K 2>>)>>)
+ (<OR <TYPE? <1 .DC> FIX> <==? <1 .DC> OPT> <==? <1 .DC> OPTIONAL>>
+ <SET CNT <COND (<TYPE? <1 .DC> FIX> <1 .DC>) (ELSE 1)>>
+ <SET SDC .DC>
+ <AGAIN>)>)>
+ <AND
+ <0? <SET N <- .N 1>>>
+ <RETURN
+ <COND
+ (.RST
+ <COND (<AND <EMPTY? .DCL> <0? .CNT>> .STRU)
+ (<FOSE .SEGF
+ .STRU
+ !<COND (<0? .CNT> (.ITYP !.DCL))
+ (<N==? .SDC <REST .DC>>
+ <COND (<0? <SET CNT <- .CNT 1>>>
+ (!.SDC !<REST .DCL>))
+ (ELSE
+ (!.SDC
+ [.CNT !<REST .DC>]
+ !<REST .DCL>))>)
+ (ELSE ([.CNT !.SDC] !<REST .DCL>))>>)>)
+ (.PT
+ <SET GP <REST <PUTREST .GP (.PT)>>>
+ <AND <ASSIGNED? SDC> <SET SDC <REST .SDC>>>
+ <COND (<AND <EMPTY? .DCL> <0? .CNT>> .GD)
+ (<PUTREST .GP
+ <COND (<OR <0? .CNT>
+ <AND <1? .CNT> <==? .SDC <REST .DC>>>>
+ .DCL)
+ (<==? .SDC <REST .DC>>
+ ([.CNT !<REST .DC>] !<REST .DCL>))
+ (<L=? <SET CNT <- .CNT 1>> 0>
+ (!.SDC !<REST .DCL>))
+ (ELSE
+ (!.SDC
+ [.CNT !<REST .DC>]
+ !<REST .DCL>))>>
+ .GD)>)
+ (ELSE .ITYP)>>>
+ <AND <OR .PT .RST> <=? .ITYP '<NOT ANY>> <RETURN <>>>
+ <AND .PT <SET GP <REST <PUTREST .GP (.ITYP)>>>>
+ <COND (<EMPTY? .DCL>
+ <RETURN <COND (.RST .STRU)
+ (.PT
+ <PUTREST .GP (!<ANY-PAT <- .N 1>> .PT)>
+ .GD)
+ (ELSE ANY)>>)>>)>)
+ (.QOK <SET DCL1 <GEN-DECL <2 .DCL>>> <AGAIN>)
+ (<AND .FMOK <==? <1 .FMOK> OR>>
+ <MAPF ,TYPE-MERGE
+ <FUNCTION (D "AUX" IT)
+ <COND (<SET IT <GET-ELE-TYPE .D .NN .RST .PT>>
+ <AND <==? .IT ANY> <MAPLEAVE ANY>>
+ .IT)
+ (ELSE <MAPRET>)>>
+ <REST .DCL>>)
+ (<AND .FMOK <==? <1 .FMOK> AND>>
+ <SET ITYP ANY>
+ <MAPF <>
+ <FUNCTION (D)
+ <SET ITYP <TYPE-OK? .ITYP <GET-ELE-TYPE .D .NN .RST>>>>
+ <REST .DCL>>
+ .ITYP)
+ (.RST <COND (<STRUCTYP .DCL1>) (ELSE STRUCTURED)>)
+ (.PT
+ <COND (<==? .NN ALL> .DCL1)
+ (ELSE <FOSE .SEGF .DCL1 !<ANY-PAT <- .NN 1>> .PT>)>)
+ (ELSE ANY)>>>
+
+"\f"
+
+<DEFINE GET-ELE-BYTE (DCL N RST PT "AUX" SIZ)
+ #DECL ((N) <OR ATOM FIX>)
+ <COND (.PT
+ <COND (<==? .N ALL> .DCL)
+ (<TYPE-AND .DCL <FORM STRUCTURED [.N FIX] [REST FIX]>>)>)
+ (.RST
+ <COND (<==? .N ALL> <SET N <MINL .DCL>>)
+ (<G? .N <MINL .DCL>> <SET N 0>)
+ (ELSE <SET N <- <MINL .DCL> .N>>)>
+ <COND (<SET SIZ <GETBSYZ .DCL>> <FORM BYTES .SIZ .N>)
+ (ELSE BYTES)>)
+ (ELSE FIX)>>
+
+<DEFINE GETBSYZ (DCL "AUX" TEM)
+ <COND (<==? <SET TEM <STRUCTYP .DCL>> STRING> 7)
+ (<AND <==? .TEM BYTES> <TYPE? .DCL FORM SEGMENT> <G=? <LENGTH .DCL> 2>
+ <TYPE? <SET TEM <2 .DCL>> FIX>>
+ .TEM)>>
+
+<DEFINE MINL (DCL "AUX" (N 0) DD D DC (LN 0) (QOK <>) (ANDOK <>) TT (OROK <>))
+ #DECL ((N VALUE LN) FIX (DC) <PRIMTYPE LIST> (D) VECTOR)
+ <AND <TYPE? .DCL ATOM> <SET DCL <GET .DCL DECL '.DCL>>>
+ <COND
+ (<AND <TYPE? .DCL FORM SEGMENT>
+ <SET DC .DCL>
+ <G? <LENGTH .DC> 1>
+ <N==? <SET TT <1 .DC>> PRIMTYPE>
+ <NOT <SET OROK <==? .TT OR>>>
+ <NOT <SET QOK <==? .TT QUOTE>>>
+ <NOT <SET ANDOK <==? .TT AND>>>
+ <N==? .TT NOT>>
+ <SET DC <REST .DC>>
+ <COND (<AND <NOT <EMPTY? .DC>> <TYPE? <1 .DC> FIX>>
+ <OR <TMATCH .TT '<PRIMTYPE BYTES>>
+ <MESSAGE ERROR "BAD-DECL-SYNTAX" .DCL>>
+ <COND (<AND <==? <LENGTH .DC> 2> <TYPE? <2 .DC> FIX>>
+ <2 .DC>)
+ (ELSE 0)>)
+ (ELSE
+ <REPEAT ()
+ #DECL ((VALUE) FIX)
+ <COND (<AND <TYPE? <SET DD <1 .DC>> VECTOR>
+ <SET D .DD>
+ <G? <LENGTH .D> 1>>
+ <COND (<MEMQ <1 .D> '[REST OPT OPTIONAL]> <RETURN .N>)
+ (<TYPE? <1 .D> FIX>
+ <SET LN <1 .D>>
+ <SET N <+ .N <* .LN <- <LENGTH .D> 1>>>>)
+ (ELSE <MESSAGE ERROR "BAD DECL " .DCL>)>)
+ (<TYPE? .DD ATOM FORM SEGMENT> <SET N <+ .N 1>>)
+ (ELSE <MESSAGE ERROR "BAD DECL " .DCL>)>
+ <AND <EMPTY? <SET DC <REST .DC>>> <RETURN .N>>>)>)
+ (<OR .OROK .ANDOK> <CHTYPE <MAPF <COND (.OROK ,MIN) (ELSE ,MAX)> ,MINL <REST .DC>>
+ FIX>)
+ (.QOK <COND (<STRUCTURED? <2 .DC>> <LENGTH <2 .DC>>) (ELSE 0)>)
+ (<TYPE? .DCL ATOM FALSE FORM SEGMENT> 0)
+ (ELSE <MESSAGE "BAD DECL " .DCL>)>>
+
+<DEFINE STRUCTYP (DCL)
+ <SET DCL <TYPE-AND .DCL STRUCTURED>>
+ <COND (<TYPE? .DCL ATOM>
+ <AND <VALID-TYPE? .DCL> <TYPEPRIM .DCL>>)
+ (<TYPE? .DCL FORM SEGMENT>
+ <COND (<PRIMHK .DCL T>)
+ (<TYPE? <1 .DCL> FORM> <PRIMHK <1 .DCL> <>>)>)>>
+
+<DEFINE PRIMHK (FRM FLG "AUX" TEM (LN <LENGTH .FRM>))
+ #DECL ((FRM) <OR FORM SEGMENT> (LN) FIX)
+ <COND (<AND <==? .LN 2>
+ <COND (<==? <SET TEM <1 .FRM>> PRIMTYPE>
+ <AND <TYPE? <SET TEM <2 .FRM>> ATOM>
+ <VALID-TYPE? .TEM>
+ <STRUCTYP <2 .FRM>>>)
+ (<==? .TEM QUOTE> <PRIMTYPE <2 .FRM>>)
+ (<==? .TEM NOT> <>)>>)
+ (<NOT <0? .LN>>
+ <COND (<==? <SET TEM <1 .FRM>> OR>
+ <SET TEM NO-RETURN>
+ <MAPF <>
+ <FUNCTION (D)
+ <SET TEM <TYPE-MERGE <STRUCTYP .D> .TEM>>> <REST .FRM>>
+ <COND (<AND <TYPE? .TEM ATOM> <VALID-TYPE? .TEM>> .TEM)>)
+ (<==? .TEM AND>
+ <MAPF <>
+ <FUNCTION (D)
+ <COND (<SET TEM <STRUCTYP .D>> <MAPLEAVE>)>>
+ <REST .FRM>>
+ .TEM)
+ (<AND <TYPE? .TEM ATOM> <VALID-TYPE? .TEM>>
+ <TYPEPRIM .TEM>)>)>>
+
+"\f"
+
+<DEFINE TYPESAME (T1 T2)
+ <AND <SET T1 <ISTYPE? .T1>>
+ <==? .T1 <ISTYPE? .T2>>>>
+
+<DEFINE ISTYPE-GOOD? (TYP "OPTIONAL" (STRICT <>))
+ <AND <SET TYP <ISTYPE? .TYP .STRICT>>
+ <NOT <MEMQ <TYPEPRIM .TYP> '![BYTES STRING LOCD TUPLE FRAME!]>>
+ .TYP>>
+
+<DEFINE TOP-TYPE (TYP "AUX" TT)
+ <COND (<AND <TYPE? .TYP ATOM> <NOT <VALID-TYPE? .TYP>>
+ <NOT <MEMQ .TYP '![STRUCTURED APPLICABLE ANY LOCATIVE]>>>
+ <SET TYP <GET .TYP DECL '.TYP>>)>
+ <COND (<TYPE? .TYP ATOM> .TYP)
+ (<AND <TYPE? .TYP FORM SEGMENT> <NOT <LENGTH? .TYP 1>>>
+ <COND (<==? <SET TT <1 .TYP>> OR>
+ <MAPF ,TYPE-MERGE ,TOP-TYPE <REST .TYP>>)
+ (<==? .TT NOT> ANY)
+ (<==? .TT QUOTE> <TYPE <2 .TYP>>)
+ (<==? .TT PRIMTYPE> .TYP)
+ (ELSE .TT)>)>>
+
+<DEFINE ISTYPE? (TYP "OPTIONAL" (STRICT <>) "AUX" TY)
+ <PROG ()
+ <OR .STRICT <TYPE? .TYP ATOM> <SET TYP <TYPE-AND .TYP '<NOT
+ UNBOUND>>>>
+ <COND
+ (<TYPE? .TYP FORM SEGMENT>
+ <COND (<AND <==? <LENGTH .TYP> 2> <==? <1 .TYP> QUOTE>>
+ <SET TYP <TYPE <2 .TYP>>>)
+ (<==? <1 .TYP> OR>
+ <SET TYP <ISTYPE? <2 <SET TY .TYP>>>>
+ <MAPF <>
+ <FUNCTION (Z)
+ <COND (<N==? .TYP <ISTYPE? .Z>>
+ <MAPLEAVE <SET TYP <>>>)>>
+ <REST .TY 2>>)
+ (ELSE <SET TYP <1 .TYP>>)>)>
+ <AND <TYPE? .TYP ATOM>
+ <COND (<VALID-TYPE? .TYP> .TYP)
+ (<SET TYP <GET .TYP DECL>> <AGAIN>)>>>>
+
+
+<DEFINE DCX (IT "AUX" TT LN)
+ #DECL ((TT) VECTOR (LN) FIX)
+ <COND (<AND <TYPE? .IT VECTOR>
+ <G=? <SET LN <LENGTH <SET TT .IT>>> 2>
+ <COND (<==? .LN 2> <2 .TT>)
+ (ELSE <TYPE-MERGE !<REST .TT>>)>>)
+ (ELSE .IT)>>
+
+"DETERMINE IF A TYPE PATTERN REQUIRES DEFERMENT 0=> NO 1=> YES 2=> DONT KNOW "
+
+"\f"
+
+<DEFINE DEFERN (PAT "AUX" STATE TEM)
+ #DECL ((STATE) FIX)
+ <PROG ()
+ <COND
+ (<TYPE? .PAT ATOM>
+ <COND (<VALID-TYPE? .PAT>
+ <COND (<MEMQ <SET PAT <TYPEPRIM .PAT>>
+ '![STRING TUPLE LOCD FRAME BYTES!]>
+ 1)
+ (ELSE 0)>)
+ (<SET PAT <GET .PAT DECL>> <AGAIN>)
+ (ELSE 2)>)
+ (<AND <TYPE? .PAT FORM SEGMENT> <NOT <EMPTY? .PAT>>>
+ <COND (<==? <SET TEM <1 .PAT>> QUOTE> <DEFERN <TYPE <2 .PAT>>>)
+ (<==? .TEM PRIMTYPE> <DEFERN <2 .PAT>>)
+ (<AND <==? .TEM OR> <NOT <EMPTY? <REST .PAT>>>>
+ <SET STATE <DEFERN <2 .PAT>>>
+ <MAPF <>
+ <FUNCTION (P)
+ <OR <==? <DEFERN .P> .STATE> <SET STATE 2>>>
+ <REST .PAT 2>>
+ .STATE)
+ (<==? .TEM NOT> 2)
+ (<==? .TEM AND>
+ <SET STATE 2>
+ <MAPF <>
+ <FUNCTION (P)
+ <COND (<L? <SET STATE <DEFERN .P>> 2>
+ <MAPLEAVE>)>>
+ <REST .PAT>>
+ .STATE)
+ (ELSE <DEFERN <1 .PAT>>)>)
+ (ELSE 2)>>>
+
+" Define a decl for a given quoted object for maximum winnage."
+
+"\f"
+
+<DEFINE GEN-DECL (OBJ)
+ <COND
+ (<OR <MONAD? .OBJ> <APPLICABLE? .OBJ> <TYPE? .OBJ STRING>> <TYPE .OBJ>)
+ (<==? <PRIMTYPE .OBJ> BYTES>
+ <CHTYPE (<TYPE .OBJ> <BYTE-SIZE .OBJ> <LENGTH .OBJ>) SEGMENT>)
+ (ELSE
+ <REPEAT ((DC <GEN-DECL <1 .OBJ>>) (CNT 1)
+ (FRM <CHTYPE (<TYPE .OBJ>) SEGMENT>) (FRME .FRM) TT T1)
+ #DECL ((CNT) FIX (FRME) <<PRIMTYPE LIST> ANY>)
+ <COND (<EMPTY? <SET OBJ <REST .OBJ>>>
+ <COND (<G? .CNT 1>
+ <SET FRME <REST <PUTREST .FRME ([.CNT .DC])>>>)
+ (ELSE <SET FRME <REST <PUTREST .FRME (.DC)>>>)>
+ <RETURN .FRM>)
+ (<AND <=? <SET TT <GEN-DECL <1 .OBJ>>> .DC> .DC>
+ <SET CNT <+ .CNT 1>>)
+ (ELSE
+ <COND (<G? .CNT 1>
+ <SET FRME <REST <PUTREST .FRME ([.CNT .DC])>>>)
+ (ELSE <SET FRME <REST <PUTREST .FRME (.DC)>>>)>
+ <SET DC .TT>
+ <SET CNT 1>)>>)>>
+
+"\f"
+
+<DEFINE REST-DECL (DC N "AUX" TT TEM)
+ #DECL ((N) FIX)
+ <COND
+ (<TYPE? .DC FORM SEGMENT>
+ <COND
+ (<OR <==? <SET TT <1 .DC>> OR> <==? .TT AND>>
+ <SET TT
+ <CHTYPE (.TT
+ !<MAPF ,LIST
+ <FUNCTION (D "AUX" (IT <REST-DECL .D .N>))
+ <COND (<==? .IT ANY>
+ <COND (<==? .TT OR> <MAPLEAVE (ANY)>)
+ (ELSE <MAPRET>)>)
+ (ELSE .IT)>>
+ <REST .DC>>)
+ FORM>>
+ <COND (<EMPTY? <REST .TT>> ANY)
+ (<EMPTY? <REST .TT 2>> <2 .TT>)
+ (ELSE .TT)>)
+ (<==? .TT NOT> ANY)
+ (<==? <STRUCTYP .DC> BYTES>
+ <COND (<==? .TT PRIMTYPE>
+ .DC)
+ (<==? <LENGTH .DC> 2>
+ <CHTYPE (!.DC .N) FORM>)
+ (<FORM .TT <2 .DC> <+ <CHTYPE <3 .DC> FIX> .N>>)>)
+ (<==? .TT PRIMTYPE>
+ <COND (<0? .N> .DC)
+ (ELSE <CHTYPE (.DC !<ANY-PAT .N>) FORM>)>)
+ (ELSE
+ <FOSE <TYPE? .DC SEGMENT> <COND (<SET TEM <STRUCTYP .TT>> <FORM PRIMTYPE .TEM>)
+ (ELSE STRUCTURED)>
+ !<ANY-PAT .N>
+ !<REST .DC>>)>)
+ (<SET TEM <STRUCTYP .DC>>
+ <COND (<OR <0? .N>
+ <==? .TEM BYTES>> <FORM PRIMTYPE .TEM>)
+ (ELSE <CHTYPE (<FORM PRIMTYPE .TEM> !<ANY-PAT .N>) FORM>)>)
+ (ELSE
+ <COND (<0? .N> STRUCTURED)
+ (ELSE <CHTYPE (STRUCTURED !<ANY-PAT .N>) FORM>)>)>>
+
+<DEFINE ANY-PAT (N)
+ #DECL ((N) FIX)
+ <COND (<L=? .N 0> ()) (<1? .N> (ANY)) (ELSE ([.N ANY]))>>
+
+" TYPE-OK? are two type patterns compatible. If the patterns
+ don't parse, send user a message."
+
+<DEFINE TYPE-OK? (P1 P2 "AUX" TEM)
+ <COND (<OR <==? .P1 NO-RETURN> <==? .P2 NO-RETURN>> NO-RETURN)
+ (<SET TEM <TYPE-AND .P1 .P2>> .TEM)
+ (<EMPTY? .TEM> .TEM)
+ (ELSE <MESSAGE ERROR " " <1 .TEM> " " .P1 " " .P2>)>>
+
+" TYPE-ATOM-OK? does an atom's initial value agree with its DECL?"
+
+<DEFINE TYPE-ATOM-OK? (P1 P2 ATM)
+ #DECL ((ATM) ATOM)
+ <OR <TYPE-OK? .P1 .P2>
+ <MESSAGE ERROR "TYPE MISUSE " .ATM>>>
+
+" Merge a group of type specs into an OR."
+
+"\f"
+
+<DEFINE TYPE-MERGE ("TUPLE" TYPS)
+ #DECL ((TYPS) TUPLE (FTYP) FORM (LN) FIX)
+ <COND (<EMPTY? .TYPS> <>)
+ (ELSE
+ <REPEAT ((ORS <1 .TYPS>))
+ <COND (<EMPTY? <SET TYPS <REST .TYPS>>> <RETURN .ORS>)>
+ <SET ORS
+ <COND (<==? <1 .TYPS> NO-RETURN> .ORS)
+ (<==? .ORS NO-RETURN> <1 .TYPS>)
+ (ELSE <TMERGE .ORS <1 .TYPS>>)>>>)>>
+
+<DEFINE PUT-IN (LST ELE)
+ #DECL ((LST) <PRIMTYPE LIST> (VALUE) LIST)
+ <COND (<AND <TYPE? .ELE FORM SEGMENT>
+ <NOT <EMPTY? .ELE>>
+ <==? <1 .ELE> OR>>
+ <SET ELE <LIST !<REST .ELE>>>)
+ (ELSE <SET ELE (.ELE)>)>
+ <SET LST
+ <MAPF ,LIST
+ <FUNCTION (L1 "AUX" TT)
+ <COND (<EMPTY? .ELE> .L1)
+ (<REPEAT ((A .ELE) B)
+ #DECL ((A B) LIST)
+ <COND (<TMATCH <1 .A> .L1>
+ <SET TT <TMERGE <1 .A> .L1>>
+ <COND (<==? .A .ELE> <SET ELE <REST .ELE>>)
+ (ELSE <PUTREST .B <REST .A>>)>
+ <RETURN T>)>
+ <AND <EMPTY? <SET A <REST <SET B .A>>>>
+ <RETURN <>>>>
+ .TT)
+ (ELSE .L1)>>
+ .LST>>
+ <LSORT <COND (<EMPTY? .ELE> .LST)
+ (ELSE <PUTREST <REST .ELE <- <LENGTH .ELE> 1>> .LST> .ELE)>>>
+
+<DEFINE ORSORT (F) #DECL ((F) <FORM ANY ANY>) <PUTREST .F <LSORT <REST .F>>>>
+
+<DEFINE LSORT (L "AUX" (M ()) (B ()) (TMP ()) (IT ()) (N 0) A1 A2)
+ #DECL ((L M B TMP IT VALUE) LIST (N) FIX (CMPRSN) <OR FALSE APPLICABLE>)
+ <PROG ()
+ <COND (<L? <SET N <LENGTH .L>> 2> <RETURN .L>)>
+ <SET B <REST <SET TMP <REST .L <- </ .N 2> 1>>>>>
+ <PUTREST .TMP ()>
+ <SET L <LSORT .L>>
+ <SET B <LSORT .B>>
+ <SET TMP ()>
+ <REPEAT ()
+ <COND (<EMPTY? .L>
+ <COND (<EMPTY? .TMP> <RETURN .B>)
+ (ELSE <PUTREST .TMP .B> <RETURN .M>)>)
+ (<EMPTY? .B>
+ <COND (<EMPTY? .TMP> <RETURN .L>)
+ (ELSE <PUTREST .TMP .L> <RETURN .M>)>)
+ (ELSE
+ <SET A1 <1 .L>>
+ <SET A2 <1 .B>>
+ <COND (<COND (<AND <TYPE? .A1 ATOM> <TYPE? .A2 ATOM>>
+ <L? <STRCOMP .A1 .A2> 0>)
+ (<TYPE? .A1 ATOM> T)
+ (<TYPE? .A2 ATOM> <>)
+ (ELSE <FCOMPARE .A1 .A2>)>
+ <SET L <REST <SET IT .L>>>)
+ (ELSE <SET B <REST <SET IT .B>>>)>
+ <PUTREST .IT ()>
+ <COND (<EMPTY? .M> <SET M <SET TMP .IT>>)
+ (ELSE <SET TMP <REST <PUTREST .TMP .IT>>>)>)>>>>
+"\f"
+
+<DEFINE FCOMPARE (F1 F2 "AUX" (L1 <LENGTH .F1>) (L2 <LENGTH .F2>))
+ #DECL ((F1 F2) <PRIMTYPE LIST> (L1 L2) FIX)
+ <COND (<==? .L1 .L2>
+ <L? <STRCOMP <UNPARSE .F1> <UNPARSE .F2>> 0>)
+ (<L? .L1 .L2>)>>
+
+
+<DEFINE CANONICAL-DECL (D)
+ <SET D <VTS .D>>
+ <COND (<AND <TYPE? .D FORM SEGMENT> <NOT <EMPTY? .D>>>
+ <COND (<==? <1 .D> OR>
+ <ORSORT <FORM OR !<CAN-ELE <REST .D>>>>)
+ (<==? <1 .D> QUOTE> <CANONICAL-DECL <GEN-DECL <2 .D>>>)
+ (ELSE <CAN-ELE .D>)>)
+ (ELSE .D)>>
+
+
+<DEFINE CAN-ELE (L "AUX" (SAME <>) SAMCNT TT TEM)
+ #DECL ((L) <PRIMTYPE LIST> (SAMCNT) FIX)
+ <CHTYPE
+ (<CANONICAL-DECL <1 .L>>
+ !<MAPR ,LIST
+ <FUNCTION (EL "AUX" (ELE <1 .EL>) (LAST <EMPTY? <REST .EL>>))
+ <COND
+ (<TYPE? .ELE VECTOR>
+ <COND
+ (<AND <==? <LENGTH .ELE> 2> <TYPE? <1 .ELE> FIX>>
+ <SET TT <CANONICAL-DECL <2 .ELE>>>
+ <COND (<AND .SAME <=? .SAME .TT>>
+ <SET SAMCNT <+ .SAMCNT <1 .ELE>>>
+ <COND (.LAST [.SAMCNT .TT]) (ELSE <MAPRET>)>)
+ (ELSE
+ <COND (.SAME <SET TEM <GR-RET .SAME .SAMCNT>>)
+ (ELSE <SET TEM <>>)>
+ <SET SAME .TT>
+ <SET SAMCNT <1 .ELE>>
+ <COND (.LAST
+ <COND (.TEM <MAPRET .TEM <GR-RET .TT .SAMCNT>>)
+ (ELSE <GR-RET .TT .SAMCNT>)>)
+ (.TEM)
+ (ELSE <MAPRET>)>)>)
+ (<AND <==? <1 .ELE> REST>
+ <==? <LENGTH .ELE> 2>
+ <==? <2 .ELE> ANY>>
+ <COND (.SAME
+ <SET TEM <GR-RET .SAME .SAMCNT>>
+ <SET SAME <>>
+ <MAPRET .TEM>)
+ (ELSE <MAPRET>)>)
+ (ELSE
+ <COND (.SAME <SET TEM <GR-RET .SAME .SAMCNT>>)
+ (ELSE <SET TEM <>>)>
+ <SET TT <IVECTOR <LENGTH .ELE>>>
+ <PUT .TT 1 <COND (<==? <1 .ELE> OPT> OPTIONAL) (ELSE <1 .ELE>)>>
+ <MAPR <>
+ <FUNCTION (X Y) <PUT .X 1 <CANONICAL-DECL <1 .Y>>>>
+ <REST .TT>
+ <REST .ELE>>
+ <SET SAME <>>
+ <COND (.TEM <MAPRET .TEM .TT>) (ELSE .TT)>)>)
+ (ELSE
+ <SET ELE <CANONICAL-DECL .ELE>>
+ <COND (<AND .SAME <=? .SAME .ELE>>
+ <SET SAMCNT <+ .SAMCNT 1>>
+ <COND (.LAST <GR-RET .ELE .SAMCNT>) (ELSE <MAPRET>)>)
+ (ELSE
+ <COND (.SAME <SET TEM <GR-RET .SAME .SAMCNT>>)
+ (ELSE <SET TEM <>>)>
+ <SET SAME .ELE>
+ <SET SAMCNT 1>
+ <COND (.LAST <COND (.TEM <MAPRET .TEM .ELE>) (ELSE .ELE)>)
+ (.TEM)
+ (ELSE <MAPRET>)>)>)>>
+ <REST .L>>)
+ FORM>>
+
+<DEFINE GR-RET (X N) #DECL ((N) FIX)
+ <COND (<1? .N> .X)(ELSE [.N .X])>>
+
+
--- /dev/null
+TITLE CONSTS
+
+RELOCA
+
+DEFINE C%MAKE A,B
+ .GLOBAL A
+
+ IRP LH,RH,[B]
+ A==[LH,,RH]
+ .ISTOP
+ TERMIM
+TERMIN
+TERMIN
+
+IRP X,,[[C%11,1,1],[C%22,2,2],[C%33,3,3],[C%44,4,4],[C%55,5,5],[C%66,6,6]
+[C%0,0,0],[C%1,0,1],[C%2,0,2],[C%3,0,3],[C%M1,-1,-1],[C%M2,-1,-2]
+[C%M10,-1,0],[C%M20,-2,0],[C%M30,-3,0],[C%M40,-4,0],[C%M60,-6,0]]
+
+ IRP A,B,[X]
+ C%MAKE A,[B]
+ .ISTOP
+ TERMIN
+
+TERMIN
+TERMIN
+END
--- /dev/null
+TITLE CORE
+
+RELOCATABLE
+
+.INSRT MUDDLE >
+
+SYSQ
+
+IF1,[
+IFE ITS,.INSRT STENEX >
+]
+
+.GLOBAL P.CORE,P.TOP,PHIBOT,PURBOT,FRETOP,SQKIL,GCFLG,KILBUF
+.GLOBAL MULTSG
+
+; .CORE AND .SUSET [.RMEMT,,---] FOR PAGED ENVIRONMENT
+
+IFN ITS,[
+
+P.CORE: PUSH P,0
+ PUSH P,A
+ PUSH P,B
+ PUSH P,C
+ PUSH P,D
+ PUSH P,E
+ SKIPN GCFLG
+ PUSHJ P,SQKIL
+ MOVE A,-4(P)
+ ASH A,10. ; CHECK IT
+ CAMLE A,PURBOT ; A CAML HERE IS OBSERVED TO LOSE
+ FATAL BAD ARG TO GET CORE
+ MOVE A,-4(P) ; RESTORE A
+ HRRZ B,P.TOP ; GET FIRST ADDRESS ABOVE TOP
+ ASH B,-10. ; TO BLOCKS
+ CAIG A,(B) ; SKIP IF GROWING
+ JRST P.COR1
+ SUBM B,A ; A/ -NUMBER OF BLOCKS TO GET
+ HRLI B,(A) ; AOBJN TO BLOCKS
+
+ .CALL P.CORU ; TRY
+ JRST POPBJ ; LOSE
+ MOVE A,B
+P.COR2: ASH B,10. ; TO WORDS
+ MOVEM B,P.TOP ; NEW TOP
+POPBJ1: AOS -6(P) ; SKIP RETURN ON SUCCESS
+POPBJ: POP P,E
+ POP P,D
+ POP P,C
+ POP P,B
+ POP P,A
+ POP P,0
+ POPJ P,
+
+; HERE TO CORE DOWN
+
+P.COR1: SUBM A,B
+ JUMPE B,POPBJ1 ; SUCCESS, YOU ALREADY HAVE WHAT YOU WANT
+ HRLI A,(B)
+ MOVEI B,(A)
+ .CALL P.CORD
+ JRST POPBJ
+ JRST P.COR2
+
+P.CORU: SETZ
+ SIXBIT /CORBLK/
+ 1000,,100000
+ 1000,,-1
+ B
+ 401000,,400001
+
+P.CORD: SETZ
+ SIXBIT /CORBLK/
+ 1000,,0
+ 1000,,-1
+ SETZ A
+]
+
+IFE ITS,[
+
+MFORK==400000
+
+P.CORE: JRST @[.+1]
+ ASH A,10. ; CHECK IT
+ CAMLE A,PURBOT
+ FATAL BAD ARG TO GET CORE
+ ASH A,-9. ; TO PAGES
+ PUSH P,D
+ PUSH P,A
+ SKIPN GCFLG
+ PUSHJ P,SQK
+ SETOM A ; FLUSH PAGES
+ HRRZ B,P.TOP ; GET P.TOP
+ ASH B,-9. ; TO PAGES
+ CAMLE B,(P)
+ SOJA B,P.CORD ; CORING DOWN
+ HRLI B,MFORK ; SET UP FORK POINTER
+P.COR2: HRRZ D,B
+ CAML D,(P) ; SEE IF DONE
+ JRST P.COR1
+ PMAP ; MAP OUT PAGE
+ ADDI B,1 ; NEXT PAGE
+ JRST P.COR2 ; LOOP BACK
+P.COR1: POP P,A ; RESTORE NEW P.TOP
+ POP P,D
+ ASH A,9. ; TO WORDS
+ MOVEM A,P.TOP
+ AOS (P)
+POPJA: ASH A,-10.
+ SKIPN MULTSG
+ POPJ P,
+ POP P,21
+ SETZM 20
+ JRST 5,20
+
+P.CORD: HRLI B,400000
+ PMAP
+ MOVEI D,-1(B)
+ CAMLE D,(P)
+ SOJA B,.-3
+ JRST P.COR1
+
+SQK: PUSH P,0
+ PUSH P,A
+ PUSH P,B
+ PUSH P,C
+ PUSH P,D
+ PUSH P,E
+ PUSHJ P,SQKIL
+ POP P,E
+ POP P,D
+ POP P,C
+ POP P,B
+ POP P,A
+ POP P,0
+ POPJ P,
+
+]
+
+IMPURE
+
+P.TOP==FRETOP
+
+PURE
+
+END
--- /dev/null
+
+TITLE PROCESS-HACKER FOR MUDDLE
+
+RELOCATABLE
+
+.INSRT MUDDLE >
+
+.GLOBAL ICR,NAPT,IGVAL,CHKARG,RESFUN,RETPROC,SWAP,MAINPR,PROCHK,NOTRES
+.GLOBAL PSTAT,LSTRES,TOPLEV,MAINPR,1STEPR,INCONS
+.GLOBAL TBINIT,APLQ,PVSTOR,SPSTOR
+
+MFUNCTION PROCESS,SUBR
+
+ ENTRY 1
+ GETYP A,(AB) ;GET TYPE OF ARG
+ ;MUST BE SOME APPLIABLE TYPE
+ PUSHJ P,APLQ
+ JRST NAPT ;NO, ERROR - NON-APPLIABLE TYPE
+OKFUN:
+
+ MOVEI A,TPLNT/2 ;SMALL STACK PARAMETERS
+ MOVEI B,PLNT/2
+ PUSHJ P,ICR ;CREATE A NEW PROCESS
+ MOVE C,TPSTO+1(B) ;GET ITS SRTACK
+ PUSH C,[TENTRY,,TOPLEV]
+ PUSH C,[1,,0] ;TIME
+ PUSH C,[0]
+ PUSH C,SPSTO(B)
+ PUSH C,PSTO+1(B)
+ MOVE D,C
+ ADD D,[3,,3]
+ PUSH C,D ;SAVED STACK POINTER
+ PUSH C,[SUICID]
+ MOVEM C,TPSTO+1(B) ;STORE NEW TP
+ HRRI D,1(C) ;MAKE A TB
+ HRLI D,400002 ;WITH A TIME
+ MOVEM D,TBINIT+1(B)
+ MOVEM D,TBSTO+1(B) ;SAVE ALSO FOR SIMULATED START
+ MOVE C,(AB) ;STORE ARG
+ MOVEM C,RESFUN(B) ;INTO PV
+ MOVE C,1(AB)
+ MOVEM C,RESFUN+1(B)
+ MOVEI 0,RUNABL
+ MOVEM 0,PSTAT+1(B)
+ JRST FINIS
+
+REPEAT 0,[
+MFUNCTION RETPROC,SUBR
+; WHO KNOWS WHAT THIS SHOULD REALLY DO
+;PROBABLY, JUST AN EXIT
+;FOR NOW, PRINT OUT AN ERROR MESSAGE
+ ERRUUO EQUOTE ATTEMPT-TO-RETURN-OUT-OF-PROCESS
+
+
+
+
+
+
+
+MFUNCTION RESUME,FSUBR
+;RESUME IS CALLED WITH TWO ARGS
+;THE FIRST IS A PROCESS FORM OF THE PROCESS TO BE RESUMED
+;THE SECOND IS A FUNCTION TO BE CALLED WHEN THIS PROCESS
+; (THE PARENT) IS ITSELF RESUMED
+;IF THE FUNCTION IS NOT GIVEN SOME STANDARD FUNCTION IS
+;PLUGGED IN
+;
+; NOTE - TYPE AND NUMBER OF ARGS CHECKS MUST BE ADDED TO BOTH RESUME AND CREATE
+
+ ENTRY 1
+ HRRZ C,@1(AB) ;GET CDR ADDRESS
+ JUMPE C,NOFUN ;IF NO SECOND ARG, SUPPLY STANDARD
+ HLLZ A,(C) ;GET CDR TYPE
+ CAME A,$TATOM ;ATOMIC?
+ JRST RES2 ;NO, MUST EVAL TO GET FUNCTION
+ MOVE B,1(C) ;YES
+ PUSHJ P,IGVAL ;TRY TO GET GLOBAL VALUE
+ CAMN A,$TUNBOUND ;GLOBALLY UNBOUND?
+ JRST LFUN ;YES, TRY FOR LOCAL VALUE
+RES1: MOVE PVP,PVSTOR+1
+ MOVEM A,RESFUN(PVP) ;STORE IN THIS PROCESS
+ MOVEM B,RESFUN+1(PVP)
+
+ HRRZ C,1(AB) ;GET CAR ADDRESS
+ PUSH TP,(C) ;PUSH PROCESS FORM
+ PUSH TP,1(C)
+ JSP E,CHKARG ;CHECK FOR DEFERED TYPE
+ ;INSERT CHECKS FOR PROCESS FORM
+ MCALL 1,EVAL ;EVAL PROCESS FORM WHICH WILL SWITCH
+ ; PROCESSES
+ JRST FINIS
+
+RES2: PUSH TP,(C) ;PUSH FUNCTION ARG
+ PUSH TP,1(C)
+ JSP E,CHKARG ;CHECK FOR DEFERED
+ MCALL 1,EVAL ;EVAL TO GET FUNCTION
+ JRST RES1
+
+LFUN: HRRZ C,1(AB) ;GET CDR ADDRESS
+ PUSH TP,(C)
+ PUSH TP,1(C)
+ MCALL 1,VALUE ;GET LOCAL VALUE OF ATOM FOR FUNCTION
+ JRST RES1
+
+NOFUN: MOVSI A,TUNBOUND ;MAKE RESUME FUNCTION UNBOUND
+ JRST RES1
+]
+
+; PROCHK - SETUP LAST RESUMER SLOT
+
+PROCHK: MOVE PVP,PVSTOR+1
+ CAME B,MAINPR ; MAIN PROCESS?
+ MOVEM PVP,LSTRES+1(B)
+ POPJ P,
+
+; THIS FUNCTION RESUMES A PROCESS, CALLED WITH ONE OR TWO ARGS
+; THE FIRST IS A VALUE TO RETURN TO THE OTHER PROCESS OR PASS TO ITS
+; RESFUN
+; THE SECOND IS THE PROCESS TO RESUME (IF NOT SUPPLIED, USE THE LSTRES)
+
+
+MFUNCTION RESUME,SUBR
+
+ ENTRY
+ JUMPGE AB,TFA
+ CAMGE AB,[-4,,0]
+ JRST TMA
+ CAMGE AB,[-2,,0]
+ JRST CHPROC ; VALIDITY CHECK ON PROC
+ MOVE PVP,PVSTOR+1
+ SKIPN B,LSTRES+1(PVP) ; ANY RESUMERS?
+ JRST NORES ; NO, COMPLAIN
+GOTPRO: MOVE C,AB
+ CAMN B,PVSTOR+1 ; DO THEY DIFFER?
+ JRST RETARG
+ MOVE A,PSTAT+1(B) ; CHECK STATE
+ CAIE A,RUNABL ; MUST BE RUNABL
+ CAIN A,RESMBL ; OR RESUMABLE
+ JRST RESUM1
+NOTRES:
+NOTRUN: ERRUUO EQUOTE PROCESS-NOT-RUNABLE-OR-RESUMABLE
+
+RESUM1: PUSHJ P,PROCHK ; FIX LISTS UP
+ MOVEI A,RESMBL ; GET NEW STATE
+ MOVE D,B ; FOR SWAP
+STRTN: JSP C,SWAP ; SWAP THEM
+ MOVEM A,PSTAT+1(E) ; CLOBBER OTHER STATE
+ MOVE PVP,PVSTOR+1
+ MOVE A,PSTAT+1(PVP) ; DECIDE HOW TO PROCEED
+ MOVEI 0,RUNING
+ MOVEM 0,PSTAT+1(PVP) ; NEW STATE
+ MOVE C,ABSTO+1(E) ; OLD ARGS
+ CAIE A,RESMBL
+ JRST DORUN ; THEY DO RUN RUN, THEY DO RUN RUN
+RETARG: MOVE A,(C)
+ MOVE B,1(C) ; RETURN
+ JRST FINIS
+
+DORUN: PUSH TP,RESFUN(PVP)
+ PUSH TP,RESFUN+1(PVP)
+ PUSH TP,(C)
+ PUSH TP,1(C)
+ MCALL 2,APPLY
+ PUSH TP,A ; CALL SUICIDE WITH THESE ARGS
+ PUSH TP,B
+ MCALL 1,SUICID ; IF IT RETURNS, KILL IT
+ JRST FINIS
+
+CHPROC: GETYP A,2(AB)
+ CAIE A,TPVP
+ JRST WTYP2
+ MOVE B,3(AB)
+ JRST GOTPRO
+
+NORES: ERRUUO EQUOTE NO-PROCESS-TO-RESUME
+
+; FUNCTION TO CAUSE PROCESSES TO SELF DESTRUCT
+
+MFUNCTION SUICIDE,SUBR
+
+ ENTRY
+
+ JUMPGE AB,TFA
+ HLRE A,AB
+ ASH A,-1 ; DIV BY 2
+ AOJE A,NOPROC ; NO PROCESS GIVEN
+ AOJL A,TMA
+ GETYP A,2(AB) ; MAKE SURE OF PROCESS
+ CAIE A,TPVP
+ JRST WTYP2
+ MOVE C,3(AB)
+ JRST SUIC2
+
+NOPROC: MOVE PVP,PVSTOR+1
+ SKIPN C,LSTRES+1(PVP)
+ MOVE C,MAINPR ; IF NOT DEFAULT TO MAIN
+SUIC2: CAMN C,PVP ; DONT SUICIDE TO SELF
+ JRST SUSELF
+ MOVE B,PSTAT+1(C)
+ CAIE B,RUNABL
+ CAIN B,RESMBL
+ JRST .+2
+ JRST NOTRUN
+ MOVE B,C
+ PUSHJ P,PROCHK
+ MOVE D,B ; RESTORE NEWPROCESS
+ MOVEI A,DEAD
+ JRST STRTN
+
+SUSELF: ERRUUO EQUOTE ATTEMPT-TO-SUICIDE-TO-SELF
+
+
+MFUNCTION RESER,SUBR,RESUMER
+
+ ENTRY
+ MOVE B,PVSTOR+1
+ JUMPGE AB,GTLAST
+ CAMGE AB,[-2,,0]
+ JRST TMA
+
+ GETYP A,(AB) ; CHECK FOR PROCESS
+ CAIE A,TPVP
+ JRST WTYP1
+ MOVE B,1(AB) ; GET PROCESS
+GTLAST: MOVSI A,TFALSE ; ASSUME NONE
+ SKIPN B,LSTRES+1(B) ; GET IT IF IT EXISTS
+ JRST FINIS
+ MOVSI A,TPVP ; GET TYPE
+ JRST FINIS
+
+; FUNCTION TO PUT AN EVAL CALL ON ANOTHER PROCESSES STACK
+
+MFUNCTION BREAKSEQ,SUBR,BREAK-SEQ
+
+ ENTRY 2
+
+ GETYP A,2(AB) ; 2D ARG MUST BE PROCESS
+ CAIE A,TPVP
+ JRST WTYP2
+
+ MOVE B,3(AB) ; GET PROCESS
+ CAMN B,PVSTOR+1 ; SKIP IF NOT ME
+ JRST BREAKM
+ MOVE A,PSTAT+1(B) ; CHECK STATE
+ CAIE A,RESMBL ; BEST BE RESUMEABLE
+ JRST NOTRUN
+ MOVE C,TBSTO+1(B) ; GET SAVE ACS TO BUILD UP A DUMMY FRAME
+ MOVE D,TPSTO+1(B) ; STACK POINTER
+ MOVE E,SPSTO+1(B) ; FIX UP OLD FRAME
+ MOVEM E,SPSAV(C)
+ MOVEI E,CALLEV ; FUNNY PC
+ MOVEM E,PCSAV(C)
+ MOVE E,PSTO+1(B) ; SET UP P,PP AND TP SAVES
+ MOVEM E,PSAV(C)
+ PUSH D,[0] ; ALLOCATES SOME SLOTS
+ PUSH D,[0]
+ PUSH D,(AB) ; NOW THAT WHIC IS TO BE EVALLED
+ PUSH D,1(AB)
+ MOVEM D,TPSAV(C)
+ HRRI E,-1(D) ; BUILD UP ARG POINTER
+ HRLI E,-2
+ PUSH D,[TENTRY,,BREAKE]
+ PUSH D,C ; OLD TB
+ PUSH D,E ; NEW ARG POINTER
+REPEAT 4,PUSH D,[0] ; OTHER SLOTS
+ MOVEM D,TPSTO+1(B)
+ MOVEI C,(D) ; BUILD NEW AB
+ AOBJN C,.+1
+ MOVEM C,TBSTO+1(B) ; STORE IT
+ MOVE A,2(AB) ; RETURN PROCESS
+ MOVE B,3(AB)
+ JRST FINIS
+
+MQUOTE BREAKER
+
+BREAKE:
+CALLEV: MOVEM A,-3(TP) ; HERE TO EVAL THE GOODIE (SAVE REAL RESULT)
+ MOVEM B,-2(TP)
+ MCALL 1,EVAL
+ POP TP,B
+ POP TP,A
+ JRST FINIS
+
+BREAKM: ERRUUO EQUOTE ATTEMPT-TO-BREAK-OWN-SEQUENCE
+
+; FUNCTION TOP PUT PROCESS IN 1 STEP MODE
+
+MFUNCTION 1STEP,SUBR
+ PUSHJ P,1PROC
+ MOVE PVP,PVSTOR+1
+ MOVEM PVP,1STEPR+1(B) ; CLOBBER TARGET PROCESS
+ JRST FINIS
+
+; FUNCTION TO UNDO ABOVE
+
+MFUNCTION %%FREE,SUBR,FREE-RUN
+ PUSHJ P,1PROC
+ MOVE PVP,PVSTOR+1
+ CAME PVP,1STEPR+1(B)
+ JRST FNDBND
+ SETZM 1STEPR+1(B)
+ JRST FINIS
+
+FNDBND: SKIPE 1STEPR+1(B) ; DOES IT HAVE ANY 1STEPPER?
+ JRST NOTMIN ; YES, COMPLAIN
+ MOVE D,B ; COPY PROCESS
+ ADD D,[1STEPR,,1STEPR] ; POINTER FOR SEARCH
+ HRRZ C,SPSTO+1(B) ; GET THIS BINDING STACK
+
+FNDLP: GETYP 0,(C) ; IS THIS A TBVL?
+ CAIN 0,TBVL
+ CAME D,1(C) ; SKIP IF THIS IS SAVED 1STEP SLOT
+ JRST FNDNXT
+ SKIPN 3(C) ; IS IT SAVING A REAL 1STEPPER?
+ JRST FNDNXT
+ MOVE PVP,PVSTOR+1
+ CAME PVP,3(C) ; IS IT ME?
+ JRST NOTMIN
+ SETZM 3(C) ; CLEAR OUT SAVED 1STEPPER
+ JRST FINIS
+FNDNXT: HRRZ C,(C) ; NEXT BINDING
+ JUMPN C,FNDLP
+
+NOTMIN: MOVE C,$TCHSTR
+ MOVE D,CHQUOTE NOT-YOUR-1STEPEE
+ PUSHJ P,INCONS
+ MOVSI A,TFALSE
+ JRST FINIS
+
+1PROC: ENTRY 1
+ GETYP A,(AB)
+ CAIE A,TPVP
+ JRST WTYP1
+ MOVE B,1(AB)
+ MOVE A,(AB)
+ POPJ P,
+
+; FUNCTION TO RETRUN THE MAIN PROCESS
+
+MFUNCTION MAIN%%,SUBR,MAIN
+ ENTRY 0
+
+ MOVE B,MAINPR
+MAIN1: MOVSI A,TPVP
+ JRST FINIS
+
+; FUNCTION TO RETURN THE CURRENT PROCESS
+
+MFUNCTION ME,SUBR
+ ENTRY 0
+
+ MOVE B,PVSTOR+1
+ JRST MAIN1
+
+; FUNCTION TO RETURN THE STATE OF A PROCESS
+
+MFUNCTION STATE,SUBR
+ ENTRY 1
+ GETYP A,(AB)
+ CAIE A,TPVP
+ JRST WTYP1
+ MOVE A,1(AB) ; GET PROCESS
+ MOVE A,PSTAT+1(A)
+ MOVE B,@STATES(A) ; GET STATE
+ MOVSI A,TATOM
+ JRST FINIS
+
+STATES:
+ IRP A,,[ILLEGAL,RUNABLE,RESUMABLE,RUNNING,DEAD,BLOCKED]
+ MQUOTE A
+ TERMIN
+
+
+
+END
+\f
\ No newline at end of file
--- /dev/null
+
+TITLE DECLARATION PROCESSOR
+
+RELOCA
+
+.INSRT MUDDLE >
+
+.GLOBAL STBL,TYPFND,TYPSGR,CHKDCL,TESTR,VALG,INCR1,TYPG,ISTRUC,TMATCH,SAT
+.GLOBAL TYPMIS,CHKAB,CHKARG,IGDECL,LOCQQ,APLQ,CALER,IEQUAL,IIGLOC,IGLOC
+.GLOBAL CHLOCI,INCONS,SPCCHK,OUTRNG,WTYP1,FLGSET,IGET,PVSTOR,SPSTOR,DSTORE
+
+; Subr to allow user to access the DECL checking code
+
+MFUNCTION CHECKD,SUBR,[DECL?]
+
+ ENTRY 2
+
+ MOVE C,(AB)
+ MOVE D,1(AB)
+ MOVE A,2(AB)
+ MOVE B,3(AB)
+ PUSHJ P,TMATCX ; CHECK THEM
+ JRST IFALS
+
+RETT: MOVSI A,TATOM
+ MOVE B,IMQUOTE T
+ JRST FINIS
+
+RETF:
+IFALS: MOVEI B,0
+ MOVSI A,TFALSE
+ JRST FINIS
+
+; Subr to turn DECL checking on and off.
+
+MFUNCTION %DECL,SUBR,[DECL-CHECK]
+
+ ENTRY
+
+ HRROI E,IGDECL
+ JRST FLGSET
+
+; Change special unspecial normal mode
+
+MFUNCTION SPECM%,SUBR,[SPECIAL-MODE]
+
+ ENTRY
+
+ CAMGE AB,[-3,,]
+ JRST TMA
+ MOVE C,SPCCHK ; GET CURRENT
+ JUMPGE AB,MODER ; RET CURRENT
+ GETYP 0,(AB) ; CHECK IT IS ATOM
+ CAIE 0,TATOM
+ JRST WTYP1
+ MOVE 0,1(AB)
+ MOVEI A,1
+ CAMN 0,MQUOTE UNSPECIAL
+ MOVSI A,(SETZ)
+ CAMN 0,MQUOTE SPECIAL
+ MOVEI A,0
+ JUMPG A,WTYP1
+ HLLM A,SPCCHK
+
+MODER: MOVSI A,TATOM
+ MOVE B,MQUOTE SPECIAL
+ SKIPGE C
+ MOVE B,MQUOTE UNSPECIAL
+ JRST FINIS
+
+; Function to turn special checking on and of
+
+MFUNCTION SPECC%,SUBR,[SPECIAL-CHECK]
+
+ ENTRY
+ CAMGE AB,[-3,,]
+ JRST TMA
+
+ MOVE C,SPCCHK
+ JUMPGE AB,SCHEK1
+
+ MOVEI A,0
+ GETYP 0,(AB)
+ CAIE 0,TFALSE
+ MOVEI A,1
+ HRRM A,SPCCHK
+
+SCHEK1: TRNN C,1
+ JRST IFALS
+ JRST RETT
+
+; Finction to set decls for GLOBAL values.
+
+MFUNCTION GDECL,FSUBR
+
+ ENTRY 1
+
+ GETYP 0,(AB)
+ CAIE 0,TLIST
+ JRST WTYP1
+
+ PUSH TP,$TLIST
+ PUSH TP,1(AB)
+ PUSH TP,$TLIST
+ PUSH TP,[0]
+ PUSH TP,$TLIST
+ PUSH TP,[0]
+
+GDECL1: INTGO
+ SKIPN C,1(TB)
+ JRST RETT
+ HRRZ D,(C) ; MAKE SURE PAIRS
+ JUMPE D,GDECLL ; LOSER, GO AWAY
+ GETYP 0,(C)
+ CAIE 0,TLIST
+ JRST GDECLL
+ HRRZ 0,(D)
+ MOVEM 0,1(TB) ; READY FOR NEXT CALL
+ MOVE C,1(C) ; SAVE ATOM LIST
+ MOVEM C,5(TB)
+ MOVEM D,3(TB)
+
+GDECL2: INTGO
+ SKIPN C,5(TB)
+ JRST GDECL1 ; OUT OF ATOMS
+ GETYP 0,(C) ; IS THIS AN ATOM
+ CAIE 0,TATOM
+ JRST GDECLL ; NO, LOSE
+ MOVE B,1(C)
+ HRRZ C,(C)
+ MOVEM C,5(TB)
+ PUSHJ P,IIGLOC ; GET ITS VAL (OR MAKE ONE)
+ GETYP 0,(B) ; UNBOUND?
+ CAIE 0,TUNBOU
+ JRST CHKCUR ; CHECK CURRENT VALUE
+ MOVE C,3(TB) ; GET DECL
+ HRRM C,-2(B)
+ JRST GDECL2
+
+CHKCUR: HRRZ D,3(TB)
+ GETYP A,(D)
+ MOVSI A,(A)
+ MOVE E,B
+ MOVE B,1(D)
+ MOVE C,(E)
+ MOVE D,1(E)
+ PUSH TP,$TVEC
+ PUSH TP,E
+ JSP E,CHKAB
+ PUSHJ P,TMATCH
+ JRST TYPMI3
+ MOVE E,(TP)
+ SUB TP,[2,,2]
+ MOVE D,3(TB)
+ HRRM D,-2(E)
+ JRST GDECL2
+
+TYPMI3: MOVE E,(TP) ; POINT BACK TO SLOT
+ MOVE A,-1(E) ; ATOM TO A
+ MOVE B,1(E)
+ MOVE D,(E) ; GET OLD VALUE
+ MOVE C,3(TB)
+ JRST TYPMIS ; GO COMPLAIN
+
+GDECLL: ERRUUO EQUOTE BAD-ARGUMENT-LIST
+
+MFUNCTION UNMANIFEST,SUBR
+
+ ENTRY
+
+ PUSH P,[HLLZS -2(B)]
+ JRST MANLP
+
+MFUNCTION MANIFEST,SUBR
+
+ ENTRY
+
+ PUSH P,[HLLOS -2(B)]
+MANLP: JUMPGE AB,RETT
+ GETYP 0,(AB)
+ CAIE 0,TATOM
+ JRST WTYP
+ MOVE B,1(AB)
+ PUSHJ P,IIGLOC
+ XCT (P)
+ ADD AB,[2,,2]
+ JRST MANLP
+
+MFUNCTION MANIFQ,SUBR,[MANIFEST?]
+
+ ENTRY 1
+
+ GETYP 0,(AB)
+ CAIE 0,TATOM
+ JRST WTYP1
+
+ MOVE B,1(AB)
+ PUSHJ P,IGLOC ; GET POINTER IF ANY
+ GETYP 0,A
+ CAIN 0,TUNBOU
+ JRST RETF
+ HRRZ 0,-2(B)
+ CAIE 0,-1
+ JRST RETF
+ JRST RETT
+
+MFUNCTION GETDECL,SUBR,[GET-DECL]
+
+ ENTRY 1
+
+ GETYP 0,(AB)
+ CAIN 0,TOFFS
+ JRST GETDOF
+ PUSHJ P,GTLOC
+ JRST GTLOCA
+
+ HRRZ C,-2(B) ; GET GLOBAL DECL
+GETD1: JUMPE C,RETF
+ CAIN C,-1
+ JRST RETMAN
+ GETYP A,(C)
+ MOVSI A,(A)
+ MOVE B,1(C)
+ JSP E,CHKAB
+ JRST FINIS
+GETDOF: HLRZ B,1(AB)
+ JUMPE B,GETDO1
+ MOVE A,(B)
+ MOVE B,1(B)
+ JRST FINIS
+GETDO1: MOVSI A,TATOM
+ MOVE B,IMQUOTE ANY
+ JRST FINIS
+
+RETMAN: MOVSI A,TATOM
+ MOVE B,MQUOTE MANIFEST
+ JRST FINIS
+
+GTLOCA: HLRZ C,2(B) ; LOCAL DECL
+ JRST GETD1
+
+MFUNCTION PUTDECL,SUBR,[PUT-DECL]
+
+ ENTRY 2
+
+ GETYP 0,(AB)
+ CAIN 0,TOFFS
+ JRST PUTDOF ; MAKE OFFSET WITH NEW DECL
+ PUSHJ P,GTLOC
+ SKIPA E,[HRLM B,2(C)]
+ MOVE E,[HRRM B,-2(C)]
+ PUSH P,E
+ GETYP 0,(B) ; ANY VALUE
+ CAIN 0,TUNBOU
+ JRST PUTD1
+ MOVE C,(B) ; GET CURRENT VALUE
+ MOVE D,1(B)
+ MOVE A,2(AB)
+ MOVE B,3(AB)
+ PUSHJ P,TMATCH
+ JRST TYPMI4
+PUTD1: MOVE C,2(AB) ; GET DECL BACK
+ MOVE D,3(AB)
+ PUSHJ P,INCONS ; CONS IT UP
+ MOVE C,1(AB) ; LOCATIVE BACK
+ XCT (P) ; CLOBBER
+ MOVE A,(AB)
+ MOVE B,1(AB)
+ JRST FINIS
+
+TYPMI4: MOVE E,1(AB) ; GET LOCATIVE
+ MOVE A,-1(E) ; NOW ATOM
+ MOVEI C,2(AB) ; POINT TO DECL
+ MOVE D,(E) ; AND CURRENT VAL
+ MOVE B,1(E)
+ JRST TYPMIS
+
+GTLOC: GETYP 0,(AB)
+ CAIE 0,TLOCD
+ JRST WTYP1
+ MOVEI B,(AB)
+ PUSHJ P,CHLOCI
+ HRRZ 0,(AB) ; LOCAL OR GLOBAL
+ SKIPN 0
+ AOS (P)
+ MOVE B,1(AB) ; RETURN LOCATIVE IN B
+ POPJ P,
+
+; MAKE OFFSET WITH SUPPLIED DECL
+PUTDOF: MOVE D,3(AB)
+ GETYP 0,2(AB)
+ CAIN TATOM
+ CAME D,IMQUOTE ANY
+ JRST PUTDO1
+ MOVSI A,TOFFS
+ HRRZ B,1(AB)
+ JRST FINIS
+PUTDO1: MOVE C,2(AB)
+ PUSHJ P,INCONS ; BUILD A LIST
+ MOVSI A,TOFFS
+ HRLS B
+ HRR B,1(AB) ; SET UP OFFSET
+ JRST FINIS
+
+; BUILD AN OFFSET--TAKES FIX AND DECL (OR ATOM FORM)
+; JUMPS INTO PUT-DECL CODE FOR OFFSETS.
+ MFUNCTION COFFSET,SUBR,[OFFSET]
+
+ ENTRY 2
+ GETYP 0,(AB)
+ CAIE 0,TFIX
+ JRST WTYP1
+ SKIPG 1(AB)
+ JRST OUTRNG ; CAN'T HAVE NEGATIVE OFFSETS
+ GETYP 0,2(AB)
+ CAIE 0,TATOM
+ CAIN 0,TFORM
+ JRST PUTDOF
+ JRST WTYP2
+
+; GET FIX PART OF OFFSET
+ MFUNCTION INDEX,SUBR
+
+ ENTRY 1
+ GETYP 0,(AB)
+ CAIE 0,TOFFS
+ JRST WTYP1
+ MOVSI A,TFIX
+ HRRE B,1(AB)
+ JRST FINIS
+\f
+; Interface between EVAL and declaration processor.
+; E points into stack at a binding and C points to decl list.
+
+CHKDCL: SKIPE IGDECL ; IGNORING DECLS?
+ POPJ P, ; YUP, JUST LEAVE
+
+ PUSH TP,$TTP ; SAVE BINDING
+ PUSH TP,E
+ MOVE A,-4(E) ; GET ATOM
+ MOVSI 0,TLIST ; SETUP FOR INTERRUPTABLE
+ MOVE PVP,PVSTOR+1
+ MOVEM 0,CSTO(PVP)
+ MOVEM 0,BSTO(PVP)
+ MOVSI 0,TATOM
+ MOVEM 0,ASTO(PVP)
+ SETZB B,0 ; CLOBBER FOR INTGO
+
+DCL2: INTGO
+ HRRZ D,(C) ; MAKE SURE EVEN ELEMENTS
+ JUMPE D,BADCL
+ GETYP B,(C) ; MUST BE LIST OF ATOMS
+ CAIE B,TLIST
+ JRST BADCL
+ MOVE B,1(C) ; GET LIST
+
+DCL1: INTGO
+ CAMN A,1(B) ; SKIP IF NOT WINNER
+ JRST DCLQ ; MAY BE WINNER
+DCL3: HRRZ B,(B) ; CDR ON
+ JUMPN B,DCL1 ; JUMP IF MORE
+
+ HRRZ C,(D) ; CDR MAIN LIST
+ JUMPN C,DCL2 ; AND JUMP IF WINNING
+
+ PUSHJ P,E.GET ; GET BINDING BACK
+ SUB TP,[2,,2] ; POP OF JUNK
+ POPJ P,
+
+DCLQ: GETYP C,(B) ; CHECK ATOMIC
+ CAIE C,TATOM
+ JRST BADCL ; LOSER
+ PUSHJ P,E.GET ; GOT IT
+ PUSH TP,$TLIST ; SAVE PATTERN
+ PUSH TP,D
+ MOVE B,1(D) ; GET PATTERN
+ HLLZ A,(D)
+ MOVE C,-3(E) ; PROPOSED VALUE
+ MOVE D,-2(E)
+ PUSHJ P,TMATCH ; MATCH TYPE
+ JRST TYPMI1 ; LOSER
+DCLQ1: MOVE E,-2(TP)
+ MOVE C,-5(E) ; CHECK FOR SPEC CHANGE
+ SKIPE 0 ; MAKE SURE NON ZERO IS -1
+ MOVNI 0,1
+ SKIPL SPCCHK ; SKIP IF NORMAL UNSPECIAL
+ SETCM 0 ; COMPLEMENT
+ ANDI 0,1 ; ONE BIT
+ CAMN C,[TATOM,,-1]
+ JRST .+3
+ CAME C,[TATOM,,-2]
+ JRST .+3
+ ANDCMI C,1
+ IOR C,0 ; MUNG BIT
+ MOVEM C,-5(E)
+ HRRZ C,(TP)
+ SUB TP,[4,,4]
+ MOVEM C,(E) ; STORE DECLS
+ MOVSI C,TLIST
+ MOVEM C,-1(E)
+ POPJ P,
+
+TYPMI1: MOVE E,-2(TP)
+ GETYP C,-3(E)
+ CAIN C,TUNBOU
+ JRST DCLQ1
+ MOVE E,-2(TP) ; GET POINTER TO BIND
+ MOVE D,-3(E) ; GET VAL
+ MOVE B,-2(E)
+ HRRZ C,(TP) ; DCL LIST
+ MOVE A,-4(E) ; GET ATOM
+ SUB TP,[4,,4]
+TYPMIS: PUSH TP,$TATOM
+ PUSH TP,EQUOTE TYPE-MISMATCH
+ PUSH TP,$TATOM
+ PUSH TP,A
+ PUSH TP,(C)
+ HLLZS (TP)
+ PUSH TP,1(C)
+ JSP E,CHKARG ; HACK DEFER
+ PUSH TP,D
+ PUSH TP,B
+ MOVEI A,4 ; 3 ERROR ARGS
+ JRST CALER
+
+BADCL: PUSHJ P,E.GET
+ ERRUUO EQUOTE BAD-DECLARATION-LIST
+
+; ROUTINE TO RESSET INT STUFF
+
+E.GET: MOVE E,(TP)
+ MOVE PVP,PVSTOR+1
+ SETZM ASTO(PVP)
+ SETZM BSTO(PVP)
+ SETZM CSTO(PVP)
+ POPJ P,
+
+; Declarations processor for MUDDLE type declarations.
+; Receives a pattern in a and B and an object in C and D.
+; It skip returns if the object fits otherwise it doesn't.
+; Declaration syntax errors are caught and sent to ERROR.
+
+TMATCH: MOVEI 0,1 ; RET SPECIAL INDICATOR
+ SKIPE IGDECL ; IGNORING DECLS?
+ JRST CPOPJ1 ; YUP, ACT LIKE THEY WON
+
+TMATCX: GETYP 0,A ; GET PATTERNS TYPE
+ CAIE 0,TSEG
+ CAIN 0,TFORM ; MUST BE FORM OR ATOM
+ JRST TMAT1
+ CAIE 0,TATOM
+ JRST TERR1 ; WRONG TYPE FOR A DCL
+
+; SIMPLE TYPE MATCHER
+
+TYPMAT: GETYP E,C ; OBJECTS TYPE TO E
+ PUSH P,E ; SAVE IT
+ PUSH TP,C
+ PUSH TP,D
+ PUSHJ P,TYPFND ; CONVERT TYPE NAME TO CODE
+ JRST SPECS ; NOT A TYPE NAME, TRY SPECIALS
+ SUB TP,[2,,2]
+ POP P,E ; RESTORE TYPE OF OBJECT
+ MOVEI 0,0 ; SPECIAL INDICATOR
+ CAIN E,(D) ; SKIP IF LOSERS
+CPOPJ1: AOS (P) ; GOOD RETURN
+CPOPJ: POPJ P,
+
+SPECS: POP P,A ; RESTORE OBJECTS TYPE
+ POP TP,D
+ POP TP,C
+ CAMN B,IMQUOTE ANY
+ JRST CPOPJ1 ; RETURN IMMEDIATELY IF ANYTHING WINS
+ CAMN B,IMQUOTE STRUCTURED
+ JRST ISTRUC ; LET ISTRUC DO THE WORK
+ CAMN B,IMQUOTE APPLICABLE
+ JRST APLQ
+ CAMN B,IMQUOTE LOCATIVE
+ JRST LOCQQ
+ PUSH TP,$TATOM
+ PUSH TP,B
+ PUSH TP,C
+ PUSH TP,D
+ MOVSI A,TATOM
+ MOVSI C,TATOM
+ MOVE D,IMQUOTE DECL
+ PUSHJ P,IGET
+ JUMPE B,TERR2X
+ MOVEM A,-3(TP)
+ MOVEM B,-2(TP)
+ INTGO
+ POP TP,D
+ POP TP,C
+ POP TP,B
+ POP TP,A
+ JRST TMATCX
+
+; ARRIVE HERE FOR A FORM IN THE DCLS
+
+TMAT1: JUMPE B,TERR3 ; EMPTY FORM LOSES
+ HRRZ E,(B) ; CDR IT
+ JUMPE E,TMAT3 ; CANT BE SPECIAL/UNSPECIAL, LEAVE
+ PUSHJ P,0ATGET ; GET POSSIBLE ATOM IN 0
+ JRST TEXP1 ; NOT ATOM
+ CAME 0,MQUOTE SPECIAL
+ CAMN 0,MQUOTE UNSPECIAL
+ JRST TMAT2 ; IGNORE SPECIAL/UNSPECIAL
+TMAT3: PUSHJ P,TEXP1
+ JRST .+2
+ AOS (P)
+ MOVEI 0,0 ; RET UNSPECIAL INDICATION
+ POPJ P,
+
+TEXP1: JUMPE B,TERR3 ; EMPTY FORM
+ GETYP E,A ; CHECK CURRENT TYPE
+ CAIN E,TATOM ; IF ATOM,
+ JRST TYPMA1 ; SIMPLE MATCH
+ CAIN E,TSEG
+ JRST .+3
+ CAIE E,TFORM
+ JRST TERR4
+ GETYP 0,(B) ; WHAT IS FIRST ELEMEMT
+ CAIE 0,TFORM ; FORM=> <<OR ..>....> OR <<PRIMTYPE FOO>....>
+ JRST TEXP12
+ PUSH TP,$TLIST ; SAVE LIST
+ PUSH TP,B
+ MOVE B,1(B) ; GET FORM
+ PUSH TP,C
+ PUSH TP,D
+ PUSH P,E
+ PUSHJ P,ACTRT1
+ TDZA 0,0 ; REMEMBER LACK OF SKIP
+ MOVEI 0,1
+ POP P,E
+ POP TP,D
+ POP TP,C
+ MOVE B,(TP) ; GET BACK SAVED LIST
+ SUB TP,[2,,2]
+ JUMPE 0,CPOPJ ; LOSERS EXIT IMMEDIATELY
+ HRRZ B,(B) ; OTHERWISE REST THE LIST AND FALL INTO ELETYPE
+
+; CHECKS TYPES OF ELEMENTS OF STRUCTURES
+
+ELETYP: CAIE E,TSEG ; MUST BE EXAXT?
+ JUMPE B,CPOPJ1 ; EMPTY=> WON
+ PUSH TP,$TLIST ; SAVE DCL LIST
+ PUSH TP,B
+ MOVE A,C ; GET OBJ IN A AND B
+ MOVE B,D
+ CAIE E,TSEG
+ TDZA E,E
+ MOVNI E,1
+ PUSH P,E
+ PUSHJ P,TYPSGR ; GET REST/NTH CODE
+ JRST ELETYL ; LOSER
+ CAIN C,5 ; BYTE STRING COMES HERE
+ JRST ELEBYT ; HACK IT
+ PUSH TP,DSTORE
+ PUSH TP,D
+ PUSH P,C ; SAVE CODE
+ PUSH TP,[0] ; AND SLOTS
+ PUSH TP,[0]
+
+; MAIN ELEMENT SCANNING LOOP
+
+ELETY1: XCT TESTR(C) ; SKIP IF OBJ NOT EMPTY
+ JRST ELETY2 ; CHEK EMPTY WINNER
+ SKIPN -4(TP)
+ JRST ELETY4
+ XCT TYPG(C) ; GET ELEMENT
+ XCT VALG(C)
+ JSP E,CHKAB ; CHECK OUT DEFER
+ MOVEM A,-1(TP) ; AND SAVE IT
+ MOVEM B,(TP)
+ MOVE C,A
+ MOVE D,B ; FOR OTHER MATCHERS
+ MOVE B,-4(TP) ; GET PATTERN
+ MOVE A,(B)
+ GETYP 0,(B) ; GET TYPE OF <1 pattern>
+ MOVE B,1(B) ; GET ATOM OR WHATEVER
+ CAIE 0,TATOM ; ATOM ... SIMPLE TYPE
+ JRST ELETY3
+ PUSHJ P,TYPMAT ; DO SIMPLE TYPE MATCH
+ JRST ELETY4 ; LOSER
+
+; HERE TO REST EVERYTHING AND GO ON BACK
+
+ELETY6: MOVE D,-2(TP) ; GET OBJ POINTER
+ MOVE C,(P) ; GET INCREMENT CODE
+ XCT INCR1(C)
+ MOVEM D,-2(TP) ; SAVED INCREMENTED GOODIR
+ MOVE 0,DSTORE
+ MOVEM 0,-3(TP)
+
+ELETY9: HRRZ B,@-4(TP) ; CDR IT
+ MOVEM B,-4(TP)
+ JUMPN B,ELETY1
+
+ SKIPN -1(P) ; SKIP IF EXACT REQUIRED
+ JRST ELETY8
+ XCT TESTR(C)
+ JRST ELETY8
+ JRST ELETY4
+
+
+; HERE IF PATTERN EMPTY
+
+ELETY8: AOS -2(P) ; SKIP RETURN
+ELETY4: SETZM DSTORE
+ SUB P,[2,,2]
+ SUB TP,[6,,6]
+ POPJ P,
+
+ELETYL: SUB P,[1,,1]
+ SUB TP,[2,,2]
+ POPJ P,
+
+; HERE TO HANDLE EMPTY OBJECT
+
+ELETY2: MOVE B,-4(TP) ; GET PATTERN
+ JUMPE B,ELETY8
+ GETYP 0,(B) ; CHECK FOR [REST ...]
+ SETZM DSTORE
+ CAIE 0,TVEC
+ JRST ELETY4 ; LOSER
+ HLRZ 0,1(B) ; SIZE OF IT
+ CAILE 0,-4 ; MUST BE 2
+ JRST ELETY4
+ MOVE B,1(B) ; GET IT
+ PUSHJ P,0ATGET ; LOOK FOR REST
+ JRST ELETY4
+ CAMN 0,MQUOTE OPTIONAL
+ JRST ELETY8
+ CAME 0,MQUOTE OPT
+ CAMN 0,IMQUOTE REST
+ JRST ELETY8 ; WINNER!!!!
+ JRST ELETY4 ; LOSER
+
+; HERE TO CHECK OUT A FORM ELEMNT
+
+ELETY3: CAIN 0,TSEG
+ JRST ELGO
+ CAIE 0,TFORM
+ JRST ELETY7
+ELGO: SETZM DSTORE
+ PUSHJ P,TEXP1 ; AND ANALYSE IT
+ JRST ELETY4 ; LOSER
+ MOVE 0,-3(TP) ; RESET DSTO
+ MOVEM 0,DSTORE
+ JRST ELETY6 ; WINNER
+
+; CHECK FOR VECTOR IN PATTERN
+
+ELETY7: CAIE 0,TVEC ; SKIP IF WINNER
+ JRST TERR12 ; YET ANOTHER ERROR
+ HLRE C,B ; CHECK LEENGTH
+ CAMLE C,[-4] ; MUST BE 2 LONG
+ JRST TERR13
+ PUSHJ P,0ATGET ; 1ST ELEMENT ATOM?
+ JRST ELET71 ; COULD BE FORM
+ CAME 0,MQUOTE OPT
+ CAMN 0,MQUOTE OPTIONAL
+ JRST ELET72
+ CAME 0,IMQUOTE REST
+ JRST TERR14
+ MOVE 0,(P) ; GET STRUC CODE
+ CAIN 0,2
+ CAME C,[-4]
+ JRST ELNUVE
+
+ GETYP 0,2(B) ; SEE IF UVECTOR REST SIMPLE TYPE
+ CAIE 0,TATOM
+ JRST ELNUVE
+
+ MOVE C,3(B) ; GET ATOM
+ HLRE 0,C
+ SUB C,0 ; POINT TO DOPE WDS
+ HRRE 0,(C)
+ JUMPE 0,ELNUVE
+ MOVSI A,TATOM
+ MOVE B,3(B)
+ MOVE C,-2(TP)
+ HLRE D,C
+ SUB C,D
+ GETYP C,(C)
+ MOVSI C,(C)
+ PUSHJ P,TMATCX
+ JRST ELETY4
+ JRST ELETY8
+
+ELNUVE: TDOA 0,[-1]
+ELET72: MOVSI 0,(SETZ) ; FLAG USED IN RESTIT
+ PUSH P,0
+ PUSHJ P,RESTIT ; CHECK REST OF STRUCTUR
+ JRST ELET41
+ POP P,0
+ TRNE 0,-1
+ JRST ELETY8 ; WIN AND DONE
+ JRST ELET81
+
+ELET41: SUB P,[1,,1]
+ JRST ELETY4
+
+; CHECK FOR [fix .... ]
+
+ELET71: CAIE 0,TFIX
+ JRST TERR15
+ MOVNS C
+ ASH C,-1
+ MOVE 0,1(B) ; GET NUMBER
+ IMULI 0,-1(C) ; COUNT MORE
+ PUSH P,0
+ PUSHJ P,RESTIT ; AND CHECK FIX NUM OF ELEMENTS
+ TDZA 0,0
+ MOVEI 0,1
+ SUB P,[1,,1]
+ JUMPE 0,ELETY4
+ELET81: MOVE D,-2(TP) ; GET OBJECT BACK
+ MOVE 0,-3(TP) ; RESET DSTO
+ MOVEM 0,DSTORE
+ MOVE C,(P) ; RESTORE CODE FOR RESTING ETC.
+ JRST ELETY9
+
+
+; HERE TO DO A TASTEFUL TYPMAT
+
+TYPMA1: PUSH TP,C
+ PUSH TP,D
+ PUSHJ P,TYPMAT
+ TDZA 0,0 ; REMEMBER LOSSAGE
+ MOVEI 0,1 ; OR WINNAGE
+ POP TP,D
+ POP TP,C ; RESTORE OBJECT
+ JUMPN 0,CPOPJ1 ; SKIPPED BEFORE, SKIP AGAIN
+ POPJ P,
+
+; HERE TO SKIP SPECIAL/UNSPECIAL
+
+TMAT2: CAME 0,MQUOTE SPECIAL
+ TDZA 0,0
+ MOVEI 0,1
+ PUSH P,0 ; SAVE INDICATOR
+ HRRZ A,(E) ; CHECK FOR EXACT LENGTH
+ JUMPN A,TERR16
+ GETYP A,(E) ; TYPE OF NEW PAT
+ MOVE B,1(E) ; VALUE
+ MOVSI A,(A)
+ PUSHJ P,TEXP1
+ JRST .+2
+ AOS -1(P)
+ POP P,0
+ POPJ P,
+
+; LOOK FOR <OR... OR <PRIMTYPE....
+
+TEXP12: CAIE 0,TATOM
+ JRST TERR5
+ MOVE 0,1(B) ; GET ATOM
+ CAMN 0,IMQUOTE QUOTE
+ JRST MQUOT ; MATCH A QUOTED OBJECT
+ CAME 0,IMQUOTE OR
+ CAMN 0,IMQUOTE PRIMTYPE
+ JRST ACTORT ; FALL INTO ACTOR HACKER
+ PUSH TP,$TLIST
+ PUSH TP,B
+ MOVE B,0 ; GET ATOM
+ PUSH TP,C ; SAVE OBJ
+ PUSH TP,D
+ PUSH P,E
+ PUSHJ P,TYPMAT
+ TDZA 0,0
+ MOVEI 0,1
+ POP P,E
+ MOVE C,-1(TP)
+ MOVE D,(TP)
+ MOVE B,-2(TP)
+ JUMPN 0,.+3 ; TO ELETYP IF WON
+ SUB TP,[4,,4]
+ POPJ P, ; ELSE LOSE
+
+ HRRZ 0,(B)
+ MOVSI A,TFORM
+ JUMPE 0,TERR3
+ MOVE B,0
+ PUSHJ P,ELETYP
+FOOPC: TDZA 0,0
+ MOVEI 0,1
+POPPIT: POP TP,D
+ POP TP,C
+ POP TP,B
+ POP TP,A
+ JUMPN 0,CPOPJ1
+ POPJ P,
+
+; THIS CODE HANDLES ORs AND PRIMTYPEs
+ACTRT1: SKIPA E,[SETZ PACT]
+
+ACTORT: MOVE E,[SETZ TEXP1]
+ JUMPE B,TERR6 ; EMPTY, LOSE
+ PUSHJ P,0ATGET ; ATOM TO 0
+ JRST PACT
+ CAME 0,IMQUOTE OR
+ JRST PACT2
+ HRRZ 0,(B) ; REST IT FLUSHING OR
+ JUMPE 0,TERR7
+ PUSH TP,$TLIST ; SAVE LSIT
+ PUSH TP,0
+ PUSH P,E ; SAVE ELEMENT CHECKER
+
+ORLP: SKIPN B,(TP) ; ANY LEFT?
+ JRST ORDON ; NOPE, LOSE
+ HRRZ 0,(B) ; SAVE THE REST
+ MOVEM 0,(TP)
+ GETYP 0,(B) ; WHAT ARE WE ORing
+ MOVE A,(B) ; TYPE WORD
+ MOVE B,1(B) ; AND ITEM
+ PUSH TP,C
+ PUSH TP,D
+ PUSHJ P,@(P) ; EITHER PACT OR TEXP1
+ TDZA 0,0
+ MOVEI 0,1
+ POP TP,D
+ POP TP,C
+ JUMPE 0,ORLP
+ AOS -1(P) ; SKIP RETURN FOR WINNER
+
+ORDON: SUB TP,[2,,2] ; FLUSH TEMP
+ SUB P,[1,,1]
+ POPJ P,
+
+; HERE TO PRIMTYPE ACTORS
+
+PACT: CAIE 0,TFORM
+ JRST PACT1
+ JUMPE B,TERR6 ; EMPTY FORM
+ MOVE 0,1(B) ; FIRST ELEMENT MUST BE PRIMTYPE
+PACT2: CAME 0,IMQUOTE PRIMTYPE
+ JRST TERR7
+ HRRZ A,(B) ; GET PRIMTYPE
+ JUMPE A,TERR7
+ HRRZ 0,(A)
+ JUMPN 0,TERR18
+ MOVEI B,(A)
+ GETYP A,C ; GET OBJ TYPE
+ GETYP 0,(B) ; GET PATTERN TYPE
+ CAIE 0,TATOM ; BETTER BE ATOM
+ JRST TERR8
+ PUSH TP,$TLIST ; SAVE DCL LIST
+ PUSH TP,B
+ PUSH TP,C
+ PUSH TP,D
+ PUSHJ P,SAT ; GET STORAGE TYPE
+ CAILE A,NUMSAT
+ JRST PTEMP
+ MOVE B,@STBL(A) ; GET PRIM NAME
+ PUSHJ P,TYPFND
+ JFCL ; MUST EXIST
+ MOVSI C,(D) ; FAKE OUT TYPMAT
+ MOVE B,-2(TP)
+ MOVE B,1(B)
+ PUSHJ P,TYPMAT
+ JRST .+2
+ AOS (P)
+ MOVE C,-1(TP)
+ MOVE D,(TP)
+ SUB TP,[4,,4]
+ POPJ P,
+
+PACT1: CAIE 0,TATOM
+ JRST TERR4
+ JRST TYPMAT
+
+PTEMP: MOVE B,-2(TP)
+ MOVE B,1(B)
+ CAMN B,IMQUOTE TEMPLATE
+ AOS (P)
+ SUB TP,[4,,4]
+ POPJ P,
+
+; RESTIT - TYPE CHECK SELECTED NUMBER OF ELEMENTS IN STRUCTURE
+
+RESTIT: PUSH TP,$TVEC ; SAVE TYPE
+ ADD B,[2,,2] ; SKIP OVER CRUFT
+ PUSH TP,B ; AND VAL
+ PUSH TP,$TVEC
+ PUSH TP,B
+RESTI1: PUSH P,A ; SAVE DISP HACK
+ PUSH P,0 ; AND COUNT HACK
+RESTI4: SKIPL (P) ; SKIP IF DOING ALL
+ SOSL (P) ; SKIP IF DONE
+ JRST RESTI6
+ AOS -2(P) ; SKIP RET
+RESTI5: SUB P,[2,,2] ; POP JUNK
+ SUB TP,[4,,4]
+ POPJ P,
+RESTI6: SKIPGE (TP)
+ JRST RESTX1
+ HLRZ 0,(P)
+ CAIN 0,(SETZ)
+ JRST RESTI2
+RESTX1: MOVE C,-4(P) ; REST CODE
+ MOVE D,-6(TP) ; SET UP FOR REST
+ MOVE E,-7(TP) ; DONT FORGET DSTO
+ MOVEM E,DSTORE
+ XCT TESTR(C) ; DONE?
+ JRST RESTI2 ; YES, CHECK WINNAGE
+ XCT TYPG(C)
+ XCT VALG(C) ; GET VAL ANDTYPE
+ JSP E,CHKAB ; CHECK DEFER
+ XCT INCR1(C) ; REST IT
+ MOVEM D,-6(TP) ; SAVE LIST
+ MOVE E,DSTORE
+ MOVEM E,-7(TP) ; FIXUP
+ SETZM DSTORE
+ MOVE C,A
+ MOVE D,B
+ SKIPL A,(TP) ; ANY MORE?
+ MOVE A,-2(TP) ; NO RECYCLE
+ ADD A,[2,,2] ; BUMP
+ MOVEM A,(TP) ; AND SAVE
+ MOVE B,-1(A) ; GET ELEMENT
+ MOVE A,-2(A)
+ GETYP 0,A
+ MOVEI E,TERR15
+ CAIN 0,TATOM
+ MOVEI E,TYPMAT ; ATOM --> SIMPLE TYPE
+ CAIE 0,TSEG
+ CAIN 0,TFORM ; FORM--> HAIRY PATTERN
+ MOVEI E,TEXP1
+ TLO E,400000
+ PUSHJ P,(E) ; DO IT
+ JRST RESTI5
+ JRST RESTI4
+
+RESTI2: SKIPGE (P) ; SKIP IF WON
+ AOS -2(P) ; COUNTERACT CPOPJ1
+ JRST RESTI5
+
+RESTI3: TEXP1
+ TYPMAT
+
+; HERE TO MATHC A QUOTED OBJ
+; B/ FORM QUOTE... C,D/ OBJECT TO MATCH AGAINST
+
+MQUOT: HRRZ B,(B) ; LOOK AT NEXT
+ JUMPE B,TERR7
+ GETYP A,(B) ; GET TYPE
+ MOVSI A,(A)
+ MOVE B,1(B) ; AND VALUE
+ JSP E,CHKAB ; HACK DEFER
+ PUSH TP,A
+ PUSH TP,B
+ PUSH TP,C
+ PUSH TP,D
+ MOVEI D,-3(TP)
+ MOVEI C,-1(TP)
+ PUSHJ P,IEQUAL
+ TDZA 0,0
+ MOVEI 0,1
+ JRST POPPIT
+
+; HERE TO HANDLE SPECIAL BYTE STRING HAIR
+
+ELEBYT: MOVE B,(TP) ; GET DECL LIST BACK
+ POP P,E ; EXACTNESS FLAG
+ JUMPE B,ELEBY2
+ GETYP 0,(B)
+ CAIE 0,TFIX
+ JRST TERR17
+ MOVE A,1(B)
+ HRRZ B,(B)
+ HRRZ 0,(B)
+ SKIPE B
+ JUMPN 0,TERR17
+ LDB C,[300600,,D] ; GET BYTE SIZE
+ CAIE A,(C)
+ JRST ELEBY3
+ HRRZ C,DSTORE
+ELEBY2: MOVEI A,0
+ JUMPE B,ELEBY4
+ GETYP 0,(B)
+ CAIE 0,TFIX
+ JRST TERR17
+ MOVE A,1(B)
+ELEBY4: CAIGE C,(A)
+ JRST ELEBY3
+ CAIE A,(C)
+ JUMPN E,ELEBY3
+ AOS (P)
+ELEBY3: SETZM DSTORE
+ SUB TP,[2,,2]
+ POPJ P,
+
+
+
+; GET ATOM IN AC 0
+
+0ATGET: GETYP 0,(B)
+ CAIE 0,TATOM ; SKIP IF ATOM
+ POPJ P,
+ MOVE 0,1(B) ; GET ATOM
+ JRST CPOPJ1
+
+TERR17: MOVE B,-2(TP)
+ MOVE B,1(B)
+ HRRZ 0,(P)
+ CAIN 0,FOOPC
+ MOVE B,-4(TP)
+ MOVSI A,TFORM
+ MOVE E,EQUOTE BAD-BYTES-DECL
+ SETZM DSTORE
+ JRST TERRD
+
+TERR18: SKIPA E,EQUOTE TOO-MANY-ARGS-TO-PRIMTYPE-DECL
+TERR16: MOVE E,EQUOTE TOO-MANY-ARGS-TO-SPECIAL-UNSPECIAL-DECL
+ MOVSI A,TFORM
+ JRST TERRD
+
+TERR9: MOVS A,0 ; TYPE TO A
+TERR4:
+TERR5:
+TERR15:
+TERR1: MOVE E,EQUOTE DECL-ELEMENT-NOT-FORM-OR-ATOM
+ JRST TERRD
+
+TERR2X: SUB TP,[2,,2]
+ POP TP,B
+ POP TP,A
+
+TERR2: MOVSI A,TATOM
+ MOVE E,EQUOTE ATOM-NOT-TYPE-NAME-OR-SPECIAL-SYMBOL
+ JRST TERRD
+TERR6:
+TERR3: MOVE E,EQUOTE EMPTY-FORM-IN-DECL
+ JRST TERRD
+TERR7: MOVE E,EQUOTE EMPTY-OR/PRIMTYPE-FORM
+ JRST TERRD
+
+TERR8: MOVS A,0 ; TYPE TO A
+ MOVE E,EQUOTE NON-TYPE-FOR-PRIMTYPE-ARG
+ JRST TERRD
+TERR12: MOVE E,EQUOTE ELEMENT-TYPE-NOT-ATOM-FORM-OR-VECTOR
+ JRST TERRD
+TERR13: MOVE E,EQUOTE VECTOR-LESS-THAN-2-ELEMENTS
+ JRST TERRD
+TERR14: MOVE E,EQUOTE FIRST-VECTOR-ELEMENT-NOT-REST-OR-A-FIX
+
+TERRD: PUSH TP,$TATOM
+ PUSH TP,EQUOTE BAD-TYPE-SPECIFICATION
+ PUSH TP,$TATOM
+ PUSH TP,E
+ PUSH TP,A
+ PUSH TP,B
+ MOVEI A,3
+ JRST CALER
+
+IMPURE
+
+IGDECL: 0
+
+PURE
+
+END
+\f\f
\ No newline at end of file
--- /dev/null
+
+TITLE DECLARATION PROCESSOR
+
+RELOCA
+
+.INSRT MUDDLE >
+
+.GLOBAL STBL,TYPFND,TYPSGR,CHKDCL,TESTR,VALG,INCR1,TYPG,ISTRUC,TMATCH,SAT
+.GLOBAL TYPMIS,CHKAB,CHKARG,IGDECL,LOCQQ,APLQ,CALER,IEQUAL,IIGLOC,IGLOC
+.GLOBAL CHLOCI,INCONS,SPCCHK,OUTRNG,WTYP1,FLGSET,IGET,PVSTOR,SPSTOR,DSTORE
+.GLOBAL NOATMS,NOSET,NOSETG
+; Subr to allow user to access the DECL checking code
+
+MFUNCTION CHECKD,SUBR,[DECL?]
+
+ ENTRY 2
+
+ MOVE C,(AB)
+ MOVE D,1(AB)
+ MOVE A,2(AB)
+ MOVE B,3(AB)
+ PUSHJ P,TMATCX ; CHECK THEM
+ JRST IFALS
+
+RETT: MOVSI A,TATOM
+ MOVE B,IMQUOTE T
+ JRST FINIS
+
+RETF:
+IFALS: MOVEI B,0
+ MOVSI A,TFALSE
+ JRST FINIS
+
+; Subr to turn DECL checking on and off.
+
+MFUNCTION %DECL,SUBR,[DECL-CHECK]
+
+ ENTRY
+
+ HRROI E,IGDECL
+ JRST FLGSET
+
+; Subr to turn on and off allowing new atoms
+
+MFUNCTION %NEWAT,SUBR,[ALLOW-NEW-ATOMS]
+
+ ENTRY
+
+ MOVEI E,NOATMS
+ JRST FLGSET
+
+; Subr to turn on and off allowing new GVALS
+
+MFUNCTION %NEWGV,SUBR,[ALLOW-NEW-GVALS]
+
+ ENTRY
+
+ MOVEI E,NOSETG
+ JRST FLGSET
+
+; Subr to turn on and off allowing new LVALs
+
+MFUNCTION %NEWLV,SUBR,[ALLOW-NEW-LVALS]
+
+ ENTRY
+
+ MOVEI E,NOSET
+ JRST FLGSET
+
+; Change special unspecial normal mode
+
+MFUNCTION SPECM%,SUBR,[SPECIAL-MODE]
+
+ ENTRY
+
+ CAMGE AB,[-3,,]
+ JRST TMA
+ MOVE C,SPCCHK ; GET CURRENT
+ JUMPGE AB,MODER ; RET CURRENT
+ GETYP 0,(AB) ; CHECK IT IS ATOM
+ CAIE 0,TATOM
+ JRST WTYP1
+ MOVE 0,1(AB)
+ MOVEI A,1
+ CAMN 0,MQUOTE UNSPECIAL
+ MOVSI A,(SETZ)
+ CAMN 0,MQUOTE SPECIAL
+ MOVEI A,0
+ JUMPG A,WTYP1
+ HLLM A,SPCCHK
+
+MODER: MOVSI A,TATOM
+ MOVE B,MQUOTE SPECIAL
+ SKIPGE C
+ MOVE B,MQUOTE UNSPECIAL
+ JRST FINIS
+
+; Function to turn special checking on and of
+
+MFUNCTION SPECC%,SUBR,[SPECIAL-CHECK]
+
+ ENTRY
+ CAMGE AB,[-3,,]
+ JRST TMA
+
+ MOVE C,SPCCHK
+ JUMPGE AB,SCHEK1
+
+ MOVEI A,0
+ GETYP 0,(AB)
+ CAIE 0,TFALSE
+ MOVEI A,1
+ HRRM A,SPCCHK
+
+SCHEK1: TRNN C,1
+ JRST IFALS
+ JRST RETT
+
+; Finction to set decls for GLOBAL values.
+
+MFUNCTION GDECL,FSUBR
+
+ ENTRY 1
+
+ GETYP 0,(AB)
+ CAIE 0,TLIST
+ JRST WTYP1
+
+ PUSH TP,$TLIST
+ PUSH TP,1(AB)
+ PUSH TP,$TLIST
+ PUSH TP,[0]
+ PUSH TP,$TLIST
+ PUSH TP,[0]
+
+GDECL1: INTGO
+ SKIPN C,1(TB)
+ JRST RETT
+ HRRZ D,(C) ; MAKE SURE PAIRS
+ JUMPE D,GDECLL ; LOSER, GO AWAY
+ GETYP 0,(C)
+ CAIE 0,TLIST
+ JRST GDECLL
+ HRRZ 0,(D)
+ MOVEM 0,1(TB) ; READY FOR NEXT CALL
+ MOVE C,1(C) ; SAVE ATOM LIST
+ MOVEM C,5(TB)
+ MOVEM D,3(TB)
+
+GDECL2: INTGO
+ SKIPN C,5(TB)
+ JRST GDECL1 ; OUT OF ATOMS
+ GETYP 0,(C) ; IS THIS AN ATOM
+ CAIE 0,TATOM
+ JRST GDECLL ; NO, LOSE
+ MOVE B,1(C)
+ HRRZ C,(C)
+ MOVEM C,5(TB)
+ PUSHJ P,IIGLOC ; GET ITS VAL (OR MAKE ONE)
+ GETYP 0,(B) ; UNBOUND?
+ CAIE 0,TUNBOU
+ JRST CHKCUR ; CHECK CURRENT VALUE
+ MOVE C,3(TB) ; GET DECL
+ HRRM C,-2(B)
+ JRST GDECL2
+
+CHKCUR: HRRZ D,3(TB)
+ GETYP A,(D)
+ MOVSI A,(A)
+ MOVE E,B
+ MOVE B,1(D)
+ MOVE C,(E)
+ MOVE D,1(E)
+ PUSH TP,$TVEC
+ PUSH TP,E
+ JSP E,CHKAB
+ PUSHJ P,TMATCH
+ JRST TYPMI3
+ MOVE E,(TP)
+ SUB TP,[2,,2]
+ MOVE D,3(TB)
+ HRRM D,-2(E)
+ JRST GDECL2
+
+TYPMI3: MOVE E,(TP) ; POINT BACK TO SLOT
+ MOVE A,-1(E) ; ATOM TO A
+ MOVE B,1(E)
+ MOVE D,(E) ; GET OLD VALUE
+ MOVE C,3(TB)
+ JRST TYPMIS ; GO COMPLAIN
+
+GDECLL: ERRUUO EQUOTE BAD-ARGUMENT-LIST
+
+MFUNCTION UNMANIFEST,SUBR
+
+ ENTRY
+
+ PUSH P,[HLLZS -2(B)]
+ JRST MANLP
+
+MFUNCTION MANIFEST,SUBR
+
+ ENTRY
+
+ PUSH P,[HLLOS -2(B)]
+MANLP: JUMPGE AB,RETT
+ GETYP 0,(AB)
+ CAIE 0,TATOM
+ JRST WTYP
+ MOVE B,1(AB)
+ PUSHJ P,IIGLOC
+ XCT (P)
+ ADD AB,[2,,2]
+ JRST MANLP
+
+MFUNCTION MANIFQ,SUBR,[MANIFEST?]
+
+ ENTRY 1
+
+ GETYP 0,(AB)
+ CAIE 0,TATOM
+ JRST WTYP1
+
+ MOVE B,1(AB)
+ PUSHJ P,IGLOC ; GET POINTER IF ANY
+ GETYP 0,A
+ CAIN 0,TUNBOU
+ JRST RETF
+ HRRZ 0,-2(B)
+ CAIE 0,-1
+ JRST RETF
+ JRST RETT
+
+MFUNCTION GETDECL,SUBR,[GET-DECL]
+
+ ENTRY 1
+
+ GETYP 0,(AB)
+ CAIN 0,TOFFS
+ JRST GETDOF
+ PUSHJ P,GTLOC
+ JRST GTLOCA
+
+ HRRZ C,-2(B) ; GET GLOBAL DECL
+GETD1: JUMPE C,RETF
+ CAIN C,-1
+ JRST RETMAN
+ GETYP A,(C)
+ MOVSI A,(A)
+ MOVE B,1(C)
+ JSP E,CHKAB
+ JRST FINIS
+GETDOF: HLRZ B,1(AB)
+ JUMPE B,GETDO1
+ MOVE A,(B)
+ MOVE B,1(B)
+ JRST FINIS
+GETDO1: MOVSI A,TATOM
+ MOVE B,IMQUOTE ANY
+ JRST FINIS
+
+RETMAN: MOVSI A,TATOM
+ MOVE B,MQUOTE MANIFEST
+ JRST FINIS
+
+GTLOCA: HLRZ C,2(B) ; LOCAL DECL
+ JRST GETD1
+
+MFUNCTION PUTDECL,SUBR,[PUT-DECL]
+
+ ENTRY 2
+
+ GETYP 0,(AB)
+ CAIN 0,TOFFS
+ JRST PUTDOF ; MAKE OFFSET WITH NEW DECL
+ PUSHJ P,GTLOC
+ SKIPA E,[HRLM B,2(C)]
+ MOVE E,[HRRM B,-2(C)]
+ PUSH P,E
+ GETYP 0,(B) ; ANY VALUE
+ CAIN 0,TUNBOU
+ JRST PUTD1
+ MOVE C,(B) ; GET CURRENT VALUE
+ MOVE D,1(B)
+ MOVE A,2(AB)
+ MOVE B,3(AB)
+ PUSHJ P,TMATCH
+ JRST TYPMI4
+PUTD1: MOVE C,2(AB) ; GET DECL BACK
+ MOVE D,3(AB)
+ PUSHJ P,INCONS ; CONS IT UP
+ MOVE C,1(AB) ; LOCATIVE BACK
+ XCT (P) ; CLOBBER
+ MOVE A,(AB)
+ MOVE B,1(AB)
+ JRST FINIS
+
+TYPMI4: MOVE E,1(AB) ; GET LOCATIVE
+ MOVE A,-1(E) ; NOW ATOM
+ MOVEI C,2(AB) ; POINT TO DECL
+ MOVE D,(E) ; AND CURRENT VAL
+ MOVE B,1(E)
+ JRST TYPMIS
+
+GTLOC: GETYP 0,(AB)
+ CAIE 0,TLOCD
+ JRST WTYP1
+ MOVEI B,(AB)
+ PUSHJ P,CHLOCI
+ HRRZ 0,(AB) ; LOCAL OR GLOBAL
+ SKIPN 0
+ AOS (P)
+ MOVE B,1(AB) ; RETURN LOCATIVE IN B
+ POPJ P,
+
+; MAKE OFFSET WITH SUPPLIED DECL
+PUTDOF: MOVE D,3(AB)
+ GETYP 0,2(AB)
+ CAIN TATOM
+ CAME D,IMQUOTE ANY
+ JRST PUTDO1
+ MOVSI A,TOFFS
+ HRRZ B,1(AB)
+ JRST FINIS
+PUTDO1: MOVE C,2(AB)
+ PUSHJ P,INCONS ; BUILD A LIST
+ MOVSI A,TOFFS
+ HRLS B
+ HRR B,1(AB) ; SET UP OFFSET
+ JRST FINIS
+
+; BUILD AN OFFSET--TAKES FIX AND DECL (OR ATOM FORM)
+; JUMPS INTO PUT-DECL CODE FOR OFFSETS.
+ MFUNCTION COFFSET,SUBR,[OFFSET]
+
+ ENTRY 2
+ GETYP 0,(AB)
+ CAIE 0,TFIX
+ JRST WTYP1
+ SKIPG 1(AB)
+ JRST OUTRNG ; CAN'T HAVE NEGATIVE OFFSETS
+ GETYP 0,2(AB)
+ CAIE 0,TATOM
+ CAIN 0,TFORM
+ JRST PUTDOF
+ JRST WTYP2
+
+; GET FIX PART OF OFFSET
+ MFUNCTION INDEX,SUBR
+
+ ENTRY 1
+ GETYP 0,(AB)
+ CAIE 0,TOFFS
+ JRST WTYP1
+ MOVSI A,TFIX
+ HRRE B,1(AB)
+ JRST FINIS
+\f
+; Interface between EVAL and declaration processor.
+; E points into stack at a binding and C points to decl list.
+
+CHKDCL: SKIPE IGDECL ; IGNORING DECLS?
+ POPJ P, ; YUP, JUST LEAVE
+
+ PUSH TP,$TTP ; SAVE BINDING
+ PUSH TP,E
+ MOVE A,-4(E) ; GET ATOM
+ MOVSI 0,TLIST ; SETUP FOR INTERRUPTABLE
+ MOVE PVP,PVSTOR+1
+ MOVEM 0,CSTO(PVP)
+ MOVEM 0,BSTO(PVP)
+ MOVSI 0,TATOM
+ MOVEM 0,ASTO(PVP)
+ SETZB B,0 ; CLOBBER FOR INTGO
+
+DCL2: INTGO
+ HRRZ D,(C) ; MAKE SURE EVEN ELEMENTS
+ JUMPE D,BADCL
+ GETYP B,(C) ; MUST BE LIST OF ATOMS
+ CAIE B,TLIST
+ JRST BADCL
+ MOVE B,1(C) ; GET LIST
+
+DCL1: INTGO
+ CAMN A,1(B) ; SKIP IF NOT WINNER
+ JRST DCLQ ; MAY BE WINNER
+DCL3: HRRZ B,(B) ; CDR ON
+ JUMPN B,DCL1 ; JUMP IF MORE
+
+ HRRZ C,(D) ; CDR MAIN LIST
+ JUMPN C,DCL2 ; AND JUMP IF WINNING
+
+ PUSHJ P,E.GET ; GET BINDING BACK
+ SUB TP,[2,,2] ; POP OF JUNK
+ POPJ P,
+
+DCLQ: GETYP C,(B) ; CHECK ATOMIC
+ CAIE C,TATOM
+ JRST BADCL ; LOSER
+ PUSHJ P,E.GET ; GOT IT
+ PUSH TP,$TLIST ; SAVE PATTERN
+ PUSH TP,D
+ MOVE B,1(D) ; GET PATTERN
+ HLLZ A,(D)
+ MOVE C,-3(E) ; PROPOSED VALUE
+ MOVE D,-2(E)
+ PUSHJ P,TMATCH ; MATCH TYPE
+ JRST TYPMI1 ; LOSER
+DCLQ1: MOVE E,-2(TP)
+ MOVE C,-5(E) ; CHECK FOR SPEC CHANGE
+ SKIPE 0 ; MAKE SURE NON ZERO IS -1
+ MOVNI 0,1
+ SKIPL SPCCHK ; SKIP IF NORMAL UNSPECIAL
+ SETCM 0 ; COMPLEMENT
+ ANDI 0,1 ; ONE BIT
+ CAMN C,[TATOM,,-1]
+ JRST .+3
+ CAME C,[TATOM,,-2]
+ JRST .+3
+ ANDCMI C,1
+ IOR C,0 ; MUNG BIT
+ MOVEM C,-5(E)
+ HRRZ C,(TP)
+ SUB TP,[4,,4]
+ MOVEM C,(E) ; STORE DECLS
+ MOVSI C,TLIST
+ MOVEM C,-1(E)
+ POPJ P,
+
+TYPMI1: MOVE E,-2(TP)
+ GETYP C,-3(E)
+ CAIN C,TUNBOU
+ JRST DCLQ1
+ MOVE E,-2(TP) ; GET POINTER TO BIND
+ MOVE D,-3(E) ; GET VAL
+ MOVE B,-2(E)
+ HRRZ C,(TP) ; DCL LIST
+ MOVE A,-4(E) ; GET ATOM
+ SUB TP,[4,,4]
+TYPMIS: PUSH TP,$TATOM
+ PUSH TP,EQUOTE TYPE-MISMATCH
+ PUSH TP,$TATOM
+ PUSH TP,A
+ PUSH TP,(C)
+ HLLZS (TP)
+ PUSH TP,1(C)
+ JSP E,CHKARG ; HACK DEFER
+ PUSH TP,D
+ PUSH TP,B
+ MOVEI A,4 ; 3 ERROR ARGS
+ JRST CALER
+
+BADCL: PUSHJ P,E.GET
+ ERRUUO EQUOTE BAD-DECLARATION-LIST
+
+; ROUTINE TO RESSET INT STUFF
+
+E.GET: MOVE E,(TP)
+ MOVE PVP,PVSTOR+1
+ SETZM ASTO(PVP)
+ SETZM BSTO(PVP)
+ SETZM CSTO(PVP)
+ POPJ P,
+
+; Declarations processor for MUDDLE type declarations.
+; Receives a pattern in a and B and an object in C and D.
+; It skip returns if the object fits otherwise it doesn't.
+; Declaration syntax errors are caught and sent to ERROR.
+
+TMATCH: MOVEI 0,1 ; RET SPECIAL INDICATOR
+ SKIPE IGDECL ; IGNORING DECLS?
+ JRST CPOPJ1 ; YUP, ACT LIKE THEY WON
+
+TMATCX: GETYP 0,A ; GET PATTERNS TYPE
+ CAIE 0,TSEG
+ CAIN 0,TFORM ; MUST BE FORM OR ATOM
+ JRST TMAT1
+ CAIE 0,TATOM
+ JRST TERR1 ; WRONG TYPE FOR A DCL
+
+; SIMPLE TYPE MATCHER
+
+TYPMAT: GETYP E,C ; OBJECTS TYPE TO E
+ PUSH P,E ; SAVE IT
+ PUSH TP,C
+ PUSH TP,D
+ PUSHJ P,TYPFND ; CONVERT TYPE NAME TO CODE
+ JRST SPECS ; NOT A TYPE NAME, TRY SPECIALS
+ SUB TP,[2,,2]
+ POP P,E ; RESTORE TYPE OF OBJECT
+ MOVEI 0,0 ; SPECIAL INDICATOR
+ CAIN E,(D) ; SKIP IF LOSERS
+CPOPJ1: AOS (P) ; GOOD RETURN
+CPOPJ: POPJ P,
+
+SPECS: POP P,A ; RESTORE OBJECTS TYPE
+ POP TP,D
+ POP TP,C
+ CAMN B,IMQUOTE ANY
+ JRST CPOPJ1 ; RETURN IMMEDIATELY IF ANYTHING WINS
+ CAMN B,IMQUOTE STRUCTURED
+ JRST ISTRUC ; LET ISTRUC DO THE WORK
+ CAMN B,IMQUOTE APPLICABLE
+ JRST APLQ
+ CAMN B,IMQUOTE LOCATIVE
+ JRST LOCQQ
+ PUSH TP,$TATOM
+ PUSH TP,B
+ PUSH TP,C
+ PUSH TP,D
+ MOVSI A,TATOM
+ MOVSI C,TATOM
+ MOVE D,IMQUOTE DECL
+ PUSHJ P,IGET
+ JUMPE B,TERR2X
+ MOVEM A,-3(TP)
+ MOVEM B,-2(TP)
+ INTGO
+ POP TP,D
+ POP TP,C
+ POP TP,B
+ POP TP,A
+ JRST TMATCX
+
+; ARRIVE HERE FOR A FORM IN THE DCLS
+
+TMAT1: JUMPE B,TERR3 ; EMPTY FORM LOSES
+ HRRZ E,(B) ; CDR IT
+ JUMPE E,TMAT3 ; CANT BE SPECIAL/UNSPECIAL, LEAVE
+ PUSHJ P,0ATGET ; GET POSSIBLE ATOM IN 0
+ JRST TEXP1 ; NOT ATOM
+ CAME 0,MQUOTE SPECIAL
+ CAMN 0,MQUOTE UNSPECIAL
+ JRST TMAT2 ; IGNORE SPECIAL/UNSPECIAL
+TMAT3: PUSHJ P,TEXP1
+ JRST .+2
+ AOS (P)
+ MOVEI 0,0 ; RET UNSPECIAL INDICATION
+ POPJ P,
+
+TEXP1: JUMPE B,TERR3 ; EMPTY FORM
+ GETYP E,A ; CHECK CURRENT TYPE
+ CAIN E,TATOM ; IF ATOM,
+ JRST TYPMA1 ; SIMPLE MATCH
+ CAIN E,TSEG
+ JRST .+3
+ CAIE E,TFORM
+ JRST TERR4
+ GETYP 0,(B) ; WHAT IS FIRST ELEMEMT
+ CAIE 0,TFORM ; FORM=> <<OR ..>....> OR <<PRIMTYPE FOO>....>
+ JRST TEXP12
+ PUSH TP,$TLIST ; SAVE LIST
+ PUSH TP,B
+ MOVE B,1(B) ; GET FORM
+ PUSH TP,C
+ PUSH TP,D
+ PUSH P,E
+ PUSHJ P,ACTRT1
+ TDZA 0,0 ; REMEMBER LACK OF SKIP
+ MOVEI 0,1
+ POP P,E
+ POP TP,D
+ POP TP,C
+ MOVE B,(TP) ; GET BACK SAVED LIST
+ SUB TP,[2,,2]
+ JUMPE 0,CPOPJ ; LOSERS EXIT IMMEDIATELY
+ HRRZ B,(B) ; OTHERWISE REST THE LIST AND FALL INTO ELETYPE
+
+; CHECKS TYPES OF ELEMENTS OF STRUCTURES
+
+ELETYP: CAIE E,TSEG ; MUST BE EXAXT?
+ JUMPE B,CPOPJ1 ; EMPTY=> WON
+ PUSH TP,$TLIST ; SAVE DCL LIST
+ PUSH TP,B
+ MOVE A,C ; GET OBJ IN A AND B
+ MOVE B,D
+ CAIE E,TSEG
+ TDZA E,E
+ MOVNI E,1
+ PUSH P,E
+ PUSHJ P,TYPSGR ; GET REST/NTH CODE
+ JRST ELETYL ; LOSER
+ CAIN C,5 ; BYTE STRING COMES HERE
+ JRST ELEBYT ; HACK IT
+ PUSH TP,DSTORE
+ PUSH TP,D
+ PUSH P,C ; SAVE CODE
+ PUSH TP,[0] ; AND SLOTS
+ PUSH TP,[0]
+
+; MAIN ELEMENT SCANNING LOOP
+
+ELETY1: XCT TESTR(C) ; SKIP IF OBJ NOT EMPTY
+ JRST ELETY2 ; CHEK EMPTY WINNER
+ SKIPN -4(TP)
+ JRST ELETY4
+ XCT TYPG(C) ; GET ELEMENT
+ XCT VALG(C)
+ JSP E,CHKAB ; CHECK OUT DEFER
+ MOVEM A,-1(TP) ; AND SAVE IT
+ MOVEM B,(TP)
+ MOVE C,A
+ MOVE D,B ; FOR OTHER MATCHERS
+ MOVE B,-4(TP) ; GET PATTERN
+ MOVE A,(B)
+ GETYP 0,(B) ; GET TYPE OF <1 pattern>
+ MOVE B,1(B) ; GET ATOM OR WHATEVER
+ CAIE 0,TATOM ; ATOM ... SIMPLE TYPE
+ JRST ELETY3
+ PUSHJ P,TYPMAT ; DO SIMPLE TYPE MATCH
+ JRST ELETY4 ; LOSER
+
+; HERE TO REST EVERYTHING AND GO ON BACK
+
+ELETY6: MOVE D,-2(TP) ; GET OBJ POINTER
+ MOVE C,(P) ; GET INCREMENT CODE
+ XCT INCR1(C)
+ MOVEM D,-2(TP) ; SAVED INCREMENTED GOODIR
+ MOVE 0,DSTORE
+ MOVEM 0,-3(TP)
+
+ELETY9: HRRZ B,@-4(TP) ; CDR IT
+ MOVEM B,-4(TP)
+ JUMPN B,ELETY1
+
+ SKIPN -1(P) ; SKIP IF EXACT REQUIRED
+ JRST ELETY8
+ XCT TESTR(C)
+ JRST ELETY8
+ JRST ELETY4
+
+
+; HERE IF PATTERN EMPTY
+
+ELETY8: AOS -2(P) ; SKIP RETURN
+ELETY4: SETZM DSTORE
+ SUB P,[2,,2]
+ SUB TP,[6,,6]
+ POPJ P,
+
+ELETYL: SUB P,[1,,1]
+ SUB TP,[2,,2]
+ POPJ P,
+
+; HERE TO HANDLE EMPTY OBJECT
+
+ELETY2: MOVE B,-4(TP) ; GET PATTERN
+ JUMPE B,ELETY8
+ GETYP 0,(B) ; CHECK FOR [REST ...]
+ SETZM DSTORE
+ CAIE 0,TVEC
+ JRST ELETY4 ; LOSER
+ HLRZ 0,1(B) ; SIZE OF IT
+ CAILE 0,-4 ; MUST BE 2
+ JRST ELETY4
+ MOVE B,1(B) ; GET IT
+ PUSHJ P,0ATGET ; LOOK FOR REST
+ JRST ELETY4
+ CAMN 0,MQUOTE OPTIONAL
+ JRST ELETY8
+ CAME 0,MQUOTE OPT
+ CAMN 0,IMQUOTE REST
+ JRST ELETY8 ; WINNER!!!!
+ JRST ELETY4 ; LOSER
+
+; HERE TO CHECK OUT A FORM ELEMNT
+
+ELETY3: CAIN 0,TSEG
+ JRST ELGO
+ CAIE 0,TFORM
+ JRST ELETY7
+ELGO: SETZM DSTORE
+ PUSHJ P,TEXP1 ; AND ANALYSE IT
+ JRST ELETY4 ; LOSER
+ MOVE 0,-3(TP) ; RESET DSTO
+ MOVEM 0,DSTORE
+ JRST ELETY6 ; WINNER
+
+; CHECK FOR VECTOR IN PATTERN
+
+ELETY7: CAIE 0,TVEC ; SKIP IF WINNER
+ JRST TERR12 ; YET ANOTHER ERROR
+ HLRE C,B ; CHECK LEENGTH
+ CAMLE C,[-4] ; MUST BE 2 LONG
+ JRST TERR13
+ PUSHJ P,0ATGET ; 1ST ELEMENT ATOM?
+ JRST ELET71 ; COULD BE FORM
+ CAME 0,MQUOTE OPT
+ CAMN 0,MQUOTE OPTIONAL
+ JRST ELET72
+ CAME 0,IMQUOTE REST
+ JRST TERR14
+ MOVE 0,(P) ; GET STRUC CODE
+ CAIN 0,2
+ CAME C,[-4]
+ JRST ELNUVE
+
+ GETYP 0,2(B) ; SEE IF UVECTOR REST SIMPLE TYPE
+ CAIE 0,TATOM
+ JRST ELNUVE
+
+ MOVE C,3(B) ; GET ATOM
+ HLRE 0,C
+ SUB C,0 ; POINT TO DOPE WDS
+ HRRE 0,(C)
+ JUMPE 0,ELNUVE
+ MOVSI A,TATOM
+ MOVE B,3(B)
+ MOVE C,-2(TP)
+ HLRE D,C
+ SUB C,D
+ GETYP C,(C)
+ MOVSI C,(C)
+ PUSHJ P,TMATCX
+ JRST ELETY4
+ JRST ELETY8
+
+ELNUVE: TDOA 0,[-1]
+ELET72: MOVSI 0,(SETZ) ; FLAG USED IN RESTIT
+ PUSH P,0
+ PUSHJ P,RESTIT ; CHECK REST OF STRUCTUR
+ JRST ELET41
+ POP P,0
+ TRNE 0,-1
+ JRST ELETY8 ; WIN AND DONE
+ JRST ELET81
+
+ELET41: SUB P,[1,,1]
+ JRST ELETY4
+
+; CHECK FOR [fix .... ]
+
+ELET71: CAIE 0,TFIX
+ JRST TERR15
+ MOVNS C
+ ASH C,-1
+ MOVE 0,1(B) ; GET NUMBER
+ IMULI 0,-1(C) ; COUNT MORE
+ PUSH P,0
+ PUSHJ P,RESTIT ; AND CHECK FIX NUM OF ELEMENTS
+ TDZA 0,0
+ MOVEI 0,1
+ SUB P,[1,,1]
+ JUMPE 0,ELETY4
+ELET81: MOVE D,-2(TP) ; GET OBJECT BACK
+ MOVE 0,-3(TP) ; RESET DSTO
+ MOVEM 0,DSTORE
+ MOVE C,(P) ; RESTORE CODE FOR RESTING ETC.
+ JRST ELETY9
+
+
+; HERE TO DO A TASTEFUL TYPMAT
+
+TYPMA1: PUSH TP,C
+ PUSH TP,D
+ PUSHJ P,TYPMAT
+ TDZA 0,0 ; REMEMBER LOSSAGE
+ MOVEI 0,1 ; OR WINNAGE
+ POP TP,D
+ POP TP,C ; RESTORE OBJECT
+ JUMPN 0,CPOPJ1 ; SKIPPED BEFORE, SKIP AGAIN
+ POPJ P,
+
+; HERE TO SKIP SPECIAL/UNSPECIAL
+
+TMAT2: CAME 0,MQUOTE SPECIAL
+ TDZA 0,0
+ MOVEI 0,1
+ PUSH P,0 ; SAVE INDICATOR
+ HRRZ A,(E) ; CHECK FOR EXACT LENGTH
+ JUMPN A,TERR16
+ GETYP A,(E) ; TYPE OF NEW PAT
+ MOVE B,1(E) ; VALUE
+ MOVSI A,(A)
+ PUSHJ P,TEXP1
+ JRST .+2
+ AOS -1(P)
+ POP P,0
+ POPJ P,
+
+; LOOK FOR <OR... OR <PRIMTYPE....
+
+TEXP12: CAIE 0,TATOM
+ JRST TERR5
+ MOVE 0,1(B) ; GET ATOM
+ CAMN 0,IMQUOTE QUOTE
+ JRST MQUOT ; MATCH A QUOTED OBJECT
+ CAME 0,IMQUOTE OR
+ CAMN 0,IMQUOTE PRIMTYPE
+ JRST ACTORT ; FALL INTO ACTOR HACKER
+ PUSH TP,$TLIST
+ PUSH TP,B
+ MOVE B,0 ; GET ATOM
+ PUSH TP,C ; SAVE OBJ
+ PUSH TP,D
+ PUSH P,E
+ PUSHJ P,TYPMAT
+ TDZA 0,0
+ MOVEI 0,1
+ POP P,E
+ MOVE C,-1(TP)
+ MOVE D,(TP)
+ MOVE B,-2(TP)
+ JUMPN 0,.+3 ; TO ELETYP IF WON
+ SUB TP,[4,,4]
+ POPJ P, ; ELSE LOSE
+
+ HRRZ 0,(B)
+ MOVSI A,TFORM
+ JUMPE 0,TERR3
+ MOVE B,0
+ PUSHJ P,ELETYP
+FOOPC: TDZA 0,0
+ MOVEI 0,1
+POPPIT: POP TP,D
+ POP TP,C
+ POP TP,B
+ POP TP,A
+ JUMPN 0,CPOPJ1
+ POPJ P,
+
+; THIS CODE HANDLES ORs AND PRIMTYPEs
+ACTRT1: SKIPA E,[SETZ PACT]
+
+ACTORT: MOVE E,[SETZ TEXP1]
+ JUMPE B,TERR6 ; EMPTY, LOSE
+ PUSHJ P,0ATGET ; ATOM TO 0
+ JRST PACT
+ CAME 0,IMQUOTE OR
+ JRST PACT2
+ HRRZ 0,(B) ; REST IT FLUSHING OR
+ JUMPE 0,TERR7
+ PUSH TP,$TLIST ; SAVE LSIT
+ PUSH TP,0
+ PUSH P,E ; SAVE ELEMENT CHECKER
+
+ORLP: SKIPN B,(TP) ; ANY LEFT?
+ JRST ORDON ; NOPE, LOSE
+ HRRZ 0,(B) ; SAVE THE REST
+ MOVEM 0,(TP)
+ GETYP 0,(B) ; WHAT ARE WE ORing
+ MOVE A,(B) ; TYPE WORD
+ MOVE B,1(B) ; AND ITEM
+ PUSH TP,C
+ PUSH TP,D
+ PUSHJ P,@(P) ; EITHER PACT OR TEXP1
+ TDZA 0,0
+ MOVEI 0,1
+ POP TP,D
+ POP TP,C
+ JUMPE 0,ORLP
+ AOS -1(P) ; SKIP RETURN FOR WINNER
+
+ORDON: SUB TP,[2,,2] ; FLUSH TEMP
+ SUB P,[1,,1]
+ POPJ P,
+
+; HERE TO PRIMTYPE ACTORS
+
+PACT: CAIE 0,TFORM
+ JRST PACT1
+ JUMPE B,TERR6 ; EMPTY FORM
+ MOVE 0,1(B) ; FIRST ELEMENT MUST BE PRIMTYPE
+PACT2: CAME 0,IMQUOTE PRIMTYPE
+ JRST TERR7
+ HRRZ A,(B) ; GET PRIMTYPE
+ JUMPE A,TERR7
+ HRRZ 0,(A)
+ JUMPN 0,TERR18
+ MOVEI B,(A)
+ GETYP A,C ; GET OBJ TYPE
+ GETYP 0,(B) ; GET PATTERN TYPE
+ CAIE 0,TATOM ; BETTER BE ATOM
+ JRST TERR8
+ PUSH TP,$TLIST ; SAVE DCL LIST
+ PUSH TP,B
+ PUSH TP,C
+ PUSH TP,D
+ PUSHJ P,SAT ; GET STORAGE TYPE
+ CAILE A,NUMSAT
+ JRST PTEMP
+ MOVE B,@STBL(A) ; GET PRIM NAME
+ PUSHJ P,TYPFND
+ JFCL ; MUST EXIST
+ MOVSI C,(D) ; FAKE OUT TYPMAT
+ MOVE B,-2(TP)
+ MOVE B,1(B)
+ PUSHJ P,TYPMAT
+ JRST .+2
+ AOS (P)
+ MOVE C,-1(TP)
+ MOVE D,(TP)
+ SUB TP,[4,,4]
+ POPJ P,
+
+PACT1: CAIE 0,TATOM
+ JRST TERR4
+ JRST TYPMAT
+
+PTEMP: MOVE B,-2(TP)
+ MOVE B,1(B)
+ CAMN B,IMQUOTE TEMPLATE
+ AOS (P)
+ SUB TP,[4,,4]
+ POPJ P,
+
+; RESTIT - TYPE CHECK SELECTED NUMBER OF ELEMENTS IN STRUCTURE
+
+RESTIT: PUSH TP,$TVEC ; SAVE TYPE
+ ADD B,[2,,2] ; SKIP OVER CRUFT
+ PUSH TP,B ; AND VAL
+ PUSH TP,$TVEC
+ PUSH TP,B
+RESTI1: PUSH P,A ; SAVE DISP HACK
+ PUSH P,0 ; AND COUNT HACK
+RESTI4: SKIPL (P) ; SKIP IF DOING ALL
+ SOSL (P) ; SKIP IF DONE
+ JRST RESTI6
+ AOS -2(P) ; SKIP RET
+RESTI5: SUB P,[2,,2] ; POP JUNK
+ SUB TP,[4,,4]
+ POPJ P,
+RESTI6: SKIPGE (TP)
+ JRST RESTX1
+ HLRZ 0,(P)
+ CAIN 0,(SETZ)
+ JRST RESTI2
+RESTX1: MOVE C,-4(P) ; REST CODE
+ MOVE D,-6(TP) ; SET UP FOR REST
+ MOVE E,-7(TP) ; DONT FORGET DSTO
+ MOVEM E,DSTORE
+ XCT TESTR(C) ; DONE?
+ JRST RESTI2 ; YES, CHECK WINNAGE
+ XCT TYPG(C)
+ XCT VALG(C) ; GET VAL ANDTYPE
+ JSP E,CHKAB ; CHECK DEFER
+ XCT INCR1(C) ; REST IT
+ MOVEM D,-6(TP) ; SAVE LIST
+ MOVE E,DSTORE
+ MOVEM E,-7(TP) ; FIXUP
+ SETZM DSTORE
+ MOVE C,A
+ MOVE D,B
+ SKIPL A,(TP) ; ANY MORE?
+ MOVE A,-2(TP) ; NO RECYCLE
+ ADD A,[2,,2] ; BUMP
+ MOVEM A,(TP) ; AND SAVE
+ MOVE B,-1(A) ; GET ELEMENT
+ MOVE A,-2(A)
+ GETYP 0,A
+ MOVEI E,TERR15
+ CAIN 0,TATOM
+ MOVEI E,TYPMAT ; ATOM --> SIMPLE TYPE
+ CAIE 0,TSEG
+ CAIN 0,TFORM ; FORM--> HAIRY PATTERN
+ MOVEI E,TEXP1
+ TLO E,400000
+ PUSHJ P,(E) ; DO IT
+ JRST RESTI5
+ JRST RESTI4
+
+RESTI2: SKIPGE (P) ; SKIP IF WON
+ AOS -2(P) ; COUNTERACT CPOPJ1
+ JRST RESTI5
+
+RESTI3: TEXP1
+ TYPMAT
+
+; HERE TO MATHC A QUOTED OBJ
+; B/ FORM QUOTE... C,D/ OBJECT TO MATCH AGAINST
+
+MQUOT: HRRZ B,(B) ; LOOK AT NEXT
+ JUMPE B,TERR7
+ GETYP A,(B) ; GET TYPE
+ MOVSI A,(A)
+ MOVE B,1(B) ; AND VALUE
+ JSP E,CHKAB ; HACK DEFER
+ PUSH TP,A
+ PUSH TP,B
+ PUSH TP,C
+ PUSH TP,D
+ MOVEI D,-3(TP)
+ MOVEI C,-1(TP)
+ PUSHJ P,IEQUAL
+ TDZA 0,0
+ MOVEI 0,1
+ JRST POPPIT
+
+; HERE TO HANDLE SPECIAL BYTE STRING HAIR
+
+ELEBYT: MOVE B,(TP) ; GET DECL LIST BACK
+ POP P,E ; EXACTNESS FLAG
+ JUMPE B,ELEBY2
+ GETYP 0,(B)
+ CAIE 0,TFIX
+ JRST TERR17
+ MOVE A,1(B)
+ HRRZ B,(B)
+ HRRZ 0,(B)
+ SKIPE B
+ JUMPN 0,TERR17
+ LDB C,[300600,,D] ; GET BYTE SIZE
+ CAIE A,(C)
+ JRST ELEBY3
+ HRRZ C,DSTORE
+ELEBY2: MOVEI A,0
+ JUMPE B,ELEBY4
+ GETYP 0,(B)
+ CAIE 0,TFIX
+ JRST TERR17
+ MOVE A,1(B)
+ELEBY4: CAIGE C,(A)
+ JRST ELEBY3
+ CAIE A,(C)
+ JUMPN E,ELEBY3
+ AOS (P)
+ELEBY3: SETZM DSTORE
+ SUB TP,[2,,2]
+ POPJ P,
+
+
+
+; GET ATOM IN AC 0
+
+0ATGET: GETYP 0,(B)
+ CAIE 0,TATOM ; SKIP IF ATOM
+ POPJ P,
+ MOVE 0,1(B) ; GET ATOM
+ JRST CPOPJ1
+
+TERR17: MOVE B,-2(TP)
+ MOVE B,1(B)
+ HRRZ 0,(P)
+ CAIN 0,FOOPC
+ MOVE B,-4(TP)
+ MOVSI A,TFORM
+ MOVE E,EQUOTE BAD-BYTES-DECL
+ SETZM DSTORE
+ JRST TERRD
+
+TERR18: SKIPA E,EQUOTE TOO-MANY-ARGS-TO-PRIMTYPE-DECL
+TERR16: MOVE E,EQUOTE TOO-MANY-ARGS-TO-SPECIAL-UNSPECIAL-DECL
+ MOVSI A,TFORM
+ JRST TERRD
+
+TERR9: MOVS A,0 ; TYPE TO A
+TERR4:
+TERR5:
+TERR15:
+TERR1: MOVE E,EQUOTE DECL-ELEMENT-NOT-FORM-OR-ATOM
+ JRST TERRD
+
+TERR2X: SUB TP,[2,,2]
+ POP TP,B
+ POP TP,A
+
+TERR2: MOVSI A,TATOM
+ MOVE E,EQUOTE ATOM-NOT-TYPE-NAME-OR-SPECIAL-SYMBOL
+ JRST TERRD
+TERR6:
+TERR3: MOVE E,EQUOTE EMPTY-FORM-IN-DECL
+ JRST TERRD
+TERR7: MOVE E,EQUOTE EMPTY-OR/PRIMTYPE-FORM
+ JRST TERRD
+
+TERR8: MOVS A,0 ; TYPE TO A
+ MOVE E,EQUOTE NON-TYPE-FOR-PRIMTYPE-ARG
+ JRST TERRD
+TERR12: MOVE E,EQUOTE ELEMENT-TYPE-NOT-ATOM-FORM-OR-VECTOR
+ JRST TERRD
+TERR13: MOVE E,EQUOTE VECTOR-LESS-THAN-2-ELEMENTS
+ JRST TERRD
+TERR14: MOVE E,EQUOTE FIRST-VECTOR-ELEMENT-NOT-REST-OR-A-FIX
+
+TERRD: PUSH TP,$TATOM
+ PUSH TP,EQUOTE BAD-TYPE-SPECIFICATION
+ PUSH TP,$TATOM
+ PUSH TP,E
+ PUSH TP,A
+ PUSH TP,B
+ MOVEI A,3
+ JRST CALER
+
+IMPURE
+
+IGDECL: 0
+
+PURE
+
+END
+\f\f
\ No newline at end of file
--- /dev/null
+TITLE EVAL -- MUDDLE EVALUATOR
+
+RELOCATABLE
+
+; GERALD JAY SUSSMAN, 1971. REWRITTEN MANY TIMES SINCE C. REEVE (1972--1974)
+
+
+.GLOBAL BINDID,LPROG,GLOBSP,GLOBASE,SPBASE,TPBASE,PTIME,SWAP,CHFRAM
+.GLOBAL IGVAL,CHKARG,NXTDCL,TPOVFL,CHFRM,PROCHK,CHFSWP,VECBOT,TYPSGR
+.GLOBAL ILVAL,ER1ARG,SPECBIND,MAKACT,SPECSTORE,MAKTUP,TPALOC,IBIND,SSPECS
+.GLOBAL IDVAL,EVECTO,EUVECT,CHARGS,BCKTRK,CELL,ILOC,IGLOC,CHKDCL,SSPEC1
+.GLOBAL PDLBUF,MESS,FACTI,CHKARG,MAKENV,PSTAT,BNDV,UNBOU,UNAS,IGDECL
+.GLOBAL 1STEPR,SEGMNT,SEGLST,NAPT,EVTYPE,EVATYP,APTYPE,APLTYP,APLQ,IDVAL1
+.GLOBAL TESTR,VALG,TYPG,INCR1,TMATCH,TYPMIS,SAT,MAKACT,NTPALO,SPECBND
+.GLOBAL TPGROW,CHKAB,TYPSEG,NXTLM,MONCH0,CHFINI,RMONC0,IMPURIFY,ICONS,INCONS
+.GLOBAL CILVAL,CISET,CIGVAL,CSETG,MAPPLY,CLLOC,CGLOC,CASSQ,CGASSQ,CBOUND
+.GLOBAL IIGLOC,CHUNW,IUNWIN,UNWIN2,SPCCHK,CURFCN,TMPLNT,TD.LNT,TBINIT
+.GLOBAL SPECBE,BSETG,GLOTOP,CANDP,CORP,TFA,TMA,DSTORE,PVSTOR,SPSTOR
+.GLOBAL AGC,GVLINC,LVLINC,CGBOUN,IEVECT,MAKTU2,STOSTR,HIBOT,POPUNW,ISTRUC
+
+.INSRT MUDDLE >
+
+MONITOR
+
+\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,$TDECL ; SAVE HEWITT ATOM
+ PUSH TP,-1(P)
+ PUSH TP,$TATOM ; AND DECLS
+ PUSH TP,-2(P)
+ TRNN A,2 ; SKIP IF INIT VAL EXISTS
+ JRST AUXB3 ; NO, USE UNBOUND
+
+; EVALUATE EXPRESSION
+
+ HRRZ C,(B) ; CDR ATOM OFF
+
+; CHECK FOR SPECIAL FORMS <TUPLE ...> <ITUPLE ...>
+
+ GETYP 0,(C) ; GET TYPE OF GOODIE
+ CAIE 0,TFORM ; SMELLS LIKE A FORM
+ JRST AUXB13
+ HRRZ D,1(C) ; GET 1ST ELEMENT
+ GETYP 0,(D) ; AND ITS VAL
+ CAIE 0,TATOM ; FEELS LIKE THE RIGHT FORM
+ JRST AUXB13
+
+ MOVE 0,1(D) ; GET THE ATOM
+ CAME 0,IMQUOTE TUPLE
+ CAMN 0,MQUOTE ITUPLE
+ JRST DOTUPL ; SURE GLAD I DIDN'T STEP IN THAT FORM
+
+
+AUXB13: PUSHJ P,FASTEV
+AUXB14: MOVE E,TP
+AUXB4: MOVEM A,-7(E) ; STORE VAL IN BINDING
+ MOVEM B,-6(E)
+
+; HERE TO CHECK AGAINST DECLARATIONS AND COMPLETE THE BINDING
+
+AUXB5: SUB E,[4,,4] ; POINT TO BINDING TOP
+ SKIPE C,-2(TP) ; POINT TO DECLARATINS
+ PUSHJ P,CHKDCL ; CHECK IT
+ PUSHJ P,USPCBE ; AND BIND UP
+ SKIPE C,RE.ARG+1(TB) ; CDR DCLS
+ HRRZ C,(C) ; IF ANY TO CDR
+ MOVEM C,RE.ARG+1(TB)
+ MOVE A,(TP) ; NOW PUT HEWITT ATOM AND DCL AWAY
+ MOVEM A,-2(P)
+ MOVE A,-2(TP)
+ MOVEM A,-1(P)
+ SUB TP,[4,,4] ; FLUSH SLOTS
+ JRST AUXB1
+
+
+AUXB3: MOVNI B,1
+ MOVSI A,TUNBOU
+ JRST AUXB14
+
+\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
+ MOVEI E,(TP)
+ PUSHJ P,STLOOP
+SSPEC2: SUBI E,(SP) ; MAKE SP BE AOBJN
+ MOVSI E,(E)
+ HLL SP,TP
+ SUB SP,E
+ MOVEM SP,SPSTOR+1
+ POP P,E
+ POPJ P,
+
+; ENTRY FOR FUNNY COMPILER UNBIND (2)
+
+SSPEC1: PUSH P,E
+ SUBI E,1 ; MAKE SURE GET CURRENT BINDING
+ PUSHJ P,STLOOP ; UNBIND
+ MOVEI E,(TP) ; NOW RESET SP
+ JRST SSPEC2
+\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
+ CAMN A,$TUNBOUND ;IF BOUND
+ PUSHJ P,BSETG ;IF NOT -- BIND IT
+ MOVE C,2(AB) ; GET PROPOSED VVAL
+ MOVE D,3(AB)
+ MOVSI A,TLOCD ; MAKE SURE MONCH WINS
+ PUSHJ P,MONCH0 ; WOULD YOU BELIEVE MONITORS!!!!
+ EXCH D,B ;SAVE PTR
+ MOVE A,C
+ HRRZ E,-2(D) ; POINT TO POSSIBLE GDECL (OR MAINIFEST)
+ JUMPE E,OKSETG ; NONE ,OK
+ CAIE E,-1 ; MANIFEST?
+ JRST SETGTY
+ GETYP 0,(D) ; IF UNBOUND, LET IT HAPPEN
+ SKIPN IGDECL
+ CAIN 0,TUNBOU
+ JRST OKSETG
+MANILO: GETYP C,(D)
+ GETYP 0,2(AB)
+ CAIN 0,(C)
+ CAME B,1(D)
+ JRST .+2
+ JRST OKSETG
+ PUSH TP,$TVEC
+ PUSH TP,D
+ MOVE B,IMQUOTE REDEFINE
+ PUSHJ P,ILVAL ; SEE IF REDEFINE OK
+ GETYP A,A
+ CAIE A,TUNBOU
+ CAIN A,TFALSE
+ JRST .+2
+ JRST OKSTG
+ PUSH TP,$TATOM
+ PUSH TP,EQUOTE ATTEMPT-TO-CHANGE-MANIFEST-VARIABLE
+ PUSH TP,$TATOM
+ PUSH TP,1(AB)
+ MOVEI A,2
+ JRST CALER
+
+SETGTY: PUSH TP,$TVEC
+ PUSH TP,D
+ MOVE C,A
+ MOVE D,B
+ GETYP A,(E)
+ MOVSI A,(A)
+ MOVE B,1(E)
+ JSP E,CHKAB
+ PUSHJ P,TMATCH
+ JRST TYPMI3
+
+OKSTG: MOVE D,(TP)
+ MOVE A,2(AB)
+ MOVE B,3(AB)
+
+OKSETG: MOVEM A,(D) ;DEPOSIT INTO THE
+ MOVEM B,1(D) ;INDICATED VALUE CELL
+ JRST FINIS
+
+TYPMI3: MOVE C,(TP)
+ HRRZ C,-2(C)
+ MOVE D,2(AB)
+ MOVE B,3(AB)
+ MOVE 0,(AB)
+ MOVE A,1(AB)
+ JRST TYPMIS
+
+BSETG: HRRZ A,GLOBASE+1
+ HRRZ B,GLOBSP+1
+ SUB B,A
+ CAIL B,6
+ JRST SETGIT
+ MOVEI B,0 ; MAKE SURE OF NO EMPTY SLOTS
+ PUSHJ P,IGLOC
+ CAMN A,$TUNBOU ; SKIP IF SLOT FOUND
+ JRST BSETG1
+ MOVE C,(TP) ; GET ATOM
+ MOVEM C,-1(B) ; CLOBBER ATOM SLOT
+ HLLZS -2(B) ; CLOBBER OLD DECL
+ JRST BSETGX
+; BSETG1: PUSH TP,GLOBASE ; MUST REALLY GROW STACK
+; PUSH TP,GLOBASE+1
+; PUSH TP,$TFIX
+; PUSH TP,[0]
+; PUSH TP,$TFIX
+; PUSH TP,[100]
+; MCALL 3,GROW
+BSETG1: PUSH P,0
+ PUSH P,C
+ MOVE C,GLOBASE+1
+ HLRE B,C
+ SUB C,B
+ MOVE B,GVLINC ; GROW BY INDICATED GVAL SLOTS
+ DPB B,[001100,,(C)]
+; MOVEM A,GLOBASE
+ MOVE C,[6,,4] ; INDICATOR FOR AGC
+ PUSHJ P,AGC
+ MOVE B,GLOBASE+1
+ MOVE 0,GVLINC ; ADJUST GLOBAL SPBASE
+ ASH 0,6
+ SUB B,0
+ HRLZS 0
+ SUB B,0
+ MOVEM B,GLOBASE+1
+; MOVEM B,GLOBASE+1
+ POP P,0
+ POP P,C
+SETGIT:
+ MOVE B,GLOBSP+1
+ SUB B,[4,,4]
+ MOVSI C,TGATOM
+ MOVEM C,(B)
+ MOVE C,(TP)
+ MOVEM C,1(B)
+ MOVEM B,GLOBSP+1
+ ADD B,[2,,2]
+BSETGX: MOVSI A,TLOCI
+ PUSHJ P,PATSCH ; FIXUP SCHLPAGE
+ MOVEM A,(C)
+ MOVEM B,1(C)
+ POPJ P,
+
+PATSCH: GETYP 0,(C)
+ CAIN 0,TLOCI
+ SKIPL D,1(C)
+ POPJ P,
+
+PATL: SKIPL E,3(D) ; SKIP IF NEXT EXISTS
+ JRST PATL1
+ MOVE D,E
+ JRST PATL
+
+PATL1: MOVEI E,1
+ MOVEM E,3(D) ; SAY GVAL ETC. EXISTS IF WE UNBIND
+ POPJ P,
+
+
+IMFUNCTION DEFMAC,FSUBR
+
+ ENTRY 1
+
+ PUSH P,.
+ JRST DFNE2
+
+IMFUNCTION DFNE,FSUBR,[DEFINE]
+
+ ENTRY 1
+
+ PUSH P,[0]
+DFNE2: GETYP A,(AB)
+ CAIE A,TLIST
+ JRST WRONGT
+ SKIPN B,1(AB) ; GET ATOM
+ JRST TFA
+ GETYP A,(B) ; MAKE SURE ATOM
+ MOVSI A,(A)
+ PUSH TP,A
+ PUSH TP,1(B)
+ JSP E,CHKARG
+ MCALL 1,EVAL ; EVAL IT TO AN ATOM
+ CAME A,$TATOM
+ JRST NONATM
+ PUSH TP,A ; SAVE TWO COPIES
+ PUSH TP,B
+ PUSHJ P,IGVAL ; SEE IF A VALUE EXISTS
+ CAMN A,$TUNBOU ; SKIP IF A WINNER
+ JRST .+3
+ PUSHJ P,ASKUSR ; CHECK WITH USER
+ JRST DFNE1
+ PUSH TP,$TATOM
+ PUSH TP,-1(TP)
+ MOVE B,1(AB)
+ HRRZ B,(B)
+ MOVSI A,TEXPR
+ SKIPN (P) ; SKIP IF MACRO
+ JRST DFNE3
+ MOVEI D,(B) ; READY TO CONS
+ MOVSI C,TEXPR
+ PUSHJ P,INCONS
+ MOVSI A,TMACRO
+DFNE3: PUSH TP,A
+ PUSH TP,B
+ MCALL 2,SETG
+DFNE1: POP TP,B ; RETURN ATOM
+ POP TP,A
+ JRST FINIS
+
+
+ASKUSR: MOVE B,IMQUOTE REDEFINE
+ PUSHJ P,ILVAL ; SEE IF REDEFINE OK
+ GETYP A,A
+ CAIE A,TUNBOU
+ CAIN A,TFALSE
+ JRST ASKUS1
+ JRST ASKUS2
+ASKUS1: PUSH TP,$TATOM
+ PUSH TP,-1(TP)
+ PUSH TP,$TATOM
+ PUSH TP,EQUOTE ALREADY-DEFINED-ERRET-NON-FALSE-TO-REDEFINE
+ MCALL 2,ERROR
+ GETYP 0,A
+ CAIE 0,TFALSE
+ASKUS2: AOS (P)
+ MOVE B,1(AB)
+ POPJ P,
+\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: CAMN A,$TUNBOUND ;BOUND?
+ PUSHJ P, BSET ;BIND IT
+ MOVE C,2(AB) ; GET NEW VAL
+ MOVE D,3(AB)
+ MOVSI A,TLOCD ; FOR MONCH
+ HRR A,2(B)
+ PUSHJ P,MONCH0 ; HURRAY FOR MONITORS!!!!!
+ MOVE E,B
+ HLRZ A,2(E) ; GET DECLS
+ JUMPE A,SET3 ; NONE, GO
+ PUSH TP,$TSP
+ PUSH TP,E
+ MOVE B,1(A)
+ HLLZ A,(A) ; GET PATTERN
+ PUSHJ P,TMATCH ; MATCH TMEM
+ JRST TYPMI2 ; LOSES
+ MOVE E,(TP)
+ SUB TP,[2,,2]
+ MOVE C,2(AB)
+ MOVE D,3(AB)
+SET3: MOVEM C,(E) ;CLOBBER IDENTIFIER
+ MOVEM D,1(E)
+ MOVE A,C
+ MOVE B,D
+ MOVE C,-2(TP) ; GET PROC
+ HRRZ C,BINDID+1(C)
+ HRLI C,TLOCI
+
+; HERE WE NOTE THAT EFFICIENCY CAN SOMETIMES GET IN THE WAY OF CORRECTNESS
+; BY SETTING THE SHALLOW BINDING WE MANAGE TO CLOBBER THE TOP LEVEL LVAL
+; EVEN IF WE ARE SETTING WITH RESPECT TO A DIFFERENT FRAME. TO CORRECT
+; THIS GLITCH THIS ACTIVITY WILL ONLY TAKE PLACE IF THE ATOM ALREADY POINTS
+; TO A BINDING
+
+ MOVE D,1(AB)
+ SKIPE (D)
+ JRST NSHALL
+ MOVEM C,(D)
+ MOVEM E,1(D)
+NSHALL: SUB TP,[4,,4]
+ JRST FINIS
+BSET:
+ MOVE PVP,PVSTOR+1
+ CAMN PVP,-2(TP) ; SKIP IF PROC DIFFERS
+ MOVEM C,-2(TP) ; ELSE USE RESULT FROM LOC SEARCH
+ MOVE B,-2(TP) ; GET PROCESS
+ HRRZ A,TPBASE+1(B) ;GET ACTUAL STACK BASE
+ HRRZ B,SPBASE+1(B) ;AND FIRST BINDING
+ SUB B,A ;ARE THERE 6
+ CAIL B,6 ;CELLS AVAILABLE?
+ JRST SETIT ;YES
+ MOVE C,(TP) ; GET POINTER BACK
+ MOVEI B,0 ; LOOK FOR EMPTY SLOT
+ PUSHJ P,AILOC
+ CAMN A,$TUNBOUND ; SKIP IF FOUND
+ JRST BSET1
+ MOVE E,1(AB) ; GET ATOM
+ MOVEM E,-1(B) ; AND STORE
+ JRST BSET2
+BSET1: MOVE B,-2(TP) ; GET PROCESS
+; PUSH TP,TPBASE(B) ;NO -- GROW THE TP
+; PUSH TP,TPBASE+1(B) ;AT THE BASE END
+; PUSH TP,$TFIX
+; PUSH TP,[0]
+; PUSH TP,$TFIX
+; PUSH TP,[100]
+; MCALL 3,GROW
+; MOVE C,-2(TP) ; GET PROCESS
+; MOVEM A,TPBASE(C) ;SAVE RESULT
+ PUSH P,0 ; MANUALLY GROW VECTOR
+ PUSH P,C
+ MOVE C,TPBASE+1(B)
+ HLRE B,C
+ SUB C,B
+ MOVEI C,1(C)
+ CAME C,TPGROW
+ ADDI C,PDLBUF
+ MOVE D,LVLINC
+ DPB D,[001100,,-1(C)]
+ MOVE C,[5,,3] ; SET UP INDICATORS FOR AGC
+ PUSHJ P,AGC
+ MOVE PVP,PVSTOR+1
+ MOVE B,TPBASE+1(PVP) ; MODIFY POINTER
+ MOVE 0,LVLINC ; ADJUST SPBASE POINTER
+ ASH 0,6
+ SUB B,0
+ HRLZS 0
+ SUB B,0
+ MOVEM B,TPBASE+1(PVP)
+ POP P,C
+ POP P,0
+; MOVEM B,TPBASE+1(C)
+SETIT: MOVE C,-2(TP) ; GET PROCESS
+ MOVE B,SPBASE+1(C)
+ MOVEI A,-6(B) ;MAKE UP BINDING
+ HRRM A,(B) ;LINK PREVIOUS BIND BLOCK
+ MOVSI A,TBIND
+ MOVEM A,-6(B)
+ MOVE A,1(AB)
+ MOVEM A,-5(B)
+ SUB B,[6,,6]
+ MOVEM B,SPBASE+1(C)
+ ADD B,[2,,2]
+BSET2: MOVE C,-2(TP) ; GET PROC
+ MOVSI A,TLOCI
+ HRR A,BINDID+1(C)
+ HLRZ D,OTBSAV(TB) ; TIME IT
+ MOVEM D,2(B) ; AND FIX IT
+ POPJ P,
+
+; HERE TO ELABORATE ON TYPE MISMATCH
+
+TYPMI2: MOVE C,(TP) ; FIND DECLS
+ HLRZ C,2(C)
+ MOVE D,2(AB)
+ MOVE B,3(AB)
+ MOVE 0,(AB) ; GET ATOM
+ MOVE A,1(AB)
+ JRST TYPMIS
+
+\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 EVAL -- MUDDLE EVALUATOR
+
+RELOCATABLE
+
+; GERALD JAY SUSSMAN, 1971. REWRITTEN MANY TIMES SINCE C. REEVE (1972--1974)
+
+
+.GLOBAL BINDID,LPROG,GLOBSP,GLOBASE,SPBASE,TPBASE,PTIME,SWAP,CHFRAM
+.GLOBAL IGVAL,CHKARG,NXTDCL,TPOVFL,CHFRM,PROCHK,CHFSWP,VECBOT,TYPSGR
+.GLOBAL ILVAL,ER1ARG,SPECBIND,MAKACT,SPECSTORE,MAKTUP,TPALOC,IBIND,SSPECS
+.GLOBAL IDVAL,EVECTO,EUVECT,CHARGS,BCKTRK,CELL,ILOC,IGLOC,CHKDCL,SSPEC1
+.GLOBAL PDLBUF,MESS,FACTI,CHKARG,MAKENV,PSTAT,BNDV,UNBOU,UNAS,IGDECL
+.GLOBAL 1STEPR,SEGMNT,SEGLST,NAPT,EVTYPE,EVATYP,APTYPE,APLTYP,APLQ,IDVAL1
+.GLOBAL TESTR,VALG,TYPG,INCR1,TMATCH,TYPMIS,SAT,MAKACT,NTPALO,SPECBND
+.GLOBAL TPGROW,CHKAB,TYPSEG,NXTLM,MONCH0,CHFINI,RMONC0,IMPURIFY,ICONS,INCONS
+.GLOBAL CILVAL,CISET,CIGVAL,CSETG,MAPPLY,CLLOC,CGLOC,CASSQ,CGASSQ,CBOUND
+.GLOBAL IIGLOC,CHUNW,IUNWIN,UNWIN2,SPCCHK,CURFCN,TMPLNT,TD.LNT,TBINIT
+.GLOBAL SPECBE,BSETG,GLOTOP,CANDP,CORP,TFA,TMA,DSTORE,PVSTOR,SPSTOR
+.GLOBAL AGC,GVLINC,LVLINC,CGBOUN,IEVECT,MAKTU2,STOSTR,HIBOT,POPUNW,ISTRUC
+
+.INSRT MUDDLE >
+
+MONITOR
+
+\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,$TDECL ; SAVE HEWITT ATOM
+ PUSH TP,-1(P)
+ PUSH TP,$TATOM ; AND DECLS
+ PUSH TP,-2(P)
+ TRNN A,2 ; SKIP IF INIT VAL EXISTS
+ JRST AUXB3 ; NO, USE UNBOUND
+
+; EVALUATE EXPRESSION
+
+ HRRZ C,(B) ; CDR ATOM OFF
+
+; CHECK FOR SPECIAL FORMS <TUPLE ...> <ITUPLE ...>
+
+ GETYP 0,(C) ; GET TYPE OF GOODIE
+ CAIE 0,TFORM ; SMELLS LIKE A FORM
+ JRST AUXB13
+ HRRZ D,1(C) ; GET 1ST ELEMENT
+ GETYP 0,(D) ; AND ITS VAL
+ CAIE 0,TATOM ; FEELS LIKE THE RIGHT FORM
+ JRST AUXB13
+
+ MOVE 0,1(D) ; GET THE ATOM
+ CAME 0,IMQUOTE TUPLE
+ CAMN 0,MQUOTE ITUPLE
+ JRST DOTUPL ; SURE GLAD I DIDN'T STEP IN THAT FORM
+
+
+AUXB13: PUSHJ P,FASTEV
+AUXB14: MOVE E,TP
+AUXB4: MOVEM A,-7(E) ; STORE VAL IN BINDING
+ MOVEM B,-6(E)
+
+; HERE TO CHECK AGAINST DECLARATIONS AND COMPLETE THE BINDING
+
+AUXB5: SUB E,[4,,4] ; POINT TO BINDING TOP
+ SKIPE C,-2(TP) ; POINT TO DECLARATINS
+ PUSHJ P,CHKDCL ; CHECK IT
+ PUSHJ P,USPCBE ; AND BIND UP
+ SKIPE C,RE.ARG+1(TB) ; CDR DCLS
+ HRRZ C,(C) ; IF ANY TO CDR
+ MOVEM C,RE.ARG+1(TB)
+ MOVE A,(TP) ; NOW PUT HEWITT ATOM AND DCL AWAY
+ MOVEM A,-2(P)
+ MOVE A,-2(TP)
+ MOVEM A,-1(P)
+ SUB TP,[4,,4] ; FLUSH SLOTS
+ JRST AUXB1
+
+
+AUXB3: MOVNI B,1
+ MOVSI A,TUNBOU
+ JRST AUXB14
+
+\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
+ CAMN A,$TUNBOUND ;IF BOUND
+ PUSHJ P,BSETG ;IF NOT -- BIND IT
+ MOVE C,2(AB) ; GET PROPOSED VVAL
+ MOVE D,3(AB)
+ MOVSI A,TLOCD ; MAKE SURE MONCH WINS
+ PUSHJ P,MONCH0 ; WOULD YOU BELIEVE MONITORS!!!!
+ EXCH D,B ;SAVE PTR
+ MOVE A,C
+ HRRZ E,-2(D) ; POINT TO POSSIBLE GDECL (OR MAINIFEST)
+ JUMPE E,OKSETG ; NONE ,OK
+ CAIE E,-1 ; MANIFEST?
+ JRST SETGTY
+ GETYP 0,(D) ; IF UNBOUND, LET IT HAPPEN
+ SKIPN IGDECL
+ CAIN 0,TUNBOU
+ JRST OKSETG
+MANILO: GETYP C,(D)
+ GETYP 0,2(AB)
+ CAIN 0,(C)
+ CAME B,1(D)
+ JRST .+2
+ JRST OKSETG
+ PUSH TP,$TVEC
+ PUSH TP,D
+ MOVE B,IMQUOTE REDEFINE
+ PUSHJ P,ILVAL ; SEE IF REDEFINE OK
+ GETYP A,A
+ CAIE A,TUNBOU
+ CAIN A,TFALSE
+ JRST .+2
+ JRST OKSTG
+ PUSH TP,$TATOM
+ PUSH TP,EQUOTE ATTEMPT-TO-CHANGE-MANIFEST-VARIABLE
+ PUSH TP,$TATOM
+ PUSH TP,1(AB)
+ MOVEI A,2
+ JRST CALER
+
+SETGTY: PUSH TP,$TVEC
+ PUSH TP,D
+ MOVE C,A
+ MOVE D,B
+ GETYP A,(E)
+ MOVSI A,(A)
+ MOVE B,1(E)
+ JSP E,CHKAB
+ PUSHJ P,TMATCH
+ JRST TYPMI3
+
+OKSTG: MOVE D,(TP)
+ MOVE A,2(AB)
+ MOVE B,3(AB)
+
+OKSETG: MOVEM A,(D) ;DEPOSIT INTO THE
+ MOVEM B,1(D) ;INDICATED VALUE CELL
+ JRST FINIS
+
+TYPMI3: MOVE C,(TP)
+ HRRZ C,-2(C)
+ MOVE D,2(AB)
+ MOVE B,3(AB)
+ MOVE 0,(AB)
+ MOVE A,1(AB)
+ JRST TYPMIS
+
+BSETG: HRRZ A,GLOBASE+1
+ HRRZ B,GLOBSP+1
+ SUB B,A
+ CAIL B,6
+ JRST SETGIT
+ MOVEI B,0 ; MAKE SURE OF NO EMPTY SLOTS
+ PUSHJ P,IGLOC
+ CAMN A,$TUNBOU ; SKIP IF SLOT FOUND
+ JRST BSETG1
+ MOVE C,(TP) ; GET ATOM
+ MOVEM C,-1(B) ; CLOBBER ATOM SLOT
+ HLLZS -2(B) ; CLOBBER OLD DECL
+ JRST BSETGX
+; BSETG1: PUSH TP,GLOBASE ; MUST REALLY GROW STACK
+; PUSH TP,GLOBASE+1
+; PUSH TP,$TFIX
+; PUSH TP,[0]
+; PUSH TP,$TFIX
+; PUSH TP,[100]
+; MCALL 3,GROW
+BSETG1: PUSH P,0
+ PUSH P,C
+ MOVE C,GLOBASE+1
+ HLRE B,C
+ SUB C,B
+ MOVE B,GVLINC ; GROW BY INDICATED GVAL SLOTS
+ DPB B,[001100,,(C)]
+; MOVEM A,GLOBASE
+ MOVE C,[6,,4] ; INDICATOR FOR AGC
+ PUSHJ P,AGC
+ MOVE B,GLOBASE+1
+ MOVE 0,GVLINC ; ADJUST GLOBAL SPBASE
+ ASH 0,6
+ SUB B,0
+ HRLZS 0
+ SUB B,0
+ MOVEM B,GLOBASE+1
+; MOVEM B,GLOBASE+1
+ POP P,0
+ POP P,C
+SETGIT:
+ MOVE B,GLOBSP+1
+ SUB B,[4,,4]
+ MOVSI C,TGATOM
+ MOVEM C,(B)
+ MOVE C,(TP)
+ MOVEM C,1(B)
+ MOVEM B,GLOBSP+1
+ ADD B,[2,,2]
+BSETGX: MOVSI A,TLOCI
+ PUSHJ P,PATSCH ; FIXUP SCHLPAGE
+ MOVEM A,(C)
+ MOVEM B,1(C)
+ POPJ P,
+
+PATSCH: GETYP 0,(C)
+ CAIN 0,TLOCI
+ SKIPL D,1(C)
+ POPJ P,
+
+PATL: SKIPL E,3(D) ; SKIP IF NEXT EXISTS
+ JRST PATL1
+ MOVE D,E
+ JRST PATL
+
+PATL1: MOVEI E,1
+ MOVEM E,3(D) ; SAY GVAL ETC. EXISTS IF WE UNBIND
+ POPJ P,
+
+
+IMFUNCTION DEFMAC,FSUBR
+
+ ENTRY 1
+
+ PUSH P,.
+ JRST DFNE2
+
+IMFUNCTION DFNE,FSUBR,[DEFINE]
+
+ ENTRY 1
+
+ PUSH P,[0]
+DFNE2: GETYP A,(AB)
+ CAIE A,TLIST
+ JRST WRONGT
+ SKIPN B,1(AB) ; GET ATOM
+ JRST TFA
+ GETYP A,(B) ; MAKE SURE ATOM
+ MOVSI A,(A)
+ PUSH TP,A
+ PUSH TP,1(B)
+ JSP E,CHKARG
+ MCALL 1,EVAL ; EVAL IT TO AN ATOM
+ CAME A,$TATOM
+ JRST NONATM
+ PUSH TP,A ; SAVE TWO COPIES
+ PUSH TP,B
+ PUSHJ P,IGVAL ; SEE IF A VALUE EXISTS
+ CAMN A,$TUNBOU ; SKIP IF A WINNER
+ JRST .+3
+ PUSHJ P,ASKUSR ; CHECK WITH USER
+ JRST DFNE1
+ PUSH TP,$TATOM
+ PUSH TP,-1(TP)
+ MOVE B,1(AB)
+ HRRZ B,(B)
+ MOVSI A,TEXPR
+ SKIPN (P) ; SKIP IF MACRO
+ JRST DFNE3
+ MOVEI D,(B) ; READY TO CONS
+ MOVSI C,TEXPR
+ PUSHJ P,INCONS
+ MOVSI A,TMACRO
+DFNE3: PUSH TP,A
+ PUSH TP,B
+ MCALL 2,SETG
+DFNE1: POP TP,B ; RETURN ATOM
+ POP TP,A
+ JRST FINIS
+
+
+ASKUSR: MOVE B,IMQUOTE REDEFINE
+ PUSHJ P,ILVAL ; SEE IF REDEFINE OK
+ GETYP A,A
+ CAIE A,TUNBOU
+ CAIN A,TFALSE
+ JRST ASKUS1
+ JRST ASKUS2
+ASKUS1: PUSH TP,$TATOM
+ PUSH TP,-1(TP)
+ PUSH TP,$TATOM
+ PUSH TP,EQUOTE ALREADY-DEFINED-ERRET-NON-FALSE-TO-REDEFINE
+ MCALL 2,ERROR
+ GETYP 0,A
+ CAIE 0,TFALSE
+ASKUS2: AOS (P)
+ MOVE B,1(AB)
+ POPJ P,
+\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: CAMN A,$TUNBOUND ;BOUND?
+ PUSHJ P, BSET ;BIND IT
+ MOVE C,2(AB) ; GET NEW VAL
+ MOVE D,3(AB)
+ MOVSI A,TLOCD ; FOR MONCH
+ HRR A,2(B)
+ PUSHJ P,MONCH0 ; HURRAY FOR MONITORS!!!!!
+ MOVE E,B
+ HLRZ A,2(E) ; GET DECLS
+ JUMPE A,SET3 ; NONE, GO
+ PUSH TP,$TSP
+ PUSH TP,E
+ MOVE B,1(A)
+ HLLZ A,(A) ; GET PATTERN
+ PUSHJ P,TMATCH ; MATCH TMEM
+ JRST TYPMI2 ; LOSES
+ MOVE E,(TP)
+ SUB TP,[2,,2]
+ MOVE C,2(AB)
+ MOVE D,3(AB)
+SET3: MOVEM C,(E) ;CLOBBER IDENTIFIER
+ MOVEM D,1(E)
+ MOVE A,C
+ MOVE B,D
+ MOVE C,-2(TP) ; GET PROC
+ HRRZ C,BINDID+1(C)
+ HRLI C,TLOCI
+
+; HERE WE NOTE THAT EFFICIENCY CAN SOMETIMES GET IN THE WAY OF CORRECTNESS
+; BY SETTING THE SHALLOW BINDING WE MANAGE TO CLOBBER THE TOP LEVEL LVAL
+; EVEN IF WE ARE SETTING WITH RESPECT TO A DIFFERENT FRAME. TO CORRECT
+; THIS GLITCH THIS ACTIVITY WILL ONLY TAKE PLACE IF THE ATOM ALREADY POINTS
+; TO A BINDING
+
+ MOVE D,1(AB)
+ SKIPE (D)
+ JRST NSHALL
+ MOVEM C,(D)
+ MOVEM E,1(D)
+NSHALL: SUB TP,[4,,4]
+ JRST FINIS
+BSET:
+ MOVE PVP,PVSTOR+1
+ CAMN PVP,-2(TP) ; SKIP IF PROC DIFFERS
+ MOVEM C,-2(TP) ; ELSE USE RESULT FROM LOC SEARCH
+ MOVE B,-2(TP) ; GET PROCESS
+ HRRZ A,TPBASE+1(B) ;GET ACTUAL STACK BASE
+ HRRZ B,SPBASE+1(B) ;AND FIRST BINDING
+ SUB B,A ;ARE THERE 6
+ CAIL B,6 ;CELLS AVAILABLE?
+ JRST SETIT ;YES
+ MOVE C,(TP) ; GET POINTER BACK
+ MOVEI B,0 ; LOOK FOR EMPTY SLOT
+ PUSHJ P,AILOC
+ CAMN A,$TUNBOUND ; SKIP IF FOUND
+ JRST BSET1
+ MOVE E,1(AB) ; GET ATOM
+ MOVEM E,-1(B) ; AND STORE
+ JRST BSET2
+BSET1: MOVE B,-2(TP) ; GET PROCESS
+; PUSH TP,TPBASE(B) ;NO -- GROW THE TP
+; PUSH TP,TPBASE+1(B) ;AT THE BASE END
+; PUSH TP,$TFIX
+; PUSH TP,[0]
+; PUSH TP,$TFIX
+; PUSH TP,[100]
+; MCALL 3,GROW
+; MOVE C,-2(TP) ; GET PROCESS
+; MOVEM A,TPBASE(C) ;SAVE RESULT
+ PUSH P,0 ; MANUALLY GROW VECTOR
+ PUSH P,C
+ MOVE C,TPBASE+1(B)
+ HLRE B,C
+ SUB C,B
+ MOVEI C,1(C)
+ CAME C,TPGROW
+ ADDI C,PDLBUF
+ MOVE D,LVLINC
+ DPB D,[001100,,-1(C)]
+ MOVE C,[5,,3] ; SET UP INDICATORS FOR AGC
+ PUSHJ P,AGC
+ MOVE PVP,PVSTOR+1
+ MOVE B,TPBASE+1(PVP) ; MODIFY POINTER
+ MOVE 0,LVLINC ; ADJUST SPBASE POINTER
+ ASH 0,6
+ SUB B,0
+ HRLZS 0
+ SUB B,0
+ MOVEM B,TPBASE+1(PVP)
+ POP P,C
+ POP P,0
+; MOVEM B,TPBASE+1(C)
+SETIT: MOVE C,-2(TP) ; GET PROCESS
+ MOVE B,SPBASE+1(C)
+ MOVEI A,-6(B) ;MAKE UP BINDING
+ HRRM A,(B) ;LINK PREVIOUS BIND BLOCK
+ MOVSI A,TBIND
+ MOVEM A,-6(B)
+ MOVE A,1(AB)
+ MOVEM A,-5(B)
+ SUB B,[6,,6]
+ MOVEM B,SPBASE+1(C)
+ ADD B,[2,,2]
+BSET2: MOVE C,-2(TP) ; GET PROC
+ MOVSI A,TLOCI
+ HRR A,BINDID+1(C)
+ HLRZ D,OTBSAV(TB) ; TIME IT
+ MOVEM D,2(B) ; AND FIX IT
+ POPJ P,
+
+; HERE TO ELABORATE ON TYPE MISMATCH
+
+TYPMI2: MOVE C,(TP) ; FIND DECLS
+ HLRZ C,2(C)
+ MOVE D,2(AB)
+ MOVE B,3(AB)
+ MOVE 0,(AB) ; GET ATOM
+ MOVE A,1(AB)
+ JRST TYPMIS
+
+\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 EVAL -- MUDDLE EVALUATOR
+
+RELOCATABLE
+
+; GERALD JAY SUSSMAN, 1971. REWRITTEN MANY TIMES SINCE C. REEVE (1972--1974)
+
+
+.GLOBAL BINDID,LPROG,GLOBSP,GLOBASE,SPBASE,TPBASE,PTIME,SWAP,CHFRAM
+.GLOBAL IGVAL,CHKARG,NXTDCL,TPOVFL,CHFRM,PROCHK,CHFSWP,VECBOT,TYPSGR
+.GLOBAL ILVAL,ER1ARG,SPECBIND,MAKACT,SPECSTORE,MAKTUP,TPALOC,IBIND,SSPECS
+.GLOBAL IDVAL,EVECTO,EUVECT,CHARGS,BCKTRK,CELL,ILOC,IGLOC,CHKDCL,SSPEC1
+.GLOBAL PDLBUF,MESS,FACTI,CHKARG,MAKENV,PSTAT,BNDV,UNBOU,UNAS,IGDECL
+.GLOBAL 1STEPR,SEGMNT,SEGLST,NAPT,EVTYPE,EVATYP,APTYPE,APLTYP,APLQ,IDVAL1
+.GLOBAL TESTR,VALG,TYPG,INCR1,TMATCH,TYPMIS,SAT,MAKACT,NTPALO,SPECBND
+.GLOBAL TPGROW,CHKAB,TYPSEG,NXTLM,MONCH0,CHFINI,RMONC0,IMPURIFY,ICONS,INCONS
+.GLOBAL CILVAL,CISET,CIGVAL,CSETG,MAPPLY,CLLOC,CGLOC,CASSQ,CGASSQ,CBOUND
+.GLOBAL IIGLOC,CHUNW,IUNWIN,UNWIN2,SPCCHK,CURFCN,TMPLNT,TD.LNT,TBINIT
+.GLOBAL SPECBE,BSETG,GLOTOP,CANDP,CORP,TFA,TMA,DSTORE,PVSTOR,SPSTOR
+.GLOBAL AGC,GVLINC,LVLINC,CGBOUN,IEVECT,MAKTU2,STOSTR,HIBOT,POPUNW,ISTRUC
+.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,$TDECL ; SAVE HEWITT ATOM
+ PUSH TP,-1(P)
+ PUSH TP,$TATOM ; AND DECLS
+ PUSH TP,-2(P)
+ TRNN A,2 ; SKIP IF INIT VAL EXISTS
+ JRST AUXB3 ; NO, USE UNBOUND
+
+; EVALUATE EXPRESSION
+
+ HRRZ C,(B) ; CDR ATOM OFF
+
+; CHECK FOR SPECIAL FORMS <TUPLE ...> <ITUPLE ...>
+
+ GETYP 0,(C) ; GET TYPE OF GOODIE
+ CAIE 0,TFORM ; SMELLS LIKE A FORM
+ JRST AUXB13
+ HRRZ D,1(C) ; GET 1ST ELEMENT
+ GETYP 0,(D) ; AND ITS VAL
+ CAIE 0,TATOM ; FEELS LIKE THE RIGHT FORM
+ JRST AUXB13
+
+ MOVE 0,1(D) ; GET THE ATOM
+ CAME 0,IMQUOTE TUPLE
+ CAMN 0,MQUOTE ITUPLE
+ JRST DOTUPL ; SURE GLAD I DIDN'T STEP IN THAT FORM
+
+
+AUXB13: PUSHJ P,FASTEV
+AUXB14: MOVE E,TP
+AUXB4: MOVEM A,-7(E) ; STORE VAL IN BINDING
+ MOVEM B,-6(E)
+
+; HERE TO CHECK AGAINST DECLARATIONS AND COMPLETE THE BINDING
+
+AUXB5: SUB E,[4,,4] ; POINT TO BINDING TOP
+ SKIPE C,-2(TP) ; POINT TO DECLARATINS
+ PUSHJ P,CHKDCL ; CHECK IT
+ PUSHJ P,USPCBE ; AND BIND UP
+ SKIPE C,RE.ARG+1(TB) ; CDR DCLS
+ HRRZ C,(C) ; IF ANY TO CDR
+ MOVEM C,RE.ARG+1(TB)
+ MOVE A,(TP) ; NOW PUT HEWITT ATOM AND DCL AWAY
+ MOVEM A,-2(P)
+ MOVE A,-2(TP)
+ MOVEM A,-1(P)
+ SUB TP,[4,,4] ; FLUSH SLOTS
+ JRST AUXB1
+
+
+AUXB3: MOVNI B,1
+ MOVSI A,TUNBOU
+ JRST AUXB14
+
+\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 EVAL -- MUDDLE EVALUATOR
+
+RELOCATABLE
+
+; GERALD JAY SUSSMAN, 1971. REWRITTEN MANY TIMES SINCE C. REEVE (1972--1974)
+
+
+.GLOBAL BINDID,LPROG,GLOBSP,GLOBASE,SPBASE,TPBASE,PTIME,SWAP,CHFRAM
+.GLOBAL IGVAL,CHKARG,NXTDCL,TPOVFL,CHFRM,PROCHK,CHFSWP,VECBOT,TYPSGR
+.GLOBAL ILVAL,ER1ARG,SPECBIND,MAKACT,SPECSTORE,MAKTUP,TPALOC,IBIND,SSPECS
+.GLOBAL IDVAL,EVECTO,EUVECT,CHARGS,BCKTRK,CELL,ILOC,IGLOC,CHKDCL,SSPEC1
+.GLOBAL PDLBUF,MESS,FACTI,CHKARG,MAKENV,PSTAT,BNDV,UNBOU,UNAS,IGDECL
+.GLOBAL 1STEPR,SEGMNT,SEGLST,NAPT,EVTYPE,EVATYP,APTYPE,APLTYP,APLQ,IDVAL1
+.GLOBAL TESTR,VALG,TYPG,INCR1,TMATCH,TYPMIS,SAT,MAKACT,NTPALO,SPECBND
+.GLOBAL TPGROW,CHKAB,TYPSEG,NXTLM,MONCH0,CHFINI,RMONC0,IMPURIFY,ICONS,INCONS
+.GLOBAL CILVAL,CISET,CIGVAL,CSETG,MAPPLY,CLLOC,CGLOC,CASSQ,CGASSQ,CBOUND
+.GLOBAL IIGLOC,CHUNW,IUNWIN,UNWIN2,SPCCHK,CURFCN,TMPLNT,TD.LNT,TBINIT
+.GLOBAL SPECBE,BSETG,GLOTOP,CANDP,CORP,TFA,TMA,DSTORE,PVSTOR,SPSTOR
+.GLOBAL AGC,GVLINC,LVLINC,CGBOUN,IEVECT,MAKTU2,STOSTR,HIBOT,POPUNW,ISTRUC
+.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
+CONN INT:
+DEL MDLXXX.*.*
+DELVER
+YY*.*.*
+EXP
+DEL MDL:MDLXXX.*.*
+DEL MDL:*.SAV00.*
+EXP MDL:
+STINK
+MMUD105.STINK\e@\e\eMMDLXXX.EXE\eY\e\eRESET .
+
+NDDT
+;YMDLXXX.EXE
+;UMDLXXX.EXE
+;OMDLXXX.SYMBOLS
+
+INTFCN\eK
+NAME1\eK
+BUFRIN\eK
+PROCID\eK
+IOIN2\eK
+ITEM\eK
+NIL\eK
+TYPVEC\eK
+INAME\eK
+ECHO\eK
+CHANNO\eK
+VAL\eK
+CHRCNT\eK
+0STO\eK
+TYPBOT\eK
+ERASCH\eK
+DIRECT\eK
+INDIC\eK
+INTFCN\eK
+KILLCH\eK
+TTICHN\eK
+ASTO\eK
+BRKCH\eK
+NODPNT\eK
+ESCAP\eK
+BSTO\eK
+TTOCHN\eK
+SYSCHR\eK
+BRFCHR\eK
+CSTO\eK
+ROOT\eK
+ASOLNT\eK
+BRFCH2\eK
+BYTPTR\eK
+INITIA\eK
+DSTO\eK
+ESTO\eK
+INTOBL\eK
+PVPSTO\eK
+ERROBL\eK
+MUDOBL\eK
+TVPSTO\eK
+ABSTO\eK
+INTNUM\eK
+STATUS\eK
+INTVEC\eK
+QUEUES\eK
+TBSTO\eK
+CHNL1\eK
+.LIST.\eK
+GCPDL\eK
+CONADJ\eK
+T.CHAN\eK
+N.CHNS\eK
+SLENGC\eK
+LENGC\eK
+SECLEN\eK
+;WMDLXXX.SYMBOLS
+;H
+RESET .
+NDDT
+;YMDLXXX.EXE
+;OMDLXXX.SYMBOLS
+NSEGS/3
+MASK1/700541,,2007
+;UMDLXXX.EXE
+;H
+LOGOUT
--- /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
+ 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
+ MOVEM 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)
+ 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
+ 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
+ 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: MOVSI 0,NOSTOR
+
+RGPARS: IORM 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]
+CHKLST: JUMPGE AB,CPOPJ1
+ SKIPGE (P) ; IF FROM OPEN, ALLOW ONE MORE
+ POPJ P,
+ PMOVEM (AB),T.XT(TB)
+ ADD AB,[2,,2]
+ 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
+ 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
+ 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
+ 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
+ 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
+ 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
+ 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)
+ 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 A,CHANNO(B) ; GET JFN
+ GDSTS ; GET STATE
+ 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 A,CHANNO(E)
+ GDSTS
+ LSH B,-32.
+ 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)
+ 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
+ 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
+ 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"
+ 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
+ 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 CHNRM1
+ 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 2
+
+PBFL: PUSH P,. ; PUSH NON-ZERONESS
+ JRST BINI1
+
+MFUNCTION READB,SUBR
+
+ ENTRY
+
+ PUSH P,[0]
+ HLRZ 0,AB
+ CAIG 0,-3
+ CAIG 0,-7
+ JRST WNA
+
+BINI1: GETYP 0,(AB) ; SHOULD BE UVEC OR STORE
+ CAIN 0,TUVEC
+ JRST BINI2
+ CAIE 0,TSTORAGE
+ 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
+ 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
+ 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)
+BINI5: SKIPE LSTCH(B) ; INDICATES IF EOF HIT
+ JRST BINEOF
+ 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
+
+BUFOU1: SKIPE BUFSTR(B) ; ANY BUFFERS AROUND?
+ PUSHJ P,BFCLS1 ; GET RID OF SAME
+ MOVE A,1(AB)
+ PUSHJ P,PGBIOO
+ HLRE C,1(AB)
+ MOVNS C
+ addm c,ACCESS(B)
+ MOVE A,(AB) ; RET VECTOR ETC.
+ MOVE B,1(AB)
+ JRST FINIS
+
+
+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
+ 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
+ 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
+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
+ MOVEI C,-1(A) ; POINT TO BUFFER
+ HRLI C,004400
+ 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
+ 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]
+ JRST PGBIOT
+DOIOTO: PUSH P,D
+ PUSH P,C
+ PUSHJ P,PGBIOO
+DOIOTE: POP P,C
+ POP P,D
+ POPJ P,
+DOIOTI: PUSH P,D
+ PUSH P,C
+ PUSHJ P,PGBIOI
+ JRST DOIOTE
+]
+\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,INTFCN-1(B)
+ PUSH TP,INTFCN(B)
+ MCALL 1,APPLY
+ 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,INTFCN-1(B) ;PUSH TYPE OF GIVEN OBJ
+ PUSH TP,INTFCN(B) ;PUSH THE SUPPLIED FUNCTION (OR SUBR ETC.)
+ PUSH TP,$TCHRS ;PUSH THE TYPE "CHARACTER"
+ PUSH TP,A ;PUSH THE CHAR
+ MCALL 2,APPLY ;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 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
+ 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
+ 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
+ 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]
+CHKLST: JUMPGE AB,CPOPJ1
+ SKIPGE (P) ; IF FROM OPEN, ALLOW ONE MORE
+ POPJ P,
+ PMOVEM (AB),T.XT(TB)
+ ADD AB,[2,,2]
+ 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
+ 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 A,CHANNO(B) ; GET JFN
+ GDSTS ; GET STATE
+ 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 A,CHANNO(E)
+ GDSTS
+ LSH B,-32.
+ 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
+ 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
+ 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"
+ 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
+ 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 CHNRM1
+ 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
+ PUSHJ P,PGBIOO
+ 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
+ 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
+ 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,INTFCN-1(B)
+ PUSH TP,INTFCN(B)
+ MCALL 1,APPLY
+ 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,INTFCN-1(B) ;PUSH TYPE OF GIVEN OBJ
+ PUSH TP,INTFCN(B) ;PUSH THE SUPPLIED FUNCTION (OR SUBR ETC.)
+ PUSH TP,$TCHRS ;PUSH THE TYPE "CHARACTER"
+ PUSH TP,A ;PUSH THE CHAR
+ MCALL 2,APPLY ;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 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
+ 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
+ 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
+ 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]
+CHKLST: JUMPGE AB,CPOPJ1
+ SKIPGE (P) ; IF FROM OPEN, ALLOW ONE MORE
+ POPJ P,
+ PMOVEM (AB),T.XT(TB)
+ ADD AB,[2,,2]
+ 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
+ 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 A,CHANNO(B) ; GET JFN
+ GDSTS ; GET STATE
+ 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 A,CHANNO(E)
+ GDSTS
+ LSH B,-32.
+ 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
+ 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"
+ 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
+ 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 CHNRM1
+ 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
+ PUSHJ P,PGBIOO
+ 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
+ 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
+ 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,INTFCN-1(B)
+ PUSH TP,INTFCN(B)
+ MCALL 1,APPLY
+ 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,INTFCN-1(B) ;PUSH TYPE OF GIVEN OBJ
+ PUSH TP,INTFCN(B) ;PUSH THE SUPPLIED FUNCTION (OR SUBR ETC.)
+ PUSH TP,$TCHRS ;PUSH THE TYPE "CHARACTER"
+ PUSH TP,A ;PUSH THE CHAR
+ MCALL 2,APPLY ;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 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
+ 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
+ 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
+ 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]
+CHKLST: JUMPGE AB,CPOPJ1
+ SKIPGE (P) ; IF FROM OPEN, ALLOW ONE MORE
+ POPJ P,
+ PMOVEM (AB),T.XT(TB)
+ ADD AB,[2,,2]
+ 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
+ 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
+ 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"
+ 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
+ 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 CHNRM1
+ 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
+ PUSHJ P,PGBIOO
+ 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
+ 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
+ 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,INTFCN-1(B)
+ PUSH TP,INTFCN(B)
+ MCALL 1,APPLY
+ 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,INTFCN-1(B) ;PUSH TYPE OF GIVEN OBJ
+ PUSH TP,INTFCN(B) ;PUSH THE SUPPLIED FUNCTION (OR SUBR ETC.)
+ PUSH TP,$TCHRS ;PUSH THE TYPE "CHARACTER"
+ PUSH TP,A ;PUSH THE CHAR
+ MCALL 2,APPLY ;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 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
+ 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
+ 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
+ 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]
+CHKLST: JUMPGE AB,CPOPJ1
+ SKIPGE (P) ; IF FROM OPEN, ALLOW ONE MORE
+ POPJ P,
+ PMOVEM (AB),T.XT(TB)
+ ADD AB,[2,,2]
+ 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
+ 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
+ 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"
+ 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
+ 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 CHNRM1
+ 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
+ PUSHJ P,PGBIOO
+ 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
+ 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
+ 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,INTFCN-1(B)
+ PUSH TP,INTFCN(B)
+ MCALL 1,APPLY
+ 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 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
+ 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
+ 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
+ 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]
+CHKLST: JUMPGE AB,CPOPJ1
+ SKIPGE (P) ; IF FROM OPEN, ALLOW ONE MORE
+ POPJ P,
+ PMOVEM (AB),T.XT(TB)
+ ADD AB,[2,,2]
+ 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
+ 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
+ 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"
+ 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
+ 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 CHNRM1
+ 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
+ PUSHJ P,PGBIOO
+ 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
+ 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
+ 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 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 CHNRM1
+ 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
+ PUSHJ P,PGBIOO
+ 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
+ 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
+ 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 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 CHNRM1
+ 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
+ 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
+ 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 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 CHNRM1
+ 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
+
+<PACKAGE "GC-GRLOAD">
+
+<ENTRY GC-GROUP-LOAD GC-GROUP-DUMP>
+
+<USE "EDIT">
+
+<COND (<G? ,MUDDLE 100> <SETG TNM1 "ETMP"> <SETG TNM2 "MUDT">)
+ (ELSE <SETG TNM1 "_ETMP_"> <SETG TNM2 ">">)>
+
+<SETG VCOMP
+ <FORM COND
+ (<FORM N==? ,MUDDLE <FORM GVAL MUDDLE>>
+ <FORM ERROR RSUBR-CANT-RUN-IN-THIS-VERSION-OF-MUDDLE!-ERRORS>)>>
+
+<DEFINE GC-GROUP-LOAD (STR
+ "OPTIONAL" NAM
+ "AUX" (CHN <OPEN "READB" .STR>) FSP (REDEFINE T))
+ #DECL ((REDEFINE) <SPECIAL ANY>)
+ <PROG ()
+ <COND (<NOT <TYPE? .CHN CHANNEL>> <RETURN .CHN>)>
+ <COND (<NOT <ASSIGNED? NAM>>
+ <SET NAM
+ <PARSE <MAPF ,STRING
+ <FUNCTION (C) <MAPRET !"\\ .C>>
+ <7 .CHN>>>>)>
+ ;"To hack ugly file names. (TT, 75/10/07)"
+ <PUT .NAM
+ CHANNEL
+ <SET FSP <LIST <7 .CHN> <8 .CHN> <9 .CHN> <10 .CHN>>>>
+ <EVAL <GC-READ .CHN>>
+ <CLOSE .CHN>
+ .NAM>>
+
+<DEFINE GC-GROUP-DUMP (STR
+ "OPTIONAL" NM (BKILLER T)
+ "AUX" (CHN <CHANNEL "PRINTB" .STR>)
+ (NAM
+ <COND (<ASSIGNED? NM> .NM)
+ (ELSE <PARSE <7 .CHN>>)>)
+ (OC
+ <OPEN "PRINTB" ,TNM1 ,TNM2 <9 .CHN> <10 .CHN>>)
+ (FIXERS ()) FUNC BKS TEM TT HOLDANY GRP FIXES)
+ #DECL ((CHN) CHANNEL (NAM) ATOM (OC) <OR CHANNEL FALSE> (FIXERS) LIST)
+ <PROG ()
+ <COND (<NOT .OC> <RETURN .OC>)>
+ <COND (<OR <NOT <ASSIGNED? .NAM>> <NOT <TYPE? ..NAM LIST>>>
+ <CLOSE .OC>
+ <RETURN #FALSE ("Not a valid group name")>)>
+ <SET GRP ..NAM>
+ <SET FIXERS
+ (<FORM PUT .NAM BLOCK <FORM UNGET <UNGET <GET .NAM BLOCK '.OBLIST>>>>
+ !.FIXERS)>
+ <MAPR <>
+ <FUNCTION (OBP "AUX" (OB <1 .OBP>))
+ <COND (<SET TEM <GET <FORM QUOTE .OBP> COMMENT>>
+ <SET FIXERS
+ (<FORM PUT <FORM QUOTE .OBP> COMMENT .TEM> !.FIXERS)>)>
+ <COND (<SET TEM <GET .OBP BLOCK>>
+ <SET FIXERS
+ (<FORM PUT
+ <FORM QUOTE .OBP>
+ BLOCK
+ <FORM UNGET <UNGET .TEM>>>
+ !.FIXERS)>)>
+ <COND
+ (<AND <TYPE? .OB FORM> <NOT <EMPTY? .OB>>>
+ <COND
+ (<OR <==? <SET TEM <1 .OB>> DEFINE> <==? .TEM DEFMAC>>
+ <COND
+ (<AND
+ .BKILLER ;"Breakpoint killer"
+ <G? <LENGTH .OB> 1>
+ <SET BKS
+ <GETPROP
+ <AND <GASSIGNED? <SET FUNC <GET <2 .OB> VALUE '<2
+ .OB>>>>
+ <GLOC .FUNC>>
+ BREAKS>>>
+ <PUTPROP <GLOC .FUNC> BREAKS>
+ <REPEAT ()
+ <COND (<EMPTY? .BKS> <RETURN>)>
+ <COND (<TYPE? <SET HOLDANY <IN <1 .BKS>>> BREAK>
+ <SETLOC <1 .BKS> <2 .HOLDANY>>)>
+ <SET BKS <REST .BKS>>>)>
+ <SET TEM <COMMENT-ON .OB>>
+ <COND (<NOT <EMPTY? .TEM>>
+ <PUTREST <REST .TEM <- <LENGTH .TEM> 1>> .FIXERS>
+ <SET FIXERS .TEM>)>)
+ (<AND <==? .TEM SETG>
+ <==? <LENGTH .OB> 3>
+ <TYPE? <SET NM <GET <2 .OB> VALUE '<2 .OB>>> ATOM>
+ <OR <TYPE? <SET TEM <3 .OB>> RSUBR>
+ <AND <GASSIGNED? .NM> <TYPE? <SET TEM ,.NM> RSUBR>>>
+ <==? .NM <2 .TEM>>>
+ <COND (<AND <TYPE? <1 .TEM> CODE> <SET FIXES <GET .TEM RSUBR>>>
+ <SET FIXERS
+ (<FORM FIXIT <FORM QUOTE .TEM> .FIXES> !.FIXERS)>)
+ (<TYPE? <1 .TEM> CODE>
+ <PRINC
+"Warning: RSUBR lacks fixups, only use in same MUDDLE version. ">
+ <PRIN1 .NM>
+ <CRLF>
+ <SET FIXERS (,VCOMP !.FIXERS)>)>
+ <COND (<NOT <EMPTY? <SET TT <ANON-SRCH .TEM>>>>
+ <PUTREST <REST .TT <- <LENGTH .TT> 1>> .FIXERS>
+ <SET FIXERS .TT>)>
+ <COND (<TYPE? <SET TT <1 .TEM>> PCODE>
+ <SET FIXERS
+ (<FORM PUT
+ <FORM QUOTE .TEM>
+ 1
+ <PARSE <REST <UNPARSE .TT>>>>
+ !.FIXERS)>)>)>)>>
+ .GRP>
+ <GC-DUMP (<FORM MAPF
+ <>
+ <FORM GVAL EVAL>
+ <FORM SET .NAM <FORM QUOTE .GRP>>>
+ .FIXERS)
+ .OC>
+ <RENAME .OC .STR>
+ <CLOSE .OC>
+ .NAM>>
+
+<DEFINE COMMENT-ON (OB "AUX" (L ()) TEM TT)
+ <COND
+ (<NOT <MONAD? .OB>>
+ <MAPR <>
+ <FUNCTION (OBP)
+ <COND (<SET TEM <GET .OBP COMMENT>>
+ <SET L
+ (<FORM PUT <FORM QUOTE .OBP> COMMENT .TEM>
+ !.L)>)>
+ <COND (<NOT <EMPTY? <SET TEM <COMMENT-ON <1 .OBP>>>>>
+ <PUTREST <REST .TEM <- <LENGTH .TEM> 1>> .L>
+ <SET L .TEM>)>>
+ <REST .OB>>
+ <COND (<SET TEM <GET <1 .OB> COMMENT>>
+ <SET L (<FORM PUT <FORM QUOTE <1 .OB>> COMMENT .TEM> !.L)>)>
+ <COND (<OR <SET TEM <GET <SET TT .OB> COMMENT>>
+ <SET TEM <GET <SET TT <REST .OB 0>> COMMENT>>>
+ <SET L (<FORM PUT <FORM QUOTE .TT> COMMENT .TEM> !.L)>)>)
+ (<SET TEM <GET .OB COMMENT>> <SET L (.TEM)>)>
+ .L>
+
+<DEFINE ANON-SRCH (R "AUX" (L ()) TEM)
+ #DECL ((R) <PRIMTYPE VECTOR> (L) LIST)
+ <MAPR <>
+ <FUNCTION (THP "AUX" (THING <1 .THP>))
+ <COND (<AND <TYPE? .THING RSUBR>
+ <G? <LENGTH .THING> 1>
+ <TYPE? <SET TEM <2 .THING>> ATOM>
+ <OR <NOT <GASSIGNED? .TEM>> <N==? ,.TEM .THING>>>
+ <COND (<AND <TYPE? <1 .THING> CODE>
+ <SET TEM <GET .THING RSUBR>>>
+ <SET L (<FORM FIXIT <FORM QUOTE .THING> .TEM> !.L)>)
+ (<TYPE? <1 .THING> CODE>
+ <PRINC
+"Warning: RSUBR lacks fixups, only use in same MUDDLE version. ">
+ <PRIN1 <2 .THING>>
+ <CRLF>)>)>
+ <COND (<AND <TYPE? .THING RSUBR> <TYPE? <1 .THING> PCODE>>
+ <SET L
+ (<FORM PUT
+ <FORM QUOTE .THING>
+ 1
+ <PARSE <REST <UNPARSE <1 .THING>>>>>
+ !.L)>)>
+ <COND (<TYPE? .THING LOCD LOCR TYPE-W TYPE-C>
+ <SET L
+ (<FORM PUT
+ <FORM QUOTE .THP>
+ 1
+ <PARSE <REST <UNPARSE .THING>>>>
+ !.L)>
+ <COND (<TYPE? .THING LOCD>
+ <PUT .THP 1 LOCD>)>)>>
+ .R>
+ .L>
+
+<DEFINE UNGET (O)
+ <MAPF ,LIST <FUNCTION (X) <GET .X OBLIST>> .O>>
+\f
+<ENDPACKAGE>
+\ 3\ 3
\ No newline at end of file
--- /dev/null
+
+TITLE GCHACK
+
+RELOCATABLE
+
+.INSRT MUDDLE >
+
+.GLOBAL FRMUNG,PARBOT,TYPVEC,GCHACK,REHASH,IMPURI,NWORDT,GCDFLG
+.GLOBAL TD.LNT,TD.GET,TD.PUT,GCSTOP,GCSBOT,GCHK10,STOSTR,UBIT,PVSTOR,SPSTOR
+
+UBIT==40000 ; BIT INDICATING VECTOR
+.LIST.==400000
+
+; THIS IS AN INTERNAL MUDDLE SUBROUTINE TO RUN AROUND GC SPACE DOING
+; SOMETHING ARBITRARY TO EVERY ENTITY THEREIN
+
+; CALL --
+; A/ INSTRUCTION TO BE EXECUTED
+; PVP/ NON-ZERO OPTIMIZE--ONLY LOOK AT ATOMS
+; PUSHJ P,GCHACK
+
+; HERE FOR SPECIAL HACKS WHICH DON'T TOUCH STOAGE
+
+GCHK10: PUSHJ P,GHSTUP
+ JRST GCHK1
+
+GCHACK: PUSHJ P,GHSTUP ; SETUP
+ MOVE B,CODTOP ; START OFF WITH IMPURE STORAGE
+ SUBI B,1 ; START AT FIRST WORD
+LOPSTO: CAIG B,STOSTR
+ JRST GCHK1
+ HRRE 0,1(B) ; GET INDICATOR OF MODIFICATION
+ JUMPGE 0,LOSTO ; JUMP IF GARBAGE
+ PUSHJ P,VHACK ; VHACK
+ JRST LOPSTO
+LOSTO: HLRZ C,1(B) ; BACK OF VECTOR
+ TRZ C,400000
+ SUBI B,(C) ; SKIP OVER VECTOR
+ JRST LOPSTO
+
+GCHK1: MOVE B,VECTOP ; NO LOOP THRU GCS
+ MOVEI B,-2(B)
+
+
+LOOPHK: MOVE C,SVTAB
+ MOVEM B,(C)
+ EXCH C,NXTTAB ; SWAP LOCATIONS
+ EXCH C,SVTAB
+ TLZ B,.LIST. ; TURN OFF LIST BIT
+ CAMGE B,GCSBOT ; SEE IF DONE
+ JRST REHASQ ; SEE IF ASSOCIATIONS ARE GOOD
+ MOVE C,(B) ; GET ELEMENT
+ TLNE C,.VECT. ; SEE IF IT IS A VECTOR
+ JRST VHCK ; JUMP IF IT IS
+GLSTHK: GETYP C,(B) ; TYPE OF CURRENT PAIR
+ MOVE D,1(B) ; AND ITS DATUM
+ TLO B,.LIST. ; INDICATE A LIST
+ SKIPL (B) ; SKIP IF MARKED
+ XCT A ; APPLY INS
+ SUBI B,2
+ JRST LOOPHK
+VHCK: PUSHJ P,VHACK ; TO VHACK
+ JRST LOOPHK
+
+; NOW DO THE SAME THING TO VECTOR SPACE
+VHACK: HLRE D,(B) ; GET TYPE FROM D.W.
+ TRZ D,.VECT. ; GET RID OF VECTOR INDICATION BIT
+ HLRZ C,1(B) ; AND TOTAL LENGTH
+ TRZE C,400000 ; GET RID OF POSSIBLE MARK BIT
+ JRST MKHAK ; JUMP IF MARKED
+ SUBI B,(C)-2 ; POINT TO START OF VECTOR
+ PUSH P,B
+ SUBI C,2 ; CHECK WINNAGE
+ JUMPL C,BADV ; FATAL LOSSAGE
+ PUSH P,C ; SAVE COUNT
+ JUMPE C,VHACK1 ; EMPTY VECTOR, FINISHED
+
+; DECIDE BASED ON TYPE WHETHER GENERAL,UNIFORM OR SPECIAL
+
+ JUMPGE D,UHACK ; UNIFORM
+ TRNE D,377777 ; SKIP IF GENERAL
+ JRST SHACK ; SPECIAL
+
+; FALL THROUGH TO GENERAL
+
+GHACK1: SKIPGE (B) ; CHECK FOR FENCE POST
+ JRST VHACK1
+ GETYP C,(B) ; LOOK A T 1ST ELEMENT
+ CAIE C,TCBLK
+ CAIN C,TENTRY ; FRAME ON STACK
+ SOJA B,EHACK
+ CAIE C,TUBIND
+ CAIN C,TBIND ; BINDING BLOCK
+ JRST BHACK
+ CAIN C,TGATOM ; ATOM WITH GDECL?
+ JRST GDHACK
+ MOVE D,1(B) ; GET DATUM
+ XCT A ; USER INS
+GDHCK1: ADDI B,2 ; NEXT ELEMENT
+ SOS (P)
+ SOSLE (P) ; COUNT ELEMENTS
+ SKIPGE (B) ; OR FENCE POST HIT
+ JRST VHACK1
+ JRST GHACK1
+
+; HERE TO GO OVER UVECTORS
+
+UHACK: CAMN A,[PUSHJ P,SBSTIS]
+ JRST VHACK1 ; IF THIS SUBSTITUTE, DONT DO UVEC
+ MOVEI C,(D) ; COPY UNIFORM TYPE
+ JUMPE PVP,UHACKX ; JUMP IF NOT ONLY ATOMS
+ ASH C,1 ; COMPUTE SAT
+ ADD C,TYPVEC+1
+ HRRZ C,(C)
+ ANDI C,SATMSK ; GOT ITS SAT
+ CAIE C,SATOM ; DON'T BOTHER IF NOT ALL ATOMS
+ JRST VHACK1
+ MOVEI C,(D)
+UHACKX: PUSH P,C ; ATFIX CLOBBERS C
+ SUBI B,1 ; BACK OFF
+
+UHACK1: MOVE C,(P)
+ TLO B,UBIT ; TURN ON BIT INDICATING UVECTOR
+ MOVE D,1(B) ; DATUM
+ XCT A
+ SOSLE -1(P) ; COUNT DOEN
+ AOJA B,UHACK1
+ TLZ UBIT
+ POP P,C
+ JRST VHACK1
+
+; HERE TO HACK VARIOUS FLAVORS OF SPECIAL GOODIES
+
+SHACK: ANDI D,377777 ; KILL EXTRA CRUFT
+ CAIN D,SATOM
+ JRST ATHACK
+ CAIE D,STPSTK ; STACK OR
+ CAIN D,SPVP ; PROCESS
+ JRST GHACK1 ; TREAT LIKE GENERAL
+ CAIN D,SASOC ; ASSOCATION
+ JRST ASHACK
+ CAIG D,NUMSAT ; TEMPLATE MAYBE?
+ JRST BADV ; NO CHANCE
+ ADDI C,(B) ; POINT TO DOPE WORDS
+ SUBI D,NUMSAT+1
+ HRLI D,(D)
+ ADD D,TD.LNT+1
+ JUMPGE D,BADV ; JUMP IF INVALID TEMPLATE HACKER
+
+ CAMN A,[PUSHJ P,SBSTIS]
+ JRST VHACK1
+
+TD.UPD: PUSH P,A ; INS TO EXECUTE
+ XCT (D)
+ HLRZ E,B ; POSSIBLE BASIC LENGTH
+ PUSH P,[0]
+ PUSH P,E
+ MOVEI B,(B) ; ISOLATE LENGTH
+ PUSH P,C ; SAVE POINTER TO OBJECT
+
+ PUSH P,[0] ; HOME FOR VALUES
+ PUSH P,[0] ; SLOT FOR TEMP
+ PUSH P,B ; SAVE
+ SUB D,TD.LNT+1
+ PUSH P,D ; SAVE FOR FINDING OTHER TABLES
+ JUMPE E,TD.UP2 ; NO REPEATING SEQ
+ ADD D,TD.GET+1 ; COMP LNTH OF REPEATING SEQ
+ HLRE D,(D) ; D ==> - LNTH OF TEMPLATE
+ ADDI D,(E) ; D ==> -LENGTH OF REP SEQ
+ MOVNS D
+ HRLM D,-5(P) ; SAVE IT AND BASIC
+
+TD.UP2: SKIPG D,-1(P) ; ANY LEFT?
+ JRST TD.UP1
+
+ 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.UP3
+
+ 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.UP3: ADDI E,(D) ; POINT TO SLOT
+ XCT (E) ; GET THIS ELEMENT INTO A AND B
+ TLO A,UBIT ; INDICATE ITS A ANY
+ MOVEM A,-3(P) ; SAVE TYPE FOR LATER PUT
+ MOVEM B,-2(P)
+ GETYP C,A ; TYPE TO C
+ MOVE D,B ; DATUME
+ MOVEI B,-3(P) ; POINTER TO HOME
+ MOVE A,-7(P) ; GET INS
+ XCT A ; AND DO IT
+ MOVE C,-4(P) ; GET POINTER FOR UPDATE OF ELEMENT
+ MOVE E,TD.PUT+1
+ SOS D,-1(P) ; RESTORE COUNT
+ ADD E,(P)
+ MOVE E,(E) ; POINTER TO VECTOR IN E
+ MOVE B,-6(P) ; SAVED OFFSET
+ ADDI E,(B)-1 ; POINT TO SLOT
+ MOVE A,-3(P) ; RESTORE TYPE WORD
+ MOVE B,-2(P)
+ XCT (E) ; SMASH IT BACK
+ JRST TD.LOS
+TD.WIN: MOVE C,-4(P)
+ JRST TD.UP2
+
+TD.LOS: SKIPN GCDFLG
+ FATAL TEMPLATE LOSSAGE
+ JRST TD.WIN
+
+TD.UP1: MOVE A,-7(P) ; RESTORE INS
+ SUB P,[10,,10]
+ MOVSI D,400000 ; RESTORE MARK/UNMARK BIT
+ JRST VHACK1
+
+; FATAL LOSSAGE ARRIVES HERE
+
+BADV: FATAL GC SPACE IN A BAD STATE
+
+; HERE TO HACK SPECIAL CRUFT IN GENERAL VECTORS (STACKS)
+
+EHACK: JUMPE PVP,EHACKX
+ ADDI B,FRAMLN+1 ; SKIP THE FRAME
+ JRST GHACK1
+
+EHACKX: HRRZ D,1(B)
+ CAILE D,HIBOT
+ JRST EHCK10
+ PUSH P,1(B)
+ HRL D,(D)
+ MOVEI C,TVEC
+ CAME A,[PUSHJ P,SBSTIS]
+ XCT A ; XCT SUBSTITUTE
+ POP P,C ; RESTORE TYPE
+ HLLM C,1(B) ; SMASH BACK
+EHCK10: ADDI B,1
+ MOVSI D,-FRAMLN+1 ; SET UP AOBJN PNTR
+
+EHACK1: HRRZ C,ETB(D) ; GET 1ST TYPE
+ PUSH P,D ; SAVE AOBJN
+ MOVE D,1(B) ; GET ITEM
+ CAME A,[PUSHJ P,SBSTIS] ; DONT IF SUBSTITUTE DIFFERENT
+ XCT A ; USER GOODIE
+ POP P,D ; RESTORE AOBJN
+ ADDI B,1 ; MOVE ON
+ SOSLE (P) ; ALSO COUNT IN TOTAL VECTOR
+ AOBJN D,EHACK1
+ AOJA B,GHACK1 ; AND GO ON
+
+; TABLE OF ENTRY BLOCK TYPES
+
+ETB: TTB
+ TAB
+ TSP
+ TPDL
+ TTP
+ TWORD
+
+; HERE TO GROVEL OVER BINDING BLOCKS
+
+BHACK: MOVEI C,TATOM ; ALSO TREEAT AS ATOM
+ MOVE D,1(B)
+ CAME A,[PUSHJ P,SBSTIS] ; DONT IF SUBSTITUTE DIFFERENT
+ XCT A
+ PUSHJ P,NXTGDY ; NEXT GOODIE
+ PUSHJ P,NXTGDY ; AND NEXT
+ MOVEI C,TSP ; TYPE THE BACK LOCATIVE
+ SKIPGE D,1(B)
+ XCT A
+ PUSHJ P,BMP ; AND NEXT
+ PUSH P,B
+ HLRZ D,-2(B) ; DECL POINTER
+ MOVEI B,0 ; MAKE SURE NO CLOBBER
+ MOVEI C,TDECL
+ XCT A ; DO THE THING BEING DONE
+ POP P,B
+ HRLM D,-2(B) ; FIX UP IN CASE CHANGED
+ JRST GHACK1
+
+; HERE TO HACK ATOMS WITH GDECLS
+
+GDHACK: CAMN A,[PUSHJ P,SBSTIS]
+ JRST GDHCK1
+
+ MOVEI C,TATOM ; TREAT LIKE ATOM
+ MOVE D,1(B)
+ XCT A
+ HRRZ D,(B) ; GET DECL
+ JUMPE D,GDHCK1
+ CAIN D,-1 ; WATCH OUT FOR MAINFEST
+ JRST GDHCK1
+ PUSH P,B ; SAVE POINTER
+ MOVEI B,0
+ MOVEI C,TLIST
+ XCT A
+ POP P,B
+ HRRM D,(B) ; RESET
+ JRST GDHCK1
+
+
+; HERE TO HACK ATOMS
+
+ATHACK: JUMPN PVP,BUCKHK ; IF ONLY CHANGING ATOMS, IGNROE OBLIST
+ MOVEI C,TOBLS ; GET TYPE
+ HRRZ D,2(B) ; AND DATUM
+ JUMPE D,BUCKHK ; NOT ON OBLIST, SO FLUSH
+ CAMGE D,VECBOT
+ MOVE D,(D) ; GET REAL OBLIST POINTER
+ HRLI D,-1
+ CAMN A,[PUSHJ P,SBSTIS] ; DONT IF SUBSTITUTE DIFFERENT
+ JRST VHACK1
+ PUSH P,B
+ MOVEI B,0
+ XCT A
+ POP P,B
+ HRRM D,2(B)
+BUCKHK: CAMN A,[PUSHJ P,SBSTIS] ; DONT IF SUBSTITUTE DIFFERENT
+ JRST VHACK1
+ HLRZ D,2(B)
+ JUMPE D,VHACK1
+ PUSH P,B
+ PUSH P,D
+ MOVEI B,-1(P) ; FAKE OUT TO MUNG STACK
+; HLRZ B,1(D)
+; ANDI B,377777
+; SUBI B,2
+; HRLI B,(B)
+; SUB D,B ; D NOW ATOM PNTR
+ MOVEI C,TATOM
+ XCT A
+; HLRE B,D
+; SUB D,B
+ POP P,D
+ POP P,B
+ HRLM D,2(B)
+ JRST VHACK1
+
+; HERE TO HACK ASSOCIATION BLOCKS
+
+ASHACK: MOVEI D,3 ; COUNT GOODIES TO MARK
+
+ASHAK1: PUSH P,D
+ MOVE D,1(B)
+ GETYP C,(B)
+ PUSH P,D ; SAVE POINTER
+ XCT A
+ POP P,D ; GET OLD BACK
+ CAME D,1(B) ; CHANGED?
+ TLO E,400000 ; SET NON-VIRGIN FLAG
+ POP P,D
+ PUSHJ P,BMP ; TO NEXT
+ SOJG D,ASHAK1
+
+; HERE TO GOT TO NEXT VECTOR
+
+VHACK1: MOVE B,-1(P) ; GET POINTER
+ SUB P,[2,,2] ; FLUSH CRUFT
+ SUBI B,2 ; FIX UP PTR
+ POPJ P,
+
+; HERE TO SKIP OVER MARKED VECTOR
+
+MKHAK: SUBI B,(C) ; POINT BELOW VECTOR
+ POPJ P,
+
+; ROUTINE TO GET A GOODIE
+
+NXTGDY: GETYP C,(B)
+NXTGD1: MOVE D,1(B)
+ XCT A ; DO IT TO IT
+BMP: SOS -1(P)
+ SOSG -1(P)
+ JRST BMP1
+ ADDI B,2
+ POPJ P,
+BMP1: SUB P,[1,,1]
+ JRST VHACK1
+
+REHASQ: JUMPL E,REHASH ; HASH TABLE RAPED, FIX IT
+ POPJ P,
+
+
+MFUNCTION SUBSTI,SUBR,[SUBSTITUTE]
+
+;THIS FUNCTION CODED BY NDR IS AN INCREDIBLE WAY TO
+;KILL YOURSELF, EVEN IF YOU THINK YOU REALLY KNOW WHAT
+;YOU ARE DOING.
+;IT DOES A MINI-GC CHANGING EACH REFERENCE OF THE
+;SECOND ITEM TO A REFERENCE OF THE FIRST ITEM, HA HA HA.
+;BOTH ITEMS MUST BE OF THE SAME TYPE OR
+;IF NOT, NEITHER CAN BE A TYPE REQUIRING TWO WORDS
+; OF STORAGE, AND SUBSTITUTION CANT BE DONE IN
+; UVECTORS WHEN THEY ARE DIFFERENT, AS WELL AS IN
+; A FEW OTHER YUCKY PLACES.
+;RETURNS ITEM TWO--THE ONLY WAY TO GET YOUR HANDS BACK ON IT
+
+ ENTRY 2
+
+
+SBSTI1: GETYP A,2(AB)
+ CAIE A,TATOM
+ JRST SBSTI2
+ MOVE B,3(AB) ; IMPURIFY HASH BUCKET MAYBE?
+ PUSHJ P,IMPURI
+ GETYP A,(AB) ; ATOM FOR ATOM SUBS?
+ CAIE A,TATOM
+ JRST SBSTI2 ; NO
+ MOVE B,3(AB) ; SEE IF OLD GUY
+ HLRE A,B
+ SUBM B,A ; POINT TO DOPE
+ HRRZ A,(A) ; POSSIBLE TYPE CODE
+ JUMPE A,SBSTI2 ; NOT A TYPE, GO
+ MOVE B,1(AB)
+ HLRE C,B
+ SUBM B,C
+ HRRZ C,(C) ; GET OTHER POSSIBLE CODE
+ JUMPN C,BADTYP
+ PUSH P,A
+ PUSHJ P,IMPURI ; IMPURIFY FOR SMASH
+ POP P,A
+ MOVE B,1(AB)
+ HLRE C,B
+ SUBM B,C
+ HRRM A,(C)
+
+SBSTI2: GETYP A,2(AB) ; GET TYPE OF SECOND ARG
+ MOVE D,A
+ PUSHJ P,NWORDT ; AND STORAGE ALLOCATION
+ MOVE E,A
+ GETYP A,(AB) ; GET TYPE OF FIRST ARG
+ MOVE B,A
+ PUSHJ P,NWORDT
+ CAMN B,D ; IF TYPES SAME, DONT CHECK FOR ALLOCATION
+ JRST SBSTI3
+ CAIN E,1
+ CAIE A,1
+ JRST SBSTIL ; LOOSE, NOT BOTH ONE WORD GOODIES
+
+SBSTI3: MOVEI C,0
+ CAIN D,0 ; IF GOODIE IS OF TYPE ZERO
+ MOVEI C,1 ; USE TYPE 1 TO KEEP INFO FROM CLOBBERAGE
+ PUSH TP,C
+ SUBI E,1
+ PUSH TP,E ; 1=DEFERRED TYPE ITEM, 0=ELSE
+ PUSH TP,C
+ PUSH TP,D ; TYPE OF GOODIE
+ PUSH TP,C
+ PUSH TP,[0]
+ CAIN D,TLIST
+ AOS (TP) ; 1=TYPE LIST, 0=ELSE
+ PUSH TP,C
+ PUSH TP,2(AB) ; TYPE-WORD
+ PUSH TP,C
+ PUSH TP,3(AB) ; VALUE-WORD
+ PUSH TP,(AB)
+ PUSH TP,1(AB) ; TYPE-VALUE OF THINGS TO CHANGE INTO
+ MOVE A,[PUSHJ P,SBSTIR]
+ CAME B,D ; IF NOT SAME TYPE, USE DIFF MUNGER
+ MOVE A,[PUSHJ P,SBSTIS]
+ MOVEI PVP,0 ; INDICATE NOT SPECIAL ATOM THING
+ PUSHJ P,GCHACK ; DO-IT
+ MOVE A,-4(TP)
+ MOVE B,-2(TP)
+ JRST FINIS ; GIVE THE LOOSER A HANDLE ON HIS GOODIE
+
+SBSTIR: CAME D,-2(TP)
+ JRST LSUB ; THIS IS IT
+ CAME C,-10(TP)
+ JRST LSUB ; IF ITEM CANT BE SAME CHECK FOR LISTAGE
+ JUMPE B,LSUB+1 ; WE GOT HOLD OF A FUNNY GOODIE, JUST IGNORE IT
+ MOVE 0,(TP)
+ MOVEM 0,1(B) ; SMASH IT
+ MOVE 0,-1(TP) ; GET TYPE WORD
+ SKIPE -12(TP) ; IF THIS IS A DEFFERABLE ITEM THEN WE MUST
+ MOVEM 0,(B) ; ALSO SMASH THE TYPE WORD SLOT
+
+LSUB: SKIPN -6(TP) ; IF WE ARE LOOKING FOR LISTS, LOOK ON
+ POPJ P, ; ELSE THATS ALL
+ TLNN B,.LIST. ; SEE IF A LIST
+ POPJ P, ; WELL NO LIST SMASHING THIS TIME
+ HRRZ 0,(B) ; GET ITS LIST POINTER
+ CAME 0,-2(TP)
+ POPJ P, ; THIS ONE DIDNT MATCH
+ MOVE 0,(TP) ; GET THE NEW REST OF THE LIST
+ HRRM 0,(B) ; AND SMASH INTO THE REST OF THE LIST
+ POPJ P,
+
+SBSTIS: CAMN D,-2(TP)
+ CAME C,-10(TP)
+ POPJ P,
+ SKIPN B ; SEE IF THIS IS A FUNNY GOODIE WE NO TOUCHIE
+ POPJ P,
+ MOVE 0,(TP)
+ MOVEM 0,1(B) ; KLOBBER VALUE CELL
+ MOVE 0,-1(TP)
+ HLLM 0,(B) ; KLOBBER TYPE CELL, WHICH WE KNOW IS THERE
+ POPJ P,
+
+SBSTIL: ERRUUO EQUOTE CANT-SUBSTITUTE-WITH-STRING-OR-TUPLE-AND-OTHER
+BADTYP: ERRUUO EQUOTE SUBSTITUTE-TYPE-FOR-TYPE
+
+GHSTUP: HRRZ E,TYPVEC+1 ; SET UP TYPE POINTER
+ HRLI E,C ; WILL HAVE TYPE CODE IN C
+ SETOM 1(TP) ; FENCE POST PDL
+ PUSH P,A
+ MOVEI A,(TB)
+ PUSHJ P,FRMUNG ; MUNG CURRENT FRAME
+ POP P,A
+ POPJ P,
+
+
+IMPURE
+
+; LOCATION TO REMEMBER PREVIOUS VALUES
+
+SVTAB: SVLOC1
+NXTTAB: SVLOC2
+
+SVLOC1: 0
+SVLOC2: 0
+
+PURE
+
+END
+
+\f\ 3
\ No newline at end of file
--- /dev/null
+
+TITLE GCHACK
+
+RELOCATABLE
+
+.INSRT MUDDLE >
+
+.GLOBAL FRMUNG,PARBOT,TYPVEC,GCHACK,REHASH,IMPURI,NWORDT,GCDFLG
+.GLOBAL TD.LNT,TD.GET,TD.PUT,GCSTOP,GCSBOT,GCHK10,STOSTR,UBIT,PVSTOR,SPSTOR
+
+UBIT==40000 ; BIT INDICATING VECTOR
+.LIST.==400000
+
+; THIS IS AN INTERNAL MUDDLE SUBROUTINE TO RUN AROUND GC SPACE DOING
+; SOMETHING ARBITRARY TO EVERY ENTITY THEREIN
+
+; CALL --
+; A/ INSTRUCTION TO BE EXECUTED
+; PVP/ NON-ZERO OPTIMIZE--ONLY LOOK AT ATOMS
+; PUSHJ P,GCHACK
+
+; HERE FOR SPECIAL HACKS WHICH DON'T TOUCH STOAGE
+
+GCHK10: PUSHJ P,GHSTUP
+ JRST GCHK1
+
+GCHACK: PUSHJ P,GHSTUP ; SETUP
+ MOVE B,CODTOP ; START OFF WITH IMPURE STORAGE
+ SUBI B,1 ; START AT FIRST WORD
+LOPSTO: CAIG B,STOSTR
+ JRST GCHK1
+ HRRE 0,1(B) ; GET INDICATOR OF MODIFICATION
+ JUMPGE 0,LOSTO ; JUMP IF GARBAGE
+ PUSHJ P,VHACK ; VHACK
+ JRST LOPSTO
+LOSTO: HLRZ C,1(B) ; BACK OF VECTOR
+ TRZ C,400000
+ SUBI B,(C) ; SKIP OVER VECTOR
+ JRST LOPSTO
+
+GCHK1: MOVE B,VECTOP ; NO LOOP THRU GCS
+ MOVEI B,-2(B)
+
+
+LOOPHK: MOVE C,SVTAB
+ MOVEM B,(C)
+ EXCH C,NXTTAB ; SWAP LOCATIONS
+ EXCH C,SVTAB
+ TLZ B,.LIST. ; TURN OFF LIST BIT
+ CAMGE B,GCSBOT ; SEE IF DONE
+ JRST REHASQ ; SEE IF ASSOCIATIONS ARE GOOD
+ MOVE C,(B) ; GET ELEMENT
+ TLNE C,.VECT. ; SEE IF IT IS A VECTOR
+ JRST VHCK ; JUMP IF IT IS
+GLSTHK: GETYP C,(B) ; TYPE OF CURRENT PAIR
+ MOVE D,1(B) ; AND ITS DATUM
+ TLO B,.LIST. ; INDICATE A LIST
+ SKIPL (B) ; SKIP IF MARKED
+ XCT A ; APPLY INS
+ SUBI B,2
+ JRST LOOPHK
+VHCK: PUSHJ P,VHACK ; TO VHACK
+ JRST LOOPHK
+
+; NOW DO THE SAME THING TO VECTOR SPACE
+VHACK: HLRE D,(B) ; GET TYPE FROM D.W.
+ TRZ D,.VECT. ; GET RID OF VECTOR INDICATION BIT
+ HLRZ C,1(B) ; AND TOTAL LENGTH
+ TRZE C,400000 ; GET RID OF POSSIBLE MARK BIT
+ JRST MKHAK ; JUMP IF MARKED
+ SUBI B,(C)-2 ; POINT TO START OF VECTOR
+ PUSH P,B
+ SUBI C,2 ; CHECK WINNAGE
+ JUMPL C,BADV ; FATAL LOSSAGE
+ PUSH P,C ; SAVE COUNT
+ JUMPE C,VHACK1 ; EMPTY VECTOR, FINISHED
+
+; DECIDE BASED ON TYPE WHETHER GENERAL,UNIFORM OR SPECIAL
+
+ JUMPGE D,UHACK ; UNIFORM
+ TRNE D,377777 ; SKIP IF GENERAL
+ JRST SHACK ; SPECIAL
+
+; FALL THROUGH TO GENERAL
+
+GHACK1: SKIPGE (B) ; CHECK FOR FENCE POST
+ JRST VHACK1
+ GETYP C,(B) ; LOOK A T 1ST ELEMENT
+ CAIE C,TCBLK
+ CAIN C,TENTRY ; FRAME ON STACK
+ SOJA B,EHACK
+ CAIE C,TUBIND
+ CAIN C,TBIND ; BINDING BLOCK
+ JRST BHACK
+ CAIN C,TGATOM ; ATOM WITH GDECL?
+ JRST GDHACK
+ MOVE D,1(B) ; GET DATUM
+ XCT A ; USER INS
+GDHCK1: ADDI B,2 ; NEXT ELEMENT
+ SOS (P)
+ SOSLE (P) ; COUNT ELEMENTS
+ SKIPGE (B) ; OR FENCE POST HIT
+ JRST VHACK1
+ JRST GHACK1
+
+; HERE TO GO OVER UVECTORS
+
+UHACK: CAMN A,[PUSHJ P,SBSTIS]
+ JRST VHACK1 ; IF THIS SUBSTITUTE, DONT DO UVEC
+ MOVEI C,(D) ; COPY UNIFORM TYPE
+ JUMPE PVP,UHACKX ; JUMP IF NOT ONLY ATOMS
+ ASH C,1 ; COMPUTE SAT
+ ADD C,TYPVEC+1
+ HRRZ C,(C)
+ ANDI C,SATMSK ; GOT ITS SAT
+ CAIE C,SCHSTR ; COULD BE SPNAME
+ JRST .+3
+ CAIE C,SATOM ; DON'T BOTHER IF NOT ALL ATOMS
+ JRST VHACK1
+ MOVEI C,(D)
+UHACKX: PUSH P,C ; ATFIX CLOBBERS C
+ SUBI B,1 ; BACK OFF
+
+UHACK1: MOVE C,(P)
+ TLO B,UBIT ; TURN ON BIT INDICATING UVECTOR
+ MOVE D,1(B) ; DATUM
+ XCT A
+ SOSLE -1(P) ; COUNT DOEN
+ AOJA B,UHACK1
+ TLZ UBIT
+ POP P,C
+ JRST VHACK1
+
+; HERE TO HACK VARIOUS FLAVORS OF SPECIAL GOODIES
+
+SHACK: ANDI D,377777 ; KILL EXTRA CRUFT
+ CAIN D,SATOM
+ JRST ATHACK
+ CAIE D,STPSTK ; STACK OR
+ CAIN D,SPVP ; PROCESS
+ JRST GHACK1 ; TREAT LIKE GENERAL
+ CAIN D,SASOC ; ASSOCATION
+ JRST ASHACK
+ CAIG D,NUMSAT ; TEMPLATE MAYBE?
+ JRST BADV ; NO CHANCE
+ ADDI C,(B) ; POINT TO DOPE WORDS
+ SUBI D,NUMSAT+1
+ HRLI D,(D)
+ ADD D,TD.LNT+1
+ JUMPGE D,BADV ; JUMP IF INVALID TEMPLATE HACKER
+
+ CAMN A,[PUSHJ P,SBSTIS]
+ JRST VHACK1
+
+TD.UPD: PUSH P,A ; INS TO EXECUTE
+ XCT (D)
+ HLRZ E,B ; POSSIBLE BASIC LENGTH
+ PUSH P,[0]
+ PUSH P,E
+ MOVEI B,(B) ; ISOLATE LENGTH
+ PUSH P,C ; SAVE POINTER TO OBJECT
+
+ PUSH P,[0] ; HOME FOR VALUES
+ PUSH P,[0] ; SLOT FOR TEMP
+ PUSH P,B ; SAVE
+ SUB D,TD.LNT+1
+ PUSH P,D ; SAVE FOR FINDING OTHER TABLES
+ JUMPE E,TD.UP2 ; NO REPEATING SEQ
+ ADD D,TD.GET+1 ; COMP LNTH OF REPEATING SEQ
+ HLRE D,(D) ; D ==> - LNTH OF TEMPLATE
+ ADDI D,(E) ; D ==> -LENGTH OF REP SEQ
+ MOVNS D
+ HRLM D,-5(P) ; SAVE IT AND BASIC
+
+TD.UP2: SKIPG D,-1(P) ; ANY LEFT?
+ JRST TD.UP1
+
+ 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.UP3
+
+ 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.UP3: ADDI E,(D) ; POINT TO SLOT
+ XCT (E) ; GET THIS ELEMENT INTO A AND B
+ TLO A,UBIT ; INDICATE ITS A ANY
+ MOVEM A,-3(P) ; SAVE TYPE FOR LATER PUT
+ MOVEM B,-2(P)
+ GETYP C,A ; TYPE TO C
+ MOVE D,B ; DATUME
+ MOVEI B,-3(P) ; POINTER TO HOME
+ MOVE A,-7(P) ; GET INS
+ XCT A ; AND DO IT
+ MOVE C,-4(P) ; GET POINTER FOR UPDATE OF ELEMENT
+ MOVE E,TD.PUT+1
+ SOS D,-1(P) ; RESTORE COUNT
+ ADD E,(P)
+ MOVE E,(E) ; POINTER TO VECTOR IN E
+ MOVE B,-6(P) ; SAVED OFFSET
+ ADDI E,(B)-1 ; POINT TO SLOT
+ MOVE A,-3(P) ; RESTORE TYPE WORD
+ MOVE B,-2(P)
+ XCT (E) ; SMASH IT BACK
+ JRST TD.LOS
+TD.WIN: MOVE C,-4(P)
+ JRST TD.UP2
+
+TD.LOS: SKIPN GCDFLG
+ FATAL TEMPLATE LOSSAGE
+ JRST TD.WIN
+
+TD.UP1: MOVE A,-7(P) ; RESTORE INS
+ SUB P,[10,,10]
+ MOVSI D,400000 ; RESTORE MARK/UNMARK BIT
+ JRST VHACK1
+
+; FATAL LOSSAGE ARRIVES HERE
+
+BADV: FATAL GC SPACE IN A BAD STATE
+
+; HERE TO HACK SPECIAL CRUFT IN GENERAL VECTORS (STACKS)
+
+EHACK: JUMPE PVP,EHACKX
+ ADDI B,FRAMLN+1 ; SKIP THE FRAME
+ JRST GHACK1
+
+EHACKX: HRRZ D,1(B)
+ CAILE D,HIBOT
+ JRST EHCK10
+ PUSH P,1(B)
+ HRL D,(D)
+ MOVEI C,TVEC
+ CAME A,[PUSHJ P,SBSTIS]
+ XCT A ; XCT SUBSTITUTE
+ POP P,C ; RESTORE TYPE
+ HLLM C,1(B) ; SMASH BACK
+EHCK10: ADDI B,1
+ MOVSI D,-FRAMLN+1 ; SET UP AOBJN PNTR
+
+EHACK1: HRRZ C,ETB(D) ; GET 1ST TYPE
+ PUSH P,D ; SAVE AOBJN
+ MOVE D,1(B) ; GET ITEM
+ CAME A,[PUSHJ P,SBSTIS] ; DONT IF SUBSTITUTE DIFFERENT
+ XCT A ; USER GOODIE
+ POP P,D ; RESTORE AOBJN
+ ADDI B,1 ; MOVE ON
+ SOSLE (P) ; ALSO COUNT IN TOTAL VECTOR
+ AOBJN D,EHACK1
+ AOJA B,GHACK1 ; AND GO ON
+
+; TABLE OF ENTRY BLOCK TYPES
+
+ETB: TTB
+ TAB
+ TSP
+ TPDL
+ TTP
+ TWORD
+
+; HERE TO GROVEL OVER BINDING BLOCKS
+
+BHACK: MOVEI C,TATOM ; ALSO TREEAT AS ATOM
+ MOVE D,1(B)
+ CAME A,[PUSHJ P,SBSTIS] ; DONT IF SUBSTITUTE DIFFERENT
+ XCT A
+ PUSHJ P,NXTGDY ; NEXT GOODIE
+ PUSHJ P,NXTGDY ; AND NEXT
+ MOVEI C,TSP ; TYPE THE BACK LOCATIVE
+ SKIPGE D,1(B)
+ XCT A
+ PUSHJ P,BMP ; AND NEXT
+ PUSH P,B
+ HLRZ D,-2(B) ; DECL POINTER
+ MOVEI B,0 ; MAKE SURE NO CLOBBER
+ MOVEI C,TDECL
+ XCT A ; DO THE THING BEING DONE
+ POP P,B
+ HRLM D,-2(B) ; FIX UP IN CASE CHANGED
+ JRST GHACK1
+
+; HERE TO HACK ATOMS WITH GDECLS
+
+GDHACK: CAMN A,[PUSHJ P,SBSTIS]
+ JRST GDHCK1
+
+ MOVEI C,TATOM ; TREAT LIKE ATOM
+ MOVE D,1(B)
+ XCT A
+ HRRZ D,(B) ; GET DECL
+ JUMPE D,GDHCK1
+ CAIN D,-1 ; WATCH OUT FOR MAINFEST
+ JRST GDHCK1
+ PUSH P,B ; SAVE POINTER
+ MOVEI B,0
+ MOVEI C,TLIST
+ XCT A
+ POP P,B
+ HRRM D,(B) ; RESET
+ JRST GDHCK1
+
+
+; HERE TO HACK ATOMS
+
+ATHACK: JUMPN PVP,BUCKHK ; IF ONLY CHANGING ATOMS, IGNROE OBLIST
+ MOVEI C,TOBLS ; GET TYPE
+ HRRZ D,2(B) ; AND DATUM
+ JUMPE D,BUCKHK ; NOT ON OBLIST, SO FLUSH
+ CAMGE D,VECBOT
+ MOVE D,(D) ; GET REAL OBLIST POINTER
+ HRLI D,-1
+ CAMN A,[PUSHJ P,SBSTIS] ; DONT IF SUBSTITUTE DIFFERENT
+ JRST VHACK1
+ PUSH P,B
+ MOVEI B,0
+ XCT A
+ POP P,B
+ HRRM D,2(B)
+BUCKHK: CAMN A,[PUSHJ P,SBSTIS] ; DONT IF SUBSTITUTE DIFFERENT
+ JRST VHACK1
+ HLRZ D,2(B)
+ JUMPE D,VHACK1
+ PUSH P,B
+ PUSH P,D
+ MOVEI B,-1(P) ; FAKE OUT TO MUNG STACK
+; HLRZ B,1(D)
+; ANDI B,377777
+; SUBI B,2
+; HRLI B,(B)
+; SUB D,B ; D NOW ATOM PNTR
+ MOVEI C,TATOM
+ XCT A
+; HLRE B,D
+; SUB D,B
+ POP P,D
+ POP P,B
+ HRLM D,2(B)
+ JRST VHACK1
+
+; HERE TO HACK ASSOCIATION BLOCKS
+
+ASHACK: MOVEI D,3 ; COUNT GOODIES TO MARK
+
+ASHAK1: PUSH P,D
+ MOVE D,1(B)
+ GETYP C,(B)
+ PUSH P,D ; SAVE POINTER
+ XCT A
+ POP P,D ; GET OLD BACK
+ CAME D,1(B) ; CHANGED?
+ TLO E,400000 ; SET NON-VIRGIN FLAG
+ POP P,D
+ PUSHJ P,BMP ; TO NEXT
+ SOJG D,ASHAK1
+
+; HERE TO GOT TO NEXT VECTOR
+
+VHACK1: MOVE B,-1(P) ; GET POINTER
+ SUB P,[2,,2] ; FLUSH CRUFT
+ SUBI B,2 ; FIX UP PTR
+ POPJ P,
+
+; HERE TO SKIP OVER MARKED VECTOR
+
+MKHAK: SUBI B,(C) ; POINT BELOW VECTOR
+ POPJ P,
+
+; ROUTINE TO GET A GOODIE
+
+NXTGDY: GETYP C,(B)
+NXTGD1: MOVE D,1(B)
+ XCT A ; DO IT TO IT
+BMP: SOS -1(P)
+ SOSG -1(P)
+ JRST BMP1
+ ADDI B,2
+ POPJ P,
+BMP1: SUB P,[1,,1]
+ JRST VHACK1
+
+REHASQ: JUMPL E,REHASH ; HASH TABLE RAPED, FIX IT
+ POPJ P,
+
+
+MFUNCTION SUBSTI,SUBR,[SUBSTITUTE]
+
+;THIS FUNCTION CODED BY NDR IS AN INCREDIBLE WAY TO
+;KILL YOURSELF, EVEN IF YOU THINK YOU REALLY KNOW WHAT
+;YOU ARE DOING.
+;IT DOES A MINI-GC CHANGING EACH REFERENCE OF THE
+;SECOND ITEM TO A REFERENCE OF THE FIRST ITEM, HA HA HA.
+;BOTH ITEMS MUST BE OF THE SAME TYPE OR
+;IF NOT, NEITHER CAN BE A TYPE REQUIRING TWO WORDS
+; OF STORAGE, AND SUBSTITUTION CANT BE DONE IN
+; UVECTORS WHEN THEY ARE DIFFERENT, AS WELL AS IN
+; A FEW OTHER YUCKY PLACES.
+;RETURNS ITEM TWO--THE ONLY WAY TO GET YOUR HANDS BACK ON IT
+
+ ENTRY 2
+
+
+SBSTI1: GETYP A,2(AB)
+ CAIE A,TATOM
+ JRST SBSTI2
+ MOVE B,3(AB) ; IMPURIFY HASH BUCKET MAYBE?
+ PUSHJ P,IMPURI
+ GETYP A,(AB) ; ATOM FOR ATOM SUBS?
+ CAIE A,TATOM
+ JRST SBSTI2 ; NO
+ MOVE B,3(AB) ; SEE IF OLD GUY
+ HLRE A,B
+ SUBM B,A ; POINT TO DOPE
+ HRRZ A,(A) ; POSSIBLE TYPE CODE
+ JUMPE A,SBSTI2 ; NOT A TYPE, GO
+ MOVE B,1(AB)
+ HLRE C,B
+ SUBM B,C
+ HRRZ C,(C) ; GET OTHER POSSIBLE CODE
+ JUMPN C,BADTYP
+ PUSH P,A
+ PUSHJ P,IMPURI ; IMPURIFY FOR SMASH
+ POP P,A
+ MOVE B,1(AB)
+ HLRE C,B
+ SUBM B,C
+ HRRM A,(C)
+
+SBSTI2: GETYP A,2(AB) ; GET TYPE OF SECOND ARG
+ MOVE D,A
+ PUSHJ P,NWORDT ; AND STORAGE ALLOCATION
+ MOVE E,A
+ GETYP A,(AB) ; GET TYPE OF FIRST ARG
+ MOVE B,A
+ PUSHJ P,NWORDT
+ CAMN B,D ; IF TYPES SAME, DONT CHECK FOR ALLOCATION
+ JRST SBSTI3
+ CAIN E,1
+ CAIE A,1
+ JRST SBSTIL ; LOOSE, NOT BOTH ONE WORD GOODIES
+
+SBSTI3: MOVEI C,0
+ CAIN D,0 ; IF GOODIE IS OF TYPE ZERO
+ MOVEI C,1 ; USE TYPE 1 TO KEEP INFO FROM CLOBBERAGE
+ PUSH TP,C
+ SUBI E,1
+ PUSH TP,E ; 1=DEFERRED TYPE ITEM, 0=ELSE
+ PUSH TP,C
+ PUSH TP,D ; TYPE OF GOODIE
+ PUSH TP,C
+ PUSH TP,[0]
+ CAIN D,TLIST
+ AOS (TP) ; 1=TYPE LIST, 0=ELSE
+ PUSH TP,C
+ PUSH TP,2(AB) ; TYPE-WORD
+ PUSH TP,C
+ PUSH TP,3(AB) ; VALUE-WORD
+ PUSH TP,(AB)
+ PUSH TP,1(AB) ; TYPE-VALUE OF THINGS TO CHANGE INTO
+ MOVE A,[PUSHJ P,SBSTIR]
+ CAME B,D ; IF NOT SAME TYPE, USE DIFF MUNGER
+ MOVE A,[PUSHJ P,SBSTIS]
+ MOVEI PVP,0 ; INDICATE NOT SPECIAL ATOM THING
+ PUSHJ P,GCHACK ; DO-IT
+ MOVE A,-4(TP)
+ MOVE B,-2(TP)
+ JRST FINIS ; GIVE THE LOOSER A HANDLE ON HIS GOODIE
+
+SBSTIR: CAME D,-2(TP)
+ JRST LSUB ; THIS IS IT
+ CAME C,-10(TP)
+ JRST LSUB ; IF ITEM CANT BE SAME CHECK FOR LISTAGE
+ JUMPE B,LSUB+1 ; WE GOT HOLD OF A FUNNY GOODIE, JUST IGNORE IT
+ MOVE 0,(TP)
+ MOVEM 0,1(B) ; SMASH IT
+ MOVE 0,-1(TP) ; GET TYPE WORD
+ SKIPE -12(TP) ; IF THIS IS A DEFFERABLE ITEM THEN WE MUST
+ MOVEM 0,(B) ; ALSO SMASH THE TYPE WORD SLOT
+
+LSUB: SKIPN -6(TP) ; IF WE ARE LOOKING FOR LISTS, LOOK ON
+ POPJ P, ; ELSE THATS ALL
+ TLNN B,.LIST. ; SEE IF A LIST
+ POPJ P, ; WELL NO LIST SMASHING THIS TIME
+ HRRZ 0,(B) ; GET ITS LIST POINTER
+ CAME 0,-2(TP)
+ POPJ P, ; THIS ONE DIDNT MATCH
+ MOVE 0,(TP) ; GET THE NEW REST OF THE LIST
+ HRRM 0,(B) ; AND SMASH INTO THE REST OF THE LIST
+ POPJ P,
+
+SBSTIS: CAMN D,-2(TP)
+ CAME C,-10(TP)
+ POPJ P,
+ SKIPN B ; SEE IF THIS IS A FUNNY GOODIE WE NO TOUCHIE
+ POPJ P,
+ MOVE 0,(TP)
+ MOVEM 0,1(B) ; KLOBBER VALUE CELL
+ MOVE 0,-1(TP)
+ HLLM 0,(B) ; KLOBBER TYPE CELL, WHICH WE KNOW IS THERE
+ POPJ P,
+
+SBSTIL: ERRUUO EQUOTE CANT-SUBSTITUTE-WITH-STRING-OR-TUPLE-AND-OTHER
+BADTYP: ERRUUO EQUOTE SUBSTITUTE-TYPE-FOR-TYPE
+
+GHSTUP: HRRZ E,TYPVEC+1 ; SET UP TYPE POINTER
+ HRLI E,C ; WILL HAVE TYPE CODE IN C
+ SETOM 1(TP) ; FENCE POST PDL
+ PUSH P,A
+ MOVEI A,(TB)
+ PUSHJ P,FRMUNG ; MUNG CURRENT FRAME
+ POP P,A
+ POPJ P,
+
+
+IMPURE
+
+; LOCATION TO REMEMBER PREVIOUS VALUES
+
+SVTAB: SVLOC1
+NXTTAB: SVLOC2
+
+SVLOC1: 0
+SVLOC2: 0
+
+PURE
+
+END
+
+\f
\ No newline at end of file
--- /dev/null
+TITLE INITIALIZATION FOR MUDDLE
+
+RELOCATABLE
+
+HTVLNT==3000 ; GUESS OF TVP LENGTH
+
+LAST==1 ;POSSIBLE CHECKS DONE LATER
+
+.INSRT MUDDLE >
+
+SYSQ
+XBLT==123000,,
+GCHN==0
+IFE ITS,[
+FATINS==.FATAL"
+SEVEC==104000,,204
+.INSRT STENEX >
+]
+
+IMPURE
+
+OBSIZE==151. ;DEFAULT OBLIST SIZE
+
+.LIFG <TVBASE+TVLNT-TVLOC>
+.LOP .VALUE
+.ELDC
+
+.GLOBAL SHRRM,SHRLM,SMOVEM,SSETZM,SXBLT,SHLRZ
+.GLOBAL SETUP,TPBAS,GCPDL,GCPVP,PVBASE,PVLNT,PARNEW,AAGC,ICR,SWAP,OBLNT,MSGTYP,POPUNW
+.GLOBAL ICLOS,OCLOS,GLOBASE,GLOBSP,PARBOT,PARTOP,CODTOP,START,BEGIN,VECBOT,VECTOP,TPBASE
+.GLOBAL LISTEN,ROOT,INITIAL,TBINIT,TOPLEV,INTOBL,ERROBL,MUDOBL,TTYOPE,RESFUN,QUITTER
+.GLOBAL IOINS,BUFRIN,IOIN2,ECHO,MTYI,MTYO,IMTYO,MUDSTR,P.TOP,TTICHN,TTOCHN,TYPVEC,SQDIR
+.GLOBAL PDLBUF,PHIBOT,%UNAM,PURVEC,STOSTR,ISTOST,TD.LNT,TD.PUT,TD.GET,CAFRE1
+.GLOBAL FRETOP,LPUR,SQBLK,REALGC,INTDIR,AGCLD,PAGEGC,TD.AGC,TVSTRT,REALTV,PVSTOR
+.GLOBAL GCSTOP,SPSTOR,DSTORE,SQBYTE,INBYTE,GCBYTE,FRSTCH,OPSYS,IJFNS,GETJS
+.GLOBAL HASHTB,ILOOKC
+
+LPUR==.LPUR ; SET UP SO LPUR WORKS
+
+; INIITAL AMOUNT OF AFREE SPACE
+
+STOSTR:
+LOC TVSTRT-1
+ISTOST: TVSTRT-STOSTR,,0
+
+ BLOCK HTVLNT ; TVP
+
+SETUP: MOVEI 0,0 ; ZERO ACS
+ MOVEI 17,1
+ BLT 17,17
+
+IFN ITS, .SUSET [.RUNAM,,%UNAM] ; FOR AGC'S BENFIT
+ MOVE P,GCPDL ;GET A PUSH DOWN STACK
+IFN ITS, .SUSET [.SMASK,,[200000]] ; ENABLE PDL OVFL
+ MOVE 0,[TVBASE,,TVSTRT]
+ BLT 0,TVSTRT+HTVLNT-3 ; BLT OVER TVP
+IFE ITS, PUSHJ P,TWENTY ; FIND OUT WHETHER IT IS TOPS20 OR NOT
+ PUSHJ P,TTYOPE ;OPEN THE TTY
+ AOS A,20 ; TOP OF LOW SEGG
+ HRRZM A,P.TOP
+ SOSN A ; IF NOTHING YET
+IFN ITS, .SUSET [.RMEMT,,P.TOP]
+IFE ITS, JRST 4,
+ MOVE A,P.TOP
+ SUB A,FRETOP ; SETUP FOR GETTING NEEDED CORE
+ SUBI A,3777
+ ASH A,-10. ; TO PAGES
+ HRLS A ; SET UP AOBJN
+ HRRZ 0,P.TOP
+ ASH 0,-10.
+ SUBI 0,1
+ HRR A,0
+IFN ITS,[
+ .CALL HIGET ; GET THEM
+ FATAL INITM--CORE NOT AVAILABLE FOR INITIALIZATION
+ ASH A,10. ; TO WORDS
+ MOVEM A,P.TOP
+ SUBI A,2000 ; WHERE FRETOP IS
+ MOVEM A,FRETOP
+
+]
+IFE ITS,[
+ MOVE A,FRETOP
+ ADDI A,2000
+ MOVEM A,P.TOP
+]
+ HRRE A,P.TOP ; CHECK TOP
+ TRNE A,377777 ; SKIP IF ALL LOW SEG
+ JUMPL A,PAGLOS ; COMPLAIN
+ MOVE A,HITOP ; FIND HI SEG TOP
+ ADDI A,1777
+ ANDCMI A,1777
+ MOVEM A,RHITOP ; SAVE IT
+ MOVEI A,200
+ SUBI A,PHIBOT
+ JUMPE A,HIBOK
+ MOVSI A,(A)
+ HRRI A,200
+IFN ITS,[
+ .CALL GIVCOR
+ .VALUE
+]
+HIBOK: MOVEI B,[ASCIZ /MUDDLE INITIALIZATION.
+/]
+ PUSHJ P,MSGTYP ;PRINT IT
+ MOVE A,CODTOP ;CHECK FOR A WINNING LOAD
+ CAML A,VECBOT ;IT BETTER BE LESS
+ JRST DEATH1 ;LOSE COMPLETELY
+SETTV: MOVE PVP,[-PVLNT*2,,GCPVP] ;AND A PROCESS VECTOR
+ MOVEM PVP,PVSTOR+1
+ MOVEM PVP,PVSTOR+1-TVSTRT+TVBASE
+ MOVEI A,(PVP) ;SET UP A BLT
+ HRLI A,PVBASE ;FROM PROTOTYPE
+ BLT A,PVLNT*2-1(PVP) ;INITIALIZE
+ MOVE TP,[-ITPLNT,,TPBAS] ;GET A STACK FOR THIS PROCCESS
+ MOVEI TB,(TP) ;AND A BASE
+IFN ITS, HRLI TB,1
+IFE ITS, HRLI TB,400001 ; FOR MULTI SEG HACKING
+ SUB TP,[1,,1] ;POP ONCE
+
+; FIRST BUILD MOBY HASH TABLE
+
+ MOVEI A,1023. ; TRY THIS OUT FOR SIZE
+ PUSHJ P,IBLOCK
+ MOVEM B,HASHTB+1-TVSTRT+TVBASE ; STORE IN TVP POINTER
+ HLRE A,B
+ SUB B,A
+ MOVEI A,TATOM+.VECT.
+ HRLM A,(B)
+
+; ALLOCATE SOME OBLISTS FOR INITIAL ATOMS
+
+ PUSH P,[5] ;COUNT INITIAL OBLISTS
+
+ PUSH P,OBLNT ;SAVE CURRENT OBLIST DEFAULT SIZE
+
+MAKEOB: SOS A,-1(P)
+ MOVE A,OBSZ(A)
+ MOVEM A,OBLNT
+ MCALL 0,MOBLIST ;GOBBLE AN OBLIST
+ PUSH TP,$TOBLS ;AND SAVE THEM
+ PUSH TP,B
+ MOVE A,(P)-1 ;COUNT DOWN
+ MOVEM B,@OBTBL(A) ;STORE
+ JUMPN A,MAKEOB
+
+ POP P,OBLNT ;RESTORE DEFAULT OBLIST SIZE
+
+ MOVE C,[-TVLNT+2,,TVBASE]
+ MOVE D,[-HTVLNT+2,,TVSTRT]
+
+;MAIN INITIALIZE LOOP - SCAN XFER VECTOR FOR ATOMS, UPDATE
+;OFFSETS IN CODE, UNIQUIFY ATOMS AND COMPACT XFER VECTOR
+
+ILOOP: HLRZ A,(C) ;FIRST TYPE
+ JUMPE A,TVEXAU ;USEFUL STUFF EXHAUSTED
+ CAIN A,TCHSTR ;CHARACTER STRING?
+ JRST CHACK ;YES, GO HACK IT
+ CAIN A,TATOM ;ATOM?
+ JRST ATOMHK ;YES, CHECK IT OUT
+ MOVE A,(C) ;MOVE TO NEW HOME (MAY BE SAME)
+ MOVEM A,(D)
+ MOVE A,1(C)
+ MOVEM A,1(D)
+SETLP: AOS (P) ;COUNT NUMBER OF PAIRS IN XFER VECTOR
+ ADD D,[2,,2] ;OUT COUNTER
+SETLP1: ADD C,[2,,2] ;AND IN COUNTER
+ JUMPL C,ILOOP ;JUMP IF MORE TO DO
+\f
+;NEW XFER VECTOR FINISHED, NOW GIVE AWAY THE REST
+
+TVEXAU: HLRE B,D ; LEFT HALF OF AOBJN
+ MOVNI TVP,HTVLNT-2 ; CALCULATE LENGTH OF TVP
+ SUB TVP,B ; GET -LENGTH OF TVP IN TVP
+ HRLS TVP
+ HRRI TVP,TVSTRT ; BUILD A TASTEFUL TVP POINTER
+ MOVNI C,TVLNT-HTVLNT+2(B) ; SMASH IN LENGTH INTO END DOPE WORDS
+ HRLM C,TVSTRT+HTVLNT-1
+ MOVSI E,400000
+ MOVEM E,TVSTRT+HTVLNT-2
+ HLRE C,TVP
+ MOVNI C,-2(C) ; CLOBBER LENGTH INTO REAL TVP
+ HLRE B,TVP
+ SUBM TVP,B
+ MOVEM E,(B)
+ HRLM C,1(B) ; PUT IN LENGTH
+ MOVE PVP,PVSTOR+1
+ MOVEM TVP,REALTV+1(PVP)
+
+
+; FIX UP TYPE VECTOR
+
+ MOVE A,TYPVEC+1 ;GET POINTER
+ MOVEI 0,0 ;FOR POSSIBLE NULL SLOTS
+ MOVSI B,TATOM ;SET TYPE TO ATOM
+ MOVEI D,400000 ; TYPE CODE HACKS
+
+TYPLP: HLLM B,(A) ;CHANGE TYPE TO ATOM
+ MOVE C,@1(A) ;GET ATOM
+ HLRE E,C ; FIND DOPE WORD
+ SUBM C,E
+ HRRM D,(E) ; STUFF INTO ATOM
+ MOVEM C,1(A)
+ ADDI D,1
+ ADD A,[2,,2] ;BUMP
+ JUMPL A,TYPLP
+
+\f; CLOSE TTY CHANNELS
+IFN ITS,[
+
+ .CLOSE 1,
+ .CLOSE 2,
+]
+
+;GENERAT THE LOGICAL TTY IN AND OUT CHANNELS
+
+;SETUP CALL TO OPEN OUTPUT TTY CHANNNEL
+
+ IRP A,,[[PRINT,TCHSTR],[TTY:,TCHSTR]]
+ IRP B,C,[A]
+ PUSH TP,$!C
+ PUSH TP,CHQUOTE B
+ .ISTOP
+ TERMIN
+ TERMIN
+
+ MCALL 2,FOPEN ;OPEN THE OUT PUT CHANNEL
+ MOVEM B,TTOCHN+1 ;SAVE IT
+
+;ASSIGN AS GLOBAL VALUE
+
+ PUSH TP,$TATOM
+ PUSH TP,IMQUOTE OUTCHAN
+ PUSH TP,A
+ PUSH TP,B
+ MOVE A,[PUSHJ P,MTYO] ;MORE WINNING INS
+ MOVEM A,IOINS(B) ;CLOBBER
+ MCALL 2,SETG
+
+;SETUP A CALL TO OPEN THE TTY CHANNEL
+
+ IRP A,,[[READ,TCHSTR],[TTY:,TCHSTR]]
+ IRP B,C,[A]
+ PUSH TP,$!C
+ PUSH TP,CHQUOTE B
+ .ISTOP
+ TERMIN
+ TERMIN
+
+ MCALL 2,FOPEN ;OPEN INPUTCHANNEL
+ MOVEM B,TTICHN+1 ;SAVE IT
+ PUSH TP,$TATOM ;ASSIGN AS A GLOBAL VALUE
+ PUSH TP,IMQUOTE INCHAN
+ PUSH TP,A
+ PUSH TP,B
+ MOVE C,BUFRIN(B) ;GET AUX BUFFER PTR
+ MOVE A,[PUSHJ P,MTYI]
+ MOVEM A,IOIN2(C) ;MORE OF A WINNER
+ MOVE A,[PUSHJ P,IMTYO]
+ MOVEM A,ECHO(C) ;ECHO INS
+ MCALL 2,SETG
+ MOVEI A,3 ;FIRST CHANNEL AFTER INIT HAPPENS
+ MOVEM A,FRSTCH
+
+;GENERATE AN INITIAL PROCESS AND SWAP IT IN
+
+ MOVEI A,TPLNT ;STACK PARAMETERS
+ MOVEI B,PLNT
+ PUSHJ P,ICR ;CREATE IT
+ MOVE PVP,PVSTOR+1
+ MOVE 0,SPSTO+1(B)
+ MOVEM 0,SPSTOR+1
+ MOVE 0,REALTV+1(PVP)
+ MOVEM 0,REALTV+1(B) ; STUFF IN TRANSFER VECTOR POINTER
+ MOVEI 0,RUNING
+ MOVEM 0,PSTAT"+1(B)
+ MOVE D,B ;SET UP TO CALL SWAP
+ JSP C,SWAP ;AND SWAP IN
+ MOVEM PVP,MAINPR" ;SAVE AS THE MAIN PROCESS
+ PUSH TP,[TENTRY,,TOPLEV] ;BUILD DUMMY FRAME
+ PUSH TP,[1,,0]
+ MOVEI A,-1(TP)
+ PUSH TP,A
+ PUSH TP,SPSTOR+1
+ PUSH TP,P
+ MOVE C,TP ;COPY TP
+ ADD C,[3,,3] ;FUDGE
+ PUSH TP,C ;TPSAV PUSHED
+ PUSH TP,[TOPLEV]
+ HRRI TB,(TP) ;SETUP TB
+IFN ITS, HRLI TB,2
+IFE ITS, HRLI TB,400002
+ ADD TB,[1,,1]
+ MOVE PVP,PVSTOR+1
+ MOVEM TB,TBINIT+1(PVP)
+ MOVSI A,TSUBR
+ MOVEM A,RESFUN(PVP)
+ MOVEI A,LISTEN"
+ MOVEM A,RESFUN+1(PVP)
+ PUSH TP,$TATOM
+ PUSH TP,IMQUOTE THIS-PROCESS
+ PUSH TP,$TPVP
+ PUSH TP,PVP
+ MCALL 2,SETG
+
+; FIND TVP OFFSET FOR THE ATOM 'T' FOR TEMPLATE
+
+ MOVEI A,IMQUOTE T
+ SUBI A,
+TVTOFF==0
+ ADDSQU TVTOFF
+
+ MOVEM A,SQULOC-1
+
+ PUSH TP,$TATOM
+ PUSH TP,IMQUOTE TVTOFF,,MUDDLE
+ PUSH TP,$TFIX
+ PUSH TP,A
+ MCALL 2,SETG
+
+; HERE TO SETUP SQUOZE TABLE IN PURE CORE
+
+ PUSHJ P,SQSETU ; GO TO ROUTINE
+
+ PUSHJ P,DUMPGC
+ MOVEI A,400000 ; FENCE POST PURE SR VECTOR
+ HRRM A,PURVEC
+ MOVE A,TP
+ HLRE B,A
+ SUBI A,-PDLBUF(B) ;POINT TO DOPE WORDS
+ MOVEI B,12 ;GROWTH SPEC
+ IORM B,(A)
+ MOVE PVP,PVSTOR+1
+ MOVE 0,REALTV+1(PVP)
+ HLRE E,0
+ SUBI 0,-1(E)
+ HRRZM 0,CODTOP
+IFE ITS, PUSHJ P,GETJS
+ PUSHJ P,AAGC ;DO IT
+ AOJL A,.-1
+ MOVE PVP,PVSTOR+1
+ MOVE A,TPBASE+1(PVP)
+ SUB A,[640.,,640.]
+ MOVEM A,TPBASE+1(PVP)
+
+; CREATE LIST OF ROOT AND NEW OBLIST
+
+ MOVEI A,5
+ PUSH P,A
+
+NAMOBL: PUSH TP,$TATOM
+ PUSH TP,@OBNAM-1(A) ; NAME
+ PUSH TP,$TATOM
+ PUSH TP,IMQUOTE OBLIST
+ PUSH TP,$TOBLS
+ PUSH TP,@OBTBL1-1(A)
+ MCALL 3,PUT ; NAME IT
+ SOS A,(P)
+ PUSH TP,$TOBLS
+ PUSH TP,@OBTBL1(A)
+ PUSH TP,$TATOM
+ PUSH TP,IMQUOTE OBLIST
+ PUSH TP,$TATOM
+ PUSH TP,@OBNAM(A)
+ MCALL 3,PUT
+ SKIPE A,(P)
+ JRST NAMOBL
+ SUB P,[1,,1]
+
+;Define MUDDLE version number
+ MOVEI A,5
+ MOVEI B,0 ;Initialize result
+ MOVE C,[440700,,MUDSTR+2]
+VERLP: ILDB D,C ;Get next charcter digit
+ CAIG D,"9 ;Non-digit ?
+ CAIGE D,"0
+ JRST VERDEF
+ SUBI D,"0 ;Convert to number
+ IMULI B,10.
+ ADD B,D ;Include number into result
+ SOJG A,VERLP ;Finished ?
+VERDEF:
+ PUSH TP,$TATOM
+ PUSH TP,IMQUOTE MUDDLE
+ PUSH TP,$TFIX
+ PUSH TP,B
+ MCALL 2,SETG ;Make definition
+OPIPC:
+IFN ITS,[
+ PUSH TP,$TCHSTR
+ PUSH TP,CHQUOTE IPC
+ PUSH TP,$TATOM
+ PUSH TP,MQUOTE IPC-HANDLER
+ MCALL 1,GVAL
+ PUSH TP,A
+ PUSH TP,B
+ PUSH TP,$TFIX
+ PUSH TP,[1]
+ MCALL 3,ON
+ MCALL 0,IPCON
+]
+
+; Allocate inital template tables
+
+ MOVEI A,10
+ PUSHJ P,CAFRE1
+ MOVSI A,(B)
+ HRRI A,1(B)
+ SETZM (B)
+ BLT A,7(B)
+ ADD B,[10,,10] ; REST IT OFF
+ MOVEM B,TD.LNT+1
+ MOVEI A,10
+ PUSHJ P,CAFRE1
+ MOVEI 0,TUVEC ; SETUP UTYPE
+ HRLM 0,10(B)
+ MOVEM B,TD.GET+1
+ MOVSI A,(B)
+ HRRI A,1(B)
+ SETZM (B)
+ BLT A,7(B)
+ MOVEI A,10
+ PUSHJ P,CAFRE1
+ MOVEI 0,TUVEC ; SETUP UTYPE
+ HRLM 0,10(B)
+ MOVEM B,TD.PUT+1
+ MOVSI A,(B)
+ HRRI A,1(B)
+ SETZM (B)
+ BLT A,7(B)
+ MOVEI A,10
+ PUSHJ P,CAFRE1
+ MOVEI 0,TUVEC ; SETUP UTYPE
+ HRLM 0,10(B)
+ MOVEM B,TD.AGC+1
+ MOVSI A,(B)
+ HRRI A,1(B)
+ SETZM (B)
+ BLT A,7(B)
+
+PTSTRT: MOVEI A,SETUP
+ ADDI A,1
+ SUB A,PARBOT ;FIND WHERE PAIRS SHOULD GO
+ MOVEM A,PARNEW
+
+; PURIFY/IMPURIFY THE WORLD (PDL)
+
+IFN ITS,[
+PURIMP: MOVE A,FRETOP
+ SUBI A,1
+ LSH A,-12
+ MOVE B,A
+ MOVNI A,1(A)
+ HRLZ A,A
+ DOTCAL CORBLK,[[1000,,310000],[1000,,-1],A]
+ FATAL INITM -- CAN'T IMPURIFY LOW CORE
+ MOVEI A,PHIBOT
+ ADDI B,1
+ SUB A,B
+ MOVNS A
+ HRL B,A
+ DOTCAL CORBLK,[[1000,,0],[1000,,-1],B]
+ FATAL INITM -- CAN'T FLUSH MIDDLE CORE
+ MOVE A,[-<400-PHIBOT>,,PHIBOT]
+ DOTCAL CORBLK,[[1000,,210000],[1000,,-1],A]
+ FATAL INITM -- CAN'T PURIFY HIGH CORE
+]
+
+IFE ITS,[
+ MOVEI A,400000
+ MOVE B,[1,,START]
+ SEVEC
+]
+ PUSH P,[15.,,15.] ;PUSH A SMALL PRGRM ONTO P
+ MOVEI A,1(P) ;POINT TO ITS START
+ PUSH P,[JRST AAGC] ;GO TO AGC
+ PUSH P,[MOVE PVP,PVSTOR+1]
+ PUSH P,[MOVE B,PSTO+1(PVP)] ;GET SAVED P
+ PUSH P,[SUB B,-14.(P)] ;FUDGE TO POP OFF PROGRAM
+ PUSH P,[MOVEM B,PSAV(TB)] ;INTO FRAME
+ PUSH P,[MOVE B,TPSTO+1(PVP)] ;GET TP
+ PUSH P,[MOVEM B,TPSAV(TB)] ;STORE IT
+ PUSH P,[MOVE B,SPSTOR+1] ;SP
+ PUSH P,[MOVEM B,SPSAV(TB)]
+ PUSH P,[MOVEI B,TOPLEV] ;WHERE TO GO
+ PUSH P,[MOVEM B,PCSAV(TB)]
+IFN ITS, PUSH P,[MOVSI B,(.VALUE )]
+IFE ITS, PUSH P,[MOVSI B,(JRST)]
+ PUSH P,[HRRI B,C]
+ PUSH P,[JRST B] ;GO DO VALRET
+ PUSH P,[B]
+ PUSH P,A ; PUSH START ADDR
+ MOVE B,[JRST -12.(P)]
+ MOVE 0,[JUMPA START]
+IFE ITS, MOVE C,[HALTF]
+IFE ITS, SKIPE OPSYS
+ MOVE C,[ASCII \\170/\e9\]
+ MOVE D,[ASCII \B/\e1Q\]
+ MOVE E,[ASCIZ \\r\16*\r\] ;TERMINATE
+ POPJ P, ; GO
+\f
+; CHECK PAIR SPACE
+
+PAIRCH: CAMG A,B
+ JRST SETTV ;O.K.
+
+DEATH1: MOVEI B,[ASCIZ /LOSSAGE--CODE AND DATA OVERLAP
+/]
+ PUSHJ P,MSGTYP
+ .VALUE
+
+;CHARACTER STRING HACKER
+
+CHACK: MOVE A,(C) ;GET TYPE
+ HLLZM A,(D) ;STORE IN NEW HOME
+ MOVE B,1(C) ;GET POINTER
+ HLRZ E,B ;-LENGHT
+ HRRM E,(D)
+ PUSH P,E+1 ; IDIVI WILL CLOBBER
+ ADDI E,4+5*2 ; ROUND AND ACCOUNT FOR DOPE WORDS
+ IDIVI E,5 ; E/ WORDS LONG
+ PUSHJ P,EBPUR ; MAKE A PURIFIED COPY
+ POP P,E+1
+ HRLI B,010700 ;MAKE POINT BYTER
+ SUBI B,1
+ MOVEM B,1(D) ;AND STORE IT
+ ANDI A,-1 ;CLEAR LH OF A
+ JUMPE A,SETLP ;JUMP IF NO REF
+ HRRZ B,-1(A) ;SEE IF PREVIOUS INSTRUCTION REFERS TO $TCHSTR
+ CAIE B,$TCHSTR ;SKIP IF IT DOES
+ JRST CHACK1 ;NO, JUST DO CHQUOTE PART
+ HRRM D,-1(A) ;CLOBBER
+CHACK1: MOVEI E,1(D)
+ HRRM E,(A) ;STORE INTO REFERENCE
+ MOVEI E,0
+ DPB E,[220400,,(A)]
+ JRST SETLP
+
+; SUBROUTINE TO COPY A HUNK OF STRUCTURE TO THE HIGH SEGMENT
+
+EBPUR: PUSH P,E
+ PUSH P,A
+ ADD E,HITOP ; GET NEW TOP
+ CAMG E,RHITOP ; SKIP IF TOO BIG
+ JRST EBPUR1
+
+; CODE TO GROW HI SEG
+
+ MOVEI A,2000
+ ADDB A,RHITOP ; NEW TOP
+ TLNE A,777776
+ JRST HIFUL
+IFN ITS,[
+ ASH A,-10. ; NUM OF BLOCKS
+ SUBI A,1 ; BLOCK TO GET
+ .CALL HIGET
+ .VALUE
+]
+
+EBPUR1: MOVEI A,-1(E) ; NEEDED TO TERMINATE BLT
+ EXCH E,HITOP
+ HRLI E,(B)
+ MOVEI B,(E)
+ BLT E,(A)
+ POP P,A
+ POP P,E
+ POPJ P,
+
+GIVCOR: SETZ
+ SIXBIT /CORBLK/
+ 1000,,0
+ 1000,,-1
+ SETZ A
+
+HIGET: SETZ
+ SIXBIT /CORBLK/
+ 1000,,100000
+ 1000,,-1
+ A
+ 401000,,400001
+
+\f
+; PROCESS AN ATOM AND ADD IT TO AN APPROPRIATE OBLIST IF IT ISN'T
+; ALREADY THERE
+
+ATOMHK: PUSH TP,$TOBLS ; SAVE OBLIST
+ PUSH TP,[0] ; FILLED IN LATER
+ PUSH TP,$TVEC ;SAVE TV POINTERS
+ PUSH TP,C
+ PUSH TP,$TVEC
+ PUSH TP,D
+ MOVE C,1(C) ;GET THE ATOM
+ PUSH TP,$TATOM ;AND SAVE
+ PUSH TP,C
+ PUSH TP,$TATOM
+ PUSH TP,[0]
+ HRRZ B,(C) ;GET OBLIST SPEC FROM ATOM
+ LSH B,1
+ ADDI B,1(TB) ;POINT TO ITS HOME
+ HRRM B,-9(TP)
+ MOVE B,(B)
+ MOVEM B,-10(TP) ; CLOBBER
+
+ SETZM 2(C) ; FLUSH CURRENT OBLIST SPEC
+ MOVEI E,0
+ MOVE D,C
+ PUSH P,[LOOKCR]
+ ADD D,[3,,3]
+ JUMPGE D,.+4
+ PUSH P,(D)
+ ADDI E,1
+ AOBJN D,.-2
+ PUSH P,E
+ MOVSI A,TOBLS
+ JRST ILOOKC
+LOOKCR:
+ MOVEM B,(TP)
+ JUMPN B,CHCKD
+
+;HERE IF THIS ATOM MUST BE PUT ON OBLIST
+
+USEATM: MOVE B,-2(TP) ; GET ATOM
+ HLRZ E,(B) ; SEE IF PURE OR NOT
+ TRNN E,400000 ; SKIP IF IMPURE
+ JRST PURATM
+ PUSH TP,$TATOM
+ PUSH TP,B
+ PUSH TP,$TOBLS
+ PUSH TP,-13(TP)
+ MCALL 2,INSERT
+
+ PUSHJ P,VALMAK ;MAKE A GLOBAL VALUE FOR THIS LOSER
+PURAT2: MOVE C,-6(TP) ;RESET POINTERS
+ MOVE D,-4(TP)
+ SUB TP,[12,,12]
+ MOVE B,(C) ;MOVE THE ENTRY
+ HLLZM B,(D) ;DON'T WANT REF POINTER STORED
+ MOVE A,1(C) ;AND MOVE ATOM
+ MOVEM A,1(D)
+ MOVEI A,1(D)
+ ANDI B,-1 ;CHECK FOR REAL REF
+ JUMPE B,SETLP1 ;DON'T SAVE THIS ATOM ON TVP
+ HRRM A,(B) ;CLOBBER CODE
+ MOVEI A,0
+ DPB A,[220400,,(B)] ; CLOBBER TVP PORTION
+ JRST SETLP
+
+
+; HERE TO MAKE A PURE ATOM
+
+PURATM: HRRZ B,-2(TP) ; POINT TO IT
+ HLRE E,-2(TP) ; - LNTH
+ MOVNS E
+ ADDI E,2
+ PUSHJ P,EBPUR ; PURE COPY
+ HRRM B,-2(TP) ; AND STORE BACK
+ MOVE B,-2(TP)
+ JUMPE 0,PURAT0
+ HRRZ D,0
+ HLRE E,0
+ SUBM D,E
+ HLRZ 0,2(D)
+ JUMPE 0,PURAT8
+ CAIG 0,HIBOT
+ FATAL INITM--PURE IMPURE LOSSAGE
+ JRST PURAT8
+
+PURAT0: HRRZ E,(C)
+ MOVE D,-2(TP) ; GET ATOM BACK
+ HRRZ 0,(D) ; GET OBLIST CODE
+ JUMPE E,PURAT9
+PURAT7: HLRZ D,1(E)
+ MOVEI D,-2(D)
+ SUBM E,D
+ HLRZ D,2(D)
+ CAILE D,HIBOT ; IF NEXT PURE & I AM ROOT
+ JUMPE 0,PURAT8 ; TAKES ADVANTAGE OF SYSTEM=0
+ JUMPE D,PURAT8
+ MOVE E,D
+ JRST PURAT7
+
+PURAT8: HLRZ D,1(E)
+ SUBI D,2
+ SUBM E,D
+ HLRE C,B
+ SUBM B,C
+ HLRZ E,2(D)
+ HRLM E,2(B)
+ HRLM C,2(D)
+ JRST PURAT6
+
+PURAT9: HLRE A,-2(TP)
+ SUBM B,A
+ HRRZM A,(C)
+
+PURAT6: MOVE B,-10(TP) ; GET BUCKET BACK
+ MOVE C,-2(TP)
+ HRRZ 0,-9(TP)
+ HRRM 0,2(C) ; STORE OBLIST IN ATOM
+PURAT1: HRRZ C,(B) ; GET CONTENTS
+ JUMPE C,HICONS ; AT END, OK
+ CAIL C,HIBOT ; SKIP IF IMPURE
+ JRST HICONS ; CONS IT ON
+ MOVEI B,(C)
+ JRST PURAT1
+
+HICONS: HRLI C,TATOM
+ PUSH P,C
+ PUSH P,-2(TP)
+ PUSH P,B
+ MOVEI B,-2(P)
+ MOVEI E,2
+ PUSHJ P,EBPUR ; MAKE PURE LIST CELL
+
+ MOVE C,(P)
+ SUB P,[3,,3]
+ HRRM B,(C) ; STORE IT
+ MOVE B,1(B) ; ATOM BACK
+ MOVE C,-6(TP) ; GET TVP SLOT
+ HRRM B,1(C) ; AND STORE
+ HLRZ 0,(B) ; TYPE OF VAL
+ MOVE C,B
+ CAIN 0,TUNBOU ; NOT UNBOUND?
+ JRST PURAT3 ; UNBOUND, NO VAL
+ MOVEI E,2 ; COUNT AGAIN
+ PUSHJ P,EBPUR ; VALUE CELL
+ MOVE C,-2(TP) ; ATOM BACK
+ HLLZS (B) ; CLEAR LH
+ MOVSI 0,TLOCI
+ MOVEM B,1(C)
+ SKIPA
+PURAT3: MOVEI 0,0
+ HRRZ A,(C) ; GET OBLIST CODE
+ MOVE A,OBTBL2(A)
+ HRRM A,2(C) ; STORE OBLIST SLOT
+ MOVEM 0,(C)
+ JRST PURAT2
+\f
+; A POSSIBLE MATCH ARRIVES HERE
+
+CHCKD: MOVE D,(TP) ;THEY MATCH!, GET EXISTING ATOM
+ MOVEI A,(D) ;GET TYPE OF IT
+ MOVE B,-2(TP) ;GET NEW ATOM
+ HLRZ 0,(B)
+ TRZ A,377777 ; SAVE ONLY 400000 BIT
+ TRZ 0,377777
+ CAIN 0,(A) ; SKIP IF WIN
+ JRST IM.PUR
+ MOVSI 0,400000
+ ANDCAM 0,(B)
+ ANDCAM 0,(D)
+ HLRZ A,(D)
+ JUMPN A,A1VAL
+ MOVE A,(B) ;MOVE VALUE
+ MOVEM A,(D)
+ MOVE A,1(B)
+ MOVEM A,1(D)
+ MOVE B,D ;EXISTING ATOM TO B
+ MOVEI 0,(B)
+ CAIL 0,HIBOT
+ JRST .+3
+ PUSHJ P,VALMAK ;MAKE A VALUE
+ JRST .+2
+ PUSHJ P,PVALM
+
+;NOW FIND ATOMS OCCURENCE IN XFER VECTOR
+
+OFFIND: MOVE D,-4(TP) ;GET CURRENT POINTER INTO TP
+ MOVE C,[-TVLNT,,TVSTRT] ;AND A COPY OF TVP
+ MOVEI A,0 ;INITIALIZE COUNTER
+ALOOP: CAMN B,1(C) ;IS THIS IT?
+ JRST AFOUND
+ ADD C,[2,,2] ;BUMP COUNTER
+ CAMG C,D
+ AOJA A,ALOOP ;NO, KEEP LOOKING
+
+ MOVEI B,[ASCIZ /LOSSAGE--ATOM DISAPPEARED
+/]
+TYPIT: PUSHJ P,MSGTYP
+ .VALUE
+
+AFOUND: LSH A,1 ;FOUND ATOM, GET REAL OFFSET
+ ADDI A,1
+ ADDI A,TVSTRT
+ MOVE C,-6(TP) ;GET TV POINTER TO NEW ATOM
+ HRRZ B,(C) ;POINT TO REFERENCE
+ SKIPE B ;ANY THERE?
+ HRRM A,(B) ;YES, CLOBBER AWAY
+ SUB TP,[12,,12]
+ MOVEI A,0
+ DPB A,[220400,,(B)] ; KILL TVP POINTER
+ JRST SETLP1 ;AND GO ON
+
+A1VAL: HLRZ C,(B) ;GET VALUE'S TYPE
+ MOVE B,D ;NOW PUT EXISTING ATOM IN B
+ CAIN C,TUNBOU ;UNBOUND?
+ JRST OFFIND ;YES, WINNER
+
+ MOVEI B,[ASCIZ /LOSSAGE--ATOM TRIES TO HAVE 2 VALUES
+/]
+ JRST TYPIT
+
+
+IM.PUR: MOVEI B,[ASCIZ /LOSSAG--ATOM TRIES TO BE BOTH PURE AND IMPURE
+/]
+ JRST TYPIT
+
+PAGLOS: MOVEI B,[ASCIZ /LOSSAGE--IMPURE CORE EXTENDS INTO HIGH SEGMENT
+/]
+ JRST TYPIT
+
+HIFUL: MOVEI B,[ASCIZ /LOSSAGE--HI SEG FULL
+/]
+ JRST TYPIT
+
+\f
+;MAKE A VALUE IN SLOT ON GLOBAL SP
+
+VALMAK: HLRZ A,(B) ;TYPE OF VALUE
+ CAIE A,400000+TUNBOU
+ CAIN A,TUNBOU ;VALUE?
+ JRST VALMA1
+ MOVE A,GLOBSP+1 ;GET POINTER TO GLOBAL SP
+ SUB A,[4,,4] ;ALLOCATE SPACE
+ CAMG A,GLOBAS+1 ;CHECK FOR OVERFLOW
+ JRST SPOVFL
+ MOVEM A,GLOBSP+1 ;STORE IT BACK
+ MOVE C,(B) ;GET TYPE CELL
+ TLZ C,400000
+ HLLZM C,2(A) ;INTO TYPE CELL
+ MOVE C,1(B) ;GET VALUE
+ MOVEM C,3(A) ;INTO VALUE SLOT
+ MOVSI C,TGATOM ;GET TATOM,,0
+ MOVEM C,(A)
+ MOVEM B,1(A) ;AND POINTER TO ATOM
+ MOVSI C,TLOCI ;NOW CLOBBER THE ATOM
+ MOVEM C,(B) ;INTO TYPE CELL
+ ADD A,[2,,2] ;POINT TO VALUE
+ MOVEM A,1(B)
+ POPJ P,
+
+VALMA1: SETZM (B)
+ POPJ P,
+
+SPOVFL: MOVEI B,[ASCIZ /LOSSAGE--GLOBAL SP OVERFLOW
+/]
+ JRST TYPIT
+
+
+PVALM: HLRZ 0,(B)
+ CAIE 0,400000+TUNBOU
+ CAIN 0,TUNBOU
+ JRST VALMA1
+ MOVEI E,2
+ PUSH P,B
+ PUSHJ P,EBPUR
+ POP P,C
+ MOVEM B,1(C)
+ MOVSI 0,TLOCI
+ MOVEM 0,(C)
+ MOVE B,C
+ POPJ P,
+\f;SET UP LIST OF INTERNAL NAMES AND ADDRESS NEEDED BY COMPILER
+
+VECTGO DUMMY1
+
+IRP A,,[FINIS,SPECBIND,WNA,WRONGT,$TLOSE,CALER1,POPUNW
+ILOC,IGLOC,IDVAL,ILVAL,IGVAL,INTFLG,LCKINT,ONINT,TYPLOO,TDEFER
+IFALSE,UNAS,UNBOU,RCALL,SEGMNT,SEGLST,NUMPRI,OPSYS,SSPEC1,COMPERR
+MAKACT,MAKENV,BFRAME,TTP,TTB,$TTP,$TTB,MAKTUP,TPALOC,IBIND,SSPECS
+CILVAL,CISET,CIGVAL,CSETG,IBLOK1,IBLOCK,CLLOC,CGLOC,CASSQ,CGASSQ
+CILNT,CILNQ,CILEGQ,CEMPTY,CIEQUA,CIREST,CINTH,CIAT,CSETLO,CIN
+CIPUT,CIGET,CIGETL,CIMON,CISTRU,CIMEMQ,CIMEMB,CITOP,CIBACK,TYPSEG
+C1CONS,CICONS,CIUVEC,CIVEC,IIFORM,IILIST,CISTNG,HITOP,INCR1,TYPG,VALG,TESTR
+OTBSAV,CITYPE,CFRAME,CARGS,CFUNCT,CUTYPE,CPTYPE,CTYPEP,CTYPEQ,CCHUTY
+CIREMA,RTFALS,CIPUTP,CIGETP,CIGTPR,MPOPJ,TAB,$TAB,ICONS,CSTO,DSTO,NTPALO
+CPLUS,CTIMES,CTIME,CDIVID,CMINUS,CLQ,CLEQ,CGQ,CGEQ,CLOG,CSIN,CCOS,CATAN,CSQRT
+CFIX,CFLOAT,CEXP,CRAND,CINEQU,SPECBND,PGGIVE,PGFIND,MTYO,CMIN,CMAX,RCL,R1C,W1C
+CALLTY,CTYPEC,CTYPEW,NOTTY,CHKAB,CTMPLT,IUNWIN,UNWIN2,NOSHUF,ROOT,ERROBL,INTOBL
+CINSER,CIRMV,CLOOKU,CATOM,CIPNAM,ISTRCM,CITERP,CIPRIN,CIPRN1,CIPRNC,CGFALS
+CPATM,CP1ATM,CPCATM,CPSTR,CP1STR,CPCSTR,CPCH,CREADC,CNXTCH,CREDC1,CNXTC1
+CGBOUN,IIGLOC,MAKTU2,CIFLTZ,CIUPRS,SAT,TFA,WTYP,NAPT,PTYPE,APLQ,PURBOT,GCSBOT
+GLOTOP,TYPVEC,1STEPR,LSTRES,NODES,MAINPR,CVTYPE,CSPNAM,CSBSTR,INTBCK,CICRLF
+CERR1,CERR2,CERR3,CANDP,CORP,CSQUTA,CIMAGE,ATOSQ,CFILLE,CPRTYC,FMPOPJ
+TD.PUT,TD.GET,TD.LNT,CBYTES,MARK,MARK2G,TD.AGC,DSTORE,RCLV,NUMSAT,RMCALL,NPRFLG
+NSPOPJ,NFPOPJ,PURCLN,FRETOP,PURVEC,SWAPGC,NTTYPE,CLRSTR]
+ .GLOBAL A
+ ADDSQU A
+TERMIN
+
+VECRET
+
+; ROUTINE TO SORT AND PURIFY SQUOZE TABLE
+
+SQSETU: MOVE A,[SQUTBL-SQULOC+2,,SQUTBL]
+ MOVEI 0,1
+SQ2: MOVE B,(A)
+ CAMG B,2(A)
+ JRST SQ1
+ MOVEI 0,0
+ EXCH B,2(A)
+ MOVEM B,(A)
+ MOVE B,1(A)
+ EXCH B,3(A)
+ MOVEM B,1(A)
+SQ1: ADD A,[2,,2]
+ JUMPL A,SQ2
+ JUMPE 0,SQSETU
+IFE ITS,[
+STSQU: MOVE B,[440700,,SQBLK]
+ PUSHJ P,MNGNAM
+ HRROI B,SQBLK
+ MOVSI A,600001
+ GTJFN
+ FATAL CANT MAKE FIXUP FILE
+ MOVEI E,(A)
+ MOVE B,[440000,,100000]
+ OPENF
+ FATAL CANT OPEN FIXUP FILE
+ MOVE B,[444400,,SQUTBL]
+ MOVNI C,SQULOC-SQUTBL
+ SOUT
+ MOVEI A,(E)
+ CLOSF
+ JFCL
+ MOVE A,[SQUTBL-SQULOC,,SQUTBL]
+ MOVEM A,SQUPNT"
+]
+IFN ITS,[
+.GLOBAL CSIXBT
+STSQU: MOVE C,MUDSTR+2 ; CALCULATE SECOND FILE NAME FOR SQUOZE TABLE
+ PUSHJ P,CSIXBT
+ HRRI C,(SIXBIT/TAB/) ; TABxxx IS SECOND NAME OF FILE
+ MOVSS C
+ MOVEM C,SQBLK+2 ; STORE IN APPROPRIATE BLOCKS
+ MOVEM C,SQWBLK+2
+ .SUSET [.SSNAM,,SQDIR]
+ .OPEN GCHN,SQWBLK ; OPEN FILE
+ FATAL CAN'T CREATE SQUOZE FILE
+ MOVE A,[SQUTBL-SQULOC,,SQUTBL]
+ MOVEM A,SQUPNT"
+ .IOT GCHN,A
+ .CLOSE GCHN ; CLOSE THE CHANNEL
+]
+ POPJ P,
+
+RHITOP: 0
+
+OBSZ: 151.
+ 13.
+ 151.
+ 151.
+ 317.
+
+OBTBL2: ROOT+1
+ ERROBL+1
+ INTOBL+1
+ MUDOBL+1
+ INITIAL+1
+
+OBTBL: INITIAL+1-TVSTRT+TVBASE
+ MUDOBL+1-TVSTRT+TVBASE
+ INTOBL+1-TVSTRT+TVBASE
+ ERROBL+1-TVSTRT+TVBASE
+ ROOT+1-TVSTRT+TVBASE
+OBNAM: MQUOTE INITIAL
+ IMQUOTE MUDDLE
+ MQUOTE INTERRUPTS
+ MQUOTE ERRORS
+ MQUOTE ROOT
+
+OBTBL1: INITIAL+1
+ MUDOBL+1
+ INTOBL+1
+ ERROBL+1
+ ROOT+1
+
+
+IFN ITS,[
+SQWBLK: SIXBIT / 'DSK/
+ SIXBIT /SQUOZE/
+ SIXBIT /TABLE/
+]
+IFE ITS,[
+MNGNAM: MOVE A,[440700,,MUDSTR+2] ; FOR NAME HACKING
+ ILDB 0,A ; SEE IF IT IS A VERSION
+ CAIN 0,177
+ POPJ P,
+ MOVE A,B
+ ILDB 0,A
+ CAIN 0,"X ; LOOK FOR X'S
+ JRST .+3
+ MOVE B,A
+ JRST .-4
+
+ MOVE A,[440700,,MUDSTR+2]
+ ILDB 0,A
+ IDPB 0,B
+ ILDB 0,A
+ IDPB 0,B
+ ILDB 0,A
+ IDPB 0,B
+ POPJ P,
+]
+
+IFN ITS,[
+.GLOBAL VCREATE,MUDSTR
+
+DEBUG: MOVE E,[440600,,[SIXBIT /EXPERIMENTAL/]]
+ MOVEI 0,12.
+ JRST STUFF
+
+VCREATE: .SUSET [.SSNAM,,[SIXBIT /MUDSYS/]]
+ .OPEN 0,OP%
+ .VALUE
+ MOVEI 0,0 ; SET 0 TO DO THE .RCHST
+ .RCHST 0
+ .CLOSE 0
+ .FDELE DB%
+ .VALUE
+ MOVE E,[440600,,B]
+ MOVEI 0,6
+STUFF: MOVE D,[440700,,MUDSTR+2]
+STUFF1: ILDB A,E ; GET A CHAR
+ CAIN A,0 ;SUPRESS SPACES
+ MOVEI A,137 ;RUBOUT'S DON'T TYPE OUT
+ ADDI A,40 ; TO ASCII
+ IDPB A,D ; STORE
+ SOJN 0,STUFF1
+ SETZM 34
+ SETZM 35
+ SETZM 36
+ .VALUE
+
+OP%: 1,,(SIXBIT /DSK/)
+ SIXBIT /MUD%/
+ SIXBIT />/
+
+DB%: (SIXBIT /DSK/)
+ SIXBIT /MUD%/
+ SIXBIT /</
+ 0
+ 0
+]
+
+
+.GLOBAL GCDIR,ILDBLK,TILDBL,GCLDBK,LENGC,SLENGC,SGCLBK,RLENGC
+.GLOBAL SECBLK,SECLEN,RSLENG,DECBLK
+
+; ROUTINE TO DUMP OUT THE GARBAGE-COLLECTOR
+
+DUMPGC:
+IFN ITS,[
+ .SUSET [.SSNAM,,GCDIR] ; SET SNAME
+ MOVE C,MUDSTR+2 ; CREATE SECOND NAMES
+ PUSHJ P,CSIXBT
+ HRRI C,(SIXBIT /MUD/)
+ MOVS A,C ; MUDxx IS SECOND NAME
+ MOVEM A,GCLDBK+2
+ MOVEM A,SGCLBK+2
+ MOVEM A,ILDBLK+2
+ MOVEM A,GCDBLK+2 ; SMASH IN SECOND NAMES
+ MOVEM A,SGCDBK+2
+ MOVEM A,INTDBK+2
+ .OPEN 0,GCDBLK ; OPEN GC FILE
+ FATAL CANT CREATE AGC FILE
+ MOVNI A,LENGC ; CALCULATE IOT POINTER
+ ASH A,10.
+ HRLZS A
+ HRRI A,REALGC
+ .IOT 0,A ; SEND IT OUT
+ .CLOSE 0, ; CLOSE THE CHANNEL
+ .OPEN 0,SGCDBK ; OPEN GC FILE
+ FATAL CANT CREATE AGC FILE
+ MOVNI A,SLENGC ; CALCULATE IOT POINTER
+ ASH A,10.
+ HRLZS A
+ HRRI A,REALGC+RLENGC
+ .IOT 0,A ; SEND IT OUT
+ .CLOSE 0, ; CLOSE THE CHANNEL
+
+
+; ROUTINE TO DUMP THE INTERPRETER
+
+ .SUSET [.SSNAM,,INTDIR]
+ .OPEN 0,ILDBLK ; OPEN FILE TO INTERPRETER BLOCK
+ FATAL CANT FIXUP INTERPRETER
+ 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 0,[1]
+ .IOT 0,A ; GET IN PAGE MAP
+ .CLOSE 0,
+ .OPEN 0,INTDBK
+ FATAL CANT FIXUP INTERPRETER
+ 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,PAGEGC ; SKIP IF DONE
+ AOJA E,LOPFND
+ ASH A,10. ; TO WORDS
+ .ACCES 0,A
+ MOVNI B,LENGC
+ ASH B,10. ; TO WORDS
+ HRLZS B ; SWAP
+ HRRI B,AGCLD
+ .IOT 0,B
+ .CLOSE 0,
+ POPJ P, ; DONE
+
+GCDBLK: SIXBIT / 'DSK/
+ SIXBIT /AGC/
+ SIXBIT /MUD /
+
+SGCDBK: SIXBIT / 'DSK/
+ SIXBIT /SGC/
+ SIXBIT /MUD /
+
+INTDBK: 100007,,(SIXBIT /DSK/)
+ SIXBIT /TS/
+ SIXBIT /MUD/
+
+]
+IFE ITS,[
+ MOVE B,[440700,,GCLDBK]
+ PUSHJ P,MNGNAM ; VERSION TO NAME IF NECESSARY
+ HRROI B,GCLDBK
+ MOVSI A,600001
+ GTJFN
+ FATAL CANT WRITE OUT GC
+ MOVEI E,(A)
+ MOVE B,[440000,,100000]
+ OPENF
+ FATAL CANT OPEN GC FILE
+ MOVNI C,LENGC
+ ASH C,10.
+ MOVE B,[444400,,REALGC]
+ MOVEI A,(E)
+ SOUT
+ MOVEI A,(E)
+ CLOSF
+ JFCL
+ MOVEI D,LENGC+LENGC
+ MOVNI A,1
+ MOVEI B,REALGC
+ ASH B,-9.
+ HRLI B,400000
+
+ PMAP
+ ADDI B,1
+ SOJG D,.-2
+
+ MOVE B,[440700,,SGCLBK]
+ PUSHJ P,MNGNAM ; VERSION TO NAME IF NECESSARY
+ HRROI B,SGCLBK
+ MOVSI A,600001
+ GTJFN
+ FATAL CANT WRITE OUT GC
+ MOVEI E,(A)
+ MOVE B,[440000,,100000]
+ OPENF
+ FATAL CANT OPEN GC FILE
+ MOVNI C,SLENGC
+ ASH C,10.
+ MOVE B,[444400,,REALGC+RLENGC]
+ MOVEI A,(E)
+ SOUT
+ MOVEI A,(E)
+ CLOSF
+ JFCL
+ MOVEI D,SLENGC+SLENGC
+ MOVNI A,1
+ MOVEI B,REALGC+RLENGC
+ ASH B,-9.
+ HRLI B,400000
+
+ PMAP
+ ADDI B,1
+ SOJG D,.-2
+
+ MOVE B,[440700,,SECBLK]
+ PUSHJ P,MNGNAM ; VERSION TO NAME IF NECESSARY
+ HRROI B,SECBLK
+ MOVSI A,600001
+ GTJFN
+ FATAL CANT WRITE OUT GC
+ MOVEI E,(A)
+ MOVE B,[440000,,100000]
+ OPENF
+ FATAL CANT OPEN GC FILE
+ MOVNI C,SECLEN
+ ASH C,10.
+ MOVE B,[444400,,REALGC+RLENGC+RSLENG]
+ MOVEI A,(E)
+ SOUT
+ MOVEI A,(E)
+ CLOSF
+ JFCL
+
+; NOW MUNG THE THING TO BE DIFFERENT TO USE UUOS FOR DEBUGGING VERSION
+
+.GLOBAL %FXUPS,%FXEND
+
+ MOVEI A,%FXUPS
+
+%DBG1: HLRZ D,(A)
+ HRRZ A,(A)
+ LDB 0,[331100,,(A)] ; GET INS
+ MOVEI C,%TBL
+ HRRZ B,(C)
+ CAME B,0
+ AOJA C,.-2
+ CAIN B,<<(XBLT)>_<-9.>>
+ HLLZS (A)
+ LDB B,[331100,,(C)]
+ DPB B,[331100,,(A)]
+ MOVE A,D
+ JUMPN A,%DBG1
+%DBG2:
+ MOVE B,[440700,,DECBLK]
+ PUSHJ P,MNGNAM ; VERSION TO NAME IF NECESSARY
+ HRROI B,DECBLK
+ MOVSI A,600001
+ GTJFN
+ FATAL CANT WRITE OUT GC
+ MOVEI E,(A)
+ MOVE B,[440000,,100000]
+ OPENF
+ FATAL CANT OPEN GC FILE
+ MOVNI C,SECLEN
+ ASH C,10.
+ MOVE B,[444400,,REALGC+RLENGC+RSLENG]
+ MOVEI A,(E)
+ SOUT
+ MOVEI A,(E)
+ CLOSF
+ JFCL
+ MOVEI D,SECLEN+SECLEN
+ MOVNI A,1
+ MOVEI B,REALGC+RLENGC
+ ASH B,-9.
+ HRLI B,400000
+
+ PMAP
+ ADDI B,1
+ SOJG D,.-2
+
+ MOVE B,[440700,,ILDBLK]
+ SKIPE OPSYS
+ MOVE B,[440700,,TILDBL]
+ PUSHJ P,MNGNAM
+ MOVSI C,-1000
+ MOVSI A,400000
+RPA: RPACS
+ TLNE B,10000
+ TLNN B,400 ; SKIP IF NOT PRIVATE
+ SKIPA
+ MOVES (C)
+ ADDI C,777
+ ADDI A,1
+ AOBJN C,RPA
+
+ MOVNI A,1
+ CLOSF
+ FATAL CANT CLOSE STUFF
+ HRROI B,ILDBLK
+ MOVSI A,100001
+ GTJFN ; GET A JFN
+ FATAL GARBAGE COLLECTOR IS MISSING
+ HRRZS E,A ; SAVE JFN
+ MOVE B,[440000,,300000]
+ OPENF
+ FATAL CANT OPEN GC FILE
+ MOVEI A,(E) ; FIND OUT LENGTH OF MAP
+ BIN ; GET LENGTH WORD
+ HLRZ 0,B
+ CAIE 0,1776 ; TOPS20 SSAVE FILE FORMAT
+ CAIN 0,1000 ; TENEX SSAVE FILE FORMAT
+ JRST .+2
+ FATAL NOT AN SSAVE FILE
+ MOVEI A,(B) ; ISOLATE SIZE OF MAP
+ HLRE B,TP ; MUST BE SPACE FOR CRUFT
+ MOVNS B
+ CAIGE B,(A) ; ROOM?
+ FATAL NO ROOM FOR PAGE MAP (GULP)
+ 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) ; POINT TO MAP
+ CAIE 0,1000
+ JRST RPA1 ; GO TO THE TOPS20 CODE
+ LDB 0,[221100,,(A)] ; GET FORK PAGE
+ CAIE 0,PAGEGC+PAGEGC ; GOT IT?
+ AOJA A,.-2
+ JRST RPA2
+
+RPA1: ADDI A,1 ; POINT TO PROCESS PAGE NUMBER
+ LDB 0,[331100,,(A)] ; REPEAT COUNT IN 0
+ LDB B,[3300,,(A)] ; FIRST PAGE NUMBER IN B
+ ADD 0,B ; LARGEST PAGE NUMBER
+ CAIL 0,PAGEGC+PAGEGC
+ CAILE B,PAGEGC+PAGEGC
+ AOJA A,RPA1 ; NEXT PAIR OF WORDS PLEASE
+ SUBI A,1 ; POINT TO FILE PAGE NUMBER
+ SUBI B,PAGEGC+PAGEGC
+ MOVN B,B
+ ADDM B,(A) ; SET UP THE PAGE
+
+RPA2: HRRZ B,(A) ; GET PAGE
+ MOVEI A,(E) ; GET JFN
+ ASH B,9.
+ SFPTR
+ FATAL ACCESS OF FILE FAILED
+ MOVEI A,(E)
+ MOVE B,[444400,,AGCLD]
+ MOVNI C,LENGC
+ ASH C,10.
+ SOUT
+ MOVEI A,(E)
+ CLOSF
+ JFCL
+ POPJ P,
+
+; CODE TO DISTINGUISH BETWEEN TOPS20 AND TENEX AT SETUP TIME
+
+TWENTY: HRROI A,C ; RESULTS KEPT HERE
+ HRLOI B,600015
+ MOVEI C,0 ; CLEAN C UP
+ DEVST
+ JFCL
+ MOVEI A,1 ; TENEX HAS OPSYS = 1
+ CAME C,[ASCII/NUL/] ; TOPS20 GIVES "NUL"
+ MOVEM A,OPSYS ; TENEX GIVES "NIL"
+ POPJ P,
+%TBL: IRP A,,[HRRM,HRLM,MOVEM,SETZM,HLRZ,XBLT]
+ S!A <<(A)>_<-9.>>
+ TERMIN
+
+GCLDBK: ASCIZ /MDLXXX.AGC/
+SGCLBK: ASCIZ /MDLXXX.SGC/
+SECBLK: ASCIZ /MDLXXX.SEC/
+ILDBLK: ASCIZ /MDLXXX.EXE/
+TILDBL: ASCIZ /MDLXXX.SAV/
+DECBLK: ASCIZ /MDLXXX.DEC/
+]
+
+
+
+END SETUP
+\f
\ No newline at end of file
--- /dev/null
+TITLE INITIALIZATION FOR MUDDLE
+
+RELOCATABLE
+
+HTVLNT==3000 ; GUESS OF TVP LENGTH
+
+LAST==1 ;POSSIBLE CHECKS DONE LATER
+
+.INSRT MUDDLE >
+
+SYSQ
+XBLT==123000,,
+GCHN==0
+IFE ITS,[
+FATINS==.FATAL"
+SEVEC==104000,,204
+.INSRT STENEX >
+]
+
+IMPURE
+
+OBSIZE==151. ;DEFAULT OBLIST SIZE
+
+.LIFG <TVBASE+TVLNT-TVLOC>
+.LOP .VALUE
+.ELDC
+
+.GLOBAL SHRRM,SHRLM,SMOVEM,SSETZM,SXBLT,SHLRZ
+.GLOBAL SETUP,TPBAS,GCPDL,GCPVP,PVBASE,PVLNT,PARNEW,AAGC,ICR,SWAP,OBLNT,MSGTYP,POPUNW
+.GLOBAL ICLOS,OCLOS,GLOBASE,GLOBSP,PARBOT,PARTOP,CODTOP,START,BEGIN,VECBOT,VECTOP,TPBASE
+.GLOBAL LISTEN,ROOT,INITIAL,TBINIT,TOPLEV,INTOBL,ERROBL,MUDOBL,TTYOPE,RESFUN,QUITTER
+.GLOBAL IOINS,BUFRIN,IOIN2,ECHO,MTYI,MTYO,IMTYO,MUDSTR,P.TOP,TTICHN,TTOCHN,TYPVEC,SQDIR
+.GLOBAL PDLBUF,PHIBOT,%UNAM,PURVEC,STOSTR,ISTOST,TD.LNT,TD.PUT,TD.GET,CAFRE1
+.GLOBAL FRETOP,LPUR,SQBLK,REALGC,INTDIR,AGCLD,PAGEGC,TD.AGC,TVSTRT,REALTV,PVSTOR
+.GLOBAL GCSTOP,SPSTOR,DSTORE,SQBYTE,INBYTE,GCBYTE,FRSTCH,OPSYS,IJFNS,GETJS
+.GLOBAL HASHTB,ILOOKC
+
+LPUR==.LPUR ; SET UP SO LPUR WORKS
+
+; INIITAL AMOUNT OF AFREE SPACE
+
+STOSTR:
+LOC TVSTRT-1
+ISTOST: TVSTRT-STOSTR,,0
+
+ BLOCK HTVLNT ; TVP
+
+SETUP: MOVEI 0,0 ; ZERO ACS
+ MOVEI 17,1
+ BLT 17,17
+
+IFN ITS, .SUSET [.RUNAM,,%UNAM] ; FOR AGC'S BENFIT
+ MOVE P,GCPDL ;GET A PUSH DOWN STACK
+IFN ITS, .SUSET [.SMASK,,[200000]] ; ENABLE PDL OVFL
+ MOVE 0,[TVBASE,,TVSTRT]
+ BLT 0,TVSTRT+HTVLNT-3 ; BLT OVER TVP
+IFE ITS, PUSHJ P,TWENTY ; FIND OUT WHETHER IT IS TOPS20 OR NOT
+ PUSHJ P,TTYOPE ;OPEN THE TTY
+ AOS A,20 ; TOP OF LOW SEGG
+ HRRZM A,P.TOP
+ SOSN A ; IF NOTHING YET
+IFN ITS, .SUSET [.RMEMT,,P.TOP]
+IFE ITS, JRST 4,
+ MOVE A,P.TOP
+ SUB A,FRETOP ; SETUP FOR GETTING NEEDED CORE
+ SUBI A,3777
+ ASH A,-10. ; TO PAGES
+ HRLS A ; SET UP AOBJN
+ HRRZ 0,P.TOP
+ ASH 0,-10.
+ SUBI 0,1
+ HRR A,0
+IFN ITS,[
+ .CALL HIGET ; GET THEM
+ FATAL INITM--CORE NOT AVAILABLE FOR INITIALIZATION
+ ASH A,10. ; TO WORDS
+ MOVEM A,P.TOP
+ SUBI A,2000 ; WHERE FRETOP IS
+ MOVEM A,FRETOP
+
+]
+IFE ITS,[
+ MOVE A,FRETOP
+ ADDI A,2000
+ MOVEM A,P.TOP
+]
+ HRRE A,P.TOP ; CHECK TOP
+ TRNE A,377777 ; SKIP IF ALL LOW SEG
+ JUMPL A,PAGLOS ; COMPLAIN
+ MOVE A,HITOP ; FIND HI SEG TOP
+ ADDI A,1777
+ ANDCMI A,1777
+ MOVEM A,RHITOP ; SAVE IT
+ MOVEI A,200
+ SUBI A,PHIBOT
+ JUMPE A,HIBOK
+ MOVSI A,(A)
+ HRRI A,200
+IFN ITS,[
+ .CALL GIVCOR
+ .VALUE
+]
+HIBOK: MOVEI B,[ASCIZ /MUDDLE INITIALIZATION.
+/]
+ PUSHJ P,MSGTYP ;PRINT IT
+ MOVE A,CODTOP ;CHECK FOR A WINNING LOAD
+ CAML A,VECBOT ;IT BETTER BE LESS
+ JRST DEATH1 ;LOSE COMPLETELY
+SETTV: MOVE PVP,[-PVLNT*2,,GCPVP] ;AND A PROCESS VECTOR
+ MOVEM PVP,PVSTOR+1
+ MOVEM PVP,PVSTOR+1-TVSTRT+TVBASE
+ MOVEI A,(PVP) ;SET UP A BLT
+ HRLI A,PVBASE ;FROM PROTOTYPE
+ BLT A,PVLNT*2-1(PVP) ;INITIALIZE
+ MOVE TP,[-ITPLNT,,TPBAS] ;GET A STACK FOR THIS PROCCESS
+ MOVEI TB,(TP) ;AND A BASE
+IFN ITS, HRLI TB,1
+IFE ITS, HRLI TB,400001 ; FOR MULTI SEG HACKING
+ SUB TP,[1,,1] ;POP ONCE
+
+; FIRST BUILD MOBY HASH TABLE
+
+ MOVEI A,1023. ; TRY THIS OUT FOR SIZE
+ PUSHJ P,IBLOCK
+ MOVEM B,HASHTB+1-TVSTRT+TVBASE ; STORE IN TVP POINTER
+ HLRE A,B
+ SUB B,A
+ MOVEI A,TATOM+.VECT.
+ HRLM A,(B)
+
+; ALLOCATE SOME OBLISTS FOR INITIAL ATOMS
+
+ PUSH P,[5] ;COUNT INITIAL OBLISTS
+
+ PUSH P,OBLNT ;SAVE CURRENT OBLIST DEFAULT SIZE
+
+MAKEOB: SOS A,-1(P)
+ MOVE A,OBSZ(A)
+ MOVEM A,OBLNT
+ MCALL 0,MOBLIST ;GOBBLE AN OBLIST
+ PUSH TP,$TOBLS ;AND SAVE THEM
+ PUSH TP,B
+ MOVE A,(P)-1 ;COUNT DOWN
+ MOVEM B,@OBTBL(A) ;STORE
+ JUMPN A,MAKEOB
+
+ POP P,OBLNT ;RESTORE DEFAULT OBLIST SIZE
+
+ MOVE C,[-TVLNT+2,,TVBASE]
+ MOVE D,[-HTVLNT+2,,TVSTRT]
+
+;MAIN INITIALIZE LOOP - SCAN XFER VECTOR FOR ATOMS, UPDATE
+;OFFSETS IN CODE, UNIQUIFY ATOMS AND COMPACT XFER VECTOR
+
+ILOOP: HLRZ A,(C) ;FIRST TYPE
+ JUMPE A,TVEXAU ;USEFUL STUFF EXHAUSTED
+ CAIN A,TCHSTR ;CHARACTER STRING?
+ JRST CHACK ;YES, GO HACK IT
+ CAIN A,TATOM ;ATOM?
+ JRST ATOMHK ;YES, CHECK IT OUT
+ MOVE A,(C) ;MOVE TO NEW HOME (MAY BE SAME)
+ MOVEM A,(D)
+ MOVE A,1(C)
+ MOVEM A,1(D)
+SETLP: AOS (P) ;COUNT NUMBER OF PAIRS IN XFER VECTOR
+ ADD D,[2,,2] ;OUT COUNTER
+SETLP1: ADD C,[2,,2] ;AND IN COUNTER
+ JUMPL C,ILOOP ;JUMP IF MORE TO DO
+\f
+;NEW XFER VECTOR FINISHED, NOW GIVE AWAY THE REST
+
+TVEXAU: HLRE B,D ; LEFT HALF OF AOBJN
+ MOVNI TVP,HTVLNT-2 ; CALCULATE LENGTH OF TVP
+ SUB TVP,B ; GET -LENGTH OF TVP IN TVP
+ HRLS TVP
+ HRRI TVP,TVSTRT ; BUILD A TASTEFUL TVP POINTER
+ MOVNI C,TVLNT-HTVLNT+2(B) ; SMASH IN LENGTH INTO END DOPE WORDS
+ HRLM C,TVSTRT+HTVLNT-1
+ MOVSI E,400000
+ MOVEM E,TVSTRT+HTVLNT-2
+ HLRE C,TVP
+ MOVNI C,-2(C) ; CLOBBER LENGTH INTO REAL TVP
+ HLRE B,TVP
+ SUBM TVP,B
+ MOVEM E,(B)
+ HRLM C,1(B) ; PUT IN LENGTH
+ MOVE PVP,PVSTOR+1
+ MOVEM TVP,REALTV+1(PVP)
+
+
+; FIX UP TYPE VECTOR
+
+ MOVE A,TYPVEC+1 ;GET POINTER
+ MOVEI 0,0 ;FOR POSSIBLE NULL SLOTS
+ MOVSI B,TATOM ;SET TYPE TO ATOM
+ MOVEI D,400000 ; TYPE CODE HACKS
+
+TYPLP: HLLM B,(A) ;CHANGE TYPE TO ATOM
+ MOVE C,@1(A) ;GET ATOM
+ HLRE E,C ; FIND DOPE WORD
+ SUBM C,E
+ HRRM D,(E) ; STUFF INTO ATOM
+ MOVEM C,1(A)
+ ADDI D,1
+ ADD A,[2,,2] ;BUMP
+ JUMPL A,TYPLP
+
+\f; CLOSE TTY CHANNELS
+IFN ITS,[
+
+ .CLOSE 1,
+ .CLOSE 2,
+]
+
+;GENERAT THE LOGICAL TTY IN AND OUT CHANNELS
+
+;SETUP CALL TO OPEN OUTPUT TTY CHANNNEL
+
+ IRP A,,[[PRINT,TCHSTR],[TTY:,TCHSTR]]
+ IRP B,C,[A]
+ PUSH TP,$!C
+ PUSH TP,CHQUOTE B
+ .ISTOP
+ TERMIN
+ TERMIN
+
+ MCALL 2,FOPEN ;OPEN THE OUT PUT CHANNEL
+ MOVEM B,TTOCHN+1 ;SAVE IT
+
+;ASSIGN AS GLOBAL VALUE
+
+ PUSH TP,$TATOM
+ PUSH TP,IMQUOTE OUTCHAN
+ PUSH TP,A
+ PUSH TP,B
+ MOVE A,[PUSHJ P,MTYO] ;MORE WINNING INS
+ MOVEM A,IOINS(B) ;CLOBBER
+ MCALL 2,SETG
+
+;SETUP A CALL TO OPEN THE TTY CHANNEL
+
+ IRP A,,[[READ,TCHSTR],[TTY:,TCHSTR]]
+ IRP B,C,[A]
+ PUSH TP,$!C
+ PUSH TP,CHQUOTE B
+ .ISTOP
+ TERMIN
+ TERMIN
+
+ MCALL 2,FOPEN ;OPEN INPUTCHANNEL
+ MOVEM B,TTICHN+1 ;SAVE IT
+ PUSH TP,$TATOM ;ASSIGN AS A GLOBAL VALUE
+ PUSH TP,IMQUOTE INCHAN
+ PUSH TP,A
+ PUSH TP,B
+ MOVE C,BUFRIN(B) ;GET AUX BUFFER PTR
+ MOVE A,[PUSHJ P,MTYI]
+ MOVEM A,IOIN2(C) ;MORE OF A WINNER
+ MOVE A,[PUSHJ P,IMTYO]
+ MOVEM A,ECHO(C) ;ECHO INS
+ MCALL 2,SETG
+ MOVEI A,3 ;FIRST CHANNEL AFTER INIT HAPPENS
+ MOVEM A,FRSTCH
+
+;GENERATE AN INITIAL PROCESS AND SWAP IT IN
+
+ MOVEI A,TPLNT ;STACK PARAMETERS
+ MOVEI B,PLNT
+ PUSHJ P,ICR ;CREATE IT
+ MOVE PVP,PVSTOR+1
+ MOVE 0,SPSTO+1(B)
+ MOVEM 0,SPSTOR+1
+ MOVE 0,REALTV+1(PVP)
+ MOVEM 0,REALTV+1(B) ; STUFF IN TRANSFER VECTOR POINTER
+ MOVEI 0,RUNING
+ MOVEM 0,PSTAT"+1(B)
+ MOVE D,B ;SET UP TO CALL SWAP
+ JSP C,SWAP ;AND SWAP IN
+ MOVEM PVP,MAINPR" ;SAVE AS THE MAIN PROCESS
+ PUSH TP,[TENTRY,,TOPLEV] ;BUILD DUMMY FRAME
+ PUSH TP,[1,,0]
+ MOVEI A,-1(TP)
+ PUSH TP,A
+ PUSH TP,SPSTOR+1
+ PUSH TP,P
+ MOVE C,TP ;COPY TP
+ ADD C,[3,,3] ;FUDGE
+ PUSH TP,C ;TPSAV PUSHED
+ PUSH TP,[TOPLEV]
+ HRRI TB,(TP) ;SETUP TB
+IFN ITS, HRLI TB,2
+IFE ITS, HRLI TB,400002
+ ADD TB,[1,,1]
+ MOVE PVP,PVSTOR+1
+ MOVEM TB,TBINIT+1(PVP)
+ MOVSI A,TSUBR
+ MOVEM A,RESFUN(PVP)
+ MOVEI A,LISTEN"
+ MOVEM A,RESFUN+1(PVP)
+ PUSH TP,$TATOM
+ PUSH TP,IMQUOTE THIS-PROCESS
+ PUSH TP,$TPVP
+ PUSH TP,PVP
+ MCALL 2,SETG
+
+; FIND TVP OFFSET FOR THE ATOM 'T' FOR TEMPLATE
+
+ MOVEI A,IMQUOTE T
+ SUBI A,
+TVTOFF==0
+ ADDSQU TVTOFF
+
+ MOVEM A,SQULOC-1
+
+ PUSH TP,$TATOM
+ PUSH TP,IMQUOTE TVTOFF,,MUDDLE
+ PUSH TP,$TFIX
+ PUSH TP,A
+ MCALL 2,SETG
+
+; HERE TO SETUP SQUOZE TABLE IN PURE CORE
+
+ PUSHJ P,SQSETU ; GO TO ROUTINE
+
+ PUSHJ P,DUMPGC
+ MOVEI A,400000 ; FENCE POST PURE SR VECTOR
+ HRRM A,PURVEC
+ MOVE A,TP
+ HLRE B,A
+ SUBI A,-PDLBUF(B) ;POINT TO DOPE WORDS
+ MOVEI B,12 ;GROWTH SPEC
+ IORM B,(A)
+ MOVE PVP,PVSTOR+1
+ MOVE 0,REALTV+1(PVP)
+ HLRE E,0
+ SUBI 0,-1(E)
+ HRRZM 0,CODTOP
+IFE ITS, PUSHJ P,GETJS
+ PUSHJ P,AAGC ;DO IT
+ AOJL A,.-1
+ MOVE PVP,PVSTOR+1
+ MOVE A,TPBASE+1(PVP)
+ SUB A,[640.,,640.]
+ MOVEM A,TPBASE+1(PVP)
+
+; CREATE LIST OF ROOT AND NEW OBLIST
+
+ MOVEI A,5
+ PUSH P,A
+
+NAMOBL: PUSH TP,$TATOM
+ PUSH TP,@OBNAM-1(A) ; NAME
+ PUSH TP,$TATOM
+ PUSH TP,IMQUOTE OBLIST
+ PUSH TP,$TOBLS
+ PUSH TP,@OBTBL1-1(A)
+ MCALL 3,PUT ; NAME IT
+ SOS A,(P)
+ PUSH TP,$TOBLS
+ PUSH TP,@OBTBL1(A)
+ PUSH TP,$TATOM
+ PUSH TP,IMQUOTE OBLIST
+ PUSH TP,$TATOM
+ PUSH TP,@OBNAM(A)
+ MCALL 3,PUT
+ SKIPE A,(P)
+ JRST NAMOBL
+ SUB P,[1,,1]
+
+;Define MUDDLE version number
+ MOVEI A,5
+ MOVEI B,0 ;Initialize result
+ MOVE C,[440700,,MUDSTR+2]
+VERLP: ILDB D,C ;Get next charcter digit
+ CAIG D,"9 ;Non-digit ?
+ CAIGE D,"0
+ JRST VERDEF
+ SUBI D,"0 ;Convert to number
+ IMULI B,10.
+ ADD B,D ;Include number into result
+ SOJG A,VERLP ;Finished ?
+VERDEF:
+ PUSH TP,$TATOM
+ PUSH TP,IMQUOTE MUDDLE
+ PUSH TP,$TFIX
+ PUSH TP,B
+ MCALL 2,SETG ;Make definition
+OPIPC:
+IFN ITS,[
+ PUSH TP,$TCHSTR
+ PUSH TP,CHQUOTE IPC
+ PUSH TP,$TATOM
+ PUSH TP,MQUOTE IPC-HANDLER
+ MCALL 1,GVAL
+ PUSH TP,A
+ PUSH TP,B
+ PUSH TP,$TFIX
+ PUSH TP,[1]
+ MCALL 3,ON
+ MCALL 0,IPCON
+]
+
+; Allocate inital template tables
+
+ MOVEI A,10
+ PUSHJ P,CAFRE1
+ MOVSI A,(B)
+ HRRI A,1(B)
+ SETZM (B)
+ BLT A,7(B)
+ ADD B,[10,,10] ; REST IT OFF
+ MOVEM B,TD.LNT+1
+ MOVEI A,10
+ PUSHJ P,CAFRE1
+ MOVEI 0,TUVEC ; SETUP UTYPE
+ HRLM 0,10(B)
+ MOVEM B,TD.GET+1
+ MOVSI A,(B)
+ HRRI A,1(B)
+ SETZM (B)
+ BLT A,7(B)
+ MOVEI A,10
+ PUSHJ P,CAFRE1
+ MOVEI 0,TUVEC ; SETUP UTYPE
+ HRLM 0,10(B)
+ MOVEM B,TD.PUT+1
+ MOVSI A,(B)
+ HRRI A,1(B)
+ SETZM (B)
+ BLT A,7(B)
+ MOVEI A,10
+ PUSHJ P,CAFRE1
+ MOVEI 0,TUVEC ; SETUP UTYPE
+ HRLM 0,10(B)
+ MOVEM B,TD.AGC+1
+ MOVSI A,(B)
+ HRRI A,1(B)
+ SETZM (B)
+ BLT A,7(B)
+
+PTSTRT: MOVEI A,SETUP
+ ADDI A,1
+ SUB A,PARBOT ;FIND WHERE PAIRS SHOULD GO
+ MOVEM A,PARNEW
+
+; PURIFY/IMPURIFY THE WORLD (PDL)
+
+IFN ITS,[
+PURIMP: MOVE A,FRETOP
+ SUBI A,1
+ LSH A,-12
+ MOVE B,A
+ MOVNI A,1(A)
+ HRLZ A,A
+ DOTCAL CORBLK,[[1000,,310000],[1000,,-1],A]
+ FATAL INITM -- CAN'T IMPURIFY LOW CORE
+ MOVEI A,PHIBOT
+ ADDI B,1
+ SUB A,B
+ MOVNS A
+ HRL B,A
+ DOTCAL CORBLK,[[1000,,0],[1000,,-1],B]
+ FATAL INITM -- CAN'T FLUSH MIDDLE CORE
+ MOVE A,[-<400-PHIBOT>,,PHIBOT]
+ DOTCAL CORBLK,[[1000,,210000],[1000,,-1],A]
+ FATAL INITM -- CAN'T PURIFY HIGH CORE
+]
+
+IFE ITS,[
+ MOVEI A,400000
+ MOVE B,[1,,START]
+ SEVEC
+]
+ PUSH P,[15.,,15.] ;PUSH A SMALL PRGRM ONTO P
+ MOVEI A,1(P) ;POINT TO ITS START
+ PUSH P,[JRST AAGC] ;GO TO AGC
+ PUSH P,[MOVE PVP,PVSTOR+1]
+ PUSH P,[MOVE B,PSTO+1(PVP)] ;GET SAVED P
+ PUSH P,[SUB B,-14.(P)] ;FUDGE TO POP OFF PROGRAM
+ PUSH P,[MOVEM B,PSAV(TB)] ;INTO FRAME
+ PUSH P,[MOVE B,TPSTO+1(PVP)] ;GET TP
+ PUSH P,[MOVEM B,TPSAV(TB)] ;STORE IT
+ PUSH P,[MOVE B,SPSTOR+1] ;SP
+ PUSH P,[MOVEM B,SPSAV(TB)]
+ PUSH P,[MOVEI B,TOPLEV] ;WHERE TO GO
+ PUSH P,[MOVEM B,PCSAV(TB)]
+IFN ITS, PUSH P,[MOVSI B,(.VALUE )]
+IFE ITS, PUSH P,[MOVSI B,(JRST)]
+ PUSH P,[HRRI B,C]
+ PUSH P,[JRST B] ;GO DO VALRET
+ PUSH P,[B]
+ PUSH P,A ; PUSH START ADDR
+ MOVE B,[JRST -12.(P)]
+ MOVE 0,[JUMPA START]
+IFE ITS, MOVE C,[HALTF]
+IFE ITS, SKIPE OPSYS
+ MOVE C,[ASCII \\170/\e9\]
+ MOVE D,[ASCII \B/\e1Q\]
+ MOVE E,[ASCIZ \\r\16*\r\] ;TERMINATE
+ POPJ P, ; GO
+\f
+; CHECK PAIR SPACE
+
+PAIRCH: CAMG A,B
+ JRST SETTV ;O.K.
+
+DEATH1: MOVEI B,[ASCIZ /LOSSAGE--CODE AND DATA OVERLAP
+/]
+ PUSHJ P,MSGTYP
+ .VALUE
+
+;CHARACTER STRING HACKER
+
+CHACK: MOVE A,(C) ;GET TYPE
+ HLLZM A,(D) ;STORE IN NEW HOME
+ MOVE B,1(C) ;GET POINTER
+ HLRZ E,B ;-LENGHT
+ HRRM E,(D)
+ PUSH P,E+1 ; IDIVI WILL CLOBBER
+ ADDI E,4+5*2 ; ROUND AND ACCOUNT FOR DOPE WORDS
+ IDIVI E,5 ; E/ WORDS LONG
+ PUSHJ P,EBPUR ; MAKE A PURIFIED COPY
+ POP P,E+1
+ HRLI B,010700 ;MAKE POINT BYTER
+ SUBI B,1
+ MOVEM B,1(D) ;AND STORE IT
+ ANDI A,-1 ;CLEAR LH OF A
+ JUMPE A,SETLP ;JUMP IF NO REF
+ HRRZ B,-1(A) ;SEE IF PREVIOUS INSTRUCTION REFERS TO $TCHSTR
+ CAIE B,$TCHSTR ;SKIP IF IT DOES
+ JRST CHACK1 ;NO, JUST DO CHQUOTE PART
+ HRRM D,-1(A) ;CLOBBER
+CHACK1: MOVEI E,1(D)
+ HRRM E,(A) ;STORE INTO REFERENCE
+ MOVEI E,0
+ DPB E,[220400,,(A)]
+ JRST SETLP
+
+; SUBROUTINE TO COPY A HUNK OF STRUCTURE TO THE HIGH SEGMENT
+
+EBPUR: PUSH P,E
+ PUSH P,A
+ ADD E,HITOP ; GET NEW TOP
+ CAMG E,RHITOP ; SKIP IF TOO BIG
+ JRST EBPUR1
+
+; CODE TO GROW HI SEG
+
+ MOVEI A,2000
+ ADDB A,RHITOP ; NEW TOP
+ TLNE A,777776
+ JRST HIFUL
+IFN ITS,[
+ ASH A,-10. ; NUM OF BLOCKS
+ SUBI A,1 ; BLOCK TO GET
+ .CALL HIGET
+ .VALUE
+]
+
+EBPUR1: MOVEI A,-1(E) ; NEEDED TO TERMINATE BLT
+ EXCH E,HITOP
+ HRLI E,(B)
+ MOVEI B,(E)
+ BLT E,(A)
+ POP P,A
+ POP P,E
+ POPJ P,
+
+GIVCOR: SETZ
+ SIXBIT /CORBLK/
+ 1000,,0
+ 1000,,-1
+ SETZ A
+
+HIGET: SETZ
+ SIXBIT /CORBLK/
+ 1000,,100000
+ 1000,,-1
+ A
+ 401000,,400001
+
+\f
+; PROCESS AN ATOM AND ADD IT TO AN APPROPRIATE OBLIST IF IT ISN'T
+; ALREADY THERE
+
+ATOMHK: PUSH TP,$TOBLS ; SAVE OBLIST
+ PUSH TP,[0] ; FILLED IN LATER
+ PUSH TP,$TVEC ;SAVE TV POINTERS
+ PUSH TP,C
+ PUSH TP,$TVEC
+ PUSH TP,D
+ MOVE C,1(C) ;GET THE ATOM
+ PUSH TP,$TATOM ;AND SAVE
+ PUSH TP,C
+ PUSH TP,$TATOM
+ PUSH TP,[0]
+ HRRZ B,(C) ;GET OBLIST SPEC FROM ATOM
+ LSH B,1
+ ADDI B,1(TB) ;POINT TO ITS HOME
+ HRRM B,-9(TP)
+ MOVE B,(B)
+ MOVEM B,-10(TP) ; CLOBBER
+
+ SETZM 2(C) ; FLUSH CURRENT OBLIST SPEC
+ MOVEI E,0
+ MOVE D,C
+ PUSH P,[LOOKCR]
+ ADD D,[3,,3]
+ JUMPGE D,.+4
+ PUSH P,(D)
+ ADDI E,1
+ AOBJN D,.-2
+ PUSH P,E
+ MOVSI A,TOBLS
+ JRST ILOOKC
+LOOKCR:
+ MOVEM B,(TP)
+ JUMPN B,CHCKD
+
+;HERE IF THIS ATOM MUST BE PUT ON OBLIST
+
+USEATM: MOVE B,-2(TP) ; GET ATOM
+ HLRZ E,(B) ; SEE IF PURE OR NOT
+ TRNN E,400000 ; SKIP IF IMPURE
+ JRST PURATM
+ PUSH TP,$TATOM
+ PUSH TP,B
+ PUSH TP,$TOBLS
+ PUSH TP,-13(TP)
+ MCALL 2,INSERT
+
+ PUSHJ P,VALMAK ;MAKE A GLOBAL VALUE FOR THIS LOSER
+PURAT2: MOVE C,-6(TP) ;RESET POINTERS
+ MOVE D,-4(TP)
+ SUB TP,[12,,12]
+ MOVE B,(C) ;MOVE THE ENTRY
+ HLLZM B,(D) ;DON'T WANT REF POINTER STORED
+ MOVE A,1(C) ;AND MOVE ATOM
+ MOVEM A,1(D)
+ MOVEI A,1(D)
+ ANDI B,-1 ;CHECK FOR REAL REF
+ JUMPE B,SETLP1 ;DON'T SAVE THIS ATOM ON TVP
+ HRRM A,(B) ;CLOBBER CODE
+ MOVEI A,0
+ DPB A,[220400,,(B)] ; CLOBBER TVP PORTION
+ JRST SETLP
+
+
+; HERE TO MAKE A PURE ATOM
+
+PURATM: HRRZ B,-2(TP) ; POINT TO IT
+ HLRE E,-2(TP) ; - LNTH
+ MOVNS E
+ ADDI E,2
+ PUSHJ P,EBPUR ; PURE COPY
+ HRRM B,-2(TP) ; AND STORE BACK
+ MOVE B,-2(TP)
+ JUMPE 0,PURAT0
+ HRRZ D,0
+ HLRE E,0
+ SUBM D,E
+ HLRZ 0,2(D)
+ JUMPE 0,PURAT8
+ CAIG 0,HIBOT
+ FATAL INITM--PURE IMPURE LOSSAGE
+ JRST PURAT8
+
+PURAT0: HRRZ E,(C)
+ MOVE D,-2(TP) ; GET ATOM BACK
+ HRRZ 0,(D) ; GET OBLIST CODE
+ JUMPE E,PURAT9
+PURAT7: HLRZ D,1(E)
+ MOVEI D,-2(D)
+ SUBM E,D
+ HLRZ D,2(D)
+ CAILE D,HIBOT ; IF NEXT PURE & I AM ROOT
+ JUMPE 0,PURAT8 ; TAKES ADVANTAGE OF SYSTEM=0
+ JUMPE D,PURAT8
+ MOVE E,D
+ JRST PURAT7
+
+PURAT8: HLRZ D,1(E)
+ SUBI D,2
+ SUBM E,D
+ HLRE C,B
+ SUBM B,C
+ HLRZ E,2(D)
+ HRLM E,2(B)
+ HRLM C,2(D)
+ JRST PURAT6
+
+PURAT9: HLRE A,-2(TP)
+ SUBM B,A
+ HRRZM A,(C)
+
+PURAT6: MOVE B,-10(TP) ; GET BUCKET BACK
+ MOVE C,-2(TP)
+ HRRZ 0,-9(TP)
+ HRRM 0,2(C) ; STORE OBLIST IN ATOM
+PURAT1: HRRZ C,(B) ; GET CONTENTS
+ JUMPE C,HICONS ; AT END, OK
+ CAIL C,HIBOT ; SKIP IF IMPURE
+ JRST HICONS ; CONS IT ON
+ MOVEI B,(C)
+ JRST PURAT1
+
+HICONS: HRLI C,TATOM
+ PUSH P,C
+ PUSH P,-2(TP)
+ PUSH P,B
+ MOVEI B,-2(P)
+ MOVEI E,2
+ PUSHJ P,EBPUR ; MAKE PURE LIST CELL
+
+ MOVE C,(P)
+ SUB P,[3,,3]
+ HRRM B,(C) ; STORE IT
+ MOVE B,1(B) ; ATOM BACK
+ MOVE C,-6(TP) ; GET TVP SLOT
+ HRRM B,1(C) ; AND STORE
+ HLRZ 0,(B) ; TYPE OF VAL
+ MOVE C,B
+ CAIN 0,TUNBOU ; NOT UNBOUND?
+ JRST PURAT3 ; UNBOUND, NO VAL
+ MOVEI E,2 ; COUNT AGAIN
+ PUSHJ P,EBPUR ; VALUE CELL
+ MOVE C,-2(TP) ; ATOM BACK
+ HLLZS (B) ; CLEAR LH
+ MOVSI 0,TLOCI
+ MOVEM B,1(C)
+ SKIPA
+PURAT3: MOVEI 0,0
+ HRRZ A,(C) ; GET OBLIST CODE
+ MOVE A,OBTBL2(A)
+ HRRM A,2(C) ; STORE OBLIST SLOT
+ MOVEM 0,(C)
+ JRST PURAT2
+\f
+; A POSSIBLE MATCH ARRIVES HERE
+
+CHCKD: MOVE D,(TP) ;THEY MATCH!, GET EXISTING ATOM
+ MOVEI A,(D) ;GET TYPE OF IT
+ MOVE B,-2(TP) ;GET NEW ATOM
+ HLRZ 0,(B)
+ TRZ A,377777 ; SAVE ONLY 400000 BIT
+ TRZ 0,377777
+ CAIN 0,(A) ; SKIP IF WIN
+ JRST IM.PUR
+ MOVSI 0,400000
+ ANDCAM 0,(B)
+ ANDCAM 0,(D)
+ HLRZ A,(D)
+ JUMPN A,A1VAL
+ MOVE A,(B) ;MOVE VALUE
+ MOVEM A,(D)
+ MOVE A,1(B)
+ MOVEM A,1(D)
+ MOVE B,D ;EXISTING ATOM TO B
+ MOVEI 0,(B)
+ CAIL 0,HIBOT
+ JRST .+3
+ PUSHJ P,VALMAK ;MAKE A VALUE
+ JRST .+2
+ PUSHJ P,PVALM
+
+;NOW FIND ATOMS OCCURENCE IN XFER VECTOR
+
+OFFIND: MOVE D,-4(TP) ;GET CURRENT POINTER INTO TP
+ MOVE C,[-TVLNT,,TVSTRT] ;AND A COPY OF TVP
+ MOVEI A,0 ;INITIALIZE COUNTER
+ALOOP: CAMN B,1(C) ;IS THIS IT?
+ JRST AFOUND
+ ADD C,[2,,2] ;BUMP COUNTER
+ CAMG C,D
+ AOJA A,ALOOP ;NO, KEEP LOOKING
+
+ MOVEI B,[ASCIZ /LOSSAGE--ATOM DISAPPEARED
+/]
+TYPIT: PUSHJ P,MSGTYP
+ .VALUE
+
+AFOUND: LSH A,1 ;FOUND ATOM, GET REAL OFFSET
+ ADDI A,1
+ ADDI A,TVSTRT
+ MOVE C,-6(TP) ;GET TV POINTER TO NEW ATOM
+ HRRZ B,(C) ;POINT TO REFERENCE
+ SKIPE B ;ANY THERE?
+ HRRM A,(B) ;YES, CLOBBER AWAY
+ SUB TP,[12,,12]
+ MOVEI A,0
+ DPB A,[220400,,(B)] ; KILL TVP POINTER
+ JRST SETLP1 ;AND GO ON
+
+A1VAL: HLRZ C,(B) ;GET VALUE'S TYPE
+ MOVE B,D ;NOW PUT EXISTING ATOM IN B
+ CAIN C,TUNBOU ;UNBOUND?
+ JRST OFFIND ;YES, WINNER
+
+ MOVEI B,[ASCIZ /LOSSAGE--ATOM TRIES TO HAVE 2 VALUES
+/]
+ JRST TYPIT
+
+
+IM.PUR: MOVEI B,[ASCIZ /LOSSAG--ATOM TRIES TO BE BOTH PURE AND IMPURE
+/]
+ JRST TYPIT
+
+PAGLOS: MOVEI B,[ASCIZ /LOSSAGE--IMPURE CORE EXTENDS INTO HIGH SEGMENT
+/]
+ JRST TYPIT
+
+HIFUL: MOVEI B,[ASCIZ /LOSSAGE--HI SEG FULL
+/]
+ JRST TYPIT
+
+\f
+;MAKE A VALUE IN SLOT ON GLOBAL SP
+
+VALMAK: HLRZ A,(B) ;TYPE OF VALUE
+ CAIE A,400000+TUNBOU
+ CAIN A,TUNBOU ;VALUE?
+ JRST VALMA1
+ MOVE A,GLOBSP+1 ;GET POINTER TO GLOBAL SP
+ SUB A,[4,,4] ;ALLOCATE SPACE
+ CAMG A,GLOBAS+1 ;CHECK FOR OVERFLOW
+ JRST SPOVFL
+ MOVEM A,GLOBSP+1 ;STORE IT BACK
+ MOVE C,(B) ;GET TYPE CELL
+ TLZ C,400000
+ HLLZM C,2(A) ;INTO TYPE CELL
+ MOVE C,1(B) ;GET VALUE
+ MOVEM C,3(A) ;INTO VALUE SLOT
+ MOVSI C,TGATOM ;GET TATOM,,0
+ MOVEM C,(A)
+ MOVEM B,1(A) ;AND POINTER TO ATOM
+ MOVSI C,TLOCI ;NOW CLOBBER THE ATOM
+ MOVEM C,(B) ;INTO TYPE CELL
+ ADD A,[2,,2] ;POINT TO VALUE
+ MOVEM A,1(B)
+ POPJ P,
+
+VALMA1: SETZM (B)
+ POPJ P,
+
+SPOVFL: MOVEI B,[ASCIZ /LOSSAGE--GLOBAL SP OVERFLOW
+/]
+ JRST TYPIT
+
+
+PVALM: HLRZ 0,(B)
+ CAIE 0,400000+TUNBOU
+ CAIN 0,TUNBOU
+ JRST VALMA1
+ MOVEI E,2
+ PUSH P,B
+ PUSHJ P,EBPUR
+ POP P,C
+ MOVEM B,1(C)
+ MOVSI 0,TLOCI
+ MOVEM 0,(C)
+ MOVE B,C
+ POPJ P,
+\f;SET UP LIST OF INTERNAL NAMES AND ADDRESS NEEDED BY COMPILER
+
+VECTGO DUMMY1
+
+IRP A,,[FINIS,SPECBIND,WNA,WRONGT,$TLOSE,CALER1,POPUNW
+ILOC,IGLOC,IDVAL,IDVAL1,ILVAL,IGVAL,INTFLG,LCKINT,ONINT,TYPLOO,TDEFER
+IFALSE,UNAS,UNBOU,RCALL,SEGMNT,SEGLST,NUMPRI,OPSYS,SSPEC1,COMPERR
+MAKACT,MAKENV,BFRAME,TTP,TTB,$TTP,$TTB,MAKTUP,TPALOC,IBIND,SSPECS
+CILVAL,CISET,CIGVAL,CSETG,IBLOK1,IBLOCK,CLLOC,CGLOC,CASSQ,CGASSQ
+CILNT,CILNQ,CILEGQ,CEMPTY,CIEQUA,CIREST,CINTH,CIAT,CSETLO,CIN
+CIPUT,CIGET,CIGETL,CIMON,CISTRU,CIMEMQ,CIMEMB,CITOP,CIBACK,TYPSEG
+C1CONS,CICONS,CIUVEC,CIVEC,IIFORM,IILIST,CISTNG,HITOP,INCR1,TYPG,VALG,TESTR
+OTBSAV,CITYPE,CFRAME,CARGS,CFUNCT,CUTYPE,CPTYPE,CTYPEP,CTYPEQ,CCHUTY
+CIREMA,RTFALS,CIPUTP,CIGETP,CIGTPR,MPOPJ,TAB,$TAB,ICONS,CSTO,DSTO,NTPALO
+CPLUS,CTIMES,CTIME,CDIVID,CMINUS,CLQ,CLEQ,CGQ,CGEQ,CLOG,CSIN,CCOS,CATAN,CSQRT
+CFIX,CFLOAT,CEXP,CRAND,CINEQU,SPECBND,PGGIVE,PGFIND,MTYO,CMIN,CMAX,RCL,R1C,W1C
+CALLTY,CTYPEC,CTYPEW,NOTTY,CHKAB,CTMPLT,IUNWIN,UNWIN2,NOSHUF,ROOT,ERROBL,INTOBL
+CINSER,CIRMV,CLOOKU,CATOM,CIPNAM,ISTRCM,CITERP,CIPRIN,CIPRN1,CIPRNC,CGFALS
+CPATM,CP1ATM,CPCATM,CPSTR,CP1STR,CPCSTR,CPCH,CREADC,CNXTCH,CREDC1,CNXTC1
+CGBOUN,IIGLOC,MAKTU2,CIFLTZ,CIUPRS,SAT,TFA,WTYP,NAPT,PTYPE,APLQ,PURBOT,GCSBOT
+GLOTOP,TYPVEC,1STEPR,LSTRES,NODES,MAINPR,CVTYPE,CSPNAM,CSBSTR,INTBCK,CICRLF
+CERR1,CERR2,CERR3,CANDP,CORP,CSQUTA,CIMAGE,ATOSQ,CFILLE,CPRTYC,FMPOPJ
+TD.PUT,TD.GET,TD.LNT,CBYTES,MARK,MARK2G,TD.AGC,DSTORE,RCLV,NUMSAT,RMCALL,NPRFLG
+NSPOPJ,NFPOPJ,PURCLN,FRETOP,PURVEC,SWAPGC,NTTYPE,CLRSTR,VECBOT]
+ .GLOBAL A
+ ADDSQU A
+TERMIN
+
+VECRET
+
+; ROUTINE TO SORT AND PURIFY SQUOZE TABLE
+
+SQSETU: MOVE A,[SQUTBL-SQULOC+2,,SQUTBL]
+ MOVEI 0,1
+SQ2: MOVE B,(A)
+ CAMG B,2(A)
+ JRST SQ1
+ MOVEI 0,0
+ EXCH B,2(A)
+ MOVEM B,(A)
+ MOVE B,1(A)
+ EXCH B,3(A)
+ MOVEM B,1(A)
+SQ1: ADD A,[2,,2]
+ JUMPL A,SQ2
+ JUMPE 0,SQSETU
+IFE ITS,[
+STSQU: MOVE B,[440700,,SQBLK]
+ PUSHJ P,MNGNAM
+ HRROI B,SQBLK
+ MOVSI A,600001
+ GTJFN
+ FATAL CANT MAKE FIXUP FILE
+ MOVEI E,(A)
+ MOVE B,[440000,,100000]
+ OPENF
+ FATAL CANT OPEN FIXUP FILE
+ MOVE B,[444400,,SQUTBL]
+ MOVNI C,SQULOC-SQUTBL
+ SOUT
+ MOVEI A,(E)
+ CLOSF
+ JFCL
+ MOVE A,[SQUTBL-SQULOC,,SQUTBL]
+ MOVEM A,SQUPNT"
+]
+IFN ITS,[
+.GLOBAL CSIXBT
+STSQU: MOVE C,MUDSTR+2 ; CALCULATE SECOND FILE NAME FOR SQUOZE TABLE
+ PUSHJ P,CSIXBT
+ HRRI C,(SIXBIT/TAB/) ; TABxxx IS SECOND NAME OF FILE
+ MOVSS C
+ MOVEM C,SQBLK+2 ; STORE IN APPROPRIATE BLOCKS
+ MOVEM C,SQWBLK+2
+ .SUSET [.SSNAM,,SQDIR]
+ .OPEN GCHN,SQWBLK ; OPEN FILE
+ FATAL CAN'T CREATE SQUOZE FILE
+ MOVE A,[SQUTBL-SQULOC,,SQUTBL]
+ MOVEM A,SQUPNT"
+ .IOT GCHN,A
+ .CLOSE GCHN ; CLOSE THE CHANNEL
+]
+ POPJ P,
+
+RHITOP: 0
+
+OBSZ: 151.
+ 13.
+ 151.
+ 151.
+ 317.
+
+OBTBL2: ROOT+1
+ ERROBL+1
+ INTOBL+1
+ MUDOBL+1
+ INITIAL+1
+
+OBTBL: INITIAL+1-TVSTRT+TVBASE
+ MUDOBL+1-TVSTRT+TVBASE
+ INTOBL+1-TVSTRT+TVBASE
+ ERROBL+1-TVSTRT+TVBASE
+ ROOT+1-TVSTRT+TVBASE
+OBNAM: MQUOTE INITIAL
+ IMQUOTE MUDDLE
+ MQUOTE INTERRUPTS
+ MQUOTE ERRORS
+ MQUOTE ROOT
+
+OBTBL1: INITIAL+1
+ MUDOBL+1
+ INTOBL+1
+ ERROBL+1
+ ROOT+1
+
+
+IFN ITS,[
+SQWBLK: SIXBIT / 'DSK/
+ SIXBIT /SQUOZE/
+ SIXBIT /TABLE/
+]
+IFE ITS,[
+MNGNAM: MOVE A,[440700,,MUDSTR+2] ; FOR NAME HACKING
+ ILDB 0,A ; SEE IF IT IS A VERSION
+ CAIN 0,177
+ POPJ P,
+ MOVE A,B
+ ILDB 0,A
+ CAIN 0,"X ; LOOK FOR X'S
+ JRST .+3
+ MOVE B,A
+ JRST .-4
+
+ MOVE A,[440700,,MUDSTR+2]
+ ILDB 0,A
+ IDPB 0,B
+ ILDB 0,A
+ IDPB 0,B
+ ILDB 0,A
+ IDPB 0,B
+ POPJ P,
+]
+
+IFN ITS,[
+.GLOBAL VCREATE,MUDSTR
+
+DEBUG: MOVE E,[440600,,[SIXBIT /EXPERIMENTAL/]]
+ MOVEI 0,12.
+ JRST STUFF
+
+VCREATE: .SUSET [.SSNAM,,[SIXBIT /MUDSYS/]]
+ .OPEN 0,OP%
+ .VALUE
+ MOVEI 0,0 ; SET 0 TO DO THE .RCHST
+ .RCHST 0
+ .CLOSE 0
+ .FDELE DB%
+ .VALUE
+ MOVE E,[440600,,B]
+ MOVEI 0,6
+STUFF: MOVE D,[440700,,MUDSTR+2]
+STUFF1: ILDB A,E ; GET A CHAR
+ CAIN A,0 ;SUPRESS SPACES
+ MOVEI A,137 ;RUBOUT'S DON'T TYPE OUT
+ ADDI A,40 ; TO ASCII
+ IDPB A,D ; STORE
+ SOJN 0,STUFF1
+ SETZM 34
+ SETZM 35
+ SETZM 36
+ .VALUE
+
+OP%: 1,,(SIXBIT /DSK/)
+ SIXBIT /MUD%/
+ SIXBIT />/
+
+DB%: (SIXBIT /DSK/)
+ SIXBIT /MUD%/
+ SIXBIT /</
+ 0
+ 0
+]
+
+
+.GLOBAL GCDIR,ILDBLK,TILDBL,GCLDBK,LENGC,SLENGC,SGCLBK,RLENGC
+.GLOBAL SECBLK,SECLEN,RSLENG,DECBLK
+
+; ROUTINE TO DUMP OUT THE GARBAGE-COLLECTOR
+
+DUMPGC:
+IFN ITS,[
+ .SUSET [.SSNAM,,GCDIR] ; SET SNAME
+ MOVE C,MUDSTR+2 ; CREATE SECOND NAMES
+ PUSHJ P,CSIXBT
+ HRRI C,(SIXBIT /MUD/)
+ MOVS A,C ; MUDxx IS SECOND NAME
+ MOVEM A,GCLDBK+2
+ MOVEM A,SGCLBK+2
+ MOVEM A,ILDBLK+2
+ MOVEM A,GCDBLK+2 ; SMASH IN SECOND NAMES
+ MOVEM A,SGCDBK+2
+ MOVEM A,INTDBK+2
+ .OPEN 0,GCDBLK ; OPEN GC FILE
+ FATAL CANT CREATE AGC FILE
+ MOVNI A,LENGC ; CALCULATE IOT POINTER
+ ASH A,10.
+ HRLZS A
+ HRRI A,REALGC
+ .IOT 0,A ; SEND IT OUT
+ .CLOSE 0, ; CLOSE THE CHANNEL
+ .OPEN 0,SGCDBK ; OPEN GC FILE
+ FATAL CANT CREATE AGC FILE
+ MOVNI A,SLENGC ; CALCULATE IOT POINTER
+ ASH A,10.
+ HRLZS A
+ HRRI A,REALGC+RLENGC
+ .IOT 0,A ; SEND IT OUT
+ .CLOSE 0, ; CLOSE THE CHANNEL
+
+
+; ROUTINE TO DUMP THE INTERPRETER
+
+ .SUSET [.SSNAM,,INTDIR]
+ .OPEN 0,ILDBLK ; OPEN FILE TO INTERPRETER BLOCK
+ FATAL CANT FIXUP INTERPRETER
+ 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 0,[1]
+ .IOT 0,A ; GET IN PAGE MAP
+ .CLOSE 0,
+ .OPEN 0,INTDBK
+ FATAL CANT FIXUP INTERPRETER
+ 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,PAGEGC ; SKIP IF DONE
+ AOJA E,LOPFND
+ ASH A,10. ; TO WORDS
+ .ACCES 0,A
+ MOVNI B,LENGC
+ ASH B,10. ; TO WORDS
+ HRLZS B ; SWAP
+ HRRI B,AGCLD
+ .IOT 0,B
+ .CLOSE 0,
+ POPJ P, ; DONE
+
+GCDBLK: SIXBIT / 'DSK/
+ SIXBIT /AGC/
+ SIXBIT /MUD /
+
+SGCDBK: SIXBIT / 'DSK/
+ SIXBIT /SGC/
+ SIXBIT /MUD /
+
+INTDBK: 100007,,(SIXBIT /DSK/)
+ SIXBIT /TS/
+ SIXBIT /MUD/
+
+]
+IFE ITS,[
+ MOVE B,[440700,,GCLDBK]
+ PUSHJ P,MNGNAM ; VERSION TO NAME IF NECESSARY
+ HRROI B,GCLDBK
+ MOVSI A,600001
+ GTJFN
+ FATAL CANT WRITE OUT GC
+ MOVEI E,(A)
+ MOVE B,[440000,,100000]
+ OPENF
+ FATAL CANT OPEN GC FILE
+ MOVNI C,LENGC
+ ASH C,10.
+ MOVE B,[444400,,REALGC]
+ MOVEI A,(E)
+ SOUT
+ MOVEI A,(E)
+ CLOSF
+ JFCL
+ MOVEI D,LENGC+LENGC
+ MOVNI A,1
+ MOVEI B,REALGC
+ ASH B,-9.
+ HRLI B,400000
+
+ PMAP
+ ADDI B,1
+ SOJG D,.-2
+
+ MOVE B,[440700,,SGCLBK]
+ PUSHJ P,MNGNAM ; VERSION TO NAME IF NECESSARY
+ HRROI B,SGCLBK
+ MOVSI A,600001
+ GTJFN
+ FATAL CANT WRITE OUT GC
+ MOVEI E,(A)
+ MOVE B,[440000,,100000]
+ OPENF
+ FATAL CANT OPEN GC FILE
+ MOVNI C,SLENGC
+ ASH C,10.
+ MOVE B,[444400,,REALGC+RLENGC]
+ MOVEI A,(E)
+ SOUT
+ MOVEI A,(E)
+ CLOSF
+ JFCL
+ MOVEI D,SLENGC+SLENGC
+ MOVNI A,1
+ MOVEI B,REALGC+RLENGC
+ ASH B,-9.
+ HRLI B,400000
+
+ PMAP
+ ADDI B,1
+ SOJG D,.-2
+
+ MOVE B,[440700,,SECBLK]
+ PUSHJ P,MNGNAM ; VERSION TO NAME IF NECESSARY
+ HRROI B,SECBLK
+ MOVSI A,600001
+ GTJFN
+ FATAL CANT WRITE OUT GC
+ MOVEI E,(A)
+ MOVE B,[440000,,100000]
+ OPENF
+ FATAL CANT OPEN GC FILE
+ MOVNI C,SECLEN
+ ASH C,10.
+ MOVE B,[444400,,REALGC+RLENGC+RSLENG]
+ MOVEI A,(E)
+ SOUT
+ MOVEI A,(E)
+ CLOSF
+ JFCL
+
+; NOW MUNG THE THING TO BE DIFFERENT TO USE UUOS FOR DEBUGGING VERSION
+
+.GLOBAL %FXUPS,%FXEND
+
+ MOVEI A,%FXUPS
+
+%DBG1: HLRZ D,(A)
+ HRRZ A,(A)
+ LDB 0,[331100,,(A)] ; GET INS
+ MOVEI C,%TBL
+ HRRZ B,(C)
+ CAME B,0
+ AOJA C,.-2
+ CAIN B,<<(XBLT)>_<-9.>>
+ HLLZS (A)
+ LDB B,[331100,,(C)]
+ DPB B,[331100,,(A)]
+ MOVE A,D
+ JUMPN A,%DBG1
+%DBG2:
+ MOVE B,[440700,,DECBLK]
+ PUSHJ P,MNGNAM ; VERSION TO NAME IF NECESSARY
+ HRROI B,DECBLK
+ MOVSI A,600001
+ GTJFN
+ FATAL CANT WRITE OUT GC
+ MOVEI E,(A)
+ MOVE B,[440000,,100000]
+ OPENF
+ FATAL CANT OPEN GC FILE
+ MOVNI C,SECLEN
+ ASH C,10.
+ MOVE B,[444400,,REALGC+RLENGC+RSLENG]
+ MOVEI A,(E)
+ SOUT
+ MOVEI A,(E)
+ CLOSF
+ JFCL
+ MOVEI D,SECLEN+SECLEN
+ MOVNI A,1
+ MOVEI B,REALGC+RLENGC
+ ASH B,-9.
+ HRLI B,400000
+
+ PMAP
+ ADDI B,1
+ SOJG D,.-2
+
+ MOVE B,[440700,,ILDBLK]
+ SKIPE OPSYS
+ MOVE B,[440700,,TILDBL]
+ PUSHJ P,MNGNAM
+ MOVSI C,-1000
+ MOVSI A,400000
+RPA: RPACS
+ TLNE B,10000
+ TLNN B,400 ; SKIP IF NOT PRIVATE
+ SKIPA
+ MOVES (C)
+ ADDI C,777
+ ADDI A,1
+ AOBJN C,RPA
+
+ MOVNI A,1
+ CLOSF
+ FATAL CANT CLOSE STUFF
+ HRROI B,ILDBLK
+ MOVSI A,100001
+ GTJFN ; GET A JFN
+ FATAL GARBAGE COLLECTOR IS MISSING
+ HRRZS E,A ; SAVE JFN
+ MOVE B,[440000,,300000]
+ OPENF
+ FATAL CANT OPEN GC FILE
+ MOVEI A,(E) ; FIND OUT LENGTH OF MAP
+ BIN ; GET LENGTH WORD
+ HLRZ 0,B
+ CAIE 0,1776 ; TOPS20 SSAVE FILE FORMAT
+ CAIN 0,1000 ; TENEX SSAVE FILE FORMAT
+ JRST .+2
+ FATAL NOT AN SSAVE FILE
+ MOVEI A,(B) ; ISOLATE SIZE OF MAP
+ HLRE B,TP ; MUST BE SPACE FOR CRUFT
+ MOVNS B
+ CAIGE B,(A) ; ROOM?
+ FATAL NO ROOM FOR PAGE MAP (GULP)
+ 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) ; POINT TO MAP
+ CAIE 0,1000
+ JRST RPA1 ; GO TO THE TOPS20 CODE
+ LDB 0,[221100,,(A)] ; GET FORK PAGE
+ CAIE 0,PAGEGC+PAGEGC ; GOT IT?
+ AOJA A,.-2
+ JRST RPA2
+
+RPA1: ADDI A,1 ; POINT TO PROCESS PAGE NUMBER
+ LDB 0,[331100,,(A)] ; REPEAT COUNT IN 0
+ LDB B,[3300,,(A)] ; FIRST PAGE NUMBER IN B
+ ADD 0,B ; LARGEST PAGE NUMBER
+ CAIL 0,PAGEGC+PAGEGC
+ CAILE B,PAGEGC+PAGEGC
+ AOJA A,RPA1 ; NEXT PAIR OF WORDS PLEASE
+ SUBI A,1 ; POINT TO FILE PAGE NUMBER
+ SUBI B,PAGEGC+PAGEGC
+ MOVN B,B
+ ADDM B,(A) ; SET UP THE PAGE
+
+RPA2: HRRZ B,(A) ; GET PAGE
+ MOVEI A,(E) ; GET JFN
+ ASH B,9.
+ SFPTR
+ FATAL ACCESS OF FILE FAILED
+ MOVEI A,(E)
+ MOVE B,[444400,,AGCLD]
+ MOVNI C,LENGC
+ ASH C,10.
+ SOUT
+ MOVEI A,(E)
+ CLOSF
+ JFCL
+ POPJ P,
+
+; CODE TO DISTINGUISH BETWEEN TOPS20 AND TENEX AT SETUP TIME
+
+TWENTY: HRROI A,C ; RESULTS KEPT HERE
+ HRLOI B,600015
+ MOVEI C,0 ; CLEAN C UP
+ DEVST
+ JFCL
+ MOVEI A,1 ; TENEX HAS OPSYS = 1
+ CAME C,[ASCII/NUL/] ; TOPS20 GIVES "NUL"
+ MOVEM A,OPSYS ; TENEX GIVES "NIL"
+ POPJ P,
+%TBL: IRP A,,[HRRM,HRLM,MOVEM,SETZM,HLRZ,XBLT]
+ S!A <<(A)>_<-9.>>
+ TERMIN
+
+GCLDBK: ASCIZ /MDLXXX.AGC/
+SGCLBK: ASCIZ /MDLXXX.SGC/
+SECBLK: ASCIZ /MDLXXX.SEC/
+ILDBLK: ASCIZ /MDLXXX.EXE/
+TILDBL: ASCIZ /MDLXXX.SAV/
+DECBLK: ASCIZ /MDLXXX.DEC/
+]
+
+
+
+END SETUP
+\f
\ No newline at end of file
--- /dev/null
+
+TITLE INTERRUPT HANDLER FOR MUDDLE
+
+RELOCATABLE
+
+;C. REEVE APRIL 1971
+
+.INSRT MUDDLE >
+
+SYSQ
+XJRST=JRST 5,
+
+F==PVP
+G==TVP
+
+IF1,[
+IFE ITS,.INSRT STENEX >
+]
+
+PDLGRO==10000 ;AMOUNT TO GROW A PDL THAT LOSES
+NINT==72. ;MAXIMUM NUMBER OF INTERRUPTS POSSIBLE
+
+IFN ITS,[
+;SET UP LOCATION 42 TO POINT TO TSINT
+
+RMT [
+
+ZZZ==$. ;SAVE CURRENT LOCATION
+
+LOC 42
+
+ JSR MTSINT ;GO TO HANDLER
+
+LOC ZZZ
+]
+]
+
+; GLOBALS NEEDED BY INTERRUPT HANDLER
+
+.GLOBAL ONINT ; FUDGE INS EXECUTED IF NON ZERO AT START OF INTERRUPT
+.GLOBAL INTBCK ; "PC-LOSER HACK "
+.GLOBA GCFLG ;TELLS WHETHER OR NOT GARBAGE COLLECTOR IS RUNNING
+.GLOBAL GCFLCH ; FLUSH CHARS IMMEDIATE SO GC CAN SEE THEM
+.GLOBAL CORTOP ; TOP OF CORE
+.GLOBA GCINT ;TELLS GARBAGE COLLECTOR TO SIMULATE AN INTERRUPT
+.GLOBAL INTNUM,INTVEC ;TV ENTRIES CONCERNING INTERRUPTS
+.GLOBAL AGC ;CALL THE GARBAGE COLLECTOR
+.GLOBAL VECNEW,PARNEW,GETNUM ;GC PSEUDO ARGS
+.GLOBAL GCPDL ;GARBAGE COLLECTORS PDL
+.GLOBAL VECTOP,VECBOT ;DELIMIT VECTOR SPACE
+.GLOBAL PURTOP,CISTNG,SAGC
+.GLOBAL PDLBUF ;AMOUNT OF PDL GROWTH
+.GLOBAL PGROW ;POINTS TO DOPE WORD OF NEXT PDL TO GROW
+.GLOBAL TPGROW ;POINTS TO NEXT MUDDLE PDL TO GROW
+.GLOBAL TOPLEV,ERROR%,N.CHNS,CHNL1
+.GLOBAL BUFRIN,CHNL0,SYSCHR ;CHANNEL GLOBALS
+.GLOBAL IFALSE,TPOVFL,1STEPR,INTOBL,INCHAR,CURPRI,RDEVIC,RDIREC,GFALS,STATUS
+.GLOBAL PSTAT,NOTRES,IOIN2,INAME,INTFCN,CHNCNT,CHANNO,GIBLOK,ICONS,INCONS
+.GLOBAL IEVECT,INSRTX,ILOOKC,IPUT,IREMAS,IGET,CSTAK,EMERGE,CHFSWP
+.GLOBAL MTSINT ;BEGINNING OF INTERRUPT HANDLER
+.GLOBAL INTINT ;CALLED BY INITIALIZER TO TAKE CARE OF INT PCS
+.GLOBAL FRMSTK,APPLY,CHUNW,TGFALS
+.GLOBAL IPCGOT,DIRQ ;HANDLE BRANCHING OFF TO IPC KLUDGERY
+.GLOBAL MULTSG
+
+; GLOBALS FOR GC
+.GLOBAL GCTIM,GCCAUS,GCCALL,GPDLOV
+
+; GLOBALS FOR MONITOR ROUTINES
+
+.GLOBAL MONCH,MONCH0,RMONCH,RMONC0,LOCQ,SMON,BAPT,APLQ,MAKACT,NAPT
+.GLOBAL PURERR,BUFRIN,INSTAT,REALTV,DSTORE
+
+MONITOR
+
+.GLOBAL MSGTYP,MTYI,UPLO,IFLUSH,OCLOS,ERRET,MASK1,MASK2 ;SUBROUTINES USED
+.GLOBAL ERROR,LISTEN,ECHO,RRESET,MTYO,GCHAPN,P.CORE,P.TOP,QUEUES,NOTTY,TTYOP2,TTICHN
+.GLOBAL INTHLD,BNDV,SPECBE,DEMFLG
+
+; GLOBALS FOR PRE-AGC INTERRUPT
+
+.GLOBAL FRETOP,GCSTOP,FREMIN,CORTOP,P.CORE,PURBOT,GETNUM,GCKNUM,GCHPN,INTAGC
+.GLOBAL SPECBIND,SSPEC1,ILVAL
+
+
+; GLOBALS FOR COPY/WRITE HACK FOR GCDUMP AND PURIFY
+
+.GLOBAL GCDFLG,%CWINF,BUFGC,WNDBOT,WIND,WNDP,%SHWND,GPURFL,%FDBUF,PURMNG,RPURBT
+.GLOBAL NPWRIT,PVSTOR,SPSTOR,OPSYS
+
+
+
+;BEGINNING OF ACTUAL INTERRUPT HANDLER (MUST BE IMPURE)
+
+
+;***** TEMP FUDGE *******
+
+QUEUES==INTVEC
+
+\f
+; DECLARATIONS ASSOCIATED WITH INTERRUPT HANDERS AND HEADERS
+
+; SPECIAL TABLES
+
+SPECIN: IRP A,,[CHAR,CLOCK,MPV,ILOPR,WRITE,READ,IOC,PURE,SYSDOWN,INFERIOR,RUNT,REALT
+PARITY]
+ MQUOTE A,[A]INTRUP
+ TERMIN
+SPECLN==.-SPECIN
+
+; TABLE OF SPECIAL FINDING ROUTINES
+
+FNDTBL: IRP A,,[GETCHN,0,0,0,LOCGET,LOCGET,0,0,0,0,0,0,0]
+ A
+ TERMIN
+
+; TABLE OF SPECIAL SETUP ROUTINES
+
+INTBL: IRP A,,[S.CHAR,S.CLOK,S.MPV,S.ILOP,S.WMON,S.RMON,S.IOC,S.PURE,S.DOWN,S.INF
+S.RUNT,S.REAL,S.PAR]
+ A
+ S!A==.IRPCNT
+ TERMIN
+
+IFN ITS,[
+
+; EXTERNAL INTERRUPT TABLE
+
+EXTINT: REPEAT NINT-36.,0
+ REPEAT 16.,HCHAR
+ 0
+ 0
+ REPEAT 8.,HINF
+ REPEAT NINT-62.,0
+EXTIND:
+
+IRP A,,[[HCLOCK,13.],[HMPV,14.],[HILOPR,6],[HIOC,9],[HPURE,26.],[HDOWN,7],[HREAL,35.]
+[HRUNT,34.],[HPAR,28.]]
+ IRP B,C,[A]
+ LOC EXTINT+C
+ B
+ .ISTOP
+ TERMIN
+TERMIN
+
+
+LOC EXTIND
+]
+\f
+IFE ITS,[
+
+; TABLES FOR TENEX INTERRUPT SYSTEM
+
+LEVTAB: P1 ; POINTS TO INT PC HOLDERS FOR LEVS 1,2 AND 3
+ P2
+ P3
+
+CHNMSK==700000,,7 ; WILL BE MASK WORD FOR INT SET UP
+MFORK==400000
+NNETS==7 ; ALLOW 7 NETWRK INTERRUPTS
+UINTS==4
+NETCHN==36.-NNETS-UINTS-1
+NCHRS==6
+RLCHN==36.-NNETS-UINTS
+
+RMT [
+IMPURE ; IMPURE BECAUSE IT CHANGES IN MULTI-SECTION MODE
+CHNTAB: ; LOCATION OF INT ROUTINES FOR VARIOUS "CHANNELS"
+
+REPEAT NCHRS, 1,,INTCHR+3*.RPCNT
+ BLOCK 36.-NNETS-NCHRS-UINTS-1 ; THERE ARE 36. TENEX INT CHANNELS
+
+REPEAT NNETS+UINTS, 1,,INTNET+3*.RPCNT
+
+IRP A,,[[9.,TNXPDL],[17.,PWRIT],[10.,TNXEOF],[11.,TNXIOC],[12.,TNXFUL]
+[RLCHN,TNXRLT],[19.,TNXINF]]
+ IRP B,C,[A]
+ LOC CHNTAB+B
+ 1,,C
+ CHNMSK==CHNMSK+<1_<35.-B>>
+ .ISTOP
+ TERMIN
+TERMIN
+LOC CHNTAB+36.
+PURE
+]
+EXTINT:
+BLOCK 36.
+REPEAT NCHRS,SETZ HCHAR
+BLOCK NINT-NNETS-NCHRS-UINTS-36.-1
+REPEAT NNETS,SETZ HNET
+REPEAT UINTS,SETZ USRINT
+LOC EXTINT+NINT-12.
+REPEAT 3,SETZ HIOC
+LOC EXTINT+NINT-RLCHN-1
+SETZ HREAL
+LOC EXTINT+NINT-19.-1
+SETZ HINF
+LOC EXTINT+NINT
+]
+
+
+; HANDLER/HEADER PARAMETERS
+
+; HEADER BLOCKS
+
+IHDRLN==4 ; LENGTH OF HEADER BLOCK
+
+INAME==0 ; NAME OF INTERRUPT
+ISTATE==2 ; CURRENT STATE
+IHNDLR==4 ; POINTS TO LIST OF HANDLERS
+INTPRI==6 ; CONTAINS PRIORITY OF INTERRUPT
+
+IHANDL==4 ; LENGTH OF A HANDLER BLOCK
+
+INXT==0 ; POINTS TO NEXTIN CHAIN
+IPREV==2 ; POINTS TO PREV IN CHAIN
+INTFCN==4 ; FUNCTION ASSOCIATED WITH THIS HANDLER
+INTPRO==6 ; PROCESS TO RUN INT IN
+
+IFN ITS,[
+RMT [
+IMPURE
+TSINT:
+MTSINT: 0 ;INTERRUPT BITS GET STORED HERE
+TSINTR: 0 ;INTERRUPT PC WORD STORED HERE
+ JRST TSINTP ;GO TO PURE CODE
+
+; SOFTWARE INTERNAL INTERRUPTS JSR TO HERE
+
+LCKINT: 0
+ JRST DOINT
+
+PURE
+]
+]
+IFE ITS,[
+RMT [
+; JSR HERE FOR SOFTWARE INTERNAL INTERRUPTS
+
+IMPURE
+LCKINT: 0
+ JRST DOINT
+PURE
+]
+]
+\f
+
+IFN ITS,[
+
+;THE REST OF THIS CODE IS PURE
+
+TSINTP: SOSGE INTFLG ; SKIP IF ENABLED
+ SETOM INTFLG ;DONT GET LESS THAN -1
+
+ SKIPE INTBCK ; ANY INT HACKS?
+ JRST PCLOSR ; DO A PC-LOSR ON THE PROGRAM
+ MOVEM A,TSAVA ;SAVE TWO ACS
+ MOVEM B,TSAVB
+ MOVE A,TSINT ;PICK UP INT BIT PATTERN
+ JUMPL A,2NDWORD ;DONT CHECK FOR PDL OVERFLOW ETC. IF SIGN BIT ON
+
+ TRZE A,200000 ;IS THIS A PDL OVERFLOW?
+ JRST IPDLOV ;YES, GO HANDLE IT FIRST
+
+IMPCH: MOVEI B,0
+ TRNE A,20000 ;IS IT A MEMORY PROTECTION VIOLATION?
+ MOVEI B,1 ; FLAG SAME
+
+ TRNE A,40 ;ILLEGAL OP CODE?
+ MOVEI B,2 ; ALSO FLAG
+ TRNN A,400 ; IOC?
+ JRST .+3
+ SOS TSINTR
+ MOVEI B,3
+ TLNE A,200 ; PURE?
+ JRST GCPWRT ; CHECK FOR PURE WRITE FOR POSSIBLE C/W
+NOPUGC: SOJGE B,DO.NOW ; CANT WAIT AROUND
+
+;DECODE THE REST OF THE INTERRUPTS USING A TABLE
+
+2NDWORD:
+ JUMPL A,GC2 ;2ND WORD?
+ IORM A,PIRQ ;NO, INTO WORD 1
+ JRST GCQUIT ;AND DISMISS INT
+
+GC2: TLZ A,400000 ;TURN OFF SIGN BIT
+ IORM A,PIRQ2
+ TRNE A,177777 ;CHECK FOR CHANNELS
+ JRST CHNACT ;GO IF CHANNEL ACTIVITY
+]
+GCQUIT: SKIPGE INTFLG ;SKIP IF INTERRUPTS ENABLED
+ JRST INTDON ;NO, DEFER REAL HANDLING UNTIL LATER
+
+ MOVE A,TSINTR ;PICKUP RETURN WORD
+IFE ITS,[
+ SKIPE MULTSG
+ JRST MLTEX
+ TLON A,10000 ; EXEC PC?
+ SOJA A,MLTEX1 ; YES FIXUP PC
+MLTEX: TLON A,10000
+ SOS TSINTR+1
+ MOVEM A,TSINTR
+ MOVE A,TSINTR+1
+]
+MLTEX1: MOVEM A,LCKINT ;STORE ELSEWHERE
+ MOVEI A,DOINTE ;CAUSE DISMISS TO HANDLER
+IFN ITS, HRRM A,TSINTR ;STORE IN INT RETURN
+IFE ITS,[
+ SKIPE MULTSG
+ HRRM A,TSINTR+1
+ SKIPN MULTSG
+ HRRM A,TSINTR
+]
+ PUSH P,INTFLG ;SAVE INT FLAG
+ SETOM INTFLG ;AND DISABLE
+
+
+INTDON: MOVE A,TSAVA ;RESTORE ACS
+ MOVE B,TSAVB
+IFN ITS, .DISMISS TSINTR ;AND DISMISS THE INTERRUPT
+IFE ITS, DEBRK
+
+IFN ITS,[
+PCLOSR: MOVEM A,TSAVA
+ HRRZ A,TSINTR ; WHERE FROM
+ CAIG A,INTBCK
+ CAILE A,INTBEN ; AVOID TIMING ERRORS
+ JRST .+2
+ JRST INTDON
+
+ SOS A,INTBCK
+ MOVEM A,TSINTR
+ SETZM INTBCK
+ SETZM INTFLG
+ AOS INTFLG
+ MOVE TP,TPSAV(TB)
+ MOVE P,PSAV(TB)
+ MOVE A,TSAVA
+ JRST TSINTP
+]
+DO.NOW: SKIPN GPURFL
+ SKIPE GCFLG
+ JRST DLOSER ; HANDLE FATAL GC ERRORS
+ MOVSI B,1
+ SKIPGE INTFLG ; IF NOT ENABLED
+ MOVEM B,INTFLG ; PRETEND IT IS
+IFN ITS, JRST 2NDWORD
+IFE ITS, JRST GCQUIT
+
+IFE ITS,[
+
+; HERE FOR TENEX PDL OVER FLOW INTERRUPT
+
+TNXPDL: SOSGE INTFLG
+ SETOM INTFLG
+ MOVEM A,TSAVA
+ MOVEM B,TSAVB
+ JRST IPDLOV ; GO TO COMMON HANDLER
+
+; HERE FOR REAL TIMER
+
+TNXRLT: MOVEM A,TSAVA
+IFG <RLCHN-18.>, MOVEI A,<1_<35.-<RLCHN>>>
+IFLE <RLCHN-18.> MOVSI A,(<1_<35.-<RLCHN>>>)
+
+ JRST CNTSG
+
+; HERE FOR TENEX ^G AND ^S INTERRUPTS
+
+INTCHR:
+REPEAT NCHRS,[
+ MOVEM A,TSAVA
+ MOVEI A,<1_<.RPCNT>>
+ JRST CNTSG
+]
+CNTSG: MOVEM B,TSAVB
+ IORM A,PIRQ2 ; SAY FOR MUDDLE LEVEL
+ SOSGE INTFLG
+ SETOM INTFLG
+ JRST GCQUIT
+INTNET:
+REPEAT NNETS+UINTS,[
+ MOVEM A,TSAVA
+ MOVE A,[1_<.RPCNT+NETCHN>]
+ JRST CNTSG
+]
+TNXINF: MOVEM A,TSAVA
+ MOVEI A,<1_<35.-19.>>
+ JRST TNXCHN
+
+; LOW LEVEL HANDLERS FOR 10X IOC INTERRUPTS
+
+TNXEOF: MOVEM A,TSAVA
+ MOVSI A,(1_<35.-10.>)
+ JRST TNXCHN
+
+TNXIOC: MOVEM A,TSAVA
+ MOVSI A,(1_<35.-11.>)
+ JRST TNXCHN
+
+TNXFUL: MOVEM A,TSAVA
+ MOVSI A,(1_<35.-12.>)
+
+TNXCHN: IORM A,PIRQ2
+ MOVEM B,TSAVB
+ HRRZ A,TSAVA ; ASSUME JFN IS IN A (PRETTY FLAKEY BUT ...)
+ MOVEM A,IOCLOS
+ JRST DO.NOW
+]
+\f
+; HERE TO PROCESS INTERRUPTS
+
+DOINT: SKIPE INTHLD ; GLOBAL LOCK ON INTS
+ JRST @LCKINT
+ SETOM INTHLD ; DONT LET IT HAPPEN AGAIN
+ PUSH P,INTFLG
+DOINTE: SKIPE ONINT ; ANY FUDGE?
+ XCT ONINT ; YEAH, TRY ONE
+ EXCH 0,LCKINT ; RELATIVIZE PC IF FROM RSUBR
+IFE ITS, TLZ 0,777740 ; KILL EXCESS BITS
+ PUSH P,0 ; AND SAVE
+ ANDI 0,-1
+ CAMG 0,PURTOP
+ CAMGE 0,VECBOT
+ JRST DONREL
+ SUBI 0,(M) ; M IS BASE REG
+IFN ITS, TLO 0,400000+M ; INDEX IT OFF M
+IFE ITS,[
+ TLO 0,400000+M
+ SKIPN MULTSG
+ JRST .+3
+ HLL 0,(P)
+ TLO 0,400000
+]
+ EXCH 0,(P) ; AND RESTORE TO STACK
+DONREL: EXCH 0,LCKINT ; GET BACK SAVED 0
+ SETZM INTFLG ;DISABLE
+ AOS -1(P) ;INCR SAVED FLAG
+
+;NOW SAVE WORKING ACS
+
+ PUSHJ P,SAVACS
+ HLRZ A,-1(P) ; HACK FUNNYNESS FOR MPV/ILOPR
+ SKIPE A
+ SETZM -1(P) ; REALLY DISABLED
+
+DIRQ: MOVE A,PIRQ ;NOW SATRT PROCESSING
+ JFFO A,FIRQ ;COUNT BITS AND GO
+ MOVE A,PIRQ2 ;1ST DONE, LOOK AT 2ND
+ JFFO A,FIRQ2
+
+INTDN1: SKIPN GCHAPN ; SKIP IF MUST DO GC INT
+ JRST .+3
+ SETZM GCHAPN
+ PUSHJ P,INTOGC ; AND INTERRUPT
+
+ PUSHJ P,RESTAC
+
+IFN ITS,[
+ .SUSET [.SPICLR,,[0]] ; DISABLE INTS
+]
+ POP P,LCKINT
+ POP P,INTFLG
+ SETZM INTHLD ; RE-ENABLE THE WORLD
+IFN ITS,[
+ EXCH 0,LCKINT
+ HRRI 0,@0 ; EFFECTIVIZE THE ADDRESS
+ TLZ 0,37 ; KILL IND AND INDEX
+ EXCH 0,LCKINT
+ .DISMIS LCKINT
+]
+IFE ITS,[
+ SKIPN MULTSG
+ JRST @LCKINT
+ XJRST .+1 ; MAKE SURE OUT OF SECTION 0
+ 0
+ FSEG,,.+1
+ EXCH 0,LCKINT
+ TLZE 0,400000
+ ADDI 0,(M)
+ EXCH 0,LCKINT
+ JRST @LCKINT
+]
+FIRQ: PUSHJ P,GETBIT ;SET UP THE BIT TO CLOBBER IN PIRQ
+ ANDCAM A,PIRQ ;CLOBBER IT
+ ADDI B,36. ;OFSET INTO TABLE
+ JRST XIRQ ;GO EXECUTE
+
+FIRQ2: PUSHJ P,GETBIT ;PREPARE TO CLOBBER BIT
+ ANDCAM A,PIRQ2 ;CLOBBER IT
+ ADDI B,71. ;AGAIN OFFSET INTO TABLE
+XIRQ:
+ CAIE B,21 ;PDL OVERFLOW?
+ JRST FHAND ;YES, HACK APPROPRIATELY
+
+PDL2: JSP E,PDL3
+ JRST DIRQ
+
+PDL3: SKIPN A,PGROW
+ SKIPE A,TPGROW
+ JRST .+2
+ JRST (E) ; NOTHING GROWING, FALSE ALARM
+ MOVEI B,PDLGRO_-6 ;GET GROWTH SPEC
+ DPB B,[111100,,-1(A)] ;STORE GROWTH SPEC
+REAGC: MOVE C,[10.,,1] ; INDICATOR FOR AGC
+ SKIPE PGROW ; P IS GROWING
+ ADDI C,6
+ SKIPE TPGROW ; TP IS GROWING
+ ADDI C,1
+ PUSHJ P,AGC ;COLLECT GARBAGE
+ SETZM PGROW
+ SETZM TPGROW
+ AOJL A,REAGC ; IF NO CORE, RETRY
+ JRST (E)
+
+SAVACS:
+ PUSH P,PVP
+ MOVE PVP,PVSTOR+1
+IRP A,,[0,A,B,C,D,E,TVP,SP]
+ PUSH TP,A!STO(PVP)
+ SETZM A!STO(PVP) ;NOW ZERO TYPE
+ PUSH TP,A
+ TERMIN
+ PUSH TP,$TLOSE
+ PUSH TP,DSTORE
+ MOVE D,PVP
+ POP P,PVP
+ PUSH TP,PVPSTO(D)
+ PUSH TP,PVP
+ SKIPE D,DSTORE
+ MOVEM D,-13(TP) ; USE AS DSTO
+ SETZM DSTORE
+ POPJ P,
+
+RESTAC: POP TP,PVP
+ PUSH P,PVP
+ MOVE PVP,PVSTOR+1
+ POP TP,PVPSTO(PVP)
+ POP TP,DSTORE
+ SUB TP,[1,,1]
+IRP A,,[SP,TVP,E,D,C,B,A,0]
+ POP TP,A
+ POP TP,A!STO(PVP)
+ TERMIN
+ SKIPE DSTORE
+ SETZM DSTO(PVP)
+ POP P,PVP
+ POPJ P,
+
+; HERE TO DO GC INTERRUPT AND CLOSE ANY DEAD CHANNELS
+
+INTOGC: PUSH P,[N.CHNS-1]
+ MOVE PVP,PVSTOR+1
+ MOVE TVP,REALTV+1(PVP)
+ MOVEI A,CHNL1
+ SUBI A,(TVP)
+ HRLS A
+ ADD A,TVP
+ PUSH TP,$TVEC
+ PUSH TP,A
+
+INTGC1: MOVE A,(TP) ; GET POINTER
+ SKIPN B,1(A) ; ANY CHANNEL?
+ JRST INTGC2
+ HRRE 0,(A) ; INDICATOR
+ JUMPGE 0,INTGC2
+ PUSH TP,$TCHAN
+ PUSH TP,B
+ MCALL 1,FCLOSE
+
+ MOVE A,(TP)
+
+INTGC2: HLLZS (A)
+ ADD A,[2,,2]
+ MOVEM A,(TP)
+ SOSE (P)
+ JRST INTGC1
+
+ SUB P,[1,,1]
+ SUB TP,[2,,2]
+ PUSH TP,$TCHSTR
+ PUSH TP,CHQUOTE GC
+ PUSH TP,$TFLOAT ; PUSH ON TIME ARGUMENT
+ PUSH TP,GCTIM
+ PUSH TP,$TFIX ; PUSH ON THE CAUSE ARGUMENT
+ PUSH TP,GCCAUS
+ PUSH TP,$TATOM ; PUSH ON THE CALL ARGUMENT
+ MOVE A,GCCALL
+ PUSH TP,@GCALLR(A)
+ MCALL 4,INTERR
+ POPJ P,
+
+; PRE AGC INTERRUPT. CAUSED WHEN FREE STORAGE REQUEST CAN BE SATISFIED BY
+; EXTENDING CORE. IT IS CALLED "AGC" AND THE HANDLER IS PASSED THE CALLER,
+; AND THE PENDING REQUEST.
+
+
+INTAGC: MOVE A,GETNUM
+ MOVEM A,GCKNUM ; SET UP TO CAUSE INTERRUPT
+ PUSH P,C ; SAVE ARGS TO GC
+ MOVEI A,2000 ; GET WORKING SPACE
+ PUSHJ P,INTCOR ; GET IT
+ MOVSI A,TATOM ; EXAMINE BINDING OF FLAG
+ MOVE B,IMQUOTE AGC-FLAG
+ PUSHJ P,ILVAL
+ CAME A,$TUNBOUND
+ JRST INAGCO ; JUMP TO GET CORE FOR INTERRUPT
+ MOVE A,GETNUM
+ ADD A,P.TOP ; SEE IF WE CAN POSSIBLY WIN
+ ADD A,FREMIN
+ CAML A,PURBOT
+ JRST AGCCAU ; WORLD IS IN BAD SHAPE, CALL AGC
+ PUSH TP,$TTP ; BIND FLAG
+ PUSH TP,TP ; FOR UNBINDING PURPOSES
+ PUSH TP,[TATOM,,-1] ; SPECBINDS ARGS
+ PUSH TP,IMQUOTE AGC-FLAG
+ PUSH TP,$TFIX
+ PUSH TP,[-1]
+ PUSH TP,[0]
+ PUSH TP,[0]
+ PUSHJ P,SPECBIND
+
+; SET UP CALL TO HANDLER
+
+ PUSH TP,$TCHSTR ; STRING INDICATING INTERRUPT
+ PUSH TP,CHQUOTE DIVERT-AGC
+ PUSH TP,$TFIX ; PENDING REQUEST
+ PUSH TP,GETNUM
+ HLRZ C,(P)
+ PUSH TP,$TATOM
+ PUSH TP,@GCALLR(C)
+ SETZM GCHPN
+ MCALL 3,INTERR ; ENABLE INTERRUPT
+ GETYP A,A ; CHECK TO SEE IF INTERRUPT WAS ENABLED
+ HRRZ E,-6(TP) ; GET ARG FOR UNBINDING
+ PUSHJ P,SSPEC1
+ SUB TP,[8,,8] ; CLEAN OFF STACK
+ CAIE A,TFALSE ; SKIP IF NOT
+ JRST CHKWIN
+
+; CAUSE AN AGC TO HAPPEN
+
+AGCCAU: MOVE C,(P) ; INDICATOR
+ PUSHJ P,SAGC ; CALL AGC
+ JRST FINAGC
+
+; SEE WHETHER ENOUGH CORE WAS ALLOCATED
+CHKWIN: MOVE A,FRETOP
+ SUB A,GCSTOP
+ SUB A,GCKNUM ; AMOUNT NEEDED OR IN EXCESS
+ JUMPGE A,FINAGC ; JUMP IF DONE
+ MOVE A,GCKNUM
+ MOVEM A,GETNUM ; SET UP REQUEST
+ MOVE C,(P)
+ JRST AGCCAU
+FINAGC: SETZM GETNUM
+ POP P,C ; RESTORE C
+ POPJ P, ; EXIT
+
+; ROUTINE TO HANDLE INTERRUPT WHILE INTERRUPT IS RUNNING
+; IT TRIES TO ALLOCATE FOR REQUEST+ AT LEAST ONE CORE BLOCK
+
+INAGCO: MOVE A,GETNUM ; GET REQUEST
+ SUB A,GCKNUM ; CALCULATE REAL CURRENT REQUEST
+ ADDI A,1777
+ ANDCMI A,1777 ; AMOUNT WANTED
+ PUSHJ P,INTCOR ; GET IT
+ POP P,C ; RESTORE C
+ POPJ P, ; EXIT
+
+; ROUTINE TO GET CORE FOR PRE-AGC INTERRUPT. REQUEST IN A
+
+
+INTCOR: ADD A,P.TOP ; ADD TOP TO REQUEST
+ CAML A,PURBOT ; SKIP IF BELOW PURE
+ JRST AGCCA1 ; LOSE
+ MOVEM A,CORTOP ; STORE POSSIBLE CORE TOP
+ ASH A,-10. ; TO PAGES
+ PUSHJ P,P.CORE ; GET THE CORE
+ JRST AGCCA1 ; LOSE,LOSE,LOSE
+ PUSH P,B
+ MOVE B,FRETOP
+ SUBI B,2000
+ MOVE A,FRETOP
+ SETZM (B)
+ HRLI B,(B)
+ ADDI B,1
+ BLT B,-1(A)
+ POP P,B
+ MOVEM A,FRETOP
+ POPJ P, ; EXIT
+AGCCA1: MOVE C,-1(P) ; GET ARGS FOR AGC
+ SUB P,[1,,1] ; FLUSH RETURN ADDRESS
+ JRST AGCCAU+1
+
+
+
+GCALLR: MQUOTE GC-READ
+ MQUOTE BLOAT
+ MQUOTE GROW
+ IMQUOTE LIST
+ IMQUOTE VECTOR
+ IMQUOTE SET
+ IMQUOTE SETG
+ MQUOTE FREEZE
+ MQUOTE PURE-PAGE-LOADER
+ MQUOTE GC
+ MQUOTE INTERRUPT-HANDLER
+ MQUOTE NEWTYPE
+ MQUOTE PURIFY
+
+\f; OLD "ON" SETS UP EVENT AND HANDLER
+
+MFUNCTION ON,SUBR
+
+ ENTRY
+
+ HLRE 0,AB ; 0=> -2*NUM OF ARGS
+ ASH 0,-1 ; TO -NUM
+ CAME 0,[-5]
+ JRST .+3
+ MOVEI B,10(AB) ; LAST MUST BE CHAN OR LOC
+ PUSHJ P,CHNORL
+ ADDI 0,3
+ JUMPG 0,TFA ; AT LEAST 3
+ MOVEI A,0 ; SET UP IN CASE NO PROC
+ AOJG 0,ONPROC ; JUMP IF NONE
+ GETYP C,6(AB) ; CHECK IT
+ CAIE C,TPVP
+ JRST TRYFIX
+ MOVE A,7(AB) ; GET IT
+ONPROC: PUSH P,A ; SAVE AS A FLAG
+ GETYP A,(AB) ; CHECK PREV EXISTANCE
+ PUSH P,0
+ CAIN A,TATOM
+ JRST .+3
+ CAIE A,TCHSTR
+ JRST WTYP1
+ MOVEI B,(AB) ; FIND IT
+ PUSHJ P,FNDINT
+ POP P,0 ; REST NUM OF ARGS
+ JUMPN B,ON3 ; ALREADY THERE
+ SKIPE C ; SKIP IF NOTHING TO FLUSH
+ SUB TP,[2,,2]
+ PUSH TP,(AB) ; GET NAME
+ PUSH TP,1(AB)
+ PUSH TP,4(AB)
+ PUSH TP,5(AB)
+ MOVEI A,2 ; # OF ARGS TO EVENT
+ AOJG 0,ON1 ; JUMP IF NO LAST ARG
+ PUSH TP,10(AB)
+ PUSH TP,11(AB)
+ ADDI A,1
+ON1: ACALL A,EVENT
+
+ON3: PUSH TP,A
+ PUSH TP,B
+ PUSH TP,2(AB) ; NOW FCN
+ PUSH TP,3(AB)
+ MOVEI A,3 ; NUM OF ARGS
+ SKIPN (P)
+ SOJA A,ON2 ; NO PROC
+ PUSH TP,$TPVP
+ PUSH TP,7(AB)
+ON2: ACALL A,HANDLER
+ JRST FINIS
+
+
+TRYFIX: SKIPN A,7(AB)
+ CAIE C,TFIX
+ JRST WRONGT
+ JRST ONPROC
+\f
+; ROUTINE TO BUILD AN EVENT
+
+MFUNCTION EVENT,SUBR
+
+ ENTRY
+
+ HLRZ 0,AB
+ CAIN 0,-2 ; IF JUST 1
+ JRST RE.EVN ; COULD BE EVENT
+ CAIL 0,-3 ; MUST BE AT LEAST 2 ARGS
+ JRST TFA
+ GETYP A,2(AB) ; 2ND ARG MUST BE FIXED POINT PRIORITY
+ CAIE A,TFIX
+ JRST WTYP2
+ GETYP A,(AB) ; FIRST ARG SHOULD BE CHSTR
+ CAIN A,TATOM ; ALLOW ACTUAL ATOM
+ JRST .+3
+ CAIE A,TCHSTR
+ JRST WTYP1
+ CAIL 0,-5
+ JRST GOTRGS
+ CAIG 0,-7
+ JRST TMA
+ MOVEI B,4(AB)
+ PUSHJ P,CHNORL ; CHANNEL OR LOCATIVE (PUT ON STACK)
+
+GOTRGS: MOVEI B,(AB) ; NOW TRY TO FIND HEADER FOR THIS INTERRUPT
+ PUSHJ P,FNDINT ; CALL INTERNAL HACKER
+ JUMPN B,FINIS ; ALREADY ONE OF THIS NAME
+ PUSH P,C
+ JUMPE C,.+3 ; GET IT OFF STACK
+ POP TP,B
+ POP TP,A
+ PUSHJ P,MAKINT ; MAKE ONE FOR ME
+ MOVSI 0,TFIX
+ MOVEM 0,INTPRI(B) ; SET UP PRIORITY
+ MOVE 0,3(AB)
+ MOVEM 0,INTPRI+1(B)
+CH.SPC: POP P,C ; GET CODE BACK
+ SKIPGE C
+ PUSHJ P,DO.SPC ; DO ANY SPECIAL HACKS
+ JRST FINIS
+
+RE.EVN: GETYP 0,(AB)
+ CAIE 0,TINTH
+ JRST TFA ; ELSE SAY NOT ENOUGH
+ MOVE B,1(AB) ; GET IT
+ SETZM ISTATE+1(B) ; MAKE SURE ENABLED
+ SETZB D,C
+ GETYP A,INAME(B) ; CHECK FOR CHANNEL
+ CAIN A,TCHAN ; SKIP IF NOT
+ HRROI C,SS.CHA ; SET UP CHANNEL HACK
+ HRLZ E,INTPRI(B) ; GET POSSIBLE READ/WRITE BITS
+ TLNE E,.WRMON+.RDMON ; SKIP IF NOT MONITORS
+ PUSHJ P,GETNM1
+ JUMPL C,RE.EV1
+ MOVE B,INAME+1(B) ; CHECK FOR SPEC
+ PUSHJ P,SPEC1
+ MOVE B,1(AB) ; RESTORE IHEADER
+RE.EV1: PUSH TP,INAME(B)
+ PUSH TP,INAME+1(B)
+ PUSH P,C
+ MOVSI C,TATOM
+ PUSH TP,$TATOM
+ SKIPN D
+ MOVE D,MQUOTE INTERRUPT
+ PUSH TP,D
+ MOVE A,INAME(B)
+ MOVE B,INAME+1(B) ; GET IT
+ PUSHJ P,IGET ; LOOK FOR IT
+ JUMPN B,FINIS ; RETURN IT
+ MOVE A,(TB)
+ MOVE B,1(TB)
+ POP TP,D
+ POP TP,C
+ PUSH TP,(AB)
+ PUSH TP,1(AB)
+ PUSHJ P,IPUT ; REESTABLISH IT
+ MOVE A,(AB)
+ MOVE B,1(AB)
+ JRST CH.SPC
+
+\f
+; FUNCTION TO GENERATE A HANDLER FOR A GIVEN INTERRUPT
+
+MFUNCTION HANDLER,SUBR
+
+ ENTRY
+
+ HLRZ 0,AB
+ CAIL 0,-2 ; MUST BE 2 OR MORE ARGS
+ JRST TFA
+ GETYP A,(AB)
+ CAIE A,TINTH ; EVENT?
+ JRST WTYP1
+ GETYP A,2(AB)
+ CAIN 0,-4 ; IF EXACTLY 2
+ CAIE A,THAND ; COULD BE HANDLER
+ JRST CHEVNT
+
+ MOVE B,3(AB) ; GET IT
+ SKIPN IPREV+1(B) ; SKIP IF ALREADY IN USE
+ JRST HNDOK
+ MOVE D,1(AB) ; GET EVENT
+ SKIPN D,IHNDLR+1(D) ; GET FIRST HANDLER
+ JRST BADHND
+ CAMN D,B ; IS THIS IT?
+ JRST HFINIS ; YES, ALREADY "HANDLED"
+ MOVE D,INXT+1(D) ; GO TO NEXT HANDLER
+ JUMPN D,.-3
+BADHND: ERRUUO EQUOTE HANDLER-ALREADY-IN-USE
+
+CHEVNT: CAIG 0,-7 ; SKIP IF LESS THAN 4
+ JRST TMA
+ PUSH TP,$TPVP ; SLOT FOR PROCESS
+ PUSH TP,[0]
+ CAIE 0,-6 ; IF 3, LOOK FOR PROC
+ JRST NOPROC
+ GETYP 0,4(AB)
+ CAIE 0,TPVP
+ JRST WTYP3
+ MOVE 0,5(AB)
+ MOVEM 0,(TP)
+
+NOPROC: PUSHJ P,APLQ
+ JRST NAPT
+ PUSHJ P,MHAND ; MAKE THE HANDLER
+ MOVE 0,1(TB) ; GET PROCESS
+ MOVEM 0,INTPRO+1(B) ; AND PUT IT INTO HANDLER
+ MOVSI 0,TPVP ; SET UP TYPE
+ MOVEM 0,INTPRO(B)
+ MOVE 0,2(AB) ; SET UP FUNCTION
+ MOVEM 0,INTFCN(B)
+ MOVE 0,3(AB)
+ MOVEM 0,INTFCN+1(B)
+
+HNDOK: MOVE D,1(AB) ; PICK UP EVEENT
+ MOVE E,IHNDLR+1(D) ; GET POINTER TO HANDLERS
+ MOVEM B,IHNDLR+1(D) ; PUT NEW ONE IN
+ MOVSI 0,TINTH ; GET INT HDR TYPE
+ MOVEM 0,IPREV(B) ; INTO BACK POINTER
+ MOVEM D,IPREV+1(B) ; AND POINTER ITSELF
+ MOVEM E,INXT+1(B) ; NOW NEXT POINTER
+ MOVSI 0,THAND ; NOW HANDLER TYPE
+ MOVEM 0,IHNDLR(D) ; SET TYPE IN HEADER
+ MOVEM 0,INXT(B)
+ JUMPE E,HFINIS ; JUMP IF HEADER WAS EMPTY
+ MOVEM 0,IPREV(E) ; FIX UP ITS PREV
+ MOVEM B,IPREV+1(E)
+HFINIS: MOVSI A,THAND
+ JRST FINIS
+
+\f
+
+; FUNCTIONS TO SET TIME LIMITS FOR REALTIME AND RUNTIME INTS
+
+IFN ITS,[
+
+MFUNCTION RUNTIMER,SUBR
+
+ ENTRY
+
+ CAMG AB,[-3,,0]
+ JRST TMA
+ JUMPGE AB,RNTLFT
+ GETYP 0,(AB)
+ JFCL 10,.+1
+ MOVE A,1(AB)
+ CAIE 0,TFIX
+ JRST RUNT1
+ IMUL A,[245761.]
+ JRST RUNT2
+
+RUNT1: CAIE 0,TFLOAT
+ JRST WTYP1
+ FMPR A,[245760.62]
+ MULI A,400 ; FIX IT
+ TSC A,A
+ ASH B,(A)-243
+ MOVE A,B
+RUNT2: JUMPL A,OUTRNG ; NOT FOR NEG #
+ JFCL 10,OUTRNG
+ .SUSET [.SRTMR,,A]
+ MOVE A,(AB)
+ MOVE B,1(AB)
+ JRST FINIS
+RNTLFT: .SUSET [.RRTMR,,B]
+ JUMPL B,IFALSE ; RETURN FALSE IF NONE SET
+ IDIV B,[245761.] ; TO SECONDS
+ MOVSI A,TFIX
+ JRST FINIS
+
+]
+.TIMAL==5
+.TIMEL==1
+
+MFUNCTION REALTIMER,SUBR
+
+ ENTRY
+
+ CAMG AB,[-3,,0]
+ JRST TMA
+ JUMPGE AB,RLTPER
+ JFCL 10,.+1
+ GETYP 0,(AB)
+ MOVE A,1(AB)
+ CAIE 0,TFIX
+ JRST REALT1
+IFN ITS, IMULI A,60. ; TO 60THS OF SEC
+IFE ITS, IMULI A,1000. ; TO MILLI
+ JRST REALT2
+
+REALT1: CAIE 0,TFLOAT
+ JRST WTYP1
+IFN ITS, FMPRI A,(60.0)
+IFE ITS, FMPRI A,(1000.0)
+ MULI A,400
+ TSC A,A
+ ASH B,(A)-243
+ MOVE A,B
+
+REALT2: JUMPL A,OUTRNG
+ JFCL 10,OUTRNG
+ MOVEM A,RLTSAV
+IFN ITS,[
+ MOVE B,[200000,,A]
+ SKIPN A
+ MOVSI B,400000
+ .REALT B,
+ JFCL
+]
+IFE ITS,[
+ MOVE A,[MFORK,,.TIMAL] ; FLUSH CURRENT FIRST
+ TIMER
+ JRST TIMERR
+ SKIPN B,RLTSAV
+ JRST RETRLT
+ HRRI A,.TIMEL
+ MOVEI C,RLCHN
+ TIMER
+ JRST TIMERR
+RETRLT: MOVE A,(AB)
+ MOVE B,1(AB)
+ JRST FINIS
+
+TIMERR: MOVNI A,1
+ PUSHJ P,TGFALS
+ JRST FINIS
+
+RLTPER: SKIPGE B,RLTSAV
+ JRST IFALSE
+IFN ITS, IDIVI B,60. ; BACK TO SECONDS
+IFE ITS, IDIVI B,1000.
+ MOVSI A,TFIX
+ JRST FINIS
+
+
+; FUNCTIONS TO ENABLE AND DISABLE INTERRUPTS
+
+MFUNCTION %ENABL,SUBR,ENABLE
+
+ PUSHJ P,GTEVNT
+ SETZM ISTATE+1(B)
+ JRST FINIS
+
+MFUNCTION %DISABL,SUBR,DISABLE
+
+
+ PUSHJ P,GTEVNT
+ SETOM ISTATE+1(B)
+ JRST FINIS
+
+GTEVNT: ENTRY 1
+ GETYP 0,(AB)
+ CAIE 0,TINTH
+ JRST WTYP1
+ MOVE A,(AB)
+ MOVE B,1(AB)
+ POPJ P,
+
+DO.SPC: HRRO C,INTBL(C) ; POINT TO SPECIAL CODE
+ HLRZ 0,AB ; - TWO TIMES NUM ARGS
+ PUSHJ P,(C) ; CALL ROUTINE
+ JUMPE E,CPOPJ ; NO BITS TO ENABLE, LEAVE
+IFE ITS,[
+ PUSH TP,A
+ PUSH TP,B
+ MOVE B,1(TB) ; CHANNEL
+ MOVE 0,CHANNO(B)
+ MOVEM 0,(E) ; SAVE IN TABLE
+ MOVEI E,(E)
+ SUBI E,NETJFN-NETCHN
+ MOVE A,0 ; SETUP FOR MTOPR
+ MOVEI B,24
+ MOVSI C,(E)
+ TLO C,770000 ; DONT SETUP INR/INS
+ MTOPR
+ MOVEI 0,1
+ MOVNS E
+ LSH 0,35.(E)
+ IORM 0,MASK1
+ MOVE B,MASK1
+ MOVEI A,MFORK
+ AIC
+
+ POP TP,B
+ POP TP,A
+ POPJ P, ; ***** TEMP ******
+]
+IFN ITS,[
+ CAILE E,35. ; SKIP IF 1ST WORD BIT
+ JRST SETW2
+ LSH 0,-1(E)
+
+ IORM 0,MASK1 ; STORE IN PROTOTYPE MASK
+ .SUSET [.SMASK,,MASK1]
+ POPJ P,
+
+SETW2: LSH 0,-36.(E)
+ IORM 0,MASK2 ; SET UP PROTO MASK2
+ .SUSET [.SMSK2,,MASK2]
+ POPJ P,
+]
+
+; ROUTINE TO CHECK FOR CHANNEL OR LOCATIVE
+
+CHNORL: GETYP A,(B) ; GET TYPE
+ CAIN A,TCHAN ; IF CHANNEL
+ JRST CHNWIN
+ PUSH P,0
+ PUSHJ P,LOCQ ; ELSE LOOCATIVE
+ JRST WRONGT
+ POP P,0
+CHNWIN: PUSH TP,(B)
+ PUSH TP,1(B)
+ POPJ P,
+\f
+; SUBROUTINE TO FIND A HANDLER OF A GIVEN NAME
+
+FNDINT: PUSHJ P,FNDNM
+ JUMPE B,CPOPJ
+ PUSHJ P,SPEC1 ; COULD BE FUNNY
+
+INTASO: PUSH P,C ; C<0 IF SPECIAL
+ PUSH TP,A
+ PUSH TP,B
+ MOVSI C,TATOM
+ SKIPN D ; COULD BE CHANGED FOR MONITOR
+ MOVE D,MQUOTE INTERRUPT
+ PUSH TP,C
+ PUSH TP,D
+ PUSHJ P,IGET
+ MOVE D,(TP)
+ SUB TP,[2,,2]
+ POP P,C ; AND RESTOR SPECIAL INDICATOR
+ SKIPE B ; IF FOUND
+ SUB TP,[2,,2] ; REMOVE CRUFT
+CPOPJ: POPJ P, ; AND RETURN
+
+; CHECK FOR SPECIAL INTERNAL INTERRUPT HACK
+
+SPEC1: MOVSI C,-SPECLN ; BUILD AOBJN PNTR
+SPCLOP: CAME B,@SPECIN(C) ; SKIP IF SPECIAL
+ AOBJN C,.-1 ; UNTIL EXHAUSTED
+ JUMPGE C,.+3
+ SKIPE E,FNDTBL(C)
+ JRST (E)
+ MOVEI 0,-1(TB) ; SEE IF OK
+ CAIE 0,(TP)
+ JRST TMA
+ POPJ P,
+
+; ROUTINE TO CREATE A NEW INTERRUPT (INTERNAL ONLY--NOT ITS FLAVOR)
+
+MAKINT: JUMPN C,GOTATM ; ALREADY HAVE NAME, GET THING
+ MOVEI B,(AB) ; POINT TO STRING
+ PUSHJ P,CSTAK ; CHARS TO STAKC
+ MOVE B,INTOBL+1
+ PUSHJ P,INSRTX
+ MOVE D,MQUOTE INTERRUPT
+GOTATM: PUSH TP,$TINTH ; MAKE SLOT FOR HEADER BLOCK
+ PUSH TP,[0]
+ PUSH TP,A
+ PUSH TP,B ; SAVE ATOM
+ PUSH TP,$TATOM
+ PUSH TP,D
+ MOVEI A,IHDRLN*2
+ PUSHJ P,GIBLOK
+ MOVE A,-3(TP) ; GET NAME AND STORE SAME
+ MOVEM A,INAME(B)
+ MOVE A,-2(TP)
+ MOVEM A,INAME+1(B)
+ SETZM ISTATE+1(B)
+ MOVEM B,-4(TP) ; STASH HEADER
+ POP TP,D
+ POP TP,C
+ EXCH B,(TP)
+ MOVSI A,TINTH
+ EXCH A,-1(TP) ; INTERNAL PUT CALL
+ PUSHJ P,IPUT
+ POP TP,B
+ POP TP,A
+ POPJ P,
+
+; FIND NAME OF INTERRUPT
+
+FNDNM: GETYP A,(B) ; TYPE
+ CAIE A,TCHSTR ; IF STRING
+ JRST FNDATM ; DONT HAVE ATOM, OTHERWISE DO
+ PUSHJ P,IILOOK
+ JRST .+2
+FNDATM: MOVE B,1(B)
+ SETZB C,D ; PREVENT LOSSAGE LATER
+ MOVSI A,TATOM
+
+; THE NEXT 2 INSTRUCTIONS ARE A KLUDGE TO GET THE RIGHT ERROR ATOM
+
+ CAMN B,IMQUOTE ERROR
+ MOVE B,MQUOTE ERROR,ERROR,INTRUP
+ POPJ P,
+
+IILOOK: PUSHJ P,CSTAK ; PUT CHRS ON STACK
+ MOVSI A,TOBLS
+ MOVE B,INTOBL+1
+ JRST ILOOKC ; LOOK IT UP
+\f
+; ROUTINE TO MAKE A HANDLER BLOCK
+
+MHAND: MOVEI A,IHANDL*2
+ JRST GIBLOK ; GET BLOCK
+
+; HERE TO GET CHANNEL FOR "CHAR" INTERRUPT
+
+GETCHN: GETYP 0,(TB) ; GET TYPE
+ CAIE 0,TCHAN ; CHANNL IS WINNER
+ JRST WRONGT
+ MOVE A,(TB) ; USE THE CHANNEL TO NAME THE INTERRUPT
+ MOVE B,1(TB)
+ SKIPN CHANNO(B) ; SKIP IF WINNING CHANNEL
+ JRST CBDCHN ; LOSER
+ POPJ P,
+
+LOCGET: GETYP 0,(TB) ; TYPE
+ CAIN 0,TCHAN ; SKIP IF LOCATIVE
+ JRST WRONGT
+ MOVE D,B
+ MOVE A,(TB)
+ MOVE B,1(TB) ; GET LOCATIVE
+ POPJ P,
+
+; FINAL MONITOR SETUP ROUTINES
+
+S.RMON: SKIPA E,[.RDMON,,]
+S.WMON: MOVSI E,.WRMON
+ PUSH TP,A
+ PUSH TP,B
+ HLRM E,INTPRI(B) ; SAVE BITS
+ MOVEI B,(TB) ; POINT TO LOCATIVE
+ HRRZ A,FSAV(TB)
+ CAIN A,OFF
+ MOVSI D,(ANDCAM E,) ; KILL INST
+ CAIN A,EVENT
+ MOVSI D,(IORM E,)
+ PUSHJ P,SMON ; GO DO IT
+ POP TP,B
+ POP TP,A
+ MOVEI E,0
+ POPJ P,
+\f
+
+; SPECIAL SETUP ROUTINES FOR INITIAL INTERRUPTS
+
+IFN ITS,[
+S.CHAR: MOVE E,1(TB) ; GET CHANNEL
+ MOVE 0,RDEVIC(E)
+ ILDB 0,0 ; 1ST CHAR TO 0
+ CAIE 0,"T ; TTY
+ JRST .+3 ; NO
+ MOVEI 0,C.INTL
+ XORM 0,-2(E) ; IN CASE OUTPUT
+ MOVE E,CHANNO(E)
+ ADDI E,36. ; GET CORRECT MASK BIT
+ONEBIT: MOVEI 0,1 ; BIT FOR INT TO RET
+ POPJ P,
+]
+IFE ITS,[
+S.CHAR: MOVE E,1(TB)
+ MOVEI 0,C.INTL
+ XORM 0,-2(E) ; IN CASE OUTPUT
+ MOVE 0,RDEVIC(E)
+ ILDB 0,0 ; 1ST CHAR
+ PUSH P,A
+ CAIE 0,"N ; NET ?
+ JRST S.CHA1
+
+ MOVEI A,0
+ HRRZ 0,CHANNO(E)
+ MOVE E,[-NNETS,,NETJFN]
+ CAMN 0,(E)
+ JRST S.CHA2
+ SKIPN (E)
+ MOVE A,E ; REMEMBER WHERE
+ AOBJN E,.-4
+ TLNN A,-1
+ FATAL NO MORE NETWORK
+ SKIPA E,A
+S.CHA1: MOVEI E,0
+S.CHA2: POP P,A
+ POPJ P,
+]
+
+
+; SPECIAL FOR CLOCK
+IFN ITS,[
+S.DOWN: SKIPA E,[7]
+S.CLOK: MOVEI E,13. ; FOR NOW JUST GET BIT #
+ JRST ONEBIT
+
+S.PAR: MOVEI E,28.
+ JRST ONEBIT
+
+; RUNTIME AND REALTIME INTERRUPTS
+
+S.RUNT: SKIPA E,[34.]
+S.REAL: MOVEI E,35.
+ JRST ONEBIT
+
+S.IOC: SKIPA E,[9.] ; IO CHANNEL ERROR
+S.PURE: MOVEI E,26.
+ JRST ONEBIT
+
+; MPV AND ILOPR
+
+S.MPV: SKIPA E,[14.] ; BIT POS
+S.ILOP: MOVEI E,6
+ JRST ONEBIT
+
+; HERE TO TURN ALL INFERIOR INTS
+
+S.INF: MOVEI E,36.+16.+2 ; START OF BITS
+ MOVEI 0,37 ; 8 BITS WORTH
+ POPJ P,
+]
+IFE ITS,[
+S.PURE:
+S.MPV:
+S.ILOP:
+S.DOWN:
+S.CLOK:
+S.PAR:
+
+
+S.RUNT: ERRUUO EQUOTE INTERRUPT-UNAVAILABLE-ON-TENEX
+S.IOC: MOVEI 0,7 ; 3 BITS FOR EOF/FULL/ERROR
+ MOVEI E,10.
+ POPJ P,
+
+S.INF:
+S.REAL: MOVEI E,0
+ POPJ P,
+]
+
+
+; HERE TO HANDLE ITS INTERRUPTS
+
+FHAND: SKIPN D,EXTINT(B) ; SKIP IF HANDLERS ARE POSSIBLE
+ JRST DIRQ
+ JRST (D)
+
+IFN ITS,[
+; SPECIAL CHARACTER HANDLERS
+
+HCHAR: MOVEI D,CHNL0+1
+ ADDI D,(B) ; POINT TO CHANNEL SLOT
+ ADDI D,(B)
+ SKIPN D,-72.(D) ; PICK UP CHANNEL
+ JRST IPCGOT ;WELL, IT GOTTA BEE THE THE IPC THEN
+ PUSH TP,$TCHAN
+ PUSH TP,D
+ LDB 0,[600,,STATUS(D)] ; GET DEVICE CODE
+ CAILE 0,2 ; SKIP IF A TTY
+ JRST HNET ; MAYBE NETWORK CHANNEL
+ HRRZ 0,-2(D)
+ TRNN 0,C.READ
+ JRST HMORE
+ CAMN D,TTICHN+1
+ SKIPE DEMFLG ; SKIP IF NOT DEMON
+ JRST .+3
+ SKIPN NOTTY
+ JRST HCHR11
+ MOVE B,D ; CHAN TO B
+ PUSH P,A
+ PUSHJ P,TTYOP2 ; RE-GOBBLE TTY
+ POP P,A
+ MOVE D,(TP)
+HCHR11: MOVE D,CHANNO(D) ; GET ITS CHANNEL
+ PUSH P,D ; AND SAVE IT
+ .CALL HOWMNY ; GET # OF CHARS
+ MOVEI B,0 ; IF TTY GONE, NO CHARS
+RECHR: ADDI B,1 ; BUMP BY ONE FOR SOSG
+ MOVEM B,CHNCNT(D) ; AND SAVE
+ IORM A,PIRQ2 ; LEAVE THE INT ON
+
+CHRLOO: MOVE D,(P) ; GET CHNNAEL NO.
+ SOSG CHNCNT(D) ; GET COUNT
+ JRST CHRDON
+
+ MOVE B,(TP)
+ MOVE D,BUFRIN(B) ; GET EXTRA BUFFER
+ XCT IOIN2(D) ; READ CHAR
+ JUMPL A,CHRDON ; NO CHAR THERE, FORGET IT
+ PUSH TP,$TCHSTR
+ PUSH TP,CHQUOTE CHAR
+ PUSH TP,$TCHRS ; SAVE CHAR FOR CALL
+ PUSH TP,A
+ PUSH TP,$TCHAN ; SAVE CHANNEL
+ PUSH TP,B
+ PUSHJ P,INCHAR ; PUT CHAR IN USERS BUFFER
+ MCALL 3,INTERRUPT ; RUN THE HANDLERS
+ JRST CHRLOO ; AND LOOP
+
+CHRDON: .CALL HOWMNY
+ MOVEI B,0
+ MOVEI A,1 ; SET FOR PI WORD CLOBBER
+ LSH A,(D)
+ JUMPG B,RECHR ; ANY MORE?
+ ANDCAM A,PIRQ2
+ SUB P,[1,,1]
+ SUB TP,[2,,2]
+ JRST DIRQ
+
+
+\f
+; HERE FOR NET CHANNEL INTERRUPT
+
+HNET: CAIE 0,26 ; NETWORK?
+ JRST HSTYET ; HANDLE PSEUDO TTY ETC.
+ PUSH TP,$TATOM
+ PUSH TP,MQUOTE CHAR,CHAR,INTRUP
+ PUSH TP,$TUVEC
+ PUSH TP,BUFRIN(D)
+ PUSH TP,$TCHAN
+ PUSH TP,D
+ MOVE B,D ; CHAN TO B
+ PUSHJ P,INSTAT ; UPDATE THE NETWRK STATE
+ MCALL 3,INTERRUPT
+ SUB TP,[2,,2]
+ JRST DIRQ
+
+HMORE:
+HSTYET: PUSH TP,$TATOM
+ PUSH TP,MQUOTE CHAR,CHAR,INTRUP
+ PUSH TP,$TCHAN
+ PUSH TP,D
+ MCALL 2,INTERRUPT
+ SUB TP,[2,,2]
+ JRST DIRQ
+
+]
+CBDCHN: ERRUUO EQUOTE BAD-CHANNEL
+
+IFN ITS,[
+
+HCLOCK: PUSH TP,$TCHSTR
+ PUSH TP,CHQUOTE CLOCK
+ MCALL 1,INTERRUPT
+ JRST DIRQ
+
+HRUNT: PUSH TP,$TATOM
+ PUSH TP,MQUOTE RUNT,RUNT,INTRUP
+ MCALL 1,INTERRUPT
+ JRST DIRQ
+]
+HREAL: PUSH TP,$TATOM
+ PUSH TP,MQUOTE REALT,REALT,INTRUP
+ MCALL 1,INTERRUPT
+ JRST DIRQ
+IFN ITS,[
+HPAR: MOVE A,MQUOTE PARITY,PARITY,INTRUP
+ JRST HMPV1
+
+HMPV: MOVE A,MQUOTE MPV,MPV,INTRUP
+ JRST HMPV1
+
+HILOPR: MOVE A,MQUOTE ILOPR,ILOPR,INTRUP
+ JRST HMPV1
+
+HPURE: MOVE A,MQUOTE PURE,PURE,INTRUP
+HMPV1: PUSH TP,$TATOM
+ PUSH TP,A
+ PUSH P,LCKINT ; SAVE LOCN
+ PUSH TP,$TATOM
+ PUSH TP,A
+ PUSH TP,$TWORD
+ PUSH TP,LCKINT
+ MCALL 2,EMERGENCY
+ POP P,A
+ MOVE C,(TP)
+ SUB TP,[2,,2]
+ JUMPN B,DIRQ
+
+ PUSH TP,$TATOM
+ PUSH TP,EQUOTE DANGEROUS-INTERRUPT-NOT-HANDLED
+ PUSH TP,$TATOM
+ PUSH TP,C
+ PUSH TP,$TWORD
+ PUSH TP,A
+ MCALL 3,ERROR
+ JRST DIRQ
+
+\f
+
+; HERE TO HANDLE SYS DOWN INTERRUPT
+
+HDOWN: PUSH TP,$TATOM
+ PUSH TP,MQUOTE SYSDOWN,SYSDOWN,INTRUP
+ .DIETI A, ; HOW LONG?
+ PUSH TP,$TFIX
+ PUSH TP,A
+ PUSH P,A ; FOR MESSAGE
+ MCALL 2,INTERRUPT
+ POP P,A
+ JUMPN B,DIRQ
+ .SUSET [.RTTY,,B] ; DO WE NOW HAVE A TTY AT ALL?
+ JUMPL B,DIRQ ; DONT HANG AROUND
+ PUSH P,A
+ MOVEI B,[ASCIZ /
+Excuse me, SYSTEM going down in /]
+ SKIPG (P) ; SKIP IF REALLY GOING DOWN
+ MOVEI B,[ASCIZ /
+Excuse me, SYSTEM has been REVIVED!
+/]
+ PUSHJ P,MSGTYP
+ POP P,B
+ JUMPE B,DIRQ
+ IDIVI B,30. ; TO SECONDS
+ IDIVI B,60. ; A/ SECONDS B/ MINUTES
+ JUMPE B,NOMIN
+ PUSH P,C
+ PUSHJ P,DECOUT
+ MOVEI B,[ASCIZ / minutes /]
+ PUSHJ P,MSGTYP
+ POP P,B
+ JRST .+2
+NOMIN: MOVEI B,(C)
+ PUSHJ P,DECOUT
+ MOVEI B,[ASCIZ / seconds.
+/]
+ PUSHJ P,MSGTYP
+ JRST DIRQ
+
+; TWO DIGIT DEC OUT FROM B/
+
+DECOUT: IDIVI B,10.
+ JUMPE B,DECOU1 ; NO TEN
+ MOVEI A,60(B)
+ PUSHJ P,MTYO
+DECOU1: MOVEI A,60(C)
+ JRST MTYO
+]
+\f
+; HERE TO HANDLE I/O CHANNEL ERRORS
+
+HIOC:
+IFN ITS,[
+ .SUSET [.RAPRC,,A] ; CONTAINS CHANNEL OF MOST RECENT LOSSAGE
+ LDB A,[330400,,A] ; GET CHAN #
+ MOVEI C,(A) ; COPY
+]
+ PUSH TP,$TATOM ; PUSH ERROR
+ PUSH TP,EQUOTE FILE-SYSTEM-ERROR
+IFE ITS, MOVE C,IOCLOS ; GET JFN
+ PUSH TP,$TCHAN
+ ASH C,1 ; GET CHANNEL
+ ADDI C,CHNL0+1 ; GET CHANNEL VECTOR
+ PUSH TP,(C)
+IFN ITS,[
+ LSH A,23. ; DO A .STATUS
+ IOR A,[.STATUS A]
+ XCT A
+]
+IFE ITS,[
+ MOVNI A,1 ; GET "MOST RECENT ERROR"
+]
+ MOVE B,(TP)
+IFN ITS, PUSHJ P,GFALS ; GEN NAMED FALSE
+IFE ITS, PUSHJ P,TGFALS
+ PUSH TP,A
+ PUSH TP,B
+ PUSH TP,$TATOM
+ PUSH TP,MQUOTE IOC,IOC,INTRUP
+
+ PUSH TP,A
+ PUSH TP,B
+ PUSH TP,-7(TP)
+ PUSH TP,-7(TP)
+ MCALL 3,EMERGENCY
+ JUMPN B,DIRQ1 ; JUMP IF HANDLED
+ MCALL 3,ERROR
+ JRST DIRQ
+
+DIRQ1: SUB TP,[6,,6]
+ JRST DIRQ
+]
+; HANDLE INFERIOR KNOCKING AT THE DOOR
+
+HINF:
+IFN ITS, SUBI B,36.+16.+2 ; CONVERT TO INF #
+IFE ITS, MOVEI B,0
+ PUSH TP,$TATOM
+ PUSH TP,MQUOTE INFERIOR,INFERIOR,INTRUP
+ PUSH TP,$TFIX
+ PUSH TP,B
+ MCALL 2,INTERRUPT
+ JRST DIRQ
+\f
+IFE ITS,[
+
+; HERE FOR TENEX INTS (FIRST CUT)
+
+MFUNCTION %ACCHRS,SUBR,[ACTIVATE-CHARS]
+
+ ENTRY
+
+ JUMPGE AB,RETCHR
+ CAMGE AB,[-3,,]
+ JRST TMA
+
+ GETYP A,(AB)
+ CAIE A,TCHSTR
+ JRST WTYP1
+ HRRZ D,(AB) ; CHECK LENGTH
+ MOVEI C,0 ; SEE IF ANY NET CHANS IN USE
+ MOVE A,[-NNETS,,NETJFN]
+ SKIPE (A)
+ SUBI C,1
+ AOBJN A,.-2
+
+ CAILE D,NCHRS+NNETS(C)
+ JRST WTYP1
+
+ MOVEI 0,(D) ; CHECK THEM
+ MOVE B,1(AB)
+
+ JUMPE 0,.+4
+ ILDB C,B
+ CAILE C,32
+ JRST WTYP1
+ SOJG 0,.-3
+
+ MOVSI E,-<NCHRS+NNETS> ; ZAP CURRENT
+ HRRZ A,CHRS(E)
+ DTI
+ SETZM CHRS(E)
+ AOBJN E,.-3
+
+ MOVE A,[-NNETS,,NETJFN] ; IN CASE USED NET INTS FOR CHARS
+
+ SKIPGE (A)
+ SETZM (A)
+ AOBJN A,.-2
+
+ MOVE E,1(AB)
+ SETZB C,F ; C WILL BE MASK, F OFFSET INTO TABLE
+ MOVSI 0,400000 ; 0 WILL BE THE BIT FOR INT MASK OR'ING
+ JUMPE D,ALP1 ; JUMP IF NONE
+ MOVNS D ; BUILD AOBJN POINTER TO CHRS TABLE
+ MOVSI D,(D)
+ MOVEI B,0 ; B COUNTS NUMBER DONE
+
+ALP: ILDB A,E ; GET CHR
+ IOR C,0
+ LSH 0,-1
+ HRROM A,CHRS(D)
+ MOVSS A
+ HRRI A,(D)
+ ADDI A,(F) ; POSSIBLE OFFSET FOR MORE CHANS
+ ATI
+ ADDI B,1
+ CAIGE B,NCHRS
+ JRST ALP2
+
+ SKIPE NETJFN-NCHRS(B)
+ AOJA B,.-1
+
+ MOVEI F,36.-NNETS-UINTS-NCHRS(B)
+ MOVN G,F
+ MOVSI 0,400000
+ LSH 0,(G) ;NEW MASK FOR INT MASKS
+ SUBI F,1(D)
+
+ALP2: AOBJN D,ALP
+
+ALP1: IORM C,MASK1
+ MOVEI A,MFORK
+ MOVE B,MASK1 ; SET UP FOR INT BITS
+ AIC ; TURN THEM ON
+ MOVE A,(AB)
+ MOVE B,1(AB)
+ JRST FINIS
+
+RETCHR: MOVE C,[-NCHRS-NNETS,,CHRS]
+ MOVEI A,0
+
+RETCH1: SKIPN D,(C)
+ JRST RETDON
+ PUSH TP,$TCHRS
+ ANDI D,177
+ PUSH TP,D
+ ADDI A,1
+ AOBJN C,RETCH1
+
+RETDON: PUSHJ P,CISTNG
+ JRST FINIS
+
+HCHAR: HRRZ A,CHRS-36.(B)
+ PUSH TP,$TATOM
+ PUSH TP,MQUOTE CHAR,CHAR,INTRUP
+ PUSH TP,$TCHRS
+ PUSH TP,A
+ PUSH TP,$TCHAN
+ PUSH TP,TTICHN+1
+ MCALL 3,INTERRUPT
+ JRST DIRQ
+
+HNET: SKIPLE A,NETJFN-NINT+NNETS+UINTS(B)
+ JRST HNET1
+ SUBI B,36.-NNETS-UINTS-NCHRS
+ JUMPE A,DIRQ
+ JRST HCHAR
+HNET1: ASH A,1
+ ADDI A,CHNL0+1
+ MOVE B,(A)
+ PUSH TP,$TATOM
+ PUSH TP,MQUOTE CHAR,CHAR,INTRUP
+ PUSH TP,$TUVEC
+ PUSH TP,BUFRIN(B)
+ PUSH TP,$TCHAN
+ PUSH TP,B
+ PUSHJ P,INSTAT
+ MCALL 3,INTERRUPT
+ JRST DIRQ
+
+USRINT: SUBI B,36.
+ PUSH TP,$TATOM
+ PUSH TP,MQUOTE USERINT,USERINT,INTRUP
+ PUSH TP,$TFIX
+ PUSH TP,B
+ MCALL 2,INTERRUPT
+ JRST DIRQ
+]
+
+\f
+MFUNCTION OFF,SUBR
+ ENTRY
+
+ JUMPGE AB,TFA
+ HLRZ 0,AB
+ GETYP A,(AB) ; ARG TYPE
+ MOVE B,1(AB) ; AND VALUE
+ CAIN A,TINTH ; HEADER, GO HACK
+ JRST OFFHD ; QUEEN OF HEARTS
+ CAIN A,TATOM
+ JRST .+3
+ CAIE A,TCHSTR
+ JRST TRYHAN ; MAYBE INDIVIDUAL HANDLER
+ CAIN 0,-2 ; MORE THAN 1 ARG?
+ JRST OFFAC1 ; NO, GO ON
+ CAIG 0,-5 ; CANT BE MORE THAN 2
+ JRST TMA
+ MOVEI B,2(AB) ; POINT TO 2D
+ PUSHJ P,CHNORL
+OFFAC1: MOVEI B,(AB)
+ PUSHJ P,FNDINT
+ JUMPGE B,NOHAN1 ; NOT HANDLED
+
+OFFH1: PUSH P,C ; SAVE C FOR BIT CLOBBER
+ MOVSI C,TATOM
+ SKIPN D
+ MOVE D,MQUOTE INTERRUPT
+ MOVE A,INAME(B)
+ MOVE B,INAME+1(B)
+ PUSHJ P,IREMAS
+ SKIPE B ; IF NO ASSOC, DONT SMASH
+ SETOM ISTATE+1(B) ; DISABLE IN CASE QUEUED
+ POP P,C ; SPECIAL?
+ JUMPGE C,FINIS ; NO, DONE
+
+ HRRZ C,INTBL(C) ; POINT TO SPECIAL CODE
+ PUSHJ P,(C) ; GO TO SAME
+ JUMPE E,OFINIS ; DONE
+IFN ITS,[
+ CAILE E,35. ; SKIP IF 1ST WORD
+ JRST CLRW2 ; CLOBBER 2D WORD BIT
+ LSH 0,-1(E) ; POSITION BIT
+ ANDCAM 0,MASK1 ; KILL BIT
+ .SUSET [.SMASK,,MASK1]
+]
+IFE ITS,[
+ MOVE D,B
+ SETZM (E)
+ MOVEI E,(E)
+ SUBI E,NETJFN-NETCHN
+ MOVEI 0,1
+ MOVNS E
+ LSH 0,35.(E)
+ ANDCAM 0,MASK1
+ MOVEI A,MFORK
+ SETCM B,MASK1
+ DIC
+ ANDCAM 0,PIRQ ; JUST IN CASE
+ MOVE B,D
+]
+OFINIS: MOVSI A,TINTH
+ JRST FINIS
+
+IFN ITS,[
+CLRW2: LSH 0,-36.(E) ; POS BIT FOR 2D WORD
+ ANDCAM 0,MASK2
+ .SUSET [.SMSK2,,MASK2]
+ JRST OFINIS
+]
+
+TRYHAN: CAIE A,THAND ; HANDLER?
+ JRST WTYP1
+ CAIE 0,-2
+ JRST TMA
+ GETYP 0,IPREV(B) ; GET TYPE OF PREV
+ MOVE A,INXT+1(B)
+ SKIPN C,IPREV+1(B) ; dont act silly if already off! (TT)
+ JRST HFINIS
+ MOVE D,IPREV(B)
+ CAIE 0,THAND
+ JRST DOHEAD ; PREV HUST BE HDR
+ MOVEM A,INXT+1(C)
+ JRST .+2
+DOHEAD: MOVEM A,IHNDLR+1(C) ; INTO HDR
+ JUMPE A,OFFINI
+ MOVEM D,IPREV(A)
+ MOVEM C,IPREV+1(A)
+OFFINI: SETZM IPREV+1(B) ; Leave NXT slot intact for RUNINT (BKD)
+ MOVSI A,THAND
+ JRST FINIS
+
+OFFHD: CAIE 0,-2
+ JRST TMA
+ PUSHJ P,GETNMS ; GET INFOR ABOUT INT
+ JUMPE C,OFFH1
+ PUSH TP,INAME(B)
+ PUSH TP,INAME+1(B)
+ JRST OFFH1
+
+GETNMS: GETYP A,INAME(B) ; CHECK FOR SPECIAL
+ SETZB C,D
+ CAIN A,TCHAN
+ HRROI C,SS.CHA
+ PUSHJ P,LOCQ ; LOCATIVE?
+ JRST CHGTNM
+
+ MOVEI B,INAME(B) ; POINT TO LOCATIVE
+ MOVSI D,(MOVE E,)
+ PUSHJ P,SMON ; GET MONITOR
+ MOVE B,1(AB)
+GETNM1: HRROI C,SS.WMO ; ASSUME WRITE
+ TLNN E,.WRMON
+ HRROI C,SS.RMO
+ MOVE D,MQUOTE WRITE,WRITE,INTRUP
+ TLNN E,.WRMON
+ MOVE D,MQUOTE READ,READ,INTRUP
+ POPJ P,
+
+CHGTNM: JUMPL C,CPOPJ
+ MOVE B,INAME+1(B)
+ PUSHJ P,SPEC1
+ MOVE B,1(AB) ; RESTORE IHEADER
+ POPJ P,
+\f
+; EMERGENCY, CANT DEFER ME!!
+
+MQUOTE INTERRUPT
+
+EMERGENCY:
+ PUSH P,.
+ JRST INTERR+1
+
+MFUNCTION INTERRUPT,SUBR
+
+ PUSH P,[0]
+
+ ENTRY
+
+ SETZM INTHLD ; RE-ENABLE THE WORLD
+ JUMPGE AB,TFA
+ MOVE B,1(AB) ; GET HANDLER/NAME
+ GETYP A,(AB) ; CAN BE HEADER OR NAME
+ CAIN A,TINTH ; SKIP IF NOT HEADER
+ JRST GTHEAD
+ CAIN A,TATOM
+ JRST .+3
+ CAIE A,TCHSTR ; SKIP IF CHAR STRING
+ JRST WTYP1
+ MOVEI B,(AB) ; LOOK UP NAME
+ PUSHJ P,FNDNM ; GET NAME
+ JUMPE B,IFALSE
+ MOVEI D,0
+ CAMN B,MQUOTE CHAR,CHAR,INTRUP
+ PUSHJ P,CHNGT1
+ CAME B,MQUOTE READ,READ,INTRUP
+ CAMN B,MQUOTE WRITE,WRITE,INTRUP
+ PUSHJ P,GTLOC1
+ PUSHJ P,INTASO
+ JUMPE B,IFALSE
+
+GTHEAD: SKIPE ISTATE+1(B) ; ENABLED?
+ JRST IFALSE ; IGNORE COMPLETELY
+ MOVE A,INTPRI+1(B) ; GET PRIORITY OF INTERRUPT
+ CAMLE A,CURPRI ; SEE IF MUST QUEU
+ JRST SETPRI ; MAY RUN NOW
+ SKIPE (P) ; SKIP IF DEFER OK
+ JRST DEFERR
+ MOVEM A,(P)
+ PUSH TP,$TINTH ; SAVE HEADER
+ PUSH TP,B
+ MOVEI A,1 ; SAVE OTHER ARGS
+PSHARG: ADD AB,[2,,2]
+ JUMPGE AB,QUEU1 ; GO MAKE QUEU ENTRY
+ PUSH TP,(AB)
+ PUSH TP,1(AB)
+ AOJA A,PSHARG
+QUEU1: PUSHJ P,IEVECT ; GET VECTOR
+ PUSH TP,$TVEC
+ PUSH TP,[0] ; WILL HOLD QUEUE HEADER
+ PUSH TP,A
+ PUSH TP,B
+
+ POP P,A ; RESTORE PRIORITY
+
+ MOVE B,QUEUES+1 ; GET INTERRUPT QUEUES
+ MOVEI D,0
+ JUMPGE B,GQUEU ; MAKE A QUEUE HDR
+
+NXTQU: CAMN A,1(B) ; GOT PRIORITY?
+ JRST ADDQU ; YES, ADD TO THE QUEU
+ CAML A,1(B) ; SKIP IF SPOT NOT FOUND
+ JRST GQUEU
+ MOVE D,B
+ MOVE B,3(B) ; GO TO NXT QUEUE
+ JUMPL B,NXTQU
+
+GQUEU: PUSH TP,$TVEC ; SAVE NEXT POINTER
+ PUSH TP,D
+ PUSH TP,$TFIX
+ PUSH TP,A ; SAVE PRIORITY
+ PUSH TP,$TVEC
+ PUSH TP,B
+ PUSH TP,$TLIST
+ PUSH TP,[0]
+ PUSH TP,$TLIST
+ PUSH TP,[0]
+ MOVEI A,4
+ PUSHJ P,IEVECT
+ MOVE D,(TP) ; NOW SPLICE
+ SUB TP,[2,,2]
+ JUMPN D,GQUEU1
+ MOVEM B,QUEUES+1
+ JRST .+2
+GQUEU1: MOVEM B,3(D)
+
+ADDQU: MOVEM B,-2(TP) ; SAVE QUEU HDR
+ POP TP,D
+ POP TP,C
+ PUSHJ P,INCONS ; CONS IT
+ MOVE C,(TP) ;GET QUEUE HEADER
+ SKIPE D,7(C) ; IF END EXISTS
+ HRRM B,(D) ; SPLICE
+ MOVEM B,7(C)
+ SKIPN 5(C) ; SKIP IF START EXISTS
+ MOVEM B,5(C)
+
+IFINI: MOVSI A,TATOM
+ MOVE B,IMQUOTE T
+ JRST FINIS
+
+SETPRI: EXCH A,CURPRI
+ MOVEM A,(P)
+
+ PUSH TP,$TAB ; PASS AB TO HANDLERS
+ PUSH TP,AB
+
+ PUSHJ P,RUNINT ; RUN THE HANDLERS
+ POP P,A ; UNQUEU ANY WAITERS
+ PUSHJ P,UNQUEU
+
+ JRST IFINI
+
+; HERE TO UNQUEUE WAITING INTERRUPTS
+
+UNQUEU: PUSH P,A ; SAVE NEW LEVEL
+
+UNQUE1: MOVE A,(P) ; TARGET LEVEL
+ CAMLE A,CURPRI ; CHECK RUG NOT PULLED OUT
+ JRST UNDONE
+ SKIPE B,QUEUES+1
+ CAML A,1(B) ; RIGHT LEVEL?
+ JRST UNDONE ; FINISHED
+
+ SKIPN C,5(B) ; ON QUEUEU?
+ JRST UNXQ
+ HRRZ D,(C) ; CDR THE LIST
+ MOVEM D,5(B)
+ SKIPN D ; SKIP IF NOT LAST
+ SETZM 7(B) ; CLOBBER END POINTER
+ MOVE A,1(B) ; GET THIS PRIORITY LEVEL
+ MOVEM A,CURPRI ; MAKE IT THE CURRENT ONE
+ MOVE D,1(C) ; GET SAVED VECTOR OF INF
+
+ MOVE B,1(D) ; INT HEADER
+ PUSH TP,$TVEC
+ PUSH TP,D ; AND ARGS
+
+ PUSHJ P,RUNINT ; RUN THEM
+ JRST UNQUE1
+
+UNDONE: POP P,CURPRI ; SET CURRENT LEVEL
+ MOVE A,CURPRI
+ POPJ P,
+
+UNXQ: MOVE B,3(B) ; GO TO NEXT QUEUE
+ MOVEM B,QUEUES+1
+ JRST UNQUE1
+
+
+
+; SUBR TO CHANGE INTERRUPT LEVEL
+
+MFUNCTION INTLEV,SUBR,[INT-LEVEL]
+ ENTRY
+ JUMPGE AB,RETLEV ; JUST RETURN CURRENT
+ GETYP A,(AB)
+ CAIE A,TFIX
+ JRST WTYP1 ; LEVEL IS FIXED
+ SKIPGE A,1(AB)
+ JRST OUTRNG"
+ CAMN A,CURPRI ; DIFFERENT?
+ JRST RETLEV ; NO RETURN
+ PUSH P,CURPRI
+ CAMG A,CURPRI ; SKIP IF NO UNQUEUE NEEDED
+ PUSHJ P,UNQUEU
+ MOVEM A,CURPRI ; SAVE
+ POP P,A
+ SKIPA B,A
+RETLEV: MOVE B,CURPRI
+ MOVSI A,TFIX
+ JRST FINIS
+
+RUNINT: PUSH TP,$THAND ; SAVE HANDLERS LIST
+ PUSH TP,IHNDLR+1(B)
+
+ SKIPN ISTATE+1(B) ; SKIP IF DISABLED
+ SKIPN B,(TP)
+ JRST SUBTP4
+NXHND: MOVEM B,(TP) ; SAVE CURRENT HDR
+ MOVE A,-2(TP) ; SAVE ARG POINTER
+ PUSHJ P,CHSWAP ; SEE IF MUST SWAP
+ PUSH TP,[0]
+ PUSH TP,[0]
+ MOVEI C,1 ; COUNT ARGS
+ PUSH TP,SPSTOR ; SAVE INITIAL BINDING POINTER
+ PUSH TP,SPSTOR+1
+ MOVE D,PVSTOR+1
+ ADD D,[1STEPR,,1STEPR]
+ PUSH TP,BNDV
+ PUSH TP,D
+ PUSH TP,$TPVP
+ PUSH TP,[0]
+ MOVE E,TP
+NBIND: PUSH TP,INTFCN(B)
+ PUSH TP,INTFCN+1(B)
+ ADD A,[2,,2]
+ JUMPGE A,DO.HND
+ PUSH TP,(A)
+ PUSH TP,1(A)
+ AOJA C,.-4
+DO.HND: MOVE PVP,PVSTOR+1
+ SKIPN 1STEPR+1(PVP) ; NECESSARY TO DO 1STEP BINDING ?
+ JRST NBIND1 ; NO, DON'T BOTHER
+ PUSH P,C
+ PUSHJ P,SPECBE ; BIND 1 STEP FLAG
+ POP P,C
+NBIND1: ACALL C,INTAPL ; RUN HAND WITH POSSIBLY BOUND 1STEP FLAG
+ MOVE SP,SPSTOR+1 ; GET CURRENT BINDING POINTER
+ CAMN SP,-4(TP) ; SAME AS SAVED BINDING POINTER ?
+ JRST NBIND2 ; YES, 1STEP FLAG NOT BOUND
+ MOVE C,(TP) ; RESET 1 STEP
+ MOVE PVP,PVSTOR+1
+ MOVEM C,1STEPR+1(PVP)
+ MOVE SP,-4(TP) ; RESTORE SAVED BINDING POINTER
+ MOVEM SP,SPSTOR+1
+NBIND2: SUB TP,[6,,6]
+ PUSHJ P,CHUNSW
+ CAMN E,PVSTOR+1
+ SUB TP,[4,,4] ; NO PROCESS CHANGE, POP JUNK
+ CAMN E,PVSTOR+1
+ JRST .+4
+ MOVE D,TPSTO+1(E)
+ SUB D,[4,,4]
+ MOVEM D,TPSTO+1(E) ; FIXUP HIS STACK
+DO.H1: GETYP A,A ; CHECK FOR A DISMISS
+ CAIN A,TDISMI
+ JRST SUBTP4
+ MOVE B,(TP) ; TRY FOR NEXT HANDLER
+ SKIPE B,INXT+1(B)
+ JRST NXHND
+SUBTP4: SUB TP,[4,,4]
+ POPJ P,
+
+MFUNCTION INTAPL,SUBR,[RUNINT]
+ JRST APPLY
+
+
+NOHAND: JUMPE C,NOHAN1
+ PUSH TP,$TATOM
+ PUSH TP,EQUOTE INTERNAL-INTERRUPT
+NOHAN1: PUSH TP,(AB)
+ PUSH TP,1(AB)
+ PUSH TP,$TATOM
+ PUSH TP,EQUOTE NOT-HANDLED
+ SKIPE A,C
+ MOVEI A,1
+ ADDI A,2
+ JRST CALER
+
+DEFERR: PUSH TP,$TATOM
+ PUSH TP,EQUOTE ATTEMPT-TO-DEFER-UNDEFERABLE-INTERRUPT
+ PUSH TP,$TINTH
+ PUSH TP,B
+ PUSH TP,$TATOM
+ PUSH TP,MQUOTE INTERRUPT
+ MCALL 3,RERR ; FORCE REAL ERROR
+ JRST FINIS
+
+; FUNCTION TO DISMISS AN INTERRUPT TO AN ARBITRARY ACTIVATION
+
+MFUNCTION DISMISS,SUBR
+
+ HLRZ 0,AB
+ JUMPGE AB,TFA
+ CAIGE 0,-6
+ JRST TMA
+ MOVNI D,1
+ CAIE 0,-6
+ JRST DISMI3
+ GETYP 0,4(AB)
+ CAIE 0,TFIX
+ JRST WTYP
+ SKIPGE D,5(AB)
+ JRST OUTRNG
+
+DISMI3: MOVEI A,(TB)
+
+DISMI0: HRRZ B,FSAV(A)
+ HRRZ C,PCSAV(A)
+ CAIE B,INTAPL
+ JRST DISMI1
+
+ MOVE E,OTBSAV(A)
+ MOVEI 0,(A) ; SAVE FRAME
+ MOVEI A,DISMI2
+ HRRM A,PCSAV(E) ; GET IT BACK HERE
+ MOVE A,(AB)
+ MOVE B,1(AB)
+ MOVE C,TPSAV(E)
+ MOVEM A,-7(C)
+ MOVEM B,-6(C)
+ MOVEI C,0
+ CAMGE AB,[-3,,]
+ MOVEI C,2(AB)
+ MOVE B,0 ; DEST FRAME
+ JUMPL D,.+3
+ MOVE A,PSAV(E) ; NOW MUNG SAVED INT LEVEL
+ MOVEM D,-1(A) ; ZAP YOUR MUNGED
+ PUSHJ P,CHUNW ; CHECK ON UNWINDERS
+ JRST FINIS ; FALL DOWN
+
+DISMI1: MOVEI E,(A)
+ HRRZ A,OTBSAV(A)
+ JUMPN A,DISMI0
+
+ MOVE A,(AB)
+ MOVE B,1(AB)
+
+ PUSH TP,A
+ PUSH TP,B
+ SKIPGE A,D
+ JRST .+4
+ CAMG A,CURPRI
+ PUSHJ P,UNQUEU
+ MOVEM A,CURPRI
+ CAML AB,[-3,,]
+ JRST .+5
+ PUSH TP,2(AB)
+ PUSH TP,3(AB)
+ MCALL 2,ERRET
+ JRST FINIS
+
+ POP TP,B
+ POP TP,A
+ JRST FINIS
+
+DISMI2: CAMN SP,-4(TP) ; 1STEP FLAG BEEN BOUND ?
+ JRST NDISMI ; NO
+ MOVE C,(TP)
+ MOVE PVP,PVSTOR+1
+ MOVEM C,1STEPR+1(PVP)
+ MOVE SP,-4(TP)
+NDISMI: SUB TP,[6,,6]
+ PUSHJ P,CHUNSW ; UNDO ANY PROCESS HACKING
+ MOVE C,TP
+ CAME E,PVSTOR+1 ; SWAPED?
+ MOVE C,TPSTO+1(E)
+ MOVE D,-1(C)
+ MOVE 0,(C)
+ SUB TP,[4,,4]
+ SUB C,[4,,4] ; MAYBE FIXUP OTHER STACK
+ CAME E,PVSTOR+1
+ MOVEM C,TPSTO+1(E)
+ PUSH TP,D
+ PUSH TP,0
+ PUSH TP,A
+ PUSH TP,B
+ MOVE A,-1(P) ; SAVED PRIORITY
+ CAMG A,CURPRI
+ PUSHJ P,UNQUEU
+ MOVEM A,CURPRI
+ SKIPN -1(TP)
+ JRST .+3
+ MCALL 2,ERRET
+ JRST FINIS
+
+ SUB TP,[4,,4]
+ MOVSI A,TDISMI
+ MOVE B,IMQUOTE T
+ JRST DO.H1
+
+CHNGT1: HLRE B,AB
+ SUBM AB,B
+ GETYP 0,-2(B)
+ CAIE 0,TCHAN
+ JRST WTYP3
+ MOVE B,-1(B)
+ MOVSI A,TCHAN
+ POPJ P,
+
+GTLOC1: GETYP A,2(AB)
+ PUSHJ P,LOCQ
+ JRST WTYP2
+ MOVE D,B ; RET ATOM FOR ASSOC
+ MOVE A,2(AB)
+ MOVE B,3(AB)
+ POPJ P,
+\f; MONITOR CHECKERS
+
+MONCH0: HLLZ 0,(B) ; POTENTIAL MONITORS
+MONCH: TLZ 0,TYPMSK ; KILL TYPE
+ IOR C,0 ; IN NEW TYPE
+ PUSH P,0
+ MOVEI 0,(B)
+ CAIL 0,HIBOT
+ JRST PURERR
+ POP P,0
+ TLNN 0,.WRMON ; SKIP IF WRITE MONIT
+ POPJ P,
+
+; MONITOR IS ON, INVOKE HANDLER
+
+ PUSH TP,A ; SAVE OBJ
+ PUSH TP,B
+ PUSH TP,C
+ PUSH TP,D ; SAVE DATUM
+ MOVSI C,TATOM ; PREPARE TO FIND IT
+ MOVE D,MQUOTE WRITE,WRITE,INTRUP
+ PUSHJ P,IGET
+ JUMPE B,MONCH1 ; NOT FOUND IGNORE FOR NOW
+ PUSH TP,A ; START SETTING UP CALL
+ PUSH TP,B
+ PUSH TP,-5(TP)
+ PUSH TP,-5(TP)
+ PUSH TP,-5(TP)
+ PUSH TP,-5(TP)
+ PUSHJ P,FRMSTK ; PUT FRAME ON STAKC
+ MCALL 4,EMERGE ; DO IT
+MONCH1: POP TP,D
+ POP TP,C
+ POP TP,B
+ POP TP,A
+ HLLZ 0,(B) ; UPDATE MONITORS
+ TLZ 0,TYPMSK
+ IOR C,0
+ POPJ P,
+
+; NOW FOR READ MONITORS
+
+RMONC0: HLLZ 0,(B)
+RMONCH: TLNN 0,.RDMON
+ POPJ P,
+ PUSH TP,A
+ PUSH TP,B
+ MOVSI C,TATOM
+ MOVE D,MQUOTE READ,READ,INTRUP
+ PUSHJ P,IGET
+ JUMPE B,RMONC1
+ PUSH TP,A
+ PUSH TP,B
+ PUSH TP,-3(TP)
+ PUSH TP,-3(TP)
+ PUSHJ P,FRMSTK ; PUT FRAME ON STACK
+ MCALL 3,EMERGE
+RMONC1: POP TP,B
+ POP TP,A
+ POPJ P,
+
+; PUT THE CURRENT FRAME ON THE STACK
+
+FRMSTK: PUSHJ P,MAKACT
+ HRLI A,TFRAME
+ PUSH TP,A
+ PUSH TP,B
+ POPJ P,
+
+; HERE TO COMPLAIN ABOUT ATTEMPTS TO MUNG PURE CODE
+
+PURERR: PUSH TP,$TATOM
+ PUSH TP,EQUOTE ATTEMPT-TO-MUNG-PURE-STRUCTURE
+ PUSH TP,A
+ PUSH TP,B
+ MOVEI A,2
+ JRST CALER
+\f
+; PROCESS SWAPPING CODE
+
+CHSWAP: MOVE E,PVSTOR+1 ; GET CURRENT
+ POP P,0
+ SKIPE D,INTPRO+1(B) ; SKIP IF NO PROCESS GIVEN
+ CAMN D,PVSTOR+1 ; SKIP IF DIFFERENT
+ JRST PSHPRO
+
+ PUSHJ P,SWAPIT ; DO SWAP
+
+PSHPRO: PUSH TP,$TPVP
+ PUSH TP,E
+ JRST @0
+
+CHUNSW: MOVE E,PVSTOR+1 ; RET OLD PROC
+ MOVE D,-2(TP) ; GET SAVED PROC
+ CAMN D,PVSTOR+1 ; SWAPPED?
+ POPJ P,
+
+SWAPIT: PUSH P,0
+ MOVE 0,PSTAT+1(D) ; CHECK STATE
+ CAIE 0,RESMBL
+ JRST NOTRES
+ MOVE PVP,PVSTOR+1
+ MOVEM 0,PSTAT+1(PVP)
+ MOVEI 0,RUNING
+ MOVEM 0,PSTAT+1(D) ; SAVE NEW STATE
+ POP P,0
+ POP P,C
+ JRST SWAP"
+\f
+
+;SUBROUTINE TO GET BIT FOR CLOBBERAGE
+
+GETBIT: MOVNS B ;NEGATE
+ MOVSI A,400000 ;GET THE BIT
+ LSH A,(B) ;SHIFT TO POSITION
+ POPJ P, ;AND RETURN
+
+; HERE TO HANDLE PURE WRITE AND CHECK FOR POSSIBLE C/W
+
+IFN ITS,[
+GCPWRT: SKIPN GCDFLG ; SEE IF IN DUMPER OR PURIFYER
+ SKIPE NPWRIT
+ JRST .+3
+ MOVEI B,4 ; INDICATE PURE WRITE
+ JRST NOPUGC ; CONTINUE
+ TLZ A,200
+ MOVEM A,TSINT ; SVE A
+ MOVE A,TSAVA
+ SOS TSINTR
+ .SUSET [.RMPVA,,A]
+ CAML A,RPURBT ; SKIP IF NOT PURE
+ CAIL A,HIBOT ; DONT MARK IF TOUCHING INTERPRETER
+ SKIPA
+ SETOM PURMNG ; MUNGING PURENESS INDICATE
+ MOVE B,BUFGC ; GET BUFFER
+ JUMPL B,GCPW1 ; JUMP IF WINDOW IS BUFFER
+ EXCH P,GCPDL
+ PUSHJ P,%CWINF ; GO DO COPY/WRITE
+GCPW2: EXCH P,GCPDL
+ MOVE A,TSINT ; RESTORE A
+ JRST 2NDWORD ; CONTINUE
+GCPW1: EXCH P,GCPDL
+ MOVEI B,WIND ; START OF BUFFER
+ PUSHJ P,%CWINF ; C/W
+ MOVEI B,WNDP ; RESTORE WINDOW
+ MOVE A,WNDBOT ; BOTTOM OF WINDOW
+ ASH A,-10. ; TO PAGES
+ SKIPE A
+ PUSHJ P,%SHWND ; SHARE IT
+ JRST GCPW2
+]
+IFE ITS,[
+
+; HERE TO HANDLE BUFFERING FOR GC-DUMP AND PURIFY FOR TENEX
+
+PWRIT: SKIPN GCDFLG ; SEE IF IN DUMPER OR PURIFYER
+ SKIPE GPURFL
+ SKIPA
+ FATAL IMW
+ EXCH P,GCPDL ; GET A GOOD PDL
+ MOVEM A,TSAVA ; SAVE AC'S
+ MOVEM B,TSAVB
+ MOVEI A,MFORK ; FOR TWENEX THIS IS A MOVEI
+ SKIPE OPSYS ; SKIP IF TOPS20
+ MOVSI A,MFORK ; FOR A TENEX IT SHOULD BE A MOVSI
+ GTRPW ; GET TRAP WORDS
+ PUSH P,A ; SAVE ADDRESS AND WORD
+ PUSH P,B
+ ANDI A,-1
+ CAML A,RPURBT ; SKIP IF NOT PURE
+ CAIL A,HIBOT ; DONT MARK IF TOUCHING INTERPRETER
+ SKIPA
+ SETOM PURMNG ; MUNGING PURENESS INDICATE
+ MOVE B,BUFGC ; GET BUFFER
+ ANDCMI A,1777 ; TO PAGE BOUNDRY
+ JUMPL B,PWRIT2 ; USE WINDOW AS BUFFER
+PWRIT3: PUSHJ P,%CWINF ; FIX UP
+PWRIT4: POP P,B ; RESTORE AC'S
+ POP P,A
+ TLNN A,10 ; SEE IF R/W CYCLE
+ MOVEM B,(A) ; FINISH WRITE
+ EXCH P,GCPDL
+ JRST INTDON
+PWRIT2: MOVEI B,WIND
+ PUSHJ P,%CWINF ; GO TRY TO WIN
+ MOVEI B,WNDP
+ MOVE A,WNDBOT ; BOTTOM OF WINDOW
+ ASH A,-10. ; TO PAGES
+ SKIPE A
+ PUSHJ P,%SHWND ; SHARE IT
+ JRST PWRIT4
+]
+
+;HERE TO HANDLE PDL OVERFLOW. ASK FOR A GC
+
+IPDLOV:
+IFN ITS,[
+ MOVEM A,TSINT ;SAVE INT WORD
+]
+
+ SKIPE GCFLG ;IS GC RUNNING?
+ JRST GCPLOV ;YES, COMPLAIN GROSSLY
+
+ MOVEI A,200000 ;GET BIT TO CLOBBER
+ IORM A,PIRQ ;LEAVE A MESSAGE FOR HIGHER LEVEL
+
+ EXCH P,GCPDL ;GET A WINNING PDL
+ HRRZ B,TSINTR ;GET POINTER TO LOSING INSTRUCTION
+IFE ITS,[
+ SKIPE MULTSG
+ MOVE B,TSINTR+1
+]
+ SKIPG GCPDL ; SKIP IF NOT P
+ LDB B,[270400,,-1(B)] ;GET AC FIELD
+ SKIPL GCPDL ; SKIP IF P
+ MOVEI B,P
+ MOVEI A,(B) ;COPY IT
+ LSH A,1 ;TIMES 2
+ EXCH PVP,PVSTOR+1
+ ADDI A,0STO(PVP) ;POINT TO THIS ACS CURRENT TYPE
+ EXCH PVP,PVSTOR+1
+ HLRZ A,(A) ;GET THAT TYPE INTO A
+ CAIN B,P ;IS IT P
+ MOVEI B,GCPDL ;POINT TO SAVED P
+
+ CAIN B,B ;OR IS IT B ITSELF
+ MOVEI B,TSAVB
+ CAIN B,A ;OR A
+ MOVEI B,TSAVA
+
+ CAIN B,C ;OR C
+ MOVEI B,1(P) ;C WILL BE ON THE STACK
+
+ PUSH P,C
+ PUSH P,A
+
+ MOVE A,(B) ;GET THE LOSING POINTER
+ MOVEI C,(A) ;AND ISOLATE RH
+
+ CAMG C,VECTOP ;CHECK IF IN GC SPACE
+ CAMG C,VECBOT
+ JRST NOGROW ;NO, COMPLAIN
+
+; FALL THROUGH
+\f
+
+ HLRZ C,A ;GET -LENGTH
+ SUBI A,-1(C) ;POINT TO A DOPE WORD
+ POP P,C ;RESTORE TYPE INTO C
+ PUSH P,D ; SAVE FOR GROWTH HACKER
+ MOVEI D,0
+ CAIN C,TPDL ; POINT TD TO APPROPRIATE DOPE WORD
+ MOVEI D,PGROW
+ CAIN C,TTP
+ MOVEI D,TPGROW
+ JUMPE D,BADPDL ; IF D STILL 0, THIS PDL IS WEIRD
+ MOVEI A,PDLBUF(A) ; POINT TO ALLEGED REAL DOPE WORD
+ SKIPN (D) ; SKIP IF PREVIOUSLY BLOWN
+ MOVEM A,(D) ; CLOBBER IN
+ CAME A,(D) ; MAKE SURE IT IS THE SAME
+ JRST PDLOSS
+ POP P,D ; RESTORE D
+
+
+PNTRHK: MOVE C,(B) ;RESTORE PDL POINTER
+ SUB C,[PDLBUF,,0] ;FUDGE THE POINTER
+ MOVEM C,(B) ;AND STORE IT
+
+ POP P,C ;RESTORE THE WORLD
+ EXCH P,GCPDL ;GET BACK ORIG PDL
+IFN ITS,[
+ MOVE A,TSINT ;RESTORE INT WORD
+
+ JRST IMPCH ;LOOK FOR MORE INTERRUPTS
+]
+IFE ITS, JRST GCQUIT
+
+TPOVFL: SETOM INTFLG ;SIMULATE PDL OVFL
+ PUSH P,A
+ MOVEI A,200000 ;TURN ON THE BIT
+ IORM A,PIRQ
+ HLRE A,TP ;FIND DOPEW
+ SUBM TP,A ;POINT TO DOPE WORD
+ MOVEI A,PDLBUF+1(A) ; ZERO LH AND POINT TO DOPEWD
+ SKIPN TPGROW
+ HRRZM A,TPGROW
+ CAME A,TPGROW ; MAKE SURE WINNAGE
+ JRST PDLOS1
+ SUB TP,[PDLBUF,,0] ; HACK STACK POINTER
+ POP P,A
+ POPJ P,
+
+
+; GROW CORE IF PDL OVERFLOW DURING GC
+
+GCPLOV: EXCH P,GCPDL ; NEED A PDL TO CALL P.CORE
+ PUSHJ P,GPDLOV ; HANDLE PDL OVERFLOW
+ EXCH P,GCPDL
+ PUSHJ P,%FDBUF
+IFE ITS,[
+ JRST GCQUIT
+]
+IFN ITS,[
+ MOVE A,TSINT
+ JRST IMPCH
+
+]
+\f
+IFN ITS,[
+
+;HERE TO HANDLE LOW-LEVEL CHANNELS
+
+
+CHNACT: SKIPN GCFLG ;GET A WINNING PDL
+ EXCH P,GCPDL
+ ANDI A,177777 ;ISOLATE CHANNEL BITS
+ PUSH P,0 ;SAVE
+
+CHNA1: MOVEI B,0 ;BIT COUNTER
+ JFFO A,.+2 ;COUNT
+ JRST CHNA2
+ SUBI B,35. ;NOW HAVE CHANNEL
+ MOVMS B ;PLUS IT
+ MOVEI 0,1
+ LSH 0,(B)
+ ANDCM A,0
+ MOVEI 0,(B) ; COPY TO 0
+ LSH 0,23. ;POSITION FOR A .STATUS
+ IOR 0,[.STATUS 0]
+ XCT 0 ;DO IT
+ ANDI 0,77 ;ISOLATE DEVICE
+ CAILE 0,2
+ JRST CHNA1
+
+PMIN4: MOVE 0,B ; CHAN TO 0
+ .ITYIC 0, ; INTO 0
+ JRST .+2 ; DONE, GO ON
+ JRST PMIN4
+ SETZM GCFLCH ; LEAVE GC MODE
+ JRST CHNA1
+
+CHNA2: POP P,0
+ SKIPN GCFLG
+ EXCH P,GCPDL
+ JRST GCQUIT
+
+HOWMNY: SETZ
+ SIXBIT /LISTEN/
+ D
+ 402000,,B
+]
+
+MFUNCTION GASCII,SUBR,ASCII
+ ENTRY 1
+
+ GETYP A,(AB)
+ CAIE A,TCHRS
+ JRST TRYNUM
+
+ MOVE B,1(AB)
+ MOVSI A,TFIX
+ JRST FINIS
+
+TRYNUM: CAIE A,TFIX
+ JRST WTYP1
+ SKIPGE B,1(AB) ;GET NUMBER
+ JRST TOOBIG
+ CAILE B,177 ;CHECK RANGE
+ JRST TOOBIG
+ MOVSI A,TCHRS
+ JRST FINIS
+
+TOOBIG: ERRUUO EQUOTE ARGUMENT-OUT-OF-RANGE
+
+\f
+;HERE IF PDL OVERFLOW DURING GARBAGE COLLECTION
+
+BADPDL: FATAL NON PDL OVERFLOW
+
+NOGROW: FATAL PDL OVERFLOW ON NON EXPANDABLE PDL
+
+PDLOS1: MOVEI D,TPGROW
+PDLOSS: MOVSI A,(GENERAL) ; FIX UP TP DOPE WORD JUST IN CASE
+ HRRZ D,(D) ; POINT TO POSSIBLE LOSING D.W.
+ SKIPN TPGROW
+ JRST PDLOS2
+ MOVEM A,-1(D)
+ MOVEI A,(TP) ; SEE IF REL STACK SIZE WINS
+ SUBI A,(TB)
+ TRNN A,1
+ SUB TP,[1,,1]
+PDLOS2: MOVSI A,.VECT.
+ SKIPE PGROW
+ MOVEM A,-1(D)
+ SUB P,[2,,2] ; TRY TO RECOVER GRACEFULLY
+ EXCH P,GCPDL
+ MOVEI A,DOAGC ; SET UP TO IMMEDIATE GC
+IFN ITS,[
+ HRRM A,TSINTR
+]
+IFE ITS,[
+ SKIPE MULTSG
+ HRRM A,TSINTR+1
+ SKIPN MULTSG
+ HRRM A,TSINTR
+]
+IFN ITS, .DISMIS TSINTR
+IFE ITS, DEBRK
+
+DOAGC: SKIPE PGROW
+ SUB P,[2,,2] ; ALLOW ROOM FOR CALL
+ JSP E,PDL3 ; CLEANUP
+ ERRUUO EQUOTE PDL-OVERFLOW-BUFFER-EXHAUSTED
+
+
+DLOSER: PUSH P,LOSRS(B)
+ MOVE A,TSAVA
+ MOVE B,TSAVB
+ POPJ P,
+
+LOSRS: IMPV
+ ILOPR
+ IOC
+ IPURE
+
+
+;MEMORY PROTECTION INTERRUPT
+
+IOC: FATAL IO CHANNEL ERROR IN GARBAGE COLLECTOR
+IMPV: FATAL MPV IN GARBAGE COLLECTOR
+
+IPURE: FATAL PURE WRITE IN GARBAGE COLLECTOR
+ILOPR: FATAL ILLEGAL OPEREATION IN GARBAGE COLLECTOR
+
+IFN ITS,[
+
+;SUBROUTINE TO BE CALLED AT INITIALIZE TIME TO SETUP INTS
+
+INTINT: SETZM CHNCNT
+ MOVE A,[CHNCNT,,CHNCNT+1]
+ BLT A,CHNCNT+16.
+ SETZM INTFLG
+ .SUSET [.SPICLR,,[-1]]
+ MOVE A,MASK1 ;SET MASKS
+ MOVE B,MASK2
+ .SETM2 A, ;SET BOTH MASKS
+ MOVSI A,TVEC
+ MOVEM A,QUEUES
+ SETZM QUEUES+1 ;UNQUEUE ANY OLD INTERRUPTS
+ SETZM CURPRI
+ POPJ P,
+]
+IFE ITS,[
+
+; INITIALIZE TENEX INTERRUPT SYSTEM
+
+INTINT: CIS ; CLEAR THE INT WORLD
+ SETZM INTFLG ; IN CASE RESTART
+ MOVSI A,TVEC ; FIXUP QUEUES
+ MOVEM A,QUEUES
+ SETZM QUEUES+1
+ SETZM CURPRI ; AND PRIORITY LEVEL
+ MOVEI A,MFORK ; TURN ON MY INTERRUPTS
+ SKIPN MULTSG
+ JRST INTINM
+ PUSHJ P,@[DOSIR] ; HACK TO TEMP GET TO SEGMENT 0
+ JRST INTINX
+
+INTINM: MOVE B,[-36.,,CHNTAB]
+ MOVSI 0,1
+ HLLM 0,(B)
+ AOBJN B,.-1
+
+ MOVE B,[LEVTAB,,CHNTAB] ; POINT TO TABLES
+ SIR ; TELL SYSTEM ABOUT THEM
+
+INTINX: MOVSI D,-NCHRS
+ MOVEI 0,40
+ MOVEI C,0
+
+INTILP: SKIPN A,CHRS(D)
+ JRST ITTIL1
+ IOR C,0
+ MOVSS A
+ HRRI A,(D)
+ ATI
+ITTIL1: LSH 0,-1
+ AOBJN D,INTILP
+
+ DPB C,[360600,,MASK1]
+ MOVE B,MASK1 ; SET UP FOR INT BITS
+ MOVEI A,MFORK
+ AIC ; TURN THEM ON
+ MOVEI A,MFORK ; DO THE ENABLE
+ EIR
+ POPJ P,
+
+
+DOSIR: MOVE B,[-36.,,CHNTAB]
+ MOVSI 0,1_12.
+ HLLM 0,(B)
+ AOBJN B,.-1
+
+ MOVEI B,..ARGB ; WILL RUN IN SEGMENT 0
+RMT [
+..ARGB: 3
+ LEVTAB
+ CHNTAB
+]
+ XSIR
+ POP P,D
+ HRLI D,FSEG
+ XJRST C ; GET BACK TO CALLING SEGMENT
+]
+\f
+
+; CNTL-G HANDLER
+
+MFUNCTION QUITTER,SUBR
+
+ ENTRY 2
+ GETYP A,(AB)
+ CAIE A,TCHRS
+ JRST WTYP1
+ GETYP A,2(AB)
+ CAIE A,TCHAN
+ JRST WTYP2
+ MOVE B,1(AB)
+ MOVE A,(AB)
+IFE ITS, CAIE ^O
+ CAIN B,^S ; HANDLE CNTL-S
+ JRST RETLIS
+ CAIE B,7
+ JRST FINIS
+
+ PUSHJ P,CLEAN ; CLEAN UP I/O CHANNELS
+ PUSH TP,$TATOM
+ PUSH TP,EQUOTE CONTROL-G?
+ MCALL 1,ERROR
+ JRST FINIS
+
+RETLIS: MOVE B,IMQUOTE LER,[LERR ]INTRUP
+ PUSHJ P,ILVAL ; GET CURRENT VALUE
+ PUSH TP,A
+ PUSH TP,B
+ MOVEI B,-1(TP)
+ PUSHJ P,CHFSWP
+ SUB TP,[2,,2]
+ MOVEI D,(TB) ; FIND A LISTEN OR ERROR TO RET TO
+
+RETLI1: HRRZ A,OTBSAV(D)
+ CAIN A,(B) ; CHECK FOR WINNER
+ JRST FNDHIM
+ HRRZ C,FSAV(A) ; CHECK FUNCTION
+ CAIE C,LISTEN
+ CAIN C,ERROR ; FOUND?
+ JRST FNDHIM ; YES, GO TO SAME
+ CAIN C,ERROR% ; FUNNY ERROR
+ JRST FNDHIM
+ CAIN C,TOPLEV ; NO ERROR/LISTEN
+ JRST FINIS
+ MOVEI D,(A)
+ JRST RETLI1
+
+FNDHIM: PUSH TP,$TTB
+ PUSH TP,D
+ PUSHJ P,CLEAN
+ MOVE B,(TP) ; NEW FRAME
+ SUB TP,[2,,2]
+ MOVEI C,0
+ PUSHJ P,CHUNW ; UNWIND?
+ MOVSI A,TATOM
+ MOVE B,IMQUOTE T
+ JRST FINIS
+
+CLEAN: MOVE B,3(AB) ; GET IN CHAN
+ PUSHJ P,RRESET
+ MOVE B,3(AB) ; CHANNEL BAKC
+ MOVE C,BUFRIN(B)
+ SKIPN C,ECHO(C) ; GET ECHO
+ JRST CLUNQ
+IFN ITS,[
+ MOVEI A,2
+ CAMN C,[PUSHJ P,MTYO]
+ JRST TYONUM
+ LDB A,[270400,,C]
+TYONUM: LSH A,23.
+ IOR A,[.RESET]
+ XCT A
+]
+IFE ITS,[
+ MOVEI A,101 ; OUTPUT JFN
+ CFOBF
+]
+
+CLUNQ: SETZB A,CURPRI
+ JRST UNQUEU
+
+\f
+IMPURE
+ONINT: 0 ; INT FUDGER
+INTBCK: 0 ; GO BACK TO THIS PC AFTER INTERRUPT
+ MOVEM TP,TPSAV(TB) ; SAVE STUFF
+ MOVEM P,PSAV(TB)
+INTBEN: SKIPL INTFLG ; PENDING INTS?
+ JRST @INTBCK
+ PUSH P,A
+ SOS A,INTBCK
+ SETZM INTBCK
+ MOVEM A,LCKINT
+ POP P,A
+ JRST LCKINT+1
+
+
+IFN ITS,[
+;RANDOM IMPURE CRUFT NEEDED
+CHNCNT: BLOCK 16. ; # OF CHARS IN EACH CHANNEL
+
+TSAVA: 0
+TSAVB: 0
+PIRQ: 0 ;HOLDS REQUEST BITS FOR 1ST WORD
+PIRQ2: 0 ;SAME FOR WORD 2
+PCOFF: 0
+MASK1: 200,,200100 ;FIRST MASK
+MASK2: 0 ;SECOND THEREOF
+CURPRI: 0 ; CURRENT PRIORITY
+RLTSAV: 0
+]
+IFE ITS,[
+CHRS: 7 ; CNTL-G
+ 23 ; CNTL-O
+ 17 ; CNTL-S
+ BLOCK NCHRS-3
+
+NETJFN: BLOCK NNETS
+MASK1: CHNMSK
+RLTSAV: 0
+TSINTR:
+P1: 0
+ 0 ; PC INT LEVEL 1 (1ST WORD IN 1 SEG MODE, 2D
+ ; IN MULTI SEG MODE)
+P2: 0
+ 0 ; PC INT LEVEL 2
+P3: 0
+ 0 ; PC INT LEVEL 3
+CURPRI: 0
+TSAVA: 0
+TSAVB: 0
+PIRQ: 0
+PIRQ2: 0
+IOCLOS: 0 ; HOLDS LOSING JFN IN TNX IOC
+]
+PURE
+
+END
+\f
\ No newline at end of file
--- /dev/null
+
+TITLE INTERRUPT HANDLER FOR MUDDLE
+
+RELOCATABLE
+
+;C. REEVE APRIL 1971
+
+.INSRT MUDDLE >
+
+SYSQ
+XJRST=JRST 5,
+
+F==PVP
+G==TVP
+
+IF1,[
+IFE ITS,.INSRT STENEX >
+]
+
+PDLGRO==10000 ;AMOUNT TO GROW A PDL THAT LOSES
+NINT==72. ;MAXIMUM NUMBER OF INTERRUPTS POSSIBLE
+
+IFN ITS,[
+;SET UP LOCATION 42 TO POINT TO TSINT
+
+RMT [
+
+ZZZ==$. ;SAVE CURRENT LOCATION
+
+LOC 42
+
+ JSR MTSINT ;GO TO HANDLER
+
+LOC ZZZ
+]
+]
+
+; GLOBALS NEEDED BY INTERRUPT HANDLER
+
+.GLOBAL ONINT ; FUDGE INS EXECUTED IF NON ZERO AT START OF INTERRUPT
+.GLOBAL INTBCK ; "PC-LOSER HACK "
+.GLOBA GCFLG ;TELLS WHETHER OR NOT GARBAGE COLLECTOR IS RUNNING
+.GLOBAL GCFLCH ; FLUSH CHARS IMMEDIATE SO GC CAN SEE THEM
+.GLOBAL CORTOP ; TOP OF CORE
+.GLOBA GCINT ;TELLS GARBAGE COLLECTOR TO SIMULATE AN INTERRUPT
+.GLOBAL INTNUM,INTVEC ;TV ENTRIES CONCERNING INTERRUPTS
+.GLOBAL AGC ;CALL THE GARBAGE COLLECTOR
+.GLOBAL VECNEW,PARNEW,GETNUM ;GC PSEUDO ARGS
+.GLOBAL GCPDL ;GARBAGE COLLECTORS PDL
+.GLOBAL VECTOP,VECBOT ;DELIMIT VECTOR SPACE
+.GLOBAL PURTOP,CISTNG,SAGC
+.GLOBAL PDLBUF ;AMOUNT OF PDL GROWTH
+.GLOBAL PGROW ;POINTS TO DOPE WORD OF NEXT PDL TO GROW
+.GLOBAL TPGROW ;POINTS TO NEXT MUDDLE PDL TO GROW
+.GLOBAL TOPLEV,ERROR%,N.CHNS,CHNL1
+.GLOBAL BUFRIN,CHNL0,SYSCHR ;CHANNEL GLOBALS
+.GLOBAL IFALSE,TPOVFL,1STEPR,INTOBL,INCHAR,CURPRI,RDEVIC,RDIREC,GFALS,STATUS
+.GLOBAL PSTAT,NOTRES,IOIN2,INAME,INTFCN,CHNCNT,CHANNO,GIBLOK,ICONS,INCONS
+.GLOBAL IEVECT,INSRTX,ILOOKC,IPUT,IREMAS,IGET,CSTAK,EMERGE,CHFSWP
+.GLOBAL MTSINT ;BEGINNING OF INTERRUPT HANDLER
+.GLOBAL INTINT ;CALLED BY INITIALIZER TO TAKE CARE OF INT PCS
+.GLOBAL FRMSTK,APPLY,CHUNW,TGFALS
+.GLOBAL IPCGOT,DIRQ ;HANDLE BRANCHING OFF TO IPC KLUDGERY
+.GLOBAL MULTSG
+
+; GLOBALS FOR GC
+.GLOBAL GCTIM,GCCAUS,GCCALL,GPDLOV
+
+; GLOBALS FOR MONITOR ROUTINES
+
+.GLOBAL MONCH,MONCH0,RMONCH,RMONC0,LOCQ,SMON,BAPT,APLQ,MAKACT,NAPT
+.GLOBAL PURERR,BUFRIN,INSTAT,REALTV,DSTORE
+
+MONITOR
+
+.GLOBAL MSGTYP,MTYI,UPLO,IFLUSH,OCLOS,ERRET,MASK1,MASK2 ;SUBROUTINES USED
+.GLOBAL ERROR,LISTEN,ECHO,RRESET,MTYO,GCHAPN,P.CORE,P.TOP,QUEUES,NOTTY,TTYOP2,TTICHN
+.GLOBAL INTHLD,BNDV,SPECBE,DEMFLG,PLODR
+
+; GLOBALS FOR PRE-AGC INTERRUPT
+
+.GLOBAL FRETOP,GCSTOP,FREMIN,CORTOP,P.CORE,PURBOT,GETNUM,GCKNUM,GCHPN,INTAGC
+.GLOBAL SPECBIND,SSPEC1,ILVAL
+
+
+; GLOBALS FOR COPY/WRITE HACK FOR GCDUMP AND PURIFY
+
+.GLOBAL GCDFLG,%CWINF,BUFGC,WNDBOT,WIND,WNDP,%SHWND,GPURFL,%FDBUF,PURMNG,RPURBT
+.GLOBAL NPWRIT,PVSTOR,SPSTOR,OPSYS
+
+
+
+;BEGINNING OF ACTUAL INTERRUPT HANDLER (MUST BE IMPURE)
+
+
+;***** TEMP FUDGE *******
+
+QUEUES==INTVEC
+
+\f
+; DECLARATIONS ASSOCIATED WITH INTERRUPT HANDERS AND HEADERS
+
+; SPECIAL TABLES
+
+SPECIN: IRP A,,[CHAR,CLOCK,MPV,ILOPR,WRITE,READ,IOC,PURE,SYSDOWN,INFERIOR,RUNT,REALT
+PARITY]
+ MQUOTE A,[A]INTRUP
+ TERMIN
+SPECLN==.-SPECIN
+
+; TABLE OF SPECIAL FINDING ROUTINES
+
+FNDTBL: IRP A,,[GETCHN,0,0,0,LOCGET,LOCGET,0,0,0,0,0,0,0]
+ A
+ TERMIN
+
+; TABLE OF SPECIAL SETUP ROUTINES
+
+INTBL: IRP A,,[S.CHAR,S.CLOK,S.MPV,S.ILOP,S.WMON,S.RMON,S.IOC,S.PURE,S.DOWN,S.INF
+S.RUNT,S.REAL,S.PAR]
+ A
+ S!A==.IRPCNT
+ TERMIN
+
+IFN ITS,[
+
+; EXTERNAL INTERRUPT TABLE
+
+EXTINT: REPEAT NINT-36.,0
+ REPEAT 16.,HCHAR
+ 0
+ 0
+ REPEAT 8.,HINF
+ REPEAT NINT-62.,0
+EXTIND:
+
+IRP A,,[[HCLOCK,13.],[HMPV,14.],[HILOPR,6],[HIOC,9],[HPURE,26.],[HDOWN,7],[HREAL,35.]
+[HRUNT,34.],[HPAR,28.]]
+ IRP B,C,[A]
+ LOC EXTINT+C
+ B
+ .ISTOP
+ TERMIN
+TERMIN
+
+
+LOC EXTIND
+]
+\f
+IFE ITS,[
+
+; TABLES FOR TENEX INTERRUPT SYSTEM
+
+LEVTAB: P1 ; POINTS TO INT PC HOLDERS FOR LEVS 1,2 AND 3
+ P2
+ P3
+
+CHNMSK==700000,,7 ; WILL BE MASK WORD FOR INT SET UP
+MFORK==400000
+NNETS==7 ; ALLOW 7 NETWRK INTERRUPTS
+UINTS==4
+NETCHN==36.-NNETS-UINTS-1
+NCHRS==6
+RLCHN==36.-NNETS-UINTS
+
+RMT [
+IMPURE ; IMPURE BECAUSE IT CHANGES IN MULTI-SECTION MODE
+CHNTAB: ; LOCATION OF INT ROUTINES FOR VARIOUS "CHANNELS"
+
+REPEAT NCHRS, 1,,INTCHR+3*.RPCNT
+ BLOCK 36.-NNETS-NCHRS-UINTS-1 ; THERE ARE 36. TENEX INT CHANNELS
+
+REPEAT NNETS+UINTS, 1,,INTNET+3*.RPCNT
+
+IRP A,,[[9.,TNXPDL],[17.,PWRIT],[10.,TNXEOF],[11.,TNXIOC],[12.,TNXFUL]
+[RLCHN,TNXRLT],[19.,TNXINF]]
+ IRP B,C,[A]
+ LOC CHNTAB+B
+ 1,,C
+ CHNMSK==CHNMSK+<1_<35.-B>>
+ .ISTOP
+ TERMIN
+TERMIN
+LOC CHNTAB+36.
+PURE
+]
+EXTINT:
+BLOCK 36.
+REPEAT NCHRS,SETZ HCHAR
+BLOCK NINT-NNETS-NCHRS-UINTS-36.-1
+REPEAT NNETS,SETZ HNET
+REPEAT UINTS,SETZ USRINT
+LOC EXTINT+NINT-11.
+REPEAT 3,SETZ HIOC
+LOC EXTINT+NINT-RLCHN-1
+SETZ HREAL
+LOC EXTINT+NINT-19.-1
+SETZ HINF
+LOC EXTINT+NINT
+]
+
+
+; HANDLER/HEADER PARAMETERS
+
+; HEADER BLOCKS
+
+IHDRLN==4 ; LENGTH OF HEADER BLOCK
+
+INAME==0 ; NAME OF INTERRUPT
+ISTATE==2 ; CURRENT STATE
+IHNDLR==4 ; POINTS TO LIST OF HANDLERS
+INTPRI==6 ; CONTAINS PRIORITY OF INTERRUPT
+
+IHANDL==4 ; LENGTH OF A HANDLER BLOCK
+
+INXT==0 ; POINTS TO NEXTIN CHAIN
+IPREV==2 ; POINTS TO PREV IN CHAIN
+INTFCN==4 ; FUNCTION ASSOCIATED WITH THIS HANDLER
+INTPRO==6 ; PROCESS TO RUN INT IN
+
+IFN ITS,[
+RMT [
+IMPURE
+TSINT:
+MTSINT: 0 ;INTERRUPT BITS GET STORED HERE
+TSINTR: 0 ;INTERRUPT PC WORD STORED HERE
+ JRST TSINTP ;GO TO PURE CODE
+
+; SOFTWARE INTERNAL INTERRUPTS JSR TO HERE
+
+LCKINT: 0
+ JRST DOINT
+
+PURE
+]
+]
+IFE ITS,[
+RMT [
+; JSR HERE FOR SOFTWARE INTERNAL INTERRUPTS
+
+IMPURE
+LCKINT: 0
+ JRST DOINT
+PURE
+]
+]
+\f
+
+IFN ITS,[
+
+;THE REST OF THIS CODE IS PURE
+
+TSINTP: SOSGE INTFLG ; SKIP IF ENABLED
+ SETOM INTFLG ;DONT GET LESS THAN -1
+
+ SKIPE INTBCK ; ANY INT HACKS?
+ JRST PCLOSR ; DO A PC-LOSR ON THE PROGRAM
+ MOVEM A,TSAVA ;SAVE TWO ACS
+ MOVEM B,TSAVB
+ MOVE A,TSINT ;PICK UP INT BIT PATTERN
+ JUMPL A,2NDWORD ;DONT CHECK FOR PDL OVERFLOW ETC. IF SIGN BIT ON
+
+ TRZE A,200000 ;IS THIS A PDL OVERFLOW?
+ JRST IPDLOV ;YES, GO HANDLE IT FIRST
+
+IMPCH: MOVEI B,0
+ TRNE A,20000 ;IS IT A MEMORY PROTECTION VIOLATION?
+ MOVEI B,1 ; FLAG SAME
+
+ TRNE A,40 ;ILLEGAL OP CODE?
+ MOVEI B,2 ; ALSO FLAG
+ TRNN A,400 ; IOC?
+ JRST .+3
+ SOS TSINTR
+ MOVEI B,3
+ TLNE A,200 ; PURE?
+ JRST GCPWRT ; CHECK FOR PURE WRITE FOR POSSIBLE C/W
+NOPUGC: SOJGE B,DO.NOW ; CANT WAIT AROUND
+
+;DECODE THE REST OF THE INTERRUPTS USING A TABLE
+
+2NDWORD:
+ JUMPL A,GC2 ;2ND WORD?
+ IORM A,PIRQ ;NO, INTO WORD 1
+ JRST GCQUIT ;AND DISMISS INT
+
+GC2: TLZ A,400000 ;TURN OFF SIGN BIT
+ IORM A,PIRQ2
+ TRNE A,177777 ;CHECK FOR CHANNELS
+ JRST CHNACT ;GO IF CHANNEL ACTIVITY
+]
+GCQUIT: SKIPGE INTFLG ;SKIP IF INTERRUPTS ENABLED
+ JRST INTDON ;NO, DEFER REAL HANDLING UNTIL LATER
+
+ MOVE A,TSINTR ;PICKUP RETURN WORD
+IFE ITS,[
+ SKIPE MULTSG
+ JRST MLTEX
+ TLON A,10000 ; EXEC PC?
+ SOJA A,MLTEX1 ; YES FIXUP PC
+MLTEX: TLON A,10000
+ SOS TSINTR+1
+ MOVEM A,TSINTR
+ MOVE A,TSINTR+1
+]
+MLTEX1: MOVEM A,LCKINT ;STORE ELSEWHERE
+ MOVEI A,DOINTE ;CAUSE DISMISS TO HANDLER
+IFN ITS, HRRM A,TSINTR ;STORE IN INT RETURN
+IFE ITS,[
+ SKIPE MULTSG
+ HRRM A,TSINTR+1
+ SKIPN MULTSG
+ HRRM A,TSINTR
+]
+ PUSH P,INTFLG ;SAVE INT FLAG
+ SETOM INTFLG ;AND DISABLE
+
+
+INTDON: MOVE A,TSAVA ;RESTORE ACS
+ MOVE B,TSAVB
+IFN ITS, .DISMISS TSINTR ;AND DISMISS THE INTERRUPT
+IFE ITS, DEBRK
+
+IFN ITS,[
+PCLOSR: MOVEM A,TSAVA
+ HRRZ A,TSINTR ; WHERE FROM
+ CAIG A,INTBCK
+ CAILE A,INTBEN ; AVOID TIMING ERRORS
+ JRST .+2
+ JRST INTDON
+
+ SOS A,INTBCK
+ MOVEM A,TSINTR
+ SETZM INTBCK
+ SETZM INTFLG
+ AOS INTFLG
+ MOVE TP,TPSAV(TB)
+ MOVE P,PSAV(TB)
+ MOVE A,TSAVA
+ JRST TSINTP
+]
+DO.NOW: SKIPN GPURFL
+ SKIPE GCFLG
+ JRST DLOSER ; HANDLE FATAL GC ERRORS
+ MOVSI B,1
+ SKIPGE INTFLG ; IF NOT ENABLED
+ MOVEM B,INTFLG ; PRETEND IT IS
+IFN ITS, JRST 2NDWORD
+IFE ITS, JRST GCQUIT
+
+IFE ITS,[
+
+; HERE FOR TENEX PDL OVER FLOW INTERRUPT
+
+TNXPDL: SOSGE INTFLG
+ SETOM INTFLG
+ MOVEM A,TSAVA
+ MOVEM B,TSAVB
+ JRST IPDLOV ; GO TO COMMON HANDLER
+
+; HERE FOR REAL TIMER
+
+TNXRLT: MOVEM A,TSAVA
+IFG <RLCHN-18.>, MOVEI A,<1_<35.-<RLCHN>>>
+IFLE <RLCHN-18.> MOVSI A,(<1_<35.-<RLCHN>>>)
+
+ JRST CNTSG
+
+; HERE FOR TENEX ^G AND ^S INTERRUPTS
+
+INTCHR:
+REPEAT NCHRS,[
+ MOVEM A,TSAVA
+ MOVEI A,<1_<.RPCNT>>
+ JRST CNTSG
+]
+CNTSG: MOVEM B,TSAVB
+ IORM A,PIRQ2 ; SAY FOR MUDDLE LEVEL
+ SOSGE INTFLG
+ SETOM INTFLG
+ JRST GCQUIT
+INTNET:
+REPEAT NNETS+UINTS,[
+ MOVEM A,TSAVA
+ MOVE A,[1_<.RPCNT+NETCHN>]
+ JRST CNTSG
+]
+TNXINF: MOVEM A,TSAVA
+ MOVEI A,<1_<35.-19.>>
+ JRST TNXCHN
+
+; LOW LEVEL HANDLERS FOR 10X IOC INTERRUPTS
+
+TNXEOF: MOVEM A,TSAVA
+ MOVSI A,(1_<35.-10.>)
+ JRST TNXCHN
+
+TNXIOC: MOVEM A,TSAVA
+ MOVSI A,(1_<35.-11.>)
+ JRST TNXCHN
+
+TNXFUL: MOVEM A,TSAVA
+ SKIPN PLODR
+ JRST TNXFU1
+ FATAL DISK FULL IN PURE FIXUP, CONTINUE TO RETRY
+ JRST INTDON
+
+TNXFU1: MOVSI A,(1_<35.-12.>)
+
+TNXCHN: IORM A,PIRQ2
+ MOVEM B,TSAVB
+ HRRZ A,TSAVA ; ASSUME JFN IS IN A (PRETTY FLAKEY BUT ...)
+ MOVEM A,IOCLOS
+ JRST DO.NOW
+]
+\f
+; HERE TO PROCESS INTERRUPTS
+
+DOINT: SKIPE INTHLD ; GLOBAL LOCK ON INTS
+ JRST @LCKINT
+ SETOM INTHLD ; DONT LET IT HAPPEN AGAIN
+ PUSH P,INTFLG
+DOINTE: SKIPE ONINT ; ANY FUDGE?
+ XCT ONINT ; YEAH, TRY ONE
+ PUSH P,ONINT
+ SETZM ONINT
+ EXCH 0,LCKINT ; RELATIVIZE PC IF FROM RSUBR
+IFE ITS, TLZ 0,777740 ; KILL EXCESS BITS
+ PUSH P,0 ; AND SAVE
+ ANDI 0,-1
+ CAMG 0,PURTOP
+ CAMGE 0,VECBOT
+ JRST DONREL
+ SUBI 0,(M) ; M IS BASE REG
+IFN ITS, TLO 0,400000+M ; INDEX IT OFF M
+IFE ITS,[
+ TLO 0,400000+M
+ SKIPN MULTSG
+ JRST .+3
+ HLL 0,(P)
+ TLO 0,400000
+]
+ EXCH 0,(P) ; AND RESTORE TO STACK
+DONREL: EXCH 0,LCKINT ; GET BACK SAVED 0
+ SETZM INTFLG ;DISABLE
+ AOS -2(P) ;INCR SAVED FLAG
+
+;NOW SAVE WORKING ACS
+
+ PUSHJ P,SAVACS
+ HLRZ A,-2(P) ; HACK FUNNYNESS FOR MPV/ILOPR
+ SKIPE A
+ SETZM -2(P) ; REALLY DISABLED
+
+DIRQ: MOVE A,PIRQ ;NOW SATRT PROCESSING
+ JFFO A,FIRQ ;COUNT BITS AND GO
+ MOVE A,PIRQ2 ;1ST DONE, LOOK AT 2ND
+ JFFO A,FIRQ2
+
+INTDN1: SKIPN GCHAPN ; SKIP IF MUST DO GC INT
+ JRST .+3
+ SETZM GCHAPN
+ PUSHJ P,INTOGC ; AND INTERRUPT
+
+ PUSHJ P,RESTAC
+
+IFN ITS,[
+ .SUSET [.SPICLR,,[0]] ; DISABLE INTS
+]
+ POP P,LCKINT
+ POP P,ONINT
+ POP P,INTFLG
+ SETZM INTHLD ; RE-ENABLE THE WORLD
+IFN ITS,[
+ EXCH 0,LCKINT
+ HRRI 0,@0 ; EFFECTIVIZE THE ADDRESS
+ TLZ 0,37 ; KILL IND AND INDEX
+ EXCH 0,LCKINT
+ .DISMIS LCKINT
+]
+IFE ITS,[
+ SKIPN MULTSG
+ JRST @LCKINT
+ XJRST .+1 ; MAKE SURE OUT OF SECTION 0
+ 0
+ FSEG,,.+1
+ EXCH 0,LCKINT
+ TLZE 0,400000
+ ADDI 0,(M)
+ EXCH 0,LCKINT
+ JRST @LCKINT
+]
+FIRQ: PUSHJ P,GETBIT ;SET UP THE BIT TO CLOBBER IN PIRQ
+ ANDCAM A,PIRQ ;CLOBBER IT
+ ADDI B,36. ;OFSET INTO TABLE
+ JRST XIRQ ;GO EXECUTE
+
+FIRQ2: PUSHJ P,GETBIT ;PREPARE TO CLOBBER BIT
+ ANDCAM A,PIRQ2 ;CLOBBER IT
+ ADDI B,71. ;AGAIN OFFSET INTO TABLE
+XIRQ:
+ CAIE B,21 ;PDL OVERFLOW?
+ JRST FHAND ;YES, HACK APPROPRIATELY
+
+PDL2: JSP E,PDL3
+ JRST DIRQ
+
+PDL3: SKIPN A,PGROW
+ SKIPE A,TPGROW
+ JRST .+2
+ JRST (E) ; NOTHING GROWING, FALSE ALARM
+ MOVEI B,PDLGRO_-6 ;GET GROWTH SPEC
+ DPB B,[111100,,-1(A)] ;STORE GROWTH SPEC
+REAGC: MOVE C,[10.,,1] ; INDICATOR FOR AGC
+ SKIPE PGROW ; P IS GROWING
+ ADDI C,6
+ SKIPE TPGROW ; TP IS GROWING
+ ADDI C,1
+ PUSHJ P,AGC ;COLLECT GARBAGE
+ SETZM PGROW
+ SETZM TPGROW
+ AOJL A,REAGC ; IF NO CORE, RETRY
+ JRST (E)
+
+SAVACS:
+ PUSH P,PVP
+ MOVE PVP,PVSTOR+1
+IRP A,,[0,A,B,C,D,E,TVP,SP]
+ PUSH TP,A!STO(PVP)
+ SETZM A!STO(PVP) ;NOW ZERO TYPE
+ PUSH TP,A
+ TERMIN
+ PUSH TP,$TLOSE
+ PUSH TP,DSTORE
+ MOVE D,PVP
+ POP P,PVP
+ PUSH TP,PVPSTO(D)
+ PUSH TP,PVP
+ SKIPE D,DSTORE
+ MOVEM D,-13(TP) ; USE AS DSTO
+ SETZM DSTORE
+ POPJ P,
+
+RESTAC: POP TP,PVP
+ PUSH P,PVP
+ MOVE PVP,PVSTOR+1
+ POP TP,PVPSTO(PVP)
+ POP TP,DSTORE
+ SUB TP,[1,,1]
+IRP A,,[SP,TVP,E,D,C,B,A,0]
+ POP TP,A
+ POP TP,A!STO(PVP)
+ TERMIN
+ SKIPE DSTORE
+ SETZM DSTO(PVP)
+ POP P,PVP
+ POPJ P,
+
+; HERE TO DO GC INTERRUPT AND CLOSE ANY DEAD CHANNELS
+
+INTOGC: PUSH P,[N.CHNS-1]
+ MOVE PVP,PVSTOR+1
+ MOVE TVP,REALTV+1(PVP)
+ MOVEI A,CHNL1
+ SUBI A,(TVP)
+ HRLS A
+ ADD A,TVP
+ PUSH TP,$TVEC
+ PUSH TP,A
+
+INTGC1: MOVE A,(TP) ; GET POINTER
+ SKIPN B,1(A) ; ANY CHANNEL?
+ JRST INTGC2
+ HRRE 0,(A) ; INDICATOR
+ JUMPGE 0,INTGC2
+ PUSH TP,$TCHAN
+ PUSH TP,B
+ MCALL 1,FCLOSE
+
+ MOVE A,(TP)
+
+INTGC2: HLLZS (A)
+ ADD A,[2,,2]
+ MOVEM A,(TP)
+ SOSE (P)
+ JRST INTGC1
+
+ SUB P,[1,,1]
+ SUB TP,[2,,2]
+ PUSH TP,$TCHSTR
+ PUSH TP,CHQUOTE GC
+ PUSH TP,$TFLOAT ; PUSH ON TIME ARGUMENT
+ PUSH TP,GCTIM
+ PUSH TP,$TFIX ; PUSH ON THE CAUSE ARGUMENT
+ PUSH TP,GCCAUS
+ PUSH TP,$TATOM ; PUSH ON THE CALL ARGUMENT
+ MOVE A,GCCALL
+ PUSH TP,@GCALLR(A)
+ MCALL 4,INTERR
+ POPJ P,
+
+; PRE AGC INTERRUPT. CAUSED WHEN FREE STORAGE REQUEST CAN BE SATISFIED BY
+; EXTENDING CORE. IT IS CALLED "AGC" AND THE HANDLER IS PASSED THE CALLER,
+; AND THE PENDING REQUEST.
+
+
+INTAGC: MOVE A,GETNUM
+ MOVEM A,GCKNUM ; SET UP TO CAUSE INTERRUPT
+ PUSH P,C ; SAVE ARGS TO GC
+ MOVEI A,2000 ; GET WORKING SPACE
+ PUSHJ P,INTCOR ; GET IT
+ MOVSI A,TATOM ; EXAMINE BINDING OF FLAG
+ MOVE B,IMQUOTE AGC-FLAG
+ PUSHJ P,ILVAL
+ CAME A,$TUNBOUND
+ JRST INAGCO ; JUMP TO GET CORE FOR INTERRUPT
+ MOVE A,GETNUM
+ ADD A,P.TOP ; SEE IF WE CAN POSSIBLY WIN
+ ADD A,FREMIN
+ CAML A,PURBOT
+ JRST AGCCAU ; WORLD IS IN BAD SHAPE, CALL AGC
+ PUSH TP,$TTP ; BIND FLAG
+ PUSH TP,TP ; FOR UNBINDING PURPOSES
+ PUSH TP,[TATOM,,-1] ; SPECBINDS ARGS
+ PUSH TP,IMQUOTE AGC-FLAG
+ PUSH TP,$TFIX
+ PUSH TP,[-1]
+ PUSH TP,[0]
+ PUSH TP,[0]
+ PUSHJ P,SPECBIND
+
+; SET UP CALL TO HANDLER
+
+ PUSH TP,$TCHSTR ; STRING INDICATING INTERRUPT
+ PUSH TP,CHQUOTE DIVERT-AGC
+ PUSH TP,$TFIX ; PENDING REQUEST
+ PUSH TP,GETNUM
+ HLRZ C,(P)
+ PUSH TP,$TATOM
+ PUSH TP,@GCALLR(C)
+ SETZM GCHPN
+ MCALL 3,INTERR ; ENABLE INTERRUPT
+ GETYP A,A ; CHECK TO SEE IF INTERRUPT WAS ENABLED
+ HRRZ E,-6(TP) ; GET ARG FOR UNBINDING
+ PUSHJ P,SSPEC1
+ SUB TP,[8,,8] ; CLEAN OFF STACK
+ CAIE A,TFALSE ; SKIP IF NOT
+ JRST CHKWIN
+
+; CAUSE AN AGC TO HAPPEN
+
+AGCCAU: MOVE C,(P) ; INDICATOR
+ PUSHJ P,SAGC ; CALL AGC
+ JRST FINAGC
+
+; SEE WHETHER ENOUGH CORE WAS ALLOCATED
+CHKWIN: MOVE A,FRETOP
+ SUB A,GCSTOP
+ SUB A,GCKNUM ; AMOUNT NEEDED OR IN EXCESS
+ JUMPGE A,FINAGC ; JUMP IF DONE
+ MOVE A,GCKNUM
+ MOVEM A,GETNUM ; SET UP REQUEST
+ MOVE C,(P)
+ JRST AGCCAU
+FINAGC: SETZM GETNUM
+ POP P,C ; RESTORE C
+ POPJ P, ; EXIT
+
+; ROUTINE TO HANDLE INTERRUPT WHILE INTERRUPT IS RUNNING
+; IT TRIES TO ALLOCATE FOR REQUEST+ AT LEAST ONE CORE BLOCK
+
+INAGCO: MOVE A,GETNUM ; GET REQUEST
+ SUB A,GCKNUM ; CALCULATE REAL CURRENT REQUEST
+ ADDI A,1777
+ ANDCMI A,1777 ; AMOUNT WANTED
+ PUSHJ P,INTCOR ; GET IT
+ POP P,C ; RESTORE C
+ POPJ P, ; EXIT
+
+; ROUTINE TO GET CORE FOR PRE-AGC INTERRUPT. REQUEST IN A
+
+
+INTCOR: ADD A,P.TOP ; ADD TOP TO REQUEST
+ CAML A,PURBOT ; SKIP IF BELOW PURE
+ JRST AGCCA1 ; LOSE
+ MOVEM A,CORTOP ; STORE POSSIBLE CORE TOP
+ ASH A,-10. ; TO PAGES
+ PUSHJ P,P.CORE ; GET THE CORE
+ JRST AGCCA1 ; LOSE,LOSE,LOSE
+ PUSH P,B
+ MOVE B,FRETOP
+ SUBI B,2000
+ MOVE A,FRETOP
+ SETZM (B)
+ HRLI B,(B)
+ ADDI B,1
+ BLT B,-1(A)
+ POP P,B
+ MOVEM A,FRETOP
+ POPJ P, ; EXIT
+AGCCA1: MOVE C,-1(P) ; GET ARGS FOR AGC
+ SUB P,[1,,1] ; FLUSH RETURN ADDRESS
+ JRST AGCCAU+1
+
+
+
+GCALLR: MQUOTE GC-READ
+ MQUOTE BLOAT
+ MQUOTE GROW
+ IMQUOTE LIST
+ IMQUOTE VECTOR
+ IMQUOTE SET
+ IMQUOTE SETG
+ MQUOTE FREEZE
+ MQUOTE PURE-PAGE-LOADER
+ MQUOTE GC
+ MQUOTE INTERRUPT-HANDLER
+ MQUOTE NEWTYPE
+ MQUOTE PURIFY
+
+\f; OLD "ON" SETS UP EVENT AND HANDLER
+
+MFUNCTION ON,SUBR
+
+ ENTRY
+
+ HLRE 0,AB ; 0=> -2*NUM OF ARGS
+ ASH 0,-1 ; TO -NUM
+ CAME 0,[-5]
+ JRST .+3
+ MOVEI B,10(AB) ; LAST MUST BE CHAN OR LOC
+ PUSHJ P,CHNORL
+ ADDI 0,3
+ JUMPG 0,TFA ; AT LEAST 3
+ MOVEI A,0 ; SET UP IN CASE NO PROC
+ AOJG 0,ONPROC ; JUMP IF NONE
+ GETYP C,6(AB) ; CHECK IT
+ CAIE C,TPVP
+ JRST TRYFIX
+ MOVE A,7(AB) ; GET IT
+ONPROC: PUSH P,A ; SAVE AS A FLAG
+ GETYP A,(AB) ; CHECK PREV EXISTANCE
+ PUSH P,0
+ CAIN A,TATOM
+ JRST .+3
+ CAIE A,TCHSTR
+ JRST WTYP1
+ MOVEI B,(AB) ; FIND IT
+ PUSHJ P,FNDINT
+ POP P,0 ; REST NUM OF ARGS
+ JUMPN B,ON3 ; ALREADY THERE
+ SKIPE C ; SKIP IF NOTHING TO FLUSH
+ SUB TP,[2,,2]
+ PUSH TP,(AB) ; GET NAME
+ PUSH TP,1(AB)
+ PUSH TP,4(AB)
+ PUSH TP,5(AB)
+ MOVEI A,2 ; # OF ARGS TO EVENT
+ AOJG 0,ON1 ; JUMP IF NO LAST ARG
+ PUSH TP,10(AB)
+ PUSH TP,11(AB)
+ ADDI A,1
+ON1: ACALL A,EVENT
+
+ON3: PUSH TP,A
+ PUSH TP,B
+ PUSH TP,2(AB) ; NOW FCN
+ PUSH TP,3(AB)
+ MOVEI A,3 ; NUM OF ARGS
+ SKIPN (P)
+ SOJA A,ON2 ; NO PROC
+ PUSH TP,$TPVP
+ PUSH TP,7(AB)
+ON2: ACALL A,HANDLER
+ JRST FINIS
+
+
+TRYFIX: SKIPN A,7(AB)
+ CAIE C,TFIX
+ JRST WRONGT
+ JRST ONPROC
+\f
+; ROUTINE TO BUILD AN EVENT
+
+MFUNCTION EVENT,SUBR
+
+ ENTRY
+
+ HLRZ 0,AB
+ CAIN 0,-2 ; IF JUST 1
+ JRST RE.EVN ; COULD BE EVENT
+ CAIL 0,-3 ; MUST BE AT LEAST 2 ARGS
+ JRST TFA
+ GETYP A,2(AB) ; 2ND ARG MUST BE FIXED POINT PRIORITY
+ CAIE A,TFIX
+ JRST WTYP2
+ GETYP A,(AB) ; FIRST ARG SHOULD BE CHSTR
+ CAIN A,TATOM ; ALLOW ACTUAL ATOM
+ JRST .+3
+ CAIE A,TCHSTR
+ JRST WTYP1
+ CAIL 0,-5
+ JRST GOTRGS
+ CAIG 0,-7
+ JRST TMA
+ MOVEI B,4(AB)
+ PUSHJ P,CHNORL ; CHANNEL OR LOCATIVE (PUT ON STACK)
+
+GOTRGS: MOVEI B,(AB) ; NOW TRY TO FIND HEADER FOR THIS INTERRUPT
+ PUSHJ P,FNDINT ; CALL INTERNAL HACKER
+ JUMPN B,FINIS ; ALREADY ONE OF THIS NAME
+ PUSH P,C
+ JUMPE C,.+3 ; GET IT OFF STACK
+ POP TP,B
+ POP TP,A
+ PUSHJ P,MAKINT ; MAKE ONE FOR ME
+ MOVSI 0,TFIX
+ MOVEM 0,INTPRI(B) ; SET UP PRIORITY
+ MOVE 0,3(AB)
+ MOVEM 0,INTPRI+1(B)
+CH.SPC: POP P,C ; GET CODE BACK
+ SKIPGE C
+ PUSHJ P,DO.SPC ; DO ANY SPECIAL HACKS
+ JRST FINIS
+
+RE.EVN: GETYP 0,(AB)
+ CAIE 0,TINTH
+ JRST TFA ; ELSE SAY NOT ENOUGH
+ MOVE B,1(AB) ; GET IT
+ SETZM ISTATE+1(B) ; MAKE SURE ENABLED
+ SETZB D,C
+ GETYP A,INAME(B) ; CHECK FOR CHANNEL
+ CAIN A,TCHAN ; SKIP IF NOT
+ HRROI C,SS.CHA ; SET UP CHANNEL HACK
+ HRLZ E,INTPRI(B) ; GET POSSIBLE READ/WRITE BITS
+ TLNE E,.WRMON+.RDMON ; SKIP IF NOT MONITORS
+ PUSHJ P,GETNM1
+ JUMPL C,RE.EV1
+ MOVE B,INAME+1(B) ; CHECK FOR SPEC
+ PUSHJ P,SPEC1
+ MOVE B,1(AB) ; RESTORE IHEADER
+RE.EV1: PUSH TP,INAME(B)
+ PUSH TP,INAME+1(B)
+ PUSH P,C
+ MOVSI C,TATOM
+ PUSH TP,$TATOM
+ SKIPN D
+ MOVE D,MQUOTE INTERRUPT
+ PUSH TP,D
+ MOVE A,INAME(B)
+ MOVE B,INAME+1(B) ; GET IT
+ PUSHJ P,IGET ; LOOK FOR IT
+ JUMPN B,FINIS ; RETURN IT
+ MOVE A,(TB)
+ MOVE B,1(TB)
+ POP TP,D
+ POP TP,C
+ PUSH TP,(AB)
+ PUSH TP,1(AB)
+ PUSHJ P,IPUT ; REESTABLISH IT
+ MOVE A,(AB)
+ MOVE B,1(AB)
+ JRST CH.SPC
+
+\f
+; FUNCTION TO GENERATE A HANDLER FOR A GIVEN INTERRUPT
+
+MFUNCTION HANDLER,SUBR
+
+ ENTRY
+
+ HLRZ 0,AB
+ CAIL 0,-2 ; MUST BE 2 OR MORE ARGS
+ JRST TFA
+ GETYP A,(AB)
+ CAIE A,TINTH ; EVENT?
+ JRST WTYP1
+ GETYP A,2(AB)
+ CAIN 0,-4 ; IF EXACTLY 2
+ CAIE A,THAND ; COULD BE HANDLER
+ JRST CHEVNT
+
+ MOVE B,3(AB) ; GET IT
+ SKIPN IPREV+1(B) ; SKIP IF ALREADY IN USE
+ JRST HNDOK
+ MOVE D,1(AB) ; GET EVENT
+ SKIPN D,IHNDLR+1(D) ; GET FIRST HANDLER
+ JRST BADHND
+ CAMN D,B ; IS THIS IT?
+ JRST HFINIS ; YES, ALREADY "HANDLED"
+ MOVE D,INXT+1(D) ; GO TO NEXT HANDLER
+ JUMPN D,.-3
+BADHND: ERRUUO EQUOTE HANDLER-ALREADY-IN-USE
+
+CHEVNT: CAIG 0,-7 ; SKIP IF LESS THAN 4
+ JRST TMA
+ PUSH TP,$TPVP ; SLOT FOR PROCESS
+ PUSH TP,[0]
+ CAIE 0,-6 ; IF 3, LOOK FOR PROC
+ JRST NOPROC
+ GETYP 0,4(AB)
+ CAIE 0,TPVP
+ JRST WTYP3
+ MOVE 0,5(AB)
+ MOVEM 0,(TP)
+
+NOPROC: PUSHJ P,APLQ
+ JRST NAPT
+ PUSHJ P,MHAND ; MAKE THE HANDLER
+ MOVE 0,1(TB) ; GET PROCESS
+ MOVEM 0,INTPRO+1(B) ; AND PUT IT INTO HANDLER
+ MOVSI 0,TPVP ; SET UP TYPE
+ MOVEM 0,INTPRO(B)
+ MOVE 0,2(AB) ; SET UP FUNCTION
+ MOVEM 0,INTFCN(B)
+ MOVE 0,3(AB)
+ MOVEM 0,INTFCN+1(B)
+
+HNDOK: MOVE D,1(AB) ; PICK UP EVEENT
+ MOVE E,IHNDLR+1(D) ; GET POINTER TO HANDLERS
+ MOVEM B,IHNDLR+1(D) ; PUT NEW ONE IN
+ MOVSI 0,TINTH ; GET INT HDR TYPE
+ MOVEM 0,IPREV(B) ; INTO BACK POINTER
+ MOVEM D,IPREV+1(B) ; AND POINTER ITSELF
+ MOVEM E,INXT+1(B) ; NOW NEXT POINTER
+ MOVSI 0,THAND ; NOW HANDLER TYPE
+ MOVEM 0,IHNDLR(D) ; SET TYPE IN HEADER
+ MOVEM 0,INXT(B)
+ JUMPE E,HFINIS ; JUMP IF HEADER WAS EMPTY
+ MOVEM 0,IPREV(E) ; FIX UP ITS PREV
+ MOVEM B,IPREV+1(E)
+HFINIS: MOVSI A,THAND
+ JRST FINIS
+
+\f
+
+; FUNCTIONS TO SET TIME LIMITS FOR REALTIME AND RUNTIME INTS
+
+IFN ITS,[
+
+MFUNCTION RUNTIMER,SUBR
+
+ ENTRY
+
+ CAMG AB,[-3,,0]
+ JRST TMA
+ JUMPGE AB,RNTLFT
+ GETYP 0,(AB)
+ JFCL 10,.+1
+ MOVE A,1(AB)
+ CAIE 0,TFIX
+ JRST RUNT1
+ IMUL A,[245761.]
+ JRST RUNT2
+
+RUNT1: CAIE 0,TFLOAT
+ JRST WTYP1
+ FMPR A,[245760.62]
+ MULI A,400 ; FIX IT
+ TSC A,A
+ ASH B,(A)-243
+ MOVE A,B
+RUNT2: JUMPL A,OUTRNG ; NOT FOR NEG #
+ JFCL 10,OUTRNG
+ .SUSET [.SRTMR,,A]
+ MOVE A,(AB)
+ MOVE B,1(AB)
+ JRST FINIS
+RNTLFT: .SUSET [.RRTMR,,B]
+ JUMPL B,IFALSE ; RETURN FALSE IF NONE SET
+ IDIV B,[245761.] ; TO SECONDS
+ MOVSI A,TFIX
+ JRST FINIS
+
+]
+.TIMAL==5
+.TIMEL==1
+
+MFUNCTION REALTIMER,SUBR
+
+ ENTRY
+
+ CAMG AB,[-3,,0]
+ JRST TMA
+ JUMPGE AB,RLTPER
+ JFCL 10,.+1
+ GETYP 0,(AB)
+ MOVE A,1(AB)
+ CAIE 0,TFIX
+ JRST REALT1
+IFN ITS, IMULI A,60. ; TO 60THS OF SEC
+IFE ITS, IMULI A,1000. ; TO MILLI
+ JRST REALT2
+
+REALT1: CAIE 0,TFLOAT
+ JRST WTYP1
+IFN ITS, FMPRI A,(60.0)
+IFE ITS, FMPRI A,(1000.0)
+ MULI A,400
+ TSC A,A
+ ASH B,(A)-243
+ MOVE A,B
+
+REALT2: JUMPL A,OUTRNG
+ JFCL 10,OUTRNG
+ MOVEM A,RLTSAV
+IFN ITS,[
+ MOVE B,[200000,,A]
+ SKIPN A
+ MOVSI B,400000
+ .REALT B,
+ JFCL
+]
+IFE ITS,[
+ MOVE A,[MFORK,,.TIMAL] ; FLUSH CURRENT FIRST
+ TIMER
+ JRST TIMERR
+ SKIPN B,RLTSAV
+ JRST RETRLT
+ HRRI A,.TIMEL
+ MOVEI C,RLCHN
+ TIMER
+ JRST TIMERR
+RETRLT: MOVE A,(AB)
+ MOVE B,1(AB)
+ JRST FINIS
+
+TIMERR: MOVNI A,1
+ PUSHJ P,TGFALS
+ JRST FINIS
+
+RLTPER: SKIPGE B,RLTSAV
+ JRST IFALSE
+IFN ITS, IDIVI B,60. ; BACK TO SECONDS
+IFE ITS, IDIVI B,1000.
+ MOVSI A,TFIX
+ JRST FINIS
+
+
+; FUNCTIONS TO ENABLE AND DISABLE INTERRUPTS
+
+MFUNCTION %ENABL,SUBR,ENABLE
+
+ PUSHJ P,GTEVNT
+ SETZM ISTATE+1(B)
+ JRST FINIS
+
+MFUNCTION %DISABL,SUBR,DISABLE
+
+
+ PUSHJ P,GTEVNT
+ SETOM ISTATE+1(B)
+ JRST FINIS
+
+GTEVNT: ENTRY 1
+ GETYP 0,(AB)
+ CAIE 0,TINTH
+ JRST WTYP1
+ MOVE A,(AB)
+ MOVE B,1(AB)
+ POPJ P,
+
+DO.SPC: HRRO C,INTBL(C) ; POINT TO SPECIAL CODE
+ HLRZ 0,AB ; - TWO TIMES NUM ARGS
+ PUSHJ P,(C) ; CALL ROUTINE
+ JUMPE E,CPOPJ ; NO BITS TO ENABLE, LEAVE
+IFE ITS,[
+ PUSH TP,A
+ PUSH TP,B
+ MOVE B,1(TB) ; CHANNEL
+ MOVE 0,CHANNO(B)
+ MOVEM 0,(E) ; SAVE IN TABLE
+ MOVEI E,(E)
+ SUBI E,NETJFN-NETCHN
+ MOVE A,0 ; SETUP FOR MTOPR
+ MOVEI B,24
+ MOVSI C,(E)
+ TLO C,770000 ; DONT SETUP INR/INS
+ MTOPR
+ MOVEI 0,1
+ MOVNS E
+ LSH 0,35.(E)
+ IORM 0,MASK1
+ MOVE B,MASK1
+ MOVEI A,MFORK
+ AIC
+
+ POP TP,B
+ POP TP,A
+ POPJ P, ; ***** TEMP ******
+]
+IFN ITS,[
+ CAILE E,35. ; SKIP IF 1ST WORD BIT
+ JRST SETW2
+ LSH 0,-1(E)
+
+ IORM 0,MASK1 ; STORE IN PROTOTYPE MASK
+ .SUSET [.SMASK,,MASK1]
+ POPJ P,
+
+SETW2: LSH 0,-36.(E)
+ IORM 0,MASK2 ; SET UP PROTO MASK2
+ .SUSET [.SMSK2,,MASK2]
+ POPJ P,
+]
+
+; ROUTINE TO CHECK FOR CHANNEL OR LOCATIVE
+
+CHNORL: GETYP A,(B) ; GET TYPE
+ CAIN A,TCHAN ; IF CHANNEL
+ JRST CHNWIN
+ PUSH P,0
+ PUSHJ P,LOCQ ; ELSE LOOCATIVE
+ JRST WRONGT
+ POP P,0
+CHNWIN: PUSH TP,(B)
+ PUSH TP,1(B)
+ POPJ P,
+\f
+; SUBROUTINE TO FIND A HANDLER OF A GIVEN NAME
+
+FNDINT: PUSHJ P,FNDNM
+ JUMPE B,CPOPJ
+ PUSHJ P,SPEC1 ; COULD BE FUNNY
+
+INTASO: PUSH P,C ; C<0 IF SPECIAL
+ PUSH TP,A
+ PUSH TP,B
+ MOVSI C,TATOM
+ SKIPN D ; COULD BE CHANGED FOR MONITOR
+ MOVE D,MQUOTE INTERRUPT
+ PUSH TP,C
+ PUSH TP,D
+ PUSHJ P,IGET
+ MOVE D,(TP)
+ SUB TP,[2,,2]
+ POP P,C ; AND RESTOR SPECIAL INDICATOR
+ SKIPE B ; IF FOUND
+ SUB TP,[2,,2] ; REMOVE CRUFT
+CPOPJ: POPJ P, ; AND RETURN
+
+; CHECK FOR SPECIAL INTERNAL INTERRUPT HACK
+
+SPEC1: MOVSI C,-SPECLN ; BUILD AOBJN PNTR
+SPCLOP: CAME B,@SPECIN(C) ; SKIP IF SPECIAL
+ AOBJN C,.-1 ; UNTIL EXHAUSTED
+ JUMPGE C,.+3
+ SKIPE E,FNDTBL(C)
+ JRST (E)
+ MOVEI 0,-1(TB) ; SEE IF OK
+ CAIE 0,(TP)
+ JRST TMA
+ POPJ P,
+
+; ROUTINE TO CREATE A NEW INTERRUPT (INTERNAL ONLY--NOT ITS FLAVOR)
+
+MAKINT: JUMPN C,GOTATM ; ALREADY HAVE NAME, GET THING
+ MOVEI B,(AB) ; POINT TO STRING
+ PUSHJ P,CSTAK ; CHARS TO STAKC
+ MOVE B,INTOBL+1
+ PUSHJ P,INSRTX
+ MOVE D,MQUOTE INTERRUPT
+GOTATM: PUSH TP,$TINTH ; MAKE SLOT FOR HEADER BLOCK
+ PUSH TP,[0]
+ PUSH TP,A
+ PUSH TP,B ; SAVE ATOM
+ PUSH TP,$TATOM
+ PUSH TP,D
+ MOVEI A,IHDRLN*2
+ PUSHJ P,GIBLOK
+ MOVE A,-3(TP) ; GET NAME AND STORE SAME
+ MOVEM A,INAME(B)
+ MOVE A,-2(TP)
+ MOVEM A,INAME+1(B)
+ SETZM ISTATE+1(B)
+ MOVEM B,-4(TP) ; STASH HEADER
+ POP TP,D
+ POP TP,C
+ EXCH B,(TP)
+ MOVSI A,TINTH
+ EXCH A,-1(TP) ; INTERNAL PUT CALL
+ PUSHJ P,IPUT
+ POP TP,B
+ POP TP,A
+ POPJ P,
+
+; FIND NAME OF INTERRUPT
+
+FNDNM: GETYP A,(B) ; TYPE
+ CAIE A,TCHSTR ; IF STRING
+ JRST FNDATM ; DONT HAVE ATOM, OTHERWISE DO
+ PUSHJ P,IILOOK
+ JRST .+2
+FNDATM: MOVE B,1(B)
+ SETZB C,D ; PREVENT LOSSAGE LATER
+ MOVSI A,TATOM
+
+; THE NEXT 2 INSTRUCTIONS ARE A KLUDGE TO GET THE RIGHT ERROR ATOM
+
+ CAMN B,IMQUOTE ERROR
+ MOVE B,MQUOTE ERROR,ERROR,INTRUP
+ POPJ P,
+
+IILOOK: PUSHJ P,CSTAK ; PUT CHRS ON STACK
+ MOVSI A,TOBLS
+ MOVE B,INTOBL+1
+ JRST ILOOKC ; LOOK IT UP
+\f
+; ROUTINE TO MAKE A HANDLER BLOCK
+
+MHAND: MOVEI A,IHANDL*2
+ JRST GIBLOK ; GET BLOCK
+
+; HERE TO GET CHANNEL FOR "CHAR" INTERRUPT
+
+GETCHN: GETYP 0,(TB) ; GET TYPE
+ CAIE 0,TCHAN ; CHANNL IS WINNER
+ JRST WRONGT
+ MOVE A,(TB) ; USE THE CHANNEL TO NAME THE INTERRUPT
+ MOVE B,1(TB)
+ SKIPN CHANNO(B) ; SKIP IF WINNING CHANNEL
+ JRST CBDCHN ; LOSER
+ POPJ P,
+
+LOCGET: GETYP 0,(TB) ; TYPE
+ CAIN 0,TCHAN ; SKIP IF LOCATIVE
+ JRST WRONGT
+ MOVE D,B
+ MOVE A,(TB)
+ MOVE B,1(TB) ; GET LOCATIVE
+ POPJ P,
+
+; FINAL MONITOR SETUP ROUTINES
+
+S.RMON: SKIPA E,[.RDMON,,]
+S.WMON: MOVSI E,.WRMON
+ PUSH TP,A
+ PUSH TP,B
+ HLRM E,INTPRI(B) ; SAVE BITS
+ MOVEI B,(TB) ; POINT TO LOCATIVE
+ HRRZ A,FSAV(TB)
+ CAIN A,OFF
+ MOVSI D,(ANDCAM E,) ; KILL INST
+ CAIN A,EVENT
+ MOVSI D,(IORM E,)
+ PUSHJ P,SMON ; GO DO IT
+ POP TP,B
+ POP TP,A
+ MOVEI E,0
+ POPJ P,
+\f
+
+; SPECIAL SETUP ROUTINES FOR INITIAL INTERRUPTS
+
+IFN ITS,[
+S.CHAR: MOVE E,1(TB) ; GET CHANNEL
+ MOVE 0,RDEVIC(E)
+ ILDB 0,0 ; 1ST CHAR TO 0
+ CAIE 0,"T ; TTY
+ JRST .+3 ; NO
+ MOVEI 0,C.INTL
+ XORM 0,-2(E) ; IN CASE OUTPUT
+ MOVE E,CHANNO(E)
+ ADDI E,36. ; GET CORRECT MASK BIT
+ONEBIT: MOVEI 0,1 ; BIT FOR INT TO RET
+ POPJ P,
+]
+IFE ITS,[
+S.CHAR: MOVE E,1(TB)
+ MOVEI 0,C.INTL
+ XORM 0,-2(E) ; IN CASE OUTPUT
+ MOVE 0,RDEVIC(E)
+ ILDB 0,0 ; 1ST CHAR
+ PUSH P,A
+ CAIE 0,"N ; NET ?
+ JRST S.CHA1
+
+ MOVEI A,0
+ HRRZ 0,CHANNO(E)
+ MOVE E,[-NNETS,,NETJFN]
+ CAMN 0,(E)
+ JRST S.CHA2
+ SKIPN (E)
+ MOVE A,E ; REMEMBER WHERE
+ AOBJN E,.-4
+ TLNN A,-1
+ FATAL NO MORE NETWORK
+ SKIPA E,A
+S.CHA1: MOVEI E,0
+S.CHA2: POP P,A
+ POPJ P,
+]
+
+
+; SPECIAL FOR CLOCK
+IFN ITS,[
+S.DOWN: SKIPA E,[7]
+S.CLOK: MOVEI E,13. ; FOR NOW JUST GET BIT #
+ JRST ONEBIT
+
+S.PAR: MOVEI E,28.
+ JRST ONEBIT
+
+; RUNTIME AND REALTIME INTERRUPTS
+
+S.RUNT: SKIPA E,[34.]
+S.REAL: MOVEI E,35.
+ JRST ONEBIT
+
+S.IOC: SKIPA E,[9.] ; IO CHANNEL ERROR
+S.PURE: MOVEI E,26.
+ JRST ONEBIT
+
+; MPV AND ILOPR
+
+S.MPV: SKIPA E,[14.] ; BIT POS
+S.ILOP: MOVEI E,6
+ JRST ONEBIT
+
+; HERE TO TURN ALL INFERIOR INTS
+
+S.INF: MOVEI E,36.+16.+2 ; START OF BITS
+ MOVEI 0,37 ; 8 BITS WORTH
+ POPJ P,
+]
+IFE ITS,[
+S.PURE:
+S.MPV:
+S.ILOP:
+S.DOWN:
+S.CLOK:
+S.PAR:
+
+
+S.RUNT: ERRUUO EQUOTE INTERRUPT-UNAVAILABLE-ON-TENEX
+S.IOC: MOVEI 0,7 ; 3 BITS FOR EOF/FULL/ERROR
+ MOVEI E,10.
+ POPJ P,
+
+S.INF:
+S.REAL: MOVEI E,0
+ POPJ P,
+]
+
+
+; HERE TO HANDLE ITS INTERRUPTS
+
+FHAND: SKIPN D,EXTINT(B) ; SKIP IF HANDLERS ARE POSSIBLE
+ JRST DIRQ
+ JRST (D)
+
+IFN ITS,[
+; SPECIAL CHARACTER HANDLERS
+
+HCHAR: MOVEI D,CHNL0+1
+ ADDI D,(B) ; POINT TO CHANNEL SLOT
+ ADDI D,(B)
+ SKIPN D,-72.(D) ; PICK UP CHANNEL
+ JRST IPCGOT ;WELL, IT GOTTA BEE THE THE IPC THEN
+ PUSH TP,$TCHAN
+ PUSH TP,D
+ LDB 0,[600,,STATUS(D)] ; GET DEVICE CODE
+ CAILE 0,2 ; SKIP IF A TTY
+ JRST HNET ; MAYBE NETWORK CHANNEL
+ HRRZ 0,-2(D)
+ TRNN 0,C.READ
+ JRST HMORE
+ CAMN D,TTICHN+1
+ SKIPE DEMFLG ; SKIP IF NOT DEMON
+ JRST .+3
+ SKIPN NOTTY
+ JRST HCHR11
+ MOVE B,D ; CHAN TO B
+ PUSH P,A
+ PUSHJ P,TTYOP2 ; RE-GOBBLE TTY
+ POP P,A
+ MOVE D,(TP)
+HCHR11: MOVE D,CHANNO(D) ; GET ITS CHANNEL
+ PUSH P,D ; AND SAVE IT
+ .CALL HOWMNY ; GET # OF CHARS
+ MOVEI B,0 ; IF TTY GONE, NO CHARS
+RECHR: ADDI B,1 ; BUMP BY ONE FOR SOSG
+ MOVEM B,CHNCNT(D) ; AND SAVE
+ IORM A,PIRQ2 ; LEAVE THE INT ON
+
+CHRLOO: MOVE D,(P) ; GET CHNNAEL NO.
+ SOSG CHNCNT(D) ; GET COUNT
+ JRST CHRDON
+
+ MOVE B,(TP)
+ MOVE D,BUFRIN(B) ; GET EXTRA BUFFER
+ XCT IOIN2(D) ; READ CHAR
+ JUMPL A,CHRDON ; NO CHAR THERE, FORGET IT
+ PUSH TP,$TCHSTR
+ PUSH TP,CHQUOTE CHAR
+ PUSH TP,$TCHRS ; SAVE CHAR FOR CALL
+ PUSH TP,A
+ PUSH TP,$TCHAN ; SAVE CHANNEL
+ PUSH TP,B
+ PUSHJ P,INCHAR ; PUT CHAR IN USERS BUFFER
+ MCALL 3,INTERRUPT ; RUN THE HANDLERS
+ JRST CHRLOO ; AND LOOP
+
+CHRDON: .CALL HOWMNY
+ MOVEI B,0
+ MOVEI A,1 ; SET FOR PI WORD CLOBBER
+ LSH A,(D)
+ JUMPG B,RECHR ; ANY MORE?
+ ANDCAM A,PIRQ2
+ SUB P,[1,,1]
+ SUB TP,[2,,2]
+ JRST DIRQ
+
+
+\f
+; HERE FOR NET CHANNEL INTERRUPT
+
+HNET: CAIE 0,26 ; NETWORK?
+ JRST HSTYET ; HANDLE PSEUDO TTY ETC.
+ PUSH TP,$TATOM
+ PUSH TP,MQUOTE CHAR,CHAR,INTRUP
+ PUSH TP,$TUVEC
+ PUSH TP,BUFRIN(D)
+ PUSH TP,$TCHAN
+ PUSH TP,D
+ MOVE B,D ; CHAN TO B
+ PUSHJ P,INSTAT ; UPDATE THE NETWRK STATE
+ MCALL 3,INTERRUPT
+ SUB TP,[2,,2]
+ JRST DIRQ
+
+HMORE:
+HSTYET: PUSH TP,$TATOM
+ PUSH TP,MQUOTE CHAR,CHAR,INTRUP
+ PUSH TP,$TCHAN
+ PUSH TP,D
+ MCALL 2,INTERRUPT
+ SUB TP,[2,,2]
+ JRST DIRQ
+
+]
+CBDCHN: ERRUUO EQUOTE BAD-CHANNEL
+
+IFN ITS,[
+
+HCLOCK: PUSH TP,$TCHSTR
+ PUSH TP,CHQUOTE CLOCK
+ MCALL 1,INTERRUPT
+ JRST DIRQ
+
+HRUNT: PUSH TP,$TATOM
+ PUSH TP,MQUOTE RUNT,RUNT,INTRUP
+ MCALL 1,INTERRUPT
+ JRST DIRQ
+]
+HREAL: PUSH TP,$TATOM
+ PUSH TP,MQUOTE REALT,REALT,INTRUP
+ MCALL 1,INTERRUPT
+ JRST DIRQ
+IFN ITS,[
+HPAR: MOVE A,MQUOTE PARITY,PARITY,INTRUP
+ JRST HMPV1
+
+HMPV: MOVE A,MQUOTE MPV,MPV,INTRUP
+ JRST HMPV1
+
+HILOPR: MOVE A,MQUOTE ILOPR,ILOPR,INTRUP
+ JRST HMPV1
+
+HPURE: MOVE A,MQUOTE PURE,PURE,INTRUP
+HMPV1: PUSH TP,$TATOM
+ PUSH TP,A
+ PUSH P,LCKINT ; SAVE LOCN
+ PUSH TP,$TATOM
+ PUSH TP,A
+ PUSH TP,$TWORD
+ PUSH TP,LCKINT
+ MCALL 2,EMERGENCY
+ POP P,A
+ MOVE C,(TP)
+ SUB TP,[2,,2]
+ JUMPN B,DIRQ
+
+ PUSH TP,$TATOM
+ PUSH TP,EQUOTE DANGEROUS-INTERRUPT-NOT-HANDLED
+ PUSH TP,$TATOM
+ PUSH TP,C
+ PUSH TP,$TWORD
+ PUSH TP,A
+ MCALL 3,ERROR
+ JRST DIRQ
+
+\f
+
+; HERE TO HANDLE SYS DOWN INTERRUPT
+
+HDOWN: PUSH TP,$TATOM
+ PUSH TP,MQUOTE SYSDOWN,SYSDOWN,INTRUP
+ .DIETI A, ; HOW LONG?
+ PUSH TP,$TFIX
+ PUSH TP,A
+ PUSH P,A ; FOR MESSAGE
+ MCALL 2,INTERRUPT
+ POP P,A
+ JUMPN B,DIRQ
+ .SUSET [.RTTY,,B] ; DO WE NOW HAVE A TTY AT ALL?
+ JUMPL B,DIRQ ; DONT HANG AROUND
+ PUSH P,A
+ MOVEI B,[ASCIZ /
+Excuse me, SYSTEM going down in /]
+ SKIPG (P) ; SKIP IF REALLY GOING DOWN
+ MOVEI B,[ASCIZ /
+Excuse me, SYSTEM has been REVIVED!
+/]
+ PUSHJ P,MSGTYP
+ POP P,B
+ JUMPE B,DIRQ
+ IDIVI B,30. ; TO SECONDS
+ IDIVI B,60. ; A/ SECONDS B/ MINUTES
+ JUMPE B,NOMIN
+ PUSH P,C
+ PUSHJ P,DECOUT
+ MOVEI B,[ASCIZ / minutes /]
+ PUSHJ P,MSGTYP
+ POP P,B
+ JRST .+2
+NOMIN: MOVEI B,(C)
+ PUSHJ P,DECOUT
+ MOVEI B,[ASCIZ / seconds.
+/]
+ PUSHJ P,MSGTYP
+ JRST DIRQ
+
+; TWO DIGIT DEC OUT FROM B/
+
+DECOUT: IDIVI B,10.
+ JUMPE B,DECOU1 ; NO TEN
+ MOVEI A,60(B)
+ PUSHJ P,MTYO
+DECOU1: MOVEI A,60(C)
+ JRST MTYO
+]
+\f
+; HERE TO HANDLE I/O CHANNEL ERRORS
+
+HIOC:
+IFN ITS,[
+ .SUSET [.RAPRC,,A] ; CONTAINS CHANNEL OF MOST RECENT LOSSAGE
+ LDB A,[330400,,A] ; GET CHAN #
+ MOVEI C,(A) ; COPY
+]
+ PUSH TP,$TATOM ; PUSH ERROR
+ PUSH TP,EQUOTE FILE-SYSTEM-ERROR
+IFE ITS, MOVE C,IOCLOS ; GET JFN
+ PUSH TP,$TCHAN
+ ASH C,1 ; GET CHANNEL
+ ADDI C,CHNL0+1 ; GET CHANNEL VECTOR
+ PUSH TP,(C)
+IFN ITS,[
+ LSH A,23. ; DO A .STATUS
+ IOR A,[.STATUS A]
+ XCT A
+]
+IFE ITS,[
+ MOVNI A,1 ; GET "MOST RECENT ERROR"
+]
+ MOVE B,(TP)
+IFN ITS, PUSHJ P,GFALS ; GEN NAMED FALSE
+IFE ITS, PUSHJ P,TGFALS
+ PUSH TP,A
+ PUSH TP,B
+ PUSH TP,$TATOM
+ PUSH TP,MQUOTE IOC,IOC,INTRUP
+
+ PUSH TP,A
+ PUSH TP,B
+ PUSH TP,-7(TP)
+ PUSH TP,-7(TP)
+ MCALL 3,EMERGENCY
+ JUMPN B,DIRQ1 ; JUMP IF HANDLED
+ MCALL 3,ERROR
+ JRST DIRQ
+
+DIRQ1: SUB TP,[6,,6]
+ JRST DIRQ
+]
+; HANDLE INFERIOR KNOCKING AT THE DOOR
+
+HINF:
+IFN ITS, SUBI B,36.+16.+2 ; CONVERT TO INF #
+IFE ITS, MOVEI B,0
+ PUSH TP,$TATOM
+ PUSH TP,MQUOTE INFERIOR,INFERIOR,INTRUP
+ PUSH TP,$TFIX
+ PUSH TP,B
+ MCALL 2,INTERRUPT
+ JRST DIRQ
+\f
+IFE ITS,[
+
+; HERE FOR TENEX INTS (FIRST CUT)
+
+MFUNCTION %ACCHRS,SUBR,[ACTIVATE-CHARS]
+
+ ENTRY
+
+ JUMPGE AB,RETCHR
+ CAMGE AB,[-3,,]
+ JRST TMA
+
+ GETYP A,(AB)
+ CAIE A,TCHSTR
+ JRST WTYP1
+ HRRZ D,(AB) ; CHECK LENGTH
+ MOVEI C,0 ; SEE IF ANY NET CHANS IN USE
+ MOVE A,[-NNETS,,NETJFN]
+ SKIPE (A)
+ SUBI C,1
+ AOBJN A,.-2
+
+ CAILE D,NCHRS+NNETS(C)
+ JRST WTYP1
+
+ MOVEI 0,(D) ; CHECK THEM
+ MOVE B,1(AB)
+
+ JUMPE 0,.+4
+ ILDB C,B
+ CAILE C,32
+ JRST WTYP1
+ SOJG 0,.-3
+
+ MOVSI E,-<NCHRS+NNETS> ; ZAP CURRENT
+ HRRZ A,CHRS(E)
+ DTI
+ SETZM CHRS(E)
+ AOBJN E,.-3
+
+ MOVE A,[-NNETS,,NETJFN] ; IN CASE USED NET INTS FOR CHARS
+
+ SKIPGE (A)
+ SETZM (A)
+ AOBJN A,.-2
+
+ MOVE E,1(AB)
+ SETZB C,F ; C WILL BE MASK, F OFFSET INTO TABLE
+ MOVSI 0,400000 ; 0 WILL BE THE BIT FOR INT MASK OR'ING
+ JUMPE D,ALP1 ; JUMP IF NONE
+ MOVNS D ; BUILD AOBJN POINTER TO CHRS TABLE
+ MOVSI D,(D)
+ MOVEI B,0 ; B COUNTS NUMBER DONE
+
+ALP: ILDB A,E ; GET CHR
+ IOR C,0
+ LSH 0,-1
+ HRROM A,CHRS(D)
+ MOVSS A
+ HRRI A,(D)
+ ADDI A,(F) ; POSSIBLE OFFSET FOR MORE CHANS
+ ATI
+ ADDI B,1
+ CAIGE B,NCHRS
+ JRST ALP2
+
+ SKIPE NETJFN-NCHRS(B)
+ AOJA B,.-1
+
+ MOVEI F,36.-NNETS-UINTS-NCHRS(B)
+ MOVN G,F
+ MOVSI 0,400000
+ LSH 0,(G) ;NEW MASK FOR INT MASKS
+ SUBI F,1(D)
+
+ALP2: AOBJN D,ALP
+
+ALP1: IORM C,MASK1
+ MOVEI A,MFORK
+ MOVE B,MASK1 ; SET UP FOR INT BITS
+ AIC ; TURN THEM ON
+ MOVE A,(AB)
+ MOVE B,1(AB)
+ JRST FINIS
+
+RETCHR: MOVE C,[-NCHRS-NNETS,,CHRS]
+ MOVEI A,0
+
+RETCH1: SKIPN D,(C)
+ JRST RETDON
+ PUSH TP,$TCHRS
+ ANDI D,177
+ PUSH TP,D
+ ADDI A,1
+ AOBJN C,RETCH1
+
+RETDON: PUSHJ P,CISTNG
+ JRST FINIS
+
+HCHAR: HRRZ A,CHRS-36.(B)
+ PUSH TP,$TATOM
+ PUSH TP,MQUOTE CHAR,CHAR,INTRUP
+ PUSH TP,$TCHRS
+ PUSH TP,A
+ PUSH TP,$TCHAN
+ PUSH TP,TTICHN+1
+ MCALL 3,INTERRUPT
+ JRST DIRQ
+
+HNET: SKIPLE A,NETJFN-NINT+NNETS+UINTS+1(B)
+ JRST HNET1
+ SUBI B,36.-NNETS-UINTS-NCHRS
+ JUMPE A,DIRQ
+ JRST HCHAR
+HNET1: ASH A,1
+ ADDI A,CHNL0+1
+ MOVE B,(A)
+ PUSH TP,$TATOM
+ PUSH TP,MQUOTE CHAR,CHAR,INTRUP
+ PUSH TP,$TUVEC
+ PUSH TP,BUFRIN(B)
+ PUSH TP,$TCHAN
+ PUSH TP,B
+ PUSHJ P,INSTAT
+ MCALL 3,INTERRUPT
+ JRST DIRQ
+
+USRINT: SUBI B,36.
+ PUSH TP,$TATOM
+ PUSH TP,MQUOTE USERINT,USERINT,INTRUP
+ PUSH TP,$TFIX
+ PUSH TP,B
+ MCALL 2,INTERRUPT
+ JRST DIRQ
+]
+
+\f
+MFUNCTION OFF,SUBR
+ ENTRY
+
+ JUMPGE AB,TFA
+ HLRZ 0,AB
+ GETYP A,(AB) ; ARG TYPE
+ MOVE B,1(AB) ; AND VALUE
+ CAIN A,TINTH ; HEADER, GO HACK
+ JRST OFFHD ; QUEEN OF HEARTS
+ CAIN A,TATOM
+ JRST .+3
+ CAIE A,TCHSTR
+ JRST TRYHAN ; MAYBE INDIVIDUAL HANDLER
+ CAIN 0,-2 ; MORE THAN 1 ARG?
+ JRST OFFAC1 ; NO, GO ON
+ CAIG 0,-5 ; CANT BE MORE THAN 2
+ JRST TMA
+ MOVEI B,2(AB) ; POINT TO 2D
+ PUSHJ P,CHNORL
+OFFAC1: MOVEI B,(AB)
+ PUSHJ P,FNDINT
+ JUMPGE B,NOHAN1 ; NOT HANDLED
+
+OFFH1: PUSH P,C ; SAVE C FOR BIT CLOBBER
+ MOVSI C,TATOM
+ SKIPN D
+ MOVE D,MQUOTE INTERRUPT
+ MOVE A,INAME(B)
+ MOVE B,INAME+1(B)
+ PUSHJ P,IREMAS
+ SKIPE B ; IF NO ASSOC, DONT SMASH
+ SETOM ISTATE+1(B) ; DISABLE IN CASE QUEUED
+ POP P,C ; SPECIAL?
+ JUMPGE C,FINIS ; NO, DONE
+
+ HRRZ C,INTBL(C) ; POINT TO SPECIAL CODE
+ PUSHJ P,(C) ; GO TO SAME
+ JUMPE E,OFINIS ; DONE
+IFN ITS,[
+ CAILE E,35. ; SKIP IF 1ST WORD
+ JRST CLRW2 ; CLOBBER 2D WORD BIT
+ LSH 0,-1(E) ; POSITION BIT
+ ANDCAM 0,MASK1 ; KILL BIT
+ .SUSET [.SMASK,,MASK1]
+]
+IFE ITS,[
+ MOVE D,B
+ SETZM (E)
+ MOVEI E,(E)
+ SUBI E,NETJFN-NETCHN
+ MOVEI 0,1
+ MOVNS E
+ LSH 0,35.(E)
+ ANDCAM 0,MASK1
+ MOVEI A,MFORK
+ SETCM B,MASK1
+ DIC
+ ANDCAM 0,PIRQ ; JUST IN CASE
+ MOVE B,D
+]
+OFINIS: MOVSI A,TINTH
+ JRST FINIS
+
+IFN ITS,[
+CLRW2: LSH 0,-36.(E) ; POS BIT FOR 2D WORD
+ ANDCAM 0,MASK2
+ .SUSET [.SMSK2,,MASK2]
+ JRST OFINIS
+]
+
+TRYHAN: CAIE A,THAND ; HANDLER?
+ JRST WTYP1
+ CAIE 0,-2
+ JRST TMA
+ GETYP 0,IPREV(B) ; GET TYPE OF PREV
+ MOVE A,INXT+1(B)
+ SKIPN C,IPREV+1(B) ; dont act silly if already off! (TT)
+ JRST HFINIS
+ MOVE D,IPREV(B)
+ CAIE 0,THAND
+ JRST DOHEAD ; PREV HUST BE HDR
+ MOVEM A,INXT+1(C)
+ JRST .+2
+DOHEAD: MOVEM A,IHNDLR+1(C) ; INTO HDR
+ JUMPE A,OFFINI
+ MOVEM D,IPREV(A)
+ MOVEM C,IPREV+1(A)
+OFFINI: SETZM IPREV+1(B) ; Leave NXT slot intact for RUNINT (BKD)
+ MOVSI A,THAND
+ JRST FINIS
+
+OFFHD: CAIE 0,-2
+ JRST TMA
+ PUSHJ P,GETNMS ; GET INFOR ABOUT INT
+ JUMPE C,OFFH1
+ PUSH TP,INAME(B)
+ PUSH TP,INAME+1(B)
+ JRST OFFH1
+
+GETNMS: GETYP A,INAME(B) ; CHECK FOR SPECIAL
+ SETZB C,D
+ CAIN A,TCHAN
+ HRROI C,SS.CHA
+ PUSHJ P,LOCQ ; LOCATIVE?
+ JRST CHGTNM
+
+ MOVEI B,INAME(B) ; POINT TO LOCATIVE
+ MOVSI D,(MOVE E,)
+ PUSHJ P,SMON ; GET MONITOR
+ MOVE B,1(AB)
+GETNM1: HRROI C,SS.WMO ; ASSUME WRITE
+ TLNN E,.WRMON
+ HRROI C,SS.RMO
+ MOVE D,MQUOTE WRITE,WRITE,INTRUP
+ TLNN E,.WRMON
+ MOVE D,MQUOTE READ,READ,INTRUP
+ POPJ P,
+
+CHGTNM: JUMPL C,CPOPJ
+ MOVE B,INAME+1(B)
+ PUSHJ P,SPEC1
+ MOVE B,1(AB) ; RESTORE IHEADER
+ POPJ P,
+\f
+; EMERGENCY, CANT DEFER ME!!
+
+MQUOTE INTERRUPT
+
+EMERGENCY:
+ PUSH P,.
+ JRST INTERR+1
+
+MFUNCTION INTERRUPT,SUBR
+
+ PUSH P,[0]
+
+ ENTRY
+
+ SETZM INTHLD ; RE-ENABLE THE WORLD
+ JUMPGE AB,TFA
+ MOVE B,1(AB) ; GET HANDLER/NAME
+ GETYP A,(AB) ; CAN BE HEADER OR NAME
+ CAIN A,TINTH ; SKIP IF NOT HEADER
+ JRST GTHEAD
+ CAIN A,TATOM
+ JRST .+3
+ CAIE A,TCHSTR ; SKIP IF CHAR STRING
+ JRST WTYP1
+ MOVEI B,(AB) ; LOOK UP NAME
+ PUSHJ P,FNDNM ; GET NAME
+ JUMPE B,IFALSE
+ MOVEI D,0
+ CAMN B,MQUOTE CHAR,CHAR,INTRUP
+ PUSHJ P,CHNGT1
+ CAME B,MQUOTE READ,READ,INTRUP
+ CAMN B,MQUOTE WRITE,WRITE,INTRUP
+ PUSHJ P,GTLOC1
+ PUSHJ P,INTASO
+ JUMPE B,IFALSE
+
+GTHEAD: SKIPE ISTATE+1(B) ; ENABLED?
+ JRST IFALSE ; IGNORE COMPLETELY
+ MOVE A,INTPRI+1(B) ; GET PRIORITY OF INTERRUPT
+ CAMLE A,CURPRI ; SEE IF MUST QUEU
+ JRST SETPRI ; MAY RUN NOW
+ SKIPE (P) ; SKIP IF DEFER OK
+ JRST DEFERR
+ MOVEM A,(P)
+ PUSH TP,$TINTH ; SAVE HEADER
+ PUSH TP,B
+ MOVEI A,1 ; SAVE OTHER ARGS
+PSHARG: ADD AB,[2,,2]
+ JUMPGE AB,QUEU1 ; GO MAKE QUEU ENTRY
+ PUSH TP,(AB)
+ PUSH TP,1(AB)
+ AOJA A,PSHARG
+QUEU1: PUSHJ P,IEVECT ; GET VECTOR
+ PUSH TP,$TVEC
+ PUSH TP,[0] ; WILL HOLD QUEUE HEADER
+ PUSH TP,A
+ PUSH TP,B
+
+ POP P,A ; RESTORE PRIORITY
+
+ MOVE B,QUEUES+1 ; GET INTERRUPT QUEUES
+ MOVEI D,0
+ JUMPGE B,GQUEU ; MAKE A QUEUE HDR
+
+NXTQU: CAMN A,1(B) ; GOT PRIORITY?
+ JRST ADDQU ; YES, ADD TO THE QUEU
+ CAML A,1(B) ; SKIP IF SPOT NOT FOUND
+ JRST GQUEU
+ MOVE D,B
+ MOVE B,3(B) ; GO TO NXT QUEUE
+ JUMPL B,NXTQU
+
+GQUEU: PUSH TP,$TVEC ; SAVE NEXT POINTER
+ PUSH TP,D
+ PUSH TP,$TFIX
+ PUSH TP,A ; SAVE PRIORITY
+ PUSH TP,$TVEC
+ PUSH TP,B
+ PUSH TP,$TLIST
+ PUSH TP,[0]
+ PUSH TP,$TLIST
+ PUSH TP,[0]
+ MOVEI A,4
+ PUSHJ P,IEVECT
+ MOVE D,(TP) ; NOW SPLICE
+ SUB TP,[2,,2]
+ JUMPN D,GQUEU1
+ MOVEM B,QUEUES+1
+ JRST .+2
+GQUEU1: MOVEM B,3(D)
+
+ADDQU: MOVEM B,-2(TP) ; SAVE QUEU HDR
+ POP TP,D
+ POP TP,C
+ PUSHJ P,INCONS ; CONS IT
+ MOVE C,(TP) ;GET QUEUE HEADER
+ SKIPE D,7(C) ; IF END EXISTS
+ HRRM B,(D) ; SPLICE
+ MOVEM B,7(C)
+ SKIPN 5(C) ; SKIP IF START EXISTS
+ MOVEM B,5(C)
+
+IFINI: MOVSI A,TATOM
+ MOVE B,IMQUOTE T
+ JRST FINIS
+
+SETPRI: EXCH A,CURPRI
+ MOVEM A,(P)
+
+ PUSH TP,$TAB ; PASS AB TO HANDLERS
+ PUSH TP,AB
+
+ PUSHJ P,RUNINT ; RUN THE HANDLERS
+ POP P,A ; UNQUEU ANY WAITERS
+ PUSHJ P,UNQUEU
+
+ JRST IFINI
+
+; HERE TO UNQUEUE WAITING INTERRUPTS
+
+UNQUEU: PUSH P,A ; SAVE NEW LEVEL
+
+UNQUE1: MOVE A,(P) ; TARGET LEVEL
+ CAMLE A,CURPRI ; CHECK RUG NOT PULLED OUT
+ JRST UNDONE
+ SKIPE B,QUEUES+1
+ CAML A,1(B) ; RIGHT LEVEL?
+ JRST UNDONE ; FINISHED
+
+ SKIPN C,5(B) ; ON QUEUEU?
+ JRST UNXQ
+ HRRZ D,(C) ; CDR THE LIST
+ MOVEM D,5(B)
+ SKIPN D ; SKIP IF NOT LAST
+ SETZM 7(B) ; CLOBBER END POINTER
+ MOVE A,1(B) ; GET THIS PRIORITY LEVEL
+ MOVEM A,CURPRI ; MAKE IT THE CURRENT ONE
+ MOVE D,1(C) ; GET SAVED VECTOR OF INF
+
+ MOVE B,1(D) ; INT HEADER
+ PUSH TP,$TVEC
+ PUSH TP,D ; AND ARGS
+
+ PUSHJ P,RUNINT ; RUN THEM
+ JRST UNQUE1
+
+UNDONE: POP P,CURPRI ; SET CURRENT LEVEL
+ MOVE A,CURPRI
+ POPJ P,
+
+UNXQ: MOVE B,3(B) ; GO TO NEXT QUEUE
+ MOVEM B,QUEUES+1
+ JRST UNQUE1
+
+
+
+; SUBR TO CHANGE INTERRUPT LEVEL
+
+MFUNCTION INTLEV,SUBR,[INT-LEVEL]
+ ENTRY
+ JUMPGE AB,RETLEV ; JUST RETURN CURRENT
+ GETYP A,(AB)
+ CAIE A,TFIX
+ JRST WTYP1 ; LEVEL IS FIXED
+ SKIPGE A,1(AB)
+ JRST OUTRNG"
+ CAMN A,CURPRI ; DIFFERENT?
+ JRST RETLEV ; NO RETURN
+ PUSH P,CURPRI
+ CAMG A,CURPRI ; SKIP IF NO UNQUEUE NEEDED
+ PUSHJ P,UNQUEU
+ MOVEM A,CURPRI ; SAVE
+ POP P,A
+ SKIPA B,A
+RETLEV: MOVE B,CURPRI
+ MOVSI A,TFIX
+ JRST FINIS
+
+RUNINT: PUSH TP,$THAND ; SAVE HANDLERS LIST
+ PUSH TP,IHNDLR+1(B)
+
+ SKIPN ISTATE+1(B) ; SKIP IF DISABLED
+ SKIPN B,(TP)
+ JRST SUBTP4
+NXHND: MOVEM B,(TP) ; SAVE CURRENT HDR
+ MOVE A,-2(TP) ; SAVE ARG POINTER
+ PUSHJ P,CHSWAP ; SEE IF MUST SWAP
+ PUSH TP,[0]
+ PUSH TP,[0]
+ MOVEI C,1 ; COUNT ARGS
+ PUSH TP,SPSTOR ; SAVE INITIAL BINDING POINTER
+ PUSH TP,SPSTOR+1
+ MOVE D,PVSTOR+1
+ ADD D,[1STEPR,,1STEPR]
+ PUSH TP,BNDV
+ PUSH TP,D
+ PUSH TP,$TPVP
+ PUSH TP,[0]
+ MOVE E,TP
+NBIND: PUSH TP,INTFCN(B)
+ PUSH TP,INTFCN+1(B)
+ ADD A,[2,,2]
+ JUMPGE A,DO.HND
+ PUSH TP,(A)
+ PUSH TP,1(A)
+ AOJA C,.-4
+DO.HND: MOVE PVP,PVSTOR+1
+ SKIPN 1STEPR+1(PVP) ; NECESSARY TO DO 1STEP BINDING ?
+ JRST NBIND1 ; NO, DON'T BOTHER
+ PUSH P,C
+ PUSHJ P,SPECBE ; BIND 1 STEP FLAG
+ POP P,C
+NBIND1: ACALL C,INTAPL ; RUN HAND WITH POSSIBLY BOUND 1STEP FLAG
+ MOVE SP,SPSTOR+1 ; GET CURRENT BINDING POINTER
+ CAMN SP,-4(TP) ; SAME AS SAVED BINDING POINTER ?
+ JRST NBIND2 ; YES, 1STEP FLAG NOT BOUND
+ MOVE C,(TP) ; RESET 1 STEP
+ MOVE PVP,PVSTOR+1
+ MOVEM C,1STEPR+1(PVP)
+ MOVE SP,-4(TP) ; RESTORE SAVED BINDING POINTER
+ MOVEM SP,SPSTOR+1
+NBIND2: SUB TP,[6,,6]
+ PUSHJ P,CHUNSW
+ CAMN E,PVSTOR+1
+ SUB TP,[4,,4] ; NO PROCESS CHANGE, POP JUNK
+ CAMN E,PVSTOR+1
+ JRST .+4
+ MOVE D,TPSTO+1(E)
+ SUB D,[4,,4]
+ MOVEM D,TPSTO+1(E) ; FIXUP HIS STACK
+DO.H1: GETYP A,A ; CHECK FOR A DISMISS
+ CAIN A,TDISMI
+ JRST SUBTP4
+ MOVE B,(TP) ; TRY FOR NEXT HANDLER
+ SKIPE B,INXT+1(B)
+ JRST NXHND
+SUBTP4: SUB TP,[4,,4]
+ POPJ P,
+
+MFUNCTION INTAPL,SUBR,[RUNINT]
+ JRST APPLY
+
+
+NOHAND: JUMPE C,NOHAN1
+ PUSH TP,$TATOM
+ PUSH TP,EQUOTE INTERNAL-INTERRUPT
+NOHAN1: PUSH TP,(AB)
+ PUSH TP,1(AB)
+ PUSH TP,$TATOM
+ PUSH TP,EQUOTE NOT-HANDLED
+ SKIPE A,C
+ MOVEI A,1
+ ADDI A,2
+ JRST CALER
+
+DEFERR: PUSH TP,$TATOM
+ PUSH TP,EQUOTE ATTEMPT-TO-DEFER-UNDEFERABLE-INTERRUPT
+ PUSH TP,$TINTH
+ PUSH TP,B
+ PUSH TP,$TATOM
+ PUSH TP,MQUOTE INTERRUPT
+ MCALL 3,RERR ; FORCE REAL ERROR
+ JRST FINIS
+
+; FUNCTION TO DISMISS AN INTERRUPT TO AN ARBITRARY ACTIVATION
+
+MFUNCTION DISMISS,SUBR
+
+ HLRZ 0,AB
+ JUMPGE AB,TFA
+ CAIGE 0,-6
+ JRST TMA
+ MOVNI D,1
+ CAIE 0,-6
+ JRST DISMI3
+ GETYP 0,4(AB)
+ CAIE 0,TFIX
+ JRST WTYP
+ SKIPGE D,5(AB)
+ JRST OUTRNG
+
+DISMI3: MOVEI A,(TB)
+
+DISMI0: HRRZ B,FSAV(A)
+ HRRZ C,PCSAV(A)
+ CAIE B,INTAPL
+ JRST DISMI1
+
+ MOVE E,OTBSAV(A)
+ MOVEI 0,(A) ; SAVE FRAME
+ MOVEI A,DISMI2
+ HRRM A,PCSAV(E) ; GET IT BACK HERE
+ MOVE A,(AB)
+ MOVE B,1(AB)
+ MOVE C,TPSAV(E)
+ MOVEM A,-7(C)
+ MOVEM B,-6(C)
+ MOVEI C,0
+ CAMGE AB,[-3,,]
+ MOVEI C,2(AB)
+ MOVE B,0 ; DEST FRAME
+ JUMPL D,.+3
+ MOVE A,PSAV(E) ; NOW MUNG SAVED INT LEVEL
+ MOVEM D,-1(A) ; ZAP YOUR MUNGED
+ PUSHJ P,CHUNW ; CHECK ON UNWINDERS
+ JRST FINIS ; FALL DOWN
+
+DISMI1: MOVEI E,(A)
+ HRRZ A,OTBSAV(A)
+ JUMPN A,DISMI0
+
+ MOVE A,(AB)
+ MOVE B,1(AB)
+
+ PUSH TP,A
+ PUSH TP,B
+ SKIPGE A,D
+ JRST .+4
+ CAMG A,CURPRI
+ PUSHJ P,UNQUEU
+ MOVEM A,CURPRI
+ CAML AB,[-3,,]
+ JRST .+5
+ PUSH TP,2(AB)
+ PUSH TP,3(AB)
+ MCALL 2,ERRET
+ JRST FINIS
+
+ POP TP,B
+ POP TP,A
+ JRST FINIS
+
+DISMI2: CAMN SP,-4(TP) ; 1STEP FLAG BEEN BOUND ?
+ JRST NDISMI ; NO
+ MOVE C,(TP)
+ MOVE PVP,PVSTOR+1
+ MOVEM C,1STEPR+1(PVP)
+ MOVE SP,-4(TP)
+NDISMI: SUB TP,[6,,6]
+ PUSHJ P,CHUNSW ; UNDO ANY PROCESS HACKING
+ MOVE C,TP
+ CAME E,PVSTOR+1 ; SWAPED?
+ MOVE C,TPSTO+1(E)
+ MOVE D,-1(C)
+ MOVE 0,(C)
+ SUB TP,[4,,4]
+ SUB C,[4,,4] ; MAYBE FIXUP OTHER STACK
+ CAME E,PVSTOR+1
+ MOVEM C,TPSTO+1(E)
+ PUSH TP,D
+ PUSH TP,0
+ PUSH TP,A
+ PUSH TP,B
+ MOVE A,-1(P) ; SAVED PRIORITY
+ CAMG A,CURPRI
+ PUSHJ P,UNQUEU
+ MOVEM A,CURPRI
+ SKIPN -1(TP)
+ JRST .+3
+ MCALL 2,ERRET
+ JRST FINIS
+
+ SUB TP,[4,,4]
+ MOVSI A,TDISMI
+ MOVE B,IMQUOTE T
+ JRST DO.H1
+
+CHNGT1: HLRE B,AB
+ SUBM AB,B
+ GETYP 0,-2(B)
+ CAIE 0,TCHAN
+ JRST WTYP3
+ MOVE B,-1(B)
+ MOVSI A,TCHAN
+ POPJ P,
+
+GTLOC1: GETYP A,2(AB)
+ PUSHJ P,LOCQ
+ JRST WTYP2
+ MOVE D,B ; RET ATOM FOR ASSOC
+ MOVE A,2(AB)
+ MOVE B,3(AB)
+ POPJ P,
+\f; MONITOR CHECKERS
+
+MONCH0: HLLZ 0,(B) ; POTENTIAL MONITORS
+MONCH: TLZ 0,TYPMSK ; KILL TYPE
+ IOR C,0 ; IN NEW TYPE
+ PUSH P,0
+ MOVEI 0,(B)
+ CAIL 0,HIBOT
+ JRST PURERR
+ POP P,0
+ TLNN 0,.WRMON ; SKIP IF WRITE MONIT
+ POPJ P,
+
+; MONITOR IS ON, INVOKE HANDLER
+
+ PUSH TP,A ; SAVE OBJ
+ PUSH TP,B
+ PUSH TP,C
+ PUSH TP,D ; SAVE DATUM
+ MOVSI C,TATOM ; PREPARE TO FIND IT
+ MOVE D,MQUOTE WRITE,WRITE,INTRUP
+ PUSHJ P,IGET
+ JUMPE B,MONCH1 ; NOT FOUND IGNORE FOR NOW
+ PUSH TP,A ; START SETTING UP CALL
+ PUSH TP,B
+ PUSH TP,-5(TP)
+ PUSH TP,-5(TP)
+ PUSH TP,-5(TP)
+ PUSH TP,-5(TP)
+ PUSHJ P,FRMSTK ; PUT FRAME ON STAKC
+ MCALL 4,EMERGE ; DO IT
+MONCH1: POP TP,D
+ POP TP,C
+ POP TP,B
+ POP TP,A
+ HLLZ 0,(B) ; UPDATE MONITORS
+ TLZ 0,TYPMSK
+ IOR C,0
+ POPJ P,
+
+; NOW FOR READ MONITORS
+
+RMONC0: HLLZ 0,(B)
+RMONCH: TLNN 0,.RDMON
+ POPJ P,
+ PUSH TP,A
+ PUSH TP,B
+ MOVSI C,TATOM
+ MOVE D,MQUOTE READ,READ,INTRUP
+ PUSHJ P,IGET
+ JUMPE B,RMONC1
+ PUSH TP,A
+ PUSH TP,B
+ PUSH TP,-3(TP)
+ PUSH TP,-3(TP)
+ PUSHJ P,FRMSTK ; PUT FRAME ON STACK
+ MCALL 3,EMERGE
+RMONC1: POP TP,B
+ POP TP,A
+ POPJ P,
+
+; PUT THE CURRENT FRAME ON THE STACK
+
+FRMSTK: PUSHJ P,MAKACT
+ HRLI A,TFRAME
+ PUSH TP,A
+ PUSH TP,B
+ POPJ P,
+
+; HERE TO COMPLAIN ABOUT ATTEMPTS TO MUNG PURE CODE
+
+PURERR: PUSH TP,$TATOM
+ PUSH TP,EQUOTE ATTEMPT-TO-MUNG-PURE-STRUCTURE
+ PUSH TP,A
+ PUSH TP,B
+ MOVEI A,2
+ JRST CALER
+\f
+; PROCESS SWAPPING CODE
+
+CHSWAP: MOVE E,PVSTOR+1 ; GET CURRENT
+ POP P,0
+ SKIPE D,INTPRO+1(B) ; SKIP IF NO PROCESS GIVEN
+ CAMN D,PVSTOR+1 ; SKIP IF DIFFERENT
+ JRST PSHPRO
+
+ PUSHJ P,SWAPIT ; DO SWAP
+
+PSHPRO: PUSH TP,$TPVP
+ PUSH TP,E
+ JRST @0
+
+CHUNSW: MOVE E,PVSTOR+1 ; RET OLD PROC
+ MOVE D,-2(TP) ; GET SAVED PROC
+ CAMN D,PVSTOR+1 ; SWAPPED?
+ POPJ P,
+
+SWAPIT: PUSH P,0
+ MOVE 0,PSTAT+1(D) ; CHECK STATE
+ CAIE 0,RESMBL
+ JRST NOTRES
+ MOVE PVP,PVSTOR+1
+ MOVEM 0,PSTAT+1(PVP)
+ MOVEI 0,RUNING
+ MOVEM 0,PSTAT+1(D) ; SAVE NEW STATE
+ POP P,0
+ POP P,C
+ JRST SWAP"
+\f
+
+;SUBROUTINE TO GET BIT FOR CLOBBERAGE
+
+GETBIT: MOVNS B ;NEGATE
+ MOVSI A,400000 ;GET THE BIT
+ LSH A,(B) ;SHIFT TO POSITION
+ POPJ P, ;AND RETURN
+
+; HERE TO HANDLE PURE WRITE AND CHECK FOR POSSIBLE C/W
+
+IFN ITS,[
+GCPWRT: SKIPN GCDFLG ; SEE IF IN DUMPER OR PURIFYER
+ SKIPE NPWRIT
+ JRST .+3
+ MOVEI B,4 ; INDICATE PURE WRITE
+ JRST NOPUGC ; CONTINUE
+ TLZ A,200
+ MOVEM A,TSINT ; SVE A
+ MOVE A,TSAVA
+ SOS TSINTR
+ .SUSET [.RMPVA,,A]
+ CAML A,RPURBT ; SKIP IF NOT PURE
+ CAIL A,HIBOT ; DONT MARK IF TOUCHING INTERPRETER
+ SKIPA
+ SETOM PURMNG ; MUNGING PURENESS INDICATE
+ MOVE B,BUFGC ; GET BUFFER
+ JUMPL B,GCPW1 ; JUMP IF WINDOW IS BUFFER
+ EXCH P,GCPDL
+ PUSHJ P,%CWINF ; GO DO COPY/WRITE
+GCPW2: EXCH P,GCPDL
+ MOVE A,TSINT ; RESTORE A
+ JRST 2NDWORD ; CONTINUE
+GCPW1: EXCH P,GCPDL
+ MOVEI B,WIND ; START OF BUFFER
+ PUSHJ P,%CWINF ; C/W
+ MOVEI B,WNDP ; RESTORE WINDOW
+ MOVE A,WNDBOT ; BOTTOM OF WINDOW
+ ASH A,-10. ; TO PAGES
+ SKIPE A
+ PUSHJ P,%SHWND ; SHARE IT
+ JRST GCPW2
+]
+IFE ITS,[
+
+; HERE TO HANDLE BUFFERING FOR GC-DUMP AND PURIFY FOR TENEX
+
+PWRIT: SKIPN GCDFLG ; SEE IF IN DUMPER OR PURIFYER
+ SKIPE GPURFL
+ SKIPA
+ FATAL IMW
+ EXCH P,GCPDL ; GET A GOOD PDL
+ MOVEM A,TSAVA ; SAVE AC'S
+ MOVEM B,TSAVB
+ MOVEI A,MFORK ; FOR TWENEX THIS IS A MOVEI
+ SKIPE OPSYS ; SKIP IF TOPS20
+ MOVSI A,MFORK ; FOR A TENEX IT SHOULD BE A MOVSI
+ GTRPW ; GET TRAP WORDS
+ PUSH P,A ; SAVE ADDRESS AND WORD
+ PUSH P,B
+ ANDI A,-1
+ CAML A,RPURBT ; SKIP IF NOT PURE
+ CAIL A,HIBOT ; DONT MARK IF TOUCHING INTERPRETER
+ SKIPA
+ SETOM PURMNG ; MUNGING PURENESS INDICATE
+ MOVE B,BUFGC ; GET BUFFER
+ ANDCMI A,1777 ; TO PAGE BOUNDRY
+ JUMPL B,PWRIT2 ; USE WINDOW AS BUFFER
+PWRIT3: PUSHJ P,%CWINF ; FIX UP
+PWRIT4: POP P,B ; RESTORE AC'S
+ POP P,A
+ TLNN A,10 ; SEE IF R/W CYCLE
+ MOVEM B,(A) ; FINISH WRITE
+ EXCH P,GCPDL
+ JRST INTDON
+PWRIT2: MOVEI B,WIND
+ PUSHJ P,%CWINF ; GO TRY TO WIN
+ MOVEI B,WNDP
+ MOVE A,WNDBOT ; BOTTOM OF WINDOW
+ ASH A,-10. ; TO PAGES
+ SKIPE A
+ PUSHJ P,%SHWND ; SHARE IT
+ JRST PWRIT4
+]
+
+;HERE TO HANDLE PDL OVERFLOW. ASK FOR A GC
+
+IPDLOV:
+IFN ITS,[
+ MOVEM A,TSINT ;SAVE INT WORD
+]
+
+ SKIPE GCFLG ;IS GC RUNNING?
+ JRST GCPLOV ;YES, COMPLAIN GROSSLY
+
+ MOVEI A,200000 ;GET BIT TO CLOBBER
+ IORM A,PIRQ ;LEAVE A MESSAGE FOR HIGHER LEVEL
+
+ EXCH P,GCPDL ;GET A WINNING PDL
+ HRRZ B,TSINTR ;GET POINTER TO LOSING INSTRUCTION
+IFE ITS,[
+ SKIPE MULTSG
+ MOVE B,TSINTR+1
+]
+ SKIPG GCPDL ; SKIP IF NOT P
+ LDB B,[270400,,-1(B)] ;GET AC FIELD
+ SKIPL GCPDL ; SKIP IF P
+ MOVEI B,P
+ MOVEI A,(B) ;COPY IT
+ LSH A,1 ;TIMES 2
+ EXCH PVP,PVSTOR+1
+ ADDI A,0STO(PVP) ;POINT TO THIS ACS CURRENT TYPE
+ EXCH PVP,PVSTOR+1
+ HLRZ A,(A) ;GET THAT TYPE INTO A
+ CAIN B,P ;IS IT P
+ MOVEI B,GCPDL ;POINT TO SAVED P
+
+ CAIN B,B ;OR IS IT B ITSELF
+ MOVEI B,TSAVB
+ CAIN B,A ;OR A
+ MOVEI B,TSAVA
+
+ CAIN B,C ;OR C
+ MOVEI B,1(P) ;C WILL BE ON THE STACK
+
+ PUSH P,C
+ PUSH P,A
+
+ MOVE A,(B) ;GET THE LOSING POINTER
+ MOVEI C,(A) ;AND ISOLATE RH
+
+ CAMG C,VECTOP ;CHECK IF IN GC SPACE
+ CAMG C,VECBOT
+ JRST NOGROW ;NO, COMPLAIN
+
+; FALL THROUGH
+\f
+
+ HLRZ C,A ;GET -LENGTH
+ SUBI A,-1(C) ;POINT TO A DOPE WORD
+ POP P,C ;RESTORE TYPE INTO C
+ PUSH P,D ; SAVE FOR GROWTH HACKER
+ MOVEI D,0
+ CAIN C,TPDL ; POINT TD TO APPROPRIATE DOPE WORD
+ MOVEI D,PGROW
+ CAIN C,TTP
+ MOVEI D,TPGROW
+ JUMPE D,BADPDL ; IF D STILL 0, THIS PDL IS WEIRD
+ MOVEI A,PDLBUF(A) ; POINT TO ALLEGED REAL DOPE WORD
+ SKIPN (D) ; SKIP IF PREVIOUSLY BLOWN
+ MOVEM A,(D) ; CLOBBER IN
+ CAME A,(D) ; MAKE SURE IT IS THE SAME
+ JRST PDLOSS
+ POP P,D ; RESTORE D
+
+
+PNTRHK: MOVE C,(B) ;RESTORE PDL POINTER
+ SUB C,[PDLBUF,,0] ;FUDGE THE POINTER
+ MOVEM C,(B) ;AND STORE IT
+
+ POP P,C ;RESTORE THE WORLD
+ EXCH P,GCPDL ;GET BACK ORIG PDL
+IFN ITS,[
+ MOVE A,TSINT ;RESTORE INT WORD
+
+ JRST IMPCH ;LOOK FOR MORE INTERRUPTS
+]
+IFE ITS, JRST GCQUIT
+
+TPOVFL: SETOM INTFLG ;SIMULATE PDL OVFL
+ PUSH P,A
+ MOVEI A,200000 ;TURN ON THE BIT
+ IORM A,PIRQ
+ HLRE A,TP ;FIND DOPEW
+ SUBM TP,A ;POINT TO DOPE WORD
+ MOVEI A,PDLBUF+1(A) ; ZERO LH AND POINT TO DOPEWD
+ SKIPN TPGROW
+ HRRZM A,TPGROW
+ CAME A,TPGROW ; MAKE SURE WINNAGE
+ JRST PDLOS1
+ SUB TP,[PDLBUF,,0] ; HACK STACK POINTER
+ POP P,A
+ POPJ P,
+
+
+; GROW CORE IF PDL OVERFLOW DURING GC
+
+GCPLOV: EXCH P,GCPDL ; NEED A PDL TO CALL P.CORE
+ PUSHJ P,GPDLOV ; HANDLE PDL OVERFLOW
+ EXCH P,GCPDL
+ PUSHJ P,%FDBUF
+IFE ITS,[
+ JRST GCQUIT
+]
+IFN ITS,[
+ MOVE A,TSINT
+ JRST IMPCH
+
+]
+\f
+IFN ITS,[
+
+;HERE TO HANDLE LOW-LEVEL CHANNELS
+
+
+CHNACT: SKIPN GCFLG ;GET A WINNING PDL
+ EXCH P,GCPDL
+ ANDI A,177777 ;ISOLATE CHANNEL BITS
+ PUSH P,0 ;SAVE
+
+CHNA1: MOVEI B,0 ;BIT COUNTER
+ JFFO A,.+2 ;COUNT
+ JRST CHNA2
+ SUBI B,35. ;NOW HAVE CHANNEL
+ MOVMS B ;PLUS IT
+ MOVEI 0,1
+ LSH 0,(B)
+ ANDCM A,0
+ MOVEI 0,(B) ; COPY TO 0
+ LSH 0,23. ;POSITION FOR A .STATUS
+ IOR 0,[.STATUS 0]
+ XCT 0 ;DO IT
+ ANDI 0,77 ;ISOLATE DEVICE
+ CAILE 0,2
+ JRST CHNA1
+
+PMIN4: MOVE 0,B ; CHAN TO 0
+ .ITYIC 0, ; INTO 0
+ JRST .+2 ; DONE, GO ON
+ JRST PMIN4
+ SETZM GCFLCH ; LEAVE GC MODE
+ JRST CHNA1
+
+CHNA2: POP P,0
+ SKIPN GCFLG
+ EXCH P,GCPDL
+ JRST GCQUIT
+
+HOWMNY: SETZ
+ SIXBIT /LISTEN/
+ D
+ 402000,,B
+]
+
+MFUNCTION GASCII,SUBR,ASCII
+ ENTRY 1
+
+ GETYP A,(AB)
+ CAIE A,TCHRS
+ JRST TRYNUM
+
+ MOVE B,1(AB)
+ MOVSI A,TFIX
+ JRST FINIS
+
+TRYNUM: CAIE A,TFIX
+ JRST WTYP1
+ SKIPGE B,1(AB) ;GET NUMBER
+ JRST TOOBIG
+ CAILE B,177 ;CHECK RANGE
+ JRST TOOBIG
+ MOVSI A,TCHRS
+ JRST FINIS
+
+TOOBIG: ERRUUO EQUOTE ARGUMENT-OUT-OF-RANGE
+
+\f
+;HERE IF PDL OVERFLOW DURING GARBAGE COLLECTION
+
+BADPDL: FATAL NON PDL OVERFLOW
+
+NOGROW: FATAL PDL OVERFLOW ON NON EXPANDABLE PDL
+
+PDLOS1: MOVEI D,TPGROW
+PDLOSS: MOVSI A,(GENERAL) ; FIX UP TP DOPE WORD JUST IN CASE
+ HRRZ D,(D) ; POINT TO POSSIBLE LOSING D.W.
+ SKIPN TPGROW
+ JRST PDLOS2
+ MOVEM A,-1(D)
+ MOVEI A,(TP) ; SEE IF REL STACK SIZE WINS
+ SUBI A,(TB)
+ TRNN A,1
+ SUB TP,[1,,1]
+PDLOS2: MOVSI A,.VECT.
+ SKIPE PGROW
+ MOVEM A,-1(D)
+ SUB P,[2,,2] ; TRY TO RECOVER GRACEFULLY
+ EXCH P,GCPDL
+ MOVEI A,DOAGC ; SET UP TO IMMEDIATE GC
+IFN ITS,[
+ HRRM A,TSINTR
+]
+IFE ITS,[
+ SKIPE MULTSG
+ HRRM A,TSINTR+1
+ SKIPN MULTSG
+ HRRM A,TSINTR
+]
+IFN ITS, .DISMIS TSINTR
+IFE ITS, DEBRK
+
+DOAGC: SKIPE PGROW
+ SUB P,[2,,2] ; ALLOW ROOM FOR CALL
+ JSP E,PDL3 ; CLEANUP
+ ERRUUO EQUOTE PDL-OVERFLOW-BUFFER-EXHAUSTED
+
+
+DLOSER: PUSH P,LOSRS(B)
+ MOVE A,TSAVA
+ MOVE B,TSAVB
+ POPJ P,
+
+LOSRS: IMPV
+ ILOPR
+ IOC
+ IPURE
+
+
+;MEMORY PROTECTION INTERRUPT
+
+IOC: FATAL IO CHANNEL ERROR IN GARBAGE COLLECTOR
+IMPV: FATAL MPV IN GARBAGE COLLECTOR
+
+IPURE: FATAL PURE WRITE IN GARBAGE COLLECTOR
+ILOPR: FATAL ILLEGAL OPEREATION IN GARBAGE COLLECTOR
+
+IFN ITS,[
+
+;SUBROUTINE TO BE CALLED AT INITIALIZE TIME TO SETUP INTS
+
+INTINT: SETZM CHNCNT
+ MOVE A,[CHNCNT,,CHNCNT+1]
+ BLT A,CHNCNT+16.
+ SETZM INTFLG
+ .SUSET [.SPICLR,,[-1]]
+ MOVE A,MASK1 ;SET MASKS
+ MOVE B,MASK2
+ .SETM2 A, ;SET BOTH MASKS
+ MOVSI A,TVEC
+ MOVEM A,QUEUES
+ SETZM QUEUES+1 ;UNQUEUE ANY OLD INTERRUPTS
+ SETZM CURPRI
+ POPJ P,
+]
+IFE ITS,[
+
+; INITIALIZE TENEX INTERRUPT SYSTEM
+
+INTINT: CIS ; CLEAR THE INT WORLD
+ SETZM INTFLG ; IN CASE RESTART
+ MOVSI A,TVEC ; FIXUP QUEUES
+ MOVEM A,QUEUES
+ SETZM QUEUES+1
+ SETZM CURPRI ; AND PRIORITY LEVEL
+ MOVEI A,MFORK ; TURN ON MY INTERRUPTS
+ SKIPN MULTSG
+ JRST INTINM
+ PUSHJ P,@[DOSIR] ; HACK TO TEMP GET TO SEGMENT 0
+ JRST INTINX
+
+INTINM: MOVE B,[-36.,,CHNTAB]
+ MOVSI 0,1
+ HLLM 0,(B)
+ AOBJN B,.-1
+
+ MOVE B,[LEVTAB,,CHNTAB] ; POINT TO TABLES
+ SIR ; TELL SYSTEM ABOUT THEM
+
+INTINX: MOVSI D,-NCHRS
+ MOVEI 0,40
+ MOVEI C,0
+
+INTILP: SKIPN A,CHRS(D)
+ JRST ITTIL1
+ IOR C,0
+ MOVSS A
+ HRRI A,(D)
+ ATI
+ITTIL1: LSH 0,-1
+ AOBJN D,INTILP
+
+ DPB C,[360600,,MASK1]
+ MOVE B,MASK1 ; SET UP FOR INT BITS
+ MOVEI A,MFORK
+ AIC ; TURN THEM ON
+ MOVEI A,MFORK ; DO THE ENABLE
+ EIR
+ POPJ P,
+
+
+DOSIR: MOVE B,[-36.,,CHNTAB]
+ MOVSI 0,<1_12.>+FSEG
+ HLLM 0,(B)
+ AOBJN B,.-1
+
+ MOVEI B,..ARGB ; WILL RUN IN SEGMENT 0
+RMT [
+..ARGB: 3
+ LEVTAB
+ CHNTAB
+]
+ XSIR
+ POP P,D
+ HRLI D,FSEG
+ XJRST C ; GET BACK TO CALLING SEGMENT
+]
+\f
+
+; CNTL-G HANDLER
+
+MFUNCTION QUITTER,SUBR
+
+ ENTRY 2
+ GETYP A,(AB)
+ CAIE A,TCHRS
+ JRST WTYP1
+ GETYP A,2(AB)
+ CAIE A,TCHAN
+ JRST WTYP2
+ MOVE B,1(AB)
+ MOVE A,(AB)
+IFE ITS, CAIE ^O
+ CAIN B,^S ; HANDLE CNTL-S
+ JRST RETLIS
+ CAIE B,7
+ JRST FINIS
+
+ PUSHJ P,CLEAN ; CLEAN UP I/O CHANNELS
+ PUSH TP,$TATOM
+ PUSH TP,EQUOTE CONTROL-G?
+ MCALL 1,ERROR
+ JRST FINIS
+
+RETLIS: MOVE B,IMQUOTE LER,[LERR ]INTRUP
+ PUSHJ P,ILVAL ; GET CURRENT VALUE
+ PUSH TP,A
+ PUSH TP,B
+ MOVEI B,-1(TP)
+ PUSHJ P,CHFSWP
+ SUB TP,[2,,2]
+ MOVEI D,(TB) ; FIND A LISTEN OR ERROR TO RET TO
+
+RETLI1: HRRZ A,OTBSAV(D)
+ CAIN A,(B) ; CHECK FOR WINNER
+ JRST FNDHIM
+ HRRZ C,FSAV(A) ; CHECK FUNCTION
+ CAIE C,LISTEN
+ CAIN C,ERROR ; FOUND?
+ JRST FNDHIM ; YES, GO TO SAME
+ CAIN C,ERROR% ; FUNNY ERROR
+ JRST FNDHIM
+ CAIN C,TOPLEV ; NO ERROR/LISTEN
+ JRST FINIS
+ MOVEI D,(A)
+ JRST RETLI1
+
+FNDHIM: PUSH TP,$TTB
+ PUSH TP,D
+ PUSHJ P,CLEAN
+ MOVE B,(TP) ; NEW FRAME
+ SUB TP,[2,,2]
+ MOVEI C,0
+ PUSHJ P,CHUNW ; UNWIND?
+ MOVSI A,TATOM
+ MOVE B,IMQUOTE T
+ JRST FINIS
+
+CLEAN: MOVE B,3(AB) ; GET IN CHAN
+ PUSHJ P,RRESET
+ MOVE B,3(AB) ; CHANNEL BAKC
+ MOVE C,BUFRIN(B)
+ SKIPN C,ECHO(C) ; GET ECHO
+ JRST CLUNQ
+IFN ITS,[
+ MOVEI A,2
+ CAMN C,[PUSHJ P,MTYO]
+ JRST TYONUM
+ LDB A,[270400,,C]
+TYONUM: LSH A,23.
+ IOR A,[.RESET]
+ XCT A
+]
+IFE ITS,[
+ MOVEI A,101 ; OUTPUT JFN
+ CFOBF
+]
+
+CLUNQ: SETZB A,CURPRI
+ JRST UNQUEU
+
+\f
+IMPURE
+ONINT: 0 ; INT FUDGER
+INTBCK: 0 ; GO BACK TO THIS PC AFTER INTERRUPT
+ MOVEM TP,TPSAV(TB) ; SAVE STUFF
+ MOVEM P,PSAV(TB)
+INTBEN: SKIPL INTFLG ; PENDING INTS?
+ JRST @INTBCK
+ PUSH P,A
+ SOS A,INTBCK
+ SETZM INTBCK
+ MOVEM A,LCKINT
+ POP P,A
+ JRST LCKINT+1
+
+
+IFN ITS,[
+;RANDOM IMPURE CRUFT NEEDED
+CHNCNT: BLOCK 16. ; # OF CHARS IN EACH CHANNEL
+
+TSAVA: 0
+TSAVB: 0
+PIRQ: 0 ;HOLDS REQUEST BITS FOR 1ST WORD
+PIRQ2: 0 ;SAME FOR WORD 2
+PCOFF: 0
+MASK1: 200,,200100 ;FIRST MASK
+MASK2: 0 ;SECOND THEREOF
+CURPRI: 0 ; CURRENT PRIORITY
+RLTSAV: 0
+]
+IFE ITS,[
+CHRS: 7 ; CNTL-G
+ 23 ; CNTL-O
+ 17 ; CNTL-S
+ BLOCK NCHRS-3
+
+NETJFN: BLOCK NNETS
+MASK1: CHNMSK
+RLTSAV: 0
+TSINTR:
+P1: 0
+ 0 ; PC INT LEVEL 1 (1ST WORD IN 1 SEG MODE, 2D
+ ; IN MULTI SEG MODE)
+P2: 0
+ 0 ; PC INT LEVEL 2
+P3: 0
+ 0 ; PC INT LEVEL 3
+CURPRI: 0
+TSAVA: 0
+TSAVB: 0
+PIRQ: 0
+PIRQ2: 0
+IOCLOS: 0 ; HOLDS LOSING JFN IN TNX IOC
+]
+PURE
+
+END
+\f
\ No newline at end of file
--- /dev/null
+TITLE IPC -- IPC COMMUNICATIONS HANDLER FOR MUDDLE
+
+RELOCATABLE
+
+; N. RYAN October 1973
+
+.INSRT MUDDLE >
+
+;THIS PROGRAM HAS ENTRIES SEND, SEND-WAIT, IPC-OFF,
+; AND IPC-HANDLER.
+
+;THESE HANDLE THE IPC DEVICE.
+
+;SEND AND SEND-WAIT SEND OUT A MESSAGE ON THE IPC DEVICE.
+;THEY TAKE 6 ARGUMENTS, THE FIRST THREE OF WHICH ARE NECESSARY
+
+; SEND (<HISNAME1> <HISNAME2> <MESSAGE> <MESSAGE-TYPE> <MYNAME1> <MYNAME2>)
+
+; <HISNAME1> -- STRING USED AS SIXBIT FOR NAME 1
+; <HISNAME2> -- STRING USED AS SIXBIT FOR NAME 2
+; <MESSAGE> -- THE MESSAGE TO SEND, EITHER A STRING OR A UVECTOR OF TYPE WORD
+; <TYPE> -- THE TYPECODE TO SEND, A FIXED NUMBER, DEFAULT 0
+; <MYNAME1> -- STRING USED AS SIXBIT FOR MY NAME 1
+; <MYNAME2> -- STRING USED AS SIXBIT FOR MY NAME 2
+
+; SEND -- TRIES TO SEND IMMEDIATELY, ELSE RETURNS FALSE WITH MESSAGE
+; SEND-WAIT -- HANGS UNTIL MESSAGE CAN BE SENT
+
+; IPC-OFF -- NO ARGUMENTS, CLOSES ALL IPC-RECEIVE CHANNELS
+
+; IPC-ON -- OPENS AN IPC RECEIVE CHANNEL
+; IT TAKES 2 OPTIONAL ARGS WHICH ARE THE NAMES TO LISTEN ON,
+; THE DEFAULT IS UNAME, JNAME
+
+
+
+\f; DEFINITIONS FOR STRUCTURE OF IPC BUFFER
+
+BUFL==200. ;LENGTH OF IPC BUFFER
+BUFHED==3 ;LENGTH OF BUFFER HEADER
+CONT==400000 ;LEFT HALF BIT INDICATING THIS IS CONTINUATION
+INCOMP==200000 ;LEFT HALF BIT INDICATING MESSAGE COMPLETE
+ASCIMS==100000 ;LEFT HALF BIT INDICATING THIS IS PACKED ASCII MESSAGE
+MESHED==2 ;LENGTH OF CRUFT AT FRONT OF FIRST MESSAGE
+MAXMES==20000. ;MAXIMUM LENGTH IN WORDS OF MESSAGES MUDDLE WILL LIKE
+
+
+.GLOBAL STRTO6,SAT,IBLOCK,MOPEN,MCLOSE,GFALS,TTOCHN,INCONS,MASK2,INTHLD
+.GLOBAL IPCS1,IBLOCK,IPCGOT,DIRQ,GIBLOK,6TOCHS,CAFRE,CAFRET,IPCBLS,PVSTOR,SPSTOR
+
+; DEFINITIONS OF BITS IN THE OPEN BLOCK FOR IPC DEVICE
+
+RFROMA==1 ;READ FROM ANY
+RFROMS==2 ;READ FROM SPECIFIC
+SANDH==4 ;SEND AND HANG
+SIMM==10 ;SEND IMMEDIATE
+USEUJ==20 ;USE MY UNAME, JNAME
+
+
+;BUFFERFORMAT: HISNAME1
+; HISNAME2
+; COUNT
+; BITS,,LENGTH
+; TYPE
+
+;WHERE ASCII MESSAGES CONSIST OF A COUNT FOLLOWED BY CHARS
+;THE LENGTH IS THE LENGTH OF THE TYPE WORD PLUS ALL THE BODIES
+
+\f
+
+; THE FOLLOWING IS THE HANDLER WHICH WILL NORMALLY BE PUT ON THE
+; IPC INTERRUPT AND SO SERVE AS THE DEFAULT HANDLER FOR IPC RECEIVES
+; WHICH ARE NOT CAUGHT BY THE USER AND SERVICED IN SOME OTHER MANNER
+
+; NOTE THAT AS AN EXPERIMENT, MESSAGE WHICH ARE ASCII STRINGS WITH TYPE-CODE 1
+; ARE CONSIDERED AS EXECUTE COMMANDS. THEY ARE FIRST PRINTED OUT,
+; THEN THEY ARE PARSED AND THAT RESULT IS EVALED.
+; ALL MESSAGES OF OTHER TYPES ARE CONSIDERED MERELY AS MESSAGES TO BE
+; PRINTED OUT WITH AN INDICATING OF WHO THEY ARE FROM
+
+; THE ARGS WHICH THIS SUBROUTINE IS CALLED WITH BY INTERRUPT ARE
+; <MESSAGE> <TYPE> <HIS NAME 1> <HIS NAME 2> <MY NAME 1> <MY NAME 2>
+; WHERE THE LAST TWO ARE OPTIONAL AND ONLY GIVEN IF THE SOCKET WAS NOT
+; LISTENING ON THE DEFAULT UNAME,JNAME COMBINATION.
+
+
+MFUNCTION IPCH,SUBR,[IPC-HANDLER]
+
+ ENTRY
+
+ PUSH P,[0] ;SAVE A SLOT FOR LATTER USE
+ HLRE 0,AB ;CHECK THE NUMBER OF ARGS WE GOT
+ CAMLE 0,[-8.] ;NEED AT LEAST 4 ARGS
+ JRST WNA
+ GETYP E,(AB) ;CHECK TYPE OF FIRST ARG
+ CAIN E,TCHSTR ;IS IT A CHARACTER STRING
+ JRST .+3
+ CAIE E,TUVEC ;IF NOT IT MUST BE A UVECTOR
+ JRST WTYP1 ;IF NEITHER THEN WE HAVE A LOOSER
+ GETYP A,2(AB) ;GET TYPE OF MESSAGE TYPE, SHOULD BE A FIX
+ CAIE A,TFIX
+ JRST WTYP2 ;IF NOT FIX COMPLAIN
+ GETYP A,4(AB)
+ CAIE A,TCHSTR ;HIS NAME 1 SHOULD BE CHAR STRING
+ JRST WTYP
+ GETYP A,6(AB)
+ CAIE A,TCHSTR
+ JRST WTYP ;HIS NAME 2 SHOULD BE CHAR STRING
+ CAML 0,[-8.] ;SEE IF WE HAVE 4 OR 6 ARGS
+ JRST IPCH1 ;WE ONLY HAD 4 ARGS
+ CAME 0,[-12.] ;THEN WE MUST HAVE EXACTLY 6 ARGS
+ JRST WNA
+ GETYP A,(AB)8.
+ CAIE A,TCHSTR
+ JRST WTYP ;CHECK TO SEE THE MY NAME 1 IS STRING
+ GETYP A,10.(AB)
+ CAIE A,TCHSTR
+ JRST WTYP ;CHECK TO SEE THAT MY NAME 2 IS STRING
+
+IPCH1: PUSH TP,$TCHAN
+ PUSH TP,TTOCHN+1 ;PUSH ON TTY OUTPUT CHANNEL TO CALL TERPRI
+ MCALL 1,TERPRI
+ PUSH TP,$TCHSTR
+ PUSH TP,CHQUOTE [IPC MESSAGE FROM ]
+ PUSH TP,$TCHAN
+ PUSH TP,TTOCHN+1
+ MCALL 2,PRINC ;PRINT OUT BLURB TO TELL LOOSER WHATS HAPPENING
+ PUSH TP,4(AB)
+ PUSH TP,5(AB) ;OUTPUT HIS NAME 1
+ PUSHJ P,TO ;JUMP OUT OUTPUTTER OVER TTY OUTPUT CHANNEL
+ PUSHJ P,STO ;JUMP TO SPACE OUTPUTTER OVER TTY OUTPUT CHANNEL
+ PUSH TP,6(AB)
+ PUSH TP,7(AB) ;OUTPUT NAME 2
+ PUSHJ P,TO
+ MOVE E,3(AB) ;MESSAGE TYPE
+ JUMPE E,IPCH3 ;IF MESSAGE TYPE 0 DO NOTHING ABOUT IT
+ CAIE E,1 ;IF 1 SEE IF THIS IS EXECUTE MESSAGE
+ JRST IPCH2 ;IF NOT TELL LOOSER ABOUT THIS MESSAGE TYPE
+ GETYP 0,(AB)
+ CAIE 0,TCHSTR ;SEE IF WE HAVE STRING
+ JRST IPCH2 ;IF NOT THIS CANT BE EXECUTE MESSAGE
+ AOS (P) ;SET FLAG TO INDICATE EXECUTE MESSAGE
+ PUSH TP,$TCHSTR
+ PUSH TP,CHQUOTE [ EXECUTE]
+ PUSHJ P,TO ;TELL THE LOOSER HE IS GETTING WHAT HE DESERVES
+ JRST IPCH3
+IPCH2: PUSH TP,$TCHSTR
+ PUSH TP,CHQUOTE [ TYPE ]
+ PUSHJ P,TO
+ PUSH TP,2(AB)
+ PUSH TP,3(AB) ;PUSH ON THE MESSAGE TYPE
+ PUSHJ P,TO
+IPCH3: HLRE 0,AB
+ CAME 0,[-12.] ;SEE IF WE HAVE 6 ARGS AND SO MUST TELL HIM WHO MESS IS FOR
+ JRST IPCH4 ;IF NOT DONT WORRY
+ PUSH TP,$TCHSTR
+ PUSH TP,CHQUOTE [ TO ]
+ PUSHJ P,TO
+ PUSH TP,8.(AB)
+ PUSH TP,9.(AB) ;PUSH ON MY NAME 1
+ PUSHJ P,TO
+ PUSHJ P,STO ;LEAVE SPACE BETWEEN NAMES
+ PUSH TP,10.(AB) ;PUSH ON MY NAME 2
+ PUSH TP,11.(AB)
+ PUSHJ P,TO
+IPCH4: PUSH TP,(AB) ;PUSH ON THE ACTUAL GOODIE
+ PUSH TP,1(AB)
+ PUSH TP,$TCHAN
+ PUSH TP,TTOCHN+1
+ MCALL 2,PRINT ;AND PRINT IT OUT
+ SKIPN (P) ;TEST TO SEE IF WE MUST EXECUTE THIS BAG BITTER
+ JRST IPCHND
+ PUSH TP,(AB)
+ PUSH TP,1(AB)
+ MCALL 1,PARSE ;PARSE HIS CRUFT
+ PUSH TP,A
+ PUSH TP,B
+ MCALL 1,EVAL ;THEN EVAL THE RESULT
+IPCHND: PUSH TP,$TCHAN
+ PUSH TP,TTOCHN+1
+ MCALL 1,TERPRI
+ MOVSI A,TATOM
+ MOVE B,IMQUOTE T
+ JRST FINIS ;TO RETURN WITH SOMETHING NICE
+
+STO: PUSH TP,$TCHSTR ;CROCK TO OUTPUT A SPACE ON THE TTY OUTPUT CHANNEL
+ PUSH TP,CHQUOTE [ ]
+TO: PUSH TP,$TCHAN
+ PUSH TP,TTOCHN+1
+
+ MCALL 2,PRINC
+ POPJ P, ;GO BACK TO WHAT WE WERE DOING
+\f
+
+;THESE ARE THE FUNCTIONS TO ACTUALLY STUFF GOODIES OUT
+;OVER THE IPC DEVICE
+;DESCRIPTION OF CALLING ARGS TO THEM IS AT THE
+;FIRST OF THE FILE
+
+MFUNCTION SEND,SUBR
+
+ ENTRY
+
+ PUSH P,[0] ;FLAG TO INDICATE DONT WAIT
+ JRST CASND
+
+MFUNCTION SENDW,SUBR,[SEND-WAIT]
+
+ ENTRY
+
+ PUSH P,[1] ;FLAG TO INDICATE WAITING
+
+CASND: HLRE 0,AB
+ CAMG 0,[-6] ;NEED AT LEAST 3 ARGS
+ CAMGE 0,[-12.] ;AND NOT MORE THAN 6 ARGS
+ JRST WNA
+ MOVE A,(AB)
+ MOVE B,1(AB)
+ PUSHJ P,STRTO6 ;POOF FIRST ARG TO SIXBIT
+ MOVE A,2(AB)
+ MOVE B,3(AB)
+ PUSHJ P,STRTO6 ;POOF SECOND ARG TO SIXBIT
+ GETYP 0,4(AB)
+ CAIN 0,TCHSTR
+ JRST CASND1 ;IF FIRST ARG IS STRING, NO PROBLEMS
+ CAIE 0,TSTORAGE
+ CAIN 0,TUVEC
+ JRST .+2
+ JRST WTYP3 ;ELSE MUST BE OF TYPE STORAGE OR UVEC
+ MOVE B,5(AB)
+ HLRE C,B ;GET COUNT FIELD
+ SUBI B,(C) ;AND ADD THAT AMOUNT TO FIND DOPE WORD
+ GETYP A,(B) ;GET TYPE WORD OUT OF DOPE
+ PUSHJ P,SAT ;GET ITS STORAGE TYPE
+ CAIE A,S1WORD
+ JRST WTYP3 ;CRUFT MUST BE OF TYPE WORD
+CASND1: PUSH TP,4(AB)
+ PUSH TP,5(AB) ;SAVE THE STRUCTURE AROUND TO REST OFF AS WE SEND
+ PUSH P,[0] ;SLOT FOR THIS MESSAGE TYPE, DEFAULT 0
+ HLRE 0,AB
+ CAMLE 0,[-8.] ;IF 4 OR MORE ARGS GET THE MESS TYPE
+ JRST CASND2
+ GETYP 0,6(AB) ;CHECK TO SEE THAT TYPE IS A FIX
+ CAIE 0,TFIX
+ JRST WTYP
+ MOVE 0,7(AB)
+ MOVEM 0,(P) ;SMASH IN THE SLOT RESERVED FOR TYPE
+CASND2: HLRE 0,AB
+ CAMN 0,[-10.] ;IF WE HAVE FIVE ARGS WE ARE A GLOBAL LOOSER NEED 4 OR 6
+ JRST WNA
+ CAMGE 0,[-8.] ;IF WE HAVE 4 OR LESS DONT WORRY
+ JRST .+4 ;GO GET LAST TO ARGS
+ PUSH P,[0] ;NO SIXBIT OF FROM
+ PUSH P,[0] ;SO SAVE SLOTS ANYWAY
+ JRST CASND3 ;GO WORRY ABOUT SENDING NOW
+ MOVE A,8.(AB)
+ MOVE B,9.(AB)
+ PUSHJ P,STRTO6 ;CONVERT MY NAME1 TO SIXBIT
+ MOVE A,10.(AB)
+ MOVE B,11.(AB) ;CONVERT MY NAME 2 TO SIXBIT
+ PUSHJ P,STRTO6
+
+CASND3: GETYP 0,-1(TP)
+ CAIE 0,TCHSTR ;IS THIS A CHAR STRING
+ JRST .+5
+ HRRZ A,-1(TP) ;IF SO GET COUNT
+ ADDI A,9.
+ IDIVI A,5 ;IF SO ROUND UP AND ADD ONE
+ JRST .+3
+ HLRE A,(TP)
+ MOVN A,A ;IF A VECTOR GET THE WORD COUNT
+ PUSH P,A ;SAVE COUNT OF WORDS
+ CAILE A,MAXMES
+ JRST TOBIGR ;MESS OVER SIZE LIKED BY MUDDLE
+ CAILE A,BUFL-MESHED ;HOW BIG A BUFFER DO WE NEED?
+ MOVEI A,BUFL-MESHED ;IF TOO BIG WE USE DEFAULT MAX SIZE, ELSE LESS
+ ADDI A,MESHED+BUFHED ;PLUS ROOM FOR MESSAGE AND SYSTEM HEADERS
+ PUSHJ P,IBLOCK
+ PUSH TP,A
+ PUSH TP,B ;GET BUFFER OF RIGHT SIZE AND SAVE ON STACK
+ PUSH TP,A
+ PUSH TP,B ;SAVE ANOTHER COPY WHICH WILL BE RESTED AT TIMES
+ MOVE C,-5(P) ;GET HIS NAME 1
+ MOVEM C,(B) ;AND STUFF IN RIGHT PLACE
+ MOVE C,-4(P)
+ MOVEM C,1(B) ;STUFF HIS NAME 2
+ MOVE C,-3(P)
+ MOVEM C,4(B) ;STUFF MESSAGE TYPE CODE WORD
+ GETYP 0,-5(TP) ;IS THIS STRING OR UVECTOR?
+ CAIE 0,TCHSTR
+ JRST CASND4
+ MOVE C,(P) ;GET LENGTH OF CHAR STRING TO SEND
+ ADDI C,1
+ MOVEM C,3(B) ;STORE IN LENGTH FIELD IN MESS HEADER
+ SOS (P) ;DECREMENT FOR COUNT WORD
+ HRRZ C,-5(TP) ;GET THE CHARACTER COUNT
+ MOVEM C,5(B) ;STORE IN CORRECT SLOT IN MESSAGE
+ MOVE D,[6,,6] ;OFFSET FOR INITIAL HEADER ON ASCII MESSAGES
+ ADDM D,(TP) ;OFFSET BUF PTR 2 BY THIS AMOUNT
+ JRST CASND5
+CASND4: MOVE C,(P) ;GET COUNT OF MESSAGE
+ ADDI C,1 ;EXTRA FOR TYPE WORD
+ MOVEM C,3(B) ;STORE IN SLOT FOR COUNT OF WHOLE MESSAGE
+ MOVE D,[5,,5] ;OFFSET FOR INITIAL HEADER ON UVECTOR MESSAGES
+ ADDM D,(TP) ;OFFSET BUF PTR 2 BY THIS AMOUNT
+CASND5: PUSHJ P,STUFBF ;GO FILL UP THE BUFFER WITH GARBAGE
+ MOVN 0,A ;GET NEGATIVE THE COUNT OF WORDS STUFFED
+ ADDM 0,(P) ;THAT MANY LESS WORDS REMAINING TO BE DONE
+ HRRZ C,-2(TP) ;GET A POINTER TO THE "UNRESTED" BUFFER
+ HRRZ D,(TP) ;GET A POINTER TO THE "RESTED" BUFFER
+ SUB D,C ;FIND OUT HOW MUCH WAS RESTED OFF
+ ADD D,A ;ADD TO THAT THE COUNT OF WORDS STUFFED THIS TIME
+ SUBI D,BUFHED ;LESS THE SYSTEM CONSTANT HEADER THAT DOENT COUNT
+ MOVEM D,2(C) ;STORE IN THE BUFFER IN CORRECT SLOT
+ PUSHJ P,CASIOT ;GO DO THE "IOT"--ACTUALLY AN OPEN
+ MOVE C,-2(TP)
+ HRLZI E,CONT ;THE "THIS IS A CONTINUATION" BIT
+ IORM E,3(C) ;TURN BIT ON IN FUTURE MESSAGES
+ ADD C,[4,,4] ;REST OFF THE SHORTER HEADER FOR THE REST OF MESSAGES
+ MOVEM C,(TP) ;STORE THIS IN THE "RESTED" BUFFER SLOT
+ SKIPLE (P) ;IS THERE MORE TO DO?
+ JRST CASND5
+ MOVSI A,TATOM
+ MOVE B,IMQUOTE T
+ JRST FINIS ;RETURN HIM SOMETHING NICE
+
+TOBIGR: ERRUUO EQUOTE MESSAGE-TOO-BIG
+
+\f
+STUFBF: MOVE C,-2(TP) ;ROUTINE TO FILL UP BUFFER WITH GOODIES
+ HRLZI E,INCOMP+ASCIMS
+ ANDCAM E,3(C) ;CLEAR THE INCOMPLETE AND ASCII FLAGS IF SET
+ HLRE B,(TP) ;GET THE BUFFER LENGTH
+ MOVN B,B ;MAKE IT A POSITIVE NUMBER
+ CAML B,-1(P) ;SEE IF THE WHOLE MESSAGE WILL FIT
+ JRST .+4 ;IT WILL ALL FIT
+ HRLZI 0,INCOMP ;THE INCOMPLETE FLAG
+ IORM 0,3(C) ;SET IT
+ JRST .+2
+ MOVE B,-1(P) ;ELSE THE WHOLE MESSAGE FITS
+ GETYP 0,-5(TP)
+ CAIN 0,TCHSTR
+ JRST STUFAS
+ HRLZ D,-4(TP) ;SET UP TO BLT UVECTOR
+ HRR D,(TP)
+ HRRZ E,(TP)
+ ADDI E,(B)-1 ;SET UP BLT POINTERS
+ SKIPLE B ;IN CASE ZERO LENGTH UVECTOR
+ BLT D,(E) ;BBBBLLLLLLLLLLLLLLLLLLTTTT?
+ MOVE A,B ;MOVE COUNT OF WORDS DONE INTO A
+ HRL B,B
+ ADDM B,-4(TP) ;REST OFF THIS MUCH OF GOODIE FOR NEXT TIME
+ POPJ P,
+STUFAS: HRLZI 0,ASCIMS
+ IORM 0,3(C) ;TURN ON THE ASCII BIT IN THE MESSAGE
+ MOVE A,B ;MOVE COUNT OF NUMBER OF WORDS INTO A
+ IMULI B,5 ;GET CHAR COUNT IN B
+ HRRZ C,-5(TP) ;COMPARE THIS WITH COUNT FIELD IN STRING
+ MOVE D,B
+ SUB D,C ;SEE HOW MANY EXTRA BLANKS AT END OF MESS
+ JUMPGE D,.+3
+ MOVEI D,0 ;NO EXTRA SPACES TO PAD
+ MOVE C,B ;NOT EXTRA SPACES, DO 5*WORD CHARS
+ MOVN E,C
+ ADDM E,-5(TP) ;FIX UP COUNT IN ASCII
+ HRLZI E,440700 ;GET A IDPB PTR INTO THE BUFFER
+ HRR E,(TP) ;POINT TO RIGHT PLACE IN BUFFER
+ JUMPLE C,.+4 ;ARE WE DONE MOVING CHARS?
+ ILDB 0,-4(TP) ;LOAD A BYTE FROM STRING
+ IDPB 0,E ;STUFF IN BUFFER
+ SOJG C,.-2 ;REPEAT THE LOOP
+ JUMPLE D,.+4 ;SEE IF WE NEED TO FILL OUT WITH NULLS
+ MOVEI 0,0
+ IDPB 0,E ;STUFF A NULL IN RIGHT SPOT IN BUFFER
+ SOJG D,.-1
+ POPJ P,
+
+CASIOT: HRRZI A,(SIXBIT /IPC/) ;FIX UP OPEN BLOCK IN THE AC'S
+ MOVE B,-2(TP) ;HOWS THAT FOR SNAZZY?
+ MOVE C,-3(P) ;MY NAME 1
+ MOVE D,-2(P) ;MY NAME 2
+ JUMPN C,.+3
+ JUMPN D,.+2
+ TLO A,USEUJ ;IF BOTH ARE ZERO THEN USE DEFAULT UNAME,JNAME
+ SKIPN -7(P) ;SEE IF SEND AND HANG FLAG IS SET
+ JRST .+3
+ TLO A,SANDH ;SET SEND AND HANG FLAG
+ JRST .+3
+ TLO A,SIMM ;ELSE WE MUST BE SENDING IMMEDIATE
+ AOS -7(P) ;IF THERE IS MORE TO DO, IT MUST BE IN HANG MODE
+ MOVSI 0,TUVEC
+ MOVE PVP,PVSTOR+1
+ MOVEM 0,BSTO(PVP) ;IN CASE WE ARE INTERRUPTED OUT WE WANT TO WIN
+ SETZM E ;FLAG USED TO INDICATE NO SKIPPAGE
+ ENABLE
+ .OPEN 0,A ;WELL, THATS ALL THERE IS TO IT.
+ AOS E ;IF WE DONT SKIP WE HAVE PROBLEMS
+ DISABLE
+ MOVE PVP,PVSTOR+1
+ SETZM BSTO(PVP) ;FIX UP THE SLOT IN PVP
+ SKIPN E ;SEE IF WE LOST
+ POPJ P, ;IF NOT WE ARE THROUGH WITH THIS PART
+ .STATUS 0,A ;FIND OUT REASON FOR LOSSAGE
+ MOVEI B,0
+ PUSHJ P,GFALS ;MAKE A FALSE WITH THAT REASON
+ JRST FINIS ;GIVE THE MAGIC FALSE BACK TO THE LOOSER
+
+\f
+MFUNCTION DEMSIG,SUBR
+
+ ENTRY 1
+
+ MOVE A,(AB)
+ MOVE B,1(AB)
+ PUSHJ P,STRTO6 ;GET THE SIXBIT REPRESENTATION
+ MOVE A,[SETZ] ;FIX UP THE BLOCK IN THE AC'S
+ MOVE B,[SIXBIT /DEMSIG/]
+ MOVE C,[SETZ (P)] ;THE SIXBIT IS ON TOP OF P STACK
+ .CALL A
+ JRST RFALS ;DIDNT WIN WITH DEMON SIGNAL
+RTRUE: MOVSI A,TATOM
+ MOVE B,IMQUOTE T
+ JRST FINIS
+
+RFALS: MOVSI A,TFALSE
+ MOVEI B,0
+ JRST FINIS ;FALSE INDICATING LACK OF WINNAGE
+
+\f
+MFUNCTION IPCON,SUBR,[IPC-ON]
+
+ ENTRY
+
+ PUSH P,[USEUJ,,0] ;FLAG FOR WHETHER OR NOT TO USE DEFAULT
+ HLRZ 0,AB
+ JUMPE 0,IPCON1 ;NO ARGS ARE FINE
+ CAIE 0,-4 ;ELSE MUST HAVE 2 ARGS
+ JRST WNA
+ SETZM (P) ;CLEAR OUR FLAG
+ MOVE A,(AB)
+ MOVE B,1(AB)
+ PUSHJ P,STRTO6 ;GET SIXBIT OF OUR FIRST ARG
+ MOVE A,2(AB)
+ MOVE B,3(AB)
+ PUSHJ P,STRTO6 ;GET SIXBIT OF OUR SECOND ARG
+ JRST IPCON2
+IPCON1: PUSH P,[0] ;SAVE SLOT ON STACK FOR EVENNESS
+ PUSH P,[0]
+IPCON2: MOVEI A,BUFL+BUFHED
+ PUSHJ P,CAFRE ;GET A BUFFER OF RIGHT LENGTH TO READ INTO
+ PUSH P,A ;AND SAVE IT AROUND SO WE DONT LOOSE
+ MOVEI 0,BUFL
+ MOVEM 0,2(A) ;FILL COUNT IN THE BUFFER SLOT
+ MOVEI A,5
+ PUSHJ P,IBLOCK ;GET A BLOCK OF STORE FOR THE OPEN BLOCK
+ PUSH TP,$TUVEC
+ PUSH TP,B ;SAVE CRUFT ON TP
+ TLO 0,RFROMA ;SET THE READ FROM ANY FLAG
+ IOR 0,-3(P) ;FIX FOR DEFAULT UNAME,JNAME IF FLAG INDICATES
+ MOVEM 0,(B) ;MAKE OPEN BLOCK
+ MOVE 0,[SIXBIT /IPC/]
+ MOVEM 0,1(B)
+ MOVE 0,-2(P)
+ MOVEM 0,3(B) ;MY NAME 1
+ MOVE 0,-1(P)
+ MOVEM 0,4(B) ;MY NAME 2 IF NOT USING DEFAULT
+ MOVE 0,(P)
+ MOVEM 0,2(B) ;PTR TO THE WIRED BUFFER FOR STUFFING CRUFT
+ MOVE A,B
+ PUSHJ P,MOPEN ;GO DO THE OPEN
+ JRST IPCON3 ;OPEN FAILED, FIND OUT WHY
+ PUSH P,A ;SAVE THE CHANNEL NUMBER
+ MOVEI E,1
+ LSH E,(A) ;SET INTERRUPT BITS RIGHT
+ IORM E,MASK2
+ .SUSET [.SMSK2,,MASK2]
+ MOVE C,-1(TP)
+ MOVE D,(TP) ;GET THE OPEN BLOCK UVECTOR
+ PUSHJ P,INCONS ;THROW INTO PAIR SPACE
+ POP P,C ;GET THE CHANNEL #
+ SUBI C,1
+ IMULI C,2
+ MOVEM B,IPCS1+1(C) ;STUFF PTR TO OPEN BLOCK INTO SLOT IN TVP
+ JRST RTRUE ;WE WON, GO LET LUSER KNOW IT.
+IPCON3: PUSH P,A ;WE LOST, LETS FIND OUT WHY
+ MOVE A,BUFL+BUFHED
+ MOVE B,-1(P) ;LETS FREE UP OUR WIRED DOWN BUFFER TO BE CLEAN
+ PUSHJ P,CAFRET
+ POP P,A ;GET THE CHANNEL # BACK
+ JUMPL A,NFCHN ;NO FREE CHANNELS?
+ 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
+ MOVEI B,0
+ PUSHJ P,GFALS
+ JRST FINIS ;RETURN A LOOSE WITH REASON FOR LOOSAGE
+
+NFCHN: ERRUUO EQUOTE NO-ITS-CHANNELS-FREE
+
+\f
+MFUNCTION IPCOFF,SUBR,[IPC-OFF]
+
+ ENTRY 0
+
+ PUSH TP,$TVEC
+ MOVE 0,[IPCS1,,IPCS1]
+ PUSH TP,0 ;SAVE OUR PLACE IN RUNNING THROUGH SLOTS
+ PUSH P,[1] ;COUNTER OF CHANNEL NUMBER
+
+IPCOF1: MOVE A,(TP) ;GET FIRST GOODIE
+ SKIPN B,1(A) ;GET THE POINTER TO LIST
+ JRST IPCOF2
+ SETZM 1(A) ;ZERO OUT SLOT TO BE CLEAN
+ MOVE B,1(B) ;GET CAR OF LIST, PTR TO OPEN BLOCK
+ MOVE C,(P) ;GET THE ACTUAL CHANNEL NUMBER
+ MOVEI E,1 ;TURN OFF INTERRUPT
+ LSH E,(C)
+ ANDCAM E,MASK2
+ .SUSET [.SMSK2,,MASK2]
+ MOVE A,C
+ PUSHJ P,MCLOSE ;CLOSE THIS CHANNEL
+ JFCL
+ MOVEI A,BUFL+BUFHED ;LENGTH OF WIRED STORE TO FREE UP
+ MOVE B,1(B) ;GET THE POINTER TO WIRED STORE
+ PUSHJ P,CAFRET ;FREE ALREADY
+IPCOF2: MOVE 0,[2,,2]
+ ADDM 0,(TP) ;REST TO NEXT SLOT
+ AOS D,(P) ;NEXT CHANNEL
+ CAIG D,15. ;ARE WE THROUGH
+ JRST IPCOF1
+ JRST RTRUE ;RETURN HIM A TRUE FOR NICENESS
+
+\f
+IPCGOT: MOVEI D,IPCS1+1
+ ADDI D,(B)
+ ADDI D,(B)
+ SKIPN D,-74.(D) ;GET THE GOODIE LIST FOR CHANNEL WE INTERRUPTED ON
+ JRST DIRQ ;MIX UP MAYBE, LET HIM WORRY ABOUT IT
+ PUSH P,B ;SAVE THE CHAN #
+ PUSH TP,$TLIST
+ PUSH TP,D ;SAVE GOODIE LIST
+ MOVE E,1(D) ;GET PTR TO OPEN BLOCK
+ PUSH P,2(E) ;SAVE PTR TO WIRED BUFFER
+ MOVE E,2(E)
+ MOVE 0,3(E) ;GET THE MAGIC BITS FOR THIS MESSAGE
+ TLNE 0,CONT ;IS THIS MESSAGE A CONTINUATION?
+ JRST IGCON ;YES
+ MOVEI A,10. ;NO
+ PUSHJ P,GIBLOK ;GET A BLOCK FOR FUNNY MESSAGE VECTOR
+ PUSH TP,$TVEC
+ PUSH TP,B ;SAVE THE BLOCK FOR FUNNY MESSAGE VECTOR
+ MOVE E,(P) ;GET PTR TO WIRED BUFFER
+ MOVE 0,3(E) ;GET THE MAGIC BITS AGAIN
+ HRRZ A,0 ;GET THE LENGTH IN WORDS OF THIS THE WHOLE MESSAGE HE HAS
+ SUBI A,1 ;MINUS ONE FOR THE TYPE WORD WHICH IS COUNTED
+ TLNE 0,ASCIMS ;IS THIS ASCII?
+ SUBI A,1 ;IF YES THEN MUST SUB 1 MORE FOR ASCII CHAR COUNT
+ CAILE A,MAXMES ;IS THIS BIGGER THAN MUDDLE BLESSES?
+ JRST TBGMS ;IF SO THEN CLEAN UP AND FORGET ABOUT THE LOOSER
+ PUSHJ P,IBLOCK
+ MOVE E,(P)
+ MOVE D,(TP)
+ MOVE 0,(E) ;GET HIS NAME 1 OUT OF MESSAGE
+ MOVEM 0,5(D) ;STORE INTO SLOT IN FUNNY MESSAGE VECTOR
+ MOVE 0,1(E) ;GET HIS NAME 2 OUT OF MESSAGE
+ MOVEM 0,7(D)
+ MOVE 0,4(E) ;GET THE MESSAGE TYPE WORD
+ MOVEM 0,9(D) ;STORE INTO SLOT IN MESSAGE VECTOR
+ MOVSI 0,TFIX
+ MOVE 0,4(D)
+ MOVE 0,6(D)
+ MOVE 0,8(D)
+ MOVE 0,3(E) ;GET THE MESSAGE BITS
+ TLNE 0,ASCIMS ;IS IT ASCII?
+ JRST IG1 ;YES
+ MOVSI 0,TUVEC
+ MOVEM 0,(D)
+ MOVEM 0,2(D)
+ MOVEM B,1(D)
+ MOVEM B,3(D) ;STORE MESSAGE BLANK TWICE, THE SECOND TO REST THROUGH
+ HLRE E,B
+ SUBM B,E
+ MOVSI 0,TFIX
+ MOVEM 0,(E) ;SET NICE TYPE TO PRINT GOODER
+ JRST IGBLT
+IG1: MOVSI 0,TUVEC
+ MOVEM 0,2(D)
+ MOVEM B,3(D) ;STORE MESSAGE BLANK AS UVECTOR TO REST THROUGH
+ HLRE A,B
+ HRLI B,010700 ;MAKE THE ILDB PTR
+ SUBI B,1
+ MOVEM B,1(D) ;AND STORE IN THE SLOT
+ IMUL A,[-5] ;MAX CHAR COUNT FOR STRING
+ MOVE B,5(E) ;GET THE ACTUAL CHARACTER COUNT HE CLAIMED
+ MOVE C,A
+ SUB C,B ;FIND DIFFERENCE BETWEEN MAX AND CLAIMED
+ JUMPL C,.+2 ;IF COUNT TOO BIG, MUST DO BEST POSSIBLE AND USE MAX COUNT
+ CAILE C,4 ;NO MORE THAN FOUR EXTRA CHARS IMPLIES GOODNESS
+ MOVE B,A ;IF LOSSAGE, THEN USE MAX COUNT INSTEAD OF HIS CLAIM
+ HRLI B,TCHSTR ;MAKE THIS A CHAR STRING TYPE WORD
+ MOVEM B,(D) ;AND FIX MESSAGE BLANK # 1 TO BE THE BLESSED STRING
+ JRST IGBLT ;BLT THE MESSAGE INTO THE BLANK
+
+IGCON: MOVE D,(TP) ;GET THE IPC SLOT LIST
+ MOVE E,(P) ;GET A PTR TO THE MESSAGE BUFFER
+ HRRZ C,(D) ;CDR THE IPC SLOT LIST TO POINT TO FIRST MESSAGE VECTOR
+IGCON1: JUMPE C,IGCONL ;IF NIL, THEN ABANDON ALL HOPE
+ MOVE B,1(C) ;LOOK AT THE VECTOR
+ MOVE 0,5(B) ;HIS NAME 1 FOR THIS BLOCK
+ CAME 0,(E) ;COMPARE WITH HIS NAME 1 IN THIS MESSAGE
+ JRST IGCON2 ;IMMEDIATE FAILURE, TRY THE NEXT IN THE LIST
+ MOVE 0,7(B) ;SEE IF HIS NAME 2 ALSO MATCHES
+ CAME 0,1(E) ;WELL, DOES IT MATCH?
+ JRST IGCON2 ;NO, TRY THE NEXT ONE
+ PUSH TP,$TVEC ;WE GOT IT
+ PUSH TP,1(C) ;SAVE THIS MESSAGE BLOCK ON TP FOR LATER BLTING
+ HRRZ C,(C) ;CDR TO REST OF LIST
+ HRRM C,(D) ;AND SPLICE IT RIGHT OUT OF THE LIST, NEAT HUH?
+ JRST IGBLT ;GO BLT TO OUR HEART'S CONTENT
+IGCON2: HRRZ D,(D) ;REST OUR FOLLOW UP POINTER
+ HRRZ C,(C) ;REST OUR ACTUAL TEST POINTER
+ JRST IGCON1 ;TRY AGAIN
+
+IGCONL: MOVE A,(TP)
+ MOVE A,1(A) ;GET PTR TO OPEN BLOCK
+ MOVE B,-1(P)
+ SUBI B,36. ;GET CHANNEL NUMBER
+ HLL B,(A)
+ MOVE C,(P) ;GET THE WIRED BUFFER
+ SUB P,[2,,2] ;WE LOST SO CLEAN UP STACKS
+ SUB TP,[2,,2]
+ROPNL: SETZM (C) ;REOPEN CHANNEL SO NOT PERMANENTLY CROGGLED
+ SETZM 1(C) ;ZERO OUT THE HIS NAME SLOTS
+ MOVEI 0,BUFL
+ MOVEM 0,2(C) ;RESET THE LENGTH FIELD IN WIRED BUF
+ DOTCAL OPEN,[B,1(A),2(A),3(A),4(A)]
+ FATAL CANT REOPEN IPC CHN
+ JRST DIRQ ;LEFT IN NICE STATE AFTER LOOSAGE
+
+TBGMS: MOVE A,-2(TP)
+ MOVE A,1(A) ;GET OPEN BLOCK
+ MOVE B,-1(P)
+ SUBI B,36. ;CHANNEL #
+ HLL B,(A)
+ MOVE C,(P) ;WIRED BUFFER
+ SUB P,[2,,2] ;CLEAN UP STACKS
+ SUB TP,[4,,4]
+ JRST ROPNL ;REOPEN SO NEXT GUY CAN WIN
+
+\f
+
+IGBLT: MOVE E,(TP) ;POINTER TO MESSAGE VECTOR
+ MOVE E,3(E) ;GET VECTOR (MAYBE STRING IN DISGUISE) TO BLT IN
+ MOVE D,(P) ;GET THE WIRED BUFFER
+ MOVEI C,4(D) ;GET A POINTER TO THE REST OF THE WIRED BUF
+ MOVEI 0,BUFL-1 ;KLUDGE TO IGNORE ONE EXTRA WORD OF BITS
+ SUB 0,2(D) ;GET LENGTH OF GOODIE GOT
+ MOVE A,3(D) ;GET THE RANDOM MESSAGE BITS
+ TLNE A,CONT ;TEST FOR CONTINUED MESSAGE
+ JRST .+7 ;IF SO THEN NO NEED TO WORRY
+ SOS 0
+ AOS C ;FIX UP FOR ONE LESS WORD TO WORRY WITH
+ TLNN A,ASCIMS ;TEST FOR ASCII MESSAGE
+ JRST .+3 ;IF NOT THEN NO WORRY
+ SOS 0
+ AOS C ;FIX UP FOR YET 1 FEWER WORD
+ HLRE A,E
+ MOVM A,A ;GET LENGTH OF VECTOR TO BLT INTO
+ CAILE 0,(A) ;CHECK TO SEE WE DONT HAVE TOO MUCH
+ MOVE 0,A ;IF WE HAVE TOO MUCH, CHOP OFF--HA, HA, HA
+ MOVEI B,-1(E)
+ ADD B,0 ;B POINTS TO LAST WORD TO BLT INTO
+ HRL C,E ;BLT POINTER
+ MOVSS C ;NDR CANT REMEMBER HOW TO BLT POINTER
+ BLT C,(B) ;VIOLA
+ HRL 0,0
+ MOVE E,(TP) ;GET BACK POINTER TO MESSAGE VECTOR
+ ADDM 0,3(E) ;REST OFF TO KEEP TRACK OF INCOMPLETE MESSAGE
+ MOVE A,3(D) ;GET THE RANDOM MESSAGE BITS BACK
+ TLNE A,INCOMP ;MESSAGE COMPLETE?
+ JRST IGHALF ;INCOMPLETE
+ JRST IGMES ;COMPLETE
+
+IGHALF: MOVE C,-1(TP) ;GOT TO SPLICE MESSAGE VECTOR BACK IN
+ MOVE D,(TP)
+ PUSHJ P,INCONS ;STICK INTO PAIR SPACE
+ HRRZ E,-2(TP) ;PTR TO LIST
+ HRRZ D,(E) ;CDR OF LIST
+ HRRM D,(B) ;MAKE SPLICE
+ HRRM B,(E) ;THAT IT
+ MOVE B,1(E) ;POINT TO OPEN BLOCK
+ MOVE 0,-1(P) ;GET CHAN #
+ SUBI 0,36.
+ HLL 0,(B)
+ MOVE E,(P) ;GET THE WIRED BUF
+ MOVEI D,BUFL
+ MOVEM D,2(E) ;REFIX THE WIRED BUF
+ SETZM (E)
+ SETZM 1(E)
+ DOTCAL OPEN,[0,1(B),2(B),3(B),4(B)]
+ FATAL CANT REOPEN IPC CHN
+ SUB P,[2,,2]
+ SUB TP,[4,,4] ;CLEAN OURSELVES
+ JRST DIRQ ;THATS ALL THERE IS TO IT
+
+IGMES: HRRZ E,-2(TP) ;PTR TO OUR KLUDGE LIST
+ MOVE B,1(E) ;PTR TO OPEN BLOCK
+ MOVE 0,-1(P) ;CHANNEL #
+ SUBI 0,36.
+ HLL 0.(B)
+ MOVE D,(P) ;GET THE WIRED BUF
+ MOVEI C,BUFL
+ MOVEM C,2(D)
+ SETZM (D)
+ SETZM 1(D) ;BLESS WIRED BUF FOR REOPENING
+ DOTCAL OPEN,[0,1(B),2(B),3(B),4(B)]
+ FATAL CANT REOPEN IPC CHN
+ MOVE E,(TP) ;GET THE MESSAGE VECTOR (ALIAS GOODIE BLOCK)
+ SUB P,[2,,2] ;BLESS OUR P STACK
+ PUSH P,5(E) ;SAVE SIXBIT HIS NAME 1
+ PUSH P,7(E) ;SAVE SIXBIT HIS NAME 2
+ SUB TP,[4,,4] ;BLESS THE TP STACK
+ PUSH TP,$TCHSTR
+ PUSH TP,CHQUOTE IPC
+ PUSH TP,(E) ;STUFF STUFF ON TO CALL INTERRUPT
+ PUSH TP,1(E) ;THAT IS THE ACTUAL MESSAGE
+ MOVE 0,9(E)
+ CAMN 0,[400000,,0]
+ JRST IGUG
+IGUGN: PUSH P,3(B) ;GET MY NAME 1 OUT OF OPEN BLOCK
+ PUSH P,4(B) ;GET MY NAME 2 OUT OF OPEN BLOCK
+ MOVE 0,(B) ;GET SOME OF THE RANDOM OPEN FLAGS
+ TLNE 0,USEUJ
+ SETZ -1(P) ;MAKE SURE WE HAVE INDICATOR IF THIS IS TO UNAME,JNAME
+ PUSH TP,$TFIX
+ PUSH TP,9(E) ;SAVE THE MESSAGE TYPE
+ MOVE A,-3(P) ;HIS NAME 1
+ PUSHJ P,6TOCHS
+ PUSH TP,A
+ PUSH TP,B ;GIVE HIM NICE CHAR STRING OF ALL THE NAMES
+ MOVE A,-2(P)
+ PUSHJ P,6TOCHS
+ PUSH TP,A
+ PUSH TP,B ;NICE CHAR STRING OF HIS NAME 2
+ SKIPN A,-1(P) ;ISE THIS DEFAULT UNAME, JNAME
+ JRST IGFOUR ;ONLY FOUR ARGS TO THE IPC INTERRUPT
+ PUSHJ P,6TOCHS
+ PUSH TP,A
+ PUSH TP,B
+ MOVE A,(P)
+ PUSHJ P,6TOCHS
+ PUSH TP,A
+ PUSH TP,B ;GIVE HIM CHAR STRINGS OF MY NAME 1 AND 2 IF NOT DEFAULT
+ MOVEI E,7 ;FOR ACALL INDICATING 6 ARGS TO THE IPC INTERRUPT HANDLER
+ JRST .+2 ;SKIP OVER FIX FOR ONLY 4 ARGS TO IPC INTERRUPT
+IGFOUR: MOVEI E,5
+ SUB P,[4,,4] ;CLEAN UP OUR WHOLE WORLD
+ ACALL E,INTERR ;THATS IT FOLKS, THE REAL THING
+ JRST DIRQ
+
+IGUG: .SUSET [.RMARPC,,0]
+ CAMN 0,[-1]
+ JRST IGUGN ; DISABLED, SO GO AWAY
+ SETZM INTHLD ; RE-ENABLEE INTERRUPTS
+ SUB P,[2,,2]
+ MCALL 1,PARSE
+ SUB TP,[2,,2] ;FLUSH OFF STRING "IPC"
+ PUSH TP,A
+ PUSH TP,B
+ MCALL 1,EVAL
+ JRST DIRQ
+
+\f
+IPCBLS: PUSH P,A
+ PUSH P,B
+ PUSH P,C
+ PUSH P,D
+ PUSH P,E ;PARANOIA STRIKES AGAIN
+ PUSH P,0
+ MOVEI E,0 ;CRETIN ASSEMBLER
+ .SUSET [.SMARPC,,E]
+ MOVEI E,IPCS1 ;BLESSES ALL CURRENTLY OPEN IPC CHANNELS
+ MOVEI 0,1
+IPCBL1: SKIPN B,1(E)
+ JRST IPCBL2
+ HLLZS (B) ;CLEAR OUT ANY PARTIAL BUFFER WE MAY HAVE
+ HRRZ B,1(B) ;GET A POINTER TO THE OPEN BLOCK
+ MOVE A,0 ;GET THE CHANNEL NUMBER
+ HLL A,(B)
+ MOVE C,2(B) ;GET A POINTER TO THE BUFFER
+ MOVEI D,BUFL ;TO FIX UP THE BUFFER
+ MOVEM D,2(C) ;FIX LENGTH UP RIGHT
+ SETZM (C)
+ SETZM 1(C) ;FIX UP THE READ FROM FIELDS
+ DOTCAL OPEN,[A,1(B),2(B),3(B),4(B)]
+ FATAL IPC DEVICE LOST
+IPCBL2: ADDI E,2
+ ADDI 0,1
+ CAIG 0,15.
+ JRST IPCBL1 ;IF ANY MORE GO BLESS THEM
+
+ POP P,0
+ POP P,E
+ POP P,D
+ POP P,C
+ POP P,B
+ POP P,A
+ POPJ P,
+
+
+
+
+END
+\f\ 3\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
+]
+
+
+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
+
+.GLOBAL TBINIT,PIDSTO,PROCID,PTIME,GCPDL,PBASE,TYPTOP,RERR,FRMSTK,EMERGE
+.GLOBAL PDLBUF,INTINT,START,SWAP,ICR,SPBASE,TPBASE,TPBAS,CURPRI,CHFINI,MKTBS
+.GLOBAL TOPLEVEL,INTOBL,INITIA,ERROBL,MAINPR,RESFUN,STATUS,TYPVEC,ROOT,TTICHN,TTOCHN
+.GLOBAL TTYOPE,MOPEN,MCLOSE,MIOT,ILVAL,MESS,ERROR,CHFRM,IGVAL,TYPBOT,ASOVEC
+.GLOBAL PRINT,PRIN1,PRINC,MUDSTR,VECBOT,CSTACK,IFALSE,TYPLOO,RCALL,SWAPIN,CTMPLT
+.GLOBAL IDPROC,CHFSWP,ILOC,MAKACT,BNDV,SPECSTORE,BINDID,IGLOC,MTYO,MSGTYP,CAFRE1,CPOPJ
+.GLOBAL EVATYP,EVTYPE,APLTYP,APTYPE,PRNTYP,PRTYPE,AGC,SGSNAM,NAPT,APLQ,STRTO6
+.GLOBAL 6TOCHS,TYPFND,STBL,CHNL0,N.CHNS,CLOSAL,%LOGOUT,%SSNAM,%RSNAM,%KILLM,SAT
+.GLOBAL MAKINF,%VALRET,COMPERR,IPUT,IGET,TMATCH,INITIZ,IPCINI,%UNAM,%JNAM,%RUNAM,%RJNAM,%RXUNA,%RXJNA,%VALFI
+.GLOBAL NOTTY,DEMFLG,CFRAME,CARGS,CFUNCT,CITYPE,CTYPEQ,CPTYPE,CTYPEP,CUTYPE,
+.GLOBAL CCHUTY,RTFALS,PGINT,PURCLN,CTYPEC,CTYPEW,IDVAL1,CALLTY,MESSAG,INITFL,WHOAMI
+.GLOBAL %SLEEP,%HANG,%TOPLQ,ONINT,CHUNW,CURFCN,BUFRIN,TD.LNT,TD.GET,TD.AGC,TD.PUT,MPOPJ
+.GLOBAL PURVEC,PLOAD,SSPECS,OUTRNG,CVTYPE,FSTART,CKVRS,CPRTYC,PVSTOR,SPSTOR
+.GLOBAL TYPIC,CISET,LSTUF,IMPURI,REALTV
+.INSRT MUDDLE >
+
+;MAIN LOOP AND STARTUP
+
+START: MOVEI 0,0 ; SET NO HACKS
+ JUMPE 0,START1
+ TLNE 0,-1 ; SEE IF CHANNEL
+ JRST START1
+ MOVE P,GCPDL
+ MOVE A,0
+ PUSH P,A
+ PUSHJ P,CKVRS ; CHECK VERSION NUMBERS
+ POP P,A
+ JRST FSTART ; GO RESTORE
+START1: MOVEM 0,WHOAMI ; HACK FOR TS FOO linked to TS MUDDLE
+ MOVE PVP,MAINPR ; MAKE SURE WE START IN THE MAIN PROCESS
+ JUMPE 0,INITIZ ; MIGHT BE RESTART
+ MOVE P,PSTO+1(PVP) ; SET UP FOR BOOTSTRAP HACK
+ MOVE TP,TPSTO+1(PVP)
+INITIZ: MOVE PVP,MAINPR
+ SKIPN P ; IF NO CURRENT P
+ MOVE P,PSTO+1(PVP) ; PDL TO GET OFF THE GROUND
+ SKIPN TP ; SAME FOR TP
+ MOVE TP,TPSTO+1(PVP) ; GET A TP TO WORK WITH
+ SETZB R,M ; RESET RSUBR AC'S
+ PUSHJ P,%RUNAM
+ JFCL
+ PUSHJ P,%RJNAM
+ PUSHJ P,TTYOPE ;OPEN THE TTY
+ MOVEI B,MUDSTR
+ SKIPE WHOAMI ; SKIP IF THIS IS MUDDLE
+ JRST NODEMT ; ELSE NO MESSAGE
+ SKIPE DEMFLG ; SKIP IF NOT DEMON
+ JRST NODEMT
+ SKIPN NOTTY ; IF NO TTY, IGNORE
+ PUSHJ P,MSGTYP ;TYPE OUT TO USER
+
+NODEMT: XCT MESSAG ;MAYBE PRINT A MESSAGE
+ PUSHJ P,INTINT ;INITIALIZE INTERRUPT HANDLER
+ XCT IPCINI
+ PUSHJ P,PURCLN ; CLEAN UP PURE SHARED AREA
+RESTART: ;RESTART A PROCESS
+STP: MOVEI C,0
+ MOVE PVP,PVSTOR+1
+ MOVE B,TBINIT+1(PVP) ;POINT INTO STACK AT START
+ PUSHJ P,CHUNW ; LEAVE WHILE DOING UNWIND CHECK
+ MOVEI E,TOPLEV
+ MOVEI A,TFALSE ; IN CASE FALLS OFF PROCESS
+ MOVEI B,0
+ HRRM E,-1(TB)
+ JRST CONTIN
+
+ IMQUOTE TOPLEVEL
+TOPLEVEL:
+ MCALL 0,LISTEN
+ JRST TOPLEVEL
+\f
+
+IMFUNCTION LISTEN,SUBR
+
+ ENTRY
+ PUSH P,[0] ;FLAG: DON'T PRINT ERROR MSG
+ JRST ER1
+
+; USER SUPPLIED ERROR HANDLER, TEMPORARY KLUDGE
+ IMQUOTE ERROR
+
+ERROR: MOVE B,IMQUOTE ERROR
+ PUSHJ P,IGVAL ; GET VALUE
+ GETYP C,A
+ CAIN C,TSUBR ; CHECK FOR NO CHANGE
+ CAIE B,RERR1 ; SKIP IF NOT CHANGED
+ JRST .+2
+ JRST RERR1 ; GO TO THE DEFAULT
+ PUSH TP,A ; SAVE VALUE
+ PUSH TP,B
+ MOVE C,AB ; SAVE AB
+ MOVEI D,1 ; AND COUNTER
+USER1: PUSH TP,(C) ; PUSH THEM
+ PUSH TP,1(C)
+ ADD C,[2,,2] ; BUMP
+ ADDI D,1
+ JUMPL C,USER1
+ ACALL D,APPLY ; EVAL USERS ERROR
+ JRST FINIS
+
+
+
+IMFUNCTION ERROR%,SUBR,ERROR
+
+RERR1: ENTRY
+ PUSH TP,$TATOM
+ PUSH TP,MQUOTE ERROR,ERROR,INTRUP
+ PUSHJ P,FRMSTK ; PUT ERROR'S FRAME ON STACK
+ MOVEI D,2
+ MOVE C,AB
+RERR2: JUMPGE C,RERR22
+ PUSH TP,(C)
+ PUSH TP,1(C)
+ ADD C,[2,,2]
+ AOJA D,RERR2
+RERR22: ACALL D,EMERGENCY
+ JRST RERR
+
+IMQUOTE ERROR
+RERR: ENTRY
+ PUSH P,[-1] ;PRINT ERROR FLAG
+
+ER1: MOVE B,IMQUOTE INCHAN
+ PUSHJ P,ILVAL ; CHECK INPUT CHANNEL IS SOME KIND OF TTY
+ GETYP A,A
+ CAIE A,TCHAN ; SKIP IF IT IS A CHANNEL
+ JRST ER2 ; NO, MUST REBIND
+ CAMN B,TTICHN+1
+ JRST NOTINC
+ER2: MOVE B,IMQUOTE INCHAN
+ MOVEI C,TTICHN ; POINT TO VALU
+ PUSHJ P,PUSH6 ; PUSH THE BINDING
+ MOVE B,TTICHN+1 ; GET IN CHAN
+NOTINC: SKIPN DEMFLG ; SKIP IF DEMON
+ SKIPE NOTTY
+ JRST NOECHO
+ PUSH TP,$TCHAN
+ PUSH TP,B
+ PUSH TP,$TATOM
+ PUSH TP,IMQUOTE T
+ MCALL 2,TTYECH ; ECHO INPUT
+NOECHO: MOVE B,IMQUOTE OUTCHAN
+ PUSHJ P,ILVAL ; GET THE VALUE
+ GETYP A,A
+ CAIE A,TCHAN ; SKIP IF OK CHANNEL
+ JRST ER3 ; NOT CHANNEL, MUST REBIND
+ CAMN B,TTOCHN+1
+ JRST NOTOUT
+ER3: MOVE B,IMQUOTE OUTCHAN
+ MOVEI C,TTOCHN
+ PUSHJ P,PUSH6 ; PUSH THE BINDINGS
+NOTOUT: MOVE B,IMQUOTE OBLIST
+ PUSHJ P,ILVAL ; GET THE VALUE OF OBLIST
+ PUSHJ P,OBCHK ; IS IT A WINNER ?
+ SKIPA A,$TATOM ; NO, SKIP AND CONTINUE
+ JRST NOTOBL ; YES, DO NOT DO REBINDING
+ MOVE B,IMQUOTE OBLIST
+ PUSHJ P,IGLOC
+ GETYP 0,A
+ CAIN 0,TUNBOU
+ JRST MAKOB ; NO GLOBAL OBLIST, MAKE ONE
+ MOVEI C,(B) ; COPY ADDRESS
+ MOVE A,(C) ; GET THE GVAL
+ MOVE B,(C)+1
+ PUSHJ P,OBCHK ; IS IT A WINNER ?
+ JRST MAKOB ; NO, GO MAKE A NEW ONE
+ MOVE B,IMQUOTE OBLIST
+ PUSHJ P,PUSH6
+
+NOTOBL: PUSH TP,[TATOM,,-1] ;FOR BINDING
+ PUSH TP,IMQUOTE LER,[LERR ]INTRUP
+ PUSHJ P,MAKACT
+ HRLI A,TFRAME ; CORRCT TYPE
+ PUSH TP,A
+ PUSH TP,B
+ PUSH TP,[0]
+ PUSH TP,[0]
+ MOVE A,PVSTOR+1 ; GET PROCESS
+ ADD A,[PROCID,,PROCID] ; POINT TO ID (ALSO LEVEL)
+ PUSH TP,BNDV
+ PUSH TP,A
+ MOVE A,PROCID(PVP)
+ ADDI A,1 ; BUMP ERROR LEVEL
+ PUSH TP,A
+ PUSH TP,PROCID+1(PVP)
+ PUSH P,A
+
+ MOVE B,IMQUOTE READ-TABLE
+ PUSHJ P,IGVAL
+ PUSH TP,[TATOM,,-1]
+ PUSH TP,IMQUOTE READ-TABLE
+ GETYP C,A ; TO GVAL OF READ-TABLE ON ERROR AND
+ CAIE C,TVEC ; TOP ERRET'S
+ JRST .+4
+ PUSH TP,A
+ PUSH TP,B
+ JRST .+3
+ PUSH TP,$TUNBOUND
+ PUSH TP,[-1]
+ PUSH TP,[0]
+ PUSH TP,[0]
+
+ PUSHJ P,SPECBIND ;BIND THE CRETANS
+ MOVE A,-1(P) ;RESTORE SWITHC
+ JUMPE A,NOERR ;IF 0, DONT PRINT ERROR MESS
+ PUSH TP,$TATOM
+ PUSH TP,EQUOTE *ERROR*
+ MCALL 0,TERPRI
+ MCALL 1,PRINC ;PRINT THE MESSAGE
+NOERR: MOVE C,AB ;GET A COPY OF AB
+
+ERRLP: JUMPGE C,LEVPRT ;IF NONE, RE-ENTER READ-EVAL-PRINT LOOP
+ PUSH TP,$TAB
+ PUSH TP,C
+ MOVEI B,PRIN1
+ GETYP A,(C) ; GET ARGS TYPE
+ CAIE A,TATOM
+ JRST ERROK
+ MOVE A,1(C) ; GET ATOM
+ HRRO A,2(A)
+ CAME A,[-1,,ERROBL+1]
+ CAMN A,ERROBL+1 ; DONT SKIP IF IN ERROR OBLIST
+ MOVEI B,PRINC ; DONT PRINT TRAILER
+ERROK: PUSH P,B ; SAVE ROUTINE POINTER
+ PUSH TP,(C)
+ PUSH TP,1(C)
+ MCALL 0,TERPRI ; CRLF
+ POP P,B ; GET ROUTINE BACK
+ .MCALL 1,(B)
+ POP TP,C
+ SUB TP,[1,,1]
+ ADD C,[2,,2] ;BUMP SAVED AB
+ JRST ERRLP ;AND CONTINUE
+
+
+LEVPRT: XCT INITFL ;LOAD MUDDLE INIT FILE IF FIRST TIME
+ MCALL 0,TERPRI
+ PUSH TP,$TATOM
+ PUSH TP,EQUOTE [LISTENING-AT-LEVEL ]
+ MCALL 1,PRINC ;PRINT LEVEL
+ PUSH TP,$TFIX ;READY TO PRINT LEVEL
+ HRRZ A,(P) ;GET LEVEL
+ SUB P,[2,,2] ;AND POP STACK
+ PUSH TP,A
+ MCALL 1,PRIN1 ;PRINT WITHOUT SPACES ETC.
+ PUSH TP,$TATOM ;NOW PROCESS
+ PUSH TP,EQUOTE [ PROCESS ]
+ MCALL 1,PRINC ;DONT SLASHIFY SPACES
+ MOVE PVP,PVSTOR+1
+ PUSH TP,PROCID(PVP) ;NOW ID
+ PUSH TP,PROCID+1(PVP)
+ MCALL 1,PRIN1
+ SKIPN C,CURPRI
+ JRST MAINLP
+ PUSH TP,$TFIX
+ PUSH TP,C
+ PUSH TP,$TATOM
+ PUSH TP,EQUOTE [ INT-LEVEL ]
+ MCALL 1,PRINC
+ MCALL 1,PRIN1
+ JRST MAINLP ; FALL INTO MAIN LOOP
+
+\f;ROUTINES FOR ERROR-LISTEN
+
+OBCHK: GETYP 0,A
+ CAIN 0,TOBLS
+ JRST CPOPJ1 ; WIN FOR SINGLE OBLIST
+ CAIE 0,TLIST ; IF LIST, MAKE SURE EACH IS AN OBLIST
+ JRST CPOPJ ; ELSE, LOSE
+
+ JUMPE B,CPOPJ ; NIL ,LOSE
+ PUSH TP,A
+ PUSH TP,B
+ PUSH P,[0] ;FLAG FOR DEFAULT CHECKING
+ MOVEI 0,1000 ; VERY BIG NUMBER FOR CIRCULARITY TEST
+
+OBCHK0: INTGO
+ SOJE 0,OBLOSE ; CIRCULARITY TEST
+ HRRZ B,(TP) ; GET LIST POINTER
+ GETYP A,(B)
+ CAIE A,TOBLS ; SKIP IF WINNER
+ JRST DEFCHK ; CHECK FOR SPECIAL ATOM DEFAULT
+ HRRZ B,(B)
+ MOVEM B,(TP)
+ JUMPN B,OBCHK0
+OBWIN: AOS (P)-1
+OBLOSE: SUB TP,[2,,2]
+ SUB P,[1,,1]
+ POPJ P,
+
+DEFCHK: SKIPN (P) ; BEEN HERE BEFORE ?
+ CAIE A,TATOM ; OR, NOT AN ATOM ?
+ JRST OBLOSE ; YES, LOSE
+ MOVE A,(B)+1
+ CAME A,MQUOTE DEFAULT
+ JRST OBLOSE ; LOSE
+ SETOM (P) ; SET FLAG
+ HRRZ B,(B) ; CHECK FOR END OF LIST
+ MOVEM B,(TP)
+ JUMPN B,OBCHK0 ; NOT THE END, CONTINUE LOOKING
+ JRST OBLOSE ; LOSE FOR DEFAULT AT THE END
+
+
+
+PUSH6: PUSH TP,[TATOM,,-1]
+ PUSH TP,B
+ PUSH TP,(C)
+ PUSH TP,1(C)
+ PUSH TP,[0]
+ PUSH TP,[0]
+ POPJ P,
+
+
+MAKOB: PUSH TP,INITIAL
+ PUSH TP,INITIAL+1
+ PUSH TP,ROOT
+ PUSH TP,ROOT+1
+ MCALL 2,LIST
+ PUSH TP,$TATOM
+ PUSH TP,IMQUOTE OBLIST
+ PUSH TP,A
+ PUSH TP,B
+ MCALL 2,SETG
+ PUSH TP,[TATOM,,-1]
+ PUSH TP,IMQUOTE OBLIST
+ PUSH TP,A
+ PUSH TP,B
+ PUSH TP,[0]
+ PUSH TP,[0]
+ JRST NOTOBL
+\f
+
+;THIS IS IT FOLKS...THE MAIN LOOP. READ, EVAL, PRINT
+
+MAINLP: MOVE A,$TATOM ;KLUDGE BY NDR LIKE ERROR TO LET LOOSER REDEFINE
+ MOVE B,IMQUOTE REP
+ PUSHJ P,ILVAL ;GET ITS LVAL TO SEE IF REDEFINED
+ GETYP C,A
+ CAIE C,TUNBOUND
+ JRST REPCHK
+ MOVE A,$TATOM ;SEE IF IT HAS GVAL SINCE NO LVAL
+ MOVE B,IMQUOTE REP
+ PUSHJ P,IGVAL
+ GETYP C,A
+ CAIN C,TUNBOUN
+ JRST IREPER
+REPCHK: CAIN C,TSUBR
+ CAIE B,REPER
+ JRST .+2
+ JRST IREPER
+REREPE: PUSH TP,A
+ PUSH TP,B
+ GETYP A,-1(TP)
+ PUSHJ P,APLQ
+ JRST ERRREP
+ MCALL 1,APPLY ;LOOSER HAS REDEFINED SO CALL HIS
+ JRST MAINLP
+IREPER: PUSH P,[0] ;INDICATE FALL THROUGH
+ JRST REPERF
+
+ERRREP: PUSH TP,[TATOM,,-1]
+ PUSH TP,IMQUOTE REP
+ PUSH TP,$TSUBR
+ PUSH TP,[REPER]
+ PUSH TP,[0]
+ PUSH TP,[0]
+ PUSHJ P,SPECBIN
+ PUSH TP,$TATOM
+ PUSH TP,EQUOTE NON-APPLICABLE-REP
+ PUSH TP,-11(TP)
+ PUSH TP,-11(TP)
+ MCALL 2,ERROR
+ SUB TP,[6,,6]
+ PUSHJ P,SSPECS
+ JRST REREPE
+
+
+IMFUNCTION REPER,SUBR,REP
+REPER: ENTRY 0
+ PUSH P,[1] ;INDICATE DIRECT CALL
+REPERF: MCALL 0,TERPRI
+ MCALL 0,READ
+ PUSH TP,A
+ PUSH TP,B
+ MOVE B,IMQUOTE L-INS
+ PUSHJ P,ILVAL ; ASSIGNED?
+ GETYP 0,A
+ CAIN 0,TLIST
+
+ PUSHJ P,LSTTOF ; PUT LAST AS FIRST
+ MCALL 0,TERPRI
+ MCALL 1,EVAL
+ MOVE C,IMQUOTE LAST-OUT
+ PUSHJ P,CISET
+ PUSH TP,A
+ PUSH TP,B
+ MOVE B,IMQUOTE L-OUTS
+ PUSHJ P,ILVAL ; ASSIGNED?
+ GETYP 0,A
+ CAIN 0,TLIST
+
+ CAME B,(TP) ; DONT STUFF IT INTO ITSELF
+ JRST STUFIT ; STUFF IT IN
+ GETYP 0,-1(TP)
+ CAIE 0,TLIST ; IF A LIST THE L-OUTS
+STUFIT: PUSHJ P,LSTTOF ; PUT LAST AS FIRST
+ MCALL 1,PRIN1
+ POP P,C ;FLAG FOR FALL THROUGH OR CALL
+ JUMPN C,FINIS ;IN CASE LOOSER CALLED REP
+ JRST MAINLP
+
+LSTTOF: SKIPN A,B
+ POPJ P,
+
+ HRRZ C,(A)
+ JUMPE C,LSTTO2
+ MOVEI D,(C) ; SAVE PTR TO 2ND ELEMENT
+ MOVEI 0,-1 ; LET THE LOSER LOSE (HA HA HA)
+
+LSTTO1: HRRZ C,(C) ; START SCAN
+ JUMPE C,GOTIT
+ HRRZ A,(A)
+ SOJG 0,LSTTO1
+
+GOTIT: HRRZ C,(A)
+ HLLZS (A)
+ CAIE D,(C) ; AVOID CIRCULARITY
+ HRRM D,(C)
+ HRRM C,(B)
+ MOVE D,1(B)
+ MOVEM D,1(C)
+ GETYP D,(B)
+ PUTYP D,(C)
+
+LSTTO2: MOVSI A,TLIST
+ MOVE C,-1(TP)
+ MOVE D,(TP)
+ JRST LSTUF
+\f
+;FUNCTION TO RETRY A PREVIOUS FUNCTION CALL
+
+MFUNCTION RETRY,SUBR
+
+ ENTRY
+ JUMPGE AB,RETRY1 ; USE MOST RECENT
+ CAMGE AB,[-2,,0]
+ JRST TMA
+ GETYP A,(AB) ; CHECK TYPE
+ CAIE A,TFRAME
+ JRST WTYP1
+ MOVEI B,(AB) ; POINT TO ARG
+ JRST RETRY2
+RETRY1: MOVE B,IMQUOTE LER,[LERR ]INTRUP
+ PUSHJ P,ILOC ; LOCATIVE TO FRAME
+RETRY2: PUSHJ P,CHFSWP ; CHECK VALIDITY AND SWAP IF NECESSARY
+ HRRZ 0,OTBSAV(B) ; CHECK FOR TOP
+ JUMPE 0,RESTAR ; YES RE-ENTER TOP LEVEL
+ PUSH TP,$TTB
+ PUSH TP,B ; SAVE FRAME
+ MOVE B,OTBSAV(B) ; GET PRVIOUS FOR UNBIND HACK
+ MOVEI C,-1(TP)
+ PUSHJ P,CHUNW ; CHECK ANY UNWINDING
+ CAME SP,SPSAV(TB) ; UNBINDING NEEDED?
+ PUSHJ P,SPECSTORE
+ MOVE P,PSAV(TB) ; GET OTHER STUFF
+ MOVE AB,ABSAV(B)
+ HLRE A,AB ; COMPUTE # OF ARGS
+ MOVNI A,-FRAMLN(A) ; MAKE TP POINT PAST FRAME
+ HRLI A,(A)
+ MOVE C,TPSAV(TB) ; COMPUTE TP
+ ADD C,A
+ MOVE TP,C
+ MOVE TB,B ; FIX UP TB
+ HRRZ C,FSAV(TB) ; GET FUNCTION
+ CAIL C,HIBOT
+ JRST (C) ; GO
+ GETYP 0,(C) ; RSUBR OR ENTRY?
+ CAIE 0,TATOM
+ CAIN 0,TRSUBR
+ JRST RETRNT
+ MOVS R,(C) ; SET UP R
+ HRRI R,(C)
+ MOVEI C,0
+ JRST RETRN3
+
+RETRNT: CAIE 0,TRSUBR
+ JRST RETRN1
+ MOVE R,1(C)
+RETRN4: HRRZ C,2(C) ; OFFSET
+RETRN3: SKIPL M,1(R)
+ JRST RETRN5
+RETRN7: ADDI C,(M)
+ JRST (C)
+
+RETRN5: MOVEI D,(M) ; TOTAL OFFSET
+ MOVSS M
+ ADD M,PURVEC+1
+ SKIPL M,1(M)
+ JRST RETRN6
+ ADDI M,(D)
+ JRST RETRN7
+
+RETRN6: HLRZ A,1(R)
+ PUSH P,D
+ PUSH P,C
+ PUSHJ P,PLOAD
+ JRST RETRER ; LOSER
+ POP P,C
+ POP P,D
+ MOVE M,B
+ JRST RETRN7
+
+RETRN1: HRL C,(C) ; FIX LH
+ MOVE B,1(C)
+ PUSH TP,$TVEC
+ PUSH TP,C
+ PUSHJ P,IGVAL
+ GETYP 0,A
+ MOVE C,(TP)
+ SUB TP,[2,,2]
+ CAIE 0,TRSUBR
+ JRST RETRN2
+ MOVE R,B
+ JRST RETRN4
+
+RETRN2: ERRUUO EQUOTE CANT-RETRY-ENTRY-GONE
+
+RETRER: ERRUUO EQUOTE PURE-LOAD-FAILURE
+
+\f
+;FUNCTION TO DO ERROR RETURN
+
+IMFUNCTION ERRET,SUBR
+
+ ENTRY
+ HLRE A,AB ; -2*# OF ARGS
+ JUMPGE A,STP ; RESTART PROCESS
+ ASH A,-1 ; -# OF ARGS
+ AOJE A,ERRET2 ; NO FRAME SUPPLIED
+ AOJL A,TMA
+ ADD AB,[2,,2]
+ PUSHJ P,OKFRT
+ JRST WTYP2
+ SUB AB,[2,,2]
+ PUSHJ P,CHPROC ; POINT TO FRAME SLOT
+ JRST ERRET3
+ERRET2: MOVE B,IMQUOTE LER,[LERR ]INTRUP
+ PUSHJ P,ILVAL ; GET ITS VALUE
+ERRET3: PUSH TP,A
+ PUSH TP,B
+ MOVEI B,-1(TP)
+ PUSHJ P,CHFSWP ; CHECK VALIDITY AND SWAP IF NECESSARY
+ HRRZ 0,OTBSAV(B) ; TOP LEVEL?
+ JUMPE 0,TOPLOS
+ PUSHJ P,CHUNW ; ANY UNWINDING
+ JRST CHFINIS
+
+
+; FUNCTION TO RETURN LAST ERROR FRAME OR PREVIOUS FRAME
+
+IMFUNCTION FRAME,SUBR
+ ENTRY
+ SETZB A,B
+ JUMPGE AB,FRM1 ; DEFAULT CASE
+ CAMG AB,[-3,,0] ; SKIP IF OK ARGS
+ JRST TMA
+ PUSHJ P,OKFRT ; A FRAME OR SIMILAR THING?
+ JRST WTYP1
+
+FRM1: PUSHJ P,CFRAME ; GO TO INTERNAL
+ JRST FINIS
+
+CFRAME: JUMPN A,FRM2 ; ARG SUPPLIED?
+ MOVE B,IMQUOTE LER,[LERR ]INTRUP
+ PUSHJ P,ILVAL
+ JRST FRM3
+FRM2: PUSHJ P,CHPROC ; CHECK FOR PROCESS
+ PUSH TP,A
+ PUSH TP,B
+ MOVEI B,-1(TP) ; POINT TO SLOT
+ PUSHJ P,CHFRM ; CHECK IT
+ MOVE C,(TP) ; GET FRAME BACK
+ MOVE B,OTBSAV(C) ;GET PREVIOUS FRAME
+ SUB TP,[2,,2]
+ TRNN B,-1 ; SKIP IF OK
+ JRST TOPLOSE
+
+FRM3: JUMPN B,FRM4 ; JUMP IF WINNER
+ MOVE B,IMQUOTE THIS-PROCESS
+ PUSHJ P,ILVAL ; GET PROCESS OF INTEREST
+ GETYP A,A ; CHECK IT
+ CAIN A,TUNBOU
+ MOVE B,PVSTOR+1 ; USE CURRENT
+ MOVEI A,PVLNT*2+1(B) ; POINT TO DOPE WORDS
+ MOVE B,TBINIT+1(B) ; AND BASE FRAME
+FRM4: HLL B,OTBSAV(B) ;TIME
+ HRLI A,TFRAME
+ POPJ P,
+
+OKFRT: AOS (P) ;ASSUME WINNAGE
+ GETYP 0,(AB)
+ MOVE A,(AB)
+ MOVE B,1(AB)
+ CAIE 0,TFRAME
+ CAIN 0,TENV
+ POPJ P,
+ CAIE 0,TPVP
+ CAIN 0,TACT
+ POPJ P,
+ SOS (P)
+ POPJ P,
+
+CHPROC: GETYP 0,A ; TYPE
+ CAIE 0,TPVP
+ POPJ P, ; OK
+ MOVEI A,PVLNT*2+1(B)
+ CAMN B,PVSTOR+1 ; THIS PROCESS?
+ JRST CHPRO1
+ MOVE B,TBSTO+1(B)
+ JRST FRM4
+
+CHPRO1: MOVE B,OTBSAV(TB)
+ JRST FRM4
+
+; FUNCTION TO RETURN ARGS TUPLE FOR A FRAME
+
+MFUNCTION ARGS,SUBR
+ ENTRY 1
+ PUSHJ P,OKFRT ; CHECK FRAME TYPE
+ JRST WTYP1
+ PUSHJ P,CARGS
+ JRST FINIS
+
+CARGS: PUSHJ P,CHPROC
+ PUSH TP,A
+ PUSH TP,B
+ MOVEI B,-1(TP) ; POINT TO FRAME SLOT
+ PUSHJ P,CHFRM ; AND CHECK FOR VALIDITY
+ MOVE C,(TP) ; FRAME BACK
+ MOVSI A,TARGS
+CARGS1: GETYP 0,FSAV(C) ; IS THIS A FUNNY ONE
+ CAIE 0,TCBLK ; SKIP IF FUNNY
+ JRST .+3 ; NO NORMAL
+ MOVE C,OTBSAV(C) ; ASSOCIATE WITH PREVIOUS FRAME
+ JRST CARGS1
+ HLR A,OTBSAV(C) ; TIME IT AND
+ MOVE B,ABSAV(C) ; GET POINTER
+ SUB TP,[2,,2] ; FLUSH CRAP
+ POPJ P,
+
+; FUNCTION TO RETURN FUNCTION ASSOCIATED WITH A FRAME
+
+MFUNCTION FUNCT,SUBR
+ ENTRY 1 ; FRAME ARGUMENT
+ PUSHJ P,OKFRT ; CHECK TYPE
+ JRST WTYP1
+ PUSHJ P,CFUNCT
+ JRST FINIS
+
+CFUNCT: PUSHJ P,CHPROC
+ PUSH TP,A
+ PUSH TP,B
+ MOVEI B,-1(TP)
+ PUSHJ P,CHFRM ; CHECK IT
+ MOVE C,(TP) ; RESTORE FRAME
+ HRRZ A,FSAV(C) ;FUNCTION POINTER
+ CAIL A,HIBOT
+ SKIPA B,@-1(A) ;NO, GET SUBR'S NAME POINTER
+ MOVE B,(A)+3 ;YES, GET RSUBR'S NAME ENTRY
+ MOVSI A,TATOM
+ SUB TP,[2,,2]
+ POPJ P,
+
+BADFRAME:
+ ERRUUO EQUOTE FRAME-NO-LONGER-EXISTS
+
+
+TOPLOSE:
+ ERRUUO EQUOTE TOP-LEVEL-FRAME
+
+
+\f
+\f
+; ROUTINE TO HANG INDEFINITELY WITH INTERRUPTS ENABLED
+
+MFUNCTION HANG,SUBR
+
+ ENTRY
+
+ JUMPGE AB,HANG1 ; NO PREDICATE
+ CAMGE AB,[-3,,]
+ JRST TMA
+REHANG: MOVE A,[PUSHJ P,CHKPRH]
+ MOVEM A,ONINT ; CHECK PREDICATE AFTER ANY INTERRUPT
+ PUSH TP,(AB)
+ PUSH TP,1(AB)
+HANG1: ENABLE ;LET OURSELVES BE INTERRUPTED OUT
+ PUSHJ P,%HANG
+ DISABLE ;PREVENT INTERRUPTS AT RANDOM TIMES
+ SETZM ONINT
+ MOVE A,$TATOM
+ MOVE B,IMQUOTE T
+ JRST FINIS
+
+
+; ROUTINE TO SLEEP FOR POSITIVE NUMBER OF SECONDS WITH INTERRUPTS ENABLED
+; ARGUMENT SHOULD BE OF TYPE FIX OR FLOAT AND NON-NEGATIVE
+
+MFUNCTION SLEEP,SUBR
+
+ ENTRY
+
+ JUMPGE AB,TFA
+ CAML AB,[-3,,]
+ JRST SLEEP1
+ CAMGE AB,[-5,,]
+ JRST TMA
+ PUSH TP,2(AB)
+ PUSH TP,3(AB)
+SLEEP1: GETYP 0,(AB)
+ CAIE 0,TFIX
+ JRST .+5
+ MOVE B,1(AB)
+ JUMPL B,OUTRNG ;ARG SHOULDNT BE NEGATIVE
+ IMULI B,30. ;CONVERT TO # OF THIRTIETHS OF A SECOND
+ JRST SLEEPR ;GO SLEEP
+ CAIE 0,TFLOAT ;IF IT WASNT FIX MAKE SURE IT IS FLOAT
+ JRST WTYP1 ;WRONG TYPE ARG
+ MOVE B,1(AB)
+ FMPR B,[30.0] ;CONVERT TO FLOATING # OF THIRTIETHS OF A SECOND
+ MULI B,400 ;KLUDGE TO FIX IT
+ TSC B,B
+ ASH C,(B)-243
+ MOVE B,C ;MOVE THE FIXED NUMBER INTO B
+ JUMPL B,OUTRNG ;CHECK TO SEE THAT WE HAVE POSITIVE NUMBER
+SLEEPR: MOVE A,B
+RESLEE: MOVE B,[PUSHJ P,CHKPRS]
+ CAMGE AB,[-3,,]
+ MOVEM B,ONINT
+ ENABLE
+ PUSHJ P,%SLEEP
+ DISABLE
+ SETZM ONINT
+ MOVE A,$TATOM
+ MOVE B,IMQUOTE T
+ JRST FINIS
+
+CHKPRH: PUSH P,B
+ MOVEI B,HANGP
+ JRST .+3
+
+CHKPRS: PUSH P,B
+ MOVEI B,SLEEPP
+ HRRM B,LCKINT
+ SETZM ONINT ; TURN OFF FEATURE FOR NOW
+ POP P,B
+ POPJ P,
+
+HANGP: SKIPA B,[REHANG]
+SLEEPP: MOVEI B,RESLEE
+ PUSH P,B
+ PUSH P,A
+ DISABLE
+ PUSH TP,(TB)
+ PUSH TP,1(TB)
+ MCALL 1,EVAL
+ GETYP 0,A
+ CAIE 0,TFALSE
+ JRST FINIS
+ POP P,A
+ POPJ P,
+
+MFUNCTION VALRET,SUBR
+; SUBR TO VALRET A STRING TO SUPERIOR ITS PROCESS
+
+ ENTRY 1
+ GETYP A,(AB) ; GET TYPE OF ARGUMENT
+ CAIN A,TFIX ; FIX?
+ JRST VALRT1
+ CAIE A,TCHSTR ; IS IT A CHR STRING?
+ JRST WTYP1 ; NO...ERROR WRONG TYPE
+ PUSHJ P,CSTACK ; COPY THE CHR STRING TO THE STACK
+ ; CSTACK IS IN ATOMHK
+ MOVEI B,0 ; ASCIZ TERMINATOR
+ EXCH B,(P) ; STORE AND RETRIEVE COUNT
+
+; CALCULATE THE BEGINNING ADDR OF THE STRING
+ MOVEI A,-1(P) ; GET ADDR OF TOP OF STACK
+ SUBI A,-1(B) ; GET STARTING ADDR
+ PUSHJ P,%VALRE ; PASS UP TO MONITOR
+ JRST IFALSE ; IF HE RETURNS, RETURN FALSE
+
+VALRT1: MOVE A,1(AB)
+ PUSHJ P,%VALFI
+ JRST IFALSE
+
+MFUNCTION LOGOUT,SUBR
+
+; SUBR TO DO A .LOGOUT (VALID ONLY AT TOP LEVEL)
+ ENTRY 0
+ PUSHJ P,%TOPLQ ; SKIP IF AT TOP LEVEL
+ JRST IFALSE
+ PUSHJ P,CLOSAL
+ PUSHJ P,%LOGOUT ; TRY TO FLUSH
+ JRST IFALSE ; COULDN'T DO IT...RETURN FALSE
+
+; FUNCTS TO GET UNAME AND JNAME
+
+; GET XUNAME (REAL UNAME)
+MFUNCTION XUNAME,SUBR
+
+ ENTRY 0
+
+ PUSHJ P,%RXUNA
+ JRST RSUJNM
+ JRST FINIS ; 10X ROUTINES SKIP
+
+MFUNCTION UNAME,SUBR
+
+ ENTRY 0
+
+ PUSHJ P,%RUNAM
+ JRST RSUJNM
+ JRST FINIS
+
+; REAL JNAME
+MFUNCTION XJNAME,SUBR
+
+ ENTRY 0
+
+ PUSHJ P,%RXJNA
+ JRST RSUJNM
+
+MFUNCTION JNAME,SUBR
+
+ ENTRY 0
+
+ PUSHJ P,%RJNAM
+ JRST RSUJNM
+
+; FUNCTION TO SET AND READ GLOBAL SNAME
+
+MFUNCTION SNAME,SUBR
+
+ ENTRY
+
+ JUMPGE AB,SNAME1
+ CAMG AB,[-3,,]
+ JRST TMA
+ GETYP A,(AB) ; ARG MUST BE STRING
+ CAIE A,TCHSTR
+ JRST WTYP1
+ PUSH TP,$TATOM
+ PUSH TP,IMQUOTE SNM
+ PUSH TP,(AB)
+ PUSH TP,1(AB)
+ MCALL 2,SETG
+ JRST FINIS
+
+SNAME1: MOVE B,IMQUOTE SNM
+ PUSHJ P,IDVAL1
+ GETYP 0,A
+ CAIN 0,TCHSTR
+ JRST FINIS
+ MOVE A,$TCHSTR
+ MOVE B,CHQUOTE
+ JRST FINIS
+
+RSUJNM: PUSHJ P,6TOCHS ; CONVERT IT
+ JRST FINIS
+
+
+SGSNAM: MOVE B,IMQUOTE SNM
+ PUSHJ P,IDVAL1
+ GETYP 0,A
+ CAIE 0,TCHSTR
+ JRST SGSN1
+
+ PUSH TP,A
+ PUSH TP,B
+ PUSHJ P,STRTO6
+ POP P,A
+ SUB TP,[2,,2]
+ JRST .+2
+
+SGSN1: MOVEI A,0
+ PUSHJ P,%SSNAM ; SET SNAME IN SYSTEM
+ POPJ P,
+
+\f
+
+;THIS SUBROUTINE ALLOCATES A NEW PROCESS
+;TAKES TP-STACK SIZE (2*WORDS) IN A AND P-STACK SIZE (WORDS) IN B
+;IS CALLED BY PUSHJ P,. RETURNS IN A AND B A NEW PROCESS.
+
+ICR: PUSH P,A
+ PUSH P,B
+ MOVEI A,PVLNT ;SETUP CALL TO VECTOR FOR PVP
+ PUSHJ P,IVECT ;GOBBLE A VECTOR
+ HRLI C,PVBASE ;SETUP A BLT POINTER
+ HRRI C,(B) ;GET INTO ADDRESS
+ BLT C,PVLNT*2-1(B) ;COPY A PROTOTYPE INTO NEW PVP
+ MOVSI C,400000+SPVP+.VECT. ;SET SPECIAL TYPE
+ MOVEM C,PVLNT*2(B) ;CLOBBER IT IN
+ PUSH TP,A ;SAVE THE RESULTS OF VECTOR
+ PUSH TP,B
+
+ PUSH TP,$TFIX ;GET A UNIFORM VECTOR
+ POP P,B
+ PUSH TP,B
+ MCALL 1,UVECTOR
+ ADD B,[PDLBUF-2,,-1] ;FUDGE WITH BUFFER
+ MOVE C,(TP) ;REGOBBLE PROCESS POINTER
+ MOVEM B,PSTO+1(C) ;STORE IN ALL HOMES
+ MOVEM B,PBASE+1(C)
+
+
+ POP P,A ;PREPARE TO CREATE A TEMPORARY PDL
+ PUSHJ P,IVECT ;GET THE TEMP PDL
+ ADD B,[PDLBUF,,0] ;PDL GROWTH HACK
+ MOVE C,(TP) ;RE-GOBBLE NEW PVP
+ SUB B,[1,,1] ;FIX FOR STACK
+ MOVEM B,TPBASE+1(C)
+
+;SETUP INITIAL BINDING
+
+ PUSH B,$TBIND
+ MOVEM B,SPBASE+1(C) ;SAVE AS BASE OF SP
+ MOVEM B,SPSTO+1(C) ;AND CURRENT THEREOF
+ MOVEM B,CURFCN+1(C) ; AND AS CURRENT FCN FOR SPEC/UNSPEC LOGIC
+ PUSH B,IMQUOTE THIS-PROCESS
+ PUSH B,$TPVP ;GIVE IT PROCESS AS VALUE
+ PUSH B,C
+ ADD B,[2,,2] ;FINISH FRAME
+ MOVEM B,TPSTO+1(C) ;MAKE THIS THE CURRENT STACK POINTER
+ MOVEM C,PVPSTO+1(C) ;SAVE THE NEW PVP ITSELF
+ AOS A,IDPROC ;GOBBLE A UNIQUE PROCESS I.D.
+ MOVEM A,PROCID+1(C) ;SAVE THAT ALSO
+ AOS A,PTIME ; GET A UNIQUE BINDING ID
+ MOVEM A,BINDID+1(C)
+
+ MOVSI A,TPVP ;CLOBBER THE TYPE
+ MOVE B,(TP) ;AND POINTER TO PROCESS
+ SUB TP,[2,,2]
+ POPJ P,
+
+;MINI ROUTINE TO CALL VECTOR WITH COUNT IN A
+
+IVECT: PUSH TP,$TFIX
+ PUSH TP,A
+ MCALL 1,VECTOR ;GOBBLE THE VECTOR
+ POPJ P,
+
+
+;SUBROUTINE TO SWAP A PROCESS IN
+;CALLED WITH JSP A,SWAP AND NEW PVP IN B
+
+SWAP: ;FIRST STORE ALL THE ACS
+
+ MOVE PVP,PVSTOR+1
+ MOVE SP,$TSP ; STORE SPSAVE
+ MOVEM SP,SPSTO(PVP)
+ MOVE SP,SPSTOR+1
+ IRP A,,[SP,AB,TB,TP,P,M,R,FRM]
+ MOVEM A,A!STO+1(PVP)
+ TERMIN
+
+ SETOM 1(TP) ; FENCE POST MAIN STACK
+ MOVEM TP,TPSAV(TB) ; CORRECT FRAME
+ SETZM PSAV(TB) ; CLEAN UP CURRENT FRAME
+ SETZM SPSAV(TB)
+ SETZM PCSAV(TB)
+
+ MOVE E,PVP ;RETURN OLD PROCESS IN E
+ MOVE PVP,D ;AND MAKE NEW ONE BE D
+ MOVEM PVP,PVSTOR+1
+
+SWAPIN:
+ ;NOW RESTORE NEW PROCESSES AC'S
+
+ MOVE PVP,PVSTOR+1
+ IRP A,,[AB,TB,SP,TP,P,M,R,FRM]
+ MOVE A,A!STO+1(PVP)
+ TERMIN
+
+ SETZM SPSTO(PVP)
+ MOVEM SP,SPSTOR+1
+ JRST (C) ;AND RETURN
+
+
+\f
+
+;SUBRS ASSOCIATED WITH TYPES
+
+;TYPE (ITYPE) ARE FUNCTIONS TO RETURN THE ATOMIC NAME OF THE
+;TYPE OF A GOODIE. TYPE TAKES ITS ARGS ON AP AND RETURNS IN A AND B.
+;ITYPE TAKES ITS ARGS IN A AND B AND RETURNS IN SAME (B=0) FOR INVALID
+;TYPECODE.
+MFUNCTION TYPE,SUBR
+
+ ENTRY 1
+ GETYP A,(AB) ;TYPE INTO A
+TYPE1: PUSHJ P,ITYPE ;GO TO INTERNAL
+ JUMPN B,FINIS ;GOOD RETURN
+TYPERR: ERRUUO EQUOTE TYPE-UNDEFINED
+
+CITYPE: GETYP A,A ; GET TYPE FOR COMPILER CALL
+ITYPE: LSH A,1 ;TIMES 2
+ HRLS A ;TO BOTH SIDES
+ ADD A,TYPVEC+1 ;GET ACTUAL LOCATION
+ JUMPGE A,TYPERR ;LOST, TYPE OUT OF BOUNDS
+ MOVE B,1(A) ;PICKUP TYPE
+ HLLZ A,(A)
+ POPJ P,
+
+; PREDICATE -- IS OBJECT OF TYPE SPECIFIED
+
+MFUNCTION %TYPEQ,SUBR,[TYPE?]
+
+ ENTRY
+
+ MOVE D,AB ; GET ARGS
+ ADD D,[2,,2]
+ JUMPGE D,TFA
+ MOVE A,(AB)
+ HLRE C,D
+ MOVMS C
+ ASH C,-1 ; FUDGE
+ PUSHJ P,ITYPQ ; GO INTERNAL
+ JFCL
+ JRST FINIS
+
+ITYPQ: GETYP A,A ; OBJECT
+ PUSHJ P,ITYPE
+TYPEQ0: SOJL C,CIFALS
+ GETYP 0,(D)
+ CAIE 0,TATOM ; Type name must be an atom
+ JRST WRONGT
+ CAMN B,1(D) ; Same as the OBJECT?
+ JRST CPOPJ1 ; Yes, return type name
+ ADD D,[2,,2]
+ JRST TYPEQ0 ; No, continue comparing
+
+CIFALS: MOVEI B,0
+ MOVSI A,TFALSE
+ POPJ P,
+
+CTYPEQ: SOJE A,CIFALS ; TREAT NO ARGS AS FALSE
+ MOVEI D,1(A) ; FIND BASE OF ARGS
+ ASH D,1
+ HRLI D,(D)
+ SUBM TP,D ; D POINTS TO BASE
+ MOVE E,D ; SAVE FOR TP RESTORE
+ ADD D,[3,,3] ; FUDGE
+ MOVEI C,(A) ; NUMBER OF TYPES
+ MOVE A,-2(D)
+ PUSHJ P,ITYPQ
+ JFCL ; IGNORE SKIP FOR NOW
+ MOVE TP,E ; SET TP BACK
+ JUMPL B,CPOPJ1 ; SKIP
+ POPJ P,
+\f
+; Entries to get type codes for types for fixing up RSUBRs and assembling
+
+MFUNCTION %TYPEC,SUBR,[TYPE-C]
+
+ ENTRY
+
+ JUMPGE AB,TFA
+ GETYP 0,(AB)
+ CAIE 0,TATOM
+ JRST WTYP1
+ MOVE B,1(AB)
+ CAMGE AB,[-3,,0] ; skip if only type name given
+ JRST GTPTYP
+ MOVE C,IMQUOTE ANY
+
+TYPEC1: PUSHJ P,CTYPEC ; go to internal
+ JRST FINIS
+
+GTPTYP: CAMGE AB,[-5,,0]
+ JRST TMA
+ GETYP 0,2(AB)
+ CAIE 0,TATOM
+ JRST WTYP2
+ MOVE C,3(AB)
+ JRST TYPEC1
+
+CTYPEC: PUSH P,C ; save primtype checker
+ PUSHJ P,TYPFND ; search type vector
+ JRST CTPEC2 ; create the poor loser
+ POP P,B
+ CAMN B,IMQUOTE ANY
+ JRST CTPEC1
+ CAMN B,IMQUOTE TEMPLATE
+ JRST TCHK
+ PUSH P,D
+ HRRZ A,(A)
+ ANDI A,SATMSK
+ PUSH P,A
+ PUSHJ P,TYPLOO
+ HRRZ 0,(A)
+ ANDI 0,SATMSK
+ CAME 0,(P)
+ JRST TYPDIF
+ MOVE D,-1(P)
+ SUB P,[2,,2]
+CTPEC1: MOVEI B,(D)
+ MOVSI A,TTYPEC
+ POPJ P,
+TCHK: PUSH P,D ; SAVE TYPE
+ MOVE A,D ; GO TO SAT
+ PUSHJ P,SAT
+ CAIG A,NUMSAT ; SKIP IF A TEMPLATE
+ JRST TYPDIF
+ POP P,D ; RESTORE TYPE
+ JRST CTPEC1
+
+CTPEC2: POP P,C ; GET BACK PRIMTYPE
+ SUBM M,(P)
+ PUSH TP,$TATOM
+ PUSH TP,B
+ CAMN C,IMQUOTE ANY
+ JRST CTPEC3
+ PUSH TP,$TATOM
+ PUSH TP,C
+ MCALL 2,NEWTYPE ; CREATE THE POOR GUY
+ MOVE C,IMQUOTE ANY
+ SUBM M,(P) ; UNRELATIVIZE
+ JRST CTYPEC
+
+CTPEC3: HRRZ 0,FSAV(TB)
+ CAIE 0,%TYPEC
+ CAIN 0,%TYPEW
+ JRST TYPERR
+
+ MCALL 1,%TYPEC
+ JRST MPOPJ
+
+MFUNCTION %TYPEW,SUBR,[TYPE-W]
+
+ ENTRY
+
+ JUMPGE AB,TFA
+ GETYP 0,(AB)
+ CAIE 0,TATOM
+ JRST WTYP1
+ MOVEI D,0
+ MOVE C,IMQUOTE ANY
+ MOVE B,1(AB)
+ CAMGE AB,[-3,,0]
+ JRST CTYPW1
+
+CTYPW3: PUSHJ P,CTYPEW
+ JRST FINIS
+
+CTYPW1: GETYP 0,2(AB)
+ CAIE 0,TATOM
+ JRST WTYP2
+ CAMGE AB,[-5,,0] ; JUMP IF RH IS GIVEN
+ JRST CTYPW2
+CTYPW5: MOVE C,3(AB)
+ JRST CTYPW3
+
+CTYPW2: CAMGE AB,[-7,,0]
+ JRST TMA
+ GETYP 0,4(AB)
+ CAIE 0,TFIX
+ JRST WRONGT
+ MOVE D,5(AB)
+ JRST CTYPW5
+
+CTYPEW: PUSH P,D
+ PUSHJ P,CTYPEC ; GET CODE IN B
+ POP P,B
+ HRLI B,(D)
+ MOVSI A,TTYPEW
+ POPJ P,
+
+MFUNCTION %VTYPE,SUBR,[VALID-TYPE?]
+
+ ENTRY 1
+
+ GETYP 0,(AB)
+ CAIE 0,TATOM
+ JRST WTYP1
+ MOVE B,1(AB)
+
+ PUSHJ P,CVTYPE
+ JFCL
+ JRST FINIS
+
+CVTYPE: PUSHJ P,TYPFND ; LOOK IT UP
+ JRST PFALS
+
+ MOVEI B,(D)
+ MOVSI A,TTYPEC
+ JRST CPOPJ1
+
+PFALS: MOVEI B,0
+ MOVSI A,TFALSE
+ POPJ P,
+\f
+;PRIMTTYPE RETURNS THE TYPE ATOM OF A PRIMITIVE TYPE IN A CLASS
+
+STBL: REPEAT NUMSAT,SETZ MQUOTE INTERNAL-TYPE
+
+LOC STBL
+
+IRP A,,[[1WORD,WORD],[2WORD,LIST],[NWORD,UVECTOR],[2NWORD,VECTOR],[STORE,STORAGE]
+[ARGS,TUPLE],[FRAME,FRAME],[ATOM,ATOM],[LOCID,LOCD],[CHSTR,STRING],[OFFS,OFFSET,1]
+[PVP,PROCESS,1],[ASOC,ASOC,1],[LOCA,LOCA],[LOCS,LOCS],[LOCU,LOCU],[LOCV,LOCV]
+[LOCL,LOCL],[LOCN,LOCAS],[LOCT,LOCT,1],[LOCR,LOCR],[LOCB,LOCB,1],[BYTE,BYTES,1]]
+IRP B,C,[A]
+LOC STBL+S!B
+IRP X,Y,[C]
+IFSE [Y],SETZ IMQUOTE X
+IFSN [Y],SETZ MQUOTE X
+.ISTOP
+TERMIN
+.ISTOP
+
+TERMIN
+TERMIN
+
+LOC STBL+NUMSAT+1
+
+
+MFUNCTION TYPEPRIM,SUBR
+
+ ENTRY 1
+ GETYP A,(AB)
+ CAIE A,TATOM
+ JRST NOTATOM
+ MOVE B,1(AB)
+ PUSHJ P,CTYPEP
+ JRST FINIS
+
+CTYPEP: PUSHJ P,TYPLOO ; CONVERT ATOM TO CODE
+ HRRZ A,(A) ; SAT TO A
+ ANDI A,SATMSK
+ JRST PTYP1
+
+MFUNCTION PTSATC,SUBR,[PRIMTYPE-C]
+
+ ENTRY 1
+
+ GETYP A,(AB)
+ CAIE A,TATOM
+ JRST WTYP1
+ MOVE B,1(AB)
+ PUSHJ P,CPRTYC
+ JRST FINIS
+
+CPRTYC: PUSHJ P,TYPLOO
+ MOVE B,(A)
+ ANDI B,SATMSK
+ MOVSI A,TSATC
+ POPJ P,
+
+
+IMFUNCTION PRIMTYPE,SUBR
+
+ ENTRY 1
+
+ MOVE A,(AB) ;GET TYPE
+ PUSHJ P,CPTYPE
+ JRST FINIS
+
+CPTYPE: GETYP A,A
+ PUSHJ P,SAT ;GET SAT
+PTYP1: JUMPE A,TYPERR
+ MOVE B,IMQUOTE TEMPLATE
+ CAIG A,NUMSAT ; IF BIG SAT, THEN TEMPLATE
+ MOVE B,@STBL(A)
+ MOVSI A,TATOM
+ POPJ P,
+\f
+
+; RSUBR MAKES A VECTOR INTO AN OBJECT OF TYPE RSUBR, ALSO SLIGHTLY MUNGING IT
+
+IMFUNCTION RSUBR,SUBR
+ ENTRY 1
+
+ GETYP A,(AB)
+ CAIE A,TVEC ; MUST BE VECTOR
+ JRST WTYP1
+ MOVE B,1(AB) ; GET IT
+ GETYP A,(B) ; CHECK 1ST ELEMENTS TYPE
+ CAIN A,TPCODE ; PURE CODE
+ JRST .+3
+ CAIE A,TCODE
+ JRST NRSUBR
+ HLRM B,(B) ; CLOBEER SPECIAL COUNT FIELD
+ MOVSI A,TRSUBR
+ JRST FINIS
+
+NRSUBR: ERRUUO EQUOTE FIRST-ELEMENT-OF-VECTOR-NOT-CODE
+
+; ROUTINE TO GENERATE ENTRYY OTHER THAN FIRST TO RSUBRR
+
+IMFUNCTION MENTRY,SUBR,[RSUBR-ENTRY]
+
+ ENTRY 2
+
+ GETYP 0,(AB) ; TYPE OF ARG
+ CAIE 0,TVEC ; BETTER BE VECTOR
+ JRST WTYP1
+ GETYP 0,2(AB)
+ CAIE 0,TFIX
+ JRST WTYP2
+ MOVE B,1(AB) ; GET VECTOR
+ CAML B,[-3,,0]
+ JRST BENTRY
+ GETYP 0,(B) ; FIRST ELEMENT
+ CAIE 0,TRSUBR
+ JRST MENTR1
+MENTR2: GETYP 0,2(B)
+ CAIE 0,TATOM
+ JRST BENTRY
+ MOVE C,3(AB)
+ HRRM C,2(B) ; OFFSET INTO VECTOR
+ HLRM B,(B)
+ MOVSI A,TENTER
+ JRST FINIS
+
+MENTR1: CAIE 0,TATOM
+ JRST BENTRY
+ MOVE B,1(B) ; GET ATOM
+ PUSHJ P,IGVAL ; GET VAL
+ GETYP 0,A
+ CAIE 0,TRSUBR
+ JRST BENTRY
+ MOVE C,1(AB) ; RESTORE B
+ MOVEM A,(C)
+ MOVEM B,1(C)
+ MOVE B,C
+ JRST MENTR2
+
+BENTRY: ERRUUO EQUOTE BAD-VECTOR
+
+; SUBR TO GET ENTRIES OFFSET
+
+MFUNCTION LENTRY,SUBR,[ENTRY-LOC]
+
+ ENTRY 1
+
+ GETYP 0,(AB)
+ CAIE 0,TENTER
+ JRST WTYP1
+ MOVE B,1(AB)
+ HRRZ B,2(B)
+ MOVSI A,TFIX
+ JRST FINIS
+
+; RETURN FALSE
+
+RTFALS: MOVSI A,TFALSE
+ MOVEI B,0
+ POPJ P,
+
+;SUBROUTINE CALL FOR RSUBRs
+RCALL: SUBM M,(P) ;CALCULATE PC's OFFSET IN THE RSUBR
+ HRLI 0,400000 ; DONT LOSE IN MULTI SEG MODE
+
+ PUSHJ P,@0 ;GO TO THE PROPER SUBROUTINE
+ SUBM M,(P) ;RECONSTITUTE THE RSUBR's PC
+ POPJ P,
+
+
+
+;CHTYPE TAKES TWO ARGUMENTS. ANY GOODIE AND A AN ATOMIC TYPE NAME
+;IT CHECKS THE STORAGE ALLOCATION TYPES OF THE TWO ARE THE SAME AND
+;IF THEY ARE CHANGES THE TYPE OF THE FIRST TO THAT NAME D IN THE SECOND
+
+MFUNCTION CHTYPE,SUBR
+
+ ENTRY 2
+ GETYP A,2(AB) ;FIRST CHECK THAT ARG 2 IS AN ATOM
+ CAIE A,TATOM
+ JRST NOTATOM
+ MOVE B,3(AB) ;AND TYPE NAME
+ PUSHJ P,TYPLOO ;GO LOOKUP TYPE
+TFOUND: HRRZ B,(A) ;GOBBLE THE SAT
+ TRNE B,CHBIT ; SKIP IF CHTYPABLE
+ JRST CANTCH
+ TRNE B,TMPLBT ; TEMPLAT
+ HRLI B,-1
+ AND B,[-1,,SATMSK]
+ GETYP A,(AB) ;NOW GET TYPE TO HACK
+ PUSHJ P,SAT ;FIND OUT ITS SAT
+ JUMPE A,TYPERR ;COMPLAIN
+ CAILE A,NUMSAT
+ JRST CHTMPL ; JUMP IF TEMPLATE DATA
+ CAIE A,(B) ;DO THEY AGREE?
+ JRST TYPDIF ;NO, COMPLAIN
+CHTMP1: MOVSI A,(D) ;GET NEW TYPE
+ HRR A,(AB) ; FOR DEFERRED GOODIES
+ JUMPL B,CHMATC ; CHECK IT
+ MOVE B,1(AB) ;AND VALUE
+ JRST FINIS
+
+CHTMPL: MOVE E,1(AB) ; GET ARG
+ HLRZ A,(E)
+ ANDI A,SATMSK
+ MOVE 0,3(AB) ; SEE IF TO "TEMPLATE"
+ CAMN 0,IMQUOTE TEMPLATE
+ JRST CHTMP1
+ TLNN E,-1 ; SKIP IF RESTED
+ CAIE A,(B)
+ JRST TYPDIF
+ JRST CHTMP1
+
+CHMATC: PUSH TP,A
+ PUSH TP,1(AB) ; SAVE GOODIE
+ MOVSI A,TATOM
+ MOVE B,3(AB)
+ MOVSI C,TATOM
+ MOVE D,IMQUOTE DECL
+ PUSHJ P,IGET ; FIND THE DECL
+ PUSH TP,A
+ PUSH TP,B
+ MOVE C,(AB)
+ MOVE D,1(AB) ; NOW GGO TO MATCH
+ PUSHJ P,TMATCH
+ JRST CHMAT1
+ SUB TP,[2,,2]
+CHMAT2: POP TP,B
+ POP TP,A
+ JRST FINIS
+
+CHMAT1: POP TP,B
+ POP TP,A
+ MOVE C,-1(TP)
+ MOVE D,(TP)
+ PUSHJ P,TMATCH
+ JRST TMPLVI
+ JRST CHMAT2
+
+TYPLOO: PUSHJ P,TYPFND
+ ERRUUO EQUOTE BAD-TYPE-NAME
+ POPJ P,
+
+TYPFND: HLRE A,B ; FIND DOPE WORDS
+ SUBM B,A ; A POINTS TO IT
+ HRRE D,(A) ; TYPE-CODE TO D
+ JUMPE D,CPOPJ
+ ANDI D,TYPMSK ; FLUSH FUNNY BITS
+ MOVEI A,(D)
+ ASH A,1
+ HRLI A,(A)
+ ADD A,TYPVEC+1
+CPOPJ1: AOS (P)
+ POPJ P,
+
+
+REPEAT 0,[
+ MOVE A,TYPVEC+1 ;GOBBLE DOWN TYPE VECTOR
+ MOVEI D,0 ;INITIALIZE TYPE COUNTER
+TLOOK: CAMN B,1(A) ;CHECK THIS ONE
+ JRST CPOPJ1
+ ADDI D,1 ;BUMP COUNTER
+ AOBJP A,.+2 ;COUTN DOWN ON VECTOR
+ AOBJN A,TLOOK
+ POPJ P,
+CPOPJ1: AOS (P)
+ POPJ P,
+]
+
+TYPDIF: ERRUUO EQUOTE STORAGE-TYPES-DIFFER
+
+
+TMPLVI: ERRUUO EQUOTE DECL-VIOLATION
+\f
+
+; FUNCTION TO ADD A NEW TYPE TO THE WORLD WITH GIVEN PRIMITIVE TYPE
+
+MFUNCTION NEWTYPE,SUBR
+
+ ENTRY
+
+ HLRZ 0,AB ; CHEC # OF ARGS
+ CAILE 0,-4 ; AT LEAST 2
+ JRST TFA
+ CAIGE 0,-6
+ JRST TMA ; NOT MORE THAN 3
+ GETYP A,(AB) ; GET 1ST ARGS TYPE (SHOULD BE ATOM)
+ GETYP C,2(AB) ; SAME WITH SECOND
+ CAIN A,TATOM ; CHECK
+ CAIE C,TATOM
+ JRST NOTATOM
+
+ MOVE B,3(AB) ; GET PRIM TYPE NAME
+ PUSHJ P,TYPLOO ; LOOK IT UP
+ HRRZ A,(A) ; GOBBLE SAT
+ ANDI A,SATMSK
+ HRLI A,TATOM ; MAKE NEW TYPE
+ PUSH P,A ; AND SAVE
+ MOVE B,1(AB) ; SEE IF PREV EXISTED
+ PUSHJ P,TYPFND
+ JRST NEWTOK ; DID NOT EXIST BEFORE
+ MOVEI B,2(A) ; FOR POSSIBLE TMPLAT BIT
+ HRRZ A,(A) ; GET SAT
+ HRRZ 0,(P) ; AND PROPOSED
+ ANDI A,SATMSK
+ ANDI 0,SATMSK
+ CAIN 0,(A) ; SKIP IF LOSER
+ JRST NEWTFN ; O.K.
+
+ ERRUUO EQUOTE TYPE-ALREADY-EXISTS
+
+NEWTOK: POP P,A
+ MOVE B,1(AB) ; NEWTYPE NAME
+ PUSHJ P,INSNT ; MUNG IN NEW TYPE
+
+NEWTFN: CAML AB,[-5,,] ; SKIP IF TEMPLAT SUPPLIED
+ JRST NEWTF1
+ MOVEI 0,TMPLBT ; GET THE BIT
+ IORM 0,-2(B) ; INTO WORD
+ MOVE A,(AB) ; GET TYPE NAME
+ MOVE B,1(AB)
+ MOVSI C,TATOM
+ MOVE D,IMQUOTE DECL
+ PUSH TP,4(AB) ; GET TEMLAT
+ PUSH TP,5(AB)
+ PUSHJ P,IPUT
+NEWTF1: MOVE A,(AB)
+ MOVE B,1(AB) ; RETURN NAME
+ JRST FINIS
+
+; SET UP GROWTH FIELDS
+
+IGROWT: SKIPA A,[111100,,(C)]
+IGROWB: MOVE A,[001100,,(C)]
+ HLRE B,C
+ SUB C,B ; POINT TO DOPE WORD
+ MOVE B,TYPIC ; INDICATED GROW BLOCK
+ DPB B,A
+ POPJ P,
+
+INSNT: PUSH TP,A
+ PUSH TP,B ; SAVE NAME OF NEWTYPE
+ MOVE C,TYPBOT+1 ; CHECK GROWTH NEED
+ CAMGE C,TYPVEC+1
+ JRST ADDIT ; STILL ROOM
+GAGN: PUSHJ P,IGROWB ; SETUP BOTTOM GROWTH
+ SKIPE C,EVATYP+1
+ PUSHJ P,IGROWT ; SET UP TOP GROWTH
+ SKIPE C,APLTYP+1
+ PUSHJ P,IGROWT
+ SKIPE C,PRNTYP+1
+ PUSHJ P,IGROWT
+ MOVE C,[11.,,5] ; SET UP INDICATOR FOR AGC
+ PUSHJ P,AGC ; GROW THE WORLD
+ AOJL A,GAGN ; BAD AGC LOSSAGE
+ MOVE 0,[-101,,-100]
+ ADDM 0,TYPBOT+1 ; FIX UP POINTER
+
+ADDIT: MOVE C,TYPVEC+1
+ SUB C,[2,,2] ; ALLOCATE ROOM
+ MOVEM C,TYPVEC+1
+ HLRE B,C ; PREPARE TO BLT
+ SUBM C,B ; C POINTS DOPE WORD END
+ HRLI C,2(C) ; GET BLT AC READY
+ BLT C,-3(B)
+ POP TP,-1(B) ; CLOBBER IT IN
+ POP TP,-2(B)
+ HLRE C,TYPVEC+1 ; GET CODE
+ MOVNS C
+ ASH C,-1
+ SUBI C,1
+ MOVE D,-1(B) ; B HAS POINTER TO TYPE VECTOR DOPE WORDS
+ MOVEI 0,(D)
+ CAIG 0,HIBOT ; IS ATOM PURE?
+ JRST ADDNOI ; NO, SO NO HACKING REQUIRED
+ PUSH P,C
+ MOVE B,D
+ PUSHJ P,IMPURIF ; DO IMPURE OF ATOM
+ MOVE C,TYPVEC+1
+ HLRE B,C
+ SUBM C,B ; RESTORE B
+ POP P,C
+ MOVE D,-1(B) ; RESTORE D
+ADDNOI: HLRE A,D
+ SUBM D,A
+ TLO C,400000
+ HRRM C,(A) ; INTO "GROWTH" FIELD
+ POPJ P,
+
+\f
+; Interface to interpreter for setting up tables associated with
+; template data structures.
+; A/ <\b-name of type>\b-
+; B/ <\b-length ins>\b-
+; C/ <\b-uvector of garbage collector code or 0>
+; D/ <\b-uvector of GETTERs>\b-
+; E/ <\b-uvector of PUTTERs>\b-
+
+CTMPLT: SUBM M,(P) ; could possibly gc during this stuff
+ PUSH TP,$TATOM ; save name of type
+ PUSH TP,A
+ PUSH P,B ; save length instr
+ HLRE A,TD.LNT+1 ; check for template slots left?
+ HRRZ B,TD.LNT+1
+ SUB B,A ; point to dope words
+ HLRZ B,1(B) ; get real length
+ ADDI A,-2(B)
+ JUMPG A,GOODRM ; jump if ok
+
+ PUSH TP,$TUVEC ; save getters and putters
+ PUSH TP,C
+ PUSH TP,$TUVEC ; save getters and putters
+ PUSH TP,D
+ PUSH TP,$TUVEC
+ PUSH TP,E
+ MOVEI A,10-2(B) ; grow it 10 by copying remember d.w. length
+ PUSH P,A ; save new length
+ PUSHJ P,CAFRE1 ; get frozen uvector
+ ADD B,[10,,10] ; rest it down some
+ HRL C,TD.LNT+1 ; prepare to BLT in
+ MOVEM B,TD.LNT+1 ; and save as new length vector
+ HRRI C,(B) ; destination
+ ADD B,(P) ; final destination address
+ BLT C,-12(B)
+ MOVE A,(P) ; length for new getters
+ PUSHJ P,CAFRE1
+ HRL C,TD.GET+1 ; get old for copy
+ MOVEM B,TD.GET+1
+ PUSHJ P,DOBLTS ; go fixup new uvector
+ MOVE A,(P) ; finally putters
+ PUSHJ P,CAFRE1
+ HRL C,TD.PUT+1
+ MOVEM B,TD.PUT+1
+ PUSHJ P,DOBLTS ; go fixup new uvector
+ MOVE A,(P) ; finally putters
+ PUSHJ P,CAFRE1
+ HRL C,TD.AGC+1
+ MOVEM B,TD.AGC+1
+ PUSHJ P,DOBLTS ; go fixup new uvector
+ SUB P,[1,,1] ; flush stack craft
+ MOVE E,(TP)
+ MOVE D,-2(TP)
+ MOVE C,-4(TP) ;GET TD.AGC
+ SUB TP,[6,,6]
+
+GOODRM: MOVE B,TD.LNT+1 ; move down to fit new guy
+ SUB B,[1,,1] ; will always win due to prev checks
+ MOVEM B,TD.LNT+1
+ HRLI B,1(B)
+ HLRE A,TD.LNT+1
+ MOVNS A
+ ADDI A,-1(B) ; A/ final destination
+ BLT B,-1(A)
+ POP P,(A) ; new length ins munged in
+ HLRE A,TD.LNT+1
+ MOVNS A ; A/ offset for other guys
+ PUSH P,A ; save it
+ ADD A,TD.GET+1 ; point for storing uvs of ins
+ MOVEM D,-1(A)
+ MOVE A,(P)
+ ADD A,TD.PUT+1
+ MOVEM E,-1(A) ; store putter also
+ MOVE A,(P)
+ ADD A,TD.AGC+1
+ MOVEM C,-1(A) ; store putter also
+ POP P,A ; compute primtype
+ ADDI A,NUMSAT
+ PUSH P,A
+ MOVE B,(TP) ; ready to mung type vector
+ SUB TP,[2,,2]
+ PUSHJ P,TYPFND ; CHECK TO SEE WHETHER TEMPLATE EXISTS
+ JRST NOTEM
+ POP P,C ; GET SAT
+ HRRM C,(A)
+ JRST MPOPJ
+NOTEM: POP P,A ; RESTORE SAT
+ HRLI A,TATOM ; GET TYPE
+ PUSHJ P,INSNT ; INSERT INTO VECTOR
+ JRST MPOPJ
+
+; this routine copies GET and PUT vectors into new ones
+
+DOBLTS: HRRI C,(B)
+ ADD B,-1(P)
+ BLT C,-11(B) ; zap those guys in
+ MOVEI A,TUVEC ; mung in uniform type
+ PUTYP A,(B)
+ MOVEI C,-7(B) ; zero out remainder of uvector
+ HRLI C,-10(B)
+ SETZM -1(C)
+ BLT C,-1(B)
+ POPJ P,
+\f
+
+; FUNCTIONS TO SET UP EVALUATION AND APPLICATION RULES FOR DATA TYPES
+
+MFUNCTION EVALTYPE,SUBR
+
+ ENTRY
+
+ PUSHJ P,CHKARG ; VERIFY WINNAGE IN ARGS
+ MOVEI A,EVATYP ; POINT TO TABLE
+ MOVEI E,EVTYPE ; POINT TO PURE VERSION
+ MOVEI 0,EVAL
+TBLCAL: PUSHJ P,TBLSET ; SETUP TABLE ENTRY
+ JRST FINIS
+
+MFUNCTION APPLYTYPE,SUBR
+
+ ENTRY
+
+ PUSHJ P,CHKARG
+ MOVEI A,APLTYP ; POINT TO APPLY TABLE
+ MOVEI E,APTYPE ; PURE TABLE
+ MOVEI 0,APPLY
+ JRST TBLCAL
+
+
+MFUNCTION PRINTTYPE,SUBR
+
+ ENTRY
+
+ PUSHJ P,CHKARG
+ MOVEI A,PRNTYP ; POINT TO APPLY TABLE
+ MOVEI E,PRTYPE ; PURE TABLE
+ MOVEI 0,PRINT
+ JRST TBLCAL
+
+; CHECK ARGS AND SETUP FOR TABLE HACKER
+
+CHKARG: JUMPGE AB,TFA
+ CAMGE AB,[-5,,]
+ JRST TMA
+ GETYP A,(AB) ; 1ST MUST BE TYPE NAME
+ CAIE A,TATOM
+ JRST WTYP1
+ MOVE B,1(AB) ; GET ATOM
+ PUSHJ P,TYPLOO ; VERIFY THAT IT IS A TYPE
+ PUSH P,D ; SAVE TYPE NO.
+ MOVEI D,-1 ; INDICATE FUNNYNESS
+ CAML AB,[-3,,] ; SKIP IF 2 OR MORE
+ JRST TY1AR
+ HRRZ A,(A) ; GET SAT
+ ANDI A,SATMSK
+ PUSH P,A
+ GETYP A,2(AB) ; GET 2D TYPE
+ CAIE A,TATOM ; EITHER TYPE OR APPLICABLE
+ JRST TRYAPL ; TRY APPLICABLE
+ MOVE B,3(AB) ; VERIFY IT IS A TYPE
+ PUSHJ P,TYPLOO
+ HRRZ A,(A) ; GET SAT
+ ANDI A,SATMSK
+ POP P,C ; RESTORE SAVED SAT
+ CAIE A,(C) ; SKIP IF A WINNER
+ JRST TYPDIF ; REPORT ERROR
+TY1AR: POP P,C ; GET SAVED TYPE
+ MOVEI B,0 ; TELL THAT WE ARE A TYPE
+ POPJ P,
+
+TRYAPL: PUSHJ P,APLQ ; IS THIS APPLICABLE
+ JRST NAPT
+ SUB P,[1,,1]
+ MOVE B,2(AB) ; RETURN SAME
+ MOVE D,3(AB)
+ POP P,C
+ POPJ P,
+
+\f
+; HERE TO PUT ENTRY IN APPROPRIATE TABLE
+
+TBLSET: PUSH TP,B
+ PUSH TP,D ; SAVE VALUE
+ PUSH TP,$TFIX
+ PUSH TP,A
+ PUSH P,C ; SAVE TYPE BEING HACKED
+ PUSH P,E
+ SKIPE B,1(A) ; SKIP IF VECTOR DOESN'T EXIST YET
+ JRST TBL.OK
+ MOVE B,-2(TP) ; CHECK FOR RETURN IT HACK
+ SKIPN -3(TP)
+ CAIE B,-1
+ JRST .+2
+ JRST RETPM2
+ HLRE A,TYPBOT+1 ; GET CURRENT TABLE LNTH
+ MOVNS A
+ ASH A,-1
+ PUSH P,0
+ PUSHJ P,IVECT ; GET VECTOR
+ POP P,0
+ MOVE C,(TP) ; POINT TO RETURN POINT
+ MOVEM B,1(C) ; SAVE VECTOR
+
+TBL.OK: POP P,E
+ POP P,C ; RESTORE TYPE
+ SUB TP,[2,,2]
+ POP TP,D
+ POP TP,A
+ JUMPN A,TBLOK1 ; JUMP IF FUNCTION ETC. SUPPLIED
+ CAIN D,-1
+ JRST TBLOK1
+ CAILE D,NUMPRI ; SKIP IF ORIGINAL TYPE
+ MOVNI E,(D) ; CAUSE E TO ENDUP 0
+ ADDI E,(D) ; POINT TO PURE SLOT
+TBLOK1: ADDI C,(C) ; POINT TO VECTOR SLOT
+ ADDI C,(B)
+ CAIN D,-1
+ JRST RETCUR
+ JUMPN A,OK.SET ; OK TO CLOBBER
+ ADDI B,(D) ; POINT TO TARGET TYPE'S SLOT
+ ADDI B,(D) ; POINT TO TARGET TYPE'S SLOT
+ SKIPN A,(B) ; SKIP IF WINNER
+ SKIPE 1(B) ; SKIP IF LOSER
+ SKIPA D,1(B) ; SETUP D
+ JRST CH.PTB ; CHECK PURE TABLE
+
+OK.SET: CAIN 0,(D) ; SKIP ON RESET
+ SETZB A,D
+ MOVEM A,(C) ; STORE
+ MOVEM D,1(C)
+RETAR1: MOVE A,(AB) ; RET TYPE
+ MOVE B,1(AB)
+ JRST FINIS
+
+CH.PTB: MOVEI A,0
+ MOVE D,[SETZ NAPT]
+ JUMPE E,OK.SET
+ MOVE D,(E)
+ JRST OK.SET
+
+RETPM2: SUB TP,[4,,4]
+ SUB P,[2,,2]
+ ASH C,1
+ SOJA E,RETPM4
+
+RETCUR: SKIPN A,(C)
+ SKIPE 1(C)
+ SKIPA B,1(C)
+ JRST RETPRM
+
+ JUMPN A,CPOPJ
+RETPM1: MOVEI A,0
+ JUMPL B,RTFALS
+ CAMN B,1(E)
+ JRST .+3
+ ADDI A,2
+ AOJA E,.-3
+
+RETPM3: ADD A,TYPVEC+1
+ MOVE B,3(A)
+ MOVE A,2(A)
+ POPJ P,
+
+RETPRM: SUBI C,(B) ; UNDO BADNESS
+RETPM4: CAIG C,NUMPRI*2
+ SKIPG 1(E)
+ JRST RTFALS
+
+ MOVEI A,-2(C)
+ JRST RETPM3
+
+CALLTY: MOVE A,TYPVEC
+ MOVE B,TYPVEC+1
+ POPJ P,
+
+MFUNCTION ALLTYPES,SUBR
+
+ ENTRY 0
+
+ MOVE A,TYPVEC
+ MOVE B,TYPVEC+1
+ JRST FINIS
+
+;\f
+
+;FUNCTION TO RETURN TYPE OF ELEMENTS IN A UVECTOR
+
+MFUNCTION UTYPE,SUBR
+
+ ENTRY 1
+
+ GETYP A,(AB) ;GET U VECTOR
+ PUSHJ P,SAT
+ CAIE A,SNWORD
+ JRST WTYP1
+ MOVE B,1(AB) ; GET UVECTOR
+ PUSHJ P,CUTYPE
+ JRST FINIS
+
+CUTYPE: HLRE A,B ;GET -LENGTH
+ HRRZS B
+ SUB B,A ;POINT TO TYPE WORD
+ GETYP A,(B)
+ JRST ITYPE ; GET NAME OF TYPE
+
+; FUNCTION TO CHANGE UNIFORM TYPE OF A VECTOR
+
+MFUNCTION CHUTYPE,SUBR
+
+ ENTRY 2
+
+ GETYP A,2(AB) ;GET 2D TYPE
+ CAIE A,TATOM
+ JRST NOTATO
+ GETYP A,(AB) ; CALL WITH UVECTOR?
+ PUSHJ P,SAT
+ CAIE A,SNWORD
+ JRST WTYP1
+ MOVE A,1(AB) ; GET UV POINTER
+ MOVE B,3(AB) ;GET ATOM
+ PUSHJ P,CCHUTY
+ MOVE A,(AB) ; RETURN UVECTOR
+ MOVE B,1(AB)
+ JRST FINIS
+
+CCHUTY: PUSH TP,$TUVEC
+ PUSH TP,A
+ PUSHJ P,TYPLOO ;LOOK IT UP
+ HRRZ B,(A) ;GET SAT
+ TRNE B,CHBIT
+ JRST CANTCH
+ ANDI B,SATMSK
+ SKIPGE MKTBS(B)
+ JRST CANTCH
+ HLRE C,(TP) ;-LENGTH
+ HRRZ E,(TP)
+ SUB E,C ;POINT TO TYPE
+ GETYP A,(E) ;GET TYPE
+ JUMPE A,WIN0 ;ALLOW TYPE "LOSE" TO CHANGE TO ANYTHING
+ PUSHJ P,SAT ;GET SAT
+ JUMPE A,TYPERR
+ CAIE A,(B) ;COMPARE
+ JRST TYPDIF
+WIN0: ADDI D,.VECT.
+ HRLM D,(E) ;CLOBBER NEW ONE
+ POP TP,B
+ POP TP,A
+ POPJ P,
+
+CANTCH: PUSH TP,$TATOM
+ PUSH TP,EQUOTE CANT-CHTYPE-INTO
+ PUSH TP,2(AB)
+ PUSH TP,3(AB)
+ MOVEI A,2
+ JRST CALER
+
+NOTATOM:
+ PUSH TP,$TATOM
+ PUSH TP,EQUOTE NON-ATOMIC-ARGUMENT
+ PUSH TP,(AB)
+ PUSH TP,1(AB)
+ MOVEI A,2
+ JRST CALER
+
+
+\f
+; SUBROUTINE TO LEAVE MUDDLE CLOSING ALL CHANNELS ON THE WAY
+
+MFUNCTION QUIT,SUBR
+
+ ENTRY 0
+
+
+ PUSHJ P,CLOSAL ; DO THE CLOSES
+ PUSHJ P,%KILLM
+ JRST IFALSE ; JUST IN CASE
+
+CLOSAL: MOVEI B,CHNL0+2 ; POINT TO 1ST (NOT INCLUDING TTY I/O)
+ MOVE PVP,PVSTOR+1
+ MOVE TVP,REALTV+1(PVP)
+ SUBI B,(TVP)
+ HRLS B
+ ADD B,TVP
+ PUSH TP,$TVEC
+ PUSH TP,B
+ PUSH P,[N.CHNS-1] ; MAX NO. OF CHANS
+
+CLOSA1: MOVE B,(TP)
+ ADD B,[2,,2]
+ MOVEM B,(TP)
+ HLLZS -2(B)
+ SKIPN C,-1(B) ; THIS ONE OPEN?
+ JRST CLOSA4 ; NO
+ CAME C,TTICHN+1
+ CAMN C,TTOCHN+1
+ JRST CLOSA4
+ PUSH TP,-2(B) ; PUSH IT
+ PUSH TP,-1(B)
+ MCALL 1,FCLOSE ; CLOSE IT
+CLOSA4: SOSLE (P) ; COUNT DOWN
+ JRST CLOSA1
+
+
+ SUB TP,[2,,2]
+ SUB P,[1,,1]
+
+CLOSA3: SKIPN B,CHNL0+1
+ POPJ P,
+ PUSH TP,(B)
+ HLLZS (TP)
+ PUSH TP,1(B)
+ HRRZ B,(B)
+ MOVEM B,CHNL0+1
+ MCALL 1,FCLOSE
+ JRST CLOSA3
+\f
+
+IMPURE
+
+WHOAMI: 0 ; SYAYS WHETHER I AM REALLY A MUDDLE OR SOME HACK
+
+
+;GARBAGE COLLECTORS PDLS
+
+
+GCPDL: -GCPLNT,,GCPDL
+
+ BLOCK GCPLNT
+
+
+PURE
+
+MUDSTR: ASCII /MUDDLE \7f\7f\7f/
+STRNG: -1
+ -1
+ -1
+ ASCIZ / IN OPERATION./
+
+;MARKED PDLS FOR GC PROCESS
+
+VECTGO
+; DUMMY FRAME FOR INITIALIZER CALLS
+
+ TENTRY,,LISTEN
+ 0
+ .-3
+ 0
+ 0
+ -ITPLNT,,TPBAS-1
+ 0
+
+TPBAS: BLOCK ITPLNT+PDLBUF
+ GENERAL
+ ITPLNT+2+PDLBUF+7,,0
+
+
+VECRET
+
+
+$TMATO: TATOM,,-1
+
+END
+\f
\ No newline at end of file
--- /dev/null
+TITLE MAIN LOOP AND GLOBALLY REFERENCED SUBROUTINES
+
+RELOCA
+
+.GLOBAL TBINIT,PIDSTO,PROCID,PTIME,GCPDL,PBASE,TYPTOP,RERR,FRMSTK,EMERGE
+.GLOBAL PDLBUF,INTINT,START,SWAP,ICR,SPBASE,TPBASE,TPBAS,CURPRI,CHFINI,MKTBS
+.GLOBAL TOPLEVEL,INTOBL,INITIA,ERROBL,MAINPR,RESFUN,STATUS,TYPVEC,ROOT,TTICHN,TTOCHN
+.GLOBAL TTYOPE,MOPEN,MCLOSE,MIOT,ILVAL,MESS,ERROR,CHFRM,IGVAL,TYPBOT,ASOVEC
+.GLOBAL PRINT,PRIN1,PRINC,MUDSTR,VECBOT,CSTACK,IFALSE,TYPLOO,RCALL,SWAPIN,CTMPLT
+.GLOBAL IDPROC,CHFSWP,ILOC,MAKACT,BNDV,SPECSTORE,BINDID,IGLOC,MTYO,MSGTYP,CAFRE1,CPOPJ
+.GLOBAL EVATYP,EVTYPE,APLTYP,APTYPE,PRNTYP,PRTYPE,AGC,SGSNAM,NAPT,APLQ,STRTO6
+.GLOBAL 6TOCHS,TYPFND,STBL,CHNL0,N.CHNS,CLOSAL,%LOGOUT,%SSNAM,%RSNAM,%KILLM,SAT
+.GLOBAL MAKINF,%VALRET,COMPERR,IPUT,IGET,TMATCH,INITIZ,IPCINI,%UNAM,%JNAM,%RUNAM,%RJNAM,%RXUNA,%RXJNA,%VALFI
+.GLOBAL NOTTY,DEMFLG,CFRAME,CARGS,CFUNCT,CITYPE,CTYPEQ,CPTYPE,CTYPEP,CUTYPE,
+.GLOBAL CCHUTY,RTFALS,PGINT,PURCLN,CTYPEC,CTYPEW,IDVAL1,CALLTY,MESSAG,INITFL,WHOAMI
+.GLOBAL %SLEEP,%HANG,%TOPLQ,ONINT,CHUNW,CURFCN,BUFRIN,TD.LNT,TD.GET,TD.AGC,TD.PUT,MPOPJ
+.GLOBAL PURVEC,PLOAD,SSPECS,OUTRNG,CVTYPE,FSTART,CKVRS,CPRTYC,PVSTOR,SPSTOR
+.GLOBAL TYPIC,CISET,LSTUF,IMPURI,REALTV
+.INSRT MUDDLE >
+
+;MAIN LOOP AND STARTUP
+
+START: MOVEI 0,0 ; SET NO HACKS
+ JUMPE 0,START1
+ TLNE 0,-1 ; SEE IF CHANNEL
+ JRST START1
+ MOVE P,GCPDL
+ MOVE A,0
+ PUSH P,A
+ PUSHJ P,CKVRS ; CHECK VERSION NUMBERS
+ POP P,A
+ JRST FSTART ; GO RESTORE
+START1: MOVEM 0,WHOAMI ; HACK FOR TS FOO linked to TS MUDDLE
+ MOVE PVP,MAINPR ; MAKE SURE WE START IN THE MAIN PROCESS
+ JUMPE 0,INITIZ ; MIGHT BE RESTART
+ MOVE P,PSTO+1(PVP) ; SET UP FOR BOOTSTRAP HACK
+ MOVE TP,TPSTO+1(PVP)
+INITIZ: MOVE PVP,MAINPR
+ SKIPN P ; IF NO CURRENT P
+ MOVE P,PSTO+1(PVP) ; PDL TO GET OFF THE GROUND
+ SKIPN TP ; SAME FOR TP
+ MOVE TP,TPSTO+1(PVP) ; GET A TP TO WORK WITH
+ SETZB R,M ; RESET RSUBR AC'S
+ PUSHJ P,%RUNAM
+ JFCL
+ PUSHJ P,%RJNAM
+ PUSHJ P,TTYOPE ;OPEN THE TTY
+ MOVEI B,MUDSTR
+ SKIPE WHOAMI ; SKIP IF THIS IS MUDDLE
+ JRST NODEMT ; ELSE NO MESSAGE
+ SKIPE DEMFLG ; SKIP IF NOT DEMON
+ JRST NODEMT
+ SKIPN NOTTY ; IF NO TTY, IGNORE
+ PUSHJ P,MSGTYP ;TYPE OUT TO USER
+
+NODEMT: XCT MESSAG ;MAYBE PRINT A MESSAGE
+ PUSHJ P,INTINT ;INITIALIZE INTERRUPT HANDLER
+ XCT IPCINI
+ PUSHJ P,PURCLN ; CLEAN UP PURE SHARED AREA
+RESTART: ;RESTART A PROCESS
+STP: MOVEI C,0
+ MOVE PVP,PVSTOR+1
+ MOVE B,TBINIT+1(PVP) ;POINT INTO STACK AT START
+ PUSHJ P,CHUNW ; LEAVE WHILE DOING UNWIND CHECK
+ MOVEI E,TOPLEV
+ MOVEI A,TFALSE ; IN CASE FALLS OFF PROCESS
+ MOVEI B,0
+ HRRM E,-1(TB)
+ JRST CONTIN
+
+ IMQUOTE TOPLEVEL
+TOPLEVEL:
+ MCALL 0,LISTEN
+ JRST TOPLEVEL
+\f
+
+IMFUNCTION LISTEN,SUBR
+
+ ENTRY
+ PUSH P,[0] ;FLAG: DON'T PRINT ERROR MSG
+ JRST ER1
+
+; USER SUPPLIED ERROR HANDLER, TEMPORARY KLUDGE
+ IMQUOTE ERROR
+
+ERROR: MOVE B,IMQUOTE ERROR
+ PUSHJ P,IGVAL ; GET VALUE
+ GETYP C,A
+ CAIN C,TSUBR ; CHECK FOR NO CHANGE
+ CAIE B,RERR1 ; SKIP IF NOT CHANGED
+ JRST .+2
+ JRST RERR1 ; GO TO THE DEFAULT
+ PUSH TP,A ; SAVE VALUE
+ PUSH TP,B
+ MOVE C,AB ; SAVE AB
+ MOVEI D,1 ; AND COUNTER
+USER1: PUSH TP,(C) ; PUSH THEM
+ PUSH TP,1(C)
+ ADD C,[2,,2] ; BUMP
+ ADDI D,1
+ JUMPL C,USER1
+ ACALL D,APPLY ; EVAL USERS ERROR
+ JRST FINIS
+
+
+
+IMFUNCTION ERROR%,SUBR,ERROR
+
+RERR1: ENTRY
+ PUSH TP,$TATOM
+ PUSH TP,MQUOTE ERROR,ERROR,INTRUP
+ PUSHJ P,FRMSTK ; PUT ERROR'S FRAME ON STACK
+ MOVEI D,2
+ MOVE C,AB
+RERR2: JUMPGE C,RERR22
+ PUSH TP,(C)
+ PUSH TP,1(C)
+ ADD C,[2,,2]
+ AOJA D,RERR2
+RERR22: ACALL D,EMERGENCY
+ JRST RERR
+
+IMQUOTE ERROR
+RERR: ENTRY
+ PUSH P,[-1] ;PRINT ERROR FLAG
+
+ER1: MOVE B,IMQUOTE INCHAN
+ PUSHJ P,ILVAL ; CHECK INPUT CHANNEL IS SOME KIND OF TTY
+ GETYP A,A
+ CAIE A,TCHAN ; SKIP IF IT IS A CHANNEL
+ JRST ER2 ; NO, MUST REBIND
+ CAMN B,TTICHN+1
+ JRST NOTINC
+ER2: MOVE B,IMQUOTE INCHAN
+ MOVEI C,TTICHN ; POINT TO VALU
+ PUSHJ P,PUSH6 ; PUSH THE BINDING
+ MOVE B,TTICHN+1 ; GET IN CHAN
+NOTINC: SKIPN DEMFLG ; SKIP IF DEMON
+ SKIPE NOTTY
+ JRST NOECHO
+ PUSH TP,$TCHAN
+ PUSH TP,B
+ PUSH TP,$TATOM
+ PUSH TP,IMQUOTE T
+ MCALL 2,TTYECH ; ECHO INPUT
+NOECHO: MOVE B,IMQUOTE OUTCHAN
+ PUSHJ P,ILVAL ; GET THE VALUE
+ GETYP A,A
+ CAIE A,TCHAN ; SKIP IF OK CHANNEL
+ JRST ER3 ; NOT CHANNEL, MUST REBIND
+ CAMN B,TTOCHN+1
+ JRST NOTOUT
+ER3: MOVE B,IMQUOTE OUTCHAN
+ MOVEI C,TTOCHN
+ PUSHJ P,PUSH6 ; PUSH THE BINDINGS
+NOTOUT: MOVE B,IMQUOTE OBLIST
+ PUSHJ P,ILVAL ; GET THE VALUE OF OBLIST
+ PUSHJ P,OBCHK ; IS IT A WINNER ?
+ SKIPA A,$TATOM ; NO, SKIP AND CONTINUE
+ JRST NOTOBL ; YES, DO NOT DO REBINDING
+ MOVE B,IMQUOTE OBLIST
+ PUSHJ P,IGLOC
+ GETYP 0,A
+ CAIN 0,TUNBOU
+ JRST MAKOB ; NO GLOBAL OBLIST, MAKE ONE
+ MOVEI C,(B) ; COPY ADDRESS
+ MOVE A,(C) ; GET THE GVAL
+ MOVE B,(C)+1
+ PUSHJ P,OBCHK ; IS IT A WINNER ?
+ JRST MAKOB ; NO, GO MAKE A NEW ONE
+ MOVE B,IMQUOTE OBLIST
+ PUSHJ P,PUSH6
+
+NOTOBL: PUSH TP,[TATOM,,-1] ;FOR BINDING
+ PUSH TP,IMQUOTE LER,[LERR ]INTRUP
+ PUSHJ P,MAKACT
+ HRLI A,TFRAME ; CORRCT TYPE
+ PUSH TP,A
+ PUSH TP,B
+ PUSH TP,[0]
+ PUSH TP,[0]
+ MOVE A,PVSTOR+1 ; GET PROCESS
+ ADD A,[PROCID,,PROCID] ; POINT TO ID (ALSO LEVEL)
+ PUSH TP,BNDV
+ PUSH TP,A
+ MOVE A,PROCID(PVP)
+ ADDI A,1 ; BUMP ERROR LEVEL
+ PUSH TP,A
+ PUSH TP,PROCID+1(PVP)
+ PUSH P,A
+
+ MOVE B,IMQUOTE READ-TABLE
+ PUSHJ P,IGVAL
+ PUSH TP,[TATOM,,-1]
+ PUSH TP,IMQUOTE READ-TABLE
+ GETYP C,A ; TO GVAL OF READ-TABLE ON ERROR AND
+ CAIE C,TVEC ; TOP ERRET'S
+ JRST .+4
+ PUSH TP,A
+ PUSH TP,B
+ JRST .+3
+ PUSH TP,$TUNBOUND
+ PUSH TP,[-1]
+ PUSH TP,[0]
+ PUSH TP,[0]
+
+ PUSHJ P,SPECBIND ;BIND THE CRETANS
+ MOVE A,-1(P) ;RESTORE SWITHC
+ JUMPE A,NOERR ;IF 0, DONT PRINT ERROR MESS
+ PUSH TP,$TATOM
+ PUSH TP,EQUOTE *ERROR*
+ MCALL 0,TERPRI
+ MCALL 1,PRINC ;PRINT THE MESSAGE
+NOERR: MOVE C,AB ;GET A COPY OF AB
+
+ERRLP: JUMPGE C,LEVPRT ;IF NONE, RE-ENTER READ-EVAL-PRINT LOOP
+ PUSH TP,$TAB
+ PUSH TP,C
+ MOVEI B,PRIN1
+ GETYP A,(C) ; GET ARGS TYPE
+ CAIE A,TATOM
+ JRST ERROK
+ MOVE A,1(C) ; GET ATOM
+ HRRO A,2(A)
+ CAME A,[-1,,ERROBL+1]
+ CAMN A,ERROBL+1 ; DONT SKIP IF IN ERROR OBLIST
+ MOVEI B,PRINC ; DONT PRINT TRAILER
+ERROK: PUSH P,B ; SAVE ROUTINE POINTER
+ PUSH TP,(C)
+ PUSH TP,1(C)
+ MCALL 0,TERPRI ; CRLF
+ POP P,B ; GET ROUTINE BACK
+ .MCALL 1,(B)
+ POP TP,C
+ SUB TP,[1,,1]
+ ADD C,[2,,2] ;BUMP SAVED AB
+ JRST ERRLP ;AND CONTINUE
+
+
+LEVPRT: XCT INITFL ;LOAD MUDDLE INIT FILE IF FIRST TIME
+ MCALL 0,TERPRI
+ PUSH TP,$TATOM
+ PUSH TP,EQUOTE [LISTENING-AT-LEVEL ]
+ MCALL 1,PRINC ;PRINT LEVEL
+ PUSH TP,$TFIX ;READY TO PRINT LEVEL
+ HRRZ A,(P) ;GET LEVEL
+ SUB P,[2,,2] ;AND POP STACK
+ PUSH TP,A
+ MCALL 1,PRIN1 ;PRINT WITHOUT SPACES ETC.
+ PUSH TP,$TATOM ;NOW PROCESS
+ PUSH TP,EQUOTE [ PROCESS ]
+ MCALL 1,PRINC ;DONT SLASHIFY SPACES
+ MOVE PVP,PVSTOR+1
+ PUSH TP,PROCID(PVP) ;NOW ID
+ PUSH TP,PROCID+1(PVP)
+ MCALL 1,PRIN1
+ SKIPN C,CURPRI
+ JRST MAINLP
+ PUSH TP,$TFIX
+ PUSH TP,C
+ PUSH TP,$TATOM
+ PUSH TP,EQUOTE [ INT-LEVEL ]
+ MCALL 1,PRINC
+ MCALL 1,PRIN1
+ JRST MAINLP ; FALL INTO MAIN LOOP
+
+\f;ROUTINES FOR ERROR-LISTEN
+
+OBCHK: GETYP 0,A
+ CAIN 0,TOBLS
+ JRST CPOPJ1 ; WIN FOR SINGLE OBLIST
+ CAIE 0,TLIST ; IF LIST, MAKE SURE EACH IS AN OBLIST
+ JRST CPOPJ ; ELSE, LOSE
+
+ JUMPE B,CPOPJ ; NIL ,LOSE
+ PUSH TP,A
+ PUSH TP,B
+ PUSH P,[0] ;FLAG FOR DEFAULT CHECKING
+ MOVEI 0,1000 ; VERY BIG NUMBER FOR CIRCULARITY TEST
+
+OBCHK0: INTGO
+ SOJE 0,OBLOSE ; CIRCULARITY TEST
+ HRRZ B,(TP) ; GET LIST POINTER
+ GETYP A,(B)
+ CAIE A,TOBLS ; SKIP IF WINNER
+ JRST DEFCHK ; CHECK FOR SPECIAL ATOM DEFAULT
+ HRRZ B,(B)
+ MOVEM B,(TP)
+ JUMPN B,OBCHK0
+OBWIN: AOS (P)-1
+OBLOSE: SUB TP,[2,,2]
+ SUB P,[1,,1]
+ POPJ P,
+
+DEFCHK: SKIPN (P) ; BEEN HERE BEFORE ?
+ CAIE A,TATOM ; OR, NOT AN ATOM ?
+ JRST OBLOSE ; YES, LOSE
+ MOVE A,(B)+1
+ CAME A,MQUOTE DEFAULT
+ JRST OBLOSE ; LOSE
+ SETOM (P) ; SET FLAG
+ HRRZ B,(B) ; CHECK FOR END OF LIST
+ MOVEM B,(TP)
+ JUMPN B,OBCHK0 ; NOT THE END, CONTINUE LOOKING
+ JRST OBLOSE ; LOSE FOR DEFAULT AT THE END
+
+
+
+PUSH6: PUSH TP,[TATOM,,-1]
+ PUSH TP,B
+ PUSH TP,(C)
+ PUSH TP,1(C)
+ PUSH TP,[0]
+ PUSH TP,[0]
+ POPJ P,
+
+
+MAKOB: PUSH TP,INITIAL
+ PUSH TP,INITIAL+1
+ PUSH TP,ROOT
+ PUSH TP,ROOT+1
+ MCALL 2,LIST
+ PUSH TP,$TATOM
+ PUSH TP,IMQUOTE OBLIST
+ PUSH TP,A
+ PUSH TP,B
+ MCALL 2,SETG
+ PUSH TP,[TATOM,,-1]
+ PUSH TP,IMQUOTE OBLIST
+ PUSH TP,A
+ PUSH TP,B
+ PUSH TP,[0]
+ PUSH TP,[0]
+ JRST NOTOBL
+\f
+
+;THIS IS IT FOLKS...THE MAIN LOOP. READ, EVAL, PRINT
+
+MAINLP: MOVE A,$TATOM ;KLUDGE BY NDR LIKE ERROR TO LET LOOSER REDEFINE
+ MOVE B,IMQUOTE REP
+ PUSHJ P,ILVAL ;GET ITS LVAL TO SEE IF REDEFINED
+ GETYP C,A
+ CAIE C,TUNBOUND
+ JRST REPCHK
+ MOVE A,$TATOM ;SEE IF IT HAS GVAL SINCE NO LVAL
+ MOVE B,IMQUOTE REP
+ PUSHJ P,IGVAL
+ GETYP C,A
+ CAIN C,TUNBOUN
+ JRST IREPER
+REPCHK: CAIN C,TSUBR
+ CAIE B,REPER
+ JRST .+2
+ JRST IREPER
+REREPE: PUSH TP,A
+ PUSH TP,B
+ GETYP A,-1(TP)
+ PUSHJ P,APLQ
+ JRST ERRREP
+ MCALL 1,APPLY ;LOOSER HAS REDEFINED SO CALL HIS
+ JRST MAINLP
+IREPER: PUSH P,[0] ;INDICATE FALL THROUGH
+ JRST REPERF
+
+ERRREP: PUSH TP,[TATOM,,-1]
+ PUSH TP,IMQUOTE REP
+ PUSH TP,$TSUBR
+ PUSH TP,[REPER]
+ PUSH TP,[0]
+ PUSH TP,[0]
+ PUSHJ P,SPECBIN
+ PUSH TP,$TATOM
+ PUSH TP,EQUOTE NON-APPLICABLE-REP
+ PUSH TP,-11(TP)
+ PUSH TP,-11(TP)
+ MCALL 2,ERROR
+ SUB TP,[6,,6]
+ PUSHJ P,SSPECS
+ JRST REREPE
+
+
+IMFUNCTION REPER,SUBR,REP
+REPER: ENTRY 0
+ PUSH P,[1] ;INDICATE DIRECT CALL
+REPERF: MCALL 0,TERPRI
+ MCALL 0,READ
+ PUSH TP,A
+ PUSH TP,B
+ MOVE B,IMQUOTE L-INS
+ PUSHJ P,ILVAL ; ASSIGNED?
+ GETYP 0,A
+ CAIN 0,TLIST
+
+ PUSHJ P,LSTTOF ; PUT LAST AS FIRST
+ MCALL 0,TERPRI
+ MCALL 1,EVAL
+ MOVE C,IMQUOTE LAST-OUT
+ PUSHJ P,CISET
+ PUSH TP,A
+ PUSH TP,B
+ MOVE B,IMQUOTE L-OUTS
+ PUSHJ P,ILVAL ; ASSIGNED?
+ GETYP 0,A
+ CAIN 0,TLIST
+
+ CAME B,(TP) ; DONT STUFF IT INTO ITSELF
+ JRST STUFIT ; STUFF IT IN
+ GETYP 0,-1(TP)
+ CAIE 0,TLIST ; IF A LIST THE L-OUTS
+STUFIT: PUSHJ P,LSTTOF ; PUT LAST AS FIRST
+ MCALL 1,PRIN1
+ POP P,C ;FLAG FOR FALL THROUGH OR CALL
+ JUMPN C,FINIS ;IN CASE LOOSER CALLED REP
+ JRST MAINLP
+
+LSTTOF: SKIPN A,B
+ POPJ P,
+
+ HRRZ C,(A)
+ JUMPE C,LSTTO2
+ MOVEI D,(C) ; SAVE PTR TO 2ND ELEMENT
+ MOVEI 0,-1 ; LET THE LOSER LOSE (HA HA HA)
+
+LSTTO1: HRRZ C,(C) ; START SCAN
+ JUMPE C,GOTIT
+ HRRZ A,(A)
+ SOJG 0,LSTTO1
+
+GOTIT: HRRZ C,(A)
+ HLLZS (A)
+ CAIE D,(C) ; AVOID CIRCULARITY
+ HRRM D,(C)
+ HRRM C,(B)
+ MOVE D,1(B)
+ MOVEM D,1(C)
+ GETYP D,(B)
+ PUTYP D,(C)
+
+LSTTO2: MOVSI A,TLIST
+ MOVE C,-1(TP)
+ MOVE D,(TP)
+ JRST LSTUF
+\f
+;FUNCTION TO RETRY A PREVIOUS FUNCTION CALL
+
+MFUNCTION RETRY,SUBR
+
+ ENTRY
+ JUMPGE AB,RETRY1 ; USE MOST RECENT
+ CAMGE AB,[-2,,0]
+ JRST TMA
+ GETYP A,(AB) ; CHECK TYPE
+ CAIE A,TFRAME
+ JRST WTYP1
+ MOVEI B,(AB) ; POINT TO ARG
+ JRST RETRY2
+RETRY1: MOVE B,IMQUOTE LER,[LERR ]INTRUP
+ PUSHJ P,ILOC ; LOCATIVE TO FRAME
+RETRY2: PUSHJ P,CHFSWP ; CHECK VALIDITY AND SWAP IF NECESSARY
+ HRRZ 0,OTBSAV(B) ; CHECK FOR TOP
+ JUMPE 0,RESTAR ; YES RE-ENTER TOP LEVEL
+ PUSH TP,$TTB
+ PUSH TP,B ; SAVE FRAME
+ MOVE B,OTBSAV(B) ; GET PRVIOUS FOR UNBIND HACK
+ MOVEI C,-1(TP)
+ PUSHJ P,CHUNW ; CHECK ANY UNWINDING
+ CAME SP,SPSAV(TB) ; UNBINDING NEEDED?
+ PUSHJ P,SPECSTORE
+ MOVE P,PSAV(TB) ; GET OTHER STUFF
+ MOVE AB,ABSAV(B)
+ HLRE A,AB ; COMPUTE # OF ARGS
+ MOVNI A,-FRAMLN(A) ; MAKE TP POINT PAST FRAME
+ HRLI A,(A)
+ MOVE C,TPSAV(TB) ; COMPUTE TP
+ ADD C,A
+ MOVE TP,C
+ MOVE TB,B ; FIX UP TB
+ HRRZ C,FSAV(TB) ; GET FUNCTION
+ CAIL C,HIBOT
+ JRST (C) ; GO
+ GETYP 0,(C) ; RSUBR OR ENTRY?
+ CAIE 0,TATOM
+ CAIN 0,TRSUBR
+ JRST RETRNT
+ MOVS R,(C) ; SET UP R
+ HRRI R,(C)
+ MOVEI C,0
+ JRST RETRN3
+
+RETRNT: CAIE 0,TRSUBR
+ JRST RETRN1
+ MOVE R,1(C)
+RETRN4: HRRZ C,2(C) ; OFFSET
+RETRN3: SKIPL M,1(R)
+ JRST RETRN5
+RETRN7: ADDI C,(M)
+ JRST (C)
+
+RETRN5: MOVEI D,(M) ; TOTAL OFFSET
+ MOVSS M
+ ADD M,PURVEC+1
+ SKIPL M,1(M)
+ JRST RETRN6
+ ADDI M,(D)
+ JRST RETRN7
+
+RETRN6: HLRZ A,1(R)
+ PUSH P,D
+ PUSH P,C
+ PUSHJ P,PLOAD
+ JRST RETRER ; LOSER
+ POP P,C
+ POP P,D
+ MOVE M,B
+ JRST RETRN7
+
+RETRN1: HRL C,(C) ; FIX LH
+ MOVE B,1(C)
+ PUSH TP,$TVEC
+ PUSH TP,C
+ PUSHJ P,IGVAL
+ GETYP 0,A
+ MOVE C,(TP)
+ SUB TP,[2,,2]
+ CAIE 0,TRSUBR
+ JRST RETRN2
+ MOVE R,B
+ JRST RETRN4
+
+RETRN2: ERRUUO EQUOTE CANT-RETRY-ENTRY-GONE
+
+RETRER: ERRUUO EQUOTE PURE-LOAD-FAILURE
+
+\f
+;FUNCTION TO DO ERROR RETURN
+
+IMFUNCTION ERRET,SUBR
+
+ ENTRY
+ HLRE A,AB ; -2*# OF ARGS
+ JUMPGE A,STP ; RESTART PROCESS
+ ASH A,-1 ; -# OF ARGS
+ AOJE A,ERRET2 ; NO FRAME SUPPLIED
+ AOJL A,TMA
+ ADD AB,[2,,2]
+ PUSHJ P,OKFRT
+ JRST WTYP2
+ SUB AB,[2,,2]
+ PUSHJ P,CHPROC ; POINT TO FRAME SLOT
+ JRST ERRET3
+ERRET2: MOVE B,IMQUOTE LER,[LERR ]INTRUP
+ PUSHJ P,ILVAL ; GET ITS VALUE
+ERRET3: PUSH TP,A
+ PUSH TP,B
+ MOVEI B,-1(TP)
+ PUSHJ P,CHFSWP ; CHECK VALIDITY AND SWAP IF NECESSARY
+ HRRZ 0,OTBSAV(B) ; TOP LEVEL?
+ JUMPE 0,TOPLOS
+ PUSHJ P,CHUNW ; ANY UNWINDING
+ JRST CHFINIS
+
+
+; FUNCTION TO RETURN LAST ERROR FRAME OR PREVIOUS FRAME
+
+IMFUNCTION FRAME,SUBR
+ ENTRY
+ SETZB A,B
+ JUMPGE AB,FRM1 ; DEFAULT CASE
+ CAMG AB,[-3,,0] ; SKIP IF OK ARGS
+ JRST TMA
+ PUSHJ P,OKFRT ; A FRAME OR SIMILAR THING?
+ JRST WTYP1
+
+FRM1: PUSHJ P,CFRAME ; GO TO INTERNAL
+ JRST FINIS
+
+CFRAME: JUMPN A,FRM2 ; ARG SUPPLIED?
+ MOVE B,IMQUOTE LER,[LERR ]INTRUP
+ PUSHJ P,ILVAL
+ JRST FRM3
+FRM2: PUSHJ P,CHPROC ; CHECK FOR PROCESS
+ PUSH TP,A
+ PUSH TP,B
+ MOVEI B,-1(TP) ; POINT TO SLOT
+ PUSHJ P,CHFRM ; CHECK IT
+ MOVE C,(TP) ; GET FRAME BACK
+ MOVE B,OTBSAV(C) ;GET PREVIOUS FRAME
+ SUB TP,[2,,2]
+ TRNN B,-1 ; SKIP IF OK
+ JRST TOPLOSE
+
+FRM3: JUMPN B,FRM4 ; JUMP IF WINNER
+ MOVE B,IMQUOTE THIS-PROCESS
+ PUSHJ P,ILVAL ; GET PROCESS OF INTEREST
+ GETYP A,A ; CHECK IT
+ CAIN A,TUNBOU
+ MOVE B,PVSTOR+1 ; USE CURRENT
+ MOVEI A,PVLNT*2+1(B) ; POINT TO DOPE WORDS
+ MOVE B,TBINIT+1(B) ; AND BASE FRAME
+FRM4: HLL B,OTBSAV(B) ;TIME
+ HRLI A,TFRAME
+ POPJ P,
+
+OKFRT: AOS (P) ;ASSUME WINNAGE
+ GETYP 0,(AB)
+ MOVE A,(AB)
+ MOVE B,1(AB)
+ CAIE 0,TFRAME
+ CAIN 0,TENV
+ POPJ P,
+ CAIE 0,TPVP
+ CAIN 0,TACT
+ POPJ P,
+ SOS (P)
+ POPJ P,
+
+CHPROC: GETYP 0,A ; TYPE
+ CAIE 0,TPVP
+ POPJ P, ; OK
+ MOVEI A,PVLNT*2+1(B)
+ CAMN B,PVSTOR+1 ; THIS PROCESS?
+ JRST CHPRO1
+ MOVE B,TBSTO+1(B)
+ JRST FRM4
+
+CHPRO1: MOVE B,OTBSAV(TB)
+ JRST FRM4
+
+; FUNCTION TO RETURN ARGS TUPLE FOR A FRAME
+
+MFUNCTION ARGS,SUBR
+ ENTRY 1
+ PUSHJ P,OKFRT ; CHECK FRAME TYPE
+ JRST WTYP1
+ PUSHJ P,CARGS
+ JRST FINIS
+
+CARGS: PUSHJ P,CHPROC
+ PUSH TP,A
+ PUSH TP,B
+ MOVEI B,-1(TP) ; POINT TO FRAME SLOT
+ PUSHJ P,CHFRM ; AND CHECK FOR VALIDITY
+ MOVE C,(TP) ; FRAME BACK
+ MOVSI A,TARGS
+CARGS1: GETYP 0,FSAV(C) ; IS THIS A FUNNY ONE
+ CAIE 0,TCBLK ; SKIP IF FUNNY
+ JRST .+3 ; NO NORMAL
+ MOVE C,OTBSAV(C) ; ASSOCIATE WITH PREVIOUS FRAME
+ JRST CARGS1
+ HLR A,OTBSAV(C) ; TIME IT AND
+ MOVE B,ABSAV(C) ; GET POINTER
+ SUB TP,[2,,2] ; FLUSH CRAP
+ POPJ P,
+
+; FUNCTION TO RETURN FUNCTION ASSOCIATED WITH A FRAME
+
+MFUNCTION FUNCT,SUBR
+ ENTRY 1 ; FRAME ARGUMENT
+ PUSHJ P,OKFRT ; CHECK TYPE
+ JRST WTYP1
+ PUSHJ P,CFUNCT
+ JRST FINIS
+
+CFUNCT: PUSHJ P,CHPROC
+ PUSH TP,A
+ PUSH TP,B
+ MOVEI B,-1(TP)
+ PUSHJ P,CHFRM ; CHECK IT
+ MOVE C,(TP) ; RESTORE FRAME
+ HRRZ A,FSAV(C) ;FUNCTION POINTER
+ CAIL A,HIBOT
+ SKIPA B,@-1(A) ;NO, GET SUBR'S NAME POINTER
+ MOVE B,(A)+3 ;YES, GET RSUBR'S NAME ENTRY
+ MOVSI A,TATOM
+ SUB TP,[2,,2]
+ POPJ P,
+
+BADFRAME:
+ ERRUUO EQUOTE FRAME-NO-LONGER-EXISTS
+
+
+TOPLOSE:
+ ERRUUO EQUOTE TOP-LEVEL-FRAME
+
+
+\f
+\f
+; ROUTINE TO HANG INDEFINITELY WITH INTERRUPTS ENABLED
+
+MFUNCTION HANG,SUBR
+
+ ENTRY
+
+ JUMPGE AB,HANG1 ; NO PREDICATE
+ CAMGE AB,[-3,,]
+ JRST TMA
+ 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 MAIN LOOP AND GLOBALLY REFERENCED SUBROUTINES
+
+RELOCA
+
+.GLOBAL TBINIT,PIDSTO,PROCID,PTIME,GCPDL,PBASE,TYPTOP,RERR,FRMSTK,EMERGE
+.GLOBAL PDLBUF,INTINT,START,SWAP,ICR,SPBASE,TPBASE,TPBAS,CURPRI,CHFINI,MKTBS
+.GLOBAL TOPLEVEL,INTOBL,INITIA,ERROBL,MAINPR,RESFUN,STATUS,TYPVEC,ROOT,TTICHN,TTOCHN
+.GLOBAL TTYOPE,MOPEN,MCLOSE,MIOT,ILVAL,MESS,ERROR,CHFRM,IGVAL,TYPBOT,ASOVEC
+.GLOBAL PRINT,PRIN1,PRINC,MUDSTR,VECBOT,CSTACK,IFALSE,TYPLOO,RCALL,SWAPIN,CTMPLT
+.GLOBAL IDPROC,CHFSWP,ILOC,MAKACT,BNDV,SPECSTORE,BINDID,IGLOC,MTYO,MSGTYP,CAFRE1,CPOPJ
+.GLOBAL EVATYP,EVTYPE,APLTYP,APTYPE,PRNTYP,PRTYPE,AGC,SGSNAM,NAPT,APLQ,STRTO6
+.GLOBAL 6TOCHS,TYPFND,STBL,CHNL0,N.CHNS,CLOSAL,%LOGOUT,%SSNAM,%RSNAM,%KILLM,SAT
+.GLOBAL MAKINF,%VALRET,COMPERR,IPUT,IGET,TMATCH,INITIZ,IPCINI,%UNAM,%JNAM,%RUNAM,%RJNAM,%RXUNA,%RXJNA,%VALFI
+.GLOBAL NOTTY,DEMFLG,CFRAME,CARGS,CFUNCT,CITYPE,CTYPEQ,CPTYPE,CTYPEP,CUTYPE,
+.GLOBAL CCHUTY,RTFALS,PGINT,PURCLN,CTYPEC,CTYPEW,IDVAL1,CALLTY,MESSAG,INITFL,WHOAMI
+.GLOBAL %SLEEP,%HANG,%TOPLQ,ONINT,CHUNW,CURFCN,BUFRIN,TD.LNT,TD.GET,TD.AGC,TD.PUT,MPOPJ
+.GLOBAL PURVEC,PLOAD,SSPECS,OUTRNG,CVTYPE,FSTART,CKVRS,CPRTYC,PVSTOR,SPSTOR
+.GLOBAL TYPIC,CISET,LSTUF,IMPURI,REALTV
+.INSRT MUDDLE >
+
+;MAIN LOOP AND STARTUP
+
+START: MOVEI 0,0 ; SET NO HACKS
+ JUMPE 0,START1
+ TLNE 0,-1 ; SEE IF CHANNEL
+ JRST START1
+ MOVE P,GCPDL
+ MOVE A,0
+ PUSH P,A
+ PUSHJ P,CKVRS ; CHECK VERSION NUMBERS
+ POP P,A
+ JRST FSTART ; GO RESTORE
+START1: MOVEM 0,WHOAMI ; HACK FOR TS FOO linked to TS MUDDLE
+ MOVE PVP,MAINPR ; MAKE SURE WE START IN THE MAIN PROCESS
+ JUMPE 0,INITIZ ; MIGHT BE RESTART
+ MOVE P,PSTO+1(PVP) ; SET UP FOR BOOTSTRAP HACK
+ MOVE TP,TPSTO+1(PVP)
+INITIZ: MOVE PVP,MAINPR
+ SKIPN P ; IF NO CURRENT P
+ MOVE P,PSTO+1(PVP) ; PDL TO GET OFF THE GROUND
+ SKIPN TP ; SAME FOR TP
+ MOVE TP,TPSTO+1(PVP) ; GET A TP TO WORK WITH
+ SETZB R,M ; RESET RSUBR AC'S
+ PUSHJ P,%RUNAM
+ JFCL
+ PUSHJ P,%RJNAM
+ PUSHJ P,TTYOPE ;OPEN THE TTY
+ MOVEI B,MUDSTR
+ SKIPE WHOAMI ; SKIP IF THIS IS MUDDLE
+ JRST NODEMT ; ELSE NO MESSAGE
+ SKIPE DEMFLG ; SKIP IF NOT DEMON
+ JRST NODEMT
+ SKIPN NOTTY ; IF NO TTY, IGNORE
+ PUSHJ P,MSGTYP ;TYPE OUT TO USER
+
+NODEMT: XCT MESSAG ;MAYBE PRINT A MESSAGE
+ PUSHJ P,INTINT ;INITIALIZE INTERRUPT HANDLER
+ XCT IPCINI
+ PUSHJ P,PURCLN ; CLEAN UP PURE SHARED AREA
+RESTART: ;RESTART A PROCESS
+STP: MOVEI C,0
+ MOVE PVP,PVSTOR+1
+ MOVE B,TBINIT+1(PVP) ;POINT INTO STACK AT START
+ PUSHJ P,CHUNW ; LEAVE WHILE DOING UNWIND CHECK
+ 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
+
+.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
+
+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: CAML B,PURBTB(A) ; if this one is larger
+ 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,[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
+
+ 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: CAMG 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
+ 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 B,PURVEC+1 ; get pointer to table
+CLN1: SETZM FB.PTR(B) ; zero pointer entry
+ SETZM FB.AGE(B) ; zero link and age slots
+ SETZM FB.PGS(B)
+ ADD B,[ELN,,ELN] ; go to next slot
+ JUMPL B,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
+ 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: MOVSI B,-OLN ; for checking more ins
+ PUSH P,C
+
+OBLFI1: AOBJP C,OBLFXX
+ MOVE A,(C)
+ AND A,OMSK(B)
+ CAME A,OINS(B)
+ JRST OBLFXX
+ AOBJN B,OBLFI1
+ JRST DOOBFX
+
+OBLFXX: MOVSI B,-OLN2 ; for checking more ins
+ MOVE C,(P)
+
+OBLFX1: AOBJP C,OBLFI2
+ MOVE A,(C)
+ AND A,OMSK2(B)
+ CAME A,OINS2(B)
+ JRST OBLFI2
+ AOBJN B,OBLFX1
+
+INSBP==331100 ; byte pointer for ins field
+ACBP==270400 ; also for ac
+INDXBP==220400
+
+DOOBFX: POP P,C
+ 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)
+ HLLOM B,5(C) ; in goes HRLI -1
+ MOVSI B,(CAIA) ; skipper
+ EXCH B,6(C)
+ MOVEM B,7(C)
+ ADD C,[7,,7]
+ JRST SFIX3
+
+OBLFI2: POP P,C
+ JRST SFIX3
+
+; Here to fixup compiled LENGTH
+
+LFIX: MOVSI B,-LLN ; for checking other LENGTH ins
+ PUSH P,C
+
+LFIX1: AOBJP C,OBLFI2
+ MOVE A,(C)
+ AND A,LMSK(B)
+ CAME A,LINS(B)
+ JRST OBLFI2
+ 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
+
+; 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
+ CAIE A,M ; check for just index
+ 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 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 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
+
+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
+
+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 B,PURVEC+1 ; get pointer to table
+CLN1: SETZM FB.PTR(B) ; zero pointer entry
+ SETZM FB.AGE(B) ; zero link and age slots
+ SETZM FB.PGS(B)
+ ADD B,[ELN,,ELN] ; go to next slot
+ JUMPL B,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,LFIXX
+ MOVE A,(C)
+ AND A,LMSK(B)
+ CAME A,LINS(B)
+LFIXX: PUSHJ P,OBLFI2 ; never POPJs, just to make P stack in good
+ ; state
+ 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
+
+; 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
+
+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
+
+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 B,PURVEC+1 ; get pointer to table
+CLN1: SETZM FB.PTR(B) ; zero pointer entry
+ SETZM FB.AGE(B) ; zero link and age slots
+ SETZM FB.PGS(B)
+ ADD B,[ELN,,ELN] ; go to next slot
+ JUMPL B,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
+
+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 B,PURVEC+1 ; get pointer to table
+CLN1: SETZM FB.PTR(B) ; zero pointer entry
+ SETZM FB.AGE(B) ; zero link and age slots
+ SETZM FB.PGS(B)
+ ADD B,[ELN,,ELN] ; go to next slot
+ JUMPL B,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
+
+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
+
+TITLE MAPS -- MAP FUNCTIONS FOR MUDDLE
+
+RELOCATABLE
+
+.INSRT MUDDLE >
+
+.GLOBAL TYPSEG,NXTLM,NAPT,APLQ,INCR1,SPECBI,FRMSTK,MAPPLY
+.GLOBAL CHFSWP,SSPEC1,ILVAL,CHUNW,DSTORE,PVSTOR,TVSTOR
+
+; PSTACK OFFSETS
+
+INCNT==0 ; INNER LOOP COUNT
+LISTNO==-1 ; ARG NUMBER BEING HACKED
+ARGCNT==-2 ; FINAL ARG COUNTER
+NARGS==-3 ; NUMBER OF STRUCTURES
+NTHRST==-4 ; 0=> MAP REST, OTHERWISE MAP FIRST
+
+; MAP THE "CAR" OF EACH LIST
+
+IMFUNCTION MAPF,SUBR
+
+ PUSH P,. ; PUSH NON-ZERO
+ JRST MAP1
+
+; MAP THE "CDR" OF EACH LIST
+
+IMFUNCTION MAPR,SUBR
+
+ PUSH P,[0]
+
+MAP1: ENTRY
+ HLRE C,AB ; HOW MANY ARGS
+ ASH C,-1 ; TO # OF PAIRS
+ ADDI C,2 ; AT LEAST 3
+ JUMPG C,TFA ; NOT ENOUGH
+ GETYP A,(AB) ; TYPE OF CONSTRUCTOR
+ CAIN A,TFALSE ; ANY CONSING NEEDE?
+ JRST MAP2 ; NO, SKIP CHECK
+ PUSHJ P,APLQ ; CHECK IF APPLICABLE
+ JRST NAPT ; NO, ERROR
+MAP2: MOVNS C ; POS NO. OF ARGS (-3)
+ PUSH P,C ; SAVE IT
+ PUSH TP,[TATOM,,-1] ; ALL **GFP** INSTRUCTIONS ARE TO DO WITH MAPRET
+ PUSH TP,IMQUOTE LMAP,[LMAP ]INTRUP
+ PUSHJ P,FRMSTK ; **GFP**
+ PUSH TP,[0] ; **GFP**
+ PUSH TP,[0] ; **GFP**
+ PUSHJ P,SPECBIND ; **GFP**
+ MOVE C,(P) ; RESTORE COUNT OF ARGS
+ MOVE A,AB ; COPY ARG POINTER
+ MOVSI 0,TAB ; CLOBBER A'S TYPE
+ MOVE PVP,PVSTOR+1
+ MOVEM 0,ASTO(PVP)
+ JUMPE C,ARGSDN ; NOA ARGS?
+
+ARGLP: INTGO ; STACK MAY OVERFLOW
+ PUSH TP,4(A) ; SKIP FCNS
+ PUSH TP,5(A)
+ ADD A,[2,,2]
+ SOJG C,ARGLP ; ALL UP ON STACK
+
+; ALL STRUCTURES ARE ON THE STACK, NOW PUSH THE CONSTRUCTOR
+
+ARGSDN: PUSH TP,(AB) ; CONSTRUCTOR
+ PUSH TP,1(AB)
+ MOVE PVP,PVSTOR+1
+ SETZM ASTO(PVP)
+ PUSH P,[-1] ; FUNNY TEMPS
+ PUSH P,[0]
+ PUSH P,[0]
+
+; OUTER LOOP CDRING EACH STRUCTURE
+
+OUTRLP: SETZM LISTNO(P) ; START AT 0TH LIST
+ MOVE 0,NARGS(P) ; TOTAL # OF STRUCS
+ MOVEM 0,INCNT(P) ; AS COUNTER IN INNER LOOP
+ PUSH TP,2(AB) ; PUSH THE APPLIER
+ PUSH TP,3(AB)
+
+; INNER LOOP, CONS UP EACH APPLICATION
+
+INRLP: INTGO
+ SOSGE INCNT(P)
+ JRST INRLP2
+ MOVEI E,2 ; READY TO BUMP LISTNO
+ ADDB E,LISTNO(P) ; CURRENT STORED AND IN C
+ ADDI E,(TB)4 ; POINT TO A STRUCTURE
+ MOVE A,(E) ; PICK IT UP
+ MOVE B,1(E) ; AND VAL
+ PUSHJ P,TYPSEG ; SETUP TO REST IT ETC.
+ MOVE E,LISTNO(P)
+ ADDI E,4(TB)
+ SKIPL ARGCNT(P) ; DONT INCR THE 1ST TIME
+ XCT INCR1(C) ; INCREMENT THE LOSER
+ MOVE 0,DSTORE ; UPDATE THE LIST
+ MOVEM 0,(E)
+ MOVEM D,1(E) ; CLOBBER AWAY
+ PUSH TP,DSTORE ; FOR REST CASE
+ PUSH TP,D
+ PUSHJ P,NXTLM ; SKIP IF GOT ONE, ELSE DONT
+ JRST DONEIT ; FINISHED
+ SETZM DSTORE
+ SKIPN NTHRST(P) ; SKIP IF MAP REST
+ JRST INRLP1
+ MOVEM A,-1(TP) ; IUSE AS ARG
+ MOVEM B,(TP)
+INRLP1: JRST INRLP ; MORE, GO DO THEM
+
+
+; ALL ARGS PUSHED, APPLY USER FCN
+
+INRLP2: SKIPGE ARGCNT(P) ; UN NEGATE ARGCNT
+ SETZM ARGCNT(P)
+ MOVE A,NARGS(P) ; GET # OF ARGS
+ ADDI A,1
+ ACALL A,MAPPLY ; APPLY THE BAG BITER
+
+ GETYP 0,(AB) ; GET TYPE OF CONSTRUCTOR
+ CAIN 0,TFALSE ; SKIP IF ONE IS THERE
+ JRST OUTRL1
+ PUSH TP,A
+ PUSH TP,B
+ AOS ARGCNT(P)
+ JRST OUTRLP
+
+OUTRL1: MOVEM A,-1(TP) ; SAVE PARTIAL VALUE
+ MOVEM B,(TP)
+ JRST OUTRLP
+
+; HERE IF ALL FINISHED
+
+DONEIT: HRLS C,LISTNO(P) ; HOW MANY DONE
+ SUB TP,[2,,2] ; FLUSH SAVED VAL
+ SUB TP,C ; FLUSH TUPLE OF CRUFT
+DONEI1: SKIPGE ARGCNT(P)
+ SETZM ARGCNT(P) ; IN CASE STILL NEGATIVE
+ SETZM DSTORE ; UNSCREW
+ GETYP 0,(AB) ; ANY CONSTRUCTOR
+ CAIN 0,TFALSE
+ JRST MFINIS ; NO, LEAVE
+ AOS D,ARGCNT(P) ; IF NO ARGS
+ ACALL D,APPLY ; APPLY IT
+
+ JRST FINIS
+
+; HERE TO FINISH IF CONSTRUCTOR WAS #FALSE ()
+
+MFINIS: POP TP,B
+ POP TP,A
+ JRST FINIS
+
+; **GFP** FROM HERE TO THE END
+
+MFUNCTION MAPLEAVE,SUBR
+
+ ENTRY
+
+ CAMGE AB,[-3,,0]
+ JRST TMA
+ MOVE B,IMQUOTE LMAP,[LMAP ]INTRUP
+ PUSHJ P,ILVAL
+ GETYP 0,A
+ CAIE 0,TFRAME ; MAKE SURE WINNER
+ JRST NOTM
+ PUSH TP,A
+ PUSH TP,B
+ MOVEI B,-1(TP) ; POINT TO FRAME POINTER
+ PUSHJ P,CHFSWP
+ PUSHJ P,CHUNW
+ JUMPL C,MAPL1 ; RET VAL SUPPLIED
+ MOVSI A,TATOM
+ MOVE B,IMQUOTE T
+ JRST FINIS
+
+MAPL1: MOVE A,(C)
+ MOVE B,1(C)
+ JRST FINIS
+
+MFUNCTION MAPSTOP,SUBR
+
+ ENTRY
+
+ PUSH P,[1]
+ JRST MAPREC
+
+MFUNCTION MAPRET,SUBR
+
+ ENTRY
+
+ PUSH P,[0]
+MAPREC: MOVE B,IMQUOTE LMAP,[LMAP ]INTRUP
+ PUSHJ P,ILVAL ; GET VALUE
+ GETYP 0,A ; FRAME?
+ CAIE 0,TFRAME
+ JRST NOTM
+ PUSH TP,A
+ PUSH TP,B
+ MOVEI B,-1(TP)
+ POP P,0 ; RET/STOP SWITCH
+ JUMPN 0,MAPRC1 ; JUMP IF STOP
+ PUSHJ P,CHFSWP ; CHECK IT OUT (AND MAYBE SWAP)
+ PUSH P,[NLOCR]
+ JRST MAPRC2
+MAPRC1: PUSHJ P,CHFSWP
+ PUSH P,[NLOCR1]
+MAPRC2: HRRZ E,SPSAV(B) ; UNBIND BEFORE RETURN
+ PUSH TP,$TAB
+ PUSH TP,C
+ ADDI E,1 ; FUDGE FOR UNBINDER
+ PUSHJ P,SSPEC1 ; UNBINDER
+ HLRE D,(TP) ; FIND NUMBER
+ JUMPE D,MAPRE1 ; SKIP IF NONE TO MOVE
+ MOVNS E,D ; AND PLUS IT
+ HRLI E,(E) ; COMPUTE NEW TP
+ ADD E,TPSAV(B) ; NEW TP
+ HRRZ C,TPSAV(B) ; GET OLD TOP
+ MOVEM E,TPSAV(B)
+ HRL C,(TP) ; AND NEW BOT
+ ADDI C,1
+ BLT C,(E) ; BRING IT ALL DOWN
+MAPRE1: ASH D,-1 ; NO OF ARGS
+ HRRI TB,(B) ; PREPARE TO FINIS
+ MOVSI A,TFIX
+ MOVEI B,(D)
+ POP P,0 ; GET PC TO GO TO
+ MOVEM 0,PCSAV(TB)
+ JRST CONTIN ; BACK TO MAPPER
+
+NLOCR1: TDZA A,A ; ZER SW
+NLOCR: MOVEI A,1
+ GETYP 0,(AB) ; CHECK IF BUILDING
+ CAIN 0,TFALSE
+ JRST FLUSHM ; REMOVE GOODIES
+ ADDM B,ARGCNT(P) ; BUMP ARG COUNTER
+NLOCR2: JUMPE A,DONEI1
+ JRST OUTRLP
+
+FLUSHM: ASH B,1 ; FLUSH GOODIES DROPPED
+ HRLI B,(B)
+ SUB TP,B
+ JRST NLOCR2
+
+NOTM: ERRUUO EQUOTE NOT-IN-MAP-FUNCTION
+
+END
+\f\ 3\f
\ No newline at end of file
--- /dev/null
+MPURE.BIN\eL
+MSPECS.BIN\eL
+MCONST.BIN\eL
+MLDGC.BIN\eL
+MUTILIT.BIN\eL
+MUUOH.BIN\eL
+MMUDEX.BIN\eL
+MMAPPUR.BIN\eL
+MCORE.BIN\eL
+MATOMHK.BIN\eL
+MINTERR.BIN\eL
+MNFREE.BIN\eL
+MGCHACK.BIN\eL
+MREADCH.BIN\eL
+MAGCMRK.BIN\eL
+MREADER.BIN\eL
+MPRINT.BIN\eL
+MBUFMOD.BIN\eL
+MARITH.BIN\eL
+MMAPS.BIN\eL
+MPRIMIT.BIN\eL
+MSTBUIL.BIN\eL
+MEVAL.BIN\eL
+MDECL.BIN\eL
+MMAIN.BIN\eL
+MMUDSQU.BIN\eL
+MFOPEN.BIN\eL
+MPUTGET.BIN\eL
+MCREATE.BIN\eL
+MSAVE.BIN\eL
+MAGC.BIN\eL
+MAMSGC.BIN\eL
+MSECAGC.BIN\eL
+MINITM.BIN\eL?\e\e
+\f
\ No newline at end of file
--- /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==0
+; 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 MUDEX -- TENEX DEPENDANT MUDDLE CODE
+
+RELOCATABLE
+
+.INSRT MUDDLE >
+.INSRT STENEX >
+
+MFORK==400000
+XJRST==JRST 5,
+
+.GLOBAL %SSNAM,%RSNAM,%KILLM,%LOGOU,%SLEEP,%VALRE,NOTTY,DEMFLG,MSGTYP,TTYOP2
+.GLOBAL %UNAM,%XUNA,%JNAM,%XJNA,%RUNAM,%RXUNA,%RJNAM,%RXJNA,%GCJOB,%VALFI
+.GLOBAL %SHWND,%SHFNT,%GETIP,%INFMP,SGCLBK,TWENTY,MULTSG,MLTUUP
+.GLOBAL GCHN,WNDP,FRNP,MESSAG,INITFL,6TOCHS,SGSNAM,MTYO,PGINT,WHOAMI
+.GLOBAL %TOPLQ,IBLOCK,TMTNXS,TNXSTR,%HANG,ILLUUO,UUOH,IPCINI,CTIME,BFLOAT
+.GLOBAL GCRSET,%MPINT,%GBINT,%CLSMP,%GCJB1,%CLMP1,%SAVIN,%MPIN,%MPIN1,%IMSV1
+.GLOBAL %PURIF,%MPINX,%CLSJB,%KILJB,%IFMP1,%OPGFX,STOSTR,%SAVRP,%RSTRP,GETSQU
+.GLOBAL WIND,%FDBUF,%CWINF,P.TOP,BUFGC,PURBOT,%IFMP2,%CLSM1,GETBUF,KILBUF
+.GLOBAL CERR1,CERR2,CERR3,COMPERR,CALER1,%LDRDO,%MPRDO,SQBLK,SQLOD,SQKIL,GETSQU
+.GLOBAL SQUPNT,SFRK,IJFNS,GETJS,OPBLK,SJFNS,OPSYS,GCLDBK,ILDBLK,IJFNS1,TILDBL
+.GLOBAL TBINIT,PVSTOR,SECBLK,PURCLN,NSEGS,INTINT,PURBTB,%CLNCO,OUTRNG
+.GLOBAL MULTI,NOMULT,THIBOT
+.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
+
+GCHN==0
+CTTRAP==1000
+CTEXST==10000
+CTREAD==100000
+CTEXEC==20000
+CTWRIT==40000
+CTCW==400
+
+MFORK==400000
+CTREAD==100000 ; READ BIT
+CTEXEC==20000 ; EXECUTE BIT
+CTWRIT==40000 ; WRITE BIT
+CTCW==400 ; COPY ON WRITE
+
+
+FREAD==200000 ; READ BIT FOR OPENF
+FEXEC==40000 ; EXEC BIT FOR OPENF
+FTHAW==2000
+FWRITE==100000
+
+GJ%SHT==1 ; SHORT FORM GTJFN
+GJ%OLD==100000 ; FILE MUST EXIST
+OP%36B==440000 ; 36 BIT BYTES
+OP%7B==700000 ; 7 BIT BYTES
+CR%CAP==200000
+
+SQLOD: MOVEI A,1
+ JRST @[.+1] ; RUN IN 0 FOR BIZARRE BUGS
+ PUSHJ P,GETBUF
+ HRRM B,SQUPNT
+ HLRZ A,SJFNS
+ JUMPE A,SQLOD1
+ HRRZS SJFNS
+ CLOSF
+ JFCL
+SQLOD1: HRROI B,SQBLK
+ SKIPE OPSYS
+ HRROI B,TSQBLK
+ MOVSI A,GJ%SHT+GJ%OLD
+ GTJFN
+ FATAL CANT GET SQUOZE
+ HRLM A,SJFNS
+ MOVEI D,(A)
+ MOVE B,[OP%36B,,FREAD]
+ OPENF
+ FATAL CANT OPEN SQUOZE
+ SIZEF
+ FATAL CANT SIZEF SQUOZE
+ MOVSI A,(D)
+ MOVNS B
+ HRLM B,SQUPNT
+ HRRZ B,SQUPNT
+ ASH B,-9.
+ HRLI B,MFORK
+ MOVSI C,CTREAD+CTEXEC
+
+ PMAP
+ ADDI A,1
+ ADDI B,1
+ PMAP
+ MOVEI A,(D)
+ CLOSF
+ JFCL
+ SKIPN MULTSG
+ POPJ P,
+ POP P,B
+ MOVEI A,0
+ XJRST A
+
+
+SQKIL: PUSHJ P,KILBUF
+ HLLZS SQUPNT
+CPOPJ:
+%PURIF:
+%GETIP: POPJ P,
+
+GETSQU: HRRZ 0,SQUPNT
+ JUMPN 0,CPOPJ
+ JRST SQLOD
+
+
+CTIME: SKIPE OPSYS ; skip if TOPS20
+ JRST .+4
+ MOVEI A,400000
+ RUNTM
+ JRST .+2
+ JOBTM ; get run time in milli secs
+ IDIVI A,400000
+ FSC B,233
+ FSC A,254
+ FADR B,A
+ FDVRI B,(1000.0) ; Change to units of seconds
+ MOVSI A,TFLOAT
+ POPJ P,
+
+; THE GLOBAL SNAME
+
+%RSNAM: PUSHJ P,TMTNXS ; GET STRING ON STACK (POINTER IN E)
+ GJINF ; USER NUMBER IS IN A
+ PUSHJ P,INFSTR ; MAKE INFO STRING
+
+%SSNAM: POPJ P,
+
+; KILL THE CURRENT JOB
+
+%VALFI:
+%KILLM: HALTF
+ POPJ P,
+
+; STRING IS IN A
+%VALRE: HRROS A
+ RSCAN ; PASS STRING
+ JFCL
+ MOVEI A,0
+ RSCAN ; MAKE IT AVAILABLE FOR USE
+ JFCL
+ JRST %KILLM
+
+; LOGOUT OF SYSTEM (MUST BE "TOP LEVEL")
+
+%LOGOU: LGOUT
+ POPJ P,
+
+; GO TO SLEEP A WHILE
+
+%SLEEP: IMULI A,33. ; TO MILLI SECS
+ DISMS
+ POPJ P,
+
+; HANG FOR EVER
+
+%HANG: WAIT
+
+; READ JNAME
+
+%RXJNA:
+%RJNAM: GETNM ; RETURNS SIXBIT IN A
+ MOVEM A,%JNAM
+ POPJ P,
+
+; READ UNAME
+
+%RXUNA:
+%RUNAM: PUSHJ P,TMTNXS ; GET STRING ON STACK (POINTER IN E)
+ GJINF ; USER NUMBER IS IN A
+ MOVE B,A ; USER NUMBER TO B
+ PUSHJ P,INFST1 ; MAKE INFO STRING
+CPOPJ1: AOS (P) ; SKIP RETURN
+ POPJ P,
+
+; MAKE A STRING FROM DIRST GOODIES
+INFSTR: TDZA 0,0
+INFST1: MOVEI 0,1 ; FLAG WHETHER TO SCAN
+ HRROI A,1(E) ; STRING POINTER IN A
+ DIRST ; GET THE NAME
+ FATAL ATTACHED DIRECTORY DOESN'TEXIST
+ MOVEI B,1(E) ; A AND B BOUND STRING
+ JUMPN 0,INFST2 ; NO NEED TO SCAN
+ SKIPE OPSYS
+ JRST INFST2
+
+ HRLI B,440700
+ MOVE A,B
+
+ ILDB 0,B ; FLUSH : AND <>
+ CAIE 0,"<
+ JRST .-2
+
+ ILDB 0,B
+ CAIN 0,">
+ JRST .+3
+ IDPB 0,A
+ JRST .-4
+
+ MOVE B,A
+ MOVEI 0,0
+ IDPB 0,B
+ MOVEI B,1(E)
+
+
+INFST2: SUBM P,E ; RELATIVIZE E
+ PUSHJ P,TNXSTR ; BUILD STRING (IN A AND B)
+ MOVE C,(P) ; GET RETURN PC FROM PUSHJ
+ SUB P,E ; P BACK TO NORMAL
+ JRST (C)
+
+; HERE TO SEE IF WE ARE A TOP LEVEL JOB
+
+%TOPLQ: GJINF
+ JUMPL D,CPOPJ1
+ JRST CPOPJ
+
+; ERRORS IN COMPILED CODE MAY END UP HERE
+
+CERR1: ERRUUO EQUOTE NEGATIVE-ARGUMENT
+
+CERR2: ERRUUO EQUOTE NTH-REST-PUT-OUT-OF-RANGE
+
+CERR3: ERRUUO EQUOTE UVECTOR-PUT-TYPE-VIOLATION
+
+COMPERR:
+ ERRUUO EQUOTE ERROR-IN-COMPILED-CODE
+
+\f
+; GET AN INFERIOR FOR THE GARBAGE COLLECTOR
+
+%GCJOB: PUSH P,A
+ MOVEI A,CR%CAP ; GET BITS FOR FORK
+ CFORK ; MAKE AN IFERIOR FORK
+ FATAL CANT GET GC FORK
+ MOVEM A,GCFRK ; SAVE HANDLE
+ POP P,A ; RESTORE PAGE
+ MOVEI B,FRNP
+ PUSHJ P,%SHWND
+ POPJ P,
+
+; HERE TO SHARE WINDOW
+
+%SHWNF: PUSH P,0
+ MOVE 0,GCFK1
+ JRST SHWND1
+
+%SHWND: PUSH P,0
+ MOVE 0,GCFRK
+
+SHWND1: PUSH P,A
+ PUSH P,B
+ PUSH P,C
+ ASH B,1 ; TO CRETINOUT TENEX PAGE SIZE
+ HRLI B,MFORK
+ ASH A,1 ; TIMES 2
+ HRL A,0
+ MOVSI C,CTREAD+CTWRIT ; READ AND WRITE ACCESS
+
+ PMAP
+ ADDI A,1
+ ADDI B,1
+ PMAP
+ ASH B,9. ; POINT TO PAGE
+ MOVES (B) ; CLOBBER TOP
+ MOVES -1(B) ; AND UNDER
+ POP P,C
+ POP P,B
+ POP P,A
+ POP P,0
+ POPJ P,
+
+; HERE TO MAP INFERIOR BACK AND KILL SAME
+
+%INFMP: PUSH P,C
+ PUSH P,D
+ PUSH P,E
+ ASH A,1
+ ASH B,1
+ MOVE D,A ; POINT TO PAGES
+ MOVE E,B ; FOR COPYING
+ PUSH P,A ; SAVE FOR TOUCHING
+
+; HERE FOR OPTIONAL MULTI FORK HACK
+
+ SKIPLE A,SFRK ; SKIP NOT ENABLED OR NOT ACTIVE
+ KFORK ; FLUSH THE OLD EXTRA
+
+ MOVS A,GCFRK
+ SKIPE SFRK ; SKIP IF NOT MULTI FORK
+ HLRZM A,SFRK ; SAVE THIS AS IT
+ MOVSI B,MFORK
+ MOVSI C,CTREAD+CTEXEC+CTCW ; READ AND WRITE COPY
+ SKIPE SFRK
+ MOVSI C,CTREAD+CTEXEC+CTWRIT
+
+LP1: HRRI A,(E)
+ HRRI B,(D)
+ PMAP
+ ADDI E,1
+ AOBJN D,LP1
+
+; HERE TO TOUCH PAGES TO INSURE KEEPING THEM (KLUDGE)
+
+ POP P,E ; RESTORE MY FIRST PAGE #
+ SKIPE SFRK ; SKIP IF NOT MULTI CASE
+ JRST ALDON
+ MOVEI A,(E) ; COPY FOR LOOP
+ ASH A,9. ; TO WORD ADDR
+ MOVES (A) ; WRITE IT
+ AOBJN E,.-3 ; FOR ALL PAGES
+
+ MOVE A,GCFRK
+ KFORK
+ALDON: POP P,E
+ POP P,D
+ POP P,C
+ POPJ P,
+
+; HACK TO PRINT MESSAGE OF INTEREST TO USER
+
+MESOUT: MOVSI A,(JFCL)
+ MOVEM A,MESSAG ; DO ONLY ONCE
+ RESET
+ SKIPE SFRK
+ SETOM SFRK ; NO FORK TO HACK RIGGHT NOW
+ PUSHJ P,GETJS ; GET SOME JFNS
+
+ MOVEI A,400000
+ MOVE B,[1,,ILLUUO]
+ MOVE C,[40,,UUOH]
+ SCVEC
+ SETZB SP,FRM ; HACK TO AVOID LOSSAGE WITH GARBAGE IN SP
+ ; FIRST TIME
+ PUSHJ P,GCRSET
+ MOVE A,[MFORK,,THIBOT]
+ MOVSI B,CTREAD+CTEXEC
+ MOVEI 0,777-THIBOT
+ SPACS
+ ADDI A,1
+ SOJGE 0,.-2
+ PUSHJ P,PGINT ; INITIALIZE PAGE MAP
+ GJINF
+ AOJN D,.+3 ; JUMP IF HAS TTY
+ SETOM DEMFLG
+ SETOM NOTTY
+ SKIPN DEMFLG
+ JRST TTON
+ MOVEI A,MFORK ; GET FORK HANDLE
+ RPCAP
+ MOVE C,B ; HAIR TO ENABLE CAPABILITIES OF DEMON
+ EPCAP
+TTON: PUSHJ P,TTYOP2
+ SKIPN DEMFLG ; SKIP IF DEMON
+ SKIPE NOTTY ; HAVE A TTY?
+ JRST RESNM ; NO, SKIP THIS STUFF
+
+ MOVEI A,MESBLK
+ MOVEI B,0
+ GTJFN
+ JRST RESNM
+ MOVE B,[OP%7B,,FREAD]
+ OPENF
+ JRST RESNM
+
+MSLP: BIN
+ MOVE D,B ; SAVE BYTE
+ GTSTS
+ TLNE B,1000
+ JRST RESNM
+ EXCH D,A
+ CAIN A,14
+ PBOUT
+ MOVE A,D
+ JRST MSLP
+
+RESNM2: CLOSF
+IPCINI: JFCL
+
+RESNM: PUSHJ P,TWENTY
+RESNM1: SKIPN MULTSG
+ POPJ P,
+ POP P,C ; STAY IN MAIN SEG
+ HRLI C,FSEG
+ JRST (C)
+
+\f
+; GET JFNS TO MDL INTERPRETER, AGC AND SGC, SAVE IN IJFNS AND IJFNS1
+GETJS: MOVEI A,$TLOSE
+ LSH A,-11
+ HRLI A,MFORK ; THIS FORK
+ RMAP
+ JUMPGE A,GETJS1 ; HAPPY?
+; HERE TO GET MDL INTERPRETER JFN EXPLICITLY RATHER THAN THROUGH RMAP
+ HRROI B,ILDBLK
+ SKIPE OPSYS
+ HRROI B,TILDBL
+ MOVSI A,GJ%SHT+GJ%OLD
+ GTJFN
+ FATAL INTERPRETER EXE FILE MISSING
+ MOVE B,[OP%36B,,FREAD+FWRITE]
+ OPENF
+ FATAL CANT OPEN MDL INTERPRETER EXE FILE
+ HRLM A,A
+GETJS1: HLRZM A,IJFNS ; SAVE JFN TO INTERPRETER
+ POPJ P,
+
+; GTJFN BLOCK FOR MESSAGE FILE
+MESBLK: 100000,,
+ 377777,,377777
+ -1,,[ASCIZ /DSK/]
+ -1,,[ASCIZ /MDL/]
+ -1,,[ASCIZ /MUDDLE/]
+ -1,,[ASCIZ /MESSAG/]
+ 0
+ 0
+ 0
+
+MUDINT: MOVSI 0,(JFCL) ; CLOBBER MUDDLE INIT SWITCH
+ MOVEM 0,INITFL
+
+; LOOP TO TOUCH ALL PAGES SO PURIFY CAN WORK
+
+ SKIPN A,DEMFLG ; SKIP IF A DEMON
+ JRST FINDIR ; GET USERS DIRECTORY
+ AOJE A,FINDIR
+ MOVE A,DEMFLG ; GET SIXBIT OF DIRECTORY NAME
+ PUSHJ P,6TOCHS ; TO CHARACACTER STRING
+ JRST DIRCON
+
+FINDIR: GJINF ; GET INFO NEEDED
+ MOVEM A,SJFNS
+ PUSHJ P,TMTNXS ; MAKE A TEMP STRING FOR TENEX INFO
+ ; (POINTER LEFT IN E)
+ PUSHJ P,INFSTR
+DIRCON: PUSH TP,$TATOM
+ PUSH TP,IMQUOTE SNM
+ PUSH TP,A
+ PUSH TP,B
+ MCALL 2,SETG
+ SKIPE WHOAMI
+ JRST SUBSYS
+ MOVE A,[SIXBIT/MUDDLE/]
+ PUSHJ P,6TOCHS ; MAKE A CHARACTER STRING
+ PUSH TP,$TCHSTR
+ PUSH TP,CHQUOTE READ
+ PUSH TP,A
+ PUSH TP,B
+ PUSH TP,$TCHSTR ; NOW THE .INIT
+ PUSH TP,CHQUOTE .INIT
+ MCALL 2,STRING ; MAKE A STRING
+ PUSH TP,A ; ARGS TO FOPEN
+ PUSH TP,B
+ MCALL 2,FOPEN
+ GETYP A,A
+ CAIN A,TCHAN
+ JRST ISVCHN
+SUBSYS: PUSH TP,$TCHSTR
+ PUSH TP,CHQUOTE READ
+ MOVE A,[SIXBIT /MUDDLE/]
+ SKIPE WHOAMI
+ MOVE A,WHOAMI
+ PUSHJ P,6TOCHS
+ PUSH TP,A
+ PUSH TP,B
+ PUSH TP,$TCHSTR
+ PUSH TP,CHQUOTE INIT
+ PUSH TP,$TCHSTR
+ PUSH TP,CHQUOTE DSK
+ PUSH TP,$TCHSTR
+ PUSH TP,CHQUOTE MUDDLE
+ MCALL 5,FOPEN
+ GETYP A,A
+ CAIE A,TCHAN
+ POPJ P,
+ISVCHN: PUSH TP,$TCHAN
+ PUSH TP,B
+ MOVEI B,INITSTR ; TELL USER WHAT'S HAPPENING
+ SKIPE WHOAMI
+ JRST INCOM
+ SKIPE DEMFLG ; SKIP IF NOT A DEMON
+ JRST INCOM
+ SKIPN NOTTY
+ PUSHJ P,MSGTYP
+INCOM: MCALL 1,MLOAD
+ POPJ P,
+
+TMTNXS: POP P,D ; SAVE RET ADDR
+ MOVE E,P ; BUILD A STRING SPACE ON PSTACK
+ MOVEI 0,20. ; USE 20 WORDS (=100 CHARS)
+ PUSH P,C%0
+ SOJG 0,.-1
+
+ JRST (D)
+
+
+TNXSTR: SUBI B,(P)
+ PUSH P,B
+ ADDI B,-1(P)
+ SUBI B,(A) ; WORDS TO B
+ IMULI B,5 ; TO CHARS
+ LDB 0,[360600,,A] ; GET BYTE POSITION
+ IDIVI 0,7 ; TO A REAL BYTE POSITION
+ MOVNS 0
+ ADDI 0,5
+ SUBM 0,B ; FINAL LENGTH IN BYTES TO B
+ PUSH P,B ; SAVE IT
+ MOVEI A,4(B) ; TO WORDS
+ IDIVI A,5
+ PUSH P,E ; SAVE E
+ PUSHJ P,IBLOCK ; GET STRING
+ POP P,E
+ POP P,A
+ POP P,C
+ ADDI C,(P)
+ MOVE D,B ; COPY POINTER
+ MOVE 0,(C) ; GET A WORD
+ MOVEM 0,(D)
+ ADDI C,1
+ AOBJN D,.-3
+
+ HRLI A,TCHSTR
+ HRLI B,00700 ; MAKE INTO BYTER
+ SOJA B,CPOPJ
+
+INITSTR: ASCIZ /MUDDLE INIT/
+
+; HERE TO RECOPY PAGE 0 WHICH CONTAINS IMFORMATION FOR REMAPPING IN INFERIOR
+%OPGFX: PUSH P,B ; SAVE B
+ PUSH P,A
+ MOVEI B,STOSTR ; TOP OF CONSTANTS
+ ADDI B,1777 ; ROUND
+ ANDCMI B,1777
+ ASH B,-10. ; TO PAGES
+ MOVN A,B
+ MOVEI B,WNDP ; GET WINDOW
+ HRLZS A ; START WITH PAGE 0
+OPGFX2: JUMPGE A,OPGFX1
+ PUSH P,A
+ HRRZS A
+ PUSHJ P,%SHWNF
+ HRRZ A,(P)
+ ASH A,10. ; TO START OF PAGE
+ HRLS A ; SET UP BLT POINTER
+ HRRI A,WIND
+ MOVEI B,WIND
+ BLT A,1777(B) ; OUT INTO THE BUFFER
+ POP P,A ; RESTORE A
+ AOBJN A,OPGFX2
+OPGFX1: POP P,A
+ POP P,B
+ POPJ P,
+
+; ROUTINE TO PROTECT A CORE IMAGE BY SAVING IT IN AN INFERIOR
+; A==FORK HANDLE B== AOBJN POINTER
+
+
+PROTCT: TRNN B,-1 ; SEE IF PAGE 0 IS INCLUDED
+ ADD B,C%11 ; INC PAGE
+ ASH B,1
+ PUSH P,C ; SAVE C
+ MOVE C,B ; COPY AOBJN
+ MOVSI A,MFORK ; FORK HANDLE
+ JUMPE C,PRTDON ; IF ZERO THEN WE ARE DONE
+PROTC1: HRRI A,(C) ; GET PAGE
+ HRRZ D,C
+ ASH D,9.
+ RPACS
+ TLNN B,CTWRIT+CTCW ; SKIP IF NOT READ ONLY
+ TLNN B,CTEXST ; SKIP IF EXISTS (OTHERWISE WE'LL CREATE IT)
+ MOVES 20(D) ; TOUCH PAGE
+ MOVSI B,CTREAD+CTEXEC ; SET UP TO MARK PAGES TO TRAP ON ANY REF
+ SPACS ; CHANGE MODE OF PAGE
+ AOBJN C,PROTC1
+PRTDON: POP P,C ; RESTORE C
+ POPJ P,
+
+%FDBUF: HRRZ A,PURBOT
+ SUB A,P.TOP ; CALCULATE ROOM FOR PROSPECTIVE BUFFER
+ CAIG A,2000 ; SEE IF ROOM
+ JRST FDBUF1
+ MOVE A,P.TOP ; START OF BUFFER
+ HRRM A,BUFGC
+ POPJ P,
+FDBUF1: SETOM BUFGC ; INDICATE NO BUFFER FOUND
+ POPJ P,
+
+; HERE TO SIMULATE A COPY ON WRITE TO AN INFERIOR. IF A PAGE HAS NO WRITE BITS
+; IT WILL COPY IT INTO THE GCFRK1 FORK. A== START OF PAGE, B== START OF BUFFER PAGE
+
+%CWINF: PUSH P,A
+ PUSH P,B ; SAVE AC'S
+ PUSH P,C
+ ANDI A,-1 ; CLEAN OUT LEFT HALF OF A
+ ASH A,-9. ; TO PAGES
+ PUSH P,C%0
+ HRLI A,MFORK ; GET FORK HANDLE
+ RPACS ; READ PAGE BITS
+ MOVEM B,(P)
+ TLNE B,CTEXST ; SKIP IF DOESN'T EXIST
+ TLNE B,CTWRIT ; SEE IF WRITABLE
+ JRST CWINFX ; NO, EXIT
+ MOVSI B,CTEXEC+CTREAD+CTCW
+ SPACS ; RESTORE PAGE TO NORMAL
+CWINFX: ADDI A,1
+ RPACS ; READ PAGE BITS
+ TLNE B,CTEXST ; SKIP IF DOESN'T EXIST
+ TLNE B,CTWRIT ; SEE IF WRITABLE
+ JRST CWINFY ; NO, EXIT
+ MOVSI B,CTEXEC+CTREAD+CTCW
+ SPACS
+ SUB P,C%11
+ JRST CWINFZ
+CWINFY: POP P,B
+ TLNE B,CTEXST ; SKIP IF DOESN'T EXIST
+ TLNE B,CTWRIT ; SEE IF WRITABLE
+ JRST CWINF1 ; NO, EXIT
+CWINFZ: HRRZI A,-1(A)
+ ASH A,-1
+ MOVE B,-1(P) ; SET UP BUFFER PAGE
+ ASH B,-10. ; TO PAGE NUMBER
+ PUSHJ P,%SHWNF ; SHARE A WINDOW
+ HRLZ A,-2(P) ; PREPARE FOR BLT
+ HRR A,-1(P)
+ HRRZ B,-1(P)
+ BLT A,1777(B) ; SAVE THE PAGE
+CWINF1: MOVE B,-1(P)
+ ASH B,-9. ; TO PAGES
+ MOVNI A,1
+ HRLI B,MFORK ; SET UP HANDLE
+ MOVEI C,0
+ PMAP ; FLUSH BUFFER
+ POP P,C
+ POP P,B
+POPAJ: POP P,A
+ POPJ P,
+
+
+
+; ROUTINE TO RESTORE THE IMAGE FROM A SAVED FORK IMAGE.
+; A== FORK HANDLE B== AOBJN POINTER TO MUDDLE
+; C== START IN INF
+
+
+RSTIM: ASH B,1 ; TO CONVERT TO TENEX PAGES
+ ASH C,1
+ HRLZS A ; FORK HANDLE TO LEFT HALF
+ JUMPE C,RSTIM1 ; SEE IF NO WORK TO DO
+RSTIM2: HRRI A,(C)
+ PUSH P,B ; SAVE B
+ RPACS ; READ PAGE BITS
+ TLNN B,CTEXST ; SKIP IF IT EXISTS
+ JRST RSTIM3
+ HRRZ B,(P) ; GET PAGE
+ HRLI B,MFORK ; GET PAGE BACK TO ME
+ PUSH P,C
+ MOVSI C,CTREAD+CTCW+CTEXEC ; PAGE MODES
+ PMAP ; GET THE PAGE
+ POP P,C ;RESTORE C
+ ASH B,9. ; TO START OF PAGE
+ MOVES 20(B) ; TOUCH PAGE
+RSTIM3: POP P,B ; GET BACK B
+ ADDI C,1 ; INC C
+ AOBJN B,RSTIM2 ; GO BACK IN LOOP
+RSTIM1: POPJ P, ; DONE
+
+
+; ROUTINE TO MAP OUT PARTS OF THE INTERPRETER IN ORDER TO PRESERVE IT
+
+%MPINX: MOVE 0,GCFK1
+ JRST MPIN
+
+%MPIN:
+%MPIN1: MOVE 0,GCFRK
+MPIN: PUSH P,C ; SAVE B
+ MOVE C,A
+ MOVE A,0 ; GET FORK HANDLE
+ PUSHJ P,RSTIM
+ POP P,C
+ POPJ P, ; EXIT
+
+%SAVIN: PUSH P,B ; SAVE AC'S
+ PUSH P,A
+ MOVSI A,CR%CAP
+ CFORK
+ FATAL AGC--CAN'T GET GC FORK
+ MOVEM A,GCFK1 ; SAVE FORK HANDLE
+ POP P,B ; RESTORE AOBJN
+ PUSHJ P,PROTCT ; PROTECT IMAGE
+ POP P,B ; RESTORE AC
+ POPJ P,
+
+%MPRDO: HRLI B,-1
+ HRR B,A
+ JRST PROTCT
+
+
+; CREATE A JOB FOR MARKING HACKS (PURIFY AND GC-DUMP) AND SAVES HANDLE IN TWO SEPERATE
+; PLACES.
+
+%GCJB1: PUSHJ P,%GCJOB ; CREATE FORK
+ MOVE A,GCFRK ; GET HANDLE
+ MOVEM A,GCFK2
+ POPJ P,
+
+%CLSMP: MOVE 0,GCFK2 ; GET BACK FROM FORK CONTAINING UPDATED WORLD
+ PUSHJ P,%GBINT
+%CLSM1: MOVE A,GCFK2 ; KILL THE FORK
+KFK1: KFORK
+%IFMP1:
+%CLSJB: POPJ P, ; IN ITS CLOSES AN INFERIORS CHANNEL WITHOUT
+ ; KILLING IT
+
+; HERE TO KILL THE IMAGE SAVING INFERIOR
+
+%KILJB: PUSH P,A ; SAVE MAPPING PARAMS
+ MOVE A,GCFK1
+ KFORK
+ JRST IFMP3 ; GO FIX UP CORE IMAGE
+
+; HERE TO MAP IN SAVED WORLD AND KILL INF CONTAINING IT
+
+;%IFMP1: POPJ P,
+
+; HERE TO MAP IN A PAGE IN READ ONLY MODE FROM THE AGD INFERIOR
+
+%LDRDO: MOVE 0,GCFK1
+ PUSH P,A ; SAVE PAGE POINTER
+ MOVE B,A
+ HRLI B,-1 ; MAKE UP PAGE POINTER
+ PUSHJ P,MPIN ; MAP IN THE PAGES
+ HRLI B,CTREAD+CTEXEC
+ HRLI A,MFORK ; SET UP HANDLE
+ HRR A,(P)
+ ASH A,1 ; CONVERT TO TENEX PATES
+ HRRZ C,A
+ ASH C,9
+ MOVES 20(C)
+ SPACS
+ ADDI A,1
+ HRRZ C,A
+ ASH C,9
+ MOVES 20(C)
+ SPACS
+ SUB P,C%11 ; CLEAN OFF STACK
+ POPJ P,
+
+%IFMP2: PUSH P,A ; SAVE POINTER
+ MOVE 0,GCFK1
+ PUSHJ P,MPIN ; MAP IT IN
+ MOVE A,GCFK1 ; KILL IT
+ KFORK
+IFMP3: POP P,C
+ ASH C,1
+ MOVSI A,MFORK ; SET UP FORK HANDLE
+ JUMPGE C,IFMP2 ; IF DONE
+DORPA: HRR A,C ; GET PAGE #
+ RPACS
+ TLNN B,CTEXST ; SKIP IF IT EXISTS
+ JRST .+3
+ MOVSI B,CTREAD+CTWRIT+CTEXEC ; CAPABILATIES
+ SPACS ; SET CAPABILATIES
+ AOBJN C,DORPA
+IFMP2: POPJ P,
+
+
+%CLMP1: MOVE A,GCFK1 ; KILL THE FIRST FORK
+ JRST KFK1
+
+%IMSV1:
+%MPINT: PUSH P,C ; SAVE C
+ PUSH P,B
+ PUSH P,D
+ ASH A,1
+ MOVEI C,0
+ MOVE D,A
+MPINT1: MOVSI A,MFORK ; SET UP ARGS TO RMAP
+ HRRI A,(D)
+ RMAP
+ MOVEM A,RMPTAB(C)
+ ADDI C,1
+ AOBJN D,MPINT1
+ POP P,D
+ POP P,B
+ POP P,C
+ POPJ P,
+
+
+; ROUTINE TO GET BACK THE INTERPRETER. IT MAPS
+%GBINT: PUSH P,E
+ PUSH P,B
+ PUSH P,C ; SAVE AC'S
+ PUSH P,D
+ ASH A,1
+ MOVE D,A ; COPY UDDATED AOBJN
+ MOVEI E,0 ; ZERO INDEX TO TABLE
+GBINT1: MOVE A,RMPTAB(E) ; GET FILE HANDLE
+ MOVSI B,MFORK ; SET UP INTERPRETER ARG
+ HRRI B,(D)
+ MOVSI C,CTREAD+CTEXEC+CTCW
+ PMAP ; IN IT COMES
+ ADDI E,1 ; INC INDEX
+ AOBJN D,GBINT1
+ POP P,D
+ POP P,C
+ POP P,B
+ POP P,E
+ POPJ P,
+
+; HERE TO SAVE RMAP TABLE FOR PURIFY
+
+%SAVRP: PUSH P,A ; SAVE AC
+ MOVE A,[RMPTAB,,ORMTAB]
+ BLT A,ENDRPT-1 ; SAVE RMAP TABLE
+ JRST POPAJ
+; POP P,A ; RESTORE A
+; POPJ P,
+
+; HERE TO RESTORE THE RMAP TABLE FOR PURIFY
+
+%RSTRP: PUSH P,A ; SAVE A
+ MOVE A,[ORMTAB,,RMPTAB]
+ BLT A,ORMTAB-1
+ JRST POPAJ
+; POP P,A ; RESTORE A
+; POPJ P,
+
+SQBLK: ASCIZ /PS:<MDL>MDLXXX.SQUOZE/
+TSQBLK: ASCIZ /DSK:<MDL>MDLXXX.SQUOZE/
+
+; CODE TO DISTINGUISH BETWEEN TOPS20 AND TENEX AT SETUP TIME
+
+TWENTY: HRROI A,C ; RESULTS KEPT HERE
+ HRLOI B,600015
+ MOVEI C,0 ; CLEAN C UP
+ DEVST
+ JFCL
+ MOVEI A,1 ; TENEX HAS OPSYS = 1
+ CAME C,[ASCII/NUL/] ; TOPS20 GIVES "NUL"
+ MOVEM A,OPSYS ; TENEX GIVES "NIL"
+ POPJ P,
+
+;%CLNCO -- FLUSH SOME PAGES FOR SAFETY
+; C ==> ADDR OF PAGE PREV TO LOSERS
+; E ==> JUST ABOVE LOSERS
+
+%CLNCO: PUSH P,C
+ PUSH P,E
+ ADDI C,777
+ ASH C,-9.
+ ASH E,-9.
+ CAIG E,1(C)
+ JRST %CLN1
+ PUSH P,A
+ PUSH P,B
+
+ MOVSI B,MFORK
+ HRRI B,(C)
+ MOVNI A,1
+ MOVEI C,0
+
+ PMAP
+ CAIL E,2(B)
+ AOJA B,.-2
+
+ POP P,B
+ POP P,A
+
+%CLN1: POP P,E
+ POP P,C
+ POPJ P,
+
+
+; MULTI -- ENTER MULTI SEGMENT MODE
+; THIS ROUTINE MAPS EVERYTHING UP AND THEN GOES UP THERE
+
+MULTI: PUSHJ P,PURCLN ; UNMAP ANY CORRENTLY MAPPED FBINS
+ PUSHJ P,SQKIL ; AND SQUOZE TABLE
+ SETOM MULTSG
+ MOVE A,PURBOT ; MUNG TABLE OF THESE GUYS
+ MOVN B,NSEGS
+ MOVSI B,(B)-1
+
+ MOVEM A,PURBTB(B)
+ AOBJN B,.-1
+
+ MOVE A,VECTOP ; CWRITE GC SPACE
+ ANDCMI A,777
+ MOVES (A)
+ SUBI A,1000
+ JUMPG A,.-2
+
+ MOVEI A,0 ; FIRST CREATE OTHER SECTIONS
+ MOVE B,[MFORK,,FSEG]
+ MOVE C,[CTREAD+CTWRIT+CTEXEC,,1]
+ MOVE D,NSEGS
+ SMAP
+ ADDI B,1
+ SOJG D,.-2
+
+; CREATE GC SEGMENT
+
+ HRRI B,GCSEG
+ SMAP
+
+; NOW LOOP AROUND MAPPING PAGES (MAY TAKE SOME TIME)
+
+ MOVEI D,FSEG_9.
+ MOVEI PVP,FSEG
+ ADD PVP,NSEGS
+ LSH PVP,9. ; PVP NOW HIGHEST PAGE TO MAP
+ MOVSI E,-1000 ; 1ST PAGE AND COUNTER
+
+PAGLP: MOVSI A,MFORK
+ HRRI A,(E)
+ RMAP
+ CAME A,C%M1
+ JRST .+3
+ MOVSI A,MFORK
+ HRRI A,(E)
+ MOVSI B,MFORK
+ HRRI B,(E)
+ IORI B,(D)
+ MOVSI C,CTREAD+CTWRIT+CTEXEC
+ PMAP
+LPON: AOBJN E,PAGLP
+
+ MOVSI E,-1000
+ ADDI D,1_9.
+ CAMGE D,PVP
+ JRST PAGLP
+
+; SETUP MULTI SEG LUUO HANDLER
+
+ MOVEI A,MFORK
+ MOVEI B,2 ; CODE FOR SETUP OF UUO TABLE
+ MOVE C,[FSEG,,MLTUUP]
+ SWTRP
+ MOVEI C,FSEG
+ MOVE B,PVSTOR+1
+ MOVE B,TBINIT+1(B)
+ HRLM C,PCSAV(B)
+ PUSHJ P,INTINT
+
+ POP P,C
+ HRLI C,FSEG ; MAKE INTO FUNNY ADDRESS
+ MOVEI B,0
+ TLO TB,400000 ; MAKE TB BE A LOCAL INDEX
+ XJRST B
+
+NOMULT: PUSHJ P,PURCLN
+ JRST @[.+1] ; RUN IN SECTION 0
+ SETZM MULTSG
+ MOVNI A,1
+ MOVE B,[MFORK,,FSEG]
+ MOVEI C,1
+ MOVE D,NSEGS
+ SMAP
+ ADDI B,1
+ SOJG D,.-2
+
+; FLUSH GC SEG
+
+ HRRI B,GCSEG
+ SMAP
+
+ JRST INTINT
+; PUSHJ P,INTINT
+; POPJ P,
+
+MFUNCTION MMS,SUBR,MULTI-SECTION
+
+ ENTRY
+
+ PUSH P,NSEGS
+ PUSH P,MULTSG
+ JUMPGE AB,RMULT ; NO ARGS==>LEAVE
+ CAMGE AB,C%M30 ; [-3,,]
+ JRST TMA
+ GETYP 0,(AB)
+ CAIE 0,TFIX
+ JRST INOUT
+ MOVE 0,1(AB)
+ CAIL 0,2
+ CAILE 0,30
+ JRST OUTRNG
+ MOVEM 0,NSEGS
+INOUT: GETYP 0,(AB)
+ CAIE 0,TFALSE
+ JRST EMULT
+LMULT: SKIPE (P)
+ PUSHJ P,NOMULT
+ JRST RMULT
+
+EMULT: SKIPN (P)
+ PUSHJ P,MULTI
+
+RMULT: POP P,A
+ POP P,B ; POSSIBLE PREV NSEGS
+ JUMPN A,TMULT
+ MOVSI A,TFALSE
+ MOVEI B,0
+ JRST FINIS
+
+TMULT: MOVSI A,TFIX
+ JRST FINIS
+IMPURE
+
+DEMFLG: 0 ; FLAG INDICATING DEMON
+ ; (IF DEMON SIXBIT OF DIRECTORY)
+SFRK: -1 ; FLAG FOR EXTRA INFERIOR HACK
+GCFRK: 0
+GCFK1: 0
+GCFK2: 0
+RMPTAB: BLOCK 25.
+ORMTAB: BLOCK 25.
+ENDRPT:
+
+MESSAG: PUSHJ P,MESOUT ; MESSAGE SWITCH
+
+INITFL: PUSHJ P,MUDINT ; MUDDLE INIT SWITCH
+
+PURE
+
+END
--- /dev/null
+TITLE MUDEX -- TENEX DEPENDANT MUDDLE CODE
+
+RELOCATABLE
+
+.INSRT MUDDLE >
+.INSRT STENEX >
+
+MFORK==400000
+XJRST==JRST 5,
+
+.GLOBAL %SSNAM,%RSNAM,%KILLM,%LOGOU,%SLEEP,%VALRE,NOTTY,DEMFLG,MSGTYP,TTYOP2
+.GLOBAL %UNAM,%XUNA,%JNAM,%XJNA,%RUNAM,%RXUNA,%RJNAM,%RXJNA,%GCJOB,%VALFI
+.GLOBAL %SHWND,%SHFNT,%GETIP,%INFMP,SGCLBK,TWENTY,MULTSG,MLTUUP
+.GLOBAL GCHN,WNDP,FRNP,MESSAG,INITFL,6TOCHS,SGSNAM,MTYO,PGINT,WHOAMI
+.GLOBAL %TOPLQ,IBLOCK,TMTNXS,TNXSTR,%HANG,ILLUUO,UUOH,IPCINI,CTIME,BFLOAT
+.GLOBAL GCRSET,%MPINT,%GBINT,%CLSMP,%GCJB1,%CLMP1,%SAVIN,%MPIN,%MPIN1,%IMSV1
+.GLOBAL %PURIF,%MPINX,%CLSJB,%KILJB,%IFMP1,%OPGFX,STOSTR,%SAVRP,%RSTRP,GETSQU
+.GLOBAL WIND,%FDBUF,%CWINF,P.TOP,BUFGC,PURBOT,%IFMP2,%CLSM1,GETBUF,KILBUF
+.GLOBAL CERR1,CERR2,CERR3,COMPERR,CALER1,%LDRDO,%MPRDO,SQBLK,SQLOD,SQKIL,GETSQU
+.GLOBAL SQUPNT,SFRK,IJFNS,GETJS,OPBLK,SJFNS,OPSYS,GCLDBK,ILDBLK,IJFNS1,TILDBL
+.GLOBAL TBINIT,PVSTOR,SECBLK,PURCLN,NSEGS,INTINT,PURBTB,%CLNCO,OUTRNG
+.GLOBAL MULTI,NOMULT,THIBOT,%PURMD
+.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
+
+GCHN==0
+CTTRAP==1000
+CTEXST==10000
+CTREAD==100000
+CTEXEC==20000
+CTWRIT==40000
+CTCW==400
+
+MFORK==400000
+CTREAD==100000 ; READ BIT
+CTEXEC==20000 ; EXECUTE BIT
+CTWRIT==40000 ; WRITE BIT
+CTCW==400 ; COPY ON WRITE
+
+
+FREAD==200000 ; READ BIT FOR OPENF
+FEXEC==40000 ; EXEC BIT FOR OPENF
+FTHAW==2000
+FWRITE==100000
+
+GJ%SHT==1 ; SHORT FORM GTJFN
+GJ%OLD==100000 ; FILE MUST EXIST
+OP%36B==440000 ; 36 BIT BYTES
+OP%7B==700000 ; 7 BIT BYTES
+CR%CAP==200000
+
+SQLOD: MOVEI A,1
+ JRST @[.+1] ; RUN IN 0 FOR BIZARRE BUGS
+ PUSHJ P,GETBUF
+ HRRM B,SQUPNT
+ HLRZ A,SJFNS
+ JUMPE A,SQLOD1
+ HRRZS SJFNS
+ CLOSF
+ JFCL
+SQLOD1: HRROI B,SQBLK
+ SKIPE OPSYS
+ HRROI B,TSQBLK
+ MOVSI A,GJ%SHT+GJ%OLD
+ GTJFN
+ FATAL CANT GET SQUOZE
+ HRLM A,SJFNS
+ MOVEI D,(A)
+ MOVE B,[OP%36B,,FREAD]
+ OPENF
+ FATAL CANT OPEN SQUOZE
+ SIZEF
+ FATAL CANT SIZEF SQUOZE
+ MOVSI A,(D)
+ MOVNS B
+ HRLM B,SQUPNT
+ HRRZ B,SQUPNT
+ ASH B,-9.
+ HRLI B,MFORK
+ MOVSI C,CTREAD+CTEXEC
+
+ PMAP
+ ADDI A,1
+ ADDI B,1
+ PMAP
+ MOVEI A,(D)
+ CLOSF
+ JFCL
+ SKIPN MULTSG
+ POPJ P,
+ POP P,B
+ MOVEI A,0
+ XJRST A
+
+
+SQKIL: PUSHJ P,KILBUF
+ HLLZS SQUPNT
+CPOPJ:
+%PURIF:
+%GETIP: POPJ P,
+
+%PURMD: MOVE A,[MFORK,,THIBOT]
+ MOVEI 0,777-THIBOT
+%PURMX: RPACS
+ TLNN B,CTWRIT+CTCW ; SKIP IF NOT READ ONLY
+ TLNN B,CTEXST ; SKIP IF EXISTS (OTHERWISE WE'LL CREATE IT)
+ JRST .+3 ; SKIP IF NOT READ ONLY
+ MOVSI B,CTREAD+CTEXEC
+ SPACS
+ ADDI A,1
+ SOJGE 0,%PURMX
+ POPJ P,
+
+GETSQU: HRRZ 0,SQUPNT
+ JUMPN 0,CPOPJ
+ JRST SQLOD
+
+
+CTIME: SKIPE OPSYS ; skip if TOPS20
+ JRST .+4
+ MOVEI A,400000
+ RUNTM
+ JRST .+2
+ JOBTM ; get run time in milli secs
+ IDIVI A,400000
+ FSC B,233
+ FSC A,254
+ FADR B,A
+ FDVRI B,(1000.0) ; Change to units of seconds
+ MOVSI A,TFLOAT
+ POPJ P,
+
+; THE GLOBAL SNAME
+
+%RSNAM: PUSHJ P,TMTNXS ; GET STRING ON STACK (POINTER IN E)
+ GJINF ; USER NUMBER IS IN A
+ PUSHJ P,INFSTR ; MAKE INFO STRING
+
+%SSNAM: POPJ P,
+
+; KILL THE CURRENT JOB
+
+%VALFI:
+%KILLM: HALTF
+ POPJ P,
+
+; STRING IS IN A
+%VALRE: HRROS A
+ RSCAN ; PASS STRING
+ JFCL
+ MOVEI A,0
+ RSCAN ; MAKE IT AVAILABLE FOR USE
+ JFCL
+ JRST %KILLM
+
+; LOGOUT OF SYSTEM (MUST BE "TOP LEVEL")
+
+%LOGOU: LGOUT
+ POPJ P,
+
+; GO TO SLEEP A WHILE
+
+%SLEEP: IMULI A,33. ; TO MILLI SECS
+ DISMS
+ POPJ P,
+
+; HANG FOR EVER
+
+%HANG: WAIT
+
+; READ JNAME
+
+%RXJNA:
+%RJNAM: GETNM ; RETURNS SIXBIT IN A
+ MOVEM A,%JNAM
+ POPJ P,
+
+; READ UNAME
+
+%RXUNA:
+%RUNAM: PUSHJ P,TMTNXS ; GET STRING ON STACK (POINTER IN E)
+ GJINF ; USER NUMBER IS IN A
+ MOVE B,A ; USER NUMBER TO B
+ PUSHJ P,INFST1 ; MAKE INFO STRING
+CPOPJ1: AOS (P) ; SKIP RETURN
+ POPJ P,
+
+; MAKE A STRING FROM DIRST GOODIES
+INFSTR: TDZA 0,0
+INFST1: MOVEI 0,1 ; FLAG WHETHER TO SCAN
+ HRROI A,1(E) ; STRING POINTER IN A
+ DIRST ; GET THE NAME
+ FATAL ATTACHED DIRECTORY DOESN'TEXIST
+ MOVEI B,1(E) ; A AND B BOUND STRING
+ JUMPN 0,INFST2 ; NO NEED TO SCAN
+ SKIPE OPSYS
+ JRST INFST2
+
+ HRLI B,440700
+ MOVE A,B
+
+ ILDB 0,B ; FLUSH : AND <>
+ CAIE 0,"<
+ JRST .-2
+
+ ILDB 0,B
+ CAIN 0,">
+ JRST .+3
+ IDPB 0,A
+ JRST .-4
+
+ MOVE B,A
+ MOVEI 0,0
+ IDPB 0,B
+ MOVEI B,1(E)
+
+
+INFST2: SUBM P,E ; RELATIVIZE E
+ PUSHJ P,TNXSTR ; BUILD STRING (IN A AND B)
+ MOVE C,(P) ; GET RETURN PC FROM PUSHJ
+ SUB P,E ; P BACK TO NORMAL
+ JRST (C)
+
+; HERE TO SEE IF WE ARE A TOP LEVEL JOB
+
+%TOPLQ: GJINF
+ JUMPL D,CPOPJ1
+ JRST CPOPJ
+
+; ERRORS IN COMPILED CODE MAY END UP HERE
+
+CERR1: ERRUUO EQUOTE NEGATIVE-ARGUMENT
+
+CERR2: ERRUUO EQUOTE NTH-REST-PUT-OUT-OF-RANGE
+
+CERR3: ERRUUO EQUOTE UVECTOR-PUT-TYPE-VIOLATION
+
+COMPERR:
+ ERRUUO EQUOTE ERROR-IN-COMPILED-CODE
+
+\f
+; GET AN INFERIOR FOR THE GARBAGE COLLECTOR
+
+%GCJOB: PUSH P,A
+ MOVEI A,CR%CAP ; GET BITS FOR FORK
+ CFORK ; MAKE AN IFERIOR FORK
+ FATAL CANT GET GC FORK
+ MOVEM A,GCFRK ; SAVE HANDLE
+ POP P,A ; RESTORE PAGE
+ MOVEI B,FRNP
+ PUSHJ P,%SHWND
+ POPJ P,
+
+; HERE TO SHARE WINDOW
+
+%SHWNF: PUSH P,0
+ MOVE 0,GCFK1
+ JRST SHWND1
+
+%SHWND: PUSH P,0
+ MOVE 0,GCFRK
+
+SHWND1: PUSH P,A
+ PUSH P,B
+ PUSH P,C
+ ASH B,1 ; TO CRETINOUT TENEX PAGE SIZE
+ HRLI B,MFORK
+ ASH A,1 ; TIMES 2
+ HRL A,0
+ MOVSI C,CTREAD+CTWRIT ; READ AND WRITE ACCESS
+
+ PMAP
+ ADDI A,1
+ ADDI B,1
+ PMAP
+ ASH B,9. ; POINT TO PAGE
+ MOVES (B) ; CLOBBER TOP
+ MOVES -1(B) ; AND UNDER
+ POP P,C
+ POP P,B
+ POP P,A
+ POP P,0
+ POPJ P,
+
+; HERE TO MAP INFERIOR BACK AND KILL SAME
+
+%INFMP: PUSH P,C
+ PUSH P,D
+ PUSH P,E
+ ASH A,1
+ ASH B,1
+ MOVE D,A ; POINT TO PAGES
+ MOVE E,B ; FOR COPYING
+ PUSH P,A ; SAVE FOR TOUCHING
+
+; HERE FOR OPTIONAL MULTI FORK HACK
+
+ SKIPLE A,SFRK ; SKIP NOT ENABLED OR NOT ACTIVE
+ KFORK ; FLUSH THE OLD EXTRA
+
+ MOVS A,GCFRK
+ SKIPE SFRK ; SKIP IF NOT MULTI FORK
+ HLRZM A,SFRK ; SAVE THIS AS IT
+ MOVSI B,MFORK
+ MOVSI C,CTREAD+CTEXEC+CTCW ; READ AND WRITE COPY
+ SKIPE SFRK
+ MOVSI C,CTREAD+CTEXEC+CTWRIT
+
+LP1: HRRI A,(E)
+ HRRI B,(D)
+ PMAP
+ ADDI E,1
+ AOBJN D,LP1
+
+; HERE TO TOUCH PAGES TO INSURE KEEPING THEM (KLUDGE)
+
+ POP P,E ; RESTORE MY FIRST PAGE #
+ SKIPE SFRK ; SKIP IF NOT MULTI CASE
+ JRST ALDON
+ MOVEI A,(E) ; COPY FOR LOOP
+ ASH A,9. ; TO WORD ADDR
+ MOVES (A) ; WRITE IT
+ AOBJN E,.-3 ; FOR ALL PAGES
+
+ MOVE A,GCFRK
+ KFORK
+ALDON: POP P,E
+ POP P,D
+ POP P,C
+ POPJ P,
+
+; HACK TO PRINT MESSAGE OF INTEREST TO USER
+
+MESOUT: MOVSI A,(JFCL)
+ MOVEM A,MESSAG ; DO ONLY ONCE
+ RESET
+ SKIPE SFRK
+ SETOM SFRK ; NO FORK TO HACK RIGGHT NOW
+ PUSHJ P,GETJS ; GET SOME JFNS
+
+ MOVEI A,400000
+ MOVE B,[1,,ILLUUO]
+ MOVE C,[40,,UUOH]
+ SCVEC
+ SETZB SP,FRM ; HACK TO AVOID LOSSAGE WITH GARBAGE IN SP
+ ; FIRST TIME
+ PUSHJ P,GCRSET
+ MOVE A,[MFORK,,THIBOT]
+ MOVSI B,CTREAD+CTEXEC
+ MOVEI 0,777-THIBOT
+ SPACS
+ ADDI A,1
+ SOJGE 0,.-2
+ PUSHJ P,PGINT ; INITIALIZE PAGE MAP
+ GJINF
+ AOJN D,.+3 ; JUMP IF HAS TTY
+ SETOM DEMFLG
+ SETOM NOTTY
+ SKIPN DEMFLG
+ JRST TTON
+ MOVEI A,MFORK ; GET FORK HANDLE
+ RPCAP
+ MOVE C,B ; HAIR TO ENABLE CAPABILITIES OF DEMON
+ EPCAP
+TTON: PUSHJ P,TTYOP2
+ SKIPN DEMFLG ; SKIP IF DEMON
+ SKIPE NOTTY ; HAVE A TTY?
+ JRST RESNM ; NO, SKIP THIS STUFF
+
+ MOVEI A,MESBLK
+ MOVEI B,0
+ GTJFN
+ JRST RESNM
+ MOVE B,[OP%7B,,FREAD]
+ OPENF
+ JRST RESNM
+
+MSLP: BIN
+ MOVE D,B ; SAVE BYTE
+ GTSTS
+ TLNE B,1000
+ JRST RESNM
+ EXCH D,A
+ CAIN A,14
+ PBOUT
+ MOVE A,D
+ JRST MSLP
+
+RESNM2: CLOSF
+IPCINI: JFCL
+
+RESNM: PUSHJ P,TWENTY
+RESNM1: SKIPN MULTSG
+ POPJ P,
+ POP P,C ; STAY IN MAIN SEG
+ HRLI C,FSEG
+ JRST (C)
+
+\f
+; GET JFNS TO MDL INTERPRETER, AGC AND SGC, SAVE IN IJFNS AND IJFNS1
+GETJS: MOVEI A,$TLOSE
+ LSH A,-11
+ HRLI A,MFORK ; THIS FORK
+ RMAP
+ JUMPGE A,GETJS1 ; HAPPY?
+; HERE TO GET MDL INTERPRETER JFN EXPLICITLY RATHER THAN THROUGH RMAP
+ HRROI B,ILDBLK
+ SKIPE OPSYS
+ HRROI B,TILDBL
+ MOVSI A,GJ%SHT+GJ%OLD
+ GTJFN
+ FATAL INTERPRETER EXE FILE MISSING
+ MOVE B,[OP%36B,,FREAD+FWRITE]
+ OPENF
+ FATAL CANT OPEN MDL INTERPRETER EXE FILE
+ HRLM A,A
+GETJS1: HLRZM A,IJFNS ; SAVE JFN TO INTERPRETER
+ POPJ P,
+
+; GTJFN BLOCK FOR MESSAGE FILE
+MESBLK: 100000,,
+ 377777,,377777
+ -1,,[ASCIZ /DSK/]
+ -1,,[ASCIZ /MDL/]
+ -1,,[ASCIZ /MUDDLE/]
+ -1,,[ASCIZ /MESSAG/]
+ 0
+ 0
+ 0
+
+MUDINT: MOVSI 0,(JFCL) ; CLOBBER MUDDLE INIT SWITCH
+ MOVEM 0,INITFL
+
+; LOOP TO TOUCH ALL PAGES SO PURIFY CAN WORK
+
+ SKIPN A,DEMFLG ; SKIP IF A DEMON
+ JRST FINDIR ; GET USERS DIRECTORY
+ AOJE A,FINDIR
+ MOVE A,DEMFLG ; GET SIXBIT OF DIRECTORY NAME
+ PUSHJ P,6TOCHS ; TO CHARACACTER STRING
+ JRST DIRCON
+
+FINDIR: GJINF ; GET INFO NEEDED
+ MOVEM A,SJFNS
+ PUSHJ P,TMTNXS ; MAKE A TEMP STRING FOR TENEX INFO
+ ; (POINTER LEFT IN E)
+ PUSHJ P,INFSTR
+DIRCON: PUSH TP,$TATOM
+ PUSH TP,IMQUOTE SNM
+ PUSH TP,A
+ PUSH TP,B
+ MCALL 2,SETG
+ SKIPE WHOAMI
+ JRST SUBSYS
+ MOVE A,[SIXBIT/MUDDLE/]
+ PUSHJ P,6TOCHS ; MAKE A CHARACTER STRING
+ PUSH TP,$TCHSTR
+ PUSH TP,CHQUOTE READ
+ PUSH TP,A
+ PUSH TP,B
+ PUSH TP,$TCHSTR ; NOW THE .INIT
+ PUSH TP,CHQUOTE .INIT
+ MCALL 2,STRING ; MAKE A STRING
+ PUSH TP,A ; ARGS TO FOPEN
+ PUSH TP,B
+ MCALL 2,FOPEN
+ GETYP A,A
+ CAIN A,TCHAN
+ JRST ISVCHN
+SUBSYS: PUSH TP,$TCHSTR
+ PUSH TP,CHQUOTE READ
+ MOVE A,[SIXBIT /MUDDLE/]
+ SKIPE WHOAMI
+ MOVE A,WHOAMI
+ PUSHJ P,6TOCHS
+ PUSH TP,A
+ PUSH TP,B
+ PUSH TP,$TCHSTR
+ PUSH TP,CHQUOTE INIT
+ PUSH TP,$TCHSTR
+ PUSH TP,CHQUOTE DSK
+ PUSH TP,$TCHSTR
+ PUSH TP,CHQUOTE MUDDLE
+ MCALL 5,FOPEN
+ GETYP A,A
+ CAIE A,TCHAN
+ POPJ P,
+ISVCHN: PUSH TP,$TCHAN
+ PUSH TP,B
+ MOVEI B,INITSTR ; TELL USER WHAT'S HAPPENING
+ SKIPE WHOAMI
+ JRST INCOM
+ SKIPE DEMFLG ; SKIP IF NOT A DEMON
+ JRST INCOM
+ SKIPN NOTTY
+ PUSHJ P,MSGTYP
+INCOM: MCALL 1,MLOAD
+ POPJ P,
+
+TMTNXS: POP P,D ; SAVE RET ADDR
+ MOVE E,P ; BUILD A STRING SPACE ON PSTACK
+ MOVEI 0,20. ; USE 20 WORDS (=100 CHARS)
+ PUSH P,C%0
+ SOJG 0,.-1
+
+ JRST (D)
+
+
+TNXSTR: SUBI B,(P)
+ PUSH P,B
+ ADDI B,-1(P)
+ SUBI B,(A) ; WORDS TO B
+ IMULI B,5 ; TO CHARS
+ LDB 0,[360600,,A] ; GET BYTE POSITION
+ IDIVI 0,7 ; TO A REAL BYTE POSITION
+ MOVNS 0
+ ADDI 0,5
+ SUBM 0,B ; FINAL LENGTH IN BYTES TO B
+ PUSH P,B ; SAVE IT
+ MOVEI A,4(B) ; TO WORDS
+ IDIVI A,5
+ PUSH P,E ; SAVE E
+ PUSHJ P,IBLOCK ; GET STRING
+ POP P,E
+ POP P,A
+ POP P,C
+ ADDI C,(P)
+ MOVE D,B ; COPY POINTER
+ MOVE 0,(C) ; GET A WORD
+ MOVEM 0,(D)
+ ADDI C,1
+ AOBJN D,.-3
+
+ HRLI A,TCHSTR
+ HRLI B,00700 ; MAKE INTO BYTER
+ SOJA B,CPOPJ
+
+INITSTR: ASCIZ /MUDDLE INIT/
+
+; HERE TO RECOPY PAGE 0 WHICH CONTAINS IMFORMATION FOR REMAPPING IN INFERIOR
+%OPGFX: PUSH P,B ; SAVE B
+ PUSH P,A
+ MOVEI B,STOSTR ; TOP OF CONSTANTS
+ ADDI B,1777 ; ROUND
+ ANDCMI B,1777
+ ASH B,-10. ; TO PAGES
+ MOVN A,B
+ MOVEI B,WNDP ; GET WINDOW
+ HRLZS A ; START WITH PAGE 0
+OPGFX2: JUMPGE A,OPGFX1
+ PUSH P,A
+ HRRZS A
+ PUSHJ P,%SHWNF
+ HRRZ A,(P)
+ ASH A,10. ; TO START OF PAGE
+ HRLS A ; SET UP BLT POINTER
+ HRRI A,WIND
+ MOVEI B,WIND
+ BLT A,1777(B) ; OUT INTO THE BUFFER
+ POP P,A ; RESTORE A
+ AOBJN A,OPGFX2
+OPGFX1: POP P,A
+ POP P,B
+ POPJ P,
+
+; ROUTINE TO PROTECT A CORE IMAGE BY SAVING IT IN AN INFERIOR
+; A==FORK HANDLE B== AOBJN POINTER
+
+
+PROTCT: TRNN B,-1 ; SEE IF PAGE 0 IS INCLUDED
+ ADD B,C%11 ; INC PAGE
+ ASH B,1
+ PUSH P,C ; SAVE C
+ MOVE C,B ; COPY AOBJN
+ MOVSI A,MFORK ; FORK HANDLE
+ JUMPE C,PRTDON ; IF ZERO THEN WE ARE DONE
+PROTC1: HRRI A,(C) ; GET PAGE
+ HRRZ D,C
+ ASH D,9.
+ RPACS
+ TLNN B,CTWRIT+CTCW ; SKIP IF NOT READ ONLY
+ TLNN B,CTEXST ; SKIP IF EXISTS (OTHERWISE WE'LL CREATE IT)
+ MOVES 20(D) ; TOUCH PAGE
+ MOVSI B,CTREAD+CTEXEC ; SET UP TO MARK PAGES TO TRAP ON ANY REF
+ SPACS ; CHANGE MODE OF PAGE
+ AOBJN C,PROTC1
+PRTDON: POP P,C ; RESTORE C
+ POPJ P,
+
+%FDBUF: HRRZ A,PURBOT
+ SUB A,P.TOP ; CALCULATE ROOM FOR PROSPECTIVE BUFFER
+ CAIG A,2000 ; SEE IF ROOM
+ JRST FDBUF1
+ MOVE A,P.TOP ; START OF BUFFER
+ HRRM A,BUFGC
+ POPJ P,
+FDBUF1: SETOM BUFGC ; INDICATE NO BUFFER FOUND
+ POPJ P,
+
+; HERE TO SIMULATE A COPY ON WRITE TO AN INFERIOR. IF A PAGE HAS NO WRITE BITS
+; IT WILL COPY IT INTO THE GCFRK1 FORK. A== START OF PAGE, B== START OF BUFFER PAGE
+
+%CWINF: PUSH P,A
+ PUSH P,B ; SAVE AC'S
+ PUSH P,C
+ ANDI A,-1 ; CLEAN OUT LEFT HALF OF A
+ ASH A,-9. ; TO PAGES
+ PUSH P,C%0
+ HRLI A,MFORK ; GET FORK HANDLE
+ RPACS ; READ PAGE BITS
+ MOVEM B,(P)
+ TLNE B,CTEXST ; SKIP IF DOESN'T EXIST
+ TLNE B,CTWRIT ; SEE IF WRITABLE
+ JRST CWINFX ; NO, EXIT
+ MOVSI B,CTEXEC+CTREAD+CTCW
+ SPACS ; RESTORE PAGE TO NORMAL
+CWINFX: ADDI A,1
+ RPACS ; READ PAGE BITS
+ TLNE B,CTEXST ; SKIP IF DOESN'T EXIST
+ TLNE B,CTWRIT ; SEE IF WRITABLE
+ JRST CWINFY ; NO, EXIT
+ MOVSI B,CTEXEC+CTREAD+CTCW
+ SPACS
+ SUB P,C%11
+ JRST CWINFZ
+CWINFY: POP P,B
+ TLNE B,CTEXST ; SKIP IF DOESN'T EXIST
+ TLNE B,CTWRIT ; SEE IF WRITABLE
+ JRST CWINF1 ; NO, EXIT
+CWINFZ: HRRZI A,-1(A)
+ ASH A,-1
+ MOVE B,-1(P) ; SET UP BUFFER PAGE
+ ASH B,-10. ; TO PAGE NUMBER
+ PUSHJ P,%SHWNF ; SHARE A WINDOW
+ HRLZ A,-2(P) ; PREPARE FOR BLT
+ HRR A,-1(P)
+ HRRZ B,-1(P)
+ BLT A,1777(B) ; SAVE THE PAGE
+CWINF1: MOVE B,-1(P)
+ ASH B,-9. ; TO PAGES
+ MOVNI A,1
+ HRLI B,MFORK ; SET UP HANDLE
+ MOVEI C,0
+ PMAP ; FLUSH BUFFER
+ POP P,C
+ POP P,B
+POPAJ: POP P,A
+ POPJ P,
+
+
+
+; ROUTINE TO RESTORE THE IMAGE FROM A SAVED FORK IMAGE.
+; A== FORK HANDLE B== AOBJN POINTER TO MUDDLE
+; C== START IN INF
+
+
+RSTIM: ASH B,1 ; TO CONVERT TO TENEX PAGES
+ ASH C,1
+ HRLZS A ; FORK HANDLE TO LEFT HALF
+ JUMPE C,RSTIM1 ; SEE IF NO WORK TO DO
+RSTIM2: HRRI A,(C)
+ PUSH P,B ; SAVE B
+ RPACS ; READ PAGE BITS
+ TLNN B,CTEXST ; SKIP IF IT EXISTS
+ JRST RSTIM3
+ HRRZ B,(P) ; GET PAGE
+ HRLI B,MFORK ; GET PAGE BACK TO ME
+ PUSH P,C
+ MOVSI C,CTREAD+CTCW+CTEXEC ; PAGE MODES
+ PMAP ; GET THE PAGE
+ POP P,C ;RESTORE C
+ ASH B,9. ; TO START OF PAGE
+ MOVES 20(B) ; TOUCH PAGE
+RSTIM3: POP P,B ; GET BACK B
+ ADDI C,1 ; INC C
+ AOBJN B,RSTIM2 ; GO BACK IN LOOP
+RSTIM1: POPJ P, ; DONE
+
+
+; ROUTINE TO MAP OUT PARTS OF THE INTERPRETER IN ORDER TO PRESERVE IT
+
+%MPINX: MOVE 0,GCFK1
+ JRST MPIN
+
+%MPIN:
+%MPIN1: MOVE 0,GCFRK
+MPIN: PUSH P,C ; SAVE B
+ MOVE C,A
+ MOVE A,0 ; GET FORK HANDLE
+ PUSHJ P,RSTIM
+ POP P,C
+ POPJ P, ; EXIT
+
+%SAVIN: PUSH P,B ; SAVE AC'S
+ PUSH P,A
+ MOVSI A,CR%CAP
+ CFORK
+ FATAL AGC--CAN'T GET GC FORK
+ MOVEM A,GCFK1 ; SAVE FORK HANDLE
+ POP P,B ; RESTORE AOBJN
+ PUSHJ P,PROTCT ; PROTECT IMAGE
+ MOVE A,[MFORK,,THIBOT]
+ MOVEI 0,777-THIBOT
+%SAVLP: RPACS
+ TLNN B,CTWRIT+CTCW ; SKIP IF NOT READ ONLY
+ TLNN B,CTEXST ; SKIP IF EXISTS (OTHERWISE WE'LL CREATE IT)
+ JRST .+3 ; SKIP IF NOT READ ONLY
+ MOVSI B,CTREAD+CTCW+CTEXEC
+ SPACS
+ ADDI A,1
+ SOJGE 0,%SAVLP
+ POP P,B ; RESTORE AC
+ POPJ P,
+
+%MPRDO: HRLI B,-1
+ HRR B,A
+ JRST PROTCT
+
+
+; CREATE A JOB FOR MARKING HACKS (PURIFY AND GC-DUMP) AND SAVES HANDLE IN TWO SEPERATE
+; PLACES.
+
+%GCJB1: PUSHJ P,%GCJOB ; CREATE FORK
+ MOVE A,GCFRK ; GET HANDLE
+ MOVEM A,GCFK2
+ POPJ P,
+
+%CLSMP: MOVE 0,GCFK2 ; GET BACK FROM FORK CONTAINING UPDATED WORLD
+ PUSHJ P,%GBINT
+%CLSM1: MOVE A,GCFK2 ; KILL THE FORK
+KFK1: KFORK
+%IFMP1:
+%CLSJB: POPJ P, ; IN ITS CLOSES AN INFERIORS CHANNEL WITHOUT
+ ; KILLING IT
+
+; HERE TO KILL THE IMAGE SAVING INFERIOR
+
+%KILJB: PUSH P,A ; SAVE MAPPING PARAMS
+ MOVE A,GCFK1
+ KFORK
+ JRST IFMP3 ; GO FIX UP CORE IMAGE
+
+; HERE TO MAP IN SAVED WORLD AND KILL INF CONTAINING IT
+
+;%IFMP1: POPJ P,
+
+; HERE TO MAP IN A PAGE IN READ ONLY MODE FROM THE AGD INFERIOR
+
+%LDRDO: MOVE 0,GCFK1
+ PUSH P,A ; SAVE PAGE POINTER
+ MOVE B,A
+ HRLI B,-1 ; MAKE UP PAGE POINTER
+ PUSHJ P,MPIN ; MAP IN THE PAGES
+ HRLI B,CTREAD+CTEXEC
+ HRLI A,MFORK ; SET UP HANDLE
+ HRR A,(P)
+ ASH A,1 ; CONVERT TO TENEX PATES
+ HRRZ C,A
+ ASH C,9
+ MOVES 20(C)
+ SPACS
+ ADDI A,1
+ HRRZ C,A
+ ASH C,9
+ MOVES 20(C)
+ SPACS
+ SUB P,C%11 ; CLEAN OFF STACK
+ POPJ P,
+
+%IFMP2: PUSH P,A ; SAVE POINTER
+ MOVE 0,GCFK1
+ PUSHJ P,MPIN ; MAP IT IN
+ MOVE A,GCFK1 ; KILL IT
+ KFORK
+IFMP3: POP P,C
+ ASH C,1
+ MOVSI A,MFORK ; SET UP FORK HANDLE
+ JUMPGE C,IFMP2 ; IF DONE
+DORPA: HRR A,C ; GET PAGE #
+ RPACS
+ TLNN B,CTEXST ; SKIP IF IT EXISTS
+ JRST .+3
+ MOVSI B,CTREAD+CTWRIT+CTEXEC ; CAPABILATIES
+ SPACS ; SET CAPABILATIES
+ AOBJN C,DORPA
+IFMP2: POPJ P,
+
+
+%CLMP1: MOVE A,GCFK1 ; KILL THE FIRST FORK
+ JRST KFK1
+
+%IMSV1:
+%MPINT: PUSH P,C ; SAVE C
+ PUSH P,B
+ PUSH P,D
+ ASH A,1
+ MOVEI C,0
+ MOVE D,A
+MPINT1: MOVSI A,MFORK ; SET UP ARGS TO RMAP
+ HRRI A,(D)
+ RMAP
+ MOVEM A,RMPTAB(C)
+ ADDI C,1
+ AOBJN D,MPINT1
+ POP P,D
+ POP P,B
+ POP P,C
+ POPJ P,
+
+
+; ROUTINE TO GET BACK THE INTERPRETER. IT MAPS
+%GBINT: PUSH P,E
+ PUSH P,B
+ PUSH P,C ; SAVE AC'S
+ PUSH P,D
+ ASH A,1
+ MOVE D,A ; COPY UDDATED AOBJN
+ MOVEI E,0 ; ZERO INDEX TO TABLE
+GBINT1: MOVE A,RMPTAB(E) ; GET FILE HANDLE
+ MOVSI B,MFORK ; SET UP INTERPRETER ARG
+ HRRI B,(D)
+ MOVSI C,CTREAD+CTEXEC
+ PMAP ; IN IT COMES
+ ADDI E,1 ; INC INDEX
+ AOBJN D,GBINT1
+ POP P,D
+ POP P,C
+ POP P,B
+ POP P,E
+ POPJ P,
+
+; HERE TO SAVE RMAP TABLE FOR PURIFY
+
+%SAVRP: PUSH P,A ; SAVE AC
+ MOVE A,[RMPTAB,,ORMTAB]
+ BLT A,ENDRPT-1 ; SAVE RMAP TABLE
+ JRST POPAJ
+; POP P,A ; RESTORE A
+; POPJ P,
+
+; HERE TO RESTORE THE RMAP TABLE FOR PURIFY
+
+%RSTRP: PUSH P,A ; SAVE A
+ MOVE A,[ORMTAB,,RMPTAB]
+ BLT A,ORMTAB-1
+ JRST POPAJ
+; POP P,A ; RESTORE A
+; POPJ P,
+
+SQBLK: ASCIZ /PS:<MDL>MDLXXX.SQUOZE/
+TSQBLK: ASCIZ /DSK:<MDL>MDLXXX.SQUOZE/
+
+; CODE TO DISTINGUISH BETWEEN TOPS20 AND TENEX AT SETUP TIME
+
+TWENTY: HRROI A,C ; RESULTS KEPT HERE
+ HRLOI B,600015
+ MOVEI C,0 ; CLEAN C UP
+ DEVST
+ JFCL
+ MOVEI A,1 ; TENEX HAS OPSYS = 1
+ CAME C,[ASCII/NUL/] ; TOPS20 GIVES "NUL"
+ MOVEM A,OPSYS ; TENEX GIVES "NIL"
+ POPJ P,
+
+;%CLNCO -- FLUSH SOME PAGES FOR SAFETY
+; C ==> ADDR OF PAGE PREV TO LOSERS
+; E ==> JUST ABOVE LOSERS
+
+%CLNCO: PUSH P,C
+ PUSH P,E
+ ADDI C,777
+ ASH C,-9.
+ ASH E,-9.
+ SKIPE MULSEC
+ JRST @[.+1] ; RUN IN SECT 0
+ CAIG E,1(C)
+ JRST %CLN1
+ PUSH P,A
+ PUSH P,B
+
+ MOVSI B,MFORK
+ HRRI B,(C)
+ MOVNI A,1
+ MOVEI C,0
+
+ PMAP
+ CAIL E,2(B)
+ AOJA B,.-2
+
+ POP P,B
+ POP P,A
+
+%CLN1: POP P,E
+ POP P,C
+ SKIPN MULSEC
+ POPJ P,
+
+ XJRST .+1 ; BACK TO SECT 1
+ 0
+ FSEG,,CPOPJ
+
+; MULTI -- ENTER MULTI SEGMENT MODE
+; THIS ROUTINE MAPS EVERYTHING UP AND THEN GOES UP THERE
+
+MULTI: PUSHJ P,PURCLN ; UNMAP ANY CORRENTLY MAPPED FBINS
+ PUSHJ P,SQKIL ; AND SQUOZE TABLE
+ SETOM MULTSG
+ MOVE A,PURBOT ; MUNG TABLE OF THESE GUYS
+ MOVN B,NSEGS
+ MOVSI B,(B)-1
+
+ MOVEM A,PURBTB(B)
+ AOBJN B,.-1
+
+ MOVE A,VECTOP ; CWRITE GC SPACE
+ ANDCMI A,777
+ MOVES (A)
+ SUBI A,1000
+ JUMPG A,.-2
+
+ MOVEI A,0 ; FIRST CREATE OTHER SECTIONS
+ MOVE B,[MFORK,,FSEG]
+ MOVE C,[CTREAD+CTWRIT+CTEXEC,,1]
+ MOVE D,NSEGS
+ SMAP
+ ADDI B,1
+ SOJG D,.-2
+
+; CREATE GC SEGMENT
+
+ HRRI B,GCSEG
+ SMAP
+
+; NOW LOOP AROUND MAPPING PAGES (MAY TAKE SOME TIME)
+
+ MOVEI D,FSEG_9.
+ MOVEI PVP,FSEG
+ ADD PVP,NSEGS
+ LSH PVP,9. ; PVP NOW HIGHEST PAGE TO MAP
+ MOVSI E,-1000 ; 1ST PAGE AND COUNTER
+
+PAGLP: MOVSI A,MFORK
+ HRRI A,(E)
+ RMAP
+ CAME A,C%M1
+ JRST .+3
+ MOVSI A,MFORK
+ HRRI A,(E)
+ MOVSI B,MFORK
+ HRRI B,(E)
+ IORI B,(D)
+ MOVSI C,CTREAD+CTWRIT+CTEXEC
+ PMAP
+LPON: AOBJN E,PAGLP
+
+ MOVSI E,-1000
+ ADDI D,1_9.
+ CAMGE D,PVP
+ JRST PAGLP
+
+; SETUP MULTI SEG LUUO HANDLER
+
+ MOVEI A,MFORK
+ MOVEI B,2 ; CODE FOR SETUP OF UUO TABLE
+ MOVE C,[FSEG,,MLTUUP]
+ SWTRP
+ MOVEI C,FSEG
+ MOVE B,PVSTOR+1
+ MOVE B,TBINIT+1(B)
+ HRLM C,PCSAV(B)
+ PUSHJ P,INTINT
+
+ POP P,C
+ HRLI C,FSEG ; MAKE INTO FUNNY ADDRESS
+ MOVEI B,0
+ TLO TB,400000 ; MAKE TB BE A LOCAL INDEX
+ XJRST B
+
+NOMULT: PUSHJ P,PURCLN
+ JRST @[.+1] ; RUN IN SECTION 0
+ SETZM MULTSG
+ MOVNI A,1
+ MOVE B,[MFORK,,FSEG]
+ MOVEI C,1
+ MOVE D,NSEGS
+ SMAP
+ ADDI B,1
+ SOJG D,.-2
+
+; FLUSH GC SEG
+
+ HRRI B,GCSEG
+ SMAP
+
+ JRST INTINT
+; PUSHJ P,INTINT
+; POPJ P,
+
+MFUNCTION MMS,SUBR,MULTI-SECTION
+
+ ENTRY
+
+ PUSH P,NSEGS
+ PUSH P,MULTSG
+ JUMPGE AB,RMULT ; NO ARGS==>LEAVE
+ CAMGE AB,C%M30 ; [-3,,]
+ JRST TMA
+ GETYP 0,(AB)
+ CAIE 0,TFIX
+ JRST INOUT
+ MOVE 0,1(AB)
+ CAIL 0,2
+ CAILE 0,30
+ JRST OUTRNG
+ MOVEM 0,NSEGS
+INOUT: GETYP 0,(AB)
+ CAIE 0,TFALSE
+ JRST EMULT
+LMULT: SKIPE (P)
+ PUSHJ P,NOMULT
+ JRST RMULT
+
+EMULT: SKIPN (P)
+ PUSHJ P,MULTI
+
+RMULT: POP P,A
+ POP P,B ; POSSIBLE PREV NSEGS
+ JUMPN A,TMULT
+ MOVSI A,TFALSE
+ MOVEI B,0
+ JRST FINIS
+
+TMULT: MOVSI A,TFIX
+ JRST FINIS
+IMPURE
+
+DEMFLG: 0 ; FLAG INDICATING DEMON
+ ; (IF DEMON SIXBIT OF DIRECTORY)
+SFRK: -1 ; FLAG FOR EXTRA INFERIOR HACK
+GCFRK: 0
+GCFK1: 0
+GCFK2: 0
+RMPTAB: BLOCK 25.
+ORMTAB: BLOCK 25.
+ENDRPT:
+
+MESSAG: PUSHJ P,MESOUT ; MESSAGE SWITCH
+
+INITFL: PUSHJ P,MUDINT ; MUDDLE INIT SWITCH
+
+PURE
+
+END
--- /dev/null
+
+TITLE MUDITS -- ITS DEPENDANT MUDDLE CODE
+
+RELOCATABLE
+
+.INSRT MUDDLE >
+
+
+.GLOBAL %SSNAM,%RSNAM,%KILLM,%LOGOU,%SLEEP,%VALRE,NOTTY,DEMFLG,MSGTYP
+.GLOBAL %UNAM,%JNAM,%XUNA,%XJNA,%RUNAM,%RJNAM,%RXUNA,%RXJNA,%GCJB1,%VALFI
+.GLOBAL %GCJOB,%SHWND,%GETIP,%INFMP
+.GLOBAL GCHN,WNDP,FRNP,FRONT,MESSAG,INITFL,6TOCHS,SGSNAM,MTYO,PGINT,WHOAMI
+.GLOBAL %TOPLQ,IPCINI,IPCBLS,%HANG,CTIME,BFLOAT,GCRSET,%MPINT,%GBINT,%SAVIN
+.GLOBAL %MPIN,%MPINX,%CLSMP,%CLSM1,%MPIN1,%IMSAV,%IMSV1,%PURIF,PSHGCF
+.GLOBAL %CLSJB,%KILJB,%IFMP1,%OPGFX,%SAVRP,%RSTRP,%CWINF,%FDBUF,BUFGC,P.TOP,P.CORE
+.GLOBAL PURBOT,SQUPNT,GETSQU,DIR,%LDRDO,%MPRDO,%IFMP2,SQBLK,SQDIR
+.GLOBAL CERR1,CERR2,CERR3,COMPERR,CALER,CALER1,SQLOD,SQKIL,SLEEPR,GETBUF,KILBUF
+
+
+
+GCHN==0
+CWTP==1000,,4000
+RDTP==1000,,200000
+WRTP==1000,,100000
+GCHI==1000,,GCHN
+CRJB==1000,,400001
+FME==1000,,-1
+FLS==1000,,
+
+%RSTRP:
+%OPGFX:
+%SAVRP: POPJ P,
+
+
+SQLOD: MOVEI A,1 ; NUMBER OF PAGES OF BUFFER
+ PUSHJ P,GETBUF
+ HRRM B,SQUPNT
+ ASH B,-10. ; TO PAGES
+ .SUSET [.RSNAM,,A] ; OPEN FILE TO SQUOZE TABLE
+ .SUSET [.SSNAM,,SQDIR] ; SET SNAME
+ .OPEN GCHN,SQBLK
+ FATAL SQUOZE TABLE NON EXISTANT
+ .SUSET [.SSNAM,,A]
+ MOVEI A,0
+ DOTCAL CORBLK,[[RDTP],[FME],B,[GCHI],A]
+ PUSHJ P,SLEEPR
+ .CLOSE GCHN,
+ MOVE A,B ; GET B
+ ASH A,10.
+ POPJ P,
+
+SQKIL: PUSHJ P,KILBUF
+ HLLZS SQUPNT
+ POPJ P,
+
+GETSQU: HRRZ 0,SQUPNT
+ JUMPN 0,ATSQ10
+ JRST SQLOD
+ATSQ10: POPJ P,
+
+
+CTIME: .SUSET [.RRUNT,,B] ; Get user's run time in 4.069 microsecond units
+ IDIVI B,400000
+ FSC C,233
+ FSC B,254
+ FADR B,C
+ FDVR B,[250000.00] ; Change to units of seconds
+ MOVSI A,TFLOAT
+ POPJ P,
+
+; SET THE SNAME GLOBALLY
+
+%SSNAM: .SUSET [.SSNAM,,A]
+ POPJ P,
+
+; READ THE GLOBAL SNAME
+
+%RSNAM: .SUSET [.RSNAM,,A]
+ POPJ P,
+
+; KILL THE CURRENT JOB/LOGOUT
+
+%LOGOU:
+%KILLM: .LOGOUT 1,
+ POPJ P,
+
+; PASS STRING TO SUPERIOR (MONITOR?)
+
+%VALRE: .VALUE (A)
+ POPJ P,
+
+; DO 'KILL'
+%VALFI: .BREAK 16,(A)
+ POPJ P,
+
+; GO TO SLEEP A WHILE
+
+%SLEEP: .SLEEP A,
+ POPJ P,
+
+; HANG FOREVER
+
+%HANG: SKIP
+ .HANG
+
+; READ JNAME
+
+%RJNAM: .SUSET [.RJNAM,,%JNAM]
+ MOVE A,%JNAM
+ POPJ P,
+
+; READ XJNAME
+
+%RXJNA: .SUSET [.RXJNA,,%XJNA]
+ MOVE A,%XJNA
+ POPJ P,
+
+; READ UNAME
+
+%RUNAM: .SUSET [.RUNAM,,%UNAM]
+ MOVE A,%UNAM
+ POPJ P,
+
+; READ XUNAME
+
+%RXUNA: .SUSET [.RXUNA,,%XUNA]
+ MOVE A,%XUNA
+ POPJ P,
+
+; HERE TO SEE IF WE ARE A TOP LEVEL JOB
+
+%TOPLQ: PUSH P,A
+ .SUSET [.RSUPPR,,A] ; READ SUPERIOR
+ SKIPGE A ; SKIP IF IT EXISTS
+ AOS -1(P) ; CAUSE SKIP RET
+ POP P,A
+ POPJ P,
+
+; ERRORS IN COMPILED CODE MAY END UP HERE
+
+CERR1: MOVE A,EQUOTE NTH-BY-A-NEGATIVE-NUMBER
+ .SUSET [.RJPC,,B]
+ JRST CERR
+
+CERR2: MOVE A,EQUOTE NTH-REST-PUT-OUT-OF-RANGE
+ .SUSET [.RJPC,,B]
+ JRST CERR
+
+CERR3: MOVE A,EQUOTE UVECTOR-PUT-TYPE-VIOLATION
+ .SUSET [.RJPC,,B]
+
+COMPERR:
+ MOVE A,EQUOTE ERROR-IN-COMPILED-CODE
+ .SUSET [.RJPC,,B]
+
+CERR: PUSH TP,$TATOM
+ PUSH TP,A
+ PUSH TP,$TWORD
+ PUSH TP,B
+ MOVEI A,2
+ JRST CALER
+\f
+; GET AN INFERIOR FOR THE GARBAGE COLLECTOR
+%GCJB1:
+%GCJOB: PUSH P,A
+ PUSH P,D
+ MOVEI 0,(SIXBIT /USR/)
+ MOVEI A,0 ; USE SAME UNAME
+ MOVSI B,(SIXBIT /AGC/) ; IDENTIFY
+
+; ROUTINE TO SEE WHETHER MAPCHN IS ALREADY OPEN
+
+ .STATUS GCHN,D
+ ANDI D,77
+ MOVEM D,PSHGCF
+ POP P,D
+ SKIPN PSHGCF ; SKIP IF OPEN
+ JRST TRYOPN
+ .IOPUSH GCHN ; PUSH THE CHANNEL
+ MOVSI B,(SIXBIT /AGE/)
+
+TRYOPN: HRLI 0,7 ; READ BLOCK OUTPUT
+ .OPEN GCHN,0 ; TRY IT
+ JRST .+2
+ JRST GCJB1 ; OK, GET A PAGE
+
+ HRLI 0,6
+ .OPEN GCHN,0 ; AND TRY AGAIN
+ AOJA B,TRYOPN ; TRY A NEW NAME
+
+ .UCLOSE GCHN, ; FLUSH JOB
+ .CLOSE GCHN, ; AND CHANNEL
+
+ AOJA B,TRYOPN
+
+GCJB1: HRLI 0,6 ; REOPEN IN READ
+ .OPEN GCHN,0
+ FATAL CAN'T REOPEN INFERIOR IN READ
+ POP P,A ; RET PAGE TO MAP AS 1ST
+ MOVEI B,FRNP ; SET UP FRONTEIR
+ PUSHJ P,%GETIP ; GET IT THERE
+ PUSHJ P,%SHWND
+ POPJ P,
+
+; HERE TO WAIT A WHILE FOR CORE
+
+
+
+; HERE TO GET A PAGE FOR THE INFERIOR
+
+%GETIP: DOTCAL CORBLK,[[WRTP],[GCHI],A,[CRJB]]
+ PUSHJ P,SLEEPR
+ POPJ P,
+
+; HERE TO PURIFY A STRUCTURE
+
+%PURIF: DOTCAL CORBLK,[[RDTP],[FME],A,[FME],A]
+ FATAL UNABLE TO PURIFY STRUCTURE
+ POPJ P,
+
+; HERE TO SHARE WINDOW
+
+%SHWND: DOTCAL CORBLK,[[WRTP],[FME],B,[GCHI],A]
+ FATAL CANT SHARE INFERIOR PAGE
+ POPJ P,
+
+; HERE TO CAUSE INFERIOR TO HOLD ONTO PURE CORE BEING FLUSHED
+
+%MPINT: PUSH P,B
+ MOVE B,A ; COPY PAGE POINTER
+ DOTCAL CORBLK,[[RDTP],[GCHI],A,[FME],B]
+ FATAL CANT CAUSE INFERIOR TO SHARE ME
+ POP P,B
+ POPJ P,
+
+; HERE TO GET BACK WHAT INFERIOR NOW HAS
+
+%GBINT: PUSH P,B
+ MOVE B,A
+ DOTCAL CORBLK,[[RDTP],[FME],A,[GCHI],B]
+ FATAL CANT GET STUFF BACK
+ POP P,B
+ POPJ P,
+
+; HERE TO MAP FROM AN INFERIOR TO A NEW BLOCK IN CORE
+
+%MPINX:
+%MPIN1: PUSH P,B
+ EXCH A,B
+ DOTCAL CORBLK,[[WRTP],[FME],A,[CRJB]]
+ PUSHJ P,SLEEPR
+ POP P,A
+
+; HERE TO MAP FROM THE INFERIOR TO THE CORE IMAGE
+
+%MPIN: DOTCAL CORBLK,[[WRTP],[FME],A,[GCHI],B]
+ FATAL CANT GET INFERIOR CORE BACK
+ POPJ P,
+
+; HERE TO PROTECT CORE IMAGE
+
+%SAVIN: PUSH P,A
+ MOVEI 0,(SIXBIT /USR/)
+ MOVEI A,0 ; USE SAME UNAME
+ MOVSI B,(SIXBIT /AGD/) ; IDENTIFY
+
+TRYOP1: HRLI 0,7 ; WRITE BLOCK OUTPUT
+ .OPEN GCHN,0 ; TRY IT
+ JRST .+2
+ JRST GCJB2 ; OK, GET A PAGE
+
+ HRLI 0,6 ; CHANGE TO READ OPEN
+ .OPEN GCHN,0 ; AND TRY AGAIN
+ AOJA B,TRYOP1 ; TRY A NEW NAME
+
+ .UCLOSE GCHN, ; FLUSH JOB
+ .CLOSE GCHN, ; AND CHANNEL
+
+ AOJA B,TRYOP1
+
+GCJB2: MOVEM B,SAVNAM
+ POP P,A
+%IMSAV: HRRZ 0,A ; SEE IF 0
+ CAIE 0,0
+ JRST IMSAV1
+ ADD A,[1,,1] ; TO NEXT PAGE
+ .ACCESS GCHN,[20] ; ACCESS IN INF
+ PUSH P,B
+ PUSH P,A
+ MOVEI A,0
+ PUSHJ P,%GETIP ; GET AROUND SYSTEM LOSSAGE CONCERNING THE FIRST PAGE
+ MOVE B,[-1760,,20] ; IOT INTO INFERIOR
+ .IOT GCHN,B
+ POP P,A
+ POP P,B
+IMSAV1: MOVE M,A
+ DOTCAL CORBLK,[[WRTP],[GCHI],A,[FME],A]
+ FATAL UNABLE TO PROTECT CORE IMAGE
+IMSAV2:
+; MAKE CORE IMAGE READ ONLY
+
+ MOVE A,M ; RESTORE A
+ DOTCAL CORBLK,[[RDTP],[FME],A,[FME],A]
+ FATAL CORBLK FAILED
+ POPJ P,
+
+; MAP A PAGE INTO AGD INFERIOR IN READ ONLY MODE
+; PAGE NUMBER IS IN A
+
+%MPRDO: DOTCAL CORBLK,[[RDTP],[GCHI],A,[FME],A]
+ FATAL CORBLK FAILED
+ POPJ P,
+
+
+; HERE TO FIND A BUFFER PAGE FOR C/W HACK
+
+%FDBUF: HRRZ A,PURBOT
+ SUB A,P.TOP ; CALCULATE ROOM FOR PROSPECTIVE BUFFER
+ CAIG A,2000 ; SEE IF ROOM
+ JRST FDBUF1
+ MOVE A,P.TOP ; START OF BUFFER
+ HRRM A,BUFGC
+ POPJ P,
+FDBUF1: SETOM BUFGC ; INDICATE NO BUFFER FOUND
+ POPJ P,
+
+; HERE TO SIMULATE COPY ON WRITE. THIS ROUTINE TAKES A SOURCE PAGE IN A
+; AND A BUFFER PAGE IN B
+
+%CWINF: PUSH P,A ; SAVE SOURCE ADDRESS
+ PUSH P,B ; SAVE BUFFER ADDRESS
+ ASH B,-10. ; TO PAGES
+ ASH A,-10.
+ DOTCAL CORBLK,[[RDTP],[FME],B,[FME],A]
+ FATAL COPY-WRITE CORBLK FAILED
+ DOTCAL CORBLK,[[WRTP],[FME],A,[CRJB]]
+ PUSHJ P,SLEEPR
+ HRLZ A,(P) ; GET START OF BUFFER
+ HRR A,-1(P) ; GET START OF SOURCE PAGE
+ EXCH B,-1(P) ; GET BEGINNING OF SOURCE PAGE
+ BLT A,1777(B)
+ MOVE B,-1(P)
+ DOTCAL CORBLK,[[FLS],[FME],B]
+ FATAL CANT FLUSH BUFFER
+ SUB P,[2,,2] ; CLEAN OFF STACK
+ POPJ P, ; EXIT
+
+
+
+; HERE TO PROTECT MUDDLES PURE SPACE
+%IMSV1: MOVE M,A
+ PUSHJ P,%MPINT
+ POPJ P,
+
+; HERE TO CLOSE THE IMAGE SAVING INFERIOR WITHOUT KILLING IT
+
+%CLSJB: .CLOSE GCHN,
+ POPJ P,
+
+; HERE TO OPEN AGD INFERIOR IN ORDER TO RESTORE CORE-IMAGE
+
+%IFMP1: .IOPUSH GCHN ; PUSH CURRENT CONTENTS OF CHANNEL
+ PUSH P,A ; SAVE AC'S
+ PUSH P,B
+ MOVEI 0,(SIXBIT /USR/)
+ MOVEI A,0
+ MOVE B,SAVNAM
+ HRLI 0,6
+ .OPEN GCHN,0
+ FATAL AGD INFERIOR LOST
+ POP P,A
+ POP P,B
+ POPJ P,
+
+; HERE TO MAP IN A PURE PAGE FROM THE AGD INFERIOR
+
+%LDRDO: DOTCAL CORBLK,[[RDTP],[FME],A,[GCHI],A]
+ FATAL CORBLK FAILED
+ POPJ P,
+
+
+
+; HERE TO MAP IN FROM AGD INFERIOR AND KILL CORE IMAGE AS WELL
+; A HAS SOURCE PAGES AND B DESTINATION PAGES
+
+%IFMP2: PUSHJ P,%INFMP
+ .IOPOP GCHN
+ POPJ P,
+
+;HERE TO KILL AN IMAGE SAVING INFERIOR
+%KILJB: .IOPUSH GCHN
+ PUSH P,0
+ PUSH P,B
+ PUSH P,C
+ PUSH P,A
+ MOVEI 0,(SIXBIT /USR/)
+ MOVE B,SAVNAM
+ HRLI 0,6
+ MOVEI A,0
+ .OPEN GCHN,0
+ FATAL AGD INFERIOR LOST
+CKPGU: HRRZ A,(P)
+ DOTCAL CORTYP,[A,,[2000,,B]]
+ FATAL CORBLK TO UNPURE PAGES FAILED
+ JUMPL B,PGW
+ DOTCAL CORBLK,[[WRTP],[FME],A,[GCHI],A]
+ FATAL CORBLK TO UNPURE PAGES FAILED
+PGW: POP P,A
+ ADD A,[1,,1]
+ SKIPL A
+ JRST KILIT
+ PUSH P,A ; REPUSH A
+ JRST CKPGU
+KILIT: .UCLOS GCHN,
+ .CLOSE GCHN,
+ POP P,C
+ POP P,B
+ POP P,0
+ .IOPOP GCHN
+ POPJ P,
+
+; HERE TO MAP INFERIOR BACK AND KILL SAME
+
+%INFMP: PUSHJ P,%MPIN ; MAP IN IMAGE
+ .UCLOSE GCHN,
+ .CLOSE GCHN,
+ SKIPE PSHGCF ; SKIP IF CHANNEL IS NOT PUSHED
+ JRST INFMPX
+ POPJ P,
+INFMPX: .IOPOP GCHN ; HAVE MORE THAN ONE GC-INF OPEN IOPOP
+ SETZM PSHGCF
+ POPJ P,
+
+
+; USED TO MAP INFERIOR CONTAINING CORE IMAGE BACK IN AND KILL SAVE
+
+%CLSMP: PUSHJ P,%GBINT
+%CLSM1: .UCLOSE GCHN,
+ .CLOSE GCHN,
+ POPJ P,
+
+; HACK TO PRINT MESSAGE OF INTEREST TO USER
+
+MESOUT: MOVSI A,(JFCL)
+ MOVEM A,MESSAG ; DO ONLY ONCE
+ MOVE A,P.TOP
+ ADDI A,1777 ; MAKE SURE ON PAGE BOUNDRY
+ ASH A,-10. ; TO PAGES
+ MOVE B,VECTOP ; GET VECTOR
+ ADDI B,1777 ; PAGE AND ROUND
+ ANDCMI B,1777
+ MOVEM B,P.TOP
+ PUSHJ P,P.CORE ; GET CORE
+ JFCL
+ SETZB SP,FRM ; HACK TO AVOID LOSSAGE WITH GARBAGE IN SP FIRST TIME
+ PUSHJ P,PGINT ; INITIALIZE PAGE MAP
+ PUSHJ P,GCRSET
+ PUSHJ P,%RSNAM ; GET SAVED SNAME
+ PUSH P,A ; SAVE IT
+ SKIPE NOTTY ; HAVE A TTY?
+ JRST RESNM ; NO, SKIP THIS STUFF
+ MOVE A,[SIXBIT /MUDSYS/]
+ PUSHJ P,%SSNAM
+ MOVEI A,(SIXBIT /DSK/)
+ SKIPN B,WHOAMI
+ MOVE B,[SIXBIT /MUDDLE/]
+ MOVE C,[SIXBIT /MESSAG/]
+ .OPEN 0,A
+ JRST RESNM
+MESSI: .IOT 0,A ; READ A CHAR
+ JUMPL A,MESCLS ; DONE, QUIT
+ CAIE A,14 ; DONT TYPE FF
+ PUSHJ P,MTYO ; AND TYPE IT OUT
+ JRST MESSI ; UNTIL DONE
+
+MESCLS: .CLOSE 0,
+
+RESNM: POP P,A ; GET SAVED SNAME BACK
+ PUSHJ P,%SSNAM ; AND SET IT BACK
+RESNM1: POPJ P,
+
+MUDINT: MOVSI 0,(JFCL) ; CLOBBER MUDDLE INIT SWITCH
+ MOVEM 0,INITFL
+ PUSHJ P,%RSNAM ; GET SNAME
+ CAMN A,[-1] ; NO SNAME ?
+ MOVE A,[SIXBIT /MUDSUB/] ; FOR DEMONS AND THE LIKE
+ PUSHJ P,6TOCHS ; TO STRING
+ PUSH TP,$TATOM
+ PUSH TP,IMQUOTE SNM
+ PUSH TP,A
+ PUSH TP,B
+ MCALL 2,SETG
+ PUSHJ P,SGSNAM ; SET TO GLOBAL
+ MOVE E,A ; SAVE IN E
+ MOVEI A,(SIXBIT /DSK/)
+ MOVE C,[SIXBIT /INIT/]
+ SKIPN B,WHOAMI ; SKIP IF NOT A STRAIGHT MUDDLE
+ JRST STMUDL
+
+ .OPEN 0,A
+ SKIPA D,E
+ JRST MUDIN1
+
+ CAMN D,[SIXBIT /MUDSUB/]
+ POPJ P,
+ .SUSET [.SSNAM,,[SIXBIT /MUDSUB/]]
+MUDIN2: .OPEN 0,A
+ POPJ P,
+MUDIN1: .CLOSE 0,
+ PUSH TP,$TCHSTR ; ATTEMPT TO LOAD A MUDDLE INIT FILE
+ PUSH TP,CHQUOTE READ
+ MOVE A,B
+ PUSHJ P,6TOCHS
+ PUSH TP,A
+ PUSH TP,B
+ PUSH TP,$TCHSTR
+ PUSH TP,CHQUOTE INIT
+ PUSH TP,$TCHSTR
+ PUSH TP,CHQUOTE DSK
+ .SUSET [.RSNAM,,A] ; USE SNAME AROUND
+ PUSHJ P,6TOCHS
+ PUSH TP,A
+ PUSH TP,B
+ MCALL 5,FOPEN
+ GETYP 0,A
+ CAIE 0,TCHAN ; DID THE CHANNEL OPEN ?
+ POPJ P, ; NO, RETURN
+ PUSH TP,A
+ PUSH TP,B
+ MOVEI B,INITSTR ; TELL USER WHAT'S HAPPENING
+ SKIPE WHOAMI
+ JRST .+3
+ SKIPN NOTTY
+ PUSHJ P,MSGTYP
+ MCALL 1,MLOAD
+ POPJ P,
+
+
+; BLOCK TO OPEN SQUOZE TABLE
+
+SQDIR: SIXBIT /MUDSAV/
+
+SQBLK: SIXBIT / &DSK/
+ SIXBIT /SQUOZE/
+ SIXBIT /TABLE/
+
+STMUDL: MOVE B,[SIXBIT /MUDDLE/]
+ JRST MUDIN2
+
+IPCINI: PUSHJ P,IPCBLS
+
+INITSTR: ASCIZ /MUDDLE INIT/
+
+IMPURE
+SAVNAM: 0 ; SAVED AGD INFERIOR NAME
+DEMFLG: 0
+
+
+MESSAG: PUSHJ P,MESOUT ; MESSAGE SWITCH
+
+INITFL: PUSHJ P,MUDINT ; MUDDLE INIT SWITCH
+
+PURE
+
+END
+\f\ 3\ 3\ 3
\ No newline at end of file
--- /dev/null
+
+TITLE MUDITS -- ITS DEPENDANT MUDDLE CODE
+
+RELOCATABLE
+
+.INSRT MUDDLE >
+
+
+.GLOBAL %SSNAM,%RSNAM,%KILLM,%LOGOU,%SLEEP,%VALRE,NOTTY,DEMFLG,MSGTYP
+.GLOBAL %UNAM,%JNAM,%XUNA,%XJNA,%RUNAM,%RJNAM,%RXUNA,%RXJNA,%GCJB1,%VALFI
+.GLOBAL %GCJOB,%SHWND,%GETIP,%INFMP
+.GLOBAL GCHN,WNDP,FRNP,FRONT,MESSAG,INITFL,6TOCHS,SGSNAM,MTYO,PGINT,WHOAMI
+.GLOBAL %TOPLQ,IPCINI,IPCBLS,%HANG,CTIME,BFLOAT,GCRSET,%MPINT,%GBINT,%SAVIN
+.GLOBAL %MPIN,%MPINX,%CLSMP,%CLSM1,%MPIN1,%IMSAV,%IMSV1,%PURIF,PSHGCF
+.GLOBAL %CLSJB,%KILJB,%IFMP1,%OPGFX,%SAVRP,%RSTRP,%CWINF,%FDBUF,BUFGC,P.TOP,P.CORE
+.GLOBAL PURBOT,SQUPNT,GETSQU,DIR,%LDRDO,%MPRDO,%IFMP2,SQBLK,SQDIR
+.GLOBAL CERR1,CERR2,CERR3,COMPERR,CALER,CALER1,SQLOD,SQKIL,SLEEPR,GETBUF,KILBUF
+
+
+
+GCHN==0
+CWTP==1000,,4000
+RDTP==1000,,200000
+WRTP==1000,,100000
+GCHI==1000,,GCHN
+CRJB==1000,,400001
+FME==1000,,-1
+FLS==1000,,
+
+%RSTRP:
+%OPGFX:
+%SAVRP: POPJ P,
+
+
+SQLOD: MOVEI A,1 ; NUMBER OF PAGES OF BUFFER
+ PUSHJ P,GETBUF
+ HRRM B,SQUPNT
+ ASH B,-10. ; TO PAGES
+ .SUSET [.RSNAM,,A] ; OPEN FILE TO SQUOZE TABLE
+ .SUSET [.SSNAM,,SQDIR] ; SET SNAME
+ .OPEN GCHN,SQBLK
+ FATAL SQUOZE TABLE NON EXISTANT
+ .SUSET [.SSNAM,,A]
+ DOTCAL FILLEN,[[GCHI],[2000,,A]]
+ .LOSE %LSFIL ;PRESUMABLY LOSSAGE MATTERS
+ MOVNS A
+ HRLM A,SQUPNT
+ MOVEI A,0
+ DOTCAL CORBLK,[[RDTP],[FME],B,[GCHI],A]
+ PUSHJ P,SLEEPR
+ .CLOSE GCHN,
+ MOVE A,B ; GET B
+ ASH A,10.
+ POPJ P,
+
+SQKIL: PUSHJ P,KILBUF
+ HLLZS SQUPNT
+ POPJ P,
+
+GETSQU: HRRZ 0,SQUPNT
+ JUMPN 0,ATSQ10
+ JRST SQLOD
+ATSQ10: POPJ P,
+
+
+CTIME: .SUSET [.RRUNT,,B] ; Get user's run time in 4.069 microsecond units
+ IDIVI B,400000
+ FSC C,233
+ FSC B,254
+ FADR B,C
+ FDVR B,[250000.00] ; Change to units of seconds
+ MOVSI A,TFLOAT
+ POPJ P,
+
+; SET THE SNAME GLOBALLY
+
+%SSNAM: .SUSET [.SSNAM,,A]
+ POPJ P,
+
+; READ THE GLOBAL SNAME
+
+%RSNAM: .SUSET [.RSNAM,,A]
+ POPJ P,
+
+; KILL THE CURRENT JOB/LOGOUT
+
+%LOGOU:
+%KILLM: .LOGOUT 1,
+ POPJ P,
+
+; PASS STRING TO SUPERIOR (MONITOR?)
+
+%VALRE: .VALUE (A)
+ POPJ P,
+
+; DO 'KILL'
+%VALFI: .BREAK 16,(A)
+ POPJ P,
+
+; GO TO SLEEP A WHILE
+
+%SLEEP: .SLEEP A,
+ POPJ P,
+
+; HANG FOREVER
+
+%HANG: SKIP
+ .HANG
+
+; READ JNAME
+
+%RJNAM: .SUSET [.RJNAM,,%JNAM]
+ MOVE A,%JNAM
+ POPJ P,
+
+; READ XJNAME
+
+%RXJNA: .SUSET [.RXJNA,,%XJNA]
+ MOVE A,%XJNA
+ POPJ P,
+
+; READ UNAME
+
+%RUNAM: .SUSET [.RUNAM,,%UNAM]
+ MOVE A,%UNAM
+ POPJ P,
+
+; READ XUNAME
+
+%RXUNA: .SUSET [.RXUNA,,%XUNA]
+ MOVE A,%XUNA
+ POPJ P,
+
+; HERE TO SEE IF WE ARE A TOP LEVEL JOB
+
+%TOPLQ: PUSH P,A
+ .SUSET [.RSUPPR,,A] ; READ SUPERIOR
+ SKIPGE A ; SKIP IF IT EXISTS
+ AOS -1(P) ; CAUSE SKIP RET
+ POP P,A
+ POPJ P,
+
+; ERRORS IN COMPILED CODE MAY END UP HERE
+
+CERR1: MOVE A,EQUOTE NTH-BY-A-NEGATIVE-NUMBER
+ .SUSET [.RJPC,,B]
+ JRST CERR
+
+CERR2: MOVE A,EQUOTE NTH-REST-PUT-OUT-OF-RANGE
+ .SUSET [.RJPC,,B]
+ JRST CERR
+
+CERR3: MOVE A,EQUOTE UVECTOR-PUT-TYPE-VIOLATION
+ .SUSET [.RJPC,,B]
+
+COMPERR:
+ MOVE A,EQUOTE ERROR-IN-COMPILED-CODE
+ .SUSET [.RJPC,,B]
+
+CERR: PUSH TP,$TATOM
+ PUSH TP,A
+ PUSH TP,$TWORD
+ PUSH TP,B
+ MOVEI A,2
+ JRST CALER
+\f
+; GET AN INFERIOR FOR THE GARBAGE COLLECTOR
+%GCJB1:
+%GCJOB: PUSH P,A
+ PUSH P,D
+ MOVEI 0,(SIXBIT /USR/)
+ MOVEI A,0 ; USE SAME UNAME
+ MOVSI B,(SIXBIT /AGC/) ; IDENTIFY
+
+; ROUTINE TO SEE WHETHER MAPCHN IS ALREADY OPEN
+
+ .STATUS GCHN,D
+ ANDI D,77
+ MOVEM D,PSHGCF
+ POP P,D
+ SKIPN PSHGCF ; SKIP IF OPEN
+ JRST TRYOPN
+ .IOPUSH GCHN ; PUSH THE CHANNEL
+ MOVSI B,(SIXBIT /AGE/)
+
+TRYOPN: HRLI 0,7 ; READ BLOCK OUTPUT
+ .OPEN GCHN,0 ; TRY IT
+ JRST .+2
+ JRST GCJB1 ; OK, GET A PAGE
+
+ HRLI 0,6
+ .OPEN GCHN,0 ; AND TRY AGAIN
+ AOJA B,TRYOPN ; TRY A NEW NAME
+
+ .UCLOSE GCHN, ; FLUSH JOB
+ .CLOSE GCHN, ; AND CHANNEL
+
+ AOJA B,TRYOPN
+
+GCJB1: HRLI 0,6 ; REOPEN IN READ
+ .OPEN GCHN,0
+ FATAL CAN'T REOPEN INFERIOR IN READ
+ POP P,A ; RET PAGE TO MAP AS 1ST
+ MOVEI B,FRNP ; SET UP FRONTEIR
+ PUSHJ P,%GETIP ; GET IT THERE
+ PUSHJ P,%SHWND
+ POPJ P,
+
+; HERE TO WAIT A WHILE FOR CORE
+
+
+
+; HERE TO GET A PAGE FOR THE INFERIOR
+
+%GETIP: DOTCAL CORBLK,[[WRTP],[GCHI],A,[CRJB]]
+ PUSHJ P,SLEEPR
+ POPJ P,
+
+; HERE TO PURIFY A STRUCTURE
+
+%PURIF: DOTCAL CORBLK,[[RDTP],[FME],A,[FME],A]
+ FATAL UNABLE TO PURIFY STRUCTURE
+ POPJ P,
+
+; HERE TO SHARE WINDOW
+
+%SHWND: DOTCAL CORBLK,[[WRTP],[FME],B,[GCHI],A]
+ FATAL CANT SHARE INFERIOR PAGE
+ POPJ P,
+
+; HERE TO CAUSE INFERIOR TO HOLD ONTO PURE CORE BEING FLUSHED
+
+%MPINT: PUSH P,B
+ MOVE B,A ; COPY PAGE POINTER
+ DOTCAL CORBLK,[[RDTP],[GCHI],A,[FME],B]
+ FATAL CANT CAUSE INFERIOR TO SHARE ME
+ POP P,B
+ POPJ P,
+
+; HERE TO GET BACK WHAT INFERIOR NOW HAS
+
+%GBINT: PUSH P,B
+ MOVE B,A
+ DOTCAL CORBLK,[[RDTP],[FME],A,[GCHI],B]
+ FATAL CANT GET STUFF BACK
+ POP P,B
+ POPJ P,
+
+; HERE TO MAP FROM AN INFERIOR TO A NEW BLOCK IN CORE
+
+%MPINX:
+%MPIN1: PUSH P,B
+ EXCH A,B
+ DOTCAL CORBLK,[[WRTP],[FME],A,[CRJB]]
+ PUSHJ P,SLEEPR
+ POP P,A
+
+; HERE TO MAP FROM THE INFERIOR TO THE CORE IMAGE
+
+%MPIN: DOTCAL CORBLK,[[WRTP],[FME],A,[GCHI],B]
+ FATAL CANT GET INFERIOR CORE BACK
+ POPJ P,
+
+; HERE TO PROTECT CORE IMAGE
+
+%SAVIN: PUSH P,A
+ MOVEI 0,(SIXBIT /USR/)
+ MOVEI A,0 ; USE SAME UNAME
+ MOVSI B,(SIXBIT /AGD/) ; IDENTIFY
+
+TRYOP1: HRLI 0,7 ; WRITE BLOCK OUTPUT
+ .OPEN GCHN,0 ; TRY IT
+ JRST .+2
+ JRST GCJB2 ; OK, GET A PAGE
+
+ HRLI 0,6 ; CHANGE TO READ OPEN
+ .OPEN GCHN,0 ; AND TRY AGAIN
+ AOJA B,TRYOP1 ; TRY A NEW NAME
+
+ .UCLOSE GCHN, ; FLUSH JOB
+ .CLOSE GCHN, ; AND CHANNEL
+
+ AOJA B,TRYOP1
+
+GCJB2: MOVEM B,SAVNAM
+ POP P,A
+%IMSAV: HRRZ 0,A ; SEE IF 0
+ CAIE 0,0
+ JRST IMSAV1
+ ADD A,[1,,1] ; TO NEXT PAGE
+ .ACCESS GCHN,[20] ; ACCESS IN INF
+ PUSH P,B
+ PUSH P,A
+ MOVEI A,0
+ PUSHJ P,%GETIP ; GET AROUND SYSTEM LOSSAGE CONCERNING THE FIRST PAGE
+ MOVE B,[-1760,,20] ; IOT INTO INFERIOR
+ .IOT GCHN,B
+ POP P,A
+ POP P,B
+IMSAV1: MOVE M,A
+ DOTCAL CORBLK,[[WRTP],[GCHI],A,[FME],A]
+ FATAL UNABLE TO PROTECT CORE IMAGE
+IMSAV2:
+; MAKE CORE IMAGE READ ONLY
+
+ MOVE A,M ; RESTORE A
+ DOTCAL CORBLK,[[RDTP],[FME],A,[FME],A]
+ FATAL CORBLK FAILED
+ POPJ P,
+
+; MAP A PAGE INTO AGD INFERIOR IN READ ONLY MODE
+; PAGE NUMBER IS IN A
+
+%MPRDO: DOTCAL CORBLK,[[RDTP],[GCHI],A,[FME],A]
+ FATAL CORBLK FAILED
+ POPJ P,
+
+
+; HERE TO FIND A BUFFER PAGE FOR C/W HACK
+
+%FDBUF: HRRZ A,PURBOT
+ SUB A,P.TOP ; CALCULATE ROOM FOR PROSPECTIVE BUFFER
+ CAIG A,2000 ; SEE IF ROOM
+ JRST FDBUF1
+ MOVE A,P.TOP ; START OF BUFFER
+ HRRM A,BUFGC
+ POPJ P,
+FDBUF1: SETOM BUFGC ; INDICATE NO BUFFER FOUND
+ POPJ P,
+
+; HERE TO SIMULATE COPY ON WRITE. THIS ROUTINE TAKES A SOURCE PAGE IN A
+; AND A BUFFER PAGE IN B
+
+%CWINF: PUSH P,A ; SAVE SOURCE ADDRESS
+ PUSH P,B ; SAVE BUFFER ADDRESS
+ ASH B,-10. ; TO PAGES
+ ASH A,-10.
+ DOTCAL CORBLK,[[RDTP],[FME],B,[FME],A]
+ FATAL COPY-WRITE CORBLK FAILED
+ DOTCAL CORBLK,[[WRTP],[FME],A,[CRJB]]
+ PUSHJ P,SLEEPR
+ HRLZ A,(P) ; GET START OF BUFFER
+ HRR A,-1(P) ; GET START OF SOURCE PAGE
+ EXCH B,-1(P) ; GET BEGINNING OF SOURCE PAGE
+ BLT A,1777(B)
+ MOVE B,-1(P)
+ DOTCAL CORBLK,[[FLS],[FME],B]
+ FATAL CANT FLUSH BUFFER
+ SUB P,[2,,2] ; CLEAN OFF STACK
+ POPJ P, ; EXIT
+
+
+
+; HERE TO PROTECT MUDDLES PURE SPACE
+%IMSV1: MOVE M,A
+ PUSHJ P,%MPINT
+ POPJ P,
+
+; HERE TO CLOSE THE IMAGE SAVING INFERIOR WITHOUT KILLING IT
+
+%CLSJB: .CLOSE GCHN,
+ POPJ P,
+
+; HERE TO OPEN AGD INFERIOR IN ORDER TO RESTORE CORE-IMAGE
+
+%IFMP1: .IOPUSH GCHN ; PUSH CURRENT CONTENTS OF CHANNEL
+ PUSH P,A ; SAVE AC'S
+ PUSH P,B
+ MOVEI 0,(SIXBIT /USR/)
+ MOVEI A,0
+ MOVE B,SAVNAM
+ HRLI 0,6
+ .OPEN GCHN,0
+ FATAL AGD INFERIOR LOST
+ POP P,A
+ POP P,B
+ POPJ P,
+
+; HERE TO MAP IN A PURE PAGE FROM THE AGD INFERIOR
+
+%LDRDO: DOTCAL CORBLK,[[RDTP],[FME],A,[GCHI],A]
+ FATAL CORBLK FAILED
+ POPJ P,
+
+
+
+; HERE TO MAP IN FROM AGD INFERIOR AND KILL CORE IMAGE AS WELL
+; A HAS SOURCE PAGES AND B DESTINATION PAGES
+
+%IFMP2: PUSHJ P,%INFMP
+ .IOPOP GCHN
+ POPJ P,
+
+;HERE TO KILL AN IMAGE SAVING INFERIOR
+%KILJB: .IOPUSH GCHN
+ PUSH P,0
+ PUSH P,B
+ PUSH P,C
+ PUSH P,A
+ MOVEI 0,(SIXBIT /USR/)
+ MOVE B,SAVNAM
+ HRLI 0,6
+ MOVEI A,0
+ .OPEN GCHN,0
+ FATAL AGD INFERIOR LOST
+CKPGU: HRRZ A,(P)
+ DOTCAL CORTYP,[A,,[2000,,B]]
+ FATAL CORBLK TO UNPURE PAGES FAILED
+ JUMPL B,PGW
+ DOTCAL CORBLK,[[WRTP],[FME],A,[GCHI],A]
+ FATAL CORBLK TO UNPURE PAGES FAILED
+PGW: POP P,A
+ ADD A,[1,,1]
+ SKIPL A
+ JRST KILIT
+ PUSH P,A ; REPUSH A
+ JRST CKPGU
+KILIT: .UCLOS GCHN,
+ .CLOSE GCHN,
+ POP P,C
+ POP P,B
+ POP P,0
+ .IOPOP GCHN
+ POPJ P,
+
+; HERE TO MAP INFERIOR BACK AND KILL SAME
+
+%INFMP: PUSHJ P,%MPIN ; MAP IN IMAGE
+ .UCLOSE GCHN,
+ .CLOSE GCHN,
+ SKIPE PSHGCF ; SKIP IF CHANNEL IS NOT PUSHED
+ JRST INFMPX
+ POPJ P,
+INFMPX: .IOPOP GCHN ; HAVE MORE THAN ONE GC-INF OPEN IOPOP
+ SETZM PSHGCF
+ POPJ P,
+
+
+; USED TO MAP INFERIOR CONTAINING CORE IMAGE BACK IN AND KILL SAVE
+
+%CLSMP: PUSHJ P,%GBINT
+%CLSM1: .UCLOSE GCHN,
+ .CLOSE GCHN,
+ POPJ P,
+
+; HACK TO PRINT MESSAGE OF INTEREST TO USER
+
+MESOUT: MOVSI A,(JFCL)
+ MOVEM A,MESSAG ; DO ONLY ONCE
+ MOVE A,P.TOP
+ ADDI A,1777 ; MAKE SURE ON PAGE BOUNDRY
+ ASH A,-10. ; TO PAGES
+ MOVE B,VECTOP ; GET VECTOR
+ ADDI B,1777 ; PAGE AND ROUND
+ ANDCMI B,1777
+ MOVEM B,P.TOP
+ PUSHJ P,P.CORE ; GET CORE
+ JFCL
+ SETZB SP,FRM ; HACK TO AVOID LOSSAGE WITH GARBAGE IN SP FIRST TIME
+ PUSHJ P,PGINT ; INITIALIZE PAGE MAP
+ PUSHJ P,GCRSET
+ PUSHJ P,%RSNAM ; GET SAVED SNAME
+ PUSH P,A ; SAVE IT
+ SKIPE NOTTY ; HAVE A TTY?
+ JRST RESNM ; NO, SKIP THIS STUFF
+ MOVE A,[SIXBIT /MUDSYS/]
+ PUSHJ P,%SSNAM
+ MOVEI A,(SIXBIT /DSK/)
+ SKIPN B,WHOAMI
+ MOVE B,[SIXBIT /MUDDLE/]
+ MOVE C,[SIXBIT /MESSAG/]
+ .OPEN 0,A
+ JRST RESNM
+MESSI: .IOT 0,A ; READ A CHAR
+ JUMPL A,MESCLS ; DONE, QUIT
+ CAIE A,14 ; DONT TYPE FF
+ PUSHJ P,MTYO ; AND TYPE IT OUT
+ JRST MESSI ; UNTIL DONE
+
+MESCLS: .CLOSE 0,
+
+RESNM: POP P,A ; GET SAVED SNAME BACK
+ PUSHJ P,%SSNAM ; AND SET IT BACK
+RESNM1: POPJ P,
+
+MUDINT: MOVSI 0,(JFCL) ; CLOBBER MUDDLE INIT SWITCH
+ MOVEM 0,INITFL
+ PUSHJ P,%RSNAM ; GET SNAME
+ CAMN A,[-1] ; NO SNAME ?
+ MOVE A,[SIXBIT /MUDSUB/] ; FOR DEMONS AND THE LIKE
+ PUSHJ P,6TOCHS ; TO STRING
+ PUSH TP,$TATOM
+ PUSH TP,IMQUOTE SNM
+ PUSH TP,A
+ PUSH TP,B
+ MCALL 2,SETG
+ PUSHJ P,SGSNAM ; SET TO GLOBAL
+ MOVE E,A ; SAVE IN E
+ MOVEI A,(SIXBIT /DSK/)
+ MOVE C,[SIXBIT /INIT/]
+ SKIPN B,WHOAMI ; SKIP IF NOT A STRAIGHT MUDDLE
+ JRST STMUDL
+
+ .OPEN 0,A
+ SKIPA D,E
+ JRST MUDIN1
+
+ CAMN D,[SIXBIT /MUDSUB/]
+ POPJ P,
+ .SUSET [.SSNAM,,[SIXBIT /MUDSUB/]]
+MUDIN2: .OPEN 0,A
+ POPJ P,
+MUDIN1: .CLOSE 0,
+ PUSH TP,$TCHSTR ; ATTEMPT TO LOAD A MUDDLE INIT FILE
+ PUSH TP,CHQUOTE READ
+ MOVE A,B
+ PUSHJ P,6TOCHS
+ PUSH TP,A
+ PUSH TP,B
+ PUSH TP,$TCHSTR
+ PUSH TP,CHQUOTE INIT
+ PUSH TP,$TCHSTR
+ PUSH TP,CHQUOTE DSK
+ .SUSET [.RSNAM,,A] ; USE SNAME AROUND
+ PUSHJ P,6TOCHS
+ PUSH TP,A
+ PUSH TP,B
+ MCALL 5,FOPEN
+ GETYP 0,A
+ CAIE 0,TCHAN ; DID THE CHANNEL OPEN ?
+ POPJ P, ; NO, RETURN
+ PUSH TP,A
+ PUSH TP,B
+ MOVEI B,INITSTR ; TELL USER WHAT'S HAPPENING
+ SKIPE WHOAMI
+ JRST .+3
+ SKIPN NOTTY
+ PUSHJ P,MSGTYP
+ MCALL 1,MLOAD
+ POPJ P,
+
+
+; BLOCK TO OPEN SQUOZE TABLE
+
+SQDIR: SIXBIT /MUDSAV/
+
+SQBLK: SIXBIT / &DSK/
+ SIXBIT /SQUOZE/
+ SIXBIT /TABLE/
+
+STMUDL: MOVE B,[SIXBIT /MUDDLE/]
+ JRST MUDIN2
+
+IPCINI: PUSHJ P,IPCBLS
+
+INITSTR: ASCIZ /MUDDLE INIT/
+
+IMPURE
+SAVNAM: 0 ; SAVED AGD INFERIOR NAME
+DEMFLG: 0
+
+
+MESSAG: PUSHJ P,MESOUT ; MESSAGE SWITCH
+
+INITFL: PUSHJ P,MUDINT ; MUDDLE INIT SWITCH
+
+PURE
+
+END
+\f
\ No newline at end of file
--- /dev/null
+
+TITLE SQUOZE TABLE HANDLER FOR MUDDLE
+
+RELOCATABLE
+
+.INSRT MUDDLE >
+
+.GLOBAL SQUPNT,ATOSQ,SQUTOA,GETSQU,CSQUTA,MPOPJ,SAT,SQUKIL,SQKIL
+
+; ROUTINE TO KILL FIXUP TABLE SOMETIMES
+
+SQUKIL: PUSH P,0 ; SAVE ACS
+ HRRZ 0,SQUPNT ; SEE IF IN INTERPRETER
+ CAIG 0,HIBOT
+ JRST POPJ0
+ PUSH P,A
+ PUSH P,B
+ PUSH P,C
+ PUSH P,D
+ PUSH P,E
+ PUSHJ P,SQKIL ; KILL THE BUFFER AND RESTORE INTERPRETER
+ POP P,E
+ POP P,D
+ POP P,C ; RESTORE AC'S
+ POP P,B
+ POP P,A
+POPJ0: POP P,0
+ POPJ P,
+
+
+; POINTER TO TABLE FILLED IN BY INITM
+
+; SUBR TO INTERFACE TO MUDDLE SQUOZE TABLE.
+; IT TAKES AN ARGUMENT OF PRIMTYPE WORD AND RETURNS A FIX GIVING THE
+; LOCATION IF IT IS IN THE SQUOZE TABLE AND OTHERWISE RETURNS FALSE
+
+ MFUNCTION SQUOTA,SUBR
+ ENTRY 1
+
+ GETYP A,(AB)
+ PUSHJ P,SAT ; GET SAT OF ARGUMENT
+ CAIE A,S1WORD ; BETTER BE OF PRIMTYPE WORD
+ JRST WTYP1
+ MOVE A,1(AB) ; GET ARGUMENT INTO A
+ PUSHJ P,CSQUTA
+ JFCL
+ JRST FINIS
+
+
+; COMPILER ENTRY TAKES ARGUMENT IN A
+
+CSQUTA: SUBM M,(P) ; RELATAVIZE P
+ MOVE E,A ; ARG TO SQUOTA
+ TLZ E,740000 ; FLUSH EXTRA BITS FOR LOOKUP
+ PUSHJ P,SQUTOA
+ JRST GTFALS
+ SOS (P) ; AND SKIP RETURN
+ PUSHJ P,SQUKIL
+ MOVSI A,TFIX ; RETURN FIX
+ MOVE B,E
+ JRST MPOPJ
+GTFALS: PUSHJ P,SQUKIL
+ MOVE A,$TFALSE
+ MOVEI B,0
+ JRST MPOPJ ; RETURN A FALSE
+
+
+; GIVEN LOCN OF SUBR RET SQUO NAME ARG AND VAL IN E
+
+ATOSQ: PUSH P,B
+ PUSH P,A
+ PUSHJ P,GETSQU
+ MOVE A,SQUPNT ; GET TABLE POINTER
+ MOVE B,[2,,2]
+ CAMN E,1(A)
+ JRST ATOSQ1
+ ADD A,B
+ JUMPL A,.-3
+POPABJ: PUSH P,E ; SAVE RESULT
+ PUSHJ P,SQUKIL
+ POP P,E
+ POP P,B
+ POP P,A
+ POPJ P,
+
+ATOSQ1: MOVE E,(A)
+ AOS -2(P)
+ JRST POPABJ
+
+; BINARY SEARCH FOR SQUOZE SYMBOL ARG IN E
+
+SQUTOA: PUSH P,A
+ PUSH P,B
+ PUSH P,C
+ PUSH P,E
+ PUSHJ P,GETSQU
+ POP P,E
+
+ MOVE A,SQUPNT ; POINTER TO TABLE
+ HLRE B,SQUPNT
+ MOVNS B
+ HRLI B,(B) ; B IS CURRENT OFFSET
+
+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
+ CAMLE E,(C) ; SKIP IF EITHER FOUND OR IN TOP
+ MOVE A,C ; POINT TO SECOND HALF
+ CAMN E,(C) ; SKIP IF NOT FOUND
+ JRST WON
+ CAML E,(C) ; SKIP IF IN TOP HALF
+ JRST UP
+ HLLZS C ; FIX UP OINTER
+ SUB A,C
+ JRST UP
+
+WON: MOVE E,1(C) ; RET VAL IN E
+ AOS -3(P) ; SKIP RET
+WON1: POP P,C
+ POP P,B
+ POP P,A
+ POPJ P,
+
+LSTHLV: CAMN E,(C) ; LINEAR SERCH REST
+ JRST WON
+ ADD C,[2,,2]
+ JUMPL C,.-3
+ JRST WON1 ; ALL GONE, LOSE
+
+
+IMPURE
+SQUPNT: 0
+
+PURE
+END
+\f
\ No newline at end of file
--- /dev/null
+
+TITLE SQUOZE TABLE HANDLER FOR MUDDLE
+
+RELOCATABLE
+
+XJRST==JRST 5,
+
+.INSRT MUDDLE >
+
+SYSQ
+
+.GLOBAL SQUPNT,ATOSQ,SQUTOA,GETSQU,CSQUTA,MPOPJ,SAT,SQUKIL,SQKIL
+.GLOBAL MULTSG
+
+; ROUTINE TO KILL FIXUP TABLE SOMETIMES
+
+SQUKIL: PUSH P,0 ; SAVE ACS
+ HRRZ 0,SQUPNT ; SEE IF IN INTERPRETER
+ CAIG 0,HIBOT
+ JRST POPJ0
+ PUSH P,A
+ PUSH P,B
+ PUSH P,C
+ PUSH P,D
+ PUSH P,E
+ PUSHJ P,SQKIL ; KILL THE BUFFER AND RESTORE INTERPRETER
+ POP P,E
+ POP P,D
+ POP P,C ; RESTORE AC'S
+ POP P,B
+ POP P,A
+POPJ0: POP P,0
+ POPJ P,
+
+
+; POINTER TO TABLE FILLED IN BY INITM
+
+; SUBR TO INTERFACE TO MUDDLE SQUOZE TABLE.
+; IT TAKES AN ARGUMENT OF PRIMTYPE WORD AND RETURNS A FIX GIVING THE
+; LOCATION IF IT IS IN THE SQUOZE TABLE AND OTHERWISE RETURNS FALSE
+
+ MFUNCTION SQUOTA,SUBR
+ ENTRY 1
+
+ GETYP A,(AB)
+ PUSHJ P,SAT ; GET SAT OF ARGUMENT
+ CAIE A,S1WORD ; BETTER BE OF PRIMTYPE WORD
+ JRST WTYP1
+ MOVE A,1(AB) ; GET ARGUMENT INTO A
+ PUSHJ P,CSQUTA
+ JFCL
+ JRST FINIS
+
+
+; COMPILER ENTRY TAKES ARGUMENT IN A
+
+CSQUTA: SUBM M,(P) ; RELATAVIZE P
+ MOVE E,A ; ARG TO SQUOTA
+ TLZ E,740000 ; FLUSH EXTRA BITS FOR LOOKUP
+ PUSHJ P,SQUTOA
+ JRST GTFALS
+ SOS (P) ; AND SKIP RETURN
+ PUSHJ P,SQUKIL
+ MOVSI A,TFIX ; RETURN FIX
+ MOVE B,E
+ JRST MPOPJ
+GTFALS: PUSHJ P,SQUKIL
+ MOVE A,$TFALSE
+ MOVEI B,0
+ JRST MPOPJ ; RETURN A FALSE
+
+
+; GIVEN LOCN OF SUBR RET SQUO NAME ARG AND VAL IN E
+
+ATOSQ: PUSH P,B
+ PUSH P,A
+ PUSHJ P,GETSQU
+IFE ITS,[
+ SKIPE MULTSG
+ PUSHJ P,@[.+1] ; RUN IN 0
+ MOVE A,SQUPNT ; GET TABLE POINTER
+ MOVE B,[2,,2]
+ CAMN E,1(A)
+ JRST ATOSQ1
+ ADD A,B
+ JUMPL A,.-3
+POPABJ: PUSH P,E ; SAVE RESULT
+ PUSHJ P,SQUKIL
+ POP P,E
+IFE ITS,[
+ SKIPN MULTSG
+ JRST GOON
+ POP P,B ; GET PC
+ MOVEI A,0
+ HRRI B,GOON ; RUN IN CALLERS SECTIO
+ XJRST A
+]
+GOON: POP P,B
+ POP P,A
+ POPJ P,
+
+ATOSQ1: MOVE E,(A)
+IFE ITS,[
+ SKIPN MULTSG
+ AOS -2(P)
+ SKIPE MULTSG
+ AOS -3(P)
+]
+IFN ITS,[
+ AOS -2(P)
+]
+ JRST POPABJ
+
+; BINARY SEARCH FOR SQUOZE SYMBOL ARG IN E
+
+SQUTOA: PUSH P,A
+ PUSH P,B
+ PUSH P,C
+ PUSH P,E
+ PUSHJ P,GETSQU
+ POP P,E
+
+IFE ITS,[
+ SKIPE MULTSG
+ PUSHJ P,@[.+1] ; RUN IN SEC 0
+]
+ MOVE A,SQUPNT ; POINTER TO TABLE
+ HLRE B,SQUPNT
+ MOVNS B
+ HRLI B,(B) ; B IS CURRENT OFFSET
+
+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
+ CAMLE E,(C) ; SKIP IF EITHER FOUND OR IN TOP
+ MOVE A,C ; POINT TO SECOND HALF
+ CAMN E,(C) ; SKIP IF NOT FOUND
+ JRST WON
+ CAML E,(C) ; SKIP IF IN TOP HALF
+ JRST UP
+ HLLZS C ; FIX UP OINTER
+ SUB A,C
+ JRST UP
+
+WON: MOVE E,1(C) ; RET VAL IN E
+IFE ITS,[
+ SKIPN MULTSG
+ AOS -3(P)
+ SKIPE MULTSG
+ AOS -4(P)
+]
+IFN ITS, AOS -3(P) ; SKIP RET
+WON1:
+IFE ITS,[
+ SKIPN MULTSG
+ JRST GOON1
+ POP P,B ; GET PC
+ MOVEI A,0
+ HRRI B,GOON1 ; RUN IN CALLERS SECTIO
+ XJRST A
+]
+GOON1: POP P,C
+ POP P,B
+ POP P,A
+ POPJ P,
+
+LSTHLV: CAMN E,(C) ; LINEAR SERCH REST
+ JRST WON
+ ADD C,[2,,2]
+ JUMPL C,.-3
+ JRST WON1 ; ALL GONE, LOSE
+
+
+IMPURE
+SQUPNT: 0
+
+PURE
+END
+\f
\ No newline at end of file
--- /dev/null
+MPURE.BIN\eL
+MSPECS.BIN\eL
+MLDGC.BIN\eL
+MUTILIT.BIN\eL
+MUUOH.BIN\eL
+MMUDEX.BIN\eL
+MMAPPUR.BIN\eL
+MCORE.BIN\eL
+MATOMHK.BIN\eL
+MINTERR.BIN\eL
+MNFREE.BIN\eL
+MGCHACK.BIN\eL
+MREADCH.BIN\eL
+MAGCMRK.BIN\eL
+MREADER.BIN\eN
+MPRINT.BIN\eN
+MBUFMOD.BIN\eN
+MARITH.BIN\eN
+MMAPS.BIN\eN
+MPRIMIT.BIN\eN
+MSTBUIL.BIN\eL
+MEVAL.BIN\eL
+MDECL.BIN\eL
+MMAIN.BIN\eL
+MMUDSQU.BIN\eL
+MFOPEN.BIN\eL
+MPUTGET.BIN\eL
+MCREATE.BIN\eL
+MSAVE.BIN\eL
+MAGC.BIN\eN
+MAMSGC.BIN\eN
+MSECAGC.BIN\eL
+MINITM.BIN\eL?\e\e
+\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
+
+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
+ 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
+ MOVEM 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)
+ 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
+ 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
+ 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: S.NM1(D)
+ S.NM2(D)
+ S.DEV(D)
+ S.SNM(D)
+ S.X1(D)
+]
+
+RDTBL: RDEVIC(B)
+ RNAME1(B)
+ RNAME2(B)
+ RSNAME(B)
+
+
+\f
+IFE ITS,[
+
+; TENEX VERSION OF FILE NAME PARSER (ONLY ACCEPT ARGS IN SINGLE STRING)
+
+RGPRS: MOVSI 0,NOSTOR
+
+RGPARS: IORM 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]
+CHKLST: JUMPGE AB,CPOPJ1
+ SKIPGE (P) ; IF FROM OPEN, ALLOW ONE MORE
+ POPJ P,
+ PMOVEM (AB),T.XT(TB)
+ ADD AB,[2,,2]
+ 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
+ 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
+ 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 NEW VERSION
+ TLO A,400000 ; FORCE OLD
+ 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
+ HRRZM A,CHANNO(B) ; SAVE IT
+ ANDI A,-1 ; READ Y TO DO OPEN
+ MOVSI B,440000 ; USE 36. BIT BYES
+ TRNE D,2
+ MOVSI B,070000
+ HRRI B,200000 ; ASSUME READ
+ CAMN C,[SIXBIT /READB/]
+ TRO B,2000 ; TURN ON THAWED IF READB
+ 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
+ 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
+ CAME C,[SIXBIT /PRINAO/]
+ CAMN C,[SIXBIT /PRINTO/]
+ TRO 0,C.RAND ; INDICATE RANDOM ACCESSING
+ MOVE B,T.CHAN+1(TB)
+ 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
+ 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
+ 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)
+ 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 A,CHANNO(B) ; GET JFN
+ GDSTS ; GET STATE
+ 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 A,CHANNO(E)
+ GDSTS
+ LSH B,-32.
+ 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
+ JRST NLOSS
+ JRST NLOSS
+ MOVEI B,1
+ MOVEI B,2
+ JRST NLOSS
+ MOVEI B,4
+ PUSHJ P,NOPND
+ MOVEI B,0
+ JRST NLOSS
+ JRST NLOSS
+ PUSHJ P,NCLSD
+ MOVEI B,0
+ JRST NLOSS
+ 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
+ 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
+ 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)
+ 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
+ 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: IMQUOTE NM1
+ IMQUOTE NM2
+ IMQUOTE DEV
+ 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
+ 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: IMQUOTE DEV
+ IMQUOTE SNM
+ IMQUOTE NM1
+ 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"
+ 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
+ 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 CHNRM1
+ 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
+ IORI A,6 ; BLOCK IMAGE
+IFN ITS,[
+ 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(D)
+ ADD A,CHANNO(D)
+ 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
+ HRRZM B,CHANNO(D) ; COULD HAVE CHANGED
+ MOVE P,(TP) ; RESTORE P
+ MOVEI A,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,-2(TP) ; CHANNEL
+ MOVE A,CHANNO(A) ; 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
+IFE ITS, PUSH P,ACCESS-1(B) ; SAVE MODE
+ PUSHJ P,BFCLOS
+IFE ITS,[
+ HRRZS A,(P) ; RESTORE MODE
+ HRRZ 0,-2(B) ; GET BITS
+ TRNE 0,C.DISK
+ TRNE 0,C.BIN
+ JUMPE A,CFINX1
+ MOVE A,CHANNO(B) ; GET JFN
+ TLO A,400000 ; BIT MEANS DONT RELEASE JFN
+ CLOSF ; CLOSE THE FILE
+ FATAL CLOSF LOST?
+ MOVE E,B ; SAVE CHANNEL
+ MOVE A,CHANNO(B)
+ HRLI A,11
+ MOVSI B,7700 ; MASK
+ MOVSI C,700 ; MAKE NEW SIZE 7
+ CHFDB
+ HRLI A,12
+ POP P,B
+ MOVE C,ACCESS(E) ; LENGTH IN CHARS
+ TRNN 0,C.BIN
+ JRST .+4
+ SUBI C,1
+ IMULI C,5
+ ADD C,B
+ SETOM B
+ CHFDB
+ MOVE A,CHANNO(E)
+ RLJFN ; FLUSH THE GD JFN
+ 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
+ TRO E,C.RAND
+ HRRM E,-2(B)
+
+;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:
+IFN ITS,[
+ TRNN E,C.BIN
+ IDIVI C,5
+]
+;SETUP THE .ACCESS
+ 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
+IFN ITS,[
+ 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:
+IFE ITS, JRST DONADV
+ TRNE E,C.BIN ; FINISHED FOR BINARY CHANNELS
+ JRST DONADV
+
+ JUMPE D,DONADV ; THIS CASE OK
+
+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 2
+
+PBFL: PUSH P,. ; PUSH NON-ZERONESS
+ JRST BINI1
+
+MFUNCTION READB,SUBR
+
+ ENTRY
+
+ PUSH P,[0]
+ HLRZ 0,AB
+ CAIG 0,-3
+ CAIG 0,-7
+ JRST WNA
+
+BINI1: GETYP 0,(AB) ; SHOULD BE UVEC OR STORE
+ CAIN 0,TUVEC
+ JRST BINI2
+ CAIE 0,TSTORAGE
+ 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
+ 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
+ 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)
+BINI5: SKIPE LSTCH(B) ; INDICATES IF EOF HIT
+ JRST BINEOF
+ 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
+
+BUFOU1: SKIPE BUFSTR(B) ; ANY BUFFERS AROUND?
+ PUSHJ P,BFCLS1 ; GET RID OF SAME
+ MOVE A,1(AB)
+ PUSHJ P,PGBIOO
+ HLRE C,1(AB)
+ MOVNS C
+ addm c,ACCESS(B)
+ MOVE A,(AB) ; RET VECTOR ETC.
+ MOVE B,1(AB)
+ JRST FINIS
+
+
+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
+
+ JUMPGE A,BUFGOO ;SKIPS IF IOT COMPLETED...FIX UP CHANNEL
+ 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
+
+; 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
+ 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
+ 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
+
+ HRRZ C,-2(B) ; GET BITS
+ TRNN C,C.BIN
+ JRST ASCBUF
+
+ SUBI A,BUFLNT-1 ; CALCULATE PNTR TO BEG OF BUFFER
+ HRLI A,-BUFLNT ; IOT (AOBJN) PNTR IN A
+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
+ MOVEI C,-1(A) ; POINT TO BUFFER
+ HRLI C,004400
+ PUSH P,CHANNO(B)
+ MOVE B,C
+ HLRE C,A ; - COUNT TO C
+ MOVN D,C
+ HRLI D,TCHSTR
+ MOVE PVP,PVSTOR+1
+ MOVEM D,BSTO(PVP)
+ MOVE D,[PUSHJ P,FIXCNT]
+ MOVEM D,ONINT
+ MOVE D,A ; XTRA POINTER
+ POP P,A ; FILE JFN
+ ENABLE
+ XCT (P) ; DO IT TO IT
+ DISABLE
+ MOVE PVP,PVSTOR+1
+ 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,
+
+ASCBUF:
+IFE ITS, PUSH P,D
+ PUSH TP,$TCHAN
+ PUSH TP,B
+IFE ITS, MOVNI C,BUFLNT*5
+IFN ITS, MOVEI C,BUFLNT*5
+ EXCH B,A
+ MOVE A,CHANNO(A)
+ MOVEI D,BUFLNT*5
+ HRLI D,TCHSTR
+ MOVE PVP,PVSTOR+1
+ MOVEM D,BSTO(PVP)
+ MOVE D,[PUSHJ P,FIXCNT]
+ MOVEM D,ONINT
+ ENABLE
+IFE ITS,[
+ XCT (P)
+]
+IFN ITS,[
+ DOTCAL SIOT,[A,B,C]
+ JFCL
+]
+ DISABLE
+
+ MOVE PVP,PVSTOR+1
+ SETZM DSTO(PVP)
+ SETZM ONINT
+ MOVE B,(TP)
+ SUB P,[1,,1]
+ JUMPE C,CPOPTP
+
+ ADDI C,BUFLNT*5
+ HRRM C,LSTCH-1(B)
+CPOPTP: SUB TP,[2,,2]
+ POPJ P,
+
+FIXCNT: PUSH P,PVP
+ MOVE PVP,PVSTOR+1
+IFE ITS, MOVNS C
+ HRRM C,BSTO(PVP)
+ MOVNS C
+ POP P,PVP
+ POPJ P,
+
+
+PGBIOO: SKIPA D,[SOUT]
+PGBIOI: MOVE D,[SIN]
+ JRST PGBIOT
+DOIOTO: PUSH P,D
+ PUSH P,C
+ PUSHJ P,PGBIOO
+DOIOTE: POP P,C
+ POP P,D
+ POPJ P,
+DOIOTI: PUSH P,D
+ PUSH P,C
+ PUSHJ P,PGBIOI
+ JRST DOIOTE
+]
+\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
+ 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: PUSH TP,$TCHAN
+ PUSH TP,B ; SAVE CHANNEL
+ HRRZ A,-2(B) ; GET BITS
+ TRNE A,C.DISK
+ JRST BFCDSK
+ 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
+ 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
+ MOVEI E,BUFLNT(A)
+ SUBI E,(C) ; FIX UP FOR BACKWARDS BLT
+ POP A,@E ; AMAZING GRACE
+ TLNE A,777777
+ 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
+ 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
+BFCLSD: HRRZ A,(TP) ; GET PTR TO DOPE WORD
+ SUBI A,BUFLNT+1
+ HRLI A,010700 ; AOBJN POINTER TO FIRST OF BUFFER
+ MOVEM A,BUFSTR(B)
+ MOVEI A,BUFLNT*5
+ HRRM A,BUFSTR-1(B)
+BFCLSY: MOVE A,CHANNO(B)
+ MOVE C,B
+BFCLSZ: SUB TP,[2,,2]
+ POPJ P,
+
+BFCDSK: MOVE A,[PUSHJ P,BFFIX]
+ MOVEM A,ONINT
+ HRRZ C,BUFSTR-1(B)
+ ADD C,[-BUFLNT*5]
+ MOVN A,C
+ MOVE PVP,PVSTOR+1
+ HRLI A,TCHSTR
+ MOVEM A,BSTO(PVP)
+ MOVE A,CHANNO(B)
+ MOVE B,BUFSTR(B)
+IFE ITS,[
+ PUSH P,B
+ RFBSZ
+ PUSH P,B
+ MOVEI B,7
+ SFBSZ
+ MOVE B,-1(P)
+]
+ ENABLE
+IFE ITS,[
+ SOUT
+]
+
+IFN ITS,[
+ MOVNS C
+ DOTCAL SIOT,[A,B,C]
+ JFCL
+]
+ SETZM ONINT
+ MOVE PVP,PVSTOR+1
+ SETZM BSTO(PVP)
+IFE ITS,[
+ MOVE B,(P)
+ SFBSZ
+ MOVE B,-1(P)
+ SUB P,[2,,2]
+]
+ HRRZ C,BUFSTR-1(B)
+ ADD C,[-BUFLNT*5]
+ IDIVI C,5
+ ADD C,BUFSTR(B)
+ SUBI C,BUFLNT
+ HRLI C,010700
+ MOVEM C,BUFSTR(B)
+ MOVEI C,BUFLNT*5
+ HRRM C,BUFSTR-1(B)
+ SUB TP,[2,,2]
+ POPJ P,
+
+BFFIX: PUSH P,PVP
+ MOVE PVP,PVSTOR+1
+IFE ITS, MOVNS C
+ HRRM C,BSTO(PVP)
+IFE ITS, MOVNS C
+ POP P,PVP
+ POPJ P,
+
+
+
+
+
+BFCLS1: HRRZ C,-2(B)
+ MOVSI 0,(JFCL)
+ TRNN C,C.BIN
+ 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
+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,INTFCN-1(B)
+ PUSH TP,INTFCN(B)
+ MCALL 1,APPLY
+ 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,INTFCN-1(B) ;PUSH TYPE OF GIVEN OBJ
+ PUSH TP,INTFCN(B) ;PUSH THE SUPPLIED FUNCTION (OR SUBR ETC.)
+ PUSH TP,$TCHRS ;PUSH THE TYPE "CHARACTER"
+ PUSH TP,A ;PUSH THE CHAR
+ MCALL 2,APPLY ;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 MODIFIED AFREE FOR MUDDLE
+
+RELOCATABLE
+
+.INSRT MUDDLE >
+
+.GLOBAL CAFREE,CAFRET,PARNEW,AGC,PARBOT,CODTOP,CAFRE1
+.GLOBAL STOGC,STOSTR,CAFRE,ISTOST,STOLST,SAT,ICONS,BYTDOP
+.GLOBAL FLIST,STORIC,GPURFL,GCDANG,PVSTOR,SPSTOR
+MFUNCTION FREEZE,SUBR
+
+ ENTRY 1
+
+ GETYP A,(AB) ; get type of it
+ PUSH TP,(AB) ; save a copy
+ PUSH TP,1(AB)
+ PUSH P,[0] ; flag for tupel freeze
+ PUSHJ P,SAT ; to SAT
+ MOVEI B,0 ; final type
+ CAIN A,SNWORD ; check valid types
+ MOVSI B,TUVEC ; use UVECTOR
+ CAIN A,S2NWOR
+ MOVSI B,TVEC
+ CAIN A,SARGS
+ MOVSI B,TVEC
+ CAIN A,SCHSTR
+ MOVSI B,TCHSTR
+ CAIN A,SBYTE
+ MOVEI B,TBYTE
+ JUMPE B,WTYP1
+ PUSH P,B ; save final type
+ CAMN B,$TBYTE
+ JRST .+3
+ CAME B,$TCHSTR ; special chars hack
+ JRST OK.FR
+ HRR B,(AB) ; fixup count
+ MOVEM B,(P)
+
+ MOVEI C,(TB) ; point to it
+ PUSHJ P,BYTDOP ; A==> points to dope word
+ HRRO B,1(TB)
+ SUBI A,1(B) ; A==> length of block
+ TLC B,-1(A)
+ MOVEM B,1(TB) ; and save
+ MOVSI 0,TUVEC
+ MOVEM 0,(TB)
+
+OK.FR: HLRE A,1(TB) ; get length
+ MOVNS A
+ PUSH P,A
+ ADDI A,2
+ PUSHJ P,CAFREE ; get storage
+ HRLZ B,1(TB) ; set up to BLT
+ HRRI B,(A)
+ POP P,C
+ ADDI C,(A) ; compute end
+ BLT B,(C)
+ HLLOS 1(C) ; INDICATION IN RELOCATION FIELD THAT ITS NOT GARBAGE
+ MOVEI B,(A)
+ HLL B,1(AB)
+ POP P,A
+ JRST FINIS
+
+
+CAFRE: PUSH P,A
+ HRRZ E,STOLST+1
+ SETZB C,D
+ PUSHJ P,ICONS ; get list element
+ PUSH TP,$TLIST ; and save
+ PUSH TP,B
+ MOVE A,(P) ; restore length
+ ADDI A,2 ; 2 more for dope words
+ PUSHJ P,CAFREE ; get the core and dope words
+ POP P,B ; restore count
+ MOVNS B ; build AOBJN pointer
+ MOVSI B,(B)
+ HRRI B,(A)
+ MOVE C,(TP)
+ MOVEM B,1(C) ; save on list
+ MOVSI 0,TSTORA ; and type
+ HLLM 0,(C)
+ HRRZM C,STOLST+1 ; and save as new list
+ SUB TP,[2,,2]
+ POPJ P,
+
+CAFRE1: PUSH P,A
+ ADDI A,2
+ PUSHJ P,CAFREE
+ HRROI B,(A) ; pointer to B
+ POP P,A ; length back
+ TLC B,-1(A)
+ POPJ P,
+
+CAFREE: IRP AC,,[B,C,D,E]
+ PUSH P,AC
+ TERMIN
+ SKIPG A ; make sure arg is a winner
+ FATAL BAD CALL TO CAFREE
+ MOVSI A,(A) ; count to left half for search
+ MOVEI B,FLIST ; get first pointer
+ HRRZ C,(B) ; c points to next block
+CLOOP: CAMG A,(C) ; skip if not big enough
+ JRST CONLIS ; found one
+ MOVEI D,(B) ; save in case fall out
+ MOVEI B,(C) ; point to new previous
+ HRRZ C,(C) ; next block
+ JUMPN C,CLOOP ; go on through loop
+ HLRZ E,A ; count to E
+ CAMGE E,STORIC ; skip if a area or more
+ MOVE E,STORIC ; else use a whole area
+ MOVE C,PARBOT ; foun out if any funny space
+ SUB C,CODTOP ; amount around to C
+ EXCH B,D
+ CAMLE C,E ; skip if must GC
+ JRST CHAVIT ; already have it
+ SUBI E,-1(C) ; get needed from agc
+ MOVEM E,PARNEW ; funny arg to AGC
+ PUSH P,A
+ MOVE C,[7,,6] ; SET UP AGC INDICATORS
+ SKIPE GPURFL ; DONT GC IF IN DUMPER
+ JRST PURGC
+ PUSHJ P,AGC ; collect that garbage
+ SETZM PARNEW ; dont do it again
+ POP P,A
+
+; Make sure pointers still good after GC
+
+ MOVEI B,FLIST
+ HRRZ D,(B)
+
+ HRRZ E,(D) ; next pointer
+ JUMPE E,.+4 ; end of list ok
+ MOVEI B,(D)
+ MOVEI D,(E)
+ JRST .-4 ; look at next
+
+CHAVIT: MOVE E,PARBOT ; find amount obtained
+ SUBI E,1 ; dont use a real pair
+ MOVEI C,(E) ; for reset of CODTOP
+ SUB E,CODTOP
+ EXCH C,CODTOP ; store it back
+ CAIE B,(C) ; did we simply grow the last block?
+ JRST CSPLIC ; no, splice it in
+ HLRZ C,(B) ; length of old guy
+ ADDI C,(E) ; total length
+ ADDI B,(E) ; point to new last dope word
+ HRLZM C,(B) ; clobber final length in
+ HRRM B,(D) ; and splice into free list
+ MOVEI C,(B) ; reset acs for reentry into loop
+ MOVEI B,(D)
+ JRST CLOOP
+
+; Here to splice new core onto end of list.
+
+CSPLIC: MOVE C,CODTOP ; point to end of new block
+ HRLZM E,(C) ; store length of new block in dope words
+ HRRM C,(D) ; D is old previous, link it up
+ MOVEI B,(D) ; and reset B for reentry into loop
+ JRST CLOOP
+
+; here if an appropriate block is on the list
+
+CONLIS: HLRZS A ; count back to a rh
+ HLRZ D,(C) ; length of proposed block to D
+ CAIN A,(D) ; skip if they are different
+ JRST CEASY ; just splice it out
+ MOVEI B,(C) ; point to block to be chopped up
+ SUBI B,-1(D) ; point to beginning of same
+ SUBI D,(A) ; amount of block to be left to D
+ HRLM D,(C) ; and fix up dope words
+ ADDI B,-1(A) ; point to end of same
+ HRLZM A,(B)
+ HRRM B,(B) ; for GC benefit
+
+CFREET: CAIE A,1 ; if more than 1
+ SETZM -1(B) ; make tasteful dope worda
+ SUBI B,-1(A)
+ MOVEI A,(B)
+ACRST: IRP AC,,[E,D,C,B]
+ POP P,AC
+ TERMIN
+ POPJ P,
+
+PURGC: SUB P,[1,,1] ; CLEAN OFF STACK
+ SETOM GCDANG ; INDICATE GC SHOULD HAVE OCCURED
+ JRST ACRST
+
+CEASY: MOVEI D,(C) ; point to block to return
+ HRRZ C,(C) ; point to next of same
+ HRRM C,(B) ; smash its previous
+ MOVEI B,(D) ; point to block with B
+ HRRM B,(B) ; for GC benefit
+ JRST CFREET
+
+CAFRET: HRROI B,(B) ; prepare to search list
+ TLC B,-1(A) ; by making an AOBJN pointer
+ HRRZ C,STOLST+1 ; start of list
+ MOVEI D,STOLST+1
+
+CAFRTL: JUMPE C,CPOPJ ; not founc
+ CAME B,1(C) ; this it?
+ JRST CAFRT1
+ HRRZ C,(C) ; yes splice it out
+ HRRM C,(D) ; smash it
+CPOPJ: POPJ P, ; dont do anything now
+
+CAFRT1: MOVEI D,(C)
+ HRRZ C,(C)
+ JRST CAFRTL
+
+; Here from GC to collect all unused blocks into free list
+
+STOGC: SETZB C,E ; zero current length and pointer
+ MOVE A,CODTOP ; get high end of free space
+
+STOGCL: CAIG A,STOSTR ; end?
+ JRST STOGCE ; yes, cleanup and leave
+
+ HLRZ 0,(A) ; get length
+ ANDI 0,377777
+ SKIPGE (A) ; skip if a not used block
+ JRST STOGC1 ; jump if marked
+
+; HERE TO SEE WHETHER AN UNMARKED ITEM IS AN ATOM. IF IT IS IT IS NOT GARBAGE
+; AND IT IS PRESERVED WITH ITS VALUE CELLS FLUSHED
+
+ HLRZ 0,-1(A) ; GET TYPE OF FIRST D.W.
+ ANDI 0,TYPMSK ; FLUSH MONITORS
+ CAIE 0,SATOM
+ JRST STOGC5 ; NOT AN ATOM COLLECT THE GARBAGE
+ PUSH P,A ; SAVE PTR TO D.W.
+ HLRZ 0,(A)
+ SUB A,0 ; POINT TO JUST BEFORE ATOM
+ SETZM 1(A) ; ZERO VALUE CELLS
+ SETZM 2(A)
+ POP P,A ; RESTORE A
+ JRST STOGC1
+
+STOGC5: HLRZ 0,(A)
+ JUMPE C,STOGC3 ; jump if no block under construction
+ ADD C,0 ; else add this length to current
+ JRST STOGC4
+
+STOGC3: MOVEI B,(A) ; save pointer
+ MOVE C,0 ; init length
+
+STOGC4: SUB A,0 ; point to next block
+ JRST STOGCL
+
+STOGC1: HLLOS (A) ; -1 IS INDICATOR OF FREE SLOT
+ ANDCAM D,(A) ; kill mark bit
+ JUMPE C,STOGC4 ; if no block under cons, dont fix
+ HRLM C,(B) ; store total block length
+ HRRM E,(B) ; next pointer hooked in
+ MOVEI E,(B) ; new next pointer
+ MOVEI C,0
+ JRST STOGC4
+
+STOGCE: JUMPE C,STGCE1 ; jump if no current block
+ HRLM C,(B) ; smash in count
+ HRRM E,(B) ; smash in next pointer
+ MOVEI E,(B) ; and setup E
+
+STGCE1: HRRZM E,FLIST+1 ; final link up
+ POPJ P,
+
+IMPURE
+
+FLIST: .+1
+ ISTOST
+
+PURE
+
+END
+\f\ 3\ 3\ 3\ 3
\ No newline at end of file
--- /dev/null
+
+TITLE MODIFIED AFREE FOR MUDDLE
+
+RELOCATABLE
+
+.INSRT MUDDLE >
+
+.GLOBAL CAFREE,CAFRET,PARNEW,AGC,PARBOT,CODTOP,CAFRE1
+.GLOBAL STOGC,STOSTR,CAFRE,ISTOST,STOLST,SAT,ICONS,BYTDOP
+.GLOBAL FLIST,STORIC,GPURFL,GCDANG,PVSTOR,SPSTOR
+.GLOBAL %CLNCO
+
+MFUNCTION FREEZE,SUBR
+
+ ENTRY 1
+
+ GETYP A,(AB) ; get type of it
+ PUSH TP,(AB) ; save a copy
+ PUSH TP,1(AB)
+ PUSH P,[0] ; flag for tupel freeze
+ PUSHJ P,SAT ; to SAT
+ MOVEI B,0 ; final type
+ CAIN A,SNWORD ; check valid types
+ MOVSI B,TUVEC ; use UVECTOR
+ CAIN A,S2NWOR
+ MOVSI B,TVEC
+ CAIN A,SARGS
+ MOVSI B,TVEC
+ CAIN A,SCHSTR
+ MOVSI B,TCHSTR
+ CAIN A,SBYTE
+ MOVEI B,TBYTE
+ JUMPE B,WTYP1
+ PUSH P,B ; save final type
+ CAMN B,$TBYTE
+ JRST .+3
+ CAME B,$TCHSTR ; special chars hack
+ JRST OK.FR
+ HRR B,(AB) ; fixup count
+ MOVEM B,(P)
+
+ MOVEI C,(TB) ; point to it
+ PUSHJ P,BYTDOP ; A==> points to dope word
+ HRRO B,1(TB)
+ SUBI A,1(B) ; A==> length of block
+ TLC B,-1(A)
+ MOVEM B,1(TB) ; and save
+ MOVSI 0,TUVEC
+ MOVEM 0,(TB)
+
+OK.FR: HLRE A,1(TB) ; get length
+ MOVNS A
+ PUSH P,A
+ ADDI A,2
+ PUSHJ P,CAFREE ; get storage
+ HRLZ B,1(TB) ; set up to BLT
+ HRRI B,(A)
+ POP P,C
+ ADDI C,(A) ; compute end
+ BLT B,(C)
+ HLLOS 1(C) ; INDICATION IN RELOCATION FIELD THAT ITS NOT GARBAGE
+ MOVEI B,(A)
+ HLL B,1(AB)
+ POP P,A
+ JRST FINIS
+
+
+CAFRE: PUSH P,A
+ HRRZ E,STOLST+1
+ SETZB C,D
+ PUSHJ P,ICONS ; get list element
+ PUSH TP,$TLIST ; and save
+ PUSH TP,B
+ MOVE A,(P) ; restore length
+ ADDI A,2 ; 2 more for dope words
+ PUSHJ P,CAFREE ; get the core and dope words
+ POP P,B ; restore count
+ MOVNS B ; build AOBJN pointer
+ MOVSI B,(B)
+ HRRI B,(A)
+ MOVE C,(TP)
+ MOVEM B,1(C) ; save on list
+ MOVSI 0,TSTORA ; and type
+ HLLM 0,(C)
+ HRRZM C,STOLST+1 ; and save as new list
+ SUB TP,[2,,2]
+ POPJ P,
+
+CAFRE1: PUSH P,A
+ ADDI A,2
+ PUSHJ P,CAFREE
+ HRROI B,(A) ; pointer to B
+ POP P,A ; length back
+ TLC B,-1(A)
+ POPJ P,
+
+CAFREE: IRP AC,,[B,C,D,E]
+ PUSH P,AC
+ TERMIN
+ SKIPG A ; make sure arg is a winner
+ FATAL BAD CALL TO CAFREE
+ MOVSI A,(A) ; count to left half for search
+ MOVEI B,FLIST ; get first pointer
+ HRRZ C,(B) ; c points to next block
+CLOOP: CAMG A,(C) ; skip if not big enough
+ JRST CONLIS ; found one
+ MOVEI D,(B) ; save in case fall out
+ MOVEI B,(C) ; point to new previous
+ HRRZ C,(C) ; next block
+ JUMPN C,CLOOP ; go on through loop
+ HLRZ E,A ; count to E
+ CAMGE E,STORIC ; skip if a area or more
+ MOVE E,STORIC ; else use a whole area
+ MOVE C,PARBOT ; found out if any funny space
+ SUB C,CODTOP ; amount around to C
+ EXCH B,D
+ CAMLE C,E ; skip if must GC
+ JRST CHAVIT ; already have it
+ SUBI E,-1(C) ; get needed from agc
+ MOVEM E,PARNEW ; funny arg to AGC
+ PUSH P,A
+ MOVE C,[7,,6] ; SET UP AGC INDICATORS
+ SKIPE GPURFL ; DONT GC IF IN DUMPER
+ JRST PURGC
+ PUSHJ P,AGC ; collect that garbage
+ SETZM PARNEW ; dont do it again
+ POP P,A
+
+; Make sure pointers still good after GC
+
+ MOVEI B,FLIST
+ HRRZ D,(B)
+
+ HRRZ E,(D) ; next pointer
+ JUMPE E,.+4 ; end of list ok
+ MOVEI B,(D)
+ MOVEI D,(E)
+ JRST .-4 ; look at next
+
+CHAVIT: MOVE C,CODTOP
+ MOVE E,PARBOT
+ PUSHJ P,%CLNCO ; flush extra pages
+ MOVE E,PARBOT ; find amount obtained
+ SUBI E,1 ; dont use a real pair
+ MOVEI C,(E) ; for reset of CODTOP
+ SUB E,CODTOP
+ EXCH C,CODTOP ; store it back
+ CAIE B,(C) ; did we simply grow the last block?
+ JRST CSPLIC ; no, splice it in
+ HLRZ C,(B) ; length of old guy
+ ADDI C,(E) ; total length
+ ADDI B,(E) ; point to new last dope word
+ HRLZM C,(B) ; clobber final length in
+ HRRM B,(D) ; and splice into free list
+ MOVEI C,(B) ; reset acs for reentry into loop
+ MOVEI B,(D)
+ JRST CLOOP
+
+; Here to splice new core onto end of list.
+
+CSPLIC: MOVE C,CODTOP ; point to end of new block
+ HRLZM E,(C) ; store length of new block in dope words
+ HRRM C,(D) ; D is old previous, link it up
+ MOVEI B,(D) ; and reset B for reentry into loop
+ JRST CLOOP
+
+; here if an appropriate block is on the list
+
+CONLIS: HLRZS A ; count back to a rh
+ HLRZ D,(C) ; length of proposed block to D
+ CAIN A,(D) ; skip if they are different
+ JRST CEASY ; just splice it out
+ MOVEI B,(C) ; point to block to be chopped up
+ SUBI B,-1(D) ; point to beginning of same
+ SUBI D,(A) ; amount of block to be left to D
+ HRLM D,(C) ; and fix up dope words
+ ADDI B,-1(A) ; point to end of same
+ HRLZM A,(B)
+ HRRM B,(B) ; for GC benefit
+
+CFREET: CAIE A,1 ; if more than 1
+ SETZM -1(B) ; make tasteful dope worda
+ SUBI B,-1(A)
+ MOVEI A,(B)
+ACRST: IRP AC,,[E,D,C,B]
+ POP P,AC
+ TERMIN
+ POPJ P,
+
+PURGC: SUB P,[1,,1] ; CLEAN OFF STACK
+ SETOM GCDANG ; INDICATE GC SHOULD HAVE OCCURED
+ JRST ACRST
+
+CEASY: MOVEI D,(C) ; point to block to return
+ HRRZ C,(C) ; point to next of same
+ HRRM C,(B) ; smash its previous
+ MOVEI B,(D) ; point to block with B
+ HRRM B,(B) ; for GC benefit
+ JRST CFREET
+
+CAFRET: HRROI B,(B) ; prepare to search list
+ TLC B,-1(A) ; by making an AOBJN pointer
+ HRRZ C,STOLST+1 ; start of list
+ MOVEI D,STOLST+1
+
+CAFRTL: JUMPE C,CPOPJ ; not founc
+ CAME B,1(C) ; this it?
+ JRST CAFRT1
+ HRRZ C,(C) ; yes splice it out
+ HRRM C,(D) ; smash it
+CPOPJ: POPJ P, ; dont do anything now
+
+CAFRT1: MOVEI D,(C)
+ HRRZ C,(C)
+ JRST CAFRTL
+
+; Here from GC to collect all unused blocks into free list
+
+STOGC: SETZB C,E ; zero current length and pointer
+ MOVE A,CODTOP ; get high end of free space
+
+STOGCL: CAIG A,STOSTR ; end?
+ JRST STOGCE ; yes, cleanup and leave
+
+ HLRZ 0,(A) ; get length
+ ANDI 0,377777
+ SKIPGE (A) ; skip if a not used block
+ JRST STOGC1 ; jump if marked
+
+; HERE TO SEE WHETHER AN UNMARKED ITEM IS AN ATOM. IF IT IS IT IS NOT GARBAGE
+; AND IT IS PRESERVED WITH ITS VALUE CELLS FLUSHED
+
+ HLRZ 0,-1(A) ; GET TYPE OF FIRST D.W.
+ ANDI 0,TYPMSK ; FLUSH MONITORS
+ CAIE 0,SATOM
+ JRST STOGC5 ; NOT AN ATOM COLLECT THE GARBAGE
+ PUSH P,A ; SAVE PTR TO D.W.
+ HLRZ 0,(A)
+ SUB A,0 ; POINT TO JUST BEFORE ATOM
+ SETZM 1(A) ; ZERO VALUE CELLS
+ SETZM 2(A)
+ POP P,A ; RESTORE A
+ JRST STOGC1
+
+STOGC5: HLRZ 0,(A)
+ JUMPE C,STOGC3 ; jump if no block under construction
+ ADD C,0 ; else add this length to current
+ JRST STOGC4
+
+STOGC3: MOVEI B,(A) ; save pointer
+ MOVE C,0 ; init length
+
+STOGC4: SUB A,0 ; point to next block
+ JRST STOGCL
+
+STOGC1: HLLOS (A) ; -1 IS INDICATOR OF FREE SLOT
+ ANDCAM D,(A) ; kill mark bit
+ JUMPE C,STOGC4 ; if no block under cons, dont fix
+ HRLM C,(B) ; store total block length
+ HRRM E,(B) ; next pointer hooked in
+ MOVEI E,(B) ; new next pointer
+ MOVEI C,0
+ JRST STOGC4
+
+STOGCE: JUMPE C,STGCE1 ; jump if no current block
+ HRLM C,(B) ; smash in count
+ HRRM E,(B) ; smash in next pointer
+ MOVEI E,(B) ; and setup E
+
+STGCE1: HRRZM E,FLIST+1 ; final link up
+ POPJ P,
+
+IMPURE
+
+FLIST: .+1
+ ISTOST
+
+PURE
+
+END
+\f
\ No newline at end of file
--- /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
+
+; 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
+ TLZE D,40 ; SKIP IF NOT ESCAPED
+ JRST INCHR2 ; ESCAPED
+ CAMN A,ESCAP(E) ; IF ESCAPE
+ TLO D,40 ; REMEMBER
+ 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
+ MOVEI B,DIRECT-1(D) ;AND ITS DIRECTION
+ PUSHJ P,CHRWRD
+ JFCL
+ CAME B,[ASCII /PRINT/]
+ JRST WRONGD
+
+ MOVE B,BUFRIN(A) ;GET A'S AUX BUFFER
+ 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: MOVEI B,DIRECT-1(A) ;GET DIRECTION
+ PUSHJ P,CHRWRD ; CONVERT
+ JFCL
+ CAME B,[ASCII /READ/]
+ JRST WRONGD
+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,
+ DOTCAL OPEN,[[1000,,TTYIN],[[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,[
+ SKIPN IMAGFL
+ JRST MTYI1
+ PUSH P,B
+ PUSHJ P,MTYO1
+ POP P,B
+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,
+
+MTYO1: MOVE B,TTOCHN+1
+ PUSH P,0
+ PUSHJ P,REASCI
+ POP P,0
+ POPJ P,
+
+; HERE FOR TYO TO ANY TTY FLAVOR DEVICE
+
+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: ERRUUO EQUOTE NOT-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,
+
+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
+ PUSHJ P,INCHAR
+ 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
+
+
+DEVTOC: PUSH P,D
+ PUSH P,E
+ PUSH P,0
+ PUSH P,A
+ MOVE D,RDEVIC(B)
+ MOVE E,[220600,,C]
+ MOVEI A,3
+ MOVEI C,0
+ ILDB 0,D
+ SUBI 0,40
+ IDPB 0,E
+ SOJG A,.-3
+ POP P,A
+ POP P,0
+ POP P,E
+ POP P,D
+ POPJ P,
+
+IMGBLK: OUT+IMAGEM+UNIT,,(SIXBIT /TTY/)
+ 0
+ 0
+
+
+
+IMPURE
+IMAGFL: 0
+PURE
+
+
+END
+\f
\ No newline at end of file
--- /dev/null
+TITLE PRIMITIVE FUNCTIONS FOR THE MUDDLE SYSTEM
+
+RELOCATABLE
+
+.INSRT MUDDLE >
+
+.GLOBAL TMA,TFA,CELL,IBLOCK,IBLOK1,ICELL2,VECTOP,LSTUF,PVSTOR,SPSTOR
+.GLOBAL NWORDT,CHARGS,CHFRM,CHLOCI,IFALSE,IPUTP,IGETP,BYTDOP
+.GLOBAL OUTRNG,IGETLO,CHFRAM,ISTRUC,TYPVEC,SAT,CHKAB,VAL,CELL2,MONCH,MONCH0
+.GLOBAL RMONCH,RMONC0,LOCQ,LOCQQ,SMON,PURERR,APLQ,NAPT,TYPSEG,NXTLM
+.GLOBAL MAKACT,ILLCHO,COMPER,CEMPTY,CIAT,CIEQUA,CILEGQ,CILNQ,CILNT,CIN,CINTH,CIREST
+.GLOBAL CISTRU,CSETLO,CIPUT,CIGET,CIGETL,CIMEMQ,CIMEMB,CIMON,CITOP,CIBACK
+.GLOBAL IGET,IGETL,IPUT,CIGETP,CIGTPR,CINEQU,IEQUAL,TD.LNT,TD.GET,TD.PUT,TD.PTY
+.GLOBAL TMPLNT,BADTPL,ISTRCM,PTYPE,CIGVAL,MAKTUP,CSBSTR,TMATCH
+
+; BUILD DISPATCH TABLE FOR PRIMITIVE FUNCTIONS USAGE
+F==PVP
+
+PRMTYP:
+
+REPEAT NUMSAT+1,[0] ;INITIALIZE TABLE TO ZEROES
+
+IRP A,,[2WORD,2NWORD,NWORD,ARGS,CHSTR,BYTE]
+
+LOC PRMTYP+S!A
+P!A==.IRPCN+1
+P!A
+
+TERMIN
+
+PTMPLT==PBYTE+1
+
+; FUDGE FOR STRUCTURE LOCATIVES
+
+IRP A,,[[LOCL,2WORD],[LOCV,2NWORD],[LOCU,NWORD],[LOCS,CHSTR],[LOCA,ARGS]
+[LOCT,TMPLT],[LOCB,BYTE]]
+ IRP B,C,[A]
+ LOC PRMTYP+S!B
+ P!B==P!C,,0
+ P!B
+ .ISTOP
+ TERMIN
+TERMIN
+
+LOC PRMTYP+SSTORE ;SPECIAL HACK FOR AFREE STORAGE
+PNWORD
+
+LOC PRMTYP+NUMSAT+1
+
+PNUM==PTMPLT+1
+
+; MACRO TO BUILD PRIMITIVE DISPATCH TABLES
+
+DEFINE PRDISP NAME,DEFAULT,LIST
+ TBLDIS NAME,DEFAULT,[LIST]PNUM,400000
+ TERMIN
+
+
+; SUBROUTINE TO RETURN PRIMITIVE TYPE AND PRINT ERROR IF ILLEGAL
+
+PTYPE: GETYP A,(B) ;CALLE D WITH B POINTING TO PAIR
+ CAIN A,TILLEG ;LOSE IF ILLEGAL
+ JRST ILLCHOS
+
+ PUSHJ P,SAT ;GET STORAGE ALLOC TYPE
+ CAIE A,SLOCA
+ CAIN A,SARGS ;SPECIAL HAIR FOR ARGS
+ PUSHJ P,CHARGS
+ CAIN A,SFRAME
+ PUSHJ P,CHFRM
+ CAIN A,SLOCID
+ PUSHJ P,CHLOCI
+PTYP1: MOVEI 0,(A) ; ALSO RETURN PRIMTYPE
+ CAILE A,NUMSAT ; SKIP IF NOT TEMPLATE
+ SKIPA A,[PTMPLT]
+ MOVE A,PRMTYP(A) ;GET PRIM TYPE,
+ POPJ P,
+
+; COMPILERS CALL TO ABOVE (LESS CHECKING)
+
+CPTYPE: PUSHJ P,SAT
+ MOVEI 0,(A)
+ CAILE A,NUMSAT
+ SKIPA A,[PTMPLT]
+ MOVE A,PRMTYP(A)
+ POPJ P,
+
+
+MFUNCTION SORT,SUBR
+
+ ENTRY
+
+; HACK TO DYNAMICALLY LOAD SORT
+ MOVE B,MQUOTE SORTX
+ PUSHJ P,CIGVAL
+ PUSH TP,A
+ PUSH TP,B ; PUSH ON FUNCTION FOR APPLY
+ MOVE A,AB ; PUSH ARGS TO SORT ONTO STACK
+ JUMPE A,DONPSH
+ PUSH TP,(A)
+ AOBJN A,.-1
+DONPSH: HLRE A,AB ; GET COUNT
+ MOVNS A
+ ADDI A,2
+ ASH A,-1 ; # OF ARGS
+ ACALL A,APPLY
+ JRST FINIS
+
+\f
+MFUNCTION SUBSTRUC,SUBR
+
+ ENTRY
+ JUMPGE AB,TFA ;need at least one arg
+ CAMGE AB,[-10,,0] ;NO MORE THEN 4
+ JRST TMA
+ HLRE A,AB ; GET NEGATIVE LENGTH IN A
+ MOVNS A ; SET UP LENGTH ARG TO SUBSTRUC
+ ASH A,-1
+ MOVE B,AB ; AOBJN POINTER FOR LOOP
+ PUSH TP,(B) ; PUSH ON ARGS
+ AOBJN B,.-1
+ PUSHJ P,CSBSTR ; GO TO INTERNAL ROUTINE
+ JRST FINIS
+
+; VARIOUS OFFSETS INTO PSTACK
+
+PRTYP==0
+LNT==0
+NOARGS==-1
+
+; VARIOUS OFFSETS INTO TP STACK
+
+OBJ==-7
+RSTR==-5
+LNT==-3
+NOBJ==-1
+
+; THIS STARTS THE MAIN ROUTINE
+
+CSBSTR: SUBM M,(P) ; FOR RSUBRS
+ JSP E,@PTBL(A)
+ MOVEI B,OBJ(TP)
+ PUSH P,A
+ PUSHJ P,PTYPE ; get primtype in A
+ PUSH P,A
+ JRST @TYTBL(A)
+
+PTBL: SETZ WNA
+ SETZ PUSH6
+ SETZ PUSH4
+ SETZ PUSH2
+ SETZ PUSH0
+
+PUSH6: PUSH TP,[0]
+ PUSH TP,[0]
+PUSH4: PUSH TP,[0]
+ PUSH TP,[0]
+PUSH2: PUSH TP,[0]
+ PUSH TP,[0]
+PUSH0: JRST (E)
+
+
+RESSUB: MOVE D,NOARGS(P) ; GET NUMBER OF ARGS
+ CAIN D,1 ; IF 1 THEN JUST COPY
+ JRST @COPYTB(A)
+ GETYP B,RSTR(TP) ; GET TYPE OF REST ARGUMENT
+ CAIE B,TFIX ;IF FIX OK
+ JRST WRONGT
+ MOVEI E,(A)
+ MOVE A,OBJ(TP)
+ MOVE B,OBJ+1(TP) ; GET OBJECT
+ SKIPGE C,RSTR+1(TP) ; GET REST ARGUMENT
+ JRST OUTRNG
+ PUSHJ P,@MRSTBL(E)
+ PUSH TP,A ; type
+ PUSH TP,B ; put rested sturc on stack
+ JRST ALOCOK
+
+PRDISP TYTBL,IWTYP1,[[PARGS,RESSUB],[P2WORD,RESSUB],[P2NWORD,RESSUB]
+[PNWORD,RESSUB],[PCHSTR,RESSUB],[PBYTE,RESSUB]]
+
+PRDISP MRSTBL,IWTYP1,[[PARGS,AREST],[P2WORD,LREST],[P2NWORD,VREST]
+[PNWORD,UREST],[PCHSTR,SREST],[PBYTE,BREST]]
+
+PRDISP COPYTB,IWTYP1,[[PARGS,CPYVEC],[P2WORD,CPYLST],[P2NWORD,CPYVEC]
+[PNWORD,CPYUVC],[PCHSTR,CPYSTR],[PBYTE,CPYBYT]]
+
+PRDISP ALOCTB,IWTYP1,[[PARGS,ALVEC],[P2WORD,ALLIST],[P2NWORD,ALVEC]
+[PNWORD,ALUVEC],[PCHSTR,ALSTR],[PBYTE,ALBYT]]
+
+; HERE WE HAVE RESTED STRUCTURE ON TOP OF STACK
+
+ALOCFX: MOVE B,(TP) ; missing 3rd arg aloc for "rest" of struc
+ MOVE C,-1(TP)
+ MOVE A,(P)
+ PUSH P,[377777,,-1]
+ PUSHJ P,@LENTBL(A) ; get length of rested struc
+ SUB P,[1,,1]
+ POP P,C
+ MOVE A,B ; # of elements needed
+ JRST @ALOCTB(C)
+
+
+; HERE WE HAVE RESTED STRUCTURE ON THE TOP OF THE STACK
+
+ALOCOK: MOVE D,NOARGS(P) ; GET NUMBER OF ARGS
+ CAIG D,2 ; SKIP IF NOT EXACTLY 3 ARGS
+ JRST ALOCFX
+ GETYP C,LNT-2(TP) ; GET THE LENGTH ARGUMENT
+ CAIE C,TFIX ; OK IF TYPE FIX
+ JRST WRONGT
+ POP P,C
+ SKIPL A,LNT-1(TP) ; GET LENGTH
+ JRST @ALOCTB(C) ; DO ALLOCATION
+ JRST OUTRNG
+
+
+CPYVEC: HLRE A,OBJ+1(TP) ; USE WHEN ONLY ONE ARG
+ MOVNS A ; LENGTH ARG IS LENGTH OF STRUCTURE
+ ASH A,-1 ; # OF ELEMENTS FOR ALLOCATION
+ PUSH TP,OBJ(TP)
+ SUB P,[1,,1]
+ PUSH TP,OBJ(TP) ; REPUSH ARGS
+
+ALVEC: PUSH P,A ; SAVE LENGTH
+ ASH A,1
+ HRLI A,(A)
+ ADD A,(TP)
+ CAIL A,-1 ; CHK FOR OUT OF RANGE
+ JRST OUTRNG
+ MOVE D,NOARGS(P)
+ CAILE D,3 ; SKIP IF WE GET VECTOR
+ JRST ALVEC2 ; USER SUPPLIED VECTOR
+ MOVE A,(P)
+ PUSHJ P,IBLOK1
+ALVEC1: MOVE A,(P) ; # OF WORDS TO ALLOCATE
+ MOVE C,B ; SAVE VECTOR POINTER
+ JUMPE A,ALEVC4
+ ASH A,1 ; TIMES 2
+ HRLI A,(A)
+ ADD A,B ; PTING TO FIRST DOPE WORD -ALLOCATED
+ CAIL A,-1
+ JRST OUTRNG
+ SUBI A,1 ; ptr to last element of the block
+ MOVE D,NOARGS(P)
+ CAILE D,3
+ CAMGE B,(TP) ; SKIP IF BACKWARDS BLT IS NEEDED
+ JRST ALEVC3
+ HRRZ 0,(TP)
+ ADD 0,-4(TP)
+ ADD 0,-4(TP) ; FIND END OF DEST
+ CAIGE 0,(B) ; SEE IF BBLT IS NEEDED
+ JRST ALEVC3
+ PUSHJ P,BBLT ; BLT IT
+ JRST ALEVC4
+ALEVC3: HRL B,(TP) ;bleft-ptr to source , b right -ptr to allocated space
+ BLT B,(A)
+ MOVE B,C
+ALEVC4: MOVE D,NOARGS(P)
+ CAIE D,4
+ JRST ALEVC5
+ MOVE A,NOBJ-2(TP)
+ JRST EXSUB
+ALEVC5: MOVSI A,TVEC
+ JRST EXSUB
+
+; RESTED OBJECT ON TOP OF STACK
+
+ALVEC2: GETYP 0,NOBJ-2(TP) ; CHECK IT IS A VECTOR
+ CAIE 0,TARGS
+ CAIN 0,TVEC
+ SKIPA
+ JRST WTYP
+ HLRE A,NOBJ-1(TP) ; CHECK SIZE
+ MOVNS A
+ ASH A,-1 ; # OF ELEMENTS
+ CAMGE A,(P) ; SKIP IF BIG ENOUGH
+ JRST OUTRNG
+ MOVE B,NOBJ-1(TP) ; WINNER, JOIN COMMON CODE
+ JRST ALVEC1
+
+CPYUVC: HLRE A,OBJ+1(TP) ;# OF ELEMENTS FOR ALLOCATION
+ MOVNS A
+ PUSH TP,(B)
+ PUSH TP,1(B)
+ SUB P,[1,,1]
+
+
+ALUVEC: PUSH P,A
+ HRLI A,(A)
+ ADD A,(TP) ; PTING TO DOPE WORD OF ORIG VEC
+ CAIL A,-1
+ JRST OUTRNG
+ MOVE D,NOARGS(P)
+ CAILE D,3
+ JRST ALUVE2
+ MOVE A,(P)
+ PUSHJ P,IBLOCK
+ALUVE1: MOVE A,(P) ; # of owrds to allocate
+ JUMPE A,ALUEV4
+ HRLI A,(A)
+ ADD A,B ; LOCATION O FIRST ALLOCATED DOPE WORD
+ HLR E,OBJ-1(TP) ; # OF ELEMENTS IN UVECTOR
+ MOVNS E
+ ADD E,OBJ-1(TP) ; LOCATION OF FIRST DOPE WORD FOR SOURCE
+ GETYP E,(E) ; GET UTYPE
+ MOVE D,NOARGS(P)
+ CAIE D,4
+ PUTYP E,(A) ; DUMP UTYPE INTO DOPE WORD OF ALLOC UVEC
+ CAILE D,3
+ CAIN 0,(E) ; 0 HAS USER UVEC UTYPE
+ JRST .+2
+ JRST WRNGUT
+ CAIL A,-1
+ JRST OUTRNG
+ MOVE D,NOARGS(P)
+ CAILE D,3
+ CAMGE B,(TP) ; SKIP IF NEEDS BACKWARDS BLT
+ JRST ALUEV3
+ HRRZ 0,(TP)
+ ADD 0,-4(TP)
+ CAIGE 0,(B)
+ JRST ALUEV3
+ SUBI A,1
+ PUSHJ P,BBLT
+ JRST ALUEV4
+ALUEV3: MOVE C,B ; SAVE POINTER TO FINAL GUY
+ HRL C,(TP) ; BUILD BLT POINTER
+ BLT C,-1(A)
+ALUEV4: MOVSI A,TUVEC
+ JRST EXSUB
+
+; BACKWARDS BLTTER
+; A==LAST WORD DEST (TP)==FIRST WORD DEST B==FIRST WORD SOURCE
+
+BBLT: SUBI A,-1(B)
+ MOVE E,A ; SAVE ADDITION
+ HRLZS A ; SWAP AND ZERO
+ HRR A,(TP)
+ ADDI A,-1(E)
+ MOVEI C,(B) ; SET UP DEST WORD
+ SUBI C,(A) ; CALC DIFF
+ ADDI C,-1(E) ; ADD TO GET TO END
+ HRLI C,A ; SET UP INDIRECT
+ POP A,@C ; BLT
+ TLNE A,-1 ; SKIP IF DONE
+ JRST .-2
+ POPJ P, ; EXIT
+
+ALUVE2: GETYP 0,NOBJ-2(TP) ; CHECK IT IS A VECTOR
+ CAIE 0,TUVEC
+ JRST WTYP
+ HLRE A,NOBJ-1(TP) ; CHECK SIZE
+ MOVNS A
+ CAMGE A,(P) ; SKIP IF BIG ENOUGH
+ JRST OUTRNG
+ MOVE B,NOBJ-1(TP) ; WINNER, JOIN COMMON CODE
+ HLRE A,B
+ SUBM B,A
+ GETYP 0,(A) ; GET UTYPE OF USER UVECTOR
+ JRST ALUVE1
+
+ALBYT: MOVSI C,TBYTE
+ JRST ALSTRX
+
+CPYBYT: SKIPA C,$TBYTE
+CPYSTR: MOVSI C,TCHSTR
+ HRR A,OBJ(TP)
+ PUSH TP,(B) ; ALSTR EXPECTS STRING IN TP
+ PUSH TP,1(B)
+ SUB P,[1,,1]
+ JRST .+2
+
+ALSTR: MOVSI C,TCHSTR
+ALSTRX: PUSH P,C ; SAVE FINAL TYPE
+ PUSH P,A ; LENGTH
+ HRRZ 0,-1(TP) ;0 IS LENGTH OFF VECTOR
+ CAIGE 0,(A)
+ JRST OUTRNG
+ CAILE D,3
+ JRST ALSTR2
+ LDB C,[300600,,(TP)]
+ MOVEI B,36.
+ IDIVI B,(C) ; B BYT PER WD, C XTRA BITS
+ ADDI A,-1(B)
+ IDIVI A,(B)
+ PUSH P,C
+ PUSHJ P,IBLOCK ;ALLOCATE SPACE
+ HLL B,(TP)
+ POP P,C
+ DPB C,[360600,,B]
+ SUBI B,1
+ MOVEM B,-2(TP)
+ MOVE A,(P) ; # OF CHARS TO A
+ HLL A,-1(P)
+ MOVEM A,-3(TP)
+ JUMPN A,SSTR1
+ALSTR9: SUB TP,[4,,4]
+ JRST ALSTR8
+ALSTR1: HLL A,-2(P) ; GET TYPE
+ HRRZ C,B ; SEE IF WE WILL OVERLAP
+ HRRZ D,(TP) ; GET RESTED STRING
+ CAIGE C,(D) ; IF C > B THE A CHANCE
+ JRST SSTR
+ MOVEI C,-1(TP) ; GO TO BYTDOP
+ PUSHJ P,BYTDOP
+ HRRZ B,-2(TP) ; IF B < A THEN OVERLAP
+ CAILE B,(A)
+ JRST SSTR
+ HRRZ A,-4(TP) ; GET LENGTH IN A
+ MOVEI B,0 ; START LENGTH COUNT
+
+; ORIGINAL STRING IS ON THE TOP OF THE STACK
+
+CLOOP1: INTGO
+ PUSH P,[0] ; STORE CHARS ON STACK
+ MOVSI E,(<440000,,(P)>) ; SETUP BYTE POINTER
+ LDB 0,[300600,,(TP)]
+ DPB 0,[300600,,E]
+CLOOP: IBP E ; BUMP IT
+ TRNE E,-1 ; WORD FULL
+ AOJA B,CLOOP1 ; PUSH NEW ONE
+ ILDB 0,(TP) ; GET A CHARACTER
+ SOS -1(TP) ; DECREMENT CHARACTER COUNT
+ DPB 0,E
+ SOJN A,CLOOP ; ANY MORE?
+ SUB TP,[2,,2]
+ MOVEI C,(P)
+ PUSH P,B ; SAVE B
+ SUBI C,(B)
+ MOVE A,-2(TP) ; GET COUNT
+ MOVE B,(TP)
+ HRLI C,440000 ; MAKE IT LOOK LIKE A BYTE PTR
+ LDB 0,[300600,,(TP)]
+ DPB 0,[300600,,C]
+CLOOP3: ILDB D,C ; GET NEW CHARACTER
+ IDPB D,B ; DEPOSIT CHARACTER
+ SOJG A,CLOOP3
+ POP P,A
+ SUBI P,(A)
+ HRLZS A
+ SUB P,A ; CLEAN OFF STACK
+ POP TP,B ;BYTE PTR TO COPY
+ SUB P,[1,,1]
+ALST10: SUB TP,[1,,1] ; CLEAN OFF STACK
+ALSTR8: POP P,A ;# FO ELEMENTS
+ HLL A,(P)
+ SUB TP,[6,,6]
+ JRST EXSUB1
+
+
+; ROUTINE TO DO FAST TRANSFER FOR NON SHARING STRINGS
+
+SSTR: MOVE A,-4(TP) ; GET # OF ELEMENTS INTO A
+ MOVE B,-2(TP)
+SSTR1: POP TP,C
+ SUB TP,[1,,1]
+ HRRZS A
+SSTR2: ILDB D,C
+ IDPB D,B
+ SOJG A,SSTR2
+ POP TP,B
+ JRST ALST10
+
+ALSTR2: GETYP 0,NOBJ-2(TP) ; CHECK IT IS A VECTOR
+ MOVSS 0
+ CAME 0,-1(P)
+ JRST WTYP
+ HRRZ A,NOBJ-2(TP)
+ CAMGE A,(P) ; SKIP IF BIG ENOUGH
+ JRST OUTRNG
+ EXCH A,(P)
+ MOVE B,NOBJ-1(TP) ; WINNER, JOIN COMMON CODE
+ JUMPE A,ALSTR9
+ JRST ALSTR1
+
+; HERE TO COPY A LIST
+
+CPYLST: SKIPN OBJ+1(TP)
+ JRST ZEROLT
+ PUSHJ P,CELL2
+ POP P,C
+ HRLI C,TLIST ; TP JUNK FOR GAR. COLLECTOR
+ PUSH TP,C ; TYPE
+ PUSH TP,B ; VALUE -PTR TO NEW LIST
+ PUSH TP,C ; TYPE
+ MOVE C,OBJ-2(TP) ; PTR TO FIRST ELEMENT OF ORIG. LIST
+REPLST: MOVE D,(C)
+ MOVE E,1(C) ; GET LIST ELEMENT INTO ALOC SPACE
+ HLLM D,(B)
+ MOVEM E,1(B) ; PUT INTO ALLOCATED SPACE
+ HRRZ C,(C) ; UPDATE PTR
+ JUMPE C,CLOSWL ; END OF LIST?
+ PUSH TP,B
+ PUSHJ P,CELL2
+ POP TP,D
+ HRRM B,(D) ; LINK ALLOCATED LIST CELLS
+ JRST REPLST
+
+CLOSWL: MOVE A,-2(TP) ; GET LIST
+ MOVE B,-1(TP)
+ SUB TP,[11.,,11.]
+LEXIT: SUB P,[1,,1]
+ JRST MPOPJ
+
+
+
+ALLIST: PUSH P,A
+ MOVE D,NOARGS(P)
+ CAILE D,3 ; SKIP IF WE BUILD LIST
+ JRST CPYLS2
+ JUMPE A,ZEROL1
+ ASH A,1 ; TIMES 2
+ PUSHJ P,CELL
+ POP P,A ; # OF ELEMENTS
+ PUSH P,B ; ptr to allocated list
+ POP TP,C ; ptr to orig list
+ JRST ENTCOP
+
+COPYL: ADDI B,2
+ HRRM B,-2(B) ; LINK ALOCATED LIST CELLS
+ENTCOP: JUMPE C,OUTRNG
+ MOVE D,(C)
+ MOVE E,1(C) ; get list element into D+E
+ HLLM D,(B)
+ MOVEM E,1(B) ; put into allocated space
+ HRRZ C,(C) ; update ptrs
+ SOJG A,COPYL ; finish transfer?
+
+CLOSEL: POP P,B
+ MOVE A,(TP)
+ SUB TP,[9.,,9.]
+ JRST LEXIT
+
+
+ZEROL1: SUB TP,[2,,2]
+ZEROLT: MOVSI A,TLIST
+ MOVEI B,0
+ SUB TP,[8,,8]
+ JRST EXSUB1
+
+CPYLS2: GETYP 0,NOBJ-2(TP)
+ CAIE 0,TLIST
+ JRST WTYP
+ MOVE B,NOBJ-1(TP) ; GET DEST LIST
+ MOVE C,(TP)
+
+ JUMPE A,CPYLS3
+CPYLS4: JUMPE B,OUTRNG
+ JUMPE C,OUTRNG
+ MOVE D,1(C)
+ MOVEM D,1(B)
+ GETYP 0,(C)
+ HRLM 0,(B)
+ HRRZ B,(B)
+ HRRZ C,(C)
+ SOJG A,CPYLS4
+
+CPYLS3: MOVE D,-2(TP)
+ MOVE B,NOBJ-1(TP)
+ MOVSI A,TLIST
+
+; HERE TO EXIT
+
+EXSUB: SUB TP,[10.,,10.]
+EXSUB1: SUB P,[2,,2]
+ JRST MPOPJ
+
+
+\f
+; PROCESS TYPE ILLEGAL
+
+ILLCHO: HRRZ B,1(B) ;GET CLOBBERED TYPE
+ CAIN B,TARGS ;WAS IT ARGS?
+ JRST ILLAR1
+ CAIN B,TFRAME ;A FRAME?
+ JRST ILFRAM
+ CAIN B,TLOCD ;A LOCATIVE TO AN ID
+ JRST ILLOC1
+
+ LSH B,1 ;NONE OF ABOVE LOOK IN TABLE
+ ADDI B,TYPVEC+1
+ PUSH TP,$TATOM
+ PUSH TP,EQUOTE ILLEGAL
+ PUSH TP,$TATOM
+ PUSH TP,(B) ;PUSH ATOMIC NAME
+ MOVEI A,2
+ JRST CALER ;GO TO ERROR REPORTER
+
+; CHECK AN ARGS POINTER
+
+CHARGS: PUSHJ P,ICHARG ; INTERNAL CHECK
+ JUMPN B,CPOPJ
+
+ILLAR1: ERRUUO EQUOTE ILLEGAL-ARGUMENT-BLOCK
+
+ICHARG: PUSH P,A ;SAVE SOME ACS
+ PUSH P,B
+ PUSH P,C
+ SKIPN C,1(B) ;GET POINTER
+ JRST ILLARG ; ZERO POINTER IS ILLEGAL
+ HLRE A,C ;FIND ASSOCIATED FRAME
+ SUBI C,(A) ;C POINTS TO FRAME OR FRAME POINTER
+ GETYP A,(C) ;GET TYPE OF NEXT GOODIE
+ CAIN A,TCBLK
+ JRST CHARG1
+ CAIE A,TENTRY ;MUST BE EITHER ENTRY OR TINFO
+ CAIN A,TINFO
+ JRST CHARG1 ;WINNER
+ JRST ILLARG
+
+CHARG1: CAIN A,TINFO ;POINTER TO FRAME?
+ ADD C,1(C) ;YES, GET IT
+ CAIE A,TINFO ;POINTS TO ENTRT?
+ MOVEI C,FRAMLN(C) ;YES POINT TO END OF FRAME
+ HLRZ C,OTBSAV(C) ;GET TIME FROM FRAME
+ HRRZ B,(B) ;AND ARGS TIME
+ CAIE B,(C) ;SAME?
+ILLARG: SETZM -1(P) ; RETURN ZEROED B
+POPBCJ: POP P,C
+ POP P,B
+ POP P,A
+ POPJ P, ;GO GET PRIM TYPE
+\f
+
+
+; CHECK A FRAME POINTER
+
+CHFRM: PUSHJ P,CHFRAM
+ JUMPN B,CPOPJ
+
+ILFRAM: ERRUUO EQUOTE ILLEGAL-FRAME
+
+CHFRAM: PUSH P,A ;SAVE SOME REGISTERS
+ PUSH P,B
+ PUSH P,C
+ HRRZ A,(B) ; GE PVP POINTER
+ HLRZ C,(A) ; GET LNTH
+ SUBI A,-1(C) ; POINT TO TOP
+ MOVE PVP,PVSTOR+1
+ CAIN A,(PVP) ; SKIP IF NOT THIS PROCESS
+ MOVEM TP,TPSTO+1(A) ; MAKE CURRENT BE STORED
+ HRRZ A,TPSTO+1(A) ; GET TP FOR THIS PROC
+ HRRZ C,1(B) ;GET POINTER PART
+ CAILE C,1(A) ;STILL WITHIN STACK
+ JRST BDFR
+ HLRZ A,FSAV(C) ;CHECK STILL AN ENTRY BLOCK
+ CAIN A,TCBLK
+ JRST .+3
+ CAIE A,TENTRY
+ JRST BDFR
+ HLRZ A,1(B) ;GET TIME FROM POINTER
+ HLRZ C,OTBSAV(C) ;AND FROM FRAME
+ CAIE A,(C) ;SAME?
+BDFR: SETZM -1(P) ; RETURN 0 IN B
+ JRST POPBCJ ;YES, WIN
+
+; CHECK A LOCATIVE TO AN IDENTIFIER
+
+CHLOCI: PUSHJ P,ICHLOC
+ JUMPN B,CPOPJ
+
+ILLOC1: ERRUUO EQUOTE ILLEGAL-LOCATIVE
+
+ICHLOC: PUSH P,A
+ PUSH P,B
+ PUSH P,C
+
+ HRRZ A,(B) ;GET TIME FROM POINTER
+ JUMPE A,POPBCJ ;ZERO, GLOBAL VARIABLE NO TIME
+ HRRZ C,1(B) ;POINT TO STACK
+ CAMLE C,VECTOP
+ JRST ILLOC ;NO
+ HRRZ C,2(C) ; SHOULD BE DECL,,TIME
+ CAIE A,(C)
+ILLOC: SETZM -1(P) ; RET 0 IN B
+ JRST POPBCJ
+
+
+
+\f
+; PREDICATE TO SEE IF AN OBJECT IS STRUCTURED
+
+MFUNCTION %STRUC,SUBR,[STRUCTURED?]
+
+ ENTRY 1
+
+ GETYP A,(AB) ; GET TYPE
+ PUSHJ P,ISTRUC ; INTERNAL
+ JRST IFALSE
+ JRST ITRUTH
+
+
+; PREDICATE TO CHECK THE LEGALITY OF A FRAME/ARGS TUPLE/IDENTIFIER LOCATIVE
+
+MFUNCTION %LEGAL,SUBR,[LEGAL?]
+
+ ENTRY 1
+
+ MOVEI B,(AB) ; POINT TO ARG
+ PUSHJ P,ILEGQ
+ JRST IFALSE
+ JRST ITRUTH
+
+ILEGQ: GETYP A,(B)
+ CAIN A,TILLEG
+ POPJ P,
+ PUSHJ P,SAT ; GET STORG TYPE
+ CAIN A,SFRAME ; FRAME?
+ PUSHJ P,CHFRAM
+ CAIE A,SLOCA
+ CAIN A,SARGS ; ARG TUPLE
+ PUSHJ P,ICHARG
+ CAIN A,SLOCID ; ID LOCATIVE
+ PUSHJ P,ICHLOC
+ JUMPE B,CPOPJ
+ JRST CPOPJ1
+
+
+; COMPILERS CALL
+
+CILEGQ: PUSH TP,A
+ PUSH TP,B
+ MOVEI B,-1(TP)
+ PUSHJ P,ILEGQ
+ TDZA 0,0
+ MOVEI 0,1
+ SUB TP,[2,,2]
+ JUMPE 0,NO
+
+YES: MOVSI A,TATOM
+ MOVE B,IMQUOTE T
+ JRST CPOPJ1
+
+NOM: SUBM M,(P)
+NO: MOVSI A,TFALSE
+ MOVEI B,0
+ POPJ P,
+
+YESM: SUBM M,(P)
+ JRST YES
+\f;SUBRS TO DEFINE, GET, AND PUT BIT FIELDS
+
+MFUNCTION BITS,SUBR
+ ENTRY
+ JUMPGE AB,TFA ;AT LEAST ONE ARG ?
+ GETYP A,(AB)
+ CAIE A,TFIX
+ JRST WTYP1
+ SKIPLE C,(AB)+1 ;GET FIRST AND CHECK TO SEE IF POSITIVE
+ CAILE C,44 ;CHECK IF FIELD NOT GREATER THAN WORD SIZE
+ JRST OUTRNG
+ MOVEI B,0
+ CAML AB,[-2,,0] ;ONLY ONE ARG ?
+ JRST ONEF ;YES
+ CAMGE AB,[-4,,0] ;MORE THAN TWO ARGS ?
+ JRST TMA ;YES, LOSE
+ GETYP A,(AB)+2
+ CAIE A,TFIX
+ JRST WTYP2
+ SKIPGE B,(AB)+3 ;GET SECOND ARG AND CHECK TO SEE IF NON-NEGATIVE
+ JRST OUTRNG
+ ADD C,(AB)+3 ;CALCULATE LEFTMOST EXTENT OF THE FIELD
+ CAILE C,44 ;SHOULD BE LESS THAN WORD SIZE
+ JRST OUTRNG
+ LSH B,6
+ONEF: ADD B,(AB)+1
+ LSH B,30 ;FORM BYTE POINTER'S LEFT HALF
+ MOVSI A,TBITS
+ JRST FINIS
+
+
+
+MFUNCTION GETBITS,SUBR
+ ENTRY 2
+ GETYP A,(AB)
+ PUSHJ P,SAT
+ CAIN A,SSTORE
+ JRST .+3
+ CAIE A,S1WORD
+ JRST WTYP1
+ GETYP A,(AB)+2
+ CAIE A,TBITS
+ JRST WTYP2
+ MOVEI A,(AB)+1 ;GET ADDRESS OF THE WORD
+ HLL A,(AB)+3 ;GET LEFT HALF OF BYTE POINTER
+ LDB B,A
+ MOVSI A,TWORD ; ALWAYS RETURN WORD\b\b\b\b____
+ JRST FINIS
+
+
+MFUNCTION PUTBITS,SUBR
+ ENTRY
+ CAML AB,[-2,,0] ;AT LEAST TWO ARGS ?
+ JRST TFA ;NO, LOSE
+ GETYP A,(AB)
+ PUSHJ P,SAT
+ CAIE A,S1WORD
+ JRST WTYP1
+ GETYP A,(AB)+2
+ CAIE A,TBITS
+ JRST WTYP2
+ MOVEI B,0 ;EMPTY THIRD ARG DEFAULT
+ CAML AB,[-4,,0] ;ONLY TWO ARGS ?
+ JRST TWOF
+ CAMGE AB,[-6,,0] ;MORE THAN THREE ARGS ?
+ JRST TMA ;YES, LOSE
+ GETYP A,(AB)+4
+ PUSHJ P,SAT
+ CAIE A,S1WORD
+ JRST WTYP3
+ MOVE B,(AB)+5
+TWOF: MOVEI A,(AB)+1 ;ADDRESS OF THE TARGET WORD
+ HLL A,(AB)+3 ;GET THE LEFT HALF OF THE BYTE POINTER
+ DPB B,A
+ MOVE B,(AB)+1
+ MOVE A,(AB) ;SAME TYPE AS FIRST ARG'S
+ JRST FINIS
+\f
+
+; FUNCTION TO GET THE LENGTH OF LISTS,VECTORS AND CHAR STRINGS
+
+MFUNCTION LNTHQ,SUBR,[LENGTH?]
+
+ ENTRY 2
+ GETYP A,(AB)2
+ CAIE A,TFIX
+ JRST WTYP2
+ PUSH P,(AB)3
+ JRST LNTHER
+
+
+MFUNCTION LENGTH,SUBR
+
+ ENTRY 1
+ PUSH P,[377777777777]
+LNTHER: MOVE B,AB ;POINT TO ARGS
+ PUSHJ P,PTYPE ;GET ITS PRIM TYPE
+ MOVE B,1(AB)
+ MOVE C,(AB)
+ PUSHJ P,@LENTBL(A) ; CALL RIGTH ONE
+ JRST LFINIS ;OTHERWISE USE 0
+
+PRDISP LENTBL,IWTYP1,[[P2WORD,LNLST],[P2NWORD,LNVEC],[PNWORD,LNUVEC]
+[PARGS,LNVEC],[PCHSTR,LNCHAR],[PTMPLT,LNTMPL],[PBYTE,LNCHAR]]
+
+LNLST: SKIPN C,B ; EMPTY?
+ JRST LNLST2 ; YUP, LEAVE
+ MOVEI B,1 ; INIT COUNTER
+ MOVSI A,TLIST ;WILL BECOME INTERRUPTABLE
+ MOVE PVP,PVSTOR+1
+ HLLM A,CSTO(PVP) ;AND C WILL BE A LIST POINTER
+LNLST1: INTGO ;IN CASE CIRCULAR LIST
+ CAMLE B,(P)-1
+ JRST LNLST2
+ HRRZ C,(C) ;STEP
+ JUMPE C,.+2 ;DONE, RETRUN LENGTH
+ AOJA B,LNLST1 ;COUNT AND GO
+LNLST2: MOVE PVP,PVSTOR+1
+ SETZM CSTO(PVP)
+ POPJ P,
+
+LFINIS: POP P,C
+ CAMLE B,C
+ JRST IFALSE
+ MOVSI A,TFIX ;LENGTH IS AN INTEGER
+ JRST FINIS
+
+LNVEC: ASH B,-1 ;GENERAL VECTOR DIVIDE BY 2
+LNUVEC: HLRES B ;GET LENGTH
+ MOVMS B ;MAKE POS
+ POPJ P,
+
+LNCHAR: HRRZ B,C ; GET COUNT
+ POPJ P,
+
+LNTMPL: GETYP A,(B) ; GET REAL SAT
+ SUBI A,NUMSAT+1
+ HRLS A ; READY TO HIT TABLE
+ ADD A,TD.LNT+1
+ JUMPGE A,BADTPL
+ MOVE C,B ; DATUM TO C
+ XCT (A) ; GET LENGTH
+ HLRZS C ; REST COUNTER
+ SUBI B,(C) ; FLUSH IT OFF
+ MOVEI B,(B) ; IN CASE FUNNY STUFF
+ MOVSI A,TFIX
+ POPJ P,
+
+; COMPILERS ENTRIES
+
+CILNT: SUBM M,(P)
+ PUSH P,[377777,,-1]
+ MOVE C,A
+ GETYP A,A
+ PUSHJ P,CPTYPE ; GET PRIMTYPE
+ JUMPE A,CILN1
+ PUSHJ P,@LENTBL(A) ; DISPATCH
+ MOVSI A,TFIX
+CILN2: SUB P,[1,,1]
+MPOPJ: SUBM M,(P)
+ POPJ P,
+
+CILN1: PUSH TP,C
+ PUSH TP,B
+ MCALL 1,LENGTH
+ JRST CILN2
+
+CILNQ: SUBM M,(P)
+ PUSH P,C
+ MOVE C,A
+ GETYP A,A
+ PUSHJ P,CPTYPE
+ JUMPE A,CILNQ1
+ PUSHJ P,@LENTBL(A)
+ POP P,C
+ SUBM M,(P)
+ MOVSI A,TFIX
+ CAMG B,C
+ JRST CPOPJ1
+ MOVSI A,TFALSE
+ MOVEI B,0
+ POPJ P,
+
+CILNQ1: PUSH TP,C
+ PUSH TP,B
+ PUSH TP,$TFIX
+ PUSH TP,(P)
+ MCALL 2,LENGTH?
+ SUBM M,(P)
+ GETYP 0,A
+ CAIE 0,TFALSE
+ AOS (P)
+ POPJ P,
+\f
+
+MFUNCTION BYTSIZ,SUBR,[BYTE-SIZE]
+
+ ENTRY 1
+
+ GETYP A,(AB)
+ PUSHJ P,SAT
+ CAIE A,SBYTE
+ JRST WTYP1
+ LDB B,[300600,,1(AB)]
+ MOVSI A,TFIX
+ JRST FINIS
+\f
+
+
+IDNT1: MOVE A,(AB) ;RETURN THE FIRST ARG
+ MOVE B,1(AB)
+ JRST FINIS
+
+IMFUNCTION QUOTE,FSUBR
+
+ ENTRY 1
+
+ GETYP A,(AB)
+ CAIE A,TLIST ;ARG MUST BE A LIST
+ JRST WTYP1
+ SKIPN B,1(AB) ;SHOULD HAVE A BODY
+ JRST TFA
+
+ HLLZ A,(B) ; GET IT
+ MOVE B,1(B)
+ JSP E,CHKAB
+ JRST FINIS
+
+MFUNCTION NEQ,SUBR,[N==?]
+
+ MOVEI D,1
+ JRST EQR
+
+MFUNCTION EQ,SUBR,[==?]
+
+ MOVEI D,0
+EQR: ENTRY 2
+
+ GETYP A,(AB) ;GET 1ST TYPE
+ GETYP C,2(AB) ;AND 2D TYPE
+ MOVE B,1(AB)
+ CAIN A,(C) ;CHECK IT
+ CAME B,3(AB)
+ JRST @TABLE2(D)
+ JRST @TABLE1(D)
+
+ITRUTH: MOVSI A,TATOM ;RETURN TRUTH
+ MOVE B,IMQUOTE T
+ JRST FINIS
+
+IFALSE: MOVSI A,TFALSE ;RETURN FALSE
+ MOVEI B,0
+ JRST FINIS
+
+TABLE1: ITRUTH
+TABLE2: IFALSE
+ ITRUTH
+
+\f
+
+
+MFUNCTION EMPTY,SUBR,EMPTY?
+
+ ENTRY 1
+
+ MOVE B,AB
+ PUSHJ P,PTYPE ;GET PRIMITIVE TYPE
+
+ MOVEI A,(A)
+ JUMPE A,WTYP1
+ SKIPN B,1(AB) ;GET THE ARG
+ JRST ITRUTH
+
+ CAIN A,PTMPLT ; TEMPLATE?
+ JRST EMPTPL
+ CAIE A,P2WORD ;A LIST?
+ JRST EMPT1 ;NO VECTOR OR CHSTR
+ JUMPE B,ITRUTH ;0 POINTER MEANS EMPTY LIST
+ JRST IFALSE
+
+
+EMPT1: CAIN A,PBYTE
+ JRST .+3
+ CAIE A,PCHSTR ;CHAR STRING?
+ JRST EMPT2 ;NO, VECTOR
+ HRRZ B,(AB) ; GET COUNT
+ JUMPE B,ITRUTH ;0 STRING WINS
+ JRST IFALSE
+
+EMPT2: JUMPGE B,ITRUTH
+ JRST IFALSE
+
+EMPTPL: PUSHJ P,LNTMPL ; GET LENGTH
+ JUMPE B,ITRUTH
+ JRST IFALSE
+
+; COMPILER'S ENTRY TO EMPTY
+
+CEMPTY: PUSH P,A
+ GETYP A,A
+ PUSHJ P,CPTYPE
+ POP P,0
+ JUMPE A,CEMPT2
+ JUMPE B,YES ; ALWAYS EMPTY
+ CAIN A,PTMPLT
+ JRST CEMPTP
+ CAIN A,P2WORD
+ JRST NO
+ CAIN A,PCHSTR
+ JRST .+3
+ JUMPGE B,YES
+ JRST NO
+ TRNE 0,-1 ; STRING, SKIP ON ZERO LENGTH FIELD
+ JRST NO
+ JRST YES
+
+CEMPTP: PUSHJ P,LNTMPL
+ JUMPE B,YES
+ JRST NO
+
+CEMPT2: PUSH TP,0
+ PUSH TP,B
+ MCALL 1,EMPTY?
+ JUMPE B,NO
+ JRST YES
+
+MFUNCTION NEQUAL,SUBR,[N=?]
+ PUSH P,[1]
+ JRST EQUALR
+
+MFUNCTION EQUAL,SUBR,[=?]
+ PUSH P,[0]
+EQUALR: ENTRY 2
+
+ MOVE C,AB ;SET UP TO CALL INTERNAL
+ MOVE D,AB
+ ADD D,[2,,2] ;C POINTS TO FIRS, D TO SECOND
+ PUSHJ P,IEQUAL ;CALL INTERNAL
+ JRST EQFALS ;NO SKIP MEANS LOSE
+ JRST EQTRUE
+EQFALS: POP P,C
+ JRST @TABLE2(C)
+EQTRUE: POP P,C
+ JRST @TABLE1(C)
+
+\f
+; COMPILER'S ENTRY TO =? AND N=?
+
+CINEQU: PUSH P,[0]
+ JRST .+2
+
+CIEQUA: PUSH P,[1]
+ PUSH TP,A
+ PUSH TP,B
+ PUSH TP,C
+ PUSH TP,D
+ MOVEI C,-3(TP)
+ MOVEI D,-1(TP)
+ SUBM M,-1(P) ; MAY BECOME INTERRUPTABLE
+ PUSHJ P,IEQUAL
+ JRST NOE
+ POP P,C
+ SUB TP,[4,,4] ; FLUSH TEMPS
+ JRST @CTAB1(C)
+
+NOE: POP P,C
+ SUB TP,[4,,4]
+ JRST @CTAB2(C)
+
+CTAB1: SETZ NOM
+CTAB2: SETZ YESM
+ SETZ NOM
+
+; INTERNAL EQUAL SUBROUTINE
+
+IEQUAL: MOVE B,C ;NOW CHECK THE ARGS
+ PUSHJ P,PTYPE
+ MOVE B,D
+ PUSHJ P,PTYPE
+ MOVE F,0 ; SAVE SAT FOR OFFSET HACK
+ GETYP 0,(C) ;NOW CHECK FOR EQ
+ GETYP B,(D)
+ MOVE E,1(C)
+ CAIN 0,(B) ;DONT SKIP IF POSSIBLE WINNER
+ CAME E,1(D) ;DEFINITE WINNER, SKIP
+ JRST IEQ1
+CPOPJ1: AOS (P) ;EQ, SKIP RETURN
+ POPJ P,
+
+
+IEQ1: CAIE 0,(B) ;SKIP IF POSSIBLE MATCH
+CPOPJ: POPJ P, ;NOT POSSIBLE WINNERS
+ CAIN F,SOFFS
+ JRST EQOFFS
+ JRST @EQTBL(A) ;DISPATCH
+
+PRDISP EQTBL,CPOPJ,[[P2WORD,EQLIST],[P2NWORD,EQVEC],[PNWORD,EQUVEC]
+[PARGS,EQVEC],[PCHSTR,EQCHST],[PTMPLT,EQTMPL],[PBYTE,EQCHST]]
+
+EQLIST: PUSHJ P,PUSHCD ;PUT ARGS ON STACK
+
+EQLST1: INTGO ;IN CASE OF CIRCULAR
+ HRRZ C,-2(TP) ;GET FIRST
+ HRRZ D,(TP) ;AND 2D
+ CAIN C,(D) ;EQUAL?
+ JRST EQLST2 ;YES, LEAVE
+ JUMPE C,EQLST3 ;NIL LOSES
+ JUMPE D,EQLST3
+ GETYP 0,(C) ;CHECK DEFERMENT
+ CAIN 0,TDEFER
+ HRRZ C,1(C) ;PICK UP POINTED TO CROCK
+ GETYP 0,(D)
+ CAIN 0,TDEFER
+ HRRZ D,1(D) ;POINT TO REAL GOODIE
+ PUSHJ P,IEQUAL ;CHECK THE CARS
+ JRST EQLST3 ;LOSE
+ HRRZ C,@-2(TP) ;CDR THE LISTS
+ HRRZ D,@(TP)
+ HRRZM C,-2(TP) ;AND STORE
+ HRRZM D,(TP)
+ JRST EQLST1
+
+EQLST2: AOS (P) ;SKIP RETRUN
+EQLST3: SUB TP,[4,,4] ;REMOVE CRUFT
+ POPJ P,
+\f
+; HERE FOR HACKING OFFSETS
+EQOFFS: HRRZ A,1(C)
+ HRRZ B,1(D) ; GET NUMBERS
+ CAIE A,(B) ; POSSIBLE WINNER IF SKIP
+ POPJ P,
+ PUSH TP,$TLIST
+ HLRZ A,1(C)
+ PUSH TP,A
+ PUSH TP,$TLIST
+ HLRZ A,1(D)
+ PUSH TP,A
+ JRST EQLST1 ; SEE IF THE TWO LISTS ARE EQUAL
+
+; HERE FOR HACKING TEMPLATE STRUCTURES
+
+EQTMPL: PUSHJ P,PUSHCD ; SAVE GOODIES
+ PUSHJ P,PUSHCD
+ MOVE C,1(C) ; CHECK REAL SATS
+ GETYP C,(C)
+ MOVE D,1(D)
+ GETYP 0,(D)
+ CAIE 0,(C) ; SKIP IF WINNERS
+ JRST EQTMP4
+ PUSH P,0 ; SAVE MAGIC OFFSET
+ MOVE B,-2(TP)
+ PUSHJ P,TM.LN1 ; RET LENGTH IN B
+ MOVEI B,(B) ; FLUSH FUNNY
+ HLRZ C,-2(TP)
+ SUBI B,(C)
+ PUSH P,B
+ MOVE C,(TP) ; POINTER TO OTHER GUY
+ ADD A,TD.LNT+1
+ XCT (A) ; OTHER LENGTH TO B
+ HLRZ 0,-2(TP) ; REST OFFSETTER
+ SUBI 0,1
+ PUSH P,0
+ MOVEI B,(B)
+ HLRZ C,(TP)
+ SUBI B,(C)
+ HRRZS -4(TP) ; UNDO RESTING (ACCOUNTED FOR BY STARTING
+ ; AT LATER ELEMENT)
+ HRRZS -6(TP)
+ CAME B,-1(P)
+ JRST EQTMP1
+
+EQTMP2: AOS C,(P)
+ SOSGE -1(P)
+ JRST EQTMP3 ; WIN!!
+
+ MOVE B,-6(TP) ; POINTER
+ MOVE 0,-2(P) ; GET MAGIC OFFSET
+ PUSHJ P,TMPLNT ; GET AN ELEMENT
+ MOVEM A,-3(TP)
+ MOVEM B,-2(TP)
+ MOVE C,(P)
+ MOVE B,-4(TP) ; OTHER GUY
+ MOVE 0,-2(P)
+ PUSHJ P,TMPLNT
+ MOVEM A,-1(TP)
+ MOVEM B,(TP)
+ MOVEI C,-3(TP)
+ MOVEI D,-1(TP)
+ PUSHJ P,IEQUAL ; RECURSE
+ JRST EQTMP1 ; LOSER
+ JRST EQTMP2 ; WINNER
+
+EQTMP3: AOS -3(P) ; WIN RETURN
+EQTMP1: SUB P,[3,,3] ; FLUSH JUNK
+EQTMP4: SUB TP,[10,,10]
+ POPJ P,
+
+
+
+EQVEC: HLRE A,1(C) ;GET LENGTHS
+ HLRZ B,1(D)
+ CAIE B,(A) ;SKIP IF EQUAL LENGTHS
+ POPJ P, ;LOSE
+ JUMPGE A,CPOPJ1 ;SKIP RETRUN WIN
+ PUSHJ P,PUSHCD ;SAVE ARGS
+
+EQVEC1: INTGO ;IN CASE LONG VECTOR
+ MOVE C,(TP)
+ MOVE D,-2(TP) ;ARGS TO C AND D
+ PUSHJ P,IEQUAL
+ JRST EQLST3
+ MOVE C,[2,,2] ;GET BUMPER
+ ADDM C,(TP)
+ ADDB C,-2(TP) ;BUMP BOTH POINTERS
+ JUMPL C,EQVEC1
+ JRST EQLST2
+
+EQUVEC: HLRE A,1(C) ;GET LENGTHS
+ HLRZ B,1(D)
+ CAIE B,(A) ;SKIP IF EQUAL
+ POPJ P,
+
+ HRRZ B,1(C) ;START COMPUTING DOPE WORD LOCN
+ SUB B,A ;B POINTS TO DOPE WORD
+ GETYP 0,(B) ;GET UNIFORM TYPE
+ HRRZ B,1(D) ;NOW FIND OTHER DOPE WORD
+ SUB B,A
+ GETYP B,(B) ;OTHER UNIFORM TYPE
+ CAIE 0,(B) ;TYPES THE SAME?
+ POPJ P, ;NO, LOSE
+
+ JUMPGE A,CPOPJ1 ;IF ZERO LENGTH ALREADY WON
+
+ HRLZI B,(B) ;TYPE TO LH
+ PUSH P,B ;AND SAVED
+ PUSHJ P,PUSHCD ;SAVE ARGS
+
+EQUV1: MOVEI C,1(TP) ;POINT TO WHERE WILL GO
+ PUSH TP,(P)
+ MOVE A,-3(TP) ;PUSH ONE OF THE VECTORS
+ PUSH TP,(A) ; PUSH ELEMENT
+ MOVEI D,1(TP) ;POINT TO 2D ARG
+ PUSH TP,(P)
+ MOVE A,-3(TP) ;AND PUSH ITS POINTER
+ PUSH TP,(A)
+ PUSHJ P,IEQUAL
+ JRST UNEQUV
+
+ SUB TP,[4,,4] ;POP TP
+ MOVE A,[1,,1]
+ ADDM A,(TP) ;BUMP POINTERS
+ ADDB A,-2(TP)
+ JUMPL A,EQUV1 ;JUMP IF STILL MORE STUFF
+ SUB P,[1,,1] ;POP OFF TYPE
+ JRST EQLST2
+
+UNEQUV: SUB P,[1,,1]
+ SUB TP,[10,,10]
+ POPJ P,
+\f
+
+
+EQCHST: HRRZ B,(C) ; GET LENGTHS
+ HRRZ A,(D)
+ CAIE A,(B) ;SAME
+ JRST EQCHS3 ;NO, LOSE
+ LDB 0,[300600,,1(C)]
+ LDB E,[300600,,1(D)]
+ CAIE 0,(E)
+ JRST EQCHS3
+ MOVE C,1(C)
+ MOVE D,1(D)
+ JUMPE A,EQCHS4 ;BOTH 0 LENGTH, WINS
+
+EQCHS2:
+ ILDB 0,C ;GET NEXT CHARS
+ ILDB E,D
+ CAME 0,E ; SKIP IF STILL WINNING
+ JRST EQCHS3 ; NOT =
+ SOJG A,EQCHS2
+
+EQCHS4: AOS (P)
+EQCHS3: POPJ P,
+
+PUSHCD: PUSH TP,(C)
+ PUSH TP,1(C)
+ PUSH TP,(D)
+ PUSH TP,1(D)
+ POPJ P,
+
+\f
+; REST/NTH/AT/PUT/GET
+
+; ARG CHECKER
+
+ARGS1: MOVE E,[JRST WTYP2] ; ERROR CONDITION FOR 2D ARG NOT FIXED
+ARGS2: HLRE 0,AB ; CHECK NO. OF ARGS
+ ASH 0,-1 ; TO - NO. OF ARGS
+ AOJG 0,TFA ; 0--TOO FEW
+ AOJL 0,TMA ; MORE THAT 2-- TOO MANY
+ MOVEI C,1 ; DEFAULT ARG2
+ JUMPN 0,ARGS4 ; GET STRUCTURED ARG
+ARGS3: GETYP A,2(AB)
+ CAIN A,TOFFS ; OFFSET?
+ JRST ARGOFF ; GO DO DECL-CHECK AND SUCH
+ CAIE A,TFIX ; SHOULD BE FIXED NUMBER
+ XCT E ; DO ERROR THING
+ SKIPGE C,3(AB) ; BETTER BE NON-NEGATIVE
+ JRST OUTRNG
+ARGS4: MOVEI B,(AB) ; POINT TO STRUCTURED POINTER
+ PUSHJ P,PTYPE ; GET PRIM TYPE
+ MOVEI E,(A) ; DISPATCH CODE TO E
+ MOVE A,(AB) ; GET ARG 1
+ MOVE B,1(AB)
+ POPJ P,
+ARGOFF: HLRZ B,3(AB) ; PICK UP DECL POINTER FOR OFFSET
+ JUMPE B,ARGOF1
+ MOVE A,(B) ; TYPE WORD
+ MOVE B,1(B) ; VALUE
+ MOVE C,(AB)
+ MOVE D,1(AB)
+ PUSHJ P,TMATCH ; CHECK THE DECL
+ JRST WTYP1 ; FIRST ARG WRONG TYPE
+ARGOF1: HRRE C,3(AB) ; GET THE FIX
+ JUMPL C,OUTRNG
+ JRST ARGS4 ; FINISH
+
+; REST
+
+IMFUNCTION REST,SUBR
+
+ ENTRY
+ PUSHJ P,ARGS1 ; GET AND CHECK ARGS
+ PUSHJ P,@RESTBL(E) ; DO IT BASED ON TYPE
+ MOVE C,A ; THE FOLLOWING IS TO MAKE STORAGE WORK
+ GETYP A,(AB)
+ PUSHJ P,SAT
+ CAIN A,SSTORE ; SKIP IF NOT STORAGE
+ MOVSI C,TSTORA ; USE ITS PRIMTYPE
+ MOVE A,C
+ JRST FINIS
+
+PRDISP RESTBL,IWTYP1,[[P2WORD,LREST],[PNWORD,UREST],[P2NWOR,VREST],[PARGS,AREST]
+[PCHSTR,SREST],[PTMPLT,TMPRST],[PBYTE,BREST]]
+
+; AT
+
+MFUNCTION AT,SUBR
+
+ ENTRY
+ PUSHJ P,ARGS1
+ SOJL C,OUTRNG
+ PUSHJ P,@ATTBL(E)
+ JRST FINIS
+
+PRDISP ATTBL,IWTYP1,[[P2WORD,LAT],[PNWORD,UAT],[P2NWORD,VAT],[PARGS,AAT]
+[PCHSTR,STAT],[PTMPLT,TAT],[PBYTE,BTAT]]
+
+\f
+; NTH
+
+MFUNCTION NTH,SUBR
+
+ ENTRY
+
+ PUSHJ P,ARGS1
+ SOJL C,OUTRNG
+ PUSHJ P,@NTHTBL(E)
+ JRST FINIS
+
+PRDISP NTHTBL,IWTYP1,[[P2WORD,LNTH],[PNWORD,UNTH],[P2NWOR,VNTH],[PARGS,ANTH]
+[PCHSTR,SNTH],[PTMPLT,TMPLNT],[PBYTE,BNTH]]
+
+; GET
+
+MFUNCTION GET,SUBR
+
+ ENTRY
+ MOVE E,IIGETP ; MAKE ARG CHECKER FAIL INTO GETPROP
+ PUSHJ P,ARGS5 ; CHECK ARGS
+ SOJL C,OUTRNG
+ SKIPN E,IGETBL(E) ; GET DISPATCH ADR
+ JRST IGETP ; REALLY PUTPROP
+ JUMPE 0,TMA
+ PUSHJ P,(E) ; DISPATCH
+ JRST FINIS
+
+PRDISP IGETBL,0,[[P2WORD,LNTH],[PNWORD,UNTH],[P2NWORD,VNTH],[PARGS,ANTH]
+[PCHSTR,SNTH],[PTMPLT,TMPLNT],[PBYTE,BNTH]]
+
+; GETL
+
+MFUNCTION GETL,SUBR
+
+ ENTRY
+ MOVE E,IIGETL ; ERROR HACK
+ PUSHJ P,ARGS5
+ SOJL C,OUTRNG ; LOSER
+ SKIPN E,IGTLTB(E)
+ JRST IGETLO ; REALLY GETPL
+ JUMPE 0,TMA
+ PUSHJ P,(E) ; DISPATCH
+ JRST FINIS
+
+IIGETL: JRST IGETLO
+
+PRDISP IGTLTB,0,[[P2WORD,LAT],[PNWORD,UAT],[P2NWORD,VAT],[PARGS,AAT]
+[PCHSTR,STAT],[PBYTE,BTAT]]
+
+
+; ARG CHECKER FOR PUT/GET/GETL
+
+ARGS5: HLRE 0,AB ; -# OF ARGS
+ ASH 0,-1
+ ADDI 0,2 ; 0 OR -1 WIN
+ JUMPG 0,TFA
+ AOJL 0,TMA ; MORE THAN 3
+ JRST ARGS3 ; GET ARGS
+\f
+; PUT
+
+MFUNCTION PUT,SUBR
+
+ ENTRY
+ MOVE E,IIPUTP
+ PUSHJ P,ARGS5 ; GET ARGS
+ SKIPN E,IPUTBL(E)
+ JRST IPUTP
+ CAML AB,[-5,,] ; SKIP IF GOOD ARRGS
+ JRST TFA
+ SOJL C,OUTRNG
+ PUSH TP,4(AB)
+ PUSH TP,5(AB)
+ PUSHJ P,(E)
+ MOVE A,(AB) ; RET STRUCTURE
+ MOVE B,1(AB)
+ JRST FINIS
+
+PRDISP IPUTBL,0,[[P2WORD,LPUT],[PNWORD,UPUT],[P2NWORD,VPUT],[PARGS,APUT]
+[PCHSTR,SPUT],[PTMPLT,TMPPUT],[PBYTE,BPUT]]
+
+; IN
+
+MFUNCTION IN,SUBR
+
+ ENTRY 1
+
+ MOVEI B,(AB) ; POINT TO ARG
+ PUSHJ P,PTYPE
+ MOVS E,A ; REAL DISPATCH TO E
+ MOVE B,1(AB)
+ MOVE A,(AB)
+ GETYP C,A ; IN CASE NEEDED
+ PUSHJ P,@INTBL(E)
+ JRST FINIS
+
+PRDISP INTBL,OTHIN,[[P2WORD,LNTH1],[PNWORD,UIN],[P2NWORD,VIN],[PARGS,AIN]
+[PCHSTR,SIN],[PTMPLT,TIN],[PBYTE,BINN]]
+
+OTHIN: CAIE C,TLOCN ; ASSOCIATION LOCATIVE
+ JRST OTHIN1 ; MAYBE LOCD
+ HLLZ 0,VAL(B)
+ PUSHJ P,RMONCH
+ MOVE A,VAL(B)
+ MOVE B,VAL+1(B)
+ POPJ P,
+
+OTHIN1: CAIN C,TLOCD
+ JRST VIN
+ JRST WTYP1
+
+\f
+; SETLOC
+
+MFUNCTION SETLOC,SUBR
+
+ ENTRY 2
+
+ MOVEI B,(AB) ; POINT TO ARG
+ PUSHJ P,PTYPE ; DO TYPE
+ MOVS E,A ; REAL TYPE
+ MOVE B,1(AB)
+ MOVE C,2(AB) ; PASS ARG
+ MOVE D,3(AB)
+ MOVE A,(AB) ; IN CASE
+ GETYP 0,A
+ PUSHJ P,@SETTBL(E)
+ MOVE A,2(AB)
+ MOVE B,3(AB)
+ JRST FINIS
+
+PRDISP SETTBL,OTHSET,[[P2WORD,LSTUF],[PNWORD,USTUF],[P2NWORD,VSTUF],[PARGS,ASTUF]
+[PCHSTR,SSTUF],[PTMPLT,TSTUF],[PBYTE,BSTUF]]
+
+OTHSET: CAIE 0,TLOCN ; ASSOC?
+ JRST OTHSE1
+ HLLZ 0,VAL(B) ; GET MONITORS
+ PUSHJ P,MONCH
+ MOVEM C,VAL(B)
+ MOVEM D,VAL+1(B)
+ POPJ P,
+
+OTHSE1: CAIE 0,TLOCD
+ JRST WTYP1
+ JRST VSTUF
+
+; LREST -- REST A LIST IN B BY AMOUNT IN C
+
+LREST: MOVSI A,TLIST
+ JUMPE C,CPOPJ
+ MOVE PVP,PVSTOR+1
+ MOVEM A,BSTO(PVP)
+
+LREST2: INTGO ;CHECK INTERRUPTS
+ JUMPE B,OUTRNG ; CANT CDR NIL
+ HRRZ B,(B) ;CDR THE LIST
+ SOJG C,LREST2 ;COUNT DOWN
+ MOVE PVP,PVSTOR+1
+ SETZM BSTO(PVP) ;RESET BSTO
+ POPJ P,
+
+\f
+; VREST -- REST A VECTOR, AREST -- REST AN ARG BLOCK
+
+VREST: SKIPA A,$TVEC ; FINAL TYPE
+AREST: HRLI A,TARGS
+ ASH C,1 ; TIMES 2
+ JRST UREST1
+
+; UREST -- REST A UVECTOR
+
+STORST: SKIPA A,$TSTORA
+UREST: MOVSI A,TUVEC
+UREST1: JUMPE C,CPOPJ
+ HRLI C,(C)
+ JUMPL C,OUTRNG
+ ADD B,C ; REST IT
+ CAILE B,-1 ; OUT OF RANGE ?
+ JRST OUTRNG
+ POPJ P,
+
+
+; SREST -- REST A STRING
+
+BREST: SKIPA D,[TBYTE]
+
+SREST: MOVEI D,TCHSTR
+ PUSH P,D
+ JUMPE C,SREST1
+ PUSH P,A ; SAVE TYPE WORD
+ PUSH P,C ; SAVE AMOUNT
+ MOVEI D,(A) ; GET LENGTH
+ CAILE C,(D) ; SKIP IF OK
+ JRST OUTRNG
+ LDB D,[366000,,B] ;POSITION FIELD OF BYTE POINTER
+ LDB A,[300600,,B] ;SIZE FIELD
+ PUSH P,A ;SAVE SIZE
+ IDIVI D,(A) ;COMPUT BYTES IN 1ST WORD
+ MOVEI 0,36. ;NOW COMPUTE BYTES PER WORD
+ IDIVI 0,(A) ;BYTES PER WORD IN 0
+ MOVE E,0 ;COPY OF BYTES PER WORD TO E
+ SUBI 0,(D) ;0 # OF UNSUED BYTES IN 1ST WORD
+ ADDB C,0 ;C AND 0 NO.OF CHARS FROM WORD BOUNDARY
+ IDIVI C,(E) ;C/ REL WORD D/ CHAR IN LAST
+ ADDI C,(B) ;POINTO WORD WITH C
+ POP P,A ;RESTORE BITS PER BYTE
+ JUMPN D,.+3 ; JUMP IF NOT WD BOUNDARY
+ MOVEI D,(E) ; USE FULL AMOUNT
+ SUBI C,1 ; POINT TO PREV WORD
+ IMULI A,(D) ;A/ BITS USED IN LAST WORD
+ MOVEI 0,36.
+ SUBI 0,(A) ;0 HAS NEW POSITION FIELD
+ DPB 0,[360600,,B] ;INTO BYTE POINTER
+ HRRI B,(C) ;POINT TO RIGHT WORD
+ POP P,C ; RESTORE AMOUNT
+ POP P,A
+ SUBI A,(C) ; NEW LENGTH
+SREST1: POP P,0
+ HRL A,0
+ POPJ P,
+
+; TMPRST -- REST A TEMPLATE DATA STRUCTURE
+
+TMPRST: PUSHJ P,TM.TOE ; CHECK ALL BOUNDS ETC.
+ MOVSI D,(D)
+ HLL C,D
+ MOVE B,C ; RET IN B
+ MOVSI A,TTMPLT
+ POPJ P,
+
+; LAT -- GET A LOCATIVE TO A LIST
+
+LAT: PUSHJ P,LREST ; GET POINTER
+ JUMPE B,OUTRNG ; YOU LOSE!
+ MOVSI A,TLOCL ; NEW TYPE
+ POPJ P,
+
+\f
+; UAT -- GET A LOCATIVE TO A UVECTOR
+
+UAT: PUSHJ P,UREST
+ MOVSI A,TLOCU
+ JRST POPJL
+
+; VAT -- GET A LOCATIVE TO A VECTOR
+
+VAT: PUSHJ P,VREST ; REST IT AND TYPE IT
+ MOVSI A,TLOCV
+ JRST POPJL
+
+; AAT -- GET A LOCATIVE TO AN ARGS BLOCK
+
+AAT: PUSHJ P,AREST
+ HRLI A,TLOCA
+POPJL: JUMPGE B,OUTRNG ; LOST
+ POPJ P,
+
+; STAT -- LOCATIVE TO A STRING
+
+STAT: PUSHJ P,SREST
+ TRNN A,-1 ; SKIP IF ANY LEFT
+ JRST OUTRNG
+ HRLI A,TLOCS ; LOCATIVE
+ POPJ P,
+
+; BTAT -- LOCATIVE TO A BYTE-STRING
+
+BTAT: PUSHJ P,BREST
+ TRNN A,-1 ; SKIP IF ANY LEFT
+ JRST OUTRNG
+ HRLI A,TLOCB ; LOCATIVE
+ POPJ P,
+
+; TAT -- LOCATIVE TO A TEMPLATE
+
+TAT: PUSHJ P,TMPRST
+ PUSH TP,A
+ PUSH TP,B
+ GETYP A,(B) ; GET REAL SAT
+ SUBI A,NUMSAT+1
+ HRLS A ; READY TO HIT TABLE
+ ADD A,TD.LNT+1
+ JUMPGE A,BADTPL
+ MOVE C,B ; DATUM TO C
+ XCT (A) ; GET LENGTH
+ HLRZS C ; REST COUNTER
+ SUBI B,(C) ; FLUSH IT OFF
+ JUMPE B,OUTRNG
+ MOVE B,(TP)
+ SUB TP,[2,,2]
+ MOVSI A,TLOCT
+ POPJ P,
+
+
+; LNTH -- NTH OF LIST
+
+LNTH: PUSHJ P,LAT
+LNTH1: PUSHJ P,RMONC0 ; CHECK READ MONITORS
+ HLLZ A,(B) ; GET GOODIE
+ MOVE B,1(B)
+ JSP E,CHKAB ; HACK DEFER
+ POPJ P,
+
+; VNTH -- NTH A VECTOR, ANTH -- NTH AN ARGS BLOCK
+
+ANTH: PUSHJ P,AAT
+ JRST .+2
+
+VNTH: PUSHJ P,VAT
+AIN:
+VIN: PUSHJ P,RMONC0
+ MOVE A,(B)
+ MOVE B,1(B)
+ POPJ P,
+
+; UNTH -- NTH OF UVECTOR
+
+UNTH: PUSHJ P,UAT
+UIN: HLRE C,B ; FIND DW
+ SUBM B,C
+ HLLZ 0,(C) ; GET MONITORS
+ MOVE D,0
+ TLZ D,TYPMSK#<-1>
+ PUSH P,D
+ PUSHJ P,RMONCH ; CHECK EM
+ POP P,A
+ MOVE B,(B) ; AND VALUE
+ POPJ P,
+
+\f
+; BNTH -- NTH A BYTE STRING
+
+BNTH: PUSHJ P,BTAT
+BINN: PUSH P,$TFIX
+ JRST SIN1
+
+; SNTH -- NTH A STRING
+
+SNTH: PUSHJ P,STAT
+SIN: PUSH P,$TCHRS
+SIN1: PUSH TP,A
+ PUSH TP,B ; SAVE POINT BYTER
+ MOVEI C,-1(TP) ; FIND DOPE WORD
+ PUSHJ P,BYTDOP
+ HLLZ 0,-1(A) ; GET
+ POP TP,B
+ POP TP,A
+ PUSHJ P,RMONCH
+ ILDB B,B ; GET CHAR
+ POP P,A
+ POPJ P,
+
+; TIN -- IN OF A TEMPLATE
+
+TIN: MOVEI C,0
+
+; TMPLNT -- NTH A TEMPLATE DATA STRUCTURE
+
+TMPLNT: ADDI C,1
+ PUSHJ P,TM.TOE ; GET POINTER TO INS IN E
+ ADD A,TD.GET+1 ; POINT TO GETTER
+ MOVE A,(A) ; GET VECTOR OF INS
+ ADDI E,-1(A) ; POINT TO INS
+ SUBI D,1
+ XCT (E) ; DO IT
+ JFCL ; SKIP IF AN ANY CASE
+ POPJ P, ; RETURN
+
+; LPUT -- PUT ON A LIST
+
+LPUT: PUSHJ P,LAT ; POSITION
+ POP TP,D
+ POP TP,C
+
+; LSTUF -- HERE TO STUFF A LIST ELEMENT
+
+LSTUF: PUSHJ P,MONCH0 ; CHECK OUT MONITOR BITS
+ GETYP A,C ; ISOLATE TYPE
+ PUSHJ P,NWORDT ; NEED TO DEFER?
+ SOJN A,DEFSTU
+ HLLM C,(B)
+ MOVEM D,1(B) ; AND VAL
+ POPJ P,
+
+DEFSTU: PUSH TP,$TLIST
+ PUSH TP,B
+ PUSH TP,C
+ PUSH TP,D
+ PUSHJ P,CELL2 ; GET WORDS
+ POP TP,1(B)
+ POP TP,(B)
+ MOVE E,(TP)
+ SUB TP,[2,,2]
+ MOVEM B,1(E)
+ HLLZ 0,(E) ; GET OLD MONITORS
+ TLZ 0,TYPMSK ; KILL TYPES
+ TLO 0,TDEFER ; MAKE DEFERRED
+ HLLM 0,(E)
+ POPJ P,
+
+; VPUT -- PUT ON A VECTOR , APUT -- PUT ON AN RG BLOCK
+
+APUT: PUSHJ P,AAT
+ JRST .+2
+
+VPUT: PUSHJ P,VAT ; TREAT LIKE VECTOR
+ POP TP,D ; GET GOODIE BACK
+ POP TP,C
+
+; AVSTUF -- CLOBBER ARGS AND VECTORS
+
+ASTUF:
+VSTUF: PUSHJ P,MONCH0
+ MOVEM C,(B)
+ MOVEM D,1(B)
+ POPJ P,
+
+\f
+
+
+; UPUT -- CLOBBER A UVECTOR
+
+UPUT: PUSHJ P,UAT ; GET IT RESTED
+ POP TP,D
+ POP TP,C
+
+; USTUF -- HERE TO CLOBBER A UVECTOR
+
+USTUF: HLRE E,B
+ SUBM B,E ; C POINTS TO DOPE
+ GETYP A,(E) ; GET UTYPE
+ GETYP 0,C
+ CAIE 0,(A) ; CHECK SAMENESS
+ JRST WRNGUT
+ HLLZ 0,(E) ; MONITOR BITS IN DOPE WORD
+ MOVSI A,TLOCU ; CHOMP, CHOMP (WAS TUVEC) -- MARC 5/2/78
+ PUSHJ P,MONCH
+ MOVEM D,(B) ; SMASH
+ POPJ P,
+
+; BPUT -- HERE TO PUT A BYTE-STRING
+
+BPUT: PUSHJ P,BTAT
+ POP TP,D
+ POP TP,C
+BSTUF: MOVEI E,TFIX
+ JRST SSTUF1
+
+; SPUT -- HERE TO PUT A STRING
+
+SPUT: PUSHJ P,STAT ; REST IT
+ POP TP,D
+ POP TP,C
+
+; SSTUF -- STUFF A STRING
+
+SSTUF: MOVEI E,TCHRS
+SSTUF1: GETYP 0,C ; BETTER BE CHAR
+ CAIE 0,(E)
+ JRST WTYP3
+ PUSH P,C
+ PUSH TP,A
+ PUSH TP,B
+ MOVEI C,-1(TP) ; FIND D.W.
+ PUSHJ P,BYTDOP
+ SKIPGE (A)-1 ; SKIP IF NOT REALLY ATOM
+ JRST PNMNG
+ HLLZ 0,(A)-1 ; GET MONITORS
+ POP TP,B
+ POP TP,A
+ POP P,C
+ PUSHJ P,MONCH
+ IDPB D,B ; STASH
+ POPJ P,
+
+PNMNG: POP TP,B
+ POP TP,A
+ PUSH TP,$TATOM
+ PUSH TP,EQUOTE ATTEMPT-TO-MUNG-ATOMS-PNAME
+ HRLI A,TCHSTR
+ PUSH TP,A
+ PUSH TP,B
+ MOVEI A,2
+ JRST CALER
+
+; TSTUF -- SETLOC A TEMPLATE
+
+TSTUF: PUSH TP,C
+ PUSH TP,D
+ MOVEI C,0
+
+; PUTTMP -- TEMPLATE PUTTER
+
+TMPPUT: ADDI C,1
+ PUSHJ P,TM.TOE ; GET E POINTING TO SLOT #
+ ADD A,TD.PUT+1 ; POINT TO INS
+ MOVE A,(A) ; GET VECTOR OF INS
+ ADDI E,-1(A)
+ POP TP,B ; NEW VAL TO A AND B
+ POP TP,A
+ SUBI D,1
+ XCT (E) ; DO IT
+ JRST BADPUT
+ POPJ P,
+
+TM.LN1: SUBI 0,NUMSAT+1
+ HRRZ A,0 ; RET FIXED OFFSET
+ HRLS 0
+ ADD 0,TD.LNT+1 ; USE LENGTHERS FOR TEST
+ JUMPGE 0,BADTPL
+ PUSH P,C
+ MOVE C,B
+ HRRZS 0 ; POINT TO TABLE ENTRY
+ PUSH P,A
+ XCT @0 ; DO IT
+ POP P,A
+ POP P,C
+ POPJ P,
+
+TM.TBL: MOVEI E,(D) ; TENTATIVE WINNER IN E
+ TLNN B,-1 ; SKIP IF REST HAIR EXISTS
+ POPJ P, ; NO, WIN
+
+ PUSH P,A ; SAVE OFFSET
+ HRLS A ; A IS REL OFFSET TO INS TABLE
+ ADD A,TD.GET+1 ; GET ONEOF THE TABLES
+ MOVE A,(A) ; TABLE POINTER TO A
+ MOVSI 0,-1(D) ; START SEEING IF PAST TEMP SPEC
+ ADD 0,A
+ JUMPL 0,CPOPJA ; JUMP IF E STILL VALID
+ HLRZ E,B ; BASIC LENGTH TO E
+ HLRE 0,A ; LENGTH OF TEMPLATE TO 0
+ ADDI 0,(E) ; 0 ==> # ELEMENTS IN REPEATING SEQUENCE
+ MOVNS 0
+ SUBM D,E ; E ==> # PAST BASIC WANTED
+ EXCH 0,E
+ IDIVI 0,(E) ; A ==> REL REST GUY WANTED
+ HLRZ E,B
+ ADDI E,1(A)
+CPOPJA: POP P,A
+ POPJ P,
+
+; TM.TOE -- GET RIGHT TEMPLATE # IN E
+; C/ OBJECT #, B/ OBJECT POINTER
+
+TM.TOE: GETYP 0,(B) ; GET REAL SAT
+ MOVEI D,(C) ; OBJ # TO D
+ HLRZ C,B ; REST COUNT
+ ADDI D,(C) ; FUDGE FOR REST COUNTER
+ MOVE C,B ; POINTER TO C
+ PUSHJ P,TM.LN1 ; GET LENGTH IN B (WATCH LH!)
+ CAILE D,(B) ; CHECK RANGE
+ JRST OUTRNG ; LOSER, QUIT
+ JRST TM.TBL ; GO COMPUTE TABLE OFFSET
+
+\f; ROUTINE FOR COMPILER CALLS RETS CODE IN E GOODIE IN A AND B
+; FIXES (P)
+
+CPTYEE: MOVE E,A
+ GETYP A,A
+ PUSHJ P,CPTYPE
+ JUMPE A,WTYPUN
+ SUBM M,-1(P)
+ EXCH E,A
+ POPJ P,
+
+; COMPILER CALLS TO MANY OF THESE GUYS
+
+CIREST: PUSHJ P,CPTYEE ; TYPE OF DISP TO E
+ HRRES C ; CLEAR LH, IN CASE IT'S AN OFFSET
+ JUMPL C,OUTRNG
+ CAIN 0,SSTORE
+ JRST CIRST1
+ PUSHJ P,@RESTBL(E)
+ JRST MPOPJ
+
+CIRST1: PUSHJ P,STORST
+ JRST MPOPJ
+
+CINTH: PUSHJ P,CPTYEE
+ HRRES C ; CLEAR LH
+ SOJL C,OUTRNG ; CHECK BOUNDS
+ PUSHJ P,@NTHTBL(E)
+ JRST MPOPJ
+
+CIAT: PUSHJ P,CPTYEE
+ SOJL C,OUTRNG
+ PUSHJ P,@ATTBL(E)
+ JRST MPOPJ
+
+CSETLO: PUSHJ P,CTYLOC
+ MOVSS E ; REAL DISPATCH
+ GETYP 0,A ; INCASE LOCAS OR LOCD
+ PUSH TP,C
+ PUSH TP,D
+ PUSHJ P,@SETTBL(E)
+ POP TP,B
+ POP TP,A
+ JRST MPOPJ
+
+CIN: PUSHJ P,CTYLOC
+ MOVSS E ; REAL DISPATCH
+ GETYP C,A
+ PUSHJ P,@INTBL(E)
+ JRST MPOPJ
+
+CTYLOC: MOVE E,A
+ GETYP A,A
+ PUSHJ P,CPTYPE
+ SUBM M,-1(P)
+ EXCH A,E
+ POPJ P,
+
+; COMPILER'S PUT,GET AND GETL
+
+CIGET: PUSH P,[0]
+ JRST .+2
+
+CIGETL: PUSH P,[1]
+ MOVE E,A
+ GETYP A,A
+ PUSHJ P,CPTYPE
+ EXCH A,E
+ JUMPE E,CIGET1 ; REAL GET, NOT NTH
+ GETYP 0,C ; INDIC FIX?
+ CAIE 0,TFIX
+ CAIN 0,TOFFS
+ JRST .+2
+ JRST CIGET1
+ POP P,E ; GET FLAG
+ AOS (P) ; ALWAYS SKIP
+ MOVE C,D ; # TO AN AC
+ JRST @.+1(E)
+ SETZ CINTH
+ SETZ CIAT
+
+CIGET1: POP P,E ; GET FLAG
+ JRST @GETTR(E) ; DO A REAL GET
+
+GETTR: SETZ CIGTPR
+ SETZ CIGETP
+
+CIPUT: SUBM M,(P)
+ MOVE E,A
+ GETYP A,A
+ PUSHJ P,CPTYPE
+ EXCH A,E
+ PUSH TP,-1(TP) ; PAIN AND SUFFERING
+ PUSH TP,-1(TP)
+ MOVEM A,-3(TP)
+ MOVEM B,-2(TP)
+ JUMPE E,CIPUT1
+ GETYP 0,C
+ CAIE 0,TFIX ; YES DO STRUCT
+ CAIN 0,TOFFS
+ JRST .+2
+ JRST CIPUT1
+ MOVE C,D
+ HRRES C
+ SOJL C,OUTRNG ; CHECK BOUNDS
+ PUSHJ P,@IPUTBL(E)
+PMPOPJ: POP TP,B
+ POP TP,A
+ JRST MPOPJ
+
+CIPUT1: PUSHJ P,IPUT
+ JRST PMPOPJ
+\f
+; SMON -- SET MONITOR BITS
+; B/ <POINTER TO LOCATIVE>
+; D/ <IORM> OR <ANDCAM>
+; E/ BITS
+
+SMON: GETYP A,(B)
+ PUSHJ P,PTYPE ; TO PRIM TYPE
+ HLRZS A
+ SKIPE A,SMONTB(A) ; DISPATCH?
+ JRST (A)
+
+; COULD STILL BE LOCN OR LOCD
+
+ GETYP A,(B) ; TYPE BACK
+ CAIE A,TLOCN
+ JRST SMON2 ; COULD BE LOCD
+ MOVE C,1(B) ; POINT
+ HRRI D,VAL(C) ; MAKE INST POINT
+ JRST SMON3
+
+SMON2: CAIE A,TLOCD
+ JRST WRONGT
+
+
+; SET LIST/TUPLE/ID LOCATIVE
+
+SMON4: HRR D,1(B) ; POINT TO TYPE WORD
+SMON3: XCT D
+ POPJ P,
+
+; SET UVEC LOC
+
+SMON5: HRRZ C,1(B) ; POINT TO TOP OF UV
+ HLRE 0,1(B)
+ SUB C,0 ; POINT TO DOPE
+ HRRI D,(C) ; POINT IN INST
+ JRST SMON3
+
+; SET CHSTR LOC
+
+SMON6: MOVEI C,(B) ; FOR BYTDOP
+ PUSHJ P,BYTDOP ; POINT TO DOPE
+ HRRI D,(A)-1
+ JRST SMON3
+
+PRDISP SMONTB,0,[[P2WORD,SMON4],[P2NWOR,SMON4],[PARGS,SMON4]
+[PNWORD,SMON5],[PCHSTR,SMON6],[PBYTE,SMON6]]
+
+\f
+; COMPILER'S MONAD?
+
+CIMON: PUSH P,A
+ GETYP A,A
+ PUSHJ P,CPTYPE
+ JUMPE A,CIMON1
+ POP P,A
+ JRST CEMPTY
+
+CIMON1: POP P,A
+ JRST YES
+
+; FUNCTION TO DECIDE IF FURTHER DECOMPOSITION POSSIBLE
+
+MFUNCTION MONAD,SUBR,MONAD?
+
+ ENTRY 1
+
+ MOVE B,AB ; CHECK PRIM TYPE
+ PUSHJ P,PTYPE
+ JUMPE A,ITRUTH ;RETURN ARGUMENT
+ SKIPE B,1(AB)
+ JRST @MONTBL(A) ;DISPATCH ON PTYPE
+ JRST ITRUTH
+
+PRDISP MONTBL,IFALSE,[[P2NWORD,MON1],[PNWORD,MON1],[PARGS,MON1]
+[PCHSTR,CHMON],[PTMPLT,TMPMON],[PBYTE,CHMON]]
+
+MON1: JUMPGE B,ITRUTH ;EMPTY VECTOR
+ JRST IFALSE
+
+CHMON: HRRZ B,(AB)
+ JUMPE B,ITRUTH
+ JRST IFALSE
+
+TMPMON: PUSHJ P,LNTMPL
+ JUMPE B,ITRUTH
+ JRST IFALSE
+
+CISTRU: GETYP A,A ; COMPILER CALL
+ PUSHJ P,ISTRUC
+ JRST NO
+ JRST YES
+
+ISTRUC: PUSHJ P,SAT ; STORAGE TYPE
+ SKIPE A,PRMTYP(A)
+ AOS (P) ; SKIP IF WINS
+ POPJ P,
+
+; SUBR TO CHECK FOR LOCATIVE
+
+MFUNCTION %LOCA,SUBR,[LOCATIVE?]
+
+ ENTRY 1
+ GETYP A,(AB)
+ PUSHJ P,LOCQQ
+ JRST IFALSE
+ JRST ITRUTH
+
+; SKIPS IF TYPE IN A IS A LOCATIVE
+
+LOCQ: GETYP A,(B) ; GET TYPE
+LOCQQ: PUSH P,A ; SAVE FOR LOCN/LOCD
+ PUSHJ P,SAT
+ MOVE A,PRMTYP(A)
+ JUMPE A,LOCQ1
+ SUB P,[1,,1]
+ TRNN A,-1
+LOCQ2: AOS (P)
+ POPJ P,
+
+LOCQ1: POP P,A ; RESTORE TYPE
+ CAIE A,TLOCN
+ CAIN A,TLOCD
+ JRST LOCQ2
+ POPJ P,
+
+\f
+; FUNCTION TO DETERMINE MEMBERSHIP IN LISTS AND VECTORS
+
+MFUNCTION MEMBER,SUBR
+
+ MOVE E,[PUSHJ P,EQLTST] ;TEST ROUTINE IN E
+ JRST MEMB
+
+MFUNCTION MEMQ,SUBR
+
+ MOVE E,[PUSHJ P,EQTST] ;EQ TESTER
+
+MEMB: ENTRY 2
+ MOVE B,AB ;POINT TO FIRST ARG
+ PUSHJ P,PTYPE ;CHECK PRIM TYPE
+ ADD B,[2,,2] ;POINT TO 2ND ARG
+ PUSHJ P,PTYPE
+ JUMPE A,WTYP2 ;2ND WRONG TYPE
+ PUSH TP,(AB)
+ PUSH TP,1(AB)
+ MOVE C,2(AB) ; FOR TUPLE CASE
+ SKIPE B,3(AB) ;GOBBLE LIST VECTOR ETC. POINTER
+ PUSHJ P,@MEMTBL(A) ;DISPATCH
+ JRST IFALSE ;OR REPORT LOSSAGE
+ JRST FINIS
+
+PRDISP MEMTBL,IWTYP2,[[P2WORD,MEMLST],[PNWORD,MUVEC],[P2NWORD,MEMVEC]
+[PARGS,MEMTUP],[PCHSTR,MEMCH],[PTMPLT,MEMTMP],[PBYTE,MEMBYT]]
+
+
+
+MEMLST: MOVSI 0,TLIST ;SET B'S TYPE TO LIST
+ MOVE PVP,PVSTOR+1
+ MOVEM 0,BSTO(PVP)
+ JUMPE B,MEMLS6 ; EMPTY LIST LOSE IMMEDIATE
+
+MEMLS1: INTGO ;CHECK INTERRUPTS
+ MOVEI C,(B) ;COPY POINTER
+ GETYP D,(C) ;GET TYPE
+ MOVSI A,(D) ;COPY
+ CAIE D,TDEFER ;DEFERRED?
+ JRST MEMLS2
+ MOVE C,1(C) ;GET DEFERRED DATUM
+ GETYPF A,(C) ;GET FULL TYPE WORD
+MEMLS2: MOVE C,1(C) ;GET DATUM
+ XCT E ;DO THE COMPARISON
+ JRST MEMLS3 ;NO MATCH
+ MOVSI A,TLIST
+MEMLS5: AOS (P)
+MEMLS6: MOVE PVP,PVSTOR+1
+ SETZM BSTO(PVP) ;RESET B'S TYPE
+ POPJ P,
+
+MEMLS3: HRRZ B,(B) ;STEP THROGH
+ JUMPN B,MEMLS1 ;STILL MORE TO DO
+MEMLS4: MOVSI A,TFALSE ;RETURN FALSE
+ JRST MEMLS6 ;RETURN 0
+
+MEMTUP: HRRZ A,C
+ TLOA A,TARGS
+MEMVEC: MOVSI A,TVEC ;CLOBBER B'S TYPE TO VECTOR
+ JUMPGE B,MEMLS4 ;EMPTY VECTOR
+ MOVE PVP,PVSTOR+1
+ MOVEM A,BSTO(PVP)
+
+MEMV1: INTGO ;CHECK FOR INTS
+ GETYPF A,(B) ;GET FULL TYPE
+ MOVE C,1(B) ;AND DATA
+ XCT E ;DO COMPARISON INS
+ JRST MEMV2 ;NOT EQUAL
+ MOVE PVP,PVSTOR+1
+ MOVE A,BSTO(PVP)
+ JRST MEMLS5 ;RETURN WITH POINTER
+\f
+MEMV2: ADD B,[2,,2] ;INCREMENT AND GO
+ JUMPL B,MEMV1 ;STILL WINNING
+MEMV3: MOVEI B,0
+ JRST MEMLS4 ;AND RETURN FALSE
+
+MUVEC: JUMPGE B,MEMLS4
+ GETYP A,-1(TP) ;GET TYPE OF GODIE
+ HLRE C,B ;LOOK FOR UNIFORM TYPE
+ SUBM B,C ;DOPE POINTER TO C
+ GETYP C,(C) ;GET THE TYPE
+ CAIE A,(C) ;ARE THEY THE SAME?
+ JRST MEMLS4 ;NO, LOSE
+ MOVSI A,TUVEC
+ CAIN 0,SSTORE
+ MOVSI A,TSTORA
+ PUSH P,A
+ MOVE PVP,PVSTOR+1
+ MOVEM A,BSTO(PVP)
+ MOVSI A,(C) ;TYPE TO LH
+ PUSH P,A ; SAVE FOR EACH TEST
+
+MUVEC1: INTGO ;CHECK OUT INTS
+ MOVE C,(B) ;GET DATUM
+ MOVE A,(P) ; GET TYPE
+ XCT E ;COMPARE
+ AOBJN B,MUVEC1 ;LOOP TO WINNAGE
+ SUB P,[1,,1]
+ POP P,A
+ JUMPGE B,MEMV3 ;LOSE RETURN
+
+MUVEC2: JRST MEMLS5
+
+
+MEMBYT: MOVEI 0,TFIX
+ MOVEI D,TBYTE
+ JRST MEMBY1
+
+MEMCH: MOVEI 0,TCHRS
+ MOVEI D,TCHSTR
+MEMBY1: GETYP A,-1(TP) ;IS ARG A SINGLE CHAR
+ CAIE 0,(A) ;SKIP IF POSSIBLE WINNER
+ JRST MEMSTR
+ MOVEI 0,(C)
+ MOVE D,(TP) ; AND CHAR
+
+MEMCH1: SOJL 0,MEMV3
+ MOVE E,B
+ ILDB A,B
+ CAIE A,(D) ;CHECK IT
+ SOJA C,MEMCH1
+
+MEMCH2: MOVE B,E
+ MOVE A,C
+ JRST MEMLS5
+
+MEMSTR: CAIN A,(D)
+ CAME E,[PUSHJ P,EQLTST]
+ JRST MEMV3
+ LDB A,[300600,,(TP)]
+ LDB 0,[300600,,B]
+ CAIE 0,(A)
+ JRST MEMV3
+ MOVEI 0,(C) ; GET # OF CHAR INTO 0
+ ILDB D,(TP)
+ PUSH P,D ; PUTS 1ST CHAR OF 1ST ARG ONTO STACK
+
+MEMST1: SOJL 0,MEMLS ; HUNTS FOR FIRST MATCHING CHAR
+ MOVE E,B
+ ILDB A,B
+ CAME A,(P)
+ SOJA C,MEMST1 ; MATCH FAILS TRY NEXT
+
+ PUSH P,B
+ PUSH P,E
+ PUSH P,C
+ PUSH P,0
+ MOVE E,(TP) ; MATCH WINS SAVE OLD VALUES FOR FAILING LOOP
+ HRRZ C,-1(TP) ; LENGTH OF 1ARG
+MEMST2: SOJE C,MEMWN ; WON -RAN OUT OF 1ARG FIRST-
+ SOJL MEMLSR ; LOST -RAN OUT OF 2ARG-
+ ILDB A,B
+ ILDB D,E
+ CAIN A,(D) ; SKP IF POSSIBLY LOST -BACK TO MEMST1-
+ JRST MEMST2
+
+ POP P,0
+ POP P,C
+ POP P,E
+ POP P,B
+ SOJA C,MEMST1
+
+MEMWN: MOVE B,-2(P) ; SETS UP ARGS LIKE MEMCH2 - HAVE WON
+ MOVE A,-1(P)
+ SUB P,[5,,5]
+ JRST MEMLS5
+
+MEMLSR: SUB P,[5,,5]
+ JRST MEMV3
+
+MEMLS: SUB P,[1,,1]
+ JRST MEMV3
+
+; MEMBERSHIP FOR TEMPLATE HACKER
+
+MEMTMP: GETYP 0,(B) ; GET REAL SAT
+ PUSH P,E
+ PUSH P,0
+ PUSH TP,A
+ PUSH TP,B ; SAVE GOOEIE
+ PUSHJ P,TM.LN1 ; GET LENGTH
+ MOVEI B,(B)
+ HLRZ A,(TP) ; FUDGE FOR REST
+ SUBI B,(A)
+ PUSH P,B ; SAVE LENGTH
+ PUSH P,[-1]
+ POP TP,B
+ POP TP,A
+ MOVE PVP,PVSTOR+1
+ MOVEM B,BSTO+1(PVP)
+
+MEMTM1: MOVE PVP,PVSTOR+1
+ SETZM BSTO(PVP)
+ AOS C,(P)
+ SOSGE -1(P)
+ JRST MEMTM2
+ MOVE 0,-2(P)
+ PUSHJ P,TMPLNT ; GET ITEM
+ EXCH C,B ; VALUE TO C, POINTER BACK TO B
+ MOVE E,-3(P)
+ MOVSI 0,TTMPLT
+ MOVE PVP,PVSTOR+1
+ MOVEM 0,BSTO(PVP)
+ XCT E
+ SKIPA
+ JRST MEMTM3
+ MOVE PVP,PVSTOR+1
+ MOVE B,BSTO+1(PVP)
+ JRST MEMTM1
+
+MEMTM3: MOVE PVP,PVSTOR+1
+ MOVE B,BSTO+1(PVP)
+ HRL B,(P) ; DO APPROPRIATE REST
+ AOS -4(P)
+MEMTM2: SUB P,[4,,4]
+ MOVSI A,TTMPLT
+ MOVE PVP,PVSTOR+1
+ SETZM BSTO(PVP)
+ POPJ P,
+
+EQTST: GETYP A,A
+ GETYP 0,-1(TP)
+ CAMN C,(TP) ;CHECK VALUE
+ CAIE 0,(A) ;AND TYPE
+ POPJ P,
+ JRST CPOPJ1
+
+EQLTST: MOVE PVP,PVSTOR+1
+ PUSH TP,BSTO(PVP)
+ PUSH TP,B
+ PUSH TP,A
+ PUSH TP,C
+ SETZM BSTO(PVP)
+ PUSH P,E ;SAVE INS
+ MOVEI C,-5(TP) ;SET UP CALL TO IEQUAL
+ MOVEI D,-1(TP)
+ AOS -1(P) ;ASSUME SKIP
+ PUSHJ P,IEQUAL ;GO INO EQUAL
+ SOS -1(P) ;UNDO SKIP
+ SUB TP,[2,,2] ;AND POOP OF CRAP
+ POP TP,B
+ MOVE PVP,PVSTOR+1
+ POP TP,BSTO(PVP)
+ POP P,E
+ POPJ P,
+
+; COMPILER MEMQ AND MEMBER
+
+CIMEMB: SKIPA E,[PUSHJ P,EQLTST]
+
+CIMEMQ: MOVE E,[PUSHJ P,EQTST]
+ SUBM M,(P)
+ PUSH TP,A
+ PUSH TP,B
+ GETYP A,C
+ PUSHJ P,CPTYPE
+ JUMPE A,WTYPUN
+ MOVE B,D ; STRUCT TO B
+ PUSHJ P,@MEMTBL(A)
+ TDZA 0,0 ; FLAG NO SKIP
+ MOVEI 0,1 ; FLAG SKIP
+ SUB TP,[2,,2]
+ JUMPE 0,NOM
+ SOS (P) ; SKIP RETURN
+ JRST MPOPJ
+\f
+
+; FUNCTION TO RETURN THE TOP OF A VECTOR , CSTRING OR UNIFORM VECTOR
+
+MFUNCTION TOP,SUBR
+
+ ENTRY 1
+
+ MOVE B,AB ;CHECK ARG
+ PUSHJ P,PTYPE
+ MOVEI E,(A)
+ MOVE A,(AB)
+ MOVE B,1(AB)
+ PUSHJ P,@TOPTBL(E) ;DISPATCH
+ JRST FINIS
+
+PRDISP TOPTBL,IWTYP1,[[PNWORD,UVTOP],[P2NWORD,VTOP],[PCHSTR,CHTOP],[PARGS,ATOP]
+[PTMPLT,BCKTOP],[PBYTE,BTOP]]
+
+BCKTOP: MOVEI B,(B) ; FIX UP POINTER
+ MOVSI A,TTMPLT
+ POPJ P,
+
+UVTOP: SKIPA A,$TUVEC
+VTOP: MOVSI A,TVEC
+ CAIN 0,SSTORE
+ MOVSI A,TSTORA
+ JUMPE B,CPOPJ
+ HLRE C,B ;AND -LENGTH
+ HRRZS B
+ SUB B,C ;POINT TO DOPE WORD
+ HLRZ D,1(B) ;TOTAL LENGTH
+ SUBI B,-2(D) ;POINT TO TOP
+ MOVNI D,-2(D) ;-LENGTH
+ HRLI B,(D) ;B NOW POINTS TO TOP
+ POPJ P,
+
+BTOP: SKIPA E,$TBYTE
+CHTOP: MOVSI E,TCHSTR
+ JUMPE B,CPOPJ
+ PUSH P,E
+ PUSH TP,A
+ PUSH TP,B
+ LDB 0,[360600,,(TP)] ; POSITION FIELD
+ LDB E,[300600,,(TP)] ; AND SIZE FILED
+ IDIVI 0,(E) ; 0/ BYTES IN 1ST WORD
+ MOVEI C,36. ; BITS PER WORD
+ IDIVI C,(E) ; BYTES PER WORD
+ PUSH P,C
+ SUBM C,0 ; UNUSED BYTES I 1ST WORD
+ ADD 0,-1(TP) ; LENGTH OF WORD BOUNDARIED STRING
+ MOVEI C,-1(TP) ; GET DOPE WORD
+ PUSHJ P,BYTDOP
+ HLRZ C,(A) ; GET LENGTH
+ SKIPGE -1(A) ; SKIP IF NOT REALLY ATOM
+ SUBI C,3 ; IF IT IS, 3 LESS WORDS
+ SUBI A,-1(C) ; START +1
+ MOVEI B,-1(A) ; SETUP BYTER
+ SUB A,(TP) ; WORDS DIFFERENT
+ IMUL A,(P) ; CHARS EXTRA
+ SUBM 0,A ; FINAL TOTAL TO A
+ HLL A,-1(P)
+ MOVE C,(P)
+ SUB P,[2,,2]
+ DPB E,[300600,,B]
+ IMULI E,(C) ; BITS USED IN FULL WORD
+ MOVEI C,36.
+ SUBI C,(E) ; WHERE TO POINT IN EMPTY? CASE
+ DPB C,[360600,,B]
+ SUB TP,[2,,2]
+ POPJ P,
+\f
+
+
+ATOP:
+
+GETATO: HLRE C,B ;GET -LENGTH
+ HRROS B
+ SUB B,C ;POINT PAST
+ GETYP 0,(B) ;GET NEXT TYPE (ASSURED OF BEING EITHER TINFO OR TENTRY)
+ CAIN 0,TENTRY ;IF ENTRY
+ JRST EASYTP ;WANT UNEVALUATED ARGS
+ HRRE C,(B) ;ELSE-- GET NO. OF ARGS (*-2)
+ SUBI B,(C) ;GO TO TOP
+ TLCA B,-1(C) ;STORE NUMBER IN TOP POINTER
+EASYTP: MOVE B,FRAMLN+ABSAV(B) ;GET ARG POINTER
+ HRLI A,TARGS
+ POPJ P,
+
+; COMPILERS ENTRY TO TOP
+
+CITOP: PUSHJ P,CPTYEE
+ CAIN E,P2WORD ; LIST?
+ JRST WTYPL
+ PUSHJ P,@TOPTBL(E)
+ JRST MPOPJ
+
+; FUNCTION TO CLOBBER THE CDR OF A LIST
+
+MFUNCTION PUTREST,SUBR,[PUTREST]
+ ENTRY 2
+
+ MOVE B,AB ;COPY ARG POINTER
+ PUSHJ P,PTYPE ;CHECK IT
+ CAIE A,P2WORD ;LIST?
+ JRST WTYP1 ;NO, LOSE
+ ADD B,[2,,2] ;AND NEXT ONE
+ PUSHJ P,PTYPE
+ CAIE A,P2WORD
+ JRST WTYP2 ;NOT LIST, LOSE
+ HRRZ B,1(AB) ;GET FIRST
+ JUMPE B,OUTRNG
+ MOVE D,3(AB) ;AND 2D LIST
+ CAIL B,HIBOT
+ JRST PURERR
+ HRRM D,(B) ;CLOBBER
+ MOVE A,(AB) ;RETURN CALLED TYPE
+ JRST FINIS
+
+\f
+
+; FUNCTION TO BACK UP A VECTOR, UVECTOR OR CHAR STRING
+
+MFUNCTION BACK,SUBR
+
+ ENTRY
+
+ MOVEI C,1 ;ASSUME BACKING UP ONE
+ JUMPGE AB,TFA ;NO ARGS IS TOO FEW
+ CAML AB,[-2,,0] ;SKIP IF MORE THAN 2 ARGS
+ JRST BACK1 ;ONLY ONE ARG
+ GETYP A,2(AB) ;GET TYPE
+ CAIE A,TFIX ;MUST BE FIXED
+ JRST WTYP2
+ SKIPGE C,3(AB) ;GET NUMBER
+ JRST OUTRNG
+ CAMGE AB,[-4,,0] ;SKIP IF WINNING NUMBER OF ARGS
+ JRST TMA
+BACK1: MOVE B,AB ;SET UP TO FIND TYPE
+ PUSHJ P,PTYPE ;GET PRIM TYPE
+ MOVEI E,(A)
+ MOVE A,(AB)
+ SKIPN B,1(AB) ;GET DATUM
+ JRST OUTRNG
+ PUSHJ P,@BCKTBL(E)
+ JRST FINIS
+
+PRDISP BCKTBL,IWTYP2,[[PNWORD,BACKU],[P2NWORD,BACKV],[PCHSTR,BACKC],[PARGS,BACKA]
+[PTMPLT,BCKTMP],[PBYTE,BACKB]]
+
+BACKV: LSH C,1 ;GENERAL, DOUBLE AMOUNT
+ SKIPA A,$TVEC
+BACKU: MOVSI A,TUVEC
+ CAIN 0,SSTORE
+ MOVSI A,TSTORA
+ HRLI C,(C) ;TO BOTH HALVES
+ SUB B,C ;BACK UP VECTOR POINTER
+ HLRE C,B ;FIND OUT IF OVERFLOW
+ SUBM B,C ;DOPE POINTER TO C
+ HLRZ D,1(C) ;GET LENGTH
+ SUBI C,-2(D) ;POINT TO TOP
+ ANDI C,-1
+ CAILE C,(B) ;SKIP IF A WINNER
+ JRST OUTRNG ;COMPLAIN
+BACKUV: POPJ P,
+
+BCKTMP: MOVSI C,(C)
+ SUB B,C ; FIX UP POINTER
+ JUMPL B,OUTRNG
+ MOVSI A,TTMPLT
+ POPJ P,
+
+BACKB: SKIPA E,[TBYTE]
+BACKC: MOVEI E,TCHSTR
+ PUSH TP,A
+ PUSH TP,B
+ ADDI A,(C) ; NEW LENGTH
+ HRLI A,(E)
+ PUSH P,A ; SAVE COUNT
+ LDB E,[300600,,B] ;BYTE SIZE
+ MOVEI 0,36. ;BITS PER WORD
+ IDIVI 0,(E) ;DIVIDE TO FIND BYTES/WORD
+ IDIV C,0 ;C/ WORDS BACK, D/BYTES BACK
+ SUBI B,(C) ;BACK WORDS UP
+ JUMPE D,CHBOUN ;CHECK BOUNDS
+
+ IMULI 0,(E) ;0/ BITS OCCUPIED BY FULL WORD
+ LDB A,[360600,,B] ;GET POSITION FILED
+BACKC2: ADDI A,(E) ;BUMP
+ CAIGE A,36.
+ JRST BACKC1 ;O.K.
+ SUB A,0
+ SUBI B,1 ;DECREMENT POINTER PART
+BACKC1: SOJG D,BACKC2 ;DO FOR ALL BYTES
+\f
+
+
+ DPB A,[360600,,B] ;FIX UP POINT BYTER
+CHBOUN: MOVEI C,-1(TP)
+ PUSHJ P,BYTDOP ; FIND DOPE WORD
+ HLRZ C,(A)
+ SKIPGE -1(A) ; SKIP IF NOT REALLY AN ATOM
+ SUBI C,3 ; ELSE FUDGE FOR VALUE CELL AND OBLIST SLOT
+ SUBI A,-1(C) ; POINT TO TOP
+ MOVE C,B ; COPY BYTER
+ IBP C
+ CAILE A,(C) ; SKIP IF OK
+ JRST OUTRNG
+ POP P,A ; RESTORE COUNT
+ SUB TP,[2,,2]
+ POPJ P,
+
+
+BACKA: LSH C,1 ;NUMBER TIMES 2
+ HRLI C,(C) ;TO BOTH HALVES
+ SUB B,C ;FIX POINTER
+ MOVE E,B ;AND SAVE
+ PUSHJ P,GETATO ;LOOK A T TOP
+ CAMLE B,E ;COMPARE
+ JRST OUTRNG
+ MOVE B,E
+ POPJ P,
+
+; COMPILER'S BACK
+
+CIBACK: PUSHJ P,CPTYEE
+ JUMPL C,OUTRNG
+ CAIN E,P2WORD
+ JRST WTYPL
+ PUSHJ P,@BCKTBL(E)
+ JRST MPOPJ
+\f
+MFUNCTION STRCOMP,SUBR
+
+ ENTRY 2
+
+ MOVE A,(AB)
+ MOVE B,1(AB)
+ MOVE C,2(AB)
+ MOVE D,3(AB)
+ PUSHJ P,ISTRCM
+ JRST FINIS
+
+ISTRCM: GETYP 0,A
+ CAIE 0,TCHSTR
+ JRST ATMCMP ; MAYBE ATOMS
+
+ GETYP 0,C
+ CAIE 0,TCHSTR
+ JRST WTYP2
+
+ MOVEI A,(A) ; ISOLATR LENGHTS
+ MOVEI C,(C)
+
+STRCO2: SOJL A,CHOTHE ; ONE STRING EXHAUSTED, CHECK OTHER
+ SOJL C,1BIG ; 1ST IS BIGGER
+ ILDB 0,B
+ ILDB E,D
+ CAIN 0,(E) ; SKIP IF DIFFERENT
+ JRST STRCO2
+ CAIL 0,(E) ; SKIP IF 2D BIGGER THAN 1ST
+ JRST 1BIG
+2BIG: MOVNI B,1
+ JRST RETFIX
+
+CHOTHE: JUMPN C,2BIG ; 2 IS BIGGER
+SM.CMP: TDZA B,B ; RETURN 0
+1BIG: MOVEI B,1
+RETFIX: MOVSI A,TFIX
+ POPJ P,
+
+ATMCMP: CAIE 0,TATOM ; COULD BE ATOM
+ JRST WTYP1 ; NO, QUIT
+ GETYP 0,C
+ CAIE 0,TATOM
+ JRST WTYP2
+
+ CAMN B,D ; SAME ATOM?
+ JRST SM.CMP
+ ADD B,[3,,3] ; SKIP VAL CELL ETC.
+ ADD D,[3,,3]
+
+ATMCM1: MOVE 0,(B) ; GET A WORD OF CHARS
+ CAME 0,(D) ; SAME?
+ JRST ATMCM3 ; NO, GET DIF
+ AOBJP B,ATMCM2
+ AOBJN D,ATMCM1 ; MORE TO COMPARE
+ JRST 1BIG ; 1ST IS BIGGER
+
+
+ATMCM2: AOBJP D,SM.CMP ; EQUAL
+ JRST 2BIG
+
+ATMCM3: LSH 0,-1 ; AVOID SIGN LOSSAGE
+ MOVE C,(D)
+ LSH C,-1
+ CAMG 0,C
+ JRST 2BIG
+ JRST 1BIG
+
+\f;ERROR COMMENTS FOR SOME PRIMITIVES
+
+OUTRNG: ERRUUO EQUOTE OUT-OF-BOUNDS
+
+WRNGUT: ERRUUO EQUOTE TYPES-DIFFER-IN-UNIFORM-VECTOR
+
+IIGETP: JRST IGETP ;FUDGE FOR MIDAS/STINK LOSSAGE
+IIPUTP: JRST IPUTP
+
+\f;SUPER USEFUL ERROR MESSAGES (USED BY WHOLE WORLD)
+
+WNA: ERRUUO EQUOTE WRONG-NUMBER-OF-ARGUMENTS
+
+TFA: ERRUUO EQUOTE TOO-FEW-ARGUMENTS-SUPPLIED
+
+TMA: ERRUUO EQUOTE TOO-MANY-ARGUMENTS-SUPPLIED
+
+WRONGT:
+WTYP: ERRUUO EQUOTE ARG-WRONG-TYPE
+
+IWTYP1:
+WTYP1: ERRUUO EQUOTE FIRST-ARG-WRONG-TYPE
+
+IWTYP2:
+WTYP2: ERRUUO EQUOTE SECOND-ARG-WRONG-TYPE
+
+BADTPL: ERRUUO EQUOTE BAD-TEMPLATE-DATA
+
+BADPUT: ERRUUO EQUOTE TEMPLATE-TYPE-VIOLATION
+
+WTYP3: ERRUUO EQUOTE THIRD-ARG-WRONG-TYPE
+
+WTYPL: ERRUUO EQUOTE INTERNAL-BACK-OR-TOP-OF-A-LIST
+
+WTYPUN: ERRUUO EQUOTE NON-STRUCTURED-ARG-TO-INTERNAL-PUT-REST-NTH-TOP-OR-BACK
+
+CALER1: MOVEI A,1
+CALER: HRRZ C,FSAV(TB)
+ PUSH TP,$TATOM
+ CAIL C,HIBOT
+ SKIPA C,@-1(C) ; SUBRS AND FSUBRS
+ MOVE C,3(C) ; FOR RSUBRS
+ PUSH TP,C
+ ADDI A,1
+ ACALL A,ERROR
+ JRST FINIS
+
+
+GETWNA: HLRZ B,(E)-2 ;GET LOSING COMPARE INSTRUCTION
+ CAIE B,(CAIE A,) ;AS EXPECTED ?
+ JRST WNA ;NO,
+ HRRE B,(E)-2 ;GET DESIRED NUMBER OF ARGS
+ HLRE A,AB ;GET ACTUAL NUMBER OF ARGS
+ CAMG B,A
+ JRST TFA
+ JRST TMA
+
+END
+\f
\ No newline at end of file
--- /dev/null
+TITLE PRIMITIVE FUNCTIONS FOR THE MUDDLE SYSTEM
+
+RELOCATABLE
+
+.INSRT MUDDLE >
+
+.GLOBAL TMA,TFA,CELL,IBLOCK,IBLOK1,ICELL2,VECTOP,LSTUF,PVSTOR,SPSTOR
+.GLOBAL NWORDT,CHARGS,CHFRM,CHLOCI,IFALSE,IPUTP,IGETP,BYTDOP
+.GLOBAL OUTRNG,IGETLO,CHFRAM,ISTRUC,TYPVEC,SAT,CHKAB,VAL,CELL2,MONCH,MONCH0
+.GLOBAL RMONCH,RMONC0,LOCQ,LOCQQ,SMON,PURERR,APLQ,NAPT,TYPSEG,NXTLM
+.GLOBAL MAKACT,ILLCHO,COMPER,CEMPTY,CIAT,CIEQUA,CILEGQ,CILNQ,CILNT,CIN,CINTH,CIREST
+.GLOBAL CISTRU,CSETLO,CIPUT,CIGET,CIGETL,CIMEMQ,CIMEMB,CIMON,CITOP,CIBACK
+.GLOBAL IGET,IGETL,IPUT,CIGETP,CIGTPR,CINEQU,IEQUAL,TD.LNT,TD.GET,TD.PUT,TD.PTY
+.GLOBAL TMPLNT,BADTPL,ISTRCM,PTYPE,CIGVAL,MAKTUP,CSBSTR,TMATCH
+
+; BUILD DISPATCH TABLE FOR PRIMITIVE FUNCTIONS USAGE
+F==PVP
+
+PRMTYP:
+
+REPEAT NUMSAT+1,[0] ;INITIALIZE TABLE TO ZEROES
+
+IRP A,,[2WORD,2NWORD,NWORD,ARGS,CHSTR,BYTE]
+
+LOC PRMTYP+S!A
+P!A==.IRPCN+1
+P!A
+
+TERMIN
+
+PTMPLT==PBYTE+1
+
+; FUDGE FOR STRUCTURE LOCATIVES
+
+IRP A,,[[LOCL,2WORD],[LOCV,2NWORD],[LOCU,NWORD],[LOCS,CHSTR],[LOCA,ARGS]
+[LOCT,TMPLT],[LOCB,BYTE]]
+ IRP B,C,[A]
+ LOC PRMTYP+S!B
+ P!B==P!C,,0
+ P!B
+ .ISTOP
+ TERMIN
+TERMIN
+
+LOC PRMTYP+SSTORE ;SPECIAL HACK FOR AFREE STORAGE
+PNWORD
+
+LOC PRMTYP+NUMSAT+1
+
+PNUM==PTMPLT+1
+
+; MACRO TO BUILD PRIMITIVE DISPATCH TABLES
+
+DEFINE PRDISP NAME,DEFAULT,LIST
+ TBLDIS NAME,DEFAULT,[LIST]PNUM,400000
+ TERMIN
+
+
+; SUBROUTINE TO RETURN PRIMITIVE TYPE AND PRINT ERROR IF ILLEGAL
+
+PTYPE: GETYP A,(B) ;CALLE D WITH B POINTING TO PAIR
+ CAIN A,TILLEG ;LOSE IF ILLEGAL
+ JRST ILLCHOS
+
+ PUSHJ P,SAT ;GET STORAGE ALLOC TYPE
+ CAIE A,SLOCA
+ CAIN A,SARGS ;SPECIAL HAIR FOR ARGS
+ PUSHJ P,CHARGS
+ CAIN A,SFRAME
+ PUSHJ P,CHFRM
+ CAIN A,SLOCID
+ PUSHJ P,CHLOCI
+PTYP1: MOVEI 0,(A) ; ALSO RETURN PRIMTYPE
+ CAILE A,NUMSAT ; SKIP IF NOT TEMPLATE
+ SKIPA A,[PTMPLT]
+ MOVE A,PRMTYP(A) ;GET PRIM TYPE,
+ POPJ P,
+
+; COMPILERS CALL TO ABOVE (LESS CHECKING)
+
+CPTYPE: PUSHJ P,SAT
+ MOVEI 0,(A)
+ CAILE A,NUMSAT
+ SKIPA A,[PTMPLT]
+ MOVE A,PRMTYP(A)
+ POPJ P,
+
+
+MFUNCTION SORT,SUBR
+
+ ENTRY
+
+; HACK TO DYNAMICALLY LOAD SORT
+ MOVE B,MQUOTE SORTX
+ PUSHJ P,CIGVAL
+ PUSH TP,A
+ PUSH TP,B ; PUSH ON FUNCTION FOR APPLY
+ MOVE A,AB ; PUSH ARGS TO SORT ONTO STACK
+ JUMPE A,DONPSH
+ PUSH TP,(A)
+ AOBJN A,.-1
+DONPSH: HLRE A,AB ; GET COUNT
+ MOVNS A
+ ADDI A,2
+ ASH A,-1 ; # OF ARGS
+ ACALL A,APPLY
+ JRST FINIS
+
+\f
+MFUNCTION SUBSTRUC,SUBR
+
+ ENTRY
+ JUMPGE AB,TFA ;need at least one arg
+ CAMGE AB,[-10,,0] ;NO MORE THEN 4
+ JRST TMA
+ HLRE A,AB ; GET NEGATIVE LENGTH IN A
+ MOVNS A ; SET UP LENGTH ARG TO SUBSTRUC
+ ASH A,-1
+ MOVE B,AB ; AOBJN POINTER FOR LOOP
+ PUSH TP,(B) ; PUSH ON ARGS
+ AOBJN B,.-1
+ PUSHJ P,CSBSTR ; GO TO INTERNAL ROUTINE
+ JRST FINIS
+
+; VARIOUS OFFSETS INTO PSTACK
+
+PRTYP==0
+LNT==0
+NOARGS==-1
+
+; VARIOUS OFFSETS INTO TP STACK
+
+OBJ==-7
+RSTR==-5
+LNT==-3
+NOBJ==-1
+
+; THIS STARTS THE MAIN ROUTINE
+
+CSBSTR: SUBM M,(P) ; FOR RSUBRS
+ JSP E,@PTBL(A)
+ MOVEI B,OBJ(TP)
+ PUSH P,A
+ PUSHJ P,PTYPE ; get primtype in A
+ PUSH P,A
+ JRST @TYTBL(A)
+
+PTBL: SETZ WNA
+ SETZ PUSH6
+ SETZ PUSH4
+ SETZ PUSH2
+ SETZ PUSH0
+
+PUSH6: PUSH TP,[0]
+ PUSH TP,[0]
+PUSH4: PUSH TP,[0]
+ PUSH TP,[0]
+PUSH2: PUSH TP,[0]
+ PUSH TP,[0]
+PUSH0: JRST (E)
+
+
+RESSUB: MOVE D,NOARGS(P) ; GET NUMBER OF ARGS
+ CAIN D,1 ; IF 1 THEN JUST COPY
+ JRST @COPYTB(A)
+ GETYP B,RSTR(TP) ; GET TYPE OF REST ARGUMENT
+ CAIE B,TFIX ;IF FIX OK
+ JRST WRONGT
+ MOVEI E,(A)
+ MOVE A,OBJ(TP)
+ MOVE B,OBJ+1(TP) ; GET OBJECT
+ SKIPGE C,RSTR+1(TP) ; GET REST ARGUMENT
+ JRST OUTRNG
+ PUSHJ P,@MRSTBL(E)
+ PUSH TP,A ; type
+ PUSH TP,B ; put rested sturc on stack
+ JRST ALOCOK
+
+PRDISP TYTBL,IWTYP1,[[PARGS,RESSUB],[P2WORD,RESSUB],[P2NWORD,RESSUB]
+[PNWORD,RESSUB],[PCHSTR,RESSUB],[PBYTE,RESSUB]]
+
+PRDISP MRSTBL,IWTYP1,[[PARGS,AREST],[P2WORD,LREST],[P2NWORD,VREST]
+[PNWORD,UREST],[PCHSTR,SREST],[PBYTE,BREST]]
+
+PRDISP COPYTB,IWTYP1,[[PARGS,CPYVEC],[P2WORD,CPYLST],[P2NWORD,CPYVEC]
+[PNWORD,CPYUVC],[PCHSTR,CPYSTR],[PBYTE,CPYBYT]]
+
+PRDISP ALOCTB,IWTYP1,[[PARGS,ALVEC],[P2WORD,ALLIST],[P2NWORD,ALVEC]
+[PNWORD,ALUVEC],[PCHSTR,ALSTR],[PBYTE,ALBYT]]
+
+; HERE WE HAVE RESTED STRUCTURE ON TOP OF STACK
+
+ALOCFX: MOVE B,(TP) ; missing 3rd arg aloc for "rest" of struc
+ MOVE C,-1(TP)
+ MOVE A,(P)
+ PUSH P,[377777,,-1]
+ PUSHJ P,@LENTBL(A) ; get length of rested struc
+ SUB P,[1,,1]
+ POP P,C
+ MOVE A,B ; # of elements needed
+ JRST @ALOCTB(C)
+
+
+; HERE WE HAVE RESTED STRUCTURE ON THE TOP OF THE STACK
+
+ALOCOK: MOVE D,NOARGS(P) ; GET NUMBER OF ARGS
+ CAIG D,2 ; SKIP IF NOT EXACTLY 3 ARGS
+ JRST ALOCFX
+ GETYP C,LNT-2(TP) ; GET THE LENGTH ARGUMENT
+ CAIE C,TFIX ; OK IF TYPE FIX
+ JRST WRONGT
+ POP P,C
+ SKIPL A,LNT-1(TP) ; GET LENGTH
+ JRST @ALOCTB(C) ; DO ALLOCATION
+ JRST OUTRNG
+
+
+CPYVEC: HLRE A,OBJ+1(TP) ; USE WHEN ONLY ONE ARG
+ MOVNS A ; LENGTH ARG IS LENGTH OF STRUCTURE
+ ASH A,-1 ; # OF ELEMENTS FOR ALLOCATION
+ PUSH TP,OBJ(TP)
+ SUB P,[1,,1]
+ PUSH TP,OBJ(TP) ; REPUSH ARGS
+
+ALVEC: PUSH P,A ; SAVE LENGTH
+ ASH A,1
+ HRLI A,(A)
+ ADD A,(TP)
+ CAIL A,-1 ; CHK FOR OUT OF RANGE
+ JRST OUTRNG
+ MOVE D,NOARGS(P)
+ CAILE D,3 ; SKIP IF WE GET VECTOR
+ JRST ALVEC2 ; USER SUPPLIED VECTOR
+ MOVE A,(P)
+ PUSHJ P,IBLOK1
+ALVEC1: MOVE A,(P) ; # OF WORDS TO ALLOCATE
+ MOVE C,B ; SAVE VECTOR POINTER
+ JUMPE A,ALEVC4
+ ASH A,1 ; TIMES 2
+ HRLI A,(A)
+ ADD A,B ; PTING TO FIRST DOPE WORD -ALLOCATED
+ CAIL A,-1
+ JRST OUTRNG
+ SUBI A,1 ; ptr to last element of the block
+ MOVE D,NOARGS(P)
+ CAILE D,3
+ CAMGE B,(TP) ; SKIP IF BACKWARDS BLT IS NEEDED
+ JRST ALEVC3
+ HRRZ 0,(TP)
+ ADD 0,-4(TP)
+ ADD 0,-4(TP) ; FIND END OF DEST
+ CAIGE 0,(B) ; SEE IF BBLT IS NEEDED
+ JRST ALEVC3
+ PUSHJ P,BBLT ; BLT IT
+ JRST ALEVC4
+ALEVC3: HRL B,(TP) ;bleft-ptr to source , b right -ptr to allocated space
+ BLT B,(A)
+ MOVE B,C
+ALEVC4: MOVE D,NOARGS(P)
+ CAIE D,4
+ JRST ALEVC5
+ MOVE A,NOBJ-2(TP)
+ JRST EXSUB
+ALEVC5: MOVSI A,TVEC
+ JRST EXSUB
+
+; RESTED OBJECT ON TOP OF STACK
+
+ALVEC2: GETYP 0,NOBJ-2(TP) ; CHECK IT IS A VECTOR
+ CAIE 0,TARGS
+ CAIN 0,TVEC
+ SKIPA
+ JRST WTYP
+ HLRE A,NOBJ-1(TP) ; CHECK SIZE
+ MOVNS A
+ ASH A,-1 ; # OF ELEMENTS
+ CAMGE A,(P) ; SKIP IF BIG ENOUGH
+ JRST OUTRNG
+ MOVE B,NOBJ-1(TP) ; WINNER, JOIN COMMON CODE
+ JRST ALVEC1
+
+CPYUVC: HLRE A,OBJ+1(TP) ;# OF ELEMENTS FOR ALLOCATION
+ MOVNS A
+ PUSH TP,(B)
+ PUSH TP,1(B)
+ SUB P,[1,,1]
+
+
+ALUVEC: PUSH P,A
+ HRLI A,(A)
+ ADD A,(TP) ; PTING TO DOPE WORD OF ORIG VEC
+ CAIL A,-1
+ JRST OUTRNG
+ MOVE D,NOARGS(P)
+ CAILE D,3
+ JRST ALUVE2
+ MOVE A,(P)
+ PUSHJ P,IBLOCK
+ALUVE1: MOVE A,(P) ; # of owrds to allocate
+ JUMPE A,ALUEV4
+ HRLI A,(A)
+ ADD A,B ; LOCATION O FIRST ALLOCATED DOPE WORD
+ HLR E,OBJ-1(TP) ; # OF ELEMENTS IN UVECTOR
+ MOVNS E
+ ADD E,OBJ-1(TP) ; LOCATION OF FIRST DOPE WORD FOR SOURCE
+ GETYP E,(E) ; GET UTYPE
+ MOVE D,NOARGS(P)
+ CAIE D,4
+ PUTYP E,(A) ; DUMP UTYPE INTO DOPE WORD OF ALLOC UVEC
+ CAILE D,3
+ CAIN 0,(E) ; 0 HAS USER UVEC UTYPE
+ JRST .+2
+ JRST WRNGUT
+ CAIL A,-1
+ JRST OUTRNG
+ MOVE D,NOARGS(P)
+ CAILE D,3
+ CAMGE B,(TP) ; SKIP IF NEEDS BACKWARDS BLT
+ JRST ALUEV3
+ HRRZ 0,(TP)
+ ADD 0,-4(TP)
+ CAIGE 0,(B)
+ JRST ALUEV3
+ SUBI A,1
+ PUSHJ P,BBLT
+ JRST ALUEV4
+ALUEV3: MOVE C,B ; SAVE POINTER TO FINAL GUY
+ HRL C,(TP) ; BUILD BLT POINTER
+ BLT C,-1(A)
+ALUEV4: MOVSI A,TUVEC
+ JRST EXSUB
+
+; BACKWARDS BLTTER
+; A==LAST WORD DEST (TP)==FIRST WORD DEST B==FIRST WORD SOURCE
+
+BBLT: SUBI A,-1(B)
+ MOVE E,A ; SAVE ADDITION
+ HRLZS A ; SWAP AND ZERO
+ HRR A,(TP)
+ ADDI A,-1(E)
+ MOVEI C,(B) ; SET UP DEST WORD
+ SUBI C,(A) ; CALC DIFF
+ ADDI C,-1(E) ; ADD TO GET TO END
+ HRLI C,A ; SET UP INDIRECT
+ POP A,@C ; BLT
+ TLNE A,-1 ; SKIP IF DONE
+ JRST .-2
+ POPJ P, ; EXIT
+
+ALUVE2: GETYP 0,NOBJ-2(TP) ; CHECK IT IS A VECTOR
+ CAIE 0,TUVEC
+ JRST WTYP
+ HLRE A,NOBJ-1(TP) ; CHECK SIZE
+ MOVNS A
+ CAMGE A,(P) ; SKIP IF BIG ENOUGH
+ JRST OUTRNG
+ MOVE B,NOBJ-1(TP) ; WINNER, JOIN COMMON CODE
+ HLRE A,B
+ SUBM B,A
+ GETYP 0,(A) ; GET UTYPE OF USER UVECTOR
+ JRST ALUVE1
+
+ALBYT: MOVSI C,TBYTE
+ JRST ALSTRX
+
+CPYBYT: SKIPA C,$TBYTE
+CPYSTR: MOVSI C,TCHSTR
+ HRR A,OBJ(TP)
+ PUSH TP,(B) ; ALSTR EXPECTS STRING IN TP
+ PUSH TP,1(B)
+ SUB P,[1,,1]
+ JRST .+2
+
+ALSTR: MOVSI C,TCHSTR
+ALSTRX: PUSH P,C ; SAVE FINAL TYPE
+ PUSH P,A ; LENGTH
+ HRRZ 0,-1(TP) ;0 IS LENGTH OFF VECTOR
+ CAIGE 0,(A)
+ JRST OUTRNG
+ CAILE D,3
+ JRST ALSTR2
+ LDB C,[300600,,(TP)]
+ MOVEI B,36.
+ IDIVI B,(C) ; B BYT PER WD, C XTRA BITS
+ ADDI A,-1(B)
+ IDIVI A,(B)
+ PUSH P,C
+ PUSHJ P,IBLOCK ;ALLOCATE SPACE
+ HLL B,(TP)
+ POP P,C
+ DPB C,[360600,,B]
+ SUBI B,1
+ MOVEM B,-2(TP)
+ MOVE A,(P) ; # OF CHARS TO A
+ HLL A,-1(P)
+ MOVEM A,-3(TP)
+ JUMPN A,SSTR1
+ALSTR9: SUB TP,[4,,4]
+ JRST ALSTR8
+ALSTR1: HLL A,-2(P) ; GET TYPE
+ HRRZ C,B ; SEE IF WE WILL OVERLAP
+ HRRZ D,(TP) ; GET RESTED STRING
+ CAIGE C,(D) ; IF C > B THE A CHANCE
+ JRST SSTR
+ MOVEI C,-1(TP) ; GO TO BYTDOP
+ PUSHJ P,BYTDOP
+ HRRZ B,-2(TP) ; IF B < A THEN OVERLAP
+ CAILE B,(A)
+ JRST SSTR
+ HRRZ A,-4(TP) ; GET LENGTH IN A
+ MOVEI B,0 ; START LENGTH COUNT
+
+; ORIGINAL STRING IS ON THE TOP OF THE STACK
+
+CLOOP1: INTGO
+ PUSH P,[0] ; STORE CHARS ON STACK
+ MOVSI E,(<440000,,(P)>) ; SETUP BYTE POINTER
+ LDB 0,[300600,,(TP)]
+ DPB 0,[300600,,E]
+CLOOP: IBP E ; BUMP IT
+ TRNE E,-1 ; WORD FULL
+ AOJA B,CLOOP1 ; PUSH NEW ONE
+ ILDB 0,(TP) ; GET A CHARACTER
+ SOS -1(TP) ; DECREMENT CHARACTER COUNT
+ DPB 0,E
+ SOJN A,CLOOP ; ANY MORE?
+ SUB TP,[2,,2]
+ MOVEI C,(P)
+ PUSH P,B ; SAVE B
+ SUBI C,(B)
+ MOVE A,-2(TP) ; GET COUNT
+ MOVE B,(TP)
+ HRLI C,440000 ; MAKE IT LOOK LIKE A BYTE PTR
+ LDB 0,[300600,,(TP)]
+ DPB 0,[300600,,C]
+CLOOP3: ILDB D,C ; GET NEW CHARACTER
+ IDPB D,B ; DEPOSIT CHARACTER
+ SOJG A,CLOOP3
+ POP P,A
+ SUBI P,(A)
+ HRLZS A
+ SUB P,A ; CLEAN OFF STACK
+ POP TP,B ;BYTE PTR TO COPY
+ SUB P,[1,,1]
+ALST10: SUB TP,[1,,1] ; CLEAN OFF STACK
+ALSTR8: POP P,A ;# FO ELEMENTS
+ HLL A,(P)
+ SUB TP,[6,,6]
+ JRST EXSUB1
+
+
+; ROUTINE TO DO FAST TRANSFER FOR NON SHARING STRINGS
+
+SSTR: MOVE A,-4(TP) ; GET # OF ELEMENTS INTO A
+ MOVE B,-2(TP)
+SSTR1: POP TP,C
+ SUB TP,[1,,1]
+ HRRZS A
+SSTR2: ILDB D,C
+ IDPB D,B
+ SOJG A,SSTR2
+ POP TP,B
+ JRST ALST10
+
+ALSTR2: GETYP 0,NOBJ-2(TP) ; CHECK IT IS A VECTOR
+ MOVSS 0
+ CAME 0,-1(P)
+ JRST WTYP
+ HRRZ A,NOBJ-2(TP)
+ CAMGE A,(P) ; SKIP IF BIG ENOUGH
+ JRST OUTRNG
+ EXCH A,(P)
+ MOVE B,NOBJ-1(TP) ; WINNER, JOIN COMMON CODE
+ JUMPE A,ALSTR9
+ JRST ALSTR1
+
+; HERE TO COPY A LIST
+
+CPYLST: SKIPN OBJ+1(TP)
+ JRST ZEROLT
+ PUSHJ P,CELL2
+ POP P,C
+ HRLI C,TLIST ; TP JUNK FOR GAR. COLLECTOR
+ PUSH TP,C ; TYPE
+ PUSH TP,B ; VALUE -PTR TO NEW LIST
+ PUSH TP,C ; TYPE
+ MOVE C,OBJ-2(TP) ; PTR TO FIRST ELEMENT OF ORIG. LIST
+REPLST: MOVE D,(C)
+ MOVE E,1(C) ; GET LIST ELEMENT INTO ALOC SPACE
+ HLLM D,(B)
+ MOVEM E,1(B) ; PUT INTO ALLOCATED SPACE
+ HRRZ C,(C) ; UPDATE PTR
+ JUMPE C,CLOSWL ; END OF LIST?
+ PUSH TP,B
+ PUSHJ P,CELL2
+ POP TP,D
+ HRRM B,(D) ; LINK ALLOCATED LIST CELLS
+ JRST REPLST
+
+CLOSWL: MOVE A,-2(TP) ; GET LIST
+ MOVE B,-1(TP)
+ SUB TP,[11.,,11.]
+LEXIT: SUB P,[1,,1]
+ JRST MPOPJ
+
+
+
+ALLIST: PUSH P,A
+ MOVE D,NOARGS(P)
+ CAILE D,3 ; SKIP IF WE BUILD LIST
+ JRST CPYLS2
+ JUMPE A,ZEROL1
+ ASH A,1 ; TIMES 2
+ PUSHJ P,CELL
+ POP P,A ; # OF ELEMENTS
+ PUSH P,B ; ptr to allocated list
+ POP TP,C ; ptr to orig list
+ JRST ENTCOP
+
+COPYL: ADDI B,2
+ HRRM B,-2(B) ; LINK ALOCATED LIST CELLS
+ENTCOP: JUMPE C,OUTRNG
+ MOVE D,(C)
+ MOVE E,1(C) ; get list element into D+E
+ HLLM D,(B)
+ MOVEM E,1(B) ; put into allocated space
+ HRRZ C,(C) ; update ptrs
+ SOJG A,COPYL ; finish transfer?
+
+CLOSEL: POP P,B
+ MOVE A,(TP)
+ SUB TP,[9.,,9.]
+ JRST LEXIT
+
+
+ZEROL1: SUB TP,[2,,2]
+ZEROLT: MOVSI A,TLIST
+ MOVEI B,0
+ SUB TP,[8,,8]
+ JRST EXSUB1
+
+CPYLS2: GETYP 0,NOBJ-2(TP)
+ CAIE 0,TLIST
+ JRST WTYP
+ MOVE B,NOBJ-1(TP) ; GET DEST LIST
+ MOVE C,(TP)
+
+ JUMPE A,CPYLS3
+CPYLS4: JUMPE B,OUTRNG
+ JUMPE C,OUTRNG
+ MOVE D,1(C)
+ MOVEM D,1(B)
+ GETYP 0,(C)
+ HRLM 0,(B)
+ HRRZ B,(B)
+ HRRZ C,(C)
+ SOJG A,CPYLS4
+
+CPYLS3: MOVE D,-2(TP)
+ MOVE B,NOBJ-1(TP)
+ MOVSI A,TLIST
+
+; HERE TO EXIT
+
+EXSUB: SUB TP,[10.,,10.]
+EXSUB1: SUB P,[2,,2]
+ JRST MPOPJ
+
+
+\f
+; PROCESS TYPE ILLEGAL
+
+ILLCHO: HRRZ B,1(B) ;GET CLOBBERED TYPE
+ CAIN B,TARGS ;WAS IT ARGS?
+ JRST ILLAR1
+ CAIN B,TFRAME ;A FRAME?
+ JRST ILFRAM
+ CAIN B,TLOCD ;A LOCATIVE TO AN ID
+ JRST ILLOC1
+
+ LSH B,1 ;NONE OF ABOVE LOOK IN TABLE
+ ADDI B,TYPVEC+1
+ PUSH TP,$TATOM
+ PUSH TP,EQUOTE ILLEGAL
+ PUSH TP,$TATOM
+ PUSH TP,(B) ;PUSH ATOMIC NAME
+ MOVEI A,2
+ JRST CALER ;GO TO ERROR REPORTER
+
+; CHECK AN ARGS POINTER
+
+CHARGS: PUSHJ P,ICHARG ; INTERNAL CHECK
+ JUMPN B,CPOPJ
+
+ILLAR1: ERRUUO EQUOTE ILLEGAL-ARGUMENT-BLOCK
+
+ICHARG: PUSH P,A ;SAVE SOME ACS
+ PUSH P,B
+ PUSH P,C
+ SKIPN C,1(B) ;GET POINTER
+ JRST ILLARG ; ZERO POINTER IS ILLEGAL
+ HLRE A,C ;FIND ASSOCIATED FRAME
+ SUBI C,(A) ;C POINTS TO FRAME OR FRAME POINTER
+ GETYP A,(C) ;GET TYPE OF NEXT GOODIE
+ CAIN A,TCBLK
+ JRST CHARG1
+ CAIE A,TENTRY ;MUST BE EITHER ENTRY OR TINFO
+ CAIN A,TINFO
+ JRST CHARG1 ;WINNER
+ JRST ILLARG
+
+CHARG1: CAIN A,TINFO ;POINTER TO FRAME?
+ ADD C,1(C) ;YES, GET IT
+ CAIE A,TINFO ;POINTS TO ENTRT?
+ MOVEI C,FRAMLN(C) ;YES POINT TO END OF FRAME
+ HLRZ C,OTBSAV(C) ;GET TIME FROM FRAME
+ HRRZ B,(B) ;AND ARGS TIME
+ CAIE B,(C) ;SAME?
+ILLARG: SETZM -1(P) ; RETURN ZEROED B
+POPBCJ: POP P,C
+ POP P,B
+ POP P,A
+ POPJ P, ;GO GET PRIM TYPE
+\f
+
+
+; CHECK A FRAME POINTER
+
+CHFRM: PUSHJ P,CHFRAM
+ JUMPN B,CPOPJ
+
+ILFRAM: ERRUUO EQUOTE ILLEGAL-FRAME
+
+CHFRAM: PUSH P,A ;SAVE SOME REGISTERS
+ PUSH P,B
+ PUSH P,C
+ HRRZ A,(B) ; GE PVP POINTER
+ HLRZ C,(A) ; GET LNTH
+ SUBI A,-1(C) ; POINT TO TOP
+ MOVE PVP,PVSTOR+1
+ CAIN A,(PVP) ; SKIP IF NOT THIS PROCESS
+ MOVEM TP,TPSTO+1(A) ; MAKE CURRENT BE STORED
+ HRRZ A,TPSTO+1(A) ; GET TP FOR THIS PROC
+ HRRZ C,1(B) ;GET POINTER PART
+ CAILE C,1(A) ;STILL WITHIN STACK
+ JRST BDFR
+ HLRZ A,FSAV(C) ;CHECK STILL AN ENTRY BLOCK
+ CAIN A,TCBLK
+ JRST .+3
+ CAIE A,TENTRY
+ JRST BDFR
+ HLRZ A,1(B) ;GET TIME FROM POINTER
+ HLRZ C,OTBSAV(C) ;AND FROM FRAME
+ CAIE A,(C) ;SAME?
+BDFR: SETZM -1(P) ; RETURN 0 IN B
+ JRST POPBCJ ;YES, WIN
+
+; CHECK A LOCATIVE TO AN IDENTIFIER
+
+CHLOCI: PUSHJ P,ICHLOC
+ JUMPN B,CPOPJ
+
+ILLOC1: ERRUUO EQUOTE ILLEGAL-LOCATIVE
+
+ICHLOC: PUSH P,A
+ PUSH P,B
+ PUSH P,C
+
+ HRRZ A,(B) ;GET TIME FROM POINTER
+ JUMPE A,POPBCJ ;ZERO, GLOBAL VARIABLE NO TIME
+ HRRZ C,1(B) ;POINT TO STACK
+ CAMLE C,VECTOP
+ JRST ILLOC ;NO
+ HRRZ C,2(C) ; SHOULD BE DECL,,TIME
+ CAIE A,(C)
+ILLOC: SETZM -1(P) ; RET 0 IN B
+ JRST POPBCJ
+
+
+
+\f
+; PREDICATE TO SEE IF AN OBJECT IS STRUCTURED
+
+MFUNCTION %STRUC,SUBR,[STRUCTURED?]
+
+ ENTRY 1
+
+ GETYP A,(AB) ; GET TYPE
+ PUSHJ P,ISTRUC ; INTERNAL
+ JRST IFALSE
+ JRST ITRUTH
+
+
+; PREDICATE TO CHECK THE LEGALITY OF A FRAME/ARGS TUPLE/IDENTIFIER LOCATIVE
+
+MFUNCTION %LEGAL,SUBR,[LEGAL?]
+
+ ENTRY 1
+
+ MOVEI B,(AB) ; POINT TO ARG
+ PUSHJ P,ILEGQ
+ JRST IFALSE
+ JRST ITRUTH
+
+ILEGQ: GETYP A,(B)
+ CAIN A,TILLEG
+ POPJ P,
+ PUSHJ P,SAT ; GET STORG TYPE
+ CAIN A,SFRAME ; FRAME?
+ PUSHJ P,CHFRAM
+ CAIE A,SLOCA
+ CAIN A,SARGS ; ARG TUPLE
+ PUSHJ P,ICHARG
+ CAIN A,SLOCID ; ID LOCATIVE
+ PUSHJ P,ICHLOC
+ JUMPE B,CPOPJ
+ JRST CPOPJ1
+
+
+; COMPILERS CALL
+
+CILEGQ: PUSH TP,A
+ PUSH TP,B
+ MOVEI B,-1(TP)
+ PUSHJ P,ILEGQ
+ TDZA 0,0
+ MOVEI 0,1
+ SUB TP,[2,,2]
+ JUMPE 0,NO
+
+YES: MOVSI A,TATOM
+ MOVE B,IMQUOTE T
+ JRST CPOPJ1
+
+NOM: SUBM M,(P)
+NO: MOVSI A,TFALSE
+ MOVEI B,0
+ POPJ P,
+
+YESM: SUBM M,(P)
+ JRST YES
+\f;SUBRS TO DEFINE, GET, AND PUT BIT FIELDS
+
+MFUNCTION BITS,SUBR
+ ENTRY
+ JUMPGE AB,TFA ;AT LEAST ONE ARG ?
+ GETYP A,(AB)
+ CAIE A,TFIX
+ JRST WTYP1
+ SKIPLE C,(AB)+1 ;GET FIRST AND CHECK TO SEE IF POSITIVE
+ CAILE C,44 ;CHECK IF FIELD NOT GREATER THAN WORD SIZE
+ JRST OUTRNG
+ MOVEI B,0
+ CAML AB,[-2,,0] ;ONLY ONE ARG ?
+ JRST ONEF ;YES
+ CAMGE AB,[-4,,0] ;MORE THAN TWO ARGS ?
+ JRST TMA ;YES, LOSE
+ GETYP A,(AB)+2
+ CAIE A,TFIX
+ JRST WTYP2
+ SKIPGE B,(AB)+3 ;GET SECOND ARG AND CHECK TO SEE IF NON-NEGATIVE
+ JRST OUTRNG
+ ADD C,(AB)+3 ;CALCULATE LEFTMOST EXTENT OF THE FIELD
+ CAILE C,44 ;SHOULD BE LESS THAN WORD SIZE
+ JRST OUTRNG
+ LSH B,6
+ONEF: ADD B,(AB)+1
+ LSH B,30 ;FORM BYTE POINTER'S LEFT HALF
+ MOVSI A,TBITS
+ JRST FINIS
+
+
+
+MFUNCTION GETBITS,SUBR
+ ENTRY 2
+ GETYP A,(AB)
+ PUSHJ P,SAT
+ CAIN A,SSTORE
+ JRST .+3
+ CAIE A,S1WORD
+ JRST WTYP1
+ GETYP A,(AB)+2
+ CAIE A,TBITS
+ JRST WTYP2
+ MOVEI A,(AB)+1 ;GET ADDRESS OF THE WORD
+ HLL A,(AB)+3 ;GET LEFT HALF OF BYTE POINTER
+ LDB B,A
+ MOVSI A,TWORD ; ALWAYS RETURN WORD\b\b\b\b____
+ JRST FINIS
+
+
+MFUNCTION PUTBITS,SUBR
+ ENTRY
+ CAML AB,[-2,,0] ;AT LEAST TWO ARGS ?
+ JRST TFA ;NO, LOSE
+ GETYP A,(AB)
+ PUSHJ P,SAT
+ CAIE A,S1WORD
+ JRST WTYP1
+ GETYP A,(AB)+2
+ CAIE A,TBITS
+ JRST WTYP2
+ MOVEI B,0 ;EMPTY THIRD ARG DEFAULT
+ CAML AB,[-4,,0] ;ONLY TWO ARGS ?
+ JRST TWOF
+ CAMGE AB,[-6,,0] ;MORE THAN THREE ARGS ?
+ JRST TMA ;YES, LOSE
+ GETYP A,(AB)+4
+ PUSHJ P,SAT
+ CAIE A,S1WORD
+ JRST WTYP3
+ MOVE B,(AB)+5
+TWOF: MOVEI A,(AB)+1 ;ADDRESS OF THE TARGET WORD
+ HLL A,(AB)+3 ;GET THE LEFT HALF OF THE BYTE POINTER
+ DPB B,A
+ MOVE B,(AB)+1
+ MOVE A,(AB) ;SAME TYPE AS FIRST ARG'S
+ JRST FINIS
+\f
+
+; FUNCTION TO GET THE LENGTH OF LISTS,VECTORS AND CHAR STRINGS
+
+MFUNCTION LNTHQ,SUBR,[LENGTH?]
+
+ ENTRY 2
+ GETYP A,(AB)2
+ CAIE A,TFIX
+ JRST WTYP2
+ PUSH P,(AB)3
+ JRST LNTHER
+
+
+MFUNCTION LENGTH,SUBR
+
+ ENTRY 1
+ PUSH P,[377777777777]
+LNTHER: MOVE B,AB ;POINT TO ARGS
+ PUSHJ P,PTYPE ;GET ITS PRIM TYPE
+ MOVE B,1(AB)
+ MOVE C,(AB)
+ PUSHJ P,@LENTBL(A) ; CALL RIGTH ONE
+ JRST LFINIS ;OTHERWISE USE 0
+
+PRDISP LENTBL,IWTYP1,[[P2WORD,LNLST],[P2NWORD,LNVEC],[PNWORD,LNUVEC]
+[PARGS,LNVEC],[PCHSTR,LNCHAR],[PTMPLT,LNTMPL],[PBYTE,LNCHAR]]
+
+LNLST: SKIPN C,B ; EMPTY?
+ JRST LNLST2 ; YUP, LEAVE
+ MOVEI B,1 ; INIT COUNTER
+ MOVSI A,TLIST ;WILL BECOME INTERRUPTABLE
+ MOVE PVP,PVSTOR+1
+ HLLM A,CSTO(PVP) ;AND C WILL BE A LIST POINTER
+LNLST1: INTGO ;IN CASE CIRCULAR LIST
+ CAMLE B,(P)-1
+ JRST LNLST2
+ HRRZ C,(C) ;STEP
+ JUMPE C,.+2 ;DONE, RETRUN LENGTH
+ AOJA B,LNLST1 ;COUNT AND GO
+LNLST2: MOVE PVP,PVSTOR+1
+ SETZM CSTO(PVP)
+ POPJ P,
+
+LFINIS: POP P,C
+ CAMLE B,C
+ JRST IFALSE
+ MOVSI A,TFIX ;LENGTH IS AN INTEGER
+ JRST FINIS
+
+LNVEC: ASH B,-1 ;GENERAL VECTOR DIVIDE BY 2
+LNUVEC: HLRES B ;GET LENGTH
+ MOVMS B ;MAKE POS
+ POPJ P,
+
+LNCHAR: HRRZ B,C ; GET COUNT
+ POPJ P,
+
+LNTMPL: GETYP A,(B) ; GET REAL SAT
+ SUBI A,NUMSAT+1
+ HRLS A ; READY TO HIT TABLE
+ ADD A,TD.LNT+1
+ JUMPGE A,BADTPL
+ MOVE C,B ; DATUM TO C
+ XCT (A) ; GET LENGTH
+ HLRZS C ; REST COUNTER
+ SUBI B,(C) ; FLUSH IT OFF
+ MOVEI B,(B) ; IN CASE FUNNY STUFF
+ MOVSI A,TFIX
+ POPJ P,
+
+; COMPILERS ENTRIES
+
+CILNT: SUBM M,(P)
+ PUSH P,[377777,,-1]
+ MOVE C,A
+ GETYP A,A
+ PUSHJ P,CPTYPE ; GET PRIMTYPE
+ JUMPE A,CILN1
+ PUSHJ P,@LENTBL(A) ; DISPATCH
+ MOVSI A,TFIX
+CILN2: SUB P,[1,,1]
+MPOPJ: SUBM M,(P)
+ POPJ P,
+
+CILN1: PUSH TP,C
+ PUSH TP,B
+ MCALL 1,LENGTH
+ JRST CILN2
+
+CILNQ: SUBM M,(P)
+ PUSH P,C
+ MOVE C,A
+ GETYP A,A
+ PUSHJ P,CPTYPE
+ JUMPE A,CILNQ1
+ PUSHJ P,@LENTBL(A)
+ POP P,C
+ SUBM M,(P)
+ MOVSI A,TFIX
+ CAMG B,C
+ JRST CPOPJ1
+ MOVSI A,TFALSE
+ MOVEI B,0
+ POPJ P,
+
+CILNQ1: PUSH TP,C
+ PUSH TP,B
+ PUSH TP,$TFIX
+ PUSH TP,(P)
+ MCALL 2,LENGTH?
+ SUBM M,(P)
+ GETYP 0,A
+ CAIE 0,TFALSE
+ AOS (P)
+ POPJ P,
+\f
+
+MFUNCTION BYTSIZ,SUBR,[BYTE-SIZE]
+
+ ENTRY 1
+
+ GETYP A,(AB)
+ PUSHJ P,SAT
+ CAIE A,SBYTE
+ JRST WTYP1
+ LDB B,[300600,,1(AB)]
+ MOVSI A,TFIX
+ JRST FINIS
+\f
+
+
+IDNT1: MOVE A,(AB) ;RETURN THE FIRST ARG
+ MOVE B,1(AB)
+ JRST FINIS
+
+IMFUNCTION QUOTE,FSUBR
+
+ ENTRY 1
+
+ GETYP A,(AB)
+ CAIE A,TLIST ;ARG MUST BE A LIST
+ JRST WTYP1
+ SKIPN B,1(AB) ;SHOULD HAVE A BODY
+ JRST TFA
+
+ HLLZ A,(B) ; GET IT
+ MOVE B,1(B)
+ JSP E,CHKAB
+ JRST FINIS
+
+MFUNCTION NEQ,SUBR,[N==?]
+
+ MOVEI D,1
+ JRST EQR
+
+MFUNCTION EQ,SUBR,[==?]
+
+ MOVEI D,0
+EQR: ENTRY 2
+
+ GETYP A,(AB) ;GET 1ST TYPE
+ GETYP C,2(AB) ;AND 2D TYPE
+ MOVE B,1(AB)
+ CAIN A,(C) ;CHECK IT
+ CAME B,3(AB)
+ JRST @TABLE2(D)
+ JRST @TABLE1(D)
+
+ITRUTH: MOVSI A,TATOM ;RETURN TRUTH
+ MOVE B,IMQUOTE T
+ JRST FINIS
+
+IFALSE: MOVSI A,TFALSE ;RETURN FALSE
+ MOVEI B,0
+ JRST FINIS
+
+TABLE1: ITRUTH
+TABLE2: IFALSE
+ ITRUTH
+
+\f
+
+
+MFUNCTION EMPTY,SUBR,EMPTY?
+
+ ENTRY 1
+
+ MOVE B,AB
+ PUSHJ P,PTYPE ;GET PRIMITIVE TYPE
+
+ MOVEI A,(A)
+ JUMPE A,WTYP1
+ SKIPN B,1(AB) ;GET THE ARG
+ JRST ITRUTH
+
+ CAIN A,PTMPLT ; TEMPLATE?
+ JRST EMPTPL
+ CAIE A,P2WORD ;A LIST?
+ JRST EMPT1 ;NO VECTOR OR CHSTR
+ JUMPE B,ITRUTH ;0 POINTER MEANS EMPTY LIST
+ JRST IFALSE
+
+
+EMPT1: CAIN A,PBYTE
+ JRST .+3
+ CAIE A,PCHSTR ;CHAR STRING?
+ JRST EMPT2 ;NO, VECTOR
+ HRRZ B,(AB) ; GET COUNT
+ JUMPE B,ITRUTH ;0 STRING WINS
+ JRST IFALSE
+
+EMPT2: JUMPGE B,ITRUTH
+ JRST IFALSE
+
+EMPTPL: PUSHJ P,LNTMPL ; GET LENGTH
+ JUMPE B,ITRUTH
+ JRST IFALSE
+
+; COMPILER'S ENTRY TO EMPTY
+
+CEMPTY: PUSH P,A
+ GETYP A,A
+ PUSHJ P,CPTYPE
+ POP P,0
+ JUMPE A,CEMPT2
+ JUMPE B,YES ; ALWAYS EMPTY
+ CAIN A,PTMPLT
+ JRST CEMPTP
+ CAIN A,P2WORD
+ JRST NO
+ CAIN A,PCHSTR
+ JRST .+3
+ JUMPGE B,YES
+ JRST NO
+ TRNE 0,-1 ; STRING, SKIP ON ZERO LENGTH FIELD
+ JRST NO
+ JRST YES
+
+CEMPTP: PUSHJ P,LNTMPL
+ JUMPE B,YES
+ JRST NO
+
+CEMPT2: PUSH TP,0
+ PUSH TP,B
+ MCALL 1,EMPTY?
+ JUMPE B,NO
+ JRST YES
+
+MFUNCTION NEQUAL,SUBR,[N=?]
+ PUSH P,[1]
+ JRST EQUALR
+
+MFUNCTION EQUAL,SUBR,[=?]
+ PUSH P,[0]
+EQUALR: ENTRY 2
+
+ MOVE C,AB ;SET UP TO CALL INTERNAL
+ MOVE D,AB
+ ADD D,[2,,2] ;C POINTS TO FIRS, D TO SECOND
+ PUSHJ P,IEQUAL ;CALL INTERNAL
+ JRST EQFALS ;NO SKIP MEANS LOSE
+ JRST EQTRUE
+EQFALS: POP P,C
+ JRST @TABLE2(C)
+EQTRUE: POP P,C
+ JRST @TABLE1(C)
+
+\f
+; COMPILER'S ENTRY TO =? AND N=?
+
+CINEQU: PUSH P,[0]
+ JRST .+2
+
+CIEQUA: PUSH P,[1]
+ PUSH TP,A
+ PUSH TP,B
+ PUSH TP,C
+ PUSH TP,D
+ MOVEI C,-3(TP)
+ MOVEI D,-1(TP)
+ SUBM M,-1(P) ; MAY BECOME INTERRUPTABLE
+ PUSHJ P,IEQUAL
+ JRST NOE
+ POP P,C
+ SUB TP,[4,,4] ; FLUSH TEMPS
+ JRST @CTAB1(C)
+
+NOE: POP P,C
+ SUB TP,[4,,4]
+ JRST @CTAB2(C)
+
+CTAB1: SETZ NOM
+CTAB2: SETZ YESM
+ SETZ NOM
+
+; INTERNAL EQUAL SUBROUTINE
+
+IEQUAL: MOVE B,C ;NOW CHECK THE ARGS
+ PUSHJ P,PTYPE
+ MOVE B,D
+ PUSHJ P,PTYPE
+ MOVE F,0 ; SAVE SAT FOR OFFSET HACK
+ GETYP 0,(C) ;NOW CHECK FOR EQ
+ GETYP B,(D)
+ MOVE E,1(C)
+ CAIN 0,(B) ;DONT SKIP IF POSSIBLE WINNER
+ CAME E,1(D) ;DEFINITE WINNER, SKIP
+ JRST IEQ1
+CPOPJ1: AOS (P) ;EQ, SKIP RETURN
+ POPJ P,
+
+
+IEQ1: CAIE 0,(B) ;SKIP IF POSSIBLE MATCH
+CPOPJ: POPJ P, ;NOT POSSIBLE WINNERS
+ CAIN F,SOFFS
+ JRST EQOFFS
+ JRST @EQTBL(A) ;DISPATCH
+
+PRDISP EQTBL,CPOPJ,[[P2WORD,EQLIST],[P2NWORD,EQVEC],[PNWORD,EQUVEC]
+[PARGS,EQVEC],[PCHSTR,EQCHST],[PTMPLT,EQTMPL],[PBYTE,EQCHST]]
+
+EQLIST: PUSHJ P,PUSHCD ;PUT ARGS ON STACK
+
+EQLST1: INTGO ;IN CASE OF CIRCULAR
+ HRRZ C,-2(TP) ;GET FIRST
+ HRRZ D,(TP) ;AND 2D
+ CAIN C,(D) ;EQUAL?
+ JRST EQLST2 ;YES, LEAVE
+ JUMPE C,EQLST3 ;NIL LOSES
+ JUMPE D,EQLST3
+ GETYP 0,(C) ;CHECK DEFERMENT
+ CAIN 0,TDEFER
+ HRRZ C,1(C) ;PICK UP POINTED TO CROCK
+ GETYP 0,(D)
+ CAIN 0,TDEFER
+ HRRZ D,1(D) ;POINT TO REAL GOODIE
+ PUSHJ P,IEQUAL ;CHECK THE CARS
+ JRST EQLST3 ;LOSE
+ HRRZ C,@-2(TP) ;CDR THE LISTS
+ HRRZ D,@(TP)
+ HRRZM C,-2(TP) ;AND STORE
+ HRRZM D,(TP)
+ JRST EQLST1
+
+EQLST2: AOS (P) ;SKIP RETRUN
+EQLST3: SUB TP,[4,,4] ;REMOVE CRUFT
+ POPJ P,
+\f
+; HERE FOR HACKING OFFSETS
+EQOFFS: HRRZ A,1(C)
+ HRRZ B,1(D) ; GET NUMBERS
+ CAIE A,(B) ; POSSIBLE WINNER IF SKIP
+ POPJ P,
+ PUSH TP,$TLIST
+ HLRZ A,1(C)
+ PUSH TP,A
+ PUSH TP,$TLIST
+ HLRZ A,1(D)
+ PUSH TP,A
+ JRST EQLST1 ; SEE IF THE TWO LISTS ARE EQUAL
+
+; HERE FOR HACKING TEMPLATE STRUCTURES
+
+EQTMPL: PUSHJ P,PUSHCD ; SAVE GOODIES
+ PUSHJ P,PUSHCD
+ MOVE C,1(C) ; CHECK REAL SATS
+ GETYP C,(C)
+ MOVE D,1(D)
+ GETYP 0,(D)
+ CAIE 0,(C) ; SKIP IF WINNERS
+ JRST EQTMP4
+ PUSH P,0 ; SAVE MAGIC OFFSET
+ MOVE B,-2(TP)
+ PUSHJ P,TM.LN1 ; RET LENGTH IN B
+ MOVEI B,(B) ; FLUSH FUNNY
+ HLRZ C,-2(TP)
+ SUBI B,(C)
+ PUSH P,B
+ MOVE C,(TP) ; POINTER TO OTHER GUY
+ ADD A,TD.LNT+1
+ XCT (A) ; OTHER LENGTH TO B
+ HLRZ 0,-2(TP) ; REST OFFSETTER
+ SUBI 0,1
+ PUSH P,0
+ MOVEI B,(B)
+ HLRZ C,(TP)
+ SUBI B,(C)
+ HRRZS -4(TP) ; UNDO RESTING (ACCOUNTED FOR BY STARTING
+ ; AT LATER ELEMENT)
+ HRRZS -6(TP)
+ CAME B,-1(P)
+ JRST EQTMP1
+
+EQTMP2: AOS C,(P)
+ SOSGE -1(P)
+ JRST EQTMP3 ; WIN!!
+
+ MOVE B,-6(TP) ; POINTER
+ MOVE 0,-2(P) ; GET MAGIC OFFSET
+ PUSHJ P,TMPLNT ; GET AN ELEMENT
+ MOVEM A,-3(TP)
+ MOVEM B,-2(TP)
+ MOVE C,(P)
+ MOVE B,-4(TP) ; OTHER GUY
+ MOVE 0,-2(P)
+ PUSHJ P,TMPLNT
+ MOVEM A,-1(TP)
+ MOVEM B,(TP)
+ MOVEI C,-3(TP)
+ MOVEI D,-1(TP)
+ PUSHJ P,IEQUAL ; RECURSE
+ JRST EQTMP1 ; LOSER
+ JRST EQTMP2 ; WINNER
+
+EQTMP3: AOS -3(P) ; WIN RETURN
+EQTMP1: SUB P,[3,,3] ; FLUSH JUNK
+EQTMP4: SUB TP,[10,,10]
+ POPJ P,
+
+
+
+EQVEC: HLRE A,1(C) ;GET LENGTHS
+ HLRZ B,1(D)
+ CAIE B,(A) ;SKIP IF EQUAL LENGTHS
+ POPJ P, ;LOSE
+ JUMPGE A,CPOPJ1 ;SKIP RETRUN WIN
+ PUSHJ P,PUSHCD ;SAVE ARGS
+
+EQVEC1: INTGO ;IN CASE LONG VECTOR
+ MOVE C,(TP)
+ MOVE D,-2(TP) ;ARGS TO C AND D
+ PUSHJ P,IEQUAL
+ JRST EQLST3
+ MOVE C,[2,,2] ;GET BUMPER
+ ADDM C,(TP)
+ ADDB C,-2(TP) ;BUMP BOTH POINTERS
+ JUMPL C,EQVEC1
+ JRST EQLST2
+
+EQUVEC: HLRE A,1(C) ;GET LENGTHS
+ HLRZ B,1(D)
+ CAIE B,(A) ;SKIP IF EQUAL
+ POPJ P,
+
+ HRRZ B,1(C) ;START COMPUTING DOPE WORD LOCN
+ SUB B,A ;B POINTS TO DOPE WORD
+ GETYP 0,(B) ;GET UNIFORM TYPE
+ HRRZ B,1(D) ;NOW FIND OTHER DOPE WORD
+ SUB B,A
+ GETYP B,(B) ;OTHER UNIFORM TYPE
+ CAIE 0,(B) ;TYPES THE SAME?
+ POPJ P, ;NO, LOSE
+
+ JUMPGE A,CPOPJ1 ;IF ZERO LENGTH ALREADY WON
+
+ HRLZI B,(B) ;TYPE TO LH
+ PUSH P,B ;AND SAVED
+ PUSHJ P,PUSHCD ;SAVE ARGS
+
+EQUV1: MOVEI C,1(TP) ;POINT TO WHERE WILL GO
+ PUSH TP,(P)
+ MOVE A,-3(TP) ;PUSH ONE OF THE VECTORS
+ PUSH TP,(A) ; PUSH ELEMENT
+ MOVEI D,1(TP) ;POINT TO 2D ARG
+ PUSH TP,(P)
+ MOVE A,-3(TP) ;AND PUSH ITS POINTER
+ PUSH TP,(A)
+ PUSHJ P,IEQUAL
+ JRST UNEQUV
+
+ SUB TP,[4,,4] ;POP TP
+ MOVE A,[1,,1]
+ ADDM A,(TP) ;BUMP POINTERS
+ ADDB A,-2(TP)
+ JUMPL A,EQUV1 ;JUMP IF STILL MORE STUFF
+ SUB P,[1,,1] ;POP OFF TYPE
+ JRST EQLST2
+
+UNEQUV: SUB P,[1,,1]
+ SUB TP,[10,,10]
+ POPJ P,
+\f
+
+
+EQCHST: HRRZ B,(C) ; GET LENGTHS
+ HRRZ A,(D)
+ CAIE A,(B) ;SAME
+ JRST EQCHS3 ;NO, LOSE
+ LDB 0,[300600,,1(C)]
+ LDB E,[300600,,1(D)]
+ CAIE 0,(E)
+ JRST EQCHS3
+ MOVE C,1(C)
+ MOVE D,1(D)
+ JUMPE A,EQCHS4 ;BOTH 0 LENGTH, WINS
+
+EQCHS2:
+ ILDB 0,C ;GET NEXT CHARS
+ ILDB E,D
+ CAME 0,E ; SKIP IF STILL WINNING
+ JRST EQCHS3 ; NOT =
+ SOJG A,EQCHS2
+
+EQCHS4: AOS (P)
+EQCHS3: POPJ P,
+
+PUSHCD: PUSH TP,(C)
+ PUSH TP,1(C)
+ PUSH TP,(D)
+ PUSH TP,1(D)
+ POPJ P,
+
+\f
+; REST/NTH/AT/PUT/GET
+
+; ARG CHECKER
+
+ARGS1: MOVE E,[JRST WTYP2] ; ERROR CONDITION FOR 2D ARG NOT FIXED
+ARGS2: HLRE 0,AB ; CHECK NO. OF ARGS
+ ASH 0,-1 ; TO - NO. OF ARGS
+ AOJG 0,TFA ; 0--TOO FEW
+ AOJL 0,TMA ; MORE THAT 2-- TOO MANY
+ MOVEI C,1 ; DEFAULT ARG2
+ JUMPN 0,ARGS4 ; GET STRUCTURED ARG
+ARGS3: GETYP A,2(AB)
+ CAIN A,TOFFS ; OFFSET?
+ JRST ARGOFF ; GO DO DECL-CHECK AND SUCH
+ CAIE A,TFIX ; SHOULD BE FIXED NUMBER
+ XCT E ; DO ERROR THING
+ SKIPGE C,3(AB) ; BETTER BE NON-NEGATIVE
+ JRST OUTRNG
+ARGS4: MOVEI B,(AB) ; POINT TO STRUCTURED POINTER
+ PUSHJ P,PTYPE ; GET PRIM TYPE
+ MOVEI E,(A) ; DISPATCH CODE TO E
+ MOVE A,(AB) ; GET ARG 1
+ MOVE B,1(AB)
+ POPJ P,
+ARGOFF: HLRZ B,3(AB) ; PICK UP DECL POINTER FOR OFFSET
+ JUMPE B,ARGOF1
+ MOVE A,(B) ; TYPE WORD
+ MOVE B,1(B) ; VALUE
+ MOVE C,(AB)
+ MOVE D,1(AB)
+ PUSHJ P,TMATCH ; CHECK THE DECL
+ JRST WTYP1 ; FIRST ARG WRONG TYPE
+ARGOF1: HRRE C,3(AB) ; GET THE FIX
+ JUMPL C,OUTRNG
+ JRST ARGS4 ; FINISH
+
+; REST
+
+IMFUNCTION REST,SUBR
+
+ ENTRY
+ PUSHJ P,ARGS1 ; GET AND CHECK ARGS
+ PUSHJ P,@RESTBL(E) ; DO IT BASED ON TYPE
+ MOVE C,A ; THE FOLLOWING IS TO MAKE STORAGE WORK
+ GETYP A,(AB)
+ PUSHJ P,SAT
+ CAIN A,SSTORE ; SKIP IF NOT STORAGE
+ MOVSI C,TSTORA ; USE ITS PRIMTYPE
+ MOVE A,C
+ JRST FINIS
+
+PRDISP RESTBL,IWTYP1,[[P2WORD,LREST],[PNWORD,UREST],[P2NWOR,VREST],[PARGS,AREST]
+[PCHSTR,SREST],[PTMPLT,TMPRST],[PBYTE,BREST]]
+
+; AT
+
+MFUNCTION AT,SUBR
+
+ ENTRY
+ PUSHJ P,ARGS1
+ SOJL C,OUTRNG
+ PUSHJ P,@ATTBL(E)
+ JRST FINIS
+
+PRDISP ATTBL,IWTYP1,[[P2WORD,LAT],[PNWORD,UAT],[P2NWORD,VAT],[PARGS,AAT]
+[PCHSTR,STAT],[PTMPLT,TAT],[PBYTE,BTAT]]
+
+\f
+; NTH
+
+MFUNCTION NTH,SUBR
+
+ ENTRY
+
+ PUSHJ P,ARGS1
+ SOJL C,OUTRNG
+ PUSHJ P,@NTHTBL(E)
+ JRST FINIS
+
+PRDISP NTHTBL,IWTYP1,[[P2WORD,LNTH],[PNWORD,UNTH],[P2NWOR,VNTH],[PARGS,ANTH]
+[PCHSTR,SNTH],[PTMPLT,TMPLNT],[PBYTE,BNTH]]
+
+; GET
+
+MFUNCTION GET,SUBR
+
+ ENTRY
+ MOVE E,IIGETP ; MAKE ARG CHECKER FAIL INTO GETPROP
+ PUSHJ P,ARGS5 ; CHECK ARGS
+ SOJL C,OUTRNG
+ SKIPN E,IGETBL(E) ; GET DISPATCH ADR
+ JRST IGETP ; REALLY PUTPROP
+ JUMPE 0,TMA
+ PUSHJ P,(E) ; DISPATCH
+ JRST FINIS
+
+PRDISP IGETBL,0,[[P2WORD,LNTH],[PNWORD,UNTH],[P2NWORD,VNTH],[PARGS,ANTH]
+[PCHSTR,SNTH],[PTMPLT,TMPLNT],[PBYTE,BNTH]]
+
+; GETL
+
+MFUNCTION GETL,SUBR
+
+ ENTRY
+ MOVE E,IIGETL ; ERROR HACK
+ PUSHJ P,ARGS5
+ SOJL C,OUTRNG ; LOSER
+ SKIPN E,IGTLTB(E)
+ JRST IGETLO ; REALLY GETPL
+ JUMPE 0,TMA
+ PUSHJ P,(E) ; DISPATCH
+ JRST FINIS
+
+IIGETL: JRST IGETLO
+
+PRDISP IGTLTB,0,[[P2WORD,LAT],[PNWORD,UAT],[P2NWORD,VAT],[PARGS,AAT]
+[PCHSTR,STAT],[PBYTE,BTAT]]
+
+
+; ARG CHECKER FOR PUT/GET/GETL
+
+ARGS5: HLRE 0,AB ; -# OF ARGS
+ ASH 0,-1
+ ADDI 0,2 ; 0 OR -1 WIN
+ JUMPG 0,TFA
+ AOJL 0,TMA ; MORE THAN 3
+ JRST ARGS3 ; GET ARGS
+\f
+; PUT
+
+MFUNCTION PUT,SUBR
+
+ ENTRY
+ MOVE E,IIPUTP
+ PUSHJ P,ARGS5 ; GET ARGS
+ SKIPN E,IPUTBL(E)
+ JRST IPUTP
+ CAML AB,[-5,,] ; SKIP IF GOOD ARRGS
+ JRST TFA
+ SOJL C,OUTRNG
+ PUSH TP,4(AB)
+ PUSH TP,5(AB)
+ PUSHJ P,(E)
+ MOVE A,(AB) ; RET STRUCTURE
+ MOVE B,1(AB)
+ JRST FINIS
+
+PRDISP IPUTBL,0,[[P2WORD,LPUT],[PNWORD,UPUT],[P2NWORD,VPUT],[PARGS,APUT]
+[PCHSTR,SPUT],[PTMPLT,TMPPUT],[PBYTE,BPUT]]
+
+; IN
+
+MFUNCTION IN,SUBR
+
+ ENTRY 1
+
+ MOVEI B,(AB) ; POINT TO ARG
+ PUSHJ P,PTYPE
+ MOVS E,A ; REAL DISPATCH TO E
+ MOVE B,1(AB)
+ MOVE A,(AB)
+ GETYP C,A ; IN CASE NEEDED
+ PUSHJ P,@INTBL(E)
+ JRST FINIS
+
+PRDISP INTBL,OTHIN,[[P2WORD,LNTH1],[PNWORD,UIN],[P2NWORD,VIN],[PARGS,AIN]
+[PCHSTR,SIN],[PTMPLT,TIN],[PBYTE,BINN]]
+
+OTHIN: CAIE C,TLOCN ; ASSOCIATION LOCATIVE
+ JRST OTHIN1 ; MAYBE LOCD
+ HLLZ 0,VAL(B)
+ PUSHJ P,RMONCH
+ MOVE A,VAL(B)
+ MOVE B,VAL+1(B)
+ POPJ P,
+
+OTHIN1: CAIN C,TLOCD
+ JRST VIN
+ JRST WTYP1
+
+\f
+; SETLOC
+
+MFUNCTION SETLOC,SUBR
+
+ ENTRY 2
+
+ MOVEI B,(AB) ; POINT TO ARG
+ PUSHJ P,PTYPE ; DO TYPE
+ MOVS E,A ; REAL TYPE
+ MOVE B,1(AB)
+ MOVE C,2(AB) ; PASS ARG
+ MOVE D,3(AB)
+ MOVE A,(AB) ; IN CASE
+ GETYP 0,A
+ PUSHJ P,@SETTBL(E)
+ MOVE A,2(AB)
+ MOVE B,3(AB)
+ JRST FINIS
+
+PRDISP SETTBL,OTHSET,[[P2WORD,LSTUF],[PNWORD,USTUF],[P2NWORD,VSTUF],[PARGS,ASTUF]
+[PCHSTR,SSTUF],[PTMPLT,TSTUF],[PBYTE,BSTUF]]
+
+OTHSET: CAIE 0,TLOCN ; ASSOC?
+ JRST OTHSE1
+ HLLZ 0,VAL(B) ; GET MONITORS
+ PUSHJ P,MONCH
+ MOVEM C,VAL(B)
+ MOVEM D,VAL+1(B)
+ POPJ P,
+
+OTHSE1: CAIE 0,TLOCD
+ JRST WTYP1
+ JRST VSTUF
+
+; LREST -- REST A LIST IN B BY AMOUNT IN C
+
+LREST: MOVSI A,TLIST
+ JUMPE C,CPOPJ
+ MOVE PVP,PVSTOR+1
+ MOVEM A,BSTO(PVP)
+
+LREST2: INTGO ;CHECK INTERRUPTS
+ JUMPE B,OUTRNG ; CANT CDR NIL
+ HRRZ B,(B) ;CDR THE LIST
+ SOJG C,LREST2 ;COUNT DOWN
+ MOVE PVP,PVSTOR+1
+ SETZM BSTO(PVP) ;RESET BSTO
+ POPJ P,
+
+\f
+; VREST -- REST A VECTOR, AREST -- REST AN ARG BLOCK
+
+VREST: SKIPA A,$TVEC ; FINAL TYPE
+AREST: HRLI A,TARGS
+ ASH C,1 ; TIMES 2
+ JRST UREST1
+
+; UREST -- REST A UVECTOR
+
+STORST: SKIPA A,$TSTORA
+UREST: MOVSI A,TUVEC
+UREST1: JUMPE C,CPOPJ
+ HRLI C,(C)
+ JUMPL C,OUTRNG
+ ADD B,C ; REST IT
+ CAILE B,-1 ; OUT OF RANGE ?
+ JRST OUTRNG
+ POPJ P,
+
+
+; SREST -- REST A STRING
+
+BREST: SKIPA D,[TBYTE]
+
+SREST: MOVEI D,TCHSTR
+ PUSH P,D
+ JUMPE C,SREST1
+ PUSH P,A ; SAVE TYPE WORD
+ PUSH P,C ; SAVE AMOUNT
+ MOVEI D,(A) ; GET LENGTH
+ CAILE C,(D) ; SKIP IF OK
+ JRST OUTRNG
+ LDB D,[366000,,B] ;POSITION FIELD OF BYTE POINTER
+ LDB A,[300600,,B] ;SIZE FIELD
+ PUSH P,A ;SAVE SIZE
+ IDIVI D,(A) ;COMPUT BYTES IN 1ST WORD
+ MOVEI 0,36. ;NOW COMPUTE BYTES PER WORD
+ IDIVI 0,(A) ;BYTES PER WORD IN 0
+ MOVE E,0 ;COPY OF BYTES PER WORD TO E
+ SUBI 0,(D) ;0 # OF UNSUED BYTES IN 1ST WORD
+ ADDB C,0 ;C AND 0 NO.OF CHARS FROM WORD BOUNDARY
+ IDIVI C,(E) ;C/ REL WORD D/ CHAR IN LAST
+ ADDI C,(B) ;POINTO WORD WITH C
+ POP P,A ;RESTORE BITS PER BYTE
+ JUMPN D,.+3 ; JUMP IF NOT WD BOUNDARY
+ MOVEI D,(E) ; USE FULL AMOUNT
+ SUBI C,1 ; POINT TO PREV WORD
+ IMULI A,(D) ;A/ BITS USED IN LAST WORD
+ MOVEI 0,36.
+ SUBI 0,(A) ;0 HAS NEW POSITION FIELD
+ DPB 0,[360600,,B] ;INTO BYTE POINTER
+ HRRI B,(C) ;POINT TO RIGHT WORD
+ POP P,C ; RESTORE AMOUNT
+ POP P,A
+ SUBI A,(C) ; NEW LENGTH
+SREST1: POP P,0
+ HRL A,0
+ POPJ P,
+
+; TMPRST -- REST A TEMPLATE DATA STRUCTURE
+
+TMPRST: PUSHJ P,TM.TOE ; CHECK ALL BOUNDS ETC.
+ MOVSI D,(D)
+ HLL C,D
+ MOVE B,C ; RET IN B
+ MOVSI A,TTMPLT
+ POPJ P,
+
+; LAT -- GET A LOCATIVE TO A LIST
+
+LAT: PUSHJ P,LREST ; GET POINTER
+ JUMPE B,OUTRNG ; YOU LOSE!
+ MOVSI A,TLOCL ; NEW TYPE
+ POPJ P,
+
+\f
+; UAT -- GET A LOCATIVE TO A UVECTOR
+
+UAT: PUSHJ P,UREST
+ MOVSI A,TLOCU
+ JRST POPJL
+
+; VAT -- GET A LOCATIVE TO A VECTOR
+
+VAT: PUSHJ P,VREST ; REST IT AND TYPE IT
+ MOVSI A,TLOCV
+ JRST POPJL
+
+; AAT -- GET A LOCATIVE TO AN ARGS BLOCK
+
+AAT: PUSHJ P,AREST
+ HRLI A,TLOCA
+POPJL: JUMPGE B,OUTRNG ; LOST
+ POPJ P,
+
+; STAT -- LOCATIVE TO A STRING
+
+STAT: PUSHJ P,SREST
+ TRNN A,-1 ; SKIP IF ANY LEFT
+ JRST OUTRNG
+ HRLI A,TLOCS ; LOCATIVE
+ POPJ P,
+
+; BTAT -- LOCATIVE TO A BYTE-STRING
+
+BTAT: PUSHJ P,BREST
+ TRNN A,-1 ; SKIP IF ANY LEFT
+ JRST OUTRNG
+ HRLI A,TLOCB ; LOCATIVE
+ POPJ P,
+
+; TAT -- LOCATIVE TO A TEMPLATE
+
+TAT: PUSHJ P,TMPRST
+ PUSH TP,A
+ PUSH TP,B
+ GETYP A,(B) ; GET REAL SAT
+ SUBI A,NUMSAT+1
+ HRLS A ; READY TO HIT TABLE
+ ADD A,TD.LNT+1
+ JUMPGE A,BADTPL
+ MOVE C,B ; DATUM TO C
+ XCT (A) ; GET LENGTH
+ HLRZS C ; REST COUNTER
+ SUBI B,(C) ; FLUSH IT OFF
+ JUMPE B,OUTRNG
+ MOVE B,(TP)
+ SUB TP,[2,,2]
+ MOVSI A,TLOCT
+ POPJ P,
+
+
+; LNTH -- NTH OF LIST
+
+LNTH: PUSHJ P,LAT
+LNTH1: PUSHJ P,RMONC0 ; CHECK READ MONITORS
+ HLLZ A,(B) ; GET GOODIE
+ MOVE B,1(B)
+ JSP E,CHKAB ; HACK DEFER
+ POPJ P,
+
+; VNTH -- NTH A VECTOR, ANTH -- NTH AN ARGS BLOCK
+
+ANTH: PUSHJ P,AAT
+ JRST .+2
+
+VNTH: PUSHJ P,VAT
+AIN:
+VIN: PUSHJ P,RMONC0
+ MOVE A,(B)
+ MOVE B,1(B)
+ POPJ P,
+
+; UNTH -- NTH OF UVECTOR
+
+UNTH: PUSHJ P,UAT
+UIN: HLRE C,B ; FIND DW
+ SUBM B,C
+ HLLZ 0,(C) ; GET MONITORS
+ MOVE D,0
+ TLZ D,TYPMSK#<-1>
+ PUSH P,D
+ PUSHJ P,RMONCH ; CHECK EM
+ POP P,A
+ MOVE B,(B) ; AND VALUE
+ POPJ P,
+
+\f
+; BNTH -- NTH A BYTE STRING
+
+BNTH: PUSHJ P,BTAT
+BINN: PUSH P,$TFIX
+ JRST SIN1
+
+; SNTH -- NTH A STRING
+
+SNTH: PUSHJ P,STAT
+SIN: PUSH P,$TCHRS
+SIN1: PUSH TP,A
+ PUSH TP,B ; SAVE POINT BYTER
+ MOVEI C,-1(TP) ; FIND DOPE WORD
+ PUSHJ P,BYTDOP
+ HLLZ 0,-1(A) ; GET
+ POP TP,B
+ POP TP,A
+ PUSHJ P,RMONCH
+ ILDB B,B ; GET CHAR
+ POP P,A
+ POPJ P,
+
+; TIN -- IN OF A TEMPLATE
+
+TIN: MOVEI C,0
+
+; TMPLNT -- NTH A TEMPLATE DATA STRUCTURE
+
+TMPLNT: ADDI C,1
+ PUSHJ P,TM.TOE ; GET POINTER TO INS IN E
+ ADD A,TD.GET+1 ; POINT TO GETTER
+ MOVE A,(A) ; GET VECTOR OF INS
+ ADDI E,-1(A) ; POINT TO INS
+ SUBI D,1
+ XCT (E) ; DO IT
+ JFCL ; SKIP IF AN ANY CASE
+ POPJ P, ; RETURN
+
+; LPUT -- PUT ON A LIST
+
+LPUT: PUSHJ P,LAT ; POSITION
+ POP TP,D
+ POP TP,C
+
+; LSTUF -- HERE TO STUFF A LIST ELEMENT
+
+LSTUF: PUSHJ P,MONCH0 ; CHECK OUT MONITOR BITS
+ GETYP A,C ; ISOLATE TYPE
+ PUSHJ P,NWORDT ; NEED TO DEFER?
+ SOJN A,DEFSTU
+ HLLM C,(B)
+ MOVEM D,1(B) ; AND VAL
+ POPJ P,
+
+DEFRCY: MOVE E,1(B) ; RECYCLE THIS HANDY DEFER
+ MOVEM C,(E)
+ MOVEM D,1(E)
+ POPJ P,
+
+DEFSTU: GETYP A,(B)
+ CAIN A,TDEFER
+ JRST DEFRCY
+ PUSH TP,$TLIST
+ PUSH TP,B
+ PUSH TP,C
+ PUSH TP,D
+ PUSHJ P,CELL2 ; GET WORDS
+ POP TP,1(B)
+ POP TP,(B)
+ MOVE E,(TP)
+ SUB TP,[2,,2]
+ MOVEM B,1(E)
+ HLLZ 0,(E) ; GET OLD MONITORS
+ TLZ 0,TYPMSK ; KILL TYPES
+ TLO 0,TDEFER ; MAKE DEFERRED
+ HLLM 0,(E)
+ POPJ P,
+
+; VPUT -- PUT ON A VECTOR , APUT -- PUT ON AN RG BLOCK
+
+APUT: PUSHJ P,AAT
+ JRST .+2
+
+VPUT: PUSHJ P,VAT ; TREAT LIKE VECTOR
+ POP TP,D ; GET GOODIE BACK
+ POP TP,C
+
+; AVSTUF -- CLOBBER ARGS AND VECTORS
+
+ASTUF:
+VSTUF: PUSHJ P,MONCH0
+ MOVEM C,(B)
+ MOVEM D,1(B)
+ POPJ P,
+
+\f
+
+
+; UPUT -- CLOBBER A UVECTOR
+
+UPUT: PUSHJ P,UAT ; GET IT RESTED
+ POP TP,D
+ POP TP,C
+
+; USTUF -- HERE TO CLOBBER A UVECTOR
+
+USTUF: HLRE E,B
+ SUBM B,E ; C POINTS TO DOPE
+ GETYP A,(E) ; GET UTYPE
+ GETYP 0,C
+ CAIE 0,(A) ; CHECK SAMENESS
+ JRST WRNGUT
+ HLLZ 0,(E) ; MONITOR BITS IN DOPE WORD
+ MOVSI A,TLOCU ; CHOMP, CHOMP (WAS TUVEC) -- MARC 5/2/78
+ PUSHJ P,MONCH
+ MOVEM D,(B) ; SMASH
+ POPJ P,
+
+; BPUT -- HERE TO PUT A BYTE-STRING
+
+BPUT: PUSHJ P,BTAT
+ POP TP,D
+ POP TP,C
+BSTUF: MOVEI E,TFIX
+ JRST SSTUF1
+
+; SPUT -- HERE TO PUT A STRING
+
+SPUT: PUSHJ P,STAT ; REST IT
+ POP TP,D
+ POP TP,C
+
+; SSTUF -- STUFF A STRING
+
+SSTUF: MOVEI E,TCHRS
+SSTUF1: GETYP 0,C ; BETTER BE CHAR
+ CAIE 0,(E)
+ JRST WTYP3
+ PUSH P,C
+ PUSH TP,A
+ PUSH TP,B
+ MOVEI C,-1(TP) ; FIND D.W.
+ PUSHJ P,BYTDOP
+ SKIPGE (A)-1 ; SKIP IF NOT REALLY ATOM
+ JRST PNMNG
+ HLLZ 0,(A)-1 ; GET MONITORS
+ POP TP,B
+ POP TP,A
+ POP P,C
+ PUSHJ P,MONCH
+ IDPB D,B ; STASH
+ POPJ P,
+
+PNMNG: POP TP,B
+ POP TP,A
+ PUSH TP,$TATOM
+ PUSH TP,EQUOTE ATTEMPT-TO-MUNG-ATOMS-PNAME
+ HRLI A,TCHSTR
+ PUSH TP,A
+ PUSH TP,B
+ MOVEI A,2
+ JRST CALER
+
+; TSTUF -- SETLOC A TEMPLATE
+
+TSTUF: PUSH TP,C
+ PUSH TP,D
+ MOVEI C,0
+
+; PUTTMP -- TEMPLATE PUTTER
+
+TMPPUT: ADDI C,1
+ PUSHJ P,TM.TOE ; GET E POINTING TO SLOT #
+ ADD A,TD.PUT+1 ; POINT TO INS
+ MOVE A,(A) ; GET VECTOR OF INS
+ ADDI E,-1(A)
+ POP TP,B ; NEW VAL TO A AND B
+ POP TP,A
+ SUBI D,1
+ XCT (E) ; DO IT
+ JRST BADPUT
+ POPJ P,
+
+TM.LN1: SUBI 0,NUMSAT+1
+ HRRZ A,0 ; RET FIXED OFFSET
+ HRLS 0
+ ADD 0,TD.LNT+1 ; USE LENGTHERS FOR TEST
+ JUMPGE 0,BADTPL
+ PUSH P,C
+ MOVE C,B
+ HRRZS 0 ; POINT TO TABLE ENTRY
+ PUSH P,A
+ XCT @0 ; DO IT
+ POP P,A
+ POP P,C
+ POPJ P,
+
+TM.TBL: MOVEI E,(D) ; TENTATIVE WINNER IN E
+ TLNN B,-1 ; SKIP IF REST HAIR EXISTS
+ POPJ P, ; NO, WIN
+
+ PUSH P,A ; SAVE OFFSET
+ HRLS A ; A IS REL OFFSET TO INS TABLE
+ ADD A,TD.GET+1 ; GET ONEOF THE TABLES
+ MOVE A,(A) ; TABLE POINTER TO A
+ MOVSI 0,-1(D) ; START SEEING IF PAST TEMP SPEC
+ ADD 0,A
+ JUMPL 0,CPOPJA ; JUMP IF E STILL VALID
+ HLRZ E,B ; BASIC LENGTH TO E
+ HLRE 0,A ; LENGTH OF TEMPLATE TO 0
+ ADDI 0,(E) ; 0 ==> # ELEMENTS IN REPEATING SEQUENCE
+ MOVNS 0
+ SUBM D,E ; E ==> # PAST BASIC WANTED
+ EXCH 0,E
+ IDIVI 0,(E) ; A ==> REL REST GUY WANTED
+ HLRZ E,B
+ ADDI E,1(A)
+CPOPJA: POP P,A
+ POPJ P,
+
+; TM.TOE -- GET RIGHT TEMPLATE # IN E
+; C/ OBJECT #, B/ OBJECT POINTER
+
+TM.TOE: GETYP 0,(B) ; GET REAL SAT
+ MOVEI D,(C) ; OBJ # TO D
+ HLRZ C,B ; REST COUNT
+ ADDI D,(C) ; FUDGE FOR REST COUNTER
+ MOVE C,B ; POINTER TO C
+ PUSHJ P,TM.LN1 ; GET LENGTH IN B (WATCH LH!)
+ CAILE D,(B) ; CHECK RANGE
+ JRST OUTRNG ; LOSER, QUIT
+ JRST TM.TBL ; GO COMPUTE TABLE OFFSET
+
+\f; ROUTINE FOR COMPILER CALLS RETS CODE IN E GOODIE IN A AND B
+; FIXES (P)
+
+CPTYEE: MOVE E,A
+ GETYP A,A
+ PUSHJ P,CPTYPE
+ JUMPE A,WTYPUN
+ SUBM M,-1(P)
+ EXCH E,A
+ POPJ P,
+
+; COMPILER CALLS TO MANY OF THESE GUYS
+
+CIREST: PUSHJ P,CPTYEE ; TYPE OF DISP TO E
+ HRRES C ; CLEAR LH, IN CASE IT'S AN OFFSET
+ JUMPL C,OUTRNG
+ CAIN 0,SSTORE
+ JRST CIRST1
+ PUSHJ P,@RESTBL(E)
+ JRST MPOPJ
+
+CIRST1: PUSHJ P,STORST
+ JRST MPOPJ
+
+CINTH: PUSHJ P,CPTYEE
+ HRRES C ; CLEAR LH
+ SOJL C,OUTRNG ; CHECK BOUNDS
+ PUSHJ P,@NTHTBL(E)
+ JRST MPOPJ
+
+CIAT: PUSHJ P,CPTYEE
+ SOJL C,OUTRNG
+ PUSHJ P,@ATTBL(E)
+ JRST MPOPJ
+
+CSETLO: PUSHJ P,CTYLOC
+ MOVSS E ; REAL DISPATCH
+ GETYP 0,A ; INCASE LOCAS OR LOCD
+ PUSH TP,C
+ PUSH TP,D
+ PUSHJ P,@SETTBL(E)
+ POP TP,B
+ POP TP,A
+ JRST MPOPJ
+
+CIN: PUSHJ P,CTYLOC
+ MOVSS E ; REAL DISPATCH
+ GETYP C,A
+ PUSHJ P,@INTBL(E)
+ JRST MPOPJ
+
+CTYLOC: MOVE E,A
+ GETYP A,A
+ PUSHJ P,CPTYPE
+ SUBM M,-1(P)
+ EXCH A,E
+ POPJ P,
+
+; COMPILER'S PUT,GET AND GETL
+
+CIGET: PUSH P,[0]
+ JRST .+2
+
+CIGETL: PUSH P,[1]
+ MOVE E,A
+ GETYP A,A
+ PUSHJ P,CPTYPE
+ EXCH A,E
+ JUMPE E,CIGET1 ; REAL GET, NOT NTH
+ GETYP 0,C ; INDIC FIX?
+ CAIE 0,TFIX
+ CAIN 0,TOFFS
+ JRST .+2
+ JRST CIGET1
+ POP P,E ; GET FLAG
+ AOS (P) ; ALWAYS SKIP
+ MOVE C,D ; # TO AN AC
+ JRST @.+1(E)
+ SETZ CINTH
+ SETZ CIAT
+
+CIGET1: POP P,E ; GET FLAG
+ JRST @GETTR(E) ; DO A REAL GET
+
+GETTR: SETZ CIGTPR
+ SETZ CIGETP
+
+CIPUT: SUBM M,(P)
+ MOVE E,A
+ GETYP A,A
+ PUSHJ P,CPTYPE
+ EXCH A,E
+ PUSH TP,-1(TP) ; PAIN AND SUFFERING
+ PUSH TP,-1(TP)
+ MOVEM A,-3(TP)
+ MOVEM B,-2(TP)
+ JUMPE E,CIPUT1
+ GETYP 0,C
+ CAIE 0,TFIX ; YES DO STRUCT
+ CAIN 0,TOFFS
+ JRST .+2
+ JRST CIPUT1
+ MOVE C,D
+ HRRES C
+ SOJL C,OUTRNG ; CHECK BOUNDS
+ PUSHJ P,@IPUTBL(E)
+PMPOPJ: POP TP,B
+ POP TP,A
+ JRST MPOPJ
+
+CIPUT1: PUSHJ P,IPUT
+ JRST PMPOPJ
+\f
+; SMON -- SET MONITOR BITS
+; B/ <POINTER TO LOCATIVE>
+; D/ <IORM> OR <ANDCAM>
+; E/ BITS
+
+SMON: GETYP A,(B)
+ PUSHJ P,PTYPE ; TO PRIM TYPE
+ HLRZS A
+ SKIPE A,SMONTB(A) ; DISPATCH?
+ JRST (A)
+
+; COULD STILL BE LOCN OR LOCD
+
+ GETYP A,(B) ; TYPE BACK
+ CAIE A,TLOCN
+ JRST SMON2 ; COULD BE LOCD
+ MOVE C,1(B) ; POINT
+ HRRI D,VAL(C) ; MAKE INST POINT
+ JRST SMON3
+
+SMON2: CAIE A,TLOCD
+ JRST WRONGT
+
+
+; SET LIST/TUPLE/ID LOCATIVE
+
+SMON4: HRR D,1(B) ; POINT TO TYPE WORD
+SMON3: XCT D
+ POPJ P,
+
+; SET UVEC LOC
+
+SMON5: HRRZ C,1(B) ; POINT TO TOP OF UV
+ HLRE 0,1(B)
+ SUB C,0 ; POINT TO DOPE
+ HRRI D,(C) ; POINT IN INST
+ JRST SMON3
+
+; SET CHSTR LOC
+
+SMON6: MOVEI C,(B) ; FOR BYTDOP
+ PUSHJ P,BYTDOP ; POINT TO DOPE
+ HRRI D,(A)-1
+ JRST SMON3
+
+PRDISP SMONTB,0,[[P2WORD,SMON4],[P2NWOR,SMON4],[PARGS,SMON4]
+[PNWORD,SMON5],[PCHSTR,SMON6],[PBYTE,SMON6]]
+
+\f
+; COMPILER'S MONAD?
+
+CIMON: PUSH P,A
+ GETYP A,A
+ PUSHJ P,CPTYPE
+ JUMPE A,CIMON1
+ POP P,A
+ JRST CEMPTY
+
+CIMON1: POP P,A
+ JRST YES
+
+; FUNCTION TO DECIDE IF FURTHER DECOMPOSITION POSSIBLE
+
+MFUNCTION MONAD,SUBR,MONAD?
+
+ ENTRY 1
+
+ MOVE B,AB ; CHECK PRIM TYPE
+ PUSHJ P,PTYPE
+ JUMPE A,ITRUTH ;RETURN ARGUMENT
+ SKIPE B,1(AB)
+ JRST @MONTBL(A) ;DISPATCH ON PTYPE
+ JRST ITRUTH
+
+PRDISP MONTBL,IFALSE,[[P2NWORD,MON1],[PNWORD,MON1],[PARGS,MON1]
+[PCHSTR,CHMON],[PTMPLT,TMPMON],[PBYTE,CHMON]]
+
+MON1: JUMPGE B,ITRUTH ;EMPTY VECTOR
+ JRST IFALSE
+
+CHMON: HRRZ B,(AB)
+ JUMPE B,ITRUTH
+ JRST IFALSE
+
+TMPMON: PUSHJ P,LNTMPL
+ JUMPE B,ITRUTH
+ JRST IFALSE
+
+CISTRU: GETYP A,A ; COMPILER CALL
+ PUSHJ P,ISTRUC
+ JRST NO
+ JRST YES
+
+ISTRUC: PUSHJ P,SAT ; STORAGE TYPE
+ SKIPE A,PRMTYP(A)
+ AOS (P) ; SKIP IF WINS
+ POPJ P,
+
+; SUBR TO CHECK FOR LOCATIVE
+
+MFUNCTION %LOCA,SUBR,[LOCATIVE?]
+
+ ENTRY 1
+ GETYP A,(AB)
+ PUSHJ P,LOCQQ
+ JRST IFALSE
+ JRST ITRUTH
+
+; SKIPS IF TYPE IN A IS A LOCATIVE
+
+LOCQ: GETYP A,(B) ; GET TYPE
+LOCQQ: PUSH P,A ; SAVE FOR LOCN/LOCD
+ PUSHJ P,SAT
+ MOVE A,PRMTYP(A)
+ JUMPE A,LOCQ1
+ SUB P,[1,,1]
+ TRNN A,-1
+LOCQ2: AOS (P)
+ POPJ P,
+
+LOCQ1: POP P,A ; RESTORE TYPE
+ CAIE A,TLOCN
+ CAIN A,TLOCD
+ JRST LOCQ2
+ POPJ P,
+
+\f
+; FUNCTION TO DETERMINE MEMBERSHIP IN LISTS AND VECTORS
+
+MFUNCTION MEMBER,SUBR
+
+ MOVE E,[PUSHJ P,EQLTST] ;TEST ROUTINE IN E
+ JRST MEMB
+
+MFUNCTION MEMQ,SUBR
+
+ MOVE E,[PUSHJ P,EQTST] ;EQ TESTER
+
+MEMB: ENTRY 2
+ MOVE B,AB ;POINT TO FIRST ARG
+ PUSHJ P,PTYPE ;CHECK PRIM TYPE
+ ADD B,[2,,2] ;POINT TO 2ND ARG
+ PUSHJ P,PTYPE
+ JUMPE A,WTYP2 ;2ND WRONG TYPE
+ PUSH TP,(AB)
+ PUSH TP,1(AB)
+ MOVE C,2(AB) ; FOR TUPLE CASE
+ SKIPE B,3(AB) ;GOBBLE LIST VECTOR ETC. POINTER
+ PUSHJ P,@MEMTBL(A) ;DISPATCH
+ JRST IFALSE ;OR REPORT LOSSAGE
+ JRST FINIS
+
+PRDISP MEMTBL,IWTYP2,[[P2WORD,MEMLST],[PNWORD,MUVEC],[P2NWORD,MEMVEC]
+[PARGS,MEMTUP],[PCHSTR,MEMCH],[PTMPLT,MEMTMP],[PBYTE,MEMBYT]]
+
+
+
+MEMLST: MOVSI 0,TLIST ;SET B'S TYPE TO LIST
+ MOVE PVP,PVSTOR+1
+ MOVEM 0,BSTO(PVP)
+ JUMPE B,MEMLS6 ; EMPTY LIST LOSE IMMEDIATE
+
+MEMLS1: INTGO ;CHECK INTERRUPTS
+ MOVEI C,(B) ;COPY POINTER
+ GETYP D,(C) ;GET TYPE
+ MOVSI A,(D) ;COPY
+ CAIE D,TDEFER ;DEFERRED?
+ JRST MEMLS2
+ MOVE C,1(C) ;GET DEFERRED DATUM
+ GETYPF A,(C) ;GET FULL TYPE WORD
+MEMLS2: MOVE C,1(C) ;GET DATUM
+ XCT E ;DO THE COMPARISON
+ JRST MEMLS3 ;NO MATCH
+ MOVSI A,TLIST
+MEMLS5: AOS (P)
+MEMLS6: MOVE PVP,PVSTOR+1
+ SETZM BSTO(PVP) ;RESET B'S TYPE
+ POPJ P,
+
+MEMLS3: HRRZ B,(B) ;STEP THROGH
+ JUMPN B,MEMLS1 ;STILL MORE TO DO
+MEMLS4: MOVSI A,TFALSE ;RETURN FALSE
+ JRST MEMLS6 ;RETURN 0
+
+MEMTUP: HRRZ A,C
+ TLOA A,TARGS
+MEMVEC: MOVSI A,TVEC ;CLOBBER B'S TYPE TO VECTOR
+ JUMPGE B,MEMLS4 ;EMPTY VECTOR
+ MOVE PVP,PVSTOR+1
+ MOVEM A,BSTO(PVP)
+
+MEMV1: INTGO ;CHECK FOR INTS
+ GETYPF A,(B) ;GET FULL TYPE
+ MOVE C,1(B) ;AND DATA
+ XCT E ;DO COMPARISON INS
+ JRST MEMV2 ;NOT EQUAL
+ MOVE PVP,PVSTOR+1
+ MOVE A,BSTO(PVP)
+ JRST MEMLS5 ;RETURN WITH POINTER
+\f
+MEMV2: ADD B,[2,,2] ;INCREMENT AND GO
+ JUMPL B,MEMV1 ;STILL WINNING
+MEMV3: MOVEI B,0
+ JRST MEMLS4 ;AND RETURN FALSE
+
+MUVEC: JUMPGE B,MEMLS4
+ GETYP A,-1(TP) ;GET TYPE OF GODIE
+ HLRE C,B ;LOOK FOR UNIFORM TYPE
+ SUBM B,C ;DOPE POINTER TO C
+ GETYP C,(C) ;GET THE TYPE
+ CAIE A,(C) ;ARE THEY THE SAME?
+ JRST MEMLS4 ;NO, LOSE
+ MOVSI A,TUVEC
+ CAIN 0,SSTORE
+ MOVSI A,TSTORA
+ PUSH P,A
+ MOVE PVP,PVSTOR+1
+ MOVEM A,BSTO(PVP)
+ MOVSI A,(C) ;TYPE TO LH
+ PUSH P,A ; SAVE FOR EACH TEST
+
+MUVEC1: INTGO ;CHECK OUT INTS
+ MOVE C,(B) ;GET DATUM
+ MOVE A,(P) ; GET TYPE
+ XCT E ;COMPARE
+ AOBJN B,MUVEC1 ;LOOP TO WINNAGE
+ SUB P,[1,,1]
+ POP P,A
+ JUMPGE B,MEMV3 ;LOSE RETURN
+
+MUVEC2: JRST MEMLS5
+
+
+MEMBYT: MOVEI 0,TFIX
+ MOVEI D,TBYTE
+ JRST MEMBY1
+
+MEMCH: MOVEI 0,TCHRS
+ MOVEI D,TCHSTR
+MEMBY1: GETYP A,-1(TP) ;IS ARG A SINGLE CHAR
+ CAIE 0,(A) ;SKIP IF POSSIBLE WINNER
+ JRST MEMSTR
+ MOVEI 0,(C)
+ MOVE D,(TP) ; AND CHAR
+
+MEMCH1: SOJL 0,MEMV3
+ MOVE E,B
+ ILDB A,B
+ CAIE A,(D) ;CHECK IT
+ SOJA C,MEMCH1
+
+MEMCH2: MOVE B,E
+ MOVE A,C
+ JRST MEMLS5
+
+MEMSTR: CAIN A,(D)
+ CAME E,[PUSHJ P,EQLTST]
+ JRST MEMV3
+ LDB A,[300600,,(TP)]
+ LDB 0,[300600,,B]
+ CAIE 0,(A)
+ JRST MEMV3
+ MOVEI 0,(C) ; GET # OF CHAR INTO 0
+ ILDB D,(TP)
+ PUSH P,D ; PUTS 1ST CHAR OF 1ST ARG ONTO STACK
+
+MEMST1: SOJL 0,MEMLS ; HUNTS FOR FIRST MATCHING CHAR
+ MOVE E,B
+ ILDB A,B
+ CAME A,(P)
+ SOJA C,MEMST1 ; MATCH FAILS TRY NEXT
+
+ PUSH P,B
+ PUSH P,E
+ PUSH P,C
+ PUSH P,0
+ MOVE E,(TP) ; MATCH WINS SAVE OLD VALUES FOR FAILING LOOP
+ HRRZ C,-1(TP) ; LENGTH OF 1ARG
+MEMST2: SOJE C,MEMWN ; WON -RAN OUT OF 1ARG FIRST-
+ SOJL MEMLSR ; LOST -RAN OUT OF 2ARG-
+ ILDB A,B
+ ILDB D,E
+ CAIN A,(D) ; SKP IF POSSIBLY LOST -BACK TO MEMST1-
+ JRST MEMST2
+
+ POP P,0
+ POP P,C
+ POP P,E
+ POP P,B
+ SOJA C,MEMST1
+
+MEMWN: MOVE B,-2(P) ; SETS UP ARGS LIKE MEMCH2 - HAVE WON
+ MOVE A,-1(P)
+ SUB P,[5,,5]
+ JRST MEMLS5
+
+MEMLSR: SUB P,[5,,5]
+ JRST MEMV3
+
+MEMLS: SUB P,[1,,1]
+ JRST MEMV3
+
+; MEMBERSHIP FOR TEMPLATE HACKER
+
+MEMTMP: GETYP 0,(B) ; GET REAL SAT
+ PUSH P,E
+ PUSH P,0
+ PUSH TP,A
+ PUSH TP,B ; SAVE GOOEIE
+ PUSHJ P,TM.LN1 ; GET LENGTH
+ MOVEI B,(B)
+ HLRZ A,(TP) ; FUDGE FOR REST
+ SUBI B,(A)
+ PUSH P,B ; SAVE LENGTH
+ PUSH P,[-1]
+ POP TP,B
+ POP TP,A
+ MOVE PVP,PVSTOR+1
+ MOVEM B,BSTO+1(PVP)
+
+MEMTM1: MOVE PVP,PVSTOR+1
+ SETZM BSTO(PVP)
+ AOS C,(P)
+ SOSGE -1(P)
+ JRST MEMTM2
+ MOVE 0,-2(P)
+ PUSHJ P,TMPLNT ; GET ITEM
+ EXCH C,B ; VALUE TO C, POINTER BACK TO B
+ MOVE E,-3(P)
+ MOVSI 0,TTMPLT
+ MOVE PVP,PVSTOR+1
+ MOVEM 0,BSTO(PVP)
+ XCT E
+ SKIPA
+ JRST MEMTM3
+ MOVE PVP,PVSTOR+1
+ MOVE B,BSTO+1(PVP)
+ JRST MEMTM1
+
+MEMTM3: MOVE PVP,PVSTOR+1
+ MOVE B,BSTO+1(PVP)
+ HRL B,(P) ; DO APPROPRIATE REST
+ AOS -4(P)
+MEMTM2: SUB P,[4,,4]
+ MOVSI A,TTMPLT
+ MOVE PVP,PVSTOR+1
+ SETZM BSTO(PVP)
+ POPJ P,
+
+EQTST: GETYP A,A
+ GETYP 0,-1(TP)
+ CAMN C,(TP) ;CHECK VALUE
+ CAIE 0,(A) ;AND TYPE
+ POPJ P,
+ JRST CPOPJ1
+
+EQLTST: MOVE PVP,PVSTOR+1
+ PUSH TP,BSTO(PVP)
+ PUSH TP,B
+ PUSH TP,A
+ PUSH TP,C
+ SETZM BSTO(PVP)
+ PUSH P,E ;SAVE INS
+ MOVEI C,-5(TP) ;SET UP CALL TO IEQUAL
+ MOVEI D,-1(TP)
+ AOS -1(P) ;ASSUME SKIP
+ PUSHJ P,IEQUAL ;GO INO EQUAL
+ SOS -1(P) ;UNDO SKIP
+ SUB TP,[2,,2] ;AND POOP OF CRAP
+ POP TP,B
+ MOVE PVP,PVSTOR+1
+ POP TP,BSTO(PVP)
+ POP P,E
+ POPJ P,
+
+; COMPILER MEMQ AND MEMBER
+
+CIMEMB: SKIPA E,[PUSHJ P,EQLTST]
+
+CIMEMQ: MOVE E,[PUSHJ P,EQTST]
+ SUBM M,(P)
+ PUSH TP,A
+ PUSH TP,B
+ GETYP A,C
+ PUSHJ P,CPTYPE
+ JUMPE A,WTYPUN
+ MOVE B,D ; STRUCT TO B
+ PUSHJ P,@MEMTBL(A)
+ TDZA 0,0 ; FLAG NO SKIP
+ MOVEI 0,1 ; FLAG SKIP
+ SUB TP,[2,,2]
+ JUMPE 0,NOM
+ SOS (P) ; SKIP RETURN
+ JRST MPOPJ
+\f
+
+; FUNCTION TO RETURN THE TOP OF A VECTOR , CSTRING OR UNIFORM VECTOR
+
+MFUNCTION TOP,SUBR
+
+ ENTRY 1
+
+ MOVE B,AB ;CHECK ARG
+ PUSHJ P,PTYPE
+ MOVEI E,(A)
+ MOVE A,(AB)
+ MOVE B,1(AB)
+ PUSHJ P,@TOPTBL(E) ;DISPATCH
+ JRST FINIS
+
+PRDISP TOPTBL,IWTYP1,[[PNWORD,UVTOP],[P2NWORD,VTOP],[PCHSTR,CHTOP],[PARGS,ATOP]
+[PTMPLT,BCKTOP],[PBYTE,BTOP]]
+
+BCKTOP: MOVEI B,(B) ; FIX UP POINTER
+ MOVSI A,TTMPLT
+ POPJ P,
+
+UVTOP: SKIPA A,$TUVEC
+VTOP: MOVSI A,TVEC
+ CAIN 0,SSTORE
+ MOVSI A,TSTORA
+ JUMPE B,CPOPJ
+ HLRE C,B ;AND -LENGTH
+ HRRZS B
+ SUB B,C ;POINT TO DOPE WORD
+ HLRZ D,1(B) ;TOTAL LENGTH
+ SUBI B,-2(D) ;POINT TO TOP
+ MOVNI D,-2(D) ;-LENGTH
+ HRLI B,(D) ;B NOW POINTS TO TOP
+ POPJ P,
+
+BTOP: SKIPA E,$TBYTE
+CHTOP: MOVSI E,TCHSTR
+ JUMPE B,CPOPJ
+ PUSH P,E
+ PUSH TP,A
+ PUSH TP,B
+ LDB 0,[360600,,(TP)] ; POSITION FIELD
+ LDB E,[300600,,(TP)] ; AND SIZE FILED
+ IDIVI 0,(E) ; 0/ BYTES IN 1ST WORD
+ MOVEI C,36. ; BITS PER WORD
+ IDIVI C,(E) ; BYTES PER WORD
+ PUSH P,C
+ SUBM C,0 ; UNUSED BYTES I 1ST WORD
+ ADD 0,-1(TP) ; LENGTH OF WORD BOUNDARIED STRING
+ MOVEI C,-1(TP) ; GET DOPE WORD
+ PUSHJ P,BYTDOP
+ HLRZ C,(A) ; GET LENGTH
+ SKIPGE -1(A) ; SKIP IF NOT REALLY ATOM
+ SUBI C,3 ; IF IT IS, 3 LESS WORDS
+ SUBI A,-1(C) ; START +1
+ MOVEI B,-1(A) ; SETUP BYTER
+ SUB A,(TP) ; WORDS DIFFERENT
+ IMUL A,(P) ; CHARS EXTRA
+ SUBM 0,A ; FINAL TOTAL TO A
+ HLL A,-1(P)
+ MOVE C,(P)
+ SUB P,[2,,2]
+ DPB E,[300600,,B]
+ IMULI E,(C) ; BITS USED IN FULL WORD
+ MOVEI C,36.
+ SUBI C,(E) ; WHERE TO POINT IN EMPTY? CASE
+ DPB C,[360600,,B]
+ SUB TP,[2,,2]
+ POPJ P,
+\f
+
+
+ATOP:
+
+GETATO: HLRE C,B ;GET -LENGTH
+ HRROS B
+ SUB B,C ;POINT PAST
+ GETYP 0,(B) ;GET NEXT TYPE (ASSURED OF BEING EITHER TINFO OR TENTRY)
+ CAIN 0,TENTRY ;IF ENTRY
+ JRST EASYTP ;WANT UNEVALUATED ARGS
+ HRRE C,(B) ;ELSE-- GET NO. OF ARGS (*-2)
+ SUBI B,(C) ;GO TO TOP
+ TLCA B,-1(C) ;STORE NUMBER IN TOP POINTER
+EASYTP: MOVE B,FRAMLN+ABSAV(B) ;GET ARG POINTER
+ HRLI A,TARGS
+ POPJ P,
+
+; COMPILERS ENTRY TO TOP
+
+CITOP: PUSHJ P,CPTYEE
+ CAIN E,P2WORD ; LIST?
+ JRST WTYPL
+ PUSHJ P,@TOPTBL(E)
+ JRST MPOPJ
+
+; FUNCTION TO CLOBBER THE CDR OF A LIST
+
+MFUNCTION PUTREST,SUBR,[PUTREST]
+ ENTRY 2
+
+ MOVE B,AB ;COPY ARG POINTER
+ PUSHJ P,PTYPE ;CHECK IT
+ CAIE A,P2WORD ;LIST?
+ JRST WTYP1 ;NO, LOSE
+ ADD B,[2,,2] ;AND NEXT ONE
+ PUSHJ P,PTYPE
+ CAIE A,P2WORD
+ JRST WTYP2 ;NOT LIST, LOSE
+ HRRZ B,1(AB) ;GET FIRST
+ JUMPE B,OUTRNG
+ MOVE D,3(AB) ;AND 2D LIST
+ CAIL B,HIBOT
+ JRST PURERR
+ HRRM D,(B) ;CLOBBER
+ MOVE A,(AB) ;RETURN CALLED TYPE
+ JRST FINIS
+
+\f
+
+; FUNCTION TO BACK UP A VECTOR, UVECTOR OR CHAR STRING
+
+MFUNCTION BACK,SUBR
+
+ ENTRY
+
+ MOVEI C,1 ;ASSUME BACKING UP ONE
+ JUMPGE AB,TFA ;NO ARGS IS TOO FEW
+ CAML AB,[-2,,0] ;SKIP IF MORE THAN 2 ARGS
+ JRST BACK1 ;ONLY ONE ARG
+ GETYP A,2(AB) ;GET TYPE
+ CAIE A,TFIX ;MUST BE FIXED
+ JRST WTYP2
+ SKIPGE C,3(AB) ;GET NUMBER
+ JRST OUTRNG
+ CAMGE AB,[-4,,0] ;SKIP IF WINNING NUMBER OF ARGS
+ JRST TMA
+BACK1: MOVE B,AB ;SET UP TO FIND TYPE
+ PUSHJ P,PTYPE ;GET PRIM TYPE
+ MOVEI E,(A)
+ MOVE A,(AB)
+ SKIPN B,1(AB) ;GET DATUM
+ JRST OUTRNG
+ PUSHJ P,@BCKTBL(E)
+ JRST FINIS
+
+PRDISP BCKTBL,IWTYP2,[[PNWORD,BACKU],[P2NWORD,BACKV],[PCHSTR,BACKC],[PARGS,BACKA]
+[PTMPLT,BCKTMP],[PBYTE,BACKB]]
+
+BACKV: LSH C,1 ;GENERAL, DOUBLE AMOUNT
+ SKIPA A,$TVEC
+BACKU: MOVSI A,TUVEC
+ CAIN 0,SSTORE
+ MOVSI A,TSTORA
+ HRLI C,(C) ;TO BOTH HALVES
+ SUB B,C ;BACK UP VECTOR POINTER
+ HLRE C,B ;FIND OUT IF OVERFLOW
+ SUBM B,C ;DOPE POINTER TO C
+ HLRZ D,1(C) ;GET LENGTH
+ SUBI C,-2(D) ;POINT TO TOP
+ ANDI C,-1
+ CAILE C,(B) ;SKIP IF A WINNER
+ JRST OUTRNG ;COMPLAIN
+BACKUV: POPJ P,
+
+BCKTMP: MOVSI C,(C)
+ SUB B,C ; FIX UP POINTER
+ JUMPL B,OUTRNG
+ MOVSI A,TTMPLT
+ POPJ P,
+
+BACKB: SKIPA E,[TBYTE]
+BACKC: MOVEI E,TCHSTR
+ PUSH TP,A
+ PUSH TP,B
+ ADDI A,(C) ; NEW LENGTH
+ HRLI A,(E)
+ PUSH P,A ; SAVE COUNT
+ LDB E,[300600,,B] ;BYTE SIZE
+ MOVEI 0,36. ;BITS PER WORD
+ IDIVI 0,(E) ;DIVIDE TO FIND BYTES/WORD
+ IDIV C,0 ;C/ WORDS BACK, D/BYTES BACK
+ SUBI B,(C) ;BACK WORDS UP
+ JUMPE D,CHBOUN ;CHECK BOUNDS
+
+ IMULI 0,(E) ;0/ BITS OCCUPIED BY FULL WORD
+ LDB A,[360600,,B] ;GET POSITION FILED
+BACKC2: ADDI A,(E) ;BUMP
+ CAIGE A,36.
+ JRST BACKC1 ;O.K.
+ SUB A,0
+ SUBI B,1 ;DECREMENT POINTER PART
+BACKC1: SOJG D,BACKC2 ;DO FOR ALL BYTES
+\f
+
+
+ DPB A,[360600,,B] ;FIX UP POINT BYTER
+CHBOUN: MOVEI C,-1(TP)
+ PUSHJ P,BYTDOP ; FIND DOPE WORD
+ HLRZ C,(A)
+ SKIPGE -1(A) ; SKIP IF NOT REALLY AN ATOM
+ SUBI C,3 ; ELSE FUDGE FOR VALUE CELL AND OBLIST SLOT
+ SUBI A,-1(C) ; POINT TO TOP
+ MOVE C,B ; COPY BYTER
+ IBP C
+ CAILE A,(C) ; SKIP IF OK
+ JRST OUTRNG
+ POP P,A ; RESTORE COUNT
+ SUB TP,[2,,2]
+ POPJ P,
+
+
+BACKA: LSH C,1 ;NUMBER TIMES 2
+ HRLI C,(C) ;TO BOTH HALVES
+ SUB B,C ;FIX POINTER
+ MOVE E,B ;AND SAVE
+ PUSHJ P,GETATO ;LOOK A T TOP
+ CAMLE B,E ;COMPARE
+ JRST OUTRNG
+ MOVE B,E
+ POPJ P,
+
+; COMPILER'S BACK
+
+CIBACK: PUSHJ P,CPTYEE
+ JUMPL C,OUTRNG
+ CAIN E,P2WORD
+ JRST WTYPL
+ PUSHJ P,@BCKTBL(E)
+ JRST MPOPJ
+\f
+MFUNCTION STRCOMP,SUBR
+
+ ENTRY 2
+
+ MOVE A,(AB)
+ MOVE B,1(AB)
+ MOVE C,2(AB)
+ MOVE D,3(AB)
+ PUSHJ P,ISTRCM
+ JRST FINIS
+
+ISTRCM: GETYP 0,A
+ CAIE 0,TCHSTR
+ JRST ATMCMP ; MAYBE ATOMS
+
+ GETYP 0,C
+ CAIE 0,TCHSTR
+ JRST WTYP2
+
+ MOVEI A,(A) ; ISOLATR LENGHTS
+ MOVEI C,(C)
+
+STRCO2: SOJL A,CHOTHE ; ONE STRING EXHAUSTED, CHECK OTHER
+ SOJL C,1BIG ; 1ST IS BIGGER
+ ILDB 0,B
+ ILDB E,D
+ CAIN 0,(E) ; SKIP IF DIFFERENT
+ JRST STRCO2
+ CAIL 0,(E) ; SKIP IF 2D BIGGER THAN 1ST
+ JRST 1BIG
+2BIG: MOVNI B,1
+ JRST RETFIX
+
+CHOTHE: JUMPN C,2BIG ; 2 IS BIGGER
+SM.CMP: TDZA B,B ; RETURN 0
+1BIG: MOVEI B,1
+RETFIX: MOVSI A,TFIX
+ POPJ P,
+
+ATMCMP: CAIE 0,TATOM ; COULD BE ATOM
+ JRST WTYP1 ; NO, QUIT
+ GETYP 0,C
+ CAIE 0,TATOM
+ JRST WTYP2
+
+ CAMN B,D ; SAME ATOM?
+ JRST SM.CMP
+ ADD B,[3,,3] ; SKIP VAL CELL ETC.
+ ADD D,[3,,3]
+
+ATMCM1: MOVE 0,(B) ; GET A WORD OF CHARS
+ CAME 0,(D) ; SAME?
+ JRST ATMCM3 ; NO, GET DIF
+ AOBJP B,ATMCM2
+ AOBJN D,ATMCM1 ; MORE TO COMPARE
+ JRST 1BIG ; 1ST IS BIGGER
+
+
+ATMCM2: AOBJP D,SM.CMP ; EQUAL
+ JRST 2BIG
+
+ATMCM3: LSH 0,-1 ; AVOID SIGN LOSSAGE
+ MOVE C,(D)
+ LSH C,-1
+ CAMG 0,C
+ JRST 2BIG
+ JRST 1BIG
+
+\f;ERROR COMMENTS FOR SOME PRIMITIVES
+
+OUTRNG: ERRUUO EQUOTE OUT-OF-BOUNDS
+
+WRNGUT: ERRUUO EQUOTE TYPES-DIFFER-IN-UNIFORM-VECTOR
+
+IIGETP: JRST IGETP ;FUDGE FOR MIDAS/STINK LOSSAGE
+IIPUTP: JRST IPUTP
+
+\f;SUPER USEFUL ERROR MESSAGES (USED BY WHOLE WORLD)
+
+WNA: ERRUUO EQUOTE WRONG-NUMBER-OF-ARGUMENTS
+
+TFA: ERRUUO EQUOTE TOO-FEW-ARGUMENTS-SUPPLIED
+
+TMA: ERRUUO EQUOTE TOO-MANY-ARGUMENTS-SUPPLIED
+
+WRONGT:
+WTYP: ERRUUO EQUOTE ARG-WRONG-TYPE
+
+IWTYP1:
+WTYP1: ERRUUO EQUOTE FIRST-ARG-WRONG-TYPE
+
+IWTYP2:
+WTYP2: ERRUUO EQUOTE SECOND-ARG-WRONG-TYPE
+
+BADTPL: ERRUUO EQUOTE BAD-TEMPLATE-DATA
+
+BADPUT: ERRUUO EQUOTE TEMPLATE-TYPE-VIOLATION
+
+WTYP3: ERRUUO EQUOTE THIRD-ARG-WRONG-TYPE
+
+WTYPL: ERRUUO EQUOTE INTERNAL-BACK-OR-TOP-OF-A-LIST
+
+WTYPUN: ERRUUO EQUOTE NON-STRUCTURED-ARG-TO-INTERNAL-PUT-REST-NTH-TOP-OR-BACK
+
+CALER1: MOVEI A,1
+CALER: HRRZ C,FSAV(TB)
+ PUSH TP,$TATOM
+ CAIL C,HIBOT
+ SKIPA C,@-1(C) ; SUBRS AND FSUBRS
+ MOVE C,3(C) ; FOR RSUBRS
+ PUSH TP,C
+ ADDI A,1
+ ACALL A,ERROR
+ JRST FINIS
+
+
+GETWNA: HLRZ B,(E)-2 ;GET LOSING COMPARE INSTRUCTION
+ CAIE B,(CAIE A,) ;AS EXPECTED ?
+ JRST WNA ;NO,
+ HRRE B,(E)-2 ;GET DESIRED NUMBER OF ARGS
+ HLRE A,AB ;GET ACTUAL NUMBER OF ARGS
+ CAMG B,A
+ JRST TFA
+ JRST TMA
+
+END
+\f
\ No newline at end of file
--- /dev/null
+TITLE PRINTER ROUTINE FOR MUDDLE
+
+RELOCATABLE
+
+.INSRT DSK:MUDDLE >
+
+.GLOBAL IPNAME,MTYO,RLOOKU,RADX,INAME,INTFCN,LINLN,DOIOTO,BFCLS1,ATOSQ,IGVAL
+.GLOBAL BYTPNT,OPNCHN,CHRWRD,IDVAL,CHARGS,CHFRM,CHLOCI,PRNTYP,PRTYPE,IBLOCK,WXCT
+.GLOBAL VECBOT,VAL,ITEM,INDIC,IOINS,DIRECT,TYPVEC,CHRPOS,LINPOS,ACCESS,PAGLN,ROOT,PROCID
+.GLOBAL BADCHN,WRONGD,CHNCLS,IGET,FNFFL,ILLCHO,BUFSTR,BYTDOP,6TOCHS,PURVEC,STBL,RXCT
+.GLOBAL TMPLNT,TD.LNT,BADTPL,MPOPJ,SSPEC1,GLOTOP,GTLPOS,SPSTOR,PVSTOR
+.GLOBAL CIPRIN,CIPRNC,CIPRN1,CPATM,CP1ATM,CPCATM,CPSTR,CP1STR,CPCSTR
+.GLOBAL CIFLTZ,CITERP,CIUPRS,CPCH,CPCH1,CICRLF,NONSPC
+
+BUFLNT==100 ; BUFFER LENGTH IN WORDS
+
+FLAGS==0 ;REGISTER USED TO STORE FLAGS
+CARRET==15 ;CARRIAGE RETURN CHARACTER
+ESCHAR=="\ ;ESCAPE CHARACTER
+SPACE==40 ;SPACE CHARACTER
+ATMBIT==200000 ;BIT SWITCH FOR ATOM-NAME PRINT
+NOQBIT==020000 ;SWITCH FOR NO ESCAPING OF OUTPUT (PRINC)
+SEGBIT==010000 ;SWITCH TO INDICATE PRINTING A SEGMENT
+SPCBIT==004000 ;SWITCH TO INDICATE "PRINT" CALL (PUT A SPACE AFTER)
+FLTBIT==002000 ;SWITCH TO INDICATE "FLATSIZE" CALL
+HSHBIT==001000 ;SWITCH TO INDICATE "PHASH" CALL
+TERBIT==000400 ;SWITCH TO INDICATE "TERPRI" CALL
+UNPRSE==000200 ;SWITCH TO INDICATE "UNPARSE" CALL
+ASCBIT==000100 ;SWITCH TO INDICATE USING A "PRINT" CHANNEL
+BINBIT==000040 ;SWITCH TO INDICATE USING A "PRINTB" CHANNEL
+CNTLPC==000020 ;SWITCH TO INDICATE USING ^P CODE IOT
+PJBIT==400000
+C.BUF==1
+C.PRIN==2
+C.BIN==4
+C.OPN==10
+C.READ==40
+
+
+\fMFUNCTION FLATSIZE,SUBR
+ DEFINE FLTMAX
+ 4(B) TERMIN
+ DEFINE FLTSIZ
+ 2(B)TERMIN
+;FLATSIZE TAKES TWO OR THREE ARGUMENTS: THE FIRST IS AN OBJECT THE SECOND
+;IS THE MAXIMUM SIZE BEFORE IT GIVES UP AN RETURNS FALSE
+;THE THIRD (OPTIONAL) ARGUMENT IS A RADIX
+ ENTRY
+ CAMG AB,[-2,,0] ;CHECK NUMBER OF ARGS
+ CAMG AB,[-6,,0]
+ JRST WNA
+ PUSH P,3(AB)
+
+ GETYP A,2(AB)
+ CAIE A,TFIX
+ JRST WTYP2 ;SECOND ARG NOT FIX THEN LOSE
+\r CAMG AB,[-4,,0] ;SEE IF THERE IS A RADIX ARGUMENT
+ JRST .+3 ; RADIX SUPPLIED
+ PUSHJ P,GTRADX ; GET THE RADIX FROM OUTCHAN
+ JRST FLTGO
+ GETYP A,4(AB) ;CHECK TO SEE THAT RADIX IS FIX
+ CAIE A,TFIX
+ JRST WTYP ;ERROR THIRD ARGUMENT WRONG TYPE
+ MOVE C,5(AB)
+ PUSHJ P,GETARG ; GET ARGS INTO A AND B
+FLTGO: POP P,D ; RESTORE FLATSIZE MAXIMUM
+ PUSHJ P,CIFLTZ
+ JFCL
+ JRST FINIS
+
+
+
+MFUNCTION UNPARSE,SUBR
+ DEFINE UPB
+ 0(B) TERMIN
+
+ ENTRY
+
+ JUMPGE AB,TFA
+ MOVE E,TP ;SAVE TP POINTER
+
+
+
+;TURN ON FLTBIT TO AVOID PRINTING LOSSAGE
+;TURN ON UNPRSE TO CAUSE CHARS TO BE STASHED
+ CAMG AB,[-2,,0] ;SKIP IF RADIX SUPPLIED
+ JRST .+3
+ PUSHJ P,GTRADX ;GET THE RADIX FROM OUTCHAN
+ JRST UNPRGO
+ CAMGE AB,[-5,,0] ;CHECK FOR TOO MANY
+ JRST TMA
+ GETYP 0,2(AB)
+ CAIE 0,TFIX ;SEE IF RADIX IS FIXED
+ JRST WTYP2
+ MOVE C,3(AB) ;GET RADIX\r
+ PUSHJ P,GETARG ;GET ARGS INTO A AND B
+UNPRGO: PUSHJ P,CIUPRS
+ JRST FINIS
+ JRST FINIS
+
+
+GTRADX: MOVE B,IMQUOTE OUTCHAN
+ PUSH P,0 ;SAVE FLAGS
+ PUSHJ P,IDVAL ;GET VALUE FOR OUTCHAN
+ POP P,0
+ GETYP A,A ;CHECK TYPE OF CHANNEL
+ CAIE A,TCHAN
+ JRST FUNCH1-1 ;IT IS A TP-POINTER
+ MOVE C,RADX(B) ;GET RADIX FROM OUTCHAN
+ JRST FUNCH1
+ MOVE C,(B)+6 ;GET RADIX FROM STACK
+
+FUNCH1: CAIG C,1 ;CHECK FOR STRANGE RADIX
+ MOVEI C,10. ;DEFAULT IF THIS IS THE CASE
+GETARG: MOVE A,(AB)
+ MOVE B,1(AB)
+ POPJ P,
+
+
+IMFUNCTION PRINT,SUBR
+ ENTRY
+ PUSHJ P,AGET ; GET ARGS
+ PUSHJ P,CIPRIN
+ JRST FINIS
+
+MFUNCTION PRINC,SUBR
+ ENTRY
+ PUSHJ P,AGET ; GET ARGS
+ PUSHJ P,CIPRNC
+ JRST FINIS
+
+MFUNCTION PRIN1,SUBR
+ ENTRY
+ PUSHJ P,AGET
+ PUSHJ P,CIPRN1
+ JRST FINIS
+
+
+MFUNCTION CRLF,SUBR
+ ENTRY
+ PUSHJ P,AGET1
+ PUSHJ P,CICRLF
+ JRST FINIS
+
+MFUNCTION TERPRI,SUBR
+ ENTRY
+ PUSHJ P,AGET1
+ PUSHJ P,CITERP
+ JRST FINIS
+
+\f
+CICRLF: SKIPA E,.
+CITERP: MOVEI E,0
+ SUBM M,(P)
+ MOVSI 0,TERBIT+SPCBIT ; SET UP FLAGS
+ PUSH P,E
+ PUSHJ P,TESTR ; TEST FOR GOOD CHANNEL
+ MOVEI A,CARRET ; MOVE IN CARRIAGE-RETURN
+ PUSHJ P,PITYO ; PRINT IT OUT
+ MOVEI A,12 ; LINE-FEED
+ PUSHJ P,PITYO
+ POP P,0
+ JUMPN 0,.+4
+ MOVSI A,TFALSE ; RETURN A FALSE
+ MOVEI B,0
+ JRST MPOPJ ; RETURN
+
+ MOVSI A,TATOM
+ MOVE B,IMQUOTE T
+ JRST MPOPJ
+
+TESTR: GETYP E,A
+ CAIN E,TCHAN ; CHANNEL?
+ JRST TESTR1 ; OK?
+ CAIE E,TTP
+ JRST BADCHN
+ HLRZS 0
+ IOR 0,A ; RESTORE FLAGS
+ HRLZS 0
+ POPJ P,
+TESTR1: HRRZ E,-2(B) ; GET IN FLAGS FROM CHANNEL
+ SKIPN IOINS(B)
+ PUSHJ P,OPENIT
+ TRNN E,C.OPN ; SKIP IF OPEN
+ JRST CHNCLS
+ TRC E,C.PRIN+C.OPN ; CHECK TO SEE THAT CHANNEL IS GOOD
+ TRNE E,C.PRIN+C.OPN
+ JRST BADCHN ; ITS A LOSER
+ TRNE E,C.BIN
+ JRST PSHNDL ; DON'T HANDLE BINARY
+ TLO ASCBIT ; ITS ASCII
+ POPJ P, ; ITS A WINNER
+
+PSHNDL: PUSH TP,C ; SAVE ARGS
+ PUSH TP,D
+ PUSH TP,A ; PUSH CHANNEL ONTO STACK
+ PUSH TP,B
+ PUSHJ P,BPRINT ; CHECK BUFFER
+ POP TP,B
+ POP TP,A
+ POP TP,D
+ POP TP,C
+ POPJ P,
+
+
+\f;CIUPRS NEEDS A RADIX IN C AND A TYPE-OBJECT PAIR IN A,B
+
+CIUPRS: SUBM M,(P) ; MODIFY M-POINTER
+ MOVE E,TP ; SAVE TP-POINTER
+ PUSH TP,[0] ; SLOT FOR FIRST STRING COPY
+ PUSH TP,[0]
+ PUSH TP,[0] ; AND SECOND STRING
+ PUSH TP,[0]
+ PUSH TP,A ; SAVE OBJECTS
+ PUSH TP,B
+ PUSH TP,$TTP ; SAVE TP POINTER
+ PUSH TP,E
+ PUSH P,C
+ MOVE D,[377777,,-1] ; MOVE IN MAXIMUM NUMBER FOR FLATSIZE
+ PUSHJ P,CIFLTZ ; FIND LENGTH OF STRING
+ FATAL UNPARSE BLEW IT
+ MOVEI A,4(B)
+ PUSH P,B
+ IDIVI A,5
+ PUSHJ P,IBLOCK ; GET A BLOCK
+ POP P,A
+ HRLI A,TCHSTR
+ HRLI B,010700
+ SUBI B,1
+ POP TP,E ; RESTORE TP-POINTER
+ SUB TP,[1,,1] ;GET RID OF TYPE WORD
+ MOVEM A,1(E) ; SAVE RESULTS
+ MOVEM A,3(E)
+ MOVEM B,2(E)
+ MOVEM B,4(E)
+ POP TP,B ; RESTORE THE WORLD
+ POP TP,A
+ POP P,C
+ MOVSI 0,FLTBIT+UNPRSE ; SET UP FLAGS
+ PUSHJ P,CUSET
+ JRST MPOPJ ; RETURN
+
+
+
+; FOR CIFLTZ C CONTAINS THE RADIX, D THE MAXIMUM NUMBER OF CHARACTERS,
+; A,B THE TYPE-OBJECT PAIR
+
+CIFLTZ: SUBM M,(P)
+ MOVE E,TP ; SAVE POINTER
+ PUSH TP,$TFIX ; PUSH ON FLATSIZE COUNT
+ PUSH TP,[0]
+ PUSH TP,$TFIX ; PUSH ON FLATSIZE MAXIMUM
+ PUSH TP,D
+ MOVSI 0,FLTBIT ; MOVE ON FLATSIZE FLAG
+ PUSHJ P,CUSET ; CONTINUE
+ JRST MPOPJ
+ SOS (P) ; SKIP RETURN
+ JRST MPOPJ ; RETURN
+
+; CUSET IS THE ROUTINE USED BY FLATSIZE AND UNPARSE TO DO THE PUSHING,POPING AND CALLING
+; NEEDED TO GET A RESULT.
+
+CUSET: PUSH TP,$TFIX ; PUSH ON RADIX
+ PUSH TP,C
+ PUSH TP,$TPDL
+ PUSH TP,P ; PUSH ON RETURN POINTER IN CASE FLATSIZE GETS A FALSE
+ PUSH TP,A ; SAVE OBJECTS
+ PUSH TP,B
+ MOVSI C,TTP ; CONSTRUCT TP-POINTER
+ HLR C,FLAGS ; SAVE FLAGS IN TP-POINTER
+ MOVE D,E
+ PUSH TP,C ; PUSH ON CHANNEL
+ PUSH TP,D
+ PUSHJ P,IPRINT ; GO TO INTERNAL PRINTER
+ POP TP,B ; GET IN TP POINTER
+ MOVE TP,B ; RESTORE POINTER
+ TLNN FLAGS,UNPRSE ; SEE IF UNPARSE CALL
+ JRST FLTGEN ; ITS A FLATSIZE
+ MOVE A,UPB+3 ; RETURN STRING
+ MOVE B,UPB+4
+ POPJ P, ; DONE
+FLTGEN: MOVE A,FLTSIZ-1 ; GET IN COUNT
+ MOVE B,FLTSIZ
+ AOS (P)
+ POPJ P, ; EXIT
+
+\f
+; CIPRIN,CIPRNC,CIPRN1,CPATM,CP1ATM,CPCATM,CPSTR,CP1STR,CPCSTR ALL ASSUME
+; THAT C,D CONTAIN THE OBJECT AND A AND B CONTAIN THE CHANNEL
+
+CIPRIN: SUBM M,(P)
+ MOVSI 0,SPCBIT ; SET UP FLAGS
+ PUSHJ P,TPRT ; PRINT INITIALIZATION
+ PUSHJ P,IPRINT
+ JRST TPRTE ; EXIT
+
+CIPRN1: SUBM M,(P)
+ MOVEI FLAGS,0 ; SET UP FLAGS
+ PUSHJ P,TPR1 ; INITIALIZATION
+ PUSHJ P,IPRINT ; PRINT IT OUT
+ JRST TPR1E ; EXIT
+
+CIPRNC: SUBM M,(P)
+ MOVSI FLAGS,NOQBIT ; SET UP FLAGS
+ PUSHJ P,TPR1 ; INITIALIZATION
+ PUSHJ P,IPRINT
+ JRST TPR1E ; EXIT
+\f
+; INITIALIZATION FOR PRINT ROUTINES
+
+TPRT: PUSHJ P,TESTR ; SEE IF CHANNEL IS OK
+ PUSH TP,C ; SAVE ARGUMENTS
+ PUSH TP,D
+ PUSH TP,A ; SAVE CHANNEL
+ PUSH TP,B
+ MOVEI A,CARRET ; PRINT CARRIAGE RETURN
+ PUSHJ P,PITYO
+ MOVEI A,12 ; AND LF
+ PUSHJ P,PITYO
+ MOVE A,-3(TP) ; MOVE IN ARGS
+ MOVE B,-2(TP)
+ POPJ P,
+
+; EXIT FOR PRINT ROUTINES
+
+TPRTE: POP TP,B ; RESTORE CHANNEL
+ MOVEI A,SPACE ; PRINT TRAILING SPACE
+ PUSHJ P,PITYO
+ SUB TP,[1,,1] ; GET RID OF CHANNEL TYPE-WORD
+ POP TP,B ; RETURN WHAT WAS PASSED
+ POP TP,A
+ JRST MPOPJ ; EXIT
+
+; INITIALIZATION FOR PRIN1 AND PRINC ROUTINES
+
+TPR1: PUSHJ P,TESTR ; SEE IF CHANNEL IS OK
+ PUSH TP,C ; SAVE ARGS
+ PUSH TP,D
+ PUSH TP,A ; SAVE CHANNEL
+ PUSH TP,B
+ MOVE A,-3(TP) ; GET ARGS
+ MOVE B,-2(TP)
+ POPJ P,
+
+; EXIT FOR PRIN1 AND PRINC ROUTINES
+
+TPR1E: SUB TP,[2,,2] ; REMOVE CHANNEL
+ POP TP,B ; RETURN ARGUMENTS THAT WERE GIVEN
+ POP TP,A
+ JRST MPOPJ ; EXIT
+
+
+\f
+CPATM: SUBM M,(P)
+ MOVSI C,TATOM ; GET TYPE FOR BINARY
+ MOVEI 0,SPCBIT ; SET UP FLAGS
+ PUSHJ P,TPRT ; PRINT INITIALIZATION
+ PUSHJ P,CPATOM ; PRINT IT OUT
+ JRST TPRTE ; EXIT
+
+CP1ATM: SUBM M,(P)
+ MOVE C,$TATOM
+ MOVEI FLAGS,0 ; SET UP FLAGS
+ PUSHJ P,TPR1 ; INITIALIZATION
+ PUSHJ P,CPATOM ; PRINT IT OUT
+ JRST TPR1E ; EXIT
+
+CPCATM: SUBM M,(P)
+ MOVE C,$TATOM
+ MOVSI FLAGS,NOQBIT ; SET UP FLAGS
+ PUSHJ P,TPR1 ; INITIALIZATION
+ PUSHJ P,CPATOM ; PRINT IT OUT
+ JRST TPR1E ; EXIT
+
+
+; THIS ROUTINE IS USD TO PRINT ONE CHARACTER. THE CHANNEL IS IN A AND B THE
+; CHARACTER IS IN C.
+CPCH1: TDZA 0,0
+CPCH: MOVEI 0,1
+ SUBM M,(P)
+ PUSH P,0
+ MOVSI FLAGS,NOQBIT
+ MOVE C,$TCHRS
+ PUSHJ P,TESTR ; SEE IF CHANNEL IS GOOD
+ EXCH D,(P) ; CHAR TO STACK, IND TO D
+ MOVE A,(P) ; MOVE IN CHARACTER FOR PITYO
+ JUMPE D,.+3
+ PUSHJ P,PRETIF
+ JRST .+2
+ PUSHJ P,PITYO
+ MOVE A,$TCHRST ; RETURN THE CHARACTER
+ POP P,B
+ JRST MPOPJ
+
+
+
+
+CPSTR: SUBM M,(P)
+ HRLI C,TCHSTR
+ MOVSI 0,SPCBIT ; SET UP FLAGS
+ PUSHJ P,TPRT ; PRINT INITIALIZATION
+ PUSHJ P,CPCHST ; PRINT IT OUT
+ JRST TPRTE ; EXIT
+
+CP1STR: SUBM M,(P)
+ HRLI C,TCHSTR
+ MOVEI FLAGS,0 ; SET UP FLAGS
+ PUSHJ P,TPR1 ; INITIALIZATION
+ PUSHJ P,CPCHST ; PRINT IT OUT
+ JRST TPR1E ; EXIT
+
+CPCSTR: SUBM M,(P)
+ HRLI C,TCHSTR
+ MOVSI FLAGS,NOQBIT ; SET UP FLAGS
+ PUSHJ P,TPR1 ; INITIALIZATION
+ PUSHJ P,CPCHST ; PRINT IT OUT
+ JRST TPR1E ; EXIT
+
+
+CPATOM: PUSH TP,A ; COPY ARGS FOR INTERNAL SAKE\r
+ PUSH TP,B
+ PUSH P,0 ; ATOM CALLER ROUTINE
+ PUSH P,C
+ JRST PATOM
+
+CPCHST: PUSH TP,A ; COPY ARGS FOR INTERNAL SAKE\r
+ PUSH TP,B
+ PUSH P,0 ; STRING CALLER ROUTINE
+ PUSH P,C
+ JRST PCHSTR
+
+
+\f\r
+AGET: MOVEI FLAGS,0
+ SKIPL E,AB ; COPY ARG POINTER
+ JRST TFA ;NO ARGS IS AN ERROR
+ ADD E,[2,,2] ;POINT AT POSSIBLE CHANNEL
+ JRST COMPT
+AGET1: MOVE E,AB ; GET COPY OF AB
+ MOVSI FLAGS,TERBIT
+
+COMPT: PUSH TP,$TFIX ;LEAVE ROOM ON STACK FOR ONE CHANNEL
+ PUSH TP,[0]
+ JUMPGE E,DEFCHN ;IF NO CHANNEL ARGUMENT, USE CURRENT BINDING
+ CAMG E,[-2,,0] ;IF MORE ARGS THEN ERROR
+ JRST TMA
+ MOVE A,(E) ;GET CHANNEL
+ MOVE B,(E)+1
+ JRST NEWCHN
+
+DEFCHN: MOVE B,IMQUOTE OUTCHAN
+ MOVSI A,TATOM
+ PUSH P,FLAGS ;SAVE FLAGS
+ PUSHJ P,IDVAL ;GET VALUE OF OUTCHAN
+ POP P,0
+
+NEWCHN: TLNE FLAGS,TERBIT ; SEE IF TERPRI
+ POPJ P,
+ MOVE C,(AB) ; GET ARGS
+ MOVE D,1(AB)
+ POPJ P,
+
+; HERE IF USING A PRINTB CHANNEL
+
+BPRINT: TLO FLAGS,BINBIT
+ SKIPE BUFSTR(B) ; ANY OUTPUT BUFFER?
+ POPJ P,
+
+; HERE TO GENERATE A STRING BUFFER
+
+ PUSH P,FLAGS
+ MOVEI A,BUFLNT ; GET BUFFER LENGTH
+ PUSHJ P,IBLOCK ; MAKE A BUFFER
+ MOVSI 0,TWORD+.VECT. ; CLOBBER U TYPE
+ MOVEM 0,BUFLNT(B)
+ SETOM (B) ; -1 THE BUFFER
+ MOVEI C,1(B)
+ HRLI C,(B)
+ BLT C,BUFLNT-1(B)
+ HRLI B,010700
+ SUBI B,1
+ MOVE C,(TP)
+ MOVEM B,BUFSTR(C) ; STOR BYTE POINTER
+ MOVE 0,[TCHSTR,,BUFLNT*5]
+ MOVEM 0,BUFSTR-1(C)
+ POP P,FLAGS
+ MOVE B,(TP)
+ POPJ P,
+\f
+
+IPRINT: PUSH P,C ; SAVE C
+ PUSH P,FLAGS ;SAVE PREVIOUS FLAGS
+ PUSH TP,A ;SAVE ARGUMENT ON TP-STACK
+ PUSH TP,B
+
+ INTGO ;ALLOW INTERRUPTS HERE
+
+ GETYP A,-1(TP) ;GET THE TYPE CODE OF THE ITEM
+ SKIPE C,PRNTYP+1 ; USER TYPE TABLE?
+ JRST PRDISP
+NORMAL: CAILE A,NUMPRI ;PRIMITIVE?
+ JRST PUNK ;JUMP TO ERROR ROUTINE IF CODE TOO GREAT
+ HRRO A,PRTYPE(A) ;YES-DISPATCH
+ JRST (A)
+
+; HERE FOR USER PRINT DISPATCH
+
+PRDISP: ADDI C,(A) ; POINT TO SLOT
+ ADDI C,(A)
+ SKIPE (C) ; SKIP EITHER A LOSER OR JRST DISP
+ JRST PRDIS1 ; APPLY EVALUATOR
+ SKIPN C,1(C) ; GET ADDR OR GO TO PURE DISP
+ JRST NORMAL
+ JRST (C)
+
+PRDIS1: SUB C,PRNTYP+1
+ PUSH P,C
+ PUSH TP,[TATOM,,-1] ; PUSH ON OUTCHAN FOR SPECBIND
+ PUSH TP,IMQUOTE OUTCHAN
+ PUSH TP,-5(TP)
+ PUSH TP,-5(TP)
+ PUSH TP,[0]
+ PUSH TP,[0]
+ PUSHJ P,SPECBIND
+ POP P,C ; RESTORE C
+ ADD C,PRNTYP+1 ; RESTORE C
+ PUSH TP,(C) ; PUSH ARGS FOR APPLY
+ PUSH TP,1(C)
+ PUSH TP,-9(TP)
+ PUSH TP,-9(TP)
+ MCALL 2,APPLY ; APPLY HACKER TO OBJECT
+ MOVEI E,-8(TP)
+ PUSHJ P,SSPEC1 ;UNBIND OUTCHAN
+ SUB TP,[6,,6] ; POP OFF STACK
+ JRST PNEXT
+
+; PRINT DISPATCH TABLE
+
+IF2,PUNKS==400000,,PUNK
+
+DISTBL PRTYPE,PUNKS,[[TATOM,PATOM],[TFORM,PFORM],[TSEG,PSEG],[TFIX,PFIX]
+[TFLOAT,PFLOAT],[TLIST,PLIST],[TVEC,PVEC],[TCHRS,PCHRS],[TCHSTR,PCHSTR]
+[TARGS,PARGS],[TUVEC,PUVEC],[TDEFER,PDEFER],[TINTH,PINTH],[THAND,PHAND]
+[TILLEG,ILLCH],[TRSUBR,PRSUBR],[TENTER,PENTRY],[TPCODE,PPCODE],[TTYPEW,PTYPEW]
+[TTYPEC,PTYPEC],[TTMPLT,TMPRNT],[TLOCD,LOCPT1],[TLOCR,LOCRPT],[TQRSUB,PRSUBR]
+[TQENT,PENTRY],[TSATC,PSATC],[TBYTE,PBYTE]
+[TOFFS,POFFSE]]
+
+PUNK: MOVE C,TYPVEC+1 ; GET AOBJN-POINTER TO VECTOR OF TYPE ATOMS
+ GETYP B,-1(TP) ; GET THE TYPE CODE INTO REG B
+ LSH B,1 ; MULTIPLY BY TWO
+ HRL B,B ; DUPLICATE IT IN THE LEFT HALF
+ ADD C,B ; INCREMENT THE AOBJN-POINTER
+ JUMPGE C,PRERR ; IF POSITIVE, INDEX > VECTOR SIZE
+
+ MOVE B,-2(TP) ; MOVE IN CHANNEL
+ PUSH TP,$TVEC ; SAVE ALLTYPES VECTOR
+ PUSH TP,C
+ PUSHJ P,RETIF1 ; START NEW LINE IF NO ROOM
+ MOVEI A,"# ; INDICATE TYPE-NAME FOLLOWS
+ PUSHJ P,PITYO
+ POP TP,C
+ SUB TP,[1,,1]
+ MOVE A,(C) ; GET TYPE-ATOM
+ MOVE B,1(C)
+ PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
+ PUSH TP,-3(TP)
+ PUSHJ P,IPRINT ; PRINT ATOM-NAME
+ SUB TP,[2,,2] ; POP STACK
+ MOVE B,-2(TP) ; MOVE IN CHANNEL
+ PUSHJ P,SPACEQ ; MAYBE SPACE
+ MOVE B,(B) ; RESET THE REAL ARGUMENT POINTER
+ HRRZ A,(C) ; GET THE STORAGE-TYPE
+ ANDI A,SATMSK
+ CAILE A,NUMSAT ; SKIP IF TEMPLATE
+ JRST TMPRNT ; PRINT TEMPLATED DATA STRUCTURE
+ HRRO A,UKTBL(A) ; USE DISPATCH TABLE ON STORAGE TYPE
+ JRST (A)
+
+DISTBS UKTBL,POCTAL,[[S2WORD,PLIST],[S2NWORD,PVEC],[SNWORD,PUVEC],[SATOM,PATOM]
+[SCHSTR,PCHSTR],[SFRAME,PFRAME],[SARGS,PARGS],[SPVP,PPVP],[SLOCID,LOCPT],[SLOCA,LOCP]
+[SLOCV,LOCP],[SLOCU,LOCP],[SLOCS,LOCP],[SLOCL,LOCP],[SLOCN,LOCP],[SASOC,ASSPNT]
+[SLOCT,LOCP],[SLOCB,LOCP],[SBYTE,PBYTE],[SOFFS,POFFSE]]
+ ; SELECK AN ILLEGAL
+
+ILLCH: MOVEI B,-1(TP)
+ JRST ILLCHO
+
+\f; PRINT INTERRUPT HANDLER
+
+PHAND: MOVE B,-2(TP) ; MOVE CHANNEL INTO B
+ PUSHJ P,RETIF1
+ MOVEI A,"#
+ PUSHJ P,PITYO ; SAY "FUNNY TYPE"
+ MOVSI A,TATOM
+ MOVE B,MQUOTE HANDLER
+ PUSH TP,-3(TP) ; PUSH CHANNEL ON FOR IPRINT
+ PUSH TP,-3(TP)
+ PUSHJ P,IPRINT ; PRINT THE TYPE NAME
+ SUB TP,[2,,2] ; POP CHANNEL OFF STACK
+ MOVE B,-2(TP) ; GET CHANNEL
+ PUSHJ P,SPACEQ ; SPACE MAYBE
+ SKIPN B,(TP) ; GET ARG BACK
+ JRST PNEXT
+ MOVE A,INTFCN(B) ; PRINT FUNCTION FOR NOW
+ MOVE B,INTFCN+1(B)
+ PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
+ PUSH TP,-3(TP)
+ PUSHJ P,IPRINT ; PRINT THE INT FUNCTION
+ SUB TP,[2,,2] ; POP CHANNEL OFF
+ JRST PNEXT
+
+; PRINT INT HEADER
+
+PINTH: MOVE B,-2(TP) ; GET CHANNEL INTO B
+ PUSHJ P,RETIF1
+ MOVEI A,"#
+ PUSHJ P,PITYO
+ MOVSI A,TATOM ; AND NAME
+ MOVE B,MQUOTE IHEADER
+ PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
+ PUSH TP,-3(TP)
+ PUSHJ P,IPRINT
+ MOVE B,-4(TP) ; GET CHANNEL INTO B
+ PUSHJ P,SPACEQ ; MAYBE SPACE
+ SKIPN B,-2(TP) ; INT HEADER BACK
+ JRST PINTH1
+ MOVE A,INAME(B) ; GET NAME
+ MOVE B,INAME+1(B)
+ PUSHJ P,IPRINT
+PINTH1: SUB TP,[2,,2] ; CLEAN OFF STACK
+ JRST PNEXT
+
+
+; PRINT ASSOCIATION BLOCK
+
+ASSPNT: MOVEI A,"( ; MAKE IT BE (ITEN INDIC VAL)
+ MOVE B,-2(TP) ; GET CHANNEL INTO B
+ PUSHJ P,PRETIF ; MAKE ROOM AND PRINT
+ SKIPA C,[-3,,0] ; # OF FIELDS
+ASSLP: PUSHJ P,SPACEQ
+ MOVE D,(TP) ; RESTORE GOODIE
+ ADD D,ASSOFF(C) ; POINT TO FIELD
+ MOVE A,(D) ; GET IT
+ MOVE B,1(D)
+ PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
+ PUSH TP,-3(TP)
+ PUSHJ P,IPRINT ; AND PRINT IT
+ SUB TP,[2,,2] ; POP OFF CHANNEL
+ MOVE B,-2(TP) ; GET CHANNEL
+ AOBJN C,ASSLP
+
+ MOVEI A,")
+ MOVE B,-2(TP) ; GET CHANNEL INTO B
+ PUSHJ P,PRETIF ; CLOSE IT
+ JRST PNEXT
+
+ASSOFF: ITEM
+ INDIC
+ VAL
+\f; PRINT TYPE-C AND TYPE-W
+
+PTYPEW: HRRZ A,(TP) ; POSSIBLE RH
+ HLRZ B,(TP)
+ MOVE C,MQUOTE TYPE-W
+ JRST PTYPEX
+
+PTYPEC: HRRZ B,(TP)
+ MOVEI A,0
+ MOVE C,MQUOTE TYPE-C
+
+PTYPEX: PUSH P,B
+ PUSH P,A
+ PUSH TP,$TATOM
+ PUSH TP,C
+ MOVEI A,2
+ MOVE B,-4(TP) ; GET CHANNEL INTO B
+ PUSHJ P,RETIF ; ROOM TO START?
+ MOVEI A,"%
+ PUSHJ P,PITYO
+ MOVEI A,"<
+ PUSHJ P,PITYO
+ POP TP,B ; GET NAME
+ POP TP,A
+ PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
+ PUSH TP,-3(TP)
+ PUSHJ P,IPRINT ; AND PRINT IT AS 1ST ELEMENT
+ SUB TP,[2,,2] ; POP OFF CHANNEL
+ MOVE B,-2(TP) ; GET CHANNEL INTO B
+ PUSHJ P,SPACEQ ; MAYBE SPACE
+ MOVE A,-1(P) ; TYPE CODE
+ ASH A,1
+ HRLI A,(A) ; MAKE SURE WINS
+ ADD A,TYPVEC+1
+ JUMPL A,PTYPX1 ; JUMP FOR A WINNER
+ ERRUUO EQUOTE BAD-TYPE-CODE
+
+PTYPX1: MOVE B,1(A) ; GET TYPE NAME
+ HRRZ A,(A) ; AND SAT
+ ANDI A,SATMSK
+ MOVEM A,-1(P) ; AND SAVE IT
+ MOVSI A,TATOM
+ PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
+ PUSH TP,-3(TP)
+ PUSHJ P,IPRINT ; OUT IT GOES
+ SUB TP,[2,,2] ; POP OFF CHANNEL
+ MOVE B,-2(TP) ; GET CHANNEL INTO B
+ PUSHJ P,SPACEQ ; MAYBE SPACE
+ MOVE A,-1(P) ; GET SAT BACK
+ MOVE B,IMQUOTE TEMPLATE
+ CAIGE A,NUMSAT
+ MOVE B,@STBL(A)
+ MOVSI A,TATOM ; AND PRINT IT
+ PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
+ PUSH TP,-3(TP)
+ PUSHJ P,IPRINT
+ SUB TP,[2,,2] ; POP OFF STACK
+ SKIPN B,(P) ; ANY EXTRA CRAP?
+ JRST PTYPX2
+
+ MOVE B,-2(TP) ; GET CHANNEL INTO B
+ PUSHJ P,SPACEQ
+ MOVE B,(P)
+ MOVSI A,TFIX
+ PUSH TP,-3(TP) ; PUSH CHANNELS FOR IPRINT
+ PUSH TP,-3(TP)
+ PUSHJ P,IPRINT ; PRINT EXTRA
+ SUB TP,[2,,2] ; POP OFF CHANNEL
+
+PTYPX2: MOVEI A,">
+ MOVE B,-2(TP) ; GET CHANNEL INTO B
+ PUSHJ P,PRETIF
+ SUB P,[2,,2] ; FLUSH CRUFT
+ JRST PNEXT
+
+\f; PRIMTYPE CODE
+
+; PRINT PURE CODE POINTER
+
+PSATC: MOVEI A,2
+ MOVE B,-2(TP) ; GET CHANNEL INTO B
+ PUSHJ P,RETIF
+ MOVEI A,"%
+ PUSHJ P,PITYO
+ MOVEI A,"<
+ PUSHJ P,PITYO
+ MOVSI A,TATOM ; PRINT SUBR CALL
+ MOVE B,MQUOTE PRIMTYPE-C
+ PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
+ PUSH TP,-3(TP)
+ PUSHJ P,IPRINT
+ MOVE B,-4(TP) ; GET CHANNEL INTO B
+ PUSHJ P,SPACEQ ; MAYBE SPACE?
+ MOVE A,-2(TP)
+ CAILE A,NUMSAT
+ JRST TMPPTY
+
+ MOVE B,@STBL(A)
+ JRST PSATC1
+
+TMPPTY: MOVE B,TYPVEC+1
+PSATC3: HRRZ C,(B)
+ ANDI C,SATMSK
+ CAIN A,(C)
+ JRST PSATC2
+ ADD B,[2,,2]
+ JUMPL B,PSATC3
+
+ ERRUUO EQUOTE BAD-PRIMTYPEC
+
+PSATC2: MOVE B,1(B)
+PSATC1: MOVSI A,TATOM
+ PUSHJ P,IPRINT
+ SUB TP,[2,,2]
+ MOVEI A,">
+ MOVE B,-2(TP) ; GET CHANNEL INTO B
+ PUSHJ P,PRETIF ; CLOSE THE FORM
+ JRST PNEXT
+
+
+PPCODE: MOVEI A,2
+ MOVE B,-2(TP) ; GET CHANNEL INTO B
+ PUSHJ P,RETIF
+ MOVEI A,"%
+ PUSHJ P,PITYO
+ MOVEI A,"<
+ PUSHJ P,PITYO
+ MOVSI A,TATOM ; PRINT SUBR CALL
+ MOVE B,MQUOTE PCODE
+ PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
+ PUSH TP,-3(TP)
+ PUSHJ P,IPRINT
+ MOVE B,-4(TP) ; GET CHANNEL INTO B
+ PUSHJ P,SPACEQ ; MAYBE SPACE?
+ HLRZ A,-2(TP) ; OFFSET TO VECTOR
+ ADD A,PURVEC+1 ; SLOT TO A
+ MOVE A,(A) ; SIXBIT NAME
+ PUSH P,FLAGS
+ PUSHJ P,6TOCHS ; TO A STRING
+ POP P,FLAGS
+ PUSHJ P,IPRINT
+ MOVE B,-4(TP) ; GET CHANNEL INTO B
+ PUSHJ P,SPACEQ
+ HRRZ B,-2(TP) ; GET OFFSET
+ MOVSI A,TFIX\r
+ PUSHJ P,IPRINT
+ SUB TP,[2,,2] ; POP CHANNEL OFF STACK
+ MOVEI A,">
+ MOVE B,-2(TP) ; GET CHANNEL INTO B
+ PUSHJ P,PRETIF ; CLOSE THE FORM
+ JRST PNEXT
+
+
+\f; PRINT SUB-ENTRY TO RSUBR
+
+PENTRY: MOVE B,(TP) ; GET BLOCK
+ GETYP A,(B) ; TYPE OF 1ST ELEMENT
+ CAIE A,TRSUBR ; RSUBR, OK
+ JRST PENT1
+PENT2: MOVEI A,2 ; CHECK ROOM
+ MOVE B,-2(TP) ; GET CHANNEL INTO B
+ PUSHJ P,RETIF
+ MOVEI A,"% ; SETUP READ TIME MACRO
+ PUSHJ P,PITYO
+ MOVEI A,"<
+ PUSHJ P,PITYO
+ MOVSI A,TATOM
+ MOVE B,IMQUOTE RSUBR-ENTRY
+ PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
+ PUSH TP,-3(TP)
+ PUSHJ P,IPRINT
+ MOVE B,-4(TP)
+ PUSHJ P,SPACEQ ; MAYBE SPACE
+ MOVEI A,"' ; QUOTE TO AVOID EVALING IT
+ PUSHJ P,PRETIF
+ MOVEI A,"[ ; OPEN SQUARE BRAKET
+ PUSHJ P,PRETIF
+ MOVE B,-2(TP)
+ GETYP A,(B)
+ CAIN A,TRSUBR
+ JRST PENT3
+ MOVE A,(B)
+ MOVE B,1(B)
+ PUSHJ P,IPRINT
+ MOVE B,-4(TP) ; MOVE IN CHANNEL
+ JRST PENT4
+PENT3: MOVE A,1(B)
+ MOVE B,3(A)
+ MOVSI A,TATOM ; FOOL EVERYBODY AND SEND OUT ATOM
+ PUSHJ P,IPRINT
+ MOVE B,-4(TP) ; PRINT SPACE
+PENT4: PUSHJ P,SPACEQ
+ MOVE B,-2(TP) ; GET PTR BACK TO VECTOR
+ MOVE A,2(B) ; THE NAME OF THE ENTRY
+ MOVE B,3(B)
+ PUSHJ P,IPRINT ; OUT IT GOES
+ CAMLE B,[-4,,-1] ; SEE IF DONE
+ JRST EXPEN
+ MOVE B,-4(TP) ; PRINT SPACE
+ PUSHJ P,SPACEQ
+ MOVE B,-2(TP) ; GET POINTER
+ MOVE A,4(B) ; DECL
+ MOVE B,5(B)
+ PUSHJ P,IPRINT
+ MOVE B,-4(TP) ; GET CHANNEL INTO B
+EXPEN: MOVEI A,"] ; CLOSE SQUARE BRAKET
+ PUSHJ P,PRETIF
+ MOVE B,-4(TP) ; GET CHANNEL INTO B
+ PUSHJ P,SPACEQ
+ MOVE B,-2(TP)
+ HRRZ B,2(B)
+ MOVSI A,TFIX
+ PUSHJ P,IPRINT
+ MOVEI A,">
+ SUB TP,[2,,2] ; POP CHANNEL OFF STACK
+ MOVE B,-2(TP) ; GET CHANNEL INTO B
+ PUSHJ P,PRETIF
+ JRST PNEXT
+
+PENT1: CAIN A,TATOM
+ JRST PENT2
+ ERRUUO EQUOTE BAD-ENTRY-BLOCK
+
+\f; HERE TO PRINT TEMPLATED DATA STRUCTURE
+
+TMPRNT: PUSH P,FLAGS ; SAVE FLAGS
+ MOVE A,(TP) ; GET POINTER
+ GETYP A,(A) ; GET SAT
+ PUSH P,A ; AND SAVE IT
+ MOVEI A,"{ ; OPEN SQUIGGLE
+ MOVE B,-2(TP) ; GET CHANNEL INTO B
+ PUSHJ P,PRETIF ; PRINT WITH CHECKING
+ HLRZ A,(TP) ; GET AMOUNT RESTED OFF
+ SUBI A,1
+ PUSH P,A ; AND SAVE IT
+ MOVE A,-1(P) ; GET SAT
+ SUBI A,NUMSAT+1 ; FIXIT UP
+ HRLI A,(A)
+ ADD A,TD.LNT+1 ; CHECK FOR WINNAGE
+ JUMPGE A,BADTPL ; COMPLAIN
+ HRRZS C,(TP) ; GET LENGTH
+ XCT (A) ; INTO B
+ SUB B,(P) ; FUDGE FOR RESTS
+ MOVEI B,-1(B) ; FUDGE IT
+ PUSH P,B ; AND SAVE IT
+
+TMPRN1: AOS C,-1(P) ; GET ELEMENT OF INTEREST
+ SOSGE (P) ; CHECK FOR ANY LEFT
+ JRST TMPRN2 ; ALL DONE
+
+ MOVE B,(TP) ; POINTER
+ HRRZ 0,-2(P) ; SAT
+ PUSHJ P,TMPLNT ; GET THE ITEM
+ MOVE FLAGS,-3(P) ; RESTORE FLAGS
+ PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
+ PUSH TP,-3(TP)
+ PUSHJ P,IPRINT ; PRINT THIS ELEMENT
+ SUB TP,[2,,2] ; POP CHANNEL OFF STACK
+ MOVE B,-2(TP) ; GET CHANNEL INTO B
+ SKIPE (P) ; IF NOT LAST ONE THEN
+ PUSHJ P,SPACEQ ; SEPARATE WITH A SPACE
+ JRST TMPRN1
+
+TMPRN2: SUB P,[4,,4]
+ MOVE B,-2(TP)
+ MOVEI A,"} ; CLOSE THIS GUY
+ PUSHJ P,PRETIF
+ JRST PNEXT
+
+
+\f; RSUBR PRINTING ROUTINES. ON PRINTB CHANNELS, WRITES OUT
+; COMPACT BINARY. ON PRINT CHANNELS ALL IS ASCII
+
+PRSUBR: MOVE A,(TP) ; GET RSUBR IN QUESTION
+ GETYP A,(A) ; CHECK FOR PURE RSUBR
+ CAIN A,TPCODE
+ JRST PRSBRP ; PRINT IT SPECIAL WAY
+
+ TLNN FLAGS,BINBIT ; SKIP IF BINARY OUTPUT
+ JRST ARSUBR
+
+ PUSH P,FLAGS
+ MOVSI A,TRSUBR ; FIND FIXUPS
+ MOVE B,(TP)
+ HLRE D,1(B) ; -LENGTH OF CODE VEC
+ PUSH P,D ; SAVE SAME
+ MOVSI C,TATOM
+ MOVE D,IMQUOTE RSUBR
+ PUSHJ P,IGET ; GO GET THEM
+ JUMPE B,RCANT ; NO FIXUPS, BINARY LOSES
+ PUSH TP,A ; SAVE FIXUP LIST
+ PUSH TP,B
+
+ MOVNI A,1 ; USE ^C AS MARKER FOR RSUBR
+ MOVE FLAGS,-1(P) ; RESTORE FLAGS
+ MOVE B,-4(TP) ; GET CHANNEL FOR PITYO
+ PUSHJ P,PITYO ; OUT IT GOES
+
+PRSBR1: MOVE B,-4(TP)
+ PUSHJ P,BFCLS1 ; FLUSH OUT CURRENT BUFFER
+
+ MOVE B,-4(TP) ; CHANNEL BACK
+ MOVN E,(P) ; LENGTH OF CODE
+ PUSH P,E
+ HRROI A,(P) ; POINT TO SAME
+ PUSHJ P,DOIOTO ; OUT GOES COUNT
+ MOVSI C,TCODE
+ MOVE PVP,PVSTOR+1
+ MOVEM C,ASTO(PVP) ; FOR IOT INTERRUPTS
+ MOVE A,-2(TP) ; GET POINTER TO CODE
+ MOVE A,1(A)
+ PUSHJ P,DOIOTO ; IOT IT OUT
+ POP P,E
+ ADDI E,1 ; UPDATE ACCESS
+ ADDM E,ACCESS(B)
+ MOVE PVP,PVSTOR+1
+ SETZM ASTO(PVP) ; UNSCREW A
+
+; NOW PRINT OUT NORMAL RSUBR VECTOR
+
+ MOVE FLAGS,-1(P) ; RESTORE FLAGS
+ SUB P,[1,,1]
+ MOVE B,-2(TP) ; GET RSUBR VECTOR
+ PUSHJ P,PRBODY ; PRINT ITS BODY
+
+; HERE TO PRINT BINARY FIXUPS
+
+ MOVEI E,0 ; 1ST COMPUTE LENGTH OF FIXUPS
+ SKIPN A,(TP) ; LIST TO A
+ JRST PRSBR5 ; EMPTY, DONE
+ JUMPL A,UFIXES ; JUMP IF FIXUPS IN UVECTOR FORM
+ ADDI E,1 ; FOR VERS
+
+PRSBR6: HRRZ A,(A) ; NEXT?
+ JUMPE A,PRSBR5
+ GETYP B,(A)
+ CAIE B,TDEFER ; POSSIBLE STRING
+ JRST PRSBR7 ; COULD BE ATOM
+ MOVE B,1(A) ; POSSIBLE STRINGER
+ GETYP C,(B)
+ CAIE C,TCHSTR ; YES!!!
+ JRST BADFXU ; LOSING FIXUPS
+ HRRZ C,(B) ; # OF CHARS TO C
+ ADDI C,5+5 ; ROUND AND ADD FOR COUNT
+ IDIVI C,5 ; TO WORDS
+ ADDI E,(C)
+ JRST FIXLST ; COUNT FOR USE LIST ETC.
+
+PRSBR7: GETYP B,(A) ; GET TYPE
+ CAIE B,TATOM
+ JRST BADFXU
+ ADDI E,1
+
+FIXLST: HRRZ A,(A) ; REST IT TO OLD VAL
+ JUMPE A,BADFXU
+ GETYP B,(A) ; FIX?
+ CAIE B,TFIX
+ JRST BADFXU
+ MOVEI D,1
+ HRRZ A,(A) ; TO USE LIST
+ JUMPE A,BADFXU
+ GETYP B,(A)
+ CAIE B,TLIST
+ JRST BADFXU ; LOSER
+ MOVE C,1(A) ; GET LIST
+
+PRSBR8: JUMPE C,PRSBR9
+ GETYP B,(C) ; TYPE OK?
+ CAIE B,TFIX
+ JRST BADFXU
+ HRRZ C,(C)
+ AOJA D,PRSBR8 ; LOOP
+
+PRSBR9: ADDI D,2 ; ROUND UP
+ ASH D,-1 ; DIV BY 2 FOR TWO GOODIES PER HWORD
+ ADDI E,(D)
+ JRST PRSBR6
+
+PRSBR5: PUSH P,E ; SAVE LENGTH OF FIXUPS
+ PUSH TP,$TUVEC ; SLOT FOR BUFFER POINTER
+ PUSH TP,[0]
+
+PFIXU1: MOVE B,-6(TP) ; START LOOPING THROUGH CHANNELS
+ PUSHJ P,BFCLS1 ; FLUSH BUFFER
+ MOVE B,-6(TP) ; CHANNEL BACK
+ MOVEI C,BUFSTR-1(B) ; SETUP BUFFER
+ PUSHJ P,BYTDOP ; FIND D.W.
+ SUBI A,BUFLNT+1
+ HRLI A,-BUFLNT
+ MOVEM A,(TP)
+ MOVE E,(P) ; LENGTH OF FIXUPS
+ SETZB C,D ; FOR EOUT
+ PUSHJ P,EOUT
+ MOVE C,-2(TP) ; FIXUP LIST
+ MOVE E,1(C) ; HAVE VERS
+ PUSHJ P,EOUT ; OUT IT GOES
+
+PFIXU2: HRRZ C,(C) ; FIRST THING
+ JUMPE C,PFIXU3 ; DONE?
+ GETYP A,(C) ; STRING OR ATOM
+ CAIN A,TATOM ; MUST BE STRING
+ JRST PFIXU4
+ MOVE A,1(C) ; POINT TO POINTER
+ HRRZ D,(A) ; LENGTH
+ IDIVI D,5
+ PUSH P,E ; SAVE REMAINDER
+ MOVEI E,1(D)
+ MOVNI D,(D)
+ MOVSI D,(D)
+ PUSH P,D
+ PUSHJ P,EOUT
+ MOVEI D,0
+PFXU1A: MOVE A,1(C) ; RESTORE POINTER
+ HRRZ A,1(A) ; BYTE POINTER
+ ADD A,(P)
+ MOVE E,(A)
+ PUSHJ P,EOUT
+ MOVE A,[1,,1]
+ ADDB A,(P)
+ JUMPL A,PFXU1A
+ MOVE D,-1(P) ; LAST WORD
+ MOVE A,1(C)
+ HRRZ A,1(A)
+ ADD A,(P)
+ SKIPE E,D
+ MOVE E,(A) ; LAST WORD OF CHARS
+ IOR E,PADS(D)
+ PUSHJ P,EOUT ; OUT
+ SUB P,[1,,1]
+ JRST PFIXU5
+
+PADS: ASCII /#####/
+ ASCII /####/
+ ASCII /\ 2###/
+ ASCII /\ 2##/
+ ASCII /\ 2\ 2#/
+
+PFIXU4: HRRZ E,(C) ; GET CURRENT VAL
+ MOVE E,1(E)
+ PUSHJ P,ATOSQ ; GET SQUOZE
+ JRST BADFXU
+ TLO E,400000 ; USE TO DIFFERENTIATE BETWEEN STRING
+ PUSHJ P,EOUT
+
+; HERE TO WRITE OUT LISTS
+
+PFIXU5: HRRZ C,(C) ; POINT TO CURRENT VALUE
+ HRLZ E,1(C)
+ HRRZ C,(C) ; POINT TO USES LIST
+ HRRZ D,1(C) ; GET IT
+
+PFIXU6: TLCE D,400000 ; SKIP FOR RH
+ HRLZ E,1(D) ; SETUP LH
+ JUMPG D,.+3
+ HRR E,1(D)
+ PUSHJ P,EOUT ; WRITE IT OUT
+ HRR D,(D)
+ TRNE D,-1 ; SKIP IF DONE
+ JRST PFIXU6
+
+ TRNE E,-1 ; SKIP IF ZERO BYTE EXISTS
+ MOVEI E,0
+ PUSHJ P,EOUT
+ JRST PFIXU2 ; DO NEXT
+
+PFIXU3: HLRE C,(TP) ; -AMNT LEFT IN BUFFER
+ MOVN D,C ; PLUS SAME
+ ADDI C,BUFLNT ; WORDS USED TO C
+ JUMPE C,PFIXU7 ; NONE USED, LEAVE
+ MOVSS C ; START SETTING UP BTB
+ MOVN A,C ; ALSO FINAL IOT POINTER
+ HRR C,(TP) ; PDL POINTER PART OF BTB
+ SUBI C,1
+ HRLI D,400000+C ; CONTINUE SETTING UP BTB (400000 IS FOR MULTI
+ ; SEGS
+ POP C,@D ; MOVE 'EM DOWN
+ TLNE C,-1
+ JRST .-2
+ HRRI A,@D ; OUTPUT POINTER
+ ADDI A,1
+ MOVSI B,TUVEC
+ MOVE PVP,PVSTOR+1
+ MOVEM B,ASTO(PVP)
+ MOVE B,-6(TP)
+ PUSHJ P,DOIOTO ; WRITE IT OUT
+ MOVE PVP,PVSTOR+1
+ SETZM ASTO(PVP)
+
+PFIXU7: SUB TP,[4,,4]
+ SUB P,[2,,2]
+ JRST PNEXT
+
+; ROUTINE TO OUTPUT CONTENTS OF E
+
+EOUT: MOVE B,-6(TP) ; CHANNEL
+ AOS ACCESS(B)
+ MOVE A,(TP) ; BUFFER POINTER
+ MOVEM E,(A)
+ AOBJP A,.+3 ; COUNT AND GO
+ MOVEM A,(TP)
+ POPJ P,
+
+ SUBI A,BUFLNT ; SET UP IOT POINTER
+ HRLI A,-BUFLNT
+ MOVEM A,(TP) ; RESET SAVED POINTER
+ MOVSI 0,TUVEC
+ MOVE PVP,PVSTOR+1
+ MOVEM 0,ASTO(PVP)
+ MOVSI 0,TLIST
+ MOVEM 0,DSTO(PVP)
+ MOVEM 0,CSTO(PVP)
+ PUSHJ P,DOIOTO ; OUT IT GOES
+ MOVE PVP,PVSTOR+1
+ SETZM ASTO(PVP)
+ SETZM CSTO(PVP)
+ SETZM DSTO(PVP)
+ POPJ P,
+
+; HERE IF UVECOR FORM OF FIXUPS
+
+UFIXES: PUSH TP,$TUVEC
+ PUSH TP,A ; SAVE IT
+
+UFIX1: MOVE B,-6(TP) ; GET SAME
+ PUSHJ P,BFCLS1 ; FLUSH OUT BUFFER
+ HLRE C,(TP) ; GET LENGTH
+ MOVMS C
+ PUSH P,C
+ HRROI A,(P) ; READY TO ZAP IT OUT
+ PUSHJ P,DOIOTO ; ZAP!
+ SUB P,[1,,1]
+ HLRE C,(TP) ; LENGTH BACK
+ MOVMS C
+ ADDI C,1
+ ADDM C,ACCESS(B) ; UPDATE ACCESS
+ MOVE A,(TP) ; NOW THE UVECTOR
+ MOVSI C,TUVEC
+ MOVE PVP,PVSTOR+1
+ MOVEM C,ASTO(PVP)
+ PUSHJ P,DOIOTO ; GO
+ MOVE PVP,PVSTOR+1
+ SETZM ASTO(PVP)
+ SUB P,[1,,1]
+ SUB TP,[4,,4]
+ JRST PNEXT
+
+RCANT: ERRUUO EQUOTE RSUBR-LACKS-FIXUPS
+
+
+BADFXU: ERRUUO EQUOTE BAD-FIXUPS
+
+PRBODY: TDZA C,C ; FLAG SAYING FLUSH CODE
+PRBOD1: MOVEI C,1 ; PRINT CODE ALSO
+ PUSH P,FLAGS
+ PUSH TP,$TRSUBR
+ PUSH TP,B
+ PUSH P,C
+ MOVEI A,"[ ; START VECTOR TEXT
+ MOVE B,-6(TP) ; GET CHANNEL FOR PITYO
+ PUSHJ P,PITYO
+ POP P,C
+ MOVE B,(TP) ; RSUBR BACK
+ JUMPN C,PRSON ; GO START PRINTING
+ MOVEI A,"0 ; PLACE SAVER FOR CODE VEC
+ MOVE B,-6(TP) ; GET CHANNEL FOR PITYO
+ PUSHJ P,PITYO
+
+PRSBR2: MOVE B,[2,,2] ; BUMP VECTOR
+ ADDB B,(TP)
+ JUMPGE B,PRSBR3 ; NO SPACE IF LAST
+ MOVE B,-6(TP) ; GET CHANNEL FOR SPACEQ
+ PUSHJ P,SPACEQ
+ SKIPA B,(TP) ; GET BACK POINTER
+PRSON: JUMPGE B,PRSBR3
+ GETYP 0,(B) ; SEE IF RSUBR POINTED TO
+ CAIE 0,TQENT
+ CAIN 0,TENTER
+ JRST .+5 ; JUMP IF RSUBR ENTRY
+ CAIN 0,TQRSUB
+ JRST .+3
+ CAIE 0,TRSUBR ; YES!
+ JRST PRSB10 ; COULD BE SUBR/FSUBR
+ MOVE C,1(B) ; GET RSUBR
+ PUSH P,0 ; SAVE TYPE FOUND
+ GETYP 0,2(C) ; SEE IF ATOM
+ CAIE 0,TATOM
+ JRST PRSBR4
+ MOVE B,3(C) ; GET ATOM NAME
+ PUSHJ P,IGVAL ; GO LOOK
+ MOVE C,(TP) ; ORIG RSUBR BACK
+ GETYP A,A
+ POP P,0 ; DESIRED TYPE
+ CAIE 0,(A) ; SAME TYPE
+ JRST PRSBR4
+ MOVE D,1(C)
+ MOVE 0,3(D) ; NAME OF RSUBR IN QUESTION
+ CAME 0,3(B) ; WIN?
+ JRST PRSBR4
+ HRRZ E,C
+ MOVSI A,TATOM
+ MOVE B,0 ; GET ATOM
+ MOVE FLAGS,(P)
+ JRST PRS101
+
+PRSBR4: MOVE FLAGS,(P) ; RESTORE FLAGS
+ MOVE B,(TP)
+ MOVE A,(B)
+ MOVE B,1(B) ; PRINT IT
+PRS101: PUSH TP,-7(TP) ; PUSH CHANNEL FOR IPRINT
+ PUSH TP,-7(TP)
+ PUSHJ P,IPRINT
+ SUB TP,[2,,2] ; POP OFF CHANNEL
+ MOVE B,-2(TP) ; MOVE IN CHANNEL
+ JRST PRSBR2
+
+PRSB10: CAIE 0,TSUBR ; SUBR?
+ CAIN 0,TFSUBR
+ JRST .+2
+ JRST PRSBR4
+ MOVE C,1(B) ; GET LOCN OF SUBR OR FSUBR
+ MOVE B,@-1(C) ; NAME OF IT
+ MOVSI A,TATOM ; AND TYPE
+ JRST PRS101
+
+PRSBR3: MOVEI A,"]
+ MOVE B,-6(TP)
+ PUSHJ P,PRETIF ; CLOSE IT UP
+ SUB TP,[2,,2] ; FLUSH CRAP
+ POP P,FLAGS
+ POPJ P,
+
+
+\f; HERE TO PRINT PURE RSUBRS
+
+PRSBRP: MOVEI A,2 ; WILL "%<" FIT?
+ MOVE B,-2(TP) ; GET CHANNEL FOR RETIF
+ PUSHJ P,RETIF
+ MOVEI A,"%
+ PUSHJ P,PITYO
+ MOVEI A,"<
+ PUSHJ P,PITYO
+ MOVSI A,TATOM
+ MOVE B,IMQUOTE RSUBR
+ PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
+ PUSH TP,-3(TP)
+ PUSHJ P,IPRINT ; PRINT IT OUT
+ SUB TP,[2,,2] ; POP OFF CHANNEL
+ MOVE B,-2(TP)
+ PUSHJ P,SPACEQ ; MAYBE SPACE
+ MOVEI A,"' ; QUOTE THE VECCTOR
+ PUSHJ P,PRETIF
+ MOVE B,(TP) ; GET RSUBR BODY BACK
+ PUSH TP,$TFIX ; STUFF THE STACK
+ PUSH TP,[0]
+ PUSHJ P,PRBOD1 ; PRINT AND UNLINK
+ SUB TP,[2,,2] ; GET JUNK OFF STACK
+ MOVE B,-2(TP) ; GET CHANNEL FOR RETIF
+ MOVEI A,">
+ PUSHJ P,PRETIF
+ JRST PNEXT
+
+; HERE TO PRINT ASCII RSUBRS
+
+ARSUBR: PUSH P,FLAGS ; SAVE FROM GET
+ MOVSI A,TRSUBR
+ MOVE B,(TP)
+ MOVSI C,TATOM
+ MOVE D,IMQUOTE RSUBR
+ PUSHJ P,IGET ; TRY TO GET FIXUPS
+ POP P,FLAGS
+ JUMPE B,PUNK ; NO FIXUPS LOSE
+ GETYP A,A
+ CAIE A,TLIST ; ARE FIXUPS A LIST?
+ JRST PUNK ; NO, AGAIN LOSE
+ PUSH TP,$TLIST
+ PUSH TP,B ; SAVE FIXUPS
+ MOVEI A,17.
+ MOVE B,-4(TP)
+ PUSHJ P,RETIF
+ PUSH P,[440700,,[ASCIZ /%<FIXUP!-RSUBRS!-/]]
+
+AL1: ILDB A,(P) ; GET CHAR
+ JUMPE A,.+3
+ PUSHJ P,PITYO
+ JRST AL1
+
+ SUB P,[1,,1]
+ PUSHJ P,SPACEQ
+
+ MOVEI A,"'
+ PUSHJ P,PRETIF ; QUOTE TO AVOID ADDITIONAL EVAL
+ MOVE B,-2(TP) ; PRINT ACTUAL KLUDGE
+ PUSHJ P,PRBOD1
+ MOVE B,-4(TP) ; GET CHANNEL FOR SPACEQ
+ PUSHJ P,SPACEQ
+ MOVEI A,"' ; DONT EVAL FIXUPS EITHER
+ PUSHJ P,PRETIF
+ POP TP,B
+ POP TP,A
+ PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
+ PUSH TP,-3(TP)
+ PUSHJ P,IPRINT
+ SUB TP,[2,,2] ; POP CHANNEL OFF STACK
+ MOVE B,-2(TP) ; GET CHANNEL INTO B
+ MOVEI A,">
+ PUSHJ P,PRETIF
+ JRST PNEXT
+\f
+; HERE TO DO OFFSETS: %<OFFSET N '<VECTOR FIX FLOAT>>
+
+POFFSE: MOVEI A,2
+ MOVE B,-2(TP)
+ PUSHJ P,RETIF
+ MOVEI A,"%
+ PUSHJ P,PITYO
+ MOVEI A,"<
+ PUSHJ P,PITYO
+ MOVSI A,TATOM
+ MOVE B,MQUOTE OFFSET
+ PUSH TP,-3(TP)
+ PUSH TP,-3(TP)
+ PUSHJ P,IPRINT
+ SUB TP,[2,,2]
+ MOVE B,-2(TP) ; RESTORE CHANNEL
+ PUSHJ P,SPACEQ
+ MOVSI A,TFIX
+ HRRE B,(TP) ; PICK UPTHE FIX
+ PUSH TP,-3(TP)
+ PUSH TP,-3(TP)
+ PUSHJ P,IPRINT
+ SUB TP,[2,,2]
+ MOVE B,-2(TP) ; RESTORE CHANNEL
+ PUSHJ P,SPACEQ
+ HLRZ A,(TP)
+ JUMPE A,POFFS2
+ GETYP B,(A)
+ CAIE B,TFORM ; FORMS HAVE TO BE QUOTED
+ JRST POFFS1
+ MOVEI A,"'
+ MOVE B,-2(TP)
+ PUSHJ P,PRETIF
+POFFS1: HLRZ B,(TP)
+ MOVE A,(B)
+ MOVE B,1(B)
+POFFPT: PUSH TP,-3(TP)
+ PUSH TP,-3(TP)
+ PUSHJ P,IPRINT
+ SUB TP,[2,,2]
+ MOVE B,-2(TP) ; RESTORE CHANNEL
+ MOVEI A,">
+ PUSHJ P,PRETIF
+ JRST PNEXT
+; PRINT 'ANY' IF 0
+POFFS2: MOVSI A,TATOM
+ MOVE B,IMQUOTE ANY
+ JRST POFFPT
+
+\f; HERE TO DO LOCATIVES (PRINT CONTENTS THEREOF)
+
+LOCP: PUSH TP,-1(TP)
+ PUSH TP,-1(TP)
+ PUSH P,0
+ MCALL 1,IN ; GET ITS CONTENTS FROM "IN"
+ POP P,0
+ PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
+ PUSH TP,-3(TP)
+ PUSHJ P,IPRINT ; PRINT IT
+ SUB TP,[2,,2] ; POP CHANNEL OFF STACK
+ JRST PNEXT
+\f;INTERNAL SUBROUTINE TO HANDLE CHARACTER OUTPUT
+;B CONTAINS CHANNEL
+;PRINTER ITYO USED FOR FLATSIZE FAKE OUT
+PITYO: TLNN FLAGS,FLTBIT
+ JRST ITYO
+PITYO1: PUSH TP,[TTP,,0] ; PUSH ON TP POINTER
+ PUSH TP,B
+ TLNE FLAGS,UNPRSE ;SKIPS UNPRSE NOT SET
+ JRST ITYO+2
+ AOS FLTSIZ ;FLATSIZE DOESN'T PRINT
+ ;INSTEAD IT COUNTS THE CHARACTERS THAT WOULD BE OUTPUT
+ SOSGE FLTMAX ;UNLESS THE MAXIMUM IS EXCEEDED
+ JRST .+4
+ POP TP,B ; GET CHANNEL BACK
+ SUB TP,[1,,1]
+ POPJ P,
+ MOVEI E,(B) ; GET POINTER FOR UNBINDING
+ PUSHJ P,SSPEC1
+ MOVE P,UPB+8 ; RESTORE P
+ POP TP,B ; GET BACK TP POINTER
+ PUSH P,0 ; SAVE FLAGS
+ MOVE TP,B ; RESTORE TP
+ MOVEI C,(TB) ; SEE IF TB IS CORRECT
+ CAIG C,1(TP) ; SKIP IF NEEDS UNWINDING
+ JRST PITYO4
+PITYO3: MOVEI C,(TB)
+ CAILE C,1(TP)
+ JRST PITYO2
+ MOVEI A,PITYO4 ; SET UP PARAMETERS TO BE RESTORED BY FINIS
+ HRRM A,PCSAV(C)
+ MOVEM TP,TPSAV(C)
+ MOVE SP,SPSTOR+1
+ MOVEM SP,SPSAV(C)
+ MOVEM P,PSAV(C)
+ MOVE TB,D ; SET TB TO ONE FRAME AHEAD
+ JRST FINIS
+PITYO4: POP P,0 ; RESTORE FLAGS
+ MOVSI A,TFALSE ;IN WHICH CASE IT IMMEDIATELY GIVES UP AND RETURNS FALSE
+ MOVEI B,0
+ POPJ P,
+
+PITYO2: MOVE D,TB ; SAVE ONE FRAME AHEAD
+ HRR TB,OTBSAV(TB) ; RESTORE TB
+ JRST PITYO3
+
+
+\f;THE REAL THING
+;NOTE THAT THE FOLLOWING CODE HAS BUGS IF IT IS PRINTING OUT LONG
+;CHARACTER STRINGS
+; (NOTE THAT THE ABOVE COMMENT, IF TRUE, SHOULD NOT BE ADMITTED.)
+ITYO: PUSH TP,$TCHAN
+ PUSH TP,B
+ PUSH P,FLAGS ;SAVE STUFF
+ PUSH P,C
+ PUSH P,A ;SAVE OUTPUT CHARACTER
+
+
+ TLNE FLAGS,UNPRSE ;SKIPS UNPRSE NOT SET
+ JRST UNPROUT ;IF FROM UNPRSE, STASH IN STRING
+ CAIN A,^J
+ PUSHJ P,INTCHK
+ PUSH P,A
+ PUSHJ P,WXCT
+ POP P,A
+ CAIE A,^L ;SKIP IF THIS IS A FORM-FEED
+ JRST NOTFF
+ SETZM LINPOS(B) ;ZERO THE LINE NUMBER
+ JRST ITYXT
+
+NOTFF: CAIE A,15 ;SKIP IF IT IS A CR
+ JRST NOTCR
+ SETZM CHRPOS(B) ;ZERO THE CHARACTER POSITION
+ PUSHJ P,AOSACC ; BUMP COUNT
+ JRST ITYXT1
+
+NOTCR: CAIN A,^I ;SKIP IF NOT TAB
+ JRST TABCNT
+ CAIE A,10 ; BACK SPACE
+ JRST .+3
+ SOS CHRPOS(B) ; BACK UP ONE
+ JRST ITYXT
+ CAIE A,^J ;SKIP IF LINE FEED
+ JRST NOTLF
+ AOS C,LINPOS(B) ;ADD ONE TO THE LINE NUMBER
+ CAMLE C,PAGLN(B) ;SKIP IF THIS DOESN'T TAKES US PAST PAGE END
+ SETZM LINPOS(B)
+ MOVE FLAGS,-2(P)
+ JRST ITYXT
+
+INTCHK: HRRZ 0,-2(B) ; GET CHANNELS FLAGS
+ TRNN 0,C.INTL ; LOSER INTERESTED IN LFS?
+ POPJ P, ; LEAVE IF NOTHING TO DO
+ PUSH TP,$TCHAN
+ PUSH TP,B ; SAVE CHANNEL
+ PUSH P,C
+ PUSH P,E
+ PUSHJ P,GTLPOS ; READ SYSTEMS VERSION OF LINE #
+ PUSH TP,$TATOM
+ PUSH TP,MQUOTE CHAR,CHAR,INTRUP
+ PUSH TP,$TFIX
+ PUSH TP,A
+ PUSH TP,$TCHAN
+ PUSH TP,B
+ MCALL 3,INTERRUPT
+ POP P,E ; RESTORE POSSIBLE COUNTS
+ POP P,C
+ POP TP,B ; RESTORE CHANNEL
+ SUB TP,[1,,1]
+ MOVEI A,^J
+ POPJ P,
+
+NOTLF: CAIGE A,40
+ AOS CHRPOS(B) ; FOR CONTROL CHARS THAT NEED 2 SPACES
+ AOS CHRPOS(B) ;ADD TO CHARACTER NUMBER
+
+ITYXT: PUSHJ P,AOSACC ; BUMP ACCESS
+ITYXT1: POP P,A ;RESTORE THE ORIGINAL CHARACTER
+
+ITYRET: POP P,C ;RESTORE REGS & RETURN
+ POP P,FLAGS
+ POP TP,B ; GET CHANNEL BACK
+ SUB TP,[1,,1]
+ POPJ P,
+
+TABCNT: PUSH P,D
+ MOVE C,CHRPOS(B)
+ ADDI C,8. ;INCREMENT COUNT BY EIGHT (MOD EIGHT)
+ IDIVI C,8.
+ IMULI C,8.
+ MOVEM C,CHRPOS(B) ;REPLACE COUNT
+ POP P,D
+ JRST ITYXT
+
+UNPROUT: POP P,A ;GET BACK THE ORIG CHAR
+ IDPB A,UPB+2 ;DEPOSIT USING BYTE POINTER I PUSHED LONG AGO
+ SOS UPB+1
+ JRST ITYRET ;RETURN
+
+AOSACC: TLNN FLAGS,BINBIT
+ JRST NRMACC
+ AOS C,ACCESS-1(B) ; COUNT CHARS IN WORD
+ CAMN C,[TFIX,,1]
+ AOS ACCESS(B)
+ CAMN C,[TFIX,,5]
+ HLLZS ACCESS-1(B)
+ POPJ P,
+
+NRMACC: AOS ACCESS(B)
+ POPJ P,
+
+SPACEQ: MOVEI A,40
+ TLNE FLAGS,FLTBIT+BINBIT
+ JRST PITYO ; JUST OUTPUT THE SPACE
+ PUSH P,[1] ; PRINT SPACE IF NOT END OF LINE
+ MOVEI A,1
+ JRST RETIF2
+
+RETIF1: MOVEI A,1
+
+RETIF: PUSH P,[0]
+ TLNE FLAGS,FLTBIT+BINBIT
+ JRST SPOPJ ; IF WE ARE IN FLATSIZE THEN ESCAPE
+RETIF2: PUSH P,FLAGS
+RETCH: PUSH P,A
+
+RETCH1: ADD A,CHRPOS(B) ;ADD THE CHARACTER POSITION
+ SKIPN CHRPOS(B) ; IF JUST RESET, DONT DO IT AGAIN
+ JRST RETXT
+ CAMG A,LINLN(B) ;SKIP IF GREATER THAN LINE LENGTH
+ JRST RETXT1
+
+ MOVEI A,^M ;FORCE A CARRIAGE RETURN
+ SETZM CHRPOS(B)
+ PUSHJ P,WXCT
+ PUSHJ P,AOSACC ; BUMP CHAR COUNT
+ MOVEI A,^J ;AND FORCE A LINE FEED
+ PUSHJ P,INTCHK ; CHECK FOR ^J INTERRUPTS
+ PUSHJ P,WXCT
+ PUSHJ P,AOSACC ; BUMP CHAR COUNT
+ AOS A,LINPOS(B)
+ CAMG A,PAGLN(B) ;AT THE END OF THE PAGE ?
+ JRST RETXT
+; MOVEI A,^L ;IF SO FORCE A FORM FEED
+; PUSHJ P,WXCT
+; PUSHJ P,AOSACC ; BUMP CHAR COUNT
+ SETZM LINPOS(B)
+
+RETXT: POP P,A
+
+ POP P,FLAGS
+SPOPJ: SUB P,[1,,1]
+ POPJ P, ;RETURN
+
+PRETIF: PUSH P,A ;SAVE CHAR
+ PUSHJ P,RETIF1
+ POP P,A
+ JRST PITYO
+
+RETIF3: TLNE FLAGS,FLTBIT ; NOTHING ON FLATSIZE
+ POPJ P,
+ PUSH P,[0]
+ PUSH P,FLAGS
+ HRRI FLAGS,2 ; PRETEND ONLY 1 CHANNEL
+ PUSH P,A
+ JRST RETCH1
+
+RETXT1: SKIPN -2(P) ; SKIP IF SPACE HACK
+ JRST RETXT
+ MOVEI A,40
+ PUSHJ P,WXCT
+ AOS CHRPOS(B)
+ PUSH P,C
+ PUSHJ P,AOSACC
+ POP P,C
+ JRST RETXT
+
+\f;THIS IS CODE TO HANDLE UNKNOWN DATA TYPES.
+;IT PRINTS "*XXXXXX*XXXXXXXXXXXX*", WHERE THE FIRST NUMBER IS THE
+;TYPE CODE IN OCTAL, THE SECOND IS THE VALUE FIELD IN OCTAL.
+PRERR: MOVEI A,21. ;CHECK FOR 21. SPACES LEFT ON PRINT LINE
+ MOVE B,-2(TP) ; GET CHANNEL INTO B
+ PUSHJ P,RETIF ;INSERT CARRIAGE RETURN IF NOT ENOUGH
+ MOVEI A,"* ;JUNK TO INDICATE ERROR PRINTOUT IN OCTAL
+ PUSHJ P,PITYO ;TYPE IT
+
+ MOVE E,[000300,,-2(TP)] ;GET POINTER INDEXED OFF TP SO THAT
+ ;TYPE CODE MAY BE OBTAINED FOR PRINTING.
+ MOVEI D,6 ;# OF OCTAL DIGITS IN HALF WORD
+OCTLP1: ILDB A,E ;GET NEXT 3-BIT BYTE OF TYPE CODE
+ IORI A,60 ;OR-IN 60 FOR ASCII DIGIT
+ PUSHJ P,PITYO ;PRINT IT
+ SOJG D,OCTLP1 ;REPEAT FOR SIX CHARACTERS
+
+PRE01: MOVEI A,"* ;DELIMIT TYPE CODE FROM VALUE FIELD
+ PUSHJ P,PITYO
+
+ HRLZI E,(410300,,(TP)) ;BYTE POINTER TO SECOND WORD
+ ;INDEXED OFF TP
+ MOVEI D,12. ;# OF OCTAL DIGITS IN A WORD
+OCTLP2: LDB A,E ;GET 3 BITS
+ IORI A,60 ;CONVERT TO ASCII
+ PUSHJ P,PITYO ;PRINT IT
+ IBP E ;INCREMENT POINTER TO NEXT BYTE
+ SOJG D,OCTLP2 ;REPEAT FOR 12. CHARS
+
+ MOVEI A,"* ;DELIMIT END OF ERROR TYPEOUT
+ PUSHJ P,PITYO ;REPRINT IT
+
+ JRST PNEXT ;RESTORE REGS & POP UP ONE LEVEL TO CALLER
+
+POCTAL: MOVEI A,14. ;RETURN TO NEW LINE IF 14. SPACES NOT LEFT
+ MOVE B,-2(TP) ; GET CHANNEL INTO B
+ PUSHJ P,RETIF
+ JRST PRE01 ;PRINT VALUE AS "*XXXXXXXXXXXX*"
+
+\f;PRINT BINARY INTEGERS IN DECIMAL.
+;
+PFIX: MOVM E,(TP) ; GET # (MAFNITUDE)
+ JUMPL E,POCTAL ; IF ABS VAL IS NEG, MUST BE SETZ
+ PUSH P,FLAGS
+
+PFIX1: MOVE B,-2(TP) ; GET CHANNEL INTO B
+PFIX2: MOVE D,UPB+6 ; IF UNPARSE, THIS IS RADIX
+ TLNE FLAGS,UNPRSE+FLTBIT ;SKIPS IF NOT FROM UNPARSE OR FLATSIZE
+ JRST PFIXU
+ MOVE D,RADX(B) ; GET OUTPUT RADIX
+PFIXU: CAIG D,1 ; DONT ALLOW FUNNY RADIX
+ MOVEI D,10. ; IF IN DOUBT USE 10.
+ PUSH P,D
+ MOVEI A,1 ; START A COUNTER
+ SKIPGE B,(TP) ; CHECK SIGN
+ MOVEI A,2 ; NEG, NEED CHAR FOR SIGN
+
+ IDIV B,D ; START COUNTING
+ JUMPE B,.+2
+ AOJA A,.-2
+
+ MOVE B,-2(TP) ; CHANNEL TO B
+ TLNN FLAGS,FLTBIT+BINBIT
+ PUSHJ P,RETIF3 ; CHECK FOR C.R.
+ MOVE B,-2(TP) ; RESTORE CHANNEL
+ MOVEI A,"- ; GET SIGN
+ SKIPGE (TP) ; SKIP IF NOT NEEDED
+ PUSHJ P,PITYO
+ MOVM C,(TP) ; GET MAGNITUDE OF #
+ MOVE B,-2(TP) ; RESTORE CHANNEL
+ POP P,E ; RESTORE RADIX
+ PUSHJ P,FIXTYO ; WRITE OUT THE #
+ MOVE FLAGS,-1(P)
+ SUB P,[1,,1] ; FLUSH P STUFF
+ JRST PNEXT
+
+FIXTYO: IDIV C,E
+ PUSH P,D ; SAVE REMAINDER
+ SKIPE C
+ PUSHJ P,FIXTYO
+ POP P,A ; START GETTING #'S BACK
+ ADDI A,60
+ MOVE B,-2(TP) ; CHANNEL BACK
+ JRST PITYO
+
+\f;PRINT SINGLE-PRECISION FLOATING POINT NUMBERS IN DECIMAL.
+;
+PFLOAT: SKIPN A,(TP) ; SKIP IF NUMBER IS NON-ZERO
+ ; SPECIAL HACK FOR ZERO)
+ JRST PFLT0 ; HACK THAT ZERO
+ MOVM E,A ; CHECK FOR NORMALIZED
+ TLNN E,400 ; NORMALIZED
+ JRST PUNK
+ MOVE E,[SETZ FLOATB] ;ADDRESS OF FLOATING POINT CONVERSION ROUTINE
+ MOVE D,[6,,6] ;# WORDS TO GET FROM STACK
+
+PNUMB: HRLI A,1(P) ; LH(A) TO CONTAIN ADDRESS OF RETURN AREA
+ ; ON STACK
+ HRR A,TP ; RH(A) TO CONTAIN ADDRESS OF DATA ITEM
+ HLRZ B,A ; SAVE RETURN AREA ADDRESS IN REG B
+ ADD P,D ; ADD # WORDS OF RETURN AREA TO BOTH HALVES OF
+ ; SP
+ JUMPGE P,PDLERR ; PLUS OR ZERO STACK POINTER IS OVERFLOW
+PDLWIN: PUSHJ P,(E) ; CALL ROUTINE WHOSE ADDRESS IS IN REG E
+
+ MOVE C,(B) ; GET COUNT 0F # CHARS RETURNED
+PFLT1: MOVE A,B
+ HRR B,P ; GET PSTACK POINTER AND PRODUCE RELATAVIZED
+ SUB A,B
+ HRLS A ; ADD TO AOBJN
+ ADD A,P ; PRODUCE PDL POINTER
+ MOVE B,-2(TP) ; GET CHANNEL INTO B
+ PUSH TP,$TPDL ; PUSH PDL POINTER
+ PUSH TP,A
+ MOVE A,C ; MAKE SURE THAT # WILL FIT ON PRINT LINE
+ PUSH P,D ; WATCH THAT MCALL
+ PUSHJ P,RETIF ; START NEW LINE IF IT WON'T
+ POP P,D
+ POP TP,B ; RESTORE B
+ SUB TP,[1,,1] ; CLEAN OFF STACK
+
+ HRLI B,000700 ;MAKE REG B INTO BYTE POINTER TO FIRST CHAR
+ ; LESS ONE
+PNUM01: ILDB A,B ; GET NEXT BYTE
+ PUSH P,B ; SAVE B
+ MOVE B,-2(TP) ; GET CHANNEL INTO B
+ PUSHJ P,PITYO ; PRINT IT
+ POP P,B ; RESTORE B
+ SOJG C,PNUM01 ; DECREMENT CHAR COUNT: LOOP IF NON-ZERO
+
+ SUB P,D ;SUBTRACT # WORDS USED ON STACK FOR RETURN
+ JRST PNEXT ;STORE REGS & POP UP ONE LEVEL TO CALLER
+
+
+PFLT0: MOVEI A,9. ; WIDTH OF 0.0000000
+ MOVEI C,9. ; SEE ABOVE
+ MOVEI D,0 ; WE'RE GONNA TEST D SOON...SO WILL DO RIGHT THING
+ MOVEI B,[ASCII /0.0000000/]
+ SOJA B,PFLT1 ; PT TO 1 BELOW CONST, THEN REJOIN CODE
+
+
+
+
+PDLERR: SUB P,D ;REST STACK POINTER
+REPEAT 6,PUSH P,[0]
+ JRST PDLWIN
+\f
+; FLOATING POINT PRINTER STOLEN FROM DDT
+
+F==E+1
+G==F+1
+H==G+1
+I==H+1
+J==I+1
+TEM1==I
+
+FLOATB: PUSH P,B
+ PUSH P,C
+ PUSH P,D
+ PUSH P,F
+ PUSH P,G
+ PUSH P,H
+ PUSH P,I
+ PUSH P,0
+ PUSH P,J
+ MOVSI 0,440700 ; BUILD BYTEPNTR
+ HLRZ J,A ; POINT TO BUFFER
+ HRRI 0,1(J)
+ ANDI A,-1
+ MOVE A,(A) ; GET NUMBER
+ MOVE D,A
+ SETZM (J) ; Clear counter
+ PUSHJ P,NFLOT
+ POP P,J
+ POP P,0
+ POP P,I
+ POP P,H
+ POP P,G
+ POP P,F
+ POP P,D
+ POP P,C
+ POP P,B
+ POPJ P,
+
+; at this point we enter code abstracted from DDT.
+NFLOT: JUMPG A,TFL1
+ JUMPE A,FP1A
+ MOVNS A
+ PUSH P,A
+ MOVEI A,"-
+ PUSHJ P,CHRO
+ POP P,A
+ TLZE A,400000
+ JRST FP1A
+
+TFL1: MOVEI B,0
+TFLX: CAMGE A,FT01
+ JRST FP4
+ CAML A,FT8
+ AOJA B,FP4
+FP1A:
+FP3: SETZB C,TEM1 ; CLEAR DIGIT CNTR, C TO RECEIVE FRACTION
+ MULI A,400
+ ASHC B,-243(A)
+ MOVE A,B
+ PUSHJ P,FP7
+ PUSH P,A
+ MOVEI A,".
+ PUSHJ P,CHRO
+ POP P,A
+ MOVNI A,10
+ ADD A,TEM1
+ MOVE E,C
+FP3A: MOVE D,E
+ MULI D,12
+ PUSHJ P,FP7B
+ SKIPE E
+ AOJL A,FP3A
+ POPJ P, ; ONE return from OFLT here
+
+FP4: MOVNI C,6
+ MOVEI F,0
+FP4A: ADDI F,1(F)
+ XCT FCP(B)
+ SOSA F
+ FMPR A,@FXP+1(B)
+ AOJN C,FP4A
+ PUSH P,EXPSGN(B)
+ PUSHJ P,FP3
+ PUSH P,A
+ MOVEI A,"E
+ PUSHJ P,CHRO
+ POP P,A
+ POP P,D
+ PUSHJ P,FDIGIT
+ MOVE A,F
+
+FP7: SKIPE A ; AVOID AOSING TEM1, NOT SIGNIFICANT DIGIT
+ AOS TEM1
+ IDIVI A,12
+ PUSH P,B
+ JUMPE A,FP7A1
+ PUSHJ P,FP7
+
+FP7A1: POP P,D
+FP7B: ADDI D,"0
+
+; type digit
+FDIGIT: PUSH P,A
+ MOVE A,D
+ PUSHJ P,CHRO
+ POP P,A
+ POPJ P,
+
+CHRO: AOS (J) ; COUNT CHAR
+ IDPB A,0 ; STUFF CHAR
+ POPJ P,
+
+; constants
+ 1.0^32.
+ 1.0^16.
+FT8: 1.0^8
+ 1.0^4
+ 1.0^2
+ 1.0^1
+FT: 1.0^0
+ 1.0^-32.
+ 1.0^-16.
+ 1.0^-8
+ 1.0^-4
+ 1.0^-2
+FT01: 1.0^-1
+FT0=FT01+1
+
+; instructions
+FCP: CAMLE A, FT0(C)
+ CAMGE A, FT(C)
+ 0, FT0(C)
+FXP: SETZ FT0(C)
+ SETZ FT(C)
+ SETZ FT0(C)
+EXPSGN: "-
+ "+
+
+\f
+;PRINT SHORT (ONE WORD) CHARACTER STRINGS
+
+PCHRS: MOVEI A,3 ;MAX # CHARS PLUS 2 (LESS ESCAPES)
+ MOVE B,-2(TP) ; GET CHANNEL INTO B
+ TLNE FLAGS,NOQBIT ;SKIP IF QUOTES WILL BE USED
+ MOVEI A,1 ;ELSE, JUST ONE CHARACTER POSSIBLE
+ PUSHJ P,RETIF ;NEW LINE IF INSUFFICIENT SPACE
+ TLNE FLAGS,NOQBIT ;DON'T QUOTE IF IN PRINC MODE
+ JRST PCASIS
+ MOVEI A,"! ;TYPE A EXCL
+ PUSHJ P,PITYO
+ MOVEI A,"\ ;AND A BACK SLASH
+ PUSHJ P,PITYO
+
+PCASIS: MOVE A,(TP) ;GET NEXT BYTE FROM WORD
+ TLNE FLAGS,NOQBIT ;SKIP IF WE ARE NOT IN PRINC MODE (NOQBIT=0)
+ JRST PCPRNT ;IF BIT IS ON, PRINT WITHOUT ESCAPING
+ CAIE A,ESCHAR ;SKIP IF NOT THE ESCAPE CHARACTER
+ JRST PCPRNT ;ESCAPE THE ESCAPE CHARACTER
+
+ESCPRT: MOVEI A,ESCHAR ;TYPE THE ESCAPE CHARACTER
+ PUSHJ P,PITYO
+PCPRNT: MOVE A,(TP) ;GET THE CHARACTER AGAIN
+ TLNE FLAGS,NOQBIT ;SKIP IF WE ARE NOT IN PRINC MODE (NOQBIT=0)
+ TLO FLAGS,CNTLPC ;SWITCH ON ^P MODE TEMPORARY
+ PUSHJ P,PITYO ;PRINT IT
+ TLZ FLAGS,CNTLPC ;SWITCH OFF ^P MODE
+ JRST PNEXT
+
+
+\f;PRINT DEFERED (INVISIBLE) ITEMS. (PRINTED AS THE THING POINTED TO)
+;
+PDEFER: MOVE A,(B) ;GET FIRST WORD OF ITEM
+ MOVE B,1(B) ;GET SECOND
+ PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
+ PUSH TP,-3(TP)
+ PUSHJ P,IPRINT ;PRINT IT
+ SUB TP,[2,,2] ; POP OFF CHANNEL
+ JRST PNEXT ;GO EXIT
+
+
+; Print an ATOM. TRAILERS are added if the atom is not in the current
+; lexical path. Also escaping of charactets is performed to allow READ
+; to win.
+
+PATOM: PUSH P,[440700,,D] ; PUSH BYE POINTER TO FINAL STRING
+ SETZB D,E ; SET CHARCOUNT AD DESTINATION TO 0
+ HLLZS -1(TP) ; RH OF TATOM,, WILL COUNT ATOMS IN PATH
+
+PATOM0: PUSH TP,$TPDL ; SAVE CURRENT STAKC FOR \ LOGIC
+ PUSH TP,P
+ LDB A,[301400,,(P)] ; GET BYTE PTR POSITION
+ DPB A,[301400,,E] ; SAVE IN E
+ MOVE C,-2(TP) ; GET ATOM POINTER
+ ADD C,[3,,3] ; POINT TO PNAME
+ JUMPGE C,BADPNM ; NO PNAME, ERROR
+ HLRE A,C ; -# WORDS TO A
+ PUSH P,A ; PUSH THAT FOR "AOSE"
+ MOVEI A,177 ; PUT RUBOUT WHERE \ MIGHT GO
+ JSP B,DOIDPB
+ HRLI C,440700 ; BUILD BYTE POINTER
+ ILDB A,C ; GET FIRST BYTE
+ JUMPE A,BADPNM ; NULL PNAME, ERROR
+ SKIPA
+PATOM1: ILDB A,C ; GET A CHAR
+ JUMPE A,PATDON ; END OF PNAME?
+ TLNN C,760000 ; SKIP IF NOT WORD BOUNDARY
+ AOS (P) ; COUNT WORD
+ JRST PENTCH ; ENTER THE CHAR INTO OUTPUT
+
+PATDON: LDB A,[220600,,E] ; GET "STATE"
+ LDB A,STABYT+NONSPC+1 ; SIMULATE "END" CHARACTER
+ DPB A,[220600,,E] ; AND STORE
+ MOVE B,E ; SETUP BYTE POINTER TO 1ST CHAR
+ TLZ B,77
+ HRR B,(TP) ; POINT
+ SUB TP,[2,,2] ; FLUSH SAVED PDL
+ MOVE C,-1(P) ; GET BYE POINTER
+ SUB P,[2,,2] ; FLUSH
+ PUSH P,D
+ MOVEI A,0
+ IDPB A,B
+ AOS -1(TP) ; COUNT ATOMS
+ TLNE FLAGS,NOQBIT ; SKIP IF NOT "PRINC"
+ JRST NOLEX4 ; NEEDS NO LEXICAL TRAILERS
+ MOVEI A,"\ ; GET QUOTER
+ TLNN E,2 ; SKIP IF NEEDED
+ JRST PATDO1
+ SOS -1(TP) ; DONT COUNT BECAUSE OF SLASH
+ DPB A,B ; CLOBBER
+PATDO1: MOVEI E,(E) ; CLEAR LH(E)
+ PUSH P,C ; SAVE BYTER
+ PUSH P,E ; ALSO CHAR COUNT
+
+ MOVE B,IMQUOTE OBLIST
+ PUSH P,FLAGS
+ PUSHJ P,IDVAL ; GET LOCAL/GLOBAL VALUE
+ POP P,FLAGS ; AND RESTORES FLAGS
+ MOVE C,(TP) ; GET ATOM BACK
+ HRRZ C,2(C) ; GET ITS OBLIST
+ SKIPN C
+ AOJA A,NOOBL1 ; NONE, USE FALSE
+ CAMG C,VECBOT ; JUMP IF REAL OBLIST
+ MOVE C,(C)
+ HRROS C
+ CAME A,$TLIST ; SKIP IF A LIST
+ CAMN A,$TOBLS ; SKIP IF UNREASONABLE VALUE
+ JRST CHOBL ; WINS, NOW LOCATE IT
+
+CHROOT: CAME C,ROOT+1 ; IS THIS ROOT?
+ JRST FNDOBL ; MUST FIND THE PATH NAME
+ POP P,E ; RESTORE CHAR COUNT
+ MOVE D,(P) ; AND PARTIAL WORD
+ EXCH D,-1(P) ; STORE BYTE POINTER AND GET PARTIAL WORD
+ MOVEI A,"! ; PUT OUT MAGIC
+ JSP B,DOIDPB ; INTO BUFFER
+ MOVEI A,"-
+ JSP B,DOIDPB
+ MOVEI A,40
+ JSP B,DOIDPB
+
+NOLEX0: SUB P,[2,,2] ; REMOVE COUNTER AND BYTE POINTER
+ PUSH P,D ; PUSH NEXT WORD IF ANY
+ JRST NOLEX4
+
+NOLEX: MOVE E,(P) ; GET COUNT
+ SUB P,[2,,2]
+NOLEX4: MOVEI E,(E) ; CLOBBER LH(E)
+ MOVE A,E ; COUNT TO A
+ SKIPN (P) ; FLUSH 0 WORD
+ SUB P,[1,,1]
+ HRRZ C,-1(TP) ; GET # OF ATOMS
+ SUBI A,(C) ; FIX COUNT
+ MOVE B,-2(TP) ; GET CHANNEL INTO B
+ PUSHJ P,RETIF ; MAY NEED C.R.
+ MOVEI C,-1(E) ; COMPUTE WORDS-1
+ IDIVI C,5 ; WORDS-1 TO C
+ HRLI C,(C)
+ MOVE D,P
+ SUB D,C ; POINTS TO 1ST WORD OF CHARS
+ MOVSI C,440700+D ; BYTEPOINTER TO STRING
+ PUSH TP,$TPDL ; SAVE FROM GC
+ PUSH TP,D
+
+PATOUT: ILDB A,C ; READ A CHAR
+ SKIPE A ; IGNORE NULS
+ PUSHJ P,PITYO ; PRINT IT
+ MOVE D,(TP) ; RESTORE POINTER
+ SOJG E,PATOUT
+
+NOLEXD: SUB TP,[2,,2] ; FLUSH TP JUNK
+ MOVE P,D ; RESTORE P
+ SUB P,[1,,1]
+ JRST PNEXT
+
+
+PENTCH: TLNE FLAGS,NOQBIT ; "PRINC"?
+ JRST PENTC1 ; YES, AVOID SLASHING
+ IDIVI A,CHRWD ; GET CHARS TYPE
+ LDB B,BYTPNT(B)
+ CAILE B,NONSPC ; SKIP IF NOT SPECIAL
+ JRST PENTC2 ; SLASH IMMEDIATE
+ LDB A,[220600,,E] ; GET "STATE"
+ LDB A,STABYT-1(B) ; GET NEW STATE
+ DPB A,[220600,,E] ; AND SAVE IT
+PENTC3: LDB A,C ; RESTORE CHARACTER
+PENTC1: JSP B,DOIDPB
+ SKIPGE (P) ; SKIP IF DONE
+ JRST PATOM1 ; CONTINUE
+ JRST PATDON
+
+PENTC2: MOVEI A,"\ ; GET CHAR QUOTER
+ JSP B,DOIDPB ; NEEDED, DO IT
+ MOVEI A,4 ; PATCH FOR ATOMS ALREADY BACKSLASHED
+ JRST PENTC3-1
+
+; ROUTINE TO PUT ONE CHAR ON STACK BUFFER
+
+DOIDPB: IDPB A,-1(P) ; DEPOSIT
+ TRNN D,377 ; SKIP IF D FULL
+ AOJA E,(B)
+ PUSH P,(P) ; MOVE TOP OF STACK UP
+ MOVEM D,-2(P) ; SAVE WORDS
+ MOVE D,[440700,,D]
+ MOVEM D,-1(P)
+ MOVEI D,0
+ AOJA E,(B)
+
+; CHECK FOR UNIQUENESS LOOKING INTO PATH
+
+CHOBL: CAME A,$TOBLS ; SINGLE OBLIST?
+ JRST LSTOBL ; NO, AL LIST THEREOF
+ CAME B,C ; THE RIGTH ONE?
+ JRST CHROOT ; NO, CHECK ROOT
+ JRST NOLEX ; WINNER, NO TRAILERS!
+
+LSTOBL: PUSH TP,A ; SCAN A LIST OF OBLISTS
+ PUSH TP,B
+ PUSH TP,A
+ PUSH TP,B
+ PUSH TP,$TOBLS
+ PUSH TP,C
+
+NXTOB2: INTGO ; LIST LOOP, PREVENT LOSSAGE
+ SKIPN C,-2(TP) ; SKIP IF NOT DONE
+ JRST CHROO1 ; EMPTY, CHECK ROOT
+ MOVE B,1(C) ; GET ONE
+ CAME B,(TP) ; WINNER?
+ JRST NXTOBL ; NO KEEP LOOKING
+ CAMN C,-4(TP) ; SKIP IF NOT FIRST ON LIST
+ JRST NOLEX1
+ MOVE A,-6(TP) ; GET ATOM BACK
+ MOVEI D,0
+ ADD A,[3,,3] ; POINT TO PNAME
+ PUSH P,0 ; SAVE FROM RLOOKU
+ PUSH P,(A)
+ ADDI D,5
+ AOBJN A,.-2 ; PUSH THE PNAME
+ PUSH P,D ; AND CHAR COUNT
+ MOVSI A,TLIST ; TELL RLOOKU WE WIN
+ MOVE B,-4(TP) ; GET BACK OBLIST LIST
+ SUB TP,[6,,6] ; FLUSH CRAP
+ PUSHJ P,RLOOKU ; FIND IT
+ POP P,0
+ CAMN B,(TP) ; SKIP IF NON UNIQUE
+ JRST NOLEX ; UNIQUE , NO TRAILER!!
+ JRST CHROO2 ; CHECK ROOT
+
+NXTOBL: HRRZ B,@-2(TP) ; STEP THE LIST
+ MOVEM B,-2(TP)
+ JRST NXTOB2
+
+
+FNDOBL: MOVE C,(TP) ; GET ATOM
+ MOVSI A,TOBLS
+ HRRZ B,2(C)
+ CAMG B,VECBOT
+ MOVE B,(B)
+ HRLI B,-1
+ MOVSI C,TATOM
+ MOVE D,IMQUOTE OBLIST
+ PUSH P,0
+ PUSHJ P,IGET
+ POP P,0
+NOOBL1: POP P,E ; RESTORE CHAR COUNT
+ MOVE D,(P) ; GET PARTIAL WORD
+ EXCH D,-1(P) ; AND BYTE POINTER
+ CAME A,$TATOM ; IF NOT ATOM, USE FALSE
+ JRST NOOBL
+ MOVEM B,(TP) ; STORE IN ATOM SLOT
+ MOVEI A,"!
+ JSP B,DOIDPB ; WRITE IT OUT
+ MOVEI A,"-
+ JSP B,DOIDPB
+ SUB P,[1,,1]
+ JRST PATOM0 ; AND LOOP
+
+NOOBL: MOVE C,[440700,,[ASCIZ /!-#FALSE ()/]]
+ ILDB A,C
+ JUMPE A,NOLEX0
+ JSP B,DOIDPB
+ JRST .-3
+
+
+NOLEX1: SUB TP,[6,,6] ; FLUSH STUFF
+ JRST NOLEX
+
+CHROO1: SUB TP,[6,,6]
+CHROO2: MOVE C,(TP) ; GET ATOM
+ HRRZ C,2(C) ; AND ITS OBLIST
+ CAMG C,VECBOT
+ MOVE C,(C)
+ HRROS C
+ JRST CHROOT
+BADPNM: ERRUUO EQUOTE BAD-PNAME
+
+
+\f; STATE TABLES FOR \ OF FIRST CHAR
+; Each word is a state and each 4 bit byte tells where to go based on the input
+; type. The types are defined in READER >. The input type selects a byte pointer
+; into the table which is indexed by the current state.
+
+RADIX 16.
+
+STATS: 431192440 ; INITIAL STATE (0)
+ 434444444 ; HERE ON INIT +- (1)
+ 222222242 ; HERE ON INIT . (2)
+ 434445642 ; HERE ON INIT DIGIT (3)
+ 444444444 ; HERE IF NO \ NEEDE (4)
+ 454444642 ; HERE ON DDDD. (5)
+ 487744444 ; HERE ON E (6)
+ 484444444 ; HERE ON E+- (7)
+ 484444442 ; HERE ON E+-DDD (8)
+ 494444444+<1_28.> ; HERE ON * (HACK IS TO GET A 10 IN THERE) (9)
+ 494494444+<1_28.>+<2_16.> ; HERE ON *DDDDD (10)
+ 444444442
+
+RADIX 8.
+
+STABYT: 400400,,STATS(A) ; LETTERS
+ 340400,,STATS(A) ; NUMBERS
+ 300400,,STATS(A) ; PLUS SIGN +
+ 240400,,STATS(A) ; MINUS SIGN -
+ 200400,,STATS(A) ; asterick *
+ 140400,,STATS(A) ; PERIOD .
+ 100400,,STATS(A) ; LETTER E
+ 040400,,STATS(A) ; extra
+ 000400,,STATS(A) ; HERE ON RAP UP
+
+\f;PRINT LONG CHARACTER STRINGS.
+;
+PCHSTR: MOVE B,(TP)
+ TLZ FLAGS,ATMBIT ;WE ARE NOT USING ATOM-NAME TYPE ESCAPING
+ MOVE D,[AOS E] ;GET INSTRUCTION TO COUNT CHARACTERS
+ SETZM E ;ZERO COUNT
+ PUSH TP,-3(TP)
+ PUSH TP,-3(TP)
+ PUSH TP,-3(TP)
+ PUSH TP,-3(TP) ;GIVE PCHRST SOME GOODIES TO PLAY WITH
+ PUSHJ P,PCHRST ;GO THROUGH STRING, ESCAPING, ETC. AND COUNTING
+ SUB TP,[4,,4] ;FLUSH MUNGED GOODIES
+ MOVE A,E ;PUT COUNT RETURNED IN REG A
+ TLNN FLAGS,NOQBIT ;SKIP (NO QUOTES) IF IN PRINC (BIT ON)
+ ADDI A,2 ;PLUS TWO FOR QUOTES
+ MOVE B,-2(TP) ; GET CHANNEL INTO B
+ PUSHJ P,RETIF ;START NEW LINE IF NO SPACE
+ TLNE FLAGS,NOQBIT ;SKIP (PRINT ") IF BIT IS OFF (NOT PRINC)
+ JRST PCHS01 ;OTHERWISE, DON'T QUOTE
+ MOVEI A,"" ;PRINT A DOUBLE QUOTE
+ MOVE B,-2(TP)
+ PUSHJ P,PITYO
+
+PCHS01: MOVE D,[PUSHJ P,PITYO] ;OUTPUT INSTRUCTION
+ PUSHJ P,PCHRST ;TYPE STRING
+
+ TLNE FLAGS,NOQBIT ;AGAIN, SKIP IF DOUBLE-QUOTING TO BE DONE
+ JRST PNEXT ;RESTORE REGS & POP UP ONE LEVEL TO CALLER
+ MOVEI A,"" ;PRINT A DOUBLE QUOTE
+ MOVE B,-2(TP) ; GET CHANNEL INTO B
+ PUSHJ P,PITYO
+ JRST PNEXT
+
+
+;INTERNAL ROUTINE USED TO COUNT OR OUTPUT CHARACTER STRINGS.
+;THE APPROPRIATE ESCAPING CONVENTIONS ARE USED AS DETERMINED BY THE FLAG BITS.
+PCHRST: PUSH P,A ;SAVE REGS
+ PUSH P,B
+ PUSH P,C
+ PUSH P,D
+
+PCHR02: INTGO ; IN CASE VERY LONG STRING
+ HRRZ C,-1(TP) ;GET COUNT
+ SOJL C,PCSOUT ; DONE?
+ HRRM C,-1(TP)
+ ILDB A,(TP) ; GET CHAR
+
+ TLNE FLAGS,NOQBIT ;SKIP IF WE ARE NOT IN PRINC MODE (NOQBIT=0)
+ JRST PCSPRT ;IF BIT IS ON, PRINT WITHOUT ESCAPING
+ CAIN A,ESCHAR ;SKIP IF NOT THE ESCAPE CHARACTER
+ JRST ESCPRN ;ESCAPE THE ESCAPE CHARACTER
+ CAIN A,"" ;SKIP IF NOT A DOUBLE QUOTE
+ JRST ESCPRN ;OTHERWISE, ESCAPE THE """
+ IDIVI A,CHRWD ;CODE HERE FINDS CHARACTER TYPE
+ LDB B,BYTPNT(B) ; "
+ CAIG B,NONSPC ;SKIP IF NOT A NUMBER/LETTER
+ JRST PCSPRT ;OTHERWISE, PRINT IT
+ TLNN FLAGS,ATMBIT ;SKIP IF PRINTING AN ATOM-NAME (UNQUOTED)
+ JRST PCSPRT ;OTHERWISE, NO OTHER CHARS TO ESCAPE
+
+ESCPRN: MOVEI A,ESCHAR ;TYPE THE ESCAPE CHARACTER
+ PUSH P,B ; SAVE B
+ MOVE B,-2(TP) ; GET CHANNEL INTO B
+ XCT (P)-1
+ POP P,B ; RESTORE B
+
+PCSPRT: LDB A,(TP) ;GET THE CHARACTER AGAIN
+ PUSH P,B ; SAVE B
+ MOVE B,-2(TP) ; GET CHANNEL INTO B
+ TLNE FLAGS,NOQBIT ; SKIP IF WE ARE NOT IN PRINC MODE (NOQBIT=0)
+ TLO FLAGS,CNTLPC ; SWITCH ON TEMPORARY ^P MODE
+ XCT (P)-1 ;PRINT IT
+ TLZ FLAGS,CNTLPC ; SWITCH OFF ^P MODE
+ POP P,B ; RESTORE B
+ JRST PCHR02 ;LOOP THROUGH STRING
+
+PCSOUT: POP P,D
+ POP P,C ;RESTORE REGS & RETURN
+ POP P,B
+ POP P,A
+ POPJ P,
+
+
+\f
+; PRINT AN ARBITRARY BYTE STRING
+
+PBYTE: PUSH TP,-3(TP)
+ PUSH TP,-3(TP)
+ MOVEI A,"#
+ MOVE B,(TP)
+ PUSHJ P,PRETIF
+ LDB B,[300600,,-2(TP)]
+ MOVSI A,TFIX
+ PUSHJ P,IPRINT
+ MOVE B,(TP)
+ PUSHJ P,SPACEQ
+ MOVEI A,"{
+ MOVE B,(TP)
+ PUSHJ P,PRETIF
+ HRRZ A,-3(TP) ; CHAR COUNT
+ JUMPE A,CLSBYT
+
+BYTLP: SOS -3(TP)
+ ILDB B,-2(TP) ; GET A BYTE
+ MOVSI A,TFIX
+ PUSHJ P,IPRINT
+ HRRZ A,-3(TP)
+ JUMPE A,CLSBYT
+ MOVE B,(TP)
+ PUSHJ P,SPACEQ
+ JRST BYTLP
+
+CLSBYT: MOVEI A,"}
+ MOVE B,(TP)
+ PUSHJ P,PRETIF
+ SUB TP,[2,,2]
+ JRST PNEXT
+
+
+;PRINT AN ARGUMENT LIST
+;CHECK FOR TIME ERRORS
+
+PARGS: MOVEI B,-1(TP) ;POINT TO ARGS POINTER
+ PUSHJ P,CHARGS ;AND CHECK THEM
+ JRST PVEC ; CHEAT TEMPORARILY
+
+
+
+;PRINT A FRAME
+PFRAME: MOVEI B,-1(TP) ;POINT TO FRAME POINTER
+ PUSHJ P,CHFRM
+ HRRZ B,(TP) ;POINT TO FRAME ITSELF
+ HRRZ B,FSAV(B) ;GET POINTER TO SUBROUTINE
+ CAIL B,HIBOT
+ SKIPA B,@-1(B) ; SUBRS AND FSUBRS
+ MOVE B,3(B) ; FOR RSUBRS
+ MOVSI A,TATOM
+ PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
+ PUSH TP,-3(TP)
+ PUSHJ P,IPRINT ;PRINT FUNCTION NAME
+ SUB TP,[2,,2] ; POP CHANNEL OFF STACK
+ JRST PNEXT
+
+PPVP: MOVE B,(TP) ; PROCESS TO B
+ MOVSI A,TFIX
+ JUMPE B,.+3
+ MOVE A,PROCID(B)
+ MOVE B,PROCID+1(B) ;GET ID
+ PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
+ PUSH TP,-3(TP)
+ PUSHJ P,IPRINT
+ SUB TP,[2,,2] ; POP CHANNEL OFF STACK
+ JRST PNEXT
+
+; HERE TO PRINT LOCATIVES
+
+LOCPT1: HRRZ A,-1(TP)
+ JUMPN A,PUNK
+LOCPT: MOVEI B,-1(TP) ; VALIDITY CHECK
+ PUSHJ P,CHLOCI
+ HRRZ A,-1(TP)
+ JUMPE A,GLOCPT
+ MOVE B,(TP)
+ MOVE A,(B)
+ MOVE B,1(B)
+ PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
+ PUSH TP,-3(TP)
+ PUSHJ P,IPRINT
+ SUB TP,[2,,2] ; POP CHANNEL OFF STACK
+ JRST PNEXT
+
+GLOCPT: MOVEI A,2
+ MOVE B,-2(TP) ; GET CHANNEL
+ PUSHJ P,RETIF
+ MOVEI A,"%
+ PUSHJ P,PITYO
+ MOVEI A,"<
+ PUSHJ P,PITYO
+ MOVSI A,TATOM
+ MOVE B,MQUOTE GLOC
+ PUSH TP,-3(TP)
+ PUSH TP,-3(TP)
+ PUSHJ P,IPRINT
+ SUB TP,[2,,2]
+ MOVE B,-2(TP) ; MOVE IN CHANNEL
+ PUSHJ P,SPACEQ
+ MOVE B,(TP)
+ MOVSI A,TATOM
+ MOVE B,-1(B)
+ PUSH TP,-3(TP)
+ PUSH TP,-3(TP)
+ PUSHJ P,IPRINT
+ SUB TP,[2,,2]
+ MOVE B,-2(TP) ; MOVE IN CHANNEL
+ PUSHJ P,SPACEQ
+ MOVSI A,TATOM
+ MOVE B,IMQUOTE T
+ PUSH TP,-3(TP)
+ PUSH TP,-3(TP)
+ PUSHJ P,IPRINT
+ SUB TP,[2,,2]
+ MOVE B,-2(TP) ; MOVE IN CHANNEL
+ MOVEI A,">
+ PUSHJ P,PRETIF
+ JRST PNEXT
+
+LOCRPT: MOVEI A,2
+ MOVE B,-2(TP) ; GET CHANNEL
+ PUSHJ P,RETIF
+ MOVEI A,"%
+ PUSHJ P,PITYO
+ MOVEI A,"<
+ PUSHJ P,PITYO
+ MOVSI A,TATOM
+ MOVE B,MQUOTE RGLOC
+ PUSH TP,-3(TP)
+ PUSH TP,-3(TP)
+ PUSHJ P,IPRINT
+ SUB TP,[2,,2]
+ MOVE B,-2(TP) ; MOVE IN CHANNEL
+ PUSHJ P,SPACEQ
+ MOVE B,(TP)
+ MOVSI A,TATOM
+ ADD B,GLOTOP+1 ; GET TO REAL ATOM
+ MOVE B,-1(B)
+ PUSH TP,-3(TP)
+ PUSH TP,-3(TP)
+ PUSHJ P,IPRINT
+ SUB TP,[2,,2]
+ MOVE B,-2(TP) ; MOVE IN CHANNEL
+ PUSHJ P,SPACEQ
+ MOVSI A,TATOM
+ MOVE B,IMQUOTE T
+ PUSH TP,-3(TP)
+ PUSH TP,-3(TP)
+ PUSHJ P,IPRINT
+ SUB TP,[2,,2]
+ MOVE B,-2(TP) ; MOVE IN CHANNEL
+ MOVEI A,">
+ PUSHJ P,PRETIF
+ JRST PNEXT
+
+\f;PRINT UNIFORM VECTORS.
+;
+PUVEC: MOVE B,-2(TP) ; GET CHANNEL INTO B
+ MOVEI A,2 ; ROOM FOR ! AND SQ BRACK?
+ PUSHJ P,RETIF
+ MOVEI A,"! ;TYPE AN ! AND OPEN SQUARE BRACKET
+ PUSHJ P,PITYO
+ MOVEI A,"[
+ PUSHJ P,PITYO
+
+ MOVE C,(TP) ;GET AOBJN POINTER TO VECTOR
+ TLNN C,777777 ;SKIP ONLY IF COUNT IS NOT ZERO
+ JRST NULVEC ;ELSE, VECTOR IS EMPTY
+
+ HLRE A,C ;GET NEG COUNT
+ MOVEI D,(C) ;COPY POINTER
+ SUB D,A ;POINT TO DOPE WORD
+ HLLZ A,(D) ;GET TYPE
+ PUSH P,A ;AND SAVE IT
+
+PUVE02: MOVE A,(P) ;PUT TYPE CODE IN REG A
+ MOVE B,(C) ;PUT DATUM INTO REG B
+ PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
+ PUSH TP,-3(TP)
+ PUSHJ P,IPRINT ;TYPE IT
+ SUB TP,[2,,2] ; POP CHANNEL OF STACK
+ MOVE C,(TP) ;GET AOBJN POINTER
+ AOBJP C,NULVE1 ;JUMP IF COUNT IS ZERO
+ MOVEM C,(TP) ;PUT POINTER BACK ONTO STACK
+
+ MOVE B,-2(TP) ; GET CHANNEL INTO B
+ PUSHJ P,SPACEQ
+ MOVE C,(TP)
+ JRST PUVE02 ;LOOP THROUGH VECTOR
+
+NULVE1: SUB P,[1,,1] ;REMOVE STACK CRAP
+NULVEC: MOVE B,-2(TP) ; GET CHANNEL INTO B
+ MOVEI A,"! ;TYPE CLOSE BRACKET
+ PUSHJ P,PRETIF
+ MOVEI A,"]
+ PUSHJ P,PRETIF
+ JRST PNEXT
+
+\f;PRINT A GENERALIZED VECTOR
+;
+PVEC: MOVE B,-2(TP) ; GET CHANNEL INTO B
+ PUSHJ P,RETIF1 ;NEW LINE IF NO ROOM FOR [
+ MOVEI A,"[ ;PRINT A LEFT-BRACKET
+ PUSHJ P,PITYO
+
+ MOVE C,(TP) ;GET AOBJN POINTER TO VECTOR
+ TLNN C,777777 ;SKIP IF POINTER-COUNT IS NON-ZERO
+ JRST PVCEND ;ELSE, FINISHED WITH VECTOR
+PVCR01: MOVE A,(C) ;PUT FIRST WORD OF NEXT ELEMENT INTO REG A
+ MOVE B,1(C) ;SECOND WORD OF LIST INTO REG B
+ PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
+ PUSH TP,-3(TP)
+ PUSHJ P,IPRINT ;PRINT THAT ELEMENT
+ SUB TP,[2,,2] ; POP CHANNEL OFF STACK
+
+ MOVE C,(TP) ;GET AOBJN POINTER FROM TP-STACK
+ AOBJP C,PVCEND ;POSITIVE HERE SERIOUS ERROR! (THOUGH NOT PDL)
+ AOBJN C,.+2 ;SKIP AND CONTINUE LOOP IF COUNT NOT ZERO
+ JRST PVCEND ;ELSE, FINISHED WITH VECTOR
+ MOVEM C,(TP) ;PUT INCREMENTED POINTER BACK ON TP-STACK
+
+ MOVE B,-2(TP) ; GET CHANNEL INTO B
+ PUSHJ P,SPACEQ
+ MOVE C,(TP) ; RESTORE REGISTER C
+ JRST PVCR01 ;CONTINUE LOOPING THROUGH OBJECTS ON VECTOR
+
+PVCEND: MOVE B,-2(TP) ; GET CHANNEL INTO B
+ PUSHJ P,RETIF1 ;NEW LINE IF NO ROOM FOR ]
+ MOVEI A,"] ; PRINT A RIGHT-BRACKET
+ PUSHJ P,PITYO
+ JRST PNEXT
+
+\f;PRINT A LIST.
+;
+PLIST: MOVE B,-2(TP) ; GET CHANNEL INTO B
+ PUSHJ P,RETIF1 ;NEW LINE IF NO SPACE LEFT FOR "("
+ MOVEI A,"( ;TYPE AN OPEN PAREN
+ PUSHJ P,PITYO
+ PUSHJ P,LSTPRT ;PRINT THE INSIDES
+ MOVE B,-2(TP) ; RESTORE CHANNEL TO B
+ PUSHJ P,RETIF1 ;NEW LINE IF NO ROOM FOR THE CLOSE PAREN
+ MOVEI A,") ;TYPE A CLOSE PAREN
+ PUSHJ P,PITYO
+ JRST PNEXT
+
+PSEG: TLOA FLAGS,SEGBIT ;PRINT A SEGMENT (& SKIP)
+
+PFORM: TLZ FLAGS,SEGBIT ;PRINT AN ELEMENT
+
+PLMNT3: MOVE C,(TP)
+ JUMPE C,PLMNT1 ;IF THE CALL IS EMPTY GO AWAY
+ MOVE B,1(C)
+ MOVEI D,0
+ CAMN B,IMQUOTE LVAL
+ MOVEI D,".
+ CAMN B,IMQUOTE GVAL
+ MOVEI D,",
+ CAMN B,IMQUOTE QUOTE
+ MOVEI D,"'
+ JUMPE D,PLMNT1 ;NEITHER, LEAVE
+
+;ITS A SPECIAL HACK
+ HRRZ C,(C)
+ JUMPE C,PLMNT1 ;NIL BODY?
+
+;ITS VALUE OF AN ATOM
+ HLLZ A,(C)
+ MOVE B,1(C)
+ HRRZ C,(C)
+ JUMPN C,PLMNT1 ;IF TERE ARE EXTRA ARGS GO AWAY
+
+ PUSH P,D ;PUSH THE CHAR
+ PUSH TP,A
+ PUSH TP,B
+ TLNN FLAGS,SEGBIT ;SKIP (CONTINUE) IF THIS IS A SEGMENT
+ JRST PLMNT4 ;ELSE DON'T PRINT THE "."
+
+;ITS A SEGMENT CALL
+ MOVE B,-4(TP) ; GET CHANNEL INTO B
+ MOVEI A,2 ; ROOM FOR ! AND . OR ,
+ PUSHJ P,RETIF
+ MOVEI A,"!
+ PUSHJ P,PITYO
+
+PLMNT4: MOVE B,-4(TP) ; GET CHANNEL INTO B
+ PUSHJ P,RETIF1
+ POP P,A ;RESTORE CHAR
+ PUSHJ P,PITYO
+ POP TP,B
+ POP TP,A
+ PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
+ PUSH TP,-3(TP)
+ PUSHJ P,IPRINT
+ SUB TP,[2,,2] ; POP CHANNEL OFF STACK
+ JRST PNEXT
+
+
+PLMNT1: TLNN FLAGS,SEGBIT ;SKIP IF THIS IS A SEGMENT
+ JRST PLMNT5 ;ELSE DON'T TYPE THE "!"
+
+;ITS A SEGMENT CALL
+ MOVE B,-2(TP) ; GET CHANNEL INTO B
+ MOVEI A,2 ; ROOM FOR ! AND <
+ PUSHJ P,RETIF
+ MOVEI A,"!
+ PUSHJ P,PITYO
+
+PLMNT5: MOVE B,-2(TP) ; GET CHANNEL FOR B
+ PUSHJ P,RETIF1
+ MOVEI A,"<
+ PUSHJ P,PITYO
+ PUSHJ P,LSTPRT
+ MOVEI A,"!
+ MOVE B,-2(TP) ; GET CHANNEL INTO B
+ TLNE FLAGS,SEGBIT ;SKIP IF NOT SEGEMNT
+ PUSHJ P,PRETIF
+ MOVEI A,">
+ PUSHJ P,PRETIF
+ JRST PNEXT
+
+
+\f
+LSTPRT: SKIPN C,(TP)
+ POPJ P,
+ HLLZ A,(C) ;GET NEXT ELEMENT
+ MOVE B,1(C)
+ HRRZ C,(C) ;CHOP THE LIST
+ JUMPN C,PLIST1
+ PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
+ PUSH TP,-3(TP)
+ PUSHJ P,IPRINT ;PRINT THE LAST ELEMENT
+ SUB TP,[2,,2] ; POP CHANNEL OFF STACK
+ POPJ P,
+
+PLIST1: MOVEM C,(TP)
+ PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
+ PUSH TP,-3(TP)
+ PUSHJ P,IPRINT ;PRINT THE NEXT ELEMENT
+ SUB TP,[2,,2] ; POP CHANNEL OFF STACK
+ MOVE B,-2(TP) ; GET CHANNEL INTO B
+ PUSHJ P,SPACEQ
+ JRST LSTPRT ;REPEAT
+
+PNEXT: POP P,FLAGS ;RESTORE PREVIOUS FLAG BITS
+ SUB TP,[2,,2] ;REMOVE INPUT ELEMENT FROM TP-STACK
+ POP P,C ;RESTORE REG C
+ POPJ P,
+
+OPENIT: PUSH P,A
+ PUSH P,B
+ PUSH P,C
+ PUSH P,D
+ PUSH P,FLAGS
+ PUSHJ P,OPNCHN
+ POP P,FLAGS
+ POP P,D
+ POP P,C
+ POP P,B
+ POP P,A
+ JUMPGE B,FNFFL ;ERROR IF IT CANNOT BE OPENED
+ HRRZ E,-2(B)
+ POPJ P,
+
+
+END
+\f
\ No newline at end of file
--- /dev/null
+TITLE PRINTER ROUTINE FOR MUDDLE
+
+RELOCATABLE
+
+.INSRT DSK:MUDDLE >
+
+.GLOBAL IPNAME,MTYO,RLOOKU,RADX,INAME,INTFCN,LINLN,DOIOTO,BFCLS1,ATOSQ,IGVAL
+.GLOBAL BYTPNT,OPNCHN,CHRWRD,IDVAL,CHARGS,CHFRM,CHLOCI,PRNTYP,PRTYPE,IBLOCK,WXCT
+.GLOBAL VECBOT,VAL,ITEM,INDIC,IOINS,DIRECT,TYPVEC,CHRPOS,LINPOS,ACCESS,PAGLN,ROOT,PROCID
+.GLOBAL BADCHN,WRONGD,CHNCLS,IGET,FNFFL,ILLCHO,BUFSTR,BYTDOP,6TOCHS,PURVEC,STBL,RXCT
+.GLOBAL TMPLNT,TD.LNT,BADTPL,MPOPJ,SSPEC1,GLOTOP,GTLPOS,SPSTOR,PVSTOR
+.GLOBAL CIPRIN,CIPRNC,CIPRN1,CPATM,CP1ATM,CPCATM,CPSTR,CP1STR,CPCSTR
+.GLOBAL CIFLTZ,CITERP,CIUPRS,CPCH,CPCH1,CICRLF,NONSPC
+
+BUFLNT==100 ; BUFFER LENGTH IN WORDS
+
+FLAGS==0 ;REGISTER USED TO STORE FLAGS
+CARRET==15 ;CARRIAGE RETURN CHARACTER
+ESCHAR=="\ ;ESCAPE CHARACTER
+SPACE==40 ;SPACE CHARACTER
+ATMBIT==200000 ;BIT SWITCH FOR ATOM-NAME PRINT
+NOQBIT==020000 ;SWITCH FOR NO ESCAPING OF OUTPUT (PRINC)
+SEGBIT==010000 ;SWITCH TO INDICATE PRINTING A SEGMENT
+SPCBIT==004000 ;SWITCH TO INDICATE "PRINT" CALL (PUT A SPACE AFTER)
+FLTBIT==002000 ;SWITCH TO INDICATE "FLATSIZE" CALL
+HSHBIT==001000 ;SWITCH TO INDICATE "PHASH" CALL
+TERBIT==000400 ;SWITCH TO INDICATE "TERPRI" CALL
+UNPRSE==000200 ;SWITCH TO INDICATE "UNPARSE" CALL
+ASCBIT==000100 ;SWITCH TO INDICATE USING A "PRINT" CHANNEL
+BINBIT==000040 ;SWITCH TO INDICATE USING A "PRINTB" CHANNEL
+CNTLPC==000020 ;SWITCH TO INDICATE USING ^P CODE IOT
+PJBIT==400000
+C.BUF==1
+C.PRIN==2
+C.BIN==4
+C.OPN==10
+C.READ==40
+
+
+\fMFUNCTION FLATSIZE,SUBR
+ DEFINE FLTMAX
+ 4(B) TERMIN
+ DEFINE FLTSIZ
+ 2(B)TERMIN
+;FLATSIZE TAKES TWO OR THREE ARGUMENTS: THE FIRST IS AN OBJECT THE SECOND
+;IS THE MAXIMUM SIZE BEFORE IT GIVES UP AN RETURNS FALSE
+;THE THIRD (OPTIONAL) ARGUMENT IS A RADIX
+ ENTRY
+ CAMG AB,[-2,,0] ;CHECK NUMBER OF ARGS
+ CAMG AB,[-6,,0]
+ JRST WNA
+ PUSH P,3(AB)
+
+ GETYP A,2(AB)
+ CAIE A,TFIX
+ JRST WTYP2 ;SECOND ARG NOT FIX THEN LOSE
+\r CAMG AB,[-4,,0] ;SEE IF THERE IS A RADIX ARGUMENT
+ JRST .+3 ; RADIX SUPPLIED
+ PUSHJ P,GTRADX ; GET THE RADIX FROM OUTCHAN
+ JRST FLTGO
+ GETYP A,4(AB) ;CHECK TO SEE THAT RADIX IS FIX
+ CAIE A,TFIX
+ JRST WTYP ;ERROR THIRD ARGUMENT WRONG TYPE
+ MOVE C,5(AB)
+ PUSHJ P,GETARG ; GET ARGS INTO A AND B
+FLTGO: POP P,D ; RESTORE FLATSIZE MAXIMUM
+ PUSHJ P,CIFLTZ
+ JFCL
+ JRST FINIS
+
+
+
+MFUNCTION UNPARSE,SUBR
+ DEFINE UPB
+ 0(B) TERMIN
+
+ ENTRY
+
+ JUMPGE AB,TFA
+ MOVE E,TP ;SAVE TP POINTER
+
+
+
+;TURN ON FLTBIT TO AVOID PRINTING LOSSAGE
+;TURN ON UNPRSE TO CAUSE CHARS TO BE STASHED
+ CAMG AB,[-2,,0] ;SKIP IF RADIX SUPPLIED
+ JRST .+3
+ PUSHJ P,GTRADX ;GET THE RADIX FROM OUTCHAN
+ JRST UNPRGO
+ CAMGE AB,[-5,,0] ;CHECK FOR TOO MANY
+ JRST TMA
+ GETYP 0,2(AB)
+ CAIE 0,TFIX ;SEE IF RADIX IS FIXED
+ JRST WTYP2
+ MOVE C,3(AB) ;GET RADIX\r
+ PUSHJ P,GETARG ;GET ARGS INTO A AND B
+UNPRGO: PUSHJ P,CIUPRS
+ JRST FINIS
+ JRST FINIS
+
+
+GTRADX: MOVE B,IMQUOTE OUTCHAN
+ PUSH P,0 ;SAVE FLAGS
+ PUSHJ P,IDVAL ;GET VALUE FOR OUTCHAN
+ POP P,0
+ GETYP A,A ;CHECK TYPE OF CHANNEL
+ CAIE A,TCHAN
+ JRST FUNCH1-1 ;IT IS A TP-POINTER
+ MOVE C,RADX(B) ;GET RADIX FROM OUTCHAN
+ JRST FUNCH1
+ MOVE C,(B)+6 ;GET RADIX FROM STACK
+
+FUNCH1: CAIG C,1 ;CHECK FOR STRANGE RADIX
+ MOVEI C,10. ;DEFAULT IF THIS IS THE CASE
+GETARG: MOVE A,(AB)
+ MOVE B,1(AB)
+ POPJ P,
+
+
+IMFUNCTION PRINT,SUBR
+ ENTRY
+ PUSHJ P,AGET ; GET ARGS
+ PUSHJ P,CIPRIN
+ JRST FINIS
+
+MFUNCTION PRINC,SUBR
+ ENTRY
+ PUSHJ P,AGET ; GET ARGS
+ PUSHJ P,CIPRNC
+ JRST FINIS
+
+MFUNCTION PRIN1,SUBR
+ ENTRY
+ PUSHJ P,AGET
+ PUSHJ P,CIPRN1
+ JRST FINIS
+
+
+MFUNCTION CRLF,SUBR
+ ENTRY
+ PUSHJ P,AGET1
+ PUSHJ P,CICRLF
+ JRST FINIS
+
+MFUNCTION TERPRI,SUBR
+ ENTRY
+ PUSHJ P,AGET1
+ PUSHJ P,CITERP
+ JRST FINIS
+
+\f
+CICRLF: SKIPA E,.
+CITERP: MOVEI E,0
+ SUBM M,(P)
+ MOVSI 0,TERBIT+SPCBIT ; SET UP FLAGS
+ PUSH P,E
+ PUSHJ P,TESTR ; TEST FOR GOOD CHANNEL
+ MOVEI A,CARRET ; MOVE IN CARRIAGE-RETURN
+ PUSHJ P,PITYO ; PRINT IT OUT
+ MOVEI A,12 ; LINE-FEED
+ PUSHJ P,PITYO
+ POP P,0
+ JUMPN 0,.+4
+ MOVSI A,TFALSE ; RETURN A FALSE
+ MOVEI B,0
+ JRST MPOPJ ; RETURN
+
+ MOVSI A,TATOM
+ MOVE B,IMQUOTE T
+ JRST MPOPJ
+
+TESTR: GETYP E,A
+ CAIN E,TCHAN ; CHANNEL?
+ JRST TESTR1 ; OK?
+ CAIE E,TTP
+ JRST BADCHN
+ HLRZS 0
+ IOR 0,A ; RESTORE FLAGS
+ HRLZS 0
+ POPJ P,
+TESTR1: HRRZ E,-2(B) ; GET IN FLAGS FROM CHANNEL
+ SKIPN IOINS(B)
+ PUSHJ P,OPENIT
+ TRNN E,C.OPN ; SKIP IF OPEN
+ JRST CHNCLS
+ TRC E,C.PRIN+C.OPN ; CHECK TO SEE THAT CHANNEL IS GOOD
+ TRNE E,C.PRIN+C.OPN
+ JRST BADCHN ; ITS A LOSER
+ TRNE E,C.BIN
+ JRST PSHNDL ; DON'T HANDLE BINARY
+ TLO ASCBIT ; ITS ASCII
+ POPJ P, ; ITS A WINNER
+
+PSHNDL: PUSH TP,C ; SAVE ARGS
+ PUSH TP,D
+ PUSH TP,A ; PUSH CHANNEL ONTO STACK
+ PUSH TP,B
+ PUSHJ P,BPRINT ; CHECK BUFFER
+ POP TP,B
+ POP TP,A
+ POP TP,D
+ POP TP,C
+ POPJ P,
+
+
+\f;CIUPRS NEEDS A RADIX IN C AND A TYPE-OBJECT PAIR IN A,B
+
+CIUPRS: SUBM M,(P) ; MODIFY M-POINTER
+ MOVE E,TP ; SAVE TP-POINTER
+ PUSH TP,[0] ; SLOT FOR FIRST STRING COPY
+ PUSH TP,[0]
+ PUSH TP,[0] ; AND SECOND STRING
+ PUSH TP,[0]
+ PUSH TP,A ; SAVE OBJECTS
+ PUSH TP,B
+ PUSH TP,$TTP ; SAVE TP POINTER
+ PUSH TP,E
+ PUSH P,C
+ MOVE D,[377777,,-1] ; MOVE IN MAXIMUM NUMBER FOR FLATSIZE
+ PUSHJ P,CIFLTZ ; FIND LENGTH OF STRING
+ FATAL UNPARSE BLEW IT
+ MOVEI A,4(B)
+ PUSH P,B
+ IDIVI A,5
+ PUSHJ P,IBLOCK ; GET A BLOCK
+ POP P,A
+ HRLI A,TCHSTR
+ HRLI B,010700
+ SUBI B,1
+ POP TP,E ; RESTORE TP-POINTER
+ SUB TP,[1,,1] ;GET RID OF TYPE WORD
+ MOVEM A,1(E) ; SAVE RESULTS
+ MOVEM A,3(E)
+ MOVEM B,2(E)
+ MOVEM B,4(E)
+ POP TP,B ; RESTORE THE WORLD
+ POP TP,A
+ POP P,C
+ MOVSI 0,FLTBIT+UNPRSE ; SET UP FLAGS
+ PUSHJ P,CUSET
+ JRST MPOPJ ; RETURN
+
+
+
+; FOR CIFLTZ C CONTAINS THE RADIX, D THE MAXIMUM NUMBER OF CHARACTERS,
+; A,B THE TYPE-OBJECT PAIR
+
+CIFLTZ: SUBM M,(P)
+ MOVE E,TP ; SAVE POINTER
+ PUSH TP,$TFIX ; PUSH ON FLATSIZE COUNT
+ PUSH TP,[0]
+ PUSH TP,$TFIX ; PUSH ON FLATSIZE MAXIMUM
+ PUSH TP,D
+ MOVSI 0,FLTBIT ; MOVE ON FLATSIZE FLAG
+ PUSHJ P,CUSET ; CONTINUE
+ JRST MPOPJ
+ SOS (P) ; SKIP RETURN
+ JRST MPOPJ ; RETURN
+
+; CUSET IS THE ROUTINE USED BY FLATSIZE AND UNPARSE TO DO THE PUSHING,POPING AND CALLING
+; NEEDED TO GET A RESULT.
+
+CUSET: PUSH TP,$TFIX ; PUSH ON RADIX
+ PUSH TP,C
+ PUSH TP,$TPDL
+ PUSH TP,P ; PUSH ON RETURN POINTER IN CASE FLATSIZE GETS A FALSE
+ PUSH TP,A ; SAVE OBJECTS
+ PUSH TP,B
+ MOVSI C,TTP ; CONSTRUCT TP-POINTER
+ HLR C,FLAGS ; SAVE FLAGS IN TP-POINTER
+ MOVE D,E
+ PUSH TP,C ; PUSH ON CHANNEL
+ PUSH TP,D
+ PUSHJ P,IPRINT ; GO TO INTERNAL PRINTER
+ POP TP,B ; GET IN TP POINTER
+ MOVE TP,B ; RESTORE POINTER
+ TLNN FLAGS,UNPRSE ; SEE IF UNPARSE CALL
+ JRST FLTGEN ; ITS A FLATSIZE
+ MOVE A,UPB+3 ; RETURN STRING
+ MOVE B,UPB+4
+ POPJ P, ; DONE
+FLTGEN: MOVE A,FLTSIZ-1 ; GET IN COUNT
+ MOVE B,FLTSIZ
+ AOS (P)
+ POPJ P, ; EXIT
+
+\f
+; CIPRIN,CIPRNC,CIPRN1,CPATM,CP1ATM,CPCATM,CPSTR,CP1STR,CPCSTR ALL ASSUME
+; THAT C,D CONTAIN THE OBJECT AND A AND B CONTAIN THE CHANNEL
+
+CIPRIN: SUBM M,(P)
+ MOVSI 0,SPCBIT ; SET UP FLAGS
+ PUSHJ P,TPRT ; PRINT INITIALIZATION
+ PUSHJ P,IPRINT
+ JRST TPRTE ; EXIT
+
+CIPRN1: SUBM M,(P)
+ MOVEI FLAGS,0 ; SET UP FLAGS
+ PUSHJ P,TPR1 ; INITIALIZATION
+ PUSHJ P,IPRINT ; PRINT IT OUT
+ JRST TPR1E ; EXIT
+
+CIPRNC: SUBM M,(P)
+ MOVSI FLAGS,NOQBIT ; SET UP FLAGS
+ PUSHJ P,TPR1 ; INITIALIZATION
+ PUSHJ P,IPRINT
+ JRST TPR1E ; EXIT
+\f
+; INITIALIZATION FOR PRINT ROUTINES
+
+TPRT: PUSHJ P,TESTR ; SEE IF CHANNEL IS OK
+ PUSH TP,C ; SAVE ARGUMENTS
+ PUSH TP,D
+ PUSH TP,A ; SAVE CHANNEL
+ PUSH TP,B
+ MOVEI A,CARRET ; PRINT CARRIAGE RETURN
+ PUSHJ P,PITYO
+ MOVEI A,12 ; AND LF
+ PUSHJ P,PITYO
+ MOVE A,-3(TP) ; MOVE IN ARGS
+ MOVE B,-2(TP)
+ POPJ P,
+
+; EXIT FOR PRINT ROUTINES
+
+TPRTE: POP TP,B ; RESTORE CHANNEL
+ MOVEI A,SPACE ; PRINT TRAILING SPACE
+ PUSHJ P,PITYO
+ SUB TP,[1,,1] ; GET RID OF CHANNEL TYPE-WORD
+ POP TP,B ; RETURN WHAT WAS PASSED
+ POP TP,A
+ JRST MPOPJ ; EXIT
+
+; INITIALIZATION FOR PRIN1 AND PRINC ROUTINES
+
+TPR1: PUSHJ P,TESTR ; SEE IF CHANNEL IS OK
+ PUSH TP,C ; SAVE ARGS
+ PUSH TP,D
+ PUSH TP,A ; SAVE CHANNEL
+ PUSH TP,B
+ MOVE A,-3(TP) ; GET ARGS
+ MOVE B,-2(TP)
+ POPJ P,
+
+; EXIT FOR PRIN1 AND PRINC ROUTINES
+
+TPR1E: SUB TP,[2,,2] ; REMOVE CHANNEL
+ POP TP,B ; RETURN ARGUMENTS THAT WERE GIVEN
+ POP TP,A
+ JRST MPOPJ ; EXIT
+
+
+\f
+CPATM: SUBM M,(P)
+ MOVSI C,TATOM ; GET TYPE FOR BINARY
+ MOVEI 0,SPCBIT ; SET UP FLAGS
+ PUSHJ P,TPRT ; PRINT INITIALIZATION
+ PUSHJ P,CPATOM ; PRINT IT OUT
+ JRST TPRTE ; EXIT
+
+CP1ATM: SUBM M,(P)
+ MOVE C,$TATOM
+ MOVEI FLAGS,0 ; SET UP FLAGS
+ PUSHJ P,TPR1 ; INITIALIZATION
+ PUSHJ P,CPATOM ; PRINT IT OUT
+ JRST TPR1E ; EXIT
+
+CPCATM: SUBM M,(P)
+ MOVE C,$TATOM
+ MOVSI FLAGS,NOQBIT ; SET UP FLAGS
+ PUSHJ P,TPR1 ; INITIALIZATION
+ PUSHJ P,CPATOM ; PRINT IT OUT
+ JRST TPR1E ; EXIT
+
+
+; THIS ROUTINE IS USD TO PRINT ONE CHARACTER. THE CHANNEL IS IN A AND B THE
+; CHARACTER IS IN C.
+CPCH1: TDZA 0,0
+CPCH: MOVEI 0,1
+ SUBM M,(P)
+ PUSH P,0
+ MOVSI FLAGS,NOQBIT
+ MOVE C,$TCHRS
+ PUSHJ P,TESTR ; SEE IF CHANNEL IS GOOD
+ EXCH D,(P) ; CHAR TO STACK, IND TO D
+ MOVE A,(P) ; MOVE IN CHARACTER FOR PITYO
+ JUMPE D,.+3
+ PUSHJ P,PRETIF
+ JRST .+2
+ PUSHJ P,PITYO
+ MOVE A,$TCHRST ; RETURN THE CHARACTER
+ POP P,B
+ JRST MPOPJ
+
+
+
+
+CPSTR: SUBM M,(P)
+ HRLI C,TCHSTR
+ MOVSI 0,SPCBIT ; SET UP FLAGS
+ PUSHJ P,TPRT ; PRINT INITIALIZATION
+ PUSHJ P,CPCHST ; PRINT IT OUT
+ JRST TPRTE ; EXIT
+
+CP1STR: SUBM M,(P)
+ HRLI C,TCHSTR
+ MOVEI FLAGS,0 ; SET UP FLAGS
+ PUSHJ P,TPR1 ; INITIALIZATION
+ PUSHJ P,CPCHST ; PRINT IT OUT
+ JRST TPR1E ; EXIT
+
+CPCSTR: SUBM M,(P)
+ HRLI C,TCHSTR
+ MOVSI FLAGS,NOQBIT ; SET UP FLAGS
+ PUSHJ P,TPR1 ; INITIALIZATION
+ PUSHJ P,CPCHST ; PRINT IT OUT
+ JRST TPR1E ; EXIT
+
+
+CPATOM: PUSH TP,A ; COPY ARGS FOR INTERNAL SAKE\r
+ PUSH TP,B
+ PUSH P,0 ; ATOM CALLER ROUTINE
+ PUSH P,C
+ SKIPN C,PRNTYP+1
+ JRST PATOM
+ ADDI C,TATOM+TATOM
+ SKIPE (C) ; SKIP IF UNCHANGED PRINT TYPE OR DISPATCH
+ JRST PRDIS1
+ SKIPN C,1(C)
+ JRST PATOM
+ JRST (C)
+
+CPCHST: PUSH TP,A ; COPY ARGS FOR INTERNAL SAKE\r
+ PUSH TP,B
+ PUSH P,C ; STRING CALLER ROUTINE
+ PUSH P,FLAGS
+ SKIPN C,PRNTYP+1
+ JRST PATOM
+ ADDI C,TCHSTR+TCHSTR
+ SKIPE (C) ; SKIP IF UNCHANGED PRINT TYPE OR DISPATCH
+ JRST PRDIS1
+ SKIPN C,1(C)
+ JRST PCHSTR
+ JRST (C)
+
+
+\f\r
+AGET: MOVEI FLAGS,0
+ SKIPL E,AB ; COPY ARG POINTER
+ JRST TFA ;NO ARGS IS AN ERROR
+ ADD E,[2,,2] ;POINT AT POSSIBLE CHANNEL
+ JRST COMPT
+AGET1: MOVE E,AB ; GET COPY OF AB
+ MOVSI FLAGS,TERBIT
+
+COMPT: PUSH TP,$TFIX ;LEAVE ROOM ON STACK FOR ONE CHANNEL
+ PUSH TP,[0]
+ JUMPGE E,DEFCHN ;IF NO CHANNEL ARGUMENT, USE CURRENT BINDING
+ CAMG E,[-2,,0] ;IF MORE ARGS THEN ERROR
+ JRST TMA
+ MOVE A,(E) ;GET CHANNEL
+ MOVE B,(E)+1
+ JRST NEWCHN
+
+DEFCHN: MOVE B,IMQUOTE OUTCHAN
+ MOVSI A,TATOM
+ PUSH P,FLAGS ;SAVE FLAGS
+ PUSHJ P,IDVAL ;GET VALUE OF OUTCHAN
+ POP P,0
+
+NEWCHN: TLNE FLAGS,TERBIT ; SEE IF TERPRI
+ POPJ P,
+ MOVE C,(AB) ; GET ARGS
+ MOVE D,1(AB)
+ POPJ P,
+
+; HERE IF USING A PRINTB CHANNEL
+
+BPRINT: TLO FLAGS,BINBIT
+ SKIPE BUFSTR(B) ; ANY OUTPUT BUFFER?
+ POPJ P,
+
+; HERE TO GENERATE A STRING BUFFER
+
+ PUSH P,FLAGS
+ MOVEI A,BUFLNT ; GET BUFFER LENGTH
+ PUSHJ P,IBLOCK ; MAKE A BUFFER
+ MOVSI 0,TWORD+.VECT. ; CLOBBER U TYPE
+ MOVEM 0,BUFLNT(B)
+ SETOM (B) ; -1 THE BUFFER
+ MOVEI C,1(B)
+ HRLI C,(B)
+ BLT C,BUFLNT-1(B)
+ HRLI B,010700
+ SUBI B,1
+ MOVE C,(TP)
+ MOVEM B,BUFSTR(C) ; STOR BYTE POINTER
+ MOVE 0,[TCHSTR,,BUFLNT*5]
+ MOVEM 0,BUFSTR-1(C)
+ POP P,FLAGS
+ MOVE B,(TP)
+ POPJ P,
+\f
+
+IPRINT: PUSH P,C ; SAVE C
+ PUSH P,FLAGS ;SAVE PREVIOUS FLAGS
+ PUSH TP,A ;SAVE ARGUMENT ON TP-STACK
+ PUSH TP,B
+
+ INTGO ;ALLOW INTERRUPTS HERE
+
+ GETYP A,-1(TP) ;GET THE TYPE CODE OF THE ITEM
+ SKIPE C,PRNTYP+1 ; USER TYPE TABLE?
+ JRST PRDISP
+NORMAL: CAILE A,NUMPRI ;PRIMITIVE?
+ JRST PUNK ;JUMP TO ERROR ROUTINE IF CODE TOO GREAT
+ HRRO A,PRTYPE(A) ;YES-DISPATCH
+ JRST (A)
+
+; HERE FOR USER PRINT DISPATCH
+
+PRDISP: ADDI C,(A) ; POINT TO SLOT
+ ADDI C,(A)
+ SKIPE (C) ; SKIP EITHER A LOSER OR JRST DISP
+ JRST PRDIS1 ; APPLY EVALUATOR
+ SKIPN C,1(C) ; GET ADDR OR GO TO PURE DISP
+ JRST NORMAL
+ JRST (C)
+
+PRDIS1: SUB C,PRNTYP+1
+ PUSH P,C
+ PUSH TP,[TATOM,,-1] ; PUSH ON OUTCHAN FOR SPECBIND
+ PUSH TP,IMQUOTE OUTCHAN
+ PUSH TP,-5(TP)
+ PUSH TP,-5(TP)
+ PUSH TP,[0]
+ PUSH TP,[0]
+ PUSHJ P,SPECBIND
+ POP P,C ; RESTORE C
+ ADD C,PRNTYP+1 ; RESTORE C
+ PUSH TP,(C) ; PUSH ARGS FOR APPLY
+ PUSH TP,1(C)
+ PUSH TP,-9(TP)
+ PUSH TP,-9(TP)
+ MCALL 2,APPLY ; APPLY HACKER TO OBJECT
+ MOVEI E,-8(TP)
+ PUSHJ P,SSPEC1 ;UNBIND OUTCHAN
+ SUB TP,[6,,6] ; POP OFF STACK
+ JRST PNEXT
+
+; PRINT DISPATCH TABLE
+
+IF2,PUNKS==400000,,PUNK
+
+DISTBL PRTYPE,PUNKS,[[TATOM,PATOM],[TFORM,PFORM],[TSEG,PSEG],[TFIX,PFIX]
+[TFLOAT,PFLOAT],[TLIST,PLIST],[TVEC,PVEC],[TCHRS,PCHRS],[TCHSTR,PCHSTR]
+[TARGS,PARGS],[TUVEC,PUVEC],[TDEFER,PDEFER],[TINTH,PINTH],[THAND,PHAND]
+[TILLEG,ILLCH],[TRSUBR,PRSUBR],[TENTER,PENTRY],[TPCODE,PPCODE],[TTYPEW,PTYPEW]
+[TTYPEC,PTYPEC],[TTMPLT,TMPRNT],[TLOCD,LOCPT1],[TLOCR,LOCRPT],[TQRSUB,PRSUBR]
+[TQENT,PENTRY],[TSATC,PSATC],[TBYTE,PBYTE]
+[TOFFS,POFFSE]]
+
+PUNK: MOVE C,TYPVEC+1 ; GET AOBJN-POINTER TO VECTOR OF TYPE ATOMS
+ GETYP B,-1(TP) ; GET THE TYPE CODE INTO REG B
+ LSH B,1 ; MULTIPLY BY TWO
+ HRL B,B ; DUPLICATE IT IN THE LEFT HALF
+ ADD C,B ; INCREMENT THE AOBJN-POINTER
+ JUMPGE C,PRERR ; IF POSITIVE, INDEX > VECTOR SIZE
+
+ MOVE B,-2(TP) ; MOVE IN CHANNEL
+ PUSH TP,$TVEC ; SAVE ALLTYPES VECTOR
+ PUSH TP,C
+ PUSHJ P,RETIF1 ; START NEW LINE IF NO ROOM
+ MOVEI A,"# ; INDICATE TYPE-NAME FOLLOWS
+ PUSHJ P,PITYO
+ POP TP,C
+ SUB TP,[1,,1]
+ MOVE A,(C) ; GET TYPE-ATOM
+ MOVE B,1(C)
+ PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
+ PUSH TP,-3(TP)
+ PUSHJ P,IPRINT ; PRINT ATOM-NAME
+ SUB TP,[2,,2] ; POP STACK
+ MOVE B,-2(TP) ; MOVE IN CHANNEL
+ PUSHJ P,SPACEQ ; MAYBE SPACE
+ MOVE B,(B) ; RESET THE REAL ARGUMENT POINTER
+ HRRZ A,(C) ; GET THE STORAGE-TYPE
+ ANDI A,SATMSK
+ CAILE A,NUMSAT ; SKIP IF TEMPLATE
+ JRST TMPRNT ; PRINT TEMPLATED DATA STRUCTURE
+ HRRO A,UKTBL(A) ; USE DISPATCH TABLE ON STORAGE TYPE
+ JRST (A)
+
+DISTBS UKTBL,POCTAL,[[S2WORD,PLIST],[S2NWORD,PVEC],[SNWORD,PUVEC],[SATOM,PATOM]
+[SCHSTR,PCHSTR],[SFRAME,PFRAME],[SARGS,PARGS],[SPVP,PPVP],[SLOCID,LOCPT],[SLOCA,LOCP]
+[SLOCV,LOCP],[SLOCU,LOCP],[SLOCS,LOCP],[SLOCL,LOCP],[SLOCN,LOCP],[SASOC,ASSPNT]
+[SLOCT,LOCP],[SLOCB,LOCP],[SBYTE,PBYTE],[SOFFS,POFFSE]]
+ ; SELECK AN ILLEGAL
+
+ILLCH: MOVEI B,-1(TP)
+ JRST ILLCHO
+
+\f; PRINT INTERRUPT HANDLER
+
+PHAND: MOVE B,-2(TP) ; MOVE CHANNEL INTO B
+ PUSHJ P,RETIF1
+ MOVEI A,"#
+ PUSHJ P,PITYO ; SAY "FUNNY TYPE"
+ MOVSI A,TATOM
+ MOVE B,MQUOTE HANDLER
+ PUSH TP,-3(TP) ; PUSH CHANNEL ON FOR IPRINT
+ PUSH TP,-3(TP)
+ PUSHJ P,IPRINT ; PRINT THE TYPE NAME
+ SUB TP,[2,,2] ; POP CHANNEL OFF STACK
+ MOVE B,-2(TP) ; GET CHANNEL
+ PUSHJ P,SPACEQ ; SPACE MAYBE
+ SKIPN B,(TP) ; GET ARG BACK
+ JRST PNEXT
+ MOVE A,INTFCN(B) ; PRINT FUNCTION FOR NOW
+ MOVE B,INTFCN+1(B)
+ PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
+ PUSH TP,-3(TP)
+ PUSHJ P,IPRINT ; PRINT THE INT FUNCTION
+ SUB TP,[2,,2] ; POP CHANNEL OFF
+ JRST PNEXT
+
+; PRINT INT HEADER
+
+PINTH: MOVE B,-2(TP) ; GET CHANNEL INTO B
+ PUSHJ P,RETIF1
+ MOVEI A,"#
+ PUSHJ P,PITYO
+ MOVSI A,TATOM ; AND NAME
+ MOVE B,MQUOTE IHEADER
+ PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
+ PUSH TP,-3(TP)
+ PUSHJ P,IPRINT
+ MOVE B,-4(TP) ; GET CHANNEL INTO B
+ PUSHJ P,SPACEQ ; MAYBE SPACE
+ SKIPN B,-2(TP) ; INT HEADER BACK
+ JRST PINTH1
+ MOVE A,INAME(B) ; GET NAME
+ MOVE B,INAME+1(B)
+ PUSHJ P,IPRINT
+PINTH1: SUB TP,[2,,2] ; CLEAN OFF STACK
+ JRST PNEXT
+
+
+; PRINT ASSOCIATION BLOCK
+
+ASSPNT: MOVEI A,"( ; MAKE IT BE (ITEN INDIC VAL)
+ MOVE B,-2(TP) ; GET CHANNEL INTO B
+ PUSHJ P,PRETIF ; MAKE ROOM AND PRINT
+ SKIPA C,[-3,,0] ; # OF FIELDS
+ASSLP: PUSHJ P,SPACEQ
+ MOVE D,(TP) ; RESTORE GOODIE
+ ADD D,ASSOFF(C) ; POINT TO FIELD
+ MOVE A,(D) ; GET IT
+ MOVE B,1(D)
+ PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
+ PUSH TP,-3(TP)
+ PUSHJ P,IPRINT ; AND PRINT IT
+ SUB TP,[2,,2] ; POP OFF CHANNEL
+ MOVE B,-2(TP) ; GET CHANNEL
+ AOBJN C,ASSLP
+
+ MOVEI A,")
+ MOVE B,-2(TP) ; GET CHANNEL INTO B
+ PUSHJ P,PRETIF ; CLOSE IT
+ JRST PNEXT
+
+ASSOFF: ITEM
+ INDIC
+ VAL
+\f; PRINT TYPE-C AND TYPE-W
+
+PTYPEW: HRRZ A,(TP) ; POSSIBLE RH
+ HLRZ B,(TP)
+ MOVE C,MQUOTE TYPE-W
+ JRST PTYPEX
+
+PTYPEC: HRRZ B,(TP)
+ MOVEI A,0
+ MOVE C,MQUOTE TYPE-C
+
+PTYPEX: PUSH P,B
+ PUSH P,A
+ PUSH TP,$TATOM
+ PUSH TP,C
+ MOVEI A,2
+ MOVE B,-4(TP) ; GET CHANNEL INTO B
+ PUSHJ P,RETIF ; ROOM TO START?
+ MOVEI A,"%
+ PUSHJ P,PITYO
+ MOVEI A,"<
+ PUSHJ P,PITYO
+ POP TP,B ; GET NAME
+ POP TP,A
+ PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
+ PUSH TP,-3(TP)
+ PUSHJ P,IPRINT ; AND PRINT IT AS 1ST ELEMENT
+ SUB TP,[2,,2] ; POP OFF CHANNEL
+ MOVE B,-2(TP) ; GET CHANNEL INTO B
+ PUSHJ P,SPACEQ ; MAYBE SPACE
+ MOVE A,-1(P) ; TYPE CODE
+ ASH A,1
+ HRLI A,(A) ; MAKE SURE WINS
+ ADD A,TYPVEC+1
+ JUMPL A,PTYPX1 ; JUMP FOR A WINNER
+ ERRUUO EQUOTE BAD-TYPE-CODE
+
+PTYPX1: MOVE B,1(A) ; GET TYPE NAME
+ HRRZ A,(A) ; AND SAT
+ ANDI A,SATMSK
+ MOVEM A,-1(P) ; AND SAVE IT
+ MOVSI A,TATOM
+ PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
+ PUSH TP,-3(TP)
+ PUSHJ P,IPRINT ; OUT IT GOES
+ SUB TP,[2,,2] ; POP OFF CHANNEL
+ MOVE B,-2(TP) ; GET CHANNEL INTO B
+ PUSHJ P,SPACEQ ; MAYBE SPACE
+ MOVE A,-1(P) ; GET SAT BACK
+ MOVE B,IMQUOTE TEMPLATE
+ CAIGE A,NUMSAT
+ MOVE B,@STBL(A)
+ MOVSI A,TATOM ; AND PRINT IT
+ PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
+ PUSH TP,-3(TP)
+ PUSHJ P,IPRINT
+ SUB TP,[2,,2] ; POP OFF STACK
+ SKIPN B,(P) ; ANY EXTRA CRAP?
+ JRST PTYPX2
+
+ MOVE B,-2(TP) ; GET CHANNEL INTO B
+ PUSHJ P,SPACEQ
+ MOVE B,(P)
+ MOVSI A,TFIX
+ PUSH TP,-3(TP) ; PUSH CHANNELS FOR IPRINT
+ PUSH TP,-3(TP)
+ PUSHJ P,IPRINT ; PRINT EXTRA
+ SUB TP,[2,,2] ; POP OFF CHANNEL
+
+PTYPX2: MOVEI A,">
+ MOVE B,-2(TP) ; GET CHANNEL INTO B
+ PUSHJ P,PRETIF
+ SUB P,[2,,2] ; FLUSH CRUFT
+ JRST PNEXT
+
+\f; PRIMTYPE CODE
+
+; PRINT PURE CODE POINTER
+
+PSATC: MOVEI A,2
+ MOVE B,-2(TP) ; GET CHANNEL INTO B
+ PUSHJ P,RETIF
+ MOVEI A,"%
+ PUSHJ P,PITYO
+ MOVEI A,"<
+ PUSHJ P,PITYO
+ MOVSI A,TATOM ; PRINT SUBR CALL
+ MOVE B,MQUOTE PRIMTYPE-C
+ PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
+ PUSH TP,-3(TP)
+ PUSHJ P,IPRINT
+ MOVE B,-4(TP) ; GET CHANNEL INTO B
+ PUSHJ P,SPACEQ ; MAYBE SPACE?
+ MOVE A,-2(TP)
+ CAILE A,NUMSAT
+ JRST TMPPTY
+
+ MOVE B,@STBL(A)
+ JRST PSATC1
+
+TMPPTY: MOVE B,TYPVEC+1
+PSATC3: HRRZ C,(B)
+ ANDI C,SATMSK
+ CAIN A,(C)
+ JRST PSATC2
+ ADD B,[2,,2]
+ JUMPL B,PSATC3
+
+ ERRUUO EQUOTE BAD-PRIMTYPEC
+
+PSATC2: MOVE B,1(B)
+PSATC1: MOVSI A,TATOM
+ PUSHJ P,IPRINT
+ SUB TP,[2,,2]
+ MOVEI A,">
+ MOVE B,-2(TP) ; GET CHANNEL INTO B
+ PUSHJ P,PRETIF ; CLOSE THE FORM
+ JRST PNEXT
+
+
+PPCODE: MOVEI A,2
+ MOVE B,-2(TP) ; GET CHANNEL INTO B
+ PUSHJ P,RETIF
+ MOVEI A,"%
+ PUSHJ P,PITYO
+ MOVEI A,"<
+ PUSHJ P,PITYO
+ MOVSI A,TATOM ; PRINT SUBR CALL
+ MOVE B,MQUOTE PCODE
+ PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
+ PUSH TP,-3(TP)
+ PUSHJ P,IPRINT
+ MOVE B,-4(TP) ; GET CHANNEL INTO B
+ PUSHJ P,SPACEQ ; MAYBE SPACE?
+ HLRZ A,-2(TP) ; OFFSET TO VECTOR
+ ADD A,PURVEC+1 ; SLOT TO A
+ MOVE A,(A) ; SIXBIT NAME
+ PUSH P,FLAGS
+ PUSHJ P,6TOCHS ; TO A STRING
+ POP P,FLAGS
+ PUSHJ P,IPRINT
+ MOVE B,-4(TP) ; GET CHANNEL INTO B
+ PUSHJ P,SPACEQ
+ HRRZ B,-2(TP) ; GET OFFSET
+ MOVSI A,TFIX\r
+ PUSHJ P,IPRINT
+ SUB TP,[2,,2] ; POP CHANNEL OFF STACK
+ MOVEI A,">
+ MOVE B,-2(TP) ; GET CHANNEL INTO B
+ PUSHJ P,PRETIF ; CLOSE THE FORM
+ JRST PNEXT
+
+
+\f; PRINT SUB-ENTRY TO RSUBR
+
+PENTRY: MOVE B,(TP) ; GET BLOCK
+ GETYP A,(B) ; TYPE OF 1ST ELEMENT
+ CAIE A,TRSUBR ; RSUBR, OK
+ JRST PENT1
+PENT2: MOVEI A,2 ; CHECK ROOM
+ MOVE B,-2(TP) ; GET CHANNEL INTO B
+ PUSHJ P,RETIF
+ MOVEI A,"% ; SETUP READ TIME MACRO
+ PUSHJ P,PITYO
+ MOVEI A,"<
+ PUSHJ P,PITYO
+ MOVSI A,TATOM
+ MOVE B,IMQUOTE RSUBR-ENTRY
+ PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
+ PUSH TP,-3(TP)
+ PUSHJ P,IPRINT
+ MOVE B,-4(TP)
+ PUSHJ P,SPACEQ ; MAYBE SPACE
+ MOVEI A,"' ; QUOTE TO AVOID EVALING IT
+ PUSHJ P,PRETIF
+ MOVEI A,"[ ; OPEN SQUARE BRAKET
+ PUSHJ P,PRETIF
+ MOVE B,-2(TP)
+ GETYP A,(B)
+ CAIN A,TRSUBR
+ JRST PENT3
+ MOVE A,(B)
+ MOVE B,1(B)
+ PUSHJ P,IPRINT
+ MOVE B,-4(TP) ; MOVE IN CHANNEL
+ JRST PENT4
+PENT3: MOVE A,1(B)
+ MOVE B,3(A)
+ MOVSI A,TATOM ; FOOL EVERYBODY AND SEND OUT ATOM
+ PUSHJ P,IPRINT
+ MOVE B,-4(TP) ; PRINT SPACE
+PENT4: PUSHJ P,SPACEQ
+ MOVE B,-2(TP) ; GET PTR BACK TO VECTOR
+ MOVE A,2(B) ; THE NAME OF THE ENTRY
+ MOVE B,3(B)
+ PUSHJ P,IPRINT ; OUT IT GOES
+ HLRZ B,-2(TP)
+ CAIL B,-4 ; SEE IF DONE
+ JRST EXPEN
+ MOVE B,-4(TP) ; PRINT SPACE
+ PUSHJ P,SPACEQ
+ MOVE B,-2(TP) ; GET POINTER
+ MOVE A,4(B) ; DECL
+ MOVE B,5(B)
+ PUSHJ P,IPRINT
+EXPEN: MOVE B,-4(TP) ; GET CHANNEL INTO B
+ MOVEI A,"] ; CLOSE SQUARE BRAKET
+ PUSHJ P,PRETIF
+ MOVE B,-4(TP) ; GET CHANNEL INTO B
+ PUSHJ P,SPACEQ
+ MOVE B,-2(TP)
+ HRRZ B,2(B)
+ MOVSI A,TFIX
+ PUSHJ P,IPRINT
+ MOVEI A,">
+ SUB TP,[2,,2] ; POP CHANNEL OFF STACK
+ MOVE B,-2(TP) ; GET CHANNEL INTO B
+ PUSHJ P,PRETIF
+ JRST PNEXT
+
+PENT1: CAIN A,TATOM
+ JRST PENT2
+ ERRUUO EQUOTE BAD-ENTRY-BLOCK
+
+\f; HERE TO PRINT TEMPLATED DATA STRUCTURE
+
+TMPRNT: PUSH P,FLAGS ; SAVE FLAGS
+ MOVE A,(TP) ; GET POINTER
+ GETYP A,(A) ; GET SAT
+ PUSH P,A ; AND SAVE IT
+ MOVEI A,"{ ; OPEN SQUIGGLE
+ MOVE B,-2(TP) ; GET CHANNEL INTO B
+ PUSHJ P,PRETIF ; PRINT WITH CHECKING
+ HLRZ A,(TP) ; GET AMOUNT RESTED OFF
+ SUBI A,1
+ PUSH P,A ; AND SAVE IT
+ MOVE A,-1(P) ; GET SAT
+ SUBI A,NUMSAT+1 ; FIXIT UP
+ HRLI A,(A)
+ ADD A,TD.LNT+1 ; CHECK FOR WINNAGE
+ JUMPGE A,BADTPL ; COMPLAIN
+ HRRZS C,(TP) ; GET LENGTH
+ XCT (A) ; INTO B
+ SUB B,(P) ; FUDGE FOR RESTS
+ MOVEI B,-1(B) ; FUDGE IT
+ PUSH P,B ; AND SAVE IT
+
+TMPRN1: AOS C,-1(P) ; GET ELEMENT OF INTEREST
+ SOSGE (P) ; CHECK FOR ANY LEFT
+ JRST TMPRN2 ; ALL DONE
+
+ MOVE B,(TP) ; POINTER
+ HRRZ 0,-2(P) ; SAT
+ PUSHJ P,TMPLNT ; GET THE ITEM
+ MOVE FLAGS,-3(P) ; RESTORE FLAGS
+ PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
+ PUSH TP,-3(TP)
+ PUSHJ P,IPRINT ; PRINT THIS ELEMENT
+ SUB TP,[2,,2] ; POP CHANNEL OFF STACK
+ MOVE B,-2(TP) ; GET CHANNEL INTO B
+ SKIPE (P) ; IF NOT LAST ONE THEN
+ PUSHJ P,SPACEQ ; SEPARATE WITH A SPACE
+ JRST TMPRN1
+
+TMPRN2: SUB P,[4,,4]
+ MOVE B,-2(TP)
+ MOVEI A,"} ; CLOSE THIS GUY
+ PUSHJ P,PRETIF
+ JRST PNEXT
+
+
+\f; RSUBR PRINTING ROUTINES. ON PRINTB CHANNELS, WRITES OUT
+; COMPACT BINARY. ON PRINT CHANNELS ALL IS ASCII
+
+PRSUBR: MOVE A,(TP) ; GET RSUBR IN QUESTION
+ GETYP A,(A) ; CHECK FOR PURE RSUBR
+ CAIN A,TPCODE
+ JRST PRSBRP ; PRINT IT SPECIAL WAY
+
+ TLNN FLAGS,BINBIT ; SKIP IF BINARY OUTPUT
+ JRST ARSUBR
+
+ PUSH P,FLAGS
+ MOVSI A,TRSUBR ; FIND FIXUPS
+ MOVE B,(TP)
+ HLRE D,1(B) ; -LENGTH OF CODE VEC
+ PUSH P,D ; SAVE SAME
+ MOVSI C,TATOM
+ MOVE D,IMQUOTE RSUBR
+ PUSHJ P,IGET ; GO GET THEM
+ JUMPE B,RCANT ; NO FIXUPS, BINARY LOSES
+ PUSH TP,A ; SAVE FIXUP LIST
+ PUSH TP,B
+
+ MOVNI A,1 ; USE ^C AS MARKER FOR RSUBR
+ MOVE FLAGS,-1(P) ; RESTORE FLAGS
+ MOVE B,-4(TP) ; GET CHANNEL FOR PITYO
+ PUSHJ P,PITYO ; OUT IT GOES
+
+PRSBR1: MOVE B,-4(TP)
+ PUSHJ P,BFCLS1 ; FLUSH OUT CURRENT BUFFER
+
+ MOVE B,-4(TP) ; CHANNEL BACK
+ MOVN E,(P) ; LENGTH OF CODE
+ PUSH P,E
+ HRROI A,(P) ; POINT TO SAME
+ PUSHJ P,DOIOTO ; OUT GOES COUNT
+ MOVSI C,TCODE
+ MOVE PVP,PVSTOR+1
+ MOVEM C,ASTO(PVP) ; FOR IOT INTERRUPTS
+ MOVE A,-2(TP) ; GET POINTER TO CODE
+ MOVE A,1(A)
+ PUSHJ P,DOIOTO ; IOT IT OUT
+ POP P,E
+ ADDI E,1 ; UPDATE ACCESS
+ ADDM E,ACCESS(B)
+ MOVE PVP,PVSTOR+1
+ SETZM ASTO(PVP) ; UNSCREW A
+
+; NOW PRINT OUT NORMAL RSUBR VECTOR
+
+ MOVE FLAGS,-1(P) ; RESTORE FLAGS
+ SUB P,[1,,1]
+ MOVE B,-2(TP) ; GET RSUBR VECTOR
+ PUSHJ P,PRBODY ; PRINT ITS BODY
+
+; HERE TO PRINT BINARY FIXUPS
+
+ MOVEI E,0 ; 1ST COMPUTE LENGTH OF FIXUPS
+ SKIPN A,(TP) ; LIST TO A
+ JRST PRSBR5 ; EMPTY, DONE
+ JUMPL A,UFIXES ; JUMP IF FIXUPS IN UVECTOR FORM
+ ADDI E,1 ; FOR VERS
+
+PRSBR6: HRRZ A,(A) ; NEXT?
+ JUMPE A,PRSBR5
+ GETYP B,(A)
+ CAIE B,TDEFER ; POSSIBLE STRING
+ JRST PRSBR7 ; COULD BE ATOM
+ MOVE B,1(A) ; POSSIBLE STRINGER
+ GETYP C,(B)
+ CAIE C,TCHSTR ; YES!!!
+ JRST BADFXU ; LOSING FIXUPS
+ HRRZ C,(B) ; # OF CHARS TO C
+ ADDI C,5+5 ; ROUND AND ADD FOR COUNT
+ IDIVI C,5 ; TO WORDS
+ ADDI E,(C)
+ JRST FIXLST ; COUNT FOR USE LIST ETC.
+
+PRSBR7: GETYP B,(A) ; GET TYPE
+ CAIE B,TATOM
+ JRST BADFXU
+ ADDI E,1
+
+FIXLST: HRRZ A,(A) ; REST IT TO OLD VAL
+ JUMPE A,BADFXU
+ GETYP B,(A) ; FIX?
+ CAIE B,TFIX
+ JRST BADFXU
+ MOVEI D,1
+ HRRZ A,(A) ; TO USE LIST
+ JUMPE A,BADFXU
+ GETYP B,(A)
+ CAIE B,TLIST
+ JRST BADFXU ; LOSER
+ MOVE C,1(A) ; GET LIST
+
+PRSBR8: JUMPE C,PRSBR9
+ GETYP B,(C) ; TYPE OK?
+ CAIE B,TFIX
+ JRST BADFXU
+ HRRZ C,(C)
+ AOJA D,PRSBR8 ; LOOP
+
+PRSBR9: ADDI D,2 ; ROUND UP
+ ASH D,-1 ; DIV BY 2 FOR TWO GOODIES PER HWORD
+ ADDI E,(D)
+ JRST PRSBR6
+
+PRSBR5: PUSH P,E ; SAVE LENGTH OF FIXUPS
+ PUSH TP,$TUVEC ; SLOT FOR BUFFER POINTER
+ PUSH TP,[0]
+
+PFIXU1: MOVE B,-6(TP) ; START LOOPING THROUGH CHANNELS
+ PUSHJ P,BFCLS1 ; FLUSH BUFFER
+ MOVE B,-6(TP) ; CHANNEL BACK
+ MOVEI C,BUFSTR-1(B) ; SETUP BUFFER
+ PUSHJ P,BYTDOP ; FIND D.W.
+ SUBI A,BUFLNT+1
+ HRLI A,-BUFLNT
+ MOVEM A,(TP)
+ MOVE E,(P) ; LENGTH OF FIXUPS
+ SETZB C,D ; FOR EOUT
+ PUSHJ P,EOUT
+ MOVE C,-2(TP) ; FIXUP LIST
+ MOVE E,1(C) ; HAVE VERS
+ PUSHJ P,EOUT ; OUT IT GOES
+
+PFIXU2: HRRZ C,(C) ; FIRST THING
+ JUMPE C,PFIXU3 ; DONE?
+ GETYP A,(C) ; STRING OR ATOM
+ CAIN A,TATOM ; MUST BE STRING
+ JRST PFIXU4
+ MOVE A,1(C) ; POINT TO POINTER
+ HRRZ D,(A) ; LENGTH
+ IDIVI D,5
+ PUSH P,E ; SAVE REMAINDER
+ MOVEI E,1(D)
+ MOVNI D,(D)
+ MOVSI D,(D)
+ PUSH P,D
+ PUSHJ P,EOUT
+ MOVEI D,0
+PFXU1A: MOVE A,1(C) ; RESTORE POINTER
+ HRRZ A,1(A) ; BYTE POINTER
+ ADD A,(P)
+ MOVE E,(A)
+ PUSHJ P,EOUT
+ MOVE A,[1,,1]
+ ADDB A,(P)
+ JUMPL A,PFXU1A
+ MOVE D,-1(P) ; LAST WORD
+ MOVE A,1(C)
+ HRRZ A,1(A)
+ ADD A,(P)
+ SKIPE E,D
+ MOVE E,(A) ; LAST WORD OF CHARS
+ IOR E,PADS(D)
+ PUSHJ P,EOUT ; OUT
+ SUB P,[1,,1]
+ JRST PFIXU5
+
+PADS: ASCII /#####/
+ ASCII /####/
+ ASCII /\ 2###/
+ ASCII /\ 2##/
+ ASCII /\ 2\ 2#/
+
+PFIXU4: HRRZ E,(C) ; GET CURRENT VAL
+ MOVE E,1(E)
+ MOVEM C,-2(TP)
+ PUSHJ P,ATOSQ ; GET SQUOZE
+ JRST BADFXU
+ TLO E,400000 ; USE TO DIFFERENTIATE BETWEEN STRING
+ PUSHJ P,EOUT
+ MOVE C,-2(TP)
+
+; HERE TO WRITE OUT LISTS
+
+PFIXU5: HRRZ C,(C) ; POINT TO CURRENT VALUE
+ HRLZ E,1(C)
+ HRRZ C,(C) ; POINT TO USES LIST
+ HRRZ D,1(C) ; GET IT
+ MOVEM C,-2(TP)
+
+PFIXU6: TLCE D,400000 ; SKIP FOR RH
+ HRLZ E,1(D) ; SETUP LH
+ JUMPG D,.+3
+ HRR E,1(D)
+ PUSHJ P,EOUT ; WRITE IT OUT
+ HRR D,(D)
+ TRNE D,-1 ; SKIP IF DONE
+ JRST PFIXU6
+
+ TRNE E,-1 ; SKIP IF ZERO BYTE EXISTS
+ MOVEI E,0
+ PUSHJ P,EOUT
+ MOVE C,-2(TP)
+ JRST PFIXU2 ; DO NEXT
+
+PFIXU3: HLRE C,(TP) ; -AMNT LEFT IN BUFFER
+ MOVN D,C ; PLUS SAME
+ ADDI C,BUFLNT ; WORDS USED TO C
+ JUMPE C,PFIXU7 ; NONE USED, LEAVE
+ MOVSS C ; START SETTING UP BTB
+ MOVN A,C ; ALSO FINAL IOT POINTER
+ HRR C,(TP) ; PDL POINTER PART OF BTB
+ SUBI C,1
+ HRLI D,400000+C ; CONTINUE SETTING UP BTB (400000 IS FOR MULTI
+ ; SEGS
+ POP C,@D ; MOVE 'EM DOWN
+ TLNE C,-1
+ JRST .-2
+ HRRI A,@D ; OUTPUT POINTER
+ ADDI A,1
+ MOVSI B,TUVEC
+ MOVE PVP,PVSTOR+1
+ MOVEM B,ASTO(PVP)
+ MOVE B,-6(TP)
+ PUSHJ P,DOIOTO ; WRITE IT OUT
+ MOVE PVP,PVSTOR+1
+ SETZM ASTO(PVP)
+
+PFIXU7: SUB TP,[4,,4]
+ SUB P,[2,,2]
+ JRST PNEXT
+
+; ROUTINE TO OUTPUT CONTENTS OF E
+
+EOUT: MOVE B,-6(TP) ; CHANNEL
+ AOS ACCESS(B)
+ MOVE A,(TP) ; BUFFER POINTER
+ MOVEM E,(A)
+ AOBJP A,.+3 ; COUNT AND GO
+ MOVEM A,(TP)
+ POPJ P,
+
+ SUBI A,BUFLNT ; SET UP IOT POINTER
+ HRLI A,-BUFLNT
+ MOVEM A,(TP) ; RESET SAVED POINTER
+ MOVSI 0,TUVEC
+ MOVE PVP,PVSTOR+1
+ MOVEM 0,ASTO(PVP)
+ MOVSI 0,TLIST
+ MOVEM 0,DSTO(PVP)
+ MOVEM 0,CSTO(PVP)
+ PUSHJ P,DOIOTO ; OUT IT GOES
+ MOVE PVP,PVSTOR+1
+ SETZM ASTO(PVP)
+ SETZM CSTO(PVP)
+ SETZM DSTO(PVP)
+ POPJ P,
+
+; HERE IF UVECOR FORM OF FIXUPS
+
+UFIXES: PUSH TP,$TUVEC
+ PUSH TP,A ; SAVE IT
+
+UFIX1: MOVE B,-6(TP) ; GET SAME
+ PUSHJ P,BFCLS1 ; FLUSH OUT BUFFER
+ HLRE C,(TP) ; GET LENGTH
+ MOVMS C
+ PUSH P,C
+ HRROI A,(P) ; READY TO ZAP IT OUT
+ PUSHJ P,DOIOTO ; ZAP!
+ SUB P,[1,,1]
+ HLRE C,(TP) ; LENGTH BACK
+ MOVMS C
+ ADDI C,1
+ ADDM C,ACCESS(B) ; UPDATE ACCESS
+ MOVE A,(TP) ; NOW THE UVECTOR
+ MOVSI C,TUVEC
+ MOVE PVP,PVSTOR+1
+ MOVEM C,ASTO(PVP)
+ PUSHJ P,DOIOTO ; GO
+ MOVE PVP,PVSTOR+1
+ SETZM ASTO(PVP)
+ SUB P,[1,,1]
+ SUB TP,[4,,4]
+ JRST PNEXT
+
+RCANT: ERRUUO EQUOTE RSUBR-LACKS-FIXUPS
+
+
+BADFXU: ERRUUO EQUOTE BAD-FIXUPS
+
+PRBODY: TDZA C,C ; FLAG SAYING FLUSH CODE
+PRBOD1: MOVEI C,1 ; PRINT CODE ALSO
+ PUSH P,FLAGS
+ PUSH TP,$TRSUBR
+ PUSH TP,B
+ PUSH P,C
+ MOVEI A,"[ ; START VECTOR TEXT
+ MOVE B,-6(TP) ; GET CHANNEL FOR PITYO
+ PUSHJ P,PITYO
+ POP P,C
+ MOVE B,(TP) ; RSUBR BACK
+ JUMPN C,PRSON ; GO START PRINTING
+ MOVEI A,"0 ; PLACE SAVER FOR CODE VEC
+ MOVE B,-6(TP) ; GET CHANNEL FOR PITYO
+ PUSHJ P,PITYO
+
+PRSBR2: MOVE B,[2,,2] ; BUMP VECTOR
+ ADDB B,(TP)
+ JUMPGE B,PRSBR3 ; NO SPACE IF LAST
+ MOVE B,-6(TP) ; GET CHANNEL FOR SPACEQ
+ PUSHJ P,SPACEQ
+ SKIPA B,(TP) ; GET BACK POINTER
+PRSON: JUMPGE B,PRSBR3
+ GETYP 0,(B) ; SEE IF RSUBR POINTED TO
+ CAIE 0,TQENT
+ CAIN 0,TENTER
+ JRST .+5 ; JUMP IF RSUBR ENTRY
+ CAIN 0,TQRSUB
+ JRST .+3
+ CAIE 0,TRSUBR ; YES!
+ JRST PRSB10 ; COULD BE SUBR/FSUBR
+ MOVE C,1(B) ; GET RSUBR
+ PUSH P,0 ; SAVE TYPE FOUND
+ GETYP 0,2(C) ; SEE IF ATOM
+ CAIE 0,TATOM
+ JRST PRSBR4
+ MOVE B,3(C) ; GET ATOM NAME
+ PUSHJ P,IGVAL ; GO LOOK
+ MOVE C,(TP) ; ORIG RSUBR BACK
+ GETYP A,A
+ POP P,0 ; DESIRED TYPE
+ CAIE 0,(A) ; SAME TYPE
+ JRST PRSBR4
+ MOVE D,1(C)
+ MOVE 0,3(D) ; NAME OF RSUBR IN QUESTION
+ CAME 0,3(B) ; WIN?
+ JRST PRSBR4
+ HRRZ E,C
+ MOVSI A,TATOM
+ MOVE B,0 ; GET ATOM
+ MOVE FLAGS,(P)
+ JRST PRS101
+
+PRSBR4: MOVE FLAGS,(P) ; RESTORE FLAGS
+ MOVE B,(TP)
+ MOVE A,(B)
+ MOVE B,1(B) ; PRINT IT
+PRS101: PUSH TP,-7(TP) ; PUSH CHANNEL FOR IPRINT
+ PUSH TP,-7(TP)
+ PUSHJ P,IPRINT
+ SUB TP,[2,,2] ; POP OFF CHANNEL
+ MOVE B,-2(TP) ; MOVE IN CHANNEL
+ JRST PRSBR2
+
+PRSB10: CAIE 0,TSUBR ; SUBR?
+ CAIN 0,TFSUBR
+ JRST .+2
+ JRST PRSBR4
+ MOVE C,1(B) ; GET LOCN OF SUBR OR FSUBR
+ MOVE B,@-1(C) ; NAME OF IT
+ MOVSI A,TATOM ; AND TYPE
+ JRST PRS101
+
+PRSBR3: MOVEI A,"]
+ MOVE B,-6(TP)
+ PUSHJ P,PRETIF ; CLOSE IT UP
+ SUB TP,[2,,2] ; FLUSH CRAP
+ POP P,FLAGS
+ POPJ P,
+
+
+\f; HERE TO PRINT PURE RSUBRS
+
+PRSBRP: MOVEI A,2 ; WILL "%<" FIT?
+ MOVE B,-2(TP) ; GET CHANNEL FOR RETIF
+ PUSHJ P,RETIF
+ MOVEI A,"%
+ PUSHJ P,PITYO
+ MOVEI A,"<
+ PUSHJ P,PITYO
+ MOVSI A,TATOM
+ MOVE B,IMQUOTE RSUBR
+ PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
+ PUSH TP,-3(TP)
+ PUSHJ P,IPRINT ; PRINT IT OUT
+ SUB TP,[2,,2] ; POP OFF CHANNEL
+ MOVE B,-2(TP)
+ PUSHJ P,SPACEQ ; MAYBE SPACE
+ MOVEI A,"' ; QUOTE THE VECCTOR
+ PUSHJ P,PRETIF
+ MOVE B,(TP) ; GET RSUBR BODY BACK
+ PUSH TP,$TFIX ; STUFF THE STACK
+ PUSH TP,[0]
+ PUSHJ P,PRBOD1 ; PRINT AND UNLINK
+ SUB TP,[2,,2] ; GET JUNK OFF STACK
+ MOVE B,-2(TP) ; GET CHANNEL FOR RETIF
+ MOVEI A,">
+ PUSHJ P,PRETIF
+ JRST PNEXT
+
+; HERE TO PRINT ASCII RSUBRS
+
+ARSUBR: PUSH P,FLAGS ; SAVE FROM GET
+ MOVSI A,TRSUBR
+ MOVE B,(TP)
+ MOVSI C,TATOM
+ MOVE D,IMQUOTE RSUBR
+ PUSHJ P,IGET ; TRY TO GET FIXUPS
+ POP P,FLAGS
+ JUMPE B,PUNK ; NO FIXUPS LOSE
+ GETYP A,A
+ CAIE A,TLIST ; ARE FIXUPS A LIST?
+ JRST PUNK ; NO, AGAIN LOSE
+ PUSH TP,$TLIST
+ PUSH TP,B ; SAVE FIXUPS
+ MOVEI A,17.
+ MOVE B,-4(TP)
+ PUSHJ P,RETIF
+ PUSH P,[440700,,[ASCIZ /%<FIXUP!-RSUBRS!-/]]
+
+AL1: ILDB A,(P) ; GET CHAR
+ JUMPE A,.+3
+ PUSHJ P,PITYO
+ JRST AL1
+
+ SUB P,[1,,1]
+ PUSHJ P,SPACEQ
+
+ MOVEI A,"'
+ PUSHJ P,PRETIF ; QUOTE TO AVOID ADDITIONAL EVAL
+ MOVE B,-2(TP) ; PRINT ACTUAL KLUDGE
+ PUSHJ P,PRBOD1
+ MOVE B,-4(TP) ; GET CHANNEL FOR SPACEQ
+ PUSHJ P,SPACEQ
+ MOVEI A,"' ; DONT EVAL FIXUPS EITHER
+ PUSHJ P,PRETIF
+ POP TP,B
+ POP TP,A
+ PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
+ PUSH TP,-3(TP)
+ PUSHJ P,IPRINT
+ SUB TP,[2,,2] ; POP CHANNEL OFF STACK
+ MOVE B,-2(TP) ; GET CHANNEL INTO B
+ MOVEI A,">
+ PUSHJ P,PRETIF
+ JRST PNEXT
+\f
+; HERE TO DO OFFSETS: %<OFFSET N '<VECTOR FIX FLOAT>>
+
+POFFSE: MOVEI A,2
+ MOVE B,-2(TP)
+ PUSHJ P,RETIF
+ MOVEI A,"%
+ PUSHJ P,PITYO
+ MOVEI A,"<
+ PUSHJ P,PITYO
+ MOVSI A,TATOM
+ MOVE B,MQUOTE OFFSET
+ PUSH TP,-3(TP)
+ PUSH TP,-3(TP)
+ PUSHJ P,IPRINT
+ SUB TP,[2,,2]
+ MOVE B,-2(TP) ; RESTORE CHANNEL
+ PUSHJ P,SPACEQ
+ MOVSI A,TFIX
+ HRRE B,(TP) ; PICK UPTHE FIX
+ PUSH TP,-3(TP)
+ PUSH TP,-3(TP)
+ PUSHJ P,IPRINT
+ SUB TP,[2,,2]
+ MOVE B,-2(TP) ; RESTORE CHANNEL
+ PUSHJ P,SPACEQ
+ HLRZ A,(TP)
+ JUMPE A,POFFS2
+ GETYP B,(A)
+ CAIE B,TFORM ; FORMS HAVE TO BE QUOTED
+ JRST POFFS1
+ MOVEI A,"'
+ MOVE B,-2(TP)
+ PUSHJ P,PRETIF
+POFFS1: HLRZ B,(TP)
+ MOVE A,(B)
+ MOVE B,1(B)
+POFFPT: PUSH TP,-3(TP)
+ PUSH TP,-3(TP)
+ PUSHJ P,IPRINT
+ SUB TP,[2,,2]
+ MOVE B,-2(TP) ; RESTORE CHANNEL
+ MOVEI A,">
+ PUSHJ P,PRETIF
+ JRST PNEXT
+; PRINT 'ANY' IF 0
+POFFS2: MOVSI A,TATOM
+ MOVE B,IMQUOTE ANY
+ JRST POFFPT
+
+\f; HERE TO DO LOCATIVES (PRINT CONTENTS THEREOF)
+
+LOCP: PUSH TP,-1(TP)
+ PUSH TP,-1(TP)
+ PUSH P,0
+ MCALL 1,IN ; GET ITS CONTENTS FROM "IN"
+ POP P,0
+ PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
+ PUSH TP,-3(TP)
+ PUSHJ P,IPRINT ; PRINT IT
+ SUB TP,[2,,2] ; POP CHANNEL OFF STACK
+ JRST PNEXT
+\f;INTERNAL SUBROUTINE TO HANDLE CHARACTER OUTPUT
+;B CONTAINS CHANNEL
+;PRINTER ITYO USED FOR FLATSIZE FAKE OUT
+PITYO: TLNN FLAGS,FLTBIT
+ JRST ITYO
+PITYO1: PUSH TP,[TTP,,0] ; PUSH ON TP POINTER
+ PUSH TP,B
+ TLNE FLAGS,UNPRSE ;SKIPS UNPRSE NOT SET
+ JRST ITYO+2
+ AOS FLTSIZ ;FLATSIZE DOESN'T PRINT
+ ;INSTEAD IT COUNTS THE CHARACTERS THAT WOULD BE OUTPUT
+ SOSGE FLTMAX ;UNLESS THE MAXIMUM IS EXCEEDED
+ JRST .+4
+ POP TP,B ; GET CHANNEL BACK
+ SUB TP,[1,,1]
+ POPJ P,
+ MOVEI E,(B) ; GET POINTER FOR UNBINDING
+ PUSHJ P,SSPEC1
+ MOVE P,UPB+8 ; RESTORE P
+ POP TP,B ; GET BACK TP POINTER
+ PUSH P,0 ; SAVE FLAGS
+ MOVE TP,B ; RESTORE TP
+ MOVEI C,(TB) ; SEE IF TB IS CORRECT
+ CAIG C,1(TP) ; SKIP IF NEEDS UNWINDING
+ JRST PITYO4
+PITYO3: MOVEI C,(TB)
+ CAILE C,1(TP)
+ JRST PITYO2
+ MOVEI A,PITYO4 ; SET UP PARAMETERS TO BE RESTORED BY FINIS
+ HRRM A,PCSAV(C)
+ MOVEM TP,TPSAV(C)
+ MOVE SP,SPSTOR+1
+ MOVEM SP,SPSAV(C)
+ MOVEM P,PSAV(C)
+ MOVE TB,D ; SET TB TO ONE FRAME AHEAD
+ JRST FINIS
+PITYO4: POP P,0 ; RESTORE FLAGS
+ MOVSI A,TFALSE ;IN WHICH CASE IT IMMEDIATELY GIVES UP AND RETURNS FALSE
+ MOVEI B,0
+ POPJ P,
+
+PITYO2: MOVE D,TB ; SAVE ONE FRAME AHEAD
+ HRR TB,OTBSAV(TB) ; RESTORE TB
+ JRST PITYO3
+
+
+\f;THE REAL THING
+;NOTE THAT THE FOLLOWING CODE HAS BUGS IF IT IS PRINTING OUT LONG
+;CHARACTER STRINGS
+; (NOTE THAT THE ABOVE COMMENT, IF TRUE, SHOULD NOT BE ADMITTED.)
+ITYO: PUSH TP,$TCHAN
+ PUSH TP,B
+ PUSH P,FLAGS ;SAVE STUFF
+ PUSH P,C
+ PUSH P,A ;SAVE OUTPUT CHARACTER
+
+
+ TLNE FLAGS,UNPRSE ;SKIPS UNPRSE NOT SET
+ JRST UNPROUT ;IF FROM UNPRSE, STASH IN STRING
+ CAIN A,^J
+ PUSHJ P,INTCHK
+ PUSH P,A
+ PUSHJ P,WXCT
+ POP P,A
+ CAIE A,^L ;SKIP IF THIS IS A FORM-FEED
+ JRST NOTFF
+ SETZM LINPOS(B) ;ZERO THE LINE NUMBER
+ JRST ITYXT
+
+NOTFF: CAIE A,15 ;SKIP IF IT IS A CR
+ JRST NOTCR
+ SETZM CHRPOS(B) ;ZERO THE CHARACTER POSITION
+ PUSHJ P,AOSACC ; BUMP COUNT
+ JRST ITYXT1
+
+NOTCR: CAIN A,^I ;SKIP IF NOT TAB
+ JRST TABCNT
+ CAIE A,10 ; BACK SPACE
+ JRST .+3
+ SOS CHRPOS(B) ; BACK UP ONE
+ JRST ITYXT
+ CAIE A,^J ;SKIP IF LINE FEED
+ JRST NOTLF
+ AOS C,LINPOS(B) ;ADD ONE TO THE LINE NUMBER
+ CAMLE C,PAGLN(B) ;SKIP IF THIS DOESN'T TAKES US PAST PAGE END
+ SETZM LINPOS(B)
+ MOVE FLAGS,-2(P)
+ JRST ITYXT
+
+INTCHK: HRRZ 0,-2(B) ; GET CHANNELS FLAGS
+ TRNN 0,C.INTL ; LOSER INTERESTED IN LFS?
+ POPJ P, ; LEAVE IF NOTHING TO DO
+ PUSH TP,$TCHAN
+ PUSH TP,B ; SAVE CHANNEL
+ PUSH P,C
+ PUSH P,E
+ PUSHJ P,GTLPOS ; READ SYSTEMS VERSION OF LINE #
+ PUSH TP,$TATOM
+ PUSH TP,MQUOTE CHAR,CHAR,INTRUP
+ PUSH TP,$TFIX
+ PUSH TP,A
+ PUSH TP,$TCHAN
+ PUSH TP,B
+ MCALL 3,INTERRUPT
+ POP P,E ; RESTORE POSSIBLE COUNTS
+ POP P,C
+ POP TP,B ; RESTORE CHANNEL
+ SUB TP,[1,,1]
+ MOVEI A,^J
+ POPJ P,
+
+NOTLF: CAIGE A,40
+ AOS CHRPOS(B) ; FOR CONTROL CHARS THAT NEED 2 SPACES
+ AOS CHRPOS(B) ;ADD TO CHARACTER NUMBER
+
+ITYXT: PUSHJ P,AOSACC ; BUMP ACCESS
+ITYXT1: POP P,A ;RESTORE THE ORIGINAL CHARACTER
+
+ITYRET: POP P,C ;RESTORE REGS & RETURN
+ POP P,FLAGS
+ POP TP,B ; GET CHANNEL BACK
+ SUB TP,[1,,1]
+ POPJ P,
+
+TABCNT: PUSH P,D
+ MOVE C,CHRPOS(B)
+ ADDI C,8. ;INCREMENT COUNT BY EIGHT (MOD EIGHT)
+ IDIVI C,8.
+ IMULI C,8.
+ MOVEM C,CHRPOS(B) ;REPLACE COUNT
+ POP P,D
+ JRST ITYXT
+
+UNPROUT: POP P,A ;GET BACK THE ORIG CHAR
+ IDPB A,UPB+2 ;DEPOSIT USING BYTE POINTER I PUSHED LONG AGO
+ SOS UPB+1
+ JRST ITYRET ;RETURN
+
+AOSACC: TLNN FLAGS,BINBIT
+ JRST NRMACC
+ AOS C,ACCESS-1(B) ; COUNT CHARS IN WORD
+ CAMN C,[TFIX,,1]
+ AOS ACCESS(B)
+ CAMN C,[TFIX,,5]
+ HLLZS ACCESS-1(B)
+ POPJ P,
+
+NRMACC: AOS ACCESS(B)
+ POPJ P,
+
+SPACEQ: MOVEI A,40
+ TLNE FLAGS,FLTBIT+BINBIT
+ JRST PITYO ; JUST OUTPUT THE SPACE
+ PUSH P,[1] ; PRINT SPACE IF NOT END OF LINE
+ MOVEI A,1
+ JRST RETIF2
+
+RETIF1: MOVEI A,1
+
+RETIF: PUSH P,[0]
+ TLNE FLAGS,FLTBIT+BINBIT
+ JRST SPOPJ ; IF WE ARE IN FLATSIZE THEN ESCAPE
+RETIF2: PUSH P,FLAGS
+RETCH: PUSH P,A
+
+RETCH1: ADD A,CHRPOS(B) ;ADD THE CHARACTER POSITION
+ SKIPN CHRPOS(B) ; IF JUST RESET, DONT DO IT AGAIN
+ JRST RETXT
+ CAMG A,LINLN(B) ;SKIP IF GREATER THAN LINE LENGTH
+ JRST RETXT1
+
+ MOVEI A,^M ;FORCE A CARRIAGE RETURN
+ SETZM CHRPOS(B)
+ PUSHJ P,WXCT
+ PUSHJ P,AOSACC ; BUMP CHAR COUNT
+ MOVEI A,^J ;AND FORCE A LINE FEED
+ PUSHJ P,INTCHK ; CHECK FOR ^J INTERRUPTS
+ PUSHJ P,WXCT
+ PUSHJ P,AOSACC ; BUMP CHAR COUNT
+ AOS A,LINPOS(B)
+ CAMG A,PAGLN(B) ;AT THE END OF THE PAGE ?
+ JRST RETXT
+; MOVEI A,^L ;IF SO FORCE A FORM FEED
+; PUSHJ P,WXCT
+; PUSHJ P,AOSACC ; BUMP CHAR COUNT
+ SETZM LINPOS(B)
+
+RETXT: POP P,A
+
+ POP P,FLAGS
+SPOPJ: SUB P,[1,,1]
+ POPJ P, ;RETURN
+
+PRETIF: PUSH P,A ;SAVE CHAR
+ PUSHJ P,RETIF1
+ POP P,A
+ JRST PITYO
+
+RETIF3: TLNE FLAGS,FLTBIT ; NOTHING ON FLATSIZE
+ POPJ P,
+ PUSH P,[0]
+ PUSH P,FLAGS
+ HRRI FLAGS,2 ; PRETEND ONLY 1 CHANNEL
+ PUSH P,A
+ JRST RETCH1
+
+RETXT1: SKIPN -2(P) ; SKIP IF SPACE HACK
+ JRST RETXT
+ MOVEI A,40
+ PUSHJ P,WXCT
+ AOS CHRPOS(B)
+ PUSH P,C
+ PUSHJ P,AOSACC
+ POP P,C
+ JRST RETXT
+
+\f;THIS IS CODE TO HANDLE UNKNOWN DATA TYPES.
+;IT PRINTS "*XXXXXX*XXXXXXXXXXXX*", WHERE THE FIRST NUMBER IS THE
+;TYPE CODE IN OCTAL, THE SECOND IS THE VALUE FIELD IN OCTAL.
+PRERR: MOVEI A,21. ;CHECK FOR 21. SPACES LEFT ON PRINT LINE
+ MOVE B,-2(TP) ; GET CHANNEL INTO B
+ PUSHJ P,RETIF ;INSERT CARRIAGE RETURN IF NOT ENOUGH
+ MOVEI A,"* ;JUNK TO INDICATE ERROR PRINTOUT IN OCTAL
+ PUSHJ P,PITYO ;TYPE IT
+
+ MOVE E,[000300,,-2(TP)] ;GET POINTER INDEXED OFF TP SO THAT
+ ;TYPE CODE MAY BE OBTAINED FOR PRINTING.
+ MOVEI D,6 ;# OF OCTAL DIGITS IN HALF WORD
+OCTLP1: ILDB A,E ;GET NEXT 3-BIT BYTE OF TYPE CODE
+ IORI A,60 ;OR-IN 60 FOR ASCII DIGIT
+ PUSHJ P,PITYO ;PRINT IT
+ SOJG D,OCTLP1 ;REPEAT FOR SIX CHARACTERS
+
+PRE01: MOVEI A,"* ;DELIMIT TYPE CODE FROM VALUE FIELD
+ PUSHJ P,PITYO
+
+ HRLZI E,(410300,,(TP)) ;BYTE POINTER TO SECOND WORD
+ ;INDEXED OFF TP
+ MOVEI D,12. ;# OF OCTAL DIGITS IN A WORD
+OCTLP2: LDB A,E ;GET 3 BITS
+ IORI A,60 ;CONVERT TO ASCII
+ PUSHJ P,PITYO ;PRINT IT
+ IBP E ;INCREMENT POINTER TO NEXT BYTE
+ SOJG D,OCTLP2 ;REPEAT FOR 12. CHARS
+
+ MOVEI A,"* ;DELIMIT END OF ERROR TYPEOUT
+ PUSHJ P,PITYO ;REPRINT IT
+
+ JRST PNEXT ;RESTORE REGS & POP UP ONE LEVEL TO CALLER
+
+POCTAL: MOVEI A,14. ;RETURN TO NEW LINE IF 14. SPACES NOT LEFT
+ MOVE B,-2(TP) ; GET CHANNEL INTO B
+ PUSHJ P,RETIF
+ JRST PRE01 ;PRINT VALUE AS "*XXXXXXXXXXXX*"
+
+\f;PRINT BINARY INTEGERS IN DECIMAL.
+;
+PFIX: MOVM E,(TP) ; GET # (MAFNITUDE)
+ JUMPL E,POCTAL ; IF ABS VAL IS NEG, MUST BE SETZ
+ PUSH P,FLAGS
+
+PFIX1: MOVE B,-2(TP) ; GET CHANNEL INTO B
+PFIX2: MOVE D,UPB+6 ; IF UNPARSE, THIS IS RADIX
+ TLNE FLAGS,UNPRSE+FLTBIT ;SKIPS IF NOT FROM UNPARSE OR FLATSIZE
+ JRST PFIXU
+ MOVE D,RADX(B) ; GET OUTPUT RADIX
+PFIXU: CAIG D,1 ; DONT ALLOW FUNNY RADIX
+ MOVEI D,10. ; IF IN DOUBT USE 10.
+ PUSH P,D
+ MOVEI A,1 ; START A COUNTER
+ SKIPGE B,(TP) ; CHECK SIGN
+ MOVEI A,2 ; NEG, NEED CHAR FOR SIGN
+
+ IDIV B,D ; START COUNTING
+ JUMPE B,.+2
+ AOJA A,.-2
+
+ MOVE B,-2(TP) ; CHANNEL TO B
+ TLNN FLAGS,FLTBIT+BINBIT
+ PUSHJ P,RETIF3 ; CHECK FOR C.R.
+ MOVE B,-2(TP) ; RESTORE CHANNEL
+ MOVEI A,"- ; GET SIGN
+ SKIPGE (TP) ; SKIP IF NOT NEEDED
+ PUSHJ P,PITYO
+ MOVM C,(TP) ; GET MAGNITUDE OF #
+ MOVE B,-2(TP) ; RESTORE CHANNEL
+ POP P,E ; RESTORE RADIX
+ PUSHJ P,FIXTYO ; WRITE OUT THE #
+ MOVE FLAGS,-1(P)
+ SUB P,[1,,1] ; FLUSH P STUFF
+ JRST PNEXT
+
+FIXTYO: IDIV C,E
+ PUSH P,D ; SAVE REMAINDER
+ SKIPE C
+ PUSHJ P,FIXTYO
+ POP P,A ; START GETTING #'S BACK
+ ADDI A,60
+ MOVE B,-2(TP) ; CHANNEL BACK
+ JRST PITYO
+
+\f;PRINT SINGLE-PRECISION FLOATING POINT NUMBERS IN DECIMAL.
+;
+PFLOAT: SKIPN A,(TP) ; SKIP IF NUMBER IS NON-ZERO
+ ; SPECIAL HACK FOR ZERO)
+ JRST PFLT0 ; HACK THAT ZERO
+ MOVM E,A ; CHECK FOR NORMALIZED
+ TLNN E,400 ; NORMALIZED
+ JRST PUNK
+ MOVE E,[SETZ FLOATB] ;ADDRESS OF FLOATING POINT CONVERSION ROUTINE
+ MOVE D,[6,,6] ;# WORDS TO GET FROM STACK
+
+PNUMB: HRLI A,1(P) ; LH(A) TO CONTAIN ADDRESS OF RETURN AREA
+ ; ON STACK
+ HRR A,TP ; RH(A) TO CONTAIN ADDRESS OF DATA ITEM
+ HLRZ B,A ; SAVE RETURN AREA ADDRESS IN REG B
+ ADD P,D ; ADD # WORDS OF RETURN AREA TO BOTH HALVES OF
+ ; SP
+ JUMPGE P,PDLERR ; PLUS OR ZERO STACK POINTER IS OVERFLOW
+PDLWIN: PUSHJ P,(E) ; CALL ROUTINE WHOSE ADDRESS IS IN REG E
+
+ MOVE C,(B) ; GET COUNT 0F # CHARS RETURNED
+PFLT1: MOVE A,B
+ HRR B,P ; GET PSTACK POINTER AND PRODUCE RELATAVIZED
+ SUB A,B
+ HRLS A ; ADD TO AOBJN
+ ADD A,P ; PRODUCE PDL POINTER
+ MOVE B,-2(TP) ; GET CHANNEL INTO B
+ PUSH TP,$TPDL ; PUSH PDL POINTER
+ PUSH TP,A
+ MOVE A,C ; MAKE SURE THAT # WILL FIT ON PRINT LINE
+ PUSH P,D ; WATCH THAT MCALL
+ PUSHJ P,RETIF ; START NEW LINE IF IT WON'T
+ POP P,D
+ POP TP,B ; RESTORE B
+ SUB TP,[1,,1] ; CLEAN OFF STACK
+
+ HRLI B,000700 ;MAKE REG B INTO BYTE POINTER TO FIRST CHAR
+ ; LESS ONE
+PNUM01: ILDB A,B ; GET NEXT BYTE
+ PUSH P,B ; SAVE B
+ MOVE B,-2(TP) ; GET CHANNEL INTO B
+ PUSHJ P,PITYO ; PRINT IT
+ POP P,B ; RESTORE B
+ SOJG C,PNUM01 ; DECREMENT CHAR COUNT: LOOP IF NON-ZERO
+
+ SUB P,D ;SUBTRACT # WORDS USED ON STACK FOR RETURN
+ JRST PNEXT ;STORE REGS & POP UP ONE LEVEL TO CALLER
+
+
+PFLT0: MOVEI A,9. ; WIDTH OF 0.0000000
+ MOVEI C,9. ; SEE ABOVE
+ MOVEI D,0 ; WE'RE GONNA TEST D SOON...SO WILL DO RIGHT THING
+ MOVEI B,[ASCII /0.0000000/]
+ SOJA B,PFLT1 ; PT TO 1 BELOW CONST, THEN REJOIN CODE
+
+
+
+
+PDLERR: SUB P,D ;REST STACK POINTER
+REPEAT 6,PUSH P,[0]
+ JRST PDLWIN
+\f
+; FLOATING POINT PRINTER STOLEN FROM DDT
+
+F==E+1
+G==F+1
+H==G+1
+I==H+1
+J==I+1
+TEM1==I
+
+FLOATB: PUSH P,B
+ PUSH P,C
+ PUSH P,D
+ PUSH P,F
+ PUSH P,G
+ PUSH P,H
+ PUSH P,I
+ PUSH P,0
+ PUSH P,J
+ MOVSI 0,440700 ; BUILD BYTEPNTR
+ HLRZ J,A ; POINT TO BUFFER
+ HRRI 0,1(J)
+ ANDI A,-1
+ MOVE A,(A) ; GET NUMBER
+ MOVE D,A
+ SETZM (J) ; Clear counter
+ PUSHJ P,NFLOT
+ POP P,J
+ POP P,0
+ POP P,I
+ POP P,H
+ POP P,G
+ POP P,F
+ POP P,D
+ POP P,C
+ POP P,B
+ POPJ P,
+
+; at this point we enter code abstracted from DDT.
+NFLOT: JUMPG A,TFL1
+ JUMPE A,FP1A
+ MOVNS A
+ PUSH P,A
+ MOVEI A,"-
+ PUSHJ P,CHRO
+ POP P,A
+ TLZE A,400000
+ JRST FP1A
+
+TFL1: MOVEI B,0
+TFLX: CAMGE A,FT01
+ JRST FP4
+ CAML A,FT8
+ AOJA B,FP4
+FP1A:
+FP3: SETZB C,TEM1 ; CLEAR DIGIT CNTR, C TO RECEIVE FRACTION
+ MULI A,400
+ ASHC B,-243(A)
+ MOVE A,B
+ PUSHJ P,FP7
+ PUSH P,A
+ MOVEI A,".
+ PUSHJ P,CHRO
+ POP P,A
+ MOVNI A,10
+ ADD A,TEM1
+ MOVE E,C
+FP3A: MOVE D,E
+ MULI D,12
+ PUSHJ P,FP7B
+ SKIPE E
+ AOJL A,FP3A
+ POPJ P, ; ONE return from OFLT here
+
+FP4: MOVNI C,6
+ MOVEI F,0
+FP4A: ADDI F,1(F)
+ XCT FCP(B)
+ SOSA F
+ FMPR A,@FXP+1(B)
+ AOJN C,FP4A
+ PUSH P,EXPSGN(B)
+ PUSHJ P,FP3
+ PUSH P,A
+ MOVEI A,"E
+ PUSHJ P,CHRO
+ POP P,A
+ POP P,D
+ PUSHJ P,FDIGIT
+ MOVE A,F
+
+FP7: SKIPE A ; AVOID AOSING TEM1, NOT SIGNIFICANT DIGIT
+ AOS TEM1
+ IDIVI A,12
+ PUSH P,B
+ JUMPE A,FP7A1
+ PUSHJ P,FP7
+
+FP7A1: POP P,D
+FP7B: ADDI D,"0
+
+; type digit
+FDIGIT: PUSH P,A
+ MOVE A,D
+ PUSHJ P,CHRO
+ POP P,A
+ POPJ P,
+
+CHRO: AOS (J) ; COUNT CHAR
+ IDPB A,0 ; STUFF CHAR
+ POPJ P,
+
+; constants
+ 1.0^32.
+ 1.0^16.
+FT8: 1.0^8
+ 1.0^4
+ 1.0^2
+ 1.0^1
+FT: 1.0^0
+ 1.0^-32.
+ 1.0^-16.
+ 1.0^-8
+ 1.0^-4
+ 1.0^-2
+FT01: 1.0^-1
+FT0=FT01+1
+
+; instructions
+FCP: CAMLE A, FT0(C)
+ CAMGE A, FT(C)
+ 0, FT0(C)
+FXP: SETZ FT0(C)
+ SETZ FT(C)
+ SETZ FT0(C)
+EXPSGN: "-
+ "+
+
+\f
+;PRINT SHORT (ONE WORD) CHARACTER STRINGS
+
+PCHRS: MOVEI A,3 ;MAX # CHARS PLUS 2 (LESS ESCAPES)
+ MOVE B,-2(TP) ; GET CHANNEL INTO B
+ TLNE FLAGS,NOQBIT ;SKIP IF QUOTES WILL BE USED
+ MOVEI A,1 ;ELSE, JUST ONE CHARACTER POSSIBLE
+ PUSHJ P,RETIF ;NEW LINE IF INSUFFICIENT SPACE
+ TLNE FLAGS,NOQBIT ;DON'T QUOTE IF IN PRINC MODE
+ JRST PCASIS
+ MOVEI A,"! ;TYPE A EXCL
+ PUSHJ P,PITYO
+ MOVEI A,"\ ;AND A BACK SLASH
+ PUSHJ P,PITYO
+
+PCASIS: MOVE A,(TP) ;GET NEXT BYTE FROM WORD
+ TLNE FLAGS,NOQBIT ;SKIP IF WE ARE NOT IN PRINC MODE (NOQBIT=0)
+ JRST PCPRNT ;IF BIT IS ON, PRINT WITHOUT ESCAPING
+ CAIE A,ESCHAR ;SKIP IF NOT THE ESCAPE CHARACTER
+ JRST PCPRNT ;ESCAPE THE ESCAPE CHARACTER
+
+ESCPRT: MOVEI A,ESCHAR ;TYPE THE ESCAPE CHARACTER
+ PUSHJ P,PITYO
+PCPRNT: MOVE A,(TP) ;GET THE CHARACTER AGAIN
+ TLNE FLAGS,NOQBIT ;SKIP IF WE ARE NOT IN PRINC MODE (NOQBIT=0)
+ TLO FLAGS,CNTLPC ;SWITCH ON ^P MODE TEMPORARY
+ PUSHJ P,PITYO ;PRINT IT
+ TLZ FLAGS,CNTLPC ;SWITCH OFF ^P MODE
+ JRST PNEXT
+
+
+\f;PRINT DEFERED (INVISIBLE) ITEMS. (PRINTED AS THE THING POINTED TO)
+;
+PDEFER: MOVE A,(B) ;GET FIRST WORD OF ITEM
+ MOVE B,1(B) ;GET SECOND
+ PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
+ PUSH TP,-3(TP)
+ PUSHJ P,IPRINT ;PRINT IT
+ SUB TP,[2,,2] ; POP OFF CHANNEL
+ JRST PNEXT ;GO EXIT
+
+
+; Print an ATOM. TRAILERS are added if the atom is not in the current
+; lexical path. Also escaping of charactets is performed to allow READ
+; to win.
+
+PATOM: PUSH P,[440700,,D] ; PUSH BYE POINTER TO FINAL STRING
+ SETZB D,E ; SET CHARCOUNT AD DESTINATION TO 0
+ HLLZS -1(TP) ; RH OF TATOM,, WILL COUNT ATOMS IN PATH
+
+PATOM0: PUSH TP,$TPDL ; SAVE CURRENT STAKC FOR \ LOGIC
+ PUSH TP,P
+ LDB A,[301400,,(P)] ; GET BYTE PTR POSITION
+ DPB A,[301400,,E] ; SAVE IN E
+ MOVE C,-2(TP) ; GET ATOM POINTER
+ ADD C,[3,,3] ; POINT TO PNAME
+ JUMPGE C,BADPNM ; NO PNAME, ERROR
+ HLRE A,C ; -# WORDS TO A
+ PUSH P,A ; PUSH THAT FOR "AOSE"
+ MOVEI A,177 ; PUT RUBOUT WHERE \ MIGHT GO
+ JSP B,DOIDPB
+ HRLI C,440700 ; BUILD BYTE POINTER
+ ILDB A,C ; GET FIRST BYTE
+ JUMPE A,BADPNM ; NULL PNAME, ERROR
+ SKIPA
+PATOM1: ILDB A,C ; GET A CHAR
+ JUMPE A,PATDON ; END OF PNAME?
+ TLNN C,760000 ; SKIP IF NOT WORD BOUNDARY
+ AOS (P) ; COUNT WORD
+ JRST PENTCH ; ENTER THE CHAR INTO OUTPUT
+
+PATDON: LDB A,[220600,,E] ; GET "STATE"
+ LDB A,STABYT+NONSPC+1 ; SIMULATE "END" CHARACTER
+ DPB A,[220600,,E] ; AND STORE
+ MOVE B,E ; SETUP BYTE POINTER TO 1ST CHAR
+ TLZ B,77
+ HRR B,(TP) ; POINT
+ SUB TP,[2,,2] ; FLUSH SAVED PDL
+ MOVE C,-1(P) ; GET BYE POINTER
+ SUB P,[2,,2] ; FLUSH
+ PUSH P,D
+ MOVEI A,0
+ IDPB A,B
+ AOS -1(TP) ; COUNT ATOMS
+ TLNE FLAGS,NOQBIT ; SKIP IF NOT "PRINC"
+ JRST NOLEX4 ; NEEDS NO LEXICAL TRAILERS
+ MOVEI A,"\ ; GET QUOTER
+ TLNN E,2 ; SKIP IF NEEDED
+ JRST PATDO1
+ SOS -1(TP) ; DONT COUNT BECAUSE OF SLASH
+ DPB A,B ; CLOBBER
+PATDO1: MOVEI E,(E) ; CLEAR LH(E)
+ PUSH P,C ; SAVE BYTER
+ PUSH P,E ; ALSO CHAR COUNT
+
+ MOVE B,IMQUOTE OBLIST
+ PUSH P,FLAGS
+ PUSHJ P,IDVAL ; GET LOCAL/GLOBAL VALUE
+ POP P,FLAGS ; AND RESTORES FLAGS
+ MOVE C,(TP) ; GET ATOM BACK
+ HRRZ C,2(C) ; GET ITS OBLIST
+ SKIPN C
+ AOJA A,NOOBL1 ; NONE, USE FALSE
+ CAMG C,VECBOT ; JUMP IF REAL OBLIST
+ MOVE C,(C)
+ HRROS C
+ CAME A,$TLIST ; SKIP IF A LIST
+ CAMN A,$TOBLS ; SKIP IF UNREASONABLE VALUE
+ JRST CHOBL ; WINS, NOW LOCATE IT
+
+CHROOT: CAME C,ROOT+1 ; IS THIS ROOT?
+ JRST FNDOBL ; MUST FIND THE PATH NAME
+ POP P,E ; RESTORE CHAR COUNT
+ MOVE D,(P) ; AND PARTIAL WORD
+ EXCH D,-1(P) ; STORE BYTE POINTER AND GET PARTIAL WORD
+ MOVEI A,"! ; PUT OUT MAGIC
+ JSP B,DOIDPB ; INTO BUFFER
+ MOVEI A,"-
+ JSP B,DOIDPB
+ MOVEI A,40
+ JSP B,DOIDPB
+
+NOLEX0: SUB P,[2,,2] ; REMOVE COUNTER AND BYTE POINTER
+ PUSH P,D ; PUSH NEXT WORD IF ANY
+ JRST NOLEX4
+
+NOLEX: MOVE E,(P) ; GET COUNT
+ SUB P,[2,,2]
+NOLEX4: MOVEI E,(E) ; CLOBBER LH(E)
+ MOVE A,E ; COUNT TO A
+ SKIPN (P) ; FLUSH 0 WORD
+ SUB P,[1,,1]
+ HRRZ C,-1(TP) ; GET # OF ATOMS
+ SUBI A,(C) ; FIX COUNT
+ MOVE B,-2(TP) ; GET CHANNEL INTO B
+ PUSHJ P,RETIF ; MAY NEED C.R.
+ MOVEI C,-1(E) ; COMPUTE WORDS-1
+ IDIVI C,5 ; WORDS-1 TO C
+ HRLI C,(C)
+ MOVE D,P
+ SUB D,C ; POINTS TO 1ST WORD OF CHARS
+ MOVSI C,440700+D ; BYTEPOINTER TO STRING
+ PUSH TP,$TPDL ; SAVE FROM GC
+ PUSH TP,D
+
+PATOUT: ILDB A,C ; READ A CHAR
+ SKIPE A ; IGNORE NULS
+ PUSHJ P,PITYO ; PRINT IT
+ MOVE D,(TP) ; RESTORE POINTER
+ SOJG E,PATOUT
+
+NOLEXD: SUB TP,[2,,2] ; FLUSH TP JUNK
+ MOVE P,D ; RESTORE P
+ SUB P,[1,,1]
+ JRST PNEXT
+
+
+PENTCH: TLNE FLAGS,NOQBIT ; "PRINC"?
+ JRST PENTC1 ; YES, AVOID SLASHING
+ IDIVI A,CHRWD ; GET CHARS TYPE
+ LDB B,BYTPNT(B)
+ CAILE B,NONSPC ; SKIP IF NOT SPECIAL
+ JRST PENTC2 ; SLASH IMMEDIATE
+ LDB A,[220600,,E] ; GET "STATE"
+ LDB A,STABYT-1(B) ; GET NEW STATE
+ DPB A,[220600,,E] ; AND SAVE IT
+PENTC3: LDB A,C ; RESTORE CHARACTER
+PENTC1: JSP B,DOIDPB
+ SKIPGE (P) ; SKIP IF DONE
+ JRST PATOM1 ; CONTINUE
+ JRST PATDON
+
+PENTC2: MOVEI A,"\ ; GET CHAR QUOTER
+ JSP B,DOIDPB ; NEEDED, DO IT
+ MOVEI A,4 ; PATCH FOR ATOMS ALREADY BACKSLASHED
+ JRST PENTC3-1
+
+; ROUTINE TO PUT ONE CHAR ON STACK BUFFER
+
+DOIDPB: IDPB A,-1(P) ; DEPOSIT
+ TRNN D,377 ; SKIP IF D FULL
+ AOJA E,(B)
+ PUSH P,(P) ; MOVE TOP OF STACK UP
+ MOVEM D,-2(P) ; SAVE WORDS
+ MOVE D,[440700,,D]
+ MOVEM D,-1(P)
+ MOVEI D,0
+ AOJA E,(B)
+
+; CHECK FOR UNIQUENESS LOOKING INTO PATH
+
+CHOBL: CAME A,$TOBLS ; SINGLE OBLIST?
+ JRST LSTOBL ; NO, AL LIST THEREOF
+ CAME B,C ; THE RIGTH ONE?
+ JRST CHROOT ; NO, CHECK ROOT
+ JRST NOLEX ; WINNER, NO TRAILERS!
+
+LSTOBL: PUSH TP,A ; SCAN A LIST OF OBLISTS
+ PUSH TP,B
+ PUSH TP,A
+ PUSH TP,B
+ PUSH TP,$TOBLS
+ PUSH TP,C
+
+NXTOB2: INTGO ; LIST LOOP, PREVENT LOSSAGE
+ SKIPN C,-2(TP) ; SKIP IF NOT DONE
+ JRST CHROO1 ; EMPTY, CHECK ROOT
+ MOVE B,1(C) ; GET ONE
+ CAME B,(TP) ; WINNER?
+ JRST NXTOBL ; NO KEEP LOOKING
+ CAMN C,-4(TP) ; SKIP IF NOT FIRST ON LIST
+ JRST NOLEX1
+ MOVE A,-6(TP) ; GET ATOM BACK
+ MOVEI D,0
+ ADD A,[3,,3] ; POINT TO PNAME
+ PUSH P,0 ; SAVE FROM RLOOKU
+ PUSH P,(A)
+ ADDI D,5
+ AOBJN A,.-2 ; PUSH THE PNAME
+ PUSH P,D ; AND CHAR COUNT
+ MOVSI A,TLIST ; TELL RLOOKU WE WIN
+ MOVE B,-4(TP) ; GET BACK OBLIST LIST
+ SUB TP,[6,,6] ; FLUSH CRAP
+ PUSHJ P,RLOOKU ; FIND IT
+ POP P,0
+ CAMN B,(TP) ; SKIP IF NON UNIQUE
+ JRST NOLEX ; UNIQUE , NO TRAILER!!
+ JRST CHROO2 ; CHECK ROOT
+
+NXTOBL: HRRZ B,@-2(TP) ; STEP THE LIST
+ MOVEM B,-2(TP)
+ JRST NXTOB2
+
+
+FNDOBL: MOVE C,(TP) ; GET ATOM
+ MOVSI A,TOBLS
+ HRRZ B,2(C)
+ CAMG B,VECBOT
+ MOVE B,(B)
+ HRLI B,-1
+ MOVSI C,TATOM
+ MOVE D,IMQUOTE OBLIST
+ PUSH P,0
+ PUSHJ P,IGET
+ POP P,0
+NOOBL1: POP P,E ; RESTORE CHAR COUNT
+ MOVE D,(P) ; GET PARTIAL WORD
+ EXCH D,-1(P) ; AND BYTE POINTER
+ CAME A,$TATOM ; IF NOT ATOM, USE FALSE
+ JRST NOOBL
+ MOVEM B,(TP) ; STORE IN ATOM SLOT
+ MOVEI A,"!
+ JSP B,DOIDPB ; WRITE IT OUT
+ MOVEI A,"-
+ JSP B,DOIDPB
+ SUB P,[1,,1]
+ JRST PATOM0 ; AND LOOP
+
+NOOBL: MOVE C,[440700,,[ASCIZ /!-#FALSE ()/]]
+ ILDB A,C
+ JUMPE A,NOLEX0
+ JSP B,DOIDPB
+ JRST .-3
+
+
+NOLEX1: SUB TP,[6,,6] ; FLUSH STUFF
+ JRST NOLEX
+
+CHROO1: SUB TP,[6,,6]
+CHROO2: MOVE C,(TP) ; GET ATOM
+ HRRZ C,2(C) ; AND ITS OBLIST
+ CAMG C,VECBOT
+ MOVE C,(C)
+ HRROS C
+ JRST CHROOT
+BADPNM: ERRUUO EQUOTE BAD-PNAME
+
+
+\f; STATE TABLES FOR \ OF FIRST CHAR
+; Each word is a state and each 4 bit byte tells where to go based on the input
+; type. The types are defined in READER >. The input type selects a byte pointer
+; into the table which is indexed by the current state.
+
+RADIX 16.
+
+STATS: 431192440 ; INITIAL STATE (0)
+ 434444444 ; HERE ON INIT +- (1)
+ 222222242 ; HERE ON INIT . (2)
+ 434445642 ; HERE ON INIT DIGIT (3)
+ 444444444 ; HERE IF NO \ NEEDE (4)
+ 454444642 ; HERE ON DDDD. (5)
+ 487744444 ; HERE ON E (6)
+ 484444444 ; HERE ON E+- (7)
+ 484444442 ; HERE ON E+-DDD (8)
+ 494444444+<1_28.> ; HERE ON * (HACK IS TO GET A 10 IN THERE) (9)
+ 494494444+<1_28.>+<2_16.> ; HERE ON *DDDDD (10)
+ 444444442
+
+RADIX 8.
+
+STABYT: 400400,,STATS(A) ; LETTERS
+ 340400,,STATS(A) ; NUMBERS
+ 300400,,STATS(A) ; PLUS SIGN +
+ 240400,,STATS(A) ; MINUS SIGN -
+ 200400,,STATS(A) ; asterick *
+ 140400,,STATS(A) ; PERIOD .
+ 100400,,STATS(A) ; LETTER E
+ 040400,,STATS(A) ; extra
+ 000400,,STATS(A) ; HERE ON RAP UP
+
+\f;PRINT LONG CHARACTER STRINGS.
+;
+PCHSTR: MOVE B,(TP)
+ TLZ FLAGS,ATMBIT ;WE ARE NOT USING ATOM-NAME TYPE ESCAPING
+ MOVE D,[AOS E] ;GET INSTRUCTION TO COUNT CHARACTERS
+ SETZM E ;ZERO COUNT
+ PUSH TP,-3(TP)
+ PUSH TP,-3(TP)
+ PUSH TP,-3(TP)
+ PUSH TP,-3(TP) ;GIVE PCHRST SOME GOODIES TO PLAY WITH
+ PUSHJ P,PCHRST ;GO THROUGH STRING, ESCAPING, ETC. AND COUNTING
+ SUB TP,[4,,4] ;FLUSH MUNGED GOODIES
+ MOVE A,E ;PUT COUNT RETURNED IN REG A
+ TLNN FLAGS,NOQBIT ;SKIP (NO QUOTES) IF IN PRINC (BIT ON)
+ ADDI A,2 ;PLUS TWO FOR QUOTES
+ MOVE B,-2(TP) ; GET CHANNEL INTO B
+ PUSHJ P,RETIF ;START NEW LINE IF NO SPACE
+ TLNE FLAGS,NOQBIT ;SKIP (PRINT ") IF BIT IS OFF (NOT PRINC)
+ JRST PCHS01 ;OTHERWISE, DON'T QUOTE
+ MOVEI A,"" ;PRINT A DOUBLE QUOTE
+ MOVE B,-2(TP)
+ PUSHJ P,PITYO
+
+PCHS01: MOVE D,[PUSHJ P,PITYO] ;OUTPUT INSTRUCTION
+ PUSHJ P,PCHRST ;TYPE STRING
+
+ TLNE FLAGS,NOQBIT ;AGAIN, SKIP IF DOUBLE-QUOTING TO BE DONE
+ JRST PNEXT ;RESTORE REGS & POP UP ONE LEVEL TO CALLER
+ MOVEI A,"" ;PRINT A DOUBLE QUOTE
+ MOVE B,-2(TP) ; GET CHANNEL INTO B
+ PUSHJ P,PITYO
+ JRST PNEXT
+
+
+;INTERNAL ROUTINE USED TO COUNT OR OUTPUT CHARACTER STRINGS.
+;THE APPROPRIATE ESCAPING CONVENTIONS ARE USED AS DETERMINED BY THE FLAG BITS.
+PCHRST: PUSH P,A ;SAVE REGS
+ PUSH P,B
+ PUSH P,C
+ PUSH P,D
+
+PCHR02: INTGO ; IN CASE VERY LONG STRING
+ HRRZ C,-1(TP) ;GET COUNT
+ SOJL C,PCSOUT ; DONE?
+ HRRM C,-1(TP)
+ ILDB A,(TP) ; GET CHAR
+
+ TLNE FLAGS,NOQBIT ;SKIP IF WE ARE NOT IN PRINC MODE (NOQBIT=0)
+ JRST PCSPRT ;IF BIT IS ON, PRINT WITHOUT ESCAPING
+ CAIN A,ESCHAR ;SKIP IF NOT THE ESCAPE CHARACTER
+ JRST ESCPRN ;ESCAPE THE ESCAPE CHARACTER
+ CAIN A,"" ;SKIP IF NOT A DOUBLE QUOTE
+ JRST ESCPRN ;OTHERWISE, ESCAPE THE """
+ IDIVI A,CHRWD ;CODE HERE FINDS CHARACTER TYPE
+ LDB B,BYTPNT(B) ; "
+ CAIG B,NONSPC ;SKIP IF NOT A NUMBER/LETTER
+ JRST PCSPRT ;OTHERWISE, PRINT IT
+ TLNN FLAGS,ATMBIT ;SKIP IF PRINTING AN ATOM-NAME (UNQUOTED)
+ JRST PCSPRT ;OTHERWISE, NO OTHER CHARS TO ESCAPE
+
+ESCPRN: MOVEI A,ESCHAR ;TYPE THE ESCAPE CHARACTER
+ PUSH P,B ; SAVE B
+ MOVE B,-2(TP) ; GET CHANNEL INTO B
+ XCT (P)-1
+ POP P,B ; RESTORE B
+
+PCSPRT: LDB A,(TP) ;GET THE CHARACTER AGAIN
+ PUSH P,B ; SAVE B
+ MOVE B,-2(TP) ; GET CHANNEL INTO B
+ TLNE FLAGS,NOQBIT ; SKIP IF WE ARE NOT IN PRINC MODE (NOQBIT=0)
+ TLO FLAGS,CNTLPC ; SWITCH ON TEMPORARY ^P MODE
+ XCT (P)-1 ;PRINT IT
+ TLZ FLAGS,CNTLPC ; SWITCH OFF ^P MODE
+ POP P,B ; RESTORE B
+ JRST PCHR02 ;LOOP THROUGH STRING
+
+PCSOUT: POP P,D
+ POP P,C ;RESTORE REGS & RETURN
+ POP P,B
+ POP P,A
+ POPJ P,
+
+
+\f
+; PRINT AN ARBITRARY BYTE STRING
+
+PBYTE: PUSH TP,-3(TP)
+ PUSH TP,-3(TP)
+ MOVEI A,"#
+ MOVE B,(TP)
+ PUSHJ P,PRETIF
+ LDB B,[300600,,-2(TP)]
+ MOVSI A,TFIX
+ PUSHJ P,IPRINT
+ MOVE B,(TP)
+ PUSHJ P,SPACEQ
+ MOVEI A,"{
+ MOVE B,(TP)
+ PUSHJ P,PRETIF
+ HRRZ A,-3(TP) ; CHAR COUNT
+ JUMPE A,CLSBYT
+
+BYTLP: SOS -3(TP)
+ ILDB B,-2(TP) ; GET A BYTE
+ MOVSI A,TFIX
+ PUSHJ P,IPRINT
+ HRRZ A,-3(TP)
+ JUMPE A,CLSBYT
+ MOVE B,(TP)
+ PUSHJ P,SPACEQ
+ JRST BYTLP
+
+CLSBYT: MOVEI A,"}
+ MOVE B,(TP)
+ PUSHJ P,PRETIF
+ SUB TP,[2,,2]
+ JRST PNEXT
+
+
+;PRINT AN ARGUMENT LIST
+;CHECK FOR TIME ERRORS
+
+PARGS: MOVEI B,-1(TP) ;POINT TO ARGS POINTER
+ PUSHJ P,CHARGS ;AND CHECK THEM
+ JRST PVEC ; CHEAT TEMPORARILY
+
+
+
+;PRINT A FRAME
+PFRAME: MOVEI B,-1(TP) ;POINT TO FRAME POINTER
+ PUSHJ P,CHFRM
+ HRRZ B,(TP) ;POINT TO FRAME ITSELF
+ HRRZ B,FSAV(B) ;GET POINTER TO SUBROUTINE
+ CAIL B,HIBOT
+ SKIPA B,@-1(B) ; SUBRS AND FSUBRS
+ MOVE B,3(B) ; FOR RSUBRS
+ MOVSI A,TATOM
+ PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
+ PUSH TP,-3(TP)
+ PUSHJ P,IPRINT ;PRINT FUNCTION NAME
+ SUB TP,[2,,2] ; POP CHANNEL OFF STACK
+ JRST PNEXT
+
+PPVP: MOVE B,(TP) ; PROCESS TO B
+ MOVSI A,TFIX
+ JUMPE B,.+3
+ MOVE A,PROCID(B)
+ MOVE B,PROCID+1(B) ;GET ID
+ PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
+ PUSH TP,-3(TP)
+ PUSHJ P,IPRINT
+ SUB TP,[2,,2] ; POP CHANNEL OFF STACK
+ JRST PNEXT
+
+; HERE TO PRINT LOCATIVES
+
+LOCPT1: HRRZ A,-1(TP)
+ JUMPN A,PUNK
+LOCPT: MOVEI B,-1(TP) ; VALIDITY CHECK
+ PUSHJ P,CHLOCI
+ HRRZ A,-1(TP)
+ JUMPE A,GLOCPT
+ MOVE B,(TP)
+ MOVE A,(B)
+ MOVE B,1(B)
+ PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
+ PUSH TP,-3(TP)
+ PUSHJ P,IPRINT
+ SUB TP,[2,,2] ; POP CHANNEL OFF STACK
+ JRST PNEXT
+
+GLOCPT: MOVEI A,2
+ MOVE B,-2(TP) ; GET CHANNEL
+ PUSHJ P,RETIF
+ MOVEI A,"%
+ PUSHJ P,PITYO
+ MOVEI A,"<
+ PUSHJ P,PITYO
+ MOVSI A,TATOM
+ MOVE B,MQUOTE GLOC
+ PUSH TP,-3(TP)
+ PUSH TP,-3(TP)
+ PUSHJ P,IPRINT
+ SUB TP,[2,,2]
+ MOVE B,-2(TP) ; MOVE IN CHANNEL
+ PUSHJ P,SPACEQ
+ MOVE B,(TP)
+ MOVSI A,TATOM
+ MOVE B,-1(B)
+ PUSH TP,-3(TP)
+ PUSH TP,-3(TP)
+ PUSHJ P,IPRINT
+ SUB TP,[2,,2]
+ MOVE B,-2(TP) ; MOVE IN CHANNEL
+ PUSHJ P,SPACEQ
+ MOVSI A,TATOM
+ MOVE B,IMQUOTE T
+ PUSH TP,-3(TP)
+ PUSH TP,-3(TP)
+ PUSHJ P,IPRINT
+ SUB TP,[2,,2]
+ MOVE B,-2(TP) ; MOVE IN CHANNEL
+ MOVEI A,">
+ PUSHJ P,PRETIF
+ JRST PNEXT
+
+LOCRPT: MOVEI A,2
+ MOVE B,-2(TP) ; GET CHANNEL
+ PUSHJ P,RETIF
+ MOVEI A,"%
+ PUSHJ P,PITYO
+ MOVEI A,"<
+ PUSHJ P,PITYO
+ MOVSI A,TATOM
+ MOVE B,MQUOTE RGLOC
+ PUSH TP,-3(TP)
+ PUSH TP,-3(TP)
+ PUSHJ P,IPRINT
+ SUB TP,[2,,2]
+ MOVE B,-2(TP) ; MOVE IN CHANNEL
+ PUSHJ P,SPACEQ
+ MOVE B,(TP)
+ MOVSI A,TATOM
+ ADD B,GLOTOP+1 ; GET TO REAL ATOM
+ MOVE B,-1(B)
+ PUSH TP,-3(TP)
+ PUSH TP,-3(TP)
+ PUSHJ P,IPRINT
+ SUB TP,[2,,2]
+ MOVE B,-2(TP) ; MOVE IN CHANNEL
+ PUSHJ P,SPACEQ
+ MOVSI A,TATOM
+ MOVE B,IMQUOTE T
+ PUSH TP,-3(TP)
+ PUSH TP,-3(TP)
+ PUSHJ P,IPRINT
+ SUB TP,[2,,2]
+ MOVE B,-2(TP) ; MOVE IN CHANNEL
+ MOVEI A,">
+ PUSHJ P,PRETIF
+ JRST PNEXT
+
+\f;PRINT UNIFORM VECTORS.
+;
+PUVEC: MOVE B,-2(TP) ; GET CHANNEL INTO B
+ MOVEI A,2 ; ROOM FOR ! AND SQ BRACK?
+ PUSHJ P,RETIF
+ MOVEI A,"! ;TYPE AN ! AND OPEN SQUARE BRACKET
+ PUSHJ P,PITYO
+ MOVEI A,"[
+ PUSHJ P,PITYO
+
+ MOVE C,(TP) ;GET AOBJN POINTER TO VECTOR
+ TLNN C,777777 ;SKIP ONLY IF COUNT IS NOT ZERO
+ JRST NULVEC ;ELSE, VECTOR IS EMPTY
+
+ HLRE A,C ;GET NEG COUNT
+ MOVEI D,(C) ;COPY POINTER
+ SUB D,A ;POINT TO DOPE WORD
+ HLLZ A,(D) ;GET TYPE
+ PUSH P,A ;AND SAVE IT
+
+PUVE02: MOVE A,(P) ;PUT TYPE CODE IN REG A
+ MOVE B,(C) ;PUT DATUM INTO REG B
+ PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
+ PUSH TP,-3(TP)
+ PUSHJ P,IPRINT ;TYPE IT
+ SUB TP,[2,,2] ; POP CHANNEL OF STACK
+ MOVE C,(TP) ;GET AOBJN POINTER
+ AOBJP C,NULVE1 ;JUMP IF COUNT IS ZERO
+ MOVEM C,(TP) ;PUT POINTER BACK ONTO STACK
+
+ MOVE B,-2(TP) ; GET CHANNEL INTO B
+ PUSHJ P,SPACEQ
+ MOVE C,(TP)
+ JRST PUVE02 ;LOOP THROUGH VECTOR
+
+NULVE1: SUB P,[1,,1] ;REMOVE STACK CRAP
+NULVEC: MOVE B,-2(TP) ; GET CHANNEL INTO B
+ MOVEI A,"! ;TYPE CLOSE BRACKET
+ PUSHJ P,PRETIF
+ MOVEI A,"]
+ PUSHJ P,PRETIF
+ JRST PNEXT
+
+\f;PRINT A GENERALIZED VECTOR
+;
+PVEC: MOVE B,-2(TP) ; GET CHANNEL INTO B
+ PUSHJ P,RETIF1 ;NEW LINE IF NO ROOM FOR [
+ MOVEI A,"[ ;PRINT A LEFT-BRACKET
+ PUSHJ P,PITYO
+
+ MOVE C,(TP) ;GET AOBJN POINTER TO VECTOR
+ TLNN C,777777 ;SKIP IF POINTER-COUNT IS NON-ZERO
+ JRST PVCEND ;ELSE, FINISHED WITH VECTOR
+PVCR01: MOVE A,(C) ;PUT FIRST WORD OF NEXT ELEMENT INTO REG A
+ MOVE B,1(C) ;SECOND WORD OF LIST INTO REG B
+ PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
+ PUSH TP,-3(TP)
+ PUSHJ P,IPRINT ;PRINT THAT ELEMENT
+ SUB TP,[2,,2] ; POP CHANNEL OFF STACK
+
+ MOVE C,(TP) ;GET AOBJN POINTER FROM TP-STACK
+ AOBJP C,PVCEND ;POSITIVE HERE SERIOUS ERROR! (THOUGH NOT PDL)
+ AOBJN C,.+2 ;SKIP AND CONTINUE LOOP IF COUNT NOT ZERO
+ JRST PVCEND ;ELSE, FINISHED WITH VECTOR
+ MOVEM C,(TP) ;PUT INCREMENTED POINTER BACK ON TP-STACK
+
+ MOVE B,-2(TP) ; GET CHANNEL INTO B
+ PUSHJ P,SPACEQ
+ MOVE C,(TP) ; RESTORE REGISTER C
+ JRST PVCR01 ;CONTINUE LOOPING THROUGH OBJECTS ON VECTOR
+
+PVCEND: MOVE B,-2(TP) ; GET CHANNEL INTO B
+ PUSHJ P,RETIF1 ;NEW LINE IF NO ROOM FOR ]
+ MOVEI A,"] ; PRINT A RIGHT-BRACKET
+ PUSHJ P,PITYO
+ JRST PNEXT
+
+\f;PRINT A LIST.
+;
+PLIST: MOVE B,-2(TP) ; GET CHANNEL INTO B
+ PUSHJ P,RETIF1 ;NEW LINE IF NO SPACE LEFT FOR "("
+ MOVEI A,"( ;TYPE AN OPEN PAREN
+ PUSHJ P,PITYO
+ PUSHJ P,LSTPRT ;PRINT THE INSIDES
+ MOVE B,-2(TP) ; RESTORE CHANNEL TO B
+ PUSHJ P,RETIF1 ;NEW LINE IF NO ROOM FOR THE CLOSE PAREN
+ MOVEI A,") ;TYPE A CLOSE PAREN
+ PUSHJ P,PITYO
+ JRST PNEXT
+
+PSEG: TLOA FLAGS,SEGBIT ;PRINT A SEGMENT (& SKIP)
+
+PFORM: TLZ FLAGS,SEGBIT ;PRINT AN ELEMENT
+
+PLMNT3: MOVE C,(TP)
+ JUMPE C,PLMNT1 ;IF THE CALL IS EMPTY GO AWAY
+ MOVE B,1(C)
+ MOVEI D,0
+ CAMN B,IMQUOTE LVAL
+ MOVEI D,".
+ CAMN B,IMQUOTE GVAL
+ MOVEI D,",
+ CAMN B,IMQUOTE QUOTE
+ MOVEI D,"'
+ JUMPE D,PLMNT1 ;NEITHER, LEAVE
+
+;ITS A SPECIAL HACK
+ HRRZ C,(C)
+ JUMPE C,PLMNT1 ;NIL BODY?
+
+;ITS VALUE OF AN ATOM
+ HLLZ A,(C)
+ MOVE B,1(C)
+ HRRZ C,(C)
+ JUMPN C,PLMNT1 ;IF TERE ARE EXTRA ARGS GO AWAY
+
+ PUSH P,D ;PUSH THE CHAR
+ PUSH TP,A
+ PUSH TP,B
+ TLNN FLAGS,SEGBIT ;SKIP (CONTINUE) IF THIS IS A SEGMENT
+ JRST PLMNT4 ;ELSE DON'T PRINT THE "."
+
+;ITS A SEGMENT CALL
+ MOVE B,-4(TP) ; GET CHANNEL INTO B
+ MOVEI A,2 ; ROOM FOR ! AND . OR ,
+ PUSHJ P,RETIF
+ MOVEI A,"!
+ PUSHJ P,PITYO
+
+PLMNT4: MOVE B,-4(TP) ; GET CHANNEL INTO B
+ PUSHJ P,RETIF1
+ POP P,A ;RESTORE CHAR
+ PUSHJ P,PITYO
+ POP TP,B
+ POP TP,A
+ PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
+ PUSH TP,-3(TP)
+ PUSHJ P,IPRINT
+ SUB TP,[2,,2] ; POP CHANNEL OFF STACK
+ JRST PNEXT
+
+
+PLMNT1: TLNN FLAGS,SEGBIT ;SKIP IF THIS IS A SEGMENT
+ JRST PLMNT5 ;ELSE DON'T TYPE THE "!"
+
+;ITS A SEGMENT CALL
+ MOVE B,-2(TP) ; GET CHANNEL INTO B
+ MOVEI A,2 ; ROOM FOR ! AND <
+ PUSHJ P,RETIF
+ MOVEI A,"!
+ PUSHJ P,PITYO
+
+PLMNT5: MOVE B,-2(TP) ; GET CHANNEL FOR B
+ PUSHJ P,RETIF1
+ MOVEI A,"<
+ PUSHJ P,PITYO
+ PUSHJ P,LSTPRT
+ MOVEI A,"!
+ MOVE B,-2(TP) ; GET CHANNEL INTO B
+ TLNE FLAGS,SEGBIT ;SKIP IF NOT SEGEMNT
+ PUSHJ P,PRETIF
+ MOVEI A,">
+ PUSHJ P,PRETIF
+ JRST PNEXT
+
+
+\f
+LSTPRT: SKIPN C,(TP)
+ POPJ P,
+ HLLZ A,(C) ;GET NEXT ELEMENT
+ MOVE B,1(C)
+ HRRZ C,(C) ;CHOP THE LIST
+ JUMPN C,PLIST1
+ PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
+ PUSH TP,-3(TP)
+ PUSHJ P,IPRINT ;PRINT THE LAST ELEMENT
+ SUB TP,[2,,2] ; POP CHANNEL OFF STACK
+ POPJ P,
+
+PLIST1: MOVEM C,(TP)
+ PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT
+ PUSH TP,-3(TP)
+ PUSHJ P,IPRINT ;PRINT THE NEXT ELEMENT
+ SUB TP,[2,,2] ; POP CHANNEL OFF STACK
+ MOVE B,-2(TP) ; GET CHANNEL INTO B
+ PUSHJ P,SPACEQ
+ JRST LSTPRT ;REPEAT
+
+PNEXT: POP P,FLAGS ;RESTORE PREVIOUS FLAG BITS
+ SUB TP,[2,,2] ;REMOVE INPUT ELEMENT FROM TP-STACK
+ POP P,C ;RESTORE REG C
+ POPJ P,
+
+OPENIT: PUSH P,A
+ PUSH P,B
+ PUSH P,C
+ PUSH P,D
+ PUSH P,FLAGS
+ PUSHJ P,OPNCHN
+ POP P,FLAGS
+ POP P,D
+ POP P,C
+ POP P,B
+ POP P,A
+ JUMPGE B,FNFFL ;ERROR IF IT CANNOT BE OPENED
+ HRRZ E,-2(B)
+ POPJ P,
+
+
+END
+\f
\ No newline at end of file
--- /dev/null
+
+TITLE SETPUR
+
+1PASS
+
+BOT==700000
+
+.GLOBAL .LPUR,.LIMPU,HIBOT,PHIBOT,REALGC,THIBOT
+REALGC==200000
+
+LOC 140
+
+.LIMPU==140
+
+HIBOT==BOT
+PHIBOT==BOT_<-10.>
+THIBOT==BOT_<-9.>
+
+.LPUR==BOT
+
+LOC BOT
+
+END
+\f\ 3\f
\ No newline at end of file
--- /dev/null
+
+TITLE GETPUT ASSOCIATION FUNCTIONS FOR MUDDLE
+
+RELOCATABLE
+
+.INSRT MUDDLE >
+
+; COMPONENTS IN AN ASSOCIATION BLOCK
+
+ITEM==0 ;ITEM TO WHICH INDUCATOR APPLIES
+VAL==2 ;VALUE
+INDIC==4 ;INDICATOR
+NODPNT==6 ;IF NON ZERO POINTS TO CHAIN
+PNTRS==7 ;POINTERS NEXT (RH) AND PREV (LH)
+
+ASOLNT==8 ;NUMBER OF WORDS IN AN ASSOCIATION BLOCK
+
+.GLOBAL ASOVEC ;POINTER TO HASH VECTOR IN TV
+.GLOBAL ASOLNT,ITEM,INDIC,VAL,NODPNT,NODES,IPUTP,IGETP,PUT,IFALSE
+.GLOBAL DUMNOD,IGETLO,IBLOCK,MONCH,RMONCH,IPUT,IGETL,IREMAS,IGET
+.GLOBAL NWORDT,CIGETP,CIGTPR,CIPUTP,CIREMA,MPOPJ,PVSTOR,SPSTOR
+
+MFUNCTION GETP,SUBR,[GETPROP]
+
+ ENTRY
+
+IGETP: PUSHJ P,GETLI
+ JRST FINIS ; NO SKIP, LOSE
+ MOVSI A,TLOCN
+ HLLZ 0,VAL(B)
+ PUSHJ P,RMONCH ; CHECK MONITOR
+ MOVE A,VAL(B) ;ELSE RETURN VALUE
+ MOVE B,VAL+1(B)
+CFINIS: JRST FINIS
+
+; FUNCTION TO RETURN LOCATIVE TO ASSOC
+
+MFUNCTION GETPL,SUBR
+
+ ENTRY
+
+IGETLO: PUSHJ P,GETLI
+ JRST FINIS
+ MOVSI A,TLOCN
+ JRST FINIS
+
+GETLI: PUSHJ P,2OR3 ; GET ARGS
+ PUSHJ P,IGETL ;SEE IF ASSOCIATION EXISTS
+ SKIPE B
+ AOS (P) ; WIN RETURN
+ CAMGE AB,[-4,,0] ; ANY ERROR THING
+ JUMPE B,CHFIN ;IF 0, NONE EXISTS
+ POPJ P,
+
+CHFIN: PUSH TP,4(AB)
+ PUSH TP,5(AB)
+ MCALL 1,EVAL
+ POPJ P,
+
+; COMPILER CALLS TO SOME OF THESE
+
+CIGETP: SUBM M,(P) ; FIX RET ADDR
+ PUSHJ P,IGETL ; GO TO INTERNAL
+ JUMPE B,MPOPJ
+ MOVSI A,TLOCN
+MPOPJ1: SOS (P) ; WINNER (SOS BECAUSE OF SUBM M,(P))
+MPOPJ: SUBM M,(P)
+ POPJ P,
+
+CIGTPR: SUBM M,(P)
+ PUSHJ P,IGETL
+ JUMPE B,MPOPJ
+ MOVE A,VAL(B) ; GET VAL TYPE
+ MOVE B,VAL+1(B)
+ JRST MPOPJ1
+
+CIPUTP: SUBM M,(P)
+ PUSH TP,-1(TP) ; SAVE VAL
+ PUSH TP,-1(TP)
+ PUSHJ P,IPUT ; DO IT
+ POP TP,B
+ POP TP,A
+ JRST MPOPJ
+
+CIREMA: SUBM M,(P)
+ PUSHJ P,IREMAS ; FLUSH IT
+ JRST MPOPJ
+
+; CHECK PUT/GET PUTPROP AND GETPROP ARGS
+
+2OR3: HLRE 0,AB
+ ASH 0,-1 ; TO -# OF ARGS
+ ADDI 0,2 ; AT LEAST 2
+ JUMPG 0,TFA ; 1 OR LESS, LOSE
+ AOJL 0,TMA ; 4 OR MORE, LOSE
+ MOVE A,(AB) ; GET ARGS INTO ACS
+ MOVE B,1(AB)
+ MOVE C,2(AB)
+ MOVE D,3(AB)
+ POPJ P,
+
+; INTERNAL GET
+
+IGET: PUSHJ P,IGETL ; GET LOCATIVE
+ JUMPE B,CPOPJ
+ MOVE A,VAL(B)
+ MOVE B,VAL+1(B)
+ POPJ P,
+
+; FUNCTION TO MAKE AN ASSOCIATION
+
+MFUNCTION PUTP,SUBR,[PUTPROP]
+
+ ENTRY
+
+IPUTP: PUSHJ P,2OR3 ; GET ARGS
+ JUMPN 0,REMAS ; REMOVE AN ASSOCIATION
+ PUSH TP,4(AB) ; SAVE NEW VAL
+ PUSH TP,5(AB)
+ PUSHJ P,IPUT ; DO IT
+ MOVE A,(AB) ; RETURN NEW VAL
+ MOVE B,1(AB)
+ JRST FINIS
+
+REMAS: PUSHJ P,IREMAS
+ JRST FINIS
+
+IPUT: SKIPN DUMNOD+1 ; NEW DUMMY NEDDED?
+ PUSHJ P,DUMMAK ; YES, GO MAKE ONE
+IPUT1: PUSHJ P,IGETI ;SEE IF THIS ONE EXISTS
+
+ JUMPE B,NEWASO ;JUMP IF NEED NEW ASSOCIATION BLOCK
+CLOBV: MOVE C,-5(TP) ; RET NEW VAL
+ MOVE D,-4(TP)
+ SUB TP,[6,,6]
+ HLLZ 0,VAL(B)
+ MOVSI A,TLOCN
+ PUSHJ P,MONCH ; MONITOR CHECK
+ MOVEM C,VAL(B) ;STORE IT
+ MOVEM D,VAL+1(B)
+CPOPJ: POPJ P,
+
+; HERE TO CREATE A NEW ASSOCIATION
+
+NEWASO: MOVE B,DUMNOD+1 ; GET BALNK ASSOCIATION
+ SETZM DUMNOD+1 ; CAUSE NEW ONE NEXT TIME
+
+
+;NOW SPLICE IN CHAIN
+
+ JUMPE D,PUT1 ;NO OTHERS EXISTED IN THIS BUCKET
+ HRLZM C,PNTRS(B) ;CLOBBER PREV POINTER
+ HRRM B,PNTRS(C) ;AND NEXT POINTER
+ JRST .+2
+
+PUT1: HRRZM B,(C) ;STORE INTO VECTOR
+ HRRZ C,NODES+1
+ HRLM C,NODPNT(B)
+ MOVE D,NODPNT(C)
+ HRRZM B,NODPNT(C)
+ HRRM D,NODPNT(B)
+ HRLM B,NODPNT(D)
+ MOVEI C,-3(TP) ;COPY ARG POINTER
+ MOVSI A,-4 ;AND COPY POINTER
+
+PUT2: MOVE D,(C) ;START COPYING
+ MOVEM D,@CLOBTB(A)
+ ADDI C,1
+ AOBJN A,PUT2 ;NOTE *** DEPENDS ON ORDER IN VECTOR ***
+
+ JRST CLOBV
+
+;HERE TO REMOVE AN ASSOCIATION
+
+IREMAS: PUSHJ P,IGETL ;LOOK IT UP
+ JUMPE B,CPOPJ ;NEVER EXISTED, IGNORE
+ HRRZ A,PNTRS(B) ;NEXT POINTER
+ HLRZ E,PNTRS(B) ;PREV POINTER
+ SKIPE A ;DOES A NEXT EXIST?
+ HRLM E,PNTRS(A) ;YES CLOBBER ITS PREV POINTER
+ SKIPN D ;SKIP IF NOT FIRST IN BUCKET
+ MOVEM A,(C) ;FIRST STORE NEW ONE
+ SKIPE D ;OTHERWISE
+ HRRM A,PNTRS(E) ;PATCH NEXT POINTER IN PREVIOUS
+ HRRZ A,NODPNT(B) ;SEE IF MUST UNSPLICE NODE
+ HLRZ E,NODPNT(B)
+ SKIPE A
+ HRLM E,NODPNT(A) ;SPLICE
+ JUMPE E,PUT4 ;FLUSH IF NO PREV POINTER
+ HRRZ C,NODPNT(E) ;GET PREV'S NEXT POINTER
+ CAIE C,(B) ;DOES IT POINT TO THIS NODE
+ .VALUE [ASCIZ /:\eFATAL PUT LOSSAGE/]
+ HRRM A,NODPNT(E) ;YES, SPLICE
+PUT4: MOVE A,VAL(B) ;RETURN VALUE
+ SETZM PNTRS(B)
+ MOVE B,VAL+1(B)
+ POPJ P,
+
+
+;INTERNAL GET FUNCTION CALLED BY PUT AND GET
+; A AND B ARE THE ITEM
+;C AND D ARE THE INDICATOR
+
+IGETL: PUSHJ P,IGETI
+ SUB TP,[4,,4] ; FLUSH CRUFT LEFT BY IGETI
+ POPJ P,
+
+IGETI: PUSHJ P,LHCLR
+ EXCH A,C
+ PUSHJ P,LHCLR
+ EXCH C,A
+ PUSH TP,A
+ PUSH TP,B
+ PUSH TP,C ;SAVE C AND D
+ PUSH TP,D
+ XOR A,B ; BUILD HASH
+ XOR A,C
+ XOR A,D
+ TLZ A,400000 ; FORCE POS A
+ HLRZ B,ASOVEC+1 ;GET LENGTH OF HASH VECTOR
+ MOVNS B
+ IDIVI A,(B) ;RELATIVE BUCKET NOW IN B
+ HRLI B,(B) ;IN CASE GC OCCURS
+ ADD B,ASOVEC+1 ;POINT TO BUCKET
+ MOVEI D,0 ;SET FIRST SWITCH
+ SKIPN A,(B) ;GET CONTENTS OF BUCKET (DONT SKIP IF EMPTY)
+ JRST GFALSE
+
+ MOVSI 0,TASOC ;FOR INTGOS, MAKE A TASOC
+ MOVE PVP,PVSTOR+1
+ HLLZM 0,ASTO(PVP)
+
+IGET1: GETYPF 0,ITEM(A) ;GET ITEMS TYPE
+ MOVE E,ITEM+1(A)
+ CAMN 0,-3(TP) ;COMPARE TYPES
+ CAME E,-2(TP) ;AND VALUES
+ JRST NXTASO ;LOSER
+ GETYPF 0,INDIC(A) ;MOW TRY INDICATORS
+ MOVE E,INDIC+1(A)
+ CAMN 0,-1(TP)
+ CAME E,(TP)
+ JRST NXTASO
+
+ SKIPN D ;IF 1ST THEN
+ MOVE C,B ;RETURN POINTER IN C
+ MOVE B,A ;FOUND, RETURN ASSOCIATION
+ MOVSI A,TASOC
+IGRET: MOVE PVP,PVSTOR+1
+ SETZM ASTO(PVP)
+ POPJ P,
+
+NXTASO: MOVEI D,1 ;SET SWITCH
+ MOVE C,A ;CYCLE
+ HRRZ A,PNTRS(A) ;STEP
+ JUMPN A,IGET1
+
+ MOVSI A,TFALSE
+ MOVEI B,0
+ JRST IGRET
+
+GFALSE: MOVE C,B ;PRESERVE VECTOR POINTER
+ MOVSI A,TFALSE
+ SETZB B,D
+ JRST IGRET
+
+; FUNCTION TO DO A PUT AND ALSO ADD TO THE NODE FOR THIS GOODIE
+
+REPEAT 0,[
+MFUNCTION PUTN,SUBR
+
+ ENTRY
+
+ CAML AB,[-4,,0] ;WAS THIS A REMOVAL
+ JRST PUT
+
+ PUSHJ P,IPUT ;DO THE PUT
+ SKIPE NODPNT(C) ;NODE CHAIN EXISTS?
+ JRST FINIS
+
+ PUSH TP,$TASOC ;NO, START TO BUILD
+ PUSH TP,C
+ SKIPN DUMNOD+1 ; FIX UP DUMMY?
+ PUSHJ P,DUMMAK
+CHPT: MOVE C,$TCHSTR
+ MOVE D,CHQUOTE NODE
+ PUSHJ P,IGETL
+ JUMPE B,MAKNOD ;NOT FOUND, LOSE
+NODSPL: MOVE C,(TP) ;HERE TO SPLICE IN NEW NODE
+ MOVE D,VAL+1(B) ;GET POINTER TO NODE STRING
+ HRRM D,NODPNT(C) ;CLOBBER
+ HRLM B,NODPNT(C)
+ SKIPE D ;SPLICE ONLY IF THERE IS SOMETHING THERE
+ HRLM C,NODPNT(D)
+ MOVEM C,VAL+1(B) ;COMPLETE NODE CHAIN
+ MOVE A,2(AB) ;RETURN VALUE
+ MOVE B,3(AB)
+ JRST FINIS
+
+MAKNOD: PUSHJ P,NEWASO ;GENERATE THE NEW ASSOCIATION
+ MOVE A,@CHPT ;GET UNIQUE STRING
+ MOVEM A,INDIC(C) ;CLOBBER IN INDIC
+ MOVE A,@CHPT+1
+ MOVEM A,INDIC+1(C)
+ MOVE B,C ;POINTER TO B
+ HRRZ C,NODES+1 ;GET POINTER TO CHAIN OF NODES
+ HRRZ D,VAL+1(C) ;SKIP DUMMY NODE
+ HRRM B,VAL+1(C) ;CLOBBER INTO CHAIN
+ HRRM D,NODPNT(B)
+ SKIPE D ;SPLICE IF ONLY SOMETHING THERE
+ HRLM B,NODPNT(D)
+ HRLM C,NODPNT(B)
+ MOVSI A,TASOC ;SET TYPE OF VAL TO ASSOCIATION
+ MOVEM A,VAL(B)
+ SETZM VAL+1(B)
+ JRST NODSPL ;GO SPLICE ITEM ONTO NODE
+]
+
+DUMMAK: PUSH TP,A
+ PUSH TP,B
+ PUSH TP,C
+ PUSH TP,D
+ MOVEI A,ASOLNT
+ PUSHJ P,IBLOCK
+ MOVSI A,400000+SASOC+.VECT.
+ MOVEM A,ASOLNT(B) ;SET SPECIAL TYPE
+ MOVEM B,DUMNOD+1
+ POP TP,D
+ POP TP,C
+ POP TP,B
+ POP TP,A
+ POPJ P,
+
+CLOBTB: SETZ ITEM(B)
+ SETZ ITEM+1(B)
+ SETZ INDIC(B)
+ SETZ INDIC+1(B)
+ SETZ VAL(B)
+ SETZ VAL+1(B)
+
+MFUNCTION ASSOCIATIONS,SUBR
+
+ ENTRY 0
+ MOVE B,NODES+1
+ASSOC1: MOVSI A,TASOC ; SET TYPE
+ HRRZ B,NODPNT(B) ; POINT TO 1ST REAL NODE
+ JUMPE B,IFALSE
+ JRST FINIS
+
+; RETURN NEXT ASSOCIATION IN CHAIN OR FALSE
+
+MFUNCTION NEXT,SUBR
+
+ ENTRY 1
+
+ GETYP 0,(AB) ; BETTER BE ASSOC
+ CAIE 0,TASOC
+ JRST WTYP1 ; LOSE
+ MOVE B,1(AB) ; GET ARG
+ JRST ASSOC1
+
+; GET ITEM/INDICATOR/VALUE CELLS
+
+MFUNCTION %ITEM,SUBR,ITEM
+
+ MOVEI B,ITEM ; OFFSET
+ JRST GETIT
+
+MFUNCTION INDICATOR,SUBR
+
+ MOVEI B,INDIC
+ JRST GETIT
+
+MFUNCTION AVALUE,SUBR
+
+ MOVEI B,VAL
+GETIT: ENTRY 1
+ GETYP 0,(AB) ; BETTER BE ASSOC
+ CAIE 0,TASOC
+ JRST WTYP1
+ ADD B,1(AB) ; GET ARG
+ MOVE A,(B)
+ MOVE B,1(B)
+ JRST FINIS
+
+LHCLR: PUSH P,A
+ GETYP A,A
+ PUSHJ P,NWORDT ; DEFERRED ?
+ SOJE A,LHCLR2
+ POP P,A
+LHCLR1: TLZ A,TYPMSK#<-1>
+ POPJ P,
+LHCLR2: POP P,A
+ HLLZS A
+ JRST LHCLR1
+
+END
+\f
\ No newline at end of file
--- /dev/null
+
+TITLE .CORE
+
+RELOCATABLE
+
+.INSRT MUDDLE >
+
+.GLOBAL P.CORE,P.TOP,PHIBOT,PURBOT,FRETOP,SQKIL,GCFLG,KILBUF
+
+; .CORE AND .SUSET [.RMEMT,,---] FOR PAGED ENVIRONMENT
+
+P.CORE: PUSH P,0
+ PUSH P,A
+ PUSH P,B
+ PUSH P,C
+ PUSH P,D
+ PUSH P,E
+ SKIPN GCFLG
+ PUSHJ P,SQKIL
+ MOVE A,-4(P)
+ ASH A,10. ; CHECK IT
+ CAMLE A,PURBOT ; A CAML HERE IS OBSERVED TO LOSE
+ FATAL BAD ARG TO GET CORE
+ MOVE A,-4(P) ; RESTORE A
+ HRRZ B,P.TOP ; GET FIRST ADDRESS ABOVE TOP
+ ASH B,-10. ; TO BLOCKS
+ CAIG A,(B) ; SKIP IF GROWING
+ JRST P.COR1
+ SUBM B,A ; A/ -NUMBER OF BLOCKS TO GET
+ HRLI B,(A) ; AOBJN TO BLOCKS
+
+ .CALL P.CORU ; TRY
+ JRST POPBJ ; LOSE
+ MOVE A,B
+P.COR2: ASH B,10. ; TO WORDS
+ MOVEM B,P.TOP ; NEW TOP
+POPBJ1: AOS -6(P) ; SKIP RETURN ON SUCCESS
+POPBJ: POP P,E
+ POP P,D
+ POP P,C
+ POP P,B
+ POP P,A
+ POP P,0
+ POPJ P,
+
+; HERE TO CORE DOWN
+
+P.COR1: SUBM A,B
+ JUMPE B,POPBJ1 ; SUCCESS, YOU ALREADY HAVE WHAT YOU WANT
+ HRLI A,(B)
+ MOVEI B,(A)
+ .CALL P.CORD
+ JRST POPBJ
+ JRST P.COR2
+
+P.CORU: SETZ
+ SIXBIT /CORBLK/
+ 1000,,100000
+ 1000,,-1
+ B
+ 401000,,400001
+
+P.CORD: SETZ
+ SIXBIT /CORBLK/
+ 1000,,0
+ 1000,,-1
+ SETZ A
+
+
+IMPURE
+
+P.TOP==FRETOP
+
+PURE
+
+END
+\f\ 3\f\ 3
\ No newline at end of file
--- /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
+
+; 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
+ TLZE D,40 ; SKIP IF NOT ESCAPED
+ JRST INCHR2 ; ESCAPED
+ CAMN A,ESCAP(E) ; IF ESCAPE
+ TLO D,40 ; REMEMBER
+ 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
+ MOVEI B,DIRECT-1(D) ;AND ITS DIRECTION
+ PUSHJ P,CHRWRD
+ JFCL
+ CAME B,[ASCII /PRINT/]
+ JRST WRONGD
+
+ MOVE B,BUFRIN(A) ;GET A'S AUX BUFFER
+ 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: MOVEI B,DIRECT-1(A) ;GET DIRECTION
+ PUSHJ P,CHRWRD ; CONVERT
+ JFCL
+ CAME B,[ASCII /READ/]
+ JRST WRONGD
+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)
+ SETZM IMAGFL ; UNFORTUNATELY SFMOD CLOBBERS IMAGENESS
+ 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,
+ DOTCAL OPEN,[[1000,,TTYIN],[[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,[
+ SKIPN IMAGFL
+ JRST MTYI1
+ PUSH P,B
+ PUSHJ P,MTYO1
+ POP P,B
+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
+IFE ITS,[
+ SKIPE IMAGFL ;SKIP RE-OPENING IF ALREADY IN ASCII
+ PUSHJ P,MTYO1 ;WAS IN IMAGE...RE-OPEN
+]
+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,
+
+MTYO1: MOVE B,TTOCHN+1
+ PUSH P,0
+ PUSHJ P,REASCI
+ POP P,0
+ POPJ P,
+
+; HERE FOR TYO TO ANY TTY FLAVOR DEVICE
+
+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: ERRUUO EQUOTE NOT-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,
+
+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
+ PUSHJ P,INCHAR
+ 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,[
+ MOVE B,CHANNO(B)
+ EXCH A,B
+ MOVE 0,B
+ RFMOD
+ PUSH P,B
+ TRZ B,300
+ SFMOD
+ STPAR
+IMGIOT:
+ MOVE B,0
+ BOUT
+ POP P,B
+ SFMOD
+ STPAR
+ MOVE B,0
+]
+
+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
+
+
+IFE ITS,[
+OPNIMG: MOVE E,A ; SAVE CHAR
+ MOVE D,B
+ MOVE A,1(B) ;GET JFN OUT OF CHANNEL
+ RFMOD ;GET THE MAGIC BITS
+ TRZ B,302
+ SFMOD ; MAKE IMAGE AND PUT BITS IN CHANNEL
+ STPAR
+ MOVE B,E
+ HLLOS IOINS-1(D)
+ CAMN D,TTOCHN+1
+ SETOM IMAGFL
+ JRST IMGIOT ]
+
+DEVTOC: PUSH P,D
+ PUSH P,E
+ PUSH P,0
+ PUSH P,A
+ MOVE D,RDEVIC(B)
+ MOVE E,[220600,,C]
+ MOVEI A,3
+ MOVEI C,0
+ ILDB 0,D
+ SUBI 0,40
+ IDPB 0,E
+ SOJG A,.-3
+ POP P,A
+ POP P,0
+ POP P,E
+ POP P,D
+ POPJ P,
+
+IMGBLK: OUT+IMAGEM+UNIT,,(SIXBIT /TTY/)
+ 0
+ 0
+
+
+
+IMPURE
+IMAGFL: 0
+PURE
+
+
+END
+\f
\ No newline at end of file
--- /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
+
+; 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
+ TLZE D,40 ; SKIP IF NOT ESCAPED
+ JRST INCHR2 ; ESCAPED
+ CAMN A,ESCAP(E) ; IF ESCAPE
+ TLO D,40 ; REMEMBER
+ 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,
+ DOTCAL OPEN,[[1000,,TTYIN],[[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: ERRUUO EQUOTE NOT-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
+ PUSHJ P,INCHAR
+ 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 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
+
+; 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
+ TLZE D,40 ; SKIP IF NOT ESCAPED
+ JRST INCHR2 ; ESCAPED
+ CAMN A,ESCAP(E) ; IF ESCAPE
+ TLO D,40 ; REMEMBER
+ 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,
+ DOTCAL OPEN,[[1000,,TTYIN],[[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
+ PUSHJ P,INCHAR
+ 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 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
+
+; 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
+ TLZE D,40 ; SKIP IF NOT ESCAPED
+ JRST INCHR2 ; ESCAPED
+ CAMN A,ESCAP(E) ; IF ESCAPE
+ TLO D,40 ; REMEMBER
+ 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,
+ DOTCAL OPEN,[[1000,,TTYIN],[[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 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
+ TLZE C,N.ESC ; SKIP IF NOT ESCAPED
+ JRST INCHR2 ; ESCAPED
+ CAMN A,ESCAP(E) ; IF ESCAPE
+ TLO C,N.ESC ; REMEMBER
+ 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,
+ DOTCAL OPEN,[[1000,,TTYIN],[[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 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,
+ DOTCAL OPEN,[[1000,,TTYIN],[[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 READER FOR MUDDLE
+
+;C. REEVE DEC. 1970
+
+RELOCA
+
+READER==1 ;TELL MUDDLE > TO USE SOME SPECIAL HACKS
+FRMSIN==1 ;FLAG SAYING WHETHER OR "." AND "'" HACKS EXIST
+KILTV==1 ;FLAG SAYING THAT (TVP) SHOULD BE REMOVED (MUDDLE 54 ONLY)
+
+.INSRT MUDDLE >
+
+F==PVP
+G==TVP
+
+.GLOBAL CONS,VECTOR,NXTCHR,RLOOKU,CRADIX,SPTIME,QUOTE,CHMAK,FLUSCH,IGET
+.GLOBAL SETDEV,OPNCHN,ILVAL,RADX,IDVAL,LSTCH,EVECTOR,EUVECTOR,CHUNW,NONSPC
+.GLOBAL CHRWRD,EOFCND,DIRECT,ACCESS,IOINS,ROOT,DIRECT,DOIOTI,DOACCS,IGVAL,BYTDOP
+.GLOBAL ICONS,INCONS,IEVECT,IEUVEC,BUFSTR,TYPFND,SQUTOA,SQUKIL,IBLOCK,GRB
+.GLOBAL BADCHN,WRONGD,CHNCLS,FNFFL,IPUT,IGET,ILOC,RXCT,WXCT,IUNWIN,UNWIN2
+.GLOBAL CNXTCH,CREADC,MPOPJ,CREDC1,CNXTC1,IREMAS,CBYTES,PVSTOR,SPSTOR,DSTORE
+.GLOBAL SFIX
+.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
+
+BUFLNT==100
+
+FF=0 ;FALG REGISTER DURING NUMBER CONVERSION
+
+;FLAGS USED (RIGHT HALF)
+
+NOTNUM==1 ;NOT A NUMBER
+NFIRST==2 ;NOT FIRST CHARACTER BEING READ
+DECFRC==4 ;FORCE DECIMAL CONVERSION
+NEGF==10 ;NEGATE THIS THING
+NUMWIN==20 ;DIGIT(S) SEEN
+INSTRN==40 ;IN QUOTED CHARACTER STRING
+FLONUM==100 ;NUMBER IS FLOOATING POINT
+DOTSEN==200 ;. SEEN IN IMPUT STREAM
+EFLG==400 ;E SEEN FOR EXPONENT
+FRSDOT==1000 ;. CAME FIRST
+USEAGN==2000 ;SPECIAL DOT HACK
+
+OCTWIN==4000
+OCTSTR==10000
+OVFLEW==40000
+ENEG==100000
+EPOS==200000
+;TEMPORARY OFFSETS
+
+VCNT==0 ;NUMBER OF ELEMENTS IN CURRENT VECTOR
+ONUM==-4 ;CURRENT NUMBER IN OCTAL
+DNUM==-4 ;CURRENT NUMBER IN DECIMAL
+CNUM==-2 ;IN CURRENT RADIX
+NDIGS==0 ;NUMBER OF DIGITS
+ENUM==-2 ;EXPONENT
+NUMTMP==6
+
+; TABLE OF POWERS OF TEN
+
+TENTAB: REPEAT 39. 10.0^<.RPCNT-1>
+
+ITENTB: REPEAT 11. 10.^<.RPCNT-1>
+
+
+\f; TEXT FILE LOADING PROGRAM
+
+MFUNCTION MLOAD,SUBR,[LOAD]
+
+ ENTRY
+
+ HLRZ A,AB ;GET NO. OF ARGS
+ CAIE A,-4 ;IS IT 2
+ JRST TRY2 ;NO, TRY ANOTHER
+ GETYP A,2(AB) ;GET TYPE
+ CAIE A,TOBLS ;IS IT OBLIST
+ CAIN A,TLIST ; OR LIST THEREOF?
+ JRST CHECK1
+ JRST WTYP2
+
+TRY2: CAIE A,-2 ;IS ONE SUPPLIED
+ JRST WNA
+
+CHECK1: GETYP A,(AB) ;GET TYPE
+ CAIE A,TCHAN ;IS IT A CHANNEL
+ JRST WTYP1
+
+LOAD1: HLRZ A,TB ;GET CURRENT TIME
+ PUSH TP,$TTIME ;AND SAVE IT
+ PUSH TP,A
+
+ MOVEI C,CLSNGO ; LOCATION OF FUNNY CLOSER
+ PUSHJ P,IUNWIN ; SET UP AS UNWINDER
+
+LOAD2: PUSH TP,(AB) ;USE SUPPLIED CHANNEL
+ PUSH TP,1(AB)
+ PUSH TP,(TB) ;USE TIME AS EOF ARG
+ PUSH TP,1(TB)
+ CAML AB,C%M20 ; [-2,,0] ;CHECK FOR 2ND ARG
+ JRST LOAD3 ;NONE
+ PUSH TP,2(AB) ;PUSH ON 2ND ARG
+ PUSH TP,3(AB)
+ MCALL 3,READ
+ JRST CHKRET ;CHECK FOR EOF RET
+
+LOAD3: MCALL 2,READ
+CHKRET: CAMN A,(TB) ;IS TYPE EOF HACK
+ CAME B,1(TB) ;AND IS VALUE
+ JRST EVALIT ;NO, GO EVAL RESULT
+ PUSH TP,(AB)
+ PUSH TP,1(AB)
+ MCALL 1,FCLOSE
+ MOVE A,$TCHSTR
+ MOVE B,CHQUOTE DONE
+ JRST FINIS
+
+CLSNGO: PUSH TP,$TCHAN
+ PUSH TP,1(AB)
+ MCALL 1,FCLOSE
+ JRST UNWIN2 ; CONTINUE UNWINDING
+
+EVALIT: PUSH TP,A
+ PUSH TP,B
+ MCALL 1,EVAL
+ JRST LOAD2
+
+
+
+; OTHER FILE LOADING PROGRAM
+
+
+\f
+MFUNCTION FLOAD,SUBR
+
+ ENTRY
+
+ MOVEI C,1 ;INITIALIZE OPEN'S ARG COUNT
+ PUSH TP,$TAB ;SLOT FOR SAVED AB
+ PUSH TP,C%0 ; [0] ;EMPTY FOR NOW
+ PUSH TP,$TCHSTR ;PUT IN FIRST ARG
+ PUSH TP,CHQUOTE READB
+ MOVE A,AB ;COPY OF ARGUMENT POINTER
+
+FARGS: JUMPGE A,CALOPN ;DONE? IF SO CALL OPEN
+ GETYP B,(A) ;NO, CHECK TYPE OF THIS ARG
+ CAIE B,TOBLS ;OBLIST?
+ CAIN B,TLIST ; OR LIST THEREOF
+ JRST OBLSV ;YES, GO SAVE IT
+
+ PUSH TP,(A) ;SAVE THESE ARGS
+ PUSH TP,1(A)
+ ADD A,C%22 ; [2,,2] ;BUMP A
+ AOJA C,FARGS ;COUNT AND GO
+
+OBLSV: MOVEM A,1(TB) ;SAVE THE AB
+
+CALOPN: ACALL C,FOPEN ;OPEN THE FILE
+
+ JUMPGE B,FNFFL ;FILE MUST NO EXIST
+ EXCH A,(TB) ;PLACE CHANNEL ON STACK
+ EXCH B,1(TB) ;OBTAINING POSSIBLE OBLIST
+ JUMPN B,2ARGS ;OBLIST SUOPPLIED?
+
+ MCALL 1,MLOAD ;NO, JUST CALL
+ JRST FINIS
+
+
+2ARGS: PUSH TP,(B) ;PUSH THE OBLIST
+ PUSH TP,1(B)
+ MCALL 2,MLOAD
+ JRST FINIS
+
+
+FNFFL: PUSH TP,$TATOM
+ PUSH TP,EQUOTE FILE-SYSTEM-ERROR
+ JUMPE B,CALER1
+ PUSH TP,A
+ PUSH TP,B
+ MOVEI A,2
+ JRST CALER
+
+\fMFUNCTION READ,SUBR
+
+ ENTRY
+
+ PUSH P,[SETZ IREAD1] ;WHERE TO GO AFTER BINDING
+READ0: PUSH TP,$TTP ;SLOT FOR LAST THING READ (TYPE IS UNREADABLE)
+ PUSH TP,C%0
+ PUSH TP,$TFIX ;SLOT FOR RADIX
+ PUSH TP,C%0
+ PUSH TP,$TCHAN ;AND SLOT FOR CHANNEL
+ PUSH TP,C%0
+ PUSH TP,C%0 ; USER DISP SLOT
+ PUSH TP,C%0
+ PUSH TP,$TSPLICE
+ PUSH TP,C%0 ;SEGMENT FOR SPLICING MACROS
+ JUMPGE AB,READ1 ;NO ARGS, NO BINDING
+ GETYP C,(AB) ;ISOLATE TYPE
+ CAIN C,TUNBOU
+ JRST WTYP1
+ PUSH TP,[TATOM,,-1] ;PUSH THE ATOMS
+ PUSH TP,IMQUOTE INCHAN
+ PUSH TP,(AB) ;PUSH ARGS
+ PUSH TP,1(AB)
+ PUSH TP,C%0 ;DUMMY
+ PUSH TP,C%0
+ MOVE B,1(AB) ;GET CHANNEL POINTER
+ ADD AB,C%22 ;AND ARG POINTER
+ JUMPGE AB,BINDEM ;MORE?
+ PUSH TP,[TVEC,,-1]
+ ADD B,[EOFCND-1,,EOFCND-1]
+ PUSH TP,B
+ PUSH TP,(AB)
+ PUSH TP,1(AB)
+ ADD AB,C%22
+ JUMPGE AB,BINDEM ;IF ANY MORE ARGS GO PROCESS AND BIND THEM
+ GETYP C,(AB) ;ISOLATE TYPE
+ CAIE C,TLIST
+ CAIN C,TOBLS
+ SKIPA
+ JRST WTYP3
+ PUSH TP,[TATOM,,-1] ;PUSH THE ATOMS
+ PUSH TP,IMQUOTE OBLIST
+ PUSH TP,(AB) ;PUSH ARGS
+ PUSH TP,1(AB)
+ PUSH TP,C%0 ;DUMMY
+ PUSH TP,C%0
+ ADD AB,C%22 ;AND ARG POINTER
+ JUMPGE AB,BINDEM ; ALL DONE, BIND ATOMS
+ GETYP 0,(AB) ; GET TYPE OF TABLE
+ CAIE 0,TVEC ; SKIP IF BAD TYPE
+ JRST WTYP ; ELSE COMPLAIN
+ PUSH TP,[TATOM,,-1]
+ PUSH TP,IMQUOTE READ-TABLE
+ PUSH TP,(AB)
+ PUSH TP,1(AB)
+ PUSH TP,C%0
+ PUSH TP,C%0
+ ADD AB,C%22 ; BUMP TO NEXT ARG
+ JUMPL AB,TMA ;MORE ?, ERROR
+BINDEM: PUSHJ P,SPECBIND
+ JRST READ1
+
+MFUNCTION RREADC,SUBR,READCHR
+
+ ENTRY
+ PUSH P,[SETZ IREADC]
+ JRST READC0 ;GO BIND VARIABLES
+
+MFUNCTION NXTRDC,SUBR,NEXTCHR
+
+ ENTRY
+
+ PUSH P,[SETZ INXTRD]
+READC0: CAMGE AB,C%M40 ; [-5,,]
+ JRST TMA
+ PUSH TP,(AB)
+ PUSH TP,1(AB)
+ JUMPL AB,READC1
+ MOVE B,IMQUOTE INCHAN
+ PUSHJ P,IDVAL
+ GETYP 0,A
+ CAIE 0,TCHAN
+ JRST BADCHN
+ MOVEM A,-1(TP)
+ MOVEM B,(TP)
+READC1: PUSHJ P,@(P)
+ JRST .+2
+ JRST FINIS
+
+ PUSH TP,-1(TP)
+ PUSH TP,-1(TP)
+ MCALL 1,FCLOSE
+ MOVE A,EOFCND-1(B)
+ MOVE B,EOFCND(B)
+ CAML AB,C%M20 ; [-3,,]
+ JRST .+3
+ MOVE A,2(AB)
+ MOVE B,3(AB)
+ PUSH TP,A
+ PUSH TP,B
+ MCALL 1,EVAL
+ JRST FINIS
+
+
+MFUNCTION PARSE,SUBR
+
+ ENTRY
+
+ PUSHJ P,GAPRS ;GET ARGS FOR PARSES
+ PUSHJ P,GPT ;GET THE PARSE TABLE
+ PUSHJ P,NXTCH ; GET A CHAR TO TEST FOR ! ALT
+ SKIPN 11.(TB) ; EOF HIT, COMPLAIN TO LOOSER
+ JRST NOPRS
+ MOVEI A,33 ; CHANGE IT TO AN ALT, SNEAKY HUH?
+ CAIN B,MANYT ; TYPE OF MULTIPLE CLOSE, I.E. ! ALT
+ MOVEM A,5(TB)
+ PUSHJ P,IREAD1 ;GO DO THE READING
+ JRST .+2
+ JRST LPSRET ;PROPER EXIT
+NOPRS: ERRUUO EQUOTE CAN'T-PARSE
+
+MFUNCTION LPARSE,SUBR
+
+ ENTRY
+
+ PUSHJ P,GAPRS ;GET THE ARGS TO THE PARSE
+ JRST LPRS1
+
+GAPRS: PUSH TP,$TTP
+ PUSH TP,C%0
+ PUSH TP,$TFIX
+ PUSH TP,[10.]
+ PUSH TP,$TFIX
+ PUSH TP,C%0 ; LETTER SAVE
+ PUSH TP,C%0
+ PUSH TP,C%0 ; PARSE TABLE MAYBE?
+ PUSH TP,$TSPLICE
+ PUSH TP,C%0 ;SEGMENT FOR SPLICING MACROS
+ PUSH TP,C%0 ;SLOT FOR LOCATIVE TO STRING
+ PUSH TP,C%0
+ JUMPGE AB,USPSTR
+ PUSH TP,[TATOM,,-1]
+ PUSH TP,IMQUOTE PARSE-STRING
+ PUSH TP,(AB)
+ PUSH TP,1(AB) ; BIND OLD PARSE-STRING
+ PUSH TP,C%0
+ PUSH TP,C%0
+ PUSHJ P,SPECBIND
+ ADD AB,C%22
+ JUMPGE AB,USPSTR
+ GETYP 0,(AB)
+ CAIE 0,TFIX
+ JRST WTYP2
+ MOVE 0,1(AB)
+ MOVEM 0,3(TB)
+ ADD AB,C%22
+ JUMPGE AB,USPSTR
+ GETYP 0,(AB)
+ CAIE 0,TLIST
+ CAIN 0,TOBLS
+ SKIPA
+ JRST WTYP3
+ PUSH TP,[TATOM,,-1]
+ PUSH TP,IMQUOTE OBLIST
+ PUSH TP,(AB)
+ PUSH TP,1(AB) ; HE WANTS HIS OWN OBLIST
+ PUSH TP,C%0
+ PUSH TP,C%0
+ PUSHJ P,SPECBIND
+ ADD AB,C%22
+ JUMPGE AB,USPSTR
+ GETYP 0,(AB)
+ CAIE 0,TVEC
+ JRST WTYP
+ PUSH TP,[TATOM,,-1]
+ PUSH TP,IMQUOTE PARSE-TABLE
+ PUSH TP,(AB)
+ PUSH TP,1(AB)
+ PUSH TP,C%0
+ PUSH TP,C%0
+ PUSHJ P,SPECBIND
+ ADD AB,C%22
+ JUMPGE AB,USPSTR
+ GETYP 0,(AB)
+ CAIE 0,TCHRS
+ JRST WTYP
+ MOVE 0,1(AB)
+ MOVEM 0,5(TB) ; STUFF IN A LOOK-AHEAD CHARACTER IF HE WANTS
+ ADD AB,C%22
+ JUMPL AB,TMA
+USPSTR: MOVE B,IMQUOTE PARSE-STRING
+ PUSHJ P,ILOC ; GET A LOCATIVE TO THE STRING, WHEREVER
+ GETYP 0,A
+ CAIN 0,TUNBOUND ; NONEXISTANT
+ JRST BDPSTR
+ GETYP 0,(B) ; IT IS POINTING TO A STRING
+ CAIE 0,TCHSTR
+ JRST BDPSTR
+ MOVEM A,10.(TB)
+ MOVEM B,11.(TB)
+ POPJ P,
+
+LPRS1: PUSHJ P,GPT ; GET THE VALUE OF PARSE-TABLE IN SLOT
+ PUSH TP,$TLIST
+ PUSH TP,C%0 ; HERE WE ARE MAKE PLACE TO SAVE GOODIES
+ PUSH TP,$TLIST
+ PUSH TP,C%0
+LPRS2: PUSHJ P,IREAD1
+ JRST LPRSDN ; IF WE ARE DONE, WE ARE THROUGH
+ MOVE C,A
+ MOVE D,B
+ PUSHJ P,INCONS
+ SKIPN -2(TP)
+ MOVEM B,-2(TP) ; SAVE THE BEGINNING ON FIRST
+ SKIPE C,(TP)
+ HRRM B,(C) ; PUTREST INTO IT
+ MOVEM B,(TP)
+ JRST LPRS2
+LPRSDN: MOVSI A,TLIST
+ MOVE B,-2(TP)
+LPSRET: SKIPLE C,5(TB) ; EXIT FOR PARSE AND LPARSE
+ CAIN C,400033 ; SEE IF NO PEEK AHEAD OR IF ! ALTMODE
+ JRST FINIS ; IF SO NO NEED TO BACK STRING ONE
+ SKIPN C,11.(TB)
+ JRST FINIS ; IF ATE WHOLE STRING, DONT GIVE BACK ANY
+BUPRS: MOVEI D,1
+ ADDM D,(C) ; AOS THE COUNT OF STRING LENGTH
+ SKIPG D,1(C) ; SEXIER THAN CLR'S CODE FOR DECREMENTING
+ SUB D,[430000,,1] ; A BYTE POINTER
+ ADD D,[70000,,0]
+ MOVEM D,1(C)
+ HRRZ E,2(TB)
+ JUMPE E,FINIS ; SEE IF WE NEED TO BACK UP TWO
+ HLLZS 2(TB) ; CLEAR OUT DOUBLE CHR LOOKY FLAG
+ JRST BUPRS ; AND BACK UP PARSE STRING A LITTLE MORE
+
+\f; ARGUMENTS ARE BOUND, NOW GET THE VALUES OF THINGS
+
+
+GRT: MOVE B,IMQUOTE READ-TABLE
+ SKIPA ; HERE TO GET TABLE FOR READ
+GPT: MOVE B,IMQUOTE PARSE-TABLE
+ MOVSI A,TATOM ; TO FILL SLOT WITH PARSE TABLE
+ PUSHJ P,ILVAL
+ GETYP 0,A
+ CAIN 0,TUNBOUND
+ POPJ P,
+ CAIE 0,TVEC
+ JRST BADPTB
+ MOVEM A,6(TB)
+ MOVEM B,7(TB)
+ POPJ P,
+
+READ1: PUSHJ P,GRT
+ MOVE B,IMQUOTE INCHAN
+ MOVSI A,TATOM
+ PUSHJ P,IDVAL ;NOW GOBBLE THE REAL CHANNEL
+ TLZ A,TYPMSK#777777
+ HLLZS A ; INCASE OF FUNNY BUG
+ CAME A,$TCHAN ;IS IT A CHANNEL
+ JRST BADCHN
+ MOVEM A,4(TB) ; STORE CHANNEL
+ MOVEM B,5(TB)
+ HRRZ A,-2(B)
+ TRNN A,C.OPN
+ JRST CHNCLS
+ TRNN A,C.READ
+ JRST WRONGD
+ HLLOS 4(TB)
+ TRNE A,C.BIN ; SKIP IF NOT BIN
+ JRST BREAD ; CHECK FOR BUFFER
+ HLLZS 4(TB)
+GETIOA: MOVE B,5(TB)
+GETIO: MOVE A,IOINS(B) ;GOBBLE THE I/O INSTRUCTION
+ JUMPE A,OPNFIL ;GO REALLY OPEN THE CROCK
+ MOVE A,RADX(B) ;GET RADIX
+ MOVEM A,3(TB)
+ MOVEM B,5(TB) ;SAVE CHANNEL
+REREAD: HRRZ D,LSTCH(B) ;ANY CHARS AROUND?
+ MOVEI 0,33
+ CAIN D,400033 ;FLUSH THE TERMINATOR HACK
+ HRRM 0,LSTCH(B) ; MAKE ! ALT INTO JUST ALT IF IT IS STILL AROUND
+
+ PUSHJ P,@(P) ;CALL INTERNAL READER
+ JRST BADTRM ;LOST
+RFINIS: SUB P,C%11 ;POP OFF LOSER
+ PUSH TP,A
+ PUSH TP,B
+ JUMPE C,FLSCOM ; FLUSH TOP LEVEL COMMENT
+ PUSH TP,C
+ PUSH TP,D
+ MOVE A,4(TB)
+ MOVE B,5(TB) ; GET CHANNEL
+ MOVSI C,TATOM
+ MOVE D,IMQUOTE COMMENT
+ PUSHJ P,IPUT
+RFINI1: POP TP,B
+ POP TP,A
+ JRST FINIS
+
+FLSCOM: MOVE A,4(TB)
+ MOVE B,5(TB)
+ MOVSI C,TATOM
+ MOVE D,IMQUOTE COMMENT
+ PUSHJ P,IREMAS
+ JRST RFINI1
+
+BADTRM: MOVE C,5(TB) ; GET CHANNEL
+ JUMPGE B,CHLSTC ;NO, MUST BE UNMATCHED PARENS
+ SETZM LSTCH(C) ; DONT REUSE EOF CHR
+ PUSH TP,4(TB) ;CLOSE THE CHANNEL
+ PUSH TP,5(TB)
+ MCALL 1,FCLOSE
+ PUSH TP,EOFCND-1(B)
+ PUSH TP,EOFCND(B)
+ MCALL 1,EVAL ;AND EVAL IT
+ SETZB C,D
+ GETYP 0,A ; CHECK FOR FUNNY ACT
+ CAIE 0,TREADA
+ JRST RFINIS ; AND RETURN
+
+ PUSHJ P,CHUNW ; UNWIND TO POINT
+ MOVSI A,TREADA ; SEND MESSAGE BACK
+ JRST CONTIN
+
+;HERE TO ATTEMPT TO OPEN A CLOSED CHANNEL
+
+OPNFIL: PUSHJ P,OPNCHN ;GO DO THE OPEN
+ JUMPGE B,FNFFL ;LOSE IC B IS 0
+ JRST GETIO
+
+
+CHLSTC: MOVE B,5(TB) ;GET CHANNEL BACK
+ JRST REREAD
+
+
+BREAD: MOVE B,5(TB) ; GET CHANNEL
+ SKIPE BUFSTR(B)
+ JRST GETIO
+ MOVEI A,BUFLNT ; GET A BUFFER
+ PUSHJ P,IBLOCK
+ MOVEI C,BUFLNT(B) ; POINT TO END
+ HRLI C,440700
+ MOVE B,5(TB) ; CHANNEL BACK
+ MOVEI 0,C.BUF
+ IORM 0,-2(B)
+ MOVEM C,BUFSTR(B)
+ MOVSI C,TCHSTR+.VECT.
+ MOVEM C,BUFSTR-1(B)
+ JRST GETIO
+\f;MAIN ENTRY TO READER
+
+NIREAD: PUSHJ P,LSTCHR
+NIREA1: PUSH P,C%M1 ; [-1] ; DONT GOBBLE COMMENTS
+ JRST IREAD2
+
+IREAD:
+ PUSHJ P,LSTCHR ;DON'T REREAD LAST CHARACTER
+IREAD1: PUSH P,C%0 ; FLAG SAYING SNARF COMMENTS
+IREAD2: INTGO
+BDLP: SKIPE C,9.(TB) ;HAVE WE GOT A SPLICING MACRO LEFT
+ JRST SPLMAC ;IF SO GIVE HIM SOME OF IT
+ PUSHJ P,NXTCH ;GOBBLE CHAR IN A AND TYPE IN D
+ MOVMS B ; FOR SPECIAL NEG HACK OF MACRO TABLES
+ CAIG B,ENTYPE
+ JUMPN B,@DTBL-1(B) ;ERROR ON ZERO TYPE OR FUNNY TYPE
+ JRST BADCHR
+
+
+SPLMAC: HRRZ D,(C) ;GET THE REST OF THE SEGMENT
+ MOVEM D,9.(TB) ;AND PUT BACK IN PLACE
+ GETYP D,(C) ;SEE IF DEFERMENT NEEDED
+ CAIN D,TDEFER
+ MOVE C,1(C) ;IF SO, DO DEFEREMENT
+ MOVE A,(C)
+ MOVE B,1(C) ;GET THE GOODIE
+ AOS -1(P) ;ALWAYS A SKIP RETURN
+ POP P,(P) ;DONT WORRY ABOUT COMMENT SEARCHAGE
+ SETZB C,D ;MAKE SURE HE DOESNT THINK WE GOT COMMENT
+ POPJ P, ;GIVE HIM WHAT HE DESERVES
+
+DTBL:
+CODINI==0
+IRP A,,[[LETCOD,LETTER],[NUMCOD,NUMBER],[PLUCOD,PNUMBE],[NEGCOD,NNUMBE],[ASTCOD,ASTSTR],[DOTTYP,DOTSTR],[ETYPE,LETTER]
+[SPATYP,SPACE],[LPATYP,LPAREN],[RPATYP,RPAREN],[LBRTYP,LBRACK],[RBRTYP,RBRACK]
+[QUOTYP,QUOTIT],[MACTYP,MACCAL],[CSTYP,CSTRING],[ESCTYP,ESCSTR],[SPCTYP,SPECTY]
+[SLMNT,OPNANG],[CNGTYP,CLSANG],[EOFTYP,EOFCHR],[COMTYP,COMNT],[GLMNT,GLOVAL]
+[TMPTYP,ILLSQG],[NTYPES,CLSBRA],[EXCEXC,LETTER],[DOTEXT,SEGDOT],[LBREXT,UVECIN]
+[RBREXT,RBRACK],[QUOEXT,QUOSEG],[CSEXT,SINCHR],[SLMEXT,SEGIN],[ELMEXT,CLSANG]
+[GLMEXT,GLOSEG],[PATHTY,LOSPATH],[BSLEXT,SINCHR],[MANYT,TERM],[USTYP1,USRDS1]
+[USTYP2,USRDS2]]
+
+ IRP B,C,[A]
+ CODINI==CODINI+1
+ B==CODINI
+ SETZ C
+ .ISTOP
+ TERMIN
+TERMIN
+
+EXPUNGE CODINI
+
+ENTYPE==.-DTBL
+
+NONSPC==ETYPE
+
+SPACE: PUSHJ P,LSTCHR ;DONT REREAD SPACER
+ JRST BDLP
+
+USRDS1: SKIPA B,A ; GET CHAR IN B
+USRDS2: MOVEI B,200(A) ; ! CHAR, DISP 200 FURTHER
+ ASH B,1
+ ADD B,7(TB) ; POINT TO TABLE ENTRY
+ GETYP 0,(B)
+ CAIN 0,TLIST
+ MOVE B,1(B) ; IF LIST, USE FIRST ITEM-SPECIAL NO BREAK HACK
+ SKIPL C,5(TB) ; GET CHANNEL POINTER (IF ANY)
+ JRST USRDS3
+ ADD C,[EOFCND-1,,EOFCND-1]
+ PUSH TP,$TBVL
+ MOVE SP,SPSTOR+1
+ HRRM SP,(TP) ; BUILD A TBVL
+ MOVE SP,TP
+ MOVEM SP,SPSTOR+1
+ PUSH TP,C
+ PUSH TP,(C)
+ PUSH TP,1(C)
+ MOVE PVP,PVSTOR+1
+ MOVEI D,PVLNT*2+1(PVP)
+ HRLI D,TREADA
+ MOVEM D,(C)
+ MOVEI D,(TB)
+ HLL D,OTBSAV(TB)
+ MOVEM D,1(C)
+USRDS3: PUSH TP,(B) ; APPLIER
+ PUSH TP,1(B)
+ PUSH TP,$TCHRS ; APPLY TO CHARACTER
+ PUSH TP,A
+ PUSHJ P,LSTCHR ; FLUSH CHAR
+ MCALL 2,APPLY ; GO TO USER GOODIE
+ SKIPL 5(TB)
+ JRST USRDS9
+ MOVE SP,SPSTOR+1
+ HRRZ E,1(SP) ; POINT TO EOFCND SLOT
+ HRRZ SP,(SP) ; UNBIND MANUALLY
+ MOVEI D,(TP)
+ SUBI D,(SP)
+ MOVSI D,(D)
+ HLL SP,TP
+ SUB SP,D
+ MOVEM SP,SPSTOR+1
+ POP TP,1(E)
+ POP TP,(E)
+ SUB TP,C%22 ; FLUSH TP CRAP
+USRDS9: GETYP 0,A ; CHECK FOR DISMISS?
+ CAIN 0,TSPLICE
+ JRST GOTSPL ; RETURN OF SEGMENT INDICATES SPLICAGE
+ CAIN 0,TREADA ; FUNNY?
+ JRST DOEOF
+ CAIE 0,TDISMI
+ JRST RET ; NO, RETURN FROM IREAD
+ JRST BDLP ; YES, IGNORE RETURN
+
+GOTSPL: MOVEM B,9.(TB) ; STICK IN THE SPLICAGE SLOT SO IREADS WILL GET HIM
+ JRST BDLP ; GO BACK AND READ FROM OUR SPLICE, OK?
+
+\f
+;HERE ON NUMBER OR LETTER, START ATOM
+
+ESCSTR: PUSHJ P,NXTC1 ; ESCAPE FIRST
+LETTER: MOVEI FF,NOTNUM ; LETTER
+ JRST ATMBLD
+
+ASTSTR: MOVEI FF,OCTSTR
+DOTST1: MOVEI B,0
+ JRST NUMBLD
+
+NUMBER: MOVEI FF,NUMWIN ; SYMBOL OR NUMBER
+NUMBR1: MOVEI B,(A) ; TO A NUMBER
+ SUBI B,60
+ JRST NUMBLD
+
+PNUMBE: SETZB FF,B
+ JRST NUMBLD
+
+NNUMBE: MOVEI FF,NEGF
+ MOVEI B,0
+
+NUMBLD: PUSH TP,$TFIX
+ PUSH TP,B
+ PUSH TP,$TFIX
+ PUSH TP,B
+ PUSH TP,$TFIX
+ PUSH TP,C%0
+
+ATMBLD: LSH A,<36.-7>
+ PUSH P,A
+ MOVEI D,1 ; D IS CHAR COUNT
+ MOVSI C,350700+P ; BYTE PNTR
+ PUSHJ P,LSTCHR
+
+ATLP: PUSH P,FF
+ INTGO
+
+ PUSHJ P,NXTCH ; GET NEXT CHAR
+ POP P,FF
+ TRNN FF,NOTNUM ; IF NOT NUMBER, SKIP
+ JRST NUMCHK
+
+ATLP2: CAILE B,NONSPC ; SKIP IF STILL LETTER OR NUMBER
+ JRST CHKEND
+
+ATLP1: PUSHJ P,LSTCHR ; DONT REUSE
+ IDPB A,C ; INTO ATOM
+ TLNE C,760000 ; SKIP IF OK WORD
+ AOJA D,ATLP
+
+ PUSH P,C%0
+ MOVSI C,440700+P
+ AOJA D,ATLP
+
+CHKEND: CAIN B,ESCTYP ; ESCAPE?
+ JRST DOESC1
+
+CHKEN1: SKIPGE C ; SKIP IF TOP SLOT FULL
+ SUB P,C%11
+ PUSH P,D ; COUNT OF CHARS
+
+ JRST LOOPA ; GO HACK TRAILERS
+
+
+; HERE IF STILL COULD BE A NUMBER
+
+NUMCHK: CAIN B,NUMCOD ; STILL NUMBER
+ JRST NUMCH1
+
+ CAILE B,NONSPC ; NUMBER FINISHED?
+ JRST NUMCNV
+
+ CAIN B,DOTTYP
+ TROE FF,DOTSEN
+ JRST NUMCH2
+ TRNE FF,OCTSTR+EFLG
+ JRST NUMCH3 ; NO . IN OCTAL OR EXPONENT
+ TRO FF,DECFRC ; MUST BE DECIMAL NOW
+ JRST ATLP1
+
+NUMCH1: TRO FF,NUMWIN
+ MOVEI B,(A)
+ SUBI B,60
+ TRNE FF,OCTSTR+OCTWIN ; IS THIS *DDDDDD* HACK
+ JRST NUMCH4 ; YES, GO DO IT
+ TRNE FF,EFLG
+ JRST NUMCH7 ; DO EXPONENT
+
+ TRNE FF,DOTSEN ; FORCE FLOAT
+ JRST NUMCH5
+
+ JFCL 17,.+1 ; KILL ALL FLAGS
+ MOVE E,CNUM(TP) ; COMPUTE CURRENT RADIX
+ IMUL E,3(TB)
+ ADDI E,(B) ; ADD IN CURRENT DIGIT
+ JFCL 10,.+3
+ MOVEM E,CNUM(TP)
+ JRST NUMCH6
+
+ MOVE E,3(TB) ; SEE IF CURRENT RADIX DECIMAL
+ CAIE E,10.
+ JRST NUMCH5 ; YES, FORCE FLOAT
+ TROA FF,OVFLEW
+
+NUMCH5: TRO FF,FLONUM ; SET FLOATING FLAG
+NUMCH6: JFCL 17,.+1 ; CLEAR ALL FLAGS
+ MOVE E,DNUM(TP) ; GET DECIMAL NUMBER
+ IMULI E,10.
+ JFCL 10,NUMCH8 ; JUMP IF OVERFLOW
+ ADDI E,(B) ; ADD IN DIGIT
+ MOVEM E,DNUM(TP)
+ TRNE FF,FLONUM ; IS THIS FRACTION?
+ SOS NDIGS(TP) ; YES, DECREASE EXPONENT BY ONE
+ JRST ATLP1
+
+NUMCH8: TRNE FF,DOTSEN ; OVERFLOW IN DECMIMAL
+ JRST ATLP1 ; OK, IN FRACTION
+
+ AOS NDIGS(TP)
+ TRO FF,FLONUM ; MAKE IT FLOATING TO FIT
+ JRST ATLP1
+
+NUMCH4: TRNE FF,OCTWIN
+ JRST NUMCH3 ; ALREADY ONE, MORE DIGITS LOSE
+ MOVE E,ONUM(TP)
+ TLNE E,700000 ; SKIP IF WORD NOT FULL
+ TRO FF,OVFLEW
+ LSH E,3
+ ADDI E,(B) ; ADD IN NEW ONE
+ MOVEM E,ONUM(TP)
+ JRST ATLP1
+
+NUMCH3: SUB TP,[NUMTMP,,NUMTMP] ; FLUSH NUMBER CRUFT
+ TRO FF,NOTNUM
+ JRST ATLP2
+
+NUMCH2: CAIN B,ASTCOD ; POSSIBLE END OF OCTAL
+ TRZN FF,OCTSTR ; RESET FLAG AND WIN
+ JRST NUMCH9
+
+ TRO FF,OCTWIN
+ JRST ATLP2
+
+NUMCH9: CAIN B,ETYPE
+ TROE FF,EFLG
+ JRST NUMC10 ; STILL COULD BE +- EXPONENT
+
+ TRZ FF,NUMWIN ; IN CASE NO MORE DIGITS
+ SETZM ENUM(TP)
+ JRST ATLP1
+
+NUMCH7: MOVE E,ENUM(TP)
+ IMULI E,10.
+ ADDI E,(B)
+ MOVEM E,ENUM(TP) ; UPDATE ECPONENT
+ TRO FF,EPOS ; FLUSH IF SIGN COMES NOW
+ JRST ATLP1
+
+NUMC10: TRNE FF,ENEG+EPOS ; SIGN FOR EXPONENT SEEN?
+ JRST NUMCH3 ; NOT A NUMBER
+ CAIN B,PLUCOD
+ TRO FF,EPOS
+ CAIN B,NEGCOD
+ TRO FF,ENEG
+ TRNE FF,EPOS+ENEG
+ JRST ATLP1
+ JRST NUMCH3
+
+; HERE AFTER \ QUOTER
+
+DOESC1: PUSHJ P,NXTC1 ; GET CHAR
+ JRST ATLP1 ; FALL BACK INTO LOOP
+
+
+; HERE TO CONVERT NUMBERS AS NEEDED
+
+NUMCNV: CAIE B,ESCTYP
+ TRNE FF,OCTSTR
+ JRST NUMCH3
+ TRNN FF,NUMWIN
+ JRST NUMCH3
+ ADDI D,4
+ IDIVI D,5
+ SKIPGE C ; SKIP IF NEW WORD ADDED
+ ADDI D,1
+ HRLI D,(D) ; TOO BOTH HALVES
+ SUB P,D ; REMOVE CHAR STRING
+ MOVE D,3(TB) ; IS RADIX 10?
+ CAIE D,10.
+ TRNE FF,DECFRC
+ TRNN FF,FLONUM+EFLG ;IS IT A FLOATING POINT NUMBER
+ TRNE FF,EFLG
+ JRST FLOATIT ;YES, GO MAKE IT WIN
+ TRNE FF,OVFLEW
+ JRST FOOR
+ MOVE B,CNUM(TP)
+ TRNE FF,DECFRC
+ MOVE B,DNUM(TP) ;GRAB FIXED GOODIE
+ TRNE FF,OCTWIN ; SKIP IF NOT OCTAL
+ MOVE B,ONUM(TP) ; USE OCTAL VALUE
+FINID2: MOVSI A,TFIX ;SAY FIXED POINT
+FINID1: TRNE FF,NEGF ;NEGATE
+ MOVNS B ;YES
+ SUB TP,[NUMTMP,,NUMTMP] ;FINISH HACK
+ JRST RET ;AND RETURN
+
+\f
+FLOATIT:
+ JFCL 17,.+1 ;CLEAR ALL ARITHMETIC FLAGS
+ TRNE FF,EFLG ;"E" SEEN?
+ JRST EXPDO ;YES, DO EXPONENT
+ MOVE D,NDIGS(TP) ;GET IMPLICIT EXPONENT
+
+FLOATE: MOVE A,DNUM(TP) ;GET DECIMAL NUMBER
+ IDIVI A,400000 ;SPLIT
+ FSC A,254 ;CONVERT MOST SIGNIFICANT
+ FSC B,233 ; AND LEAST SIGNIFICANT
+ FADR B,A ;COMBINE
+
+ MOVM A,D ;GET MAGNITUDE OF EXPONENT
+ MOVSI E,(1.0)
+ JFCL 17,.+1 ; CLEAR ALL OVERFLOW/UNDERFLOW BITS
+ CAIG A,38. ;HOW BIG?
+ JRST .+3 ;TOO BIG-FLOATING OUT OF RANGE
+ MOVE E,[1.0^38.]
+ SUBI A,38.
+ JUMPGE D,FLOAT1 ;JUMP IF EXPONENT POSITIVE
+ FDVR B,E
+ FDVR B,TENTAB(A) ;DIVIDE BY TEN TO THE EXPONENT
+ JRST SETFLO
+
+FLOAT1: FMPR B,E
+ FMPR B,TENTAB(A) ;SCALE UP
+
+SETFLO: JFCL 17,FOOR ;FLOATING OUT OF RANGE ON OVERFLOW
+ MOVSI A,TFLOAT
+ TRZ FF,FRSDOT ;FLOATING NUMBER NOT VALUE
+ JRST FINID1
+
+EXPDO:
+ HRRZ D,ENUM(TP) ;GET EXPONENT
+ TRNE FF,ENEG ;IS EXPONENT NEGATIVE?
+ MOVNS D ;YES
+ ADD D,NDIGS(TP) ;ADD IMPLICIT EXPONENT
+ JUMPL D,FLOATE ;FLOATING IF EXPONENT NEGATIVE
+ CAIG D,10. ;OR IF EXPONENT TOO LARGE
+ TRNE FF,FLONUM ;OR IF FLAG SET
+ JRST FLOATE
+ MOVE B,DNUM(TP) ;
+ IMUL B,ITENTB(D)
+ JFCL 10,FLOATE ;IF OVERFLOW, MAKE FLOATING
+ JRST FINID2 ;GO MAKE FIXED NUMBER
+
+
+; HERE TO START BUILDING A CHARACTER STRING GOODIE
+
+CSTRING:
+ PUSH P,C%0
+ MOVEI D,0 ; CHARCOUNT
+ MOVSI C,440700+P ; AND BYTE POINTER
+
+CSLP: PUSH P,FF
+ INTGO
+ PUSHJ P,NXTC1 ; GET NEXT CHAR
+ POP P,FF
+
+ CAIN B,CSTYP ; END OF STRING?
+ JRST CSLPEND
+
+ CAIN B,ESCTYP ; ESCAPE?
+ PUSHJ P,NXTC1
+
+ IDPB A,C ; INTO ATOM
+ TLNE C,760000 ; SKIP IF OK WORD
+ AOJA D,CSLP
+
+ PUSH P,C%0
+ MOVSI C,440700+P
+ AOJA D,CSLP
+
+CSLPEND:
+ SKIPGE C
+ SUB P,C%11
+ PUSH P,D
+ PUSHJ P,CHMAK
+ PUSHJ P,LSTCHR
+
+ JRST RET
+
+;ARRIVE HERE TO INVOKE A READ TIME MACRO FUNCTION
+
+MACCAL: PUSHJ P,NXTCH1 ;READ ONE MORE CHARACTER
+ CAIE B,MACTYP ;IS IT ANOTHER MACRO CHAR
+
+ JRST MACAL2 ;NO, CALL MACRO AND USE VALUE
+ PUSHJ P,LSTCHR ;DONT REREAD %
+ PUSHJ P,MACAL1 ;OTHERWISE, USE SIDE EFFECCT, BUT NOT VALUE
+ JRST IREAD2
+
+MACAL2: PUSH P,CRET
+MACAL1: PUSHJ P,IREAD1 ;READ FUNCTION NAME
+ PUSHJ P,RETERR
+ PUSH TP,C
+ PUSH TP,D ; SAVE COMMENT IF ANY
+ PUSH TP,A ;SAVE THE RESULT
+ PUSH TP,B ;AND USE IT AS AN ARGUMENT
+ MCALL 1,EVAL
+ POP TP,D
+ POP TP,C ; RESTORE COMMENT IF ANY...
+CRET: POPJ P,RET12
+
+;CALL GOBBLE TO FIND THE TYPE AND THEN IREAD TO READ IT
+
+SPECTY: PUSHJ P,NIREAD ; READ THE TYPES NAME (SHOULD BE AN ATOM)
+ PUSHJ P,RETERR
+ PUSH TP,A
+ PUSH TP,B
+ GETYP A,A
+ CAIN A,TFIX
+ JRST BYTIN
+ PUSHJ P,NXTCH ; GET NEXT CHAR
+ CAIN B,TMPTYP ; SKIP IF NOT TEMPLATE START
+ JRST RDTMPL
+ SETZB A,B
+ EXCH A,-1(TP)
+ EXCH B,(TP)
+ PUSH TP,A ;BEGIN SETTING UP CHTYPE CALL
+ PUSH TP,B
+ PUSHJ P,IREAD1 ;NOW READ STRUCTURE
+ PUSHJ P,RETERR
+ MOVEM C,-3(TP) ; SAVE COMMENT
+ MOVEM D,-2(TP)
+ EXCH A,-1(TP) ;USE AS FIRST ARG
+ EXCH B,(TP)
+ PUSH TP,A ;USE OTHER AS 2D ARG
+ PUSH TP,B
+ MCALL 2,CHTYPE ;ATTEMPT TO MUNG
+RET13: POP TP,D
+ POP TP,C ; RESTORE COMMENT
+RET12: SETOM (P) ; DONT LOOOK FOR MORE!
+ JRST RET
+
+RDTMPL: PUSH P,["}] ; SET UP TERMINATE TEST
+ MOVE B,(TP)
+ PUSHJ P,IGVAL
+ MOVEM A,-1(TP)
+ MOVEM B,(TP)
+ PUSH P,[BLDTMP] ; FLAG FOR VECTOR READING CODE
+ JRST LBRAK2
+
+BLDTMP: ADDI A,1 ; 1 MORE ARGUMENT
+ ACALL A,APPLY ; DO IT TO IT
+ POPJ P,
+
+BYTIN: PUSHJ P,NXTCH ; CHECK FOR OPENR
+ CAIN B,SPATYP
+ PUSHJ P,SPACEQ
+ JRST .+3
+ PUSHJ P,LSTCHR
+ JRST BYTIN
+ CAIE B,TMPTYP
+ ERRUUO EQUOTE BAD-USE-OF-BYTE-STRING
+ PUSH P,["}]
+ PUSH P,[CBYTE1]
+ JRST LBRAK2
+
+CBYTE1: AOJA A,CBYTES
+
+RETERR: SKIPL A,5(TB)
+ MOVEI A,5(TB)-LSTCH ;NO CHANNEL, USE SLOT
+ HRRM B,LSTCH(A) ; RESTORE LAST CHAR
+ PUSHJ P,ERRPAR
+ SOS (P)
+ SOS (P)
+ POPJ P,
+
+\f
+;THIS CODE CALLS IREAD RECURSIVELY TO READ THAT WHICH IS
+;BETWEEN (), ARRIVED AT WHEN ( IS READ
+
+SEGIN: PUSH TP,$TSEG
+ JRST OPNAN1
+
+OPNANG: PUSH TP,$TFORM ;SAVE TYPE
+OPNAN1: PUSH P,[">]
+ JRST LPARN1
+
+LPAREN: PUSH P,[")]
+ PUSH TP,$TLIST ;START BY ASSUMING NIL
+LPARN1: PUSH TP,C%0
+ PUSHJ P,LSTCHR ;DON'T REREAD PARENS
+LLPLOP: PUSHJ P,IREAD1 ;READ IT
+ JRST LDONE ;HIT TERMINATOR
+
+;HERE WHEN MUST ADD CAR TO CURRENT WINNER
+
+GENCAR: PUSH TP,C ; SAVE COMMENT
+ PUSH TP,D
+ MOVE C,A ; SET UP CALL
+ MOVE D,B
+ PUSHJ P,INCONS ; CONS ON TO NIL
+ POP TP,D
+ POP TP,C
+ POP TP,E ;GET CDR
+ JUMPN E,CDRIN ;IF STACKED GOODIE NOT NIL SKIP
+ PUSH TP,B ;AND USE AS TOTAL VALUE
+ PUSH TP,$TLIST ;SAVE THIS AS FIRSST THING ON LIST
+ MOVE A,-2(TP) ; GET REAL TYPE
+ JRST .+2 ;SKIP CDR SETTING
+CDRIN: HRRM B,(E)
+ PUSH TP,B ;CLOBBER IN NEW PARTIAL GOODIE
+ JUMPE C,LLPLOP ; JUMP IF NO COMMENT
+ PUSH TP,C
+ PUSH TP,D
+ MOVSI C,TATOM
+ MOVE D,IMQUOTE COMMENT
+ PUSHJ P,IPUT
+ JRST LLPLOP ;AND CONTINUE
+
+; HERE TO RAP UP LIST
+
+LDONE: CAME B,(P) ;CHECK VALIDITY OF CHARACTER
+ PUSHJ P,MISMAT ;REPORT MISMATCH
+ SUB P, C%11
+ POP TP,B ;GET VALUE OF PARTIAL RESULT
+ POP TP,A ;AND TYPE OF SAME
+ JUMPE B,RET ;VALUE IS NIL, DON'T POP AGAIN
+ POP TP,B ;POP FIRST LIST ELEMENT
+ POP TP,A ;AND TYPE
+ JRST RET
+\f
+;THIS CODE IS SIMILAR TO LIST GENERATING CODE BUT IS FOR VECTORS
+OPNBRA: PUSH P,["}] ; SAVE TERMINATOR
+UVECIN: PUSH P,[135] ; CLOSE SQUARE BRACKET
+ PUSH P,[SETZ IEUVECTOR] ;PUSH NAME OF U VECT HACKER
+ JRST LBRAK2 ;AND GO
+
+LBRACK: PUSH P,[135] ; SAVE TERMINATE
+ PUSH P,[SETZ IEVECTOR] ;PUSH GEN VECTOR HACKER
+LBRAK2: PUSHJ P,LSTCHR ;FORCE READING NEW CHAR
+ PUSH P,C%0 ; COUNT ELEMENTS
+ PUSH TP,$TLIST ; AND SLOT FOR GOODIES
+ PUSH TP,C%0
+
+LBRAK1: PUSHJ P,IREAD1 ;RECURSIVELY READ ELEMENTS OF ARRAY
+ JRST LBDONE ;RAP UP ON TERMINATOR
+
+STAKIT: EXCH A,-1(TP) ; STORE RESULT AND GET CURRENT LIST
+ EXCH B,(TP)
+ AOS (P) ; COUNT ELEMENTS
+ JUMPE C,LBRAK3 ; IF NO COMMENT, GO ON
+ MOVEI E,(B) ; GET CDR
+ PUSHJ P,ICONS ; CONS IT ON
+ MOVEI E,(B) ; SAVE RS
+ MOVSI C,TFIX ; AND GET FIXED NUM
+ MOVE D,(P)
+ PUSHJ P,ICONS
+LBRAK3: PUSH TP,A ; SAVE CURRENT COMMENT LIST
+ PUSH TP,B
+ JRST LBRAK1
+
+; HERE TO RAP UP VECTOR
+
+LBDONE: CAME B,-2(P) ; FINISHED RETURN (WAS THE RIGHT STOP USED?)
+ PUSHJ P,MISMAB ; WARN USER
+ POP TP,1(TB) ; REMOVE COMMENT LIST
+ POP TP,(TB)
+ MOVE A,(P) ; COUNT TO A
+ PUSHJ P,-1@(P) ; MAKE THE VECTOR
+ SUB P,C%33
+
+; PUT COMMENTS ON VECTOR (OR UVECTOR)
+
+ MOVNI C,1 ; INDICATE TEMPLATE HACK
+ CAMN A,$TVEC
+ MOVEI C,1
+ CAMN A,$TUVEC ; SKIP IF UVECTOR
+ MOVEI C,0
+ PUSH P,C ; SAVE
+ PUSH TP,A ; SAVE VECTOR/UVECTOR
+ PUSH TP,B
+
+VECCOM: SKIPN C,1(TB) ; ANY LEFT?
+ JRST RETVEC ; NO, LEAVE
+ MOVE A,1(C) ; ASSUME WINNING TYPES
+ SUBI A,1
+ HRRZ C,(C) ; CDR THE LIST
+ HRRZ E,(C) ; AGAIN
+ MOVEM E,1(TB) ; SAVE CDR
+ GETYP E,(C) ; CHECK DEFFERED
+ MOVSI D,(E)
+ CAIN E,TDEFER ; SKIP IF NOT DEFERRED
+ MOVE C,1(C)
+ CAIN E,TDEFER
+ GETYPF D,(C) ; GET REAL TYPE
+ MOVE B,(TP) ; GET VECTOR POINTER
+ SKIPGE (P) ; SKIP IF NOT TEMPLATE
+ JRST TMPCOM
+ HRLI A,(A) ; COUNTER
+ LSH A,@(P) ; MAYBE SHIFT IT
+ ADD B,A
+ MOVE A,-1(TP) ; TYPE
+TMPCO1: PUSH TP,D
+ PUSH TP,1(C) ; PUSH THE COMMENT
+ MOVSI C,TATOM
+ MOVE D,IMQUOTE COMMENT
+ PUSHJ P,IPUT
+ JRST VECCOM
+
+TMPCOM: MOVSI A,(A)
+ ADD B,A
+ MOVSI A,TTMPLT
+ JRST TMPCO1
+
+RETVEC: SUB P,C%11
+ POP TP,B
+ POP TP,A
+ JRST RET
+
+; BUILD A SINGLE CHARACTER ITEM
+
+SINCHR: PUSHJ P,NXTC1 ;FORCE READ NEXT
+ CAIN B,ESCTYP ;ESCAPE?
+ PUSHJ P,NXTC1 ;RETRY
+ MOVEI B,(A)
+ MOVSI A,TCHRS
+ JRST RETCL
+
+\f
+; HERE ON RIGHT PAREN, BRACKET, ANGLE BRACKET OR CTL C
+
+CLSBRA:
+CLSANG: ;CLOSE ANGLE BRACKETS
+RBRACK: ;COMMON RETURN FOR END OF ARRAY ALSO
+RPAREN: PUSHJ P,LSTCHR ;DON'T REREAD
+EOFCH1: MOVE B,A ;GETCHAR IN B
+ MOVSI A,TCHRS ;AND TYPE IN A
+RET1: SUB P,C%11
+ POPJ P,
+
+EOFCHR: SETZB C,D
+ JUMPL A,EOFCH1 ; JUMP ON REAL EOF
+ JRST RRSUBR ; MAYBE A BINARY RSUBR
+
+DOEOF: MOVE A,[-1,,3]
+ SETZB C,D
+ JRST EOFCH1
+
+
+; NORMAL RETURN FROM IREAD/IREAD1
+
+RETCL: PUSHJ P,LSTCHR ;DONT REREAD
+RET: AOS -1(P) ;SKIP
+ POP P,E ; POP FLAG
+RETC: JUMPL E,RET2 ; DONT LOOK FOR COMMENTS
+ PUSH TP,A ; SAVE ITEM
+ PUSH TP,B
+CHCOMN: PUSHJ P,NXTCH ; READ A CHARACTER
+ CAIE B,COMTYP ; SKIP IF COMMENT
+ JRST CHSPA
+ PUSHJ P,IREAD ; READ THE COMMENT
+ JRST POPAJ
+ MOVE C,A
+ MOVE D,B
+ JRST .+2
+POPAJ: SETZB C,D
+ POP TP,B
+ POP TP,A
+RET2: POPJ P,
+
+CHSPA: CAIN B,SPATYP
+ PUSHJ P,SPACEQ ; IS IT A REAL SPACE
+ JRST POPAJ
+ PUSHJ P,LSTCHR ; FLUSH THE SPACE
+ JRST CHCOMN
+
+;RANDOM MINI-SUBROUTINES USED BY THE READER
+
+;READ A CHAR INTO A AND TYPE CODE INTO D
+
+NXTC3: SKIPL B,5(TB) ;GET CHANNEL
+ JRST NXTPR4 ;NO CHANNEL, GO READ STRING
+ SKIPE LSTCH(B)
+ PUSHJ P,CNTACC ; COUNT ON ACCESS POINTER
+ PUSHJ P,RXCT
+ TRO A,200
+ JRST GETCTP
+
+NXTC1: SKIPL B,5(TB) ;GET CHANNEL
+ JRST NXTPR1 ;NO CHANNEL, GO READ STRING
+ SKIPE LSTCH(B)
+ PUSHJ P,CNTACC ; COUNT ON ACCESS POINTER
+ JRST NXTC2
+NXTC: SKIPL B,5(TB) ;GET CHANNEL
+ JRST NXTPRS ;NO CHANNEL, GO READ STRING
+ SKIPE A,LSTCH(B) ;CHAR IN A IF REUSE
+ JRST PRSRET
+NXTC2: PUSHJ P,RXCT ;GET CHAR FROM INPUT
+ TLO A,200000 ; BIT TO AVOID ^@ LOSSAGE
+ HLLZS 2(TB) ;FLAG INDICATING ONE CHAR LOOK AHEAD
+ MOVEM A,LSTCH(B) ;SAVE THE CHARACTER
+PRSRET: TLZ A,200000
+ TRZE A,400000 ;DONT SKIP IF SPECIAL
+ TRO A,200 ;GO HACK SPECIALLY
+GETCTP: PUSH P,A ;AND SAVE FROM DIVISION
+ ANDI A,377
+ IDIVI A,CHRWD ;YIELDS WORD AND CHAR NUMBER
+ LDB B,BYTPNT(B) ;GOBBLE TYPE CODE
+ POP P,A
+ ANDI A,177 ; RETURN REAL ASCII
+ POPJ P,
+
+NXTPR4: MOVEI F,400000
+ JRST NXTPR5
+
+NXTPRS: SKIPE A,5(TB) ;GET OLD CHARACTER IF ONE EXISTS
+ JRST PRSRET
+NXTPR1: MOVEI F,0
+NXTPR5: MOVE A,11.(TB)
+ HRRZ B,(A) ;GET THE STRING
+ SOJL B,NXTPR3
+ HRRM B,(A)
+ ILDB A,1(A) ;GET THE CHARACTER FROM THE STRING
+ IORI A,(F)
+NXTPR2: MOVEM A,5(TB) ;SAVE IT
+ JRST PRSRET ;CONTINUE
+
+NXTPR3: SETZM 8.(TB)
+ SETZM 9.(TB) ;CLEAR OUT LOCATIVE, AT END OF STRING
+ MOVEI A,400033
+ JRST NXTPR2
+
+; NXTCH AND NXTCH1 ARE SAME AS NXTC AND NXTC1 EXCEPT THEY CHECK !
+; HACKS
+
+NXTCH1: PUSHJ P,NXTC1 ;READ CHAR
+ JRST .+2
+NXTCH: PUSHJ P,NXTC ;READ CHAR
+ PUSHJ P,CHKUS1 ; CHECK FOR USER DISPATCH
+
+ CAIE B,NTYPES+1 ; SKIP IF ! ING NEXT CHAR
+ POPJ P,
+ PUSHJ P,NXTC3 ;READ NEXT ONE
+ HLLOS 2(TB) ;FLAG FOR TWO CHAR LOOK AHEAD
+
+CRMLST: IORI A,400000 ;CLOBBER LASTCHR
+ PUSH P,B
+ SKIPL B,5(TB) ;POINT TO CHANNEL
+ MOVEI B,5(TB)-LSTCH ;NO CHANNEL, POINT AT SLOT
+ HRRM A,LSTCH(B)
+ ANDI A,377777 ;DECREASE CHAR
+ POP P,B
+
+CHKUS2: SKIPN 7(TB) ; SKIP IF USER TABLE
+ POPJ P,
+ MOVEI F,200(A)
+ ASH F,1 ; POINT TO SLOT
+ HRLI F,(F)
+ ADD F,7(TB)
+ JUMPGE F,CPOPJ ;IS THERE VECTOR ENOUGH?
+ SKIPN 1(F) ; NON-ZERO==>USER FCN EXISTS
+ JRST CPOPJ ; HOPE HE APPRECIATES THIS
+ MOVEI B,USTYP2
+CHKRDO: PUSH P,0 ; CHECK FOR REDOING IF CHAR IN TABLE
+ GETYP 0,(F)
+ CAIE 0,TCHRS
+ JRST CHKUS5
+ POP P,0 ;WE ARE TRANSMOGRIFYING
+ MOVE A,1(F) ;GET NEW CHARACTER
+ PUSH P,7(TB)
+ PUSH P,2(TB) ; FLAGS FOR NUM OF CHRS IN LOOK AHEAD
+ PUSH P,5(TB) ; TO AVOID SMASHING LSTCHR
+ SETZM 5(TB) ; CLEAR OUT CHANNEL
+ SETZM 7(TB) ;CLEAR OUT TABLE
+ TRZE A,200 ; ! HACK
+ TRO A,400000 ; TURN ON PROPER BIT
+ PUSHJ P,PRSRET
+ POP P,5(TB) ; GET BACK CHANNEL
+ POP P,2(TB)
+ POP P,7(TB) ;GET BACK OLD PARSE TABLE
+ POPJ P,
+
+CHKUS5: PUSH P,A
+ CAIE 0,TLIST
+ JRST .+4 ; SPECIAL NON-BREAK TYPE HACK
+ MOVNS (P) ; INDICATE BY NEGATIVE
+ MOVE A,1(F) ; GET <1 LIST>
+ GETYP 0,(A) ; AND GET THE TYPE OF THAT
+ CAIE 0,TFIX ; SEE IF HE WANTS SAME CHAR WITH DIFF TYPE
+ JRST CHKUS6 ; JUST A VANILLA HACK
+ MOVE A,1(F) ; PRETEND IT IS SAME TYPE AS NEW CHAR
+ PUSH P,7(TB) ; CLEAR OUT TRANSLATE TABLE
+ PUSH P,2(TB) ; FLAGS FOR # OF CHRS IN LOOK AHEAD
+ SETZM 7(TB)
+ TRZE A,200
+ TRO A,400000 ; TURN ON PROPER BIT IF ! HACK
+ PUSHJ P,PRSRET ; REGET TYPE
+ POP P,2(TB)
+ POP P,7(TB) ; PUT TRANSLATE TABLE BACK
+CHKUS6: SKIPGE -1(P) ; SEE IF A SPECIAL NON-BREAK
+ MOVNS B ; SEXY, HUH?
+ POP P,A
+ POP P,0
+ MOVMS A ; FIX UP A POSITIVE CHARACTER
+ POPJ P,
+
+CHKUS4: POP P,A
+ POPJ P,
+
+CHKUS1: SKIPN 7(TB) ; USER CHECK FOR NOT ! CASE
+ POPJ P,
+ MOVEI F,(A)
+ ASH F,1
+ HRLI F,(F)
+ ADD F,7(TB)
+ JUMPGE F,CPOPJ
+ SKIPN 1(F)
+ POPJ P,
+ MOVEI B,USTYP1
+ JRST CHKRDO ; TRANSMOGRIFY CHARACTER?
+
+CHKUS3: POP P,A
+ POPJ P,
+
+UPLO: POPJ P, ; LETS NOT AND SAY WE USED TO
+ ; AVOID STRANGE ! BLECHAGE
+NXTCS: PUSHJ P,NXTC
+ PUSH P,A ; HACK TO NOT TRANSLATE CHAR
+ PUSHJ P,CHKUS1 ; BUT DO TRANSLATION OF TYPE IF HE WANTS
+ POP P,A ; USED TO BUILD UP STRINGS
+ POPJ P,
+
+CHKALT: CAIN A,33 ;ALT?
+ MOVEI B,MANYT
+ JRST CRMLST
+
+
+TERM: MOVEI B,0 ;RETURN A 0
+ JRST RET1
+ ;AND RETURN
+
+CHKMIN: CAIN A,"- ; IF CHAR IS -, WINNER
+ MOVEI B,PATHTY
+ JRST CRMLST
+
+LOSPAT: PUSHJ P,LSTCHR ; FIX RECURSIVE LOSAGE
+ ERRUUO EQUOTE UNATTACHED-PATH-NAME-SEPARATOR
+
+\f
+; HERE TO SEE IF READING RSUBR
+
+RRSUBR: PUSHJ P,LSTCHR ; FLUSH JUST READ CHAR
+ SKIPL B,5(TB) ; SKIP IF A CHANNEL EXISTS
+ JRST SPACE ; ELSE LIKE A SPACE
+ HRRZ C,BUFSTR(B) ; SEE IF FLAG SAYS START OF RSUBR
+ MOVE C,(C)
+ TRNN C,1 ; SKIP IF REAL RSUBR
+ JRST EOFCH2 ; NO, IGNORE FOR NOW
+
+; REALLY ARE READING AN RSUBR
+
+ HRRZ 0,4(TB) ; GET READ/READB INDICATOR
+ MOVE C,ACCESS(B) ; GET CURRENT ACCESS
+ JUMPN 0,.+3 ; ALREADY WORDS, NO NEED TO DIVIDE
+ ADDI C,4 ; ROUND UP
+ IDIVI C,5
+ PUSH P,C ; SAVE WORD ACCESS
+ MOVEI A,(C) ; COPY IT FOR CALL
+ JUMPN 0,.+3
+ IMULI C,5
+ MOVEM C,ACCESS(B) ; FIXUP ACCESS
+ HLLZS ACCESS-1(B) ; FOR READB LOSER
+ PUSHJ P,DOACCS ; AND GO THERE
+ PUSH P,C%0 ; FOR READ IN
+ HRROI A,(P) ; PREPARE TO READ LENGTH
+ PUSHJ P,DOIOTI ; READ IT
+ POP P,C ; GET READ GOODIE
+ JUMPGE A,.+4 ; JUMP IF WON
+ SUB P,C%11
+EOFCH2: HRROI A,3
+ JRST EOFCH1
+ MOVEI A,(C) ; COPY FOR GETTING BLOCK
+ ADDI C,1 ; COUNT COUNT WORD
+ ADDM C,(P)
+ PUSH TP,$TUVEC ; WILL HOLD UVECTOR OF FIXUPS IF THEY STAY
+ PUSH TP,C%0
+ PUSHJ P,IBLOCK ; GET A BLOCK
+ PUSH TP,$TUVEC
+ PUSH TP,B ; AND SAVE
+ MOVE A,B ; READY TO IOT IT IN
+ MOVE B,5(TB) ; GET CHANNEL BACK
+ MOVSI 0,TUVEC ; SETUP A'S TYPE
+ MOVE PVP,PVSTOR+1
+ MOVEM 0,ASTO(PVP)
+ PUSHJ P,DOIOTI ; IN COMES THE WHOLE BLOCK
+ MOVE PVP,PVSTOR+1
+ SETZM ASTO(PVP) ; A NO LONGER SPECIAL
+ MOVEI C,BUFSTR-1(B) ; NO RESET BUFFER
+ PUSHJ P,BYTDOP ; A POINTS TO DOPW WORD
+ SUBI A,2
+ HRLI A,010700 ; SETUP BYTE POINTER TO END
+ HLLZS BUFSTR-1(B) ; ZERO CHAR COUNNT
+ MOVEM A,BUFSTR(B)
+ HRRZ A,4(TB) ; READ/READB FLG
+ MOVE C,(P) ; ACCESS IN WORDS
+ SKIPN A ; SKIP FOR ASCII
+ IMULI C,5 ; BUMP
+ MOVEM C,ACCESS(B) ; UPDATE ACCESS
+ PUSHJ P,NIREAD ; READ RSUBR VECTOR
+ JRST BRSUBR ; LOSER
+ GETYP A,A ; VERIFY A LITTLE
+ CAIE A,TVEC ; DONT SKIP IF BAD
+ JRST BRSUBR ; NOT A GOOD FILE
+ PUSHJ P,LSTCHR ; FLUSH REREAD CHAR
+ MOVE C,(TP) ; CODE VECTOR BACK
+ MOVSI A,TCODE
+ HLR A,B ; FUNNY COUNT
+ MOVEM A,(B) ; CLOBBER
+ MOVEM C,1(B)
+ PUSH TP,$TRSUBR ; MAKE RSUBR
+ PUSH TP,B
+
+; NOW LOOK OVER FIXUPS
+
+ MOVE B,5(TB) ; GET CHANNEL
+ MOVE C,ACCESS(B)
+ HLLZS ACCESS-1(B) ; FOR READB LOSER
+ HRRZ 0,4(TB) ; READ/READB FLG
+ JUMPN 0,RSUB1
+ ADDI C,4 ; ROUND UP
+ IDIVI C,5 ; TO WORDS
+ MOVEI D,(C) ; FIXUP ACCESS
+ IMULI D,5
+ MOVEM D,ACCESS(B) ; AND STORE
+RSUB1: ADDI C,1 ; ACCOUNT FOR EXTRA COUNTERS
+ MOVEM C,(P) ; SAVE FOR LATER
+ MOVEI A,-1(C) ; FOR DOACS
+ MOVEI C,2 ; UPDATE REAL ACCESS
+ SKIPN 0 ; SKIP FOR READB CASE
+ MOVEI C,10.
+ ADDM C,ACCESS(B)
+ PUSHJ P,DOACCS ; DO THE ACCESS
+ PUSH TP,$TUVEC ; SLOT FOR FIXUP BUFFER
+ PUSH TP,C%0
+
+; FOUND OUT IF FIXUPS STAY
+
+ MOVE B,IMQUOTE KEEP-FIXUPS
+ PUSHJ P,ILVAL ; GET VALUE
+ GETYP 0,A
+ MOVE B,5(TB) ; CHANNEL BACK TO B
+ CAIE 0,TUNBOU
+ CAIN 0,TFALSE
+ JRST RSUB4 ; NO, NOT KEEPING FIXUPS
+ PUSH P,C%0 ; SLOT TO READ INTO
+ HRROI A,(P) ; GET LENGTH OF SAME
+ PUSHJ P,DOIOTI
+ POP P,C
+ MOVEI A,(C) ; GET UVECTOR FOR KEEPING
+ ADDM C,(P) ; ACCESS TO END
+ PUSH P,C ; SAVE LENGTH OF FIXUPS
+ PUSHJ P,IBLOCK
+ MOVEM B,-6(TP) ; AND SAVE
+ MOVE A,B ; FOR IOTING THEM IN
+ ADD B,C%11 ; POINT PAST VERS #
+ MOVEM B,(TP)
+ MOVSI C,TUVEC
+ MOVE PVP,PVSTOR+1
+ MOVEM C,ASTO(PVP)
+ MOVE B,5(TB) ; AND CHANNEL
+ PUSHJ P,DOIOTI ; GET THEM
+ MOVE PVP,PVSTOR+1
+ SETZM ASTO(PVP)
+ MOVE A,(TP) ; GET VERS
+ PUSH P,-1(A) ; AND PUSH IT
+ JRST RSUB5
+
+RSUB4: PUSH P,C%0
+ PUSH P,C%0 ; 2 SLOTS FOR READING
+ MOVEI A,-1(P)
+ HRLI A,-2
+ PUSHJ P,DOIOTI
+ MOVE C,-1(P)
+ MOVE D,(P)
+ ADDM C,-2(P) ; NOW -2(P) IS ACCESS TO END OF FIXUPS
+RSUB5: MOVEI C,BUFSTR-1(B) ; FIXUP BUFFER
+ PUSHJ P,BYTDOP
+ SUBI A,2 ; POINT BEFORE D.W.
+ HRLI A,10700
+ MOVEM A,BUFSTR(B)
+ HLLZS BUFSTR-1(B)
+ SKIPE -6(TP)
+ JRST RSUB2A
+ SUBI A,BUFLNT-1 ; ALSO MAKE AN IOT FLAVOR BUFFER
+ HRLI A,-BUFLNT
+ MOVEM A,(TP)
+ MOVSI C,TUVEC
+ MOVE PVP,PVSTOR+1
+ MOVEM C,ASTO(PVP)
+ PUSHJ P,DOIOTI
+ MOVE PVP,PVSTOR+1
+ SETZM ASTO(PVP)
+RSUB2A: PUSH P,-1(P) ; ANOTHER COPY OF LENGTH OF FIXUPS
+
+; LOOP FIXING UP NEW TYPES
+
+RSUB2: PUSHJ P,WRDIN ; SEE WHAT NEXT THING IS
+ JRST RSUB3 ; NO MORE, DONE
+ JUMPL E,STSQ ; MUST BE FIRST SQUOZE
+ MOVNI 0,(E) ; TO UPDATE AMNT OF FIXUPS
+ ADDB 0,(P)
+ HRLI E,(E) ; IS LENGTH OF STRING IN WORDS
+ ADD E,(TP) ; FIXUP BUFFER POINTER
+ JUMPL E,.+3
+ SUB E,[BUFLNT,,BUFLNT]
+ JUMPGE E,.-1 ; STILL NOT RIGHT
+ EXCH E,(TP) ; FIX UP SLOT
+ HLRE C,E ; FIX BYTE POINTER ALSO
+ IMUL C,[-5] ; + CHARS LEFT
+ MOVE B,5(TB) ; CHANNEL
+ PUSH TP,BUFSTR-1(B)
+ PUSH TP,BUFSTR(B)
+ HRRM C,BUFSTR-1(B)
+ HRLI E,440700 ; AND BYTE POINTER
+ MOVEM E,BUFSTR(B)
+ PUSHJ P,NIREAD ; READ ATOM NAME OF TYPE
+ TDZA 0,0 ; FLAG LOSSAGE
+ MOVEI 0,1 ; WINNAGE
+ MOVE C,5(TB) ; RESET BUFFER
+ POP TP,BUFSTR(C)
+ POP TP,BUFSTR-1(C)
+ JUMPE 0,BRSUBR ; BAD READ OF RSUBR
+ GETYP A,A ; A LITTLE CHECKING
+ CAIE A,TATOM
+ JRST BRSUBR
+ PUSHJ P,LSTCHR ; FLUSH REREAD CHAR
+ HRRZ 0,4(TB) ; FIXUP ACCESS PNTR
+ MOVE C,5(TB)
+ MOVE D,ACCESS(C)
+ HLLZS ACCESS-1(C) ; FOR READB HACKER
+ ADDI D,4
+ IDIVI D,5
+ IMULI D,5
+ SKIPN 0
+ MOVEM D,ACCESS(C) ; RESET
+TYFIXE: PUSHJ P,TYPFND ; SEE IF A LEGAL TYPE NAME
+ JRST TYPFIX ; GO SEE USER ABOUT THIS
+ PUSHJ P,FIXCOD ; GO FIX UP THE CODE
+ JRST RSUB2
+
+; NOW FIX UP SUBRS ETC. IF NECESSARY
+
+STSQ: MOVE B,IMQUOTE MUDDLE
+ PUSHJ P,IGVAL ; GET CURRENT VERS
+ CAME B,-1(P) ; SKIP IF NO FIXUPS NEEDED
+ JRST DOFIX0 ; MUST DO THEM
+
+; ALL DONE, ACCESS PAST FIXUPS AND RETURN
+RSUB31: PUSHJ P,SQUKIL ; DONE FIXING UP, KILL SQUOZE TABLE IF IN INTERP
+RSUB3: MOVE A,-3(P)
+ MOVE B,5(TB)
+ MOVEI C,(A) ; UPDATE CHANNEL ACCESS IN CASE SKIPPING
+ HRRZ 0,4(TB) ; READ/READB FLAG
+ SKIPN 0
+ IMULI C,5
+ MOVEM C,ACCESS(B) ; INTO ACCESS SLOT
+ HLLZS ACCESS-1(B)
+ PUSHJ P,DOACCS ; ACCESSED
+ MOVEI C,BUFSTR-1(B) ; FIX UP BUFFER
+ PUSHJ P,BYTDOP
+ SUBI A,2
+ HRLI A,10700
+ MOVEM A,BUFSTR(B)
+ HLLZS BUFSTR-1(B)
+ SKIPN A,-6(TP) ; SKIP IF KEEPING FIXUPS
+ JRST RSUB6
+ PUSH TP,$TUVEC
+ PUSH TP,A
+ MOVSI A,TRSUBR
+ MOVE B,-4(TP)
+ MOVSI C,TATOM
+ MOVE D,IMQUOTE RSUBR
+ PUSHJ P,IPUT ; DO THE ASSOCIATION
+
+RSUB6: MOVE C,-4(TP) ; DO SPECIAL FIXUPS
+ PUSHJ P,SFIX
+ MOVE B,-2(TP) ; GET RSUBR
+ MOVSI A,TRSUBR
+ SUB P,C%44 ; FLUSH P CRUFT
+ SUB TP,[10,,10]
+ JRST RET
+
+; FIXUP SUBRS ETC.
+
+DOFIX0: SKIPN C,-6(TP) ; GET BUFFER IF KEEPING
+ JRST DOFIXE
+ MOVEM B,(C) ; CLOBBER
+ JRST DOFIXE
+
+FIXUPL: PUSHJ P,WRDIN
+ JRST RSUB31
+DOFIXE: JUMPGE E,BRSUBR
+ TLZ E,740000 ; KILL BITS
+IFN KILTV,[
+ CAME E,[SQUOZE 0,DSTO]
+ JRST NOOPV
+ MOVE E,[SQUOZE 40,DSTORE]
+ MOVE A,(TP)
+ SKIPE -6(TP)
+ MOVEM E,-1(A)
+ MOVEI E,53
+ HRLM E,(A)
+ MOVEI E,DSTORE
+ JRST .+3
+NOOPV:
+]
+ PUSHJ P,SQUTOA ; LOOK IT UP
+ PUSHJ P,BRSUB1
+ MOVEI D,(E) ; FOR FIXCOD
+ PUSHJ P,FIXCOD ; FIX 'EM UP
+ JRST FIXUPL
+
+; BAD SQUOZE, BE MORE SPECIFIC
+
+BRSUB1: PUSHJ P,SQSTR
+ PUSH TP,$TATOM
+ PUSH TP,EQUOTE SQUZE-SYMBOL-NOT-FOUND-ERRET CORRECTION
+ PUSH TP,A
+ PUSH TP,B
+ PUSH TP,$TATOM
+ PUSH TP,MQUOTE READ
+ MCALL 3,ERROR
+ GETYP A,A
+ CAIE A,TFIX
+ ERRUUO EQUOTE VALUE-MUST-BE-FIX
+ MOVE E,B
+ POPJ P,
+
+; CONVERT SQUOZE TO A MUDDLE STRING FOR USER
+
+SQSTR: PUSHJ P,SPTT
+ PUSH P,C
+ CAIN B,6 ; 6 chars?
+ PUSH P,D
+ PUSH P,B
+ PUSHJ P,CHMAK
+ POPJ P,
+
+SPTT: SETZB B,C
+ MOVE A,[440700,,C]
+ MOVEI D,0
+
+SPT1: IDIVI E,50
+ PUSH P,F
+ JUMPE E,SPT3
+ PUSHJ P,SPT1
+SPT3: POP P,E
+ ADDI E,"0-1
+ CAILE E,"9
+ ADDI E,"A-"9-1
+ CAILE E,"Z
+ SUBI E,"Z-"#+1
+ CAIN E,"#
+ MOVEI E,".
+ CAIN E,"/
+SPC: MOVEI E,40
+ IDPB E,A
+ ADDI B,1
+ POPJ P,
+
+
+;0 1-12 13-44 45 46 47
+;NULL 0-9 A-Z . $ %
+
+; ROUTINE TO FIXUP ACTUAL CODE
+
+FIXCOD: MOVEI E,0 ; FOR HWRDIN
+ PUSH P,D ; NEW VALUE
+ PUSHJ P,HWRDIN ; GET HW NEEDED
+ MOVE D,(P) ; GET NEW VAL
+ MOVE A,(TP) ; AND BUFFER POINTER
+ SKIPE -6(TP) ; SAVING?
+ HRLM D,-1(A) ; YES, CLOBBER
+ SUB C,(P) ; DIFFERENCE
+ MOVN D,C
+
+FIXLP: PUSHJ P,HWRDIN ; GET AN OFFSET
+ JUMPE C,FIXED
+ HRRES C ; MAKE NEG IF NEC
+ JUMPL C,LHFXUP
+ ADD C,-4(TP) ; POINT INTO CODE
+IFN KILTV,[
+ LDB 0,[220400,,-1(C)] ; GET INDEX FIELD
+ CAIE 0,7
+ JRST NOTV
+KIND: MOVEI 0,0
+ DPB 0,[220400,,-1(C)]
+ JRST DONTV
+NOTV: CAIE 0,6 ; IS IT PVP
+ JRST DONTV
+ HRRZ 0,-1(C)
+ CAIE 0,12 ; OLD DSTO
+ JRST DONTV
+ MOVEI 0,33.
+ ADDM 0,-1(C)
+ JRST KIND
+DONTV:
+]
+ ADDM D,-1(C)
+ JRST FIXLP
+
+LHFXUP: MOVMS C
+ ADD C,-4(TP)
+ MOVSI 0,(D)
+ ADDM 0,-1(C)
+ JRST FIXLP
+
+FIXED: SUB P,C%11
+ POPJ P,
+
+; ROUTINE TO READ A WORD FROM BUFFER
+
+WRDIN: PUSH P,A
+ PUSH P,B
+ SOSG -3(P) ; COUNT IT DOWN
+ JRST WRDIN1
+ AOS -2(P) ; SKIP RETURN
+ MOVE B,5(TB) ; CHANNEL
+ HRRZ A,4(TB) ; READ/READB SW
+ MOVEI E,5
+ SKIPE A
+ MOVEI E,1
+ ADDM E,ACCESS(B)
+ MOVE A,(TP) ; BUFFER
+ MOVE E,(A)
+ AOBJP A,WRDIN2 ; NEED NEW BUFFER
+ MOVEM A,(TP)
+WRDIN1: POP P,B
+ POP P,A
+ POPJ P,
+
+WRDIN2: MOVE B,-3(P) ; IS THIS LAST WORD?
+ SOJLE B,WRDIN1 ; YES, DONT RE-IOT
+ SUB A,[BUFLNT,,BUFLNT]
+ MOVEM A,(TP)
+ MOVSI B,TUVEC
+ MOVE PVP,PVSTOR+1
+ MOVEM B,ASTO(PVP)
+ MOVE B,5(TB)
+ PUSHJ P,DOIOTI
+ MOVE PVP,PVSTOR+1
+ SETZM ASTO(PVP)
+ JRST WRDIN1
+
+; READ IN NEXT HALF WORD
+
+HWRDIN: JUMPN E,NOIOT ; USE EXISTING WORD
+ PUSH P,-3(P) ; FAKE OUT WRDIN IF NEC.
+ PUSHJ P,WRDIN
+ JRST BRSUBR
+ POP P,-4(P) ; RESET COUNTER
+ HLRZ C,E ; RET LH
+ POPJ P,
+
+NOIOT: HRRZ C,E
+ MOVEI E,0
+ POPJ P,
+
+TYPFIX: PUSH TP,$TATOM
+ PUSH TP,EQUOTE BAD-TYPE-NAME
+ PUSH TP,$TATOM
+ PUSH TP,B
+ PUSH TP,$TATOM
+ PUSH TP,EQUOTE ERRET-TYPE-NAME-DESIRED
+ MCALL 3,ERROR
+ JRST TYFIXE
+
+BRSUBR: ERRUUO EQUOTE RSUBR-IN-BAD-FORMAT
+\f
+
+
+;TABLE OF BYTE POINTERS FOR GETTING CHARS
+
+BYTPNT": 350700,,CHTBL(A)
+ 260700,,CHTBL(A)
+ 170700,,CHTBL(A)
+ 100700,,CHTBL(A)
+ 010700,,CHTBL(A)
+
+;HERE ARE THE TABLES OF CHXRACTERS (NOTE EVERYTHING NOT SPECIFIED IS
+;IN THE NUMBER LETTER CATAGORY)
+
+CHROFF==0 ; USED FOR ! HACKS
+SETCHR NUMCOD,[0123456789]
+
+SETCHR PLUCOD,[+]
+
+SETCHR NEGCOD,[-]
+
+SETCHR ASTCOD,[*]
+
+SETCHR DOTTYP,[.]
+
+SETCHR ETYPE,[Ee]
+
+SETCOD SPATYP,[0,15,12,11,14,40,33] ;ALL ARE TYPE 2 (SPACING - FF,TAB,SPACE,ALT-MODE)
+
+INCRCH LPATYP,[()[]'%"\#<>] ;GIVE THESE INCREASRNG CODES FROM 3
+
+SETCOD EOFTYP,[3] ;^C - EOF CHARACTER
+
+SETCOD SPATYP,[32] ;^Z - TENEX/TOPS-20 EOF (SET IN BOTH TO BE CONSISTENT)
+
+INCRCH COMTYP,[;,{}!] ;COMMENT AND GLOBAL VALUE AND SPECIAL
+
+CHROFF==200 ; CODED AS HAVING 200 ADDED
+
+INCRCH EXCEXC,[!.[]'"<>,-\]
+
+SETCOD MANYT,[33]
+
+CHTBL:
+ OUTTBL ;OUTPUT THE TABLE RIGHT HERE
+
+
+\f; THIS CODE FLUSHES WANDERING COMMENTS
+
+COMNT: PUSHJ P,IREAD
+ JRST COMNT2
+ JRST BDLP
+
+COMNT2: SKIPL A,5(TB) ; RESTORE CHANNEL
+ MOVEI A,5(TB)-LSTCH ;NO CHANNEL, POINT AT SLOT
+ HRRM B,LSTCH(A) ; CLOBBER IN CHAR
+ PUSHJ P,ERRPAR
+ JRST BDLP
+\f
+
+;HERE TO SET UP FOR .FOO ..FOO OR.<ABC>
+
+DOTSTR: PUSHJ P,NXTCH1 ; GOBBLE A NEW CHARACTER
+ MOVEI FF,FRSDOT+DOTSEN ; SET FLAG IN CASE
+ CAIN B,NUMCOD ; SKIP IF NOT NUMERIC
+ JRST DOTST1 ; NUMERIC, COULD BE FLONUM
+
+; CODE TO HANDLE ALL IMPLICIT CALLS I.E. QUOTE, LVAL, GVAL
+
+ MOVSI B,TFORM ; LVAL
+ MOVE A,IMQUOTE LVAL
+ JRST IMPCA1
+
+GLOSEG: SKIPA B,$TSEG ;SEG CALL TO GVAL
+GLOVAL: MOVSI B,TFORM ;FORM CALL TO SAME
+ MOVE A,IMQUOTE GVAL
+ JRST IMPCAL
+
+QUOSEG: SKIPA B,$TSEG ;SEG CALL TO QUOTE
+QUOTIT: MOVSI B,TFORM
+ MOVE A,IMQUOTE QUOTE
+ JRST IMPCAL
+
+SEGDOT: MOVSI B,TSEG ;SEG CALL TO LVAL
+ MOVE A,IMQUOTE LVAL
+IMPCAL: PUSHJ P,LSTCHR ;FLUSH LAST CHAR EXCEPT
+IMPCA1: PUSH TP,$TATOM ;FOR .FOO FLAVOR
+ PUSH TP,A ;PUSH ARGS
+ PUSH P,B ;SAVE TYPE
+ PUSHJ P,IREAD1 ;READ
+ JRST USENIL ; IF NO ARG, USE NIL
+IMPCA2: PUSH TP,C
+ PUSH TP,D
+ MOVE C,A ; GET READ THING
+ MOVE D,B
+ PUSHJ P,INCONS ; CONS TO NIL
+ MOVEI E,(B) ; PREPARE TON CONS ON
+POPARE: POP TP,D ; GET ATOM BACK
+ POP TP,C
+ EXCH C,-1(TP) ; SAVE THAT COMMENT
+ EXCH D,(TP)
+ PUSHJ P,ICONS
+ POP P,A ;GET FINAL TYPE
+ JRST RET13 ;AND RETURN
+
+
+USENIL: PUSH TP,C
+ PUSH TP,D
+ SKIPL A,5(TB) ; RESTOR LAST CHR
+ MOVEI A,5(TB)-LSTCH ;NO CHANNEL, POINT AT SLOT
+ HRRM B,LSTCH(A)
+ MOVEI E,0
+ JRST POPARE
+\f
+;HERE AFTER READING ATOM TO CALL VALUE
+
+.SET: PUSH P,$TFORM ;GET WINNING TYPE
+ MOVE E,(P)
+ PUSHJ P,RETC ; CHECK FOR POSSIBLE COMMENT
+ PUSH TP,$TATOM
+ PUSH TP,IMQUOTE LVAL
+ JRST IMPCA2 ;GO CONS LIST
+
+LOOPA: PUSH P,FF ; SAVE FLAGS IN CASE .ATOM
+LOOPAT: PUSHJ P,NXTCH ; CHECK FOR TRAILER
+ CAIN B,PATHTY ; PATH BEGINNER
+ JRST PATH0 ; YES, GO PROCESS
+ CAIN B,SPATYP ; SPACER?
+ PUSHJ P,SPACEQ ; CHECK FOR REAL SPACE
+ JRST PATH2
+ PUSHJ P,LSTCHR ; FLUSH IT AND RETRY
+ JRST LOOPAT
+PATH0: PUSHJ P,NXTCH1 ; READ FORCED NEXT
+ CAIE B,SPCTYP ; DO #FALSE () HACK
+ CAIN B,ESCTYP
+ JRST PATH4
+ CAIL B,SPATYP ; SPACER?
+ JRST PATH3 ; YES, USE THE ROOT OBLIST
+PATH4: PUSHJ P,NIREA1 ; READ NEXT ITEM
+ PUSHJ P,ERRPAR ; LOSER
+ CAME A,$TATOM ; ONLY ALLOW ATOMS
+ JRST BADPAT
+
+ PUSH TP,A
+ PUSH TP,B
+ MOVSI C,TATOM
+ MOVE D,IMQUOTE OBLIST
+ PUSHJ P,IGET ; GET THE OBLIST
+ ; IF NOT OBLIST, MAKE ONE
+ JUMPN B,PATH6
+ MCALL 1,MOBLIS ; MAKE ONE
+ JRST PATH1
+
+PATH6: SUB TP,C%22
+ JRST PATH1
+
+
+PATH3: MOVE B,ROOT+1 ; GET ROOT OBLIST
+ MOVSI A,TOBLS
+PATH1: POP P,FF ; FLAGS
+ TRNE FF,FRSDOT
+ JRST PATH.
+ PUSHJ P,RLOOKU ; AND LOOK IT UP
+
+ JRST RET
+
+PATH.: PUSHJ P,RLOOKU
+ JRST .SET ; CONS AN LVAL FORM
+
+SPACEQ: ANDI A,-1
+ CAIE A,33
+ CAIN A,400033
+ POPJ P,
+ CAIE A,3
+ AOS (P)
+ POPJ P,
+\f
+
+PATH2: MOVE B,IMQUOTE OBLIST
+ PUSHJ P,IDVAL
+ JRST PATH1
+
+BADPAT: ERRUUO EQUOTE NON-ATOMIC-OBLIST-NAME
+
+\f
+
+; HERE TO READ ONE CHARACTER FOR USER.
+
+CREDC1: SUBM M,(P)
+ PUSH TP,A
+ PUSH TP,B
+ PUSHJ P,IREADC
+ JRST CRDEO1
+ JRST RMPOPJ
+
+CNXTC1: SUBM M,(P)
+ PUSH TP,A
+ PUSH TP,B
+ PUSHJ P,INXTRD
+ JRST CRDEO1
+ JRST RMPOPJ
+
+CRDEO1: MOVE B,(TP)
+ PUSH TP,EOFCND-1(B)
+ PUSH TP,EOFCND(B)
+ PUSH TP,$TCHAN
+ PUSH TP,B
+ MCALL 1,FCLOSE
+ MCALL 1,EVAL
+ JRST RMPOPJ
+
+
+CREADC: SUBM M,(P)
+ PUSH TP,A
+ PUSH TP,B
+ PUSHJ P,IREADC
+ JRST CRDEOF
+ SOS (P)
+ JRST RMPOPJ
+
+CNXTCH: SUBM M,(P)
+ PUSH TP,A
+ PUSH TP,B
+ PUSHJ P,INXTRD
+ JRST CRDEOF
+ SOS (P)
+RMPOPJ: SUB TP,C%22
+ JRST MPOPJ
+
+CRDEOF: .MCALL 1,FCLOSE
+ MOVSI A,TCHRS
+ HRROI B,3
+ JRST MPOPJ
+
+INXTRD: TDZA E,E
+IREADC: MOVEI E,1
+ MOVE B,(TP) ; CHANNEL
+ HRRZ A,-2(B) ; GET BLESS BITS
+ TRNE A,C.BIN
+ TRNE A,C.BUF
+ JRST .+3
+ PUSHJ P,GRB
+ HRRZ A,-2(B)
+ TRC A,C.OPN+C.READ
+ TRNE A,C.OPN+C.READ
+ JRST BADCHN
+ SKIPN A,LSTCH(B)
+ PUSHJ P,RXCT
+ TLO A,200000
+ MOVEM A,LSTCH(B) ; SAVE CHAR
+ CAMN A,C%M1 ; [-1] ; SPECIAL PSEUDO TTY HACK?
+ JRST PSEUDO ; YES, RET AS FIX
+; ANDI A,-1
+ TLZ A,200000
+ TRZN A,400000 ; UNDO ! HACK
+ JRST NOEXCL
+ SKIPE E
+ MOVEM A,LSTCH(B)
+ MOVEI A,"! ; RETURN AN !
+NOEXC1: SKIPGE B,A ; CHECK EOF
+ SOS (P) ; DO EOF RETURN
+ MOVE B,A ; CHAR TO B
+ MOVSI A,TCHRS
+PSEUD1: AOS (P)
+ POPJ P,
+
+PSEUDO: MOVE F,B
+ SKIPE E
+ PUSHJ P,LSTCH2
+ MOVE B,A
+ MOVSI A,TFIX
+ JRST PSEUD1
+
+NOEXCL: JUMPE E,NOEXC1
+ MOVE F,B
+ PUSHJ P,LSTCH2
+ JRST NOEXC1
+
+; READER ERRORS COME HERE
+
+ERRPAR: PUSH TP,$TCHRS ;DO THE OFFENDER
+ PUSH TP,B
+ PUSH TP,$TCHRS
+ PUSH TP,[40] ;SPACE
+ PUSH TP,$TCHSTR
+ PUSH TP,CHQUOT UNEXPECTED
+ JRST MISMA1
+
+;COMPLAIN ABOUT MISMATCHED CLOSINGS
+
+MISMAB: SKIPA A,["]]
+MISMAT: MOVE A,-1(P) ;GOBBLE THE DESIRED CHARACTER
+ JUMPE B,CPOPJ ;IGNORE UNIVERSAL CLOSE
+ PUSH TP,$TCHRS
+ PUSH TP,B
+ PUSH TP,$TCHSTR
+ PUSH TP,CHQUOT [ INSTEAD-OF ]
+ PUSH TP,$TCHRS
+ PUSH TP,A
+MISMA1: MCALL 3,STRING
+ PUSH TP,$TATOM
+ PUSH TP,EQUOTE READER-SYNTAX-ERROR-ERRET-ANYTHING-TO-GO-ON
+ PUSH TP,A
+ PUSH TP,B
+ PUSH TP,$TATOM
+ PUSH TP,MQUOTE READ
+ MCALL 3,ERROR
+CPOPJ: POPJ P,
+\f
+; HERE ON BAD INPUT CHARACTER
+
+BADCHR: ERRUUO EQUOTE BAD-ASCII-CHARACTER
+
+; HERE ON YUCKY PARSE TABLE
+
+BADPTB: ERRUUO EQUOTE BAD-MACRO-TABLE
+
+BDPSTR: ERRUUO EQUOTE BAD-PARSE-STRING
+
+ILLSQG: PUSHJ P,LSTCHR ; DON'T MESS WITH IT AGAIN
+ ERRUUO EQUOTE BAD-USE-OF-SQUIGGLY-BRACKETS
+
+
+;FLOATING POINT NUMBER TOO LARGE OR SMALL
+FOOR: ERRUUO EQUOTE NUMBER-OUT-OF-RANGE
+
+
+NILSXP: 0,,0
+
+LSTCHR: SKIPL F,5(TB) ;GET CHANNEL
+ JRST LSTCH1 ;NO CHANNEL, POINT AT SLOT
+
+LSTCH2: SKIPE LSTCH(F) ;ARE WE REALLY FLUSHING A REUSE CHARACTER ?
+ PUSHJ P,CNTACX
+ SETZM LSTCH(F)
+ POPJ P,
+
+LSTCH1: SETZM 5(TB) ;ZERO THE LETTER AND RETURN
+ POPJ P,
+
+CNTACC: MOVE F,B
+CNTACX: HRRZ G,-2(F) ; GET BITS
+ TRNE G,C.BIN
+ JRST CNTBIN
+ AOS ACCESS(F)
+CNTDON: POPJ P,
+
+CNTBIN: AOS G,ACCESS-1(F)
+ CAMN G,[TFIX,,1]
+ AOS ACCESS(F)
+ CAMN G,[TFIX,,5]
+ HLLZS ACCESS-1(F)
+ POPJ P,
+
+
+;TABLE OF NAMES OF ARGS AND ALLOWED TYPES
+
+ARGS:
+ IRP A,,[[[CAIN C,TUNBOU]],[[CAIE C,TCHAN],INCHAN],[[PUSHJ P,CHOBL],OBLIST]]
+ IRP B,C,[A]
+ B
+ IFSN [C],IMQUOTE C
+ .ISTOP
+ TERMIN
+ TERMIN
+
+CHOBL: CAIE C,TLIST ;A LIST OR AN OBLIST
+ CAIN C,TOBLS
+ AOS (P)
+ POPJ P,
+
+END
+
+\f
\ No newline at end of file
--- /dev/null
+
+TITLE READER FOR MUDDLE
+
+;C. REEVE DEC. 1970
+
+RELOCA
+
+READER==1 ;TELL MUDDLE > TO USE SOME SPECIAL HACKS
+FRMSIN==1 ;FLAG SAYING WHETHER OR "." AND "'" HACKS EXIST
+KILTV==1 ;FLAG SAYING THAT (TVP) SHOULD BE REMOVED (MUDDLE 54 ONLY)
+
+.INSRT MUDDLE >
+
+F==PVP
+G==TVP
+
+.GLOBAL CONS,VECTOR,NXTCHR,RLOOKU,CRADIX,SPTIME,QUOTE,CHMAK,FLUSCH,IGET
+.GLOBAL SETDEV,OPNCHN,ILVAL,RADX,IDVAL,LSTCH,EVECTOR,EUVECTOR,CHUNW,NONSPC
+.GLOBAL CHRWRD,EOFCND,DIRECT,ACCESS,IOINS,ROOT,DIRECT,DOIOTI,DOACCS,IGVAL,BYTDOP
+.GLOBAL ICONS,INCONS,IEVECT,IEUVEC,BUFSTR,TYPFND,SQUTOA,SQUKIL,IBLOCK,GRB
+.GLOBAL BADCHN,WRONGD,CHNCLS,FNFFL,IPUT,IGET,ILOC,RXCT,WXCT,IUNWIN,UNWIN2
+.GLOBAL CNXTCH,CREADC,MPOPJ,CREDC1,CNXTC1,IREMAS,CBYTES,PVSTOR,SPSTOR,DSTORE
+.GLOBAL SFIX
+.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
+
+BUFLNT==100
+
+FF=0 ;FALG REGISTER DURING NUMBER CONVERSION
+
+;FLAGS USED (RIGHT HALF)
+
+NOTNUM==1 ;NOT A NUMBER
+NFIRST==2 ;NOT FIRST CHARACTER BEING READ
+DECFRC==4 ;FORCE DECIMAL CONVERSION
+NEGF==10 ;NEGATE THIS THING
+NUMWIN==20 ;DIGIT(S) SEEN
+INSTRN==40 ;IN QUOTED CHARACTER STRING
+FLONUM==100 ;NUMBER IS FLOOATING POINT
+DOTSEN==200 ;. SEEN IN IMPUT STREAM
+EFLG==400 ;E SEEN FOR EXPONENT
+FRSDOT==1000 ;. CAME FIRST
+USEAGN==2000 ;SPECIAL DOT HACK
+
+OCTWIN==4000
+OCTSTR==10000
+OVFLEW==40000
+ENEG==100000
+EPOS==200000
+;TEMPORARY OFFSETS
+
+VCNT==0 ;NUMBER OF ELEMENTS IN CURRENT VECTOR
+ONUM==-4 ;CURRENT NUMBER IN OCTAL
+DNUM==-4 ;CURRENT NUMBER IN DECIMAL
+CNUM==-2 ;IN CURRENT RADIX
+NDIGS==0 ;NUMBER OF DIGITS
+ENUM==-2 ;EXPONENT
+NUMTMP==6
+
+; TABLE OF POWERS OF TEN
+
+TENTAB: REPEAT 39. 10.0^<.RPCNT-1>
+
+ITENTB: REPEAT 11. 10.^<.RPCNT-1>
+
+
+\f; TEXT FILE LOADING PROGRAM
+
+MFUNCTION MLOAD,SUBR,[LOAD]
+
+ ENTRY
+
+ HLRZ A,AB ;GET NO. OF ARGS
+ CAIE A,-4 ;IS IT 2
+ JRST TRY2 ;NO, TRY ANOTHER
+ GETYP A,2(AB) ;GET TYPE
+ CAIE A,TOBLS ;IS IT OBLIST
+ CAIN A,TLIST ; OR LIST THEREOF?
+ JRST CHECK1
+ JRST WTYP2
+
+TRY2: CAIE A,-2 ;IS ONE SUPPLIED
+ JRST WNA
+
+CHECK1: GETYP A,(AB) ;GET TYPE
+ CAIE A,TCHAN ;IS IT A CHANNEL
+ JRST WTYP1
+
+LOAD1: HLRZ A,TB ;GET CURRENT TIME
+ PUSH TP,$TTIME ;AND SAVE IT
+ PUSH TP,A
+
+ MOVEI C,CLSNGO ; LOCATION OF FUNNY CLOSER
+ PUSHJ P,IUNWIN ; SET UP AS UNWINDER
+
+LOAD2: PUSH TP,(AB) ;USE SUPPLIED CHANNEL
+ PUSH TP,1(AB)
+ PUSH TP,(TB) ;USE TIME AS EOF ARG
+ PUSH TP,1(TB)
+ CAML AB,C%M20 ; [-2,,0] ;CHECK FOR 2ND ARG
+ JRST LOAD3 ;NONE
+ PUSH TP,2(AB) ;PUSH ON 2ND ARG
+ PUSH TP,3(AB)
+ MCALL 3,READ
+ JRST CHKRET ;CHECK FOR EOF RET
+
+LOAD3: MCALL 2,READ
+CHKRET: CAMN A,(TB) ;IS TYPE EOF HACK
+ CAME B,1(TB) ;AND IS VALUE
+ JRST EVALIT ;NO, GO EVAL RESULT
+ PUSH TP,(AB)
+ PUSH TP,1(AB)
+ MCALL 1,FCLOSE
+ MOVE A,$TCHSTR
+ MOVE B,CHQUOTE DONE
+ JRST FINIS
+
+CLSNGO: PUSH TP,$TCHAN
+ PUSH TP,1(AB)
+ MCALL 1,FCLOSE
+ JRST UNWIN2 ; CONTINUE UNWINDING
+
+EVALIT: PUSH TP,A
+ PUSH TP,B
+ MCALL 1,EVAL
+ JRST LOAD2
+
+
+
+; OTHER FILE LOADING PROGRAM
+
+
+\f
+MFUNCTION FLOAD,SUBR
+
+ ENTRY
+
+ MOVEI C,1 ;INITIALIZE OPEN'S ARG COUNT
+ PUSH TP,$TAB ;SLOT FOR SAVED AB
+ PUSH TP,C%0 ; [0] ;EMPTY FOR NOW
+ PUSH TP,$TCHSTR ;PUT IN FIRST ARG
+ PUSH TP,CHQUOTE READ
+ MOVE A,AB ;COPY OF ARGUMENT POINTER
+
+FARGS: JUMPGE A,CALOPN ;DONE? IF SO CALL OPEN
+ GETYP B,(A) ;NO, CHECK TYPE OF THIS ARG
+ CAIE B,TOBLS ;OBLIST?
+ CAIN B,TLIST ; OR LIST THEREOF
+ JRST OBLSV ;YES, GO SAVE IT
+
+ PUSH TP,(A) ;SAVE THESE ARGS
+ PUSH TP,1(A)
+ ADD A,C%22 ; [2,,2] ;BUMP A
+ AOJA C,FARGS ;COUNT AND GO
+
+OBLSV: MOVEM A,1(TB) ;SAVE THE AB
+
+CALOPN: ACALL C,FOPEN ;OPEN THE FILE
+
+ JUMPGE B,FNFFL ;FILE MUST NO EXIST
+ EXCH A,(TB) ;PLACE CHANNEL ON STACK
+ EXCH B,1(TB) ;OBTAINING POSSIBLE OBLIST
+ JUMPN B,2ARGS ;OBLIST SUOPPLIED?
+
+ MCALL 1,MLOAD ;NO, JUST CALL
+ JRST FINIS
+
+
+2ARGS: PUSH TP,(B) ;PUSH THE OBLIST
+ PUSH TP,1(B)
+ MCALL 2,MLOAD
+ JRST FINIS
+
+
+FNFFL: PUSH TP,$TATOM
+ PUSH TP,EQUOTE FILE-SYSTEM-ERROR
+ JUMPE B,CALER1
+ PUSH TP,A
+ PUSH TP,B
+ MOVEI A,2
+ JRST CALER
+
+\fMFUNCTION READ,SUBR
+
+ ENTRY
+
+ PUSH P,[SETZ IREAD1] ;WHERE TO GO AFTER BINDING
+READ0: PUSH TP,$TTP ;SLOT FOR LAST THING READ (TYPE IS UNREADABLE)
+ PUSH TP,C%0
+ PUSH TP,$TFIX ;SLOT FOR RADIX
+ PUSH TP,C%0
+ PUSH TP,$TCHAN ;AND SLOT FOR CHANNEL
+ PUSH TP,C%0
+ PUSH TP,C%0 ; USER DISP SLOT
+ PUSH TP,C%0
+ PUSH TP,$TSPLICE
+ PUSH TP,C%0 ;SEGMENT FOR SPLICING MACROS
+ JUMPGE AB,READ1 ;NO ARGS, NO BINDING
+ GETYP C,(AB) ;ISOLATE TYPE
+ CAIN C,TUNBOU
+ JRST WTYP1
+ PUSH TP,[TATOM,,-1] ;PUSH THE ATOMS
+ PUSH TP,IMQUOTE INCHAN
+ PUSH TP,(AB) ;PUSH ARGS
+ PUSH TP,1(AB)
+ PUSH TP,C%0 ;DUMMY
+ PUSH TP,C%0
+ MOVE B,1(AB) ;GET CHANNEL POINTER
+ ADD AB,C%22 ;AND ARG POINTER
+ JUMPGE AB,BINDEM ;MORE?
+ PUSH TP,[TVEC,,-1]
+ ADD B,[EOFCND-1,,EOFCND-1]
+ PUSH TP,B
+ PUSH TP,(AB)
+ PUSH TP,1(AB)
+ ADD AB,C%22
+ JUMPGE AB,BINDEM ;IF ANY MORE ARGS GO PROCESS AND BIND THEM
+ GETYP C,(AB) ;ISOLATE TYPE
+ CAIE C,TLIST
+ CAIN C,TOBLS
+ SKIPA
+ JRST WTYP3
+ PUSH TP,[TATOM,,-1] ;PUSH THE ATOMS
+ PUSH TP,IMQUOTE OBLIST
+ PUSH TP,(AB) ;PUSH ARGS
+ PUSH TP,1(AB)
+ PUSH TP,C%0 ;DUMMY
+ PUSH TP,C%0
+ ADD AB,C%22 ;AND ARG POINTER
+ JUMPGE AB,BINDEM ; ALL DONE, BIND ATOMS
+ GETYP 0,(AB) ; GET TYPE OF TABLE
+ CAIE 0,TVEC ; SKIP IF BAD TYPE
+ JRST WTYP ; ELSE COMPLAIN
+ PUSH TP,[TATOM,,-1]
+ PUSH TP,IMQUOTE READ-TABLE
+ PUSH TP,(AB)
+ PUSH TP,1(AB)
+ PUSH TP,C%0
+ PUSH TP,C%0
+ ADD AB,C%22 ; BUMP TO NEXT ARG
+ JUMPL AB,TMA ;MORE ?, ERROR
+BINDEM: PUSHJ P,SPECBIND
+ JRST READ1
+
+MFUNCTION RREADC,SUBR,READCHR
+
+ ENTRY
+ PUSH P,[SETZ IREADC]
+ JRST READC0 ;GO BIND VARIABLES
+
+MFUNCTION NXTRDC,SUBR,NEXTCHR
+
+ ENTRY
+
+ PUSH P,[SETZ INXTRD]
+READC0: CAMGE AB,C%M40 ; [-5,,]
+ JRST TMA
+ PUSH TP,(AB)
+ PUSH TP,1(AB)
+ JUMPL AB,READC1
+ MOVE B,IMQUOTE INCHAN
+ PUSHJ P,IDVAL
+ GETYP 0,A
+ CAIE 0,TCHAN
+ JRST BADCHN
+ MOVEM A,-1(TP)
+ MOVEM B,(TP)
+READC1: PUSHJ P,@(P)
+ JRST .+2
+ JRST FINIS
+
+ PUSH TP,-1(TP)
+ PUSH TP,-1(TP)
+ MCALL 1,FCLOSE
+ MOVE A,EOFCND-1(B)
+ MOVE B,EOFCND(B)
+ CAML AB,C%M20 ; [-3,,]
+ JRST .+3
+ MOVE A,2(AB)
+ MOVE B,3(AB)
+ PUSH TP,A
+ PUSH TP,B
+ MCALL 1,EVAL
+ JRST FINIS
+
+
+MFUNCTION PARSE,SUBR
+
+ ENTRY
+
+ PUSHJ P,GAPRS ;GET ARGS FOR PARSES
+ PUSHJ P,GPT ;GET THE PARSE TABLE
+ PUSHJ P,NXTCH ; GET A CHAR TO TEST FOR ! ALT
+ SKIPN 11.(TB) ; EOF HIT, COMPLAIN TO LOOSER
+ JRST NOPRS
+ MOVEI A,33 ; CHANGE IT TO AN ALT, SNEAKY HUH?
+ CAIN B,MANYT ; TYPE OF MULTIPLE CLOSE, I.E. ! ALT
+ MOVEM A,5(TB)
+ PUSHJ P,IREAD1 ;GO DO THE READING
+ JRST .+2
+ JRST LPSRET ;PROPER EXIT
+NOPRS: ERRUUO EQUOTE CAN'T-PARSE
+
+MFUNCTION LPARSE,SUBR
+
+ ENTRY
+
+ PUSHJ P,GAPRS ;GET THE ARGS TO THE PARSE
+ JRST LPRS1
+
+GAPRS: PUSH TP,$TTP
+ PUSH TP,C%0
+ PUSH TP,$TFIX
+ PUSH TP,[10.]
+ PUSH TP,$TFIX
+ PUSH TP,C%0 ; LETTER SAVE
+ PUSH TP,C%0
+ PUSH TP,C%0 ; PARSE TABLE MAYBE?
+ PUSH TP,$TSPLICE
+ PUSH TP,C%0 ;SEGMENT FOR SPLICING MACROS
+ PUSH TP,C%0 ;SLOT FOR LOCATIVE TO STRING
+ PUSH TP,C%0
+ JUMPGE AB,USPSTR
+ PUSH TP,[TATOM,,-1]
+ PUSH TP,IMQUOTE PARSE-STRING
+ PUSH TP,(AB)
+ PUSH TP,1(AB) ; BIND OLD PARSE-STRING
+ PUSH TP,C%0
+ PUSH TP,C%0
+ PUSHJ P,SPECBIND
+ ADD AB,C%22
+ JUMPGE AB,USPSTR
+ GETYP 0,(AB)
+ CAIE 0,TFIX
+ JRST WTYP2
+ MOVE 0,1(AB)
+ MOVEM 0,3(TB)
+ ADD AB,C%22
+ JUMPGE AB,USPSTR
+ GETYP 0,(AB)
+ CAIE 0,TLIST
+ CAIN 0,TOBLS
+ SKIPA
+ JRST WTYP3
+ PUSH TP,[TATOM,,-1]
+ PUSH TP,IMQUOTE OBLIST
+ PUSH TP,(AB)
+ PUSH TP,1(AB) ; HE WANTS HIS OWN OBLIST
+ PUSH TP,C%0
+ PUSH TP,C%0
+ PUSHJ P,SPECBIND
+ ADD AB,C%22
+ JUMPGE AB,USPSTR
+ GETYP 0,(AB)
+ CAIE 0,TVEC
+ JRST WTYP
+ PUSH TP,[TATOM,,-1]
+ PUSH TP,IMQUOTE PARSE-TABLE
+ PUSH TP,(AB)
+ PUSH TP,1(AB)
+ PUSH TP,C%0
+ PUSH TP,C%0
+ PUSHJ P,SPECBIND
+ ADD AB,C%22
+ JUMPGE AB,USPSTR
+ GETYP 0,(AB)
+ CAIE 0,TCHRS
+ JRST WTYP
+ MOVE 0,1(AB)
+ MOVEM 0,5(TB) ; STUFF IN A LOOK-AHEAD CHARACTER IF HE WANTS
+ ADD AB,C%22
+ JUMPL AB,TMA
+USPSTR: MOVE B,IMQUOTE PARSE-STRING
+ PUSHJ P,ILOC ; GET A LOCATIVE TO THE STRING, WHEREVER
+ GETYP 0,A
+ CAIN 0,TUNBOUND ; NONEXISTANT
+ JRST BDPSTR
+ GETYP 0,(B) ; IT IS POINTING TO A STRING
+ CAIE 0,TCHSTR
+ JRST BDPSTR
+ MOVEM A,10.(TB)
+ MOVEM B,11.(TB)
+ POPJ P,
+
+LPRS1: PUSHJ P,GPT ; GET THE VALUE OF PARSE-TABLE IN SLOT
+ PUSH TP,$TLIST
+ PUSH TP,C%0 ; HERE WE ARE MAKE PLACE TO SAVE GOODIES
+ PUSH TP,$TLIST
+ PUSH TP,C%0
+LPRS2: PUSHJ P,IREAD1
+ JRST LPRSDN ; IF WE ARE DONE, WE ARE THROUGH
+ MOVE C,A
+ MOVE D,B
+ PUSHJ P,INCONS
+ SKIPN -2(TP)
+ MOVEM B,-2(TP) ; SAVE THE BEGINNING ON FIRST
+ SKIPE C,(TP)
+ HRRM B,(C) ; PUTREST INTO IT
+ MOVEM B,(TP)
+ JRST LPRS2
+LPRSDN: MOVSI A,TLIST
+ MOVE B,-2(TP)
+LPSRET: SKIPLE C,5(TB) ; EXIT FOR PARSE AND LPARSE
+ CAIN C,400033 ; SEE IF NO PEEK AHEAD OR IF ! ALTMODE
+ JRST FINIS ; IF SO NO NEED TO BACK STRING ONE
+ SKIPN C,11.(TB)
+ JRST FINIS ; IF ATE WHOLE STRING, DONT GIVE BACK ANY
+BUPRS: MOVEI D,1
+ ADDM D,(C) ; AOS THE COUNT OF STRING LENGTH
+ SKIPG D,1(C) ; SEXIER THAN CLR'S CODE FOR DECREMENTING
+ SUB D,[430000,,1] ; A BYTE POINTER
+ ADD D,[70000,,0]
+ MOVEM D,1(C)
+ HRRZ E,2(TB)
+ JUMPE E,FINIS ; SEE IF WE NEED TO BACK UP TWO
+ HLLZS 2(TB) ; CLEAR OUT DOUBLE CHR LOOKY FLAG
+ JRST BUPRS ; AND BACK UP PARSE STRING A LITTLE MORE
+
+\f; ARGUMENTS ARE BOUND, NOW GET THE VALUES OF THINGS
+
+
+GRT: MOVE B,IMQUOTE READ-TABLE
+ SKIPA ; HERE TO GET TABLE FOR READ
+GPT: MOVE B,IMQUOTE PARSE-TABLE
+ MOVSI A,TATOM ; TO FILL SLOT WITH PARSE TABLE
+ PUSHJ P,ILVAL
+ GETYP 0,A
+ CAIN 0,TUNBOUND
+ POPJ P,
+ CAIE 0,TVEC
+ JRST BADPTB
+ MOVEM A,6(TB)
+ MOVEM B,7(TB)
+ POPJ P,
+
+READ1: PUSHJ P,GRT
+ MOVE B,IMQUOTE INCHAN
+ MOVSI A,TATOM
+ PUSHJ P,IDVAL ;NOW GOBBLE THE REAL CHANNEL
+ TLZ A,TYPMSK#777777
+ HLLZS A ; INCASE OF FUNNY BUG
+ CAME A,$TCHAN ;IS IT A CHANNEL
+ JRST BADCHN
+ MOVEM A,4(TB) ; STORE CHANNEL
+ MOVEM B,5(TB)
+ HRRZ A,-2(B)
+ TRNN A,C.OPN
+ JRST CHNCLS
+ TRNN A,C.READ
+ JRST WRONGD
+ HLLOS 4(TB)
+ TRNE A,C.BIN ; SKIP IF NOT BIN
+ JRST BREAD ; CHECK FOR BUFFER
+ HLLZS 4(TB)
+GETIOA: MOVE B,5(TB)
+GETIO: MOVE A,IOINS(B) ;GOBBLE THE I/O INSTRUCTION
+ JUMPE A,OPNFIL ;GO REALLY OPEN THE CROCK
+ MOVE A,RADX(B) ;GET RADIX
+ MOVEM A,3(TB)
+ MOVEM B,5(TB) ;SAVE CHANNEL
+REREAD: HRRZ D,LSTCH(B) ;ANY CHARS AROUND?
+ MOVEI 0,33
+ CAIN D,400033 ;FLUSH THE TERMINATOR HACK
+ HRRM 0,LSTCH(B) ; MAKE ! ALT INTO JUST ALT IF IT IS STILL AROUND
+
+ PUSHJ P,@(P) ;CALL INTERNAL READER
+ JRST BADTRM ;LOST
+RFINIS: SUB P,C%11 ;POP OFF LOSER
+ PUSH TP,A
+ PUSH TP,B
+ JUMPE C,FLSCOM ; FLUSH TOP LEVEL COMMENT
+ PUSH TP,C
+ PUSH TP,D
+ MOVE A,4(TB)
+ MOVE B,5(TB) ; GET CHANNEL
+ MOVSI C,TATOM
+ MOVE D,IMQUOTE COMMENT
+ PUSHJ P,IPUT
+RFINI1: POP TP,B
+ POP TP,A
+ JRST FINIS
+
+FLSCOM: MOVE A,4(TB)
+ MOVE B,5(TB)
+ MOVSI C,TATOM
+ MOVE D,IMQUOTE COMMENT
+ PUSHJ P,IREMAS
+ JRST RFINI1
+
+BADTRM: MOVE C,5(TB) ; GET CHANNEL
+ JUMPGE B,CHLSTC ;NO, MUST BE UNMATCHED PARENS
+ SETZM LSTCH(C) ; DONT REUSE EOF CHR
+ PUSH TP,4(TB) ;CLOSE THE CHANNEL
+ PUSH TP,5(TB)
+ MCALL 1,FCLOSE
+ PUSH TP,EOFCND-1(B)
+ PUSH TP,EOFCND(B)
+ MCALL 1,EVAL ;AND EVAL IT
+ SETZB C,D
+ GETYP 0,A ; CHECK FOR FUNNY ACT
+ CAIE 0,TREADA
+ JRST RFINIS ; AND RETURN
+
+ PUSHJ P,CHUNW ; UNWIND TO POINT
+ MOVSI A,TREADA ; SEND MESSAGE BACK
+ JRST CONTIN
+
+;HERE TO ATTEMPT TO OPEN A CLOSED CHANNEL
+
+OPNFIL: PUSHJ P,OPNCHN ;GO DO THE OPEN
+ JUMPGE B,FNFFL ;LOSE IC B IS 0
+ JRST GETIO
+
+
+CHLSTC: MOVE B,5(TB) ;GET CHANNEL BACK
+ JRST REREAD
+
+
+BREAD: MOVE B,5(TB) ; GET CHANNEL
+ SKIPE BUFSTR(B)
+ JRST GETIO
+ MOVEI A,BUFLNT ; GET A BUFFER
+ PUSHJ P,IBLOCK
+ MOVEI C,BUFLNT(B) ; POINT TO END
+ HRLI C,440700
+ MOVE B,5(TB) ; CHANNEL BACK
+ MOVEI 0,C.BUF
+ IORM 0,-2(B)
+ MOVEM C,BUFSTR(B)
+ MOVSI C,TCHSTR+.VECT.
+ MOVEM C,BUFSTR-1(B)
+ JRST GETIO
+\f;MAIN ENTRY TO READER
+
+NIREAD: PUSHJ P,LSTCHR
+NIREA1: PUSH P,C%M1 ; [-1] ; DONT GOBBLE COMMENTS
+ JRST IREAD2
+
+IREAD:
+ PUSHJ P,LSTCHR ;DON'T REREAD LAST CHARACTER
+IREAD1: PUSH P,C%0 ; FLAG SAYING SNARF COMMENTS
+IREAD2: INTGO
+BDLP: SKIPE C,9.(TB) ;HAVE WE GOT A SPLICING MACRO LEFT
+ JRST SPLMAC ;IF SO GIVE HIM SOME OF IT
+ PUSHJ P,NXTCH ;GOBBLE CHAR IN A AND TYPE IN D
+ MOVMS B ; FOR SPECIAL NEG HACK OF MACRO TABLES
+ CAIG B,ENTYPE
+ JUMPN B,@DTBL-1(B) ;ERROR ON ZERO TYPE OR FUNNY TYPE
+ JRST BADCHR
+
+
+SPLMAC: HRRZ D,(C) ;GET THE REST OF THE SEGMENT
+ MOVEM D,9.(TB) ;AND PUT BACK IN PLACE
+ GETYP D,(C) ;SEE IF DEFERMENT NEEDED
+ CAIN D,TDEFER
+ MOVE C,1(C) ;IF SO, DO DEFEREMENT
+ MOVE A,(C)
+ MOVE B,1(C) ;GET THE GOODIE
+ AOS -1(P) ;ALWAYS A SKIP RETURN
+ POP P,(P) ;DONT WORRY ABOUT COMMENT SEARCHAGE
+ SETZB C,D ;MAKE SURE HE DOESNT THINK WE GOT COMMENT
+ POPJ P, ;GIVE HIM WHAT HE DESERVES
+
+DTBL:
+CODINI==0
+IRP A,,[[LETCOD,LETTER],[NUMCOD,NUMBER],[PLUCOD,PNUMBE],[NEGCOD,NNUMBE],[ASTCOD,ASTSTR],[DOTTYP,DOTSTR],[ETYPE,LETTER]
+[SPATYP,SPACE],[LPATYP,LPAREN],[RPATYP,RPAREN],[LBRTYP,LBRACK],[RBRTYP,RBRACK]
+[QUOTYP,QUOTIT],[MACTYP,MACCAL],[CSTYP,CSTRING],[ESCTYP,ESCSTR],[SPCTYP,SPECTY]
+[SLMNT,OPNANG],[CNGTYP,CLSANG],[EOFTYP,EOFCHR],[COMTYP,COMNT],[GLMNT,GLOVAL]
+[TMPTYP,ILLSQG],[NTYPES,CLSBRA],[EXCEXC,LETTER],[DOTEXT,SEGDOT],[LBREXT,UVECIN]
+[RBREXT,RBRACK],[QUOEXT,QUOSEG],[CSEXT,SINCHR],[SLMEXT,SEGIN],[ELMEXT,CLSANG]
+[GLMEXT,GLOSEG],[PATHTY,LOSPATH],[BSLEXT,SINCHR],[MANYT,TERM],[USTYP1,USRDS1]
+[USTYP2,USRDS2]]
+
+ IRP B,C,[A]
+ CODINI==CODINI+1
+ B==CODINI
+ SETZ C
+ .ISTOP
+ TERMIN
+TERMIN
+
+EXPUNGE CODINI
+
+ENTYPE==.-DTBL
+
+NONSPC==ETYPE
+
+SPACE: PUSHJ P,LSTCHR ;DONT REREAD SPACER
+ JRST BDLP
+
+USRDS1: SKIPA B,A ; GET CHAR IN B
+USRDS2: MOVEI B,200(A) ; ! CHAR, DISP 200 FURTHER
+ ASH B,1
+ ADD B,7(TB) ; POINT TO TABLE ENTRY
+ GETYP 0,(B)
+ CAIN 0,TLIST
+ MOVE B,1(B) ; IF LIST, USE FIRST ITEM-SPECIAL NO BREAK HACK
+ SKIPL C,5(TB) ; GET CHANNEL POINTER (IF ANY)
+ JRST USRDS3
+ ADD C,[EOFCND-1,,EOFCND-1]
+ PUSH TP,$TBVL
+ MOVE SP,SPSTOR+1
+ HRRM SP,(TP) ; BUILD A TBVL
+ MOVE SP,TP
+ MOVEM SP,SPSTOR+1
+ PUSH TP,C
+ PUSH TP,(C)
+ PUSH TP,1(C)
+ MOVE PVP,PVSTOR+1
+ MOVEI D,PVLNT*2+1(PVP)
+ HRLI D,TREADA
+ MOVEM D,(C)
+ MOVEI D,(TB)
+ HLL D,OTBSAV(TB)
+ MOVEM D,1(C)
+USRDS3: PUSH TP,(B) ; APPLIER
+ PUSH TP,1(B)
+ PUSH TP,$TCHRS ; APPLY TO CHARACTER
+ PUSH TP,A
+ PUSHJ P,LSTCHR ; FLUSH CHAR
+ MCALL 2,APPLY ; GO TO USER GOODIE
+ SKIPL 5(TB)
+ JRST USRDS9
+ MOVE SP,SPSTOR+1
+ HRRZ E,1(SP) ; POINT TO EOFCND SLOT
+ HRRZ SP,(SP) ; UNBIND MANUALLY
+ MOVEI D,(TP)
+ SUBI D,(SP)
+ MOVSI D,(D)
+ HLL SP,TP
+ SUB SP,D
+ MOVEM SP,SPSTOR+1
+ POP TP,1(E)
+ POP TP,(E)
+ SUB TP,C%22 ; FLUSH TP CRAP
+USRDS9: GETYP 0,A ; CHECK FOR DISMISS?
+ CAIN 0,TSPLICE
+ JRST GOTSPL ; RETURN OF SEGMENT INDICATES SPLICAGE
+ CAIN 0,TREADA ; FUNNY?
+ JRST DOEOF
+ CAIE 0,TDISMI
+ JRST RET ; NO, RETURN FROM IREAD
+ JRST BDLP ; YES, IGNORE RETURN
+
+GOTSPL: MOVEM B,9.(TB) ; STICK IN THE SPLICAGE SLOT SO IREADS WILL GET HIM
+ JRST BDLP ; GO BACK AND READ FROM OUR SPLICE, OK?
+
+\f
+;HERE ON NUMBER OR LETTER, START ATOM
+
+ESCSTR: PUSHJ P,NXTC1 ; ESCAPE FIRST
+LETTER: MOVEI FF,NOTNUM ; LETTER
+ JRST ATMBLD
+
+ASTSTR: MOVEI FF,OCTSTR
+DOTST1: MOVEI B,0
+ JRST NUMBLD
+
+NUMBER: MOVEI FF,NUMWIN ; SYMBOL OR NUMBER
+NUMBR1: MOVEI B,(A) ; TO A NUMBER
+ SUBI B,60
+ JRST NUMBLD
+
+PNUMBE: SETZB FF,B
+ JRST NUMBLD
+
+NNUMBE: MOVEI FF,NEGF
+ MOVEI B,0
+
+NUMBLD: PUSH TP,$TFIX
+ PUSH TP,B
+ PUSH TP,$TFIX
+ PUSH TP,B
+ PUSH TP,$TFIX
+ PUSH TP,C%0
+
+ATMBLD: LSH A,<36.-7>
+ PUSH P,A
+ MOVEI D,1 ; D IS CHAR COUNT
+ MOVSI C,350700+P ; BYTE PNTR
+ PUSHJ P,LSTCHR
+
+ATLP: PUSH P,FF
+ INTGO
+
+ PUSHJ P,NXTCH ; GET NEXT CHAR
+ POP P,FF
+ TRNN FF,NOTNUM ; IF NOT NUMBER, SKIP
+ JRST NUMCHK
+
+ATLP2: CAILE B,NONSPC ; SKIP IF STILL LETTER OR NUMBER
+ JRST CHKEND
+
+ATLP1: PUSHJ P,LSTCHR ; DONT REUSE
+ IDPB A,C ; INTO ATOM
+ TLNE C,760000 ; SKIP IF OK WORD
+ AOJA D,ATLP
+
+ PUSH P,C%0
+ MOVSI C,440700+P
+ AOJA D,ATLP
+
+CHKEND: CAIN B,ESCTYP ; ESCAPE?
+ JRST DOESC1
+
+CHKEN1: SKIPGE C ; SKIP IF TOP SLOT FULL
+ SUB P,C%11
+ PUSH P,D ; COUNT OF CHARS
+
+ JRST LOOPA ; GO HACK TRAILERS
+
+
+; HERE IF STILL COULD BE A NUMBER
+
+NUMCHK: CAIN B,NUMCOD ; STILL NUMBER
+ JRST NUMCH1
+
+ CAILE B,NONSPC ; NUMBER FINISHED?
+ JRST NUMCNV
+
+ CAIN B,DOTTYP
+ TROE FF,DOTSEN
+ JRST NUMCH2
+ TRNE FF,OCTSTR+EFLG
+ JRST NUMCH3 ; NO . IN OCTAL OR EXPONENT
+ TRO FF,DECFRC ; MUST BE DECIMAL NOW
+ JRST ATLP1
+
+NUMCH1: TRO FF,NUMWIN
+ MOVEI B,(A)
+ SUBI B,60
+ TRNE FF,OCTSTR+OCTWIN ; IS THIS *DDDDDD* HACK
+ JRST NUMCH4 ; YES, GO DO IT
+ TRNE FF,EFLG
+ JRST NUMCH7 ; DO EXPONENT
+
+ TRNE FF,DOTSEN ; FORCE FLOAT
+ JRST NUMCH5
+
+ JFCL 17,.+1 ; KILL ALL FLAGS
+ MOVE E,CNUM(TP) ; COMPUTE CURRENT RADIX
+ IMUL E,3(TB)
+ ADDI E,(B) ; ADD IN CURRENT DIGIT
+ JFCL 10,.+3
+ MOVEM E,CNUM(TP)
+ JRST NUMCH6
+
+ MOVE E,3(TB) ; SEE IF CURRENT RADIX DECIMAL
+ CAIE E,10.
+ JRST NUMCH5 ; YES, FORCE FLOAT
+ TROA FF,OVFLEW
+
+NUMCH5: TRO FF,FLONUM ; SET FLOATING FLAG
+NUMCH6: JFCL 17,.+1 ; CLEAR ALL FLAGS
+ MOVE E,DNUM(TP) ; GET DECIMAL NUMBER
+ IMULI E,10.
+ JFCL 10,NUMCH8 ; JUMP IF OVERFLOW
+ ADDI E,(B) ; ADD IN DIGIT
+ MOVEM E,DNUM(TP)
+ TRNE FF,FLONUM ; IS THIS FRACTION?
+ SOS NDIGS(TP) ; YES, DECREASE EXPONENT BY ONE
+ JRST ATLP1
+
+NUMCH8: TRNE FF,DOTSEN ; OVERFLOW IN DECMIMAL
+ JRST ATLP1 ; OK, IN FRACTION
+
+ AOS NDIGS(TP)
+ TRO FF,FLONUM ; MAKE IT FLOATING TO FIT
+ JRST ATLP1
+
+NUMCH4: TRNE FF,OCTWIN
+ JRST NUMCH3 ; ALREADY ONE, MORE DIGITS LOSE
+ MOVE E,ONUM(TP)
+ TLNE E,700000 ; SKIP IF WORD NOT FULL
+ TRO FF,OVFLEW
+ LSH E,3
+ ADDI E,(B) ; ADD IN NEW ONE
+ MOVEM E,ONUM(TP)
+ JRST ATLP1
+
+NUMCH3: SUB TP,[NUMTMP,,NUMTMP] ; FLUSH NUMBER CRUFT
+ TRO FF,NOTNUM
+ JRST ATLP2
+
+NUMCH2: CAIN B,ASTCOD ; POSSIBLE END OF OCTAL
+ TRZN FF,OCTSTR ; RESET FLAG AND WIN
+ JRST NUMCH9
+
+ TRO FF,OCTWIN
+ JRST ATLP2
+
+NUMCH9: CAIN B,ETYPE
+ TROE FF,EFLG
+ JRST NUMC10 ; STILL COULD BE +- EXPONENT
+
+ TRZ FF,NUMWIN ; IN CASE NO MORE DIGITS
+ SETZM ENUM(TP)
+ JRST ATLP1
+
+NUMCH7: MOVE E,ENUM(TP)
+ IMULI E,10.
+ ADDI E,(B)
+ MOVEM E,ENUM(TP) ; UPDATE ECPONENT
+ TRO FF,EPOS ; FLUSH IF SIGN COMES NOW
+ JRST ATLP1
+
+NUMC10: TRNE FF,ENEG+EPOS ; SIGN FOR EXPONENT SEEN?
+ JRST NUMCH3 ; NOT A NUMBER
+ CAIN B,PLUCOD
+ TRO FF,EPOS
+ CAIN B,NEGCOD
+ TRO FF,ENEG
+ TRNE FF,EPOS+ENEG
+ JRST ATLP1
+ JRST NUMCH3
+
+; HERE AFTER \ QUOTER
+
+DOESC1: PUSHJ P,NXTC1 ; GET CHAR
+ JRST ATLP1 ; FALL BACK INTO LOOP
+
+
+; HERE TO CONVERT NUMBERS AS NEEDED
+
+NUMCNV: CAIE B,ESCTYP
+ TRNE FF,OCTSTR
+ JRST NUMCH3
+ TRNN FF,NUMWIN
+ JRST NUMCH3
+ ADDI D,4
+ IDIVI D,5
+ SKIPGE C ; SKIP IF NEW WORD ADDED
+ ADDI D,1
+ HRLI D,(D) ; TOO BOTH HALVES
+ SUB P,D ; REMOVE CHAR STRING
+ MOVE D,3(TB) ; IS RADIX 10?
+ CAIE D,10.
+ TRNE FF,DECFRC
+ TRNN FF,FLONUM+EFLG ;IS IT A FLOATING POINT NUMBER
+ TRNE FF,EFLG
+ JRST FLOATIT ;YES, GO MAKE IT WIN
+ TRNE FF,OVFLEW
+ JRST FOOR
+ MOVE B,CNUM(TP)
+ TRNE FF,DECFRC
+ MOVE B,DNUM(TP) ;GRAB FIXED GOODIE
+ TRNE FF,OCTWIN ; SKIP IF NOT OCTAL
+ MOVE B,ONUM(TP) ; USE OCTAL VALUE
+FINID2: MOVSI A,TFIX ;SAY FIXED POINT
+FINID1: TRNE FF,NEGF ;NEGATE
+ MOVNS B ;YES
+ SUB TP,[NUMTMP,,NUMTMP] ;FINISH HACK
+ JRST RET ;AND RETURN
+
+\f
+FLOATIT:
+ JFCL 17,.+1 ;CLEAR ALL ARITHMETIC FLAGS
+ TRNE FF,EFLG ;"E" SEEN?
+ JRST EXPDO ;YES, DO EXPONENT
+ MOVE D,NDIGS(TP) ;GET IMPLICIT EXPONENT
+
+FLOATE: MOVE A,DNUM(TP) ;GET DECIMAL NUMBER
+ IDIVI A,400000 ;SPLIT
+ FSC A,254 ;CONVERT MOST SIGNIFICANT
+ FSC B,233 ; AND LEAST SIGNIFICANT
+ FADR B,A ;COMBINE
+
+ MOVM A,D ;GET MAGNITUDE OF EXPONENT
+ MOVSI E,(1.0)
+ JFCL 17,.+1 ; CLEAR ALL OVERFLOW/UNDERFLOW BITS
+ CAIG A,38. ;HOW BIG?
+ JRST .+3 ;TOO BIG-FLOATING OUT OF RANGE
+ MOVE E,[1.0^38.]
+ SUBI A,38.
+ JUMPGE D,FLOAT1 ;JUMP IF EXPONENT POSITIVE
+ FDVR B,E
+ FDVR B,TENTAB(A) ;DIVIDE BY TEN TO THE EXPONENT
+ JRST SETFLO
+
+FLOAT1: FMPR B,E
+ FMPR B,TENTAB(A) ;SCALE UP
+
+SETFLO: JFCL 17,FOOR ;FLOATING OUT OF RANGE ON OVERFLOW
+ MOVSI A,TFLOAT
+ TRZ FF,FRSDOT ;FLOATING NUMBER NOT VALUE
+ JRST FINID1
+
+EXPDO:
+ HRRZ D,ENUM(TP) ;GET EXPONENT
+ TRNE FF,ENEG ;IS EXPONENT NEGATIVE?
+ MOVNS D ;YES
+ ADD D,NDIGS(TP) ;ADD IMPLICIT EXPONENT
+ JUMPL D,FLOATE ;FLOATING IF EXPONENT NEGATIVE
+ CAIG D,10. ;OR IF EXPONENT TOO LARGE
+ TRNE FF,FLONUM ;OR IF FLAG SET
+ JRST FLOATE
+ MOVE B,DNUM(TP) ;
+ IMUL B,ITENTB(D)
+ JFCL 10,FLOATE ;IF OVERFLOW, MAKE FLOATING
+ JRST FINID2 ;GO MAKE FIXED NUMBER
+
+
+; HERE TO START BUILDING A CHARACTER STRING GOODIE
+
+CSTRING:
+ PUSH P,C%0
+ MOVEI D,0 ; CHARCOUNT
+ MOVSI C,440700+P ; AND BYTE POINTER
+
+CSLP: PUSH P,FF
+ INTGO
+ PUSHJ P,NXTC1 ; GET NEXT CHAR
+ POP P,FF
+
+ CAIN B,CSTYP ; END OF STRING?
+ JRST CSLPEND
+
+ CAIN B,ESCTYP ; ESCAPE?
+ PUSHJ P,NXTC1
+
+ IDPB A,C ; INTO ATOM
+ TLNE C,760000 ; SKIP IF OK WORD
+ AOJA D,CSLP
+
+ PUSH P,C%0
+ MOVSI C,440700+P
+ AOJA D,CSLP
+
+CSLPEND:
+ SKIPGE C
+ SUB P,C%11
+ PUSH P,D
+ PUSHJ P,CHMAK
+ PUSHJ P,LSTCHR
+
+ JRST RET
+
+;ARRIVE HERE TO INVOKE A READ TIME MACRO FUNCTION
+
+MACCAL: PUSHJ P,NXTCH1 ;READ ONE MORE CHARACTER
+ CAIE B,MACTYP ;IS IT ANOTHER MACRO CHAR
+
+ JRST MACAL2 ;NO, CALL MACRO AND USE VALUE
+ PUSHJ P,LSTCHR ;DONT REREAD %
+ PUSHJ P,MACAL1 ;OTHERWISE, USE SIDE EFFECCT, BUT NOT VALUE
+ JRST IREAD2
+
+MACAL2: PUSH P,CRET
+MACAL1: PUSHJ P,IREAD1 ;READ FUNCTION NAME
+ PUSHJ P,RETERR
+ PUSH TP,C
+ PUSH TP,D ; SAVE COMMENT IF ANY
+ PUSH TP,A ;SAVE THE RESULT
+ PUSH TP,B ;AND USE IT AS AN ARGUMENT
+ MCALL 1,EVAL
+ POP TP,D
+ POP TP,C ; RESTORE COMMENT IF ANY...
+CRET: POPJ P,RET12
+
+;CALL GOBBLE TO FIND THE TYPE AND THEN IREAD TO READ IT
+
+SPECTY: PUSHJ P,NIREAD ; READ THE TYPES NAME (SHOULD BE AN ATOM)
+ PUSHJ P,RETERR
+ PUSH TP,A
+ PUSH TP,B
+ GETYP A,A
+ CAIN A,TFIX
+ JRST BYTIN
+ PUSHJ P,NXTCH ; GET NEXT CHAR
+ CAIN B,TMPTYP ; SKIP IF NOT TEMPLATE START
+ JRST RDTMPL
+ SETZB A,B
+ EXCH A,-1(TP)
+ EXCH B,(TP)
+ PUSH TP,A ;BEGIN SETTING UP CHTYPE CALL
+ PUSH TP,B
+ PUSHJ P,IREAD1 ;NOW READ STRUCTURE
+ PUSHJ P,RETERR
+ MOVEM C,-3(TP) ; SAVE COMMENT
+ MOVEM D,-2(TP)
+ EXCH A,-1(TP) ;USE AS FIRST ARG
+ EXCH B,(TP)
+ PUSH TP,A ;USE OTHER AS 2D ARG
+ PUSH TP,B
+ MCALL 2,CHTYPE ;ATTEMPT TO MUNG
+RET13: POP TP,D
+ POP TP,C ; RESTORE COMMENT
+RET12: SETOM (P) ; DONT LOOOK FOR MORE!
+ JRST RET
+
+RDTMPL: PUSH P,["}] ; SET UP TERMINATE TEST
+ MOVE B,(TP)
+ PUSHJ P,IGVAL
+ MOVEM A,-1(TP)
+ MOVEM B,(TP)
+ PUSH P,[BLDTMP] ; FLAG FOR VECTOR READING CODE
+ JRST LBRAK2
+
+BLDTMP: ADDI A,1 ; 1 MORE ARGUMENT
+ ACALL A,APPLY ; DO IT TO IT
+ POPJ P,
+
+BYTIN: PUSHJ P,NXTCH ; CHECK FOR OPENR
+ CAIN B,SPATYP
+ PUSHJ P,SPACEQ
+ JRST .+3
+ PUSHJ P,LSTCHR
+ JRST BYTIN
+ CAIE B,TMPTYP
+ ERRUUO EQUOTE BAD-USE-OF-BYTE-STRING
+ PUSH P,["}]
+ PUSH P,[CBYTE1]
+ JRST LBRAK2
+
+CBYTE1: AOJA A,CBYTES
+
+RETERR: SKIPL A,5(TB)
+ MOVEI A,5(TB)-LSTCH ;NO CHANNEL, USE SLOT
+ HRRM B,LSTCH(A) ; RESTORE LAST CHAR
+ PUSHJ P,ERRPAR
+ SOS (P)
+ SOS (P)
+ POPJ P,
+
+\f
+;THIS CODE CALLS IREAD RECURSIVELY TO READ THAT WHICH IS
+;BETWEEN (), ARRIVED AT WHEN ( IS READ
+
+SEGIN: PUSH TP,$TSEG
+ JRST OPNAN1
+
+OPNANG: PUSH TP,$TFORM ;SAVE TYPE
+OPNAN1: PUSH P,[">]
+ JRST LPARN1
+
+LPAREN: PUSH P,[")]
+ PUSH TP,$TLIST ;START BY ASSUMING NIL
+LPARN1: PUSH TP,C%0
+ PUSHJ P,LSTCHR ;DON'T REREAD PARENS
+LLPLOP: PUSHJ P,IREAD1 ;READ IT
+ JRST LDONE ;HIT TERMINATOR
+
+;HERE WHEN MUST ADD CAR TO CURRENT WINNER
+
+GENCAR: PUSH TP,C ; SAVE COMMENT
+ PUSH TP,D
+ MOVE C,A ; SET UP CALL
+ MOVE D,B
+ PUSHJ P,INCONS ; CONS ON TO NIL
+ POP TP,D
+ POP TP,C
+ POP TP,E ;GET CDR
+ JUMPN E,CDRIN ;IF STACKED GOODIE NOT NIL SKIP
+ PUSH TP,B ;AND USE AS TOTAL VALUE
+ PUSH TP,$TLIST ;SAVE THIS AS FIRSST THING ON LIST
+ MOVE A,-2(TP) ; GET REAL TYPE
+ JRST .+2 ;SKIP CDR SETTING
+CDRIN: HRRM B,(E)
+ PUSH TP,B ;CLOBBER IN NEW PARTIAL GOODIE
+ JUMPE C,LLPLOP ; JUMP IF NO COMMENT
+ PUSH TP,C
+ PUSH TP,D
+ MOVSI C,TATOM
+ MOVE D,IMQUOTE COMMENT
+ PUSHJ P,IPUT
+ JRST LLPLOP ;AND CONTINUE
+
+; HERE TO RAP UP LIST
+
+LDONE: CAME B,(P) ;CHECK VALIDITY OF CHARACTER
+ PUSHJ P,MISMAT ;REPORT MISMATCH
+ SUB P, C%11
+ POP TP,B ;GET VALUE OF PARTIAL RESULT
+ POP TP,A ;AND TYPE OF SAME
+ JUMPE B,RET ;VALUE IS NIL, DON'T POP AGAIN
+ POP TP,B ;POP FIRST LIST ELEMENT
+ POP TP,A ;AND TYPE
+ JRST RET
+\f
+;THIS CODE IS SIMILAR TO LIST GENERATING CODE BUT IS FOR VECTORS
+OPNBRA: PUSH P,["}] ; SAVE TERMINATOR
+UVECIN: PUSH P,[135] ; CLOSE SQUARE BRACKET
+ PUSH P,[SETZ IEUVECTOR] ;PUSH NAME OF U VECT HACKER
+ JRST LBRAK2 ;AND GO
+
+LBRACK: PUSH P,[135] ; SAVE TERMINATE
+ PUSH P,[SETZ IEVECTOR] ;PUSH GEN VECTOR HACKER
+LBRAK2: PUSHJ P,LSTCHR ;FORCE READING NEW CHAR
+ PUSH P,C%0 ; COUNT ELEMENTS
+ PUSH TP,$TLIST ; AND SLOT FOR GOODIES
+ PUSH TP,C%0
+
+LBRAK1: PUSHJ P,IREAD1 ;RECURSIVELY READ ELEMENTS OF ARRAY
+ JRST LBDONE ;RAP UP ON TERMINATOR
+
+STAKIT: EXCH A,-1(TP) ; STORE RESULT AND GET CURRENT LIST
+ EXCH B,(TP)
+ AOS (P) ; COUNT ELEMENTS
+ JUMPE C,LBRAK3 ; IF NO COMMENT, GO ON
+ MOVEI E,(B) ; GET CDR
+ PUSHJ P,ICONS ; CONS IT ON
+ MOVEI E,(B) ; SAVE RS
+ MOVSI C,TFIX ; AND GET FIXED NUM
+ MOVE D,(P)
+ PUSHJ P,ICONS
+LBRAK3: PUSH TP,A ; SAVE CURRENT COMMENT LIST
+ PUSH TP,B
+ JRST LBRAK1
+
+; HERE TO RAP UP VECTOR
+
+LBDONE: CAME B,-2(P) ; FINISHED RETURN (WAS THE RIGHT STOP USED?)
+ PUSHJ P,MISMAB ; WARN USER
+ POP TP,1(TB) ; REMOVE COMMENT LIST
+ POP TP,(TB)
+ MOVE A,(P) ; COUNT TO A
+ PUSHJ P,-1@(P) ; MAKE THE VECTOR
+ SUB P,C%33
+
+; PUT COMMENTS ON VECTOR (OR UVECTOR)
+
+ MOVNI C,1 ; INDICATE TEMPLATE HACK
+ CAMN A,$TVEC
+ MOVEI C,1
+ CAMN A,$TUVEC ; SKIP IF UVECTOR
+ MOVEI C,0
+ PUSH P,C ; SAVE
+ PUSH TP,A ; SAVE VECTOR/UVECTOR
+ PUSH TP,B
+
+VECCOM: SKIPN C,1(TB) ; ANY LEFT?
+ JRST RETVEC ; NO, LEAVE
+ MOVE A,1(C) ; ASSUME WINNING TYPES
+ SUBI A,1
+ HRRZ C,(C) ; CDR THE LIST
+ HRRZ E,(C) ; AGAIN
+ MOVEM E,1(TB) ; SAVE CDR
+ GETYP E,(C) ; CHECK DEFFERED
+ MOVSI D,(E)
+ CAIN E,TDEFER ; SKIP IF NOT DEFERRED
+ MOVE C,1(C)
+ CAIN E,TDEFER
+ GETYPF D,(C) ; GET REAL TYPE
+ MOVE B,(TP) ; GET VECTOR POINTER
+ SKIPGE (P) ; SKIP IF NOT TEMPLATE
+ JRST TMPCOM
+ HRLI A,(A) ; COUNTER
+ LSH A,@(P) ; MAYBE SHIFT IT
+ ADD B,A
+ MOVE A,-1(TP) ; TYPE
+TMPCO1: PUSH TP,D
+ PUSH TP,1(C) ; PUSH THE COMMENT
+ MOVSI C,TATOM
+ MOVE D,IMQUOTE COMMENT
+ PUSHJ P,IPUT
+ JRST VECCOM
+
+TMPCOM: MOVSI A,(A)
+ ADD B,A
+ MOVSI A,TTMPLT
+ JRST TMPCO1
+
+RETVEC: SUB P,C%11
+ POP TP,B
+ POP TP,A
+ JRST RET
+
+; BUILD A SINGLE CHARACTER ITEM
+
+SINCHR: PUSHJ P,NXTC1 ;FORCE READ NEXT
+ CAIN B,ESCTYP ;ESCAPE?
+ PUSHJ P,NXTC1 ;RETRY
+ MOVEI B,(A)
+ MOVSI A,TCHRS
+ JRST RETCL
+
+\f
+; HERE ON RIGHT PAREN, BRACKET, ANGLE BRACKET OR CTL C
+
+CLSBRA:
+CLSANG: ;CLOSE ANGLE BRACKETS
+RBRACK: ;COMMON RETURN FOR END OF ARRAY ALSO
+RPAREN: PUSHJ P,LSTCHR ;DON'T REREAD
+EOFCH1: MOVE B,A ;GETCHAR IN B
+ MOVSI A,TCHRS ;AND TYPE IN A
+RET1: SUB P,C%11
+ POPJ P,
+
+EOFCHR: SETZB C,D
+ JUMPL A,EOFCH1 ; JUMP ON REAL EOF
+ JRST RRSUBR ; MAYBE A BINARY RSUBR
+
+DOEOF: MOVE A,[-1,,3]
+ SETZB C,D
+ JRST EOFCH1
+
+
+; NORMAL RETURN FROM IREAD/IREAD1
+
+RETCL: PUSHJ P,LSTCHR ;DONT REREAD
+RET: AOS -1(P) ;SKIP
+ POP P,E ; POP FLAG
+RETC: JUMPL E,RET2 ; DONT LOOK FOR COMMENTS
+ PUSH TP,A ; SAVE ITEM
+ PUSH TP,B
+CHCOMN: PUSHJ P,NXTCH ; READ A CHARACTER
+ CAIE B,COMTYP ; SKIP IF COMMENT
+ JRST CHSPA
+ PUSHJ P,IREAD ; READ THE COMMENT
+ JRST POPAJ
+ MOVE C,A
+ MOVE D,B
+ JRST .+2
+POPAJ: SETZB C,D
+ POP TP,B
+ POP TP,A
+RET2: POPJ P,
+
+CHSPA: CAIN B,SPATYP
+ PUSHJ P,SPACEQ ; IS IT A REAL SPACE
+ JRST POPAJ
+ PUSHJ P,LSTCHR ; FLUSH THE SPACE
+ JRST CHCOMN
+
+;RANDOM MINI-SUBROUTINES USED BY THE READER
+
+;READ A CHAR INTO A AND TYPE CODE INTO D
+
+NXTC3: SKIPL B,5(TB) ;GET CHANNEL
+ JRST NXTPR4 ;NO CHANNEL, GO READ STRING
+ SKIPE LSTCH(B)
+ PUSHJ P,CNTACC ; COUNT ON ACCESS POINTER
+ PUSHJ P,RXCT
+ TRO A,200
+ JRST GETCTP
+
+NXTC1: SKIPL B,5(TB) ;GET CHANNEL
+ JRST NXTPR1 ;NO CHANNEL, GO READ STRING
+ SKIPE LSTCH(B)
+ PUSHJ P,CNTACC ; COUNT ON ACCESS POINTER
+ JRST NXTC2
+NXTC: SKIPL B,5(TB) ;GET CHANNEL
+ JRST NXTPRS ;NO CHANNEL, GO READ STRING
+ SKIPE A,LSTCH(B) ;CHAR IN A IF REUSE
+ JRST PRSRET
+NXTC2: PUSHJ P,RXCT ;GET CHAR FROM INPUT
+ TLO A,200000 ; BIT TO AVOID ^@ LOSSAGE
+ HLLZS 2(TB) ;FLAG INDICATING ONE CHAR LOOK AHEAD
+ MOVEM A,LSTCH(B) ;SAVE THE CHARACTER
+PRSRET: TLZ A,200000
+ TRZE A,400000 ;DONT SKIP IF SPECIAL
+ TRO A,200 ;GO HACK SPECIALLY
+GETCTP: PUSH P,A ;AND SAVE FROM DIVISION
+ ANDI A,377
+ IDIVI A,CHRWD ;YIELDS WORD AND CHAR NUMBER
+ LDB B,BYTPNT(B) ;GOBBLE TYPE CODE
+ POP P,A
+ ANDI A,177 ; RETURN REAL ASCII
+ POPJ P,
+
+NXTPR4: MOVEI F,400000
+ JRST NXTPR5
+
+NXTPRS: SKIPE A,5(TB) ;GET OLD CHARACTER IF ONE EXISTS
+ JRST PRSRET
+NXTPR1: MOVEI F,0
+NXTPR5: MOVE A,11.(TB)
+ HRRZ B,(A) ;GET THE STRING
+ SOJL B,NXTPR3
+ HRRM B,(A)
+ ILDB A,1(A) ;GET THE CHARACTER FROM THE STRING
+ IORI A,(F)
+NXTPR2: MOVEM A,5(TB) ;SAVE IT
+ JRST PRSRET ;CONTINUE
+
+NXTPR3: SETZM 8.(TB)
+ SETZM 9.(TB) ;CLEAR OUT LOCATIVE, AT END OF STRING
+ MOVEI A,400033
+ JRST NXTPR2
+
+; NXTCH AND NXTCH1 ARE SAME AS NXTC AND NXTC1 EXCEPT THEY CHECK !
+; HACKS
+
+NXTCH1: PUSHJ P,NXTC1 ;READ CHAR
+ JRST .+2
+NXTCH: PUSHJ P,NXTC ;READ CHAR
+ PUSHJ P,CHKUS1 ; CHECK FOR USER DISPATCH
+
+ CAIE B,NTYPES+1 ; SKIP IF ! ING NEXT CHAR
+ POPJ P,
+ PUSHJ P,NXTC3 ;READ NEXT ONE
+ HLLOS 2(TB) ;FLAG FOR TWO CHAR LOOK AHEAD
+
+CRMLST: IORI A,400000 ;CLOBBER LASTCHR
+ PUSH P,B
+ SKIPL B,5(TB) ;POINT TO CHANNEL
+ MOVEI B,5(TB)-LSTCH ;NO CHANNEL, POINT AT SLOT
+ HRRM A,LSTCH(B)
+ ANDI A,377777 ;DECREASE CHAR
+ POP P,B
+
+CHKUS2: SKIPN 7(TB) ; SKIP IF USER TABLE
+ POPJ P,
+ MOVEI F,200(A)
+ ASH F,1 ; POINT TO SLOT
+ HRLI F,(F)
+ ADD F,7(TB)
+ JUMPGE F,CPOPJ ;IS THERE VECTOR ENOUGH?
+ SKIPN 1(F) ; NON-ZERO==>USER FCN EXISTS
+ JRST CPOPJ ; HOPE HE APPRECIATES THIS
+ MOVEI B,USTYP2
+CHKRDO: PUSH P,0 ; CHECK FOR REDOING IF CHAR IN TABLE
+ GETYP 0,(F)
+ CAIE 0,TCHRS
+ JRST CHKUS5
+ POP P,0 ;WE ARE TRANSMOGRIFYING
+ MOVE A,1(F) ;GET NEW CHARACTER
+ PUSH P,7(TB)
+ PUSH P,2(TB) ; FLAGS FOR NUM OF CHRS IN LOOK AHEAD
+ PUSH P,5(TB) ; TO AVOID SMASHING LSTCHR
+ SETZM 5(TB) ; CLEAR OUT CHANNEL
+ SETZM 7(TB) ;CLEAR OUT TABLE
+ TRZE A,200 ; ! HACK
+ TRO A,400000 ; TURN ON PROPER BIT
+ PUSHJ P,PRSRET
+ POP P,5(TB) ; GET BACK CHANNEL
+ POP P,2(TB)
+ POP P,7(TB) ;GET BACK OLD PARSE TABLE
+ POPJ P,
+
+CHKUS5: PUSH P,A
+ CAIE 0,TLIST
+ JRST .+4 ; SPECIAL NON-BREAK TYPE HACK
+ MOVNS (P) ; INDICATE BY NEGATIVE
+ MOVE A,1(F) ; GET <1 LIST>
+ GETYP 0,(A) ; AND GET THE TYPE OF THAT
+ CAIE 0,TFIX ; SEE IF HE WANTS SAME CHAR WITH DIFF TYPE
+ JRST CHKUS6 ; JUST A VANILLA HACK
+ MOVE A,1(F) ; PRETEND IT IS SAME TYPE AS NEW CHAR
+ PUSH P,7(TB) ; CLEAR OUT TRANSLATE TABLE
+ PUSH P,2(TB) ; FLAGS FOR # OF CHRS IN LOOK AHEAD
+ SETZM 7(TB)
+ TRZE A,200
+ TRO A,400000 ; TURN ON PROPER BIT IF ! HACK
+ PUSHJ P,PRSRET ; REGET TYPE
+ POP P,2(TB)
+ POP P,7(TB) ; PUT TRANSLATE TABLE BACK
+CHKUS6: SKIPGE -1(P) ; SEE IF A SPECIAL NON-BREAK
+ MOVNS B ; SEXY, HUH?
+ POP P,A
+ POP P,0
+ MOVMS A ; FIX UP A POSITIVE CHARACTER
+ POPJ P,
+
+CHKUS4: POP P,A
+ POPJ P,
+
+CHKUS1: SKIPN 7(TB) ; USER CHECK FOR NOT ! CASE
+ POPJ P,
+ MOVEI F,(A)
+ ASH F,1
+ HRLI F,(F)
+ ADD F,7(TB)
+ JUMPGE F,CPOPJ
+ SKIPN 1(F)
+ POPJ P,
+ MOVEI B,USTYP1
+ JRST CHKRDO ; TRANSMOGRIFY CHARACTER?
+
+CHKUS3: POP P,A
+ POPJ P,
+
+UPLO: POPJ P, ; LETS NOT AND SAY WE USED TO
+ ; AVOID STRANGE ! BLECHAGE
+NXTCS: PUSHJ P,NXTC
+ PUSH P,A ; HACK TO NOT TRANSLATE CHAR
+ PUSHJ P,CHKUS1 ; BUT DO TRANSLATION OF TYPE IF HE WANTS
+ POP P,A ; USED TO BUILD UP STRINGS
+ POPJ P,
+
+CHKALT: CAIN A,33 ;ALT?
+ MOVEI B,MANYT
+ JRST CRMLST
+
+
+TERM: MOVEI B,0 ;RETURN A 0
+ JRST RET1
+ ;AND RETURN
+
+CHKMIN: CAIN A,"- ; IF CHAR IS -, WINNER
+ MOVEI B,PATHTY
+ JRST CRMLST
+
+LOSPAT: PUSHJ P,LSTCHR ; FIX RECURSIVE LOSAGE
+ ERRUUO EQUOTE UNATTACHED-PATH-NAME-SEPARATOR
+
+\f
+; HERE TO SEE IF READING RSUBR
+
+RRSUBR: PUSHJ P,LSTCHR ; FLUSH JUST READ CHAR
+ SKIPL B,5(TB) ; SKIP IF A CHANNEL EXISTS
+ JRST SPACE ; ELSE LIKE A SPACE
+ HRRZ C,BUFSTR(B) ; SEE IF FLAG SAYS START OF RSUBR
+ MOVE C,(C)
+ TRNN C,1 ; SKIP IF REAL RSUBR
+ JRST EOFCH2 ; NO, IGNORE FOR NOW
+
+; REALLY ARE READING AN RSUBR
+
+ HRRZ 0,4(TB) ; GET READ/READB INDICATOR
+ MOVE C,ACCESS(B) ; GET CURRENT ACCESS
+ JUMPN 0,.+3 ; ALREADY WORDS, NO NEED TO DIVIDE
+ ADDI C,4 ; ROUND UP
+ IDIVI C,5
+ PUSH P,C ; SAVE WORD ACCESS
+ MOVEI A,(C) ; COPY IT FOR CALL
+ JUMPN 0,.+3
+ IMULI C,5
+ MOVEM C,ACCESS(B) ; FIXUP ACCESS
+ HLLZS ACCESS-1(B) ; FOR READB LOSER
+ PUSHJ P,DOACCS ; AND GO THERE
+ PUSH P,C%0 ; FOR READ IN
+ HRROI A,(P) ; PREPARE TO READ LENGTH
+ PUSHJ P,DOIOTI ; READ IT
+ POP P,C ; GET READ GOODIE
+ JUMPGE A,.+4 ; JUMP IF WON
+ SUB P,C%11
+EOFCH2: HRROI A,3
+ JRST EOFCH1
+ MOVEI A,(C) ; COPY FOR GETTING BLOCK
+ ADDI C,1 ; COUNT COUNT WORD
+ ADDM C,(P)
+ PUSH TP,$TUVEC ; WILL HOLD UVECTOR OF FIXUPS IF THEY STAY
+ PUSH TP,C%0
+ PUSHJ P,IBLOCK ; GET A BLOCK
+ PUSH TP,$TUVEC
+ PUSH TP,B ; AND SAVE
+ MOVE A,B ; READY TO IOT IT IN
+ MOVE B,5(TB) ; GET CHANNEL BACK
+ MOVSI 0,TUVEC ; SETUP A'S TYPE
+ MOVE PVP,PVSTOR+1
+ MOVEM 0,ASTO(PVP)
+ PUSHJ P,DOIOTI ; IN COMES THE WHOLE BLOCK
+ MOVE PVP,PVSTOR+1
+ SETZM ASTO(PVP) ; A NO LONGER SPECIAL
+ MOVEI C,BUFSTR-1(B) ; NO RESET BUFFER
+ PUSHJ P,BYTDOP ; A POINTS TO DOPW WORD
+ SUBI A,2
+ HRLI A,010700 ; SETUP BYTE POINTER TO END
+ HLLZS BUFSTR-1(B) ; ZERO CHAR COUNNT
+ MOVEM A,BUFSTR(B)
+ HRRZ A,4(TB) ; READ/READB FLG
+ MOVE C,(P) ; ACCESS IN WORDS
+ SKIPN A ; SKIP FOR ASCII
+ IMULI C,5 ; BUMP
+ MOVEM C,ACCESS(B) ; UPDATE ACCESS
+ PUSHJ P,NIREAD ; READ RSUBR VECTOR
+ JRST BRSUBR ; LOSER
+ GETYP A,A ; VERIFY A LITTLE
+ CAIE A,TVEC ; DONT SKIP IF BAD
+ JRST BRSUBR ; NOT A GOOD FILE
+ PUSHJ P,LSTCHR ; FLUSH REREAD CHAR
+ MOVE C,(TP) ; CODE VECTOR BACK
+ MOVSI A,TCODE
+ HLR A,B ; FUNNY COUNT
+ MOVEM A,(B) ; CLOBBER
+ MOVEM C,1(B)
+ PUSH TP,$TRSUBR ; MAKE RSUBR
+ PUSH TP,B
+
+; NOW LOOK OVER FIXUPS
+
+ MOVE B,5(TB) ; GET CHANNEL
+ MOVE C,ACCESS(B)
+ HLLZS ACCESS-1(B) ; FOR READB LOSER
+ HRRZ 0,4(TB) ; READ/READB FLG
+ JUMPN 0,RSUB1
+ ADDI C,4 ; ROUND UP
+ IDIVI C,5 ; TO WORDS
+ MOVEI D,(C) ; FIXUP ACCESS
+ IMULI D,5
+ MOVEM D,ACCESS(B) ; AND STORE
+RSUB1: ADDI C,1 ; ACCOUNT FOR EXTRA COUNTERS
+ MOVEM C,(P) ; SAVE FOR LATER
+ MOVEI A,-1(C) ; FOR DOACS
+ MOVEI C,2 ; UPDATE REAL ACCESS
+ SKIPN 0 ; SKIP FOR READB CASE
+ MOVEI C,10.
+ ADDM C,ACCESS(B)
+ PUSHJ P,DOACCS ; DO THE ACCESS
+ PUSH TP,$TUVEC ; SLOT FOR FIXUP BUFFER
+ PUSH TP,C%0
+
+; FOUND OUT IF FIXUPS STAY
+
+ MOVE B,IMQUOTE KEEP-FIXUPS
+ PUSHJ P,ILVAL ; GET VALUE
+ GETYP 0,A
+ MOVE B,5(TB) ; CHANNEL BACK TO B
+ CAIE 0,TUNBOU
+ CAIN 0,TFALSE
+ JRST RSUB4 ; NO, NOT KEEPING FIXUPS
+ PUSH P,C%0 ; SLOT TO READ INTO
+ HRROI A,(P) ; GET LENGTH OF SAME
+ PUSHJ P,DOIOTI
+ POP P,C
+ MOVEI A,(C) ; GET UVECTOR FOR KEEPING
+ ADDM C,(P) ; ACCESS TO END
+ PUSH P,C ; SAVE LENGTH OF FIXUPS
+ PUSHJ P,IBLOCK
+ MOVEM B,-6(TP) ; AND SAVE
+ MOVE A,B ; FOR IOTING THEM IN
+ ADD B,C%11 ; POINT PAST VERS #
+ MOVEM B,(TP)
+ MOVSI C,TUVEC
+ MOVE PVP,PVSTOR+1
+ MOVEM C,ASTO(PVP)
+ MOVE B,5(TB) ; AND CHANNEL
+ PUSHJ P,DOIOTI ; GET THEM
+ MOVE PVP,PVSTOR+1
+ SETZM ASTO(PVP)
+ MOVE A,(TP) ; GET VERS
+ PUSH P,-1(A) ; AND PUSH IT
+ JRST RSUB5
+
+RSUB4: PUSH P,C%0
+ PUSH P,C%0 ; 2 SLOTS FOR READING
+ MOVEI A,-1(P)
+ HRLI A,-2
+ PUSHJ P,DOIOTI
+ MOVE C,-1(P)
+ MOVE D,(P)
+ ADDM C,-2(P) ; NOW -2(P) IS ACCESS TO END OF FIXUPS
+RSUB5: MOVEI C,BUFSTR-1(B) ; FIXUP BUFFER
+ PUSHJ P,BYTDOP
+ SUBI A,2 ; POINT BEFORE D.W.
+ HRLI A,10700
+ MOVEM A,BUFSTR(B)
+ HLLZS BUFSTR-1(B)
+ SKIPE -6(TP)
+ JRST RSUB2A
+ SUBI A,BUFLNT-1 ; ALSO MAKE AN IOT FLAVOR BUFFER
+ HRLI A,-BUFLNT
+ MOVEM A,(TP)
+ MOVSI C,TUVEC
+ MOVE PVP,PVSTOR+1
+ MOVEM C,ASTO(PVP)
+ PUSHJ P,DOIOTI
+ MOVE PVP,PVSTOR+1
+ SETZM ASTO(PVP)
+RSUB2A: PUSH P,-1(P) ; ANOTHER COPY OF LENGTH OF FIXUPS
+
+; LOOP FIXING UP NEW TYPES
+
+RSUB2: PUSHJ P,WRDIN ; SEE WHAT NEXT THING IS
+ JRST RSUB3 ; NO MORE, DONE
+ JUMPL E,STSQ ; MUST BE FIRST SQUOZE
+ MOVNI 0,(E) ; TO UPDATE AMNT OF FIXUPS
+ ADDB 0,(P)
+ HRLI E,(E) ; IS LENGTH OF STRING IN WORDS
+ ADD E,(TP) ; FIXUP BUFFER POINTER
+ JUMPL E,.+3
+ SUB E,[BUFLNT,,BUFLNT]
+ JUMPGE E,.-1 ; STILL NOT RIGHT
+ EXCH E,(TP) ; FIX UP SLOT
+ HLRE C,E ; FIX BYTE POINTER ALSO
+ IMUL C,[-5] ; + CHARS LEFT
+ MOVE B,5(TB) ; CHANNEL
+ PUSH TP,BUFSTR-1(B)
+ PUSH TP,BUFSTR(B)
+ HRRM C,BUFSTR-1(B)
+ HRLI E,440700 ; AND BYTE POINTER
+ MOVEM E,BUFSTR(B)
+ PUSHJ P,NIREAD ; READ ATOM NAME OF TYPE
+ TDZA 0,0 ; FLAG LOSSAGE
+ MOVEI 0,1 ; WINNAGE
+ MOVE C,5(TB) ; RESET BUFFER
+ POP TP,BUFSTR(C)
+ POP TP,BUFSTR-1(C)
+ JUMPE 0,BRSUBR ; BAD READ OF RSUBR
+ GETYP A,A ; A LITTLE CHECKING
+ CAIE A,TATOM
+ JRST BRSUBR
+ PUSHJ P,LSTCHR ; FLUSH REREAD CHAR
+ HRRZ 0,4(TB) ; FIXUP ACCESS PNTR
+ MOVE C,5(TB)
+ MOVE D,ACCESS(C)
+ HLLZS ACCESS-1(C) ; FOR READB HACKER
+ ADDI D,4
+ IDIVI D,5
+ IMULI D,5
+ SKIPN 0
+ MOVEM D,ACCESS(C) ; RESET
+TYFIXE: PUSHJ P,TYPFND ; SEE IF A LEGAL TYPE NAME
+ JRST TYPFIX ; GO SEE USER ABOUT THIS
+ PUSHJ P,FIXCOD ; GO FIX UP THE CODE
+ JRST RSUB2
+
+; NOW FIX UP SUBRS ETC. IF NECESSARY
+
+STSQ: MOVE B,IMQUOTE MUDDLE
+ PUSHJ P,IGVAL ; GET CURRENT VERS
+ CAME B,-1(P) ; SKIP IF NO FIXUPS NEEDED
+ JRST DOFIX0 ; MUST DO THEM
+
+; ALL DONE, ACCESS PAST FIXUPS AND RETURN
+RSUB31: PUSHJ P,SQUKIL ; DONE FIXING UP, KILL SQUOZE TABLE IF IN INTERP
+RSUB3: MOVE A,-3(P)
+ MOVE B,5(TB)
+ MOVEI C,(A) ; UPDATE CHANNEL ACCESS IN CASE SKIPPING
+ HRRZ 0,4(TB) ; READ/READB FLAG
+ SKIPN 0
+ IMULI C,5
+ MOVEM C,ACCESS(B) ; INTO ACCESS SLOT
+ HLLZS ACCESS-1(B)
+ PUSHJ P,DOACCS ; ACCESSED
+ MOVEI C,BUFSTR-1(B) ; FIX UP BUFFER
+ PUSHJ P,BYTDOP
+ SUBI A,2
+ HRLI A,10700
+ MOVEM A,BUFSTR(B)
+ HLLZS BUFSTR-1(B)
+ SKIPN A,-6(TP) ; SKIP IF KEEPING FIXUPS
+ JRST RSUB6
+ PUSH TP,$TUVEC
+ PUSH TP,A
+ MOVSI A,TRSUBR
+ MOVE B,-4(TP)
+ MOVSI C,TATOM
+ MOVE D,IMQUOTE RSUBR
+ PUSHJ P,IPUT ; DO THE ASSOCIATION
+
+RSUB6: MOVE C,-4(TP) ; DO SPECIAL FIXUPS
+ PUSHJ P,SFIX
+ MOVE B,-2(TP) ; GET RSUBR
+ MOVSI A,TRSUBR
+ SUB P,C%44 ; FLUSH P CRUFT
+ SUB TP,[10,,10]
+ JRST RET
+
+; FIXUP SUBRS ETC.
+
+DOFIX0: SKIPN C,-6(TP) ; GET BUFFER IF KEEPING
+ JRST DOFIXE
+ MOVEM B,(C) ; CLOBBER
+ JRST DOFIXE
+
+FIXUPL: PUSHJ P,WRDIN
+ JRST RSUB31
+DOFIXE: JUMPGE E,BRSUBR
+ TLZ E,740000 ; KILL BITS
+IFN KILTV,[
+ CAME E,[SQUOZE 0,DSTO]
+ JRST NOOPV
+ MOVE E,[SQUOZE 40,DSTORE]
+ MOVE A,(TP)
+ SKIPE -6(TP)
+ MOVEM E,-1(A)
+ MOVEI E,53
+ HRLM E,(A)
+ MOVEI E,DSTORE
+ JRST .+3
+NOOPV:
+]
+ PUSHJ P,SQUTOA ; LOOK IT UP
+ PUSHJ P,BRSUB1
+ MOVEI D,(E) ; FOR FIXCOD
+ PUSHJ P,FIXCOD ; FIX 'EM UP
+ JRST FIXUPL
+
+; BAD SQUOZE, BE MORE SPECIFIC
+
+BRSUB1: PUSHJ P,SQSTR
+ PUSH TP,$TATOM
+ PUSH TP,EQUOTE SQUZE-SYMBOL-NOT-FOUND-ERRET CORRECTION
+ PUSH TP,A
+ PUSH TP,B
+ PUSH TP,$TATOM
+ PUSH TP,MQUOTE READ
+ MCALL 3,ERROR
+ GETYP A,A
+ CAIE A,TFIX
+ ERRUUO EQUOTE VALUE-MUST-BE-FIX
+ MOVE E,B
+ POPJ P,
+
+; CONVERT SQUOZE TO A MUDDLE STRING FOR USER
+
+SQSTR: PUSHJ P,SPTT
+ PUSH P,C
+ CAIN B,6 ; 6 chars?
+ PUSH P,D
+ PUSH P,B
+ PUSHJ P,CHMAK
+ POPJ P,
+
+SPTT: SETZB B,C
+ MOVE A,[440700,,C]
+ MOVEI D,0
+
+SPT1: IDIVI E,50
+ PUSH P,F
+ JUMPE E,SPT3
+ PUSHJ P,SPT1
+SPT3: POP P,E
+ ADDI E,"0-1
+ CAILE E,"9
+ ADDI E,"A-"9-1
+ CAILE E,"Z
+ SUBI E,"Z-"#+1
+ CAIN E,"#
+ MOVEI E,".
+ CAIN E,"/
+SPC: MOVEI E,40
+ IDPB E,A
+ ADDI B,1
+ POPJ P,
+
+
+;0 1-12 13-44 45 46 47
+;NULL 0-9 A-Z . $ %
+
+; ROUTINE TO FIXUP ACTUAL CODE
+
+FIXCOD: MOVEI E,0 ; FOR HWRDIN
+ PUSH P,D ; NEW VALUE
+ PUSHJ P,HWRDIN ; GET HW NEEDED
+ MOVE D,(P) ; GET NEW VAL
+ MOVE A,(TP) ; AND BUFFER POINTER
+ SKIPE -6(TP) ; SAVING?
+ HRLM D,-1(A) ; YES, CLOBBER
+ SUB C,(P) ; DIFFERENCE
+ MOVN D,C
+
+FIXLP: PUSHJ P,HWRDIN ; GET AN OFFSET
+ JUMPE C,FIXED
+ HRRES C ; MAKE NEG IF NEC
+ JUMPL C,LHFXUP
+ ADD C,-4(TP) ; POINT INTO CODE
+IFN KILTV,[
+ LDB 0,[220400,,-1(C)] ; GET INDEX FIELD
+ CAIE 0,7
+ JRST NOTV
+KIND: MOVEI 0,0
+ DPB 0,[220400,,-1(C)]
+ JRST DONTV
+NOTV: CAIE 0,6 ; IS IT PVP
+ JRST DONTV
+ HRRZ 0,-1(C)
+ CAIE 0,12 ; OLD DSTO
+ JRST DONTV
+ MOVEI 0,33.
+ ADDM 0,-1(C)
+ JRST KIND
+DONTV:
+]
+ ADDM D,-1(C)
+ JRST FIXLP
+
+LHFXUP: MOVMS C
+ ADD C,-4(TP)
+ MOVSI 0,(D)
+ ADDM 0,-1(C)
+ JRST FIXLP
+
+FIXED: SUB P,C%11
+ POPJ P,
+
+; ROUTINE TO READ A WORD FROM BUFFER
+
+WRDIN: PUSH P,A
+ PUSH P,B
+ SOSG -3(P) ; COUNT IT DOWN
+ JRST WRDIN1
+ AOS -2(P) ; SKIP RETURN
+ MOVE B,5(TB) ; CHANNEL
+ HRRZ A,4(TB) ; READ/READB SW
+ MOVEI E,5
+ SKIPE A
+ MOVEI E,1
+ ADDM E,ACCESS(B)
+ MOVE A,(TP) ; BUFFER
+ MOVE E,(A)
+ AOBJP A,WRDIN2 ; NEED NEW BUFFER
+ MOVEM A,(TP)
+WRDIN1: POP P,B
+ POP P,A
+ POPJ P,
+
+WRDIN2: MOVE B,-3(P) ; IS THIS LAST WORD?
+ SOJLE B,WRDIN1 ; YES, DONT RE-IOT
+ SUB A,[BUFLNT,,BUFLNT]
+ MOVEM A,(TP)
+ MOVSI B,TUVEC
+ MOVE PVP,PVSTOR+1
+ MOVEM B,ASTO(PVP)
+ MOVE B,5(TB)
+ PUSHJ P,DOIOTI
+ MOVE PVP,PVSTOR+1
+ SETZM ASTO(PVP)
+ JRST WRDIN1
+
+; READ IN NEXT HALF WORD
+
+HWRDIN: JUMPN E,NOIOT ; USE EXISTING WORD
+ PUSH P,-3(P) ; FAKE OUT WRDIN IF NEC.
+ PUSHJ P,WRDIN
+ JRST BRSUBR
+ POP P,-4(P) ; RESET COUNTER
+ HLRZ C,E ; RET LH
+ POPJ P,
+
+NOIOT: HRRZ C,E
+ MOVEI E,0
+ POPJ P,
+
+TYPFIX: PUSH TP,$TATOM
+ PUSH TP,EQUOTE BAD-TYPE-NAME
+ PUSH TP,$TATOM
+ PUSH TP,B
+ PUSH TP,$TATOM
+ PUSH TP,EQUOTE ERRET-TYPE-NAME-DESIRED
+ MCALL 3,ERROR
+ JRST TYFIXE
+
+BRSUBR: ERRUUO EQUOTE RSUBR-IN-BAD-FORMAT
+\f
+
+
+;TABLE OF BYTE POINTERS FOR GETTING CHARS
+
+BYTPNT": 350700,,CHTBL(A)
+ 260700,,CHTBL(A)
+ 170700,,CHTBL(A)
+ 100700,,CHTBL(A)
+ 010700,,CHTBL(A)
+
+;HERE ARE THE TABLES OF CHXRACTERS (NOTE EVERYTHING NOT SPECIFIED IS
+;IN THE NUMBER LETTER CATAGORY)
+
+CHROFF==0 ; USED FOR ! HACKS
+SETCHR NUMCOD,[0123456789]
+
+SETCHR PLUCOD,[+]
+
+SETCHR NEGCOD,[-]
+
+SETCHR ASTCOD,[*]
+
+SETCHR DOTTYP,[.]
+
+SETCHR ETYPE,[Ee]
+
+SETCOD SPATYP,[0,15,12,11,14,40,33] ;ALL ARE TYPE 2 (SPACING - FF,TAB,SPACE,ALT-MODE)
+
+INCRCH LPATYP,[()[]'%"\#<>] ;GIVE THESE INCREASRNG CODES FROM 3
+
+SETCOD EOFTYP,[3] ;^C - EOF CHARACTER
+
+SETCOD SPATYP,[32] ;^Z - TENEX/TOPS-20 EOF (SET IN BOTH TO BE CONSISTENT)
+
+INCRCH COMTYP,[;,{}!] ;COMMENT AND GLOBAL VALUE AND SPECIAL
+
+CHROFF==200 ; CODED AS HAVING 200 ADDED
+
+INCRCH EXCEXC,[!.[]'"<>,-\]
+
+SETCOD MANYT,[33]
+
+CHTBL:
+ OUTTBL ;OUTPUT THE TABLE RIGHT HERE
+
+
+\f; THIS CODE FLUSHES WANDERING COMMENTS
+
+COMNT: PUSHJ P,IREAD
+ JRST COMNT2
+ JRST BDLP
+
+COMNT2: SKIPL A,5(TB) ; RESTORE CHANNEL
+ MOVEI A,5(TB)-LSTCH ;NO CHANNEL, POINT AT SLOT
+ HRRM B,LSTCH(A) ; CLOBBER IN CHAR
+ PUSHJ P,ERRPAR
+ JRST BDLP
+\f
+
+;HERE TO SET UP FOR .FOO ..FOO OR.<ABC>
+
+DOTSTR: PUSHJ P,NXTCH1 ; GOBBLE A NEW CHARACTER
+ MOVEI FF,FRSDOT+DOTSEN+NUMWIN ; SET FLAG IN CASE
+ CAIN B,NUMCOD ; SKIP IF NOT NUMERIC
+ JRST DOTST1 ; NUMERIC, COULD BE FLONUM
+
+; CODE TO HANDLE ALL IMPLICIT CALLS I.E. QUOTE, LVAL, GVAL
+
+ TRZ FF,NUMWIN ; WE ARE NOT A NUMBER
+ MOVSI B,TFORM ; LVAL
+ MOVE A,IMQUOTE LVAL
+ JRST IMPCA1
+
+GLOSEG: SKIPA B,$TSEG ;SEG CALL TO GVAL
+GLOVAL: MOVSI B,TFORM ;FORM CALL TO SAME
+ MOVE A,IMQUOTE GVAL
+ JRST IMPCAL
+
+QUOSEG: SKIPA B,$TSEG ;SEG CALL TO QUOTE
+QUOTIT: MOVSI B,TFORM
+ MOVE A,IMQUOTE QUOTE
+ JRST IMPCAL
+
+SEGDOT: MOVSI B,TSEG ;SEG CALL TO LVAL
+ MOVE A,IMQUOTE LVAL
+IMPCAL: PUSHJ P,LSTCHR ;FLUSH LAST CHAR EXCEPT
+IMPCA1: PUSH TP,$TATOM ;FOR .FOO FLAVOR
+ PUSH TP,A ;PUSH ARGS
+ PUSH P,B ;SAVE TYPE
+ PUSHJ P,IREAD1 ;READ
+ JRST USENIL ; IF NO ARG, USE NIL
+IMPCA2: PUSH TP,C
+ PUSH TP,D
+ MOVE C,A ; GET READ THING
+ MOVE D,B
+ PUSHJ P,INCONS ; CONS TO NIL
+ MOVEI E,(B) ; PREPARE TON CONS ON
+POPARE: POP TP,D ; GET ATOM BACK
+ POP TP,C
+ EXCH C,-1(TP) ; SAVE THAT COMMENT
+ EXCH D,(TP)
+ PUSHJ P,ICONS
+ POP P,A ;GET FINAL TYPE
+ JRST RET13 ;AND RETURN
+
+
+USENIL: PUSH TP,C
+ PUSH TP,D
+ SKIPL A,5(TB) ; RESTOR LAST CHR
+ MOVEI A,5(TB)-LSTCH ;NO CHANNEL, POINT AT SLOT
+ HRRM B,LSTCH(A)
+ MOVEI E,0
+ JRST POPARE
+\f
+;HERE AFTER READING ATOM TO CALL VALUE
+
+.SET: PUSH P,$TFORM ;GET WINNING TYPE
+ MOVE E,(P)
+ PUSHJ P,RETC ; CHECK FOR POSSIBLE COMMENT
+ PUSH TP,$TATOM
+ PUSH TP,IMQUOTE LVAL
+ JRST IMPCA2 ;GO CONS LIST
+
+LOOPA: PUSH P,FF ; SAVE FLAGS IN CASE .ATOM
+LOOPAT: PUSHJ P,NXTCH ; CHECK FOR TRAILER
+ CAIN B,PATHTY ; PATH BEGINNER
+ JRST PATH0 ; YES, GO PROCESS
+ CAIN B,SPATYP ; SPACER?
+ PUSHJ P,SPACEQ ; CHECK FOR REAL SPACE
+ JRST PATH2
+ PUSHJ P,LSTCHR ; FLUSH IT AND RETRY
+ JRST LOOPAT
+PATH0: PUSHJ P,NXTCH1 ; READ FORCED NEXT
+ CAIE B,SPCTYP ; DO #FALSE () HACK
+ CAIN B,ESCTYP
+ JRST PATH4
+ CAIL B,SPATYP ; SPACER?
+ JRST PATH3 ; YES, USE THE ROOT OBLIST
+PATH4: PUSHJ P,NIREA1 ; READ NEXT ITEM
+ PUSHJ P,ERRPAR ; LOSER
+ CAME A,$TATOM ; ONLY ALLOW ATOMS
+ JRST BADPAT
+
+ PUSH TP,A
+ PUSH TP,B
+ MOVSI C,TATOM
+ MOVE D,IMQUOTE OBLIST
+ PUSHJ P,IGET ; GET THE OBLIST
+ ; IF NOT OBLIST, MAKE ONE
+ JUMPN B,PATH6
+ MCALL 1,MOBLIS ; MAKE ONE
+ JRST PATH1
+
+PATH6: SUB TP,C%22
+ JRST PATH1
+
+
+PATH3: MOVE B,ROOT+1 ; GET ROOT OBLIST
+ MOVSI A,TOBLS
+PATH1: POP P,FF ; FLAGS
+ TRNE FF,FRSDOT
+ JRST PATH.
+ PUSHJ P,RLOOKU ; AND LOOK IT UP
+
+ JRST RET
+
+PATH.: PUSHJ P,RLOOKU
+ JRST .SET ; CONS AN LVAL FORM
+
+SPACEQ: ANDI A,-1
+ CAIE A,33
+ CAIN A,400033
+ POPJ P,
+ CAIE A,3
+ AOS (P)
+ POPJ P,
+\f
+
+PATH2: MOVE B,IMQUOTE OBLIST
+ PUSHJ P,IDVAL
+ JRST PATH1
+
+BADPAT: ERRUUO EQUOTE NON-ATOMIC-OBLIST-NAME
+
+\f
+
+; HERE TO READ ONE CHARACTER FOR USER.
+
+CREDC1: SUBM M,(P)
+ PUSH TP,A
+ PUSH TP,B
+ PUSHJ P,IREADC
+ JRST CRDEO1
+ JRST RMPOPJ
+
+CNXTC1: SUBM M,(P)
+ PUSH TP,A
+ PUSH TP,B
+ PUSHJ P,INXTRD
+ JRST CRDEO1
+ JRST RMPOPJ
+
+CRDEO1: MOVE B,(TP)
+ PUSH TP,EOFCND-1(B)
+ PUSH TP,EOFCND(B)
+ PUSH TP,$TCHAN
+ PUSH TP,B
+ MCALL 1,FCLOSE
+ MCALL 1,EVAL
+ JRST RMPOPJ
+
+
+CREADC: SUBM M,(P)
+ PUSH TP,A
+ PUSH TP,B
+ PUSHJ P,IREADC
+ JRST CRDEOF
+ SOS (P)
+ JRST RMPOPJ
+
+CNXTCH: SUBM M,(P)
+ PUSH TP,A
+ PUSH TP,B
+ PUSHJ P,INXTRD
+ JRST CRDEOF
+ SOS (P)
+RMPOPJ: SUB TP,C%22
+ JRST MPOPJ
+
+CRDEOF: .MCALL 1,FCLOSE
+ MOVSI A,TCHRS
+ HRROI B,3
+ JRST MPOPJ
+
+INXTRD: TDZA E,E
+IREADC: MOVEI E,1
+ MOVE B,(TP) ; CHANNEL
+ HRRZ A,-2(B) ; GET BLESS BITS
+ TRNE A,C.BIN
+ TRNE A,C.BUF
+ JRST .+3
+ PUSHJ P,GRB
+ HRRZ A,-2(B)
+ TRC A,C.OPN+C.READ
+ TRNE A,C.OPN+C.READ
+ JRST BADCHN
+ SKIPN A,LSTCH(B)
+ PUSHJ P,RXCT
+ TLO A,200000
+ MOVEM A,LSTCH(B) ; SAVE CHAR
+ CAMN A,C%M1 ; [-1] ; SPECIAL PSEUDO TTY HACK?
+ JRST PSEUDO ; YES, RET AS FIX
+; ANDI A,-1
+ TLZ A,200000
+ TRZN A,400000 ; UNDO ! HACK
+ JRST NOEXCL
+ SKIPE E
+ MOVEM A,LSTCH(B)
+ MOVEI A,"! ; RETURN AN !
+NOEXC1: SKIPGE B,A ; CHECK EOF
+ SOS (P) ; DO EOF RETURN
+ MOVE B,A ; CHAR TO B
+ MOVSI A,TCHRS
+PSEUD1: AOS (P)
+ POPJ P,
+
+PSEUDO: MOVE F,B
+ SKIPE E
+ PUSHJ P,LSTCH2
+ MOVE B,A
+ MOVSI A,TFIX
+ JRST PSEUD1
+
+NOEXCL: JUMPE E,NOEXC1
+ MOVE F,B
+ PUSHJ P,LSTCH2
+ JRST NOEXC1
+
+; READER ERRORS COME HERE
+
+ERRPAR: PUSH TP,$TCHRS ;DO THE OFFENDER
+ PUSH TP,B
+ PUSH TP,$TCHRS
+ PUSH TP,[40] ;SPACE
+ PUSH TP,$TCHSTR
+ PUSH TP,CHQUOT UNEXPECTED
+ JRST MISMA1
+
+;COMPLAIN ABOUT MISMATCHED CLOSINGS
+
+MISMAB: SKIPA A,["]]
+MISMAT: MOVE A,-1(P) ;GOBBLE THE DESIRED CHARACTER
+ JUMPE B,CPOPJ ;IGNORE UNIVERSAL CLOSE
+ PUSH TP,$TCHRS
+ PUSH TP,B
+ PUSH TP,$TCHSTR
+ PUSH TP,CHQUOT [ INSTEAD-OF ]
+ PUSH TP,$TCHRS
+ PUSH TP,A
+MISMA1: MCALL 3,STRING
+ PUSH TP,$TATOM
+ PUSH TP,EQUOTE READER-SYNTAX-ERROR-ERRET-ANYTHING-TO-GO-ON
+ PUSH TP,A
+ PUSH TP,B
+ PUSH TP,$TATOM
+ PUSH TP,MQUOTE READ
+ MCALL 3,ERROR
+CPOPJ: POPJ P,
+\f
+; HERE ON BAD INPUT CHARACTER
+
+BADCHR: ERRUUO EQUOTE BAD-ASCII-CHARACTER
+
+; HERE ON YUCKY PARSE TABLE
+
+BADPTB: ERRUUO EQUOTE BAD-MACRO-TABLE
+
+BDPSTR: ERRUUO EQUOTE BAD-PARSE-STRING
+
+ILLSQG: PUSHJ P,LSTCHR ; DON'T MESS WITH IT AGAIN
+ ERRUUO EQUOTE BAD-USE-OF-SQUIGGLY-BRACKETS
+
+
+;FLOATING POINT NUMBER TOO LARGE OR SMALL
+FOOR: ERRUUO EQUOTE NUMBER-OUT-OF-RANGE
+
+
+NILSXP: 0,,0
+
+LSTCHR: SKIPL F,5(TB) ;GET CHANNEL
+ JRST LSTCH1 ;NO CHANNEL, POINT AT SLOT
+
+LSTCH2: SKIPE LSTCH(F) ;ARE WE REALLY FLUSHING A REUSE CHARACTER ?
+ PUSHJ P,CNTACX
+ SETZM LSTCH(F)
+ POPJ P,
+
+LSTCH1: SETZM 5(TB) ;ZERO THE LETTER AND RETURN
+ POPJ P,
+
+CNTACC: MOVE F,B
+CNTACX: HRRZ G,-2(F) ; GET BITS
+ TRNE G,C.BIN
+ JRST CNTBIN
+ AOS ACCESS(F)
+CNTDON: POPJ P,
+
+CNTBIN: AOS G,ACCESS-1(F)
+ CAMN G,[TFIX,,1]
+ AOS ACCESS(F)
+ CAMN G,[TFIX,,5]
+ HLLZS ACCESS-1(F)
+ POPJ P,
+
+
+;TABLE OF NAMES OF ARGS AND ALLOWED TYPES
+
+ARGS:
+ IRP A,,[[[CAIN C,TUNBOU]],[[CAIE C,TCHAN],INCHAN],[[PUSHJ P,CHOBL],OBLIST]]
+ IRP B,C,[A]
+ B
+ IFSN [C],IMQUOTE C
+ .ISTOP
+ TERMIN
+ TERMIN
+
+CHOBL: CAIE C,TLIST ;A LIST OR AN OBLIST
+ CAIN C,TOBLS
+ AOS (P)
+ POPJ P,
+
+END
+
+\f
\ No newline at end of file
--- /dev/null
+
+TITLE READER FOR MUDDLE
+
+;C. REEVE DEC. 1970
+
+RELOCA
+
+READER==1 ;TELL MUDDLE > TO USE SOME SPECIAL HACKS
+FRMSIN==1 ;FLAG SAYING WHETHER OR "." AND "'" HACKS EXIST
+KILTV==1 ;FLAG SAYING THAT (TVP) SHOULD BE REMOVED (MUDDLE 54 ONLY)
+
+.INSRT MUDDLE >
+
+F==PVP
+G==TVP
+
+.GLOBAL CONS,VECTOR,NXTCHR,RLOOKU,CRADIX,SPTIME,QUOTE,CHMAK,FLUSCH,IGET
+.GLOBAL SETDEV,OPNCHN,ILVAL,RADX,IDVAL,LSTCH,EVECTOR,EUVECTOR,CHUNW,NONSPC
+.GLOBAL CHRWRD,EOFCND,DIRECT,ACCESS,IOINS,ROOT,DIRECT,DOIOTI,DOACCS,IGVAL,BYTDOP
+.GLOBAL ICONS,INCONS,IEVECT,IEUVEC,BUFSTR,TYPFND,SQUTOA,SQUKIL,IBLOCK,GRB
+.GLOBAL BADCHN,WRONGD,CHNCLS,FNFFL,IPUT,IGET,ILOC,RXCT,WXCT,IUNWIN,UNWIN2
+.GLOBAL CNXTCH,CREADC,MPOPJ,CREDC1,CNXTC1,IREMAS,CBYTES,PVSTOR,SPSTOR,DSTORE
+.GLOBAL SFIX
+.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
+
+BUFLNT==100
+
+FF=0 ;FALG REGISTER DURING NUMBER CONVERSION
+
+;FLAGS USED (RIGHT HALF)
+
+NOTNUM==1 ;NOT A NUMBER
+NFIRST==2 ;NOT FIRST CHARACTER BEING READ
+DECFRC==4 ;FORCE DECIMAL CONVERSION
+NEGF==10 ;NEGATE THIS THING
+NUMWIN==20 ;DIGIT(S) SEEN
+INSTRN==40 ;IN QUOTED CHARACTER STRING
+FLONUM==100 ;NUMBER IS FLOOATING POINT
+DOTSEN==200 ;. SEEN IN IMPUT STREAM
+EFLG==400 ;E SEEN FOR EXPONENT
+FRSDOT==1000 ;. CAME FIRST
+USEAGN==2000 ;SPECIAL DOT HACK
+
+OCTWIN==4000
+OCTSTR==10000
+OVFLEW==40000
+ENEG==100000
+EPOS==200000
+;TEMPORARY OFFSETS
+
+VCNT==0 ;NUMBER OF ELEMENTS IN CURRENT VECTOR
+ONUM==-4 ;CURRENT NUMBER IN OCTAL
+DNUM==-4 ;CURRENT NUMBER IN DECIMAL
+CNUM==-2 ;IN CURRENT RADIX
+NDIGS==0 ;NUMBER OF DIGITS
+ENUM==-2 ;EXPONENT
+NUMTMP==6
+
+; TABLE OF POWERS OF TEN
+
+TENTAB: REPEAT 39. 10.0^<.RPCNT-1>
+
+ITENTB: REPEAT 11. 10.^<.RPCNT-1>
+
+
+\f; TEXT FILE LOADING PROGRAM
+
+MFUNCTION MLOAD,SUBR,[LOAD]
+
+ ENTRY
+
+ HLRZ A,AB ;GET NO. OF ARGS
+ CAIE A,-4 ;IS IT 2
+ JRST TRY2 ;NO, TRY ANOTHER
+ GETYP A,2(AB) ;GET TYPE
+ CAIE A,TOBLS ;IS IT OBLIST
+ CAIN A,TLIST ; OR LIST THEREOF?
+ JRST CHECK1
+ JRST WTYP2
+
+TRY2: CAIE A,-2 ;IS ONE SUPPLIED
+ JRST WNA
+
+CHECK1: GETYP A,(AB) ;GET TYPE
+ CAIE A,TCHAN ;IS IT A CHANNEL
+ JRST WTYP1
+
+LOAD1: HLRZ A,TB ;GET CURRENT TIME
+ PUSH TP,$TTIME ;AND SAVE IT
+ PUSH TP,A
+
+ MOVEI C,CLSNGO ; LOCATION OF FUNNY CLOSER
+ PUSHJ P,IUNWIN ; SET UP AS UNWINDER
+
+LOAD2: PUSH TP,(AB) ;USE SUPPLIED CHANNEL
+ PUSH TP,1(AB)
+ PUSH TP,(TB) ;USE TIME AS EOF ARG
+ PUSH TP,1(TB)
+ CAML AB,C%M20 ; [-2,,0] ;CHECK FOR 2ND ARG
+ JRST LOAD3 ;NONE
+ PUSH TP,2(AB) ;PUSH ON 2ND ARG
+ PUSH TP,3(AB)
+ MCALL 3,READ
+ JRST CHKRET ;CHECK FOR EOF RET
+
+LOAD3: MCALL 2,READ
+CHKRET: CAMN A,(TB) ;IS TYPE EOF HACK
+ CAME B,1(TB) ;AND IS VALUE
+ JRST EVALIT ;NO, GO EVAL RESULT
+ PUSH TP,(AB)
+ PUSH TP,1(AB)
+ MCALL 1,FCLOSE
+ MOVE A,$TCHSTR
+ MOVE B,CHQUOTE DONE
+ JRST FINIS
+
+CLSNGO: PUSH TP,$TCHAN
+ PUSH TP,1(AB)
+ MCALL 1,FCLOSE
+ JRST UNWIN2 ; CONTINUE UNWINDING
+
+EVALIT: PUSH TP,A
+ PUSH TP,B
+ MCALL 1,EVAL
+ JRST LOAD2
+
+
+
+; OTHER FILE LOADING PROGRAM
+
+
+\f
+MFUNCTION FLOAD,SUBR
+
+ ENTRY
+
+ MOVEI C,1 ;INITIALIZE OPEN'S ARG COUNT
+ PUSH TP,$TAB ;SLOT FOR SAVED AB
+ PUSH TP,C%0 ; [0] ;EMPTY FOR NOW
+ PUSH TP,$TCHSTR ;PUT IN FIRST ARG
+ PUSH TP,CHQUOTE READ
+ MOVE A,AB ;COPY OF ARGUMENT POINTER
+
+FARGS: JUMPGE A,CALOPN ;DONE? IF SO CALL OPEN
+ GETYP B,(A) ;NO, CHECK TYPE OF THIS ARG
+ CAIE B,TOBLS ;OBLIST?
+ CAIN B,TLIST ; OR LIST THEREOF
+ JRST OBLSV ;YES, GO SAVE IT
+
+ PUSH TP,(A) ;SAVE THESE ARGS
+ PUSH TP,1(A)
+ ADD A,C%22 ; [2,,2] ;BUMP A
+ AOJA C,FARGS ;COUNT AND GO
+
+OBLSV: MOVEM A,1(TB) ;SAVE THE AB
+
+CALOPN: ACALL C,FOPEN ;OPEN THE FILE
+
+ JUMPGE B,FNFFL ;FILE MUST NO EXIST
+ EXCH A,(TB) ;PLACE CHANNEL ON STACK
+ EXCH B,1(TB) ;OBTAINING POSSIBLE OBLIST
+ JUMPN B,2ARGS ;OBLIST SUOPPLIED?
+
+ MCALL 1,MLOAD ;NO, JUST CALL
+ JRST FINIS
+
+
+2ARGS: PUSH TP,(B) ;PUSH THE OBLIST
+ PUSH TP,1(B)
+ MCALL 2,MLOAD
+ JRST FINIS
+
+
+FNFFL: PUSH TP,$TATOM
+ PUSH TP,EQUOTE FILE-SYSTEM-ERROR
+ JUMPE B,CALER1
+ PUSH TP,A
+ PUSH TP,B
+ MOVEI A,2
+ JRST CALER
+
+\fMFUNCTION READ,SUBR
+
+ ENTRY
+
+ PUSH P,[SETZ IREAD1] ;WHERE TO GO AFTER BINDING
+READ0: PUSH TP,$TTP ;SLOT FOR LAST THING READ (TYPE IS UNREADABLE)
+ PUSH TP,C%0
+ PUSH TP,$TFIX ;SLOT FOR RADIX
+ PUSH TP,C%0
+ PUSH TP,$TCHAN ;AND SLOT FOR CHANNEL
+ PUSH TP,C%0
+ PUSH TP,C%0 ; USER DISP SLOT
+ PUSH TP,C%0
+ PUSH TP,$TSPLICE
+ PUSH TP,C%0 ;SEGMENT FOR SPLICING MACROS
+ JUMPGE AB,READ1 ;NO ARGS, NO BINDING
+ GETYP C,(AB) ;ISOLATE TYPE
+ CAIN C,TUNBOU
+ JRST WTYP1
+ PUSH TP,[TATOM,,-1] ;PUSH THE ATOMS
+ PUSH TP,IMQUOTE INCHAN
+ PUSH TP,(AB) ;PUSH ARGS
+ PUSH TP,1(AB)
+ PUSH TP,C%0 ;DUMMY
+ PUSH TP,C%0
+ MOVE B,1(AB) ;GET CHANNEL POINTER
+ ADD AB,C%22 ;AND ARG POINTER
+ JUMPGE AB,BINDEM ;MORE?
+ PUSH TP,[TVEC,,-1]
+ ADD B,[EOFCND-1,,EOFCND-1]
+ PUSH TP,B
+ PUSH TP,(AB)
+ PUSH TP,1(AB)
+ ADD AB,C%22
+ JUMPGE AB,BINDEM ;IF ANY MORE ARGS GO PROCESS AND BIND THEM
+ GETYP C,(AB) ;ISOLATE TYPE
+ CAIE C,TLIST
+ CAIN C,TOBLS
+ SKIPA
+ JRST WTYP3
+ PUSH TP,[TATOM,,-1] ;PUSH THE ATOMS
+ PUSH TP,IMQUOTE OBLIST
+ PUSH TP,(AB) ;PUSH ARGS
+ PUSH TP,1(AB)
+ PUSH TP,C%0 ;DUMMY
+ PUSH TP,C%0
+ ADD AB,C%22 ;AND ARG POINTER
+ JUMPGE AB,BINDEM ; ALL DONE, BIND ATOMS
+ GETYP 0,(AB) ; GET TYPE OF TABLE
+ CAIE 0,TVEC ; SKIP IF BAD TYPE
+ JRST WTYP ; ELSE COMPLAIN
+ PUSH TP,[TATOM,,-1]
+ PUSH TP,IMQUOTE READ-TABLE
+ PUSH TP,(AB)
+ PUSH TP,1(AB)
+ PUSH TP,C%0
+ PUSH TP,C%0
+ ADD AB,C%22 ; BUMP TO NEXT ARG
+ JUMPL AB,TMA ;MORE ?, ERROR
+BINDEM: PUSHJ P,SPECBIND
+ JRST READ1
+
+MFUNCTION RREADC,SUBR,READCHR
+
+ ENTRY
+ PUSH P,[SETZ IREADC]
+ JRST READC0 ;GO BIND VARIABLES
+
+MFUNCTION NXTRDC,SUBR,NEXTCHR
+
+ ENTRY
+
+ PUSH P,[SETZ INXTRD]
+READC0: CAMGE AB,C%M40 ; [-5,,]
+ JRST TMA
+ PUSH TP,(AB)
+ PUSH TP,1(AB)
+ JUMPL AB,READC1
+ MOVE B,IMQUOTE INCHAN
+ PUSHJ P,IDVAL
+ GETYP 0,A
+ CAIE 0,TCHAN
+ JRST BADCHN
+ MOVEM A,-1(TP)
+ MOVEM B,(TP)
+READC1: PUSHJ P,@(P)
+ JRST .+2
+ JRST FINIS
+
+ PUSH TP,-1(TP)
+ PUSH TP,-1(TP)
+ MCALL 1,FCLOSE
+ MOVE A,EOFCND-1(B)
+ MOVE B,EOFCND(B)
+ CAML AB,C%M20 ; [-3,,]
+ JRST .+3
+ MOVE A,2(AB)
+ MOVE B,3(AB)
+ PUSH TP,A
+ PUSH TP,B
+ MCALL 1,EVAL
+ JRST FINIS
+
+
+MFUNCTION PARSE,SUBR
+
+ ENTRY
+
+ PUSHJ P,GAPRS ;GET ARGS FOR PARSES
+ PUSHJ P,GPT ;GET THE PARSE TABLE
+ PUSHJ P,NXTCH ; GET A CHAR TO TEST FOR ! ALT
+ SKIPN 11.(TB) ; EOF HIT, COMPLAIN TO LOOSER
+ JRST NOPRS
+ MOVEI A,33 ; CHANGE IT TO AN ALT, SNEAKY HUH?
+ CAIN B,MANYT ; TYPE OF MULTIPLE CLOSE, I.E. ! ALT
+ MOVEM A,5(TB)
+ PUSHJ P,IREAD1 ;GO DO THE READING
+ JRST .+2
+ JRST LPSRET ;PROPER EXIT
+NOPRS: ERRUUO EQUOTE CAN'T-PARSE
+
+MFUNCTION LPARSE,SUBR
+
+ ENTRY
+
+ PUSHJ P,GAPRS ;GET THE ARGS TO THE PARSE
+ JRST LPRS1
+
+GAPRS: PUSH TP,$TTP
+ PUSH TP,C%0
+ PUSH TP,$TFIX
+ PUSH TP,[10.]
+ PUSH TP,$TFIX
+ PUSH TP,C%0 ; LETTER SAVE
+ PUSH TP,C%0
+ PUSH TP,C%0 ; PARSE TABLE MAYBE?
+ PUSH TP,$TSPLICE
+ PUSH TP,C%0 ;SEGMENT FOR SPLICING MACROS
+ PUSH TP,C%0 ;SLOT FOR LOCATIVE TO STRING
+ PUSH TP,C%0
+ JUMPGE AB,USPSTR
+ PUSH TP,[TATOM,,-1]
+ PUSH TP,IMQUOTE PARSE-STRING
+ PUSH TP,(AB)
+ PUSH TP,1(AB) ; BIND OLD PARSE-STRING
+ PUSH TP,C%0
+ PUSH TP,C%0
+ PUSHJ P,SPECBIND
+ ADD AB,C%22
+ JUMPGE AB,USPSTR
+ GETYP 0,(AB)
+ CAIE 0,TFIX
+ JRST WTYP2
+ MOVE 0,1(AB)
+ MOVEM 0,3(TB)
+ ADD AB,C%22
+ JUMPGE AB,USPSTR
+ GETYP 0,(AB)
+ CAIE 0,TLIST
+ CAIN 0,TOBLS
+ SKIPA
+ JRST WTYP3
+ PUSH TP,[TATOM,,-1]
+ PUSH TP,IMQUOTE OBLIST
+ PUSH TP,(AB)
+ PUSH TP,1(AB) ; HE WANTS HIS OWN OBLIST
+ PUSH TP,C%0
+ PUSH TP,C%0
+ PUSHJ P,SPECBIND
+ ADD AB,C%22
+ JUMPGE AB,USPSTR
+ GETYP 0,(AB)
+ CAIE 0,TVEC
+ JRST WTYP
+ PUSH TP,[TATOM,,-1]
+ PUSH TP,IMQUOTE PARSE-TABLE
+ PUSH TP,(AB)
+ PUSH TP,1(AB)
+ PUSH TP,C%0
+ PUSH TP,C%0
+ PUSHJ P,SPECBIND
+ ADD AB,C%22
+ JUMPGE AB,USPSTR
+ GETYP 0,(AB)
+ CAIE 0,TCHRS
+ JRST WTYP
+ MOVE 0,1(AB)
+ MOVEM 0,5(TB) ; STUFF IN A LOOK-AHEAD CHARACTER IF HE WANTS
+ ADD AB,C%22
+ JUMPL AB,TMA
+USPSTR: MOVE B,IMQUOTE PARSE-STRING
+ PUSHJ P,ILOC ; GET A LOCATIVE TO THE STRING, WHEREVER
+ GETYP 0,A
+ CAIN 0,TUNBOUND ; NONEXISTANT
+ JRST BDPSTR
+ GETYP 0,(B) ; IT IS POINTING TO A STRING
+ CAIE 0,TCHSTR
+ JRST BDPSTR
+ MOVEM A,10.(TB)
+ MOVEM B,11.(TB)
+ POPJ P,
+
+LPRS1: PUSHJ P,GPT ; GET THE VALUE OF PARSE-TABLE IN SLOT
+ PUSH TP,$TLIST
+ PUSH TP,C%0 ; HERE WE ARE MAKE PLACE TO SAVE GOODIES
+ PUSH TP,$TLIST
+ PUSH TP,C%0
+LPRS2: PUSHJ P,IREAD1
+ JRST LPRSDN ; IF WE ARE DONE, WE ARE THROUGH
+ MOVE C,A
+ MOVE D,B
+ PUSHJ P,INCONS
+ SKIPN -2(TP)
+ MOVEM B,-2(TP) ; SAVE THE BEGINNING ON FIRST
+ SKIPE C,(TP)
+ HRRM B,(C) ; PUTREST INTO IT
+ MOVEM B,(TP)
+ JRST LPRS2
+LPRSDN: MOVSI A,TLIST
+ MOVE B,-2(TP)
+LPSRET: SKIPLE C,5(TB) ; EXIT FOR PARSE AND LPARSE
+ CAIN C,400033 ; SEE IF NO PEEK AHEAD OR IF ! ALTMODE
+ JRST FINIS ; IF SO NO NEED TO BACK STRING ONE
+ SKIPN C,11.(TB)
+ JRST FINIS ; IF ATE WHOLE STRING, DONT GIVE BACK ANY
+BUPRS: MOVEI D,1
+ ADDM D,(C) ; AOS THE COUNT OF STRING LENGTH
+ SKIPG D,1(C) ; SEXIER THAN CLR'S CODE FOR DECREMENTING
+ SUB D,[430000,,1] ; A BYTE POINTER
+ ADD D,[70000,,0]
+ MOVEM D,1(C)
+ HRRZ E,2(TB)
+ JUMPE E,FINIS ; SEE IF WE NEED TO BACK UP TWO
+ HLLZS 2(TB) ; CLEAR OUT DOUBLE CHR LOOKY FLAG
+ JRST BUPRS ; AND BACK UP PARSE STRING A LITTLE MORE
+
+\f; ARGUMENTS ARE BOUND, NOW GET THE VALUES OF THINGS
+
+
+GRT: MOVE B,IMQUOTE READ-TABLE
+ SKIPA ; HERE TO GET TABLE FOR READ
+GPT: MOVE B,IMQUOTE PARSE-TABLE
+ MOVSI A,TATOM ; TO FILL SLOT WITH PARSE TABLE
+ PUSHJ P,ILVAL
+ GETYP 0,A
+ CAIN 0,TUNBOUND
+ POPJ P,
+ CAIE 0,TVEC
+ JRST BADPTB
+ MOVEM A,6(TB)
+ MOVEM B,7(TB)
+ POPJ P,
+
+READ1: PUSHJ P,GRT
+ MOVE B,IMQUOTE INCHAN
+ MOVSI A,TATOM
+ PUSHJ P,IDVAL ;NOW GOBBLE THE REAL CHANNEL
+ TLZ A,TYPMSK#777777
+ HLLZS A ; INCASE OF FUNNY BUG
+ CAME A,$TCHAN ;IS IT A CHANNEL
+ JRST BADCHN
+ MOVEM A,4(TB) ; STORE CHANNEL
+ MOVEM B,5(TB)
+ HRRZ A,-2(B)
+ TRNN A,C.OPN
+ JRST CHNCLS
+ TRNN A,C.READ
+ JRST WRONGD
+ HLLOS 4(TB)
+ TRNE A,C.BIN ; SKIP IF NOT BIN
+ JRST BREAD ; CHECK FOR BUFFER
+ HLLZS 4(TB)
+GETIOA: MOVE B,5(TB)
+GETIO: MOVE A,IOINS(B) ;GOBBLE THE I/O INSTRUCTION
+ JUMPE A,OPNFIL ;GO REALLY OPEN THE CROCK
+ MOVE A,RADX(B) ;GET RADIX
+ MOVEM A,3(TB)
+ MOVEM B,5(TB) ;SAVE CHANNEL
+REREAD: HRRZ D,LSTCH(B) ;ANY CHARS AROUND?
+ MOVEI 0,33
+ CAIN D,400033 ;FLUSH THE TERMINATOR HACK
+ HRRM 0,LSTCH(B) ; MAKE ! ALT INTO JUST ALT IF IT IS STILL AROUND
+
+ PUSHJ P,@(P) ;CALL INTERNAL READER
+ JRST BADTRM ;LOST
+RFINIS: SUB P,C%11 ;POP OFF LOSER
+ PUSH TP,A
+ PUSH TP,B
+ JUMPE C,FLSCOM ; FLUSH TOP LEVEL COMMENT
+ PUSH TP,C
+ PUSH TP,D
+ MOVE A,4(TB)
+ MOVE B,5(TB) ; GET CHANNEL
+ MOVSI C,TATOM
+ MOVE D,IMQUOTE COMMENT
+ PUSHJ P,IPUT
+RFINI1: POP TP,B
+ POP TP,A
+ JRST FINIS
+
+FLSCOM: MOVE A,4(TB)
+ MOVE B,5(TB)
+ MOVSI C,TATOM
+ MOVE D,IMQUOTE COMMENT
+ PUSHJ P,IREMAS
+ JRST RFINI1
+
+BADTRM: MOVE C,5(TB) ; GET CHANNEL
+ JUMPGE B,CHLSTC ;NO, MUST BE UNMATCHED PARENS
+ SETZM LSTCH(C) ; DONT REUSE EOF CHR
+ PUSH TP,4(TB) ;CLOSE THE CHANNEL
+ PUSH TP,5(TB)
+ MCALL 1,FCLOSE
+ PUSH TP,EOFCND-1(B)
+ PUSH TP,EOFCND(B)
+ MCALL 1,EVAL ;AND EVAL IT
+ SETZB C,D
+ GETYP 0,A ; CHECK FOR FUNNY ACT
+ CAIE 0,TREADA
+ JRST RFINIS ; AND RETURN
+
+ PUSHJ P,CHUNW ; UNWIND TO POINT
+ MOVSI A,TREADA ; SEND MESSAGE BACK
+ JRST CONTIN
+
+;HERE TO ATTEMPT TO OPEN A CLOSED CHANNEL
+
+OPNFIL: PUSHJ P,OPNCHN ;GO DO THE OPEN
+ JUMPGE B,FNFFL ;LOSE IC B IS 0
+ JRST GETIO
+
+
+CHLSTC: MOVE B,5(TB) ;GET CHANNEL BACK
+ JRST REREAD
+
+
+BREAD: MOVE B,5(TB) ; GET CHANNEL
+ SKIPE BUFSTR(B)
+ JRST GETIO
+ MOVEI A,BUFLNT ; GET A BUFFER
+ PUSHJ P,IBLOCK
+ MOVEI C,BUFLNT(B) ; POINT TO END
+ HRLI C,440700
+ MOVE B,5(TB) ; CHANNEL BACK
+ MOVEI 0,C.BUF
+ IORM 0,-2(B)
+ MOVEM C,BUFSTR(B)
+ MOVSI C,TCHSTR+.VECT.
+ MOVEM C,BUFSTR-1(B)
+ JRST GETIO
+\f;MAIN ENTRY TO READER
+
+NIREAD: PUSHJ P,LSTCHR
+NIREA1: PUSH P,C%M1 ; [-1] ; DONT GOBBLE COMMENTS
+ JRST IREAD2
+
+IREAD:
+ PUSHJ P,LSTCHR ;DON'T REREAD LAST CHARACTER
+IREAD1: PUSH P,C%0 ; FLAG SAYING SNARF COMMENTS
+IREAD2: INTGO
+BDLP: SKIPE C,9.(TB) ;HAVE WE GOT A SPLICING MACRO LEFT
+ JRST SPLMAC ;IF SO GIVE HIM SOME OF IT
+ PUSHJ P,NXTCH ;GOBBLE CHAR IN A AND TYPE IN D
+ MOVMS B ; FOR SPECIAL NEG HACK OF MACRO TABLES
+ CAIG B,ENTYPE
+ JUMPN B,@DTBL-1(B) ;ERROR ON ZERO TYPE OR FUNNY TYPE
+ JRST BADCHR
+
+
+SPLMAC: HRRZ D,(C) ;GET THE REST OF THE SEGMENT
+ MOVEM D,9.(TB) ;AND PUT BACK IN PLACE
+ GETYP D,(C) ;SEE IF DEFERMENT NEEDED
+ CAIN D,TDEFER
+ MOVE C,1(C) ;IF SO, DO DEFEREMENT
+ MOVE A,(C)
+ MOVE B,1(C) ;GET THE GOODIE
+ AOS -1(P) ;ALWAYS A SKIP RETURN
+ POP P,(P) ;DONT WORRY ABOUT COMMENT SEARCHAGE
+ SETZB C,D ;MAKE SURE HE DOESNT THINK WE GOT COMMENT
+ POPJ P, ;GIVE HIM WHAT HE DESERVES
+
+DTBL:
+CODINI==0
+IRP A,,[[LETCOD,LETTER],[NUMCOD,NUMBER],[PLUCOD,PNUMBE],[NEGCOD,NNUMBE],[ASTCOD,ASTSTR],[DOTTYP,DOTSTR],[ETYPE,LETTER]
+[SPATYP,SPACE],[LPATYP,LPAREN],[RPATYP,RPAREN],[LBRTYP,LBRACK],[RBRTYP,RBRACK]
+[QUOTYP,QUOTIT],[MACTYP,MACCAL],[CSTYP,CSTRING],[ESCTYP,ESCSTR],[SPCTYP,SPECTY]
+[SLMNT,OPNANG],[CNGTYP,CLSANG],[EOFTYP,EOFCHR],[COMTYP,COMNT],[GLMNT,GLOVAL]
+[TMPTYP,ILLSQG],[NTYPES,CLSBRA],[EXCEXC,LETTER],[DOTEXT,SEGDOT],[LBREXT,UVECIN]
+[RBREXT,RBRACK],[QUOEXT,QUOSEG],[CSEXT,SINCHR],[SLMEXT,SEGIN],[ELMEXT,CLSANG]
+[GLMEXT,GLOSEG],[PATHTY,LOSPATH],[BSLEXT,SINCHR],[MANYT,TERM],[USTYP1,USRDS1]
+[USTYP2,USRDS2]]
+
+ IRP B,C,[A]
+ CODINI==CODINI+1
+ B==CODINI
+ SETZ C
+ .ISTOP
+ TERMIN
+TERMIN
+
+EXPUNGE CODINI
+
+ENTYPE==.-DTBL
+
+NONSPC==ETYPE
+
+SPACE: PUSHJ P,LSTCHR ;DONT REREAD SPACER
+ JRST BDLP
+
+USRDS1: SKIPA B,A ; GET CHAR IN B
+USRDS2: MOVEI B,200(A) ; ! CHAR, DISP 200 FURTHER
+ ASH B,1
+ ADD B,7(TB) ; POINT TO TABLE ENTRY
+ GETYP 0,(B)
+ CAIN 0,TLIST
+ MOVE B,1(B) ; IF LIST, USE FIRST ITEM-SPECIAL NO BREAK HACK
+ SKIPL C,5(TB) ; GET CHANNEL POINTER (IF ANY)
+ JRST USRDS3
+ ADD C,[EOFCND-1,,EOFCND-1]
+ PUSH TP,$TBVL
+ MOVE SP,SPSTOR+1
+ HRRM SP,(TP) ; BUILD A TBVL
+ MOVE SP,TP
+ MOVEM SP,SPSTOR+1
+ PUSH TP,C
+ PUSH TP,(C)
+ PUSH TP,1(C)
+ MOVE PVP,PVSTOR+1
+ MOVEI D,PVLNT*2+1(PVP)
+ HRLI D,TREADA
+ MOVEM D,(C)
+ MOVEI D,(TB)
+ HLL D,OTBSAV(TB)
+ MOVEM D,1(C)
+USRDS3: PUSH TP,(B) ; APPLIER
+ PUSH TP,1(B)
+ PUSH TP,$TCHRS ; APPLY TO CHARACTER
+ PUSH TP,A
+ PUSHJ P,LSTCHR ; FLUSH CHAR
+ MCALL 2,APPLY ; GO TO USER GOODIE
+ SKIPL 5(TB)
+ JRST USRDS9
+ MOVE SP,SPSTOR+1
+ HRRZ E,1(SP) ; POINT TO EOFCND SLOT
+ HRRZ SP,(SP) ; UNBIND MANUALLY
+ MOVEI D,(TP)
+ SUBI D,(SP)
+ MOVSI D,(D)
+ HLL SP,TP
+ SUB SP,D
+ MOVEM SP,SPSTOR+1
+ POP TP,1(E)
+ POP TP,(E)
+ SUB TP,C%22 ; FLUSH TP CRAP
+USRDS9: GETYP 0,A ; CHECK FOR DISMISS?
+ CAIN 0,TSPLICE
+ JRST GOTSPL ; RETURN OF SEGMENT INDICATES SPLICAGE
+ CAIN 0,TREADA ; FUNNY?
+ JRST DOEOF
+ CAIE 0,TDISMI
+ JRST RET ; NO, RETURN FROM IREAD
+ JRST BDLP ; YES, IGNORE RETURN
+
+GOTSPL: MOVEM B,9.(TB) ; STICK IN THE SPLICAGE SLOT SO IREADS WILL GET HIM
+ JRST BDLP ; GO BACK AND READ FROM OUR SPLICE, OK?
+
+\f
+;HERE ON NUMBER OR LETTER, START ATOM
+
+ESCSTR: PUSHJ P,NXTC1 ; ESCAPE FIRST
+LETTER: MOVEI FF,NOTNUM ; LETTER
+ JRST ATMBLD
+
+ASTSTR: MOVEI FF,OCTSTR
+DOTST1: MOVEI B,0
+ JRST NUMBLD
+
+NUMBER: MOVEI FF,NUMWIN ; SYMBOL OR NUMBER
+NUMBR1: MOVEI B,(A) ; TO A NUMBER
+ SUBI B,60
+ JRST NUMBLD
+
+PNUMBE: SETZB FF,B
+ JRST NUMBLD
+
+NNUMBE: MOVEI FF,NEGF
+ MOVEI B,0
+
+NUMBLD: PUSH TP,$TFIX
+ PUSH TP,B
+ PUSH TP,$TFIX
+ PUSH TP,B
+ PUSH TP,$TFIX
+ PUSH TP,C%0
+
+ATMBLD: LSH A,<36.-7>
+ PUSH P,A
+ MOVEI D,1 ; D IS CHAR COUNT
+ MOVSI C,350700+P ; BYTE PNTR
+ PUSHJ P,LSTCHR
+
+ATLP: PUSH P,FF
+ INTGO
+
+ PUSHJ P,NXTCH ; GET NEXT CHAR
+ POP P,FF
+ TRNN FF,NOTNUM ; IF NOT NUMBER, SKIP
+ JRST NUMCHK
+
+ATLP2: CAILE B,NONSPC ; SKIP IF STILL LETTER OR NUMBER
+ JRST CHKEND
+
+ATLP1: PUSHJ P,LSTCHR ; DONT REUSE
+ IDPB A,C ; INTO ATOM
+ TLNE C,760000 ; SKIP IF OK WORD
+ AOJA D,ATLP
+
+ PUSH P,C%0
+ MOVSI C,440700+P
+ AOJA D,ATLP
+
+CHKEND: CAIN B,ESCTYP ; ESCAPE?
+ JRST DOESC1
+
+CHKEN1: SKIPGE C ; SKIP IF TOP SLOT FULL
+ SUB P,C%11
+ PUSH P,D ; COUNT OF CHARS
+
+ JRST LOOPA ; GO HACK TRAILERS
+
+
+; HERE IF STILL COULD BE A NUMBER
+
+NUMCHK: CAIN B,NUMCOD ; STILL NUMBER
+ JRST NUMCH1
+
+ CAILE B,NONSPC ; NUMBER FINISHED?
+ JRST NUMCNV
+
+ CAIN B,DOTTYP
+ TROE FF,DOTSEN
+ JRST NUMCH2
+ TRNE FF,OCTSTR+EFLG
+ JRST NUMCH3 ; NO . IN OCTAL OR EXPONENT
+ TRO FF,DECFRC ; MUST BE DECIMAL NOW
+ JRST ATLP1
+
+NUMCH1: TRO FF,NUMWIN
+ MOVEI B,(A)
+ SUBI B,60
+ TRNE FF,OCTSTR+OCTWIN ; IS THIS *DDDDDD* HACK
+ JRST NUMCH4 ; YES, GO DO IT
+ TRNE FF,EFLG
+ JRST NUMCH7 ; DO EXPONENT
+
+ TRNE FF,DOTSEN ; FORCE FLOAT
+ JRST NUMCH5
+
+ JFCL 17,.+1 ; KILL ALL FLAGS
+ MOVE E,CNUM(TP) ; COMPUTE CURRENT RADIX
+ IMUL E,3(TB)
+ ADDI E,(B) ; ADD IN CURRENT DIGIT
+ JFCL 10,.+3
+ MOVEM E,CNUM(TP)
+ JRST NUMCH6
+
+ MOVE E,3(TB) ; SEE IF CURRENT RADIX DECIMAL
+ CAIE E,10.
+ JRST NUMCH5 ; YES, FORCE FLOAT
+ TROA FF,OVFLEW
+
+NUMCH5: TRO FF,FLONUM ; SET FLOATING FLAG
+NUMCH6: JFCL 17,.+1 ; CLEAR ALL FLAGS
+ MOVE E,DNUM(TP) ; GET DECIMAL NUMBER
+ IMULI E,10.
+ JFCL 10,NUMCH8 ; JUMP IF OVERFLOW
+ ADDI E,(B) ; ADD IN DIGIT
+ MOVEM E,DNUM(TP)
+ TRNE FF,FLONUM ; IS THIS FRACTION?
+ SOS NDIGS(TP) ; YES, DECREASE EXPONENT BY ONE
+ JRST ATLP1
+
+NUMCH8: TRNE FF,DOTSEN ; OVERFLOW IN DECMIMAL
+ JRST ATLP1 ; OK, IN FRACTION
+
+ AOS NDIGS(TP)
+ TRO FF,FLONUM ; MAKE IT FLOATING TO FIT
+ JRST ATLP1
+
+NUMCH4: TRNE FF,OCTWIN
+ JRST NUMCH3 ; ALREADY ONE, MORE DIGITS LOSE
+ MOVE E,ONUM(TP)
+ TLNE E,700000 ; SKIP IF WORD NOT FULL
+ TRO FF,OVFLEW
+ LSH E,3
+ ADDI E,(B) ; ADD IN NEW ONE
+ MOVEM E,ONUM(TP)
+ JRST ATLP1
+
+NUMCH3: SUB TP,[NUMTMP,,NUMTMP] ; FLUSH NUMBER CRUFT
+ TRO FF,NOTNUM
+ JRST ATLP2
+
+NUMCH2: CAIN B,ASTCOD ; POSSIBLE END OF OCTAL
+ TRZN FF,OCTSTR ; RESET FLAG AND WIN
+ JRST NUMCH9
+
+ TRO FF,OCTWIN
+ JRST ATLP2
+
+NUMCH9: CAIN B,ETYPE
+ TROE FF,EFLG
+ JRST NUMC10 ; STILL COULD BE +- EXPONENT
+
+ TRZ FF,NUMWIN ; IN CASE NO MORE DIGITS
+ SETZM ENUM(TP)
+ JRST ATLP1
+
+NUMCH7: MOVE E,ENUM(TP)
+ IMULI E,10.
+ ADDI E,(B)
+ MOVEM E,ENUM(TP) ; UPDATE ECPONENT
+ TRO FF,EPOS ; FLUSH IF SIGN COMES NOW
+ JRST ATLP1
+
+NUMC10: TRNN FF,EFLG ; IF NOT IN EXPONENT, LOSE
+ TRNE FF,ENEG+EPOS ; SIGN FOR EXPONENT SEEN?
+ JRST NUMCH3 ; NOT A NUMBER
+ CAIN B,PLUCOD
+ TRO FF,EPOS
+ CAIN B,NEGCOD
+ TRO FF,ENEG
+ TRNE FF,EPOS+ENEG
+ JRST ATLP1
+ JRST NUMCH3
+
+; HERE AFTER \ QUOTER
+
+DOESC1: PUSHJ P,NXTC1 ; GET CHAR
+ JRST ATLP1 ; FALL BACK INTO LOOP
+
+
+; HERE TO CONVERT NUMBERS AS NEEDED
+
+NUMCNV: CAIE B,ESCTYP
+ TRNE FF,OCTSTR
+ JRST NUMCH3
+ TRNN FF,NUMWIN
+ JRST NUMCH3
+ ADDI D,4
+ IDIVI D,5
+ SKIPGE C ; SKIP IF NEW WORD ADDED
+ ADDI D,1
+ HRLI D,(D) ; TOO BOTH HALVES
+ SUB P,D ; REMOVE CHAR STRING
+ MOVE D,3(TB) ; IS RADIX 10?
+ CAIE D,10.
+ TRNE FF,DECFRC
+ TRNN FF,FLONUM+EFLG ;IS IT A FLOATING POINT NUMBER
+ TRNE FF,EFLG
+ JRST FLOATIT ;YES, GO MAKE IT WIN
+ TRNE FF,OVFLEW
+ JRST FOOR
+ MOVE B,CNUM(TP)
+ TRNE FF,DECFRC
+ MOVE B,DNUM(TP) ;GRAB FIXED GOODIE
+ TRNE FF,OCTWIN ; SKIP IF NOT OCTAL
+ MOVE B,ONUM(TP) ; USE OCTAL VALUE
+FINID2: MOVSI A,TFIX ;SAY FIXED POINT
+FINID1: TRNE FF,NEGF ;NEGATE
+ MOVNS B ;YES
+ SUB TP,[NUMTMP,,NUMTMP] ;FINISH HACK
+ JRST RET ;AND RETURN
+
+\f
+FLOATIT:
+ JFCL 17,.+1 ;CLEAR ALL ARITHMETIC FLAGS
+ TRNE FF,EFLG ;"E" SEEN?
+ JRST EXPDO ;YES, DO EXPONENT
+ MOVE D,NDIGS(TP) ;GET IMPLICIT EXPONENT
+
+FLOATE: MOVE A,DNUM(TP) ;GET DECIMAL NUMBER
+ IDIVI A,400000 ;SPLIT
+ FSC A,254 ;CONVERT MOST SIGNIFICANT
+ FSC B,233 ; AND LEAST SIGNIFICANT
+ FADR B,A ;COMBINE
+
+ MOVM A,D ;GET MAGNITUDE OF EXPONENT
+ MOVSI E,(1.0)
+ JFCL 17,.+1 ; CLEAR ALL OVERFLOW/UNDERFLOW BITS
+ CAIG A,38. ;HOW BIG?
+ JRST .+3 ;TOO BIG-FLOATING OUT OF RANGE
+ MOVE E,[1.0^38.]
+ SUBI A,38.
+ JUMPGE D,FLOAT1 ;JUMP IF EXPONENT POSITIVE
+ FDVR B,E
+ FDVR B,TENTAB(A) ;DIVIDE BY TEN TO THE EXPONENT
+ JRST SETFLO
+
+FLOAT1: FMPR B,E
+ FMPR B,TENTAB(A) ;SCALE UP
+
+SETFLO: JFCL 17,FOOR ;FLOATING OUT OF RANGE ON OVERFLOW
+ MOVSI A,TFLOAT
+ TRZ FF,FRSDOT ;FLOATING NUMBER NOT VALUE
+ JRST FINID1
+
+EXPDO:
+ HRRZ D,ENUM(TP) ;GET EXPONENT
+ TRNE FF,ENEG ;IS EXPONENT NEGATIVE?
+ MOVNS D ;YES
+ ADD D,NDIGS(TP) ;ADD IMPLICIT EXPONENT
+ JUMPL D,FLOATE ;FLOATING IF EXPONENT NEGATIVE
+ CAIG D,10. ;OR IF EXPONENT TOO LARGE
+ TRNE FF,FLONUM ;OR IF FLAG SET
+ JRST FLOATE
+ MOVE B,DNUM(TP) ;
+ IMUL B,ITENTB(D)
+ JFCL 10,FLOATE ;IF OVERFLOW, MAKE FLOATING
+ JRST FINID2 ;GO MAKE FIXED NUMBER
+
+
+; HERE TO START BUILDING A CHARACTER STRING GOODIE
+
+CSTRING:
+ PUSH P,C%0
+ MOVEI D,0 ; CHARCOUNT
+ MOVSI C,440700+P ; AND BYTE POINTER
+
+CSLP: PUSH P,FF
+ INTGO
+ PUSHJ P,NXTC1 ; GET NEXT CHAR
+ POP P,FF
+
+ CAIN B,CSTYP ; END OF STRING?
+ JRST CSLPEND
+
+ CAIN B,ESCTYP ; ESCAPE?
+ PUSHJ P,NXTC1
+
+ IDPB A,C ; INTO ATOM
+ TLNE C,760000 ; SKIP IF OK WORD
+ AOJA D,CSLP
+
+ PUSH P,C%0
+ MOVSI C,440700+P
+ AOJA D,CSLP
+
+CSLPEND:
+ SKIPGE C
+ SUB P,C%11
+ PUSH P,D
+ PUSHJ P,CHMAK
+ PUSHJ P,LSTCHR
+
+ JRST RET
+
+;ARRIVE HERE TO INVOKE A READ TIME MACRO FUNCTION
+
+MACCAL: PUSHJ P,NXTCH1 ;READ ONE MORE CHARACTER
+ CAIE B,MACTYP ;IS IT ANOTHER MACRO CHAR
+
+ JRST MACAL2 ;NO, CALL MACRO AND USE VALUE
+ PUSHJ P,LSTCHR ;DONT REREAD %
+ PUSHJ P,MACAL1 ;OTHERWISE, USE SIDE EFFECCT, BUT NOT VALUE
+ JRST IREAD2
+
+MACAL2: PUSH P,CRET
+MACAL1: PUSHJ P,IREAD1 ;READ FUNCTION NAME
+ PUSHJ P,RETERR
+ PUSH TP,C
+ PUSH TP,D ; SAVE COMMENT IF ANY
+ PUSH TP,A ;SAVE THE RESULT
+ PUSH TP,B ;AND USE IT AS AN ARGUMENT
+ MCALL 1,EVAL
+ POP TP,D
+ POP TP,C ; RESTORE COMMENT IF ANY...
+CRET: POPJ P,RET12
+
+;CALL GOBBLE TO FIND THE TYPE AND THEN IREAD TO READ IT
+
+SPECTY: PUSHJ P,NIREAD ; READ THE TYPES NAME (SHOULD BE AN ATOM)
+ PUSHJ P,RETERR
+ PUSH TP,A
+ PUSH TP,B
+ GETYP A,A
+ CAIN A,TFIX
+ JRST BYTIN
+ PUSHJ P,NXTCH ; GET NEXT CHAR
+ CAIN B,TMPTYP ; SKIP IF NOT TEMPLATE START
+ JRST RDTMPL
+ SETZB A,B
+ EXCH A,-1(TP)
+ EXCH B,(TP)
+ PUSH TP,A ;BEGIN SETTING UP CHTYPE CALL
+ PUSH TP,B
+ PUSHJ P,IREAD1 ;NOW READ STRUCTURE
+ PUSHJ P,RETERR
+ MOVEM C,-3(TP) ; SAVE COMMENT
+ MOVEM D,-2(TP)
+ EXCH A,-1(TP) ;USE AS FIRST ARG
+ EXCH B,(TP)
+ PUSH TP,A ;USE OTHER AS 2D ARG
+ PUSH TP,B
+ MCALL 2,CHTYPE ;ATTEMPT TO MUNG
+RET13: POP TP,D
+ POP TP,C ; RESTORE COMMENT
+RET12: SETOM (P) ; DONT LOOOK FOR MORE!
+ JRST RET
+
+RDTMPL: PUSH P,["}] ; SET UP TERMINATE TEST
+ MOVE B,(TP)
+ PUSHJ P,IGVAL
+ MOVEM A,-1(TP)
+ MOVEM B,(TP)
+ PUSH P,[BLDTMP] ; FLAG FOR VECTOR READING CODE
+ JRST LBRAK2
+
+BLDTMP: ADDI A,1 ; 1 MORE ARGUMENT
+ ACALL A,APPLY ; DO IT TO IT
+ POPJ P,
+
+BYTIN: PUSHJ P,NXTCH ; CHECK FOR OPENR
+ CAIN B,SPATYP
+ PUSHJ P,SPACEQ
+ JRST .+3
+ PUSHJ P,LSTCHR
+ JRST BYTIN
+ CAIE B,TMPTYP
+ ERRUUO EQUOTE BAD-USE-OF-BYTE-STRING
+ PUSH P,["}]
+ PUSH P,[CBYTE1]
+ JRST LBRAK2
+
+CBYTE1: AOJA A,CBYTES
+
+RETERR: SKIPL A,5(TB)
+ MOVEI A,5(TB)-LSTCH ;NO CHANNEL, USE SLOT
+ HRRM B,LSTCH(A) ; RESTORE LAST CHAR
+ PUSHJ P,ERRPAR
+ SOS (P)
+ SOS (P)
+ POPJ P,
+
+\f
+;THIS CODE CALLS IREAD RECURSIVELY TO READ THAT WHICH IS
+;BETWEEN (), ARRIVED AT WHEN ( IS READ
+
+SEGIN: PUSH TP,$TSEG
+ JRST OPNAN1
+
+OPNANG: PUSH TP,$TFORM ;SAVE TYPE
+OPNAN1: PUSH P,[">]
+ JRST LPARN1
+
+LPAREN: PUSH P,[")]
+ PUSH TP,$TLIST ;START BY ASSUMING NIL
+LPARN1: PUSH TP,C%0
+ PUSHJ P,LSTCHR ;DON'T REREAD PARENS
+LLPLOP: PUSHJ P,IREAD1 ;READ IT
+ JRST LDONE ;HIT TERMINATOR
+
+;HERE WHEN MUST ADD CAR TO CURRENT WINNER
+
+GENCAR: PUSH TP,C ; SAVE COMMENT
+ PUSH TP,D
+ MOVE C,A ; SET UP CALL
+ MOVE D,B
+ PUSHJ P,INCONS ; CONS ON TO NIL
+ POP TP,D
+ POP TP,C
+ POP TP,E ;GET CDR
+ JUMPN E,CDRIN ;IF STACKED GOODIE NOT NIL SKIP
+ PUSH TP,B ;AND USE AS TOTAL VALUE
+ PUSH TP,$TLIST ;SAVE THIS AS FIRSST THING ON LIST
+ MOVE A,-2(TP) ; GET REAL TYPE
+ JRST .+2 ;SKIP CDR SETTING
+CDRIN: HRRM B,(E)
+ PUSH TP,B ;CLOBBER IN NEW PARTIAL GOODIE
+ JUMPE C,LLPLOP ; JUMP IF NO COMMENT
+ PUSH TP,C
+ PUSH TP,D
+ MOVSI C,TATOM
+ MOVE D,IMQUOTE COMMENT
+ PUSHJ P,IPUT
+ JRST LLPLOP ;AND CONTINUE
+
+; HERE TO RAP UP LIST
+
+LDONE: CAME B,(P) ;CHECK VALIDITY OF CHARACTER
+ PUSHJ P,MISMAT ;REPORT MISMATCH
+ SUB P, C%11
+ POP TP,B ;GET VALUE OF PARTIAL RESULT
+ POP TP,A ;AND TYPE OF SAME
+ JUMPE B,RET ;VALUE IS NIL, DON'T POP AGAIN
+ POP TP,B ;POP FIRST LIST ELEMENT
+ POP TP,A ;AND TYPE
+ JRST RET
+\f
+;THIS CODE IS SIMILAR TO LIST GENERATING CODE BUT IS FOR VECTORS
+OPNBRA: PUSH P,["}] ; SAVE TERMINATOR
+UVECIN: PUSH P,[135] ; CLOSE SQUARE BRACKET
+ PUSH P,[SETZ IEUVECTOR] ;PUSH NAME OF U VECT HACKER
+ JRST LBRAK2 ;AND GO
+
+LBRACK: PUSH P,[135] ; SAVE TERMINATE
+ PUSH P,[SETZ IEVECTOR] ;PUSH GEN VECTOR HACKER
+LBRAK2: PUSHJ P,LSTCHR ;FORCE READING NEW CHAR
+ PUSH P,C%0 ; COUNT ELEMENTS
+ PUSH TP,$TLIST ; AND SLOT FOR GOODIES
+ PUSH TP,C%0
+
+LBRAK1: PUSHJ P,IREAD1 ;RECURSIVELY READ ELEMENTS OF ARRAY
+ JRST LBDONE ;RAP UP ON TERMINATOR
+
+STAKIT: EXCH A,-1(TP) ; STORE RESULT AND GET CURRENT LIST
+ EXCH B,(TP)
+ AOS (P) ; COUNT ELEMENTS
+ JUMPE C,LBRAK3 ; IF NO COMMENT, GO ON
+ MOVEI E,(B) ; GET CDR
+ PUSHJ P,ICONS ; CONS IT ON
+ MOVEI E,(B) ; SAVE RS
+ MOVSI C,TFIX ; AND GET FIXED NUM
+ MOVE D,(P)
+ PUSHJ P,ICONS
+LBRAK3: PUSH TP,A ; SAVE CURRENT COMMENT LIST
+ PUSH TP,B
+ JRST LBRAK1
+
+; HERE TO RAP UP VECTOR
+
+LBDONE: CAME B,-2(P) ; FINISHED RETURN (WAS THE RIGHT STOP USED?)
+ PUSHJ P,MISMAB ; WARN USER
+ POP TP,1(TB) ; REMOVE COMMENT LIST
+ POP TP,(TB)
+ MOVE A,(P) ; COUNT TO A
+ PUSHJ P,-1@(P) ; MAKE THE VECTOR
+ SUB P,C%33
+
+; PUT COMMENTS ON VECTOR (OR UVECTOR)
+
+ MOVNI C,1 ; INDICATE TEMPLATE HACK
+ CAMN A,$TVEC
+ MOVEI C,1
+ CAMN A,$TUVEC ; SKIP IF UVECTOR
+ MOVEI C,0
+ PUSH P,C ; SAVE
+ PUSH TP,A ; SAVE VECTOR/UVECTOR
+ PUSH TP,B
+
+VECCOM: SKIPN C,1(TB) ; ANY LEFT?
+ JRST RETVEC ; NO, LEAVE
+ MOVE A,1(C) ; ASSUME WINNING TYPES
+ SUBI A,1
+ HRRZ C,(C) ; CDR THE LIST
+ HRRZ E,(C) ; AGAIN
+ MOVEM E,1(TB) ; SAVE CDR
+ GETYP E,(C) ; CHECK DEFFERED
+ MOVSI D,(E)
+ CAIN E,TDEFER ; SKIP IF NOT DEFERRED
+ MOVE C,1(C)
+ CAIN E,TDEFER
+ GETYPF D,(C) ; GET REAL TYPE
+ MOVE B,(TP) ; GET VECTOR POINTER
+ SKIPGE (P) ; SKIP IF NOT TEMPLATE
+ JRST TMPCOM
+ HRLI A,(A) ; COUNTER
+ LSH A,@(P) ; MAYBE SHIFT IT
+ ADD B,A
+ MOVE A,-1(TP) ; TYPE
+TMPCO1: PUSH TP,D
+ PUSH TP,1(C) ; PUSH THE COMMENT
+ MOVSI C,TATOM
+ MOVE D,IMQUOTE COMMENT
+ PUSHJ P,IPUT
+ JRST VECCOM
+
+TMPCOM: MOVSI A,(A)
+ ADD B,A
+ MOVSI A,TTMPLT
+ JRST TMPCO1
+
+RETVEC: SUB P,C%11
+ POP TP,B
+ POP TP,A
+ JRST RET
+
+; BUILD A SINGLE CHARACTER ITEM
+
+SINCHR: PUSHJ P,NXTC1 ;FORCE READ NEXT
+ CAIN B,ESCTYP ;ESCAPE?
+ PUSHJ P,NXTC1 ;RETRY
+ MOVEI B,(A)
+ MOVSI A,TCHRS
+ JRST RETCL
+
+\f
+; HERE ON RIGHT PAREN, BRACKET, ANGLE BRACKET OR CTL C
+
+CLSBRA:
+CLSANG: ;CLOSE ANGLE BRACKETS
+RBRACK: ;COMMON RETURN FOR END OF ARRAY ALSO
+RPAREN: PUSHJ P,LSTCHR ;DON'T REREAD
+EOFCH1: MOVE B,A ;GETCHAR IN B
+ MOVSI A,TCHRS ;AND TYPE IN A
+RET1: SUB P,C%11
+ POPJ P,
+
+EOFCHR: SETZB C,D
+ JUMPL A,EOFCH1 ; JUMP ON REAL EOF
+ JRST RRSUBR ; MAYBE A BINARY RSUBR
+
+DOEOF: MOVE A,[-1,,3]
+ SETZB C,D
+ JRST EOFCH1
+
+
+; NORMAL RETURN FROM IREAD/IREAD1
+
+RETCL: PUSHJ P,LSTCHR ;DONT REREAD
+RET: AOS -1(P) ;SKIP
+ POP P,E ; POP FLAG
+RETC: JUMPL E,RET2 ; DONT LOOK FOR COMMENTS
+ PUSH TP,A ; SAVE ITEM
+ PUSH TP,B
+CHCOMN: PUSHJ P,NXTCH ; READ A CHARACTER
+ CAIE B,COMTYP ; SKIP IF COMMENT
+ JRST CHSPA
+ PUSHJ P,IREAD ; READ THE COMMENT
+ JRST POPAJ
+ MOVE C,A
+ MOVE D,B
+ JRST .+2
+POPAJ: SETZB C,D
+ POP TP,B
+ POP TP,A
+RET2: POPJ P,
+
+CHSPA: CAIN B,SPATYP
+ PUSHJ P,SPACEQ ; IS IT A REAL SPACE
+ JRST POPAJ
+ PUSHJ P,LSTCHR ; FLUSH THE SPACE
+ JRST CHCOMN
+
+;RANDOM MINI-SUBROUTINES USED BY THE READER
+
+;READ A CHAR INTO A AND TYPE CODE INTO D
+
+NXTC3: SKIPL B,5(TB) ;GET CHANNEL
+ JRST NXTPR4 ;NO CHANNEL, GO READ STRING
+ SKIPE LSTCH(B)
+ PUSHJ P,CNTACC ; COUNT ON ACCESS POINTER
+ PUSHJ P,RXCT
+ TRO A,200
+ JRST GETCTP
+
+NXTC1: SKIPL B,5(TB) ;GET CHANNEL
+ JRST NXTPR1 ;NO CHANNEL, GO READ STRING
+ SKIPE LSTCH(B)
+ PUSHJ P,CNTACC ; COUNT ON ACCESS POINTER
+ JRST NXTC2
+NXTC: SKIPL B,5(TB) ;GET CHANNEL
+ JRST NXTPRS ;NO CHANNEL, GO READ STRING
+ SKIPE A,LSTCH(B) ;CHAR IN A IF REUSE
+ JRST PRSRET
+NXTC2: PUSHJ P,RXCT ;GET CHAR FROM INPUT
+ TLO A,200000 ; BIT TO AVOID ^@ LOSSAGE
+ HLLZS 2(TB) ;FLAG INDICATING ONE CHAR LOOK AHEAD
+ MOVEM A,LSTCH(B) ;SAVE THE CHARACTER
+PRSRET: TLZ A,200000
+ TRZE A,400000 ;DONT SKIP IF SPECIAL
+ TRO A,200 ;GO HACK SPECIALLY
+GETCTP: PUSH P,A ;AND SAVE FROM DIVISION
+ ANDI A,377
+ IDIVI A,CHRWD ;YIELDS WORD AND CHAR NUMBER
+ LDB B,BYTPNT(B) ;GOBBLE TYPE CODE
+ POP P,A
+ ANDI A,177 ; RETURN REAL ASCII
+ POPJ P,
+
+NXTPR4: MOVEI F,400000
+ JRST NXTPR5
+
+NXTPRS: SKIPE A,5(TB) ;GET OLD CHARACTER IF ONE EXISTS
+ JRST PRSRET
+NXTPR1: MOVEI F,0
+NXTPR5: MOVE A,11.(TB)
+ HRRZ B,(A) ;GET THE STRING
+ SOJL B,NXTPR3
+ HRRM B,(A)
+ ILDB A,1(A) ;GET THE CHARACTER FROM THE STRING
+ IORI A,(F)
+NXTPR2: MOVEM A,5(TB) ;SAVE IT
+ JRST PRSRET ;CONTINUE
+
+NXTPR3: SETZM 8.(TB)
+ SETZM 9.(TB) ;CLEAR OUT LOCATIVE, AT END OF STRING
+ MOVEI A,400033
+ JRST NXTPR2
+
+; NXTCH AND NXTCH1 ARE SAME AS NXTC AND NXTC1 EXCEPT THEY CHECK !
+; HACKS
+
+NXTCH1: PUSHJ P,NXTC1 ;READ CHAR
+ JRST .+2
+NXTCH: PUSHJ P,NXTC ;READ CHAR
+ PUSHJ P,CHKUS1 ; CHECK FOR USER DISPATCH
+
+ CAIE B,NTYPES+1 ; SKIP IF ! ING NEXT CHAR
+ POPJ P,
+ PUSHJ P,NXTC3 ;READ NEXT ONE
+ HLLOS 2(TB) ;FLAG FOR TWO CHAR LOOK AHEAD
+
+CRMLST: IORI A,400000 ;CLOBBER LASTCHR
+ PUSH P,B
+ SKIPL B,5(TB) ;POINT TO CHANNEL
+ MOVEI B,5(TB)-LSTCH ;NO CHANNEL, POINT AT SLOT
+ HRRM A,LSTCH(B)
+ ANDI A,377777 ;DECREASE CHAR
+ POP P,B
+
+CHKUS2: SKIPN 7(TB) ; SKIP IF USER TABLE
+ POPJ P,
+ MOVEI F,200(A)
+ ASH F,1 ; POINT TO SLOT
+ HRLI F,(F)
+ ADD F,7(TB)
+ JUMPGE F,CPOPJ ;IS THERE VECTOR ENOUGH?
+ SKIPN 1(F) ; NON-ZERO==>USER FCN EXISTS
+ JRST CPOPJ ; HOPE HE APPRECIATES THIS
+ MOVEI B,USTYP2
+CHKRDO: PUSH P,0 ; CHECK FOR REDOING IF CHAR IN TABLE
+ GETYP 0,(F)
+ CAIE 0,TCHRS
+ JRST CHKUS5
+ POP P,0 ;WE ARE TRANSMOGRIFYING
+ MOVE A,1(F) ;GET NEW CHARACTER
+ PUSH P,7(TB)
+ PUSH P,2(TB) ; FLAGS FOR NUM OF CHRS IN LOOK AHEAD
+ PUSH P,5(TB) ; TO AVOID SMASHING LSTCHR
+ SETZM 5(TB) ; CLEAR OUT CHANNEL
+ SETZM 7(TB) ;CLEAR OUT TABLE
+ TRZE A,200 ; ! HACK
+ TRO A,400000 ; TURN ON PROPER BIT
+ PUSHJ P,PRSRET
+ POP P,5(TB) ; GET BACK CHANNEL
+ POP P,2(TB)
+ POP P,7(TB) ;GET BACK OLD PARSE TABLE
+ POPJ P,
+
+CHKUS5: PUSH P,A
+ CAIE 0,TLIST
+ JRST .+4 ; SPECIAL NON-BREAK TYPE HACK
+ MOVNS (P) ; INDICATE BY NEGATIVE
+ MOVE A,1(F) ; GET <1 LIST>
+ GETYP 0,(A) ; AND GET THE TYPE OF THAT
+ CAIE 0,TFIX ; SEE IF HE WANTS SAME CHAR WITH DIFF TYPE
+ JRST CHKUS6 ; JUST A VANILLA HACK
+ MOVE A,1(F) ; PRETEND IT IS SAME TYPE AS NEW CHAR
+ PUSH P,7(TB) ; CLEAR OUT TRANSLATE TABLE
+ PUSH P,2(TB) ; FLAGS FOR # OF CHRS IN LOOK AHEAD
+ SETZM 7(TB)
+ TRZE A,200
+ TRO A,400000 ; TURN ON PROPER BIT IF ! HACK
+ PUSHJ P,PRSRET ; REGET TYPE
+ POP P,2(TB)
+ POP P,7(TB) ; PUT TRANSLATE TABLE BACK
+CHKUS6: SKIPGE -1(P) ; SEE IF A SPECIAL NON-BREAK
+ MOVNS B ; SEXY, HUH?
+ POP P,A
+ POP P,0
+ MOVMS A ; FIX UP A POSITIVE CHARACTER
+ POPJ P,
+
+CHKUS4: POP P,A
+ POPJ P,
+
+CHKUS1: SKIPN 7(TB) ; USER CHECK FOR NOT ! CASE
+ POPJ P,
+ MOVEI F,(A)
+ ASH F,1
+ HRLI F,(F)
+ ADD F,7(TB)
+ JUMPGE F,CPOPJ
+ SKIPN 1(F)
+ POPJ P,
+ MOVEI B,USTYP1
+ JRST CHKRDO ; TRANSMOGRIFY CHARACTER?
+
+CHKUS3: POP P,A
+ POPJ P,
+
+UPLO: POPJ P, ; LETS NOT AND SAY WE USED TO
+ ; AVOID STRANGE ! BLECHAGE
+NXTCS: PUSHJ P,NXTC
+ PUSH P,A ; HACK TO NOT TRANSLATE CHAR
+ PUSHJ P,CHKUS1 ; BUT DO TRANSLATION OF TYPE IF HE WANTS
+ POP P,A ; USED TO BUILD UP STRINGS
+ POPJ P,
+
+CHKALT: CAIN A,33 ;ALT?
+ MOVEI B,MANYT
+ JRST CRMLST
+
+
+TERM: MOVEI B,0 ;RETURN A 0
+ JRST RET1
+ ;AND RETURN
+
+CHKMIN: CAIN A,"- ; IF CHAR IS -, WINNER
+ MOVEI B,PATHTY
+ JRST CRMLST
+
+LOSPAT: PUSHJ P,LSTCHR ; FIX RECURSIVE LOSAGE
+ ERRUUO EQUOTE UNATTACHED-PATH-NAME-SEPARATOR
+
+\f
+; HERE TO SEE IF READING RSUBR
+
+RRSUBR: PUSHJ P,LSTCHR ; FLUSH JUST READ CHAR
+ SKIPL B,5(TB) ; SKIP IF A CHANNEL EXISTS
+ JRST SPACE ; ELSE LIKE A SPACE
+ HRRZ C,BUFSTR(B) ; SEE IF FLAG SAYS START OF RSUBR
+ MOVE C,(C)
+ TRNN C,1 ; SKIP IF REAL RSUBR
+ JRST EOFCH2 ; NO, IGNORE FOR NOW
+
+; REALLY ARE READING AN RSUBR
+
+ HRRZ 0,4(TB) ; GET READ/READB INDICATOR
+ MOVE C,ACCESS(B) ; GET CURRENT ACCESS
+ JUMPN 0,.+3 ; ALREADY WORDS, NO NEED TO DIVIDE
+ ADDI C,4 ; ROUND UP
+ IDIVI C,5
+ PUSH P,C ; SAVE WORD ACCESS
+ MOVEI A,(C) ; COPY IT FOR CALL
+ JUMPN 0,.+3
+ IMULI C,5
+ MOVEM C,ACCESS(B) ; FIXUP ACCESS
+ HLLZS ACCESS-1(B) ; FOR READB LOSER
+ PUSHJ P,DOACCS ; AND GO THERE
+ PUSH P,C%0 ; FOR READ IN
+ HRROI A,(P) ; PREPARE TO READ LENGTH
+ PUSHJ P,DOIOTI ; READ IT
+ POP P,C ; GET READ GOODIE
+ JUMPGE A,.+4 ; JUMP IF WON
+ SUB P,C%11
+EOFCH2: HRROI A,3
+ JRST EOFCH1
+ MOVEI A,(C) ; COPY FOR GETTING BLOCK
+ ADDI C,1 ; COUNT COUNT WORD
+ ADDM C,(P)
+ PUSH TP,$TUVEC ; WILL HOLD UVECTOR OF FIXUPS IF THEY STAY
+ PUSH TP,C%0
+ PUSHJ P,IBLOCK ; GET A BLOCK
+ PUSH TP,$TUVEC
+ PUSH TP,B ; AND SAVE
+ MOVE A,B ; READY TO IOT IT IN
+ MOVE B,5(TB) ; GET CHANNEL BACK
+ MOVSI 0,TUVEC ; SETUP A'S TYPE
+ MOVE PVP,PVSTOR+1
+ MOVEM 0,ASTO(PVP)
+ PUSHJ P,DOIOTI ; IN COMES THE WHOLE BLOCK
+ MOVE PVP,PVSTOR+1
+ SETZM ASTO(PVP) ; A NO LONGER SPECIAL
+ MOVEI C,BUFSTR-1(B) ; NO RESET BUFFER
+ PUSHJ P,BYTDOP ; A POINTS TO DOPW WORD
+ SUBI A,2
+ HRLI A,010700 ; SETUP BYTE POINTER TO END
+ HLLZS BUFSTR-1(B) ; ZERO CHAR COUNNT
+ MOVEM A,BUFSTR(B)
+ HRRZ A,4(TB) ; READ/READB FLG
+ MOVE C,(P) ; ACCESS IN WORDS
+ SKIPN A ; SKIP FOR ASCII
+ IMULI C,5 ; BUMP
+ MOVEM C,ACCESS(B) ; UPDATE ACCESS
+ PUSHJ P,NIREAD ; READ RSUBR VECTOR
+ JRST BRSUBR ; LOSER
+ GETYP A,A ; VERIFY A LITTLE
+ CAIE A,TVEC ; DONT SKIP IF BAD
+ JRST BRSUBR ; NOT A GOOD FILE
+ PUSHJ P,LSTCHR ; FLUSH REREAD CHAR
+ MOVE C,(TP) ; CODE VECTOR BACK
+ MOVSI A,TCODE
+ HLR A,B ; FUNNY COUNT
+ MOVEM A,(B) ; CLOBBER
+ MOVEM C,1(B)
+ PUSH TP,$TRSUBR ; MAKE RSUBR
+ PUSH TP,B
+
+; NOW LOOK OVER FIXUPS
+
+ MOVE B,5(TB) ; GET CHANNEL
+ MOVE C,ACCESS(B)
+ HLLZS ACCESS-1(B) ; FOR READB LOSER
+ HRRZ 0,4(TB) ; READ/READB FLG
+ JUMPN 0,RSUB1
+ ADDI C,4 ; ROUND UP
+ IDIVI C,5 ; TO WORDS
+ MOVEI D,(C) ; FIXUP ACCESS
+ IMULI D,5
+ MOVEM D,ACCESS(B) ; AND STORE
+RSUB1: ADDI C,1 ; ACCOUNT FOR EXTRA COUNTERS
+ MOVEM C,(P) ; SAVE FOR LATER
+ MOVEI A,-1(C) ; FOR DOACS
+ MOVEI C,2 ; UPDATE REAL ACCESS
+ SKIPN 0 ; SKIP FOR READB CASE
+ MOVEI C,10.
+ ADDM C,ACCESS(B)
+ PUSHJ P,DOACCS ; DO THE ACCESS
+ PUSH TP,$TUVEC ; SLOT FOR FIXUP BUFFER
+ PUSH TP,C%0
+
+; FOUND OUT IF FIXUPS STAY
+
+ MOVE B,IMQUOTE KEEP-FIXUPS
+ PUSHJ P,ILVAL ; GET VALUE
+ GETYP 0,A
+ MOVE B,5(TB) ; CHANNEL BACK TO B
+ CAIE 0,TUNBOU
+ CAIN 0,TFALSE
+ JRST RSUB4 ; NO, NOT KEEPING FIXUPS
+ PUSH P,C%0 ; SLOT TO READ INTO
+ HRROI A,(P) ; GET LENGTH OF SAME
+ PUSHJ P,DOIOTI
+ POP P,C
+ MOVEI A,(C) ; GET UVECTOR FOR KEEPING
+ ADDM C,(P) ; ACCESS TO END
+ PUSH P,C ; SAVE LENGTH OF FIXUPS
+ PUSHJ P,IBLOCK
+ MOVEM B,-6(TP) ; AND SAVE
+ MOVE A,B ; FOR IOTING THEM IN
+ ADD B,C%11 ; POINT PAST VERS #
+ MOVEM B,(TP)
+ MOVSI C,TUVEC
+ MOVE PVP,PVSTOR+1
+ MOVEM C,ASTO(PVP)
+ MOVE B,5(TB) ; AND CHANNEL
+ PUSHJ P,DOIOTI ; GET THEM
+ MOVE PVP,PVSTOR+1
+ SETZM ASTO(PVP)
+ MOVE A,(TP) ; GET VERS
+ PUSH P,-1(A) ; AND PUSH IT
+ JRST RSUB5
+
+RSUB4: PUSH P,C%0
+ PUSH P,C%0 ; 2 SLOTS FOR READING
+ MOVEI A,-1(P)
+ HRLI A,-2
+ PUSHJ P,DOIOTI
+ MOVE C,-1(P)
+ MOVE D,(P)
+ ADDM C,-2(P) ; NOW -2(P) IS ACCESS TO END OF FIXUPS
+RSUB5: MOVEI C,BUFSTR-1(B) ; FIXUP BUFFER
+ PUSHJ P,BYTDOP
+ SUBI A,2 ; POINT BEFORE D.W.
+ HRLI A,10700
+ MOVEM A,BUFSTR(B)
+ HLLZS BUFSTR-1(B)
+ SKIPE -6(TP)
+ JRST RSUB2A
+ SUBI A,BUFLNT-1 ; ALSO MAKE AN IOT FLAVOR BUFFER
+ HRLI A,-BUFLNT
+ MOVEM A,(TP)
+ MOVSI C,TUVEC
+ MOVE PVP,PVSTOR+1
+ MOVEM C,ASTO(PVP)
+ PUSHJ P,DOIOTI
+ MOVE PVP,PVSTOR+1
+ SETZM ASTO(PVP)
+RSUB2A: PUSH P,-1(P) ; ANOTHER COPY OF LENGTH OF FIXUPS
+
+; LOOP FIXING UP NEW TYPES
+
+RSUB2: PUSHJ P,WRDIN ; SEE WHAT NEXT THING IS
+ JRST RSUB3 ; NO MORE, DONE
+ JUMPL E,STSQ ; MUST BE FIRST SQUOZE
+ MOVNI 0,(E) ; TO UPDATE AMNT OF FIXUPS
+ ADDB 0,(P)
+ HRLI E,(E) ; IS LENGTH OF STRING IN WORDS
+ ADD E,(TP) ; FIXUP BUFFER POINTER
+ JUMPL E,.+3
+ SUB E,[BUFLNT,,BUFLNT]
+ JUMPGE E,.-1 ; STILL NOT RIGHT
+ EXCH E,(TP) ; FIX UP SLOT
+ HLRE C,E ; FIX BYTE POINTER ALSO
+ IMUL C,[-5] ; + CHARS LEFT
+ MOVE B,5(TB) ; CHANNEL
+ PUSH TP,BUFSTR-1(B)
+ PUSH TP,BUFSTR(B)
+ HRRM C,BUFSTR-1(B)
+ HRLI E,440700 ; AND BYTE POINTER
+ MOVEM E,BUFSTR(B)
+ PUSHJ P,NIREAD ; READ ATOM NAME OF TYPE
+ TDZA 0,0 ; FLAG LOSSAGE
+ MOVEI 0,1 ; WINNAGE
+ MOVE C,5(TB) ; RESET BUFFER
+ POP TP,BUFSTR(C)
+ POP TP,BUFSTR-1(C)
+ JUMPE 0,BRSUBR ; BAD READ OF RSUBR
+ GETYP A,A ; A LITTLE CHECKING
+ CAIE A,TATOM
+ JRST BRSUBR
+ PUSHJ P,LSTCHR ; FLUSH REREAD CHAR
+ HRRZ 0,4(TB) ; FIXUP ACCESS PNTR
+ MOVE C,5(TB)
+ MOVE D,ACCESS(C)
+ HLLZS ACCESS-1(C) ; FOR READB HACKER
+ ADDI D,4
+ IDIVI D,5
+ IMULI D,5
+ SKIPN 0
+ MOVEM D,ACCESS(C) ; RESET
+TYFIXE: PUSHJ P,TYPFND ; SEE IF A LEGAL TYPE NAME
+ JRST TYPFIX ; GO SEE USER ABOUT THIS
+ PUSHJ P,FIXCOD ; GO FIX UP THE CODE
+ JRST RSUB2
+
+; NOW FIX UP SUBRS ETC. IF NECESSARY
+
+STSQ: MOVE B,IMQUOTE MUDDLE
+ PUSHJ P,IGVAL ; GET CURRENT VERS
+ CAME B,-1(P) ; SKIP IF NO FIXUPS NEEDED
+ JRST DOFIX0 ; MUST DO THEM
+
+; ALL DONE, ACCESS PAST FIXUPS AND RETURN
+RSUB31: PUSHJ P,SQUKIL ; DONE FIXING UP, KILL SQUOZE TABLE IF IN INTERP
+RSUB3: MOVE A,-3(P)
+ MOVE B,5(TB)
+ MOVEI C,(A) ; UPDATE CHANNEL ACCESS IN CASE SKIPPING
+ HRRZ 0,4(TB) ; READ/READB FLAG
+ SKIPN 0
+ IMULI C,5
+ MOVEM C,ACCESS(B) ; INTO ACCESS SLOT
+ HLLZS ACCESS-1(B)
+ PUSHJ P,DOACCS ; ACCESSED
+ MOVEI C,BUFSTR-1(B) ; FIX UP BUFFER
+ PUSHJ P,BYTDOP
+ SUBI A,2
+ HRLI A,10700
+ MOVEM A,BUFSTR(B)
+ HLLZS BUFSTR-1(B)
+ SKIPN A,-6(TP) ; SKIP IF KEEPING FIXUPS
+ JRST RSUB6
+ PUSH TP,$TUVEC
+ PUSH TP,A
+ MOVSI A,TRSUBR
+ MOVE B,-4(TP)
+ MOVSI C,TATOM
+ MOVE D,IMQUOTE RSUBR
+ PUSHJ P,IPUT ; DO THE ASSOCIATION
+
+RSUB6: MOVE C,-4(TP) ; DO SPECIAL FIXUPS
+ PUSHJ P,SFIX
+ MOVE B,-2(TP) ; GET RSUBR
+ MOVSI A,TRSUBR
+ SUB P,C%44 ; FLUSH P CRUFT
+ SUB TP,[10,,10]
+ JRST RET
+
+; FIXUP SUBRS ETC.
+
+DOFIX0: SKIPN C,-6(TP) ; GET BUFFER IF KEEPING
+ JRST DOFIXE
+ MOVEM B,(C) ; CLOBBER
+ JRST DOFIXE
+
+FIXUPL: PUSHJ P,WRDIN
+ JRST RSUB31
+DOFIXE: JUMPGE E,BRSUBR
+ TLZ E,740000 ; KILL BITS
+IFN KILTV,[
+ CAME E,[SQUOZE 0,DSTO]
+ JRST NOOPV
+ MOVE E,[SQUOZE 40,DSTORE]
+ MOVE A,(TP)
+ SKIPE -6(TP)
+ MOVEM E,-1(A)
+ MOVEI E,53
+ HRLM E,(A)
+ MOVEI E,DSTORE
+ JRST .+3
+NOOPV:
+]
+ PUSHJ P,SQUTOA ; LOOK IT UP
+ PUSHJ P,BRSUB1
+ MOVEI D,(E) ; FOR FIXCOD
+ PUSHJ P,FIXCOD ; FIX 'EM UP
+ JRST FIXUPL
+
+; BAD SQUOZE, BE MORE SPECIFIC
+
+BRSUB1: PUSHJ P,SQSTR
+ PUSH TP,$TATOM
+ PUSH TP,EQUOTE SQUZE-SYMBOL-NOT-FOUND-ERRET CORRECTION
+ PUSH TP,A
+ PUSH TP,B
+ PUSH TP,$TATOM
+ PUSH TP,MQUOTE READ
+ MCALL 3,ERROR
+ GETYP A,A
+ CAIE A,TFIX
+ ERRUUO EQUOTE VALUE-MUST-BE-FIX
+ MOVE E,B
+ POPJ P,
+
+; CONVERT SQUOZE TO A MUDDLE STRING FOR USER
+
+SQSTR: PUSHJ P,SPTT
+ PUSH P,C
+ CAIN B,6 ; 6 chars?
+ PUSH P,D
+ PUSH P,B
+ PUSHJ P,CHMAK
+ POPJ P,
+
+SPTT: SETZB B,C
+ MOVE A,[440700,,C]
+ MOVEI D,0
+
+SPT1: IDIVI E,50
+ PUSH P,F
+ JUMPE E,SPT3
+ PUSHJ P,SPT1
+SPT3: POP P,E
+ ADDI E,"0-1
+ CAILE E,"9
+ ADDI E,"A-"9-1
+ CAILE E,"Z
+ SUBI E,"Z-"#+1
+ CAIN E,"#
+ MOVEI E,".
+ CAIN E,"/
+SPC: MOVEI E,40
+ IDPB E,A
+ ADDI B,1
+ POPJ P,
+
+
+;0 1-12 13-44 45 46 47
+;NULL 0-9 A-Z . $ %
+
+; ROUTINE TO FIXUP ACTUAL CODE
+
+FIXCOD: MOVEI E,0 ; FOR HWRDIN
+ PUSH P,D ; NEW VALUE
+ PUSHJ P,HWRDIN ; GET HW NEEDED
+ MOVE D,(P) ; GET NEW VAL
+ MOVE A,(TP) ; AND BUFFER POINTER
+ SKIPE -6(TP) ; SAVING?
+ HRLM D,-1(A) ; YES, CLOBBER
+ SUB C,(P) ; DIFFERENCE
+ MOVN D,C
+
+FIXLP: PUSHJ P,HWRDIN ; GET AN OFFSET
+ JUMPE C,FIXED
+ HRRES C ; MAKE NEG IF NEC
+ JUMPL C,LHFXUP
+ ADD C,-4(TP) ; POINT INTO CODE
+IFN KILTV,[
+ LDB 0,[220400,,-1(C)] ; GET INDEX FIELD
+ CAIE 0,7
+ JRST NOTV
+KIND: MOVEI 0,0
+ DPB 0,[220400,,-1(C)]
+ JRST DONTV
+NOTV: CAIE 0,6 ; IS IT PVP
+ JRST DONTV
+ HRRZ 0,-1(C)
+ CAIE 0,12 ; OLD DSTO
+ JRST DONTV
+ MOVEI 0,33.
+ ADDM 0,-1(C)
+ JRST KIND
+DONTV:
+]
+ ADDM D,-1(C)
+ JRST FIXLP
+
+LHFXUP: MOVMS C
+ ADD C,-4(TP)
+ MOVSI 0,(D)
+ ADDM 0,-1(C)
+ JRST FIXLP
+
+FIXED: SUB P,C%11
+ POPJ P,
+
+; ROUTINE TO READ A WORD FROM BUFFER
+
+WRDIN: PUSH P,A
+ PUSH P,B
+ SOSG -3(P) ; COUNT IT DOWN
+ JRST WRDIN1
+ AOS -2(P) ; SKIP RETURN
+ MOVE B,5(TB) ; CHANNEL
+ HRRZ A,4(TB) ; READ/READB SW
+ MOVEI E,5
+ SKIPE A
+ MOVEI E,1
+ ADDM E,ACCESS(B)
+ MOVE A,(TP) ; BUFFER
+ MOVE E,(A)
+ AOBJP A,WRDIN2 ; NEED NEW BUFFER
+ MOVEM A,(TP)
+WRDIN1: POP P,B
+ POP P,A
+ POPJ P,
+
+WRDIN2: MOVE B,-3(P) ; IS THIS LAST WORD?
+ SOJLE B,WRDIN1 ; YES, DONT RE-IOT
+ SUB A,[BUFLNT,,BUFLNT]
+ MOVEM A,(TP)
+ MOVSI B,TUVEC
+ MOVE PVP,PVSTOR+1
+ MOVEM B,ASTO(PVP)
+ MOVE B,5(TB)
+ PUSHJ P,DOIOTI
+ MOVE PVP,PVSTOR+1
+ SETZM ASTO(PVP)
+ JRST WRDIN1
+
+; READ IN NEXT HALF WORD
+
+HWRDIN: JUMPN E,NOIOT ; USE EXISTING WORD
+ PUSH P,-3(P) ; FAKE OUT WRDIN IF NEC.
+ PUSHJ P,WRDIN
+ JRST BRSUBR
+ POP P,-4(P) ; RESET COUNTER
+ HLRZ C,E ; RET LH
+ POPJ P,
+
+NOIOT: HRRZ C,E
+ MOVEI E,0
+ POPJ P,
+
+TYPFIX: PUSH TP,$TATOM
+ PUSH TP,EQUOTE BAD-TYPE-NAME
+ PUSH TP,$TATOM
+ PUSH TP,B
+ PUSH TP,$TATOM
+ PUSH TP,EQUOTE ERRET-TYPE-NAME-DESIRED
+ MCALL 3,ERROR
+ JRST TYFIXE
+
+BRSUBR: ERRUUO EQUOTE RSUBR-IN-BAD-FORMAT
+\f
+
+
+;TABLE OF BYTE POINTERS FOR GETTING CHARS
+
+BYTPNT": 350700,,CHTBL(A)
+ 260700,,CHTBL(A)
+ 170700,,CHTBL(A)
+ 100700,,CHTBL(A)
+ 010700,,CHTBL(A)
+
+;HERE ARE THE TABLES OF CHXRACTERS (NOTE EVERYTHING NOT SPECIFIED IS
+;IN THE NUMBER LETTER CATAGORY)
+
+CHROFF==0 ; USED FOR ! HACKS
+SETCHR NUMCOD,[0123456789]
+
+SETCHR PLUCOD,[+]
+
+SETCHR NEGCOD,[-]
+
+SETCHR ASTCOD,[*]
+
+SETCHR DOTTYP,[.]
+
+SETCHR ETYPE,[Ee]
+
+SETCOD SPATYP,[0,15,12,11,14,40,33] ;ALL ARE TYPE 2 (SPACING - FF,TAB,SPACE,ALT-MODE)
+
+INCRCH LPATYP,[()[]'%"\#<>] ;GIVE THESE INCREASRNG CODES FROM 3
+
+SETCOD EOFTYP,[3] ;^C - EOF CHARACTER
+
+SETCOD SPATYP,[32] ;^Z - TENEX/TOPS-20 EOF (SET IN BOTH TO BE CONSISTENT)
+
+INCRCH COMTYP,[;,{}!] ;COMMENT AND GLOBAL VALUE AND SPECIAL
+
+CHROFF==200 ; CODED AS HAVING 200 ADDED
+
+INCRCH EXCEXC,[!.[]'"<>,-\]
+
+SETCOD MANYT,[33]
+
+CHTBL:
+ OUTTBL ;OUTPUT THE TABLE RIGHT HERE
+
+
+\f; THIS CODE FLUSHES WANDERING COMMENTS
+
+COMNT: PUSHJ P,IREAD
+ JRST COMNT2
+ JRST BDLP
+
+COMNT2: SKIPL A,5(TB) ; RESTORE CHANNEL
+ MOVEI A,5(TB)-LSTCH ;NO CHANNEL, POINT AT SLOT
+ HRRM B,LSTCH(A) ; CLOBBER IN CHAR
+ PUSHJ P,ERRPAR
+ JRST BDLP
+\f
+
+;HERE TO SET UP FOR .FOO ..FOO OR.<ABC>
+
+DOTSTR: PUSHJ P,NXTCH1 ; GOBBLE A NEW CHARACTER
+ MOVEI FF,FRSDOT+DOTSEN+NUMWIN ; SET FLAG IN CASE
+ CAIN B,NUMCOD ; SKIP IF NOT NUMERIC
+ JRST DOTST1 ; NUMERIC, COULD BE FLONUM
+
+; CODE TO HANDLE ALL IMPLICIT CALLS I.E. QUOTE, LVAL, GVAL
+
+ TRZ FF,NUMWIN ; WE ARE NOT A NUMBER
+ MOVSI B,TFORM ; LVAL
+ MOVE A,IMQUOTE LVAL
+ JRST IMPCA1
+
+GLOSEG: SKIPA B,$TSEG ;SEG CALL TO GVAL
+GLOVAL: MOVSI B,TFORM ;FORM CALL TO SAME
+ MOVE A,IMQUOTE GVAL
+ JRST IMPCAL
+
+QUOSEG: SKIPA B,$TSEG ;SEG CALL TO QUOTE
+QUOTIT: MOVSI B,TFORM
+ MOVE A,IMQUOTE QUOTE
+ JRST IMPCAL
+
+SEGDOT: MOVSI B,TSEG ;SEG CALL TO LVAL
+ MOVE A,IMQUOTE LVAL
+IMPCAL: PUSHJ P,LSTCHR ;FLUSH LAST CHAR EXCEPT
+IMPCA1: PUSH TP,$TATOM ;FOR .FOO FLAVOR
+ PUSH TP,A ;PUSH ARGS
+ PUSH P,B ;SAVE TYPE
+ PUSHJ P,IREAD1 ;READ
+ JRST USENIL ; IF NO ARG, USE NIL
+IMPCA2: PUSH TP,C
+ PUSH TP,D
+ MOVE C,A ; GET READ THING
+ MOVE D,B
+ PUSHJ P,INCONS ; CONS TO NIL
+ MOVEI E,(B) ; PREPARE TON CONS ON
+POPARE: POP TP,D ; GET ATOM BACK
+ POP TP,C
+ EXCH C,-1(TP) ; SAVE THAT COMMENT
+ EXCH D,(TP)
+ PUSHJ P,ICONS
+ POP P,A ;GET FINAL TYPE
+ JRST RET13 ;AND RETURN
+
+
+USENIL: PUSH TP,C
+ PUSH TP,D
+ SKIPL A,5(TB) ; RESTOR LAST CHR
+ MOVEI A,5(TB)-LSTCH ;NO CHANNEL, POINT AT SLOT
+ HRRM B,LSTCH(A)
+ MOVEI E,0
+ JRST POPARE
+\f
+;HERE AFTER READING ATOM TO CALL VALUE
+
+.SET: PUSH P,$TFORM ;GET WINNING TYPE
+ MOVE E,(P)
+ PUSHJ P,RETC ; CHECK FOR POSSIBLE COMMENT
+ PUSH TP,$TATOM
+ PUSH TP,IMQUOTE LVAL
+ JRST IMPCA2 ;GO CONS LIST
+
+LOOPA: PUSH P,FF ; SAVE FLAGS IN CASE .ATOM
+LOOPAT: PUSHJ P,NXTCH ; CHECK FOR TRAILER
+ CAIN B,PATHTY ; PATH BEGINNER
+ JRST PATH0 ; YES, GO PROCESS
+ CAIN B,SPATYP ; SPACER?
+ PUSHJ P,SPACEQ ; CHECK FOR REAL SPACE
+ JRST PATH2
+ PUSHJ P,LSTCHR ; FLUSH IT AND RETRY
+ JRST LOOPAT
+PATH0: PUSHJ P,NXTCH1 ; READ FORCED NEXT
+ CAIE B,SPCTYP ; DO #FALSE () HACK
+ CAIN B,ESCTYP
+ JRST PATH4
+ CAIL B,SPATYP ; SPACER?
+ JRST PATH3 ; YES, USE THE ROOT OBLIST
+PATH4: PUSHJ P,NIREA1 ; READ NEXT ITEM
+ PUSHJ P,ERRPAR ; LOSER
+ CAME A,$TATOM ; ONLY ALLOW ATOMS
+ JRST BADPAT
+
+ PUSH TP,A
+ PUSH TP,B
+ MOVSI C,TATOM
+ MOVE D,IMQUOTE OBLIST
+ PUSHJ P,IGET ; GET THE OBLIST
+ ; IF NOT OBLIST, MAKE ONE
+ JUMPN B,PATH6
+ MCALL 1,MOBLIS ; MAKE ONE
+ JRST PATH1
+
+PATH6: SUB TP,C%22
+ JRST PATH1
+
+
+PATH3: MOVE B,ROOT+1 ; GET ROOT OBLIST
+ MOVSI A,TOBLS
+PATH1: POP P,FF ; FLAGS
+ TRNE FF,FRSDOT
+ JRST PATH.
+ PUSHJ P,RLOOKU ; AND LOOK IT UP
+
+ JRST RET
+
+PATH.: PUSHJ P,RLOOKU
+ JRST .SET ; CONS AN LVAL FORM
+
+SPACEQ: ANDI A,-1
+ CAIE A,33
+ CAIN A,400033
+ POPJ P,
+ CAIE A,3
+ AOS (P)
+ POPJ P,
+\f
+
+PATH2: MOVE B,IMQUOTE OBLIST
+ PUSHJ P,IDVAL
+ JRST PATH1
+
+BADPAT: ERRUUO EQUOTE NON-ATOMIC-OBLIST-NAME
+
+\f
+
+; HERE TO READ ONE CHARACTER FOR USER.
+
+CREDC1: SUBM M,(P)
+ PUSH TP,A
+ PUSH TP,B
+ PUSHJ P,IREADC
+ JRST CRDEO1
+ JRST RMPOPJ
+
+CNXTC1: SUBM M,(P)
+ PUSH TP,A
+ PUSH TP,B
+ PUSHJ P,INXTRD
+ JRST CRDEO1
+ JRST RMPOPJ
+
+CRDEO1: MOVE B,(TP)
+ PUSH TP,EOFCND-1(B)
+ PUSH TP,EOFCND(B)
+ PUSH TP,$TCHAN
+ PUSH TP,B
+ MCALL 1,FCLOSE
+ MCALL 1,EVAL
+ JRST RMPOPJ
+
+
+CREADC: SUBM M,(P)
+ PUSH TP,A
+ PUSH TP,B
+ PUSHJ P,IREADC
+ JRST CRDEOF
+ SOS (P)
+ JRST RMPOPJ
+
+CNXTCH: SUBM M,(P)
+ PUSH TP,A
+ PUSH TP,B
+ PUSHJ P,INXTRD
+ JRST CRDEOF
+ SOS (P)
+RMPOPJ: SUB TP,C%22
+ JRST MPOPJ
+
+CRDEOF: .MCALL 1,FCLOSE
+ MOVSI A,TCHRS
+ HRROI B,3
+ JRST MPOPJ
+
+INXTRD: TDZA E,E
+IREADC: MOVEI E,1
+ MOVE B,(TP) ; CHANNEL
+ HRRZ A,-2(B) ; GET BLESS BITS
+ TRNE A,C.BIN
+ TRNE A,C.BUF
+ JRST .+3
+ PUSHJ P,GRB
+ HRRZ A,-2(B)
+ TRC A,C.OPN+C.READ
+ TRNE A,C.OPN+C.READ
+ JRST BADCHN
+ SKIPN A,LSTCH(B)
+ PUSHJ P,RXCT
+ TLO A,200000
+ MOVEM A,LSTCH(B) ; SAVE CHAR
+ CAMN A,C%M1 ; [-1] ; SPECIAL PSEUDO TTY HACK?
+ JRST PSEUDO ; YES, RET AS FIX
+; ANDI A,-1
+ TLZ A,200000
+ TRZN A,400000 ; UNDO ! HACK
+ JRST NOEXCL
+ SKIPE E
+ MOVEM A,LSTCH(B)
+ MOVEI A,"! ; RETURN AN !
+NOEXC1: SKIPGE B,A ; CHECK EOF
+ SOS (P) ; DO EOF RETURN
+ MOVE B,A ; CHAR TO B
+ MOVSI A,TCHRS
+PSEUD1: AOS (P)
+ POPJ P,
+
+PSEUDO: MOVE F,B
+ SKIPE E
+ PUSHJ P,LSTCH2
+ MOVE B,A
+ MOVSI A,TFIX
+ JRST PSEUD1
+
+NOEXCL: JUMPE E,NOEXC1
+ MOVE F,B
+ PUSHJ P,LSTCH2
+ JRST NOEXC1
+
+; READER ERRORS COME HERE
+
+ERRPAR: PUSH TP,$TCHRS ;DO THE OFFENDER
+ PUSH TP,B
+ PUSH TP,$TCHRS
+ PUSH TP,[40] ;SPACE
+ PUSH TP,$TCHSTR
+ PUSH TP,CHQUOT UNEXPECTED
+ JRST MISMA1
+
+;COMPLAIN ABOUT MISMATCHED CLOSINGS
+
+MISMAB: SKIPA A,["]]
+MISMAT: MOVE A,-1(P) ;GOBBLE THE DESIRED CHARACTER
+ JUMPE B,CPOPJ ;IGNORE UNIVERSAL CLOSE
+ PUSH TP,$TCHRS
+ PUSH TP,B
+ PUSH TP,$TCHSTR
+ PUSH TP,CHQUOT [ INSTEAD-OF ]
+ PUSH TP,$TCHRS
+ PUSH TP,A
+MISMA1: MCALL 3,STRING
+ PUSH TP,$TATOM
+ PUSH TP,EQUOTE READER-SYNTAX-ERROR-ERRET-ANYTHING-TO-GO-ON
+ PUSH TP,A
+ PUSH TP,B
+ PUSH TP,$TATOM
+ PUSH TP,MQUOTE READ
+ MCALL 3,ERROR
+CPOPJ: POPJ P,
+\f
+; HERE ON BAD INPUT CHARACTER
+
+BADCHR: ERRUUO EQUOTE BAD-ASCII-CHARACTER
+
+; HERE ON YUCKY PARSE TABLE
+
+BADPTB: ERRUUO EQUOTE BAD-MACRO-TABLE
+
+BDPSTR: ERRUUO EQUOTE BAD-PARSE-STRING
+
+ILLSQG: PUSHJ P,LSTCHR ; DON'T MESS WITH IT AGAIN
+ ERRUUO EQUOTE BAD-USE-OF-SQUIGGLY-BRACKETS
+
+
+;FLOATING POINT NUMBER TOO LARGE OR SMALL
+FOOR: ERRUUO EQUOTE NUMBER-OUT-OF-RANGE
+
+
+NILSXP: 0,,0
+
+LSTCHR: SKIPL F,5(TB) ;GET CHANNEL
+ JRST LSTCH1 ;NO CHANNEL, POINT AT SLOT
+
+LSTCH2: SKIPE LSTCH(F) ;ARE WE REALLY FLUSHING A REUSE CHARACTER ?
+ PUSHJ P,CNTACX
+ SETZM LSTCH(F)
+ POPJ P,
+
+LSTCH1: SETZM 5(TB) ;ZERO THE LETTER AND RETURN
+ POPJ P,
+
+CNTACC: MOVE F,B
+CNTACX: HRRZ G,-2(F) ; GET BITS
+ TRNE G,C.BIN
+ JRST CNTBIN
+ AOS ACCESS(F)
+CNTDON: POPJ P,
+
+CNTBIN: AOS G,ACCESS-1(F)
+ CAMN G,[TFIX,,1]
+ AOS ACCESS(F)
+ CAMN G,[TFIX,,5]
+ HLLZS ACCESS-1(F)
+ POPJ P,
+
+
+;TABLE OF NAMES OF ARGS AND ALLOWED TYPES
+
+ARGS:
+ IRP A,,[[[CAIN C,TUNBOU]],[[CAIE C,TCHAN],INCHAN],[[PUSHJ P,CHOBL],OBLIST]]
+ IRP B,C,[A]
+ B
+ IFSN [C],IMQUOTE C
+ .ISTOP
+ TERMIN
+ TERMIN
+
+CHOBL: CAIE C,TLIST ;A LIST OR AN OBLIST
+ CAIN C,TOBLS
+ AOS (P)
+ POPJ P,
+
+END
+
+\f
\ No newline at end of file
--- /dev/null
+
+TITLE READER FOR MUDDLE
+
+;C. REEVE DEC. 1970
+
+RELOCA
+
+READER==1 ;TELL MUDDLE > TO USE SOME SPECIAL HACKS
+FRMSIN==1 ;FLAG SAYING WHETHER OR "." AND "'" HACKS EXIST
+KILTV==1 ;FLAG SAYING THAT (TVP) SHOULD BE REMOVED (MUDDLE 54 ONLY)
+
+.INSRT MUDDLE >
+
+F==PVP
+G==TVP
+
+.GLOBAL CONS,VECTOR,NXTCHR,RLOOKU,CRADIX,SPTIME,QUOTE,CHMAK,FLUSCH,IGET
+.GLOBAL SETDEV,OPNCHN,ILVAL,RADX,IDVAL,LSTCH,EVECTOR,EUVECTOR,CHUNW,NONSPC
+.GLOBAL CHRWRD,EOFCND,DIRECT,ACCESS,IOINS,ROOT,DIRECT,DOIOTI,DOACCS,IGVAL,BYTDOP
+.GLOBAL ICONS,INCONS,IEVECT,IEUVEC,BUFSTR,TYPFND,SQUTOA,SQUKIL,IBLOCK,GRB
+.GLOBAL BADCHN,WRONGD,CHNCLS,FNFFL,IPUT,IGET,ILOC,RXCT,WXCT,IUNWIN,UNWIN2
+.GLOBAL CNXTCH,CREADC,MPOPJ,CREDC1,CNXTC1,IREMAS,CBYTES,PVSTOR,SPSTOR,DSTORE
+.GLOBAL SFIX
+.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
+
+BUFLNT==100
+
+FF=0 ;FALG REGISTER DURING NUMBER CONVERSION
+
+;FLAGS USED (RIGHT HALF)
+
+NOTNUM==1 ;NOT A NUMBER
+NFIRST==2 ;NOT FIRST CHARACTER BEING READ
+DECFRC==4 ;FORCE DECIMAL CONVERSION
+NEGF==10 ;NEGATE THIS THING
+NUMWIN==20 ;DIGIT(S) SEEN
+INSTRN==40 ;IN QUOTED CHARACTER STRING
+FLONUM==100 ;NUMBER IS FLOOATING POINT
+DOTSEN==200 ;. SEEN IN IMPUT STREAM
+EFLG==400 ;E SEEN FOR EXPONENT
+FRSDOT==1000 ;. CAME FIRST
+USEAGN==2000 ;SPECIAL DOT HACK
+
+OCTWIN==4000
+OCTSTR==10000
+OVFLEW==40000
+ENEG==100000
+EPOS==200000
+;TEMPORARY OFFSETS
+
+VCNT==0 ;NUMBER OF ELEMENTS IN CURRENT VECTOR
+ONUM==-4 ;CURRENT NUMBER IN OCTAL
+DNUM==-4 ;CURRENT NUMBER IN DECIMAL
+CNUM==-2 ;IN CURRENT RADIX
+NDIGS==0 ;NUMBER OF DIGITS
+ENUM==-2 ;EXPONENT
+NUMTMP==6
+
+; TABLE OF POWERS OF TEN
+
+TENTAB: REPEAT 39. 10.0^<.RPCNT-1>
+
+ITENTB: REPEAT 11. 10.^<.RPCNT-1>
+
+
+\f; TEXT FILE LOADING PROGRAM
+
+MFUNCTION MLOAD,SUBR,[LOAD]
+
+ ENTRY
+
+ HLRZ A,AB ;GET NO. OF ARGS
+ CAIE A,-4 ;IS IT 2
+ JRST TRY2 ;NO, TRY ANOTHER
+ GETYP A,2(AB) ;GET TYPE
+ CAIE A,TOBLS ;IS IT OBLIST
+ CAIN A,TLIST ; OR LIST THEREOF?
+ JRST CHECK1
+ JRST WTYP2
+
+TRY2: CAIE A,-2 ;IS ONE SUPPLIED
+ JRST WNA
+
+CHECK1: GETYP A,(AB) ;GET TYPE
+ CAIE A,TCHAN ;IS IT A CHANNEL
+ JRST WTYP1
+
+LOAD1: HLRZ A,TB ;GET CURRENT TIME
+ PUSH TP,$TTIME ;AND SAVE IT
+ PUSH TP,A
+
+ MOVEI C,CLSNGO ; LOCATION OF FUNNY CLOSER
+ PUSHJ P,IUNWIN ; SET UP AS UNWINDER
+
+LOAD2: PUSH TP,(AB) ;USE SUPPLIED CHANNEL
+ PUSH TP,1(AB)
+ PUSH TP,(TB) ;USE TIME AS EOF ARG
+ PUSH TP,1(TB)
+ CAML AB,C%M20 ; [-2,,0] ;CHECK FOR 2ND ARG
+ JRST LOAD3 ;NONE
+ PUSH TP,2(AB) ;PUSH ON 2ND ARG
+ PUSH TP,3(AB)
+ MCALL 3,READ
+ JRST CHKRET ;CHECK FOR EOF RET
+
+LOAD3: MCALL 2,READ
+CHKRET: CAMN A,(TB) ;IS TYPE EOF HACK
+ CAME B,1(TB) ;AND IS VALUE
+ JRST EVALIT ;NO, GO EVAL RESULT
+ PUSH TP,(AB)
+ PUSH TP,1(AB)
+ MCALL 1,FCLOSE
+ MOVE A,$TCHSTR
+ MOVE B,CHQUOTE DONE
+ JRST FINIS
+
+CLSNGO: PUSH TP,$TCHAN
+ PUSH TP,1(AB)
+ MCALL 1,FCLOSE
+ JRST UNWIN2 ; CONTINUE UNWINDING
+
+EVALIT: PUSH TP,A
+ PUSH TP,B
+ MCALL 1,EVAL
+ JRST LOAD2
+
+
+
+; OTHER FILE LOADING PROGRAM
+
+
+\f
+MFUNCTION FLOAD,SUBR
+
+ ENTRY
+
+ MOVEI C,1 ;INITIALIZE OPEN'S ARG COUNT
+ PUSH TP,$TAB ;SLOT FOR SAVED AB
+ PUSH TP,C%0 ; [0] ;EMPTY FOR NOW
+ PUSH TP,$TCHSTR ;PUT IN FIRST ARG
+ PUSH TP,CHQUOTE READ
+ MOVE A,AB ;COPY OF ARGUMENT POINTER
+
+FARGS: JUMPGE A,CALOPN ;DONE? IF SO CALL OPEN
+ GETYP B,(A) ;NO, CHECK TYPE OF THIS ARG
+ CAIE B,TOBLS ;OBLIST?
+ CAIN B,TLIST ; OR LIST THEREOF
+ JRST OBLSV ;YES, GO SAVE IT
+
+ PUSH TP,(A) ;SAVE THESE ARGS
+ PUSH TP,1(A)
+ ADD A,C%22 ; [2,,2] ;BUMP A
+ AOJA C,FARGS ;COUNT AND GO
+
+OBLSV: MOVEM A,1(TB) ;SAVE THE AB
+
+CALOPN: ACALL C,FOPEN ;OPEN THE FILE
+
+ JUMPGE B,FNFFL ;FILE MUST NO EXIST
+ EXCH A,(TB) ;PLACE CHANNEL ON STACK
+ EXCH B,1(TB) ;OBTAINING POSSIBLE OBLIST
+ JUMPN B,2ARGS ;OBLIST SUOPPLIED?
+
+ MCALL 1,MLOAD ;NO, JUST CALL
+ JRST FINIS
+
+
+2ARGS: PUSH TP,(B) ;PUSH THE OBLIST
+ PUSH TP,1(B)
+ MCALL 2,MLOAD
+ JRST FINIS
+
+
+FNFFL: PUSH TP,$TATOM
+ PUSH TP,EQUOTE FILE-SYSTEM-ERROR
+ JUMPE B,CALER1
+ PUSH TP,A
+ PUSH TP,B
+ MOVEI A,2
+ JRST CALER
+
+\fMFUNCTION READ,SUBR
+
+ ENTRY
+
+ PUSH P,[SETZ IREAD1] ;WHERE TO GO AFTER BINDING
+READ0: PUSH TP,$TTP ;SLOT FOR LAST THING READ (TYPE IS UNREADABLE)
+ PUSH TP,C%0
+ PUSH TP,$TFIX ;SLOT FOR RADIX
+ PUSH TP,C%0
+ PUSH TP,$TCHAN ;AND SLOT FOR CHANNEL
+ PUSH TP,C%0
+ PUSH TP,C%0 ; USER DISP SLOT
+ PUSH TP,C%0
+ PUSH TP,$TSPLICE
+ PUSH TP,C%0 ;SEGMENT FOR SPLICING MACROS
+ JUMPGE AB,READ1 ;NO ARGS, NO BINDING
+ GETYP C,(AB) ;ISOLATE TYPE
+ CAIN C,TUNBOU
+ JRST WTYP1
+ PUSH TP,[TATOM,,-1] ;PUSH THE ATOMS
+ PUSH TP,IMQUOTE INCHAN
+ PUSH TP,(AB) ;PUSH ARGS
+ PUSH TP,1(AB)
+ PUSH TP,C%0 ;DUMMY
+ PUSH TP,C%0
+ MOVE B,1(AB) ;GET CHANNEL POINTER
+ ADD AB,C%22 ;AND ARG POINTER
+ JUMPGE AB,BINDEM ;MORE?
+ PUSH TP,[TVEC,,-1]
+ ADD B,[EOFCND-1,,EOFCND-1]
+ PUSH TP,B
+ PUSH TP,(AB)
+ PUSH TP,1(AB)
+ ADD AB,C%22
+ JUMPGE AB,BINDEM ;IF ANY MORE ARGS GO PROCESS AND BIND THEM
+ GETYP C,(AB) ;ISOLATE TYPE
+ CAIE C,TLIST
+ CAIN C,TOBLS
+ SKIPA
+ JRST WTYP3
+ PUSH TP,[TATOM,,-1] ;PUSH THE ATOMS
+ PUSH TP,IMQUOTE OBLIST
+ PUSH TP,(AB) ;PUSH ARGS
+ PUSH TP,1(AB)
+ PUSH TP,C%0 ;DUMMY
+ PUSH TP,C%0
+ ADD AB,C%22 ;AND ARG POINTER
+ JUMPGE AB,BINDEM ; ALL DONE, BIND ATOMS
+ GETYP 0,(AB) ; GET TYPE OF TABLE
+ CAIE 0,TVEC ; SKIP IF BAD TYPE
+ JRST WTYP ; ELSE COMPLAIN
+ PUSH TP,[TATOM,,-1]
+ PUSH TP,IMQUOTE READ-TABLE
+ PUSH TP,(AB)
+ PUSH TP,1(AB)
+ PUSH TP,C%0
+ PUSH TP,C%0
+ ADD AB,C%22 ; BUMP TO NEXT ARG
+ JUMPL AB,TMA ;MORE ?, ERROR
+BINDEM: PUSHJ P,SPECBIND
+ JRST READ1
+
+MFUNCTION RREADC,SUBR,READCHR
+
+ ENTRY
+ PUSH P,[SETZ IREADC]
+ JRST READC0 ;GO BIND VARIABLES
+
+MFUNCTION NXTRDC,SUBR,NEXTCHR
+
+ ENTRY
+
+ PUSH P,[SETZ INXTRD]
+READC0: CAMGE AB,C%M40 ; [-5,,]
+ JRST TMA
+ PUSH TP,(AB)
+ PUSH TP,1(AB)
+ JUMPL AB,READC1
+ MOVE B,IMQUOTE INCHAN
+ PUSHJ P,IDVAL
+ GETYP 0,A
+ CAIE 0,TCHAN
+ JRST BADCHN
+ MOVEM A,-1(TP)
+ MOVEM B,(TP)
+READC1: PUSHJ P,@(P)
+ JRST .+2
+ JRST FINIS
+
+ PUSH TP,-1(TP)
+ PUSH TP,-1(TP)
+ MCALL 1,FCLOSE
+ MOVE A,EOFCND-1(B)
+ MOVE B,EOFCND(B)
+ CAML AB,C%M20 ; [-3,,]
+ JRST .+3
+ MOVE A,2(AB)
+ MOVE B,3(AB)
+ PUSH TP,A
+ PUSH TP,B
+ MCALL 1,EVAL
+ JRST FINIS
+
+
+MFUNCTION PARSE,SUBR
+
+ ENTRY
+
+ PUSHJ P,GAPRS ;GET ARGS FOR PARSES
+ PUSHJ P,GPT ;GET THE PARSE TABLE
+ PUSHJ P,NXTCH ; GET A CHAR TO TEST FOR ! ALT
+ SKIPN 11.(TB) ; EOF HIT, COMPLAIN TO LOOSER
+ JRST NOPRS
+ MOVEI A,33 ; CHANGE IT TO AN ALT, SNEAKY HUH?
+ CAIN B,MANYT ; TYPE OF MULTIPLE CLOSE, I.E. ! ALT
+ MOVEM A,5(TB)
+ PUSHJ P,IREAD1 ;GO DO THE READING
+ JRST .+2
+ JRST LPSRET ;PROPER EXIT
+NOPRS: ERRUUO EQUOTE CAN'T-PARSE
+
+MFUNCTION LPARSE,SUBR
+
+ ENTRY
+
+ PUSHJ P,GAPRS ;GET THE ARGS TO THE PARSE
+ JRST LPRS1
+
+GAPRS: PUSH TP,$TTP
+ PUSH TP,C%0
+ PUSH TP,$TFIX
+ PUSH TP,[10.]
+ PUSH TP,$TFIX
+ PUSH TP,C%0 ; LETTER SAVE
+ PUSH TP,C%0
+ PUSH TP,C%0 ; PARSE TABLE MAYBE?
+ PUSH TP,$TSPLICE
+ PUSH TP,C%0 ;SEGMENT FOR SPLICING MACROS
+ PUSH TP,C%0 ;SLOT FOR LOCATIVE TO STRING
+ PUSH TP,C%0
+ JUMPGE AB,USPSTR
+ PUSH TP,[TATOM,,-1]
+ PUSH TP,IMQUOTE PARSE-STRING
+ PUSH TP,(AB)
+ PUSH TP,1(AB) ; BIND OLD PARSE-STRING
+ PUSH TP,C%0
+ PUSH TP,C%0
+ PUSHJ P,SPECBIND
+ ADD AB,C%22
+ JUMPGE AB,USPSTR
+ GETYP 0,(AB)
+ CAIE 0,TFIX
+ JRST WTYP2
+ MOVE 0,1(AB)
+ MOVEM 0,3(TB)
+ ADD AB,C%22
+ JUMPGE AB,USPSTR
+ GETYP 0,(AB)
+ CAIE 0,TLIST
+ CAIN 0,TOBLS
+ SKIPA
+ JRST WTYP3
+ PUSH TP,[TATOM,,-1]
+ PUSH TP,IMQUOTE OBLIST
+ PUSH TP,(AB)
+ PUSH TP,1(AB) ; HE WANTS HIS OWN OBLIST
+ PUSH TP,C%0
+ PUSH TP,C%0
+ PUSHJ P,SPECBIND
+ ADD AB,C%22
+ JUMPGE AB,USPSTR
+ GETYP 0,(AB)
+ CAIE 0,TVEC
+ JRST WTYP
+ PUSH TP,[TATOM,,-1]
+ PUSH TP,IMQUOTE PARSE-TABLE
+ PUSH TP,(AB)
+ PUSH TP,1(AB)
+ PUSH TP,C%0
+ PUSH TP,C%0
+ PUSHJ P,SPECBIND
+ ADD AB,C%22
+ JUMPGE AB,USPSTR
+ GETYP 0,(AB)
+ CAIE 0,TCHRS
+ JRST WTYP
+ MOVE 0,1(AB)
+ MOVEM 0,5(TB) ; STUFF IN A LOOK-AHEAD CHARACTER IF HE WANTS
+ ADD AB,C%22
+ JUMPL AB,TMA
+USPSTR: MOVE B,IMQUOTE PARSE-STRING
+ PUSHJ P,ILOC ; GET A LOCATIVE TO THE STRING, WHEREVER
+ GETYP 0,A
+ CAIN 0,TUNBOUND ; NONEXISTANT
+ JRST BDPSTR
+ GETYP 0,(B) ; IT IS POINTING TO A STRING
+ CAIE 0,TCHSTR
+ JRST BDPSTR
+ MOVEM A,10.(TB)
+ MOVEM B,11.(TB)
+ POPJ P,
+
+LPRS1: PUSHJ P,GPT ; GET THE VALUE OF PARSE-TABLE IN SLOT
+ PUSH TP,$TLIST
+ PUSH TP,C%0 ; HERE WE ARE MAKE PLACE TO SAVE GOODIES
+ PUSH TP,$TLIST
+ PUSH TP,C%0
+LPRS2: PUSHJ P,IREAD1
+ JRST LPRSDN ; IF WE ARE DONE, WE ARE THROUGH
+ MOVE C,A
+ MOVE D,B
+ PUSHJ P,INCONS
+ SKIPN -2(TP)
+ MOVEM B,-2(TP) ; SAVE THE BEGINNING ON FIRST
+ SKIPE C,(TP)
+ HRRM B,(C) ; PUTREST INTO IT
+ MOVEM B,(TP)
+ JRST LPRS2
+LPRSDN: MOVSI A,TLIST
+ MOVE B,-2(TP)
+LPSRET: SKIPLE C,5(TB) ; EXIT FOR PARSE AND LPARSE
+ CAIN C,400033 ; SEE IF NO PEEK AHEAD OR IF ! ALTMODE
+ JRST FINIS ; IF SO NO NEED TO BACK STRING ONE
+ SKIPN C,11.(TB)
+ JRST FINIS ; IF ATE WHOLE STRING, DONT GIVE BACK ANY
+BUPRS: MOVEI D,1
+ ADDM D,(C) ; AOS THE COUNT OF STRING LENGTH
+ SKIPG D,1(C) ; SEXIER THAN CLR'S CODE FOR DECREMENTING
+ SUB D,[430000,,1] ; A BYTE POINTER
+ ADD D,[70000,,0]
+ MOVEM D,1(C)
+ HRRZ E,2(TB)
+ JUMPE E,FINIS ; SEE IF WE NEED TO BACK UP TWO
+ HLLZS 2(TB) ; CLEAR OUT DOUBLE CHR LOOKY FLAG
+ JRST BUPRS ; AND BACK UP PARSE STRING A LITTLE MORE
+
+\f; ARGUMENTS ARE BOUND, NOW GET THE VALUES OF THINGS
+
+
+GRT: MOVE B,IMQUOTE READ-TABLE
+ SKIPA ; HERE TO GET TABLE FOR READ
+GPT: MOVE B,IMQUOTE PARSE-TABLE
+ MOVSI A,TATOM ; TO FILL SLOT WITH PARSE TABLE
+ PUSHJ P,ILVAL
+ GETYP 0,A
+ CAIN 0,TUNBOUND
+ POPJ P,
+ CAIE 0,TVEC
+ JRST BADPTB
+ MOVEM A,6(TB)
+ MOVEM B,7(TB)
+ POPJ P,
+
+READ1: PUSHJ P,GRT
+ MOVE B,IMQUOTE INCHAN
+ MOVSI A,TATOM
+ PUSHJ P,IDVAL ;NOW GOBBLE THE REAL CHANNEL
+ TLZ A,TYPMSK#777777
+ HLLZS A ; INCASE OF FUNNY BUG
+ CAME A,$TCHAN ;IS IT A CHANNEL
+ JRST BADCHN
+ MOVEM A,4(TB) ; STORE CHANNEL
+ MOVEM B,5(TB)
+ HRRZ A,-2(B)
+ TRNN A,C.OPN
+ JRST CHNCLS
+ TRNN A,C.READ
+ JRST WRONGD
+ HLLOS 4(TB)
+ TRNE A,C.BIN ; SKIP IF NOT BIN
+ JRST BREAD ; CHECK FOR BUFFER
+ HLLZS 4(TB)
+GETIOA: MOVE B,5(TB)
+GETIO: MOVE A,IOINS(B) ;GOBBLE THE I/O INSTRUCTION
+ JUMPE A,OPNFIL ;GO REALLY OPEN THE CROCK
+ MOVE A,RADX(B) ;GET RADIX
+ MOVEM A,3(TB)
+ MOVEM B,5(TB) ;SAVE CHANNEL
+REREAD: HRRZ D,LSTCH(B) ;ANY CHARS AROUND?
+ MOVEI 0,33
+ CAIN D,400033 ;FLUSH THE TERMINATOR HACK
+ HRRM 0,LSTCH(B) ; MAKE ! ALT INTO JUST ALT IF IT IS STILL AROUND
+
+ PUSHJ P,@(P) ;CALL INTERNAL READER
+ JRST BADTRM ;LOST
+RFINIS: SUB P,C%11 ;POP OFF LOSER
+ PUSH TP,A
+ PUSH TP,B
+ JUMPE C,FLSCOM ; FLUSH TOP LEVEL COMMENT
+ PUSH TP,C
+ PUSH TP,D
+ MOVE A,4(TB)
+ MOVE B,5(TB) ; GET CHANNEL
+ MOVSI C,TATOM
+ MOVE D,IMQUOTE COMMENT
+ PUSHJ P,IPUT
+RFINI1: POP TP,B
+ POP TP,A
+ JRST FINIS
+
+FLSCOM: MOVE A,4(TB)
+ MOVE B,5(TB)
+ MOVSI C,TATOM
+ MOVE D,IMQUOTE COMMENT
+ PUSHJ P,IREMAS
+ JRST RFINI1
+
+BADTRM: MOVE C,5(TB) ; GET CHANNEL
+ JUMPGE B,CHLSTC ;NO, MUST BE UNMATCHED PARENS
+ SETZM LSTCH(C) ; DONT REUSE EOF CHR
+ PUSH TP,4(TB) ;CLOSE THE CHANNEL
+ PUSH TP,5(TB)
+ MCALL 1,FCLOSE
+ PUSH TP,EOFCND-1(B)
+ PUSH TP,EOFCND(B)
+ MCALL 1,EVAL ;AND EVAL IT
+ SETZB C,D
+ GETYP 0,A ; CHECK FOR FUNNY ACT
+ CAIE 0,TREADA
+ JRST RFINIS ; AND RETURN
+
+ PUSHJ P,CHUNW ; UNWIND TO POINT
+ MOVSI A,TREADA ; SEND MESSAGE BACK
+ JRST CONTIN
+
+;HERE TO ATTEMPT TO OPEN A CLOSED CHANNEL
+
+OPNFIL: PUSHJ P,OPNCHN ;GO DO THE OPEN
+ JUMPGE B,FNFFL ;LOSE IC B IS 0
+ JRST GETIO
+
+
+CHLSTC: MOVE B,5(TB) ;GET CHANNEL BACK
+ JRST REREAD
+
+
+BREAD: MOVE B,5(TB) ; GET CHANNEL
+ SKIPE BUFSTR(B)
+ JRST GETIO
+ MOVEI A,BUFLNT ; GET A BUFFER
+ PUSHJ P,IBLOCK
+ MOVEI C,BUFLNT(B) ; POINT TO END
+ HRLI C,440700
+ MOVE B,5(TB) ; CHANNEL BACK
+ MOVEI 0,C.BUF
+ IORM 0,-2(B)
+ MOVEM C,BUFSTR(B)
+ MOVSI C,TCHSTR+.VECT.
+ MOVEM C,BUFSTR-1(B)
+ JRST GETIO
+\f;MAIN ENTRY TO READER
+
+NIREAD: PUSHJ P,LSTCHR
+NIREA1: PUSH P,C%M1 ; [-1] ; DONT GOBBLE COMMENTS
+ JRST IREAD2
+
+IREAD:
+ PUSHJ P,LSTCHR ;DON'T REREAD LAST CHARACTER
+IREAD1: PUSH P,C%0 ; FLAG SAYING SNARF COMMENTS
+IREAD2: INTGO
+BDLP: SKIPE C,9.(TB) ;HAVE WE GOT A SPLICING MACRO LEFT
+ JRST SPLMAC ;IF SO GIVE HIM SOME OF IT
+ PUSHJ P,NXTCH ;GOBBLE CHAR IN A AND TYPE IN D
+ MOVMS B ; FOR SPECIAL NEG HACK OF MACRO TABLES
+ CAIG B,ENTYPE
+ JUMPN B,@DTBL-1(B) ;ERROR ON ZERO TYPE OR FUNNY TYPE
+ JRST BADCHR
+
+
+SPLMAC: HRRZ D,(C) ;GET THE REST OF THE SEGMENT
+ MOVEM D,9.(TB) ;AND PUT BACK IN PLACE
+ GETYP D,(C) ;SEE IF DEFERMENT NEEDED
+ CAIN D,TDEFER
+ MOVE C,1(C) ;IF SO, DO DEFEREMENT
+ MOVE A,(C)
+ MOVE B,1(C) ;GET THE GOODIE
+ AOS -1(P) ;ALWAYS A SKIP RETURN
+ POP P,(P) ;DONT WORRY ABOUT COMMENT SEARCHAGE
+ SETZB C,D ;MAKE SURE HE DOESNT THINK WE GOT COMMENT
+ POPJ P, ;GIVE HIM WHAT HE DESERVES
+
+DTBL:
+CODINI==0
+IRP A,,[[LETCOD,LETTER],[NUMCOD,NUMBER],[PLUCOD,PNUMBE],[NEGCOD,NNUMBE],[ASTCOD,ASTSTR],[DOTTYP,DOTSTR],[ETYPE,LETTER]
+[SPATYP,SPACE],[LPATYP,LPAREN],[RPATYP,RPAREN],[LBRTYP,LBRACK],[RBRTYP,RBRACK]
+[QUOTYP,QUOTIT],[MACTYP,MACCAL],[CSTYP,CSTRING],[ESCTYP,ESCSTR],[SPCTYP,SPECTY]
+[SLMNT,OPNANG],[CNGTYP,CLSANG],[EOFTYP,EOFCHR],[COMTYP,COMNT],[GLMNT,GLOVAL]
+[TMPTYP,ILLSQG],[NTYPES,CLSBRA],[EXCEXC,LETTER],[DOTEXT,SEGDOT],[LBREXT,UVECIN]
+[RBREXT,RBRACK],[QUOEXT,QUOSEG],[CSEXT,SINCHR],[SLMEXT,SEGIN],[ELMEXT,CLSANG]
+[GLMEXT,GLOSEG],[PATHTY,LOSPATH],[BSLEXT,SINCHR],[MANYT,TERM],[USTYP1,USRDS1]
+[USTYP2,USRDS2]]
+
+ IRP B,C,[A]
+ CODINI==CODINI+1
+ B==CODINI
+ SETZ C
+ .ISTOP
+ TERMIN
+TERMIN
+
+EXPUNGE CODINI
+
+ENTYPE==.-DTBL
+
+NONSPC==ETYPE
+
+SPACE: PUSHJ P,LSTCHR ;DONT REREAD SPACER
+ JRST BDLP
+
+USRDS1: SKIPA B,A ; GET CHAR IN B
+USRDS2: MOVEI B,200(A) ; ! CHAR, DISP 200 FURTHER
+ ASH B,1
+ ADD B,7(TB) ; POINT TO TABLE ENTRY
+ GETYP 0,(B)
+ CAIN 0,TLIST
+ MOVE B,1(B) ; IF LIST, USE FIRST ITEM-SPECIAL NO BREAK HACK
+ SKIPL C,5(TB) ; GET CHANNEL POINTER (IF ANY)
+ JRST USRDS3
+ ADD C,[EOFCND-1,,EOFCND-1]
+ PUSH TP,$TBVL
+ MOVE SP,SPSTOR+1
+ HRRM SP,(TP) ; BUILD A TBVL
+ MOVE SP,TP
+ MOVEM SP,SPSTOR+1
+ PUSH TP,C
+ PUSH TP,(C)
+ PUSH TP,1(C)
+ MOVE PVP,PVSTOR+1
+ MOVEI D,PVLNT*2+1(PVP)
+ HRLI D,TREADA
+ MOVEM D,(C)
+ MOVEI D,(TB)
+ HLL D,OTBSAV(TB)
+ MOVEM D,1(C)
+USRDS3: PUSH TP,(B) ; APPLIER
+ PUSH TP,1(B)
+ PUSH TP,$TCHRS ; APPLY TO CHARACTER
+ PUSH TP,A
+ PUSHJ P,LSTCHR ; FLUSH CHAR
+ MCALL 2,APPLY ; GO TO USER GOODIE
+ SKIPL 5(TB)
+ JRST USRDS9
+ MOVE SP,SPSTOR+1
+ HRRZ E,1(SP) ; POINT TO EOFCND SLOT
+ HRRZ SP,(SP) ; UNBIND MANUALLY
+ MOVEI D,(TP)
+ SUBI D,(SP)
+ MOVSI D,(D)
+ HLL SP,TP
+ SUB SP,D
+ MOVEM SP,SPSTOR+1
+ POP TP,1(E)
+ POP TP,(E)
+ SUB TP,C%22 ; FLUSH TP CRAP
+USRDS9: GETYP 0,A ; CHECK FOR DISMISS?
+ CAIN 0,TSPLICE
+ JRST GOTSPL ; RETURN OF SEGMENT INDICATES SPLICAGE
+ CAIN 0,TREADA ; FUNNY?
+ JRST DOEOF
+ CAIE 0,TDISMI
+ JRST RET ; NO, RETURN FROM IREAD
+ JRST BDLP ; YES, IGNORE RETURN
+
+GOTSPL: MOVEM B,9.(TB) ; STICK IN THE SPLICAGE SLOT SO IREADS WILL GET HIM
+ JRST BDLP ; GO BACK AND READ FROM OUR SPLICE, OK?
+
+\f
+;HERE ON NUMBER OR LETTER, START ATOM
+
+ESCSTR: PUSHJ P,NXTC1 ; ESCAPE FIRST
+LETTER: MOVEI FF,NOTNUM ; LETTER
+ JRST ATMBLD
+
+ASTSTR: MOVEI FF,OCTSTR
+DOTST1: MOVEI B,0
+ JRST NUMBLD
+
+NUMBER: MOVEI FF,NUMWIN ; SYMBOL OR NUMBER
+NUMBR1: MOVEI B,(A) ; TO A NUMBER
+ SUBI B,60
+ JRST NUMBLD
+
+PNUMBE: SETZB FF,B
+ JRST NUMBLD
+
+NNUMBE: MOVEI FF,NEGF
+ MOVEI B,0
+
+NUMBLD: PUSH TP,$TFIX
+ PUSH TP,B
+ PUSH TP,$TFIX
+ PUSH TP,B
+ PUSH TP,$TFIX
+ PUSH TP,C%0
+
+ATMBLD: LSH A,<36.-7>
+ PUSH P,A
+ MOVEI D,1 ; D IS CHAR COUNT
+ MOVSI C,350700+P ; BYTE PNTR
+ PUSHJ P,LSTCHR
+
+ATLP: PUSH P,FF
+ INTGO
+
+ PUSHJ P,NXTCH ; GET NEXT CHAR
+ POP P,FF
+ TRNN FF,NOTNUM ; IF NOT NUMBER, SKIP
+ JRST NUMCHK
+
+ATLP2: CAILE B,NONSPC ; SKIP IF STILL LETTER OR NUMBER
+ JRST CHKEND
+
+ATLP1: PUSHJ P,LSTCHR ; DONT REUSE
+ IDPB A,C ; INTO ATOM
+ TLNE C,760000 ; SKIP IF OK WORD
+ AOJA D,ATLP
+
+ PUSH P,C%0
+ MOVSI C,440700+P
+ AOJA D,ATLP
+
+CHKEND: CAIN B,ESCTYP ; ESCAPE?
+ JRST DOESC1
+
+CHKEN1: SKIPGE C ; SKIP IF TOP SLOT FULL
+ SUB P,C%11
+ PUSH P,D ; COUNT OF CHARS
+
+ JRST LOOPA ; GO HACK TRAILERS
+
+
+; HERE IF STILL COULD BE A NUMBER
+
+NUMCHK: CAIN B,NUMCOD ; STILL NUMBER
+ JRST NUMCH1
+
+ CAILE B,NONSPC ; NUMBER FINISHED?
+ JRST NUMCNV
+
+ CAIN B,DOTTYP
+ TROE FF,DOTSEN
+ JRST NUMCH2
+ TRNE FF,OCTSTR+EFLG
+ JRST NUMCH3 ; NO . IN OCTAL OR EXPONENT
+ TRO FF,DECFRC ; MUST BE DECIMAL NOW
+ JRST ATLP1
+
+NUMCH1: TRO FF,NUMWIN
+ MOVEI B,(A)
+ SUBI B,60
+ TRNE FF,OCTSTR+OCTWIN ; IS THIS *DDDDDD* HACK
+ JRST NUMCH4 ; YES, GO DO IT
+ TRNE FF,EFLG
+ JRST NUMCH7 ; DO EXPONENT
+
+ TRNE FF,DOTSEN ; FORCE FLOAT
+ JRST NUMCH5
+
+ JFCL 17,.+1 ; KILL ALL FLAGS
+ MOVE E,CNUM(TP) ; COMPUTE CURRENT RADIX
+ IMUL E,3(TB)
+ ADDI E,(B) ; ADD IN CURRENT DIGIT
+ JFCL 10,.+3
+ MOVEM E,CNUM(TP)
+ JRST NUMCH6
+
+ MOVE E,3(TB) ; SEE IF CURRENT RADIX DECIMAL
+ CAIE E,10.
+ JRST NUMCH5 ; YES, FORCE FLOAT
+ TROA FF,OVFLEW
+
+NUMCH5: TRO FF,FLONUM ; SET FLOATING FLAG
+NUMCH6: JFCL 17,.+1 ; CLEAR ALL FLAGS
+ MOVE E,DNUM(TP) ; GET DECIMAL NUMBER
+ IMULI E,10.
+ JFCL 10,NUMCH8 ; JUMP IF OVERFLOW
+ ADDI E,(B) ; ADD IN DIGIT
+ MOVEM E,DNUM(TP)
+ TRNE FF,FLONUM ; IS THIS FRACTION?
+ SOS NDIGS(TP) ; YES, DECREASE EXPONENT BY ONE
+ JRST ATLP1
+
+NUMCH8: TRNE FF,DOTSEN ; OVERFLOW IN DECMIMAL
+ JRST ATLP1 ; OK, IN FRACTION
+
+ AOS NDIGS(TP)
+ TRO FF,FLONUM ; MAKE IT FLOATING TO FIT
+ JRST ATLP1
+
+NUMCH4: TRNE FF,OCTWIN
+ JRST NUMCH3 ; ALREADY ONE, MORE DIGITS LOSE
+ MOVE E,ONUM(TP)
+ TLNE E,700000 ; SKIP IF WORD NOT FULL
+ TRO FF,OVFLEW
+ LSH E,3
+ ADDI E,(B) ; ADD IN NEW ONE
+ MOVEM E,ONUM(TP)
+ JRST ATLP1
+
+NUMCH3: SUB TP,[NUMTMP,,NUMTMP] ; FLUSH NUMBER CRUFT
+ TRO FF,NOTNUM
+ JRST ATLP2
+
+NUMCH2: CAIN B,ASTCOD ; POSSIBLE END OF OCTAL
+ TRZN FF,OCTSTR ; RESET FLAG AND WIN
+ JRST NUMCH9
+
+ TRO FF,OCTWIN
+ JRST ATLP2
+
+NUMCH9: CAIN B,ETYPE
+ TROE FF,EFLG
+ JRST NUMC10 ; STILL COULD BE +- EXPONENT
+
+ TRZ FF,NUMWIN ; IN CASE NO MORE DIGITS
+ SETZM ENUM(TP)
+ JRST ATLP1
+
+NUMCH7: MOVE E,ENUM(TP)
+ IMULI E,10.
+ ADDI E,(B)
+ MOVEM E,ENUM(TP) ; UPDATE ECPONENT
+ TRO FF,EPOS ; FLUSH IF SIGN COMES NOW
+ JRST ATLP1
+
+NUMC10: TRNN FF,EFLG ; IF NOT IN EXPONENT, LOSE
+ TRNE FF,ENEG+EPOS ; SIGN FOR EXPONENT SEEN?
+ JRST NUMCH3 ; NOT A NUMBER
+ CAIN B,PLUCOD
+ TRO FF,EPOS
+ CAIN B,NEGCOD
+ TRO FF,ENEG
+ TRNE FF,EPOS+ENEG
+ JRST ATLP1
+ JRST NUMCH3
+
+; HERE AFTER \ QUOTER
+
+DOESC1: PUSHJ P,NXTC1 ; GET CHAR
+ JRST ATLP1 ; FALL BACK INTO LOOP
+
+
+; HERE TO CONVERT NUMBERS AS NEEDED
+
+NUMCNV: CAIE B,ESCTYP
+ TRNE FF,OCTSTR
+ JRST NUMCH3
+ TRNN FF,NUMWIN
+ JRST NUMCH3
+ ADDI D,4
+ IDIVI D,5
+ SKIPGE C ; SKIP IF NEW WORD ADDED
+ ADDI D,1
+ HRLI D,(D) ; TOO BOTH HALVES
+ SUB P,D ; REMOVE CHAR STRING
+ MOVE D,3(TB) ; IS RADIX 10?
+ CAIE D,10.
+ TRNE FF,DECFRC
+ TRNN FF,FLONUM+EFLG ;IS IT A FLOATING POINT NUMBER
+ TRNE FF,EFLG
+ JRST FLOATIT ;YES, GO MAKE IT WIN
+ TRNE FF,OVFLEW
+ JRST FOOR
+ MOVE B,CNUM(TP)
+ TRNE FF,DECFRC
+ MOVE B,DNUM(TP) ;GRAB FIXED GOODIE
+ TRNE FF,OCTWIN ; SKIP IF NOT OCTAL
+ MOVE B,ONUM(TP) ; USE OCTAL VALUE
+FINID2: MOVSI A,TFIX ;SAY FIXED POINT
+FINID1: TRNE FF,NEGF ;NEGATE
+ MOVNS B ;YES
+ SUB TP,[NUMTMP,,NUMTMP] ;FINISH HACK
+ JRST RET ;AND RETURN
+
+\f
+FLOATIT:
+ JFCL 17,.+1 ;CLEAR ALL ARITHMETIC FLAGS
+ TRNE FF,EFLG ;"E" SEEN?
+ JRST EXPDO ;YES, DO EXPONENT
+ MOVE D,NDIGS(TP) ;GET IMPLICIT EXPONENT
+
+FLOATE: MOVE A,DNUM(TP) ;GET DECIMAL NUMBER
+ IDIVI A,400000 ;SPLIT
+ FSC A,254 ;CONVERT MOST SIGNIFICANT
+ FSC B,233 ; AND LEAST SIGNIFICANT
+ FADR B,A ;COMBINE
+
+ MOVM A,D ;GET MAGNITUDE OF EXPONENT
+ MOVSI E,(1.0)
+ JFCL 17,.+1 ; CLEAR ALL OVERFLOW/UNDERFLOW BITS
+ CAIG A,38. ;HOW BIG?
+ JRST .+3 ;TOO BIG-FLOATING OUT OF RANGE
+ MOVE E,[1.0^38.]
+ SUBI A,38.
+ JUMPGE D,FLOAT1 ;JUMP IF EXPONENT POSITIVE
+ FDVR B,E
+ FDVR B,TENTAB(A) ;DIVIDE BY TEN TO THE EXPONENT
+ JRST SETFLO
+
+FLOAT1: FMPR B,E
+ FMPR B,TENTAB(A) ;SCALE UP
+
+SETFLO: JFCL 17,FOOR ;FLOATING OUT OF RANGE ON OVERFLOW
+ MOVSI A,TFLOAT
+ TRZ FF,FRSDOT ;FLOATING NUMBER NOT VALUE
+ JRST FINID1
+
+EXPDO:
+ HRRZ D,ENUM(TP) ;GET EXPONENT
+ TRNE FF,ENEG ;IS EXPONENT NEGATIVE?
+ MOVNS D ;YES
+ ADD D,NDIGS(TP) ;ADD IMPLICIT EXPONENT
+ JUMPL D,FLOATE ;FLOATING IF EXPONENT NEGATIVE
+ CAIG D,10. ;OR IF EXPONENT TOO LARGE
+ TRNE FF,FLONUM ;OR IF FLAG SET
+ JRST FLOATE
+ MOVE B,DNUM(TP) ;
+ IMUL B,ITENTB(D)
+ JFCL 10,FLOATE ;IF OVERFLOW, MAKE FLOATING
+ JRST FINID2 ;GO MAKE FIXED NUMBER
+
+
+; HERE TO START BUILDING A CHARACTER STRING GOODIE
+
+CSTRING:
+ PUSH P,C%0
+ MOVEI D,0 ; CHARCOUNT
+ MOVSI C,440700+P ; AND BYTE POINTER
+
+CSLP: PUSH P,FF
+ INTGO
+ PUSHJ P,NXTC1 ; GET NEXT CHAR
+ POP P,FF
+
+ CAIN B,CSTYP ; END OF STRING?
+ JRST CSLPEND
+
+ CAIN B,ESCTYP ; ESCAPE?
+ PUSHJ P,NXTC1
+
+ IDPB A,C ; INTO ATOM
+ TLNE C,760000 ; SKIP IF OK WORD
+ AOJA D,CSLP
+
+ PUSH P,C%0
+ MOVSI C,440700+P
+ AOJA D,CSLP
+
+CSLPEND:
+ SKIPGE C
+ SUB P,C%11
+ PUSH P,D
+ PUSHJ P,CHMAK
+ PUSHJ P,LSTCHR
+
+ JRST RET
+
+;ARRIVE HERE TO INVOKE A READ TIME MACRO FUNCTION
+
+MACCAL: PUSHJ P,NXTCH1 ;READ ONE MORE CHARACTER
+ CAIE B,MACTYP ;IS IT ANOTHER MACRO CHAR
+
+ JRST MACAL2 ;NO, CALL MACRO AND USE VALUE
+ PUSHJ P,LSTCHR ;DONT REREAD %
+ PUSHJ P,MACAL1 ;OTHERWISE, USE SIDE EFFECCT, BUT NOT VALUE
+ JRST IREAD2
+
+MACAL2: PUSH P,[RET12]
+MACAL1: PUSHJ P,IREAD1 ;READ FUNCTION NAME
+ PUSHJ P,RETERR
+ PUSH TP,C
+ PUSH TP,D ; SAVE COMMENT IF ANY
+ PUSH TP,A ;SAVE THE RESULT
+ PUSH TP,B ;AND USE IT AS AN ARGUMENT
+ MCALL 1,EVAL
+ POP TP,D
+ POP TP,C ; RESTORE COMMENT IF ANY...
+CRET: POPJ P,RET12
+
+;CALL GOBBLE TO FIND THE TYPE AND THEN IREAD TO READ IT
+
+SPECTY: PUSHJ P,NIREAD ; READ THE TYPES NAME (SHOULD BE AN ATOM)
+ PUSHJ P,RETERR
+ PUSH TP,A
+ PUSH TP,B
+ GETYP A,A
+ CAIN A,TFIX
+ JRST BYTIN
+ PUSHJ P,NXTCH ; GET NEXT CHAR
+ CAIN B,TMPTYP ; SKIP IF NOT TEMPLATE START
+ JRST RDTMPL
+ SETZB A,B
+ EXCH A,-1(TP)
+ EXCH B,(TP)
+ PUSH TP,A ;BEGIN SETTING UP CHTYPE CALL
+ PUSH TP,B
+ PUSHJ P,IREAD1 ;NOW READ STRUCTURE
+ PUSHJ P,RETERR
+ MOVEM C,-3(TP) ; SAVE COMMENT
+ MOVEM D,-2(TP)
+ EXCH A,-1(TP) ;USE AS FIRST ARG
+ EXCH B,(TP)
+ PUSH TP,A ;USE OTHER AS 2D ARG
+ PUSH TP,B
+ MCALL 2,CHTYPE ;ATTEMPT TO MUNG
+RET13: POP TP,D
+ POP TP,C ; RESTORE COMMENT
+RET12: SETOM (P) ; DONT LOOOK FOR MORE!
+ JRST RET
+
+RDTMPL: PUSH P,["}] ; SET UP TERMINATE TEST
+ MOVE B,(TP)
+ PUSHJ P,IGVAL
+ MOVEM A,-1(TP)
+ MOVEM B,(TP)
+ PUSH P,[BLDTMP] ; FLAG FOR VECTOR READING CODE
+ JRST LBRAK2
+
+BLDTMP: ADDI A,1 ; 1 MORE ARGUMENT
+ ACALL A,APPLY ; DO IT TO IT
+ POPJ P,
+
+BYTIN: PUSHJ P,NXTCH ; CHECK FOR OPENR
+ CAIN B,SPATYP
+ PUSHJ P,SPACEQ
+ JRST .+3
+ PUSHJ P,LSTCHR
+ JRST BYTIN
+ CAIE B,TMPTYP
+ ERRUUO EQUOTE BAD-USE-OF-BYTE-STRING
+ PUSH P,["}]
+ PUSH P,[CBYTE1]
+ JRST LBRAK2
+
+CBYTE1: AOJA A,CBYTES
+
+RETERR: SKIPL A,5(TB)
+ MOVEI A,5(TB)-LSTCH ;NO CHANNEL, USE SLOT
+ HRRM B,LSTCH(A) ; RESTORE LAST CHAR
+ PUSHJ P,ERRPAR
+ SOS (P)
+ SOS (P)
+ POPJ P,
+
+\f
+;THIS CODE CALLS IREAD RECURSIVELY TO READ THAT WHICH IS
+;BETWEEN (), ARRIVED AT WHEN ( IS READ
+
+SEGIN: PUSH TP,$TSEG
+ JRST OPNAN1
+
+OPNANG: PUSH TP,$TFORM ;SAVE TYPE
+OPNAN1: PUSH P,[">]
+ JRST LPARN1
+
+LPAREN: PUSH P,[")]
+ PUSH TP,$TLIST ;START BY ASSUMING NIL
+LPARN1: PUSH TP,C%0
+ PUSHJ P,LSTCHR ;DON'T REREAD PARENS
+LLPLOP: PUSHJ P,IREAD1 ;READ IT
+ JRST LDONE ;HIT TERMINATOR
+
+;HERE WHEN MUST ADD CAR TO CURRENT WINNER
+
+GENCAR: PUSH TP,C ; SAVE COMMENT
+ PUSH TP,D
+ MOVE C,A ; SET UP CALL
+ MOVE D,B
+ PUSHJ P,INCONS ; CONS ON TO NIL
+ POP TP,D
+ POP TP,C
+ POP TP,E ;GET CDR
+ JUMPN E,CDRIN ;IF STACKED GOODIE NOT NIL SKIP
+ PUSH TP,B ;AND USE AS TOTAL VALUE
+ PUSH TP,$TLIST ;SAVE THIS AS FIRSST THING ON LIST
+ MOVE A,-2(TP) ; GET REAL TYPE
+ JRST .+2 ;SKIP CDR SETTING
+CDRIN: HRRM B,(E)
+ PUSH TP,B ;CLOBBER IN NEW PARTIAL GOODIE
+ JUMPE C,LLPLOP ; JUMP IF NO COMMENT
+ PUSH TP,C
+ PUSH TP,D
+ MOVSI C,TATOM
+ MOVE D,IMQUOTE COMMENT
+ PUSHJ P,IPUT
+ JRST LLPLOP ;AND CONTINUE
+
+; HERE TO RAP UP LIST
+
+LDONE: CAME B,(P) ;CHECK VALIDITY OF CHARACTER
+ PUSHJ P,MISMAT ;REPORT MISMATCH
+ SUB P, C%11
+ POP TP,B ;GET VALUE OF PARTIAL RESULT
+ POP TP,A ;AND TYPE OF SAME
+ JUMPE B,RET ;VALUE IS NIL, DON'T POP AGAIN
+ POP TP,B ;POP FIRST LIST ELEMENT
+ POP TP,A ;AND TYPE
+ JRST RET
+\f
+;THIS CODE IS SIMILAR TO LIST GENERATING CODE BUT IS FOR VECTORS
+OPNBRA: PUSH P,["}] ; SAVE TERMINATOR
+UVECIN: PUSH P,[135] ; CLOSE SQUARE BRACKET
+ PUSH P,[SETZ IEUVECTOR] ;PUSH NAME OF U VECT HACKER
+ JRST LBRAK2 ;AND GO
+
+LBRACK: PUSH P,[135] ; SAVE TERMINATE
+ PUSH P,[SETZ IEVECTOR] ;PUSH GEN VECTOR HACKER
+LBRAK2: PUSHJ P,LSTCHR ;FORCE READING NEW CHAR
+ PUSH P,C%0 ; COUNT ELEMENTS
+ PUSH TP,$TLIST ; AND SLOT FOR GOODIES
+ PUSH TP,C%0
+
+LBRAK1: PUSHJ P,IREAD1 ;RECURSIVELY READ ELEMENTS OF ARRAY
+ JRST LBDONE ;RAP UP ON TERMINATOR
+
+STAKIT: EXCH A,-1(TP) ; STORE RESULT AND GET CURRENT LIST
+ EXCH B,(TP)
+ AOS (P) ; COUNT ELEMENTS
+ JUMPE C,LBRAK3 ; IF NO COMMENT, GO ON
+ MOVEI E,(B) ; GET CDR
+ PUSHJ P,ICONS ; CONS IT ON
+ MOVEI E,(B) ; SAVE RS
+ MOVSI C,TFIX ; AND GET FIXED NUM
+ MOVE D,(P)
+ PUSHJ P,ICONS
+LBRAK3: PUSH TP,A ; SAVE CURRENT COMMENT LIST
+ PUSH TP,B
+ JRST LBRAK1
+
+; HERE TO RAP UP VECTOR
+
+LBDONE: CAME B,-2(P) ; FINISHED RETURN (WAS THE RIGHT STOP USED?)
+ PUSHJ P,MISMAB ; WARN USER
+ POP TP,1(TB) ; REMOVE COMMENT LIST
+ POP TP,(TB)
+ MOVE A,(P) ; COUNT TO A
+ PUSHJ P,-1@(P) ; MAKE THE VECTOR
+ SUB P,C%33
+
+; PUT COMMENTS ON VECTOR (OR UVECTOR)
+
+ MOVNI C,1 ; INDICATE TEMPLATE HACK
+ CAMN A,$TVEC
+ MOVEI C,1
+ CAMN A,$TUVEC ; SKIP IF UVECTOR
+ MOVEI C,0
+ PUSH P,C ; SAVE
+ PUSH TP,A ; SAVE VECTOR/UVECTOR
+ PUSH TP,B
+
+VECCOM: SKIPN C,1(TB) ; ANY LEFT?
+ JRST RETVEC ; NO, LEAVE
+ MOVE A,1(C) ; ASSUME WINNING TYPES
+ SUBI A,1
+ HRRZ C,(C) ; CDR THE LIST
+ HRRZ E,(C) ; AGAIN
+ MOVEM E,1(TB) ; SAVE CDR
+ GETYP E,(C) ; CHECK DEFFERED
+ MOVSI D,(E)
+ CAIN E,TDEFER ; SKIP IF NOT DEFERRED
+ MOVE C,1(C)
+ CAIN E,TDEFER
+ GETYPF D,(C) ; GET REAL TYPE
+ MOVE B,(TP) ; GET VECTOR POINTER
+ SKIPGE (P) ; SKIP IF NOT TEMPLATE
+ JRST TMPCOM
+ HRLI A,(A) ; COUNTER
+ LSH A,@(P) ; MAYBE SHIFT IT
+ ADD B,A
+ MOVE A,-1(TP) ; TYPE
+TMPCO1: PUSH TP,D
+ PUSH TP,1(C) ; PUSH THE COMMENT
+ MOVSI C,TATOM
+ MOVE D,IMQUOTE COMMENT
+ PUSHJ P,IPUT
+ JRST VECCOM
+
+TMPCOM: MOVSI A,(A)
+ ADD B,A
+ MOVSI A,TTMPLT
+ JRST TMPCO1
+
+RETVEC: SUB P,C%11
+ POP TP,B
+ POP TP,A
+ JRST RET
+
+; BUILD A SINGLE CHARACTER ITEM
+
+SINCHR: PUSHJ P,NXTC1 ;FORCE READ NEXT
+ CAIN B,ESCTYP ;ESCAPE?
+ PUSHJ P,NXTC1 ;RETRY
+ MOVEI B,(A)
+ MOVSI A,TCHRS
+ JRST RETCL
+
+\f
+; HERE ON RIGHT PAREN, BRACKET, ANGLE BRACKET OR CTL C
+
+CLSBRA:
+CLSANG: ;CLOSE ANGLE BRACKETS
+RBRACK: ;COMMON RETURN FOR END OF ARRAY ALSO
+RPAREN: PUSHJ P,LSTCHR ;DON'T REREAD
+EOFCH1: MOVE B,A ;GETCHAR IN B
+ MOVSI A,TCHRS ;AND TYPE IN A
+RET1: SUB P,C%11
+ POPJ P,
+
+EOFCHR: SETZB C,D
+ JUMPL A,EOFCH1 ; JUMP ON REAL EOF
+ JRST RRSUBR ; MAYBE A BINARY RSUBR
+
+DOEOF: MOVE A,[-1,,3]
+ SETZB C,D
+ JRST EOFCH1
+
+
+; NORMAL RETURN FROM IREAD/IREAD1
+
+RETCL: PUSHJ P,LSTCHR ;DONT REREAD
+RET: AOS -1(P) ;SKIP
+ POP P,E ; POP FLAG
+RETC: JUMPL E,RET2 ; DONT LOOK FOR COMMENTS
+ PUSH TP,A ; SAVE ITEM
+ PUSH TP,B
+CHCOMN: PUSHJ P,NXTCH ; READ A CHARACTER
+ CAIE B,COMTYP ; SKIP IF COMMENT
+ JRST CHSPA
+ PUSHJ P,IREAD ; READ THE COMMENT
+ JRST POPAJ
+ MOVE C,A
+ MOVE D,B
+ JRST .+2
+POPAJ: SETZB C,D
+ POP TP,B
+ POP TP,A
+RET2: POPJ P,
+
+CHSPA: CAIN B,SPATYP
+ PUSHJ P,SPACEQ ; IS IT A REAL SPACE
+ JRST POPAJ
+ PUSHJ P,LSTCHR ; FLUSH THE SPACE
+ JRST CHCOMN
+
+;RANDOM MINI-SUBROUTINES USED BY THE READER
+
+;READ A CHAR INTO A AND TYPE CODE INTO D
+
+NXTC3: SKIPL B,5(TB) ;GET CHANNEL
+ JRST NXTPR4 ;NO CHANNEL, GO READ STRING
+ SKIPE LSTCH(B)
+ PUSHJ P,CNTACC ; COUNT ON ACCESS POINTER
+ PUSHJ P,RXCT
+ TRO A,200
+ JRST GETCTP
+
+NXTC1: SKIPL B,5(TB) ;GET CHANNEL
+ JRST NXTPR1 ;NO CHANNEL, GO READ STRING
+ SKIPE LSTCH(B)
+ PUSHJ P,CNTACC ; COUNT ON ACCESS POINTER
+ JRST NXTC2
+NXTC: SKIPL B,5(TB) ;GET CHANNEL
+ JRST NXTPRS ;NO CHANNEL, GO READ STRING
+ SKIPE A,LSTCH(B) ;CHAR IN A IF REUSE
+ JRST PRSRET
+NXTC2: PUSHJ P,RXCT ;GET CHAR FROM INPUT
+ TLO A,200000 ; BIT TO AVOID ^@ LOSSAGE
+ HLLZS 2(TB) ;FLAG INDICATING ONE CHAR LOOK AHEAD
+ MOVEM A,LSTCH(B) ;SAVE THE CHARACTER
+PRSRET: TLZ A,200000
+ TRZE A,400000 ;DONT SKIP IF SPECIAL
+ TRO A,200 ;GO HACK SPECIALLY
+GETCTP: PUSH P,A ;AND SAVE FROM DIVISION
+ ANDI A,377
+ IDIVI A,CHRWD ;YIELDS WORD AND CHAR NUMBER
+ LDB B,BYTPNT(B) ;GOBBLE TYPE CODE
+ POP P,A
+ ANDI A,177 ; RETURN REAL ASCII
+ POPJ P,
+
+NXTPR4: MOVEI F,400000
+ JRST NXTPR5
+
+NXTPRS: SKIPE A,5(TB) ;GET OLD CHARACTER IF ONE EXISTS
+ JRST PRSRET
+NXTPR1: MOVEI F,0
+NXTPR5: MOVE A,11.(TB)
+ HRRZ B,(A) ;GET THE STRING
+ SOJL B,NXTPR3
+ HRRM B,(A)
+ ILDB A,1(A) ;GET THE CHARACTER FROM THE STRING
+ IORI A,(F)
+NXTPR2: MOVEM A,5(TB) ;SAVE IT
+ JRST PRSRET ;CONTINUE
+
+NXTPR3: SETZM 8.(TB)
+ SETZM 9.(TB) ;CLEAR OUT LOCATIVE, AT END OF STRING
+ MOVEI A,400033
+ JRST NXTPR2
+
+; NXTCH AND NXTCH1 ARE SAME AS NXTC AND NXTC1 EXCEPT THEY CHECK !
+; HACKS
+
+NXTCH1: PUSHJ P,NXTC1 ;READ CHAR
+ JRST .+2
+NXTCH: PUSHJ P,NXTC ;READ CHAR
+ PUSHJ P,CHKUS1 ; CHECK FOR USER DISPATCH
+
+ CAIE B,NTYPES+1 ; SKIP IF ! ING NEXT CHAR
+ POPJ P,
+ PUSHJ P,NXTC3 ;READ NEXT ONE
+ HLLOS 2(TB) ;FLAG FOR TWO CHAR LOOK AHEAD
+
+CRMLST: IORI A,400000 ;CLOBBER LASTCHR
+ PUSH P,B
+ SKIPL B,5(TB) ;POINT TO CHANNEL
+ MOVEI B,5(TB)-LSTCH ;NO CHANNEL, POINT AT SLOT
+ HRRM A,LSTCH(B)
+ ANDI A,377777 ;DECREASE CHAR
+ POP P,B
+
+CHKUS2: SKIPN 7(TB) ; SKIP IF USER TABLE
+ POPJ P,
+ MOVEI F,200(A)
+ ASH F,1 ; POINT TO SLOT
+ HRLI F,(F)
+ ADD F,7(TB)
+ JUMPGE F,CPOPJ ;IS THERE VECTOR ENOUGH?
+ SKIPN 1(F) ; NON-ZERO==>USER FCN EXISTS
+ JRST CPOPJ ; HOPE HE APPRECIATES THIS
+ MOVEI B,USTYP2
+CHKRDO: PUSH P,0 ; CHECK FOR REDOING IF CHAR IN TABLE
+ GETYP 0,(F)
+ CAIE 0,TCHRS
+ JRST CHKUS5
+ POP P,0 ;WE ARE TRANSMOGRIFYING
+ MOVE A,1(F) ;GET NEW CHARACTER
+ PUSH P,7(TB)
+ PUSH P,2(TB) ; FLAGS FOR NUM OF CHRS IN LOOK AHEAD
+ PUSH P,5(TB) ; TO AVOID SMASHING LSTCHR
+ SETZM 5(TB) ; CLEAR OUT CHANNEL
+ SETZM 7(TB) ;CLEAR OUT TABLE
+ TRZE A,200 ; ! HACK
+ TRO A,400000 ; TURN ON PROPER BIT
+ PUSHJ P,PRSRET
+ POP P,5(TB) ; GET BACK CHANNEL
+ POP P,2(TB)
+ POP P,7(TB) ;GET BACK OLD PARSE TABLE
+ POPJ P,
+
+CHKUS5: PUSH P,A
+ CAIE 0,TLIST
+ JRST .+4 ; SPECIAL NON-BREAK TYPE HACK
+ MOVNS (P) ; INDICATE BY NEGATIVE
+ MOVE A,1(F) ; GET <1 LIST>
+ GETYP 0,(A) ; AND GET THE TYPE OF THAT
+ CAIE 0,TFIX ; SEE IF HE WANTS SAME CHAR WITH DIFF TYPE
+ JRST CHKUS6 ; JUST A VANILLA HACK
+ MOVE A,1(F) ; PRETEND IT IS SAME TYPE AS NEW CHAR
+ PUSH P,7(TB) ; CLEAR OUT TRANSLATE TABLE
+ PUSH P,2(TB) ; FLAGS FOR # OF CHRS IN LOOK AHEAD
+ SETZM 7(TB)
+ TRZE A,200
+ TRO A,400000 ; TURN ON PROPER BIT IF ! HACK
+ PUSHJ P,PRSRET ; REGET TYPE
+ POP P,2(TB)
+ POP P,7(TB) ; PUT TRANSLATE TABLE BACK
+CHKUS6: SKIPGE -1(P) ; SEE IF A SPECIAL NON-BREAK
+ MOVNS B ; SEXY, HUH?
+ POP P,A
+ POP P,0
+ MOVMS A ; FIX UP A POSITIVE CHARACTER
+ POPJ P,
+
+CHKUS4: POP P,A
+ POPJ P,
+
+CHKUS1: SKIPN 7(TB) ; USER CHECK FOR NOT ! CASE
+ POPJ P,
+ MOVEI F,(A)
+ ASH F,1
+ HRLI F,(F)
+ ADD F,7(TB)
+ JUMPGE F,CPOPJ
+ SKIPN 1(F)
+ POPJ P,
+ MOVEI B,USTYP1
+ JRST CHKRDO ; TRANSMOGRIFY CHARACTER?
+
+CHKUS3: POP P,A
+ POPJ P,
+
+UPLO: POPJ P, ; LETS NOT AND SAY WE USED TO
+ ; AVOID STRANGE ! BLECHAGE
+NXTCS: PUSHJ P,NXTC
+ PUSH P,A ; HACK TO NOT TRANSLATE CHAR
+ PUSHJ P,CHKUS1 ; BUT DO TRANSLATION OF TYPE IF HE WANTS
+ POP P,A ; USED TO BUILD UP STRINGS
+ POPJ P,
+
+CHKALT: CAIN A,33 ;ALT?
+ MOVEI B,MANYT
+ JRST CRMLST
+
+
+TERM: MOVEI B,0 ;RETURN A 0
+ JRST RET1
+ ;AND RETURN
+
+CHKMIN: CAIN A,"- ; IF CHAR IS -, WINNER
+ MOVEI B,PATHTY
+ JRST CRMLST
+
+LOSPAT: PUSHJ P,LSTCHR ; FIX RECURSIVE LOSAGE
+ ERRUUO EQUOTE UNATTACHED-PATH-NAME-SEPARATOR
+
+\f
+; HERE TO SEE IF READING RSUBR
+
+RRSUBR: PUSHJ P,LSTCHR ; FLUSH JUST READ CHAR
+ SKIPL B,5(TB) ; SKIP IF A CHANNEL EXISTS
+ JRST SPACE ; ELSE LIKE A SPACE
+ HRRZ C,BUFSTR(B) ; SEE IF FLAG SAYS START OF RSUBR
+ MOVE C,(C)
+ TRNN C,1 ; SKIP IF REAL RSUBR
+ JRST EOFCH2 ; NO, IGNORE FOR NOW
+
+; REALLY ARE READING AN RSUBR
+
+ HRRZ 0,4(TB) ; GET READ/READB INDICATOR
+ MOVE C,ACCESS(B) ; GET CURRENT ACCESS
+ JUMPN 0,.+3 ; ALREADY WORDS, NO NEED TO DIVIDE
+ ADDI C,4 ; ROUND UP
+ IDIVI C,5
+ PUSH P,C ; SAVE WORD ACCESS
+ MOVEI A,(C) ; COPY IT FOR CALL
+ JUMPN 0,.+3
+ IMULI C,5
+ MOVEM C,ACCESS(B) ; FIXUP ACCESS
+ HLLZS ACCESS-1(B) ; FOR READB LOSER
+ PUSHJ P,DOACCS ; AND GO THERE
+ PUSH P,C%0 ; FOR READ IN
+ HRROI A,(P) ; PREPARE TO READ LENGTH
+ PUSHJ P,DOIOTI ; READ IT
+ POP P,C ; GET READ GOODIE
+ JUMPGE A,.+4 ; JUMP IF WON
+ SUB P,C%11
+EOFCH2: HRROI A,3
+ JRST EOFCH1
+ MOVEI A,(C) ; COPY FOR GETTING BLOCK
+ ADDI C,1 ; COUNT COUNT WORD
+ ADDM C,(P)
+ PUSH TP,$TUVEC ; WILL HOLD UVECTOR OF FIXUPS IF THEY STAY
+ PUSH TP,C%0
+ PUSHJ P,IBLOCK ; GET A BLOCK
+ PUSH TP,$TUVEC
+ PUSH TP,B ; AND SAVE
+ MOVE A,B ; READY TO IOT IT IN
+ MOVE B,5(TB) ; GET CHANNEL BACK
+ MOVSI 0,TUVEC ; SETUP A'S TYPE
+ MOVE PVP,PVSTOR+1
+ MOVEM 0,ASTO(PVP)
+ PUSHJ P,DOIOTI ; IN COMES THE WHOLE BLOCK
+ MOVE PVP,PVSTOR+1
+ SETZM ASTO(PVP) ; A NO LONGER SPECIAL
+ MOVEI C,BUFSTR-1(B) ; NO RESET BUFFER
+ PUSHJ P,BYTDOP ; A POINTS TO DOPW WORD
+ SUBI A,2
+ HRLI A,010700 ; SETUP BYTE POINTER TO END
+ HLLZS BUFSTR-1(B) ; ZERO CHAR COUNNT
+ MOVEM A,BUFSTR(B)
+ HRRZ A,4(TB) ; READ/READB FLG
+ MOVE C,(P) ; ACCESS IN WORDS
+ SKIPN A ; SKIP FOR ASCII
+ IMULI C,5 ; BUMP
+ MOVEM C,ACCESS(B) ; UPDATE ACCESS
+ PUSHJ P,NIREAD ; READ RSUBR VECTOR
+ JRST BRSUBR ; LOSER
+ GETYP A,A ; VERIFY A LITTLE
+ CAIE A,TVEC ; DONT SKIP IF BAD
+ JRST BRSUBR ; NOT A GOOD FILE
+ PUSHJ P,LSTCHR ; FLUSH REREAD CHAR
+ MOVE C,(TP) ; CODE VECTOR BACK
+ MOVSI A,TCODE
+ HLR A,B ; FUNNY COUNT
+ MOVEM A,(B) ; CLOBBER
+ MOVEM C,1(B)
+ PUSH TP,$TRSUBR ; MAKE RSUBR
+ PUSH TP,B
+
+; NOW LOOK OVER FIXUPS
+
+ MOVE B,5(TB) ; GET CHANNEL
+ MOVE C,ACCESS(B)
+ HLLZS ACCESS-1(B) ; FOR READB LOSER
+ HRRZ 0,4(TB) ; READ/READB FLG
+ JUMPN 0,RSUB1
+ ADDI C,4 ; ROUND UP
+ IDIVI C,5 ; TO WORDS
+ MOVEI D,(C) ; FIXUP ACCESS
+ IMULI D,5
+ MOVEM D,ACCESS(B) ; AND STORE
+RSUB1: ADDI C,1 ; ACCOUNT FOR EXTRA COUNTERS
+ MOVEM C,(P) ; SAVE FOR LATER
+ MOVEI A,-1(C) ; FOR DOACS
+ MOVEI C,2 ; UPDATE REAL ACCESS
+ SKIPN 0 ; SKIP FOR READB CASE
+ MOVEI C,10.
+ ADDM C,ACCESS(B)
+ PUSHJ P,DOACCS ; DO THE ACCESS
+ PUSH TP,$TUVEC ; SLOT FOR FIXUP BUFFER
+ PUSH TP,C%0
+
+; FOUND OUT IF FIXUPS STAY
+
+ MOVE B,IMQUOTE KEEP-FIXUPS
+ PUSHJ P,ILVAL ; GET VALUE
+ GETYP 0,A
+ MOVE B,5(TB) ; CHANNEL BACK TO B
+ CAIE 0,TUNBOU
+ CAIN 0,TFALSE
+ JRST RSUB4 ; NO, NOT KEEPING FIXUPS
+ PUSH P,C%0 ; SLOT TO READ INTO
+ HRROI A,(P) ; GET LENGTH OF SAME
+ PUSHJ P,DOIOTI
+ POP P,C
+ MOVEI A,(C) ; GET UVECTOR FOR KEEPING
+ ADDM C,(P) ; ACCESS TO END
+ PUSH P,C ; SAVE LENGTH OF FIXUPS
+ PUSHJ P,IBLOCK
+ MOVEM B,-6(TP) ; AND SAVE
+ MOVE A,B ; FOR IOTING THEM IN
+ ADD B,C%11 ; POINT PAST VERS #
+ MOVEM B,(TP)
+ MOVSI C,TUVEC
+ MOVE PVP,PVSTOR+1
+ MOVEM C,ASTO(PVP)
+ MOVE B,5(TB) ; AND CHANNEL
+ PUSHJ P,DOIOTI ; GET THEM
+ MOVE PVP,PVSTOR+1
+ SETZM ASTO(PVP)
+ MOVE A,(TP) ; GET VERS
+ PUSH P,-1(A) ; AND PUSH IT
+ JRST RSUB5
+
+RSUB4: PUSH P,C%0
+ PUSH P,C%0 ; 2 SLOTS FOR READING
+ MOVEI A,-1(P)
+ HRLI A,-2
+ PUSHJ P,DOIOTI
+ MOVE C,-1(P)
+ MOVE D,(P)
+ ADDM C,-2(P) ; NOW -2(P) IS ACCESS TO END OF FIXUPS
+RSUB5: MOVEI C,BUFSTR-1(B) ; FIXUP BUFFER
+ PUSHJ P,BYTDOP
+ SUBI A,2 ; POINT BEFORE D.W.
+ HRLI A,10700
+ MOVEM A,BUFSTR(B)
+ HLLZS BUFSTR-1(B)
+ SKIPE -6(TP)
+ JRST RSUB2A
+ SUBI A,BUFLNT-1 ; ALSO MAKE AN IOT FLAVOR BUFFER
+ HRLI A,-BUFLNT
+ MOVEM A,(TP)
+ MOVSI C,TUVEC
+ MOVE PVP,PVSTOR+1
+ MOVEM C,ASTO(PVP)
+ PUSHJ P,DOIOTI
+ MOVE PVP,PVSTOR+1
+ SETZM ASTO(PVP)
+RSUB2A: PUSH P,-1(P) ; ANOTHER COPY OF LENGTH OF FIXUPS
+
+; LOOP FIXING UP NEW TYPES
+
+RSUB2: PUSHJ P,WRDIN ; SEE WHAT NEXT THING IS
+ JRST RSUB3 ; NO MORE, DONE
+ JUMPL E,STSQ ; MUST BE FIRST SQUOZE
+ MOVNI 0,(E) ; TO UPDATE AMNT OF FIXUPS
+ ADDB 0,(P)
+ HRLI E,(E) ; IS LENGTH OF STRING IN WORDS
+ ADD E,(TP) ; FIXUP BUFFER POINTER
+ JUMPL E,.+3
+ SUB E,[BUFLNT,,BUFLNT]
+ JUMPGE E,.-1 ; STILL NOT RIGHT
+ EXCH E,(TP) ; FIX UP SLOT
+ HLRE C,E ; FIX BYTE POINTER ALSO
+ IMUL C,[-5] ; + CHARS LEFT
+ MOVE B,5(TB) ; CHANNEL
+ PUSH TP,BUFSTR-1(B)
+ PUSH TP,BUFSTR(B)
+ HRRM C,BUFSTR-1(B)
+ HRLI E,440700 ; AND BYTE POINTER
+ MOVEM E,BUFSTR(B)
+ PUSHJ P,NIREAD ; READ ATOM NAME OF TYPE
+ TDZA 0,0 ; FLAG LOSSAGE
+ MOVEI 0,1 ; WINNAGE
+ MOVE C,5(TB) ; RESET BUFFER
+ POP TP,BUFSTR(C)
+ POP TP,BUFSTR-1(C)
+ JUMPE 0,BRSUBR ; BAD READ OF RSUBR
+ GETYP A,A ; A LITTLE CHECKING
+ CAIE A,TATOM
+ JRST BRSUBR
+ PUSHJ P,LSTCHR ; FLUSH REREAD CHAR
+ HRRZ 0,4(TB) ; FIXUP ACCESS PNTR
+ MOVE C,5(TB)
+ MOVE D,ACCESS(C)
+ HLLZS ACCESS-1(C) ; FOR READB HACKER
+ ADDI D,4
+ IDIVI D,5
+ IMULI D,5
+ SKIPN 0
+ MOVEM D,ACCESS(C) ; RESET
+TYFIXE: PUSHJ P,TYPFND ; SEE IF A LEGAL TYPE NAME
+ JRST TYPFIX ; GO SEE USER ABOUT THIS
+ PUSHJ P,FIXCOD ; GO FIX UP THE CODE
+ JRST RSUB2
+
+; NOW FIX UP SUBRS ETC. IF NECESSARY
+
+STSQ: MOVE B,IMQUOTE MUDDLE
+ PUSHJ P,IGVAL ; GET CURRENT VERS
+ CAME B,-1(P) ; SKIP IF NO FIXUPS NEEDED
+ JRST DOFIX0 ; MUST DO THEM
+
+; ALL DONE, ACCESS PAST FIXUPS AND RETURN
+RSUB31: PUSHJ P,SQUKIL ; DONE FIXING UP, KILL SQUOZE TABLE IF IN INTERP
+RSUB3: MOVE A,-3(P)
+ MOVE B,5(TB)
+ MOVEI C,(A) ; UPDATE CHANNEL ACCESS IN CASE SKIPPING
+ HRRZ 0,4(TB) ; READ/READB FLAG
+ SKIPN 0
+ IMULI C,5
+ MOVEM C,ACCESS(B) ; INTO ACCESS SLOT
+ HLLZS ACCESS-1(B)
+ PUSHJ P,DOACCS ; ACCESSED
+ MOVEI C,BUFSTR-1(B) ; FIX UP BUFFER
+ PUSHJ P,BYTDOP
+ SUBI A,2
+ HRLI A,10700
+ MOVEM A,BUFSTR(B)
+ HLLZS BUFSTR-1(B)
+ SKIPN A,-6(TP) ; SKIP IF KEEPING FIXUPS
+ JRST RSUB6
+ PUSH TP,$TUVEC
+ PUSH TP,A
+ MOVSI A,TRSUBR
+ MOVE B,-4(TP)
+ MOVSI C,TATOM
+ MOVE D,IMQUOTE RSUBR
+ PUSHJ P,IPUT ; DO THE ASSOCIATION
+
+RSUB6: MOVE C,-4(TP) ; DO SPECIAL FIXUPS
+ PUSHJ P,SFIX
+ MOVE B,-2(TP) ; GET RSUBR
+ MOVSI A,TRSUBR
+ SUB P,C%44 ; FLUSH P CRUFT
+ SUB TP,[10,,10]
+ JRST RET
+
+; FIXUP SUBRS ETC.
+
+DOFIX0: SKIPN C,-6(TP) ; GET BUFFER IF KEEPING
+ JRST DOFIXE
+ MOVEM B,(C) ; CLOBBER
+ JRST DOFIXE
+
+FIXUPL: PUSHJ P,WRDIN
+ JRST RSUB31
+DOFIXE: JUMPGE E,BRSUBR
+ TLZ E,740000 ; KILL BITS
+IFN KILTV,[
+ CAME E,[SQUOZE 0,DSTO]
+ JRST NOOPV
+ MOVE E,[SQUOZE 40,DSTORE]
+ MOVE A,(TP)
+ SKIPE -6(TP)
+ MOVEM E,-1(A)
+ MOVEI E,53
+ HRLM E,(A)
+ MOVEI E,DSTORE
+ JRST .+3
+NOOPV:
+]
+ PUSHJ P,SQUTOA ; LOOK IT UP
+ PUSHJ P,BRSUB1
+ MOVEI D,(E) ; FOR FIXCOD
+ PUSHJ P,FIXCOD ; FIX 'EM UP
+ JRST FIXUPL
+
+; BAD SQUOZE, BE MORE SPECIFIC
+
+BRSUB1: PUSHJ P,SQSTR
+ PUSH TP,$TATOM
+ PUSH TP,EQUOTE SQUZE-SYMBOL-NOT-FOUND-ERRET CORRECTION
+ PUSH TP,A
+ PUSH TP,B
+ PUSH TP,$TATOM
+ PUSH TP,MQUOTE READ
+ MCALL 3,ERROR
+ GETYP A,A
+ CAIE A,TFIX
+ ERRUUO EQUOTE VALUE-MUST-BE-FIX
+ MOVE E,B
+ POPJ P,
+
+; CONVERT SQUOZE TO A MUDDLE STRING FOR USER
+
+SQSTR: PUSHJ P,SPTT
+ PUSH P,C
+ CAIN B,6 ; 6 chars?
+ PUSH P,D
+ PUSH P,B
+ PUSHJ P,CHMAK
+ POPJ P,
+
+SPTT: SETZB B,C
+ MOVE A,[440700,,C]
+ MOVEI D,0
+
+SPT1: IDIVI E,50
+ PUSH P,F
+ JUMPE E,SPT3
+ PUSHJ P,SPT1
+SPT3: POP P,E
+ ADDI E,"0-1
+ CAILE E,"9
+ ADDI E,"A-"9-1
+ CAILE E,"Z
+ SUBI E,"Z-"#+1
+ CAIN E,"#
+ MOVEI E,".
+ CAIN E,"/
+SPC: MOVEI E,40
+ IDPB E,A
+ ADDI B,1
+ POPJ P,
+
+
+;0 1-12 13-44 45 46 47
+;NULL 0-9 A-Z . $ %
+
+; ROUTINE TO FIXUP ACTUAL CODE
+
+FIXCOD: MOVEI E,0 ; FOR HWRDIN
+ PUSH P,D ; NEW VALUE
+ PUSHJ P,HWRDIN ; GET HW NEEDED
+ MOVE D,(P) ; GET NEW VAL
+ MOVE A,(TP) ; AND BUFFER POINTER
+ SKIPE -6(TP) ; SAVING?
+ HRLM D,-1(A) ; YES, CLOBBER
+ SUB C,(P) ; DIFFERENCE
+ MOVN D,C
+
+FIXLP: PUSHJ P,HWRDIN ; GET AN OFFSET
+ JUMPE C,FIXED
+ HRRES C ; MAKE NEG IF NEC
+ JUMPL C,LHFXUP
+ ADD C,-4(TP) ; POINT INTO CODE
+IFN KILTV,[
+ LDB 0,[220400,,-1(C)] ; GET INDEX FIELD
+ CAIE 0,7
+ JRST NOTV
+KIND: MOVEI 0,0
+ DPB 0,[220400,,-1(C)]
+ JRST DONTV
+NOTV: CAIE 0,6 ; IS IT PVP
+ JRST DONTV
+ HRRZ 0,-1(C)
+ CAIE 0,12 ; OLD DSTO
+ JRST DONTV
+ MOVEI 0,33.
+ ADDM 0,-1(C)
+ JRST KIND
+DONTV:
+]
+ ADDM D,-1(C)
+ JRST FIXLP
+
+LHFXUP: MOVMS C
+ ADD C,-4(TP)
+ MOVSI 0,(D)
+ ADDM 0,-1(C)
+ JRST FIXLP
+
+FIXED: SUB P,C%11
+ POPJ P,
+
+; ROUTINE TO READ A WORD FROM BUFFER
+
+WRDIN: PUSH P,A
+ PUSH P,B
+ SOSG -3(P) ; COUNT IT DOWN
+ JRST WRDIN1
+ AOS -2(P) ; SKIP RETURN
+ MOVE B,5(TB) ; CHANNEL
+ HRRZ A,4(TB) ; READ/READB SW
+ MOVEI E,5
+ SKIPE A
+ MOVEI E,1
+ ADDM E,ACCESS(B)
+ MOVE A,(TP) ; BUFFER
+ MOVE E,(A)
+ AOBJP A,WRDIN2 ; NEED NEW BUFFER
+ MOVEM A,(TP)
+WRDIN1: POP P,B
+ POP P,A
+ POPJ P,
+
+WRDIN2: MOVE B,-3(P) ; IS THIS LAST WORD?
+ SOJLE B,WRDIN1 ; YES, DONT RE-IOT
+ SUB A,[BUFLNT,,BUFLNT]
+ MOVEM A,(TP)
+ MOVSI B,TUVEC
+ MOVE PVP,PVSTOR+1
+ MOVEM B,ASTO(PVP)
+ MOVE B,5(TB)
+ PUSHJ P,DOIOTI
+ MOVE PVP,PVSTOR+1
+ SETZM ASTO(PVP)
+ JRST WRDIN1
+
+; READ IN NEXT HALF WORD
+
+HWRDIN: JUMPN E,NOIOT ; USE EXISTING WORD
+ PUSH P,-3(P) ; FAKE OUT WRDIN IF NEC.
+ PUSHJ P,WRDIN
+ JRST BRSUBR
+ POP P,-4(P) ; RESET COUNTER
+ HLRZ C,E ; RET LH
+ POPJ P,
+
+NOIOT: HRRZ C,E
+ MOVEI E,0
+ POPJ P,
+
+TYPFIX: PUSH TP,$TATOM
+ PUSH TP,EQUOTE BAD-TYPE-NAME
+ PUSH TP,$TATOM
+ PUSH TP,B
+ PUSH TP,$TATOM
+ PUSH TP,EQUOTE ERRET-TYPE-NAME-DESIRED
+ MCALL 3,ERROR
+ JRST TYFIXE
+
+BRSUBR: ERRUUO EQUOTE RSUBR-IN-BAD-FORMAT
+\f
+
+
+;TABLE OF BYTE POINTERS FOR GETTING CHARS
+
+BYTPNT": 350700,,CHTBL(A)
+ 260700,,CHTBL(A)
+ 170700,,CHTBL(A)
+ 100700,,CHTBL(A)
+ 010700,,CHTBL(A)
+
+;HERE ARE THE TABLES OF CHXRACTERS (NOTE EVERYTHING NOT SPECIFIED IS
+;IN THE NUMBER LETTER CATAGORY)
+
+CHROFF==0 ; USED FOR ! HACKS
+SETCHR NUMCOD,[0123456789]
+
+SETCHR PLUCOD,[+]
+
+SETCHR NEGCOD,[-]
+
+SETCHR ASTCOD,[*]
+
+SETCHR DOTTYP,[.]
+
+SETCHR ETYPE,[Ee]
+
+SETCOD SPATYP,[0,15,12,11,14,40,33] ;ALL ARE TYPE 2 (SPACING - FF,TAB,SPACE,ALT-MODE)
+
+INCRCH LPATYP,[()[]'%"\#<>] ;GIVE THESE INCREASRNG CODES FROM 3
+
+SETCOD EOFTYP,[3] ;^C - EOF CHARACTER
+
+SETCOD SPATYP,[32] ;^Z - TENEX/TOPS-20 EOF (SET IN BOTH TO BE CONSISTENT)
+
+INCRCH COMTYP,[;,{}!] ;COMMENT AND GLOBAL VALUE AND SPECIAL
+
+CHROFF==200 ; CODED AS HAVING 200 ADDED
+
+INCRCH EXCEXC,[!.[]'"<>,-\]
+
+SETCOD MANYT,[33]
+
+CHTBL:
+ OUTTBL ;OUTPUT THE TABLE RIGHT HERE
+
+
+\f; THIS CODE FLUSHES WANDERING COMMENTS
+
+COMNT: PUSHJ P,IREAD
+ JRST COMNT2
+ JRST BDLP
+
+COMNT2: SKIPL A,5(TB) ; RESTORE CHANNEL
+ MOVEI A,5(TB)-LSTCH ;NO CHANNEL, POINT AT SLOT
+ HRRM B,LSTCH(A) ; CLOBBER IN CHAR
+ PUSHJ P,ERRPAR
+ JRST BDLP
+\f
+
+;HERE TO SET UP FOR .FOO ..FOO OR.<ABC>
+
+DOTSTR: PUSHJ P,NXTCH1 ; GOBBLE A NEW CHARACTER
+ MOVEI FF,FRSDOT+DOTSEN+NUMWIN ; SET FLAG IN CASE
+ CAIN B,NUMCOD ; SKIP IF NOT NUMERIC
+ JRST DOTST1 ; NUMERIC, COULD BE FLONUM
+
+; CODE TO HANDLE ALL IMPLICIT CALLS I.E. QUOTE, LVAL, GVAL
+
+ TRZ FF,NUMWIN ; WE ARE NOT A NUMBER
+ MOVSI B,TFORM ; LVAL
+ MOVE A,IMQUOTE LVAL
+ JRST IMPCA1
+
+GLOSEG: SKIPA B,$TSEG ;SEG CALL TO GVAL
+GLOVAL: MOVSI B,TFORM ;FORM CALL TO SAME
+ MOVE A,IMQUOTE GVAL
+ JRST IMPCAL
+
+QUOSEG: SKIPA B,$TSEG ;SEG CALL TO QUOTE
+QUOTIT: MOVSI B,TFORM
+ MOVE A,IMQUOTE QUOTE
+ JRST IMPCAL
+
+SEGDOT: MOVSI B,TSEG ;SEG CALL TO LVAL
+ MOVE A,IMQUOTE LVAL
+IMPCAL: PUSHJ P,LSTCHR ;FLUSH LAST CHAR EXCEPT
+IMPCA1: PUSH TP,$TATOM ;FOR .FOO FLAVOR
+ PUSH TP,A ;PUSH ARGS
+ PUSH P,B ;SAVE TYPE
+ PUSHJ P,IREAD1 ;READ
+ JRST USENIL ; IF NO ARG, USE NIL
+IMPCA2: PUSH TP,C
+ PUSH TP,D
+ MOVE C,A ; GET READ THING
+ MOVE D,B
+ PUSHJ P,INCONS ; CONS TO NIL
+ MOVEI E,(B) ; PREPARE TON CONS ON
+POPARE: POP TP,D ; GET ATOM BACK
+ POP TP,C
+ EXCH C,-1(TP) ; SAVE THAT COMMENT
+ EXCH D,(TP)
+ PUSHJ P,ICONS
+ POP P,A ;GET FINAL TYPE
+ JRST RET13 ;AND RETURN
+
+
+USENIL: PUSH TP,C
+ PUSH TP,D
+ SKIPL A,5(TB) ; RESTOR LAST CHR
+ MOVEI A,5(TB)-LSTCH ;NO CHANNEL, POINT AT SLOT
+ HRRM B,LSTCH(A)
+ MOVEI E,0
+ JRST POPARE
+\f
+;HERE AFTER READING ATOM TO CALL VALUE
+
+.SET: PUSH P,$TFORM ;GET WINNING TYPE
+ MOVE E,(P)
+ PUSHJ P,RETC ; CHECK FOR POSSIBLE COMMENT
+ PUSH TP,$TATOM
+ PUSH TP,IMQUOTE LVAL
+ JRST IMPCA2 ;GO CONS LIST
+
+LOOPA: PUSH P,FF ; SAVE FLAGS IN CASE .ATOM
+LOOPAT: PUSHJ P,NXTCH ; CHECK FOR TRAILER
+ CAIN B,PATHTY ; PATH BEGINNER
+ JRST PATH0 ; YES, GO PROCESS
+ CAIN B,SPATYP ; SPACER?
+ PUSHJ P,SPACEQ ; CHECK FOR REAL SPACE
+ JRST PATH2
+ PUSHJ P,LSTCHR ; FLUSH IT AND RETRY
+ JRST LOOPAT
+PATH0: PUSHJ P,NXTCH1 ; READ FORCED NEXT
+ CAIE B,SPCTYP ; DO #FALSE () HACK
+ CAIN B,ESCTYP
+ JRST PATH4
+ CAIL B,SPATYP ; SPACER?
+ JRST PATH3 ; YES, USE THE ROOT OBLIST
+PATH4: PUSHJ P,NIREA1 ; READ NEXT ITEM
+ PUSHJ P,ERRPAR ; LOSER
+ CAME A,$TATOM ; ONLY ALLOW ATOMS
+ JRST BADPAT
+
+ PUSH TP,A
+ PUSH TP,B
+ MOVSI C,TATOM
+ MOVE D,IMQUOTE OBLIST
+ PUSHJ P,IGET ; GET THE OBLIST
+ ; IF NOT OBLIST, MAKE ONE
+ JUMPN B,PATH6
+ MCALL 1,MOBLIS ; MAKE ONE
+ JRST PATH1
+
+PATH6: SUB TP,C%22
+ JRST PATH1
+
+
+PATH3: MOVE B,ROOT+1 ; GET ROOT OBLIST
+ MOVSI A,TOBLS
+PATH1: POP P,FF ; FLAGS
+ TRNE FF,FRSDOT
+ JRST PATH.
+ PUSHJ P,RLOOKU ; AND LOOK IT UP
+
+ JRST RET
+
+PATH.: PUSHJ P,RLOOKU
+ JRST .SET ; CONS AN LVAL FORM
+
+SPACEQ: ANDI A,-1
+ CAIE A,33
+ CAIN A,400033
+ POPJ P,
+ CAIE A,3
+ AOS (P)
+ POPJ P,
+\f
+
+PATH2: MOVE B,IMQUOTE OBLIST
+ PUSHJ P,IDVAL
+ JRST PATH1
+
+BADPAT: ERRUUO EQUOTE NON-ATOMIC-OBLIST-NAME
+
+\f
+
+; HERE TO READ ONE CHARACTER FOR USER.
+
+CREDC1: SUBM M,(P)
+ PUSH TP,A
+ PUSH TP,B
+ PUSHJ P,IREADC
+ JRST CRDEO1
+ JRST RMPOPJ
+
+CNXTC1: SUBM M,(P)
+ PUSH TP,A
+ PUSH TP,B
+ PUSHJ P,INXTRD
+ JRST CRDEO1
+ JRST RMPOPJ
+
+CRDEO1: MOVE B,(TP)
+ PUSH TP,EOFCND-1(B)
+ PUSH TP,EOFCND(B)
+ PUSH TP,$TCHAN
+ PUSH TP,B
+ MCALL 1,FCLOSE
+ MCALL 1,EVAL
+ JRST RMPOPJ
+
+
+CREADC: SUBM M,(P)
+ PUSH TP,A
+ PUSH TP,B
+ PUSHJ P,IREADC
+ JRST CRDEOF
+ SOS (P)
+ JRST RMPOPJ
+
+CNXTCH: SUBM M,(P)
+ PUSH TP,A
+ PUSH TP,B
+ PUSHJ P,INXTRD
+ JRST CRDEOF
+ SOS (P)
+RMPOPJ: SUB TP,C%22
+ JRST MPOPJ
+
+CRDEOF: .MCALL 1,FCLOSE
+ MOVSI A,TCHRS
+ HRROI B,3
+ JRST MPOPJ
+
+INXTRD: TDZA E,E
+IREADC: MOVEI E,1
+ MOVE B,(TP) ; CHANNEL
+ HRRZ A,-2(B) ; GET BLESS BITS
+ TRNE A,C.BIN
+ TRNE A,C.BUF
+ JRST .+3
+ PUSHJ P,GRB
+ HRRZ A,-2(B)
+ TRC A,C.OPN+C.READ
+ TRNE A,C.OPN+C.READ
+ JRST BADCHN
+ SKIPN A,LSTCH(B)
+ PUSHJ P,RXCT
+ TLO A,200000
+ MOVEM A,LSTCH(B) ; SAVE CHAR
+ CAMN A,C%M1 ; [-1] ; SPECIAL PSEUDO TTY HACK?
+ JRST PSEUDO ; YES, RET AS FIX
+; ANDI A,-1
+ TLZ A,200000
+ TRZN A,400000 ; UNDO ! HACK
+ JRST NOEXCL
+ SKIPE E
+ MOVEM A,LSTCH(B)
+ MOVEI A,"! ; RETURN AN !
+NOEXC1: SKIPGE B,A ; CHECK EOF
+ SOS (P) ; DO EOF RETURN
+ MOVE B,A ; CHAR TO B
+ MOVSI A,TCHRS
+PSEUD1: AOS (P)
+ POPJ P,
+
+PSEUDO: MOVE F,B
+ SKIPE E
+ PUSHJ P,LSTCH2
+ MOVE B,A
+ MOVSI A,TFIX
+ JRST PSEUD1
+
+NOEXCL: JUMPE E,NOEXC1
+ MOVE F,B
+ PUSHJ P,LSTCH2
+ JRST NOEXC1
+
+; READER ERRORS COME HERE
+
+ERRPAR: PUSH TP,$TCHRS ;DO THE OFFENDER
+ PUSH TP,B
+ PUSH TP,$TCHRS
+ PUSH TP,[40] ;SPACE
+ PUSH TP,$TCHSTR
+ PUSH TP,CHQUOT UNEXPECTED
+ JRST MISMA1
+
+;COMPLAIN ABOUT MISMATCHED CLOSINGS
+
+MISMAB: SKIPA A,["]]
+MISMAT: MOVE A,-1(P) ;GOBBLE THE DESIRED CHARACTER
+ JUMPE B,CPOPJ ;IGNORE UNIVERSAL CLOSE
+ PUSH TP,$TCHRS
+ PUSH TP,B
+ PUSH TP,$TCHSTR
+ PUSH TP,CHQUOT [ INSTEAD-OF ]
+ PUSH TP,$TCHRS
+ PUSH TP,A
+MISMA1: MCALL 3,STRING
+ PUSH TP,$TATOM
+ PUSH TP,EQUOTE READER-SYNTAX-ERROR-ERRET-ANYTHING-TO-GO-ON
+ PUSH TP,A
+ PUSH TP,B
+ PUSH TP,$TATOM
+ PUSH TP,MQUOTE READ
+ MCALL 3,ERROR
+CPOPJ: POPJ P,
+\f
+; HERE ON BAD INPUT CHARACTER
+
+BADCHR: ERRUUO EQUOTE BAD-ASCII-CHARACTER
+
+; HERE ON YUCKY PARSE TABLE
+
+BADPTB: ERRUUO EQUOTE BAD-MACRO-TABLE
+
+BDPSTR: ERRUUO EQUOTE BAD-PARSE-STRING
+
+ILLSQG: PUSHJ P,LSTCHR ; DON'T MESS WITH IT AGAIN
+ ERRUUO EQUOTE BAD-USE-OF-SQUIGGLY-BRACKETS
+
+
+;FLOATING POINT NUMBER TOO LARGE OR SMALL
+FOOR: ERRUUO EQUOTE NUMBER-OUT-OF-RANGE
+
+
+NILSXP: 0,,0
+
+LSTCHR: SKIPL F,5(TB) ;GET CHANNEL
+ JRST LSTCH1 ;NO CHANNEL, POINT AT SLOT
+
+LSTCH2: SKIPE LSTCH(F) ;ARE WE REALLY FLUSHING A REUSE CHARACTER ?
+ PUSHJ P,CNTACX
+ SETZM LSTCH(F)
+ POPJ P,
+
+LSTCH1: SETZM 5(TB) ;ZERO THE LETTER AND RETURN
+ POPJ P,
+
+CNTACC: MOVE F,B
+CNTACX: HRRZ G,-2(F) ; GET BITS
+ TRNE G,C.BIN
+ JRST CNTBIN
+ AOS ACCESS(F)
+CNTDON: POPJ P,
+
+CNTBIN: AOS G,ACCESS-1(F)
+ CAMN G,[TFIX,,1]
+ AOS ACCESS(F)
+ CAMN G,[TFIX,,5]
+ HLLZS ACCESS-1(F)
+ POPJ P,
+
+
+;TABLE OF NAMES OF ARGS AND ALLOWED TYPES
+
+ARGS:
+ IRP A,,[[[CAIN C,TUNBOU]],[[CAIE C,TCHAN],INCHAN],[[PUSHJ P,CHOBL],OBLIST]]
+ IRP B,C,[A]
+ B
+ IFSN [C],IMQUOTE C
+ .ISTOP
+ TERMIN
+ TERMIN
+
+CHOBL: CAIE C,TLIST ;A LIST OR AN OBLIST
+ CAIN C,TOBLS
+ AOS (P)
+ POPJ P,
+
+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
+
+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
+
+ HLRZ A,IJFNS ; CLOSE AGC
+ CLOSF
+ JFCL
+ HRRZ A,IJFNS ; CLOSE INTERPRETER
+ CLOSF
+ JFCL
+ HLRZ A,IJFNS1 ; CLOSE SGC
+ CLOSF
+ JFCL
+
+ HRRZ A,IJFNS1
+ CLOSF
+ JFCL
+
+ SETZM IJFNS
+ SETZM IJFNS1
+]
+ PUSHJ P,PURCLN ; DONT KEEP PURE SHAREDNESS
+
+ POP P,E
+IFE ITS,[
+ 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*2,,CHNL1] ; POINT TO REAL CHANNELS SLOTS
+ PUSH TP,$TVEC
+ PUSH TP,C
+ PUSH P,[N.CHNS]
+
+CHNLP: HRRZ A,(C) ; SEE IF NEW VALUE
+ JUMPN 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
+ 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)
+ SETZM (C)-1
+CHNLO2: MOVEI B,[ASCIZ /
+CHANNEL-NOT-RESTORED
+/]
+ JRST MSGTYP"
+
+
+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,
+
+
+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*2,,CHNL1] ; POINT TO REAL CHANNELS SLOTS
+ PUSH TP,$TVEC
+ PUSH TP,C
+ PUSH P,[N.CHNS]
+
+CHNLP: HRRZ A,(C) ; SEE IF NEW VALUE
+ JUMPN 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
+ 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)
+ SETZM (C)-1
+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 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*2,,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
+ 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 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*2,,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
+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
+ 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 SECAGC MUDDLE GARBAGE COLLECTOR FOR MULTI SECTIONS
+
+;SYSTEM WIDE DEFINITIONS GO HERE
+
+RELOCATABLE
+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
+CONN INT:
+RENAME MDLXXX.EXE MDL106.EXE
+
+RENAME MDLXXX.SYMBOLS MDL106.SYMBOLS
+
+NDDT
+;YMDL106.EXE
+;O
+MUDSTR+2/\e0"106^?^?\e
+\eP;UMDL106.EXE
+;H
+RES .
+CONN MDL:
+NDDT
+;YINT:MDL106.EXE
+;OINT:MDL106.SYMBOLS
+\eG<SAVE "PS:<MDL>M106UNI.SAVE">\e<FLOAD "MDL:NEWMUD">\e
+<FOO>\e;HCONN INT:
+CONT
+;UMDL106.EXE
+;H
+LOGOUT
--- /dev/null
+TITLE SPECS FOR MUDDLE
+
+RELOCA
+
+MAIN==1
+.GLOBAL TYPVLC,PBASE,TYPBOT,MAINPR,PTIME,IDPROC,ROOT,TTICHN,TTOCHN,TYPVEC
+.GLOBAL %UNAM,%JNAM,NOTTY,GCHAPN,INTHLD,PURBOT,PURTOP,N.CHNS,SPCCHK,CURFCN
+.GLOBAL TD.GET,TD.PUT,TD.LNT,NOSHUF,GLOTOP,RSTACK,RCYCHN,START,TVSTRT,REALTV
+.GLOBAL IJFNS,IJFNS1,SJFNS,OPSYS,HASHTB,MULTSG,PURBTB,NSEGS
+
+.INSRT MUDDLE >
+
+SYSQ
+
+CONSTANTS
+
+IFN ITS,[
+ N.CHNS==16.
+ FATINS==.VALUE
+]
+IFE ITS,[
+ N.CHNS==102
+]
+
+IMPURE
+
+LOC100: JRST START
+IFN ITS,[
+%UNAM: 0 ; HOLDS UNAME
+%JNAM: 0 ; HOLDS JNAME
+OPSYS: -1 ; MINUS ONE (-1) IF ITS
+RLTSAV: -1 ; SAVED ARG TO REALTIMER
+]
+IFE ITS,[
+IJFNS: 0 ; AGCS JFN,,MUDDLE'S JFN
+IJFNS1: 0 ; SGCS JFN
+SJFNS: 0 ; SQUOZE JFN,,SAVE JFN
+OPSYS: 0 ; ZERO IF TOPS20, ONE IF TENEX
+MULTSG: 0 ; NON-ZERO MEANS TRYING TO USE MULTI SEG STUFF
+NSEGS: MAXSEG
+PURBTB: REPEAT MAXSEG,HIBOT
+]
+IDPROC: 0 ; ENVIRONMENT NUMBER GENERATOR
+PTIME: 0 ; UNIQUE NUMBER FOR PROCID AND ENVIRONMENTS
+OBLNT": 13. ; LENGTH OF DEFAULT OBLISTS (SMALL)
+PARTOP":
+GCSTOP":
+VECTOP": VECLOC ; TOP OF CURRENT GARBAGE COLLECTED SPACE
+GCSBOT":
+PARBOT":
+VECBOT": PARBASE ; BOTTOM OF GARBAGE COLLECTED SPACE
+FRETOP": 120000
+CODBOT: 0 ; ABSOLUTE BOTTOM OF CODE
+CODTOP": PARBASE ; TOP OF IMPURE CODE (INCLUDING "STORAGE")
+HITOP: 0 ; TOP OF INTERPRETER PURE CORE
+GCSNEW":
+PARNEW":
+VECNEW": 0 ; LOCATION FOR OFFSET BETWWEN OLD GCSTOP AND NEW GCSTOP
+INTFLG: 0 ; INTERRUPT PENDING FLAG
+MAINPR: 0 ; HOLDS POINTER TO THE MAIN PROCESS
+NOTTY: 0 ; NON-ZERO==> THIS MUDDLE HAS NO TTY
+GCHAPN: 0 ; NON-ZERO A GC HAS HAPPENED RECENTLY
+INTHLD: 0 ; NON-ZERO INTERRUPTS CANT HAPPEN
+PURBOT: HIBOT ; BOTTOM OF DYNAMICALLY ALLOCATED PURE
+PURTOP: HIBOT ; TOP OF DYNAMICALLY ALLOCATED PURE
+SPCCHK: SETZ ; SPECIAL/UNSPECIAL CHECKING?
+NOSHUF: 0 ; FLAG TO BUILD A NON MOVING HI SEG
+
+;PAGE MAP USAGE TABLE FOR MUDDLE
+;EACH PAGE IS REPRESENTED BY ONE BIT IN THE TABLE
+;IF BIT = 0 THEN PAGE IS FREE OTHERWISE BUSY
+;FOR PAGE n USE BIT (n MOD 32.) IN WORD PMAP+n/32.
+PMAPB": 525252,,525252 ;SECTION 0 -- BELONGS TO AGC
+ 525252,,525252
+ 525252,,525252 ;SECTION 1 -- BELONGS TO AGC
+ 525252,,525252
+ 525252,,525252 ;SECTION 2 -- BELONGS TO AGC
+ 525252,,525252
+ 525252,,525252 ;SECTION 3 -- BELONGS TO AGC
+ 525252,,525252
+ 525252,,525252 ;SECTION 4 -- BELONGS TO AGC
+ 525252,,525252
+ 525252,,525252 ;SECTION 5 -- BELONGS TO AGC (DEPENDS ON HIBOT)
+ 525252,,525252
+ 525252,,525252 ;SECTION 6 -- START OF PURE CORE (FILLED IN BY INITM)
+ 525252,,525252
+ 525252,,525252
+ 525252,,525252
+
+NINT==72. ; NUMBER OF POSSIBLE ITS INTERRUPTS
+NASOCS==159. ; LENGTH OF ASSOCIATION VECTOR
+PDLBUF==100 ; EXTRA INSURENCE PDL
+ASOLNT==10 ; LENGTH OF ASSOCIATION BLOCKS
+
+
+.GLOBAL PATCH,TBINIT,LERR,LPROG,PIDSTO,PROCID,PTIME,GCPDL,INTFLG,WTYP1,WTYP2
+.GLOBAL PAT,PDLBUF,INTINT,PARNEW,GCPVP,START,SWAP,ICR,SPBASE,TPBASE,GLOBAS,GLOBSP,TPBAS
+.GLOBAL GCSBOT,GCSTOP,FRETOP,GCSNEW,TD.AGC,SPSTOR,PVSTOR
+.GLOBAL TOPLEVEL,INTNUM,INTVEC,INTOBL,ASOVEC,ERROBL,MAINPR,RESFUN,.BLOCK,ASOLNT,NODES
+.GLOBAL WRONGT,TTYOPE,OPEN,CLOSE,IOT,ILVAL,MESS,FACTI,REFVEC,MUDOBL,INITIA
+.GLOBAL LSTRES,BINDID,DUMNOD,PSTAT,1STEPR,IDPROC,EVATYP,APLTYP,PRNTYP,PURVEC,STOLST
+
+TVSTRT==1400 ; THIS SHOULD BE LARGE ENOUGH SO THAT WE HAVE ENOUGH
+ ; ROOM FOR INITAL FREE STORAGE
+
+
+VECTGO
+TVBASE": BLOCK TVLNT
+ GENERAL
+ TVLNT+2,,0
+TVLOC==TVBASE
+
+
+
+;INITIAL TYPE TABLE
+
+TYPVLC":
+ BLOCK 2*NUMPRI+2
+ GENERAL
+ 2*NUMPRI+2+2,,0
+
+TYPTP==.-2 ; POINT TO TOP OF TYPES
+
+; INITIAL SYMBOL TABEL FOR RSUBRS
+
+SQULOC==.
+SQUTBL: BLOCK 2*NSUBRS
+ TWORD,,0
+ 2*NSUBRS+2,,0
+
+INTVCL: BLOCK 2*NINT
+ TLIST,,0
+ 2*NINT+2,,0
+
+NODLST: TTP,,0
+ 0
+ TASOC,,0
+ BLOCK ASOLNT-3
+ GENERAL+<SASOC,,0>
+ ASOLNT+2,,0
+
+NODDUM: BLOCK ASOLNT
+ GENERAL+<SASOC,,0>
+ ASOLNT+2,,0
+
+
+
+ASOVCL: BLOCK NASOCS
+ TASOC,,0
+ NASOCS+2,,0
+
+
+
+;THESE ENTRIES MUST NOT MOVE DURING INITILAIZATION
+
+ADDTV TVEC,[-2*NUMPRI-2,,TYPVLC]
+TYPVEC==TVOFF+TVSTRT-1
+
+ADDTV TVEC,[-2*NUMPRI-2,,TYPVLC]
+TYPBOT==TVOFF+TVSTRT-1 ; POINT TO CURRENT TOP OF TYPE VECTORS
+
+;ENTRY FOR ROOT,TTICHN,TTOCHN
+
+ADDTV TCHAN,0
+TTICHN==TVOFF+TVSTRT-1
+
+ADDTV TCHAN,0
+TTOCHN==TVOFF+TVSTRT-1
+
+ADDTV TOBLS,0
+ROOT==TVOFF+TVSTRT-1
+ADDTV TOBLS,0
+INITIA==TVOFF+TVSTRT-1
+ADDTV TOBLS,0
+INTOBL==TVOFF+TVSTRT-1
+ADDTV TOBLS,0
+ERROBL==TVOFF+TVSTRT-1
+ADDTV TOBLS,0
+MUDOBL==TVOFF+TVSTRT-1
+ADDTV TVEC,0
+GRAPHS==TVOFF+TVSTRT-1
+ADDTV TFIX,0
+INTNUM==TVOFF+TVSTRT-1
+ADDTV TVEC,[-2*NINT,,INTVCL]
+INTVEC==TVOFF+TVSTRT-1
+ADDTV TUVEC,[-NASOCS,,ASOVCL]
+ASOVEC==TVOFF+TVSTRT-1
+ADDTV TSP,0
+SPSTOR==TVOFF+TVSTRT-1
+ADDTV TPVP,0
+PVSTOR==TVOFF+TVSTRT-1
+ADDTV TUVEC,0
+HASHTB==TVOFF+TVSTRT-1
+ADDTV TLIST,0
+CHNL0"==TVOFF+TVSTRT-1 ;LIST FOR CURRENTLY OPEN PSUEDO CHANNELS
+
+
+IFN ITS,[
+DEFINE ADDCHN N
+ ADDTV TCHAN,0
+ CHNL!N==TVOFF+TVSTRT-1
+ .GLOBAL CHNL!N
+ TERMIN
+
+REPEAT 15.,ADDCHN \.RPCNT+1
+
+DEFINE ADDIPC N
+ ADDTV TLIST,0
+ IPCS!N==TVOFF+TVSTRT-1
+ .GLOBAL IPCS!N
+ TERMIN
+
+REPEAT 15.,ADDIPC \.RPCNT+1
+]
+
+IFE ITS,[
+ADDTV TCHAN,0
+CHNL1==TVOFF+TVSTRT-1
+.GLOBAL CHNL1
+REPEAT N.CHNS-1,[ADDTV TCHAN,0
+]
+]
+
+ADDTV TASOC,[-ASOLNT,,NODLST]
+NODES==TVOFF+TVSTRT-1
+
+ADDTV TASOC,[-ASOLNT,,NODDUM]
+DUMNOD==TVOFF+TVSTRT-1
+
+ADDTV TVEC,0
+EVATYP==TVOFF+TVSTRT-1
+
+ADDTV TVEC,0
+APLTYP==TVOFF+TVSTRT-1
+
+ADDTV TVEC,0
+PRNTYP==TVOFF+TVSTRT-1
+
+; SLOTS ASSOCIATED WITH TEMPLATE DATA STRUCTURES
+
+ADDTV TUVEC,0
+TD.GET==TVOFF+TVSTRT-1
+
+ADDTV TUVEC,0
+TD.PUT==TVOFF+TVSTRT-1
+
+ADDTV TUVEC,0
+TD.AGC==TVOFF+TVSTRT-1
+
+ADDTV TUVEC,0
+TD.LNT==TVOFF+TVSTRT-1
+
+ADDTV TUVEC,0
+TD.PTY==TVOFF+TVSTRT-1
+
+ADDTV TCHAN,0
+RCYCHN==TVOFF+TVSTRT-1
+
+
+;GLOBAL SPECIAL PDL
+
+GSP: BLOCK GSPLNT
+ GENERAL
+ GSPLNT+2,,0
+
+ADDTV TVEC,[-GSPLNT,,GSP]
+GLOBASE==TVOFF+TVSTRT-1
+GLOB==.-2
+ADDTV TVEC,GLOB
+GLOBSP==TVOFF+TVSTRT-1 ;ENTRY FOR CURRENT POINTER TO GLOBAL SP
+
+; POINTER VECTOR TO PURE SHARED RSUBRS
+
+PURV: BLOCK 3*20. ; ENOUGH FOR 20 SUCH (INITIALLY)
+ 0
+ 3*20.+2,,0
+
+ADDTV TUVEC,[-3*20.,,PURV]
+PURVEC==TVOFF+TVSTRT-1
+
+ADDTV TLIST,0
+STOLST==TVOFF+TVSTRT-1
+
+ADDTV TVEC,GLOB
+GLOTOP==TVOFF+TVSTRT-1
+
+;PROCESS VECTOR FOR GARBAGE COLLECTOR PROCESS
+
+GCPVP: BLOCK PVLNT*2
+ GENERAL
+ PVLNT*2+2,,0
+
+
+VECRET
+
+PURE
+
+;INITIAL PROCESS VECTOR
+
+PVBASE": BLOCK PVLNT*2
+ GENERAL
+ PVLNT*2+2,,0
+PVLOC==PVBASE
+
+
+;ENTRY FOR PROCESS I.D.
+
+ ADDPV TFIX,1,PROCID
+;THE FOLLOWING IRP MAKES SPACE FO9 SAVED ACS
+
+ZZZ==.
+
+IRP A,,[0,A,B,C,D,E,PVP,TVP,FRM,AB,TB,TP,SP,M,R,P]B,,[0
+0,0,0,0,0,0,0,TTP,TAB,TTB,TTP,0,TCODE,TRSUBR,TPDL]
+
+LOC PVLOC+2*A
+A!STO==.-PVBASE
+B,,0
+0
+TERMIN
+
+PVLOC==PVLOC+16.*2
+LOC ZZZ
+
+
+ADDPV TTB,0,TBINIT
+ADDPV TTP,0,TPBASE
+ADDPV TSP,0,SPBASE
+ADDPV TPDL,0,PBASE
+ADDPV 0,0,RESFUN
+ADDPV TLIST,0,.BLOCK
+ADDPV TLIST,0,MESS
+ADDPV TACT,0,FACTI
+ADDPV TPVP,0,LSTRES
+ADDPV TFIX,0,BINDID
+ADDPV TFIX,1,PSTAT
+ADDPV TPVP,0,1STEPR
+ADDPV TSP,0,CURFCN
+ADDPV TTVP,0,REALTV
+
+
+
+IMPURE
+
+END
--- /dev/null
+TITLE SPECS FOR MUDDLE
+
+RELOCA
+
+MAIN==1
+.GLOBAL TYPVLC,PBASE,TYPBOT,MAINPR,PTIME,IDPROC,ROOT,TTICHN,TTOCHN,TYPVEC
+.GLOBAL %UNAM,%JNAM,NOTTY,GCHAPN,INTHLD,PURBOT,PURTOP,N.CHNS,SPCCHK,CURFCN
+.GLOBAL TD.GET,TD.PUT,TD.LNT,NOSHUF,GLOTOP,RSTACK,RCYCHN,START,TVSTRT,REALTV
+.GLOBAL IJFNS,IJFNS1,SJFNS,OPSYS,HASHTB,MULTSG,PURBTB,NSEGS,NOATMS,NOSETG,NOSET
+
+.INSRT MUDDLE >
+
+SYSQ
+
+CONSTANTS
+
+IFN ITS,[
+ N.CHNS==16.
+ FATINS==.VALUE
+]
+IFE ITS,[
+ N.CHNS==102
+]
+
+IMPURE
+
+LOC100: JRST START
+IFN ITS,[
+%UNAM: 0 ; HOLDS UNAME
+%JNAM: 0 ; HOLDS JNAME
+OPSYS: -1 ; MINUS ONE (-1) IF ITS
+RLTSAV: -1 ; SAVED ARG TO REALTIMER
+]
+IFE ITS,[
+IJFNS: 0 ; AGCS JFN,,MUDDLE'S JFN
+IJFNS1: 0 ; SGCS JFN
+SJFNS: 0 ; SQUOZE JFN,,SAVE JFN
+OPSYS: 0 ; ZERO IF TOPS20, ONE IF TENEX
+MULTSG: 0 ; NON-ZERO MEANS TRYING TO USE MULTI SEG STUFF
+NSEGS: MAXSEG
+PURBTB: REPEAT MAXSEG,HIBOT
+]
+IDPROC: 0 ; ENVIRONMENT NUMBER GENERATOR
+PTIME: 0 ; UNIQUE NUMBER FOR PROCID AND ENVIRONMENTS
+OBLNT": 13. ; LENGTH OF DEFAULT OBLISTS (SMALL)
+PARTOP":
+GCSTOP":
+VECTOP": VECLOC ; TOP OF CURRENT GARBAGE COLLECTED SPACE
+GCSBOT":
+PARBOT":
+VECBOT": PARBASE ; BOTTOM OF GARBAGE COLLECTED SPACE
+FRETOP": 120000
+CODBOT: 0 ; ABSOLUTE BOTTOM OF CODE
+CODTOP": PARBASE ; TOP OF IMPURE CODE (INCLUDING "STORAGE")
+HITOP: 0 ; TOP OF INTERPRETER PURE CORE
+GCSNEW":
+PARNEW":
+VECNEW": 0 ; LOCATION FOR OFFSET BETWWEN OLD GCSTOP AND NEW GCSTOP
+INTFLG: 0 ; INTERRUPT PENDING FLAG
+MAINPR: 0 ; HOLDS POINTER TO THE MAIN PROCESS
+NOTTY: 0 ; NON-ZERO==> THIS MUDDLE HAS NO TTY
+GCHAPN: 0 ; NON-ZERO A GC HAS HAPPENED RECENTLY
+INTHLD: 0 ; NON-ZERO INTERRUPTS CANT HAPPEN
+PURBOT: HIBOT ; BOTTOM OF DYNAMICALLY ALLOCATED PURE
+PURTOP: HIBOT ; TOP OF DYNAMICALLY ALLOCATED PURE
+SPCCHK: SETZ ; SPECIAL/UNSPECIAL CHECKING?
+NOSHUF: 0 ; FLAG TO BUILD A NON MOVING HI SEG
+NOATMS: 0 ; FLAG DISALLOWING CREATION OF NEW ATOMS
+NOSETG: 0 ; FLAG DISALLOWING AUTO-CREATE OF GBINDS
+NOSET: 0 ; FLAG DISALLOWING AUTO-CREATE OF BINDINGS
+;PAGE MAP USAGE TABLE FOR MUDDLE
+;EACH PAGE IS REPRESENTED BY ONE BIT IN THE TABLE
+;IF BIT = 0 THEN PAGE IS FREE OTHERWISE BUSY
+;FOR PAGE n USE BIT (n MOD 32.) IN WORD PMAP+n/32.
+PMAPB": 525252,,525252 ;SECTION 0 -- BELONGS TO AGC
+ 525252,,525252
+ 525252,,525252 ;SECTION 1 -- BELONGS TO AGC
+ 525252,,525252
+ 525252,,525252 ;SECTION 2 -- BELONGS TO AGC
+ 525252,,525252
+ 525252,,525252 ;SECTION 3 -- BELONGS TO AGC
+ 525252,,525252
+ 525252,,525252 ;SECTION 4 -- BELONGS TO AGC
+ 525252,,525252
+ 525252,,525252 ;SECTION 5 -- BELONGS TO AGC (DEPENDS ON HIBOT)
+ 525252,,525252
+ 525252,,525252 ;SECTION 6 -- START OF PURE CORE (FILLED IN BY INITM)
+ 525252,,525252
+ 525252,,525252
+ 525252,,525252
+
+NINT==72. ; NUMBER OF POSSIBLE ITS INTERRUPTS
+NASOCS==159. ; LENGTH OF ASSOCIATION VECTOR
+PDLBUF==100 ; EXTRA INSURENCE PDL
+ASOLNT==10 ; LENGTH OF ASSOCIATION BLOCKS
+
+
+.GLOBAL PATCH,TBINIT,LERR,LPROG,PIDSTO,PROCID,PTIME,GCPDL,INTFLG,WTYP1,WTYP2
+.GLOBAL PAT,PDLBUF,INTINT,PARNEW,GCPVP,START,SWAP,ICR,SPBASE,TPBASE,GLOBAS,GLOBSP,TPBAS
+.GLOBAL GCSBOT,GCSTOP,FRETOP,GCSNEW,TD.AGC,SPSTOR,PVSTOR
+.GLOBAL TOPLEVEL,INTNUM,INTVEC,INTOBL,ASOVEC,ERROBL,MAINPR,RESFUN,.BLOCK,ASOLNT,NODES
+.GLOBAL WRONGT,TTYOPE,OPEN,CLOSE,IOT,ILVAL,MESS,FACTI,REFVEC,MUDOBL,INITIA
+.GLOBAL LSTRES,BINDID,DUMNOD,PSTAT,1STEPR,IDPROC,EVATYP,APLTYP,PRNTYP,PURVEC,STOLST
+
+TVSTRT==1400 ; THIS SHOULD BE LARGE ENOUGH SO THAT WE HAVE ENOUGH
+ ; ROOM FOR INITAL FREE STORAGE
+
+
+VECTGO
+TVBASE": BLOCK TVLNT
+ GENERAL
+ TVLNT+2,,0
+TVLOC==TVBASE
+
+
+
+;INITIAL TYPE TABLE
+
+TYPVLC":
+ BLOCK 2*NUMPRI+2
+ GENERAL
+ 2*NUMPRI+2+2,,0
+
+TYPTP==.-2 ; POINT TO TOP OF TYPES
+
+; INITIAL SYMBOL TABEL FOR RSUBRS
+
+SQULOC==.
+SQUTBL: BLOCK 2*NSUBRS
+ TWORD,,0
+ 2*NSUBRS+2,,0
+
+INTVCL: BLOCK 2*NINT
+ TLIST,,0
+ 2*NINT+2,,0
+
+NODLST: TTP,,0
+ 0
+ TASOC,,0
+ BLOCK ASOLNT-3
+ GENERAL+<SASOC,,0>
+ ASOLNT+2,,0
+
+NODDUM: BLOCK ASOLNT
+ GENERAL+<SASOC,,0>
+ ASOLNT+2,,0
+
+
+
+ASOVCL: BLOCK NASOCS
+ TASOC,,0
+ NASOCS+2,,0
+
+
+
+;THESE ENTRIES MUST NOT MOVE DURING INITILAIZATION
+
+ADDTV TVEC,[-2*NUMPRI-2,,TYPVLC]
+TYPVEC==TVOFF+TVSTRT-1
+
+ADDTV TVEC,[-2*NUMPRI-2,,TYPVLC]
+TYPBOT==TVOFF+TVSTRT-1 ; POINT TO CURRENT TOP OF TYPE VECTORS
+
+;ENTRY FOR ROOT,TTICHN,TTOCHN
+
+ADDTV TCHAN,0
+TTICHN==TVOFF+TVSTRT-1
+
+ADDTV TCHAN,0
+TTOCHN==TVOFF+TVSTRT-1
+
+ADDTV TOBLS,0
+ROOT==TVOFF+TVSTRT-1
+ADDTV TOBLS,0
+INITIA==TVOFF+TVSTRT-1
+ADDTV TOBLS,0
+INTOBL==TVOFF+TVSTRT-1
+ADDTV TOBLS,0
+ERROBL==TVOFF+TVSTRT-1
+ADDTV TOBLS,0
+MUDOBL==TVOFF+TVSTRT-1
+ADDTV TVEC,0
+GRAPHS==TVOFF+TVSTRT-1
+ADDTV TFIX,0
+INTNUM==TVOFF+TVSTRT-1
+ADDTV TVEC,[-2*NINT,,INTVCL]
+INTVEC==TVOFF+TVSTRT-1
+ADDTV TUVEC,[-NASOCS,,ASOVCL]
+ASOVEC==TVOFF+TVSTRT-1
+ADDTV TSP,0
+SPSTOR==TVOFF+TVSTRT-1
+ADDTV TPVP,0
+PVSTOR==TVOFF+TVSTRT-1
+ADDTV TUVEC,0
+HASHTB==TVOFF+TVSTRT-1
+ADDTV TLIST,0
+CHNL0"==TVOFF+TVSTRT-1 ;LIST FOR CURRENTLY OPEN PSUEDO CHANNELS
+
+
+IFN ITS,[
+DEFINE ADDCHN N
+ ADDTV TCHAN,0
+ CHNL!N==TVOFF+TVSTRT-1
+ .GLOBAL CHNL!N
+ TERMIN
+
+REPEAT 15.,ADDCHN \.RPCNT+1
+
+DEFINE ADDIPC N
+ ADDTV TLIST,0
+ IPCS!N==TVOFF+TVSTRT-1
+ .GLOBAL IPCS!N
+ TERMIN
+
+REPEAT 15.,ADDIPC \.RPCNT+1
+]
+
+IFE ITS,[
+ADDTV TCHAN,0
+CHNL1==TVOFF+TVSTRT-1
+.GLOBAL CHNL1
+REPEAT N.CHNS-1,[ADDTV TCHAN,0
+]
+]
+
+ADDTV TASOC,[-ASOLNT,,NODLST]
+NODES==TVOFF+TVSTRT-1
+
+ADDTV TASOC,[-ASOLNT,,NODDUM]
+DUMNOD==TVOFF+TVSTRT-1
+
+ADDTV TVEC,0
+EVATYP==TVOFF+TVSTRT-1
+
+ADDTV TVEC,0
+APLTYP==TVOFF+TVSTRT-1
+
+ADDTV TVEC,0
+PRNTYP==TVOFF+TVSTRT-1
+
+; SLOTS ASSOCIATED WITH TEMPLATE DATA STRUCTURES
+
+ADDTV TUVEC,0
+TD.GET==TVOFF+TVSTRT-1
+
+ADDTV TUVEC,0
+TD.PUT==TVOFF+TVSTRT-1
+
+ADDTV TUVEC,0
+TD.AGC==TVOFF+TVSTRT-1
+
+ADDTV TUVEC,0
+TD.LNT==TVOFF+TVSTRT-1
+
+ADDTV TUVEC,0
+TD.PTY==TVOFF+TVSTRT-1
+
+ADDTV TCHAN,0
+RCYCHN==TVOFF+TVSTRT-1
+
+
+;GLOBAL SPECIAL PDL
+
+GSP: BLOCK GSPLNT
+ GENERAL
+ GSPLNT+2,,0
+
+ADDTV TVEC,[-GSPLNT,,GSP]
+GLOBASE==TVOFF+TVSTRT-1
+GLOB==.-2
+ADDTV TVEC,GLOB
+GLOBSP==TVOFF+TVSTRT-1 ;ENTRY FOR CURRENT POINTER TO GLOBAL SP
+
+; POINTER VECTOR TO PURE SHARED RSUBRS
+
+PURV: BLOCK 3*20. ; ENOUGH FOR 20 SUCH (INITIALLY)
+ 0
+ 3*20.+2,,0
+
+ADDTV TUVEC,[-3*20.,,PURV]
+PURVEC==TVOFF+TVSTRT-1
+
+ADDTV TLIST,0
+STOLST==TVOFF+TVSTRT-1
+
+ADDTV TVEC,GLOB
+GLOTOP==TVOFF+TVSTRT-1
+
+;PROCESS VECTOR FOR GARBAGE COLLECTOR PROCESS
+
+GCPVP: BLOCK PVLNT*2
+ GENERAL
+ PVLNT*2+2,,0
+
+
+VECRET
+
+PURE
+
+;INITIAL PROCESS VECTOR
+
+PVBASE": BLOCK PVLNT*2
+ GENERAL
+ PVLNT*2+2,,0
+PVLOC==PVBASE
+
+
+;ENTRY FOR PROCESS I.D.
+
+ ADDPV TFIX,1,PROCID
+;THE FOLLOWING IRP MAKES SPACE FO9 SAVED ACS
+
+ZZZ==.
+
+IRP A,,[0,A,B,C,D,E,PVP,TVP,FRM,AB,TB,TP,SP,M,R,P]B,,[0
+0,0,0,0,0,0,0,TTP,TAB,TTB,TTP,0,TCODE,TRSUBR,TPDL]
+
+LOC PVLOC+2*A
+A!STO==.-PVBASE
+B,,0
+0
+TERMIN
+
+PVLOC==PVLOC+16.*2
+LOC ZZZ
+
+
+ADDPV TTB,0,TBINIT
+ADDPV TTP,0,TPBASE
+ADDPV TSP,0,SPBASE
+ADDPV TPDL,0,PBASE
+ADDPV 0,0,RESFUN
+ADDPV TLIST,0,.BLOCK
+ADDPV TLIST,0,MESS
+ADDPV TACT,0,FACTI
+ADDPV TPVP,0,LSTRES
+ADDPV TFIX,0,BINDID
+ADDPV TFIX,1,PSTAT
+ADDPV TPVP,0,1STEPR
+ADDPV TSP,0,CURFCN
+ADDPV TTVP,0,REALTV
+
+
+
+IMPURE
+
+END
--- /dev/null
+
+ TITLE STRBUILD MUDDLE STRUCTURE BUILDER
+
+.GLOBAL RCL,VECTOP,GCSTOP,GCSBOT,FRETOP,GCSNEW,VECBOT,PARTOP,PARBOT,HITOP,HIBOT,GETPAG
+.GLOBAL PDLBUF,PDLEX,PDLEXP,GCFLG,GCPDL,GETNUM,PARNEW,MOVPUR,RCLV,RCLVEC
+.GLOBAL PGROW,TPGROW,MAINPR,%SLEEP,MSGTYP,PURTOP,PURBOT,STOSTR,RBLDM,CPOPJ,CPOPJ1,STBL
+.GLOBAL MTYI,UPLO,FRMUNG,BYTDOP,GLOBSP,FREDIF,FREMIN,GCHAPN,INTFLG,PINIT,CKPUR,GCSET
+.GLOBAL SAT,TTOCHN,TYPVEC,ICONS,INCONS,IBLOCK,IEUVEC,IEVECTI,CELL2,MKTBS,CPOPJ1,.LIST.
+.GLOBAL GIBLOK,REHASH,IBLOK1,IILIST,IIFORM,CIVEC,CIUVEC,CICONS,SLEEPR,GCHK10,FPAG
+.GLOBAL SPBASE,OUTRNG,CISTNG,CBYTES,%RUNAM,PURVEC,GCDOWN,N.CHNS,CHNL1,PLODR,C1CONS
+.GLOBAL CAFRE,CAFRET,STOGC,GCHN,WNDP,FRNP,FRONT,%GCJOB,%SHWND,%INFMP,%GETIP
+.GLOBAL TD.PUT,TD.GET,TD.LNT,GLOTOP,UBIT,FLGSET,PURMNG,RPURBT,%IFMP2,CHKPGI,PURCLN
+.GLOBAL CTIME,MTYO,ILOC,NODES,GPURFL,GCDANG,GCHACK,LPUR,HITOP,BADCHN,IMPURX
+.GLOBAL NOWLVL,CURPLN,PVSTOR,SPSTOR,MPOPJ,NGCS,RNUMSP,NUMSWP,SAGC,INQAGC
+.GLOBAL GCTIM,GCCAUS,GCCALL,AAGC,LVLINC,STORIC,GVLINC,TYPIC,GCRSET,ACCESS,NOSHUF,SQUPNT
+; GLOBALS ASSOCIATE WITH THE ASSOCIATION VECTOR
+
+.GLOBAL ASOVEC,ASOLNT,ITEM,INDIC,VAL,NWORDT,NODPNT,PNTRS
+.GLOBAL CELL,BINDID,GCFLCH,TYPBOT,GLOBAS,TPBASE
+.GLOBAL TPBINC,GBLINC,TYPINC,CONADJ,OGCSTP,ABOTN
+.GLOBAL AGC,ROOT,CIGTPR,IIGLOC
+.GLOBAL P.TOP,P.CORE,PMAPB
+.GLOBAL %MPINT,%GBINT,%CLSMP,%CLSM1
+.GLOBAL GCKNUM,CORTOP,GCHPN,INTAGC,WNDP,WNDBOT,BUFGC,WIND,GCDFLG,SAVM
+
+; SHARED SYMBOLS WITH GC MODULE
+
+.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,PMIN,PURMIN
+.GLOBAL GLBINC,GCHAIR,GCMONF,SQKIL,INBLOT
+.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
+
+NOPAGS==1 ; NUMBER OF WINDOWS
+EOFBIT==1000
+PDLBUF=100
+
+.ATOM.==200000 ; FLAG SAYING ATOMS MARKED (FOR VAL FLUSH LOGIC)
+
+GCHN==0 ; CHANNEL FOR FUNNNY INFERIOR
+STATNO==19. ; # OF STATISTICS FOR BLOAT-STAT
+STATGC==8. ; # OF GC-STATISTICS FOR BLOAT-STAT
+
+
+RELOCATABLE
+.INSRT MUDDLE >
+SYSQ
+IFE ITS,[
+.INSRT STENEX >
+]
+IFN ITS, PGSZ==10.
+IFE ITS, PGSZ==9.
+
+
+\f; GC-READ TAKES ONE ARGUMENT WHICH MUST BE A "READB" CHANNEL
+
+.GLOBAL CLOOKU,CINSER,MOBLIST,CATOM,EOFCND,IGLOC
+
+MFUNCTION GCREAD,SUBR,[GC-READ]
+
+ ENTRY
+
+ CAML AB,C%M2 ; CHECK # OF ARGS
+ JRST TFA
+ CAMGE AB,C%M40
+ JRST TMA
+
+ GETYP A,(AB) ; MAKE SURE ARG IS A CHANNEL
+ CAIE A,TCHAN
+ JRST WTYP2 ; IT ISN'T COMPLAIN
+ MOVE B,1(AB) ; GET PTR TO CHANNEL
+ HRRZ C,-2(B) ; LOOK AT BITS IN CHANNEL
+ TRC C,C.OPN+C.READ+C.BIN
+ TRNE C,C.OPN+C.READ+C.BIN
+ JRST BADCHN
+
+ PUSH P,1(B) ; SAVE ITS CHANNEL #
+IFN ITS,[
+ MOVE B,[-2,,C] ; SET UP AOBJN PTR TO READ IN DELIMITING
+ ; CONSTANTS
+ MOVE A,(P) ; GET CHANNEL #
+ DOTCAL IOT,[A,B]
+ FATAL GCREAD-- IOT FAILED
+ JUMPL B,EOFGC ; IF BLOCK DIDN'T FINISH THEN EOF
+]
+IFE ITS,[
+ MOVE A,(P) ; GET CHANNEL
+ BIN
+ MOVE C,B ; TO C
+ BIN
+ MOVE D,B ; TO D
+ GTSTS ; SEE IF EOF
+ TLNE B,EOFBIT
+ JRST EOFGC
+]
+
+ PUSH P,C ; SAVE AC'S
+ PUSH P,D
+
+IFN ITS,[
+ MOVE B,[-3,,C] ; NEXT GROUP OF WORDS
+ DOTCAL IOT,[A,B]
+ FATAL GCREAD--GC IOT FAILED
+]
+IFE ITS,[
+ MOVE A,-2(P) ; GET CHANNEL
+ BIN
+ MOVE C,B
+ BIN
+ MOVE D,B
+ BIN
+ MOVE E,B
+]
+ MOVEI 0,0 ; DO PRELIMINARY TESTS
+ IOR 0,A ; IOR ALL WORDS IN
+ IOR 0,B
+ IOR 0,C
+ IOR 0,(P)
+ IOR 0,-1(P)
+ TLNE 0,-1 ; SKIP IF NO BITS IN LEFT HALF
+ JRST ERDGC
+
+ MOVEM D,NNPRI
+ MOVEM E,NNSAT
+ MOVE D,C ; GET START OF NEWTYPE TABLE
+ SUB D,-1(P) ; CREATE AOBJN POINTER
+ HRLZS D
+ ADDI D,(C)
+ MOVEM D,TYPTAB ; SAVE IT
+ MOVE A,(P) ; GET LENGTH OF WORD
+ SUBI A,CONADJ ; SUBTRACT FOR CONSTANTS
+
+ ADD A,GCSTOP
+ CAMG A,FRETOP ; SEE IF GC IS NESESSARY
+ JRST RDGC1
+ ADDM C,GETNUM ; MOVE IN REQUEST
+ MOVE C,[0,,1] ; ARGS TO GC
+ PUSHJ P,INQAGC ; GC
+RDGC1: MOVE C,GCSTOP ; GET CURRENT TOP OF THE WORLD
+ MOVEM C,OGCSTP ; SAVE IT
+ ADD C,(P) ; CALCULATE NEW GCSTOP
+ ADDI C,2 ; SUBTRACT FOR CONSTANTS
+ MOVEM C,GCSTOP
+ SUB C,OGCSTP
+ SUBI C,2 ; SUBSTRACT TO GET RID OF D.W'S
+ MOVNS C ; SET UP AOBJN PTR FOR READIN
+IFN ITS,[
+ HRLZS C
+ MOVE A,-2(P) ; GET CHANNEL #
+ ADD C,OGCSTP
+ DOTCAL IOT,[A,C]
+ FATAL GCREAD-- IOT FAILED
+]
+IFE ITS,[
+ MOVE A,-2(P) ; CHANNEL TO A
+ MOVE B,OGCSTP ; SET UP BYTE POINTER
+ HRLI B,444400
+ SIN ; IN IT COMES
+]
+
+ MOVE C,(P) ; GET LENGHT OF OBJECT
+ ADDI A,5
+ MOVE B,1(AB) ; GET CHANNEL
+ ADDM C,ACCESS(B)
+ MOVE D,GCSTOP ; SET UP TO LOOK LIKE UVECTOR OF LOSES
+ ADDI C,2 ; ADD 2 FOR DOPE WORDS
+ HRLM C,-1(D)
+ MOVSI A,.VECT.
+ SETZM -2(D)
+ IORM A,-2(D) ; MARK VECTOR BIT
+ PUSH TP,$TRDTB ; HOLD ON IN CASE OF GC
+ MOVEI A,-2(D)
+ MOVN C,(P)
+ ADD A,C
+ HRL A,C
+ PUSH TP,A
+
+ MOVE D,-1(P) ; SET UP BOTTOM OF ATOM TABLE
+ SUBI D,1
+ MOVEM D,ABOTN
+ MOVE C,GCSTOP ; START AT TOP OF WORLD
+ SUBI C,3 ; POINT TO FIRST ATOM
+
+; LOOP TO FIX UP THE ATOMS
+
+AFXLP: HRRZ 0,1(TB)
+ ADD 0,ABOTN
+ CAMG C,0 ; SEE IF WE ARE DONE
+ JRST SWEEIN
+ HRRZ 0,1(TB)
+ SUB C,0
+ PUSHJ P,ATFXU ; FIX IT UP
+ HLRZ A,(C) ; GET LENGTH
+ TRZ A,400000 ; TURN OFF MARK BIT
+ SUBI C,(A) ; POINT TO PRECEDING ATOM
+ HRRZS C ; CLEAR OFF NEGATIVE
+ JRST AFXLP
+
+; FIXUP ROUTINE FOR ATOMS (C==> D.W.)
+
+ATFXU: PUSH P,C ; SAVE PTR TO D.W.
+ ADD C,1(TB)
+ MOVE A,C
+ HLRZ B,(A) ; GET LENGTH AND MARKING
+ TRZE B,400000 ; TURN OF MARK BIT AND SKIP IF WAS ALREADY MARKED
+ JRST ATFXU1
+ MOVEI D,-3(B) ; FULL WORDS OF STRING IN PNAME
+ IMULI D,5 ; CALCULATE # OF CHARACTERS
+ MOVE 0,-2(A) ; GET LAST WORD OF STRING
+ SUBI A,-1(B) ; LET A POINT TO OBLIST SLOAT
+ MOVE B,A ; GET COPY OF A
+ MOVE A,0
+ SUBI A,1
+ ANDCM 0,A
+ JFFO 0,.+1
+ HRREI 0,-34.(A)
+ IDIVI 0,7 ; # OF CHARS IN LAST WORD
+ ADD D,0
+ ADD D,$TCHSTR ; MAKE IT LOOK LIKE A STRINGS TYPE-WORD
+ PUSH P,D ; SAVE IT
+ MOVE C,(B) ; GET OBLIST SLOT PTR
+ATFXU9: HRRZS B ; RELATAVIZE POINTER
+ HRRZ 0,1(TB)
+ SUB B,0
+ PUSH P,B
+ JUMPE C,ATFXU6 ; NO OBLIST. CREATE ATOM
+ CAMN C,C%M1 ; SEE IF ROOT ATOM
+ JRST RTFX
+ ADD C,ABOTN ; POINT TO ATOM
+ PUSHJ P,ATFXU
+ PUSH TP,$TATOM
+ PUSH TP,B
+ MOVE A,$TATOM ; SET UP TO SEE IF OBLIST EXITS
+ MOVE C,$TATOM
+ MOVE D,IMQUOTE OBLIST
+ PUSHJ P,CIGTPR
+ JRST ATFXU8 ; NO OBLIST. CREATE ONE
+ SUB TP,C%22 ; GET RID OF SAVED ATOM
+RTCON: PUSH TP,$TOBLS
+ PUSH TP,B
+ MOVE C,B ; SET UP FOR LOOKUP
+ MOVE A,-1(P) ; SET UP PTR TO PNAME
+ MOVE B,(P)
+ ADD B,[440700,,1] ; ADJUST TO MAKE IT LOOK LIKE A BYTE-POINTER
+ HRRZ 0,1(TB)
+ ADD B,0
+ PUSHJ P,CLOOKU
+ JRST ATFXU4 ; NOT ON IT SO INSERT
+ATFXU3: SUB P,C%22 ; DONE
+ SUB TP,C%22 ; POP OFF OBLIST
+ATFXU7: MOVE C,(P) ; RESTORE PTR TO D.W.
+ ADD C,1(TB)
+ MOVEM B,-1(C) ; MOVE IN RELATAVIZE ADDRESS
+ MOVSI D,400000
+ IORM D,(C) ; TURN OFF MARK BIT
+ MOVE 0,3(B) ; SEE IF MUST BE LOCR
+ TRNE 0,1 ; SKIP IF MUST MAKE IT IMPURE
+ PUSHJ P,IIGLOC
+ POP P,C
+ ADD C,1(TB)
+ POPJ P, ; EXIT
+ATFXU1: POP P,C ; RESTORE PTR TO D.W.
+ ADD C,1(TB)
+ MOVE B,-1(C) ; GET ATOM
+ POPJ P,
+
+; ROUTINE TO INSERT AN ATOM
+
+ATFXU4: MOVE C,(TP) ; GET OBLIST PTR
+ MOVE B,(P) ; SET UP STRING PTR TO PNAME
+ ADD B,[440700,,1]
+ HRRZ 0,1(TB)
+ ADD B,0
+ MOVE A,-1(P) ; GET TYPE WORD
+ PUSHJ P,CINSER ; INSERT IT
+ JRST ATFXU3
+
+; THIS ROUTINE CREATS THE ATOM SO THAT ITS NOT ON ANY OBLIST
+
+ATFXU6: MOVE B,(P) ; POINT TO PNAME
+ ADD B,[440700,,1] ; MAKE IT LOOK LIKE A BYTE POINTER
+ HRRZ 0,1(TB)
+ ADD B,0
+ MOVE A,-1(P)
+ PUSHJ P,CATOM
+ SUB P,C%22 ; CLEAN OFF STACK
+ JRST ATFXU7
+
+; THIS ROUTINE CREATES AND OBLIST
+
+ATFXU8: MCALL 1,MOBLIST
+ PUSH TP,$TOBLS
+ PUSH TP,B ; SAVE OBLIST PTR
+ JRST ATFXU4 ; JUMP TO INSERT THE OBLIST
+
+; HERE TO INSERT AN ATOM INTO THE ROOT OBLIST
+
+RTFX: MOVE B,ROOT+1 ; GET ROOT OBLIST
+ JRST RTCON
+
+; THIS ROUTINE SWEEPS THRU THE NEW CORE IMAGE AND UPDATES ALL THE POINTERS.
+
+SWEEIN:
+; ROUTINE TO FIX UP TYPE-TABLE FOR GC-READ. THIS ROUTINE FIXES UP THE TYPE TABLE SO THAT
+; THE TYPES ATOM I.D. IS REPLACED BY ITS TYPE-NUMBER IN THE NEW MUDDLE AND IF ITS A
+; TEMPLATE, THE SLOT FOR THE PRIMTYPE-ATOM IS REPLACED BY THE SAT OF THE TEMPLATE
+
+ HRRZ E,1(TB) ; SET UP TYPE TABLE
+ ADD E,TYPTAB
+ JUMPGE E,VUP ; SKIP OVER IF DONE
+TYPUP1: PUSH P,C%0 ; PUSH SLOT FOR POSSIBLE TEMPLATE ATOM
+ HLRZ A,1(E) ; GET POSSIBLE ATOM SLOT
+ JUMPE A,TYPUP2 ; JUMP IF NOT A TEMPLATE
+ ADD A,ABOTN ; GET ATOM
+ ADD A,1(TB)
+ MOVE A,-1(A)
+ MOVE B,TYPVEC+1 ; GET TYPE VECTOR SLOT FOR LOOP TO SEE IF ITS THERE
+TYPUP3: CAMN A,1(B) ; SKIP IF NOT EQUAL
+ JRST TYPUP4 ; FOUND ONE
+ ADD B,C%22 ; TO NEXT
+ JUMPL B,TYPUP3
+ JRST ERTYP1 ; ERROR NONE EXISTS
+TYPUP4: HRRZ C,(B) ; GET SAT SLOT
+ CAIG C,NUMSAT ; MAKE SURE TYPE IS A TEMPLATE
+ JRST ERTYP2 ; IF NOT COMPLAIN
+ HRLM C,1(E) ; SMASH IN NEW SAT
+ MOVE B,1(B) ; GET ATOM OF PRIMTYPE
+ MOVEM B,(P) ; PUSH ONTO STACK
+TYPUP2: MOVEI D,0 ; INITIALIZE TYPE COUNT FOR LOOKUP LOOP
+ MOVE B,TYPVEC+1 ; GET PTR FOR LOOP
+ HRRZ A,1(E) ; GET TYPE'S ATOM ID
+ ADD A,ABOTN ; GET ATOM
+ ADD A,1(TB)
+ MOVE A,-1(A)
+TYPUP5: CAMN A,1(B) ; SKIP IF NOT EQUAL
+ JRST TYPUP6 ; FOUND ONE
+ ADDI D,1 ; INCREMENT TYPE-COUNT
+ ADD B,C%22 ; POINT TO NEXT
+ JUMPL B,TYPUP5
+ HRRM D,1(E) ; CLOBBER IN TYPE-NUMBER
+ PUSH TP,$TATOM ; PUSH ARGS FOR NEWTYPE
+ PUSH TP,A
+ PUSH TP,$TATOM
+ POP P,B ; GET BACK POSSIBLE PRIMTYPE ATOM
+ JUMPE B,TYPUP7 ; JUMP IF NOT A TEMPLATE
+ PUSH TP,B ; PUSH ON PRIMTYPE
+TYPUP9: SUB E,1(TB)
+ PUSH P,E ; SAVE RELATAVIZED PTR TO TYPE-TABLE
+ MCALL 2,NEWTYPE
+ POP P,E ; RESTORE RELATAVIZED PTR
+ ADD E,1(TB) ; FIX IT UP
+TYPUP0: ADD E,C%22 ; INCREMENT E
+ JUMPL E,TYPUP1
+ JRST VUP
+TYPUP7: HRRZ B,(E) ; FIND PRIMTYPE FROM SAT
+ MOVE A,@STBL(B)
+ PUSH TP,A
+ JRST TYPUP9
+TYPUP6: HRRM D,1(E) ; CLOBBER IN TYPE #
+ JRST TYPUP0
+
+ERTYP1: ERRUUO EQUOTE CANT-FIND-TEMPLATE
+
+ERTYP2: ERRUUO EQUOTE TEMPLATE-TYPE-NAME-NOT-OF-TYPE-TEMPLATE
+
+VUP: HRRZ E,1(TB) ; FIX UP SOME POINTERS
+ MOVEM E,OGCSTP
+ ADDM E,ABOTN
+ ADDM E,TYPTAB
+
+
+; ROUTINE TO SWEEP THRU THE READ-IN IMAGE LOOKING FOR UVECTORS AND TEMPLATES.
+; WHILE SWEEPING IT FIXES UP THE DOPE WORDS APPROPRIATELY.
+
+ HRRZ A,TYPTAB ; GET TO TOP OF WORLD
+ SUBI A,2 ; GET TO FIRST TYPE WORD OR DOPE-WORD OF FIRST OBJECT
+VUP1: CAMG A,OGCSTP ; SKIP IF NOT DONE
+ JRST VUP3
+ HLRZ B,(A) ; GET TYPE SLOT
+ TRNE B,.VECT. ; SKIP IF NOT A VECTOR
+ JRST VUP2
+ SUBI A,2 ; SKIP OVER PAIR
+ JRST VUP1
+VUP2: TRNE B,400000 ; SKIP IF UVECTOR
+ JRST VUP4
+ ANDI B,TYPMSK ; GET RID OF MONITORS
+ CAMG B,NNPRI ; SKIP IF NEWTYPE
+ JRST VUP5
+ PUSHJ P,GETNTP ; GET THE NEW TYPE #
+ PUTYP B,(A) ; SMASH IT IT
+VUP5: HLRZ B,1(A) ; SKIP OVER VECTOR
+ TRZ B,400000 ; GET RID OF POSSIBLE MARK BIT
+ SUBI A,(B)
+ JRST VUP1 ; LOOP
+VUP4: ANDI B,TYPMSK ; FLUSH MONITORS
+ CAMG B,NNSAT ; SKIP IF TEMPLATE
+ JRST VUP5
+ PUSHJ P,GETSAT ; CONVERT TO NEW SAT
+ ADDI B,.VECT. ; MAJIC TO TURN ON BIT
+ PUTYP B,(A)
+ JRST VUP5
+
+
+VUP3: PUSH P,GCSBOT ; SAVE CURRENT GCSBOT
+ MOVE A,OGCSTP ; SET UP NEW GCSBOT
+ MOVEM A,GCSBOT
+ PUSH P,GCSTOP
+ HRRZ A,TYPTAB ; SET UP NEW GCSTOP
+ MOVEM A,GCSTOP
+ SETOM GCDFLG
+ MOVE A,[PUSHJ P,RDFIX] ; INS FOR GCHACK
+ MOVEI PVP,0 ; SAY MIGHT BE NON-ATOMS
+ PUSHJ P,GCHK10
+ SETZM GCDFLG
+ POP P,GCSTOP ; RESTORE GCSTOP
+ MOVE A,1(TB) ; GET A POINTER TO RETURNING VALUES
+ MOVE B,A
+ HLRE C,B
+ SUB B,C
+ SETZM (B)
+ SETZM 1(B)
+ POP P,GCSBOT ; RESTORE GCSBOT
+ MOVE B,1(A) ; GET PTR TO OBJECTS
+ MOVE A,(A)
+ JRST FINIS ; EXIT
+
+; ERROR FOR INCORRECT GCREAD FILE
+
+ERDGC: ERRUUO EQUOTE BAD-GC-READ-FILE
+
+; ROUTINE CALLED BY GCHACK TO UPDATE PTRS IN THE NEW CORE IMAGE
+
+RDFIX: PUSH P,C ; SAVE C
+ PUSH P,B ; SAVE PTR
+ EXCH B,C
+ TLNE C,UBIT ; SKIP IF NOT UVECTOR
+ JRST ELEFX ; DON'T HACK TYPES IN UVECTOR
+ CAIN B,TTYPEC
+ JRST TYPCFX
+ CAIN B,TTYPEW
+ JRST TYPWFX
+ CAML B,NNPRI
+ JRST TYPGFX
+ELEFX: EXCH B,A ; EXCHANGE FOR SAT
+ PUSHJ P,SAT
+ EXCH B,A ; REFIX
+ CAIE B,SLOCR ; REL GLOC'S ARE STORED AS ATOMS
+ CAIN B,SATOM
+ JRST ATFX
+ CAIN B,SCHSTR
+ JRST STFX
+ CAIN B,S1WORD ; SEE IF PRIMTYPE WOR
+ JRST RDLSTF ; LEAVE IF IS
+STFXX: MOVE 0,GCSBOT ; ADJUSTMENT
+ SUBI 0,FPAG+5
+ SKIPE 1(C) ; DON'T CHANGE A PTR TO NIL
+ ADDM 0,1(C) ; FIX UP
+RDLSTF: TLNN C,.LIST. ; SEE IF PAIR
+ JRST RDL1 ; EXIT
+ MOVE 0,GCSBOT ; FIX UP
+ SUBI 0,FPAG+5
+ HRRZ B,(C) ; SEE IF POINTS TO NIL
+ SKIPN B
+ JRST RDL1
+ MOVE B,C ; GET ARG FOR RLISTQ
+ PUSHJ P,RLISTQ
+ JRST RDL1
+ ADDM 0,(C)
+RDL1: POP P,B ; RESTORE B
+ POP P,C
+ POPJ P,
+
+; ROUTINE TO FIX UP PNAMES
+
+STFX: TLZN D,STATM
+ JRST STFXX
+ HLLM D,1(C) ; PUT BACK WITH BIT OFF
+ ADD D,ABOTN
+ ANDI D,-1
+ HLRE 0,-1(D) ; LENGTH OF ATOM
+ MOVNS 0
+ SUBI 0,3 ; VAL & OBLIST
+ IMULI 0,5 ; TO CHARS (SORT OF)
+ HRRZ D,-1(D)
+ ADDI D,2
+ PUSH P,A
+ PUSH P,B
+ LDB A,[360600,,1(C)] ; GET BYTE POS
+ IDIVI A,7 ; TO CHAR POS
+ SKIPE A
+ SUBI A,5
+ HRRZ B,(C) ; STRING LENGTH
+ SUB B,A ; TO WORD BOUNDARY STRING
+ SUBI 0,(B)
+ IDIVI 0,5
+ ADD D,0
+ POP P,B
+ POP P,A
+ HRRM D,1(C)
+ JRST RDLSTF
+
+; ROUTINE TO FIX UP POINTERS TO ATOMS
+
+ATFX: SKIPGE D
+ JRST RDLSTF
+ ADD D,ABOTN
+ MOVE 0,-1(D) ; GET PTR TO ATOM
+ CAIE B,SLOCR ; IF REL LOCATIVE, MORE HAIR
+ JRST ATFXAT
+ MOVE B,0
+ PUSH P,E
+ PUSH P,D
+ PUSH P,C
+ PUSH P,B
+ PUSH P,A
+ PUSHJ P,IGLOC
+ SUB B,GLOTOP+1
+ MOVE 0,B
+ POP P,A
+ POP P,B
+ POP P,C
+ POP P,D
+ POP P,E
+ATFXAT: MOVEM 0,1(C) ; SMASH IT IN
+ JRST RDLSTF ; EXIT
+
+TYPCFX: HRRZ B,1(C) ; GET TYPE
+ PUSHJ P,GETNEW ; GET TYPE IN THIS CORE IMAGE
+ HRRM B,1(C) ; CLOBBER IT IN
+ JRST RDLSTF ; CONTINUE FIXUP
+
+TYPWFX: HLRZ B,1(C) ; GET TYPE
+ PUSHJ P,GETNEW ; GET TYPE IN THIS CORE IMAGE
+ HRLM B,1(C) ; SMASH IT IN
+ JRST ELEFX
+
+TYPGFX: PUSH P,D
+ PUSHJ P,GETNTP ; GET TYPE IN THIS CORE IMAGE
+ POP P,D
+ PUTYP B,(C)
+ JRST ELEFX
+
+; HERE TO HANDLE AN EOF IN GC-READ. IT USES OPTIONAL SECOND ARG IF SUPPLIED AS
+; EOF HANDLER ELSE USES CHANNELS.
+
+EOFGC: MOVE B,1(AB) ; GET CHANNEL INTO B
+ CAML AB,C%M20 ; [-2,,0] ; SKIP IF EOF ROUTINE IS SUPPLIED
+ JRST MYCLOS ; USE CHANNELS
+ PUSH TP,2(AB)
+ PUSH TP,3(AB)
+ JRST CLOSIT
+MYCLOS: PUSH TP,EOFCND-1(B)
+ PUSH TP,EOFCND(B)
+CLOSIT: PUSH TP,$TCHAN
+ PUSH TP,B
+ MCALL 1,FCLOSE ; CLOSE CHANNEL
+ MCALL 1,EVAL ; EVAL HIS EOF HANDLER
+ JRST FINIS
+
+; ROUTINE TO SUPPLY THE TYPE NUMBER FOR A NEWTYPE
+
+GETNEW: CAMG B,NNPRI ;NEWTYPE
+ POPJ P,
+GETNTP: MOVE D,TYPTAB ; GET AOBJN POINTER TO TYPE-TABLE
+GETNT1: HLRZ E,(D) ; GET TYPE #
+ CAIN E,(B) ; SKIP IF NOT EQUAL TO GOAL
+ JRST GOTTYP ; FOUND IT
+ ADD D,C%22 ; POINT TO NEXT
+ JUMPL D,GETNT1
+ SKIPA ; KEEP TYPE SAME
+GOTTYP: HRRZ B,1(D) ; GET NEW TYPE #
+ POPJ P,
+
+; ROUTINE TO SUPPLY THE SAT TO A TEMPLATE HACKER
+
+GETSAT: MOVE D,TYPTAB ; GET AOBJN PTR TO TYPE TABLE
+GETSA1: HRRZ E,(D) ; GET OBJECT
+ CAIN E,(B) ; SKIP IF NOT EQUAL TO GOAL
+ JRST GOTSAT ; FOUND IT
+ ADD D,C%22
+ JUMPL D,GETSA1
+ FATAL GC-DUMP -- TYPE FIXUP FAILURE
+GOTSAT: HLRZ B,1(D) ; GET NEW SAT
+ POPJ P,
+
+
+; A ROUTINE TO DISTINGUISH BETWEEN A DEFERRED AND A LIST POINTER
+RLISTQ: PUSH P,A
+ GETYP A,(B) ; GET TYPE
+ PUSHJ P,SAT ; GET SAT
+ CAIG A,NUMSAT ; NOT DEFERRED IF TEMPLATE
+ SKIPL MKTBS(A)
+ AOS -1(P) ; SKIP IF NOT DEFFERED
+ POP P,A
+ POPJ P, ; EXIT
+
+\f
+.GLOBAL FLIST
+
+MFUNCTION BLOATSTAT,SUBR,[BLOAT-STAT]
+
+ENTRY
+
+ JUMPGE AB,GETUVC ; SEE IF THERE IS AN ARGUMENT
+ GETYP A,(AB)
+ CAIE A,TUVEC ; SEE IF THE ARGUMENT IS A UVECTOR
+ JRST WTYP1 ; IF NOT COMPLAIN
+ HLRE 0,1(AB)
+ MOVNS 0
+ CAIE 0,STATNO+STATGC ; SEE IF UVECTOR IS RIGHT LENGTH
+ JRST WTYP1
+ CAMGE AB,C%M20 ; [-2,,0] ; SEE IF THERE ARE TOO MANY ARGUMENTS
+ JRST TMA
+ MOVE A,(AB) ; GET THE UVECTOR
+ MOVE B,1(AB)
+ JRST SETUV ; CONTINUE
+GETUVC: MOVEI A,STATNO+STATGC ; CREATE A UVECTOR
+ PUSHJ P,IBLOCK
+SETUV: PUSH P,A ; SAVE UVECTOR
+ PUSH P,B
+ MOVE 0,NOWFRE ; COMPUTE FREE STORAGE USED SINCE LAST BLOAT-STAT
+ SUB 0,RFRETP
+ ADD 0,GCSTOP
+ MOVEM 0,CURFRE
+ PUSHJ P,GCSET ; FIX UP BLOAT-STAT PARAMETERS
+ HLRE 0,TP ; COMPUTE STACK SPACE USED UP
+ ADD 0,NOWTP
+ SUBI 0,PDLBUF
+ MOVEM 0,CURTP
+ MOVE B,IMQUOTE THIS-PROCESS
+ PUSHJ P,ILOC
+ HRRZS B
+ MOVE PVP,PVSTOR+1
+ HRRZ C,TPBASE+1(PVP) ; CALCULATE # OF ATOM SLOTS
+ MOVE 0,B
+ HRRZ D,SPBASE+1(PVP) ; COMPUTE CURRENT # OF BINDINGS
+ SUB 0,D
+ IDIVI 0,6
+ MOVEM 0,CURLVL
+ SUB B,C ; TOTAL WORDS ATOM STORAGE
+ IDIVI B,6 ; COMPUTE # OF SLOTS
+ MOVEM B,NOWLVL
+ HRRZ A,GLOBASE+1 ; COMPUTE TOTAL # OF GLOBAL SLOTS
+ HLRE 0,GLOBASE+1
+ SUB A,0 ; POINT TO DOPE WORD
+ HLRZ B,1(A)
+ ASH B,-2 ; # OF GVAL SLOTS
+ MOVEM B,NOWGVL
+ HRRZ A,GLOTOP+1 ; COMPUTE # OF GVAL SLOTS IN USE
+ HRRZ 0,GLOBSP+1
+ SUB A,0
+ ASH A,-2 ; NEGATIVE # OF SLOTS USED
+ MOVEM A,CURGVL
+ HRRZ A,TYPBOT+1 ; GET LENGTH OF TYPE VECTOR
+ HLRE 0,TYPBOT+1
+ SUB A,0
+ HLRZ B,1(A) ; # OF WORDS IN TYPE-VECTOR
+ IDIVI B,2 ; CONVERT TO # OF TYPES
+ MOVEM B,NOWTYP
+ HLRE 0,TYPVEC+1 ; LENGTH OF VISABLE TYPE-VECTOR
+ MOVNS 0
+ IDIVI 0,2 ; GET # OF TYPES
+ MOVEM 0,CURTYP
+ MOVE 0,CODTOP ; GET LENGTH OF STATIONARY IMPURE STORAGE
+ MOVEM 0,NOWSTO
+ SETZB B,D ; ZERO OUT MAXIMUM
+ HRRZ C,FLIST
+LOOPC: HLRZ 0,(C) ; GET BLK LENGTH
+ ADD D,0 ; ADD # OF WORDS IN BLOCK
+ CAMGE B,0 ; SEE IF NEW MAXIMUM
+ MOVE B,0
+ HRRZ C,(C) ; POINT TO NEXT BLOCK
+ JUMPN C,LOOPC ; REPEAT
+ MOVEM D,CURSTO
+ MOVEM B,CURMAX
+ HLRE 0,P ; GET AMOUNT OF ROOM LEFT ON P
+ ADD 0,NOWP
+ SUBI 0,PDLBUF
+ MOVEM 0,CURP
+ MOVSI C,BSTGC ; SET UP BLT FOR GC FIGURES
+ HRRZ B,(P) ; RESTORE B
+ HRR C,B
+ BLT C,(B)STATGC-1
+ HRLI C,BSTAT ; MODIFY BLT FOR STATS
+ HRRI C,STATGC(B)
+ BLT C,(B)STATGC+STATNO-1
+ MOVEI 0,TFIX+.VECT.
+ HRLM 0,(B)STATNO+STATGC ; MOVE IN UTYPE
+ POP P,B
+ POP P,A ; RESTORE TYPE-WORD
+ JRST FINIS
+
+GCRSET: SETZM GCNO ; CALL FROM INIT, ZAP ALL 1ST
+ MOVE 0,[GCNO,,GCNO+1]
+ BLT 0,GCCALL
+ JRST GCSET
+
+
+
+\f
+.GLOBAL PGFIND,PGGIVE,PGTAKE,PGINT
+
+; USER GARBAGE COLLECTOR INTERFACE
+.GLOBAL ILVAL
+
+MFUNCTION GC,SUBR
+ ENTRY
+
+ JUMPGE AB,GC1
+ CAMGE AB,C%M60 ; [-6,,0]
+ JRST TMA
+ PUSHJ P,GETFIX ; GET FREEE MIN IF GIVEN
+ SKIPE A ; SKIP FOR 0 ARGUMENT
+ MOVEM A,FREMIN
+GC1: PUSHJ P,COMPRM ; GET CURRENT USED CORE
+ PUSH P,A
+ CAML AB,C%M40 ; [-4,,0] ; SEE IF 3RD ARG
+ JRST GC5
+ GETYP A,4(AB) ; MAKE SURE A FIX
+ CAIE A,TFIX
+ JRST WTYP ; ARG WRONG TYPE
+ MOVE A,5(AB)
+ MOVEM A,RNUMSP
+ MOVEM A,NUMSWP
+GC5: CAML AB,C%M20 ; [-2,,0] ; SEE IF SECOND ARG
+ JRST GC3
+ GETYP A,2(AB) ; SEE IF NONFALSE
+ CAIE A,TFALSE ; SKIP IF FALSE
+ JRST HAIRGC ; CAUSE A HAIRY GC
+GC3: MOVSI A,TATOM ; CHECK TO SEE IF INTERRUPT FLAG IS ON
+ MOVE B,IMQUOTE AGC-FLAG
+ PUSHJ P,ILVAL
+ CAMN A,$TUNBOUND ; SKIP IF NOT UNBOUND
+ JRST GC2
+ SKIPE GCHPN ; SKIP IF GCHAPPEN IS 0
+ JRST FALRTN ; JUMP TO RETURN FALSE
+GC2: MOVE C,[9.,,0]
+ PUSHJ P,AGC ; COLLECT THAT TRASH
+ PUSHJ P,COMPRM ; HOW MUCH ROOM NOW?
+ POP P,B ; RETURN AMOUNT
+ SUB B,A
+ MOVSI A,TFIX
+ JRST FINIS
+HAIRGC: MOVE B,3(AB)
+ CAIN A,TFIX ; IF FIX THEN CLOBBER NGCS
+ MOVEM B,NGCS
+ MOVEI A,1 ; FORCE VALUE FLUSHING PHASE TO OCCUR
+ MOVEM A,GCHAIR
+ JRST GC2 ; HAIRY GC OCCORS NO MATTER WHAT
+FALRTN: MOVE A,$TFALSE
+ MOVEI B,0 ; RETURN A FALSE-- FOR GC WHICH DIDN'T OCCOR
+ JRST FINIS
+
+
+COMPRM: MOVE A,GCSTOP ; USED SPACE
+ SUB A,GCSBOT
+ POPJ P,
+
+\f
+MFUNCTION GCDMON,SUBR,[GC-MON]
+
+ ENTRY
+
+ MOVEI E,GCMONF
+
+FLGSET: MOVE C,(E) ; GET CURRENT VALUE
+ JUMPGE AB,RETFLG ; RET CURRENT
+ CAMGE AB,C%M20 ; [-3,,]
+ JRST TMA
+ GETYP 0,(AB)
+ SETZM (E)
+ CAIN 0,TFALSE
+ SETOM (E)
+ SKIPL E
+ SETCMM (E)
+
+RETFLG: SKIPL E
+ SETCMM C
+ JUMPL C,NOFLG
+ MOVSI A,TATOM
+ MOVE B,IMQUOTE T
+ JRST FINIS
+
+NOFLG: MOVEI B,0
+ MOVSI A,TFALSE
+ JRST FINIS
+
+.GLOBAL EVATYP,APLTYP,PRNTYP
+
+\fMFUNCTION BLOAT,SUBR
+ ENTRY
+
+ PUSHJ P,SQKIL
+ MOVEI C,0 ; FLAG TO SAY WHETHER NEED A GC
+ MOVSI E,-NBLO ; AOBJN TO BLOATER TABLE
+
+BLOAT2: JUMPGE AB,BLOAT1 ; ALL DONE?
+ PUSHJ P,NXTFIX ; GET NEXT BLOAT PARAM
+ SKIPE A
+ PUSHJ P,@BLOATER(E) ; DISPATCH
+ AOBJN E,BLOAT2 ; COUNT PARAMS SET
+
+ JUMPL AB,TMA ; ANY LEFT...ERROR
+BLOAT1: JUMPE C,BLOATD ; DONE, NO GC NEEDED
+ MOVE C,E ; MOVE IN INDICATOR
+ HRLI C,1 ; INDICATE THAT IT COMES FROM BLOAT
+ SETOM INBLOT
+ PUSHJ P,AGC ; DO ONE
+ SKIPE A,TPBINC ; SMASH POINNTERS
+ MOVE PVP,PVSTOR+1
+ ADDM A,TPBASE+1(PVP)
+ SKIPE A,GLBINC ; GLOBAL SP
+ ADDM A,GLOBASE+1
+ SKIPE A,TYPINC
+ ADDM A,TYPBOT+1
+ SETZM TPBINC ; RESET PARAMS
+ SETZM GLBINC
+ SETZM TYPINC
+
+BLOATD: SKIPN A,GETNUM ; SKIP IF FREE STORAGE REQUEST IN EFFECT
+ JRST BLTFN
+ ADD A,FRETOP ; ADD FRETOP
+ ADDI A,1777 ; ONE BLOCK FOR MARK PDL AND ROUND
+ ANDCMI A,1777 ; TO PAGE BOUNDRY
+ CAML A,PURBOT ; SKIP IF POSSIBLE TO WIN
+ JRST BLFAGC
+ ASH A,-10. ; TO PAGES
+ PUSHJ P,P.CORE ; GRET THE CORE
+ JRST BLFAGC ; LOSE LOSE LOSE
+ MOVE A,FRETOP ; CALCULATE NEW PARAMETERS
+ MOVEM A,RFRETP
+ MOVEM A,CORTOP
+ MOVE B,GCSTOP
+ SETZM 1(B)
+ HRLI B,1(B)
+ HRRI B,2(B)
+ BLT B,-1(A) ; ZERO CORE
+BLTFN: SETZM GETNUM
+ MOVE B,FRETOP
+ SUB B,GCSTOP
+ MOVSI A,TFIX ; RETURN CORE FOUND
+ JRST FINIS
+BLFAGC: MOVN A,FREMIN
+ ADDM A,GETNUM ; FIX UP SO BLOATS CORRECTLY
+ MOVE C,C%11 ; INDICATOR FOR AGC
+ PUSHJ P,AGC ; GARBAGE COLLECT
+ JRST BLTFN ; EXIT
+
+; TABLE OF BLOAT ROUTINES
+
+BLOATER:
+ MAINB
+ TPBLO
+ LOBLO
+ GLBLO
+ TYBLO
+ STBLO
+ PBLO
+ SFREM
+ SLVL
+ SGVL
+ STYP
+ SSTO
+ PUMIN
+ PMUNG
+ TPMUNG
+ NBLO==.-BLOATER
+
+; BLOAT MAIN STORAGE AREA
+
+MAINB: SETZM GETNUM
+ MOVE D,FRETOP ; COMPUTE CURRENT ROOM
+ SUB D,PARTOP
+ CAMGE A,D ; NEED MORE?
+ POPJ P, ; NO, LEAVE
+ SUB A,D
+ MOVEM A,GETNUM ; SAVE
+ POPJ P,
+
+; BLOAT TP STACK (AT TOP)
+
+TPBLO: HLRE D,TP ; GET -SIZE
+ MOVNS B,D
+ ADDI D,1(TP) ; POINT TO DOPE (ALMOST)
+ CAME D,TPGROW ; BLOWN?
+ ADDI D,PDLBUF ; POINT TO REAL DOPE WORD
+ SUB A,B ; SKIP IF GROWTH NEEDED
+ JUMPLE A,CPOPJ
+ ADDI A,63.
+ ASH A,-6 ; CONVERT TO 64 WD BLOCKS
+ CAILE A,377
+ JRST OUTRNG
+ DPB A,[111100,,-1(D)] ; SMASH SPECS IN
+ AOJA C,CPOPJ
+
+; BLOAT TOP LEVEL LOCALS
+
+LOBLO: HLRE D,TP ; GET -SIZE
+ MOVNS B,D
+ ADDI D,1(TP) ; POINT TO DOPE (ALMOST)
+ CAME D,TPGROW ; BLOWN?
+ ADDI D,PDLBUF ; POINT TO REAL DOPE WORD
+ CAMG A,B ; SKIP IF GROWTH NEEDED
+ IMULI A,6 ; 6 WORDS PER BINDING
+ MOVE PVP,PVSTOR+1
+ HRRZ 0,TPBASE+1(PVP)
+ HRRZ B,SPBASE+1(PVP) ; ROOM AVAIL TO E
+ SUB B,0
+ SUBI A,(B) ; HOW MUCH MORE?
+ JUMPLE A,CPOPJ ; NONE NEEDED
+ MOVEI B,TPBINC
+ PUSHJ P,NUMADJ
+ DPB A,[1100,,-1(D)] ; SMASH
+ AOJA C,CPOPJ
+
+; GLOBAL SLOT GROWER
+
+GLBLO: ASH A,2 ; 4 WORDS PER VAR
+ MOVE D,GLOBASE+1 ; CURRENT LIMITS
+ HRRZ B,GLOBSP+1
+ SUBI B,(D)
+ SUBI A,(B) ; NEW AMOUNT NEEDED
+ JUMPLE A,CPOPJ
+ MOVEI B,GLBINC ; WHERE TO KEEP UPDATE
+ PUSHJ P,NUMADJ ; FIX NUMBER
+ HLRE 0,D
+ SUB D,0 ; POINT TO DOPE
+ DPB A,[1100,,(D)] ; AND SMASH
+ AOJA C,CPOPJ
+
+; HERE TO GROW TYPE VECTOR (AND FRIENDS)
+
+TYBLO: ASH A,1 ; TWO WORD PER TYPE
+ HRRZ B,TYPVEC+1 ; FIND CURRENT ROOM
+ MOVE D,TYPBOT+1
+ SUBI B,(D)
+ SUBI A,(B) ; EXTRA NEEDED TO A
+ JUMPLE A,CPOPJ ; NONE NEEDED, LEAVE
+ MOVEI B,TYPINC ; WHERE TO STASH SPEC
+ PUSHJ P,NUMADJ ; FIX NUMBER
+ HLRE 0,D ; POINT TO DOPE
+ SUB D,0
+ DPB A,[1100,,(D)]
+ SKIPE D,EVATYP+1 ; GROW AUX TYPE VECS IF NEEDED
+ PUSHJ P,SGROW1
+ SKIPE D,APLTYP+1
+ PUSHJ P,SGROW1
+ SKIPE D,PRNTYP+1
+ PUSHJ P,SGROW1
+ AOJA C,CPOPJ
+
+; HERE TO CREATE STORAGE SPACE
+
+STBLO: MOVE D,GCSBOT ; HOW MUCH NOW HERE
+ SUB D,CODTOP
+ SUBI A,(D) ; MORE NEEDED?
+ JUMPLE A,CPOPJ
+ MOVEM A,PARNEW ; FORCE PAIR SPACE TO MOVE ON OUT
+ AOJA C,CPOPJ
+
+; BLOAT P STACK
+
+PBLO: HLRE D,P
+ MOVNS B,D
+ SUBI D,5 ; FUDGE FOR THIS CALL
+ SUBI A,(D)
+ JUMPLE A,CPOPJ
+ ADDI B,1(P) ; POINT TO DOPE
+ CAME B,PGROW ; BLOWN?
+ ADDI B,PDLBUF ; NOPE, POIN TO REAL D.W.
+ ADDI A,63.
+ ASH A,-6 ; TO 64 WRD BLOCKS
+ CAILE A,377 ; IN RANGE?
+ JRST OUTRNG
+ DPB A,[111100,,-1(B)]
+ AOJA C,CPOPJ
+
+; SET FREMIN
+
+SFREM: SKIPE A ; DON'T ZERO EMPTY PARAMETER
+ MOVEM A,FREMIN
+ POPJ P,
+
+; SET LVAL INCREMENT
+
+SLVL: IMULI A,6 ; CALCULATE AMOUNT TO GROW B
+ MOVEI B,LVLINC
+ PUSHJ P,NUMADJ
+ MOVEM A,LVLINC
+ POPJ P,
+
+; SET GVAL INCREMENT
+
+SGVL: IMULI A,4. ; # OF SLOTS
+ MOVEI B,GVLINC
+ PUSHJ P,NUMADJ
+ MOVEM A,GVLINC
+ POPJ P,
+
+; SET TYPE INCREMENT
+
+STYP: IMULI A,2 ; CALCULATE NUMBER OF GROW BLOCKS NEEDED
+ MOVEI B,TYPIC
+ PUSHJ P,NUMADJ
+ MOVEM A,TYPIC
+ POPJ P,
+
+; SET STORAGE INCREMENT
+
+SSTO: IDIVI A,2000 ; # OF BLOCKS
+ CAIE B,0 ; REMAINDER?
+ ADDI A,1
+ IMULI A,2000 ; CONVERT BACK TO WORDS
+ MOVEM A,STORIC
+ POPJ P,
+; HERE FOR MINIMUM PURE SPACE
+
+PUMIN: ADDI A,1777
+ ANDCMI A,1777 ; TO PAGE BOUNDRY
+ MOVEM A,PURMIN
+ POPJ P,
+
+; HERE TO ADJUST PSTACK PARAMETERS IN GC
+
+PMUNG: ADDI A,777 ; TO NEAREST 1000 WORD BOUNDRY
+ ANDCMI A,777
+ MOVEM A,PGOOD ; PGOOD
+ ASH A,2 ; PMAX IS 4*PGOOD
+ MOVEM A,PMAX
+ ASH A,-4 ; PMIN IS .25*PGOOD
+ MOVEM A,PMIN
+
+; HERE TO ADJUST GC TPSTACK PARAMS
+
+TPMUNG: ADDI A,777
+ ANDCMI A,777 ; TO NEAREST 1000 WORD BOUNDRY
+ MOVEM A,TPGOOD
+ ASH A,2 ; TPMAX= 4*TPGOOD
+ MOVEM A,TPMAX
+ ASH A,-4 ; TPMIN= .25*TPGOOD
+ MOVEM A,TPMIN
+
+
+; GET NEXT (FIX) ARG
+
+NXTFIX: PUSHJ P,GETFIX
+ ADD AB,C%22
+ POPJ P,
+
+; ROUTINE TO GET POS FIXED ARG
+
+GETFIX: GETYP A,(AB)
+ CAIE A,TFIX
+ JRST WRONGT
+ SKIPGE A,1(AB)
+ JRST BADNUM
+ POPJ P,
+
+
+; GET NUMBERS FIXED UP FOR GROWTH FIELDS
+
+NUMADJ: ADDI A,77 ; ROUND UP
+ ANDCMI A,77 ; KILL CRAP
+ MOVE 0,A
+ MOVNS A ; COMPUTE ADD FACTOR FOR SPEC. POINTER UPDATE
+ HRLI A,-1(A)
+ MOVEM A,(B) ; AND STASH IT
+ MOVE A,0
+ ASH A,-6 ; TO 64 WD BLOCKS
+ CAILE A,377 ; CHECK FIT
+ JRST OUTRNG
+ POPJ P,
+
+; DO SYMPATHETIC GROWTHS
+
+SGROW1: HLRE 0,D
+ SUB D,0
+ DPB A,[111100,,(D)]
+ POPJ P,
+
+\f;FUNCTION TO CONSTRUCT A LIST
+
+MFUNCTION CONS,SUBR
+
+ ENTRY 2
+ GETYP A,2(AB) ;GET TYPE OF 2ND ARG
+ CAIE A,TLIST ;LIST?
+ JRST WTYP2 ;NO , COMPLAIN
+ MOVE C,(AB) ; GET THING TO CONS IN
+ MOVE D,1(AB)
+ HRRZ E,3(AB) ; AND LIST
+ PUSHJ P,ICONS ; INTERNAL CONS
+ JRST FINIS
+
+; COMPILER CALL TO CONS
+
+C1CONS: PUSHJ P,ICELL2
+ JRST ICONS2
+ICONS4: HRRI C,(E)
+ICONS3: MOVEM C,(B) ; AND STORE
+ MOVEM D,1(B)
+TLPOPJ: MOVSI A,TLIST
+ POPJ P,
+
+; INTERNAL CONS--ICONS; C,D VALUE, E CDR
+
+; RELATIVIZE RETURN ADDRESS HERE--MUST BE DIFFERENT FROM ICONS, SINCE
+; ICONS IS CALLED FROM INTERPRETER ENTRIES WHICH ARE THEMSELVES PUSHJ'ED
+; TO: DOING SUBM M,(P) ANYWHERE IN ICONS IS FATAL IF A GC OCCURS.
+
+CICONS: SUBM M,(P)
+ PUSHJ P,ICONS
+ JRST MPOPJ
+
+; INTERNAL CONS TO NIL--INCONS
+
+INCONS: MOVEI E,0
+
+ICONS: GETYP A,C ; CHECK TYPE OF VAL
+ PUSHJ P,NWORDT ; # OF WORDS
+ SOJN A,ICONS1 ; JUMP IF DEFERMENT NEEDED
+ PUSHJ P,ICELL2 ; NO DEFER, GET 2 WORDS FROM PAIR SPACE
+ JRST ICNS2A ; NO CORE, GO GC (SPECIAL PLACE, NOTICE)
+ JRST ICONS4
+
+; HERE IF CONSING DEFERRED
+
+ICONS1: MOVEI A,4 ; NEED 4 WORDS
+ PUSHJ P,ICELL ; GO GET 'EM
+ JRST ICNS2A ; NOT THERE, GC (SAME PLACE AS FOR ICONS)
+ HRLI E,TDEFER ; CDR AND DEFER
+ MOVEM E,(B) ; STORE
+ MOVEI E,2(B) ; POINT E TO VAL CELL
+ HRRZM E,1(B)
+ MOVEM C,(E) ; STORE VALUE
+ MOVEM D,1(E)
+ JRST TLPOPJ
+
+
+
+; HERE TO GC ON A CONS
+
+; HERE FROM C1CONS
+ICONS2: SUBM M,(P)
+ PUSHJ P,ICONSG
+ SUBM M,(P)
+ JRST C1CONS
+
+; HERE FROM ICONS (THUS CICONS, INDIRECTLY), ICONS1
+ICNS2A: PUSHJ P,ICONSG
+ JRST ICONS
+
+; REALLY DO GC
+ICONSG: PUSH TP,C ; SAVE VAL
+ PUSH TP,D
+ PUSH TP,$TLIST
+ PUSH TP,E ; SAVE VITAL STUFF
+ ADDM A,GETNUM ; AMOUNT NEEDED
+ MOVE C,[3,,1] ; INDICATOR FOR AGC
+ PUSHJ P,INQAGC ; ATTEMPT TO WIN
+ MOVE D,-2(TP) ; RESTORE VOLATILE STUFF
+ MOVE C,-3(TP)
+ MOVE E,(TP)
+ SUB TP,C%44 ; [4,,4]
+ POPJ P, ; BACK TO DRAWING BOARD
+
+; SUBROUTINE TO ALLOCATE WORDS IN PAIR SPACE. CALLS AGC IF NEEDED
+
+CELL2: MOVEI A,2 ; USUAL CASE
+CELL: PUSHJ P,ICELL ; INTERNAL
+ JRST .+2 ; LOSER
+ POPJ P,
+
+ ADDM A,GETNUM ; AMOUNT REQUIRED
+ PUSH P,A ; PREVENT AGC DESTRUCTION
+ MOVE C,[3,,1] ; INDICATOR FOR AGC
+ PUSHJ P,INQAGC
+ POP P,A
+ JRST CELL ; AND TRY AGAIN
+
+; INTERNAL CELL GETTER, SKIPS IF ROO EXISTS, ELSE DOESN'T
+
+ICELL2: MOVEI A,2 ; MOST LIKELY CAE
+ICELL: SKIPE B,RCL
+ JRST ICELRC ;SEE IF WE CAN RE-USE A RECYCLE CELL
+ MOVE B,PARTOP ; GET TOP OF PAIRS
+ ADDI B,(A) ; BUMP
+ CAMLE B,FRETOP ; SKIP IF OK.
+ JRST VECTRY ; LOSE
+ EXCH B,PARTOP ; SETUP NEW PARTOP AND RETURN POINTER
+ ADDM A,USEFRE
+ JRST CPOPJ1 ; SKIP RETURN
+
+; TRY RECYCLING USING A VECTOR FROM RCLV
+
+VECTRY: SKIPN B,RCLV ; SKIP IF VECTOR EXISTS
+ POPJ P,
+ PUSH P,C
+ PUSH P,A
+ MOVEI C,RCLV
+VECTR1: HLRZ A,(B) ; GET LENGTH
+ SUB A,(P)
+ JUMPL A,NXTVEC ; DOESN'T SATISFY TRY AGAIN
+ CAIN A,1 ; MAKE SURE NOT LEFT WITH A SINGLE SLOT
+ JRST NXTVEC
+ JUMPN A,SOML ; SOME ARE LEFT
+ HRRZ A,(B)
+ HRRM A,(C)
+ HLRZ A,(B)
+ SETZM (B)
+ SETZM -1(B) ; CLEAR DOPE WORDS
+ SUBI B,-1(A)
+ POP P,A ; CLEAR STACK
+ POP P,C
+ JRST CPOPJ1
+SOML: HRLM A,(B) ; SMASH AMOUNT LEFT
+ SUBI B,-1(A) ; GET TO BEGINNING
+ SUB B,(P)
+ POP P,A
+ POP P,C
+ JRST CPOPJ1
+NXTVEC: MOVEI C,(B)
+ HRRZ B,(B) ; GET NEXT
+ JUMPN B,VECTR1
+ POP P,A
+ POP P,C
+ POPJ P,
+
+ICELRC: CAIE A,2
+ JRST ICELL+2 ;IF HE DOESNT WANT TWO, USE OLD METHOD
+ PUSH P,A
+ MOVE A,(B)
+ HRRZM A,RCL
+ POP P,A
+ SETZM (B) ;GIVE HIM A CLEAN RECYCLED CELL
+ SETZM 1(B)
+ JRST CPOPJ1 ;THAT IT
+
+
+\f;FUNCTION TO BUILD A LIST OF MANY ELEMENTS
+
+IMFUNCTION LIST,SUBR
+ ENTRY
+
+ PUSH P,$TLIST
+LIST12: HLRE A,AB ;GET -NUM OF ARGS
+ PUSH TP,$TAB
+ PUSH TP,AB
+ MOVNS A ;MAKE IT +
+ JUMPE A,LISTN ;JUMP IF 0
+ SKIPE RCL ;SEE IF WE WANT TO DO ONE AT A TIME
+ JRST LST12R ;TO GET RECYCLED CELLS
+ PUSHJ P,CELL ;GET NUMBER OF CELLS
+ PUSH TP,(P) ;SAVE IT
+ PUSH TP,B
+ SUB P,C%11
+ LSH A,-1 ;NUMBER OF REAL LIST ELEMENTS
+
+CHAINL: ADDI B,2 ;LOOP TO CHAIN ELEMENTS
+ HRRZM B,-2(B) ;CHAIN LAST ONE TO NEXT ONE
+ SOJG A,.-2 ;LOOP TIL ALL DONE
+ CLEARM B,-2(B) ;SET THE LAST CDR TO NIL
+
+; NOW LOBEER THE DATA IN TO THE LIST
+
+ MOVE D,AB ; COPY OF ARG POINTER
+ MOVE B,(TP) ;RESTORE LIS POINTER
+LISTLP: GETYP A,(D) ;GET TYPE
+ PUSHJ P,NWORDT ;GET NUMBER OF WORDS
+ SOJN A,LDEFER ;NEED TO DEFER POINTER
+ GETYP A,(D) ;NOW CLOBBER ELEMENTS
+ HRLM A,(B)
+ MOVE A,1(D) ;AND VALUE..
+ MOVEM A,1(B)
+LISTL2: HRRZ B,(B) ;REST B
+ ADD D,C%22 ;STEP ARGS
+ JUMPL D,LISTLP
+
+ POP TP,B
+ POP TP,A
+ SUB TP,C%22 ; CLEANUP STACK
+ JRST FINIS
+
+
+LST12R: ASH A,-1 ;ONE AT A TIME TO GET RECYCLED CELLS
+ JUMPE A,LISTN
+ PUSH P,A ;SAVE COUNT ON STACK
+ SETZM E
+ SETZB C,D
+ PUSHJ P,ICONS
+ MOVE E,B ;LOOP AND CHAIN TOGETHER
+ SOSLE (P)
+ JRST .-4
+ PUSH TP,-1(P) ;PUSH ON THE TYPE WE WANT
+ PUSH TP,B
+ SUB P,C%22 ;CLEAN UP AFTER OURSELVES
+ JRST LISTLP-2 ;AND REJOIN MAIN STREAM
+
+
+; MAKE A DEFERRED POINTER
+
+LDEFER: PUSH TP,$TLIST ;SAVE CURRENT POINTER
+ PUSH TP,B
+ MOVEM D,1(TB) ; SAVE ARG HACKER
+ PUSHJ P,CELL2
+ MOVE D,1(TB)
+ GETYPF A,(D) ;GET FULL DATA
+ MOVE C,1(D)
+ MOVEM A,(B)
+ MOVEM C,1(B)
+ MOVE C,(TP) ;RESTORE LIST POINTER
+ MOVEM B,1(C) ;AND MAKE THIS BE THE VALUE
+ MOVSI A,TDEFER
+ HLLM A,(C) ;AND STORE IT
+ MOVE B,C
+ SUB TP,C%22
+ JRST LISTL2
+
+LISTN: MOVEI B,0
+ POP P,A
+ JRST FINIS
+
+; BUILD A FORM
+
+IMFUNCTION FORM,SUBR
+
+ ENTRY
+
+ PUSH P,$TFORM
+ JRST LIST12
+
+\f; COMPILERS CALLS TO FORM AND LIST A/ COUNT ELEMENTS ON STACK
+
+IILIST: SUBM M,(P)
+ PUSHJ P,IILST
+ MOVSI A,TLIST
+ JRST MPOPJ
+
+IIFORM: SUBM M,(P)
+ PUSHJ P,IILST
+ MOVSI A,TFORM
+ JRST MPOPJ
+
+IILST: JUMPE A,IILST0 ; NIL WHATSIT
+ PUSH P,A
+ MOVEI E,0
+IILST1: POP TP,D
+ POP TP,C
+ PUSHJ P,ICONS ; CONS 'EM UP
+ MOVEI E,(B)
+ SOSE (P) ; COUNT
+ JRST IILST1
+
+ SUB P,C%11
+ POPJ P,
+
+IILST0: MOVEI B,0
+ POPJ P,
+
+\f;FUNCTION TO BUILD AN IMPLICIT LIST
+
+MFUNCTION ILIST,SUBR
+ ENTRY
+ PUSH P,$TLIST
+ILIST2: JUMPGE AB,TFA ;NEED AT LEAST ONE ARG
+ CAMGE AB,C%M40 ; [-4,,0] ; NO MORE THAN TWO ARGS
+ JRST TMA
+ PUSHJ P,GETFIX ; GET POS FIX #
+ JUMPE A,LISTN ;EMPTY LIST ?
+ CAML AB,C%M20 ; [-2,,0] ;ONLY ONE ARG?
+ JRST LOSEL ;YES
+ PUSH P,A ;SAVE THE CURRENT VALUE OF LENGTH FOR LOOP ITERATION
+ILIST0: PUSH TP,2(AB)
+ PUSH TP,(AB)3
+ MCALL 1,EVAL
+ PUSH TP,A
+ PUSH TP,B
+ SOSLE (P)
+ JRST ILIST0
+ POP P,C
+ILIST1: MOVE C,(AB)+1 ;REGOBBLE LENGTH
+ ACALL C,LIST
+ILIST3: POP P,A ; GET FINAL TYPE
+ JRST FINIS
+
+
+LOSEL: PUSH P,A ; SAVE COUNT
+ MOVEI E,0
+
+LOSEL1: SETZB C,D ; TLOSE,,0
+ PUSHJ P,ICONS
+ MOVEI E,(B)
+ SOSLE (P)
+ JRST LOSEL1
+
+ SUB P,C%11
+ JRST ILIST3
+
+; IMPLICIT FORM
+
+MFUNCTION IFORM,SUBR
+
+ ENTRY
+ PUSH P,$TFORM
+ JRST ILIST2
+
+\f; IVECTOR AND IUVECTOR--GET VECTOR AND UVECTOR OF COMPUTED VALUES
+
+MFUNCTION VECTOR,SUBR,[IVECTOR]
+
+ MOVEI C,1
+ JRST VECTO3
+
+MFUNCTION UVECTOR,SUBR,[IUVECTOR]
+
+ MOVEI C,0
+VECTO3: ENTRY
+ JUMPGE AB,TFA ; AT LEAST ONE ARG
+ CAMGE AB,C%M40 ; [-4,,0] ; NOT MORE THAN 2
+ JRST TMA
+ PUSHJ P,GETFIX ; GET A POS FIXED NUMBER
+ LSH A,(C) ; A-> NUMBER OF WORDS
+ PUSH P,C ; SAVE FOR LATER
+ PUSHJ P,IBLOCK ; GET BLOCK (TURN ON BIT APPROPRIATELY)
+ POP P,C
+ HLRE A,B ; START TO
+ SUBM B,A ; FIND DOPE WORD
+ MOVSI D,.VECT. ; FOR GCHACK
+ IORM D,(A)
+ JUMPE C,VECTO4
+ MOVSI D,400000 ; GET NOT UNIFORM BIT
+ IORM D,(A) ; INTO DOPE WORD
+ SKIPA A,$TVEC ; GET TYPE
+VECTO4: MOVSI A,TUVEC
+ CAML AB,C%M20 ; [-2,,0] ; SKIP IF ARGS NEED TO BE HACKED
+ JRST FINIS
+ JUMPGE B,FINIS ; DON'T EVAL FOR EMPTY CASE
+
+ PUSH TP,A ; SAVE THE VECTOR
+ PUSH TP,B
+ PUSH TP,A
+ PUSH TP,B
+
+ JUMPE C,UINIT
+ JUMPGE B,FINIS ; EMPTY VECTOR, LEAVE
+INLP: PUSHJ P,IEVAL ; EVAL EXPR
+ MOVEM A,(C)
+ MOVEM B,1(C)
+ ADD C,C%22 ; BUMP VECTOR
+ MOVEM C,(TP)
+ JUMPL C,INLP ; IF MORE DO IT
+
+GETVEC: MOVE A,-3(TP)
+ MOVE B,-2(TP)
+ SUB TP,C%44 ; [4,,4]
+ JRST FINIS
+
+; HERE TO FILL UP A UVECTOR
+
+UINIT: PUSHJ P,IEVAL ; HACK THE 1ST VALUE
+ GETYP A,A ; GET TYPE
+ PUSH P,A ; SAVE TYPE
+ PUSHJ P,NWORDT ; SEE IF IT CAN BE UNIFORMED
+ SOJN A,CANTUN ; COMPLAIN
+STJOIN: MOVE C,(TP) ; RESTORE POINTER
+ ADD C,1(AB) ; POINT TO DOPE WORD
+ MOVE A,(P) ; GET TYPE
+ HRLZM A,(C) ; STORE IN D.W.
+ MOVSI D,.VECT. ; FOR GCHACK
+ IORM D,(C)
+ MOVE C,(TP) ; GET BACK VECTOR
+ SKIPE 1(AB)
+ JRST UINLP1 ; START FILLING UV
+ JRST GETVE1
+
+UINLP: MOVEM C,(TP) ; SAVE PNTR
+ PUSHJ P,IEVAL ; EVAL THE EXPR
+ GETYP A,A ; GET EVALED TYPE
+ CAIE A,@(P) ; WINNER?
+ JRST WRNGSU ; SERVICE ERROR FOR UVECTOR,STORAGE
+UINLP1: MOVEM B,(C) ; STORE
+ AOBJN C,UINLP
+GETVE1: SUB P,C%11
+ JRST GETVEC ; AND RETURN VECTOR
+
+IEVAL: PUSH TP,2(AB)
+ PUSH TP,3(AB)
+ MCALL 1,EVAL
+ MOVE C,(TP)
+ POPJ P,
+
+; ISTORAGE -- GET STORAGE OF COMPUTED VALUES
+
+MFUNCTION ISTORAGE,SUBR
+ ENTRY
+ JUMPGE AB,TFA
+ CAMGE AB,C%M40 ; [-4,,0] ; AT LEAST ONE ARG
+ JRST TMA
+ PUSHJ P,GETFIX ; POSITIVE COUNT FIRST ARG
+ PUSHJ P,CAFRE ; GET CORE
+ MOVN B,1(AB) ; -COUNT
+ HRL A,B ; PUT IN LHW (A)
+ MOVM B,B ; +COUNT
+ HRLI B,2(B) ; LENGTH + 2
+ ADDI B,(A) ; MAKE POINTER TO DOPE WORDS
+ HLLZM B,1(B) ; PUT TOTAL LENGTH IN 2ND DOPE
+ HRRM A,1(B) ; PUT ADDRESS IN RHW (STORE DOES THIS TOO).
+ MOVE B,A
+ MOVSI A,TSTORAGE
+ CAML AB,C%M20 ; [-2,,0] ; SECOND ARG TO EVAL?
+ JRST FINIS ; IF NOT, RETURN EMPTY
+ PUSH TP,A
+ PUSH TP,B
+ PUSH TP,A
+ PUSH TP,B
+ PUSHJ P,IEVAL ; EVALUATE FOR FIRST VALUE
+ GETYP A,A
+ PUSH P,A ; FOR COMPARISON LATER
+ PUSHJ P,SAT
+ CAIN A,S1WORD
+ JRST STJOIN ;TREAT LIKE A UVECTOR
+; IF NOT 1-WORD TYPES, CANNOT STORE, SO COMPLAIN
+ PUSHJ P,FREESV ; FREE STORAGE VECTOR
+ ERRUUO EQUOTE DATA-CANT-GO-IN-STORAGE
+
+; FOR STORAGE, MUST FREE THE CORE ELSE IT IS LOST (NO GC)
+FREESV: MOVE A,1(AB) ; GET COUNT
+ ADDI A,2 ; FOR DOPE
+ HRRZ B,(TP) ; GET ADDRESS
+ PUSHJ P,CAFRET ; FREE THE CORE
+ POPJ P,
+
+\f
+; INTERNAL VECTOR ALLOCATOR. A/SIZE OF VECTOR (NOT INCLUDING DOPE WORDS)
+
+IBLOK1: ASH A,1 ; TIMES 2
+GIBLOK: TLOA A,400000 ; FUNNY BIT
+IBLOCK: TLZ A,400000 ; NO BIT ON
+ TLO A,.VECT. ; TURN ON BIT FOR GCHACK
+ ADDI A,2 ; COMPENSATE FOR DOPE WORDS
+IBLOK2: SKIPE B,RCLV ; ANY TO RECYCLE?
+ JRST RCLVEC
+NORCL: MOVE B,GCSTOP ; POINT TO BOTTOM OF SPACE
+ PUSH P,B ; SAVE TO BUILD PTR
+ ADDI B,(A) ; ADD NEEDED AMOUNT
+ CAML B,FRETOP ; SKIP IF NO GC NEEDED
+ JRST IVECT1
+ MOVEM B,GCSTOP ; WIN, GET POINTER TO BLOCK AND UPDATE VECBOT
+ ADDM A,USEFRE
+ HRRZS USEFRE
+ HRLZM A,-1(B) ; STORE LENGTH IN DOPE WORD
+ HLLZM A,-2(B) ; AND BIT
+ HRLI A,-1(B) ; SMASH IN RELOCATION
+ HLRM A,-1(B)
+ POP P,B ; RESTORE PTR TO BOTTOM OF VECTOR
+ HRROS B ; POINT TO START OF VECTOR
+ TLC B,-3(A) ; SETUP COUNT
+ HRRI A,TVEC
+ SKIPL A
+ HRRI A,TUVEC
+ MOVSI A,(A)
+ POPJ P,
+
+; HERE TO DO A GC ON A VECTOR ALLOCATION
+
+IVECT1: PUSH P,0
+ PUSH P,A ; SAVE DESIRED LENGTH
+ HRRZ 0,A
+ ADDM 0,GETNUM ; AND STORE AS DESIRED AMOUNT
+ MOVE C,[4,,1] ; GET INDICATOR FOR AGC
+ PUSHJ P,INQAGC
+ POP P,A
+ POP P,0
+ POP P,B
+ JRST IBLOK2
+
+
+; INTERNAL EVECTOR (CALLED FROM READ) A/ #OF THINGS
+; ITEMS ON TOP OF STACK
+
+IEVECT: ASH A,1 ; TO NUMBER OF WORDS
+ PUSH P,A
+ PUSHJ P,IBLOCK ; GET VECTOR
+ HLRE D,B ; FIND DW
+ SUBM B,D ; A POINTS TO DW
+ MOVSI 0,400000+.VECT.
+ MOVEM 0,(D) ; CLOBBER NON UNIF BIT
+ POP P,A ; RESTORE COUNT
+ JUMPE A,IVEC1 ; 0 LNTH, DONE
+ MOVEI C,(TP) ; BUILD BLT
+ SUBI C,(A)-1 ; C POINTS TO 1ST ITEM ON STACK
+ MOVSI C,(C)
+ HRRI C,(B) ; B/ SOURCE,,DEST
+ BLT C,-1(D) ; XFER THE DATA
+ HRLI A,(A)
+ SUB TP,A ; FLUSH STACKAGE
+IVEC1: MOVSI A,TVEC
+ POPJ P,
+
+
+; COMPILERS CALL
+
+CIVEC: SUBM M,(P)
+ PUSHJ P,IEVECT
+ JRST MPOPJ
+
+
+\f; INTERNAL CALL TO EUVECTOR
+
+IEUVEC: PUSH P,A ; SAVE LENGTH
+ PUSHJ P,IBLOCK
+ MOVE A,(P)
+ JUMPE A,IEUVE1 ; EMPTY, LEAVE
+ ASH A,1 ; NOW FIND STACK POSITION
+ MOVEI C,(TP) ; POINT TO TOP
+ MOVE D,B ; COPY VEC POINTER
+ SUBI C,-1(A) ; POINT TO 1ST DATUM
+ GETYP A,(C) ; CHECK IT
+ PUSHJ P,NWORDT
+ SOJN A,CANTUN ; WONT FIT
+ GETYP E,(C)
+
+IEUVE2: GETYP 0,(C) ; TYPE OF EL
+ CAIE 0,(E) ; MATCH?
+ JRST WRNGUT
+ MOVE 0,1(C)
+ MOVEM 0,(D) ; CLOBBER
+ ADDI C,2
+ AOBJN D,IEUVE2 ; LOOP
+ TRO E,.VECT.
+ HRLZM E,(D) ; STORE UTYPE
+IEUVE1: POP P,A ; GET COUNY
+ ASH A,1 ; MUST FLUSH 2 TIMES # OF ELEMENTS
+ HRLI A,(A)
+ SUB TP,A ; CLEAN UP STACK
+ MOVSI A,TUVEC
+ POPJ P,
+
+; COMPILER'S CALL
+
+CIUVEC: SUBM M,(P)
+ PUSHJ P,IEUVEC
+ JRST MPOPJ
+
+IMFUNCTION EVECTOR,SUBR,[VECTOR]
+ ENTRY
+ HLRE A,AB
+ MOVNS A
+ PUSH P,A ;SAVE NUMBER OF WORDS
+ PUSHJ P,IBLOCK ; GET WORDS
+ MOVEI D,-1(B) ; SETUP FOR BLT AND DOPE CLOBBER
+ JUMPGE B,FINISV ;DONT COPY A ZERO LENGTH VECTOR
+
+ HRLI C,(AB) ;START BUILDING BLT POINTER
+ HRRI C,(B) ;TO ADDRESS
+ ADDI D,@(P) ;SET D TO FINAL ADDRESS
+ BLT C,(D)
+FINISV: MOVSI 0,400000+.VECT.
+ MOVEM 0,1(D) ; MARK AS GENERAL
+ SUB P,C%11
+ MOVSI A,TVEC
+ JRST FINIS
+
+
+
+\f;EXPLICIT VECTORS FOR THE UNIFORM CSE
+
+IMFUNCTION EUVECTOR,SUBR,[UVECTOR]
+
+ ENTRY
+ HLRE A,AB ;-NUM OF ARGS
+ MOVNS A
+ ASH A,-1 ;NEED HALF AS MANY WORDS
+ PUSH P,A
+ JUMPGE AB,EUV1 ; DONT CHECK FOR EMPTY
+ GETYP A,(AB) ;GET FIRST ARG
+ PUSHJ P,NWORDT ;SEE IF NEEDS EXTRA WORDS
+ SOJN A,CANTUN
+EUV1: POP P,A
+ PUSHJ P,IBLOCK ; GET VECT
+ JUMPGE B,FINISU
+
+ GETYP C,(AB) ;GET THE FIRST TYPE
+ MOVE D,AB ;COPY THE ARG POINTER
+ MOVE E,B ;COPY OF RESULT
+
+EUVLP: GETYP 0,(D) ;GET A TYPE
+ CAIE 0,(C) ;SAME?
+ JRST WRNGUT ;NO , LOSE
+ MOVE 0,1(D) ;GET GOODIE
+ MOVEM 0,(E) ;CLOBBER
+ ADD D,C%22 ;BUMP ARGS POINTER
+ AOBJN E,EUVLP
+
+ TRO C,.VECT.
+ HRLM C,(E) ;CLOBBER UNIFORM TYPE IN
+FINISU: MOVSI A,TUVEC
+ JRST FINIS
+
+WRNGSU: GETYP A,-1(TP)
+ CAIE A,TSTORAGE
+ JRST WRNGUT ;IF UVECTOR
+ PUSHJ P,FREESV ;FREE STORAGE VECTOR
+ ERRUUO EQUOTE TYPES-DIFFER-IN-STORAGE-OBJECT
+
+WRNGUT: ERRUUO EQUOTE TYPES-DIFFER-IN-UNIFORM-VECTOR
+
+CANTUN: ERRUUO EQUOTE DATA-CANT-GO-IN-UNIFORM-VECTOR
+
+BADNUM: ERRUUO EQUOTE NEGATIVE-ARGUMENT
+\f; FUNCTION TO GROW A VECTOR
+REPEAT 0,[
+MFUNCTION GROW,SUBR
+
+ ENTRY 3
+
+ MOVEI D,0 ;STACK HACKING FLAG
+ GETYP A,(AB) ;FIRST TYPE
+ PUSHJ P,SAT ;GET STORAGE TYPE
+ GETYP B,2(AB) ;2ND ARG
+ CAIE A,STPSTK ;IS IT ASTACK
+ CAIN A,SPSTK
+ AOJA D,GRSTCK ;YES, WIN
+ CAIE A,SNWORD ;UNIFORM VECTOR
+ CAIN A,S2NWORD ;OR GENERAL
+GRSTCK: CAIE B,TFIX ;IS 2ND FIXED
+ JRST WTYP2 ;COMPLAIN
+ GETYP B,4(AB)
+ CAIE B,TFIX ;3RD ARG
+ JRST WTYP3 ;LOSE
+
+ MOVEI E,1 ;UNIFORM/GENERAL FLAG
+ CAIE A,SNWORD ;SKIP IF UNIFORM
+ CAIN A,SPSTK ;DONT SKIP IF UNIFORM PDL
+ MOVEI E,0
+
+ HRRZ B,1(AB) ;POINT TO START
+ HLRE A,1(AB) ;GET -LENGTH
+ SUB B,A ;POINT TO DOPE WORD
+ SKIPE D ;SKIP IF NOT STACK
+ ADDI B,PDLBUF ;FUDGE FOR PDL
+ HLLZS (B) ;ZERO OUT GROWTH SPECS
+ SKIPN A,3(AB) ;ANY TOP GROWTH?
+ JRST GROW1 ;NO, LOOK FOR BOTTOM GROWTH
+ ASH A,(E) ;MULT BY 2 IF GENERAL
+ ADDI A,77 ;ROUND TO NEAREST BLOCK
+ ANDCMI A,77 ;CLEAR LOW ORDER BITS
+ ASH A,9-6 ;DIVIDE BY 100 AND SHIFT TO POSTION
+ TRZE A,400000 ;CONVERT TO SIGN MAGNITUDE
+ MOVNS A
+ TLNE A,-1 ;SKIP IF NOT TOO BIG
+ JRST GTOBIG ;ERROR
+GROW1: SKIPN C,5(AB) ;CHECK LOW GROWTH
+ JRST GROW4 ;NONE, SKIP
+ ASH C,(E) ;GENRAL FUDGE
+ ADDI C,77 ;ROUND
+ ANDCMI C,77 ;FUDGE FOR VALUE RETURN
+ PUSH P,C ;AND SAVE
+ ASH C,-6 ;DIVIDE BY 100
+ TRZE C,400 ;CONVERT TO SIGN MAGNITUDE
+ MOVNS C
+ TDNE C,[-1,,777000] ;CHECK FOR OVERFLOW
+ JRST GTOBIG
+GROW2: HLRZ E,1(B) ;GET TOTAL LENGTH OF VECTOR
+ MOVNI E,-1(E)
+ HRLI E,(E) ;TO BOTH HALVES
+ ADDI E,1(B) ;POINTS TO TOP
+ SKIPE D ;STACK?
+ ADD E,[PDLBUF,,0] ;YES, FUDGE LENGTH
+ SKIPL D,(P) ;SHRINKAGE?
+ JRST GROW3 ;NO, CONTINUE
+ MOVNS D ;PLUSIFY
+ HRLI D,(D) ;TO BOTH HALVES
+ ADD E,D ;POINT TO NEW LOW ADDR
+GROW3: IORI A,(C) ;OR TOGETHER
+ HRRM A,(B) ;DEPOSIT INTO DOPEWORD
+ PUSH TP,(AB) ;PUSH TYPE
+ PUSH TP,E ;AND VALUE
+ SKIPE A ;DON'T GC FOR NOTHING
+ MOVE C,[2,,0] ; GET INDICATOR FOR AGC
+ PUSHJ P,AGC
+ JUMPL A,GROFUL
+ POP P,C ;RESTORE GROWTH
+ HRLI C,(C)
+ POP TP,B ;GET VECTOR POINTER
+ SUB B,C ;POINT TO NEW TOP
+ POP TP,A
+ JRST FINIS
+
+GROFUL: SUB P,C%11 ; CLEAN UP STACK
+ SUB TP,C%22
+ PUSHJ P,FULLOS
+ JRST GROW
+
+GTOBIG: ERRUUO EQUOTE ATTEMPT-TO-GROW-VECTOR-TOO-MUCH
+GROW4: PUSH P,[0] ;0 BOTTOM GROWTH
+ JRST GROW2
+]
+FULLOS: ERRUUO EQUOTE NO-STORAGE
+
+
+\f; SUBROUTINE TO BUILD CHARACTER STRING GOODIES
+
+MFUNCTION BYTES,SUBR
+
+ ENTRY
+ MOVEI D,1
+ JUMPGE AB,TFA
+ GETYP 0,(AB)
+ CAIE 0,TFIX
+ JRST WTYP1
+ MOVE E,1(AB)
+ ADD AB,C%22
+ JRST STRNG1
+
+IMFUNCTION STRING,SUBR
+
+ ENTRY
+
+ MOVEI D,0
+ MOVEI E,7
+STRNG1: MOVE B,AB ;COPY ARG POINTER
+ MOVEI C,0 ;INITIALIZE COUNTER
+ PUSH TP,$TAB ;SAVE A COPY
+ PUSH TP,B
+ HLRE A,B ; GET # OF ARGS
+ MOVNS A
+ ASH A,-1 ; 1/2 FOR # OF ARGS
+ PUSHJ P,IISTRN
+ JRST FINIS
+
+IISTRN: PUSH P,E
+ JUMPL E,OUTRNG
+ CAILE E,36.
+ JRST OUTRNG
+ SKIPN E,A ; SKIP IF ARGS EXIST
+ JRST MAKSTR ; ALL DONE
+
+STRIN2: GETYP 0,(B) ;GET TYPE CODE
+ CAMN 0,SING(D) ; SINGLE CHARACTER OR FIX?
+ AOJA C,STRIN1
+ CAME 0,MULTI(D) ; OR STRING OR BYTE-STRING
+ JRST WRONGT ;NEITHER
+ HRRZ 0,(B) ; GET CHAR COUNT
+ ADD C,0 ; AND BUMP
+
+STRIN1: ADD B,C%22
+ SOJG A,STRIN2
+
+; NOW GET THE NECESSARY VECTOR
+
+MAKSTR: HRL C,MULTI(D) ; FINAL TYPE,, CHAR COUNT
+ PUSH P,C ; SAVE CHAR COUNT
+ PUSH P,E ; SAVE ARG COUNT
+ MOVEI D,36.
+ IDIV D,-2(P) ; A==> BYTES PER WORD
+ MOVEI A,(C) ; LNTH+4 TO A
+ ADDI A,-1(D)
+ IDIVI A,(D)
+ LSH E,12.
+ MOVE D,-2(P)
+ DPB D,[060600,,E]
+ HRLM E,-2(P) ; SAVE REMAINDER
+ PUSHJ P,IBLOCK
+
+ POP P,A
+ JUMPGE B,DONEC ; 0 LENGTH, NO STRING
+ HRLI B,440000 ;CONVERT B TO A BYTE POINTER
+ HRRZ 0,-1(P) ; BYTE SIZE
+ DPB 0,[300600,,B]
+ MOVE C,(TP) ; POINT TO ARGS AGAIN
+
+NXTRG1: GETYP D,(C) ;GET AN ARG
+ CAIN D,TFIX
+ JRST .+3
+ CAIE D,TCHRS
+ JRST TRYSTR
+ MOVE D,1(C) ; GET IT
+ IDPB D,B ;AND DEPOSIT IT
+ JRST NXTARG
+
+TRYSTR: MOVE E,1(C) ;GET BYTER
+ HRRZ 0,(C) ;AND COUNT
+NXTCHR: SOJL 0,NXTARG ; IF RUNOUT, GET NEXT ARG
+ ILDB D,E ;AND GET NEXT
+ IDPB D,B ; AND DEPOSIT SAME
+ JRST NXTCHR
+
+NXTARG: ADD C,C%22 ;BUMP ARG POINTER
+ SOJG A,NXTRG1
+ ADDI B,1
+
+DONEC: MOVSI C,TCHRS+.VECT.
+ TLO B,400000
+ HLLM C,(B) ;AND CLOBBER AWAY
+ HLRZ C,1(B) ;GET LENGTH BACK
+ POP P,A
+ SUBI B,-1(C)
+ HLL B,(P) ;MAKE A BYTE POINTER
+ SUB P,C%11
+ POPJ P,
+
+SING: TCHRS
+ TFIX
+
+MULTI: TCHSTR
+ TBYTE
+
+
+; COMPILER'S CALL TO MAKE A STRING
+
+CISTNG: TDZA D,D
+
+; COMPILERS CALL TO MAKE A BYTE STRING
+
+CBYTES: MOVEI D,1
+ SUBM M,(P)
+ MOVEI C,0 ; INIT CHAR COUNTER
+ MOVEI B,(A) ; SET UP STACK POINTER
+ ASH B,1 ; * 2 FOR NO. OF SLOTS
+ HRLI B,(B)
+ SUBM TP,B ; B POINTS TO ARGS
+ PUSH P,D
+ MOVEI E,7
+ JUMPE D,CBYST
+ GETYP 0,1(B) ; CHECK BYTE SIZE
+ CAIE 0,TFIX
+ JRST WRONGT
+ MOVE E,2(B)
+ ADD B,C%22
+ SUBI A,1
+CBYST: ADD B,C%11
+ PUSH TP,$TTP
+ PUSH TP,B
+ PUSHJ P,IISTRN ; MAKE IT HAPPEN
+ MOVE TP,(TP) ; FLUSH ARGS
+ SUB TP,C%11
+ POP P,D
+ JUMPE D,MPOPJ
+ SUB TP,C%22
+ JRST MPOPJ
+
+\f;BUILD IMPLICT STRING
+
+MFUNCTION IBYTES,SUBR
+
+ ENTRY
+
+ CAML AB,C%M20 ; [-3,,] ; AT LEAST 2
+ JRST TFA
+ CAMGE AB,C%M60 ; [-7,,] ; NO MORE THAN 3
+ JRST TMA
+ PUSHJ P,GETFIX ; GET BYTE SIZE
+ JUMPL A,OUTRNG
+ CAILE A,36.
+ JRST OUTRNG
+ PUSH P,[TFIX]
+ PUSH P,A
+ PUSH P,$TBYTE
+ ADD AB,C%22
+ MOVEM AB,ABSAV(TB)
+ JRST ISTR1
+
+MFUNCTION ISTRING,SUBR
+
+ ENTRY
+ JUMPGE AB,TFA ; TOO FEW ARGS
+ CAMGE AB,C%M40 ; [-4,,0] ; VERIFY NOT TOO MANY ARGS
+ JRST TMA
+ PUSH P,[TCHRS]
+ PUSH P,[7]
+ PUSH P,$TCHSTR
+ISTR1: PUSHJ P,GETFIX
+ MOVEI C,36.
+ IDIV C,-1(P)
+ ADDI A,-1(C)
+ IDIVI A,(C) ; # OF WORDS NEEDED TO A
+ ASH D,12.
+ MOVE C,-1(P) ; GET BYTE SIZE
+ DPB C,[060600,,D]
+ PUSH P,D
+ PUSHJ P,IBLOCK
+ HLRE C,B ; -LENGTH TO C
+ SUBM B,C ; LOCN OF DOPE WORD TO C
+ HRLI D,TCHRS+.VECT. ; CLOBBER ITS TYPE
+ HLLM D,(C)
+ MOVE A,-1(P)
+ HRR A,1(AB) ; SETUP TYPE'S RH
+ SUBI B,1
+ HRL B,(P) ; AND BYTE POINTER
+ SUB P,C%33
+ SKIPE (AB)+1 ; SKIP IF NO CHARACTERS TO DEPOSIT
+ CAML AB,C%M20 ; [-2,,0] ; SKIP IF 2 ARGS GIVEN
+ JRST FINIS
+ PUSH TP,A ;SAVE OUR STRING
+ PUSH TP,B
+ PUSH TP,A ;SAVE A TEMPORARY CLOBBER POINTER
+ PUSH TP,B
+ PUSH P,(AB)1 ;SAVE COUNT
+ PUSH TP,(AB)+2
+ PUSH TP,(AB)+3
+CLOBST: PUSH TP,-1(TP)
+ PUSH TP,-1(TP)
+ MCALL 1,EVAL
+ GETYP C,A ; CHECK IT
+ CAME C,-1(P) ; MUST BE A CHARACTER
+ JRST WTYP2
+ IDPB B,-2(TP) ;CLOBBER
+ SOSLE (P) ;FINISHED?
+ JRST CLOBST ;NO
+ SUB P,C%22
+ SUB TP,C%66
+ MOVE A,(TP)+1
+ MOVE B,(TP)+2
+ JRST FINIS
+
+\f
+; HERE TO CHECK TO SEE WHETHER PURE RSUBR'S ARE MAPPED BELOW FRETOP AND
+; PUNT SOME IF THERE ARE.
+
+INQAGC: PUSH P,C
+ PUSH P,B
+ PUSH P,A
+ PUSH P,E
+ PUSHJ P,SQKIL
+ JSP E,CKPUR ; CHECK FOR PURE RSUBR
+ POP P,E
+ MOVE A,PURTOP
+ SUB A,CURPLN
+ MOVE B,RFRETP ; GET REAL FRETOP
+ CAIL B,(A)
+ MOVE B,A ; TOP OF WORLD
+ MOVE A,GCSTOP
+ ADD A,GETNUM
+ ADDI A,1777 ; PAGE BOUNDARY
+ ANDCMI A,1777
+ CAIL A,(B) ; SEE WHETHER THERE IS ROOM
+ JRST GOTOGC
+ PUSHJ P,CLEANT
+ POP P,A
+ POP P,B
+ POP P,C
+ POPJ P,
+GOTOGC: POP P,A
+ POP P,B
+ POP P,C ; RESTORE CAUSE INDICATOR
+ MOVE A,P.TOP
+ PUSHJ P,CLEANT ; CLEAN UP
+ SKIPL PLODR ; IF IN PLOAD DON'T INTERRUPT
+ JRST INTAGC ; GO CAUSE GARBAGE COLLECT
+ JRST SAGC
+
+CLEANT: PUSH P,C
+ PUSH P,A
+ SUB A,P.TOP
+ ASH A,-PGSZ
+ JUMPE A,CLNT1
+ PUSHJ P,GETPAG ; GET THOSE PAGES
+ FATAL CAN'T GET PAGES NEEDED
+ MOVE A,(P)
+ ASH A,-10. ; TO PAGES
+ PUSHJ P,P.CORE
+ PUSHJ P,SLEEPR
+CLNT1: PUSHJ P,RBLDM
+ POP P,A
+ POP P,C
+ POPJ P,
+
+\f; RCLVEC DISTASTEFUL VECTOR RECYCLER
+
+; Arrive here with B pointing to first recycler, A desired length
+
+RCLVEC: PUSH P,D ; Save registers
+ PUSH P,C
+ PUSH P,E
+ MOVEI D,RCLV ; Point to previous recycle for splice
+RCLV1: HLRZ C,(B) ; Get size of this block
+ CAIL C,(A) ; Skip if too small
+ JRST FOUND1
+
+RCLV2: MOVEI D,(B) ; Save previous pointer
+ HRRZ B,(B) ; Point to next block
+ JUMPN B,RCLV1 ; Jump if more blocks
+
+ POP P,E
+ POP P,C
+ POP P,D
+ JRST NORCL ; Go to normal allocator
+
+
+FOUND1: CAIN C,1(A) ; Exactly 1 greater?
+ JRST RCLV2 ; Cant use this guy
+
+ HRLM A,(B) ; Smash in new count
+ TLO A,.VECT. ; make vector bit be on
+ HLLM A,-1(B)
+ CAIE C,(A) ; Exactly right length?
+ JRST FOUND2 ; No, do hair
+
+ HRRZ C,(B) ; Point to next block
+ HRRM C,(D) ; Smash previous pointer
+ HRRM B,(B)
+ SUBI B,-1(A) ; Point to top of block
+ JRST FOUND3
+
+FOUND2: SUBI C,(A) ; Amount of left over to C
+ HRRZ E,(B) ; Point to next block
+ HRRM B,(B)
+ SUBI B,(A) ; Point to dope words of guy to put back
+ MOVSM C,(B) ; Smash in count
+ MOVSI C,.VECT. ; Get vector bit
+ MOVEM C,-1(B) ; Make sure it is a vector
+ HRRM B,(D) ; Splice him in
+ HRRM E,(B) ; And the next guy also
+ ADDI B,1 ; Point to start of vector
+
+FOUND3: HRROI B,(B) ; Make an AOBJN pointer
+ TLC B,-3(A)
+ HRRI A,TVEC
+ SKIPGE A
+ HRRI A,TUVEC
+ MOVSI A,(A)
+ POP P,E
+ POP P,C
+ POP P,D
+ POPJ P,
+
+END
+\f
\ No newline at end of file
--- /dev/null
+
+ TITLE STRBUILD MUDDLE STRUCTURE BUILDER
+
+.GLOBAL RCL,VECTOP,GCSTOP,GCSBOT,FRETOP,GCSNEW,VECBOT,PARTOP,PARBOT,HITOP,HIBOT,GETPAG
+.GLOBAL PDLBUF,PDLEX,PDLEXP,GCFLG,GCPDL,GETNUM,PARNEW,MOVPUR,RCLV,RCLVEC
+.GLOBAL PGROW,TPGROW,MAINPR,%SLEEP,MSGTYP,PURTOP,PURBOT,STOSTR,RBLDM,CPOPJ,CPOPJ1,STBL
+.GLOBAL MTYI,UPLO,FRMUNG,BYTDOP,GLOBSP,FREDIF,FREMIN,GCHAPN,INTFLG,PINIT,CKPUR,GCSET
+.GLOBAL SAT,TTOCHN,TYPVEC,ICONS,INCONS,IBLOCK,IEUVEC,IEVECTI,CELL2,MKTBS,CPOPJ1,.LIST.
+.GLOBAL GIBLOK,REHASH,IBLOK1,IILIST,IIFORM,CIVEC,CIUVEC,CICONS,SLEEPR,GCHK10,FPAG
+.GLOBAL SPBASE,OUTRNG,CISTNG,CBYTES,%RUNAM,PURVEC,GCDOWN,N.CHNS,CHNL1,PLODR,C1CONS
+.GLOBAL CAFRE,CAFRET,STOGC,GCHN,WNDP,FRNP,FRONT,%GCJOB,%SHWND,%INFMP,%GETIP
+.GLOBAL TD.PUT,TD.GET,TD.LNT,GLOTOP,UBIT,FLGSET,PURMNG,RPURBT,%IFMP2,CHKPGI,PURCLN
+.GLOBAL CTIME,MTYO,ILOC,NODES,GPURFL,GCDANG,GCHACK,LPUR,HITOP,BADCHN,IMPURX
+.GLOBAL NOWLVL,CURPLN,PVSTOR,SPSTOR,MPOPJ,NGCS,RNUMSP,NUMSWP,SAGC,INQAGC
+.GLOBAL GCTIM,GCCAUS,GCCALL,AAGC,LVLINC,STORIC,GVLINC,TYPIC,GCRSET,ACCESS,NOSHUF,SQUPNT
+; GLOBALS ASSOCIATE WITH THE ASSOCIATION VECTOR
+
+.GLOBAL ASOVEC,ASOLNT,ITEM,INDIC,VAL,NWORDT,NODPNT,PNTRS
+.GLOBAL CELL,BINDID,GCFLCH,TYPBOT,GLOBAS,TPBASE
+.GLOBAL TPBINC,GBLINC,TYPINC,CONADJ,OGCSTP,ABOTN
+.GLOBAL AGC,ROOT,CIGTPR,IIGLOC
+.GLOBAL P.TOP,P.CORE,PMAPB
+.GLOBAL %MPINT,%GBINT,%CLSMP,%CLSM1
+.GLOBAL GCKNUM,CORTOP,GCHPN,INTAGC,WNDP,WNDBOT,BUFGC,WIND,GCDFLG,SAVM
+
+; SHARED SYMBOLS WITH GC MODULE
+
+.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,PMIN,PURMIN
+.GLOBAL GLBINC,GCHAIR,GCMONF,SQKIL,INBLOT
+.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
+
+NOPAGS==1 ; NUMBER OF WINDOWS
+EOFBIT==1000
+PDLBUF=100
+
+.ATOM.==200000 ; FLAG SAYING ATOMS MARKED (FOR VAL FLUSH LOGIC)
+
+GCHN==0 ; CHANNEL FOR FUNNNY INFERIOR
+STATNO==19. ; # OF STATISTICS FOR BLOAT-STAT
+STATGC==8. ; # OF GC-STATISTICS FOR BLOAT-STAT
+
+
+RELOCATABLE
+.INSRT MUDDLE >
+SYSQ
+IFE ITS,[
+.INSRT STENEX >
+]
+IFN ITS, PGSZ==10.
+IFE ITS, PGSZ==9.
+
+
+\f; GC-READ TAKES ONE ARGUMENT WHICH MUST BE A "READB" CHANNEL
+
+.GLOBAL CLOOKU,CINSER,MOBLIST,CATOM,EOFCND,IGLOC
+
+MFUNCTION GCREAD,SUBR,[GC-READ]
+
+ ENTRY
+
+ CAML AB,C%M2 ; CHECK # OF ARGS
+ JRST TFA
+ CAMGE AB,C%M40
+ JRST TMA
+
+ GETYP A,(AB) ; MAKE SURE ARG IS A CHANNEL
+ CAIE A,TCHAN
+ JRST WTYP2 ; IT ISN'T COMPLAIN
+ MOVE B,1(AB) ; GET PTR TO CHANNEL
+ HRRZ C,-2(B) ; LOOK AT BITS IN CHANNEL
+ TRC C,C.OPN+C.READ+C.BIN
+ TRNE C,C.OPN+C.READ+C.BIN
+ JRST BADCHN
+
+ PUSH P,1(B) ; SAVE ITS CHANNEL #
+IFN ITS,[
+ MOVE B,[-2,,C] ; SET UP AOBJN PTR TO READ IN DELIMITING
+ ; CONSTANTS
+ MOVE A,(P) ; GET CHANNEL #
+ DOTCAL IOT,[A,B]
+ FATAL GCREAD-- IOT FAILED
+ JUMPL B,EOFGC ; IF BLOCK DIDN'T FINISH THEN EOF
+]
+IFE ITS,[
+ MOVE A,(P) ; GET CHANNEL
+ BIN
+ MOVE C,B ; TO C
+ BIN
+ MOVE D,B ; TO D
+ GTSTS ; SEE IF EOF
+ TLNE B,EOFBIT
+ JRST EOFGC
+]
+
+ PUSH P,C ; SAVE AC'S
+ PUSH P,D
+
+IFN ITS,[
+ MOVE B,[-3,,C] ; NEXT GROUP OF WORDS
+ DOTCAL IOT,[A,B]
+ FATAL GCREAD--GC IOT FAILED
+]
+IFE ITS,[
+ MOVE A,-2(P) ; GET CHANNEL
+ BIN
+ MOVE C,B
+ BIN
+ MOVE D,B
+ BIN
+ MOVE E,B
+]
+ MOVEI 0,0 ; DO PRELIMINARY TESTS
+ IOR 0,A ; IOR ALL WORDS IN
+ IOR 0,B
+ IOR 0,C
+ IOR 0,(P)
+ IOR 0,-1(P)
+ TLNE 0,-1 ; SKIP IF NO BITS IN LEFT HALF
+ JRST ERDGC
+
+ MOVEM D,NNPRI
+ MOVEM E,NNSAT
+ MOVE D,C ; GET START OF NEWTYPE TABLE
+ SUB D,-1(P) ; CREATE AOBJN POINTER
+ HRLZS D
+ ADDI D,(C)
+ MOVEM D,TYPTAB ; SAVE IT
+ MOVE A,(P) ; GET LENGTH OF WORD
+ SUBI A,CONADJ ; SUBTRACT FOR CONSTANTS
+
+ ADD A,GCSTOP
+ CAMG A,FRETOP ; SEE IF GC IS NESESSARY
+ JRST RDGC1
+ ADDM C,GETNUM ; MOVE IN REQUEST
+ MOVE C,[0,,1] ; ARGS TO GC
+ PUSHJ P,INQAGC ; GC
+RDGC1: MOVE C,GCSTOP ; GET CURRENT TOP OF THE WORLD
+ MOVEM C,OGCSTP ; SAVE IT
+ ADD C,(P) ; CALCULATE NEW GCSTOP
+ ADDI C,2 ; SUBTRACT FOR CONSTANTS
+ MOVEM C,GCSTOP
+ SUB C,OGCSTP
+ SUBI C,2 ; SUBSTRACT TO GET RID OF D.W'S
+ MOVNS C ; SET UP AOBJN PTR FOR READIN
+IFN ITS,[
+ HRLZS C
+ MOVE A,-2(P) ; GET CHANNEL #
+ ADD C,OGCSTP
+ DOTCAL IOT,[A,C]
+ FATAL GCREAD-- IOT FAILED
+]
+IFE ITS,[
+ MOVE A,-2(P) ; CHANNEL TO A
+ MOVE B,OGCSTP ; SET UP BYTE POINTER
+ HRLI B,444400
+ SIN ; IN IT COMES
+]
+
+ MOVE C,(P) ; GET LENGHT OF OBJECT
+ ADDI A,5
+ MOVE B,1(AB) ; GET CHANNEL
+ ADDM C,ACCESS(B)
+ MOVE D,GCSTOP ; SET UP TO LOOK LIKE UVECTOR OF LOSES
+ ADDI C,2 ; ADD 2 FOR DOPE WORDS
+ HRLM C,-1(D)
+ MOVSI A,.VECT.
+ SETZM -2(D)
+ IORM A,-2(D) ; MARK VECTOR BIT
+ PUSH TP,$TRDTB ; HOLD ON IN CASE OF GC
+ MOVEI A,-2(D)
+ MOVN C,(P)
+ ADD A,C
+ HRL A,C
+ PUSH TP,A
+
+ MOVE D,-1(P) ; SET UP BOTTOM OF ATOM TABLE
+ SUBI D,1
+ MOVEM D,ABOTN
+ MOVE C,GCSTOP ; START AT TOP OF WORLD
+ SUBI C,3 ; POINT TO FIRST ATOM
+
+; LOOP TO FIX UP THE ATOMS
+
+AFXLP: HRRZ 0,1(TB)
+ ADD 0,ABOTN
+ CAMG C,0 ; SEE IF WE ARE DONE
+ JRST SWEEIN
+ HRRZ 0,1(TB)
+ SUB C,0
+ PUSHJ P,ATFXU ; FIX IT UP
+ HLRZ A,(C) ; GET LENGTH
+ TRZ A,400000 ; TURN OFF MARK BIT
+ SUBI C,(A) ; POINT TO PRECEDING ATOM
+ HRRZS C ; CLEAR OFF NEGATIVE
+ JRST AFXLP
+
+; FIXUP ROUTINE FOR ATOMS (C==> D.W.)
+
+ATFXU: PUSH P,C ; SAVE PTR TO D.W.
+ ADD C,1(TB)
+ MOVE A,C
+ HLRZ B,(A) ; GET LENGTH AND MARKING
+ TRZE B,400000 ; TURN OF MARK BIT AND SKIP IF WAS ALREADY MARKED
+ JRST ATFXU1
+ MOVEI D,-3(B) ; FULL WORDS OF STRING IN PNAME
+ IMULI D,5 ; CALCULATE # OF CHARACTERS
+ MOVE 0,-2(A) ; GET LAST WORD OF STRING
+ SUBI A,-1(B) ; LET A POINT TO OBLIST SLOAT
+ MOVE B,A ; GET COPY OF A
+ MOVE A,0
+ SUBI A,1
+ ANDCM 0,A
+ JFFO 0,.+1
+ HRREI 0,-34.(A)
+ IDIVI 0,7 ; # OF CHARS IN LAST WORD
+ ADD D,0
+ ADD D,$TCHSTR ; MAKE IT LOOK LIKE A STRINGS TYPE-WORD
+ PUSH P,D ; SAVE IT
+ MOVE C,(B) ; GET OBLIST SLOT PTR
+ATFXU9: HRRZS B ; RELATAVIZE POINTER
+ HRRZ 0,1(TB)
+ SUB B,0
+ PUSH P,B
+ JUMPE C,ATFXU6 ; NO OBLIST. CREATE ATOM
+ CAMN C,C%M1 ; SEE IF ROOT ATOM
+ JRST RTFX
+ ADD C,ABOTN ; POINT TO ATOM
+ PUSHJ P,ATFXU
+ PUSH TP,$TATOM
+ PUSH TP,B
+ MOVE A,$TATOM ; SET UP TO SEE IF OBLIST EXITS
+ MOVE C,$TATOM
+ MOVE D,IMQUOTE OBLIST
+ PUSHJ P,CIGTPR
+ JRST ATFXU8 ; NO OBLIST. CREATE ONE
+ SUB TP,C%22 ; GET RID OF SAVED ATOM
+RTCON: PUSH TP,$TOBLS
+ PUSH TP,B
+ MOVE C,B ; SET UP FOR LOOKUP
+ MOVE A,-1(P) ; SET UP PTR TO PNAME
+ MOVE B,(P)
+ ADD B,[440700,,1] ; ADJUST TO MAKE IT LOOK LIKE A BYTE-POINTER
+ HRRZ 0,1(TB)
+ ADD B,0
+ PUSHJ P,CLOOKU
+ JRST ATFXU4 ; NOT ON IT SO INSERT
+ATFXU3: SUB P,C%22 ; DONE
+ SUB TP,C%22 ; POP OFF OBLIST
+ATFXU7: MOVE C,(P) ; RESTORE PTR TO D.W.
+ ADD C,1(TB)
+ MOVEM B,-1(C) ; MOVE IN RELATAVIZE ADDRESS
+ MOVSI D,400000
+ IORM D,(C) ; TURN OFF MARK BIT
+ MOVE 0,3(B) ; SEE IF MUST BE LOCR
+ TRNE 0,1 ; SKIP IF MUST MAKE IT IMPURE
+ PUSHJ P,IIGLOC
+ POP P,C
+ ADD C,1(TB)
+ POPJ P, ; EXIT
+ATFXU1: POP P,C ; RESTORE PTR TO D.W.
+ ADD C,1(TB)
+ MOVE B,-1(C) ; GET ATOM
+ POPJ P,
+
+; ROUTINE TO INSERT AN ATOM
+
+ATFXU4: MOVE C,(TP) ; GET OBLIST PTR
+ MOVE B,(P) ; SET UP STRING PTR TO PNAME
+ ADD B,[440700,,1]
+ HRRZ 0,1(TB)
+ ADD B,0
+ MOVE A,-1(P) ; GET TYPE WORD
+ PUSHJ P,CINSER ; INSERT IT
+ JRST ATFXU3
+
+; THIS ROUTINE CREATS THE ATOM SO THAT ITS NOT ON ANY OBLIST
+
+ATFXU6: MOVE B,(P) ; POINT TO PNAME
+ ADD B,[440700,,1] ; MAKE IT LOOK LIKE A BYTE POINTER
+ HRRZ 0,1(TB)
+ ADD B,0
+ MOVE A,-1(P)
+ PUSHJ P,CATOM
+ SUB P,C%22 ; CLEAN OFF STACK
+ JRST ATFXU7
+
+; THIS ROUTINE CREATES AND OBLIST
+
+ATFXU8: MCALL 1,MOBLIST
+ PUSH TP,$TOBLS
+ PUSH TP,B ; SAVE OBLIST PTR
+ JRST ATFXU4 ; JUMP TO INSERT THE OBLIST
+
+; HERE TO INSERT AN ATOM INTO THE ROOT OBLIST
+
+RTFX: MOVE B,ROOT+1 ; GET ROOT OBLIST
+ JRST RTCON
+
+; THIS ROUTINE SWEEPS THRU THE NEW CORE IMAGE AND UPDATES ALL THE POINTERS.
+
+SWEEIN:
+; ROUTINE TO FIX UP TYPE-TABLE FOR GC-READ. THIS ROUTINE FIXES UP THE TYPE TABLE SO THAT
+; THE TYPES ATOM I.D. IS REPLACED BY ITS TYPE-NUMBER IN THE NEW MUDDLE AND IF ITS A
+; TEMPLATE, THE SLOT FOR THE PRIMTYPE-ATOM IS REPLACED BY THE SAT OF THE TEMPLATE
+
+ HRRZ E,1(TB) ; SET UP TYPE TABLE
+ ADD E,TYPTAB
+ JUMPGE E,VUP ; SKIP OVER IF DONE
+TYPUP1: PUSH P,C%0 ; PUSH SLOT FOR POSSIBLE TEMPLATE ATOM
+ HLRZ A,1(E) ; GET POSSIBLE ATOM SLOT
+ JUMPE A,TYPUP2 ; JUMP IF NOT A TEMPLATE
+ ADD A,ABOTN ; GET ATOM
+ ADD A,1(TB)
+ MOVE A,-1(A)
+ MOVE B,TYPVEC+1 ; GET TYPE VECTOR SLOT FOR LOOP TO SEE IF ITS THERE
+TYPUP3: CAMN A,1(B) ; SKIP IF NOT EQUAL
+ JRST TYPUP4 ; FOUND ONE
+ ADD B,C%22 ; TO NEXT
+ JUMPL B,TYPUP3
+ JRST ERTYP1 ; ERROR NONE EXISTS
+TYPUP4: HRRZ C,(B) ; GET SAT SLOT
+ CAIG C,NUMSAT ; MAKE SURE TYPE IS A TEMPLATE
+ JRST ERTYP2 ; IF NOT COMPLAIN
+ HRLM C,1(E) ; SMASH IN NEW SAT
+ MOVE B,1(B) ; GET ATOM OF PRIMTYPE
+ MOVEM B,(P) ; PUSH ONTO STACK
+TYPUP2: MOVEI D,0 ; INITIALIZE TYPE COUNT FOR LOOKUP LOOP
+ MOVE B,TYPVEC+1 ; GET PTR FOR LOOP
+ HRRZ A,1(E) ; GET TYPE'S ATOM ID
+ ADD A,ABOTN ; GET ATOM
+ ADD A,1(TB)
+ MOVE A,-1(A)
+TYPUP5: CAMN A,1(B) ; SKIP IF NOT EQUAL
+ JRST TYPUP6 ; FOUND ONE
+ ADDI D,1 ; INCREMENT TYPE-COUNT
+ ADD B,C%22 ; POINT TO NEXT
+ JUMPL B,TYPUP5
+ HRRM D,1(E) ; CLOBBER IN TYPE-NUMBER
+ PUSH TP,$TATOM ; PUSH ARGS FOR NEWTYPE
+ PUSH TP,A
+ PUSH TP,$TATOM
+ POP P,B ; GET BACK POSSIBLE PRIMTYPE ATOM
+ JUMPE B,TYPUP7 ; JUMP IF NOT A TEMPLATE
+ PUSH TP,B ; PUSH ON PRIMTYPE
+TYPUP9: SUB E,1(TB)
+ PUSH P,E ; SAVE RELATAVIZED PTR TO TYPE-TABLE
+ MCALL 2,NEWTYPE
+ POP P,E ; RESTORE RELATAVIZED PTR
+ ADD E,1(TB) ; FIX IT UP
+TYPUP0: ADD E,C%22 ; INCREMENT E
+ JUMPL E,TYPUP1
+ JRST VUP
+TYPUP7: HRRZ B,(E) ; FIND PRIMTYPE FROM SAT
+ MOVE A,@STBL(B)
+ PUSH TP,A
+ JRST TYPUP9
+TYPUP6: HRRM D,1(E) ; CLOBBER IN TYPE #
+ JRST TYPUP0
+
+ERTYP1: ERRUUO EQUOTE CANT-FIND-TEMPLATE
+
+ERTYP2: ERRUUO EQUOTE TEMPLATE-TYPE-NAME-NOT-OF-TYPE-TEMPLATE
+
+VUP: HRRZ E,1(TB) ; FIX UP SOME POINTERS
+ MOVEM E,OGCSTP
+ ADDM E,ABOTN
+ ADDM E,TYPTAB
+
+
+; ROUTINE TO SWEEP THRU THE READ-IN IMAGE LOOKING FOR UVECTORS AND TEMPLATES.
+; WHILE SWEEPING IT FIXES UP THE DOPE WORDS APPROPRIATELY.
+
+ HRRZ A,TYPTAB ; GET TO TOP OF WORLD
+ SUBI A,2 ; GET TO FIRST TYPE WORD OR DOPE-WORD OF FIRST OBJECT
+VUP1: CAMG A,OGCSTP ; SKIP IF NOT DONE
+ JRST VUP3
+ HLRZ B,(A) ; GET TYPE SLOT
+ TRNE B,.VECT. ; SKIP IF NOT A VECTOR
+ JRST VUP2
+ SUBI A,2 ; SKIP OVER PAIR
+ JRST VUP1
+VUP2: TRNE B,400000 ; SKIP IF UVECTOR
+ JRST VUP4
+ ANDI B,TYPMSK ; GET RID OF MONITORS
+ CAMG B,NNPRI ; SKIP IF NEWTYPE
+ JRST VUP5
+ PUSHJ P,GETNTP ; GET THE NEW TYPE #
+ PUTYP B,(A) ; SMASH IT IT
+VUP5: HLRZ B,1(A) ; SKIP OVER VECTOR
+ TRZ B,400000 ; GET RID OF POSSIBLE MARK BIT
+ SUBI A,(B)
+ JRST VUP1 ; LOOP
+VUP4: ANDI B,TYPMSK ; FLUSH MONITORS
+ CAMG B,NNSAT ; SKIP IF TEMPLATE
+ JRST VUP5
+ PUSHJ P,GETSAT ; CONVERT TO NEW SAT
+ ADDI B,.VECT. ; MAJIC TO TURN ON BIT
+ PUTYP B,(A)
+ JRST VUP5
+
+
+VUP3: PUSH P,GCSBOT ; SAVE CURRENT GCSBOT
+ MOVE A,OGCSTP ; SET UP NEW GCSBOT
+ MOVEM A,GCSBOT
+ PUSH P,GCSTOP
+ HRRZ A,TYPTAB ; SET UP NEW GCSTOP
+ MOVEM A,GCSTOP
+ SETOM GCDFLG
+ MOVE A,[PUSHJ P,RDFIX] ; INS FOR GCHACK
+ MOVEI PVP,0 ; SAY MIGHT BE NON-ATOMS
+ PUSHJ P,GCHK10
+ SETZM GCDFLG
+ POP P,GCSTOP ; RESTORE GCSTOP
+ MOVE A,1(TB) ; GET A POINTER TO RETURNING VALUES
+ MOVE B,A
+ HLRE C,B
+ SUB B,C
+ SETZM (B)
+ SETZM 1(B)
+ POP P,GCSBOT ; RESTORE GCSBOT
+ MOVE B,1(A) ; GET PTR TO OBJECTS
+ MOVE A,(A)
+ JRST FINIS ; EXIT
+
+; ERROR FOR INCORRECT GCREAD FILE
+
+ERDGC: ERRUUO EQUOTE BAD-GC-READ-FILE
+
+; ROUTINE CALLED BY GCHACK TO UPDATE PTRS IN THE NEW CORE IMAGE
+
+RDFIX: PUSH P,C ; SAVE C
+ PUSH P,B ; SAVE PTR
+ EXCH B,C
+ TLNE C,UBIT ; SKIP IF NOT UVECTOR
+ JRST ELEFX ; DON'T HACK TYPES IN UVECTOR
+ CAIN B,TTYPEC
+ JRST TYPCFX
+ CAIN B,TTYPEW
+ JRST TYPWFX
+ CAML B,NNPRI
+ JRST TYPGFX
+ELEFX: EXCH B,A ; EXCHANGE FOR SAT
+ PUSHJ P,SAT
+ EXCH B,A ; REFIX
+ CAIE B,SLOCR ; REL GLOC'S ARE STORED AS ATOMS
+ CAIN B,SATOM
+ JRST ATFX
+ CAIN B,SCHSTR
+ JRST STFX
+ CAIN B,S1WORD ; SEE IF PRIMTYPE WOR
+ JRST RDLSTF ; LEAVE IF IS
+STFXX: MOVE 0,GCSBOT ; ADJUSTMENT
+ SUBI 0,FPAG+5
+ SKIPE 1(C) ; DON'T CHANGE A PTR TO NIL
+ ADDM 0,1(C) ; FIX UP
+RDLSTF: TLNN C,.LIST. ; SEE IF PAIR
+ JRST RDL1 ; EXIT
+ MOVE 0,GCSBOT ; FIX UP
+ SUBI 0,FPAG+5
+ HRRZ B,(C) ; SEE IF POINTS TO NIL
+ SKIPN B
+ JRST RDL1
+ MOVE B,C ; GET ARG FOR RLISTQ
+ PUSHJ P,RLISTQ
+ JRST RDL1
+ ADDM 0,(C)
+RDL1: POP P,B ; RESTORE B
+ POP P,C
+ POPJ P,
+
+; ROUTINE TO FIX UP PNAMES
+
+STFX: TLZN D,STATM
+ JRST STFXX
+ HLLM D,1(C) ; PUT BACK WITH BIT OFF
+ ADD D,ABOTN
+ ANDI D,-1
+ HLRE 0,-1(D) ; LENGTH OF ATOM
+ MOVNS 0
+ SUBI 0,3 ; VAL & OBLIST
+ IMULI 0,5 ; TO CHARS (SORT OF)
+ HRRZ D,-1(D)
+ ADDI D,2
+ PUSH P,A
+ PUSH P,B
+ LDB A,[360600,,1(C)] ; GET BYTE POS
+ IDIVI A,7 ; TO CHAR POS
+ SKIPE A
+ SUBI A,5
+ HRRZ B,(C) ; STRING LENGTH
+ SUB B,A ; TO WORD BOUNDARY STRING
+ SUBI 0,(B)
+ IDIVI 0,5
+ ADD D,0
+ POP P,B
+ POP P,A
+ HRRM D,1(C)
+ JRST RDLSTF
+
+; ROUTINE TO FIX UP POINTERS TO ATOMS
+
+ATFX: SKIPGE D
+ JRST RDLSTF
+ ADD D,ABOTN
+ MOVE 0,-1(D) ; GET PTR TO ATOM
+ CAIE B,SLOCR ; IF REL LOCATIVE, MORE HAIR
+ JRST ATFXAT
+ MOVE B,0
+ PUSH P,E
+ PUSH P,D
+ PUSH P,C
+ PUSH P,B
+ PUSH P,A
+ PUSHJ P,IGLOC
+ SUB B,GLOTOP+1
+ MOVE 0,B
+ POP P,A
+ POP P,B
+ POP P,C
+ POP P,D
+ POP P,E
+ATFXAT: MOVEM 0,1(C) ; SMASH IT IN
+ JRST RDLSTF ; EXIT
+
+TYPCFX: HRRZ B,1(C) ; GET TYPE
+ PUSHJ P,GETNEW ; GET TYPE IN THIS CORE IMAGE
+ HRRM B,1(C) ; CLOBBER IT IN
+ JRST RDLSTF ; CONTINUE FIXUP
+
+TYPWFX: HLRZ B,1(C) ; GET TYPE
+ PUSHJ P,GETNEW ; GET TYPE IN THIS CORE IMAGE
+ HRLM B,1(C) ; SMASH IT IN
+ JRST ELEFX
+
+TYPGFX: PUSH P,D
+ PUSHJ P,GETNTP ; GET TYPE IN THIS CORE IMAGE
+ POP P,D
+ PUTYP B,(C)
+ JRST ELEFX
+
+; HERE TO HANDLE AN EOF IN GC-READ. IT USES OPTIONAL SECOND ARG IF SUPPLIED AS
+; EOF HANDLER ELSE USES CHANNELS.
+
+EOFGC: MOVE B,1(AB) ; GET CHANNEL INTO B
+ CAML AB,C%M20 ; [-2,,0] ; SKIP IF EOF ROUTINE IS SUPPLIED
+ JRST MYCLOS ; USE CHANNELS
+ PUSH TP,2(AB)
+ PUSH TP,3(AB)
+ JRST CLOSIT
+MYCLOS: PUSH TP,EOFCND-1(B)
+ PUSH TP,EOFCND(B)
+CLOSIT: PUSH TP,$TCHAN
+ PUSH TP,B
+ MCALL 1,FCLOSE ; CLOSE CHANNEL
+ MCALL 1,EVAL ; EVAL HIS EOF HANDLER
+ JRST FINIS
+
+; ROUTINE TO SUPPLY THE TYPE NUMBER FOR A NEWTYPE
+
+GETNEW: CAMG B,NNPRI ;NEWTYPE
+ POPJ P,
+GETNTP: MOVE D,TYPTAB ; GET AOBJN POINTER TO TYPE-TABLE
+GETNT1: HLRZ E,(D) ; GET TYPE #
+ CAIN E,(B) ; SKIP IF NOT EQUAL TO GOAL
+ JRST GOTTYP ; FOUND IT
+ ADD D,C%22 ; POINT TO NEXT
+ JUMPL D,GETNT1
+ SKIPA ; KEEP TYPE SAME
+GOTTYP: HRRZ B,1(D) ; GET NEW TYPE #
+ POPJ P,
+
+; ROUTINE TO SUPPLY THE SAT TO A TEMPLATE HACKER
+
+GETSAT: MOVE D,TYPTAB ; GET AOBJN PTR TO TYPE TABLE
+GETSA1: HRRZ E,(D) ; GET OBJECT
+ CAIN E,(B) ; SKIP IF NOT EQUAL TO GOAL
+ JRST GOTSAT ; FOUND IT
+ ADD D,C%22
+ JUMPL D,GETSA1
+ FATAL GC-DUMP -- TYPE FIXUP FAILURE
+GOTSAT: HLRZ B,1(D) ; GET NEW SAT
+ POPJ P,
+
+
+; A ROUTINE TO DISTINGUISH BETWEEN A DEFERRED AND A LIST POINTER
+RLISTQ: PUSH P,A
+ GETYP A,(B) ; GET TYPE
+ PUSHJ P,SAT ; GET SAT
+ CAIG A,NUMSAT ; NOT DEFERRED IF TEMPLATE
+ SKIPL MKTBS(A)
+ AOS -1(P) ; SKIP IF NOT DEFFERED
+ POP P,A
+ POPJ P, ; EXIT
+
+\f
+.GLOBAL FLIST
+
+MFUNCTION BLOATSTAT,SUBR,[BLOAT-STAT]
+
+ENTRY
+
+ JUMPGE AB,GETUVC ; SEE IF THERE IS AN ARGUMENT
+ GETYP A,(AB)
+ CAIE A,TUVEC ; SEE IF THE ARGUMENT IS A UVECTOR
+ JRST WTYP1 ; IF NOT COMPLAIN
+ HLRE 0,1(AB)
+ MOVNS 0
+ CAIE 0,STATNO+STATGC ; SEE IF UVECTOR IS RIGHT LENGTH
+ JRST WTYP1
+ CAMGE AB,C%M20 ; [-2,,0] ; SEE IF THERE ARE TOO MANY ARGUMENTS
+ JRST TMA
+ MOVE A,(AB) ; GET THE UVECTOR
+ MOVE B,1(AB)
+ JRST SETUV ; CONTINUE
+GETUVC: MOVEI A,STATNO+STATGC ; CREATE A UVECTOR
+ PUSHJ P,IBLOCK
+SETUV: PUSH P,A ; SAVE UVECTOR
+ PUSH P,B
+ MOVE 0,NOWFRE ; COMPUTE FREE STORAGE USED SINCE LAST BLOAT-STAT
+ SUB 0,RFRETP
+ ADD 0,GCSTOP
+ MOVEM 0,CURFRE
+ PUSHJ P,GCSET ; FIX UP BLOAT-STAT PARAMETERS
+ HLRE 0,TP ; COMPUTE STACK SPACE USED UP
+ ADD 0,NOWTP
+ SUBI 0,PDLBUF
+ MOVEM 0,CURTP
+ MOVE B,IMQUOTE THIS-PROCESS
+ PUSHJ P,ILOC
+ HRRZS B
+ MOVE PVP,PVSTOR+1
+ HRRZ C,TPBASE+1(PVP) ; CALCULATE # OF ATOM SLOTS
+ MOVE 0,B
+ HRRZ D,SPBASE+1(PVP) ; COMPUTE CURRENT # OF BINDINGS
+ SUB 0,D
+ IDIVI 0,6
+ MOVEM 0,CURLVL
+ SUB B,C ; TOTAL WORDS ATOM STORAGE
+ IDIVI B,6 ; COMPUTE # OF SLOTS
+ MOVEM B,NOWLVL
+ HRRZ A,GLOBASE+1 ; COMPUTE TOTAL # OF GLOBAL SLOTS
+ HLRE 0,GLOBASE+1
+ SUB A,0 ; POINT TO DOPE WORD
+ HLRZ B,1(A)
+ ASH B,-2 ; # OF GVAL SLOTS
+ MOVEM B,NOWGVL
+ HRRZ A,GLOTOP+1 ; COMPUTE # OF GVAL SLOTS IN USE
+ HRRZ 0,GLOBSP+1
+ SUB A,0
+ ASH A,-2 ; NEGATIVE # OF SLOTS USED
+ MOVEM A,CURGVL
+ HRRZ A,TYPBOT+1 ; GET LENGTH OF TYPE VECTOR
+ HLRE 0,TYPBOT+1
+ SUB A,0
+ HLRZ B,1(A) ; # OF WORDS IN TYPE-VECTOR
+ IDIVI B,2 ; CONVERT TO # OF TYPES
+ MOVEM B,NOWTYP
+ HLRE 0,TYPVEC+1 ; LENGTH OF VISABLE TYPE-VECTOR
+ MOVNS 0
+ IDIVI 0,2 ; GET # OF TYPES
+ MOVEM 0,CURTYP
+ MOVE 0,CODTOP ; GET LENGTH OF STATIONARY IMPURE STORAGE
+ MOVEM 0,NOWSTO
+ SETZB B,D ; ZERO OUT MAXIMUM
+ HRRZ C,FLIST
+LOOPC: HLRZ 0,(C) ; GET BLK LENGTH
+ ADD D,0 ; ADD # OF WORDS IN BLOCK
+ CAMGE B,0 ; SEE IF NEW MAXIMUM
+ MOVE B,0
+ HRRZ C,(C) ; POINT TO NEXT BLOCK
+ JUMPN C,LOOPC ; REPEAT
+ MOVEM D,CURSTO
+ MOVEM B,CURMAX
+ HLRE 0,P ; GET AMOUNT OF ROOM LEFT ON P
+ ADD 0,NOWP
+ SUBI 0,PDLBUF
+ MOVEM 0,CURP
+ MOVSI C,BSTGC ; SET UP BLT FOR GC FIGURES
+ HRRZ B,(P) ; RESTORE B
+ HRR C,B
+ BLT C,(B)STATGC-1
+ HRLI C,BSTAT ; MODIFY BLT FOR STATS
+ HRRI C,STATGC(B)
+ BLT C,(B)STATGC+STATNO-1
+ MOVEI 0,TFIX+.VECT.
+ HRLM 0,(B)STATNO+STATGC ; MOVE IN UTYPE
+ POP P,B
+ POP P,A ; RESTORE TYPE-WORD
+ JRST FINIS
+
+GCRSET: SETZM GCNO ; CALL FROM INIT, ZAP ALL 1ST
+ MOVE 0,[GCNO,,GCNO+1]
+ BLT 0,GCCALL
+ JRST GCSET
+
+
+
+\f
+.GLOBAL PGFIND,PGGIVE,PGTAKE,PGINT
+
+; USER GARBAGE COLLECTOR INTERFACE
+.GLOBAL ILVAL
+
+MFUNCTION GC,SUBR
+ ENTRY
+
+ JUMPGE AB,GC1
+ CAMGE AB,C%M60 ; [-6,,0]
+ JRST TMA
+ PUSHJ P,GETFIX ; GET FREEE MIN IF GIVEN
+ SKIPE A ; SKIP FOR 0 ARGUMENT
+ MOVEM A,FREMIN
+GC1: PUSHJ P,COMPRM ; GET CURRENT USED CORE
+ PUSH P,A
+ CAML AB,C%M40 ; [-4,,0] ; SEE IF 3RD ARG
+ JRST GC5
+ GETYP A,4(AB) ; MAKE SURE A FIX
+ CAIE A,TFIX
+ JRST WTYP ; ARG WRONG TYPE
+ MOVE A,5(AB)
+ MOVEM A,RNUMSP
+ MOVEM A,NUMSWP
+GC5: CAML AB,C%M20 ; [-2,,0] ; SEE IF SECOND ARG
+ JRST GC3
+ GETYP A,2(AB) ; SEE IF NONFALSE
+ CAIE A,TFALSE ; SKIP IF FALSE
+ JRST HAIRGC ; CAUSE A HAIRY GC
+GC3: MOVSI A,TATOM ; CHECK TO SEE IF INTERRUPT FLAG IS ON
+ MOVE B,IMQUOTE AGC-FLAG
+ PUSHJ P,ILVAL
+ CAMN A,$TUNBOUND ; SKIP IF NOT UNBOUND
+ JRST GC2
+ SKIPE GCHPN ; SKIP IF GCHAPPEN IS 0
+ JRST FALRTN ; JUMP TO RETURN FALSE
+GC2: MOVE C,[9.,,0]
+ PUSHJ P,AGC ; COLLECT THAT TRASH
+ PUSHJ P,COMPRM ; HOW MUCH ROOM NOW?
+ POP P,B ; RETURN AMOUNT
+ SUB B,A
+ MOVSI A,TFIX
+ JRST FINIS
+HAIRGC: MOVE B,3(AB)
+ CAIN A,TFIX ; IF FIX THEN CLOBBER NGCS
+ MOVEM B,NGCS
+ MOVEI A,1 ; FORCE VALUE FLUSHING PHASE TO OCCUR
+ MOVEM A,GCHAIR
+ JRST GC2 ; HAIRY GC OCCORS NO MATTER WHAT
+FALRTN: MOVE A,$TFALSE
+ MOVEI B,0 ; RETURN A FALSE-- FOR GC WHICH DIDN'T OCCOR
+ JRST FINIS
+
+
+COMPRM: MOVE A,GCSTOP ; USED SPACE
+ SUB A,GCSBOT
+ POPJ P,
+
+\f
+MFUNCTION GCDMON,SUBR,[GC-MON]
+
+ ENTRY
+
+ MOVEI E,GCMONF
+
+FLGSET: MOVE C,(E) ; GET CURRENT VALUE
+ JUMPGE AB,RETFLG ; RET CURRENT
+ CAMGE AB,C%M20 ; [-3,,]
+ JRST TMA
+ GETYP 0,(AB)
+ SETZM (E)
+ CAIN 0,TFALSE
+ SETOM (E)
+ SKIPL E
+ SETCMM (E)
+
+RETFLG: SKIPL E
+ SETCMM C
+ JUMPL C,NOFLG
+ MOVSI A,TATOM
+ MOVE B,IMQUOTE T
+ JRST FINIS
+
+NOFLG: MOVEI B,0
+ MOVSI A,TFALSE
+ JRST FINIS
+
+.GLOBAL EVATYP,APLTYP,PRNTYP
+
+\fMFUNCTION BLOAT,SUBR
+ ENTRY
+
+ PUSHJ P,SQKIL
+ MOVEI C,0 ; FLAG TO SAY WHETHER NEED A GC
+ MOVSI E,-NBLO ; AOBJN TO BLOATER TABLE
+
+BLOAT2: JUMPGE AB,BLOAT1 ; ALL DONE?
+ PUSHJ P,NXTFIX ; GET NEXT BLOAT PARAM
+ SKIPE A
+ PUSHJ P,@BLOATER(E) ; DISPATCH
+ AOBJN E,BLOAT2 ; COUNT PARAMS SET
+
+ JUMPL AB,TMA ; ANY LEFT...ERROR
+BLOAT1: JUMPE C,BLOATD ; DONE, NO GC NEEDED
+ MOVE C,E ; MOVE IN INDICATOR
+ HRLI C,1 ; INDICATE THAT IT COMES FROM BLOAT
+ SETOM INBLOT
+ PUSHJ P,AGC ; DO ONE
+ SKIPE A,TPBINC ; SMASH POINNTERS
+ MOVE PVP,PVSTOR+1
+ ADDM A,TPBASE+1(PVP)
+ SKIPE A,GLBINC ; GLOBAL SP
+ ADDM A,GLOBASE+1
+ SKIPE A,TYPINC
+ ADDM A,TYPBOT+1
+ SETZM TPBINC ; RESET PARAMS
+ SETZM GLBINC
+ SETZM TYPINC
+
+BLOATD: SKIPN A,GETNUM ; SKIP IF FREE STORAGE REQUEST IN EFFECT
+ JRST BLTFN
+ ADD A,FRETOP ; ADD FRETOP
+ ADDI A,1777 ; ONE BLOCK FOR MARK PDL AND ROUND
+ ANDCMI A,1777 ; TO PAGE BOUNDRY
+ CAML A,PURBOT ; SKIP IF POSSIBLE TO WIN
+ JRST BLFAGC
+ ASH A,-10. ; TO PAGES
+ PUSHJ P,P.CORE ; GRET THE CORE
+ JRST BLFAGC ; LOSE LOSE LOSE
+ MOVE A,FRETOP ; CALCULATE NEW PARAMETERS
+ MOVEM A,RFRETP
+ MOVEM A,CORTOP
+ MOVE B,GCSTOP
+ SETZM 1(B)
+ HRLI B,1(B)
+ HRRI B,2(B)
+ BLT B,-1(A) ; ZERO CORE
+BLTFN: SETZM GETNUM
+ MOVE B,FRETOP
+ SUB B,GCSTOP
+ MOVSI A,TFIX ; RETURN CORE FOUND
+ JRST FINIS
+BLFAGC: MOVN A,FREMIN
+ ADDM A,GETNUM ; FIX UP SO BLOATS CORRECTLY
+ MOVE C,C%11 ; INDICATOR FOR AGC
+ PUSHJ P,AGC ; GARBAGE COLLECT
+ JRST BLTFN ; EXIT
+
+; TABLE OF BLOAT ROUTINES
+
+BLOATER:
+ MAINB
+ TPBLO
+ LOBLO
+ GLBLO
+ TYBLO
+ STBLO
+ PBLO
+ SFREM
+ SLVL
+ SGVL
+ STYP
+ SSTO
+ PUMIN
+ PMUNG
+ TPMUNG
+ NBLO==.-BLOATER
+
+; BLOAT MAIN STORAGE AREA
+
+MAINB: SETZM GETNUM
+ MOVE D,FRETOP ; COMPUTE CURRENT ROOM
+ SUB D,PARTOP
+ CAMGE A,D ; NEED MORE?
+ POPJ P, ; NO, LEAVE
+ SUB A,D
+ MOVEM A,GETNUM ; SAVE
+ POPJ P,
+
+; BLOAT TP STACK (AT TOP)
+
+TPBLO: HLRE D,TP ; GET -SIZE
+ MOVNS B,D
+ ADDI D,1(TP) ; POINT TO DOPE (ALMOST)
+ CAME D,TPGROW ; BLOWN?
+ ADDI D,PDLBUF ; POINT TO REAL DOPE WORD
+ SUB A,B ; SKIP IF GROWTH NEEDED
+ JUMPLE A,CPOPJ
+ ADDI A,63.
+ ASH A,-6 ; CONVERT TO 64 WD BLOCKS
+ CAILE A,377
+ JRST OUTRNG
+ DPB A,[111100,,-1(D)] ; SMASH SPECS IN
+ AOJA C,CPOPJ
+
+; BLOAT TOP LEVEL LOCALS
+
+LOBLO: HLRE D,TP ; GET -SIZE
+ MOVNS B,D
+ ADDI D,1(TP) ; POINT TO DOPE (ALMOST)
+ CAME D,TPGROW ; BLOWN?
+ ADDI D,PDLBUF ; POINT TO REAL DOPE WORD
+ CAMG A,B ; SKIP IF GROWTH NEEDED
+ IMULI A,6 ; 6 WORDS PER BINDING
+ MOVE PVP,PVSTOR+1
+ HRRZ 0,TPBASE+1(PVP)
+ HRRZ B,SPBASE+1(PVP) ; ROOM AVAIL TO E
+ SUB B,0
+ SUBI A,(B) ; HOW MUCH MORE?
+ JUMPLE A,CPOPJ ; NONE NEEDED
+ MOVEI B,TPBINC
+ PUSHJ P,NUMADJ
+ DPB A,[1100,,-1(D)] ; SMASH
+ AOJA C,CPOPJ
+
+; GLOBAL SLOT GROWER
+
+GLBLO: ASH A,2 ; 4 WORDS PER VAR
+ MOVE D,GLOBASE+1 ; CURRENT LIMITS
+ HRRZ B,GLOBSP+1
+ SUBI B,(D)
+ SUBI A,(B) ; NEW AMOUNT NEEDED
+ JUMPLE A,CPOPJ
+ MOVEI B,GLBINC ; WHERE TO KEEP UPDATE
+ PUSHJ P,NUMADJ ; FIX NUMBER
+ HLRE 0,D
+ SUB D,0 ; POINT TO DOPE
+ DPB A,[1100,,(D)] ; AND SMASH
+ AOJA C,CPOPJ
+
+; HERE TO GROW TYPE VECTOR (AND FRIENDS)
+
+TYBLO: ASH A,1 ; TWO WORD PER TYPE
+ HRRZ B,TYPVEC+1 ; FIND CURRENT ROOM
+ MOVE D,TYPBOT+1
+ SUBI B,(D)
+ SUBI A,(B) ; EXTRA NEEDED TO A
+ JUMPLE A,CPOPJ ; NONE NEEDED, LEAVE
+ MOVEI B,TYPINC ; WHERE TO STASH SPEC
+ PUSHJ P,NUMADJ ; FIX NUMBER
+ HLRE 0,D ; POINT TO DOPE
+ SUB D,0
+ DPB A,[1100,,(D)]
+ SKIPE D,EVATYP+1 ; GROW AUX TYPE VECS IF NEEDED
+ PUSHJ P,SGROW1
+ SKIPE D,APLTYP+1
+ PUSHJ P,SGROW1
+ SKIPE D,PRNTYP+1
+ PUSHJ P,SGROW1
+ AOJA C,CPOPJ
+
+; HERE TO CREATE STORAGE SPACE
+
+STBLO: MOVE D,GCSBOT ; HOW MUCH NOW HERE
+ SUB D,CODTOP
+ SUBI A,(D) ; MORE NEEDED?
+ JUMPLE A,CPOPJ
+ MOVEM A,PARNEW ; FORCE PAIR SPACE TO MOVE ON OUT
+ AOJA C,CPOPJ
+
+; BLOAT P STACK
+
+PBLO: HLRE D,P
+ MOVNS B,D
+ SUBI D,5 ; FUDGE FOR THIS CALL
+ SUBI A,(D)
+ JUMPLE A,CPOPJ
+ ADDI B,1(P) ; POINT TO DOPE
+ CAME B,PGROW ; BLOWN?
+ ADDI B,PDLBUF ; NOPE, POIN TO REAL D.W.
+ ADDI A,63.
+ ASH A,-6 ; TO 64 WRD BLOCKS
+ CAILE A,377 ; IN RANGE?
+ JRST OUTRNG
+ DPB A,[111100,,-1(B)]
+ AOJA C,CPOPJ
+
+; SET FREMIN
+
+SFREM: SKIPE A ; DON'T ZERO EMPTY PARAMETER
+ MOVEM A,FREMIN
+ POPJ P,
+
+; SET LVAL INCREMENT
+
+SLVL: IMULI A,6 ; CALCULATE AMOUNT TO GROW B
+ MOVEI B,LVLINC
+ PUSHJ P,NUMADJ
+ MOVEM A,LVLINC
+ POPJ P,
+
+; SET GVAL INCREMENT
+
+SGVL: IMULI A,4. ; # OF SLOTS
+ MOVEI B,GVLINC
+ PUSHJ P,NUMADJ
+ MOVEM A,GVLINC
+ POPJ P,
+
+; SET TYPE INCREMENT
+
+STYP: IMULI A,2 ; CALCULATE NUMBER OF GROW BLOCKS NEEDED
+ MOVEI B,TYPIC
+ PUSHJ P,NUMADJ
+ MOVEM A,TYPIC
+ POPJ P,
+
+; SET STORAGE INCREMENT
+
+SSTO: IDIVI A,2000 ; # OF BLOCKS
+ CAIE B,0 ; REMAINDER?
+ ADDI A,1
+ IMULI A,2000 ; CONVERT BACK TO WORDS
+ MOVEM A,STORIC
+ POPJ P,
+; HERE FOR MINIMUM PURE SPACE
+
+PUMIN: ADDI A,1777
+ ANDCMI A,1777 ; TO PAGE BOUNDRY
+ MOVEM A,PURMIN
+ POPJ P,
+
+; HERE TO ADJUST PSTACK PARAMETERS IN GC
+
+PMUNG: ADDI A,777 ; TO NEAREST 1000 WORD BOUNDRY
+ ANDCMI A,777
+ MOVEM A,PGOOD ; PGOOD
+ ASH A,2 ; PMAX IS 4*PGOOD
+ MOVEM A,PMAX
+ ASH A,-4 ; PMIN IS .25*PGOOD
+ MOVEM A,PMIN
+
+; HERE TO ADJUST GC TPSTACK PARAMS
+
+TPMUNG: ADDI A,777
+ ANDCMI A,777 ; TO NEAREST 1000 WORD BOUNDRY
+ MOVEM A,TPGOOD
+ ASH A,2 ; TPMAX= 4*TPGOOD
+ MOVEM A,TPMAX
+ ASH A,-4 ; TPMIN= .25*TPGOOD
+ MOVEM A,TPMIN
+
+
+; GET NEXT (FIX) ARG
+
+NXTFIX: PUSHJ P,GETFIX
+ ADD AB,C%22
+ POPJ P,
+
+; ROUTINE TO GET POS FIXED ARG
+
+GETFIX: GETYP A,(AB)
+ CAIE A,TFIX
+ JRST WRONGT
+ SKIPGE A,1(AB)
+ JRST BADNUM
+ POPJ P,
+
+
+; GET NUMBERS FIXED UP FOR GROWTH FIELDS
+
+NUMADJ: ADDI A,77 ; ROUND UP
+ ANDCMI A,77 ; KILL CRAP
+ MOVE 0,A
+ MOVNS A ; COMPUTE ADD FACTOR FOR SPEC. POINTER UPDATE
+ HRLI A,-1(A)
+ MOVEM A,(B) ; AND STASH IT
+ MOVE A,0
+ ASH A,-6 ; TO 64 WD BLOCKS
+ CAILE A,377 ; CHECK FIT
+ JRST OUTRNG
+ POPJ P,
+
+; DO SYMPATHETIC GROWTHS
+
+SGROW1: HLRE 0,D
+ SUB D,0
+ DPB A,[111100,,(D)]
+ POPJ P,
+
+\f;FUNCTION TO CONSTRUCT A LIST
+
+MFUNCTION CONS,SUBR
+
+ ENTRY 2
+ GETYP A,2(AB) ;GET TYPE OF 2ND ARG
+ CAIE A,TLIST ;LIST?
+ JRST WTYP2 ;NO , COMPLAIN
+ MOVE C,(AB) ; GET THING TO CONS IN
+ MOVE D,1(AB)
+ HRRZ E,3(AB) ; AND LIST
+ PUSHJ P,ICONS ; INTERNAL CONS
+ JRST FINIS
+
+; COMPILER CALL TO CONS
+
+C1CONS: PUSHJ P,ICELL2
+ JRST ICONS2
+ICONS4: HRRI C,(E)
+ICONS3: MOVEM C,(B) ; AND STORE
+ MOVEM D,1(B)
+TLPOPJ: MOVSI A,TLIST
+ POPJ P,
+
+; INTERNAL CONS--ICONS; C,D VALUE, E CDR
+
+; RELATIVIZE RETURN ADDRESS HERE--MUST BE DIFFERENT FROM ICONS, SINCE
+; ICONS IS CALLED FROM INTERPRETER ENTRIES WHICH ARE THEMSELVES PUSHJ'ED
+; TO: DOING SUBM M,(P) ANYWHERE IN ICONS IS FATAL IF A GC OCCURS.
+
+CICONS: SUBM M,(P)
+ PUSHJ P,ICONS
+ JRST MPOPJ
+
+; INTERNAL CONS TO NIL--INCONS
+
+INCONS: MOVEI E,0
+
+ICONS: GETYP A,C ; CHECK TYPE OF VAL
+ PUSHJ P,NWORDT ; # OF WORDS
+ SOJN A,ICONS1 ; JUMP IF DEFERMENT NEEDED
+ PUSHJ P,ICELL2 ; NO DEFER, GET 2 WORDS FROM PAIR SPACE
+ JRST ICNS2A ; NO CORE, GO GC (SPECIAL PLACE, NOTICE)
+ JRST ICONS4
+
+; HERE IF CONSING DEFERRED
+
+ICONS1: MOVEI A,4 ; NEED 4 WORDS
+ PUSHJ P,ICELL ; GO GET 'EM
+ JRST ICNS2A ; NOT THERE, GC (SAME PLACE AS FOR ICONS)
+ HRLI E,TDEFER ; CDR AND DEFER
+ MOVEM E,(B) ; STORE
+ MOVEI E,2(B) ; POINT E TO VAL CELL
+ HRRZM E,1(B)
+ MOVEM C,(E) ; STORE VALUE
+ MOVEM D,1(E)
+ JRST TLPOPJ
+
+
+
+; HERE TO GC ON A CONS
+
+; HERE FROM C1CONS
+ICONS2: SUBM M,(P)
+ PUSHJ P,ICONSG
+ SUBM M,(P)
+ JRST C1CONS
+
+; HERE FROM ICONS (THUS CICONS, INDIRECTLY), ICONS1
+ICNS2A: PUSHJ P,ICONSG
+ JRST ICONS
+
+; REALLY DO GC
+ICONSG: PUSH TP,C ; SAVE VAL
+ PUSH TP,D
+ PUSH TP,$TLIST
+ PUSH TP,E ; SAVE VITAL STUFF
+ ADDM A,GETNUM ; AMOUNT NEEDED
+ MOVE C,[3,,1] ; INDICATOR FOR AGC
+ PUSHJ P,INQAGC ; ATTEMPT TO WIN
+ MOVE D,-2(TP) ; RESTORE VOLATILE STUFF
+ MOVE C,-3(TP)
+ MOVE E,(TP)
+ SUB TP,C%44 ; [4,,4]
+ POPJ P, ; BACK TO DRAWING BOARD
+
+; SUBROUTINE TO ALLOCATE WORDS IN PAIR SPACE. CALLS AGC IF NEEDED
+
+CELL2: MOVEI A,2 ; USUAL CASE
+CELL: PUSHJ P,ICELL ; INTERNAL
+ JRST .+2 ; LOSER
+ POPJ P,
+
+ ADDM A,GETNUM ; AMOUNT REQUIRED
+ PUSH P,A ; PREVENT AGC DESTRUCTION
+ MOVE C,[3,,1] ; INDICATOR FOR AGC
+ PUSHJ P,INQAGC
+ POP P,A
+ JRST CELL ; AND TRY AGAIN
+
+; INTERNAL CELL GETTER, SKIPS IF ROO EXISTS, ELSE DOESN'T
+
+ICELL2: MOVEI A,2 ; MOST LIKELY CAE
+ICELL: SKIPE B,RCL
+ JRST ICELRC ;SEE IF WE CAN RE-USE A RECYCLE CELL
+ MOVE B,PARTOP ; GET TOP OF PAIRS
+ ADDI B,(A) ; BUMP
+ CAMLE B,FRETOP ; SKIP IF OK.
+ JRST VECTRY ; LOSE
+ EXCH B,PARTOP ; SETUP NEW PARTOP AND RETURN POINTER
+ ADDM A,USEFRE
+ JRST CPOPJ1 ; SKIP RETURN
+
+; TRY RECYCLING USING A VECTOR FROM RCLV
+
+VECTRY: SKIPN B,RCLV ; SKIP IF VECTOR EXISTS
+ POPJ P,
+ PUSH P,C
+ PUSH P,A
+ MOVEI C,RCLV
+VECTR1: HLRZ A,(B) ; GET LENGTH
+ SUB A,(P)
+ JUMPL A,NXTVEC ; DOESN'T SATISFY TRY AGAIN
+ CAIN A,1 ; MAKE SURE NOT LEFT WITH A SINGLE SLOT
+ JRST NXTVEC
+ JUMPN A,SOML ; SOME ARE LEFT
+ HRRZ A,(B)
+ HRRM A,(C)
+ HLRZ A,(B)
+ SETZM (B)
+ SETZM -1(B) ; CLEAR DOPE WORDS
+ SUBI B,-1(A)
+ POP P,A ; CLEAR STACK
+ POP P,C
+ JRST CPOPJ1
+SOML: HRLM A,(B) ; SMASH AMOUNT LEFT
+ SUBI B,-1(A) ; GET TO BEGINNING
+ SUB B,(P)
+ POP P,A
+ POP P,C
+ JRST CPOPJ1
+NXTVEC: MOVEI C,(B)
+ HRRZ B,(B) ; GET NEXT
+ JUMPN B,VECTR1
+ POP P,A
+ POP P,C
+ POPJ P,
+
+ICELRC: CAIE A,2
+ JRST ICELL+2 ;IF HE DOESNT WANT TWO, USE OLD METHOD
+ PUSH P,A
+ MOVE A,(B)
+ HRRZM A,RCL
+ POP P,A
+ SETZM (B) ;GIVE HIM A CLEAN RECYCLED CELL
+ SETZM 1(B)
+ JRST CPOPJ1 ;THAT IT
+
+
+\f;FUNCTION TO BUILD A LIST OF MANY ELEMENTS
+
+IMFUNCTION LIST,SUBR
+ ENTRY
+
+ PUSH P,$TLIST
+LIST12: HLRE A,AB ;GET -NUM OF ARGS
+ PUSH TP,$TAB
+ PUSH TP,AB
+ MOVNS A ;MAKE IT +
+ JUMPE A,LISTN ;JUMP IF 0
+ SKIPE RCL ;SEE IF WE WANT TO DO ONE AT A TIME
+ JRST LST12R ;TO GET RECYCLED CELLS
+ PUSHJ P,CELL ;GET NUMBER OF CELLS
+ PUSH TP,(P) ;SAVE IT
+ PUSH TP,B
+ SUB P,C%11
+ LSH A,-1 ;NUMBER OF REAL LIST ELEMENTS
+
+CHAINL: ADDI B,2 ;LOOP TO CHAIN ELEMENTS
+ HRRZM B,-2(B) ;CHAIN LAST ONE TO NEXT ONE
+ SOJG A,.-2 ;LOOP TIL ALL DONE
+ CLEARM B,-2(B) ;SET THE LAST CDR TO NIL
+
+; NOW LOBEER THE DATA IN TO THE LIST
+
+ MOVE D,AB ; COPY OF ARG POINTER
+ MOVE B,(TP) ;RESTORE LIS POINTER
+LISTLP: GETYP A,(D) ;GET TYPE
+ PUSHJ P,NWORDT ;GET NUMBER OF WORDS
+ SOJN A,LDEFER ;NEED TO DEFER POINTER
+ GETYP A,(D) ;NOW CLOBBER ELEMENTS
+ HRLM A,(B)
+ MOVE A,1(D) ;AND VALUE..
+ MOVEM A,1(B)
+LISTL2: HRRZ B,(B) ;REST B
+ ADD D,C%22 ;STEP ARGS
+ JUMPL D,LISTLP
+
+ POP TP,B
+ POP TP,A
+ SUB TP,C%22 ; CLEANUP STACK
+ JRST FINIS
+
+
+LST12R: ASH A,-1 ;ONE AT A TIME TO GET RECYCLED CELLS
+ JUMPE A,LISTN
+ PUSH P,A ;SAVE COUNT ON STACK
+ SETZM E
+ SETZB C,D
+ PUSHJ P,ICONS
+ MOVE E,B ;LOOP AND CHAIN TOGETHER
+ SOSLE (P)
+ JRST .-4
+ PUSH TP,-1(P) ;PUSH ON THE TYPE WE WANT
+ PUSH TP,B
+ SUB P,C%22 ;CLEAN UP AFTER OURSELVES
+ JRST LISTLP-2 ;AND REJOIN MAIN STREAM
+
+
+; MAKE A DEFERRED POINTER
+
+LDEFER: PUSH TP,$TLIST ;SAVE CURRENT POINTER
+ PUSH TP,B
+ MOVEM D,1(TB) ; SAVE ARG HACKER
+ PUSHJ P,CELL2
+ MOVE D,1(TB)
+ GETYPF A,(D) ;GET FULL DATA
+ MOVE C,1(D)
+ MOVEM A,(B)
+ MOVEM C,1(B)
+ MOVE C,(TP) ;RESTORE LIST POINTER
+ MOVEM B,1(C) ;AND MAKE THIS BE THE VALUE
+ MOVSI A,TDEFER
+ HLLM A,(C) ;AND STORE IT
+ MOVE B,C
+ SUB TP,C%22
+ JRST LISTL2
+
+LISTN: MOVEI B,0
+ POP P,A
+ JRST FINIS
+
+; BUILD A FORM
+
+IMFUNCTION FORM,SUBR
+
+ ENTRY
+
+ PUSH P,$TFORM
+ JRST LIST12
+
+\f; COMPILERS CALLS TO FORM AND LIST A/ COUNT ELEMENTS ON STACK
+
+IILIST: SUBM M,(P)
+ PUSHJ P,IILST
+ MOVSI A,TLIST
+ JRST MPOPJ
+
+IIFORM: SUBM M,(P)
+ PUSHJ P,IILST
+ MOVSI A,TFORM
+ JRST MPOPJ
+
+IILST: JUMPE A,IILST0 ; NIL WHATSIT
+ PUSH P,A
+ MOVEI E,0
+IILST1: POP TP,D
+ POP TP,C
+ PUSHJ P,ICONS ; CONS 'EM UP
+ MOVEI E,(B)
+ SOSE (P) ; COUNT
+ JRST IILST1
+
+ SUB P,C%11
+ POPJ P,
+
+IILST0: MOVEI B,0
+ POPJ P,
+
+\f;FUNCTION TO BUILD AN IMPLICIT LIST
+
+MFUNCTION ILIST,SUBR
+ ENTRY
+ PUSH P,$TLIST
+ILIST2: JUMPGE AB,TFA ;NEED AT LEAST ONE ARG
+ CAMGE AB,C%M40 ; [-4,,0] ; NO MORE THAN TWO ARGS
+ JRST TMA
+ PUSHJ P,GETFIX ; GET POS FIX #
+ JUMPE A,LISTN ;EMPTY LIST ?
+ CAML AB,C%M20 ; [-2,,0] ;ONLY ONE ARG?
+ JRST LOSEL ;YES
+ PUSH P,A ;SAVE THE CURRENT VALUE OF LENGTH FOR LOOP ITERATION
+ILIST0: PUSH TP,2(AB)
+ PUSH TP,(AB)3
+ MCALL 1,EVAL
+ PUSH TP,A
+ PUSH TP,B
+ SOSLE (P)
+ JRST ILIST0
+ POP P,C
+ILIST1: MOVE C,(AB)+1 ;REGOBBLE LENGTH
+ ACALL C,LIST
+ILIST3: POP P,A ; GET FINAL TYPE
+ JRST FINIS
+
+
+LOSEL: PUSH P,A ; SAVE COUNT
+ MOVEI E,0
+
+LOSEL1: SETZB C,D ; TLOSE,,0
+ PUSHJ P,ICONS
+ MOVEI E,(B)
+ SOSLE (P)
+ JRST LOSEL1
+
+ SUB P,C%11
+ JRST ILIST3
+
+; IMPLICIT FORM
+
+MFUNCTION IFORM,SUBR
+
+ ENTRY
+ PUSH P,$TFORM
+ JRST ILIST2
+
+\f; IVECTOR AND IUVECTOR--GET VECTOR AND UVECTOR OF COMPUTED VALUES
+
+MFUNCTION VECTOR,SUBR,[IVECTOR]
+
+ MOVEI C,1
+ JRST VECTO3
+
+MFUNCTION UVECTOR,SUBR,[IUVECTOR]
+
+ MOVEI C,0
+VECTO3: ENTRY
+ JUMPGE AB,TFA ; AT LEAST ONE ARG
+ CAMGE AB,C%M40 ; [-4,,0] ; NOT MORE THAN 2
+ JRST TMA
+ PUSHJ P,GETFIX ; GET A POS FIXED NUMBER
+ LSH A,(C) ; A-> NUMBER OF WORDS
+ PUSH P,C ; SAVE FOR LATER
+ PUSHJ P,IBLOCK ; GET BLOCK (TURN ON BIT APPROPRIATELY)
+ POP P,C
+ HLRE A,B ; START TO
+ SUBM B,A ; FIND DOPE WORD
+ MOVSI D,.VECT. ; FOR GCHACK
+ IORM D,(A)
+ JUMPE C,VECTO4
+ MOVSI D,400000 ; GET NOT UNIFORM BIT
+ IORM D,(A) ; INTO DOPE WORD
+ SKIPA A,$TVEC ; GET TYPE
+VECTO4: MOVSI A,TUVEC
+ CAML AB,C%M20 ; [-2,,0] ; SKIP IF ARGS NEED TO BE HACKED
+ JRST FINIS
+ JUMPGE B,FINIS ; DON'T EVAL FOR EMPTY CASE
+
+ PUSH TP,A ; SAVE THE VECTOR
+ PUSH TP,B
+ PUSH TP,A
+ PUSH TP,B
+
+ JUMPE C,UINIT
+ JUMPGE B,FINIS ; EMPTY VECTOR, LEAVE
+INLP: PUSHJ P,IEVAL ; EVAL EXPR
+ MOVEM A,(C)
+ MOVEM B,1(C)
+ ADD C,C%22 ; BUMP VECTOR
+ MOVEM C,(TP)
+ JUMPL C,INLP ; IF MORE DO IT
+
+GETVEC: MOVE A,-3(TP)
+ MOVE B,-2(TP)
+ SUB TP,C%44 ; [4,,4]
+ JRST FINIS
+
+; HERE TO FILL UP A UVECTOR
+
+UINIT: PUSHJ P,IEVAL ; HACK THE 1ST VALUE
+ GETYP A,A ; GET TYPE
+ PUSH P,A ; SAVE TYPE
+ PUSHJ P,NWORDT ; SEE IF IT CAN BE UNIFORMED
+ SOJN A,CANTUN ; COMPLAIN
+STJOIN: MOVE C,(TP) ; RESTORE POINTER
+ ADD C,1(AB) ; POINT TO DOPE WORD
+ MOVE A,(P) ; GET TYPE
+ HRLZM A,(C) ; STORE IN D.W.
+ MOVSI D,.VECT. ; FOR GCHACK
+ IORM D,(C)
+ MOVE C,(TP) ; GET BACK VECTOR
+ SKIPE 1(AB)
+ JRST UINLP1 ; START FILLING UV
+ JRST GETVE1
+
+UINLP: MOVEM C,(TP) ; SAVE PNTR
+ PUSHJ P,IEVAL ; EVAL THE EXPR
+ GETYP A,A ; GET EVALED TYPE
+ CAIE A,@(P) ; WINNER?
+ JRST WRNGSU ; SERVICE ERROR FOR UVECTOR,STORAGE
+UINLP1: MOVEM B,(C) ; STORE
+ AOBJN C,UINLP
+GETVE1: SUB P,C%11
+ JRST GETVEC ; AND RETURN VECTOR
+
+IEVAL: PUSH TP,2(AB)
+ PUSH TP,3(AB)
+ MCALL 1,EVAL
+ MOVE C,(TP)
+ POPJ P,
+
+; ISTORAGE -- GET STORAGE OF COMPUTED VALUES
+
+MFUNCTION ISTORAGE,SUBR
+ ENTRY
+ JUMPGE AB,TFA
+ CAMGE AB,C%M40 ; [-4,,0] ; AT LEAST ONE ARG
+ JRST TMA
+ PUSHJ P,GETFIX ; POSITIVE COUNT FIRST ARG
+ PUSHJ P,CAFRE ; GET CORE
+ MOVN B,1(AB) ; -COUNT
+ HRL A,B ; PUT IN LHW (A)
+ MOVM B,B ; +COUNT
+ HRLI B,2(B) ; LENGTH + 2
+ ADDI B,(A) ; MAKE POINTER TO DOPE WORDS
+ HLLZM B,1(B) ; PUT TOTAL LENGTH IN 2ND DOPE
+ HRRM A,1(B) ; PUT ADDRESS IN RHW (STORE DOES THIS TOO).
+ MOVE B,A
+ MOVSI A,TSTORAGE
+ CAML AB,C%M20 ; [-2,,0] ; SECOND ARG TO EVAL?
+ JRST FINIS ; IF NOT, RETURN EMPTY
+ PUSH TP,A
+ PUSH TP,B
+ PUSH TP,A
+ PUSH TP,B
+ PUSHJ P,IEVAL ; EVALUATE FOR FIRST VALUE
+ GETYP A,A
+ PUSH P,A ; FOR COMPARISON LATER
+ PUSHJ P,SAT
+ CAIN A,S1WORD
+ JRST STJOIN ;TREAT LIKE A UVECTOR
+; IF NOT 1-WORD TYPES, CANNOT STORE, SO COMPLAIN
+ PUSHJ P,FREESV ; FREE STORAGE VECTOR
+ ERRUUO EQUOTE DATA-CANT-GO-IN-STORAGE
+
+; FOR STORAGE, MUST FREE THE CORE ELSE IT IS LOST (NO GC)
+FREESV: MOVE A,1(AB) ; GET COUNT
+ ADDI A,2 ; FOR DOPE
+ HRRZ B,(TP) ; GET ADDRESS
+ PUSHJ P,CAFRET ; FREE THE CORE
+ POPJ P,
+
+\f
+; INTERNAL VECTOR ALLOCATOR. A/SIZE OF VECTOR (NOT INCLUDING DOPE WORDS)
+
+IBLOK1: ASH A,1 ; TIMES 2
+GIBLOK: TLOA A,400000 ; FUNNY BIT
+IBLOCK: TLZ A,400000 ; NO BIT ON
+ TLO A,.VECT. ; TURN ON BIT FOR GCHACK
+ ADDI A,2 ; COMPENSATE FOR DOPE WORDS
+IBLOK2: SKIPE B,RCLV ; ANY TO RECYCLE?
+ JRST RCLVEC
+NORCL: MOVE B,GCSTOP ; POINT TO BOTTOM OF SPACE
+ PUSH P,B ; SAVE TO BUILD PTR
+ ADDI B,(A) ; ADD NEEDED AMOUNT
+ CAML B,FRETOP ; SKIP IF NO GC NEEDED
+ JRST IVECT1
+ MOVEM B,GCSTOP ; WIN, GET POINTER TO BLOCK AND UPDATE VECBOT
+ ADDM A,USEFRE
+ HRRZS USEFRE
+ HRLZM A,-1(B) ; STORE LENGTH IN DOPE WORD
+ HLLZM A,-2(B) ; AND BIT
+ HRRM B,-1(B) ; SMASH IN RELOCATION
+ SOS -1(B)
+ POP P,B ; RESTORE PTR TO BOTTOM OF VECTOR
+ HRROS B ; POINT TO START OF VECTOR
+ TLC B,-3(A) ; SETUP COUNT
+ HRRI A,TVEC
+ SKIPL A
+ HRRI A,TUVEC
+ MOVSI A,(A)
+ POPJ P,
+
+; HERE TO DO A GC ON A VECTOR ALLOCATION
+
+IVECT1: PUSH P,0
+ PUSH P,A ; SAVE DESIRED LENGTH
+ HRRZ 0,A
+ ADDM 0,GETNUM ; AND STORE AS DESIRED AMOUNT
+ MOVE C,[4,,1] ; GET INDICATOR FOR AGC
+ PUSHJ P,INQAGC
+ POP P,A
+ POP P,0
+ POP P,B
+ JRST IBLOK2
+
+
+; INTERNAL EVECTOR (CALLED FROM READ) A/ #OF THINGS
+; ITEMS ON TOP OF STACK
+
+IEVECT: ASH A,1 ; TO NUMBER OF WORDS
+ PUSH P,A
+ PUSHJ P,IBLOCK ; GET VECTOR
+ HLRE D,B ; FIND DW
+ SUBM B,D ; A POINTS TO DW
+ MOVSI 0,400000+.VECT.
+ MOVEM 0,(D) ; CLOBBER NON UNIF BIT
+ POP P,A ; RESTORE COUNT
+ JUMPE A,IVEC1 ; 0 LNTH, DONE
+ MOVEI C,(TP) ; BUILD BLT
+ SUBI C,(A)-1 ; C POINTS TO 1ST ITEM ON STACK
+ MOVSI C,(C)
+ HRRI C,(B) ; B/ SOURCE,,DEST
+ BLT C,-1(D) ; XFER THE DATA
+ HRLI A,(A)
+ SUB TP,A ; FLUSH STACKAGE
+IVEC1: MOVSI A,TVEC
+ POPJ P,
+
+
+; COMPILERS CALL
+
+CIVEC: SUBM M,(P)
+ PUSHJ P,IEVECT
+ JRST MPOPJ
+
+
+\f; INTERNAL CALL TO EUVECTOR
+
+IEUVEC: PUSH P,A ; SAVE LENGTH
+ PUSHJ P,IBLOCK
+ MOVE A,(P)
+ JUMPE A,IEUVE1 ; EMPTY, LEAVE
+ ASH A,1 ; NOW FIND STACK POSITION
+ MOVEI C,(TP) ; POINT TO TOP
+ MOVE D,B ; COPY VEC POINTER
+ SUBI C,-1(A) ; POINT TO 1ST DATUM
+ GETYP A,(C) ; CHECK IT
+ PUSHJ P,NWORDT
+ SOJN A,CANTUN ; WONT FIT
+ GETYP E,(C)
+
+IEUVE2: GETYP 0,(C) ; TYPE OF EL
+ CAIE 0,(E) ; MATCH?
+ JRST WRNGUT
+ MOVE 0,1(C)
+ MOVEM 0,(D) ; CLOBBER
+ ADDI C,2
+ AOBJN D,IEUVE2 ; LOOP
+ TRO E,.VECT.
+ HRLZM E,(D) ; STORE UTYPE
+IEUVE1: POP P,A ; GET COUNY
+ ASH A,1 ; MUST FLUSH 2 TIMES # OF ELEMENTS
+ HRLI A,(A)
+ SUB TP,A ; CLEAN UP STACK
+ MOVSI A,TUVEC
+ POPJ P,
+
+; COMPILER'S CALL
+
+CIUVEC: SUBM M,(P)
+ PUSHJ P,IEUVEC
+ JRST MPOPJ
+
+IMFUNCTION EVECTOR,SUBR,[VECTOR]
+ ENTRY
+ HLRE A,AB
+ MOVNS A
+ PUSH P,A ;SAVE NUMBER OF WORDS
+ PUSHJ P,IBLOCK ; GET WORDS
+ MOVEI D,-1(B) ; SETUP FOR BLT AND DOPE CLOBBER
+ JUMPGE B,FINISV ;DONT COPY A ZERO LENGTH VECTOR
+
+ HRLI C,(AB) ;START BUILDING BLT POINTER
+ HRRI C,(B) ;TO ADDRESS
+ ADDI D,@(P) ;SET D TO FINAL ADDRESS
+ BLT C,(D)
+FINISV: MOVSI 0,400000+.VECT.
+ MOVEM 0,1(D) ; MARK AS GENERAL
+ SUB P,C%11
+ MOVSI A,TVEC
+ JRST FINIS
+
+
+
+\f;EXPLICIT VECTORS FOR THE UNIFORM CSE
+
+IMFUNCTION EUVECTOR,SUBR,[UVECTOR]
+
+ ENTRY
+ HLRE A,AB ;-NUM OF ARGS
+ MOVNS A
+ ASH A,-1 ;NEED HALF AS MANY WORDS
+ PUSH P,A
+ JUMPGE AB,EUV1 ; DONT CHECK FOR EMPTY
+ GETYP A,(AB) ;GET FIRST ARG
+ PUSHJ P,NWORDT ;SEE IF NEEDS EXTRA WORDS
+ SOJN A,CANTUN
+EUV1: POP P,A
+ PUSHJ P,IBLOCK ; GET VECT
+ JUMPGE B,FINISU
+
+ GETYP C,(AB) ;GET THE FIRST TYPE
+ MOVE D,AB ;COPY THE ARG POINTER
+ MOVE E,B ;COPY OF RESULT
+
+EUVLP: GETYP 0,(D) ;GET A TYPE
+ CAIE 0,(C) ;SAME?
+ JRST WRNGUT ;NO , LOSE
+ MOVE 0,1(D) ;GET GOODIE
+ MOVEM 0,(E) ;CLOBBER
+ ADD D,C%22 ;BUMP ARGS POINTER
+ AOBJN E,EUVLP
+
+ TRO C,.VECT.
+ HRLM C,(E) ;CLOBBER UNIFORM TYPE IN
+FINISU: MOVSI A,TUVEC
+ JRST FINIS
+
+WRNGSU: GETYP A,-1(TP)
+ CAIE A,TSTORAGE
+ JRST WRNGUT ;IF UVECTOR
+ PUSHJ P,FREESV ;FREE STORAGE VECTOR
+ ERRUUO EQUOTE TYPES-DIFFER-IN-STORAGE-OBJECT
+
+WRNGUT: ERRUUO EQUOTE TYPES-DIFFER-IN-UNIFORM-VECTOR
+
+CANTUN: ERRUUO EQUOTE DATA-CANT-GO-IN-UNIFORM-VECTOR
+
+BADNUM: ERRUUO EQUOTE NEGATIVE-ARGUMENT
+\f; FUNCTION TO GROW A VECTOR
+REPEAT 0,[
+MFUNCTION GROW,SUBR
+
+ ENTRY 3
+
+ MOVEI D,0 ;STACK HACKING FLAG
+ GETYP A,(AB) ;FIRST TYPE
+ PUSHJ P,SAT ;GET STORAGE TYPE
+ GETYP B,2(AB) ;2ND ARG
+ CAIE A,STPSTK ;IS IT ASTACK
+ CAIN A,SPSTK
+ AOJA D,GRSTCK ;YES, WIN
+ CAIE A,SNWORD ;UNIFORM VECTOR
+ CAIN A,S2NWORD ;OR GENERAL
+GRSTCK: CAIE B,TFIX ;IS 2ND FIXED
+ JRST WTYP2 ;COMPLAIN
+ GETYP B,4(AB)
+ CAIE B,TFIX ;3RD ARG
+ JRST WTYP3 ;LOSE
+
+ MOVEI E,1 ;UNIFORM/GENERAL FLAG
+ CAIE A,SNWORD ;SKIP IF UNIFORM
+ CAIN A,SPSTK ;DONT SKIP IF UNIFORM PDL
+ MOVEI E,0
+
+ HRRZ B,1(AB) ;POINT TO START
+ HLRE A,1(AB) ;GET -LENGTH
+ SUB B,A ;POINT TO DOPE WORD
+ SKIPE D ;SKIP IF NOT STACK
+ ADDI B,PDLBUF ;FUDGE FOR PDL
+ HLLZS (B) ;ZERO OUT GROWTH SPECS
+ SKIPN A,3(AB) ;ANY TOP GROWTH?
+ JRST GROW1 ;NO, LOOK FOR BOTTOM GROWTH
+ ASH A,(E) ;MULT BY 2 IF GENERAL
+ ADDI A,77 ;ROUND TO NEAREST BLOCK
+ ANDCMI A,77 ;CLEAR LOW ORDER BITS
+ ASH A,9-6 ;DIVIDE BY 100 AND SHIFT TO POSTION
+ TRZE A,400000 ;CONVERT TO SIGN MAGNITUDE
+ MOVNS A
+ TLNE A,-1 ;SKIP IF NOT TOO BIG
+ JRST GTOBIG ;ERROR
+GROW1: SKIPN C,5(AB) ;CHECK LOW GROWTH
+ JRST GROW4 ;NONE, SKIP
+ ASH C,(E) ;GENRAL FUDGE
+ ADDI C,77 ;ROUND
+ ANDCMI C,77 ;FUDGE FOR VALUE RETURN
+ PUSH P,C ;AND SAVE
+ ASH C,-6 ;DIVIDE BY 100
+ TRZE C,400 ;CONVERT TO SIGN MAGNITUDE
+ MOVNS C
+ TDNE C,[-1,,777000] ;CHECK FOR OVERFLOW
+ JRST GTOBIG
+GROW2: HLRZ E,1(B) ;GET TOTAL LENGTH OF VECTOR
+ MOVNI E,-1(E)
+ HRLI E,(E) ;TO BOTH HALVES
+ ADDI E,1(B) ;POINTS TO TOP
+ SKIPE D ;STACK?
+ ADD E,[PDLBUF,,0] ;YES, FUDGE LENGTH
+ SKIPL D,(P) ;SHRINKAGE?
+ JRST GROW3 ;NO, CONTINUE
+ MOVNS D ;PLUSIFY
+ HRLI D,(D) ;TO BOTH HALVES
+ ADD E,D ;POINT TO NEW LOW ADDR
+GROW3: IORI A,(C) ;OR TOGETHER
+ HRRM A,(B) ;DEPOSIT INTO DOPEWORD
+ PUSH TP,(AB) ;PUSH TYPE
+ PUSH TP,E ;AND VALUE
+ SKIPE A ;DON'T GC FOR NOTHING
+ MOVE C,[2,,0] ; GET INDICATOR FOR AGC
+ PUSHJ P,AGC
+ JUMPL A,GROFUL
+ POP P,C ;RESTORE GROWTH
+ HRLI C,(C)
+ POP TP,B ;GET VECTOR POINTER
+ SUB B,C ;POINT TO NEW TOP
+ POP TP,A
+ JRST FINIS
+
+GROFUL: SUB P,C%11 ; CLEAN UP STACK
+ SUB TP,C%22
+ PUSHJ P,FULLOS
+ JRST GROW
+
+GTOBIG: ERRUUO EQUOTE ATTEMPT-TO-GROW-VECTOR-TOO-MUCH
+GROW4: PUSH P,[0] ;0 BOTTOM GROWTH
+ JRST GROW2
+]
+FULLOS: ERRUUO EQUOTE NO-STORAGE
+
+
+\f; SUBROUTINE TO BUILD CHARACTER STRING GOODIES
+
+MFUNCTION BYTES,SUBR
+
+ ENTRY
+ MOVEI D,1
+ JUMPGE AB,TFA
+ GETYP 0,(AB)
+ CAIE 0,TFIX
+ JRST WTYP1
+ MOVE E,1(AB)
+ ADD AB,C%22
+ JRST STRNG1
+
+IMFUNCTION STRING,SUBR
+
+ ENTRY
+
+ MOVEI D,0
+ MOVEI E,7
+STRNG1: MOVE B,AB ;COPY ARG POINTER
+ MOVEI C,0 ;INITIALIZE COUNTER
+ PUSH TP,$TAB ;SAVE A COPY
+ PUSH TP,B
+ HLRE A,B ; GET # OF ARGS
+ MOVNS A
+ ASH A,-1 ; 1/2 FOR # OF ARGS
+ PUSHJ P,IISTRN
+ JRST FINIS
+
+IISTRN: PUSH P,E
+ JUMPL E,OUTRNG
+ CAILE E,36.
+ JRST OUTRNG
+ SKIPN E,A ; SKIP IF ARGS EXIST
+ JRST MAKSTR ; ALL DONE
+
+STRIN2: GETYP 0,(B) ;GET TYPE CODE
+ CAMN 0,SING(D) ; SINGLE CHARACTER OR FIX?
+ AOJA C,STRIN1
+ CAME 0,MULTI(D) ; OR STRING OR BYTE-STRING
+ JRST WRONGT ;NEITHER
+ HRRZ 0,(B) ; GET CHAR COUNT
+ ADD C,0 ; AND BUMP
+
+STRIN1: ADD B,C%22
+ SOJG A,STRIN2
+
+; NOW GET THE NECESSARY VECTOR
+
+MAKSTR: HRL C,MULTI(D) ; FINAL TYPE,, CHAR COUNT
+ PUSH P,C ; SAVE CHAR COUNT
+ PUSH P,E ; SAVE ARG COUNT
+ MOVEI D,36.
+ IDIV D,-2(P) ; A==> BYTES PER WORD
+ MOVEI A,(C) ; LNTH+4 TO A
+ ADDI A,-1(D)
+ IDIVI A,(D)
+ LSH E,12.
+ MOVE D,-2(P)
+ DPB D,[060600,,E]
+ HRLM E,-2(P) ; SAVE REMAINDER
+ PUSHJ P,IBLOCK
+
+ POP P,A
+ JUMPGE B,DONEC ; 0 LENGTH, NO STRING
+ HRLI B,440000 ;CONVERT B TO A BYTE POINTER
+ HRRZ 0,-1(P) ; BYTE SIZE
+ DPB 0,[300600,,B]
+ MOVE C,(TP) ; POINT TO ARGS AGAIN
+
+NXTRG1: GETYP D,(C) ;GET AN ARG
+ CAIN D,TFIX
+ JRST .+3
+ CAIE D,TCHRS
+ JRST TRYSTR
+ MOVE D,1(C) ; GET IT
+ IDPB D,B ;AND DEPOSIT IT
+ JRST NXTARG
+
+TRYSTR: MOVE E,1(C) ;GET BYTER
+ HRRZ 0,(C) ;AND COUNT
+NXTCHR: SOJL 0,NXTARG ; IF RUNOUT, GET NEXT ARG
+ ILDB D,E ;AND GET NEXT
+ IDPB D,B ; AND DEPOSIT SAME
+ JRST NXTCHR
+
+NXTARG: ADD C,C%22 ;BUMP ARG POINTER
+ SOJG A,NXTRG1
+ ADDI B,1
+
+DONEC: MOVSI C,TCHRS+.VECT.
+ TLO B,400000
+ HLLM C,(B) ;AND CLOBBER AWAY
+ HLRZ C,1(B) ;GET LENGTH BACK
+ POP P,A
+ SUBI B,-1(C)
+ HLL B,(P) ;MAKE A BYTE POINTER
+ SUB P,C%11
+ POPJ P,
+
+SING: TCHRS
+ TFIX
+
+MULTI: TCHSTR
+ TBYTE
+
+
+; COMPILER'S CALL TO MAKE A STRING
+
+CISTNG: TDZA D,D
+
+; COMPILERS CALL TO MAKE A BYTE STRING
+
+CBYTES: MOVEI D,1
+ SUBM M,(P)
+ MOVEI C,0 ; INIT CHAR COUNTER
+ MOVEI B,(A) ; SET UP STACK POINTER
+ ASH B,1 ; * 2 FOR NO. OF SLOTS
+ HRLI B,(B)
+ SUBM TP,B ; B POINTS TO ARGS
+ PUSH P,D
+ MOVEI E,7
+ JUMPE D,CBYST
+ GETYP 0,1(B) ; CHECK BYTE SIZE
+ CAIE 0,TFIX
+ JRST WRONGT
+ MOVE E,2(B)
+ ADD B,C%22
+ SUBI A,1
+CBYST: ADD B,C%11
+ PUSH TP,$TTP
+ PUSH TP,B
+ PUSHJ P,IISTRN ; MAKE IT HAPPEN
+ MOVE TP,(TP) ; FLUSH ARGS
+ SUB TP,C%11
+ POP P,D
+ JUMPE D,MPOPJ
+ SUB TP,C%22
+ JRST MPOPJ
+
+\f;BUILD IMPLICT STRING
+
+MFUNCTION IBYTES,SUBR
+
+ ENTRY
+
+ CAML AB,C%M20 ; [-3,,] ; AT LEAST 2
+ JRST TFA
+ CAMGE AB,C%M60 ; [-7,,] ; NO MORE THAN 3
+ JRST TMA
+ PUSHJ P,GETFIX ; GET BYTE SIZE
+ JUMPL A,OUTRNG
+ CAILE A,36.
+ JRST OUTRNG
+ PUSH P,[TFIX]
+ PUSH P,A
+ PUSH P,$TBYTE
+ ADD AB,C%22
+ MOVEM AB,ABSAV(TB)
+ JRST ISTR1
+
+MFUNCTION ISTRING,SUBR
+
+ ENTRY
+ JUMPGE AB,TFA ; TOO FEW ARGS
+ CAMGE AB,C%M40 ; [-4,,0] ; VERIFY NOT TOO MANY ARGS
+ JRST TMA
+ PUSH P,[TCHRS]
+ PUSH P,[7]
+ PUSH P,$TCHSTR
+ISTR1: PUSHJ P,GETFIX
+ MOVEI C,36.
+ IDIV C,-1(P)
+ ADDI A,-1(C)
+ IDIVI A,(C) ; # OF WORDS NEEDED TO A
+ ASH D,12.
+ MOVE C,-1(P) ; GET BYTE SIZE
+ DPB C,[060600,,D]
+ PUSH P,D
+ PUSHJ P,IBLOCK
+ HLRE C,B ; -LENGTH TO C
+ SUBM B,C ; LOCN OF DOPE WORD TO C
+ HRLI D,TCHRS+.VECT. ; CLOBBER ITS TYPE
+ HLLM D,(C)
+ MOVE A,-1(P)
+ HRR A,1(AB) ; SETUP TYPE'S RH
+ SUBI B,1
+ HRL B,(P) ; AND BYTE POINTER
+ SUB P,C%33
+ SKIPE (AB)+1 ; SKIP IF NO CHARACTERS TO DEPOSIT
+ CAML AB,C%M20 ; [-2,,0] ; SKIP IF 2 ARGS GIVEN
+ JRST FINIS
+ PUSH TP,A ;SAVE OUR STRING
+ PUSH TP,B
+ PUSH TP,A ;SAVE A TEMPORARY CLOBBER POINTER
+ PUSH TP,B
+ PUSH P,(AB)1 ;SAVE COUNT
+ PUSH TP,(AB)+2
+ PUSH TP,(AB)+3
+CLOBST: PUSH TP,-1(TP)
+ PUSH TP,-1(TP)
+ MCALL 1,EVAL
+ GETYP C,A ; CHECK IT
+ CAME C,-1(P) ; MUST BE A CHARACTER
+ JRST WTYP2
+ IDPB B,-2(TP) ;CLOBBER
+ SOSLE (P) ;FINISHED?
+ JRST CLOBST ;NO
+ SUB P,C%22
+ SUB TP,C%66
+ MOVE A,(TP)+1
+ MOVE B,(TP)+2
+ JRST FINIS
+
+\f
+; HERE TO CHECK TO SEE WHETHER PURE RSUBR'S ARE MAPPED BELOW FRETOP AND
+; PUNT SOME IF THERE ARE.
+
+INQAGC: PUSH P,C
+ PUSH P,B
+ PUSH P,A
+ PUSH P,E
+ PUSHJ P,SQKIL
+ JSP E,CKPUR ; CHECK FOR PURE RSUBR
+ POP P,E
+ MOVE A,PURTOP
+ SUB A,CURPLN
+ MOVE B,RFRETP ; GET REAL FRETOP
+ CAIL B,(A)
+ MOVE B,A ; TOP OF WORLD
+ MOVE A,GCSTOP
+ ADD A,GETNUM
+ ADDI A,1777 ; PAGE BOUNDARY
+ ANDCMI A,1777
+ CAIL A,(B) ; SEE WHETHER THERE IS ROOM
+ JRST GOTOGC
+ PUSHJ P,CLEANT
+ POP P,A
+ POP P,B
+ POP P,C
+ POPJ P,
+GOTOGC: POP P,A
+ POP P,B
+ POP P,C ; RESTORE CAUSE INDICATOR
+ MOVE A,P.TOP
+ PUSHJ P,CLEANT ; CLEAN UP
+ SKIPL PLODR ; IF IN PLOAD DON'T INTERRUPT
+ JRST INTAGC ; GO CAUSE GARBAGE COLLECT
+ JRST SAGC
+
+CLEANT: PUSH P,C
+ PUSH P,A
+ SUB A,P.TOP
+ ASH A,-PGSZ
+ JUMPE A,CLNT1
+ PUSHJ P,GETPAG ; GET THOSE PAGES
+ FATAL CAN'T GET PAGES NEEDED
+ MOVE A,(P)
+ ASH A,-10. ; TO PAGES
+ PUSHJ P,P.CORE
+ PUSHJ P,SLEEPR
+CLNT1: PUSHJ P,RBLDM
+ POP P,A
+ POP P,C
+ POPJ P,
+
+\f; RCLVEC DISTASTEFUL VECTOR RECYCLER
+
+; Arrive here with B pointing to first recycler, A desired length
+
+RCLVEC: PUSH P,D ; Save registers
+ PUSH P,C
+ PUSH P,E
+ MOVEI D,RCLV ; Point to previous recycle for splice
+RCLV1: HLRZ C,(B) ; Get size of this block
+ CAIL C,(A) ; Skip if too small
+ JRST FOUND1
+
+RCLV2: MOVEI D,(B) ; Save previous pointer
+ HRRZ B,(B) ; Point to next block
+ JUMPN B,RCLV1 ; Jump if more blocks
+
+ POP P,E
+ POP P,C
+ POP P,D
+ JRST NORCL ; Go to normal allocator
+
+
+FOUND1: CAIN C,1(A) ; Exactly 1 greater?
+ JRST RCLV2 ; Cant use this guy
+
+ HRLM A,(B) ; Smash in new count
+ TLO A,.VECT. ; make vector bit be on
+ HLLM A,-1(B)
+ CAIE C,(A) ; Exactly right length?
+ JRST FOUND2 ; No, do hair
+
+ HRRZ C,(B) ; Point to next block
+ HRRM C,(D) ; Smash previous pointer
+ HRRM B,(B)
+ SUBI B,-1(A) ; Point to top of block
+ JRST FOUND3
+
+FOUND2: SUBI C,(A) ; Amount of left over to C
+ HRRZ E,(B) ; Point to next block
+ HRRM B,(B)
+ SUBI B,(A) ; Point to dope words of guy to put back
+ MOVSM C,(B) ; Smash in count
+ MOVSI C,.VECT. ; Get vector bit
+ MOVEM C,-1(B) ; Make sure it is a vector
+ HRRM B,(D) ; Splice him in
+ HRRM E,(B) ; And the next guy also
+ ADDI B,1 ; Point to start of vector
+
+FOUND3: HRROI B,(B) ; Make an AOBJN pointer
+ TLC B,-3(A)
+ HRRI A,TVEC
+ SKIPGE A
+ HRRI A,TUVEC
+ MOVSI A,(A)
+ POP P,E
+ POP P,C
+ POP P,D
+ POPJ P,
+
+END
+\f
\ No newline at end of file
--- /dev/null
+
+ TITLE STRBUILD MUDDLE STRUCTURE BUILDER
+
+.GLOBAL RCL,VECTOP,GCSTOP,GCSBOT,FRETOP,GCSNEW,VECBOT,PARTOP,PARBOT,HITOP,HIBOT,GETPAG
+.GLOBAL PDLBUF,PDLEX,PDLEXP,GCFLG,GCPDL,GETNUM,PARNEW,MOVPUR,RCLV,RCLVEC
+.GLOBAL PGROW,TPGROW,MAINPR,%SLEEP,MSGTYP,PURTOP,PURBOT,STOSTR,RBLDM,CPOPJ,CPOPJ1,STBL
+.GLOBAL MTYI,UPLO,FRMUNG,BYTDOP,GLOBSP,FREDIF,FREMIN,GCHAPN,INTFLG,PINIT,CKPUR,GCSET
+.GLOBAL SAT,TTOCHN,TYPVEC,ICONS,INCONS,IBLOCK,IEUVEC,IEVECTI,CELL2,MKTBS,CPOPJ1,.LIST.
+.GLOBAL GIBLOK,REHASH,IBLOK1,IILIST,IIFORM,CIVEC,CIUVEC,CICONS,SLEEPR,GCHK10,FPAG
+.GLOBAL SPBASE,OUTRNG,CISTNG,CBYTES,%RUNAM,PURVEC,GCDOWN,N.CHNS,CHNL1,PLODR,C1CONS
+.GLOBAL CAFRE,CAFRET,STOGC,GCHN,WNDP,FRNP,FRONT,%GCJOB,%SHWND,%INFMP,%GETIP
+.GLOBAL TD.PUT,TD.GET,TD.LNT,GLOTOP,UBIT,FLGSET,PURMNG,RPURBT,%IFMP2,CHKPGI,PURCLN
+.GLOBAL CTIME,MTYO,ILOC,NODES,GPURFL,GCDANG,GCHACK,LPUR,HITOP,BADCHN,IMPURX
+.GLOBAL NOWLVL,CURPLN,PVSTOR,SPSTOR,MPOPJ,NGCS,RNUMSP,NUMSWP,SAGC,INQAGC
+.GLOBAL GCTIM,GCCAUS,GCCALL,AAGC,LVLINC,STORIC,GVLINC,TYPIC,GCRSET,ACCESS,NOSHUF,SQUPNT
+; GLOBALS ASSOCIATE WITH THE ASSOCIATION VECTOR
+
+.GLOBAL ASOVEC,ASOLNT,ITEM,INDIC,VAL,NWORDT,NODPNT,PNTRS
+.GLOBAL CELL,BINDID,GCFLCH,TYPBOT,GLOBAS,TPBASE
+.GLOBAL TPBINC,GBLINC,TYPINC,CONADJ,OGCSTP,ABOTN
+.GLOBAL AGC,ROOT,CIGTPR,IIGLOC
+.GLOBAL P.TOP,P.CORE,PMAPB
+.GLOBAL %MPINT,%GBINT,%CLSMP,%CLSM1
+.GLOBAL GCKNUM,CORTOP,GCHPN,INTAGC,WNDP,WNDBOT,BUFGC,WIND,GCDFLG,SAVM
+
+; SHARED SYMBOLS WITH GC MODULE
+
+.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,PMIN,PURMIN
+.GLOBAL GLBINC,GCHAIR,GCMONF,SQKIL,INBLOT
+.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
+
+NOPAGS==1 ; NUMBER OF WINDOWS
+EOFBIT==1000
+PDLBUF=100
+
+.ATOM.==200000 ; FLAG SAYING ATOMS MARKED (FOR VAL FLUSH LOGIC)
+
+GCHN==0 ; CHANNEL FOR FUNNNY INFERIOR
+STATNO==19. ; # OF STATISTICS FOR BLOAT-STAT
+STATGC==8. ; # OF GC-STATISTICS FOR BLOAT-STAT
+
+
+RELOCATABLE
+.INSRT MUDDLE >
+SYSQ
+IFE ITS,[
+.INSRT STENEX >
+]
+IFN ITS, PGSZ==10.
+IFE ITS, PGSZ==9.
+
+
+\f; GC-READ TAKES ONE ARGUMENT WHICH MUST BE A "READB" CHANNEL
+
+.GLOBAL CLOOKU,CINSER,MOBLIST,CATOM,EOFCND,IGLOC
+
+MFUNCTION GCREAD,SUBR,[GC-READ]
+
+ ENTRY
+
+ CAML AB,C%M2 ; CHECK # OF ARGS
+ JRST TFA
+ CAMGE AB,C%M40
+ JRST TMA
+
+ GETYP A,(AB) ; MAKE SURE ARG IS A CHANNEL
+ CAIE A,TCHAN
+ JRST WTYP2 ; IT ISN'T COMPLAIN
+ MOVE B,1(AB) ; GET PTR TO CHANNEL
+ HRRZ C,-2(B) ; LOOK AT BITS IN CHANNEL
+ TRC C,C.OPN+C.READ+C.BIN
+ TRNE C,C.OPN+C.READ+C.BIN
+ JRST BADCHN
+
+ PUSH P,1(B) ; SAVE ITS CHANNEL #
+IFN ITS,[
+ MOVE B,[-2,,C] ; SET UP AOBJN PTR TO READ IN DELIMITING
+ ; CONSTANTS
+ MOVE A,(P) ; GET CHANNEL #
+ DOTCAL IOT,[A,B]
+ FATAL GCREAD-- IOT FAILED
+ JUMPL B,EOFGC ; IF BLOCK DIDN'T FINISH THEN EOF
+]
+IFE ITS,[
+ MOVE A,(P) ; GET CHANNEL
+ BIN
+ MOVE C,B ; TO C
+ BIN
+ MOVE D,B ; TO D
+ GTSTS ; SEE IF EOF
+ TLNE B,EOFBIT
+ JRST EOFGC
+]
+
+ PUSH P,C ; SAVE AC'S
+ PUSH P,D
+
+IFN ITS,[
+ MOVE B,[-3,,C] ; NEXT GROUP OF WORDS
+ DOTCAL IOT,[A,B]
+ FATAL GCREAD--GC IOT FAILED
+]
+IFE ITS,[
+ MOVE A,-2(P) ; GET CHANNEL
+ BIN
+ MOVE C,B
+ BIN
+ MOVE D,B
+ BIN
+ MOVE E,B
+]
+ MOVEI 0,0 ; DO PRELIMINARY TESTS
+ IOR 0,A ; IOR ALL WORDS IN
+ IOR 0,B
+ IOR 0,C
+ IOR 0,(P)
+ IOR 0,-1(P)
+ TLNE 0,-1 ; SKIP IF NO BITS IN LEFT HALF
+ JRST ERDGC
+
+ MOVEM D,NNPRI
+ MOVEM E,NNSAT
+ MOVE D,C ; GET START OF NEWTYPE TABLE
+ SUB D,-1(P) ; CREATE AOBJN POINTER
+ HRLZS D
+ ADDI D,(C)
+ MOVEM D,TYPTAB ; SAVE IT
+ MOVE A,(P) ; GET LENGTH OF WORD
+ SUBI A,CONADJ ; SUBTRACT FOR CONSTANTS
+
+ ADD A,GCSTOP
+ CAMG A,FRETOP ; SEE IF GC IS NESESSARY
+ JRST RDGC1
+ MOVE C,(P)
+ ADDM C,GETNUM ; MOVE IN REQUEST
+ MOVE C,[0,,1] ; ARGS TO GC
+ PUSHJ P,INQAGC ; GC
+RDGC1: MOVE C,GCSTOP ; GET CURRENT TOP OF THE WORLD
+ MOVEM C,OGCSTP ; SAVE IT
+ ADD C,(P) ; CALCULATE NEW GCSTOP
+ ADDI C,2 ; SUBTRACT FOR CONSTANTS
+ MOVEM C,GCSTOP
+ SUB C,OGCSTP
+ SUBI C,2 ; SUBSTRACT TO GET RID OF D.W'S
+ MOVNS C ; SET UP AOBJN PTR FOR READIN
+IFN ITS,[
+ HRLZS C
+ MOVE A,-2(P) ; GET CHANNEL #
+ ADD C,OGCSTP
+ DOTCAL IOT,[A,C]
+ FATAL GCREAD-- IOT FAILED
+]
+IFE ITS,[
+ MOVE A,-2(P) ; CHANNEL TO A
+ MOVE B,OGCSTP ; SET UP BYTE POINTER
+ HRLI B,444400
+ SIN ; IN IT COMES
+]
+
+ MOVE C,(P) ; GET LENGHT OF OBJECT
+ ADDI A,5
+ MOVE B,1(AB) ; GET CHANNEL
+ ADDM C,ACCESS(B)
+ MOVE D,GCSTOP ; SET UP TO LOOK LIKE UVECTOR OF LOSES
+ ADDI C,2 ; ADD 2 FOR DOPE WORDS
+ HRLM C,-1(D)
+ MOVSI A,.VECT.
+ SETZM -2(D)
+ IORM A,-2(D) ; MARK VECTOR BIT
+ PUSH TP,$TRDTB ; HOLD ON IN CASE OF GC
+ MOVEI A,-2(D)
+ MOVN C,(P)
+ ADD A,C
+ HRL A,C
+ PUSH TP,A
+
+ MOVE D,-1(P) ; SET UP BOTTOM OF ATOM TABLE
+ SUBI D,1
+ MOVEM D,ABOTN
+ MOVE C,GCSTOP ; START AT TOP OF WORLD
+ SUBI C,3 ; POINT TO FIRST ATOM
+
+; LOOP TO FIX UP THE ATOMS
+
+AFXLP: HRRZ 0,1(TB)
+ ADD 0,ABOTN
+ CAMG C,0 ; SEE IF WE ARE DONE
+ JRST SWEEIN
+ HRRZ 0,1(TB)
+ SUB C,0
+ PUSHJ P,ATFXU ; FIX IT UP
+ HLRZ A,(C) ; GET LENGTH
+ TRZ A,400000 ; TURN OFF MARK BIT
+ SUBI C,(A) ; POINT TO PRECEDING ATOM
+ HRRZS C ; CLEAR OFF NEGATIVE
+ JRST AFXLP
+
+; FIXUP ROUTINE FOR ATOMS (C==> D.W.)
+
+ATFXU: PUSH P,C ; SAVE PTR TO D.W.
+ ADD C,1(TB)
+ MOVE A,C
+ HLRZ B,(A) ; GET LENGTH AND MARKING
+ TRZE B,400000 ; TURN OF MARK BIT AND SKIP IF WAS ALREADY MARKED
+ JRST ATFXU1
+ MOVEI D,-3(B) ; FULL WORDS OF STRING IN PNAME
+ IMULI D,5 ; CALCULATE # OF CHARACTERS
+ MOVE 0,-2(A) ; GET LAST WORD OF STRING
+ SUBI A,-1(B) ; LET A POINT TO OBLIST SLOAT
+ MOVE B,A ; GET COPY OF A
+ MOVE A,0
+ SUBI A,1
+ ANDCM 0,A
+ JFFO 0,.+1
+ HRREI 0,-34.(A)
+ IDIVI 0,7 ; # OF CHARS IN LAST WORD
+ ADD D,0
+ ADD D,$TCHSTR ; MAKE IT LOOK LIKE A STRINGS TYPE-WORD
+ PUSH P,D ; SAVE IT
+ MOVE C,(B) ; GET OBLIST SLOT PTR
+ATFXU9: HRRZS B ; RELATAVIZE POINTER
+ HRRZ 0,1(TB)
+ SUB B,0
+ PUSH P,B
+ JUMPE C,ATFXU6 ; NO OBLIST. CREATE ATOM
+ CAMN C,C%M1 ; SEE IF ROOT ATOM
+ JRST RTFX
+ ADD C,ABOTN ; POINT TO ATOM
+ PUSHJ P,ATFXU
+ PUSH TP,$TATOM
+ PUSH TP,B
+ MOVE A,$TATOM ; SET UP TO SEE IF OBLIST EXITS
+ MOVE C,$TATOM
+ MOVE D,IMQUOTE OBLIST
+ PUSHJ P,CIGTPR
+ JRST ATFXU8 ; NO OBLIST. CREATE ONE
+ SUB TP,C%22 ; GET RID OF SAVED ATOM
+RTCON: PUSH TP,$TOBLS
+ PUSH TP,B
+ MOVE C,B ; SET UP FOR LOOKUP
+ MOVE A,-1(P) ; SET UP PTR TO PNAME
+ MOVE B,(P)
+ ADD B,[440700,,1] ; ADJUST TO MAKE IT LOOK LIKE A BYTE-POINTER
+ HRRZ 0,1(TB)
+ ADD B,0
+ PUSHJ P,CLOOKU
+ JRST ATFXU4 ; NOT ON IT SO INSERT
+ATFXU3: SUB P,C%22 ; DONE
+ SUB TP,C%22 ; POP OFF OBLIST
+ATFXU7: MOVE C,(P) ; RESTORE PTR TO D.W.
+ ADD C,1(TB)
+ MOVEM B,-1(C) ; MOVE IN RELATAVIZE ADDRESS
+ MOVSI D,400000
+ IORM D,(C) ; TURN OFF MARK BIT
+ MOVE 0,3(B) ; SEE IF MUST BE LOCR
+ TRNE 0,1 ; SKIP IF MUST MAKE IT IMPURE
+ PUSHJ P,IIGLOC
+ POP P,C
+ ADD C,1(TB)
+ POPJ P, ; EXIT
+ATFXU1: POP P,C ; RESTORE PTR TO D.W.
+ ADD C,1(TB)
+ MOVE B,-1(C) ; GET ATOM
+ POPJ P,
+
+; ROUTINE TO INSERT AN ATOM
+
+ATFXU4: MOVE C,(TP) ; GET OBLIST PTR
+ MOVE B,(P) ; SET UP STRING PTR TO PNAME
+ ADD B,[440700,,1]
+ HRRZ 0,1(TB)
+ ADD B,0
+ MOVE A,-1(P) ; GET TYPE WORD
+ PUSHJ P,CINSER ; INSERT IT
+ JRST ATFXU3
+
+; THIS ROUTINE CREATS THE ATOM SO THAT ITS NOT ON ANY OBLIST
+
+ATFXU6: MOVE B,(P) ; POINT TO PNAME
+ ADD B,[440700,,1] ; MAKE IT LOOK LIKE A BYTE POINTER
+ HRRZ 0,1(TB)
+ ADD B,0
+ MOVE A,-1(P)
+ PUSHJ P,CATOM
+ SUB P,C%22 ; CLEAN OFF STACK
+ JRST ATFXU7
+
+; THIS ROUTINE CREATES AND OBLIST
+
+ATFXU8: MCALL 1,MOBLIST
+ PUSH TP,$TOBLS
+ PUSH TP,B ; SAVE OBLIST PTR
+ JRST ATFXU4 ; JUMP TO INSERT THE OBLIST
+
+; HERE TO INSERT AN ATOM INTO THE ROOT OBLIST
+
+RTFX: MOVE B,ROOT+1 ; GET ROOT OBLIST
+ JRST RTCON
+
+; THIS ROUTINE SWEEPS THRU THE NEW CORE IMAGE AND UPDATES ALL THE POINTERS.
+
+SWEEIN:
+; ROUTINE TO FIX UP TYPE-TABLE FOR GC-READ. THIS ROUTINE FIXES UP THE TYPE TABLE SO THAT
+; THE TYPES ATOM I.D. IS REPLACED BY ITS TYPE-NUMBER IN THE NEW MUDDLE AND IF ITS A
+; TEMPLATE, THE SLOT FOR THE PRIMTYPE-ATOM IS REPLACED BY THE SAT OF THE TEMPLATE
+
+ HRRZ E,1(TB) ; SET UP TYPE TABLE
+ ADD E,TYPTAB
+ JUMPGE E,VUP ; SKIP OVER IF DONE
+TYPUP1: PUSH P,C%0 ; PUSH SLOT FOR POSSIBLE TEMPLATE ATOM
+ HLRZ A,1(E) ; GET POSSIBLE ATOM SLOT
+ JUMPE A,TYPUP2 ; JUMP IF NOT A TEMPLATE
+ ADD A,ABOTN ; GET ATOM
+ ADD A,1(TB)
+ MOVE A,-1(A)
+ MOVE B,TYPVEC+1 ; GET TYPE VECTOR SLOT FOR LOOP TO SEE IF ITS THERE
+TYPUP3: CAMN A,1(B) ; SKIP IF NOT EQUAL
+ JRST TYPUP4 ; FOUND ONE
+ ADD B,C%22 ; TO NEXT
+ JUMPL B,TYPUP3
+ JRST ERTYP1 ; ERROR NONE EXISTS
+TYPUP4: HRRZ C,(B) ; GET SAT SLOT
+ CAIG C,NUMSAT ; MAKE SURE TYPE IS A TEMPLATE
+ JRST ERTYP2 ; IF NOT COMPLAIN
+ HRLM C,1(E) ; SMASH IN NEW SAT
+ MOVE B,1(B) ; GET ATOM OF PRIMTYPE
+ MOVEM B,(P) ; PUSH ONTO STACK
+TYPUP2: MOVEI D,0 ; INITIALIZE TYPE COUNT FOR LOOKUP LOOP
+ MOVE B,TYPVEC+1 ; GET PTR FOR LOOP
+ HRRZ A,1(E) ; GET TYPE'S ATOM ID
+ ADD A,ABOTN ; GET ATOM
+ ADD A,1(TB)
+ MOVE A,-1(A)
+TYPUP5: CAMN A,1(B) ; SKIP IF NOT EQUAL
+ JRST TYPUP6 ; FOUND ONE
+ ADDI D,1 ; INCREMENT TYPE-COUNT
+ ADD B,C%22 ; POINT TO NEXT
+ JUMPL B,TYPUP5
+ HRRM D,1(E) ; CLOBBER IN TYPE-NUMBER
+ PUSH TP,$TATOM ; PUSH ARGS FOR NEWTYPE
+ PUSH TP,A
+ PUSH TP,$TATOM
+ POP P,B ; GET BACK POSSIBLE PRIMTYPE ATOM
+ JUMPE B,TYPUP7 ; JUMP IF NOT A TEMPLATE
+ PUSH TP,B ; PUSH ON PRIMTYPE
+TYPUP9: SUB E,1(TB)
+ PUSH P,E ; SAVE RELATAVIZED PTR TO TYPE-TABLE
+ MCALL 2,NEWTYPE
+ POP P,E ; RESTORE RELATAVIZED PTR
+ ADD E,1(TB) ; FIX IT UP
+TYPUP0: ADD E,C%22 ; INCREMENT E
+ JUMPL E,TYPUP1
+ JRST VUP
+TYPUP7: HRRZ B,(E) ; FIND PRIMTYPE FROM SAT
+ MOVE A,@STBL(B)
+ PUSH TP,A
+ JRST TYPUP9
+TYPUP6: HRRM D,1(E) ; CLOBBER IN TYPE #
+ JRST TYPUP0
+
+ERTYP1: ERRUUO EQUOTE CANT-FIND-TEMPLATE
+
+ERTYP2: ERRUUO EQUOTE TEMPLATE-TYPE-NAME-NOT-OF-TYPE-TEMPLATE
+
+VUP: HRRZ E,1(TB) ; FIX UP SOME POINTERS
+ MOVEM E,OGCSTP
+ ADDM E,ABOTN
+ ADDM E,TYPTAB
+
+
+; ROUTINE TO SWEEP THRU THE READ-IN IMAGE LOOKING FOR UVECTORS AND TEMPLATES.
+; WHILE SWEEPING IT FIXES UP THE DOPE WORDS APPROPRIATELY.
+
+ HRRZ A,TYPTAB ; GET TO TOP OF WORLD
+ SUBI A,2 ; GET TO FIRST TYPE WORD OR DOPE-WORD OF FIRST OBJECT
+VUP1: CAMG A,OGCSTP ; SKIP IF NOT DONE
+ JRST VUP3
+ HLRZ B,(A) ; GET TYPE SLOT
+ TRNE B,.VECT. ; SKIP IF NOT A VECTOR
+ JRST VUP2
+ SUBI A,2 ; SKIP OVER PAIR
+ JRST VUP1
+VUP2: TRNE B,400000 ; SKIP IF UVECTOR
+ JRST VUP4
+ ANDI B,TYPMSK ; GET RID OF MONITORS
+ CAMG B,NNPRI ; SKIP IF NEWTYPE
+ JRST VUP5
+ PUSHJ P,GETNTP ; GET THE NEW TYPE #
+ PUTYP B,(A) ; SMASH IT IT
+VUP5: HLRZ B,1(A) ; SKIP OVER VECTOR
+ TRZ B,400000 ; GET RID OF POSSIBLE MARK BIT
+ SUBI A,(B)
+ JRST VUP1 ; LOOP
+VUP4: ANDI B,TYPMSK ; FLUSH MONITORS
+ CAMG B,NNSAT ; SKIP IF TEMPLATE
+ JRST VUP5
+ PUSHJ P,GETSAT ; CONVERT TO NEW SAT
+ ADDI B,.VECT. ; MAJIC TO TURN ON BIT
+ PUTYP B,(A)
+ JRST VUP5
+
+
+VUP3: PUSH P,GCSBOT ; SAVE CURRENT GCSBOT
+ MOVE A,OGCSTP ; SET UP NEW GCSBOT
+ MOVEM A,GCSBOT
+ PUSH P,GCSTOP
+ HRRZ A,TYPTAB ; SET UP NEW GCSTOP
+ MOVEM A,GCSTOP
+ SETOM GCDFLG
+ MOVE A,[PUSHJ P,RDFIX] ; INS FOR GCHACK
+ MOVEI PVP,0 ; SAY MIGHT BE NON-ATOMS
+ PUSHJ P,GCHK10
+ SETZM GCDFLG
+ POP P,GCSTOP ; RESTORE GCSTOP
+ MOVE A,1(TB) ; GET A POINTER TO RETURNING VALUES
+ MOVE B,A
+ HLRE C,B
+ SUB B,C
+ SETZM (B)
+ SETZM 1(B)
+ POP P,GCSBOT ; RESTORE GCSBOT
+ MOVE B,1(A) ; GET PTR TO OBJECTS
+ MOVE A,(A)
+ JRST FINIS ; EXIT
+
+; ERROR FOR INCORRECT GCREAD FILE
+
+ERDGC: ERRUUO EQUOTE BAD-GC-READ-FILE
+
+; ROUTINE CALLED BY GCHACK TO UPDATE PTRS IN THE NEW CORE IMAGE
+
+RDFIX: PUSH P,C ; SAVE C
+ PUSH P,B ; SAVE PTR
+ EXCH B,C
+ TLNE C,UBIT ; SKIP IF NOT UVECTOR
+ JRST ELEFX ; DON'T HACK TYPES IN UVECTOR
+ CAIN B,TTYPEC
+ JRST TYPCFX
+ CAIN B,TTYPEW
+ JRST TYPWFX
+ CAML B,NNPRI
+ JRST TYPGFX
+ELEFX: EXCH B,A ; EXCHANGE FOR SAT
+ PUSHJ P,SAT
+ EXCH B,A ; REFIX
+ CAIE B,SLOCR ; REL GLOC'S ARE STORED AS ATOMS
+ CAIN B,SATOM
+ JRST ATFX
+ CAIN B,SCHSTR
+ JRST STFX
+ CAIN B,S1WORD ; SEE IF PRIMTYPE WOR
+ JRST RDLSTF ; LEAVE IF IS
+STFXX: MOVE 0,GCSBOT ; ADJUSTMENT
+ SUBI 0,FPAG+5
+ SKIPE 1(C) ; DON'T CHANGE A PTR TO NIL
+ ADDM 0,1(C) ; FIX UP
+RDLSTF: TLNN C,.LIST. ; SEE IF PAIR
+ JRST RDL1 ; EXIT
+ MOVE 0,GCSBOT ; FIX UP
+ SUBI 0,FPAG+5
+ HRRZ B,(C) ; SEE IF POINTS TO NIL
+ SKIPN B
+ JRST RDL1
+ MOVE B,C ; GET ARG FOR RLISTQ
+ PUSHJ P,RLISTQ
+ JRST RDL1
+ ADDM 0,(C)
+RDL1: POP P,B ; RESTORE B
+ POP P,C
+ POPJ P,
+
+; ROUTINE TO FIX UP PNAMES
+
+STFX: TLZN D,STATM
+ JRST STFXX
+ HLLM D,1(C) ; PUT BACK WITH BIT OFF
+ ADD D,ABOTN
+ ANDI D,-1
+ HLRE 0,-1(D) ; LENGTH OF ATOM
+ MOVNS 0
+ SUBI 0,3 ; VAL & OBLIST
+ IMULI 0,5 ; TO CHARS (SORT OF)
+ HRRZ D,-1(D)
+ ADDI D,2
+ PUSH P,A
+ PUSH P,B
+ LDB A,[360600,,1(C)] ; GET BYTE POS
+ IDIVI A,7 ; TO CHAR POS
+ SKIPE A
+ SUBI A,5
+ HRRZ B,(C) ; STRING LENGTH
+ SUB B,A ; TO WORD BOUNDARY STRING
+ SUBI 0,(B)
+ IDIVI 0,5
+ ADD D,0
+ POP P,B
+ POP P,A
+ HRRM D,1(C)
+ JRST RDLSTF
+
+; ROUTINE TO FIX UP POINTERS TO ATOMS
+
+ATFX: SKIPGE D
+ JRST RDLSTF
+ ADD D,ABOTN
+ MOVE 0,-1(D) ; GET PTR TO ATOM
+ CAIE B,SLOCR ; IF REL LOCATIVE, MORE HAIR
+ JRST ATFXAT
+ MOVE B,0
+ PUSH P,E
+ PUSH P,D
+ PUSH P,C
+ PUSH P,B
+ PUSH P,A
+ PUSHJ P,IGLOC
+ SUB B,GLOTOP+1
+ MOVE 0,B
+ POP P,A
+ POP P,B
+ POP P,C
+ POP P,D
+ POP P,E
+ATFXAT: MOVEM 0,1(C) ; SMASH IT IN
+ JRST RDLSTF ; EXIT
+
+TYPCFX: HRRZ B,1(C) ; GET TYPE
+ PUSHJ P,GETNEW ; GET TYPE IN THIS CORE IMAGE
+ HRRM B,1(C) ; CLOBBER IT IN
+ JRST RDLSTF ; CONTINUE FIXUP
+
+TYPWFX: HLRZ B,1(C) ; GET TYPE
+ PUSHJ P,GETNEW ; GET TYPE IN THIS CORE IMAGE
+ HRLM B,1(C) ; SMASH IT IN
+ JRST ELEFX
+
+TYPGFX: PUSH P,D
+ PUSHJ P,GETNTP ; GET TYPE IN THIS CORE IMAGE
+ POP P,D
+ PUTYP B,(C)
+ JRST ELEFX
+
+; HERE TO HANDLE AN EOF IN GC-READ. IT USES OPTIONAL SECOND ARG IF SUPPLIED AS
+; EOF HANDLER ELSE USES CHANNELS.
+
+EOFGC: MOVE B,1(AB) ; GET CHANNEL INTO B
+ CAML AB,C%M20 ; [-2,,0] ; SKIP IF EOF ROUTINE IS SUPPLIED
+ JRST MYCLOS ; USE CHANNELS
+ PUSH TP,2(AB)
+ PUSH TP,3(AB)
+ JRST CLOSIT
+MYCLOS: PUSH TP,EOFCND-1(B)
+ PUSH TP,EOFCND(B)
+CLOSIT: PUSH TP,$TCHAN
+ PUSH TP,B
+ MCALL 1,FCLOSE ; CLOSE CHANNEL
+ MCALL 1,EVAL ; EVAL HIS EOF HANDLER
+ JRST FINIS
+
+; ROUTINE TO SUPPLY THE TYPE NUMBER FOR A NEWTYPE
+
+GETNEW: CAMG B,NNPRI ;NEWTYPE
+ POPJ P,
+GETNTP: MOVE D,TYPTAB ; GET AOBJN POINTER TO TYPE-TABLE
+GETNT1: HLRZ E,(D) ; GET TYPE #
+ CAIN E,(B) ; SKIP IF NOT EQUAL TO GOAL
+ JRST GOTTYP ; FOUND IT
+ ADD D,C%22 ; POINT TO NEXT
+ JUMPL D,GETNT1
+ SKIPA ; KEEP TYPE SAME
+GOTTYP: HRRZ B,1(D) ; GET NEW TYPE #
+ POPJ P,
+
+; ROUTINE TO SUPPLY THE SAT TO A TEMPLATE HACKER
+
+GETSAT: MOVE D,TYPTAB ; GET AOBJN PTR TO TYPE TABLE
+GETSA1: HRRZ E,(D) ; GET OBJECT
+ CAIN E,(B) ; SKIP IF NOT EQUAL TO GOAL
+ JRST GOTSAT ; FOUND IT
+ ADD D,C%22
+ JUMPL D,GETSA1
+ FATAL GC-DUMP -- TYPE FIXUP FAILURE
+GOTSAT: HLRZ B,1(D) ; GET NEW SAT
+ POPJ P,
+
+
+; A ROUTINE TO DISTINGUISH BETWEEN A DEFERRED AND A LIST POINTER
+RLISTQ: PUSH P,A
+ GETYP A,(B) ; GET TYPE
+ PUSHJ P,SAT ; GET SAT
+ CAIG A,NUMSAT ; NOT DEFERRED IF TEMPLATE
+ SKIPL MKTBS(A)
+ AOS -1(P) ; SKIP IF NOT DEFFERED
+ POP P,A
+ POPJ P, ; EXIT
+
+\f
+.GLOBAL FLIST
+
+MFUNCTION BLOATSTAT,SUBR,[BLOAT-STAT]
+
+ENTRY
+
+ JUMPGE AB,GETUVC ; SEE IF THERE IS AN ARGUMENT
+ GETYP A,(AB)
+ CAIE A,TUVEC ; SEE IF THE ARGUMENT IS A UVECTOR
+ JRST WTYP1 ; IF NOT COMPLAIN
+ HLRE 0,1(AB)
+ MOVNS 0
+ CAIE 0,STATNO+STATGC ; SEE IF UVECTOR IS RIGHT LENGTH
+ JRST WTYP1
+ CAMGE AB,C%M20 ; [-2,,0] ; SEE IF THERE ARE TOO MANY ARGUMENTS
+ JRST TMA
+ MOVE A,(AB) ; GET THE UVECTOR
+ MOVE B,1(AB)
+ JRST SETUV ; CONTINUE
+GETUVC: MOVEI A,STATNO+STATGC ; CREATE A UVECTOR
+ PUSHJ P,IBLOCK
+SETUV: PUSH P,A ; SAVE UVECTOR
+ PUSH P,B
+ MOVE 0,NOWFRE ; COMPUTE FREE STORAGE USED SINCE LAST BLOAT-STAT
+ SUB 0,RFRETP
+ ADD 0,GCSTOP
+ MOVEM 0,CURFRE
+ PUSHJ P,GCSET ; FIX UP BLOAT-STAT PARAMETERS
+ HLRE 0,TP ; COMPUTE STACK SPACE USED UP
+ ADD 0,NOWTP
+ SUBI 0,PDLBUF
+ MOVEM 0,CURTP
+ MOVE B,IMQUOTE THIS-PROCESS
+ PUSHJ P,ILOC
+ HRRZS B
+ MOVE PVP,PVSTOR+1
+ HRRZ C,TPBASE+1(PVP) ; CALCULATE # OF ATOM SLOTS
+ MOVE 0,B
+ HRRZ D,SPBASE+1(PVP) ; COMPUTE CURRENT # OF BINDINGS
+ SUB 0,D
+ IDIVI 0,6
+ MOVEM 0,CURLVL
+ SUB B,C ; TOTAL WORDS ATOM STORAGE
+ IDIVI B,6 ; COMPUTE # OF SLOTS
+ MOVEM B,NOWLVL
+ HRRZ A,GLOBASE+1 ; COMPUTE TOTAL # OF GLOBAL SLOTS
+ HLRE 0,GLOBASE+1
+ SUB A,0 ; POINT TO DOPE WORD
+ HLRZ B,1(A)
+ ASH B,-2 ; # OF GVAL SLOTS
+ MOVEM B,NOWGVL
+ HRRZ A,GLOTOP+1 ; COMPUTE # OF GVAL SLOTS IN USE
+ HRRZ 0,GLOBSP+1
+ SUB A,0
+ ASH A,-2 ; NEGATIVE # OF SLOTS USED
+ MOVEM A,CURGVL
+ HRRZ A,TYPBOT+1 ; GET LENGTH OF TYPE VECTOR
+ HLRE 0,TYPBOT+1
+ SUB A,0
+ HLRZ B,1(A) ; # OF WORDS IN TYPE-VECTOR
+ IDIVI B,2 ; CONVERT TO # OF TYPES
+ MOVEM B,NOWTYP
+ HLRE 0,TYPVEC+1 ; LENGTH OF VISABLE TYPE-VECTOR
+ MOVNS 0
+ IDIVI 0,2 ; GET # OF TYPES
+ MOVEM 0,CURTYP
+ MOVE 0,CODTOP ; GET LENGTH OF STATIONARY IMPURE STORAGE
+ MOVEM 0,NOWSTO
+ SETZB B,D ; ZERO OUT MAXIMUM
+ HRRZ C,FLIST
+LOOPC: HLRZ 0,(C) ; GET BLK LENGTH
+ ADD D,0 ; ADD # OF WORDS IN BLOCK
+ CAMGE B,0 ; SEE IF NEW MAXIMUM
+ MOVE B,0
+ HRRZ C,(C) ; POINT TO NEXT BLOCK
+ JUMPN C,LOOPC ; REPEAT
+ MOVEM D,CURSTO
+ MOVEM B,CURMAX
+ HLRE 0,P ; GET AMOUNT OF ROOM LEFT ON P
+ ADD 0,NOWP
+ SUBI 0,PDLBUF
+ MOVEM 0,CURP
+ MOVSI C,BSTGC ; SET UP BLT FOR GC FIGURES
+ HRRZ B,(P) ; RESTORE B
+ HRR C,B
+ BLT C,(B)STATGC-1
+ HRLI C,BSTAT ; MODIFY BLT FOR STATS
+ HRRI C,STATGC(B)
+ BLT C,(B)STATGC+STATNO-1
+ MOVEI 0,TFIX+.VECT.
+ HRLM 0,(B)STATNO+STATGC ; MOVE IN UTYPE
+ POP P,B
+ POP P,A ; RESTORE TYPE-WORD
+ JRST FINIS
+
+GCRSET: SETZM GCNO ; CALL FROM INIT, ZAP ALL 1ST
+ MOVE 0,[GCNO,,GCNO+1]
+ BLT 0,GCCALL
+ JRST GCSET
+
+
+
+\f
+.GLOBAL PGFIND,PGGIVE,PGTAKE,PGINT
+
+; USER GARBAGE COLLECTOR INTERFACE
+.GLOBAL ILVAL
+
+MFUNCTION GC,SUBR
+ ENTRY
+
+ JUMPGE AB,GC1
+ CAMGE AB,C%M60 ; [-6,,0]
+ JRST TMA
+ PUSHJ P,GETFIX ; GET FREEE MIN IF GIVEN
+ SKIPE A ; SKIP FOR 0 ARGUMENT
+ MOVEM A,FREMIN
+GC1: PUSHJ P,COMPRM ; GET CURRENT USED CORE
+ PUSH P,A
+ CAML AB,C%M40 ; [-4,,0] ; SEE IF 3RD ARG
+ JRST GC5
+ GETYP A,4(AB) ; MAKE SURE A FIX
+ CAIE A,TFIX
+ JRST WTYP ; ARG WRONG TYPE
+ MOVE A,5(AB)
+ MOVEM A,RNUMSP
+ MOVEM A,NUMSWP
+GC5: CAML AB,C%M20 ; [-2,,0] ; SEE IF SECOND ARG
+ JRST GC3
+ GETYP A,2(AB) ; SEE IF NONFALSE
+ CAIE A,TFALSE ; SKIP IF FALSE
+ JRST HAIRGC ; CAUSE A HAIRY GC
+GC3: MOVSI A,TATOM ; CHECK TO SEE IF INTERRUPT FLAG IS ON
+ MOVE B,IMQUOTE AGC-FLAG
+ PUSHJ P,ILVAL
+ CAMN A,$TUNBOUND ; SKIP IF NOT UNBOUND
+ JRST GC2
+ SKIPE GCHPN ; SKIP IF GCHAPPEN IS 0
+ JRST FALRTN ; JUMP TO RETURN FALSE
+GC2: MOVE C,[9.,,0]
+ PUSHJ P,AGC ; COLLECT THAT TRASH
+ PUSHJ P,COMPRM ; HOW MUCH ROOM NOW?
+ POP P,B ; RETURN AMOUNT
+ SUB B,A
+ MOVSI A,TFIX
+ JRST FINIS
+HAIRGC: MOVE B,3(AB)
+ CAIN A,TFIX ; IF FIX THEN CLOBBER NGCS
+ MOVEM B,NGCS
+ MOVEI A,1 ; FORCE VALUE FLUSHING PHASE TO OCCUR
+ MOVEM A,GCHAIR
+ JRST GC2 ; HAIRY GC OCCORS NO MATTER WHAT
+FALRTN: MOVE A,$TFALSE
+ MOVEI B,0 ; RETURN A FALSE-- FOR GC WHICH DIDN'T OCCOR
+ JRST FINIS
+
+
+COMPRM: MOVE A,GCSTOP ; USED SPACE
+ SUB A,GCSBOT
+ POPJ P,
+
+\f
+MFUNCTION GCDMON,SUBR,[GC-MON]
+
+ ENTRY
+
+ MOVEI E,GCMONF
+
+FLGSET: MOVE C,(E) ; GET CURRENT VALUE
+ JUMPGE AB,RETFLG ; RET CURRENT
+ CAMGE AB,C%M20 ; [-3,,]
+ JRST TMA
+ GETYP 0,(AB)
+ SETZM (E)
+ CAIN 0,TFALSE
+ SETOM (E)
+ SKIPL E
+ SETCMM (E)
+
+RETFLG: SKIPL E
+ SETCMM C
+ JUMPL C,NOFLG
+ MOVSI A,TATOM
+ MOVE B,IMQUOTE T
+ JRST FINIS
+
+NOFLG: MOVEI B,0
+ MOVSI A,TFALSE
+ JRST FINIS
+
+.GLOBAL EVATYP,APLTYP,PRNTYP
+
+\fMFUNCTION BLOAT,SUBR
+ ENTRY
+
+ PUSHJ P,SQKIL
+ MOVEI C,0 ; FLAG TO SAY WHETHER NEED A GC
+ MOVSI E,-NBLO ; AOBJN TO BLOATER TABLE
+
+BLOAT2: JUMPGE AB,BLOAT1 ; ALL DONE?
+ PUSHJ P,NXTFIX ; GET NEXT BLOAT PARAM
+ SKIPE A
+ PUSHJ P,@BLOATER(E) ; DISPATCH
+ AOBJN E,BLOAT2 ; COUNT PARAMS SET
+
+ JUMPL AB,TMA ; ANY LEFT...ERROR
+BLOAT1: JUMPE C,BLOATD ; DONE, NO GC NEEDED
+ MOVE C,E ; MOVE IN INDICATOR
+ HRLI C,1 ; INDICATE THAT IT COMES FROM BLOAT
+ SETOM INBLOT
+ PUSHJ P,AGC ; DO ONE
+ SKIPE A,TPBINC ; SMASH POINNTERS
+ MOVE PVP,PVSTOR+1
+ ADDM A,TPBASE+1(PVP)
+ SKIPE A,GLBINC ; GLOBAL SP
+ ADDM A,GLOBASE+1
+ SKIPE A,TYPINC
+ ADDM A,TYPBOT+1
+ SETZM TPBINC ; RESET PARAMS
+ SETZM GLBINC
+ SETZM TYPINC
+
+BLOATD: SKIPN A,GETNUM ; SKIP IF FREE STORAGE REQUEST IN EFFECT
+ JRST BLTFN
+ ADD A,FRETOP ; ADD FRETOP
+ ADDI A,1777 ; ONE BLOCK FOR MARK PDL AND ROUND
+ ANDCMI A,1777 ; TO PAGE BOUNDRY
+ CAML A,PURBOT ; SKIP IF POSSIBLE TO WIN
+ JRST BLFAGC
+ ASH A,-10. ; TO PAGES
+ PUSHJ P,P.CORE ; GRET THE CORE
+ JRST BLFAGC ; LOSE LOSE LOSE
+ MOVE A,FRETOP ; CALCULATE NEW PARAMETERS
+ MOVEM A,RFRETP
+ MOVEM A,CORTOP
+ MOVE B,GCSTOP
+ SETZM 1(B)
+ HRLI B,1(B)
+ HRRI B,2(B)
+ BLT B,-1(A) ; ZERO CORE
+BLTFN: SETZM GETNUM
+ MOVE B,FRETOP
+ SUB B,GCSTOP
+ MOVSI A,TFIX ; RETURN CORE FOUND
+ JRST FINIS
+BLFAGC: MOVN A,FREMIN
+ ADDM A,GETNUM ; FIX UP SO BLOATS CORRECTLY
+ MOVE C,C%11 ; INDICATOR FOR AGC
+ PUSHJ P,AGC ; GARBAGE COLLECT
+ JRST BLTFN ; EXIT
+
+; TABLE OF BLOAT ROUTINES
+
+BLOATER:
+ MAINB
+ TPBLO
+ LOBLO
+ GLBLO
+ TYBLO
+ STBLO
+ PBLO
+ SFREM
+ SLVL
+ SGVL
+ STYP
+ SSTO
+ PUMIN
+ PMUNG
+ TPMUNG
+ NBLO==.-BLOATER
+
+; BLOAT MAIN STORAGE AREA
+
+MAINB: SETZM GETNUM
+ MOVE D,FRETOP ; COMPUTE CURRENT ROOM
+ SUB D,PARTOP
+ CAMGE A,D ; NEED MORE?
+ POPJ P, ; NO, LEAVE
+ SUB A,D
+ MOVEM A,GETNUM ; SAVE
+ POPJ P,
+
+; BLOAT TP STACK (AT TOP)
+
+TPBLO: HLRE D,TP ; GET -SIZE
+ MOVNS B,D
+ ADDI D,1(TP) ; POINT TO DOPE (ALMOST)
+ CAME D,TPGROW ; BLOWN?
+ ADDI D,PDLBUF ; POINT TO REAL DOPE WORD
+ SUB A,B ; SKIP IF GROWTH NEEDED
+ JUMPLE A,CPOPJ
+ ADDI A,63.
+ ASH A,-6 ; CONVERT TO 64 WD BLOCKS
+ CAILE A,377
+ JRST OUTRNG
+ DPB A,[111100,,-1(D)] ; SMASH SPECS IN
+ AOJA C,CPOPJ
+
+; BLOAT TOP LEVEL LOCALS
+
+LOBLO: HLRE D,TP ; GET -SIZE
+ MOVNS B,D
+ ADDI D,1(TP) ; POINT TO DOPE (ALMOST)
+ CAME D,TPGROW ; BLOWN?
+ ADDI D,PDLBUF ; POINT TO REAL DOPE WORD
+ CAMG A,B ; SKIP IF GROWTH NEEDED
+ IMULI A,6 ; 6 WORDS PER BINDING
+ MOVE PVP,PVSTOR+1
+ HRRZ 0,TPBASE+1(PVP)
+ HRRZ B,SPBASE+1(PVP) ; ROOM AVAIL TO E
+ SUB B,0
+ SUBI A,(B) ; HOW MUCH MORE?
+ JUMPLE A,CPOPJ ; NONE NEEDED
+ MOVEI B,TPBINC
+ PUSHJ P,NUMADJ
+ DPB A,[1100,,-1(D)] ; SMASH
+ AOJA C,CPOPJ
+
+; GLOBAL SLOT GROWER
+
+GLBLO: ASH A,2 ; 4 WORDS PER VAR
+ MOVE D,GLOBASE+1 ; CURRENT LIMITS
+ HRRZ B,GLOBSP+1
+ SUBI B,(D)
+ SUBI A,(B) ; NEW AMOUNT NEEDED
+ JUMPLE A,CPOPJ
+ MOVEI B,GLBINC ; WHERE TO KEEP UPDATE
+ PUSHJ P,NUMADJ ; FIX NUMBER
+ HLRE 0,D
+ SUB D,0 ; POINT TO DOPE
+ DPB A,[1100,,(D)] ; AND SMASH
+ AOJA C,CPOPJ
+
+; HERE TO GROW TYPE VECTOR (AND FRIENDS)
+
+TYBLO: ASH A,1 ; TWO WORD PER TYPE
+ HRRZ B,TYPVEC+1 ; FIND CURRENT ROOM
+ MOVE D,TYPBOT+1
+ SUBI B,(D)
+ SUBI A,(B) ; EXTRA NEEDED TO A
+ JUMPLE A,CPOPJ ; NONE NEEDED, LEAVE
+ MOVEI B,TYPINC ; WHERE TO STASH SPEC
+ PUSHJ P,NUMADJ ; FIX NUMBER
+ HLRE 0,D ; POINT TO DOPE
+ SUB D,0
+ DPB A,[1100,,(D)]
+ SKIPE D,EVATYP+1 ; GROW AUX TYPE VECS IF NEEDED
+ PUSHJ P,SGROW1
+ SKIPE D,APLTYP+1
+ PUSHJ P,SGROW1
+ SKIPE D,PRNTYP+1
+ PUSHJ P,SGROW1
+ AOJA C,CPOPJ
+
+; HERE TO CREATE STORAGE SPACE
+
+STBLO: MOVE D,GCSBOT ; HOW MUCH NOW HERE
+ SUB D,CODTOP
+ SUBI A,(D) ; MORE NEEDED?
+ JUMPLE A,CPOPJ
+ MOVEM A,PARNEW ; FORCE PAIR SPACE TO MOVE ON OUT
+ AOJA C,CPOPJ
+
+; BLOAT P STACK
+
+PBLO: HLRE D,P
+ MOVNS B,D
+ SUBI D,5 ; FUDGE FOR THIS CALL
+ SUBI A,(D)
+ JUMPLE A,CPOPJ
+ ADDI B,1(P) ; POINT TO DOPE
+ CAME B,PGROW ; BLOWN?
+ ADDI B,PDLBUF ; NOPE, POIN TO REAL D.W.
+ ADDI A,63.
+ ASH A,-6 ; TO 64 WRD BLOCKS
+ CAILE A,377 ; IN RANGE?
+ JRST OUTRNG
+ DPB A,[111100,,-1(B)]
+ AOJA C,CPOPJ
+
+; SET FREMIN
+
+SFREM: SKIPE A ; DON'T ZERO EMPTY PARAMETER
+ MOVEM A,FREMIN
+ POPJ P,
+
+; SET LVAL INCREMENT
+
+SLVL: IMULI A,6 ; CALCULATE AMOUNT TO GROW B
+ MOVEI B,LVLINC
+ PUSHJ P,NUMADJ
+ MOVEM A,LVLINC
+ POPJ P,
+
+; SET GVAL INCREMENT
+
+SGVL: IMULI A,4. ; # OF SLOTS
+ MOVEI B,GVLINC
+ PUSHJ P,NUMADJ
+ MOVEM A,GVLINC
+ POPJ P,
+
+; SET TYPE INCREMENT
+
+STYP: IMULI A,2 ; CALCULATE NUMBER OF GROW BLOCKS NEEDED
+ MOVEI B,TYPIC
+ PUSHJ P,NUMADJ
+ MOVEM A,TYPIC
+ POPJ P,
+
+; SET STORAGE INCREMENT
+
+SSTO: IDIVI A,2000 ; # OF BLOCKS
+ CAIE B,0 ; REMAINDER?
+ ADDI A,1
+ IMULI A,2000 ; CONVERT BACK TO WORDS
+ MOVEM A,STORIC
+ POPJ P,
+; HERE FOR MINIMUM PURE SPACE
+
+PUMIN: ADDI A,1777
+ ANDCMI A,1777 ; TO PAGE BOUNDRY
+ MOVEM A,PURMIN
+ POPJ P,
+
+; HERE TO ADJUST PSTACK PARAMETERS IN GC
+
+PMUNG: ADDI A,777 ; TO NEAREST 1000 WORD BOUNDRY
+ ANDCMI A,777
+ MOVEM A,PGOOD ; PGOOD
+ ASH A,2 ; PMAX IS 4*PGOOD
+ MOVEM A,PMAX
+ ASH A,-4 ; PMIN IS .25*PGOOD
+ MOVEM A,PMIN
+
+; HERE TO ADJUST GC TPSTACK PARAMS
+
+TPMUNG: ADDI A,777
+ ANDCMI A,777 ; TO NEAREST 1000 WORD BOUNDRY
+ MOVEM A,TPGOOD
+ ASH A,2 ; TPMAX= 4*TPGOOD
+ MOVEM A,TPMAX
+ ASH A,-4 ; TPMIN= .25*TPGOOD
+ MOVEM A,TPMIN
+
+
+; GET NEXT (FIX) ARG
+
+NXTFIX: PUSHJ P,GETFIX
+ ADD AB,C%22
+ POPJ P,
+
+; ROUTINE TO GET POS FIXED ARG
+
+GETFIX: GETYP A,(AB)
+ CAIE A,TFIX
+ JRST WRONGT
+ SKIPGE A,1(AB)
+ JRST BADNUM
+ POPJ P,
+
+
+; GET NUMBERS FIXED UP FOR GROWTH FIELDS
+
+NUMADJ: ADDI A,77 ; ROUND UP
+ ANDCMI A,77 ; KILL CRAP
+ MOVE 0,A
+ MOVNS A ; COMPUTE ADD FACTOR FOR SPEC. POINTER UPDATE
+ HRLI A,-1(A)
+ MOVEM A,(B) ; AND STASH IT
+ MOVE A,0
+ ASH A,-6 ; TO 64 WD BLOCKS
+ CAILE A,377 ; CHECK FIT
+ JRST OUTRNG
+ POPJ P,
+
+; DO SYMPATHETIC GROWTHS
+
+SGROW1: HLRE 0,D
+ SUB D,0
+ DPB A,[111100,,(D)]
+ POPJ P,
+
+\f;FUNCTION TO CONSTRUCT A LIST
+
+MFUNCTION CONS,SUBR
+
+ ENTRY 2
+ GETYP A,2(AB) ;GET TYPE OF 2ND ARG
+ CAIE A,TLIST ;LIST?
+ JRST WTYP2 ;NO , COMPLAIN
+ MOVE C,(AB) ; GET THING TO CONS IN
+ MOVE D,1(AB)
+ HRRZ E,3(AB) ; AND LIST
+ PUSHJ P,ICONS ; INTERNAL CONS
+ JRST FINIS
+
+; COMPILER CALL TO CONS
+
+C1CONS: PUSHJ P,ICELL2
+ JRST ICONS2
+ICONS4: HRRI C,(E)
+ICONS3: MOVEM C,(B) ; AND STORE
+ MOVEM D,1(B)
+TLPOPJ: MOVSI A,TLIST
+ POPJ P,
+
+; INTERNAL CONS--ICONS; C,D VALUE, E CDR
+
+; RELATIVIZE RETURN ADDRESS HERE--MUST BE DIFFERENT FROM ICONS, SINCE
+; ICONS IS CALLED FROM INTERPRETER ENTRIES WHICH ARE THEMSELVES PUSHJ'ED
+; TO: DOING SUBM M,(P) ANYWHERE IN ICONS IS FATAL IF A GC OCCURS.
+
+CICONS: SUBM M,(P)
+ PUSHJ P,ICONS
+ JRST MPOPJ
+
+; INTERNAL CONS TO NIL--INCONS
+
+INCONS: MOVEI E,0
+
+ICONS: GETYP A,C ; CHECK TYPE OF VAL
+ PUSHJ P,NWORDT ; # OF WORDS
+ SOJN A,ICONS1 ; JUMP IF DEFERMENT NEEDED
+ PUSHJ P,ICELL2 ; NO DEFER, GET 2 WORDS FROM PAIR SPACE
+ JRST ICNS2A ; NO CORE, GO GC (SPECIAL PLACE, NOTICE)
+ JRST ICONS4
+
+; HERE IF CONSING DEFERRED
+
+ICONS1: MOVEI A,4 ; NEED 4 WORDS
+ PUSHJ P,ICELL ; GO GET 'EM
+ JRST ICNS2A ; NOT THERE, GC (SAME PLACE AS FOR ICONS)
+ HRLI E,TDEFER ; CDR AND DEFER
+ MOVEM E,(B) ; STORE
+ MOVEI E,2(B) ; POINT E TO VAL CELL
+ HRRZM E,1(B)
+ MOVEM C,(E) ; STORE VALUE
+ MOVEM D,1(E)
+ JRST TLPOPJ
+
+
+
+; HERE TO GC ON A CONS
+
+; HERE FROM C1CONS
+ICONS2: SUBM M,(P)
+ PUSHJ P,ICONSG
+ SUBM M,(P)
+ JRST C1CONS
+
+; HERE FROM ICONS (THUS CICONS, INDIRECTLY), ICONS1
+ICNS2A: PUSHJ P,ICONSG
+ JRST ICONS
+
+; REALLY DO GC
+ICONSG: PUSH TP,C ; SAVE VAL
+ PUSH TP,D
+ PUSH TP,$TLIST
+ PUSH TP,E ; SAVE VITAL STUFF
+ ADDM A,GETNUM ; AMOUNT NEEDED
+ MOVE C,[3,,1] ; INDICATOR FOR AGC
+ PUSHJ P,INQAGC ; ATTEMPT TO WIN
+ MOVE D,-2(TP) ; RESTORE VOLATILE STUFF
+ MOVE C,-3(TP)
+ MOVE E,(TP)
+ SUB TP,C%44 ; [4,,4]
+ POPJ P, ; BACK TO DRAWING BOARD
+
+; SUBROUTINE TO ALLOCATE WORDS IN PAIR SPACE. CALLS AGC IF NEEDED
+
+CELL2: MOVEI A,2 ; USUAL CASE
+CELL: PUSHJ P,ICELL ; INTERNAL
+ JRST .+2 ; LOSER
+ POPJ P,
+
+ ADDM A,GETNUM ; AMOUNT REQUIRED
+ PUSH P,A ; PREVENT AGC DESTRUCTION
+ MOVE C,[3,,1] ; INDICATOR FOR AGC
+ PUSHJ P,INQAGC
+ POP P,A
+ JRST CELL ; AND TRY AGAIN
+
+; INTERNAL CELL GETTER, SKIPS IF ROO EXISTS, ELSE DOESN'T
+
+ICELL2: MOVEI A,2 ; MOST LIKELY CAE
+ICELL: SKIPE B,RCL
+ JRST ICELRC ;SEE IF WE CAN RE-USE A RECYCLE CELL
+ MOVE B,PARTOP ; GET TOP OF PAIRS
+ ADDI B,(A) ; BUMP
+ CAMLE B,FRETOP ; SKIP IF OK.
+ JRST VECTRY ; LOSE
+ EXCH B,PARTOP ; SETUP NEW PARTOP AND RETURN POINTER
+ ADDM A,USEFRE
+ JRST CPOPJ1 ; SKIP RETURN
+
+; TRY RECYCLING USING A VECTOR FROM RCLV
+
+VECTRY: SKIPN B,RCLV ; SKIP IF VECTOR EXISTS
+ POPJ P,
+ PUSH P,C
+ PUSH P,A
+ MOVEI C,RCLV
+VECTR1: HLRZ A,(B) ; GET LENGTH
+ SUB A,(P)
+ JUMPL A,NXTVEC ; DOESN'T SATISFY TRY AGAIN
+ CAIN A,1 ; MAKE SURE NOT LEFT WITH A SINGLE SLOT
+ JRST NXTVEC
+ JUMPN A,SOML ; SOME ARE LEFT
+ HRRZ A,(B)
+ HRRM A,(C)
+ HLRZ A,(B)
+ SETZM (B)
+ SETZM -1(B) ; CLEAR DOPE WORDS
+ SUBI B,-1(A)
+ POP P,A ; CLEAR STACK
+ POP P,C
+ JRST CPOPJ1
+SOML: HRLM A,(B) ; SMASH AMOUNT LEFT
+ SUBI B,-1(A) ; GET TO BEGINNING
+ SUB B,(P)
+ POP P,A
+ POP P,C
+ JRST CPOPJ1
+NXTVEC: MOVEI C,(B)
+ HRRZ B,(B) ; GET NEXT
+ JUMPN B,VECTR1
+ POP P,A
+ POP P,C
+ POPJ P,
+
+ICELRC: CAIE A,2
+ JRST ICELL+2 ;IF HE DOESNT WANT TWO, USE OLD METHOD
+ PUSH P,A
+ MOVE A,(B)
+ HRRZM A,RCL
+ POP P,A
+ SETZM (B) ;GIVE HIM A CLEAN RECYCLED CELL
+ SETZM 1(B)
+ JRST CPOPJ1 ;THAT IT
+
+
+\f;FUNCTION TO BUILD A LIST OF MANY ELEMENTS
+
+IMFUNCTION LIST,SUBR
+ ENTRY
+
+ PUSH P,$TLIST
+LIST12: HLRE A,AB ;GET -NUM OF ARGS
+ PUSH TP,$TAB
+ PUSH TP,AB
+ MOVNS A ;MAKE IT +
+ JUMPE A,LISTN ;JUMP IF 0
+ SKIPE RCL ;SEE IF WE WANT TO DO ONE AT A TIME
+ JRST LST12R ;TO GET RECYCLED CELLS
+ PUSHJ P,CELL ;GET NUMBER OF CELLS
+ PUSH TP,(P) ;SAVE IT
+ PUSH TP,B
+ SUB P,C%11
+ LSH A,-1 ;NUMBER OF REAL LIST ELEMENTS
+
+CHAINL: ADDI B,2 ;LOOP TO CHAIN ELEMENTS
+ HRRZM B,-2(B) ;CHAIN LAST ONE TO NEXT ONE
+ SOJG A,.-2 ;LOOP TIL ALL DONE
+ CLEARM B,-2(B) ;SET THE LAST CDR TO NIL
+
+; NOW LOBEER THE DATA IN TO THE LIST
+
+ MOVE D,AB ; COPY OF ARG POINTER
+ MOVE B,(TP) ;RESTORE LIS POINTER
+LISTLP: GETYP A,(D) ;GET TYPE
+ PUSHJ P,NWORDT ;GET NUMBER OF WORDS
+ SOJN A,LDEFER ;NEED TO DEFER POINTER
+ GETYP A,(D) ;NOW CLOBBER ELEMENTS
+ HRLM A,(B)
+ MOVE A,1(D) ;AND VALUE..
+ MOVEM A,1(B)
+LISTL2: HRRZ B,(B) ;REST B
+ ADD D,C%22 ;STEP ARGS
+ JUMPL D,LISTLP
+
+ POP TP,B
+ POP TP,A
+ SUB TP,C%22 ; CLEANUP STACK
+ JRST FINIS
+
+
+LST12R: ASH A,-1 ;ONE AT A TIME TO GET RECYCLED CELLS
+ JUMPE A,LISTN
+ PUSH P,A ;SAVE COUNT ON STACK
+ SETZM E
+ SETZB C,D
+ PUSHJ P,ICONS
+ MOVE E,B ;LOOP AND CHAIN TOGETHER
+ SOSLE (P)
+ JRST .-4
+ PUSH TP,-1(P) ;PUSH ON THE TYPE WE WANT
+ PUSH TP,B
+ SUB P,C%22 ;CLEAN UP AFTER OURSELVES
+ JRST LISTLP-2 ;AND REJOIN MAIN STREAM
+
+
+; MAKE A DEFERRED POINTER
+
+LDEFER: PUSH TP,$TLIST ;SAVE CURRENT POINTER
+ PUSH TP,B
+ MOVEM D,1(TB) ; SAVE ARG HACKER
+ PUSHJ P,CELL2
+ MOVE D,1(TB)
+ GETYPF A,(D) ;GET FULL DATA
+ MOVE C,1(D)
+ MOVEM A,(B)
+ MOVEM C,1(B)
+ MOVE C,(TP) ;RESTORE LIST POINTER
+ MOVEM B,1(C) ;AND MAKE THIS BE THE VALUE
+ MOVSI A,TDEFER
+ HLLM A,(C) ;AND STORE IT
+ MOVE B,C
+ SUB TP,C%22
+ JRST LISTL2
+
+LISTN: MOVEI B,0
+ POP P,A
+ JRST FINIS
+
+; BUILD A FORM
+
+IMFUNCTION FORM,SUBR
+
+ ENTRY
+
+ PUSH P,$TFORM
+ JRST LIST12
+
+\f; COMPILERS CALLS TO FORM AND LIST A/ COUNT ELEMENTS ON STACK
+
+IILIST: SUBM M,(P)
+ PUSHJ P,IILST
+ MOVSI A,TLIST
+ JRST MPOPJ
+
+IIFORM: SUBM M,(P)
+ PUSHJ P,IILST
+ MOVSI A,TFORM
+ JRST MPOPJ
+
+IILST: JUMPE A,IILST0 ; NIL WHATSIT
+ PUSH P,A
+ MOVEI E,0
+IILST1: POP TP,D
+ POP TP,C
+ PUSHJ P,ICONS ; CONS 'EM UP
+ MOVEI E,(B)
+ SOSE (P) ; COUNT
+ JRST IILST1
+
+ SUB P,C%11
+ POPJ P,
+
+IILST0: MOVEI B,0
+ POPJ P,
+
+\f;FUNCTION TO BUILD AN IMPLICIT LIST
+
+MFUNCTION ILIST,SUBR
+ ENTRY
+ PUSH P,$TLIST
+ILIST2: JUMPGE AB,TFA ;NEED AT LEAST ONE ARG
+ CAMGE AB,C%M40 ; [-4,,0] ; NO MORE THAN TWO ARGS
+ JRST TMA
+ PUSHJ P,GETFIX ; GET POS FIX #
+ JUMPE A,LISTN ;EMPTY LIST ?
+ CAML AB,C%M20 ; [-2,,0] ;ONLY ONE ARG?
+ JRST LOSEL ;YES
+ PUSH P,A ;SAVE THE CURRENT VALUE OF LENGTH FOR LOOP ITERATION
+ILIST0: PUSH TP,2(AB)
+ PUSH TP,(AB)3
+ MCALL 1,EVAL
+ PUSH TP,A
+ PUSH TP,B
+ SOSLE (P)
+ JRST ILIST0
+ POP P,C
+ILIST1: MOVE C,(AB)+1 ;REGOBBLE LENGTH
+ ACALL C,LIST
+ILIST3: POP P,A ; GET FINAL TYPE
+ JRST FINIS
+
+
+LOSEL: PUSH P,A ; SAVE COUNT
+ MOVEI E,0
+
+LOSEL1: SETZB C,D ; TLOSE,,0
+ PUSHJ P,ICONS
+ MOVEI E,(B)
+ SOSLE (P)
+ JRST LOSEL1
+
+ SUB P,C%11
+ JRST ILIST3
+
+; IMPLICIT FORM
+
+MFUNCTION IFORM,SUBR
+
+ ENTRY
+ PUSH P,$TFORM
+ JRST ILIST2
+
+\f; IVECTOR AND IUVECTOR--GET VECTOR AND UVECTOR OF COMPUTED VALUES
+
+MFUNCTION VECTOR,SUBR,[IVECTOR]
+
+ MOVEI C,1
+ JRST VECTO3
+
+MFUNCTION UVECTOR,SUBR,[IUVECTOR]
+
+ MOVEI C,0
+VECTO3: ENTRY
+ JUMPGE AB,TFA ; AT LEAST ONE ARG
+ CAMGE AB,C%M40 ; [-4,,0] ; NOT MORE THAN 2
+ JRST TMA
+ PUSHJ P,GETFIX ; GET A POS FIXED NUMBER
+ LSH A,(C) ; A-> NUMBER OF WORDS
+ PUSH P,C ; SAVE FOR LATER
+ PUSHJ P,IBLOCK ; GET BLOCK (TURN ON BIT APPROPRIATELY)
+ POP P,C
+ HLRE A,B ; START TO
+ SUBM B,A ; FIND DOPE WORD
+ MOVSI D,.VECT. ; FOR GCHACK
+ IORM D,(A)
+ JUMPE C,VECTO4
+ MOVSI D,400000 ; GET NOT UNIFORM BIT
+ IORM D,(A) ; INTO DOPE WORD
+ SKIPA A,$TVEC ; GET TYPE
+VECTO4: MOVSI A,TUVEC
+ CAML AB,C%M20 ; [-2,,0] ; SKIP IF ARGS NEED TO BE HACKED
+ JRST FINIS
+ JUMPGE B,FINIS ; DON'T EVAL FOR EMPTY CASE
+
+ PUSH TP,A ; SAVE THE VECTOR
+ PUSH TP,B
+ PUSH TP,A
+ PUSH TP,B
+
+ JUMPE C,UINIT
+ JUMPGE B,FINIS ; EMPTY VECTOR, LEAVE
+INLP: PUSHJ P,IEVAL ; EVAL EXPR
+ MOVEM A,(C)
+ MOVEM B,1(C)
+ ADD C,C%22 ; BUMP VECTOR
+ MOVEM C,(TP)
+ JUMPL C,INLP ; IF MORE DO IT
+
+GETVEC: MOVE A,-3(TP)
+ MOVE B,-2(TP)
+ SUB TP,C%44 ; [4,,4]
+ JRST FINIS
+
+; HERE TO FILL UP A UVECTOR
+
+UINIT: PUSHJ P,IEVAL ; HACK THE 1ST VALUE
+ GETYP A,A ; GET TYPE
+ PUSH P,A ; SAVE TYPE
+ PUSHJ P,NWORDT ; SEE IF IT CAN BE UNIFORMED
+ SOJN A,CANTUN ; COMPLAIN
+STJOIN: MOVE C,(TP) ; RESTORE POINTER
+ ADD C,1(AB) ; POINT TO DOPE WORD
+ MOVE A,(P) ; GET TYPE
+ HRLZM A,(C) ; STORE IN D.W.
+ MOVSI D,.VECT. ; FOR GCHACK
+ IORM D,(C)
+ MOVE C,(TP) ; GET BACK VECTOR
+ SKIPE 1(AB)
+ JRST UINLP1 ; START FILLING UV
+ JRST GETVE1
+
+UINLP: MOVEM C,(TP) ; SAVE PNTR
+ PUSHJ P,IEVAL ; EVAL THE EXPR
+ GETYP A,A ; GET EVALED TYPE
+ CAIE A,@(P) ; WINNER?
+ JRST WRNGSU ; SERVICE ERROR FOR UVECTOR,STORAGE
+UINLP1: MOVEM B,(C) ; STORE
+ AOBJN C,UINLP
+GETVE1: SUB P,C%11
+ JRST GETVEC ; AND RETURN VECTOR
+
+IEVAL: PUSH TP,2(AB)
+ PUSH TP,3(AB)
+ MCALL 1,EVAL
+ MOVE C,(TP)
+ POPJ P,
+
+; ISTORAGE -- GET STORAGE OF COMPUTED VALUES
+
+MFUNCTION ISTORAGE,SUBR
+ ENTRY
+ JUMPGE AB,TFA
+ CAMGE AB,C%M40 ; [-4,,0] ; AT LEAST ONE ARG
+ JRST TMA
+ PUSHJ P,GETFIX ; POSITIVE COUNT FIRST ARG
+ PUSHJ P,CAFRE ; GET CORE
+ MOVN B,1(AB) ; -COUNT
+ HRL A,B ; PUT IN LHW (A)
+ MOVM B,B ; +COUNT
+ HRLI B,2(B) ; LENGTH + 2
+ ADDI B,(A) ; MAKE POINTER TO DOPE WORDS
+ HLLZM B,1(B) ; PUT TOTAL LENGTH IN 2ND DOPE
+ HRRM A,1(B) ; PUT ADDRESS IN RHW (STORE DOES THIS TOO).
+ MOVE B,A
+ MOVSI A,TSTORAGE
+ CAML AB,C%M20 ; [-2,,0] ; SECOND ARG TO EVAL?
+ JRST FINIS ; IF NOT, RETURN EMPTY
+ PUSH TP,A
+ PUSH TP,B
+ PUSH TP,A
+ PUSH TP,B
+ PUSHJ P,IEVAL ; EVALUATE FOR FIRST VALUE
+ GETYP A,A
+ PUSH P,A ; FOR COMPARISON LATER
+ PUSHJ P,SAT
+ CAIN A,S1WORD
+ JRST STJOIN ;TREAT LIKE A UVECTOR
+; IF NOT 1-WORD TYPES, CANNOT STORE, SO COMPLAIN
+ PUSHJ P,FREESV ; FREE STORAGE VECTOR
+ ERRUUO EQUOTE DATA-CANT-GO-IN-STORAGE
+
+; FOR STORAGE, MUST FREE THE CORE ELSE IT IS LOST (NO GC)
+FREESV: MOVE A,1(AB) ; GET COUNT
+ ADDI A,2 ; FOR DOPE
+ HRRZ B,(TP) ; GET ADDRESS
+ PUSHJ P,CAFRET ; FREE THE CORE
+ POPJ P,
+
+\f
+; INTERNAL VECTOR ALLOCATOR. A/SIZE OF VECTOR (NOT INCLUDING DOPE WORDS)
+
+IBLOK1: ASH A,1 ; TIMES 2
+GIBLOK: TLOA A,400000 ; FUNNY BIT
+IBLOCK: TLZ A,400000 ; NO BIT ON
+ TLO A,.VECT. ; TURN ON BIT FOR GCHACK
+ ADDI A,2 ; COMPENSATE FOR DOPE WORDS
+IBLOK2: SKIPE B,RCLV ; ANY TO RECYCLE?
+ JRST RCLVEC
+NORCL: MOVE B,GCSTOP ; POINT TO BOTTOM OF SPACE
+ PUSH P,B ; SAVE TO BUILD PTR
+ ADDI B,(A) ; ADD NEEDED AMOUNT
+ CAML B,FRETOP ; SKIP IF NO GC NEEDED
+ JRST IVECT1
+ MOVEM B,GCSTOP ; WIN, GET POINTER TO BLOCK AND UPDATE VECBOT
+ ADDM A,USEFRE
+ HRRZS USEFRE
+ HRLZM A,-1(B) ; STORE LENGTH IN DOPE WORD
+ HLLZM A,-2(B) ; AND BIT
+ HRRM B,-1(B) ; SMASH IN RELOCATION
+ SOS -1(B)
+ POP P,B ; RESTORE PTR TO BOTTOM OF VECTOR
+ HRROS B ; POINT TO START OF VECTOR
+ TLC B,-3(A) ; SETUP COUNT
+ HRRI A,TVEC
+ SKIPL A
+ HRRI A,TUVEC
+ MOVSI A,(A)
+ POPJ P,
+
+; HERE TO DO A GC ON A VECTOR ALLOCATION
+
+IVECT1: PUSH P,0
+ PUSH P,A ; SAVE DESIRED LENGTH
+ HRRZ 0,A
+ ADDM 0,GETNUM ; AND STORE AS DESIRED AMOUNT
+ MOVE C,[4,,1] ; GET INDICATOR FOR AGC
+ PUSHJ P,INQAGC
+ POP P,A
+ POP P,0
+ POP P,B
+ JRST IBLOK2
+
+
+; INTERNAL EVECTOR (CALLED FROM READ) A/ #OF THINGS
+; ITEMS ON TOP OF STACK
+
+IEVECT: ASH A,1 ; TO NUMBER OF WORDS
+ PUSH P,A
+ PUSHJ P,IBLOCK ; GET VECTOR
+ HLRE D,B ; FIND DW
+ SUBM B,D ; A POINTS TO DW
+ MOVSI 0,400000+.VECT.
+ MOVEM 0,(D) ; CLOBBER NON UNIF BIT
+ POP P,A ; RESTORE COUNT
+ JUMPE A,IVEC1 ; 0 LNTH, DONE
+ MOVEI C,(TP) ; BUILD BLT
+ SUBI C,(A)-1 ; C POINTS TO 1ST ITEM ON STACK
+ MOVSI C,(C)
+ HRRI C,(B) ; B/ SOURCE,,DEST
+ BLT C,-1(D) ; XFER THE DATA
+ HRLI A,(A)
+ SUB TP,A ; FLUSH STACKAGE
+IVEC1: MOVSI A,TVEC
+ POPJ P,
+
+
+; COMPILERS CALL
+
+CIVEC: SUBM M,(P)
+ PUSHJ P,IEVECT
+ JRST MPOPJ
+
+
+\f; INTERNAL CALL TO EUVECTOR
+
+IEUVEC: PUSH P,A ; SAVE LENGTH
+ PUSHJ P,IBLOCK
+ MOVE A,(P)
+ JUMPE A,IEUVE1 ; EMPTY, LEAVE
+ ASH A,1 ; NOW FIND STACK POSITION
+ MOVEI C,(TP) ; POINT TO TOP
+ MOVE D,B ; COPY VEC POINTER
+ SUBI C,-1(A) ; POINT TO 1ST DATUM
+ GETYP A,(C) ; CHECK IT
+ PUSHJ P,NWORDT
+ SOJN A,CANTUN ; WONT FIT
+ GETYP E,(C)
+
+IEUVE2: GETYP 0,(C) ; TYPE OF EL
+ CAIE 0,(E) ; MATCH?
+ JRST WRNGUT
+ MOVE 0,1(C)
+ MOVEM 0,(D) ; CLOBBER
+ ADDI C,2
+ AOBJN D,IEUVE2 ; LOOP
+ TRO E,.VECT.
+ HRLZM E,(D) ; STORE UTYPE
+IEUVE1: POP P,A ; GET COUNY
+ ASH A,1 ; MUST FLUSH 2 TIMES # OF ELEMENTS
+ HRLI A,(A)
+ SUB TP,A ; CLEAN UP STACK
+ MOVSI A,TUVEC
+ POPJ P,
+
+; COMPILER'S CALL
+
+CIUVEC: SUBM M,(P)
+ PUSHJ P,IEUVEC
+ JRST MPOPJ
+
+IMFUNCTION EVECTOR,SUBR,[VECTOR]
+ ENTRY
+ HLRE A,AB
+ MOVNS A
+ PUSH P,A ;SAVE NUMBER OF WORDS
+ PUSHJ P,IBLOCK ; GET WORDS
+ MOVEI D,-1(B) ; SETUP FOR BLT AND DOPE CLOBBER
+ JUMPGE B,FINISV ;DONT COPY A ZERO LENGTH VECTOR
+
+ HRLI C,(AB) ;START BUILDING BLT POINTER
+ HRRI C,(B) ;TO ADDRESS
+ ADDI D,@(P) ;SET D TO FINAL ADDRESS
+ BLT C,(D)
+FINISV: MOVSI 0,400000+.VECT.
+ MOVEM 0,1(D) ; MARK AS GENERAL
+ SUB P,C%11
+ MOVSI A,TVEC
+ JRST FINIS
+
+
+
+\f;EXPLICIT VECTORS FOR THE UNIFORM CSE
+
+IMFUNCTION EUVECTOR,SUBR,[UVECTOR]
+
+ ENTRY
+ HLRE A,AB ;-NUM OF ARGS
+ MOVNS A
+ ASH A,-1 ;NEED HALF AS MANY WORDS
+ PUSH P,A
+ JUMPGE AB,EUV1 ; DONT CHECK FOR EMPTY
+ GETYP A,(AB) ;GET FIRST ARG
+ PUSHJ P,NWORDT ;SEE IF NEEDS EXTRA WORDS
+ SOJN A,CANTUN
+EUV1: POP P,A
+ PUSHJ P,IBLOCK ; GET VECT
+ JUMPGE B,FINISU
+
+ GETYP C,(AB) ;GET THE FIRST TYPE
+ MOVE D,AB ;COPY THE ARG POINTER
+ MOVE E,B ;COPY OF RESULT
+
+EUVLP: GETYP 0,(D) ;GET A TYPE
+ CAIE 0,(C) ;SAME?
+ JRST WRNGUT ;NO , LOSE
+ MOVE 0,1(D) ;GET GOODIE
+ MOVEM 0,(E) ;CLOBBER
+ ADD D,C%22 ;BUMP ARGS POINTER
+ AOBJN E,EUVLP
+
+ TRO C,.VECT.
+ HRLM C,(E) ;CLOBBER UNIFORM TYPE IN
+FINISU: MOVSI A,TUVEC
+ JRST FINIS
+
+WRNGSU: GETYP A,-1(TP)
+ CAIE A,TSTORAGE
+ JRST WRNGUT ;IF UVECTOR
+ PUSHJ P,FREESV ;FREE STORAGE VECTOR
+ ERRUUO EQUOTE TYPES-DIFFER-IN-STORAGE-OBJECT
+
+WRNGUT: ERRUUO EQUOTE TYPES-DIFFER-IN-UNIFORM-VECTOR
+
+CANTUN: ERRUUO EQUOTE DATA-CANT-GO-IN-UNIFORM-VECTOR
+
+BADNUM: ERRUUO EQUOTE NEGATIVE-ARGUMENT
+\f; FUNCTION TO GROW A VECTOR
+REPEAT 0,[
+MFUNCTION GROW,SUBR
+
+ ENTRY 3
+
+ MOVEI D,0 ;STACK HACKING FLAG
+ GETYP A,(AB) ;FIRST TYPE
+ PUSHJ P,SAT ;GET STORAGE TYPE
+ GETYP B,2(AB) ;2ND ARG
+ CAIE A,STPSTK ;IS IT ASTACK
+ CAIN A,SPSTK
+ AOJA D,GRSTCK ;YES, WIN
+ CAIE A,SNWORD ;UNIFORM VECTOR
+ CAIN A,S2NWORD ;OR GENERAL
+GRSTCK: CAIE B,TFIX ;IS 2ND FIXED
+ JRST WTYP2 ;COMPLAIN
+ GETYP B,4(AB)
+ CAIE B,TFIX ;3RD ARG
+ JRST WTYP3 ;LOSE
+
+ MOVEI E,1 ;UNIFORM/GENERAL FLAG
+ CAIE A,SNWORD ;SKIP IF UNIFORM
+ CAIN A,SPSTK ;DONT SKIP IF UNIFORM PDL
+ MOVEI E,0
+
+ HRRZ B,1(AB) ;POINT TO START
+ HLRE A,1(AB) ;GET -LENGTH
+ SUB B,A ;POINT TO DOPE WORD
+ SKIPE D ;SKIP IF NOT STACK
+ ADDI B,PDLBUF ;FUDGE FOR PDL
+ HLLZS (B) ;ZERO OUT GROWTH SPECS
+ SKIPN A,3(AB) ;ANY TOP GROWTH?
+ JRST GROW1 ;NO, LOOK FOR BOTTOM GROWTH
+ ASH A,(E) ;MULT BY 2 IF GENERAL
+ ADDI A,77 ;ROUND TO NEAREST BLOCK
+ ANDCMI A,77 ;CLEAR LOW ORDER BITS
+ ASH A,9-6 ;DIVIDE BY 100 AND SHIFT TO POSTION
+ TRZE A,400000 ;CONVERT TO SIGN MAGNITUDE
+ MOVNS A
+ TLNE A,-1 ;SKIP IF NOT TOO BIG
+ JRST GTOBIG ;ERROR
+GROW1: SKIPN C,5(AB) ;CHECK LOW GROWTH
+ JRST GROW4 ;NONE, SKIP
+ ASH C,(E) ;GENRAL FUDGE
+ ADDI C,77 ;ROUND
+ ANDCMI C,77 ;FUDGE FOR VALUE RETURN
+ PUSH P,C ;AND SAVE
+ ASH C,-6 ;DIVIDE BY 100
+ TRZE C,400 ;CONVERT TO SIGN MAGNITUDE
+ MOVNS C
+ TDNE C,[-1,,777000] ;CHECK FOR OVERFLOW
+ JRST GTOBIG
+GROW2: HLRZ E,1(B) ;GET TOTAL LENGTH OF VECTOR
+ MOVNI E,-1(E)
+ HRLI E,(E) ;TO BOTH HALVES
+ ADDI E,1(B) ;POINTS TO TOP
+ SKIPE D ;STACK?
+ ADD E,[PDLBUF,,0] ;YES, FUDGE LENGTH
+ SKIPL D,(P) ;SHRINKAGE?
+ JRST GROW3 ;NO, CONTINUE
+ MOVNS D ;PLUSIFY
+ HRLI D,(D) ;TO BOTH HALVES
+ ADD E,D ;POINT TO NEW LOW ADDR
+GROW3: IORI A,(C) ;OR TOGETHER
+ HRRM A,(B) ;DEPOSIT INTO DOPEWORD
+ PUSH TP,(AB) ;PUSH TYPE
+ PUSH TP,E ;AND VALUE
+ SKIPE A ;DON'T GC FOR NOTHING
+ MOVE C,[2,,0] ; GET INDICATOR FOR AGC
+ PUSHJ P,AGC
+ JUMPL A,GROFUL
+ POP P,C ;RESTORE GROWTH
+ HRLI C,(C)
+ POP TP,B ;GET VECTOR POINTER
+ SUB B,C ;POINT TO NEW TOP
+ POP TP,A
+ JRST FINIS
+
+GROFUL: SUB P,C%11 ; CLEAN UP STACK
+ SUB TP,C%22
+ PUSHJ P,FULLOS
+ JRST GROW
+
+GTOBIG: ERRUUO EQUOTE ATTEMPT-TO-GROW-VECTOR-TOO-MUCH
+GROW4: PUSH P,[0] ;0 BOTTOM GROWTH
+ JRST GROW2
+]
+FULLOS: ERRUUO EQUOTE NO-STORAGE
+
+
+\f; SUBROUTINE TO BUILD CHARACTER STRING GOODIES
+
+MFUNCTION BYTES,SUBR
+
+ ENTRY
+ MOVEI D,1
+ JUMPGE AB,TFA
+ GETYP 0,(AB)
+ CAIE 0,TFIX
+ JRST WTYP1
+ MOVE E,1(AB)
+ ADD AB,C%22
+ JRST STRNG1
+
+IMFUNCTION STRING,SUBR
+
+ ENTRY
+
+ MOVEI D,0
+ MOVEI E,7
+STRNG1: MOVE B,AB ;COPY ARG POINTER
+ MOVEI C,0 ;INITIALIZE COUNTER
+ PUSH TP,$TAB ;SAVE A COPY
+ PUSH TP,B
+ HLRE A,B ; GET # OF ARGS
+ MOVNS A
+ ASH A,-1 ; 1/2 FOR # OF ARGS
+ PUSHJ P,IISTRN
+ JRST FINIS
+
+IISTRN: PUSH P,E
+ JUMPL E,OUTRNG
+ CAILE E,36.
+ JRST OUTRNG
+ SKIPN E,A ; SKIP IF ARGS EXIST
+ JRST MAKSTR ; ALL DONE
+
+STRIN2: GETYP 0,(B) ;GET TYPE CODE
+ CAMN 0,SING(D) ; SINGLE CHARACTER OR FIX?
+ AOJA C,STRIN1
+ CAME 0,MULTI(D) ; OR STRING OR BYTE-STRING
+ JRST WRONGT ;NEITHER
+ HRRZ 0,(B) ; GET CHAR COUNT
+ ADD C,0 ; AND BUMP
+
+STRIN1: ADD B,C%22
+ SOJG A,STRIN2
+
+; NOW GET THE NECESSARY VECTOR
+
+MAKSTR: HRL C,MULTI(D) ; FINAL TYPE,, CHAR COUNT
+ PUSH P,C ; SAVE CHAR COUNT
+ PUSH P,E ; SAVE ARG COUNT
+ MOVEI D,36.
+ IDIV D,-2(P) ; A==> BYTES PER WORD
+ MOVEI A,(C) ; LNTH+4 TO A
+ ADDI A,-1(D)
+ IDIVI A,(D)
+ LSH E,12.
+ MOVE D,-2(P)
+ DPB D,[060600,,E]
+ HRLM E,-2(P) ; SAVE REMAINDER
+ PUSHJ P,IBLOCK
+
+ POP P,A
+ JUMPGE B,DONEC ; 0 LENGTH, NO STRING
+ HRLI B,440000 ;CONVERT B TO A BYTE POINTER
+ HRRZ 0,-1(P) ; BYTE SIZE
+ DPB 0,[300600,,B]
+ MOVE C,(TP) ; POINT TO ARGS AGAIN
+
+NXTRG1: GETYP D,(C) ;GET AN ARG
+ CAIN D,TFIX
+ JRST .+3
+ CAIE D,TCHRS
+ JRST TRYSTR
+ MOVE D,1(C) ; GET IT
+ IDPB D,B ;AND DEPOSIT IT
+ JRST NXTARG
+
+TRYSTR: MOVE E,1(C) ;GET BYTER
+ HRRZ 0,(C) ;AND COUNT
+NXTCHR: SOJL 0,NXTARG ; IF RUNOUT, GET NEXT ARG
+ ILDB D,E ;AND GET NEXT
+ IDPB D,B ; AND DEPOSIT SAME
+ JRST NXTCHR
+
+NXTARG: ADD C,C%22 ;BUMP ARG POINTER
+ SOJG A,NXTRG1
+ ADDI B,1
+
+DONEC: MOVSI C,TCHRS+.VECT.
+ TLO B,400000
+ HLLM C,(B) ;AND CLOBBER AWAY
+ HLRZ C,1(B) ;GET LENGTH BACK
+ POP P,A
+ SUBI B,-1(C)
+ HLL B,(P) ;MAKE A BYTE POINTER
+ SUB P,C%11
+ POPJ P,
+
+SING: TCHRS
+ TFIX
+
+MULTI: TCHSTR
+ TBYTE
+
+
+; COMPILER'S CALL TO MAKE A STRING
+
+CISTNG: TDZA D,D
+
+; COMPILERS CALL TO MAKE A BYTE STRING
+
+CBYTES: MOVEI D,1
+ SUBM M,(P)
+ MOVEI C,0 ; INIT CHAR COUNTER
+ MOVEI B,(A) ; SET UP STACK POINTER
+ ASH B,1 ; * 2 FOR NO. OF SLOTS
+ HRLI B,(B)
+ SUBM TP,B ; B POINTS TO ARGS
+ PUSH P,D
+ MOVEI E,7
+ JUMPE D,CBYST
+ GETYP 0,1(B) ; CHECK BYTE SIZE
+ CAIE 0,TFIX
+ JRST WRONGT
+ MOVE E,2(B)
+ ADD B,C%22
+ SUBI A,1
+CBYST: ADD B,C%11
+ PUSH TP,$TTP
+ PUSH TP,B
+ PUSHJ P,IISTRN ; MAKE IT HAPPEN
+ MOVE TP,(TP) ; FLUSH ARGS
+ SUB TP,C%11
+ POP P,D
+ JUMPE D,MPOPJ
+ SUB TP,C%22
+ JRST MPOPJ
+
+\f;BUILD IMPLICT STRING
+
+MFUNCTION IBYTES,SUBR
+
+ ENTRY
+
+ CAML AB,C%M20 ; [-3,,] ; AT LEAST 2
+ JRST TFA
+ CAMGE AB,C%M60 ; [-7,,] ; NO MORE THAN 3
+ JRST TMA
+ PUSHJ P,GETFIX ; GET BYTE SIZE
+ JUMPL A,OUTRNG
+ CAILE A,36.
+ JRST OUTRNG
+ PUSH P,[TFIX]
+ PUSH P,A
+ PUSH P,$TBYTE
+ ADD AB,C%22
+ MOVEM AB,ABSAV(TB)
+ JRST ISTR1
+
+MFUNCTION ISTRING,SUBR
+
+ ENTRY
+ JUMPGE AB,TFA ; TOO FEW ARGS
+ CAMGE AB,C%M40 ; [-4,,0] ; VERIFY NOT TOO MANY ARGS
+ JRST TMA
+ PUSH P,[TCHRS]
+ PUSH P,[7]
+ PUSH P,$TCHSTR
+ISTR1: PUSHJ P,GETFIX
+ MOVEI C,36.
+ IDIV C,-1(P)
+ ADDI A,-1(C)
+ IDIVI A,(C) ; # OF WORDS NEEDED TO A
+ ASH D,12.
+ MOVE C,-1(P) ; GET BYTE SIZE
+ DPB C,[060600,,D]
+ PUSH P,D
+ PUSHJ P,IBLOCK
+ HLRE C,B ; -LENGTH TO C
+ SUBM B,C ; LOCN OF DOPE WORD TO C
+ HRLI D,TCHRS+.VECT. ; CLOBBER ITS TYPE
+ HLLM D,(C)
+ MOVE A,-1(P)
+ HRR A,1(AB) ; SETUP TYPE'S RH
+ SUBI B,1
+ HRL B,(P) ; AND BYTE POINTER
+ SUB P,C%33
+ SKIPE (AB)+1 ; SKIP IF NO CHARACTERS TO DEPOSIT
+ CAML AB,C%M20 ; [-2,,0] ; SKIP IF 2 ARGS GIVEN
+ JRST FINIS
+ PUSH TP,A ;SAVE OUR STRING
+ PUSH TP,B
+ PUSH TP,A ;SAVE A TEMPORARY CLOBBER POINTER
+ PUSH TP,B
+ PUSH P,(AB)1 ;SAVE COUNT
+ PUSH TP,(AB)+2
+ PUSH TP,(AB)+3
+CLOBST: PUSH TP,-1(TP)
+ PUSH TP,-1(TP)
+ MCALL 1,EVAL
+ GETYP C,A ; CHECK IT
+ CAME C,-1(P) ; MUST BE A CHARACTER
+ JRST WTYP2
+ IDPB B,-2(TP) ;CLOBBER
+ SOSLE (P) ;FINISHED?
+ JRST CLOBST ;NO
+ SUB P,C%22
+ SUB TP,C%66
+ MOVE A,(TP)+1
+ MOVE B,(TP)+2
+ JRST FINIS
+
+\f
+; HERE TO CHECK TO SEE WHETHER PURE RSUBR'S ARE MAPPED BELOW FRETOP AND
+; PUNT SOME IF THERE ARE.
+
+INQAGC: PUSH P,C
+ PUSH P,B
+ PUSH P,A
+ PUSH P,E
+ PUSHJ P,SQKIL
+ JSP E,CKPUR ; CHECK FOR PURE RSUBR
+ POP P,E
+ MOVE A,PURTOP
+ SUB A,CURPLN
+ MOVE B,RFRETP ; GET REAL FRETOP
+ CAIL B,(A)
+ MOVE B,A ; TOP OF WORLD
+ MOVE A,GCSTOP
+ ADD A,GETNUM
+ ADDI A,1777 ; PAGE BOUNDARY
+ ANDCMI A,1777
+ CAIL A,(B) ; SEE WHETHER THERE IS ROOM
+ JRST GOTOGC
+ PUSHJ P,CLEANT
+ POP P,A
+ POP P,B
+ POP P,C
+ POPJ P,
+GOTOGC: POP P,A
+ POP P,B
+ POP P,C ; RESTORE CAUSE INDICATOR
+ MOVE A,P.TOP
+ PUSHJ P,CLEANT ; CLEAN UP
+ SKIPL PLODR ; IF IN PLOAD DON'T INTERRUPT
+ JRST INTAGC ; GO CAUSE GARBAGE COLLECT
+ JRST SAGC
+
+CLEANT: PUSH P,C
+ PUSH P,A
+ SUB A,P.TOP
+ ASH A,-PGSZ
+ JUMPE A,CLNT1
+ PUSHJ P,GETPAG ; GET THOSE PAGES
+ FATAL CAN'T GET PAGES NEEDED
+ MOVE A,(P)
+ ASH A,-10. ; TO PAGES
+ PUSHJ P,P.CORE
+ PUSHJ P,SLEEPR
+CLNT1: PUSHJ P,RBLDM
+ POP P,A
+ POP P,C
+ POPJ P,
+
+\f; RCLVEC DISTASTEFUL VECTOR RECYCLER
+
+; Arrive here with B pointing to first recycler, A desired length
+
+RCLVEC: PUSH P,D ; Save registers
+ PUSH P,C
+ PUSH P,E
+ MOVEI D,RCLV ; Point to previous recycle for splice
+RCLV1: HLRZ C,(B) ; Get size of this block
+ CAIL C,(A) ; Skip if too small
+ JRST FOUND1
+
+RCLV2: MOVEI D,(B) ; Save previous pointer
+ HRRZ B,(B) ; Point to next block
+ JUMPN B,RCLV1 ; Jump if more blocks
+
+ POP P,E
+ POP P,C
+ POP P,D
+ JRST NORCL ; Go to normal allocator
+
+
+FOUND1: CAIN C,1(A) ; Exactly 1 greater?
+ JRST RCLV2 ; Cant use this guy
+
+ HRLM A,(B) ; Smash in new count
+ TLO A,.VECT. ; make vector bit be on
+ HLLM A,-1(B)
+ CAIE C,(A) ; Exactly right length?
+ JRST FOUND2 ; No, do hair
+
+ HRRZ C,(B) ; Point to next block
+ HRRM C,(D) ; Smash previous pointer
+ HRRM B,(B)
+ SUBI B,-1(A) ; Point to top of block
+ JRST FOUND3
+
+FOUND2: SUBI C,(A) ; Amount of left over to C
+ HRRZ E,(B) ; Point to next block
+ HRRM B,(B)
+ SUBI B,(A) ; Point to dope words of guy to put back
+ MOVSM C,(B) ; Smash in count
+ MOVSI C,.VECT. ; Get vector bit
+ MOVEM C,-1(B) ; Make sure it is a vector
+ HRRM B,(D) ; Splice him in
+ HRRM E,(B) ; And the next guy also
+ ADDI B,1 ; Point to start of vector
+
+FOUND3: HRROI B,(B) ; Make an AOBJN pointer
+ TLC B,-3(A)
+ HRRI A,TVEC
+ SKIPGE A
+ HRRI A,TUVEC
+ MOVSI A,(A)
+ POP P,E
+ POP P,C
+ POP P,D
+ POPJ P,
+
+END
+\f
\ No newline at end of file
--- /dev/null
+
+ TITLE STRBUILD MUDDLE STRUCTURE BUILDER
+
+.GLOBAL RCL,VECTOP,GCSTOP,GCSBOT,FRETOP,GCSNEW,VECBOT,PARTOP,PARBOT,HITOP,HIBOT,GETPAG
+.GLOBAL PDLBUF,PDLEX,PDLEXP,GCFLG,GCPDL,GETNUM,PARNEW,MOVPUR,RCLV,RCLVEC
+.GLOBAL PGROW,TPGROW,MAINPR,%SLEEP,MSGTYP,PURTOP,PURBOT,STOSTR,RBLDM,CPOPJ,CPOPJ1,STBL
+.GLOBAL MTYI,UPLO,FRMUNG,BYTDOP,GLOBSP,FREDIF,FREMIN,GCHAPN,INTFLG,PINIT,CKPUR,GCSET
+.GLOBAL SAT,TTOCHN,TYPVEC,ICONS,INCONS,IBLOCK,IEUVEC,IEVECTI,CELL2,MKTBS,CPOPJ1,.LIST.
+.GLOBAL GIBLOK,REHASH,IBLOK1,IILIST,IIFORM,CIVEC,CIUVEC,CICONS,SLEEPR,GCHK10,FPAG
+.GLOBAL SPBASE,OUTRNG,CISTNG,CBYTES,%RUNAM,PURVEC,GCDOWN,N.CHNS,CHNL1,PLODR,C1CONS
+.GLOBAL CAFRE,CAFRET,STOGC,GCHN,WNDP,FRNP,FRONT,%GCJOB,%SHWND,%INFMP,%GETIP
+.GLOBAL TD.PUT,TD.GET,TD.LNT,GLOTOP,UBIT,FLGSET,PURMNG,RPURBT,%IFMP2,CHKPGI,PURCLN
+.GLOBAL CTIME,MTYO,ILOC,NODES,GPURFL,GCDANG,GCHACK,LPUR,HITOP,BADCHN,IMPURX
+.GLOBAL NOWLVL,CURPLN,PVSTOR,SPSTOR,MPOPJ,NGCS,RNUMSP,NUMSWP,SAGC,INQAGC
+.GLOBAL GCTIM,GCCAUS,GCCALL,AAGC,LVLINC,STORIC,GVLINC,TYPIC,GCRSET,ACCESS,NOSHUF,SQUPNT
+; GLOBALS ASSOCIATE WITH THE ASSOCIATION VECTOR
+
+.GLOBAL ASOVEC,ASOLNT,ITEM,INDIC,VAL,NWORDT,NODPNT,PNTRS
+.GLOBAL CELL,BINDID,GCFLCH,TYPBOT,GLOBAS,TPBASE
+.GLOBAL TPBINC,GBLINC,TYPINC,CONADJ,OGCSTP,ABOTN
+.GLOBAL AGC,ROOT,CIGTPR,IIGLOC
+.GLOBAL P.TOP,P.CORE,PMAPB
+.GLOBAL %MPINT,%GBINT,%CLSMP,%CLSM1
+.GLOBAL GCKNUM,CORTOP,GCHPN,INTAGC,WNDP,WNDBOT,BUFGC,WIND,GCDFLG,SAVM
+
+; SHARED SYMBOLS WITH GC MODULE
+
+.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,PMIN,PURMIN
+.GLOBAL GLBINC,GCHAIR,GCMONF,SQKIL,INBLOT
+.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
+
+NOPAGS==1 ; NUMBER OF WINDOWS
+EOFBIT==1000
+PDLBUF=100
+
+.ATOM.==200000 ; FLAG SAYING ATOMS MARKED (FOR VAL FLUSH LOGIC)
+
+GCHN==0 ; CHANNEL FOR FUNNNY INFERIOR
+STATNO==19. ; # OF STATISTICS FOR BLOAT-STAT
+STATGC==8. ; # OF GC-STATISTICS FOR BLOAT-STAT
+
+
+RELOCATABLE
+.INSRT MUDDLE >
+SYSQ
+IFE ITS,[
+.INSRT STENEX >
+]
+IFN ITS, PGSZ==10.
+IFE ITS, PGSZ==9.
+
+
+\f; GC-READ TAKES ONE ARGUMENT WHICH MUST BE A "READB" CHANNEL
+
+.GLOBAL CLOOKU,CINSER,MOBLIST,CATOM,EOFCND,IGLOC
+
+MFUNCTION GCREAD,SUBR,[GC-READ]
+
+ ENTRY
+
+ CAML AB,C%M2 ; CHECK # OF ARGS
+ JRST TFA
+ CAMGE AB,C%M40
+ JRST TMA
+
+ GETYP A,(AB) ; MAKE SURE ARG IS A CHANNEL
+ CAIE A,TCHAN
+ JRST WTYP2 ; IT ISN'T COMPLAIN
+ MOVE B,1(AB) ; GET PTR TO CHANNEL
+ HRRZ C,-2(B) ; LOOK AT BITS IN CHANNEL
+ TRC C,C.OPN+C.READ+C.BIN
+ TRNE C,C.OPN+C.READ+C.BIN
+ JRST BADCHN
+
+ PUSH P,1(B) ; SAVE ITS CHANNEL #
+IFN ITS,[
+ MOVE B,[-2,,C] ; SET UP AOBJN PTR TO READ IN DELIMITING
+ ; CONSTANTS
+ MOVE A,(P) ; GET CHANNEL #
+ DOTCAL IOT,[A,B]
+ FATAL GCREAD-- IOT FAILED
+ JUMPL B,EOFGC ; IF BLOCK DIDN'T FINISH THEN EOF
+]
+IFE ITS,[
+ MOVE A,(P) ; GET CHANNEL
+ BIN
+ MOVE C,B ; TO C
+ BIN
+ MOVE D,B ; TO D
+ GTSTS ; SEE IF EOF
+ TLNE B,EOFBIT
+ JRST EOFGC
+]
+
+ PUSH P,C ; SAVE AC'S
+ PUSH P,D
+
+IFN ITS,[
+ MOVE B,[-3,,C] ; NEXT GROUP OF WORDS
+ DOTCAL IOT,[A,B]
+ FATAL GCREAD--GC IOT FAILED
+]
+IFE ITS,[
+ MOVE A,-2(P) ; GET CHANNEL
+ BIN
+ MOVE C,B
+ BIN
+ MOVE D,B
+ BIN
+ MOVE E,B
+]
+ MOVEI 0,0 ; DO PRELIMINARY TESTS
+ IOR 0,A ; IOR ALL WORDS IN
+ IOR 0,B
+ IOR 0,C
+ IOR 0,(P)
+ IOR 0,-1(P)
+ TLNE 0,-1 ; SKIP IF NO BITS IN LEFT HALF
+ JRST ERDGC
+
+ MOVEM D,NNPRI
+ MOVEM E,NNSAT
+ MOVE D,C ; GET START OF NEWTYPE TABLE
+ SUB D,-1(P) ; CREATE AOBJN POINTER
+ HRLZS D
+ ADDI D,(C)
+ MOVEM D,TYPTAB ; SAVE IT
+ MOVE A,(P) ; GET LENGTH OF WORD
+ SUBI A,CONADJ ; SUBTRACT FOR CONSTANTS
+
+ ADD A,GCSTOP
+ CAMG A,FRETOP ; SEE IF GC IS NESESSARY
+ JRST RDGC1
+ MOVE C,(P)
+ ADDM C,GETNUM ; MOVE IN REQUEST
+ MOVE C,[0,,1] ; ARGS TO GC
+ PUSHJ P,AGC ; GC
+RDGC1: MOVE C,GCSTOP ; GET CURRENT TOP OF THE WORLD
+ MOVEM C,OGCSTP ; SAVE IT
+ ADD C,(P) ; CALCULATE NEW GCSTOP
+ ADDI C,2 ; SUBTRACT FOR CONSTANTS
+ MOVEM C,GCSTOP
+ SUB C,OGCSTP
+ SUBI C,2 ; SUBSTRACT TO GET RID OF D.W'S
+ MOVNS C ; SET UP AOBJN PTR FOR READIN
+IFN ITS,[
+ HRLZS C
+ MOVE A,-2(P) ; GET CHANNEL #
+ ADD C,OGCSTP
+ DOTCAL IOT,[A,C]
+ FATAL GCREAD-- IOT FAILED
+]
+IFE ITS,[
+ MOVE A,-2(P) ; CHANNEL TO A
+ MOVE B,OGCSTP ; SET UP BYTE POINTER
+ HRLI B,444400
+ SIN ; IN IT COMES
+]
+
+ MOVE C,(P) ; GET LENGHT OF OBJECT
+ ADDI A,5
+ MOVE B,1(AB) ; GET CHANNEL
+ ADDM C,ACCESS(B)
+ MOVE D,GCSTOP ; SET UP TO LOOK LIKE UVECTOR OF LOSES
+ ADDI C,2 ; ADD 2 FOR DOPE WORDS
+ HRLM C,-1(D)
+ MOVSI A,.VECT.
+ SETZM -2(D)
+ IORM A,-2(D) ; MARK VECTOR BIT
+ PUSH TP,$TRDTB ; HOLD ON IN CASE OF GC
+ MOVEI A,-2(D)
+ MOVN C,(P)
+ ADD A,C
+ HRL A,C
+ PUSH TP,A
+
+ MOVE D,-1(P) ; SET UP BOTTOM OF ATOM TABLE
+ SUBI D,1
+ MOVEM D,ABOTN
+ MOVE C,GCSTOP ; START AT TOP OF WORLD
+ SUBI C,3 ; POINT TO FIRST ATOM
+
+; LOOP TO FIX UP THE ATOMS
+
+AFXLP: HRRZ 0,1(TB)
+ ADD 0,ABOTN
+ CAMG C,0 ; SEE IF WE ARE DONE
+ JRST SWEEIN
+ HRRZ 0,1(TB)
+ SUB C,0
+ PUSHJ P,ATFXU ; FIX IT UP
+ HLRZ A,(C) ; GET LENGTH
+ TRZ A,400000 ; TURN OFF MARK BIT
+ SUBI C,(A) ; POINT TO PRECEDING ATOM
+ HRRZS C ; CLEAR OFF NEGATIVE
+ JRST AFXLP
+
+; FIXUP ROUTINE FOR ATOMS (C==> D.W.)
+
+ATFXU: PUSH P,C ; SAVE PTR TO D.W.
+ ADD C,1(TB)
+ MOVE A,C
+ HLRZ B,(A) ; GET LENGTH AND MARKING
+ TRZE B,400000 ; TURN OF MARK BIT AND SKIP IF WAS ALREADY MARKED
+ JRST ATFXU1
+ MOVEI D,-3(B) ; FULL WORDS OF STRING IN PNAME
+ IMULI D,5 ; CALCULATE # OF CHARACTERS
+ MOVE 0,-2(A) ; GET LAST WORD OF STRING
+ SUBI A,-1(B) ; LET A POINT TO OBLIST SLOAT
+ MOVE B,A ; GET COPY OF A
+ MOVE A,0
+ SUBI A,1
+ ANDCM 0,A
+ JFFO 0,.+1
+ HRREI 0,-34.(A)
+ IDIVI 0,7 ; # OF CHARS IN LAST WORD
+ ADD D,0
+ ADD D,$TCHSTR ; MAKE IT LOOK LIKE A STRINGS TYPE-WORD
+ PUSH P,D ; SAVE IT
+ MOVE C,(B) ; GET OBLIST SLOT PTR
+ATFXU9: HRRZS B ; RELATAVIZE POINTER
+ HRRZ 0,1(TB)
+ SUB B,0
+ PUSH P,B
+ JUMPE C,ATFXU6 ; NO OBLIST. CREATE ATOM
+ CAMN C,C%M1 ; SEE IF ROOT ATOM
+ JRST RTFX
+ ADD C,ABOTN ; POINT TO ATOM
+ PUSHJ P,ATFXU
+ PUSH TP,$TATOM
+ PUSH TP,B
+ MOVE A,$TATOM ; SET UP TO SEE IF OBLIST EXITS
+ MOVE C,$TATOM
+ MOVE D,IMQUOTE OBLIST
+ PUSHJ P,CIGTPR
+ JRST ATFXU8 ; NO OBLIST. CREATE ONE
+ SUB TP,C%22 ; GET RID OF SAVED ATOM
+RTCON: PUSH TP,$TOBLS
+ PUSH TP,B
+ MOVE C,B ; SET UP FOR LOOKUP
+ MOVE A,-1(P) ; SET UP PTR TO PNAME
+ MOVE B,(P)
+ ADD B,[440700,,1] ; ADJUST TO MAKE IT LOOK LIKE A BYTE-POINTER
+ HRRZ 0,1(TB)
+ ADD B,0
+ PUSHJ P,CLOOKU
+ JRST ATFXU4 ; NOT ON IT SO INSERT
+ATFXU3: SUB P,C%22 ; DONE
+ SUB TP,C%22 ; POP OFF OBLIST
+ATFXU7: MOVE C,(P) ; RESTORE PTR TO D.W.
+ ADD C,1(TB)
+ MOVEM B,-1(C) ; MOVE IN RELATAVIZE ADDRESS
+ MOVSI D,400000
+ IORM D,(C) ; TURN OFF MARK BIT
+ MOVE 0,3(B) ; SEE IF MUST BE LOCR
+ TRNE 0,1 ; SKIP IF MUST MAKE IT IMPURE
+ PUSHJ P,IIGLOC
+ POP P,C
+ ADD C,1(TB)
+ POPJ P, ; EXIT
+ATFXU1: POP P,C ; RESTORE PTR TO D.W.
+ ADD C,1(TB)
+ MOVE B,-1(C) ; GET ATOM
+ POPJ P,
+
+; ROUTINE TO INSERT AN ATOM
+
+ATFXU4: MOVE C,(TP) ; GET OBLIST PTR
+ MOVE B,(P) ; SET UP STRING PTR TO PNAME
+ ADD B,[440700,,1]
+ HRRZ 0,1(TB)
+ ADD B,0
+ MOVE A,-1(P) ; GET TYPE WORD
+ PUSHJ P,CINSER ; INSERT IT
+ JRST ATFXU3
+
+; THIS ROUTINE CREATS THE ATOM SO THAT ITS NOT ON ANY OBLIST
+
+ATFXU6: MOVE B,(P) ; POINT TO PNAME
+ ADD B,[440700,,1] ; MAKE IT LOOK LIKE A BYTE POINTER
+ HRRZ 0,1(TB)
+ ADD B,0
+ MOVE A,-1(P)
+ PUSHJ P,CATOM
+ SUB P,C%22 ; CLEAN OFF STACK
+ JRST ATFXU7
+
+; THIS ROUTINE CREATES AND OBLIST
+
+ATFXU8: MCALL 1,MOBLIST
+ PUSH TP,$TOBLS
+ PUSH TP,B ; SAVE OBLIST PTR
+ JRST ATFXU4 ; JUMP TO INSERT THE OBLIST
+
+; HERE TO INSERT AN ATOM INTO THE ROOT OBLIST
+
+RTFX: MOVE B,ROOT+1 ; GET ROOT OBLIST
+ JRST RTCON
+
+; THIS ROUTINE SWEEPS THRU THE NEW CORE IMAGE AND UPDATES ALL THE POINTERS.
+
+SWEEIN:
+; ROUTINE TO FIX UP TYPE-TABLE FOR GC-READ. THIS ROUTINE FIXES UP THE TYPE TABLE SO THAT
+; THE TYPES ATOM I.D. IS REPLACED BY ITS TYPE-NUMBER IN THE NEW MUDDLE AND IF ITS A
+; TEMPLATE, THE SLOT FOR THE PRIMTYPE-ATOM IS REPLACED BY THE SAT OF THE TEMPLATE
+
+ HRRZ E,1(TB) ; SET UP TYPE TABLE
+ ADD E,TYPTAB
+ JUMPGE E,VUP ; SKIP OVER IF DONE
+TYPUP1: PUSH P,C%0 ; PUSH SLOT FOR POSSIBLE TEMPLATE ATOM
+ HLRZ A,1(E) ; GET POSSIBLE ATOM SLOT
+ JUMPE A,TYPUP2 ; JUMP IF NOT A TEMPLATE
+ ADD A,ABOTN ; GET ATOM
+ ADD A,1(TB)
+ MOVE A,-1(A)
+ MOVE B,TYPVEC+1 ; GET TYPE VECTOR SLOT FOR LOOP TO SEE IF ITS THERE
+TYPUP3: CAMN A,1(B) ; SKIP IF NOT EQUAL
+ JRST TYPUP4 ; FOUND ONE
+ ADD B,C%22 ; TO NEXT
+ JUMPL B,TYPUP3
+ JRST ERTYP1 ; ERROR NONE EXISTS
+TYPUP4: HRRZ C,(B) ; GET SAT SLOT
+ CAIG C,NUMSAT ; MAKE SURE TYPE IS A TEMPLATE
+ JRST ERTYP2 ; IF NOT COMPLAIN
+ HRLM C,1(E) ; SMASH IN NEW SAT
+ MOVE B,1(B) ; GET ATOM OF PRIMTYPE
+ MOVEM B,(P) ; PUSH ONTO STACK
+TYPUP2: MOVEI D,0 ; INITIALIZE TYPE COUNT FOR LOOKUP LOOP
+ MOVE B,TYPVEC+1 ; GET PTR FOR LOOP
+ HRRZ A,1(E) ; GET TYPE'S ATOM ID
+ ADD A,ABOTN ; GET ATOM
+ ADD A,1(TB)
+ MOVE A,-1(A)
+TYPUP5: CAMN A,1(B) ; SKIP IF NOT EQUAL
+ JRST TYPUP6 ; FOUND ONE
+ ADDI D,1 ; INCREMENT TYPE-COUNT
+ ADD B,C%22 ; POINT TO NEXT
+ JUMPL B,TYPUP5
+ HRRM D,1(E) ; CLOBBER IN TYPE-NUMBER
+ PUSH TP,$TATOM ; PUSH ARGS FOR NEWTYPE
+ PUSH TP,A
+ PUSH TP,$TATOM
+ POP P,B ; GET BACK POSSIBLE PRIMTYPE ATOM
+ JUMPE B,TYPUP7 ; JUMP IF NOT A TEMPLATE
+ PUSH TP,B ; PUSH ON PRIMTYPE
+TYPUP9: SUB E,1(TB)
+ PUSH P,E ; SAVE RELATAVIZED PTR TO TYPE-TABLE
+ MCALL 2,NEWTYPE
+ POP P,E ; RESTORE RELATAVIZED PTR
+ ADD E,1(TB) ; FIX IT UP
+TYPUP0: ADD E,C%22 ; INCREMENT E
+ JUMPL E,TYPUP1
+ JRST VUP
+TYPUP7: HRRZ B,(E) ; FIND PRIMTYPE FROM SAT
+ MOVE A,@STBL(B)
+ PUSH TP,A
+ JRST TYPUP9
+TYPUP6: HRRM D,1(E) ; CLOBBER IN TYPE #
+ JRST TYPUP0
+
+ERTYP1: ERRUUO EQUOTE CANT-FIND-TEMPLATE
+
+ERTYP2: ERRUUO EQUOTE TEMPLATE-TYPE-NAME-NOT-OF-TYPE-TEMPLATE
+
+VUP: HRRZ E,1(TB) ; FIX UP SOME POINTERS
+ MOVEM E,OGCSTP
+ ADDM E,ABOTN
+ ADDM E,TYPTAB
+
+
+; ROUTINE TO SWEEP THRU THE READ-IN IMAGE LOOKING FOR UVECTORS AND TEMPLATES.
+; WHILE SWEEPING IT FIXES UP THE DOPE WORDS APPROPRIATELY.
+
+ HRRZ A,TYPTAB ; GET TO TOP OF WORLD
+ SUBI A,2 ; GET TO FIRST TYPE WORD OR DOPE-WORD OF FIRST OBJECT
+VUP1: CAMG A,OGCSTP ; SKIP IF NOT DONE
+ JRST VUP3
+ HLRZ B,(A) ; GET TYPE SLOT
+ TRNE B,.VECT. ; SKIP IF NOT A VECTOR
+ JRST VUP2
+ SUBI A,2 ; SKIP OVER PAIR
+ JRST VUP1
+VUP2: TRNE B,400000 ; SKIP IF UVECTOR
+ JRST VUP4
+ ANDI B,TYPMSK ; GET RID OF MONITORS
+ CAMG B,NNPRI ; SKIP IF NEWTYPE
+ JRST VUP5
+ PUSHJ P,GETNTP ; GET THE NEW TYPE #
+ PUTYP B,(A) ; SMASH IT IT
+VUP5: HLRZ B,1(A) ; SKIP OVER VECTOR
+ TRZ B,400000 ; GET RID OF POSSIBLE MARK BIT
+ SUBI A,(B)
+ JRST VUP1 ; LOOP
+VUP4: ANDI B,TYPMSK ; FLUSH MONITORS
+ CAMG B,NNSAT ; SKIP IF TEMPLATE
+ JRST VUP5
+ PUSHJ P,GETSAT ; CONVERT TO NEW SAT
+ ADDI B,.VECT. ; MAJIC TO TURN ON BIT
+ PUTYP B,(A)
+ JRST VUP5
+
+
+VUP3: PUSH P,GCSBOT ; SAVE CURRENT GCSBOT
+ MOVE A,OGCSTP ; SET UP NEW GCSBOT
+ MOVEM A,GCSBOT
+ PUSH P,GCSTOP
+ HRRZ A,TYPTAB ; SET UP NEW GCSTOP
+ MOVEM A,GCSTOP
+ SETOM GCDFLG
+ MOVE A,[PUSHJ P,RDFIX] ; INS FOR GCHACK
+ MOVEI PVP,0 ; SAY MIGHT BE NON-ATOMS
+ PUSHJ P,GCHK10
+ SETZM GCDFLG
+ POP P,GCSTOP ; RESTORE GCSTOP
+ MOVE A,1(TB) ; GET A POINTER TO RETURNING VALUES
+ MOVE B,A
+ HLRE C,B
+ SUB B,C
+ SETZM (B)
+ SETZM 1(B)
+ POP P,GCSBOT ; RESTORE GCSBOT
+ MOVE B,1(A) ; GET PTR TO OBJECTS
+ MOVE A,(A)
+ JRST FINIS ; EXIT
+
+; ERROR FOR INCORRECT GCREAD FILE
+
+ERDGC: ERRUUO EQUOTE BAD-GC-READ-FILE
+
+; ROUTINE CALLED BY GCHACK TO UPDATE PTRS IN THE NEW CORE IMAGE
+
+RDFIX: PUSH P,C ; SAVE C
+ PUSH P,B ; SAVE PTR
+ EXCH B,C
+ TLNE C,UBIT ; SKIP IF NOT UVECTOR
+ JRST ELEFX ; DON'T HACK TYPES IN UVECTOR
+ CAIN B,TTYPEC
+ JRST TYPCFX
+ CAIN B,TTYPEW
+ JRST TYPWFX
+ CAML B,NNPRI
+ JRST TYPGFX
+ELEFX: EXCH B,A ; EXCHANGE FOR SAT
+ PUSHJ P,SAT
+ EXCH B,A ; REFIX
+ CAIE B,SLOCR ; REL GLOC'S ARE STORED AS ATOMS
+ CAIN B,SATOM
+ JRST ATFX
+ CAIN B,SCHSTR
+ JRST STFX
+ CAIN B,S1WORD ; SEE IF PRIMTYPE WOR
+ JRST RDLSTF ; LEAVE IF IS
+STFXX: MOVE 0,GCSBOT ; ADJUSTMENT
+ SUBI 0,FPAG+5
+ SKIPE 1(C) ; DON'T CHANGE A PTR TO NIL
+ ADDM 0,1(C) ; FIX UP
+RDLSTF: TLNN C,.LIST. ; SEE IF PAIR
+ JRST RDL1 ; EXIT
+ MOVE 0,GCSBOT ; FIX UP
+ SUBI 0,FPAG+5
+ HRRZ B,(C) ; SEE IF POINTS TO NIL
+ SKIPN B
+ JRST RDL1
+ MOVE B,C ; GET ARG FOR RLISTQ
+ PUSHJ P,RLISTQ
+ JRST RDL1
+ ADDM 0,(C)
+RDL1: POP P,B ; RESTORE B
+ POP P,C
+ POPJ P,
+
+; ROUTINE TO FIX UP PNAMES
+
+STFX: TLZN D,STATM
+ JRST STFXX
+ HLLM D,1(C) ; PUT BACK WITH BIT OFF
+ ADD D,ABOTN
+ ANDI D,-1
+ HLRE 0,-1(D) ; LENGTH OF ATOM
+ MOVNS 0
+ SUBI 0,3 ; VAL & OBLIST
+ IMULI 0,5 ; TO CHARS (SORT OF)
+ HRRZ D,-1(D)
+ ADDI D,2
+ PUSH P,A
+ PUSH P,B
+ LDB A,[360600,,1(C)] ; GET BYTE POS
+ IDIVI A,7 ; TO CHAR POS
+ SKIPE A
+ SUBI A,5
+ HRRZ B,(C) ; STRING LENGTH
+ SUB B,A ; TO WORD BOUNDARY STRING
+ SUBI 0,(B)
+ IDIVI 0,5
+ ADD D,0
+ POP P,B
+ POP P,A
+ HRRM D,1(C)
+ JRST RDLSTF
+
+; ROUTINE TO FIX UP POINTERS TO ATOMS
+
+ATFX: SKIPGE D
+ JRST RDLSTF
+ ADD D,ABOTN
+ MOVE 0,-1(D) ; GET PTR TO ATOM
+ CAIE B,SLOCR ; IF REL LOCATIVE, MORE HAIR
+ JRST ATFXAT
+ MOVE B,0
+ PUSH P,E
+ PUSH P,D
+ PUSH P,C
+ PUSH P,B
+ PUSH P,A
+ PUSHJ P,IGLOC
+ SUB B,GLOTOP+1
+ MOVE 0,B
+ POP P,A
+ POP P,B
+ POP P,C
+ POP P,D
+ POP P,E
+ATFXAT: MOVEM 0,1(C) ; SMASH IT IN
+ JRST RDLSTF ; EXIT
+
+TYPCFX: HRRZ B,1(C) ; GET TYPE
+ PUSHJ P,GETNEW ; GET TYPE IN THIS CORE IMAGE
+ HRRM B,1(C) ; CLOBBER IT IN
+ JRST RDLSTF ; CONTINUE FIXUP
+
+TYPWFX: HLRZ B,1(C) ; GET TYPE
+ PUSHJ P,GETNEW ; GET TYPE IN THIS CORE IMAGE
+ HRLM B,1(C) ; SMASH IT IN
+ JRST ELEFX
+
+TYPGFX: PUSH P,D
+ PUSHJ P,GETNTP ; GET TYPE IN THIS CORE IMAGE
+ POP P,D
+ PUTYP B,(C)
+ JRST ELEFX
+
+; HERE TO HANDLE AN EOF IN GC-READ. IT USES OPTIONAL SECOND ARG IF SUPPLIED AS
+; EOF HANDLER ELSE USES CHANNELS.
+
+EOFGC: MOVE B,1(AB) ; GET CHANNEL INTO B
+ CAML AB,C%M20 ; [-2,,0] ; SKIP IF EOF ROUTINE IS SUPPLIED
+ JRST MYCLOS ; USE CHANNELS
+ PUSH TP,2(AB)
+ PUSH TP,3(AB)
+ JRST CLOSIT
+MYCLOS: PUSH TP,EOFCND-1(B)
+ PUSH TP,EOFCND(B)
+CLOSIT: PUSH TP,$TCHAN
+ PUSH TP,B
+ MCALL 1,FCLOSE ; CLOSE CHANNEL
+ MCALL 1,EVAL ; EVAL HIS EOF HANDLER
+ JRST FINIS
+
+; ROUTINE TO SUPPLY THE TYPE NUMBER FOR A NEWTYPE
+
+GETNEW: CAMG B,NNPRI ;NEWTYPE
+ POPJ P,
+GETNTP: MOVE D,TYPTAB ; GET AOBJN POINTER TO TYPE-TABLE
+GETNT1: HLRZ E,(D) ; GET TYPE #
+ CAIN E,(B) ; SKIP IF NOT EQUAL TO GOAL
+ JRST GOTTYP ; FOUND IT
+ ADD D,C%22 ; POINT TO NEXT
+ JUMPL D,GETNT1
+ SKIPA ; KEEP TYPE SAME
+GOTTYP: HRRZ B,1(D) ; GET NEW TYPE #
+ POPJ P,
+
+; ROUTINE TO SUPPLY THE SAT TO A TEMPLATE HACKER
+
+GETSAT: MOVE D,TYPTAB ; GET AOBJN PTR TO TYPE TABLE
+GETSA1: HRRZ E,(D) ; GET OBJECT
+ CAIN E,(B) ; SKIP IF NOT EQUAL TO GOAL
+ JRST GOTSAT ; FOUND IT
+ ADD D,C%22
+ JUMPL D,GETSA1
+ FATAL GC-DUMP -- TYPE FIXUP FAILURE
+GOTSAT: HLRZ B,1(D) ; GET NEW SAT
+ POPJ P,
+
+
+; A ROUTINE TO DISTINGUISH BETWEEN A DEFERRED AND A LIST POINTER
+RLISTQ: PUSH P,A
+ GETYP A,(B) ; GET TYPE
+ PUSHJ P,SAT ; GET SAT
+ CAIG A,NUMSAT ; NOT DEFERRED IF TEMPLATE
+ SKIPL MKTBS(A)
+ AOS -1(P) ; SKIP IF NOT DEFFERED
+ POP P,A
+ POPJ P, ; EXIT
+
+\f
+.GLOBAL FLIST
+
+MFUNCTION BLOATSTAT,SUBR,[BLOAT-STAT]
+
+ENTRY
+
+ JUMPGE AB,GETUVC ; SEE IF THERE IS AN ARGUMENT
+ GETYP A,(AB)
+ CAIE A,TUVEC ; SEE IF THE ARGUMENT IS A UVECTOR
+ JRST WTYP1 ; IF NOT COMPLAIN
+ HLRE 0,1(AB)
+ MOVNS 0
+ CAIE 0,STATNO+STATGC ; SEE IF UVECTOR IS RIGHT LENGTH
+ JRST WTYP1
+ CAMGE AB,C%M20 ; [-2,,0] ; SEE IF THERE ARE TOO MANY ARGUMENTS
+ JRST TMA
+ MOVE A,(AB) ; GET THE UVECTOR
+ MOVE B,1(AB)
+ JRST SETUV ; CONTINUE
+GETUVC: MOVEI A,STATNO+STATGC ; CREATE A UVECTOR
+ PUSHJ P,IBLOCK
+SETUV: PUSH P,A ; SAVE UVECTOR
+ PUSH P,B
+ MOVE 0,NOWFRE ; COMPUTE FREE STORAGE USED SINCE LAST BLOAT-STAT
+ SUB 0,RFRETP
+ ADD 0,GCSTOP
+ MOVEM 0,CURFRE
+ PUSHJ P,GCSET ; FIX UP BLOAT-STAT PARAMETERS
+ HLRE 0,TP ; COMPUTE STACK SPACE USED UP
+ ADD 0,NOWTP
+ SUBI 0,PDLBUF
+ MOVEM 0,CURTP
+ MOVE B,IMQUOTE THIS-PROCESS
+ PUSHJ P,ILOC
+ HRRZS B
+ MOVE PVP,PVSTOR+1
+ HRRZ C,TPBASE+1(PVP) ; CALCULATE # OF ATOM SLOTS
+ MOVE 0,B
+ HRRZ D,SPBASE+1(PVP) ; COMPUTE CURRENT # OF BINDINGS
+ SUB 0,D
+ IDIVI 0,6
+ MOVEM 0,CURLVL
+ SUB B,C ; TOTAL WORDS ATOM STORAGE
+ IDIVI B,6 ; COMPUTE # OF SLOTS
+ MOVEM B,NOWLVL
+ HRRZ A,GLOBASE+1 ; COMPUTE TOTAL # OF GLOBAL SLOTS
+ HLRE 0,GLOBASE+1
+ SUB A,0 ; POINT TO DOPE WORD
+ HLRZ B,1(A)
+ ASH B,-2 ; # OF GVAL SLOTS
+ MOVEM B,NOWGVL
+ HRRZ A,GLOTOP+1 ; COMPUTE # OF GVAL SLOTS IN USE
+ HRRZ 0,GLOBSP+1
+ SUB A,0
+ ASH A,-2 ; NEGATIVE # OF SLOTS USED
+ MOVEM A,CURGVL
+ HRRZ A,TYPBOT+1 ; GET LENGTH OF TYPE VECTOR
+ HLRE 0,TYPBOT+1
+ SUB A,0
+ HLRZ B,1(A) ; # OF WORDS IN TYPE-VECTOR
+ IDIVI B,2 ; CONVERT TO # OF TYPES
+ MOVEM B,NOWTYP
+ HLRE 0,TYPVEC+1 ; LENGTH OF VISABLE TYPE-VECTOR
+ MOVNS 0
+ IDIVI 0,2 ; GET # OF TYPES
+ MOVEM 0,CURTYP
+ MOVE 0,CODTOP ; GET LENGTH OF STATIONARY IMPURE STORAGE
+ MOVEM 0,NOWSTO
+ SETZB B,D ; ZERO OUT MAXIMUM
+ HRRZ C,FLIST
+LOOPC: HLRZ 0,(C) ; GET BLK LENGTH
+ ADD D,0 ; ADD # OF WORDS IN BLOCK
+ CAMGE B,0 ; SEE IF NEW MAXIMUM
+ MOVE B,0
+ HRRZ C,(C) ; POINT TO NEXT BLOCK
+ JUMPN C,LOOPC ; REPEAT
+ MOVEM D,CURSTO
+ MOVEM B,CURMAX
+ HLRE 0,P ; GET AMOUNT OF ROOM LEFT ON P
+ ADD 0,NOWP
+ SUBI 0,PDLBUF
+ MOVEM 0,CURP
+ MOVSI C,BSTGC ; SET UP BLT FOR GC FIGURES
+ HRRZ B,(P) ; RESTORE B
+ HRR C,B
+ BLT C,(B)STATGC-1
+ HRLI C,BSTAT ; MODIFY BLT FOR STATS
+ HRRI C,STATGC(B)
+ BLT C,(B)STATGC+STATNO-1
+ MOVEI 0,TFIX+.VECT.
+ HRLM 0,(B)STATNO+STATGC ; MOVE IN UTYPE
+ POP P,B
+ POP P,A ; RESTORE TYPE-WORD
+ JRST FINIS
+
+GCRSET: SETZM GCNO ; CALL FROM INIT, ZAP ALL 1ST
+ MOVE 0,[GCNO,,GCNO+1]
+ BLT 0,GCCALL
+ JRST GCSET
+
+
+
+\f
+.GLOBAL PGFIND,PGGIVE,PGTAKE,PGINT
+
+; USER GARBAGE COLLECTOR INTERFACE
+.GLOBAL ILVAL
+
+MFUNCTION GC,SUBR
+ ENTRY
+
+ JUMPGE AB,GC1
+ CAMGE AB,C%M60 ; [-6,,0]
+ JRST TMA
+ PUSHJ P,GETFIX ; GET FREEE MIN IF GIVEN
+ SKIPE A ; SKIP FOR 0 ARGUMENT
+ MOVEM A,FREMIN
+GC1: PUSHJ P,COMPRM ; GET CURRENT USED CORE
+ PUSH P,A
+ CAML AB,C%M40 ; [-4,,0] ; SEE IF 3RD ARG
+ JRST GC5
+ GETYP A,4(AB) ; MAKE SURE A FIX
+ CAIE A,TFIX
+ JRST WTYP ; ARG WRONG TYPE
+ MOVE A,5(AB)
+ MOVEM A,RNUMSP
+ MOVEM A,NUMSWP
+GC5: CAML AB,C%M20 ; [-2,,0] ; SEE IF SECOND ARG
+ JRST GC3
+ GETYP A,2(AB) ; SEE IF NONFALSE
+ CAIE A,TFALSE ; SKIP IF FALSE
+ JRST HAIRGC ; CAUSE A HAIRY GC
+GC3: MOVSI A,TATOM ; CHECK TO SEE IF INTERRUPT FLAG IS ON
+ MOVE B,IMQUOTE AGC-FLAG
+ PUSHJ P,ILVAL
+ CAMN A,$TUNBOUND ; SKIP IF NOT UNBOUND
+ JRST GC2
+ SKIPE GCHPN ; SKIP IF GCHAPPEN IS 0
+ JRST FALRTN ; JUMP TO RETURN FALSE
+GC2: MOVE C,[9.,,0]
+ PUSHJ P,AGC ; COLLECT THAT TRASH
+ PUSHJ P,COMPRM ; HOW MUCH ROOM NOW?
+ POP P,B ; RETURN AMOUNT
+ SUB B,A
+ MOVSI A,TFIX
+ JRST FINIS
+HAIRGC: MOVE B,3(AB)
+ CAIN A,TFIX ; IF FIX THEN CLOBBER NGCS
+ MOVEM B,NGCS
+ MOVEI A,1 ; FORCE VALUE FLUSHING PHASE TO OCCUR
+ MOVEM A,GCHAIR
+ JRST GC2 ; HAIRY GC OCCORS NO MATTER WHAT
+FALRTN: MOVE A,$TFALSE
+ MOVEI B,0 ; RETURN A FALSE-- FOR GC WHICH DIDN'T OCCOR
+ JRST FINIS
+
+
+COMPRM: MOVE A,GCSTOP ; USED SPACE
+ SUB A,GCSBOT
+ POPJ P,
+
+\f
+MFUNCTION GCDMON,SUBR,[GC-MON]
+
+ ENTRY
+
+ MOVEI E,GCMONF
+
+FLGSET: MOVE C,(E) ; GET CURRENT VALUE
+ JUMPGE AB,RETFLG ; RET CURRENT
+ CAMGE AB,C%M20 ; [-3,,]
+ JRST TMA
+ GETYP 0,(AB)
+ SETZM (E)
+ CAIN 0,TFALSE
+ SETOM (E)
+ SKIPL E
+ SETCMM (E)
+
+RETFLG: SKIPL E
+ SETCMM C
+ JUMPL C,NOFLG
+ MOVSI A,TATOM
+ MOVE B,IMQUOTE T
+ JRST FINIS
+
+NOFLG: MOVEI B,0
+ MOVSI A,TFALSE
+ JRST FINIS
+
+.GLOBAL EVATYP,APLTYP,PRNTYP
+
+\fMFUNCTION BLOAT,SUBR
+ ENTRY
+
+ PUSHJ P,SQKIL
+ MOVEI C,0 ; FLAG TO SAY WHETHER NEED A GC
+ MOVSI E,-NBLO ; AOBJN TO BLOATER TABLE
+
+BLOAT2: JUMPGE AB,BLOAT1 ; ALL DONE?
+ PUSHJ P,NXTFIX ; GET NEXT BLOAT PARAM
+ SKIPE A
+ PUSHJ P,@BLOATER(E) ; DISPATCH
+ AOBJN E,BLOAT2 ; COUNT PARAMS SET
+
+ JUMPL AB,TMA ; ANY LEFT...ERROR
+BLOAT1: JUMPE C,BLOATD ; DONE, NO GC NEEDED
+ MOVE C,E ; MOVE IN INDICATOR
+ HRLI C,1 ; INDICATE THAT IT COMES FROM BLOAT
+ SETOM INBLOT
+ PUSHJ P,AGC ; DO ONE
+ SKIPE A,TPBINC ; SMASH POINNTERS
+ MOVE PVP,PVSTOR+1
+ ADDM A,TPBASE+1(PVP)
+ SKIPE A,GLBINC ; GLOBAL SP
+ ADDM A,GLOBASE+1
+ SKIPE A,TYPINC
+ ADDM A,TYPBOT+1
+ SETZM TPBINC ; RESET PARAMS
+ SETZM GLBINC
+ SETZM TYPINC
+
+BLOATD: SKIPN A,GETNUM ; SKIP IF FREE STORAGE REQUEST IN EFFECT
+ JRST BLTFN
+ ADD A,FRETOP ; ADD FRETOP
+ ADDI A,1777 ; ONE BLOCK FOR MARK PDL AND ROUND
+ ANDCMI A,1777 ; TO PAGE BOUNDRY
+ CAML A,PURBOT ; SKIP IF POSSIBLE TO WIN
+ JRST BLFAGC
+ ASH A,-10. ; TO PAGES
+ PUSHJ P,P.CORE ; GRET THE CORE
+ JRST BLFAGC ; LOSE LOSE LOSE
+ MOVE A,FRETOP ; CALCULATE NEW PARAMETERS
+ MOVEM A,RFRETP
+ MOVEM A,CORTOP
+ MOVE B,GCSTOP
+ SETZM 1(B)
+ HRLI B,1(B)
+ HRRI B,2(B)
+ BLT B,-1(A) ; ZERO CORE
+BLTFN: SETZM GETNUM
+ MOVE B,FRETOP
+ SUB B,GCSTOP
+ MOVSI A,TFIX ; RETURN CORE FOUND
+ JRST FINIS
+BLFAGC: MOVN A,FREMIN
+ ADDM A,GETNUM ; FIX UP SO BLOATS CORRECTLY
+ MOVE C,C%11 ; INDICATOR FOR AGC
+ PUSHJ P,AGC ; GARBAGE COLLECT
+ JRST BLTFN ; EXIT
+
+; TABLE OF BLOAT ROUTINES
+
+BLOATER:
+ MAINB
+ TPBLO
+ LOBLO
+ GLBLO
+ TYBLO
+ STBLO
+ PBLO
+ SFREM
+ SLVL
+ SGVL
+ STYP
+ SSTO
+ PUMIN
+ PMUNG
+ TPMUNG
+ NBLO==.-BLOATER
+
+; BLOAT MAIN STORAGE AREA
+
+MAINB: SETZM GETNUM
+ MOVE D,FRETOP ; COMPUTE CURRENT ROOM
+ SUB D,PARTOP
+ CAMGE A,D ; NEED MORE?
+ POPJ P, ; NO, LEAVE
+ SUB A,D
+ MOVEM A,GETNUM ; SAVE
+ POPJ P,
+
+; BLOAT TP STACK (AT TOP)
+
+TPBLO: HLRE D,TP ; GET -SIZE
+ MOVNS B,D
+ ADDI D,1(TP) ; POINT TO DOPE (ALMOST)
+ CAME D,TPGROW ; BLOWN?
+ ADDI D,PDLBUF ; POINT TO REAL DOPE WORD
+ SUB A,B ; SKIP IF GROWTH NEEDED
+ JUMPLE A,CPOPJ
+ ADDI A,63.
+ ASH A,-6 ; CONVERT TO 64 WD BLOCKS
+ CAILE A,377
+ JRST OUTRNG
+ DPB A,[111100,,-1(D)] ; SMASH SPECS IN
+ AOJA C,CPOPJ
+
+; BLOAT TOP LEVEL LOCALS
+
+LOBLO: HLRE D,TP ; GET -SIZE
+ MOVNS B,D
+ ADDI D,1(TP) ; POINT TO DOPE (ALMOST)
+ CAME D,TPGROW ; BLOWN?
+ ADDI D,PDLBUF ; POINT TO REAL DOPE WORD
+ CAMG A,B ; SKIP IF GROWTH NEEDED
+ IMULI A,6 ; 6 WORDS PER BINDING
+ MOVE PVP,PVSTOR+1
+ HRRZ 0,TPBASE+1(PVP)
+ HRRZ B,SPBASE+1(PVP) ; ROOM AVAIL TO E
+ SUB B,0
+ SUBI A,(B) ; HOW MUCH MORE?
+ JUMPLE A,CPOPJ ; NONE NEEDED
+ MOVEI B,TPBINC
+ PUSHJ P,NUMADJ
+ DPB A,[1100,,-1(D)] ; SMASH
+ AOJA C,CPOPJ
+
+; GLOBAL SLOT GROWER
+
+GLBLO: ASH A,2 ; 4 WORDS PER VAR
+ MOVE D,GLOBASE+1 ; CURRENT LIMITS
+ HRRZ B,GLOBSP+1
+ SUBI B,(D)
+ SUBI A,(B) ; NEW AMOUNT NEEDED
+ JUMPLE A,CPOPJ
+ MOVEI B,GLBINC ; WHERE TO KEEP UPDATE
+ PUSHJ P,NUMADJ ; FIX NUMBER
+ HLRE 0,D
+ SUB D,0 ; POINT TO DOPE
+ DPB A,[1100,,(D)] ; AND SMASH
+ AOJA C,CPOPJ
+
+; HERE TO GROW TYPE VECTOR (AND FRIENDS)
+
+TYBLO: ASH A,1 ; TWO WORD PER TYPE
+ HRRZ B,TYPVEC+1 ; FIND CURRENT ROOM
+ MOVE D,TYPBOT+1
+ SUBI B,(D)
+ SUBI A,(B) ; EXTRA NEEDED TO A
+ JUMPLE A,CPOPJ ; NONE NEEDED, LEAVE
+ MOVEI B,TYPINC ; WHERE TO STASH SPEC
+ PUSHJ P,NUMADJ ; FIX NUMBER
+ HLRE 0,D ; POINT TO DOPE
+ SUB D,0
+ DPB A,[1100,,(D)]
+ SKIPE D,EVATYP+1 ; GROW AUX TYPE VECS IF NEEDED
+ PUSHJ P,SGROW1
+ SKIPE D,APLTYP+1
+ PUSHJ P,SGROW1
+ SKIPE D,PRNTYP+1
+ PUSHJ P,SGROW1
+ AOJA C,CPOPJ
+
+; HERE TO CREATE STORAGE SPACE
+
+STBLO: MOVE D,GCSBOT ; HOW MUCH NOW HERE
+ SUB D,CODTOP
+ SUBI A,(D) ; MORE NEEDED?
+ JUMPLE A,CPOPJ
+ MOVEM A,PARNEW ; FORCE PAIR SPACE TO MOVE ON OUT
+ AOJA C,CPOPJ
+
+; BLOAT P STACK
+
+PBLO: HLRE D,P
+ MOVNS B,D
+ SUBI D,5 ; FUDGE FOR THIS CALL
+ SUBI A,(D)
+ JUMPLE A,CPOPJ
+ ADDI B,1(P) ; POINT TO DOPE
+ CAME B,PGROW ; BLOWN?
+ ADDI B,PDLBUF ; NOPE, POIN TO REAL D.W.
+ ADDI A,63.
+ ASH A,-6 ; TO 64 WRD BLOCKS
+ CAILE A,377 ; IN RANGE?
+ JRST OUTRNG
+ DPB A,[111100,,-1(B)]
+ AOJA C,CPOPJ
+
+; SET FREMIN
+
+SFREM: SKIPE A ; DON'T ZERO EMPTY PARAMETER
+ MOVEM A,FREMIN
+ POPJ P,
+
+; SET LVAL INCREMENT
+
+SLVL: IMULI A,6 ; CALCULATE AMOUNT TO GROW B
+ MOVEI B,LVLINC
+ PUSHJ P,NUMADJ
+ MOVEM A,LVLINC
+ POPJ P,
+
+; SET GVAL INCREMENT
+
+SGVL: IMULI A,4. ; # OF SLOTS
+ MOVEI B,GVLINC
+ PUSHJ P,NUMADJ
+ MOVEM A,GVLINC
+ POPJ P,
+
+; SET TYPE INCREMENT
+
+STYP: IMULI A,2 ; CALCULATE NUMBER OF GROW BLOCKS NEEDED
+ MOVEI B,TYPIC
+ PUSHJ P,NUMADJ
+ MOVEM A,TYPIC
+ POPJ P,
+
+; SET STORAGE INCREMENT
+
+SSTO: IDIVI A,2000 ; # OF BLOCKS
+ CAIE B,0 ; REMAINDER?
+ ADDI A,1
+ IMULI A,2000 ; CONVERT BACK TO WORDS
+ MOVEM A,STORIC
+ POPJ P,
+; HERE FOR MINIMUM PURE SPACE
+
+PUMIN: ADDI A,1777
+ ANDCMI A,1777 ; TO PAGE BOUNDRY
+ MOVEM A,PURMIN
+ POPJ P,
+
+; HERE TO ADJUST PSTACK PARAMETERS IN GC
+
+PMUNG: ADDI A,777 ; TO NEAREST 1000 WORD BOUNDRY
+ ANDCMI A,777
+ MOVEM A,PGOOD ; PGOOD
+ ASH A,2 ; PMAX IS 4*PGOOD
+ MOVEM A,PMAX
+ ASH A,-4 ; PMIN IS .25*PGOOD
+ MOVEM A,PMIN
+
+; HERE TO ADJUST GC TPSTACK PARAMS
+
+TPMUNG: ADDI A,777
+ ANDCMI A,777 ; TO NEAREST 1000 WORD BOUNDRY
+ MOVEM A,TPGOOD
+ ASH A,2 ; TPMAX= 4*TPGOOD
+ MOVEM A,TPMAX
+ ASH A,-4 ; TPMIN= .25*TPGOOD
+ MOVEM A,TPMIN
+
+
+; GET NEXT (FIX) ARG
+
+NXTFIX: PUSHJ P,GETFIX
+ ADD AB,C%22
+ POPJ P,
+
+; ROUTINE TO GET POS FIXED ARG
+
+GETFIX: GETYP A,(AB)
+ CAIE A,TFIX
+ JRST WRONGT
+ SKIPGE A,1(AB)
+ JRST BADNUM
+ POPJ P,
+
+
+; GET NUMBERS FIXED UP FOR GROWTH FIELDS
+
+NUMADJ: ADDI A,77 ; ROUND UP
+ ANDCMI A,77 ; KILL CRAP
+ MOVE 0,A
+ MOVNS A ; COMPUTE ADD FACTOR FOR SPEC. POINTER UPDATE
+ HRLI A,-1(A)
+ MOVEM A,(B) ; AND STASH IT
+ MOVE A,0
+ ASH A,-6 ; TO 64 WD BLOCKS
+ CAILE A,377 ; CHECK FIT
+ JRST OUTRNG
+ POPJ P,
+
+; DO SYMPATHETIC GROWTHS
+
+SGROW1: HLRE 0,D
+ SUB D,0
+ DPB A,[111100,,(D)]
+ POPJ P,
+
+\f;FUNCTION TO CONSTRUCT A LIST
+
+MFUNCTION CONS,SUBR
+
+ ENTRY 2
+ GETYP A,2(AB) ;GET TYPE OF 2ND ARG
+ CAIE A,TLIST ;LIST?
+ JRST WTYP2 ;NO , COMPLAIN
+ MOVE C,(AB) ; GET THING TO CONS IN
+ MOVE D,1(AB)
+ HRRZ E,3(AB) ; AND LIST
+ PUSHJ P,ICONS ; INTERNAL CONS
+ JRST FINIS
+
+; COMPILER CALL TO CONS
+
+C1CONS: PUSHJ P,ICELL2
+ JRST ICONS2
+ICONS4: HRRI C,(E)
+ICONS3: MOVEM C,(B) ; AND STORE
+ MOVEM D,1(B)
+TLPOPJ: MOVSI A,TLIST
+ POPJ P,
+
+; INTERNAL CONS--ICONS; C,D VALUE, E CDR
+
+; RELATIVIZE RETURN ADDRESS HERE--MUST BE DIFFERENT FROM ICONS, SINCE
+; ICONS IS CALLED FROM INTERPRETER ENTRIES WHICH ARE THEMSELVES PUSHJ'ED
+; TO: DOING SUBM M,(P) ANYWHERE IN ICONS IS FATAL IF A GC OCCURS.
+
+CICONS: SUBM M,(P)
+ PUSHJ P,ICONS
+ JRST MPOPJ
+
+; INTERNAL CONS TO NIL--INCONS
+
+INCONS: MOVEI E,0
+
+ICONS: GETYP A,C ; CHECK TYPE OF VAL
+ PUSHJ P,NWORDT ; # OF WORDS
+ SOJN A,ICONS1 ; JUMP IF DEFERMENT NEEDED
+ PUSHJ P,ICELL2 ; NO DEFER, GET 2 WORDS FROM PAIR SPACE
+ JRST ICNS2A ; NO CORE, GO GC (SPECIAL PLACE, NOTICE)
+ JRST ICONS4
+
+; HERE IF CONSING DEFERRED
+
+ICONS1: MOVEI A,4 ; NEED 4 WORDS
+ PUSHJ P,ICELL ; GO GET 'EM
+ JRST ICNS2A ; NOT THERE, GC (SAME PLACE AS FOR ICONS)
+ HRLI E,TDEFER ; CDR AND DEFER
+ MOVEM E,(B) ; STORE
+ MOVEI E,2(B) ; POINT E TO VAL CELL
+ HRRZM E,1(B)
+ MOVEM C,(E) ; STORE VALUE
+ MOVEM D,1(E)
+ JRST TLPOPJ
+
+
+
+; HERE TO GC ON A CONS
+
+; HERE FROM C1CONS
+ICONS2: SUBM M,(P)
+ PUSHJ P,ICONSG
+ SUBM M,(P)
+ JRST C1CONS
+
+; HERE FROM ICONS (THUS CICONS, INDIRECTLY), ICONS1
+ICNS2A: PUSHJ P,ICONSG
+ JRST ICONS
+
+; REALLY DO GC
+ICONSG: PUSH TP,C ; SAVE VAL
+ PUSH TP,D
+ PUSH TP,$TLIST
+ PUSH TP,E ; SAVE VITAL STUFF
+ ADDM A,GETNUM ; AMOUNT NEEDED
+ MOVE C,[3,,1] ; INDICATOR FOR AGC
+ PUSHJ P,INQAGC ; ATTEMPT TO WIN
+ MOVE D,-2(TP) ; RESTORE VOLATILE STUFF
+ MOVE C,-3(TP)
+ MOVE E,(TP)
+ SUB TP,C%44 ; [4,,4]
+ POPJ P, ; BACK TO DRAWING BOARD
+
+; SUBROUTINE TO ALLOCATE WORDS IN PAIR SPACE. CALLS AGC IF NEEDED
+
+CELL2: MOVEI A,2 ; USUAL CASE
+CELL: PUSHJ P,ICELL ; INTERNAL
+ JRST .+2 ; LOSER
+ POPJ P,
+
+ ADDM A,GETNUM ; AMOUNT REQUIRED
+ PUSH P,A ; PREVENT AGC DESTRUCTION
+ MOVE C,[3,,1] ; INDICATOR FOR AGC
+ PUSHJ P,INQAGC
+ POP P,A
+ JRST CELL ; AND TRY AGAIN
+
+; INTERNAL CELL GETTER, SKIPS IF ROO EXISTS, ELSE DOESN'T
+
+ICELL2: MOVEI A,2 ; MOST LIKELY CAE
+ICELL: SKIPE B,RCL
+ JRST ICELRC ;SEE IF WE CAN RE-USE A RECYCLE CELL
+ MOVE B,PARTOP ; GET TOP OF PAIRS
+ ADDI B,(A) ; BUMP
+ CAMLE B,FRETOP ; SKIP IF OK.
+ JRST VECTRY ; LOSE
+ EXCH B,PARTOP ; SETUP NEW PARTOP AND RETURN POINTER
+ ADDM A,USEFRE
+ JRST CPOPJ1 ; SKIP RETURN
+
+; TRY RECYCLING USING A VECTOR FROM RCLV
+
+VECTRY: SKIPN B,RCLV ; SKIP IF VECTOR EXISTS
+ POPJ P,
+ PUSH P,C
+ PUSH P,A
+ MOVEI C,RCLV
+VECTR1: HLRZ A,(B) ; GET LENGTH
+ SUB A,(P)
+ JUMPL A,NXTVEC ; DOESN'T SATISFY TRY AGAIN
+ CAIN A,1 ; MAKE SURE NOT LEFT WITH A SINGLE SLOT
+ JRST NXTVEC
+ JUMPN A,SOML ; SOME ARE LEFT
+ HRRZ A,(B)
+ HRRM A,(C)
+ HLRZ A,(B)
+ SETZM (B)
+ SETZM -1(B) ; CLEAR DOPE WORDS
+ SUBI B,-1(A)
+ POP P,A ; CLEAR STACK
+ POP P,C
+ JRST CPOPJ1
+SOML: HRLM A,(B) ; SMASH AMOUNT LEFT
+ SUBI B,-1(A) ; GET TO BEGINNING
+ SUB B,(P)
+ POP P,A
+ POP P,C
+ JRST CPOPJ1
+NXTVEC: MOVEI C,(B)
+ HRRZ B,(B) ; GET NEXT
+ JUMPN B,VECTR1
+ POP P,A
+ POP P,C
+ POPJ P,
+
+ICELRC: CAIE A,2
+ JRST ICELL+2 ;IF HE DOESNT WANT TWO, USE OLD METHOD
+ PUSH P,A
+ MOVE A,(B)
+ HRRZM A,RCL
+ POP P,A
+ SETZM (B) ;GIVE HIM A CLEAN RECYCLED CELL
+ SETZM 1(B)
+ JRST CPOPJ1 ;THAT IT
+
+
+\f;FUNCTION TO BUILD A LIST OF MANY ELEMENTS
+
+IMFUNCTION LIST,SUBR
+ ENTRY
+
+ PUSH P,$TLIST
+LIST12: HLRE A,AB ;GET -NUM OF ARGS
+ PUSH TP,$TAB
+ PUSH TP,AB
+ MOVNS A ;MAKE IT +
+ JUMPE A,LISTN ;JUMP IF 0
+ SKIPE RCL ;SEE IF WE WANT TO DO ONE AT A TIME
+ JRST LST12R ;TO GET RECYCLED CELLS
+ PUSHJ P,CELL ;GET NUMBER OF CELLS
+ PUSH TP,(P) ;SAVE IT
+ PUSH TP,B
+ SUB P,C%11
+ LSH A,-1 ;NUMBER OF REAL LIST ELEMENTS
+
+CHAINL: ADDI B,2 ;LOOP TO CHAIN ELEMENTS
+ HRRZM B,-2(B) ;CHAIN LAST ONE TO NEXT ONE
+ SOJG A,.-2 ;LOOP TIL ALL DONE
+ CLEARM B,-2(B) ;SET THE LAST CDR TO NIL
+
+; NOW LOBEER THE DATA IN TO THE LIST
+
+ MOVE D,AB ; COPY OF ARG POINTER
+ MOVE B,(TP) ;RESTORE LIS POINTER
+LISTLP: GETYP A,(D) ;GET TYPE
+ PUSHJ P,NWORDT ;GET NUMBER OF WORDS
+ SOJN A,LDEFER ;NEED TO DEFER POINTER
+ GETYP A,(D) ;NOW CLOBBER ELEMENTS
+ HRLM A,(B)
+ MOVE A,1(D) ;AND VALUE..
+ MOVEM A,1(B)
+LISTL2: HRRZ B,(B) ;REST B
+ ADD D,C%22 ;STEP ARGS
+ JUMPL D,LISTLP
+
+ POP TP,B
+ POP TP,A
+ SUB TP,C%22 ; CLEANUP STACK
+ JRST FINIS
+
+
+LST12R: ASH A,-1 ;ONE AT A TIME TO GET RECYCLED CELLS
+ JUMPE A,LISTN
+ PUSH P,A ;SAVE COUNT ON STACK
+ SETZM E
+ SETZB C,D
+ PUSHJ P,ICONS
+ MOVE E,B ;LOOP AND CHAIN TOGETHER
+ SOSLE (P)
+ JRST .-4
+ PUSH TP,-1(P) ;PUSH ON THE TYPE WE WANT
+ PUSH TP,B
+ SUB P,C%22 ;CLEAN UP AFTER OURSELVES
+ JRST LISTLP-2 ;AND REJOIN MAIN STREAM
+
+
+; MAKE A DEFERRED POINTER
+
+LDEFER: PUSH TP,$TLIST ;SAVE CURRENT POINTER
+ PUSH TP,B
+ MOVEM D,1(TB) ; SAVE ARG HACKER
+ PUSHJ P,CELL2
+ MOVE D,1(TB)
+ GETYPF A,(D) ;GET FULL DATA
+ MOVE C,1(D)
+ MOVEM A,(B)
+ MOVEM C,1(B)
+ MOVE C,(TP) ;RESTORE LIST POINTER
+ MOVEM B,1(C) ;AND MAKE THIS BE THE VALUE
+ MOVSI A,TDEFER
+ HLLM A,(C) ;AND STORE IT
+ MOVE B,C
+ SUB TP,C%22
+ JRST LISTL2
+
+LISTN: MOVEI B,0
+ POP P,A
+ JRST FINIS
+
+; BUILD A FORM
+
+IMFUNCTION FORM,SUBR
+
+ ENTRY
+
+ PUSH P,$TFORM
+ JRST LIST12
+
+\f; COMPILERS CALLS TO FORM AND LIST A/ COUNT ELEMENTS ON STACK
+
+IILIST: SUBM M,(P)
+ PUSHJ P,IILST
+ MOVSI A,TLIST
+ JRST MPOPJ
+
+IIFORM: SUBM M,(P)
+ PUSHJ P,IILST
+ MOVSI A,TFORM
+ JRST MPOPJ
+
+IILST: JUMPE A,IILST0 ; NIL WHATSIT
+ PUSH P,A
+ MOVEI E,0
+IILST1: POP TP,D
+ POP TP,C
+ PUSHJ P,ICONS ; CONS 'EM UP
+ MOVEI E,(B)
+ SOSE (P) ; COUNT
+ JRST IILST1
+
+ SUB P,C%11
+ POPJ P,
+
+IILST0: MOVEI B,0
+ POPJ P,
+
+\f;FUNCTION TO BUILD AN IMPLICIT LIST
+
+MFUNCTION ILIST,SUBR
+ ENTRY
+ PUSH P,$TLIST
+ILIST2: JUMPGE AB,TFA ;NEED AT LEAST ONE ARG
+ CAMGE AB,C%M40 ; [-4,,0] ; NO MORE THAN TWO ARGS
+ JRST TMA
+ PUSHJ P,GETFIX ; GET POS FIX #
+ JUMPE A,LISTN ;EMPTY LIST ?
+ CAML AB,C%M20 ; [-2,,0] ;ONLY ONE ARG?
+ JRST LOSEL ;YES
+ PUSH P,A ;SAVE THE CURRENT VALUE OF LENGTH FOR LOOP ITERATION
+ILIST0: PUSH TP,2(AB)
+ PUSH TP,(AB)3
+ MCALL 1,EVAL
+ PUSH TP,A
+ PUSH TP,B
+ SOSLE (P)
+ JRST ILIST0
+ POP P,C
+ILIST1: MOVE C,(AB)+1 ;REGOBBLE LENGTH
+ ACALL C,LIST
+ILIST3: POP P,A ; GET FINAL TYPE
+ JRST FINIS
+
+
+LOSEL: PUSH P,A ; SAVE COUNT
+ MOVEI E,0
+
+LOSEL1: SETZB C,D ; TLOSE,,0
+ PUSHJ P,ICONS
+ MOVEI E,(B)
+ SOSLE (P)
+ JRST LOSEL1
+
+ SUB P,C%11
+ JRST ILIST3
+
+; IMPLICIT FORM
+
+MFUNCTION IFORM,SUBR
+
+ ENTRY
+ PUSH P,$TFORM
+ JRST ILIST2
+
+\f; IVECTOR AND IUVECTOR--GET VECTOR AND UVECTOR OF COMPUTED VALUES
+
+MFUNCTION VECTOR,SUBR,[IVECTOR]
+
+ MOVEI C,1
+ JRST VECTO3
+
+MFUNCTION UVECTOR,SUBR,[IUVECTOR]
+
+ MOVEI C,0
+VECTO3: ENTRY
+ JUMPGE AB,TFA ; AT LEAST ONE ARG
+ CAMGE AB,C%M40 ; [-4,,0] ; NOT MORE THAN 2
+ JRST TMA
+ PUSHJ P,GETFIX ; GET A POS FIXED NUMBER
+ LSH A,(C) ; A-> NUMBER OF WORDS
+ PUSH P,C ; SAVE FOR LATER
+ PUSHJ P,IBLOCK ; GET BLOCK (TURN ON BIT APPROPRIATELY)
+ POP P,C
+ HLRE A,B ; START TO
+ SUBM B,A ; FIND DOPE WORD
+ MOVSI D,.VECT. ; FOR GCHACK
+ IORM D,(A)
+ JUMPE C,VECTO4
+ MOVSI D,400000 ; GET NOT UNIFORM BIT
+ IORM D,(A) ; INTO DOPE WORD
+ SKIPA A,$TVEC ; GET TYPE
+VECTO4: MOVSI A,TUVEC
+ CAML AB,C%M20 ; [-2,,0] ; SKIP IF ARGS NEED TO BE HACKED
+ JRST FINIS
+ JUMPGE B,FINIS ; DON'T EVAL FOR EMPTY CASE
+
+ PUSH TP,A ; SAVE THE VECTOR
+ PUSH TP,B
+ PUSH TP,A
+ PUSH TP,B
+
+ JUMPE C,UINIT
+ JUMPGE B,FINIS ; EMPTY VECTOR, LEAVE
+INLP: PUSHJ P,IEVAL ; EVAL EXPR
+ MOVEM A,(C)
+ MOVEM B,1(C)
+ ADD C,C%22 ; BUMP VECTOR
+ MOVEM C,(TP)
+ JUMPL C,INLP ; IF MORE DO IT
+
+GETVEC: MOVE A,-3(TP)
+ MOVE B,-2(TP)
+ SUB TP,C%44 ; [4,,4]
+ JRST FINIS
+
+; HERE TO FILL UP A UVECTOR
+
+UINIT: PUSHJ P,IEVAL ; HACK THE 1ST VALUE
+ GETYP A,A ; GET TYPE
+ PUSH P,A ; SAVE TYPE
+ PUSHJ P,NWORDT ; SEE IF IT CAN BE UNIFORMED
+ SOJN A,CANTUN ; COMPLAIN
+STJOIN: MOVE C,(TP) ; RESTORE POINTER
+ ADD C,1(AB) ; POINT TO DOPE WORD
+ MOVE A,(P) ; GET TYPE
+ HRLZM A,(C) ; STORE IN D.W.
+ MOVSI D,.VECT. ; FOR GCHACK
+ IORM D,(C)
+ MOVE C,(TP) ; GET BACK VECTOR
+ SKIPE 1(AB)
+ JRST UINLP1 ; START FILLING UV
+ JRST GETVE1
+
+UINLP: MOVEM C,(TP) ; SAVE PNTR
+ PUSHJ P,IEVAL ; EVAL THE EXPR
+ GETYP A,A ; GET EVALED TYPE
+ CAIE A,@(P) ; WINNER?
+ JRST WRNGSU ; SERVICE ERROR FOR UVECTOR,STORAGE
+UINLP1: MOVEM B,(C) ; STORE
+ AOBJN C,UINLP
+GETVE1: SUB P,C%11
+ JRST GETVEC ; AND RETURN VECTOR
+
+IEVAL: PUSH TP,2(AB)
+ PUSH TP,3(AB)
+ MCALL 1,EVAL
+ MOVE C,(TP)
+ POPJ P,
+
+; ISTORAGE -- GET STORAGE OF COMPUTED VALUES
+
+MFUNCTION ISTORAGE,SUBR
+ ENTRY
+ JUMPGE AB,TFA
+ CAMGE AB,C%M40 ; [-4,,0] ; AT LEAST ONE ARG
+ JRST TMA
+ PUSHJ P,GETFIX ; POSITIVE COUNT FIRST ARG
+ PUSHJ P,CAFRE ; GET CORE
+ MOVN B,1(AB) ; -COUNT
+ HRL A,B ; PUT IN LHW (A)
+ MOVM B,B ; +COUNT
+ HRLI B,2(B) ; LENGTH + 2
+ ADDI B,(A) ; MAKE POINTER TO DOPE WORDS
+ HLLZM B,1(B) ; PUT TOTAL LENGTH IN 2ND DOPE
+ HRRM A,1(B) ; PUT ADDRESS IN RHW (STORE DOES THIS TOO).
+ MOVE B,A
+ MOVSI A,TSTORAGE
+ CAML AB,C%M20 ; [-2,,0] ; SECOND ARG TO EVAL?
+ JRST FINIS ; IF NOT, RETURN EMPTY
+ PUSH TP,A
+ PUSH TP,B
+ PUSH TP,A
+ PUSH TP,B
+ PUSHJ P,IEVAL ; EVALUATE FOR FIRST VALUE
+ GETYP A,A
+ PUSH P,A ; FOR COMPARISON LATER
+ PUSHJ P,SAT
+ CAIN A,S1WORD
+ JRST STJOIN ;TREAT LIKE A UVECTOR
+; IF NOT 1-WORD TYPES, CANNOT STORE, SO COMPLAIN
+ PUSHJ P,FREESV ; FREE STORAGE VECTOR
+ ERRUUO EQUOTE DATA-CANT-GO-IN-STORAGE
+
+; FOR STORAGE, MUST FREE THE CORE ELSE IT IS LOST (NO GC)
+FREESV: MOVE A,1(AB) ; GET COUNT
+ ADDI A,2 ; FOR DOPE
+ HRRZ B,(TP) ; GET ADDRESS
+ PUSHJ P,CAFRET ; FREE THE CORE
+ POPJ P,
+
+\f
+; INTERNAL VECTOR ALLOCATOR. A/SIZE OF VECTOR (NOT INCLUDING DOPE WORDS)
+
+IBLOK1: ASH A,1 ; TIMES 2
+GIBLOK: TLOA A,400000 ; FUNNY BIT
+IBLOCK: TLZ A,400000 ; NO BIT ON
+ TLO A,.VECT. ; TURN ON BIT FOR GCHACK
+ ADDI A,2 ; COMPENSATE FOR DOPE WORDS
+IBLOK2: SKIPE B,RCLV ; ANY TO RECYCLE?
+ JRST RCLVEC
+NORCL: MOVE B,GCSTOP ; POINT TO BOTTOM OF SPACE
+ PUSH P,B ; SAVE TO BUILD PTR
+ ADDI B,(A) ; ADD NEEDED AMOUNT
+ CAML B,FRETOP ; SKIP IF NO GC NEEDED
+ JRST IVECT1
+ MOVEM B,GCSTOP ; WIN, GET POINTER TO BLOCK AND UPDATE VECBOT
+ ADDM A,USEFRE
+ HRRZS USEFRE
+ HRLZM A,-1(B) ; STORE LENGTH IN DOPE WORD
+ HLLZM A,-2(B) ; AND BIT
+ HRRM B,-1(B) ; SMASH IN RELOCATION
+ SOS -1(B)
+ POP P,B ; RESTORE PTR TO BOTTOM OF VECTOR
+ HRROS B ; POINT TO START OF VECTOR
+ TLC B,-3(A) ; SETUP COUNT
+ HRRI A,TVEC
+ SKIPL A
+ HRRI A,TUVEC
+ MOVSI A,(A)
+ POPJ P,
+
+; HERE TO DO A GC ON A VECTOR ALLOCATION
+
+IVECT1: PUSH P,0
+ PUSH P,A ; SAVE DESIRED LENGTH
+ HRRZ 0,A
+ ADDM 0,GETNUM ; AND STORE AS DESIRED AMOUNT
+ MOVE C,[4,,1] ; GET INDICATOR FOR AGC
+ PUSHJ P,INQAGC
+ POP P,A
+ POP P,0
+ POP P,B
+ JRST IBLOK2
+
+
+; INTERNAL EVECTOR (CALLED FROM READ) A/ #OF THINGS
+; ITEMS ON TOP OF STACK
+
+IEVECT: ASH A,1 ; TO NUMBER OF WORDS
+ PUSH P,A
+ PUSHJ P,IBLOCK ; GET VECTOR
+ HLRE D,B ; FIND DW
+ SUBM B,D ; A POINTS TO DW
+ MOVSI 0,400000+.VECT.
+ MOVEM 0,(D) ; CLOBBER NON UNIF BIT
+ POP P,A ; RESTORE COUNT
+ JUMPE A,IVEC1 ; 0 LNTH, DONE
+ MOVEI C,(TP) ; BUILD BLT
+ SUBI C,(A)-1 ; C POINTS TO 1ST ITEM ON STACK
+ MOVSI C,(C)
+ HRRI C,(B) ; B/ SOURCE,,DEST
+ BLT C,-1(D) ; XFER THE DATA
+ HRLI A,(A)
+ SUB TP,A ; FLUSH STACKAGE
+IVEC1: MOVSI A,TVEC
+ POPJ P,
+
+
+; COMPILERS CALL
+
+CIVEC: SUBM M,(P)
+ PUSHJ P,IEVECT
+ JRST MPOPJ
+
+
+\f; INTERNAL CALL TO EUVECTOR
+
+IEUVEC: PUSH P,A ; SAVE LENGTH
+ PUSHJ P,IBLOCK
+ MOVE A,(P)
+ JUMPE A,IEUVE1 ; EMPTY, LEAVE
+ ASH A,1 ; NOW FIND STACK POSITION
+ MOVEI C,(TP) ; POINT TO TOP
+ MOVE D,B ; COPY VEC POINTER
+ SUBI C,-1(A) ; POINT TO 1ST DATUM
+ GETYP A,(C) ; CHECK IT
+ PUSHJ P,NWORDT
+ SOJN A,CANTUN ; WONT FIT
+ GETYP E,(C)
+
+IEUVE2: GETYP 0,(C) ; TYPE OF EL
+ CAIE 0,(E) ; MATCH?
+ JRST WRNGUT
+ MOVE 0,1(C)
+ MOVEM 0,(D) ; CLOBBER
+ ADDI C,2
+ AOBJN D,IEUVE2 ; LOOP
+ TRO E,.VECT.
+ HRLZM E,(D) ; STORE UTYPE
+IEUVE1: POP P,A ; GET COUNY
+ ASH A,1 ; MUST FLUSH 2 TIMES # OF ELEMENTS
+ HRLI A,(A)
+ SUB TP,A ; CLEAN UP STACK
+ MOVSI A,TUVEC
+ POPJ P,
+
+; COMPILER'S CALL
+
+CIUVEC: SUBM M,(P)
+ PUSHJ P,IEUVEC
+ JRST MPOPJ
+
+IMFUNCTION EVECTOR,SUBR,[VECTOR]
+ ENTRY
+ HLRE A,AB
+ MOVNS A
+ PUSH P,A ;SAVE NUMBER OF WORDS
+ PUSHJ P,IBLOCK ; GET WORDS
+ MOVEI D,-1(B) ; SETUP FOR BLT AND DOPE CLOBBER
+ JUMPGE B,FINISV ;DONT COPY A ZERO LENGTH VECTOR
+
+ HRLI C,(AB) ;START BUILDING BLT POINTER
+ HRRI C,(B) ;TO ADDRESS
+ ADDI D,@(P) ;SET D TO FINAL ADDRESS
+ BLT C,(D)
+FINISV: MOVSI 0,400000+.VECT.
+ MOVEM 0,1(D) ; MARK AS GENERAL
+ SUB P,C%11
+ MOVSI A,TVEC
+ JRST FINIS
+
+
+
+\f;EXPLICIT VECTORS FOR THE UNIFORM CSE
+
+IMFUNCTION EUVECTOR,SUBR,[UVECTOR]
+
+ ENTRY
+ HLRE A,AB ;-NUM OF ARGS
+ MOVNS A
+ ASH A,-1 ;NEED HALF AS MANY WORDS
+ PUSH P,A
+ JUMPGE AB,EUV1 ; DONT CHECK FOR EMPTY
+ GETYP A,(AB) ;GET FIRST ARG
+ PUSHJ P,NWORDT ;SEE IF NEEDS EXTRA WORDS
+ SOJN A,CANTUN
+EUV1: POP P,A
+ PUSHJ P,IBLOCK ; GET VECT
+ JUMPGE B,FINISU
+
+ GETYP C,(AB) ;GET THE FIRST TYPE
+ MOVE D,AB ;COPY THE ARG POINTER
+ MOVE E,B ;COPY OF RESULT
+
+EUVLP: GETYP 0,(D) ;GET A TYPE
+ CAIE 0,(C) ;SAME?
+ JRST WRNGUT ;NO , LOSE
+ MOVE 0,1(D) ;GET GOODIE
+ MOVEM 0,(E) ;CLOBBER
+ ADD D,C%22 ;BUMP ARGS POINTER
+ AOBJN E,EUVLP
+
+ TRO C,.VECT.
+ HRLM C,(E) ;CLOBBER UNIFORM TYPE IN
+FINISU: MOVSI A,TUVEC
+ JRST FINIS
+
+WRNGSU: GETYP A,-1(TP)
+ CAIE A,TSTORAGE
+ JRST WRNGUT ;IF UVECTOR
+ PUSHJ P,FREESV ;FREE STORAGE VECTOR
+ ERRUUO EQUOTE TYPES-DIFFER-IN-STORAGE-OBJECT
+
+WRNGUT: ERRUUO EQUOTE TYPES-DIFFER-IN-UNIFORM-VECTOR
+
+CANTUN: ERRUUO EQUOTE DATA-CANT-GO-IN-UNIFORM-VECTOR
+
+BADNUM: ERRUUO EQUOTE NEGATIVE-ARGUMENT
+\f; FUNCTION TO GROW A VECTOR
+REPEAT 0,[
+MFUNCTION GROW,SUBR
+
+ ENTRY 3
+
+ MOVEI D,0 ;STACK HACKING FLAG
+ GETYP A,(AB) ;FIRST TYPE
+ PUSHJ P,SAT ;GET STORAGE TYPE
+ GETYP B,2(AB) ;2ND ARG
+ CAIE A,STPSTK ;IS IT ASTACK
+ CAIN A,SPSTK
+ AOJA D,GRSTCK ;YES, WIN
+ CAIE A,SNWORD ;UNIFORM VECTOR
+ CAIN A,S2NWORD ;OR GENERAL
+GRSTCK: CAIE B,TFIX ;IS 2ND FIXED
+ JRST WTYP2 ;COMPLAIN
+ GETYP B,4(AB)
+ CAIE B,TFIX ;3RD ARG
+ JRST WTYP3 ;LOSE
+
+ MOVEI E,1 ;UNIFORM/GENERAL FLAG
+ CAIE A,SNWORD ;SKIP IF UNIFORM
+ CAIN A,SPSTK ;DONT SKIP IF UNIFORM PDL
+ MOVEI E,0
+
+ HRRZ B,1(AB) ;POINT TO START
+ HLRE A,1(AB) ;GET -LENGTH
+ SUB B,A ;POINT TO DOPE WORD
+ SKIPE D ;SKIP IF NOT STACK
+ ADDI B,PDLBUF ;FUDGE FOR PDL
+ HLLZS (B) ;ZERO OUT GROWTH SPECS
+ SKIPN A,3(AB) ;ANY TOP GROWTH?
+ JRST GROW1 ;NO, LOOK FOR BOTTOM GROWTH
+ ASH A,(E) ;MULT BY 2 IF GENERAL
+ ADDI A,77 ;ROUND TO NEAREST BLOCK
+ ANDCMI A,77 ;CLEAR LOW ORDER BITS
+ ASH A,9-6 ;DIVIDE BY 100 AND SHIFT TO POSTION
+ TRZE A,400000 ;CONVERT TO SIGN MAGNITUDE
+ MOVNS A
+ TLNE A,-1 ;SKIP IF NOT TOO BIG
+ JRST GTOBIG ;ERROR
+GROW1: SKIPN C,5(AB) ;CHECK LOW GROWTH
+ JRST GROW4 ;NONE, SKIP
+ ASH C,(E) ;GENRAL FUDGE
+ ADDI C,77 ;ROUND
+ ANDCMI C,77 ;FUDGE FOR VALUE RETURN
+ PUSH P,C ;AND SAVE
+ ASH C,-6 ;DIVIDE BY 100
+ TRZE C,400 ;CONVERT TO SIGN MAGNITUDE
+ MOVNS C
+ TDNE C,[-1,,777000] ;CHECK FOR OVERFLOW
+ JRST GTOBIG
+GROW2: HLRZ E,1(B) ;GET TOTAL LENGTH OF VECTOR
+ MOVNI E,-1(E)
+ HRLI E,(E) ;TO BOTH HALVES
+ ADDI E,1(B) ;POINTS TO TOP
+ SKIPE D ;STACK?
+ ADD E,[PDLBUF,,0] ;YES, FUDGE LENGTH
+ SKIPL D,(P) ;SHRINKAGE?
+ JRST GROW3 ;NO, CONTINUE
+ MOVNS D ;PLUSIFY
+ HRLI D,(D) ;TO BOTH HALVES
+ ADD E,D ;POINT TO NEW LOW ADDR
+GROW3: IORI A,(C) ;OR TOGETHER
+ HRRM A,(B) ;DEPOSIT INTO DOPEWORD
+ PUSH TP,(AB) ;PUSH TYPE
+ PUSH TP,E ;AND VALUE
+ SKIPE A ;DON'T GC FOR NOTHING
+ MOVE C,[2,,0] ; GET INDICATOR FOR AGC
+ PUSHJ P,AGC
+ JUMPL A,GROFUL
+ POP P,C ;RESTORE GROWTH
+ HRLI C,(C)
+ POP TP,B ;GET VECTOR POINTER
+ SUB B,C ;POINT TO NEW TOP
+ POP TP,A
+ JRST FINIS
+
+GROFUL: SUB P,C%11 ; CLEAN UP STACK
+ SUB TP,C%22
+ PUSHJ P,FULLOS
+ JRST GROW
+
+GTOBIG: ERRUUO EQUOTE ATTEMPT-TO-GROW-VECTOR-TOO-MUCH
+GROW4: PUSH P,[0] ;0 BOTTOM GROWTH
+ JRST GROW2
+]
+FULLOS: ERRUUO EQUOTE NO-STORAGE
+
+
+\f; SUBROUTINE TO BUILD CHARACTER STRING GOODIES
+
+MFUNCTION BYTES,SUBR
+
+ ENTRY
+ MOVEI D,1
+ JUMPGE AB,TFA
+ GETYP 0,(AB)
+ CAIE 0,TFIX
+ JRST WTYP1
+ MOVE E,1(AB)
+ ADD AB,C%22
+ JRST STRNG1
+
+IMFUNCTION STRING,SUBR
+
+ ENTRY
+
+ MOVEI D,0
+ MOVEI E,7
+STRNG1: MOVE B,AB ;COPY ARG POINTER
+ MOVEI C,0 ;INITIALIZE COUNTER
+ PUSH TP,$TAB ;SAVE A COPY
+ PUSH TP,B
+ HLRE A,B ; GET # OF ARGS
+ MOVNS A
+ ASH A,-1 ; 1/2 FOR # OF ARGS
+ PUSHJ P,IISTRN
+ JRST FINIS
+
+IISTRN: PUSH P,E
+ JUMPL E,OUTRNG
+ CAILE E,36.
+ JRST OUTRNG
+ SKIPN E,A ; SKIP IF ARGS EXIST
+ JRST MAKSTR ; ALL DONE
+
+STRIN2: GETYP 0,(B) ;GET TYPE CODE
+ CAMN 0,SING(D) ; SINGLE CHARACTER OR FIX?
+ AOJA C,STRIN1
+ CAME 0,MULTI(D) ; OR STRING OR BYTE-STRING
+ JRST WRONGT ;NEITHER
+ HRRZ 0,(B) ; GET CHAR COUNT
+ ADD C,0 ; AND BUMP
+
+STRIN1: ADD B,C%22
+ SOJG A,STRIN2
+
+; NOW GET THE NECESSARY VECTOR
+
+MAKSTR: HRL C,MULTI(D) ; FINAL TYPE,, CHAR COUNT
+ PUSH P,C ; SAVE CHAR COUNT
+ PUSH P,E ; SAVE ARG COUNT
+ MOVEI D,36.
+ IDIV D,-2(P) ; A==> BYTES PER WORD
+ MOVEI A,(C) ; LNTH+4 TO A
+ ADDI A,-1(D)
+ IDIVI A,(D)
+ LSH E,12.
+ MOVE D,-2(P)
+ DPB D,[060600,,E]
+ HRLM E,-2(P) ; SAVE REMAINDER
+ PUSHJ P,IBLOCK
+
+ POP P,A
+ JUMPGE B,DONEC ; 0 LENGTH, NO STRING
+ HRLI B,440000 ;CONVERT B TO A BYTE POINTER
+ HRRZ 0,-1(P) ; BYTE SIZE
+ DPB 0,[300600,,B]
+ MOVE C,(TP) ; POINT TO ARGS AGAIN
+
+NXTRG1: GETYP D,(C) ;GET AN ARG
+ CAIN D,TFIX
+ JRST .+3
+ CAIE D,TCHRS
+ JRST TRYSTR
+ MOVE D,1(C) ; GET IT
+ IDPB D,B ;AND DEPOSIT IT
+ JRST NXTARG
+
+TRYSTR: MOVE E,1(C) ;GET BYTER
+ HRRZ 0,(C) ;AND COUNT
+NXTCHR: SOJL 0,NXTARG ; IF RUNOUT, GET NEXT ARG
+ ILDB D,E ;AND GET NEXT
+ IDPB D,B ; AND DEPOSIT SAME
+ JRST NXTCHR
+
+NXTARG: ADD C,C%22 ;BUMP ARG POINTER
+ SOJG A,NXTRG1
+ ADDI B,1
+
+DONEC: MOVSI C,TCHRS+.VECT.
+ TLO B,400000
+ HLLM C,(B) ;AND CLOBBER AWAY
+ HLRZ C,1(B) ;GET LENGTH BACK
+ POP P,A
+ SUBI B,-1(C)
+ HLL B,(P) ;MAKE A BYTE POINTER
+ SUB P,C%11
+ POPJ P,
+
+SING: TCHRS
+ TFIX
+
+MULTI: TCHSTR
+ TBYTE
+
+
+; COMPILER'S CALL TO MAKE A STRING
+
+CISTNG: TDZA D,D
+
+; COMPILERS CALL TO MAKE A BYTE STRING
+
+CBYTES: MOVEI D,1
+ SUBM M,(P)
+ MOVEI C,0 ; INIT CHAR COUNTER
+ MOVEI B,(A) ; SET UP STACK POINTER
+ ASH B,1 ; * 2 FOR NO. OF SLOTS
+ HRLI B,(B)
+ SUBM TP,B ; B POINTS TO ARGS
+ PUSH P,D
+ MOVEI E,7
+ JUMPE D,CBYST
+ GETYP 0,1(B) ; CHECK BYTE SIZE
+ CAIE 0,TFIX
+ JRST WRONGT
+ MOVE E,2(B)
+ ADD B,C%22
+ SUBI A,1
+CBYST: ADD B,C%11
+ PUSH TP,$TTP
+ PUSH TP,B
+ PUSHJ P,IISTRN ; MAKE IT HAPPEN
+ MOVE TP,(TP) ; FLUSH ARGS
+ SUB TP,C%11
+ POP P,D
+ JUMPE D,MPOPJ
+ SUB TP,C%22
+ JRST MPOPJ
+
+\f;BUILD IMPLICT STRING
+
+MFUNCTION IBYTES,SUBR
+
+ ENTRY
+
+ CAML AB,C%M20 ; [-3,,] ; AT LEAST 2
+ JRST TFA
+ CAMGE AB,C%M60 ; [-7,,] ; NO MORE THAN 3
+ JRST TMA
+ PUSHJ P,GETFIX ; GET BYTE SIZE
+ JUMPL A,OUTRNG
+ CAILE A,36.
+ JRST OUTRNG
+ PUSH P,[TFIX]
+ PUSH P,A
+ PUSH P,$TBYTE
+ ADD AB,C%22
+ MOVEM AB,ABSAV(TB)
+ JRST ISTR1
+
+MFUNCTION ISTRING,SUBR
+
+ ENTRY
+ JUMPGE AB,TFA ; TOO FEW ARGS
+ CAMGE AB,C%M40 ; [-4,,0] ; VERIFY NOT TOO MANY ARGS
+ JRST TMA
+ PUSH P,[TCHRS]
+ PUSH P,[7]
+ PUSH P,$TCHSTR
+ISTR1: PUSHJ P,GETFIX
+ MOVEI C,36.
+ IDIV C,-1(P)
+ ADDI A,-1(C)
+ IDIVI A,(C) ; # OF WORDS NEEDED TO A
+ ASH D,12.
+ MOVE C,-1(P) ; GET BYTE SIZE
+ DPB C,[060600,,D]
+ PUSH P,D
+ PUSHJ P,IBLOCK
+ HLRE C,B ; -LENGTH TO C
+ SUBM B,C ; LOCN OF DOPE WORD TO C
+ HRLI D,TCHRS+.VECT. ; CLOBBER ITS TYPE
+ HLLM D,(C)
+ MOVE A,-1(P)
+ HRR A,1(AB) ; SETUP TYPE'S RH
+ SUBI B,1
+ HRL B,(P) ; AND BYTE POINTER
+ SUB P,C%33
+ SKIPE (AB)+1 ; SKIP IF NO CHARACTERS TO DEPOSIT
+ CAML AB,C%M20 ; [-2,,0] ; SKIP IF 2 ARGS GIVEN
+ JRST FINIS
+ PUSH TP,A ;SAVE OUR STRING
+ PUSH TP,B
+ PUSH TP,A ;SAVE A TEMPORARY CLOBBER POINTER
+ PUSH TP,B
+ PUSH P,(AB)1 ;SAVE COUNT
+ PUSH TP,(AB)+2
+ PUSH TP,(AB)+3
+CLOBST: PUSH TP,-1(TP)
+ PUSH TP,-1(TP)
+ MCALL 1,EVAL
+ GETYP C,A ; CHECK IT
+ CAME C,-1(P) ; MUST BE A CHARACTER
+ JRST WTYP2
+ IDPB B,-2(TP) ;CLOBBER
+ SOSLE (P) ;FINISHED?
+ JRST CLOBST ;NO
+ SUB P,C%22
+ SUB TP,C%66
+ MOVE A,(TP)+1
+ MOVE B,(TP)+2
+ JRST FINIS
+
+\f
+; HERE TO CHECK TO SEE WHETHER PURE RSUBR'S ARE MAPPED BELOW FRETOP AND
+; PUNT SOME IF THERE ARE.
+
+INQAGC: PUSH P,C
+ PUSH P,B
+ PUSH P,A
+ PUSH P,E
+ PUSHJ P,SQKIL
+ JSP E,CKPUR ; CHECK FOR PURE RSUBR
+ POP P,E
+ MOVE A,PURTOP
+ SUB A,CURPLN
+ MOVE B,RFRETP ; GET REAL FRETOP
+ CAIL B,(A)
+ MOVE B,A ; TOP OF WORLD
+ MOVE A,GCSTOP
+ ADD A,GETNUM
+ ADDI A,1777 ; PAGE BOUNDARY
+ ANDCMI A,1777
+ CAIL A,(B) ; SEE WHETHER THERE IS ROOM
+ JRST GOTOGC
+ PUSHJ P,CLEANT
+ POP P,A
+ POP P,B
+ POP P,C
+ POPJ P,
+GOTOGC: POP P,A
+ POP P,B
+ POP P,C ; RESTORE CAUSE INDICATOR
+ MOVE A,P.TOP
+ PUSHJ P,CLEANT ; CLEAN UP
+ SKIPL PLODR ; IF IN PLOAD DON'T INTERRUPT
+ JRST INTAGC ; GO CAUSE GARBAGE COLLECT
+ JRST SAGC
+
+CLEANT: PUSH P,C
+ PUSH P,A
+ SUB A,P.TOP
+ ASH A,-PGSZ
+ JUMPE A,CLNT1
+ PUSHJ P,GETPAG ; GET THOSE PAGES
+ FATAL CAN'T GET PAGES NEEDED
+ MOVE A,(P)
+ ASH A,-10. ; TO PAGES
+ PUSHJ P,P.CORE
+ PUSHJ P,SLEEPR
+CLNT1: PUSHJ P,RBLDM
+ POP P,A
+ POP P,C
+ POPJ P,
+
+\f; RCLVEC DISTASTEFUL VECTOR RECYCLER
+
+; Arrive here with B pointing to first recycler, A desired length
+
+RCLVEC: PUSH P,D ; Save registers
+ PUSH P,C
+ PUSH P,E
+ MOVEI D,RCLV ; Point to previous recycle for splice
+RCLV1: HLRZ C,(B) ; Get size of this block
+ CAIL C,(A) ; Skip if too small
+ JRST FOUND1
+
+RCLV2: MOVEI D,(B) ; Save previous pointer
+ HRRZ B,(B) ; Point to next block
+ JUMPN B,RCLV1 ; Jump if more blocks
+
+ POP P,E
+ POP P,C
+ POP P,D
+ JRST NORCL ; Go to normal allocator
+
+
+FOUND1: CAIN C,1(A) ; Exactly 1 greater?
+ JRST RCLV2 ; Cant use this guy
+
+ HRLM A,(B) ; Smash in new count
+ TLO A,.VECT. ; make vector bit be on
+ HLLM A,-1(B)
+ CAIE C,(A) ; Exactly right length?
+ JRST FOUND2 ; No, do hair
+
+ HRRZ C,(B) ; Point to next block
+ HRRM C,(D) ; Smash previous pointer
+ HRRM B,(B)
+ SUBI B,-1(A) ; Point to top of block
+ JRST FOUND3
+
+FOUND2: SUBI C,(A) ; Amount of left over to C
+ HRRZ E,(B) ; Point to next block
+ HRRM B,(B)
+ SUBI B,(A) ; Point to dope words of guy to put back
+ MOVSM C,(B) ; Smash in count
+ MOVSI C,.VECT. ; Get vector bit
+ MOVEM C,-1(B) ; Make sure it is a vector
+ HRRM B,(D) ; Splice him in
+ HRRM E,(B) ; And the next guy also
+ ADDI B,1 ; Point to start of vector
+
+FOUND3: HRROI B,(B) ; Make an AOBJN pointer
+ TLC B,-3(A)
+ HRRI A,TVEC
+ SKIPGE A
+ HRRI A,TUVEC
+ MOVSI A,(A)
+ POP P,E
+ POP P,C
+ POP P,D
+ POPJ P,
+
+END
+\f
\ No newline at end of file
--- /dev/null
+
+ TITLE STRBUILD MUDDLE STRUCTURE BUILDER
+
+.GLOBAL RCL,VECTOP,GCSTOP,GCSBOT,FRETOP,GCSNEW,VECBOT,PARTOP,PARBOT,HITOP,HIBOT,GETPAG
+.GLOBAL PDLBUF,PDLEX,PDLEXP,GCFLG,GCPDL,GETNUM,PARNEW,MOVPUR,RCLV,RCLVEC
+.GLOBAL PGROW,TPGROW,MAINPR,%SLEEP,MSGTYP,PURTOP,PURBOT,STOSTR,RBLDM,CPOPJ,CPOPJ1,STBL
+.GLOBAL MTYI,UPLO,FRMUNG,BYTDOP,GLOBSP,FREDIF,FREMIN,GCHAPN,INTFLG,PINIT,CKPUR,GCSET
+.GLOBAL SAT,TTOCHN,TYPVEC,ICONS,INCONS,IBLOCK,IEUVEC,IEVECTI,CELL2,MKTBS,CPOPJ1,.LIST.
+.GLOBAL GIBLOK,REHASH,IBLOK1,IILIST,IIFORM,CIVEC,CIUVEC,CICONS,SLEEPR,GCHK10,FPAG
+.GLOBAL SPBASE,OUTRNG,CISTNG,CBYTES,%RUNAM,PURVEC,GCDOWN,N.CHNS,CHNL1,PLODR,C1CONS
+.GLOBAL CAFRE,CAFRET,STOGC,GCHN,WNDP,FRNP,FRONT,%GCJOB,%SHWND,%INFMP,%GETIP
+.GLOBAL TD.PUT,TD.GET,TD.LNT,GLOTOP,UBIT,FLGSET,PURMNG,RPURBT,%IFMP2,CHKPGI,PURCLN
+.GLOBAL CTIME,MTYO,ILOC,NODES,GPURFL,GCDANG,GCHACK,LPUR,HITOP,BADCHN,IMPURX
+.GLOBAL NOWLVL,CURPLN,PVSTOR,SPSTOR,MPOPJ,NGCS,RNUMSP,NUMSWP,SAGC,INQAGC
+.GLOBAL GCTIM,GCCAUS,GCCALL,AAGC,LVLINC,STORIC,GVLINC,TYPIC,GCRSET,ACCESS,NOSHUF,SQUPNT
+; GLOBALS ASSOCIATE WITH THE ASSOCIATION VECTOR
+
+.GLOBAL ASOVEC,ASOLNT,ITEM,INDIC,VAL,NWORDT,NODPNT,PNTRS
+.GLOBAL CELL,BINDID,GCFLCH,TYPBOT,GLOBAS,TPBASE
+.GLOBAL TPBINC,GBLINC,TYPINC,CONADJ,OGCSTP,ABOTN
+.GLOBAL AGC,ROOT,CIGTPR,IIGLOC
+.GLOBAL P.TOP,P.CORE,PMAPB
+.GLOBAL %MPINT,%GBINT,%CLSMP,%CLSM1
+.GLOBAL GCKNUM,CORTOP,GCHPN,INTAGC,WNDP,WNDBOT,BUFGC,WIND,GCDFLG,SAVM
+
+; SHARED SYMBOLS WITH GC MODULE
+
+.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,PMIN,PURMIN
+.GLOBAL GLBINC,GCHAIR,GCMONF,SQKIL,INBLOT
+.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
+
+NOPAGS==1 ; NUMBER OF WINDOWS
+EOFBIT==1000
+PDLBUF=100
+
+.ATOM.==200000 ; FLAG SAYING ATOMS MARKED (FOR VAL FLUSH LOGIC)
+
+GCHN==0 ; CHANNEL FOR FUNNNY INFERIOR
+STATNO==19. ; # OF STATISTICS FOR BLOAT-STAT
+STATGC==8. ; # OF GC-STATISTICS FOR BLOAT-STAT
+
+
+RELOCATABLE
+.INSRT MUDDLE >
+SYSQ
+IFE ITS,[
+.INSRT STENEX >
+]
+IFN ITS, PGSZ==10.
+IFE ITS, PGSZ==9.
+
+
+\f; GC-READ TAKES ONE ARGUMENT WHICH MUST BE A "READB" CHANNEL
+
+.GLOBAL CLOOKU,CINSER,MOBLIST,CATOM,EOFCND,IGLOC
+
+MFUNCTION GCREAD,SUBR,[GC-READ]
+
+ ENTRY
+
+ CAML AB,C%M2 ; CHECK # OF ARGS
+ JRST TFA
+ CAMGE AB,C%M40
+ JRST TMA
+
+ GETYP A,(AB) ; MAKE SURE ARG IS A CHANNEL
+ CAIE A,TCHAN
+ JRST WTYP2 ; IT ISN'T COMPLAIN
+ MOVE B,1(AB) ; GET PTR TO CHANNEL
+ HRRZ C,-2(B) ; LOOK AT BITS IN CHANNEL
+ TRC C,C.OPN+C.READ+C.BIN
+ TRNE C,C.OPN+C.READ+C.BIN
+ JRST BADCHN
+
+ PUSH P,1(B) ; SAVE ITS CHANNEL #
+IFN ITS,[
+ MOVE B,[-2,,C] ; SET UP AOBJN PTR TO READ IN DELIMITING
+ ; CONSTANTS
+ MOVE A,(P) ; GET CHANNEL #
+ DOTCAL IOT,[A,B]
+ FATAL GCREAD-- IOT FAILED
+ JUMPL B,EOFGC ; IF BLOCK DIDN'T FINISH THEN EOF
+]
+IFE ITS,[
+ MOVE A,(P) ; GET CHANNEL
+ BIN
+ MOVE C,B ; TO C
+ BIN
+ MOVE D,B ; TO D
+ GTSTS ; SEE IF EOF
+ TLNE B,EOFBIT
+ JRST EOFGC
+]
+
+ PUSH P,C ; SAVE AC'S
+ PUSH P,D
+
+IFN ITS,[
+ MOVE B,[-3,,C] ; NEXT GROUP OF WORDS
+ DOTCAL IOT,[A,B]
+ FATAL GCREAD--GC IOT FAILED
+]
+IFE ITS,[
+ MOVE A,-2(P) ; GET CHANNEL
+ BIN
+ MOVE C,B
+ BIN
+ MOVE D,B
+ BIN
+ MOVE E,B
+]
+ MOVEI 0,0 ; DO PRELIMINARY TESTS
+ IOR 0,A ; IOR ALL WORDS IN
+ IOR 0,B
+ IOR 0,C
+ IOR 0,(P)
+ IOR 0,-1(P)
+ TLNE 0,-1 ; SKIP IF NO BITS IN LEFT HALF
+ JRST ERDGC
+
+ MOVEM D,NNPRI
+ MOVEM E,NNSAT
+ MOVE D,C ; GET START OF NEWTYPE TABLE
+ SUB D,-1(P) ; CREATE AOBJN POINTER
+ HRLZS D
+ ADDI D,(C)
+ MOVEM D,TYPTAB ; SAVE IT
+ MOVE A,(P) ; GET LENGTH OF WORD
+ SUBI A,CONADJ ; SUBTRACT FOR CONSTANTS
+
+ ADD A,GCSTOP
+ CAMG A,FRETOP ; SEE IF GC IS NESESSARY
+ JRST RDGC1
+ MOVE C,(P)
+ ADDM C,GETNUM ; MOVE IN REQUEST
+ MOVE C,[0,,1] ; ARGS TO GC
+ PUSHJ P,AGC ; GC
+RDGC1: MOVE C,GCSTOP ; GET CURRENT TOP OF THE WORLD
+ MOVEM C,OGCSTP ; SAVE IT
+ ADD C,(P) ; CALCULATE NEW GCSTOP
+ ADDI C,2 ; SUBTRACT FOR CONSTANTS
+ MOVEM C,GCSTOP
+ SUB C,OGCSTP
+ SUBI C,2 ; SUBSTRACT TO GET RID OF D.W'S
+ MOVNS C ; SET UP AOBJN PTR FOR READIN
+IFN ITS,[
+ HRLZS C
+ MOVE A,-2(P) ; GET CHANNEL #
+ ADD C,OGCSTP
+ DOTCAL IOT,[A,C]
+ FATAL GCREAD-- IOT FAILED
+]
+IFE ITS,[
+ MOVE A,-2(P) ; CHANNEL TO A
+ MOVE B,OGCSTP ; SET UP BYTE POINTER
+ HRLI B,444400
+ SIN ; IN IT COMES
+]
+
+ MOVE C,(P) ; GET LENGHT OF OBJECT
+ ADDI A,5
+ MOVE B,1(AB) ; GET CHANNEL
+ ADDM C,ACCESS(B)
+ MOVE D,GCSTOP ; SET UP TO LOOK LIKE UVECTOR OF LOSES
+ ADDI C,2 ; ADD 2 FOR DOPE WORDS
+ HRLM C,-1(D)
+ MOVSI A,.VECT.
+ SETZM -2(D)
+ IORM A,-2(D) ; MARK VECTOR BIT
+ PUSH TP,$TRDTB ; HOLD ON IN CASE OF GC
+ MOVEI A,-2(D)
+ MOVN C,(P)
+ ADD A,C
+ HRL A,C
+ PUSH TP,A
+
+ MOVE D,-1(P) ; SET UP BOTTOM OF ATOM TABLE
+ SUBI D,1
+ MOVEM D,ABOTN
+ MOVE C,GCSTOP ; START AT TOP OF WORLD
+ SUBI C,3 ; POINT TO FIRST ATOM
+
+; LOOP TO FIX UP THE ATOMS
+
+AFXLP: HRRZ 0,1(TB)
+ ADD 0,ABOTN
+ CAMG C,0 ; SEE IF WE ARE DONE
+ JRST SWEEIN
+ HRRZ 0,1(TB)
+ SUB C,0
+ PUSHJ P,ATFXU ; FIX IT UP
+ HLRZ A,(C) ; GET LENGTH
+ TRZ A,400000 ; TURN OFF MARK BIT
+ SUBI C,(A) ; POINT TO PRECEDING ATOM
+ HRRZS C ; CLEAR OFF NEGATIVE
+ JRST AFXLP
+
+; FIXUP ROUTINE FOR ATOMS (C==> D.W.)
+
+ATFXU: PUSH P,C ; SAVE PTR TO D.W.
+ ADD C,1(TB)
+ MOVE A,C
+ HLRZ B,(A) ; GET LENGTH AND MARKING
+ TRZE B,400000 ; TURN OF MARK BIT AND SKIP IF WAS ALREADY MARKED
+ JRST ATFXU1
+ MOVEI D,-3(B) ; FULL WORDS OF STRING IN PNAME
+ IMULI D,5 ; CALCULATE # OF CHARACTERS
+ MOVE 0,-2(A) ; GET LAST WORD OF STRING
+ SUBI A,-1(B) ; LET A POINT TO OBLIST SLOAT
+ MOVE B,A ; GET COPY OF A
+ MOVE A,0
+ SUBI A,1
+ ANDCM 0,A
+ JFFO 0,.+1
+ HRREI 0,-34.(A)
+ IDIVI 0,7 ; # OF CHARS IN LAST WORD
+ ADD D,0
+ ADD D,$TCHSTR ; MAKE IT LOOK LIKE A STRINGS TYPE-WORD
+ PUSH P,D ; SAVE IT
+ MOVE C,(B) ; GET OBLIST SLOT PTR
+ATFXU9: HRRZS B ; RELATAVIZE POINTER
+ HRRZ 0,1(TB)
+ SUB B,0
+ PUSH P,B
+ JUMPE C,ATFXU6 ; NO OBLIST. CREATE ATOM
+ CAMN C,C%M1 ; SEE IF ROOT ATOM
+ JRST RTFX
+ ADD C,ABOTN ; POINT TO ATOM
+ PUSHJ P,ATFXU
+ PUSH TP,$TATOM
+ PUSH TP,B
+ MOVE A,$TATOM ; SET UP TO SEE IF OBLIST EXITS
+ MOVE C,$TATOM
+ MOVE D,IMQUOTE OBLIST
+ PUSHJ P,CIGTPR
+ JRST ATFXU8 ; NO OBLIST. CREATE ONE
+ SUB TP,C%22 ; GET RID OF SAVED ATOM
+RTCON: PUSH TP,$TOBLS
+ PUSH TP,B
+ MOVE C,B ; SET UP FOR LOOKUP
+ MOVE A,-1(P) ; SET UP PTR TO PNAME
+ MOVE B,(P)
+ ADD B,[440700,,1] ; ADJUST TO MAKE IT LOOK LIKE A BYTE-POINTER
+ HRRZ 0,1(TB)
+ ADD B,0
+ PUSHJ P,CLOOKU
+ JRST ATFXU4 ; NOT ON IT SO INSERT
+ATFXU3: SUB P,C%22 ; DONE
+ SUB TP,C%22 ; POP OFF OBLIST
+ATFXU7: MOVE C,(P) ; RESTORE PTR TO D.W.
+ ADD C,1(TB)
+ MOVEM B,-1(C) ; MOVE IN RELATAVIZE ADDRESS
+ MOVSI D,400000
+ IORM D,(C) ; TURN OFF MARK BIT
+ MOVE 0,3(B) ; SEE IF MUST BE LOCR
+ TRNE 0,1 ; SKIP IF MUST MAKE IT IMPURE
+ PUSHJ P,IIGLOC
+ POP P,C
+ ADD C,1(TB)
+ POPJ P, ; EXIT
+ATFXU1: POP P,C ; RESTORE PTR TO D.W.
+ ADD C,1(TB)
+ MOVE B,-1(C) ; GET ATOM
+ POPJ P,
+
+; ROUTINE TO INSERT AN ATOM
+
+ATFXU4: MOVE C,(TP) ; GET OBLIST PTR
+ MOVE B,(P) ; SET UP STRING PTR TO PNAME
+ ADD B,[440700,,1]
+ HRRZ 0,1(TB)
+ ADD B,0
+ MOVE A,-1(P) ; GET TYPE WORD
+ PUSHJ P,CINSER ; INSERT IT
+ JRST ATFXU3
+
+; THIS ROUTINE CREATS THE ATOM SO THAT ITS NOT ON ANY OBLIST
+
+ATFXU6: MOVE B,(P) ; POINT TO PNAME
+ ADD B,[440700,,1] ; MAKE IT LOOK LIKE A BYTE POINTER
+ HRRZ 0,1(TB)
+ ADD B,0
+ MOVE A,-1(P)
+ PUSHJ P,CATOM
+ SUB P,C%22 ; CLEAN OFF STACK
+ JRST ATFXU7
+
+; THIS ROUTINE CREATES AND OBLIST
+
+ATFXU8: MCALL 1,MOBLIST
+ PUSH TP,$TOBLS
+ PUSH TP,B ; SAVE OBLIST PTR
+ JRST ATFXU4 ; JUMP TO INSERT THE OBLIST
+
+; HERE TO INSERT AN ATOM INTO THE ROOT OBLIST
+
+RTFX: MOVE B,ROOT+1 ; GET ROOT OBLIST
+ JRST RTCON
+
+; THIS ROUTINE SWEEPS THRU THE NEW CORE IMAGE AND UPDATES ALL THE POINTERS.
+
+SWEEIN:
+; ROUTINE TO FIX UP TYPE-TABLE FOR GC-READ. THIS ROUTINE FIXES UP THE TYPE TABLE SO THAT
+; THE TYPES ATOM I.D. IS REPLACED BY ITS TYPE-NUMBER IN THE NEW MUDDLE AND IF ITS A
+; TEMPLATE, THE SLOT FOR THE PRIMTYPE-ATOM IS REPLACED BY THE SAT OF THE TEMPLATE
+
+ HRRZ E,1(TB) ; SET UP TYPE TABLE
+ ADD E,TYPTAB
+ JUMPGE E,VUP ; SKIP OVER IF DONE
+TYPUP1: PUSH P,C%0 ; PUSH SLOT FOR POSSIBLE TEMPLATE ATOM
+ HLRZ A,1(E) ; GET POSSIBLE ATOM SLOT
+ JUMPE A,TYPUP2 ; JUMP IF NOT A TEMPLATE
+ ADD A,ABOTN ; GET ATOM
+ ADD A,1(TB)
+ MOVE A,-1(A)
+ MOVE B,TYPVEC+1 ; GET TYPE VECTOR SLOT FOR LOOP TO SEE IF ITS THERE
+TYPUP3: CAMN A,1(B) ; SKIP IF NOT EQUAL
+ JRST TYPUP4 ; FOUND ONE
+ ADD B,C%22 ; TO NEXT
+ JUMPL B,TYPUP3
+ JRST ERTYP1 ; ERROR NONE EXISTS
+TYPUP4: HRRZ C,(B) ; GET SAT SLOT
+ CAIG C,NUMSAT ; MAKE SURE TYPE IS A TEMPLATE
+ JRST ERTYP2 ; IF NOT COMPLAIN
+ HRLM C,1(E) ; SMASH IN NEW SAT
+ MOVE B,1(B) ; GET ATOM OF PRIMTYPE
+ MOVEM B,(P) ; PUSH ONTO STACK
+TYPUP2: MOVEI D,0 ; INITIALIZE TYPE COUNT FOR LOOKUP LOOP
+ MOVE B,TYPVEC+1 ; GET PTR FOR LOOP
+ HRRZ A,1(E) ; GET TYPE'S ATOM ID
+ ADD A,ABOTN ; GET ATOM
+ ADD A,1(TB)
+ MOVE A,-1(A)
+TYPUP5: CAMN A,1(B) ; SKIP IF NOT EQUAL
+ JRST TYPUP6 ; FOUND ONE
+ ADDI D,1 ; INCREMENT TYPE-COUNT
+ ADD B,C%22 ; POINT TO NEXT
+ JUMPL B,TYPUP5
+ HRRM D,1(E) ; CLOBBER IN TYPE-NUMBER
+ PUSH TP,$TATOM ; PUSH ARGS FOR NEWTYPE
+ PUSH TP,A
+ PUSH TP,$TATOM
+ POP P,B ; GET BACK POSSIBLE PRIMTYPE ATOM
+ JUMPE B,TYPUP7 ; JUMP IF NOT A TEMPLATE
+ PUSH TP,B ; PUSH ON PRIMTYPE
+TYPUP9: SUB E,1(TB)
+ PUSH P,E ; SAVE RELATAVIZED PTR TO TYPE-TABLE
+ MCALL 2,NEWTYPE
+ POP P,E ; RESTORE RELATAVIZED PTR
+ ADD E,1(TB) ; FIX IT UP
+TYPUP0: ADD E,C%22 ; INCREMENT E
+ JUMPL E,TYPUP1
+ JRST VUP
+TYPUP7: HRRZ B,(E) ; FIND PRIMTYPE FROM SAT
+ MOVE A,@STBL(B)
+ PUSH TP,A
+ JRST TYPUP9
+TYPUP6: HRRM D,1(E) ; CLOBBER IN TYPE #
+ JRST TYPUP0
+
+ERTYP1: ERRUUO EQUOTE CANT-FIND-TEMPLATE
+
+ERTYP2: ERRUUO EQUOTE TEMPLATE-TYPE-NAME-NOT-OF-TYPE-TEMPLATE
+
+VUP: HRRZ E,1(TB) ; FIX UP SOME POINTERS
+ MOVEM E,OGCSTP
+ ADDM E,ABOTN
+ ADDM E,TYPTAB
+
+
+; ROUTINE TO SWEEP THRU THE READ-IN IMAGE LOOKING FOR UVECTORS AND TEMPLATES.
+; WHILE SWEEPING IT FIXES UP THE DOPE WORDS APPROPRIATELY.
+
+ HRRZ A,TYPTAB ; GET TO TOP OF WORLD
+ SUBI A,2 ; GET TO FIRST TYPE WORD OR DOPE-WORD OF FIRST OBJECT
+VUP1: CAMG A,OGCSTP ; SKIP IF NOT DONE
+ JRST VUP3
+ HLRZ B,(A) ; GET TYPE SLOT
+ TRNE B,.VECT. ; SKIP IF NOT A VECTOR
+ JRST VUP2
+ SUBI A,2 ; SKIP OVER PAIR
+ JRST VUP1
+VUP2: TRNE B,400000 ; SKIP IF UVECTOR
+ JRST VUP4
+ ANDI B,TYPMSK ; GET RID OF MONITORS
+ CAMG B,NNPRI ; SKIP IF NEWTYPE
+ JRST VUP5
+ PUSHJ P,GETNTP ; GET THE NEW TYPE #
+ PUTYP B,(A) ; SMASH IT IT
+VUP5: HLRZ B,1(A) ; SKIP OVER VECTOR
+ TRZ B,400000 ; GET RID OF POSSIBLE MARK BIT
+ SUBI A,(B)
+ JRST VUP1 ; LOOP
+VUP4: ANDI B,TYPMSK ; FLUSH MONITORS
+ CAMG B,NNSAT ; SKIP IF TEMPLATE
+ JRST VUP5
+ PUSHJ P,GETSAT ; CONVERT TO NEW SAT
+ ADDI B,.VECT. ; MAJIC TO TURN ON BIT
+ PUTYP B,(A)
+ JRST VUP5
+
+
+VUP3: PUSH P,GCSBOT ; SAVE CURRENT GCSBOT
+ MOVE A,OGCSTP ; SET UP NEW GCSBOT
+ MOVEM A,GCSBOT
+ PUSH P,GCSTOP
+ HRRZ A,TYPTAB ; SET UP NEW GCSTOP
+ MOVEM A,GCSTOP
+ SETOM GCDFLG
+ MOVE A,[PUSHJ P,RDFIX] ; INS FOR GCHACK
+ MOVEI PVP,0 ; SAY MIGHT BE NON-ATOMS
+ PUSHJ P,GCHK10
+ SETZM GCDFLG
+ POP P,GCSTOP ; RESTORE GCSTOP
+ MOVE A,1(TB) ; GET A POINTER TO RETURNING VALUES
+ MOVE B,A
+ HLRE C,B
+ SUB B,C
+ SETZM (B)
+ SETZM 1(B)
+ POP P,GCSBOT ; RESTORE GCSBOT
+ MOVE B,1(A) ; GET PTR TO OBJECTS
+ MOVE A,(A)
+ JRST FINIS ; EXIT
+
+; ERROR FOR INCORRECT GCREAD FILE
+
+ERDGC: ERRUUO EQUOTE BAD-GC-READ-FILE
+
+; ROUTINE CALLED BY GCHACK TO UPDATE PTRS IN THE NEW CORE IMAGE
+
+RDFIX: PUSH P,C ; SAVE C
+ PUSH P,B ; SAVE PTR
+ EXCH B,C
+ TLNE C,UBIT ; SKIP IF NOT UVECTOR
+ JRST ELEFX ; DON'T HACK TYPES IN UVECTOR
+ CAIN B,TTYPEC
+ JRST TYPCFX
+ CAIN B,TTYPEW
+ JRST TYPWFX
+ CAMLE B,NNPRI
+ JRST TYPGFX
+ELEFX: EXCH B,A ; EXCHANGE FOR SAT
+ PUSHJ P,SAT
+ EXCH B,A ; REFIX
+ CAIE B,SOFFS
+ JRST OFSFIX
+ CAIE B,SLOCR ; REL GLOC'S ARE STORED AS ATOMS
+ CAIN B,SATOM
+ JRST ATFX
+ CAIN B,SCHSTR
+ JRST STFX
+ CAIN B,S1WORD ; SEE IF PRIMTYPE WOR
+ JRST RDLSTF ; LEAVE IF IS
+STFXX: MOVE 0,GCSBOT ; ADJUSTMENT
+ SUBI 0,FPAG+5
+ SKIPE 1(C) ; DON'T CHANGE A PTR TO NIL
+ ADDM 0,1(C) ; FIX UP
+RDLSTF: TLNN C,.LIST. ; SEE IF PAIR
+ JRST RDL1 ; EXIT
+ MOVE 0,GCSBOT ; FIX UP
+ SUBI 0,FPAG+5
+ HRRZ B,(C) ; SEE IF POINTS TO NIL
+ SKIPN B
+ JRST RDL1
+ MOVE B,C ; GET ARG FOR RLISTQ
+ PUSHJ P,RLISTQ
+ JRST RDL1
+ ADDM 0,(C)
+RDL1: POP P,B ; RESTORE B
+ POP P,C
+ POPJ P,
+
+; FIXUP OFSSETS
+
+OFSFIX: HLRZ B,1(A) ; SEE IF PNTR TO FIXUP
+ JUMPE B,RDL1
+ MOVE 0,GCSBOT ; GET UPDATE AMOUNT
+ SUBI 0,FPAG+5
+ HRLZS 0
+ ADDM 0,1(A) ; FIX POINTER
+ JRST RDL1
+
+; ROUTINE TO FIX UP PNAMES
+
+STFX: TLZN D,STATM
+ JRST STFXX
+ HLLM D,1(C) ; PUT BACK WITH BIT OFF
+ ADD D,ABOTN
+ ANDI D,-1
+ HLRE 0,-1(D) ; LENGTH OF ATOM
+ MOVNS 0
+ SUBI 0,3 ; VAL & OBLIST
+ IMULI 0,5 ; TO CHARS (SORT OF)
+ HRRZ D,-1(D)
+ ADDI D,2
+ PUSH P,A
+ PUSH P,B
+ LDB A,[360600,,1(C)] ; GET BYTE POS
+ IDIVI A,7 ; TO CHAR POS
+ SKIPE A
+ SUBI A,5
+ HRRZ B,(C) ; STRING LENGTH
+ SUB B,A ; TO WORD BOUNDARY STRING
+ SUBI 0,(B)
+ IDIVI 0,5
+ ADD D,0
+ POP P,B
+ POP P,A
+ HRRM D,1(C)
+ JRST RDLSTF
+
+; ROUTINE TO FIX UP POINTERS TO ATOMS
+
+ATFX: SKIPGE D
+ JRST RDLSTF
+ ADD D,ABOTN
+ MOVE 0,-1(D) ; GET PTR TO ATOM
+ CAIE B,SLOCR ; IF REL LOCATIVE, MORE HAIR
+ JRST ATFXAT
+ MOVE B,0
+ PUSH P,E
+ PUSH P,D
+ PUSH P,C
+ PUSH P,B
+ PUSH P,A
+ PUSHJ P,IGLOC
+ SUB B,GLOTOP+1
+ MOVE 0,B
+ POP P,A
+ POP P,B
+ POP P,C
+ POP P,D
+ POP P,E
+ATFXAT: MOVEM 0,1(C) ; SMASH IT IN
+ JRST RDLSTF ; EXIT
+
+TYPCFX: HRRZ B,1(C) ; GET TYPE
+ PUSHJ P,GETNEW ; GET TYPE IN THIS CORE IMAGE
+ HRRM B,1(C) ; CLOBBER IT IN
+ JRST RDLSTF ; CONTINUE FIXUP
+
+TYPWFX: HLRZ B,1(C) ; GET TYPE
+ PUSHJ P,GETNEW ; GET TYPE IN THIS CORE IMAGE
+ HRLM B,1(C) ; SMASH IT IN
+ JRST ELEFX
+
+TYPGFX: PUSH P,D
+ PUSHJ P,GETNTP ; GET TYPE IN THIS CORE IMAGE
+ POP P,D
+ PUTYP B,(C)
+ JRST ELEFX
+
+; HERE TO HANDLE AN EOF IN GC-READ. IT USES OPTIONAL SECOND ARG IF SUPPLIED AS
+; EOF HANDLER ELSE USES CHANNELS.
+
+EOFGC: MOVE B,1(AB) ; GET CHANNEL INTO B
+ CAML AB,C%M20 ; [-2,,0] ; SKIP IF EOF ROUTINE IS SUPPLIED
+ JRST MYCLOS ; USE CHANNELS
+ PUSH TP,2(AB)
+ PUSH TP,3(AB)
+ JRST CLOSIT
+MYCLOS: PUSH TP,EOFCND-1(B)
+ PUSH TP,EOFCND(B)
+CLOSIT: PUSH TP,$TCHAN
+ PUSH TP,B
+ MCALL 1,FCLOSE ; CLOSE CHANNEL
+ MCALL 1,EVAL ; EVAL HIS EOF HANDLER
+ JRST FINIS
+
+; ROUTINE TO SUPPLY THE TYPE NUMBER FOR A NEWTYPE
+
+GETNEW: CAMG B,NNPRI ;NEWTYPE
+ POPJ P,
+GETNTP: MOVE D,TYPTAB ; GET AOBJN POINTER TO TYPE-TABLE
+GETNT1: HLRZ E,(D) ; GET TYPE #
+ CAIN E,(B) ; SKIP IF NOT EQUAL TO GOAL
+ JRST GOTTYP ; FOUND IT
+ ADD D,C%22 ; POINT TO NEXT
+ JUMPL D,GETNT1
+ SKIPA ; KEEP TYPE SAME
+GOTTYP: HRRZ B,1(D) ; GET NEW TYPE #
+ POPJ P,
+
+; ROUTINE TO SUPPLY THE SAT TO A TEMPLATE HACKER
+
+GETSAT: MOVE D,TYPTAB ; GET AOBJN PTR TO TYPE TABLE
+GETSA1: HRRZ E,(D) ; GET OBJECT
+ CAIN E,(B) ; SKIP IF NOT EQUAL TO GOAL
+ JRST GOTSAT ; FOUND IT
+ ADD D,C%22
+ JUMPL D,GETSA1
+ FATAL GC-DUMP -- TYPE FIXUP FAILURE
+GOTSAT: HLRZ B,1(D) ; GET NEW SAT
+ POPJ P,
+
+
+; A ROUTINE TO DISTINGUISH BETWEEN A DEFERRED AND A LIST POINTER
+RLISTQ: PUSH P,A
+ GETYP A,(B) ; GET TYPE
+ PUSHJ P,SAT ; GET SAT
+ CAIG A,NUMSAT ; NOT DEFERRED IF TEMPLATE
+ SKIPL MKTBS(A)
+ AOS -1(P) ; SKIP IF NOT DEFFERED
+ POP P,A
+ POPJ P, ; EXIT
+
+\f
+.GLOBAL FLIST
+
+MFUNCTION BLOATSTAT,SUBR,[BLOAT-STAT]
+
+ENTRY
+
+ JUMPGE AB,GETUVC ; SEE IF THERE IS AN ARGUMENT
+ GETYP A,(AB)
+ CAIE A,TUVEC ; SEE IF THE ARGUMENT IS A UVECTOR
+ JRST WTYP1 ; IF NOT COMPLAIN
+ HLRE 0,1(AB)
+ MOVNS 0
+ CAIE 0,STATNO+STATGC ; SEE IF UVECTOR IS RIGHT LENGTH
+ JRST WTYP1
+ CAMGE AB,C%M20 ; [-2,,0] ; SEE IF THERE ARE TOO MANY ARGUMENTS
+ JRST TMA
+ MOVE A,(AB) ; GET THE UVECTOR
+ MOVE B,1(AB)
+ JRST SETUV ; CONTINUE
+GETUVC: MOVEI A,STATNO+STATGC ; CREATE A UVECTOR
+ PUSHJ P,IBLOCK
+SETUV: PUSH P,A ; SAVE UVECTOR
+ PUSH P,B
+ MOVE 0,NOWFRE ; COMPUTE FREE STORAGE USED SINCE LAST BLOAT-STAT
+ SUB 0,RFRETP
+ ADD 0,GCSTOP
+ MOVEM 0,CURFRE
+ PUSHJ P,GCSET ; FIX UP BLOAT-STAT PARAMETERS
+ HLRE 0,TP ; COMPUTE STACK SPACE USED UP
+ ADD 0,NOWTP
+ SUBI 0,PDLBUF
+ MOVEM 0,CURTP
+ MOVE B,IMQUOTE THIS-PROCESS
+ PUSHJ P,ILOC
+ HRRZS B
+ MOVE PVP,PVSTOR+1
+ HRRZ C,TPBASE+1(PVP) ; CALCULATE # OF ATOM SLOTS
+ MOVE 0,B
+ HRRZ D,SPBASE+1(PVP) ; COMPUTE CURRENT # OF BINDINGS
+ SUB 0,D
+ IDIVI 0,6
+ MOVEM 0,CURLVL
+ SUB B,C ; TOTAL WORDS ATOM STORAGE
+ IDIVI B,6 ; COMPUTE # OF SLOTS
+ MOVEM B,NOWLVL
+ HRRZ A,GLOBASE+1 ; COMPUTE TOTAL # OF GLOBAL SLOTS
+ HLRE 0,GLOBASE+1
+ SUB A,0 ; POINT TO DOPE WORD
+ HLRZ B,1(A)
+ ASH B,-2 ; # OF GVAL SLOTS
+ MOVEM B,NOWGVL
+ HRRZ A,GLOTOP+1 ; COMPUTE # OF GVAL SLOTS IN USE
+ HRRZ 0,GLOBSP+1
+ SUB A,0
+ ASH A,-2 ; NEGATIVE # OF SLOTS USED
+ MOVEM A,CURGVL
+ HRRZ A,TYPBOT+1 ; GET LENGTH OF TYPE VECTOR
+ HLRE 0,TYPBOT+1
+ SUB A,0
+ HLRZ B,1(A) ; # OF WORDS IN TYPE-VECTOR
+ IDIVI B,2 ; CONVERT TO # OF TYPES
+ MOVEM B,NOWTYP
+ HLRE 0,TYPVEC+1 ; LENGTH OF VISABLE TYPE-VECTOR
+ MOVNS 0
+ IDIVI 0,2 ; GET # OF TYPES
+ MOVEM 0,CURTYP
+ MOVE 0,CODTOP ; GET LENGTH OF STATIONARY IMPURE STORAGE
+ MOVEM 0,NOWSTO
+ SETZB B,D ; ZERO OUT MAXIMUM
+ HRRZ C,FLIST
+LOOPC: HLRZ 0,(C) ; GET BLK LENGTH
+ ADD D,0 ; ADD # OF WORDS IN BLOCK
+ CAMGE B,0 ; SEE IF NEW MAXIMUM
+ MOVE B,0
+ HRRZ C,(C) ; POINT TO NEXT BLOCK
+ JUMPN C,LOOPC ; REPEAT
+ MOVEM D,CURSTO
+ MOVEM B,CURMAX
+ HLRE 0,P ; GET AMOUNT OF ROOM LEFT ON P
+ ADD 0,NOWP
+ SUBI 0,PDLBUF
+ MOVEM 0,CURP
+ MOVSI C,BSTGC ; SET UP BLT FOR GC FIGURES
+ HRRZ B,(P) ; RESTORE B
+ HRR C,B
+ BLT C,(B)STATGC-1
+ HRLI C,BSTAT ; MODIFY BLT FOR STATS
+ HRRI C,STATGC(B)
+ BLT C,(B)STATGC+STATNO-1
+ MOVEI 0,TFIX+.VECT.
+ HRLM 0,(B)STATNO+STATGC ; MOVE IN UTYPE
+ POP P,B
+ POP P,A ; RESTORE TYPE-WORD
+ JRST FINIS
+
+GCRSET: SETZM GCNO ; CALL FROM INIT, ZAP ALL 1ST
+ MOVE 0,[GCNO,,GCNO+1]
+ BLT 0,GCCALL
+ JRST GCSET
+
+
+
+\f
+.GLOBAL PGFIND,PGGIVE,PGTAKE,PGINT
+
+; USER GARBAGE COLLECTOR INTERFACE
+.GLOBAL ILVAL
+
+MFUNCTION GC,SUBR
+ ENTRY
+
+ JUMPGE AB,GC1
+ CAMGE AB,C%M60 ; [-6,,0]
+ JRST TMA
+ PUSHJ P,GETFIX ; GET FREEE MIN IF GIVEN
+ SKIPE A ; SKIP FOR 0 ARGUMENT
+ MOVEM A,FREMIN
+GC1: PUSHJ P,COMPRM ; GET CURRENT USED CORE
+ PUSH P,A
+ CAML AB,C%M40 ; [-4,,0] ; SEE IF 3RD ARG
+ JRST GC5
+ GETYP A,4(AB) ; MAKE SURE A FIX
+ CAIE A,TFIX
+ JRST WTYP ; ARG WRONG TYPE
+ MOVE A,5(AB)
+ MOVEM A,RNUMSP
+ MOVEM A,NUMSWP
+GC5: CAML AB,C%M20 ; [-2,,0] ; SEE IF SECOND ARG
+ JRST GC3
+ GETYP A,2(AB) ; SEE IF NONFALSE
+ CAIE A,TFALSE ; SKIP IF FALSE
+ JRST HAIRGC ; CAUSE A HAIRY GC
+GC3: MOVSI A,TATOM ; CHECK TO SEE IF INTERRUPT FLAG IS ON
+ MOVE B,IMQUOTE AGC-FLAG
+ PUSHJ P,ILVAL
+ CAMN A,$TUNBOUND ; SKIP IF NOT UNBOUND
+ JRST GC2
+ SKIPE GCHPN ; SKIP IF GCHAPPEN IS 0
+ JRST FALRTN ; JUMP TO RETURN FALSE
+GC2: MOVE C,[9.,,0]
+ PUSHJ P,AGC ; COLLECT THAT TRASH
+ PUSHJ P,COMPRM ; HOW MUCH ROOM NOW?
+ POP P,B ; RETURN AMOUNT
+ SUB B,A
+ MOVSI A,TFIX
+ JRST FINIS
+HAIRGC: MOVE B,3(AB)
+ CAIN A,TFIX ; IF FIX THEN CLOBBER NGCS
+ MOVEM B,NGCS
+ MOVEI A,1 ; FORCE VALUE FLUSHING PHASE TO OCCUR
+ MOVEM A,GCHAIR
+ JRST GC2 ; HAIRY GC OCCORS NO MATTER WHAT
+FALRTN: MOVE A,$TFALSE
+ MOVEI B,0 ; RETURN A FALSE-- FOR GC WHICH DIDN'T OCCOR
+ JRST FINIS
+
+
+COMPRM: MOVE A,GCSTOP ; USED SPACE
+ SUB A,GCSBOT
+ POPJ P,
+
+\f
+MFUNCTION GCDMON,SUBR,[GC-MON]
+
+ ENTRY
+
+ MOVEI E,GCMONF
+
+FLGSET: MOVE C,(E) ; GET CURRENT VALUE
+ JUMPGE AB,RETFLG ; RET CURRENT
+ CAMGE AB,C%M20 ; [-3,,]
+ JRST TMA
+ GETYP 0,(AB)
+ SETZM (E)
+ CAIN 0,TFALSE
+ SETOM (E)
+ SKIPL E
+ SETCMM (E)
+
+RETFLG: SKIPL E
+ SETCMM C
+ JUMPL C,NOFLG
+ MOVSI A,TATOM
+ MOVE B,IMQUOTE T
+ JRST FINIS
+
+NOFLG: MOVEI B,0
+ MOVSI A,TFALSE
+ JRST FINIS
+
+.GLOBAL EVATYP,APLTYP,PRNTYP
+
+\fMFUNCTION BLOAT,SUBR
+ ENTRY
+
+ PUSHJ P,SQKIL
+ MOVEI C,0 ; FLAG TO SAY WHETHER NEED A GC
+ MOVSI E,-NBLO ; AOBJN TO BLOATER TABLE
+
+BLOAT2: JUMPGE AB,BLOAT1 ; ALL DONE?
+ PUSHJ P,NXTFIX ; GET NEXT BLOAT PARAM
+ SKIPE A
+ PUSHJ P,@BLOATER(E) ; DISPATCH
+ AOBJN E,BLOAT2 ; COUNT PARAMS SET
+
+ JUMPL AB,TMA ; ANY LEFT...ERROR
+BLOAT1: JUMPE C,BLOATD ; DONE, NO GC NEEDED
+ MOVE C,E ; MOVE IN INDICATOR
+ HRLI C,1 ; INDICATE THAT IT COMES FROM BLOAT
+ SETOM INBLOT
+ PUSHJ P,AGC ; DO ONE
+ SKIPE A,TPBINC ; SMASH POINNTERS
+ MOVE PVP,PVSTOR+1
+ ADDM A,TPBASE+1(PVP)
+ SKIPE A,GLBINC ; GLOBAL SP
+ ADDM A,GLOBASE+1
+ SKIPE A,TYPINC
+ ADDM A,TYPBOT+1
+ SETZM TPBINC ; RESET PARAMS
+ SETZM GLBINC
+ SETZM TYPINC
+
+BLOATD: SKIPN A,GETNUM ; SKIP IF FREE STORAGE REQUEST IN EFFECT
+ JRST BLTFN
+ ADD A,FRETOP ; ADD FRETOP
+ ADDI A,1777 ; ONE BLOCK FOR MARK PDL AND ROUND
+ ANDCMI A,1777 ; TO PAGE BOUNDRY
+ CAML A,PURBOT ; SKIP IF POSSIBLE TO WIN
+ JRST BLFAGC
+ ASH A,-10. ; TO PAGES
+ PUSHJ P,P.CORE ; GRET THE CORE
+ JRST BLFAGC ; LOSE LOSE LOSE
+ MOVE A,FRETOP ; CALCULATE NEW PARAMETERS
+ MOVEM A,RFRETP
+ MOVEM A,CORTOP
+ MOVE B,GCSTOP
+ SETZM 1(B)
+ HRLI B,1(B)
+ HRRI B,2(B)
+ BLT B,-1(A) ; ZERO CORE
+BLTFN: SETZM GETNUM
+ MOVE B,FRETOP
+ SUB B,GCSTOP
+ MOVSI A,TFIX ; RETURN CORE FOUND
+ JRST FINIS
+BLFAGC: MOVN A,FREMIN
+ ADDM A,GETNUM ; FIX UP SO BLOATS CORRECTLY
+ MOVE C,C%11 ; INDICATOR FOR AGC
+ PUSHJ P,AGC ; GARBAGE COLLECT
+ JRST BLTFN ; EXIT
+
+; TABLE OF BLOAT ROUTINES
+
+BLOATER:
+ MAINB
+ TPBLO
+ LOBLO
+ GLBLO
+ TYBLO
+ STBLO
+ PBLO
+ SFREM
+ SLVL
+ SGVL
+ STYP
+ SSTO
+ PUMIN
+ PMUNG
+ TPMUNG
+ NBLO==.-BLOATER
+
+; BLOAT MAIN STORAGE AREA
+
+MAINB: SETZM GETNUM
+ MOVE D,FRETOP ; COMPUTE CURRENT ROOM
+ SUB D,PARTOP
+ CAMGE A,D ; NEED MORE?
+ POPJ P, ; NO, LEAVE
+ SUB A,D
+ MOVEM A,GETNUM ; SAVE
+ POPJ P,
+
+; BLOAT TP STACK (AT TOP)
+
+TPBLO: HLRE D,TP ; GET -SIZE
+ MOVNS B,D
+ ADDI D,1(TP) ; POINT TO DOPE (ALMOST)
+ CAME D,TPGROW ; BLOWN?
+ ADDI D,PDLBUF ; POINT TO REAL DOPE WORD
+ SUB A,B ; SKIP IF GROWTH NEEDED
+ JUMPLE A,CPOPJ
+ ADDI A,63.
+ ASH A,-6 ; CONVERT TO 64 WD BLOCKS
+ CAILE A,377
+ JRST OUTRNG
+ DPB A,[111100,,-1(D)] ; SMASH SPECS IN
+ AOJA C,CPOPJ
+
+; BLOAT TOP LEVEL LOCALS
+
+LOBLO: HLRE D,TP ; GET -SIZE
+ MOVNS B,D
+ ADDI D,1(TP) ; POINT TO DOPE (ALMOST)
+ CAME D,TPGROW ; BLOWN?
+ ADDI D,PDLBUF ; POINT TO REAL DOPE WORD
+ CAMG A,B ; SKIP IF GROWTH NEEDED
+ IMULI A,6 ; 6 WORDS PER BINDING
+ MOVE PVP,PVSTOR+1
+ HRRZ 0,TPBASE+1(PVP)
+ HRRZ B,SPBASE+1(PVP) ; ROOM AVAIL TO E
+ SUB B,0
+ SUBI A,(B) ; HOW MUCH MORE?
+ JUMPLE A,CPOPJ ; NONE NEEDED
+ MOVEI B,TPBINC
+ PUSHJ P,NUMADJ
+ DPB A,[1100,,-1(D)] ; SMASH
+ AOJA C,CPOPJ
+
+; GLOBAL SLOT GROWER
+
+GLBLO: ASH A,2 ; 4 WORDS PER VAR
+ MOVE D,GLOBASE+1 ; CURRENT LIMITS
+ HRRZ B,GLOBSP+1
+ SUBI B,(D)
+ SUBI A,(B) ; NEW AMOUNT NEEDED
+ JUMPLE A,CPOPJ
+ MOVEI B,GLBINC ; WHERE TO KEEP UPDATE
+ PUSHJ P,NUMADJ ; FIX NUMBER
+ HLRE 0,D
+ SUB D,0 ; POINT TO DOPE
+ DPB A,[1100,,(D)] ; AND SMASH
+ AOJA C,CPOPJ
+
+; HERE TO GROW TYPE VECTOR (AND FRIENDS)
+
+TYBLO: ASH A,1 ; TWO WORD PER TYPE
+ HRRZ B,TYPVEC+1 ; FIND CURRENT ROOM
+ MOVE D,TYPBOT+1
+ SUBI B,(D)
+ SUBI A,(B) ; EXTRA NEEDED TO A
+ JUMPLE A,CPOPJ ; NONE NEEDED, LEAVE
+ MOVEI B,TYPINC ; WHERE TO STASH SPEC
+ PUSHJ P,NUMADJ ; FIX NUMBER
+ HLRE 0,D ; POINT TO DOPE
+ SUB D,0
+ DPB A,[1100,,(D)]
+ SKIPE D,EVATYP+1 ; GROW AUX TYPE VECS IF NEEDED
+ PUSHJ P,SGROW1
+ SKIPE D,APLTYP+1
+ PUSHJ P,SGROW1
+ SKIPE D,PRNTYP+1
+ PUSHJ P,SGROW1
+ AOJA C,CPOPJ
+
+; HERE TO CREATE STORAGE SPACE
+
+STBLO: MOVE D,GCSBOT ; HOW MUCH NOW HERE
+ SUB D,CODTOP
+ SUBI A,(D) ; MORE NEEDED?
+ JUMPLE A,CPOPJ
+ MOVEM A,PARNEW ; FORCE PAIR SPACE TO MOVE ON OUT
+ AOJA C,CPOPJ
+
+; BLOAT P STACK
+
+PBLO: HLRE D,P
+ MOVNS B,D
+ SUBI D,5 ; FUDGE FOR THIS CALL
+ SUBI A,(D)
+ JUMPLE A,CPOPJ
+ ADDI B,1(P) ; POINT TO DOPE
+ CAME B,PGROW ; BLOWN?
+ ADDI B,PDLBUF ; NOPE, POIN TO REAL D.W.
+ ADDI A,63.
+ ASH A,-6 ; TO 64 WRD BLOCKS
+ CAILE A,377 ; IN RANGE?
+ JRST OUTRNG
+ DPB A,[111100,,-1(B)]
+ AOJA C,CPOPJ
+
+; SET FREMIN
+
+SFREM: SKIPE A ; DON'T ZERO EMPTY PARAMETER
+ MOVEM A,FREMIN
+ POPJ P,
+
+; SET LVAL INCREMENT
+
+SLVL: IMULI A,6 ; CALCULATE AMOUNT TO GROW B
+ MOVEI B,LVLINC
+ PUSHJ P,NUMADJ
+ MOVEM A,LVLINC
+ POPJ P,
+
+; SET GVAL INCREMENT
+
+SGVL: IMULI A,4. ; # OF SLOTS
+ MOVEI B,GVLINC
+ PUSHJ P,NUMADJ
+ MOVEM A,GVLINC
+ POPJ P,
+
+; SET TYPE INCREMENT
+
+STYP: IMULI A,2 ; CALCULATE NUMBER OF GROW BLOCKS NEEDED
+ MOVEI B,TYPIC
+ PUSHJ P,NUMADJ
+ MOVEM A,TYPIC
+ POPJ P,
+
+; SET STORAGE INCREMENT
+
+SSTO: IDIVI A,2000 ; # OF BLOCKS
+ CAIE B,0 ; REMAINDER?
+ ADDI A,1
+ IMULI A,2000 ; CONVERT BACK TO WORDS
+ MOVEM A,STORIC
+ POPJ P,
+; HERE FOR MINIMUM PURE SPACE
+
+PUMIN: ADDI A,1777
+ ANDCMI A,1777 ; TO PAGE BOUNDRY
+ MOVEM A,PURMIN
+ POPJ P,
+
+; HERE TO ADJUST PSTACK PARAMETERS IN GC
+
+PMUNG: ADDI A,777 ; TO NEAREST 1000 WORD BOUNDRY
+ ANDCMI A,777
+ MOVEM A,PGOOD ; PGOOD
+ ASH A,2 ; PMAX IS 4*PGOOD
+ MOVEM A,PMAX
+ ASH A,-4 ; PMIN IS .25*PGOOD
+ MOVEM A,PMIN
+
+; HERE TO ADJUST GC TPSTACK PARAMS
+
+TPMUNG: ADDI A,777
+ ANDCMI A,777 ; TO NEAREST 1000 WORD BOUNDRY
+ MOVEM A,TPGOOD
+ ASH A,2 ; TPMAX= 4*TPGOOD
+ MOVEM A,TPMAX
+ ASH A,-4 ; TPMIN= .25*TPGOOD
+ MOVEM A,TPMIN
+
+
+; GET NEXT (FIX) ARG
+
+NXTFIX: PUSHJ P,GETFIX
+ ADD AB,C%22
+ POPJ P,
+
+; ROUTINE TO GET POS FIXED ARG
+
+GETFIX: GETYP A,(AB)
+ CAIE A,TFIX
+ JRST WRONGT
+ SKIPGE A,1(AB)
+ JRST BADNUM
+ POPJ P,
+
+
+; GET NUMBERS FIXED UP FOR GROWTH FIELDS
+
+NUMADJ: ADDI A,77 ; ROUND UP
+ ANDCMI A,77 ; KILL CRAP
+ MOVE 0,A
+ MOVNS A ; COMPUTE ADD FACTOR FOR SPEC. POINTER UPDATE
+ HRLI A,-1(A)
+ MOVEM A,(B) ; AND STASH IT
+ MOVE A,0
+ ASH A,-6 ; TO 64 WD BLOCKS
+ CAILE A,377 ; CHECK FIT
+ JRST OUTRNG
+ POPJ P,
+
+; DO SYMPATHETIC GROWTHS
+
+SGROW1: HLRE 0,D
+ SUB D,0
+ DPB A,[111100,,(D)]
+ POPJ P,
+
+\f;FUNCTION TO CONSTRUCT A LIST
+
+MFUNCTION CONS,SUBR
+
+ ENTRY 2
+ GETYP A,2(AB) ;GET TYPE OF 2ND ARG
+ CAIE A,TLIST ;LIST?
+ JRST WTYP2 ;NO , COMPLAIN
+ MOVE C,(AB) ; GET THING TO CONS IN
+ MOVE D,1(AB)
+ HRRZ E,3(AB) ; AND LIST
+ PUSHJ P,ICONS ; INTERNAL CONS
+ JRST FINIS
+
+; COMPILER CALL TO CONS
+
+C1CONS: PUSHJ P,ICELL2
+ JRST ICONS2
+ICONS4: HRRI C,(E)
+ICONS3: MOVEM C,(B) ; AND STORE
+ MOVEM D,1(B)
+TLPOPJ: MOVSI A,TLIST
+ POPJ P,
+
+; INTERNAL CONS--ICONS; C,D VALUE, E CDR
+
+; RELATIVIZE RETURN ADDRESS HERE--MUST BE DIFFERENT FROM ICONS, SINCE
+; ICONS IS CALLED FROM INTERPRETER ENTRIES WHICH ARE THEMSELVES PUSHJ'ED
+; TO: DOING SUBM M,(P) ANYWHERE IN ICONS IS FATAL IF A GC OCCURS.
+
+CICONS: SUBM M,(P)
+ PUSHJ P,ICONS
+ JRST MPOPJ
+
+; INTERNAL CONS TO NIL--INCONS
+
+INCONS: MOVEI E,0
+
+ICONS: GETYP A,C ; CHECK TYPE OF VAL
+ PUSHJ P,NWORDT ; # OF WORDS
+ SOJN A,ICONS1 ; JUMP IF DEFERMENT NEEDED
+ PUSHJ P,ICELL2 ; NO DEFER, GET 2 WORDS FROM PAIR SPACE
+ JRST ICNS2A ; NO CORE, GO GC (SPECIAL PLACE, NOTICE)
+ JRST ICONS4
+
+; HERE IF CONSING DEFERRED
+
+ICONS1: MOVEI A,4 ; NEED 4 WORDS
+ PUSHJ P,ICELL ; GO GET 'EM
+ JRST ICNS2A ; NOT THERE, GC (SAME PLACE AS FOR ICONS)
+ HRLI E,TDEFER ; CDR AND DEFER
+ MOVEM E,(B) ; STORE
+ MOVEI E,2(B) ; POINT E TO VAL CELL
+ HRRZM E,1(B)
+ MOVEM C,(E) ; STORE VALUE
+ MOVEM D,1(E)
+ JRST TLPOPJ
+
+
+
+; HERE TO GC ON A CONS
+
+; HERE FROM C1CONS
+ICONS2: SUBM M,(P)
+ PUSHJ P,ICONSG
+ SUBM M,(P)
+ JRST C1CONS
+
+; HERE FROM ICONS (THUS CICONS, INDIRECTLY), ICONS1
+ICNS2A: PUSHJ P,ICONSG
+ JRST ICONS
+
+; REALLY DO GC
+ICONSG: PUSH TP,C ; SAVE VAL
+ PUSH TP,D
+ PUSH TP,$TLIST
+ PUSH TP,E ; SAVE VITAL STUFF
+ ADDM A,GETNUM ; AMOUNT NEEDED
+ MOVE C,[3,,1] ; INDICATOR FOR AGC
+ PUSHJ P,INQAGC ; ATTEMPT TO WIN
+ MOVE D,-2(TP) ; RESTORE VOLATILE STUFF
+ MOVE C,-3(TP)
+ MOVE E,(TP)
+ SUB TP,C%44 ; [4,,4]
+ POPJ P, ; BACK TO DRAWING BOARD
+
+; SUBROUTINE TO ALLOCATE WORDS IN PAIR SPACE. CALLS AGC IF NEEDED
+
+CELL2: MOVEI A,2 ; USUAL CASE
+CELL: PUSHJ P,ICELL ; INTERNAL
+ JRST .+2 ; LOSER
+ POPJ P,
+
+ ADDM A,GETNUM ; AMOUNT REQUIRED
+ PUSH P,A ; PREVENT AGC DESTRUCTION
+ MOVE C,[3,,1] ; INDICATOR FOR AGC
+ PUSHJ P,INQAGC
+ POP P,A
+ JRST CELL ; AND TRY AGAIN
+
+; INTERNAL CELL GETTER, SKIPS IF ROO EXISTS, ELSE DOESN'T
+
+ICELL2: MOVEI A,2 ; MOST LIKELY CAE
+ICELL: SKIPE B,RCL
+ JRST ICELRC ;SEE IF WE CAN RE-USE A RECYCLE CELL
+ MOVE B,PARTOP ; GET TOP OF PAIRS
+ ADDI B,(A) ; BUMP
+ CAMLE B,FRETOP ; SKIP IF OK.
+ JRST VECTRY ; LOSE
+ EXCH B,PARTOP ; SETUP NEW PARTOP AND RETURN POINTER
+ ADDM A,USEFRE
+ JRST CPOPJ1 ; SKIP RETURN
+
+; TRY RECYCLING USING A VECTOR FROM RCLV
+
+VECTRY: SKIPN B,RCLV ; SKIP IF VECTOR EXISTS
+ POPJ P,
+ PUSH P,C
+ PUSH P,A
+ MOVEI C,RCLV
+VECTR1: HLRZ A,(B) ; GET LENGTH
+ SUB A,(P)
+ JUMPL A,NXTVEC ; DOESN'T SATISFY TRY AGAIN
+ CAIN A,1 ; MAKE SURE NOT LEFT WITH A SINGLE SLOT
+ JRST NXTVEC
+ JUMPN A,SOML ; SOME ARE LEFT
+ HRRZ A,(B)
+ HRRM A,(C)
+ HLRZ A,(B)
+ SETZM (B)
+ SETZM -1(B) ; CLEAR DOPE WORDS
+ SUBI B,-1(A)
+ POP P,A ; CLEAR STACK
+ POP P,C
+ JRST CPOPJ1
+SOML: HRLM A,(B) ; SMASH AMOUNT LEFT
+ SUBI B,-1(A) ; GET TO BEGINNING
+ SUB B,(P)
+ POP P,A
+ POP P,C
+ JRST CPOPJ1
+NXTVEC: MOVEI C,(B)
+ HRRZ B,(B) ; GET NEXT
+ JUMPN B,VECTR1
+ POP P,A
+ POP P,C
+ POPJ P,
+
+ICELRC: CAIE A,2
+ JRST ICELL+2 ;IF HE DOESNT WANT TWO, USE OLD METHOD
+ PUSH P,A
+ MOVE A,(B)
+ HRRZM A,RCL
+ POP P,A
+ SETZM (B) ;GIVE HIM A CLEAN RECYCLED CELL
+ SETZM 1(B)
+ JRST CPOPJ1 ;THAT IT
+
+
+\f;FUNCTION TO BUILD A LIST OF MANY ELEMENTS
+
+IMFUNCTION LIST,SUBR
+ ENTRY
+
+ PUSH P,$TLIST
+LIST12: HLRE A,AB ;GET -NUM OF ARGS
+ PUSH TP,$TAB
+ PUSH TP,AB
+ MOVNS A ;MAKE IT +
+ JUMPE A,LISTN ;JUMP IF 0
+ SKIPE RCL ;SEE IF WE WANT TO DO ONE AT A TIME
+ JRST LST12R ;TO GET RECYCLED CELLS
+ PUSHJ P,CELL ;GET NUMBER OF CELLS
+ PUSH TP,(P) ;SAVE IT
+ PUSH TP,B
+ SUB P,C%11
+ LSH A,-1 ;NUMBER OF REAL LIST ELEMENTS
+
+CHAINL: ADDI B,2 ;LOOP TO CHAIN ELEMENTS
+ HRRZM B,-2(B) ;CHAIN LAST ONE TO NEXT ONE
+ SOJG A,.-2 ;LOOP TIL ALL DONE
+ CLEARM B,-2(B) ;SET THE LAST CDR TO NIL
+
+; NOW LOBEER THE DATA IN TO THE LIST
+
+ MOVE D,AB ; COPY OF ARG POINTER
+ MOVE B,(TP) ;RESTORE LIS POINTER
+LISTLP: GETYP A,(D) ;GET TYPE
+ PUSHJ P,NWORDT ;GET NUMBER OF WORDS
+ SOJN A,LDEFER ;NEED TO DEFER POINTER
+ GETYP A,(D) ;NOW CLOBBER ELEMENTS
+ HRLM A,(B)
+ MOVE A,1(D) ;AND VALUE..
+ MOVEM A,1(B)
+LISTL2: HRRZ B,(B) ;REST B
+ ADD D,C%22 ;STEP ARGS
+ JUMPL D,LISTLP
+
+ POP TP,B
+ POP TP,A
+ SUB TP,C%22 ; CLEANUP STACK
+ JRST FINIS
+
+
+LST12R: ASH A,-1 ;ONE AT A TIME TO GET RECYCLED CELLS
+ JUMPE A,LISTN
+ PUSH P,A ;SAVE COUNT ON STACK
+ SETZM E
+ SETZB C,D
+ PUSHJ P,ICONS
+ MOVE E,B ;LOOP AND CHAIN TOGETHER
+ SOSLE (P)
+ JRST .-4
+ PUSH TP,-1(P) ;PUSH ON THE TYPE WE WANT
+ PUSH TP,B
+ SUB P,C%22 ;CLEAN UP AFTER OURSELVES
+ JRST LISTLP-2 ;AND REJOIN MAIN STREAM
+
+
+; MAKE A DEFERRED POINTER
+
+LDEFER: PUSH TP,$TLIST ;SAVE CURRENT POINTER
+ PUSH TP,B
+ MOVEM D,1(TB) ; SAVE ARG HACKER
+ PUSHJ P,CELL2
+ MOVE D,1(TB)
+ GETYPF A,(D) ;GET FULL DATA
+ MOVE C,1(D)
+ MOVEM A,(B)
+ MOVEM C,1(B)
+ MOVE C,(TP) ;RESTORE LIST POINTER
+ MOVEM B,1(C) ;AND MAKE THIS BE THE VALUE
+ MOVSI A,TDEFER
+ HLLM A,(C) ;AND STORE IT
+ MOVE B,C
+ SUB TP,C%22
+ JRST LISTL2
+
+LISTN: MOVEI B,0
+ POP P,A
+ JRST FINIS
+
+; BUILD A FORM
+
+IMFUNCTION FORM,SUBR
+
+ ENTRY
+
+ PUSH P,$TFORM
+ JRST LIST12
+
+\f; COMPILERS CALLS TO FORM AND LIST A/ COUNT ELEMENTS ON STACK
+
+IILIST: SUBM M,(P)
+ PUSHJ P,IILST
+ MOVSI A,TLIST
+ JRST MPOPJ
+
+IIFORM: SUBM M,(P)
+ PUSHJ P,IILST
+ MOVSI A,TFORM
+ JRST MPOPJ
+
+IILST: JUMPE A,IILST0 ; NIL WHATSIT
+ PUSH P,A
+ MOVEI E,0
+IILST1: POP TP,D
+ POP TP,C
+ PUSHJ P,ICONS ; CONS 'EM UP
+ MOVEI E,(B)
+ SOSE (P) ; COUNT
+ JRST IILST1
+
+ SUB P,C%11
+ POPJ P,
+
+IILST0: MOVEI B,0
+ POPJ P,
+
+\f;FUNCTION TO BUILD AN IMPLICIT LIST
+
+MFUNCTION ILIST,SUBR
+ ENTRY
+ PUSH P,$TLIST
+ILIST2: JUMPGE AB,TFA ;NEED AT LEAST ONE ARG
+ CAMGE AB,C%M40 ; [-4,,0] ; NO MORE THAN TWO ARGS
+ JRST TMA
+ PUSHJ P,GETFIX ; GET POS FIX #
+ JUMPE A,LISTN ;EMPTY LIST ?
+ CAML AB,C%M20 ; [-2,,0] ;ONLY ONE ARG?
+ JRST LOSEL ;YES
+ PUSH P,A ;SAVE THE CURRENT VALUE OF LENGTH FOR LOOP ITERATION
+ILIST0: PUSH TP,2(AB)
+ PUSH TP,(AB)3
+ MCALL 1,EVAL
+ PUSH TP,A
+ PUSH TP,B
+ SOSLE (P)
+ JRST ILIST0
+ POP P,C
+ILIST1: MOVE C,(AB)+1 ;REGOBBLE LENGTH
+ ACALL C,LIST
+ILIST3: POP P,A ; GET FINAL TYPE
+ JRST FINIS
+
+
+LOSEL: PUSH P,A ; SAVE COUNT
+ MOVEI E,0
+
+LOSEL1: SETZB C,D ; TLOSE,,0
+ PUSHJ P,ICONS
+ MOVEI E,(B)
+ SOSLE (P)
+ JRST LOSEL1
+
+ SUB P,C%11
+ JRST ILIST3
+
+; IMPLICIT FORM
+
+MFUNCTION IFORM,SUBR
+
+ ENTRY
+ PUSH P,$TFORM
+ JRST ILIST2
+
+\f; IVECTOR AND IUVECTOR--GET VECTOR AND UVECTOR OF COMPUTED VALUES
+
+MFUNCTION VECTOR,SUBR,[IVECTOR]
+
+ MOVEI C,1
+ JRST VECTO3
+
+MFUNCTION UVECTOR,SUBR,[IUVECTOR]
+
+ MOVEI C,0
+VECTO3: ENTRY
+ JUMPGE AB,TFA ; AT LEAST ONE ARG
+ CAMGE AB,C%M40 ; [-4,,0] ; NOT MORE THAN 2
+ JRST TMA
+ PUSHJ P,GETFIX ; GET A POS FIXED NUMBER
+ LSH A,(C) ; A-> NUMBER OF WORDS
+ PUSH P,C ; SAVE FOR LATER
+ PUSHJ P,IBLOCK ; GET BLOCK (TURN ON BIT APPROPRIATELY)
+ POP P,C
+ HLRE A,B ; START TO
+ SUBM B,A ; FIND DOPE WORD
+ MOVSI D,.VECT. ; FOR GCHACK
+ IORM D,(A)
+ JUMPE C,VECTO4
+ MOVSI D,400000 ; GET NOT UNIFORM BIT
+ IORM D,(A) ; INTO DOPE WORD
+ SKIPA A,$TVEC ; GET TYPE
+VECTO4: MOVSI A,TUVEC
+ CAML AB,C%M20 ; [-2,,0] ; SKIP IF ARGS NEED TO BE HACKED
+ JRST FINIS
+ JUMPGE B,FINIS ; DON'T EVAL FOR EMPTY CASE
+
+ PUSH TP,A ; SAVE THE VECTOR
+ PUSH TP,B
+ PUSH TP,A
+ PUSH TP,B
+
+ JUMPE C,UINIT
+ JUMPGE B,FINIS ; EMPTY VECTOR, LEAVE
+INLP: PUSHJ P,IEVAL ; EVAL EXPR
+ MOVEM A,(C)
+ MOVEM B,1(C)
+ ADD C,C%22 ; BUMP VECTOR
+ MOVEM C,(TP)
+ JUMPL C,INLP ; IF MORE DO IT
+
+GETVEC: MOVE A,-3(TP)
+ MOVE B,-2(TP)
+ SUB TP,C%44 ; [4,,4]
+ JRST FINIS
+
+; HERE TO FILL UP A UVECTOR
+
+UINIT: PUSHJ P,IEVAL ; HACK THE 1ST VALUE
+ GETYP A,A ; GET TYPE
+ PUSH P,A ; SAVE TYPE
+ PUSHJ P,NWORDT ; SEE IF IT CAN BE UNIFORMED
+ SOJN A,CANTUN ; COMPLAIN
+STJOIN: MOVE C,(TP) ; RESTORE POINTER
+ ADD C,1(AB) ; POINT TO DOPE WORD
+ MOVE A,(P) ; GET TYPE
+ HRLZM A,(C) ; STORE IN D.W.
+ MOVSI D,.VECT. ; FOR GCHACK
+ IORM D,(C)
+ MOVE C,(TP) ; GET BACK VECTOR
+ SKIPE 1(AB)
+ JRST UINLP1 ; START FILLING UV
+ JRST GETVE1
+
+UINLP: MOVEM C,(TP) ; SAVE PNTR
+ PUSHJ P,IEVAL ; EVAL THE EXPR
+ GETYP A,A ; GET EVALED TYPE
+ CAIE A,@(P) ; WINNER?
+ JRST WRNGSU ; SERVICE ERROR FOR UVECTOR,STORAGE
+UINLP1: MOVEM B,(C) ; STORE
+ AOBJN C,UINLP
+GETVE1: SUB P,C%11
+ JRST GETVEC ; AND RETURN VECTOR
+
+IEVAL: PUSH TP,2(AB)
+ PUSH TP,3(AB)
+ MCALL 1,EVAL
+ MOVE C,(TP)
+ POPJ P,
+
+; ISTORAGE -- GET STORAGE OF COMPUTED VALUES
+
+MFUNCTION ISTORAGE,SUBR
+ ENTRY
+ JUMPGE AB,TFA
+ CAMGE AB,C%M40 ; [-4,,0] ; AT LEAST ONE ARG
+ JRST TMA
+ PUSHJ P,GETFIX ; POSITIVE COUNT FIRST ARG
+ PUSHJ P,CAFRE ; GET CORE
+ MOVN B,1(AB) ; -COUNT
+ HRL A,B ; PUT IN LHW (A)
+ MOVM B,B ; +COUNT
+ HRLI B,2(B) ; LENGTH + 2
+ ADDI B,(A) ; MAKE POINTER TO DOPE WORDS
+ HLLZM B,1(B) ; PUT TOTAL LENGTH IN 2ND DOPE
+ HRRM A,1(B) ; PUT ADDRESS IN RHW (STORE DOES THIS TOO).
+ MOVE B,A
+ MOVSI A,TSTORAGE
+ CAML AB,C%M20 ; [-2,,0] ; SECOND ARG TO EVAL?
+ JRST FINIS ; IF NOT, RETURN EMPTY
+ PUSH TP,A
+ PUSH TP,B
+ PUSH TP,A
+ PUSH TP,B
+ PUSHJ P,IEVAL ; EVALUATE FOR FIRST VALUE
+ GETYP A,A
+ PUSH P,A ; FOR COMPARISON LATER
+ PUSHJ P,SAT
+ CAIN A,S1WORD
+ JRST STJOIN ;TREAT LIKE A UVECTOR
+; IF NOT 1-WORD TYPES, CANNOT STORE, SO COMPLAIN
+ PUSHJ P,FREESV ; FREE STORAGE VECTOR
+ ERRUUO EQUOTE DATA-CANT-GO-IN-STORAGE
+
+; FOR STORAGE, MUST FREE THE CORE ELSE IT IS LOST (NO GC)
+FREESV: MOVE A,1(AB) ; GET COUNT
+ ADDI A,2 ; FOR DOPE
+ HRRZ B,(TP) ; GET ADDRESS
+ PUSHJ P,CAFRET ; FREE THE CORE
+ POPJ P,
+
+\f
+; INTERNAL VECTOR ALLOCATOR. A/SIZE OF VECTOR (NOT INCLUDING DOPE WORDS)
+
+IBLOK1: ASH A,1 ; TIMES 2
+GIBLOK: TLOA A,400000 ; FUNNY BIT
+IBLOCK: TLZ A,400000 ; NO BIT ON
+ TLO A,.VECT. ; TURN ON BIT FOR GCHACK
+ ADDI A,2 ; COMPENSATE FOR DOPE WORDS
+IBLOK2: SKIPE B,RCLV ; ANY TO RECYCLE?
+ JRST RCLVEC
+NORCL: MOVE B,GCSTOP ; POINT TO BOTTOM OF SPACE
+ PUSH P,B ; SAVE TO BUILD PTR
+ ADDI B,(A) ; ADD NEEDED AMOUNT
+ CAML B,FRETOP ; SKIP IF NO GC NEEDED
+ JRST IVECT1
+ MOVEM B,GCSTOP ; WIN, GET POINTER TO BLOCK AND UPDATE VECBOT
+ ADDM A,USEFRE
+ HRRZS USEFRE
+ HRLZM A,-1(B) ; STORE LENGTH IN DOPE WORD
+ HLLZM A,-2(B) ; AND BIT
+ HRRM B,-1(B) ; SMASH IN RELOCATION
+ SOS -1(B)
+ POP P,B ; RESTORE PTR TO BOTTOM OF VECTOR
+ HRROS B ; POINT TO START OF VECTOR
+ TLC B,-3(A) ; SETUP COUNT
+ HRRI A,TVEC
+ SKIPL A
+ HRRI A,TUVEC
+ MOVSI A,(A)
+ POPJ P,
+
+; HERE TO DO A GC ON A VECTOR ALLOCATION
+
+IVECT1: PUSH P,0
+ PUSH P,A ; SAVE DESIRED LENGTH
+ HRRZ 0,A
+ ADDM 0,GETNUM ; AND STORE AS DESIRED AMOUNT
+ MOVE C,[4,,1] ; GET INDICATOR FOR AGC
+ PUSHJ P,INQAGC
+ POP P,A
+ POP P,0
+ POP P,B
+ JRST IBLOK2
+
+
+; INTERNAL EVECTOR (CALLED FROM READ) A/ #OF THINGS
+; ITEMS ON TOP OF STACK
+
+IEVECT: ASH A,1 ; TO NUMBER OF WORDS
+ PUSH P,A
+ PUSHJ P,IBLOCK ; GET VECTOR
+ HLRE D,B ; FIND DW
+ SUBM B,D ; A POINTS TO DW
+ MOVSI 0,400000+.VECT.
+ MOVEM 0,(D) ; CLOBBER NON UNIF BIT
+ POP P,A ; RESTORE COUNT
+ JUMPE A,IVEC1 ; 0 LNTH, DONE
+ MOVEI C,(TP) ; BUILD BLT
+ SUBI C,(A)-1 ; C POINTS TO 1ST ITEM ON STACK
+ MOVSI C,(C)
+ HRRI C,(B) ; B/ SOURCE,,DEST
+ BLT C,-1(D) ; XFER THE DATA
+ HRLI A,(A)
+ SUB TP,A ; FLUSH STACKAGE
+IVEC1: MOVSI A,TVEC
+ POPJ P,
+
+
+; COMPILERS CALL
+
+CIVEC: SUBM M,(P)
+ PUSHJ P,IEVECT
+ JRST MPOPJ
+
+
+\f; INTERNAL CALL TO EUVECTOR
+
+IEUVEC: PUSH P,A ; SAVE LENGTH
+ PUSHJ P,IBLOCK
+ MOVE A,(P)
+ JUMPE A,IEUVE1 ; EMPTY, LEAVE
+ ASH A,1 ; NOW FIND STACK POSITION
+ MOVEI C,(TP) ; POINT TO TOP
+ MOVE D,B ; COPY VEC POINTER
+ SUBI C,-1(A) ; POINT TO 1ST DATUM
+ GETYP A,(C) ; CHECK IT
+ PUSHJ P,NWORDT
+ SOJN A,CANTUN ; WONT FIT
+ GETYP E,(C)
+
+IEUVE2: GETYP 0,(C) ; TYPE OF EL
+ CAIE 0,(E) ; MATCH?
+ JRST WRNGUT
+ MOVE 0,1(C)
+ MOVEM 0,(D) ; CLOBBER
+ ADDI C,2
+ AOBJN D,IEUVE2 ; LOOP
+ TRO E,.VECT.
+ HRLZM E,(D) ; STORE UTYPE
+IEUVE1: POP P,A ; GET COUNY
+ ASH A,1 ; MUST FLUSH 2 TIMES # OF ELEMENTS
+ HRLI A,(A)
+ SUB TP,A ; CLEAN UP STACK
+ MOVSI A,TUVEC
+ POPJ P,
+
+; COMPILER'S CALL
+
+CIUVEC: SUBM M,(P)
+ PUSHJ P,IEUVEC
+ JRST MPOPJ
+
+IMFUNCTION EVECTOR,SUBR,[VECTOR]
+ ENTRY
+ HLRE A,AB
+ MOVNS A
+ PUSH P,A ;SAVE NUMBER OF WORDS
+ PUSHJ P,IBLOCK ; GET WORDS
+ MOVEI D,-1(B) ; SETUP FOR BLT AND DOPE CLOBBER
+ JUMPGE B,FINISV ;DONT COPY A ZERO LENGTH VECTOR
+
+ HRLI C,(AB) ;START BUILDING BLT POINTER
+ HRRI C,(B) ;TO ADDRESS
+ ADDI D,@(P) ;SET D TO FINAL ADDRESS
+ BLT C,(D)
+FINISV: MOVSI 0,400000+.VECT.
+ MOVEM 0,1(D) ; MARK AS GENERAL
+ SUB P,C%11
+ MOVSI A,TVEC
+ JRST FINIS
+
+
+
+\f;EXPLICIT VECTORS FOR THE UNIFORM CSE
+
+IMFUNCTION EUVECTOR,SUBR,[UVECTOR]
+
+ ENTRY
+ HLRE A,AB ;-NUM OF ARGS
+ MOVNS A
+ ASH A,-1 ;NEED HALF AS MANY WORDS
+ PUSH P,A
+ JUMPGE AB,EUV1 ; DONT CHECK FOR EMPTY
+ GETYP A,(AB) ;GET FIRST ARG
+ PUSHJ P,NWORDT ;SEE IF NEEDS EXTRA WORDS
+ SOJN A,CANTUN
+EUV1: POP P,A
+ PUSHJ P,IBLOCK ; GET VECT
+ JUMPGE B,FINISU
+
+ GETYP C,(AB) ;GET THE FIRST TYPE
+ MOVE D,AB ;COPY THE ARG POINTER
+ MOVE E,B ;COPY OF RESULT
+
+EUVLP: GETYP 0,(D) ;GET A TYPE
+ CAIE 0,(C) ;SAME?
+ JRST WRNGUT ;NO , LOSE
+ MOVE 0,1(D) ;GET GOODIE
+ MOVEM 0,(E) ;CLOBBER
+ ADD D,C%22 ;BUMP ARGS POINTER
+ AOBJN E,EUVLP
+
+ TRO C,.VECT.
+ HRLM C,(E) ;CLOBBER UNIFORM TYPE IN
+FINISU: MOVSI A,TUVEC
+ JRST FINIS
+
+WRNGSU: GETYP A,-1(TP)
+ CAIE A,TSTORAGE
+ JRST WRNGUT ;IF UVECTOR
+ PUSHJ P,FREESV ;FREE STORAGE VECTOR
+ ERRUUO EQUOTE TYPES-DIFFER-IN-STORAGE-OBJECT
+
+WRNGUT: ERRUUO EQUOTE TYPES-DIFFER-IN-UNIFORM-VECTOR
+
+CANTUN: ERRUUO EQUOTE DATA-CANT-GO-IN-UNIFORM-VECTOR
+
+BADNUM: ERRUUO EQUOTE NEGATIVE-ARGUMENT
+\f; FUNCTION TO GROW A VECTOR
+REPEAT 0,[
+MFUNCTION GROW,SUBR
+
+ ENTRY 3
+
+ MOVEI D,0 ;STACK HACKING FLAG
+ GETYP A,(AB) ;FIRST TYPE
+ PUSHJ P,SAT ;GET STORAGE TYPE
+ GETYP B,2(AB) ;2ND ARG
+ CAIE A,STPSTK ;IS IT ASTACK
+ CAIN A,SPSTK
+ AOJA D,GRSTCK ;YES, WIN
+ CAIE A,SNWORD ;UNIFORM VECTOR
+ CAIN A,S2NWORD ;OR GENERAL
+GRSTCK: CAIE B,TFIX ;IS 2ND FIXED
+ JRST WTYP2 ;COMPLAIN
+ GETYP B,4(AB)
+ CAIE B,TFIX ;3RD ARG
+ JRST WTYP3 ;LOSE
+
+ MOVEI E,1 ;UNIFORM/GENERAL FLAG
+ CAIE A,SNWORD ;SKIP IF UNIFORM
+ CAIN A,SPSTK ;DONT SKIP IF UNIFORM PDL
+ MOVEI E,0
+
+ HRRZ B,1(AB) ;POINT TO START
+ HLRE A,1(AB) ;GET -LENGTH
+ SUB B,A ;POINT TO DOPE WORD
+ SKIPE D ;SKIP IF NOT STACK
+ ADDI B,PDLBUF ;FUDGE FOR PDL
+ HLLZS (B) ;ZERO OUT GROWTH SPECS
+ SKIPN A,3(AB) ;ANY TOP GROWTH?
+ JRST GROW1 ;NO, LOOK FOR BOTTOM GROWTH
+ ASH A,(E) ;MULT BY 2 IF GENERAL
+ ADDI A,77 ;ROUND TO NEAREST BLOCK
+ ANDCMI A,77 ;CLEAR LOW ORDER BITS
+ ASH A,9-6 ;DIVIDE BY 100 AND SHIFT TO POSTION
+ TRZE A,400000 ;CONVERT TO SIGN MAGNITUDE
+ MOVNS A
+ TLNE A,-1 ;SKIP IF NOT TOO BIG
+ JRST GTOBIG ;ERROR
+GROW1: SKIPN C,5(AB) ;CHECK LOW GROWTH
+ JRST GROW4 ;NONE, SKIP
+ ASH C,(E) ;GENRAL FUDGE
+ ADDI C,77 ;ROUND
+ ANDCMI C,77 ;FUDGE FOR VALUE RETURN
+ PUSH P,C ;AND SAVE
+ ASH C,-6 ;DIVIDE BY 100
+ TRZE C,400 ;CONVERT TO SIGN MAGNITUDE
+ MOVNS C
+ TDNE C,[-1,,777000] ;CHECK FOR OVERFLOW
+ JRST GTOBIG
+GROW2: HLRZ E,1(B) ;GET TOTAL LENGTH OF VECTOR
+ MOVNI E,-1(E)
+ HRLI E,(E) ;TO BOTH HALVES
+ ADDI E,1(B) ;POINTS TO TOP
+ SKIPE D ;STACK?
+ ADD E,[PDLBUF,,0] ;YES, FUDGE LENGTH
+ SKIPL D,(P) ;SHRINKAGE?
+ JRST GROW3 ;NO, CONTINUE
+ MOVNS D ;PLUSIFY
+ HRLI D,(D) ;TO BOTH HALVES
+ ADD E,D ;POINT TO NEW LOW ADDR
+GROW3: IORI A,(C) ;OR TOGETHER
+ HRRM A,(B) ;DEPOSIT INTO DOPEWORD
+ PUSH TP,(AB) ;PUSH TYPE
+ PUSH TP,E ;AND VALUE
+ SKIPE A ;DON'T GC FOR NOTHING
+ MOVE C,[2,,0] ; GET INDICATOR FOR AGC
+ PUSHJ P,AGC
+ JUMPL A,GROFUL
+ POP P,C ;RESTORE GROWTH
+ HRLI C,(C)
+ POP TP,B ;GET VECTOR POINTER
+ SUB B,C ;POINT TO NEW TOP
+ POP TP,A
+ JRST FINIS
+
+GROFUL: SUB P,C%11 ; CLEAN UP STACK
+ SUB TP,C%22
+ PUSHJ P,FULLOS
+ JRST GROW
+
+GTOBIG: ERRUUO EQUOTE ATTEMPT-TO-GROW-VECTOR-TOO-MUCH
+GROW4: PUSH P,[0] ;0 BOTTOM GROWTH
+ JRST GROW2
+]
+FULLOS: ERRUUO EQUOTE NO-STORAGE
+
+
+\f; SUBROUTINE TO BUILD CHARACTER STRING GOODIES
+
+MFUNCTION BYTES,SUBR
+
+ ENTRY
+ MOVEI D,1
+ JUMPGE AB,TFA
+ GETYP 0,(AB)
+ CAIE 0,TFIX
+ JRST WTYP1
+ MOVE E,1(AB)
+ ADD AB,C%22
+ JRST STRNG1
+
+IMFUNCTION STRING,SUBR
+
+ ENTRY
+
+ MOVEI D,0
+ MOVEI E,7
+STRNG1: MOVE B,AB ;COPY ARG POINTER
+ MOVEI C,0 ;INITIALIZE COUNTER
+ PUSH TP,$TAB ;SAVE A COPY
+ PUSH TP,B
+ HLRE A,B ; GET # OF ARGS
+ MOVNS A
+ ASH A,-1 ; 1/2 FOR # OF ARGS
+ PUSHJ P,IISTRN
+ JRST FINIS
+
+IISTRN: PUSH P,E
+ JUMPL E,OUTRNG
+ CAILE E,36.
+ JRST OUTRNG
+ SKIPN E,A ; SKIP IF ARGS EXIST
+ JRST MAKSTR ; ALL DONE
+
+STRIN2: GETYP 0,(B) ;GET TYPE CODE
+ CAMN 0,SING(D) ; SINGLE CHARACTER OR FIX?
+ AOJA C,STRIN1
+ CAME 0,MULTI(D) ; OR STRING OR BYTE-STRING
+ JRST WRONGT ;NEITHER
+ HRRZ 0,(B) ; GET CHAR COUNT
+ ADD C,0 ; AND BUMP
+
+STRIN1: ADD B,C%22
+ SOJG A,STRIN2
+
+; NOW GET THE NECESSARY VECTOR
+
+MAKSTR: HRL C,MULTI(D) ; FINAL TYPE,, CHAR COUNT
+ PUSH P,C ; SAVE CHAR COUNT
+ PUSH P,E ; SAVE ARG COUNT
+ MOVEI D,36.
+ IDIV D,-2(P) ; A==> BYTES PER WORD
+ MOVEI A,(C) ; LNTH+4 TO A
+ ADDI A,-1(D)
+ IDIVI A,(D)
+ LSH E,12.
+ MOVE D,-2(P)
+ DPB D,[060600,,E]
+ HRLM E,-2(P) ; SAVE REMAINDER
+ PUSHJ P,IBLOCK
+
+ POP P,A
+ JUMPGE B,DONEC ; 0 LENGTH, NO STRING
+ HRLI B,440000 ;CONVERT B TO A BYTE POINTER
+ HRRZ 0,-1(P) ; BYTE SIZE
+ DPB 0,[300600,,B]
+ MOVE C,(TP) ; POINT TO ARGS AGAIN
+
+NXTRG1: GETYP D,(C) ;GET AN ARG
+ CAIN D,TFIX
+ JRST .+3
+ CAIE D,TCHRS
+ JRST TRYSTR
+ MOVE D,1(C) ; GET IT
+ IDPB D,B ;AND DEPOSIT IT
+ JRST NXTARG
+
+TRYSTR: MOVE E,1(C) ;GET BYTER
+ HRRZ 0,(C) ;AND COUNT
+NXTCHR: SOJL 0,NXTARG ; IF RUNOUT, GET NEXT ARG
+ ILDB D,E ;AND GET NEXT
+ IDPB D,B ; AND DEPOSIT SAME
+ JRST NXTCHR
+
+NXTARG: ADD C,C%22 ;BUMP ARG POINTER
+ SOJG A,NXTRG1
+ ADDI B,1
+
+DONEC: MOVSI C,TCHRS+.VECT.
+ TLO B,400000
+ HLLM C,(B) ;AND CLOBBER AWAY
+ HLRZ C,1(B) ;GET LENGTH BACK
+ POP P,A
+ SUBI B,-1(C)
+ HLL B,(P) ;MAKE A BYTE POINTER
+ SUB P,C%11
+ POPJ P,
+
+SING: TCHRS
+ TFIX
+
+MULTI: TCHSTR
+ TBYTE
+
+
+; COMPILER'S CALL TO MAKE A STRING
+
+CISTNG: TDZA D,D
+
+; COMPILERS CALL TO MAKE A BYTE STRING
+
+CBYTES: MOVEI D,1
+ SUBM M,(P)
+ MOVEI C,0 ; INIT CHAR COUNTER
+ MOVEI B,(A) ; SET UP STACK POINTER
+ ASH B,1 ; * 2 FOR NO. OF SLOTS
+ HRLI B,(B)
+ SUBM TP,B ; B POINTS TO ARGS
+ PUSH P,D
+ MOVEI E,7
+ JUMPE D,CBYST
+ GETYP 0,1(B) ; CHECK BYTE SIZE
+ CAIE 0,TFIX
+ JRST WRONGT
+ MOVE E,2(B)
+ ADD B,C%22
+ SUBI A,1
+CBYST: ADD B,C%11
+ PUSH TP,$TTP
+ PUSH TP,B
+ PUSHJ P,IISTRN ; MAKE IT HAPPEN
+ MOVE TP,(TP) ; FLUSH ARGS
+ SUB TP,C%11
+ POP P,D
+ JUMPE D,MPOPJ
+ SUB TP,C%22
+ JRST MPOPJ
+
+\f;BUILD IMPLICT STRING
+
+MFUNCTION IBYTES,SUBR
+
+ ENTRY
+
+ CAML AB,C%M20 ; [-3,,] ; AT LEAST 2
+ JRST TFA
+ CAMGE AB,C%M60 ; [-7,,] ; NO MORE THAN 3
+ JRST TMA
+ PUSHJ P,GETFIX ; GET BYTE SIZE
+ JUMPL A,OUTRNG
+ CAILE A,36.
+ JRST OUTRNG
+ PUSH P,[TFIX]
+ PUSH P,A
+ PUSH P,$TBYTE
+ ADD AB,C%22
+ MOVEM AB,ABSAV(TB)
+ JRST ISTR1
+
+MFUNCTION ISTRING,SUBR
+
+ ENTRY
+ JUMPGE AB,TFA ; TOO FEW ARGS
+ CAMGE AB,C%M40 ; [-4,,0] ; VERIFY NOT TOO MANY ARGS
+ JRST TMA
+ PUSH P,[TCHRS]
+ PUSH P,[7]
+ PUSH P,$TCHSTR
+ISTR1: PUSHJ P,GETFIX
+ MOVEI C,36.
+ IDIV C,-1(P)
+ ADDI A,-1(C)
+ IDIVI A,(C) ; # OF WORDS NEEDED TO A
+ ASH D,12.
+ MOVE C,-1(P) ; GET BYTE SIZE
+ DPB C,[060600,,D]
+ PUSH P,D
+ PUSHJ P,IBLOCK
+ HLRE C,B ; -LENGTH TO C
+ SUBM B,C ; LOCN OF DOPE WORD TO C
+ HRLI D,TCHRS+.VECT. ; CLOBBER ITS TYPE
+ HLLM D,(C)
+ MOVE A,-1(P)
+ HRR A,1(AB) ; SETUP TYPE'S RH
+ SUBI B,1
+ HRL B,(P) ; AND BYTE POINTER
+ SUB P,C%33
+ SKIPE (AB)+1 ; SKIP IF NO CHARACTERS TO DEPOSIT
+ CAML AB,C%M20 ; [-2,,0] ; SKIP IF 2 ARGS GIVEN
+ JRST FINIS
+ PUSH TP,A ;SAVE OUR STRING
+ PUSH TP,B
+ PUSH TP,A ;SAVE A TEMPORARY CLOBBER POINTER
+ PUSH TP,B
+ PUSH P,(AB)1 ;SAVE COUNT
+ PUSH TP,(AB)+2
+ PUSH TP,(AB)+3
+CLOBST: PUSH TP,-1(TP)
+ PUSH TP,-1(TP)
+ MCALL 1,EVAL
+ GETYP C,A ; CHECK IT
+ CAME C,-1(P) ; MUST BE A CHARACTER
+ JRST WTYP2
+ IDPB B,-2(TP) ;CLOBBER
+ SOSLE (P) ;FINISHED?
+ JRST CLOBST ;NO
+ SUB P,C%22
+ SUB TP,C%66
+ MOVE A,(TP)+1
+ MOVE B,(TP)+2
+ JRST FINIS
+
+\f
+; HERE TO CHECK TO SEE WHETHER PURE RSUBR'S ARE MAPPED BELOW FRETOP AND
+; PUNT SOME IF THERE ARE.
+
+INQAGC: PUSH P,C
+ PUSH P,B
+ PUSH P,A
+ PUSH P,E
+ PUSHJ P,SQKIL
+ JSP E,CKPUR ; CHECK FOR PURE RSUBR
+ POP P,E
+ MOVE A,PURTOP
+ SUB A,CURPLN
+ MOVE B,RFRETP ; GET REAL FRETOP
+ CAIL B,(A)
+ MOVE B,A ; TOP OF WORLD
+ MOVE A,GCSTOP
+ ADD A,GETNUM
+ ADDI A,1777 ; PAGE BOUNDARY
+ ANDCMI A,1777
+ CAIL A,(B) ; SEE WHETHER THERE IS ROOM
+ JRST GOTOGC
+ PUSHJ P,CLEANT
+ POP P,A
+ POP P,B
+ POP P,C
+ POPJ P,
+GOTOGC: POP P,A
+ POP P,B
+ POP P,C ; RESTORE CAUSE INDICATOR
+ MOVE A,P.TOP
+ PUSHJ P,CLEANT ; CLEAN UP
+ SKIPL PLODR ; IF IN PLOAD DON'T INTERRUPT
+ JRST INTAGC ; GO CAUSE GARBAGE COLLECT
+ JRST SAGC
+
+CLEANT: PUSH P,C
+ PUSH P,A
+ SUB A,P.TOP
+ ASH A,-PGSZ
+ JUMPE A,CLNT1
+ PUSHJ P,GETPAG ; GET THOSE PAGES
+ FATAL CAN'T GET PAGES NEEDED
+ MOVE A,(P)
+ ASH A,-10. ; TO PAGES
+ PUSHJ P,P.CORE
+ PUSHJ P,SLEEPR
+CLNT1: PUSHJ P,RBLDM
+ POP P,A
+ POP P,C
+ POPJ P,
+
+\f; RCLVEC DISTASTEFUL VECTOR RECYCLER
+
+; Arrive here with B pointing to first recycler, A desired length
+
+RCLVEC: PUSH P,D ; Save registers
+ PUSH P,C
+ PUSH P,E
+ MOVEI D,RCLV ; Point to previous recycle for splice
+RCLV1: HLRZ C,(B) ; Get size of this block
+ CAIL C,(A) ; Skip if too small
+ JRST FOUND1
+
+RCLV2: MOVEI D,(B) ; Save previous pointer
+ HRRZ B,(B) ; Point to next block
+ JUMPN B,RCLV1 ; Jump if more blocks
+
+ POP P,E
+ POP P,C
+ POP P,D
+ JRST NORCL ; Go to normal allocator
+
+
+FOUND1: CAIN C,1(A) ; Exactly 1 greater?
+ JRST RCLV2 ; Cant use this guy
+
+ HRLM A,(B) ; Smash in new count
+ TLO A,.VECT. ; make vector bit be on
+ HLLM A,-1(B)
+ CAIE C,(A) ; Exactly right length?
+ JRST FOUND2 ; No, do hair
+
+ HRRZ C,(B) ; Point to next block
+ HRRM C,(D) ; Smash previous pointer
+ HRRM B,(B)
+ SUBI B,-1(A) ; Point to top of block
+ JRST FOUND3
+
+FOUND2: SUBI C,(A) ; Amount of left over to C
+ HRRZ E,(B) ; Point to next block
+ HRRM B,(B)
+ SUBI B,(A) ; Point to dope words of guy to put back
+ MOVSM C,(B) ; Smash in count
+ MOVSI C,.VECT. ; Get vector bit
+ MOVEM C,-1(B) ; Make sure it is a vector
+ HRRM B,(D) ; Splice him in
+ HRRM E,(B) ; And the next guy also
+ ADDI B,1 ; Point to start of vector
+
+FOUND3: HRROI B,(B) ; Make an AOBJN pointer
+ TLC B,-3(A)
+ HRRI A,TVEC
+ SKIPGE A
+ HRRI A,TUVEC
+ MOVSI A,(A)
+ POP P,E
+ POP P,C
+ POP P,D
+ POPJ P,
+
+END
+\f
\ No newline at end of file
--- /dev/null
+
+ TITLE STRBUILD MUDDLE STRUCTURE BUILDER
+
+.GLOBAL RCL,VECTOP,GCSTOP,GCSBOT,FRETOP,GCSNEW,VECBOT,PARTOP,PARBOT,HITOP,HIBOT,GETPAG
+.GLOBAL PDLBUF,PDLEX,PDLEXP,GCFLG,GCPDL,GETNUM,PARNEW,MOVPUR,RCLV,RCLVEC
+.GLOBAL PGROW,TPGROW,MAINPR,%SLEEP,MSGTYP,PURTOP,PURBOT,STOSTR,RBLDM,CPOPJ,CPOPJ1,STBL
+.GLOBAL MTYI,UPLO,FRMUNG,BYTDOP,GLOBSP,FREDIF,FREMIN,GCHAPN,INTFLG,PINIT,CKPUR,GCSET
+.GLOBAL SAT,TTOCHN,TYPVEC,ICONS,INCONS,IBLOCK,IEUVEC,IEVECTI,CELL2,MKTBS,CPOPJ1,.LIST.
+.GLOBAL GIBLOK,REHASH,IBLOK1,IILIST,IIFORM,CIVEC,CIUVEC,CICONS,SLEEPR,GCHK10,FPAG
+.GLOBAL SPBASE,OUTRNG,CISTNG,CBYTES,%RUNAM,PURVEC,GCDOWN,N.CHNS,CHNL1,PLODR,C1CONS
+.GLOBAL CAFRE,CAFRET,STOGC,GCHN,WNDP,FRNP,FRONT,%GCJOB,%SHWND,%INFMP,%GETIP
+.GLOBAL TD.PUT,TD.GET,TD.LNT,GLOTOP,UBIT,FLGSET,PURMNG,RPURBT,%IFMP2,CHKPGI,PURCLN
+.GLOBAL CTIME,MTYO,ILOC,NODES,GPURFL,GCDANG,GCHACK,LPUR,HITOP,BADCHN,IMPURX
+.GLOBAL NOWLVL,CURPLN,PVSTOR,SPSTOR,MPOPJ,NGCS,RNUMSP,NUMSWP,SAGC,INQAGC
+.GLOBAL GCTIM,GCCAUS,GCCALL,AAGC,LVLINC,STORIC,GVLINC,TYPIC,GCRSET,ACCESS,NOSHUF,SQUPNT
+; GLOBALS ASSOCIATE WITH THE ASSOCIATION VECTOR
+
+.GLOBAL ASOVEC,ASOLNT,ITEM,INDIC,VAL,NWORDT,NODPNT,PNTRS
+.GLOBAL CELL,BINDID,GCFLCH,TYPBOT,GLOBAS,TPBASE
+.GLOBAL TPBINC,GBLINC,TYPINC,CONADJ,OGCSTP,ABOTN
+.GLOBAL AGC,ROOT,CIGTPR,IIGLOC
+.GLOBAL P.TOP,P.CORE,PMAPB
+.GLOBAL %MPINT,%GBINT,%CLSMP,%CLSM1
+.GLOBAL GCKNUM,CORTOP,GCHPN,INTAGC,WNDP,WNDBOT,BUFGC,WIND,GCDFLG,SAVM
+
+; SHARED SYMBOLS WITH GC MODULE
+
+.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,PMIN,PURMIN
+.GLOBAL GLBINC,GCHAIR,GCMONF,SQKIL,INBLOT
+.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
+
+NOPAGS==1 ; NUMBER OF WINDOWS
+EOFBIT==1000
+PDLBUF=100
+
+.ATOM.==200000 ; FLAG SAYING ATOMS MARKED (FOR VAL FLUSH LOGIC)
+
+GCHN==0 ; CHANNEL FOR FUNNNY INFERIOR
+STATNO==19. ; # OF STATISTICS FOR BLOAT-STAT
+STATGC==8. ; # OF GC-STATISTICS FOR BLOAT-STAT
+
+
+RELOCATABLE
+.INSRT MUDDLE >
+SYSQ
+IFE ITS,[
+.INSRT STENEX >
+]
+IFN ITS, PGSZ==10.
+IFE ITS, PGSZ==9.
+
+
+\f; GC-READ TAKES ONE ARGUMENT WHICH MUST BE A "READB" CHANNEL
+
+.GLOBAL CLOOKU,CINSER,MOBLIST,CATOM,EOFCND,IGLOC
+
+MFUNCTION GCREAD,SUBR,[GC-READ]
+
+ ENTRY
+
+ CAML AB,C%M2 ; CHECK # OF ARGS
+ JRST TFA
+ CAMGE AB,C%M40
+ JRST TMA
+
+ GETYP A,(AB) ; MAKE SURE ARG IS A CHANNEL
+ CAIE A,TCHAN
+ JRST WTYP2 ; IT ISN'T COMPLAIN
+ MOVE B,1(AB) ; GET PTR TO CHANNEL
+ HRRZ C,-2(B) ; LOOK AT BITS IN CHANNEL
+ TRC C,C.OPN+C.READ+C.BIN
+ TRNE C,C.OPN+C.READ+C.BIN
+ JRST BADCHN
+
+ PUSH P,1(B) ; SAVE ITS CHANNEL #
+IFN ITS,[
+ MOVE B,[-2,,C] ; SET UP AOBJN PTR TO READ IN DELIMITING
+ ; CONSTANTS
+ MOVE A,(P) ; GET CHANNEL #
+ DOTCAL IOT,[A,B]
+ FATAL GCREAD-- IOT FAILED
+ JUMPL B,EOFGC ; IF BLOCK DIDN'T FINISH THEN EOF
+]
+IFE ITS,[
+ MOVE A,(P) ; GET CHANNEL
+ BIN
+ MOVE C,B ; TO C
+ BIN
+ MOVE D,B ; TO D
+ GTSTS ; SEE IF EOF
+ TLNE B,EOFBIT
+ JRST EOFGC
+]
+
+ PUSH P,C ; SAVE AC'S
+ PUSH P,D
+
+IFN ITS,[
+ MOVE B,[-3,,C] ; NEXT GROUP OF WORDS
+ DOTCAL IOT,[A,B]
+ FATAL GCREAD--GC IOT FAILED
+]
+IFE ITS,[
+ MOVE A,-2(P) ; GET CHANNEL
+ BIN
+ MOVE C,B
+ BIN
+ MOVE D,B
+ BIN
+ MOVE E,B
+]
+ MOVEI 0,0 ; DO PRELIMINARY TESTS
+ IOR 0,A ; IOR ALL WORDS IN
+ IOR 0,B
+ IOR 0,C
+ IOR 0,(P)
+ IOR 0,-1(P)
+ TLNE 0,-1 ; SKIP IF NO BITS IN LEFT HALF
+ JRST ERDGC
+
+ MOVEM D,NNPRI
+ MOVEM E,NNSAT
+ MOVE D,C ; GET START OF NEWTYPE TABLE
+ SUB D,-1(P) ; CREATE AOBJN POINTER
+ HRLZS D
+ ADDI D,(C)
+ MOVEM D,TYPTAB ; SAVE IT
+ MOVE A,(P) ; GET LENGTH OF WORD
+ SUBI A,CONADJ ; SUBTRACT FOR CONSTANTS
+
+ ADD A,GCSTOP
+ CAMG A,FRETOP ; SEE IF GC IS NESESSARY
+ JRST RDGC1
+ MOVE C,(P)
+ ADDM C,GETNUM ; MOVE IN REQUEST
+ MOVE C,[0,,1] ; ARGS TO GC
+ PUSHJ P,AGC ; GC
+RDGC1: MOVE C,GCSTOP ; GET CURRENT TOP OF THE WORLD
+ MOVEM C,OGCSTP ; SAVE IT
+ ADD C,(P) ; CALCULATE NEW GCSTOP
+ ADDI C,2 ; SUBTRACT FOR CONSTANTS
+ MOVEM C,GCSTOP
+ SUB C,OGCSTP
+ SUBI C,2 ; SUBSTRACT TO GET RID OF D.W'S
+ MOVNS C ; SET UP AOBJN PTR FOR READIN
+IFN ITS,[
+ HRLZS C
+ MOVE A,-2(P) ; GET CHANNEL #
+ ADD C,OGCSTP
+ DOTCAL IOT,[A,C]
+ FATAL GCREAD-- IOT FAILED
+]
+IFE ITS,[
+ MOVE A,-2(P) ; CHANNEL TO A
+ MOVE B,OGCSTP ; SET UP BYTE POINTER
+ HRLI B,444400
+ SIN ; IN IT COMES
+]
+
+ MOVE C,(P) ; GET LENGHT OF OBJECT
+ ADDI A,5
+ MOVE B,1(AB) ; GET CHANNEL
+ ADDM C,ACCESS(B)
+ MOVE D,GCSTOP ; SET UP TO LOOK LIKE UVECTOR OF LOSES
+ ADDI C,2 ; ADD 2 FOR DOPE WORDS
+ HRLM C,-1(D)
+ MOVSI A,.VECT.
+ SETZM -2(D)
+ IORM A,-2(D) ; MARK VECTOR BIT
+ PUSH TP,$TRDTB ; HOLD ON IN CASE OF GC
+ MOVEI A,-2(D)
+ MOVN C,(P)
+ ADD A,C
+ HRL A,C
+ PUSH TP,A
+
+ MOVE D,-1(P) ; SET UP BOTTOM OF ATOM TABLE
+ SUBI D,1
+ MOVEM D,ABOTN
+ MOVE C,GCSTOP ; START AT TOP OF WORLD
+ SUBI C,3 ; POINT TO FIRST ATOM
+
+; LOOP TO FIX UP THE ATOMS
+
+AFXLP: HRRZ 0,1(TB)
+ ADD 0,ABOTN
+ CAMG C,0 ; SEE IF WE ARE DONE
+ JRST SWEEIN
+ HRRZ 0,1(TB)
+ SUB C,0
+ PUSHJ P,ATFXU ; FIX IT UP
+ HLRZ A,(C) ; GET LENGTH
+ TRZ A,400000 ; TURN OFF MARK BIT
+ SUBI C,(A) ; POINT TO PRECEDING ATOM
+ HRRZS C ; CLEAR OFF NEGATIVE
+ JRST AFXLP
+
+; FIXUP ROUTINE FOR ATOMS (C==> D.W.)
+
+ATFXU: PUSH P,C ; SAVE PTR TO D.W.
+ ADD C,1(TB)
+ MOVE A,C
+ HLRZ B,(A) ; GET LENGTH AND MARKING
+ TRZE B,400000 ; TURN OF MARK BIT AND SKIP IF WAS ALREADY MARKED
+ JRST ATFXU1
+ MOVEI D,-3(B) ; FULL WORDS OF STRING IN PNAME
+ IMULI D,5 ; CALCULATE # OF CHARACTERS
+ MOVE 0,-2(A) ; GET LAST WORD OF STRING
+ SUBI A,-1(B) ; LET A POINT TO OBLIST SLOAT
+ MOVE B,A ; GET COPY OF A
+ MOVE A,0
+ SUBI A,1
+ ANDCM 0,A
+ JFFO 0,.+1
+ HRREI 0,-34.(A)
+ IDIVI 0,7 ; # OF CHARS IN LAST WORD
+ ADD D,0
+ ADD D,$TCHSTR ; MAKE IT LOOK LIKE A STRINGS TYPE-WORD
+ PUSH P,D ; SAVE IT
+ MOVE C,(B) ; GET OBLIST SLOT PTR
+ATFXU9: HRRZS B ; RELATAVIZE POINTER
+ HRRZ 0,1(TB)
+ SUB B,0
+ PUSH P,B
+ JUMPE C,ATFXU6 ; NO OBLIST. CREATE ATOM
+ CAMN C,C%M1 ; SEE IF ROOT ATOM
+ JRST RTFX
+ ADD C,ABOTN ; POINT TO ATOM
+ PUSHJ P,ATFXU
+ PUSH TP,$TATOM
+ PUSH TP,B
+ MOVE A,$TATOM ; SET UP TO SEE IF OBLIST EXITS
+ MOVE C,$TATOM
+ MOVE D,IMQUOTE OBLIST
+ PUSHJ P,CIGTPR
+ JRST ATFXU8 ; NO OBLIST. CREATE ONE
+ SUB TP,C%22 ; GET RID OF SAVED ATOM
+RTCON: PUSH TP,$TOBLS
+ PUSH TP,B
+ MOVE C,B ; SET UP FOR LOOKUP
+ MOVE A,-1(P) ; SET UP PTR TO PNAME
+ MOVE B,(P)
+ ADD B,[440700,,1] ; ADJUST TO MAKE IT LOOK LIKE A BYTE-POINTER
+ HRRZ 0,1(TB)
+ ADD B,0
+ PUSHJ P,CLOOKU
+ JRST ATFXU4 ; NOT ON IT SO INSERT
+ATFXU3: SUB P,C%22 ; DONE
+ SUB TP,C%22 ; POP OFF OBLIST
+ATFXU7: MOVE C,(P) ; RESTORE PTR TO D.W.
+ ADD C,1(TB)
+ MOVEM B,-1(C) ; MOVE IN RELATAVIZE ADDRESS
+ MOVSI D,400000
+ IORM D,(C) ; TURN OFF MARK BIT
+ MOVE 0,3(B) ; SEE IF MUST BE LOCR
+ TRNE 0,1 ; SKIP IF MUST MAKE IT IMPURE
+ PUSHJ P,IIGLOC
+ POP P,C
+ ADD C,1(TB)
+ POPJ P, ; EXIT
+ATFXU1: POP P,C ; RESTORE PTR TO D.W.
+ ADD C,1(TB)
+ MOVE B,-1(C) ; GET ATOM
+ POPJ P,
+
+; ROUTINE TO INSERT AN ATOM
+
+ATFXU4: MOVE C,(TP) ; GET OBLIST PTR
+ MOVE B,(P) ; SET UP STRING PTR TO PNAME
+ ADD B,[440700,,1]
+ HRRZ 0,1(TB)
+ ADD B,0
+ MOVE A,-1(P) ; GET TYPE WORD
+ PUSHJ P,CINSER ; INSERT IT
+ JRST ATFXU3
+
+; THIS ROUTINE CREATS THE ATOM SO THAT ITS NOT ON ANY OBLIST
+
+ATFXU6: MOVE B,(P) ; POINT TO PNAME
+ ADD B,[440700,,1] ; MAKE IT LOOK LIKE A BYTE POINTER
+ HRRZ 0,1(TB)
+ ADD B,0
+ MOVE A,-1(P)
+ PUSHJ P,CATOM
+ SUB P,C%22 ; CLEAN OFF STACK
+ JRST ATFXU7
+
+; THIS ROUTINE CREATES AND OBLIST
+
+ATFXU8: MCALL 1,MOBLIST
+ PUSH TP,$TOBLS
+ PUSH TP,B ; SAVE OBLIST PTR
+ JRST ATFXU4 ; JUMP TO INSERT THE OBLIST
+
+; HERE TO INSERT AN ATOM INTO THE ROOT OBLIST
+
+RTFX: MOVE B,ROOT+1 ; GET ROOT OBLIST
+ JRST RTCON
+
+; THIS ROUTINE SWEEPS THRU THE NEW CORE IMAGE AND UPDATES ALL THE POINTERS.
+
+SWEEIN:
+; ROUTINE TO FIX UP TYPE-TABLE FOR GC-READ. THIS ROUTINE FIXES UP THE TYPE TABLE SO THAT
+; THE TYPES ATOM I.D. IS REPLACED BY ITS TYPE-NUMBER IN THE NEW MUDDLE AND IF ITS A
+; TEMPLATE, THE SLOT FOR THE PRIMTYPE-ATOM IS REPLACED BY THE SAT OF THE TEMPLATE
+
+ HRRZ E,1(TB) ; SET UP TYPE TABLE
+ ADD E,TYPTAB
+ JUMPGE E,VUP ; SKIP OVER IF DONE
+TYPUP1: PUSH P,C%0 ; PUSH SLOT FOR POSSIBLE TEMPLATE ATOM
+ HLRZ A,1(E) ; GET POSSIBLE ATOM SLOT
+ JUMPE A,TYPUP2 ; JUMP IF NOT A TEMPLATE
+ ADD A,ABOTN ; GET ATOM
+ ADD A,1(TB)
+ MOVE A,-1(A)
+ MOVE B,TYPVEC+1 ; GET TYPE VECTOR SLOT FOR LOOP TO SEE IF ITS THERE
+TYPUP3: CAMN A,1(B) ; SKIP IF NOT EQUAL
+ JRST TYPUP4 ; FOUND ONE
+ ADD B,C%22 ; TO NEXT
+ JUMPL B,TYPUP3
+ JRST ERTYP1 ; ERROR NONE EXISTS
+TYPUP4: HRRZ C,(B) ; GET SAT SLOT
+ CAIG C,NUMSAT ; MAKE SURE TYPE IS A TEMPLATE
+ JRST ERTYP2 ; IF NOT COMPLAIN
+ HRLM C,1(E) ; SMASH IN NEW SAT
+ MOVE B,1(B) ; GET ATOM OF PRIMTYPE
+ MOVEM B,(P) ; PUSH ONTO STACK
+TYPUP2: MOVEI D,0 ; INITIALIZE TYPE COUNT FOR LOOKUP LOOP
+ MOVE B,TYPVEC+1 ; GET PTR FOR LOOP
+ HRRZ A,1(E) ; GET TYPE'S ATOM ID
+ ADD A,ABOTN ; GET ATOM
+ ADD A,1(TB)
+ MOVE A,-1(A)
+TYPUP5: CAMN A,1(B) ; SKIP IF NOT EQUAL
+ JRST TYPUP6 ; FOUND ONE
+ ADDI D,1 ; INCREMENT TYPE-COUNT
+ ADD B,C%22 ; POINT TO NEXT
+ JUMPL B,TYPUP5
+ HRRM D,1(E) ; CLOBBER IN TYPE-NUMBER
+ PUSH TP,$TATOM ; PUSH ARGS FOR NEWTYPE
+ PUSH TP,A
+ PUSH TP,$TATOM
+ POP P,B ; GET BACK POSSIBLE PRIMTYPE ATOM
+ JUMPE B,TYPUP7 ; JUMP IF NOT A TEMPLATE
+ PUSH TP,B ; PUSH ON PRIMTYPE
+TYPUP9: SUB E,1(TB)
+ PUSH P,E ; SAVE RELATAVIZED PTR TO TYPE-TABLE
+ MCALL 2,NEWTYPE
+ POP P,E ; RESTORE RELATAVIZED PTR
+ ADD E,1(TB) ; FIX IT UP
+TYPUP0: ADD E,C%22 ; INCREMENT E
+ JUMPL E,TYPUP1
+ JRST VUP
+TYPUP7: HRRZ B,(E) ; FIND PRIMTYPE FROM SAT
+ MOVE A,@STBL(B)
+ PUSH TP,A
+ JRST TYPUP9
+TYPUP6: HRRM D,1(E) ; CLOBBER IN TYPE #
+ JRST TYPUP0
+
+ERTYP1: ERRUUO EQUOTE CANT-FIND-TEMPLATE
+
+ERTYP2: ERRUUO EQUOTE TEMPLATE-TYPE-NAME-NOT-OF-TYPE-TEMPLATE
+
+VUP: HRRZ E,1(TB) ; FIX UP SOME POINTERS
+ MOVEM E,OGCSTP
+ ADDM E,ABOTN
+ ADDM E,TYPTAB
+
+
+; ROUTINE TO SWEEP THRU THE READ-IN IMAGE LOOKING FOR UVECTORS AND TEMPLATES.
+; WHILE SWEEPING IT FIXES UP THE DOPE WORDS APPROPRIATELY.
+
+ HRRZ A,TYPTAB ; GET TO TOP OF WORLD
+ SUBI A,2 ; GET TO FIRST TYPE WORD OR DOPE-WORD OF FIRST OBJECT
+VUP1: CAMG A,OGCSTP ; SKIP IF NOT DONE
+ JRST VUP3
+ HLRZ B,(A) ; GET TYPE SLOT
+ TRNE B,.VECT. ; SKIP IF NOT A VECTOR
+ JRST VUP2
+ SUBI A,2 ; SKIP OVER PAIR
+ JRST VUP1
+VUP2: TRNE B,400000 ; SKIP IF UVECTOR
+ JRST VUP4
+ ANDI B,TYPMSK ; GET RID OF MONITORS
+ CAMG B,NNPRI ; SKIP IF NEWTYPE
+ JRST VUP5
+ PUSHJ P,GETNTP ; GET THE NEW TYPE #
+ PUTYP B,(A) ; SMASH IT IT
+VUP5: HLRZ B,1(A) ; SKIP OVER VECTOR
+ TRZ B,400000 ; GET RID OF POSSIBLE MARK BIT
+ SUBI A,(B)
+ JRST VUP1 ; LOOP
+VUP4: ANDI B,TYPMSK ; FLUSH MONITORS
+ CAMG B,NNSAT ; SKIP IF TEMPLATE
+ JRST VUP5
+ PUSHJ P,GETSAT ; CONVERT TO NEW SAT
+ ADDI B,.VECT. ; MAJIC TO TURN ON BIT
+ PUTYP B,(A)
+ JRST VUP5
+
+
+VUP3: PUSH P,GCSBOT ; SAVE CURRENT GCSBOT
+ MOVE A,OGCSTP ; SET UP NEW GCSBOT
+ MOVEM A,GCSBOT
+ PUSH P,GCSTOP
+ HRRZ A,TYPTAB ; SET UP NEW GCSTOP
+ MOVEM A,GCSTOP
+ SETOM GCDFLG
+ MOVE A,[PUSHJ P,RDFIX] ; INS FOR GCHACK
+ MOVEI PVP,0 ; SAY MIGHT BE NON-ATOMS
+ PUSHJ P,GCHK10
+ SETZM GCDFLG
+ POP P,GCSTOP ; RESTORE GCSTOP
+ MOVE A,1(TB) ; GET A POINTER TO RETURNING VALUES
+ MOVE B,A
+ HLRE C,B
+ SUB B,C
+ SETZM (B)
+ SETZM 1(B)
+ POP P,GCSBOT ; RESTORE GCSBOT
+ MOVE B,1(A) ; GET PTR TO OBJECTS
+ MOVE A,(A)
+ JRST FINIS ; EXIT
+
+; ERROR FOR INCORRECT GCREAD FILE
+
+ERDGC: ERRUUO EQUOTE BAD-GC-READ-FILE
+
+; ROUTINE CALLED BY GCHACK TO UPDATE PTRS IN THE NEW CORE IMAGE
+
+RDFIX: PUSH P,C ; SAVE C
+ PUSH P,B ; SAVE PTR
+ EXCH B,C
+ TLNE C,UBIT ; SKIP IF NOT UVECTOR
+ JRST ELEFX ; DON'T HACK TYPES IN UVECTOR
+ CAIN B,TTYPEC
+ JRST TYPCFX
+ CAIN B,TTYPEW
+ JRST TYPWFX
+ CAMLE B,NNPRI
+ JRST TYPGFX
+ELEFX: EXCH B,A ; EXCHANGE FOR SAT
+ PUSHJ P,SAT
+ EXCH B,A ; REFIX
+ CAIE B,SOFFS
+ JRST OFSFIX
+ CAIE B,SLOCR ; REL GLOC'S ARE STORED AS ATOMS
+ CAIN B,SATOM
+ JRST ATFX
+ CAIN B,SCHSTR
+ JRST STFX
+ CAIN B,S1WORD ; SEE IF PRIMTYPE WOR
+ JRST RDLSTF ; LEAVE IF IS
+STFXX: MOVE 0,GCSBOT ; ADJUSTMENT
+ SUBI 0,FPAG+5
+ SKIPE 1(C) ; DON'T CHANGE A PTR TO NIL
+ ADDM 0,1(C) ; FIX UP
+RDLSTF: TLNN C,.LIST. ; SEE IF PAIR
+ JRST RDL1 ; EXIT
+ MOVE 0,GCSBOT ; FIX UP
+ SUBI 0,FPAG+5
+ HRRZ B,(C) ; SEE IF POINTS TO NIL
+ SKIPN B
+ JRST RDL1
+ MOVE B,C ; GET ARG FOR RLISTQ
+ PUSHJ P,RLISTQ
+ JRST RDL1
+ ADDM 0,(C)
+RDL1: POP P,B ; RESTORE B
+ POP P,C
+ POPJ P,
+
+; FIXUP OFSSETS
+
+OFSFIX: HLRZ B,1(C) ; SEE IF PNTR TO FIXUP
+ JUMPE B,RDL1
+ MOVE 0,GCSBOT ; GET UPDATE AMOUNT
+ SUBI 0,FPAG+5
+ HRLZS 0
+ ADDM 0,1(C) ; FIX POINTER
+ JRST RDL1
+
+; ROUTINE TO FIX UP PNAMES
+
+STFX: TLZN D,STATM
+ JRST STFXX
+ HLLM D,1(C) ; PUT BACK WITH BIT OFF
+ ADD D,ABOTN
+ ANDI D,-1
+ HLRE 0,-1(D) ; LENGTH OF ATOM
+ MOVNS 0
+ SUBI 0,3 ; VAL & OBLIST
+ IMULI 0,5 ; TO CHARS (SORT OF)
+ HRRZ D,-1(D)
+ ADDI D,2
+ PUSH P,A
+ PUSH P,B
+ LDB A,[360600,,1(C)] ; GET BYTE POS
+ IDIVI A,7 ; TO CHAR POS
+ SKIPE A
+ SUBI A,5
+ HRRZ B,(C) ; STRING LENGTH
+ SUB B,A ; TO WORD BOUNDARY STRING
+ SUBI 0,(B)
+ IDIVI 0,5
+ ADD D,0
+ POP P,B
+ POP P,A
+ HRRM D,1(C)
+ JRST RDLSTF
+
+; ROUTINE TO FIX UP POINTERS TO ATOMS
+
+ATFX: SKIPGE D
+ JRST RDLSTF
+ ADD D,ABOTN
+ MOVE 0,-1(D) ; GET PTR TO ATOM
+ CAIE B,SLOCR ; IF REL LOCATIVE, MORE HAIR
+ JRST ATFXAT
+ MOVE B,0
+ PUSH P,E
+ PUSH P,D
+ PUSH P,C
+ PUSH P,B
+ PUSH P,A
+ PUSHJ P,IGLOC
+ SUB B,GLOTOP+1
+ MOVE 0,B
+ POP P,A
+ POP P,B
+ POP P,C
+ POP P,D
+ POP P,E
+ATFXAT: MOVEM 0,1(C) ; SMASH IT IN
+ JRST RDLSTF ; EXIT
+
+TYPCFX: HRRZ B,1(C) ; GET TYPE
+ PUSHJ P,GETNEW ; GET TYPE IN THIS CORE IMAGE
+ HRRM B,1(C) ; CLOBBER IT IN
+ JRST RDLSTF ; CONTINUE FIXUP
+
+TYPWFX: HLRZ B,1(C) ; GET TYPE
+ PUSHJ P,GETNEW ; GET TYPE IN THIS CORE IMAGE
+ HRLM B,1(C) ; SMASH IT IN
+ JRST ELEFX
+
+TYPGFX: PUSH P,D
+ PUSHJ P,GETNTP ; GET TYPE IN THIS CORE IMAGE
+ POP P,D
+ PUTYP B,(C)
+ JRST ELEFX
+
+; HERE TO HANDLE AN EOF IN GC-READ. IT USES OPTIONAL SECOND ARG IF SUPPLIED AS
+; EOF HANDLER ELSE USES CHANNELS.
+
+EOFGC: MOVE B,1(AB) ; GET CHANNEL INTO B
+ CAML AB,C%M20 ; [-2,,0] ; SKIP IF EOF ROUTINE IS SUPPLIED
+ JRST MYCLOS ; USE CHANNELS
+ PUSH TP,2(AB)
+ PUSH TP,3(AB)
+ JRST CLOSIT
+MYCLOS: PUSH TP,EOFCND-1(B)
+ PUSH TP,EOFCND(B)
+CLOSIT: PUSH TP,$TCHAN
+ PUSH TP,B
+ MCALL 1,FCLOSE ; CLOSE CHANNEL
+ MCALL 1,EVAL ; EVAL HIS EOF HANDLER
+ JRST FINIS
+
+; ROUTINE TO SUPPLY THE TYPE NUMBER FOR A NEWTYPE
+
+GETNEW: CAMG B,NNPRI ;NEWTYPE
+ POPJ P,
+GETNTP: MOVE D,TYPTAB ; GET AOBJN POINTER TO TYPE-TABLE
+GETNT1: HLRZ E,(D) ; GET TYPE #
+ CAIN E,(B) ; SKIP IF NOT EQUAL TO GOAL
+ JRST GOTTYP ; FOUND IT
+ ADD D,C%22 ; POINT TO NEXT
+ JUMPL D,GETNT1
+ SKIPA ; KEEP TYPE SAME
+GOTTYP: HRRZ B,1(D) ; GET NEW TYPE #
+ POPJ P,
+
+; ROUTINE TO SUPPLY THE SAT TO A TEMPLATE HACKER
+
+GETSAT: MOVE D,TYPTAB ; GET AOBJN PTR TO TYPE TABLE
+GETSA1: HRRZ E,(D) ; GET OBJECT
+ CAIN E,(B) ; SKIP IF NOT EQUAL TO GOAL
+ JRST GOTSAT ; FOUND IT
+ ADD D,C%22
+ JUMPL D,GETSA1
+ FATAL GC-DUMP -- TYPE FIXUP FAILURE
+GOTSAT: HLRZ B,1(D) ; GET NEW SAT
+ POPJ P,
+
+
+; A ROUTINE TO DISTINGUISH BETWEEN A DEFERRED AND A LIST POINTER
+RLISTQ: PUSH P,A
+ GETYP A,(B) ; GET TYPE
+ PUSHJ P,SAT ; GET SAT
+ CAIG A,NUMSAT ; NOT DEFERRED IF TEMPLATE
+ SKIPL MKTBS(A)
+ AOS -1(P) ; SKIP IF NOT DEFFERED
+ POP P,A
+ POPJ P, ; EXIT
+
+\f
+.GLOBAL FLIST
+
+MFUNCTION BLOATSTAT,SUBR,[BLOAT-STAT]
+
+ENTRY
+
+ JUMPGE AB,GETUVC ; SEE IF THERE IS AN ARGUMENT
+ GETYP A,(AB)
+ CAIE A,TUVEC ; SEE IF THE ARGUMENT IS A UVECTOR
+ JRST WTYP1 ; IF NOT COMPLAIN
+ HLRE 0,1(AB)
+ MOVNS 0
+ CAIE 0,STATNO+STATGC ; SEE IF UVECTOR IS RIGHT LENGTH
+ JRST WTYP1
+ CAMGE AB,C%M20 ; [-2,,0] ; SEE IF THERE ARE TOO MANY ARGUMENTS
+ JRST TMA
+ MOVE A,(AB) ; GET THE UVECTOR
+ MOVE B,1(AB)
+ JRST SETUV ; CONTINUE
+GETUVC: MOVEI A,STATNO+STATGC ; CREATE A UVECTOR
+ PUSHJ P,IBLOCK
+SETUV: PUSH P,A ; SAVE UVECTOR
+ PUSH P,B
+ MOVE 0,NOWFRE ; COMPUTE FREE STORAGE USED SINCE LAST BLOAT-STAT
+ SUB 0,RFRETP
+ ADD 0,GCSTOP
+ MOVEM 0,CURFRE
+ PUSHJ P,GCSET ; FIX UP BLOAT-STAT PARAMETERS
+ HLRE 0,TP ; COMPUTE STACK SPACE USED UP
+ ADD 0,NOWTP
+ SUBI 0,PDLBUF
+ MOVEM 0,CURTP
+ MOVE B,IMQUOTE THIS-PROCESS
+ PUSHJ P,ILOC
+ HRRZS B
+ MOVE PVP,PVSTOR+1
+ HRRZ C,TPBASE+1(PVP) ; CALCULATE # OF ATOM SLOTS
+ MOVE 0,B
+ HRRZ D,SPBASE+1(PVP) ; COMPUTE CURRENT # OF BINDINGS
+ SUB 0,D
+ IDIVI 0,6
+ MOVEM 0,CURLVL
+ SUB B,C ; TOTAL WORDS ATOM STORAGE
+ IDIVI B,6 ; COMPUTE # OF SLOTS
+ MOVEM B,NOWLVL
+ HRRZ A,GLOBASE+1 ; COMPUTE TOTAL # OF GLOBAL SLOTS
+ HLRE 0,GLOBASE+1
+ SUB A,0 ; POINT TO DOPE WORD
+ HLRZ B,1(A)
+ ASH B,-2 ; # OF GVAL SLOTS
+ MOVEM B,NOWGVL
+ HRRZ A,GLOTOP+1 ; COMPUTE # OF GVAL SLOTS IN USE
+ HRRZ 0,GLOBSP+1
+ SUB A,0
+ ASH A,-2 ; NEGATIVE # OF SLOTS USED
+ MOVEM A,CURGVL
+ HRRZ A,TYPBOT+1 ; GET LENGTH OF TYPE VECTOR
+ HLRE 0,TYPBOT+1
+ SUB A,0
+ HLRZ B,1(A) ; # OF WORDS IN TYPE-VECTOR
+ IDIVI B,2 ; CONVERT TO # OF TYPES
+ MOVEM B,NOWTYP
+ HLRE 0,TYPVEC+1 ; LENGTH OF VISABLE TYPE-VECTOR
+ MOVNS 0
+ IDIVI 0,2 ; GET # OF TYPES
+ MOVEM 0,CURTYP
+ MOVE 0,CODTOP ; GET LENGTH OF STATIONARY IMPURE STORAGE
+ MOVEM 0,NOWSTO
+ SETZB B,D ; ZERO OUT MAXIMUM
+ HRRZ C,FLIST
+LOOPC: HLRZ 0,(C) ; GET BLK LENGTH
+ ADD D,0 ; ADD # OF WORDS IN BLOCK
+ CAMGE B,0 ; SEE IF NEW MAXIMUM
+ MOVE B,0
+ HRRZ C,(C) ; POINT TO NEXT BLOCK
+ JUMPN C,LOOPC ; REPEAT
+ MOVEM D,CURSTO
+ MOVEM B,CURMAX
+ HLRE 0,P ; GET AMOUNT OF ROOM LEFT ON P
+ ADD 0,NOWP
+ SUBI 0,PDLBUF
+ MOVEM 0,CURP
+ MOVSI C,BSTGC ; SET UP BLT FOR GC FIGURES
+ HRRZ B,(P) ; RESTORE B
+ HRR C,B
+ BLT C,(B)STATGC-1
+ HRLI C,BSTAT ; MODIFY BLT FOR STATS
+ HRRI C,STATGC(B)
+ BLT C,(B)STATGC+STATNO-1
+ MOVEI 0,TFIX+.VECT.
+ HRLM 0,(B)STATNO+STATGC ; MOVE IN UTYPE
+ POP P,B
+ POP P,A ; RESTORE TYPE-WORD
+ JRST FINIS
+
+GCRSET: SETZM GCNO ; CALL FROM INIT, ZAP ALL 1ST
+ MOVE 0,[GCNO,,GCNO+1]
+ BLT 0,GCCALL
+ JRST GCSET
+
+
+
+\f
+.GLOBAL PGFIND,PGGIVE,PGTAKE,PGINT
+
+; USER GARBAGE COLLECTOR INTERFACE
+.GLOBAL ILVAL
+
+MFUNCTION GC,SUBR
+ ENTRY
+
+ JUMPGE AB,GC1
+ CAMGE AB,C%M60 ; [-6,,0]
+ JRST TMA
+ PUSHJ P,GETFIX ; GET FREEE MIN IF GIVEN
+ SKIPE A ; SKIP FOR 0 ARGUMENT
+ MOVEM A,FREMIN
+GC1: PUSHJ P,COMPRM ; GET CURRENT USED CORE
+ PUSH P,A
+ CAML AB,C%M40 ; [-4,,0] ; SEE IF 3RD ARG
+ JRST GC5
+ GETYP A,4(AB) ; MAKE SURE A FIX
+ CAIE A,TFIX
+ JRST WTYP ; ARG WRONG TYPE
+ MOVE A,5(AB)
+ MOVEM A,RNUMSP
+ MOVEM A,NUMSWP
+GC5: CAML AB,C%M20 ; [-2,,0] ; SEE IF SECOND ARG
+ JRST GC3
+ GETYP A,2(AB) ; SEE IF NONFALSE
+ CAIE A,TFALSE ; SKIP IF FALSE
+ JRST HAIRGC ; CAUSE A HAIRY GC
+GC3: MOVSI A,TATOM ; CHECK TO SEE IF INTERRUPT FLAG IS ON
+ MOVE B,IMQUOTE AGC-FLAG
+ PUSHJ P,ILVAL
+ CAMN A,$TUNBOUND ; SKIP IF NOT UNBOUND
+ JRST GC2
+ SKIPE GCHPN ; SKIP IF GCHAPPEN IS 0
+ JRST FALRTN ; JUMP TO RETURN FALSE
+GC2: MOVE C,[9.,,0]
+ PUSHJ P,AGC ; COLLECT THAT TRASH
+ PUSHJ P,COMPRM ; HOW MUCH ROOM NOW?
+ POP P,B ; RETURN AMOUNT
+ SUB B,A
+ MOVSI A,TFIX
+ JRST FINIS
+HAIRGC: MOVE B,3(AB)
+ CAIN A,TFIX ; IF FIX THEN CLOBBER NGCS
+ MOVEM B,NGCS
+ MOVEI A,1 ; FORCE VALUE FLUSHING PHASE TO OCCUR
+ MOVEM A,GCHAIR
+ JRST GC2 ; HAIRY GC OCCORS NO MATTER WHAT
+FALRTN: MOVE A,$TFALSE
+ MOVEI B,0 ; RETURN A FALSE-- FOR GC WHICH DIDN'T OCCOR
+ JRST FINIS
+
+
+COMPRM: MOVE A,GCSTOP ; USED SPACE
+ SUB A,GCSBOT
+ POPJ P,
+
+\f
+MFUNCTION GCDMON,SUBR,[GC-MON]
+
+ ENTRY
+
+ MOVEI E,GCMONF
+
+FLGSET: MOVE C,(E) ; GET CURRENT VALUE
+ JUMPGE AB,RETFLG ; RET CURRENT
+ CAMGE AB,C%M20 ; [-3,,]
+ JRST TMA
+ GETYP 0,(AB)
+ SETZM (E)
+ CAIN 0,TFALSE
+ SETOM (E)
+ SKIPL E
+ SETCMM (E)
+
+RETFLG: SKIPL E
+ SETCMM C
+ JUMPL C,NOFLG
+ MOVSI A,TATOM
+ MOVE B,IMQUOTE T
+ JRST FINIS
+
+NOFLG: MOVEI B,0
+ MOVSI A,TFALSE
+ JRST FINIS
+
+.GLOBAL EVATYP,APLTYP,PRNTYP
+
+\fMFUNCTION BLOAT,SUBR
+ ENTRY
+
+ PUSHJ P,SQKIL
+ MOVEI C,0 ; FLAG TO SAY WHETHER NEED A GC
+ MOVSI E,-NBLO ; AOBJN TO BLOATER TABLE
+
+BLOAT2: JUMPGE AB,BLOAT1 ; ALL DONE?
+ PUSHJ P,NXTFIX ; GET NEXT BLOAT PARAM
+ SKIPE A
+ PUSHJ P,@BLOATER(E) ; DISPATCH
+ AOBJN E,BLOAT2 ; COUNT PARAMS SET
+
+ JUMPL AB,TMA ; ANY LEFT...ERROR
+BLOAT1: JUMPE C,BLOATD ; DONE, NO GC NEEDED
+ MOVE C,E ; MOVE IN INDICATOR
+ HRLI C,1 ; INDICATE THAT IT COMES FROM BLOAT
+ SETOM INBLOT
+ PUSHJ P,AGC ; DO ONE
+ SKIPE A,TPBINC ; SMASH POINNTERS
+ MOVE PVP,PVSTOR+1
+ ADDM A,TPBASE+1(PVP)
+ SKIPE A,GLBINC ; GLOBAL SP
+ ADDM A,GLOBASE+1
+ SKIPE A,TYPINC
+ ADDM A,TYPBOT+1
+ SETZM TPBINC ; RESET PARAMS
+ SETZM GLBINC
+ SETZM TYPINC
+
+BLOATD: SKIPN A,GETNUM ; SKIP IF FREE STORAGE REQUEST IN EFFECT
+ JRST BLTFN
+ ADD A,FRETOP ; ADD FRETOP
+ ADDI A,1777 ; ONE BLOCK FOR MARK PDL AND ROUND
+ ANDCMI A,1777 ; TO PAGE BOUNDRY
+ CAML A,PURBOT ; SKIP IF POSSIBLE TO WIN
+ JRST BLFAGC
+ ASH A,-10. ; TO PAGES
+ PUSHJ P,P.CORE ; GRET THE CORE
+ JRST BLFAGC ; LOSE LOSE LOSE
+ MOVE A,FRETOP ; CALCULATE NEW PARAMETERS
+ MOVEM A,RFRETP
+ MOVEM A,CORTOP
+ MOVE B,GCSTOP
+ SETZM 1(B)
+ HRLI B,1(B)
+ HRRI B,2(B)
+ BLT B,-1(A) ; ZERO CORE
+BLTFN: SETZM GETNUM
+ MOVE B,FRETOP
+ SUB B,GCSTOP
+ MOVSI A,TFIX ; RETURN CORE FOUND
+ JRST FINIS
+BLFAGC: MOVN A,FREMIN
+ ADDM A,GETNUM ; FIX UP SO BLOATS CORRECTLY
+ MOVE C,C%11 ; INDICATOR FOR AGC
+ PUSHJ P,AGC ; GARBAGE COLLECT
+ JRST BLTFN ; EXIT
+
+; TABLE OF BLOAT ROUTINES
+
+BLOATER:
+ MAINB
+ TPBLO
+ LOBLO
+ GLBLO
+ TYBLO
+ STBLO
+ PBLO
+ SFREM
+ SLVL
+ SGVL
+ STYP
+ SSTO
+ PUMIN
+ PMUNG
+ TPMUNG
+ NBLO==.-BLOATER
+
+; BLOAT MAIN STORAGE AREA
+
+MAINB: SETZM GETNUM
+ MOVE D,FRETOP ; COMPUTE CURRENT ROOM
+ SUB D,PARTOP
+ CAMGE A,D ; NEED MORE?
+ POPJ P, ; NO, LEAVE
+ SUB A,D
+ MOVEM A,GETNUM ; SAVE
+ POPJ P,
+
+; BLOAT TP STACK (AT TOP)
+
+TPBLO: HLRE D,TP ; GET -SIZE
+ MOVNS B,D
+ ADDI D,1(TP) ; POINT TO DOPE (ALMOST)
+ CAME D,TPGROW ; BLOWN?
+ ADDI D,PDLBUF ; POINT TO REAL DOPE WORD
+ SUB A,B ; SKIP IF GROWTH NEEDED
+ JUMPLE A,CPOPJ
+ ADDI A,63.
+ ASH A,-6 ; CONVERT TO 64 WD BLOCKS
+ CAILE A,377
+ JRST OUTRNG
+ DPB A,[111100,,-1(D)] ; SMASH SPECS IN
+ AOJA C,CPOPJ
+
+; BLOAT TOP LEVEL LOCALS
+
+LOBLO: HLRE D,TP ; GET -SIZE
+ MOVNS B,D
+ ADDI D,1(TP) ; POINT TO DOPE (ALMOST)
+ CAME D,TPGROW ; BLOWN?
+ ADDI D,PDLBUF ; POINT TO REAL DOPE WORD
+ CAMG A,B ; SKIP IF GROWTH NEEDED
+ IMULI A,6 ; 6 WORDS PER BINDING
+ MOVE PVP,PVSTOR+1
+ HRRZ 0,TPBASE+1(PVP)
+ HRRZ B,SPBASE+1(PVP) ; ROOM AVAIL TO E
+ SUB B,0
+ SUBI A,(B) ; HOW MUCH MORE?
+ JUMPLE A,CPOPJ ; NONE NEEDED
+ MOVEI B,TPBINC
+ PUSHJ P,NUMADJ
+ DPB A,[1100,,-1(D)] ; SMASH
+ AOJA C,CPOPJ
+
+; GLOBAL SLOT GROWER
+
+GLBLO: ASH A,2 ; 4 WORDS PER VAR
+ MOVE D,GLOBASE+1 ; CURRENT LIMITS
+ HRRZ B,GLOBSP+1
+ SUBI B,(D)
+ SUBI A,(B) ; NEW AMOUNT NEEDED
+ JUMPLE A,CPOPJ
+ MOVEI B,GLBINC ; WHERE TO KEEP UPDATE
+ PUSHJ P,NUMADJ ; FIX NUMBER
+ HLRE 0,D
+ SUB D,0 ; POINT TO DOPE
+ DPB A,[1100,,(D)] ; AND SMASH
+ AOJA C,CPOPJ
+
+; HERE TO GROW TYPE VECTOR (AND FRIENDS)
+
+TYBLO: ASH A,1 ; TWO WORD PER TYPE
+ HRRZ B,TYPVEC+1 ; FIND CURRENT ROOM
+ MOVE D,TYPBOT+1
+ SUBI B,(D)
+ SUBI A,(B) ; EXTRA NEEDED TO A
+ JUMPLE A,CPOPJ ; NONE NEEDED, LEAVE
+ MOVEI B,TYPINC ; WHERE TO STASH SPEC
+ PUSHJ P,NUMADJ ; FIX NUMBER
+ HLRE 0,D ; POINT TO DOPE
+ SUB D,0
+ DPB A,[1100,,(D)]
+ SKIPE D,EVATYP+1 ; GROW AUX TYPE VECS IF NEEDED
+ PUSHJ P,SGROW1
+ SKIPE D,APLTYP+1
+ PUSHJ P,SGROW1
+ SKIPE D,PRNTYP+1
+ PUSHJ P,SGROW1
+ AOJA C,CPOPJ
+
+; HERE TO CREATE STORAGE SPACE
+
+STBLO: MOVE D,GCSBOT ; HOW MUCH NOW HERE
+ SUB D,CODTOP
+ SUBI A,(D) ; MORE NEEDED?
+ JUMPLE A,CPOPJ
+ MOVEM A,PARNEW ; FORCE PAIR SPACE TO MOVE ON OUT
+ AOJA C,CPOPJ
+
+; BLOAT P STACK
+
+PBLO: HLRE D,P
+ MOVNS B,D
+ SUBI D,5 ; FUDGE FOR THIS CALL
+ SUBI A,(D)
+ JUMPLE A,CPOPJ
+ ADDI B,1(P) ; POINT TO DOPE
+ CAME B,PGROW ; BLOWN?
+ ADDI B,PDLBUF ; NOPE, POIN TO REAL D.W.
+ ADDI A,63.
+ ASH A,-6 ; TO 64 WRD BLOCKS
+ CAILE A,377 ; IN RANGE?
+ JRST OUTRNG
+ DPB A,[111100,,-1(B)]
+ AOJA C,CPOPJ
+
+; SET FREMIN
+
+SFREM: SKIPE A ; DON'T ZERO EMPTY PARAMETER
+ MOVEM A,FREMIN
+ POPJ P,
+
+; SET LVAL INCREMENT
+
+SLVL: IMULI A,6 ; CALCULATE AMOUNT TO GROW B
+ MOVEI B,LVLINC
+ PUSHJ P,NUMADJ
+ MOVEM A,LVLINC
+ POPJ P,
+
+; SET GVAL INCREMENT
+
+SGVL: IMULI A,4. ; # OF SLOTS
+ MOVEI B,GVLINC
+ PUSHJ P,NUMADJ
+ MOVEM A,GVLINC
+ POPJ P,
+
+; SET TYPE INCREMENT
+
+STYP: IMULI A,2 ; CALCULATE NUMBER OF GROW BLOCKS NEEDED
+ MOVEI B,TYPIC
+ PUSHJ P,NUMADJ
+ MOVEM A,TYPIC
+ POPJ P,
+
+; SET STORAGE INCREMENT
+
+SSTO: IDIVI A,2000 ; # OF BLOCKS
+ CAIE B,0 ; REMAINDER?
+ ADDI A,1
+ IMULI A,2000 ; CONVERT BACK TO WORDS
+ MOVEM A,STORIC
+ POPJ P,
+; HERE FOR MINIMUM PURE SPACE
+
+PUMIN: ADDI A,1777
+ ANDCMI A,1777 ; TO PAGE BOUNDRY
+ MOVEM A,PURMIN
+ POPJ P,
+
+; HERE TO ADJUST PSTACK PARAMETERS IN GC
+
+PMUNG: ADDI A,777 ; TO NEAREST 1000 WORD BOUNDRY
+ ANDCMI A,777
+ MOVEM A,PGOOD ; PGOOD
+ ASH A,2 ; PMAX IS 4*PGOOD
+ MOVEM A,PMAX
+ ASH A,-4 ; PMIN IS .25*PGOOD
+ MOVEM A,PMIN
+
+; HERE TO ADJUST GC TPSTACK PARAMS
+
+TPMUNG: ADDI A,777
+ ANDCMI A,777 ; TO NEAREST 1000 WORD BOUNDRY
+ MOVEM A,TPGOOD
+ ASH A,2 ; TPMAX= 4*TPGOOD
+ MOVEM A,TPMAX
+ ASH A,-4 ; TPMIN= .25*TPGOOD
+ MOVEM A,TPMIN
+
+
+; GET NEXT (FIX) ARG
+
+NXTFIX: PUSHJ P,GETFIX
+ ADD AB,C%22
+ POPJ P,
+
+; ROUTINE TO GET POS FIXED ARG
+
+GETFIX: GETYP A,(AB)
+ CAIE A,TFIX
+ JRST WRONGT
+ SKIPGE A,1(AB)
+ JRST BADNUM
+ POPJ P,
+
+
+; GET NUMBERS FIXED UP FOR GROWTH FIELDS
+
+NUMADJ: ADDI A,77 ; ROUND UP
+ ANDCMI A,77 ; KILL CRAP
+ MOVE 0,A
+ MOVNS A ; COMPUTE ADD FACTOR FOR SPEC. POINTER UPDATE
+ HRLI A,-1(A)
+ MOVEM A,(B) ; AND STASH IT
+ MOVE A,0
+ ASH A,-6 ; TO 64 WD BLOCKS
+ CAILE A,377 ; CHECK FIT
+ JRST OUTRNG
+ POPJ P,
+
+; DO SYMPATHETIC GROWTHS
+
+SGROW1: HLRE 0,D
+ SUB D,0
+ DPB A,[111100,,(D)]
+ POPJ P,
+
+\f;FUNCTION TO CONSTRUCT A LIST
+
+MFUNCTION CONS,SUBR
+
+ ENTRY 2
+ GETYP A,2(AB) ;GET TYPE OF 2ND ARG
+ CAIE A,TLIST ;LIST?
+ JRST WTYP2 ;NO , COMPLAIN
+ MOVE C,(AB) ; GET THING TO CONS IN
+ MOVE D,1(AB)
+ HRRZ E,3(AB) ; AND LIST
+ PUSHJ P,ICONS ; INTERNAL CONS
+ JRST FINIS
+
+; COMPILER CALL TO CONS
+
+C1CONS: PUSHJ P,ICELL2
+ JRST ICONS2
+ICONS4: HRRI C,(E)
+ICONS3: MOVEM C,(B) ; AND STORE
+ MOVEM D,1(B)
+TLPOPJ: MOVSI A,TLIST
+ POPJ P,
+
+; INTERNAL CONS--ICONS; C,D VALUE, E CDR
+
+; RELATIVIZE RETURN ADDRESS HERE--MUST BE DIFFERENT FROM ICONS, SINCE
+; ICONS IS CALLED FROM INTERPRETER ENTRIES WHICH ARE THEMSELVES PUSHJ'ED
+; TO: DOING SUBM M,(P) ANYWHERE IN ICONS IS FATAL IF A GC OCCURS.
+
+CICONS: SUBM M,(P)
+ PUSHJ P,ICONS
+ JRST MPOPJ
+
+; INTERNAL CONS TO NIL--INCONS
+
+INCONS: MOVEI E,0
+
+ICONS: GETYP A,C ; CHECK TYPE OF VAL
+ PUSHJ P,NWORDT ; # OF WORDS
+ SOJN A,ICONS1 ; JUMP IF DEFERMENT NEEDED
+ PUSHJ P,ICELL2 ; NO DEFER, GET 2 WORDS FROM PAIR SPACE
+ JRST ICNS2A ; NO CORE, GO GC (SPECIAL PLACE, NOTICE)
+ JRST ICONS4
+
+; HERE IF CONSING DEFERRED
+
+ICONS1: MOVEI A,4 ; NEED 4 WORDS
+ PUSHJ P,ICELL ; GO GET 'EM
+ JRST ICNS2A ; NOT THERE, GC (SAME PLACE AS FOR ICONS)
+ HRLI E,TDEFER ; CDR AND DEFER
+ MOVEM E,(B) ; STORE
+ MOVEI E,2(B) ; POINT E TO VAL CELL
+ HRRZM E,1(B)
+ MOVEM C,(E) ; STORE VALUE
+ MOVEM D,1(E)
+ JRST TLPOPJ
+
+
+
+; HERE TO GC ON A CONS
+
+; HERE FROM C1CONS
+ICONS2: SUBM M,(P)
+ PUSHJ P,ICONSG
+ SUBM M,(P)
+ JRST C1CONS
+
+; HERE FROM ICONS (THUS CICONS, INDIRECTLY), ICONS1
+ICNS2A: PUSHJ P,ICONSG
+ JRST ICONS
+
+; REALLY DO GC
+ICONSG: PUSH TP,C ; SAVE VAL
+ PUSH TP,D
+ PUSH TP,$TLIST
+ PUSH TP,E ; SAVE VITAL STUFF
+ ADDM A,GETNUM ; AMOUNT NEEDED
+ MOVE C,[3,,1] ; INDICATOR FOR AGC
+ PUSHJ P,INQAGC ; ATTEMPT TO WIN
+ MOVE D,-2(TP) ; RESTORE VOLATILE STUFF
+ MOVE C,-3(TP)
+ MOVE E,(TP)
+ SUB TP,C%44 ; [4,,4]
+ POPJ P, ; BACK TO DRAWING BOARD
+
+; SUBROUTINE TO ALLOCATE WORDS IN PAIR SPACE. CALLS AGC IF NEEDED
+
+CELL2: MOVEI A,2 ; USUAL CASE
+CELL: PUSHJ P,ICELL ; INTERNAL
+ JRST .+2 ; LOSER
+ POPJ P,
+
+ ADDM A,GETNUM ; AMOUNT REQUIRED
+ PUSH P,A ; PREVENT AGC DESTRUCTION
+ MOVE C,[3,,1] ; INDICATOR FOR AGC
+ PUSHJ P,INQAGC
+ POP P,A
+ JRST CELL ; AND TRY AGAIN
+
+; INTERNAL CELL GETTER, SKIPS IF ROO EXISTS, ELSE DOESN'T
+
+ICELL2: MOVEI A,2 ; MOST LIKELY CAE
+ICELL: SKIPE B,RCL
+ JRST ICELRC ;SEE IF WE CAN RE-USE A RECYCLE CELL
+ MOVE B,PARTOP ; GET TOP OF PAIRS
+ ADDI B,(A) ; BUMP
+ CAMLE B,FRETOP ; SKIP IF OK.
+ JRST VECTRY ; LOSE
+ EXCH B,PARTOP ; SETUP NEW PARTOP AND RETURN POINTER
+ ADDM A,USEFRE
+ JRST CPOPJ1 ; SKIP RETURN
+
+; TRY RECYCLING USING A VECTOR FROM RCLV
+
+VECTRY: SKIPN B,RCLV ; SKIP IF VECTOR EXISTS
+ POPJ P,
+ PUSH P,C
+ PUSH P,A
+ MOVEI C,RCLV
+VECTR1: HLRZ A,(B) ; GET LENGTH
+ SUB A,(P)
+ JUMPL A,NXTVEC ; DOESN'T SATISFY TRY AGAIN
+ CAIN A,1 ; MAKE SURE NOT LEFT WITH A SINGLE SLOT
+ JRST NXTVEC
+ JUMPN A,SOML ; SOME ARE LEFT
+ HRRZ A,(B)
+ HRRM A,(C)
+ HLRZ A,(B)
+ SETZM (B)
+ SETZM -1(B) ; CLEAR DOPE WORDS
+ SUBI B,-1(A)
+ POP P,A ; CLEAR STACK
+ POP P,C
+ JRST CPOPJ1
+SOML: HRLM A,(B) ; SMASH AMOUNT LEFT
+ SUBI B,-1(A) ; GET TO BEGINNING
+ SUB B,(P)
+ POP P,A
+ POP P,C
+ JRST CPOPJ1
+NXTVEC: MOVEI C,(B)
+ HRRZ B,(B) ; GET NEXT
+ JUMPN B,VECTR1
+ POP P,A
+ POP P,C
+ POPJ P,
+
+ICELRC: CAIE A,2
+ JRST ICELL+2 ;IF HE DOESNT WANT TWO, USE OLD METHOD
+ PUSH P,A
+ MOVE A,(B)
+ HRRZM A,RCL
+ POP P,A
+ SETZM (B) ;GIVE HIM A CLEAN RECYCLED CELL
+ SETZM 1(B)
+ JRST CPOPJ1 ;THAT IT
+
+
+\f;FUNCTION TO BUILD A LIST OF MANY ELEMENTS
+
+IMFUNCTION LIST,SUBR
+ ENTRY
+
+ PUSH P,$TLIST
+LIST12: HLRE A,AB ;GET -NUM OF ARGS
+ PUSH TP,$TAB
+ PUSH TP,AB
+ MOVNS A ;MAKE IT +
+ JUMPE A,LISTN ;JUMP IF 0
+ SKIPE RCL ;SEE IF WE WANT TO DO ONE AT A TIME
+ JRST LST12R ;TO GET RECYCLED CELLS
+ PUSHJ P,CELL ;GET NUMBER OF CELLS
+ PUSH TP,(P) ;SAVE IT
+ PUSH TP,B
+ SUB P,C%11
+ LSH A,-1 ;NUMBER OF REAL LIST ELEMENTS
+
+CHAINL: ADDI B,2 ;LOOP TO CHAIN ELEMENTS
+ HRRZM B,-2(B) ;CHAIN LAST ONE TO NEXT ONE
+ SOJG A,.-2 ;LOOP TIL ALL DONE
+ CLEARM B,-2(B) ;SET THE LAST CDR TO NIL
+
+; NOW LOBEER THE DATA IN TO THE LIST
+
+ MOVE D,AB ; COPY OF ARG POINTER
+ MOVE B,(TP) ;RESTORE LIS POINTER
+LISTLP: GETYP A,(D) ;GET TYPE
+ PUSHJ P,NWORDT ;GET NUMBER OF WORDS
+ SOJN A,LDEFER ;NEED TO DEFER POINTER
+ GETYP A,(D) ;NOW CLOBBER ELEMENTS
+ HRLM A,(B)
+ MOVE A,1(D) ;AND VALUE..
+ MOVEM A,1(B)
+LISTL2: HRRZ B,(B) ;REST B
+ ADD D,C%22 ;STEP ARGS
+ JUMPL D,LISTLP
+
+ POP TP,B
+ POP TP,A
+ SUB TP,C%22 ; CLEANUP STACK
+ JRST FINIS
+
+
+LST12R: ASH A,-1 ;ONE AT A TIME TO GET RECYCLED CELLS
+ JUMPE A,LISTN
+ PUSH P,A ;SAVE COUNT ON STACK
+ SETZM E
+ SETZB C,D
+ PUSHJ P,ICONS
+ MOVE E,B ;LOOP AND CHAIN TOGETHER
+ SOSLE (P)
+ JRST .-4
+ PUSH TP,-1(P) ;PUSH ON THE TYPE WE WANT
+ PUSH TP,B
+ SUB P,C%22 ;CLEAN UP AFTER OURSELVES
+ JRST LISTLP-2 ;AND REJOIN MAIN STREAM
+
+
+; MAKE A DEFERRED POINTER
+
+LDEFER: PUSH TP,$TLIST ;SAVE CURRENT POINTER
+ PUSH TP,B
+ MOVEM D,1(TB) ; SAVE ARG HACKER
+ PUSHJ P,CELL2
+ MOVE D,1(TB)
+ GETYPF A,(D) ;GET FULL DATA
+ MOVE C,1(D)
+ MOVEM A,(B)
+ MOVEM C,1(B)
+ MOVE C,(TP) ;RESTORE LIST POINTER
+ MOVEM B,1(C) ;AND MAKE THIS BE THE VALUE
+ MOVSI A,TDEFER
+ HLLM A,(C) ;AND STORE IT
+ MOVE B,C
+ SUB TP,C%22
+ JRST LISTL2
+
+LISTN: MOVEI B,0
+ POP P,A
+ JRST FINIS
+
+; BUILD A FORM
+
+IMFUNCTION FORM,SUBR
+
+ ENTRY
+
+ PUSH P,$TFORM
+ JRST LIST12
+
+\f; COMPILERS CALLS TO FORM AND LIST A/ COUNT ELEMENTS ON STACK
+
+IILIST: SUBM M,(P)
+ PUSHJ P,IILST
+ MOVSI A,TLIST
+ JRST MPOPJ
+
+IIFORM: SUBM M,(P)
+ PUSHJ P,IILST
+ MOVSI A,TFORM
+ JRST MPOPJ
+
+IILST: JUMPE A,IILST0 ; NIL WHATSIT
+ PUSH P,A
+ MOVEI E,0
+IILST1: POP TP,D
+ POP TP,C
+ PUSHJ P,ICONS ; CONS 'EM UP
+ MOVEI E,(B)
+ SOSE (P) ; COUNT
+ JRST IILST1
+
+ SUB P,C%11
+ POPJ P,
+
+IILST0: MOVEI B,0
+ POPJ P,
+
+\f;FUNCTION TO BUILD AN IMPLICIT LIST
+
+MFUNCTION ILIST,SUBR
+ ENTRY
+ PUSH P,$TLIST
+ILIST2: JUMPGE AB,TFA ;NEED AT LEAST ONE ARG
+ CAMGE AB,C%M40 ; [-4,,0] ; NO MORE THAN TWO ARGS
+ JRST TMA
+ PUSHJ P,GETFIX ; GET POS FIX #
+ JUMPE A,LISTN ;EMPTY LIST ?
+ CAML AB,C%M20 ; [-2,,0] ;ONLY ONE ARG?
+ JRST LOSEL ;YES
+ PUSH P,A ;SAVE THE CURRENT VALUE OF LENGTH FOR LOOP ITERATION
+ILIST0: PUSH TP,2(AB)
+ PUSH TP,(AB)3
+ MCALL 1,EVAL
+ PUSH TP,A
+ PUSH TP,B
+ SOSLE (P)
+ JRST ILIST0
+ POP P,C
+ILIST1: MOVE C,(AB)+1 ;REGOBBLE LENGTH
+ ACALL C,LIST
+ILIST3: POP P,A ; GET FINAL TYPE
+ JRST FINIS
+
+
+LOSEL: PUSH P,A ; SAVE COUNT
+ MOVEI E,0
+
+LOSEL1: SETZB C,D ; TLOSE,,0
+ PUSHJ P,ICONS
+ MOVEI E,(B)
+ SOSLE (P)
+ JRST LOSEL1
+
+ SUB P,C%11
+ JRST ILIST3
+
+; IMPLICIT FORM
+
+MFUNCTION IFORM,SUBR
+
+ ENTRY
+ PUSH P,$TFORM
+ JRST ILIST2
+
+\f; IVECTOR AND IUVECTOR--GET VECTOR AND UVECTOR OF COMPUTED VALUES
+
+MFUNCTION VECTOR,SUBR,[IVECTOR]
+
+ MOVEI C,1
+ JRST VECTO3
+
+MFUNCTION UVECTOR,SUBR,[IUVECTOR]
+
+ MOVEI C,0
+VECTO3: ENTRY
+ JUMPGE AB,TFA ; AT LEAST ONE ARG
+ CAMGE AB,C%M40 ; [-4,,0] ; NOT MORE THAN 2
+ JRST TMA
+ PUSHJ P,GETFIX ; GET A POS FIXED NUMBER
+ LSH A,(C) ; A-> NUMBER OF WORDS
+ PUSH P,C ; SAVE FOR LATER
+ PUSHJ P,IBLOCK ; GET BLOCK (TURN ON BIT APPROPRIATELY)
+ POP P,C
+ HLRE A,B ; START TO
+ SUBM B,A ; FIND DOPE WORD
+ MOVSI D,.VECT. ; FOR GCHACK
+ IORM D,(A)
+ JUMPE C,VECTO4
+ MOVSI D,400000 ; GET NOT UNIFORM BIT
+ IORM D,(A) ; INTO DOPE WORD
+ SKIPA A,$TVEC ; GET TYPE
+VECTO4: MOVSI A,TUVEC
+ CAML AB,C%M20 ; [-2,,0] ; SKIP IF ARGS NEED TO BE HACKED
+ JRST FINIS
+ JUMPGE B,FINIS ; DON'T EVAL FOR EMPTY CASE
+
+ PUSH TP,A ; SAVE THE VECTOR
+ PUSH TP,B
+ PUSH TP,A
+ PUSH TP,B
+
+ JUMPE C,UINIT
+ JUMPGE B,FINIS ; EMPTY VECTOR, LEAVE
+INLP: PUSHJ P,IEVAL ; EVAL EXPR
+ MOVEM A,(C)
+ MOVEM B,1(C)
+ ADD C,C%22 ; BUMP VECTOR
+ MOVEM C,(TP)
+ JUMPL C,INLP ; IF MORE DO IT
+
+GETVEC: MOVE A,-3(TP)
+ MOVE B,-2(TP)
+ SUB TP,C%44 ; [4,,4]
+ JRST FINIS
+
+; HERE TO FILL UP A UVECTOR
+
+UINIT: PUSHJ P,IEVAL ; HACK THE 1ST VALUE
+ GETYP A,A ; GET TYPE
+ PUSH P,A ; SAVE TYPE
+ PUSHJ P,NWORDT ; SEE IF IT CAN BE UNIFORMED
+ SOJN A,CANTUN ; COMPLAIN
+STJOIN: MOVE C,(TP) ; RESTORE POINTER
+ ADD C,1(AB) ; POINT TO DOPE WORD
+ MOVE A,(P) ; GET TYPE
+ HRLZM A,(C) ; STORE IN D.W.
+ MOVSI D,.VECT. ; FOR GCHACK
+ IORM D,(C)
+ MOVE C,(TP) ; GET BACK VECTOR
+ SKIPE 1(AB)
+ JRST UINLP1 ; START FILLING UV
+ JRST GETVE1
+
+UINLP: MOVEM C,(TP) ; SAVE PNTR
+ PUSHJ P,IEVAL ; EVAL THE EXPR
+ GETYP A,A ; GET EVALED TYPE
+ CAIE A,@(P) ; WINNER?
+ JRST WRNGSU ; SERVICE ERROR FOR UVECTOR,STORAGE
+UINLP1: MOVEM B,(C) ; STORE
+ AOBJN C,UINLP
+GETVE1: SUB P,C%11
+ JRST GETVEC ; AND RETURN VECTOR
+
+IEVAL: PUSH TP,2(AB)
+ PUSH TP,3(AB)
+ MCALL 1,EVAL
+ MOVE C,(TP)
+ POPJ P,
+
+; ISTORAGE -- GET STORAGE OF COMPUTED VALUES
+
+MFUNCTION ISTORAGE,SUBR
+ ENTRY
+ JUMPGE AB,TFA
+ CAMGE AB,C%M40 ; [-4,,0] ; AT LEAST ONE ARG
+ JRST TMA
+ PUSHJ P,GETFIX ; POSITIVE COUNT FIRST ARG
+ PUSHJ P,CAFRE ; GET CORE
+ MOVN B,1(AB) ; -COUNT
+ HRL A,B ; PUT IN LHW (A)
+ MOVM B,B ; +COUNT
+ HRLI B,2(B) ; LENGTH + 2
+ ADDI B,(A) ; MAKE POINTER TO DOPE WORDS
+ HLLZM B,1(B) ; PUT TOTAL LENGTH IN 2ND DOPE
+ HRRM A,1(B) ; PUT ADDRESS IN RHW (STORE DOES THIS TOO).
+ MOVE B,A
+ MOVSI A,TSTORAGE
+ CAML AB,C%M20 ; [-2,,0] ; SECOND ARG TO EVAL?
+ JRST FINIS ; IF NOT, RETURN EMPTY
+ PUSH TP,A
+ PUSH TP,B
+ PUSH TP,A
+ PUSH TP,B
+ PUSHJ P,IEVAL ; EVALUATE FOR FIRST VALUE
+ GETYP A,A
+ PUSH P,A ; FOR COMPARISON LATER
+ PUSHJ P,SAT
+ CAIN A,S1WORD
+ JRST STJOIN ;TREAT LIKE A UVECTOR
+; IF NOT 1-WORD TYPES, CANNOT STORE, SO COMPLAIN
+ PUSHJ P,FREESV ; FREE STORAGE VECTOR
+ ERRUUO EQUOTE DATA-CANT-GO-IN-STORAGE
+
+; FOR STORAGE, MUST FREE THE CORE ELSE IT IS LOST (NO GC)
+FREESV: MOVE A,1(AB) ; GET COUNT
+ ADDI A,2 ; FOR DOPE
+ HRRZ B,(TP) ; GET ADDRESS
+ PUSHJ P,CAFRET ; FREE THE CORE
+ POPJ P,
+
+\f
+; INTERNAL VECTOR ALLOCATOR. A/SIZE OF VECTOR (NOT INCLUDING DOPE WORDS)
+
+IBLOK1: ASH A,1 ; TIMES 2
+GIBLOK: TLOA A,400000 ; FUNNY BIT
+IBLOCK: TLZ A,400000 ; NO BIT ON
+ TLO A,.VECT. ; TURN ON BIT FOR GCHACK
+ ADDI A,2 ; COMPENSATE FOR DOPE WORDS
+IBLOK2: SKIPE B,RCLV ; ANY TO RECYCLE?
+ JRST RCLVEC
+NORCL: MOVE B,GCSTOP ; POINT TO BOTTOM OF SPACE
+ PUSH P,B ; SAVE TO BUILD PTR
+ ADDI B,(A) ; ADD NEEDED AMOUNT
+ CAML B,FRETOP ; SKIP IF NO GC NEEDED
+ JRST IVECT1
+ MOVEM B,GCSTOP ; WIN, GET POINTER TO BLOCK AND UPDATE VECBOT
+ ADDM A,USEFRE
+ HRRZS USEFRE
+ HRLZM A,-1(B) ; STORE LENGTH IN DOPE WORD
+ HLLZM A,-2(B) ; AND BIT
+ HRRM B,-1(B) ; SMASH IN RELOCATION
+ SOS -1(B)
+ POP P,B ; RESTORE PTR TO BOTTOM OF VECTOR
+ HRROS B ; POINT TO START OF VECTOR
+ TLC B,-3(A) ; SETUP COUNT
+ HRRI A,TVEC
+ SKIPL A
+ HRRI A,TUVEC
+ MOVSI A,(A)
+ POPJ P,
+
+; HERE TO DO A GC ON A VECTOR ALLOCATION
+
+IVECT1: PUSH P,0
+ PUSH P,A ; SAVE DESIRED LENGTH
+ HRRZ 0,A
+ ADDM 0,GETNUM ; AND STORE AS DESIRED AMOUNT
+ MOVE C,[4,,1] ; GET INDICATOR FOR AGC
+ PUSHJ P,INQAGC
+ POP P,A
+ POP P,0
+ POP P,B
+ JRST IBLOK2
+
+
+; INTERNAL EVECTOR (CALLED FROM READ) A/ #OF THINGS
+; ITEMS ON TOP OF STACK
+
+IEVECT: ASH A,1 ; TO NUMBER OF WORDS
+ PUSH P,A
+ PUSHJ P,IBLOCK ; GET VECTOR
+ HLRE D,B ; FIND DW
+ SUBM B,D ; A POINTS TO DW
+ MOVSI 0,400000+.VECT.
+ MOVEM 0,(D) ; CLOBBER NON UNIF BIT
+ POP P,A ; RESTORE COUNT
+ JUMPE A,IVEC1 ; 0 LNTH, DONE
+ MOVEI C,(TP) ; BUILD BLT
+ SUBI C,(A)-1 ; C POINTS TO 1ST ITEM ON STACK
+ MOVSI C,(C)
+ HRRI C,(B) ; B/ SOURCE,,DEST
+ BLT C,-1(D) ; XFER THE DATA
+ HRLI A,(A)
+ SUB TP,A ; FLUSH STACKAGE
+IVEC1: MOVSI A,TVEC
+ POPJ P,
+
+
+; COMPILERS CALL
+
+CIVEC: SUBM M,(P)
+ PUSHJ P,IEVECT
+ JRST MPOPJ
+
+
+\f; INTERNAL CALL TO EUVECTOR
+
+IEUVEC: PUSH P,A ; SAVE LENGTH
+ PUSHJ P,IBLOCK
+ MOVE A,(P)
+ JUMPE A,IEUVE1 ; EMPTY, LEAVE
+ ASH A,1 ; NOW FIND STACK POSITION
+ MOVEI C,(TP) ; POINT TO TOP
+ MOVE D,B ; COPY VEC POINTER
+ SUBI C,-1(A) ; POINT TO 1ST DATUM
+ GETYP A,(C) ; CHECK IT
+ PUSHJ P,NWORDT
+ SOJN A,CANTUN ; WONT FIT
+ GETYP E,(C)
+
+IEUVE2: GETYP 0,(C) ; TYPE OF EL
+ CAIE 0,(E) ; MATCH?
+ JRST WRNGUT
+ MOVE 0,1(C)
+ MOVEM 0,(D) ; CLOBBER
+ ADDI C,2
+ AOBJN D,IEUVE2 ; LOOP
+ TRO E,.VECT.
+ HRLZM E,(D) ; STORE UTYPE
+IEUVE1: POP P,A ; GET COUNY
+ ASH A,1 ; MUST FLUSH 2 TIMES # OF ELEMENTS
+ HRLI A,(A)
+ SUB TP,A ; CLEAN UP STACK
+ MOVSI A,TUVEC
+ POPJ P,
+
+; COMPILER'S CALL
+
+CIUVEC: SUBM M,(P)
+ PUSHJ P,IEUVEC
+ JRST MPOPJ
+
+IMFUNCTION EVECTOR,SUBR,[VECTOR]
+ ENTRY
+ HLRE A,AB
+ MOVNS A
+ PUSH P,A ;SAVE NUMBER OF WORDS
+ PUSHJ P,IBLOCK ; GET WORDS
+ MOVEI D,-1(B) ; SETUP FOR BLT AND DOPE CLOBBER
+ JUMPGE B,FINISV ;DONT COPY A ZERO LENGTH VECTOR
+
+ HRLI C,(AB) ;START BUILDING BLT POINTER
+ HRRI C,(B) ;TO ADDRESS
+ ADDI D,@(P) ;SET D TO FINAL ADDRESS
+ BLT C,(D)
+FINISV: MOVSI 0,400000+.VECT.
+ MOVEM 0,1(D) ; MARK AS GENERAL
+ SUB P,C%11
+ MOVSI A,TVEC
+ JRST FINIS
+
+
+
+\f;EXPLICIT VECTORS FOR THE UNIFORM CSE
+
+IMFUNCTION EUVECTOR,SUBR,[UVECTOR]
+
+ ENTRY
+ HLRE A,AB ;-NUM OF ARGS
+ MOVNS A
+ ASH A,-1 ;NEED HALF AS MANY WORDS
+ PUSH P,A
+ JUMPGE AB,EUV1 ; DONT CHECK FOR EMPTY
+ GETYP A,(AB) ;GET FIRST ARG
+ PUSHJ P,NWORDT ;SEE IF NEEDS EXTRA WORDS
+ SOJN A,CANTUN
+EUV1: POP P,A
+ PUSHJ P,IBLOCK ; GET VECT
+ JUMPGE B,FINISU
+
+ GETYP C,(AB) ;GET THE FIRST TYPE
+ MOVE D,AB ;COPY THE ARG POINTER
+ MOVE E,B ;COPY OF RESULT
+
+EUVLP: GETYP 0,(D) ;GET A TYPE
+ CAIE 0,(C) ;SAME?
+ JRST WRNGUT ;NO , LOSE
+ MOVE 0,1(D) ;GET GOODIE
+ MOVEM 0,(E) ;CLOBBER
+ ADD D,C%22 ;BUMP ARGS POINTER
+ AOBJN E,EUVLP
+
+ TRO C,.VECT.
+ HRLM C,(E) ;CLOBBER UNIFORM TYPE IN
+FINISU: MOVSI A,TUVEC
+ JRST FINIS
+
+WRNGSU: GETYP A,-1(TP)
+ CAIE A,TSTORAGE
+ JRST WRNGUT ;IF UVECTOR
+ PUSHJ P,FREESV ;FREE STORAGE VECTOR
+ ERRUUO EQUOTE TYPES-DIFFER-IN-STORAGE-OBJECT
+
+WRNGUT: ERRUUO EQUOTE TYPES-DIFFER-IN-UNIFORM-VECTOR
+
+CANTUN: ERRUUO EQUOTE DATA-CANT-GO-IN-UNIFORM-VECTOR
+
+BADNUM: ERRUUO EQUOTE NEGATIVE-ARGUMENT
+\f; FUNCTION TO GROW A VECTOR
+REPEAT 0,[
+MFUNCTION GROW,SUBR
+
+ ENTRY 3
+
+ MOVEI D,0 ;STACK HACKING FLAG
+ GETYP A,(AB) ;FIRST TYPE
+ PUSHJ P,SAT ;GET STORAGE TYPE
+ GETYP B,2(AB) ;2ND ARG
+ CAIE A,STPSTK ;IS IT ASTACK
+ CAIN A,SPSTK
+ AOJA D,GRSTCK ;YES, WIN
+ CAIE A,SNWORD ;UNIFORM VECTOR
+ CAIN A,S2NWORD ;OR GENERAL
+GRSTCK: CAIE B,TFIX ;IS 2ND FIXED
+ JRST WTYP2 ;COMPLAIN
+ GETYP B,4(AB)
+ CAIE B,TFIX ;3RD ARG
+ JRST WTYP3 ;LOSE
+
+ MOVEI E,1 ;UNIFORM/GENERAL FLAG
+ CAIE A,SNWORD ;SKIP IF UNIFORM
+ CAIN A,SPSTK ;DONT SKIP IF UNIFORM PDL
+ MOVEI E,0
+
+ HRRZ B,1(AB) ;POINT TO START
+ HLRE A,1(AB) ;GET -LENGTH
+ SUB B,A ;POINT TO DOPE WORD
+ SKIPE D ;SKIP IF NOT STACK
+ ADDI B,PDLBUF ;FUDGE FOR PDL
+ HLLZS (B) ;ZERO OUT GROWTH SPECS
+ SKIPN A,3(AB) ;ANY TOP GROWTH?
+ JRST GROW1 ;NO, LOOK FOR BOTTOM GROWTH
+ ASH A,(E) ;MULT BY 2 IF GENERAL
+ ADDI A,77 ;ROUND TO NEAREST BLOCK
+ ANDCMI A,77 ;CLEAR LOW ORDER BITS
+ ASH A,9-6 ;DIVIDE BY 100 AND SHIFT TO POSTION
+ TRZE A,400000 ;CONVERT TO SIGN MAGNITUDE
+ MOVNS A
+ TLNE A,-1 ;SKIP IF NOT TOO BIG
+ JRST GTOBIG ;ERROR
+GROW1: SKIPN C,5(AB) ;CHECK LOW GROWTH
+ JRST GROW4 ;NONE, SKIP
+ ASH C,(E) ;GENRAL FUDGE
+ ADDI C,77 ;ROUND
+ ANDCMI C,77 ;FUDGE FOR VALUE RETURN
+ PUSH P,C ;AND SAVE
+ ASH C,-6 ;DIVIDE BY 100
+ TRZE C,400 ;CONVERT TO SIGN MAGNITUDE
+ MOVNS C
+ TDNE C,[-1,,777000] ;CHECK FOR OVERFLOW
+ JRST GTOBIG
+GROW2: HLRZ E,1(B) ;GET TOTAL LENGTH OF VECTOR
+ MOVNI E,-1(E)
+ HRLI E,(E) ;TO BOTH HALVES
+ ADDI E,1(B) ;POINTS TO TOP
+ SKIPE D ;STACK?
+ ADD E,[PDLBUF,,0] ;YES, FUDGE LENGTH
+ SKIPL D,(P) ;SHRINKAGE?
+ JRST GROW3 ;NO, CONTINUE
+ MOVNS D ;PLUSIFY
+ HRLI D,(D) ;TO BOTH HALVES
+ ADD E,D ;POINT TO NEW LOW ADDR
+GROW3: IORI A,(C) ;OR TOGETHER
+ HRRM A,(B) ;DEPOSIT INTO DOPEWORD
+ PUSH TP,(AB) ;PUSH TYPE
+ PUSH TP,E ;AND VALUE
+ SKIPE A ;DON'T GC FOR NOTHING
+ MOVE C,[2,,0] ; GET INDICATOR FOR AGC
+ PUSHJ P,AGC
+ JUMPL A,GROFUL
+ POP P,C ;RESTORE GROWTH
+ HRLI C,(C)
+ POP TP,B ;GET VECTOR POINTER
+ SUB B,C ;POINT TO NEW TOP
+ POP TP,A
+ JRST FINIS
+
+GROFUL: SUB P,C%11 ; CLEAN UP STACK
+ SUB TP,C%22
+ PUSHJ P,FULLOS
+ JRST GROW
+
+GTOBIG: ERRUUO EQUOTE ATTEMPT-TO-GROW-VECTOR-TOO-MUCH
+GROW4: PUSH P,[0] ;0 BOTTOM GROWTH
+ JRST GROW2
+]
+FULLOS: ERRUUO EQUOTE NO-STORAGE
+
+
+\f; SUBROUTINE TO BUILD CHARACTER STRING GOODIES
+
+MFUNCTION BYTES,SUBR
+
+ ENTRY
+ MOVEI D,1
+ JUMPGE AB,TFA
+ GETYP 0,(AB)
+ CAIE 0,TFIX
+ JRST WTYP1
+ MOVE E,1(AB)
+ ADD AB,C%22
+ JRST STRNG1
+
+IMFUNCTION STRING,SUBR
+
+ ENTRY
+
+ MOVEI D,0
+ MOVEI E,7
+STRNG1: MOVE B,AB ;COPY ARG POINTER
+ MOVEI C,0 ;INITIALIZE COUNTER
+ PUSH TP,$TAB ;SAVE A COPY
+ PUSH TP,B
+ HLRE A,B ; GET # OF ARGS
+ MOVNS A
+ ASH A,-1 ; 1/2 FOR # OF ARGS
+ PUSHJ P,IISTRN
+ JRST FINIS
+
+IISTRN: PUSH P,E
+ JUMPL E,OUTRNG
+ CAILE E,36.
+ JRST OUTRNG
+ SKIPN E,A ; SKIP IF ARGS EXIST
+ JRST MAKSTR ; ALL DONE
+
+STRIN2: GETYP 0,(B) ;GET TYPE CODE
+ CAMN 0,SING(D) ; SINGLE CHARACTER OR FIX?
+ AOJA C,STRIN1
+ CAME 0,MULTI(D) ; OR STRING OR BYTE-STRING
+ JRST WRONGT ;NEITHER
+ HRRZ 0,(B) ; GET CHAR COUNT
+ ADD C,0 ; AND BUMP
+
+STRIN1: ADD B,C%22
+ SOJG A,STRIN2
+
+; NOW GET THE NECESSARY VECTOR
+
+MAKSTR: HRL C,MULTI(D) ; FINAL TYPE,, CHAR COUNT
+ PUSH P,C ; SAVE CHAR COUNT
+ PUSH P,E ; SAVE ARG COUNT
+ MOVEI D,36.
+ IDIV D,-2(P) ; A==> BYTES PER WORD
+ MOVEI A,(C) ; LNTH+4 TO A
+ ADDI A,-1(D)
+ IDIVI A,(D)
+ LSH E,12.
+ MOVE D,-2(P)
+ DPB D,[060600,,E]
+ HRLM E,-2(P) ; SAVE REMAINDER
+ PUSHJ P,IBLOCK
+
+ POP P,A
+ JUMPGE B,DONEC ; 0 LENGTH, NO STRING
+ HRLI B,440000 ;CONVERT B TO A BYTE POINTER
+ HRRZ 0,-1(P) ; BYTE SIZE
+ DPB 0,[300600,,B]
+ MOVE C,(TP) ; POINT TO ARGS AGAIN
+
+NXTRG1: GETYP D,(C) ;GET AN ARG
+ CAIN D,TFIX
+ JRST .+3
+ CAIE D,TCHRS
+ JRST TRYSTR
+ MOVE D,1(C) ; GET IT
+ IDPB D,B ;AND DEPOSIT IT
+ JRST NXTARG
+
+TRYSTR: MOVE E,1(C) ;GET BYTER
+ HRRZ 0,(C) ;AND COUNT
+NXTCHR: SOJL 0,NXTARG ; IF RUNOUT, GET NEXT ARG
+ ILDB D,E ;AND GET NEXT
+ IDPB D,B ; AND DEPOSIT SAME
+ JRST NXTCHR
+
+NXTARG: ADD C,C%22 ;BUMP ARG POINTER
+ SOJG A,NXTRG1
+ ADDI B,1
+
+DONEC: MOVSI C,TCHRS+.VECT.
+ TLO B,400000
+ HLLM C,(B) ;AND CLOBBER AWAY
+ HLRZ C,1(B) ;GET LENGTH BACK
+ POP P,A
+ SUBI B,-1(C)
+ HLL B,(P) ;MAKE A BYTE POINTER
+ SUB P,C%11
+ POPJ P,
+
+SING: TCHRS
+ TFIX
+
+MULTI: TCHSTR
+ TBYTE
+
+
+; COMPILER'S CALL TO MAKE A STRING
+
+CISTNG: TDZA D,D
+
+; COMPILERS CALL TO MAKE A BYTE STRING
+
+CBYTES: MOVEI D,1
+ SUBM M,(P)
+ MOVEI C,0 ; INIT CHAR COUNTER
+ MOVEI B,(A) ; SET UP STACK POINTER
+ ASH B,1 ; * 2 FOR NO. OF SLOTS
+ HRLI B,(B)
+ SUBM TP,B ; B POINTS TO ARGS
+ PUSH P,D
+ MOVEI E,7
+ JUMPE D,CBYST
+ GETYP 0,1(B) ; CHECK BYTE SIZE
+ CAIE 0,TFIX
+ JRST WRONGT
+ MOVE E,2(B)
+ ADD B,C%22
+ SUBI A,1
+CBYST: ADD B,C%11
+ PUSH TP,$TTP
+ PUSH TP,B
+ PUSHJ P,IISTRN ; MAKE IT HAPPEN
+ MOVE TP,(TP) ; FLUSH ARGS
+ SUB TP,C%11
+ POP P,D
+ JUMPE D,MPOPJ
+ SUB TP,C%22
+ JRST MPOPJ
+
+\f;BUILD IMPLICT STRING
+
+MFUNCTION IBYTES,SUBR
+
+ ENTRY
+
+ CAML AB,C%M20 ; [-3,,] ; AT LEAST 2
+ JRST TFA
+ CAMGE AB,C%M60 ; [-7,,] ; NO MORE THAN 3
+ JRST TMA
+ PUSHJ P,GETFIX ; GET BYTE SIZE
+ JUMPL A,OUTRNG
+ CAILE A,36.
+ JRST OUTRNG
+ PUSH P,[TFIX]
+ PUSH P,A
+ PUSH P,$TBYTE
+ ADD AB,C%22
+ MOVEM AB,ABSAV(TB)
+ JRST ISTR1
+
+MFUNCTION ISTRING,SUBR
+
+ ENTRY
+ JUMPGE AB,TFA ; TOO FEW ARGS
+ CAMGE AB,C%M40 ; [-4,,0] ; VERIFY NOT TOO MANY ARGS
+ JRST TMA
+ PUSH P,[TCHRS]
+ PUSH P,[7]
+ PUSH P,$TCHSTR
+ISTR1: PUSHJ P,GETFIX
+ MOVEI C,36.
+ IDIV C,-1(P)
+ ADDI A,-1(C)
+ IDIVI A,(C) ; # OF WORDS NEEDED TO A
+ ASH D,12.
+ MOVE C,-1(P) ; GET BYTE SIZE
+ DPB C,[060600,,D]
+ PUSH P,D
+ PUSHJ P,IBLOCK
+ HLRE C,B ; -LENGTH TO C
+ SUBM B,C ; LOCN OF DOPE WORD TO C
+ HRLI D,TCHRS+.VECT. ; CLOBBER ITS TYPE
+ HLLM D,(C)
+ MOVE A,-1(P)
+ HRR A,1(AB) ; SETUP TYPE'S RH
+ SUBI B,1
+ HRL B,(P) ; AND BYTE POINTER
+ SUB P,C%33
+ SKIPE (AB)+1 ; SKIP IF NO CHARACTERS TO DEPOSIT
+ CAML AB,C%M20 ; [-2,,0] ; SKIP IF 2 ARGS GIVEN
+ JRST FINIS
+ PUSH TP,A ;SAVE OUR STRING
+ PUSH TP,B
+ PUSH TP,A ;SAVE A TEMPORARY CLOBBER POINTER
+ PUSH TP,B
+ PUSH P,(AB)1 ;SAVE COUNT
+ PUSH TP,(AB)+2
+ PUSH TP,(AB)+3
+CLOBST: PUSH TP,-1(TP)
+ PUSH TP,-1(TP)
+ MCALL 1,EVAL
+ GETYP C,A ; CHECK IT
+ CAME C,-1(P) ; MUST BE A CHARACTER
+ JRST WTYP2
+ IDPB B,-2(TP) ;CLOBBER
+ SOSLE (P) ;FINISHED?
+ JRST CLOBST ;NO
+ SUB P,C%22
+ SUB TP,C%66
+ MOVE A,(TP)+1
+ MOVE B,(TP)+2
+ JRST FINIS
+
+\f
+; HERE TO CHECK TO SEE WHETHER PURE RSUBR'S ARE MAPPED BELOW FRETOP AND
+; PUNT SOME IF THERE ARE.
+
+INQAGC: PUSH P,C
+ PUSH P,B
+ PUSH P,A
+ PUSH P,E
+ PUSHJ P,SQKIL
+ JSP E,CKPUR ; CHECK FOR PURE RSUBR
+ POP P,E
+ MOVE A,PURTOP
+ SUB A,CURPLN
+ MOVE B,RFRETP ; GET REAL FRETOP
+ CAIL B,(A)
+ MOVE B,A ; TOP OF WORLD
+ MOVE A,GCSTOP
+ ADD A,GETNUM
+ ADDI A,1777 ; PAGE BOUNDARY
+ ANDCMI A,1777
+ CAIL A,(B) ; SEE WHETHER THERE IS ROOM
+ JRST GOTOGC
+ PUSHJ P,CLEANT
+ POP P,A
+ POP P,B
+ POP P,C
+ POPJ P,
+GOTOGC: POP P,A
+ POP P,B
+ POP P,C ; RESTORE CAUSE INDICATOR
+ MOVE A,P.TOP
+ PUSHJ P,CLEANT ; CLEAN UP
+ SKIPL PLODR ; IF IN PLOAD DON'T INTERRUPT
+ JRST INTAGC ; GO CAUSE GARBAGE COLLECT
+ JRST SAGC
+
+CLEANT: PUSH P,C
+ PUSH P,A
+ SUB A,P.TOP
+ ASH A,-PGSZ
+ JUMPE A,CLNT1
+ PUSHJ P,GETPAG ; GET THOSE PAGES
+ FATAL CAN'T GET PAGES NEEDED
+ MOVE A,(P)
+ ASH A,-10. ; TO PAGES
+ PUSHJ P,P.CORE
+ PUSHJ P,SLEEPR
+CLNT1: PUSHJ P,RBLDM
+ POP P,A
+ POP P,C
+ POPJ P,
+
+\f; RCLVEC DISTASTEFUL VECTOR RECYCLER
+
+; Arrive here with B pointing to first recycler, A desired length
+
+RCLVEC: PUSH P,D ; Save registers
+ PUSH P,C
+ PUSH P,E
+ MOVEI D,RCLV ; Point to previous recycle for splice
+RCLV1: HLRZ C,(B) ; Get size of this block
+ CAIL C,(A) ; Skip if too small
+ JRST FOUND1
+
+RCLV2: MOVEI D,(B) ; Save previous pointer
+ HRRZ B,(B) ; Point to next block
+ JUMPN B,RCLV1 ; Jump if more blocks
+
+ POP P,E
+ POP P,C
+ POP P,D
+ JRST NORCL ; Go to normal allocator
+
+
+FOUND1: CAIN C,1(A) ; Exactly 1 greater?
+ JRST RCLV2 ; Cant use this guy
+
+ HRLM A,(B) ; Smash in new count
+ TLO A,.VECT. ; make vector bit be on
+ HLLM A,-1(B)
+ CAIE C,(A) ; Exactly right length?
+ JRST FOUND2 ; No, do hair
+
+ HRRZ C,(B) ; Point to next block
+ HRRM C,(D) ; Smash previous pointer
+ HRRM B,(B)
+ SUBI B,-1(A) ; Point to top of block
+ JRST FOUND3
+
+FOUND2: SUBI C,(A) ; Amount of left over to C
+ HRRZ E,(B) ; Point to next block
+ HRRM B,(B)
+ SUBI B,(A) ; Point to dope words of guy to put back
+ MOVSM C,(B) ; Smash in count
+ MOVSI C,.VECT. ; Get vector bit
+ MOVEM C,-1(B) ; Make sure it is a vector
+ HRRM B,(D) ; Splice him in
+ HRRM E,(B) ; And the next guy also
+ ADDI B,1 ; Point to start of vector
+
+FOUND3: HRROI B,(B) ; Make an AOBJN pointer
+ TLC B,-3(A)
+ HRRI A,TVEC
+ SKIPGE A
+ HRRI A,TUVEC
+ MOVSI A,(A)
+ POP P,E
+ POP P,C
+ POP P,D
+ POPJ P,
+
+END
+\f
\ No newline at end of file
--- /dev/null
+;ADDED VTS JSYS'S 21-NOV-80 EDIT BY PDL
+;ADDED RSCAN EDIT BY PDL
+;ADDED IIT (Interrupt In Time) 8/2/77 EDIT BY JMB
+;<SYSTEM>STENEX.MAC;432 6-NOV-73 04:28:29 EDIT BY MELVIN
+;ADDED UNIVERSAL STENEX
+;<SYSTEM>STENEX.MAC;431 1-NOV-73 22:17:59 EDIT BY MELVIN
+;ADDED LGINX6 -- ONE JOB FOR PEASANTS
+;<SYSTEM>STENEX.MAC;43 25-MAY-73 13:44:46 EDIT BY CLEMENTS
+;<SYSTEM>STENEX.MAC;42 27-DEC-72 22:57:51 EDIT BY MURPHY
+;<SYSTEM>STENEX.MAC;41 30-NOV-72 0:27:54 EDIT BY CLEMENTS
+;<SYSTEM>STENEX.MAC;40 18-NOV-72 18:12:32 EDIT BY WALLACE
+;<SYSTEM>STENEX.MAC;38 13-NOV-72 22:15:04 EDIT BY CLEMENTS
+;<SYSTEM>STENEX.MAC;37 13-NOV-72 21:53:19 EDIT BY CLEMENTS
+;<SYSTEM>STENEX.MAC;36 30-OCT-72 13:43:16 EDIT BY TOMLINSON
+;<SYSTEM>STENEX.MAC;35 30-OCT-72 12:22:04 EDIT BY TOMLINSON
+;<SYSTEM>STENEX.MAC;34 8-AUG-72 21:52:21 EDIT BY MURPHY
+;<SYSTEM>STENEX.MAC;33 8-AUG-72 20:31:17 EDIT BY MURPHY
+
+;9 FEB 72, 1425: - DLM
+
+;JSYS INSTRUCTIONS AND ERROR MNEMONICS FOR TENEX
+
+JSYS=104_27.
+
+DEFINE DEFJS NAME,NUM
+ NAME=JSYS NUM
+ TERMIN
+
+
+DEFJS JSYS,0
+
+DEFJS LOGIN,1
+DEFJS CRJOB,2
+DEFJS LGOUT,3
+DEFJS CACCT,4
+DEFJS EFACT,5
+DEFJS SMON,6
+DEFJS TMON,7
+DEFJS GETAB,10
+DEFJS ERSTR,11
+DEFJS GETER,12
+DEFJS GJINF,13
+DEFJS TIME,14
+DEFJS RUNTM,15
+DEFJS SYSGT,16
+DEFJS GNJFN,17
+DEFJS GTJFN,20
+DEFJS OPENF,21
+DEFJS CLOSF,22
+DEFJS RLJFN,23
+DEFJS GTSTS,24
+DEFJS STSTS,25
+DEFJS DELF,26
+DEFJS SFPTR,27
+DEFJS JFNS,30
+DEFJS FFFFP,31
+DEFJS RDDIR,32
+DEFJS CPRTF,33
+DEFJS CLZFF,34
+DEFJS RNAMF,35
+DEFJS SIZEF,36
+DEFJS GACTF,37
+\f
+DEFJS STDIR,40
+DEFJS DIRST,41
+DEFJS BKJFN,42
+DEFJS RFPTR,43
+DEFJS CNDIR,44
+DEFJS RFBSZ,45
+DEFJS SFBSZ,46
+DEFJS SWJFN,47
+DEFJS BIN,50
+DEFJS BOUT,51
+DEFJS SIN,52
+DEFJS SOUT,53
+DEFJS RIN,54
+DEFJS ROUT,55
+DEFJS PMAP,56
+DEFJS RPACS,57
+DEFJS SPACS,60
+DEFJS RMAP,61
+DEFJS SACTF,62
+DEFJS GTFDB,63
+DEFJS CHFDB,64
+DEFJS DUMPI,65
+DEFJS DUMPO,66
+DEFJS DELDF,67
+DEFJS ASND,70
+DEFJS RELD,71
+DEFJS CSYNO,72
+DEFJS PBIN,73
+DEFJS PBOUT,74
+DEFJS PSIN,75
+DEFJS PSOUT,76
+DEFJS MTOPR,77
+DEFJS CFIBF,100
+DEFJS CFOBF,101
+DEFJS SIBE,102
+DEFJS SOBE,103
+DEFJS DOBE,104
+DEFJS GTABS,105
+DEFJS STABS,106
+DEFJS RFMOD,107
+DEFJS SFMOD,110
+DEFJS RFPOS,111
+DEFJS RFCOC,112
+DEFJS SFCOC,113
+DEFJS STI,114
+DEFJS DTACH,115
+DEFJS ATACH,116
+DEFJS DVCHR,117
+\f
+DEFJS STDEV,120
+DEFJS DEVST,121
+DEFJS MOUNT,122
+DEFJS DSMNT,123
+DEFJS INIDR,124
+DEFJS SIR,125
+DEFJS EIR,126
+DEFJS SKPIR,127
+DEFJS DIR,130
+DEFJS AIC,131
+DEFJS IIC,132
+DEFJS DIC,133
+DEFJS RCM,134
+DEFJS RWM,135
+DEFJS DEBRK,136
+DEFJS ATI,137
+DEFJS DTI,140
+DEFJS CIS,141
+DEFJS SIRCM,142
+DEFJS RIRCM,143
+DEFJS RIR,144
+DEFJS GDSTS,145
+DEFJS SDSTS,146
+DEFJS RESET,147
+DEFJS RPCAP,150
+DEFJS EPCAP,151
+DEFJS CFORK,152
+DEFJS KFORK,153
+DEFJS FFORK,154
+DEFJS RFORK,155
+DEFJS RFSTS,156
+DEFJS SFORK,157
+DEFJS SFACS,160
+DEFJS RFACS,161
+DEFJS HFORK,162
+DEFJS WFORK,163
+DEFJS GFRKH,164
+DEFJS RFRKH,165
+DEFJS GFRKS,166
+DEFJS DISMS,167
+DEFJS HALTF,170
+DEFJS GTRPW,171
+DEFJS GTRPI,172
+DEFJS RTIW,173
+DEFJS STIW,174
+DEFJS SOBF,175
+DEFJS RWSET,176
+DEFJS GETNM,177
+\f
+DEFJS GET,200
+DEFJS SFRKV,201
+DEFJS SAVE,202
+DEFJS SSAVE,203
+DEFJS SEVEC,204
+DEFJS GEVEC,205
+DEFJS GPJFN,206
+DEFJS SPJFN,207
+DEFJS SETNM,210
+DEFJS FFUFP,211
+DEFJS DIBE,212
+DEFJS FDFRE,213
+DEFJS GDSKC,214
+DEFJS LITES,215
+DEFJS TLINK,216
+DEFJS STPAR,217
+DEFJS ODTIM,220
+DEFJS IDTIM,221
+DEFJS ODCNV,222
+DEFJS IDCNV,223
+DEFJS NOUT,224
+DEFJS NIN,225
+DEFJS STAD,226
+DEFJS GTAD,227
+DEFJS ODTNC,230
+DEFJS IDTNC,231
+DEFJS FLIN,232
+DEFJS FLOUT,233
+DEFJS DFIN,234
+DEFJS DFOUT,235
+
+DEFJS CRDIR,240
+DEFJS GTDIR,241
+DEFJS DSKOP,242
+DEFJS SPRIW,243
+DEFJS DSKAS,244
+DEFJS SJPRI,245
+; HOLE
+DEFJS ASNDP,260
+DEFJS RELDP,261
+DEFJS ASNDC,262
+DEFJS RELDC,263
+DEFJS STRDP,264
+DEFJS STPDP,265
+DEFJS STSDP,266
+DEFJS RDSDP,267
+DEFJS WATDP,270
+
+DEFJS ATPTY,274
+DEFJS CVSKT,275
+DEFJS CVHST,276
+DEFJS FLHST,277
+
+DEFJS GCVEC,300
+DEFJS SCVEC,301
+DEFJS STTYP,302
+DEFJS GTTYP,303
+DEFJS BPT,304
+DEFJS GTDAL,305
+DEFJS WAIT,306
+DEFJS HSYS,307
+
+DEFJS USRIO,310
+DEFJS PEEK,311
+DEFJS MSFRK,312
+DEFJS ESOUT,313
+DEFJS SPLFK,314
+DEFJS ADVIZ,315
+DEFJS JOBTM,316
+DEFJS DELNF,317
+DEFJS SWTCH,320
+
+DEFJS RSCAN,500
+DEFJS LNMST,504
+DEFJS TIMER,522
+DEFJS SWTRP,573
+DEFJS XSIR,602
+DEFJS IIT,630
+DEFJS VTSOP,635
+DEFJS RTMOD,636
+DEFJS STMOD,637
+DEFJS RTCHR,640
+DEFJS STCHR,641
+DEFJS SMAP,767
+\f
+
+DEFINE ...QQQ E,N,F
+IFE F,[
+E=600000+N]
+IFN F,[
+E=600000+N+F_21]
+TERMIN\r
+
+...QQQ LGINX1,10
+...QQQ LGINX2,11
+...QQQ LGINX3,12
+...QQQ LGINX4,13
+...QQQ LGINX5,14
+...QQQ LGINX6,15
+
+...QQQ CRJBX1,20
+...QQQ CRJBX2,21
+...QQQ CRJBX3,22
+...QQQ CRJBX4,23
+...QQQ CRJBX5,24
+...QQQ CRJBX6,25
+...QQQ CRJBX7,26
+
+...QQQ LOUTX1,35
+...QQQ LOUTX2,36
+
+...QQQ CACTX1,45
+...QQQ CACTX2,46
+
+...QQQ EFCTX1,50
+...QQQ EFCTX2,51
+...QQQ EFCTX3,52
+\f
+...QQQ GJFX1,55
+...QQQ GJFX2,56
+...QQQ GJFX3,57
+...QQQ GJFX4,60
+...QQQ GJFX5,61
+...QQQ GJFX6,62
+...QQQ GJFX7,63
+...QQQ GJFX8,64
+...QQQ GJFX9,65
+...QQQ GJFX10,66
+...QQQ GJFX11,67
+...QQQ GJFX12,70
+...QQQ GJFX13,71
+...QQQ GJFX14,72
+...QQQ GJFX15,73
+...QQQ GJFX16,74
+...QQQ GJFX17,75
+...QQQ GJFX18,76
+...QQQ GJFX19,77
+...QQQ GJFX20,100
+...QQQ GJFX21,101
+...QQQ GJFX22,102
+...QQQ GJFX23,103
+...QQQ GJFX24,104
+...QQQ GJFX25,105
+...QQQ GJFX26,106
+...QQQ GJFX27,107
+...QQQ GJFX28,110
+...QQQ GJFX29,111
+...QQQ GJFX30,112
+...QQQ GJFX31,113
+...QQQ GJFX32,114
+...QQQ GJFX33,115
+...QQQ GJFX34,116
+...QQQ GJFX35,117
+...QQQ OPNX1,120
+...QQQ OPNX2,121
+...QQQ OPNX3,122
+...QQQ OPNX4,123
+...QQQ OPNX5,124
+...QQQ OPNX6,125
+...QQQ OPNX7,126
+...QQQ OPNX8,127
+...QQQ OPNX9,130
+...QQQ OPNX10,131
+...QQQ OPNX11,132
+...QQQ OPNX12,133
+...QQQ OPNX13,134
+...QQQ OPNX14,135
+...QQQ OPNX15,136
+...QQQ OPNX16,137
+...QQQ OPNX17,140
+...QQQ OPNX18,141
+...QQQ OPNX19,142
+...QQQ OPNX20,143
+...QQQ OPNX21,144
+...QQQ OPNX22,145
+\f
+...QQQ DESX1,150
+...QQQ DESX2,151
+...QQQ DESX3,152
+...QQQ DESX4,153
+...QQQ DESX5,154
+...QQQ DESX6,155
+...QQQ DESX7,156
+...QQQ DESX8,157
+
+...QQQ CLSX1,160
+...QQQ CLSX2,161
+
+...QQQ RJFNX1,165
+...QQQ RJFNX2,166
+...QQQ RJFNX3,167
+
+...QQQ DELFX1,170
+
+...QQQ SFPTX1,175
+...QQQ SFPTX2,176
+...QQQ SFPTX3,177
+
+...QQQ CNDIX1,200
+...QQQ CNDIX2,201
+...QQQ CNDIX3,202
+...QQQ CNDIX4,203
+...QQQ CNDIX5,204
+
+...QQQ SFBSX1,210
+...QQQ SFBSX2,211
+
+...QQQ IOX1,215
+...QQQ IOX2,216
+...QQQ IOX3,217
+...QQQ IOX4,220
+...QQQ IOX5,221
+...QQQ IOX6,222
+
+...QQQ PMAPX1,240
+...QQQ PMAPX2,241
+
+...QQQ SPACX1,245
+
+\f
+...QQQ FRKHX1,250
+...QQQ FRKHX2,251
+...QQQ FRKHX3,252
+...QQQ FRKHX4,253
+...QQQ FRKHX5,254
+...QQQ FRKHX6,255
+
+...QQQ SPLFX1,260
+...QQQ SPLFX2,261
+...QQQ SPLFX3,262
+
+...QQQ GTABX1,267
+...QQQ GTABX2,270
+...QQQ GTABX3,271
+
+...QQQ RUNTX1,273
+
+...QQQ STADX1,275
+...QQQ STADX2,276
+
+...QQQ ASNDX1,300
+...QQQ ASNDX2,301
+...QQQ ASNDX3,302
+
+...QQQ CSYNX1,312
+
+...QQQ ATACX1,320
+...QQQ ATACX2,321
+...QQQ ATACX3,322
+...QQQ ATACX4,323
+...QQQ ATACX5,324
+
+...QQQ DCHRX1,330 ;USED ?
+
+...QQQ STDVX1,332
+
+...QQQ DEVX1,335
+...QQQ DEVX2,336
+...QQQ DEVX3,337
+
+...QQQ ADVX1,344
+...QQQ MNTX1,345
+...QQQ MNTX2,346
+...QQQ MNTX3,347
+
+...QQQ TERMX1,350
+
+...QQQ TLNKX1,351
+
+...QQQ ATIX1,352
+...QQQ ATIX2,353
+
+...QQQ DTIX1,355
+...QQQ TLNKX2,356
+...QQQ TLNKX3,357
+...QQQ TTYX1,360
+
+...QQQ CFRKX2,362
+...QQQ CFRKX3,363
+
+\f
+...QQQ KFRKX1,365
+...QQQ KFRKX2,366
+
+...QQQ RFRKX1,367
+
+...QQQ GFRKX1,371
+
+...QQQ GETX1,373
+...QQQ GETX2,374
+
+...QQQ SFRVX1,377
+
+...QQQ NOUTX1,407
+...QQQ NOUTX2,410
+
+...QQQ IFIXX1,414
+...QQQ IFIXX2,415
+...QQQ IFIXX3,416
+
+...QQQ ADVX1,420
+...QQQ ADVX2,421
+...QQQ ADVX3,422
+...QQQ ADVX4,423
+...QQQ GFDBX1,424
+...QQQ GFDBX2,425
+...QQQ GFDBX3,426
+
+...QQQ CFDBX1,430
+...QQQ CFDBX2,431
+...QQQ CFDBX3,432
+...QQQ CFDBX4,433
+
+...QQQ DUMPX1,440
+...QQQ DUMPX2,441
+...QQQ DUMPX3,442
+...QQQ DUMPX4,443
+
+...QQQ RNAMX1,450
+...QQQ RNAMX2,451
+...QQQ RNAMX3,452
+...QQQ RNAMX4,453
+; MORE RENAMX ERRORS LATER
+
+...QQQ BKJFX1,454
+
+...QQQ TIMEX1,460
+...QQQ ZONEX1,461
+...QQQ ODTNX1,462
+;463 FREE
+...QQQ DILFX1,464
+...QQQ TILFX1,465
+...QQQ DATEX1,466
+...QQQ DATEX2,467
+...QQQ DATEX3,470
+...QQQ DATEX4,471
+...QQQ DATEX5,472
+...QQQ DATEX6,473
+\f
+...QQQ TMONX1,515
+...QQQ SMONX1,515
+
+...QQQ CPRTX1,520
+
+...QQQ SACTX1,530
+...QQQ SACTX2,531
+...QQQ SACTX3,532
+...QQQ SACTX4,533
+
+...QQQ GACTX1,540
+...QQQ GACTX2,541
+
+...QQQ FFUFX1,544
+...QQQ FFUFX2,545
+...QQQ FFUFX3,546
+
+...QQQ DSMX1,555
+
+...QQQ RDDIX1,560
+
+...QQQ SIRX1,570
+
+...QQQ SSAVX1,600
+...QQQ SSAVX2,601
+
+...QQQ SEVEX1,610
+
+...QQQ WHELX1,614
+...QQQ CAPX1,615
+...QQQ PEEKX1,616
+...QQQ PEEKX2,617
+
+...QQQ CRDIX1,620
+...QQQ CRDIX2,621
+...QQQ CRDIX3,622
+...QQQ CRDIX4,623
+...QQQ CRDIX5,624
+...QQQ CRDIX6,625
+...QQQ CRDIX7,626
+
+...QQQ GTDIX1,640
+...QQQ GTDIX2,641
+
+...QQQ FLINX1,650
+...QQQ FLINX2,651
+...QQQ FLINX3,652
+...QQQ FLINX4,653
+
+...QQQ FLOTX1,660
+...QQQ FLOTX2,661
+...QQQ FLOTX3,662
+
+...QQQ FDFRX1,700
+...QQQ FDFRX2,701
+
+...QQQ ATPX1,710
+...QQQ ATPX2,711
+...QQQ ATPX3,712
+...QQQ ATPX4,713
+...QQQ ATPX5,714
+...QQQ ATPX6,715
+...QQQ ATPX7,716
+...QQQ ATPX8,717
+...QQQ ATPX9,720
+...QQQ ATPX10,721
+...QQQ ATPX11,722
+...QQQ ATPX12,723
+...QQQ ATPX13,724
+
+...QQQ CVSKX1,730
+...QQQ CVSKX2,731
+
+...QQQ DPX1,734
+...QQQ DPX2,735
+...QQQ STRDX1,740
+...QQQ STRDX2,741
+...QQQ STRDX3,742
+
+...QQQ STTX1,744
+
+...QQQ RNAMX5,750
+...QQQ RNAMX6,751
+...QQQ RNAMX7,752
+...QQQ RNAMX8,753
+...QQQ RNAMX9,754
+...QQQ RNMX10,755
+...QQQ RNMX11,756
+...QQQ RNMX12,757
+
+...QQQ GJFX36,760
+\f
+;ADD JSYS ERROR CODES HERE
+
+...QQQ ILINS1,770
+...QQQ ILINS2,771
+...QQQ ILINS3,772
+
+;EXTRA INSTRUCTIONS ON TOPS-20
+
+ADJSP==105000,,0
+ERJMP==JUMP 16,
+ERCAL==JUMP 17,
+\f
\ No newline at end of file
--- /dev/null
+TITLE TSTINKING ODOR
+
+ITS==0 ; FLAG SAYING WHETHER FOR ITS OR 20
+
+IFE ITS,.INSRT MUDSYS;STENEX >
+
+ZR=0
+P=1
+A=2
+B=3
+C=4 ;FOR L.OP
+D=5
+T=6
+TT=7
+ADR=10
+BOT=11
+CKS=12
+LL=13
+RH=14
+MEMTOP=15
+NBLKS=16
+FF=17
+
+;I/O CHANNELS
+
+TPCHN==1
+TYOC==2
+TYIC==3
+ERCHN==4 ;CHANNEL FOR ERROR DEVICE
+
+;RIGHT HALF FLAGS
+
+ALTF==1
+LOSE==2
+ARG==4
+UNDEF==10 ;COMPLAIN ABOUT UNDEF
+INDEF==20 ;GLOBAL LOC
+GLOSYM==40 ;ENTER GLOBAL SYMS INTO DDT TABLE
+SEARCH==100 ;LIBRARY
+CODEF==200 ;SPECIAL WORD LOADED
+GPARAM==400 ;ENTER GPA LOCALS
+COND==1000 ;LOAD TIME CONDITIONAL
+NAME==2000 ;SET JOB NAME TO PROGRAM NAME
+LOCF=4000 ;LOCAL IN SYM PRT
+JBN==10000 ;JOB NAME SET BY JCOMMAND
+GOF==20000 ;LEAVING LDR BY G COMMAND
+GETTY==40000 ;GE CONSOLE
+MLAST==100000 ;LAST COMMAND WAS AN "M"
+NOTNUM==200000 ;USED FOR DUMMY SYMBOL LOGIC
+SETDEV==400000 ;DEVICE SET LAST TIME
+
+
+HSW==1
+
+;MISCELLANEOUS CONSTANTS
+
+LOWLOD==0 ;LOWEST LOCATION LOADED
+LPDL==20
+CBUFL==2000 ;COMMAND BUFFER LENGTH (MOBY LONG!)
+DOLL==44 ;REAL DOLLAR SIGN (NOT ALT MODE ETC.)
+INHASH==151. ; HASH TABLE LENGTH
+ICOMM==10000 ;INITIAL COMMON
+
+PPDL==60 ;POLISH PUSH DOWN LENGTH
+SATPDL==5 ;SATED PUSH DOWN LENGTH
+MNLNKS==20 ;MAXIMUM NUMBER OF LINKS
+STNBLN==200 ;STINK INPUT BUFFER SIZE
+
+;REFERECNE WORD FLAGS
+
+FIXRT==1
+FIXLT==2
+POLREQ==200000 ;MARKS GLOGAL REQUEST AS POLISH REQUEST
+DEFINT==400000 ;DEFERED INTERNAL
+
+
+MFOR==101000 ; FOR .CBLK
+MBLKS==301000
+
+BUCK==2 ; OFFSETS INTO SYMBOL BLOCKS
+LIST==3
+
+\f
+ LOC 41
+ JSR TYPR
+ 0 ;TSINT
+
+IF2,COMLOD=TPOK ;IS YOUR TAPE OK?
+
+DEFINE INFORM A,B
+IF1,[PRINTX / A = B
+/]
+TERMIN
+
+DEFINE CONC69 A,B,C,D,E,F,G,H
+A!B!C!D!E!F!G!H!TERMIN
+
+DMCGSW==0
+
+DEFINE DMCG
+IFN DMCGSW!TERMIN
+
+DEFINE NODMCG
+IFE DMCGSW!TERMIN
+\fLOC 200
+REL: ADDI@ T,FACTOR
+ABS: HRRZ ADR,T
+DATABK: HRRZS ADR
+ PUSHJ P,GETBIT
+ TRZE TT,4
+ JRST DATBK1
+ PUSHJ P,RRELOC
+COM1: ADDB T,AWORD
+ ADD T,RH
+ HLL T,AWORD
+ CLEARB RH,AWORD
+IFN LOWLOD,[CAIGE ADR,LOWLOD
+ AOJA ADR,DATABK
+]GCR2: CAMLE ADR,MEMTOP
+ JRST GCR1
+ TRNE FF,CODEF
+ MOVEM T,(ADR)
+ TRNN FF,CODEF
+ MOVEM T,@ADRPTR
+ AOJA ADR,DATABK
+ERR1:
+DATBK1: PUSHJ P,RLKUP
+ TRNE TT,2
+ JRST DECODE ;LINK OR EXTEND
+USE: ROTC T,3
+ HRL ADR,TT
+ SKIPE C,TIMES
+ CLEARM TIMES
+ DPB C,[(261200)ADR]
+ JUMPGE D,USE1A
+ TLNE B,200000
+ JRST USE2 ;PREV DEFINED
+ TRNE FF,UNDEF
+ JRST ERR2
+ PUSHJ P,DOWN
+ MOVEM ADR,(D)
+CDATABK: JRST DATABK
+
+GCR1: TRNE ADR,400000 ; PURE?
+ JRST HIGHSG ; YES, USE HIGH SEG
+ PUSHJ P,GETMEM
+ JRST GCR2
+
+HIGHSG: CAMLE ADR,HIGTOP ; WITHIN HIGH BOUND?
+ PUSHJ P,GETHI ; NO, GROW
+ MOVEM T,(ADR) ; STORE
+ AOJA ADR,DATABK
+\f
+; ROUTINE TO GROW HIGH SEGMENT
+
+GETHI:
+DMCG,[
+ PUSH P,A
+ SKIPE TT,USINDX ; DO WE KNOW USER INDEX
+ JRST GETHI1 ; YES, CONTINUE
+
+IFN ITS, .SUSET [.RUIND,,USINDX]
+ MOVE TT,USINDX
+
+GETHI1: MOVEI A,200001 ; FOR SEG #1 FROM CORE JOB
+ DPB TT,[MFOR,,A] ; STORE USER POINTER
+ MOVEI TT,(ADR) ; GET WHERE TO POINTER
+ SUBI TT,400000-2000 ; ROUND UP AND REMOVE HIGH BIT
+ ASH TT,-10. ; TO BLOCKS
+ DPB TT,[MBLKS,,A] ; STORE IT ALSO
+IFN ITS,[
+ .CBLK A, ; GOT TO SYSTEM
+ PUSHJ P,SCE
+]
+ MOVE A,HIBLK ; GET NO. OF HIGH BLOCKS
+ SUBM TT,A ; GET NEW BLOCKS
+ MOVEM TT,HIBLK ; AND STORE
+ ASH TT,10. ; NOW COMPUTE NEW HIGTOP
+ TRO TT,400000 ; WITH HIGH BIT
+ SUBI TT,1
+ MOVEM TT,HIGTOP
+ JRST POPAJ
+];DMCG
+
+NODMCG,[
+ PUSH P,A
+ MOVEI TT,(ADR)
+ SUBI TT,400000-2000
+ ASH TT,-10.
+ SUB TT,HIBLK ;NUMBER OF BLOCKS TO GET
+ ADDM TT,HIBLK ;NUMBER OF BLOCKS WE ARE GOING TO HAVE
+ SKIPG TT
+IFN ITS, .VALUE
+IFE ITS, HALTF
+ MOVE A,CWORD1
+ ADDI A,1000
+IFN ITS,[
+ .CBLK A,
+ PUSHJ P,SCE
+ SOJG TT,.-3
+]
+ MOVEM A,CWORD1
+ MOVE TT,HIBLK
+ ASH TT,10.
+ ADDI TT,400000-1
+ MOVEM TT,HIGTOP
+ JRST POPAJ
+];NODMCG
+\f
+USE2: MOVE T,1(D) ;FILL REQUEST
+ PUSHJ P,DECGEN
+ ADDM T,AWORD
+ ADDM TT,RH
+ JRST DATABK
+
+USE1A: MOVE T,ADR
+USE1: TLO A,400000
+ TRNN FF,UNDEF
+ JRST DEF1A ;ENTER DEF
+ERR2: (5000+SIXBIT /UGA/)
+ JRST DATABK
+
+
+DEF1: TLO A,600000
+ TRNN FF,INDEF+GPARAM ;DEFINE ALL SYMBOLS
+ TLNE A,40000 ;OTHERWISE, FLUSH LOCALS
+ JRST ENT
+ JRST DEF4
+\f
+RDEF: TRO TT,10 ;SET FLAG FOR REDEFINITION
+DEF: ROTC T,3
+ PUSHJ P,RRELOC
+DFSYM1: PUSH P,CDATABK
+DEFSYM: MOVEM T,T1
+DFSYM2: MOVEM A,CGLOB ;SAVE SQUOOZE IN CASE WE SATISFY POLISH
+ JUMPGE D,DEF1 ;NOT PREV SEEN
+ TLNN B,200000 ;PREVIOUSLY DEFINED
+ JRST PATCH5 ;PREVIOUSLY NEEDED
+
+DEF2: TRNE TT,100 ;REDEFINE NOT OK
+DEF3: MOVEM T,1(D)
+ CAME T,1(D)
+ (5000+SIXBIT /MDG/)
+DEF4: TRZ FF,GPARAM
+ POPJ P,
+
+PATCH3: PUSH P,PATCH6
+PATCH: PUSH P,A ; SAVE SYMBOL
+ HRRZ D,T2 ; DELETE REFERENCES FROM TABLE
+ MOVE A,(D) ; SQUOOZE
+ TLNE A,200000 ; CHECK FOR DEFINED SYMBOL
+ JRST PATCH2 ; DON'T DELETE REFERENCES
+ HRRZ A,1(D) ; FIRST REFERENCE
+ SETZM 1(D)
+ HRRZ D,(A)
+ PUSHJ P,PARRET
+ SKIPE A,D
+ JRST .-3
+PATCH2: HRRZ A,T2 ; POINT TO SYMBOL TO BE FLUSHED(REFS ARE GONE)
+ HRRZ B,LIST(A) ; GET LIST POINTER LEFT
+ HLRZ C,LIST(A) ; AND RIGHT
+ SKIPE B ; END?
+ HRLM C,LIST(B) ; NO, SPLICE
+ SKIPE C
+ HRRM B,LIST(C)
+ HRRZ C,BUCK(A) ; NOW GET BUCKET POINTERS
+ HLRZ B,BUCK(A)
+ CAMG B,HTOP ; SEE IF POINTS TO HASH TABLE
+ CAMGE B,HBOT
+ JRST .+3 ; NO, SKIP
+ HRRM C,(B) ; IT IS, CLOBBER IN
+ JRST .+2
+ HRRM C,BUCK(B) ; SPLICE BUCKET
+ SKIPE C
+ HRLM B,BUCK(C) ; SPLICE IT ALSO
+ CAIN A,(BOT) ; RESET BOT?
+ HRRZ BOT,LIST(BOT) ; YES
+ SETZM LIST(A) ; CLEAR FOR DEBUGGING
+ PUSHJ P,QUADRT ; RETURN BLOCK
+ POP P,A ; RESTORE SYMBOL
+ SKIPE SATED
+ JRST UNSATE ;DELETE THEM
+PATCH6: POPJ P,.+1
+\fPATCH7: PUSHJ P,LKUP1A
+ JUMPGE D,DEF1
+PATCH5: HRRZM D,T2
+
+ HRRZ B,1(D) ; POINT TO REF CHAIN
+ MOVEI D,(B)
+PATCH1: MOVE T,T1
+ JUMPE D,PATCH3
+ MOVE B,1(D) ; GET REF WORD
+ HRRZ D,(D)
+ HLL ADR,B
+ HRRZS B
+ TLZE ADR,DEFINT
+ JRST DEFIF ;DEFERED INTERNAL
+ TLZE ADR,POLREQ
+ JRST POLSAT ;POLISH REQUEST
+ CAIGE B,LOWLOD
+ JRST PATCH1
+ TLZN ADR,100000
+ JRST GEN ;GENERAL REQUEST
+ PUSH P,CPTCH1
+UNTHR: TRNN B,400000 ; HIGH SEG?
+ MOVEI B,@BPTR ; NO FUDGE
+ HRL T,(B)
+ HRRM T,(B)
+ HLRZ B,T
+ JUMPN B,UNTHR
+CPTCH1: POPJ P,PATCH1
+\fDEFIF: SKIPGE (B)
+ JRST DEFIF1 ;MUST SATISFY DEFERRED INTERNAL
+ TLNE ADR,FIXRT+FIXLT
+ JRST 4,.
+DEFIF6: EXCH A,B
+ PUSHJ P,PARRET
+ MOVE A,B ;GET THE SYMBOL BACK
+ JRST PATCH1
+
+DEFIF1: TLNN ADR,FIXRT+FIXLT
+ JRST 4,. ;SYMBOL FIXED UP BUT NOT EXPUNGED FROM TABLE
+ TLC ADR,FIXRT+FIXLT
+ TLCN ADR,FIXRT+FIXLT
+ JRST 4,. ;BOTH BITS TURNED ON!!
+ PUSH P,D
+ PUSH P,B ;POINTS TO VALUE PAIR
+ MOVE T,1(B) ;SQUOOZE FOR DEFERRED INTERNAL
+ PUSHJ P,LKUP
+ JUMPGE D,DEFIF4 ;PERHAPS ITS'S IN DDT TABLE
+ TLNE B,200000
+ JRST 4,. ;LOSER
+ PUSHJ P,GLOBS3 ;FIND THE VALUE
+ JUMPE B,[JRST 4,.]
+ TLNE ADR,FIXRT
+ JRST DEFIFR ;RIGHT HANDED
+ TLNN ADR,FIXLT
+ JRST DEFIF2 ;LEFT HANDED FIXUP
+ TLZN A,FIXLT
+ JRST 4,.
+ HLRE T,1(A)
+DEFIF2: ADD T,T1
+ TLZE ADR,FIXRT
+ HRRM T,1(A)
+ TLZE ADR,FIXLT
+ HRLM T,1(A)
+ MOVEM A,1(B) ;WRITE THE REFERENCE WORD BACK
+ MOVE T,1(A) ;SAVE VALUE OF THIS GLOBAL IN CASE
+ MOVE B,A
+ POP P,A ;POINTS TO VALUE PAIR
+ PUSHJ P,PARRET
+ TLNE B,FIXLT+FIXRT
+ JRST DEFIF3 ;STILL NOT COMPLETELY DEFINED
+ MOVE B,(D) ;SIMULATE CALL TO LKUP
+ MOVE A,B
+ TLZ A,700000
+ PUSH P,T1
+ PUSH P,T2
+ PUSH P,CGLOB
+ PUSHJ P,DEFSYM ;HOLD YOUR BREATH
+ POP P,CGLOB
+ POP P,T2
+ POP P,T1
+DEFIF3: POP P,D
+ MOVE A,CGLOB
+ JRST PATCH1
+
+DEFIFR: TLZN A,FIXRT
+ JRST 4,.
+ HRRE T,1(A)
+ JRST DEFIF2
+
+DEFIF4: POP P,B
+ POP P,D
+ PUSH P,B
+ PUSH P,T1 ;VALUE TO BE ADDED
+ PUSH P,[DEFIF5] ;WHERE TO RETURN
+ TLZ T,200000 ;ASSUME RIGHT HALF FIX
+ TLZE ADR,FIXLT
+ TLO T,200000 ;ITS LEFT HALF FIX
+ TLZ ADR,FIXRT
+ JRST GLST2
+DEFIF5: POP P,B
+ MOVE A,CGLOB
+ JRST DEFIF6
+\f
+GEN: PUSHJ P, DECGEN
+ TRNN B,400000 ; HIGH SEG
+ MOVEI B,@BPTR ; NO GET REAL LOC
+ ADD T,(B)
+ ADD TT,T
+ HRR T,TT
+ MOVEM T,(B)
+ JRST PATCH1
+
+DECGEN: MOVEI TT,0
+ TLNE ADR,10
+ MOVNS T
+ LDB C,[(261200)ADR]
+ SKIPE C
+ IMUL T,C
+ LDB C,[(220200)ADR]
+ TLNE ADR,4
+ MOVSS T
+ XCT WRDTAB(C)
+
+WRDTAB: POPJ P, ;FW
+ EXCH T,TT ;RH
+ HLLZS T ;LH
+ ROT T,5 ;AC
+
+
+DECODE: TRNN TT,1
+ JRST THRDR ;6 > LINK REQ
+ PUSHJ P,GETBIT
+ JRST @.+1(TT)
+ DEF ;DEFINE SYMBOL (70)
+ COMMON ;COMMON RELOCATION (71)
+ LOCGLO ;LOCAL TO GLOBAL RECOVERY (72)
+ LIBREQ ;LIBRARY REQUEST (73)
+ RDEF ;REDEFINITION (74)
+ REPT ;GLOBAL MULTIPLIED BY 1024>N>0 (75)
+ DEFPT ;DEFINE AS POINT (76)
+
+\f
+RLKUP: PUSHJ P,RPB
+
+LKUP: MOVE A,T
+LKUP1B: MOVE D,BOT
+LKUP3: MOVEI B,0(ADR) ;CONTAINS GLOBAL OFFSET
+ TRNN FF,CODEF
+ MOVEM B,CPOINT+1 ;$.
+ TLZ A,700000
+LKUP1A: PUSH P,A
+ MOVE B,HTOP
+ SUB B,HBOT ; COMP LENGTH
+ IDIVI A,(B) ; HASH THE SYMBOL
+ ADD B,HBOT ; POINT TO THE BUCKET
+ HRRZ D,(B) ; SKIP IF NOT EMPTY
+ MOVE A,(P) ; RESTORE SYMBOL
+ JRST LKUP7
+LKUP1: MOVE B,(D) ; GET A CANDIDATE
+ TLZ B,600000
+ CAMN A,B ; SKIP IF NOT FOUND
+ JRST LKUP5
+ HRRZ D,BUCK(D) ; GO TO NEXT IN BUCKET
+LKUP7: JUMPE D,LKUP6 ; FAIL, GO ON
+ HRROI D,(D)
+ JRST LKUP1
+
+LKUP6: TROA FF,LOSE
+LKUP5: MOVE B,(D) ; SYMBOL WITH ALL FLAGS TO B
+ JRST POPAJ
+
+RRELOC: PUSHJ P,RPB
+RELOC: HLRZ C,T
+ TRNE TT,1
+ ADD T,FACTOR
+ TRNE TT,2
+ ADD C,FACTOR
+ HRL T,C
+ POPJ P,
+
+DOWN: PUSH P,A
+ PUSHJ P,PAIR ; GET A REF PAIR
+ HRRZ ZR,1(D) ; SAVE OLD REF
+ MOVEM A,1(D) ; CLOBBER IT
+ MOVEM ZR,(A) ; AND PATCH
+ MOVEI D,1(A) ; POINT D TO DESTINATION OF REF WRD
+ JRST POPAJ
+\f
+;HERE TO CREATE NEW TABLE ENTRY
+;A/ SQUOZE
+;T/ VALUE
+
+DEF1A: PUSH P,CDATABK
+DEF2A: PUSH P,A ; SAVE SYMBOL
+ PUSHJ P,PAIR ; GET PAIR FOR REF CHAIN
+ MOVEM T,1(A) ; SAVE REF WORD
+ MOVEI T,(A) ; USE POINTER AS VALUE
+ SKIPA A,(P)
+ENT: PUSH P,A
+ PUSH P,C
+ TLZ A,700000
+ MOVEM A,GLBFS
+ PUSHJ P,QUAD ; GET A QUADRAD FOR SYMBOL
+ MOVE D,A ; POINT WITH C
+ MOVE A,-1(P) ; RESTORE SYMBOL FOR HASHING
+ MOVE B,HTOP ; -LNTH OF TABLE
+ SUB B,HBOT
+ TLZ A,600000 ; CLOBBER FLAGS
+ IDIVI A,(B) ; GET HASH
+ ADD B,HBOT ; POINT TO BUCKET
+ HRRZ C,(B) ; GET CONTENTS THEREOF
+ HRROM D,(B) ; PUT NEW ONE IN
+ HRRM C,BUCK(D) ; PUT OLD ONE IN
+ HRLM B,BUCK(D) ; POINT BACK TO TABLE
+ SKIPE C ; SKIP IF NO NEXT
+ HRLM D,BUCK(C)
+ SKIPE BOT
+ HRLM D,LIST(BOT)
+ HRRZM BOT,LIST(D) ; INTO LIST OF ALL SYMBOLS
+ MOVEI BOT,(D) ; AND RESET
+ MOVE A,-1(P)
+ MOVEM A,(D)
+ MOVEM T,1(D)
+ POP P,C
+ JRST POPAJ
+\fTHRDR: PUSHJ P,RPB
+ TLNE T,100000
+ ADD T,FACTOR
+ HRLI T,100000
+ JUMPGE D,USE1
+ MOVE B,(D)
+ TLNE B,200000
+ JRST THRD2 ;PREV DEFINED
+ PUSHJ P,DOWN ;ENTER LINK REQUEST
+ MOVEM T,(D)
+ JRST DATABK
+
+THRD2: HRRZ B,T
+ MOVE T,1(D)
+ PUSHJ P,UNTHR
+ JRST DATABK
+
+LOCGLO: JUMPGE T,LG2 ;JUMP FOR NORMAL LOCAL TO GLOBAL RECOVERY
+
+;HERE TO EXPUNGE OR RENAME LOCAL IN LOADER TABLE
+
+ JUMPGE D,[JRST 4,.] ;NO SYMBOL THERE
+ HRRZM D,T2 ;TABLE ENTRY TO DELETE
+ PUSHJ P,RPB ;SOAK UP ANOTHER WORD
+ JUMPGE T,LG1 ;JUMP TO RENAME LOCAL
+ TLNN B,200000 ;MAKE SURE THING IS DEFINED
+ JRST 4,. ;CANNOT HACK UNDEFINED SYMBOL
+ PUSHJ P,PATCH
+ JRST DATABK
+
+;HERE TO RENAME LOCAL IN LOADER TABLE
+
+LG1: PUSH P,(D) ;SQUOZE
+ PUSH P,1(D) ;VALUE
+ MOVSI B,200000 ;MARK AS DEFINED SO THAT . . .
+ IORM B,(D) ;PATCH WILL NOT HACK REFERENCES
+ PUSHJ P,PATCH
+ MOVE A,T ;NEW NAME
+ POP P,T ;VALUE
+ POP P,B ;OLD NAME
+ TDZ B,[37777,,-1] ;CLEAR SQUOZE
+ TLZ A,700000 ;CLEAR FLAGS OF NEW NAME
+ IOR A,B ;FOLD FLAGS, NEW NAME
+ MOVEI B,DATABK ;ASSUME IT WILL BE LOCAL
+ TLZE A,40000 ;SEE IF WE MUST RECOVER TO GLOBAL
+ MOVEI B,.+3 ;MUST RECOVER TO GLOBAL
+ PUSH P,B ;RETURN ADDRESS
+ JRST ENT ;ENTER IT
+ MOVE B,(D) ;SQUOZE AND FLAGS
+ MOVE A,B ;SQUOZE WITH . . .
+ TLZA A,740000 ;FLAGS CLEARED
+
+
+;HERE FOR NORMAL LOCAL TO GLOBAL RECOVERY
+
+LG2: JUMPGE D,DATABK ;LOCAL-GLOBAL RECOVERY
+ MOVE T,D ;D POINTS TO LOCAL
+ TLO A,40000 ;GLOBAL
+ PUSHJ P,LKUP1B ;FIND OCCURANCE OF GLOBAL
+ IORM A,(T) ;SMASH OLD LOCAL OCCURENCE
+ JUMPGE D,DATABK
+ TLNN B,200000
+ JRST DATABK
+ MOVE B,1(D) ;ALREADY DEFINED
+ MOVEM B,T1
+ HRRZM D,T2
+ ADDI D,2
+ PUSHJ P,PATCH ;CLOBBER DEFINITION
+ MOVE D,BOT
+ PUSH P,CDATABK
+ JRST PATCH7 ;FILL IN OLD LOCAL REQ
+
+LIBREQ: JUMPL D,DATABK ;ALREADY THERE
+ MOVEI T,0
+ JRST USE1
+
+REPT: MOVEM T,TIMES
+ JRST DATABK
+
+COMMON: ADD RH,COMLOC
+ JRST COM1
+
+DEFPT: MOVEI T,@LKUP3
+ TRO FF,GPARAM
+ JRST DFSYM1
+
+
+\f
+LDCND: TRO FF,COND
+ JRST LIB
+
+LIB6: CAIN A,12 ;END OF CONDITIONAL
+ JRST .OMIT1
+ HRRZS T
+ CAIN A,1
+ CAIE T,5 ;LOADER VALUE CONDITIONAL
+ CAIN A,11 ;COUNT MATCHING CONDITIONALS
+ AOS FLSH
+ JRST OMIT
+
+LIB2: TRNE FF,COND
+ JRST LIB6
+ CAIN A,5
+ JRST LIB7
+ PUSHJ P,RPB
+ CAIN A,4 ;PRGM NAME
+ TLNN T,40000 ;REAL END
+ JRST OMIT
+ JRST OMIT1 ;LEAVE LIB SEARCH MODE
+
+LIB1: TRO FF,SEARCH
+ PUSHJ P,RPB
+ JUMPGE T,.-1
+ TRZ FF,SEARCH
+LIB4: PUSHJ P,LKUP
+ JUMPGE D,LIB3 ;NOT ENTERED
+ TRNE FF,COND
+ JRST LIB5
+ TLNE B,200000 ;RQST NOT FILLED
+LIB3: TLC T,200000 ;"AND NOT" BIT
+LIB5: TLNE T,200000
+ JRST LIB1 ;THIS ONE LOSES
+LIB: CLEARM FLSH
+LIB7: PUSHJ P,RPB
+ JUMPGE T,LIB4
+.OMIT1: SOSGE FLSH
+OMIT1: TRZ FF,SEARCH+COND;END OF SEGMENT,LOAD THIS PROG
+OMIT: PUSH P,.
+
+\f
+RPB: SOSL TC
+ JRST GTWD
+ PUSHJ P,GTWD ;SOAK UP CKSUM
+ AOJN CKS,RCKS
+
+LOAD: JRST (LL) ;READ SWITCH
+LOAD2: PUSHJ P,GTWD
+ LDB A,[(220700)T]
+ MOVEM A,TC
+ MOVSI A,770000
+ ANDCAM A,BITPTR
+ LDB A,[(310700)T]
+LOAD1: MOVE P,SAVPDL
+ JUMPLE T,OUT
+ CAIL A,LOADTE-LOADTB
+ JRST TPOK
+ TRNE FF,SEARCH
+ JRST LIB2
+ TRZ FF,COND ;FUDGE FOR IMPROPER USE OF .LIBRA
+ JRST @.+1(A)
+LOADTB: TPOK
+ LDCMD ;LOADER COMMAND (1)
+ ABS ;ABSOLUTE (2)
+ REL ;RELOCATABLE (3)
+ PRGN ;PROGRAM NAME (4)
+ LIB ;LIBRARY (5)
+ COMLOD ;COMMON LOADING (6)
+ GPA ;GLOBAL PARAMETER ASSIGNMENT (7)
+SYMSW: DDSYMS ;LOCAL SYMBOLS (10)
+ LDCND ;LOAD TIME CONDITIONAL (11)
+SYMFLG: SETZ OMIT ;END LDCND (12)
+ HLFKIL ;HALF KILL A BLOCK OF SYMBOLS
+ OMIT ;OMIT BLOCK GENERATED BY LIBRARY CREATOR
+ OMIT ;LATER WILL BE .ENTRY
+ AEXTER ;BLOCK OF STUFF FOR SDAT OR USDAT
+ OMIT ;FOR .LIFND
+ GLOBS ;GLOBAL SYMBOLS BLOCK TYPE 20
+ FIXES ;FIXUPS BLOCK TYPE 21
+ POLFIX ;POLISH FIXUPS BLOCK TYPE 22
+ LINK ;LINK LIST HACK (23)
+ OMIT ;LOAD FILE (24)
+ OMIT ;LOAD LIBRARY (25)
+ OMIT ;LVAR (26) OBSOLETE
+ OMIT ;INDEX (27) NEW DEC STUFF
+ OMIT ;HIGH SEG(30)
+LOADTE:
+
+OUT: MOVE P,SAVPDL
+ADRM: POPJ P,
+\f
+;HERE TO PROCESS AN .EXTERN
+
+AEXTER: PUSHJ P,RPB ;READ AND LOOK UP SYMBOL
+ TLO T,40000 ;TURN ON GLOBAL BIT
+ PUSHJ P,LKUP ;NOW LOOK IT UP
+ JUMPGE D,.+3 ;NEVER APPEARED, MUST ENTER
+ TLNE B,200000 ;SKIP IF NOT DEFINED
+ JRST AEXTER ;THIS ONE EXISTS, GO AGAIN
+ MOVE B,USDATP ;GET POINTER TO USDAT
+ PUSH P,A ;SAVE SYMBOL
+ TLZ A,740000 ;KILL ALL FLAGS
+ MOVE T,B ;SAVE A COPY OF THIS
+ ADD T,[3,,3] ;ENOUGH ROOM?
+ JUMPGE T,TMX ;NO, BARF AT THE LOSER
+ MOVEM T,USDATP ;NOW SAVE
+ TRNN B,400000 ; HIGH SEG?
+ MOVEM A,@BPTR ; NO GET REAL LOC
+ TRNE B,400000 ; SKIP IF LOW SEG
+ MOVEM A,(B) ;STORE INTO CORE IMAGE BEING BUILT
+ POP P,A ;RESTORE SYMBOL
+ MOVEI T,1(B) ;ALSO COMPUTE 'VALUE' OF SYMBOL
+ PUSHJ P,DEFSYM
+ JRST AEXTER
+
+
+;USDAT HAS OVERFLOWN
+
+TMX: (3000+SIXBIT /TMX/)
+\fGPA: PUSHJ P,RPB
+ MOVEM T,T2
+ MOVEI T,0
+
+LDCMD: ADDI T,LDCMD2+1
+ HRRM T,LDCMD2
+ ROT T,4
+ DPB T,[(330300)LDCVAL]
+ TRO FF,UNDEF+CODEF
+ HRRM ADR,ADRM
+ MOVEI B,@LKUP3
+ MOVEM B,CPOINT+1
+ MOVEI ADR,T1
+ JSP LL,DATABK
+
+LDCMD1: TRZ FF,UNDEF+CODEF
+ HRRZ ADR,ADRM
+ CLEARB RH,AWORD
+ MOVE D,T1
+LDCMD2: JRST @.
+ GPA1
+ JMP ;JUMP BLOCK (1)
+ GLOBAL ;GLOBAL LOCATION ASSIGNMENT (2)
+ COMSET ;COMMON ORIGIN (3)
+ RESPNT ;RESET GLOBAL RELOCATION (4)
+ LDCVAL ;LOADER VALUE CONDITIONAL (5)
+ .OFFSET ;GLOBAL OFFSET (6)
+ L.OP ;LOADER EXECUTE (7)
+ .RESOF ;RESET GLOBAL OFFSET\f
+JMP: JUMPE D,JMP1
+ TRNN FF,JBN
+ TLO FF,NAME
+ MOVEM D,SA
+JMP1: MOVEI LL,LOAD2
+ JRST LOAD2
+
+GLOBAL: TRO FF,INDEF
+ HRRM D,RELADR
+ MOVE ADR,D
+ MOVEI D,RELADR
+GLOB1: HRRM D,REL
+ JRST JMP1
+
+RESPNT: TRZ FF,INDEF
+ MOVEI D,FACTOR
+ HRRZ ADR,FACTOR
+ JRST GLOB1
+
+LDCVAL: JUMP D,JMP1
+ TRO FF,SEARCH+COND
+ CLEARM FLSH
+ JRST JMP1
+
+.OFFSET: HRRM D,LKUP3
+ JRST JMP1
+
+L.OP: MOVE B,T1 ;B=3 C=4 D=5
+ MOVE 4,T1+1
+ MOVE 5,T1+2
+ TDNN B,[(757)777777]
+IFN 0,[ JRST L.OP2
+ HRRM ADR,ADRM
+ HRRZ ADR,ADRPTR
+ MOVEM 4,4(ADR)
+ MOVEM 5,5(ADR)
+ MOVEM B,20(ADR)
+ HRLZI B,(.RETUUO)
+ MOVEM B,21(ADR)
+ MOVEM B,22(ADR)
+ .XCTUUO NBLKS,
+ MOVE 4,4(ADR)
+ MOVE 5,5(ADR)
+ HRRZ ADR,ADRM
+ JRST .+2
+L.OP2:] IOR B,[0 4,5]
+ XCT B
+ MOVEM 4,.VAL1
+ MOVEM 5,.VAL2
+ JRST JMP1
+.RESOF: MOVEI D,0
+ JRST .OFFSET
+\f
+SETJNM: MOVEI A,SJNM1
+ HRRM A,SPTY
+ SETZM A
+ MOVE B,[(600)A-1]
+ PUSHJ P,SPT
+ MOVEM A,JOBNAM
+ MOVEI A,TYO
+ HRRM A,SPTY
+ MOVE A,PRGNAM
+ POPJ P,
+
+SJNM1: TRC T,40
+DDT4: IDPB T,B
+ POPJ P,
+
+
+GPA1: MOVE T,T2
+ PUSHJ P,LKUP
+ MOVE T,T1
+ MOVEI TT,100 ;DON'T GENERATE MDG
+ TRO FF,GPARAM
+ PUSHJ P,DEFSYM
+ JRST JMP1
+
+DDLUP:
+DDSYMS: PUSHJ P,RPB
+ LDB TT,[(410300)T]
+ TLNE T,40000
+ JRST DDLUP2
+ TLZ T,240000
+ TLO T,100000
+DDLUP1: MOVE A,T
+ PUSHJ P,RRELOC
+ PUSHJ P,ADDDDT
+ JRST DDLUP
+
+DDLUP2: TLZ T,740000 ;MARK AS BLOCK NAME
+ JRST DDLUP1
+\f;HERE TO HANDLE GLOBAL BLOCK -- BLOCK TYPE #20
+
+GLOBS: PUSHJ P,GETBIT ;CODE BITS
+ PUSHJ P,RPB ;SQOOZE
+ MOVEM T,CGLOB
+ PUSHJ P,GETBIT ;CODE BITS
+ PUSHJ P,RRELOC ;VALUE
+ MOVEM T,CGLOBV
+ MOVE T,CGLOB
+ TLO T,40000 ;GLOBAL FLAG
+ PUSHJ P,LKUP ;SYMBOL LKUP
+ LDB C,[400400,,CGLOB] ;FLAGS
+ CAIN C,60_-2
+ JRST GLOBRQ ;GLOBAL REQUEST
+
+;HERE TO HANDLE SYMBOL TABLE FIX UPS OR GLOBAL DEFINITION
+
+ TRNN C,10_-2 ;TEST FOR VALID FLAGS
+ TRNN C,4_-2 ;FORMAT IS XX01
+ JRST 4,.
+ LSH C,-2 ;SHIFT OUT GARBAGE
+ JUMPE C,GLBDEF ;FLAGS 04=> GLOBAL DEFINITION
+ CAIN C,40_-4 ;*****JUST A GUESS
+ JRST GLBDEF ;*****JUST A GUESS
+
+;DUMP A DEFERRED INTERNAL INTO LOADER TABLE
+
+ JUMPL D,GDFIT ;JUMP IF IN LOADER TABLE
+ PUSHJ P,PAIR ;GET VALUE PAIR
+ MOVSI T,DEFINT(C)
+ HRR T,A ;REFERENCE WORD POINTS TO PAIR
+ MOVE A,CGLOBV
+ SETZM (T) ;MARK AS VALUE
+ MOVEM A,1(T) ;SECOND WORD IS VALUE
+GLOBS0: MOVE A,CGLOB ;SQUOOZE
+ TLZ A,300000 ;FIX THE FLAGS
+ TLO A,440000
+ PUSHJ P,DEF2A ;PUT IT INTO LOADER TABLE
+ JRST GLOBS
+
+;HERE FOR DEFERRED INTERNAL ALREADY IN TABLE
+
+GDFIT: TLNE B,200000
+ JRST 4,. ;ALREADY DEFINED
+ PUSHJ P,GLOBS3 ;RETURNS REFERENCE WORD IN A
+ JUMPE B,GDFIT1 ;MUST ADD DEFERRED VALUE
+ HLRZ B,A
+ CAIE B,DEFINT(C)
+ JRST 4,. ;REFERENCE WORDS DON'T MATCH
+ MOVE B,CGLOBV
+ CAME B,1(A)
+ JRST 4,. ;VALUES DON'T MATCH
+ JRST GLOBS ;ALL'S WELL THAT ENDS WELL
+
+GDFIT1: PUSHJ P,DOWN
+ PUSHJ P,PAIR
+ MOVSI T,DEFINT(C)
+ HRR T,A
+ MOVEM T,(D)
+ SETZM (T) ;MARK AS VALUE
+ MOVE A,CGLOBV
+ MOVEM A,1(T) ;VALUE
+ JRST GLOBS
+\f;HERE TO HANDLE GLOBAL REQUEST -- FLAGS=60
+
+GLOBRQ: SKIPGE T,CGLOBV ;SKIP IF THREADED LIST
+ JRST GLOBR1 ;SINGLE WORD FIX UP MUST WORK HARDER
+
+;SIMPLE REQUEST
+
+ JUMPE T,GLOBS ;IGNORE NULL REQUEST
+ JUMPGE D,GLOBNT ;JUMP IF SYMBOL NOT IN TABLE
+ TLNE B,200000 ;TEST TO SEE IF DEFINED
+ JRST GLOBPD ;PREVIOUSLY DEFINED
+ PUSHJ P,DOWN ;NOT DEFINED, ENTER REQEST INTO TABLE
+ MOVE C,CGLOBV
+ HRLI C,100000 ;THIS IS A LINK LIST
+ MOVEM C,(D)
+ JRST GLOBS
+
+;HERE TO DEFINE GLOBAL SYMBOL, FLAGS=04
+
+GLBDEF: MOVE T,CGLOBV ;VALUE
+ MOVEI TT,0 ;REDEFINE NOT OKAY, SEE DEF2
+ PUSHJ P,DEFSYM ;SQUOOZE+FLAGS ALREADY IN B BECAUSE OF EARLIER LOOK UP
+ JRST GLOBS
+\f; HERE IF GLOBAL DEFINED, UNTHREAD THE CHAIN
+
+GLOBPD: MOVE T,1(D) ;VALUE
+ MOVE B,CGLOBV ;POINTER TO CHAIN
+ PUSHJ P,UNTHR
+ JRST GLOBS
+
+; ENTER NEW SYMBOL WITH LINK REQUEST
+
+GLOBNT: MOVEI C,44_-2 ;PROPER FLAGS, GLOBAL AND THIS HERE SQUOZ
+ DPB C,[400400,,A]
+ HRLI T,100000 ;SET LINK BIT IN REQUEST
+ PUSHJ P,DEF2A
+ JRST GLOBS
+
+; SINGLE WORD FIX UP -- FLAGS=60
+
+GLOBR1: TLNE T,100000 ;TEST FOR SYMBOL TABLE FIX
+ JRST GLOBST ;SYMBOL TABLE FIX
+ JUMPGE D,GLOBR2 ;JUMP IF NOT IN TABLE
+ TLNN B,200000
+ JRST GLOBR3 ;NOT PREVIOUSLY DEFINED
+ HRRZ B,T ;FIX UP LOCATION
+ PUSHJ P,MAPB ;DO THE RIGHT THING IF B IN HIGH SEGMENT
+ TLNE T,200000 ;LEFT OR RIGHT?
+ JRST HWAL ;LEFT
+HWAR: HRRE C,(B) ;HALF WORD ADD RIGHT
+ ADD C,1(D)
+ HRRM C,(B)
+ JRST GLOBS
+
+HWAL: HLRE C,(B) ;HALF WORD ADD LEFT
+ ADD C,1(D)
+ HRLM C,(B)
+ JRST GLOBS
+
+; HERE FOR SINGLE WORD FIX, SYMBOL UNDEFINED
+
+GLOBR3: PUSHJ P,DOWN ;MAKE ROOM IN TABLE
+ MOVE C,T
+ HRLI T,40001 ;ASSUME RIGHT HALF
+ TLNE C,200000 ;RIGHT OR LEFT?
+ HRLI T,40002 ;LEFT
+ MOVEM T,(D)
+ JRST GLOBS
+
+;HERE TO MAPPING ON AC B SO THAT SECOND SEGMENT LOADING WORKS
+
+MAPB: TRNN B,400000 ;SECOND SEGMENT
+ HRRI B,@BPTR ;NO, RELOCATE THE ADDRESS
+ POPJ P,
+\f; HERE FOR SINGLE WORD FIXUP, SYMBOL NOT IN TABLE
+
+GLOBR2: TLO A,400000 ;SYMBOL FLAG
+ MOVE C,T
+ HRLI T,1 ;ASSUME RIGHT HALF FIX
+ TLNE C,200000 ;LEFT OR RIGHT?
+ HRLI T,2 ;LEFT
+ PUSHJ P,DEF2A
+ JRST GLOBS
+
+; HERE FOR SYMBOL TABLE FIX
+
+GLOBST:
+; MOVE A,CGLOBV
+; TLZ A,700000 ;MAKE SURE WE ARE STILL FIXING SAME SYMBOL
+; CAME A,GLBFS
+; JRST 4,. ;DON'T AGREE
+ JUMPGE D,GLOBS5 ;JUMP IF FIXUP NOT SEEN
+ TLNN B,200000
+ JRST GLOBS6 ;FIXUP NOT EVEN DEFINED
+ PUSH P,1(D) ;SAVE POINTER TO OLD SYMBOL
+ PUSH P,T
+ MOVE T,CGLOBV
+ PUSHJ P,LKUP
+ JUMPGE D,GLST1
+ TLNE B,200000
+ JRST 4,.
+ PUSHJ P,GLOBS3 ;FIND THE GLOBAL VALUE
+ SKIPE B
+ SKIPN (A)
+ JRST 4,.
+ POP P,T
+ EXCH B,(P) ;GET BACK VALUE OF FIXUP SYMBOL
+ TLNE T,200000 ;LEFT OR RIGHT?
+ JRST GLOBS1 ;LEFT
+ HRRE C,1(A) ;RIGHT
+ ADD C,B
+ HRRM C,1(A)
+ TLZN A,FIXRT ;DID WE REALLY WANT TO DO THIS
+ JRST 4,. ;NO
+ JRST GLOBS2 ;YES
+
+GLOBS1: HLRE C,1(A) ;LEFT HALF FIX
+ ADD C,B
+ HRLM C,1(A)
+ TLZN A,FIXLT ;DID WE REALLY WANT TO DO THIS
+ JRST 4,. ;NOPE
+
+; HERE TO FINISH UP SYMBOL TABLE FIX
+
+GLOBS2: POP P,B
+ MOVEM A,1(B) ;STORE BACK REFERENCE WORD
+ TLNE A,FIXLT+FIXRT ;DO WE HAVE MORE FIXING
+ JRST GLOBS ;NO
+ MOVE T,1(A) ;FIXED VALUE
+ MOVEI TT,100 ;OKAY TO REDEFINE, TT USED AT DEF2
+ PUSHJ P,DEFSYM
+ JRST GLOBS
+
+;HERE TO FIND POINTER TO VALUE OF DEFERRED INTERNAL
+
+GLOBS3: MOVE B,1(D) ;FIRST REFERENCE WORD
+GLOBS4: SKIPGE A,1(B)
+ JRST GLOBS8
+GLOBS9: HRRZ B,(B)
+ JUMPN B,GLOBS4
+ POPJ P, ;REFERENCE WORD NOT FOUND
+GLOBS8: SKIPGE (A)
+ JRST GLOBS9 ;DEFERED INTERNAL FOR ANOTHER SYMBOL
+ POPJ P,
+
+GLOBS5: PUSHJ P,GLOBS7
+ JRST GLOBS0
+
+GLOBS6: PUSHJ P,GLOBS7
+ PUSHJ P,DOWN
+ MOVEM T,(D)
+CGLOBS: JRST GLOBS
+
+GLOBS7: PUSHJ P,PAIR
+ MOVE B,T
+ TLZ T,700000
+ MOVEM T,1(A)
+ MOVSI T,DEFINT+FIXRT
+ TLNE B,200000
+ TLC T,FIXRT+FIXLT
+ HRR T,A
+ MOVSI B,400000
+ MOVEM B,(T) ;MARK AS SQUOOZE
+ MOVE B,CGLOBV
+ MOVEM B,1(T) ;SQUOOZE
+ POPJ P,
+
+GLST1: POP P,(P) ;VALUE TO ADD ON TOP OF STACK
+ PUSH P,CGLOBS
+
+;HERE TO FIX UP DIFFERED INTERNAL
+;THAT MIGHT BE A LOCAL CALL WITH STACK
+; -1(P) VALUE TO ADD
+; (P) RETURN ADDRESS
+; T SQUOZE FOR FIXUP (20,XXX=>LEFT HALF FIX)
+
+GLST2: PUSH P,A
+ PUSH P,T
+ TLNE T,40000
+ JRST 4,. ;ITS GLOBAL, THERE'S NO HOPE
+ MOVEI B,0 ;BLOCK NAME
+ MOVE C,T ;SYMBOL TO FIX
+ TLZ C,740000
+ PUSHJ P,FSYMT2
+ JRST 4,. ;CROCK
+ MOVE B,1(T) ;VALUE TO FIX
+ HLRZ C,B ;THE LEFT HALF
+ POP P,A
+ TLNN A,200000
+ ADD B,-2(P)
+ TLNE A,200000
+ ADD C,-2(P)
+ HRL B,C
+ MOVEM B,1(T)
+ POP P,A
+ POP P,-1(P)
+ POPJ P,
+\f; HERE TO HANDLE FIXUPS -- BLOCK TYPE #21
+
+FIXES: SKIPE LFTFIX
+ JRST FIXESL ;LEFT HALF FIXUP LEFT OVER FROM PREVIOUS BLOCK
+ PUSHJ P,GETBIT ;CODE BITS
+ PUSHJ P,RRELOC ;FIX UP WORD
+ CAMN T,[-1] ;SKIPS ON RIGHT HALF FIX
+ JRST FIXESL ;LEFT HALF FIX
+ HLRZ B,T ;C(T) = POINTER,,VALUE C(B)=POINTER
+ PUSHJ P,UNTHR
+ JRST FIXES
+
+FIXESL: SETOM LFTFIX ;IN CASE RRELOC GETS US OUT OF BLOCK
+ PUSHJ P,GETBIT
+ PUSHJ P,RRELOC
+ SETZM LFTFIX ;OFF TO THE RACES
+ HLRZ B,T
+ PUSHJ P,UNTHL
+ JRST FIXES
+
+UNTHL: PUSHJ P,MAPB
+ HLL T,(B) ;CALL IS POINTER IN B
+ HRLM T,(B) ; VALUE IN T
+ HLRZ B,T
+ JUMPN B,UNTHL
+ POPJ P,
+
+UNTHF: PUSHJ P,MAPB
+ HRL B,(B)
+ MOVEM T,(B)
+ HLRZS B
+ JUMPN B,UNTHF
+ POPJ P,
+\f;POLISH FIXUPS <BLOCK TYPE 22>
+
+PDLOV: SKIPE POLSW ;PDL OV ARE WE DOING POLISH?
+ JRST COMPOL ;YES
+ (3000+SIXBIT /POV/)
+COMPOL: (3000+SIXBIT /PTC/)
+LOAD4A: (3000+SIXBIT /IBF/)
+
+
+;READ A HALF WORD AT A TIME
+
+RDHLF: TLON FF,HSW ;WHICH HALF
+ JRST NORD
+ PUSHJ P,RWORD ;GET A NEW ONE
+ TLZ FF,HSW ;SET TO READ OTEHR HALF
+ MOVEM T,SVHWD ;SAVE IT
+ HLRZS T ;GET LEFT HALF
+ POPJ P, ;AND RETURN
+NORD: HRRZ T,SVHWD ;GET RIGHT HALF
+ POPJ P, ;AND RETURN
+
+RWORD: PUSH P,C
+ PUSHJ P,GETBIT
+ PUSHJ P,RRELOC
+ POP P,C
+ POPJ P,
+
+;HERE TO ENTER POLISH TOKEN INTO GLOBAL TABLE
+; C/ TOKEN TYPE
+; T/ VALUE (IGNORED IF OPERATOR)
+
+SYM3X2: PUSH P,A
+ PUSHJ P,PAIR ;GET TWO WORDS
+ MOVEM T,1(A) ;VALUE
+ EXCH T,POLPNT ;POINTER TO CHAIN
+ MOVEM T,(A) ;INTO NEW NODE
+ HRLM C,(A) ;TOKEN TYPE INTO LEFT HALF OF FIRST WORD
+ EXCH T,A
+ EXCH T,POLPNT ;RESTORE T, POINTER TO NEW NODE
+ JRST POPAJ
+\f;THIS ROUTINE SEARCHES TO SEE IF GLOBAL DEFINED (SKIPES IF UNDEFINED)
+;CALL WITH SQUOOZE IN C AND RETURNS WITH POINTER IN A IF DEFINED
+
+SDEF: PUSH P,A
+ PUSH P,B
+ PUSH P,C
+ PUSH P,D
+ PUSH P,T
+ MOVE T,C
+ PUSHJ P,LKUP
+ SKIPGE D
+ TLNN B,200000 ;SKIP IF DEFINED
+ AOS -5(P) ;INCREMENT ADDRESS
+ MOVEM D,-4(P) ;SET POINTER IN A
+ POP P,T
+ POP P,D
+ POP P,C
+POPBAJ: POP P,B
+POPAJ: POP P,A
+ POPJ P,
+
+;START READING THE POLISH
+
+POLFIX: MOVE D,PPDP ;SET UP THE POLISH PUSHDOWN LIST
+ MOVEI B,100 ;IN CASE OF ON OPERATORS
+ MOVEM B,SVSAT
+ SETOM POLSW ;WE ARE DOING POLISH
+ TLO FF,HSW ;FIX TO READ A WORD THE FIRST TIME
+ SETOM GLBCNT ;NUMBER OF GLOBALS IN THIS FIXUP
+ SETZM POLPNT ;NULL POINTER TO POLISH CHAIN
+ PUSH D,[15] ;FAKE OPERATOR SO STORE WILL NOT HACK
+
+RPOL: PUSHJ P,RDHLF ;GET A HALF WORD
+ TRNE T,400000 ;IS IT A STORE OP?
+ JRST STOROP ;YES, DO IT
+ CAIGE T,3 ;0,1,2 ARE OPERANDS
+ JRST OPND
+ CAILE T,14 ;14 IS HIGHEST OPERATOR
+ JRST LOAD4A ;ILL FORMAT
+ PUSH D,T ;SAVE OPERATOR IN STACK
+ MOVE B,DESTB-3(T) ;GET NUMBER OF OPERANDS NEEDED
+ MOVEM B,SVSAT ;ALSO SAVE IT
+ JRST RPOL ;BACK FOR MORE
+
+\f;HANDLE OPERANDS. THIS GETS COMPLICATED BECAUSE OF THE PRESENCE OF
+;GLOBAL REQUESTS
+
+OPND: MOVE A,T ;GET THE OPERAND TYPE HERE
+ PUSHJ P,RDHLF ;THIS IS AT LEAST PART OF THE OPERAND
+ MOVE C,T ;GET IT INTO C
+ JUMPE A,HLFOP1 ;0 IS HALF-WORD OPERAND
+ PUSHJ P,RDHLF ;NEED FULL WORD, GET SECOND HALF
+ HRL C,T ;GET HALF IN RIGHT PLACE
+ MOVSS C ;WELL ALMOST RIGHT
+ SOJE A,HLFOP1 ;1 IS FULL WORD, 2 IS GLOBAL REQUEST
+
+ LDB A,[400400,,C]
+ TLNE C,40000 ;CHECK FOR FUNNY LOCAL
+ PUSHJ P,SQZCON ;CONVERT TO STINKING SQUOOZE
+ DPB A,[400400,,C]
+ PUSHJ P,SDEF ;SEE IF IT IS ALREADY DEFINED
+ JRST OPND1 ;YES, WE WIN
+ AOSN GLBCNT ;NO, INCREMENT NUMBER OF GLOBALS THIS FIXUP
+ AOS HEADNM ;INCREMENT FIXUP NUMBER IF FIRST GLOBAL
+ PUSH P,C ;SAVE GLOBAL REQUESTS FOR LATER
+ MOVEI T,0 ;MARK AS SQUOOZE
+ EXCH C,T
+ PUSHJ P,SYM3X2 ;INTO THE LOADER TABLE
+ HRRZ C,POLPNT ;NEW "VALUE"
+ SKIPA A,[400000];SET UP GLOBAL FLAG
+HLFOP: MOVEI A,0 ;VALUE OPERAND FLAG
+HLFOP1: SOJL B,CSAT ;ENOUGH OPERANDS SEEN?
+ PUSH D,C ;NO, SAVE VALUE(OR GLOBAL NAME)
+ HRLI A,400000 ;PUT IN A VALUE MARKER
+ PUSH D,A ;TO THE STACK
+ JRST RPOL ;GET MORE POLISH
+
+;HERE TO CONVERT TO STINKING SQUOOZE, CAVEAT: THE FLAG BITS ARE CLEARED
+
+SQZCON: TLZ C,740000
+ JUMPE C,CPOPJ
+SQZ1: CAML C,[50*50*50*50*50]
+ POPJ P,
+ IMULI C,50
+ JRST SQZ1
+
+; HERE IF GLOBAL SYMBOL DEFINED AT POLISH BLOCK READ TIME
+
+OPND1: MOVE C,1(A) ;SYMBOL VALUE
+ JRST HLFOP
+\f;HAVE ENOUGH OPERANDS FOR THE CURRENT OPERATOR
+
+CSAT: HRRZS A ;KEEP ONLY THE GLOBAL-VALUE HALF
+ SKIPN SVSAT ;IS IT UNARY
+ JRST UNOP ;YES, NO NEED TO GET 2ND OPERAND
+ HRL A,(D) ;GET GLOBAL VALUE MARKER FOR 2ND OP
+ POP D,T
+ POP D,T ;VALUE OR GLOBAL NAME
+UNOP: POP D,B ;OPERATOR
+ JUMPN A,GLOB ;IF EITHER IS A GLOBAL HANDLE SPECIALLY
+ XCT OPTAB-3(B) ;IF BOTH VALUES JUST XCT
+ MOVE C,T ;GET THE CURRENT VALUE
+SETSAT: SKIPG B,(D) ;IS THERE A VALUE IN THE STACK
+ MOVE B,-2(D) ;YES, THIS MUST BE THE OPERATOR
+ MOVE B,DESTB-3(B) ;GET NUMBER OF OPERANDS NEEDED
+ MOVEM B,SVSAT ;SAVE IT HERE
+ SKIPG (D) ;WAS THERE AN OPERAND
+ SUBI B,1 ;HAVE 1 OPERAND ALREADY
+ JRST HLFOP1 ;GO SEE WHAT WE SHOULD DO NOW
+
+;HANDLE GLOBALS
+
+GLOB: TRNE A,-1 ;IS IT IN RIGHT HALF
+ JRST TLHG ;NO NEED TO SAVE THIS VALUE IF ITS GLOBAL
+ PUSH P,T ;SAVE FOR A WHILE
+ MOVE T,C ;THE VALUE
+ MOVEI C,1 ;MARK AS VALUE
+ PUSHJ P,SYM3X2
+ HRRZ C,POLPNT ;POINTER TO VALUE
+ POP P,T ;RETRIEVE THE OTHER VALUE
+TLHG: SKIPE SVSAT ;WAS THIS A UNARY OPERATOR
+ TLNE A,-1 ;WAS THERE A GLOBAL IN LEFT HALF
+ JRST GLSET
+ PUSH P,C
+ MOVEI C,1 ;SEE ABOVE
+ PUSHJ P,SYM3X2
+ HRRZ T,POLPNT ;POINTER TO VALUE
+ POP P,C
+
+GLSET: EXCH C,B ;OPERATOR INTO RIGHT AC
+ SKIPE SVSAT ;SKIP ON UNARY OPERATOR
+ HRL B,T ;SECOND,,FIRST
+ MOVE T,B ;SET UP FOR CALL TO SYM3X2
+ PUSHJ P,SYM3X2
+ MOVEI A,400000 ;SET UP AS A GLOBAL VALUE
+ HRRZ C,POLPNT ;POINTER TO "VALUE"
+ JRST SETSAT ;AND SET UP FOR NEXT OPERATOR
+\f;FINALLY WE GET TO STORE THIS MESS
+
+STOROP: MOVE B,-2(D) ;THIS SHOULD BE THE FAKE OPERATOR
+ CAIE B,15 ;IS IT
+ JRST LOAD4A ;NO, ILL FORMAT
+ HRRZ B,(D) ;GET THE VALUE TYPE
+ JUMPN B,GLSTR ;AND TREAT GLOBALS SPECIAL
+ MOVE A,T ;THE TYPE OF STORE OPERATOR
+ CAIGE A,-3
+ PUSHJ P,FSYMT ;SYMBOL TABLE FIXUP, MUST WORK HARDER
+ PUSHJ P,RDHLF ;GET THE ADDRESS
+ MOVE B,T ;SET UP FOR FIXUPS
+ POP D,T ;GET THE VALUE
+ POP D,T ;AFTER IGNORING THE FLAG
+ PUSHJ P,@STRTAB+6(A) ;CALL THE CORRECT FIXUP ROUTINE
+
+COMSTR: SETZM POLSW ;ALL DONE WITH POLISH
+ MOVE B,HEADNM
+ CAILE B,477777
+ JRST COMPOL ;TOO BIG, GIVE ERROR
+ PUSHJ P,RWORD ;THIS SHOULD GET US OUT (I.E RUN OUT COUNT)
+ JRST LOAD4A ;IF NOT, SOMETHING IS WRONG
+
+GLSTR: MOVE A,T
+ CAIGE A,-3
+ JRST 4,. ;PUSHJ P,FSYMT ;SYMBOL TABLE FIXUP
+ PUSHJ P,RDHLF ;GET THE STORE LOCATION
+ SUB D,[2,,2] ;VALUE AND MARKER ON STACK MEANINGLESS
+ MOVE C,A ;STORE OP
+ PUSHJ P,SYM3X2 ;STORE LOC ALREADY IN T
+ AOS T,GLBCNT ;WE STARTED AT -1 REMEMBER?
+ HRRZ C,HEADNM ;GET HEADER #
+ TLO C,440000 ;MARK FIXUP AS GLOBAL BEASTIE
+ PUSHJ P,SYM3X2 ;LAST OF POLISH FIXUP
+ HRRZ T,POLPNT ;POINTER TO POLISH BODY
+ MOVE A,C ;FIXUP NAME
+ PUSHJ P,ENT
+GLSTR1: SOSGE GLBCNT ;MUST PUT GLOBAL REQUESTS IN TABLE
+ JRST COMSTR ;AND FINISH
+ POP P,T ;SQUOOZE
+ PUSHJ P,LKUP
+ MOVE A,HEADNM ;SETUP REQUEST WORD
+ TLO A,POLREQ ;MARK AS POLISH REQUEST
+ JUMPGE D,GLSTR2 ;JUMP IF NOT SEEN
+ PUSHJ P,DOWN
+ MOVEM A,(D)
+ JRST GLSTR1
+
+GLSTR2: EXCH A,T ;NOT PREVIOUSLY SEEN ENTER FULL REQUEST
+ TLO A,400000 ;MARK AS NEW TABLE ENTRY
+ PUSHJ P,DEF2A
+ JRST GLSTR1
+\fSTRTAB: ALSYM ;-6 FULL SYMBOL TABLE FIXUP
+ LFSYM ;-5 LEFT HALF SYMBOL FIX
+ RHSYM ;-4 RIGHT HALF SYMBOL FIX
+ UNTHF ;-3 FULL WORD FIXUP
+ UNTHL ;-2 LEFT HALF WORD FIXUP
+ UNTHR ;-1 RIGHT HALF WIRD FIXUP
+ CPOPJ ;0
+
+DESTB: 1
+ 1
+ 1
+ 1
+ 1
+ 1
+ 1
+ 1
+ 0
+ 0
+ 100
+
+OPTAB: ADD T,C
+ SUB T,C
+ IMUL T,C
+ IDIV T,C
+ AND T,C
+ IOR T,C
+ LSH T,(C)
+ XOR T,C
+ SETCM T,C
+ MOVN T,C
+
+;HERE TO LOOK UP LOCAL IN SYMBOL TABLE
+
+FSYMT: PUSHJ P,FSYMT1 ;BLOCK NAME
+ MOVE B,C ;SAVE SYMBOL
+ PUSHJ P,FSYMT1 ;SYMBOL NAME
+ EXCH B,C ;BLOCK NAME IN B, SYMBOL NAME IN C
+FSYMT2: PUSH P,A ;SAVE IT
+ MOVE T,DDPTR ;AOBJN POINTER TO LOCALS
+SLCL: MOVE A,(T) ;SQUOZE
+ TLZN A,740000 ;CLEAR FLAGS FOR COMPARE
+ JRST SLCL3 ;BLOCK NAME
+ CAMN A,C ;IS THIS THE SYMBOL WE SEEK
+ JRST SLCL1 ;YES, WE MUST STILL VERIFY THE BLOCK
+SLCL4: ADD T,[1,,1] ;NO KEEP LOOKING
+ AOBJN T,SLCL
+ JRST 4,. ;SYMBOL NOT FOUND
+
+SLCL1: JUMPE B,POPAJ1 ;SYMBOL IS IN THIS BLOCK
+ PUSH P,T ;THIS POINTER POSSIBLY A WINNER
+ ADD T,[2,,2] ;NEXT SYMBOL
+ JUMPGE T,[JRST 4,.] ;WE HAVE RUN OUT OF TABLE
+ MOVE A,(T) ;SQUOZE
+ TLNE A,740000 ;SKIP ON BLOCK NAME
+ JRST .-4
+
+; HERE WHEN WE FIND BLOCK NAME
+
+ CAME A,B ;DOES THE BLOCK NAME MATCH
+ JRST SLCL2 ;NO KEEP LOOKING
+ POP P,T ;WINNING SYMBOL TABLE ENTRY
+POPAJ1: POP P,A ;RESTORE A
+ AOS (P) ;SKIP THE PUSHJ P,RDHLF THAT FOLLOWS THIS CALL
+ POPJ P,
+
+SLCL3: JUMPN B,SLCL4
+ JRST 4,. ;SYMBOL SHOULD BE IN THIS BLOCK
+
+SLCL2: SUB P,[1,,1] ;FLUSH THE LOSING SYMBOL POINTER
+ JRST SLCL
+
+FSYMT1: PUSHJ P,RDHLF
+ HRL C,T
+ PUSHJ P,RDHLF
+ HRR C,T
+ JRST SQZCON
+\f;HERE TO SATISFY GLOBAL REQUEST FOR POLISH
+
+POLSAT: PUSH P,D ;POINTER TO CURRENTLY PROCESSED GLOBAL REQUEST
+ HRRZ T,B ;LOOK UP POLISH TO BE FIXED
+ TLO T,440000
+ PUSHJ P,LKUP
+ JUMPGE D,[JRST 4,.] ;CANNOT FIND POLISH
+ MOVE T,CGLOB ;SQUOOZE (SET UP AT DFSYM2)
+ MOVE B,1(D) ;COUNT
+ MOVE B,(B) ;STORE OP
+ MOVE B,(B) ;FIRST TOKEN
+ PUSHJ P,FIXPOL
+ MOVE B,1(D)
+ SOSG 1(B) ;UPDATE UNDEFINED GLOBAL COUNT
+ JRST PALSAT ;COUNTED OUT FINISH THIS FIXUP
+POLRET: MOVE A,CGLOB
+ POP P,D
+ JRST PATCH1
+
+;HERE TO FIXUP A SINGLE GLOBAL REQUEST IN POLISH
+
+FIXPOL: HLRZ A,(B) ;TOKEN TYPE
+ JUMPN A,FXP1 ;JUMP IF NOT SQUOZE
+ CAME T,1(B)
+ JRST FXP1 ;SQUOOZE DOES NOT MATCH
+ HRRI A,1 ;MARK AS VALUE
+ MOVE T,T1 ;VALUE
+ HRLM A,(B) ;NEW TOKEN TYPE
+ MOVEM T,1(B) ;NEW VALUE
+ POPJ P,
+
+FXP1: HRRZ B,(B) ;POINTER TO NEXT TOKEN
+ JUMPN B,FIXPOL
+ JRST 4,. ;DID NOT FIND SYMBOL
+\f;HERE TO FINISH THE POLISH AFTER ALL REQUESTS ARE SATISFIED
+
+PALSAT: AOS SATED ;NUMBER OF FIXUPS SATISFIED
+ PUSH P,(D) ;SAVE THE NAME OF THIS FIXUP FOR LATER DELETION
+ MOVE A,1(D) ;POINTS TO COUNT
+ MOVE A,(A) ;STORE OP
+ MOVE D,PPDP
+ HLLZ B,(A) ;STORE OP
+ HRRZ T,1(A) ;PLACE TO STORE
+ PUSH D,B ;STORE OP
+ PUSH D,T ;STORE ADDRESS
+ MOVEI T,-1(D) ;POINTER TO STORE OP
+ PUSH D,T
+ MOVE A,(A) ;POINTS TO FIRST TOKEN
+
+PSAT1: HLRE B,(A) ;OPERATOR
+ JUMPL B,ENDPOL ;FOUND STORE OP
+ CAIGE B,15
+ CAIGE B,3
+ JRST 4,. ;NOT OPERATOR
+ MOVE T,1(A) ;OPERANDS (SECOND,,FIRST)
+ HLRZ C,(T) ;FIRST OPERAND
+ JUMPE C,[JRST 4,.] ;SQUOZE NEVER DEFINED
+ CAIE C,1 ;SKIP IF DEFINED
+ JRST PSDOWN ;GO DOWN A LEVEL IN TREE
+ SKIPN DESTB-3(B)
+ JRST PSAT2 ;IF UNARY OP WE ARE DONE
+ MOVSS T
+ HLRZ C,(T) ;SECOND OPERAND
+ JUMPE C,[JRST 4,.]
+ CAIE C,1
+ JRST PSDOWN
+ MOVSS T
+
+;HERE TO PERFORM OPERATION
+
+PSAT2: MOVE C,1(T) ;VALUE FIRST OPERAND
+ MOVSS T
+ SKIPE DESTB-3(B)
+ MOVE T,1(T) ;GET SECOND OPERAND ONLY IF NECESSARY
+ XCT OPTAB-3(B) ;WOW!
+ MOVEM T,1(A) ;NEW VALUE
+ MOVEI C,1
+ HRLM C,(A) ;MARK AS VALUE
+ POP D,A ;GO UP A LEVEL IN TREE
+ JRST PSAT1
+
+;HERE TO GO DOWN LEVEL IN TREE
+
+PSDOWN: PUSH D,A ;SAVE THE OLD NODE
+ HRRZ A,T ;NEW NODE
+ JRST PSAT1
+\f;HERE TO END PROCESSING OF POLISH IN SYMBOL TABLE (VALUE IN T)
+
+ENDPOL: POP D,B ;STORE ADDRESS
+ MOVS A,(D) ;STORE OP
+ PUSHJ P,@STRTAB+6(A)
+ POP P,D ;NAME OF THIS FIXUP
+ EXCH P,SATPDP ;SAVE THIS NAME FOR LATER DELETION FROM TABLE
+ PUSH P,D
+ EXCH P,SATPDP
+ JRST POLRET
+
+; HERE TO DO SYMBOL TABLE FIXUPS
+; T/ VALUE
+; B/ SYMBOL TABLE POINTER
+
+RHSYM: HRRM T,1(B) ;RIGHT HALF FIX
+ POPJ P,
+
+LFSYM: HRLM T,1(B) ;LEFT HALF FIX
+ POPJ P,
+
+ALSYM: MOVEM T,1(B) ;FULL WORD FIX
+ POPJ P,
+
+
+;HERE TO REMOVE POLISH FIXUPS FROM SYMBOL TABLE
+
+UNSATE: PUSH P,T2
+ MOVE A,[-SATPDL,,SATPDB-1]
+ EXCH A,SATPDP ;SET UP PUSH DOWN POINTER
+ MOVE B,SATED ;# FIXUPS TO BE DELETED
+ SETZM SATED
+ CAILE B,SATPDP ;LIST LONG ENOUGH?
+ JRST 4,. ;TIME TO REASSEMBLE
+UNSAT1: SOJL B,UNSAT3
+ POP A,T ;FIXUP
+ PUSH P,A
+ PUSH P,B
+ PUSHJ P,LKUP ;LOOK IT UP
+ HRRZM D,T2
+UNSAT2: PUSHJ P,PATCH ;REMOVE IT FROM TABLE
+ POP P,B
+ POP P,A
+ JRST UNSAT1
+
+UNSAT3: POP P,T2 ;POINTS TO TABLE ENTRY
+ MOVE T,T1 ;SYMBOL VALUE
+ MOVE A,CGLOB ;SQUOOZE
+ POPJ P,
+\f; HERE TO HANDLE LINKS (BLOCK TYPE 23)
+
+LINK: SETOM LINKDB ;LINKS BEING HACKED
+ PUSHJ P,GETBIT ;RELOCATION BITS INTO TT
+ PUSHJ P,RRELOC ;LINK #
+ MOVE A,T
+ JUMPE A,LOAD4A ;ILLEGAL LINK #
+ PUSHJ P,GETBIT
+ PUSHJ P,RRELOC ;STORE ADDRESS
+ HRRZ B,T
+ JUMPL A,LNKEND ;JUMP ON LINK END
+ CAILE A,MNLNKS
+ JRST LOAD4A ;ILLEGAL LINK #
+
+ HRRZ C,LINKDB(A) ;LINK VALUE
+ PUSH P,B
+ PUSHJ P,MAPB
+ HRRM C,(B) ;VALUE INTO STORE ADDRESS
+ POP P,B
+ HRRM B,LINKDB(A) ;NEW VALUE
+ JRST LINK
+
+;END LINK
+
+LNKEND: MOVNS A ;LINK #
+ CAILE A,MNLNKS
+ JRST LOAD4A ;ILLEGAL LINK #
+ HRLM B,LINKDB(A) ;LINK END ADDRESS
+ JRST LINK
+
+;HERE AFTER ALL LOADING TO CLEAN UP LINKS
+
+LNKFIN: PUSH P,A
+ PUSH P,B
+ MOVEI A,MNLNKS
+
+LNKF1: MOVS B,LINKDB(A) ;VALUE,,STORE ADDRESS
+ TRNN B,-1 ;DON'T STORE FOR ZERO STORE ADDRESS
+ JRST .+3
+ PUSHJ P,MAPB
+ HLRM B,(B)
+ SOJG A,LNKF1
+ JRST POPBAJ
+\f;HERE TO HALF KILL LOCAL SYMBOLS DEFINED BY LOADER
+
+HLFKIL: MOVE D,DDPTR ;RESTORE POINTER TO LOCAL TABLE
+ ADD D,[2,,2] ;BUMP IT
+NXTKIL: MOVE B,D ;PUT POINTER ALSO IN B
+ PUSHJ P,RPB ;GET A WORD
+ TLZ T,740000 ;MAKE SURE NO FLAGS
+NXTSYK: MOVE A,(B) ;GET A SYMBOL
+ TLZN A,740000 ;IF PROG NAME HIT, TIME TO QUIT
+ JRST NXTKIL
+ CAME T,A ;IS THIS ONE
+ JRST NOKIL ;NO TRY AGAIN
+ TLO A,400000 ;TURN ON HALF KILL BIT IN DDT
+ IORM A,(B) ;RESTORE SYMBOL TO TABLE
+ JRST NXTKIL
+
+NOKIL: AOBJN B,.+1
+ AOBJN B,NXTSYK ;TRY ANOTHER
+ JRST NXTKIL ;TRY ANOTHER ONE
+
+
+
+\f
+PRGN: PUSHJ P,RPB
+ MOVE A,T
+ MOVEM A,PRGNAM
+ TLZE FF,NAME
+ PUSHJ P,SETJNM
+ MOVE T,FACTOR
+ HRL T,ADR
+ TLNE A,40000
+ PUSHJ P,PRGEND ;REAL PRGM END
+ TLO A,740000
+ PUSHJ P,ENT
+ PUSHJ P,SYMS
+ MOVE A,(BOT) ; GET CURRENT PRG NAME
+NODMCG, MOVSI T,1 ; WANT NON-ZERO, BUT POSITIVE LEFT HALF
+DMCG, MOVE T,1(BOT) ; POINTS TO TOP AND BOTTOM OF PROGRAM
+ TLZ A,740000 ; MARK AS PROGNAME
+ SKIPL SYMSW
+ PUSHJ P,ADDDDT ; TO DDT TABLE
+ SKIPL SYMSW
+ PUSHJ P,SHUFLE ;PUT THE SYMBOLS IN THE RIGHT ORDER
+ HLLZS LKUP3
+ PUSHJ P,RESETT
+ JRST OMIT
+
+PRGEND: HRRZM ADR,FACTOR
+ SETZM LFTFIX
+ POPJ P,
+
+
+;WE DO ALL OF THE FOLLOWING HACKING TO INSURE THAT THE
+;THE SYMBOLS ARE GIVEN TO DDT IN EXACTLY THE SAME ORDER
+;THAT THE TRANSLATOR GAVE THEM TO STINK
+
+SHUFLE: MOVE B,DDPTR
+ ADD B,[2,,2] ;IGNORE THIS PROGRAM NAME
+ JUMPGE B,CPOPJ ;NO LOCALS IN DDT'S TABLE
+
+SHUF1: MOVE A,(B) ;SQUOOZE
+ TLNN A,740000
+ JRST SHUF2 ;FOUND A BLOCK NAME
+SHUF3: ADD B,[1,,1]
+ AOBJN B,SHUF1
+
+SHUF4: HRRZ A,DDPTR ;EXTENT OF THE SYMBOLS IS KNOWN
+ ;A/POINTER TO BOTTOM SYMBOLS
+ ;B/POINTER TO TOP OF SYMBOLS
+SHUF5: ADDI A,2 ;SYMBOL AT BOTTOM
+ HRRZI B,-2(B) ;SYMBOL AT TOP
+ CAMG B,A
+ POPJ P, ;WE HAVE MET THE ENEMY AND THEY IS US!
+
+ MOVE C,(A) ;SWAP THESE TWO ENTRIES
+ EXCH C,(B)
+ MOVEM C,(A)
+
+ MOVE C,1(A) ;VALUE
+ EXCH C,1(B)
+ MOVEM C,1(A)
+ JRST SHUF5
+
+;HERE WHEN WE FIND A BLOCK NAME
+
+SHUF2: MOVE A,1(B) ;VALUE
+ TLNE A,-1 ;PROGRAM NAME?
+ JRST SHUF4 ;YES
+ JRST SHUF3 ;IGNORE BLOCK NAME
+\f
+GTWD: PUSHJ P,RDWRD ;GOBBLE A WORD FROM THE BUFFER
+ JFCL 4,.+1
+ ADD CKS,T
+ JFCL 4,[AOJA CKS,.+1]
+RELADR: POPJ P,
+
+GETBIT: ILDB TT,BITPTR
+ SKIPL BITPTR
+ POPJ P,
+ EXCH T,BITS
+ SOS BITPTR
+ PUSHJ P,RPB
+ EXCH T,BITS
+ LDB TT,BITPTR
+ POPJ P,
+
+;SUBROUTINE TO GET A WORD FROM BUFFER (GETS NEW ONE IF NEC.)
+
+RDWRD: PUSH P,TT ;SAVE TT
+ MOVE TT,INPTR ;GOBBLE POINTER
+ MOVE T,(TT) ;GOBBLE DATUM
+ AOBJN TT,RDRET ;BUFFER EMPTY?
+DOREAD: MOVE TT,[-STNBLN,,STNBUF] ;YES, READ A NEW ONE
+IFN ITS, .IOT TPCHN,TT ;GOBBLE IT
+IFE ITS,[
+ MOVEM 1,JSYS1
+ MOVEM 2,JSYS2
+ MOVEM 3,JSYS3
+
+ MOVE 2,TT
+ HLRE 3,TT
+ HRLI 2,444400
+ MOVE 1,IJFN
+ SIN
+ SKIPE 3
+ CLOSF
+ JFCL
+ MOVE 1,JSYS1
+ MOVE 2,JSYS2
+ MOVE 3,JSYS3
+]
+ MOVE TT,[-STNBLN,,STNBUF] ;RE GOOBBLE
+RDRET: MOVEM TT,INPTR ;SAVE IT
+ POP P,TT
+ POPJ P,
+
+;HERE TO START FIRST READ
+
+RDFRST: PUSH P,TT
+ JRST DOREAD ;READ A NEW BUFFER
+
+RCKS: (3000+SIXBIT /CKS/)
+\f
+;LOADER INTERFACE
+
+TYPR: 0
+ PUSH P,C
+ PUSH P,T
+ PUSH P,TT
+ LDB C,[(330300)40]
+ MOVEI TT,LI3
+ TRON C,4
+ HRRM TT,TYPR
+ ORCMI C,7
+ HRLZ TT,40
+TYPR2: PUSHJ P,SIXTYO
+ AOJE C,TYPR1
+ PUSHJ P,SPC
+ HRRZ T,ADR
+ PUSHJ P,OPT
+ AOJE C,TYPR1
+ PUSHJ P,SPC
+ PUSHJ P,ASPT
+TYPR1: PUSHJ P,CRL
+ POP P,TT
+ POP P,T
+ POP P,C
+ JRST 2,@TYPR
+
+ASPT: MOVE T,A
+SPT: TLNN T,40000
+ TRO FF,LOCF
+SPT2: TLZ T,740000
+SPT1: IDIVI T,50
+ HRLM TT,(P)
+ JUMPE T,SPT3
+ PUSHJ P,SPT1
+SPT3: TRZE FF,LOCF
+ PUSH P,["*-"0+1,,.+1]
+ HLRE T,(P)
+ ADDI T,"0-1
+ CAILE T,"9
+ ADDI T,"A-"9-1
+ CAILE T,"Z
+ SUBI T,"Z-"#+1
+ CAIN T,"#
+ MOVEI T,".
+ CAIN T,"/
+SPC: MOVEI T,40
+SPTY: JRST TYO
+
+
+;0 1-12 13-44 45 46 47
+;NULL 0-9 A-Z . $ %
+\f
+LI4: CAMN A,[(10700)CBUF-1]
+ JRST LI3
+ LDB T,A
+ ADD A,[(70000)]
+ SKIPGE A
+ SUB A,[(430000)1]
+IFN ITS, .IOT TYOC,T
+IFE ITS,[
+IFN T-1,[
+ MOVEM 1,JSYS1
+ MOVE 1,T
+]
+ PBOUT
+IFN T-1, MOVE 1,JSYS1
+]
+ JRST LI1
+
+TYI:
+IFN ITS, .IOT TYIC,T
+IFE ITS,[
+IFN T-1,[
+ MOVEM 1,JSYS1
+]
+ PBIN
+IFN T-1,[
+ MOVE T,1
+ MOVE 1,JSYS1
+]
+ CAIE T,15
+ CAIN T,12
+ JRST TYO
+ CAIN T,^R
+ JRST TYO
+ POPJ P,
+
+LIS: ANDI FF,GETTY
+LI3: MOVE A,[(10700)CBUF-1]
+ MOVEM A,CPTR
+ MOVE P,[(,-LPDL)PDL-1]
+ PUSHJ P,CRLS
+ TRZ FF,LOCF
+LI1: TRZ FF,ALTF
+LI2: PUSHJ P,TYI
+ CAIN T,33
+ MOVEI T,"\e
+ CAIN T,7
+ JRST LI3
+ CAIN T,177 ;RUBOUT
+ JRST LI4
+ IDPB T,A
+ CAMN A,[(10700)CBUF+CBUFL]
+ JRST LI4
+
+\f
+LIS1: CAIE T,"\e
+ JRST LI1
+ TRON FF,ALTF
+ JRST LI2
+ PUSHJ P,CRL
+CD: MOVEI D,0
+CD3: TRZ FF,ARG
+CD2: ILDB T,CPTR
+ CAIL T,"0
+ CAILE T,"9
+ JRST CD1
+ LSH D,3
+ ADDI D,-"0(T)
+VALRET: TRO FF,ARG
+ JRST CD2
+
+CD1: CAIE T,33
+ CAIN T,DOLL ;CHECK FOR A REAL DOLLAR SIGN
+ JRST LI3
+ CAIL T,"<
+ CAILE T,"[
+ JRST CD
+ IDIVI T,4
+ LDB T,DTAB(TT)
+ MOVEI A,SLIS(T) ;WHERE TO?
+ CAIE A,DUMPY ;IS IT A DUMP
+ TRZ FF,MLAST+SETDEV ;NO, KILL FUNNY FLAGS
+ CAIE A,HASHS ; HASH SET?
+ PUSHJ P,HASHS1 ; MAYBE DO IT
+ PUSHJ P,SLIS(T)
+ JRST CD
+ JRST VALRET
+
+
+\f
+SLIS: TDZA C,C
+MLIS: MOVEI C,2
+ TRNE FF,GETTY
+ PUSHJ P,FORMF
+ TRNE FF,ARG
+ JUMPL D,LISTER
+ MOVE D,BOT
+ JRST LISTER
+
+LISTER: MOVE A,(D)
+ LDB TT,[(410300)A]
+ ORCMI TT,7 ; -1 -> PROGNAME, -2 DEFINED , -4 UNDEFINED
+ AOJN TT,LIST2 ; NOT PROG NAME
+LIST4: PUSHJ P,ASPT
+LIST5: PUSHJ P,VALPT
+ JRST LIST6
+
+LIST2: XOR TT,C ; TT/ -1 IF S AND DEF, OR ? AND UNDEF
+ AOJE TT,LIST7 ; PRINT VALUES
+LIST6: HRRZ D,LIST(D) ; NEXT SYMBOL
+ JUMPN D,LISTER ; MORE, GO ON
+ JRST CRL ; DONE
+
+LIST7: PUSHJ P,SPC ; PRINT UNDEFINED SYMBOL
+ PUSHJ P,ASPT ; PRINT SYMBOL
+ PUSH P,D
+ TRNE FF,ARG ; SKIP IF 1?
+ JUMPN C,LIST9 ; JUMP IF ?
+ PUSHJ P,VALPT
+ JRST LIST8
+LIST9: MOVE D,1(D) ; POINT TO CHAIN
+ PUSHJ P,VALPT
+ HRRZ D,(D)
+ JUMPN D,.-2
+LIST8: POP P,D
+ JRST LIST6
+
+VALPT: PUSHJ P,TAB
+ HRRZ T,1(D) ; SMALL VAL
+ TRNN FF,ARG ; ARG GIVEN?
+ SKIPN C ; OR SS COMM
+ MOVE T,1(D) ; USE FULL WORD
+ JRST OPTCR ; PRINT
+\f
+; INITIALIZES ALL AREAS OF CORE
+
+HASHS: MOVE A,D ; SIZE TO A
+ TRNN FF,ARG ; SKI IF ARG GIVEN
+HASHS1: MOVEI A,INHASH ; USE INITIAL
+ SKIPE HBOT ; SKIP IF NOT DONE
+ POPJ P,
+ PUSH P,A ; NOW SAVEE IT
+ PUSH P,T
+ PUSH P,B
+
+ MOVEI B,LOSYM ; CURRENT TOP
+ ADDI A,LOSYM
+ CAIG A,<INITCR*2000> ; MORE CORE NEEDED?
+ JRST HASHS3 ; NO, OK
+ SUBI A,<INITCR*2000>+1777
+ ASH A,-10.
+HASHS2: PUSHJ P,CORRUP ; UP THE CORE
+ SOJN A,.-1 ; FOR ALL BLOCKS
+
+HASHS3: MOVEM B,HBOT ; STORE AS BOTTOM OF HASH TABLE
+ ADD B,-2(P) ; ADD LENGTH
+ MOVEM B,HTOP ; INTOTOP
+
+ ADDI B,1 ; BUMP
+ MOVEM B,PARBOT ; SAVE AS BOTTOM OF LOADER TABLE AREA
+ MOVEM B,PARCUR ; ALSO AS CURRENT PLACE
+
+ MOVE B,LOBLKS ; CURRENT TOP OF CORE
+ PUSHJ P,CORRUP
+ ASH B,10. ; WORDS
+ SUBI B,1
+ MOVEM B,PARTOP
+ ADDI B,1 ; NOW DDT TABLE
+ MOVEM B,DDBOT
+ ADDI B,1777
+ MOVEM B,DDPTR
+ MOVEM B,DDTOP ; TOP OF DDT TABLE
+ ADDI B,1
+ HRRM B,ADRPTR ; INTO CORE SLOTS
+ HRRM B,BPTR
+ HRRM B,DPTR
+
+ PUSHJ P,CORRUP ; INITIAL CCORE BLOCK
+
+ PUSHJ P,GETMEM
+
+; SET UP INIT SYMBOLS
+
+ MOVE C,[EISYM-EISYME,,EISYM]
+
+SYMINT: MOVE A,(C)
+ TLZ A,600000
+ MOVE B,HTOP
+ SUB B,HBOT
+ IDIVI A,(B) ; HASH IT
+ ADD B,HBOT
+ HRRZ A,(B) ; GET CONTENTS
+ HRROM C,(B)
+ HRRM A,BUCK(C)
+ HRLM B,BUCK(C)
+ SKIPE A
+ HRLM C,(A)
+ ADD C,[3,,3]
+ JUMPL C,SYMINT
+
+
+ POP P,B
+ POP P,T
+ POP P,A
+ POPJ P,
+
+CORRUP: PUSHJ P,GETCOR
+IFN ITS,[
+ PUSHJ P,SCE
+ SKIPE KEEP
+ PUSHJ P,WINP ; WE HAVE THE CORE, TELL LOSER
+]
+ JFCL
+ AOS NBLKS
+ AOS LOBLKS
+CCRL: POPJ P,CRL
+
+IFN ITS,TMSERR: JRST SCE
+\f
+
+EQLS: MOVE T,D
+OPTCR: PUSH P,CCRL
+OPT: MOVEI TT,10
+ HRRM TT,OPT1
+OPT2: LSHC T,-43
+ LSH TT,-1
+OPT1: DIVI T,10
+ HRLM TT,(P)
+ JUMPE T,.+2
+ PUSHJ P,OPT2
+ HLRZ T,(P)
+ ADDI T,260
+TYOM: JRST TYO
+
+TAB: PUSHJ P,SPC
+ PUSHJ P,TYO
+ JRST TYO
+
+CRLS: TRNE FF,GETTY
+ PUSH P,[CRLS1]
+CRL: MOVEI T,15
+ PUSHJ P,TYO
+CRT: SKIPA T,C.12
+FORMF1: MOVEI T,"C
+TYO: IFN ITS, .IOT TYOC,T
+IFE ITS,[
+IFN T-1,[
+ MOVEM 1,JSYS1
+ MOVE 1,T
+]
+ PBOUT
+IFN T-1, MOVE 1,JSYS1
+
+C.12: POPJ P,12
+
+CRLS1: MOVEI T,"*
+ JRST TYO
+
+FORMF: POPJ P,12
+\f
+TDDT: SKIPE LINKDB ;TEST FOR LINK HACKAGE
+ PUSHJ P,LNKFIN ;CLEAN UP LINKS
+ PUSH P,[TDDTEX] ;MAKE SURE 1ST SYM IS A PROGRAM NAME, FOR DDT'S SAKE.
+ HRRZ D,BOT
+ TRO FF,GLOSYM
+
+SYMS: JUMPE D,SYMS5 ; DONE, QUIT
+ MOVE A,(D) ; GET SYMBOL
+ TLNN A,200000 ; SKIP IF DEFINED
+ JRST SYMS6
+ TLNE A,40000 ; SKIP IF LOCAL
+ TRNE FF,GLOSYM ; SKIP IF GLOBALS NOT ACCEPTABLE
+ TLNE A,100000 ; HERE IF LOCAL OR WINNING GLOBAL, SKIP IF NOT PROG NAME
+ JRST SYMS6 ; LOSER, OMIT
+ TRNN FF,GLOSYM ; SKIP IF GLOBAL
+ SKIPL SYMSW ; SKIP IF NO LOCALS
+ JRST SYMS3 ; WINNER!!!, MOVE IT OUT
+
+SYMS8: HRRZ A,LIST(D) ; POINT TO NEXT
+ PUSH P,A ; AND SAVE
+ MOVEM D,T2 ; SAVE FOR PATCH
+ PUSHJ P,PATCH ; FLUSH FROM TABLE
+ POP P,D ; POINT TO NEXT
+ JRST SYMS
+
+SYMS6: HRRZ D,LIST(D) ; POINT TO NEXT SYMBOL
+ JRST SYMS ; AND CONTINUE
+
+SYMS3: TRZ FF,NOTNUM ;ASSUME ALL NUMERIC
+ TLZ A,740000
+ MOVE T,A ;SEE IF IT IS A FUNNY SYMBOL
+ IDIVI T,50 ;GET LAST CHAR IN TT
+ JUMPE TT,OKSYM
+DIVSYM: CAIG TT,12 ;IS THE SYMBOL > 9
+ CAIGE TT,1 ;AND LESS THAN OR EQUAL TO 0
+ TRO FF,NOTNUM ;NO, SAY NOT A NUMBER
+ IDIVI T,50 ;CHECK NEXT
+ JUMPE TT,SYMS8 ;NULL IN THE MIDDLE LOSES
+ JUMPN T,DIVSYM ;DIVIDE UNTIL T IS 0
+ CAIN TT,21 ;IS THIS A "G"
+ TRNE FF,NOTNUM ;YES, SKIP IF SYMBOL OF FORM "GXXXXX" X IS A DIGGIT
+ JRST OKSYM ;WIN
+ JRST SYMS8 ;LOSE
+OKSYM: MOVE T,1(D)
+ HRRZ C,LIST(D) ; POINT TO NEXT
+ PUSH P,C
+ MOVEM D,T2
+ PUSHJ P,PATCH ; FLUSH IT
+ POP P,D
+ TLO A,40000
+ TRNN FF,GLOSYM
+ TLC A,140000 ;DDT LOCAL
+ TLNN A,37777 ;IF SQUOZE "NAME" < 1000000,
+ PUSHJ P,ADDDD2 ;TREAT SPECIALLY (IT IS MIDAS'S SYMTAB IDX)
+ TLNE A,37777
+ PUSHJ P,ADDDDT
+ JRST SYMS
+
+SYMS5: POPJ P,
+\fGO: TRNE FF,ARG
+ MOVEM D,SA
+ TRO FF,GOF
+ JRST DDT
+
+EXAM: CAMLE D,MEMTOP
+ JRST TRYHI ; COULD BE IN HIGH SEG
+ MOVE T,@DPTR
+ JRST OPTCR
+
+TRYHI: TRNE D,400000 ; SKIP IF NOT HIGH
+ CAMLE D,HIGTOP ; SKIP IF OK
+ (3000+SIXBIT /NEM/)
+ MOVE T,(D) ; GET CONTENTS
+ JRST OPTCR
+
+C.CD2: POPJ P,CD2
+
+GETCOM: MOVE A,[10700,,CBUF-1]
+ MOVEM A,CPTR
+ MOVE P,[(,-LPDL)PDL-1]
+ PUSH P,C.CD2
+ MOVEM P,SAVPDL
+IFN ITS,[
+ MOVEI T,0 ;REOPEN CHANNEL IN ASCII MODE
+ HLLM T,DEV
+ .OPEN TPCHN,DEV ;RE OPEN
+ JRST FNF2 ;LOSE
+]
+IFE ITS,[
+ MOVEM 1,JSYS1
+ MOVEM 2,JSYS2
+ MOVEM 3,JSYS3
+ MOVSI 1,100001
+ HRROI 2,FILSTR
+ GTJFN
+ JRST .+3
+ MOVE 2,[070000,,200000]
+ OPENF
+ MOVEI 1,0
+ MOVEM 1,IJFN
+ MOVE 1,JSYS1
+ MOVE 2,JSYS2
+ MOVE 3,JSYS3
+ SKIPN IJFN
+ JRST FNF
+]
+GTCM1:
+IFN ITS, .IOT TPCHN,T
+IFE ITS,[
+ MOVEM 1,JSYS1
+ MOVEM 2,JSYS2
+ MOVEM 3,JSYS3
+
+ MOVE 1,IJFN
+ MOVE 2,[070700,,T]
+ MOVNI 3,1
+ SIN
+
+ SKIPGE 3
+ MOVNI T,1
+ MOVE 1,JSYS1
+ MOVE 2,JSYS2
+ MOVE 3,JSYS3
+]
+ JUMPL T,FIXOPN ;JUMP IF EOF
+ CAIN T,3 ;CHECK FOR EOF
+ JRST FIXOPN ;IF SO QUIT
+ CAIL T,"a
+ CAILE T,"z
+ CAIA
+ SUBI T,40
+ IDPB T,A ;DEPOSIT CHARACTER
+ CAME A,[10700,,CBUF+CBUFL]
+ JRST GTCM1
+TPOK: SKIPA T,BELL
+ERR: MOVE T,"?
+IFN ITS, .IOT TYOC,T
+IFE ITS,[
+ MOVEM 1,JSYS1
+ MOVE 1,T
+ PBOUT
+ MOVE 1,JSYS1
+]
+ PUSHJ P,FIXOPN ;FIX UP OPEN CODE
+ JRST LI3
+
+;HERE TO RESET OPEN
+
+FIXOPN: MOVEI T,6
+ HRLM T,DEV
+ POPJ P,
+
+FNF2: PUSHJ P,FIXOPN
+ JRST FNF
+
+\f
+PAPER: MOVEI A,(SIXBIT /PTR/)
+ HRRM A,DEV
+ POPJ P, ;REAL OPEN WILL OCCUR LATER
+
+UTAP: TRZN FF,ARG
+ JRST OPNTP
+ TRO FF,SETDEV ;SETTING DEVICE
+ MOVE A,DEVTBL(D)
+ HRRM A,DEV
+OPNTP: TRO FF,MLAST ;SET M LAST COMMAND
+ PUSHJ P,FRD
+IFN ITS, .SUSET [.SSNAM,,SNAME]
+ MOVEM B,NM1
+ MOVEM C,NM2
+ POPJ P, ;REAL OPEN WILL OCCUR LATER
+
+OPNPTR:
+IFN ITS,[
+ .OPEN TPCHN,DEV
+ JRST FNF
+ JRST RDFRST ;STAART UP THE READ ING
+]
+IFE ITS,[
+ MOVEM 1,JSYS1
+ MOVEM 2,JSYS2
+ MOVEM 3,JSYS3
+ MOVSI 1,100001
+ HRROI 2,FILSTR
+ GTJFN
+ JRST .+3
+
+ MOVE 2,[440000,,200000]
+ OPENF
+ MOVEI 1,0
+ MOVEM 1,IJFN
+ MOVE 1,JSYS1
+ MOVE 2,JSYS2
+ MOVE 3,JSYS3
+ SKIPN IJFN
+ JRST FNF
+ JRST RDFRST
+]
+NTS: (3000+SIXBIT /NTS/)
+
+DEV: 6,,(SIXBIT /DSK/)
+NM1: SIXBIT /BIN/
+NM2: SIXBIT /BIN/
+0
+SNAME: 0 ;SYSTEM NAME
+JSYS1: 0
+JSYS2: 0
+JSYS3: 0
+IJFN: 0
+OUTJFN: 0
+
+SIXTYO: JUMPE TT,CPOPJ
+ MOVEI T,0
+ LSHC T,6
+ ADDI T,40
+ PUSHJ P,TYO
+ JRST SIXTYO
+
+JOB: PUSHJ P,FRD
+ MOVEM B,JOBNAM
+ TRO FF,JBN
+ POPJ P,
+
+JOBNAM: 0
+
+
+DEVTBL: IRPS DEV,,[DSK UT1 UT2 UT3 UT4 UT5 UT6 UT7 UT8]
+ (SIXBIT /DEV/)
+ TERMIN
+
+FNF: PUSHJ P,TYPFIL
+ REPEAT 2,PUSHJ P,SPC
+IFN ITS,[
+ .OPEN ERCHN,ERRBL ;OPEN ERROR DEVICE
+ JRST .-1 ;DON'T TAKE NO FOR AN ANSWER
+
+ERLP: .IOT ERCHN,A ;READ A CHAR
+ CAIE A,14 ;IF FORM FEED
+ CAIN A,3 ;OR ^C
+ JRST ERDON ;STOP
+
+ .IOT TYOC,A ;PRINT
+ JRST ERLP
+
+ERDON: .CLOSE ERCHN,
+]
+
+ JRST LI3
+
+
+ERRBL: (SIXBIT /ERR/) ;ERROR DEVICE
+ 2
+ TPCHN
+
+
+TYPFIL:
+IFN ITS,[
+ MOVSI A,-4
+ HRLZ TT,DEV
+ JRST .+3
+TYPF2: SKIPN TT,DEV(A)
+ AOJA A,.-1
+ PUSHJ P,SIXTYO
+ MOVE T,TYPFTB(A)
+ PUSHJ P,TYO
+ AOBJN A,TYPF2
+ POPJ P,
+
+TYPFTB: ":
+ 40
+ 40
+ 0
+ ";
+]
+IFE ITS,[
+ MOVE A,[440700,,FILSTR]
+
+ ILDB T,A
+ JUMPE T,.+3
+ PUSHJ P,TYO
+ JRST .-3
+ POPJ P,
+]
+
+
+
+]\f
+LOADN: SKIPA C,SYMFLG
+LOADG: MOVEI C,DDSYMS
+ PUSHJ P,OPNPTR ;DO THE REAL OPEN (AND FIRST READ)
+
+ MOVEM C,SYMSW
+
+RESTAR: MOVEM P,SAVPDL
+ CLEARB CKS,TC
+ CLEARB RH,AWORD
+ PUSH P,CJMP1
+RESETT: MOVEI A,FACTOR ;LEAVE GLOBAL LOCATION MODE
+ HRRM A,REL
+ TRZA FF,UNDEF+GPARAM+INDEF+GLOSYM+SEARCH+CODEF+COND
+SFACT: MOVEM D,FACTOR
+CJMP1: POPJ P,JMP1
+
+KILL: POPJ P,
+COMVAL: SKIPA COMLOC
+SADR: HRRZ D,SA
+POPJ1: AOSA (P)
+COMSET: MOVEM D,COMLOC
+BELL: POPJ P,7
+
+LBRAK: MOVEM D,T1
+ TRZ FF,LOSE
+ PUSHJ P,ISYM
+ MOVE T,T1
+ TRO FF,GPARAM
+ TRZE FF,ARG
+ JRST DFSYM2
+ TLNN B,200000
+ (3000+SIXBIT /UND/)
+ MOVE D,1(D)
+ TRZN FF,LOSE
+ JRST POPJ1
+ (2000+SIXBIT /UND/)
+
+SOFSET: HRRM D,LKUP3
+CPOPJ: POPJ P,
+\f
+
+BEG: MOVE D,FACTOR
+ JRST POPJ1
+
+DDT: SKIPN JOBNAM
+ JRST NJN
+ PUSHJ P,TDDT
+ MOVE A,JOBNAM
+ HRR B,BPTR
+ ADDI B,30
+ HRRM B,YPTR
+ HRLI B,440700
+ MOVEI D,^W
+ IDPB D,B
+ MOVE C,[(000600)A-1]
+ MOVEI T,6
+DDT2: ILDB D,C
+ JUMPE D,DDT1
+ ADDI D,40
+ IDPB D,B
+ SOJG T,DDT2
+\fDMCG,[
+DDT1: MOVEI C,[CONC69 ASCIZ \\e\eJ,\SA,[/\e9B!\eQ\r],\DDPTR,[/\eQ\e\19:VP \]]
+ HRLI C,440700
+DDT6: ILDB T,C
+ IDPB T,B
+ JUMPN T,DDT6 ;END OF STRING MARKED WITH ZERO BYTE
+ MOVE T,SA ;GET STARTING ADDRESS
+ TLNN T,777000 ;IF INSTRUCTION PART ZERO,
+ TLO T,(JRST) ;THEN TURN INTO JRST
+ MOVEM T,SA ;USE AS STARTING ADDRESS
+ TRNE FF,GOF ;IF G COMMAND,
+ MOVEM T,EXIT ;THEN USE AS LOADER EXIT
+ MOVE B,LOBLKS ;GET CURRENT CORE ALLOCATION+1
+ SUBI B,1(NBLKS) ;REDUCE TO PROGRAM CORE ALLOCATION
+ HRRM B,PALLOC ;SAVE IN EXIT ROUTINE
+ LSH B,10. ;SHIFT TO MEMORY LOCATION
+ SUBI B,1 ;REDUCE TO TOP LOCATION IN CORE OF PROGRAM
+ HRRM B,PMEMT ;SAVE FOR MAIN PROGRAM BLT (DON'T LET NON-ZERO CORE ABOVE PROGRAM STAY AROUND)
+ HRLZ 17,BPTR ;GET LOCATION OF BEGINNING OF PROGRAM IN LH(17)
+ ADDM 17,PSV17 ;17 BLT POINTER FOR AC'S, TURN SV17 INTO BLT POINTER FOR PROGRAM
+ MOVE B,EXBLTP ;GET EXIT ROUTINE BLT POINTER
+YPTR:
+IFN ITS, .VALUE ;ADDRESS POINTS TO VALRET STRING
+IFE ITS, HALTF
+ ;DON'T TRY TO STOP THEN START STINK AFTER HERE (AFTER BREAKPOINT OR WITH $G)
+ BLT B,LEXEND ;BLT IN EXIT ROUTINE
+ BLT 17,17 ;BLT IN PROGRAM AC'S
+ EXCH 17,SV17 ;SAVE PROGRAM LOCATION 17, SET UP BLT POINTER
+IFN ITS,[
+ .CLOSE TYOC,
+ .CLOSE TYIC,
+ .CLOSE TPCHN,
+]
+IFE ITS,[
+ MOVEM 1,JSYS1
+ MOVE 1,IJFN
+ CLOSF
+ JFCL
+ MOVE 1,JSYS1
+]
+ JRST LEXIT
+
+ ;EXIT ROUTINE FROM LOADER
+ ;BLT'ED INTO 30 - 30+N
+
+EXBLTP: .+1,,LEXIT ;BLT POINTER
+ OFST==30-. ;LEXIT=30
+LEXIT=.+OFST
+PMEMT: BLT 17, ;BLT DOWN MAIN PROGRAM
+ MOVE 17,SV17 ;GIVE USER HIS LOCATION 17
+PALLOC:
+IFN ITS, .CORE ;REDUCE CORE ALLOCATION TO WHAT REQUIRED BY PROGRAM
+IFE ITS, SKIPA
+PSV17: SV17=.+OFST
+ 40,,40 ;40 FIRST PROGRAM ADDRESS LOADED INTO
+EXIT:
+IFN ITS, .VALUE LEXEND
+IFE ITS, HALTF
+LEXEND=.+OFST
+ 0 ;END OF EXIT ROUTINE
+];DMCG
+\fNODMCG,[
+DDT1: MOVE T,SA ;GET STARTING ADDRESS
+ TLNN T,777000 ;IF INSTRUCTION PART ZERO,
+ TLO T,(JRST) ;THEN TURN INTO JRST
+ MOVEM T,SA ;USE AS STARTING ADDRESS
+ TRNE FF,GOF ;IF G COMMAND,
+ MOVEM T,EXIT ;THEN USE AS LOADER EXIT
+ MOVEI T,DDT4 ;MAKE OPT GO TO DDT4
+ HRRM T,TYOM ;INSTEAD OF TYO
+ MOVEI C,[ASCIZ \\e\eJ\e9B/#0\r#1\e\19\eP\16\] ;# CAUSES FOLLOWING DIGIT TO BE INTERPRETED AS INDEX INTO DDTST
+ HRLI C,440700
+ PUSHJ P,DDTSG ;GENERATE REST OF STRING
+ MOVE B,LOWSIZ ;GET CURRENT CORE ALLOCATION
+ SUBI B,(NBLKS) ;REDUCE TO PROGRAM CORE ALLOCATION
+ MOVE C,B ;SAVE OUR SIZE
+ LSH B,10. ;SHIFT TO MEMORY LOCATION
+ SUBI B,1 ;REDUCE TO TOP LOCATION IN CORE OF PROGRAM
+ HRRM B,PMEMT ;SAVE FOR MAIN PROGRAM BLT (DON'T LET NON-ZERO CORE ABOVE PROGRAM STAY AROUND)
+ SUB C,LOWSIZ
+ MOVNM C,PALL0 ;NUMBER OF BLOCKS TO FLUSH
+ MOVE C,CWORD0
+ TRZ C,400000 ;DELETE PAGE
+ HRRZM C,PALL1
+ HRLZ 17,BPTR ;GET LOCATION OF BEGINNING OF PROGRAM IN LH(17)
+ ADDM 17,PSV17 ;17 BLT POINTER FOR AC'S, TURN SV17 INTO BLT POINTER FOR PROGRAM
+ MOVE B,EXBLTP ;GET EXIT ROUTINE BLT POINTER
+YPTR:
+IFN ITS, .VALUE ;ADDRESS POINTS TO VALRET STRING
+IFE ITS, HALTF
+ ;DON'T TRY TO STOP THEN START STINK AFTER HERE (AFTER BREAKPOINT OR WITH $G)
+ BLT B,LEXEND ;BLT IN EXIT ROUTINE
+ BLT 17,17 ;BLT IN PROGRAM AC'S
+ EXCH 17,SV17 ;SAVE PROGRAM LOCATION 17, SET UP BLT POINTER
+IFN ITS,[
+ .CLOSE TYOC,
+ .CLOSE TYIC,
+ .CLOSE TPCHN,
+]
+IFE ITS,[
+ MOVEM 1,JSYS1
+ MOVE 1,IJFN
+ CLOSF
+ JFCL
+ MOVE 1,JSYS1
+]
+ JRST LEXIT
+
+DDTST: MOVE T,SA ;#0
+ MOVE T,DDPTR ;#1
+
+DDTSN: ILDB T,C ;GET DIGIT AFTER NUMBER SIGN
+ XCT DDTST-"0(T) ;GET VALUE IN T
+ PUSHJ P,OPT ;"TYPE OUT" INTO VALRET STRING IN OCTAL
+DDTSG: ILDB T,C ;GET CHAR FROM INPUT STRING
+ CAIN T,"# ;NUMBER SIGN?
+ JRST DDTSN ;NUMBER SIGN, INTERPRET FOLLOWING DIGIT
+ IDPB T,B ;DEPOSIT IN OUTPUT STRING
+ JUMPN T,DDTSG ;LOOP ON NOT DONE YET
+ POPJ P,
+
+ ;EXIT ROUTINE FROM LOADER
+ ;BLT'ED INTO 20 - 20+N
+
+EXBLTP: .+1,,LEXIT ;BLT POINTER
+ OFST==20-. ;OFFSET, THIS CODE DESTINED FOR LEXIT
+LEXIT=.+OFST ;LEXIT=20
+
+PMEMT: BLT 17, ;BLT DOWN MAIN PROGRAM
+ MOVE 17,PALL1+OFST
+IFN ITS, .CBLK 17,
+IFE ITS, SKIPA
+PSV17: 40,,40 ;40 FIRST PROGRAM ADDRESS LOADED INTO
+ SUBI 17,1000
+ SOSLE PALL0+OFST
+ JRST .+OFST-4
+ MOVE 17,PSV17+OFST ;GIVE USER HIS LOCATION 17
+EXIT:
+IFN ITS, .VALUE .+OFST+1
+IFE ITS, HALTF
+PALL0: 0
+PALL1: 0
+
+LEXEND=.+OFST-1 ;END OF EXIT ROUTINE
+SV17=PSV17+OFST ;LOCATION TO SAVE 17
+];NODMCG
+\f
+NJN: TRZ FF,GOF
+ (3000+SIXBIT /NJN/)
+
+ZERO: MOVEI A,(NBLKS)
+ MOVEM A,LOBLKS
+ PUSHJ P,GETCOR
+IFN ITS,[
+ PUSHJ P,SCE ;GO TO ERROR
+ SKIPE KEEP
+ PUSHJ P,WINP
+]
+ JFCL
+ SETOM MEMTOP
+ MOVEI A,1(NBLKS)
+ MOVEM A,LOBLKS
+GETMEM: PUSHJ P,GETCOR
+IFN ITS,[
+ PUSHJ P,SCE
+ SKIPE KEEP
+ PUSHJ P,WINP
+]
+ JFCL
+
+ ADDI MEMTOP,2000
+ AOS LOBLKS
+ POPJ P,
+
+GETCOR:
+DMCG,[
+IFN ITS,[
+ .CORE @LOBLKS
+ POPJ P,
+]
+ JRST POPJ1
+];DMCG
+
+NODMCG,[
+ PUSH P,A
+ PUSH P,B
+ MOVE B,LOBLKS
+ SUB B,LOWSIZ ;NUMBER OF BLOCKS WE WANT
+ JUMPE B,GETC2
+ SKIPG B
+IFN ITS, .VALUE
+IFE ITS, HALTF
+ MOVE A,CWORD0
+GETC1: ADDI A,1000
+IFN ITS,[
+ .CBLK A,
+ JRST POPBAJ
+]
+ MOVEM A,CWORD0
+ AOS LOWSIZ
+ SOJG B,GETC1
+GETC2: AOS -2(P) ;SKIP RETURN
+ JRST POPBAJ
+];NODMCG
+
+IFN ITS,[
+SCE: SOS (P) ;MAKE POPJ BE A "JRST .-1"
+ SOS (P)
+ PUSHJ P,COREQ ;ASK LOSER
+ POPJ P, ;HE SAID YES
+ (2000+SIXBIT /SCE/)
+
+COREQ: PUSH P,A ;SAVE SOME ACS
+ SKIPE KEEP ; SKIP IF NOT LOOPING
+ JRST COREQ3
+COREQ0: MOVEI A,[ASCIZ /NO CORE:
+ TYPE C TO TRY INDEFINITELY
+ TYPE Y TO TRY ONCE
+ TYPE N TO LOSE/]
+
+ PUSHJ P,LINOUT
+ .IOT TYIC,A ;READ A CHARACTER
+ .RESET TYIC,
+ CAIN A,"N ; WANTS LOSSAGE?
+ JRST COREQ2
+ CAIN A,"Y
+ JRST POPAJ
+ CAIE A,"C
+ JRST COREQ0
+ AOSA KEEP
+COREQ2: AOS -1(P)
+ JRST POPAJ
+
+COREQ3: MOVEI A,1
+ .SLEEP A,
+ JRST POPAJ
+]
+;ROUTINE TO PRINT A LINE
+
+LINOUT: PUSH P,C
+ PUSH P,B
+ MOVSI B,440700+A ;BYTE POINTER TO INDEX OF A
+
+LINO1: ILDB C,B ;GET CHAR
+ JUMPE C,LINO2 ;ZERO, END
+IFN ITS, .IOT TYOC,C
+IFE ITS,[
+ EXCH C,1
+ PBOUT
+ EXCH C,1
+]
+ JRST LINO1
+
+LINO2: MOVEI A,15 ;PUT OUT CR
+IFN ITS, .IOT TYOC,A
+IFE ITS,[
+ EXCH A,1
+ PBOUT
+ EXCH A,1
+]
+ POP P,B
+ POP P,C
+ POPJ P,
+
+WINP: PUSH P,A
+ MOVEI A,[ASCIZ /WIN!!!/]
+ PUSHJ P,LINOUT
+ SETZM KEEP
+ JRST POPAJ
+\f
+DEFINE FOUR A,B,C,D
+ (<<A-SLIS>_9>+B-SLIS)<<C-SLIS>_9>+D-SLIS
+ TERMIN
+
+DTAB: (331100+T)DTB-74/4
+ (221100+T)DTB-74/4
+ (111100+T)DTB-74/4
+ (1100+T)DTB-74/4
+
+DTB: FOUR LBRAK,EQLS,ERR,MLIS, ;< = > ?
+ FOUR GETCOM,ERR,BEG,COMSET, ;@ A B C
+ FOUR DDT,NTS,NTS,GO, ;D E F G
+ FOUR HASHS,ERR,JOB,KILL, ;H I J K
+ FOUR LOADG,UTAP,LOADN,SOFSET, ;L M N O
+ FOUR PAPER,COMVAL,SFACT,SLIS, ;P Q R S
+ FOUR CPOPJ,ERR,ERR,ERR, ;T U V W
+ FOUR SADR,DUMPY,ZERO,EXAM, ;X Y Z [
+
+IFLE 1000-DDT+SLIS,[PRINTX /DISPATCH OVERFLOW
+/]
+INFORM [DISPATCH ROOM]\<1000-DDT+SLIS>
+
+\f
+;THIS CODE DUMPS THE LOADED CORE IMAGE INTO A DISK FILE AND THEN CAUSES
+;STINK TO KILL ITSELF.
+
+DUMPY:
+IFN ITS,[
+ TRZN FF,MLAST ;WAS "M" THE LAST COMMAND?
+ PUSHJ P,FIXFIL ;FIX UP THE FILE NAME
+ MOVEI A,(SIXBIT /DSK/)
+ TRZN FF,SETDEV ;WAS DEVICE SET?
+ HRRM A,DEV ;NO, SET IT
+
+ .OPEN TPCHN,DEV ;SEE IF IT EXISTS
+ JRST OPNOK ;NO, WIN
+
+ .CLOSE TPCHN, ;CLOSE IT
+ .FDELE DEV ;DELETE IT
+ JFCL ;IGNORE LOSSAGE
+
+OPNOK: MOVSI A,7 ;SET DEVICE SPEC TO BE WRITE/IMAGE/BLOCK
+ HLLM A,DEV
+ .OPEN TPCHN,DEV ;OPEN THE CHANNEL
+ JRST FNF
+]
+IFE ITS,[
+ MOVEM 1,JSYS1
+ MOVEM 2,JSYS2
+ MOVEM 3,JSYS3
+ MOVSI 1,1
+ HRROI 2,FILSTR
+ GTJFN
+ JRST .+3
+ MOVE 2,[440000,,300000]
+ OPENF
+ MOVEI 1,0
+ MOVEM 1,OUTJFN
+ MOVE 1,JSYS1
+ MOVE 2,JSYS2
+ MOVE 3,JSYS3
+ SKIPN OUTJFN
+ JRST FNF
+]
+ PUSHJ P,TDDT ;MOVE ALL SYMBOLS TO DDT TABLE
+IFN ITS,[
+ MOVE B,[JRST 1] ;START FILE WITH "JRST 1"
+ PUSHJ P,OUTWRD ;PUT IT OUT
+]
+ MOVE B,LOWSIZ ;GET CURRENT CORE ALLOCATION
+ SUBI B,(NBLKS) ;REDUCE TO PROGRAM CORE ALLOCATION
+ LSH B,10. ;SHIFT TO MEMORY LOCATION
+ SUBI B,1 ;REDUCE TO TOP LOCATION IN CORE OF PROGRAM
+ MOVEI ADR,20 ; GET TOP OF LOW SEG IN USER'S LOC 20
+ HRRZM B,@ADRPTR
+
+ MOVN ADR,MEMTOP ;GET -<LENGTH OF CORE IMAGE>
+ HRLZS ADR ;AOBJN POINTER
+
+DMP2: SKIPN B,@ADRPTR ;LOOK FOR THE FIRST NON-ZERO WORD
+ AOBJN ADR,.-1 ;UNTIL THE WORLD IS EXHAUSTED
+ JUMPGE ADR,CHKHI ;DROPPED THROUGH, JUMP IF CORE EMPTY
+
+ MOVEI C,(ADR) ;SAVE POINTER TO NON ZERO WORD
+ MOVEI A,(C) ;AND ANOTHER COPY
+
+DMP1: SKIPE B,@ADRPTR ;NOW LOOK FOR END OF NON ZERO BLOCK
+ AOBJN ADR,.-1 ;UNTIL WORLD EXHAUSTED
+ JUMPGE ADR,DMPLST ;IF WORLD EMPTY, QUIT
+
+ AOBJP ADR,DMPLST ;CHECK NEXT WORD
+ SKIPE B,@ADRPTR ;FOR BEING ZERO
+ JRST DMP1 ;ONE LONE ZERO, DON'T END BLOCK
+
+DMPLST: MOVEI D,(ADR) ;POINT TO END
+ SUB C,D ;C/ -<LENGTH OF BLOCK>
+ HRL A,C ;A/ AOBJN TO BLOCK
+ MOVE B,A ;COPY TO B FOR OUTWRD
+IFE ITS, SUBI B,1
+ PUSHJ P,OUTWRD ;PUT IT OUT
+IFE ITS, ADDI B,1
+ HRRI B,@BPTR ;NOW POINT TO REAL CORE
+IFN ITS, .IOT TPCHN,B ;BARF IT OUT
+IFE ITS,[
+ MOVEM 1,JSYS1
+ MOVEM 2,JSYS2
+ MOVEM 3,JSYS3
+
+ MOVE 2,B
+ HLRE 3,B
+ HRLI 2,444400
+ MOVE 1,OUTJFN
+ SOUT
+ MOVE 1,JSYS1
+ MOVE 2,JSYS2
+ MOVE 3,JSYS3
+]
+
+IFN ITS,[
+ MOVE B,A ;GET POINTER BACK IN B
+ MOVE C,B ;FIRST WORD IN CHECK SUM
+ HRRI B,@BPTR ;POINT TO REAL CORE
+
+ ROT C,1 ;ROTATE CKS
+ ADD C,(B) ;ADD
+ AOBJN B,.-2 ;AND DO FOR ENTIRE BLOCK
+
+ MOVE B,C ;CKS TO B
+ PUSHJ P,OUTWRD ;AND PUT IT OUT
+]
+ JUMPL ADR,DMP2 ;IF MORE, GO DO IT
+
+CHKHI: SKIPN MEMTOP,HIGTOP ; ANY HIGH SEG
+ JRST DMPSYMS ; NO, GO ON TO SYMS
+ SETZM HIGTOP ; RESET IT
+ HLLZS ADRPTR ; FIX UP POINTERS
+ HLLZS BPTR
+ LDB ADR,[2100,,MEMTOP] ; GET NO. OF WORDS
+ MOVNS ADR ; NEGATE
+ MOVSI ADR,(ADR)
+ HRRI ADR,400000 ; START OF HIGH SEG
+ JRST DMP2
+
+
+;HERE TO DO START ADDRESS
+
+DMPSYMS: HRRZ B,SA ;GET START ADR
+IFN ITS, HRLI B,(JUMPA) ;USE "JUMPA" TO MAKE DDT HAPPY
+IFE ITS, HRLI B,1
+ PUSHJ P,OUTWRD
+
+;HERE TO DO SYMBOLS
+
+IFE ITS,[
+; ON TENEX/20 CLOSE FILE AND CREATE SEPARATE SYMBOL FILE
+
+ MOVEM 1,JSYS1
+ MOVEM 2,JSYS2
+ MOVEM 3,JSYS3
+
+ MOVE 1,OUTJFN
+ CLOSF
+ JFCL
+
+ MOVE 1,[440700,,FILSTR]
+
+FNDNMX: ILDB 2,1
+ CAIE 2,"<
+ JRST FNDNM2
+
+ ILDB 2,1
+ CAIE 2,">
+ JRST .-2
+ ILDB 2,1
+
+FNDNM2: JUMPE 2,.+3
+ CAIE 2,".
+ JRST FNDNMX
+
+ MOVEI 2,".
+ DPB 2,1
+
+ MOVE 3,[440700,,[ASCIZ /SYMBOLS/]]
+ ILDB 2,3
+ IDPB 2,1
+ JUMPN 2,.-2
+
+ MOVSI 1,1
+ HRROI 2,FILSTR
+ GTJFN
+ JRST .+3
+ MOVE 2,[440000,,300000]
+ OPENF
+ MOVEI 1,0
+ MOVEM 1,OUTJFN
+ MOVE 1,JSYS1
+ MOVE 2,JSYS2
+ MOVE 3,JSYS3
+ SKIPN OUTJFN
+ JRST FNF
+]
+IFN ITS,[
+ HLLZ B,DDPTR ;GET NUMBER
+ PUSHJ P,OUTWRD ;PUT IT OUT
+
+ MOVE C,DDPTR ;FOR CKS
+ .IOT TPCHN,DDPTR ;OUT GOES THE WHOLE TABLE
+]
+
+IFE ITS,[
+ MOVE A,DDPTR
+ MOVEI B,0 ; WILL COUNT SYMS
+
+TWNTY1: MOVE T,(A)
+ TLZ T,740000 ; KILL SQUOZE BITS
+
+ MOVE D,T
+ IDIVI T,50 ; CONVERT TO 10X/20 SQUOZE
+ JUMPN TT,.+3
+ MOVE D,T
+ JRST .-3
+
+ HLLZ T,(A)
+ TLZ T,37777 ; JUST GET SQUOZE BITS
+ JUMPN T,TWNTY2 ; JUMP UNLESS PROG NAME
+ ADDI B,1
+TWNTY2: ADDI B,1
+ IOR D,T
+ MOVEM D,(A)
+ ADD A,[2,,2]
+ JUMPL A,TWNTY1
+
+; HAVE COUNTED SYMS AND FIXED UP SYMBOLS, START OUTPUTTING
+
+ ASH B,1
+ MOVNS B
+ MOVSS B
+ PUSHJ P,OUTWRD ; PUT OUT COUNT
+
+ MOVE A,DDPTR
+
+TWNTY3: MOVE D,A
+ MOVEI C,0
+TWNTY5: MOVE T,(A) ; SEARCH FOR A PROG NAME (OR END)
+ TLNN T,740000
+ JRST TWNTY4
+ ADD A,[2,,2]
+ ADDI C,2
+ JUMPL A,TWNTY5
+
+TWNTY6: JUMPE C,TWNTY7
+ MOVNS C
+ HRL D,C
+ MOVEM 1,JSYS1
+ MOVEM 2,JSYS2
+ MOVEM 3,JSYS3
+
+ MOVE 1,OUTJFN
+ MOVE 2,D
+ HRLI 2,444400
+ HLRE 3,D
+ SOUT
+ MOVE 1,JSYS1
+ MOVE 2,JSYS2
+ MOVE 3,JSYS3
+TWNTY7: ADD A,[2,,2]
+ JUMPL A,TWNTY3
+]
+IFN ITS,[
+ ROT B,1
+ ADD B,(C) ;ADD IT
+ AOBJN C,.-2
+
+ PUSHJ P,OUTWRD ;PUT OUT THE CKS
+
+ MOVSI B,(JRST) ;FINISH WITH "JRST 0"
+ PUSHJ P,OUTWRD
+
+ MOVNI B,1 ;FINISH WITH NEGATIVE
+ PUSHJ P,OUTWRD
+
+ .CLOSE TPCHN, ;CLOSE THE FILE
+]
+IFE ITS,[
+ EXCH 1,OUTJFN
+ CLOSF
+ JFCL
+ EXCH 1,OUTJFN
+]
+
+IFN ITS, .VALUE [ASCIZ /:KILL /] ;KILL
+IFE ITS,[
+ HALTF
+
+TWNTY4: MOVE B,T
+ PUSHJ P,OUTWRD
+ MOVEI B,0
+ PUSHJ P,OUTWRD
+ MOVEI B,0
+ PUSHJ P,OUTWRD
+ MOVEI B,0
+ PUSHJ P,OUTWRD
+ JRST TWNTY6
+
+;SUBROUTINE TO PUT OUT ONE WORD
+
+OUTWRD: HRROI T,B ;AOBJN POINTER TO B
+IFN ITS, .IOT TPCHN,T
+IFE ITS,[
+ MOVEM 1,JSYS1
+ MOVEM 2,JSYS2
+ MOVEM 3,JSYS3
+ MOVE 2,B
+ MOVE 1,OUTJFN
+ BOUT
+ MOVE 1,JSYS1
+ MOVE 2,JSYS2
+ MOVE 3,JSYS3
+]
+ POPJ P,
+
+
+
+\f
+;HERE TO BUILD DEFAULT OUTPUT FILE NAME
+
+FIXFIL: MOVE A,[SIXBIT /_STNK_/] ;DEFAULT NAME 1
+ MOVEM A,NM1
+ MOVE A,[SIXBIT /DUMP/] ;AND NAME 2
+ MOVEM A,NM2
+ POPJ P,
+\f
+; CORE AND TABLE MANAGEMENT ROUTINES FOR HASH CODED TABLE STINK.
+
+PAIR: PUSH P,B
+ SKIPN A,PARLST ; ANY ON FREE LIST?
+ JRST PAIR1 ; NO, TRY FREE AREA
+ HRRZ B,(A) ; YES, CDR THE LIST
+ MOVEM B,PARLST
+PAIR3A: SETZM (A) ; CLEAR 1ST WORD
+PAIR3: POP P,B
+ POPJ P,
+
+PAIR1: MOVE A,PARCUR ; TRY FREE AREA
+ ADDI A,2 ; WORDS NEEDED
+ CAML A,PARTOP ; SKIP IF ROOM EXISTS
+ JRST PAIR2
+PAIR4: EXCH A,PARCUR ; RETURN POINTER AND RESET PARCUR
+ JRST PAIR3A
+
+QUAD: PUSH P,B
+ SKIPN A,QUADLS ; SKIP IF ANY THERE
+ JRST QUAD1
+ HRRZ B,(A) ; CDR THE QUAD LIST
+ MOVEM B,QUADLS
+ JRST PAIR3A
+
+QUAD1: MOVE A,PARCUR ; GET TOP
+ ADDI A,4
+ CAML A,PARTOP ; OVERFLOW?
+ JRST QUAD2 ; YES, GET MORE
+ JRST PAIR4 ; NO, WIN
+
+PAIR2: PUSHJ P,MORPAR ; GET MORE CORE
+ JRST PAIR1
+
+QUAD2: PUSHJ P,MORPAR
+ JRST QUAD1
+
+PARRET: PUSH P,B
+ HRRZ B,PARLST ; SPLICE IT INTO FREE LIST
+ HRRM B,(A)
+ MOVEM A,PARLST
+ JRST PAIR3 ; RETURN POPPING B
+
+QUADRT: PUSH P,B
+ HRRZ B,QUADLS
+ HRRM B,(A)
+ MOVEM A,QUADLS
+ JRST PAIR3
+\f
+; HERE TO ALLOCATE MORE STORAGE (1 BLOCK) FOR SYMBOL TABLE STUFF
+
+MORPAR: PUSHJ P,GETCOR ; TRY AND GET A BLOCK
+IFN ITS,[
+ PUSHJ P,TMSERR ; COMPLAIN
+ SKIPE KEEP
+ PUSHJ P,WINP
+]
+ JFCL
+ AOS NBLKS
+ PUSHJ P,MOVCOD ; TRY AND GET CODE OUT OF THE WAY
+ PUSHJ P,MOVDD ; ALSO GET DDT SYMBOLS OUT
+ MOVEI A,2000 ; INCREASE PARTOP
+ ADDM A,PARTOP
+ AOS LOBLKS
+ POPJ P,
+
+; HERE TO MOVE CODE
+
+MOVCOD: PUSH P,C
+ PUSH P,B
+ HRRZ A,ADRPTR ; POINT TO CURRENT START
+ ADDI A,2000 ; NEW START
+ MOVE C,A
+ HRRM A,ADRPTR ; FIX POINTERS
+ HRRM A,BPTR
+ HRRM A,DPTR
+ MOVE B,LOBLKS ; GEV(CURRENT TOP (IN BLOCKS)
+ ASH B,10. ; CONVERT TO WORDS
+
+MOVCO3: MOVEI A,-2000(B) ; A/ POINT TO LAST DESTINATION
+ CAIG B,(C) ; SKIP IF NOT DONE
+ JRST MOVCO2
+ HRLI A,-2000(A) ; B/ FIRST SOURCE,,FIRST DESTINATION
+ BLT A,-1(B)
+ SUBI B,2000
+ JRST MOVCO3
+
+MOVCO2: POP P,B
+ POP P,C
+ POPJ P,
+
+
+; HERE TO MOVE DDT SYMBOLS
+
+MOVDD: PUSH P,C
+ PUSH P,C
+ HRRZ A,DDPTR ; GET CURRENT POINTER
+ ADDI A,2000
+ HRRM A,DDPTR
+ HRRZ A,DDTOP ; TOP OF DDT TABLE
+ ADDI A,2000
+ MOVEM A,DDTOP
+
+ MOVEI B,1(A) ; SET UP FOR BLT LOOP
+ HRRZ C,DDBOT
+ ADDI C,2000 ; BUMP
+ MOVEM C,DDBOT
+ JRST MOVCO3 ; FALL INTO BLT LOOP
+
+
+;HAVE NAME W/ FLAGS IN A, VALUE IN T,
+;PUT SYM IN DDT SYMBOL TABLE.
+ADDDDT: PUSH P,A
+ PUSH P,B
+ADDDD1: MOVE A,DDPTR
+ SUB A,[2,,2]
+ HRRZ B,DDBOT
+ CAILE B,(A) ; SKIP IF OK
+ JRST GROWDD ; MUST GROW DDT TABLE
+ MOVEM A,DDPTR
+ MOVEM T,1(A) ; CLOBBER AWAY
+ POP P,B
+ POP P,(A)
+ MOVE A,(A) ; RESTORE A
+ POPJ P,
+
+GROWDD: PUSHJ P,GETCOR
+IFN ITS,[
+ PUSHJ P,TMSERR
+ SKIPE KEEP
+ PUSHJ P,WINP
+]
+ JFCL
+ AOS NBLKS
+ PUSHJ P,MOVCOD ; MOVE THE CODE
+ PUSHJ P,MOVDD
+ MOVNI A,2000
+ ADDM A,DDBOT
+ AOS LOBLKS
+ JRST ADDDD1
+
+ADDDD2: PUSH P,A ;CALL HERE FROM SYMS OR TDDT.
+ PUSH P,B
+ SKIPA B,DDPTR ;SPECIAL LOCAL SYM, LOOK FOR STE WITH SAME "NAME".
+ADDDD3: ADD B,[2,,2]
+ JUMPGE B,POPBAJ ;NO ENTRY, THROW AWAY SYM.
+ HLL A,(B)
+ CAME A,(B)
+ JRST ADDDD3 ;NOT THIS ONE.
+ MOVE A,1(B) ;SYM'S REAL NAME IS IN 2ND WD OF STE,
+ MOVEM A,(B)
+ MOVEM T,1(B) ;PUT IN THE VALUE.
+ JRST POPBAJ
+
+;TDDT EXITS THROUGH HERE.
+TDDTEX: PUSH P,A ;MAKE SURE 1ST STE IN FILE IS PROGRAM NAME.
+ PUSH P,B
+ SKIPA A,DDPTR
+TDDTE1: ADD A,[2,,2]
+ JUMPGE A,POPBAJ ;NO PROGRAM NAMES AT ALL => NO PROBLEM.
+ MOVE B,(A)
+ TLNE B,740000
+ JRST TDDTE1 ;THIS NOT PROGRAM NAME.
+ CAMN A,DDPTR
+ JRST POPBAJ ;IF IT'S ALREADY 1ST, NO PROBLEM.
+ MOVE B,DDPTR
+REPEAT 2,[
+ EXCH T,.RPCNT(A) ;EXCHANGE PROGRAM NAME WITH 1ST STE.
+ EXCH T,.RPCNT(B)
+ EXCH T,.RPCNT(A)]
+ JRST POPBAJ
+\fISYM: MOVSI C,(50*50*50*50*50*50)
+ MOVSI T,40000 ;GLOBAL BIT
+
+ISYM0: ILDB A,CPTR
+ CAIN A,"*
+ TLZ T,40000 ;LOCAL
+ CAIN A,"*
+ JRST ISYM0
+ CAIN A,">
+ JRST LKUP
+ SUBI A,"0-1
+ CAIL A,"A-"0+1
+ SUBI A,"A-"0+1-13
+ JUMPGE A,ISYM2
+ ADDI A,61
+ CAIN A,60
+ MOVEI A,45 ;.
+ISYM2: IDIVI C,50
+ IMUL A,C
+ ADDM A,T
+ JRST ISYM0
+
+\f
+IFN ITS,[
+FRD2: CAME B,[SIXBIT /@/]
+ JRST DEVNAM
+ SKIPA B,C
+FRD: MOVSI B,(SIXBIT /@/)
+ MOVSI C,(SIXBIT /@/)
+ MOVE A,[(600)C-1]
+FRD1: ILDB T,CPTR
+ CAIE T,33
+ CAIN T,DOLL
+ JRST CHBIN ;CHECK IF SHOULD CHANGE NAME 2 TO BIN
+ TRC T,40
+ JUMPE T,FRD2
+ CAIN T,32
+ JRST DEVSET
+ CAIN T,33
+ JRST USRSET
+ CAIN T,77
+ MOVEI T,0
+ CAME A,[(600)C]
+ IDPB T,A
+ JRST FRD1
+
+
+
+
+USRSET: MOVEM C,SNAME
+ JRST FRD+1
+
+DEVNAM: PUSH P,CDEVN1
+ MOVEM C,NM2
+ JRST FRD+1
+
+DEVNM1: TRO FF,SETDEV ;SAY DEVICE SET
+ HLRM C,DEV
+ MOVE C,NM2
+ JRST CHBIN ;CHECK FOR CHANGE TO BIN
+
+DEVSET: TRO FF,SETDEV ;DEVICE SET
+ HLRM C,DEV
+ JRST FRD+1
+
+CHBIN: CAME B,[SIXBIT /@/] ;WAS NO NAME2 SUPPLIED?
+ POPJ P, ;NAME2 SUPPLIED, GO AWAY
+ MOVE B,C ;MAKE NAME1 INTO NAME2
+NODMCG, MOVSI C,(SIXBIT /REL/) ;USE REL FOR NAME2
+DMCG, MOVSI C,(SIXBIT /BIN/)
+CDEVN1: POPJ P,DEVNM1
+]
+IFE ITS,[
+FRD:
+ MOVE B,[440700,,FILSTR]
+
+FRD2: ILDB T,CPTR
+ CAIE T,DOLL
+ CAIN T,33
+ JRST FRD1 ; FINISHED
+ IDPB T,B
+ JRST FRD2
+
+FRD1: MOVEI T,0
+ IDPB T,B ; ASCIZ
+ POPJ P,
+]
+CONSTANTS
+\f;IMPURE STORAGE
+
+EISYM: ;INITIAL SYMBOLS
+
+CRELPT: SQUOZE 64,$R.
+FACTOR: 100
+ 0
+CPOINT: SQUOZE 64,$.
+ 100
+ 0
+ SQUOZE 64,.LVAL1
+.VAL1: 0
+ 0
+ SQUOZE 64,.LVAL2
+.VAL2: 0
+ 0
+ SQUOZE 64,USDATL
+USDATP: 0
+ 0
+EISYME:
+
+POLSW: 0 ;-1=>WE ARE DOING POLISH
+PPDP: -PPDL,,PPDB-1 ;INITIAL POLISH PUSH DOWN POINTER
+PPDB: BLOCK PPDL+1 ;POLISH PUSH DOWN BLOCK
+SATED: 0 ;COUNT OF POLISH FIXUPS TO BE DELETED
+SATPDP: -SATPDL,,SATPDB-1 ;POINTER TO POLISH FIXUPS TO BE DELETED
+SATPDB: BLOCK SATPDL+1 ;LIST OF POLISH FIXUPS TO BE DELETED
+SVSAT: 0 ;# OF OPERANDS NEEDED
+POLPNT: 0 ;POINTER TO POLISH CHAIN
+CGLOB: 0 ;CURRENT GLOBAL IN SOME SENSE
+CGLOBV: 0 ;CURRENT GLOBAL VALUE IN SOME SENSE
+GLBFS: 0 ;GLOBAL BEING FIXED UP DURINGS DEFERED REQUEST
+SVHWD: 0 ;WORD CURRENTLY BEING READ BY POLISH
+GLBCNT: 0 ;# UNDEFINED FIXUPS DURING READING PHASE OF POLISH
+HEADNM: 0 ;# POLISH FIXUPS SEEN
+LFTFIX: 0 ;-1=> LEFT HALF FIXUP IN PROGRESS
+LINKDB: BLOCK MNLNKS+1 ;LINK DATA BLOCK (END LINK,,CURRENT VALUE)
+HIBLK: 0 ; BLOCKS IN HIGH SEG
+KEEP: 0 ; FLAG SAYING WE ARE IN A CORE LOOP
+DMCG,[
+USINDX: 0 ; USER INDEX
+];DMCG
+HIGTOP: 0 ; TOP OF HIGH SEG
+INPTR: 0 ;HOLDS CURRENT IO POINTER
+STNBUF: BLOCK STNBLN ;BUFFER FOR BLOCK READS
+PAT: BLOCK 100
+PATEND==.+1
+CPTR: 0
+AWORD: 0
+ADRPTR: <INITCR*2000>(ADR)
+BPTR: <INITCR*2000>(B)
+DPTR: <INITCR*2000>(D)
+SA: 0
+TC: 0
+BITS: 0
+BITPTR: (300)BITS
+SAVPDL: 0
+LBOT: INITCR*2000
+TIMES: 0
+COMLOC: ICOMM
+T1: 0
+T2: 0
+FLSH: 0
+PRGNAM: 0
+
+; CORE MANAGEMENT VARIABLES
+
+NODMCG,[
+CWORD0: 4000,,400000+<<INITCR-1>_9.>
+CWORD1: 4000,,600000-1000
+LOWSIZ: INITCR ; NUMBER BLOCKS WE GOT (IN LOW SEGMENT)
+];NODMCG
+LOBLKS: INITCR+1 ; NUMBER OF BLOCKS OF CORE WE WANT
+PARBOT: 0 ; POINT TO BOTTOM OF SYMBOL TABLES
+PARTOP: 0 ; POINT TO TOP OF SAME
+PARLST: 0 ; LIST OF AVAILABLE 2 WORD BLOCKS
+QUADLS: 0 ; LIST OF AVAILABLE 4 WORD BLOCKS
+PARCUR: 0 ; TOP CURRENTLY IN USE SYMBOL TABLE CORE
+
+DDPTR: 0 ; AOBJN POINTER TO CURRENT DDT SYMBOL TABLE
+DDTOP: 0 ; HIGHEST ALLOCATED FOR DDT
+DDBOT: 0 ; LOWEST ALLOCATED FOR DDT
+
+HTOP: 0 ; TOP OF HASH TABLE
+HBOT: 0 ; BOTTOM OF HASH TABLE
+\fINIT:
+PDL: IFN ITS, .SUSET [.RSNAM,,SNAME] ;GET INITIAL SYSTEM NAME
+ MOVEI A,100
+ MOVEM A,FACTOR
+ MOVE NBLKS,[20,,INITCR]
+ MOVEI A,ICOMM
+ MOVEM A,COMLOC
+ HLLZS LKUP3
+ SETOM MEMTOP
+ MOVEI A,FACTOR
+ HRRM A,REL
+ MOVE P,[-100,,PDL]
+ PUSHJ P,KILL
+IFN ITS,[
+ .OPEN TYOC,TTYO
+ .VALUE 0
+ .OPEN TYIC,TTYI
+ .VALUE 0
+ .STATUS TYIC,T
+ ANDI T,77
+ CAIN T,2
+ TRO FF,GETTY
+]
+ MOVE TT,[SIXBIT /STINK./]
+ PUSHJ P,SIXTYO
+ MOVE TT,[.FNAM2]
+ PUSHJ P,SIXTYO
+IFN ITS, .SUSET [.RMEMT,,TT]
+IFE ITS,[
+ MOVEI TT,INITCR*2000
+]
+ LSH TT,-10.
+ MOVEM TT,LOWSIZ
+ SUBI TT,1
+ LSH TT,9.
+ TDO TT,[4000,,400000]
+ MOVEM TT,CWORD0
+ JRST LIS
+
+TTYO==.
+ 1,,(SIXBIT /TTY/)
+ SIXBIT /STINK/
+ SIXBIT /OUTPUT/
+
+TTYI==.
+ 30,,(SIXBIT /TTY/)
+ SIXBIT /STINK/
+ SIXBIT /INPUT/
+
+CONSTANTS
+
+LOC PDL+LPDL
+CBUF: BLOCK CBUFL
+FILSTR: BLOCK 10 ; GOOD FOR 40 CHARS
+LOSYM: ;LOWEST LOC AVAIL FOR SYM TBL
+INITCR==<LOSYM+3000>/2000 ;LDR LENGTH IN BLOCKS
+
+INFORM [HIGHEST USED]\LOSYM
+INFORM [LOWEST LOCATION LOADED ]\LOWLOD
+INFORM [COMMAND BUFFER LENGTH]\<CBUFL*5>
+INFORM [INITIAL CORE ALLOCATION]\INITCR
+
+END PDL
+\ 3\ 3
\ No newline at end of file
--- /dev/null
+CONN INT:
+DEL MDLXXX.*.*
+DELVER
+YY*.*.*
+EXP
+DEL MDL:MDLXXX.*.*
+DEL MDL:*.SAV00.*
+EXP MDL:
+STINK
+MMUD105.STINK\e@\e\eMMDLXXX.EXE\eY\e\eRESET .
+
+NDDT
+;YMDLXXX.EXE
+;UMDLXXX.EXE
+;OMDLXXX.SYMBOLS
+
+INTFCN\eK
+NAME1\eK
+BUFRIN\eK
+PROCID\eK
+IOIN2\eK
+ITEM\eK
+NIL\eK
+TYPVEC\eK
+INAME\eK
+ECHO\eK
+CHANNO\eK
+VAL\eK
+CHRCNT\eK
+0STO\eK
+TYPBOT\eK
+ERASCH\eK
+DIRECT\eK
+INDIC\eK
+INTFCN\eK
+KILLCH\eK
+TTICHN\eK
+ASTO\eK
+BRKCH\eK
+NODPNT\eK
+ESCAP\eK
+BSTO\eK
+TTOCHN\eK
+SYSCHR\eK
+BRFCHR\eK
+CSTO\eK
+ROOT\eK
+ASOLNT\eK
+BRFCH2\eK
+BYTPTR\eK
+INITIA\eK
+DSTO\eK
+ESTO\eK
+INTOBL\eK
+PVPSTO\eK
+ERROBL\eK
+MUDOBL\eK
+TVPSTO\eK
+ABSTO\eK
+INTNUM\eK
+STATUS\eK
+INTVEC\eK
+QUEUES\eK
+TBSTO\eK
+CHNL1\eK
+.LIST.\eK
+GCPDL\eK
+CONADJ\eK
+T.CHAN\eK
+N.CHNS\eK
+SLENGC\eK
+LENGC\eK
+SECLEN\eK
+;WMDLXXX.SYMBOLS
+;H
+RESET .
+NDDT
+;YMDLXXX.EXE
+;OMDLXXX.SYMBOLS
+NSEGS/3
+MASK1/700541,,2007
+\eP;UMDLXXX.EXE
+;H
+RES .
+CONN MDL:
+NDDT
+;YINT:MDLXXX.EXE
+;OINT:MDLXXX.SYMBOLS
+\eG<FLOAD "MDL:NEWMUD">\e
+<SETG L-SEARCH-PATH ("LIBMUD" "PS:<MDLLIB>LIBMUD" [] ["PS" "LIBMUD"])>\e
+<FOO>\e;HCONN INT:
+CONT
+;UMDLXXX.EXE
+;H
+LOGOUT
--- /dev/null
+TITLE VCREATE MCR001 C. REEVE (CLR)
+
+RELOCA
+
+.INSRT MUDDLE >
+
+.GLOBAL VCREATE,MUDSTR
+
+DEBUG: MOVE E,[440600,,[SIXBIT /EXPERIMENTAL/]]
+ MOVEI 0,12.
+ JRST STUFF
+
+VCREATE: .SUSET [.SSNAM,,[SIXBIT /MUDSYS/]]
+ .OPEN 0,OP%
+ .VALUE
+ MOVEI 0,0 ; SET 0 TO DO THE .RCHST
+ .RCHST 0
+ .CLOSE 0
+ .FDELE DB%
+ .VALUE
+ MOVE E,[440600,,B]
+ MOVEI 0,6
+STUFF: MOVE D,[440700,,MUDSTR+2]
+STUFF1: ILDB A,E ; GET A CHAR
+ CAIN A,0 ;SUPRESS SPACES
+ MOVEI A,137 ;RUBOUT'S DON'T TYPE OUT
+ ADDI A,40 ; TO ASCII
+ IDPB A,D ; STORE
+ SOJN 0,STUFF1
+ SETZM 34
+ SETZM 35
+ SETZM 36
+ .VALUE
+
+OP%: 1,,(SIXBIT /DSK/)
+ SIXBIT /TMUD%/
+ SIXBIT />/
+
+DB%: (SIXBIT /DSK/)
+ SIXBIT /TMUD%/
+ SIXBIT /</
+ 0
+ 0
+
+CONSTANTS
+
+EDB:
+
+ END
+\f\ 3\f\ 3
\ No newline at end of file
--- /dev/null
+
+TITLE SETPUR
+
+1PASS
+
+BOT==700000
+
+.GLOBAL .LPUR,.LIMPU,HIBOT,PHIBOT,REALGC
+REALGC==200000
+
+LOC 140
+
+.LIMPU==140
+
+HIBOT==BOT
+PHIBOT==BOT_<-10.>
+
+.LPUR==BOT
+
+LOC BOT
+
+END
+\f\ 3\f
\ No newline at end of file
--- /dev/null
+TITLE UTILITY FUNCTIONS FOR MUDDLE
+
+RELOCATABLE
+
+.INSRT MUDDLE >
+
+SYSQ
+
+IFE ITS,[
+.INSRT STENEX >
+XJRST==JRST 5,
+]
+
+.GLOBAL GODUMP,IPURIF,EGCDUM,EPURIF,LODGC,KILGC,CALER,RBLDM,CPOPJ,C1POPJ,INQAGC,FRETOP
+.GLOBAL SAT,PGFIND,PGGIVE,PGTAKE,PINIT,ERRKIL,CKPUR,GCSET,MKTBS,PFLG,NPWRIT,GETNUM
+.GLOBAL AGC,AAGC,%CLSM1,%SHWND,IBLOCK,FINAGC,PGINT,CPOPJ1,REHASH,FRMUNG,MAXLEN,TOTCNT
+.GLOBAL NWORDT,NWORDS,MSGTYP,IMTYO,MULTSG,MULTI,NOMULT,GCDEBU
+.GLOBAL PURCOR,INCORF,BADCHN,INTHLD,%MPIN1,WNDP,WIND,ACCESS,PURTOP,GCPDL,CTIME,P.CORE
+.GLOBAL IAGC,IAAGC,TYPVEC,PURBOT,PURTOP,MOVPUR,PURVEC,PMAPB,CURPLN,RFRETP,NOWFRE,FREMIN
+.GLOBAL MAXFRE,TPGROW,PDLBUF,CTPMX,PGROW,PDLBUF,CPMX,SAVM,NOWP,NOWTP,MPOPJ,GCFLG,GCDOWN
+.GLOBAL GCTIM,NOSHUF,P.TOP,GETPAG,ITEM,INDIC,ASOVEC,ASOLNT,GETBUF,KILBUF,PAT,PATEND
+.GLOBAL PATCH,DSTORE,PVSTOR,SPSTOR,SQKIL,IAMSGC,FNMSGC,RNUMSP,NUMSWP,SWAPGC,SAGC,GCSTOP
+.GLOBAL ISECGC
+.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
+
+FPAG==2000
+
+; GC-DUMP TAKES AN OBJECT AND MAPS IT INTO A FILE DIRECTLY USING THE GARBAGE
+; COLLECTOR. ALL OBJECTS HAVE RELATIVIZED POINTERS AND WILL BE SET UP UPON
+; READIN (USING GC-READ).
+; IT TAKES TWO ARGUMENTS. THE FIRST IS THE OBJECT THE SECOND MUST BE A "PRINTB"
+; CHANNEL.
+
+MFUNCTION GCDUMP,SUBR,[GC-DUMP]
+
+ ENTRY
+
+IFE ITS,[
+ PUSH P,MULTSG
+ SKIPE MULTSG ; MUST RUN I 0 SEXTION MODE
+ PUSHJ P,NOMULT
+]
+ MOVE PVP,PVSTOR+1
+ IRP AC,,[FRM,P,R,M,TP,TB,AB]
+ MOVEM AC,AC!STO"+1(PVP)
+ TERMIN
+
+ SETZM PURCOR
+ SETZM INCORF ; SET UP PARAMS
+ CAML AB,C%M20 ; CHECK ARGS
+ JRST TFA
+ CAMG AB,C%M60
+ JRST TMA
+ GETYP A,2(AB) ; SEE WHETHER THE CHANNEL IS A WINNER
+ CAIN A,TFALSE ; SKIP IF NOT FALSE
+ JRST UVEARG
+ CAIE A,TCHAN
+ JRST WTYP2 ; ITS NOT A CHANNEL. COMPLAIN
+ MOVE B,3(AB) ; CHECK BITS IN CHANNEL
+ HRRZ C,-2(B)
+ TRC C,C.PRIN+C.OPN+C.BIN
+ TRNE C,C.PRIN+C.OPN+C.BIN
+ JRST BADCHN
+ PUSH P,1(B) ; SAVE CHANNEL NUMBER
+ CAMGE AB,C%M40 ; SEE IF THIRD ARG WAS SNUCK IN
+ JRST TMA
+ JRST IGCDUM
+
+UVEARG: SETOM INCORF ; SET UP FLAG INDICATING UVECTOR
+ CAML AB,C%M40 ; SEE IF THIRD ARG
+ JRST IGCDUM
+ GETYP A,5(AB)
+ CAIE A,TFALSE
+ SETOM PURCOR
+IGCDUM: SETZM SWAPGC
+ PUSHJ P,LODGC ; GET THE GARBAGE COLLECTOR
+ SETOM INTHLD
+ JRST GODUMP
+
+EGCDUM: PUSH P,A ; SAVE LENGTH
+ PUSHJ P,KILGC ; KILL THE GARBAGE COLLECTOR
+ POP P,A
+ SETZM INTHLD
+ SKIPN INCORF ; SKIP IF TO UVECTOR
+ JRST OUTFIL
+ SKIPN PURCOR ; SKIP IF PURE UVECTOR
+ JRST BLTGCD
+
+; ROUTINE TO CREATE A UVECTOR IN PURE STORAGE CONTAINING GC-DUMPED
+; OBJECTS.
+
+ ADDI A,1777 ; ROUND
+ ANDCMI A,1777
+ ASH A,-10. ; TO BLOCKS
+ PUSH P,A ; SAVE IT
+TRAGN: PUSHJ P,PGFIND ; TRY TO GET PAGES
+ JUMPL B,GCDPLS ; LOSSAGE?
+ POP P,A ; GET # OF PAGES
+ PUSH P,B ; SAVE B\r
+ MOVNS A ; BUILD AOBJN POINTER
+ HRLZS A
+ ADDI A,FPAG/2000 ; START
+ HLL B,A ; SAME # OF PAGES
+ PUSHJ P,%MPIN1
+ POP P,B ; RESTORE # OF FIRST PAGE
+ ASH B,10. ; TO ADDRESS
+ POP P,A ; RESTORE LENGTH IN WORDS
+ MOVNI A,-2(A) ; BUILD AOBJN
+ HRL B,A
+ MOVE A,$TUVEC ; TYPE WORD
+ JRST DONDUM ; FINISH
+
+; HERE WHEN EFFORTS TO GE PURE STORAGE FAIL.
+
+GCDPLS: MOVE A,(P) ; GET # OF PAGES
+ ASH A,10. ; TO WORDS
+ ADDI A,1777
+ ANDCMI A,1777 ; ROUND AND TO PAGE
+ MOVEM A,GCDOWN
+ MOVE C,[13.,,9.] ; CAUSE INDICATOR
+ PUSHJ P,AGC ; CAUSE AGC TO HAPPEN
+ MOVE A,(P) ; GET # OF PAGES
+ JRST TRAGN ; TRY AGAIN
+
+; HERE TO TRANSFER FROM INFERIOR TO THE FILE
+OUTFIL: PUSH P,A ; SAVE LENGTH OF FILE
+ PUSHJ P,SETBUF
+ MOVE A,(P)
+ ANDCMI A,1777
+ ASH A,-10. ; TO PAGES
+ MOVNS A ; SET UP AOBJN POINTER
+ HRLZS A
+ ADDI A,1 ; STARTS ON PAGE ONE
+ MOVE C,-1(P) ; GET ITS CHANNEL #
+ MOVE B,BUFP ; WINDOW PAGE
+ JUMPGE A,DPGC5
+IFN ITS,[
+DPGC3: MOVE D,BUFL
+ HRLI D,-2000 ; SET UP BUFFER IOT POINTER
+ PUSHJ P,%SHWND ; SHARE INF PAGE AND WINDOW
+ DOTCAL IOT,[C,D]
+ FATAL GCDUMP-- IOT FAILED
+ AOBJN A,DPGC3
+]
+IFE ITS,[
+DPGC3: MOVE B,BUFP
+ PUSHJ P,%SHWND
+ PUSH P,A ; SAVE A
+ PUSH P,C ; SAVE C
+ MOVE A,C ; CHANNEL INTO A
+ MOVE B,BUFL ; SET UP BYTE POINTER
+ HRLI B,444400
+ MOVNI C,2000
+ SOUT ; OUT IT GOES
+ POP P,C
+ POP P,A ; RESTORE A
+ AOBJN A,DPGC3
+]
+
+DPGC5: MOVE D,(P) ; CALCULATE AMOUNT LEFT TO SEND OUT
+ MOVE 0,D
+ ANDCMI D,1777 ; TO PAGE BOUNDRY
+ SUB D,0 ; SET UP AOBJN PTR FOR OUTPUT
+IFN ITS,[
+ HRLZS D
+ ADD D,BUFL
+ MOVE B,BUFP ; SHARE WINDOW
+ PUSHJ P,%SHWND
+ DOTCAL IOT,[C,D]
+ FATAL GCDUMP-- IOT FAILED
+]
+IFE ITS,[
+ MOVE B,BUFP ; SET UP WINDOW
+ PUSHJ P,%SHWND
+ MOVE A,C ; CHANNEL TO A
+ MOVE C,D
+ MOVE B,BUFL ; SET UP BYTE POINTER
+ HRLI B,444400
+ SOUT
+] POP P,D
+ MOVE B,3(AB) ; GET CHANNEL
+ ADDM D,ACCESS(B)
+
+ PUSHJ P,KILBUF
+ MOVE A,(AB) ; RETURN WHAT IS GIVEN
+ MOVE B,1(AB)
+DONDUM: PUSH TP,A ; SAVE RETURNS
+ PUSH TP,B
+ PUSHJ P,%CLSM1
+ SUB P,C%11
+IFE ITS,[
+ POP P,MULTSG
+ SKIPE MULTSG
+ PUSHJ P,MULTI
+]
+ POP TP,B
+ POP TP,A
+ JRST FINIS
+
+
+; HERE TO BLT INTO A UVECTOR IN GCS
+
+BLTGCD: PUSH P,A ; SAVE # OF WORDS
+ PUSHJ P,SETBUF
+ MOVE A,(P)
+ PUSHJ P,IBLOCK ; GET THE UVECTOR
+ PUSH TP,A ; SAVE POINTER TO IT
+ PUSH TP,B
+ MOVE C,(P) ; GET # OF WORDS
+ ASH C,-10. ; TO PAGES
+ PUSH P,C ; SAVE C
+ MOVNS C
+ HRLZS C
+ ADDI C,FPAG/2000
+ MOVE B,BUFP ; WINDOW ACTS AS A BUFFER
+ HRRZ D,(TP) ; GET PTR TO START OF UVECTOR
+ JUMPGE C,DUNBLT ; IF < 1 BLOCK
+LOPBLT: MOVEI A,(C) ; GET A BLOCK
+ PUSHJ P,%SHWND
+ MOVS A,BUFL ; SET UP TO BLT INTO UVECTOR
+ HRRI A,(D)
+ BLT A,1777(D) ; IN COMES ONE BLOCK
+ ADDI D,2000 ; INCREMENT D
+ AOBJN C,LOPBLT ; LOOP
+DUNBLT: MOVEI A,(C) ; SHARE LAST PAGE
+ PUSHJ P,%SHWND
+ MOVS A,BUFL ; SET UP BLT
+ HRRI A,(D)
+ MOVE C,-1(P) ; GET TOTAL # OF WORDS
+ MOVE 0,(P)
+ ASH 0,10.
+ SUB C,0 ; CALCULATE # LEFT TO GO
+ ADDI D,-1(C) ; END OF UVECTOR
+ BLT A,(D)
+ SUB P,C%22 ; CLEAN OFF STACK
+ PUSHJ P,KILBUF
+ POP TP,B
+ POP TP,A
+ JRST DONDUM ; DONE
+
+SETBUF: MOVEI A,1
+ PUSHJ P,GETBUF
+ MOVEM B,BUFL
+ ASH B,-10.
+ MOVEM B,BUFP
+ POPJ P,
+
+\f
+; LITTLE ROUTINES USED ALL OVER THE PLACE
+
+MSGTYP: HRLI B,440700 ;MAKE BYTE POINTER
+MSGTY1: ILDB A,B ;GET NEXT CHARACTER
+ JUMPE A,CPOPJ ;NULL ENDS STRING
+ CAIE A,177 ; DONT PRINT RUBOUTS
+ PUSHJ P,IMTYO
+ JRST MSGTY1 ;AND GET NEXT CHARACTER
+CPOPJ: POPJ P,
+
+
+; ROUTINE TO PURIFY A STRUCTURE AND FREEZE ATOMS POINTED TO BY IT.
+; TAKES ONE ARGUMENT, THE ITEM TO PURIFY
+
+MFUNCTION PURIF,SUBR,[PURIFY]
+
+ ENTRY
+
+ JUMPGE AB,TFA ; CHECK # OF ARGS
+
+IFE ITS,[
+ PUSH P,MULTSG
+ SKIPE MULTSG ; MUST RUN I 0 SEXTION MODE
+ PUSHJ P,NOMULT
+]
+ MOVE C,AB
+ PUSH P,C%0 ; SLOT TO SEE IF WINNER
+PURMO1: HRRZ 0,1(C)
+ CAML 0,PURTOP
+ JRST PURMON ; CHECK FOR PURENESS
+ GETYP A,(C) ; SEE IF ITS MONAD
+ PUSHJ P,SAT
+ ANDI A,SATMSK
+ CAIE A,S1WORD
+ CAIN A,SLOCR
+ JRST PURMON
+ CAIN A,SATOM
+ JRST PURMON
+ SKIPE 1(C) ; SKIP IF EMPTY
+ SETOM (P)
+PURMON: ADD C,C%22 ; INC AND GO
+ JUMPL C,PURMO1
+ POP P,A ; GET MARKING
+ JUMPN A,PURCON
+NPF: MOVE A,(AB) ; FINISH IF MONAD
+ MOVE B,1(AB)
+IFE ITS,[
+ POP P,MULTSG
+ SKIPE MULTSG
+ PUSHJ P,MULTI
+]
+ JRST FINIS
+
+PURCON: SETZM SWAPGC
+ PUSHJ P,LODGC ; LOAD THE GARBAGE COLLECTOR
+ SETOM INTHLD
+ SETOM NPWRIT
+ JRST IPURIF
+
+EPURIF: PUSHJ P,KILGC
+ SETZM INTHLD
+ SETZM NPWRIT
+IFE ITS,[
+ SKIPN MULTSG
+ JRST NPF
+ POP P,B
+ HRRI B,NPF
+ MOVEI A,0
+ XJRST A
+]
+IFN ITS,[
+ JRST NPF
+]
+
+
+\f
+; ROUTINE TO DO A SPECIAL GARBAGE COLLECT, CALLED FOR FREE STORAGE GARBAGE
+; COLLECTS
+; AND CAN RUN A MARK/SWEEP GARBAGE COLLECT
+
+SAGC:
+IFE ITS,[
+ JRST @[.+1] ; RETURN WITH US NOW TO THE THRILLING
+ ; DAYS OF SEGMENT 0
+]
+ SOSL NUMSWP ; GET NUMBER OF SWEEP GARBAGE COLLECTS
+ JRST MSGC ; TRY MARK/SWEEP
+ MOVE RNUMSP ; MOVE IN RNUMSWP
+ MOVEM NUMSWP ; SMASH IT IN
+ JRST GOGC
+MSGC: SKIPN PGROW ; CHECK FOR STACK OVERFLOW
+ SKIPE TPGROW
+ JRST AGC ; IF SO CAUSE REAL GARBAGE COLLECT
+ PUSH P,C
+ PUSH P,D
+ PUSH P,E
+ SETOM SWAPGC ; LOAD MARK SWEEP VERSION
+ PUSHJ P,AGC1 ; CAUSE GARBAGE COLLECT
+ HRRZ 0,MAXLEN ; SEE IF REQUEST SATISFIED
+ CAMGE 0,GETNUM
+ JRST LOSE1
+ MOVE C,FREMIN ; GET FREMIN
+ SUB C,TOTCNT ; CALCULATE NEEDED
+ SUB C,FRETOP
+ ADD C,GCSTOP
+ JUMPL C,DONE1
+ JSP E,CKPUR ; GO CHECK FOR SOME STUFF
+ MOVE D,PURBOT
+IFE ITS, ANDCMI D,1777 ; MAKE LIKE AN ITS PAGE
+ SUB D,CURPLN ; CALCULATE PURENESS
+ SUB D,P.TOP
+ CAIG D,(C) ; SEE IF PURENESS EXISTS
+ JRST LOSE1
+ PUSH P,A
+ ADD C,GCSTOP
+ MOVEI A,1777(C)
+ ASH A,-10.
+ PUSHJ P,P.CORE
+ FATAL P.CORE FAILED
+ HRRZ 0,GCSTOP
+ SETZM @0
+ HRLS 0
+ ADDI 0,1
+ HRRZ A,FRETOP
+ BLT 0,-1(A)
+ POP P,A
+DONE1: POP P,E
+ POP P,D
+ POP P,C
+IFN ITS, POPJ P,
+IFE ITS,[
+ SKIPN MULTSG
+ POPJ P,
+ SETZM 20
+ POP P,21 ; BACK TO CALLING SEGMENT
+ XJRST 20
+]
+LOSE1: POP P,E
+ POP P,D
+ POP P,C
+GOGC:
+
+
+AGC:
+IFE ITS,[
+ SKIPE MULTSG
+ SKIPE GCDEBU
+ JRST @[SEC1]
+ XJRST .+1
+ 0
+ FSEG,,SEC1
+SEC1:
+]
+ MOVE 0,RNUMSP
+ MOVEM 0,NUMSWP
+ SETZM SWAPGC
+AGC1: SKIPE NPWRIT
+ JRST IAGC
+ EXCH P,GCPDL
+ PUSHJ P,SVAC ; SAVE ACS
+ PUSHJ P,SQKIL
+ PUSHJ P,CTIME
+ MOVEM B,GCTIM
+ PUSHJ P,LODGC ; LOAD GC
+ PUSHJ P,RSAC ; RESTORE ACS
+ EXCH P,GCPDL
+ SKIPE SWAPGC
+ JRST IAMSGC
+ SKIPN MULTSG
+ JRST IAGC
+ JRST ISECGC
+
+AAGC: SETZM SWAPGC
+ EXCH P,GCPDL
+ PUSHJ P,SVAC ; SAVE ACS
+ PUSHJ P,LODGC ; LOAD GC
+ PUSHJ P,RSAC ; RESTORE ACS
+ EXCH P,GCPDL
+ JRST IAAGC
+
+FNMSGC:
+FINAGC: SKIPE NPWRIT
+ JRST FINAGG
+ PUSHJ P,SVAC ; SAVE ACS
+ PUSHJ P,KILGC
+ PUSHJ P,RSAC
+FINAGG:
+IFN ITS, POPJ P,
+IFE ITS,[
+ SKIPN MULTSG
+ POPJ P,
+ SETZM 20
+ POP P,21 ; BACK TO CALLING SEGMENT
+ XJRST 20
+]
+
+; ROUTINE TO SAVE THE ACS
+
+SVAC: EXCH 0,(P)
+ PUSH P,A
+ PUSH P,B
+ PUSH P,C
+ PUSH P,D
+ PUSH P,E
+ JRST @0
+
+; ROUTINE TO RESTORE THE ACS
+
+RSAC: POP P,0
+ POP P,E
+ POP P,D
+ POP P,C
+ POP P,B
+ POP P,A
+ EXCH 0,(P)
+ POPJ P,
+
+
+\f
+
+; INTERNAL FUNCTION TO GET STRAGE ALLOCATION TYPE
+; GETS THE TYPE CODE IN A AND RETURNS SAT IN A.
+
+SAT: LSH A,1 ; TIMES 2 TO REF VECTOR
+ HRLS A ; TO BOTH HALVES TO HACK AOBJN
+ ; POINTER
+ ADD A,TYPVEC+1 ; ACCESS THE VECTOR
+ HRR A,(A) ; GET PROBABLE SAT
+ JUMPL A,.+2 ; DID WE REALLY HAVE A VALID
+ ; TYPE
+ MOVEI A,0 ; NO RETURN 0
+ ANDI A,SATMSK
+ POPJ P, ; AND RETURN
+
+; FIND AND ALLOCATE AS MANY CONTIGUOUS PAGES AS INDICATED BY REG A
+; RETURN THE NUMBER (0-255.) OF THE FIRST SUCH PAGE IN REG B
+; RETURN -1 IN REG B IF NONE FOUND
+
+PGFIND:
+ JUMPLE A,FPLOSS
+ CAILE A,256.
+ JRST FPLOSS
+
+ PUSHJ P,PGFND1 ; SEE IF ALREADY ENOUGH
+ SKIPN NOSHUF ; CAN'T MOVE PURNESS
+ SKIPL B ; SKIP IF LOST
+ POPJ P,
+
+ SUBM M,(P)
+ PUSH P,E
+ PUSH P,C
+ PUSH P,D
+PGFLO4: MOVE C,PURBOT ; CHECK IF ROOM AT ALL
+ ; (NOTE POTENTIAL FOR INFINITE LOOP)
+ SUB C,P.TOP ; TOTAL SPACE
+ MOVEI D,(C) ; COPY FOR CONVERSION TO PAGES
+ ASH D,-10.
+ CAIGE D,(A) ; SKIP IF COULD WIN
+ JRST PGFLO1
+
+ MOVNS A ; MOVE PURE AREA DOWN "A" PAGES
+ PUSHJ P,MOVPUR
+ MOVE B,PURTOP ; GET FIRST PAGE ALLOCATED
+ ASH B,-10. ; TO PAGE #
+PGFLOS: POP P,D
+ POP P,C
+ POP P,E
+ PUSHJ P,RBLDM ; GET A NEW VALUE FOR M
+ JRST MPOPJ
+
+; HERE TO SHUFFLE PURE SPACE TO TRY TO FIND PAGES
+
+PGFLO1: SKIPE GCFLG ; SKIP IF NOT IN GC
+ JRST PGFLO5 ; WE LOST
+ MOVE C,PURTOP
+ SUB C,P.TOP
+ HRRZ D,FSAV(TB) ; ARE WE IN A PURE RSUBR?
+ CAIL D,HIBOT ; ARE WE AN RSUBR AT ALL?
+ JRST PGFLO2
+ GETYP E,(R) ; SEE IF PCODE
+ CAIE E,TPCODE
+ JRST PGFLO2
+ HLRZ D,1(R) ; GET OFFSET TO PURVEC
+ ADD D,PURVEC+1
+ HRROS 2(D) ; MUNG AGE
+ HLRE D,1(D) ; GET LENGTH
+ ADD C,D
+PGFLO2: ASH C,-10.
+ CAILE A,(C)
+ JRST PGFLO3
+ PUSH P,A
+IFE ITS, ASH A,1 ; TENEX PAGES ARE HALF SIZE
+ PUSHJ P,GETPAG ; SHUFFLE THEM AROUND
+ FATAL PURE SPACE LOSING
+ POP P,A
+ JRST PGFLO4
+
+; HERE TO CAUSE AGC IF PAGES ARE NOT AVAILABLE EVEN AFTER MAPPING OUT THE WORLD
+
+
+PGFLO3: PUSH P,A ; ASK GC FOR SPACE
+ ASH A,10.
+ MOVEM A,GCDOWN ; REQUEST THOSE PAGES
+ MOVE C,[8.,,9.]
+ PUSHJ P,AGC ; GO GARBAGE COLLECT
+ POP P,A
+ JRST PGFLO4 ; GO BACK TO POTENTIAL LOOP
+
+
+PGFLO5: SETOM B ; -1 TO B
+ JRST PGFLOS ; INDICATE LOSSAGE
+
+PGFND1: PUSH P,E
+ PUSH P,D
+ PUSH P,C
+ PUSH P,C%M1 ; POSSIBLE CONTENTS FOR REG B
+ PUSH P,A ; SAVE LENGTH OF BLOCK DESIRED FOR LATER USE
+ SETZB B,C ; INITIAL SECTION AND PAGE NUMBERS
+ MOVEI 0,0 ; COUNT OF PAGES ALREADY FOUND
+ PUSHJ P,PINIT
+PLOOP: TDNE E,D ; FREE PAGE ?
+ JRST NOTFRE ; NO
+ JUMPN 0,NFIRST ; FIRST FREE PAGE OF A BLOCK ?
+ MOVEI A,(B) ; YES SAVE ADDRESS OF PAGE IN REG A
+ IMULI A,16.
+ ASH C,-1 ; BACK TO PAGES
+ ADDI A,(C)
+ ASH C,1 ; FIX IT TO WHAT IT WAS
+NFIRST: ADDI 0,1
+ CAML 0,(P) ; TEST IF ENOUGH PAGES HAVE BEEN FOUND
+ JRST PWIN ; YES, FINISHED
+ SKIPA
+NOTFRE: MOVEI 0,0 ; RESET COUNT
+ PUSHJ P,PNEXT ; NEXT PAGE
+ JRST PLOSE ; NONE--LOSE RETURNING -1 IN REG B
+ JRST PLOOP
+
+PWIN: MOVEI B,(A) ; GET WINNING ADDRESS
+ MOVEM B,(P)-1 ; RETURN ADDRESS OF WINNING PAGE
+ MOVE A,(P) ; RELOAD LENGTH OF BLOCK OF PAGES
+ MOVE 0,[TDO E,D] ; INST TO SET "BUSY" BITS
+ JRST ITAKE
+
+; CLAIM OR RETURN TO FREE STORAGE AS MANY CONTIGUOUS PAGES AS INDICATED BY REG A
+; THE NUMBER (0 - 255.) OF THE FIRST SUCH PAGE IS IN REG B
+PGGIVE: MOVE 0,[TDZ E,D] ; INST TO SET "FREE" BITS
+ SKIPA
+PGTAKE: MOVE 0,[TDO E,D] ; INST TO SET "BUSY" BITS
+ JUMPLE A,FPLOSS
+ CAIL B,0
+ CAILE B,255.
+ JRST FPLOSS
+ PUSH P,E
+ PUSH P,D
+ PUSH P,C
+ PUSH P,B
+ PUSH P,A
+ITAKE: IDIVI B,16.
+ PUSHJ P,PINIT
+ SUBI A,1
+RTL: XCT 0 ; SET APPROPRIATE BIT
+ PUSHJ P,PNEXT ; NEXT PAGE'S BIT
+ JUMPG A,FPLOSS ; TOO MANY ?
+ SOJGE A,RTL
+ MOVEM E,PMAPB(B) ; REPLACE BIT MASK
+PLOSE: POP P,A
+ POP P,B
+ POP P,C
+ POP P,D
+ POP P,E
+ POPJ P,
+
+
+PINIT: MOVE E,PMAPB(B) ; GET BITS FOR THIS SECTION
+ HRLZI D,400000 ; BIT MASK
+ IMULI C,2
+ MOVNS C
+ LSH D,(C) ; SHIFT TO APPROPRIATE BIT POSITION
+ MOVNS C
+ POPJ P,
+
+PNEXT: AOS (P) ; FOR SKIP RETURN ON EXPECTED SUCCESS
+ LSH D,-2 ; CONSIDER NEXT PAGE
+ CAIL C,30. ; FINISHED WITH THIS SECTION ?
+ JRST PNEXT1
+ AOS C
+ AOJA C,CPOPJ ; NO, INCREMENT AND CONTINUE
+PNEXT1: MOVEM E,PMAPB(B) ; REPLACE BIT MASK
+ SETZ C,
+ CAIGE B,15. ; LAST SECTION ?
+ AOJA B,PINIT ; NO, INCREMENT AND CONTINUE
+ SOS (P) ; YES, UNDO SKIP RETURN
+ POPJ P,
+
+FPLOSS: FATAL PAGE LOSSAGE
+
+PGINT: MOVEI B,HIBOT ; INITIALIZE MUDDLE'S PAGE MAP TABLE
+ IDIVI B,2000 ; FIRST PAGE OF PURE CODE
+ MOVE C,HITOP
+ IDIVI C,2000
+ MOVEI A,(C)+1
+ SUBI A,(B) ; NUMBER OF SUCH PAGES
+ PUSHJ P,PGTAKE ; MARK THESE PAGES AS TAKEN
+ POPJ P,
+
+
+
+\f
+ERRKIL: PUSH P,A
+ PUSHJ P,KILGC ; KILL THE GARBAGE COLLECTOR
+ POP P,A
+ JRST CALER
+
+; IF IN A PURE RSUBR, FIND ITS LENGTH AND FUDGE ITS LRU
+
+CKPUR: HRRZ A,FSAV(TB) ; GET NAME OF CURRENT GOODIE
+ SETZM CURPLN ; CLEAR FOR NONE
+ CAIL A,HIBOT ; IF LESS THAN TOP OF PURE ASSUME RSUBR
+ JRST (E)
+ GETYP 0,(A) ; SEE IF PURE
+ CAIE 0,TPCODE ; SKIP IF IT IS
+ JRST NPRSUB
+NRSB2: HLRZ B,1(A) ; GET SLOT INDICATION
+ ADD B,PURVEC+1 ; POINT TO SLOT
+ HRROS 2(B) ; MUNG AGE
+ HLRE A,1(B) ; - LENGTH TO A
+ TRZ A,777
+ MOVNM A,CURPLN ; AND STORE
+ JRST (E)
+NPRSUB: SKIPGE B,1(R) ; SEE IF PURE RSUBR
+ JRST (E)
+ MOVE A,R
+ JRST NRSB2
+
+; THIS IS THE SCHEME USED TO UPDATE CERTAIN IMFORMATION USED BY THE
+; BLOAT-SPEC ROUTINE TO GIVE USERS IMFORMATION ABOUT USE OF SPACE BY
+; THEIR MUDDLE.
+
+GCSET: MOVE A,RFRETP ; COMPUTE FREE SPACE AVAILABLE
+ SUB A,PARTOP
+ MOVEM A,NOWFRE
+ CAMLE A,MAXFRE
+ MOVEM A,MAXFRE ; MODIFY MAXIMUM
+ HLRE A,TP ; FIND THE DOPE WORD OF THE TP STACK
+ MOVNS A
+ ADDI A,1(TP) ; CLOSE TO DOPE WORD
+ CAME A,TPGROW
+ ADDI A,PDLBUF ; NOW AT REAL DOPE WORD
+ HLRZ B,(A) ; GET LENGTH OF TP-STACK
+ MOVEM B,NOWTP
+ CAMLE B,CTPMX ; SEE IF THIS IS THE BIGGEST TP
+ MOVEM B,CTPMX
+ HLRE B,P ; FIND DOPE WORD OF P-STACK
+ MOVNS B
+ ADDI B,1(P) ; CLOSE TO IT
+ CAME B,PGROW ; SEE IF THE STACK IS BLOWN
+ ADDI B,PDLBUF ; POINTING TO IT
+ HLRZ A,(B) ; GET IN LENGTH
+ MOVEM A,NOWP
+ CAMLE A,CPMX ; SEE IF WE HAVE THE BIGGEST P STACK
+ MOVEM A,CPMX
+ POPJ P, ; EXIT
+
+RBLDM: JUMPGE R,CPOPJ
+ SKIPGE M,1(R) ; SKIP IF FUNNY
+ JRST RBLDM1
+
+ HLRS M
+ ADD M,PURVEC+1
+ HLLM TB,2(M)
+ SKIPL M,1(M)
+ JRST RBLDM1
+ PUSH P,0
+ HRRZ 0,1(R)
+ ADD M,0
+ POP P,0
+RBLDM1: SKIPN SAVM ; SKIP IF FUNNY (M)
+ POPJ P, ; EXIT
+ MOVEM M,SAVM
+ MOVEI M,0
+ POPJ P,
+CPOPJ1:
+C1POPJ: AOS (P)
+ POPJ P,
+
+
+\f
+; THIS ROUTINE MAKES SURE CURRENT FRAME MAKES SENSE
+FRMUNG: MOVEM D,PSAV(A)
+ MOVE SP,SPSTOR+1
+ MOVEM SP,SPSAV(A)
+ MOVEM TP,TPSAV(A) ; SAVE FOR MARKING
+ POPJ P,
+
+
+; SUBROUTINE TO REBUILD THE NOW DEFUNCT HASH TABLE
+
+REHASH: MOVE D,ASOVEC+1 ; GET POINTER TO VECTOR
+ MOVEI E,(D)
+ PUSH P,E ; PUSH A POINTER
+ HLRE A,D ; GET -LENGTH
+ MOVMS A ; AND PLUSIFY
+ PUSH P,A ; PUSH IT ALSO
+
+REH3: HRRZ C,(D) ; POINT TO FIRST BUCKKET
+ HLRZS (D) ; MAKE SURE NEW POINTER IS IN RH
+ JUMPLE C,REH1 ; BUCKET EMPTY, QUIT
+
+REH2: MOVEI E,(C) ; MAKE A COPY OF THE POINTER
+ MOVE A,ITEM(C) ; START HASHING
+ TLZ A,TYPMSK#777777 ; KILL MONITORS
+ XOR A,ITEM+1(C)
+ MOVE 0,INDIC(C)
+ TLZ 0,TYPMSK#777777
+ XOR A,0
+ XOR A,INDIC+1(C)
+ TLZ A,400000 ; MAKE SURE FINAL HASH IS +
+ IDIV A,(P) ; DIVIDE BY TOTAL LENGTH
+ ADD B,-1(P) ; POINT TO WINNING BUCKET
+
+ MOVE C,[002200,,(B)] ; BYTE POINTER TO RH
+ CAILE B,(D) ; IF PAST CURRENT POINT
+ MOVE C,[222200,,(B)] ; USE LH
+ LDB A,C ; GET OLD VALUE
+ DPB E,C ; STORE NEW VALUE
+ HRRZ B,ASOLNT-1(E) ; GET NEXT POINTER
+ HRRZM A,ASOLNT-1(E) ; AND CLOBBER IN NEW NEXT
+ SKIPE A ; SKKIP IF NOTHING PREVIOUSLY IN BUCKET
+ HRLM E,ASOLNT-1(A) ; OTHERWISE CLOBBER
+ SKIPE C,B ; SKIP IF END OF CHAIN
+ JRST REH2
+REH1: AOBJN D,REH3
+
+ SUB P,C%22 ; FLUSH THE JUNK
+ POPJ P,
+\f
+;SUBROUTINES TO RETURN WORDS NEEDED BASED ON TYPE OR SAT
+
+NWORDT: PUSHJ P,SAT ;GET STORAGE ALLOC TYPE
+NWORDS: CAIG A,NUMSAT ; TEMPLATE?
+ SKIPL MKTBS(A) ;-ENTRY IN TABLE MEANS 2 NEEDED
+ SKIPA A,C%1 ;NEED ONLY 1
+ MOVEI A,2 ;NEED 2
+ POPJ P,
+
+.GLOBAL GCRET,PAIRMK,DEFMK,VECTMK,TBMK,TPMK,ARGMK,VECTMK,FRMK,BYTMK,ATOMK,GATOMK
+.GLOBAL LOCMK,BYTMK,ABMK,LOCRMK,GCRDMK,DEFQMK,ASMRK,OFFSMK
+
+; DISPATCH TABLE FOR MARK PHASE ("SETZ'D" ENTRIES MUST BE DEFERRED)
+
+DISTBS MKTBS,GCRET,[[S2WORD,PAIRMK],[S2DEFR,DEFMK],[SNWORD,VECTMK],[STBASE,TBMK]
+[STPSTK,TPMK],[SARGS,<SETZ ARGMK>],[S2NWORD,VECTMK],[SPSTK,TPMK],[SSTORE,VECTMK]
+[SFRAME,<SETZ FRMK>],[SBYTE,<SETZ BYTMK>],[SATOM,ATOMK],[SPVP,VECTMK],[SGATOM,GATOMK]
+[SLOCID,<SETZ LOCMK>],[SCHSTR,<SETZ BYTMK>],[SASOC,ASMRK],[SLOCL,PAIRMK],[SABASE,ABMK]
+[SLOCA,<SETZ ARGMK>],[SLOCV,VECTMK],[SLOCU,VECTMK],[SLOCS,<SETZ BYTMK>],[SLOCN,ASMRK]
+[SLOCR,LOCRMK],[SRDTB,GCRDMK],[SLOCB,<SETZ BYTMK>],[SDEFQ,DEFQMK],[SOFFS,OFFSMK]]
+
+IMPURE
+
+DSTORE: 0 ; USED FOR MAPFS AND SEGMENTS
+BUFL: 0 ; BUFFER PAGE (WORDS)
+BUFP: 0 ; BUFFER PAGE (PAGES)
+NPWRIT: 0 ; INDICATION OF PURIFY
+RNUMSP: 0 ; NUMBER OF MARK/SWEEP GARBAGE
+ ; COLLECTS TO REAL GARBAGE COLLECT
+NUMSWP: 0 ; NUMBER MARK SWEEP GARBAGE COLLECTS TO GO
+SWAPGC: 0 ; FLAG INDICATING WHETHER TO LOAD SWAP
+ ; GC OR NOT
+TOTCNT: 0 ; TOTAL COUNT
+
+PURE
+
+PAT:
+PATCH:
+
+BLOCK 400
+PATEND:
+
+END
+\f
\ No newline at end of file
--- /dev/null
+TITLE UTILITY FUNCTIONS FOR MUDDLE
+
+RELOCATABLE
+
+.INSRT MUDDLE >
+
+SYSQ
+
+IFE ITS,[
+.INSRT STENEX >
+XJRST==JRST 5,
+]
+
+.GLOBAL GODUMP,IPURIF,EGCDUM,EPURIF,LODGC,KILGC,CALER,RBLDM,CPOPJ,C1POPJ,INQAGC,FRETOP
+.GLOBAL SAT,PGFIND,PGGIVE,PGTAKE,PINIT,ERRKIL,CKPUR,GCSET,MKTBS,PFLG,NPWRIT,GETNUM
+.GLOBAL AGC,AAGC,%CLSM1,%SHWND,IBLOCK,FINAGC,PGINT,CPOPJ1,REHASH,FRMUNG,MAXLEN,TOTCNT
+.GLOBAL NWORDT,NWORDS,MSGTYP,IMTYO,MULTSG,MULTI,NOMULT,GCDEBU
+.GLOBAL PURCOR,INCORF,BADCHN,INTHLD,%MPIN1,WNDP,WIND,ACCESS,PURTOP,GCPDL,CTIME,P.CORE
+.GLOBAL IAGC,IAAGC,TYPVEC,PURBOT,PURTOP,MOVPUR,PURVEC,PMAPB,CURPLN,RFRETP,NOWFRE,FREMIN
+.GLOBAL MAXFRE,TPGROW,PDLBUF,CTPMX,PGROW,PDLBUF,CPMX,SAVM,NOWP,NOWTP,MPOPJ,GCFLG,GCDOWN
+.GLOBAL GCTIM,NOSHUF,P.TOP,GETPAG,ITEM,INDIC,ASOVEC,ASOLNT,GETBUF,KILBUF,PAT,PATEND
+.GLOBAL PATCH,DSTORE,PVSTOR,SPSTOR,SQKIL,IAMSGC,FNMSGC,RNUMSP,NUMSWP,SWAPGC,SAGC,GCSTOP
+.GLOBAL ISECGC
+.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
+
+FPAG==2000
+
+; GC-DUMP TAKES AN OBJECT AND MAPS IT INTO A FILE DIRECTLY USING THE GARBAGE
+; COLLECTOR. ALL OBJECTS HAVE RELATIVIZED POINTERS AND WILL BE SET UP UPON
+; READIN (USING GC-READ).
+; IT TAKES TWO ARGUMENTS. THE FIRST IS THE OBJECT THE SECOND MUST BE A "PRINTB"
+; CHANNEL.
+
+MFUNCTION GCDUMP,SUBR,[GC-DUMP]
+
+ ENTRY
+
+IFE ITS,[
+ PUSH P,MULTSG
+ SKIPE MULTSG ; MUST RUN I 0 SEXTION MODE
+ PUSHJ P,NOMULT
+]
+ MOVE PVP,PVSTOR+1
+ IRP AC,,[FRM,P,R,M,TP,TB,AB]
+ MOVEM AC,AC!STO"+1(PVP)
+ TERMIN
+
+ SETZM PURCOR
+ SETZM INCORF ; SET UP PARAMS
+ CAML AB,C%M20 ; CHECK ARGS
+ JRST TFA
+ CAMG AB,C%M60
+ JRST TMA
+ GETYP A,2(AB) ; SEE WHETHER THE CHANNEL IS A WINNER
+ CAIN A,TFALSE ; SKIP IF NOT FALSE
+ JRST UVEARG
+ CAIE A,TCHAN
+ JRST WTYP2 ; ITS NOT A CHANNEL. COMPLAIN
+ MOVE B,3(AB) ; CHECK BITS IN CHANNEL
+ HRRZ C,-2(B)
+ TRC C,C.PRIN+C.OPN+C.BIN
+ TRNE C,C.PRIN+C.OPN+C.BIN
+ JRST BADCHN
+ PUSH P,1(B) ; SAVE CHANNEL NUMBER
+ CAMGE AB,C%M40 ; SEE IF THIRD ARG WAS SNUCK IN
+ JRST TMA
+ JRST IGCDUM
+
+UVEARG: SETOM INCORF ; SET UP FLAG INDICATING UVECTOR
+ CAML AB,C%M40 ; SEE IF THIRD ARG
+ JRST IGCDUM
+ GETYP A,5(AB)
+ CAIE A,TFALSE
+ SETOM PURCOR
+IGCDUM: SETZM SWAPGC
+ PUSHJ P,LODGC ; GET THE GARBAGE COLLECTOR
+ SETOM INTHLD
+ JRST GODUMP
+
+EGCDUM: PUSH P,A ; SAVE LENGTH
+ PUSHJ P,KILGC ; KILL THE GARBAGE COLLECTOR
+ POP P,A
+ SETZM INTHLD
+ SKIPN INCORF ; SKIP IF TO UVECTOR
+ JRST OUTFIL
+ SKIPN PURCOR ; SKIP IF PURE UVECTOR
+ JRST BLTGCD
+
+; ROUTINE TO CREATE A UVECTOR IN PURE STORAGE CONTAINING GC-DUMPED
+; OBJECTS.
+
+ ADDI A,1777 ; ROUND
+ ANDCMI A,1777
+ ASH A,-10. ; TO BLOCKS
+ PUSH P,A ; SAVE IT
+TRAGN: PUSHJ P,PGFIND ; TRY TO GET PAGES
+ JUMPL B,GCDPLS ; LOSSAGE?
+ POP P,A ; GET # OF PAGES
+ PUSH P,B ; SAVE B\r
+ MOVNS A ; BUILD AOBJN POINTER
+ HRLZS A
+ ADDI A,FPAG/2000 ; START
+ HLL B,A ; SAME # OF PAGES
+ PUSHJ P,%MPIN1
+ POP P,B ; RESTORE # OF FIRST PAGE
+ ASH B,10. ; TO ADDRESS
+ POP P,A ; RESTORE LENGTH IN WORDS
+ MOVNI A,-2(A) ; BUILD AOBJN
+ HRL B,A
+ MOVE A,$TUVEC ; TYPE WORD
+ JRST DONDUM ; FINISH
+
+; HERE WHEN EFFORTS TO GE PURE STORAGE FAIL.
+
+GCDPLS: MOVE A,(P) ; GET # OF PAGES
+ ASH A,10. ; TO WORDS
+ ADDI A,1777
+ ANDCMI A,1777 ; ROUND AND TO PAGE
+ MOVEM A,GCDOWN
+ MOVE C,[13.,,9.] ; CAUSE INDICATOR
+ PUSHJ P,AGC ; CAUSE AGC TO HAPPEN
+ MOVE A,(P) ; GET # OF PAGES
+ JRST TRAGN ; TRY AGAIN
+
+; HERE TO TRANSFER FROM INFERIOR TO THE FILE
+OUTFIL: PUSH P,A ; SAVE LENGTH OF FILE
+ PUSHJ P,SETBUF
+ MOVE A,(P)
+ ANDCMI A,1777
+ ASH A,-10. ; TO PAGES
+ MOVNS A ; SET UP AOBJN POINTER
+ HRLZS A
+ ADDI A,1 ; STARTS ON PAGE ONE
+ MOVE C,-1(P) ; GET ITS CHANNEL #
+ MOVE B,BUFP ; WINDOW PAGE
+ JUMPGE A,DPGC5
+IFN ITS,[
+DPGC3: MOVE D,BUFL
+ HRLI D,-2000 ; SET UP BUFFER IOT POINTER
+ PUSHJ P,%SHWND ; SHARE INF PAGE AND WINDOW
+ DOTCAL IOT,[C,D]
+ FATAL GCDUMP-- IOT FAILED
+ AOBJN A,DPGC3
+]
+IFE ITS,[
+DPGC3: MOVE B,BUFP
+ PUSHJ P,%SHWND
+ PUSH P,A ; SAVE A
+ PUSH P,C ; SAVE C
+ MOVE A,C ; CHANNEL INTO A
+ MOVE B,BUFL ; SET UP BYTE POINTER
+ HRLI B,444400
+ MOVNI C,2000
+ SOUT ; OUT IT GOES
+ POP P,C
+ POP P,A ; RESTORE A
+ AOBJN A,DPGC3
+]
+
+DPGC5: MOVE D,(P) ; CALCULATE AMOUNT LEFT TO SEND OUT
+ MOVE 0,D
+ ANDCMI D,1777 ; TO PAGE BOUNDRY
+ SUB D,0 ; SET UP AOBJN PTR FOR OUTPUT
+IFN ITS,[
+ HRLZS D
+ ADD D,BUFL
+ MOVE B,BUFP ; SHARE WINDOW
+ PUSHJ P,%SHWND
+ DOTCAL IOT,[C,D]
+ FATAL GCDUMP-- IOT FAILED
+]
+IFE ITS,[
+ MOVE B,BUFP ; SET UP WINDOW
+ PUSHJ P,%SHWND
+ MOVE A,C ; CHANNEL TO A
+ MOVE C,D
+ MOVE B,BUFL ; SET UP BYTE POINTER
+ HRLI B,444400
+ SOUT
+] POP P,D
+ MOVE B,3(AB) ; GET CHANNEL
+ ADDM D,ACCESS(B)
+
+ PUSHJ P,KILBUF
+ MOVE A,(AB) ; RETURN WHAT IS GIVEN
+ MOVE B,1(AB)
+DONDUM: PUSH TP,A ; SAVE RETURNS
+ PUSH TP,B
+ PUSHJ P,%CLSM1
+ SUB P,C%11
+IFE ITS,[
+ POP P,MULTSG
+ SKIPE MULTSG
+ PUSHJ P,MULTI
+]
+ POP TP,B
+ POP TP,A
+ JRST FINIS
+
+
+; HERE TO BLT INTO A UVECTOR IN GCS
+
+BLTGCD: PUSH P,A ; SAVE # OF WORDS
+ PUSHJ P,SETBUF
+ MOVE A,(P)
+ PUSHJ P,IBLOCK ; GET THE UVECTOR
+ PUSH TP,A ; SAVE POINTER TO IT
+ PUSH TP,B
+ MOVE C,(P) ; GET # OF WORDS
+ ASH C,-10. ; TO PAGES
+ PUSH P,C ; SAVE C
+ MOVNS C
+ HRLZS C
+ ADDI C,FPAG/2000
+ MOVE B,BUFP ; WINDOW ACTS AS A BUFFER
+ HRRZ D,(TP) ; GET PTR TO START OF UVECTOR
+ JUMPGE C,DUNBLT ; IF < 1 BLOCK
+LOPBLT: MOVEI A,(C) ; GET A BLOCK
+ PUSHJ P,%SHWND
+ MOVS A,BUFL ; SET UP TO BLT INTO UVECTOR
+ HRRI A,(D)
+ BLT A,1777(D) ; IN COMES ONE BLOCK
+ ADDI D,2000 ; INCREMENT D
+ AOBJN C,LOPBLT ; LOOP
+DUNBLT: MOVEI A,(C) ; SHARE LAST PAGE
+ PUSHJ P,%SHWND
+ MOVS A,BUFL ; SET UP BLT
+ HRRI A,(D)
+ MOVE C,-1(P) ; GET TOTAL # OF WORDS
+ MOVE 0,(P)
+ ASH 0,10.
+ SUB C,0 ; CALCULATE # LEFT TO GO
+ ADDI D,-1(C) ; END OF UVECTOR
+ BLT A,(D)
+ SUB P,C%22 ; CLEAN OFF STACK
+ PUSHJ P,KILBUF
+ POP TP,B
+ POP TP,A
+ JRST DONDUM ; DONE
+
+SETBUF: MOVEI A,1
+ PUSHJ P,GETBUF
+ MOVEM B,BUFL
+ ASH B,-10.
+ MOVEM B,BUFP
+ POPJ P,
+
+\f
+; LITTLE ROUTINES USED ALL OVER THE PLACE
+
+MSGTYP: HRLI B,440700 ;MAKE BYTE POINTER
+MSGTY1: ILDB A,B ;GET NEXT CHARACTER
+ JUMPE A,CPOPJ ;NULL ENDS STRING
+ CAIE A,177 ; DONT PRINT RUBOUTS
+ PUSHJ P,IMTYO
+ JRST MSGTY1 ;AND GET NEXT CHARACTER
+CPOPJ: POPJ P,
+
+
+; ROUTINE TO PURIFY A STRUCTURE AND FREEZE ATOMS POINTED TO BY IT.
+; TAKES ONE ARGUMENT, THE ITEM TO PURIFY
+
+MFUNCTION PURIF,SUBR,[PURIFY]
+
+ ENTRY
+
+ JUMPGE AB,TFA ; CHECK # OF ARGS
+
+IFE ITS,[
+ PUSH P,MULTSG
+ SKIPE MULTSG ; MUST RUN I 0 SEXTION MODE
+ PUSHJ P,NOMULT
+]
+ MOVE C,AB
+ PUSH P,C%0 ; SLOT TO SEE IF WINNER
+PURMO1: HRRZ 0,1(C)
+ CAML 0,PURTOP
+ JRST PURMON ; CHECK FOR PURENESS
+ GETYP A,(C) ; SEE IF ITS MONAD
+ PUSHJ P,SAT
+ ANDI A,SATMSK
+ CAIE A,S1WORD
+ CAIN A,SLOCR
+ JRST PURMON
+ CAIN A,SATOM
+ JRST PURMON
+ SKIPE 1(C) ; SKIP IF EMPTY
+ SETOM (P)
+PURMON: ADD C,C%22 ; INC AND GO
+ JUMPL C,PURMO1
+ POP P,A ; GET MARKING
+ JUMPN A,PURCON
+NPF: MOVE A,(AB) ; FINISH IF MONAD
+ MOVE B,1(AB)
+IFE ITS,[
+ POP P,MULTSG
+ SKIPE MULTSG
+ PUSHJ P,MULTI
+]
+ JRST FINIS
+
+PURCON: SETZM SWAPGC
+ PUSHJ P,LODGC ; LOAD THE GARBAGE COLLECTOR
+ SETOM INTHLD
+ SETOM NPWRIT
+ JRST IPURIF
+
+EPURIF: PUSHJ P,KILGC
+ SETZM INTHLD
+ SETZM NPWRIT
+IFE ITS,[
+ SKIPN MULTSG
+ JRST NPF
+ POP P,B
+ HRRI B,NPF
+ MOVEI A,0
+ XJRST A
+]
+IFN ITS,[
+ JRST NPF
+]
+
+
+\f
+; ROUTINE TO DO A SPECIAL GARBAGE COLLECT, CALLED FOR FREE STORAGE GARBAGE
+; COLLECTS
+; AND CAN RUN A MARK/SWEEP GARBAGE COLLECT
+
+SAGC:
+IFE ITS,[
+ JRST @[.+1] ; RETURN WITH US NOW TO THE THRILLING
+ ; DAYS OF SEGMENT 0
+]
+ SOSL NUMSWP ; GET NUMBER OF SWEEP GARBAGE COLLECTS
+ JRST MSGC ; TRY MARK/SWEEP
+ MOVE RNUMSP ; MOVE IN RNUMSWP
+ MOVEM NUMSWP ; SMASH IT IN
+ JRST GOGC
+MSGC: SKIPN PGROW ; CHECK FOR STACK OVERFLOW
+ SKIPE TPGROW
+ JRST AGC ; IF SO CAUSE REAL GARBAGE COLLECT
+ PUSH P,C
+ PUSH P,D
+ PUSH P,E
+ SETOM SWAPGC ; LOAD MARK SWEEP VERSION
+ PUSHJ P,AGC1 ; CAUSE GARBAGE COLLECT
+ HRRZ 0,MAXLEN ; SEE IF REQUEST SATISFIED
+ CAMGE 0,GETNUM
+ JRST LOSE1
+ MOVE C,FREMIN ; GET FREMIN
+ SUB C,TOTCNT ; CALCULATE NEEDED
+ SUB C,FRETOP
+ ADD C,GCSTOP
+ JUMPL C,DONE1
+ JSP E,CKPUR ; GO CHECK FOR SOME STUFF
+ MOVE D,PURBOT
+IFE ITS, ANDCMI D,1777 ; MAKE LIKE AN ITS PAGE
+ SUB D,CURPLN ; CALCULATE PURENESS
+ SUB D,P.TOP
+ CAIG D,(C) ; SEE IF PURENESS EXISTS
+ JRST LOSE1
+ PUSH P,A
+ ADD C,GCSTOP
+ MOVEI A,1777(C)
+ ASH A,-10.
+ PUSHJ P,P.CORE
+ FATAL P.CORE FAILED
+ HRRZ 0,GCSTOP
+ SETZM @0
+ HRLS 0
+ ADDI 0,1
+ HRRZ A,FRETOP
+ BLT 0,-1(A)
+ PUSHJ P,RBLDM
+ POP P,A
+DONE1: POP P,E
+ POP P,D
+ POP P,C
+IFN ITS, POPJ P,
+IFE ITS,[
+ SKIPN MULTSG
+ POPJ P,
+ SETZM 20
+ POP P,21 ; BACK TO CALLING SEGMENT
+ XJRST 20
+]
+LOSE1: POP P,E
+ POP P,D
+ POP P,C
+GOGC:
+
+
+AGC:
+IFE ITS,[
+ SKIPE MULTSG
+ SKIPE GCDEBU
+ JRST @[SEC1]
+ XJRST .+1
+ 0
+ FSEG,,SEC1
+SEC1:
+]
+ MOVE 0,RNUMSP
+ MOVEM 0,NUMSWP
+ SETZM SWAPGC
+AGC1: SKIPE NPWRIT
+ JRST IAGC
+ EXCH P,GCPDL
+ PUSHJ P,SVAC ; SAVE ACS
+ PUSHJ P,SQKIL
+ PUSHJ P,CTIME
+ MOVEM B,GCTIM
+ PUSHJ P,LODGC ; LOAD GC
+ PUSHJ P,RSAC ; RESTORE ACS
+ EXCH P,GCPDL
+ SKIPE SWAPGC
+ JRST IAMSGC
+ SKIPN MULTSG
+ JRST IAGC
+ JRST ISECGC
+
+AAGC: SETZM SWAPGC
+ EXCH P,GCPDL
+ PUSHJ P,SVAC ; SAVE ACS
+ PUSHJ P,LODGC ; LOAD GC
+ PUSHJ P,RSAC ; RESTORE ACS
+ EXCH P,GCPDL
+ JRST IAAGC
+
+FNMSGC:
+FINAGC: SKIPE NPWRIT
+ JRST FINAGG
+ PUSHJ P,SVAC ; SAVE ACS
+ PUSHJ P,KILGC
+ PUSHJ P,RSAC
+FINAGG:
+IFN ITS, POPJ P,
+IFE ITS,[
+ SKIPN MULTSG
+ POPJ P,
+ SETZM 20
+ POP P,21 ; BACK TO CALLING SEGMENT
+ XJRST 20
+]
+
+; ROUTINE TO SAVE THE ACS
+
+SVAC: EXCH 0,(P)
+ PUSH P,A
+ PUSH P,B
+ PUSH P,C
+ PUSH P,D
+ PUSH P,E
+ JRST @0
+
+; ROUTINE TO RESTORE THE ACS
+
+RSAC: POP P,0
+ POP P,E
+ POP P,D
+ POP P,C
+ POP P,B
+ POP P,A
+ EXCH 0,(P)
+ POPJ P,
+
+
+\f
+
+; INTERNAL FUNCTION TO GET STRAGE ALLOCATION TYPE
+; GETS THE TYPE CODE IN A AND RETURNS SAT IN A.
+
+SAT: LSH A,1 ; TIMES 2 TO REF VECTOR
+ HRLS A ; TO BOTH HALVES TO HACK AOBJN
+ ; POINTER
+ ADD A,TYPVEC+1 ; ACCESS THE VECTOR
+ HRR A,(A) ; GET PROBABLE SAT
+ JUMPL A,.+2 ; DID WE REALLY HAVE A VALID
+ ; TYPE
+ MOVEI A,0 ; NO RETURN 0
+ ANDI A,SATMSK
+ POPJ P, ; AND RETURN
+
+; FIND AND ALLOCATE AS MANY CONTIGUOUS PAGES AS INDICATED BY REG A
+; RETURN THE NUMBER (0-255.) OF THE FIRST SUCH PAGE IN REG B
+; RETURN -1 IN REG B IF NONE FOUND
+
+PGFIND:
+ JUMPLE A,FPLOSS
+ CAILE A,256.
+ JRST FPLOSS
+
+ PUSHJ P,PGFND1 ; SEE IF ALREADY ENOUGH
+ SKIPN NOSHUF ; CAN'T MOVE PURNESS
+ SKIPL B ; SKIP IF LOST
+ POPJ P,
+
+ SUBM M,(P)
+ PUSH P,E
+ PUSH P,C
+ PUSH P,D
+PGFLO4: MOVE C,PURBOT ; CHECK IF ROOM AT ALL
+ ; (NOTE POTENTIAL FOR INFINITE LOOP)
+ SUB C,P.TOP ; TOTAL SPACE
+ MOVEI D,(C) ; COPY FOR CONVERSION TO PAGES
+ ASH D,-10.
+ CAIGE D,(A) ; SKIP IF COULD WIN
+ JRST PGFLO1
+
+ MOVNS A ; MOVE PURE AREA DOWN "A" PAGES
+ PUSHJ P,MOVPUR
+ MOVE B,PURTOP ; GET FIRST PAGE ALLOCATED
+ ASH B,-10. ; TO PAGE #
+PGFLOS: POP P,D
+ POP P,C
+ POP P,E
+ PUSHJ P,RBLDM ; GET A NEW VALUE FOR M
+ JRST MPOPJ
+
+; HERE TO SHUFFLE PURE SPACE TO TRY TO FIND PAGES
+
+PGFLO1: SKIPE GCFLG ; SKIP IF NOT IN GC
+ JRST PGFLO5 ; WE LOST
+ MOVE C,PURTOP
+ SUB C,P.TOP
+ HRRZ D,FSAV(TB) ; ARE WE IN A PURE RSUBR?
+ CAIL D,HIBOT ; ARE WE AN RSUBR AT ALL?
+ JRST PGFLO2
+ GETYP E,(R) ; SEE IF PCODE
+ CAIE E,TPCODE
+ JRST PGFLO2
+ HLRZ D,1(R) ; GET OFFSET TO PURVEC
+ ADD D,PURVEC+1
+ HRROS 2(D) ; MUNG AGE
+ HLRE D,1(D) ; GET LENGTH
+ ADD C,D
+PGFLO2: ASH C,-10.
+ CAILE A,(C)
+ JRST PGFLO3
+ PUSH P,A
+IFE ITS, ASH A,1 ; TENEX PAGES ARE HALF SIZE
+ PUSHJ P,GETPAG ; SHUFFLE THEM AROUND
+ FATAL PURE SPACE LOSING
+ POP P,A
+ JRST PGFLO4
+
+; HERE TO CAUSE AGC IF PAGES ARE NOT AVAILABLE EVEN AFTER MAPPING OUT THE WORLD
+
+
+PGFLO3: PUSH P,A ; ASK GC FOR SPACE
+ ASH A,10.
+ MOVEM A,GCDOWN ; REQUEST THOSE PAGES
+ MOVE C,[8.,,9.]
+ PUSHJ P,AGC ; GO GARBAGE COLLECT
+ POP P,A
+ JRST PGFLO4 ; GO BACK TO POTENTIAL LOOP
+
+
+PGFLO5: SETOM B ; -1 TO B
+ JRST PGFLOS ; INDICATE LOSSAGE
+
+PGFND1: PUSH P,E
+ PUSH P,D
+ PUSH P,C
+ PUSH P,C%M1 ; POSSIBLE CONTENTS FOR REG B
+ PUSH P,A ; SAVE LENGTH OF BLOCK DESIRED FOR LATER USE
+ SETZB B,C ; INITIAL SECTION AND PAGE NUMBERS
+ MOVEI 0,0 ; COUNT OF PAGES ALREADY FOUND
+ PUSHJ P,PINIT
+PLOOP: TDNE E,D ; FREE PAGE ?
+ JRST NOTFRE ; NO
+ JUMPN 0,NFIRST ; FIRST FREE PAGE OF A BLOCK ?
+ MOVEI A,(B) ; YES SAVE ADDRESS OF PAGE IN REG A
+ IMULI A,16.
+ ASH C,-1 ; BACK TO PAGES
+ ADDI A,(C)
+ ASH C,1 ; FIX IT TO WHAT IT WAS
+NFIRST: ADDI 0,1
+ CAML 0,(P) ; TEST IF ENOUGH PAGES HAVE BEEN FOUND
+ JRST PWIN ; YES, FINISHED
+ SKIPA
+NOTFRE: MOVEI 0,0 ; RESET COUNT
+ PUSHJ P,PNEXT ; NEXT PAGE
+ JRST PLOSE ; NONE--LOSE RETURNING -1 IN REG B
+ JRST PLOOP
+
+PWIN: MOVEI B,(A) ; GET WINNING ADDRESS
+ MOVEM B,(P)-1 ; RETURN ADDRESS OF WINNING PAGE
+ MOVE A,(P) ; RELOAD LENGTH OF BLOCK OF PAGES
+ MOVE 0,[TDO E,D] ; INST TO SET "BUSY" BITS
+ JRST ITAKE
+
+; CLAIM OR RETURN TO FREE STORAGE AS MANY CONTIGUOUS PAGES AS INDICATED BY REG A
+; THE NUMBER (0 - 255.) OF THE FIRST SUCH PAGE IS IN REG B
+PGGIVE: MOVE 0,[TDZ E,D] ; INST TO SET "FREE" BITS
+ SKIPA
+PGTAKE: MOVE 0,[TDO E,D] ; INST TO SET "BUSY" BITS
+ JUMPLE A,FPLOSS
+ CAIL B,0
+ CAILE B,255.
+ JRST FPLOSS
+ PUSH P,E
+ PUSH P,D
+ PUSH P,C
+ PUSH P,B
+ PUSH P,A
+ITAKE: IDIVI B,16.
+ PUSHJ P,PINIT
+ SUBI A,1
+RTL: XCT 0 ; SET APPROPRIATE BIT
+ PUSHJ P,PNEXT ; NEXT PAGE'S BIT
+ JUMPG A,FPLOSS ; TOO MANY ?
+ SOJGE A,RTL
+ MOVEM E,PMAPB(B) ; REPLACE BIT MASK
+PLOSE: POP P,A
+ POP P,B
+ POP P,C
+ POP P,D
+ POP P,E
+ POPJ P,
+
+
+PINIT: MOVE E,PMAPB(B) ; GET BITS FOR THIS SECTION
+ HRLZI D,400000 ; BIT MASK
+ IMULI C,2
+ MOVNS C
+ LSH D,(C) ; SHIFT TO APPROPRIATE BIT POSITION
+ MOVNS C
+ POPJ P,
+
+PNEXT: AOS (P) ; FOR SKIP RETURN ON EXPECTED SUCCESS
+ LSH D,-2 ; CONSIDER NEXT PAGE
+ CAIL C,30. ; FINISHED WITH THIS SECTION ?
+ JRST PNEXT1
+ AOS C
+ AOJA C,CPOPJ ; NO, INCREMENT AND CONTINUE
+PNEXT1: MOVEM E,PMAPB(B) ; REPLACE BIT MASK
+ SETZ C,
+ CAIGE B,15. ; LAST SECTION ?
+ AOJA B,PINIT ; NO, INCREMENT AND CONTINUE
+ SOS (P) ; YES, UNDO SKIP RETURN
+ POPJ P,
+
+FPLOSS: FATAL PAGE LOSSAGE
+
+PGINT: MOVEI B,HIBOT ; INITIALIZE MUDDLE'S PAGE MAP TABLE
+ IDIVI B,2000 ; FIRST PAGE OF PURE CODE
+ MOVE C,HITOP
+ IDIVI C,2000
+ MOVEI A,(C)+1
+ SUBI A,(B) ; NUMBER OF SUCH PAGES
+ PUSHJ P,PGTAKE ; MARK THESE PAGES AS TAKEN
+ POPJ P,
+
+
+
+\f
+ERRKIL: PUSH P,A
+ PUSHJ P,KILGC ; KILL THE GARBAGE COLLECTOR
+ POP P,A
+ JRST CALER
+
+; IF IN A PURE RSUBR, FIND ITS LENGTH AND FUDGE ITS LRU
+
+CKPUR: HRRZ A,FSAV(TB) ; GET NAME OF CURRENT GOODIE
+ SETZM CURPLN ; CLEAR FOR NONE
+ CAIL A,HIBOT ; IF LESS THAN TOP OF PURE ASSUME RSUBR
+ JRST (E)
+ GETYP 0,(A) ; SEE IF PURE
+ CAIE 0,TPCODE ; SKIP IF IT IS
+ JRST NPRSUB
+NRSB2: HLRZ B,1(A) ; GET SLOT INDICATION
+ ADD B,PURVEC+1 ; POINT TO SLOT
+ HRROS 2(B) ; MUNG AGE
+ HLRE A,1(B) ; - LENGTH TO A
+ TRZ A,777
+ MOVNM A,CURPLN ; AND STORE
+ JRST (E)
+NPRSUB: SKIPGE B,1(R) ; SEE IF PURE RSUBR
+ JRST (E)
+ MOVE A,R
+ JRST NRSB2
+
+; THIS IS THE SCHEME USED TO UPDATE CERTAIN IMFORMATION USED BY THE
+; BLOAT-SPEC ROUTINE TO GIVE USERS IMFORMATION ABOUT USE OF SPACE BY
+; THEIR MUDDLE.
+
+GCSET: MOVE A,RFRETP ; COMPUTE FREE SPACE AVAILABLE
+ SUB A,PARTOP
+ MOVEM A,NOWFRE
+ CAMLE A,MAXFRE
+ MOVEM A,MAXFRE ; MODIFY MAXIMUM
+ HLRE A,TP ; FIND THE DOPE WORD OF THE TP STACK
+ MOVNS A
+ ADDI A,1(TP) ; CLOSE TO DOPE WORD
+ CAME A,TPGROW
+ ADDI A,PDLBUF ; NOW AT REAL DOPE WORD
+ HLRZ B,(A) ; GET LENGTH OF TP-STACK
+ MOVEM B,NOWTP
+ CAMLE B,CTPMX ; SEE IF THIS IS THE BIGGEST TP
+ MOVEM B,CTPMX
+ HLRE B,P ; FIND DOPE WORD OF P-STACK
+ MOVNS B
+ ADDI B,1(P) ; CLOSE TO IT
+ CAME B,PGROW ; SEE IF THE STACK IS BLOWN
+ ADDI B,PDLBUF ; POINTING TO IT
+ HLRZ A,(B) ; GET IN LENGTH
+ MOVEM A,NOWP
+ CAMLE A,CPMX ; SEE IF WE HAVE THE BIGGEST P STACK
+ MOVEM A,CPMX
+ POPJ P, ; EXIT
+
+RBLDM: JUMPGE R,CPOPJ
+ SKIPGE M,1(R) ; SKIP IF FUNNY
+ JRST RBLDM1
+
+ HLRS M
+ ADD M,PURVEC+1
+ HLLM TB,2(M)
+ SKIPL M,1(M)
+ JRST RBLDM1
+ PUSH P,0
+ HRRZ 0,1(R)
+ ADD M,0
+ POP P,0
+RBLDM1: SKIPN SAVM ; SKIP IF FUNNY (M)
+ POPJ P, ; EXIT
+ MOVEM M,SAVM
+ MOVEI M,0
+ POPJ P,
+CPOPJ1:
+C1POPJ: AOS (P)
+ POPJ P,
+
+
+\f
+; THIS ROUTINE MAKES SURE CURRENT FRAME MAKES SENSE
+FRMUNG: MOVEM D,PSAV(A)
+ MOVE SP,SPSTOR+1
+ MOVEM SP,SPSAV(A)
+ MOVEM TP,TPSAV(A) ; SAVE FOR MARKING
+ POPJ P,
+
+
+; SUBROUTINE TO REBUILD THE NOW DEFUNCT HASH TABLE
+
+REHASH: MOVE D,ASOVEC+1 ; GET POINTER TO VECTOR
+ MOVEI E,(D)
+ PUSH P,E ; PUSH A POINTER
+ HLRE A,D ; GET -LENGTH
+ MOVMS A ; AND PLUSIFY
+ PUSH P,A ; PUSH IT ALSO
+
+REH3: HRRZ C,(D) ; POINT TO FIRST BUCKKET
+ HLRZS (D) ; MAKE SURE NEW POINTER IS IN RH
+ JUMPLE C,REH1 ; BUCKET EMPTY, QUIT
+
+REH2: MOVEI E,(C) ; MAKE A COPY OF THE POINTER
+ MOVE A,ITEM(C) ; START HASHING
+ TLZ A,TYPMSK#777777 ; KILL MONITORS
+ XOR A,ITEM+1(C)
+ MOVE 0,INDIC(C)
+ TLZ 0,TYPMSK#777777
+ XOR A,0
+ XOR A,INDIC+1(C)
+ TLZ A,400000 ; MAKE SURE FINAL HASH IS +
+ IDIV A,(P) ; DIVIDE BY TOTAL LENGTH
+ ADD B,-1(P) ; POINT TO WINNING BUCKET
+
+ MOVE C,[002200,,(B)] ; BYTE POINTER TO RH
+ CAILE B,(D) ; IF PAST CURRENT POINT
+ MOVE C,[222200,,(B)] ; USE LH
+ LDB A,C ; GET OLD VALUE
+ DPB E,C ; STORE NEW VALUE
+ HRRZ B,ASOLNT-1(E) ; GET NEXT POINTER
+ HRRZM A,ASOLNT-1(E) ; AND CLOBBER IN NEW NEXT
+ SKIPE A ; SKKIP IF NOTHING PREVIOUSLY IN BUCKET
+ HRLM E,ASOLNT-1(A) ; OTHERWISE CLOBBER
+ SKIPE C,B ; SKIP IF END OF CHAIN
+ JRST REH2
+REH1: AOBJN D,REH3
+
+ SUB P,C%22 ; FLUSH THE JUNK
+ POPJ P,
+\f
+;SUBROUTINES TO RETURN WORDS NEEDED BASED ON TYPE OR SAT
+
+NWORDT: PUSHJ P,SAT ;GET STORAGE ALLOC TYPE
+NWORDS: CAIG A,NUMSAT ; TEMPLATE?
+ SKIPL MKTBS(A) ;-ENTRY IN TABLE MEANS 2 NEEDED
+ SKIPA A,C%1 ;NEED ONLY 1
+ MOVEI A,2 ;NEED 2
+ POPJ P,
+
+.GLOBAL GCRET,PAIRMK,DEFMK,VECTMK,TBMK,TPMK,ARGMK,VECTMK,FRMK,BYTMK,ATOMK,GATOMK
+.GLOBAL LOCMK,BYTMK,ABMK,LOCRMK,GCRDMK,DEFQMK,ASMRK,OFFSMK
+
+; DISPATCH TABLE FOR MARK PHASE ("SETZ'D" ENTRIES MUST BE DEFERRED)
+
+DISTBS MKTBS,GCRET,[[S2WORD,PAIRMK],[S2DEFR,DEFMK],[SNWORD,VECTMK],[STBASE,TBMK]
+[STPSTK,TPMK],[SARGS,<SETZ ARGMK>],[S2NWORD,VECTMK],[SPSTK,TPMK],[SSTORE,VECTMK]
+[SFRAME,<SETZ FRMK>],[SBYTE,<SETZ BYTMK>],[SATOM,ATOMK],[SPVP,VECTMK],[SGATOM,GATOMK]
+[SLOCID,<SETZ LOCMK>],[SCHSTR,<SETZ BYTMK>],[SASOC,ASMRK],[SLOCL,PAIRMK],[SABASE,ABMK]
+[SLOCA,<SETZ ARGMK>],[SLOCV,VECTMK],[SLOCU,VECTMK],[SLOCS,<SETZ BYTMK>],[SLOCN,ASMRK]
+[SLOCR,LOCRMK],[SRDTB,GCRDMK],[SLOCB,<SETZ BYTMK>],[SDEFQ,DEFQMK],[SOFFS,OFFSMK]]
+
+IMPURE
+
+DSTORE: 0 ; USED FOR MAPFS AND SEGMENTS
+BUFL: 0 ; BUFFER PAGE (WORDS)
+BUFP: 0 ; BUFFER PAGE (PAGES)
+NPWRIT: 0 ; INDICATION OF PURIFY
+RNUMSP: 0 ; NUMBER OF MARK/SWEEP GARBAGE
+ ; COLLECTS TO REAL GARBAGE COLLECT
+NUMSWP: 0 ; NUMBER MARK SWEEP GARBAGE COLLECTS TO GO
+SWAPGC: 0 ; FLAG INDICATING WHETHER TO LOAD SWAP
+ ; GC OR NOT
+TOTCNT: 0 ; TOTAL COUNT
+
+PURE
+
+PAT:
+PATCH:
+
+BLOCK 400
+PATEND:
+
+END
+\f
\ No newline at end of file
--- /dev/null
+TITLE UTILITY FUNCTIONS FOR MUDDLE
+
+RELOCATABLE
+
+.INSRT MUDDLE >
+
+SYSQ
+
+IFE ITS,[
+.INSRT STENEX >
+XJRST==JRST 5,
+]
+
+.GLOBAL GODUMP,IPURIF,EGCDUM,EPURIF,LODGC,KILGC,CALER,RBLDM,CPOPJ,C1POPJ,INQAGC,FRETOP
+.GLOBAL SAT,PGFIND,PGGIVE,PGTAKE,PINIT,ERRKIL,CKPUR,GCSET,MKTBS,PFLG,NPWRIT,GETNUM
+.GLOBAL AGC,AAGC,%CLSM1,%SHWND,IBLOCK,FINAGC,PGINT,CPOPJ1,REHASH,FRMUNG,MAXLEN,TOTCNT
+.GLOBAL NWORDT,NWORDS,MSGTYP,IMTYO,MULTSG,MULTI,NOMULT,GCDEBU
+.GLOBAL PURCOR,INCORF,BADCHN,INTHLD,%MPIN1,WNDP,WIND,ACCESS,PURTOP,GCPDL,CTIME,P.CORE
+.GLOBAL IAGC,IAAGC,TYPVEC,PURBOT,PURTOP,MOVPUR,PURVEC,PMAPB,CURPLN,RFRETP,NOWFRE,FREMIN
+.GLOBAL MAXFRE,TPGROW,PDLBUF,CTPMX,PGROW,PDLBUF,CPMX,SAVM,NOWP,NOWTP,MPOPJ,GCFLG,GCDOWN
+.GLOBAL GCTIM,NOSHUF,P.TOP,GETPAG,ITEM,INDIC,ASOVEC,ASOLNT,GETBUF,KILBUF,PAT,PATEND
+.GLOBAL PATCH,DSTORE,PVSTOR,SPSTOR,SQKIL,IAMSGC,FNMSGC,RNUMSP,NUMSWP,SWAPGC,SAGC,GCSTOP
+.GLOBAL ISECGC
+.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
+
+FPAG==2000
+
+; GC-DUMP TAKES AN OBJECT AND MAPS IT INTO A FILE DIRECTLY USING THE GARBAGE
+; COLLECTOR. ALL OBJECTS HAVE RELATIVIZED POINTERS AND WILL BE SET UP UPON
+; READIN (USING GC-READ).
+; IT TAKES TWO ARGUMENTS. THE FIRST IS THE OBJECT THE SECOND MUST BE A "PRINTB"
+; CHANNEL.
+
+MFUNCTION GCDUMP,SUBR,[GC-DUMP]
+
+ ENTRY
+
+IFE ITS,[
+ PUSH P,MULTSG
+ SKIPE MULTSG ; MUST RUN I 0 SEXTION MODE
+ PUSHJ P,NOMULT
+]
+ MOVE PVP,PVSTOR+1
+ IRP AC,,[FRM,P,R,M,TP,TB,AB]
+ MOVEM AC,AC!STO"+1(PVP)
+ TERMIN
+
+ SETZM PURCOR
+ SETZM INCORF ; SET UP PARAMS
+ CAML AB,C%M20 ; CHECK ARGS
+ JRST TFA
+ CAMG AB,C%M60
+ JRST TMA
+ GETYP A,2(AB) ; SEE WHETHER THE CHANNEL IS A WINNER
+ CAIN A,TFALSE ; SKIP IF NOT FALSE
+ JRST UVEARG
+ CAIE A,TCHAN
+ JRST WTYP2 ; ITS NOT A CHANNEL. COMPLAIN
+ MOVE B,3(AB) ; CHECK BITS IN CHANNEL
+ HRRZ C,-2(B)
+ TRC C,C.PRIN+C.OPN+C.BIN
+ TRNE C,C.PRIN+C.OPN+C.BIN
+ JRST BADCHN
+ PUSH P,1(B) ; SAVE CHANNEL NUMBER
+ CAMGE AB,C%M40 ; SEE IF THIRD ARG WAS SNUCK IN
+ JRST TMA
+ JRST IGCDUM
+
+UVEARG: SETOM INCORF ; SET UP FLAG INDICATING UVECTOR
+ CAML AB,C%M40 ; SEE IF THIRD ARG
+ JRST IGCDUM
+ GETYP A,5(AB)
+ CAIE A,TFALSE
+ SETOM PURCOR
+IGCDUM: SETZM SWAPGC
+ PUSHJ P,LODGC ; GET THE GARBAGE COLLECTOR
+ SETOM INTHLD
+ JRST GODUMP
+
+EGCDUM: PUSH P,A ; SAVE LENGTH
+ PUSHJ P,KILGC ; KILL THE GARBAGE COLLECTOR
+ POP P,A
+ SETZM INTHLD
+ SKIPN INCORF ; SKIP IF TO UVECTOR
+ JRST OUTFIL
+ SKIPN PURCOR ; SKIP IF PURE UVECTOR
+ JRST BLTGCD
+
+; ROUTINE TO CREATE A UVECTOR IN PURE STORAGE CONTAINING GC-DUMPED
+; OBJECTS.
+
+ ADDI A,1777 ; ROUND
+ ANDCMI A,1777
+ ASH A,-10. ; TO BLOCKS
+ PUSH P,A ; SAVE IT
+TRAGN: PUSHJ P,PGFIND ; TRY TO GET PAGES
+ JUMPL B,GCDPLS ; LOSSAGE?
+ POP P,A ; GET # OF PAGES
+ PUSH P,B ; SAVE B\r
+ MOVNS A ; BUILD AOBJN POINTER
+ HRLZS A
+ ADDI A,FPAG/2000 ; START
+ HLL B,A ; SAME # OF PAGES
+ PUSHJ P,%MPIN1
+ POP P,B ; RESTORE # OF FIRST PAGE
+ ASH B,10. ; TO ADDRESS
+ POP P,A ; RESTORE LENGTH IN WORDS
+ MOVNI A,-2(A) ; BUILD AOBJN
+ HRL B,A
+ MOVE A,$TUVEC ; TYPE WORD
+ JRST DONDUM ; FINISH
+
+; HERE WHEN EFFORTS TO GE PURE STORAGE FAIL.
+
+GCDPLS: MOVE A,(P) ; GET # OF PAGES
+ ASH A,10. ; TO WORDS
+ ADDI A,1777
+ ANDCMI A,1777 ; ROUND AND TO PAGE
+ MOVEM A,GCDOWN
+ MOVE C,[13.,,9.] ; CAUSE INDICATOR
+ PUSHJ P,AGC ; CAUSE AGC TO HAPPEN
+ MOVE A,(P) ; GET # OF PAGES
+ JRST TRAGN ; TRY AGAIN
+
+; HERE TO TRANSFER FROM INFERIOR TO THE FILE
+OUTFIL: PUSH P,A ; SAVE LENGTH OF FILE
+ PUSHJ P,SETBUF
+ MOVE A,(P)
+ ANDCMI A,1777
+ ASH A,-10. ; TO PAGES
+ MOVNS A ; SET UP AOBJN POINTER
+ HRLZS A
+ ADDI A,1 ; STARTS ON PAGE ONE
+ MOVE C,-1(P) ; GET ITS CHANNEL #
+ MOVE B,BUFP ; WINDOW PAGE
+ JUMPGE A,DPGC5
+IFN ITS,[
+DPGC3: MOVE D,BUFL
+ HRLI D,-2000 ; SET UP BUFFER IOT POINTER
+ PUSHJ P,%SHWND ; SHARE INF PAGE AND WINDOW
+ DOTCAL IOT,[C,D]
+ FATAL GCDUMP-- IOT FAILED
+ AOBJN A,DPGC3
+]
+IFE ITS,[
+DPGC3: MOVE B,BUFP
+ PUSHJ P,%SHWND
+ PUSH P,A ; SAVE A
+ PUSH P,C ; SAVE C
+ MOVE A,C ; CHANNEL INTO A
+ MOVE B,BUFL ; SET UP BYTE POINTER
+ HRLI B,444400
+ MOVNI C,2000
+ SOUT ; OUT IT GOES
+ POP P,C
+ POP P,A ; RESTORE A
+ AOBJN A,DPGC3
+]
+
+DPGC5: MOVE D,(P) ; CALCULATE AMOUNT LEFT TO SEND OUT
+ MOVE 0,D
+ ANDCMI D,1777 ; TO PAGE BOUNDRY
+ SUB D,0 ; SET UP AOBJN PTR FOR OUTPUT
+IFN ITS,[
+ HRLZS D
+ ADD D,BUFL
+ MOVE B,BUFP ; SHARE WINDOW
+ PUSHJ P,%SHWND
+ DOTCAL IOT,[C,D]
+ FATAL GCDUMP-- IOT FAILED
+]
+IFE ITS,[
+ MOVE B,BUFP ; SET UP WINDOW
+ PUSHJ P,%SHWND
+ MOVE A,C ; CHANNEL TO A
+ MOVE C,D
+ MOVE B,BUFL ; SET UP BYTE POINTER
+ HRLI B,444400
+ SOUT
+] POP P,D
+ MOVE B,3(AB) ; GET CHANNEL
+ ADDM D,ACCESS(B)
+
+ PUSHJ P,KILBUF
+ MOVE A,(AB) ; RETURN WHAT IS GIVEN
+ MOVE B,1(AB)
+DONDUM: PUSH TP,A ; SAVE RETURNS
+ PUSH TP,B
+ PUSHJ P,%CLSM1
+ SUB P,C%11
+IFE ITS,[
+ POP P,MULTSG
+ SKIPE MULTSG
+ PUSHJ P,MULTI
+]
+ POP TP,B
+ POP TP,A
+ JRST FINIS
+
+
+; HERE TO BLT INTO A UVECTOR IN GCS
+
+BLTGCD: PUSH P,A ; SAVE # OF WORDS
+ PUSHJ P,SETBUF
+ MOVE A,(P)
+ PUSHJ P,IBLOCK ; GET THE UVECTOR
+ PUSH TP,A ; SAVE POINTER TO IT
+ PUSH TP,B
+ MOVE C,(P) ; GET # OF WORDS
+ ASH C,-10. ; TO PAGES
+ PUSH P,C ; SAVE C
+ MOVNS C
+ HRLZS C
+ ADDI C,FPAG/2000
+ MOVE B,BUFP ; WINDOW ACTS AS A BUFFER
+ HRRZ D,(TP) ; GET PTR TO START OF UVECTOR
+ JUMPGE C,DUNBLT ; IF < 1 BLOCK
+LOPBLT: MOVEI A,(C) ; GET A BLOCK
+ PUSHJ P,%SHWND
+ MOVS A,BUFL ; SET UP TO BLT INTO UVECTOR
+ HRRI A,(D)
+ BLT A,1777(D) ; IN COMES ONE BLOCK
+ ADDI D,2000 ; INCREMENT D
+ AOBJN C,LOPBLT ; LOOP
+DUNBLT: MOVEI A,(C) ; SHARE LAST PAGE
+ PUSHJ P,%SHWND
+ MOVS A,BUFL ; SET UP BLT
+ HRRI A,(D)
+ MOVE C,-1(P) ; GET TOTAL # OF WORDS
+ MOVE 0,(P)
+ ASH 0,10.
+ SUB C,0 ; CALCULATE # LEFT TO GO
+ ADDI D,-1(C) ; END OF UVECTOR
+ BLT A,(D)
+ SUB P,C%22 ; CLEAN OFF STACK
+ PUSHJ P,KILBUF
+ POP TP,B
+ POP TP,A
+ JRST DONDUM ; DONE
+
+SETBUF: MOVEI A,1
+ PUSHJ P,GETBUF
+ MOVEM B,BUFL
+ ASH B,-10.
+ MOVEM B,BUFP
+ POPJ P,
+
+\f
+; LITTLE ROUTINES USED ALL OVER THE PLACE
+
+MSGTYP: HRLI B,440700 ;MAKE BYTE POINTER
+MSGTY1: ILDB A,B ;GET NEXT CHARACTER
+ JUMPE A,CPOPJ ;NULL ENDS STRING
+ CAIE A,177 ; DONT PRINT RUBOUTS
+ PUSHJ P,IMTYO
+ JRST MSGTY1 ;AND GET NEXT CHARACTER
+CPOPJ: POPJ P,
+
+
+; ROUTINE TO PURIFY A STRUCTURE AND FREEZE ATOMS POINTED TO BY IT.
+; TAKES ONE ARGUMENT, THE ITEM TO PURIFY
+
+MFUNCTION PURIF,SUBR,[PURIFY]
+
+ ENTRY
+
+ JUMPGE AB,TFA ; CHECK # OF ARGS
+
+IFE ITS,[
+ PUSH P,MULTSG
+ SKIPE MULTSG ; MUST RUN I 0 SEXTION MODE
+ PUSHJ P,NOMULT
+]
+ MOVE C,AB
+ PUSH P,C%0 ; SLOT TO SEE IF WINNER
+PURMO1: HRRZ 0,1(C)
+ CAML 0,PURTOP
+ JRST PURMON ; CHECK FOR PURENESS
+ GETYP A,(C) ; SEE IF ITS MONAD
+ PUSHJ P,SAT
+ ANDI A,SATMSK
+ CAIE A,S1WORD
+ CAIN A,SLOCR
+ JRST PURMON
+ CAIN A,SATOM
+ JRST PURMON
+ SKIPE 1(C) ; SKIP IF EMPTY
+ SETOM (P)
+PURMON: ADD C,C%22 ; INC AND GO
+ JUMPL C,PURMO1
+ POP P,A ; GET MARKING
+ JUMPN A,PURCON
+NPF: MOVE A,(AB) ; FINISH IF MONAD
+ MOVE B,1(AB)
+IFE ITS,[
+ POP P,MULTSG
+ SKIPE MULTSG
+ PUSHJ P,MULTI
+]
+ JRST FINIS
+
+PURCON: SETZM SWAPGC
+ PUSHJ P,LODGC ; LOAD THE GARBAGE COLLECTOR
+ SETOM INTHLD
+ SETOM NPWRIT
+ JRST IPURIF
+
+EPURIF: PUSHJ P,KILGC
+ SETZM INTHLD
+ SETZM NPWRIT
+IFE ITS,[
+ SKIPN MULTSG
+ JRST NPF
+ POP P,B
+ HRRI B,NPF
+ MOVEI A,0
+ XJRST A
+]
+IFN ITS,[
+ JRST NPF
+]
+
+
+\f
+; ROUTINE TO DO A SPECIAL GARBAGE COLLECT, CALLED FOR FREE STORAGE GARBAGE
+; COLLECTS
+; AND CAN RUN A MARK/SWEEP GARBAGE COLLECT
+
+SAGC:
+IFE ITS,[
+ JRST @[.+1] ; RETURN WITH US NOW TO THE THRILLING
+ ; DAYS OF SEGMENT 0
+]
+ SOSL NUMSWP ; GET NUMBER OF SWEEP GARBAGE COLLECTS
+ JRST MSGC ; TRY MARK/SWEEP
+ MOVE RNUMSP ; MOVE IN RNUMSWP
+ MOVEM NUMSWP ; SMASH IT IN
+ JRST GOGC
+MSGC: SKIPN PGROW ; CHECK FOR STACK OVERFLOW
+ SKIPE TPGROW
+ JRST AGC ; IF SO CAUSE REAL GARBAGE COLLECT
+ PUSH P,C
+ PUSH P,D
+ PUSH P,E
+ SETOM SWAPGC ; LOAD MARK SWEEP VERSION
+ PUSHJ P,AGC1 ; CAUSE GARBAGE COLLECT
+ HRRZ 0,MAXLEN ; SEE IF REQUEST SATISFIED
+ CAMGE 0,GETNUM
+ JRST LOSE1
+ MOVE C,FREMIN ; GET FREMIN
+ SUB C,TOTCNT ; CALCULATE NEEDED
+ SUB C,FRETOP
+ ADD C,GCSTOP
+ JUMPL C,DONE1
+ JSP E,CKPUR ; GO CHECK FOR SOME STUFF
+ MOVE D,PURBOT
+IFE ITS, ANDCMI D,1777 ; MAKE LIKE AN ITS PAGE
+ SUB D,CURPLN ; CALCULATE PURENESS
+ SUB D,P.TOP
+ CAIG D,(C) ; SEE IF PURENESS EXISTS
+ JRST LOSE1
+ PUSH P,A
+ ADD C,GCSTOP
+ MOVEI A,1777(C)
+ ASH A,-10.
+ PUSHJ P,P.CORE
+ FATAL P.CORE FAILED
+ HRRZ 0,GCSTOP
+ SETZM @0
+ HRLS 0
+ ADDI 0,1
+ HRRZ A,FRETOP
+ BLT 0,-1(A)
+ PUSHJ P,RBLDM
+ POP P,A
+DONE1: POP P,E
+ POP P,D
+ POP P,C
+IFN ITS, POPJ P,
+IFE ITS,[
+ SKIPN MULTSG
+ POPJ P,
+ SETZM 20
+ POP P,21 ; BACK TO CALLING SEGMENT
+ XJRST 20
+]
+LOSE1: POP P,E
+ POP P,D
+ POP P,C
+GOGC:
+
+
+AGC:
+IFE ITS,[
+ SKIPE MULTSG
+ SKIPE GCDEBU
+ JRST @[SEC1]
+ XJRST .+1
+ 0
+ FSEG,,SEC1
+SEC1:
+]
+ MOVE 0,RNUMSP
+ MOVEM 0,NUMSWP
+ SETZM SWAPGC
+AGC1: SKIPE NPWRIT
+ JRST IAGC
+ EXCH P,GCPDL
+ PUSHJ P,SVAC ; SAVE ACS
+ PUSHJ P,SQKIL
+ PUSHJ P,CTIME
+ MOVEM B,GCTIM
+ PUSHJ P,LODGC ; LOAD GC
+ PUSHJ P,RSAC ; RESTORE ACS
+ EXCH P,GCPDL
+ SKIPE SWAPGC
+ JRST IAMSGC
+ SKIPN MULTSG
+ JRST IAGC
+ JRST ISECGC
+
+AAGC: SETZM SWAPGC
+ EXCH P,GCPDL
+ PUSHJ P,SVAC ; SAVE ACS
+ PUSHJ P,LODGC ; LOAD GC
+ PUSHJ P,RSAC ; RESTORE ACS
+ EXCH P,GCPDL
+ JRST IAAGC
+
+FNMSGC:
+FINAGC: SKIPE NPWRIT
+ JRST FINAGG
+ PUSHJ P,SVAC ; SAVE ACS
+ PUSHJ P,KILGC
+ PUSHJ P,RSAC
+FINAGG:
+IFN ITS, POPJ P,
+IFE ITS,[
+ SKIPN MULTSG
+ POPJ P,
+ SETZM 20
+ POP P,21 ; BACK TO CALLING SEGMENT
+ XJRST 20
+]
+
+; ROUTINE TO SAVE THE ACS
+
+SVAC: EXCH 0,(P)
+ PUSH P,A
+ PUSH P,B
+ PUSH P,C
+ PUSH P,D
+ PUSH P,E
+ JRST @0
+
+; ROUTINE TO RESTORE THE ACS
+
+RSAC: POP P,0
+ POP P,E
+ POP P,D
+ POP P,C
+ POP P,B
+ POP P,A
+ EXCH 0,(P)
+ POPJ P,
+
+
+\f
+
+; INTERNAL FUNCTION TO GET STRAGE ALLOCATION TYPE
+; GETS THE TYPE CODE IN A AND RETURNS SAT IN A.
+
+SAT: LSH A,1 ; TIMES 2 TO REF VECTOR
+ HRLS A ; TO BOTH HALVES TO HACK AOBJN
+ ; POINTER
+ ADD A,TYPVEC+1 ; ACCESS THE VECTOR
+ HRR A,(A) ; GET PROBABLE SAT
+ JUMPL A,.+2 ; DID WE REALLY HAVE A VALID
+ ; TYPE
+ MOVEI A,0 ; NO RETURN 0
+ ANDI A,SATMSK
+ POPJ P, ; AND RETURN
+
+; FIND AND ALLOCATE AS MANY CONTIGUOUS PAGES AS INDICATED BY REG A
+; RETURN THE NUMBER (0-255.) OF THE FIRST SUCH PAGE IN REG B
+; RETURN -1 IN REG B IF NONE FOUND
+
+PGFIND:
+ JUMPLE A,FPLOSS
+ CAILE A,256.
+ JRST FPLOSS
+
+ PUSHJ P,PGFND1 ; SEE IF ALREADY ENOUGH
+ SKIPN NOSHUF ; CAN'T MOVE PURNESS
+ SKIPL B ; SKIP IF LOST
+ POPJ P,
+
+ SUBM M,(P)
+ PUSH P,E
+ PUSH P,C
+ PUSH P,D
+PGFLO4: MOVE C,PURBOT ; CHECK IF ROOM AT ALL
+ ; (NOTE POTENTIAL FOR INFINITE LOOP)
+ SUB C,P.TOP ; TOTAL SPACE
+ MOVEI D,(C) ; COPY FOR CONVERSION TO PAGES
+ ASH D,-10.
+ CAIGE D,(A) ; SKIP IF COULD WIN
+ JRST PGFLO1
+
+ MOVNS A ; MOVE PURE AREA DOWN "A" PAGES
+ PUSHJ P,MOVPUR
+ MOVE B,PURTOP ; GET FIRST PAGE ALLOCATED
+ ASH B,-10. ; TO PAGE #
+PGFLOS: POP P,D
+ POP P,C
+ POP P,E
+ PUSHJ P,RBLDM ; GET A NEW VALUE FOR M
+ JRST MPOPJ
+
+; HERE TO SHUFFLE PURE SPACE TO TRY TO FIND PAGES
+
+PGFLO1: SKIPE GCFLG ; SKIP IF NOT IN GC
+ JRST PGFLO5 ; WE LOST
+ MOVE C,PURTOP
+ SUB C,P.TOP
+ HRRZ D,FSAV(TB) ; ARE WE IN A PURE RSUBR?
+ CAIL D,HIBOT ; ARE WE AN RSUBR AT ALL?
+ JRST PGFLO2
+ GETYP E,(R) ; SEE IF PCODE
+ CAIE E,TPCODE
+ JRST PGFLO2
+ HLRZ D,1(R) ; GET OFFSET TO PURVEC
+ ADD D,PURVEC+1
+ HRROS 2(D) ; MUNG AGE
+ HLRE D,1(D) ; GET LENGTH
+ ADD C,D
+PGFLO2: ASH C,-10.
+ CAILE A,(C)
+ JRST PGFLO3
+ PUSH P,A
+IFE ITS, ASH A,1 ; TENEX PAGES ARE HALF SIZE
+ PUSHJ P,GETPAG ; SHUFFLE THEM AROUND
+ FATAL PURE SPACE LOSING
+ POP P,A
+ JRST PGFLO4
+
+; HERE TO CAUSE AGC IF PAGES ARE NOT AVAILABLE EVEN AFTER MAPPING OUT THE WORLD
+
+
+PGFLO3: PUSH P,A ; ASK GC FOR SPACE
+ ASH A,10.
+ MOVEM A,GCDOWN ; REQUEST THOSE PAGES
+ MOVE C,[8.,,9.]
+ PUSHJ P,AGC ; GO GARBAGE COLLECT
+ POP P,A
+ JRST PGFLO4 ; GO BACK TO POTENTIAL LOOP
+
+
+PGFLO5: SETOM B ; -1 TO B
+ JRST PGFLOS ; INDICATE LOSSAGE
+
+PGFND1: PUSH P,E
+ PUSH P,D
+ PUSH P,C
+ PUSH P,C%M1 ; POSSIBLE CONTENTS FOR REG B
+ PUSH P,A ; SAVE LENGTH OF BLOCK DESIRED FOR LATER USE
+ SETZB B,C ; INITIAL SECTION AND PAGE NUMBERS
+ MOVEI 0,0 ; COUNT OF PAGES ALREADY FOUND
+ PUSHJ P,PINIT
+PLOOP: TDNE E,D ; FREE PAGE ?
+ JRST NOTFRE ; NO
+ JUMPN 0,NFIRST ; FIRST FREE PAGE OF A BLOCK ?
+ MOVEI A,(B) ; YES SAVE ADDRESS OF PAGE IN REG A
+ IMULI A,16.
+ ASH C,-1 ; BACK TO PAGES
+ ADDI A,(C)
+ ASH C,1 ; FIX IT TO WHAT IT WAS
+NFIRST: ADDI 0,1
+ CAML 0,(P) ; TEST IF ENOUGH PAGES HAVE BEEN FOUND
+ JRST PWIN ; YES, FINISHED
+ SKIPA
+NOTFRE: MOVEI 0,0 ; RESET COUNT
+ PUSHJ P,PNEXT ; NEXT PAGE
+ JRST PLOSE ; NONE--LOSE RETURNING -1 IN REG B
+ JRST PLOOP
+
+PWIN: MOVEI B,(A) ; GET WINNING ADDRESS
+ MOVEM B,(P)-1 ; RETURN ADDRESS OF WINNING PAGE
+ MOVE A,(P) ; RELOAD LENGTH OF BLOCK OF PAGES
+ MOVE 0,[TDO E,D] ; INST TO SET "BUSY" BITS
+ JRST ITAKE
+
+; CLAIM OR RETURN TO FREE STORAGE AS MANY CONTIGUOUS PAGES AS INDICATED BY REG A
+; THE NUMBER (0 - 255.) OF THE FIRST SUCH PAGE IS IN REG B
+PGGIVE: MOVE 0,[TDZ E,D] ; INST TO SET "FREE" BITS
+ SKIPA
+PGTAKE: MOVE 0,[TDO E,D] ; INST TO SET "BUSY" BITS
+ JUMPLE A,FPLOSS
+ CAIL B,0
+ CAILE B,255.
+ JRST FPLOSS
+ PUSH P,E
+ PUSH P,D
+ PUSH P,C
+ PUSH P,B
+ PUSH P,A
+ITAKE: IDIVI B,16.
+ PUSHJ P,PINIT
+ SUBI A,1
+RTL: XCT 0 ; SET APPROPRIATE BIT
+ PUSHJ P,PNEXT ; NEXT PAGE'S BIT
+ JUMPG A,FPLOSS ; TOO MANY ?
+ SOJGE A,RTL
+ MOVEM E,PMAPB(B) ; REPLACE BIT MASK
+PLOSE: POP P,A
+ POP P,B
+ POP P,C
+ POP P,D
+ POP P,E
+ POPJ P,
+
+
+PINIT: MOVE E,PMAPB(B) ; GET BITS FOR THIS SECTION
+ HRLZI D,400000 ; BIT MASK
+ IMULI C,2
+ MOVNS C
+ LSH D,(C) ; SHIFT TO APPROPRIATE BIT POSITION
+ MOVNS C
+ POPJ P,
+
+PNEXT: AOS (P) ; FOR SKIP RETURN ON EXPECTED SUCCESS
+ LSH D,-2 ; CONSIDER NEXT PAGE
+ CAIL C,30. ; FINISHED WITH THIS SECTION ?
+ JRST PNEXT1
+ AOS C
+ AOJA C,CPOPJ ; NO, INCREMENT AND CONTINUE
+PNEXT1: MOVEM E,PMAPB(B) ; REPLACE BIT MASK
+ SETZ C,
+ CAIGE B,15. ; LAST SECTION ?
+ AOJA B,PINIT ; NO, INCREMENT AND CONTINUE
+ SOS (P) ; YES, UNDO SKIP RETURN
+ POPJ P,
+
+FPLOSS: FATAL PAGE LOSSAGE
+
+PGINT: MOVEI B,HIBOT ; INITIALIZE MUDDLE'S PAGE MAP TABLE
+ IDIVI B,2000 ; FIRST PAGE OF PURE CODE
+ MOVE C,HITOP
+ IDIVI C,2000
+ MOVEI A,(C)+1
+ SUBI A,(B) ; NUMBER OF SUCH PAGES
+ PUSHJ P,PGTAKE ; MARK THESE PAGES AS TAKEN
+ POPJ P,
+
+
+
+\f
+ERRKIL: PUSH P,A
+ PUSHJ P,KILGC ; KILL THE GARBAGE COLLECTOR
+ POP P,A
+ JRST CALER
+
+; IF IN A PURE RSUBR, FIND ITS LENGTH AND FUDGE ITS LRU
+
+CKPUR: HRRZ A,FSAV(TB) ; GET NAME OF CURRENT GOODIE
+ SETZM CURPLN ; CLEAR FOR NONE
+ CAIL A,HIBOT ; IF LESS THAN TOP OF PURE ASSUME RSUBR
+ JRST (E)
+ GETYP 0,(A) ; SEE IF PURE
+ CAIE 0,TPCODE ; SKIP IF IT IS
+ JRST NPRSUB
+NRSB2: HLRZ B,1(A) ; GET SLOT INDICATION
+ ADD B,PURVEC+1 ; POINT TO SLOT
+ HRROS 2(B) ; MUNG AGE
+ HLRE A,1(B) ; - LENGTH TO A
+ TRZ A,1777
+ MOVNM A,CURPLN ; AND STORE
+ JRST (E)
+NPRSUB: SKIPGE B,1(R) ; SEE IF PURE RSUBR
+ JRST (E)
+ MOVE A,R
+ JRST NRSB2
+
+; THIS IS THE SCHEME USED TO UPDATE CERTAIN IMFORMATION USED BY THE
+; BLOAT-SPEC ROUTINE TO GIVE USERS IMFORMATION ABOUT USE OF SPACE BY
+; THEIR MUDDLE.
+
+GCSET: MOVE A,RFRETP ; COMPUTE FREE SPACE AVAILABLE
+ SUB A,PARTOP
+ MOVEM A,NOWFRE
+ CAMLE A,MAXFRE
+ MOVEM A,MAXFRE ; MODIFY MAXIMUM
+ HLRE A,TP ; FIND THE DOPE WORD OF THE TP STACK
+ MOVNS A
+ ADDI A,1(TP) ; CLOSE TO DOPE WORD
+ CAME A,TPGROW
+ ADDI A,PDLBUF ; NOW AT REAL DOPE WORD
+ HLRZ B,(A) ; GET LENGTH OF TP-STACK
+ MOVEM B,NOWTP
+ CAMLE B,CTPMX ; SEE IF THIS IS THE BIGGEST TP
+ MOVEM B,CTPMX
+ HLRE B,P ; FIND DOPE WORD OF P-STACK
+ MOVNS B
+ ADDI B,1(P) ; CLOSE TO IT
+ CAME B,PGROW ; SEE IF THE STACK IS BLOWN
+ ADDI B,PDLBUF ; POINTING TO IT
+ HLRZ A,(B) ; GET IN LENGTH
+ MOVEM A,NOWP
+ CAMLE A,CPMX ; SEE IF WE HAVE THE BIGGEST P STACK
+ MOVEM A,CPMX
+ POPJ P, ; EXIT
+
+RBLDM: JUMPGE R,CPOPJ
+ SKIPGE M,1(R) ; SKIP IF FUNNY
+ JRST RBLDM1
+
+ HLRS M
+ ADD M,PURVEC+1
+ HLLM TB,2(M)
+ SKIPL M,1(M)
+ JRST RBLDM1
+ PUSH P,0
+ HRRZ 0,1(R)
+ ADD M,0
+ POP P,0
+RBLDM1: SKIPN SAVM ; SKIP IF FUNNY (M)
+ POPJ P, ; EXIT
+ MOVEM M,SAVM
+ MOVEI M,0
+ POPJ P,
+CPOPJ1:
+C1POPJ: AOS (P)
+ POPJ P,
+
+
+\f
+; THIS ROUTINE MAKES SURE CURRENT FRAME MAKES SENSE
+FRMUNG: MOVEM D,PSAV(A)
+ MOVE SP,SPSTOR+1
+ MOVEM SP,SPSAV(A)
+ MOVEM TP,TPSAV(A) ; SAVE FOR MARKING
+ POPJ P,
+
+
+; SUBROUTINE TO REBUILD THE NOW DEFUNCT HASH TABLE
+
+REHASH: MOVE D,ASOVEC+1 ; GET POINTER TO VECTOR
+ MOVEI E,(D)
+ PUSH P,E ; PUSH A POINTER
+ HLRE A,D ; GET -LENGTH
+ MOVMS A ; AND PLUSIFY
+ PUSH P,A ; PUSH IT ALSO
+
+REH3: HRRZ C,(D) ; POINT TO FIRST BUCKKET
+ HLRZS (D) ; MAKE SURE NEW POINTER IS IN RH
+ JUMPLE C,REH1 ; BUCKET EMPTY, QUIT
+
+REH2: MOVEI E,(C) ; MAKE A COPY OF THE POINTER
+ MOVE A,ITEM(C) ; START HASHING
+ TLZ A,TYPMSK#777777 ; KILL MONITORS
+ XOR A,ITEM+1(C)
+ MOVE 0,INDIC(C)
+ TLZ 0,TYPMSK#777777
+ XOR A,0
+ XOR A,INDIC+1(C)
+ TLZ A,400000 ; MAKE SURE FINAL HASH IS +
+ IDIV A,(P) ; DIVIDE BY TOTAL LENGTH
+ ADD B,-1(P) ; POINT TO WINNING BUCKET
+
+ MOVE C,[002200,,(B)] ; BYTE POINTER TO RH
+ CAILE B,(D) ; IF PAST CURRENT POINT
+ MOVE C,[222200,,(B)] ; USE LH
+ LDB A,C ; GET OLD VALUE
+ DPB E,C ; STORE NEW VALUE
+ HRRZ B,ASOLNT-1(E) ; GET NEXT POINTER
+ HRRZM A,ASOLNT-1(E) ; AND CLOBBER IN NEW NEXT
+ SKIPE A ; SKKIP IF NOTHING PREVIOUSLY IN BUCKET
+ HRLM E,ASOLNT-1(A) ; OTHERWISE CLOBBER
+ SKIPE C,B ; SKIP IF END OF CHAIN
+ JRST REH2
+REH1: AOBJN D,REH3
+
+ SUB P,C%22 ; FLUSH THE JUNK
+ POPJ P,
+\f
+;SUBROUTINES TO RETURN WORDS NEEDED BASED ON TYPE OR SAT
+
+NWORDT: PUSHJ P,SAT ;GET STORAGE ALLOC TYPE
+NWORDS: CAIG A,NUMSAT ; TEMPLATE?
+ SKIPL MKTBS(A) ;-ENTRY IN TABLE MEANS 2 NEEDED
+ SKIPA A,C%1 ;NEED ONLY 1
+ MOVEI A,2 ;NEED 2
+ POPJ P,
+
+.GLOBAL GCRET,PAIRMK,DEFMK,VECTMK,TBMK,TPMK,ARGMK,VECTMK,FRMK,BYTMK,ATOMK,GATOMK
+.GLOBAL LOCMK,BYTMK,ABMK,LOCRMK,GCRDMK,DEFQMK,ASMRK,OFFSMK
+
+; DISPATCH TABLE FOR MARK PHASE ("SETZ'D" ENTRIES MUST BE DEFERRED)
+
+DISTBS MKTBS,GCRET,[[S2WORD,PAIRMK],[S2DEFR,DEFMK],[SNWORD,VECTMK],[STBASE,TBMK]
+[STPSTK,TPMK],[SARGS,<SETZ ARGMK>],[S2NWORD,VECTMK],[SPSTK,TPMK],[SSTORE,VECTMK]
+[SFRAME,<SETZ FRMK>],[SBYTE,<SETZ BYTMK>],[SATOM,ATOMK],[SPVP,VECTMK],[SGATOM,GATOMK]
+[SLOCID,<SETZ LOCMK>],[SCHSTR,<SETZ BYTMK>],[SASOC,ASMRK],[SLOCL,PAIRMK],[SABASE,ABMK]
+[SLOCA,<SETZ ARGMK>],[SLOCV,VECTMK],[SLOCU,VECTMK],[SLOCS,<SETZ BYTMK>],[SLOCN,ASMRK]
+[SLOCR,LOCRMK],[SRDTB,GCRDMK],[SLOCB,<SETZ BYTMK>],[SDEFQ,DEFQMK],[SOFFS,OFFSMK]]
+
+IMPURE
+
+DSTORE: 0 ; USED FOR MAPFS AND SEGMENTS
+BUFL: 0 ; BUFFER PAGE (WORDS)
+BUFP: 0 ; BUFFER PAGE (PAGES)
+NPWRIT: 0 ; INDICATION OF PURIFY
+RNUMSP: 0 ; NUMBER OF MARK/SWEEP GARBAGE
+ ; COLLECTS TO REAL GARBAGE COLLECT
+NUMSWP: 0 ; NUMBER MARK SWEEP GARBAGE COLLECTS TO GO
+SWAPGC: 0 ; FLAG INDICATING WHETHER TO LOAD SWAP
+ ; GC OR NOT
+TOTCNT: 0 ; TOTAL COUNT
+
+PURE
+
+PAT:
+PATCH:
+
+BLOCK 400
+PATEND:
+
+END
+\f
\ No newline at end of file
--- /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
+IFE ITS,[
+ ADD C,M ; POINT TO START PC
+ SKIPE MULTSG
+ TLZ C,777400 ; KILL COUNT
+]
+ AOBJP TB,MCHK7
+ INTGO
+IFN ITS, JRST @C ; GO TO IT
+IFE ITS,[
+MCHK8: 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
+]
+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,M
+ SKIPE MULTSG
+ HRLI 0,<<M>_12.> ; MAKE GLOBAL INDEX
+]
+ 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,440640 ; OR IN THE BYTE POINTER
+ SKIPN MULTSG
+ HRR A,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
+; MOVE 0,[A,,ACSAV]
+; BLT 0,ACSAV+NOACS-1 ; UNNECESSARY SINCE WILL BE MUNGED ANYWAY
+ HRRZ B,-3(P) ; NUMBER OF ACS
+; MOVE B,0
+LOPPOP: POP TP,ACSAV-1(B)
+LOPBAR: SUB TP,C%11
+; SUBI B,1
+LOPFOO: SOJG B,LOPPOP
+; MOVEI 0,ACSAV-1 ; THIS CAUSES BLT TO GO TOO FAR
+; ADDM 0,-3(P)
+ 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
--- /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,M
+ SKIPE MULTSG
+ HRLI 0,<<M>_12.> ; MAKE GLOBAL INDEX
+]
+ 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,440640 ; OR IN THE BYTE POINTER
+ SKIPN MULTSG
+ HRR A,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
+; MOVE 0,[A,,ACSAV]
+; BLT 0,ACSAV+NOACS-1 ; UNNECESSARY SINCE WILL BE MUNGED ANYWAY
+ HRRZ B,-3(P) ; NUMBER OF ACS
+; MOVE B,0
+LOPPOP: POP TP,ACSAV-1(B)
+LOPBAR: SUB TP,C%11
+; SUBI B,1
+LOPFOO: SOJG B,LOPPOP
+; MOVEI 0,ACSAV-1 ; THIS CAUSES BLT TO GO TOO FAR
+; ADDM 0,-3(P)
+ 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
--- /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,440640 ; OR IN THE BYTE POINTER
+ SKIPN MULTSG
+ HRR A,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
--- /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
-Placeholder.
+MIDAS Muddle for TOPS-20.
+
+There should also be support for ITS, but it won't build as is.
projects / pdp10-muddle.git / commitdiff