From: Lars Brinkhoff Date: Wed, 14 Feb 2018 06:03:37 +0000 (+0100) Subject: Twenex Muddle. X-Git-Url: https://jxself.org/git/?a=commitdiff_plain;h=bab072f950a643ac109660a223b57e635492ac25;p=pdp10-muddle.git Twenex Muddle. --- diff --git a//_chkdcl.temp.1 b//_chkdcl.temp.1 new file mode 100644 index 0000000..1532f04 Binary files /dev/null and b//_chkdcl.temp.1 differ diff --git a//_clr.ev.1 b//_clr.ev.1 new file mode 100644 index 0000000..3a73985 Binary files /dev/null and b//_clr.ev.1 differ diff --git a//_clr.opcodes.1 b//_clr.opcodes.1 new file mode 100644 index 0000000..ca2dca1 Binary files /dev/null and b//_clr.opcodes.1 differ diff --git a//_clr.opcodes.2 b//_clr.opcodes.2 new file mode 100644 index 0000000..c94fe33 Binary files /dev/null and b//_clr.opcodes.2 differ diff --git a//_clr.rmode.1 b//_clr.rmode.1 new file mode 100644 index 0000000..4a4eaf3 Binary files /dev/null and b//_clr.rmode.1 differ diff --git a//agc.bin.16 b//agc.bin.16 new file mode 100644 index 0000000..426d296 Binary files /dev/null and b//agc.bin.16 differ diff --git a//agc.bin.21 b//agc.bin.21 new file mode 100644 index 0000000..0526574 Binary files /dev/null and b//agc.bin.21 differ diff --git a//agc.mid.131 b//agc.mid.131 new file mode 100644 index 0000000..e44c5e7 --- /dev/null +++ b//agc.mid.131 @@ -0,0 +1,3601 @@ +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 + + +; 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 + 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 + + +; 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 + + +.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 + + + +.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 + + + +; 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,],[SATOM,DATOMK],[SPVP,ERDP],[SGATOM,ERDP] +[SLOCID,ERDP],[SCHSTR,],[SASOC,ERDP],[SLOCL,PAIRMK],[SABASE,ERDP] +[SLOCA,ERDP],[SLOCV,VECTMK],[SLOCU,VECTMK],[SLOCS,],[SLOCN,ERDP] +[SLOCB,],[SLOCR,LOCRDP],[SOFFS,OFFSMK]] + +OFFSET OFFS + + +; 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 + + + +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 + + ; 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 + + + + ; 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 + + ; 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, + + + ;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 + + + ;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 + + ; 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 + + + ; 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, + + + ;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 + + + + ; 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 + + ; 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 + + +; 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 + + + ; 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, + + + + + ; 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, + + + + ; 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 + + + +; 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 + + +; 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 + + +; 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 + + +; 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 + + +; 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 + + +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 + + + +; MARK NON-GENERAL VECTORS + +NOTGEN: CAMN B,[GENERAL+] + 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 + + + +; 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 + + + +;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 + + +; 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 + + + ; 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 + + + +; 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 + + ; 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 + + ;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, + + ; 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 + + +; 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, + + +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 + + +;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 WIND <,-10.> +WNDP==.LVAL1 + +.LOP FRONT <,-10.> +FRNP==.LVAL1 + +ZZ2==ENDGC-AGCLD +.LOP ZZ2 <,-10.> +LENGC==.LVAL1 + +.LOP LENGC <,10.> +RLENGC==.LVAL1 + +.LOP AGCLD <,-10.> +PAGEGC==.LVAL1 + +OFFSET 0 + +LOC GCST +.LPUR==$. + +END + diff --git a//agc.mid.139 b//agc.mid.139 new file mode 100644 index 0000000..1a58c58 --- /dev/null +++ b//agc.mid.139 @@ -0,0 +1,3632 @@ +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 + + +; 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 + 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 + + +; 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 + + +.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 + + + +.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 + + + +; 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,],[SATOM,DATOMK],[SPVP,ERDP],[SGATOM,ERDP] +[SLOCID,ERDP],[SCHSTR,],[SASOC,ERDP],[SLOCL,PAIRMK],[SABASE,ERDP] +[SLOCA,ERDP],[SLOCV,VECTMK],[SLOCU,VECTMK],[SLOCS,],[SLOCN,ERDP] +[SLOCB,],[SLOCR,LOCRDP],[SOFFS,OFFSMK]] + +OFFSET OFFS + + +; 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 + + + +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 + + ; 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 + + + + ; 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 + + ; 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, + + + ;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 + + + ;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 + + ; 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 + + + ; 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, + + + ;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 + + + + ; 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 + + ; 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 + + +; 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 + + + ; 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, + + + + + ; 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, + + + + ; 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 + + + +; 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 + + +; 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 + + +; 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 + + +; 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 + + +; 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 + + +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 + + + +; MARK NON-GENERAL VECTORS + +NOTGEN: CAMN B,[GENERAL+] + 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 + + + +; 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 + + + +;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 + + +; 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 + + + ; 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 + + + +; 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 + + ; 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 + + ;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, + + ; 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 + + +; 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, + + +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 + + +;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 WIND <,-10.> +WNDP==.LVAL1 + +.LOP FRONT <,-10.> +FRNP==.LVAL1 + +ZZ2==ENDGC-AGCLD +.LOP ZZ2 <,-10.> +LENGC==.LVAL1 + +.LOP LENGC <,10.> +RLENGC==.LVAL1 + +.LOP AGCLD <,-10.> +PAGEGC==.LVAL1 + +OFFSET 0 + +LOC GCST +.LPUR==$. + +END + diff --git a//agc.mid.140 b//agc.mid.140 new file mode 100644 index 0000000..433a455 --- /dev/null +++ b//agc.mid.140 @@ -0,0 +1,3632 @@ +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 + + +; 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 + 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 + + +; 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 + + +.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 + + + +.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 + + + +; 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,],[SATOM,DATOMK],[SPVP,ERDP],[SGATOM,ERDP] +[SLOCID,ERDP],[SCHSTR,],[SASOC,ERDP],[SLOCL,PAIRMK],[SABASE,ERDP] +[SLOCA,ERDP],[SLOCV,VECTMK],[SLOCU,VECTMK],[SLOCS,],[SLOCN,ERDP] +[SLOCB,],[SLOCR,LOCRDP],[SOFFS,OFFSMK]] + +OFFSET OFFS + + +; 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 + + + +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 + + ; 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 + + + + ; 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 + + ; 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, + + + ;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 + + + ;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 + + ; 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 + + + ; 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, + + + ;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 + + + + ; 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 + + ; 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 + + +; 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 + + + ; 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, + + + + + ; 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, + + + + ; 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 + + + +; 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 + + +; 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 + + +; 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 + + +; 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 + + +; 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 + + +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 + + + +; MARK NON-GENERAL VECTORS + +NOTGEN: CAMN B,[GENERAL+] + 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 + + + +; 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 + + + +;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 + + +; 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 + + + ; 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 + + + +; 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 + + ; 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 + + ;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, + + ; 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 + + +; 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, + + +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 + + +;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 WIND <,-10.> +WNDP==.LVAL1 + +.LOP FRONT <,-10.> +FRNP==.LVAL1 + +ZZ2==ENDGC-AGCLD +.LOP ZZ2 <,-10.> +LENGC==.LVAL1 + +.LOP LENGC <,10.> +RLENGC==.LVAL1 + +.LOP AGCLD <,-10.> +PAGEGC==.LVAL1 + +OFFSET 0 + +LOC GCST +.LPUR==$. + +END + diff --git a//agc.mid.141 b//agc.mid.141 new file mode 100644 index 0000000..a0f2684 --- /dev/null +++ b//agc.mid.141 @@ -0,0 +1,3634 @@ +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 + + +; 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 + 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 + + +; 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 + + +.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 + + + +.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 + + + +; 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,],[SATOM,DATOMK],[SPVP,ERDP],[SGATOM,ERDP] +[SLOCID,ERDP],[SCHSTR,],[SASOC,ERDP],[SLOCL,PAIRMK],[SABASE,ERDP] +[SLOCA,ERDP],[SLOCV,VECTMK],[SLOCU,VECTMK],[SLOCS,],[SLOCN,ERDP] +[SLOCB,],[SLOCR,LOCRDP],[SOFFS,OFFSMK]] + +OFFSET OFFS + + +; 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 + + + +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 + + ; 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 + + + + ; 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 + + ; 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, + + + ;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 + + + ;RESTORE AC'S +TRYCOX: SKIPN GCMONF + JRST NOMONO + MOVEI B,[ASCIZ /GOUT /] + PUSHJ P,MSGTYP +NOMONO: MOVE PVP,PVSTOR+1 + IRP AC,,[0,A,B,C,D,E,P,R,M,SP,TP,TB,AB,TVP,FRM] + MOVE AC,AC!STO+1(PVP) + TERMIN + SKIPN DSTORE + SETZM DSTO(PVP) + MOVE PVP,PVPSTO+1(PVP) + +; CLOSING ROUTINE FOR G-C + PUSH P,A ; SAVE AC'C + PUSH P,B + PUSH P,C + PUSH P,D + + MOVE A,FRETOP ; ADJUST BLOAT-STAT PARAMETERS + SUB A,GCSTOP + ADDM A,NOWFRE + PUSHJ P,GCSET ; FIX UP BLOAT-STAT PARAMETERS + MOVE A,CURTP + ADDM A,NOWTP + MOVE A,CURP + ADDM A,NOWP + + PUSHJ P,CTIME + FSBR B,GCTIM ; GET TIME ELAPSED + SKIPN INBLOT ; STORE TIME ONLY IF NO RETRY + SKIPN GCDANG + MOVEM B,GCTIM ; SAVE ELAPSED TIME FOR INT-HANDLER + SKIPN GCMONF ; SEE IF MONITORING + JRST GCCONT + PUSHJ P,FIXSEN ; OUTPUT TIME + MOVEI A,15 ; OUTPUT C/R LINE-FEED + PUSHJ P,IMTYO + MOVEI A,12 + PUSHJ P,IMTYO +GCCONT: MOVE C,[NTPGOO,,NTPMAX] ; MAY FIX UP TP PARAMS TO ENCOURAGE + ; SHRINKAGE FOR EXTRA ROOM + SKIPE GCDANG + MOVE C,[ETPGOO,,ETPMAX] + HLRZM C,TPGOOD + HRRZM C,TPMAX + POP P,D ; RESTORE AC'C + POP P,C + POP P,B + POP P,A + MOVE A,GCDANG + JUMPE A,AGCWIN ; IF ZERO THE GC WORKED + SKIPN GCHAIR ; SEE IF HAIRY GC + JRST BTEST +REAGCX: MOVEI A,1 ; PREPARE FOR A HAIRY GC + MOVEM A,GCHAIR + SETZM GCDANG + MOVE C,[11,,10.] ; REASON FOR GC + JRST IAGC + +BTEST: SKIPE INBLOT + JRST AGCWIN + FATAL AGC--NO CORE AVAILABLE TO SATISFY REQUESTS + JRST REAGCX + +AGCWIN: SETZM PARNEW ;CLEAR FOR NEXT AGC CALL + SETZM GETNUM ;ALSO CLEAR THIS + SETZM INBLOT + SETZM GCFLG + + SETZM PGROW ; CLEAR GROWTH + SETZM TPGROW + SETOM GCHAPN ; INDICATE A GC HAS HAPPENED + SETOM GCHPN + SETOM INTFLG ; AND REQUEST AN INTERRUPT + SETZM GCDOWN + PUSHJ P,RBLDM +; JUMPE R,FINAGC +; JUMPN M,FINAGC ; IF M 0, RUNNING RSUBR SWAPPED OUT +; SKIPE PLODR ; LOADING ONE, M = 0 IS OK + JRST FINAGC + + FATAL AGC--RUNNING RSUBR WENT AWAY + +AGCE1: FATAL AGC--TYPE VECTOR NOT OF TYPE VECTOR + + ; 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 + + + ; 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, + + + ;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 + + + + ; 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 + + ; 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 + + +; 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 + + + ; 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, + + + + + ; 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, + + + + ; 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 + + + +; 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 + + +; 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 + + +; 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 + + +; 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 + + +; 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 + + +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 + + + +; MARK NON-GENERAL VECTORS + +NOTGEN: CAMN B,[GENERAL+] + 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 + + + +; 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 + + + +;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 + + +; 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 + + + ; 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 + + + +; 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 + + ; 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 + + ;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, + + ; 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 + + +; 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, + + +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 + + +;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 WIND <,-10.> +WNDP==.LVAL1 + +.LOP FRONT <,-10.> +FRNP==.LVAL1 + +ZZ2==ENDGC-AGCLD +.LOP ZZ2 <,-10.> +LENGC==.LVAL1 + +.LOP LENGC <,10.> +RLENGC==.LVAL1 + +.LOP AGCLD <,-10.> +PAGEGC==.LVAL1 + +OFFSET 0 + +LOC GCST +.LPUR==$. + +END + diff --git a//agcmrk.bin.3 b//agcmrk.bin.3 new file mode 100644 index 0000000..780f18a Binary files /dev/null and b//agcmrk.bin.3 differ diff --git a//agcmrk.mid.1 b//agcmrk.mid.1 new file mode 100644 index 0000000..6c87a46 --- /dev/null +++ b//agcmrk.mid.1 @@ -0,0 +1,14 @@ +TITLE AGCMRK ESTABLISH AGC LOADING POINT + +RELOCA + +.GLOBAL AGCLD + +XX==$.+1777 + +.LOP ANDCM XX,1777 + +AGCLD=.LVAL1 + +END + \ No newline at end of file diff --git a//amsgc.bin.12 b//amsgc.bin.12 new file mode 100644 index 0000000..113a9e5 Binary files /dev/null and b//amsgc.bin.12 differ diff --git a//amsgc.mid.107 b//amsgc.mid.107 new file mode 100644 index 0000000..2d66f20 --- /dev/null +++ b//amsgc.mid.107 @@ -0,0 +1,865 @@ +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 + + +; 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 + + +; 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,],[S2NWORD,VECMK],[SPSTK,TPMK],[SSTORE,UVMK] +[SFRAME,],[SBYTE,],[SATOM,ATOMK],[SPVP,VECMK],[SGATOM,GATOMK] +[SLOCID,],[SCHSTR,],[SASOC,ASMK],[SLOCL,PAIRMK],[SABASE,ABMK] +[SLOCA,],[SLOCV,VECMK],[SLOCU,UVMK],[SLOCS,],[SLOCN,ASMK] +[SRDTB,GCRDMK],[SLOCB,],[SDEFQ,DEFQMK],[SOFFS,OFFSMK]] + +OFFSET OFFS + + +; 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 + + +; 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 + + +; 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 + +; 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 + + +; 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 + +; 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 + +; 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 + +; 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 + + +; 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 + + + + +; 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 + + +; 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, + + +; 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 ZZ2 <,-10.> +SLENGC==.LVAL1 +.LOP SLENGC <10.> +RSLENG==.LVAL1 +LOC GCST + +.LPUR=$. + +END diff --git a//amsgc.mid.108 b//amsgc.mid.108 new file mode 100644 index 0000000..4379f68 --- /dev/null +++ b//amsgc.mid.108 @@ -0,0 +1,886 @@ +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 + + +; 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 + + +; 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,],[S2NWORD,VECMK],[SPSTK,TPMK],[SSTORE,UVMK] +[SFRAME,],[SBYTE,],[SATOM,ATOMK],[SPVP,VECMK],[SGATOM,GATOMK] +[SLOCID,],[SCHSTR,],[SASOC,ASMK],[SLOCL,PAIRMK],[SABASE,ABMK] +[SLOCA,],[SLOCV,VECMK],[SLOCU,UVMK],[SLOCS,],[SLOCN,ASMK] +[SRDTB,GCRDMK],[SLOCB,],[SDEFQ,DEFQMK],[SOFFS,OFFSMK]] + +OFFSET OFFS + + +; 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 + + +; 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 + + +; 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 + +; 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 + + +; 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 + +; 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 + +; 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 + +; 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 + + +; 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, + + + +; 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 + + +; 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, + + +; 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 ZZ2 <,-10.> +SLENGC==.LVAL1 +.LOP SLENGC <10.> +RSLENG==.LVAL1 +LOC GCST + +.LPUR=$. + +END diff --git a//amsgc.mid.109 b//amsgc.mid.109 new file mode 100644 index 0000000..fda1ffa --- /dev/null +++ b//amsgc.mid.109 @@ -0,0 +1,886 @@ +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 + + +; 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 + + +; 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,],[S2NWORD,VECMK],[SPSTK,TPMK],[SSTORE,UVMK] +[SFRAME,],[SBYTE,],[SATOM,ATOMK],[SPVP,VECMK],[SGATOM,GATOMK] +[SLOCID,],[SCHSTR,],[SASOC,ASMK],[SLOCL,PAIRMK],[SABASE,ABMK] +[SLOCA,],[SLOCV,VECMK],[SLOCU,UVMK],[SLOCS,],[SLOCN,ASMK] +[SRDTB,GCRDMK],[SLOCB,],[SDEFQ,DEFQMK],[SOFFS,OFFSMK]] + +OFFSET OFFS + + +; 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 + + +; 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 + + +; 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 + +; 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 + + +; 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 + +; 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 + +; 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 + +; 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 + + +; 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, + + + +; 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 + + +; 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, + + +; 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 ZZ2 <,-10.> +SLENGC==.LVAL1 +.LOP SLENGC <10.> +RSLENG==.LVAL1 +LOC GCST + +.LPUR=$. + +END diff --git a//amsgc.mid.110 b//amsgc.mid.110 new file mode 100644 index 0000000..6b51e0c --- /dev/null +++ b//amsgc.mid.110 @@ -0,0 +1,887 @@ +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 + + +; 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 + + +; 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,],[S2NWORD,VECMK],[SPSTK,TPMK],[SSTORE,UVMK] +[SFRAME,],[SBYTE,],[SATOM,ATOMK],[SPVP,VECMK],[SGATOM,GATOMK] +[SLOCID,],[SCHSTR,],[SASOC,ASMK],[SLOCL,PAIRMK],[SABASE,ABMK] +[SLOCA,],[SLOCV,VECMK],[SLOCU,UVMK],[SLOCS,],[SLOCN,ASMK] +[SRDTB,GCRDMK],[SLOCB,],[SDEFQ,DEFQMK],[SOFFS,OFFSMK]] + +OFFSET OFFS + + +; 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 + + +; 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 + + +; 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 + +; 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 + + +; 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 + +; 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 + +; 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 + +; 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 + + +; 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, + + + +; 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 + + +; 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, + + +; 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 ZZ2 <,-10.> +SLENGC==.LVAL1 +.LOP SLENGC <10.> +RSLENG==.LVAL1 +LOC GCST + +.LPUR=$. + +END diff --git a//arith.bin.4 b//arith.bin.4 new file mode 100644 index 0000000..2d7fdce Binary files /dev/null and b//arith.bin.4 differ diff --git a//arith.mid.94 b//arith.mid.94 new file mode 100644 index 0000000..602aabf --- /dev/null +++ b//arith.mid.94 @@ -0,0 +1,856 @@ +TITLE ARITHMETIC PRIMITIVES FOR MUDDLE + +.GLOBAL HI,RLOW,CPLUS,CMINUS,CTIMES,CDIVID,CFIX,CFLOAT +.GLOBAL CLQ,CGQ,CLEQ,CGEQ,C1Q,C0Q,CMAX,CMIN,CABS,CMOD,CCOS,CSIN,CATAN,CLOG +.GLOBAL CEXP,CSQRT,CTIME,CORB,CXORB,CANDB,CEQVB,CRAND,CLSH,CROT, +.GLOBAL SAT,BFLOAT,FLGSET + +;BKD + +;DEFINES MUDDLE PRIMITIVES: FIX,FLOAT,ATAN,IEXP,LOG, +; G?,L?,0?,1?,+,-,*,/,MAX,MIN,ABS,SIN,COS,SQRT,RANDOM, +; TIME,SORT. + +RELOCATABLE + +.INSRT MUDDLE > + +O=0 + + +DEFINE TYP1 + (AB) TERMIN +DEFINE VAL1 + (AB)+1 TERMIN + +DEFINE TYP2 + (AB)+2 TERMIN +DEFINE VAL2 + (AB)+3 TERMIN + +DEFINE TYP3 + (AB)+4 TERMIN +DEFINE VAL3 + (AB)+5 TERMIN + +DEFINE TYPN + (D) TERMIN +DEFINE VALN + (D)+1 TERMIN + + +YES: MOVSI A,TATOM ;RETURN PATH FOR 'TRUE' + MOVE B,IMQUOTE T + AOS (P) + POPJ P, + +NO: MOVSI A,TFALSE ;RETURN PATH FOR 'FALSE' + MOVEI B,NIL + POPJ P, + + ;ERROR RETURNS AND OTHER UTILITY ROUTINES + +OVRFLW==10 +OVRFLD: ERRUUO EQUOTE OVERFLOW + +CARGCH: GETYP 0,A ; GET TYPE + CAIN 0,TFLOAT + POPJ P, + JSP A,BFLOAT + POPJ P, + +ARGCHK: ;CHECK FOR SINGLE FIXED OR FLOATING + ;ARGUMENT IF FIXED CONVERT TO FLOATING + ;RETURN FLOATING ARGRUMENT IN B ALWAYS + ENTRY 1 + GETYP C,TYP1 + MOVE B,VAL1 + CAIN C,TFLOAT ;FLOATING? + POPJ P, ;YES, RETURN + CAIE C,TFIX ;FIXED? + JRST WTYP1 ;NO, ERROR + JSP A,BFLOAT ;YES, CONVERT TO FLOATING AND RETURN + POPJ P, + +OUTRNG: ERRUUO EQUOTE ARGUMENT-OUT-OF-RANGE + +NSQRT: ERRUUO EQUOTE NEGATIVE-ARGUMENT + +DEFINE MFLOAT AC + IDIVI AC,400000 + FSC AC+1,233 + FSC AC,254 + FADR AC,AC+1 + TERMIN + +BFLOAT: MFLOAT B + JRST (A) + +OFLOAT: MFLOAT O + JRST (C) + +BFIX: MULI B,400 + TSC B,B + ASH C,(B)-243 + MOVE B,C + JRST (A) + + ;DISPATCH TABLES USED TO CONTROL THE FLOW OF THE VARIOUS PRIMITIVES + +TABLE2: SETZ NO ;TABLE2 (0) +TABLE3: SETZ YES ;TABLE2 (1) & TABLE3 (0) + SETZ NO ;TABLE2 (2) + SETZ YES + SETZ NO + +TABLE4: SETZ NO + SETZ NO + SETZ YES + SETZ YES + + + +FUNC: JSP A,BFIX + JSP A,BFLOAT + SUB B,VALN + IDIV B,VALN + ADD B,VALN + IMUL B,VALN + JSP C,SWITCH + JSP C,SWITCH + + + +FLFUNC==.-2 + FSBR B,O + FDVR B,O + FADR B,O + FMPR B,O + JSP C,FLSWCH + JSP C,FLSWCH + +DEFVAL==.-2 + 0 + 1 + 0 + 1 + 377777,,-1 + 400000,,1 + +DEFTYP==.-2 + TFIX,, + TFIX,, + TFIX,, + TFIX,, + TFLOAT,, + TFLOAT,, + ;PRIMITIVES FLOAT AND FIX + +IMFUNCTION FIX,SUBR + + ENTRY 1 + + JSP C,FXFL + MOVE B,1(AB) + CAIE A,TFIX + JSP A,BFIX + MOVSI A,TFIX + JRST FINIS + +IMFUNCTION FLOAT,SUBR + + ENTRY 1 + + JSP C,FXFL + MOVE B,1(AB) + CAIE A,TFLOAT + JSP A,BFLOAT + MOVSI A,TFLOAT + JRST FINIS + +CFIX: GETYP 0,A + CAIN 0,TFIX + POPJ P, + JSP A,BFIX + MOVSI A,TFIX + POPJ P, + +CFLOAT: GETYP 0,A + CAIN 0,TFLOAT + POPJ P, + JSP A,BFLOAT + MOVSI A,TFLOAT + POPJ P, + +FXFL: GETYP A,(AB) + CAIE A,TFIX + CAIN A,TFLOAT + JRST (C) + JRST WTYP1 + + +MFUNCTION ABS,SUBR + ENTRY 1 + GETYP A,TYP1 + CAIE A,TFIX + CAIN A,TFLOAT + JRST MOVIT + JRST WTYP1 +MOVIT: MOVM B,VAL1 ;GET ABSOLUTE VALUE OF ARGUMENT +AFINIS: HRLZS A ;MOVE TYPE CODE INTO LEFT HALF + JRST FINIS + + + +MFUNCTION MOD,SUBR + ENTRY 2 + GETYP A,TYP1 + CAIE A,TFIX ;FIRST ARG FIXED ? + JRST WTYP1 + GETYP A,TYP2 + CAIE A,TFIX ;SECOND ARG FIXED ? + JRST WTYP2 + MOVE A,VAL1 + IDIV A,VAL2 ;FORM QUOTIENT & REMAINDER + JUMPGE B,.+2 ;Only return positive remainders + ADD B,VAL2 + MOVSI A,TFIX + JRST FINIS + ;PRIMITIVES PLUS, DIFFERENCE, TIMES, DIVIDE, MIN, AND MAX + +MFUNCTION MIN,SUBR + + ENTRY + + MOVEI E,6 + JRST GOPT + +IMFUNCTION MAX,SUBR + + ENTRY + + MOVEI E,7 + JRST GOPT + +MFUNCTION DIVIDE,SUBR,[/] + + ENTRY + + MOVEI E,3 + JRST GOPT + +MFUNCTION DIFFERENCE,SUBR,[-] + + ENTRY + + MOVEI E,2 + JRST GOPT + +IMFUNCTION TIMES,SUBR,[*] + + ENTRY + + MOVEI E,5 + JRST GOPT + +MFUNCTION PLUS,SUBR,[+] + + ENTRY + + MOVEI E,4 + +GOPT: MOVE D,AB ;ARGUMENT POINTER + HLRE A,AB + MOVMS A + ASH A,-1 + PUSHJ P,CARITH + JRST FINIS + +; BUILD COMPILER ENTRIES TO THESE ROUTINES + +IRP NAME,,[CMINUS,CDIVID,CPLUS,CTIMES,CMIN,CMAX]CODE,,[2,3,4,5,6,7] + +NAME: MOVEI E,CODE + JRST CARIT1 +TERMIN + +CARIT1: MOVEI D,(A) + ASH D,1 ; TIMES 2 + HRLI D,(D) + SUBM TP,D ; POINT TO ARGS + PUSH TP,$TTP + AOBJN D,.+1 + PUSH TP,D + PUSHJ P,CARITH + MOVE TP,(TP) + SUB TP,[1,,1] + POPJ P, + +CARITH: MOVE B,DEFVAL(E) ; GET VAL + JFCL OVRFLW,.+1 + MOVEI 0,TFIX ; FIX UNTIL CHANGE + JUMPN A,ARITH0 ; AT LEAST ONE ARG + MOVE A,DEFTYP(E) + POPJ P, + +ARITH0: SOJE A,ARITH1 ; FALL IN WITH ONE ARG + MOVE B,1(D) + GETYP C,(D) ; TYPE OF 1ST ARG + ADD D,[2,,2] ; GO TO NEXT + CAIN C,TFLOAT + JRST ARITH3 + CAIN C,TFIX + JRST ARITH1 + JRST WRONGT + +ARITH1: GETYP C,0(D) ; GET NEXT TYPE + CAIE C,TFIX + JRST ARITH2 ; TO FLOAT LOOP + XCT FUNC(E) ; DO IT + ADD D,[2,,2] + SOJG A,ARITH1 ; KEEP ADDING OR WHATEVER + SKIPE OVFLG + JFCL OVRFLW,OVRFLD + MOVSI A,TFIX + POPJ P, + +ARITH3: GETYP C,0(D) + MOVE 0,1(D) ; GET ARG + CAIE C,TFIX + JRST ARITH4 + PUSH P,A + JSP C,OFLOAT ; FLOAT IT + POP P,A + JRST ARITH5 +ARITH4: CAIE C,TFLOAT + JRST WRONGT + JRST ARITH5 + +ARITH2: CAIE C,TFLOAT ; FLOATER? + JRST WRONGT + PUSH P,A + JSP A,BFLOAT + POP P,A + MOVE 0,1(D) + +ARITH5: XCT FLFUNC(E) + ADD D,[2,,2] + SOJG A,ARITH3 + + SKIPE OVFLG + JFCL OVRFLW,OVRFLD + MOVSI A,TFLOAT + POPJ P, + +SWITCH: XCT COMPAR(E) ;FOR MAX & MIN TESTING + MOVE B,VALN + JRST (C) +COMPAR==.-6 + CAMLE B,VALN + CAMGE B,VALN + + + +FLSWCH: XCT FLCMPR(E) + MOVE B,O + JRST (C) +FLCMPR==.-6 + CAMLE B,O + CAMGE B,O + ;PRIMITIVES ONEP AND ZEROP + +MFUNCTION ONEP,SUBR,[1?] + MOVEI E,1 + JRST JOIN + +MFUNCTION ZEROP,SUBR,[0?] + MOVEI E, + +JOIN: ENTRY 1 + GETYP A,TYP1 + CAIN A,TFIX ;fixed ? + JRST TESTFX + CAIE A,TFLOAT ;floating ? + JRST WTYP1 + MOVE B,VAL1 + CAMN B,NUMBR(E) ;equal to correct value ? + JRST YES1 + JRST NO1 + +TESTFX: CAMN E,VAL1 ;equal to correct value ? + JRST YES1 + +NO1: MOVSI A,TFALSE + MOVEI B,0 + JRST FINIS + +YES1: MOVSI A,TATOM + MOVE B,IMQUOTE T + JRST FINIS + +NUMBR: 0 ;FLOATING PT ZERO + 201400,,0 ;FLOATING PT ONE + ;PRIMITIVES LESSP AND GREATERP + +MFUNCTION LEQP,SUBR,[L=?] + MOVEI E,3 + JRST ARGS + +MFUNCTION GEQP,SUBR,[G=?] + MOVEI E,2 + JRST ARGS + + +MFUNCTION LESSP,SUBR,[L?] + MOVEI E,1 + JRST ARGS + +MFUNCTION GREATERP,SUBR,[G?] + MOVEI E,0 + +ARGS: ENTRY 2 + MOVE B,VAL1 + MOVE A,TYP1 + GETYP 0,A + PUSHJ P,CMPTYP + JRST WTYP1 + MOVE D,VAL2 + MOVE C,TYP2 + GETYP 0,C + PUSHJ P,CMPTYP + JRST WTYP2 + PUSHJ P,ACOMPS + JFCL + JRST FINIS + +; COMPILERS ENTRIES TO THESE GUYS + +IRP NAME,,[CGQ,CLQ,CGEQ,CLEQ]COD,,[0,1,2,3] + +NAME: MOVEI E,COD + JRST ACOMPS +TERMIN + +ACOMPS: GETYP A,A + GETYP 0,C + CAIE 0,(A) + JRST COMPD ; COMPARING FIX AND FLOAT +TEST: CAMN B,D + JRST @TABLE4(E) + CAMG B,D + JRST @TABLE2(E) + JRST @TABLE3(E) + +CMPTYP: CAIE 0,TFIX + CAIN 0,TFLOAT + AOS (P) + POPJ P, +COMPD: EXCH B,D + CAIN A,TFLOAT + JSP A,BFLOAT + EXCH B,D + CAIN 0,TFLOAT + JSP A,BFLOAT +COMPF: JRST TEST + +MFUNCTION RANDOM,SUBR + ENTRY + HLRE A,AB + CAMGE A,[-4] ;At most two arguments to random to set seeds + JRST TMA + JRST RANDGO(A) + MOVE B,VAL2 ;Set second seed + MOVEM B,RLOW + MOVE A,VAL1 ;Set first seed + MOVEM A,RHI +RANDGO: PUSHJ P,CRAND + JRST FINIS + +CRAND: MOVE A,RHI + MOVE B,RLOW + MOVEM A,RLOW ;Update Low seed + LSHC A,-1 ;Shift both right one bit + XORB B,RHI ;Generate output and update High seed + MOVSI A,TFIX + POPJ P, + + + MFUNCTION SQRT,SUBR + PUSHJ P,ARGCHK + JUMPL B,NSQRT + PUSHJ P,ISQRT + JRST FINIS + +ISQRT: MOVE A,B + ASH B,-1 + FSC B,100 +SQ2: MOVE C,B ;NEWTON'S METHOD, SPECINER'S HACK. + FDVRM A,B + FADRM C,B + FSC B,-1 + CAME C,B + JRST SQ2 + MOVSI A,TFLOAT + POPJ P, + +MFUNCTION COS,SUBR + PUSHJ P,ARGCHK + FADR B,[1.570796326] ;COS(X)=SIN (X+PI/2) + PUSHJ P,.SIN + MOVSI A,TFLOAT + JRST FINIS + +MFUNCTION SIN,SUBR + PUSHJ P,ARGCHK + PUSHJ P,.SIN + MOVSI A,TFLOAT + JRST FINIS + +.SIN: MOVM A,B + CAMG A,[.0001] + POPJ P, ;GOSPER'S RECURSIVE SIN. + FDVR B,[-3.0] ;SIN(X)=4*SIN(X/-3)**3-3*SIN(X/-3) + PUSHJ P,.SIN + FSC A,1 + FMPR A,A + FADR A,[-3.0] + FMPRB A,B + POPJ P, + +CSQRT: PUSHJ P,CARGCH + JUMPL B,NSQRT + JRST ISQRT + +CSIN: PUSHJ P,CARGCH +CSIN1: PUSHJ P,.SIN + MOVSI A,TFLOAT + POPJ P, + +CCOS: PUSHJ P,CARGCH + FADR B,[1.570796326] + JRST CSIN1 + MFUNCTION LOG,SUBR + PUSHJ P,ARGCHK ;LEAVES ARGUMENT IN B + PUSHJ P,ILOG + JRST FINIS + +CLOG: PUSHJ P,CARGCH + +ILOG: JUMPLE B,OUTRNG + LDB D,[331100,,B] ;GRAB EXPONENT + SUBI D,201 ;REMOVE BIAS + TLZ B,777000 ;SET EXPONENT + TLO B,201000 ; TO 1 + MOVE A,B + FSBR A,RT2 + FADR B,RT2 + FDVB A,B + FMPR B,B + MOVE C,[0.434259751] + FMPR C,B + FADR C,[0.576584342] + FMPR C,B + FADR C,[0.961800762] + FMPR C,B + FADR C,[2.88539007] + FMPR C,A + FADR C,[0.5] + MOVE B,D + FSC B,233 + FADR B,C + FMPR B,[0.693147180] ;LOG E OF 2 + MOVSI A,TFLOAT + POPJ P, + +RT2: 1.41421356 + MFUNCTION ATAN,SUBR + PUSHJ P,ARGCHK + PUSHJ P,IATAN + JRST FINIS + +CATAN: PUSHJ P,CARGCH + +IATAN: PUSH P,B + MOVM D,B + CAMG D,[0.4^-8] ;SMALL ENOUGH SO ATAN(X)=X? + JRST ATAN3 ;YES + CAML D,[7.0^7] ;LARGE ENOUGH SO THAT ATAN(X)=PI/2? + JRST ATAN1 ;YES + MOVN C,[1.0] + CAMLE D,[1.0] ;IS ABS(X)<1.0? + FDVM C,D ;NO,SCALE IT DOWN + MOVE B,D + FMPR B,B + MOVE C,[1.44863154] + FADR C,B + MOVE A,[-0.264768620] + FDVM A,C + FADR C,B + FADR C,[3.31633543] + MOVE A,[-7.10676005] + FDVM A,C + FADR C,B + FADR C,[6.76213924] + MOVE B,[3.70925626] + FDVR B,C + FADR B,[0.174655439] + FMPR B,D + JUMPG D,ATAN2 ;WAS ARG SCALED? + FADR B,PI2 ;YES, ATAN(X)=PI/2-ATAN(1/X) + JRST ATAN2 +ATAN1: MOVE B,PI2 +ATAN2: SKIPGE (P) ;WAS INPUT NEGATIVE? + MOVNS B ;YES,COMPLEMENT +ATAN3: MOVSI A,TFLOAT + SUB P,[1,,1] + POPJ P, + +PI2: 1.57079632 + MFUNCTION IEXP,SUBR,[EXP] + PUSHJ P,ARGCHK ;LEAVE FLOATING POINT ARG IN B + PUSHJ P,IIEXP + JRST FINIS + +CEXP: PUSHJ P,CARGCH + +IIEXP: PUSH P,B + MOVM A,B + SETZM B + FMPR A,[0.434294481] ;LOG BASE 10 OF E + MOVE D,[1.0] + CAMG A,D + JRST RATEX + MULI A,400 + ASHC B,-243(A) + CAILE B,43 + JRST OUTRNG + CAILE B,7 + JRST EXPR2 +EXPR1: FMPR D,FLOAP1(B) + LDB A,[103300,,C] + SKIPE A + TLO A,177000 + FADR A,A +RATEX: MOVEI B,7 + SETZM C +RATEY: FADR C,COEF2-1(B) + FMPR C,A + SOJN B,RATEY + FADR C,[1.0] + FMPR C,C + FMPR D,C + MOVE B,[1.0] + SKIPL (P) ;SKIP IF INPUT NEGATIVE + SKIPN B,D + FDVR B,D + MOVSI A,TFLOAT + SUB P,[1,,1] + POPJ P, + +EXPR2: LDB E,[030300,,B] + ANDI B,7 + MOVE D,FLOAP1(E) + FMPR D,D ;TO THE 8TH POWER + FMPR D,D + FMPR D,D + JRST EXPR1 + +COEF2: 1.15129278 + 0.662730884 + 0.254393575 + 0.0729517367 + 0.0174211199 + 2.55491796^-3 + 9.3264267^-4 + +FLOAP1: 1.0 + 10.0 + 100.0 + 1000.0 + 10000.0 + 100000.0 + 1000000.0 + 10000000.0 + +;LSH AND ROT (ERB WOULD BE PLEASED) PDL 2/22/79 + +MFUNCTION %LSH,SUBR,LSH + ENTRY 2 + MOVE C,[LSH B,(A)] + JRST LSHROT + +MFUNCTION %ROT,SUBR,ROT + ENTRY 2 + MOVE C,[ROT B,(A)] +LSHROT: GETYP A,(AB) + PUSHJ P,SAT + CAIE A,S1WORD + JRST WRONGT + GETYP A,2(AB) + CAIE A,TFIX + JRST WTYP2 + MOVE A,3(AB) + MOVE B,1(AB) + XCT C + MOVE A,$TWORD + JRST FINIS + +;BITWISE BOOLEAN FUNCTIONS + +MFUNCTION %ANDB,SUBR,ANDB + ENTRY + HRREI B,-1 ;START ANDING WITH ALL ONES + MOVE D,[AND B,A] ;LOGICAL INSTRUCTION + JRST LOGFUN ;DO THE OPERATION + +MFUNCTION %ORB,SUBR,ORB + ENTRY + MOVEI B,0 + MOVE D,[IOR B,A] + JRST LOGFUN + +MFUNCTION %XORB,SUBR,XORB + ENTRY + MOVEI B,0 + MOVE D,[XOR B,A] + JRST LOGFUN + +MFUNCTION %EQVB,SUBR,EQVB + ENTRY + HRREI B,-1 + MOVE D,[EQV B,A] + +LOGFUN: JUMPGE AB,ZROARG +LOGTYP: GETYP A,(AB) ;GRAB THE TYPE + PUSHJ P,SAT ;STORAGE ALLOCATION TYPE + CAIE A,S1WORD + JRST WRONGT ;WRONG TYPE...LOSE + MOVE A,1(AB) ;LOAD ARG INTO A + XCT D ;DO THE LOGICAL OPERATION + AOBJP AB,.+2 ;ADD ONE TO BOTH HALVES + AOBJN AB,LOGTYP ;ADD AGAIN AND LOOP IF NEEDED + +ZROARG: MOVE A,$TWORD + JRST FINIS + REPEAT 0,[ +;routine to sort lists or vectors of either fixed point or floating numbers +;the components are interchanged repeatedly to acheive the sort +;first arg: the structure to be sorted +;if no second arg sort in descending order +;second arg: if false then sort in ascending order +; else sort in descending order + +MFUNCTION SORT,SUBR + ENTRY + HLRZ A,AB + CAIGE A,-4 ;Only two arguments allowed + JRST TMA + MOVE O,DESCEND ;Set up "O" to test for descending order as default condition + CAIE A,-4 ;Optional second argument? + JRST .+4 + GETYP B,TYP2 ;See if it is other than false + CAIN B,TFALSE + MOVE O,ASCEND ;Set up "O" to test for ascending order + GETYP A,TYP1 ;CHECK TYPE OF FIRST ARGUMENT + CAIN A,TLIST + JRST LSORT + CAIN A,TVEC + JRST VSORT + JRST WTYP1 + + + + +GOBACK: MOVE A,TYP1 ;RETURN THE SORTED ARGUMENT AS VALUE + MOVE B,VAL1 + JRST FINIS + +DESCEND: CAMG C,(A)+1 +ASCEND: CAML C,(A)+1 + ;ROUTINE TO SORT LISTS IN NUMERICAL ORDER + +LSORT: MOVE A,VAL1 + JUMPE A,GOBACK ;EMPTY LIST? + HLRZ B,(A) ;TYPE OF FIRST COMPONENT + CAIE B,TFIX + CAIN B,TFLOAT + SKIPA + JRST WRONGT + MOVEI E,0 ;FOR COUNT OF LENGTH OF LIST +LCOUNT: JUMPE A,LLSORT ;REACHED END OF LIST? + MOVE A,(A) ;NEXT COMPONENT + TLZ A,(B) ;SAME TYPE AS FIRST COMPONENT? + TLNE A,-1 + JRST WRONGT + AOJA E,LCOUNT ;INCREMENT COUNT AND CONTINUE + +LLSORT: SOJE E,GOBACK ;FINISHED WITH SORTING? + HRRZ A,VAL1 ;START THIS LOOP OF SORTING AT THE BEGINNING + MOVEM E,(P)+1 ;Save the iteration depth +CLSORT: HRRZ B,(A) ;NEXT COMPONENT + MOVE C,(B)+1 ;ITS VALUE + XCT O ;ARE THESE TWO COMPONENTS IN ORDER? + JRST .+4 + MOVE D,(A)+1 ;INTERCHANGE THEM + MOVEM D,(B)+1 + MOVEM C,(A)+1 + MOVE A,B ;MAKE THE COMPONENT IN "B" THE CURRENT ONE + SOJG E,CLSORT + MOVE E,(P)+1 ;Restore the iteration depth + JRST LLSORT + ;ROUTINE TO SORT VECTORS IN NUMERICAL ORDER + +VSORT: HLRE D,VAL1 ;GET COUNT FIELD OF VECTOR + IDIV D,[-2] ;LENGTH + JUMPE D,GOBACK ;EMPTY VECTOR? + MOVE E,D ;SAVE LENGTH IN "E" + HRRZ A,VAL1 ;POINTER TO VECTOR + MOVE B,(A) ;TYPE OF FIRST COMPONENT + CAME B,$TFIX + CAMN B,$TFLOAT + SKIPA + JRST WRONGT + SOJLE D,GOBACK ;IF ONLY ONE COMPONENT THEN FINISHED +VCOUNT: ADDI A,2 ;CHECK NEXT COMPONENT + CAME B,(A) ;SAME TYPE AS FIRST COMPONENT? + JRST WRONGT + SOJG D,VCOUNT ;CONTINUE WITH NEXT COMPONENT + +VVSORT: SOJE E,GOBACK ;FINISHED SORTING? + HRRZ A,VAL1 ;START THIS LOOP OF SORTING AT THE BEGINNING + MOVEM E,(P)+1 ;Save the iteration depth +CVSORT: MOVE C,(A)+3 ;VALUE OF NEXT COMPONENT + XCT O ;ARE THESE TWO COMPONENTS IN ORDER? + JRST .+4 + MOVE D,(A)+1 ;INTERCHANGE THEM + MOVEM D,(A)+3 + MOVEM C,(A)+1 + ADDI A,2 ;UPDATE THE CURRENT COMPONENT + SOJG E,CVSORT + MOVE E,(P)+1 ;Restore the iteration depth + JRST VVSORT +] + +MFUNCTION OVERFLOW,SUBR + + ENTRY + + MOVEI E,OVFLG + JRST FLGSET + + +MFUNCTION TIME,SUBR + ENTRY + PUSHJ P,CTIME + JRST FINIS + +IMPURE + +RHI: 267762113337 +RLOW: 155256071112 +OVFLG: -1 +PURE + + +END + \ No newline at end of file diff --git a//assem.all.7 b//assem.all.7 new file mode 100644 index 0000000..c155adb --- /dev/null +++ b//assem.all.7 @@ -0,0 +1,115 @@ +LOGIN CLRt +CONN INT: +MIDAS +AGC BIN_AGC MID +RESET MIDAS +MIDAS +AGCMRK BIN_AGCMRK MID +RESET MIDAS +MIDAS +AMSGC BIN_AMSGC MID +RESET MIDAS +MIDAS +ARITH BIN_ARITH MID +RESET MIDAS +MIDAS +ATOMHK BIN_ATOMHK MID +RESET MIDAS +MIDAS +BUFMOD BIN_BUFMOD MID +RESET MIDAS +MIDAS +CORE BIN_CORE MID +RESET MIDAS +MIDAS +CREATE BIN_CREATE MID +RESET MIDAS +MIDAS +DECL BIN_DECL MID +RESET MIDAS +MIDAS +EVAL BIN_EVAL MID +RESET MIDAS +MIDAS +FOPEN BIN_FOPEN MID +RESET MIDAS +MIDAS +GCHACK BIN_GCHACK MID +RESET MIDAS +MIDAS +INITM BIN_INITM MID +RESET MIDAS +MIDAS +INTERR BIN_INTERR MID +RESET MIDAS +MIDAS +IPC BIN_IPC MID +RESET MIDAS +MIDAS +LDGC BIN_LDGC MID +RESET MIDAS +MIDAS +MAIN BIN_MAIN MID +RESET MIDAS +MIDAS +MAPPUR BIN_MAPPUR MID +RESET MIDAS +MIDAS +MAPS BIN_MAPS MID +RESET MIDAS +MIDAS +MUDEX BIN_MUDEX MID +RESET MIDAS +MIDAS +MUDITS BIN_MUDITS MID +RESET MIDAS +MIDAS +MUDSQU BIN_MUDSQU MID +RESET MIDAS +MIDAS +NFREE BIN_NFREE MID +RESET MIDAS +MIDAS +PRIMIT BIN_PRIMIT MID +RESET MIDAS +MIDAS +PRINT BIN_PRINT MID +RESET MIDAS +MIDAS +PURE BIN_PURE MID +RESET MIDAS +MIDAS +PUTGET BIN_PUTGET MID +RESET MIDAS +MIDAS +PXCORE BIN_PXCORE MID +RESET MIDAS +MIDAS +READCH BIN_READCH MID +RESET MIDAS +MIDAS +READER BIN_READER MID +RESET MIDAS +MIDAS +SAVE BIN_SAVE MID +RESET MIDAS +MIDAS +SPECS BIN_SPECS MID +RESET MIDAS +MIDAS +STBUIL BIN_STBUIL MID +RESET MIDAS +MIDAS +STENEX BIN_STENEX MID +RESET MIDAS +MIDAS +TMUDV BIN_TMUDV MID +RESET MIDAS +MIDAS +TXPURE BIN_TXPURE MID +RESET MIDAS +MIDAS +UTILIT BIN_UTILIT MID +RESET MIDAS +MIDAS +UUOH BIN_UUOH MID diff --git a//atomhk.bin.6 b//atomhk.bin.6 new file mode 100644 index 0000000..dd39638 Binary files /dev/null and b//atomhk.bin.6 differ diff --git a//atomhk.bin.7 b//atomhk.bin.7 new file mode 100644 index 0000000..9925a39 Binary files /dev/null and b//atomhk.bin.7 differ diff --git a//atomhk.mid.144 b//atomhk.mid.144 new file mode 100644 index 0000000..1d1855c --- /dev/null +++ b//atomhk.mid.144 @@ -0,0 +1,1185 @@ + +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 + + ; 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 + ; 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 + + ; 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 + +; 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 + + +;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 + ;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 + + ;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, + + ; 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 + ;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, + + ;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 + + +; 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 diff --git a//atomhk.mid.149 b//atomhk.mid.149 new file mode 100644 index 0000000..1fe87fa --- /dev/null +++ b//atomhk.mid.149 @@ -0,0 +1,1193 @@ + +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 + + ; 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 + ; 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 + + ; 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 + +; 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 + + +;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 + ;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 + + ;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, + + ; 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 + ;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, + + ;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 + + +; 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 diff --git a//atomhk.mid.150 b//atomhk.mid.150 new file mode 100644 index 0000000..3bb9765 --- /dev/null +++ b//atomhk.mid.150 @@ -0,0 +1,1198 @@ + +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 + + ; 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 + ; 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 + + ; 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 + +; 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 + + +;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 + ;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 + + ;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, + + ; 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 + ;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, + + ;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 + + +; 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 diff --git a//bufmod.bin.2 b//bufmod.bin.2 new file mode 100644 index 0000000..100f02e Binary files /dev/null and b//bufmod.bin.2 differ diff --git a//bufmod.mid.4 b//bufmod.mid.4 new file mode 100644 index 0000000..0d96216 --- /dev/null +++ b//bufmod.mid.4 @@ -0,0 +1,18 @@ +TITLE BUFMOD BUFFER MODULE + +RELOCA + +; HERE TO DEFINE MUDDLES BUFFER SPACE + +.GLOBAL STRBUF,STRPAG + +HERE==$.+1777 + +.LOP ANDCM HERE 1777 + +STRBUF==.LVAL1 +.LOP STRBUF <,-10.> +STRPAG==.LVAL1 + +END +  \ No newline at end of file diff --git a//chess.script.1 b//chess.script.1 new file mode 100644 index 0000000..6d925a2 --- /dev/null +++ b//chess.script.1 @@ -0,0 +1,171 @@ +%% 30 December 1980 23:47:54 +Type ? for help. +White to move: p-k4 +Black to move: pb +1. ... P-K4 ; (1.0 85%) +White to move: p-q3 +2. ... P-Q4 ; (1.7 93%) +White to move: n-kb4 +; Impossible +White to move: n-kb3 +; T-reject B-Q3 +3. ... N-QB3 ; (3.8 91%) +White to move: b-k2 +4. ... P-Q5 ; (3.0 94%) +White to move: o-o +; T-reject N-QN5 +5. ... B-Q3 ; (6.9 94%) +White to move: p-qb3 +; Foo! +6. ... PxP ; (3.0 91%) +White to move: nxp(qb3) +; T-reject N-Q5 +7. ... B-QN5 ; (8.3 88%) +White to move: b-n5 +8. ... N-KB3 ; (3.4 91%) +White to move: p-qr3 +9. ... B-QB4 ; (5.1 95%) +White to move: p-qn4 +10. ... B-QN3 ; (5.4 92%) +White to move: q-r4 +11. ... O-O ; (4.4 92%) +White to move: p-n5 +; T-reject N-Q5 N-QR4 N-QN1 ... +; Foo! +12. ... N-Q5 ; (11.6 90%) +White to move: r-k1 +; Ambiguous +White to move: r(b1)-k1 +13. ... NxB+ ; (3.9 94%) +White to move: rxn +14. ... QxP ; (4.6 77%) +White to move: q-b2 +15. ... Q-Q3 ; (6.3 87%) +White to move: r-q1 +; T-reject QxP +16. ... Q-QB4 ; (9.5 91%) +White to move: r(k2)-q2 +; T-reject QxP(QR6) +17. ... B-QR4 ; (7.0 92%) +White to move: r-q8 +18. ... QxN ; (6.1 95%) +White to move: qxq +19. ... BxQ ; (3.5 92%) +White to move: b-k3 +20. ... NxP ; (5.4 90%) +White to move: nxp +21. ... BxN ; (4.5 91%) +White to move: p-b3 +22. ... N-QB6 ; (4.6 95%) +White to move: r-q2 +; Ambiguous +White to move: r(q1)-q2 +; T-reject NxP +; M-reject RxR +23. ... NxP ; (6.3 86%) +White to move: b-b5 +; M-reject RxR +24. ... B-Q3 ; (19.7 91%) +White to move: bxb +25. ... RxR ; (2.8 92%) +White to move: u +Black to move: u +White to move: rxr +Black to move: pb +25. ... BxR ; (1.6 95%) +White to move: bxb +26. ... KxB ; (2.2 94%) +White to move: r-q8 +27. ... K-K2 ; (0.0 92%) +White to move: r-r8 +28. ... NxP ; (1.6 94%) +White to move: rxp +29. ... P-KN4 ; (3.2 91%) +White to move: r-r6 +30. ... R-QN1 ; (1.9 90%) +White to move: k-b2 +31. ... K-Q2 ; (3.2 89%) +White to move: r-b6 +; Ambiguous +White to move: r-kb6 +32. ... K-K2 ; (1.6 93%) +White to move: r-b5 +33. ... BxR ; (1.4 96%) +White to move: u +Black to move: u +White to move: r-r6 +; Ambiguous +White to move: r-kr6 +Black to move: pb +33. ... K-Q2 ; (3.2 95%) +White to move: k-k3 +34. ... P-QB4 ; (5.0 91%) +White to move: k-q3 +35. ... K-QB2 ; (1.8 88%) +White to move: k-b3 +36. ... P-QB5 ; (2.2 87%) +White to move: k-n4 +; T-reject N-QN8 N-QB7+ +; Foo! +37. ... N-QN8 ; (3.2 88%) +White to move: kxp +38. ... P-QN4+ ; (1.8 96%) +White to move: k-n4 +; T-reject K-QN2 R-QR1 +39. ... P-KB4 ; (3.4 92%) +White to move: r-kn6 +40. ... P-KN5 ; (2.0 76%) +White to move: pxp +41. ... PxP ; (1.8 95%) +White to move: r-n7 +42. ... K-QN3 ; (1.2 96%) +White to move: r-b7 +; Ambiguous +White to move: r-kb7 +43. ... R-QR1 ; (2.3 95%) +White to move: r-b1 +44. ... N-Q7 ; (2.4 85%) +White to move: r-q1 +45. ... N-K5 ; (3.7 72%) +White to move: p-r3 +46. ... PxP ; (2.7 95%) +White to move: pxp +47. ... BxP ; (2.5 90%) +White to move: r-q3 +48. ... N-KB7 ; (4.4 87%) +White to move: rq-6 +; Move what?? +White to move: r-q6 +; T-reject K-QB2 K-QN2 +; Foo! +49. ... K-QB2 ; (2.2 85%) +White to move: r-kr6 +50. ... P-QR3 ; (2.3 92%) +White to move: r-r7 +51. ... K-QN3 ; (1.4 95%) +White to move: r-kb7 +52. ... N-K5 ; (5.0 93%) +White to move: r-b5 +53. ... BxR ; (2.0 92%) +White to move: u +Black to move: u +White to move: r-b4 +Black to move: pb +53. ... N-Q7 ; (4.6 95%) +White to move: r-b6 +54. ... K-QN2 ; (1.3 88%) +White to move: k-r5 +55. ... N-K5 ; (2.9 94%) +White to move: r-b7 +56. ... K-QB3 ; (1.0 95%) +White to move: r-r7 +; Ambiguous +White to move: r-kr7 +57. ... N-KN4 ; (2.8 93%) +White to move: r-r5 +; T-reject N-KB6 N-K5 N-K3 ... +; Foo! +58. ... R-KN1 ; (4.4 85%) +White to move: kxp +59. ... R-QR1+ ; (0.7 8%) +; Checkmate. diff --git a//chkdcl.mud.2 b//chkdcl.mud.2 new file mode 100644 index 0000000..452a57c --- /dev/null +++ b//chkdcl.mud.2 @@ -0,0 +1,1319 @@ + + + + + + + + + + + + + + + + + + + + + + +> + + <==? .D NO-RETURN>> ANY) + ( > .D) + ( ATOM> >> + > + .TEM) + ( + + ANY> >>) + (<==? <1 .D> FIX> FIX) + ( 2> <==? <1 .D> NOT>> ANY) + ( + SEGMENT>) + (ELSE FORM>)>) + ( + [ OPT> OPTIONAL) (ELSE <1 .D>)> + !>]) + (ELSE .D)>> + + + <==? 2> + LIST>> + + <==? 2> + LIST>> + <> T>> + >) + (<=? .P1 '> .P2) + (<=? .P2 '> .P1) + (ELSE .P2>) FORM>)>> + + <>>> + + <> <>>> + +>) + > + +> + > + .PAT1) + (> ATOM> >) + (> ATOM> ) + ( > + ) + (ELSE #FALSE (BAD-SYNTAX!-ERRORS))>> + + + + > + .X> + > + .X>> + +) + > >>>> + + + > + > + .TYP> + + >>) + ( ) + (ELSE #FALSE (BAD-SYNTAX!-ERRORS))>> + + > .TYP> > + > .PAT> + >>>>> + +" " + +) + #FALSE (EMPTY-TYPE-FORM!-ERRORS)) + ( '![OR AND NOT PRIMTYPE!]> ) + ( QUOTE> <2-ELEM .FORT>> + > .PAT>) + (ELSE )>> + +) TEM1) + #DECL ((FORT) ) + + >> + #FALSE (EMPTY-OR-MATCH!-ERRORS)) + (ELSE + > ATOM> + ) + (> + + >) + (ELSE T)>> + >> + >>> + + )> + >) + (ELSE + + >)>)>) + (ELSE )>)>) + (> )> + >> + > + > <1 .AL>) + (ELSE + >)>>>)>>)>) + (<==? .ACTOR NOT> ) + (ELSE )>> + + + <==? <1 .FORTYP> PRIMTYPE>> + ) + (ELSE #FALSE (BAD-SYNTAX!-ERRORS))>) + ( ) + (ELSE #FALSE (BAD-SYNTAX!-ERRORS))>> + +" " + + + <>) + (<==? .TYP APPLICABLE> + ) + (ELSE + ')>>) + ( + + '![LIST VECTOR UVECTOR TEMPLATE STRING TUPLE + STORAGE BYTES!]>>)>) + (<==? .WRD LOCATIVE> + ) + (<==? .WRD APPLICABLE> + >) + (<==? .TYP STRUCTURED> + >) + ()>)> + ) + (ELSE + > >) + (ELSE <>)>)>>> + + + (PTYP) >) + + + <==? 2> + <==? <1 .PAT1> PRIMTYPE>> + <2 .PTYP>> .PAT1) + (ELSE >)>)>) + ( + ) + ( + T> + ) + (ELSE >)>)>) + ( + <==? <2 .PTYP>> + >) + (ELSE >)>)>) + ( + + >> + > OR> ) + (<==? .ACTOR NOT> + ) + (ELSE + >> + > .PTYP) + ( .TEM) + ( ANY)>)>) + (>> + +
>) + (ELSE + ) SEGMENT>)>) + (ELSE T)>)>)>> + +" " + +) + + > + OR> <==? <1 .PAT> AND>>> + ) + (ELSE + 2> + .PAT>>> + ) + (<==? <2 .NF> ANY> ) + ( + + + >> + ANY) (ELSE T)>) + (.ORF ANY)>) + (ELSE #FALSE (BAD-SYNTAX!-ERRORS))>)>> + + + <==? 2> + <==? <1 .D> NOT>> + <2 .D>) + (ELSE )>> +" " + + > + (RPAT) ) + ATOM> <==? <1 .FRM> .RPAT>> + ) + (ELSE + >>) + (ELSE >)> + + <> <> T>>> + >) + (ELSE + ATOM> .PAT>) + ( FORM> .PAT>)>)>> + .TEM> + ) FORM>) + (ELSE ) SEGMENT>)>) + (ELSE .TEM)>) + ( + '![OR AND NOT PRIMTYPE!]> ) + (ELSE + 2> LIST>> + ) + ( 2> FIX>> + ) + ( 2> FIX>> + >) + ( + <> T>>> + >) + ( <> T>>> + >) + (ELSE + > + + + 1> + <==? <1 .TEM> OR> + + .EX> + + >> + >> + .TEM)>)>)>)>> + +" " + + (MLF1 MLF2) FIX) + > + > #FALSE (EMPTY-FORM-IN-DECL!-ERRORS))> + + ATOM> .RPAT>) + ( FORM> .RPAT>) + (ELSE #FALSE (BAD-SYNTAX!-ERRORS))>) + ( >) + (ELSE #FALSE (BAD-SYNTAX!-ERRORS))>> + .FST) + (ELSE + <> <> <>> + > + > + 2> FIX>> + ' <> <> <>> + <2 .F1>> + >) + (ELSE >)>) + ( <2 .F1>> + + + <2 .F2>>>>> + >)>) + (ELSE #FALSE (BAD-SYNTAX!-ERRORS))>) + (> + + + '[REST FIX]>) + (ELSE + + [.MLF1 FIX] + '[REST FIX]>)>>> + ) + (ELSE >)>) + ( + ) + (ELSE + )>> + >)>) + (ELSE >) (ELSE <>)>)>) + (ELSE #FALSE (BAD-SYNTAX!-ERRORS))>)>> + +)) + ) SEGMENT>) + (ELSE ) FORM>)>> + + >) + (ELSE >)>> + +) + >> + >>> + #FALSE (EMPTY-FORM-IN-DECL!-ERRORS))> + + ATOM> .RPAT>) + ( FORM> .RPAT>) + (ELSE #FALSE (BAD-SYNTAX!-ERRORS))>) + ( >) + (ELSE #FALSE (BAD-SYNTAX!-ERRORS))>> + .FST) + (ELSE + <> <>> + LIST>> + ,ALLWORDS <> <><>> + !<2 .F2>>> + .FST) + (ELSE )>) + ( <2 .F2>>> + )>) + (ELSE #FALSE (BAD-SYNTAX!-ERRORS))>) + (ELSE >) (ELSE <>)>)>) + (ELSE #FALSE (BAD-SYNTAX!-ERRORS))>)>> + +) (LOW <1 .PAIRS>)) + #DECL ((PAIRS) (HIGH LOW) FIX) + >> )> + >> + >>> + FIX>> + <==? .LOW FIX>>> + ()) + (ELSE (.LOW .HIGH))>> + + +) HIGH LOW TEM (L (0)) (LL .L)) + #DECL ((L LL L1 L2) (HIGH LOW) FIX) + > + + + )> + > + > + (LO HI) FIX) + )> + > + > .LOW> + > + > + > + >> + > + > + 2>> + + )> + >> + >> + ) (ELSE <>)>>)>>> + +" " + + + + LIST>> + >>>> .TT)>)>> + +" " + + 0 <> <> '[]>) (FAIL <>) (INOPT <>) + (S2 0 <> <> '[]>) (FL ()) (FP '<>) FSTL + SEGF RTEM) + #DECL ((S1 S2) ANY FIX ANY ANY ANY> + (F1 F2) (FP) (FL) LIST) + > + > #FALSE (EMPTY-FORM-IN-DECL!-ERRORS)) + ( .RTYP>>> >) + (ELSE + + ATOM> >) + ( FORM> .RTYP>) + (ELSE #FALSE (BAD-SYNTAX!-ERRORS))>) + ( >) + (ELSE #FALSE (BAD-SYNTAX!-ERRORS))>> + ) + (ELSE )>> + LIST>>)> + > + > + ) (TEM2 <>) T1 T2 TEM TT) + #DECL ((TT) ) + >> + > >> + >> + > >> + >>> + >> + <1 .FP>) (ELSE .FP)>>)> + + > + .T2) + (ELSE <>)>) + ( + > + .T1) + (ELSE <>)>) + (ELSE )>>> + >>) + (.MAYBEF >) (ELSE )>) + (ELSE >)>> + + + >> + + + >>> + >) + ( + 1>> (.TEM)>)> + > + <0? >>> + > + <0? >>>> + > + >)> + >> + >>>> + + >>> + + >>>>> + + >>> + + <1 .FP>) + (ELSE .FP)>>) + (ELSE + + > + <1 .T1>) + (ELSE .T1)>>)>) + (>>> + + <1 .FP>) + (ELSE .FP)>>) + (ELSE + + > + <1 .T1>) + (ELSE .T1)>>)>)>) + (ELSE )>) + ( + > + >> + )> + + .ANDF + + >>>> + VECTOR> + <=? <2 >> .TEM>> + 1>>) + ( .FL> <=? .TEM <1 .FL>>> + ) + (ELSE >>)>)>) + (ELSE + >> + <1 .FP>) (ELSE .FP)>>) + (ELSE )>) + (ELSE )>)>>)>)>> + +" " + +) (TEM1 T) (TEM2 T) (OPTIT <>)) + #DECL ((S1 S2) (FL) + (TT) VECTOR) + > + > >> + )> + > + >>> T) + (> + > + >>>>>> + >> + + ) + > > + + ) (ELSE ANY)>>>> + > + > + > + > + >)> + + > .T1>>>)> + > >> + ]> 2>> + ) + (ELSE >)> + T) + ( >> .TEM1) + (ELSE .TEM2)>) + (ELSE 0)>> + +)) + #DECL ((V) ) + + )>> + >) + (ELSE [REST .FRST])>> + + + ANY FIX ANY ANY ANY> (N) FIX + (TT) VECTOR) + > >)> + ) + (>> + 1>> + ) + (>> <>) + ( ATOM FORM SEGMENT> + > + >> + ) + ( VECTOR> + > + >> + > + 1> + REST> + 2> + <==? <2 .TT> ANY>> + <>) + (ELSE + + >)>) + ( FIX> >> + '![OPT OPTIONAL!]> + >> + FIX> + > + 1>> 1>> + > + <>) (ELSE .S)>) + (#FALSE (BAD-VECTOR-SYNTAX!-ERRORS))>) + (ELSE #FALSE (BAD-FORM-SYNTAX!-ERRORS))>) + (ELSE #FALSE (BAD-FORM-SYNTAX!-ERRORS))>> + +" " + +>)) + #DECL ((S) (TEM) VECTOR) + >>)> + + >> +" " + +) (PT <>) + "AUX" (LN 0) (CNT 0) ITYP DC SDC DCL (N 0) DC1 (QOK <>) + (FMOK <>) STRU (GD '<>) (GP ()) (K 0) (DCL1 .DCL2) + (SEGF <>) TEM) + #DECL ((LN CNT K N) FIX (DCL) (SDC DC) VECTOR + (GD) (GP) LIST) + >> + .PT>>)> + >> + )> + BYTES> + >)> + ) (ELSE STRUCTURED)>>) + (.PT + ) + (> ) + (ELSE STRUCTURED)>>)> + + + > 1> + '![OR AND NOT!]>>> + QUOTE>>> + PRIMTYPE>>> + + > LIST>>> + > VECTOR> + + 2> + <==? <1 .DC> REST> + 2> + ]>) + (.PT .PT>]>) + (ELSE <2 .DC>)>) + (.RST >]>) + (.PT + > + >]>) + (ELSE >)>> + >>) (D .DCL) TEM) + #DECL ((D) ) + >> + <==? <1 .TT> REST>>>> + ) + (.PT .GD) + (ELSE .CK)>) + (.PT .GD) + (.RST .STRU) + (ELSE ANY)>>)> + >>>> + + [<1 .TT> + !> + >]) + (ELSE + )>)>>>>>>) + (ELSE + + > LIST>>> + >> + >> + > .PT>) + (ELSE ANY)>>)> + > + >> + > + >> + >> + > .PT)> + .GD) + (ELSE ANY)>>) + (ELSE )>>)> + >) + ( ATOM FORM SEGMENT> + > + >) + (> VECTOR> + + REST> + >> .PT> + <==? 2 > + <=? <2 .DC> '> + >> + <- 1>>> + <- 1>>> + .DC) + (ELSE [REST >])>>) + (.PT + ()) + (<1? .N> (!)) + (ELSE ([.N !]))> + !> -1> .PT) + (ELSE .O)>> + > + .DC)> + .GD) + (ELSE >)>>) + ( FIX> <==? <1 .DC> OPT> <==? <1 .DC> OPTIONAL>> + FIX> <1 .DC>) (ELSE 1)>> + + )>)> + >> + <0? .CNT>> .STRU) + ( (.ITYP !.DCL)) + (> + >> + (!.SDC !)) + (ELSE + (!.SDC + [.CNT !] + !))>) + (ELSE ([.CNT !.SDC] !))>>)>) + (.PT + >> + >> + <0? .CNT>> .GD) + ( + <==? .SDC >>> + .DCL) + (<==? .SDC > + ([.CNT !] !)) + (> 0> + (!.SDC !)) + (ELSE + (!.SDC + [.CNT !] + !))>> + .GD)>) + (ELSE .ITYP)>>> + <=? .ITYP '> >> + >>> + + > .PT)> + .GD) + (ELSE ANY)>>)>>)>) + (.QOK >> ) + ( OR>> + > + > + .IT) + (ELSE )>> + >) + ( AND>> + + + >>> + > + .ITYP) + (.RST ) (ELSE STRUCTURED)>) + (.PT + .DCL1) + (ELSE > .PT>)>) + (ELSE ANY)>>> + +" " + +) + .DCL) + (>)>) + (.RST + >) + (> ) + (ELSE .N>>)> + > ) + (ELSE BYTES)>) + (ELSE FIX)>> + +> STRING> 7) + ( 2> + > FIX>> + .TEM)>> + +) (ANDOK <>) TT (OROK <>)) + #DECL ((N VALUE LN) FIX (DC) (D) VECTOR) + >> + + + 1> + > PRIMTYPE> + >> + >> + >> + > + > + > FIX>> + > + > + 2> FIX>> + <2 .DC>) + (ELSE 0)>) + (ELSE + > VECTOR> + + 1>> + '[REST OPT OPTIONAL]> ) + ( FIX> + > + 1>>>>) + (ELSE )>) + ( >) + (ELSE )> + >> >>)>) + ( ,MINL > + FIX>) + (.QOK > >) (ELSE 0)>) + ( 0) + (ELSE )>> + +> + + >) + ( + ) + ( FORM> <>>)>)>> + +)) + #DECL ((FRM) (LN) FIX) + + > PRIMTYPE> + > ATOM> + + >>) + (<==? .TEM QUOTE> >) + (<==? .TEM NOT> <>)>>) + (> + > OR> + + + .TEM>>> > + > .TEM)>) + (<==? .TEM AND> + + > )>> + > + .TEM) + ( > + )>)>> + +" " + +> + <==? .T1 >>> + +)) + > + '![BYTES STRING LOCD TUPLE FRAME!]>> + .TYP>> + + > + >> + >)> + .TYP) + ( >> + > OR> + >) + (<==? .TT NOT> ANY) + (<==? .TT QUOTE> >) + (<==? .TT PRIMTYPE> .TYP) + (ELSE .TT)>)>> + +) "AUX" TY) + >>> + + 2> <==? <1 .TYP> QUOTE>> + >>) + (<==? <1 .TYP> OR> + >>> + + > + >>)>> + >) + (ELSE >)>)> + + .TYP) + (> )>>>> + + + + >> 2> + <2 .TT>) + (ELSE >)>>) + (ELSE .IT)>> + +"DETERMINE IF A TYPE PATTERN REQUIRES DEFERMENT 0=> NO 1=> YES 2=> DONT KNOW " + +" " + + + + > + '![STRING TUPLE LOCD FRAME BYTES!]> + 1) + (ELSE 0)>) + (> ) + (ELSE 2)>) + ( >> + > QUOTE> >>) + (<==? .TEM PRIMTYPE> >) + ( >>> + >> + + .STATE> >> + > + .STATE) + (<==? .TEM NOT> 2) + (<==? .TEM AND> + + + > 2> + )>> + > + .STATE) + (ELSE >)>) + (ELSE 2)>>> + +" Define a decl for a given quoted object for maximum winnage." + +" " + + > ) + (<==? BYTES> + ) SEGMENT>) + (ELSE + >) (CNT 1) + (FRM ) SEGMENT>) (FRME .FRM) TT T1) + #DECL ((CNT) FIX (FRME) < ANY>) + >> + + >>) + (ELSE >>)> + ) + (>> .DC> .DC> + >) + (ELSE + + >>) + (ELSE >>)> + + )>>)>> + +" " + + + > OR> <==? .TT AND>> + )) + + ) + (ELSE )>) + (ELSE .IT)>> + >) + FORM>> + > ANY) + (> <2 .TT>) + (ELSE .TT)>) + (<==? .TT NOT> ANY) + (<==? BYTES> + + .DC) + (<==? 2> + ) + ( <+ FIX> .N>>)>) + (<==? .TT PRIMTYPE> + .DC) + (ELSE ) FORM>)>) + (ELSE + > ) + (ELSE STRUCTURED)> + ! + !>)>) + (> + + <==? .TEM BYTES>> ) + (ELSE !) FORM>)>) + (ELSE + STRUCTURED) + (ELSE ) FORM>)>)>> + + ()) (<1? .N> (ANY)) (ELSE ([.N ANY]))>> + +" TYPE-OK? are two type patterns compatible. If the patterns + don't parse, send user a message." + + <==? .P2 NO-RETURN>> NO-RETURN) + (> .TEM) + ( .TEM) + (ELSE " " .P1 " " .P2>)>> + +" TYPE-ATOM-OK? does an atom's initial value agree with its DECL?" + + + >> + +" Merge a group of type specs into an OR." + +" " + + <>) + (ELSE + )) + >> )> + NO-RETURN> .ORS) + (<==? .ORS NO-RETURN> <1 .TYPS>) + (ELSE >)>>>)>> + + (VALUE) LIST) + + > + <==? <1 .ELE> OR>> + >>) + (ELSE )> + .L1) + ( .L1> + .L1>> + >) + (ELSE >)> + )> + >>> + >>> + .TT) + (ELSE .L1)>> + .LST>> + .LST) + (ELSE 1>> .LST> .ELE)>>> + +) >>> + +) + > 2> )> + 1>>>>> + + > + > + + + ) + (ELSE )>) + ( + ) + (ELSE )>) + (ELSE + > + > + > + 0>) + ( T) + ( <>) + (ELSE )> + >>) + (ELSE >>)> + + >) + (ELSE >>)>)>>>> +" " + +) (L2 )) + #DECL ((F1 F2) (L1 L2) FIX) + + > 0>) + ()>> + + +> + >> + OR> + >>>) + (<==? <1 .D> QUOTE> >>) + (ELSE )>) + (ELSE .D)>> + + +) SAMCNT TT TEM) + #DECL ((L) (SAMCNT) FIX) + > + !) (LAST >)) + + 2> FIX>> + >> + > + >> + )>) + (ELSE + >) + (ELSE >)> + + > + >) + (ELSE )>) + (.TEM) + (ELSE )>)>) + ( REST> + <==? 2> + <==? <2 .ELE> ANY>> + > + > + ) + (ELSE )>) + (ELSE + >) + (ELSE >)> + >> + OPT> OPTIONAL) (ELSE <1 .ELE>)>> + + >>> + + > + > + ) (ELSE .TT)>)>) + (ELSE + > + > + > + ) (ELSE )>) + (ELSE + >) + (ELSE >)> + + + ) (ELSE .ELE)>) + (.TEM) + (ELSE )>)>)>> + >) + FORM>> + + .X)(ELSE [.N .X])>> + + diff --git a//chkdcl.nbin.2 b//chkdcl.nbin.2 new file mode 100644 index 0000000..6979ad1 Binary files /dev/null and b//chkdcl.nbin.2 differ diff --git a//const.bin.4 b//const.bin.4 new file mode 100644 index 0000000..74fb088 Binary files /dev/null and b//const.bin.4 differ diff --git a//const.mid.5 b//const.mid.5 new file mode 100644 index 0000000..32a0ea4 --- /dev/null +++ b//const.mid.5 @@ -0,0 +1,26 @@ +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 diff --git a//core.bin.4 b//core.bin.4 new file mode 100644 index 0000000..4a82c04 Binary files /dev/null and b//core.bin.4 differ diff --git a//core.mid.13 b//core.mid.13 new file mode 100644 index 0000000..f1f2dbf --- /dev/null +++ b//core.mid.13 @@ -0,0 +1,145 @@ +TITLE CORE + +RELOCATABLE + +.INSRT MUDDLE > + +SYSQ + +IF1,[ +IFE ITS,.INSRT STENEX > +] + +.GLOBAL P.CORE,P.TOP,PHIBOT,PURBOT,FRETOP,SQKIL,GCFLG,KILBUF +.GLOBAL MULTSG + +; .CORE AND .SUSET [.RMEMT,,---] FOR PAGED ENVIRONMENT + +IFN ITS,[ + +P.CORE: PUSH P,0 + PUSH P,A + PUSH P,B + PUSH P,C + PUSH P,D + PUSH P,E + SKIPN GCFLG + PUSHJ P,SQKIL + MOVE A,-4(P) + ASH A,10. ; CHECK IT + CAMLE A,PURBOT ; A CAML HERE IS OBSERVED TO LOSE + FATAL BAD ARG TO GET CORE + MOVE A,-4(P) ; RESTORE A + HRRZ B,P.TOP ; GET FIRST ADDRESS ABOVE TOP + ASH B,-10. ; TO BLOCKS + CAIG A,(B) ; SKIP IF GROWING + JRST P.COR1 + SUBM B,A ; A/ -NUMBER OF BLOCKS TO GET + HRLI B,(A) ; AOBJN TO BLOCKS + + .CALL P.CORU ; TRY + JRST POPBJ ; LOSE + MOVE A,B +P.COR2: ASH B,10. ; TO WORDS + MOVEM B,P.TOP ; NEW TOP +POPBJ1: AOS -6(P) ; SKIP RETURN ON SUCCESS +POPBJ: POP P,E + POP P,D + POP P,C + POP P,B + POP P,A + POP P,0 + POPJ P, + +; HERE TO CORE DOWN + +P.COR1: SUBM A,B + JUMPE B,POPBJ1 ; SUCCESS, YOU ALREADY HAVE WHAT YOU WANT + HRLI A,(B) + MOVEI B,(A) + .CALL P.CORD + JRST POPBJ + JRST P.COR2 + +P.CORU: SETZ + SIXBIT /CORBLK/ + 1000,,100000 + 1000,,-1 + B + 401000,,400001 + +P.CORD: SETZ + SIXBIT /CORBLK/ + 1000,,0 + 1000,,-1 + SETZ A +] + +IFE ITS,[ + +MFORK==400000 + +P.CORE: JRST @[.+1] + ASH A,10. ; CHECK IT + CAMLE A,PURBOT + FATAL BAD ARG TO GET CORE + ASH A,-9. ; TO PAGES + PUSH P,D + PUSH P,A + SKIPN GCFLG + PUSHJ P,SQK + SETOM A ; FLUSH PAGES + HRRZ B,P.TOP ; GET P.TOP + ASH B,-9. ; TO PAGES + CAMLE B,(P) + SOJA B,P.CORD ; CORING DOWN + HRLI B,MFORK ; SET UP FORK POINTER +P.COR2: HRRZ D,B + CAML D,(P) ; SEE IF DONE + JRST P.COR1 + PMAP ; MAP OUT PAGE + ADDI B,1 ; NEXT PAGE + JRST P.COR2 ; LOOP BACK +P.COR1: POP P,A ; RESTORE NEW P.TOP + POP P,D + ASH A,9. ; TO WORDS + MOVEM A,P.TOP + AOS (P) +POPJA: ASH A,-10. + SKIPN MULTSG + POPJ P, + POP P,21 + SETZM 20 + JRST 5,20 + +P.CORD: HRLI B,400000 + PMAP + MOVEI D,-1(B) + CAMLE D,(P) + SOJA B,.-3 + JRST P.COR1 + +SQK: PUSH P,0 + PUSH P,A + PUSH P,B + PUSH P,C + PUSH P,D + PUSH P,E + PUSHJ P,SQKIL + POP P,E + POP P,D + POP P,C + POP P,B + POP P,A + POP P,0 + POPJ P, + +] + +IMPURE + +P.TOP==FRETOP + +PURE + +END diff --git a//create.bin.3 b//create.bin.3 new file mode 100644 index 0000000..2ff15e3 Binary files /dev/null and b//create.bin.3 differ diff --git a//create.mid.40 b//create.mid.40 new file mode 100644 index 0000000..b0f5b48 --- /dev/null +++ b//create.mid.40 @@ -0,0 +1,376 @@ + +TITLE PROCESS-HACKER FOR MUDDLE + +RELOCATABLE + +.INSRT MUDDLE > + +.GLOBAL ICR,NAPT,IGVAL,CHKARG,RESFUN,RETPROC,SWAP,MAINPR,PROCHK,NOTRES +.GLOBAL PSTAT,LSTRES,TOPLEV,MAINPR,1STEPR,INCONS +.GLOBAL TBINIT,APLQ,PVSTOR,SPSTOR + +MFUNCTION PROCESS,SUBR + + ENTRY 1 + GETYP A,(AB) ;GET TYPE OF ARG + ;MUST BE SOME APPLIABLE TYPE + PUSHJ P,APLQ + JRST NAPT ;NO, ERROR - NON-APPLIABLE TYPE +OKFUN: + + MOVEI A,TPLNT/2 ;SMALL STACK PARAMETERS + MOVEI B,PLNT/2 + PUSHJ P,ICR ;CREATE A NEW PROCESS + MOVE C,TPSTO+1(B) ;GET ITS SRTACK + PUSH C,[TENTRY,,TOPLEV] + PUSH C,[1,,0] ;TIME + PUSH C,[0] + PUSH C,SPSTO(B) + PUSH C,PSTO+1(B) + MOVE D,C + ADD D,[3,,3] + PUSH C,D ;SAVED STACK POINTER + PUSH C,[SUICID] + MOVEM C,TPSTO+1(B) ;STORE NEW TP + HRRI D,1(C) ;MAKE A TB + HRLI D,400002 ;WITH A TIME + MOVEM D,TBINIT+1(B) + MOVEM D,TBSTO+1(B) ;SAVE ALSO FOR SIMULATED START + MOVE C,(AB) ;STORE ARG + MOVEM C,RESFUN(B) ;INTO PV + MOVE C,1(AB) + MOVEM C,RESFUN+1(B) + MOVEI 0,RUNABL + MOVEM 0,PSTAT+1(B) + JRST FINIS + +REPEAT 0,[ +MFUNCTION RETPROC,SUBR +; WHO KNOWS WHAT THIS SHOULD REALLY DO +;PROBABLY, JUST AN EXIT +;FOR NOW, PRINT OUT AN ERROR MESSAGE + ERRUUO EQUOTE ATTEMPT-TO-RETURN-OUT-OF-PROCESS + + + + + + + +MFUNCTION RESUME,FSUBR +;RESUME IS CALLED WITH TWO ARGS +;THE FIRST IS A PROCESS FORM OF THE PROCESS TO BE RESUMED +;THE SECOND IS A FUNCTION TO BE CALLED WHEN THIS PROCESS +; (THE PARENT) IS ITSELF RESUMED +;IF THE FUNCTION IS NOT GIVEN SOME STANDARD FUNCTION IS +;PLUGGED IN +; +; NOTE - TYPE AND NUMBER OF ARGS CHECKS MUST BE ADDED TO BOTH RESUME AND CREATE + + ENTRY 1 + HRRZ C,@1(AB) ;GET CDR ADDRESS + JUMPE C,NOFUN ;IF NO SECOND ARG, SUPPLY STANDARD + HLLZ A,(C) ;GET CDR TYPE + CAME A,$TATOM ;ATOMIC? + JRST RES2 ;NO, MUST EVAL TO GET FUNCTION + MOVE B,1(C) ;YES + PUSHJ P,IGVAL ;TRY TO GET GLOBAL VALUE + CAMN A,$TUNBOUND ;GLOBALLY UNBOUND? + JRST LFUN ;YES, TRY FOR LOCAL VALUE +RES1: MOVE PVP,PVSTOR+1 + MOVEM A,RESFUN(PVP) ;STORE IN THIS PROCESS + MOVEM B,RESFUN+1(PVP) + + HRRZ C,1(AB) ;GET CAR ADDRESS + PUSH TP,(C) ;PUSH PROCESS FORM + PUSH TP,1(C) + JSP E,CHKARG ;CHECK FOR DEFERED TYPE + ;INSERT CHECKS FOR PROCESS FORM + MCALL 1,EVAL ;EVAL PROCESS FORM WHICH WILL SWITCH + ; PROCESSES + JRST FINIS + +RES2: PUSH TP,(C) ;PUSH FUNCTION ARG + PUSH TP,1(C) + JSP E,CHKARG ;CHECK FOR DEFERED + MCALL 1,EVAL ;EVAL TO GET FUNCTION + JRST RES1 + +LFUN: HRRZ C,1(AB) ;GET CDR ADDRESS + PUSH TP,(C) + PUSH TP,1(C) + MCALL 1,VALUE ;GET LOCAL VALUE OF ATOM FOR FUNCTION + JRST RES1 + +NOFUN: MOVSI A,TUNBOUND ;MAKE RESUME FUNCTION UNBOUND + JRST RES1 +] + +; PROCHK - SETUP LAST RESUMER SLOT + +PROCHK: MOVE PVP,PVSTOR+1 + CAME B,MAINPR ; MAIN PROCESS? + MOVEM PVP,LSTRES+1(B) + POPJ P, + +; THIS FUNCTION RESUMES A PROCESS, CALLED WITH ONE OR TWO ARGS +; THE FIRST IS A VALUE TO RETURN TO THE OTHER PROCESS OR PASS TO ITS +; RESFUN +; THE SECOND IS THE PROCESS TO RESUME (IF NOT SUPPLIED, USE THE LSTRES) + + +MFUNCTION RESUME,SUBR + + ENTRY + JUMPGE AB,TFA + CAMGE AB,[-4,,0] + JRST TMA + CAMGE AB,[-2,,0] + JRST CHPROC ; VALIDITY CHECK ON PROC + MOVE PVP,PVSTOR+1 + SKIPN B,LSTRES+1(PVP) ; ANY RESUMERS? + JRST NORES ; NO, COMPLAIN +GOTPRO: MOVE C,AB + CAMN B,PVSTOR+1 ; DO THEY DIFFER? + JRST RETARG + MOVE A,PSTAT+1(B) ; CHECK STATE + CAIE A,RUNABL ; MUST BE RUNABL + CAIN A,RESMBL ; OR RESUMABLE + JRST RESUM1 +NOTRES: +NOTRUN: ERRUUO EQUOTE PROCESS-NOT-RUNABLE-OR-RESUMABLE + +RESUM1: PUSHJ P,PROCHK ; FIX LISTS UP + MOVEI A,RESMBL ; GET NEW STATE + MOVE D,B ; FOR SWAP +STRTN: JSP C,SWAP ; SWAP THEM + MOVEM A,PSTAT+1(E) ; CLOBBER OTHER STATE + MOVE PVP,PVSTOR+1 + MOVE A,PSTAT+1(PVP) ; DECIDE HOW TO PROCEED + MOVEI 0,RUNING + MOVEM 0,PSTAT+1(PVP) ; NEW STATE + MOVE C,ABSTO+1(E) ; OLD ARGS + CAIE A,RESMBL + JRST DORUN ; THEY DO RUN RUN, THEY DO RUN RUN +RETARG: MOVE A,(C) + MOVE B,1(C) ; RETURN + JRST FINIS + +DORUN: PUSH TP,RESFUN(PVP) + PUSH TP,RESFUN+1(PVP) + PUSH TP,(C) + PUSH TP,1(C) + MCALL 2,APPLY + PUSH TP,A ; CALL SUICIDE WITH THESE ARGS + PUSH TP,B + MCALL 1,SUICID ; IF IT RETURNS, KILL IT + JRST FINIS + +CHPROC: GETYP A,2(AB) + CAIE A,TPVP + JRST WTYP2 + MOVE B,3(AB) + JRST GOTPRO + +NORES: ERRUUO EQUOTE NO-PROCESS-TO-RESUME + +; FUNCTION TO CAUSE PROCESSES TO SELF DESTRUCT + +MFUNCTION SUICIDE,SUBR + + ENTRY + + JUMPGE AB,TFA + HLRE A,AB + ASH A,-1 ; DIV BY 2 + AOJE A,NOPROC ; NO PROCESS GIVEN + AOJL A,TMA + GETYP A,2(AB) ; MAKE SURE OF PROCESS + CAIE A,TPVP + JRST WTYP2 + MOVE C,3(AB) + JRST SUIC2 + +NOPROC: MOVE PVP,PVSTOR+1 + SKIPN C,LSTRES+1(PVP) + MOVE C,MAINPR ; IF NOT DEFAULT TO MAIN +SUIC2: CAMN C,PVP ; DONT SUICIDE TO SELF + JRST SUSELF + MOVE B,PSTAT+1(C) + CAIE B,RUNABL + CAIN B,RESMBL + JRST .+2 + JRST NOTRUN + MOVE B,C + PUSHJ P,PROCHK + MOVE D,B ; RESTORE NEWPROCESS + MOVEI A,DEAD + JRST STRTN + +SUSELF: ERRUUO EQUOTE ATTEMPT-TO-SUICIDE-TO-SELF + + +MFUNCTION RESER,SUBR,RESUMER + + ENTRY + MOVE B,PVSTOR+1 + JUMPGE AB,GTLAST + CAMGE AB,[-2,,0] + JRST TMA + + GETYP A,(AB) ; CHECK FOR PROCESS + CAIE A,TPVP + JRST WTYP1 + MOVE B,1(AB) ; GET PROCESS +GTLAST: MOVSI A,TFALSE ; ASSUME NONE + SKIPN B,LSTRES+1(B) ; GET IT IF IT EXISTS + JRST FINIS + MOVSI A,TPVP ; GET TYPE + JRST FINIS + +; FUNCTION TO PUT AN EVAL CALL ON ANOTHER PROCESSES STACK + +MFUNCTION BREAKSEQ,SUBR,BREAK-SEQ + + ENTRY 2 + + GETYP A,2(AB) ; 2D ARG MUST BE PROCESS + CAIE A,TPVP + JRST WTYP2 + + MOVE B,3(AB) ; GET PROCESS + CAMN B,PVSTOR+1 ; SKIP IF NOT ME + JRST BREAKM + MOVE A,PSTAT+1(B) ; CHECK STATE + CAIE A,RESMBL ; BEST BE RESUMEABLE + JRST NOTRUN + MOVE C,TBSTO+1(B) ; GET SAVE ACS TO BUILD UP A DUMMY FRAME + MOVE D,TPSTO+1(B) ; STACK POINTER + MOVE E,SPSTO+1(B) ; FIX UP OLD FRAME + MOVEM E,SPSAV(C) + MOVEI E,CALLEV ; FUNNY PC + MOVEM E,PCSAV(C) + MOVE E,PSTO+1(B) ; SET UP P,PP AND TP SAVES + MOVEM E,PSAV(C) + PUSH D,[0] ; ALLOCATES SOME SLOTS + PUSH D,[0] + PUSH D,(AB) ; NOW THAT WHIC IS TO BE EVALLED + PUSH D,1(AB) + MOVEM D,TPSAV(C) + HRRI E,-1(D) ; BUILD UP ARG POINTER + HRLI E,-2 + PUSH D,[TENTRY,,BREAKE] + PUSH D,C ; OLD TB + PUSH D,E ; NEW ARG POINTER +REPEAT 4,PUSH D,[0] ; OTHER SLOTS + MOVEM D,TPSTO+1(B) + MOVEI C,(D) ; BUILD NEW AB + AOBJN C,.+1 + MOVEM C,TBSTO+1(B) ; STORE IT + MOVE A,2(AB) ; RETURN PROCESS + MOVE B,3(AB) + JRST FINIS + +MQUOTE BREAKER + +BREAKE: +CALLEV: MOVEM A,-3(TP) ; HERE TO EVAL THE GOODIE (SAVE REAL RESULT) + MOVEM B,-2(TP) + MCALL 1,EVAL + POP TP,B + POP TP,A + JRST FINIS + +BREAKM: ERRUUO EQUOTE ATTEMPT-TO-BREAK-OWN-SEQUENCE + +; FUNCTION TOP PUT PROCESS IN 1 STEP MODE + +MFUNCTION 1STEP,SUBR + PUSHJ P,1PROC + MOVE PVP,PVSTOR+1 + MOVEM PVP,1STEPR+1(B) ; CLOBBER TARGET PROCESS + JRST FINIS + +; FUNCTION TO UNDO ABOVE + +MFUNCTION %%FREE,SUBR,FREE-RUN + PUSHJ P,1PROC + MOVE PVP,PVSTOR+1 + CAME PVP,1STEPR+1(B) + JRST FNDBND + SETZM 1STEPR+1(B) + JRST FINIS + +FNDBND: SKIPE 1STEPR+1(B) ; DOES IT HAVE ANY 1STEPPER? + JRST NOTMIN ; YES, COMPLAIN + MOVE D,B ; COPY PROCESS + ADD D,[1STEPR,,1STEPR] ; POINTER FOR SEARCH + HRRZ C,SPSTO+1(B) ; GET THIS BINDING STACK + +FNDLP: GETYP 0,(C) ; IS THIS A TBVL? + CAIN 0,TBVL + CAME D,1(C) ; SKIP IF THIS IS SAVED 1STEP SLOT + JRST FNDNXT + SKIPN 3(C) ; IS IT SAVING A REAL 1STEPPER? + JRST FNDNXT + MOVE PVP,PVSTOR+1 + CAME PVP,3(C) ; IS IT ME? + JRST NOTMIN + SETZM 3(C) ; CLEAR OUT SAVED 1STEPPER + JRST FINIS +FNDNXT: HRRZ C,(C) ; NEXT BINDING + JUMPN C,FNDLP + +NOTMIN: MOVE C,$TCHSTR + MOVE D,CHQUOTE NOT-YOUR-1STEPEE + PUSHJ P,INCONS + MOVSI A,TFALSE + JRST FINIS + +1PROC: ENTRY 1 + GETYP A,(AB) + CAIE A,TPVP + JRST WTYP1 + MOVE B,1(AB) + MOVE A,(AB) + POPJ P, + +; FUNCTION TO RETRUN THE MAIN PROCESS + +MFUNCTION MAIN%%,SUBR,MAIN + ENTRY 0 + + MOVE B,MAINPR +MAIN1: MOVSI A,TPVP + JRST FINIS + +; FUNCTION TO RETURN THE CURRENT PROCESS + +MFUNCTION ME,SUBR + ENTRY 0 + + MOVE B,PVSTOR+1 + JRST MAIN1 + +; FUNCTION TO RETURN THE STATE OF A PROCESS + +MFUNCTION STATE,SUBR + ENTRY 1 + GETYP A,(AB) + CAIE A,TPVP + JRST WTYP1 + MOVE A,1(AB) ; GET PROCESS + MOVE A,PSTAT+1(A) + MOVE B,@STATES(A) ; GET STATE + MOVSI A,TATOM + JRST FINIS + +STATES: + IRP A,,[ILLEGAL,RUNABLE,RESUMABLE,RUNNING,DEAD,BLOCKED] + MQUOTE A + TERMIN + + + +END + \ No newline at end of file diff --git a//decl.bin.3 b//decl.bin.3 new file mode 100644 index 0000000..82f61ed Binary files /dev/null and b//decl.bin.3 differ diff --git a//decl.mid.102 b//decl.mid.102 new file mode 100644 index 0000000..0cede3c --- /dev/null +++ b//decl.mid.102 @@ -0,0 +1,1064 @@ + +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 + +; 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 <....> + 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 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 + \ No newline at end of file diff --git a//decl.mid.103 b//decl.mid.103 new file mode 100644 index 0000000..1fce52b --- /dev/null +++ b//decl.mid.103 @@ -0,0 +1,1091 @@ + +TITLE DECLARATION PROCESSOR + +RELOCA + +.INSRT MUDDLE > + +.GLOBAL STBL,TYPFND,TYPSGR,CHKDCL,TESTR,VALG,INCR1,TYPG,ISTRUC,TMATCH,SAT +.GLOBAL TYPMIS,CHKAB,CHKARG,IGDECL,LOCQQ,APLQ,CALER,IEQUAL,IIGLOC,IGLOC +.GLOBAL CHLOCI,INCONS,SPCCHK,OUTRNG,WTYP1,FLGSET,IGET,PVSTOR,SPSTOR,DSTORE +.GLOBAL NOATMS,NOSET,NOSETG +; Subr to allow user to access the DECL checking code + +MFUNCTION CHECKD,SUBR,[DECL?] + + ENTRY 2 + + MOVE C,(AB) + MOVE D,1(AB) + MOVE A,2(AB) + MOVE B,3(AB) + PUSHJ P,TMATCX ; CHECK THEM + JRST IFALS + +RETT: MOVSI A,TATOM + MOVE B,IMQUOTE T + JRST FINIS + +RETF: +IFALS: MOVEI B,0 + MOVSI A,TFALSE + JRST FINIS + +; Subr to turn DECL checking on and off. + +MFUNCTION %DECL,SUBR,[DECL-CHECK] + + ENTRY + + HRROI E,IGDECL + JRST FLGSET + +; Subr to turn on and off allowing new atoms + +MFUNCTION %NEWAT,SUBR,[ALLOW-NEW-ATOMS] + + ENTRY + + MOVEI E,NOATMS + JRST FLGSET + +; Subr to turn on and off allowing new GVALS + +MFUNCTION %NEWGV,SUBR,[ALLOW-NEW-GVALS] + + ENTRY + + MOVEI E,NOSETG + JRST FLGSET + +; Subr to turn on and off allowing new LVALs + +MFUNCTION %NEWLV,SUBR,[ALLOW-NEW-LVALS] + + ENTRY + + MOVEI E,NOSET + JRST FLGSET + +; Change special unspecial normal mode + +MFUNCTION SPECM%,SUBR,[SPECIAL-MODE] + + ENTRY + + CAMGE AB,[-3,,] + JRST TMA + MOVE C,SPCCHK ; GET CURRENT + JUMPGE AB,MODER ; RET CURRENT + GETYP 0,(AB) ; CHECK IT IS ATOM + CAIE 0,TATOM + JRST WTYP1 + MOVE 0,1(AB) + MOVEI A,1 + CAMN 0,MQUOTE UNSPECIAL + MOVSI A,(SETZ) + CAMN 0,MQUOTE SPECIAL + MOVEI A,0 + JUMPG A,WTYP1 + HLLM A,SPCCHK + +MODER: MOVSI A,TATOM + MOVE B,MQUOTE SPECIAL + SKIPGE C + MOVE B,MQUOTE UNSPECIAL + JRST FINIS + +; Function to turn special checking on and of + +MFUNCTION SPECC%,SUBR,[SPECIAL-CHECK] + + ENTRY + CAMGE AB,[-3,,] + JRST TMA + + MOVE C,SPCCHK + JUMPGE AB,SCHEK1 + + MOVEI A,0 + GETYP 0,(AB) + CAIE 0,TFALSE + MOVEI A,1 + HRRM A,SPCCHK + +SCHEK1: TRNN C,1 + JRST IFALS + JRST RETT + +; Finction to set decls for GLOBAL values. + +MFUNCTION GDECL,FSUBR + + ENTRY 1 + + GETYP 0,(AB) + CAIE 0,TLIST + JRST WTYP1 + + PUSH TP,$TLIST + PUSH TP,1(AB) + PUSH TP,$TLIST + PUSH TP,[0] + PUSH TP,$TLIST + PUSH TP,[0] + +GDECL1: INTGO + SKIPN C,1(TB) + JRST RETT + HRRZ D,(C) ; MAKE SURE PAIRS + JUMPE D,GDECLL ; LOSER, GO AWAY + GETYP 0,(C) + CAIE 0,TLIST + JRST GDECLL + HRRZ 0,(D) + MOVEM 0,1(TB) ; READY FOR NEXT CALL + MOVE C,1(C) ; SAVE ATOM LIST + MOVEM C,5(TB) + MOVEM D,3(TB) + +GDECL2: INTGO + SKIPN C,5(TB) + JRST GDECL1 ; OUT OF ATOMS + GETYP 0,(C) ; IS THIS AN ATOM + CAIE 0,TATOM + JRST GDECLL ; NO, LOSE + MOVE B,1(C) + HRRZ C,(C) + MOVEM C,5(TB) + PUSHJ P,IIGLOC ; GET ITS VAL (OR MAKE ONE) + GETYP 0,(B) ; UNBOUND? + CAIE 0,TUNBOU + JRST CHKCUR ; CHECK CURRENT VALUE + MOVE C,3(TB) ; GET DECL + HRRM C,-2(B) + JRST GDECL2 + +CHKCUR: HRRZ D,3(TB) + GETYP A,(D) + MOVSI A,(A) + MOVE E,B + MOVE B,1(D) + MOVE C,(E) + MOVE D,1(E) + PUSH TP,$TVEC + PUSH TP,E + JSP E,CHKAB + PUSHJ P,TMATCH + JRST TYPMI3 + MOVE E,(TP) + SUB TP,[2,,2] + MOVE D,3(TB) + HRRM D,-2(E) + JRST GDECL2 + +TYPMI3: MOVE E,(TP) ; POINT BACK TO SLOT + MOVE A,-1(E) ; ATOM TO A + MOVE B,1(E) + MOVE D,(E) ; GET OLD VALUE + MOVE C,3(TB) + JRST TYPMIS ; GO COMPLAIN + +GDECLL: ERRUUO EQUOTE BAD-ARGUMENT-LIST + +MFUNCTION UNMANIFEST,SUBR + + ENTRY + + PUSH P,[HLLZS -2(B)] + JRST MANLP + +MFUNCTION MANIFEST,SUBR + + ENTRY + + PUSH P,[HLLOS -2(B)] +MANLP: JUMPGE AB,RETT + GETYP 0,(AB) + CAIE 0,TATOM + JRST WTYP + MOVE B,1(AB) + PUSHJ P,IIGLOC + XCT (P) + ADD AB,[2,,2] + JRST MANLP + +MFUNCTION MANIFQ,SUBR,[MANIFEST?] + + ENTRY 1 + + GETYP 0,(AB) + CAIE 0,TATOM + JRST WTYP1 + + MOVE B,1(AB) + PUSHJ P,IGLOC ; GET POINTER IF ANY + GETYP 0,A + CAIN 0,TUNBOU + JRST RETF + HRRZ 0,-2(B) + CAIE 0,-1 + JRST RETF + JRST RETT + +MFUNCTION GETDECL,SUBR,[GET-DECL] + + ENTRY 1 + + GETYP 0,(AB) + CAIN 0,TOFFS + JRST GETDOF + PUSHJ P,GTLOC + JRST GTLOCA + + HRRZ C,-2(B) ; GET GLOBAL DECL +GETD1: JUMPE C,RETF + CAIN C,-1 + JRST RETMAN + GETYP A,(C) + MOVSI A,(A) + MOVE B,1(C) + JSP E,CHKAB + JRST FINIS +GETDOF: HLRZ B,1(AB) + JUMPE B,GETDO1 + MOVE A,(B) + MOVE B,1(B) + JRST FINIS +GETDO1: MOVSI A,TATOM + MOVE B,IMQUOTE ANY + JRST FINIS + +RETMAN: MOVSI A,TATOM + MOVE B,MQUOTE MANIFEST + JRST FINIS + +GTLOCA: HLRZ C,2(B) ; LOCAL DECL + JRST GETD1 + +MFUNCTION PUTDECL,SUBR,[PUT-DECL] + + ENTRY 2 + + GETYP 0,(AB) + CAIN 0,TOFFS + JRST PUTDOF ; MAKE OFFSET WITH NEW DECL + PUSHJ P,GTLOC + SKIPA E,[HRLM B,2(C)] + MOVE E,[HRRM B,-2(C)] + PUSH P,E + GETYP 0,(B) ; ANY VALUE + CAIN 0,TUNBOU + JRST PUTD1 + MOVE C,(B) ; GET CURRENT VALUE + MOVE D,1(B) + MOVE A,2(AB) + MOVE B,3(AB) + PUSHJ P,TMATCH + JRST TYPMI4 +PUTD1: MOVE C,2(AB) ; GET DECL BACK + MOVE D,3(AB) + PUSHJ P,INCONS ; CONS IT UP + MOVE C,1(AB) ; LOCATIVE BACK + XCT (P) ; CLOBBER + MOVE A,(AB) + MOVE B,1(AB) + JRST FINIS + +TYPMI4: MOVE E,1(AB) ; GET LOCATIVE + MOVE A,-1(E) ; NOW ATOM + MOVEI C,2(AB) ; POINT TO DECL + MOVE D,(E) ; AND CURRENT VAL + MOVE B,1(E) + JRST TYPMIS + +GTLOC: GETYP 0,(AB) + CAIE 0,TLOCD + JRST WTYP1 + MOVEI B,(AB) + PUSHJ P,CHLOCI + HRRZ 0,(AB) ; LOCAL OR GLOBAL + SKIPN 0 + AOS (P) + MOVE B,1(AB) ; RETURN LOCATIVE IN B + POPJ P, + +; MAKE OFFSET WITH SUPPLIED DECL +PUTDOF: MOVE D,3(AB) + GETYP 0,2(AB) + CAIN TATOM + CAME D,IMQUOTE ANY + JRST PUTDO1 + MOVSI A,TOFFS + HRRZ B,1(AB) + JRST FINIS +PUTDO1: MOVE C,2(AB) + PUSHJ P,INCONS ; BUILD A LIST + MOVSI A,TOFFS + HRLS B + HRR B,1(AB) ; SET UP OFFSET + JRST FINIS + +; BUILD AN OFFSET--TAKES FIX AND DECL (OR ATOM FORM) +; JUMPS INTO PUT-DECL CODE FOR OFFSETS. + MFUNCTION COFFSET,SUBR,[OFFSET] + + ENTRY 2 + GETYP 0,(AB) + CAIE 0,TFIX + JRST WTYP1 + SKIPG 1(AB) + JRST OUTRNG ; CAN'T HAVE NEGATIVE OFFSETS + GETYP 0,2(AB) + CAIE 0,TATOM + CAIN 0,TFORM + JRST PUTDOF + JRST WTYP2 + +; GET FIX PART OF OFFSET + MFUNCTION INDEX,SUBR + + ENTRY 1 + GETYP 0,(AB) + CAIE 0,TOFFS + JRST WTYP1 + MOVSI A,TFIX + HRRE B,1(AB) + JRST FINIS + +; 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 <....> + 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 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 + \ No newline at end of file diff --git a//ecagc.bin.1 b//ecagc.bin.1 new file mode 100644 index 0000000..e69de29 diff --git a//eval.bin.13 b//eval.bin.13 new file mode 100644 index 0000000..c13d12b Binary files /dev/null and b//eval.bin.13 differ diff --git a//eval.bin.14 b//eval.bin.14 new file mode 100644 index 0000000..8bf7d14 Binary files /dev/null and b//eval.bin.14 differ diff --git a//eval.mid.122 b//eval.mid.122 new file mode 100644 index 0000000..bf17181 --- /dev/null +++ b//eval.mid.122 @@ -0,0 +1,4211 @@ +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 + + +; 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]] + + +;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, + + +; 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 + +; 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, + + +; 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 + + +; 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,,[[TSUBR,APSUBR],[TFSUBR,APFSUB],[TRSUBR,APRSUB],[TFIX,APNUM] +[TEXPR,APEXPR],[TFUNAR,APFUNARG],[TENTER,APENTR],[TMACRO,APMACR],[TOFFS,APNUM]] + +; 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, + +; 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,[] + JRST .+3 + CAME B,[+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 + + +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 + + +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 + + + + +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? + JRST MPD + PUSHJ P,@E.ARG+1(TB) ; SEE IF ANYMORE ARGS + JRST APRDON + JRST TMA + + +; 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 + + +; 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 +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, + +; 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 + + + +; 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 + +; 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 + +; 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,[] + JRST .+3 + CAME B,[+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) + + +; 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 + + +; 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 + + 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 + + + +; 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 + + +; 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 + +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 + + +; 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 + +; 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 + +; 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 ) OR ('A ) + 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, + +; 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 + + +; 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) + + + +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 + + +; 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 + + +;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, + + +;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 + +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, + + ;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 + +; 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 + + + +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 + + +; 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, + + + +;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 + + + +; 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 + + +; 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 + + +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 + + +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 + + + + +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 + + + +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? + + +; 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 + + +;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, + + + +;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 + + + +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 + + ;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, + + +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 + + + +;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 + \ No newline at end of file diff --git a//eval.mid.123 b//eval.mid.123 new file mode 100644 index 0000000..e75e261 --- /dev/null +++ b//eval.mid.123 @@ -0,0 +1,4217 @@ +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 + + +; 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]] + + +;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, + + +; 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 + +; 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, + + +; 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 + + +; 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,,[[TSUBR,APSUBR],[TFSUBR,APFSUB],[TRSUBR,APRSUB],[TFIX,APNUM] +[TEXPR,APEXPR],[TFUNAR,APFUNARG],[TENTER,APENTR],[TMACRO,APMACR],[TOFFS,APNUM]] + +; 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, + +; 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,[] + JRST .+3 + CAME B,[+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 + + +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 + + +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 + + + + +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? + JRST MPD + PUSHJ P,@E.ARG+1(TB) ; SEE IF ANYMORE ARGS + JRST APRDON + JRST TMA + + +; 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 + + +; 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 +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, + +; 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 + + + +; 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 + +; 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 + +; 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,[] + JRST .+3 + CAME B,[+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) + + +; 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 + + +; 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 + + 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 + + + +; 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 + + +; 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 + +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 + + +; 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 + +; 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 + +; 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 ) OR ('A ) + 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, + +; 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 + + +; 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) + + + +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 + + +; 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 + + +;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, + + +;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 + +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, + + ;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 + +; 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 + + + +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 + + +; 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, + + + +;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 + + + +; 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 + + +; 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 + + +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 + + +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 + + + + +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 + + + +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? + + +; 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 + + +;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, + + + +;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 + + + +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 + + ;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, + + +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 + + + +;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 + \ No newline at end of file diff --git a//eval.mid.124 b//eval.mid.124 new file mode 100644 index 0000000..f377766 --- /dev/null +++ b//eval.mid.124 @@ -0,0 +1,4245 @@ +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 + + +; 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]] + + +;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, + + +; 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 + +; 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, + + +; 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 + + +; 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,,[[TSUBR,APSUBR],[TFSUBR,APFSUB],[TRSUBR,APRSUB],[TFIX,APNUM] +[TEXPR,APEXPR],[TFUNAR,APFUNARG],[TENTER,APENTR],[TMACRO,APMACR],[TOFFS,APNUM]] + +; 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, + +; 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,[] + JRST .+3 + CAME B,[+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 + + +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 + + +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 + + + + +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? + JRST MPD + PUSHJ P,@E.ARG+1(TB) ; SEE IF ANYMORE ARGS + JRST APRDON + JRST TMA + + +; 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 + + +; 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 +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, + +; 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 + + + +; 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 + +; 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 + +; 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,[] + JRST .+3 + CAME B,[+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) + + +; 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 + + +; 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 + + 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 + + + +; 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 + + +; 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 + +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 + + +; 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 + +; 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 + +; 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 ) OR ('A ) + 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, + +; 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 + + +; 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) + + + +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 + + +; 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 + + +;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, + + +;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 + +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, + + ;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 + +; 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 + + + +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 + + +; 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, + + + +;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 + + + +; 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 + + +; 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 + + +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 + + +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 + + + + +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 + + + +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? + + +; 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 + + +;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, + + + +;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 + + + +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 + + ;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, + + +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 + + + +;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 + \ No newline at end of file diff --git a//eval.mid.125 b//eval.mid.125 new file mode 100644 index 0000000..9f2552b --- /dev/null +++ b//eval.mid.125 @@ -0,0 +1,4245 @@ +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 + + +; 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]] + + +;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, + + +; 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 + +; 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, + + +; 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 + + +; 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,,[[TSUBR,APSUBR],[TFSUBR,APFSUB],[TRSUBR,APRSUB],[TFIX,APNUM] +[TEXPR,APEXPR],[TFUNAR,APFUNARG],[TENTER,APENTR],[TMACRO,APMACR],[TOFFS,APNUM]] + +; 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, + +; 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,[] + JRST .+3 + CAME B,[+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 + + +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 + + +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 + + + + +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? + JRST MPD + PUSHJ P,@E.ARG+1(TB) ; SEE IF ANYMORE ARGS + JRST APRDON + JRST TMA + + +; 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 + + +; 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 +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, + +; 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 + + + +; 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 + +; 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 + +; 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,[] + JRST .+3 + CAME B,[+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) + + +; 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 + + +; 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 + + 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 + + + +; 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 + + +; 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 + +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 + + +; 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 + +; 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 + +; 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 ) OR ('A ) + 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, + +; 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 + + +; 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) + + + +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 + + +; 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 + + +;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, + + +;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 + +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, + + ;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 + +; 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 + + + +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 + + +; 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, + + + +;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 + + + +; 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 + + +; 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 + + +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 + + +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 + + + + +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 + + + +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? + + +; 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 + + +;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, + + + +;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 + + + +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 + + ;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, + + +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 + + + +;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 + \ No newline at end of file diff --git a//first.cmd.2 b//first.cmd.2 new file mode 100644 index 0000000..9dc3276 --- /dev/null +++ b//first.cmd.2 @@ -0,0 +1,84 @@ +CONN INT: +DEL MDLXXX.*.* +DELVER +YY*.*.* +EXP +DEL MDL:MDLXXX.*.* +DEL MDL:*.SAV00.* +EXP MDL: +STINK +MMUD105.STINK@MMDLXXX.EXEYRESET . + +NDDT +;YMDLXXX.EXE +;UMDLXXX.EXE +;OMDLXXX.SYMBOLS + +INTFCNK +NAME1K +BUFRINK +PROCIDK +IOIN2K +ITEMK +NILK +TYPVECK +INAMEK +ECHOK +CHANNOK +VALK +CHRCNTK +0STOK +TYPBOTK +ERASCHK +DIRECTK +INDICK +INTFCNK +KILLCHK +TTICHNK +ASTOK +BRKCHK +NODPNTK +ESCAPK +BSTOK +TTOCHNK +SYSCHRK +BRFCHRK +CSTOK +ROOTK +ASOLNTK +BRFCH2K +BYTPTRK +INITIAK +DSTOK +ESTOK +INTOBLK +PVPSTOK +ERROBLK +MUDOBLK +TVPSTOK +ABSTOK +INTNUMK +STATUSK +INTVECK +QUEUESK +TBSTOK +CHNL1K +.LIST.K +GCPDLK +CONADJK +T.CHANK +N.CHNSK +SLENGCK +LENGCK +SECLENK +;WMDLXXX.SYMBOLS +;H +RESET . +NDDT +;YMDLXXX.EXE +;OMDLXXX.SYMBOLS +NSEGS/3 +MASK1/700541,,2007 +;UMDLXXX.EXE +;H +LOGOUT diff --git a//fopen.bin.16 b//fopen.bin.16 new file mode 100644 index 0000000..5daad10 Binary files /dev/null and b//fopen.bin.16 differ diff --git a//fopen.bin.22 b//fopen.bin.22 new file mode 100644 index 0000000..0b5b1e5 Binary files /dev/null and b//fopen.bin.22 differ diff --git a//fopen.mid.35 b//fopen.mid.35 new file mode 100644 index 0000000..5c9c32a --- /dev/null +++ b//fopen.mid.35 @@ -0,0 +1,4538 @@ +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 (,,,,) +; +; - DIRECTION EITHER READ (INPUT) OR PRINT (OUPUT). DEFAULT IS READ + +; - FIRST FILE NAME. DEFAULT INPUT OR OUTPUT. + +; - SECOND FILE NAME. DEFAULT MUDDLE. + +; - DEVICE FROM WHICH TO OPEN. DEFAULT IS DSK. + +; - 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 + + +;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 + +.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) = ,, +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 + + + +;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 + + + + +; 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 + + + +; 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, +] + + +; 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, + + +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," ; 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, + + + +; 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 +] + + +; 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) + + + +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," ; 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 + +] + + +; 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) + + +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 + +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) + + +; 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 + + +; 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 + + +; 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, + + +; 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, + +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, + +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 + +] + +; 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, + + +; 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, +] + +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 + + +; 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, + + +; 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 +] +] + + +; 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, +] + +;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, + +; 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 + ] + +; 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 + 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 + + ; 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 + +; 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 + + ; 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] + + ;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 + ;SUBR TO DO .ACCESS ON A READ CHANNEL +;FORM: +;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,[+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 + +; 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,[+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, + ; 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,[+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 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/ + +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 + + ; 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 +; AND BOTH SUBRS RETURN THE NUMBER OF CHARS READ OR WRITTEN + +; FORMAT FOR PRINTSTRING IS + +; 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 + + ; 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 +] + +; 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 +BCLS11: POP P,0 + HLLZS ACCESS-1(B) + HRRZ C,BUFSTR-1(B) + CAIE C,BUFLNT*5 + PUSHJ P,BFCLOS + POPJ P, + + +; 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 + + ;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 + + + +; 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,[+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, +] + + + ; 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 = +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 +] + ;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 + + \ No newline at end of file diff --git a//fopen.mid.54 b//fopen.mid.54 new file mode 100644 index 0000000..fcdfdf0 --- /dev/null +++ b//fopen.mid.54 @@ -0,0 +1,4686 @@ +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 (,,,,) +; +; - DIRECTION EITHER READ (INPUT) OR PRINT (OUPUT). DEFAULT IS READ + +; - FIRST FILE NAME. DEFAULT INPUT OR OUTPUT. + +; - SECOND FILE NAME. DEFAULT MUDDLE. + +; - DEVICE FROM WHICH TO OPEN. DEFAULT IS DSK. + +; - 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 + + +;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 + +.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) = ,, +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 + + + +;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 + + + + +; 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 + + + +; 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, +] + + +; 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, + + +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," ; 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, + + + +; 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 +] + + +; 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) + + + +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," ; 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 + +] + + +; 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) + + +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 + +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) + + +; 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 + + +; 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 + + +; 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, + + +; 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, + +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, + +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 + +] + +; 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, + + +; 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, +] + +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 + + +; 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, + + +; 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 +] +] + + +; 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, +] + +;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, + +; 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 + ] + +; 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 + 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 + + ; 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 + +; 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 + + ; 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] + + ;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 + ;SUBR TO DO .ACCESS ON A READ CHANNEL +;FORM: +;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,[+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 + +; 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,[+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, + ; 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,[+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 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/ + +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 + + ; 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 +; AND BOTH SUBRS RETURN THE NUMBER OF CHARS READ OR WRITTEN + +; FORMAT FOR PRINTSTRING IS + +; 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 + + ; 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 +] + +; 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 +BCLS11: POP P,0 + HLLZS ACCESS-1(B) + HRRZ C,BUFSTR-1(B) + CAIE C,BUFLNT*5 + PUSHJ P,BFCLOS + POPJ P, + + +; 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 + + ;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 + + + +; 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,[+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, +] + + + ; 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 = +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 +] + ;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 + + \ No newline at end of file diff --git a//fopen.mid.56 b//fopen.mid.56 new file mode 100644 index 0000000..a7512e3 --- /dev/null +++ b//fopen.mid.56 @@ -0,0 +1,4686 @@ +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 (,,,,) +; +; - DIRECTION EITHER READ (INPUT) OR PRINT (OUPUT). DEFAULT IS READ + +; - FIRST FILE NAME. DEFAULT INPUT OR OUTPUT. + +; - SECOND FILE NAME. DEFAULT MUDDLE. + +; - DEVICE FROM WHICH TO OPEN. DEFAULT IS DSK. + +; - 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 + + +;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 + +.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) = ,, +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 + + + +;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 + + + + +; 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 + + + +; 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, +] + + +; 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, + + +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," ; 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, + + + +; 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 +] + + +; 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) + + + +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," ; 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 + +] + + +; 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) + + +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 + +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) + + +; 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 + + +; 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 + + +; 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, + + +; 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, + +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, + +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 + +] + +; 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, + + +; 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, +] + +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 + + +; 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, + + +; 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 +] +] + + +; 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, +] + +;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, + +; 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 + ] + +; 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 + 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 + + ; 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 + +; 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 + + ; 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] + + ;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 + ;SUBR TO DO .ACCESS ON A READ CHANNEL +;FORM: +;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,[+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 + +; 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,[+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, + ; 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,[+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 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/ + +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 + + ; 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 +; AND BOTH SUBRS RETURN THE NUMBER OF CHARS READ OR WRITTEN + +; FORMAT FOR PRINTSTRING IS + +; 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 + + ; 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 +] + +; 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 +BCLS11: POP P,0 + HLLZS ACCESS-1(B) + HRRZ C,BUFSTR-1(B) + CAIE C,BUFLNT*5 + PUSHJ P,BFCLOS + POPJ P, + + +; 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 + + ;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 + + + +; 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,[+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, +] + + + ; 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 = +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 +] + ;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 + + \ No newline at end of file diff --git a//fopen.mid.57 b//fopen.mid.57 new file mode 100644 index 0000000..e42534b --- /dev/null +++ b//fopen.mid.57 @@ -0,0 +1,4703 @@ +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 (,,,,) +; +; - DIRECTION EITHER READ (INPUT) OR PRINT (OUPUT). DEFAULT IS READ + +; - FIRST FILE NAME. DEFAULT INPUT OR OUTPUT. + +; - SECOND FILE NAME. DEFAULT MUDDLE. + +; - DEVICE FROM WHICH TO OPEN. DEFAULT IS DSK. + +; - 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 + + +;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 + +.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) = ,, +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 + + + +;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 + + + + +; 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 + + + +; 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, +] + + +; 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, + + +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," ; 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, + + + +; 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 +] + + +; 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) + + + +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," ; 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 + +] + + +; 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) + + +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 + +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) + + +; 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 + + +; 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 + + +; 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, + + +; 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, + +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, + +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 + +] + +; 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, + + +; 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, +] + +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 + + +; 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, + + +; 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 +] +] + + +; 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, +] + +;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, + +; 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 + ] + +; 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 + 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 + + ; 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 + +; 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 + + ; 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] + + ;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 + ;SUBR TO DO .ACCESS ON A READ CHANNEL +;FORM: +;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,[+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 + +; 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,[+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, + ; 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,[+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 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/ + +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 + + ; 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 +; AND BOTH SUBRS RETURN THE NUMBER OF CHARS READ OR WRITTEN + +; FORMAT FOR PRINTSTRING IS + +; 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 + + ; 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 +] + +; 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 +BCLS11: POP P,0 + HLLZS ACCESS-1(B) + HRRZ C,BUFSTR-1(B) + CAIE C,BUFLNT*5 + PUSHJ P,BFCLOS + POPJ P, + + +; 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 + + ;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 + + + +; 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,[+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, +] + + + ; 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 = +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 +] + ;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 + + \ No newline at end of file diff --git a//fopen.mid.58 b//fopen.mid.58 new file mode 100644 index 0000000..302ae73 --- /dev/null +++ b//fopen.mid.58 @@ -0,0 +1,4703 @@ +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 (,,,,) +; +; - DIRECTION EITHER READ (INPUT) OR PRINT (OUPUT). DEFAULT IS READ + +; - FIRST FILE NAME. DEFAULT INPUT OR OUTPUT. + +; - SECOND FILE NAME. DEFAULT MUDDLE. + +; - DEVICE FROM WHICH TO OPEN. DEFAULT IS DSK. + +; - 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 + + +;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 + +.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) = ,, +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 + + + +;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 + + + + +; 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 + + + +; 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, +] + + +; 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, + + +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," ; 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, + + + +; 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 +] + + +; 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) + + + +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," ; 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 + +] + + +; 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) + + +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 + +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) + + +; 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 + + +; 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 + + +; 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, + + +; 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, + +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, + +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 + +] + +; 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, + + +; 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, +] + +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 + + +; 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, + + +; 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 +] +] + + +; 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, +] + +;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, + +; 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 + ] + +; 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 + 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 + + ; 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 + +; 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 + + ; 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] + + ;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 + ;SUBR TO DO .ACCESS ON A READ CHANNEL +;FORM: +;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,[+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 + +; 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,[+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, + ; 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,[+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 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/ + +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 + + ; 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 +; AND BOTH SUBRS RETURN THE NUMBER OF CHARS READ OR WRITTEN + +; FORMAT FOR PRINTSTRING IS + +; 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 + + ; 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 +] + +; 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 +BCLS11: POP P,0 + HLLZS ACCESS-1(B) + HRRZ C,BUFSTR-1(B) + CAIE C,BUFLNT*5 + PUSHJ P,BFCLOS + POPJ P, + + +; 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 + + ;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 + + + +; 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,[+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, +] + + + ; 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 = +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 +] + ;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 + + \ No newline at end of file diff --git a//fopen.mid.59 b//fopen.mid.59 new file mode 100644 index 0000000..c2d1c0c --- /dev/null +++ b//fopen.mid.59 @@ -0,0 +1,4703 @@ +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 (,,,,) +; +; - DIRECTION EITHER READ (INPUT) OR PRINT (OUPUT). DEFAULT IS READ + +; - FIRST FILE NAME. DEFAULT INPUT OR OUTPUT. + +; - SECOND FILE NAME. DEFAULT MUDDLE. + +; - DEVICE FROM WHICH TO OPEN. DEFAULT IS DSK. + +; - 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 + + +;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 + +.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) = ,, +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 + + + +;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 + + + + +; 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 + + + +; 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, +] + + +; 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, + + +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," ; 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, + + + +; 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 +] + + +; 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) + + + +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," ; 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 + +] + + +; 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) + + +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 + +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) + + +; 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 + + +; 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 + + +; 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, + + +; 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, + +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, + +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 + +] + +; 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, + + +; 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, +] + +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 + + +; 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, + + +; 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 +] +] + + +; 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, +] + +;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, + +; 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 + ] + +; 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 + 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 + + ; 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 + +; 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 + + ; 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] + + ;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 + ;SUBR TO DO .ACCESS ON A READ CHANNEL +;FORM: +;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,[+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 + +; 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,[+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, + ; 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,[+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 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/ + +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 + + ; 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 +; AND BOTH SUBRS RETURN THE NUMBER OF CHARS READ OR WRITTEN + +; FORMAT FOR PRINTSTRING IS + +; 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 + + ; 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 +] + +; 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 +BCLS11: POP P,0 + HLLZS ACCESS-1(B) + HRRZ C,BUFSTR-1(B) + CAIE C,BUFLNT*5 + PUSHJ P,BFCLOS + POPJ P, + + +; 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 + + ;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 + + + +; 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,[+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, +] + + + ; 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 = +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 +] + ;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 + + \ No newline at end of file diff --git a//fopen.mid.60 b//fopen.mid.60 new file mode 100644 index 0000000..afe3199 --- /dev/null +++ b//fopen.mid.60 @@ -0,0 +1,4712 @@ +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 (,,,,) +; +; - DIRECTION EITHER READ (INPUT) OR PRINT (OUPUT). DEFAULT IS READ + +; - FIRST FILE NAME. DEFAULT INPUT OR OUTPUT. + +; - SECOND FILE NAME. DEFAULT MUDDLE. + +; - DEVICE FROM WHICH TO OPEN. DEFAULT IS DSK. + +; - 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 + + +;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 + +.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) = ,, +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 + + + +;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 + + + + +; 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 + + + +; 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, +] + + +; 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, + + +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," ; 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, + + + +; 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 +] + + +; 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) + + + +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," ; 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 + +] + + +; 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) + + +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 + +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) + + +; 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 + + +; 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 + + +; 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, + + +; 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, + +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, + +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 + +] + +; 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, + + +; 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, +] + +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 + + +; 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, + + +; 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 +] +] + + +; 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, +] + +;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, + +; 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 + ] + +; 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 + 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 + + ; 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 + +; 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 + + ; 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] + + ;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 + ;SUBR TO DO .ACCESS ON A READ CHANNEL +;FORM: +;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,[+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 + +; 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,[+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, + ; 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,[+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 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/ + +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 + + ; 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 +; AND BOTH SUBRS RETURN THE NUMBER OF CHARS READ OR WRITTEN + +; FORMAT FOR PRINTSTRING IS + +; 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 + + ; 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 +] + +; 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 +BCLS11: POP P,0 + HLLZS ACCESS-1(B) + HRRZ C,BUFSTR-1(B) + CAIE C,BUFLNT*5 + PUSHJ P,BFCLOS + POPJ P, + + +; 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 + + ;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 + + + +; 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,[+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, +] + + + ; 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 = +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 +] + ;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 + + \ No newline at end of file diff --git a//fopen.mid.61 b//fopen.mid.61 new file mode 100644 index 0000000..eb1619b --- /dev/null +++ b//fopen.mid.61 @@ -0,0 +1,4715 @@ +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 (,,,,) +; +; - DIRECTION EITHER READ (INPUT) OR PRINT (OUPUT). DEFAULT IS READ + +; - FIRST FILE NAME. DEFAULT INPUT OR OUTPUT. + +; - SECOND FILE NAME. DEFAULT MUDDLE. + +; - DEVICE FROM WHICH TO OPEN. DEFAULT IS DSK. + +; - 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 + + +;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 + +.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) = ,, +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 + + + +;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 + + + + +; 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 + + + +; 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, +] + + +; 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, + + +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," ; 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, + + + +; 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 +] + + +; 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) + + + +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," ; 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 + +] + + +; 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) + + +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 + +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) + + +; 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 + + +; 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 + + +; 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, + + +; 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, + +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, + +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 + +] + +; 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, + + +; 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, +] + +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 + + +; 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, + + +; 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 +] +] + + +; 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, +] + +;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, + +; 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 + ] + +; 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 + 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 + + ; 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 + +; 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 + + ; 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] + + ;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 + ;SUBR TO DO .ACCESS ON A READ CHANNEL +;FORM: +;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,[+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 + +; 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,[+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, + ; 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,[+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 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/ + +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 + + ; 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 +; AND BOTH SUBRS RETURN THE NUMBER OF CHARS READ OR WRITTEN + +; FORMAT FOR PRINTSTRING IS + +; 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 + + ; 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 +] + +; 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 +BCLS11: POP P,0 + HLLZS ACCESS-1(B) + HRRZ C,BUFSTR-1(B) + CAIE C,BUFLNT*5 + PUSHJ P,BFCLOS + POPJ P, + + +; 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 + + ;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 + + + +; 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,[+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, +] + + + ; 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 = +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 +] + ;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 + + \ No newline at end of file diff --git a//fopen.mid.62 b//fopen.mid.62 new file mode 100644 index 0000000..6268b96 --- /dev/null +++ b//fopen.mid.62 @@ -0,0 +1,4722 @@ +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 (,,,,) +; +; - DIRECTION EITHER READ (INPUT) OR PRINT (OUPUT). DEFAULT IS READ + +; - FIRST FILE NAME. DEFAULT INPUT OR OUTPUT. + +; - SECOND FILE NAME. DEFAULT MUDDLE. + +; - DEVICE FROM WHICH TO OPEN. DEFAULT IS DSK. + +; - 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 + + +;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 + +.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) = ,, +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 + + + +;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 + + + + +; 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 + + + +; 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, +] + + +; 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, + + +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," ; 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, + + + +; 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 +] + + +; 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) + + + +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," ; 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 + +] + + +; 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) + + +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 + +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) + + +; 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 + + +; 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 + + +; 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, + + +; 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, + +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, + +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 + +] + +; 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, + + +; 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, +] + +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 + + +; 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, + + +; 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 +] +] + + +; 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, +] + +;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, + +; 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 + ] + +; 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 + 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 + + ; 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 + +; 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 + + ; 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] + + ;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 + ;SUBR TO DO .ACCESS ON A READ CHANNEL +;FORM: +;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,[+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 + +; 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,[+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, + ; 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,[+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 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/ + +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 + + ; 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 +; AND BOTH SUBRS RETURN THE NUMBER OF CHARS READ OR WRITTEN + +; FORMAT FOR PRINTSTRING IS + +; 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 + + ; 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 +] + +; 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 +BCLS11: POP P,0 + HLLZS ACCESS-1(B) + HRRZ C,BUFSTR-1(B) + CAIE C,BUFLNT*5 + PUSHJ P,BFCLOS + POPJ P, + + +; 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 + + ;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 + + + +; 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,[+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, +] + + + ; 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 = +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 +] + ;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 + + \ No newline at end of file diff --git a//gcgdgl.mud.1 b//gcgdgl.mud.1 new file mode 100644 index 0000000..8578f76 --- /dev/null +++ b//gcgdgl.mud.1 @@ -0,0 +1,186 @@ + + + + + + + + ) + (ELSE ">)> + +> + )>> + +) FSP (REDEFINE T)) + #DECL ((REDEFINE) ) + > )> + > + > + <7 .CHN>>>>)> + ;"To hack ugly file names. (TT, 75/10/07)" + <8 .CHN> <9 .CHN> <10 .CHN>>>> + > + + .NAM>> + +) + (NAM + .NM) + (ELSE >)>) + (OC + <10 .CHN>>) + (FIXERS ()) FUNC BKS TEM TT HOLDANY GRP FIXES) + #DECL ((CHN) CHANNEL (NAM) ATOM (OC) (FIXERS) LIST) + )> + > >> + + )> + + >>> + !.FIXERS)> + + )) + COMMENT>> + COMMENT .TEM> !.FIXERS)>)> + > + + BLOCK + >> + !.FIXERS)>)> + >> + > DEFINE> <==? .TEM DEFMAC>> + 1> + VALUE '<2 + .OB>>>> + > + BREAKS>>> + BREAKS> + )> + >> BREAK> + <2 .HOLDANY>>)> + >>)> + > + > + 1>> .FIXERS> + )>) + ( + <==? 3> + VALUE '<2 .OB>>> ATOM> + > RSUBR> + RSUBR>>> + <==? .NM <2 .TEM>>> + CODE> >> + .FIXES> !.FIXERS)>) + ( CODE> + + + + )> + >>> + 1>> .FIXERS> + )> + > PCODE> + + 1 + >>> + !.FIXERS)>)>)>)>> + .GRP> + + + >> + .FIXERS) + .OC> + + + .NAM>> + +> + + > + COMMENT .TEM> + !.L)>)> + >>>> + 1>> .L> + )>> + > + COMMENT>> + > COMMENT .TEM> !.L)>)> + COMMENT>> + > COMMENT>>> + COMMENT .TEM> !.L)>)>) + (> )> + .L> + + (L) LIST) + + )) + + 1> + > ATOM> + > >> + CODE> + >> + .TEM> !.L)>) + ( CODE> + + > + )>)> + PCODE>> + + 1 + >>>> + !.L)>)> + + + 1 + >>> + !.L)> + + )>)>> + .R> + .L> + +> .O>> + + + \ No newline at end of file diff --git a//gcgdgl.nbin.1 b//gcgdgl.nbin.1 new file mode 100644 index 0000000..ab3a95a Binary files /dev/null and b//gcgdgl.nbin.1 differ diff --git a//gcgld.mud.1 b//gcgld.mud.1 new file mode 100644 index 0000000..e69de29 diff --git a//gchack.bin.2 b//gchack.bin.2 new file mode 100644 index 0000000..eec5c55 Binary files /dev/null and b//gchack.bin.2 differ diff --git a//gchack.bin.3 b//gchack.bin.3 new file mode 100644 index 0000000..b2b099a Binary files /dev/null and b//gchack.bin.3 differ diff --git a//gchack.mid.45 b//gchack.mid.45 new file mode 100644 index 0000000..804b865 --- /dev/null +++ b//gchack.mid.45 @@ -0,0 +1,538 @@ + +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 + +  \ No newline at end of file diff --git a//gchack.mid.46 b//gchack.mid.46 new file mode 100644 index 0000000..b2b86f6 --- /dev/null +++ b//gchack.mid.46 @@ -0,0 +1,540 @@ + +TITLE GCHACK + +RELOCATABLE + +.INSRT MUDDLE > + +.GLOBAL FRMUNG,PARBOT,TYPVEC,GCHACK,REHASH,IMPURI,NWORDT,GCDFLG +.GLOBAL TD.LNT,TD.GET,TD.PUT,GCSTOP,GCSBOT,GCHK10,STOSTR,UBIT,PVSTOR,SPSTOR + +UBIT==40000 ; BIT INDICATING VECTOR +.LIST.==400000 + +; THIS IS AN INTERNAL MUDDLE SUBROUTINE TO RUN AROUND GC SPACE DOING +; SOMETHING ARBITRARY TO EVERY ENTITY THEREIN + +; CALL -- +; A/ INSTRUCTION TO BE EXECUTED +; PVP/ NON-ZERO OPTIMIZE--ONLY LOOK AT ATOMS +; PUSHJ P,GCHACK + +; HERE FOR SPECIAL HACKS WHICH DON'T TOUCH STOAGE + +GCHK10: PUSHJ P,GHSTUP + JRST GCHK1 + +GCHACK: PUSHJ P,GHSTUP ; SETUP + MOVE B,CODTOP ; START OFF WITH IMPURE STORAGE + SUBI B,1 ; START AT FIRST WORD +LOPSTO: CAIG B,STOSTR + JRST GCHK1 + HRRE 0,1(B) ; GET INDICATOR OF MODIFICATION + JUMPGE 0,LOSTO ; JUMP IF GARBAGE + PUSHJ P,VHACK ; VHACK + JRST LOPSTO +LOSTO: HLRZ C,1(B) ; BACK OF VECTOR + TRZ C,400000 + SUBI B,(C) ; SKIP OVER VECTOR + JRST LOPSTO + +GCHK1: MOVE B,VECTOP ; NO LOOP THRU GCS + MOVEI B,-2(B) + + +LOOPHK: MOVE C,SVTAB + MOVEM B,(C) + EXCH C,NXTTAB ; SWAP LOCATIONS + EXCH C,SVTAB + TLZ B,.LIST. ; TURN OFF LIST BIT + CAMGE B,GCSBOT ; SEE IF DONE + JRST REHASQ ; SEE IF ASSOCIATIONS ARE GOOD + MOVE C,(B) ; GET ELEMENT + TLNE C,.VECT. ; SEE IF IT IS A VECTOR + JRST VHCK ; JUMP IF IT IS +GLSTHK: GETYP C,(B) ; TYPE OF CURRENT PAIR + MOVE D,1(B) ; AND ITS DATUM + TLO B,.LIST. ; INDICATE A LIST + SKIPL (B) ; SKIP IF MARKED + XCT A ; APPLY INS + SUBI B,2 + JRST LOOPHK +VHCK: PUSHJ P,VHACK ; TO VHACK + JRST LOOPHK + +; NOW DO THE SAME THING TO VECTOR SPACE +VHACK: HLRE D,(B) ; GET TYPE FROM D.W. + TRZ D,.VECT. ; GET RID OF VECTOR INDICATION BIT + HLRZ C,1(B) ; AND TOTAL LENGTH + TRZE C,400000 ; GET RID OF POSSIBLE MARK BIT + JRST MKHAK ; JUMP IF MARKED + SUBI B,(C)-2 ; POINT TO START OF VECTOR + PUSH P,B + SUBI C,2 ; CHECK WINNAGE + JUMPL C,BADV ; FATAL LOSSAGE + PUSH P,C ; SAVE COUNT + JUMPE C,VHACK1 ; EMPTY VECTOR, FINISHED + +; DECIDE BASED ON TYPE WHETHER GENERAL,UNIFORM OR SPECIAL + + JUMPGE D,UHACK ; UNIFORM + TRNE D,377777 ; SKIP IF GENERAL + JRST SHACK ; SPECIAL + +; FALL THROUGH TO GENERAL + +GHACK1: SKIPGE (B) ; CHECK FOR FENCE POST + JRST VHACK1 + GETYP C,(B) ; LOOK A T 1ST ELEMENT + CAIE C,TCBLK + CAIN C,TENTRY ; FRAME ON STACK + SOJA B,EHACK + CAIE C,TUBIND + CAIN C,TBIND ; BINDING BLOCK + JRST BHACK + CAIN C,TGATOM ; ATOM WITH GDECL? + JRST GDHACK + MOVE D,1(B) ; GET DATUM + XCT A ; USER INS +GDHCK1: ADDI B,2 ; NEXT ELEMENT + SOS (P) + SOSLE (P) ; COUNT ELEMENTS + SKIPGE (B) ; OR FENCE POST HIT + JRST VHACK1 + JRST GHACK1 + +; HERE TO GO OVER UVECTORS + +UHACK: CAMN A,[PUSHJ P,SBSTIS] + JRST VHACK1 ; IF THIS SUBSTITUTE, DONT DO UVEC + MOVEI C,(D) ; COPY UNIFORM TYPE + JUMPE PVP,UHACKX ; JUMP IF NOT ONLY ATOMS + ASH C,1 ; COMPUTE SAT + ADD C,TYPVEC+1 + HRRZ C,(C) + ANDI C,SATMSK ; GOT ITS SAT + CAIE C,SCHSTR ; COULD BE SPNAME + JRST .+3 + CAIE C,SATOM ; DON'T BOTHER IF NOT ALL ATOMS + JRST VHACK1 + MOVEI C,(D) +UHACKX: PUSH P,C ; ATFIX CLOBBERS C + SUBI B,1 ; BACK OFF + +UHACK1: MOVE C,(P) + TLO B,UBIT ; TURN ON BIT INDICATING UVECTOR + MOVE D,1(B) ; DATUM + XCT A + SOSLE -1(P) ; COUNT DOEN + AOJA B,UHACK1 + TLZ UBIT + POP P,C + JRST VHACK1 + +; HERE TO HACK VARIOUS FLAVORS OF SPECIAL GOODIES + +SHACK: ANDI D,377777 ; KILL EXTRA CRUFT + CAIN D,SATOM + JRST ATHACK + CAIE D,STPSTK ; STACK OR + CAIN D,SPVP ; PROCESS + JRST GHACK1 ; TREAT LIKE GENERAL + CAIN D,SASOC ; ASSOCATION + JRST ASHACK + CAIG D,NUMSAT ; TEMPLATE MAYBE? + JRST BADV ; NO CHANCE + ADDI C,(B) ; POINT TO DOPE WORDS + SUBI D,NUMSAT+1 + HRLI D,(D) + ADD D,TD.LNT+1 + JUMPGE D,BADV ; JUMP IF INVALID TEMPLATE HACKER + + CAMN A,[PUSHJ P,SBSTIS] + JRST VHACK1 + +TD.UPD: PUSH P,A ; INS TO EXECUTE + XCT (D) + HLRZ E,B ; POSSIBLE BASIC LENGTH + PUSH P,[0] + PUSH P,E + MOVEI B,(B) ; ISOLATE LENGTH + PUSH P,C ; SAVE POINTER TO OBJECT + + PUSH P,[0] ; HOME FOR VALUES + PUSH P,[0] ; SLOT FOR TEMP + PUSH P,B ; SAVE + SUB D,TD.LNT+1 + PUSH P,D ; SAVE FOR FINDING OTHER TABLES + JUMPE E,TD.UP2 ; NO REPEATING SEQ + ADD D,TD.GET+1 ; COMP LNTH OF REPEATING SEQ + HLRE D,(D) ; D ==> - LNTH OF TEMPLATE + ADDI D,(E) ; D ==> -LENGTH OF REP SEQ + MOVNS D + HRLM D,-5(P) ; SAVE IT AND BASIC + +TD.UP2: SKIPG D,-1(P) ; ANY LEFT? + JRST TD.UP1 + + MOVE E,TD.GET+1 + ADD E,(P) + MOVE E,(E) ; POINTER TO VECTOR IN E + MOVEM D,-6(P) ; SAVE ELMENT # + SKIPN B,-5(P) ; SKIP IF "RESTS" EXIST + SOJA D,TD.UP3 + + MOVEI 0,(B) ; BASIC LNT TO 0 + SUBI 0,(D) ; SEE IF PAST BASIC + JUMPGE 0,.-3 ; JUMP IF O.K. + MOVSS B ; REP LNT TO RH, BASIC TO LH + IDIVI 0,(B) ; A==> -WHICH REPEATER + MOVNS A + ADD A,-5(P) ; PLUS BASIC + ADDI A,1 ; AND FUDGE + MOVEM A,-6(P) ; SAVE FOR PUTTER + ADDI E,-1(A) ; POINT + SOJA D,.+2 + +TD.UP3: ADDI E,(D) ; POINT TO SLOT + XCT (E) ; GET THIS ELEMENT INTO A AND B + TLO A,UBIT ; INDICATE ITS A ANY + MOVEM A,-3(P) ; SAVE TYPE FOR LATER PUT + MOVEM B,-2(P) + GETYP C,A ; TYPE TO C + MOVE D,B ; DATUME + MOVEI B,-3(P) ; POINTER TO HOME + MOVE A,-7(P) ; GET INS + XCT A ; AND DO IT + MOVE C,-4(P) ; GET POINTER FOR UPDATE OF ELEMENT + MOVE E,TD.PUT+1 + SOS D,-1(P) ; RESTORE COUNT + ADD E,(P) + MOVE E,(E) ; POINTER TO VECTOR IN E + MOVE B,-6(P) ; SAVED OFFSET + ADDI E,(B)-1 ; POINT TO SLOT + MOVE A,-3(P) ; RESTORE TYPE WORD + MOVE B,-2(P) + XCT (E) ; SMASH IT BACK + JRST TD.LOS +TD.WIN: MOVE C,-4(P) + JRST TD.UP2 + +TD.LOS: SKIPN GCDFLG + FATAL TEMPLATE LOSSAGE + JRST TD.WIN + +TD.UP1: MOVE A,-7(P) ; RESTORE INS + SUB P,[10,,10] + MOVSI D,400000 ; RESTORE MARK/UNMARK BIT + JRST VHACK1 + +; FATAL LOSSAGE ARRIVES HERE + +BADV: FATAL GC SPACE IN A BAD STATE + +; HERE TO HACK SPECIAL CRUFT IN GENERAL VECTORS (STACKS) + +EHACK: JUMPE PVP,EHACKX + ADDI B,FRAMLN+1 ; SKIP THE FRAME + JRST GHACK1 + +EHACKX: HRRZ D,1(B) + CAILE D,HIBOT + JRST EHCK10 + PUSH P,1(B) + HRL D,(D) + MOVEI C,TVEC + CAME A,[PUSHJ P,SBSTIS] + XCT A ; XCT SUBSTITUTE + POP P,C ; RESTORE TYPE + HLLM C,1(B) ; SMASH BACK +EHCK10: ADDI B,1 + MOVSI D,-FRAMLN+1 ; SET UP AOBJN PNTR + +EHACK1: HRRZ C,ETB(D) ; GET 1ST TYPE + PUSH P,D ; SAVE AOBJN + MOVE D,1(B) ; GET ITEM + CAME A,[PUSHJ P,SBSTIS] ; DONT IF SUBSTITUTE DIFFERENT + XCT A ; USER GOODIE + POP P,D ; RESTORE AOBJN + ADDI B,1 ; MOVE ON + SOSLE (P) ; ALSO COUNT IN TOTAL VECTOR + AOBJN D,EHACK1 + AOJA B,GHACK1 ; AND GO ON + +; TABLE OF ENTRY BLOCK TYPES + +ETB: TTB + TAB + TSP + TPDL + TTP + TWORD + +; HERE TO GROVEL OVER BINDING BLOCKS + +BHACK: MOVEI C,TATOM ; ALSO TREEAT AS ATOM + MOVE D,1(B) + CAME A,[PUSHJ P,SBSTIS] ; DONT IF SUBSTITUTE DIFFERENT + XCT A + PUSHJ P,NXTGDY ; NEXT GOODIE + PUSHJ P,NXTGDY ; AND NEXT + MOVEI C,TSP ; TYPE THE BACK LOCATIVE + SKIPGE D,1(B) + XCT A + PUSHJ P,BMP ; AND NEXT + PUSH P,B + HLRZ D,-2(B) ; DECL POINTER + MOVEI B,0 ; MAKE SURE NO CLOBBER + MOVEI C,TDECL + XCT A ; DO THE THING BEING DONE + POP P,B + HRLM D,-2(B) ; FIX UP IN CASE CHANGED + JRST GHACK1 + +; HERE TO HACK ATOMS WITH GDECLS + +GDHACK: CAMN A,[PUSHJ P,SBSTIS] + JRST GDHCK1 + + MOVEI C,TATOM ; TREAT LIKE ATOM + MOVE D,1(B) + XCT A + HRRZ D,(B) ; GET DECL + JUMPE D,GDHCK1 + CAIN D,-1 ; WATCH OUT FOR MAINFEST + JRST GDHCK1 + PUSH P,B ; SAVE POINTER + MOVEI B,0 + MOVEI C,TLIST + XCT A + POP P,B + HRRM D,(B) ; RESET + JRST GDHCK1 + + +; HERE TO HACK ATOMS + +ATHACK: JUMPN PVP,BUCKHK ; IF ONLY CHANGING ATOMS, IGNROE OBLIST + MOVEI C,TOBLS ; GET TYPE + HRRZ D,2(B) ; AND DATUM + JUMPE D,BUCKHK ; NOT ON OBLIST, SO FLUSH + CAMGE D,VECBOT + MOVE D,(D) ; GET REAL OBLIST POINTER + HRLI D,-1 + CAMN A,[PUSHJ P,SBSTIS] ; DONT IF SUBSTITUTE DIFFERENT + JRST VHACK1 + PUSH P,B + MOVEI B,0 + XCT A + POP P,B + HRRM D,2(B) +BUCKHK: CAMN A,[PUSHJ P,SBSTIS] ; DONT IF SUBSTITUTE DIFFERENT + JRST VHACK1 + HLRZ D,2(B) + JUMPE D,VHACK1 + PUSH P,B + PUSH P,D + MOVEI B,-1(P) ; FAKE OUT TO MUNG STACK +; HLRZ B,1(D) +; ANDI B,377777 +; SUBI B,2 +; HRLI B,(B) +; SUB D,B ; D NOW ATOM PNTR + MOVEI C,TATOM + XCT A +; HLRE B,D +; SUB D,B + POP P,D + POP P,B + HRLM D,2(B) + JRST VHACK1 + +; HERE TO HACK ASSOCIATION BLOCKS + +ASHACK: MOVEI D,3 ; COUNT GOODIES TO MARK + +ASHAK1: PUSH P,D + MOVE D,1(B) + GETYP C,(B) + PUSH P,D ; SAVE POINTER + XCT A + POP P,D ; GET OLD BACK + CAME D,1(B) ; CHANGED? + TLO E,400000 ; SET NON-VIRGIN FLAG + POP P,D + PUSHJ P,BMP ; TO NEXT + SOJG D,ASHAK1 + +; HERE TO GOT TO NEXT VECTOR + +VHACK1: MOVE B,-1(P) ; GET POINTER + SUB P,[2,,2] ; FLUSH CRUFT + SUBI B,2 ; FIX UP PTR + POPJ P, + +; HERE TO SKIP OVER MARKED VECTOR + +MKHAK: SUBI B,(C) ; POINT BELOW VECTOR + POPJ P, + +; ROUTINE TO GET A GOODIE + +NXTGDY: GETYP C,(B) +NXTGD1: MOVE D,1(B) + XCT A ; DO IT TO IT +BMP: SOS -1(P) + SOSG -1(P) + JRST BMP1 + ADDI B,2 + POPJ P, +BMP1: SUB P,[1,,1] + JRST VHACK1 + +REHASQ: JUMPL E,REHASH ; HASH TABLE RAPED, FIX IT + POPJ P, + + +MFUNCTION SUBSTI,SUBR,[SUBSTITUTE] + +;THIS FUNCTION CODED BY NDR IS AN INCREDIBLE WAY TO +;KILL YOURSELF, EVEN IF YOU THINK YOU REALLY KNOW WHAT +;YOU ARE DOING. +;IT DOES A MINI-GC CHANGING EACH REFERENCE OF THE +;SECOND ITEM TO A REFERENCE OF THE FIRST ITEM, HA HA HA. +;BOTH ITEMS MUST BE OF THE SAME TYPE OR +;IF NOT, NEITHER CAN BE A TYPE REQUIRING TWO WORDS +; OF STORAGE, AND SUBSTITUTION CANT BE DONE IN +; UVECTORS WHEN THEY ARE DIFFERENT, AS WELL AS IN +; A FEW OTHER YUCKY PLACES. +;RETURNS ITEM TWO--THE ONLY WAY TO GET YOUR HANDS BACK ON IT + + ENTRY 2 + + +SBSTI1: GETYP A,2(AB) + CAIE A,TATOM + JRST SBSTI2 + MOVE B,3(AB) ; IMPURIFY HASH BUCKET MAYBE? + PUSHJ P,IMPURI + GETYP A,(AB) ; ATOM FOR ATOM SUBS? + CAIE A,TATOM + JRST SBSTI2 ; NO + MOVE B,3(AB) ; SEE IF OLD GUY + HLRE A,B + SUBM B,A ; POINT TO DOPE + HRRZ A,(A) ; POSSIBLE TYPE CODE + JUMPE A,SBSTI2 ; NOT A TYPE, GO + MOVE B,1(AB) + HLRE C,B + SUBM B,C + HRRZ C,(C) ; GET OTHER POSSIBLE CODE + JUMPN C,BADTYP + PUSH P,A + PUSHJ P,IMPURI ; IMPURIFY FOR SMASH + POP P,A + MOVE B,1(AB) + HLRE C,B + SUBM B,C + HRRM A,(C) + +SBSTI2: GETYP A,2(AB) ; GET TYPE OF SECOND ARG + MOVE D,A + PUSHJ P,NWORDT ; AND STORAGE ALLOCATION + MOVE E,A + GETYP A,(AB) ; GET TYPE OF FIRST ARG + MOVE B,A + PUSHJ P,NWORDT + CAMN B,D ; IF TYPES SAME, DONT CHECK FOR ALLOCATION + JRST SBSTI3 + CAIN E,1 + CAIE A,1 + JRST SBSTIL ; LOOSE, NOT BOTH ONE WORD GOODIES + +SBSTI3: MOVEI C,0 + CAIN D,0 ; IF GOODIE IS OF TYPE ZERO + MOVEI C,1 ; USE TYPE 1 TO KEEP INFO FROM CLOBBERAGE + PUSH TP,C + SUBI E,1 + PUSH TP,E ; 1=DEFERRED TYPE ITEM, 0=ELSE + PUSH TP,C + PUSH TP,D ; TYPE OF GOODIE + PUSH TP,C + PUSH TP,[0] + CAIN D,TLIST + AOS (TP) ; 1=TYPE LIST, 0=ELSE + PUSH TP,C + PUSH TP,2(AB) ; TYPE-WORD + PUSH TP,C + PUSH TP,3(AB) ; VALUE-WORD + PUSH TP,(AB) + PUSH TP,1(AB) ; TYPE-VALUE OF THINGS TO CHANGE INTO + MOVE A,[PUSHJ P,SBSTIR] + CAME B,D ; IF NOT SAME TYPE, USE DIFF MUNGER + MOVE A,[PUSHJ P,SBSTIS] + MOVEI PVP,0 ; INDICATE NOT SPECIAL ATOM THING + PUSHJ P,GCHACK ; DO-IT + MOVE A,-4(TP) + MOVE B,-2(TP) + JRST FINIS ; GIVE THE LOOSER A HANDLE ON HIS GOODIE + +SBSTIR: CAME D,-2(TP) + JRST LSUB ; THIS IS IT + CAME C,-10(TP) + JRST LSUB ; IF ITEM CANT BE SAME CHECK FOR LISTAGE + JUMPE B,LSUB+1 ; WE GOT HOLD OF A FUNNY GOODIE, JUST IGNORE IT + MOVE 0,(TP) + MOVEM 0,1(B) ; SMASH IT + MOVE 0,-1(TP) ; GET TYPE WORD + SKIPE -12(TP) ; IF THIS IS A DEFFERABLE ITEM THEN WE MUST + MOVEM 0,(B) ; ALSO SMASH THE TYPE WORD SLOT + +LSUB: SKIPN -6(TP) ; IF WE ARE LOOKING FOR LISTS, LOOK ON + POPJ P, ; ELSE THATS ALL + TLNN B,.LIST. ; SEE IF A LIST + POPJ P, ; WELL NO LIST SMASHING THIS TIME + HRRZ 0,(B) ; GET ITS LIST POINTER + CAME 0,-2(TP) + POPJ P, ; THIS ONE DIDNT MATCH + MOVE 0,(TP) ; GET THE NEW REST OF THE LIST + HRRM 0,(B) ; AND SMASH INTO THE REST OF THE LIST + POPJ P, + +SBSTIS: CAMN D,-2(TP) + CAME C,-10(TP) + POPJ P, + SKIPN B ; SEE IF THIS IS A FUNNY GOODIE WE NO TOUCHIE + POPJ P, + MOVE 0,(TP) + MOVEM 0,1(B) ; KLOBBER VALUE CELL + MOVE 0,-1(TP) + HLLM 0,(B) ; KLOBBER TYPE CELL, WHICH WE KNOW IS THERE + POPJ P, + +SBSTIL: ERRUUO EQUOTE CANT-SUBSTITUTE-WITH-STRING-OR-TUPLE-AND-OTHER +BADTYP: ERRUUO EQUOTE SUBSTITUTE-TYPE-FOR-TYPE + +GHSTUP: HRRZ E,TYPVEC+1 ; SET UP TYPE POINTER + HRLI E,C ; WILL HAVE TYPE CODE IN C + SETOM 1(TP) ; FENCE POST PDL + PUSH P,A + MOVEI A,(TB) + PUSHJ P,FRMUNG ; MUNG CURRENT FRAME + POP P,A + POPJ P, + + +IMPURE + +; LOCATION TO REMEMBER PREVIOUS VALUES + +SVTAB: SVLOC1 +NXTTAB: SVLOC2 + +SVLOC1: 0 +SVLOC2: 0 + +PURE + +END + + \ No newline at end of file diff --git a//initm.bin.17 b//initm.bin.17 new file mode 100644 index 0000000..a0e2df9 Binary files /dev/null and b//initm.bin.17 differ diff --git a//initm.mid.371 b//initm.mid.371 new file mode 100644 index 0000000..1134e59 --- /dev/null +++ b//initm.mid.371 @@ -0,0 +1,1360 @@ +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 +.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 + +;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 + + ; 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 \0/9\] + MOVE D,[ASCII \B/1Q\] + MOVE E,[ASCIZ \ * \] ;TERMINATE + POPJ P, ; GO + +; 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 + + +; 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 + +; 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 + + +;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, + ;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 /_<-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 + \ No newline at end of file diff --git a//initm.mid.373 b//initm.mid.373 new file mode 100644 index 0000000..bbd8fe6 --- /dev/null +++ b//initm.mid.373 @@ -0,0 +1,1360 @@ +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 +.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 + +;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 + + ; 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 \0/9\] + MOVE D,[ASCII \B/1Q\] + MOVE E,[ASCIZ \ * \] ;TERMINATE + POPJ P, ; GO + +; 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 + + +; 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 + +; 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 + + +;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, + ;SET UP LIST OF INTERNAL NAMES AND ADDRESS NEEDED BY COMPILER + +VECTGO DUMMY1 + +IRP A,,[FINIS,SPECBIND,WNA,WRONGT,$TLOSE,CALER1,POPUNW +ILOC,IGLOC,IDVAL,IDVAL1,ILVAL,IGVAL,INTFLG,LCKINT,ONINT,TYPLOO,TDEFER +IFALSE,UNAS,UNBOU,RCALL,SEGMNT,SEGLST,NUMPRI,OPSYS,SSPEC1,COMPERR +MAKACT,MAKENV,BFRAME,TTP,TTB,$TTP,$TTB,MAKTUP,TPALOC,IBIND,SSPECS +CILVAL,CISET,CIGVAL,CSETG,IBLOK1,IBLOCK,CLLOC,CGLOC,CASSQ,CGASSQ +CILNT,CILNQ,CILEGQ,CEMPTY,CIEQUA,CIREST,CINTH,CIAT,CSETLO,CIN +CIPUT,CIGET,CIGETL,CIMON,CISTRU,CIMEMQ,CIMEMB,CITOP,CIBACK,TYPSEG +C1CONS,CICONS,CIUVEC,CIVEC,IIFORM,IILIST,CISTNG,HITOP,INCR1,TYPG,VALG,TESTR +OTBSAV,CITYPE,CFRAME,CARGS,CFUNCT,CUTYPE,CPTYPE,CTYPEP,CTYPEQ,CCHUTY +CIREMA,RTFALS,CIPUTP,CIGETP,CIGTPR,MPOPJ,TAB,$TAB,ICONS,CSTO,DSTO,NTPALO +CPLUS,CTIMES,CTIME,CDIVID,CMINUS,CLQ,CLEQ,CGQ,CGEQ,CLOG,CSIN,CCOS,CATAN,CSQRT +CFIX,CFLOAT,CEXP,CRAND,CINEQU,SPECBND,PGGIVE,PGFIND,MTYO,CMIN,CMAX,RCL,R1C,W1C +CALLTY,CTYPEC,CTYPEW,NOTTY,CHKAB,CTMPLT,IUNWIN,UNWIN2,NOSHUF,ROOT,ERROBL,INTOBL +CINSER,CIRMV,CLOOKU,CATOM,CIPNAM,ISTRCM,CITERP,CIPRIN,CIPRN1,CIPRNC,CGFALS +CPATM,CP1ATM,CPCATM,CPSTR,CP1STR,CPCSTR,CPCH,CREADC,CNXTCH,CREDC1,CNXTC1 +CGBOUN,IIGLOC,MAKTU2,CIFLTZ,CIUPRS,SAT,TFA,WTYP,NAPT,PTYPE,APLQ,PURBOT,GCSBOT +GLOTOP,TYPVEC,1STEPR,LSTRES,NODES,MAINPR,CVTYPE,CSPNAM,CSBSTR,INTBCK,CICRLF +CERR1,CERR2,CERR3,CANDP,CORP,CSQUTA,CIMAGE,ATOSQ,CFILLE,CPRTYC,FMPOPJ +TD.PUT,TD.GET,TD.LNT,CBYTES,MARK,MARK2G,TD.AGC,DSTORE,RCLV,NUMSAT,RMCALL,NPRFLG +NSPOPJ,NFPOPJ,PURCLN,FRETOP,PURVEC,SWAPGC,NTTYPE,CLRSTR,VECBOT] + .GLOBAL A + ADDSQU A +TERMIN + +VECRET + +; ROUTINE TO SORT AND PURIFY SQUOZE TABLE + +SQSETU: MOVE A,[SQUTBL-SQULOC+2,,SQUTBL] + MOVEI 0,1 +SQ2: MOVE B,(A) + CAMG B,2(A) + JRST SQ1 + MOVEI 0,0 + EXCH B,2(A) + MOVEM B,(A) + MOVE B,1(A) + EXCH B,3(A) + MOVEM B,1(A) +SQ1: ADD A,[2,,2] + JUMPL A,SQ2 + JUMPE 0,SQSETU +IFE ITS,[ +STSQU: MOVE B,[440700,,SQBLK] + PUSHJ P,MNGNAM + HRROI B,SQBLK + MOVSI A,600001 + GTJFN + FATAL CANT MAKE FIXUP FILE + MOVEI E,(A) + MOVE B,[440000,,100000] + OPENF + FATAL CANT OPEN FIXUP FILE + MOVE B,[444400,,SQUTBL] + MOVNI C,SQULOC-SQUTBL + SOUT + MOVEI A,(E) + CLOSF + JFCL + MOVE A,[SQUTBL-SQULOC,,SQUTBL] + MOVEM A,SQUPNT" +] +IFN ITS,[ +.GLOBAL CSIXBT +STSQU: MOVE C,MUDSTR+2 ; CALCULATE SECOND FILE NAME FOR SQUOZE TABLE + PUSHJ P,CSIXBT + HRRI C,(SIXBIT/TAB/) ; TABxxx IS SECOND NAME OF FILE + MOVSS C + MOVEM C,SQBLK+2 ; STORE IN APPROPRIATE BLOCKS + MOVEM C,SQWBLK+2 + .SUSET [.SSNAM,,SQDIR] + .OPEN GCHN,SQWBLK ; OPEN FILE + FATAL CAN'T CREATE SQUOZE FILE + MOVE A,[SQUTBL-SQULOC,,SQUTBL] + MOVEM A,SQUPNT" + .IOT GCHN,A + .CLOSE GCHN ; CLOSE THE CHANNEL +] + POPJ P, + +RHITOP: 0 + +OBSZ: 151. + 13. + 151. + 151. + 317. + +OBTBL2: ROOT+1 + ERROBL+1 + INTOBL+1 + MUDOBL+1 + INITIAL+1 + +OBTBL: INITIAL+1-TVSTRT+TVBASE + MUDOBL+1-TVSTRT+TVBASE + INTOBL+1-TVSTRT+TVBASE + ERROBL+1-TVSTRT+TVBASE + ROOT+1-TVSTRT+TVBASE +OBNAM: MQUOTE INITIAL + IMQUOTE MUDDLE + MQUOTE INTERRUPTS + MQUOTE ERRORS + MQUOTE ROOT + +OBTBL1: INITIAL+1 + MUDOBL+1 + INTOBL+1 + ERROBL+1 + ROOT+1 + + +IFN ITS,[ +SQWBLK: SIXBIT / 'DSK/ + SIXBIT /SQUOZE/ + SIXBIT /TABLE/ +] +IFE ITS,[ +MNGNAM: MOVE A,[440700,,MUDSTR+2] ; FOR NAME HACKING + ILDB 0,A ; SEE IF IT IS A VERSION + CAIN 0,177 + POPJ P, + MOVE A,B + ILDB 0,A + CAIN 0,"X ; LOOK FOR X'S + JRST .+3 + MOVE B,A + JRST .-4 + + MOVE A,[440700,,MUDSTR+2] + ILDB 0,A + IDPB 0,B + ILDB 0,A + IDPB 0,B + ILDB 0,A + IDPB 0,B + POPJ P, +] + +IFN ITS,[ +.GLOBAL VCREATE,MUDSTR + +DEBUG: MOVE E,[440600,,[SIXBIT /EXPERIMENTAL/]] + MOVEI 0,12. + JRST STUFF + +VCREATE: .SUSET [.SSNAM,,[SIXBIT /MUDSYS/]] + .OPEN 0,OP% + .VALUE + MOVEI 0,0 ; SET 0 TO DO THE .RCHST + .RCHST 0 + .CLOSE 0 + .FDELE DB% + .VALUE + MOVE E,[440600,,B] + MOVEI 0,6 +STUFF: MOVE D,[440700,,MUDSTR+2] +STUFF1: ILDB A,E ; GET A CHAR + CAIN A,0 ;SUPRESS SPACES + MOVEI A,137 ;RUBOUT'S DON'T TYPE OUT + ADDI A,40 ; TO ASCII + IDPB A,D ; STORE + SOJN 0,STUFF1 + SETZM 34 + SETZM 35 + SETZM 36 + .VALUE + +OP%: 1,,(SIXBIT /DSK/) + SIXBIT /MUD%/ + SIXBIT />/ + +DB%: (SIXBIT /DSK/) + SIXBIT /MUD%/ + SIXBIT /_<-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 + \ No newline at end of file diff --git a//interr.bin.28 b//interr.bin.28 new file mode 100644 index 0000000..46090dd Binary files /dev/null and b//interr.bin.28 differ diff --git a//interr.bin.30 b//interr.bin.30 new file mode 100644 index 0000000..492b902 Binary files /dev/null and b//interr.bin.30 differ diff --git a//interr.mid.419 b//interr.mid.419 new file mode 100644 index 0000000..5473cab --- /dev/null +++ b//interr.mid.419 @@ -0,0 +1,2890 @@ + +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 + + +; 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 +] + +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 +] +] + + +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 , MOVEI A,<1_<35.->> +IFLE MOVSI A,(<1_<35.->>) + + 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 +] + +; 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 + + ; 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 + +; 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 + + +; 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 + + + +; 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, + +; 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 + +; 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, + + +; 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 + + + +; 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 + + + +; 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 +] + +; 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 + +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,- ; 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 +] + + +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, + +; 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, + ; 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 + +; 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" + + +;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 + + + 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 + +] + +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 + + +;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 +] + + +; 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 + + +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 + \ No newline at end of file diff --git a//interr.mid.425 b//interr.mid.425 new file mode 100644 index 0000000..8e73375 --- /dev/null +++ b//interr.mid.425 @@ -0,0 +1,2898 @@ + +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 + + +; 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 +] + +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 +] +] + + +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 , MOVEI A,<1_<35.->> +IFLE MOVSI A,(<1_<35.->>) + + 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 +] + +; 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 + + ; 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 + +; 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 + + +; 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 + + + +; 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, + +; 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 + +; 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, + + +; 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 + + + +; 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 + + + +; 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 +] + +; 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 + +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,- ; 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 +] + + +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, + +; 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, + ; 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 + +; 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" + + +;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 + + + 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 + +] + +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 + + +;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 +] + + +; 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 + + +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 + \ No newline at end of file diff --git a//ipc.bin.2 b//ipc.bin.2 new file mode 100644 index 0000000..f5a7413 Binary files /dev/null and b//ipc.bin.2 differ diff --git a//ipc.mid.19 b//ipc.mid.19 new file mode 100644 index 0000000..f171574 --- /dev/null +++ b//ipc.mid.19 @@ -0,0 +1,815 @@ +TITLE IPC -- IPC COMMUNICATIONS HANDLER FOR MUDDLE + +RELOCATABLE + +; N. RYAN October 1973 + +.INSRT MUDDLE > + +;THIS PROGRAM HAS ENTRIES SEND, SEND-WAIT, IPC-OFF, +; AND IPC-HANDLER. + +;THESE HANDLE THE IPC DEVICE. + +;SEND AND SEND-WAIT SEND OUT A MESSAGE ON THE IPC DEVICE. +;THEY TAKE 6 ARGUMENTS, THE FIRST THREE OF WHICH ARE NECESSARY + +; SEND ( ) + +; -- STRING USED AS SIXBIT FOR NAME 1 +; -- STRING USED AS SIXBIT FOR NAME 2 +; -- THE MESSAGE TO SEND, EITHER A STRING OR A UVECTOR OF TYPE WORD +; -- THE TYPECODE TO SEND, A FIXED NUMBER, DEFAULT 0 +; -- STRING USED AS SIXBIT FOR MY NAME 1 +; -- STRING USED AS SIXBIT FOR MY NAME 2 + +; SEND -- TRIES TO SEND IMMEDIATELY, ELSE RETURNS FALSE WITH MESSAGE +; SEND-WAIT -- HANGS UNTIL MESSAGE CAN BE SENT + +; IPC-OFF -- NO ARGUMENTS, CLOSES ALL IPC-RECEIVE CHANNELS + +; IPC-ON -- OPENS AN IPC RECEIVE CHANNEL +; IT TAKES 2 OPTIONAL ARGS WHICH ARE THE NAMES TO LISTEN ON, +; THE DEFAULT IS UNAME, JNAME + + + + ; DEFINITIONS FOR STRUCTURE OF IPC BUFFER + +BUFL==200. ;LENGTH OF IPC BUFFER +BUFHED==3 ;LENGTH OF BUFFER HEADER +CONT==400000 ;LEFT HALF BIT INDICATING THIS IS CONTINUATION +INCOMP==200000 ;LEFT HALF BIT INDICATING MESSAGE COMPLETE +ASCIMS==100000 ;LEFT HALF BIT INDICATING THIS IS PACKED ASCII MESSAGE +MESHED==2 ;LENGTH OF CRUFT AT FRONT OF FIRST MESSAGE +MAXMES==20000. ;MAXIMUM LENGTH IN WORDS OF MESSAGES MUDDLE WILL LIKE + + +.GLOBAL STRTO6,SAT,IBLOCK,MOPEN,MCLOSE,GFALS,TTOCHN,INCONS,MASK2,INTHLD +.GLOBAL IPCS1,IBLOCK,IPCGOT,DIRQ,GIBLOK,6TOCHS,CAFRE,CAFRET,IPCBLS,PVSTOR,SPSTOR + +; DEFINITIONS OF BITS IN THE OPEN BLOCK FOR IPC DEVICE + +RFROMA==1 ;READ FROM ANY +RFROMS==2 ;READ FROM SPECIFIC +SANDH==4 ;SEND AND HANG +SIMM==10 ;SEND IMMEDIATE +USEUJ==20 ;USE MY UNAME, JNAME + + +;BUFFERFORMAT: HISNAME1 +; HISNAME2 +; COUNT +; BITS,,LENGTH +; TYPE + +;WHERE ASCII MESSAGES CONSIST OF A COUNT FOLLOWED BY CHARS +;THE LENGTH IS THE LENGTH OF THE TYPE WORD PLUS ALL THE BODIES + + + +; THE FOLLOWING IS THE HANDLER WHICH WILL NORMALLY BE PUT ON THE +; IPC INTERRUPT AND SO SERVE AS THE DEFAULT HANDLER FOR IPC RECEIVES +; WHICH ARE NOT CAUGHT BY THE USER AND SERVICED IN SOME OTHER MANNER + +; NOTE THAT AS AN EXPERIMENT, MESSAGE WHICH ARE ASCII STRINGS WITH TYPE-CODE 1 +; ARE CONSIDERED AS EXECUTE COMMANDS. THEY ARE FIRST PRINTED OUT, +; THEN THEY ARE PARSED AND THAT RESULT IS EVALED. +; ALL MESSAGES OF OTHER TYPES ARE CONSIDERED MERELY AS MESSAGES TO BE +; PRINTED OUT WITH AN INDICATING OF WHO THEY ARE FROM + +; THE ARGS WHICH THIS SUBROUTINE IS CALLED WITH BY INTERRUPT ARE +; +; WHERE THE LAST TWO ARE OPTIONAL AND ONLY GIVEN IF THE SOCKET WAS NOT +; LISTENING ON THE DEFAULT UNAME,JNAME COMBINATION. + + +MFUNCTION IPCH,SUBR,[IPC-HANDLER] + + ENTRY + + PUSH P,[0] ;SAVE A SLOT FOR LATTER USE + HLRE 0,AB ;CHECK THE NUMBER OF ARGS WE GOT + CAMLE 0,[-8.] ;NEED AT LEAST 4 ARGS + JRST WNA + GETYP E,(AB) ;CHECK TYPE OF FIRST ARG + CAIN E,TCHSTR ;IS IT A CHARACTER STRING + JRST .+3 + CAIE E,TUVEC ;IF NOT IT MUST BE A UVECTOR + JRST WTYP1 ;IF NEITHER THEN WE HAVE A LOOSER + GETYP A,2(AB) ;GET TYPE OF MESSAGE TYPE, SHOULD BE A FIX + CAIE A,TFIX + JRST WTYP2 ;IF NOT FIX COMPLAIN + GETYP A,4(AB) + CAIE A,TCHSTR ;HIS NAME 1 SHOULD BE CHAR STRING + JRST WTYP + GETYP A,6(AB) + CAIE A,TCHSTR + JRST WTYP ;HIS NAME 2 SHOULD BE CHAR STRING + CAML 0,[-8.] ;SEE IF WE HAVE 4 OR 6 ARGS + JRST IPCH1 ;WE ONLY HAD 4 ARGS + CAME 0,[-12.] ;THEN WE MUST HAVE EXACTLY 6 ARGS + JRST WNA + GETYP A,(AB)8. + CAIE A,TCHSTR + JRST WTYP ;CHECK TO SEE THE MY NAME 1 IS STRING + GETYP A,10.(AB) + CAIE A,TCHSTR + JRST WTYP ;CHECK TO SEE THAT MY NAME 2 IS STRING + +IPCH1: PUSH TP,$TCHAN + PUSH TP,TTOCHN+1 ;PUSH ON TTY OUTPUT CHANNEL TO CALL TERPRI + MCALL 1,TERPRI + PUSH TP,$TCHSTR + PUSH TP,CHQUOTE [IPC MESSAGE FROM ] + PUSH TP,$TCHAN + PUSH TP,TTOCHN+1 + MCALL 2,PRINC ;PRINT OUT BLURB TO TELL LOOSER WHATS HAPPENING + PUSH TP,4(AB) + PUSH TP,5(AB) ;OUTPUT HIS NAME 1 + PUSHJ P,TO ;JUMP OUT OUTPUTTER OVER TTY OUTPUT CHANNEL + PUSHJ P,STO ;JUMP TO SPACE OUTPUTTER OVER TTY OUTPUT CHANNEL + PUSH TP,6(AB) + PUSH TP,7(AB) ;OUTPUT NAME 2 + PUSHJ P,TO + MOVE E,3(AB) ;MESSAGE TYPE + JUMPE E,IPCH3 ;IF MESSAGE TYPE 0 DO NOTHING ABOUT IT + CAIE E,1 ;IF 1 SEE IF THIS IS EXECUTE MESSAGE + JRST IPCH2 ;IF NOT TELL LOOSER ABOUT THIS MESSAGE TYPE + GETYP 0,(AB) + CAIE 0,TCHSTR ;SEE IF WE HAVE STRING + JRST IPCH2 ;IF NOT THIS CANT BE EXECUTE MESSAGE + AOS (P) ;SET FLAG TO INDICATE EXECUTE MESSAGE + PUSH TP,$TCHSTR + PUSH TP,CHQUOTE [ EXECUTE] + PUSHJ P,TO ;TELL THE LOOSER HE IS GETTING WHAT HE DESERVES + JRST IPCH3 +IPCH2: PUSH TP,$TCHSTR + PUSH TP,CHQUOTE [ TYPE ] + PUSHJ P,TO + PUSH TP,2(AB) + PUSH TP,3(AB) ;PUSH ON THE MESSAGE TYPE + PUSHJ P,TO +IPCH3: HLRE 0,AB + CAME 0,[-12.] ;SEE IF WE HAVE 6 ARGS AND SO MUST TELL HIM WHO MESS IS FOR + JRST IPCH4 ;IF NOT DONT WORRY + PUSH TP,$TCHSTR + PUSH TP,CHQUOTE [ TO ] + PUSHJ P,TO + PUSH TP,8.(AB) + PUSH TP,9.(AB) ;PUSH ON MY NAME 1 + PUSHJ P,TO + PUSHJ P,STO ;LEAVE SPACE BETWEEN NAMES + PUSH TP,10.(AB) ;PUSH ON MY NAME 2 + PUSH TP,11.(AB) + PUSHJ P,TO +IPCH4: PUSH TP,(AB) ;PUSH ON THE ACTUAL GOODIE + PUSH TP,1(AB) + PUSH TP,$TCHAN + PUSH TP,TTOCHN+1 + MCALL 2,PRINT ;AND PRINT IT OUT + SKIPN (P) ;TEST TO SEE IF WE MUST EXECUTE THIS BAG BITTER + JRST IPCHND + PUSH TP,(AB) + PUSH TP,1(AB) + MCALL 1,PARSE ;PARSE HIS CRUFT + PUSH TP,A + PUSH TP,B + MCALL 1,EVAL ;THEN EVAL THE RESULT +IPCHND: PUSH TP,$TCHAN + PUSH TP,TTOCHN+1 + MCALL 1,TERPRI + MOVSI A,TATOM + MOVE B,IMQUOTE T + JRST FINIS ;TO RETURN WITH SOMETHING NICE + +STO: PUSH TP,$TCHSTR ;CROCK TO OUTPUT A SPACE ON THE TTY OUTPUT CHANNEL + PUSH TP,CHQUOTE [ ] +TO: PUSH TP,$TCHAN + PUSH TP,TTOCHN+1 + + MCALL 2,PRINC + POPJ P, ;GO BACK TO WHAT WE WERE DOING + + +;THESE ARE THE FUNCTIONS TO ACTUALLY STUFF GOODIES OUT +;OVER THE IPC DEVICE +;DESCRIPTION OF CALLING ARGS TO THEM IS AT THE +;FIRST OF THE FILE + +MFUNCTION SEND,SUBR + + ENTRY + + PUSH P,[0] ;FLAG TO INDICATE DONT WAIT + JRST CASND + +MFUNCTION SENDW,SUBR,[SEND-WAIT] + + ENTRY + + PUSH P,[1] ;FLAG TO INDICATE WAITING + +CASND: HLRE 0,AB + CAMG 0,[-6] ;NEED AT LEAST 3 ARGS + CAMGE 0,[-12.] ;AND NOT MORE THAN 6 ARGS + JRST WNA + MOVE A,(AB) + MOVE B,1(AB) + PUSHJ P,STRTO6 ;POOF FIRST ARG TO SIXBIT + MOVE A,2(AB) + MOVE B,3(AB) + PUSHJ P,STRTO6 ;POOF SECOND ARG TO SIXBIT + GETYP 0,4(AB) + CAIN 0,TCHSTR + JRST CASND1 ;IF FIRST ARG IS STRING, NO PROBLEMS + CAIE 0,TSTORAGE + CAIN 0,TUVEC + JRST .+2 + JRST WTYP3 ;ELSE MUST BE OF TYPE STORAGE OR UVEC + MOVE B,5(AB) + HLRE C,B ;GET COUNT FIELD + SUBI B,(C) ;AND ADD THAT AMOUNT TO FIND DOPE WORD + GETYP A,(B) ;GET TYPE WORD OUT OF DOPE + PUSHJ P,SAT ;GET ITS STORAGE TYPE + CAIE A,S1WORD + JRST WTYP3 ;CRUFT MUST BE OF TYPE WORD +CASND1: PUSH TP,4(AB) + PUSH TP,5(AB) ;SAVE THE STRUCTURE AROUND TO REST OFF AS WE SEND + PUSH P,[0] ;SLOT FOR THIS MESSAGE TYPE, DEFAULT 0 + HLRE 0,AB + CAMLE 0,[-8.] ;IF 4 OR MORE ARGS GET THE MESS TYPE + JRST CASND2 + GETYP 0,6(AB) ;CHECK TO SEE THAT TYPE IS A FIX + CAIE 0,TFIX + JRST WTYP + MOVE 0,7(AB) + MOVEM 0,(P) ;SMASH IN THE SLOT RESERVED FOR TYPE +CASND2: HLRE 0,AB + CAMN 0,[-10.] ;IF WE HAVE FIVE ARGS WE ARE A GLOBAL LOOSER NEED 4 OR 6 + JRST WNA + CAMGE 0,[-8.] ;IF WE HAVE 4 OR LESS DONT WORRY + JRST .+4 ;GO GET LAST TO ARGS + PUSH P,[0] ;NO SIXBIT OF FROM + PUSH P,[0] ;SO SAVE SLOTS ANYWAY + JRST CASND3 ;GO WORRY ABOUT SENDING NOW + MOVE A,8.(AB) + MOVE B,9.(AB) + PUSHJ P,STRTO6 ;CONVERT MY NAME1 TO SIXBIT + MOVE A,10.(AB) + MOVE B,11.(AB) ;CONVERT MY NAME 2 TO SIXBIT + PUSHJ P,STRTO6 + +CASND3: GETYP 0,-1(TP) + CAIE 0,TCHSTR ;IS THIS A CHAR STRING + JRST .+5 + HRRZ A,-1(TP) ;IF SO GET COUNT + ADDI A,9. + IDIVI A,5 ;IF SO ROUND UP AND ADD ONE + JRST .+3 + HLRE A,(TP) + MOVN A,A ;IF A VECTOR GET THE WORD COUNT + PUSH P,A ;SAVE COUNT OF WORDS + CAILE A,MAXMES + JRST TOBIGR ;MESS OVER SIZE LIKED BY MUDDLE + CAILE A,BUFL-MESHED ;HOW BIG A BUFFER DO WE NEED? + MOVEI A,BUFL-MESHED ;IF TOO BIG WE USE DEFAULT MAX SIZE, ELSE LESS + ADDI A,MESHED+BUFHED ;PLUS ROOM FOR MESSAGE AND SYSTEM HEADERS + PUSHJ P,IBLOCK + PUSH TP,A + PUSH TP,B ;GET BUFFER OF RIGHT SIZE AND SAVE ON STACK + PUSH TP,A + PUSH TP,B ;SAVE ANOTHER COPY WHICH WILL BE RESTED AT TIMES + MOVE C,-5(P) ;GET HIS NAME 1 + MOVEM C,(B) ;AND STUFF IN RIGHT PLACE + MOVE C,-4(P) + MOVEM C,1(B) ;STUFF HIS NAME 2 + MOVE C,-3(P) + MOVEM C,4(B) ;STUFF MESSAGE TYPE CODE WORD + GETYP 0,-5(TP) ;IS THIS STRING OR UVECTOR? + CAIE 0,TCHSTR + JRST CASND4 + MOVE C,(P) ;GET LENGTH OF CHAR STRING TO SEND + ADDI C,1 + MOVEM C,3(B) ;STORE IN LENGTH FIELD IN MESS HEADER + SOS (P) ;DECREMENT FOR COUNT WORD + HRRZ C,-5(TP) ;GET THE CHARACTER COUNT + MOVEM C,5(B) ;STORE IN CORRECT SLOT IN MESSAGE + MOVE D,[6,,6] ;OFFSET FOR INITIAL HEADER ON ASCII MESSAGES + ADDM D,(TP) ;OFFSET BUF PTR 2 BY THIS AMOUNT + JRST CASND5 +CASND4: MOVE C,(P) ;GET COUNT OF MESSAGE + ADDI C,1 ;EXTRA FOR TYPE WORD + MOVEM C,3(B) ;STORE IN SLOT FOR COUNT OF WHOLE MESSAGE + MOVE D,[5,,5] ;OFFSET FOR INITIAL HEADER ON UVECTOR MESSAGES + ADDM D,(TP) ;OFFSET BUF PTR 2 BY THIS AMOUNT +CASND5: PUSHJ P,STUFBF ;GO FILL UP THE BUFFER WITH GARBAGE + MOVN 0,A ;GET NEGATIVE THE COUNT OF WORDS STUFFED + ADDM 0,(P) ;THAT MANY LESS WORDS REMAINING TO BE DONE + HRRZ C,-2(TP) ;GET A POINTER TO THE "UNRESTED" BUFFER + HRRZ D,(TP) ;GET A POINTER TO THE "RESTED" BUFFER + SUB D,C ;FIND OUT HOW MUCH WAS RESTED OFF + ADD D,A ;ADD TO THAT THE COUNT OF WORDS STUFFED THIS TIME + SUBI D,BUFHED ;LESS THE SYSTEM CONSTANT HEADER THAT DOENT COUNT + MOVEM D,2(C) ;STORE IN THE BUFFER IN CORRECT SLOT + PUSHJ P,CASIOT ;GO DO THE "IOT"--ACTUALLY AN OPEN + MOVE C,-2(TP) + HRLZI E,CONT ;THE "THIS IS A CONTINUATION" BIT + IORM E,3(C) ;TURN BIT ON IN FUTURE MESSAGES + ADD C,[4,,4] ;REST OFF THE SHORTER HEADER FOR THE REST OF MESSAGES + MOVEM C,(TP) ;STORE THIS IN THE "RESTED" BUFFER SLOT + SKIPLE (P) ;IS THERE MORE TO DO? + JRST CASND5 + MOVSI A,TATOM + MOVE B,IMQUOTE T + JRST FINIS ;RETURN HIM SOMETHING NICE + +TOBIGR: ERRUUO EQUOTE MESSAGE-TOO-BIG + + +STUFBF: MOVE C,-2(TP) ;ROUTINE TO FILL UP BUFFER WITH GOODIES + HRLZI E,INCOMP+ASCIMS + ANDCAM E,3(C) ;CLEAR THE INCOMPLETE AND ASCII FLAGS IF SET + HLRE B,(TP) ;GET THE BUFFER LENGTH + MOVN B,B ;MAKE IT A POSITIVE NUMBER + CAML B,-1(P) ;SEE IF THE WHOLE MESSAGE WILL FIT + JRST .+4 ;IT WILL ALL FIT + HRLZI 0,INCOMP ;THE INCOMPLETE FLAG + IORM 0,3(C) ;SET IT + JRST .+2 + MOVE B,-1(P) ;ELSE THE WHOLE MESSAGE FITS + GETYP 0,-5(TP) + CAIN 0,TCHSTR + JRST STUFAS + HRLZ D,-4(TP) ;SET UP TO BLT UVECTOR + HRR D,(TP) + HRRZ E,(TP) + ADDI E,(B)-1 ;SET UP BLT POINTERS + SKIPLE B ;IN CASE ZERO LENGTH UVECTOR + BLT D,(E) ;BBBBLLLLLLLLLLLLLLLLLLTTTT? + MOVE A,B ;MOVE COUNT OF WORDS DONE INTO A + HRL B,B + ADDM B,-4(TP) ;REST OFF THIS MUCH OF GOODIE FOR NEXT TIME + POPJ P, +STUFAS: HRLZI 0,ASCIMS + IORM 0,3(C) ;TURN ON THE ASCII BIT IN THE MESSAGE + MOVE A,B ;MOVE COUNT OF NUMBER OF WORDS INTO A + IMULI B,5 ;GET CHAR COUNT IN B + HRRZ C,-5(TP) ;COMPARE THIS WITH COUNT FIELD IN STRING + MOVE D,B + SUB D,C ;SEE HOW MANY EXTRA BLANKS AT END OF MESS + JUMPGE D,.+3 + MOVEI D,0 ;NO EXTRA SPACES TO PAD + MOVE C,B ;NOT EXTRA SPACES, DO 5*WORD CHARS + MOVN E,C + ADDM E,-5(TP) ;FIX UP COUNT IN ASCII + HRLZI E,440700 ;GET A IDPB PTR INTO THE BUFFER + HRR E,(TP) ;POINT TO RIGHT PLACE IN BUFFER + JUMPLE C,.+4 ;ARE WE DONE MOVING CHARS? + ILDB 0,-4(TP) ;LOAD A BYTE FROM STRING + IDPB 0,E ;STUFF IN BUFFER + SOJG C,.-2 ;REPEAT THE LOOP + JUMPLE D,.+4 ;SEE IF WE NEED TO FILL OUT WITH NULLS + MOVEI 0,0 + IDPB 0,E ;STUFF A NULL IN RIGHT SPOT IN BUFFER + SOJG D,.-1 + POPJ P, + +CASIOT: HRRZI A,(SIXBIT /IPC/) ;FIX UP OPEN BLOCK IN THE AC'S + MOVE B,-2(TP) ;HOWS THAT FOR SNAZZY? + MOVE C,-3(P) ;MY NAME 1 + MOVE D,-2(P) ;MY NAME 2 + JUMPN C,.+3 + JUMPN D,.+2 + TLO A,USEUJ ;IF BOTH ARE ZERO THEN USE DEFAULT UNAME,JNAME + SKIPN -7(P) ;SEE IF SEND AND HANG FLAG IS SET + JRST .+3 + TLO A,SANDH ;SET SEND AND HANG FLAG + JRST .+3 + TLO A,SIMM ;ELSE WE MUST BE SENDING IMMEDIATE + AOS -7(P) ;IF THERE IS MORE TO DO, IT MUST BE IN HANG MODE + MOVSI 0,TUVEC + MOVE PVP,PVSTOR+1 + MOVEM 0,BSTO(PVP) ;IN CASE WE ARE INTERRUPTED OUT WE WANT TO WIN + SETZM E ;FLAG USED TO INDICATE NO SKIPPAGE + ENABLE + .OPEN 0,A ;WELL, THATS ALL THERE IS TO IT. + AOS E ;IF WE DONT SKIP WE HAVE PROBLEMS + DISABLE + MOVE PVP,PVSTOR+1 + SETZM BSTO(PVP) ;FIX UP THE SLOT IN PVP + SKIPN E ;SEE IF WE LOST + POPJ P, ;IF NOT WE ARE THROUGH WITH THIS PART + .STATUS 0,A ;FIND OUT REASON FOR LOSSAGE + MOVEI B,0 + PUSHJ P,GFALS ;MAKE A FALSE WITH THAT REASON + JRST FINIS ;GIVE THE MAGIC FALSE BACK TO THE LOOSER + + +MFUNCTION DEMSIG,SUBR + + ENTRY 1 + + MOVE A,(AB) + MOVE B,1(AB) + PUSHJ P,STRTO6 ;GET THE SIXBIT REPRESENTATION + MOVE A,[SETZ] ;FIX UP THE BLOCK IN THE AC'S + MOVE B,[SIXBIT /DEMSIG/] + MOVE C,[SETZ (P)] ;THE SIXBIT IS ON TOP OF P STACK + .CALL A + JRST RFALS ;DIDNT WIN WITH DEMON SIGNAL +RTRUE: MOVSI A,TATOM + MOVE B,IMQUOTE T + JRST FINIS + +RFALS: MOVSI A,TFALSE + MOVEI B,0 + JRST FINIS ;FALSE INDICATING LACK OF WINNAGE + + +MFUNCTION IPCON,SUBR,[IPC-ON] + + ENTRY + + PUSH P,[USEUJ,,0] ;FLAG FOR WHETHER OR NOT TO USE DEFAULT + HLRZ 0,AB + JUMPE 0,IPCON1 ;NO ARGS ARE FINE + CAIE 0,-4 ;ELSE MUST HAVE 2 ARGS + JRST WNA + SETZM (P) ;CLEAR OUR FLAG + MOVE A,(AB) + MOVE B,1(AB) + PUSHJ P,STRTO6 ;GET SIXBIT OF OUR FIRST ARG + MOVE A,2(AB) + MOVE B,3(AB) + PUSHJ P,STRTO6 ;GET SIXBIT OF OUR SECOND ARG + JRST IPCON2 +IPCON1: PUSH P,[0] ;SAVE SLOT ON STACK FOR EVENNESS + PUSH P,[0] +IPCON2: MOVEI A,BUFL+BUFHED + PUSHJ P,CAFRE ;GET A BUFFER OF RIGHT LENGTH TO READ INTO + PUSH P,A ;AND SAVE IT AROUND SO WE DONT LOOSE + MOVEI 0,BUFL + MOVEM 0,2(A) ;FILL COUNT IN THE BUFFER SLOT + MOVEI A,5 + PUSHJ P,IBLOCK ;GET A BLOCK OF STORE FOR THE OPEN BLOCK + PUSH TP,$TUVEC + PUSH TP,B ;SAVE CRUFT ON TP + TLO 0,RFROMA ;SET THE READ FROM ANY FLAG + IOR 0,-3(P) ;FIX FOR DEFAULT UNAME,JNAME IF FLAG INDICATES + MOVEM 0,(B) ;MAKE OPEN BLOCK + MOVE 0,[SIXBIT /IPC/] + MOVEM 0,1(B) + MOVE 0,-2(P) + MOVEM 0,3(B) ;MY NAME 1 + MOVE 0,-1(P) + MOVEM 0,4(B) ;MY NAME 2 IF NOT USING DEFAULT + MOVE 0,(P) + MOVEM 0,2(B) ;PTR TO THE WIRED BUFFER FOR STUFFING CRUFT + MOVE A,B + PUSHJ P,MOPEN ;GO DO THE OPEN + JRST IPCON3 ;OPEN FAILED, FIND OUT WHY + PUSH P,A ;SAVE THE CHANNEL NUMBER + MOVEI E,1 + LSH E,(A) ;SET INTERRUPT BITS RIGHT + IORM E,MASK2 + .SUSET [.SMSK2,,MASK2] + MOVE C,-1(TP) + MOVE D,(TP) ;GET THE OPEN BLOCK UVECTOR + PUSHJ P,INCONS ;THROW INTO PAIR SPACE + POP P,C ;GET THE CHANNEL # + SUBI C,1 + IMULI C,2 + MOVEM B,IPCS1+1(C) ;STUFF PTR TO OPEN BLOCK INTO SLOT IN TVP + JRST RTRUE ;WE WON, GO LET LUSER KNOW IT. +IPCON3: PUSH P,A ;WE LOST, LETS FIND OUT WHY + MOVE A,BUFL+BUFHED + MOVE B,-1(P) ;LETS FREE UP OUR WIRED DOWN BUFFER TO BE CLEAN + PUSHJ P,CAFRET + POP P,A ;GET THE CHANNEL # BACK + JUMPL A,NFCHN ;NO FREE CHANNELS? + MOVE B,[.STATUS A] ;MAKE A CALL TO STATUS TO FIND REASON + LSH A,23. ;SHIFT THE CHANNEL NUMBER INTO RIGHT PLACE + IOR B,A ;FIX UP .STATUS + XCT B + MOVEI B,0 + PUSHJ P,GFALS + JRST FINIS ;RETURN A LOOSE WITH REASON FOR LOOSAGE + +NFCHN: ERRUUO EQUOTE NO-ITS-CHANNELS-FREE + + +MFUNCTION IPCOFF,SUBR,[IPC-OFF] + + ENTRY 0 + + PUSH TP,$TVEC + MOVE 0,[IPCS1,,IPCS1] + PUSH TP,0 ;SAVE OUR PLACE IN RUNNING THROUGH SLOTS + PUSH P,[1] ;COUNTER OF CHANNEL NUMBER + +IPCOF1: MOVE A,(TP) ;GET FIRST GOODIE + SKIPN B,1(A) ;GET THE POINTER TO LIST + JRST IPCOF2 + SETZM 1(A) ;ZERO OUT SLOT TO BE CLEAN + MOVE B,1(B) ;GET CAR OF LIST, PTR TO OPEN BLOCK + MOVE C,(P) ;GET THE ACTUAL CHANNEL NUMBER + MOVEI E,1 ;TURN OFF INTERRUPT + LSH E,(C) + ANDCAM E,MASK2 + .SUSET [.SMSK2,,MASK2] + MOVE A,C + PUSHJ P,MCLOSE ;CLOSE THIS CHANNEL + JFCL + MOVEI A,BUFL+BUFHED ;LENGTH OF WIRED STORE TO FREE UP + MOVE B,1(B) ;GET THE POINTER TO WIRED STORE + PUSHJ P,CAFRET ;FREE ALREADY +IPCOF2: MOVE 0,[2,,2] + ADDM 0,(TP) ;REST TO NEXT SLOT + AOS D,(P) ;NEXT CHANNEL + CAIG D,15. ;ARE WE THROUGH + JRST IPCOF1 + JRST RTRUE ;RETURN HIM A TRUE FOR NICENESS + + +IPCGOT: MOVEI D,IPCS1+1 + ADDI D,(B) + ADDI D,(B) + SKIPN D,-74.(D) ;GET THE GOODIE LIST FOR CHANNEL WE INTERRUPTED ON + JRST DIRQ ;MIX UP MAYBE, LET HIM WORRY ABOUT IT + PUSH P,B ;SAVE THE CHAN # + PUSH TP,$TLIST + PUSH TP,D ;SAVE GOODIE LIST + MOVE E,1(D) ;GET PTR TO OPEN BLOCK + PUSH P,2(E) ;SAVE PTR TO WIRED BUFFER + MOVE E,2(E) + MOVE 0,3(E) ;GET THE MAGIC BITS FOR THIS MESSAGE + TLNE 0,CONT ;IS THIS MESSAGE A CONTINUATION? + JRST IGCON ;YES + MOVEI A,10. ;NO + PUSHJ P,GIBLOK ;GET A BLOCK FOR FUNNY MESSAGE VECTOR + PUSH TP,$TVEC + PUSH TP,B ;SAVE THE BLOCK FOR FUNNY MESSAGE VECTOR + MOVE E,(P) ;GET PTR TO WIRED BUFFER + MOVE 0,3(E) ;GET THE MAGIC BITS AGAIN + HRRZ A,0 ;GET THE LENGTH IN WORDS OF THIS THE WHOLE MESSAGE HE HAS + SUBI A,1 ;MINUS ONE FOR THE TYPE WORD WHICH IS COUNTED + TLNE 0,ASCIMS ;IS THIS ASCII? + SUBI A,1 ;IF YES THEN MUST SUB 1 MORE FOR ASCII CHAR COUNT + CAILE A,MAXMES ;IS THIS BIGGER THAN MUDDLE BLESSES? + JRST TBGMS ;IF SO THEN CLEAN UP AND FORGET ABOUT THE LOOSER + PUSHJ P,IBLOCK + MOVE E,(P) + MOVE D,(TP) + MOVE 0,(E) ;GET HIS NAME 1 OUT OF MESSAGE + MOVEM 0,5(D) ;STORE INTO SLOT IN FUNNY MESSAGE VECTOR + MOVE 0,1(E) ;GET HIS NAME 2 OUT OF MESSAGE + MOVEM 0,7(D) + MOVE 0,4(E) ;GET THE MESSAGE TYPE WORD + MOVEM 0,9(D) ;STORE INTO SLOT IN MESSAGE VECTOR + MOVSI 0,TFIX + MOVE 0,4(D) + MOVE 0,6(D) + MOVE 0,8(D) + MOVE 0,3(E) ;GET THE MESSAGE BITS + TLNE 0,ASCIMS ;IS IT ASCII? + JRST IG1 ;YES + MOVSI 0,TUVEC + MOVEM 0,(D) + MOVEM 0,2(D) + MOVEM B,1(D) + MOVEM B,3(D) ;STORE MESSAGE BLANK TWICE, THE SECOND TO REST THROUGH + HLRE E,B + SUBM B,E + MOVSI 0,TFIX + MOVEM 0,(E) ;SET NICE TYPE TO PRINT GOODER + JRST IGBLT +IG1: MOVSI 0,TUVEC + MOVEM 0,2(D) + MOVEM B,3(D) ;STORE MESSAGE BLANK AS UVECTOR TO REST THROUGH + HLRE A,B + HRLI B,010700 ;MAKE THE ILDB PTR + SUBI B,1 + MOVEM B,1(D) ;AND STORE IN THE SLOT + IMUL A,[-5] ;MAX CHAR COUNT FOR STRING + MOVE B,5(E) ;GET THE ACTUAL CHARACTER COUNT HE CLAIMED + MOVE C,A + SUB C,B ;FIND DIFFERENCE BETWEEN MAX AND CLAIMED + JUMPL C,.+2 ;IF COUNT TOO BIG, MUST DO BEST POSSIBLE AND USE MAX COUNT + CAILE C,4 ;NO MORE THAN FOUR EXTRA CHARS IMPLIES GOODNESS + MOVE B,A ;IF LOSSAGE, THEN USE MAX COUNT INSTEAD OF HIS CLAIM + HRLI B,TCHSTR ;MAKE THIS A CHAR STRING TYPE WORD + MOVEM B,(D) ;AND FIX MESSAGE BLANK # 1 TO BE THE BLESSED STRING + JRST IGBLT ;BLT THE MESSAGE INTO THE BLANK + +IGCON: MOVE D,(TP) ;GET THE IPC SLOT LIST + MOVE E,(P) ;GET A PTR TO THE MESSAGE BUFFER + HRRZ C,(D) ;CDR THE IPC SLOT LIST TO POINT TO FIRST MESSAGE VECTOR +IGCON1: JUMPE C,IGCONL ;IF NIL, THEN ABANDON ALL HOPE + MOVE B,1(C) ;LOOK AT THE VECTOR + MOVE 0,5(B) ;HIS NAME 1 FOR THIS BLOCK + CAME 0,(E) ;COMPARE WITH HIS NAME 1 IN THIS MESSAGE + JRST IGCON2 ;IMMEDIATE FAILURE, TRY THE NEXT IN THE LIST + MOVE 0,7(B) ;SEE IF HIS NAME 2 ALSO MATCHES + CAME 0,1(E) ;WELL, DOES IT MATCH? + JRST IGCON2 ;NO, TRY THE NEXT ONE + PUSH TP,$TVEC ;WE GOT IT + PUSH TP,1(C) ;SAVE THIS MESSAGE BLOCK ON TP FOR LATER BLTING + HRRZ C,(C) ;CDR TO REST OF LIST + HRRM C,(D) ;AND SPLICE IT RIGHT OUT OF THE LIST, NEAT HUH? + JRST IGBLT ;GO BLT TO OUR HEART'S CONTENT +IGCON2: HRRZ D,(D) ;REST OUR FOLLOW UP POINTER + HRRZ C,(C) ;REST OUR ACTUAL TEST POINTER + JRST IGCON1 ;TRY AGAIN + +IGCONL: MOVE A,(TP) + MOVE A,1(A) ;GET PTR TO OPEN BLOCK + MOVE B,-1(P) + SUBI B,36. ;GET CHANNEL NUMBER + HLL B,(A) + MOVE C,(P) ;GET THE WIRED BUFFER + SUB P,[2,,2] ;WE LOST SO CLEAN UP STACKS + SUB TP,[2,,2] +ROPNL: SETZM (C) ;REOPEN CHANNEL SO NOT PERMANENTLY CROGGLED + SETZM 1(C) ;ZERO OUT THE HIS NAME SLOTS + MOVEI 0,BUFL + MOVEM 0,2(C) ;RESET THE LENGTH FIELD IN WIRED BUF + DOTCAL OPEN,[B,1(A),2(A),3(A),4(A)] + FATAL CANT REOPEN IPC CHN + JRST DIRQ ;LEFT IN NICE STATE AFTER LOOSAGE + +TBGMS: MOVE A,-2(TP) + MOVE A,1(A) ;GET OPEN BLOCK + MOVE B,-1(P) + SUBI B,36. ;CHANNEL # + HLL B,(A) + MOVE C,(P) ;WIRED BUFFER + SUB P,[2,,2] ;CLEAN UP STACKS + SUB TP,[4,,4] + JRST ROPNL ;REOPEN SO NEXT GUY CAN WIN + + + +IGBLT: MOVE E,(TP) ;POINTER TO MESSAGE VECTOR + MOVE E,3(E) ;GET VECTOR (MAYBE STRING IN DISGUISE) TO BLT IN + MOVE D,(P) ;GET THE WIRED BUFFER + MOVEI C,4(D) ;GET A POINTER TO THE REST OF THE WIRED BUF + MOVEI 0,BUFL-1 ;KLUDGE TO IGNORE ONE EXTRA WORD OF BITS + SUB 0,2(D) ;GET LENGTH OF GOODIE GOT + MOVE A,3(D) ;GET THE RANDOM MESSAGE BITS + TLNE A,CONT ;TEST FOR CONTINUED MESSAGE + JRST .+7 ;IF SO THEN NO NEED TO WORRY + SOS 0 + AOS C ;FIX UP FOR ONE LESS WORD TO WORRY WITH + TLNN A,ASCIMS ;TEST FOR ASCII MESSAGE + JRST .+3 ;IF NOT THEN NO WORRY + SOS 0 + AOS C ;FIX UP FOR YET 1 FEWER WORD + HLRE A,E + MOVM A,A ;GET LENGTH OF VECTOR TO BLT INTO + CAILE 0,(A) ;CHECK TO SEE WE DONT HAVE TOO MUCH + MOVE 0,A ;IF WE HAVE TOO MUCH, CHOP OFF--HA, HA, HA + MOVEI B,-1(E) + ADD B,0 ;B POINTS TO LAST WORD TO BLT INTO + HRL C,E ;BLT POINTER + MOVSS C ;NDR CANT REMEMBER HOW TO BLT POINTER + BLT C,(B) ;VIOLA + HRL 0,0 + MOVE E,(TP) ;GET BACK POINTER TO MESSAGE VECTOR + ADDM 0,3(E) ;REST OFF TO KEEP TRACK OF INCOMPLETE MESSAGE + MOVE A,3(D) ;GET THE RANDOM MESSAGE BITS BACK + TLNE A,INCOMP ;MESSAGE COMPLETE? + JRST IGHALF ;INCOMPLETE + JRST IGMES ;COMPLETE + +IGHALF: MOVE C,-1(TP) ;GOT TO SPLICE MESSAGE VECTOR BACK IN + MOVE D,(TP) + PUSHJ P,INCONS ;STICK INTO PAIR SPACE + HRRZ E,-2(TP) ;PTR TO LIST + HRRZ D,(E) ;CDR OF LIST + HRRM D,(B) ;MAKE SPLICE + HRRM B,(E) ;THAT IT + MOVE B,1(E) ;POINT TO OPEN BLOCK + MOVE 0,-1(P) ;GET CHAN # + SUBI 0,36. + HLL 0,(B) + MOVE E,(P) ;GET THE WIRED BUF + MOVEI D,BUFL + MOVEM D,2(E) ;REFIX THE WIRED BUF + SETZM (E) + SETZM 1(E) + DOTCAL OPEN,[0,1(B),2(B),3(B),4(B)] + FATAL CANT REOPEN IPC CHN + SUB P,[2,,2] + SUB TP,[4,,4] ;CLEAN OURSELVES + JRST DIRQ ;THATS ALL THERE IS TO IT + +IGMES: HRRZ E,-2(TP) ;PTR TO OUR KLUDGE LIST + MOVE B,1(E) ;PTR TO OPEN BLOCK + MOVE 0,-1(P) ;CHANNEL # + SUBI 0,36. + HLL 0.(B) + MOVE D,(P) ;GET THE WIRED BUF + MOVEI C,BUFL + MOVEM C,2(D) + SETZM (D) + SETZM 1(D) ;BLESS WIRED BUF FOR REOPENING + DOTCAL OPEN,[0,1(B),2(B),3(B),4(B)] + FATAL CANT REOPEN IPC CHN + MOVE E,(TP) ;GET THE MESSAGE VECTOR (ALIAS GOODIE BLOCK) + SUB P,[2,,2] ;BLESS OUR P STACK + PUSH P,5(E) ;SAVE SIXBIT HIS NAME 1 + PUSH P,7(E) ;SAVE SIXBIT HIS NAME 2 + SUB TP,[4,,4] ;BLESS THE TP STACK + PUSH TP,$TCHSTR + PUSH TP,CHQUOTE IPC + PUSH TP,(E) ;STUFF STUFF ON TO CALL INTERRUPT + PUSH TP,1(E) ;THAT IS THE ACTUAL MESSAGE + MOVE 0,9(E) + CAMN 0,[400000,,0] + JRST IGUG +IGUGN: PUSH P,3(B) ;GET MY NAME 1 OUT OF OPEN BLOCK + PUSH P,4(B) ;GET MY NAME 2 OUT OF OPEN BLOCK + MOVE 0,(B) ;GET SOME OF THE RANDOM OPEN FLAGS + TLNE 0,USEUJ + SETZ -1(P) ;MAKE SURE WE HAVE INDICATOR IF THIS IS TO UNAME,JNAME + PUSH TP,$TFIX + PUSH TP,9(E) ;SAVE THE MESSAGE TYPE + MOVE A,-3(P) ;HIS NAME 1 + PUSHJ P,6TOCHS + PUSH TP,A + PUSH TP,B ;GIVE HIM NICE CHAR STRING OF ALL THE NAMES + MOVE A,-2(P) + PUSHJ P,6TOCHS + PUSH TP,A + PUSH TP,B ;NICE CHAR STRING OF HIS NAME 2 + SKIPN A,-1(P) ;ISE THIS DEFAULT UNAME, JNAME + JRST IGFOUR ;ONLY FOUR ARGS TO THE IPC INTERRUPT + PUSHJ P,6TOCHS + PUSH TP,A + PUSH TP,B + MOVE A,(P) + PUSHJ P,6TOCHS + PUSH TP,A + PUSH TP,B ;GIVE HIM CHAR STRINGS OF MY NAME 1 AND 2 IF NOT DEFAULT + MOVEI E,7 ;FOR ACALL INDICATING 6 ARGS TO THE IPC INTERRUPT HANDLER + JRST .+2 ;SKIP OVER FIX FOR ONLY 4 ARGS TO IPC INTERRUPT +IGFOUR: MOVEI E,5 + SUB P,[4,,4] ;CLEAN UP OUR WHOLE WORLD + ACALL E,INTERR ;THATS IT FOLKS, THE REAL THING + JRST DIRQ + +IGUG: .SUSET [.RMARPC,,0] + CAMN 0,[-1] + JRST IGUGN ; DISABLED, SO GO AWAY + SETZM INTHLD ; RE-ENABLEE INTERRUPTS + SUB P,[2,,2] + MCALL 1,PARSE + SUB TP,[2,,2] ;FLUSH OFF STRING "IPC" + PUSH TP,A + PUSH TP,B + MCALL 1,EVAL + JRST DIRQ + + +IPCBLS: PUSH P,A + PUSH P,B + PUSH P,C + PUSH P,D + PUSH P,E ;PARANOIA STRIKES AGAIN + PUSH P,0 + MOVEI E,0 ;CRETIN ASSEMBLER + .SUSET [.SMARPC,,E] + MOVEI E,IPCS1 ;BLESSES ALL CURRENTLY OPEN IPC CHANNELS + MOVEI 0,1 +IPCBL1: SKIPN B,1(E) + JRST IPCBL2 + HLLZS (B) ;CLEAR OUT ANY PARTIAL BUFFER WE MAY HAVE + HRRZ B,1(B) ;GET A POINTER TO THE OPEN BLOCK + MOVE A,0 ;GET THE CHANNEL NUMBER + HLL A,(B) + MOVE C,2(B) ;GET A POINTER TO THE BUFFER + MOVEI D,BUFL ;TO FIX UP THE BUFFER + MOVEM D,2(C) ;FIX LENGTH UP RIGHT + SETZM (C) + SETZM 1(C) ;FIX UP THE READ FROM FIELDS + DOTCAL OPEN,[A,1(B),2(B),3(B),4(B)] + FATAL IPC DEVICE LOST +IPCBL2: ADDI E,2 + ADDI 0,1 + CAIG 0,15. + JRST IPCBL1 ;IF ANY MORE GO BLESS THEM + + POP P,0 + POP P,E + POP P,D + POP P,C + POP P,B + POP P,A + POPJ P, + + + + +END +  \ No newline at end of file diff --git a//ldgc.bin.11 b//ldgc.bin.11 new file mode 100644 index 0000000..cb46aeb Binary files /dev/null and b//ldgc.bin.11 differ diff --git a//ldgc.mid.100 b//ldgc.mid.100 new file mode 100644 index 0000000..d2f1c6a --- /dev/null +++ b//ldgc.mid.100 @@ -0,0 +1,504 @@ +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: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 + \ No newline at end of file diff --git a//main.bin.9 b//main.bin.9 new file mode 100644 index 0000000..d654363 Binary files /dev/null and b//main.bin.9 differ diff --git a//main.mid.350 b//main.mid.350 new file mode 100644 index 0000000..16369e5 --- /dev/null +++ b//main.mid.350 @@ -0,0 +1,2056 @@ +TITLE MAIN LOOP AND GLOBALLY REFERENCED SUBROUTINES + +RELOCA + +.GLOBAL TBINIT,PIDSTO,PROCID,PTIME,GCPDL,PBASE,TYPTOP,RERR,FRMSTK,EMERGE +.GLOBAL PDLBUF,INTINT,START,SWAP,ICR,SPBASE,TPBASE,TPBAS,CURPRI,CHFINI,MKTBS +.GLOBAL TOPLEVEL,INTOBL,INITIA,ERROBL,MAINPR,RESFUN,STATUS,TYPVEC,ROOT,TTICHN,TTOCHN +.GLOBAL TTYOPE,MOPEN,MCLOSE,MIOT,ILVAL,MESS,ERROR,CHFRM,IGVAL,TYPBOT,ASOVEC +.GLOBAL PRINT,PRIN1,PRINC,MUDSTR,VECBOT,CSTACK,IFALSE,TYPLOO,RCALL,SWAPIN,CTMPLT +.GLOBAL IDPROC,CHFSWP,ILOC,MAKACT,BNDV,SPECSTORE,BINDID,IGLOC,MTYO,MSGTYP,CAFRE1,CPOPJ +.GLOBAL EVATYP,EVTYPE,APLTYP,APTYPE,PRNTYP,PRTYPE,AGC,SGSNAM,NAPT,APLQ,STRTO6 +.GLOBAL 6TOCHS,TYPFND,STBL,CHNL0,N.CHNS,CLOSAL,%LOGOUT,%SSNAM,%RSNAM,%KILLM,SAT +.GLOBAL MAKINF,%VALRET,COMPERR,IPUT,IGET,TMATCH,INITIZ,IPCINI,%UNAM,%JNAM,%RUNAM,%RJNAM,%RXUNA,%RXJNA,%VALFI +.GLOBAL NOTTY,DEMFLG,CFRAME,CARGS,CFUNCT,CITYPE,CTYPEQ,CPTYPE,CTYPEP,CUTYPE, +.GLOBAL CCHUTY,RTFALS,PGINT,PURCLN,CTYPEC,CTYPEW,IDVAL1,CALLTY,MESSAG,INITFL,WHOAMI +.GLOBAL %SLEEP,%HANG,%TOPLQ,ONINT,CHUNW,CURFCN,BUFRIN,TD.LNT,TD.GET,TD.AGC,TD.PUT,MPOPJ +.GLOBAL PURVEC,PLOAD,SSPECS,OUTRNG,CVTYPE,FSTART,CKVRS,CPRTYC,PVSTOR,SPSTOR +.GLOBAL TYPIC,CISET,LSTUF,IMPURI,REALTV +.INSRT MUDDLE > + +;MAIN LOOP AND STARTUP + +START: MOVEI 0,0 ; SET NO HACKS + JUMPE 0,START1 + TLNE 0,-1 ; SEE IF CHANNEL + JRST START1 + MOVE P,GCPDL + MOVE A,0 + PUSH P,A + PUSHJ P,CKVRS ; CHECK VERSION NUMBERS + POP P,A + JRST FSTART ; GO RESTORE +START1: MOVEM 0,WHOAMI ; HACK FOR TS FOO linked to TS MUDDLE + MOVE PVP,MAINPR ; MAKE SURE WE START IN THE MAIN PROCESS + JUMPE 0,INITIZ ; MIGHT BE RESTART + MOVE P,PSTO+1(PVP) ; SET UP FOR BOOTSTRAP HACK + MOVE TP,TPSTO+1(PVP) +INITIZ: MOVE PVP,MAINPR + SKIPN P ; IF NO CURRENT P + MOVE P,PSTO+1(PVP) ; PDL TO GET OFF THE GROUND + SKIPN TP ; SAME FOR TP + MOVE TP,TPSTO+1(PVP) ; GET A TP TO WORK WITH + SETZB R,M ; RESET RSUBR AC'S + PUSHJ P,%RUNAM + JFCL + PUSHJ P,%RJNAM + PUSHJ P,TTYOPE ;OPEN THE TTY + MOVEI B,MUDSTR + SKIPE WHOAMI ; SKIP IF THIS IS MUDDLE + JRST NODEMT ; ELSE NO MESSAGE + SKIPE DEMFLG ; SKIP IF NOT DEMON + JRST NODEMT + SKIPN NOTTY ; IF NO TTY, IGNORE + PUSHJ P,MSGTYP ;TYPE OUT TO USER + +NODEMT: XCT MESSAG ;MAYBE PRINT A MESSAGE + PUSHJ P,INTINT ;INITIALIZE INTERRUPT HANDLER + XCT IPCINI + PUSHJ P,PURCLN ; CLEAN UP PURE SHARED AREA +RESTART: ;RESTART A PROCESS +STP: MOVEI C,0 + MOVE PVP,PVSTOR+1 + MOVE B,TBINIT+1(PVP) ;POINT INTO STACK AT START + PUSHJ P,CHUNW ; LEAVE WHILE DOING UNWIND CHECK + MOVEI E,TOPLEV + MOVEI A,TFALSE ; IN CASE FALLS OFF PROCESS + MOVEI B,0 + HRRM E,-1(TB) + JRST CONTIN + + IMQUOTE TOPLEVEL +TOPLEVEL: + MCALL 0,LISTEN + JRST TOPLEVEL + + +IMFUNCTION LISTEN,SUBR + + ENTRY + PUSH P,[0] ;FLAG: DON'T PRINT ERROR MSG + JRST ER1 + +; USER SUPPLIED ERROR HANDLER, TEMPORARY KLUDGE + IMQUOTE ERROR + +ERROR: MOVE B,IMQUOTE ERROR + PUSHJ P,IGVAL ; GET VALUE + GETYP C,A + CAIN C,TSUBR ; CHECK FOR NO CHANGE + CAIE B,RERR1 ; SKIP IF NOT CHANGED + JRST .+2 + JRST RERR1 ; GO TO THE DEFAULT + PUSH TP,A ; SAVE VALUE + PUSH TP,B + MOVE C,AB ; SAVE AB + MOVEI D,1 ; AND COUNTER +USER1: PUSH TP,(C) ; PUSH THEM + PUSH TP,1(C) + ADD C,[2,,2] ; BUMP + ADDI D,1 + JUMPL C,USER1 + ACALL D,APPLY ; EVAL USERS ERROR + JRST FINIS + + + +IMFUNCTION ERROR%,SUBR,ERROR + +RERR1: ENTRY + PUSH TP,$TATOM + PUSH TP,MQUOTE ERROR,ERROR,INTRUP + PUSHJ P,FRMSTK ; PUT ERROR'S FRAME ON STACK + MOVEI D,2 + MOVE C,AB +RERR2: JUMPGE C,RERR22 + PUSH TP,(C) + PUSH TP,1(C) + ADD C,[2,,2] + AOJA D,RERR2 +RERR22: ACALL D,EMERGENCY + JRST RERR + +IMQUOTE ERROR +RERR: ENTRY + PUSH P,[-1] ;PRINT ERROR FLAG + +ER1: MOVE B,IMQUOTE INCHAN + PUSHJ P,ILVAL ; CHECK INPUT CHANNEL IS SOME KIND OF TTY + GETYP A,A + CAIE A,TCHAN ; SKIP IF IT IS A CHANNEL + JRST ER2 ; NO, MUST REBIND + CAMN B,TTICHN+1 + JRST NOTINC +ER2: MOVE B,IMQUOTE INCHAN + MOVEI C,TTICHN ; POINT TO VALU + PUSHJ P,PUSH6 ; PUSH THE BINDING + MOVE B,TTICHN+1 ; GET IN CHAN +NOTINC: SKIPN DEMFLG ; SKIP IF DEMON + SKIPE NOTTY + JRST NOECHO + PUSH TP,$TCHAN + PUSH TP,B + PUSH TP,$TATOM + PUSH TP,IMQUOTE T + MCALL 2,TTYECH ; ECHO INPUT +NOECHO: MOVE B,IMQUOTE OUTCHAN + PUSHJ P,ILVAL ; GET THE VALUE + GETYP A,A + CAIE A,TCHAN ; SKIP IF OK CHANNEL + JRST ER3 ; NOT CHANNEL, MUST REBIND + CAMN B,TTOCHN+1 + JRST NOTOUT +ER3: MOVE B,IMQUOTE OUTCHAN + MOVEI C,TTOCHN + PUSHJ P,PUSH6 ; PUSH THE BINDINGS +NOTOUT: MOVE B,IMQUOTE OBLIST + PUSHJ P,ILVAL ; GET THE VALUE OF OBLIST + PUSHJ P,OBCHK ; IS IT A WINNER ? + SKIPA A,$TATOM ; NO, SKIP AND CONTINUE + JRST NOTOBL ; YES, DO NOT DO REBINDING + MOVE B,IMQUOTE OBLIST + PUSHJ P,IGLOC + GETYP 0,A + CAIN 0,TUNBOU + JRST MAKOB ; NO GLOBAL OBLIST, MAKE ONE + MOVEI C,(B) ; COPY ADDRESS + MOVE A,(C) ; GET THE GVAL + MOVE B,(C)+1 + PUSHJ P,OBCHK ; IS IT A WINNER ? + JRST MAKOB ; NO, GO MAKE A NEW ONE + MOVE B,IMQUOTE OBLIST + PUSHJ P,PUSH6 + +NOTOBL: PUSH TP,[TATOM,,-1] ;FOR BINDING + PUSH TP,IMQUOTE LER,[LERR ]INTRUP + PUSHJ P,MAKACT + HRLI A,TFRAME ; CORRCT TYPE + PUSH TP,A + PUSH TP,B + PUSH TP,[0] + PUSH TP,[0] + MOVE A,PVSTOR+1 ; GET PROCESS + ADD A,[PROCID,,PROCID] ; POINT TO ID (ALSO LEVEL) + PUSH TP,BNDV + PUSH TP,A + MOVE A,PROCID(PVP) + ADDI A,1 ; BUMP ERROR LEVEL + PUSH TP,A + PUSH TP,PROCID+1(PVP) + PUSH P,A + + MOVE B,IMQUOTE READ-TABLE + PUSHJ P,IGVAL + PUSH TP,[TATOM,,-1] + PUSH TP,IMQUOTE READ-TABLE + GETYP C,A ; TO GVAL OF READ-TABLE ON ERROR AND + CAIE C,TVEC ; TOP ERRET'S + JRST .+4 + PUSH TP,A + PUSH TP,B + JRST .+3 + PUSH TP,$TUNBOUND + PUSH TP,[-1] + PUSH TP,[0] + PUSH TP,[0] + + PUSHJ P,SPECBIND ;BIND THE CRETANS + MOVE A,-1(P) ;RESTORE SWITHC + JUMPE A,NOERR ;IF 0, DONT PRINT ERROR MESS + PUSH TP,$TATOM + PUSH TP,EQUOTE *ERROR* + MCALL 0,TERPRI + MCALL 1,PRINC ;PRINT THE MESSAGE +NOERR: MOVE C,AB ;GET A COPY OF AB + +ERRLP: JUMPGE C,LEVPRT ;IF NONE, RE-ENTER READ-EVAL-PRINT LOOP + PUSH TP,$TAB + PUSH TP,C + MOVEI B,PRIN1 + GETYP A,(C) ; GET ARGS TYPE + CAIE A,TATOM + JRST ERROK + MOVE A,1(C) ; GET ATOM + HRRO A,2(A) + CAME A,[-1,,ERROBL+1] + CAMN A,ERROBL+1 ; DONT SKIP IF IN ERROR OBLIST + MOVEI B,PRINC ; DONT PRINT TRAILER +ERROK: PUSH P,B ; SAVE ROUTINE POINTER + PUSH TP,(C) + PUSH TP,1(C) + MCALL 0,TERPRI ; CRLF + POP P,B ; GET ROUTINE BACK + .MCALL 1,(B) + POP TP,C + SUB TP,[1,,1] + ADD C,[2,,2] ;BUMP SAVED AB + JRST ERRLP ;AND CONTINUE + + +LEVPRT: XCT INITFL ;LOAD MUDDLE INIT FILE IF FIRST TIME + MCALL 0,TERPRI + PUSH TP,$TATOM + PUSH TP,EQUOTE [LISTENING-AT-LEVEL ] + MCALL 1,PRINC ;PRINT LEVEL + PUSH TP,$TFIX ;READY TO PRINT LEVEL + HRRZ A,(P) ;GET LEVEL + SUB P,[2,,2] ;AND POP STACK + PUSH TP,A + MCALL 1,PRIN1 ;PRINT WITHOUT SPACES ETC. + PUSH TP,$TATOM ;NOW PROCESS + PUSH TP,EQUOTE [ PROCESS ] + MCALL 1,PRINC ;DONT SLASHIFY SPACES + MOVE PVP,PVSTOR+1 + PUSH TP,PROCID(PVP) ;NOW ID + PUSH TP,PROCID+1(PVP) + MCALL 1,PRIN1 + SKIPN C,CURPRI + JRST MAINLP + PUSH TP,$TFIX + PUSH TP,C + PUSH TP,$TATOM + PUSH TP,EQUOTE [ INT-LEVEL ] + MCALL 1,PRINC + MCALL 1,PRIN1 + JRST MAINLP ; FALL INTO MAIN LOOP + + ;ROUTINES FOR ERROR-LISTEN + +OBCHK: GETYP 0,A + CAIN 0,TOBLS + JRST CPOPJ1 ; WIN FOR SINGLE OBLIST + CAIE 0,TLIST ; IF LIST, MAKE SURE EACH IS AN OBLIST + JRST CPOPJ ; ELSE, LOSE + + JUMPE B,CPOPJ ; NIL ,LOSE + PUSH TP,A + PUSH TP,B + PUSH P,[0] ;FLAG FOR DEFAULT CHECKING + MOVEI 0,1000 ; VERY BIG NUMBER FOR CIRCULARITY TEST + +OBCHK0: INTGO + SOJE 0,OBLOSE ; CIRCULARITY TEST + HRRZ B,(TP) ; GET LIST POINTER + GETYP A,(B) + CAIE A,TOBLS ; SKIP IF WINNER + JRST DEFCHK ; CHECK FOR SPECIAL ATOM DEFAULT + HRRZ B,(B) + MOVEM B,(TP) + JUMPN B,OBCHK0 +OBWIN: AOS (P)-1 +OBLOSE: SUB TP,[2,,2] + SUB P,[1,,1] + POPJ P, + +DEFCHK: SKIPN (P) ; BEEN HERE BEFORE ? + CAIE A,TATOM ; OR, NOT AN ATOM ? + JRST OBLOSE ; YES, LOSE + MOVE A,(B)+1 + CAME A,MQUOTE DEFAULT + JRST OBLOSE ; LOSE + SETOM (P) ; SET FLAG + HRRZ B,(B) ; CHECK FOR END OF LIST + MOVEM B,(TP) + JUMPN B,OBCHK0 ; NOT THE END, CONTINUE LOOKING + JRST OBLOSE ; LOSE FOR DEFAULT AT THE END + + + +PUSH6: PUSH TP,[TATOM,,-1] + PUSH TP,B + PUSH TP,(C) + PUSH TP,1(C) + PUSH TP,[0] + PUSH TP,[0] + POPJ P, + + +MAKOB: PUSH TP,INITIAL + PUSH TP,INITIAL+1 + PUSH TP,ROOT + PUSH TP,ROOT+1 + MCALL 2,LIST + PUSH TP,$TATOM + PUSH TP,IMQUOTE OBLIST + PUSH TP,A + PUSH TP,B + MCALL 2,SETG + PUSH TP,[TATOM,,-1] + PUSH TP,IMQUOTE OBLIST + PUSH TP,A + PUSH TP,B + PUSH TP,[0] + PUSH TP,[0] + JRST NOTOBL + + +;THIS IS IT FOLKS...THE MAIN LOOP. READ, EVAL, PRINT + +MAINLP: MOVE A,$TATOM ;KLUDGE BY NDR LIKE ERROR TO LET LOOSER REDEFINE + MOVE B,IMQUOTE REP + PUSHJ P,ILVAL ;GET ITS LVAL TO SEE IF REDEFINED + GETYP C,A + CAIE C,TUNBOUND + JRST REPCHK + MOVE A,$TATOM ;SEE IF IT HAS GVAL SINCE NO LVAL + MOVE B,IMQUOTE REP + PUSHJ P,IGVAL + GETYP C,A + CAIN C,TUNBOUN + JRST IREPER +REPCHK: CAIN C,TSUBR + CAIE B,REPER + JRST .+2 + JRST IREPER +REREPE: PUSH TP,A + PUSH TP,B + GETYP A,-1(TP) + PUSHJ P,APLQ + JRST ERRREP + MCALL 1,APPLY ;LOOSER HAS REDEFINED SO CALL HIS + JRST MAINLP +IREPER: PUSH P,[0] ;INDICATE FALL THROUGH + JRST REPERF + +ERRREP: PUSH TP,[TATOM,,-1] + PUSH TP,IMQUOTE REP + PUSH TP,$TSUBR + PUSH TP,[REPER] + PUSH TP,[0] + PUSH TP,[0] + PUSHJ P,SPECBIN + PUSH TP,$TATOM + PUSH TP,EQUOTE NON-APPLICABLE-REP + PUSH TP,-11(TP) + PUSH TP,-11(TP) + MCALL 2,ERROR + SUB TP,[6,,6] + PUSHJ P,SSPECS + JRST REREPE + + +IMFUNCTION REPER,SUBR,REP +REPER: ENTRY 0 + PUSH P,[1] ;INDICATE DIRECT CALL +REPERF: MCALL 0,TERPRI + MCALL 0,READ + PUSH TP,A + PUSH TP,B + MOVE B,IMQUOTE L-INS + PUSHJ P,ILVAL ; ASSIGNED? + GETYP 0,A + CAIN 0,TLIST + + PUSHJ P,LSTTOF ; PUT LAST AS FIRST + MCALL 0,TERPRI + MCALL 1,EVAL + MOVE C,IMQUOTE LAST-OUT + PUSHJ P,CISET + PUSH TP,A + PUSH TP,B + MOVE B,IMQUOTE L-OUTS + PUSHJ P,ILVAL ; ASSIGNED? + GETYP 0,A + CAIN 0,TLIST + + CAME B,(TP) ; DONT STUFF IT INTO ITSELF + JRST STUFIT ; STUFF IT IN + GETYP 0,-1(TP) + CAIE 0,TLIST ; IF A LIST THE L-OUTS +STUFIT: PUSHJ P,LSTTOF ; PUT LAST AS FIRST + MCALL 1,PRIN1 + POP P,C ;FLAG FOR FALL THROUGH OR CALL + JUMPN C,FINIS ;IN CASE LOOSER CALLED REP + JRST MAINLP + +LSTTOF: SKIPN A,B + POPJ P, + + HRRZ C,(A) + JUMPE C,LSTTO2 + MOVEI D,(C) ; SAVE PTR TO 2ND ELEMENT + MOVEI 0,-1 ; LET THE LOSER LOSE (HA HA HA) + +LSTTO1: HRRZ C,(C) ; START SCAN + JUMPE C,GOTIT + HRRZ A,(A) + SOJG 0,LSTTO1 + +GOTIT: HRRZ C,(A) + HLLZS (A) + CAIE D,(C) ; AVOID CIRCULARITY + HRRM D,(C) + HRRM C,(B) + MOVE D,1(B) + MOVEM D,1(C) + GETYP D,(B) + PUTYP D,(C) + +LSTTO2: MOVSI A,TLIST + MOVE C,-1(TP) + MOVE D,(TP) + JRST LSTUF + +;FUNCTION TO RETRY A PREVIOUS FUNCTION CALL + +MFUNCTION RETRY,SUBR + + ENTRY + JUMPGE AB,RETRY1 ; USE MOST RECENT + CAMGE AB,[-2,,0] + JRST TMA + GETYP A,(AB) ; CHECK TYPE + CAIE A,TFRAME + JRST WTYP1 + MOVEI B,(AB) ; POINT TO ARG + JRST RETRY2 +RETRY1: MOVE B,IMQUOTE LER,[LERR ]INTRUP + PUSHJ P,ILOC ; LOCATIVE TO FRAME +RETRY2: PUSHJ P,CHFSWP ; CHECK VALIDITY AND SWAP IF NECESSARY + HRRZ 0,OTBSAV(B) ; CHECK FOR TOP + JUMPE 0,RESTAR ; YES RE-ENTER TOP LEVEL + PUSH TP,$TTB + PUSH TP,B ; SAVE FRAME + MOVE B,OTBSAV(B) ; GET PRVIOUS FOR UNBIND HACK + MOVEI C,-1(TP) + PUSHJ P,CHUNW ; CHECK ANY UNWINDING + CAME SP,SPSAV(TB) ; UNBINDING NEEDED? + PUSHJ P,SPECSTORE + MOVE P,PSAV(TB) ; GET OTHER STUFF + MOVE AB,ABSAV(B) + HLRE A,AB ; COMPUTE # OF ARGS + MOVNI A,-FRAMLN(A) ; MAKE TP POINT PAST FRAME + HRLI A,(A) + MOVE C,TPSAV(TB) ; COMPUTE TP + ADD C,A + MOVE TP,C + MOVE TB,B ; FIX UP TB + HRRZ C,FSAV(TB) ; GET FUNCTION + CAIL C,HIBOT + JRST (C) ; GO + GETYP 0,(C) ; RSUBR OR ENTRY? + CAIE 0,TATOM + CAIN 0,TRSUBR + JRST RETRNT + MOVS R,(C) ; SET UP R + HRRI R,(C) + MOVEI C,0 + JRST RETRN3 + +RETRNT: CAIE 0,TRSUBR + JRST RETRN1 + MOVE R,1(C) +RETRN4: HRRZ C,2(C) ; OFFSET +RETRN3: SKIPL M,1(R) + JRST RETRN5 +RETRN7: ADDI C,(M) + JRST (C) + +RETRN5: MOVEI D,(M) ; TOTAL OFFSET + MOVSS M + ADD M,PURVEC+1 + SKIPL M,1(M) + JRST RETRN6 + ADDI M,(D) + JRST RETRN7 + +RETRN6: HLRZ A,1(R) + PUSH P,D + PUSH P,C + PUSHJ P,PLOAD + JRST RETRER ; LOSER + POP P,C + POP P,D + MOVE M,B + JRST RETRN7 + +RETRN1: HRL C,(C) ; FIX LH + MOVE B,1(C) + PUSH TP,$TVEC + PUSH TP,C + PUSHJ P,IGVAL + GETYP 0,A + MOVE C,(TP) + SUB TP,[2,,2] + CAIE 0,TRSUBR + JRST RETRN2 + MOVE R,B + JRST RETRN4 + +RETRN2: ERRUUO EQUOTE CANT-RETRY-ENTRY-GONE + +RETRER: ERRUUO EQUOTE PURE-LOAD-FAILURE + + +;FUNCTION TO DO ERROR RETURN + +IMFUNCTION ERRET,SUBR + + ENTRY + HLRE A,AB ; -2*# OF ARGS + JUMPGE A,STP ; RESTART PROCESS + ASH A,-1 ; -# OF ARGS + AOJE A,ERRET2 ; NO FRAME SUPPLIED + AOJL A,TMA + ADD AB,[2,,2] + PUSHJ P,OKFRT + JRST WTYP2 + SUB AB,[2,,2] + PUSHJ P,CHPROC ; POINT TO FRAME SLOT + JRST ERRET3 +ERRET2: MOVE B,IMQUOTE LER,[LERR ]INTRUP + PUSHJ P,ILVAL ; GET ITS VALUE +ERRET3: PUSH TP,A + PUSH TP,B + MOVEI B,-1(TP) + PUSHJ P,CHFSWP ; CHECK VALIDITY AND SWAP IF NECESSARY + HRRZ 0,OTBSAV(B) ; TOP LEVEL? + JUMPE 0,TOPLOS + PUSHJ P,CHUNW ; ANY UNWINDING + JRST CHFINIS + + +; FUNCTION TO RETURN LAST ERROR FRAME OR PREVIOUS FRAME + +IMFUNCTION FRAME,SUBR + ENTRY + SETZB A,B + JUMPGE AB,FRM1 ; DEFAULT CASE + CAMG AB,[-3,,0] ; SKIP IF OK ARGS + JRST TMA + PUSHJ P,OKFRT ; A FRAME OR SIMILAR THING? + JRST WTYP1 + +FRM1: PUSHJ P,CFRAME ; GO TO INTERNAL + JRST FINIS + +CFRAME: JUMPN A,FRM2 ; ARG SUPPLIED? + MOVE B,IMQUOTE LER,[LERR ]INTRUP + PUSHJ P,ILVAL + JRST FRM3 +FRM2: PUSHJ P,CHPROC ; CHECK FOR PROCESS + PUSH TP,A + PUSH TP,B + MOVEI B,-1(TP) ; POINT TO SLOT + PUSHJ P,CHFRM ; CHECK IT + MOVE C,(TP) ; GET FRAME BACK + MOVE B,OTBSAV(C) ;GET PREVIOUS FRAME + SUB TP,[2,,2] + TRNN B,-1 ; SKIP IF OK + JRST TOPLOSE + +FRM3: JUMPN B,FRM4 ; JUMP IF WINNER + MOVE B,IMQUOTE THIS-PROCESS + PUSHJ P,ILVAL ; GET PROCESS OF INTEREST + GETYP A,A ; CHECK IT + CAIN A,TUNBOU + MOVE B,PVSTOR+1 ; USE CURRENT + MOVEI A,PVLNT*2+1(B) ; POINT TO DOPE WORDS + MOVE B,TBINIT+1(B) ; AND BASE FRAME +FRM4: HLL B,OTBSAV(B) ;TIME + HRLI A,TFRAME + POPJ P, + +OKFRT: AOS (P) ;ASSUME WINNAGE + GETYP 0,(AB) + MOVE A,(AB) + MOVE B,1(AB) + CAIE 0,TFRAME + CAIN 0,TENV + POPJ P, + CAIE 0,TPVP + CAIN 0,TACT + POPJ P, + SOS (P) + POPJ P, + +CHPROC: GETYP 0,A ; TYPE + CAIE 0,TPVP + POPJ P, ; OK + MOVEI A,PVLNT*2+1(B) + CAMN B,PVSTOR+1 ; THIS PROCESS? + JRST CHPRO1 + MOVE B,TBSTO+1(B) + JRST FRM4 + +CHPRO1: MOVE B,OTBSAV(TB) + JRST FRM4 + +; FUNCTION TO RETURN ARGS TUPLE FOR A FRAME + +MFUNCTION ARGS,SUBR + ENTRY 1 + PUSHJ P,OKFRT ; CHECK FRAME TYPE + JRST WTYP1 + PUSHJ P,CARGS + JRST FINIS + +CARGS: PUSHJ P,CHPROC + PUSH TP,A + PUSH TP,B + MOVEI B,-1(TP) ; POINT TO FRAME SLOT + PUSHJ P,CHFRM ; AND CHECK FOR VALIDITY + MOVE C,(TP) ; FRAME BACK + MOVSI A,TARGS +CARGS1: GETYP 0,FSAV(C) ; IS THIS A FUNNY ONE + CAIE 0,TCBLK ; SKIP IF FUNNY + JRST .+3 ; NO NORMAL + MOVE C,OTBSAV(C) ; ASSOCIATE WITH PREVIOUS FRAME + JRST CARGS1 + HLR A,OTBSAV(C) ; TIME IT AND + MOVE B,ABSAV(C) ; GET POINTER + SUB TP,[2,,2] ; FLUSH CRAP + POPJ P, + +; FUNCTION TO RETURN FUNCTION ASSOCIATED WITH A FRAME + +MFUNCTION FUNCT,SUBR + ENTRY 1 ; FRAME ARGUMENT + PUSHJ P,OKFRT ; CHECK TYPE + JRST WTYP1 + PUSHJ P,CFUNCT + JRST FINIS + +CFUNCT: PUSHJ P,CHPROC + PUSH TP,A + PUSH TP,B + MOVEI B,-1(TP) + PUSHJ P,CHFRM ; CHECK IT + MOVE C,(TP) ; RESTORE FRAME + HRRZ A,FSAV(C) ;FUNCTION POINTER + CAIL A,HIBOT + SKIPA B,@-1(A) ;NO, GET SUBR'S NAME POINTER + MOVE B,(A)+3 ;YES, GET RSUBR'S NAME ENTRY + MOVSI A,TATOM + SUB TP,[2,,2] + POPJ P, + +BADFRAME: + ERRUUO EQUOTE FRAME-NO-LONGER-EXISTS + + +TOPLOSE: + ERRUUO EQUOTE TOP-LEVEL-FRAME + + + + +; ROUTINE TO HANG INDEFINITELY WITH INTERRUPTS ENABLED + +MFUNCTION HANG,SUBR + + ENTRY + + JUMPGE AB,HANG1 ; NO PREDICATE + CAMGE AB,[-3,,] + JRST TMA +REHANG: MOVE A,[PUSHJ P,CHKPRH] + MOVEM A,ONINT ; CHECK PREDICATE AFTER ANY INTERRUPT + PUSH TP,(AB) + PUSH TP,1(AB) +HANG1: ENABLE ;LET OURSELVES BE INTERRUPTED OUT + PUSHJ P,%HANG + DISABLE ;PREVENT INTERRUPTS AT RANDOM TIMES + SETZM ONINT + MOVE A,$TATOM + MOVE B,IMQUOTE T + JRST FINIS + + +; ROUTINE TO SLEEP FOR POSITIVE NUMBER OF SECONDS WITH INTERRUPTS ENABLED +; ARGUMENT SHOULD BE OF TYPE FIX OR FLOAT AND NON-NEGATIVE + +MFUNCTION SLEEP,SUBR + + ENTRY + + JUMPGE AB,TFA + CAML AB,[-3,,] + JRST SLEEP1 + CAMGE AB,[-5,,] + JRST TMA + PUSH TP,2(AB) + PUSH TP,3(AB) +SLEEP1: GETYP 0,(AB) + CAIE 0,TFIX + JRST .+5 + MOVE B,1(AB) + JUMPL B,OUTRNG ;ARG SHOULDNT BE NEGATIVE + IMULI B,30. ;CONVERT TO # OF THIRTIETHS OF A SECOND + JRST SLEEPR ;GO SLEEP + CAIE 0,TFLOAT ;IF IT WASNT FIX MAKE SURE IT IS FLOAT + JRST WTYP1 ;WRONG TYPE ARG + MOVE B,1(AB) + FMPR B,[30.0] ;CONVERT TO FLOATING # OF THIRTIETHS OF A SECOND + MULI B,400 ;KLUDGE TO FIX IT + TSC B,B + ASH C,(B)-243 + MOVE B,C ;MOVE THE FIXED NUMBER INTO B + JUMPL B,OUTRNG ;CHECK TO SEE THAT WE HAVE POSITIVE NUMBER +SLEEPR: MOVE A,B +RESLEE: MOVE B,[PUSHJ P,CHKPRS] + CAMGE AB,[-3,,] + MOVEM B,ONINT + ENABLE + PUSHJ P,%SLEEP + DISABLE + SETZM ONINT + MOVE A,$TATOM + MOVE B,IMQUOTE T + JRST FINIS + +CHKPRH: PUSH P,B + MOVEI B,HANGP + JRST .+3 + +CHKPRS: PUSH P,B + MOVEI B,SLEEPP + HRRM B,LCKINT + SETZM ONINT ; TURN OFF FEATURE FOR NOW + POP P,B + POPJ P, + +HANGP: SKIPA B,[REHANG] +SLEEPP: MOVEI B,RESLEE + PUSH P,B + PUSH P,A + DISABLE + PUSH TP,(TB) + PUSH TP,1(TB) + MCALL 1,EVAL + GETYP 0,A + CAIE 0,TFALSE + JRST FINIS + POP P,A + POPJ P, + +MFUNCTION VALRET,SUBR +; SUBR TO VALRET A STRING TO SUPERIOR ITS PROCESS + + ENTRY 1 + GETYP A,(AB) ; GET TYPE OF ARGUMENT + CAIN A,TFIX ; FIX? + JRST VALRT1 + CAIE A,TCHSTR ; IS IT A CHR STRING? + JRST WTYP1 ; NO...ERROR WRONG TYPE + PUSHJ P,CSTACK ; COPY THE CHR STRING TO THE STACK + ; CSTACK IS IN ATOMHK + MOVEI B,0 ; ASCIZ TERMINATOR + EXCH B,(P) ; STORE AND RETRIEVE COUNT + +; CALCULATE THE BEGINNING ADDR OF THE STRING + MOVEI A,-1(P) ; GET ADDR OF TOP OF STACK + SUBI A,-1(B) ; GET STARTING ADDR + PUSHJ P,%VALRE ; PASS UP TO MONITOR + JRST IFALSE ; IF HE RETURNS, RETURN FALSE + +VALRT1: MOVE A,1(AB) + PUSHJ P,%VALFI + JRST IFALSE + +MFUNCTION LOGOUT,SUBR + +; SUBR TO DO A .LOGOUT (VALID ONLY AT TOP LEVEL) + ENTRY 0 + PUSHJ P,%TOPLQ ; SKIP IF AT TOP LEVEL + JRST IFALSE + PUSHJ P,CLOSAL + PUSHJ P,%LOGOUT ; TRY TO FLUSH + JRST IFALSE ; COULDN'T DO IT...RETURN FALSE + +; FUNCTS TO GET UNAME AND JNAME + +; GET XUNAME (REAL UNAME) +MFUNCTION XUNAME,SUBR + + ENTRY 0 + + PUSHJ P,%RXUNA + JRST RSUJNM + JRST FINIS ; 10X ROUTINES SKIP + +MFUNCTION UNAME,SUBR + + ENTRY 0 + + PUSHJ P,%RUNAM + JRST RSUJNM + JRST FINIS + +; REAL JNAME +MFUNCTION XJNAME,SUBR + + ENTRY 0 + + PUSHJ P,%RXJNA + JRST RSUJNM + +MFUNCTION JNAME,SUBR + + ENTRY 0 + + PUSHJ P,%RJNAM + JRST RSUJNM + +; FUNCTION TO SET AND READ GLOBAL SNAME + +MFUNCTION SNAME,SUBR + + ENTRY + + JUMPGE AB,SNAME1 + CAMG AB,[-3,,] + JRST TMA + GETYP A,(AB) ; ARG MUST BE STRING + CAIE A,TCHSTR + JRST WTYP1 + PUSH TP,$TATOM + PUSH TP,IMQUOTE SNM + PUSH TP,(AB) + PUSH TP,1(AB) + MCALL 2,SETG + JRST FINIS + +SNAME1: MOVE B,IMQUOTE SNM + PUSHJ P,IDVAL1 + GETYP 0,A + CAIN 0,TCHSTR + JRST FINIS + MOVE A,$TCHSTR + MOVE B,CHQUOTE + JRST FINIS + +RSUJNM: PUSHJ P,6TOCHS ; CONVERT IT + JRST FINIS + + +SGSNAM: MOVE B,IMQUOTE SNM + PUSHJ P,IDVAL1 + GETYP 0,A + CAIE 0,TCHSTR + JRST SGSN1 + + PUSH TP,A + PUSH TP,B + PUSHJ P,STRTO6 + POP P,A + SUB TP,[2,,2] + JRST .+2 + +SGSN1: MOVEI A,0 + PUSHJ P,%SSNAM ; SET SNAME IN SYSTEM + POPJ P, + + + +;THIS SUBROUTINE ALLOCATES A NEW PROCESS +;TAKES TP-STACK SIZE (2*WORDS) IN A AND P-STACK SIZE (WORDS) IN B +;IS CALLED BY PUSHJ P,. RETURNS IN A AND B A NEW PROCESS. + +ICR: PUSH P,A + PUSH P,B + MOVEI A,PVLNT ;SETUP CALL TO VECTOR FOR PVP + PUSHJ P,IVECT ;GOBBLE A VECTOR + HRLI C,PVBASE ;SETUP A BLT POINTER + HRRI C,(B) ;GET INTO ADDRESS + BLT C,PVLNT*2-1(B) ;COPY A PROTOTYPE INTO NEW PVP + MOVSI C,400000+SPVP+.VECT. ;SET SPECIAL TYPE + MOVEM C,PVLNT*2(B) ;CLOBBER IT IN + PUSH TP,A ;SAVE THE RESULTS OF VECTOR + PUSH TP,B + + PUSH TP,$TFIX ;GET A UNIFORM VECTOR + POP P,B + PUSH TP,B + MCALL 1,UVECTOR + ADD B,[PDLBUF-2,,-1] ;FUDGE WITH BUFFER + MOVE C,(TP) ;REGOBBLE PROCESS POINTER + MOVEM B,PSTO+1(C) ;STORE IN ALL HOMES + MOVEM B,PBASE+1(C) + + + POP P,A ;PREPARE TO CREATE A TEMPORARY PDL + PUSHJ P,IVECT ;GET THE TEMP PDL + ADD B,[PDLBUF,,0] ;PDL GROWTH HACK + MOVE C,(TP) ;RE-GOBBLE NEW PVP + SUB B,[1,,1] ;FIX FOR STACK + MOVEM B,TPBASE+1(C) + +;SETUP INITIAL BINDING + + PUSH B,$TBIND + MOVEM B,SPBASE+1(C) ;SAVE AS BASE OF SP + MOVEM B,SPSTO+1(C) ;AND CURRENT THEREOF + MOVEM B,CURFCN+1(C) ; AND AS CURRENT FCN FOR SPEC/UNSPEC LOGIC + PUSH B,IMQUOTE THIS-PROCESS + PUSH B,$TPVP ;GIVE IT PROCESS AS VALUE + PUSH B,C + ADD B,[2,,2] ;FINISH FRAME + MOVEM B,TPSTO+1(C) ;MAKE THIS THE CURRENT STACK POINTER + MOVEM C,PVPSTO+1(C) ;SAVE THE NEW PVP ITSELF + AOS A,IDPROC ;GOBBLE A UNIQUE PROCESS I.D. + MOVEM A,PROCID+1(C) ;SAVE THAT ALSO + AOS A,PTIME ; GET A UNIQUE BINDING ID + MOVEM A,BINDID+1(C) + + MOVSI A,TPVP ;CLOBBER THE TYPE + MOVE B,(TP) ;AND POINTER TO PROCESS + SUB TP,[2,,2] + POPJ P, + +;MINI ROUTINE TO CALL VECTOR WITH COUNT IN A + +IVECT: PUSH TP,$TFIX + PUSH TP,A + MCALL 1,VECTOR ;GOBBLE THE VECTOR + POPJ P, + + +;SUBROUTINE TO SWAP A PROCESS IN +;CALLED WITH JSP A,SWAP AND NEW PVP IN B + +SWAP: ;FIRST STORE ALL THE ACS + + MOVE PVP,PVSTOR+1 + MOVE SP,$TSP ; STORE SPSAVE + MOVEM SP,SPSTO(PVP) + MOVE SP,SPSTOR+1 + IRP A,,[SP,AB,TB,TP,P,M,R,FRM] + MOVEM A,A!STO+1(PVP) + TERMIN + + SETOM 1(TP) ; FENCE POST MAIN STACK + MOVEM TP,TPSAV(TB) ; CORRECT FRAME + SETZM PSAV(TB) ; CLEAN UP CURRENT FRAME + SETZM SPSAV(TB) + SETZM PCSAV(TB) + + MOVE E,PVP ;RETURN OLD PROCESS IN E + MOVE PVP,D ;AND MAKE NEW ONE BE D + MOVEM PVP,PVSTOR+1 + +SWAPIN: + ;NOW RESTORE NEW PROCESSES AC'S + + MOVE PVP,PVSTOR+1 + IRP A,,[AB,TB,SP,TP,P,M,R,FRM] + MOVE A,A!STO+1(PVP) + TERMIN + + SETZM SPSTO(PVP) + MOVEM SP,SPSTOR+1 + JRST (C) ;AND RETURN + + + + +;SUBRS ASSOCIATED WITH TYPES + +;TYPE (ITYPE) ARE FUNCTIONS TO RETURN THE ATOMIC NAME OF THE +;TYPE OF A GOODIE. TYPE TAKES ITS ARGS ON AP AND RETURNS IN A AND B. +;ITYPE TAKES ITS ARGS IN A AND B AND RETURNS IN SAME (B=0) FOR INVALID +;TYPECODE. +MFUNCTION TYPE,SUBR + + ENTRY 1 + GETYP A,(AB) ;TYPE INTO A +TYPE1: PUSHJ P,ITYPE ;GO TO INTERNAL + JUMPN B,FINIS ;GOOD RETURN +TYPERR: ERRUUO EQUOTE TYPE-UNDEFINED + +CITYPE: GETYP A,A ; GET TYPE FOR COMPILER CALL +ITYPE: LSH A,1 ;TIMES 2 + HRLS A ;TO BOTH SIDES + ADD A,TYPVEC+1 ;GET ACTUAL LOCATION + JUMPGE A,TYPERR ;LOST, TYPE OUT OF BOUNDS + MOVE B,1(A) ;PICKUP TYPE + HLLZ A,(A) + POPJ P, + +; PREDICATE -- IS OBJECT OF TYPE SPECIFIED + +MFUNCTION %TYPEQ,SUBR,[TYPE?] + + ENTRY + + MOVE D,AB ; GET ARGS + ADD D,[2,,2] + JUMPGE D,TFA + MOVE A,(AB) + HLRE C,D + MOVMS C + ASH C,-1 ; FUDGE + PUSHJ P,ITYPQ ; GO INTERNAL + JFCL + JRST FINIS + +ITYPQ: GETYP A,A ; OBJECT + PUSHJ P,ITYPE +TYPEQ0: SOJL C,CIFALS + GETYP 0,(D) + CAIE 0,TATOM ; Type name must be an atom + JRST WRONGT + CAMN B,1(D) ; Same as the OBJECT? + JRST CPOPJ1 ; Yes, return type name + ADD D,[2,,2] + JRST TYPEQ0 ; No, continue comparing + +CIFALS: MOVEI B,0 + MOVSI A,TFALSE + POPJ P, + +CTYPEQ: SOJE A,CIFALS ; TREAT NO ARGS AS FALSE + MOVEI D,1(A) ; FIND BASE OF ARGS + ASH D,1 + HRLI D,(D) + SUBM TP,D ; D POINTS TO BASE + MOVE E,D ; SAVE FOR TP RESTORE + ADD D,[3,,3] ; FUDGE + MOVEI C,(A) ; NUMBER OF TYPES + MOVE A,-2(D) + PUSHJ P,ITYPQ + JFCL ; IGNORE SKIP FOR NOW + MOVE TP,E ; SET TP BACK + JUMPL B,CPOPJ1 ; SKIP + POPJ P, + +; Entries to get type codes for types for fixing up RSUBRs and assembling + +MFUNCTION %TYPEC,SUBR,[TYPE-C] + + ENTRY + + JUMPGE AB,TFA + GETYP 0,(AB) + CAIE 0,TATOM + JRST WTYP1 + MOVE B,1(AB) + CAMGE AB,[-3,,0] ; skip if only type name given + JRST GTPTYP + MOVE C,IMQUOTE ANY + +TYPEC1: PUSHJ P,CTYPEC ; go to internal + JRST FINIS + +GTPTYP: CAMGE AB,[-5,,0] + JRST TMA + GETYP 0,2(AB) + CAIE 0,TATOM + JRST WTYP2 + MOVE C,3(AB) + JRST TYPEC1 + +CTYPEC: PUSH P,C ; save primtype checker + PUSHJ P,TYPFND ; search type vector + JRST CTPEC2 ; create the poor loser + POP P,B + CAMN B,IMQUOTE ANY + JRST CTPEC1 + CAMN B,IMQUOTE TEMPLATE + JRST TCHK + PUSH P,D + HRRZ A,(A) + ANDI A,SATMSK + PUSH P,A + PUSHJ P,TYPLOO + HRRZ 0,(A) + ANDI 0,SATMSK + CAME 0,(P) + JRST TYPDIF + MOVE D,-1(P) + SUB P,[2,,2] +CTPEC1: MOVEI B,(D) + MOVSI A,TTYPEC + POPJ P, +TCHK: PUSH P,D ; SAVE TYPE + MOVE A,D ; GO TO SAT + PUSHJ P,SAT + CAIG A,NUMSAT ; SKIP IF A TEMPLATE + JRST TYPDIF + POP P,D ; RESTORE TYPE + JRST CTPEC1 + +CTPEC2: POP P,C ; GET BACK PRIMTYPE + SUBM M,(P) + PUSH TP,$TATOM + PUSH TP,B + CAMN C,IMQUOTE ANY + JRST CTPEC3 + PUSH TP,$TATOM + PUSH TP,C + MCALL 2,NEWTYPE ; CREATE THE POOR GUY + MOVE C,IMQUOTE ANY + SUBM M,(P) ; UNRELATIVIZE + JRST CTYPEC + +CTPEC3: HRRZ 0,FSAV(TB) + CAIE 0,%TYPEC + CAIN 0,%TYPEW + JRST TYPERR + + MCALL 1,%TYPEC + JRST MPOPJ + +MFUNCTION %TYPEW,SUBR,[TYPE-W] + + ENTRY + + JUMPGE AB,TFA + GETYP 0,(AB) + CAIE 0,TATOM + JRST WTYP1 + MOVEI D,0 + MOVE C,IMQUOTE ANY + MOVE B,1(AB) + CAMGE AB,[-3,,0] + JRST CTYPW1 + +CTYPW3: PUSHJ P,CTYPEW + JRST FINIS + +CTYPW1: GETYP 0,2(AB) + CAIE 0,TATOM + JRST WTYP2 + CAMGE AB,[-5,,0] ; JUMP IF RH IS GIVEN + JRST CTYPW2 +CTYPW5: MOVE C,3(AB) + JRST CTYPW3 + +CTYPW2: CAMGE AB,[-7,,0] + JRST TMA + GETYP 0,4(AB) + CAIE 0,TFIX + JRST WRONGT + MOVE D,5(AB) + JRST CTYPW5 + +CTYPEW: PUSH P,D + PUSHJ P,CTYPEC ; GET CODE IN B + POP P,B + HRLI B,(D) + MOVSI A,TTYPEW + POPJ P, + +MFUNCTION %VTYPE,SUBR,[VALID-TYPE?] + + ENTRY 1 + + GETYP 0,(AB) + CAIE 0,TATOM + JRST WTYP1 + MOVE B,1(AB) + + PUSHJ P,CVTYPE + JFCL + JRST FINIS + +CVTYPE: PUSHJ P,TYPFND ; LOOK IT UP + JRST PFALS + + MOVEI B,(D) + MOVSI A,TTYPEC + JRST CPOPJ1 + +PFALS: MOVEI B,0 + MOVSI A,TFALSE + POPJ P, + +;PRIMTTYPE RETURNS THE TYPE ATOM OF A PRIMITIVE TYPE IN A CLASS + +STBL: REPEAT NUMSAT,SETZ MQUOTE INTERNAL-TYPE + +LOC STBL + +IRP A,,[[1WORD,WORD],[2WORD,LIST],[NWORD,UVECTOR],[2NWORD,VECTOR],[STORE,STORAGE] +[ARGS,TUPLE],[FRAME,FRAME],[ATOM,ATOM],[LOCID,LOCD],[CHSTR,STRING],[OFFS,OFFSET,1] +[PVP,PROCESS,1],[ASOC,ASOC,1],[LOCA,LOCA],[LOCS,LOCS],[LOCU,LOCU],[LOCV,LOCV] +[LOCL,LOCL],[LOCN,LOCAS],[LOCT,LOCT,1],[LOCR,LOCR],[LOCB,LOCB,1],[BYTE,BYTES,1]] +IRP B,C,[A] +LOC STBL+S!B +IRP X,Y,[C] +IFSE [Y],SETZ IMQUOTE X +IFSN [Y],SETZ MQUOTE X +.ISTOP +TERMIN +.ISTOP + +TERMIN +TERMIN + +LOC STBL+NUMSAT+1 + + +MFUNCTION TYPEPRIM,SUBR + + ENTRY 1 + GETYP A,(AB) + CAIE A,TATOM + JRST NOTATOM + MOVE B,1(AB) + PUSHJ P,CTYPEP + JRST FINIS + +CTYPEP: PUSHJ P,TYPLOO ; CONVERT ATOM TO CODE + HRRZ A,(A) ; SAT TO A + ANDI A,SATMSK + JRST PTYP1 + +MFUNCTION PTSATC,SUBR,[PRIMTYPE-C] + + ENTRY 1 + + GETYP A,(AB) + CAIE A,TATOM + JRST WTYP1 + MOVE B,1(AB) + PUSHJ P,CPRTYC + JRST FINIS + +CPRTYC: PUSHJ P,TYPLOO + MOVE B,(A) + ANDI B,SATMSK + MOVSI A,TSATC + POPJ P, + + +IMFUNCTION PRIMTYPE,SUBR + + ENTRY 1 + + MOVE A,(AB) ;GET TYPE + PUSHJ P,CPTYPE + JRST FINIS + +CPTYPE: GETYP A,A + PUSHJ P,SAT ;GET SAT +PTYP1: JUMPE A,TYPERR + MOVE B,IMQUOTE TEMPLATE + CAIG A,NUMSAT ; IF BIG SAT, THEN TEMPLATE + MOVE B,@STBL(A) + MOVSI A,TATOM + POPJ P, + + +; RSUBR MAKES A VECTOR INTO AN OBJECT OF TYPE RSUBR, ALSO SLIGHTLY MUNGING IT + +IMFUNCTION RSUBR,SUBR + ENTRY 1 + + GETYP A,(AB) + CAIE A,TVEC ; MUST BE VECTOR + JRST WTYP1 + MOVE B,1(AB) ; GET IT + GETYP A,(B) ; CHECK 1ST ELEMENTS TYPE + CAIN A,TPCODE ; PURE CODE + JRST .+3 + CAIE A,TCODE + JRST NRSUBR + HLRM B,(B) ; CLOBEER SPECIAL COUNT FIELD + MOVSI A,TRSUBR + JRST FINIS + +NRSUBR: ERRUUO EQUOTE FIRST-ELEMENT-OF-VECTOR-NOT-CODE + +; ROUTINE TO GENERATE ENTRYY OTHER THAN FIRST TO RSUBRR + +IMFUNCTION MENTRY,SUBR,[RSUBR-ENTRY] + + ENTRY 2 + + GETYP 0,(AB) ; TYPE OF ARG + CAIE 0,TVEC ; BETTER BE VECTOR + JRST WTYP1 + GETYP 0,2(AB) + CAIE 0,TFIX + JRST WTYP2 + MOVE B,1(AB) ; GET VECTOR + CAML B,[-3,,0] + JRST BENTRY + GETYP 0,(B) ; FIRST ELEMENT + CAIE 0,TRSUBR + JRST MENTR1 +MENTR2: GETYP 0,2(B) + CAIE 0,TATOM + JRST BENTRY + MOVE C,3(AB) + HRRM C,2(B) ; OFFSET INTO VECTOR + HLRM B,(B) + MOVSI A,TENTER + JRST FINIS + +MENTR1: CAIE 0,TATOM + JRST BENTRY + MOVE B,1(B) ; GET ATOM + PUSHJ P,IGVAL ; GET VAL + GETYP 0,A + CAIE 0,TRSUBR + JRST BENTRY + MOVE C,1(AB) ; RESTORE B + MOVEM A,(C) + MOVEM B,1(C) + MOVE B,C + JRST MENTR2 + +BENTRY: ERRUUO EQUOTE BAD-VECTOR + +; SUBR TO GET ENTRIES OFFSET + +MFUNCTION LENTRY,SUBR,[ENTRY-LOC] + + ENTRY 1 + + GETYP 0,(AB) + CAIE 0,TENTER + JRST WTYP1 + MOVE B,1(AB) + HRRZ B,2(B) + MOVSI A,TFIX + JRST FINIS + +; RETURN FALSE + +RTFALS: MOVSI A,TFALSE + MOVEI B,0 + POPJ P, + +;SUBROUTINE CALL FOR RSUBRs +RCALL: SUBM M,(P) ;CALCULATE PC's OFFSET IN THE RSUBR + HRLI 0,400000 ; DONT LOSE IN MULTI SEG MODE + + PUSHJ P,@0 ;GO TO THE PROPER SUBROUTINE + SUBM M,(P) ;RECONSTITUTE THE RSUBR's PC + POPJ P, + + + +;CHTYPE TAKES TWO ARGUMENTS. ANY GOODIE AND A AN ATOMIC TYPE NAME +;IT CHECKS THE STORAGE ALLOCATION TYPES OF THE TWO ARE THE SAME AND +;IF THEY ARE CHANGES THE TYPE OF THE FIRST TO THAT NAME D IN THE SECOND + +MFUNCTION CHTYPE,SUBR + + ENTRY 2 + GETYP A,2(AB) ;FIRST CHECK THAT ARG 2 IS AN ATOM + CAIE A,TATOM + JRST NOTATOM + MOVE B,3(AB) ;AND TYPE NAME + PUSHJ P,TYPLOO ;GO LOOKUP TYPE +TFOUND: HRRZ B,(A) ;GOBBLE THE SAT + TRNE B,CHBIT ; SKIP IF CHTYPABLE + JRST CANTCH + TRNE B,TMPLBT ; TEMPLAT + HRLI B,-1 + AND B,[-1,,SATMSK] + GETYP A,(AB) ;NOW GET TYPE TO HACK + PUSHJ P,SAT ;FIND OUT ITS SAT + JUMPE A,TYPERR ;COMPLAIN + CAILE A,NUMSAT + JRST CHTMPL ; JUMP IF TEMPLATE DATA + CAIE A,(B) ;DO THEY AGREE? + JRST TYPDIF ;NO, COMPLAIN +CHTMP1: MOVSI A,(D) ;GET NEW TYPE + HRR A,(AB) ; FOR DEFERRED GOODIES + JUMPL B,CHMATC ; CHECK IT + MOVE B,1(AB) ;AND VALUE + JRST FINIS + +CHTMPL: MOVE E,1(AB) ; GET ARG + HLRZ A,(E) + ANDI A,SATMSK + MOVE 0,3(AB) ; SEE IF TO "TEMPLATE" + CAMN 0,IMQUOTE TEMPLATE + JRST CHTMP1 + TLNN E,-1 ; SKIP IF RESTED + CAIE A,(B) + JRST TYPDIF + JRST CHTMP1 + +CHMATC: PUSH TP,A + PUSH TP,1(AB) ; SAVE GOODIE + MOVSI A,TATOM + MOVE B,3(AB) + MOVSI C,TATOM + MOVE D,IMQUOTE DECL + PUSHJ P,IGET ; FIND THE DECL + PUSH TP,A + PUSH TP,B + MOVE C,(AB) + MOVE D,1(AB) ; NOW GGO TO MATCH + PUSHJ P,TMATCH + JRST CHMAT1 + SUB TP,[2,,2] +CHMAT2: POP TP,B + POP TP,A + JRST FINIS + +CHMAT1: POP TP,B + POP TP,A + MOVE C,-1(TP) + MOVE D,(TP) + PUSHJ P,TMATCH + JRST TMPLVI + JRST CHMAT2 + +TYPLOO: PUSHJ P,TYPFND + ERRUUO EQUOTE BAD-TYPE-NAME + POPJ P, + +TYPFND: HLRE A,B ; FIND DOPE WORDS + SUBM B,A ; A POINTS TO IT + HRRE D,(A) ; TYPE-CODE TO D + JUMPE D,CPOPJ + ANDI D,TYPMSK ; FLUSH FUNNY BITS + MOVEI A,(D) + ASH A,1 + HRLI A,(A) + ADD A,TYPVEC+1 +CPOPJ1: AOS (P) + POPJ P, + + +REPEAT 0,[ + MOVE A,TYPVEC+1 ;GOBBLE DOWN TYPE VECTOR + MOVEI D,0 ;INITIALIZE TYPE COUNTER +TLOOK: CAMN B,1(A) ;CHECK THIS ONE + JRST CPOPJ1 + ADDI D,1 ;BUMP COUNTER + AOBJP A,.+2 ;COUTN DOWN ON VECTOR + AOBJN A,TLOOK + POPJ P, +CPOPJ1: AOS (P) + POPJ P, +] + +TYPDIF: ERRUUO EQUOTE STORAGE-TYPES-DIFFER + + +TMPLVI: ERRUUO EQUOTE DECL-VIOLATION + + +; FUNCTION TO ADD A NEW TYPE TO THE WORLD WITH GIVEN PRIMITIVE TYPE + +MFUNCTION NEWTYPE,SUBR + + ENTRY + + HLRZ 0,AB ; CHEC # OF ARGS + CAILE 0,-4 ; AT LEAST 2 + JRST TFA + CAIGE 0,-6 + JRST TMA ; NOT MORE THAN 3 + GETYP A,(AB) ; GET 1ST ARGS TYPE (SHOULD BE ATOM) + GETYP C,2(AB) ; SAME WITH SECOND + CAIN A,TATOM ; CHECK + CAIE C,TATOM + JRST NOTATOM + + MOVE B,3(AB) ; GET PRIM TYPE NAME + PUSHJ P,TYPLOO ; LOOK IT UP + HRRZ A,(A) ; GOBBLE SAT + ANDI A,SATMSK + HRLI A,TATOM ; MAKE NEW TYPE + PUSH P,A ; AND SAVE + MOVE B,1(AB) ; SEE IF PREV EXISTED + PUSHJ P,TYPFND + JRST NEWTOK ; DID NOT EXIST BEFORE + MOVEI B,2(A) ; FOR POSSIBLE TMPLAT BIT + HRRZ A,(A) ; GET SAT + HRRZ 0,(P) ; AND PROPOSED + ANDI A,SATMSK + ANDI 0,SATMSK + CAIN 0,(A) ; SKIP IF LOSER + JRST NEWTFN ; O.K. + + ERRUUO EQUOTE TYPE-ALREADY-EXISTS + +NEWTOK: POP P,A + MOVE B,1(AB) ; NEWTYPE NAME + PUSHJ P,INSNT ; MUNG IN NEW TYPE + +NEWTFN: CAML AB,[-5,,] ; SKIP IF TEMPLAT SUPPLIED + JRST NEWTF1 + MOVEI 0,TMPLBT ; GET THE BIT + IORM 0,-2(B) ; INTO WORD + MOVE A,(AB) ; GET TYPE NAME + MOVE B,1(AB) + MOVSI C,TATOM + MOVE D,IMQUOTE DECL + PUSH TP,4(AB) ; GET TEMLAT + PUSH TP,5(AB) + PUSHJ P,IPUT +NEWTF1: MOVE A,(AB) + MOVE B,1(AB) ; RETURN NAME + JRST FINIS + +; SET UP GROWTH FIELDS + +IGROWT: SKIPA A,[111100,,(C)] +IGROWB: MOVE A,[001100,,(C)] + HLRE B,C + SUB C,B ; POINT TO DOPE WORD + MOVE B,TYPIC ; INDICATED GROW BLOCK + DPB B,A + POPJ P, + +INSNT: PUSH TP,A + PUSH TP,B ; SAVE NAME OF NEWTYPE + MOVE C,TYPBOT+1 ; CHECK GROWTH NEED + CAMGE C,TYPVEC+1 + JRST ADDIT ; STILL ROOM +GAGN: PUSHJ P,IGROWB ; SETUP BOTTOM GROWTH + SKIPE C,EVATYP+1 + PUSHJ P,IGROWT ; SET UP TOP GROWTH + SKIPE C,APLTYP+1 + PUSHJ P,IGROWT + SKIPE C,PRNTYP+1 + PUSHJ P,IGROWT + MOVE C,[11.,,5] ; SET UP INDICATOR FOR AGC + PUSHJ P,AGC ; GROW THE WORLD + AOJL A,GAGN ; BAD AGC LOSSAGE + MOVE 0,[-101,,-100] + ADDM 0,TYPBOT+1 ; FIX UP POINTER + +ADDIT: MOVE C,TYPVEC+1 + SUB C,[2,,2] ; ALLOCATE ROOM + MOVEM C,TYPVEC+1 + HLRE B,C ; PREPARE TO BLT + SUBM C,B ; C POINTS DOPE WORD END + HRLI C,2(C) ; GET BLT AC READY + BLT C,-3(B) + POP TP,-1(B) ; CLOBBER IT IN + POP TP,-2(B) + HLRE C,TYPVEC+1 ; GET CODE + MOVNS C + ASH C,-1 + SUBI C,1 + MOVE D,-1(B) ; B HAS POINTER TO TYPE VECTOR DOPE WORDS + MOVEI 0,(D) + CAIG 0,HIBOT ; IS ATOM PURE? + JRST ADDNOI ; NO, SO NO HACKING REQUIRED + PUSH P,C + MOVE B,D + PUSHJ P,IMPURIF ; DO IMPURE OF ATOM + MOVE C,TYPVEC+1 + HLRE B,C + SUBM C,B ; RESTORE B + POP P,C + MOVE D,-1(B) ; RESTORE D +ADDNOI: HLRE A,D + SUBM D,A + TLO C,400000 + HRRM C,(A) ; INTO "GROWTH" FIELD + POPJ P, + + +; Interface to interpreter for setting up tables associated with +; template data structures. +; A/ <-name of type>- +; B/ <-length ins>- +; C/ <-uvector of garbage collector code or 0> +; D/ <-uvector of GETTERs>- +; E/ <-uvector of PUTTERs>- + +CTMPLT: SUBM M,(P) ; could possibly gc during this stuff + PUSH TP,$TATOM ; save name of type + PUSH TP,A + PUSH P,B ; save length instr + HLRE A,TD.LNT+1 ; check for template slots left? + HRRZ B,TD.LNT+1 + SUB B,A ; point to dope words + HLRZ B,1(B) ; get real length + ADDI A,-2(B) + JUMPG A,GOODRM ; jump if ok + + PUSH TP,$TUVEC ; save getters and putters + PUSH TP,C + PUSH TP,$TUVEC ; save getters and putters + PUSH TP,D + PUSH TP,$TUVEC + PUSH TP,E + MOVEI A,10-2(B) ; grow it 10 by copying remember d.w. length + PUSH P,A ; save new length + PUSHJ P,CAFRE1 ; get frozen uvector + ADD B,[10,,10] ; rest it down some + HRL C,TD.LNT+1 ; prepare to BLT in + MOVEM B,TD.LNT+1 ; and save as new length vector + HRRI C,(B) ; destination + ADD B,(P) ; final destination address + BLT C,-12(B) + MOVE A,(P) ; length for new getters + PUSHJ P,CAFRE1 + HRL C,TD.GET+1 ; get old for copy + MOVEM B,TD.GET+1 + PUSHJ P,DOBLTS ; go fixup new uvector + MOVE A,(P) ; finally putters + PUSHJ P,CAFRE1 + HRL C,TD.PUT+1 + MOVEM B,TD.PUT+1 + PUSHJ P,DOBLTS ; go fixup new uvector + MOVE A,(P) ; finally putters + PUSHJ P,CAFRE1 + HRL C,TD.AGC+1 + MOVEM B,TD.AGC+1 + PUSHJ P,DOBLTS ; go fixup new uvector + SUB P,[1,,1] ; flush stack craft + MOVE E,(TP) + MOVE D,-2(TP) + MOVE C,-4(TP) ;GET TD.AGC + SUB TP,[6,,6] + +GOODRM: MOVE B,TD.LNT+1 ; move down to fit new guy + SUB B,[1,,1] ; will always win due to prev checks + MOVEM B,TD.LNT+1 + HRLI B,1(B) + HLRE A,TD.LNT+1 + MOVNS A + ADDI A,-1(B) ; A/ final destination + BLT B,-1(A) + POP P,(A) ; new length ins munged in + HLRE A,TD.LNT+1 + MOVNS A ; A/ offset for other guys + PUSH P,A ; save it + ADD A,TD.GET+1 ; point for storing uvs of ins + MOVEM D,-1(A) + MOVE A,(P) + ADD A,TD.PUT+1 + MOVEM E,-1(A) ; store putter also + MOVE A,(P) + ADD A,TD.AGC+1 + MOVEM C,-1(A) ; store putter also + POP P,A ; compute primtype + ADDI A,NUMSAT + PUSH P,A + MOVE B,(TP) ; ready to mung type vector + SUB TP,[2,,2] + PUSHJ P,TYPFND ; CHECK TO SEE WHETHER TEMPLATE EXISTS + JRST NOTEM + POP P,C ; GET SAT + HRRM C,(A) + JRST MPOPJ +NOTEM: POP P,A ; RESTORE SAT + HRLI A,TATOM ; GET TYPE + PUSHJ P,INSNT ; INSERT INTO VECTOR + JRST MPOPJ + +; this routine copies GET and PUT vectors into new ones + +DOBLTS: HRRI C,(B) + ADD B,-1(P) + BLT C,-11(B) ; zap those guys in + MOVEI A,TUVEC ; mung in uniform type + PUTYP A,(B) + MOVEI C,-7(B) ; zero out remainder of uvector + HRLI C,-10(B) + SETZM -1(C) + BLT C,-1(B) + POPJ P, + + +; FUNCTIONS TO SET UP EVALUATION AND APPLICATION RULES FOR DATA TYPES + +MFUNCTION EVALTYPE,SUBR + + ENTRY + + PUSHJ P,CHKARG ; VERIFY WINNAGE IN ARGS + MOVEI A,EVATYP ; POINT TO TABLE + MOVEI E,EVTYPE ; POINT TO PURE VERSION + MOVEI 0,EVAL +TBLCAL: PUSHJ P,TBLSET ; SETUP TABLE ENTRY + JRST FINIS + +MFUNCTION APPLYTYPE,SUBR + + ENTRY + + PUSHJ P,CHKARG + MOVEI A,APLTYP ; POINT TO APPLY TABLE + MOVEI E,APTYPE ; PURE TABLE + MOVEI 0,APPLY + JRST TBLCAL + + +MFUNCTION PRINTTYPE,SUBR + + ENTRY + + PUSHJ P,CHKARG + MOVEI A,PRNTYP ; POINT TO APPLY TABLE + MOVEI E,PRTYPE ; PURE TABLE + MOVEI 0,PRINT + JRST TBLCAL + +; CHECK ARGS AND SETUP FOR TABLE HACKER + +CHKARG: JUMPGE AB,TFA + CAMGE AB,[-5,,] + JRST TMA + GETYP A,(AB) ; 1ST MUST BE TYPE NAME + CAIE A,TATOM + JRST WTYP1 + MOVE B,1(AB) ; GET ATOM + PUSHJ P,TYPLOO ; VERIFY THAT IT IS A TYPE + PUSH P,D ; SAVE TYPE NO. + MOVEI D,-1 ; INDICATE FUNNYNESS + CAML AB,[-3,,] ; SKIP IF 2 OR MORE + JRST TY1AR + HRRZ A,(A) ; GET SAT + ANDI A,SATMSK + PUSH P,A + GETYP A,2(AB) ; GET 2D TYPE + CAIE A,TATOM ; EITHER TYPE OR APPLICABLE + JRST TRYAPL ; TRY APPLICABLE + MOVE B,3(AB) ; VERIFY IT IS A TYPE + PUSHJ P,TYPLOO + HRRZ A,(A) ; GET SAT + ANDI A,SATMSK + POP P,C ; RESTORE SAVED SAT + CAIE A,(C) ; SKIP IF A WINNER + JRST TYPDIF ; REPORT ERROR +TY1AR: POP P,C ; GET SAVED TYPE + MOVEI B,0 ; TELL THAT WE ARE A TYPE + POPJ P, + +TRYAPL: PUSHJ P,APLQ ; IS THIS APPLICABLE + JRST NAPT + SUB P,[1,,1] + MOVE B,2(AB) ; RETURN SAME + MOVE D,3(AB) + POP P,C + POPJ P, + + +; HERE TO PUT ENTRY IN APPROPRIATE TABLE + +TBLSET: PUSH TP,B + PUSH TP,D ; SAVE VALUE + PUSH TP,$TFIX + PUSH TP,A + PUSH P,C ; SAVE TYPE BEING HACKED + PUSH P,E + SKIPE B,1(A) ; SKIP IF VECTOR DOESN'T EXIST YET + JRST TBL.OK + MOVE B,-2(TP) ; CHECK FOR RETURN IT HACK + SKIPN -3(TP) + CAIE B,-1 + JRST .+2 + JRST RETPM2 + HLRE A,TYPBOT+1 ; GET CURRENT TABLE LNTH + MOVNS A + ASH A,-1 + PUSH P,0 + PUSHJ P,IVECT ; GET VECTOR + POP P,0 + MOVE C,(TP) ; POINT TO RETURN POINT + MOVEM B,1(C) ; SAVE VECTOR + +TBL.OK: POP P,E + POP P,C ; RESTORE TYPE + SUB TP,[2,,2] + POP TP,D + POP TP,A + JUMPN A,TBLOK1 ; JUMP IF FUNCTION ETC. SUPPLIED + CAIN D,-1 + JRST TBLOK1 + CAILE D,NUMPRI ; SKIP IF ORIGINAL TYPE + MOVNI E,(D) ; CAUSE E TO ENDUP 0 + ADDI E,(D) ; POINT TO PURE SLOT +TBLOK1: ADDI C,(C) ; POINT TO VECTOR SLOT + ADDI C,(B) + CAIN D,-1 + JRST RETCUR + JUMPN A,OK.SET ; OK TO CLOBBER + ADDI B,(D) ; POINT TO TARGET TYPE'S SLOT + ADDI B,(D) ; POINT TO TARGET TYPE'S SLOT + SKIPN A,(B) ; SKIP IF WINNER + SKIPE 1(B) ; SKIP IF LOSER + SKIPA D,1(B) ; SETUP D + JRST CH.PTB ; CHECK PURE TABLE + +OK.SET: CAIN 0,(D) ; SKIP ON RESET + SETZB A,D + MOVEM A,(C) ; STORE + MOVEM D,1(C) +RETAR1: MOVE A,(AB) ; RET TYPE + MOVE B,1(AB) + JRST FINIS + +CH.PTB: MOVEI A,0 + MOVE D,[SETZ NAPT] + JUMPE E,OK.SET + MOVE D,(E) + JRST OK.SET + +RETPM2: SUB TP,[4,,4] + SUB P,[2,,2] + ASH C,1 + SOJA E,RETPM4 + +RETCUR: SKIPN A,(C) + SKIPE 1(C) + SKIPA B,1(C) + JRST RETPRM + + JUMPN A,CPOPJ +RETPM1: MOVEI A,0 + JUMPL B,RTFALS + CAMN B,1(E) + JRST .+3 + ADDI A,2 + AOJA E,.-3 + +RETPM3: ADD A,TYPVEC+1 + MOVE B,3(A) + MOVE A,2(A) + POPJ P, + +RETPRM: SUBI C,(B) ; UNDO BADNESS +RETPM4: CAIG C,NUMPRI*2 + SKIPG 1(E) + JRST RTFALS + + MOVEI A,-2(C) + JRST RETPM3 + +CALLTY: MOVE A,TYPVEC + MOVE B,TYPVEC+1 + POPJ P, + +MFUNCTION ALLTYPES,SUBR + + ENTRY 0 + + MOVE A,TYPVEC + MOVE B,TYPVEC+1 + JRST FINIS + +; + +;FUNCTION TO RETURN TYPE OF ELEMENTS IN A UVECTOR + +MFUNCTION UTYPE,SUBR + + ENTRY 1 + + GETYP A,(AB) ;GET U VECTOR + PUSHJ P,SAT + CAIE A,SNWORD + JRST WTYP1 + MOVE B,1(AB) ; GET UVECTOR + PUSHJ P,CUTYPE + JRST FINIS + +CUTYPE: HLRE A,B ;GET -LENGTH + HRRZS B + SUB B,A ;POINT TO TYPE WORD + GETYP A,(B) + JRST ITYPE ; GET NAME OF TYPE + +; FUNCTION TO CHANGE UNIFORM TYPE OF A VECTOR + +MFUNCTION CHUTYPE,SUBR + + ENTRY 2 + + GETYP A,2(AB) ;GET 2D TYPE + CAIE A,TATOM + JRST NOTATO + GETYP A,(AB) ; CALL WITH UVECTOR? + PUSHJ P,SAT + CAIE A,SNWORD + JRST WTYP1 + MOVE A,1(AB) ; GET UV POINTER + MOVE B,3(AB) ;GET ATOM + PUSHJ P,CCHUTY + MOVE A,(AB) ; RETURN UVECTOR + MOVE B,1(AB) + JRST FINIS + +CCHUTY: PUSH TP,$TUVEC + PUSH TP,A + PUSHJ P,TYPLOO ;LOOK IT UP + HRRZ B,(A) ;GET SAT + TRNE B,CHBIT + JRST CANTCH + ANDI B,SATMSK + SKIPGE MKTBS(B) + JRST CANTCH + HLRE C,(TP) ;-LENGTH + HRRZ E,(TP) + SUB E,C ;POINT TO TYPE + GETYP A,(E) ;GET TYPE + JUMPE A,WIN0 ;ALLOW TYPE "LOSE" TO CHANGE TO ANYTHING + PUSHJ P,SAT ;GET SAT + JUMPE A,TYPERR + CAIE A,(B) ;COMPARE + JRST TYPDIF +WIN0: ADDI D,.VECT. + HRLM D,(E) ;CLOBBER NEW ONE + POP TP,B + POP TP,A + POPJ P, + +CANTCH: PUSH TP,$TATOM + PUSH TP,EQUOTE CANT-CHTYPE-INTO + PUSH TP,2(AB) + PUSH TP,3(AB) + MOVEI A,2 + JRST CALER + +NOTATOM: + PUSH TP,$TATOM + PUSH TP,EQUOTE NON-ATOMIC-ARGUMENT + PUSH TP,(AB) + PUSH TP,1(AB) + MOVEI A,2 + JRST CALER + + + +; SUBROUTINE TO LEAVE MUDDLE CLOSING ALL CHANNELS ON THE WAY + +MFUNCTION QUIT,SUBR + + ENTRY 0 + + + PUSHJ P,CLOSAL ; DO THE CLOSES + PUSHJ P,%KILLM + JRST IFALSE ; JUST IN CASE + +CLOSAL: MOVEI B,CHNL0+2 ; POINT TO 1ST (NOT INCLUDING TTY I/O) + MOVE PVP,PVSTOR+1 + MOVE TVP,REALTV+1(PVP) + SUBI B,(TVP) + HRLS B + ADD B,TVP + PUSH TP,$TVEC + PUSH TP,B + PUSH P,[N.CHNS-1] ; MAX NO. OF CHANS + +CLOSA1: MOVE B,(TP) + ADD B,[2,,2] + MOVEM B,(TP) + HLLZS -2(B) + SKIPN C,-1(B) ; THIS ONE OPEN? + JRST CLOSA4 ; NO + CAME C,TTICHN+1 + CAMN C,TTOCHN+1 + JRST CLOSA4 + PUSH TP,-2(B) ; PUSH IT + PUSH TP,-1(B) + MCALL 1,FCLOSE ; CLOSE IT +CLOSA4: SOSLE (P) ; COUNT DOWN + JRST CLOSA1 + + + SUB TP,[2,,2] + SUB P,[1,,1] + +CLOSA3: SKIPN B,CHNL0+1 + POPJ P, + PUSH TP,(B) + HLLZS (TP) + PUSH TP,1(B) + HRRZ B,(B) + MOVEM B,CHNL0+1 + MCALL 1,FCLOSE + JRST CLOSA3 + + +IMPURE + +WHOAMI: 0 ; SYAYS WHETHER I AM REALLY A MUDDLE OR SOME HACK + + +;GARBAGE COLLECTORS PDLS + + +GCPDL: -GCPLNT,,GCPDL + + BLOCK GCPLNT + + +PURE + +MUDSTR: ASCII /MUDDLE / +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 + \ No newline at end of file diff --git a//main.mid.351 b//main.mid.351 new file mode 100644 index 0000000..6b7ae6e --- /dev/null +++ b//main.mid.351 @@ -0,0 +1,2058 @@ +TITLE MAIN LOOP AND GLOBALLY REFERENCED SUBROUTINES + +RELOCA + +.GLOBAL TBINIT,PIDSTO,PROCID,PTIME,GCPDL,PBASE,TYPTOP,RERR,FRMSTK,EMERGE +.GLOBAL PDLBUF,INTINT,START,SWAP,ICR,SPBASE,TPBASE,TPBAS,CURPRI,CHFINI,MKTBS +.GLOBAL TOPLEVEL,INTOBL,INITIA,ERROBL,MAINPR,RESFUN,STATUS,TYPVEC,ROOT,TTICHN,TTOCHN +.GLOBAL TTYOPE,MOPEN,MCLOSE,MIOT,ILVAL,MESS,ERROR,CHFRM,IGVAL,TYPBOT,ASOVEC +.GLOBAL PRINT,PRIN1,PRINC,MUDSTR,VECBOT,CSTACK,IFALSE,TYPLOO,RCALL,SWAPIN,CTMPLT +.GLOBAL IDPROC,CHFSWP,ILOC,MAKACT,BNDV,SPECSTORE,BINDID,IGLOC,MTYO,MSGTYP,CAFRE1,CPOPJ +.GLOBAL EVATYP,EVTYPE,APLTYP,APTYPE,PRNTYP,PRTYPE,AGC,SGSNAM,NAPT,APLQ,STRTO6 +.GLOBAL 6TOCHS,TYPFND,STBL,CHNL0,N.CHNS,CLOSAL,%LOGOUT,%SSNAM,%RSNAM,%KILLM,SAT +.GLOBAL MAKINF,%VALRET,COMPERR,IPUT,IGET,TMATCH,INITIZ,IPCINI,%UNAM,%JNAM,%RUNAM,%RJNAM,%RXUNA,%RXJNA,%VALFI +.GLOBAL NOTTY,DEMFLG,CFRAME,CARGS,CFUNCT,CITYPE,CTYPEQ,CPTYPE,CTYPEP,CUTYPE, +.GLOBAL CCHUTY,RTFALS,PGINT,PURCLN,CTYPEC,CTYPEW,IDVAL1,CALLTY,MESSAG,INITFL,WHOAMI +.GLOBAL %SLEEP,%HANG,%TOPLQ,ONINT,CHUNW,CURFCN,BUFRIN,TD.LNT,TD.GET,TD.AGC,TD.PUT,MPOPJ +.GLOBAL PURVEC,PLOAD,SSPECS,OUTRNG,CVTYPE,FSTART,CKVRS,CPRTYC,PVSTOR,SPSTOR +.GLOBAL TYPIC,CISET,LSTUF,IMPURI,REALTV +.INSRT MUDDLE > + +;MAIN LOOP AND STARTUP + +START: MOVEI 0,0 ; SET NO HACKS + JUMPE 0,START1 + TLNE 0,-1 ; SEE IF CHANNEL + JRST START1 + MOVE P,GCPDL + MOVE A,0 + PUSH P,A + PUSHJ P,CKVRS ; CHECK VERSION NUMBERS + POP P,A + JRST FSTART ; GO RESTORE +START1: MOVEM 0,WHOAMI ; HACK FOR TS FOO linked to TS MUDDLE + MOVE PVP,MAINPR ; MAKE SURE WE START IN THE MAIN PROCESS + JUMPE 0,INITIZ ; MIGHT BE RESTART + MOVE P,PSTO+1(PVP) ; SET UP FOR BOOTSTRAP HACK + MOVE TP,TPSTO+1(PVP) +INITIZ: MOVE PVP,MAINPR + SKIPN P ; IF NO CURRENT P + MOVE P,PSTO+1(PVP) ; PDL TO GET OFF THE GROUND + SKIPN TP ; SAME FOR TP + MOVE TP,TPSTO+1(PVP) ; GET A TP TO WORK WITH + SETZB R,M ; RESET RSUBR AC'S + PUSHJ P,%RUNAM + JFCL + PUSHJ P,%RJNAM + PUSHJ P,TTYOPE ;OPEN THE TTY + MOVEI B,MUDSTR + SKIPE WHOAMI ; SKIP IF THIS IS MUDDLE + JRST NODEMT ; ELSE NO MESSAGE + SKIPE DEMFLG ; SKIP IF NOT DEMON + JRST NODEMT + SKIPN NOTTY ; IF NO TTY, IGNORE + PUSHJ P,MSGTYP ;TYPE OUT TO USER + +NODEMT: XCT MESSAG ;MAYBE PRINT A MESSAGE + PUSHJ P,INTINT ;INITIALIZE INTERRUPT HANDLER + XCT IPCINI + PUSHJ P,PURCLN ; CLEAN UP PURE SHARED AREA +RESTART: ;RESTART A PROCESS +STP: MOVEI C,0 + MOVE PVP,PVSTOR+1 + MOVE B,TBINIT+1(PVP) ;POINT INTO STACK AT START + PUSHJ P,CHUNW ; LEAVE WHILE DOING UNWIND CHECK + MOVEI E,TOPLEV + MOVEI A,TFALSE ; IN CASE FALLS OFF PROCESS + MOVEI B,0 + HRRM E,-1(TB) + JRST CONTIN + + IMQUOTE TOPLEVEL +TOPLEVEL: + MCALL 0,LISTEN + JRST TOPLEVEL + + +IMFUNCTION LISTEN,SUBR + + ENTRY + PUSH P,[0] ;FLAG: DON'T PRINT ERROR MSG + JRST ER1 + +; USER SUPPLIED ERROR HANDLER, TEMPORARY KLUDGE + IMQUOTE ERROR + +ERROR: MOVE B,IMQUOTE ERROR + PUSHJ P,IGVAL ; GET VALUE + GETYP C,A + CAIN C,TSUBR ; CHECK FOR NO CHANGE + CAIE B,RERR1 ; SKIP IF NOT CHANGED + JRST .+2 + JRST RERR1 ; GO TO THE DEFAULT + PUSH TP,A ; SAVE VALUE + PUSH TP,B + MOVE C,AB ; SAVE AB + MOVEI D,1 ; AND COUNTER +USER1: PUSH TP,(C) ; PUSH THEM + PUSH TP,1(C) + ADD C,[2,,2] ; BUMP + ADDI D,1 + JUMPL C,USER1 + ACALL D,APPLY ; EVAL USERS ERROR + JRST FINIS + + + +IMFUNCTION ERROR%,SUBR,ERROR + +RERR1: ENTRY + PUSH TP,$TATOM + PUSH TP,MQUOTE ERROR,ERROR,INTRUP + PUSHJ P,FRMSTK ; PUT ERROR'S FRAME ON STACK + MOVEI D,2 + MOVE C,AB +RERR2: JUMPGE C,RERR22 + PUSH TP,(C) + PUSH TP,1(C) + ADD C,[2,,2] + AOJA D,RERR2 +RERR22: ACALL D,EMERGENCY + JRST RERR + +IMQUOTE ERROR +RERR: ENTRY + PUSH P,[-1] ;PRINT ERROR FLAG + +ER1: MOVE B,IMQUOTE INCHAN + PUSHJ P,ILVAL ; CHECK INPUT CHANNEL IS SOME KIND OF TTY + GETYP A,A + CAIE A,TCHAN ; SKIP IF IT IS A CHANNEL + JRST ER2 ; NO, MUST REBIND + CAMN B,TTICHN+1 + JRST NOTINC +ER2: MOVE B,IMQUOTE INCHAN + MOVEI C,TTICHN ; POINT TO VALU + PUSHJ P,PUSH6 ; PUSH THE BINDING + MOVE B,TTICHN+1 ; GET IN CHAN +NOTINC: SKIPN DEMFLG ; SKIP IF DEMON + SKIPE NOTTY + JRST NOECHO + PUSH TP,$TCHAN + PUSH TP,B + PUSH TP,$TATOM + PUSH TP,IMQUOTE T + MCALL 2,TTYECH ; ECHO INPUT +NOECHO: MOVE B,IMQUOTE OUTCHAN + PUSHJ P,ILVAL ; GET THE VALUE + GETYP A,A + CAIE A,TCHAN ; SKIP IF OK CHANNEL + JRST ER3 ; NOT CHANNEL, MUST REBIND + CAMN B,TTOCHN+1 + JRST NOTOUT +ER3: MOVE B,IMQUOTE OUTCHAN + MOVEI C,TTOCHN + PUSHJ P,PUSH6 ; PUSH THE BINDINGS +NOTOUT: MOVE B,IMQUOTE OBLIST + PUSHJ P,ILVAL ; GET THE VALUE OF OBLIST + PUSHJ P,OBCHK ; IS IT A WINNER ? + SKIPA A,$TATOM ; NO, SKIP AND CONTINUE + JRST NOTOBL ; YES, DO NOT DO REBINDING + MOVE B,IMQUOTE OBLIST + PUSHJ P,IGLOC + GETYP 0,A + CAIN 0,TUNBOU + JRST MAKOB ; NO GLOBAL OBLIST, MAKE ONE + MOVEI C,(B) ; COPY ADDRESS + MOVE A,(C) ; GET THE GVAL + MOVE B,(C)+1 + PUSHJ P,OBCHK ; IS IT A WINNER ? + JRST MAKOB ; NO, GO MAKE A NEW ONE + MOVE B,IMQUOTE OBLIST + PUSHJ P,PUSH6 + +NOTOBL: PUSH TP,[TATOM,,-1] ;FOR BINDING + PUSH TP,IMQUOTE LER,[LERR ]INTRUP + PUSHJ P,MAKACT + HRLI A,TFRAME ; CORRCT TYPE + PUSH TP,A + PUSH TP,B + PUSH TP,[0] + PUSH TP,[0] + MOVE A,PVSTOR+1 ; GET PROCESS + ADD A,[PROCID,,PROCID] ; POINT TO ID (ALSO LEVEL) + PUSH TP,BNDV + PUSH TP,A + MOVE A,PROCID(PVP) + ADDI A,1 ; BUMP ERROR LEVEL + PUSH TP,A + PUSH TP,PROCID+1(PVP) + PUSH P,A + + MOVE B,IMQUOTE READ-TABLE + PUSHJ P,IGVAL + PUSH TP,[TATOM,,-1] + PUSH TP,IMQUOTE READ-TABLE + GETYP C,A ; TO GVAL OF READ-TABLE ON ERROR AND + CAIE C,TVEC ; TOP ERRET'S + JRST .+4 + PUSH TP,A + PUSH TP,B + JRST .+3 + PUSH TP,$TUNBOUND + PUSH TP,[-1] + PUSH TP,[0] + PUSH TP,[0] + + PUSHJ P,SPECBIND ;BIND THE CRETANS + MOVE A,-1(P) ;RESTORE SWITHC + JUMPE A,NOERR ;IF 0, DONT PRINT ERROR MESS + PUSH TP,$TATOM + PUSH TP,EQUOTE *ERROR* + MCALL 0,TERPRI + MCALL 1,PRINC ;PRINT THE MESSAGE +NOERR: MOVE C,AB ;GET A COPY OF AB + +ERRLP: JUMPGE C,LEVPRT ;IF NONE, RE-ENTER READ-EVAL-PRINT LOOP + PUSH TP,$TAB + PUSH TP,C + MOVEI B,PRIN1 + GETYP A,(C) ; GET ARGS TYPE + CAIE A,TATOM + JRST ERROK + MOVE A,1(C) ; GET ATOM + HRRO A,2(A) + CAME A,[-1,,ERROBL+1] + CAMN A,ERROBL+1 ; DONT SKIP IF IN ERROR OBLIST + MOVEI B,PRINC ; DONT PRINT TRAILER +ERROK: PUSH P,B ; SAVE ROUTINE POINTER + PUSH TP,(C) + PUSH TP,1(C) + MCALL 0,TERPRI ; CRLF + POP P,B ; GET ROUTINE BACK + .MCALL 1,(B) + POP TP,C + SUB TP,[1,,1] + ADD C,[2,,2] ;BUMP SAVED AB + JRST ERRLP ;AND CONTINUE + + +LEVPRT: XCT INITFL ;LOAD MUDDLE INIT FILE IF FIRST TIME + MCALL 0,TERPRI + PUSH TP,$TATOM + PUSH TP,EQUOTE [LISTENING-AT-LEVEL ] + MCALL 1,PRINC ;PRINT LEVEL + PUSH TP,$TFIX ;READY TO PRINT LEVEL + HRRZ A,(P) ;GET LEVEL + SUB P,[2,,2] ;AND POP STACK + PUSH TP,A + MCALL 1,PRIN1 ;PRINT WITHOUT SPACES ETC. + PUSH TP,$TATOM ;NOW PROCESS + PUSH TP,EQUOTE [ PROCESS ] + MCALL 1,PRINC ;DONT SLASHIFY SPACES + MOVE PVP,PVSTOR+1 + PUSH TP,PROCID(PVP) ;NOW ID + PUSH TP,PROCID+1(PVP) + MCALL 1,PRIN1 + SKIPN C,CURPRI + JRST MAINLP + PUSH TP,$TFIX + PUSH TP,C + PUSH TP,$TATOM + PUSH TP,EQUOTE [ INT-LEVEL ] + MCALL 1,PRINC + MCALL 1,PRIN1 + JRST MAINLP ; FALL INTO MAIN LOOP + + ;ROUTINES FOR ERROR-LISTEN + +OBCHK: GETYP 0,A + CAIN 0,TOBLS + JRST CPOPJ1 ; WIN FOR SINGLE OBLIST + CAIE 0,TLIST ; IF LIST, MAKE SURE EACH IS AN OBLIST + JRST CPOPJ ; ELSE, LOSE + + JUMPE B,CPOPJ ; NIL ,LOSE + PUSH TP,A + PUSH TP,B + PUSH P,[0] ;FLAG FOR DEFAULT CHECKING + MOVEI 0,1000 ; VERY BIG NUMBER FOR CIRCULARITY TEST + +OBCHK0: INTGO + SOJE 0,OBLOSE ; CIRCULARITY TEST + HRRZ B,(TP) ; GET LIST POINTER + GETYP A,(B) + CAIE A,TOBLS ; SKIP IF WINNER + JRST DEFCHK ; CHECK FOR SPECIAL ATOM DEFAULT + HRRZ B,(B) + MOVEM B,(TP) + JUMPN B,OBCHK0 +OBWIN: AOS (P)-1 +OBLOSE: SUB TP,[2,,2] + SUB P,[1,,1] + POPJ P, + +DEFCHK: SKIPN (P) ; BEEN HERE BEFORE ? + CAIE A,TATOM ; OR, NOT AN ATOM ? + JRST OBLOSE ; YES, LOSE + MOVE A,(B)+1 + CAME A,MQUOTE DEFAULT + JRST OBLOSE ; LOSE + SETOM (P) ; SET FLAG + HRRZ B,(B) ; CHECK FOR END OF LIST + MOVEM B,(TP) + JUMPN B,OBCHK0 ; NOT THE END, CONTINUE LOOKING + JRST OBLOSE ; LOSE FOR DEFAULT AT THE END + + + +PUSH6: PUSH TP,[TATOM,,-1] + PUSH TP,B + PUSH TP,(C) + PUSH TP,1(C) + PUSH TP,[0] + PUSH TP,[0] + POPJ P, + + +MAKOB: PUSH TP,INITIAL + PUSH TP,INITIAL+1 + PUSH TP,ROOT + PUSH TP,ROOT+1 + MCALL 2,LIST + PUSH TP,$TATOM + PUSH TP,IMQUOTE OBLIST + PUSH TP,A + PUSH TP,B + MCALL 2,SETG + PUSH TP,[TATOM,,-1] + PUSH TP,IMQUOTE OBLIST + PUSH TP,A + PUSH TP,B + PUSH TP,[0] + PUSH TP,[0] + JRST NOTOBL + + +;THIS IS IT FOLKS...THE MAIN LOOP. READ, EVAL, PRINT + +MAINLP: MOVE A,$TATOM ;KLUDGE BY NDR LIKE ERROR TO LET LOOSER REDEFINE + MOVE B,IMQUOTE REP + PUSHJ P,ILVAL ;GET ITS LVAL TO SEE IF REDEFINED + GETYP C,A + CAIE C,TUNBOUND + JRST REPCHK + MOVE A,$TATOM ;SEE IF IT HAS GVAL SINCE NO LVAL + MOVE B,IMQUOTE REP + PUSHJ P,IGVAL + GETYP C,A + CAIN C,TUNBOUN + JRST IREPER +REPCHK: CAIN C,TSUBR + CAIE B,REPER + JRST .+2 + JRST IREPER +REREPE: PUSH TP,A + PUSH TP,B + GETYP A,-1(TP) + PUSHJ P,APLQ + JRST ERRREP + MCALL 1,APPLY ;LOOSER HAS REDEFINED SO CALL HIS + JRST MAINLP +IREPER: PUSH P,[0] ;INDICATE FALL THROUGH + JRST REPERF + +ERRREP: PUSH TP,[TATOM,,-1] + PUSH TP,IMQUOTE REP + PUSH TP,$TSUBR + PUSH TP,[REPER] + PUSH TP,[0] + PUSH TP,[0] + PUSHJ P,SPECBIN + PUSH TP,$TATOM + PUSH TP,EQUOTE NON-APPLICABLE-REP + PUSH TP,-11(TP) + PUSH TP,-11(TP) + MCALL 2,ERROR + SUB TP,[6,,6] + PUSHJ P,SSPECS + JRST REREPE + + +IMFUNCTION REPER,SUBR,REP +REPER: ENTRY 0 + PUSH P,[1] ;INDICATE DIRECT CALL +REPERF: MCALL 0,TERPRI + MCALL 0,READ + PUSH TP,A + PUSH TP,B + MOVE B,IMQUOTE L-INS + PUSHJ P,ILVAL ; ASSIGNED? + GETYP 0,A + CAIN 0,TLIST + + PUSHJ P,LSTTOF ; PUT LAST AS FIRST + MCALL 0,TERPRI + MCALL 1,EVAL + MOVE C,IMQUOTE LAST-OUT + PUSHJ P,CISET + PUSH TP,A + PUSH TP,B + MOVE B,IMQUOTE L-OUTS + PUSHJ P,ILVAL ; ASSIGNED? + GETYP 0,A + CAIN 0,TLIST + + CAME B,(TP) ; DONT STUFF IT INTO ITSELF + JRST STUFIT ; STUFF IT IN + GETYP 0,-1(TP) + CAIE 0,TLIST ; IF A LIST THE L-OUTS +STUFIT: PUSHJ P,LSTTOF ; PUT LAST AS FIRST + MCALL 1,PRIN1 + POP P,C ;FLAG FOR FALL THROUGH OR CALL + JUMPN C,FINIS ;IN CASE LOOSER CALLED REP + JRST MAINLP + +LSTTOF: SKIPN A,B + POPJ P, + + HRRZ C,(A) + JUMPE C,LSTTO2 + MOVEI D,(C) ; SAVE PTR TO 2ND ELEMENT + MOVEI 0,-1 ; LET THE LOSER LOSE (HA HA HA) + +LSTTO1: HRRZ C,(C) ; START SCAN + JUMPE C,GOTIT + HRRZ A,(A) + SOJG 0,LSTTO1 + +GOTIT: HRRZ C,(A) + HLLZS (A) + CAIE D,(C) ; AVOID CIRCULARITY + HRRM D,(C) + HRRM C,(B) + MOVE D,1(B) + MOVEM D,1(C) + GETYP D,(B) + PUTYP D,(C) + +LSTTO2: MOVSI A,TLIST + MOVE C,-1(TP) + MOVE D,(TP) + JRST LSTUF + +;FUNCTION TO RETRY A PREVIOUS FUNCTION CALL + +MFUNCTION RETRY,SUBR + + ENTRY + JUMPGE AB,RETRY1 ; USE MOST RECENT + CAMGE AB,[-2,,0] + JRST TMA + GETYP A,(AB) ; CHECK TYPE + CAIE A,TFRAME + JRST WTYP1 + MOVEI B,(AB) ; POINT TO ARG + JRST RETRY2 +RETRY1: MOVE B,IMQUOTE LER,[LERR ]INTRUP + PUSHJ P,ILOC ; LOCATIVE TO FRAME +RETRY2: PUSHJ P,CHFSWP ; CHECK VALIDITY AND SWAP IF NECESSARY + HRRZ 0,OTBSAV(B) ; CHECK FOR TOP + JUMPE 0,RESTAR ; YES RE-ENTER TOP LEVEL + PUSH TP,$TTB + PUSH TP,B ; SAVE FRAME + MOVE B,OTBSAV(B) ; GET PRVIOUS FOR UNBIND HACK + MOVEI C,-1(TP) + PUSHJ P,CHUNW ; CHECK ANY UNWINDING + CAME SP,SPSAV(TB) ; UNBINDING NEEDED? + PUSHJ P,SPECSTORE + MOVE P,PSAV(TB) ; GET OTHER STUFF + MOVE AB,ABSAV(B) + HLRE A,AB ; COMPUTE # OF ARGS + MOVNI A,-FRAMLN(A) ; MAKE TP POINT PAST FRAME + HRLI A,(A) + MOVE C,TPSAV(TB) ; COMPUTE TP + ADD C,A + MOVE TP,C + MOVE TB,B ; FIX UP TB + HRRZ C,FSAV(TB) ; GET FUNCTION + CAIL C,HIBOT + JRST (C) ; GO + GETYP 0,(C) ; RSUBR OR ENTRY? + CAIE 0,TATOM + CAIN 0,TRSUBR + JRST RETRNT + MOVS R,(C) ; SET UP R + HRRI R,(C) + MOVEI C,0 + JRST RETRN3 + +RETRNT: CAIE 0,TRSUBR + JRST RETRN1 + MOVE R,1(C) +RETRN4: HRRZ C,2(C) ; OFFSET +RETRN3: SKIPL M,1(R) + JRST RETRN5 +RETRN7: ADDI C,(M) + JRST (C) + +RETRN5: MOVEI D,(M) ; TOTAL OFFSET + MOVSS M + ADD M,PURVEC+1 + SKIPL M,1(M) + JRST RETRN6 + ADDI M,(D) + JRST RETRN7 + +RETRN6: HLRZ A,1(R) + PUSH P,D + PUSH P,C + PUSHJ P,PLOAD + JRST RETRER ; LOSER + POP P,C + POP P,D + MOVE M,B + JRST RETRN7 + +RETRN1: HRL C,(C) ; FIX LH + MOVE B,1(C) + PUSH TP,$TVEC + PUSH TP,C + PUSHJ P,IGVAL + GETYP 0,A + MOVE C,(TP) + SUB TP,[2,,2] + CAIE 0,TRSUBR + JRST RETRN2 + MOVE R,B + JRST RETRN4 + +RETRN2: ERRUUO EQUOTE CANT-RETRY-ENTRY-GONE + +RETRER: ERRUUO EQUOTE PURE-LOAD-FAILURE + + +;FUNCTION TO DO ERROR RETURN + +IMFUNCTION ERRET,SUBR + + ENTRY + HLRE A,AB ; -2*# OF ARGS + JUMPGE A,STP ; RESTART PROCESS + ASH A,-1 ; -# OF ARGS + AOJE A,ERRET2 ; NO FRAME SUPPLIED + AOJL A,TMA + ADD AB,[2,,2] + PUSHJ P,OKFRT + JRST WTYP2 + SUB AB,[2,,2] + PUSHJ P,CHPROC ; POINT TO FRAME SLOT + JRST ERRET3 +ERRET2: MOVE B,IMQUOTE LER,[LERR ]INTRUP + PUSHJ P,ILVAL ; GET ITS VALUE +ERRET3: PUSH TP,A + PUSH TP,B + MOVEI B,-1(TP) + PUSHJ P,CHFSWP ; CHECK VALIDITY AND SWAP IF NECESSARY + HRRZ 0,OTBSAV(B) ; TOP LEVEL? + JUMPE 0,TOPLOS + PUSHJ P,CHUNW ; ANY UNWINDING + JRST CHFINIS + + +; FUNCTION TO RETURN LAST ERROR FRAME OR PREVIOUS FRAME + +IMFUNCTION FRAME,SUBR + ENTRY + SETZB A,B + JUMPGE AB,FRM1 ; DEFAULT CASE + CAMG AB,[-3,,0] ; SKIP IF OK ARGS + JRST TMA + PUSHJ P,OKFRT ; A FRAME OR SIMILAR THING? + JRST WTYP1 + +FRM1: PUSHJ P,CFRAME ; GO TO INTERNAL + JRST FINIS + +CFRAME: JUMPN A,FRM2 ; ARG SUPPLIED? + MOVE B,IMQUOTE LER,[LERR ]INTRUP + PUSHJ P,ILVAL + JRST FRM3 +FRM2: PUSHJ P,CHPROC ; CHECK FOR PROCESS + PUSH TP,A + PUSH TP,B + MOVEI B,-1(TP) ; POINT TO SLOT + PUSHJ P,CHFRM ; CHECK IT + MOVE C,(TP) ; GET FRAME BACK + MOVE B,OTBSAV(C) ;GET PREVIOUS FRAME + SUB TP,[2,,2] + TRNN B,-1 ; SKIP IF OK + JRST TOPLOSE + +FRM3: JUMPN B,FRM4 ; JUMP IF WINNER + MOVE B,IMQUOTE THIS-PROCESS + PUSHJ P,ILVAL ; GET PROCESS OF INTEREST + GETYP A,A ; CHECK IT + CAIN A,TUNBOU + MOVE B,PVSTOR+1 ; USE CURRENT + MOVEI A,PVLNT*2+1(B) ; POINT TO DOPE WORDS + MOVE B,TBINIT+1(B) ; AND BASE FRAME +FRM4: HLL B,OTBSAV(B) ;TIME + HRLI A,TFRAME + POPJ P, + +OKFRT: AOS (P) ;ASSUME WINNAGE + GETYP 0,(AB) + MOVE A,(AB) + MOVE B,1(AB) + CAIE 0,TFRAME + CAIN 0,TENV + POPJ P, + CAIE 0,TPVP + CAIN 0,TACT + POPJ P, + SOS (P) + POPJ P, + +CHPROC: GETYP 0,A ; TYPE + CAIE 0,TPVP + POPJ P, ; OK + MOVEI A,PVLNT*2+1(B) + CAMN B,PVSTOR+1 ; THIS PROCESS? + JRST CHPRO1 + MOVE B,TBSTO+1(B) + JRST FRM4 + +CHPRO1: MOVE B,OTBSAV(TB) + JRST FRM4 + +; FUNCTION TO RETURN ARGS TUPLE FOR A FRAME + +MFUNCTION ARGS,SUBR + ENTRY 1 + PUSHJ P,OKFRT ; CHECK FRAME TYPE + JRST WTYP1 + PUSHJ P,CARGS + JRST FINIS + +CARGS: PUSHJ P,CHPROC + PUSH TP,A + PUSH TP,B + MOVEI B,-1(TP) ; POINT TO FRAME SLOT + PUSHJ P,CHFRM ; AND CHECK FOR VALIDITY + MOVE C,(TP) ; FRAME BACK + MOVSI A,TARGS +CARGS1: GETYP 0,FSAV(C) ; IS THIS A FUNNY ONE + CAIE 0,TCBLK ; SKIP IF FUNNY + JRST .+3 ; NO NORMAL + MOVE C,OTBSAV(C) ; ASSOCIATE WITH PREVIOUS FRAME + JRST CARGS1 + HLR A,OTBSAV(C) ; TIME IT AND + MOVE B,ABSAV(C) ; GET POINTER + SUB TP,[2,,2] ; FLUSH CRAP + POPJ P, + +; FUNCTION TO RETURN FUNCTION ASSOCIATED WITH A FRAME + +MFUNCTION FUNCT,SUBR + ENTRY 1 ; FRAME ARGUMENT + PUSHJ P,OKFRT ; CHECK TYPE + JRST WTYP1 + PUSHJ P,CFUNCT + JRST FINIS + +CFUNCT: PUSHJ P,CHPROC + PUSH TP,A + PUSH TP,B + MOVEI B,-1(TP) + PUSHJ P,CHFRM ; CHECK IT + MOVE C,(TP) ; RESTORE FRAME + HRRZ A,FSAV(C) ;FUNCTION POINTER + CAIL A,HIBOT + SKIPA B,@-1(A) ;NO, GET SUBR'S NAME POINTER + MOVE B,(A)+3 ;YES, GET RSUBR'S NAME ENTRY + MOVSI A,TATOM + SUB TP,[2,,2] + POPJ P, + +BADFRAME: + ERRUUO EQUOTE FRAME-NO-LONGER-EXISTS + + +TOPLOSE: + ERRUUO EQUOTE TOP-LEVEL-FRAME + + + + +; ROUTINE TO HANG INDEFINITELY WITH INTERRUPTS ENABLED + +MFUNCTION HANG,SUBR + + ENTRY + + JUMPGE AB,HANG1 ; NO PREDICATE + CAMGE AB,[-3,,] + JRST TMA + PUSH TP,(AB) + PUSH TP,1(AB) + PUSHJ P,CHKPRD +REHANG: MOVE A,[PUSHJ P,CHKPRH] + MOVEM A,ONINT ; CHECK PREDICATE AFTER ANY INTERRUPT +HANG1: ENABLE ;LET OURSELVES BE INTERRUPTED OUT + PUSHJ P,%HANG + DISABLE ;PREVENT INTERRUPTS AT RANDOM TIMES + SETZM ONINT + MOVE A,$TATOM + MOVE B,IMQUOTE T + JRST FINIS + + +; ROUTINE TO SLEEP FOR POSITIVE NUMBER OF SECONDS WITH INTERRUPTS ENABLED +; ARGUMENT SHOULD BE OF TYPE FIX OR FLOAT AND NON-NEGATIVE + +MFUNCTION SLEEP,SUBR + + ENTRY + + JUMPGE AB,TFA + CAML AB,[-3,,] + JRST SLEEP1 + CAMGE AB,[-5,,] + JRST TMA + PUSH TP,2(AB) + PUSH TP,3(AB) + PUSHJ P,CHKPRD +SLEEP1: GETYP 0,(AB) + CAIE 0,TFIX + JRST .+5 + MOVE B,1(AB) + JUMPL B,OUTRNG ;ARG SHOULDNT BE NEGATIVE + IMULI B,30. ;CONVERT TO # OF THIRTIETHS OF A SECOND + JRST SLEEPR ;GO SLEEP + CAIE 0,TFLOAT ;IF IT WASNT FIX MAKE SURE IT IS FLOAT + JRST WTYP1 ;WRONG TYPE ARG + MOVE B,1(AB) + FMPR B,[30.0] ;CONVERT TO FLOATING # OF THIRTIETHS OF A SECOND + MULI B,400 ;KLUDGE TO FIX IT + TSC B,B + ASH C,(B)-243 + MOVE B,C ;MOVE THE FIXED NUMBER INTO B + JUMPL B,OUTRNG ;CHECK TO SEE THAT WE HAVE POSITIVE NUMBER +SLEEPR: MOVE A,B +RESLEE: MOVE B,[PUSHJ P,CHKPRS] + CAMGE AB,[-3,,] + MOVEM B,ONINT + ENABLE + PUSHJ P,%SLEEP + DISABLE + SETZM ONINT + MOVE A,$TATOM + MOVE B,IMQUOTE T + JRST FINIS + +CHKPRH: PUSH P,B + MOVEI B,HANGP + JRST .+3 + +CHKPRS: PUSH P,B + MOVEI B,SLEEPP + HRRM B,LCKINT + SETZM ONINT ; TURN OFF FEATURE FOR NOW + POP P,B + POPJ P, + +HANGP: SKIPA B,[REHANG] +SLEEPP: MOVEI B,RESLEE + PUSH P,B +CHKPRD: PUSH P,A + DISABLE + PUSH TP,(TB) + PUSH TP,1(TB) + MCALL 1,EVAL + GETYP 0,A + CAIE 0,TFALSE + JRST FINIS + POP P,A + POPJ P, + +MFUNCTION VALRET,SUBR +; SUBR TO VALRET A STRING TO SUPERIOR ITS PROCESS + + ENTRY 1 + GETYP A,(AB) ; GET TYPE OF ARGUMENT + CAIN A,TFIX ; FIX? + JRST VALRT1 + CAIE A,TCHSTR ; IS IT A CHR STRING? + JRST WTYP1 ; NO...ERROR WRONG TYPE + PUSHJ P,CSTACK ; COPY THE CHR STRING TO THE STACK + ; CSTACK IS IN ATOMHK + MOVEI B,0 ; ASCIZ TERMINATOR + EXCH B,(P) ; STORE AND RETRIEVE COUNT + +; CALCULATE THE BEGINNING ADDR OF THE STRING + MOVEI A,-1(P) ; GET ADDR OF TOP OF STACK + SUBI A,-1(B) ; GET STARTING ADDR + PUSHJ P,%VALRE ; PASS UP TO MONITOR + JRST IFALSE ; IF HE RETURNS, RETURN FALSE + +VALRT1: MOVE A,1(AB) + PUSHJ P,%VALFI + JRST IFALSE + +MFUNCTION LOGOUT,SUBR + +; SUBR TO DO A .LOGOUT (VALID ONLY AT TOP LEVEL) + ENTRY 0 + PUSHJ P,%TOPLQ ; SKIP IF AT TOP LEVEL + JRST IFALSE + PUSHJ P,CLOSAL + PUSHJ P,%LOGOUT ; TRY TO FLUSH + JRST IFALSE ; COULDN'T DO IT...RETURN FALSE + +; FUNCTS TO GET UNAME AND JNAME + +; GET XUNAME (REAL UNAME) +MFUNCTION XUNAME,SUBR + + ENTRY 0 + + PUSHJ P,%RXUNA + JRST RSUJNM + JRST FINIS ; 10X ROUTINES SKIP + +MFUNCTION UNAME,SUBR + + ENTRY 0 + + PUSHJ P,%RUNAM + JRST RSUJNM + JRST FINIS + +; REAL JNAME +MFUNCTION XJNAME,SUBR + + ENTRY 0 + + PUSHJ P,%RXJNA + JRST RSUJNM + +MFUNCTION JNAME,SUBR + + ENTRY 0 + + PUSHJ P,%RJNAM + JRST RSUJNM + +; FUNCTION TO SET AND READ GLOBAL SNAME + +MFUNCTION SNAME,SUBR + + ENTRY + + JUMPGE AB,SNAME1 + CAMG AB,[-3,,] + JRST TMA + GETYP A,(AB) ; ARG MUST BE STRING + CAIE A,TCHSTR + JRST WTYP1 + PUSH TP,$TATOM + PUSH TP,IMQUOTE SNM + PUSH TP,(AB) + PUSH TP,1(AB) + MCALL 2,SETG + JRST FINIS + +SNAME1: MOVE B,IMQUOTE SNM + PUSHJ P,IDVAL1 + GETYP 0,A + CAIN 0,TCHSTR + JRST FINIS + MOVE A,$TCHSTR + MOVE B,CHQUOTE + JRST FINIS + +RSUJNM: PUSHJ P,6TOCHS ; CONVERT IT + JRST FINIS + + +SGSNAM: MOVE B,IMQUOTE SNM + PUSHJ P,IDVAL1 + GETYP 0,A + CAIE 0,TCHSTR + JRST SGSN1 + + PUSH TP,A + PUSH TP,B + PUSHJ P,STRTO6 + POP P,A + SUB TP,[2,,2] + JRST .+2 + +SGSN1: MOVEI A,0 + PUSHJ P,%SSNAM ; SET SNAME IN SYSTEM + POPJ P, + + + +;THIS SUBROUTINE ALLOCATES A NEW PROCESS +;TAKES TP-STACK SIZE (2*WORDS) IN A AND P-STACK SIZE (WORDS) IN B +;IS CALLED BY PUSHJ P,. RETURNS IN A AND B A NEW PROCESS. + +ICR: PUSH P,A + PUSH P,B + MOVEI A,PVLNT ;SETUP CALL TO VECTOR FOR PVP + PUSHJ P,IVECT ;GOBBLE A VECTOR + HRLI C,PVBASE ;SETUP A BLT POINTER + HRRI C,(B) ;GET INTO ADDRESS + BLT C,PVLNT*2-1(B) ;COPY A PROTOTYPE INTO NEW PVP + MOVSI C,400000+SPVP+.VECT. ;SET SPECIAL TYPE + MOVEM C,PVLNT*2(B) ;CLOBBER IT IN + PUSH TP,A ;SAVE THE RESULTS OF VECTOR + PUSH TP,B + + PUSH TP,$TFIX ;GET A UNIFORM VECTOR + POP P,B + PUSH TP,B + MCALL 1,UVECTOR + ADD B,[PDLBUF-2,,-1] ;FUDGE WITH BUFFER + MOVE C,(TP) ;REGOBBLE PROCESS POINTER + MOVEM B,PSTO+1(C) ;STORE IN ALL HOMES + MOVEM B,PBASE+1(C) + + + POP P,A ;PREPARE TO CREATE A TEMPORARY PDL + PUSHJ P,IVECT ;GET THE TEMP PDL + ADD B,[PDLBUF,,0] ;PDL GROWTH HACK + MOVE C,(TP) ;RE-GOBBLE NEW PVP + SUB B,[1,,1] ;FIX FOR STACK + MOVEM B,TPBASE+1(C) + +;SETUP INITIAL BINDING + + PUSH B,$TBIND + MOVEM B,SPBASE+1(C) ;SAVE AS BASE OF SP + MOVEM B,SPSTO+1(C) ;AND CURRENT THEREOF + MOVEM B,CURFCN+1(C) ; AND AS CURRENT FCN FOR SPEC/UNSPEC LOGIC + PUSH B,IMQUOTE THIS-PROCESS + PUSH B,$TPVP ;GIVE IT PROCESS AS VALUE + PUSH B,C + ADD B,[2,,2] ;FINISH FRAME + MOVEM B,TPSTO+1(C) ;MAKE THIS THE CURRENT STACK POINTER + MOVEM C,PVPSTO+1(C) ;SAVE THE NEW PVP ITSELF + AOS A,IDPROC ;GOBBLE A UNIQUE PROCESS I.D. + MOVEM A,PROCID+1(C) ;SAVE THAT ALSO + AOS A,PTIME ; GET A UNIQUE BINDING ID + MOVEM A,BINDID+1(C) + + MOVSI A,TPVP ;CLOBBER THE TYPE + MOVE B,(TP) ;AND POINTER TO PROCESS + SUB TP,[2,,2] + POPJ P, + +;MINI ROUTINE TO CALL VECTOR WITH COUNT IN A + +IVECT: PUSH TP,$TFIX + PUSH TP,A + MCALL 1,VECTOR ;GOBBLE THE VECTOR + POPJ P, + + +;SUBROUTINE TO SWAP A PROCESS IN +;CALLED WITH JSP A,SWAP AND NEW PVP IN B + +SWAP: ;FIRST STORE ALL THE ACS + + MOVE PVP,PVSTOR+1 + MOVE SP,$TSP ; STORE SPSAVE + MOVEM SP,SPSTO(PVP) + MOVE SP,SPSTOR+1 + IRP A,,[SP,AB,TB,TP,P,M,R,FRM] + MOVEM A,A!STO+1(PVP) + TERMIN + + SETOM 1(TP) ; FENCE POST MAIN STACK + MOVEM TP,TPSAV(TB) ; CORRECT FRAME + SETZM PSAV(TB) ; CLEAN UP CURRENT FRAME + SETZM SPSAV(TB) + SETZM PCSAV(TB) + + MOVE E,PVP ;RETURN OLD PROCESS IN E + MOVE PVP,D ;AND MAKE NEW ONE BE D + MOVEM PVP,PVSTOR+1 + +SWAPIN: + ;NOW RESTORE NEW PROCESSES AC'S + + MOVE PVP,PVSTOR+1 + IRP A,,[AB,TB,SP,TP,P,M,R,FRM] + MOVE A,A!STO+1(PVP) + TERMIN + + SETZM SPSTO(PVP) + MOVEM SP,SPSTOR+1 + JRST (C) ;AND RETURN + + + + +;SUBRS ASSOCIATED WITH TYPES + +;TYPE (ITYPE) ARE FUNCTIONS TO RETURN THE ATOMIC NAME OF THE +;TYPE OF A GOODIE. TYPE TAKES ITS ARGS ON AP AND RETURNS IN A AND B. +;ITYPE TAKES ITS ARGS IN A AND B AND RETURNS IN SAME (B=0) FOR INVALID +;TYPECODE. +MFUNCTION TYPE,SUBR + + ENTRY 1 + GETYP A,(AB) ;TYPE INTO A +TYPE1: PUSHJ P,ITYPE ;GO TO INTERNAL + JUMPN B,FINIS ;GOOD RETURN +TYPERR: ERRUUO EQUOTE TYPE-UNDEFINED + +CITYPE: GETYP A,A ; GET TYPE FOR COMPILER CALL +ITYPE: LSH A,1 ;TIMES 2 + HRLS A ;TO BOTH SIDES + ADD A,TYPVEC+1 ;GET ACTUAL LOCATION + JUMPGE A,TYPERR ;LOST, TYPE OUT OF BOUNDS + MOVE B,1(A) ;PICKUP TYPE + HLLZ A,(A) + POPJ P, + +; PREDICATE -- IS OBJECT OF TYPE SPECIFIED + +MFUNCTION %TYPEQ,SUBR,[TYPE?] + + ENTRY + + MOVE D,AB ; GET ARGS + ADD D,[2,,2] + JUMPGE D,TFA + MOVE A,(AB) + HLRE C,D + MOVMS C + ASH C,-1 ; FUDGE + PUSHJ P,ITYPQ ; GO INTERNAL + JFCL + JRST FINIS + +ITYPQ: GETYP A,A ; OBJECT + PUSHJ P,ITYPE +TYPEQ0: SOJL C,CIFALS + GETYP 0,(D) + CAIE 0,TATOM ; Type name must be an atom + JRST WRONGT + CAMN B,1(D) ; Same as the OBJECT? + JRST CPOPJ1 ; Yes, return type name + ADD D,[2,,2] + JRST TYPEQ0 ; No, continue comparing + +CIFALS: MOVEI B,0 + MOVSI A,TFALSE + POPJ P, + +CTYPEQ: SOJE A,CIFALS ; TREAT NO ARGS AS FALSE + MOVEI D,1(A) ; FIND BASE OF ARGS + ASH D,1 + HRLI D,(D) + SUBM TP,D ; D POINTS TO BASE + MOVE E,D ; SAVE FOR TP RESTORE + ADD D,[3,,3] ; FUDGE + MOVEI C,(A) ; NUMBER OF TYPES + MOVE A,-2(D) + PUSHJ P,ITYPQ + JFCL ; IGNORE SKIP FOR NOW + MOVE TP,E ; SET TP BACK + JUMPL B,CPOPJ1 ; SKIP + POPJ P, + +; Entries to get type codes for types for fixing up RSUBRs and assembling + +MFUNCTION %TYPEC,SUBR,[TYPE-C] + + ENTRY + + JUMPGE AB,TFA + GETYP 0,(AB) + CAIE 0,TATOM + JRST WTYP1 + MOVE B,1(AB) + CAMGE AB,[-3,,0] ; skip if only type name given + JRST GTPTYP + MOVE C,IMQUOTE ANY + +TYPEC1: PUSHJ P,CTYPEC ; go to internal + JRST FINIS + +GTPTYP: CAMGE AB,[-5,,0] + JRST TMA + GETYP 0,2(AB) + CAIE 0,TATOM + JRST WTYP2 + MOVE C,3(AB) + JRST TYPEC1 + +CTYPEC: PUSH P,C ; save primtype checker + PUSHJ P,TYPFND ; search type vector + JRST CTPEC2 ; create the poor loser + POP P,B + CAMN B,IMQUOTE ANY + JRST CTPEC1 + CAMN B,IMQUOTE TEMPLATE + JRST TCHK + PUSH P,D + HRRZ A,(A) + ANDI A,SATMSK + PUSH P,A + PUSHJ P,TYPLOO + HRRZ 0,(A) + ANDI 0,SATMSK + CAME 0,(P) + JRST TYPDIF + MOVE D,-1(P) + SUB P,[2,,2] +CTPEC1: MOVEI B,(D) + MOVSI A,TTYPEC + POPJ P, +TCHK: PUSH P,D ; SAVE TYPE + MOVE A,D ; GO TO SAT + PUSHJ P,SAT + CAIG A,NUMSAT ; SKIP IF A TEMPLATE + JRST TYPDIF + POP P,D ; RESTORE TYPE + JRST CTPEC1 + +CTPEC2: POP P,C ; GET BACK PRIMTYPE + SUBM M,(P) + PUSH TP,$TATOM + PUSH TP,B + CAMN C,IMQUOTE ANY + JRST CTPEC3 + PUSH TP,$TATOM + PUSH TP,C + MCALL 2,NEWTYPE ; CREATE THE POOR GUY + MOVE C,IMQUOTE ANY + SUBM M,(P) ; UNRELATIVIZE + JRST CTYPEC + +CTPEC3: HRRZ 0,FSAV(TB) + CAIE 0,%TYPEC + CAIN 0,%TYPEW + JRST TYPERR + + MCALL 1,%TYPEC + JRST MPOPJ + +MFUNCTION %TYPEW,SUBR,[TYPE-W] + + ENTRY + + JUMPGE AB,TFA + GETYP 0,(AB) + CAIE 0,TATOM + JRST WTYP1 + MOVEI D,0 + MOVE C,IMQUOTE ANY + MOVE B,1(AB) + CAMGE AB,[-3,,0] + JRST CTYPW1 + +CTYPW3: PUSHJ P,CTYPEW + JRST FINIS + +CTYPW1: GETYP 0,2(AB) + CAIE 0,TATOM + JRST WTYP2 + CAMGE AB,[-5,,0] ; JUMP IF RH IS GIVEN + JRST CTYPW2 +CTYPW5: MOVE C,3(AB) + JRST CTYPW3 + +CTYPW2: CAMGE AB,[-7,,0] + JRST TMA + GETYP 0,4(AB) + CAIE 0,TFIX + JRST WRONGT + MOVE D,5(AB) + JRST CTYPW5 + +CTYPEW: PUSH P,D + PUSHJ P,CTYPEC ; GET CODE IN B + POP P,B + HRLI B,(D) + MOVSI A,TTYPEW + POPJ P, + +MFUNCTION %VTYPE,SUBR,[VALID-TYPE?] + + ENTRY 1 + + GETYP 0,(AB) + CAIE 0,TATOM + JRST WTYP1 + MOVE B,1(AB) + + PUSHJ P,CVTYPE + JFCL + JRST FINIS + +CVTYPE: PUSHJ P,TYPFND ; LOOK IT UP + JRST PFALS + + MOVEI B,(D) + MOVSI A,TTYPEC + JRST CPOPJ1 + +PFALS: MOVEI B,0 + MOVSI A,TFALSE + POPJ P, + +;PRIMTTYPE RETURNS THE TYPE ATOM OF A PRIMITIVE TYPE IN A CLASS + +STBL: REPEAT NUMSAT,SETZ MQUOTE INTERNAL-TYPE + +LOC STBL + +IRP A,,[[1WORD,WORD],[2WORD,LIST],[NWORD,UVECTOR],[2NWORD,VECTOR],[STORE,STORAGE] +[ARGS,TUPLE],[FRAME,FRAME],[ATOM,ATOM],[LOCID,LOCD],[CHSTR,STRING],[OFFS,OFFSET,1] +[PVP,PROCESS,1],[ASOC,ASOC,1],[LOCA,LOCA],[LOCS,LOCS],[LOCU,LOCU],[LOCV,LOCV] +[LOCL,LOCL],[LOCN,LOCAS],[LOCT,LOCT,1],[LOCR,LOCR],[LOCB,LOCB,1],[BYTE,BYTES,1]] +IRP B,C,[A] +LOC STBL+S!B +IRP X,Y,[C] +IFSE [Y],SETZ IMQUOTE X +IFSN [Y],SETZ MQUOTE X +.ISTOP +TERMIN +.ISTOP + +TERMIN +TERMIN + +LOC STBL+NUMSAT+1 + + +MFUNCTION TYPEPRIM,SUBR + + ENTRY 1 + GETYP A,(AB) + CAIE A,TATOM + JRST NOTATOM + MOVE B,1(AB) + PUSHJ P,CTYPEP + JRST FINIS + +CTYPEP: PUSHJ P,TYPLOO ; CONVERT ATOM TO CODE + HRRZ A,(A) ; SAT TO A + ANDI A,SATMSK + JRST PTYP1 + +MFUNCTION PTSATC,SUBR,[PRIMTYPE-C] + + ENTRY 1 + + GETYP A,(AB) + CAIE A,TATOM + JRST WTYP1 + MOVE B,1(AB) + PUSHJ P,CPRTYC + JRST FINIS + +CPRTYC: PUSHJ P,TYPLOO + MOVE B,(A) + ANDI B,SATMSK + MOVSI A,TSATC + POPJ P, + + +IMFUNCTION PRIMTYPE,SUBR + + ENTRY 1 + + MOVE A,(AB) ;GET TYPE + PUSHJ P,CPTYPE + JRST FINIS + +CPTYPE: GETYP A,A + PUSHJ P,SAT ;GET SAT +PTYP1: JUMPE A,TYPERR + MOVE B,IMQUOTE TEMPLATE + CAIG A,NUMSAT ; IF BIG SAT, THEN TEMPLATE + MOVE B,@STBL(A) + MOVSI A,TATOM + POPJ P, + + +; RSUBR MAKES A VECTOR INTO AN OBJECT OF TYPE RSUBR, ALSO SLIGHTLY MUNGING IT + +IMFUNCTION RSUBR,SUBR + ENTRY 1 + + GETYP A,(AB) + CAIE A,TVEC ; MUST BE VECTOR + JRST WTYP1 + MOVE B,1(AB) ; GET IT + GETYP A,(B) ; CHECK 1ST ELEMENTS TYPE + CAIN A,TPCODE ; PURE CODE + JRST .+3 + CAIE A,TCODE + JRST NRSUBR + HLRM B,(B) ; CLOBEER SPECIAL COUNT FIELD + MOVSI A,TRSUBR + JRST FINIS + +NRSUBR: ERRUUO EQUOTE FIRST-ELEMENT-OF-VECTOR-NOT-CODE + +; ROUTINE TO GENERATE ENTRYY OTHER THAN FIRST TO RSUBRR + +IMFUNCTION MENTRY,SUBR,[RSUBR-ENTRY] + + ENTRY 2 + + GETYP 0,(AB) ; TYPE OF ARG + CAIE 0,TVEC ; BETTER BE VECTOR + JRST WTYP1 + GETYP 0,2(AB) + CAIE 0,TFIX + JRST WTYP2 + MOVE B,1(AB) ; GET VECTOR + CAML B,[-3,,0] + JRST BENTRY + GETYP 0,(B) ; FIRST ELEMENT + CAIE 0,TRSUBR + JRST MENTR1 +MENTR2: GETYP 0,2(B) + CAIE 0,TATOM + JRST BENTRY + MOVE C,3(AB) + HRRM C,2(B) ; OFFSET INTO VECTOR + HLRM B,(B) + MOVSI A,TENTER + JRST FINIS + +MENTR1: CAIE 0,TATOM + JRST BENTRY + MOVE B,1(B) ; GET ATOM + PUSHJ P,IGVAL ; GET VAL + GETYP 0,A + CAIE 0,TRSUBR + JRST BENTRY + MOVE C,1(AB) ; RESTORE B + MOVEM A,(C) + MOVEM B,1(C) + MOVE B,C + JRST MENTR2 + +BENTRY: ERRUUO EQUOTE BAD-VECTOR + +; SUBR TO GET ENTRIES OFFSET + +MFUNCTION LENTRY,SUBR,[ENTRY-LOC] + + ENTRY 1 + + GETYP 0,(AB) + CAIE 0,TENTER + JRST WTYP1 + MOVE B,1(AB) + HRRZ B,2(B) + MOVSI A,TFIX + JRST FINIS + +; RETURN FALSE + +RTFALS: MOVSI A,TFALSE + MOVEI B,0 + POPJ P, + +;SUBROUTINE CALL FOR RSUBRs +RCALL: SUBM M,(P) ;CALCULATE PC's OFFSET IN THE RSUBR + HRLI 0,400000 ; DONT LOSE IN MULTI SEG MODE + + PUSHJ P,@0 ;GO TO THE PROPER SUBROUTINE + SUBM M,(P) ;RECONSTITUTE THE RSUBR's PC + POPJ P, + + + +;CHTYPE TAKES TWO ARGUMENTS. ANY GOODIE AND A AN ATOMIC TYPE NAME +;IT CHECKS THE STORAGE ALLOCATION TYPES OF THE TWO ARE THE SAME AND +;IF THEY ARE CHANGES THE TYPE OF THE FIRST TO THAT NAME D IN THE SECOND + +MFUNCTION CHTYPE,SUBR + + ENTRY 2 + GETYP A,2(AB) ;FIRST CHECK THAT ARG 2 IS AN ATOM + CAIE A,TATOM + JRST NOTATOM + MOVE B,3(AB) ;AND TYPE NAME + PUSHJ P,TYPLOO ;GO LOOKUP TYPE +TFOUND: HRRZ B,(A) ;GOBBLE THE SAT + TRNE B,CHBIT ; SKIP IF CHTYPABLE + JRST CANTCH + TRNE B,TMPLBT ; TEMPLAT + HRLI B,-1 + AND B,[-1,,SATMSK] + GETYP A,(AB) ;NOW GET TYPE TO HACK + PUSHJ P,SAT ;FIND OUT ITS SAT + JUMPE A,TYPERR ;COMPLAIN + CAILE A,NUMSAT + JRST CHTMPL ; JUMP IF TEMPLATE DATA + CAIE A,(B) ;DO THEY AGREE? + JRST TYPDIF ;NO, COMPLAIN +CHTMP1: MOVSI A,(D) ;GET NEW TYPE + HRR A,(AB) ; FOR DEFERRED GOODIES + JUMPL B,CHMATC ; CHECK IT + MOVE B,1(AB) ;AND VALUE + JRST FINIS + +CHTMPL: MOVE E,1(AB) ; GET ARG + HLRZ A,(E) + ANDI A,SATMSK + MOVE 0,3(AB) ; SEE IF TO "TEMPLATE" + CAMN 0,IMQUOTE TEMPLATE + JRST CHTMP1 + TLNN E,-1 ; SKIP IF RESTED + CAIE A,(B) + JRST TYPDIF + JRST CHTMP1 + +CHMATC: PUSH TP,A + PUSH TP,1(AB) ; SAVE GOODIE + MOVSI A,TATOM + MOVE B,3(AB) + MOVSI C,TATOM + MOVE D,IMQUOTE DECL + PUSHJ P,IGET ; FIND THE DECL + PUSH TP,A + PUSH TP,B + MOVE C,(AB) + MOVE D,1(AB) ; NOW GGO TO MATCH + PUSHJ P,TMATCH + JRST CHMAT1 + SUB TP,[2,,2] +CHMAT2: POP TP,B + POP TP,A + JRST FINIS + +CHMAT1: POP TP,B + POP TP,A + MOVE C,-1(TP) + MOVE D,(TP) + PUSHJ P,TMATCH + JRST TMPLVI + JRST CHMAT2 + +TYPLOO: PUSHJ P,TYPFND + ERRUUO EQUOTE BAD-TYPE-NAME + POPJ P, + +TYPFND: HLRE A,B ; FIND DOPE WORDS + SUBM B,A ; A POINTS TO IT + HRRE D,(A) ; TYPE-CODE TO D + JUMPE D,CPOPJ + ANDI D,TYPMSK ; FLUSH FUNNY BITS + MOVEI A,(D) + ASH A,1 + HRLI A,(A) + ADD A,TYPVEC+1 +CPOPJ1: AOS (P) + POPJ P, + + +REPEAT 0,[ + MOVE A,TYPVEC+1 ;GOBBLE DOWN TYPE VECTOR + MOVEI D,0 ;INITIALIZE TYPE COUNTER +TLOOK: CAMN B,1(A) ;CHECK THIS ONE + JRST CPOPJ1 + ADDI D,1 ;BUMP COUNTER + AOBJP A,.+2 ;COUTN DOWN ON VECTOR + AOBJN A,TLOOK + POPJ P, +CPOPJ1: AOS (P) + POPJ P, +] + +TYPDIF: ERRUUO EQUOTE STORAGE-TYPES-DIFFER + + +TMPLVI: ERRUUO EQUOTE DECL-VIOLATION + + +; FUNCTION TO ADD A NEW TYPE TO THE WORLD WITH GIVEN PRIMITIVE TYPE + +MFUNCTION NEWTYPE,SUBR + + ENTRY + + HLRZ 0,AB ; CHEC # OF ARGS + CAILE 0,-4 ; AT LEAST 2 + JRST TFA + CAIGE 0,-6 + JRST TMA ; NOT MORE THAN 3 + GETYP A,(AB) ; GET 1ST ARGS TYPE (SHOULD BE ATOM) + GETYP C,2(AB) ; SAME WITH SECOND + CAIN A,TATOM ; CHECK + CAIE C,TATOM + JRST NOTATOM + + MOVE B,3(AB) ; GET PRIM TYPE NAME + PUSHJ P,TYPLOO ; LOOK IT UP + HRRZ A,(A) ; GOBBLE SAT + ANDI A,SATMSK + HRLI A,TATOM ; MAKE NEW TYPE + PUSH P,A ; AND SAVE + MOVE B,1(AB) ; SEE IF PREV EXISTED + PUSHJ P,TYPFND + JRST NEWTOK ; DID NOT EXIST BEFORE + MOVEI B,2(A) ; FOR POSSIBLE TMPLAT BIT + HRRZ A,(A) ; GET SAT + HRRZ 0,(P) ; AND PROPOSED + ANDI A,SATMSK + ANDI 0,SATMSK + CAIN 0,(A) ; SKIP IF LOSER + JRST NEWTFN ; O.K. + + ERRUUO EQUOTE TYPE-ALREADY-EXISTS + +NEWTOK: POP P,A + MOVE B,1(AB) ; NEWTYPE NAME + PUSHJ P,INSNT ; MUNG IN NEW TYPE + +NEWTFN: CAML AB,[-5,,] ; SKIP IF TEMPLAT SUPPLIED + JRST NEWTF1 + MOVEI 0,TMPLBT ; GET THE BIT + IORM 0,-2(B) ; INTO WORD + MOVE A,(AB) ; GET TYPE NAME + MOVE B,1(AB) + MOVSI C,TATOM + MOVE D,IMQUOTE DECL + PUSH TP,4(AB) ; GET TEMLAT + PUSH TP,5(AB) + PUSHJ P,IPUT +NEWTF1: MOVE A,(AB) + MOVE B,1(AB) ; RETURN NAME + JRST FINIS + +; SET UP GROWTH FIELDS + +IGROWT: SKIPA A,[111100,,(C)] +IGROWB: MOVE A,[001100,,(C)] + HLRE B,C + SUB C,B ; POINT TO DOPE WORD + MOVE B,TYPIC ; INDICATED GROW BLOCK + DPB B,A + POPJ P, + +INSNT: PUSH TP,A + PUSH TP,B ; SAVE NAME OF NEWTYPE + MOVE C,TYPBOT+1 ; CHECK GROWTH NEED + CAMGE C,TYPVEC+1 + JRST ADDIT ; STILL ROOM +GAGN: PUSHJ P,IGROWB ; SETUP BOTTOM GROWTH + SKIPE C,EVATYP+1 + PUSHJ P,IGROWT ; SET UP TOP GROWTH + SKIPE C,APLTYP+1 + PUSHJ P,IGROWT + SKIPE C,PRNTYP+1 + PUSHJ P,IGROWT + MOVE C,[11.,,5] ; SET UP INDICATOR FOR AGC + PUSHJ P,AGC ; GROW THE WORLD + AOJL A,GAGN ; BAD AGC LOSSAGE + MOVE 0,[-101,,-100] + ADDM 0,TYPBOT+1 ; FIX UP POINTER + +ADDIT: MOVE C,TYPVEC+1 + SUB C,[2,,2] ; ALLOCATE ROOM + MOVEM C,TYPVEC+1 + HLRE B,C ; PREPARE TO BLT + SUBM C,B ; C POINTS DOPE WORD END + HRLI C,2(C) ; GET BLT AC READY + BLT C,-3(B) + POP TP,-1(B) ; CLOBBER IT IN + POP TP,-2(B) + HLRE C,TYPVEC+1 ; GET CODE + MOVNS C + ASH C,-1 + SUBI C,1 + MOVE D,-1(B) ; B HAS POINTER TO TYPE VECTOR DOPE WORDS + MOVEI 0,(D) + CAIG 0,HIBOT ; IS ATOM PURE? + JRST ADDNOI ; NO, SO NO HACKING REQUIRED + PUSH P,C + MOVE B,D + PUSHJ P,IMPURIF ; DO IMPURE OF ATOM + MOVE C,TYPVEC+1 + HLRE B,C + SUBM C,B ; RESTORE B + POP P,C + MOVE D,-1(B) ; RESTORE D +ADDNOI: HLRE A,D + SUBM D,A + TLO C,400000 + HRRM C,(A) ; INTO "GROWTH" FIELD + POPJ P, + + +; Interface to interpreter for setting up tables associated with +; template data structures. +; A/ <-name of type>- +; B/ <-length ins>- +; C/ <-uvector of garbage collector code or 0> +; D/ <-uvector of GETTERs>- +; E/ <-uvector of PUTTERs>- + +CTMPLT: SUBM M,(P) ; could possibly gc during this stuff + PUSH TP,$TATOM ; save name of type + PUSH TP,A + PUSH P,B ; save length instr + HLRE A,TD.LNT+1 ; check for template slots left? + HRRZ B,TD.LNT+1 + SUB B,A ; point to dope words + HLRZ B,1(B) ; get real length + ADDI A,-2(B) + JUMPG A,GOODRM ; jump if ok + + PUSH TP,$TUVEC ; save getters and putters + PUSH TP,C + PUSH TP,$TUVEC ; save getters and putters + PUSH TP,D + PUSH TP,$TUVEC + PUSH TP,E + MOVEI A,10-2(B) ; grow it 10 by copying remember d.w. length + PUSH P,A ; save new length + PUSHJ P,CAFRE1 ; get frozen uvector + ADD B,[10,,10] ; rest it down some + HRL C,TD.LNT+1 ; prepare to BLT in + MOVEM B,TD.LNT+1 ; and save as new length vector + HRRI C,(B) ; destination + ADD B,(P) ; final destination address + BLT C,-12(B) + MOVE A,(P) ; length for new getters + PUSHJ P,CAFRE1 + HRL C,TD.GET+1 ; get old for copy + MOVEM B,TD.GET+1 + PUSHJ P,DOBLTS ; go fixup new uvector + MOVE A,(P) ; finally putters + PUSHJ P,CAFRE1 + HRL C,TD.PUT+1 + MOVEM B,TD.PUT+1 + PUSHJ P,DOBLTS ; go fixup new uvector + MOVE A,(P) ; finally putters + PUSHJ P,CAFRE1 + HRL C,TD.AGC+1 + MOVEM B,TD.AGC+1 + PUSHJ P,DOBLTS ; go fixup new uvector + SUB P,[1,,1] ; flush stack craft + MOVE E,(TP) + MOVE D,-2(TP) + MOVE C,-4(TP) ;GET TD.AGC + SUB TP,[6,,6] + +GOODRM: MOVE B,TD.LNT+1 ; move down to fit new guy + SUB B,[1,,1] ; will always win due to prev checks + MOVEM B,TD.LNT+1 + HRLI B,1(B) + HLRE A,TD.LNT+1 + MOVNS A + ADDI A,-1(B) ; A/ final destination + BLT B,-1(A) + POP P,(A) ; new length ins munged in + HLRE A,TD.LNT+1 + MOVNS A ; A/ offset for other guys + PUSH P,A ; save it + ADD A,TD.GET+1 ; point for storing uvs of ins + MOVEM D,-1(A) + MOVE A,(P) + ADD A,TD.PUT+1 + MOVEM E,-1(A) ; store putter also + MOVE A,(P) + ADD A,TD.AGC+1 + MOVEM C,-1(A) ; store putter also + POP P,A ; compute primtype + ADDI A,NUMSAT + PUSH P,A + MOVE B,(TP) ; ready to mung type vector + SUB TP,[2,,2] + PUSHJ P,TYPFND ; CHECK TO SEE WHETHER TEMPLATE EXISTS + JRST NOTEM + POP P,C ; GET SAT + HRRM C,(A) + JRST MPOPJ +NOTEM: POP P,A ; RESTORE SAT + HRLI A,TATOM ; GET TYPE + PUSHJ P,INSNT ; INSERT INTO VECTOR + JRST MPOPJ + +; this routine copies GET and PUT vectors into new ones + +DOBLTS: HRRI C,(B) + ADD B,-1(P) + BLT C,-11(B) ; zap those guys in + MOVEI A,TUVEC ; mung in uniform type + PUTYP A,(B) + MOVEI C,-7(B) ; zero out remainder of uvector + HRLI C,-10(B) + SETZM -1(C) + BLT C,-1(B) + POPJ P, + + +; FUNCTIONS TO SET UP EVALUATION AND APPLICATION RULES FOR DATA TYPES + +MFUNCTION EVALTYPE,SUBR + + ENTRY + + PUSHJ P,CHKARG ; VERIFY WINNAGE IN ARGS + MOVEI A,EVATYP ; POINT TO TABLE + MOVEI E,EVTYPE ; POINT TO PURE VERSION + MOVEI 0,EVAL +TBLCAL: PUSHJ P,TBLSET ; SETUP TABLE ENTRY + JRST FINIS + +MFUNCTION APPLYTYPE,SUBR + + ENTRY + + PUSHJ P,CHKARG + MOVEI A,APLTYP ; POINT TO APPLY TABLE + MOVEI E,APTYPE ; PURE TABLE + MOVEI 0,APPLY + JRST TBLCAL + + +MFUNCTION PRINTTYPE,SUBR + + ENTRY + + PUSHJ P,CHKARG + MOVEI A,PRNTYP ; POINT TO APPLY TABLE + MOVEI E,PRTYPE ; PURE TABLE + MOVEI 0,PRINT + JRST TBLCAL + +; CHECK ARGS AND SETUP FOR TABLE HACKER + +CHKARG: JUMPGE AB,TFA + CAMGE AB,[-5,,] + JRST TMA + GETYP A,(AB) ; 1ST MUST BE TYPE NAME + CAIE A,TATOM + JRST WTYP1 + MOVE B,1(AB) ; GET ATOM + PUSHJ P,TYPLOO ; VERIFY THAT IT IS A TYPE + PUSH P,D ; SAVE TYPE NO. + MOVEI D,-1 ; INDICATE FUNNYNESS + CAML AB,[-3,,] ; SKIP IF 2 OR MORE + JRST TY1AR + HRRZ A,(A) ; GET SAT + ANDI A,SATMSK + PUSH P,A + GETYP A,2(AB) ; GET 2D TYPE + CAIE A,TATOM ; EITHER TYPE OR APPLICABLE + JRST TRYAPL ; TRY APPLICABLE + MOVE B,3(AB) ; VERIFY IT IS A TYPE + PUSHJ P,TYPLOO + HRRZ A,(A) ; GET SAT + ANDI A,SATMSK + POP P,C ; RESTORE SAVED SAT + CAIE A,(C) ; SKIP IF A WINNER + JRST TYPDIF ; REPORT ERROR +TY1AR: POP P,C ; GET SAVED TYPE + MOVEI B,0 ; TELL THAT WE ARE A TYPE + POPJ P, + +TRYAPL: PUSHJ P,APLQ ; IS THIS APPLICABLE + JRST NAPT + SUB P,[1,,1] + MOVE B,2(AB) ; RETURN SAME + MOVE D,3(AB) + POP P,C + POPJ P, + + +; HERE TO PUT ENTRY IN APPROPRIATE TABLE + +TBLSET: PUSH TP,B + PUSH TP,D ; SAVE VALUE + PUSH TP,$TFIX + PUSH TP,A + PUSH P,C ; SAVE TYPE BEING HACKED + PUSH P,E + SKIPE B,1(A) ; SKIP IF VECTOR DOESN'T EXIST YET + JRST TBL.OK + MOVE B,-2(TP) ; CHECK FOR RETURN IT HACK + SKIPN -3(TP) + CAIE B,-1 + JRST .+2 + JRST RETPM2 + HLRE A,TYPBOT+1 ; GET CURRENT TABLE LNTH + MOVNS A + ASH A,-1 + PUSH P,0 + PUSHJ P,IVECT ; GET VECTOR + POP P,0 + MOVE C,(TP) ; POINT TO RETURN POINT + MOVEM B,1(C) ; SAVE VECTOR + +TBL.OK: POP P,E + POP P,C ; RESTORE TYPE + SUB TP,[2,,2] + POP TP,D + POP TP,A + JUMPN A,TBLOK1 ; JUMP IF FUNCTION ETC. SUPPLIED + CAIN D,-1 + JRST TBLOK1 + CAILE D,NUMPRI ; SKIP IF ORIGINAL TYPE + MOVNI E,(D) ; CAUSE E TO ENDUP 0 + ADDI E,(D) ; POINT TO PURE SLOT +TBLOK1: ADDI C,(C) ; POINT TO VECTOR SLOT + ADDI C,(B) + CAIN D,-1 + JRST RETCUR + JUMPN A,OK.SET ; OK TO CLOBBER + ADDI B,(D) ; POINT TO TARGET TYPE'S SLOT + ADDI B,(D) ; POINT TO TARGET TYPE'S SLOT + SKIPN A,(B) ; SKIP IF WINNER + SKIPE 1(B) ; SKIP IF LOSER + SKIPA D,1(B) ; SETUP D + JRST CH.PTB ; CHECK PURE TABLE + +OK.SET: CAIN 0,(D) ; SKIP ON RESET + SETZB A,D + MOVEM A,(C) ; STORE + MOVEM D,1(C) +RETAR1: MOVE A,(AB) ; RET TYPE + MOVE B,1(AB) + JRST FINIS + +CH.PTB: MOVEI A,0 + MOVE D,[SETZ NAPT] + JUMPE E,OK.SET + MOVE D,(E) + JRST OK.SET + +RETPM2: SUB TP,[4,,4] + SUB P,[2,,2] + ASH C,1 + SOJA E,RETPM4 + +RETCUR: SKIPN A,(C) + SKIPE 1(C) + SKIPA B,1(C) + JRST RETPRM + + JUMPN A,CPOPJ +RETPM1: MOVEI A,0 + JUMPL B,RTFALS + CAMN B,1(E) + JRST .+3 + ADDI A,2 + AOJA E,.-3 + +RETPM3: ADD A,TYPVEC+1 + MOVE B,3(A) + MOVE A,2(A) + POPJ P, + +RETPRM: SUBI C,(B) ; UNDO BADNESS +RETPM4: CAIG C,NUMPRI*2 + SKIPG 1(E) + JRST RTFALS + + MOVEI A,-2(C) + JRST RETPM3 + +CALLTY: MOVE A,TYPVEC + MOVE B,TYPVEC+1 + POPJ P, + +MFUNCTION ALLTYPES,SUBR + + ENTRY 0 + + MOVE A,TYPVEC + MOVE B,TYPVEC+1 + JRST FINIS + +; + +;FUNCTION TO RETURN TYPE OF ELEMENTS IN A UVECTOR + +MFUNCTION UTYPE,SUBR + + ENTRY 1 + + GETYP A,(AB) ;GET U VECTOR + PUSHJ P,SAT + CAIE A,SNWORD + JRST WTYP1 + MOVE B,1(AB) ; GET UVECTOR + PUSHJ P,CUTYPE + JRST FINIS + +CUTYPE: HLRE A,B ;GET -LENGTH + HRRZS B + SUB B,A ;POINT TO TYPE WORD + GETYP A,(B) + JRST ITYPE ; GET NAME OF TYPE + +; FUNCTION TO CHANGE UNIFORM TYPE OF A VECTOR + +MFUNCTION CHUTYPE,SUBR + + ENTRY 2 + + GETYP A,2(AB) ;GET 2D TYPE + CAIE A,TATOM + JRST NOTATO + GETYP A,(AB) ; CALL WITH UVECTOR? + PUSHJ P,SAT + CAIE A,SNWORD + JRST WTYP1 + MOVE A,1(AB) ; GET UV POINTER + MOVE B,3(AB) ;GET ATOM + PUSHJ P,CCHUTY + MOVE A,(AB) ; RETURN UVECTOR + MOVE B,1(AB) + JRST FINIS + +CCHUTY: PUSH TP,$TUVEC + PUSH TP,A + PUSHJ P,TYPLOO ;LOOK IT UP + HRRZ B,(A) ;GET SAT + TRNE B,CHBIT + JRST CANTCH + ANDI B,SATMSK + SKIPGE MKTBS(B) + JRST CANTCH + HLRE C,(TP) ;-LENGTH + HRRZ E,(TP) + SUB E,C ;POINT TO TYPE + GETYP A,(E) ;GET TYPE + JUMPE A,WIN0 ;ALLOW TYPE "LOSE" TO CHANGE TO ANYTHING + PUSHJ P,SAT ;GET SAT + JUMPE A,TYPERR + CAIE A,(B) ;COMPARE + JRST TYPDIF +WIN0: ADDI D,.VECT. + HRLM D,(E) ;CLOBBER NEW ONE + POP TP,B + POP TP,A + POPJ P, + +CANTCH: PUSH TP,$TATOM + PUSH TP,EQUOTE CANT-CHTYPE-INTO + PUSH TP,2(AB) + PUSH TP,3(AB) + MOVEI A,2 + JRST CALER + +NOTATOM: + PUSH TP,$TATOM + PUSH TP,EQUOTE NON-ATOMIC-ARGUMENT + PUSH TP,(AB) + PUSH TP,1(AB) + MOVEI A,2 + JRST CALER + + + +; SUBROUTINE TO LEAVE MUDDLE CLOSING ALL CHANNELS ON THE WAY + +MFUNCTION QUIT,SUBR + + ENTRY 0 + + + PUSHJ P,CLOSAL ; DO THE CLOSES + PUSHJ P,%KILLM + JRST IFALSE ; JUST IN CASE + +CLOSAL: MOVEI B,CHNL0+2 ; POINT TO 1ST (NOT INCLUDING TTY I/O) + MOVE PVP,PVSTOR+1 + MOVE TVP,REALTV+1(PVP) + SUBI B,(TVP) + HRLS B + ADD B,TVP + PUSH TP,$TVEC + PUSH TP,B + PUSH P,[N.CHNS-1] ; MAX NO. OF CHANS + +CLOSA1: MOVE B,(TP) + ADD B,[2,,2] + MOVEM B,(TP) + HLLZS -2(B) + SKIPN C,-1(B) ; THIS ONE OPEN? + JRST CLOSA4 ; NO + CAME C,TTICHN+1 + CAMN C,TTOCHN+1 + JRST CLOSA4 + PUSH TP,-2(B) ; PUSH IT + PUSH TP,-1(B) + MCALL 1,FCLOSE ; CLOSE IT +CLOSA4: SOSLE (P) ; COUNT DOWN + JRST CLOSA1 + + + SUB TP,[2,,2] + SUB P,[1,,1] + +CLOSA3: SKIPN B,CHNL0+1 + POPJ P, + PUSH TP,(B) + HLLZS (TP) + PUSH TP,1(B) + HRRZ B,(B) + MOVEM B,CHNL0+1 + MCALL 1,FCLOSE + JRST CLOSA3 + + +IMPURE + +WHOAMI: 0 ; SYAYS WHETHER I AM REALLY A MUDDLE OR SOME HACK + + +;GARBAGE COLLECTORS PDLS + + +GCPDL: -GCPLNT,,GCPDL + + BLOCK GCPLNT + + +PURE + +MUDSTR: ASCII /MUDDLE / +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 + \ No newline at end of file diff --git a//main.mid.352 b//main.mid.352 new file mode 100644 index 0000000..2be87b5 --- /dev/null +++ b//main.mid.352 @@ -0,0 +1,2058 @@ +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 + + +IMFUNCTION LISTEN,SUBR + + ENTRY + PUSH P,[0] ;FLAG: DON'T PRINT ERROR MSG + JRST ER1 + +; USER SUPPLIED ERROR HANDLER, TEMPORARY KLUDGE + IMQUOTE ERROR + +ERROR: MOVE B,IMQUOTE ERROR + PUSHJ P,IGVAL ; GET VALUE + GETYP C,A + CAIN C,TSUBR ; CHECK FOR NO CHANGE + CAIE B,RERR1 ; SKIP IF NOT CHANGED + JRST .+2 + JRST RERR1 ; GO TO THE DEFAULT + PUSH TP,A ; SAVE VALUE + PUSH TP,B + MOVE C,AB ; SAVE AB + MOVEI D,1 ; AND COUNTER +USER1: PUSH TP,(C) ; PUSH THEM + PUSH TP,1(C) + ADD C,[2,,2] ; BUMP + ADDI D,1 + JUMPL C,USER1 + ACALL D,APPLY ; EVAL USERS ERROR + JRST FINIS + + + +IMFUNCTION ERROR%,SUBR,ERROR + +RERR1: ENTRY + PUSH TP,$TATOM + PUSH TP,MQUOTE ERROR,ERROR,INTRUP + PUSHJ P,FRMSTK ; PUT ERROR'S FRAME ON STACK + MOVEI D,2 + MOVE C,AB +RERR2: JUMPGE C,RERR22 + PUSH TP,(C) + PUSH TP,1(C) + ADD C,[2,,2] + AOJA D,RERR2 +RERR22: ACALL D,EMERGENCY + JRST RERR + +IMQUOTE ERROR +RERR: ENTRY + PUSH P,[-1] ;PRINT ERROR FLAG + +ER1: MOVE B,IMQUOTE INCHAN + PUSHJ P,ILVAL ; CHECK INPUT CHANNEL IS SOME KIND OF TTY + GETYP A,A + CAIE A,TCHAN ; SKIP IF IT IS A CHANNEL + JRST ER2 ; NO, MUST REBIND + CAMN B,TTICHN+1 + JRST NOTINC +ER2: MOVE B,IMQUOTE INCHAN + MOVEI C,TTICHN ; POINT TO VALU + PUSHJ P,PUSH6 ; PUSH THE BINDING + MOVE B,TTICHN+1 ; GET IN CHAN +NOTINC: SKIPN DEMFLG ; SKIP IF DEMON + SKIPE NOTTY + JRST NOECHO + PUSH TP,$TCHAN + PUSH TP,B + PUSH TP,$TATOM + PUSH TP,IMQUOTE T + MCALL 2,TTYECH ; ECHO INPUT +NOECHO: MOVE B,IMQUOTE OUTCHAN + PUSHJ P,ILVAL ; GET THE VALUE + GETYP A,A + CAIE A,TCHAN ; SKIP IF OK CHANNEL + JRST ER3 ; NOT CHANNEL, MUST REBIND + CAMN B,TTOCHN+1 + JRST NOTOUT +ER3: MOVE B,IMQUOTE OUTCHAN + MOVEI C,TTOCHN + PUSHJ P,PUSH6 ; PUSH THE BINDINGS +NOTOUT: MOVE B,IMQUOTE OBLIST + PUSHJ P,ILVAL ; GET THE VALUE OF OBLIST + PUSHJ P,OBCHK ; IS IT A WINNER ? + SKIPA A,$TATOM ; NO, SKIP AND CONTINUE + JRST NOTOBL ; YES, DO NOT DO REBINDING + MOVE B,IMQUOTE OBLIST + PUSHJ P,IGLOC + GETYP 0,A + CAIN 0,TUNBOU + JRST MAKOB ; NO GLOBAL OBLIST, MAKE ONE + MOVEI C,(B) ; COPY ADDRESS + MOVE A,(C) ; GET THE GVAL + MOVE B,(C)+1 + PUSHJ P,OBCHK ; IS IT A WINNER ? + JRST MAKOB ; NO, GO MAKE A NEW ONE + MOVE B,IMQUOTE OBLIST + PUSHJ P,PUSH6 + +NOTOBL: PUSH TP,[TATOM,,-1] ;FOR BINDING + PUSH TP,IMQUOTE LER,[LERR ]INTRUP + PUSHJ P,MAKACT + HRLI A,TFRAME ; CORRCT TYPE + PUSH TP,A + PUSH TP,B + PUSH TP,[0] + PUSH TP,[0] + MOVE A,PVSTOR+1 ; GET PROCESS + ADD A,[PROCID,,PROCID] ; POINT TO ID (ALSO LEVEL) + PUSH TP,BNDV + PUSH TP,A + MOVE A,PROCID(PVP) + ADDI A,1 ; BUMP ERROR LEVEL + PUSH TP,A + PUSH TP,PROCID+1(PVP) + PUSH P,A + + MOVE B,IMQUOTE READ-TABLE + PUSHJ P,IGVAL + PUSH TP,[TATOM,,-1] + PUSH TP,IMQUOTE READ-TABLE + GETYP C,A ; TO GVAL OF READ-TABLE ON ERROR AND + CAIE C,TVEC ; TOP ERRET'S + JRST .+4 + PUSH TP,A + PUSH TP,B + JRST .+3 + PUSH TP,$TUNBOUND + PUSH TP,[-1] + PUSH TP,[0] + PUSH TP,[0] + + PUSHJ P,SPECBIND ;BIND THE CRETANS + MOVE A,-1(P) ;RESTORE SWITHC + JUMPE A,NOERR ;IF 0, DONT PRINT ERROR MESS + PUSH TP,$TATOM + PUSH TP,EQUOTE *ERROR* + MCALL 0,TERPRI + MCALL 1,PRINC ;PRINT THE MESSAGE +NOERR: MOVE C,AB ;GET A COPY OF AB + +ERRLP: JUMPGE C,LEVPRT ;IF NONE, RE-ENTER READ-EVAL-PRINT LOOP + PUSH TP,$TAB + PUSH TP,C + MOVEI B,PRIN1 + GETYP A,(C) ; GET ARGS TYPE + CAIE A,TATOM + JRST ERROK + MOVE A,1(C) ; GET ATOM + HRRO A,2(A) + CAME A,[-1,,ERROBL+1] + CAMN A,ERROBL+1 ; DONT SKIP IF IN ERROR OBLIST + MOVEI B,PRINC ; DONT PRINT TRAILER +ERROK: PUSH P,B ; SAVE ROUTINE POINTER + PUSH TP,(C) + PUSH TP,1(C) + MCALL 0,TERPRI ; CRLF + POP P,B ; GET ROUTINE BACK + .MCALL 1,(B) + POP TP,C + SUB TP,[1,,1] + ADD C,[2,,2] ;BUMP SAVED AB + JRST ERRLP ;AND CONTINUE + + +LEVPRT: XCT INITFL ;LOAD MUDDLE INIT FILE IF FIRST TIME + MCALL 0,TERPRI + PUSH TP,$TATOM + PUSH TP,EQUOTE [LISTENING-AT-LEVEL ] + MCALL 1,PRINC ;PRINT LEVEL + PUSH TP,$TFIX ;READY TO PRINT LEVEL + HRRZ A,(P) ;GET LEVEL + SUB P,[2,,2] ;AND POP STACK + PUSH TP,A + MCALL 1,PRIN1 ;PRINT WITHOUT SPACES ETC. + PUSH TP,$TATOM ;NOW PROCESS + PUSH TP,EQUOTE [ PROCESS ] + MCALL 1,PRINC ;DONT SLASHIFY SPACES + MOVE PVP,PVSTOR+1 + PUSH TP,PROCID(PVP) ;NOW ID + PUSH TP,PROCID+1(PVP) + MCALL 1,PRIN1 + SKIPN C,CURPRI + JRST MAINLP + PUSH TP,$TFIX + PUSH TP,C + PUSH TP,$TATOM + PUSH TP,EQUOTE [ INT-LEVEL ] + MCALL 1,PRINC + MCALL 1,PRIN1 + JRST MAINLP ; FALL INTO MAIN LOOP + + ;ROUTINES FOR ERROR-LISTEN + +OBCHK: GETYP 0,A + CAIN 0,TOBLS + JRST CPOPJ1 ; WIN FOR SINGLE OBLIST + CAIE 0,TLIST ; IF LIST, MAKE SURE EACH IS AN OBLIST + JRST CPOPJ ; ELSE, LOSE + + JUMPE B,CPOPJ ; NIL ,LOSE + PUSH TP,A + PUSH TP,B + PUSH P,[0] ;FLAG FOR DEFAULT CHECKING + MOVEI 0,1000 ; VERY BIG NUMBER FOR CIRCULARITY TEST + +OBCHK0: INTGO + SOJE 0,OBLOSE ; CIRCULARITY TEST + HRRZ B,(TP) ; GET LIST POINTER + GETYP A,(B) + CAIE A,TOBLS ; SKIP IF WINNER + JRST DEFCHK ; CHECK FOR SPECIAL ATOM DEFAULT + HRRZ B,(B) + MOVEM B,(TP) + JUMPN B,OBCHK0 +OBWIN: AOS (P)-1 +OBLOSE: SUB TP,[2,,2] + SUB P,[1,,1] + POPJ P, + +DEFCHK: SKIPN (P) ; BEEN HERE BEFORE ? + CAIE A,TATOM ; OR, NOT AN ATOM ? + JRST OBLOSE ; YES, LOSE + MOVE A,(B)+1 + CAME A,MQUOTE DEFAULT + JRST OBLOSE ; LOSE + SETOM (P) ; SET FLAG + HRRZ B,(B) ; CHECK FOR END OF LIST + MOVEM B,(TP) + JUMPN B,OBCHK0 ; NOT THE END, CONTINUE LOOKING + JRST OBLOSE ; LOSE FOR DEFAULT AT THE END + + + +PUSH6: PUSH TP,[TATOM,,-1] + PUSH TP,B + PUSH TP,(C) + PUSH TP,1(C) + PUSH TP,[0] + PUSH TP,[0] + POPJ P, + + +MAKOB: PUSH TP,INITIAL + PUSH TP,INITIAL+1 + PUSH TP,ROOT + PUSH TP,ROOT+1 + MCALL 2,LIST + PUSH TP,$TATOM + PUSH TP,IMQUOTE OBLIST + PUSH TP,A + PUSH TP,B + MCALL 2,SETG + PUSH TP,[TATOM,,-1] + PUSH TP,IMQUOTE OBLIST + PUSH TP,A + PUSH TP,B + PUSH TP,[0] + PUSH TP,[0] + JRST NOTOBL + + +;THIS IS IT FOLKS...THE MAIN LOOP. READ, EVAL, PRINT + +MAINLP: MOVE A,$TATOM ;KLUDGE BY NDR LIKE ERROR TO LET LOOSER REDEFINE + MOVE B,IMQUOTE REP + PUSHJ P,ILVAL ;GET ITS LVAL TO SEE IF REDEFINED + GETYP C,A + CAIE C,TUNBOUND + JRST REPCHK + MOVE A,$TATOM ;SEE IF IT HAS GVAL SINCE NO LVAL + MOVE B,IMQUOTE REP + PUSHJ P,IGVAL + GETYP C,A + CAIN C,TUNBOUN + JRST IREPER +REPCHK: CAIN C,TSUBR + CAIE B,REPER + JRST .+2 + JRST IREPER +REREPE: PUSH TP,A + PUSH TP,B + GETYP A,-1(TP) + PUSHJ P,APLQ + JRST ERRREP + MCALL 1,APPLY ;LOOSER HAS REDEFINED SO CALL HIS + JRST MAINLP +IREPER: PUSH P,[0] ;INDICATE FALL THROUGH + JRST REPERF + +ERRREP: PUSH TP,[TATOM,,-1] + PUSH TP,IMQUOTE REP + PUSH TP,$TSUBR + PUSH TP,[REPER] + PUSH TP,[0] + PUSH TP,[0] + PUSHJ P,SPECBIN + PUSH TP,$TATOM + PUSH TP,EQUOTE NON-APPLICABLE-REP + PUSH TP,-11(TP) + PUSH TP,-11(TP) + MCALL 2,ERROR + SUB TP,[6,,6] + PUSHJ P,SSPECS + JRST REREPE + + +IMFUNCTION REPER,SUBR,REP +REPER: ENTRY 0 + PUSH P,[1] ;INDICATE DIRECT CALL +REPERF: MCALL 0,TERPRI + MCALL 0,READ + PUSH TP,A + PUSH TP,B + MOVE B,IMQUOTE L-INS + PUSHJ P,ILVAL ; ASSIGNED? + GETYP 0,A + CAIN 0,TLIST + + PUSHJ P,LSTTOF ; PUT LAST AS FIRST + MCALL 0,TERPRI + MCALL 1,EVAL + MOVE C,IMQUOTE LAST-OUT + PUSHJ P,CISET + PUSH TP,A + PUSH TP,B + MOVE B,IMQUOTE L-OUTS + PUSHJ P,ILVAL ; ASSIGNED? + GETYP 0,A + CAIN 0,TLIST + + CAME B,(TP) ; DONT STUFF IT INTO ITSELF + JRST STUFIT ; STUFF IT IN + GETYP 0,-1(TP) + CAIE 0,TLIST ; IF A LIST THE L-OUTS +STUFIT: PUSHJ P,LSTTOF ; PUT LAST AS FIRST + MCALL 1,PRIN1 + POP P,C ;FLAG FOR FALL THROUGH OR CALL + JUMPN C,FINIS ;IN CASE LOOSER CALLED REP + JRST MAINLP + +LSTTOF: SKIPN A,B + POPJ P, + + HRRZ C,(A) + JUMPE C,LSTTO2 + MOVEI D,(C) ; SAVE PTR TO 2ND ELEMENT + MOVEI 0,-1 ; LET THE LOSER LOSE (HA HA HA) + +LSTTO1: HRRZ C,(C) ; START SCAN + JUMPE C,GOTIT + HRRZ A,(A) + SOJG 0,LSTTO1 + +GOTIT: HRRZ C,(A) + HLLZS (A) + CAIE D,(C) ; AVOID CIRCULARITY + HRRM D,(C) + HRRM C,(B) + MOVE D,1(B) + MOVEM D,1(C) + GETYP D,(B) + PUTYP D,(C) + +LSTTO2: MOVSI A,TLIST + MOVE C,-1(TP) + MOVE D,(TP) + JRST LSTUF + +;FUNCTION TO RETRY A PREVIOUS FUNCTION CALL + +MFUNCTION RETRY,SUBR + + ENTRY + JUMPGE AB,RETRY1 ; USE MOST RECENT + CAMGE AB,[-2,,0] + JRST TMA + GETYP A,(AB) ; CHECK TYPE + CAIE A,TFRAME + JRST WTYP1 + MOVEI B,(AB) ; POINT TO ARG + JRST RETRY2 +RETRY1: MOVE B,IMQUOTE LER,[LERR ]INTRUP + PUSHJ P,ILOC ; LOCATIVE TO FRAME +RETRY2: PUSHJ P,CHFSWP ; CHECK VALIDITY AND SWAP IF NECESSARY + HRRZ 0,OTBSAV(B) ; CHECK FOR TOP + JUMPE 0,RESTAR ; YES RE-ENTER TOP LEVEL + PUSH TP,$TTB + PUSH TP,B ; SAVE FRAME + MOVE B,OTBSAV(B) ; GET PRVIOUS FOR UNBIND HACK + MOVEI C,-1(TP) + PUSHJ P,CHUNW ; CHECK ANY UNWINDING + CAME SP,SPSAV(TB) ; UNBINDING NEEDED? + PUSHJ P,SPECSTORE + MOVE P,PSAV(TB) ; GET OTHER STUFF + MOVE AB,ABSAV(B) + HLRE A,AB ; COMPUTE # OF ARGS + MOVNI A,-FRAMLN(A) ; MAKE TP POINT PAST FRAME + HRLI A,(A) + MOVE C,TPSAV(TB) ; COMPUTE TP + ADD C,A + MOVE TP,C + MOVE TB,B ; FIX UP TB + HRRZ C,FSAV(TB) ; GET FUNCTION + CAIL C,HIBOT + JRST (C) ; GO + GETYP 0,(C) ; RSUBR OR ENTRY? + CAIE 0,TATOM + CAIN 0,TRSUBR + JRST RETRNT + MOVS R,(C) ; SET UP R + HRRI R,(C) + MOVEI C,0 + JRST RETRN3 + +RETRNT: CAIE 0,TRSUBR + JRST RETRN1 + MOVE R,1(C) +RETRN4: HRRZ C,2(C) ; OFFSET +RETRN3: SKIPL M,1(R) + JRST RETRN5 +RETRN7: ADDI C,(M) + JRST (C) + +RETRN5: MOVEI D,(M) ; TOTAL OFFSET + MOVSS M + ADD M,PURVEC+1 + SKIPL M,1(M) + JRST RETRN6 + ADDI M,(D) + JRST RETRN7 + +RETRN6: HLRZ A,1(R) + PUSH P,D + PUSH P,C + PUSHJ P,PLOAD + JRST RETRER ; LOSER + POP P,C + POP P,D + MOVE M,B + JRST RETRN7 + +RETRN1: HRL C,(C) ; FIX LH + MOVE B,1(C) + PUSH TP,$TVEC + PUSH TP,C + PUSHJ P,IGVAL + GETYP 0,A + MOVE C,(TP) + SUB TP,[2,,2] + CAIE 0,TRSUBR + JRST RETRN2 + MOVE R,B + JRST RETRN4 + +RETRN2: ERRUUO EQUOTE CANT-RETRY-ENTRY-GONE + +RETRER: ERRUUO EQUOTE PURE-LOAD-FAILURE + + +;FUNCTION TO DO ERROR RETURN + +IMFUNCTION ERRET,SUBR + + ENTRY + HLRE A,AB ; -2*# OF ARGS + JUMPGE A,STP ; RESTART PROCESS + ASH A,-1 ; -# OF ARGS + AOJE A,ERRET2 ; NO FRAME SUPPLIED + AOJL A,TMA + ADD AB,[2,,2] + PUSHJ P,OKFRT + JRST WTYP2 + SUB AB,[2,,2] + PUSHJ P,CHPROC ; POINT TO FRAME SLOT + JRST ERRET3 +ERRET2: MOVE B,IMQUOTE LER,[LERR ]INTRUP + PUSHJ P,ILVAL ; GET ITS VALUE +ERRET3: PUSH TP,A + PUSH TP,B + MOVEI B,-1(TP) + PUSHJ P,CHFSWP ; CHECK VALIDITY AND SWAP IF NECESSARY + HRRZ 0,OTBSAV(B) ; TOP LEVEL? + JUMPE 0,TOPLOS + PUSHJ P,CHUNW ; ANY UNWINDING + JRST CHFINIS + + +; FUNCTION TO RETURN LAST ERROR FRAME OR PREVIOUS FRAME + +IMFUNCTION FRAME,SUBR + ENTRY + SETZB A,B + JUMPGE AB,FRM1 ; DEFAULT CASE + CAMG AB,[-3,,0] ; SKIP IF OK ARGS + JRST TMA + PUSHJ P,OKFRT ; A FRAME OR SIMILAR THING? + JRST WTYP1 + +FRM1: PUSHJ P,CFRAME ; GO TO INTERNAL + JRST FINIS + +CFRAME: JUMPN A,FRM2 ; ARG SUPPLIED? + MOVE B,IMQUOTE LER,[LERR ]INTRUP + PUSHJ P,ILVAL + JRST FRM3 +FRM2: PUSHJ P,CHPROC ; CHECK FOR PROCESS + PUSH TP,A + PUSH TP,B + MOVEI B,-1(TP) ; POINT TO SLOT + PUSHJ P,CHFRM ; CHECK IT + MOVE C,(TP) ; GET FRAME BACK + MOVE B,OTBSAV(C) ;GET PREVIOUS FRAME + SUB TP,[2,,2] + TRNN B,-1 ; SKIP IF OK + JRST TOPLOSE + +FRM3: JUMPN B,FRM4 ; JUMP IF WINNER + MOVE B,IMQUOTE THIS-PROCESS + PUSHJ P,ILVAL ; GET PROCESS OF INTEREST + GETYP A,A ; CHECK IT + CAIN A,TUNBOU + MOVE B,PVSTOR+1 ; USE CURRENT + MOVEI A,PVLNT*2+1(B) ; POINT TO DOPE WORDS + MOVE B,TBINIT+1(B) ; AND BASE FRAME +FRM4: HLL B,OTBSAV(B) ;TIME + HRLI A,TFRAME + POPJ P, + +OKFRT: AOS (P) ;ASSUME WINNAGE + GETYP 0,(AB) + MOVE A,(AB) + MOVE B,1(AB) + CAIE 0,TFRAME + CAIN 0,TENV + POPJ P, + CAIE 0,TPVP + CAIN 0,TACT + POPJ P, + SOS (P) + POPJ P, + +CHPROC: GETYP 0,A ; TYPE + CAIE 0,TPVP + POPJ P, ; OK + MOVEI A,PVLNT*2+1(B) + CAMN B,PVSTOR+1 ; THIS PROCESS? + JRST CHPRO1 + MOVE B,TBSTO+1(B) + JRST FRM4 + +CHPRO1: MOVE B,OTBSAV(TB) + JRST FRM4 + +; FUNCTION TO RETURN ARGS TUPLE FOR A FRAME + +MFUNCTION ARGS,SUBR + ENTRY 1 + PUSHJ P,OKFRT ; CHECK FRAME TYPE + JRST WTYP1 + PUSHJ P,CARGS + JRST FINIS + +CARGS: PUSHJ P,CHPROC + PUSH TP,A + PUSH TP,B + MOVEI B,-1(TP) ; POINT TO FRAME SLOT + PUSHJ P,CHFRM ; AND CHECK FOR VALIDITY + MOVE C,(TP) ; FRAME BACK + MOVSI A,TARGS +CARGS1: GETYP 0,FSAV(C) ; IS THIS A FUNNY ONE + CAIE 0,TCBLK ; SKIP IF FUNNY + JRST .+3 ; NO NORMAL + MOVE C,OTBSAV(C) ; ASSOCIATE WITH PREVIOUS FRAME + JRST CARGS1 + HLR A,OTBSAV(C) ; TIME IT AND + MOVE B,ABSAV(C) ; GET POINTER + SUB TP,[2,,2] ; FLUSH CRAP + POPJ P, + +; FUNCTION TO RETURN FUNCTION ASSOCIATED WITH A FRAME + +MFUNCTION FUNCT,SUBR + ENTRY 1 ; FRAME ARGUMENT + PUSHJ P,OKFRT ; CHECK TYPE + JRST WTYP1 + PUSHJ P,CFUNCT + JRST FINIS + +CFUNCT: PUSHJ P,CHPROC + PUSH TP,A + PUSH TP,B + MOVEI B,-1(TP) + PUSHJ P,CHFRM ; CHECK IT + MOVE C,(TP) ; RESTORE FRAME + HRRZ A,FSAV(C) ;FUNCTION POINTER + CAIL A,HIBOT + SKIPA B,@-1(A) ;NO, GET SUBR'S NAME POINTER + MOVE B,(A)+3 ;YES, GET RSUBR'S NAME ENTRY + MOVSI A,TATOM + SUB TP,[2,,2] + POPJ P, + +BADFRAME: + ERRUUO EQUOTE FRAME-NO-LONGER-EXISTS + + +TOPLOSE: + ERRUUO EQUOTE TOP-LEVEL-FRAME + + + + +; ROUTINE TO HANG INDEFINITELY WITH INTERRUPTS ENABLED + +MFUNCTION HANG,SUBR + + ENTRY + + JUMPGE AB,HANG1 ; NO PREDICATE + CAMGE AB,[-3,,] + JRST TMA + PUSH TP,(AB) + PUSH TP,1(AB) + PUSHJ P,CHKPRD +REHANG: MOVE A,[PUSHJ P,CHKPRH] + MOVEM A,ONINT ; CHECK PREDICATE AFTER ANY INTERRUPT +HANG1: ENABLE ;LET OURSELVES BE INTERRUPTED OUT + PUSHJ P,%HANG + DISABLE ;PREVENT INTERRUPTS AT RANDOM TIMES + SETZM ONINT + MOVE A,$TATOM + MOVE B,IMQUOTE T + JRST FINIS + + +; ROUTINE TO SLEEP FOR POSITIVE NUMBER OF SECONDS WITH INTERRUPTS ENABLED +; ARGUMENT SHOULD BE OF TYPE FIX OR FLOAT AND NON-NEGATIVE + +MFUNCTION SLEEP,SUBR + + ENTRY + + JUMPGE AB,TFA + CAML AB,[-3,,] + JRST SLEEP1 + CAMGE AB,[-5,,] + JRST TMA + PUSH TP,2(AB) + PUSH TP,3(AB) + PUSHJ P,CHKPRD +SLEEP1: GETYP 0,(AB) + CAIE 0,TFIX + JRST .+5 + MOVE B,1(AB) + JUMPL B,OUTRNG ;ARG SHOULDNT BE NEGATIVE + IMULI B,30. ;CONVERT TO # OF THIRTIETHS OF A SECOND + JRST SLEEPR ;GO SLEEP + CAIE 0,TFLOAT ;IF IT WASNT FIX MAKE SURE IT IS FLOAT + JRST WTYP1 ;WRONG TYPE ARG + MOVE B,1(AB) + FMPR B,[30.0] ;CONVERT TO FLOATING # OF THIRTIETHS OF A SECOND + MULI B,400 ;KLUDGE TO FIX IT + TSC B,B + ASH C,(B)-243 + MOVE B,C ;MOVE THE FIXED NUMBER INTO B + JUMPL B,OUTRNG ;CHECK TO SEE THAT WE HAVE POSITIVE NUMBER +SLEEPR: MOVE A,B +RESLEE: MOVE B,[PUSHJ P,CHKPRS] + CAMGE AB,[-3,,] + MOVEM B,ONINT + ENABLE + PUSHJ P,%SLEEP + DISABLE + SETZM ONINT + MOVE A,$TATOM + MOVE B,IMQUOTE T + JRST FINIS + +CHKPRH: PUSH P,B + MOVEI B,HANGP + JRST .+3 + +CHKPRS: PUSH P,B + MOVEI B,SLEEPP + HRRM B,LCKINT + SETZM ONINT ; TURN OFF FEATURE FOR NOW + POP P,B + POPJ P, + +HANGP: SKIPA B,[REHANG] +SLEEPP: MOVEI B,RESLEE + PUSH P,B +CHKPRD: PUSH P,A + DISABLE + PUSH TP,(TB) + PUSH TP,1(TB) + MCALL 1,EVAL + GETYP 0,A + CAIE 0,TFALSE + JRST FINIS + POP P,A + POPJ P, + +MFUNCTION VALRET,SUBR +; SUBR TO VALRET A STRING TO SUPERIOR ITS PROCESS + + ENTRY 1 + GETYP A,(AB) ; GET TYPE OF ARGUMENT + CAIN A,TFIX ; FIX? + JRST VALRT1 + CAIE A,TCHSTR ; IS IT A CHR STRING? + JRST WTYP1 ; NO...ERROR WRONG TYPE + PUSHJ P,CSTACK ; COPY THE CHR STRING TO THE STACK + ; CSTACK IS IN ATOMHK + MOVEI B,0 ; ASCIZ TERMINATOR + EXCH B,(P) ; STORE AND RETRIEVE COUNT + +; CALCULATE THE BEGINNING ADDR OF THE STRING + MOVEI A,-1(P) ; GET ADDR OF TOP OF STACK + SUBI A,-1(B) ; GET STARTING ADDR + PUSHJ P,%VALRE ; PASS UP TO MONITOR + JRST IFALSE ; IF HE RETURNS, RETURN FALSE + +VALRT1: MOVE A,1(AB) + PUSHJ P,%VALFI + JRST IFALSE + +MFUNCTION LOGOUT,SUBR + +; SUBR TO DO A .LOGOUT (VALID ONLY AT TOP LEVEL) + ENTRY 0 + PUSHJ P,%TOPLQ ; SKIP IF AT TOP LEVEL + JRST IFALSE + PUSHJ P,CLOSAL + PUSHJ P,%LOGOUT ; TRY TO FLUSH + JRST IFALSE ; COULDN'T DO IT...RETURN FALSE + +; FUNCTS TO GET UNAME AND JNAME + +; GET XUNAME (REAL UNAME) +MFUNCTION XUNAME,SUBR + + ENTRY 0 + + PUSHJ P,%RXUNA + JRST RSUJNM + JRST FINIS ; 10X ROUTINES SKIP + +MFUNCTION UNAME,SUBR + + ENTRY 0 + + PUSHJ P,%RUNAM + JRST RSUJNM + JRST FINIS + +; REAL JNAME +MFUNCTION XJNAME,SUBR + + ENTRY 0 + + PUSHJ P,%RXJNA + JRST RSUJNM + +MFUNCTION JNAME,SUBR + + ENTRY 0 + + PUSHJ P,%RJNAM + JRST RSUJNM + +; FUNCTION TO SET AND READ GLOBAL SNAME + +MFUNCTION SNAME,SUBR + + ENTRY + + JUMPGE AB,SNAME1 + CAMG AB,[-3,,] + JRST TMA + GETYP A,(AB) ; ARG MUST BE STRING + CAIE A,TCHSTR + JRST WTYP1 + PUSH TP,$TATOM + PUSH TP,IMQUOTE SNM + PUSH TP,(AB) + PUSH TP,1(AB) + MCALL 2,SETG + JRST FINIS + +SNAME1: MOVE B,IMQUOTE SNM + PUSHJ P,IDVAL1 + GETYP 0,A + CAIN 0,TCHSTR + JRST FINIS + MOVE A,$TCHSTR + MOVE B,CHQUOTE + JRST FINIS + +RSUJNM: PUSHJ P,6TOCHS ; CONVERT IT + JRST FINIS + + +SGSNAM: MOVE B,IMQUOTE SNM + PUSHJ P,IDVAL1 + GETYP 0,A + CAIE 0,TCHSTR + JRST SGSN1 + + PUSH TP,A + PUSH TP,B + PUSHJ P,STRTO6 + POP P,A + SUB TP,[2,,2] + JRST .+2 + +SGSN1: MOVEI A,0 + PUSHJ P,%SSNAM ; SET SNAME IN SYSTEM + POPJ P, + + + +;THIS SUBROUTINE ALLOCATES A NEW PROCESS +;TAKES TP-STACK SIZE (2*WORDS) IN A AND P-STACK SIZE (WORDS) IN B +;IS CALLED BY PUSHJ P,. RETURNS IN A AND B A NEW PROCESS. + +ICR: PUSH P,A + PUSH P,B + MOVEI A,PVLNT ;SETUP CALL TO VECTOR FOR PVP + PUSHJ P,IVECT ;GOBBLE A VECTOR + HRLI C,PVBASE ;SETUP A BLT POINTER + HRRI C,(B) ;GET INTO ADDRESS + BLT C,PVLNT*2-1(B) ;COPY A PROTOTYPE INTO NEW PVP + MOVSI C,400000+SPVP+.VECT. ;SET SPECIAL TYPE + MOVEM C,PVLNT*2(B) ;CLOBBER IT IN + PUSH TP,A ;SAVE THE RESULTS OF VECTOR + PUSH TP,B + + PUSH TP,$TFIX ;GET A UNIFORM VECTOR + POP P,B + PUSH TP,B + MCALL 1,UVECTOR + ADD B,[PDLBUF-2,,-1] ;FUDGE WITH BUFFER + MOVE C,(TP) ;REGOBBLE PROCESS POINTER + MOVEM B,PSTO+1(C) ;STORE IN ALL HOMES + MOVEM B,PBASE+1(C) + + + POP P,A ;PREPARE TO CREATE A TEMPORARY PDL + PUSHJ P,IVECT ;GET THE TEMP PDL + ADD B,[PDLBUF,,0] ;PDL GROWTH HACK + MOVE C,(TP) ;RE-GOBBLE NEW PVP + SUB B,[1,,1] ;FIX FOR STACK + MOVEM B,TPBASE+1(C) + +;SETUP INITIAL BINDING + + PUSH B,$TBIND + MOVEM B,SPBASE+1(C) ;SAVE AS BASE OF SP + MOVEM B,SPSTO+1(C) ;AND CURRENT THEREOF + MOVEM B,CURFCN+1(C) ; AND AS CURRENT FCN FOR SPEC/UNSPEC LOGIC + PUSH B,IMQUOTE THIS-PROCESS + PUSH B,$TPVP ;GIVE IT PROCESS AS VALUE + PUSH B,C + ADD B,[2,,2] ;FINISH FRAME + MOVEM B,TPSTO+1(C) ;MAKE THIS THE CURRENT STACK POINTER + MOVEM C,PVPSTO+1(C) ;SAVE THE NEW PVP ITSELF + AOS A,IDPROC ;GOBBLE A UNIQUE PROCESS I.D. + MOVEM A,PROCID+1(C) ;SAVE THAT ALSO + AOS A,PTIME ; GET A UNIQUE BINDING ID + MOVEM A,BINDID+1(C) + + MOVSI A,TPVP ;CLOBBER THE TYPE + MOVE B,(TP) ;AND POINTER TO PROCESS + SUB TP,[2,,2] + POPJ P, + +;MINI ROUTINE TO CALL VECTOR WITH COUNT IN A + +IVECT: PUSH TP,$TFIX + PUSH TP,A + MCALL 1,VECTOR ;GOBBLE THE VECTOR + POPJ P, + + +;SUBROUTINE TO SWAP A PROCESS IN +;CALLED WITH JSP A,SWAP AND NEW PVP IN B + +SWAP: ;FIRST STORE ALL THE ACS + + MOVE PVP,PVSTOR+1 + MOVE SP,$TSP ; STORE SPSAVE + MOVEM SP,SPSTO(PVP) + MOVE SP,SPSTOR+1 + IRP A,,[SP,AB,TB,TP,P,M,R,FRM] + MOVEM A,A!STO+1(PVP) + TERMIN + + SETOM 1(TP) ; FENCE POST MAIN STACK + MOVEM TP,TPSAV(TB) ; CORRECT FRAME + SETZM PSAV(TB) ; CLEAN UP CURRENT FRAME + SETZM SPSAV(TB) + SETZM PCSAV(TB) + + MOVE E,PVP ;RETURN OLD PROCESS IN E + MOVE PVP,D ;AND MAKE NEW ONE BE D + MOVEM PVP,PVSTOR+1 + +SWAPIN: + ;NOW RESTORE NEW PROCESSES AC'S + + MOVE PVP,PVSTOR+1 + IRP A,,[AB,TB,SP,TP,P,M,R,FRM] + MOVE A,A!STO+1(PVP) + TERMIN + + SETZM SPSTO(PVP) + MOVEM SP,SPSTOR+1 + JRST (C) ;AND RETURN + + + + +;SUBRS ASSOCIATED WITH TYPES + +;TYPE (ITYPE) ARE FUNCTIONS TO RETURN THE ATOMIC NAME OF THE +;TYPE OF A GOODIE. TYPE TAKES ITS ARGS ON AP AND RETURNS IN A AND B. +;ITYPE TAKES ITS ARGS IN A AND B AND RETURNS IN SAME (B=0) FOR INVALID +;TYPECODE. +MFUNCTION TYPE,SUBR + + ENTRY 1 + GETYP A,(AB) ;TYPE INTO A +TYPE1: PUSHJ P,ITYPE ;GO TO INTERNAL + JUMPN B,FINIS ;GOOD RETURN +TYPERR: ERRUUO EQUOTE TYPE-UNDEFINED + +CITYPE: GETYP A,A ; GET TYPE FOR COMPILER CALL +ITYPE: LSH A,1 ;TIMES 2 + HRLS A ;TO BOTH SIDES + ADD A,TYPVEC+1 ;GET ACTUAL LOCATION + JUMPGE A,TYPERR ;LOST, TYPE OUT OF BOUNDS + MOVE B,1(A) ;PICKUP TYPE + HLLZ A,(A) + POPJ P, + +; PREDICATE -- IS OBJECT OF TYPE SPECIFIED + +MFUNCTION %TYPEQ,SUBR,[TYPE?] + + ENTRY + + MOVE D,AB ; GET ARGS + ADD D,[2,,2] + JUMPGE D,TFA + MOVE A,(AB) + HLRE C,D + MOVMS C + ASH C,-1 ; FUDGE + PUSHJ P,ITYPQ ; GO INTERNAL + JFCL + JRST FINIS + +ITYPQ: GETYP A,A ; OBJECT + PUSHJ P,ITYPE +TYPEQ0: SOJL C,CIFALS + GETYP 0,(D) + CAIE 0,TATOM ; Type name must be an atom + JRST WRONGT + CAMN B,1(D) ; Same as the OBJECT? + JRST CPOPJ1 ; Yes, return type name + ADD D,[2,,2] + JRST TYPEQ0 ; No, continue comparing + +CIFALS: MOVEI B,0 + MOVSI A,TFALSE + POPJ P, + +CTYPEQ: SOJE A,CIFALS ; TREAT NO ARGS AS FALSE + MOVEI D,1(A) ; FIND BASE OF ARGS + ASH D,1 + HRLI D,(D) + SUBM TP,D ; D POINTS TO BASE + MOVE E,D ; SAVE FOR TP RESTORE + ADD D,[3,,3] ; FUDGE + MOVEI C,(A) ; NUMBER OF TYPES + MOVE A,-2(D) + PUSHJ P,ITYPQ + JFCL ; IGNORE SKIP FOR NOW + MOVE TP,E ; SET TP BACK + JUMPL B,CPOPJ1 ; SKIP + POPJ P, + +; Entries to get type codes for types for fixing up RSUBRs and assembling + +MFUNCTION %TYPEC,SUBR,[TYPE-C] + + ENTRY + + JUMPGE AB,TFA + GETYP 0,(AB) + CAIE 0,TATOM + JRST WTYP1 + MOVE B,1(AB) + CAMGE AB,[-3,,0] ; skip if only type name given + JRST GTPTYP + MOVE C,IMQUOTE ANY + +TYPEC1: PUSHJ P,CTYPEC ; go to internal + JRST FINIS + +GTPTYP: CAMGE AB,[-5,,0] + JRST TMA + GETYP 0,2(AB) + CAIE 0,TATOM + JRST WTYP2 + MOVE C,3(AB) + JRST TYPEC1 + +CTYPEC: PUSH P,C ; save primtype checker + PUSHJ P,TYPFND ; search type vector + JRST CTPEC2 ; create the poor loser + POP P,B + CAMN B,IMQUOTE ANY + JRST CTPEC1 + CAMN B,IMQUOTE TEMPLATE + JRST TCHK + PUSH P,D + HRRZ A,(A) + ANDI A,SATMSK + PUSH P,A + PUSHJ P,TYPLOO + HRRZ 0,(A) + ANDI 0,SATMSK + CAME 0,(P) + JRST TYPDIF + MOVE D,-1(P) + SUB P,[2,,2] +CTPEC1: MOVEI B,(D) + MOVSI A,TTYPEC + POPJ P, +TCHK: PUSH P,D ; SAVE TYPE + MOVE A,D ; GO TO SAT + PUSHJ P,SAT + CAIG A,NUMSAT ; SKIP IF A TEMPLATE + JRST TYPDIF + POP P,D ; RESTORE TYPE + JRST CTPEC1 + +CTPEC2: POP P,C ; GET BACK PRIMTYPE + SUBM M,(P) + PUSH TP,$TATOM + PUSH TP,B + CAMN C,IMQUOTE ANY + JRST CTPEC3 + PUSH TP,$TATOM + PUSH TP,C + MCALL 2,NEWTYPE ; CREATE THE POOR GUY + MOVE C,IMQUOTE ANY + SUBM M,(P) ; UNRELATIVIZE + JRST CTYPEC + +CTPEC3: HRRZ 0,FSAV(TB) + CAIE 0,%TYPEC + CAIN 0,%TYPEW + JRST TYPERR + + MCALL 1,%TYPEC + JRST MPOPJ + +MFUNCTION %TYPEW,SUBR,[TYPE-W] + + ENTRY + + JUMPGE AB,TFA + GETYP 0,(AB) + CAIE 0,TATOM + JRST WTYP1 + MOVEI D,0 + MOVE C,IMQUOTE ANY + MOVE B,1(AB) + CAMGE AB,[-3,,0] + JRST CTYPW1 + +CTYPW3: PUSHJ P,CTYPEW + JRST FINIS + +CTYPW1: GETYP 0,2(AB) + CAIE 0,TATOM + JRST WTYP2 + CAMGE AB,[-5,,0] ; JUMP IF RH IS GIVEN + JRST CTYPW2 +CTYPW5: MOVE C,3(AB) + JRST CTYPW3 + +CTYPW2: CAMGE AB,[-7,,0] + JRST TMA + GETYP 0,4(AB) + CAIE 0,TFIX + JRST WRONGT + MOVE D,5(AB) + JRST CTYPW5 + +CTYPEW: PUSH P,D + PUSHJ P,CTYPEC ; GET CODE IN B + POP P,B + HRLI B,(D) + MOVSI A,TTYPEW + POPJ P, + +MFUNCTION %VTYPE,SUBR,[VALID-TYPE?] + + ENTRY 1 + + GETYP 0,(AB) + CAIE 0,TATOM + JRST WTYP1 + MOVE B,1(AB) + + PUSHJ P,CVTYPE + JFCL + JRST FINIS + +CVTYPE: PUSHJ P,TYPFND ; LOOK IT UP + JRST PFALS + + MOVEI B,(D) + MOVSI A,TTYPEC + JRST CPOPJ1 + +PFALS: MOVEI B,0 + MOVSI A,TFALSE + POPJ P, + +;PRIMTTYPE RETURNS THE TYPE ATOM OF A PRIMITIVE TYPE IN A CLASS + +STBL: REPEAT NUMSAT,SETZ MQUOTE INTERNAL-TYPE + +LOC STBL + +IRP A,,[[1WORD,WORD],[2WORD,LIST],[NWORD,UVECTOR],[2NWORD,VECTOR],[STORE,STORAGE] +[ARGS,TUPLE],[FRAME,FRAME],[ATOM,ATOM],[LOCID,LOCD],[CHSTR,STRING],[OFFS,OFFSET,1] +[PVP,PROCESS,1],[ASOC,ASOC,1],[LOCA,LOCA],[LOCS,LOCS],[LOCU,LOCU],[LOCV,LOCV] +[LOCL,LOCL],[LOCN,LOCAS],[LOCT,LOCT,1],[LOCR,LOCR],[LOCB,LOCB,1],[BYTE,BYTES,1]] +IRP B,C,[A] +LOC STBL+S!B +IRP X,Y,[C] +IFSE [Y],SETZ IMQUOTE X +IFSN [Y],SETZ MQUOTE X +.ISTOP +TERMIN +.ISTOP + +TERMIN +TERMIN + +LOC STBL+NUMSAT+1 + + +MFUNCTION TYPEPRIM,SUBR + + ENTRY 1 + GETYP A,(AB) + CAIE A,TATOM + JRST NOTATOM + MOVE B,1(AB) + PUSHJ P,CTYPEP + JRST FINIS + +CTYPEP: PUSHJ P,TYPLOO ; CONVERT ATOM TO CODE + HRRZ A,(A) ; SAT TO A + ANDI A,SATMSK + JRST PTYP1 + +MFUNCTION PTSATC,SUBR,[PRIMTYPE-C] + + ENTRY 1 + + GETYP A,(AB) + CAIE A,TATOM + JRST WTYP1 + MOVE B,1(AB) + PUSHJ P,CPRTYC + JRST FINIS + +CPRTYC: PUSHJ P,TYPLOO + MOVE B,(A) + ANDI B,SATMSK + MOVSI A,TSATC + POPJ P, + + +IMFUNCTION PRIMTYPE,SUBR + + ENTRY 1 + + MOVE A,(AB) ;GET TYPE + PUSHJ P,CPTYPE + JRST FINIS + +CPTYPE: GETYP A,A + PUSHJ P,SAT ;GET SAT +PTYP1: JUMPE A,TYPERR + MOVE B,IMQUOTE TEMPLATE + CAIG A,NUMSAT ; IF BIG SAT, THEN TEMPLATE + MOVE B,@STBL(A) + MOVSI A,TATOM + POPJ P, + + +; RSUBR MAKES A VECTOR INTO AN OBJECT OF TYPE RSUBR, ALSO SLIGHTLY MUNGING IT + +IMFUNCTION RSUBR,SUBR + ENTRY 1 + + GETYP A,(AB) + CAIE A,TVEC ; MUST BE VECTOR + JRST WTYP1 + MOVE B,1(AB) ; GET IT + GETYP A,(B) ; CHECK 1ST ELEMENTS TYPE + CAIN A,TPCODE ; PURE CODE + JRST .+3 + CAIE A,TCODE + JRST NRSUBR + HLRM B,(B) ; CLOBEER SPECIAL COUNT FIELD + MOVSI A,TRSUBR + JRST FINIS + +NRSUBR: ERRUUO EQUOTE FIRST-ELEMENT-OF-VECTOR-NOT-CODE + +; ROUTINE TO GENERATE ENTRYY OTHER THAN FIRST TO RSUBRR + +IMFUNCTION MENTRY,SUBR,[RSUBR-ENTRY] + + ENTRY 2 + + GETYP 0,(AB) ; TYPE OF ARG + CAIE 0,TVEC ; BETTER BE VECTOR + JRST WTYP1 + GETYP 0,2(AB) + CAIE 0,TFIX + JRST WTYP2 + MOVE B,1(AB) ; GET VECTOR + CAML B,[-3,,0] + JRST BENTRY + GETYP 0,(B) ; FIRST ELEMENT + CAIE 0,TRSUBR + JRST MENTR1 +MENTR2: GETYP 0,2(B) + CAIE 0,TATOM + JRST BENTRY + MOVE C,3(AB) + HRRM C,2(B) ; OFFSET INTO VECTOR + HLRM B,(B) + MOVSI A,TENTER + JRST FINIS + +MENTR1: CAIE 0,TATOM + JRST BENTRY + MOVE B,1(B) ; GET ATOM + PUSHJ P,IGVAL ; GET VAL + GETYP 0,A + CAIE 0,TRSUBR + JRST BENTRY + MOVE C,1(AB) ; RESTORE B + MOVEM A,(C) + MOVEM B,1(C) + MOVE B,C + JRST MENTR2 + +BENTRY: ERRUUO EQUOTE BAD-VECTOR + +; SUBR TO GET ENTRIES OFFSET + +MFUNCTION LENTRY,SUBR,[ENTRY-LOC] + + ENTRY 1 + + GETYP 0,(AB) + CAIE 0,TENTER + JRST WTYP1 + MOVE B,1(AB) + HRRZ B,2(B) + MOVSI A,TFIX + JRST FINIS + +; RETURN FALSE + +RTFALS: MOVSI A,TFALSE + MOVEI B,0 + POPJ P, + +;SUBROUTINE CALL FOR RSUBRs +RCALL: SUBM M,(P) ;CALCULATE PC's OFFSET IN THE RSUBR + HRLI 0,400000 ; DONT LOSE IN MULTI SEG MODE + + PUSHJ P,@0 ;GO TO THE PROPER SUBROUTINE + SUBM M,(P) ;RECONSTITUTE THE RSUBR's PC + POPJ P, + + + +;CHTYPE TAKES TWO ARGUMENTS. ANY GOODIE AND A AN ATOMIC TYPE NAME +;IT CHECKS THE STORAGE ALLOCATION TYPES OF THE TWO ARE THE SAME AND +;IF THEY ARE CHANGES THE TYPE OF THE FIRST TO THAT NAME D IN THE SECOND + +MFUNCTION CHTYPE,SUBR + + ENTRY 2 + GETYP A,2(AB) ;FIRST CHECK THAT ARG 2 IS AN ATOM + CAIE A,TATOM + JRST NOTATOM + MOVE B,3(AB) ;AND TYPE NAME + PUSHJ P,TYPLOO ;GO LOOKUP TYPE +TFOUND: HRRZ B,(A) ;GOBBLE THE SAT + TRNE B,CHBIT ; SKIP IF CHTYPABLE + JRST CANTCH + TRNE B,TMPLBT ; TEMPLAT + HRLI B,-1 + AND B,[-1,,SATMSK] + GETYP A,(AB) ;NOW GET TYPE TO HACK + PUSHJ P,SAT ;FIND OUT ITS SAT + JUMPE A,TYPERR ;COMPLAIN + CAILE A,NUMSAT + JRST CHTMPL ; JUMP IF TEMPLATE DATA + CAIE A,(B) ;DO THEY AGREE? + JRST TYPDIF ;NO, COMPLAIN +CHTMP1: MOVSI A,(D) ;GET NEW TYPE + HRR A,(AB) ; FOR DEFERRED GOODIES + JUMPL B,CHMATC ; CHECK IT + MOVE B,1(AB) ;AND VALUE + JRST FINIS + +CHTMPL: MOVE E,1(AB) ; GET ARG + HLRZ A,(E) + ANDI A,SATMSK + MOVE 0,3(AB) ; SEE IF TO "TEMPLATE" + CAMN 0,IMQUOTE TEMPLATE + JRST CHTMP1 + TLNN E,-1 ; SKIP IF RESTED + CAIE A,(B) + JRST TYPDIF + JRST CHTMP1 + +CHMATC: PUSH TP,A + PUSH TP,1(AB) ; SAVE GOODIE + MOVSI A,TATOM + MOVE B,3(AB) + MOVSI C,TATOM + MOVE D,IMQUOTE DECL + PUSHJ P,IGET ; FIND THE DECL + PUSH TP,A + PUSH TP,B + MOVE C,(AB) + MOVE D,1(AB) ; NOW GGO TO MATCH + PUSHJ P,TMATCH + JRST CHMAT1 + SUB TP,[2,,2] +CHMAT2: POP TP,B + POP TP,A + JRST FINIS + +CHMAT1: POP TP,B + POP TP,A + MOVE C,-1(TP) + MOVE D,(TP) + PUSHJ P,TMATCH + JRST TMPLVI + JRST CHMAT2 + +TYPLOO: PUSHJ P,TYPFND + ERRUUO EQUOTE BAD-TYPE-NAME + POPJ P, + +TYPFND: HLRE A,B ; FIND DOPE WORDS + SUBM B,A ; A POINTS TO IT + HRRE D,(A) ; TYPE-CODE TO D + JUMPE D,CPOPJ + ANDI D,TYPMSK ; FLUSH FUNNY BITS + MOVEI A,(D) + ASH A,1 + HRLI A,(A) + ADD A,TYPVEC+1 +CPOPJ1: AOS (P) + POPJ P, + + +REPEAT 0,[ + MOVE A,TYPVEC+1 ;GOBBLE DOWN TYPE VECTOR + MOVEI D,0 ;INITIALIZE TYPE COUNTER +TLOOK: CAMN B,1(A) ;CHECK THIS ONE + JRST CPOPJ1 + ADDI D,1 ;BUMP COUNTER + AOBJP A,.+2 ;COUTN DOWN ON VECTOR + AOBJN A,TLOOK + POPJ P, +CPOPJ1: AOS (P) + POPJ P, +] + +TYPDIF: ERRUUO EQUOTE STORAGE-TYPES-DIFFER + + +TMPLVI: ERRUUO EQUOTE DECL-VIOLATION + + +; FUNCTION TO ADD A NEW TYPE TO THE WORLD WITH GIVEN PRIMITIVE TYPE + +MFUNCTION NEWTYPE,SUBR + + ENTRY + + HLRZ 0,AB ; CHEC # OF ARGS + CAILE 0,-4 ; AT LEAST 2 + JRST TFA + CAIGE 0,-6 + JRST TMA ; NOT MORE THAN 3 + GETYP A,(AB) ; GET 1ST ARGS TYPE (SHOULD BE ATOM) + GETYP C,2(AB) ; SAME WITH SECOND + CAIN A,TATOM ; CHECK + CAIE C,TATOM + JRST NOTATOM + + MOVE B,3(AB) ; GET PRIM TYPE NAME + PUSHJ P,TYPLOO ; LOOK IT UP + HRRZ A,(A) ; GOBBLE SAT + ANDI A,SATMSK + HRLI A,TATOM ; MAKE NEW TYPE + PUSH P,A ; AND SAVE + MOVE B,1(AB) ; SEE IF PREV EXISTED + PUSHJ P,TYPFND + JRST NEWTOK ; DID NOT EXIST BEFORE + MOVEI B,2(A) ; FOR POSSIBLE TMPLAT BIT + HRRZ A,(A) ; GET SAT + HRRZ 0,(P) ; AND PROPOSED + ANDI A,SATMSK + ANDI 0,SATMSK + CAIN 0,(A) ; SKIP IF LOSER + JRST NEWTFN ; O.K. + + ERRUUO EQUOTE TYPE-ALREADY-EXISTS + +NEWTOK: POP P,A + MOVE B,1(AB) ; NEWTYPE NAME + PUSHJ P,INSNT ; MUNG IN NEW TYPE + +NEWTFN: CAML AB,[-5,,] ; SKIP IF TEMPLAT SUPPLIED + JRST NEWTF1 + MOVEI 0,TMPLBT ; GET THE BIT + IORM 0,-2(B) ; INTO WORD + MOVE A,(AB) ; GET TYPE NAME + MOVE B,1(AB) + MOVSI C,TATOM + MOVE D,IMQUOTE DECL + PUSH TP,4(AB) ; GET TEMLAT + PUSH TP,5(AB) + PUSHJ P,IPUT +NEWTF1: MOVE A,(AB) + MOVE B,1(AB) ; RETURN NAME + JRST FINIS + +; SET UP GROWTH FIELDS + +IGROWT: SKIPA A,[111100,,(C)] +IGROWB: MOVE A,[001100,,(C)] + HLRE B,C + SUB C,B ; POINT TO DOPE WORD + MOVE B,TYPIC ; INDICATED GROW BLOCK + DPB B,A + POPJ P, + +INSNT: PUSH TP,A + PUSH TP,B ; SAVE NAME OF NEWTYPE + MOVE C,TYPBOT+1 ; CHECK GROWTH NEED + CAMGE C,TYPVEC+1 + JRST ADDIT ; STILL ROOM +GAGN: PUSHJ P,IGROWB ; SETUP BOTTOM GROWTH + SKIPE C,EVATYP+1 + PUSHJ P,IGROWT ; SET UP TOP GROWTH + SKIPE C,APLTYP+1 + PUSHJ P,IGROWT + SKIPE C,PRNTYP+1 + PUSHJ P,IGROWT + MOVE C,[11.,,5] ; SET UP INDICATOR FOR AGC + PUSHJ P,AGC ; GROW THE WORLD + AOJL A,GAGN ; BAD AGC LOSSAGE + MOVE 0,[-101,,-100] + ADDM 0,TYPBOT+1 ; FIX UP POINTER + +ADDIT: MOVE C,TYPVEC+1 + SUB C,[2,,2] ; ALLOCATE ROOM + MOVEM C,TYPVEC+1 + HLRE B,C ; PREPARE TO BLT + SUBM C,B ; C POINTS DOPE WORD END + HRLI C,2(C) ; GET BLT AC READY + BLT C,-3(B) + POP TP,-1(B) ; CLOBBER IT IN + POP TP,-2(B) + HLRE C,TYPVEC+1 ; GET CODE + MOVNS C + ASH C,-1 + SUBI C,1 + MOVE D,-1(B) ; B HAS POINTER TO TYPE VECTOR DOPE WORDS + MOVEI 0,(D) + CAIG 0,HIBOT ; IS ATOM PURE? + JRST ADDNOI ; NO, SO NO HACKING REQUIRED + PUSH P,C + MOVE B,D + PUSHJ P,IMPURIF ; DO IMPURE OF ATOM + MOVE C,TYPVEC+1 + HLRE B,C + SUBM C,B ; RESTORE B + POP P,C + MOVE D,-1(B) ; RESTORE D +ADDNOI: HLRE A,D + SUBM D,A + TLO C,400000 + HRRM C,(A) ; INTO "GROWTH" FIELD + POPJ P, + + +; Interface to interpreter for setting up tables associated with +; template data structures. +; A/ <-name of type>- +; B/ <-length ins>- +; C/ <-uvector of garbage collector code or 0> +; D/ <-uvector of GETTERs>- +; E/ <-uvector of PUTTERs>- + +CTMPLT: SUBM M,(P) ; could possibly gc during this stuff + PUSH TP,$TATOM ; save name of type + PUSH TP,A + PUSH P,B ; save length instr + HLRE A,TD.LNT+1 ; check for template slots left? + HRRZ B,TD.LNT+1 + SUB B,A ; point to dope words + HLRZ B,1(B) ; get real length + ADDI A,-2(B) + JUMPG A,GOODRM ; jump if ok + + PUSH TP,$TUVEC ; save getters and putters + PUSH TP,C + PUSH TP,$TUVEC ; save getters and putters + PUSH TP,D + PUSH TP,$TUVEC + PUSH TP,E + MOVEI A,10-2(B) ; grow it 10 by copying remember d.w. length + PUSH P,A ; save new length + PUSHJ P,CAFRE1 ; get frozen uvector + ADD B,[10,,10] ; rest it down some + HRL C,TD.LNT+1 ; prepare to BLT in + MOVEM B,TD.LNT+1 ; and save as new length vector + HRRI C,(B) ; destination + ADD B,(P) ; final destination address + BLT C,-12(B) + MOVE A,(P) ; length for new getters + PUSHJ P,CAFRE1 + HRL C,TD.GET+1 ; get old for copy + MOVEM B,TD.GET+1 + PUSHJ P,DOBLTS ; go fixup new uvector + MOVE A,(P) ; finally putters + PUSHJ P,CAFRE1 + HRL C,TD.PUT+1 + MOVEM B,TD.PUT+1 + PUSHJ P,DOBLTS ; go fixup new uvector + MOVE A,(P) ; finally putters + PUSHJ P,CAFRE1 + HRL C,TD.AGC+1 + MOVEM B,TD.AGC+1 + PUSHJ P,DOBLTS ; go fixup new uvector + SUB P,[1,,1] ; flush stack craft + MOVE E,(TP) + MOVE D,-2(TP) + MOVE C,-4(TP) ;GET TD.AGC + SUB TP,[6,,6] + +GOODRM: MOVE B,TD.LNT+1 ; move down to fit new guy + SUB B,[1,,1] ; will always win due to prev checks + MOVEM B,TD.LNT+1 + HRLI B,1(B) + HLRE A,TD.LNT+1 + MOVNS A + ADDI A,-1(B) ; A/ final destination + BLT B,-1(A) + POP P,(A) ; new length ins munged in + HLRE A,TD.LNT+1 + MOVNS A ; A/ offset for other guys + PUSH P,A ; save it + ADD A,TD.GET+1 ; point for storing uvs of ins + MOVEM D,-1(A) + MOVE A,(P) + ADD A,TD.PUT+1 + MOVEM E,-1(A) ; store putter also + MOVE A,(P) + ADD A,TD.AGC+1 + MOVEM C,-1(A) ; store putter also + POP P,A ; compute primtype + ADDI A,NUMSAT + PUSH P,A + MOVE B,(TP) ; ready to mung type vector + SUB TP,[2,,2] + PUSHJ P,TYPFND ; CHECK TO SEE WHETHER TEMPLATE EXISTS + JRST NOTEM + POP P,C ; GET SAT + HRRM C,(A) + JRST MPOPJ +NOTEM: POP P,A ; RESTORE SAT + HRLI A,TATOM ; GET TYPE + PUSHJ P,INSNT ; INSERT INTO VECTOR + JRST MPOPJ + +; this routine copies GET and PUT vectors into new ones + +DOBLTS: HRRI C,(B) + ADD B,-1(P) + BLT C,-11(B) ; zap those guys in + MOVEI A,TUVEC ; mung in uniform type + PUTYP A,(B) + MOVEI C,-7(B) ; zero out remainder of uvector + HRLI C,-10(B) + SETZM -1(C) + BLT C,-1(B) + POPJ P, + + +; FUNCTIONS TO SET UP EVALUATION AND APPLICATION RULES FOR DATA TYPES + +MFUNCTION EVALTYPE,SUBR + + ENTRY + + PUSHJ P,CHKARG ; VERIFY WINNAGE IN ARGS + MOVEI A,EVATYP ; POINT TO TABLE + MOVEI E,EVTYPE ; POINT TO PURE VERSION + MOVEI 0,EVAL +TBLCAL: PUSHJ P,TBLSET ; SETUP TABLE ENTRY + JRST FINIS + +MFUNCTION APPLYTYPE,SUBR + + ENTRY + + PUSHJ P,CHKARG + MOVEI A,APLTYP ; POINT TO APPLY TABLE + MOVEI E,APTYPE ; PURE TABLE + MOVEI 0,APPLY + JRST TBLCAL + + +MFUNCTION PRINTTYPE,SUBR + + ENTRY + + PUSHJ P,CHKARG + MOVEI A,PRNTYP ; POINT TO APPLY TABLE + MOVEI E,PRTYPE ; PURE TABLE + MOVEI 0,PRINT + JRST TBLCAL + +; CHECK ARGS AND SETUP FOR TABLE HACKER + +CHKARG: JUMPGE AB,TFA + CAMGE AB,[-5,,] + JRST TMA + GETYP A,(AB) ; 1ST MUST BE TYPE NAME + CAIE A,TATOM + JRST WTYP1 + MOVE B,1(AB) ; GET ATOM + PUSHJ P,TYPLOO ; VERIFY THAT IT IS A TYPE + PUSH P,D ; SAVE TYPE NO. + MOVEI D,-1 ; INDICATE FUNNYNESS + CAML AB,[-3,,] ; SKIP IF 2 OR MORE + JRST TY1AR + HRRZ A,(A) ; GET SAT + ANDI A,SATMSK + PUSH P,A + GETYP A,2(AB) ; GET 2D TYPE + CAIE A,TATOM ; EITHER TYPE OR APPLICABLE + JRST TRYAPL ; TRY APPLICABLE + MOVE B,3(AB) ; VERIFY IT IS A TYPE + PUSHJ P,TYPLOO + HRRZ A,(A) ; GET SAT + ANDI A,SATMSK + POP P,C ; RESTORE SAVED SAT + CAIE A,(C) ; SKIP IF A WINNER + JRST TYPDIF ; REPORT ERROR +TY1AR: POP P,C ; GET SAVED TYPE + MOVEI B,0 ; TELL THAT WE ARE A TYPE + POPJ P, + +TRYAPL: PUSHJ P,APLQ ; IS THIS APPLICABLE + JRST NAPT + SUB P,[1,,1] + MOVE B,2(AB) ; RETURN SAME + MOVE D,3(AB) + POP P,C + POPJ P, + + +; HERE TO PUT ENTRY IN APPROPRIATE TABLE + +TBLSET: PUSH TP,B + PUSH TP,D ; SAVE VALUE + PUSH TP,$TFIX + PUSH TP,A + PUSH P,C ; SAVE TYPE BEING HACKED + PUSH P,E + SKIPE B,1(A) ; SKIP IF VECTOR DOESN'T EXIST YET + JRST TBL.OK + MOVE B,-2(TP) ; CHECK FOR RETURN IT HACK + SKIPN -3(TP) + CAIE B,-1 + JRST .+2 + JRST RETPM2 + HLRE A,TYPBOT+1 ; GET CURRENT TABLE LNTH + MOVNS A + ASH A,-1 + PUSH P,0 + PUSHJ P,IVECT ; GET VECTOR + POP P,0 + MOVE C,(TP) ; POINT TO RETURN POINT + MOVEM B,1(C) ; SAVE VECTOR + +TBL.OK: POP P,E + POP P,C ; RESTORE TYPE + SUB TP,[2,,2] + POP TP,D + POP TP,A + JUMPN A,TBLOK1 ; JUMP IF FUNCTION ETC. SUPPLIED + CAIN D,-1 + JRST TBLOK1 + CAILE D,NUMPRI ; SKIP IF ORIGINAL TYPE + MOVNI E,(D) ; CAUSE E TO ENDUP 0 + ADDI E,(D) ; POINT TO PURE SLOT +TBLOK1: ADDI C,(C) ; POINT TO VECTOR SLOT + ADDI C,(B) + CAIN D,-1 + JRST RETCUR + JUMPN A,OK.SET ; OK TO CLOBBER + ADDI B,(D) ; POINT TO TARGET TYPE'S SLOT + ADDI B,(D) ; POINT TO TARGET TYPE'S SLOT + SKIPN A,(B) ; SKIP IF WINNER + SKIPE 1(B) ; SKIP IF LOSER + SKIPA D,1(B) ; SETUP D + JRST CH.PTB ; CHECK PURE TABLE + +OK.SET: CAIN 0,(D) ; SKIP ON RESET + SETZB A,D + MOVEM A,(C) ; STORE + MOVEM D,1(C) +RETAR1: MOVE A,(AB) ; RET TYPE + MOVE B,1(AB) + JRST FINIS + +CH.PTB: MOVEI A,0 + MOVE D,[SETZ NAPT] + JUMPE E,OK.SET + MOVE D,(E) + JRST OK.SET + +RETPM2: SUB TP,[4,,4] + SUB P,[2,,2] + ASH C,1 + SOJA E,RETPM4 + +RETCUR: SKIPN A,(C) + SKIPE 1(C) + SKIPA B,1(C) + JRST RETPRM + + JUMPN A,CPOPJ +RETPM1: MOVEI A,0 + JUMPL B,RTFALS + CAMN B,1(E) + JRST .+3 + ADDI A,2 + AOJA E,.-3 + +RETPM3: ADD A,TYPVEC+1 + MOVE B,3(A) + MOVE A,2(A) + POPJ P, + +RETPRM: SUBI C,(B) ; UNDO BADNESS +RETPM4: CAIG C,NUMPRI*2 + SKIPG 1(E) + JRST RTFALS + + MOVEI A,-2(C) + JRST RETPM3 + +CALLTY: MOVE A,TYPVEC + MOVE B,TYPVEC+1 + POPJ P, + +MFUNCTION ALLTYPES,SUBR + + ENTRY 0 + + MOVE A,TYPVEC + MOVE B,TYPVEC+1 + JRST FINIS + +; + +;FUNCTION TO RETURN TYPE OF ELEMENTS IN A UVECTOR + +MFUNCTION UTYPE,SUBR + + ENTRY 1 + + GETYP A,(AB) ;GET U VECTOR + PUSHJ P,SAT + CAIE A,SNWORD + JRST WTYP1 + MOVE B,1(AB) ; GET UVECTOR + PUSHJ P,CUTYPE + JRST FINIS + +CUTYPE: HLRE A,B ;GET -LENGTH + HRRZS B + SUB B,A ;POINT TO TYPE WORD + GETYP A,(B) + JRST ITYPE ; GET NAME OF TYPE + +; FUNCTION TO CHANGE UNIFORM TYPE OF A VECTOR + +MFUNCTION CHUTYPE,SUBR + + ENTRY 2 + + GETYP A,2(AB) ;GET 2D TYPE + CAIE A,TATOM + JRST NOTATO + GETYP A,(AB) ; CALL WITH UVECTOR? + PUSHJ P,SAT + CAIE A,SNWORD + JRST WTYP1 + MOVE A,1(AB) ; GET UV POINTER + MOVE B,3(AB) ;GET ATOM + PUSHJ P,CCHUTY + MOVE A,(AB) ; RETURN UVECTOR + MOVE B,1(AB) + JRST FINIS + +CCHUTY: PUSH TP,$TUVEC + PUSH TP,A + PUSHJ P,TYPLOO ;LOOK IT UP + HRRZ B,(A) ;GET SAT + TRNE B,CHBIT + JRST CANTCH + ANDI B,SATMSK + SKIPGE MKTBS(B) + JRST CANTCH + HLRE C,(TP) ;-LENGTH + HRRZ E,(TP) + SUB E,C ;POINT TO TYPE + GETYP A,(E) ;GET TYPE + JUMPE A,WIN0 ;ALLOW TYPE "LOSE" TO CHANGE TO ANYTHING + PUSHJ P,SAT ;GET SAT + JUMPE A,TYPERR + CAIE A,(B) ;COMPARE + JRST TYPDIF +WIN0: ADDI D,.VECT. + HRLM D,(E) ;CLOBBER NEW ONE + POP TP,B + POP TP,A + POPJ P, + +CANTCH: PUSH TP,$TATOM + PUSH TP,EQUOTE CANT-CHTYPE-INTO + PUSH TP,2(AB) + PUSH TP,3(AB) + MOVEI A,2 + JRST CALER + +NOTATOM: + PUSH TP,$TATOM + PUSH TP,EQUOTE NON-ATOMIC-ARGUMENT + PUSH TP,(AB) + PUSH TP,1(AB) + MOVEI A,2 + JRST CALER + + + +; SUBROUTINE TO LEAVE MUDDLE CLOSING ALL CHANNELS ON THE WAY + +MFUNCTION QUIT,SUBR + + ENTRY 0 + + + PUSHJ P,CLOSAL ; DO THE CLOSES + PUSHJ P,%KILLM + JRST IFALSE ; JUST IN CASE + +CLOSAL: MOVEI B,CHNL0+2 ; POINT TO 1ST (NOT INCLUDING TTY I/O) + MOVE PVP,PVSTOR+1 + MOVE TVP,REALTV+1(PVP) + SUBI B,(TVP) + HRLS B + ADD B,TVP + PUSH TP,$TVEC + PUSH TP,B + PUSH P,[N.CHNS-1] ; MAX NO. OF CHANS + +CLOSA1: MOVE B,(TP) + ADD B,[2,,2] + MOVEM B,(TP) + HLLZS -2(B) + SKIPN C,-1(B) ; THIS ONE OPEN? + JRST CLOSA4 ; NO + CAME C,TTICHN+1 + CAMN C,TTOCHN+1 + JRST CLOSA4 + PUSH TP,-2(B) ; PUSH IT + PUSH TP,-1(B) + MCALL 1,FCLOSE ; CLOSE IT +CLOSA4: SOSLE (P) ; COUNT DOWN + JRST CLOSA1 + + + SUB TP,[2,,2] + SUB P,[1,,1] + +CLOSA3: SKIPN B,CHNL0+1 + POPJ P, + PUSH TP,(B) + HLLZS (TP) + PUSH TP,1(B) + HRRZ B,(B) + MOVEM B,CHNL0+1 + MCALL 1,FCLOSE + JRST CLOSA3 + + +IMPURE + +WHOAMI: 0 ; SYAYS WHETHER I AM REALLY A MUDDLE OR SOME HACK + + +;GARBAGE COLLECTORS PDLS + + +GCPDL: -GCPLNT,,GCPDL + + BLOCK GCPLNT + + +PURE + +MUDSTR: ASCII /MUDDLE / +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 + \ No newline at end of file diff --git a//mappur.bin.34 b//mappur.bin.34 new file mode 100644 index 0000000..7545199 Binary files /dev/null and b//mappur.bin.34 differ diff --git a//mappur.bin.37 b//mappur.bin.37 new file mode 100644 index 0000000..126d514 Binary files /dev/null and b//mappur.bin.37 differ diff --git a//mappur.mid.146 b//mappur.mid.146 new file mode 100644 index 0000000..3d0015e --- /dev/null +++ b//mappur.mid.146 @@ -0,0 +1,1928 @@ + +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># ; 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, +] + + ; 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 ,, + 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,_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 +] + + ; 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 + + ; 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 +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:FIXUP.FILE/ +SAVSTR: ASCIZ /PS:SAV.FILE/ +TFXSTR: ASCIZ /DSK:FIXUP.FILE/ +TSAVST: ASCIZ /DSK: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,[[,IMSK],[,IMSK],[MOVE,AIMSK] + [,AIMSK],[,IMSK] + [,AIMSK],[MOVEI,AIMSK]] + +FOO OINS2,OLN2,OMSK2,[[,IMSK],[,IMSK],[,AIMSK] + [MOVE,AIMSK],[,AIMSK],[,IMSK] + [,AIMSK],[MOVEI,AIMSK]] + +FOO LINS,LLN,LMSK,[[,AIMSK],[,AIMSK],[,IMSK] + [,<-1,,777760>]] + +] +IMPURE + +SAVSNM: 0 ; SAVED SNAME +INPLOD: 0 ; FLAG SAYING WE ARE IN MAPPUR + +IFE ITS,[ +MAPJFN: 0 ; JFN OF SAV FILE +DIRCHN: 0 ; JFN USED BY GETDIR +] + +PURE + +END + diff --git a//mappur.mid.159 b//mappur.mid.159 new file mode 100644 index 0000000..4f64307 --- /dev/null +++ b//mappur.mid.159 @@ -0,0 +1,1972 @@ + +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># ; 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, +] + + ; 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 ,, + 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,_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 +] + + ; 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 + + ; 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 +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:FIXUP.FILE/ +SAVSTR: ASCIZ /PS:SAV.FILE/ +TFXSTR: ASCIZ /DSK:FIXUP.FILE/ +TSAVST: ASCIZ /DSK: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,[[,IMSK],[,IMSK],[MOVE,AIMSK] + [,AIMSK],[,IMSK] + [,AIMSK],[MOVEI,AIMSK]] + +FOO OINS3,OLN3,OMSK3,[[,IMSK],[,IMSK],[MOVE,AIMSK] + [,IMSK],[MOVEI,AIMSK]] + +FOO OINS2,OLN2,OMSK2,[[,IMSK],[,IMSK],[,AIMSK] + [MOVE,AIMSK],[,AIMSK],[,IMSK] + [,AIMSK],[MOVEI,AIMSK]] + +FOO OINS4,OLN4,OMSK4,[[,IMSK],[,IMSK],[,AIMSK] + [MOVE,AIMSK],[,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,[[,AIMSK],[,AIMSK],[,IMSK] + [,<-1,,777760>]] + +] +IMPURE + +SAVSNM: 0 ; SAVED SNAME +INPLOD: 0 ; FLAG SAYING WE ARE IN MAPPUR + +IFE ITS,[ +MAPJFN: 0 ; JFN OF SAV FILE +DIRCHN: 0 ; JFN USED BY GETDIR +] + +PURE + +END + diff --git a//mappur.mid.160 b//mappur.mid.160 new file mode 100644 index 0000000..ceabb2c --- /dev/null +++ b//mappur.mid.160 @@ -0,0 +1,1974 @@ + +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># ; 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, +] + + ; 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 ,, + 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,_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 +] + + ; 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 + + ; 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 +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:FIXUP.FILE/ +SAVSTR: ASCIZ /PS:SAV.FILE/ +TFXSTR: ASCIZ /DSK:FIXUP.FILE/ +TSAVST: ASCIZ /DSK: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,[[,IMSK],[,IMSK],[MOVE,AIMSK] + [,AIMSK],[,IMSK] + [,AIMSK],[MOVEI,AIMSK]] + +FOO OINS3,OLN3,OMSK3,[[,IMSK],[,IMSK],[MOVE,AIMSK] + [,IMSK],[MOVEI,AIMSK]] + +FOO OINS2,OLN2,OMSK2,[[,IMSK],[,IMSK],[,AIMSK] + [MOVE,AIMSK],[,AIMSK],[,IMSK] + [,AIMSK],[MOVEI,AIMSK]] + +FOO OINS4,OLN4,OMSK4,[[,IMSK],[,IMSK],[,AIMSK] + [MOVE,AIMSK],[,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,[[,AIMSK],[,AIMSK],[,IMSK] + [,<-1,,777760>]] + +] +IMPURE + +SAVSNM: 0 ; SAVED SNAME +INPLOD: 0 ; FLAG SAYING WE ARE IN MAPPUR + +IFE ITS,[ +MAPJFN: 0 ; JFN OF SAV FILE +DIRCHN: 0 ; JFN USED BY GETDIR +] + +PURE + +END + diff --git a//mappur.mid.161 b//mappur.mid.161 new file mode 100644 index 0000000..b261d53 --- /dev/null +++ b//mappur.mid.161 @@ -0,0 +1,1975 @@ + +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># ; 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, +] + + ; 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 ,, + 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,_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 +] + + ; 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 + + ; 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 +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:FIXUP.FILE/ +SAVSTR: ASCIZ /PS:SAV.FILE/ +TFXSTR: ASCIZ /DSK:FIXUP.FILE/ +TSAVST: ASCIZ /DSK: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,[[,IMSK],[,IMSK],[MOVE,AIMSK] + [,AIMSK],[,IMSK] + [,AIMSK],[MOVEI,AIMSK]] + +FOO OINS3,OLN3,OMSK3,[[,IMSK],[,IMSK],[MOVE,AIMSK] + [,IMSK],[MOVEI,AIMSK]] + +FOO OINS2,OLN2,OMSK2,[[,IMSK],[,IMSK],[,AIMSK] + [MOVE,AIMSK],[,AIMSK],[,IMSK] + [,AIMSK],[MOVEI,AIMSK]] + +FOO OINS4,OLN4,OMSK4,[[,IMSK],[,IMSK],[,AIMSK] + [MOVE,AIMSK],[,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,[[,AIMSK],[,AIMSK],[,IMSK] + [,<-1,,777760>]] + +] +IMPURE + +SAVSNM: 0 ; SAVED SNAME +INPLOD: 0 ; FLAG SAYING WE ARE IN MAPPUR + +IFE ITS,[ +MAPJFN: 0 ; JFN OF SAV FILE +DIRCHN: 0 ; JFN USED BY GETDIR +] + +PURE + +END + diff --git a//mappur.mid.162 b//mappur.mid.162 new file mode 100644 index 0000000..416f6e8 --- /dev/null +++ b//mappur.mid.162 @@ -0,0 +1,1986 @@ + +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># ; 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, +] + + ; 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 ,, + 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,_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 +] + + ; 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 + + ; 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 +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:FIXUP.FILE/ +SAVSTR: ASCIZ /PS:SAV.FILE/ +TFXSTR: ASCIZ /DSK:FIXUP.FILE/ +TSAVST: ASCIZ /DSK: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,[[,IMSK],[,IMSK],[MOVE,AIMSK] + [,AIMSK],[,IMSK] + [,AIMSK],[MOVEI,AIMSK]] + +FOO OINS3,OLN3,OMSK3,[[,IMSK],[,IMSK],[MOVE,AIMSK] + [,IMSK],[MOVEI,AIMSK]] + +FOO OINS2,OLN2,OMSK2,[[,IMSK],[,IMSK],[,AIMSK] + [MOVE,AIMSK],[,AIMSK],[,IMSK] + [,AIMSK],[MOVEI,AIMSK]] + +FOO OINS4,OLN4,OMSK4,[[,IMSK],[,IMSK],[,AIMSK] + [MOVE,AIMSK],[,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,[[,AIMSK],[,AIMSK],[,IMSK] + [,<-1,,777760>]] + +] +IMPURE + +SAVSNM: 0 ; SAVED SNAME +INPLOD: 0 ; FLAG SAYING WE ARE IN MAPPUR + +IFE ITS,[ +MAPJFN: 0 ; JFN OF SAV FILE +DIRCHN: 0 ; JFN USED BY GETDIR +] + +PURE + +END + diff --git a//maps.bin.2 b//maps.bin.2 new file mode 100644 index 0000000..3a7b0d0 Binary files /dev/null and b//maps.bin.2 differ diff --git a//maps.mid.29 b//maps.mid.29 new file mode 100644 index 0000000..4c0cbf2 --- /dev/null +++ b//maps.mid.29 @@ -0,0 +1,247 @@ + +TITLE MAPS -- MAP FUNCTIONS FOR MUDDLE + +RELOCATABLE + +.INSRT MUDDLE > + +.GLOBAL TYPSEG,NXTLM,NAPT,APLQ,INCR1,SPECBI,FRMSTK,MAPPLY +.GLOBAL CHFSWP,SSPEC1,ILVAL,CHUNW,DSTORE,PVSTOR,TVSTOR + +; PSTACK OFFSETS + +INCNT==0 ; INNER LOOP COUNT +LISTNO==-1 ; ARG NUMBER BEING HACKED +ARGCNT==-2 ; FINAL ARG COUNTER +NARGS==-3 ; NUMBER OF STRUCTURES +NTHRST==-4 ; 0=> MAP REST, OTHERWISE MAP FIRST + +; MAP THE "CAR" OF EACH LIST + +IMFUNCTION MAPF,SUBR + + PUSH P,. ; PUSH NON-ZERO + JRST MAP1 + +; MAP THE "CDR" OF EACH LIST + +IMFUNCTION MAPR,SUBR + + PUSH P,[0] + +MAP1: ENTRY + HLRE C,AB ; HOW MANY ARGS + ASH C,-1 ; TO # OF PAIRS + ADDI C,2 ; AT LEAST 3 + JUMPG C,TFA ; NOT ENOUGH + GETYP A,(AB) ; TYPE OF CONSTRUCTOR + CAIN A,TFALSE ; ANY CONSING NEEDE? + JRST MAP2 ; NO, SKIP CHECK + PUSHJ P,APLQ ; CHECK IF APPLICABLE + JRST NAPT ; NO, ERROR +MAP2: MOVNS C ; POS NO. OF ARGS (-3) + PUSH P,C ; SAVE IT + PUSH TP,[TATOM,,-1] ; ALL **GFP** INSTRUCTIONS ARE TO DO WITH MAPRET + PUSH TP,IMQUOTE LMAP,[LMAP ]INTRUP + PUSHJ P,FRMSTK ; **GFP** + PUSH TP,[0] ; **GFP** + PUSH TP,[0] ; **GFP** + PUSHJ P,SPECBIND ; **GFP** + MOVE C,(P) ; RESTORE COUNT OF ARGS + MOVE A,AB ; COPY ARG POINTER + MOVSI 0,TAB ; CLOBBER A'S TYPE + MOVE PVP,PVSTOR+1 + MOVEM 0,ASTO(PVP) + JUMPE C,ARGSDN ; NOA ARGS? + +ARGLP: INTGO ; STACK MAY OVERFLOW + PUSH TP,4(A) ; SKIP FCNS + PUSH TP,5(A) + ADD A,[2,,2] + SOJG C,ARGLP ; ALL UP ON STACK + +; ALL STRUCTURES ARE ON THE STACK, NOW PUSH THE CONSTRUCTOR + +ARGSDN: PUSH TP,(AB) ; CONSTRUCTOR + PUSH TP,1(AB) + MOVE PVP,PVSTOR+1 + SETZM ASTO(PVP) + PUSH P,[-1] ; FUNNY TEMPS + PUSH P,[0] + PUSH P,[0] + +; OUTER LOOP CDRING EACH STRUCTURE + +OUTRLP: SETZM LISTNO(P) ; START AT 0TH LIST + MOVE 0,NARGS(P) ; TOTAL # OF STRUCS + MOVEM 0,INCNT(P) ; AS COUNTER IN INNER LOOP + PUSH TP,2(AB) ; PUSH THE APPLIER + PUSH TP,3(AB) + +; INNER LOOP, CONS UP EACH APPLICATION + +INRLP: INTGO + SOSGE INCNT(P) + JRST INRLP2 + MOVEI E,2 ; READY TO BUMP LISTNO + ADDB E,LISTNO(P) ; CURRENT STORED AND IN C + ADDI E,(TB)4 ; POINT TO A STRUCTURE + MOVE A,(E) ; PICK IT UP + MOVE B,1(E) ; AND VAL + PUSHJ P,TYPSEG ; SETUP TO REST IT ETC. + MOVE E,LISTNO(P) + ADDI E,4(TB) + SKIPL ARGCNT(P) ; DONT INCR THE 1ST TIME + XCT INCR1(C) ; INCREMENT THE LOSER + MOVE 0,DSTORE ; UPDATE THE LIST + MOVEM 0,(E) + MOVEM D,1(E) ; CLOBBER AWAY + PUSH TP,DSTORE ; FOR REST CASE + PUSH TP,D + PUSHJ P,NXTLM ; SKIP IF GOT ONE, ELSE DONT + JRST DONEIT ; FINISHED + SETZM DSTORE + SKIPN NTHRST(P) ; SKIP IF MAP REST + JRST INRLP1 + MOVEM A,-1(TP) ; IUSE AS ARG + MOVEM B,(TP) +INRLP1: JRST INRLP ; MORE, GO DO THEM + + +; ALL ARGS PUSHED, APPLY USER FCN + +INRLP2: SKIPGE ARGCNT(P) ; UN NEGATE ARGCNT + SETZM ARGCNT(P) + MOVE A,NARGS(P) ; GET # OF ARGS + ADDI A,1 + ACALL A,MAPPLY ; APPLY THE BAG BITER + + GETYP 0,(AB) ; GET TYPE OF CONSTRUCTOR + CAIN 0,TFALSE ; SKIP IF ONE IS THERE + JRST OUTRL1 + PUSH TP,A + PUSH TP,B + AOS ARGCNT(P) + JRST OUTRLP + +OUTRL1: MOVEM A,-1(TP) ; SAVE PARTIAL VALUE + MOVEM B,(TP) + JRST OUTRLP + +; HERE IF ALL FINISHED + +DONEIT: HRLS C,LISTNO(P) ; HOW MANY DONE + SUB TP,[2,,2] ; FLUSH SAVED VAL + SUB TP,C ; FLUSH TUPLE OF CRUFT +DONEI1: SKIPGE ARGCNT(P) + SETZM ARGCNT(P) ; IN CASE STILL NEGATIVE + SETZM DSTORE ; UNSCREW + GETYP 0,(AB) ; ANY CONSTRUCTOR + CAIN 0,TFALSE + JRST MFINIS ; NO, LEAVE + AOS D,ARGCNT(P) ; IF NO ARGS + ACALL D,APPLY ; APPLY IT + + JRST FINIS + +; HERE TO FINISH IF CONSTRUCTOR WAS #FALSE () + +MFINIS: POP TP,B + POP TP,A + JRST FINIS + +; **GFP** FROM HERE TO THE END + +MFUNCTION MAPLEAVE,SUBR + + ENTRY + + CAMGE AB,[-3,,0] + JRST TMA + MOVE B,IMQUOTE LMAP,[LMAP ]INTRUP + PUSHJ P,ILVAL + GETYP 0,A + CAIE 0,TFRAME ; MAKE SURE WINNER + JRST NOTM + PUSH TP,A + PUSH TP,B + MOVEI B,-1(TP) ; POINT TO FRAME POINTER + PUSHJ P,CHFSWP + PUSHJ P,CHUNW + JUMPL C,MAPL1 ; RET VAL SUPPLIED + MOVSI A,TATOM + MOVE B,IMQUOTE T + JRST FINIS + +MAPL1: MOVE A,(C) + MOVE B,1(C) + JRST FINIS + +MFUNCTION MAPSTOP,SUBR + + ENTRY + + PUSH P,[1] + JRST MAPREC + +MFUNCTION MAPRET,SUBR + + ENTRY + + PUSH P,[0] +MAPREC: MOVE B,IMQUOTE LMAP,[LMAP ]INTRUP + PUSHJ P,ILVAL ; GET VALUE + GETYP 0,A ; FRAME? + CAIE 0,TFRAME + JRST NOTM + PUSH TP,A + PUSH TP,B + MOVEI B,-1(TP) + POP P,0 ; RET/STOP SWITCH + JUMPN 0,MAPRC1 ; JUMP IF STOP + PUSHJ P,CHFSWP ; CHECK IT OUT (AND MAYBE SWAP) + PUSH P,[NLOCR] + JRST MAPRC2 +MAPRC1: PUSHJ P,CHFSWP + PUSH P,[NLOCR1] +MAPRC2: HRRZ E,SPSAV(B) ; UNBIND BEFORE RETURN + PUSH TP,$TAB + PUSH TP,C + ADDI E,1 ; FUDGE FOR UNBINDER + PUSHJ P,SSPEC1 ; UNBINDER + HLRE D,(TP) ; FIND NUMBER + JUMPE D,MAPRE1 ; SKIP IF NONE TO MOVE + MOVNS E,D ; AND PLUS IT + HRLI E,(E) ; COMPUTE NEW TP + ADD E,TPSAV(B) ; NEW TP + HRRZ C,TPSAV(B) ; GET OLD TOP + MOVEM E,TPSAV(B) + HRL C,(TP) ; AND NEW BOT + ADDI C,1 + BLT C,(E) ; BRING IT ALL DOWN +MAPRE1: ASH D,-1 ; NO OF ARGS + HRRI TB,(B) ; PREPARE TO FINIS + MOVSI A,TFIX + MOVEI B,(D) + POP P,0 ; GET PC TO GO TO + MOVEM 0,PCSAV(TB) + JRST CONTIN ; BACK TO MAPPER + +NLOCR1: TDZA A,A ; ZER SW +NLOCR: MOVEI A,1 + GETYP 0,(AB) ; CHECK IF BUILDING + CAIN 0,TFALSE + JRST FLUSHM ; REMOVE GOODIES + ADDM B,ARGCNT(P) ; BUMP ARG COUNTER +NLOCR2: JUMPE A,DONEI1 + JRST OUTRLP + +FLUSHM: ASH B,1 ; FLUSH GOODIES DROPPED + HRLI B,(B) + SUB TP,B + JRST NLOCR2 + +NOTM: ERRUUO EQUOTE NOT-IN-MAP-FUNCTION + +END +  \ No newline at end of file diff --git a//mdl106.agc.1 b//mdl106.agc.1 new file mode 100644 index 0000000..4602c83 Binary files /dev/null and b//mdl106.agc.1 differ diff --git a//mdl106.agc.2 b//mdl106.agc.2 new file mode 100644 index 0000000..4602c83 Binary files /dev/null and b//mdl106.agc.2 differ diff --git a//mdl106.dec.1 b//mdl106.dec.1 new file mode 100644 index 0000000..1912f48 Binary files /dev/null and b//mdl106.dec.1 differ diff --git a//mdl106.dec.2 b//mdl106.dec.2 new file mode 100644 index 0000000..1912f48 Binary files /dev/null and b//mdl106.dec.2 differ diff --git a//mdl106.exe.2 b//mdl106.exe.2 new file mode 100644 index 0000000..925e0f7 Binary files /dev/null and b//mdl106.exe.2 differ diff --git a//mdl106.exe.3 b//mdl106.exe.3 new file mode 100644 index 0000000..3ea6215 Binary files /dev/null and b//mdl106.exe.3 differ diff --git a//mdl106.exe.4 b//mdl106.exe.4 new file mode 100644 index 0000000..925e0f7 Binary files /dev/null and b//mdl106.exe.4 differ diff --git a//mdl106.exe.5 b//mdl106.exe.5 new file mode 100644 index 0000000..98fcfca Binary files /dev/null and b//mdl106.exe.5 differ diff --git a//mdl106.sec.1 b//mdl106.sec.1 new file mode 100644 index 0000000..a6761ca Binary files /dev/null and b//mdl106.sec.1 differ diff --git a//mdl106.sec.2 b//mdl106.sec.2 new file mode 100644 index 0000000..a6761ca Binary files /dev/null and b//mdl106.sec.2 differ diff --git a//mdl106.sgc.1 b//mdl106.sgc.1 new file mode 100644 index 0000000..4823a5a Binary files /dev/null and b//mdl106.sgc.1 differ diff --git a//mdl106.sgc.2 b//mdl106.sgc.2 new file mode 100644 index 0000000..4823a5a Binary files /dev/null and b//mdl106.sgc.2 differ diff --git a//mdl106.symbols.1 b//mdl106.symbols.1 new file mode 100644 index 0000000..fcb50d0 Binary files /dev/null and b//mdl106.symbols.1 differ diff --git a//mdl106.symbols.2 b//mdl106.symbols.2 new file mode 100644 index 0000000..fcb50d0 Binary files /dev/null and b//mdl106.symbols.2 differ diff --git a//mdlxxx.exe.1 b//mdlxxx.exe.1 new file mode 100644 index 0000000..c9715c6 Binary files /dev/null and b//mdlxxx.exe.1 differ diff --git a//mdlxxx.exe.2 b//mdlxxx.exe.2 new file mode 100644 index 0000000..189ec4d Binary files /dev/null and b//mdlxxx.exe.2 differ diff --git a//mdlxxx.symbols.1 b//mdlxxx.symbols.1 new file mode 100644 index 0000000..e47d5ed Binary files /dev/null and b//mdlxxx.symbols.1 differ diff --git a//midas.bin.3 b//midas.bin.3 new file mode 100644 index 0000000..e69de29 diff --git a//midas.exe.5 b//midas.exe.5 new file mode 100644 index 0000000..174b1c8 Binary files /dev/null and b//midas.exe.5 differ diff --git a//midas.symbols.2 b//midas.symbols.2 new file mode 100644 index 0000000..c75bbf9 Binary files /dev/null and b//midas.symbols.2 differ diff --git a//mud105.stink.10 b//mud105.stink.10 new file mode 100644 index 0000000..d9ea6eb --- /dev/null +++ b//mud105.stink.10 @@ -0,0 +1,35 @@ +MPURE.BINL +MSPECS.BINL +MCONST.BINL +MLDGC.BINL +MUTILIT.BINL +MUUOH.BINL +MMUDEX.BINL +MMAPPUR.BINL +MCORE.BINL +MATOMHK.BINL +MINTERR.BINL +MNFREE.BINL +MGCHACK.BINL +MREADCH.BINL +MAGCMRK.BINL +MREADER.BINL +MPRINT.BINL +MBUFMOD.BINL +MARITH.BINL +MMAPS.BINL +MPRIMIT.BINL +MSTBUIL.BINL +MEVAL.BINL +MDECL.BINL +MMAIN.BINL +MMUDSQU.BINL +MFOPEN.BINL +MPUTGET.BINL +MCREATE.BINL +MSAVE.BINL +MAGC.BINL +MAMSGC.BINL +MSECAGC.BINL +MINITM.BINL? + \ No newline at end of file diff --git a//muddle.mid.346 b//muddle.mid.346 new file mode 100644 index 0000000..b52d7f6 --- /dev/null +++ b//muddle.mid.346 @@ -0,0 +1,1254 @@ +; 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 -- FOR NORMAL ATOMS +; EQUOTE -- FOR ERROR COMMENT ATOMS + +; FUNCTION CALLS TO INITIAL FUNCTIONS WILL BE CALLED USING THE FOLLOWING: + +; MCALL N, ;SEE MCALL MACRO +; ACALL AC, ; 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) + + + + + + ; 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-- + +; + + + ; 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 + +; 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 + + ; 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 +; OBJ +; 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 + + + ;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,,+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 + +; ,,<0 OR BINDID> ; TLOCI MEANS VAL EXISTS. + ; 0 MEANS GLOBAL +; ; BINDID SPECS ENV IN + ; WHICH LOCAL VAL EXISTS +; +; +; +; <400000+SATOM,,0> +; ,,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 + + IF1 [ +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.>->,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 ,ARG==0 + EXPUNGE D + TERMIN +] + +DEFMAI MAIN +DEFMAI READER + +IF2,EXPUNGE DEFMAI + + ;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 +] +] ;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 + +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 +] +] + ;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 +] + +;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 + + +; 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 +] + IF1 [ +;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 ,[FLG==1 + IFE LH, + IFN LH, +] + .ISTOP + TERMIN + TERMIN + IFE FLG,[ + IFE LH, + IFN LH, + ] + 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 +] + + +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 + + + + ;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 + + + + + +;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, + IFSN [PNAME],MAKAT [PNAME]T!TYPE+IMP,NAME,SYSTEM, + 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][][\ + ] + TERMIN + ] +TERMIN + +; MACRO TO HANDLE FATAL ERRORS + +DEFINE FATAL MSG/ + FATINS [ASCIZ /: FATAL ERROR MSG  /] + TERMIN +] + +CHRWD==5 + +IFN READER,[ +NCHARS==377 +;CHARACTER TABLE GENERATING MACROS + +DEFINE SETSYM WRDL,BYTL,COD + WRD!WRDL==& + WRD!WRDL==\<_<<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==/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==/5 + DUM2==CHROFF+CHAR-DUM1*5 + SETSYM \DUM1,\DUM2,COD + IFE CHROFF,[DUM1==/5 + DUM2==> + 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==/5 + DUM2==CHROFF+CHAR-DUM1*5 + SETSYM \DUM1,\DUM2,\ + IFE CHROFF,[DUM1==/5 + DUM2==> + SETSYM \DUM1,\DUM2, + ] + TERMIN + TERMIN + +DEFINE INCRCH OCOD,LIST + IRPC CHAR,,[LIST] + DUM3==<"CHAR>+CHROFF + DUM1==DUM3/5 + DUM2==DUM3-DUM1*5 + SETSYM \DUM1,\DUM2,\ + IFE CHROFF,[DUM3==DUM3+200 + DUM1==DUM3/5 + DUM2==DUM3-DUM1*5 + SETSYM \DUM1,\DUM2, + ] + TERMIN + TERMIN + RMT [EXPUNGE DUM1,DUM2,DUM3 + REPEAT NWRDS,KILLWD \.RPCNT + REPEAT CHRWD,KILMSK \.RPCNT +] + +TERMIN + +INITCH +] + +;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==&77 + REST== + IFN N,IFGE <31-N>,IFGE ,TOTAL==TOTAL*10.+ + 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==<<<&77>+40>_29.> + B==<&77> + IFN B,A==A+<_22.> + B==<&77> + IFN B,A==A+<_15.> + B==<&77> + IFN B,A==A+<_8.> + B==<&77> + IFN B,A==A+<_1.> + A + IFN ,<+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 \ + 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 + diff --git a//mudex.bin.34 b//mudex.bin.34 new file mode 100644 index 0000000..b9c5740 Binary files /dev/null and b//mudex.bin.34 differ diff --git a//mudex.bin.38 b//mudex.bin.38 new file mode 100644 index 0000000..446e0c7 Binary files /dev/null and b//mudex.bin.38 differ diff --git a//mudex.mid.177 b//mudex.mid.177 new file mode 100644 index 0000000..0284d99 --- /dev/null +++ b//mudex.mid.177 @@ -0,0 +1,1025 @@ +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 + + +; 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) + + +; 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:MDLXXX.SQUOZE/ +TSQBLK: ASCIZ /DSK: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 diff --git a//mudex.mid.183 b//mudex.mid.183 new file mode 100644 index 0000000..e763624 --- /dev/null +++ b//mudex.mid.183 @@ -0,0 +1,1053 @@ +TITLE MUDEX -- TENEX DEPENDANT MUDDLE CODE + +RELOCATABLE + +.INSRT MUDDLE > +.INSRT STENEX > + +MFORK==400000 +XJRST==JRST 5, + +.GLOBAL %SSNAM,%RSNAM,%KILLM,%LOGOU,%SLEEP,%VALRE,NOTTY,DEMFLG,MSGTYP,TTYOP2 +.GLOBAL %UNAM,%XUNA,%JNAM,%XJNA,%RUNAM,%RXUNA,%RJNAM,%RXJNA,%GCJOB,%VALFI +.GLOBAL %SHWND,%SHFNT,%GETIP,%INFMP,SGCLBK,TWENTY,MULTSG,MLTUUP +.GLOBAL GCHN,WNDP,FRNP,MESSAG,INITFL,6TOCHS,SGSNAM,MTYO,PGINT,WHOAMI +.GLOBAL %TOPLQ,IBLOCK,TMTNXS,TNXSTR,%HANG,ILLUUO,UUOH,IPCINI,CTIME,BFLOAT +.GLOBAL GCRSET,%MPINT,%GBINT,%CLSMP,%GCJB1,%CLMP1,%SAVIN,%MPIN,%MPIN1,%IMSV1 +.GLOBAL %PURIF,%MPINX,%CLSJB,%KILJB,%IFMP1,%OPGFX,STOSTR,%SAVRP,%RSTRP,GETSQU +.GLOBAL WIND,%FDBUF,%CWINF,P.TOP,BUFGC,PURBOT,%IFMP2,%CLSM1,GETBUF,KILBUF +.GLOBAL CERR1,CERR2,CERR3,COMPERR,CALER1,%LDRDO,%MPRDO,SQBLK,SQLOD,SQKIL,GETSQU +.GLOBAL SQUPNT,SFRK,IJFNS,GETJS,OPBLK,SJFNS,OPSYS,GCLDBK,ILDBLK,IJFNS1,TILDBL +.GLOBAL TBINIT,PVSTOR,SECBLK,PURCLN,NSEGS,INTINT,PURBTB,%CLNCO,OUTRNG +.GLOBAL MULTI,NOMULT,THIBOT,%PURMD +.GLOBAL C%11,C%22,C%33,C%44,C%55,C%66,C%0,C%1,C%2,C%3,C%M1,C%M2,C%M10 +.GLOBAL C%M20,C%M30,C%M40,C%M60 + +GCHN==0 +CTTRAP==1000 +CTEXST==10000 +CTREAD==100000 +CTEXEC==20000 +CTWRIT==40000 +CTCW==400 + +MFORK==400000 +CTREAD==100000 ; READ BIT +CTEXEC==20000 ; EXECUTE BIT +CTWRIT==40000 ; WRITE BIT +CTCW==400 ; COPY ON WRITE + + +FREAD==200000 ; READ BIT FOR OPENF +FEXEC==40000 ; EXEC BIT FOR OPENF +FTHAW==2000 +FWRITE==100000 + +GJ%SHT==1 ; SHORT FORM GTJFN +GJ%OLD==100000 ; FILE MUST EXIST +OP%36B==440000 ; 36 BIT BYTES +OP%7B==700000 ; 7 BIT BYTES +CR%CAP==200000 + +SQLOD: MOVEI A,1 + JRST @[.+1] ; RUN IN 0 FOR BIZARRE BUGS + PUSHJ P,GETBUF + HRRM B,SQUPNT + HLRZ A,SJFNS + JUMPE A,SQLOD1 + HRRZS SJFNS + CLOSF + JFCL +SQLOD1: HRROI B,SQBLK + SKIPE OPSYS + HRROI B,TSQBLK + MOVSI A,GJ%SHT+GJ%OLD + GTJFN + FATAL CANT GET SQUOZE + HRLM A,SJFNS + MOVEI D,(A) + MOVE B,[OP%36B,,FREAD] + OPENF + FATAL CANT OPEN SQUOZE + SIZEF + FATAL CANT SIZEF SQUOZE + MOVSI A,(D) + MOVNS B + HRLM B,SQUPNT + HRRZ B,SQUPNT + ASH B,-9. + HRLI B,MFORK + MOVSI C,CTREAD+CTEXEC + + PMAP + ADDI A,1 + ADDI B,1 + PMAP + MOVEI A,(D) + CLOSF + JFCL + SKIPN MULTSG + POPJ P, + POP P,B + MOVEI A,0 + XJRST A + + +SQKIL: PUSHJ P,KILBUF + HLLZS SQUPNT +CPOPJ: +%PURIF: +%GETIP: POPJ P, + +%PURMD: MOVE A,[MFORK,,THIBOT] + MOVEI 0,777-THIBOT +%PURMX: RPACS + TLNN B,CTWRIT+CTCW ; SKIP IF NOT READ ONLY + TLNN B,CTEXST ; SKIP IF EXISTS (OTHERWISE WE'LL CREATE IT) + JRST .+3 ; SKIP IF NOT READ ONLY + MOVSI B,CTREAD+CTEXEC + SPACS + ADDI A,1 + SOJGE 0,%PURMX + POPJ P, + +GETSQU: HRRZ 0,SQUPNT + JUMPN 0,CPOPJ + JRST SQLOD + + +CTIME: SKIPE OPSYS ; skip if TOPS20 + JRST .+4 + MOVEI A,400000 + RUNTM + JRST .+2 + JOBTM ; get run time in milli secs + IDIVI A,400000 + FSC B,233 + FSC A,254 + FADR B,A + FDVRI B,(1000.0) ; Change to units of seconds + MOVSI A,TFLOAT + POPJ P, + +; THE GLOBAL SNAME + +%RSNAM: PUSHJ P,TMTNXS ; GET STRING ON STACK (POINTER IN E) + GJINF ; USER NUMBER IS IN A + PUSHJ P,INFSTR ; MAKE INFO STRING + +%SSNAM: POPJ P, + +; KILL THE CURRENT JOB + +%VALFI: +%KILLM: HALTF + POPJ P, + +; STRING IS IN A +%VALRE: HRROS A + RSCAN ; PASS STRING + JFCL + MOVEI A,0 + RSCAN ; MAKE IT AVAILABLE FOR USE + JFCL + JRST %KILLM + +; LOGOUT OF SYSTEM (MUST BE "TOP LEVEL") + +%LOGOU: LGOUT + POPJ P, + +; GO TO SLEEP A WHILE + +%SLEEP: IMULI A,33. ; TO MILLI SECS + DISMS + POPJ P, + +; HANG FOR EVER + +%HANG: WAIT + +; READ JNAME + +%RXJNA: +%RJNAM: GETNM ; RETURNS SIXBIT IN A + MOVEM A,%JNAM + POPJ P, + +; READ UNAME + +%RXUNA: +%RUNAM: PUSHJ P,TMTNXS ; GET STRING ON STACK (POINTER IN E) + GJINF ; USER NUMBER IS IN A + MOVE B,A ; USER NUMBER TO B + PUSHJ P,INFST1 ; MAKE INFO STRING +CPOPJ1: AOS (P) ; SKIP RETURN + POPJ P, + +; MAKE A STRING FROM DIRST GOODIES +INFSTR: TDZA 0,0 +INFST1: MOVEI 0,1 ; FLAG WHETHER TO SCAN + HRROI A,1(E) ; STRING POINTER IN A + DIRST ; GET THE NAME + FATAL ATTACHED DIRECTORY DOESN'TEXIST + MOVEI B,1(E) ; A AND B BOUND STRING + JUMPN 0,INFST2 ; NO NEED TO SCAN + SKIPE OPSYS + JRST INFST2 + + HRLI B,440700 + MOVE A,B + + ILDB 0,B ; FLUSH : AND <> + CAIE 0,"< + JRST .-2 + + ILDB 0,B + CAIN 0,"> + JRST .+3 + IDPB 0,A + JRST .-4 + + MOVE B,A + MOVEI 0,0 + IDPB 0,B + MOVEI B,1(E) + + +INFST2: SUBM P,E ; RELATIVIZE E + PUSHJ P,TNXSTR ; BUILD STRING (IN A AND B) + MOVE C,(P) ; GET RETURN PC FROM PUSHJ + SUB P,E ; P BACK TO NORMAL + JRST (C) + +; HERE TO SEE IF WE ARE A TOP LEVEL JOB + +%TOPLQ: GJINF + JUMPL D,CPOPJ1 + JRST CPOPJ + +; ERRORS IN COMPILED CODE MAY END UP HERE + +CERR1: ERRUUO EQUOTE NEGATIVE-ARGUMENT + +CERR2: ERRUUO EQUOTE NTH-REST-PUT-OUT-OF-RANGE + +CERR3: ERRUUO EQUOTE UVECTOR-PUT-TYPE-VIOLATION + +COMPERR: + ERRUUO EQUOTE ERROR-IN-COMPILED-CODE + + +; 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) + + +; GET JFNS TO MDL INTERPRETER, AGC AND SGC, SAVE IN IJFNS AND IJFNS1 +GETJS: MOVEI A,$TLOSE + LSH A,-11 + HRLI A,MFORK ; THIS FORK + RMAP + JUMPGE A,GETJS1 ; HAPPY? +; HERE TO GET MDL INTERPRETER JFN EXPLICITLY RATHER THAN THROUGH RMAP + HRROI B,ILDBLK + SKIPE OPSYS + HRROI B,TILDBL + MOVSI A,GJ%SHT+GJ%OLD + GTJFN + FATAL INTERPRETER EXE FILE MISSING + MOVE B,[OP%36B,,FREAD+FWRITE] + OPENF + FATAL CANT OPEN MDL INTERPRETER EXE FILE + HRLM A,A +GETJS1: HLRZM A,IJFNS ; SAVE JFN TO INTERPRETER + POPJ P, + +; GTJFN BLOCK FOR MESSAGE FILE +MESBLK: 100000,, + 377777,,377777 + -1,,[ASCIZ /DSK/] + -1,,[ASCIZ /MDL/] + -1,,[ASCIZ /MUDDLE/] + -1,,[ASCIZ /MESSAG/] + 0 + 0 + 0 + +MUDINT: MOVSI 0,(JFCL) ; CLOBBER MUDDLE INIT SWITCH + MOVEM 0,INITFL + +; LOOP TO TOUCH ALL PAGES SO PURIFY CAN WORK + + SKIPN A,DEMFLG ; SKIP IF A DEMON + JRST FINDIR ; GET USERS DIRECTORY + AOJE A,FINDIR + MOVE A,DEMFLG ; GET SIXBIT OF DIRECTORY NAME + PUSHJ P,6TOCHS ; TO CHARACACTER STRING + JRST DIRCON + +FINDIR: GJINF ; GET INFO NEEDED + MOVEM A,SJFNS + PUSHJ P,TMTNXS ; MAKE A TEMP STRING FOR TENEX INFO + ; (POINTER LEFT IN E) + PUSHJ P,INFSTR +DIRCON: PUSH TP,$TATOM + PUSH TP,IMQUOTE SNM + PUSH TP,A + PUSH TP,B + MCALL 2,SETG + SKIPE WHOAMI + JRST SUBSYS + MOVE A,[SIXBIT/MUDDLE/] + PUSHJ P,6TOCHS ; MAKE A CHARACTER STRING + PUSH TP,$TCHSTR + PUSH TP,CHQUOTE READ + PUSH TP,A + PUSH TP,B + PUSH TP,$TCHSTR ; NOW THE .INIT + PUSH TP,CHQUOTE .INIT + MCALL 2,STRING ; MAKE A STRING + PUSH TP,A ; ARGS TO FOPEN + PUSH TP,B + MCALL 2,FOPEN + GETYP A,A + CAIN A,TCHAN + JRST ISVCHN +SUBSYS: PUSH TP,$TCHSTR + PUSH TP,CHQUOTE READ + MOVE A,[SIXBIT /MUDDLE/] + SKIPE WHOAMI + MOVE A,WHOAMI + PUSHJ P,6TOCHS + PUSH TP,A + PUSH TP,B + PUSH TP,$TCHSTR + PUSH TP,CHQUOTE INIT + PUSH TP,$TCHSTR + PUSH TP,CHQUOTE DSK + PUSH TP,$TCHSTR + PUSH TP,CHQUOTE MUDDLE + MCALL 5,FOPEN + GETYP A,A + CAIE A,TCHAN + POPJ P, +ISVCHN: PUSH TP,$TCHAN + PUSH TP,B + MOVEI B,INITSTR ; TELL USER WHAT'S HAPPENING + SKIPE WHOAMI + JRST INCOM + SKIPE DEMFLG ; SKIP IF NOT A DEMON + JRST INCOM + SKIPN NOTTY + PUSHJ P,MSGTYP +INCOM: MCALL 1,MLOAD + POPJ P, + +TMTNXS: POP P,D ; SAVE RET ADDR + MOVE E,P ; BUILD A STRING SPACE ON PSTACK + MOVEI 0,20. ; USE 20 WORDS (=100 CHARS) + PUSH P,C%0 + SOJG 0,.-1 + + JRST (D) + + +TNXSTR: SUBI B,(P) + PUSH P,B + ADDI B,-1(P) + SUBI B,(A) ; WORDS TO B + IMULI B,5 ; TO CHARS + LDB 0,[360600,,A] ; GET BYTE POSITION + IDIVI 0,7 ; TO A REAL BYTE POSITION + MOVNS 0 + ADDI 0,5 + SUBM 0,B ; FINAL LENGTH IN BYTES TO B + PUSH P,B ; SAVE IT + MOVEI A,4(B) ; TO WORDS + IDIVI A,5 + PUSH P,E ; SAVE E + PUSHJ P,IBLOCK ; GET STRING + POP P,E + POP P,A + POP P,C + ADDI C,(P) + MOVE D,B ; COPY POINTER + MOVE 0,(C) ; GET A WORD + MOVEM 0,(D) + ADDI C,1 + AOBJN D,.-3 + + HRLI A,TCHSTR + HRLI B,00700 ; MAKE INTO BYTER + SOJA B,CPOPJ + +INITSTR: ASCIZ /MUDDLE INIT/ + +; HERE TO RECOPY PAGE 0 WHICH CONTAINS IMFORMATION FOR REMAPPING IN INFERIOR +%OPGFX: PUSH P,B ; SAVE B + PUSH P,A + MOVEI B,STOSTR ; TOP OF CONSTANTS + ADDI B,1777 ; ROUND + ANDCMI B,1777 + ASH B,-10. ; TO PAGES + MOVN A,B + MOVEI B,WNDP ; GET WINDOW + HRLZS A ; START WITH PAGE 0 +OPGFX2: JUMPGE A,OPGFX1 + PUSH P,A + HRRZS A + PUSHJ P,%SHWNF + HRRZ A,(P) + ASH A,10. ; TO START OF PAGE + HRLS A ; SET UP BLT POINTER + HRRI A,WIND + MOVEI B,WIND + BLT A,1777(B) ; OUT INTO THE BUFFER + POP P,A ; RESTORE A + AOBJN A,OPGFX2 +OPGFX1: POP P,A + POP P,B + POPJ P, + +; ROUTINE TO PROTECT A CORE IMAGE BY SAVING IT IN AN INFERIOR +; A==FORK HANDLE B== AOBJN POINTER + + +PROTCT: TRNN B,-1 ; SEE IF PAGE 0 IS INCLUDED + ADD B,C%11 ; INC PAGE + ASH B,1 + PUSH P,C ; SAVE C + MOVE C,B ; COPY AOBJN + MOVSI A,MFORK ; FORK HANDLE + JUMPE C,PRTDON ; IF ZERO THEN WE ARE DONE +PROTC1: HRRI A,(C) ; GET PAGE + HRRZ D,C + ASH D,9. + RPACS + TLNN B,CTWRIT+CTCW ; SKIP IF NOT READ ONLY + TLNN B,CTEXST ; SKIP IF EXISTS (OTHERWISE WE'LL CREATE IT) + MOVES 20(D) ; TOUCH PAGE + MOVSI B,CTREAD+CTEXEC ; SET UP TO MARK PAGES TO TRAP ON ANY REF + SPACS ; CHANGE MODE OF PAGE + AOBJN C,PROTC1 +PRTDON: POP P,C ; RESTORE C + POPJ P, + +%FDBUF: HRRZ A,PURBOT + SUB A,P.TOP ; CALCULATE ROOM FOR PROSPECTIVE BUFFER + CAIG A,2000 ; SEE IF ROOM + JRST FDBUF1 + MOVE A,P.TOP ; START OF BUFFER + HRRM A,BUFGC + POPJ P, +FDBUF1: SETOM BUFGC ; INDICATE NO BUFFER FOUND + POPJ P, + +; HERE TO SIMULATE A COPY ON WRITE TO AN INFERIOR. IF A PAGE HAS NO WRITE BITS +; IT WILL COPY IT INTO THE GCFRK1 FORK. A== START OF PAGE, B== START OF BUFFER PAGE + +%CWINF: PUSH P,A + PUSH P,B ; SAVE AC'S + PUSH P,C + ANDI A,-1 ; CLEAN OUT LEFT HALF OF A + ASH A,-9. ; TO PAGES + PUSH P,C%0 + HRLI A,MFORK ; GET FORK HANDLE + RPACS ; READ PAGE BITS + MOVEM B,(P) + TLNE B,CTEXST ; SKIP IF DOESN'T EXIST + TLNE B,CTWRIT ; SEE IF WRITABLE + JRST CWINFX ; NO, EXIT + MOVSI B,CTEXEC+CTREAD+CTCW + SPACS ; RESTORE PAGE TO NORMAL +CWINFX: ADDI A,1 + RPACS ; READ PAGE BITS + TLNE B,CTEXST ; SKIP IF DOESN'T EXIST + TLNE B,CTWRIT ; SEE IF WRITABLE + JRST CWINFY ; NO, EXIT + MOVSI B,CTEXEC+CTREAD+CTCW + SPACS + SUB P,C%11 + JRST CWINFZ +CWINFY: POP P,B + TLNE B,CTEXST ; SKIP IF DOESN'T EXIST + TLNE B,CTWRIT ; SEE IF WRITABLE + JRST CWINF1 ; NO, EXIT +CWINFZ: HRRZI A,-1(A) + ASH A,-1 + MOVE B,-1(P) ; SET UP BUFFER PAGE + ASH B,-10. ; TO PAGE NUMBER + PUSHJ P,%SHWNF ; SHARE A WINDOW + HRLZ A,-2(P) ; PREPARE FOR BLT + HRR A,-1(P) + HRRZ B,-1(P) + BLT A,1777(B) ; SAVE THE PAGE +CWINF1: MOVE B,-1(P) + ASH B,-9. ; TO PAGES + MOVNI A,1 + HRLI B,MFORK ; SET UP HANDLE + MOVEI C,0 + PMAP ; FLUSH BUFFER + POP P,C + POP P,B +POPAJ: POP P,A + POPJ P, + + + +; ROUTINE TO RESTORE THE IMAGE FROM A SAVED FORK IMAGE. +; A== FORK HANDLE B== AOBJN POINTER TO MUDDLE +; C== START IN INF + + +RSTIM: ASH B,1 ; TO CONVERT TO TENEX PAGES + ASH C,1 + HRLZS A ; FORK HANDLE TO LEFT HALF + JUMPE C,RSTIM1 ; SEE IF NO WORK TO DO +RSTIM2: HRRI A,(C) + PUSH P,B ; SAVE B + RPACS ; READ PAGE BITS + TLNN B,CTEXST ; SKIP IF IT EXISTS + JRST RSTIM3 + HRRZ B,(P) ; GET PAGE + HRLI B,MFORK ; GET PAGE BACK TO ME + PUSH P,C + MOVSI C,CTREAD+CTCW+CTEXEC ; PAGE MODES + PMAP ; GET THE PAGE + POP P,C ;RESTORE C + ASH B,9. ; TO START OF PAGE + MOVES 20(B) ; TOUCH PAGE +RSTIM3: POP P,B ; GET BACK B + ADDI C,1 ; INC C + AOBJN B,RSTIM2 ; GO BACK IN LOOP +RSTIM1: POPJ P, ; DONE + + +; ROUTINE TO MAP OUT PARTS OF THE INTERPRETER IN ORDER TO PRESERVE IT + +%MPINX: MOVE 0,GCFK1 + JRST MPIN + +%MPIN: +%MPIN1: MOVE 0,GCFRK +MPIN: PUSH P,C ; SAVE B + MOVE C,A + MOVE A,0 ; GET FORK HANDLE + PUSHJ P,RSTIM + POP P,C + POPJ P, ; EXIT + +%SAVIN: PUSH P,B ; SAVE AC'S + PUSH P,A + MOVSI A,CR%CAP + CFORK + FATAL AGC--CAN'T GET GC FORK + MOVEM A,GCFK1 ; SAVE FORK HANDLE + POP P,B ; RESTORE AOBJN + PUSHJ P,PROTCT ; PROTECT IMAGE + MOVE A,[MFORK,,THIBOT] + MOVEI 0,777-THIBOT +%SAVLP: RPACS + TLNN B,CTWRIT+CTCW ; SKIP IF NOT READ ONLY + TLNN B,CTEXST ; SKIP IF EXISTS (OTHERWISE WE'LL CREATE IT) + JRST .+3 ; SKIP IF NOT READ ONLY + MOVSI B,CTREAD+CTCW+CTEXEC + SPACS + ADDI A,1 + SOJGE 0,%SAVLP + POP P,B ; RESTORE AC + POPJ P, + +%MPRDO: HRLI B,-1 + HRR B,A + JRST PROTCT + + +; CREATE A JOB FOR MARKING HACKS (PURIFY AND GC-DUMP) AND SAVES HANDLE IN TWO SEPERATE +; PLACES. + +%GCJB1: PUSHJ P,%GCJOB ; CREATE FORK + MOVE A,GCFRK ; GET HANDLE + MOVEM A,GCFK2 + POPJ P, + +%CLSMP: MOVE 0,GCFK2 ; GET BACK FROM FORK CONTAINING UPDATED WORLD + PUSHJ P,%GBINT +%CLSM1: MOVE A,GCFK2 ; KILL THE FORK +KFK1: KFORK +%IFMP1: +%CLSJB: POPJ P, ; IN ITS CLOSES AN INFERIORS CHANNEL WITHOUT + ; KILLING IT + +; HERE TO KILL THE IMAGE SAVING INFERIOR + +%KILJB: PUSH P,A ; SAVE MAPPING PARAMS + MOVE A,GCFK1 + KFORK + JRST IFMP3 ; GO FIX UP CORE IMAGE + +; HERE TO MAP IN SAVED WORLD AND KILL INF CONTAINING IT + +;%IFMP1: POPJ P, + +; HERE TO MAP IN A PAGE IN READ ONLY MODE FROM THE AGD INFERIOR + +%LDRDO: MOVE 0,GCFK1 + PUSH P,A ; SAVE PAGE POINTER + MOVE B,A + HRLI B,-1 ; MAKE UP PAGE POINTER + PUSHJ P,MPIN ; MAP IN THE PAGES + HRLI B,CTREAD+CTEXEC + HRLI A,MFORK ; SET UP HANDLE + HRR A,(P) + ASH A,1 ; CONVERT TO TENEX PATES + HRRZ C,A + ASH C,9 + MOVES 20(C) + SPACS + ADDI A,1 + HRRZ C,A + ASH C,9 + MOVES 20(C) + SPACS + SUB P,C%11 ; CLEAN OFF STACK + POPJ P, + +%IFMP2: PUSH P,A ; SAVE POINTER + MOVE 0,GCFK1 + PUSHJ P,MPIN ; MAP IT IN + MOVE A,GCFK1 ; KILL IT + KFORK +IFMP3: POP P,C + ASH C,1 + MOVSI A,MFORK ; SET UP FORK HANDLE + JUMPGE C,IFMP2 ; IF DONE +DORPA: HRR A,C ; GET PAGE # + RPACS + TLNN B,CTEXST ; SKIP IF IT EXISTS + JRST .+3 + MOVSI B,CTREAD+CTWRIT+CTEXEC ; CAPABILATIES + SPACS ; SET CAPABILATIES + AOBJN C,DORPA +IFMP2: POPJ P, + + +%CLMP1: MOVE A,GCFK1 ; KILL THE FIRST FORK + JRST KFK1 + +%IMSV1: +%MPINT: PUSH P,C ; SAVE C + PUSH P,B + PUSH P,D + ASH A,1 + MOVEI C,0 + MOVE D,A +MPINT1: MOVSI A,MFORK ; SET UP ARGS TO RMAP + HRRI A,(D) + RMAP + MOVEM A,RMPTAB(C) + ADDI C,1 + AOBJN D,MPINT1 + POP P,D + POP P,B + POP P,C + POPJ P, + + +; ROUTINE TO GET BACK THE INTERPRETER. IT MAPS +%GBINT: PUSH P,E + PUSH P,B + PUSH P,C ; SAVE AC'S + PUSH P,D + ASH A,1 + MOVE D,A ; COPY UDDATED AOBJN + MOVEI E,0 ; ZERO INDEX TO TABLE +GBINT1: MOVE A,RMPTAB(E) ; GET FILE HANDLE + MOVSI B,MFORK ; SET UP INTERPRETER ARG + HRRI B,(D) + MOVSI C,CTREAD+CTEXEC + PMAP ; IN IT COMES + ADDI E,1 ; INC INDEX + AOBJN D,GBINT1 + POP P,D + POP P,C + POP P,B + POP P,E + POPJ P, + +; HERE TO SAVE RMAP TABLE FOR PURIFY + +%SAVRP: PUSH P,A ; SAVE AC + MOVE A,[RMPTAB,,ORMTAB] + BLT A,ENDRPT-1 ; SAVE RMAP TABLE + JRST POPAJ +; POP P,A ; RESTORE A +; POPJ P, + +; HERE TO RESTORE THE RMAP TABLE FOR PURIFY + +%RSTRP: PUSH P,A ; SAVE A + MOVE A,[ORMTAB,,RMPTAB] + BLT A,ORMTAB-1 + JRST POPAJ +; POP P,A ; RESTORE A +; POPJ P, + +SQBLK: ASCIZ /PS:MDLXXX.SQUOZE/ +TSQBLK: ASCIZ /DSK:MDLXXX.SQUOZE/ + +; CODE TO DISTINGUISH BETWEEN TOPS20 AND TENEX AT SETUP TIME + +TWENTY: HRROI A,C ; RESULTS KEPT HERE + HRLOI B,600015 + MOVEI C,0 ; CLEAN C UP + DEVST + JFCL + MOVEI A,1 ; TENEX HAS OPSYS = 1 + CAME C,[ASCII/NUL/] ; TOPS20 GIVES "NUL" + MOVEM A,OPSYS ; TENEX GIVES "NIL" + POPJ P, + +;%CLNCO -- FLUSH SOME PAGES FOR SAFETY +; C ==> ADDR OF PAGE PREV TO LOSERS +; E ==> JUST ABOVE LOSERS + +%CLNCO: PUSH P,C + PUSH P,E + ADDI C,777 + ASH C,-9. + ASH E,-9. + SKIPE MULSEC + JRST @[.+1] ; RUN IN SECT 0 + CAIG E,1(C) + JRST %CLN1 + PUSH P,A + PUSH P,B + + MOVSI B,MFORK + HRRI B,(C) + MOVNI A,1 + MOVEI C,0 + + PMAP + CAIL E,2(B) + AOJA B,.-2 + + POP P,B + POP P,A + +%CLN1: POP P,E + POP P,C + SKIPN MULSEC + POPJ P, + + XJRST .+1 ; BACK TO SECT 1 + 0 + FSEG,,CPOPJ + +; MULTI -- ENTER MULTI SEGMENT MODE +; THIS ROUTINE MAPS EVERYTHING UP AND THEN GOES UP THERE + +MULTI: PUSHJ P,PURCLN ; UNMAP ANY CORRENTLY MAPPED FBINS + PUSHJ P,SQKIL ; AND SQUOZE TABLE + SETOM MULTSG + MOVE A,PURBOT ; MUNG TABLE OF THESE GUYS + MOVN B,NSEGS + MOVSI B,(B)-1 + + MOVEM A,PURBTB(B) + AOBJN B,.-1 + + MOVE A,VECTOP ; CWRITE GC SPACE + ANDCMI A,777 + MOVES (A) + SUBI A,1000 + JUMPG A,.-2 + + MOVEI A,0 ; FIRST CREATE OTHER SECTIONS + MOVE B,[MFORK,,FSEG] + MOVE C,[CTREAD+CTWRIT+CTEXEC,,1] + MOVE D,NSEGS + SMAP + ADDI B,1 + SOJG D,.-2 + +; CREATE GC SEGMENT + + HRRI B,GCSEG + SMAP + +; NOW LOOP AROUND MAPPING PAGES (MAY TAKE SOME TIME) + + MOVEI D,FSEG_9. + MOVEI PVP,FSEG + ADD PVP,NSEGS + LSH PVP,9. ; PVP NOW HIGHEST PAGE TO MAP + MOVSI E,-1000 ; 1ST PAGE AND COUNTER + +PAGLP: MOVSI A,MFORK + HRRI A,(E) + RMAP + CAME A,C%M1 + JRST .+3 + MOVSI A,MFORK + HRRI A,(E) + MOVSI B,MFORK + HRRI B,(E) + IORI B,(D) + MOVSI C,CTREAD+CTWRIT+CTEXEC + PMAP +LPON: AOBJN E,PAGLP + + MOVSI E,-1000 + ADDI D,1_9. + CAMGE D,PVP + JRST PAGLP + +; SETUP MULTI SEG LUUO HANDLER + + MOVEI A,MFORK + MOVEI B,2 ; CODE FOR SETUP OF UUO TABLE + MOVE C,[FSEG,,MLTUUP] + SWTRP + MOVEI C,FSEG + MOVE B,PVSTOR+1 + MOVE B,TBINIT+1(B) + HRLM C,PCSAV(B) + PUSHJ P,INTINT + + POP P,C + HRLI C,FSEG ; MAKE INTO FUNNY ADDRESS + MOVEI B,0 + TLO TB,400000 ; MAKE TB BE A LOCAL INDEX + XJRST B + +NOMULT: PUSHJ P,PURCLN + JRST @[.+1] ; RUN IN SECTION 0 + SETZM MULTSG + MOVNI A,1 + MOVE B,[MFORK,,FSEG] + MOVEI C,1 + MOVE D,NSEGS + SMAP + ADDI B,1 + SOJG D,.-2 + +; FLUSH GC SEG + + HRRI B,GCSEG + SMAP + + JRST INTINT +; PUSHJ P,INTINT +; POPJ P, + +MFUNCTION MMS,SUBR,MULTI-SECTION + + ENTRY + + PUSH P,NSEGS + PUSH P,MULTSG + JUMPGE AB,RMULT ; NO ARGS==>LEAVE + CAMGE AB,C%M30 ; [-3,,] + JRST TMA + GETYP 0,(AB) + CAIE 0,TFIX + JRST INOUT + MOVE 0,1(AB) + CAIL 0,2 + CAILE 0,30 + JRST OUTRNG + MOVEM 0,NSEGS +INOUT: GETYP 0,(AB) + CAIE 0,TFALSE + JRST EMULT +LMULT: SKIPE (P) + PUSHJ P,NOMULT + JRST RMULT + +EMULT: SKIPN (P) + PUSHJ P,MULTI + +RMULT: POP P,A + POP P,B ; POSSIBLE PREV NSEGS + JUMPN A,TMULT + MOVSI A,TFALSE + MOVEI B,0 + JRST FINIS + +TMULT: MOVSI A,TFIX + JRST FINIS +IMPURE + +DEMFLG: 0 ; FLAG INDICATING DEMON + ; (IF DEMON SIXBIT OF DIRECTORY) +SFRK: -1 ; FLAG FOR EXTRA INFERIOR HACK +GCFRK: 0 +GCFK1: 0 +GCFK2: 0 +RMPTAB: BLOCK 25. +ORMTAB: BLOCK 25. +ENDRPT: + +MESSAG: PUSHJ P,MESOUT ; MESSAGE SWITCH + +INITFL: PUSHJ P,MUDINT ; MUDDLE INIT SWITCH + +PURE + +END diff --git a//mudits.mcr130.1 b//mudits.mcr130.1 new file mode 100644 index 0000000..055ee88 --- /dev/null +++ b//mudits.mcr130.1 @@ -0,0 +1,566 @@ + +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 + +; 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 +  \ No newline at end of file diff --git a//mudits.mid.131 b//mudits.mid.131 new file mode 100644 index 0000000..b870724 --- /dev/null +++ b//mudits.mid.131 @@ -0,0 +1,570 @@ + +TITLE MUDITS -- ITS DEPENDANT MUDDLE CODE + +RELOCATABLE + +.INSRT MUDDLE > + + +.GLOBAL %SSNAM,%RSNAM,%KILLM,%LOGOU,%SLEEP,%VALRE,NOTTY,DEMFLG,MSGTYP +.GLOBAL %UNAM,%JNAM,%XUNA,%XJNA,%RUNAM,%RJNAM,%RXUNA,%RXJNA,%GCJB1,%VALFI +.GLOBAL %GCJOB,%SHWND,%GETIP,%INFMP +.GLOBAL GCHN,WNDP,FRNP,FRONT,MESSAG,INITFL,6TOCHS,SGSNAM,MTYO,PGINT,WHOAMI +.GLOBAL %TOPLQ,IPCINI,IPCBLS,%HANG,CTIME,BFLOAT,GCRSET,%MPINT,%GBINT,%SAVIN +.GLOBAL %MPIN,%MPINX,%CLSMP,%CLSM1,%MPIN1,%IMSAV,%IMSV1,%PURIF,PSHGCF +.GLOBAL %CLSJB,%KILJB,%IFMP1,%OPGFX,%SAVRP,%RSTRP,%CWINF,%FDBUF,BUFGC,P.TOP,P.CORE +.GLOBAL PURBOT,SQUPNT,GETSQU,DIR,%LDRDO,%MPRDO,%IFMP2,SQBLK,SQDIR +.GLOBAL CERR1,CERR2,CERR3,COMPERR,CALER,CALER1,SQLOD,SQKIL,SLEEPR,GETBUF,KILBUF + + + +GCHN==0 +CWTP==1000,,4000 +RDTP==1000,,200000 +WRTP==1000,,100000 +GCHI==1000,,GCHN +CRJB==1000,,400001 +FME==1000,,-1 +FLS==1000,, + +%RSTRP: +%OPGFX: +%SAVRP: POPJ P, + + +SQLOD: MOVEI A,1 ; NUMBER OF PAGES OF BUFFER + PUSHJ P,GETBUF + HRRM B,SQUPNT + ASH B,-10. ; TO PAGES + .SUSET [.RSNAM,,A] ; OPEN FILE TO SQUOZE TABLE + .SUSET [.SSNAM,,SQDIR] ; SET SNAME + .OPEN GCHN,SQBLK + FATAL SQUOZE TABLE NON EXISTANT + .SUSET [.SSNAM,,A] + DOTCAL FILLEN,[[GCHI],[2000,,A]] + .LOSE %LSFIL ;PRESUMABLY LOSSAGE MATTERS + MOVNS A + HRLM A,SQUPNT + MOVEI A,0 + DOTCAL CORBLK,[[RDTP],[FME],B,[GCHI],A] + PUSHJ P,SLEEPR + .CLOSE GCHN, + MOVE A,B ; GET B + ASH A,10. + POPJ P, + +SQKIL: PUSHJ P,KILBUF + HLLZS SQUPNT + POPJ P, + +GETSQU: HRRZ 0,SQUPNT + JUMPN 0,ATSQ10 + JRST SQLOD +ATSQ10: POPJ P, + + +CTIME: .SUSET [.RRUNT,,B] ; Get user's run time in 4.069 microsecond units + IDIVI B,400000 + FSC C,233 + FSC B,254 + FADR B,C + FDVR B,[250000.00] ; Change to units of seconds + MOVSI A,TFLOAT + POPJ P, + +; SET THE SNAME GLOBALLY + +%SSNAM: .SUSET [.SSNAM,,A] + POPJ P, + +; READ THE GLOBAL SNAME + +%RSNAM: .SUSET [.RSNAM,,A] + POPJ P, + +; KILL THE CURRENT JOB/LOGOUT + +%LOGOU: +%KILLM: .LOGOUT 1, + POPJ P, + +; PASS STRING TO SUPERIOR (MONITOR?) + +%VALRE: .VALUE (A) + POPJ P, + +; DO 'KILL' +%VALFI: .BREAK 16,(A) + POPJ P, + +; GO TO SLEEP A WHILE + +%SLEEP: .SLEEP A, + POPJ P, + +; HANG FOREVER + +%HANG: SKIP + .HANG + +; READ JNAME + +%RJNAM: .SUSET [.RJNAM,,%JNAM] + MOVE A,%JNAM + POPJ P, + +; READ XJNAME + +%RXJNA: .SUSET [.RXJNA,,%XJNA] + MOVE A,%XJNA + POPJ P, + +; READ UNAME + +%RUNAM: .SUSET [.RUNAM,,%UNAM] + MOVE A,%UNAM + POPJ P, + +; READ XUNAME + +%RXUNA: .SUSET [.RXUNA,,%XUNA] + MOVE A,%XUNA + POPJ P, + +; HERE TO SEE IF WE ARE A TOP LEVEL JOB + +%TOPLQ: PUSH P,A + .SUSET [.RSUPPR,,A] ; READ SUPERIOR + SKIPGE A ; SKIP IF IT EXISTS + AOS -1(P) ; CAUSE SKIP RET + POP P,A + POPJ P, + +; ERRORS IN COMPILED CODE MAY END UP HERE + +CERR1: MOVE A,EQUOTE NTH-BY-A-NEGATIVE-NUMBER + .SUSET [.RJPC,,B] + JRST CERR + +CERR2: MOVE A,EQUOTE NTH-REST-PUT-OUT-OF-RANGE + .SUSET [.RJPC,,B] + JRST CERR + +CERR3: MOVE A,EQUOTE UVECTOR-PUT-TYPE-VIOLATION + .SUSET [.RJPC,,B] + +COMPERR: + MOVE A,EQUOTE ERROR-IN-COMPILED-CODE + .SUSET [.RJPC,,B] + +CERR: PUSH TP,$TATOM + PUSH TP,A + PUSH TP,$TWORD + PUSH TP,B + MOVEI A,2 + JRST CALER + +; 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 + \ No newline at end of file diff --git a//mudsqu.bin.6 b//mudsqu.bin.6 new file mode 100644 index 0000000..994f249 Binary files /dev/null and b//mudsqu.bin.6 differ diff --git a//mudsqu.mcr025.1 b//mudsqu.mcr025.1 new file mode 100644 index 0000000..c9392c3 --- /dev/null +++ b//mudsqu.mcr025.1 @@ -0,0 +1,138 @@ + +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 + \ No newline at end of file diff --git a//mudsqu.mid.28 b//mudsqu.mid.28 new file mode 100644 index 0000000..17253f6 --- /dev/null +++ b//mudsqu.mid.28 @@ -0,0 +1,181 @@ + +TITLE SQUOZE TABLE HANDLER FOR MUDDLE + +RELOCATABLE + +XJRST==JRST 5, + +.INSRT MUDDLE > + +SYSQ + +.GLOBAL SQUPNT,ATOSQ,SQUTOA,GETSQU,CSQUTA,MPOPJ,SAT,SQUKIL,SQKIL +.GLOBAL MULTSG + +; ROUTINE TO KILL FIXUP TABLE SOMETIMES + +SQUKIL: PUSH P,0 ; SAVE ACS + HRRZ 0,SQUPNT ; SEE IF IN INTERPRETER + CAIG 0,HIBOT + JRST POPJ0 + PUSH P,A + PUSH P,B + PUSH P,C + PUSH P,D + PUSH P,E + PUSHJ P,SQKIL ; KILL THE BUFFER AND RESTORE INTERPRETER + POP P,E + POP P,D + POP P,C ; RESTORE AC'S + POP P,B + POP P,A +POPJ0: POP P,0 + POPJ P, + + +; POINTER TO TABLE FILLED IN BY INITM + +; SUBR TO INTERFACE TO MUDDLE SQUOZE TABLE. +; IT TAKES AN ARGUMENT OF PRIMTYPE WORD AND RETURNS A FIX GIVING THE +; LOCATION IF IT IS IN THE SQUOZE TABLE AND OTHERWISE RETURNS FALSE + + MFUNCTION SQUOTA,SUBR + ENTRY 1 + + GETYP A,(AB) + PUSHJ P,SAT ; GET SAT OF ARGUMENT + CAIE A,S1WORD ; BETTER BE OF PRIMTYPE WORD + JRST WTYP1 + MOVE A,1(AB) ; GET ARGUMENT INTO A + PUSHJ P,CSQUTA + JFCL + JRST FINIS + + +; COMPILER ENTRY TAKES ARGUMENT IN A + +CSQUTA: SUBM M,(P) ; RELATAVIZE P + MOVE E,A ; ARG TO SQUOTA + TLZ E,740000 ; FLUSH EXTRA BITS FOR LOOKUP + PUSHJ P,SQUTOA + JRST GTFALS + SOS (P) ; AND SKIP RETURN + PUSHJ P,SQUKIL + MOVSI A,TFIX ; RETURN FIX + MOVE B,E + JRST MPOPJ +GTFALS: PUSHJ P,SQUKIL + MOVE A,$TFALSE + MOVEI B,0 + JRST MPOPJ ; RETURN A FALSE + + +; GIVEN LOCN OF SUBR RET SQUO NAME ARG AND VAL IN E + +ATOSQ: PUSH P,B + PUSH P,A + PUSHJ P,GETSQU +IFE ITS,[ + SKIPE MULTSG + PUSHJ P,@[.+1] ; RUN IN 0 + MOVE A,SQUPNT ; GET TABLE POINTER + MOVE B,[2,,2] + CAMN E,1(A) + JRST ATOSQ1 + ADD A,B + JUMPL A,.-3 +POPABJ: PUSH P,E ; SAVE RESULT + PUSHJ P,SQUKIL + POP P,E +IFE ITS,[ + SKIPN MULTSG + JRST GOON + POP P,B ; GET PC + MOVEI A,0 + HRRI B,GOON ; RUN IN CALLERS SECTIO + XJRST A +] +GOON: POP P,B + POP P,A + POPJ P, + +ATOSQ1: MOVE E,(A) +IFE ITS,[ + SKIPN MULTSG + AOS -2(P) + SKIPE MULTSG + AOS -3(P) +] +IFN ITS,[ + AOS -2(P) +] + JRST POPABJ + +; BINARY SEARCH FOR SQUOZE SYMBOL ARG IN E + +SQUTOA: PUSH P,A + PUSH P,B + PUSH P,C + PUSH P,E + PUSHJ P,GETSQU + POP P,E + +IFE ITS,[ + SKIPE MULTSG + PUSHJ P,@[.+1] ; RUN IN SEC 0 +] + MOVE A,SQUPNT ; POINTER TO TABLE + HLRE B,SQUPNT + MOVNS B + HRLI B,(B) ; B IS CURRENT OFFSET + +UP: ASH B,-1 ; HALVE TABLE + AND B,[-2,,-2] ; FORCE DIVIS BY 2 + MOVE C,A ; COPY POINTER + JUMPLE B,LSTHLV ; CANT GET SMALLER + ADD C,B + CAMLE E,(C) ; SKIP IF EITHER FOUND OR IN TOP + MOVE A,C ; POINT TO SECOND HALF + CAMN E,(C) ; SKIP IF NOT FOUND + JRST WON + CAML E,(C) ; SKIP IF IN TOP HALF + JRST UP + HLLZS C ; FIX UP OINTER + SUB A,C + JRST UP + +WON: MOVE E,1(C) ; RET VAL IN E +IFE ITS,[ + SKIPN MULTSG + AOS -3(P) + SKIPE MULTSG + AOS -4(P) +] +IFN ITS, AOS -3(P) ; SKIP RET +WON1: +IFE ITS,[ + SKIPN MULTSG + JRST GOON1 + POP P,B ; GET PC + MOVEI A,0 + HRRI B,GOON1 ; RUN IN CALLERS SECTIO + XJRST A +] +GOON1: POP P,C + POP P,B + POP P,A + POPJ P, + +LSTHLV: CAMN E,(C) ; LINEAR SERCH REST + JRST WON + ADD C,[2,,2] + JUMPL C,.-3 + JRST WON1 ; ALL GONE, LOSE + + +IMPURE +SQUPNT: 0 + +PURE +END + \ No newline at end of file diff --git a//mudxxx.stink.2 b//mudxxx.stink.2 new file mode 100644 index 0000000..dd9cd48 --- /dev/null +++ b//mudxxx.stink.2 @@ -0,0 +1,34 @@ +MPURE.BINL +MSPECS.BINL +MLDGC.BINL +MUTILIT.BINL +MUUOH.BINL +MMUDEX.BINL +MMAPPUR.BINL +MCORE.BINL +MATOMHK.BINL +MINTERR.BINL +MNFREE.BINL +MGCHACK.BINL +MREADCH.BINL +MAGCMRK.BINL +MREADER.BINN +MPRINT.BINN +MBUFMOD.BINN +MARITH.BINN +MMAPS.BINN +MPRIMIT.BINN +MSTBUIL.BINL +MEVAL.BINL +MDECL.BINL +MMAIN.BINL +MMUDSQU.BINL +MFOPEN.BINL +MPUTGET.BINL +MCREATE.BINL +MSAVE.BINL +MAGC.BINN +MAMSGC.BINN +MSECAGC.BINL +MINITM.BINL? + \ No newline at end of file diff --git a//mymode.teco.1 b//mymode.teco.1 new file mode 100644 index 0000000..dd9a681 Binary files /dev/null and b//mymode.teco.1 differ diff --git a//nfopen.bin.2 b//nfopen.bin.2 new file mode 100644 index 0000000..9b7991b Binary files /dev/null and b//nfopen.bin.2 differ diff --git a//nfopen.mid.4 b//nfopen.mid.4 new file mode 100644 index 0000000..235baf7 --- /dev/null +++ b//nfopen.mid.4 @@ -0,0 +1,4481 @@ +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 (,,,,) +; +; - DIRECTION EITHER READ (INPUT) OR PRINT (OUPUT). DEFAULT IS READ + +; - FIRST FILE NAME. DEFAULT INPUT OR OUTPUT. + +; - SECOND FILE NAME. DEFAULT MUDDLE. + +; - DEVICE FROM WHICH TO OPEN. DEFAULT IS DSK. + +; - 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 + + +;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 + +.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) = ,, +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 + + + +;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 + + + + +; 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 + + + +; 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, +] + + +; 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, + + +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," ; 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, + + + +; 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 +] + + +; 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) + + + +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," ; 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 + +] + + +; 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) + + +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 + +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) + + +; 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 + + +; 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 + + +; 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, + + +; 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, + +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, + +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 + +] + +; 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, + + +; 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, +] + +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 + + +; 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, + + +; 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 +] +] + + +; 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, +] + +;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, + +; 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 + ] + +; 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 + 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 + + ; 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 + +; 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 + + ; 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] + + ;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 + + ;SUBR TO DO .ACCESS ON A READ CHANNEL +;FORM: +;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,[+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 + +; 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,[+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, + ; 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,[+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 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/ + +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 + + ; 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 +; AND BOTH SUBRS RETURN THE NUMBER OF CHARS READ OR WRITTEN + +; FORMAT FOR PRINTSTRING IS + +; 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 + + ; 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 +] + +; 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, + + +; 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 + + ;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 + + + +; 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,[+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, +] + + + ; 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 = +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 +] + ;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 + + \ No newline at end of file diff --git a//nfree.bin.5 b//nfree.bin.5 new file mode 100644 index 0000000..736af62 Binary files /dev/null and b//nfree.bin.5 differ diff --git a//nfree.mcr052.1 b//nfree.mcr052.1 new file mode 100644 index 0000000..aa7b707 --- /dev/null +++ b//nfree.mcr052.1 @@ -0,0 +1,276 @@ + +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 +  \ No newline at end of file diff --git a//nfree.mid.53 b//nfree.mid.53 new file mode 100644 index 0000000..be431d4 --- /dev/null +++ b//nfree.mid.53 @@ -0,0 +1,281 @@ + +TITLE MODIFIED AFREE FOR MUDDLE + +RELOCATABLE + +.INSRT MUDDLE > + +.GLOBAL CAFREE,CAFRET,PARNEW,AGC,PARBOT,CODTOP,CAFRE1 +.GLOBAL STOGC,STOSTR,CAFRE,ISTOST,STOLST,SAT,ICONS,BYTDOP +.GLOBAL FLIST,STORIC,GPURFL,GCDANG,PVSTOR,SPSTOR +.GLOBAL %CLNCO + +MFUNCTION FREEZE,SUBR + + ENTRY 1 + + GETYP A,(AB) ; get type of it + PUSH TP,(AB) ; save a copy + PUSH TP,1(AB) + PUSH P,[0] ; flag for tupel freeze + PUSHJ P,SAT ; to SAT + MOVEI B,0 ; final type + CAIN A,SNWORD ; check valid types + MOVSI B,TUVEC ; use UVECTOR + CAIN A,S2NWOR + MOVSI B,TVEC + CAIN A,SARGS + MOVSI B,TVEC + CAIN A,SCHSTR + MOVSI B,TCHSTR + CAIN A,SBYTE + MOVEI B,TBYTE + JUMPE B,WTYP1 + PUSH P,B ; save final type + CAMN B,$TBYTE + JRST .+3 + CAME B,$TCHSTR ; special chars hack + JRST OK.FR + HRR B,(AB) ; fixup count + MOVEM B,(P) + + MOVEI C,(TB) ; point to it + PUSHJ P,BYTDOP ; A==> points to dope word + HRRO B,1(TB) + SUBI A,1(B) ; A==> length of block + TLC B,-1(A) + MOVEM B,1(TB) ; and save + MOVSI 0,TUVEC + MOVEM 0,(TB) + +OK.FR: HLRE A,1(TB) ; get length + MOVNS A + PUSH P,A + ADDI A,2 + PUSHJ P,CAFREE ; get storage + HRLZ B,1(TB) ; set up to BLT + HRRI B,(A) + POP P,C + ADDI C,(A) ; compute end + BLT B,(C) + HLLOS 1(C) ; INDICATION IN RELOCATION FIELD THAT ITS NOT GARBAGE + MOVEI B,(A) + HLL B,1(AB) + POP P,A + JRST FINIS + + +CAFRE: PUSH P,A + HRRZ E,STOLST+1 + SETZB C,D + PUSHJ P,ICONS ; get list element + PUSH TP,$TLIST ; and save + PUSH TP,B + MOVE A,(P) ; restore length + ADDI A,2 ; 2 more for dope words + PUSHJ P,CAFREE ; get the core and dope words + POP P,B ; restore count + MOVNS B ; build AOBJN pointer + MOVSI B,(B) + HRRI B,(A) + MOVE C,(TP) + MOVEM B,1(C) ; save on list + MOVSI 0,TSTORA ; and type + HLLM 0,(C) + HRRZM C,STOLST+1 ; and save as new list + SUB TP,[2,,2] + POPJ P, + +CAFRE1: PUSH P,A + ADDI A,2 + PUSHJ P,CAFREE + HRROI B,(A) ; pointer to B + POP P,A ; length back + TLC B,-1(A) + POPJ P, + +CAFREE: IRP AC,,[B,C,D,E] + PUSH P,AC + TERMIN + SKIPG A ; make sure arg is a winner + FATAL BAD CALL TO CAFREE + MOVSI A,(A) ; count to left half for search + MOVEI B,FLIST ; get first pointer + HRRZ C,(B) ; c points to next block +CLOOP: CAMG A,(C) ; skip if not big enough + JRST CONLIS ; found one + MOVEI D,(B) ; save in case fall out + MOVEI B,(C) ; point to new previous + HRRZ C,(C) ; next block + JUMPN C,CLOOP ; go on through loop + HLRZ E,A ; count to E + CAMGE E,STORIC ; skip if a area or more + MOVE E,STORIC ; else use a whole area + MOVE C,PARBOT ; found out if any funny space + SUB C,CODTOP ; amount around to C + EXCH B,D + CAMLE C,E ; skip if must GC + JRST CHAVIT ; already have it + SUBI E,-1(C) ; get needed from agc + MOVEM E,PARNEW ; funny arg to AGC + PUSH P,A + MOVE C,[7,,6] ; SET UP AGC INDICATORS + SKIPE GPURFL ; DONT GC IF IN DUMPER + JRST PURGC + PUSHJ P,AGC ; collect that garbage + SETZM PARNEW ; dont do it again + POP P,A + +; Make sure pointers still good after GC + + MOVEI B,FLIST + HRRZ D,(B) + + HRRZ E,(D) ; next pointer + JUMPE E,.+4 ; end of list ok + MOVEI B,(D) + MOVEI D,(E) + JRST .-4 ; look at next + +CHAVIT: MOVE C,CODTOP + MOVE E,PARBOT + PUSHJ P,%CLNCO ; flush extra pages + MOVE E,PARBOT ; find amount obtained + SUBI E,1 ; dont use a real pair + MOVEI C,(E) ; for reset of CODTOP + SUB E,CODTOP + EXCH C,CODTOP ; store it back + CAIE B,(C) ; did we simply grow the last block? + JRST CSPLIC ; no, splice it in + HLRZ C,(B) ; length of old guy + ADDI C,(E) ; total length + ADDI B,(E) ; point to new last dope word + HRLZM C,(B) ; clobber final length in + HRRM B,(D) ; and splice into free list + MOVEI C,(B) ; reset acs for reentry into loop + MOVEI B,(D) + JRST CLOOP + +; Here to splice new core onto end of list. + +CSPLIC: MOVE C,CODTOP ; point to end of new block + HRLZM E,(C) ; store length of new block in dope words + HRRM C,(D) ; D is old previous, link it up + MOVEI B,(D) ; and reset B for reentry into loop + JRST CLOOP + +; here if an appropriate block is on the list + +CONLIS: HLRZS A ; count back to a rh + HLRZ D,(C) ; length of proposed block to D + CAIN A,(D) ; skip if they are different + JRST CEASY ; just splice it out + MOVEI B,(C) ; point to block to be chopped up + SUBI B,-1(D) ; point to beginning of same + SUBI D,(A) ; amount of block to be left to D + HRLM D,(C) ; and fix up dope words + ADDI B,-1(A) ; point to end of same + HRLZM A,(B) + HRRM B,(B) ; for GC benefit + +CFREET: CAIE A,1 ; if more than 1 + SETZM -1(B) ; make tasteful dope worda + SUBI B,-1(A) + MOVEI A,(B) +ACRST: IRP AC,,[E,D,C,B] + POP P,AC + TERMIN + POPJ P, + +PURGC: SUB P,[1,,1] ; CLEAN OFF STACK + SETOM GCDANG ; INDICATE GC SHOULD HAVE OCCURED + JRST ACRST + +CEASY: MOVEI D,(C) ; point to block to return + HRRZ C,(C) ; point to next of same + HRRM C,(B) ; smash its previous + MOVEI B,(D) ; point to block with B + HRRM B,(B) ; for GC benefit + JRST CFREET + +CAFRET: HRROI B,(B) ; prepare to search list + TLC B,-1(A) ; by making an AOBJN pointer + HRRZ C,STOLST+1 ; start of list + MOVEI D,STOLST+1 + +CAFRTL: JUMPE C,CPOPJ ; not founc + CAME B,1(C) ; this it? + JRST CAFRT1 + HRRZ C,(C) ; yes splice it out + HRRM C,(D) ; smash it +CPOPJ: POPJ P, ; dont do anything now + +CAFRT1: MOVEI D,(C) + HRRZ C,(C) + JRST CAFRTL + +; Here from GC to collect all unused blocks into free list + +STOGC: SETZB C,E ; zero current length and pointer + MOVE A,CODTOP ; get high end of free space + +STOGCL: CAIG A,STOSTR ; end? + JRST STOGCE ; yes, cleanup and leave + + HLRZ 0,(A) ; get length + ANDI 0,377777 + SKIPGE (A) ; skip if a not used block + JRST STOGC1 ; jump if marked + +; HERE TO SEE WHETHER AN UNMARKED ITEM IS AN ATOM. IF IT IS IT IS NOT GARBAGE +; AND IT IS PRESERVED WITH ITS VALUE CELLS FLUSHED + + HLRZ 0,-1(A) ; GET TYPE OF FIRST D.W. + ANDI 0,TYPMSK ; FLUSH MONITORS + CAIE 0,SATOM + JRST STOGC5 ; NOT AN ATOM COLLECT THE GARBAGE + PUSH P,A ; SAVE PTR TO D.W. + HLRZ 0,(A) + SUB A,0 ; POINT TO JUST BEFORE ATOM + SETZM 1(A) ; ZERO VALUE CELLS + SETZM 2(A) + POP P,A ; RESTORE A + JRST STOGC1 + +STOGC5: HLRZ 0,(A) + JUMPE C,STOGC3 ; jump if no block under construction + ADD C,0 ; else add this length to current + JRST STOGC4 + +STOGC3: MOVEI B,(A) ; save pointer + MOVE C,0 ; init length + +STOGC4: SUB A,0 ; point to next block + JRST STOGCL + +STOGC1: HLLOS (A) ; -1 IS INDICATOR OF FREE SLOT + ANDCAM D,(A) ; kill mark bit + JUMPE C,STOGC4 ; if no block under cons, dont fix + HRLM C,(B) ; store total block length + HRRM E,(B) ; next pointer hooked in + MOVEI E,(B) ; new next pointer + MOVEI C,0 + JRST STOGC4 + +STOGCE: JUMPE C,STGCE1 ; jump if no current block + HRLM C,(B) ; smash in count + HRRM E,(B) ; smash in next pointer + MOVEI E,(B) ; and setup E + +STGCE1: HRRZM E,FLIST+1 ; final link up + POPJ P, + +IMPURE + +FLIST: .+1 + ISTOST + +PURE + +END + \ No newline at end of file diff --git a//oreadch.mid.208 b//oreadch.mid.208 new file mode 100644 index 0000000..6c2c33a --- /dev/null +++ b//oreadch.mid.208 @@ -0,0 +1,1433 @@ +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, + +; 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 + +; 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 + +; 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,,^ _ + +; 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 + +; 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, + +; 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 // ; ITS SOFTWARE + ASCII // ; DATAMEDIA + ASCII /HJ/ ; HP2640 + 0 + 0 + 0 + 0 + ASCII /HJ/ ; VT50 + 0 + ASCII /(/ ; GT40 + 0 + ASCII /HJ/ ; VT52 + 0 + 0 + ASCII /HJ/ ; VT100 + ASCII /HJ/ ; TELERAY + ASCII /HJ/ ; 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 / / ; ITS SOFTWARE DISPLAY + 0 + ASCII /DK/ ; HP2640 + 0 + 0 + 0 + 0 + ASCII /DK/ ; VT50 + 0 + 0 + 0 + ASCII /DK/ ; VT52 + 0 + 0 + ASCII /DK/ ; VT100 + ASCII /DK/ ; TELERAY + ASCII /DK/ ; 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 // ; ITS SOFTWARE DISPLAY + 0 + ASCII /K/ ; HP2640 + 0 + 0 + 0 + 0 + ASCII /K/ ; VT50 + 0 + 0 + 0 + ASCII /K/ ; VT52 + 0 + 0 + ASCII /K/ ; VT100 + ASCII /K/ ; TELERAY + ASCII /K/ ; 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 +/ + + + + +; 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, +] + +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, + +; 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, +] + +; 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_]] + 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 + \ No newline at end of file diff --git a//primit.bin.5 b//primit.bin.5 new file mode 100644 index 0000000..e935da6 Binary files /dev/null and b//primit.bin.5 differ diff --git a//primit.mid.315 b//primit.mid.315 new file mode 100644 index 0000000..5e79bde --- /dev/null +++ b//primit.mid.315 @@ -0,0 +1,2822 @@ +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 + + +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 + + + +; 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 + + + +; 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 + + + + +; 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 + ;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____ + 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 + + +; 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, + + +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 + + + +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 + + + + +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) + + +; 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, + +; 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, + + + +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, + + +; 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]] + + +; 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 + +; 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 + + +; 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, + + +; 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, + + +; 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, + + +; 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, + + + + +; 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 + + ; 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 + +; SMON -- SET MONITOR BITS +; B/ +; D/ OR +; 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]] + + +; 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, + + +; 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 + +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 + + +; 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, + + + +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 + + + +; 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 + + + + 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 + +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 + + ;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 + + ;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 + \ No newline at end of file diff --git a//primit.mid.316 b//primit.mid.316 new file mode 100644 index 0000000..4147a23 --- /dev/null +++ b//primit.mid.316 @@ -0,0 +1,2830 @@ +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 + + +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 + + + +; 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 + + + +; 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 + + + + +; 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 + ;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____ + 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 + + +; 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, + + +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 + + + +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 + + + + +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) + + +; 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, + +; 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, + + + +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, + + +; 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]] + + +; 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 + +; 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 + + +; 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, + + +; 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, + + +; 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, + + +; BNTH -- NTH A BYTE STRING + +BNTH: PUSHJ P,BTAT +BINN: PUSH P,$TFIX + JRST SIN1 + +; SNTH -- NTH A STRING + +SNTH: PUSHJ P,STAT +SIN: PUSH P,$TCHRS +SIN1: PUSH TP,A + PUSH TP,B ; SAVE POINT BYTER + MOVEI C,-1(TP) ; FIND DOPE WORD + PUSHJ P,BYTDOP + HLLZ 0,-1(A) ; GET + POP TP,B + POP TP,A + PUSHJ P,RMONCH + ILDB B,B ; GET CHAR + POP P,A + POPJ P, + +; TIN -- IN OF A TEMPLATE + +TIN: MOVEI C,0 + +; TMPLNT -- NTH A TEMPLATE DATA STRUCTURE + +TMPLNT: ADDI C,1 + PUSHJ P,TM.TOE ; GET POINTER TO INS IN E + ADD A,TD.GET+1 ; POINT TO GETTER + MOVE A,(A) ; GET VECTOR OF INS + ADDI E,-1(A) ; POINT TO INS + SUBI D,1 + XCT (E) ; DO IT + JFCL ; SKIP IF AN ANY CASE + POPJ P, ; RETURN + +; LPUT -- PUT ON A LIST + +LPUT: PUSHJ P,LAT ; POSITION + POP TP,D + POP TP,C + +; LSTUF -- HERE TO STUFF A LIST ELEMENT + +LSTUF: PUSHJ P,MONCH0 ; CHECK OUT MONITOR BITS + GETYP A,C ; ISOLATE TYPE + PUSHJ P,NWORDT ; NEED TO DEFER? + SOJN A,DEFSTU + HLLM C,(B) + MOVEM D,1(B) ; AND VAL + POPJ P, + +DEFRCY: MOVE E,1(B) ; RECYCLE THIS HANDY DEFER + MOVEM C,(E) + MOVEM D,1(E) + POPJ P, + +DEFSTU: GETYP A,(B) + CAIN A,TDEFER + JRST DEFRCY + PUSH TP,$TLIST + PUSH TP,B + PUSH TP,C + PUSH TP,D + PUSHJ P,CELL2 ; GET WORDS + POP TP,1(B) + POP TP,(B) + MOVE E,(TP) + SUB TP,[2,,2] + MOVEM B,1(E) + HLLZ 0,(E) ; GET OLD MONITORS + TLZ 0,TYPMSK ; KILL TYPES + TLO 0,TDEFER ; MAKE DEFERRED + HLLM 0,(E) + POPJ P, + +; VPUT -- PUT ON A VECTOR , APUT -- PUT ON AN RG BLOCK + +APUT: PUSHJ P,AAT + JRST .+2 + +VPUT: PUSHJ P,VAT ; TREAT LIKE VECTOR + POP TP,D ; GET GOODIE BACK + POP TP,C + +; AVSTUF -- CLOBBER ARGS AND VECTORS + +ASTUF: +VSTUF: PUSHJ P,MONCH0 + MOVEM C,(B) + MOVEM D,1(B) + POPJ P, + + + + +; 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 + + ; 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 + +; SMON -- SET MONITOR BITS +; B/ +; D/ OR +; 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]] + + +; 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, + + +; 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 + +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 + + +; 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, + + + +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 + + + +; 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 + + + + 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 + +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 + + ;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 + + ;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 + \ No newline at end of file diff --git a//print.bin.11 b//print.bin.11 new file mode 100644 index 0000000..d18dc04 Binary files /dev/null and b//print.bin.11 differ diff --git a//print.bin.9 b//print.bin.9 new file mode 100644 index 0000000..5929247 Binary files /dev/null and b//print.bin.9 differ diff --git a//print.mid.340 b//print.mid.340 new file mode 100644 index 0000000..770b48f --- /dev/null +++ b//print.mid.340 @@ -0,0 +1,2692 @@ +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 + + + MFUNCTION 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 + 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 + 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 + + +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, + + + ;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 + + +; 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 + +; 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 + + + +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 + PUSH TP,B + PUSH P,0 ; ATOM CALLER ROUTINE + PUSH P,C + JRST PATOM + +CPCHST: PUSH TP,A ; COPY ARGS FOR INTERNAL SAKE + PUSH TP,B + PUSH P,0 ; STRING CALLER ROUTINE + PUSH P,C + JRST PCHSTR + + + +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, + + +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 + + ; 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 + ; 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 + + ; 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 + 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 + + + ; 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 + + ; 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 + + + ; 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 /###/ + ASCII /##/ + ASCII /#/ + +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, + + + ; 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 /% + PUSHJ P,PRETIF + JRST PNEXT + +; HERE TO DO OFFSETS: %> + +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 + + ; 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 + ;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 + + + ;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 + + ;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*" + + ;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 + + ;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 + +; 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: "- + "+ + + +;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 + + + ;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 + + + ; 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 + + ;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, + + + +; 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 + + ;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 + + ;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 + + ;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 + + + +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 + \ No newline at end of file diff --git a//print.mid.346 b//print.mid.346 new file mode 100644 index 0000000..4e295bd --- /dev/null +++ b//print.mid.346 @@ -0,0 +1,2711 @@ +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 + + + MFUNCTION 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 + 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 + 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 + + +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, + + + ;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 + + +; 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 + +; 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 + + + +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 + PUSH TP,B + PUSH P,0 ; ATOM CALLER ROUTINE + PUSH P,C + SKIPN C,PRNTYP+1 + JRST PATOM + ADDI C,TATOM+TATOM + SKIPE (C) ; SKIP IF UNCHANGED PRINT TYPE OR DISPATCH + JRST PRDIS1 + SKIPN C,1(C) + JRST PATOM + JRST (C) + +CPCHST: PUSH TP,A ; COPY ARGS FOR INTERNAL SAKE + PUSH TP,B + PUSH P,C ; STRING CALLER ROUTINE + PUSH P,FLAGS + SKIPN C,PRNTYP+1 + JRST PATOM + ADDI C,TCHSTR+TCHSTR + SKIPE (C) ; SKIP IF UNCHANGED PRINT TYPE OR DISPATCH + JRST PRDIS1 + SKIPN C,1(C) + JRST PCHSTR + JRST (C) + + + +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, + + +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 + + ; 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 + ; 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 + + ; 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 + 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 + + + ; PRINT SUB-ENTRY TO RSUBR + +PENTRY: MOVE B,(TP) ; GET BLOCK + GETYP A,(B) ; TYPE OF 1ST ELEMENT + CAIE A,TRSUBR ; RSUBR, OK + JRST PENT1 +PENT2: MOVEI A,2 ; CHECK ROOM + MOVE B,-2(TP) ; GET CHANNEL INTO B + PUSHJ P,RETIF + MOVEI A,"% ; SETUP READ TIME MACRO + PUSHJ P,PITYO + MOVEI A,"< + PUSHJ P,PITYO + MOVSI A,TATOM + MOVE B,IMQUOTE RSUBR-ENTRY + PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT + PUSH TP,-3(TP) + PUSHJ P,IPRINT + MOVE B,-4(TP) + PUSHJ P,SPACEQ ; MAYBE SPACE + MOVEI A,"' ; QUOTE TO AVOID EVALING IT + PUSHJ P,PRETIF + MOVEI A,"[ ; OPEN SQUARE BRAKET + PUSHJ P,PRETIF + MOVE B,-2(TP) + GETYP A,(B) + CAIN A,TRSUBR + JRST PENT3 + MOVE A,(B) + MOVE B,1(B) + PUSHJ P,IPRINT + MOVE B,-4(TP) ; MOVE IN CHANNEL + JRST PENT4 +PENT3: MOVE A,1(B) + MOVE B,3(A) + MOVSI A,TATOM ; FOOL EVERYBODY AND SEND OUT ATOM + PUSHJ P,IPRINT + MOVE B,-4(TP) ; PRINT SPACE +PENT4: PUSHJ P,SPACEQ + MOVE B,-2(TP) ; GET PTR BACK TO VECTOR + MOVE A,2(B) ; THE NAME OF THE ENTRY + MOVE B,3(B) + PUSHJ P,IPRINT ; OUT IT GOES + HLRZ B,-2(TP) + CAIL B,-4 ; SEE IF DONE + JRST EXPEN + MOVE B,-4(TP) ; PRINT SPACE + PUSHJ P,SPACEQ + MOVE B,-2(TP) ; GET POINTER + MOVE A,4(B) ; DECL + MOVE B,5(B) + PUSHJ P,IPRINT +EXPEN: MOVE B,-4(TP) ; GET CHANNEL INTO B + MOVEI A,"] ; CLOSE SQUARE BRAKET + PUSHJ P,PRETIF + MOVE B,-4(TP) ; GET CHANNEL INTO B + PUSHJ P,SPACEQ + MOVE B,-2(TP) + HRRZ B,2(B) + MOVSI A,TFIX + PUSHJ P,IPRINT + MOVEI A,"> + SUB TP,[2,,2] ; POP CHANNEL OFF STACK + MOVE B,-2(TP) ; GET CHANNEL INTO B + PUSHJ P,PRETIF + JRST PNEXT + +PENT1: CAIN A,TATOM + JRST PENT2 + ERRUUO EQUOTE BAD-ENTRY-BLOCK + + ; 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 + + + ; 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 /###/ + ASCII /##/ + ASCII /#/ + +PFIXU4: HRRZ E,(C) ; GET CURRENT VAL + MOVE E,1(E) + MOVEM C,-2(TP) + PUSHJ P,ATOSQ ; GET SQUOZE + JRST BADFXU + TLO E,400000 ; USE TO DIFFERENTIATE BETWEEN STRING + PUSHJ P,EOUT + MOVE C,-2(TP) + +; HERE TO WRITE OUT LISTS + +PFIXU5: HRRZ C,(C) ; POINT TO CURRENT VALUE + HRLZ E,1(C) + HRRZ C,(C) ; POINT TO USES LIST + HRRZ D,1(C) ; GET IT + MOVEM C,-2(TP) + +PFIXU6: TLCE D,400000 ; SKIP FOR RH + HRLZ E,1(D) ; SETUP LH + JUMPG D,.+3 + HRR E,1(D) + PUSHJ P,EOUT ; WRITE IT OUT + HRR D,(D) + TRNE D,-1 ; SKIP IF DONE + JRST PFIXU6 + + TRNE E,-1 ; SKIP IF ZERO BYTE EXISTS + MOVEI E,0 + PUSHJ P,EOUT + MOVE C,-2(TP) + JRST PFIXU2 ; DO NEXT + +PFIXU3: HLRE C,(TP) ; -AMNT LEFT IN BUFFER + MOVN D,C ; PLUS SAME + ADDI C,BUFLNT ; WORDS USED TO C + JUMPE C,PFIXU7 ; NONE USED, LEAVE + MOVSS C ; START SETTING UP BTB + MOVN A,C ; ALSO FINAL IOT POINTER + HRR C,(TP) ; PDL POINTER PART OF BTB + SUBI C,1 + HRLI D,400000+C ; CONTINUE SETTING UP BTB (400000 IS FOR MULTI + ; SEGS + POP C,@D ; MOVE 'EM DOWN + TLNE C,-1 + JRST .-2 + HRRI A,@D ; OUTPUT POINTER + ADDI A,1 + MOVSI B,TUVEC + MOVE PVP,PVSTOR+1 + MOVEM B,ASTO(PVP) + MOVE B,-6(TP) + PUSHJ P,DOIOTO ; WRITE IT OUT + MOVE PVP,PVSTOR+1 + SETZM ASTO(PVP) + +PFIXU7: SUB TP,[4,,4] + SUB P,[2,,2] + JRST PNEXT + +; ROUTINE TO OUTPUT CONTENTS OF E + +EOUT: MOVE B,-6(TP) ; CHANNEL + AOS ACCESS(B) + MOVE A,(TP) ; BUFFER POINTER + MOVEM E,(A) + AOBJP A,.+3 ; COUNT AND GO + MOVEM A,(TP) + POPJ P, + + SUBI A,BUFLNT ; SET UP IOT POINTER + HRLI A,-BUFLNT + MOVEM A,(TP) ; RESET SAVED POINTER + MOVSI 0,TUVEC + MOVE PVP,PVSTOR+1 + MOVEM 0,ASTO(PVP) + MOVSI 0,TLIST + MOVEM 0,DSTO(PVP) + MOVEM 0,CSTO(PVP) + PUSHJ P,DOIOTO ; OUT IT GOES + MOVE PVP,PVSTOR+1 + SETZM ASTO(PVP) + SETZM CSTO(PVP) + SETZM DSTO(PVP) + POPJ P, + +; HERE IF UVECOR FORM OF FIXUPS + +UFIXES: PUSH TP,$TUVEC + PUSH TP,A ; SAVE IT + +UFIX1: MOVE B,-6(TP) ; GET SAME + PUSHJ P,BFCLS1 ; FLUSH OUT BUFFER + HLRE C,(TP) ; GET LENGTH + MOVMS C + PUSH P,C + HRROI A,(P) ; READY TO ZAP IT OUT + PUSHJ P,DOIOTO ; ZAP! + SUB P,[1,,1] + HLRE C,(TP) ; LENGTH BACK + MOVMS C + ADDI C,1 + ADDM C,ACCESS(B) ; UPDATE ACCESS + MOVE A,(TP) ; NOW THE UVECTOR + MOVSI C,TUVEC + MOVE PVP,PVSTOR+1 + MOVEM C,ASTO(PVP) + PUSHJ P,DOIOTO ; GO + MOVE PVP,PVSTOR+1 + SETZM ASTO(PVP) + SUB P,[1,,1] + SUB TP,[4,,4] + JRST PNEXT + +RCANT: ERRUUO EQUOTE RSUBR-LACKS-FIXUPS + + +BADFXU: ERRUUO EQUOTE BAD-FIXUPS + +PRBODY: TDZA C,C ; FLAG SAYING FLUSH CODE +PRBOD1: MOVEI C,1 ; PRINT CODE ALSO + PUSH P,FLAGS + PUSH TP,$TRSUBR + PUSH TP,B + PUSH P,C + MOVEI A,"[ ; START VECTOR TEXT + MOVE B,-6(TP) ; GET CHANNEL FOR PITYO + PUSHJ P,PITYO + POP P,C + MOVE B,(TP) ; RSUBR BACK + JUMPN C,PRSON ; GO START PRINTING + MOVEI A,"0 ; PLACE SAVER FOR CODE VEC + MOVE B,-6(TP) ; GET CHANNEL FOR PITYO + PUSHJ P,PITYO + +PRSBR2: MOVE B,[2,,2] ; BUMP VECTOR + ADDB B,(TP) + JUMPGE B,PRSBR3 ; NO SPACE IF LAST + MOVE B,-6(TP) ; GET CHANNEL FOR SPACEQ + PUSHJ P,SPACEQ + SKIPA B,(TP) ; GET BACK POINTER +PRSON: JUMPGE B,PRSBR3 + GETYP 0,(B) ; SEE IF RSUBR POINTED TO + CAIE 0,TQENT + CAIN 0,TENTER + JRST .+5 ; JUMP IF RSUBR ENTRY + CAIN 0,TQRSUB + JRST .+3 + CAIE 0,TRSUBR ; YES! + JRST PRSB10 ; COULD BE SUBR/FSUBR + MOVE C,1(B) ; GET RSUBR + PUSH P,0 ; SAVE TYPE FOUND + GETYP 0,2(C) ; SEE IF ATOM + CAIE 0,TATOM + JRST PRSBR4 + MOVE B,3(C) ; GET ATOM NAME + PUSHJ P,IGVAL ; GO LOOK + MOVE C,(TP) ; ORIG RSUBR BACK + GETYP A,A + POP P,0 ; DESIRED TYPE + CAIE 0,(A) ; SAME TYPE + JRST PRSBR4 + MOVE D,1(C) + MOVE 0,3(D) ; NAME OF RSUBR IN QUESTION + CAME 0,3(B) ; WIN? + JRST PRSBR4 + HRRZ E,C + MOVSI A,TATOM + MOVE B,0 ; GET ATOM + MOVE FLAGS,(P) + JRST PRS101 + +PRSBR4: MOVE FLAGS,(P) ; RESTORE FLAGS + MOVE B,(TP) + MOVE A,(B) + MOVE B,1(B) ; PRINT IT +PRS101: PUSH TP,-7(TP) ; PUSH CHANNEL FOR IPRINT + PUSH TP,-7(TP) + PUSHJ P,IPRINT + SUB TP,[2,,2] ; POP OFF CHANNEL + MOVE B,-2(TP) ; MOVE IN CHANNEL + JRST PRSBR2 + +PRSB10: CAIE 0,TSUBR ; SUBR? + CAIN 0,TFSUBR + JRST .+2 + JRST PRSBR4 + MOVE C,1(B) ; GET LOCN OF SUBR OR FSUBR + MOVE B,@-1(C) ; NAME OF IT + MOVSI A,TATOM ; AND TYPE + JRST PRS101 + +PRSBR3: MOVEI A,"] + MOVE B,-6(TP) + PUSHJ P,PRETIF ; CLOSE IT UP + SUB TP,[2,,2] ; FLUSH CRAP + POP P,FLAGS + POPJ P, + + + ; 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 /% + PUSHJ P,PRETIF + JRST PNEXT + +; HERE TO DO OFFSETS: %> + +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 + + ; 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 + ;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 + + + ;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 + + ;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*" + + ;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 + + ;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 + +; 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: "- + "+ + + +;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 + + + ;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 + + + ; 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 + + ;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, + + + +; 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 + + ;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 + + ;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 + + ;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 + + + +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 + \ No newline at end of file diff --git a//pure.bin.5 b//pure.bin.5 new file mode 100644 index 0000000..212ce00 Binary files /dev/null and b//pure.bin.5 differ diff --git a//pure.mid.15 b//pure.mid.15 new file mode 100644 index 0000000..0a263b5 --- /dev/null +++ b//pure.mid.15 @@ -0,0 +1,24 @@ + +TITLE SETPUR + +1PASS + +BOT==700000 + +.GLOBAL .LPUR,.LIMPU,HIBOT,PHIBOT,REALGC,THIBOT +REALGC==200000 + +LOC 140 + +.LIMPU==140 + +HIBOT==BOT +PHIBOT==BOT_<-10.> +THIBOT==BOT_<-9.> + +.LPUR==BOT + +LOC BOT + +END +  \ No newline at end of file diff --git a//putget.bin.3 b//putget.bin.3 new file mode 100644 index 0000000..275cac7 Binary files /dev/null and b//putget.bin.3 differ diff --git a//putget.mid.51 b//putget.mid.51 new file mode 100644 index 0000000..9d3901b --- /dev/null +++ b//putget.mid.51 @@ -0,0 +1,397 @@ + +TITLE GETPUT ASSOCIATION FUNCTIONS FOR MUDDLE + +RELOCATABLE + +.INSRT MUDDLE > + +; COMPONENTS IN AN ASSOCIATION BLOCK + +ITEM==0 ;ITEM TO WHICH INDUCATOR APPLIES +VAL==2 ;VALUE +INDIC==4 ;INDICATOR +NODPNT==6 ;IF NON ZERO POINTS TO CHAIN +PNTRS==7 ;POINTERS NEXT (RH) AND PREV (LH) + +ASOLNT==8 ;NUMBER OF WORDS IN AN ASSOCIATION BLOCK + +.GLOBAL ASOVEC ;POINTER TO HASH VECTOR IN TV +.GLOBAL ASOLNT,ITEM,INDIC,VAL,NODPNT,NODES,IPUTP,IGETP,PUT,IFALSE +.GLOBAL DUMNOD,IGETLO,IBLOCK,MONCH,RMONCH,IPUT,IGETL,IREMAS,IGET +.GLOBAL NWORDT,CIGETP,CIGTPR,CIPUTP,CIREMA,MPOPJ,PVSTOR,SPSTOR + +MFUNCTION GETP,SUBR,[GETPROP] + + ENTRY + +IGETP: PUSHJ P,GETLI + JRST FINIS ; NO SKIP, LOSE + MOVSI A,TLOCN + HLLZ 0,VAL(B) + PUSHJ P,RMONCH ; CHECK MONITOR + MOVE A,VAL(B) ;ELSE RETURN VALUE + MOVE B,VAL+1(B) +CFINIS: JRST FINIS + +; FUNCTION TO RETURN LOCATIVE TO ASSOC + +MFUNCTION GETPL,SUBR + + ENTRY + +IGETLO: PUSHJ P,GETLI + JRST FINIS + MOVSI A,TLOCN + JRST FINIS + +GETLI: PUSHJ P,2OR3 ; GET ARGS + PUSHJ P,IGETL ;SEE IF ASSOCIATION EXISTS + SKIPE B + AOS (P) ; WIN RETURN + CAMGE AB,[-4,,0] ; ANY ERROR THING + JUMPE B,CHFIN ;IF 0, NONE EXISTS + POPJ P, + +CHFIN: PUSH TP,4(AB) + PUSH TP,5(AB) + MCALL 1,EVAL + POPJ P, + +; COMPILER CALLS TO SOME OF THESE + +CIGETP: SUBM M,(P) ; FIX RET ADDR + PUSHJ P,IGETL ; GO TO INTERNAL + JUMPE B,MPOPJ + MOVSI A,TLOCN +MPOPJ1: SOS (P) ; WINNER (SOS BECAUSE OF SUBM M,(P)) +MPOPJ: SUBM M,(P) + POPJ P, + +CIGTPR: SUBM M,(P) + PUSHJ P,IGETL + JUMPE B,MPOPJ + MOVE A,VAL(B) ; GET VAL TYPE + MOVE B,VAL+1(B) + JRST MPOPJ1 + +CIPUTP: SUBM M,(P) + PUSH TP,-1(TP) ; SAVE VAL + PUSH TP,-1(TP) + PUSHJ P,IPUT ; DO IT + POP TP,B + POP TP,A + JRST MPOPJ + +CIREMA: SUBM M,(P) + PUSHJ P,IREMAS ; FLUSH IT + JRST MPOPJ + +; CHECK PUT/GET PUTPROP AND GETPROP ARGS + +2OR3: HLRE 0,AB + ASH 0,-1 ; TO -# OF ARGS + ADDI 0,2 ; AT LEAST 2 + JUMPG 0,TFA ; 1 OR LESS, LOSE + AOJL 0,TMA ; 4 OR MORE, LOSE + MOVE A,(AB) ; GET ARGS INTO ACS + MOVE B,1(AB) + MOVE C,2(AB) + MOVE D,3(AB) + POPJ P, + +; INTERNAL GET + +IGET: PUSHJ P,IGETL ; GET LOCATIVE + JUMPE B,CPOPJ + MOVE A,VAL(B) + MOVE B,VAL+1(B) + POPJ P, + +; FUNCTION TO MAKE AN ASSOCIATION + +MFUNCTION PUTP,SUBR,[PUTPROP] + + ENTRY + +IPUTP: PUSHJ P,2OR3 ; GET ARGS + JUMPN 0,REMAS ; REMOVE AN ASSOCIATION + PUSH TP,4(AB) ; SAVE NEW VAL + PUSH TP,5(AB) + PUSHJ P,IPUT ; DO IT + MOVE A,(AB) ; RETURN NEW VAL + MOVE B,1(AB) + JRST FINIS + +REMAS: PUSHJ P,IREMAS + JRST FINIS + +IPUT: SKIPN DUMNOD+1 ; NEW DUMMY NEDDED? + PUSHJ P,DUMMAK ; YES, GO MAKE ONE +IPUT1: PUSHJ P,IGETI ;SEE IF THIS ONE EXISTS + + JUMPE B,NEWASO ;JUMP IF NEED NEW ASSOCIATION BLOCK +CLOBV: MOVE C,-5(TP) ; RET NEW VAL + MOVE D,-4(TP) + SUB TP,[6,,6] + HLLZ 0,VAL(B) + MOVSI A,TLOCN + PUSHJ P,MONCH ; MONITOR CHECK + MOVEM C,VAL(B) ;STORE IT + MOVEM D,VAL+1(B) +CPOPJ: POPJ P, + +; HERE TO CREATE A NEW ASSOCIATION + +NEWASO: MOVE B,DUMNOD+1 ; GET BALNK ASSOCIATION + SETZM DUMNOD+1 ; CAUSE NEW ONE NEXT TIME + + +;NOW SPLICE IN CHAIN + + JUMPE D,PUT1 ;NO OTHERS EXISTED IN THIS BUCKET + HRLZM C,PNTRS(B) ;CLOBBER PREV POINTER + HRRM B,PNTRS(C) ;AND NEXT POINTER + JRST .+2 + +PUT1: HRRZM B,(C) ;STORE INTO VECTOR + HRRZ C,NODES+1 + HRLM C,NODPNT(B) + MOVE D,NODPNT(C) + HRRZM B,NODPNT(C) + HRRM D,NODPNT(B) + HRLM B,NODPNT(D) + MOVEI C,-3(TP) ;COPY ARG POINTER + MOVSI A,-4 ;AND COPY POINTER + +PUT2: MOVE D,(C) ;START COPYING + MOVEM D,@CLOBTB(A) + ADDI C,1 + AOBJN A,PUT2 ;NOTE *** DEPENDS ON ORDER IN VECTOR *** + + JRST CLOBV + +;HERE TO REMOVE AN ASSOCIATION + +IREMAS: PUSHJ P,IGETL ;LOOK IT UP + JUMPE B,CPOPJ ;NEVER EXISTED, IGNORE + HRRZ A,PNTRS(B) ;NEXT POINTER + HLRZ E,PNTRS(B) ;PREV POINTER + SKIPE A ;DOES A NEXT EXIST? + HRLM E,PNTRS(A) ;YES CLOBBER ITS PREV POINTER + SKIPN D ;SKIP IF NOT FIRST IN BUCKET + MOVEM A,(C) ;FIRST STORE NEW ONE + SKIPE D ;OTHERWISE + HRRM A,PNTRS(E) ;PATCH NEXT POINTER IN PREVIOUS + HRRZ A,NODPNT(B) ;SEE IF MUST UNSPLICE NODE + HLRZ E,NODPNT(B) + SKIPE A + HRLM E,NODPNT(A) ;SPLICE + JUMPE E,PUT4 ;FLUSH IF NO PREV POINTER + HRRZ C,NODPNT(E) ;GET PREV'S NEXT POINTER + CAIE C,(B) ;DOES IT POINT TO THIS NODE + .VALUE [ASCIZ /:FATAL PUT LOSSAGE/] + HRRM A,NODPNT(E) ;YES, SPLICE +PUT4: MOVE A,VAL(B) ;RETURN VALUE + SETZM PNTRS(B) + MOVE B,VAL+1(B) + POPJ P, + + +;INTERNAL GET FUNCTION CALLED BY PUT AND GET +; A AND B ARE THE ITEM +;C AND D ARE THE INDICATOR + +IGETL: PUSHJ P,IGETI + SUB TP,[4,,4] ; FLUSH CRUFT LEFT BY IGETI + POPJ P, + +IGETI: PUSHJ P,LHCLR + EXCH A,C + PUSHJ P,LHCLR + EXCH C,A + PUSH TP,A + PUSH TP,B + PUSH TP,C ;SAVE C AND D + PUSH TP,D + XOR A,B ; BUILD HASH + XOR A,C + XOR A,D + TLZ A,400000 ; FORCE POS A + HLRZ B,ASOVEC+1 ;GET LENGTH OF HASH VECTOR + MOVNS B + IDIVI A,(B) ;RELATIVE BUCKET NOW IN B + HRLI B,(B) ;IN CASE GC OCCURS + ADD B,ASOVEC+1 ;POINT TO BUCKET + MOVEI D,0 ;SET FIRST SWITCH + SKIPN A,(B) ;GET CONTENTS OF BUCKET (DONT SKIP IF EMPTY) + JRST GFALSE + + MOVSI 0,TASOC ;FOR INTGOS, MAKE A TASOC + MOVE PVP,PVSTOR+1 + HLLZM 0,ASTO(PVP) + +IGET1: GETYPF 0,ITEM(A) ;GET ITEMS TYPE + MOVE E,ITEM+1(A) + CAMN 0,-3(TP) ;COMPARE TYPES + CAME E,-2(TP) ;AND VALUES + JRST NXTASO ;LOSER + GETYPF 0,INDIC(A) ;MOW TRY INDICATORS + MOVE E,INDIC+1(A) + CAMN 0,-1(TP) + CAME E,(TP) + JRST NXTASO + + SKIPN D ;IF 1ST THEN + MOVE C,B ;RETURN POINTER IN C + MOVE B,A ;FOUND, RETURN ASSOCIATION + MOVSI A,TASOC +IGRET: MOVE PVP,PVSTOR+1 + SETZM ASTO(PVP) + POPJ P, + +NXTASO: MOVEI D,1 ;SET SWITCH + MOVE C,A ;CYCLE + HRRZ A,PNTRS(A) ;STEP + JUMPN A,IGET1 + + MOVSI A,TFALSE + MOVEI B,0 + JRST IGRET + +GFALSE: MOVE C,B ;PRESERVE VECTOR POINTER + MOVSI A,TFALSE + SETZB B,D + JRST IGRET + +; FUNCTION TO DO A PUT AND ALSO ADD TO THE NODE FOR THIS GOODIE + +REPEAT 0,[ +MFUNCTION PUTN,SUBR + + ENTRY + + CAML AB,[-4,,0] ;WAS THIS A REMOVAL + JRST PUT + + PUSHJ P,IPUT ;DO THE PUT + SKIPE NODPNT(C) ;NODE CHAIN EXISTS? + JRST FINIS + + PUSH TP,$TASOC ;NO, START TO BUILD + PUSH TP,C + SKIPN DUMNOD+1 ; FIX UP DUMMY? + PUSHJ P,DUMMAK +CHPT: MOVE C,$TCHSTR + MOVE D,CHQUOTE NODE + PUSHJ P,IGETL + JUMPE B,MAKNOD ;NOT FOUND, LOSE +NODSPL: MOVE C,(TP) ;HERE TO SPLICE IN NEW NODE + MOVE D,VAL+1(B) ;GET POINTER TO NODE STRING + HRRM D,NODPNT(C) ;CLOBBER + HRLM B,NODPNT(C) + SKIPE D ;SPLICE ONLY IF THERE IS SOMETHING THERE + HRLM C,NODPNT(D) + MOVEM C,VAL+1(B) ;COMPLETE NODE CHAIN + MOVE A,2(AB) ;RETURN VALUE + MOVE B,3(AB) + JRST FINIS + +MAKNOD: PUSHJ P,NEWASO ;GENERATE THE NEW ASSOCIATION + MOVE A,@CHPT ;GET UNIQUE STRING + MOVEM A,INDIC(C) ;CLOBBER IN INDIC + MOVE A,@CHPT+1 + MOVEM A,INDIC+1(C) + MOVE B,C ;POINTER TO B + HRRZ C,NODES+1 ;GET POINTER TO CHAIN OF NODES + HRRZ D,VAL+1(C) ;SKIP DUMMY NODE + HRRM B,VAL+1(C) ;CLOBBER INTO CHAIN + HRRM D,NODPNT(B) + SKIPE D ;SPLICE IF ONLY SOMETHING THERE + HRLM B,NODPNT(D) + HRLM C,NODPNT(B) + MOVSI A,TASOC ;SET TYPE OF VAL TO ASSOCIATION + MOVEM A,VAL(B) + SETZM VAL+1(B) + JRST NODSPL ;GO SPLICE ITEM ONTO NODE +] + +DUMMAK: PUSH TP,A + PUSH TP,B + PUSH TP,C + PUSH TP,D + MOVEI A,ASOLNT + PUSHJ P,IBLOCK + MOVSI A,400000+SASOC+.VECT. + MOVEM A,ASOLNT(B) ;SET SPECIAL TYPE + MOVEM B,DUMNOD+1 + POP TP,D + POP TP,C + POP TP,B + POP TP,A + POPJ P, + +CLOBTB: SETZ ITEM(B) + SETZ ITEM+1(B) + SETZ INDIC(B) + SETZ INDIC+1(B) + SETZ VAL(B) + SETZ VAL+1(B) + +MFUNCTION ASSOCIATIONS,SUBR + + ENTRY 0 + MOVE B,NODES+1 +ASSOC1: MOVSI A,TASOC ; SET TYPE + HRRZ B,NODPNT(B) ; POINT TO 1ST REAL NODE + JUMPE B,IFALSE + JRST FINIS + +; RETURN NEXT ASSOCIATION IN CHAIN OR FALSE + +MFUNCTION NEXT,SUBR + + ENTRY 1 + + GETYP 0,(AB) ; BETTER BE ASSOC + CAIE 0,TASOC + JRST WTYP1 ; LOSE + MOVE B,1(AB) ; GET ARG + JRST ASSOC1 + +; GET ITEM/INDICATOR/VALUE CELLS + +MFUNCTION %ITEM,SUBR,ITEM + + MOVEI B,ITEM ; OFFSET + JRST GETIT + +MFUNCTION INDICATOR,SUBR + + MOVEI B,INDIC + JRST GETIT + +MFUNCTION AVALUE,SUBR + + MOVEI B,VAL +GETIT: ENTRY 1 + GETYP 0,(AB) ; BETTER BE ASSOC + CAIE 0,TASOC + JRST WTYP1 + ADD B,1(AB) ; GET ARG + MOVE A,(B) + MOVE B,1(B) + JRST FINIS + +LHCLR: PUSH P,A + GETYP A,A + PUSHJ P,NWORDT ; DEFERRED ? + SOJE A,LHCLR2 + POP P,A +LHCLR1: TLZ A,TYPMSK#<-1> + POPJ P, +LHCLR2: POP P,A + HLLZS A + JRST LHCLR1 + +END + \ No newline at end of file diff --git a//pxcore.bin.2 b//pxcore.bin.2 new file mode 100644 index 0000000..36ce9a5 Binary files /dev/null and b//pxcore.bin.2 differ diff --git a//pxcore.mid.9 b//pxcore.mid.9 new file mode 100644 index 0000000..8e3ecee --- /dev/null +++ b//pxcore.mid.9 @@ -0,0 +1,77 @@ + +TITLE .CORE + +RELOCATABLE + +.INSRT MUDDLE > + +.GLOBAL P.CORE,P.TOP,PHIBOT,PURBOT,FRETOP,SQKIL,GCFLG,KILBUF + +; .CORE AND .SUSET [.RMEMT,,---] FOR PAGED ENVIRONMENT + +P.CORE: PUSH P,0 + PUSH P,A + PUSH P,B + PUSH P,C + PUSH P,D + PUSH P,E + SKIPN GCFLG + PUSHJ P,SQKIL + MOVE A,-4(P) + ASH A,10. ; CHECK IT + CAMLE A,PURBOT ; A CAML HERE IS OBSERVED TO LOSE + FATAL BAD ARG TO GET CORE + MOVE A,-4(P) ; RESTORE A + HRRZ B,P.TOP ; GET FIRST ADDRESS ABOVE TOP + ASH B,-10. ; TO BLOCKS + CAIG A,(B) ; SKIP IF GROWING + JRST P.COR1 + SUBM B,A ; A/ -NUMBER OF BLOCKS TO GET + HRLI B,(A) ; AOBJN TO BLOCKS + + .CALL P.CORU ; TRY + JRST POPBJ ; LOSE + MOVE A,B +P.COR2: ASH B,10. ; TO WORDS + MOVEM B,P.TOP ; NEW TOP +POPBJ1: AOS -6(P) ; SKIP RETURN ON SUCCESS +POPBJ: POP P,E + POP P,D + POP P,C + POP P,B + POP P,A + POP P,0 + POPJ P, + +; HERE TO CORE DOWN + +P.COR1: SUBM A,B + JUMPE B,POPBJ1 ; SUCCESS, YOU ALREADY HAVE WHAT YOU WANT + HRLI A,(B) + MOVEI B,(A) + .CALL P.CORD + JRST POPBJ + JRST P.COR2 + +P.CORU: SETZ + SIXBIT /CORBLK/ + 1000,,100000 + 1000,,-1 + B + 401000,,400001 + +P.CORD: SETZ + SIXBIT /CORBLK/ + 1000,,0 + 1000,,-1 + SETZ A + + +IMPURE + +P.TOP==FRETOP + +PURE + +END +   \ No newline at end of file diff --git a//readch.bin.12 b//readch.bin.12 new file mode 100644 index 0000000..6a1e0f3 Binary files /dev/null and b//readch.bin.12 differ diff --git a//readch.bin.16 b//readch.bin.16 new file mode 100644 index 0000000..f993201 Binary files /dev/null and b//readch.bin.16 differ diff --git a//readch.mid.206 b//readch.mid.206 new file mode 100644 index 0000000..cbbaef5 --- /dev/null +++ b//readch.mid.206 @@ -0,0 +1,1448 @@ +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, + +; 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 + +; 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 + +; 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,,^ _ + +; 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 + +; 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, + +; 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 // ; ITS SOFTWARE + ASCII // ; DATAMEDIA + ASCII /HJ/ ; HP2640 + 0 + 0 + 0 + 0 + ASCII /HJ/ ; VT50 + 0 + ASCII /(/ ; GT40 + 0 + ASCII /HJ/ ; VT52 + 0 + 0 + ASCII /HJ/ ; VT100 + ASCII /HJ/ ; TELERAY + ASCII /HJ/ ; 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 / / ; ITS SOFTWARE DISPLAY + 0 + ASCII /DK/ ; HP2640 + 0 + 0 + 0 + 0 + ASCII /DK/ ; VT50 + 0 + 0 + 0 + ASCII /DK/ ; VT52 + 0 + 0 + ASCII /DK/ ; VT100 + ASCII /DK/ ; TELERAY + ASCII /DK/ ; 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 // ; ITS SOFTWARE DISPLAY + 0 + ASCII /K/ ; HP2640 + 0 + 0 + 0 + 0 + ASCII /K/ ; VT50 + 0 + 0 + 0 + ASCII /K/ ; VT52 + 0 + 0 + ASCII /K/ ; VT100 + ASCII /K/ ; TELERAY + ASCII /K/ ; 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 +/ + + + + +; 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, +] + +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, + +; 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, +] + +; 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_]] + 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 + \ No newline at end of file diff --git a//readch.mid.210 b//readch.mid.210 new file mode 100644 index 0000000..30fb3cc --- /dev/null +++ b//readch.mid.210 @@ -0,0 +1,1405 @@ +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, + +; 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 + +; 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 + +; 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,,^ _ + +; 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 + +; 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, + +; 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 // ; ITS SOFTWARE + ASCII // ; DATAMEDIA + ASCII /HJ/ ; HP2640 + 0 + 0 + 0 + 0 + ASCII /HJ/ ; VT50 + 0 + ASCII /(/ ; GT40 + 0 + ASCII /HJ/ ; VT52 + 0 + 0 + ASCII /HJ/ ; VT100 + ASCII /HJ/ ; TELERAY + ASCII /HJ/ ; 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 / / ; ITS SOFTWARE DISPLAY + 0 + ASCII /DK/ ; HP2640 + 0 + 0 + 0 + 0 + ASCII /DK/ ; VT50 + 0 + 0 + 0 + ASCII /DK/ ; VT52 + 0 + 0 + ASCII /DK/ ; VT100 + ASCII /DK/ ; TELERAY + ASCII /DK/ ; 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 // ; ITS SOFTWARE DISPLAY + 0 + ASCII /K/ ; HP2640 + 0 + 0 + 0 + 0 + ASCII /K/ ; VT50 + 0 + 0 + 0 + ASCII /K/ ; VT52 + 0 + 0 + ASCII /K/ ; VT100 + ASCII /K/ ; TELERAY + ASCII /K/ ; 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 +/ + + + + +; 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, +] + +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, + +; 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, +] + +; 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_]] + 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 + \ No newline at end of file diff --git a//readch.mid.211 b//readch.mid.211 new file mode 100644 index 0000000..16bf029 --- /dev/null +++ b//readch.mid.211 @@ -0,0 +1,1405 @@ +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, + +; 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 + +; 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 + +; 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,,^ _ + +; 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 + +; 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, + +; 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 // ; ITS SOFTWARE + ASCII // ; DATAMEDIA + ASCII /HJ/ ; HP2640 + 0 + 0 + 0 + 0 + ASCII /HJ/ ; VT50 + 0 + ASCII /(/ ; GT40 + 0 + ASCII /HJ/ ; VT52 + 0 + 0 + ASCII /HJ/ ; VT100 + ASCII /HJ/ ; TELERAY + ASCII /HJ/ ; 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 / / ; ITS SOFTWARE DISPLAY + 0 + ASCII /DK/ ; HP2640 + 0 + 0 + 0 + 0 + ASCII /DK/ ; VT50 + 0 + 0 + 0 + ASCII /DK/ ; VT52 + 0 + 0 + ASCII /DK/ ; VT100 + ASCII /DK/ ; TELERAY + ASCII /DK/ ; 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 // ; ITS SOFTWARE DISPLAY + 0 + ASCII /K/ ; HP2640 + 0 + 0 + 0 + 0 + ASCII /K/ ; VT50 + 0 + 0 + 0 + ASCII /K/ ; VT52 + 0 + 0 + ASCII /K/ ; VT100 + ASCII /K/ ; TELERAY + ASCII /K/ ; 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 +/ + + + + +; 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, +] + +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, + +; 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, +] + +; 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_]] + 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 + \ No newline at end of file diff --git a//readch.mid.212 b//readch.mid.212 new file mode 100644 index 0000000..a9e41e2 --- /dev/null +++ b//readch.mid.212 @@ -0,0 +1,1407 @@ +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, + +; 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 + +; 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 + +; 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,,^ _ + +; 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 + +; 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, + +; 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 // ; ITS SOFTWARE + ASCII // ; DATAMEDIA + ASCII /HJ/ ; HP2640 + 0 + 0 + 0 + 0 + ASCII /HJ/ ; VT50 + 0 + ASCII /(/ ; GT40 + 0 + ASCII /HJ/ ; VT52 + 0 + 0 + ASCII /HJ/ ; VT100 + ASCII /HJ/ ; TELERAY + ASCII /HJ/ ; 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 / / ; ITS SOFTWARE DISPLAY + 0 + ASCII /DK/ ; HP2640 + 0 + 0 + 0 + 0 + ASCII /DK/ ; VT50 + 0 + 0 + 0 + ASCII /DK/ ; VT52 + 0 + 0 + ASCII /DK/ ; VT100 + ASCII /DK/ ; TELERAY + ASCII /DK/ ; 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 // ; ITS SOFTWARE DISPLAY + 0 + ASCII /K/ ; HP2640 + 0 + 0 + 0 + 0 + ASCII /K/ ; VT50 + 0 + 0 + 0 + ASCII /K/ ; VT52 + 0 + 0 + ASCII /K/ ; VT100 + ASCII /K/ ; TELERAY + ASCII /K/ ; 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 +/ + + + + +; 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, +] + +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, + +; 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, +] + +; 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_]] + 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 + \ No newline at end of file diff --git a//readch.mid.213 b//readch.mid.213 new file mode 100644 index 0000000..1aacdb9 --- /dev/null +++ b//readch.mid.213 @@ -0,0 +1,1408 @@ +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, + +; 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 + +; 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 + +; 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,,^ _ + +; 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 + +; 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, + +; 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 // ; ITS SOFTWARE + ASCII // ; DATAMEDIA + ASCII /HJ/ ; HP2640 + 0 + 0 + 0 + 0 + ASCII /HJ/ ; VT50 + 0 + ASCII /(/ ; GT40 + 0 + ASCII /HJ/ ; VT52 + 0 + 0 + ASCII /HJ/ ; VT100 + ASCII /HJ/ ; TELERAY + ASCII /HJ/ ; 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 / / ; ITS SOFTWARE DISPLAY + 0 + ASCII /DK/ ; HP2640 + 0 + 0 + 0 + 0 + ASCII /DK/ ; VT50 + 0 + 0 + 0 + ASCII /DK/ ; VT52 + 0 + 0 + ASCII /DK/ ; VT100 + ASCII /DK/ ; TELERAY + ASCII /DK/ ; 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 // ; ITS SOFTWARE DISPLAY + 0 + ASCII /K/ ; HP2640 + 0 + 0 + 0 + 0 + ASCII /K/ ; VT50 + 0 + 0 + 0 + ASCII /K/ ; VT52 + 0 + 0 + ASCII /K/ ; VT100 + ASCII /K/ ; TELERAY + ASCII /K/ ; 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 +/ + + + + +; 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, +] + +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, + +; 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, +] + +; 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_]] + 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 + \ No newline at end of file diff --git a//readch.mid.214 b//readch.mid.214 new file mode 100644 index 0000000..385d60d --- /dev/null +++ b//readch.mid.214 @@ -0,0 +1,1407 @@ +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, + +; 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 + +; 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 + +; 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,,^ _ + +; 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 + +; 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, + +; 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 // ; ITS SOFTWARE + ASCII // ; DATAMEDIA + ASCII /HJ/ ; HP2640 + 0 + 0 + 0 + 0 + ASCII /HJ/ ; VT50 + 0 + ASCII /(/ ; GT40 + 0 + ASCII /HJ/ ; VT52 + 0 + 0 + ASCII /HJ/ ; VT100 + ASCII /HJ/ ; TELERAY + ASCII /HJ/ ; 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 / / ; ITS SOFTWARE DISPLAY + 0 + ASCII /DK/ ; HP2640 + 0 + 0 + 0 + 0 + ASCII /DK/ ; VT50 + 0 + 0 + 0 + ASCII /DK/ ; VT52 + 0 + 0 + ASCII /DK/ ; VT100 + ASCII /DK/ ; TELERAY + ASCII /DK/ ; 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 // ; ITS SOFTWARE DISPLAY + 0 + ASCII /K/ ; HP2640 + 0 + 0 + 0 + 0 + ASCII /K/ ; VT50 + 0 + 0 + 0 + ASCII /K/ ; VT52 + 0 + 0 + ASCII /K/ ; VT100 + ASCII /K/ ; TELERAY + ASCII /K/ ; 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 +/ + + + + +; 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, +] + +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, + +; 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, +] + +; 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_]] + 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 + \ No newline at end of file diff --git a//reader.bin.10 b//reader.bin.10 new file mode 100644 index 0000000..fe82c78 Binary files /dev/null and b//reader.bin.10 differ diff --git a//reader.mid.353 b//reader.mid.353 new file mode 100644 index 0000000..2e9afa5 --- /dev/null +++ b//reader.mid.353 @@ -0,0 +1,2201 @@ + +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> + + + ; 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 + + + +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 + + MFUNCTION 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 + + ; 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 + ;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? + + +;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 + + +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, + + +;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 + +;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 + + +; 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 + + +; 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 + + + +;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 + + + ; 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 + + +;HERE TO SET UP FOR .FOO ..FOO OR. + +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 + +;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, + + +PATH2: MOVE B,IMQUOTE OBLIST + PUSHJ P,IDVAL + JRST PATH1 + +BADPAT: ERRUUO EQUOTE NON-ATOMIC-OBLIST-NAME + + + +; 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, + +; 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 + + \ No newline at end of file diff --git a//reader.mid.355 b//reader.mid.355 new file mode 100644 index 0000000..265a333 --- /dev/null +++ b//reader.mid.355 @@ -0,0 +1,2202 @@ + +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> + + + ; 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 + + + +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 + + MFUNCTION 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 + + ; 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 + ;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? + + +;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 + + +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, + + +;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 + +;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 + + +; 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 + + +; 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 + + + +;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 + + + ; 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 + + +;HERE TO SET UP FOR .FOO ..FOO OR. + +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 + +;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, + + +PATH2: MOVE B,IMQUOTE OBLIST + PUSHJ P,IDVAL + JRST PATH1 + +BADPAT: ERRUUO EQUOTE NON-ATOMIC-OBLIST-NAME + + + +; 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, + +; 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 + + \ No newline at end of file diff --git a//reader.mid.356 b//reader.mid.356 new file mode 100644 index 0000000..db5cb35 --- /dev/null +++ b//reader.mid.356 @@ -0,0 +1,2203 @@ + +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> + + + ; 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 + + + +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 + + MFUNCTION 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 + + ; 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 + ;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? + + +;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 + + +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, + + +;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 + +;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 + + +; 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 + + +; 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 + + + +;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 + + + ; 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 + + +;HERE TO SET UP FOR .FOO ..FOO OR. + +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 + +;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, + + +PATH2: MOVE B,IMQUOTE OBLIST + PUSHJ P,IDVAL + JRST PATH1 + +BADPAT: ERRUUO EQUOTE NON-ATOMIC-OBLIST-NAME + + + +; 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, + +; 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 + + \ No newline at end of file diff --git a//reader.mid.357 b//reader.mid.357 new file mode 100644 index 0000000..b813edb --- /dev/null +++ b//reader.mid.357 @@ -0,0 +1,2203 @@ + +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> + + + ; 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 + + + +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 + + MFUNCTION 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 + + ; 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 + ;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? + + +;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 + + +FLOATIT: + JFCL 17,.+1 ;CLEAR ALL ARITHMETIC FLAGS + TRNE FF,EFLG ;"E" SEEN? + JRST EXPDO ;YES, DO EXPONENT + MOVE D,NDIGS(TP) ;GET IMPLICIT EXPONENT + +FLOATE: MOVE A,DNUM(TP) ;GET DECIMAL NUMBER + IDIVI A,400000 ;SPLIT + FSC A,254 ;CONVERT MOST SIGNIFICANT + FSC B,233 ; AND LEAST SIGNIFICANT + FADR B,A ;COMBINE + + MOVM A,D ;GET MAGNITUDE OF EXPONENT + MOVSI E,(1.0) + JFCL 17,.+1 ; CLEAR ALL OVERFLOW/UNDERFLOW BITS + CAIG A,38. ;HOW BIG? + JRST .+3 ;TOO BIG-FLOATING OUT OF RANGE + MOVE E,[1.0^38.] + SUBI A,38. + JUMPGE D,FLOAT1 ;JUMP IF EXPONENT POSITIVE + FDVR B,E + FDVR B,TENTAB(A) ;DIVIDE BY TEN TO THE EXPONENT + JRST SETFLO + +FLOAT1: FMPR B,E + FMPR B,TENTAB(A) ;SCALE UP + +SETFLO: JFCL 17,FOOR ;FLOATING OUT OF RANGE ON OVERFLOW + MOVSI A,TFLOAT + TRZ FF,FRSDOT ;FLOATING NUMBER NOT VALUE + JRST FINID1 + +EXPDO: + HRRZ D,ENUM(TP) ;GET EXPONENT + TRNE FF,ENEG ;IS EXPONENT NEGATIVE? + MOVNS D ;YES + ADD D,NDIGS(TP) ;ADD IMPLICIT EXPONENT + JUMPL D,FLOATE ;FLOATING IF EXPONENT NEGATIVE + CAIG D,10. ;OR IF EXPONENT TOO LARGE + TRNE FF,FLONUM ;OR IF FLAG SET + JRST FLOATE + MOVE B,DNUM(TP) ; + IMUL B,ITENTB(D) + JFCL 10,FLOATE ;IF OVERFLOW, MAKE FLOATING + JRST FINID2 ;GO MAKE FIXED NUMBER + + +; HERE TO START BUILDING A CHARACTER STRING GOODIE + +CSTRING: + PUSH P,C%0 + MOVEI D,0 ; CHARCOUNT + MOVSI C,440700+P ; AND BYTE POINTER + +CSLP: PUSH P,FF + INTGO + PUSHJ P,NXTC1 ; GET NEXT CHAR + POP P,FF + + CAIN B,CSTYP ; END OF STRING? + JRST CSLPEND + + CAIN B,ESCTYP ; ESCAPE? + PUSHJ P,NXTC1 + + IDPB A,C ; INTO ATOM + TLNE C,760000 ; SKIP IF OK WORD + AOJA D,CSLP + + PUSH P,C%0 + MOVSI C,440700+P + AOJA D,CSLP + +CSLPEND: + SKIPGE C + SUB P,C%11 + PUSH P,D + PUSHJ P,CHMAK + PUSHJ P,LSTCHR + + JRST RET + +;ARRIVE HERE TO INVOKE A READ TIME MACRO FUNCTION + +MACCAL: PUSHJ P,NXTCH1 ;READ ONE MORE CHARACTER + CAIE B,MACTYP ;IS IT ANOTHER MACRO CHAR + + JRST MACAL2 ;NO, CALL MACRO AND USE VALUE + PUSHJ P,LSTCHR ;DONT REREAD % + PUSHJ P,MACAL1 ;OTHERWISE, USE SIDE EFFECCT, BUT NOT VALUE + JRST IREAD2 + +MACAL2: PUSH P,[RET12] +MACAL1: PUSHJ P,IREAD1 ;READ FUNCTION NAME + PUSHJ P,RETERR + PUSH TP,C + PUSH TP,D ; SAVE COMMENT IF ANY + PUSH TP,A ;SAVE THE RESULT + PUSH TP,B ;AND USE IT AS AN ARGUMENT + MCALL 1,EVAL + POP TP,D + POP TP,C ; RESTORE COMMENT IF ANY... +CRET: POPJ P,RET12 + +;CALL GOBBLE TO FIND THE TYPE AND THEN IREAD TO READ IT + +SPECTY: PUSHJ P,NIREAD ; READ THE TYPES NAME (SHOULD BE AN ATOM) + PUSHJ P,RETERR + PUSH TP,A + PUSH TP,B + GETYP A,A + CAIN A,TFIX + JRST BYTIN + PUSHJ P,NXTCH ; GET NEXT CHAR + CAIN B,TMPTYP ; SKIP IF NOT TEMPLATE START + JRST RDTMPL + SETZB A,B + EXCH A,-1(TP) + EXCH B,(TP) + PUSH TP,A ;BEGIN SETTING UP CHTYPE CALL + PUSH TP,B + PUSHJ P,IREAD1 ;NOW READ STRUCTURE + PUSHJ P,RETERR + MOVEM C,-3(TP) ; SAVE COMMENT + MOVEM D,-2(TP) + EXCH A,-1(TP) ;USE AS FIRST ARG + EXCH B,(TP) + PUSH TP,A ;USE OTHER AS 2D ARG + PUSH TP,B + MCALL 2,CHTYPE ;ATTEMPT TO MUNG +RET13: POP TP,D + POP TP,C ; RESTORE COMMENT +RET12: SETOM (P) ; DONT LOOOK FOR MORE! + JRST RET + +RDTMPL: PUSH P,["}] ; SET UP TERMINATE TEST + MOVE B,(TP) + PUSHJ P,IGVAL + MOVEM A,-1(TP) + MOVEM B,(TP) + PUSH P,[BLDTMP] ; FLAG FOR VECTOR READING CODE + JRST LBRAK2 + +BLDTMP: ADDI A,1 ; 1 MORE ARGUMENT + ACALL A,APPLY ; DO IT TO IT + POPJ P, + +BYTIN: PUSHJ P,NXTCH ; CHECK FOR OPENR + CAIN B,SPATYP + PUSHJ P,SPACEQ + JRST .+3 + PUSHJ P,LSTCHR + JRST BYTIN + CAIE B,TMPTYP + ERRUUO EQUOTE BAD-USE-OF-BYTE-STRING + PUSH P,["}] + PUSH P,[CBYTE1] + JRST LBRAK2 + +CBYTE1: AOJA A,CBYTES + +RETERR: SKIPL A,5(TB) + MOVEI A,5(TB)-LSTCH ;NO CHANNEL, USE SLOT + HRRM B,LSTCH(A) ; RESTORE LAST CHAR + PUSHJ P,ERRPAR + SOS (P) + SOS (P) + POPJ P, + + +;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 + +;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 + + +; 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 + + +; 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 + + + +;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 + + + ; 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 + + +;HERE TO SET UP FOR .FOO ..FOO OR. + +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 + +;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, + + +PATH2: MOVE B,IMQUOTE OBLIST + PUSHJ P,IDVAL + JRST PATH1 + +BADPAT: ERRUUO EQUOTE NON-ATOMIC-OBLIST-NAME + + + +; 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, + +; 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 + + \ No newline at end of file diff --git a//save.bin.13 b//save.bin.13 new file mode 100644 index 0000000..1697f29 Binary files /dev/null and b//save.bin.13 differ diff --git a//save.bin.9 b//save.bin.9 new file mode 100644 index 0000000..2471f0b Binary files /dev/null and b//save.bin.9 differ diff --git a//save.mid.169 b//save.mid.169 new file mode 100644 index 0000000..57ddaa6 --- /dev/null +++ b//save.mid.169 @@ -0,0 +1,774 @@ +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,[-,,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 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 + \ No newline at end of file diff --git a//save.mid.174 b//save.mid.174 new file mode 100644 index 0000000..3397c3c --- /dev/null +++ b//save.mid.174 @@ -0,0 +1,790 @@ +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,[-,,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 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 + + \ No newline at end of file diff --git a//save.mid.175 b//save.mid.175 new file mode 100644 index 0000000..7939d07 --- /dev/null +++ b//save.mid.175 @@ -0,0 +1,792 @@ +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,[-,,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 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 + + \ No newline at end of file diff --git a//save.mid.176 b//save.mid.176 new file mode 100644 index 0000000..7a70df5 --- /dev/null +++ b//save.mid.176 @@ -0,0 +1,799 @@ +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,[-,,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 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 + + \ No newline at end of file diff --git a//secagc.bin.32 b//secagc.bin.32 new file mode 100644 index 0000000..8d9284f Binary files /dev/null and b//secagc.bin.32 differ diff --git a//secagc.mid.80 b//secagc.mid.80 new file mode 100644 index 0000000..cc0d98b --- /dev/null +++ b//secagc.mid.80 @@ -0,0 +1,2288 @@ + +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 + + + +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 +] + + + +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 + + ; 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 + + + + +; 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,] + + +; NOW REHASH THE ASSOCIATIONS BASED ON VALUES +GARZR1: PUSHJ P,REHASH + + + ;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 + + ; 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, + + + + ; 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 + + + ; 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, + + + ;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 + + + ; 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 + + ; 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 + + +; 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 + +; 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, + + ; 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, + + + ; 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 + + +; 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 + + +; 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 + + +; 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 + + +; 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 + + +; 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, + +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 + + + +; MARK NON-GENERAL VECTORS + +NOTGEN: CAMN B,[GENERAL+] + 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 + + + +; 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 + + +;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 + + +; 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 + + + ; 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 + + + +; 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 + + ; 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 + + ;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, + + ; 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 + + +; 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, + + +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 + + +;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 ZZ2 <,-10.> +SECLEN==.LVAL1 + +.LOP SECLEN <,10.> +RSECLE==.LVAL1 + +.LOP AGCLD <,-10.> +PAGESC==.LVAL1 + +OFFSET 0 + +LOC GCST +.LPUR==$. + +END + diff --git a//secagc.mid.81 b//secagc.mid.81 new file mode 100644 index 0000000..45cd0ef --- /dev/null +++ b//secagc.mid.81 @@ -0,0 +1,2290 @@ + +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 + + + +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 +] + + + +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 + + ; 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 + + + + +; 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,] + + +; NOW REHASH THE ASSOCIATIONS BASED ON VALUES +GARZR1: PUSHJ P,REHASH + + + ;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 + + ; 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, + + + + ; 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 + + + ; 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, + + + ;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 + + + ; 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 + + ; 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 + + +; 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 + +; 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, + + ; 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, + + + ; 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 + + +; 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 + + +; 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 + + +; 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 + + +; 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 + + +; 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, + +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 + + + +; MARK NON-GENERAL VECTORS + +NOTGEN: CAMN B,[GENERAL+] + 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 + + + +; 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 + + +;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 + + +; 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 + + + ; 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 + + + +; 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 + + ; 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 + + ;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, + + ; 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 + + +; 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, + + +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 + + +;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 ZZ2 <,-10.> +SECLEN==.LVAL1 + +.LOP SECLEN <,10.> +RSECLE==.LVAL1 + +.LOP AGCLD <,-10.> +PAGESC==.LVAL1 + +OFFSET 0 + +LOC GCST +.LPUR==$. + +END + diff --git a//second.cmd.10 b//second.cmd.10 new file mode 100644 index 0000000..a73d384 --- /dev/null +++ b//second.cmd.10 @@ -0,0 +1,22 @@ +CONN INT: +RENAME MDLXXX.EXE MDL106.EXE + +RENAME MDLXXX.SYMBOLS MDL106.SYMBOLS + +NDDT +;YMDL106.EXE +;O +MUDSTR+2/0"106^?^? +P;UMDL106.EXE +;H +RES . +CONN MDL: +NDDT +;YINT:MDL106.EXE +;OINT:MDL106.SYMBOLS +GM106UNI.SAVE"> +;HCONN INT: +CONT +;UMDL106.EXE +;H +LOGOUT diff --git a//specs.bin.7 b//specs.bin.7 new file mode 100644 index 0000000..af188cf Binary files /dev/null and b//specs.bin.7 differ diff --git a//specs.mid.110 b//specs.mid.110 new file mode 100644 index 0000000..9e0d177 --- /dev/null +++ b//specs.mid.110 @@ -0,0 +1,345 @@ +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+ + ASOLNT+2,,0 + +NODDUM: BLOCK ASOLNT + GENERAL+ + 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 diff --git a//specs.mid.111 b//specs.mid.111 new file mode 100644 index 0000000..efe5a47 --- /dev/null +++ b//specs.mid.111 @@ -0,0 +1,347 @@ +TITLE SPECS FOR MUDDLE + +RELOCA + +MAIN==1 +.GLOBAL TYPVLC,PBASE,TYPBOT,MAINPR,PTIME,IDPROC,ROOT,TTICHN,TTOCHN,TYPVEC +.GLOBAL %UNAM,%JNAM,NOTTY,GCHAPN,INTHLD,PURBOT,PURTOP,N.CHNS,SPCCHK,CURFCN +.GLOBAL TD.GET,TD.PUT,TD.LNT,NOSHUF,GLOTOP,RSTACK,RCYCHN,START,TVSTRT,REALTV +.GLOBAL IJFNS,IJFNS1,SJFNS,OPSYS,HASHTB,MULTSG,PURBTB,NSEGS,NOATMS,NOSETG,NOSET + +.INSRT MUDDLE > + +SYSQ + +CONSTANTS + +IFN ITS,[ + N.CHNS==16. + FATINS==.VALUE +] +IFE ITS,[ + N.CHNS==102 +] + +IMPURE + +LOC100: JRST START +IFN ITS,[ +%UNAM: 0 ; HOLDS UNAME +%JNAM: 0 ; HOLDS JNAME +OPSYS: -1 ; MINUS ONE (-1) IF ITS +RLTSAV: -1 ; SAVED ARG TO REALTIMER +] +IFE ITS,[ +IJFNS: 0 ; AGCS JFN,,MUDDLE'S JFN +IJFNS1: 0 ; SGCS JFN +SJFNS: 0 ; SQUOZE JFN,,SAVE JFN +OPSYS: 0 ; ZERO IF TOPS20, ONE IF TENEX +MULTSG: 0 ; NON-ZERO MEANS TRYING TO USE MULTI SEG STUFF +NSEGS: MAXSEG +PURBTB: REPEAT MAXSEG,HIBOT +] +IDPROC: 0 ; ENVIRONMENT NUMBER GENERATOR +PTIME: 0 ; UNIQUE NUMBER FOR PROCID AND ENVIRONMENTS +OBLNT": 13. ; LENGTH OF DEFAULT OBLISTS (SMALL) +PARTOP": +GCSTOP": +VECTOP": VECLOC ; TOP OF CURRENT GARBAGE COLLECTED SPACE +GCSBOT": +PARBOT": +VECBOT": PARBASE ; BOTTOM OF GARBAGE COLLECTED SPACE +FRETOP": 120000 +CODBOT: 0 ; ABSOLUTE BOTTOM OF CODE +CODTOP": PARBASE ; TOP OF IMPURE CODE (INCLUDING "STORAGE") +HITOP: 0 ; TOP OF INTERPRETER PURE CORE +GCSNEW": +PARNEW": +VECNEW": 0 ; LOCATION FOR OFFSET BETWWEN OLD GCSTOP AND NEW GCSTOP +INTFLG: 0 ; INTERRUPT PENDING FLAG +MAINPR: 0 ; HOLDS POINTER TO THE MAIN PROCESS +NOTTY: 0 ; NON-ZERO==> THIS MUDDLE HAS NO TTY +GCHAPN: 0 ; NON-ZERO A GC HAS HAPPENED RECENTLY +INTHLD: 0 ; NON-ZERO INTERRUPTS CANT HAPPEN +PURBOT: HIBOT ; BOTTOM OF DYNAMICALLY ALLOCATED PURE +PURTOP: HIBOT ; TOP OF DYNAMICALLY ALLOCATED PURE +SPCCHK: SETZ ; SPECIAL/UNSPECIAL CHECKING? +NOSHUF: 0 ; FLAG TO BUILD A NON MOVING HI SEG +NOATMS: 0 ; FLAG DISALLOWING CREATION OF NEW ATOMS +NOSETG: 0 ; FLAG DISALLOWING AUTO-CREATE OF GBINDS +NOSET: 0 ; FLAG DISALLOWING AUTO-CREATE OF BINDINGS +;PAGE MAP USAGE TABLE FOR MUDDLE +;EACH PAGE IS REPRESENTED BY ONE BIT IN THE TABLE +;IF BIT = 0 THEN PAGE IS FREE OTHERWISE BUSY +;FOR PAGE n USE BIT (n MOD 32.) IN WORD PMAP+n/32. +PMAPB": 525252,,525252 ;SECTION 0 -- BELONGS TO AGC + 525252,,525252 + 525252,,525252 ;SECTION 1 -- BELONGS TO AGC + 525252,,525252 + 525252,,525252 ;SECTION 2 -- BELONGS TO AGC + 525252,,525252 + 525252,,525252 ;SECTION 3 -- BELONGS TO AGC + 525252,,525252 + 525252,,525252 ;SECTION 4 -- BELONGS TO AGC + 525252,,525252 + 525252,,525252 ;SECTION 5 -- BELONGS TO AGC (DEPENDS ON HIBOT) + 525252,,525252 + 525252,,525252 ;SECTION 6 -- START OF PURE CORE (FILLED IN BY INITM) + 525252,,525252 + 525252,,525252 + 525252,,525252 + +NINT==72. ; NUMBER OF POSSIBLE ITS INTERRUPTS +NASOCS==159. ; LENGTH OF ASSOCIATION VECTOR +PDLBUF==100 ; EXTRA INSURENCE PDL +ASOLNT==10 ; LENGTH OF ASSOCIATION BLOCKS + + +.GLOBAL PATCH,TBINIT,LERR,LPROG,PIDSTO,PROCID,PTIME,GCPDL,INTFLG,WTYP1,WTYP2 +.GLOBAL PAT,PDLBUF,INTINT,PARNEW,GCPVP,START,SWAP,ICR,SPBASE,TPBASE,GLOBAS,GLOBSP,TPBAS +.GLOBAL GCSBOT,GCSTOP,FRETOP,GCSNEW,TD.AGC,SPSTOR,PVSTOR +.GLOBAL TOPLEVEL,INTNUM,INTVEC,INTOBL,ASOVEC,ERROBL,MAINPR,RESFUN,.BLOCK,ASOLNT,NODES +.GLOBAL WRONGT,TTYOPE,OPEN,CLOSE,IOT,ILVAL,MESS,FACTI,REFVEC,MUDOBL,INITIA +.GLOBAL LSTRES,BINDID,DUMNOD,PSTAT,1STEPR,IDPROC,EVATYP,APLTYP,PRNTYP,PURVEC,STOLST + +TVSTRT==1400 ; THIS SHOULD BE LARGE ENOUGH SO THAT WE HAVE ENOUGH + ; ROOM FOR INITAL FREE STORAGE + + +VECTGO +TVBASE": BLOCK TVLNT + GENERAL + TVLNT+2,,0 +TVLOC==TVBASE + + + +;INITIAL TYPE TABLE + +TYPVLC": + BLOCK 2*NUMPRI+2 + GENERAL + 2*NUMPRI+2+2,,0 + +TYPTP==.-2 ; POINT TO TOP OF TYPES + +; INITIAL SYMBOL TABEL FOR RSUBRS + +SQULOC==. +SQUTBL: BLOCK 2*NSUBRS + TWORD,,0 + 2*NSUBRS+2,,0 + +INTVCL: BLOCK 2*NINT + TLIST,,0 + 2*NINT+2,,0 + +NODLST: TTP,,0 + 0 + TASOC,,0 + BLOCK ASOLNT-3 + GENERAL+ + ASOLNT+2,,0 + +NODDUM: BLOCK ASOLNT + GENERAL+ + 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 diff --git a//stbuil.bin.10 b//stbuil.bin.10 new file mode 100644 index 0000000..f28807c Binary files /dev/null and b//stbuil.bin.10 differ diff --git a//stbuil.mid.15 b//stbuil.mid.15 new file mode 100644 index 0000000..0579fbb --- /dev/null +++ b//stbuil.mid.15 @@ -0,0 +1,2132 @@ + + 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. + + + ; 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 + + +.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 + + + + +.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, + + +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 + + MFUNCTION 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, + + ;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 + + + ;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 + + ; 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, + + ;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 + + ; 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, + + +; 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 + + + ; 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 + + + + ;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 + ; 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 + + + ; 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 + + ;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 + + +; 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, + + ; 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 + \ No newline at end of file diff --git a//stbuil.mid.16 b//stbuil.mid.16 new file mode 100644 index 0000000..819bfc5 --- /dev/null +++ b//stbuil.mid.16 @@ -0,0 +1,2132 @@ + + 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. + + + ; 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 + + +.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 + + + + +.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, + + +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 + + MFUNCTION 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, + + ;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 + + + ;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 + + ; 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, + + ;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 + + ; 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, + + +; 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 + + + ; 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 + + + + ;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 + ; 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 + + + ; 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 + + ;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 + + +; 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, + + ; 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 + \ No newline at end of file diff --git a//stbuil.mid.17 b//stbuil.mid.17 new file mode 100644 index 0000000..acb7171 --- /dev/null +++ b//stbuil.mid.17 @@ -0,0 +1,2133 @@ + + 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. + + + ; 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 + + +.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 + + + + +.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, + + +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 + + MFUNCTION 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, + + ;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 + + + ;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 + + ; 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, + + ;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 + + ; 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, + + +; 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 + + + ; 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 + + + + ;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 + ; 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 + + + ; 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 + + ;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 + + +; 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, + + ; 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 + \ No newline at end of file diff --git a//stbuil.mid.18 b//stbuil.mid.18 new file mode 100644 index 0000000..e5269f5 --- /dev/null +++ b//stbuil.mid.18 @@ -0,0 +1,2133 @@ + + 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. + + + ; 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 + + +.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 + + + + +.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, + + +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 + + MFUNCTION 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, + + ;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 + + + ;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 + + ; 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, + + ;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 + + ; 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, + + +; 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 + + + ; 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 + + + + ;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 + ; 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 + + + ; 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 + + ;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 + + +; 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, + + ; 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 + \ No newline at end of file diff --git a//stbuil.mid.19 b//stbuil.mid.19 new file mode 100644 index 0000000..52ad29b --- /dev/null +++ b//stbuil.mid.19 @@ -0,0 +1,2145 @@ + + 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. + + + ; 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 + + +.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 + + + + +.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, + + +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 + + MFUNCTION 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, + + ;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 + + + ;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 + + ; 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, + + ;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 + + ; 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, + + +; 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 + + + ; 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 + + + + ;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 + ; 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 + + + ; 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 + + ;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 + + +; 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, + + ; 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 + \ No newline at end of file diff --git a//stbuil.mid.20 b//stbuil.mid.20 new file mode 100644 index 0000000..6381714 --- /dev/null +++ b//stbuil.mid.20 @@ -0,0 +1,2145 @@ + + 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. + + + ; GC-READ TAKES ONE ARGUMENT WHICH MUST BE A "READB" CHANNEL + +.GLOBAL CLOOKU,CINSER,MOBLIST,CATOM,EOFCND,IGLOC + +MFUNCTION GCREAD,SUBR,[GC-READ] + + ENTRY + + CAML AB,C%M2 ; CHECK # OF ARGS + JRST TFA + CAMGE AB,C%M40 + JRST TMA + + GETYP A,(AB) ; MAKE SURE ARG IS A CHANNEL + CAIE A,TCHAN + JRST WTYP2 ; IT ISN'T COMPLAIN + MOVE B,1(AB) ; GET PTR TO CHANNEL + HRRZ C,-2(B) ; LOOK AT BITS IN CHANNEL + TRC C,C.OPN+C.READ+C.BIN + TRNE C,C.OPN+C.READ+C.BIN + JRST BADCHN + + PUSH P,1(B) ; SAVE ITS CHANNEL # +IFN ITS,[ + MOVE B,[-2,,C] ; SET UP AOBJN PTR TO READ IN DELIMITING + ; CONSTANTS + MOVE A,(P) ; GET CHANNEL # + DOTCAL IOT,[A,B] + FATAL GCREAD-- IOT FAILED + JUMPL B,EOFGC ; IF BLOCK DIDN'T FINISH THEN EOF +] +IFE ITS,[ + MOVE A,(P) ; GET CHANNEL + BIN + MOVE C,B ; TO C + BIN + MOVE D,B ; TO D + GTSTS ; SEE IF EOF + TLNE B,EOFBIT + JRST EOFGC +] + + PUSH P,C ; SAVE AC'S + PUSH P,D + +IFN ITS,[ + MOVE B,[-3,,C] ; NEXT GROUP OF WORDS + DOTCAL IOT,[A,B] + FATAL GCREAD--GC IOT FAILED +] +IFE ITS,[ + MOVE A,-2(P) ; GET CHANNEL + BIN + MOVE C,B + BIN + MOVE D,B + BIN + MOVE E,B +] + MOVEI 0,0 ; DO PRELIMINARY TESTS + IOR 0,A ; IOR ALL WORDS IN + IOR 0,B + IOR 0,C + IOR 0,(P) + IOR 0,-1(P) + TLNE 0,-1 ; SKIP IF NO BITS IN LEFT HALF + JRST ERDGC + + MOVEM D,NNPRI + MOVEM E,NNSAT + MOVE D,C ; GET START OF NEWTYPE TABLE + SUB D,-1(P) ; CREATE AOBJN POINTER + HRLZS D + ADDI D,(C) + MOVEM D,TYPTAB ; SAVE IT + MOVE A,(P) ; GET LENGTH OF WORD + SUBI A,CONADJ ; SUBTRACT FOR CONSTANTS + + ADD A,GCSTOP + CAMG A,FRETOP ; SEE IF GC IS NESESSARY + JRST RDGC1 + MOVE C,(P) + ADDM C,GETNUM ; MOVE IN REQUEST + MOVE C,[0,,1] ; ARGS TO GC + PUSHJ P,AGC ; GC +RDGC1: MOVE C,GCSTOP ; GET CURRENT TOP OF THE WORLD + MOVEM C,OGCSTP ; SAVE IT + ADD C,(P) ; CALCULATE NEW GCSTOP + ADDI C,2 ; SUBTRACT FOR CONSTANTS + MOVEM C,GCSTOP + SUB C,OGCSTP + SUBI C,2 ; SUBSTRACT TO GET RID OF D.W'S + MOVNS C ; SET UP AOBJN PTR FOR READIN +IFN ITS,[ + HRLZS C + MOVE A,-2(P) ; GET CHANNEL # + ADD C,OGCSTP + DOTCAL IOT,[A,C] + FATAL GCREAD-- IOT FAILED +] +IFE ITS,[ + MOVE A,-2(P) ; CHANNEL TO A + MOVE B,OGCSTP ; SET UP BYTE POINTER + HRLI B,444400 + SIN ; IN IT COMES +] + + MOVE C,(P) ; GET LENGHT OF OBJECT + ADDI A,5 + MOVE B,1(AB) ; GET CHANNEL + ADDM C,ACCESS(B) + MOVE D,GCSTOP ; SET UP TO LOOK LIKE UVECTOR OF LOSES + ADDI C,2 ; ADD 2 FOR DOPE WORDS + HRLM C,-1(D) + MOVSI A,.VECT. + SETZM -2(D) + IORM A,-2(D) ; MARK VECTOR BIT + PUSH TP,$TRDTB ; HOLD ON IN CASE OF GC + MOVEI A,-2(D) + MOVN C,(P) + ADD A,C + HRL A,C + PUSH TP,A + + MOVE D,-1(P) ; SET UP BOTTOM OF ATOM TABLE + SUBI D,1 + MOVEM D,ABOTN + MOVE C,GCSTOP ; START AT TOP OF WORLD + SUBI C,3 ; POINT TO FIRST ATOM + +; LOOP TO FIX UP THE ATOMS + +AFXLP: HRRZ 0,1(TB) + ADD 0,ABOTN + CAMG C,0 ; SEE IF WE ARE DONE + JRST SWEEIN + HRRZ 0,1(TB) + SUB C,0 + PUSHJ P,ATFXU ; FIX IT UP + HLRZ A,(C) ; GET LENGTH + TRZ A,400000 ; TURN OFF MARK BIT + SUBI C,(A) ; POINT TO PRECEDING ATOM + HRRZS C ; CLEAR OFF NEGATIVE + JRST AFXLP + +; FIXUP ROUTINE FOR ATOMS (C==> D.W.) + +ATFXU: PUSH P,C ; SAVE PTR TO D.W. + ADD C,1(TB) + MOVE A,C + HLRZ B,(A) ; GET LENGTH AND MARKING + TRZE B,400000 ; TURN OF MARK BIT AND SKIP IF WAS ALREADY MARKED + JRST ATFXU1 + MOVEI D,-3(B) ; FULL WORDS OF STRING IN PNAME + IMULI D,5 ; CALCULATE # OF CHARACTERS + MOVE 0,-2(A) ; GET LAST WORD OF STRING + SUBI A,-1(B) ; LET A POINT TO OBLIST SLOAT + MOVE B,A ; GET COPY OF A + MOVE A,0 + SUBI A,1 + ANDCM 0,A + JFFO 0,.+1 + HRREI 0,-34.(A) + IDIVI 0,7 ; # OF CHARS IN LAST WORD + ADD D,0 + ADD D,$TCHSTR ; MAKE IT LOOK LIKE A STRINGS TYPE-WORD + PUSH P,D ; SAVE IT + MOVE C,(B) ; GET OBLIST SLOT PTR +ATFXU9: HRRZS B ; RELATAVIZE POINTER + HRRZ 0,1(TB) + SUB B,0 + PUSH P,B + JUMPE C,ATFXU6 ; NO OBLIST. CREATE ATOM + CAMN C,C%M1 ; SEE IF ROOT ATOM + JRST RTFX + ADD C,ABOTN ; POINT TO ATOM + PUSHJ P,ATFXU + PUSH TP,$TATOM + PUSH TP,B + MOVE A,$TATOM ; SET UP TO SEE IF OBLIST EXITS + MOVE C,$TATOM + MOVE D,IMQUOTE OBLIST + PUSHJ P,CIGTPR + JRST ATFXU8 ; NO OBLIST. CREATE ONE + SUB TP,C%22 ; GET RID OF SAVED ATOM +RTCON: PUSH TP,$TOBLS + PUSH TP,B + MOVE C,B ; SET UP FOR LOOKUP + MOVE A,-1(P) ; SET UP PTR TO PNAME + MOVE B,(P) + ADD B,[440700,,1] ; ADJUST TO MAKE IT LOOK LIKE A BYTE-POINTER + HRRZ 0,1(TB) + ADD B,0 + PUSHJ P,CLOOKU + JRST ATFXU4 ; NOT ON IT SO INSERT +ATFXU3: SUB P,C%22 ; DONE + SUB TP,C%22 ; POP OFF OBLIST +ATFXU7: MOVE C,(P) ; RESTORE PTR TO D.W. + ADD C,1(TB) + MOVEM B,-1(C) ; MOVE IN RELATAVIZE ADDRESS + MOVSI D,400000 + IORM D,(C) ; TURN OFF MARK BIT + MOVE 0,3(B) ; SEE IF MUST BE LOCR + TRNE 0,1 ; SKIP IF MUST MAKE IT IMPURE + PUSHJ P,IIGLOC + POP P,C + ADD C,1(TB) + POPJ P, ; EXIT +ATFXU1: POP P,C ; RESTORE PTR TO D.W. + ADD C,1(TB) + MOVE B,-1(C) ; GET ATOM + POPJ P, + +; ROUTINE TO INSERT AN ATOM + +ATFXU4: MOVE C,(TP) ; GET OBLIST PTR + MOVE B,(P) ; SET UP STRING PTR TO PNAME + ADD B,[440700,,1] + HRRZ 0,1(TB) + ADD B,0 + MOVE A,-1(P) ; GET TYPE WORD + PUSHJ P,CINSER ; INSERT IT + JRST ATFXU3 + +; THIS ROUTINE CREATS THE ATOM SO THAT ITS NOT ON ANY OBLIST + +ATFXU6: MOVE B,(P) ; POINT TO PNAME + ADD B,[440700,,1] ; MAKE IT LOOK LIKE A BYTE POINTER + HRRZ 0,1(TB) + ADD B,0 + MOVE A,-1(P) + PUSHJ P,CATOM + SUB P,C%22 ; CLEAN OFF STACK + JRST ATFXU7 + +; THIS ROUTINE CREATES AND OBLIST + +ATFXU8: MCALL 1,MOBLIST + PUSH TP,$TOBLS + PUSH TP,B ; SAVE OBLIST PTR + JRST ATFXU4 ; JUMP TO INSERT THE OBLIST + +; HERE TO INSERT AN ATOM INTO THE ROOT OBLIST + +RTFX: MOVE B,ROOT+1 ; GET ROOT OBLIST + JRST RTCON + +; THIS ROUTINE SWEEPS THRU THE NEW CORE IMAGE AND UPDATES ALL THE POINTERS. + +SWEEIN: +; ROUTINE TO FIX UP TYPE-TABLE FOR GC-READ. THIS ROUTINE FIXES UP THE TYPE TABLE SO THAT +; THE TYPES ATOM I.D. IS REPLACED BY ITS TYPE-NUMBER IN THE NEW MUDDLE AND IF ITS A +; TEMPLATE, THE SLOT FOR THE PRIMTYPE-ATOM IS REPLACED BY THE SAT OF THE TEMPLATE + + HRRZ E,1(TB) ; SET UP TYPE TABLE + ADD E,TYPTAB + JUMPGE E,VUP ; SKIP OVER IF DONE +TYPUP1: PUSH P,C%0 ; PUSH SLOT FOR POSSIBLE TEMPLATE ATOM + HLRZ A,1(E) ; GET POSSIBLE ATOM SLOT + JUMPE A,TYPUP2 ; JUMP IF NOT A TEMPLATE + ADD A,ABOTN ; GET ATOM + ADD A,1(TB) + MOVE A,-1(A) + MOVE B,TYPVEC+1 ; GET TYPE VECTOR SLOT FOR LOOP TO SEE IF ITS THERE +TYPUP3: CAMN A,1(B) ; SKIP IF NOT EQUAL + JRST TYPUP4 ; FOUND ONE + ADD B,C%22 ; TO NEXT + JUMPL B,TYPUP3 + JRST ERTYP1 ; ERROR NONE EXISTS +TYPUP4: HRRZ C,(B) ; GET SAT SLOT + CAIG C,NUMSAT ; MAKE SURE TYPE IS A TEMPLATE + JRST ERTYP2 ; IF NOT COMPLAIN + HRLM C,1(E) ; SMASH IN NEW SAT + MOVE B,1(B) ; GET ATOM OF PRIMTYPE + MOVEM B,(P) ; PUSH ONTO STACK +TYPUP2: MOVEI D,0 ; INITIALIZE TYPE COUNT FOR LOOKUP LOOP + MOVE B,TYPVEC+1 ; GET PTR FOR LOOP + HRRZ A,1(E) ; GET TYPE'S ATOM ID + ADD A,ABOTN ; GET ATOM + ADD A,1(TB) + MOVE A,-1(A) +TYPUP5: CAMN A,1(B) ; SKIP IF NOT EQUAL + JRST TYPUP6 ; FOUND ONE + ADDI D,1 ; INCREMENT TYPE-COUNT + ADD B,C%22 ; POINT TO NEXT + JUMPL B,TYPUP5 + HRRM D,1(E) ; CLOBBER IN TYPE-NUMBER + PUSH TP,$TATOM ; PUSH ARGS FOR NEWTYPE + PUSH TP,A + PUSH TP,$TATOM + POP P,B ; GET BACK POSSIBLE PRIMTYPE ATOM + JUMPE B,TYPUP7 ; JUMP IF NOT A TEMPLATE + PUSH TP,B ; PUSH ON PRIMTYPE +TYPUP9: SUB E,1(TB) + PUSH P,E ; SAVE RELATAVIZED PTR TO TYPE-TABLE + MCALL 2,NEWTYPE + POP P,E ; RESTORE RELATAVIZED PTR + ADD E,1(TB) ; FIX IT UP +TYPUP0: ADD E,C%22 ; INCREMENT E + JUMPL E,TYPUP1 + JRST VUP +TYPUP7: HRRZ B,(E) ; FIND PRIMTYPE FROM SAT + MOVE A,@STBL(B) + PUSH TP,A + JRST TYPUP9 +TYPUP6: HRRM D,1(E) ; CLOBBER IN TYPE # + JRST TYPUP0 + +ERTYP1: ERRUUO EQUOTE CANT-FIND-TEMPLATE + +ERTYP2: ERRUUO EQUOTE TEMPLATE-TYPE-NAME-NOT-OF-TYPE-TEMPLATE + +VUP: HRRZ E,1(TB) ; FIX UP SOME POINTERS + MOVEM E,OGCSTP + ADDM E,ABOTN + ADDM E,TYPTAB + + +; ROUTINE TO SWEEP THRU THE READ-IN IMAGE LOOKING FOR UVECTORS AND TEMPLATES. +; WHILE SWEEPING IT FIXES UP THE DOPE WORDS APPROPRIATELY. + + HRRZ A,TYPTAB ; GET TO TOP OF WORLD + SUBI A,2 ; GET TO FIRST TYPE WORD OR DOPE-WORD OF FIRST OBJECT +VUP1: CAMG A,OGCSTP ; SKIP IF NOT DONE + JRST VUP3 + HLRZ B,(A) ; GET TYPE SLOT + TRNE B,.VECT. ; SKIP IF NOT A VECTOR + JRST VUP2 + SUBI A,2 ; SKIP OVER PAIR + JRST VUP1 +VUP2: TRNE B,400000 ; SKIP IF UVECTOR + JRST VUP4 + ANDI B,TYPMSK ; GET RID OF MONITORS + CAMG B,NNPRI ; SKIP IF NEWTYPE + JRST VUP5 + PUSHJ P,GETNTP ; GET THE NEW TYPE # + PUTYP B,(A) ; SMASH IT IT +VUP5: HLRZ B,1(A) ; SKIP OVER VECTOR + TRZ B,400000 ; GET RID OF POSSIBLE MARK BIT + SUBI A,(B) + JRST VUP1 ; LOOP +VUP4: ANDI B,TYPMSK ; FLUSH MONITORS + CAMG B,NNSAT ; SKIP IF TEMPLATE + JRST VUP5 + PUSHJ P,GETSAT ; CONVERT TO NEW SAT + ADDI B,.VECT. ; MAJIC TO TURN ON BIT + PUTYP B,(A) + JRST VUP5 + + +VUP3: PUSH P,GCSBOT ; SAVE CURRENT GCSBOT + MOVE A,OGCSTP ; SET UP NEW GCSBOT + MOVEM A,GCSBOT + PUSH P,GCSTOP + HRRZ A,TYPTAB ; SET UP NEW GCSTOP + MOVEM A,GCSTOP + SETOM GCDFLG + MOVE A,[PUSHJ P,RDFIX] ; INS FOR GCHACK + MOVEI PVP,0 ; SAY MIGHT BE NON-ATOMS + PUSHJ P,GCHK10 + SETZM GCDFLG + POP P,GCSTOP ; RESTORE GCSTOP + MOVE A,1(TB) ; GET A POINTER TO RETURNING VALUES + MOVE B,A + HLRE C,B + SUB B,C + SETZM (B) + SETZM 1(B) + POP P,GCSBOT ; RESTORE GCSBOT + MOVE B,1(A) ; GET PTR TO OBJECTS + MOVE A,(A) + JRST FINIS ; EXIT + +; ERROR FOR INCORRECT GCREAD FILE + +ERDGC: ERRUUO EQUOTE BAD-GC-READ-FILE + +; ROUTINE CALLED BY GCHACK TO UPDATE PTRS IN THE NEW CORE IMAGE + +RDFIX: PUSH P,C ; SAVE C + PUSH P,B ; SAVE PTR + EXCH B,C + TLNE C,UBIT ; SKIP IF NOT UVECTOR + JRST ELEFX ; DON'T HACK TYPES IN UVECTOR + CAIN B,TTYPEC + JRST TYPCFX + CAIN B,TTYPEW + JRST TYPWFX + CAMLE B,NNPRI + JRST TYPGFX +ELEFX: EXCH B,A ; EXCHANGE FOR SAT + PUSHJ P,SAT + EXCH B,A ; REFIX + CAIE B,SOFFS + JRST OFSFIX + CAIE B,SLOCR ; REL GLOC'S ARE STORED AS ATOMS + CAIN B,SATOM + JRST ATFX + CAIN B,SCHSTR + JRST STFX + CAIN B,S1WORD ; SEE IF PRIMTYPE WOR + JRST RDLSTF ; LEAVE IF IS +STFXX: MOVE 0,GCSBOT ; ADJUSTMENT + SUBI 0,FPAG+5 + SKIPE 1(C) ; DON'T CHANGE A PTR TO NIL + ADDM 0,1(C) ; FIX UP +RDLSTF: TLNN C,.LIST. ; SEE IF PAIR + JRST RDL1 ; EXIT + MOVE 0,GCSBOT ; FIX UP + SUBI 0,FPAG+5 + HRRZ B,(C) ; SEE IF POINTS TO NIL + SKIPN B + JRST RDL1 + MOVE B,C ; GET ARG FOR RLISTQ + PUSHJ P,RLISTQ + JRST RDL1 + ADDM 0,(C) +RDL1: POP P,B ; RESTORE B + POP P,C + POPJ P, + +; FIXUP OFSSETS + +OFSFIX: HLRZ B,1(C) ; SEE IF PNTR TO FIXUP + JUMPE B,RDL1 + MOVE 0,GCSBOT ; GET UPDATE AMOUNT + SUBI 0,FPAG+5 + HRLZS 0 + ADDM 0,1(C) ; FIX POINTER + JRST RDL1 + +; ROUTINE TO FIX UP PNAMES + +STFX: TLZN D,STATM + JRST STFXX + HLLM D,1(C) ; PUT BACK WITH BIT OFF + ADD D,ABOTN + ANDI D,-1 + HLRE 0,-1(D) ; LENGTH OF ATOM + MOVNS 0 + SUBI 0,3 ; VAL & OBLIST + IMULI 0,5 ; TO CHARS (SORT OF) + HRRZ D,-1(D) + ADDI D,2 + PUSH P,A + PUSH P,B + LDB A,[360600,,1(C)] ; GET BYTE POS + IDIVI A,7 ; TO CHAR POS + SKIPE A + SUBI A,5 + HRRZ B,(C) ; STRING LENGTH + SUB B,A ; TO WORD BOUNDARY STRING + SUBI 0,(B) + IDIVI 0,5 + ADD D,0 + POP P,B + POP P,A + HRRM D,1(C) + JRST RDLSTF + +; ROUTINE TO FIX UP POINTERS TO ATOMS + +ATFX: SKIPGE D + JRST RDLSTF + ADD D,ABOTN + MOVE 0,-1(D) ; GET PTR TO ATOM + CAIE B,SLOCR ; IF REL LOCATIVE, MORE HAIR + JRST ATFXAT + MOVE B,0 + PUSH P,E + PUSH P,D + PUSH P,C + PUSH P,B + PUSH P,A + PUSHJ P,IGLOC + SUB B,GLOTOP+1 + MOVE 0,B + POP P,A + POP P,B + POP P,C + POP P,D + POP P,E +ATFXAT: MOVEM 0,1(C) ; SMASH IT IN + JRST RDLSTF ; EXIT + +TYPCFX: HRRZ B,1(C) ; GET TYPE + PUSHJ P,GETNEW ; GET TYPE IN THIS CORE IMAGE + HRRM B,1(C) ; CLOBBER IT IN + JRST RDLSTF ; CONTINUE FIXUP + +TYPWFX: HLRZ B,1(C) ; GET TYPE + PUSHJ P,GETNEW ; GET TYPE IN THIS CORE IMAGE + HRLM B,1(C) ; SMASH IT IN + JRST ELEFX + +TYPGFX: PUSH P,D + PUSHJ P,GETNTP ; GET TYPE IN THIS CORE IMAGE + POP P,D + PUTYP B,(C) + JRST ELEFX + +; HERE TO HANDLE AN EOF IN GC-READ. IT USES OPTIONAL SECOND ARG IF SUPPLIED AS +; EOF HANDLER ELSE USES CHANNELS. + +EOFGC: MOVE B,1(AB) ; GET CHANNEL INTO B + CAML AB,C%M20 ; [-2,,0] ; SKIP IF EOF ROUTINE IS SUPPLIED + JRST MYCLOS ; USE CHANNELS + PUSH TP,2(AB) + PUSH TP,3(AB) + JRST CLOSIT +MYCLOS: PUSH TP,EOFCND-1(B) + PUSH TP,EOFCND(B) +CLOSIT: PUSH TP,$TCHAN + PUSH TP,B + MCALL 1,FCLOSE ; CLOSE CHANNEL + MCALL 1,EVAL ; EVAL HIS EOF HANDLER + JRST FINIS + +; ROUTINE TO SUPPLY THE TYPE NUMBER FOR A NEWTYPE + +GETNEW: CAMG B,NNPRI ;NEWTYPE + POPJ P, +GETNTP: MOVE D,TYPTAB ; GET AOBJN POINTER TO TYPE-TABLE +GETNT1: HLRZ E,(D) ; GET TYPE # + CAIN E,(B) ; SKIP IF NOT EQUAL TO GOAL + JRST GOTTYP ; FOUND IT + ADD D,C%22 ; POINT TO NEXT + JUMPL D,GETNT1 + SKIPA ; KEEP TYPE SAME +GOTTYP: HRRZ B,1(D) ; GET NEW TYPE # + POPJ P, + +; ROUTINE TO SUPPLY THE SAT TO A TEMPLATE HACKER + +GETSAT: MOVE D,TYPTAB ; GET AOBJN PTR TO TYPE TABLE +GETSA1: HRRZ E,(D) ; GET OBJECT + CAIN E,(B) ; SKIP IF NOT EQUAL TO GOAL + JRST GOTSAT ; FOUND IT + ADD D,C%22 + JUMPL D,GETSA1 + FATAL GC-DUMP -- TYPE FIXUP FAILURE +GOTSAT: HLRZ B,1(D) ; GET NEW SAT + POPJ P, + + +; A ROUTINE TO DISTINGUISH BETWEEN A DEFERRED AND A LIST POINTER +RLISTQ: PUSH P,A + GETYP A,(B) ; GET TYPE + PUSHJ P,SAT ; GET SAT + CAIG A,NUMSAT ; NOT DEFERRED IF TEMPLATE + SKIPL MKTBS(A) + AOS -1(P) ; SKIP IF NOT DEFFERED + POP P,A + POPJ P, ; EXIT + + +.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 + + + + +.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, + + +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 + + MFUNCTION 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, + + ;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 + + + ;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 + + ; 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, + + ;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 + + ; 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, + + +; 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 + + + ; 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 + + + + ;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 + ; 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 + + + ; 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 + + ;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 + + +; 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, + + ; 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 + \ No newline at end of file diff --git a//stenex.mid.11 b//stenex.mid.11 new file mode 100644 index 0000000..46f673b --- /dev/null +++ b//stenex.mid.11 @@ -0,0 +1,604 @@ +;ADDED VTS JSYS'S 21-NOV-80 EDIT BY PDL +;ADDED RSCAN EDIT BY PDL +;ADDED IIT (Interrupt In Time) 8/2/77 EDIT BY JMB +;STENEX.MAC;432 6-NOV-73 04:28:29 EDIT BY MELVIN +;ADDED UNIVERSAL STENEX +;STENEX.MAC;431 1-NOV-73 22:17:59 EDIT BY MELVIN +;ADDED LGINX6 -- ONE JOB FOR PEASANTS +;STENEX.MAC;43 25-MAY-73 13:44:46 EDIT BY CLEMENTS +;STENEX.MAC;42 27-DEC-72 22:57:51 EDIT BY MURPHY +;STENEX.MAC;41 30-NOV-72 0:27:54 EDIT BY CLEMENTS +;STENEX.MAC;40 18-NOV-72 18:12:32 EDIT BY WALLACE +;STENEX.MAC;38 13-NOV-72 22:15:04 EDIT BY CLEMENTS +;STENEX.MAC;37 13-NOV-72 21:53:19 EDIT BY CLEMENTS +;STENEX.MAC;36 30-OCT-72 13:43:16 EDIT BY TOMLINSON +;STENEX.MAC;35 30-OCT-72 12:22:04 EDIT BY TOMLINSON +;STENEX.MAC;34 8-AUG-72 21:52:21 EDIT BY MURPHY +;STENEX.MAC;33 8-AUG-72 20:31:17 EDIT BY MURPHY + +;9 FEB 72, 1425: - DLM + +;JSYS INSTRUCTIONS AND ERROR MNEMONICS FOR TENEX + +JSYS=104_27. + +DEFINE DEFJS NAME,NUM + NAME=JSYS NUM + TERMIN + + +DEFJS JSYS,0 + +DEFJS LOGIN,1 +DEFJS CRJOB,2 +DEFJS LGOUT,3 +DEFJS CACCT,4 +DEFJS EFACT,5 +DEFJS SMON,6 +DEFJS TMON,7 +DEFJS GETAB,10 +DEFJS ERSTR,11 +DEFJS GETER,12 +DEFJS GJINF,13 +DEFJS TIME,14 +DEFJS RUNTM,15 +DEFJS SYSGT,16 +DEFJS GNJFN,17 +DEFJS GTJFN,20 +DEFJS OPENF,21 +DEFJS CLOSF,22 +DEFJS RLJFN,23 +DEFJS GTSTS,24 +DEFJS STSTS,25 +DEFJS DELF,26 +DEFJS SFPTR,27 +DEFJS JFNS,30 +DEFJS FFFFP,31 +DEFJS RDDIR,32 +DEFJS CPRTF,33 +DEFJS CLZFF,34 +DEFJS RNAMF,35 +DEFJS SIZEF,36 +DEFJS GACTF,37 + +DEFJS STDIR,40 +DEFJS DIRST,41 +DEFJS BKJFN,42 +DEFJS RFPTR,43 +DEFJS CNDIR,44 +DEFJS RFBSZ,45 +DEFJS SFBSZ,46 +DEFJS SWJFN,47 +DEFJS BIN,50 +DEFJS BOUT,51 +DEFJS SIN,52 +DEFJS SOUT,53 +DEFJS RIN,54 +DEFJS ROUT,55 +DEFJS PMAP,56 +DEFJS RPACS,57 +DEFJS SPACS,60 +DEFJS RMAP,61 +DEFJS SACTF,62 +DEFJS GTFDB,63 +DEFJS CHFDB,64 +DEFJS DUMPI,65 +DEFJS DUMPO,66 +DEFJS DELDF,67 +DEFJS ASND,70 +DEFJS RELD,71 +DEFJS CSYNO,72 +DEFJS PBIN,73 +DEFJS PBOUT,74 +DEFJS PSIN,75 +DEFJS PSOUT,76 +DEFJS MTOPR,77 +DEFJS CFIBF,100 +DEFJS CFOBF,101 +DEFJS SIBE,102 +DEFJS SOBE,103 +DEFJS DOBE,104 +DEFJS GTABS,105 +DEFJS STABS,106 +DEFJS RFMOD,107 +DEFJS SFMOD,110 +DEFJS RFPOS,111 +DEFJS RFCOC,112 +DEFJS SFCOC,113 +DEFJS STI,114 +DEFJS DTACH,115 +DEFJS ATACH,116 +DEFJS DVCHR,117 + +DEFJS STDEV,120 +DEFJS DEVST,121 +DEFJS MOUNT,122 +DEFJS DSMNT,123 +DEFJS INIDR,124 +DEFJS SIR,125 +DEFJS EIR,126 +DEFJS SKPIR,127 +DEFJS DIR,130 +DEFJS AIC,131 +DEFJS IIC,132 +DEFJS DIC,133 +DEFJS RCM,134 +DEFJS RWM,135 +DEFJS DEBRK,136 +DEFJS ATI,137 +DEFJS DTI,140 +DEFJS CIS,141 +DEFJS SIRCM,142 +DEFJS RIRCM,143 +DEFJS RIR,144 +DEFJS GDSTS,145 +DEFJS SDSTS,146 +DEFJS RESET,147 +DEFJS RPCAP,150 +DEFJS EPCAP,151 +DEFJS CFORK,152 +DEFJS KFORK,153 +DEFJS FFORK,154 +DEFJS RFORK,155 +DEFJS RFSTS,156 +DEFJS SFORK,157 +DEFJS SFACS,160 +DEFJS RFACS,161 +DEFJS HFORK,162 +DEFJS WFORK,163 +DEFJS GFRKH,164 +DEFJS RFRKH,165 +DEFJS GFRKS,166 +DEFJS DISMS,167 +DEFJS HALTF,170 +DEFJS GTRPW,171 +DEFJS GTRPI,172 +DEFJS RTIW,173 +DEFJS STIW,174 +DEFJS SOBF,175 +DEFJS RWSET,176 +DEFJS GETNM,177 + +DEFJS GET,200 +DEFJS SFRKV,201 +DEFJS SAVE,202 +DEFJS SSAVE,203 +DEFJS SEVEC,204 +DEFJS GEVEC,205 +DEFJS GPJFN,206 +DEFJS SPJFN,207 +DEFJS SETNM,210 +DEFJS FFUFP,211 +DEFJS DIBE,212 +DEFJS FDFRE,213 +DEFJS GDSKC,214 +DEFJS LITES,215 +DEFJS TLINK,216 +DEFJS STPAR,217 +DEFJS ODTIM,220 +DEFJS IDTIM,221 +DEFJS ODCNV,222 +DEFJS IDCNV,223 +DEFJS NOUT,224 +DEFJS NIN,225 +DEFJS STAD,226 +DEFJS GTAD,227 +DEFJS ODTNC,230 +DEFJS IDTNC,231 +DEFJS FLIN,232 +DEFJS FLOUT,233 +DEFJS DFIN,234 +DEFJS DFOUT,235 + +DEFJS CRDIR,240 +DEFJS GTDIR,241 +DEFJS DSKOP,242 +DEFJS SPRIW,243 +DEFJS DSKAS,244 +DEFJS SJPRI,245 +; HOLE +DEFJS ASNDP,260 +DEFJS RELDP,261 +DEFJS ASNDC,262 +DEFJS RELDC,263 +DEFJS STRDP,264 +DEFJS STPDP,265 +DEFJS STSDP,266 +DEFJS RDSDP,267 +DEFJS WATDP,270 + +DEFJS ATPTY,274 +DEFJS CVSKT,275 +DEFJS CVHST,276 +DEFJS FLHST,277 + +DEFJS GCVEC,300 +DEFJS SCVEC,301 +DEFJS STTYP,302 +DEFJS GTTYP,303 +DEFJS BPT,304 +DEFJS GTDAL,305 +DEFJS WAIT,306 +DEFJS HSYS,307 + +DEFJS USRIO,310 +DEFJS PEEK,311 +DEFJS MSFRK,312 +DEFJS ESOUT,313 +DEFJS SPLFK,314 +DEFJS ADVIZ,315 +DEFJS JOBTM,316 +DEFJS DELNF,317 +DEFJS SWTCH,320 + +DEFJS RSCAN,500 +DEFJS LNMST,504 +DEFJS TIMER,522 +DEFJS SWTRP,573 +DEFJS XSIR,602 +DEFJS IIT,630 +DEFJS VTSOP,635 +DEFJS RTMOD,636 +DEFJS STMOD,637 +DEFJS RTCHR,640 +DEFJS STCHR,641 +DEFJS SMAP,767 + + +DEFINE ...QQQ E,N,F +IFE F,[ +E=600000+N] +IFN F,[ +E=600000+N+F_21] +TERMIN + +...QQQ LGINX1,10 +...QQQ LGINX2,11 +...QQQ LGINX3,12 +...QQQ LGINX4,13 +...QQQ LGINX5,14 +...QQQ LGINX6,15 + +...QQQ CRJBX1,20 +...QQQ CRJBX2,21 +...QQQ CRJBX3,22 +...QQQ CRJBX4,23 +...QQQ CRJBX5,24 +...QQQ CRJBX6,25 +...QQQ CRJBX7,26 + +...QQQ LOUTX1,35 +...QQQ LOUTX2,36 + +...QQQ CACTX1,45 +...QQQ CACTX2,46 + +...QQQ EFCTX1,50 +...QQQ EFCTX2,51 +...QQQ EFCTX3,52 + +...QQQ GJFX1,55 +...QQQ GJFX2,56 +...QQQ GJFX3,57 +...QQQ GJFX4,60 +...QQQ GJFX5,61 +...QQQ GJFX6,62 +...QQQ GJFX7,63 +...QQQ GJFX8,64 +...QQQ GJFX9,65 +...QQQ GJFX10,66 +...QQQ GJFX11,67 +...QQQ GJFX12,70 +...QQQ GJFX13,71 +...QQQ GJFX14,72 +...QQQ GJFX15,73 +...QQQ GJFX16,74 +...QQQ GJFX17,75 +...QQQ GJFX18,76 +...QQQ GJFX19,77 +...QQQ GJFX20,100 +...QQQ GJFX21,101 +...QQQ GJFX22,102 +...QQQ GJFX23,103 +...QQQ GJFX24,104 +...QQQ GJFX25,105 +...QQQ GJFX26,106 +...QQQ GJFX27,107 +...QQQ GJFX28,110 +...QQQ GJFX29,111 +...QQQ GJFX30,112 +...QQQ GJFX31,113 +...QQQ GJFX32,114 +...QQQ GJFX33,115 +...QQQ GJFX34,116 +...QQQ GJFX35,117 +...QQQ OPNX1,120 +...QQQ OPNX2,121 +...QQQ OPNX3,122 +...QQQ OPNX4,123 +...QQQ OPNX5,124 +...QQQ OPNX6,125 +...QQQ OPNX7,126 +...QQQ OPNX8,127 +...QQQ OPNX9,130 +...QQQ OPNX10,131 +...QQQ OPNX11,132 +...QQQ OPNX12,133 +...QQQ OPNX13,134 +...QQQ OPNX14,135 +...QQQ OPNX15,136 +...QQQ OPNX16,137 +...QQQ OPNX17,140 +...QQQ OPNX18,141 +...QQQ OPNX19,142 +...QQQ OPNX20,143 +...QQQ OPNX21,144 +...QQQ OPNX22,145 + +...QQQ DESX1,150 +...QQQ DESX2,151 +...QQQ DESX3,152 +...QQQ DESX4,153 +...QQQ DESX5,154 +...QQQ DESX6,155 +...QQQ DESX7,156 +...QQQ DESX8,157 + +...QQQ CLSX1,160 +...QQQ CLSX2,161 + +...QQQ RJFNX1,165 +...QQQ RJFNX2,166 +...QQQ RJFNX3,167 + +...QQQ DELFX1,170 + +...QQQ SFPTX1,175 +...QQQ SFPTX2,176 +...QQQ SFPTX3,177 + +...QQQ CNDIX1,200 +...QQQ CNDIX2,201 +...QQQ CNDIX3,202 +...QQQ CNDIX4,203 +...QQQ CNDIX5,204 + +...QQQ SFBSX1,210 +...QQQ SFBSX2,211 + +...QQQ IOX1,215 +...QQQ IOX2,216 +...QQQ IOX3,217 +...QQQ IOX4,220 +...QQQ IOX5,221 +...QQQ IOX6,222 + +...QQQ PMAPX1,240 +...QQQ PMAPX2,241 + +...QQQ SPACX1,245 + + +...QQQ FRKHX1,250 +...QQQ FRKHX2,251 +...QQQ FRKHX3,252 +...QQQ FRKHX4,253 +...QQQ FRKHX5,254 +...QQQ FRKHX6,255 + +...QQQ SPLFX1,260 +...QQQ SPLFX2,261 +...QQQ SPLFX3,262 + +...QQQ GTABX1,267 +...QQQ GTABX2,270 +...QQQ GTABX3,271 + +...QQQ RUNTX1,273 + +...QQQ STADX1,275 +...QQQ STADX2,276 + +...QQQ ASNDX1,300 +...QQQ ASNDX2,301 +...QQQ ASNDX3,302 + +...QQQ CSYNX1,312 + +...QQQ ATACX1,320 +...QQQ ATACX2,321 +...QQQ ATACX3,322 +...QQQ ATACX4,323 +...QQQ ATACX5,324 + +...QQQ DCHRX1,330 ;USED ? + +...QQQ STDVX1,332 + +...QQQ DEVX1,335 +...QQQ DEVX2,336 +...QQQ DEVX3,337 + +...QQQ ADVX1,344 +...QQQ MNTX1,345 +...QQQ MNTX2,346 +...QQQ MNTX3,347 + +...QQQ TERMX1,350 + +...QQQ TLNKX1,351 + +...QQQ ATIX1,352 +...QQQ ATIX2,353 + +...QQQ DTIX1,355 +...QQQ TLNKX2,356 +...QQQ TLNKX3,357 +...QQQ TTYX1,360 + +...QQQ CFRKX2,362 +...QQQ CFRKX3,363 + + +...QQQ KFRKX1,365 +...QQQ KFRKX2,366 + +...QQQ RFRKX1,367 + +...QQQ GFRKX1,371 + +...QQQ GETX1,373 +...QQQ GETX2,374 + +...QQQ SFRVX1,377 + +...QQQ NOUTX1,407 +...QQQ NOUTX2,410 + +...QQQ IFIXX1,414 +...QQQ IFIXX2,415 +...QQQ IFIXX3,416 + +...QQQ ADVX1,420 +...QQQ ADVX2,421 +...QQQ ADVX3,422 +...QQQ ADVX4,423 +...QQQ GFDBX1,424 +...QQQ GFDBX2,425 +...QQQ GFDBX3,426 + +...QQQ CFDBX1,430 +...QQQ CFDBX2,431 +...QQQ CFDBX3,432 +...QQQ CFDBX4,433 + +...QQQ DUMPX1,440 +...QQQ DUMPX2,441 +...QQQ DUMPX3,442 +...QQQ DUMPX4,443 + +...QQQ RNAMX1,450 +...QQQ RNAMX2,451 +...QQQ RNAMX3,452 +...QQQ RNAMX4,453 +; MORE RENAMX ERRORS LATER + +...QQQ BKJFX1,454 + +...QQQ TIMEX1,460 +...QQQ ZONEX1,461 +...QQQ ODTNX1,462 +;463 FREE +...QQQ DILFX1,464 +...QQQ TILFX1,465 +...QQQ DATEX1,466 +...QQQ DATEX2,467 +...QQQ DATEX3,470 +...QQQ DATEX4,471 +...QQQ DATEX5,472 +...QQQ DATEX6,473 + +...QQQ TMONX1,515 +...QQQ SMONX1,515 + +...QQQ CPRTX1,520 + +...QQQ SACTX1,530 +...QQQ SACTX2,531 +...QQQ SACTX3,532 +...QQQ SACTX4,533 + +...QQQ GACTX1,540 +...QQQ GACTX2,541 + +...QQQ FFUFX1,544 +...QQQ FFUFX2,545 +...QQQ FFUFX3,546 + +...QQQ DSMX1,555 + +...QQQ RDDIX1,560 + +...QQQ SIRX1,570 + +...QQQ SSAVX1,600 +...QQQ SSAVX2,601 + +...QQQ SEVEX1,610 + +...QQQ WHELX1,614 +...QQQ CAPX1,615 +...QQQ PEEKX1,616 +...QQQ PEEKX2,617 + +...QQQ CRDIX1,620 +...QQQ CRDIX2,621 +...QQQ CRDIX3,622 +...QQQ CRDIX4,623 +...QQQ CRDIX5,624 +...QQQ CRDIX6,625 +...QQQ CRDIX7,626 + +...QQQ GTDIX1,640 +...QQQ GTDIX2,641 + +...QQQ FLINX1,650 +...QQQ FLINX2,651 +...QQQ FLINX3,652 +...QQQ FLINX4,653 + +...QQQ FLOTX1,660 +...QQQ FLOTX2,661 +...QQQ FLOTX3,662 + +...QQQ FDFRX1,700 +...QQQ FDFRX2,701 + +...QQQ ATPX1,710 +...QQQ ATPX2,711 +...QQQ ATPX3,712 +...QQQ ATPX4,713 +...QQQ ATPX5,714 +...QQQ ATPX6,715 +...QQQ ATPX7,716 +...QQQ ATPX8,717 +...QQQ ATPX9,720 +...QQQ ATPX10,721 +...QQQ ATPX11,722 +...QQQ ATPX12,723 +...QQQ ATPX13,724 + +...QQQ CVSKX1,730 +...QQQ CVSKX2,731 + +...QQQ DPX1,734 +...QQQ DPX2,735 +...QQQ STRDX1,740 +...QQQ STRDX2,741 +...QQQ STRDX3,742 + +...QQQ STTX1,744 + +...QQQ RNAMX5,750 +...QQQ RNAMX6,751 +...QQQ RNAMX7,752 +...QQQ RNAMX8,753 +...QQQ RNAMX9,754 +...QQQ RNMX10,755 +...QQQ RNMX11,756 +...QQQ RNMX12,757 + +...QQQ GJFX36,760 + +;ADD JSYS ERROR CODES HERE + +...QQQ ILINS1,770 +...QQQ ILINS2,771 +...QQQ ILINS3,772 + +;EXTRA INSTRUCTIONS ON TOPS-20 + +ADJSP==105000,,0 +ERJMP==JUMP 16, +ERCAL==JUMP 17, + \ No newline at end of file diff --git a//stink.exe.13 b//stink.exe.13 new file mode 100644 index 0000000..6ee2cd5 Binary files /dev/null and b//stink.exe.13 differ diff --git a//stink.mid.1 b//stink.mid.1 new file mode 100644 index 0000000..60e72fa --- /dev/null +++ b//stink.mid.1 @@ -0,0 +1,3424 @@ +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 + + + 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 + LOC 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 + +; 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 + +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 + +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 + PATCH7: 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 + DEFIF: 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 + +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) + + +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 + +;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 + THRDR: 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 + + + +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,. + + +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, + +;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/) + GPA: 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 +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 + +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 + ;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 + ;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 + ; 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, + ; 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, + ; 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, + ;POLISH FIXUPS + +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 + ;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 + + ;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 + ;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 + ;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 + STRTAB: 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 + ;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 + ;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 + ;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, + ; 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 + ;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 + + + + +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 + +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/) + +;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 . $ % + +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," + CAIN T,7 + JRST LI3 + CAIN T,177 ;RUBOUT + JRST LI4 + IDPB T,A + CAMN A,[(10700)CBUF+CBUFL] + JRST LI4 + + +LIS1: CAIE T," + 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 + + + +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 + +; 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, ; MORE CORE NEEDED? + JRST HASHS3 ; NO, OK + SUBI A,+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 + + +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 + +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, + GO: 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 + + +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, +] + + + +] +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, + + +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 + DMCG,[ +DDT1: MOVEI C,[CONC69 ASCIZ \J,\SA,[/9B!Q ],\DDPTR,[/Q: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 + NODMCG,[ +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 \J9B/#0 #1P\] ;# 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 + +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 + +DEFINE FOUR A,B,C,D + (<_9>+B-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> + + +;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 - + 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/ - + 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, + + + + +;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, + +; 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 + +; 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 + ISYM: 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 + + +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 + ;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: (ADR) +BPTR: (B) +DPTR: (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+<_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 + INIT: +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==/2000 ;LDR LENGTH IN BLOCKS + +INFORM [HIGHEST USED]\LOSYM +INFORM [LOWEST LOCATION LOADED ]\LOWLOD +INFORM [COMMAND BUFFER LENGTH]\ +INFORM [INITIAL CORE ALLOCATION]\INITCR + +END PDL + \ No newline at end of file diff --git a//stink.symbols.4 b//stink.symbols.4 new file mode 100644 index 0000000..24b37df Binary files /dev/null and b//stink.symbols.4 differ diff --git a//symbol.cmd.4 b//symbol.cmd.4 new file mode 100644 index 0000000..e57f7e0 --- /dev/null +++ b//symbol.cmd.4 @@ -0,0 +1,95 @@ +CONN INT: +DEL MDLXXX.*.* +DELVER +YY*.*.* +EXP +DEL MDL:MDLXXX.*.* +DEL MDL:*.SAV00.* +EXP MDL: +STINK +MMUD105.STINK@MMDLXXX.EXEYRESET . + +NDDT +;YMDLXXX.EXE +;UMDLXXX.EXE +;OMDLXXX.SYMBOLS + +INTFCNK +NAME1K +BUFRINK +PROCIDK +IOIN2K +ITEMK +NILK +TYPVECK +INAMEK +ECHOK +CHANNOK +VALK +CHRCNTK +0STOK +TYPBOTK +ERASCHK +DIRECTK +INDICK +INTFCNK +KILLCHK +TTICHNK +ASTOK +BRKCHK +NODPNTK +ESCAPK +BSTOK +TTOCHNK +SYSCHRK +BRFCHRK +CSTOK +ROOTK +ASOLNTK +BRFCH2K +BYTPTRK +INITIAK +DSTOK +ESTOK +INTOBLK +PVPSTOK +ERROBLK +MUDOBLK +TVPSTOK +ABSTOK +INTNUMK +STATUSK +INTVECK +QUEUESK +TBSTOK +CHNL1K +.LIST.K +GCPDLK +CONADJK +T.CHANK +N.CHNSK +SLENGCK +LENGCK +SECLENK +;WMDLXXX.SYMBOLS +;H +RESET . +NDDT +;YMDLXXX.EXE +;OMDLXXX.SYMBOLS +NSEGS/3 +MASK1/700541,,2007 +P;UMDLXXX.EXE +;H +RES . +CONN MDL: +NDDT +;YINT:MDLXXX.EXE +;OINT:MDLXXX.SYMBOLS +G +LIBMUD" [] ["PS" "LIBMUD"])> +;HCONN INT: +CONT +;UMDLXXX.EXE +;H +LOGOUT diff --git a//tmudv.bin.1 b//tmudv.bin.1 new file mode 100644 index 0000000..e69de29 diff --git a//tmudv.mid.1 b//tmudv.mid.1 new file mode 100644 index 0000000..b6ce52f --- /dev/null +++ b//tmudv.mid.1 @@ -0,0 +1,50 @@ +TITLE VCREATE MCR001 C. REEVE (CLR) + +RELOCA + +.INSRT MUDDLE > + +.GLOBAL VCREATE,MUDSTR + +DEBUG: MOVE E,[440600,,[SIXBIT /EXPERIMENTAL/]] + MOVEI 0,12. + JRST STUFF + +VCREATE: .SUSET [.SSNAM,,[SIXBIT /MUDSYS/]] + .OPEN 0,OP% + .VALUE + MOVEI 0,0 ; SET 0 TO DO THE .RCHST + .RCHST 0 + .CLOSE 0 + .FDELE DB% + .VALUE + MOVE E,[440600,,B] + MOVEI 0,6 +STUFF: MOVE D,[440700,,MUDSTR+2] +STUFF1: ILDB A,E ; GET A CHAR + CAIN A,0 ;SUPRESS SPACES + MOVEI A,137 ;RUBOUT'S DON'T TYPE OUT + ADDI A,40 ; TO ASCII + IDPB A,D ; STORE + SOJN 0,STUFF1 + SETZM 34 + SETZM 35 + SETZM 36 + .VALUE + +OP%: 1,,(SIXBIT /DSK/) + SIXBIT /TMUD%/ + SIXBIT />/ + +DB%: (SIXBIT /DSK/) + SIXBIT /TMUD%/ + SIXBIT //txpure.bin.2 b//txpure.bin.2 new file mode 100644 index 0000000..1175038 Binary files /dev/null and b//txpure.bin.2 differ diff --git a//txpure.mid.3 b//txpure.mid.3 new file mode 100644 index 0000000..fc80923 --- /dev/null +++ b//txpure.mid.3 @@ -0,0 +1,23 @@ + +TITLE SETPUR + +1PASS + +BOT==700000 + +.GLOBAL .LPUR,.LIMPU,HIBOT,PHIBOT,REALGC +REALGC==200000 + +LOC 140 + +.LIMPU==140 + +HIBOT==BOT +PHIBOT==BOT_<-10.> + +.LPUR==BOT + +LOC BOT + +END +  \ No newline at end of file diff --git a//utilit.bin.15 b//utilit.bin.15 new file mode 100644 index 0000000..3fb1da6 Binary files /dev/null and b//utilit.bin.15 differ diff --git a//utilit.bin.16 b//utilit.bin.16 new file mode 100644 index 0000000..a61b21a Binary files /dev/null and b//utilit.bin.16 differ diff --git a//utilit.mid.103 b//utilit.mid.103 new file mode 100644 index 0000000..43c3e0b --- /dev/null +++ b//utilit.mid.103 @@ -0,0 +1,829 @@ +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 + 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, + + +; 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 +] + + + +; 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, + + + + +; 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, + + + + +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, + + + +; 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, + +;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,],[S2NWORD,VECTMK],[SPSTK,TPMK],[SSTORE,VECTMK] +[SFRAME,],[SBYTE,],[SATOM,ATOMK],[SPVP,VECTMK],[SGATOM,GATOMK] +[SLOCID,],[SCHSTR,],[SASOC,ASMRK],[SLOCL,PAIRMK],[SABASE,ABMK] +[SLOCA,],[SLOCV,VECTMK],[SLOCU,VECTMK],[SLOCS,],[SLOCN,ASMRK] +[SLOCR,LOCRMK],[SRDTB,GCRDMK],[SLOCB,],[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 + \ No newline at end of file diff --git a//utilit.mid.104 b//utilit.mid.104 new file mode 100644 index 0000000..8a4eafc --- /dev/null +++ b//utilit.mid.104 @@ -0,0 +1,830 @@ +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 + 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, + + +; 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 +] + + + +; 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, + + + + +; 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, + + + + +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, + + + +; 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, + +;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,],[S2NWORD,VECTMK],[SPSTK,TPMK],[SSTORE,VECTMK] +[SFRAME,],[SBYTE,],[SATOM,ATOMK],[SPVP,VECTMK],[SGATOM,GATOMK] +[SLOCID,],[SCHSTR,],[SASOC,ASMRK],[SLOCL,PAIRMK],[SABASE,ABMK] +[SLOCA,],[SLOCV,VECTMK],[SLOCU,VECTMK],[SLOCS,],[SLOCN,ASMRK] +[SLOCR,LOCRMK],[SRDTB,GCRDMK],[SLOCB,],[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 + \ No newline at end of file diff --git a//utilit.mid.105 b//utilit.mid.105 new file mode 100644 index 0000000..8b8b6ff --- /dev/null +++ b//utilit.mid.105 @@ -0,0 +1,830 @@ +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 + 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, + + +; 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 +] + + + +; 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, + + + + +; 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, + + + + +ERRKIL: PUSH P,A + PUSHJ P,KILGC ; KILL THE GARBAGE COLLECTOR + POP P,A + JRST CALER + +; IF IN A PURE RSUBR, FIND ITS LENGTH AND FUDGE ITS LRU + +CKPUR: HRRZ A,FSAV(TB) ; GET NAME OF CURRENT GOODIE + SETZM CURPLN ; CLEAR FOR NONE + CAIL A,HIBOT ; IF LESS THAN TOP OF PURE ASSUME RSUBR + JRST (E) + GETYP 0,(A) ; SEE IF PURE + CAIE 0,TPCODE ; SKIP IF IT IS + JRST NPRSUB +NRSB2: HLRZ B,1(A) ; GET SLOT INDICATION + ADD B,PURVEC+1 ; POINT TO SLOT + HRROS 2(B) ; MUNG AGE + HLRE A,1(B) ; - LENGTH TO A + TRZ A,1777 + MOVNM A,CURPLN ; AND STORE + JRST (E) +NPRSUB: SKIPGE B,1(R) ; SEE IF PURE RSUBR + JRST (E) + MOVE A,R + JRST NRSB2 + +; THIS IS THE SCHEME USED TO UPDATE CERTAIN IMFORMATION USED BY THE +; BLOAT-SPEC ROUTINE TO GIVE USERS IMFORMATION ABOUT USE OF SPACE BY +; THEIR MUDDLE. + +GCSET: MOVE A,RFRETP ; COMPUTE FREE SPACE AVAILABLE + SUB A,PARTOP + MOVEM A,NOWFRE + CAMLE A,MAXFRE + MOVEM A,MAXFRE ; MODIFY MAXIMUM + HLRE A,TP ; FIND THE DOPE WORD OF THE TP STACK + MOVNS A + ADDI A,1(TP) ; CLOSE TO DOPE WORD + CAME A,TPGROW + ADDI A,PDLBUF ; NOW AT REAL DOPE WORD + HLRZ B,(A) ; GET LENGTH OF TP-STACK + MOVEM B,NOWTP + CAMLE B,CTPMX ; SEE IF THIS IS THE BIGGEST TP + MOVEM B,CTPMX + HLRE B,P ; FIND DOPE WORD OF P-STACK + MOVNS B + ADDI B,1(P) ; CLOSE TO IT + CAME B,PGROW ; SEE IF THE STACK IS BLOWN + ADDI B,PDLBUF ; POINTING TO IT + HLRZ A,(B) ; GET IN LENGTH + MOVEM A,NOWP + CAMLE A,CPMX ; SEE IF WE HAVE THE BIGGEST P STACK + MOVEM A,CPMX + POPJ P, ; EXIT + +RBLDM: JUMPGE R,CPOPJ + SKIPGE M,1(R) ; SKIP IF FUNNY + JRST RBLDM1 + + HLRS M + ADD M,PURVEC+1 + HLLM TB,2(M) + SKIPL M,1(M) + JRST RBLDM1 + PUSH P,0 + HRRZ 0,1(R) + ADD M,0 + POP P,0 +RBLDM1: SKIPN SAVM ; SKIP IF FUNNY (M) + POPJ P, ; EXIT + MOVEM M,SAVM + MOVEI M,0 + POPJ P, +CPOPJ1: +C1POPJ: AOS (P) + POPJ P, + + + +; 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, + +;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,],[S2NWORD,VECTMK],[SPSTK,TPMK],[SSTORE,VECTMK] +[SFRAME,],[SBYTE,],[SATOM,ATOMK],[SPVP,VECTMK],[SGATOM,GATOMK] +[SLOCID,],[SCHSTR,],[SASOC,ASMRK],[SLOCL,PAIRMK],[SABASE,ABMK] +[SLOCA,],[SLOCV,VECTMK],[SLOCU,VECTMK],[SLOCS,],[SLOCN,ASMRK] +[SLOCR,LOCRMK],[SRDTB,GCRDMK],[SLOCB,],[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 + \ No newline at end of file diff --git a//uuoh.bin.23 b//uuoh.bin.23 new file mode 100644 index 0000000..bbfbafa Binary files /dev/null and b//uuoh.bin.23 differ diff --git a//uuoh.bin.25 b//uuoh.bin.25 new file mode 100644 index 0000000..de390b8 Binary files /dev/null and b//uuoh.bin.25 differ diff --git a//uuoh.mid.179 b//uuoh.mid.179 new file mode 100644 index 0000000..9361703 --- /dev/null +++ b//uuoh.mid.179 @@ -0,0 +1,1086 @@ +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 + +; 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 +] + + + ;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 +] + + + +; 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 + +; 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) +] + + ;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 +] + +; 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,<_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>#> ; 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 + \ No newline at end of file diff --git a//uuoh.mid.181 b//uuoh.mid.181 new file mode 100644 index 0000000..cdd9ce1 --- /dev/null +++ b//uuoh.mid.181 @@ -0,0 +1,1092 @@ +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 + +; 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 +] + + + ;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 +] + + + +; 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 + +; 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) +] + + ;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 +] + +; 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,<_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>#> ; 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 + \ No newline at end of file diff --git a//uuoh.mid.182 b//uuoh.mid.182 new file mode 100644 index 0000000..ee49582 --- /dev/null +++ b//uuoh.mid.182 @@ -0,0 +1,1095 @@ +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 + +; 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 +] + + + ;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 +] + + + +; 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 + +; 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) +] + + ;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 +] + +; 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>#> ; 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 + \ No newline at end of file diff --git a//uuoh.mid.183 b//uuoh.mid.183 new file mode 100644 index 0000000..ece0dc6 --- /dev/null +++ b//uuoh.mid.183 @@ -0,0 +1,1095 @@ +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 + +; 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 +] + + + ;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 +] + + + +; 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 + +; 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) +] + + ;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 +] + +; 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>#> ; 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 + \ No newline at end of file diff --git a//x.x.3 b//x.x.3 new file mode 100644 index 0000000..a94ec93 Binary files /dev/null and b//x.x.3 differ diff --git a/README.md b/README.md index 75ed9b6..ed8917b 100644 --- a/README.md +++ b/README.md @@ -1 +1,3 @@ -Placeholder. +MIDAS Muddle for TOPS-20. + +There should also be support for ITS, but it won't build as is.