From: Adam Sampson Date: Fri, 20 Apr 2018 13:11:39 +0000 (+0100) Subject: Remove all the old source files. X-Git-Url: https://jxself.org/git/?a=commitdiff_plain;h=9c281a2b81a850e99edb110f62715bd39af32007;hp=021318ebb077c1f6e394ca3556d0206bda26b74a;p=pdp10-muddle.git Remove all the old source files. These aren't needed since we can fix the latest versions. --- diff --git a//agc.131 b//agc.131 deleted file mode 100644 index e44c5e7..0000000 --- a//agc.131 +++ /dev/null @@ -1,3601 +0,0 @@ -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.139 b//agc.139 deleted file mode 100644 index 1a58c58..0000000 --- a//agc.139 +++ /dev/null @@ -1,3632 +0,0 @@ -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.140 b//agc.140 deleted file mode 100644 index 433a455..0000000 --- a//agc.140 +++ /dev/null @@ -1,3632 +0,0 @@ -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//amsgc.107 b//amsgc.107 deleted file mode 100644 index 2d66f20..0000000 --- a//amsgc.107 +++ /dev/null @@ -1,865 +0,0 @@ -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.108 b//amsgc.108 deleted file mode 100644 index 4379f68..0000000 --- a//amsgc.108 +++ /dev/null @@ -1,886 +0,0 @@ -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.109 b//amsgc.109 deleted file mode 100644 index fda1ffa..0000000 --- a//amsgc.109 +++ /dev/null @@ -1,886 +0,0 @@ -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.110 b//amsgc.110 deleted file mode 100644 index 6b51e0c..0000000 --- a//amsgc.110 +++ /dev/null @@ -1,887 +0,0 @@ -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//atomhk.144 b//atomhk.144 deleted file mode 100644 index 1d1855c..0000000 --- a//atomhk.144 +++ /dev/null @@ -1,1185 +0,0 @@ - -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.149 b//atomhk.149 deleted file mode 100644 index 1fe87fa..0000000 --- a//atomhk.149 +++ /dev/null @@ -1,1193 +0,0 @@ - -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.150 b//atomhk.150 deleted file mode 100644 index 3bb9765..0000000 --- a//atomhk.150 +++ /dev/null @@ -1,1198 +0,0 @@ - -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//const.5 b//const.5 deleted file mode 100644 index 32a0ea4..0000000 --- a//const.5 +++ /dev/null @@ -1,26 +0,0 @@ -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//decl.102 b//decl.102 deleted file mode 100644 index 0cede3c..0000000 --- a//decl.102 +++ /dev/null @@ -1,1064 +0,0 @@ - -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//eval.122 b//eval.122 deleted file mode 100644 index bf17181..0000000 --- a//eval.122 +++ /dev/null @@ -1,4211 +0,0 @@ -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.123 b//eval.123 deleted file mode 100644 index e75e261..0000000 --- a//eval.123 +++ /dev/null @@ -1,4217 +0,0 @@ -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.124 b//eval.124 deleted file mode 100644 index f377766..0000000 --- a//eval.124 +++ /dev/null @@ -1,4245 +0,0 @@ -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.125 b//eval.125 deleted file mode 100644 index 9f2552b..0000000 --- a//eval.125 +++ /dev/null @@ -1,4245 +0,0 @@ -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//fopen.35 b//fopen.35 deleted file mode 100644 index 5c9c32a..0000000 --- a//fopen.35 +++ /dev/null @@ -1,4538 +0,0 @@ -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.54 b//fopen.54 deleted file mode 100644 index fcdfdf0..0000000 --- a//fopen.54 +++ /dev/null @@ -1,4686 +0,0 @@ -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.56 b//fopen.56 deleted file mode 100644 index a7512e3..0000000 --- a//fopen.56 +++ /dev/null @@ -1,4686 +0,0 @@ -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.57 b//fopen.57 deleted file mode 100644 index e42534b..0000000 --- a//fopen.57 +++ /dev/null @@ -1,4703 +0,0 @@ -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.58 b//fopen.58 deleted file mode 100644 index 302ae73..0000000 --- a//fopen.58 +++ /dev/null @@ -1,4703 +0,0 @@ -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.59 b//fopen.59 deleted file mode 100644 index c2d1c0c..0000000 --- a//fopen.59 +++ /dev/null @@ -1,4703 +0,0 @@ -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.60 b//fopen.60 deleted file mode 100644 index afe3199..0000000 --- a//fopen.60 +++ /dev/null @@ -1,4712 +0,0 @@ -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.61 b//fopen.61 deleted file mode 100644 index eb1619b..0000000 --- a//fopen.61 +++ /dev/null @@ -1,4715 +0,0 @@ -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.62 b//fopen.62 deleted file mode 100644 index 6268b96..0000000 --- a//fopen.62 +++ /dev/null @@ -1,4722 +0,0 @@ -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//gchack.45 b//gchack.45 deleted file mode 100644 index 804b865..0000000 --- a//gchack.45 +++ /dev/null @@ -1,538 +0,0 @@ - -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//initm.371 b//initm.371 deleted file mode 100644 index 1134e59..0000000 --- a//initm.371 +++ /dev/null @@ -1,1360 +0,0 @@ -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//interr.419 b//interr.419 deleted file mode 100644 index 5473cab..0000000 --- a//interr.419 +++ /dev/null @@ -1,2890 +0,0 @@ - -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.425 b//interr.425 deleted file mode 100644 index 8e73375..0000000 --- a//interr.425 +++ /dev/null @@ -1,2898 +0,0 @@ - -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//ldgc.100 b//ldgc.100 deleted file mode 100644 index d2f1c6a..0000000 --- a//ldgc.100 +++ /dev/null @@ -1,504 +0,0 @@ -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.350 b//main.350 deleted file mode 100644 index 16369e5..0000000 --- a//main.350 +++ /dev/null @@ -1,2056 +0,0 @@ -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.351 b//main.351 deleted file mode 100644 index 6b7ae6e..0000000 --- a//main.351 +++ /dev/null @@ -1,2058 +0,0 @@ -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.352 b//main.352 deleted file mode 100644 index 2be87b5..0000000 --- a//main.352 +++ /dev/null @@ -1,2058 +0,0 @@ -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.146 b//mappur.146 deleted file mode 100644 index 3d0015e..0000000 --- a//mappur.146 +++ /dev/null @@ -1,1928 +0,0 @@ - -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.159 b//mappur.159 deleted file mode 100644 index 4f64307..0000000 --- a//mappur.159 +++ /dev/null @@ -1,1972 +0,0 @@ - -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.160 b//mappur.160 deleted file mode 100644 index ceabb2c..0000000 --- a//mappur.160 +++ /dev/null @@ -1,1974 +0,0 @@ - -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.161 b//mappur.161 deleted file mode 100644 index b261d53..0000000 --- a//mappur.161 +++ /dev/null @@ -1,1975 +0,0 @@ - -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.162 b//mappur.162 deleted file mode 100644 index 416f6e8..0000000 --- a//mappur.162 +++ /dev/null @@ -1,1986 +0,0 @@ - -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//muddle.346 b//muddle.346 deleted file mode 100644 index b52d7f6..0000000 --- a//muddle.346 +++ /dev/null @@ -1,1254 +0,0 @@ -; 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.177 b//mudex.177 deleted file mode 100644 index 0284d99..0000000 --- a//mudex.177 +++ /dev/null @@ -1,1025 +0,0 @@ -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//mudits.mcr130 b//mudits.mcr130 deleted file mode 100644 index 055ee88..0000000 --- a//mudits.mcr130 +++ /dev/null @@ -1,566 +0,0 @@ - -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//mudsqu.mcr025 b//mudsqu.mcr025 deleted file mode 100644 index c9392c3..0000000 --- a//mudsqu.mcr025 +++ /dev/null @@ -1,138 +0,0 @@ - -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//nfopen.4 b//nfopen.4 deleted file mode 100644 index 235baf7..0000000 --- a//nfopen.4 +++ /dev/null @@ -1,4481 +0,0 @@ -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.mcr052 b//nfree.mcr052 deleted file mode 100644 index aa7b707..0000000 --- a//nfree.mcr052 +++ /dev/null @@ -1,276 +0,0 @@ - -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//oreadch.208 b//oreadch.208 deleted file mode 100644 index 6c2c33a..0000000 --- a//oreadch.208 +++ /dev/null @@ -1,1433 +0,0 @@ -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.315 b//primit.315 deleted file mode 100644 index 5e79bde..0000000 --- a//primit.315 +++ /dev/null @@ -1,2822 +0,0 @@ -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//print.340 b//print.340 deleted file mode 100644 index 770b48f..0000000 --- a//print.340 +++ /dev/null @@ -1,2692 +0,0 @@ -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//readch.206 b//readch.206 deleted file mode 100644 index cbbaef5..0000000 --- a//readch.206 +++ /dev/null @@ -1,1448 +0,0 @@ -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.210 b//readch.210 deleted file mode 100644 index 30fb3cc..0000000 --- a//readch.210 +++ /dev/null @@ -1,1405 +0,0 @@ -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.211 b//readch.211 deleted file mode 100644 index 16bf029..0000000 --- a//readch.211 +++ /dev/null @@ -1,1405 +0,0 @@ -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.212 b//readch.212 deleted file mode 100644 index a9e41e2..0000000 --- a//readch.212 +++ /dev/null @@ -1,1407 +0,0 @@ -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.213 b//readch.213 deleted file mode 100644 index 1aacdb9..0000000 --- a//readch.213 +++ /dev/null @@ -1,1408 +0,0 @@ -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.214 b//readch.214 deleted file mode 100644 index 385d60d..0000000 --- a//readch.214 +++ /dev/null @@ -1,1407 +0,0 @@ -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.353 b//reader.353 deleted file mode 100644 index 2e9afa5..0000000 --- a//reader.353 +++ /dev/null @@ -1,2201 +0,0 @@ - -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.355 b//reader.355 deleted file mode 100644 index 265a333..0000000 --- a//reader.355 +++ /dev/null @@ -1,2202 +0,0 @@ - -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.356 b//reader.356 deleted file mode 100644 index db5cb35..0000000 --- a//reader.356 +++ /dev/null @@ -1,2203 +0,0 @@ - -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//save.169 b//save.169 deleted file mode 100644 index 57ddaa6..0000000 --- a//save.169 +++ /dev/null @@ -1,774 +0,0 @@ -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.174 b//save.174 deleted file mode 100644 index 3397c3c..0000000 --- a//save.174 +++ /dev/null @@ -1,790 +0,0 @@ -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.175 b//save.175 deleted file mode 100644 index 7939d07..0000000 --- a//save.175 +++ /dev/null @@ -1,792 +0,0 @@ -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.176 b//save.176 deleted file mode 100644 index 7a70df5..0000000 --- a//save.176 +++ /dev/null @@ -1,799 +0,0 @@ -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.80 b//secagc.80 deleted file mode 100644 index cc0d98b..0000000 --- a//secagc.80 +++ /dev/null @@ -1,2288 +0,0 @@ - -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.81 b//secagc.81 deleted file mode 100644 index 45cd0ef..0000000 --- a//secagc.81 +++ /dev/null @@ -1,2290 +0,0 @@ - -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//specs.110 b//specs.110 deleted file mode 100644 index 9e0d177..0000000 --- a//specs.110 +++ /dev/null @@ -1,345 +0,0 @@ -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//stbuil.15 b//stbuil.15 deleted file mode 100644 index 0579fbb..0000000 --- a//stbuil.15 +++ /dev/null @@ -1,2132 +0,0 @@ - - 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.16 b//stbuil.16 deleted file mode 100644 index 819bfc5..0000000 --- a//stbuil.16 +++ /dev/null @@ -1,2132 +0,0 @@ - - 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.17 b//stbuil.17 deleted file mode 100644 index acb7171..0000000 --- a//stbuil.17 +++ /dev/null @@ -1,2133 +0,0 @@ - - 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.18 b//stbuil.18 deleted file mode 100644 index e5269f5..0000000 --- a//stbuil.18 +++ /dev/null @@ -1,2133 +0,0 @@ - - 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.19 b//stbuil.19 deleted file mode 100644 index 52ad29b..0000000 --- a//stbuil.19 +++ /dev/null @@ -1,2145 +0,0 @@ - - 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//stink.1 b//stink.1 deleted file mode 100644 index 60e72fa..0000000 --- a//stink.1 +++ /dev/null @@ -1,3424 +0,0 @@ -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//utilit.103 b//utilit.103 deleted file mode 100644 index 43c3e0b..0000000 --- a//utilit.103 +++ /dev/null @@ -1,829 +0,0 @@ -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.104 b//utilit.104 deleted file mode 100644 index 8a4eafc..0000000 --- a//utilit.104 +++ /dev/null @@ -1,830 +0,0 @@ -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//uuoh.179 b//uuoh.179 deleted file mode 100644 index 9361703..0000000 --- a//uuoh.179 +++ /dev/null @@ -1,1086 +0,0 @@ -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.181 b//uuoh.181 deleted file mode 100644 index cdd9ce1..0000000 --- a//uuoh.181 +++ /dev/null @@ -1,1092 +0,0 @@ -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.182 b//uuoh.182 deleted file mode 100644 index ee49582..0000000 --- a//uuoh.182 +++ /dev/null @@ -1,1095 +0,0 @@ -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.183 b//uuoh.183 deleted file mode 100644 index ece0dc6..0000000 --- a//uuoh.183 +++ /dev/null @@ -1,1095 +0,0 @@ -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