These aren't needed since we can fix the latest versions.
+++ /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 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 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 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 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 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
-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
-
-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 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 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 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
-; 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 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 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 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 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 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 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 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
-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 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 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
-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 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
projects / pdp10-muddle.git / commitdiff