--- /dev/null
+TITLE AGC MUDDLE GARBAGE COLLECTOR\r
+\r
+;SYSTEM WIDE DEFINITIONS GO HERE\r
+\r
+.GLOBAL RCL,VECTOP,VECBOT,PARTOP,PARBOT,HITOP,HIBOT,GETPAG\r
+.GLOBAL PDLBUF,PDLEX,PDLEXP,GCFLG,GCPDL,GETNUM,PARNEW,MOVPUR\r
+.GLOBAL PGROW,TPGROW,TIMOUT,MAINPR,%SLEEP,MSGTYP,PURTOP,PURBOT,STOSTR\r
+.GLOBAL MTYI,UPLO,FRMUNG,BYTDOP,GLOBSP,SYSMAX,FREDIF,FREMIN,GCHAPN,INTFLG\r
+.GLOBAL SAT,TTOCHN,TYPVEC,ICONS,INCONS,IBLOCK,IEUVEC,IEVECTI,CELL2\r
+.GLOBAL GIBLOK,REHASH,IBLOK1,IILIST,IIFORM,CIVEC,CIUVEC,CICONS\r
+.GLOBAL SPBASE,OUTRNG,CISTNG,%RUNAM,PURVEC,GCDOWN,N.CHNS,CHNL1\r
+.GLOBAL CAFRE,CAFRET,STOGC,GCHN,WNDP,FRNP,%GCJOB,%SHWND,%SHFNT,%INFMP,%GETIP\r
+.GLOBAL TD.PUT,TD.GET,TD.LNT\r
+.GLOBAL CTIME,MTYO,ILOC,GCRSET\r
+.GLOBAL GCTIM,GCCAUS,GCCALL,AAGC,LVLINC,STORIC,GVLINC,TYPIC\r
+; GLOBALS ASSOCIATE WITH THE ASSOCIATION VECTOR\r
+\r
+.GLOBAL ASOVEC,ASOLNT,ITEM,INDIC,VAL,NWORDT,NODPNT,PNTRS\r
+.GLOBAL CELL,BINDID,GCFLCH,TYPBOT,GLOBAS,TPBASE\r
+\r
+.GLOBAL P.TOP,P.CORE,PMAP\r
+\r
+NGCS==8 ; AFTER NGCS, DO HAIRY VAL/ASSOC FLUSH\r
+PDLBUF=100\r
+TPMAX==20000 ;PDLS LARGER THAN THIS WILL BE SHRUNK\r
+PMAX==4000 ;MAXIMUM PSTACK SIZE\r
+TPMIN==1000 ;MINIMUM PDL SIZES\r
+PMIN==400\r
+TPGOOD==10000 ; A GOOD STACK SIZE\r
+PGOOD==1000\r
+.ATOM.==200000 ; FLAG SAYING ATOMS MARKED (FOR VAL FLUSH LOGIC)\r
+\r
+GCHN==0 ; CHANNEL FOR FUNNNY INFERIOR\r
+STATNO==19. ; # OF STATISTICS FOR BLOAT-STAT\r
+STATGC==8. ; # OF GC-STATISTICS FOR BLOAT-STAT\r
+\r
+\r
+RELOCATABLE\r
+.INSRT MUDDLE >\r
+\r
+TYPNT=AB ;SPECIAL AC USAGE DURING GC\r
+F=TP ;ALSO SPECIAL DURING GC\r
+LPVP=SP ;SPECIAL FOR GC, HOLDS POINTER TO PROCESS CHAIN\r
+FPTR=TB ; POINT TO CURRENT FRONTIER OF INFERIOR\r
+\r
+\r
+; WINDOW AND FRONTIER PAGES\r
+\r
+FRONT==776000 ; PAGE 255. IS FRONTIER\r
+WIND==774000 ; PAGE 254. IS WINDOW\r
+FRNP==FRONT/2000\r
+WNDP==WIND/2000\r
+\r
+\r
+\r
+\r
+\r
+\f\r
+.GLOBAL FLIST\r
+\r
+MFUNCTION BLOATSTAT,SUBR,[BLOAT-STAT]\r
+\r
+ENTRY\r
+\r
+ JUMPGE AB,GETUVC ; SEE IF THERE IS AN ARGUMENT\r
+ GETYP A,(AB)\r
+ CAIE A,TUVEC ; SEE IF THE ARGUMENT IS A UVECTOR\r
+ JRST WTYP1 ; IF NOT COMPLAIN\r
+ HLRE 0,1(AB)\r
+ MOVNS 0\r
+ CAIGE 0,STATNO+STATGC ; SEE IF UVECTOR IS RIGHT LENGTH\r
+ JRST WTYP1\r
+ CAMGE AB,[-2,,0] ; SEE IF THERE ARE TOO MANY ARGUMENTS\r
+ JRST TMA\r
+ MOVE A,(AB) ; GET THE UVECTOR\r
+ MOVE B,1(AB)\r
+ JRST SETUV ; CONTINUE\r
+GETUVC: MOVEI A,STATNO+STATGC ; CREATE A UVECTOR\r
+ PUSHJ P,IBLOCK\r
+SETUV: PUSH P,A ; SAVE UVECTOR\r
+ PUSH P,B\r
+ MOVE 0,NOWFRE ; COMPUTE FREE STORAGE USED SINCE LAST GC\r
+ SUB 0,VECBOT\r
+ ADD 0,PARTOP\r
+ MOVEM 0,CURFRE\r
+ HLRE 0,TP ; COMPUTE STACK SPACE USED UP\r
+ ADD 0,NOWTP\r
+ SUBI 0,PDLBUF\r
+ MOVEM 0,CURTP\r
+ MOVE B,IMQUOTE THIS-PROCESS\r
+ PUSHJ P,ILOC\r
+ HRRZS B\r
+ HRRZ C,TPBASE+1(PVP) ; CALCULATE # OF ATOM SLOTS\r
+ MOVE 0,B\r
+ HRRZ D,SPBASE+1(PVP) ; COMPUTE CURRENT # OF BINDINGS\r
+ SUB 0,D\r
+ IDIVI 0,6\r
+ MOVEM 0,CURLVL\r
+ SUB B,C ; TOTAL WORDS ATOM STORAGE\r
+ IDIVI B,6 ; COMPUTE # OF SLOTS\r
+ MOVEM B,NOWLVL\r
+ HRRZ A,GLOBASE+1(TVP) ; COMPUTE TOTAL # OF GLOBAL SLOTS\r
+ HLRE 0,GLOBASE+1(TVP)\r
+ SUB A,0 ; POINT TO DOPE WORD\r
+ HLRZ B,1(A)\r
+ ASH B,-2 ; # OF GVAL SLOTS\r
+ MOVEM B,NOWGVL\r
+ HRRZ 0,GLOBASE+1(TVP) ; COMPUTE # OF GVAL SLOTS IN USE\r
+ HRRZ A,GLOBSP+1(TVP)\r
+ SUB A,0\r
+ ASH A,-2 ; NEGATIVE # OF SLOTS USED\r
+ SUBI B,(A)\r
+ MOVEM B,CURGVL\r
+ HRRZ A,TYPBOT+1(TVP) ; GET LENGTH OF TYPE VECTOR\r
+ HLRE 0,TYPBOT+1(TVP)\r
+ SUB A,0\r
+ HLRZ B,1(A) ; # OF WORDS IN TYPE-VECTOR\r
+ IDIVI B,2 ; CONVERT TO # OF TYPES\r
+ MOVEM B,NOWTYP\r
+ HLRE 0,TYPVEC+1(TVP) ; LENGTH OF VISABLE TYPE-VECTOR\r
+ MOVNS 0\r
+ IDIVI 0,2 ; GET # OF TYPES\r
+ MOVEM 0,CURTYP\r
+ MOVE 0,CODTOP ; GET LENGTH OF STATIONARY IMPURE STORAGE\r
+ MOVEM 0,NOWSTO\r
+ SETZB B,D ; ZERO OUT MAXIMUM\r
+ HRRZ C,FLIST\r
+LOOPC: HLRZ 0,(C) ; GET BLK LENGTH\r
+ ADD D,0 ; ADD # OF WORDS IN BLOCK\r
+ CAMGE B,0 ; SEE IF NEW MAXIMUM\r
+ MOVE B,0\r
+ HRRZ C,(C) ; POINT TO NEXT BLOCK\r
+ JUMPN C,LOOPC ; REPEAT\r
+ MOVEM D,CURSTO\r
+ MOVEM B,CURMAX\r
+ HLRE 0,P ; GET AMOUNT OF ROOM LEFT ON P\r
+ ADD 0,NOWP\r
+ SUBI 0,PDLBUF\r
+ MOVEM 0,CURP\r
+ PUSHJ P,GCSET ; FIX UP BLOAT-STAT PARAMETERS\r
+ MOVSI C,BSTGC ; SET UP BLT FOR GC FIGURES\r
+ HRRZ B,(P) ; RESTORE B\r
+ HRR C,B\r
+ BLT C,(B)STATGC-1\r
+ HRLI C,BSTAT ; MODIFY BLT FOR STATS\r
+ ADDI C,STATGC ; B HAS ELEMENTS\r
+ BLT C,(B)STATGC+STATNO-1\r
+ MOVEI 0,TFIX\r
+ HRLM 0,(B)STATNO+STATGC ; MOVE IN UTYPE\r
+ POP P,B\r
+ POP P,A ; RESTORE TYPE-WORD\r
+ JRST FINIS\r
+\r
+\r
+; THIS IS THE SCHEME USED TO UPDATE CERTAIN IMFORMATION USED BY THE\r
+; BLOAT-SPEC ROUTINE TO GIVE USERS IMFORMATION ABOUT USE OF SPACE BY\r
+; THEIR MUDDLE.\r
+\r
+GCRSET: SETZM GCNO ; CALL FROM INIT, ZAP ALL 1ST\r
+ MOVE 0,[GCNO,,GCNO+1]\r
+ BLT 0,GCCALL\r
+\r
+GCSET: MOVE A,VECBOT ; COMPUTE FREE SPACE AVAILABLE\r
+ SUB A,PARTOP\r
+ MOVEM A,NOWFRE\r
+ CAMLE A,MAXFRE\r
+ MOVEM A,MAXFRE ; MODIFY MAXIMUM\r
+ HLRE A,TP ; FIND THE DOPE WORD OF THE TP STACK\r
+ MOVNS A\r
+ ADDI A,1(TP) ; CLOSE TO DOPE WORD\r
+ CAME A,TPGROW\r
+ ADDI A,PDLBUF ; NOW AT REAL DOPE WORD\r
+ HLRZ B,(A) ; GET LENGTH OF TP-STACK\r
+ MOVEM B,NOWTP\r
+ CAMLE B,CTPMX ; SEE IF THIS IS THE BIGGEST TP\r
+ MOVEM B,CTPMX\r
+ HLRE B,P ; FIND DOPE WORD OF P-STACK\r
+ MOVNS B\r
+ ADDI B,1(P) ; CLOSE TO IT\r
+ CAME B,PGROW ; SEE IF THE STACK IS BLOWN\r
+ ADDI B,PDLBUF ; POINTING TO IT\r
+ HLRZ A,(B) ; GET IN LENGTH\r
+ MOVEM A,NOWP\r
+ CAMLE A,CPMX ; SEE IF WE HAVE THE BIGGEST P STACK\r
+ MOVEM A,CPMX\r
+ POPJ P, ; EXIT\r
+\r
+\r
+.GLOBAL PGFIND,PGGIVE,PGTAKE,PGINT\r
+\r
+; FIND AND ALLOCATE AS MANY CONTIGUOUS PAGES AS INDICATED BY REG A\r
+; RETURN THE NUMBER (0-255.) OF THE FIRST SUCH PAGE IN REG B\r
+; RETURN -1 IN REG B IF NONE FOUND\r
+\r
+PGFIND:\r
+ JUMPLE A,FPLOSS\r
+ PUSHJ P,PGFND1 ; SEE IF ALREADY ENOUGH\r
+ SKIPL B ; SKIP IF LOST\r
+ POPJ P,\r
+\r
+ SUBM M,(P)\r
+ PUSH P,E\r
+ PUSH P,C\r
+ PUSH P,D\r
+ MOVE C,PURBOT ; CHECK IF ROOM AT ALL\r
+ SUB C,P.TOP ; TOTAL SPACE\r
+ MOVEI D,(C) ; COPY FOR CONVERSION TO PAGES\r
+ ASH D,-10.\r
+ CAIGE C,(A) ; SKIP IF COULD WIN\r
+ JRST PGFLOS\r
+\r
+ MOVNS A ; MOVE PURE AREA DOWN "A" PAGES\r
+ PUSHJ P,MOVPUR\r
+ MOVE B,PURTOP ; GET FIRST PAGE ALLOCATED\r
+ ASH B,-10. ; TO PAGE #\r
+PGFLOS: POP P,D\r
+ POP P,C\r
+ POP P,E\r
+ PUSHJ P,RBLDM ; GET A NEW VALUE FOR M\r
+ JRST MPOPJ\r
+\r
+PGFND1: PUSH P,E\r
+ PUSH P,D\r
+ PUSH P,C\r
+ PUSH P,[-1] ;POSSIBLE CONTENTS FOR REG B\r
+ PUSH P,A ;SAVE LENGTH OF BLOCK DESIRED FOR LATER USE\r
+ SETZB B,C ;INITIAL SECTION AND PAGE NUMBERS\r
+ MOVEI 0,0 ;COUNT OF PAGES ALREADY FOUND\r
+ PUSHJ P,PINIT\r
+PLOOP: TDNE E,D ;FREE PAGE ?\r
+ JRST NOTFRE ;NO\r
+ JUMPN 0,NFIRST ;FIRST FREE PAGE OF A BLOCK ?\r
+ MOVEI A,(B) ;YES SAVE ADDRESS OF PAGE IN REG A\r
+ IMULI A,32.\r
+ ADDI A,(C)\r
+NFIRST: ADDI 0,1\r
+ CAML 0,(P) ;TEST IF ENOUGH PAGES HAVE BEEN FOUND\r
+ JRST PWIN ;YES, FINISHED\r
+ SKIPA \r
+NOTFRE: MOVEI 0,0 ;RESET COUNT\r
+ PUSHJ P,PNEXT ;NEXT PAGE\r
+ JRST PLOSE ;NONE--LOSE RETURNING -1 IN REG B\r
+ JRST PLOOP\r
+\r
+PWIN: MOVEI B,(A) ;GET WINNING ADDRESS\r
+ MOVEM B,(P)-1 ;RETURN ADDRESS OF WINNING PAGE\r
+ MOVE A,(P) ;RELOAD LENGTH OF BLOCK OF PAGES\r
+ MOVE 0,[TDO E,D] ;INST TO SET "BUSY" BITS\r
+ JRST ITAKE\r
+\r
+;CLAIM OR RETURN TO FREE STORAGE AS MANY CONTIGUOUS PAGES AS INDICATED BY REG A\r
+;THE NUMBER (0 - 255.) OF THE FIRST SUCH PAGE IS IN REG B\r
+PGGIVE: MOVE 0,[TDZ E,D] ;INST TO SET "FREE" BITS\r
+ SKIPA\r
+PGTAKE: MOVE 0,[TDO E,D] ;INST TO SET "BUSY" BITS\r
+ JUMPLE A,FPLOSS\r
+ CAIL B,0\r
+ CAILE B,255.\r
+ JRST FPLOSS\r
+ PUSH P,E\r
+ PUSH P,D\r
+ PUSH P,C\r
+ PUSH P,B\r
+ PUSH P,A\r
+ITAKE: IDIVI B,32.\r
+ PUSHJ P,PINIT\r
+ SUBI A,1\r
+RTL: XCT 0 ;SET APPROPRIATE BIT\r
+ PUSHJ P,PNEXT ;NEXT PAGE'S BIT\r
+ JUMPG A,FPLOSS ;TOO MANY ?\r
+ SOJGE A,RTL\r
+ MOVEM E,PMAP(B) ;REPLACE BIT MASK\r
+PLOSE: POP P,A\r
+ POP P,B\r
+ POP P,C\r
+ POP P,D\r
+ POP P,E\r
+ POPJ P,\r
+\r
+\r
+PINIT: MOVE E,PMAP(B) ;GET BITS FOR THIS SECTION\r
+ HRLZI D,400000 ;BIT MASK\r
+ MOVNS C\r
+ LSH D,(C) ;SHIFT TO APPROPRIATE BIT POSITION\r
+ MOVNS C\r
+ POPJ P,\r
+\r
+PNEXT: AOS (P) ;FOR SKIP RETURN ON EXPECTED SUCCESS\r
+ LSH D,-1 ;CONSIDER NEXT PAGE\r
+ CAIGE C,31. ;FINISHED WITH THIS SECTION ?\r
+ AOJA C,CPOPJ ;NO, INCREMENT AND CONTINUE\r
+ MOVEM E,PMAP(B) ;REPLACE BIT MASK\r
+ SETZ C,\r
+ CAIGE B,7. ;LAST SECTION ?\r
+ AOJA B,PINIT ;NO, INCREMENT AND CONTINUE\r
+ SOS (P) ;YES, UNDO SKIP RETURN\r
+ POPJ P,\r
+\r
+FPLOSS: FATAL PAGE LOSSAGE\r
+\r
+PGINT: MOVEI B,HIBOT ;INITIALIZE MUDDLE'S PAGE MAP TABLE\r
+ IDIVI B,2000 ;FIRST PAGE OF PURE CODE\r
+ MOVE C,HITOP\r
+ IDIVI C,2000\r
+ MOVEI A,(C)+1\r
+ SUBI A,(B) ;NUMBER OF SUCH PAGES\r
+ PUSHJ P,PGTAKE ;MARK THESE PAGES AS TAKEN\r
+ POPJ P,\r
+; USER GARBAGE COLLECTOR INTERFACE\r
+\r
+MFUNCTION GC,SUBR\r
+ ENTRY\r
+\r
+ JUMPGE AB,GC1\r
+ CAMGE AB,[-4,,0]\r
+ JRST TMA\r
+ PUSHJ P,GETFIX ; GET FREEE MIN IF GIVEN\r
+ MOVEM A,FREMIN\r
+ ADD AB,[2,,2] ; NEXT ARG\r
+ JUMPGE AB,GC1 ; NOT SUPPLIED\r
+ PUSHJ P,GETFIX ; GET FREDIF\r
+ MOVEM A,FREDIF\r
+GC1: PUSHJ P,COMPRM ; GET CURRENT USED CORE\r
+ PUSH P,A\r
+ MOVEI A,1\r
+ MOVEM A,GCHAIR ; FORCE FLUSH OF VALS ASSOCS\r
+ MOVE C,[11,,0] ; INDICATOR FOR AGC\r
+ PUSHJ P,AGC ; COLLECT THAT TRASH\r
+ SKIPGE A ; SKIP IF OK\r
+ PUSHJ P,FULLOS ; COMPLAIN ABOUT LACK OF SPACE\r
+ PUSHJ P,COMPRM ; HOW MUCH ROOM NOW?\r
+ POP P,B ; RETURN AMOUNT\r
+ SUB B,A\r
+ MOVSI A,TFIX\r
+ JRST FINIS\r
+\r
+\r
+COMPRM: MOVE A,PARTOP ; USED SPACE\r
+ SUB A,PARBOT\r
+ ADD A,VECTOP\r
+ SUB A,VECBOT\r
+ POPJ P,\r
+\r
+MFUNCTION GCDMON,SUBR,[GC-MON]\r
+\r
+ ENTRY 1\r
+\r
+ SETZM GCMONF ; ASSUME FALSE\r
+ GETYP 0,(AB)\r
+ CAIE 0,TFALSE\r
+ SETOM GCMONF\r
+ MOVE A,(AB)\r
+ MOVE B,1(AB)\r
+ JRST FINIS\r
+.GLOBAL EVATYP,APLTYP,PRNTYP\r
+\r
+\fMFUNCTION BLOAT,SUBR\r
+ ENTRY\r
+\r
+ MOVEI C,0 ; FLAG TO SAY WHETHER NEED A GC\r
+ MOVSI E,-NBLO ; AOBJN TO BLOATER TABLE\r
+\r
+BLOAT2: JUMPGE AB,BLOAT1 ; ALL DONE?\r
+ PUSHJ P,NXTFIX ; GET NEXT BLOAT PARAM\r
+ PUSHJ P,@BLOATER(E) ; DISPATCH\r
+ AOBJN E,BLOAT2 ; COUNT PARAMS SET\r
+\r
+ JUMPL AB,TMA ; ANY LEFT...ERROR\r
+BLOAT1: JUMPE C,BLOATD ; DONE, NO GC NEEDED\r
+ MOVEI 0,1\r
+ MOVEM 0,GCHAIR ; FORCE HAIR TO OCCUR\r
+ MOVE C,E ; MOVE IN INDICATOR\r
+ HRLI C,1 ; INDICATE THAT IT COMES FROM BLOAT\r
+ PUSHJ P,AGC ; DO ONE\r
+ SKIPGE A\r
+ PUSHJ P,FULLOS ; NO CORE LEFT\r
+ SKIPE A,TPBINC ; SMASH POINNTERS\r
+ ADDM A,TPBASE+1(PVP)\r
+ SKIPE A,GLBINC ; GLOBAL SP\r
+ ADDM A,GLOBASE+1(TVP)\r
+ SKIPE A,TYPINC\r
+ ADDM A,TYPBOT+1(TVP)\r
+ SETZM TPBINC ; RESET PARAMS\r
+ SETZM GLBINC\r
+ SETZM TYPINC\r
+\r
+BLOATD: MOVE B,VECBOT\r
+ SUB B,PARTOP\r
+ MOVSI A,TFIX ; RETURN CORE FOUND\r
+ JRST FINIS\r
+\r
+; TABLE OF BLOAT ROUTINES\r
+\r
+BLOATER:\r
+ MAINB\r
+ TPBLO\r
+ LOBLO\r
+ GLBLO\r
+ TYBLO\r
+ STBLO\r
+ PBLO\r
+ SFREM\r
+ SFRED\r
+ SLVL\r
+ SGVL\r
+ STYP\r
+ SSTO\r
+ NBLO==.-BLOATER\r
+\r
+; BLOAT MAIN STORAGE AREA\r
+\r
+MAINB: MOVE D,VECBOT ; COMPUTE CURRENT ROOM\r
+ SUB D,PARTOP\r
+ CAMGE A,D ; NEED MORE?\r
+ POPJ P, ; NO, LEAVE\r
+ MOVEM A,GETNUM ; SAVE\r
+ AOJA C,CPOPJ ; LEAVE SETTING C\r
+\r
+; BLOAT TP STACK (AT TOP)\r
+\r
+TPBLO: HLRE D,TP ; GET -SIZE\r
+ MOVNS B,D\r
+ ADDI D,1(TP) ; POINT TO DOPE (ALMOST)\r
+ CAME D,TPGROW ; BLOWN?\r
+ ADDI D,PDLBUF ; POINT TO REAL DOPE WORD\r
+ CAMG A,B ; SKIP IF GROWTH NEEDED\r
+ POPJ P,\r
+ ASH A,-6 ; CONVERT TO 64 WD BLOCKS\r
+ CAILE A,377\r
+ JRST OUTRNG\r
+ DPB A,[111100,,-1(D)] ; SMASH SPECS IN\r
+ AOJA C,CPOPJ\r
+\r
+; BLOAT TOP LEVEL LOCALS\r
+\r
+LOBLO: IMULI A,6 ; 6 WORDS PER BINDING\r
+ HRRZ 0,TPBASE+1(PVP)\r
+ HRRZ B,SPBASE+1(PVP) ; ROOM AVAIL TO E\r
+ SUB B,0\r
+ SUBI A,(B) ; HOW MUCH MORE?\r
+ JUMPLE A,CPOPJ ; NONE NEEDED\r
+ MOVEI B,TPBINC\r
+ PUSHJ P,NUMADJ\r
+ DPB A,[1100,,-1(D)] ; SMASH\r
+ AOJA C,CPOPJ\r
+\r
+; GLOBAL SLOT GROWER\r
+\r
+GLBLO: ASH A,2 ; 4 WORDS PER VAR\r
+ MOVE D,GLOBASE+1(TVP) ; CURRENT LIMITS\r
+ HRRZ B,GLOBSP+1(TVP)\r
+ SUBI B,(D)\r
+ SUBI A,(B) ; NEW AMOUNT NEEDED\r
+ JUMPLE A,CPOPJ\r
+ MOVEI B,GLBINC ; WHERE TO KEEP UPDATE\r
+ PUSHJ P,NUMADJ ; FIX NUMBER\r
+ HLRE 0,D\r
+ SUB D,0 ; POINT TO DOPE\r
+ DPB A,[1100,,(D)] ; AND SMASH\r
+ AOJA C,CPOPJ\r
+\r
+; HERE TO GROW TYPE VECTOR (AND FRIENDS)\r
+\r
+TYBLO: ASH A,1 ; TWO WORD PER TYPE\r
+ HRRZ B,TYPBOT+1(TVP) ; FIND CURRENT ROOM\r
+ MOVE D,TYPVEC+1(TVP)\r
+ SUBI B,(D)\r
+ SUBI A,(B) ; EXTRA NEEDED TO A\r
+ JUMPLE A,CPOPJ ; NONE NEEDED, LEAVE\r
+ MOVEI B,TYPINC ; WHERE TO STASH SPEC\r
+ PUSHJ P,NUMADJ ; FIX NUMBER\r
+ HLRE 0,D ; POINT TO DOPE\r
+ SUB D,0\r
+ DPB A,[1100,,(D)]\r
+ SKIPE D,EVATYP+1(TVP) ; GROW AUX TYPE VECS IF NEEDED\r
+ PUSHJ P,SGROW1\r
+ SKIPE D,APLTYP+1(TVP)\r
+ PUSHJ P,SGROW1\r
+ SKIPE D,PRNTYP+1(TVP)\r
+ PUSHJ P,SGROW1\r
+ AOJA C,CPOPJ\r
+\r
+; HERE TO CREATE STORAGE SPACE\r
+\r
+STBLO: MOVE D,PARBOT ; HOW MUCH NOW HERE\r
+ SUB D,CODTOP\r
+ SUBI A,(D) ; MORE NEEDED?\r
+ JUMPLE A,CPOPJ\r
+ MOVEM A,PARNEW ; FORCE PAIR SPACE TO MOVE ON OUT\r
+ AOJA C,CPOPJ\r
+\r
+; BLOAT P STACK\r
+\r
+PBLO: HLRE D,P\r
+ MOVNS B,D\r
+ SUBI D,5 ; FUDGE FOR THIS CALL\r
+ SUBI A,(D)\r
+ JUMPLE A,CPOPJ\r
+ ADDI B,1(P) ; POINT TO DOPE\r
+ CAME B,PGROW ; BLOWN?\r
+ ADDI B,PDLBUF ; NOPE, POIN TO REAL D.W.\r
+ ASH A,-6 ; TO 64 WRD BLOCKS\r
+ CAILE A,377 ; IN RANGE?\r
+ JRST OUTRNG\r
+ DPB A,[111100,,-1(B)]\r
+ AOJA C,CPOPJ\r
+ \r
+; SET FREMIN\r
+\r
+SFREM: MOVEM A,FREMIN\r
+ POPJ P,\r
+\r
+; SET FREDIF\r
+\r
+SFRED: MOVEM A,FREDIF\r
+ POPJ P,\r
+\r
+; SET LVAL INCREMENT\r
+\r
+SLVL: IMULI A,6 ; CALCULATE AMOUNT TO GROW B\r
+ IDIVI A,64. ; # OF GROW BLOCKS NEEDED\r
+ CAIE B,0 ; DOES B HAVE A REMAINDER\r
+ ADDI A,1 ; IF SO ADD A BLOCK\r
+ MOVEM A,LVLINC\r
+ POPJ P,\r
+\r
+; SET GVAL INCREMENT\r
+\r
+SGVL: IDIVI A,16. ; CALCULATE NUMBER OF GROW BLOCKS NEEDED\r
+ CAIE B,0\r
+ ADDI A,1 ; COMPENSATE FOR EXTRA\r
+ MOVEM A,GVLINC\r
+ POPJ P,\r
+\r
+; SET TYPE INCREMENT\r
+\r
+STYP: IDIVI A,32. ; CALCULATE NUMBER OF GROW BLOCKS NEEDED\r
+ CAIE B,0\r
+ ADDI A,1 ; COMPENSATE FOR EXTRA\r
+ MOVEM A,TYPIC\r
+ POPJ P,\r
+\r
+; SET STORAGE INCREMENT\r
+\r
+SSTO: IDIVI A,2000 ; # OF BLOCKS\r
+ CAIE B,0 ; REMAINDER?\r
+ ADDI A,1\r
+ IMULI A,2000 ; CONVERT BACK TO WORDS\r
+ MOVEM A,STORIC\r
+ POPJ P,\r
+\r
+\r
+; GET NEXT (FIX) ARG\r
+\r
+NXTFIX: PUSHJ P,GETFIX\r
+ ADD AB,[2,,2]\r
+ POPJ P,\r
+\r
+; ROUTINE TO GET POS FIXED ARG\r
+\r
+GETFIX: GETYP A,(AB)\r
+ CAIE A,TFIX\r
+ JRST WRONGT\r
+ SKIPGE A,1(AB)\r
+ JRST BADNUM\r
+ POPJ P,\r
+\r
+\r
+; GET NUMBERS FIXED UP FOR GROWTH FIELDS\r
+\r
+NUMADJ: ADDI A,77 ; ROUND UP\r
+ ANDCMI A,77 ; KILL CRAP\r
+ MOVE 0,A\r
+ MOVNS A ; COMPUTE ADD FACTOR FOR SPEC. POINTER UPDATE\r
+ HRLI A,-1(A)\r
+ MOVEM A,(B) ; AND STASH IT\r
+ MOVE A,0\r
+ ASH A,-6 ; TO 64 WD BLOCKS\r
+ CAILE A,377 ; CHECK FIT\r
+ JRST OUTRNG\r
+ POPJ P,\r
+\r
+; DO SYMPATHETIC GROWTHS\r
+\r
+SGROW1: HLRE 0,D\r
+ SUB D,0\r
+ DPB A,[111100,,(D)]\r
+ POPJ P,\r
+\r
+\f;FUNCTION TO CONSTRUCT A LIST\r
+\r
+MFUNCTION CONS,SUBR\r
+\r
+ ENTRY 2\r
+ GETYP A,2(AB) ;GET TYPE OF 2ND ARG\r
+ CAIE A,TLIST ;LIST?\r
+ JRST WTYP2 ;NO , COMPLAIN\r
+ MOVE C,(AB) ; GET THING TO CONS IN\r
+ MOVE D,1(AB)\r
+ HRRZ E,3(AB) ; AND LIST\r
+ PUSHJ P,ICONS ; INTERNAL CONS\r
+ JRST FINIS\r
+\r
+; COMPILER CALL TO CONS\r
+\r
+CICONS: SUBM M,(P)\r
+ PUSHJ P,ICONS\r
+MPOPJ: SUBM M,(P)\r
+ POPJ P,\r
+\r
+; INTERNAL CONS TO NIL--INCONS\r
+\r
+INCONS: MOVEI E,0\r
+\r
+; INTERNAL CONS--ICONS; C,D VALUE, E CDR\r
+\r
+ICONS: GETYP A,C ; CHECK TYPE OF VAL\r
+ PUSHJ P,NWORDT ; # OF WORDS\r
+ SOJN A,ICONS1 ; JUMP IF DEFERMENT NEEDED\r
+ PUSHJ P,ICELL2 ; NO DEFER, GET 2 WORDS FROM PAIR SPACE\r
+ JRST ICONS2 ; NO CORE, GO GC\r
+ HRRI C,(E) ; SET UP CDR\r
+ICONS3: MOVEM C,(B) ; AND STORE\r
+ MOVEM D,1(B)\r
+TLPOPJ: MOVSI A,TLIST\r
+ POPJ P,\r
+\r
+; HERE IF CONSING DEFERRED\r
+\r
+ICONS1: MOVEI A,4 ; NEED 4 WORDS\r
+ PUSHJ P,ICELL ; GO GET 'EM\r
+ JRST ICONS2 ; NOT THERE, GC\r
+ HRLI E,TDEFER ; CDR AND DEFER\r
+ MOVEM E,(B) ; STORE\r
+ MOVEI E,2(B) ; POINT E TO VAL CELL\r
+ HRRZM E,1(B)\r
+ MOVEM C,(E) ; STORE VALUE\r
+ MOVEM D,1(E)\r
+ JRST TLPOPJ\r
+\r
+\r
+\r
+; HERE TO GC ON A CONS\r
+\r
+ICONS2: PUSH TP,C ; SAVE VAL\r
+ PUSH TP,D\r
+ PUSH TP,$TLIST\r
+ PUSH TP,E ; SAVE VITAL STUFF\r
+ MOVEM A,GETNUM ; AMOUNT NEEDED\r
+ MOVE C,[3,,1] ; INDICATOR FOR AGC\r
+ PUSHJ P,AGC ; ATTEMPT TO WIN\r
+ SKIPGE A ; SKIP IF WON\r
+ PUSHJ P,FULLOS\r
+ MOVE D,-2(TP) ; RESTORE VOLATILE STUFF\r
+ MOVE C,-3(TP)\r
+ MOVE E,(TP)\r
+ SUB TP,[4,,4]\r
+ JRST ICONS ; BACK TO DRAWING BOARD\r
+\r
+; SUBROUTINE TO ALLOCATE WORDS IN PAIR SPACE. CALLS AGC IF NEEDED\r
+\r
+CELL2: MOVEI A,2 ; USUAL CASE\r
+CELL: PUSHJ P,ICELL ; INTERNAL\r
+ JRST .+2 ; LOSER\r
+ POPJ P,\r
+\r
+ MOVEM A,GETNUM ; AMOUNT REQUIRED\r
+ PUSH P,A ; PREVENT AGC DESTRUCTION\r
+ MOVE C,[3,,1] ; INDICATOR FOR AGC\r
+ PUSHJ P,AGC\r
+ SKIPGE A ; SKIP IF WINNER\r
+ PUSHJ P,FULLOS ; REPORT TROUBLE\r
+ POP P,A\r
+ JRST CELL ; AND TRY AGAIN\r
+\r
+; INTERNAL CELL GETTER, SKIPS IF ROO EXISTS, ELSE DOESN'T\r
+\r
+ICELL2: MOVEI A,2 ; MOST LIKELY CAE\r
+ICELL: SKIPE B,RCL\r
+ JRST ICELRC ;SEE IF WE CAN RE-USE A RECYCLE CELL\r
+ MOVE B,PARTOP ; GET TOP OF PAIRS\r
+ ADDI B,(A) ; BUMP\r
+ CAMLE B,VECBOT ; SKIP IF OK.\r
+ POPJ P, ; LOSE\r
+ EXCH B,PARTOP ; SETUP NEW PARTOP AND RETURN POINTER\r
+ PUSH P,B ; MODIFY TOTAL # OF FREE WORDS\r
+ MOVE B,USEFRE\r
+ ADDI B,(A)\r
+ MOVEM B,USEFRE\r
+ POP P,B\r
+ JRST CPOPJ1 ; SKIP RETURN\r
+\r
+ICELRC: CAIE A,2\r
+ JRST ICELL+2 ;IF HE DOESNT WANT TWO, USE OLD METHOD\r
+ PUSH P,A\r
+ MOVE A,(B)\r
+ HRRZM A,RCL\r
+ POP P,A\r
+ SETZM (B) ;GIVE HIM A CLEAN RECYCLED CELL\r
+ SETZM 1(B)\r
+ JRST CPOPJ ;THAT IT\r
+\r
+;SUBROUTINES TO RETURN WORDS NEEDED BASED ON TYPE OR SAT\r
+\r
+NWORDT: PUSHJ P,SAT ;GET STORAGE ALLOC TYPE\r
+NWORDS: CAIG A,NUMSAT ; TEMPLATE?\r
+ SKIPL MKTBS(A) ;-ENTRY IN TABLE MEANS 2 NEEDED\r
+ SKIPA A,[1] ;NEED ONLY 1\r
+ MOVEI A,2 ;NEED 2\r
+ POPJ P,\r
+\r
+\f;FUNCTION TO BUILD A LIST OF MANY ELEMENTS\r
+\r
+MFUNCTION LIST,SUBR\r
+ ENTRY\r
+\r
+ PUSH P,$TLIST\r
+LIST12: HLRE A,AB ;GET -NUM OF ARGS\r
+ SKIPE RCL ;SEE IF WE WANT TO DO ONE AT A TIME\r
+ JRST LST12R ;TO GET RECYCLED CELLS\r
+ MOVNS A ;MAKE IT +\r
+ JUMPE A,LISTN ;JUMP IF 0\r
+ PUSHJ P,CELL ;GET NUMBER OF CELLS\r
+ PUSH TP,$TAB\r
+ PUSH TP,AB\r
+ PUSH TP,(P) ;SAVE IT\r
+ PUSH TP,B\r
+ SUB P,[1,,1]\r
+ LSH A,-1 ;NUMBER OF REAL LIST ELEMENTS\r
+\r
+CHAINL: ADDI B,2 ;LOOP TO CHAIN ELEMENTS\r
+ HRRZM B,-2(B) ;CHAIN LAST ONE TO NEXT ONE\r
+ SOJG A,.-2 ;LOOP TIL ALL DONE\r
+ CLEARM B,-2(B) ;SET THE LAST CDR TO NIL\r
+\r
+; NOW LOBEER THE DATA IN TO THE LIST\r
+\r
+ MOVE D,AB ; COPY OF ARG POINTER\r
+ MOVE B,(TP) ;RESTORE LIS POINTER\r
+LISTLP: GETYP A,(D) ;GET TYPE\r
+ PUSHJ P,NWORDT ;GET NUMBER OF WORDS\r
+ SOJN A,LDEFER ;NEED TO DEFER POINTER\r
+ GETYP A,(D) ;NOW CLOBBER ELEMENTS\r
+ HRLM A,(B)\r
+ MOVE A,1(D) ;AND VALUE..\r
+ MOVEM A,1(B)\r
+LISTL2: HRRZ B,(B) ;REST B\r
+ ADD D,[2,,2] ;STEP ARGS\r
+ JUMPL D,LISTLP\r
+\r
+ POP TP,B\r
+ POP TP,A\r
+ SUB TP,[2,,2] ; CLEANUP STACK\r
+ JRST FINIS\r
+\r
+\r
+LST12R: ASH A,-1 ;ONE AT A TIME TO GET RECYCLED CELLS\r
+ JUMPE A,LISTN\r
+ PUSH P,A ;SAVE COUNT ON STACK\r
+ SETZB C,D\r
+ SETZM E\r
+ PUSHJ P,ICONS\r
+ MOVE E,B ;LOOP AND CHAIN TOGETHER\r
+ AOSGE (P)\r
+ JRST .-3\r
+ PUSH TP,-1(P) ;PUSH ON THE TYPE WE WANT\r
+ PUSH TP,B\r
+ SUB P,[2,,2] ;CLEAN UP AFTER OURSELVES\r
+ JRST LISTLP-2 ;AND REJOIN MAIN STREAM\r
+\r
+\r
+; MAKE A DEFERRED POINTER\r
+\r
+LDEFER: PUSH TP,$TLIST ;SAVE CURRENT POINTER\r
+ PUSH TP,B\r
+ MOVEM D,1(TB) ; SAVE ARG HACKER\r
+ PUSHJ P,CELL2\r
+ MOVE D,1(TB)\r
+ GETYPF A,(D) ;GET FULL DATA\r
+ MOVE C,1(D)\r
+ MOVEM A,(B)\r
+ MOVEM C,1(B)\r
+ MOVE C,(TP) ;RESTORE LIST POINTER\r
+ MOVEM B,1(C) ;AND MAKE THIS BE THE VALUE\r
+ MOVSI A,TDEFER\r
+ HLLM A,(C) ;AND STORE IT\r
+ MOVE B,C\r
+ SUB TP,[2,,2]\r
+ JRST LISTL2\r
+\r
+LISTN: MOVEI B,0\r
+ POP P,A\r
+ JRST FINIS\r
+\r
+; BUILD A FORM\r
+\r
+MFUNCTION FORM,SUBR\r
+\r
+ ENTRY\r
+\r
+ PUSH P,$TFORM\r
+ JRST LIST12\r
+\r
+\f; COMPILERS CALLS TO FORM AND LIST A/ COUNT ELEMENTS ON STACK\r
+\r
+IILIST: SUBM M,(P)\r
+ PUSHJ P,IILST\r
+ MOVSI A,TLIST\r
+ JRST MPOPJ\r
+\r
+IIFORM: SUBM M,(P)\r
+ PUSHJ P,IILST\r
+ MOVSI A,TFORM\r
+ JRST MPOPJ\r
+\r
+IILST: JUMPE A,IILST0 ; NIL WHATSIT\r
+ PUSH P,A\r
+ MOVEI E,0\r
+IILST1: POP TP,D\r
+ POP TP,C\r
+ PUSHJ P,ICONS ; CONS 'EM UP\r
+ MOVEI E,(B)\r
+ SOSE (P) ; COUNT\r
+ JRST IILST1\r
+\r
+ SUB P,[1,,1]\r
+ POPJ P,\r
+\r
+IILST0: MOVEI B,0\r
+ POPJ P,\r
+\r
+\f;FUNCTION TO BUILD AN IMPLICIT LIST\r
+\r
+MFUNCTION ILIST,SUBR\r
+ ENTRY\r
+ PUSH P,$TLIST\r
+ILIST2: JUMPGE AB,TFA ;NEED AT LEAST ONE ARG\r
+ CAMGE AB,[-4,,0] ;NO MORE THAN TWO ARGS\r
+ JRST TMA\r
+ PUSHJ P,GETFIX ; GET POS FIX #\r
+ JUMPE A,LISTN ;EMPTY LIST ?\r
+ CAML AB,[-2,,0] ;ONLY ONE ARG?\r
+ JRST LOSEL ;YES\r
+ PUSH P,A ;SAVE THE CURRENT VALUE OF LENGTH FOR LOOP ITERATION\r
+ILIST0: PUSH TP,2(AB)\r
+ PUSH TP,(AB)3\r
+ MCALL 1,EVAL\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ SOSLE (P)\r
+ JRST ILIST0\r
+ POP P,C\r
+ILIST1: MOVE C,(AB)+1 ;REGOBBLE LENGTH\r
+ ACALL C,LIST\r
+ILIST3: POP P,A ; GET FINAL TYPE\r
+ JRST FINIS\r
+\r
+\r
+LOSEL: PUSH P,A ; SAVE COUNT\r
+ MOVEI E,0\r
+\r
+LOSEL1: SETZB C,D ; TLOSE,,0\r
+ PUSHJ P,ICONS\r
+ MOVEI E,(B)\r
+ SOSLE (P)\r
+ JRST LOSEL1\r
+\r
+ SUB P,[1,,1]\r
+ JRST ILIST3\r
+\r
+; IMPLICIT FORM\r
+\r
+MFUNCTION IFORM,SUBR\r
+\r
+ ENTRY\r
+ PUSH P,$TFORM\r
+ JRST ILIST2\r
+\r
+\f; IVECTOR AND IUVECTOR--GET VECTOR AND UVECTOR OF COMPUTED VALUES\r
+\r
+MFUNCTION VECTOR,SUBR,[IVECTOR]\r
+\r
+ MOVEI C,1\r
+ JRST VECTO3\r
+\r
+MFUNCTION UVECTOR,SUBR,[IUVECTOR]\r
+\r
+ MOVEI C,0\r
+VECTO3: ENTRY\r
+ JUMPGE AB,TFA ; AT LEAST ONE ARG\r
+ CAMGE AB,[-4,,0] ; NOT MORE THAN 2\r
+ JRST TMA\r
+ PUSHJ P,GETFIX ; GET A POS FIXED NUMBER\r
+ LSH A,(C) ; A-> NUMBER OF WORDS\r
+ PUSH P,C ; SAVE FOR LATER\r
+ PUSHJ P,IBLOCK ; GET BLOCK (TURN ON BIT APPROPRIATELY)\r
+ POP P,C\r
+ HLRE A,B ; START TO\r
+ SUBM B,A ; FIND DOPE WORD\r
+ JUMPE C,VECTO4\r
+ MOVSI D,400000 ; GET NOT UNIFORM BIT\r
+ MOVEM D,(A) ; INTO DOPE WORD\r
+ SKIPA A,$TVEC ; GET TYPE\r
+VECTO4: MOVSI A,TUVEC\r
+ CAML AB,[-2,,0] ; SKIP IF ARGS NEED TO BE HACKED\r
+ JRST FINIS\r
+ JUMPGE B,FINIS ; DON'T EVAL FOR EMPTY CASE\r
+\r
+ PUSH TP,A ; SAVE THE VECTOR\r
+ PUSH TP,B\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+\r
+ JUMPE C,UINIT\r
+ JUMPGE B,FINIS ; EMPTY VECTOR, LEAVE\r
+INLP: PUSHJ P,IEVAL ; EVAL EXPR\r
+ MOVEM A,(C)\r
+ MOVEM B,1(C)\r
+ ADD C,[2,,2] ; BUMP VECTOR\r
+ MOVEM C,(TP)\r
+ JUMPL C,INLP ; IF MORE DO IT\r
+\r
+GETVEC: MOVE A,-3(TP)\r
+ MOVE B,-2(TP)\r
+ SUB TP,[4,,4]\r
+ JRST FINIS\r
+\r
+; HERE TO FILL UP A UVECTOR\r
+\r
+UINIT: PUSHJ P,IEVAL ; HACK THE 1ST VALUE\r
+ GETYP A,A ; GET TYPE\r
+ PUSH P,A ; SAVE TYPE\r
+ PUSHJ P,NWORDT ; SEE IF IT CAN BE UNIFORMED\r
+ SOJN A,CANTUN ; COMPLAIN\r
+STJOIN: MOVE C,(TP) ; RESTORE POINTER\r
+ ADD C,1(AB) ; POINT TO DOPE WORD\r
+ MOVE A,(P) ; GET TYPE\r
+ HRLZM A,(C) ; STORE IN D.W.\r
+ MOVE C,(TP) ; GET BACK VECTOR\r
+ SKIPE 1(AB)\r
+ JRST UINLP1 ; START FILLING UV\r
+ JRST GETVE1\r
+\r
+UINLP: MOVEM C,(TP) ; SAVE PNTR\r
+ PUSHJ P,IEVAL ; EVAL THE EXPR\r
+ GETYP A,A ; GET EVALED TYPE\r
+ CAIE A,@(P) ; WINNER?\r
+ JRST WRNGSU ; SERVICE ERROR FOR UVECTOR,STORAGE\r
+UINLP1: MOVEM B,(C) ; STORE\r
+ AOBJN C,UINLP\r
+GETVE1: SUB P,[1,,1]\r
+ JRST GETVEC ; AND RETURN VECTOR\r
+\r
+IEVAL: PUSH TP,2(AB)\r
+ PUSH TP,3(AB)\r
+ MCALL 1,EVAL\r
+ MOVE C,(TP)\r
+ POPJ P,\r
+\r
+; ISTORAGE -- GET STORAGE OF COMPUTED VALUES\r
+\r
+MFUNCTION ISTORAGE,SUBR\r
+ ENTRY\r
+ JUMPGE AB,TFA\r
+ CAMGE AB,[-4,,0] ; AT LEAST ONE ARG\r
+ JRST TMA\r
+ PUSHJ P,GETFIX ; POSITIVE COUNT FIRST ARG\r
+ PUSHJ P,CAFRE ; GET CORE\r
+ MOVN B,1(AB) ; -COUNT\r
+ HRL A,B ; PUT IN LHW (A)\r
+ MOVM B,B ; +COUNT\r
+ HRLI B,2(B) ; LENGTH + 2\r
+ ADDI B,(A) ; MAKE POINTER TO DOPE WORDS\r
+ HLLZM B,1(B) ; PUT TOTAL LENGTH IN 2ND DOPE\r
+ HRRM A,1(B) ; PUT ADDRESS IN RHW (STORE DOES THIS TOO).\r
+ MOVE B,A\r
+ MOVSI A,TSTORAGE\r
+ CAML AB,[-2,,0] ; SECOND ARG TO EVAL?\r
+ JRST FINIS ; IF NOT, RETURN EMPTY\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ PUSHJ P,IEVAL ; EVALUATE FOR FIRST VALUE\r
+ GETYP A,A\r
+ PUSH P,A ; FOR COMPARISON LATER\r
+ PUSHJ P,SAT\r
+ CAIN A,S1WORD\r
+ JRST STJOIN ;TREAT LIKE A UVECTOR\r
+ ; IF NOT 1-WORD TYPES, CANNOT STORE, SO COMPLAIN\r
+ PUSHJ P,FREESV ; FREE STORAGE VECTOR\r
+ PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE DATA-CAN'T-GO-IN-STORAGE\r
+ JRST CALER1\r
+\r
+; FOR STORAGE, MUST FREE THE CORE ELSE IT IS LOST (NO GC)\r
+FREESV: MOVE A,1(AB) ; GET COUNT\r
+ ADDI A,2 ; FOR DOPE\r
+ HRRZ B,(TP) ; GET ADDRESS\r
+ PUSHJ P,CAFRET ; FREE THE CORE\r
+ POPJ P,\r
+\r
+\f; INTERNAL VECTOR ALLOCATOR. A/SIZE OF VECTOR (NOT INCLUDING DOPE WORDS)\r
+\r
+IBLOK1: ASH A,1 ; TIMES 2\r
+GIBLOK: TLOA A,400000 ; FUNNY BIT\r
+IBLOCK: TLZ A,400000 ; NO BIT ON\r
+ ADDI A,2 ; COMPENSATE FOR DOPE WORDS\r
+IBLOK2: MOVE B,VECBOT ; POINT TO BOTTOM OF SPACE\r
+ SUBI B,(A) ; SUBTRACT NEEDED AMOUNT\r
+ CAMGE B,PARTOP ; SKIP IF NO GC NEEDED\r
+ JRST IVECT1\r
+ EXCH B,VECBOT ; WIN, GET POINTER TO BLOCK AND UPDATE VECBOT\r
+ PUSH P,B\r
+ MOVE B,USEFRE\r
+ ADDI B,(A)\r
+ MOVEM B,USEFRE\r
+ POP P,B\r
+ HRLZM A,-1(B) ; STORE LENGTH IN DOPE WORD\r
+ HLLZM A,-2(B) ; AND BIT\r
+ HRRO B,VECBOT ; POINT TO START OF VECTOR\r
+ TLC B,-3(A) ; SETUP COUNT\r
+ HRRI A,TVEC\r
+ SKIPL A\r
+ HRRI A,TUVEC\r
+ MOVSI A,(A)\r
+ POPJ P,\r
+\r
+; HERE TO DO A GC ON A VECTOR ALLOCATION\r
+\r
+IVECT1: PUSH P,A ; SAVE DESIRED LENGTH\r
+ HRRZM A,GETNUM ; AND STORE AS DESIRED AMOUNT\r
+ MOVE C,[4,,1] ; GET INDICATOR FOR AGC\r
+ PUSHJ P,AGC\r
+ SKIPGE A\r
+ PUSHJ P,FULLOS ; LOST, COMPLAIN\r
+ POP P,A\r
+ JRST IBLOK2\r
+\r
+\r
+; INTERNAL EVECTOR (CALLED FROM READ) A/ #OF THINGS\r
+; ITEMS ON TOP OF STACK\r
+\r
+IEVECT: ASH A,1 ; TO NUMBER OF WORDS\r
+ PUSH P,A\r
+ PUSHJ P,IBLOCK ; GET VECTOR\r
+ HLRE D,B ; FIND DW\r
+ SUBM B,D ; A POINTS TO DW\r
+ MOVSI 0,400000\r
+ MOVEM 0,(D) ; CLOBBER NON UNIF BIT\r
+ POP P,A ; RESTORE COUNT\r
+ JUMPE A,IVEC1 ; 0 LNTH, DONE\r
+ MOVEI C,(TP) ; BUILD BLT\r
+ SUBI C,(A)-1 ; C POINTS TO 1ST ITEM ON STACK\r
+ MOVSI C,(C)\r
+ HRRI C,(B) ; B/ SOURCE,,DEST\r
+ BLT C,-1(D) ; XFER THE DATA\r
+ HRLI A,(A)\r
+ SUB TP,A ; FLUSH STACKAGE\r
+IVEC1: MOVSI A,TVEC\r
+ POPJ P,\r
+ \r
+\r
+; COMPILERS CALL\r
+\r
+CIVEC: SUBM M,(P)\r
+ PUSHJ P,IEVECT\r
+ JRST MPOPJ\r
+\r
+\r
+\f; INTERNAL CALL TO EUVECTOR\r
+\r
+IEUVEC: PUSH P,A ; SAVE LENGTH\r
+ PUSHJ P,IBLOCK\r
+ MOVE A,(P)\r
+ JUMPE A,IEUVE1 ; EMPTY, LEAVE\r
+ ASH A,1 ; NOW FIND STACK POSITION\r
+ MOVEI C,(TP) ; POINT TO TOP\r
+ MOVE D,B ; COPY VEC POINTER\r
+ SUBI C,-1(A) ; POINT TO 1ST DATUM\r
+ GETYP A,(C) ; CHECK IT\r
+ PUSHJ P,NWORDT\r
+ SOJN A,CANTUN ; WONT FIT\r
+ GETYP E,(C)\r
+\r
+IEUVE2: GETYP 0,(C) ; TYPE OF EL\r
+ CAIE 0,(E) ; MATCH?\r
+ JRST WRNGUT\r
+ MOVE 0,1(C)\r
+ MOVEM 0,(D) ; CLOBBER\r
+ ADDI C,2\r
+ AOBJN D,IEUVE2 ; LOOP\r
+ HRLZM E,(D) ; STORE UTYPE\r
+IEUVE1: POP P,A ; GET COUNY\r
+ ASH A,1 ; MUST FLUSH 2 TIMES # OF ELEMENTS\r
+ HRLI A,(A)\r
+ SUB TP,A ; CLEAN UP STACK\r
+ MOVSI A,TUVEC\r
+ POPJ P,\r
+\r
+; COMPILER'S CALL\r
+\r
+CIUVEC: SUBM M,(P)\r
+ PUSHJ P,IEUVEC\r
+ JRST MPOPJ\r
+\r
+MFUNCTION EVECTOR,SUBR,[VECTOR]\r
+ ENTRY\r
+ HLRE A,AB\r
+ MOVNS A\r
+ PUSH P,A ;SAVE NUMBER OF WORDS\r
+ PUSHJ P,IBLOCK ; GET WORDS\r
+ MOVEI D,-1(B) ; SETUP FOR BLT AND DOPE CLOBBER\r
+ JUMPGE B,FINISV ;DONT COPY A ZERO LENGTH VECTOR\r
+\r
+ HRLI C,(AB) ;START BUILDING BLT POINTER\r
+ HRRI C,(B) ;TO ADDRESS\r
+ ADDI D,@(P) ;SET D TO FINAL ADDRESS\r
+ BLT C,(D)\r
+FINISV: MOVSI 0,400000\r
+ MOVEM 0,1(D) ; MARK AS GENERAL\r
+ SUB P,[1,,1]\r
+ MOVSI A,TVEC\r
+ JRST FINIS\r
+\r
+\r
+\r
+\f;EXPLICIT VECTORS FOR THE UNIFORM CSE\r
+\r
+MFUNCTION EUVECTOR,SUBR,[UVECTOR]\r
+\r
+ ENTRY\r
+ HLRE A,AB ;-NUM OF ARGS\r
+ MOVNS A\r
+ ASH A,-1 ;NEED HALF AS MANY WORDS\r
+ PUSH P,A\r
+ JUMPGE AB,EUV1 ; DONT CHECK FOR EMPTY\r
+ GETYP A,(AB) ;GET FIRST ARG\r
+ PUSHJ P,NWORDT ;SEE IF NEEDS EXTRA WORDS\r
+ SOJN A,CANTUN\r
+EUV1: POP P,A\r
+ PUSHJ P,IBLOCK ; GET VECT\r
+ JUMPGE B,FINISU\r
+\r
+ GETYP C,(AB) ;GET THE FIRST TYPE\r
+ MOVE D,AB ;COPY THE ARG POINTER\r
+ MOVE E,B ;COPY OF RESULT\r
+\r
+EUVLP: GETYP 0,(D) ;GET A TYPE\r
+ CAIE 0,(C) ;SAME?\r
+ JRST WRNGUT ;NO , LOSE\r
+ MOVE 0,1(D) ;GET GOODIE\r
+ MOVEM 0,(E) ;CLOBBER\r
+ ADD D,[2,,2] ;BUMP ARGS POINTER\r
+ AOBJN E,EUVLP\r
+\r
+ HRLM C,(E) ;CLOBBER UNIFORM TYPE IN\r
+FINISU: MOVSI A,TUVEC\r
+ JRST FINIS\r
+\r
+WRNGSU: GETYP A,-1(TP)\r
+ CAIE A,TSTORAGE\r
+ JRST WRNGUT ;IF UVECTOR\r
+ PUSHJ P,FREESV ;FREE STORAGE VECTOR\r
+ PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE TYPES-DIFFER-IN-STORAGE-OBJECT\r
+ JRST CALER1\r
+\r
+ \r
+WRNGUT: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE TYPES-DIFFER-IN-UNIFORM-VECTOR\r
+ JRST CALER1\r
+\r
+CANTUN: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE DATA-CANT-GO-IN-UNIFORM-VECTOR\r
+ JRST CALER1\r
+\r
+BADNUM: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE NEGATIVE-ARGUMENT\r
+ JRST CALER1\r
+\f; FUNCTION TO GROW A VECTOR\r
+\r
+MFUNCTION GROW,SUBR\r
+\r
+ ENTRY 3\r
+\r
+ MOVEI D,0 ;STACK HACKING FLAG\r
+ GETYP A,(AB) ;FIRST TYPE\r
+ PUSHJ P,SAT ;GET STORAGE TYPE\r
+ GETYP B,2(AB) ;2ND ARG\r
+ CAIE A,STPSTK ;IS IT ASTACK\r
+ CAIN A,SPSTK\r
+ AOJA D,GRSTCK ;YES, WIN\r
+ CAIE A,SNWORD ;UNIFORM VECTOR\r
+ CAIN A,S2NWORD ;OR GENERAL\r
+GRSTCK: CAIE B,TFIX ;IS 2ND FIXED\r
+ JRST WTYP2 ;COMPLAIN\r
+ GETYP B,4(AB)\r
+ CAIE B,TFIX ;3RD ARG\r
+ JRST WTYP3 ;LOSE\r
+\r
+ MOVEI E,1 ;UNIFORM/GENERAL FLAG\r
+ CAIE A,SNWORD ;SKIP IF UNIFORM\r
+ CAIN A,SPSTK ;DONT SKIP IF UNIFORM PDL\r
+ MOVEI E,0\r
+\r
+ HRRZ B,1(AB) ;POINT TO START\r
+ HLRE A,1(AB) ;GET -LENGTH\r
+ SUB B,A ;POINT TO DOPE WORD\r
+ SKIPE D ;SKIP IF NOT STACK\r
+ ADDI B,PDLBUF ;FUDGE FOR PDL\r
+ HLLZS (B) ;ZERO OUT GROWTH SPECS\r
+ SKIPN A,3(AB) ;ANY TOP GROWTH?\r
+ JRST GROW1 ;NO, LOOK FOR BOTTOM GROWTH\r
+ ASH A,(E) ;MULT BY 2 IF GENERAL\r
+ ADDI A,77 ;ROUND TO NEAREST BLOCK\r
+ ANDCMI A,77 ;CLEAR LOW ORDER BITS\r
+ ASH A,9-6 ;DIVIDE BY 100 AND SHIFT TO POSTION\r
+ TRZE A,400000 ;CONVERT TO SIGN MAGNITUDE\r
+ MOVNS A\r
+ TLNE A,-1 ;SKIP IF NOT TOO BIG\r
+ JRST GTOBIG ;ERROR\r
+GROW1: SKIPN C,5(AB) ;CHECK LOW GROWTH\r
+ JRST GROW4 ;NONE, SKIP\r
+ ASH C,(E) ;GENRAL FUDGE\r
+ ADDI C,77 ;ROUND\r
+ ANDCMI C,77 ;FUDGE FOR VALUE RETURN\r
+ PUSH P,C ;AND SAVE\r
+ ASH C,-6 ;DIVIDE BY 100\r
+ TRZE C,400 ;CONVERT TO SIGN MAGNITUDE\r
+ MOVNS C\r
+ TDNE C,[-1,,777000] ;CHECK FOR OVERFLOW\r
+ JRST GTOBIG\r
+GROW2: HLRZ E,1(B) ;GET TOTAL LENGTH OF VECTOR\r
+ MOVNI E,-1(E)\r
+ HRLI E,(E) ;TO BOTH HALVES\r
+ ADDI E,1(B) ;POINTS TO TOP\r
+ SKIPE D ;STACK?\r
+ ADD E,[PDLBUF,,0] ;YES, FUDGE LENGTH\r
+ SKIPL D,(P) ;SHRINKAGE?\r
+ JRST GROW3 ;NO, CONTINUE\r
+ MOVNS D ;PLUSIFY\r
+ HRLI D,(D) ;TO BOTH HALVES\r
+ ADD E,D ;POINT TO NEW LOW ADDR\r
+GROW3: IORI A,(C) ;OR TOGETHER\r
+ HRRM A,(B) ;DEPOSIT INTO DOPEWORD\r
+ PUSH TP,(AB) ;PUSH TYPE\r
+ PUSH TP,E ;AND VALUE\r
+ JUMPE A,.+3 ;DON'T GC FOR NOTHING\r
+ MOVE C,[2,,0] ; GET INDICATOR FOR AGC\r
+ PUSHJ P,AGC\r
+ JUMPL A,GROFUL\r
+ POP P,C ;RESTORE GROWTH\r
+ HRLI C,(C)\r
+ POP TP,B ;GET VECTOR POINTER\r
+ SUB B,C ;POINT TO NEW TOP\r
+ POP TP,A\r
+ JRST FINIS\r
+\r
+GROFUL: SUB P,[1,,1] ; CLEAN UP STACK\r
+ SUB TP,[2,,2]\r
+ PUSHJ P,FULLOS\r
+ JRST GROW\r
+\r
+GTOBIG: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE ATTEMPT-TO-GROW-VECTOR-TOO-MUCH\r
+ JRST CALER1\r
+GROW4: PUSH P,[0] ;0 BOTTOM GROWTH\r
+ JRST GROW2\r
+\r
+FULLOS: PUSH TP,$TATOM ; GENERATE ERROR\r
+ PUSH TP,@ERRTB(A)\r
+ AOJL A,CALER1 ; IF BAD, CALL ERROR\r
+ SKIPN GCMONF\r
+ POPJ P,\r
+ PUSH TP,TTOCHN(TVP) ; FORCE MESSAGES TO TTY\r
+ PUSH TP,TTOCHN+1(TVP)\r
+ PUSH TP,TTOCHN(TVP) ; FORCE MESSAGES TO TTY\r
+ PUSH TP,TTOCHN+1(TVP)\r
+ MCALL 1,TERPRI ; JUST PRINT MESSAGE\r
+ MCALL 2,PRINC\r
+ POPJ P,\r
+\r
+\r
+ EQUOTE STILL-NO-STORAGE\r
+ EQUOTE NO-STORAGE\r
+ EQUOTE STORAGE-LOW\r
+ERRTB==.\r
+\f; SUBROUTINE TO BUILD CHARACTER STRING GOODIES\r
+\r
+MFUNCTION STRING,SUBR\r
+\r
+ ENTRY\r
+\r
+ MOVE B,AB ;COPY ARG POINTER\r
+ MOVEI C,0 ;INITIALIZE COUNTER\r
+ PUSH TP,$TAB ;SAVE A COPY\r
+ PUSH TP,B\r
+ HLRE A,B ; GET # OF ARGS\r
+ MOVNS A\r
+ ASH A,-1 ; 1/2 FOR # OF ARGS\r
+ PUSHJ P,IISTRN\r
+ JRST FINIS\r
+\r
+IISTRN: SKIPN E,A ; SKIP IF ARGS EXIST\r
+ JRST MAKSTR ; ALL DONE\r
+\r
+STRIN2: GETYP D,(B) ;GET TYPE CODE\r
+ CAIN D,TCHRS ;SINGLE CHARACTER?\r
+ AOJA C,STRIN1\r
+ CAIE D,TCHSTR ;OR STRING\r
+ JRST WRONGT ;NEITHER\r
+ HRRZ D,(B) ; GET CHAR COUNT\r
+ ADDI C,(D) ; AND BUMP\r
+\r
+STRIN1: ADD B,[2,,2]\r
+ SOJG A,STRIN2\r
+\r
+; NOW GET THE NECESSARY VECTOR\r
+\r
+MAKSTR: PUSH P,C ; SAVE CHAR COUNT\r
+ PUSH P,E ; SAVE ARG COUNT\r
+ MOVEI A,4(C) ; LNTH+4 TO A\r
+ IDIVI A,5\r
+ PUSHJ P,IBLOCK\r
+\r
+ POP P,A\r
+ JUMPGE B,DONEC ; 0 LENGTH, NO STRING\r
+ HRLI B,440700 ;CONVERT B TO A BYTE POINTER\r
+ MOVE C,(TP) ; POINT TO ARGS AGAIN\r
+\r
+NXTRG1: GETYP D,(C) ;GET AN ARG\r
+ CAIE D,TCHRS\r
+ JRST TRYSTR\r
+ MOVE D,1(C) ; GET IT\r
+ IDPB D,B ;AND DEPOSIT IT\r
+ JRST NXTARG\r
+\r
+TRYSTR: MOVE E,1(C) ;GET BYTER\r
+ HRRZ 0,(C) ;AND COUNT\r
+NXTCHR: SOJL 0,NXTARG ; IF RUNOUT, GET NEXT ARG\r
+ ILDB D,E ;AND GET NEXT\r
+ IDPB D,B ; AND DEPOSIT SAME\r
+ JRST NXTCHR\r
+\r
+NXTARG: ADD C,[2,,2] ;BUMP ARG POINTER\r
+ SOJG A,NXTRG1\r
+ ADDI B,1\r
+\r
+DONEC: MOVSI C,TCHRS\r
+ HLLM C,(B) ;AND CLOBBER AWAY\r
+ HLRZ C,1(B) ;GET LENGTH BACK\r
+ POP P,A\r
+ HRLI A,TCHSTR\r
+ SUBI B,-2(C)\r
+ HRLI B,440700 ;MAKE A BYTE POINTER\r
+ POPJ P,\r
+\r
+; COMPILER'S CALL TO MAKE A STRING\r
+\r
+CISTNG: SUBM M,(P)\r
+ MOVEI C,0 ; INIT CHAR COUNTER\r
+ MOVEI B,(A) ; SET UP STACK POINTER\r
+ ASH B,1 ; * 2 FOR NO. OF SLOTS\r
+ HRLI B,(B)\r
+ SUBM TP,B ; B POINTS TO ARGS\r
+ ADD B,[1,,1]\r
+ PUSH TP,$TTP\r
+ PUSH TP,B\r
+ PUSHJ P,IISTRN ; MAKE IT HAPPEN\r
+ POP TP,TP ; FLUSH ARGS\r
+ SUB TP,[1,,1]\r
+ JRST MPOPJ\r
+\f;BUILD IMPLICT STRING\r
+\r
+MFUNCTION ISTRING,SUBR\r
+\r
+ ENTRY\r
+ JUMPGE AB,TFA ; TOO FEW ARGS\r
+ CAMGE AB,[-4,,0] ; VERIFY NOT TOO MANY ARGS\r
+ JRST TMA\r
+ PUSHJ P,GETFIX\r
+ ADDI A,4\r
+ IDIVI A,5 ; # OF WORDS NEEDED TO A\r
+ PUSH TP,$TFIX\r
+ PUSH TP,A\r
+ MCALL 1,UVECTOR ; GET SAME\r
+ HLRE C,B ; -LENGTH TO C\r
+ SUBM B,C ; LOCN OF DOPE WORD TO C\r
+ HRLI D,TCHRS ; CLOBBER ITS TYPE\r
+ HLLM D,(C)\r
+ MOVSI A,TCHSTR\r
+ HRR A,1(AB) ; SETUP TYPE'S RH\r
+ HRLI B,440700 ; AND BYTE POINTER\r
+ SKIPE (AB)+1 ; SKIP IF NO CHARACTERS TO DEPOSIT\r
+ CAML AB,[-2,,0] ; SKIP IF 2 ARGS GIVEN\r
+ JRST FINIS\r
+ PUSH TP,A ;SAVE OUR STRING\r
+ PUSH TP,B\r
+ PUSH TP,A ;SAVE A TEMPORARY CLOBBER POINTER\r
+ PUSH TP,B\r
+ PUSH P,(AB)1 ;SAVE COUNT\r
+CLOBST: PUSH TP,(AB)+2\r
+ PUSH TP,(AB)+3\r
+ MCALL 1,EVAL\r
+ GETYP C,A ; CHECK IT\r
+ CAIE C,TCHRS ; MUST BE A CHARACTER\r
+ JRST WTYP2\r
+ IDPB B,(TP) ;CLOBBER\r
+ SOSLE (P) ;FINISHED?\r
+ JRST CLOBST ;NO\r
+ SUB P,[1,,1]\r
+ SUB TP,[4,,4]\r
+ MOVE A,(TP)+1\r
+ MOVE B,(TP)+2\r
+ JRST FINIS\r
+\r
+\r
+\fAGC":\r
+;SET FLAG FOR INTERRUPT HANDLER\r
+\r
+ SETZB M,RCL ; CLEAR OUT RECYCLE LIST CELLS, AND RSUBR BASE PNTR\r
+ PUSH P,B\r
+ PUSH P,A\r
+ PUSH P,C ; SAVE C\r
+ PUSHJ P,CTIME ; GET TIME FOR GIN-GOUT\r
+ MOVEM B,GCTIM ; SAVE FOR LATER\r
+ MOVEI B,[ASCIZ /GIN /]\r
+ SKIPE GCMONF\r
+ PUSHJ P,MSGTYP\r
+NOMON1: HRRZ C,(P) ; GET CAUSE OF GC INDICATOR\r
+ MOVE B,GCNO(C) ; ADD 1 TO COUNT OF GC'S CAUSED BY GIVEN REASON\r
+ ADDI B,1\r
+ MOVEM B,GCNO(C)\r
+ MOVEM C,GCCAUS ; SAVE CAUSE OF GC\r
+ SKIPN GCMONF ; MONITORING\r
+ JRST NOMON2\r
+ MOVE B,MSGGCT(C) ; GET CAUSE MESSAGE\r
+ PUSHJ P,MSGTYP\r
+NOMON2: HLRZ C,(P) ; FIND OUT WHO CAUSED THE GC\r
+ MOVEM C,GCCALL ; SAVE CALLER OF GC\r
+ SKIPN GCMONF ; MONITORING\r
+ JRST NOMON3\r
+ MOVE B,MSGGFT(C)\r
+ PUSHJ P,MSGTYP\r
+NOMON3: SUB P,[1,,1] ; POP OFF C\r
+ POP P,A\r
+ POP P,B\r
+ JRST .+1\r
+AAGC: SETZB M,RCL ; ALTERNATE GC-ENTRY POINT FOR INITIALIZATION\r
+INITGC: SETOM GCFLG\r
+\r
+;SAVE AC'S\r
+ IRP AC,,[0,A,B,C,D,E,P,R,M,SP,TP,TB,AB,TVP,PVP]\r
+ MOVEM AC,AC!STO"+1(PVP)\r
+ TERMIN\r
+\r
+; FUDGE NOWFRE FOR LATER WINNING\r
+\r
+ MOVE 0,NOWFRE\r
+ SUB 0,VECBOT\r
+ ADD 0,PARTOP\r
+ MOVEM 0,NOWFRE\r
+\r
+; IF IN A PURE RSUBR, FIND ITS LENGTH AND FUDGE ITS LRU\r
+\r
+ HRRZ A,FSAV(TB) ; GET NAME OF CURRENT GOODIE\r
+ SETZM CURPLN ; CLEAR FOR NONE\r
+ CAML A,PURTOP ; IF LESS THAN TOP OF PURE ASSUME RSUBR\r
+ JRST NRSUBR\r
+ GETYP 0,(A) ; SEE IF PURE\r
+ CAIE 0,TPCODE ; SKIP IF IT IS\r
+ JRST NRSUBR\r
+ HLRZ B,1(A) ; GET SLOT INDICATION\r
+ ADD B,PURVEC+1(TVP) ; POINT TO SLOT\r
+ HRROS 2(B) ; MUNG AGE\r
+ HLRE A,1(B) ; - LENGTH TO A\r
+ MOVNM A,CURPLN ; AND STORE\r
+NRSUBR:\r
+\r
+;SET UP E TO POINT TO TYPE VECTOR\r
+ GETYP E,TYPVEC(TVP)\r
+ CAIE E,TVEC\r
+ JRST AGCE1\r
+ HRRZ TYPNT,TYPVEC+1(TVP)\r
+ HRLI TYPNT,B\r
+\r
+CHPDL: MOVE D,P ; SAVE FOR LATER\r
+ MOVE P,GCPDL ;GET GC'S PDL\r
+CORGET: MOVE A,P.TOP ; UPDATE CORTOP\r
+ MOVEM A,CORTOP\r
+ MOVE A,VECTOP ; ROOM BETWEEN CORTOP AND VECTOP IS GC MARK PDL\r
+ SUB A,CORTOP\r
+ MOVSS A ; BUILD A PDL POINTER\r
+ ADD A,VECTOP\r
+ JUMPGE A,TRYCOR ; NO ROOM, GO GET SOME\r
+ MOVE P,A ; SET UP PDL POINTER\r
+\r
+;FENCE POST PDLS AND CHECK IF ANY SHOULD BE SHRUNK\r
+\r
+ MOVEI A,(TB) ;POINT TO CURRENT FRAME IN PROCESS\r
+ PUSHJ P,FRMUNG ;AND MUNG IT\r
+ MOVE A,TP ;THEN TEMPORARY PDL\r
+ PUSHJ P,PDLCHK\r
+ MOVE A,PSTO+1(PVP) ;AND UNMARKED P STACK\r
+ PUSHJ P,PDLCHP\r
+\r
+\f; FIRST CREATE INFERIOR TO HOLD NEW PAGES\r
+\r
+INFCRT: MOVE A,PARBOT ; GENERATE NEW PARBOT AND PARNEW\r
+ ADD A,PARNEW\r
+ ADDI A,1777\r
+ ANDCMI A,1777 ; EVEN PAGE BOUNDARY\r
+ HRRM A,BOTNEW ; INTO POINTER WORD\r
+ MOVEM A,WNDBOT\r
+ MOVEI 0,2000(A) ; BOUNDS OF WINDOW\r
+ MOVEM 0,WNDTOP\r
+ SUB A,PARBOT\r
+ MOVEM A,PARNEW ; FIXED UP PARNEW\r
+ HRRZ A,BOTNEW ; GET PAGE TO START INF AT\r
+ ASH A,-10. ; TO PAGES\r
+ PUSHJ P,%GCJOB ; GET PAGE HOLDER\r
+ MOVSI FPTR,-2000 ; FIX UP FRONTIER POINTER\r
+\r
+;MARK PHASE: MARK ALL LISTS AND VECTORS\r
+;POINTED TO WITH ONE BIT IN SIGN BIT\r
+;START AT TRANSFER VECTOR\r
+\r
+ SETZB LPVP,VECNUM ;CLEAR NUMBER OF VECTOR WORDS\r
+ SETZB PARNUM ;CLEAR NUMBER OF PAIRS\r
+ MOVEI 0,NGCS ; SEE IF NEED HAIR\r
+ SOSGE GCHAIR\r
+ MOVEM 0,GCHAIR ; RESUME COUNTING\r
+ SETZM GREW ; ASSUME NO GROW/SHRINK\r
+ SETZM SHRUNK\r
+ MOVSI D,400000 ;SIGN BIT FOR MARKING\r
+ MOVE A,ASOVEC+1(TVP) ;MARK ASSOC. VECTOR NOW\r
+ PUSHJ P,PRMRK ; PRE-MARK\r
+ MOVE A,GLOBSP+1(TVP)\r
+ PUSHJ P,PRMRK\r
+\r
+; HAIR TO DO AUTO CHANNEL CLOSE\r
+\r
+ MOVEI 0,N.CHNS-1 ; NUMBER OF CHANNELS\r
+ MOVEI A,CHNL1(TVP) ; 1ST SLOT\r
+\r
+ SKIPE 1(A) ; NOW A CHANNEL?\r
+ SETZM (A) ; DON'T MARK AS CHANNELS\r
+ ADDI A,2\r
+ SOJG 0,.-3\r
+\r
+ MOVE A,PVP ;START AT PROCESS VECTOR\r
+ MOVEI B,TPVP ;IT IS A PROCESS VECTOR\r
+ PUSHJ P,MARK ;AND MARK THIS VECTOR\r
+ MOVEI B,TPVP\r
+ MOVE A,MAINPR ; MARK MAIN PROCES EVEN IF SWAPPED OUT\r
+ PUSHJ P,MARK\r
+\r
+; ASSOCIATION AND VALUE FLUSHING PHASE\r
+\r
+ SKIPN GCHAIR ; ONLY IF HAIR\r
+ PUSHJ P,VALFLS\r
+\r
+ SKIPE GCHAIR ; IF NOT HAIR, DO CHANNELS NOW\r
+ PUSHJ P,CHNFLS\r
+\r
+;OPTIONAL RETIMING PHASE\r
+;THIS HAS BEEN FLUSHED BECAUSE OF PLANNER\r
+ REPEAT 0,[\r
+ SKIPE A,TIMOUT ;ANY TIME OVERFLOWS\r
+ PUSHJ P,RETIME ;YES, RE-CALIBRATE THEM\r
+]\r
+;UPDATE PARTOP\r
+\r
+ MOVEI A,@BOTNEW\r
+ SUB A,PARNEW\r
+ MOVEM A,PARTOP\r
+\r
+;CORE ADJUSTMENT PHASE\r
+ MOVE P,GCPDL ; GET A PDL\r
+ SETZM CORSET ;CLEAR LATER CORE SETTING\r
+ PUSHJ P,CORADJ ;AND MAKE CORE ADJUSTMENTS\r
+\r
+;RELOCATION ESTABLISHMENT PHASE\r
+;1 -- IN VECTOR SPACE, ESTABLISH POINTERS TO TOP OF CORE\r
+ MOVE A,VECTOP" ;START AT TOP OF VECTOR SPACE\r
+ MOVE B,VECNEW" ;AND SET TO INITIAL OFFSET\r
+ SUBI A,1 ;POINT TO DOPE WORDS\r
+ ADDI B,(A) ; WHERE TOP VECTOR WILL GO\r
+ PUSHJ P,VECREL ;AND ESTABLISH RELOCATION FOR VECTORS\r
+ SUBI B,(A) ; RE-RELATIVIZE VECNEW\r
+ MOVEM B,VECNEW ;SAVE FINAL OFFSET\r
+\r
+\r
+\f; MAP NEW PAIR SPACE IN FOR PAIR SPACE UPDATE\r
+\r
+ MOVE B,PARTOP ; POINT TO TOP OF PAIRS\r
+ ADDI B,2000\r
+ ANDCMI B,1777\r
+ CAMGE B,VECBOT ; OVERLAP VECTORS\r
+ JRST DOMAP\r
+ MOVE C,VECBOT\r
+ ANDI C,1777 ; REL TO PAGE\r
+ ADDI C,FRONT ; 1ST DEST WORD\r
+ HRL C,VECBOT\r
+ BLT C,FRONT+1777 ; MUNG IT\r
+\r
+DOMAP: ASH B,-10. ; TO PAGES\r
+ MOVE A,PARBOT\r
+ MOVEI C,(A) ; COMPUTE HIS TOP\r
+ ADD C,PARNEW\r
+ ASH C,-10.\r
+ ASH A,-10.\r
+ SUBM A,B ; B==> - # OF PAGES\r
+ HRLI A,(B) ; AOBJN TO SOURCE AND DEST\r
+ MOVE B,A ; IN CASE OF FUNNY\r
+ HRRI B,(C) ; MAP HIS POSSIBLE HIGHER OR LOWER PAGES\r
+ PUSHJ P,%INFMP ; NOW FLUSH INF AND MAKE HIS CORE MINE\r
+\r
+\f;POINTER UPDATE PHASE\r
+;1 -- UPDATE ALL PAIR POINTERS\r
+ MOVE A,PARBOT ;START AT BOTTOM OF PAIR SPACE\r
+ PUSHJ P,PARUPD ;AND UPDATE ALL PAIR POINTERS\r
+\r
+;2 -- UPDATE ALL VECTORS\r
+ MOVE A,VECTOP ;START AT TOP OF VECTOR SPACE\r
+ PUSHJ P,VECUPD ;AND UPDATE THE POINTERS\r
+ MOVE A,CODTOP ; NOW UPDATE STORAGE STUFF\r
+ MOVEI D,0 ; FAKE OUT TO NOT UNMARK\r
+ PUSHJ P,STOUP\r
+ MOVSI D,400000\r
+\r
+;3 -- UPDATE THE PVP AC\r
+ MOVEI A,PVP-1 ;SET LOC TO POINT TO PVP\r
+ MOVE C,PVP ;GET THE DATUM\r
+ PUSHJ P,NWRDUP ;AND UPDATE THIS VALUE\r
+;4 -- UPDATE THE MAIN PROCESS POINTER\r
+ MOVEI A,MAINPR-1 ;POINT TO MAIN PROCESS POINTER\r
+ MOVE C,MAINPR ;GET CONTENTS IN C\r
+ PUSHJ P,NWRDUP ;AND UPDATE IT\r
+;DATA MOVEMMENT ANDCLEANUP PHASE\r
+\r
+;1 -- ADJUST FOR SHRINKING VECTORS\r
+ MOVE A,VECTOP ;VECTOR SHRINKING PHASE\r
+ SKIPE SHRUNK ; SKIP IF NO SHRINKERS\r
+ PUSHJ P,VECSH ;GO SHRINK ANY SHRINKERS\r
+\r
+;2 -- MOVE VECTORS (AND LIST ELEMENTS)\r
+ MOVE A,VECTOP ;START AT TOP OF VECTOR SPACE\r
+ PUSHJ P,VECMOVE ;AND MOVE THE VECTORS\r
+ MOVE A,VECNEW ;GET FINAL CHANGE TO VECBOT\r
+ ADDM A,VECBOT ;OFFSET VECBOT TO ITS NEW PLACE\r
+ MOVE A,CORTOP ;GET NEW VALUE FOR TOP OF VECTOR SPACE\r
+ SUBI A,2000 ; FUDGE FOR MARK PDL\r
+ MOVEM A,VECTOP ;AND UPDATE VECTOP\r
+\r
+;3 -- CLEANUP VECTORS (NOTE A CONTAINS NEW VECTOP)\r
+\r
+ SKIPE GREW ; SKIP IF NO GROWERS\r
+ PUSHJ P,VECZER ;\r
+ PUSHJ P,STOGC\r
+\r
+;GARBAGE ZEROING PHASE\r
+GARZER: MOVE A,PARTOP ;FIRST WORD OF GARBAGE IS AFTER PAIR SPACE\r
+ HRLS A ;GET FIRST ADDRESS IN LEFT HALF\r
+ MOVE B,VECBOT ;LAST ADDRESS OF GARBAGE + 1\r
+ CLEARM (A) ;ZERO THE FIRST WORD\r
+ ADDI A,1 ;MAKE A A BLT POINTER\r
+ BLT A,-1(B) ;AND COPY ZEROES INTO REST OF AREA\r
+\r
+;FINAL CORE ADJUSTMENT\r
+ SKIPE A,CORSET ;IFLESS CORE NEEDED\r
+ PUSHJ P,CORADL ;GIVE SOME AWAY.\r
+\r
+;NOW REHASH THE ASSOCIATIONS BASED ON NEW VALUES\r
+\r
+ PUSHJ P,REHASH\r
+\r
+\f;RESTORE AC'S\r
+TRYCOX: MOVE 0,VECBOT\r
+ SUB 0,PARTOP\r
+ ADDM 0,NOWFRE\r
+ SKIPN GCMONF\r
+ JRST NOMONO\r
+ MOVEI B,[ASCIZ /GOUT /]\r
+ PUSHJ P,MSGTYP\r
+NOMONO: IRP AC,,[0,A,B,C,D,E,P,R,M,SP,TP,TB,AB,PVP,TVP]\r
+ MOVE AC,AC!STO+1(PVP)\r
+ TERMIN\r
+; CLOSING ROUTINE FOR G-C\r
+ PUSH P,A ; SAVE AC'C\r
+ PUSH P,B\r
+ PUSH P,C\r
+ PUSH P,D\r
+ PUSHJ P,CTIME\r
+ PUSHJ P,FIXSEN ; OUTPUT TIME\r
+ SKIPN GCMONF\r
+ JRST GCCONT\r
+ MOVEI A,15 ; OUTPUT C/R LINE-FEED\r
+ PUSHJ P,MTYO\r
+ MOVEI A,12\r
+ PUSHJ P,MTYO\r
+GCCONT: POP P,D ; RESTORE AC'C\r
+ POP P,C\r
+ POP P,B\r
+ POP P,A\r
+ MOVE A,GCDANG ; ERROR LEVELS TO ACS\r
+ ADD A,GCDNTG\r
+ SETZM GCDANG ; NOW CLEAR SAME\r
+ SETZM GCDNTG\r
+ JUMPGE A,AGCWIN\r
+ SKIPN GCHAIR ; WAS IT A FLUSHER?\r
+ JRST AGCWIN ; YES, NO MORE AVAILABLE\r
+ MOVEI A,1\r
+ MOVEM A,GCHAIR ; RE-DO WITH HAIR\r
+ MOVE A,SPARNW ; RESET PARNEW\r
+ MOVEM A,PARNEW\r
+ SETZM SPARNW\r
+ MOVE C,[11,10.] ; INDICATOR FOR AGC\r
+ JRST AGC ; TRY ONCE MORE\r
+\r
+AGCWIN: SETZM PARNEW ;CLEAR FOR NEXT AGC CALL\r
+ SETZM GETNUM ;ALSO CLEAR THIS\r
+ SETZM GCFLG\r
+\r
+ JUMPGE P,RBLDM ; DONT LOSE ON BLOWN PDLS\r
+ JUMPGE TP,RBLDM\r
+ CAMGE A,[-1] ; SKIP IF GOOD NEWS\r
+ JRST RBLDM\r
+ SETZM PGROW ; CLEAR GROWTH\r
+ SETZM TPGROW\r
+ SETOM GCHAPN ; INDICATE A GC HAS HAPPENED\r
+ SETOM INTFLG ; AND REQUEST AN INTERRUPT\r
+ SETZM GCDOWN\r
+\r
+RBLDM: JUMPGE R,CPOPJ\r
+ SKIPGE M,1(R) ; SKIP IF FUNNY\r
+ POPJ P,\r
+\r
+ HLRS M\r
+ ADD M,PURVEC+1(TVP)\r
+ SKIPL M,1(M)\r
+ POPJ P,\r
+ PUSH P,0\r
+ HRRZ 0,1(R)\r
+ ADD M,0\r
+ POP P,0\r
+CPOPJ: POPJ P,\r
+\r
+\r
+AGCE1: FATAL AGC--TYPE VECTOR NOT OF TYPE VECTOR\r
+\r
+\f; CONVERSION FROM FLOAT TO DECIMAL. X 100 AND SEND OUT WITH APPROPRIATELY PLACED DECIMAL\r
+; POINT.\r
+\r
+FIXSEN: PUSH P,B ; SAVE TIME\r
+ MOVEI B,[ASCIZ /TIME= /]\r
+ SKIPE GCMONF\r
+ PUSHJ P,MSGTYP ; PRINT OUT MESSAGE\r
+ POP P,B ; RESTORE B\r
+ FSBR B,GCTIM ; GET TIME ELAPSED\r
+ MOVEM B,GCTIM ; SAVE ELAPSED TIME FOR INT-HANDLER\r
+ SKIPN GCMONF\r
+ POPJ P,\r
+ FMPRI B,(100.0) ; CONVERT TO FIX\r
+ MULI B,400\r
+ TSC B,B\r
+ ASH C,-163.(B)\r
+ MOVEI A,1 ; INITIALIZE COUNT OF CHARACTERS FOR PUTTING OUT TIME\r
+ PUSH P,C\r
+ IDIVI C,10. ; START COUNTING\r
+ JUMPLE C,.+2\r
+ AOJA A,.-2\r
+ POP P,C\r
+ CAIN A,1 ; SEE IF THERE IS ONLY ONE CHARACTER\r
+ JRST DOT1\r
+FIXOUT: IDIVI C,10. ; RECOVER NUMBER\r
+ HRLM D,(P)\r
+ SKIPE C\r
+ PUSHJ P,FIXOUT\r
+ PUSH P,A ; SAVE A\r
+ CAIN A,2 ; DECIMAL POINT HERE?\r
+ JRST DOT2\r
+FIX1: HLRZ A,(P)-1 ; GET NUMBER\r
+ ADDI A,60 ; MAKE IT A CHARACTER\r
+ PUSHJ P,MTYO ; OUT IT GOES\r
+ POP P,A\r
+ SOJ A,\r
+ POPJ P,\r
+DOT1: MOVEI A,". ; OUTPUT DECIMAL POINT AND PADDING 0\r
+ PUSHJ P,MTYO\r
+ MOVEI A,"0\r
+ PUSHJ P,MTYO\r
+ JRST FIXOUT ; CONTINUE\r
+DOT2: MOVEI A,". ; OUTPUT DECIMAL POINT\r
+ PUSHJ P,MTYO\r
+ JRST FIX1\r
+\r
+\f; INITIAL CORE ADJUSTMENT TO OBTAIN SPACE\r
+; FOR MARK PHASE PDL\r
+\r
+TRYCOR: MOVEI A,2000\r
+ ADDB A,CORTOP ; TRY AND GET 1 BLOCK\r
+ ASH A,-10.\r
+ MOVEI E,(A) ; SAVE FOR LOOPER\r
+ PUSHJ P,P.CORE ; GET CORE\r
+ JRST TRYCO2 ; FAILED, TAKE MORE ACTION\r
+ JRST CORGET\r
+\r
+TRYCO2: MOVNI A,2000 ; FIXUP CORTOP\r
+ ADDM A,CORTOP\r
+TRYCO3: MOVE 0,TPGROW\r
+ ADD 0,PGROW ; 0/ NEQ 0 IF STACK BLEW\r
+ SKIPGE TP ; SKIP IF TP BLOWN\r
+ SKIPL PSTO+1(PVP) ; SKIP IF P WINS\r
+ MOVEI 0,1\r
+ SKIPN 0\r
+ MOVEI B,[ASCIZ /\r
+CORE NEEDED:\r
+ TYPE C TO KEEP TRYING\r
+ TYPE N TO GET MUDDLE ERROR\r
+ TYPE V TO RETURN TO MONITOR\r
+/]\r
+ SKIPE 0\r
+ MOVEI B,[ASCIZ /\r
+CORE NEEDED:\r
+ TYPE C TO KEEP TRYING\r
+ TYPE V TO RETURN TO MONITOR\r
+/]\r
+ PUSH P,0\r
+ PUSHJ P,MSGTYP\r
+ SETOM GCFLCH ; TELL INTERRUPT HANDLER TO .ITYIC\r
+ PUSHJ P,MTYI\r
+ PUSHJ P,UPLO ; IN CASE LOWER CASE TYPED\r
+ SETZM GCFLCH\r
+ POP P,0\r
+ CAIN A,"C\r
+ JRST TRYCO4\r
+ CAIN A,"N\r
+ JUMPE 0,TRYCO5\r
+ CAIN A,"V\r
+ FATAL CORE LOSSAGE\r
+ JRST TRYCO3\r
+\r
+UPLO: CAIL A,"a\r
+ CAILE A,"z\r
+ POPJ P,\r
+ SUBI A,40\r
+ POPJ P,\r
+\r
+TRYCO4: MOVEI A,(E)\r
+TRYCO9: MOVEI B,1 ; SLEEP AND CORE UNTIL WINNAGE\r
+ EXCH A,B\r
+ PUSHJ P,%SLEEP ; SLEEP A WHILE\r
+ EXCH A,B\r
+ PUSHJ P,P.CORE\r
+ JRST TRYCO9\r
+\r
+ MOVEI B,[ASCIZ /\r
+WIN!\r
+/]\r
+ PUSHJ P,MSGTYP\r
+ JRST CORGET\r
+\r
+TRYCO5: MOVNI A,3 ; GIVE WORST ERROR RETURN\r
+ MOVEM A,GCDANG\r
+ JRST TRYCOX\r
+\r
+\r
+\f; SUBROUTINE TO CHECK SIZE OF PDLS AND DO FENCEPOSTING\r
+\r
+PDLCHK: JUMPGE A,CPOPJ\r
+ HLRE B,A ;GET NEGATIVE COUNT\r
+ MOVE C,A ;SAVE A COPY OF PDL POINTER\r
+ SUBI A,-1(B) ;LOCATE DOPE WORD PAIR\r
+ HRRZS A ; ISOLATE POINTER\r
+ CAME A,TPGROW ;GROWING?\r
+ ADDI A,PDLBUF ;NO, POINT TO REAL DOPE WORD\r
+ HLRZ D,(A) ;GET COUNT FROM DOPE WORD\r
+ MOVNS B ;GET POSITIVE AMOUNT LEFT\r
+ SUBI D,2(B) ; PDL FULL?\r
+ JUMPE D,NOFENC ;YES NO FENCE POSTING\r
+ SETOM 1(C) ;CLOBBER TOP WORD\r
+ SOJE D,NOFENC ;STILL MORE?\r
+ MOVSI D,1(C) ;YES, SET UP TO BLT FENCE POSTS\r
+ HRRI D,2(C)\r
+ BLT D,-2(A) ;FENCE POST ALL EXCEPT DOPE WORDS\r
+\r
+\r
+NOFENC: CAIG B,TPMAX ;NOW CHECK SIZE\r
+ CAIG B,TPMIN\r
+ JRST MUNGTP ;TOO BIG OR TOO SMALL\r
+ POPJ P,\r
+\r
+MUNGTP: SUBI B,TPGOOD ;FIND DELTA TP\r
+MUNG3: MOVE C,-1(A) ;IS GROWTH ALREADY SPECIFIED\r
+ TRNE C,777000 ;SKIP IF NOT\r
+ POPJ P, ;ASSUME GROWTH GIVEN WILL WIN\r
+\r
+ ASH B,-6 ;CONVERT TO NUMBER OF BLOCKS\r
+ JUMPLE B,MUNGT1\r
+ CAILE B,377 ; SKIP IF BELOW MAX\r
+ MOVEI B,377 ; ELSE USE MAX\r
+ TRO B,400 ;TURN ON SHRINK BIT\r
+ JRST MUNGT2\r
+MUNGT1: MOVMS B\r
+ ANDI B,377\r
+MUNGT2: DPB B,[111100,,-1(A)] ;STORE IN DOPE WORD\r
+ POPJ P,\r
+\r
+; CHECK UNMARKED STACK (NO NEED TO FENCE POST)\r
+\r
+PDLCHP: HLRE B,A ;-LENGTH TO B\r
+ MOVE C,A\r
+ SUBI A,-1(B) ;POINT TO DOPE WORD\r
+ HRRZS A ;ISOLATE POINTER\r
+ CAME A,PGROW ;GROWING?\r
+ ADDI A,PDLBUF ;NO, POINT TO REAL DOPE WORD\r
+ MOVMS B ;PLUS LENGTH\r
+ HLRZ D,(A) ; D.W. LENGTH\r
+ SUBI D,2(B) ; PDL FULL\r
+ JUMPE D,NOPF\r
+ SETOM 1(C) ; START FENECE POST\r
+ SOJE D,NOPF ; 1 WORD?\r
+ MOVSI D,1(C)\r
+ HRRI D,2(C)\r
+ BLT D,-2(A)\r
+\r
+NOPF: CAIG B,PMAX ;TOO BIG?\r
+ CAIG B,PMIN ;OR TOO LITTLE\r
+ JRST .+2 ;YES, MUNG IT\r
+ POPJ P,\r
+ SUBI B,PGOOD\r
+ JRST MUNG3\r
+\r
+;THIS ROUTINE MAKES SURE CURRENT FRAME MAKES SENSE\r
+FRMUNG: MOVEM D,PSAV(A)\r
+ MOVEM SP,SPSAV(A)\r
+ MOVEM TP,TPSAV(A) ;SAVE FOR MARKING\r
+ POPJ P,\r
+\r
+; ROUTINE TO PRE MARK SPECIAL HACKS\r
+\r
+PRMRK: SKIPE GCHAIR ; FLUSH IF NO HAIR\r
+ POPJ P,\r
+ HLRE B,A\r
+ SUBI A,(B) ;POINT TO DOPE WORD\r
+ HLRZ B,1(A) ; GET LNTH\r
+ ADDM B,VECNUM ; AND UPDATE VECNUM\r
+ LDB B,[111100,,(A)] ; GET GROWTHS\r
+ TRZE B,400 ; SIGN HACK\r
+ MOVNS B\r
+ ASH B,6 ; TO WORDS\r
+ ADDM B,VECNUM\r
+ LDB 0,[001100,,(A)]\r
+ TRZE 0,400\r
+ MOVNS 0\r
+ ASH 0,6\r
+ ADDM 0,VECNUM\r
+ PUSHJ P,GSHFLG ; SET GROW FLAGS\r
+ IORM D,1(A) ;AND MARK\r
+ POPJ P,\r
+\r
+; SET UP FLAGS FOR OPTIOANAL GROW/SHRINK PHASES\r
+\r
+GSHFLG: SKIPG B\r
+ SKIPLE 0\r
+ SETOM GREW\r
+ SKIPL B\r
+ SKIPGE 0\r
+ SETOM SHRUNK\r
+ POPJ P,\r
+\r
+\f;GENERAL MARK SUBROUTINE. CALLED TO MARK ALL THINGS\r
+; A/ GOODIE TO MARK FROM\r
+; B/ TYPE OF A (IN RH)\r
+; C/ TYPE,DATUM PAIR POINTER\r
+\r
+MARK2: HLRZ B,(C) ;GET TYPE\r
+MARK1: MOVE A,1(C) ;GET GOODIE\r
+MARK: JUMPE A,CPOPJ ; NEVER MARK 0\r
+ MOVEI 0,(A)\r
+ CAIL 0,@PURBOT ; DONT MARK PURE STUFF\r
+ POPJ P,\r
+ PUSH P,A ;SAVE GOODIE\r
+ HRLM C,-1(P) ;AND POINTER TO IT\r
+ ANDI B,TYPMSK ; FLUSH MONITORS\r
+ LSH B,1 ;TIMES 2 TO GET SAT\r
+ HRRZ B,@TYPNT ;GET SAT\r
+ ANDI B,SATMSK\r
+ CAIG B,NUMSAT ; SKIP IF TEMPLATE DATA\r
+ JRST @MKTBS(B) ;AND GO MARK\r
+ JRST TD.MRK\r
+\r
+; DISPATCH TABLE FOR MARK PHASE ("SETZ'D" ENTRIES MUST BE DEFERRED)\r
+\r
+DISTBS MKTBS,GCRET,[[S2WORD,PAIRMK],[S2DEFR,DEFMK],[SNWORD,VECTMK]\r
+[STPSTK,TPMK],[SARGS,<SETZ ARGMK>],[S2NWORD,VECTMK],[SPSTK,TPMK],[SSTORE,VECTMK]\r
+[SFRAME,<SETZ FRMK>],[SBYTE,<SETZ BYTMK>],[SATOM,ATOMK],[SPVP,VECTMK],[SGATOM,GATOMK]\r
+[SLOCID,<SETZ LOCMK>],[SCHSTR,<SETZ BYTMK>],[SASOC,ASMRK],[SLOCL,PAIRMK]\r
+[SLOCA,<SETZ ARGMK>],[SLOCV,VECTMK],[SLOCU,VECTMK],[SLOCS,<SETZ BYTMK>],[SLOCN,ASMRK]]\r
+\r
+\r
+;HERE TO MARK THAT WHICH IS POINTED TO BY A DEFERRED POINTER\r
+\r
+DEFMK: TLOA TYPNT,400000 ;USE SIGN BIT AS FLAG\r
+\r
+;HERE TO MARK LIST ELEMENTS\r
+\r
+PAIRMK: TLZ TYPNT,400000 ;TURN OF DEFER BIT\r
+ PUSH P,[0] ; WILL HOLD BACK PNTR\r
+ MOVEI C,(A) ;POINT TO LIST\r
+PAIRM1: CAMGE C,PARTOP ;CHECK FOR BEING IN BOUNDS\r
+ CAMGE C,PARBOT\r
+ FATAL AGC--MARKED PAIR OUTSIDE PAIR SPACE\r
+ SKIPGE B,(C) ;SKIP IF NOT MARKED\r
+ JRST RETNEW ;ALREADY MARKED, RETURN\r
+ IORM D,(C) ;MARK IT\r
+ AOS PARNUM\r
+ MOVEM B,FRONT(FPTR) ; STORE 1ST WORD\r
+ MOVE 0,1(C) ; AND 2D\r
+ MOVEM 0,FRONT+1(FPTR)\r
+ ADD FPTR,[2,,2] ; MOVE ALONG IN FRONTIER\r
+ JUMPL FPTR,PAIRM2 ; NOD NEED FOR NEW CORE\r
+\r
+; HERE TO EXTEND THE FRONTIER\r
+\r
+ HRRZ A,BOTNEW ; CURRENT BOTTOM OF WINDOW IN INF\r
+ ADDI A,2000 ; MOVE IT UP\r
+ HRRM A,BOTNEW\r
+ ASH A,-10. ; TO PAGES\r
+SYSLO1: PUSHJ P,%GETIP ; GET PAGE\r
+ PUSHJ P,%SHFNT ; AND SHARE IT\r
+ MOVSI FPTR,-2000\r
+\r
+PAIRM2: MOVEI A,@BOTNEW ; GET INF ADDR\r
+ SUBI A,2\r
+ HRRM A,(C) ; LEAVE A POINTER TO NEW HOME\r
+ HRRZ E,(P) ; GET BACK POINTER\r
+ JUMPE E,PAIRM7 ; 1ST ONE, NEW FIXUP\r
+ MOVSI 0,(HRRM) ; INS FOR CLOBBER\r
+ PUSHJ P,SMINF ; SMASH INF'S CORE IMAGE\r
+PAIRM4: MOVEM A,(P) ; NEW BACK POINTER\r
+ JUMPL TYPNT,DEFDO ;GO HANDLE DEFERRED POINTER\r
+ HRLM B,(P) ; SAVE OLD CDR\r
+ PUSHJ P,MARK2 ;MARK THIS DATUM\r
+ HRRZ E,(P) ; SMASH CAR IN CASE CHANGED\r
+ ADDI E,1\r
+ MOVSI 0,(MOVEM)\r
+ PUSHJ P,SMINF\r
+ HLRZ C,(P) ;GET CDR OF LIST\r
+ CAIGE C,@PURBOT ; SKIP IF PURE (I.E. DONT MARK)\r
+ JUMPN C,PAIRM1 ;IF NOT NIL, MARK IT\r
+GCRETP: SUB P,[1,,1]\r
+\r
+GCRET: TLZ TYPNT,400000 ;FOR PAIRMKS BENEFIT\r
+ HLRZ C,-1(P) ;RESTORE C\r
+ POP P,A\r
+ POPJ P, ;AND RETURN TO CALLER\r
+\r
+;HERE TO MARK DEFERRED POINTER\r
+\r
+DEFDO: PUSH P,B ; PUSH OLD PAIR ON STACK\r
+ PUSH P,1(C)\r
+ MOVEI C,-1(P) ; USE AS NEW DATUM\r
+ PUSHJ P,MARK2 ;MARK THE DATUM\r
+ HRRZ E,-2(P) ; GET POINTER IN INF CORE\r
+ ADDI E,1\r
+ MOVSI 0,(MOVEM)\r
+ PUSHJ P,SMINF ; AND CLOBBER\r
+ SUB P,[3,,3]\r
+ JRST GCRET ;AND RETURN\r
+\r
+\r
+PAIRM7: MOVEM A,-1(P) ; SAVE NEW VAL FOR RETURN\r
+ JRST PAIRM4\r
+\r
+RETNEW: HRRZ A,(C) ; POINT TO NEW WORLD LOCN\r
+ HRRZ E,(P) ; BACK POINTER\r
+ JUMPE E,RETNW1 ; NONE\r
+ MOVSI 0,(HRRM)\r
+ PUSHJ P,SMINF\r
+ JRST GCRETP\r
+\r
+RETNW1: MOVEM A,-1(P)\r
+ JRST GCRETP\r
+\r
+; ROUTINE TO SMASH INFERIORS PPAGES\r
+; E/ ADDR IN INF, A/ THING TO SMASH ,0/ INS TO USE\r
+\r
+SMINF: CAML E,WNDBOT ; SEE IF IN WINDOW\r
+ CAML E,WNDTOP\r
+ JRST SMINF1 ; NO TRY FRONTIER\r
+SMINF3: SUB E,WNDBOT ; FIX UP\r
+ IOR 0,[0 A,WIND(E)] ; FIX INS\r
+ XCT 0\r
+ POPJ P,\r
+\r
+SMINF1: PUSH P,0\r
+ HRRZ 0,BOTNEW ; GET FRONTIER RANGE\r
+ CAML E,0 ; SKIP IF BELOW\r
+ CAIL E,@BOTNEW\r
+ JRST SMINF2\r
+ SUB E,0 ; FIXUP E\r
+ POP P,0\r
+ IOR 0,[0 A,FRONT(E)]\r
+ XCT 0\r
+ POPJ P,\r
+\r
+SMINF2: PUSH P,A\r
+ MOVE A,E\r
+ ASH A,-10. ; TO PAGES\r
+ PUSHJ P,%SHWND\r
+ ASH A,10. ; BACK TO WORDS\r
+ MOVEM A,WNDBOT\r
+ ADDI A,2000\r
+ MOVEM A,WNDTOP\r
+ POP P,A\r
+ POP P,0 ; RESTORE INS OF INTEREST\r
+ JRST SMINF3\r
+ \r
+\r
+\f; VECTOR AND TP MARKER, SIGN OF TYPNT IS SET BASED ON WHICH ONE\r
+\r
+TPMK: TLOA TYPNT,400000 ;SET TP MARK FLAG\r
+VECTMK: TLZ TYPNT,400000\r
+ MOVEI E,(A) ;SAVE A POINTER TO THE VECTOR\r
+ HLRE B,A ;GET -LNTH\r
+ SUB A,B ;LOCATE DOPE WORD\r
+ MOVEI A,1(A) ;ZERO LH AND POINT TO 2ND DOPE WORD\r
+ PUSHJ P,VECBND ; CHECK IN VECTOR SPACE\r
+ JRST VECTB1 ;LOSE, COMPLAIN\r
+\r
+ JUMPGE TYPNT,NOBUFR ;IF A VECTOR, NO BUFFER CHECK\r
+ CAME A,PGROW ;IS THIS THE BLOWN P\r
+ CAMN A,TPGROW ;IS THIS THE GROWING PDL\r
+ JRST NOBUFR ;YES, DONT ADD BUFFER\r
+ ADDI A,PDLBUF ;POINT TO REAL DOPE WORD\r
+ MOVSI 0,-PDLBUF ;ALSO FIX UP POINTER\r
+ ADDB 0,1(C)\r
+ MOVEM 0,(P) ; FIXUP RET'D PNTR\r
+\r
+NOBUFR: HLRE B,(A) ;GET LENGTH FROM DOPE WORD\r
+ JUMPL B,GCRET ; MARKED, LEAVE\r
+ ANDI B,377777 ;CLOBBER POSSIBLE MARK BIT\r
+ MOVEI F,(A) ;SAVE A POINTER TO DOPE WORD\r
+ SUBI F,1(B) ;F POINTS TO START OF VECTOR\r
+ HRRZ 0,-1(A) ;SEE IF GROWTH SPECIFIED\r
+ MOVEI B,0 ; SET GROWTH 0\r
+ JUMPE 0,NOCHNG ;NONE, JUST CHECK CURRENT SIZES\r
+\r
+ LDB B,[001100,,0] ;GET GROWTH FACTOR\r
+ TRZE B,400 ;KILL SIGN BIT AND SKIP IF +\r
+ MOVNS B ;NEGATE\r
+ ASH B,6 ;CONVERT TO NUMBER OF WORDS\r
+ SUB F,B ;BOTTOM IS LOWER IN CORE\r
+ LDB 0,[111100,,0] ;GET TOP GROWTH\r
+ TRZE 0,400 ;HACK SIGN BIT\r
+ MOVNS 0\r
+ ASH 0,6 ;CONVERT TO WORDS\r
+ PUSHJ P,GSHFLG ; HACK FLAGS FOR GROW/SHRINK\r
+ ADD B,0 ;TOTAL GROWTH TO B\r
+NOCHNG:\r
+VECOK: HLRE E,(A) ;GET LENGTH AND MARKING\r
+ MOVEI F,(E) ;SAVE A COPY\r
+ ADD F,B ;ADD GROWTH\r
+ SUBI E,2 ;- DOPE WORD LENGTH\r
+ IORM D,(A) ;MAKE SURE NOW MARKED\r
+ CAML A,VECBOT ; ONLY IF REALLY IN VEC SPACE\r
+ ADDM F,VECNUM ; ADD LENGTH OF VECTOR\r
+ JUMPLE E,GCRET ;ALREADY MARKED OR ZERO LENGTH, LEAVE\r
+\r
+ SKIPGE B,-1(A) ;SKIP IF UNIFORM\r
+ TLNE B,377777 ;SKIP IF NOT SPECIAL\r
+ JUMPGE TYPNT,NOTGEN ;JUMP IF NOT A GENERAL VECTOR\r
+\r
+GENRAL: HLRZ 0,B ;CHECK FOR PSTACK\r
+ JUMPE 0,NOTGEN ;IT ISN'T GENERAL\r
+ SUBI A,1(E) ;POINT TO FIRST ELEMENT\r
+ MOVEI C,(A) ;POINT TO FIRST ELEMENT WITH C\r
+\r
+\f; LOOP TO MARK ELEMENTS IN A GENERAL VECTOR\r
+ PUSH P,[0]\r
+VECTM2: HLRE B,(C) ;GET TYPE AND MARKING\r
+ JUMPL B,GCRET1 ;RETURN, (EITHER DOPE WORD OR FENCE POST)\r
+ MOVE A,1(C) ;DATUM TO A\r
+ ANDI B,TYPMSK ; FLUSH MONITORS\r
+ CAIE B,TCBLK ;IS THIS A SAVED FRAME?\r
+ CAIN B,TENTRY ;IS THIS A STACK FRAME\r
+ JRST MFRAME ;YES, MARK IT\r
+ CAIE B,TUBIND ; BIND\r
+ CAIN B,TBIND ;OR A BINDING BLOCK\r
+ JRST MBIND\r
+\r
+VECTM3: PUSHJ P,MARK ;MARK DATUM\r
+ MOVEM A,1(C) ; IN CASE WAS FIXED\r
+VECTM4: ADDI C,2\r
+ JRST VECTM2\r
+\r
+MFRAME: HRROI C,FRAMLN+FSAV-1(C) ;POINT TO FUNCTION\r
+ HRRZ A,1(C) ; GET IT\r
+ PUSHJ P,VECBND ; CHECK IN VECTOR SPACE\r
+ JRST MFRAM1 ; IGNORE, NOT IN VECTOR SPACE\r
+ HRL A,(A) ; GET LENGTH\r
+ MOVEI B,TVEC\r
+ PUSHJ P,MARK ; AND MARK IT\r
+MFRAM1: HRROI C,SPSAV-FSAV(C) ;POINT TO SAVED SP\r
+ MOVEI B,TSP\r
+ PUSHJ P,MARK1 ;MARK THE GOODIE\r
+ HRROI C,PSAV-SPSAV(C) ;POINT TO SAVED P\r
+ MOVEI B,TPDL\r
+ PUSHJ P,MARK1 ;AND MARK IT\r
+ HRROI C,TPSAV-PSAV(C) ;POINT TO SAVED TP\r
+ MOVEI B,TTP\r
+ PUSHJ P,MARK1 ;MARK IT ALS\r
+ MOVEI C,-TPSAV+1(C) ;POINT PAST THE FRAME\r
+ JRST VECTM2 ;AND DO MORE MARKING\r
+\r
+\r
+MBIND: MOVEI B,TATOM ;FIRST MARK ATOM\r
+ SKIPN GCHAIR ; IF NO HAIR, MARK ALL NOW\r
+ SKIPE (P) ; PASSED MARKER, IF SO DONT SKIP\r
+ JRST MBIND2 ; GO MARK\r
+ CAME A,IMQUOTE THIS-PROCESS\r
+ JRST MBIND1 ; NOT IT, CONTINUE SKIPPING\r
+ HRRM LPVP,2(C) ; SAVE IN RH OF TPVP,,0\r
+ MOVEI LPVP,(C) ; POINT\r
+ SETOM (P) ; INDICATE PASSAGE\r
+MBIND1: ADDI C,6 ; SKIP BINDING\r
+ JRST VECTM2\r
+\r
+MBIND2: PUSHJ P,MARK1 ; MARK ATOM\r
+ ADDI C,2 ; POINT TO VAL\r
+ PUSHJ P,MARK2 ; AND MARK IT\r
+ MOVEM A,1(C)\r
+ ADDI C,2\r
+ MOVEI B,TLIST ; POINT TO DECL SPECS\r
+ HLRZ A,(C)\r
+ PUSHJ P,MARK ; AND MARK IT\r
+ HRLM A,(C) ; LIST FIX UP\r
+ MOVEI B,TLOCI ; NOW MARK LOCATIVE\r
+ MOVE A,1(C)\r
+ JRST VECTM3\r
+\r
+VECLOS: JUMPL C,CCRET ;JUMP IF CAN'T MUNG TYPE\r
+ HLLZ 0,(C) ;GET TYPE\r
+ MOVEI B,TILLEG ;GET ILLEGAL TYPE\r
+ HRLM B,(C)\r
+ MOVEM 0,1(C) ;AND STORE OLD TYPE AS VALUE\r
+ JRST GCRET ;RETURN WITHOUT MARKING VECTOR\r
+\r
+CCRET: CLEARM 1(C) ;CLOBBER THE DATUM\r
+ JRST GCRET\r
+\r
+\r
+IGBLK: HRRZ B,(C) ;SKIP TO END OF PP BLOCK\r
+ ADDI C,3(B)\r
+ JRST VECTM2\r
+\f; MARK ARG POINTERS\r
+\r
+ARGMK: HRRZ A,1(C) ; GET POINTER\r
+ HLRE B,1(C) ; AND LNTH\r
+ SUB A,B ; POINT TO BASE\r
+ PUSHJ P,VECBND\r
+ JRST ARGMK0\r
+ HLRZ 0,(A) ; GET TYPE\r
+ ANDI 0,TYPMSK\r
+ CAIN 0,TCBLK\r
+ JRST ARGMK1\r
+ CAIE 0,TENTRY ; IS NEXT A WINNER?\r
+ CAIN 0,TINFO\r
+ JRST ARGMK1 ; YES, GO ON TO WIN CODE\r
+\r
+ARGMK0: SETZB A,1(C) ; CLOBBER THE CELL\r
+ SETZM (P) ; AND SAVED COPY\r
+ JRST GCRET\r
+\r
+ARGMK1: MOVE B,1(A) ; ASSUME TTB\r
+ ADDI B,(A) ; POINT TO FRAME\r
+ CAIE 0,TINFO ; IS IT?\r
+ MOVEI B,FRAMLN(A) ; NO, USE OTHER GOODIE\r
+ HLRZ 0,OTBSAV(B) ; GET TIME\r
+ HRRZ A,(C) ; AND FROM POINTER\r
+ CAIE 0,(A) ; SKIP IF WINNER\r
+ JRST ARGMK0\r
+ HRROI C,TPSAV-1(B) ; MARK FROM TP SLOT\r
+ MOVEI B,TTP\r
+ MOVE A,1(C)\r
+; PUSHJ P,MARK ; WILL PUT BACK WHEN KNOWN HOW!\r
+ JRST GCRET\r
+\r
+; MARK FRAME POINTERS\r
+\r
+FRMK: SUBI C,1 ;PREPARE TO MARK PROCESS VECTOR\r
+ HRRZ A,1(C) ;USE AS DATUM\r
+ SUBI A,1 ;FUDGE FOR VECTMK\r
+ MOVEI B,TPVP ;IT IS A VECTRO\r
+ PUSHJ P,MARK ;MARK IT\r
+ JRST GCRET\r
+\r
+; MARK BYTE POINTER\r
+\r
+BYTMK: PUSHJ P,BYTDOP ; GET DOPE WORD IN A\r
+ SOJG A,VECTMK ;FUDGE DOPE WORD POINTER FOR VECTMK\r
+\r
+ FATAL AGC--BYTE POINTER WITH ZERO DOPE WORD POINTER\r
+\r
+\f; MARK ATOMS IN GVAL STACK\r
+\r
+GATOMK: HRRZ B,(C) ; POINT TO POSSIBLE GDECL\r
+ JUMPE B,ATOMK\r
+ CAIN B,-1\r
+ JRST ATOMK\r
+ MOVEI A,(B) ; POINT TO DECL FOR MARK\r
+ MOVEI B,TLIST\r
+ MOVEI C,0\r
+ PUSHJ P,MARK\r
+ HLRZ C,-1(P) ; RESTORE HOME POINTER\r
+ HRRM A,(C) ; CLOBBER UPDATED LIST IN\r
+ MOVE A,1(C) ; RESTORE ATOM POINTER\r
+\r
+; MARK ATOMS\r
+\r
+ATOMK:\r
+REPEAT 0,[\r
+ TLO TYPNT,.ATOM. ; SAY ATOM WAS MARKED\r
+ PUSHJ P,GETLNT ;GET LENGTH AND CHECK BOUNDS\r
+ HRRZ C,(A) ; IF UNBOUND OR GLOBAL\r
+ JUMPE C,MRKOBL ; SKIP\r
+ HRRZ C,1(A) ; DONT MARK BUT UPDATE BASED ON TPGROW\r
+ HLRE B,1(A)\r
+ SUB C,B ; POINT TO DOPE WORD\r
+ MOVEI C,1(C) ; POINT TO 2D DOPE WORD\r
+ MOVSI B,-PDLBUF ; IN CASE UPDATE\r
+ CAME C,TPGROW ; SKIP IF GROWER\r
+ ADDM B,1(A) ; OTHERWISE UPDATE\r
+MRKOBL: MOVEI C,1(A) ; POINT TO OBLIST SLOT\r
+]\r
+ TLO TYPNT,.ATOM. ; SAY ATOM WAS MARKED\r
+ MOVEI C,1(A)\r
+ HRRZ 0,(A)\r
+ PUSHJ P,GETLNT ;GET LENGTH AND CHECK BOUNDS\r
+ JUMPE 0,MRKOBL\r
+ HRRZ B,(C)\r
+ HLRE 0,(C)\r
+ SUB B,0\r
+ MOVEI B,1(B)\r
+ MOVSI 0,-PDLBUF\r
+ CAME B,TPGROW\r
+ ADDM 0,(C)\r
+MRKOBL: MOVEI B,TOBLS\r
+ SKIPGE 1(C) ; IF > 0, NOT OBL\r
+ PUSHJ P,MARK1 ; AND MARK IT\r
+ JRST GCRET ;AND LEAVE\r
+\r
+GETLNT: HLRE B,A ;GET -LNTH\r
+ SUB A,B ;POINT TO 1ST DOPE WORD\r
+ MOVEI A,1(A) ;POINT TO 2ND DOPE WORD\r
+ PUSHJ P,VECBND\r
+ JRST VECTB1 ;BAD VECTOR, COMPLAIN\r
+\r
+ HLRE B,(A) ;GET LENGTH AND MARKING\r
+ IORM D,(A) ;MAKE SURE MARKED\r
+ JUMPL B,GCRET1 ;MARKED ALREADY, QUIT\r
+ SUBI A,-1(B) ;POINT TO TOP OF ATOM\r
+ CAML A,VECBOT ; DONT COUNT STORAGE\r
+ ADDM B,VECNUM ;UPDATE VECNUM\r
+ POPJ P, ;AND RETURN\r
+\r
+GCRET1: SUB P,[1,,1] ;FLUSH RETURN ADDRESS\r
+ JRST GCRET\r
+\r
+VECBND: CAMGE A,VECTOP\r
+ CAMGE A,VECBOT\r
+ JRST .+2\r
+ JRST CPOPJ1\r
+\r
+ CAMG A,CODTOP\r
+ CAIGE A,STOSTR\r
+ POPJ P,\r
+ JRST CPOPJ1\r
+\r
+; MARK NON-GENERAL VECTORS\r
+\r
+NOTGEN: CAMN B,[GENERAL+<SPVP,,0>] ;PROCESS VECTOR?\r
+ JRST GENRAL ;YES, MARK AS A VECTOR\r
+ JUMPL B,SPECLS ; COMPLAIN IF A SPECIAL HACK\r
+ SUBI A,1(E) ;POINT TO TOP OF A UNIFORM VECTOR\r
+ HLRZS B ;ISOLATE TYPE\r
+ ANDI E,TYPMSK\r
+ MOVE F,B ; AND COPY IT\r
+ LSH B,1 ;FIND OUT WHERE IT WILL GO\r
+ HRRZ B,@TYPNT ;GET SAT IN B\r
+ ANDI B,SATMSK\r
+ MOVEI C,@MKTBS(B) ;POINT TO MARK SR\r
+ CAIN C,GCRET ;IF NOT A MARKED FROM GOODIE, IGNORE\r
+ JRST GCRET\r
+ MOVEI C,-1(A) ;POINT 1 PRIOR TO VECTOR START\r
+ PUSH P,E ;SAVE NUMBER OF ELEMENTS\r
+ PUSH P,F ;AND UNIFORM TYPE\r
+\r
+UNLOOP: MOVE B,(P) ;GET TYPE\r
+ MOVE A,1(C) ;AND GOODIE\r
+ TLO C,400000 ;CAN'T MUNG TYPE\r
+ PUSHJ P,MARK ;MARK THIS ONE\r
+ MOVEM A,1(C) ; LIST FIXUP\r
+ SOSE -1(P) ;COUNT\r
+ AOJA C,UNLOOP ;IF MORE, DO NEXT\r
+\r
+ SUB P,[2,,2] ;REMOVE STACK CRAP\r
+ JRST GCRET\r
+\r
+\r
+SPECLS: FATAL AGC--UNRECOGNIZED SPECIAL VECTOR\r
+\r
+\f;MARK LOCID TYPE GOODIES\r
+\r
+LOCMK: HRRZ B,(C) ;GET TIME\r
+ JUMPE B,LOCMK1 ; SKIP LEGAL CHECK FOR GLOBAL\r
+ HRRZ 0,2(A) ; GET OTHER TIME\r
+ CAIE 0,(B) ; SAME?\r
+ SETZB A,1(C) ; NO, SMASH LOCATIVE\r
+ JUMPE A,GCRET ; LEAVE IF DONE\r
+LOCMK1: PUSH P,C\r
+ MOVEI B,TATOM ; MARK ATOM\r
+ MOVEI C,-2(A) ; POINT TO ATOM\r
+ PUSHJ P,MARK1 ; LET LOCATIVE SAVE THE ATOM\r
+ POP P,C\r
+ HRRZ B,(C) ; TIME BACK\r
+ MOVE A,1(C) ; RESTORE POINTER TO STACK\r
+ JUMPE B,VECTMK ;IF ZERO, GLOBAL\r
+ JRST TPMK ;ELSE, ON TP\r
+\r
+; MARK ASSOCIATION BLOCKS\r
+\r
+ASMRK: HRLI A,-ASOLNT ;LOOK LIKE A VECTOR POINTER\r
+ PUSHJ P,GETLNT ;GET LENGTH AND CHECK BOUNDS\r
+ MOVEI C,(A) ;COPY POINTER\r
+ PUSHJ P,MARK2 ;MARK ITEM CELL\r
+ MOVEM A,1(C)\r
+ ADDI C,INDIC-ITEM ;POINT TO INDICATOR\r
+ PUSHJ P,MARK2\r
+ MOVEM A,1(C)\r
+ ADDI C,VAL-INDIC\r
+ PUSHJ P,MARK2\r
+ MOVEM A,1(C)\r
+ SKIPN GCHAIR ; IF NO HAIR, MARK ALL FRIENDS\r
+ JRST GCRET\r
+ HRRZ A,NODPNT-VAL(C) ; NEXT\r
+ JUMPN A,ASMRK ; IF EXISTS, GO\r
+ JRST GCRET\r
+\r
+\r
+\r
+;HERE WHEN A VECTOR POINTER IS BAD\r
+\r
+VECTB1:FATAL AGC--VECTOR POINTS OUTSIDE OF VECTOR SPACE\r
+\r
+\f; HERE TO MARK TEMPLATE DATA STRUCTURES\r
+\r
+TD.MRK: HLRZ B,(A) ; GET REAL SPEC TYPE\r
+ ANDI B,377777 ; KILL SIGN BIT\r
+ MOVEI E,-NUMSAT-1(B) ; GET REL POINTER TO TABLE\r
+ HRLI E,(E)\r
+ ADD E,TD.LNT+1(TVP)\r
+ HRRZS C,A ; FLUSH COUNT AND SAVE\r
+ SKIPL E ; WITHIN BOUNDS\r
+ FATAL BAD SAT IN AGC\r
+ PUSHJ P,GETLNT ; GOODIE IS NOW MARKED\r
+\r
+ XCT (E) ; RET # OF ELEMENTS IN B\r
+\r
+ HLRZ D,B ; GET POSSIBLE "BASIC LENGTH" FOR RESTS\r
+ PUSH P,[0] ; TEMP USED IF RESTS EXIST\r
+ PUSH P,D\r
+ MOVEI B,(B) ; ZAP TO ONLY LENGTH\r
+ PUSH P,C ; SAVE POINTER TO TEMPLATE STRUCTURE\r
+ PUSH P,[0] ; HOME FOR VALUES\r
+ PUSH P,[0] ; SLOT FOR TEMP\r
+ PUSH P,B ; SAVE\r
+ SUB E,TD.LNT+1(TVP)\r
+ PUSH P,E ; SAVE FOR FINDING OTHER TABLES\r
+ JUMPE D,TD.MR2 ; NO REPEATING SEQ\r
+ ADD E,TD.GET+1(TVP) ; COMP LNTH OF REPEATING SEQ\r
+ HLRE E,(E) ; E ==> - LNTH OF TEMPLATE\r
+ ADDI E,(D) ; E ==> -LENGTH OF REP SEQ\r
+ MOVNS E\r
+ HRLM E,-5(P) ; SAVE IT AND BASIC\r
+\r
+TD.MR2: SKIPG D,-1(P) ; ANY LEFT?\r
+ JRST TD.MR1\r
+\r
+ MOVE E,TD.GET+1(TVP)\r
+ ADD E,(P)\r
+ MOVE E,(E) ; POINTER TO VECTOR IN E\r
+ MOVEM D,-6(P) ; SAVE ELMENT #\r
+ SKIPN B,-5(P) ; SKIP IF "RESTS" EXIST\r
+ SOJA D,TD.MR3\r
+\r
+ MOVEI 0,(B) ; BASIC LNT TO 0\r
+ SUBI 0,(D) ; SEE IF PAST BASIC\r
+ JUMPGE 0,.-3 ; JUMP IF O.K.\r
+ MOVSS B ; REP LNT TO RH, BASIC TO LH\r
+ IDIVI 0,(B) ; A==> -WHICH REPEATER\r
+ MOVNS A\r
+ ADD A,-5(P) ; PLUS BASIC\r
+ ADDI A,1 ; AND FUDGE\r
+ MOVEM A,-6(P) ; SAVE FOR PUTTER\r
+ ADDI E,-1(A) ; POINT\r
+ SOJA D,.+2\r
+\r
+TD.MR3: ADDI E,(D) ; POINT TO SLOT\r
+ XCT (E) ; GET THIS ELEMENT INTO A AND B\r
+ MOVEM A,-3(P) ; SAVE TYPE FOR LATER PUT\r
+ MOVEM B,-2(P)\r
+ EXCH A,B ; REARRANGE\r
+ GETYP B,B\r
+ MOVEI C,-3(P) ; TELL OTHER GUYS THEY CANT DIRECTLY MUNG\r
+ MOVSI D,400000 ; RESET FOR MARK\r
+ PUSHJ P,MARK ; AND MARK THIS GUY (RET FIXED POINTER IN A)\r
+ MOVE C,-4(P) ; REGOBBLE POINTER TO TEMPLATE\r
+ MOVE E,TD.PUT+1(TVP)\r
+ MOVE B,-6(P) ; RESTORE COUNT\r
+ ADD E,(P)\r
+ MOVE E,(E) ; POINTER TO VECTOR IN E\r
+ ADDI E,(B)-1 ; POINT TO SLOT\r
+ MOVE B,-3(P) ; RESTORE TYPE WORD\r
+ EXCH A,B\r
+ SOS D,-1(P) ; GET ELEMENT #\r
+ XCT (E) ; SMASH IT BACK\r
+ FATAL TEMPLATE LOSSAGE\r
+ MOVE C,-4(P) ; RESTORE POINTER IN CASE MUNGED\r
+ JRST TD.MR2\r
+\r
+TD.MR1: SUB P,[7,,7]\r
+ MOVSI D,400000 ; RESTORE MARK/UNMARK BIT\r
+ JRST GCRET\r
+\r
+; This phase attempts to remove any unwanted associations. The program\r
+; loops through the structure marking values of associations. It can only\r
+; stop when no new values (potential items and/or indicators) are marked.\r
+\r
+VALFLS: PUSH P,[0] ; INDICATE WHETHER ANY ON THIS PASS\r
+ PUSH P,[0] ; OR THIS BUCKET\r
+ASOMK1: MOVE A,ASOVEC+1(TVP) ; GET VECTOR POINTER\r
+ SETOM -1(P) ; INITIALIZE FLAG\r
+\r
+ASOM6: SKIPG C,(A) ; SKIP IF BUCKET TO BE SCANNED\r
+ JRST ASOM1\r
+ SETOM (P) ; SAY BUCKET NOT CHANGED\r
+\r
+ASOM2: MOVEI F,(C) ; COPY POINTER\r
+ SKIPG ASOLNT+1(C) ; SKIP IF NOT ALREADY MARKED\r
+ JRST ASOM4 ; MARKED, GO ON\r
+ PUSHJ P,MARKQ ; SEE IF ITEM IS MARKED\r
+ JRST ASOM3 ; IT IS NOT, IGNORE IT\r
+ MOVEI F,(C) ; IN CASE CLOBBERED BY MARK2\r
+ MOVEI C,INDIC(C) ; POINT TO INDICATOR SLOT\r
+ PUSHJ P,MARKQ\r
+ JRST ASOM3 ; NOT MARKED\r
+\r
+ PUSH P,A ; HERE TO MARK VALUE\r
+ PUSH P,F\r
+ HLRE F,ASOLNT-INDIC+1(C) ; GET LENGTH\r
+ JUMPL F,.+3 ; SKIP IF MARKED\r
+ CAML C,VECBOT ; SKIP IF IN NOT VECT SPACE\r
+ ADDM F,VECNUM\r
+ PUSHJ P,MARK2 ; AND MARK\r
+ MOVEM A,1(C) ; LIST FIX UP\r
+ ADDI C,ITEM-INDIC ; POINT TO ITEM\r
+ PUSHJ P,MARK2\r
+ MOVEM A,1(C)\r
+ ADDI C,VAL-ITEM ; POINT TO VALUE\r
+ PUSHJ P,MARK2\r
+ MOVEM A,1(C)\r
+ IORM D,ASOLNT-VAL+1(C) ; MARK ASOC BLOCK\r
+ POP P,F\r
+ POP P,A\r
+ AOSA -1(P) ; INDICATE A MARK TOOK PLACE\r
+\r
+ASOM3: AOS (P) ; INDICATE AN UNMARKED IN THIS BUCKET\r
+ASOM4: HRRZ C,ASOLNT-1(F) ; POINT TO NEXT IN BUCKET\r
+ JUMPN C,ASOM2 ; IF NOT EMPTY, CONTINUE\r
+ SKIPGE (P) ; SKIP IF ANY NOT MARKED\r
+ HRROS (A) ; MARK BUCKET AS NOT INTERESTING\r
+ASOM1: AOBJN A,ASOM6 ; GO TO NEXT BUCKET\r
+ TLZE TYPNT,.ATOM. ; ANY ATOMS MARKED?\r
+ JRST VALFLA ; YES, CHECK VALUES\r
+VALFL8:\r
+\r
+; NOW SEE WHICH CHANNELS STILL POINTED TO\r
+\r
+CHNFL3: MOVEI 0,N.CHNS-1\r
+ MOVEI A,CHNL1(TVP) ; SLOTS\r
+ HRLI A,TCHAN ; TYPE HERE TOO\r
+\r
+CHNFL2: SKIPN B,1(A)\r
+ JRST CHNFL1\r
+ HLRE C,B\r
+ SUBI B,(C) ; POINT TO DOPE\r
+ HLLM A,(A) ; PUT TYPE BACK\r
+ SKIPGE 1(B)\r
+ JRST CHNFL1\r
+ HLLOS (A) ; MARK AS A LOSER\r
+ PUSH P,A\r
+ PUSH P,0\r
+ MOVEI C,(A)\r
+ PUSHJ P,MARK2\r
+ POP P,0\r
+ POP P,A\r
+ SETZM -1(P) ; SAY MARKED\r
+CHNFL1: ADDI A,2\r
+ SOJG 0,CHNFL2\r
+\r
+ SKIPE GCHAIR ; IF NOT HAIRY CASE\r
+ POPJ P, ; LEAVE\r
+\r
+ SKIPL -1(P) ; SKIP IF NOTHING NEW MARKED\r
+ JRST ASOMK1\r
+\r
+ SUB P,[2,,2] ; REMOVE FLAGS\r
+\r
+\r
+\r
+\f; HERE TO REEMOVE UNUSED ASSOCIATIONS\r
+\r
+ MOVE A,ASOVEC+1(TVP) ; GET ASOVEC BACK FOR FLUSHES\r
+\r
+ASOFL1: SKIPN C,(A) ; SKIP IF BUCKET NOT EMPTY\r
+ JRST ASOFL2 ; EMPTY BUCKET, IGNORE\r
+ HRRZS (A) ; UNDO DAMAGE OF BEFORE\r
+\r
+ASOFL5: SKIPGE ASOLNT+1(C) ; SKIP IF UNMARKED\r
+ JRST ASOFL3 ; MARKED, DONT FLUSH\r
+\r
+ HRRZ B,ASOLNT-1(C) ; GET FORWARD POINTER\r
+ HLRZ E,ASOLNT-1(C) ; AND BACK POINTER\r
+ JUMPN E,ASOFL4 ; JUMP IF NO BACK POINTER (FIRST IN BUCKET)\r
+ HRRZM B,(A) ; FIX BUCKET\r
+ JRST .+2\r
+\r
+ASOFL4: HRRM B,ASOLNT-1(E) ; FIX UP PREVIOUS\r
+ JUMPE B,.+2 ; JUMP IF NO NEXT POINTER\r
+ HRLM E,ASOLNT-1(B) ; FIX NEXT'S BACK POINTER\r
+ HRRZ B,NODPNT(C) ; SPLICE OUT THRAD\r
+ HLRZ E,NODPNT(C)\r
+ SKIPE E\r
+ HRRM B,NODPNT(E)\r
+ SKIPE B\r
+ HRLM E,NODPNT(B)\r
+\r
+ASOFL3: HRRZ C,ASOLNT-1(C) ; GO TO NEXT\r
+ JUMPN C,ASOFL5\r
+ASOFL2: AOBJN A,ASOFL1\r
+\r
+; NOW CLOBBER UNMARKED LOCAL NAD GLOBAL VALUES\r
+\r
+ MOVE A,GLOBSP+1(TVP) ; GET GLOBAL PDL\r
+\r
+GLOFLS: SKIPGE (A) ; SKIP IF NOT ALREADY MARKED\r
+ JRST .+3 ; VIOLATE CARDINAL RULE #69\r
+ MOVSI B,-3\r
+ PUSHJ P,ZERSLT ; CLOBBER THE SLOT\r
+ ANDCAM D,(A) ; UNMARK\r
+ ADD A,[4,,4]\r
+ JUMPL A,GLOFLS ; MORE?, KEEP LOOPING\r
+\r
+LOCFL1: HRRZ A,(LPVP) ; NOW CLOBBER LOCAL SLOTS\r
+ HRRZ C,2(LPVP)\r
+ HLLZS 2(LPVP) ; NOW CLEAR\r
+ MOVEI LPVP,(C)\r
+ JUMPE A,LOCFL2 ; NONE TO FLUSH\r
+\r
+LOCFLS: SKIPGE (A) ; MARKDE?\r
+ JRST .+3\r
+ MOVSI B,-5\r
+ PUSHJ P,ZERSLT\r
+ ANDCAM D,(A) ;UNMARK\r
+ HRRZ A,(A) ; GO ON\r
+ JUMPN A,LOCFLS\r
+LOCFL2: JUMPN LPVP,LOCFL1 ; JUMP IF MORE PROCESS\r
+ POPJ P,\r
+\r
+\r
+\r
+MARK23: PUSH P,A ; SAVE BUCKET POINTER\r
+ PUSH P,F\r
+ PUSHJ P,MARK2\r
+ MOVEM A,1(C)\r
+ POP P,F\r
+ POP P,A\r
+ AOS -2(P) ; MARKING HAS OCCURRED\r
+ IORM D,ASOLNT+1(C) ; MARK IT\r
+ JRST MKD\r
+\r
+\f; CHANNEL FLUSHER FOR NON HAIRY GC\r
+\r
+CHNFLS: PUSH P,[-1]\r
+ SETOM (P) ; RESET FOR RETRY\r
+ PUSHJ P,CHNFL3\r
+ SKIPL (P)\r
+ JRST .-3 ; REDO\r
+ SUB P,[1,,1]\r
+ POPJ P,\r
+\r
+; VALUE FLUSHING PHASE, HACKS BOTTOM OF TP AND GLOBAL SP\r
+\r
+VALFLA: MOVE C,GLOBSP+1(TVP)\r
+\r
+VALFL1: SKIPL (C) ; SKIP IF NOT MARKED\r
+ PUSHJ P,MARKQ ; SEE IF ATOM IS MARKED\r
+ JRST VALFL2\r
+ IORM D,(C)\r
+ AOS -1(P) ; INDICATE MARK OCCURRED\r
+ PUSH P,C\r
+ HRRZ B,(C) ; GET POSSIBLE GDECL\r
+ JUMPE B,VLFL10 ; NONE\r
+ CAIN B,-1 ; MAINFIFEST\r
+ JRST VLFL10\r
+ MOVEI A,(B)\r
+ MOVEI B,TLIST\r
+ MOVEI C,0\r
+ PUSHJ P,MARK ; MARK IT\r
+ MOVE C,(P) ; POINT\r
+ HRRM A,(C) ; CLOBBER UPDATE IN\r
+VLFL10: ADD C,[2,,2] ; BUMP TO VALUE\r
+ PUSHJ P,MARK2 ; MARK VALUE\r
+ MOVEM A,1(C)\r
+ POP P,C\r
+VALFL2: ADD C,[4,,4]\r
+ JUMPL C,VALFL1 ; JUMP IF MORE\r
+\r
+ HRLM LPVP,(P) ; SAVE POINTER\r
+VALFL7: MOVEI C,(LPVP)\r
+ MOVEI LPVP,0\r
+VALFL6: HRRM C,(P)\r
+\r
+VALFL5: HRRZ C,(C) ; CHAIN\r
+ JUMPE C,VALFL4\r
+ MOVEI B,TATOM ; TREAT LIKE AN ATOM\r
+ SKIPL (C) ; MARKED?\r
+ PUSHJ P,MARKQ1 ; NO, SEE\r
+ JRST VALFL5 ; LOOP\r
+ AOS -1(P) ; MARK WILL OCCUR\r
+ IORM D,(C)\r
+ ADD C,[2,,2] ; POINT TO VALUE\r
+ PUSHJ P,MARK2 ; MARK VALUE\r
+ MOVEM A,1(C)\r
+ SUBI C,2\r
+ JRST VALFL5\r
+\r
+VALFL4: HRRZ C,(P) ; GET SAVED LPVP\r
+ MOVEI A,(C)\r
+ HRRZ C,2(C) ; POINT TO NEXT\r
+ JUMPN C,VALFL6\r
+ JUMPE LPVP,VALFL9\r
+\r
+ HRRM LPVP,2(A) ; NEW PROCESS WAS MARKED\r
+ JRST VALFL7\r
+\r
+ZERSLT: HRRI B,(A) ; COPY POINTER\r
+ SETZM 1(B)\r
+ AOBJN B,.-1\r
+ POPJ P,\r
+\r
+VALFL9: HLRZ LPVP,(P) ; RESTORE CHAIN\r
+ JRST VALFL8\r
+\r
+\r
+\f;SUBROUTINE TO SEE IF A GOODIE IS MARKED\r
+;RECEIVES POINTER IN C\r
+;SKIPS IF MARKED NOT OTHERWISE\r
+\r
+MARKQ: HLRZ B,(C) ;TYPE TO B\r
+MARKQ1: MOVE E,1(C) ;DATUM TO C\r
+ MOVEI 0,(E)\r
+ CAIL 0,@PURBOT ; DONT CHACK PURE\r
+ JRST MKD ; ALWAYS MARKED\r
+ ANDI B,TYPMSK ; FLUSH MONITORS\r
+ LSH B,1\r
+ HRRZ B,@TYPNT ;GOBBLE SAT\r
+ ANDI B,SATMSK\r
+ CAIG B,NUMSAT ; SKIP FOR TEMPLATE\r
+ JRST @MQTBS(B) ;DISPATCH\r
+ ANDI E,-1 ; FLUSH REST HACKS\r
+ JRST VECMQ\r
+\r
+\r
+DISTBS MQTBS,MKD,[[S2WORD,PAIRMQ],[S2DEFR,PAIRMQ],[SNWORD,VECMQ],[S2NWORD,VECMQ]\r
+[STPSTK,VECMQ],[SARGS,ARGMQ],[SPSTK,VECMQ],[SFRAME,FRMQ],[SBYTE,BYTMQ],[SLOCID,LOCMQ]\r
+[SATOM,VECMQ],[SPVP,VECMQ],[SLOCID,VECMQ],[SCHSTR,BYTMQ],[SLOCA,ARGMQ],[SLOCU,VECMQ]\r
+[SLOCV,VECMQ],[SLOCS,BYTMQ],[SLOCN,ASMQ],[SASOC,ASMQ],[SLOCL,PAIRMQ],[SGATOM,VECMQ]]\r
+\r
+PAIRMQ: JUMPE E,MKD ; NIL ALWAYS MARKED\r
+ SKIPL (E) ; SKIP IF MARKED\r
+ POPJ P,\r
+CPOPJ1:\r
+ARGMQ:\r
+MKD: AOS (P)\r
+ POPJ P,\r
+\r
+BYTMQ: HRRZ E,(C) ;GET DOPE WORD POINTER\r
+ SOJA E,VECMQ1 ;TREAT LIKE VECTOR\r
+\r
+FRMQ: HRRZ E,(C) ; POINT TO PV DOPE WORD\r
+ SOJA E,VECMQ1\r
+\r
+\r
+VECMQ: HLRE 0,E ;GET LENGTH\r
+ SUB E,0 ;POINT TO DOPE WORDS\r
+\r
+VECMQ1: SKIPGE 1(E) ;SKIP IF NOT MARKED\r
+ AOS (P) ;MARKED, CAUSE SKIP RETURN\r
+ POPJ P,\r
+\r
+ASMQ: SUBI E,ASOLNT\r
+ JRST VECMQ1\r
+\r
+LOCMQ: HRRZ 0,(C) ; GET TIME\r
+ JUMPE 0,VECMQ ; GLOBAL, LIKE VECTOR\r
+ HLRE 0,E ; FIND DOPE\r
+ SUB E,0\r
+ MOVEI E,1(E) ; POINT TO LAST DOPE\r
+ CAMN E,TPGROW ; GROWING?\r
+ SOJA E,VECMQ1 ; YES, CHECK\r
+ ADDI E,PDLBUF ; FUDGE\r
+ MOVSI 0,-PDLBUF\r
+ ADDM 0,1(C)\r
+ SOJA E,VECMQ1\r
+\fREPEAT 0,[\r
+\r
+\r
+\r
+;RETIME PHASE -- CALLED IFF A FRAME TIME HAS OVERFLOWED\r
+;RECEIVES POINTER TO STACK TO BE RECALIBRATED IN A\r
+;LEAVES HIGHEST TIME IN TIMOUT\r
+\r
+RETIME: HLRE B,A ;GET LENGTH IN B\r
+ SUB A,B ;COMPUTE DOPE WORD LOCATION\r
+ MOVEI A,1(A) ;POINT TO 2D DOPE WORD AND CLEAR LH\r
+ CAME A,TPGROW ;IS THIS ONE BLOWN?\r
+ ADDI A,PDLBUF ;NO, POINT TO DOPE WORD\r
+ LDB B,[222100,,(A)] ;GET LENGTH FIELD (IGNOREING MARK BIT\r
+ SUBI A,-1(B) ;POINT TO PDLS BASE\r
+ MOVEI C,1 ;INITIALIZE NEW TIMES\r
+\r
+RETIM1: SKIPGE B,(A) ;IF <0, HIT DOPE WORD OR FENCE POST\r
+ JRST RETIM3\r
+ HLRZS B ;ISOLATE TYPE\r
+ CAIE B,TENTRY ;FRAME START?\r
+ AOJA A,RETIM2 ;NO, TRY BINDING\r
+ HRLM C,FRAMLN+OTBSAV(A) ;STORE NEW TIME\r
+ ADDI A,FRAMLN ;POINT TO NEXT ELEMENT\r
+ AOJA C,RETIM1 ;BUMP TIME AND MOVE ON\r
+\r
+RETIM2: CAIE B,TUBIND\r
+ CAIN B,TBIND ;BINDING?\r
+ HRRM C,3(A) ;YES, STORE CURRENT TIME\r
+ AOJA A,RETIM1 ;AND GO ON\r
+\r
+RETIM3: MOVEM C,TIMOUT ;SAVE TIME\r
+ POPJ P, ;RETURN\r
+\r
+\r
+]\r
+\r
+\f; Core adjustment phase, try to win in all obscure cases!\r
+\r
+CORADJ: MOVE A,P.TOP ; update AGCs core top\r
+ MOVEM A,CORTOP\r
+ MOVE A,PARBOT ; figure out all the core needed\r
+ ADD A,PARNEW\r
+ ADD A,PARNUM\r
+ ADD A,PARNUM\r
+ ADD A,VECNUM\r
+ ADDI A,3777 ; account for gc pdl and round to block\r
+ ANDCMI A,1777\r
+\r
+CORAD3: CAMG A,PURTOP ; any way of winning at all?\r
+ JRST CORAD1 ; yes, go try\r
+CORA33: SETOM GCDNTG ; no, can't even grow something\r
+ SETOM GCDANG ; or get current request\r
+ SKIPL C,PARNEW ; or move pairs up\r
+ SETZM PARNEW\r
+ MOVEM C,SPARNW ; save attempt in case of retry\r
+\r
+CORAD6: MOVE A,CORTOP ; update core gotton with needed\r
+ ASH A,-10. ; to blocks\r
+ PUSHJ P,P.CORE ; try to get it (any lossage will retry)\r
+ PUSHJ P,SLPM1\r
+CORA11: MOVE A,CORTOP ; compute new home for vectors\r
+ SUB A,VECTOP\r
+ SUBI A,2000 ; remember gc pdl\r
+ MOVEM A,VECNEW\r
+ POPJ P, ; return to main GC loop\r
+\r
+; Here if at least enough for growers\r
+\r
+CORAD1: SKIPN B,GCDOWN ; skip if were called to get pure space\r
+ JRST CORAD2\r
+ ADDI A,2000(B) ; A/ enough for move down and minimum free\r
+ CAMG A,PURTOP ; any chance of winning?\r
+ JRST CORAD4 ; yes, go win some\r
+\r
+; Here if cant move down\r
+\r
+ SETOM GCDANG ; complain upon return\r
+ SUBI A,2000(B) ; reset for re-entry into loop\r
+ CAMLE A,PURTOP ; win?\r
+ JRST CORA33\r
+\r
+; Here if may be able to grant current request\r
+\r
+CORAD2: ADD A,GETNUM ; A/ total neede including request\r
+ ADD A,CURPLN ; dont give self away or something\r
+ ADDI A,3777 ; at least one free block and round\r
+ ANDCMI A,1777 ; to block boundary\r
+ CAMG A,PURTOP ; any hope of this?\r
+ JRST CORAD5 ; yes, now see if some slop space can appear\r
+\r
+ SETOM GCDANG ; tell caller we lost\r
+ MOVE A,PURTOP ; try to get as much as possible anyway\r
+ SUB A,PURBOT\r
+ SUB A,CURPLN\r
+CORAD8: ASH A,-10. ; to pages\r
+ PUSHJ P,GETPAG\r
+ FATAL PAGES NOT AVAILABLE\r
+ MOVSI D,400000 ; wipes out D\r
+ MOVE A,PURBOT ; and use current PURBOT as new core top\r
+ SUBI A,2000 ; for gc pdl\r
+ MOVEM A,CORTOP\r
+ JRST CORAD6 ; and allocate necessary pages\r
+\r
+; Here if real necessities taken care of, try for slop space\r
+\r
+CORAD5: ADD A,FREMIN ; try for minimum\r
+ SUBI A,2000-1777 ; round and flush min 2000 of before\r
+ ANDCMI A,1777 ; round to block boundary\r
+ CAMG A,PURTOP ; again, do we win?\r
+ JRST CORAD7 ; yes, we win totally\r
+\r
+; Here if cant get desired free but get some\r
+\r
+ MOVE A,PURTOP ; compute pages to flush\r
+ SUB A,CURPLN ; again dont flush current prog\r
+ SUB A,PURBOT ; A/ words to get\r
+ JRST CORAD8 ; go do it\r
+\r
+; Here if can get all the free we want\r
+\r
+CORAD7: SUB A,CURPLN\r
+ CAMG A,PURBOT ; do any pages get the ax?\r
+ JRST CORAD9 ; no, see if can give core back!\r
+ SUB A,PURBOT ; words to get purely\r
+ JRST CORAD8\r
+\r
+CORAD9: CAMG A,CORTOP ; skip if must get core\r
+ JRST CORA10\r
+ MOVEM A,CORTOP\r
+ JRST CORAD6 ; and go get it\r
+\r
+; Here if still may have to give it back\r
+\r
+CORA10: MOVE B,CORTOP\r
+ SUB B,A\r
+ CAMG B,FREDIF ; skip if giving awy\r
+ JRST CORA11\r
+\r
+CORA12: MOVEM A,CORTOP\r
+ ASH A,-10.\r
+ MOVEM A,CORSET ; leave to shrink later\r
+ JRST CORA11\r
+\r
+; Here if going down to also get free space\r
+\r
+CORAD4: SUBI A,2000 ; uncompensate for min\r
+ ADD A,FREMIN\r
+ CAML A,CORTOP ; skip if ok for max\r
+ MOVE A,CORTOP ; else use up to pure\r
+ SUB A,GCDOWN ; new CORTOP to A\r
+ JRST CORA12 ; go set up final shrink\r
+\r
+; routine to wait for core\r
+\r
+SLPM1: MOVEI 0,1\r
+ .SLEEP 0,\r
+ SOS (P)\r
+ SOS (P) ; ret to prev ins\r
+ POPJ P,\r
+\r
+CORADL: PUSHJ P,P.CORE ;SET TO NEW CORE VALUE\r
+ FATAL AGC--CANT CORE DOWN\r
+ POPJ P,\r
+\f;VECTOR RELOCATE --GETS VECTOP IN A\r
+;AND VECNEW IN B\r
+;FILLS IN RELOCATION FIELDS OF MARKED VECTORS\r
+;AND REUTRNS FINAL VECNEW IN B\r
+\r
+VECREL: CAMG A,VECBOT ;PROCESSED TO BOTTOM OF VECTOR SPACE?\r
+ POPJ P, ;YES, RETURN\r
+ HLRE C,(A) ;GET COUNT FROM DOPE WD, EXTEND MARK BIT\r
+ JUMPL C,VECRE1 ;IF MARKED GO PROCESS\r
+ HRRM A,(A) ; INDICATE NON-MOVE BY LEAVING SAME\r
+ SUBI A,(C) ;MOVE ON TO NEXT VECTOR\r
+ SOJG C,VECREL ;AND KEEP SCANNING\r
+ JSP D,VCMLOS ;LOSER, LEAVE TRACKS AS TO WHO LOST\r
+\r
+VECRE1: HRRZ E,-1(A) ;GOBBLE THE GROWTH FILEDS\r
+ HRRM B,(A) ;STORE RELOCATION\r
+ JUMPE E,VECRE2 ;NO GROWTH (OR SHRINKAGE), GO AWAY\r
+ LDB F,[111100,,E] ;GET TOP GROWTH IN F\r
+ TRZN F,400 ;CHECK AND FLUSH SIGN\r
+ MOVNS F ;WAS ON, NEGATE\r
+ SKIPE GCDNTG ; SKIP IF GROWTH OK\r
+ JUMPL F,VECRE3 ; DONT ALLOW POSITIVE GROWTH\r
+ ASH F,6 ;CONVERT TO WORDS\r
+ ADD B,F ;UPDATE RELOCATION\r
+ HRRM B,(A) ;AND STORE IT\r
+VECRE3: ANDI E,777 ;ISOLATE BOTTOM GROWTH\r
+ TRZN E,400 ;CHECK AND CLEAR SIGN\r
+ MOVNS E\r
+ SKIPE GCDNTG ; SKIP IF GROWTH OK\r
+ JUMPL E,VECRE2\r
+ ASH E,6 ;CONVERT TO WORDS\r
+ ADD B,E ;UPDATE FUTURE RELOCATIONS\r
+VECRE2: SUBI A,400000(C) ;AND MOVE ON TO NEXT VECTOR\r
+ ANDI C,377777 ;KILL MARK\r
+ SUBI B,(C) ; UPDATE WHERE TO GO LOCN\r
+ SOJG C,VECREL ;AND KEEP GOING\r
+ JSP D,VCMLOS ;LOSES, LEAVE TRACKS\r
+\r
+;PAIR SPACE UPDATE\r
+\r
+;GETS PARBOT IN AC A\r
+;UPDATES VALUES AND CDRS UP TO PARTOP\r
+\r
+PARUPD: CAML A,PARTOP ;ARE THERE MORE PAIRS TO PROCESS\r
+ POPJ P, ;NO -- RETURN\r
+\r
+;UPDATE VALUE CELL\r
+PARUP1: ANDCAM D,(A) ; KILL MARK BIT\r
+ HLRZ B,(A) ;SET RH OF B TO TYPE\r
+ MOVE C,1(A) ;SET C TO VALUE\r
+ PUSHJ P,VALUPD ;UPDATE THIS VALUE\r
+ ADDI A,2 ;MOVE ON TO NEXT PAIR\r
+ JRST PARUPD ;AND CONTINUE\r
+\r
+\r
+\f;VECTOR SPACE UPDATE\r
+;GETS VECTOP IN A\r
+;UPDATES ALL VALUE CELLS IN MARKED VECTORS\r
+;ESCAPES WHEN IT GETS TO VECBOT\r
+\r
+VECUPD: SUBI A,1 ;MAKE A POINT TO LAST DOPE WD\r
+ PUSH P,VECBOT\r
+ PUSHJ P,UPD1\r
+ SUB P,[1,,1]\r
+ POPJ P,\r
+\r
+; STORAGE SPACE UPDATE\r
+\r
+STOUP: PUSH P,[STOSTR]\r
+ PUSHJ P,UPD1\r
+ SUB P,[1,,1]\r
+ JRST ENHACK\r
+UPD1:\r
+VECUP1: CAMG A,-1(P) ;ANY MORE VECTORS TO PROCESS?\r
+ POPJ P,\r
+ SKIPGE B,(A) ;IS DOPE WORD MARKED?\r
+ JRST VECUP2 ;YES -- GO PROCESS VALUES IN THIS VECTOR\r
+ HLLZS -1(A) ;MAKE SURE NO GROWTH ATTEMPTS\r
+ HLRZS B ;NO -- SET RH OF B TO SIZE OF VECTOR\r
+VECUP5: SUB A,B ;SET A TO POINT TO DOPE WD OF NEXT VECTOR\r
+ JRST VECUP1 ;AND CONTINUE\r
+\r
+VECUP2: PUSH P,A ;SAVE DOPE WORD POINTER\r
+ HLRZ B,(A) ;GET LENGTH OF THIS VECTOR\r
+VECU11: ANDI B,377777 ;TURN OFF MARK BIT\r
+ SKIPGE E,-1(A) ;CHECK FOR UNIFORM OR SPECIAL\r
+ TLNE E,377777 ;SKIP IF GENERAL\r
+ JRST VECUP6 ;UNIFORM OR SPECIAL, GO DO IT\r
+VECU10: SUB A,B ;SET AC A TO NEXT DOPE WORD\r
+ ADDI A,1 ;AND ADVANCE TO FIRST ELEMENT OF THIS VECTOR\r
+VECUP3: HLRZ B,(A) ;GET TYPE\r
+ TRNE B,400000 ;IF MARK BIT SET\r
+ JRST VECUP4 ;DONE WITH THIS VECTOR\r
+ ANDI B,TYPMSK\r
+ CAIE B,TCBLK\r
+ CAIN B,TENTRY ;SPECIAL HACK FOR ENTRY\r
+ JRST ENTRUP\r
+ CAIE B,TUNWIN\r
+ CAIN B,TSKIP ; SKIP POINTER\r
+ JRST BINDUP ; HACK APPROPRAITELY\r
+ CAIE B,TBVL ;VECTOR BINDING?\r
+ CAIN B,TBIND ;AND BINDING BLOCK\r
+ JRST BINDUP\r
+ CAIN B,TUBIND\r
+ JRST BINDUP\r
+VECU15: MOVE C,1(A) ;GET VALUE\r
+ PUSHJ P,VALUPD ;UPDATE THIS VALUE\r
+VECU12: ADDI A,2 ;GO ON TO NEXT VECTOR\r
+ JRST VECUP3 ;AND CONTINUE\r
+\r
+VECUP4: POP P,A ;SET TO OLD DOPE WORD\r
+ ANDCAM D,(A) ;TURN OFF MARK BIT\r
+ HLRZ B,(A) ;GET LENGTH\r
+ ANDI B,377777 ; IN CASE DING STORAGE\r
+ JRST VECUP5 ;GO ON TO NEXT VECTOR\r
+\r
+\r
+\r
+;UPDATE A SAVED SAVE BLOCK\r
+ENTSUP: MOVEI A,FRAMLN+SPSAV-1(A) ;A POINTS BEFORE SAVED SP\r
+ MOVEI B,TSP\r
+ PUSHJ P,VALPD1 ;UPDATE SPSAV\r
+ MOVEI A,PSAV-SPSAV(A)\r
+ MOVEI B,TPDL\r
+ PUSHJ P,VALPD1 ;UPDATE PSAV\r
+ MOVEI A,TPSAV-PSAV(A)\r
+ MOVEI B,TTP\r
+ PUSHJ P,VALPD1 ;UPDATE TPSAV\r
+;SKIP TO END OF BLOCK\r
+ SUBI A,PSAV-1\r
+ JRST VECUP3\r
+\r
+;IGNORE A BLOCK\r
+IGBLK2: HRRZ B,(A) ;GET DISPLACEMENT\r
+ ADDI A,3(B) ;USE IT\r
+ JRST VECUP3 ;GO\r
+\r
+\f; ENTRY PART OF THE STACK UPDATER\r
+\r
+ENTRUP: ADDI A,FRAMLN-2 ;POINT PAST FRAME\r
+ JRST VECU12 ;NOW REJOIN VECTOR UPDATE\r
+\r
+; UPDATE A BINDING BLOCK\r
+\r
+BINDUP: HRRZ C,(A) ;POINT TO CHAIN\r
+ JUMPE C,NONEXT ;JUMP IF NO NEXT BINDING IN CHAIN\r
+ HRRZ 0,@(P) ; GET OWN DESTINATION\r
+ SUBI 0,@(P) ; RELATIVIZE\r
+ ADD C,0 ; AND UPDATE\r
+ HRRM C,(A) ;AND STORE IT BACK\r
+NONEXT: CAIN B,TUBIND\r
+ JRST .+3\r
+ CAIE B,TBIND ;SKIP IF VAR BINDING\r
+ JRST VECU14 ;NO, MUST BE A VECTOR BIND\r
+ MOVEI B,TATOM ;UPDATE ATOM POINTER\r
+ PUSHJ P,VALPD1\r
+ ADDI A,2\r
+ HLRZ B,(A) ;TYPE OF VALUE\r
+ PUSHJ P,VALPD1\r
+ ADDI A,2 ; POINT TO PREV LOCATIVE\r
+VECU16: MOVEI B,TLOCI\r
+ SKIPN 1(A) ; IF NO LOCATIVE,\r
+ MOVEI B,TUNBOU ; SAY UNBOUND\r
+ PUSHJ P,VALPD1\r
+ JRST VECU12\r
+\r
+VECU14: CAIN B,TBVL ; CHANGE BVL TO VEC\r
+ MOVEI B,TVEC ;NOW TREAT LIKE A VECTOR\r
+ JRST VECU15\r
+\r
+; NOW SAFE TO UPDATE ALL ENTRY BLOCKS\r
+\r
+ENHACK: HRRZ F,TBSTO(LPVP) ;GET POINTER TO TOP FRAME\r
+ HLLZS TBSTO(LPVP) ;CLEAR FIELD\r
+ HLLZS TPSTO(LPVP)\r
+ JUMPE F,LSTFRM ;FINISHED\r
+\r
+ENHCK1: MOVEI A,FSAV-1(F) ;POINT PRIOR TO SAVED FUNCTION\r
+ HRRZ C,1(A) ; GET POINTER TO FCN\r
+ CAML C,VECBOT ; SKIP IF A LOSER\r
+ CAMLE C,VECTOP ; SKIP IF A WINNER\r
+ JRST ENHCK2\r
+ HRL C,(C) ; MAKE INTO AOBJN\r
+ MOVEI B,TVEC\r
+ PUSHJ P,VALUPD ; AND UPDATE\r
+ENHCK2: HRRZ F,2(A) ;POINT TO PRIOR FRAME\r
+ MOVEI B,TTB ;MARK SAVED TB\r
+ PUSHJ P,[AOJA A,VALPD1]\r
+ MOVEI B,TAB ;MARK ARG POINTER\r
+ PUSHJ P,[AOJA A,VALPD1]\r
+ MOVEI B,TSP ;SAVED SP\r
+ PUSHJ P,[AOJA A,VALPD1]\r
+ MOVEI B,TPDL ;SAVED P STACK\r
+ PUSHJ P,[AOJA A,VALPD1]\r
+ MOVEI B,TTP ;SAVED TP\r
+ PUSHJ P,[AOJA A,VALPD1]\r
+ JUMPN F,ENHCK1 ;MARK NEXT ONE IF IT EXISTS\r
+\r
+LSTFRM: HRRZ A,BINDID(LPVP) ;NEXT PROCESS\r
+ HLLZS BINDID(LPVP) ;CLOBBER\r
+ MOVEI LPVP,(A)\r
+ JUMPN LPVP,ENHACK ;DO NEXT PROCESS\r
+ POPJ P,\r
+\r
+\f; UPDATE ELEMENTS IN UNIFROM AND SPECIAL VECTORS\r
+\r
+VECUP6: JUMPL E,VECUP7 ;JUMP IF SPECIAL\r
+ CAIG B,2 ;EMPTY UVECTOR ?\r
+ JRST VECUP4 ;YES, NOTHING TO UPDATE\r
+ HLRZS E ;ISOLATE TYPE\r
+ ANDI E,37777\r
+ EXCH E,B ;TYPE TO B AND LENGTH TO E\r
+ SUBI A,(E) ;POINT TO NEXT DOPE WORD\r
+ LSH B,1 ;FIND SAT\r
+ HRRZ B,@TYPNT\r
+ ANDI B,SATMSK\r
+ MOVE B,UPDTBS(B) ;FIND WHERE POINTS\r
+ CAIN B,CPOPJ ;UNMARKED?\r
+ JRST VECUP4 ;YES, GO ON TO NEXT VECTOR\r
+ PUSH P,B ;SAVE SR POINTER\r
+ SUBI E,2 ;DON'T COUNT DOPE WORDS\r
+\r
+VECUP8: MOVE C,1(A) ;GET GOODIE\r
+ MOVEI 0,(C) ; ISOLATE ADDR\r
+ JUMPE 0,.+3 ; NEVER 0 PNTR\r
+ CAIGE 0,@PURBOT ; OR IF PURE\r
+ PUSHJ P,@(P) ;CALL UPDATE ROUTINE\r
+ ADDI A,1\r
+ SOJG E,VECUP8 ;LOOP FOR ALL ELEMNTS\r
+\r
+ SUB P,[1,,1] ;REMOVE RANDOMNESS\r
+ JRST VECUP4\r
+\r
+; SPECIAL VECTOR UPDATE\r
+\r
+VECUP7: HLRZS E ;ISOLATE SPECIAL TYPE\r
+ CAIN E,SATOM+400000 ;ATOM?\r
+ JRST ATOMUP ;YES, GO DO IT\r
+ CAIN E,STPSTK+400000 ;STACK\r
+ JRST VECU10 ;TREAT LIKE A VECTOR\r
+ CAIN E,SPVP+400000 ;PROCESS VECTOR\r
+ JRST PVPUP ;DO SPECIAL STUFF\r
+ CAIN E,SASOC+400000\r
+ JRST ASOUP ;UPDATE ASSOCIATION BLOCK\r
+\r
+ TRZ E,400000 ; CHECK FOR TEMPLATE VECTOR\r
+ CAIG E,NUMSAT ; SKIP IF POSSIBLE\r
+ FATAL AGC--UNRECOGNIZED SPECIAL VECTOR (UPDATE)\r
+ MOVEI E,-NUMSAT-1(E)\r
+ HRLI E,(E)\r
+ ADD E,TD.LNT+1(TVP)\r
+ SKIPL E\r
+ FATAL AGC--BAD TEMPLATE TYPE\r
+\r
+TD.UPD: MOVEI C,-1(A) ; POINTER TO OBJECT IN C\r
+ XCT (E)\r
+ HLRZ D,B ; POSSIBLE BASIC LENGTH\r
+ PUSH P,[0]\r
+ PUSH P,D\r
+ MOVEI B,(B) ; ISOLATE LENGTH\r
+ PUSH P,C ; SAVE POINTER TO OBJECT\r
+\r
+ PUSH P,[0] ; HOME FOR VALUES\r
+ PUSH P,[0] ; SLOT FOR TEMP\r
+ PUSH P,B ; SAVE\r
+ SUB E,TD.LNT+1(TVP)\r
+ PUSH P,E ; SAVE FOR FINDING OTHER TABLES\r
+ JUMPE D,TD.UP2 ; NO REPEATING SEQ\r
+ ADD E,TD.GET+1(TVP) ; COMP LNTH OF REPEATING SEQ\r
+ HLRE E,(E) ; E ==> - LNTH OF TEMPLATE\r
+ ADDI E,(D) ; E ==> -LENGTH OF REP SEQ\r
+ MOVNS E\r
+ HRLM E,-5(P) ; SAVE IT AND BASIC\r
+\r
+TD.UP2: SKIPG D,-1(P) ; ANY LEFT?\r
+ JRST TD.UP1\r
+\r
+ MOVE E,TD.GET+1(TVP)\r
+ ADD E,(P)\r
+ MOVE E,(E) ; POINTER TO VECTOR IN E\r
+ MOVEM D,-6(P) ; SAVE ELMENT #\r
+ SKIPN B,-5(P) ; SKIP IF "RESTS" EXIST\r
+ SOJA D,TD.UP3\r
+\r
+ MOVEI 0,(B) ; BASIC LNT TO 0\r
+ SUBI 0,(D) ; SEE IF PAST BASIC\r
+ JUMPGE 0,.-3 ; JUMP IF O.K.\r
+ MOVSS B ; REP LNT TO RH, BASIC TO LH\r
+ IDIVI 0,(B) ; A==> -WHICH REPEATER\r
+ MOVNS A\r
+ ADD A,-5(P) ; PLUS BASIC\r
+ ADDI A,1 ; AND FUDGE\r
+ MOVEM A,-6(P) ; SAVE FOR PUTTER\r
+ ADDI E,-1(A) ; POINT\r
+ SOJA D,.+2\r
+\r
+TD.UP3: ADDI E,(D) ; POINT TO SLOT\r
+ XCT (E) ; GET THIS ELEMENT INTO A AND B\r
+ MOVEM A,-3(P) ; SAVE TYPE FOR LATER PUT\r
+ MOVEM B,-2(P)\r
+ MOVE C,B ; VALUE TO C FOR VALUPD\r
+ GETYP B,A\r
+ MOVEI A,-3(P) ; TELL OTHER GUYS THEY CANT DIRECTLY MUNG\r
+ MOVSI D,400000 ; RESET FOR MARK\r
+ PUSHJ P,VALUPD ; AND MARK THIS GUY (RET FIXED POINTER IN A)\r
+ MOVE C,-4(P) ; GET POINTER FOR UPDATE OF ELEMENT\r
+ MOVE E,TD.PUT+1(TVP)\r
+ SOS D,-1(P) ; RESTORE COUNT\r
+ ADD E,(P)\r
+ MOVE E,(E) ; POINTER TO VECTOR IN E\r
+ MOVE B,-6(P) ; SAVED OFFSET\r
+ ADDI E,(B)-1 ; POINT TO SLOT\r
+ MOVE A,-3(P) ; RESTORE TYPE WORD\r
+ MOVE B,-2(P)\r
+ XCT (E) ; SMASH IT BACK\r
+ FATAL TEMPLATE LOSSAGE\r
+ MOVE C,-4(P)\r
+ JRST TD.UP2\r
+\r
+TD.UP1: SUB P,[7,,7]\r
+ MOVSI D,400000 ; RESTORE MARK/UNMARK BIT\r
+ JRST VECUP4\r
+\r
+\f; UPDATE ATOM VALUE CELLS\r
+\r
+ATOMUP: SUBI A,-1(B) ; POINT TO VALUE CELL\r
+ HLRZ B,(A)\r
+ HRRZ 0,(A) ;GOBBLE BINDID\r
+ JUMPN 0,.+3 ;NOT GLOBAL\r
+ CAIN B,TLOCI ;IS IT A LOCATIVE?\r
+ MOVEI B,TVEC ;MARK AS A VECTOR\r
+ HRRZ 0,1(A) ; GET POINTER\r
+ CAML 0,VECBOT\r
+ CAMLE 0,VECTOP\r
+ JRST .+2 ; OUT OF BOUNDS, DONT UPDATE\r
+ PUSHJ P,VALPD1 ;UPDATE IT\r
+ MOVEI B,TOBLS ; TYPE TO OBLIST\r
+ SKIPGE 2(A)\r
+ PUSHJ P,[AOJA A,VALPD1]\r
+ JRST VECUP4\r
+\r
+; UPDATE PROCESS VECTOR\r
+\r
+PVPUP: SUBI A,-1(B) ;POINT TO TOP\r
+ HRRM LPVP,BINDID(A) ;CHAIN ALL PROCESSES TOGETHER\r
+ MOVEI LPVP,(A)\r
+ HRRZ 0,TBSTO+1(A) ;POINT TO CURRENT FRAME\r
+ HRRM 0,TBSTO(A) ;SAVE\r
+ HRRZ 0,TPSTO+1(A) ;0_SAVED TP POINTER\r
+ HLRE B,TPSTO+1(A)\r
+ SUBI 0,-1(B) ;0 _ POINTER TO OLD DOPE WORD\r
+ HRRM 0,TPSTO(A)\r
+ JRST VECUP3\r
+\r
+\r
+\f;THIS SUBROUTINE TAKES CARE OF UPDATING ASSOCIATION BLOCKS\r
+\r
+ASOUP: SUBI A,-1(B) ;POINT TO START OF BLOCK\r
+ HRRZ B,ASOLNT-1(A) ;POINT TO NEXT\r
+ JUMPE B,ASOUP1\r
+ HRRZ C,ASOLNT+1(B) ;AND GET ITS RELOC IN C\r
+ SUBI C,ASOLNT+1(B) ; RELATIVIZE\r
+ ADDM C,ASOLNT-1(A) ;C NOW HAS UPDATED PONTER\r
+ASOUP1: HLRZ B,ASOLNT-1(A) ;GET PREV BLOCK POINTER\r
+ JUMPE B,ASOUP2\r
+ HRRZ F,ASOLNT+1(B) ;AND ITS RELOCATION\r
+ SUBI F,ASOLNT+1(B) ; RELATIVIZE\r
+ MOVSI F,(F)\r
+ ADDM F,ASOLNT-1(A) ;RELOCATE\r
+ASOUP2: HRRZ B,NODPNT(A) ;UPDATE NODE CHAIN\r
+ JUMPE B,ASOUP4\r
+ HRRZ C,ASOLNT+1(B) ;GET RELOC\r
+ SUBI C,ASOLNT+1(B) ; RELATIVIZE\r
+ ADDM C,NODPNT(A) ;ANID UPDATE\r
+ASOUP4: HLRZ B,NODPNT(A) ;GET PREV POINTER\r
+ JUMPE B,ASOUP5\r
+ HRRZ F,ASOLNT+1(B) ;RELOC\r
+ SUBI F,ASOLNT+1(B)\r
+ MOVSI F,(F)\r
+ ADDM F,NODPNT(A)\r
+ASOUP5: HRLI A,-3 ;SET TO UPDATE OTHER CONTENTS\r
+\r
+ASOUP3: HLRZ B,(A) ;GET TYPE\r
+ PUSHJ P,VALPD1 ;UPDATE\r
+ ADD A,[1,,2] ;MOVE POINTER\r
+ JUMPL A,ASOUP3\r
+ JRST VECUP4 ;AND QUIT\r
+\r
+\f;VALUPD UPDATES A SINLE VALUE FROM EITHER PAIR SPACE OR VECTOR SPACE\r
+;GETS POINTER TO TYPE CELL IN RH OF A\r
+;TYPE IN RH OF B (LH MUST BE 0)\r
+;VALUE IN C\r
+\r
+VALPD1: MOVE C,1(A) ;GET VALUE TO UPDATE\r
+VALUPD: MOVEI 0,(C)\r
+ CAIGE 0,@PURBOT ; SKIP IF PURE, I.E. DONT HACK\r
+ TRNN C,-1 ;ANY POINTER PART?\r
+ JRST CPOPJ ;NO, LEAVE\r
+ ANDI B,TYPMSK\r
+ LSH B,1 ;SET TYPE TIMES 2\r
+ HRRZ B,@TYPNT ;GET STORAGE ALLOCATION TYPE\r
+ ANDI B,SATMSK\r
+ CAIG B,NUMSAT ; SKIP IF TEMPLATE\r
+ JRST @UPDTBS(B) ;AND DISPATCH THROUGH STORAGE ALLOCATION DISPATCH TABLE\r
+ AOJA C,TMPLUP\r
+\r
+;SAT DISPATCH TABLE\r
+\r
+DISTBS UPDTBS,CPOPJ,[[SNWORD,NWRDUP],[STPSTK,STCKUP]\r
+[SFRAME,FRAMUP],[STBASE,TBUP],[SARGS,ARGUP],[SBYTE,BYTUP],[SATOM,NWRDUP],[SPSTK,STCKUP]\r
+[SLOCID,LOCUP],[SPVP,NWRDUP],[S2NWORD,NWRDUP],[SABASE,ABUP],[SCHSTR,BYTUP],[SASOC,ASUP]\r
+[SLOCA,ARGUP],[SLOCU,NWRDUP],[SLOCN,ASUP],[SLOCS,BYTUP],[SGATOM,NWRDUP]]\r
+\r
+\r
+\r
+\r
+;PAIR POINTER UPDATE\r
+2WDUP: MOVEI 0,(C)\r
+ CAIGE 0,@PURBOT ; SKIP AND IGNORE IF PURE\r
+ TRNN C,-1 ;POINT TO NIL?\r
+ POPJ P, ;YES -- NO UPDATE NEEDED\r
+ SKIPGE B,(C) ;NO -- IS THIS A BROKEN HEART\r
+ HRRM B,1(A) ;YESS -- STORE NEW VALUE\r
+ SKIPE B,PARNEW ;IF LIST SPACE IS MOVING\r
+ ADDM B,1(A) ;THEN ADD OFFSET TO VALUE\r
+ POPJ P, ;FINISHED\r
+\r
+; HERE TO UPDATE ASSOCIATIONS\r
+\r
+ASUP: HRLI C,-ASOLNT ;MAKE INTO VECTOR POINTER\r
+ JRST NWRDUP\r
+\f;VECTOR, ATOM, STACK, AND BASE POINTER UPDATE\r
+\r
+LOCUP: HRRZ B,(A) ;CHECK IF IT IS TIMED\r
+ JUMPN B,LOCUP1 ;JUMP IF TIMED, OTHERWISE TREAT LIKE VECTORE\r
+\r
+NWRDUP: HLRE B,C ;EXTEND COUNT IN B\r
+ SUBI C,-1(B) ;SET C TO POINT TO DOPE WORD\r
+TMPLUP: HRRZ B,(C) ;EXTEND RELOCATION IN B\r
+ SUBI B,(C) ; RELATIVIZE\r
+ ADDM B,1(A) ;AND ADD RELOCATION TO STORED DATUM\r
+ HRRZ C,-1(C) ;GET GROWTH SPECS\r
+ JUMPE C,CPOPJ ;NO GROWTH, LEAVE\r
+ LDB C,[111100,,C] ;GET UPWORD GROWTH\r
+ TRZN C,400 ;FLUSH SIGN AN NEGATR DIRECTION\r
+ MOVNS C\r
+ SKIPE GCDNTG ; SKIP IF GROWTH WINS\r
+ JUMPL C,CPOPJ ; POS GROWTH, LOSE\r
+ ASH C,6+18. ;TO LH AND TIMES 100(8)\r
+ ADDM C,1(A) ;UPDATE POINTER\r
+ POPJ P,\r
+\r
+\r
+LOCUP1:\r
+STCKUP: MOVSI B,PDLBUF ;GET OFFSET FOR PDLS\r
+ ADDM B,1(A) ;AND ADD TO COUNT\r
+ JRST NWRDUP ;NOW TREAT LIKE VECTOR\r
+\r
+BYTUP: MOVEI C,(A) ; SET TO GET DOPE WORD\r
+ PUSH P,A\r
+ PUSHJ P,BYTDOP\r
+ POP P,C\r
+ HRRZ B,(A) ;SET B TO RELOCATION FOR THIS VEC\r
+ SUBI B,(A) ; RELATIVIZE\r
+ ADDM B,1(C) ;AND UPDATE VALUE\r
+ MOVE A,C ; FIX UP FOR SCANNER\r
+ POPJ P, ;DONE WITH UPDATE\r
+\r
+ARGUP:\r
+ABUP: HLRE B,C ;GET LENGTH\r
+ SUB C,B ;POINT TO FRAME\r
+ HLRZ B,(C) ;GET TYPE OF NEXT GOODIE\r
+ ANDI B,TYPMSK\r
+ CAIN B,TINFO ;IS IT A FRAME\r
+ ADD C,1(C) ;NO, POINT TO FRAME\r
+ CAIE B,TINFO ;IF IT IS A FRAME\r
+ ADDI C,FRAMLN ;POINT TO ITS BASE\r
+TBUP: MOVE C,TPSAV(C) ;GET A ASTACK POINTER TO FIND DOPE WORD\r
+ HLRE B,C ;UPDATE BASED ON THIS POINTER\r
+ SUBI C,(B)\r
+ABUP1: HRRZ B,1(C) ;GET RELOCATION\r
+ SUBI B,1(C) ; RELATIVIZE\r
+ ADDM B,1(A) ;AND MUNG POINTER\r
+ POPJ P,\r
+\r
+FRAMUP: HRRZ B,(A) ;UPDATE PVP\r
+ HRRZ C,(B) ;IN CELL\r
+ SUBI C,(B) ; RELATIVIZE\r
+ ADDM C,(A)\r
+ HLRZ C,(B)\r
+ ANDI C,377777\r
+ SUBI B,-1(C) ;ADDRESS OF PV\r
+ HRRZ C,TPSTO(B) ;IF TPSTO HAS OLD TP DOPE WORD,\r
+ JUMPN C,ABUP2 ;USE IT\r
+ HRRZ C,TPSTO+1(B) ;ELSE, GENERATE IT\r
+ HLRE B,TPSTO+1(B)\r
+ SUBI C,-1(B)\r
+ABUP2: SOJA C,ABUP1 ; FUDGE AND GO\r
+\r
+\f;VECTOR SHRINKING PHASE\r
+\r
+VECSH: SUBI A,1 ;POOINT TO 1ST DOPE WORD\r
+VECSH1: CAMGE A,VECBOT ;FINISHED\r
+ POPJ P, ;YES, QUIT\r
+ HRRZ B,-1(A) ;GET A SPEC\r
+ JUMPE B,NXTSHN ;IGNORE IF NONE\r
+ PUSHJ P,GETGRO ;GET THE SPECS\r
+ JUMPGE C,SHRNBT ;SHRINKIGN AT BOTTOM\r
+ MOVEI E,(A) ;COPY POINTER\r
+ ADD A,C ;POINT TO NEW DOPE LOCATION WITH E\r
+ MOVE F,-1(E) ;GET OLD DOPE\r
+ ANDCMI F,777000 ;KILL THIS SPEC\r
+ MOVEM F,-1(A) ;STORE\r
+ MOVE F,(E) ;OTHER DOPE WORD\r
+ ADD F,C ; UPDATE DESTINATION\r
+ HRLZI C,(C) ;TO LH\r
+ ADD F,C ;CHANGE LENGTH\r
+ MOVEM F,(A) ;AND STORE\r
+ MOVMS C ;PLUSIFY\r
+ HRRI C,(E) ; MAKE NOT MOVE\r
+ MOVEM C,(E) ;AND STORE\r
+ SETZM -1(E)\r
+SHRNBT: JUMPGE B,NXTSHN ;GROWTH, IGNOORE\r
+ MOVM E,B ;GET A POSITIVE COPY\r
+ HRLZI B,(B) ;TO LH\r
+ ADDM B,(A) ;ADD INTO DOPE WORD\r
+ MOVEI 0,777 ;SET TO CLOBBER GROWTH\r
+ ANDCAM 0,-1(A) ;CLOBBER\r
+ HLRZ B,(A) ;GET NEW LENGTH\r
+ SUBI A,(B) ;POINT TO LOW END\r
+ HRLI E,(A) ; MAKE NON MOVER\r
+ MOVSM E,(A) ;STORE\r
+ SETZM -1(A)\r
+\r
+NXTSHN: HLRZ B,(A) ;GET LENGTH\r
+ JUMPE B,VCMLOS ;LOOSE\r
+ SUBI A,(B) ;STEP\r
+ JRST VECSH1\r
+\r
+GETGRO: LDB C,[111100,,B] ;GET UPWARD GROWTH\r
+ TRZE C,400 ;CHECK AND MUNG SIGN\r
+ MOVNS C\r
+ ASH C,6 ;?IMES 100\r
+ ANDI B,777 ;AND GET DOWN GROWTH\r
+ TRZE B,400 ;CHECK AND MUNG SIGN\r
+ MOVNS B\r
+ ASH B,6\r
+ POPJ P,\r
+\f;VECMOV -- MOVES VECTOR DATA TO WHERE RELOC FIELDS OF\r
+;VECTORS INDICATE. MOVES DOPEWDS UP FOR VECTORS GROWING AT\r
+;THE END.\r
+;CALLED WITH VECTOP IN A. CALLS PARMOV TO MOVE PAIRS\r
+\r
+VECMOV: SUBI A,1 ;SET A TO ADDR OF TOP DOPE WD\r
+ MOVSI D,400000 ;NEGATIVE D MARKS END OF BACK CHAIN\r
+ MOVEI TYPNT,0 ;CLEAR ON GOING ADDRESS FOR FORWARD RESUME\r
+VECMO1: CAMGE A,VECBOT ;GOT TO BOTTOM OF VECTORS\r
+ JRST PARMOV ;YES, MOVE LIST ELEMENTS AND RETURN\r
+ MOVEI C,(A) ;NO, COPY ADDR OF THIS DOPEWD\r
+ HRRZ B,(A) ;GET RELOCATION OF THIS VECTOR\r
+ SUBI B,(A) ; RELATIVIZE\r
+ JUMPL B,VECMO5 ;IF MOVING DOWNWARD, MAKE BACK CHAIN\r
+ JUMPE B,VECMO4 ;IF NON MOVER, JUST ADJUST DOPW AND MOVE ON\r
+\r
+ ADDI C,(B) ;SET ADDR OF LAST DESTINATION WD\r
+ HRLI B,A ;MAKE B INDEX ON A\r
+ HLL A,(A) ;COUNT TO A LEFT HALF\r
+\r
+ POP A,@B ;MOVE A WORD\r
+ TLNE A,-1 ;REACHED END OF MOVING\r
+ JRST .-2 ;NO, REPEAT\r
+ ;YES, NOTE A HAS ADDR OF NEXT DOPEWD\r
+\f;HERE TO ADJUST LOCATION OF DOPEWDS FOR GROWTH (FORWARDLY)\r
+VECMO2: LDB B,[111000,,-1(C)] ;GET HIGH GROWTH FIELD\r
+ JUMPE B,VECMO3 ;IF NO GROWTH, DONT MOVE\r
+ SKIPE GCDNTG ; SKIP IF GROWTH PERMITTED\r
+ JRST VECMO3\r
+ ASH B,6 ;EXPRESS GROWTH IN WORDS\r
+ HRLI C,2 ;SET COUNT FOR POPPING 2 DOPEWDS\r
+ HRLI B,C ;MAKE B INDEX ON C\r
+ POP C,@B ;MOVE PRIME DOPEWD\r
+ POP C,@B ;MOVE AUX DOPEWD\r
+VECMO3: JUMPL D,VECMO1 ;IF NO BACK CHAIN THEN MOVE ON\r
+ JRST VECMO6 ;YES, BACKCHAINING, CONTINUE SAME\r
+\r
+;HERE TO SKIP OVER STILL VECTORS (FORWARDLY)\r
+VECMO4: HLRZ B,(A) ;GET SIZE OF UNMOVER\r
+ SUBI A,(B) ;UPDATE A TO NEXT VECTOR\r
+ JRST VECMO2 ;AND GO CLEAN UP GROWTH\r
+;HERE TO ESTABLISH A BACKWARDS CHAIN\r
+VECMO5: EXCH D,(A) ;CHAIN FORWARD\r
+ HLRZ B,D ;GET SIZE\r
+ SUBI A,(B) ;GO ON TO NEXT VECOTR\r
+ CAMGE A,VECBOT ;HAVE WE GOT TO END OF VECTORS?\r
+ JRST VECMO7 ;YES, GO MOVE PAIRS AND UNCHAIN\r
+ HRRZ B,(A) ;GET RELOCATION OF THIS VECTOR\r
+ SUBI B,(A) ; RELATIVIZE\r
+ JUMPLE B,VECMO5 ;IF NOT POSITIVE, CONTINUE CHAINING\r
+ MOVEM A,TYPNT ;SAVE ADDR FOR FORWARD RESUME\r
+\r
+;HERE TO UNCHAIN A VECTOR, MOVE IT, AND ADJUST DOPEWDS\r
+VECMO6: HLRZ B,D ;GET SIZE\r
+ MOVEI F,1(A) ;GET A COPY OF BEGINNING OF VECTOR\r
+ ADDI A,(B) ;SET TO POINT TO ADDR OF DOPEWD CURRENTLY IN D\r
+ EXCH D,(A) ;AND UNCHAIN\r
+ HRRZ B,(A) ;GET RELOCATION FOR THIS VECTOR\r
+ SUBI B,(A) ; RELATIVIZE\r
+ MOVEI C,(A) ;COPY A POINTER TO DOPEW\r
+ SKIPGE D ;HAVE WE REACHED THE TOP OF THE CHAIN?\r
+ MOVE A,TYPNT ;YES, RESTORE FORWARD MOVE RESUME ADDR\r
+ JUMPE B,VECMO2 ;IF STILL VECTOR,GO ADJUST DOPEWDS\r
+ ADDI C,(B) ;MAKE C POINT TO NEW DOPEW ADDR\r
+ ADDI B,(F) ;B RH NEW 1ST WORD\r
+ HRLI B,(F) ;B LH OLD 1ST WD ADDR\r
+ BLT B,(C) ;COPY THE DATA\r
+ JRST VECMO2 ;AND GO ADJUST DOPEWDS\r
+\r
+;HERE TO STOP CHAINING BECAUSE OF BOTTOM OF VECTOR SPACE\r
+VECMO7: MOVEM A,TYPNT\r
+ PUSH P,D\r
+ PUSHJ P,PARMOV\r
+ POP P,D\r
+ MOVE A,TYPNT\r
+ JRST VECMO6\r
+\f;PAIR MOVEMENT PHASE -- USES PARNEW,PARBOT, AND PARTOP TO MOVE PAIRS\r
+;TO NEW HOMES\r
+\r
+PARMOV: SKIPN A,PARNEW ;IS THERE ANY PAIR MOVEMENT?\r
+ POPJ P, ;NO, RETURN\r
+ JUMPL A,PARMO2 ;YES -- IF MOVING DOWNWARDS, GO DO A BLT\r
+ HRLI A,B ;MOVING UPWARDS SETAC A TO INDEX OFF AC B\r
+ MOVE B,PARTOP ;GET HIGH PAIR ADDREESS\r
+ SUB B,PARBOT ;AND SUBTRACT BOTTOM TO GET NUMBER OF PAIRS\r
+ HRLZS B ;PUT COUNT IN LEFT HALF\r
+ HRR B,PARTOP ;GET HIGH ADDRESS PLUS ONE IN RH\r
+ SUBI B,1 ;AND SUBTRACT ONE TO POINT TO LAST WORD TO BE MOVED\r
+\r
+PARMO1: TLNN B,-1 ;HAS COUNT REACHED ZERO?\r
+ JRST PARMO3 ;YES -- FINISH UP\r
+ POP B,@A ;NO -- TRANSFER2Y\eU NEXT WORD\r
+ JRST PARMO1 ;AND REPEAT\r
+\r
+PARMO2: MOVE B,PARBOT ;GET ADDRESS OF FIRST SOURCE WD\r
+ HRLS B ;IN BOTH HALVES OF AC B\r
+ ADD B,A ;MAKE RH OF B POINT TO FIRST DESTINATION WORD\r
+ ADD A,PARTOP ;MAKE RH OF A POINT TO LAST DESTINATION WORD PLUS ONE\r
+ BLT B,-1(A) ;AND TRANSFER THE BLOCK OF PAIRS\r
+\r
+PARMO3: MOVE A,PARNEW ;GET OFFSET FOR PAIR SPACE\r
+ ADDM A,PARBOT ;AND CORRECT BOTTOM\r
+ ADDM A,PARTOP ;AND CORRECT TOP.\r
+ SETZM PARNEW ;CLEAR SO IF CALLED TWICE, NO LOSSAGE\r
+ POPJ P,\r
+\f;VECZER -- CLEARS DATA IN AREAS JUST GROWN\r
+;UPDATES SIZE OF VECTORS\r
+;CLEARS RELOCATION AND GROWTH FIELDS IN DOPEWDS\r
+;CALLED WITH NEW VECTOP IN A (VECBOT SHOULD BE NEW TOO)\r
+\r
+VECZER: SUBI A,1 ;MAKE A POINT TO HIGH VECTORS\r
+VECZE1: CAMGE A,VECBOT ;REACHED BOTTOM OF VECTORS?\r
+ POPJ P, ;YES, RETURN\r
+ HLLZS F,(A) ;NO, CLEAR RELOCATION GET SIZE\r
+ HLRZS F ;AND PUT SIZE IN RH OF F\r
+ HRRZ B,-1(A) ;GET GROWTH INTO B\r
+ JUMPN B,VECZE3 ;IF THERE IS SOME GROWTH, GO DO IT\r
+VECZE2: SUBI A,(F) ;GROWTH DONE, MOVE ON TO NEXT VECTOR\r
+ JRST VECZE1 ;AND REPEAT\r
+\r
+VECZE3: HLLZS -1(A) ;CLEAR GROWTH IN THE VECTOR\r
+ LDB C,[111000,,B] ;GET HIGH ORDER GROWTH IN C\r
+ SKIPE GCDNTG\r
+ JRST VECZE5\r
+ ANDI B,377 ;AND LIMIT B TO LOW SIDE\r
+ ASHC B,6 ;EXPRESS GROWTH IN WORDS\r
+ JUMPE C,VECZE4 ;IF NO HIGH GROWTH SKIP TO LOW GROWTH\r
+ ADDI F,(C) ;ADD HIGH GROWTH TO SIZE\r
+ SUBM A,C ;GET ADDR OF 2ND WD TO BE ZEROED\r
+ SETZM -1(C) ;CLEAR 1ST WORD\r
+ HRLI C,-1(C) ;MAKE C A CLEARING BLT POINTER\r
+ BLT C,-2(A) ;AND CLEAR HIGH END DATA\r
+\r
+VECZE4: JUMPE B,VECZE5 ;IF NO LOW GROWTH SKIP TO SIZE UPDATE\r
+ MOVNI C,(F) ;GET NEGATIVE SIZE SO FAR\r
+ ADDI C,(A) ;AND MAKE C POINT TO LAST WORD OF STUFF TO BE CLEARED\r
+ ADDI F,(B) ;UPDATE SIZE\r
+ SUBM C,B ;MAKE B POINT TO LAST WD OF NEXT VECT\r
+ ADDI B,2 ;AND NOW TO 2ND DATA WD TO BE CLEARED\r
+ SETZM -1(B) ;CLEAR 1ST DATA WD\r
+ HRLI B,-1(B) ;MAKE B A CLEARING BLT POINTER\r
+ BLT B,(C) ;AND CLEAR THE LOW DATA\r
+\r
+VECZE5: HRLZM F,(A) ;STORE THE NEW SIZE IN DOPEWD\r
+ JRST VECZE2\r
+\r
+\f;SUBROUTINE TO REBUILD THE NOW DEFUNCT HASH TABLE\r
+\r
+REHASH: MOVE TVP,TVPSTO+1(PVP) ;RESTORE TV POINTER\r
+ MOVE D,ASOVEC+1(TVP) ;GET POINTER TO VECTOR\r
+ MOVEI E,(D)\r
+ PUSH P,E ;PUSH A POINTER\r
+ HLRE A,D ;GET -LENGTH\r
+ MOVMS A ;AND PLUSIFY\r
+ PUSH P,A ;PUSH IT ALSO\r
+\r
+REH3: HRRZ C,(D) ;POINT TO FIRST BUCKKET\r
+ HLRZS (D) ;MAKE SURE NEW POINTER IS IN RH\r
+ JUMPE C,REH1 ;BUCKET EMPTY, QUIT\r
+\r
+REH2: MOVEI E,(C) ;MAKE A COPY OF THE POINTER\r
+ MOVE A,ITEM(C) ;START HASHING\r
+ TLZ A,TYPMSK#777777 ; KILL MONITORS\r
+ XOR A,ITEM+1(C)\r
+ MOVE 0,INDIC(C)\r
+ TLZ 0,TYPMSK#777777\r
+ XOR A,0\r
+ XOR A,INDIC+1(C)\r
+ TLZ A,400000 ;MAKE SURE FINAL HASH IS +\r
+ IDIV A,(P) ;DIVIDE BY TOTAL LENGTH\r
+ ADD B,-1(P) ;POINT TO WINNING BUCKET\r
+\r
+ MOVE C,[002200,,(B)] ;BYTE POINTER TO RH\r
+ CAILE B,(D) ;IF PAST CURRENT POINT\r
+ MOVE C,[222200,,(B)] ;USE LH\r
+ LDB A,C ;GET OLD VALUE\r
+ DPB E,C ;STORE NEW VALUE\r
+ HRRZ B,ASOLNT-1(E) ;GET NEXT POINTER\r
+ HRRZM A,ASOLNT-1(E) ;AND CLOBBER IN NEW NEXT\r
+ SKIPE A ;SKKIP IF NOTHING PREVIOUSLY IN BUCKET\r
+ HRLM E,ASOLNT-1(A) ;OTHERWISE CLOBBER\r
+ SKIPE C,B ;SKIP IF END OF CHAIN\r
+ JRST REH2\r
+REH1: AOBJN D,REH3\r
+\r
+ SUB P,[2,,2] ;FLUSH THE JUNK\r
+ POPJ P,\r
+\fVCMLOS: FATAL AGC--VECTOR WITH ZERO IN DOPE WORD LENGTH\r
+\r
+\r
+; THESE ARE THE MESSAGES INDICATING THE CAUSE OF THE GC\r
+\r
+MSGGCT: [ASCIZ /USER CALLED- /]\r
+ [ASCIZ /FREE STORAGE- /]\r
+ [ASCIZ /TP-STACK- /]\r
+ [ASCIZ /TOP-LEVEL LOCALS- /]\r
+ [ASCIZ /GLOBAL VALUES- /]\r
+ [ASCIZ /TYPES- /]\r
+ [ASCIZ /STATIONARY IMPURE STORAGE- /]\r
+ [ASCIZ /P-STACK /]\r
+ [ASCIZ /BOTH STACKS BLOWN- /]\r
+ [ASCIZ /PURE STORAGE- /]\r
+ [ASCIZ /GC-RCALL- /]\r
+\r
+; THESE ARE MESSAGES INDICATING WHO CAUSED THE GC\r
+\r
+MSGGFT: 0\r
+ [ASCIZ /BLOAT /]\r
+ [ASCIZ /GROW /]\r
+ [ASCIZ /LIST /]\r
+ [ASCIZ /VECTOR /]\r
+ [ASCIZ /SET /]\r
+ [ASCIZ /SETG /]\r
+ [ASCIZ /FREEZE /]\r
+ [ASCIZ /PURE-PAGE LOADER /]\r
+ [ASCIZ /GC /]\r
+ [ASCIZ /INTERRUPT-HANDLER /]\r
+ [ASCIZ /NEWTYPE /] \r
+\r
+\r
+\r
+\f\r
+;LOCAL VARIABLES\r
+\r
+IMPURE\r
+; LOCATIONS USED BY BLOAT-STAT TO HELP THE USER PICK BLOAT SPECIFICATIONS.\r
+;\r
+\r
+GCNO: 0 ; USER-CALLED GC\r
+BSTGC: 0 ; FREE STORAGE\r
+ 0 ; BLOWN TP\r
+ 0 ; TOP-LEVEL LVALS\r
+ 0 ; GVALS\r
+ 0 ; TYPE\r
+ 0 ; STORAGE\r
+ 0 ; P-STACK\r
+ 0 ; BOTH STATCKS BLOWN\r
+ 0 ; STORAGE\r
+\r
+BSTAT:\r
+NOWFRE: 0 ; FREE STORAGE FROM LAST GC\r
+CURFRE: 0 ; STORAGE USED SINCE LAST GC\r
+MAXFRE: 0 ; MAXIMUM FREE STORAGE ALLOCATED\r
+USEFRE: 0 ; TOTAL FREE STORAGE USED\r
+NOWTP: 0 ; TP LENGTH FROM LAST GC\r
+CURTP: 0 ; # WORDS ON TP\r
+CTPMX: 0 ; MAXIMUM SIZE OF TP SO FAR\r
+NOWLVL: 0 ; # OF TOP-LEVEL LVAL-SLOTS\r
+CURLVL: 0 ; # OF TOP-LEVEL LVALS\r
+NOWGVL: 0 ; # OF GVAL SLOTS\r
+CURGVL: 0 ; # OF GVALS\r
+NOWTYP: 0 ; SIZE OF TYPE-VECTOR\r
+CURTYP: 0 ; # OF TYPES\r
+NOWSTO: 0 ; SIZE OF STATIONARY STORAGE\r
+CURSTO: 0 ; STATIONARY STORAGE IN USE\r
+CURMAX: 0 ; MAXIMUM BLOCK OF CONTIGUOUS STORAGE\r
+NOWP: 0 ; SIZE OF P-STACK\r
+CURP: 0 ; #WORDS ON P\r
+CPMX: 0 ; MAXIMUM P-STACK LENGTH SO FAR\r
+GCCAUS: 0 ; INDICATOR FOR CAUSE OF GC\r
+GCCALL: 0 ; INDICATOR FOR CALLER OF GC\r
+\r
+\r
+; THIS GROUP OF VARIABLES DETERMINES HOW THINGS GROW\r
+LVLINC: 6 ; LVAL INCREMENT ASSUMED TO BE 64 SLOTS\r
+GVLINC: 4 ; GVAL INCREMENT ASSUMED TO BE 64 SLOTS\r
+TYPIC: 1 ; TYPE INCREMENT ASSUMED TO BE 32 TYPES\r
+STORIC: 2000 ; STORAGE INCREMENT USED BY NFREE (MINIMUM BLOCK-SIZE)\r
+\r
+\r
+RCL: 0 ; POINTER TO LIST OF RECYCLEABLE LIST CELLS\r
+GCMONF: 0 ; NON-ZERO SAY GIN/GOUT\r
+GCDANG: 0 ; NON-ZERO, STORAGE IS LOW\r
+GCDNTG: 0 ; NON-ZERO ABORT GROWTHS\r
+GETNUM: 0 ;NO OF WORDS TO GET\r
+PARNUM: 0 ;NO OF PAIRS MARKED\r
+VECNUM: 0 ;NO OF WORDS IN MARKED VECTORS\r
+CORSET: 0 ;NO OF BLOCKS OF CORE, IF GIVING CORE AWAY\r
+CORTOP: 0 ;CURRENT TOP OF CORE, EXCLUDING ANY TO BE GIVEN AWAY\r
+\r
+;VARIABLES WHICH DETERMIN WHEN MUDDLE WILL ASK FOR MORE CORE,\r
+;AND WHEN IT WILL GET UNHAPPY\r
+\r
+SYSMAX: 50. ;MAXIMUM SIZE OF MUDDLE\r
+FREMIN: 20000 ;MINIMUM FREE WORDS\r
+FREDIF: 10000 ;DIFFERENCE BETWEEN FREMIN AND MAXIMUM NUMBER OF FREE WORDS\r
+;POINTER TO GROWING PDL\r
+\r
+TPGROW: 0 ;POINTS TO A BLOWN TP\r
+PPGROW: 0 ;POINTS TO A BLOWN PP\r
+TIMOUT: 0 ;POINTS TO TIMED OUT PDL\r
+PGROW: 0 ;POINTS TO A BLOWN P\r
+\r
+;IN GC FLAG\r
+\r
+GCFLG: 0\r
+GCFLCH: 0 ; TELL INT HANDLER TO ITIC CHARS\r
+GCHAIR: 1 ; COUNTS GCS AND TELLS WHEN TO HAIRIFY\r
+SHRUNK: 0 ; NON-ZERO=> AVECTOR(S) SHRUNK\r
+GREW: 0 ; NON-ZERO=> A VECTOR(S) GREW\r
+SPARNW: 0 ; SAVED PARNEW\r
+GCDOWN: 0 ; AMOUNT TO TRY AND MOVE DOWN\r
+CURPLN: 0 ; LENGTH OF CURRENTLY RUNNING PURE RSUBR\r
+\r
+; VARS ASSOCIATED WITH BLOAT LOGIC\r
+\r
+TPBINC: 0\r
+GLBINC: 0\r
+TYPINC: 0\r
+\r
+; VARS FOR PAGE WINDOW HACKS\r
+\r
+WNDBOT: 0 ; BOTTOM OF WINDOW\r
+WNDTOP: 0\r
+BOTNEW: (FPTR) ; POINTER TO FRONTIER\r
+GCTIM: 0\r
+\r
+PURE\r
+\r
+\r
+END\r
+\r
+\r
+\r
+\r
+\r
+\fTITLE ARITHMETIC PRIMITIVES FOR MUDDLE\r
+\r
+.GLOBAL HI,RLOW,CPLUS,CMINUS,CTIMES,CDIVID,CFIX,CFLOAT\r
+.GLOBAL CLQ,CGQ,CLEQ,CGEQ,C1Q,C0Q,CMAX,CMIN,CABS,CMOD,CCOS,CSIN,CATAN,CLOG\r
+.GLOBAL CEXP,CSQRT,CTIME,CORB,CXORB,CANDB,CEQVB,CRAND,SAT,BFLOAT\r
+\r
+;BKD\r
+\r
+;DEFINES MUDDLE PRIMITIVES: FIX,FLOAT,ATAN,IEXP,LOG,\r
+; G?,L?,0?,1?,+,-,*,/,MAX,MIN,ABS,SIN,COS,SQRT,RANDOM,\r
+; TIME,SORT.\r
+\r
+RELOCATABLE\r
+\r
+.INSRT MUDDLE >\r
+\r
+O=0\r
+\r
+\r
+DEFINE TYP1\r
+ (AB) TERMIN\r
+DEFINE VAL1\r
+ (AB)+1 TERMIN\r
+\r
+DEFINE TYP2\r
+ (AB)+2 TERMIN\r
+DEFINE VAL2\r
+ (AB)+3 TERMIN\r
+\r
+DEFINE TYP3\r
+ (AB)+4 TERMIN\r
+DEFINE VAL3\r
+ (AB)+5 TERMIN\r
+\r
+DEFINE TYPN\r
+ (D) TERMIN\r
+DEFINE VALN\r
+ (D)+1 TERMIN\r
+\r
+\r
+YES: MOVSI A,TATOM ;RETURN PATH FOR 'TRUE'\r
+ MOVE B,MQUOTE T\r
+ AOS (P)\r
+ POPJ P,\r
+\r
+NO: MOVSI A,TFALSE ;RETURN PATH FOR 'FALSE'\r
+ MOVEI B,NIL\r
+ POPJ P,\r
+\r
+\f;ERROR RETURNS AND OTHER UTILITY ROUTINES\r
+\r
+OVRFLW==10\r
+OVRFLD: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE OVERFLOW\r
+ JRST CALER1\r
+\r
+CARGCH: GETYP 0,A ; GET TYPE\r
+ CAIN 0,TFLOAT\r
+ POPJ P,\r
+ JSP A,BFLOAT\r
+ POPJ P,\r
+\r
+ARGCHK: ;CHECK FOR SINGLE FIXED OR FLOATING\r
+ ;ARGUMENT IF FIXED CONVERT TO FLOATING\r
+ ;RETURN FLOATING ARGRUMENT IN B ALWAYS\r
+ ENTRY 1\r
+ GETYP C,TYP1 \r
+ MOVE B,VAL1\r
+ CAIN C,TFLOAT ;FLOATING?\r
+ POPJ P, ;YES, RETURN\r
+ CAIE C,TFIX ;FIXED?\r
+ JRST WTYP1 ;NO, ERROR\r
+ JSP A,BFLOAT ;YES, CONVERT TO FLOATING AND RETURN\r
+ POPJ P,\r
+\r
+OUTRNG: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE ARGUMENT-OUT-OF-RANGE\r
+ JRST CALER1\r
+\r
+NSQRT: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE NEGATIVE-ARGUMENT\r
+ JRST CALER1\r
+\r
+DEFINE MFLOAT AC\r
+ IDIVI AC,400000\r
+ FSC AC+1,233\r
+ FSC AC,254\r
+ FADR AC,AC+1\r
+ TERMIN\r
+\r
+BFLOAT: MFLOAT B\r
+ JRST (A)\r
+\r
+OFLOAT: MFLOAT O\r
+ JRST (C)\r
+\r
+BFIX: MULI B,400\r
+ TSC B,B\r
+ ASH C,(B)-243\r
+ MOVE B,C\r
+ JRST (A)\r
+\r
+\f;DISPATCH TABLES USED TO CONTROL THE FLOW OF THE VARIOUS PRIMITIVES\r
+\r
+TABLE2: NO ;TABLE2 (0)\r
+TABLE3: YES ;TABLE2 (1) & TABLE3 (0)\r
+ NO ;TABLE2 (2)\r
+ YES\r
+ NO\r
+\r
+TABLE4: NO\r
+ NO\r
+ YES\r
+ YES\r
+\r
+\r
+\r
+FUNC: JSP A,BFIX\r
+ JSP A,BFLOAT\r
+ SUB B,VALN\r
+ IDIV B,VALN\r
+ ADD B,VALN\r
+ IMUL B,VALN\r
+ JSP C,SWITCH\r
+ JSP C,SWITCH\r
+\r
+\r
+\r
+FLFUNC==.-2\r
+ FSBR B,O\r
+ FDVR B,O\r
+ FADR B,O\r
+ FMPR B,O\r
+ JSP C,FLSWCH\r
+ JSP C,FLSWCH\r
+\r
+DEFVAL==.-2\r
+ 0\r
+ 1\r
+ 0\r
+ 1\r
+ 377777,,-1\r
+ 400000,,1\r
+\r
+DEFTYP==.-2\r
+ TFIX,,\r
+ TFIX,,\r
+ TFIX,,\r
+ TFIX,,\r
+ TFLOAT,,\r
+ TFLOAT,,\r
+\f;PRIMITIVES FLOAT AND FIX\r
+\r
+MFUNCTION FIX,SUBR\r
+\r
+ ENTRY 1\r
+\r
+ JSP C,FXFL\r
+ MOVE B,1(AB)\r
+ CAIE A,TFIX\r
+ JSP A,BFIX\r
+ MOVSI A,TFIX\r
+ JRST FINIS\r
+\r
+MFUNCTION FLOAT,SUBR\r
+\r
+ ENTRY 1\r
+\r
+ JSP C,FXFL\r
+ MOVE B,1(AB)\r
+ CAIE A,TFLOAT\r
+ JSP A,BFLOAT\r
+ MOVSI A,TFLOAT\r
+ JRST FINIS\r
+\r
+CFIX: GETYP 0,A\r
+ CAIN 0,TFIX\r
+ POPJ P,\r
+ JSP A,BFIX\r
+ MOVSI A,TFIX\r
+ POPJ P,\r
+\r
+CFLOAT: GETYP 0,A\r
+ CAIN 0,TFLOAT\r
+ POPJ P,\r
+ JSP A,BFLOAT\r
+ MOVSI A,TFLOAT\r
+ POPJ P,\r
+\r
+FXFL: GETYP A,(AB)\r
+ CAIE A,TFIX\r
+ CAIN A,TFLOAT\r
+ JRST (C)\r
+ JRST WTYP1\r
+\r
+\r
+MFUNCTION ABS,SUBR\r
+ ENTRY 1\r
+ GETYP A,TYP1\r
+ CAIE A,TFIX\r
+ CAIN A,TFLOAT\r
+ JRST MOVIT\r
+ JRST WTYP1\r
+MOVIT: MOVM B,VAL1 ;GET ABSOLUTE VALUE OF ARGUMENT\r
+AFINIS: HRLZS A ;MOVE TYPE CODE INTO LEFT HALF\r
+ JRST FINIS\r
+\r
+\r
+\r
+MFUNCTION MOD,SUBR\r
+ ENTRY 2\r
+ GETYP A,TYP1\r
+ CAIE A,TFIX ;FIRST ARG FIXED ?\r
+ JRST WTYP1\r
+ GETYP A,TYP2\r
+ CAIE A,TFIX ;SECOND ARG FIXED ?\r
+ JRST WTYP2\r
+ MOVE A,VAL1\r
+ IDIV A,VAL2 ;FORM QUOTIENT & REMAINDER\r
+ JUMPGE B,.+2 ;Only return positive remainders\r
+ ADD B,VAL2\r
+ MOVSI A,TFIX\r
+ JRST FINIS\r
+\f;PRIMITIVES PLUS, DIFFERENCE, TIMES, DIVIDE, MIN, AND MAX\r
+\r
+MFUNCTION MIN,SUBR\r
+ \r
+ ENTRY\r
+\r
+ MOVEI E,6\r
+ JRST GOPT\r
+\r
+MFUNCTION MAX,SUBR\r
+\r
+ ENTRY\r
+\r
+ MOVEI E,7\r
+ JRST GOPT\r
+\r
+MFUNCTION DIVIDE,SUBR,[/]\r
+\r
+ ENTRY\r
+\r
+ MOVEI E,3\r
+ JRST GOPT\r
+\r
+MFUNCTION DIFFERENCE,SUBR,[-]\r
+\r
+ ENTRY\r
+\r
+ MOVEI E,2\r
+ JRST GOPT\r
+\r
+MFUNCTION TIMES,SUBR,[*]\r
+\r
+ ENTRY\r
+\r
+ MOVEI E,5\r
+ JRST GOPT\r
+\r
+MFUNCTION PLUS,SUBR,[+]\r
+\r
+ ENTRY\r
+\r
+ MOVEI E,4\r
+\r
+GOPT: MOVE D,AB ;ARGUMENT POINTER\r
+ HLRE A,AB\r
+ MOVMS A\r
+ ASH A,-1\r
+ PUSHJ P,CARITH\r
+ JRST FINIS\r
+\r
+; BUILD COMPILER ENTRIES TO THESE ROUTINES\r
+\r
+IRP NAME,,[CMINUS,CDIVID,CPLUS,CTIMES,CMIN,CMAX]CODE,,[2,3,4,5,6,7]\r
+\r
+NAME: MOVEI E,CODE\r
+ JRST CARIT1\r
+TERMIN\r
+\f\r
+CARIT1: MOVEI D,(A)\r
+ ASH D,1 ; TIMES 2\r
+ SUBI D,1\r
+ HRLI D,(D)\r
+ SUBM TP,D ; POINT TO ARGS\r
+ PUSH TP,$TTP\r
+ PUSH TP,D\r
+ PUSHJ P,CARITH\r
+ POP TP,TP\r
+ SUB TP,[1,,1]\r
+ POPJ P,\r
+\r
+CARITH: MOVE B,DEFVAL(E) ; GET VAL\r
+ JFCL OVRFLW,.+1\r
+ MOVEI 0,TFIX ; FIX UNTIL CHANGE\r
+ JUMPN A,ARITH0 ; AT LEAST ONE ARG\r
+ MOVE A,DEFTYP(E)\r
+ POPJ P,\r
+\r
+ARITH0: SOJE A,ARITH1 ; FALL IN WITH ONE ARG\r
+ MOVE B,1(D)\r
+ GETYP C,(D) ; TYPE OF 1ST ARG\r
+ ADD D,[2,,2] ; GO TO NEXT\r
+ CAIN C,TFLOAT\r
+ JRST ARITH3\r
+ CAIN C,TFIX\r
+ JRST ARITH1\r
+ JRST WRONGT\r
+\r
+ARITH1: GETYP C,(D) ; GET NEXT TYPE\r
+ CAIE C,TFIX\r
+ JRST ARITH2 ; TO FLOAT LOOP\r
+ XCT FUNC(E) ; DO IT\r
+ ADD D,[2,,2]\r
+ SOJG A,ARITH1 ; KEEP ADDING OR WHATEVER\r
+ JFCL OVRFLW,OVRFLD\r
+ MOVSI A,TFIX\r
+ POPJ P,\r
+\r
+ARITH3: GETYP C,(D)\r
+ MOVE 0,1(D) ; GET ARG\r
+ CAIE C,TFIX\r
+ JRST ARITH4\r
+ PUSH P,A\r
+ JSP C,OFLOAT ; FLOAT IT\r
+ POP P,A\r
+ JRST ARITH5\r
+ARITH4: CAIE C,TFLOAT\r
+ JRST WRONGT\r
+ JRST ARITH5\r
+\r
+ARITH2: CAIE C,TFLOAT ; FLOATER?\r
+ JRST WRONGT\r
+ PUSH P,A\r
+ JSP A,BFLOAT\r
+ POP P,A\r
+ MOVE 0,1(D)\r
+\r
+ARITH5: XCT FLFUNC(E)\r
+ ADD D,[2,,2]\r
+ SOJG A,ARITH3\r
+\r
+ JFCL OVRFLW,OVRFLD\r
+ MOVSI A,TFLOAT\r
+ POPJ P,\r
+\r
+SWITCH: XCT COMPAR(E) ;FOR MAX & MIN TESTING\r
+ MOVE B,VALN\r
+ JRST (C)\r
+COMPAR==.-6\r
+ CAMLE B,VALN\r
+ CAMGE B,VALN\r
+\r
+\r
+\r
+FLSWCH: XCT FLCMPR(E)\r
+ MOVE B,O\r
+ JRST (C)\r
+FLCMPR==.-6\r
+ CAMLE B,O\r
+ CAMGE B,O\r
+\f;PRIMITIVES ONEP AND ZEROP\r
+\r
+MFUNCTION ONEP,SUBR,[1?]\r
+ MOVEI E,1\r
+ JRST JOIN\r
+\r
+MFUNCTION ZEROP,SUBR,[0?]\r
+ MOVEI E,\r
+\r
+JOIN: ENTRY 1\r
+ GETYP A,TYP1\r
+ CAIN A,TFIX ;fixed ?\r
+ JRST TESTFX\r
+ CAIE A,TFLOAT ;floating ?\r
+ JRST WTYP1\r
+ MOVE B,VAL1\r
+ CAMN B,NUMBR(E) ;equal to correct value ?\r
+ JRST YES1\r
+ JRST NO1\r
+\r
+TESTFX: CAMN E,VAL1 ;equal to correct value ?\r
+ JRST YES1\r
+\r
+NO1: MOVSI A,TFALSE\r
+ MOVEI B,0\r
+ JRST FINIS\r
+\r
+YES1: MOVSI A,TATOM\r
+ MOVE B,MQUOTE T\r
+ JRST FINIS\r
+\r
+NUMBR: 0 ;FLOATING PT ZERO\r
+ 201400,,0 ;FLOATING PT ONE\r
+\f;PRIMITIVES LESSP AND GREATERP\r
+\r
+MFUNCTION LEQP,SUBR,[L=?]\r
+ MOVEI E,3\r
+ JRST ARGS\r
+\r
+MFUNCTION GEQP,SUBR,[G=?]\r
+ MOVEI E,2\r
+ JRST ARGS\r
+\r
+\r
+MFUNCTION LESSP,SUBR,[L?]\r
+ MOVEI E,1\r
+ JRST ARGS\r
+\r
+MFUNCTION GREATERP,SUBR,[G?]\r
+ MOVEI E,0\r
+\r
+ARGS: ENTRY 2\r
+ MOVE B,VAL1\r
+ MOVE A,TYP1\r
+ GETYP 0,A\r
+ PUSHJ P,CMPTYP\r
+ JRST WTYP1\r
+ MOVE D,VAL2\r
+ MOVE C,TYP2\r
+ GETYP 0,C\r
+ PUSHJ P,CMPTYP\r
+ JRST WTYP2\r
+ PUSHJ P,ACOMPS\r
+ JFCL\r
+ JRST FINIS\r
+\r
+; COMPILERS ENTRIES TO THESE GUYS\r
+\r
+IRP NAME,,[CGQ,CLQ,CGEQ,CLEQ]COD,,[0,1,2,3]\r
+\r
+NAME: MOVEI E,COD\r
+ JRST ACOMPS\r
+TERMIN\r
+\r
+ACOMPS: GETYP A,A\r
+ GETYP 0,C\r
+ CAIE 0,(A)\r
+ JRST COMPD ; COMPARING FIX AND FLOAT\r
+TEST: CAMN B,D\r
+ JRST @TABLE4(E)\r
+ CAMG B,D\r
+ JRST @TABLE2(E)\r
+ JRST @TABLE3(E)\r
+\r
+CMPTYP: CAIE 0,TFIX\r
+ CAIN 0,TFLOAT\r
+ AOS (P)\r
+ POPJ P,\r
+COMPD: EXCH B,D\r
+ CAIN A,TFLOAT\r
+ JSP A,BFLOAT\r
+ EXCH B,D\r
+ CAIN 0,TFLOAT\r
+ JSP A,BFLOAT\r
+COMPF: JRST TEST\r
+\r
+MFUNCTION RANDOM,SUBR\r
+ ENTRY\r
+ HLRE A,AB\r
+ CAMGE A,[-4] ;At most two arguments to random to set seeds\r
+ JRST TMA\r
+ JRST RANDGO(A)\r
+ MOVE B,VAL2 ;Set second seed\r
+ MOVEM B,RLOW\r
+ MOVE A,VAL1 ;Set first seed\r
+ MOVEM A,RHI\r
+RANDGO: PUSHJ P,CRAND\r
+ JRST FINIS\r
+\r
+CRAND: MOVE B,RLOW ;FREDKIN'S RANDOM NUMBER GENERATOR.\r
+ MOVE A,RHI\r
+ MOVEM A,RLOW\r
+ LSHC A,-43\r
+ XORB B,RHI\r
+ MOVSI A,TFIX\r
+ POPJ P,\r
+\r
+\fMFUNCTION SQRT,SUBR\r
+ PUSHJ P,ARGCHK\r
+ JUMPL B,NSQRT\r
+ PUSHJ P,ISQRT\r
+ JRST FINIS\r
+\r
+ISQRT: MOVE A,B\r
+ ASH B,-1\r
+ FSC B,100\r
+SQ2: MOVE C,B ;NEWTON'S METHOD, SPECINER'S HACK.\r
+ FDVRM A,B\r
+ FADRM C,B\r
+ FSC B,-1\r
+ CAME C,B\r
+ JRST SQ2\r
+ MOVSI A,TFLOAT\r
+ POPJ P,\r
+\r
+MFUNCTION COS,SUBR\r
+ PUSHJ P,ARGCHK\r
+ FADR B,[1.570796326] ;COS(X)=SIN (X+PI/2)\r
+ PUSHJ P,.SIN\r
+ MOVSI A,TFLOAT\r
+ JRST FINIS\r
+\r
+MFUNCTION SIN,SUBR\r
+ PUSHJ P,ARGCHK\r
+ PUSHJ P,.SIN\r
+ MOVSI A,TFLOAT\r
+ JRST FINIS\r
+\r
+.SIN: MOVM A,B\r
+ CAMG A,[.0001]\r
+ POPJ P, ;GOSPER'S RECURSIVE SIN.\r
+ FDVR B,[-3.0] ;SIN(X)=4*SIN(X/-3)**3-3*SIN(X/-3)\r
+ PUSHJ P,.SIN\r
+ FSC A,1\r
+ FMPR A,A\r
+ FADR A,[-3.0]\r
+ FMPRB A,B\r
+ POPJ P,\r
+\r
+CSQRT: PUSHJ P,CARGCH\r
+ JUMPL B,NSQRT\r
+ JRST ISQRT\r
+\r
+CSIN: PUSHJ P,CARGCH\r
+CSIN1: PUSHJ P,.SIN\r
+ MOVSI A,TFLOAT\r
+ POPJ P,\r
+\r
+CCOS: PUSHJ P,CARGCH\r
+ FADR B,[1.570796326]\r
+ JRST CSIN1\r
+\fMFUNCTION LOG,SUBR\r
+ PUSHJ P,ARGCHK ;LEAVES ARGUMENT IN B\r
+ PUSHJ P,ILOG\r
+ JRST FINIS\r
+\r
+CLOG: PUSHJ P,CARGCH\r
+\r
+ILOG: JUMPLE B,OUTRNG\r
+ LDB D,[331100,,B] ;GRAB EXPONENT\r
+ SUBI D,201 ;REMOVE BIAS\r
+ TLZ B,777000 ;SET EXPONENT\r
+ TLO B,201000 ; TO 1\r
+ MOVE A,B\r
+ FSBR A,RT2\r
+ FADR B,RT2\r
+ FDVB A,B\r
+ FMPR B,B\r
+ MOVE C,[0.434259751]\r
+ FMPR C,B\r
+ FADR C,[0.576584342]\r
+ FMPR C,B\r
+ FADR C,[0.961800762]\r
+ FMPR C,B\r
+ FADR C,[2.88539007]\r
+ FMPR C,A\r
+ FADR C,[0.5]\r
+ MOVE B,D\r
+ FSC B,233\r
+ FADR B,C\r
+ FMPR B,[0.693147180] ;LOG E OF 2\r
+ MOVSI A,TFLOAT\r
+ POPJ P,\r
+\r
+RT2: 1.41421356\r
+\fMFUNCTION ATAN,SUBR\r
+ PUSHJ P,ARGCHK\r
+ PUSHJ P,IATAN\r
+ JRST FINIS\r
+\r
+CATAN: PUSHJ P,CARGCH\r
+\r
+IATAN: PUSH P,B\r
+ MOVM D,B\r
+ CAMG D,[0.4^-8] ;SMALL ENOUGH SO ATAN(X)=X?\r
+ JRST ATAN3 ;YES\r
+ CAML D,[7.0^7] ;LARGE ENOUGH SO THAT ATAN(X)=PI/2?\r
+ JRST ATAN1 ;YES\r
+ MOVN C,[1.0]\r
+ CAMLE D,[1.0] ;IS ABS(X)<1.0?\r
+ FDVM C,D ;NO,SCALE IT DOWN\r
+ MOVE B,D\r
+ FMPR B,B\r
+ MOVE C,[1.44863154]\r
+ FADR C,B\r
+ MOVE A,[-0.264768620]\r
+ FDVM A,C\r
+ FADR C,B\r
+ FADR C,[3.31633543]\r
+ MOVE A,[-7.10676005]\r
+ FDVM A,C\r
+ FADR C,B\r
+ FADR C,[6.76213924]\r
+ MOVE B,[3.70925626]\r
+ FDVR B,C\r
+ FADR B,[0.174655439]\r
+ FMPR B,D\r
+ JUMPG D,ATAN2 ;WAS ARG SCALED?\r
+ FADR B,PI2 ;YES, ATAN(X)=PI/2-ATAN(1/X)\r
+ JRST ATAN2\r
+ATAN1: MOVE B,PI2\r
+ATAN2: SKIPGE (P) ;WAS INPUT NEGATIVE?\r
+ MOVNS B ;YES,COMPLEMENT\r
+ATAN3: MOVSI A,TFLOAT \r
+ SUB P,[1,,1]\r
+ POPJ P,\r
+\r
+PI2: 1.57079632\r
+\fMFUNCTION IEXP,SUBR,[EXP] \r
+ PUSHJ P,ARGCHK ;LEAVE FLOATING POINT ARG IN B\r
+ PUSHJ P,IIEXP\r
+ JRST FINIS\r
+\r
+CEXP: PUSHJ P,CARGCH\r
+\r
+IIEXP: PUSH P,B\r
+ MOVM A,B\r
+ SETZM B\r
+ FMPR A,[0.434294481] ;LOG BASE 10 OF E\r
+ MOVE D,[1.0]\r
+ CAMG A,D\r
+ JRST RATEX\r
+ MULI A,400\r
+ ASHC B,-243(A)\r
+ CAILE B,43\r
+ JRST OUTRNG\r
+ CAILE B,7\r
+ JRST EXPR2\r
+EXPR1: FMPR D,FLOAP1(B)\r
+ LDB A,[103300,,C] \r
+ SKIPE A\r
+ TLO A,177000\r
+ FADR A,A\r
+RATEX: MOVEI B,7\r
+ SETZM C\r
+RATEY: FADR C,COEF2-1(B)\r
+ FMPR C,A\r
+ SOJN B,RATEY\r
+ FADR C,[1.0] \r
+ FMPR C,C\r
+ FMPR D,C\r
+ MOVE B,[1.0]\r
+ SKIPL (P) ;SKIP IF INPUT NEGATIVE\r
+ SKIPN B,D\r
+ FDVR B,D\r
+ MOVSI A,TFLOAT\r
+ SUB P,[1,,1]\r
+ POPJ P,\r
+\r
+EXPR2: LDB E,[030300,,B] \r
+ ANDI B,7\r
+ MOVE D,FLOAP1(E)\r
+ FMPR D,D ;TO THE 8TH POWER\r
+ FMPR D,D\r
+ FMPR D,D\r
+ JRST EXPR1\r
+\r
+COEF2: 1.15129278\r
+ 0.662730884\r
+ 0.254393575\r
+ 0.0729517367\r
+ 0.0174211199\r
+ 2.55491796^-3\r
+ 9.3264267^-4\r
+\r
+FLOAP1: 1.0\r
+ 10.0\r
+ 100.0\r
+ 1000.0\r
+ 10000.0\r
+ 100000.0\r
+ 1000000.0\r
+ 10000000.0\r
+\f;BITWISE BOOLEAN FUNCTIONS\r
+\r
+MFUNCTION %ANDB,SUBR,ANDB\r
+ ENTRY\r
+ HRREI B,-1 ;START ANDING WITH ALL ONES\r
+ MOVE D,[AND B,A] ;LOGICAL INSTRUCTION\r
+ JRST LOGFUN ;DO THE OPERATION\r
+\r
+MFUNCTION %ORB,SUBR,ORB\r
+ ENTRY\r
+ MOVEI B,0\r
+ MOVE D,[IOR B,A]\r
+ JRST LOGFUN\r
+\r
+MFUNCTION %XORB,SUBR,XORB\r
+ ENTRY\r
+ MOVEI B,0\r
+ MOVE D,[XOR B,A]\r
+ JRST LOGFUN\r
+\r
+MFUNCTION %EQVB,SUBR,EQVB\r
+ ENTRY\r
+ HRREI B,-1\r
+ MOVE D,[EQV B,A]\r
+\r
+LOGFUN: JUMPGE AB,ZROARG\r
+LOGTYP: GETYP A,(AB) ;GRAB THE TYPE\r
+ PUSHJ P,SAT ;STORAGE ALLOCATION TYPE\r
+ CAIE A,S1WORD\r
+ JRST WRONGT ;WRONG TYPE...LOSE\r
+ MOVE A,1(AB) ;LOAD ARG INTO A\r
+ XCT D ;DO THE LOGICAL OPERATION\r
+ AOBJP AB,.+2 ;ADD ONE TO BOTH HALVES\r
+ AOBJN AB,LOGTYP ;ADD AGAIN AND LOOP IF NEEDED\r
+\r
+ZROARG: MOVE A,$TWORD\r
+ JRST FINIS\r
+\fREPEAT 0,[\r
+;routine to sort lists or vectors of either fixed point or floating numbers\r
+;the components are interchanged repeatedly to acheive the sort\r
+;first arg: the structure to be sorted\r
+;if no second arg sort in descending order\r
+;second arg: if false then sort in ascending order\r
+; else sort in descending order\r
+\r
+MFUNCTION SORT,SUBR\r
+ ENTRY \r
+ HLRZ A,AB\r
+ CAIGE A,-4 ;Only two arguments allowed\r
+ JRST TMA\r
+ MOVE O,DESCEND ;Set up "O" to test for descending order as default condition\r
+ CAIE A,-4 ;Optional second argument?\r
+ JRST .+4\r
+ GETYP B,TYP2 ;See if it is other than false\r
+ CAIN B,TFALSE\r
+ MOVE O,ASCEND ;Set up "O" to test for ascending order\r
+ GETYP A,TYP1 ;CHECK TYPE OF FIRST ARGUMENT\r
+ CAIN A,TLIST\r
+ JRST LSORT\r
+ CAIN A,TVEC\r
+ JRST VSORT\r
+ JRST WTYP1\r
+\r
+\r
+\r
+\r
+GOBACK: MOVE A,TYP1 ;RETURN THE SORTED ARGUMENT AS VALUE\r
+ MOVE B,VAL1\r
+ JRST FINIS\r
+\r
+DESCEND: CAMG C,(A)+1\r
+ASCEND: CAML C,(A)+1\r
+\f;ROUTINE TO SORT LISTS IN NUMERICAL ORDER\r
+\r
+LSORT: MOVE A,VAL1\r
+ JUMPE A,GOBACK ;EMPTY LIST?\r
+ HLRZ B,(A) ;TYPE OF FIRST COMPONENT\r
+ CAIE B,TFIX\r
+ CAIN B,TFLOAT\r
+ SKIPA\r
+ JRST WRONGT\r
+ MOVEI E,0 ;FOR COUNT OF LENGTH OF LIST\r
+LCOUNT: JUMPE A,LLSORT ;REACHED END OF LIST?\r
+ MOVE A,(A) ;NEXT COMPONENT\r
+ TLZ A,(B) ;SAME TYPE AS FIRST COMPONENT?\r
+ TLNE A,-1\r
+ JRST WRONGT\r
+ AOJA E,LCOUNT ;INCREMENT COUNT AND CONTINUE\r
+\r
+LLSORT: SOJE E,GOBACK ;FINISHED WITH SORTING?\r
+ HRRZ A,VAL1 ;START THIS LOOP OF SORTING AT THE BEGINNING\r
+ MOVEM E,(P)+1 ;Save the iteration depth\r
+CLSORT: HRRZ B,(A) ;NEXT COMPONENT\r
+ MOVE C,(B)+1 ;ITS VALUE\r
+ XCT O ;ARE THESE TWO COMPONENTS IN ORDER?\r
+ JRST .+4\r
+ MOVE D,(A)+1 ;INTERCHANGE THEM\r
+ MOVEM D,(B)+1\r
+ MOVEM C,(A)+1\r
+ MOVE A,B ;MAKE THE COMPONENT IN "B" THE CURRENT ONE\r
+ SOJG E,CLSORT\r
+ MOVE E,(P)+1 ;Restore the iteration depth\r
+ JRST LLSORT\r
+\f;ROUTINE TO SORT VECTORS IN NUMERICAL ORDER\r
+\r
+VSORT: HLRE D,VAL1 ;GET COUNT FIELD OF VECTOR\r
+ IDIV D,[-2] ;LENGTH\r
+ JUMPE D,GOBACK ;EMPTY VECTOR?\r
+ MOVE E,D ;SAVE LENGTH IN "E"\r
+ HRRZ A,VAL1 ;POINTER TO VECTOR\r
+ MOVE B,(A) ;TYPE OF FIRST COMPONENT\r
+ CAME B,$TFIX\r
+ CAMN B,$TFLOAT\r
+ SKIPA\r
+ JRST WRONGT\r
+ SOJLE D,GOBACK ;IF ONLY ONE COMPONENT THEN FINISHED\r
+VCOUNT: ADDI A,2 ;CHECK NEXT COMPONENT\r
+ CAME B,(A) ;SAME TYPE AS FIRST COMPONENT?\r
+ JRST WRONGT\r
+ SOJG D,VCOUNT ;CONTINUE WITH NEXT COMPONENT\r
+\r
+VVSORT: SOJE E,GOBACK ;FINISHED SORTING?\r
+ HRRZ A,VAL1 ;START THIS LOOP OF SORTING AT THE BEGINNING\r
+ MOVEM E,(P)+1 ;Save the iteration depth\r
+CVSORT: MOVE C,(A)+3 ;VALUE OF NEXT COMPONENT\r
+ XCT O ;ARE THESE TWO COMPONENTS IN ORDER?\r
+ JRST .+4\r
+ MOVE D,(A)+1 ;INTERCHANGE THEM\r
+ MOVEM D,(A)+3\r
+ MOVEM C,(A)+1\r
+ ADDI A,2 ;UPDATE THE CURRENT COMPONENT\r
+ SOJG E,CVSORT\r
+ MOVE E,(P)+1 ;Restore the iteration depth\r
+ JRST VVSORT\r
+]\r
+\r
+MFUNCTION TIME,SUBR\r
+ ENTRY\r
+ PUSHJ P,CTIME\r
+ JRST FINIS\r
+\r
+IMPURE\r
+\r
+RHI: 267762113337\r
+RLOW: 155256071112\r
+PURE\r
+\r
+\r
+END\r
+\f\fTITLE ATOMHACKER FOR MUDDLE\r
+\r
+RELOCATABLE\r
+\r
+.INSRT MUDDLE >\r
+.GLOBAL RLOOKU,CHMAK,OBLNT,ROOT,INTOBL,ERROBL,IFALSE\r
+.GLOBAL .BLOCK,IDVAL,NXTDCL,CHRWRD,CSTACK,CSTAK,ILOOKC,IGVAL,BYTDOP\r
+.GLOBAL ICONS,INCONS,IBLOCK,INSRTX,GCHACK,IMPURIFY\r
+.GLOBAL CINSER,CIRMV,CLOOKU,CATOM,CIPNAM,MPOPJ,CSETG\r
+\r
+.VECT.==40000 ; BIT FOR GCHACK\r
+\r
+; FUNCTION TO GENERATE AN EMPTY OBLIST\r
+\r
+MFUNCTION MOBLIST,SUBR\r
+\r
+ ENTRY\r
+ CAMGE AB,[-5,,0] ;CHECK NUMBER OF ARGS\r
+ JRST TMA\r
+ JUMPGE AB,MOBL2 ; NO ARGS\r
+ PUSH TP,(AB)\r
+ PUSH TP,1(AB)\r
+ PUSH TP,$TATOM\r
+ PUSH TP,IMQUOTE OBLIST\r
+ MCALL 2,GET ; CHECK IF IT EXISTS ALREADY\r
+ CAMN A,$TOBLS\r
+ JRST FINIS\r
+MOBL2: MOVE A,OBLNT ;GET DEFAULT LENGTH\r
+ CAML AB,[-3,,0] ;IS LENGTH SUPPLIED\r
+ JRST MOBL1 ;NO, USE STANDARD LENGTH\r
+ GETYP C,2(AB) ;GET ARG TYPE\r
+ CAIE C,TFIX\r
+ JRST WTYP2 ;LOSE\r
+ MOVE A,3(AB) ;GET LENGTH\r
+MOBL1: PUSH TP,$TFIX\r
+ PUSH TP,A\r
+ MCALL 1,UVECTOR ;GET A UNIFORM VECTOR\r
+ MOVSI C,TLIST+.VECT. ;IT IS OF TYPE LIST\r
+ HLRE D,B ;-LENGTH TO D\r
+ SUBM B,D ;D POINTS TO DOPE WORD\r
+ MOVEM C,(D) ;CLOBBER TYPE IN\r
+ MOVSI A,TOBLS\r
+ JUMPGE AB,FINIS ; IF NO ARGS, DONE\r
+ GETYP A,(AB)\r
+ CAIE A,TATOM\r
+ JRST WTYP1\r
+ PUSH TP,$TOBLS\r
+ PUSH TP,B\r
+ PUSH TP,$TOBLS\r
+ PUSH TP,B\r
+ PUSH TP,$TATOM\r
+ PUSH TP,IMQUOTE OBLIST\r
+ PUSH TP,(AB)\r
+ PUSH TP,1(AB)\r
+ MCALL 3,PUT ; PUT THE NAME ON THE OBLIST\r
+ PUSH TP,(AB)\r
+ PUSH TP,1(AB)\r
+ PUSH TP,$TATOM\r
+ PUSH TP,IMQUOTE OBLIST\r
+ PUSH TP,(TB)\r
+ PUSH TP,1(TB)\r
+ MCALL 3,PUT ; PUT THE OBLIST ON THE NAME\r
+\r
+ POP TP,B\r
+ POP TP,A\r
+ JRST FINIS\r
+\r
+MFUNCTION GROOT,SUBR,ROOT\r
+ ENTRY 0\r
+ MOVE A,ROOT(TVP)\r
+ MOVE B,ROOT+1(TVP)\r
+ JRST FINIS\r
+\r
+MFUNCTION GINTS,SUBR,INTERRUPTS\r
+ ENTRY 0\r
+ MOVE A,INTOBL(TVP)\r
+ MOVE B,INTOBL+1(TVP)\r
+ JRST FINIS\r
+\r
+MFUNCTION GERRS,SUBR,ERRORS\r
+ ENTRY 0\r
+ MOVE A,ERROBL(TVP)\r
+ MOVE B,ERROBL+1(TVP)\r
+ JRST FINIS\r
+\r
+\r
+COBLQ: SKIPN B,2(B) ; SKIP IF EXISTS\r
+ JRST IFLS\r
+ MOVSI A,TOBLS\r
+ JUMPL B,CPOPJ1\r
+ ADDI B,(TVP)\r
+ MOVE B,(B)\r
+CPOPJ1: AOS (P)\r
+ POPJ P,\r
+\r
+IFLS: MOVEI B,0\r
+ MOVSI A,TFALSE\r
+ POPJ P,\r
+\r
+MFUNCTION OBLQ,SUBR,[OBLIST?]\r
+\r
+ ENTRY 1\r
+ GETYP A,(AB)\r
+ CAIE A,TATOM\r
+ JRST WTYP1\r
+ MOVE B,1(AB) ; GET ATOM\r
+ PUSHJ P,COBLQ\r
+ JFCL\r
+ JRST FINIS\r
+\r
+\f; FUNCTION TO FIND AN ATOM ON A GIVEN OBLIST WITH A GIVEN PNAME\r
+\r
+MFUNCTION LOOKUP,SUBR\r
+\r
+ ENTRY 2\r
+ PUSHJ P,ILOOKU ;CALL INTERNAL ROUTINE\r
+ JRST FINIS\r
+\r
+CLOOKU: SUBM M,(P)\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ MOVEI B,-1(TP)\r
+ PUSH TP,$TOBLS\r
+ PUSH TP,C\r
+ GETYP A,A\r
+ PUSHJ P,CSTAK\r
+ MOVE B,(TP)\r
+ PUSHJ P,ILOOK\r
+ POP P,D\r
+ HRLI D,(D)\r
+ SUB P,D\r
+ SKIPE B\r
+ SOS (P)\r
+ SUB TP,[4,,4]\r
+ JRST MPOPJ\r
+\r
+ILOOKU: PUSHJ P,ARGCHK ;CHECK ARGS\r
+ PUSHJ P,CSTACK ;PUT CHARACTERS ON THE STACK\r
+\r
+CALLIT: MOVE B,3(AB) ;GET OBLIST\r
+ILOOKC: PUSHJ P,ILOOK ;LOOK IT UP\r
+ POP P,D ;RESTORE COUNT\r
+ HRLI D,(D) ;TO BOTH SIDES\r
+ SUB P,D\r
+ POPJ P,\r
+\r
+;THIS ROUTINE CHECKS ARG TYPES\r
+\r
+ARGCHK: GETYP A,(AB) ;GET TYPES\r
+ GETYP C,2(AB)\r
+ CAIE A,TCHRS ;IS IT EITHER CHAR STRING\r
+ CAIN A,TCHSTR\r
+ CAIE C,TOBLS ;IS 2ND AN OBLIST\r
+ JRST WRONGT ;TYPES ARE WRONG\r
+ POPJ P,\r
+\r
+;THIS SUBROUTINE PUTS CHARACTERS ON THE STACK (P WILL BE CHANGED)\r
+\r
+\r
+CSTACK: MOVEI B,(AB)\r
+CSTAK: POP P,D ;RETURN ADDRESS TO D\r
+ CAIE A,TCHRS ;IMMEDIATE?\r
+ JRST NOTIMM ;NO, HAIR\r
+ MOVE A,1(B) ; GET CHAR\r
+ LSH A,29. ; POSITION\r
+ PUSH P,A ;ONTO P\r
+ PUSH P,[1] ;WITH NUMBER\r
+ JRST (D) ;GO CALL SEARCHER\r
+\r
+NOTIMM: MOVEI A,1 ; CLEAR CHAR COUNT\r
+ HRRZ C,(B) ; GET COUNT OF CHARS\r
+ JUMPE C,NULST ; FLUSH NULL STRING\r
+ MOVE B,1(B) ;GET BYTE POINTER\r
+\r
+CLOOP1: PUSH P,[0] ; STORE CHARS ON STACK\r
+ MOVSI E,(<440700,,(P)>) ; SETUP BYTE POINTER\r
+CLOOP: ILDB 0,B ;GET A CHARACTER\r
+ IDPB 0,E ;STORE IT\r
+ SOJE C,CDONE ; ANY MORE?\r
+ TLNE E,760000 ; WORD FULL\r
+ JRST CLOOP ;NO CONTINUE\r
+ AOJA A,CLOOP1 ;AND CONTINUE\r
+\r
+CDONE:\r
+CDONE1: PUSH P,A ;AND NUMBER OF WORDS\r
+ JRST (D) ;RETURN\r
+\r
+\r
+NULST: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE NULL-STRING\r
+ JRST CALER1\r
+\f; THIS FUNCTION LOOKS FOR ATOMS. CALLED BY PUSHJ P,ILOOK\r
+; B/ OBLIST POINTER\r
+; -1(P)/ LENGTH IN WORDS OF CHARACTER BLOCK\r
+; CHAR STRING IS ON THE STACK\r
+\r
+ILOOK: MOVN A,-1(P) ;GET -LENGTH\r
+ HRLI A,-1(A) ;<-LENGTH-1>,,-LENGTH\r
+ PUSH TP,$TFIX ;SAVE\r
+ PUSH TP,A\r
+ ADDI A,-1(P) ;HAVE AOBJN POINTER TO CHARS\r
+ MOVEI D,0 ;HASH WORD\r
+ XOR D,(A)\r
+ AOBJN A,.-1 ;XOR THEM ALL TOGETHER\r
+ HLRE A,B ;GET LENGTH OF OBLIST\r
+ MOVNS A\r
+ TLZ D,400000 ; MAKE SURE + HASH CODE\r
+ IDIVI D,(A) ;DIVIDE\r
+ HRLI E,(E) ;TO BOTH HALVES\r
+ ADD B,E ;POINT TO BUCKET\r
+\r
+ MOVEI 0,(B) ;IN CASE REMOVING 1ST\r
+ SKIPN C,(B) ;BUCKET EMPTY?\r
+ JRST NOTFND ;YES, GIVE UP\r
+LOOK2: SKIPN A,1(C) ;NIL CAR ON LIST?\r
+ JRST NEXT ;YES TRY NEXT\r
+ ADD A,[3,,3] ;POINT TO ATOMS PNAME\r
+ MOVE D,(TP) ;GET PSEUDO AOBJN POINTER TO CHARS\r
+ ADDI D,-1(P) ;NOW ITS A REAL AOBJN POINTER\r
+ JUMPE D,CHECK0 ;ONE IS EMPTY\r
+LOOK1: MOVE E,(D) ;GET A WORD\r
+ CAME E,(A) ;COMPARE\r
+ JRST NEXT ;THIS ONE DOESN'T MATCH\r
+ AOBJP D,CHECK ;ONE RAN OUT\r
+ AOBJN A,LOOK1 ;JUMP IF STILL MIGHT WIN\r
+\r
+NEXT: MOVEI 0,(C) ;POINT TO PREVIOUS ELEMENT\r
+ HRRZ C,(C) ;STEP THROUGH\r
+ JUMPN C,LOOK2\r
+\r
+NOTFND: EXCH C,B ;RETURN BUCKET IN B\r
+ MOVSI A,TFALSE\r
+CPOPJT: SUB TP,[2,,2] ;REMOVE RANDOM TP STUFF\r
+ POPJ P,\r
+\r
+CHECK0: JUMPN A,NEXT ;JUMP IF NOT ALSO EMPTY\r
+ SKIPA\r
+CHECK: AOBJN A,NEXT ;JUMP IF NO MATCH\r
+ HLLZ A,(C)\r
+ MOVE E,B ; RETURN BUCKET\r
+ MOVE B,1(C) ;GET ATOM\r
+ JRST CPOPJT\r
+\r
+\r
+\f; FUNCTION TO INSERT AN ATOM ON AN OBLIST\r
+\r
+MFUNCTION INSERT,SUBR\r
+\r
+ ENTRY 2\r
+ GETYP A,2(AB)\r
+ CAIE A,TOBLS\r
+ JRST WTYP2\r
+ MOVE A,(AB)\r
+ MOVE B,1(AB)\r
+ MOVE C,3(AB)\r
+ PUSHJ P,IINSRT\r
+ JRST FINIS\r
+\r
+CINSER: SUBM M,(P)\r
+ PUSHJ P,IINSRT\r
+ JRST MPOPJ\r
+\r
+IINSRT: PUSH TP,A\r
+ PUSH TP,B\r
+ PUSH TP,$TOBLS\r
+ PUSH TP,C\r
+ GETYP A,A\r
+ CAIN A,TATOM\r
+ JRST INSRT0\r
+\r
+;INSERT WITH A GIVEN PNAME\r
+\r
+ CAIE A,TCHRS\r
+ CAIN A,TCHSTR\r
+ JRST .+2\r
+ JRST WTYP1\r
+\r
+ PUSH TP,$TFIX ;FLAG CALL\r
+ PUSH TP,[0]\r
+ MOVEI B,-5(TP)\r
+ PUSHJ P,CSTAK ;COPY ONTO STACK\r
+ MOVE B,-2(TP)\r
+ PUSHJ P,ILOOK ;LOOK IT UP (BUCKET RETURNS IN C)\r
+ JUMPN B,ALRDY ;EXISTS, LOSE\r
+ MOVE D,-2(TP) ; GET OBLIST BACK\r
+INSRT1: PUSH TP,$TOBLS ;SAVE BUCKET POINTER\r
+ PUSH TP,C\r
+ PUSH TP,$TOBLS\r
+ PUSH TP,D ; SAVE OBLIST\r
+INSRT3: PUSHJ P,IATOM ; MAKE AN ATOM\r
+ PUSHJ P,LINKCK ; A LINK REALLY NEEDED ?\r
+ MOVE E,-2(TP)\r
+ HRRZ E,(E) ; GET BUCKET\r
+ PUSHJ P,ICONS\r
+ MOVE C,-2(TP) ;BUCKET AGAIN\r
+ HRRM B,(C) ;INTO NEW BUCKET\r
+ MOVSI A,TATOM\r
+ MOVE B,1(B) ;GET ATOM BACK\r
+ MOVE D,(TP) ; GET OBLIST\r
+ MOVEM D,2(B) ; AND CLOBBER\r
+ MOVE C,-4(TP) ;GET FLAG\r
+ SUB TP,[6,,6] ;POP STACK\r
+ JUMPN C,(C)\r
+ SUB TP,[4,,4]\r
+ POPJ P,\r
+\r
+;INSERT WITH GIVEN ATOM\r
+INSRT0: MOVE A,-2(TP) ;GOBBLE PNAME\r
+ SKIPE 2(A) ; SKIP IF NOT ON AN OBLIST\r
+ JRST ONOBL\r
+ ADD A,[3,,3]\r
+ HLRE C,A\r
+ MOVNS C\r
+ PUSH P,(A) ;FLUSH PNAME ONTO P STACK\r
+ AOBJN A,.-1\r
+ PUSH P,C\r
+ MOVE B,(TP) ; GET OBLIST FOR LOOKUP\r
+ PUSHJ P,ILOOK ;ALREADY THERE?\r
+ JUMPN B,ALRDY\r
+ PUSH TP,$TOBLS ;SAVE NECESSARY STUFF AWAY FROM CONS\r
+ PUSH TP,C ;WHICH WILL MAKE A LIST FROM THE ATOM\r
+ MOVSI C,TATOM\r
+ MOVE D,-4(TP)\r
+ PUSHJ P,INCONS\r
+ MOVE C,(TP) ;RESTORE\r
+ HRRZ D,(C)\r
+ HRRM B,(C)\r
+ HRRM D,(B)\r
+ MOVE C,-2(TP)\r
+ MOVE B,-4(TP) ; GET BACK ATOM\r
+ MOVEM C,2(B) ; CLOBBER OBLIST IN\r
+ MOVSI A,TATOM\r
+ SUB TP,[6,,6]\r
+ POP P,C\r
+ HRLI C,(C)\r
+ SUB P,C\r
+ POPJ P,\r
+\r
+LINKCK: HRRZ C,FSAV(TB) ;CALLER'S NAME\r
+ CAIN C,LINK\r
+ SKIPA C,$TLINK ;LET US INSERT A LINK INSTEAD OF AN ATOM\r
+ MOVSI C,TATOM ;GET REAL ATOM FOR CALL TO ICONS\r
+ MOVE D,B\r
+ POPJ P,\r
+\r
+\r
+\r
+ALRDY: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE ATOM-ALREADY-THERE\r
+ JRST CALER1\r
+\r
+ONOBL: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE ON-AN-OBLIST-ALREADY\r
+ JRST CALER1\r
+\r
+; INTERNAL INSERT CALL\r
+\r
+INSRTX: POP P,0 ; GET RET ADDR\r
+ PUSH TP,$TFIX\b \r
+ PUSH TP,0\r
+ PUSH TP,$TOBLS\r
+ PUSH TP,B\r
+ PUSH TP,$TOBLS\r
+ PUSH TP,B\r
+ PUSHJ P,ILOOK\r
+ JUMPN B,INSRXT\r
+ MOVEM C,-2(TP)\r
+ JRST INSRT3 ; INTO INSERT CODE\r
+\r
+INSRXT: PUSH P,-4(TP)\r
+ SUB TP,[6,,6]\r
+ POPJ P,\r
+ JRST IATM1\r
+\f\r
+; FUNCTION TO REMOVE AN ATOM FROM AN OBLIST\r
+\r
+MFUNCTION REMOVE,SUBR\r
+\r
+ ENTRY\r
+\r
+ JUMPGE AB,TFA\r
+ CAMGE AB,[-5,,]\r
+ JRST TMA\r
+ MOVEI C,0\r
+ CAML AB,[-3,,] ; SKIP IF OBLIST GIVEN\r
+ JRST .+5\r
+ GETYP 0,2(AB)\r
+ CAIE 0,TOBLS\r
+ JRST WTYP2\r
+ MOVE C,3(AB)\r
+ MOVE A,(AB)\r
+ MOVE B,1(AB)\r
+ PUSHJ P,IRMV\r
+ JRST FINIS\r
+\r
+CIRMV: SUBM M,(P)\r
+ PUSHJ P,IRMV\r
+ JRST MPOPJ\r
+\r
+IRMV: PUSH TP,A\r
+ PUSH TP,B\r
+ PUSH TP,$TOBLS\r
+ PUSH TP,C\r
+IRMV1: GETYP 0,A ; CHECK 1ST ARG\r
+ CAIN 0,TLINK\r
+ JRST .+3\r
+ CAIE 0,TATOM ; ATOM, TREAT ACCORDINGLY\r
+ JRST RMV1\r
+\r
+ SKIPN D,2(B) ; SKIP IF ON OBLIST AND GET SAME\r
+ JRST IFALSE\r
+ JUMPL D,.+3\r
+ ADDI D,(TVP)\r
+ MOVE D,(D)\r
+ JUMPE C,GOTOBL\r
+ CAME C,D ; BETTER BE THE SAME\r
+ JRST ONOTH\r
+\r
+GOTOBL: ADD B,[3,,3] ; POINT TO PNAME\r
+ HLRE A,B\r
+ MOVNS A\r
+ PUSH P,(B) ; PUSH PNAME\r
+ AOBJN B,.-1\r
+ PUSH P,A\r
+ MOVEM D,(TP) ; SAVE OBLIST\r
+ JRST RMV3\r
+\r
+RMV1: JUMPE C,TFA\r
+ CAIE 0,TCHRS\r
+ CAIN 0,TCHSTR\r
+ SKIPA A,0\r
+ JRST WTYP1\r
+ MOVEI B,-3(TP)\r
+ PUSHJ P,CSTAK\r
+RMV3: MOVE B,(TP)\r
+ PUSHJ P,ILOOK\r
+ POP P,D\r
+ HRLI D,(D)\r
+ SUB P,D\r
+ JUMPE B,RMVDON\r
+ HRRZ D,0 ;PREPARE TO SPLICE (0 POINTS PRIOR TO LOSING PAIR)\r
+ HRRZ C,(C) ;GET NEXT OF LOSING PAIR\r
+ MOVEI 0,(B)\r
+ CAIGE 0,HIBOT ; SKIP IF PURE\r
+ JRST RMV2\r
+ PUSHJ P,IMPURIFY\r
+ MOVE A,-3(TP)\r
+ MOVE B,-2(TP)\r
+ MOVE C,(TP)\r
+ JRST IRMV1\r
+RMV2: HRRM C,(D) ;AND SPLICE\r
+ SETZM 2(B) ; CLOBBER OBLIST SLOT\r
+RMVDON: SUB TP,[4,,4]\r
+ POPJ P,\r
+\r
+\f\r
+;INTERNAL CALL FROM THE READER\r
+\r
+RLOOKU: PUSH TP,$TFIX ;PUSH A FLAG\r
+ POP P,C ;POP OFF RET ADR\r
+ PUSH TP,C ;AND USE AS A FLAG FOR INTERNAL\r
+ MOVE C,(P) ; CHANGE CHAR COUNT TO WORD\r
+ ADDI C,4\r
+ IDIVI C,5\r
+ MOVEM C,(P)\r
+\r
+ CAMN A,$TOBLS ;IS IT ONE OBLIST?\r
+ JRST RLOOK1\r
+ CAME A,$TLIST ;IS IT A LIST\r
+ JRST BADOBL\r
+\r
+ JUMPE B,BADLST\r
+ PUSH TP,$TOBLS ; SLOT FOR REMEBERIG\r
+ PUSH TP,[0]\r
+ PUSH TP,$TOBLS\r
+ PUSH TP,[0]\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+\r
+RLOOK2: GETYP A,(B) ;CHECK THIS IS AN OBLIST\r
+ MOVE B,1(B) ;VALUE\r
+ CAIE A,TOBLS\r
+ JRST DEFALT\r
+ PUSHJ P,ILOOK ;LOOK IT UP\r
+ JUMPN B,RLOOK3 ;WIN\r
+ SKIPE -2(TP) ; SKIP IF DEFAULT NOT STORED\r
+ JRST RLOOK4\r
+ HRRZ D,(TP) ; GET CURRENT\r
+ MOVE D,1(D) ; OBLIST\r
+ MOVEM D,-2(TP)\r
+ MOVEM C,-4(TP) ; FOR INSERT IF NEEDED\r
+RLOOK4: INTGO\r
+ HRRZ B,@(TP) ;CDR THE LIST\r
+ HRRZM B,(TP)\r
+ JUMPN B,RLOOK2\r
+ SKIPN D,-2(TP) ; RESTORE FOR INSERT\r
+ JRST BADDEF ; NO DEFAULT, USER LOST ON SPECIFICATION\r
+ MOVE C,-4(TP)\r
+ SUB TP,[6,,6] ; FLUSH CRAP\r
+ JRST INSRT1\r
+\r
+DEFFLG==1 ;SPECIAL FLAG USED TO INDICATE THAT A DEFAULT HAS ALREADY BEEN SPECIFIED\r
+DEFALT: CAIN A,TATOM ;SPECIAL DEFAULT INDICATING ATOM ?\r
+ CAME B,MQUOTE DEFAULT\r
+ JRST BADDEF ;NO, LOSE\r
+ MOVSI A,DEFFLG\r
+ XORB A,-6(TP) ;SET AND TEST FLAG\r
+ TLNN A,DEFFLG ; HAVE WE BEEN HERE BEFORE ?\r
+ JRST BADDEF ; YES, LOSE\r
+ SETZM -2(TP) ;ZERO OUT PREVIOUS DEFAULT\r
+ SETZM -4(TP)\r
+ JRST RLOOK4 ;CONTINUE\r
+\r
+RLOOK1: PUSH TP,$TOBLS\r
+ PUSH TP,B ; SAVE OBLIST\r
+ PUSHJ P,ILOOK ;LOOK IT UP THERE\r
+ MOVE D,(TP) ; GET OBLIST\r
+ SUB TP,[2,,2]\r
+ JUMPE B,INSRT1 ;GO INSET IT\r
+\r
+\r
+INSRT2: JRST .+2 ;\r
+RLOOK3: SUB TP,[6,,6] ;POP OFF LOSSAGE\r
+ PUSHJ P,ILINK ;IF THIS IS A LINK FOLLOW IT\r
+ PUSH P,(TP) ;GET BACK RET ADR\r
+ SUB TP,[2,,2] ;POP TP\r
+ JRST IATM1 ;AND RETURN\r
+\r
+\r
+BADOBL: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE BAD-OBLIST-OR-LIST-THEREOF\r
+ JRST CALER1\r
+\r
+BADDEF: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE BAD-DEFAULT-OBLIST-SPECIFICATION\r
+ JRST CALER1\r
+\r
+ONOTH: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE ATOM-ON-DIFFERENT-OBLIST\r
+ JRST CALER1\r
+\f;SUBROUTINE TO MAKE AN ATOM\r
+\r
+MFUNCTION ATOM,SUBR\r
+\r
+ ENTRY 1\r
+\r
+ MOVE A,(AB)\r
+ MOVE B,1(AB)\r
+ PUSHJ P,IATOMI\r
+ JRST FINIS\r
+\r
+CATOM: SUBM M,(P)\r
+ PUSHJ P,IATOMI\r
+ JRST MPOPJ\r
+\r
+IATOMI: GETYP 0,A ;CHECK ARG TYPE\r
+ CAIE 0,TCHRS\r
+ CAIN 0,TCHSTR\r
+ JRST .+2 ;JUMP IF WINNERS\r
+ JRST WTYP1\r
+\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ MOVEI B,-1(TP)\r
+ MOVE A,0\r
+ PUSHJ P,CSTAK ;COPY ONTO STACK\r
+ PUSHJ P,IATOM ;NOW MAKE THE ATOM\r
+ POPJ P,\r
+\r
+;INTERNAL ATOM MAKER\r
+\r
+IATOM: MOVE A,-1(P) ;GET WORDS IN PNAME\r
+ ADDI A,3 ;FOR VALUE CELL\r
+ PUSHJ P,IBLOCK ; GET BLOCK\r
+ MOVSI C,<(GENERAL)>+SATOM+.VECT. ;FOR TYPE FIELD\r
+ MOVE D,-1(P) ;RE-GOBBLE LENGTH\r
+ ADDI D,3(B) ;POINT TO DOPE WORD\r
+ MOVEM C,(D)\r
+ SKIPG -1(P) ;EMPTY PNAME ?\r
+ JRST IATM0 ;YES, NO CHARACTERS TO MOVE\r
+ MOVE E,B ;COPY ATOM POINTER\r
+ ADD E,[3,,3] ;POINT TO PNAME AREA\r
+ MOVEI C,-1(P)\r
+ SUB C,-1(P) ;POINT TO STRING ON STACK\r
+ MOVE D,(C) ;GET SOME CHARS\r
+ MOVEM D,(E) ;AND COPY THEM\r
+ ADDI C,1\r
+ AOBJN E,.-3\r
+IATM0: MOVSI A,TATOM ;TYPE TO ATOM\r
+IATM1: POP P,D ;RETURN ADR\r
+ POP P,C\r
+ HRLI C,(C)\r
+ SUB P,C\r
+ JRST (D) ;RETURN\r
+\r
+\f;SUBROUTINE TO GET AN ATOM'S PNAME\r
+\r
+MFUNCTION PNAME,SUBR\r
+\r
+ ENTRY 1\r
+\r
+ GETYP A,(AB)\r
+ CAIE A,TATOM ;CHECK TYPE IS ATOM\r
+ JRST WTYP1\r
+ MOVE A,1(AB)\r
+ PUSHJ P,IPNAME\r
+ JRST FINIS\r
+\r
+CIPNAM: SUBM M,(P)\r
+ PUSHJ P,IPNAME\r
+ JRST MPOPJ\r
+\r
+IPNAME: ADD A,[3,,3]\r
+ HLRE B,A\r
+ MOVM B,B\r
+ PUSH P,(A) ;FLUSH PNAME ONTO P\r
+ AOBJN A,.-1\r
+ IMULI B,5 ; CHARS TO B\r
+ MOVE 0,(P) ; LAST WORD\r
+ MOVE A,0\r
+ SUBI A,1 ; FIND LAST 1\r
+ ANDCM 0,A ; 0 HAS 1ST 1\r
+ JFFO 0,.+1\r
+ HRREI 0,-34.(A) ; FIND HOW MUCH TO ADD\r
+ IDIVI 0,7\r
+ ADD B,0\r
+ PUSH P,B\r
+ PUSHJ P,CHMAK ;MAKE A STRING\r
+ POPJ P,\r
+\r
+\f; BLOCK STRUCTURE SUBROUTINES FOR MUDDLE\r
+\r
+MFUNCTION BLK,SUBR,BLOCK\r
+\r
+ ENTRY 1\r
+\r
+ GETYP A,(AB) ;CHECK TYPE OF ARG\r
+ CAIE A,TOBLS ;IS IT AN OBLIST\r
+ CAIN A,TLIST ;OR A LIAT\r
+ JRST .+2\r
+ JRST WTYP1\r
+ MOVSI A,TATOM ;LOOK UP OBLIST\r
+ MOVE B,IMQUOTE OBLIST\r
+ PUSHJ P,IDVAL ;GET VALUE\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ PUSH TP,.BLOCK(PVP) ;HACK THE LIST\r
+ PUSH TP,.BLOCK+1(PVP)\r
+ MCALL 2,CONS ;CONS THE LIST\r
+ MOVEM A,.BLOCK(PVP) ;STORE IT BACK\r
+ MOVEM B,.BLOCK+1(PVP)\r
+ PUSH TP,$TATOM\r
+ PUSH TP,IMQUOTE OBLIST\r
+ PUSH TP,(AB)\r
+ PUSH TP,1(AB)\r
+ MCALL 2,SET ;SET OBLIST TO ARG\r
+ JRST FINIS\r
+\r
+MFUNCTION ENDBLOCK,SUBR\r
+\r
+ ENTRY 0\r
+\r
+ SKIPN B,.BLOCK+1(PVP) ;IS THE LIST NIL?\r
+ JRST BLKERR ;YES, LOSE\r
+ HRRZ C,(B) ;CDR THE LIST\r
+ HRRZM C,.BLOCK+1(PVP)\r
+ PUSH TP,$TATOM ;NOW RESET OBLIST\r
+ PUSH TP,IMQUOTE OBLIST\r
+ HLLZ A,(B) ;PUSH THE TYPE OF THE CAR\r
+ PUSH TP,A\r
+ PUSH TP,1(B) ;AND VALUE OF CAR\r
+ MCALL 2,SET\r
+ JRST FINIS\r
+\r
+BLKERR: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE UNMATCHED\r
+ JRST CALER1\r
+\r
+BADLST: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE NIL-LIST-OF-OBLISTS\r
+ JRST CALER1\r
+\f;SUBROUTINE TO CREATE CHARACTER STRING GOODIE\r
+\r
+CHMAK: MOVE A,-1(P)\r
+ ADDI A,4\r
+ IDIVI A,5\r
+ PUSHJ P,IBLOCK\r
+ MOVEI C,-1(P) ;FIND START OF CHARS\r
+ HLRE E,B ; - LENGTH\r
+ ADD C,E ;C POINTS TO START\r
+ MOVE D,B ;COPY VECTOR RESULT\r
+ JUMPGE D,NULLST ;JUMP IF EMPTY\r
+ MOVE A,(C) ;GET ONE\r
+ MOVEM A,(D)\r
+ ADDI C,1 ;BUMP POINTER\r
+ AOBJN D,.-3 ;COPY\r
+NULLST: MOVSI C,TCHRS+.VECT. ;GET TYPE\r
+ MOVEM C,(D) ;CLOBBER IT IN\r
+ MOVE A,-1(P) ; # WORDS\r
+ HRLI A,TCHSTR\r
+ HRLI B,440700\r
+ MOVMM E,-1(P) ; SO IATM1 WORKS\r
+ JRST IATM1 ;RETURN\r
+\r
+; SUBROUTINE TO READ FIVE CHARS FROM STRING.\r
+; TWO CALLS, ONE WITH A POINTING TO LIST ELEMENT,\r
+; THE OTHER WITH B POINTING TO PAIR. SKIPS IF WINNER, ELSE DOESNT\r
+\r
+NXTDCL: GETYP B,(A) ;CHECK TYPE\r
+ CAIE B,TDEFER ;LOSE IF NOT DEFERRED\r
+ POPJ P,\r
+\r
+ MOVE B,1(A) ;GET REAL BYTE POINTER\r
+CHRWRD: PUSH P,C\r
+ GETYP C,(B) ;CHECK IT IS CHSTR\r
+ CAIE C,TCHSTR\r
+ JRST CPOPJC ;NO, QUIT\r
+ PUSH P,D\r
+ PUSH P,E\r
+ PUSH P,0\r
+ MOVEI E,0 ;INITIALIZE DESTINATION\r
+ HRRZ C,(B) ; GET CHAR COUNT\r
+ JUMPE C,GOTDCL ; NULL, FINISHED\r
+ MOVE B,1(B) ;GET BYTE POINTER\r
+ MOVE D,[440700,,E] ;BYTE POINT TO E\r
+CHLOOP: ILDB 0,B ; GET A CHR\r
+ IDPB 0,D ;CLOBBER AWAY\r
+ SOJE C,GOTDCL ; JUMP IF DONE\r
+ TLNE D,760000 ; SKIP IF WORD FULL\r
+ JRST CHLOOP ; MORE THAN 5 CHARS\r
+ TRO E,1 ; TURN ON FLAG\r
+\r
+GOTDCL: MOVE B,E ;RESULT TO B\r
+ AOS -4(P) ;SKIP RETURN\r
+CPOPJ0: POP P,0\r
+ POP P,E\r
+ POP P,D\r
+CPOPJC: POP P,C\r
+ POPJ P,\r
+\r
+; SUBROUTINE TO FIND A BYTE STRINGS DOPE WORD\r
+; RECEIVES POINTER TO PAIR CONNTAINIGN CHSTR IN C, RETURNS DOPE WORD IN A\r
+\r
+BYTDOP: PUSH P,B ; SAVE SOME ACS\r
+ PUSH P,D\r
+ PUSH P,E\r
+ MOVE B,1(C) ; GET BYTE POINTER\r
+ LDB D,[360600,,B] ; POSITION TO D\r
+ LDB E,[300600,,B] ; AND BYTE SIZE\r
+ MOVEI A,(E) ; A COPY IN A\r
+ IDIVI D,(E) ; D=> # OF BYTES IN WORD 1\r
+ HRRZ E,(C) ; GET LENGTH\r
+ SUBM E,D ; # OF BYTES IN OTHER WORDS\r
+ JUMPL D,BYTDO1 ; NEAR DOPE WORD\r
+ MOVEI B,36. ; COMPUTE BYTES PER WORD\r
+ IDIVM B,A\r
+ ADDI D,-1(A) ; NOW COMPUTE WORDS\r
+ IDIVI D,(A) ; D/ # NO. OF WORDS PAST 1ST\r
+ ADD D,1(C) ; D POINTS TO DOPE WORD\r
+ MOVEI A,2(D)\r
+\r
+BYTDO2: POP P,E\r
+ POP P,D\r
+ POP P,B\r
+ POPJ P,\r
+BYTDO1: MOVEI A,1(B)\r
+ CAME D,[-5]\r
+ AOJA A,BYTDO2\r
+ JRST BYTDO2\r
+\f;ROUTINES TO DEFINE AND HANDLE LINKS\r
+\r
+MFUNCTION LINK,SUBR\r
+ ENTRY\r
+ CAML AB,[-6,,0] ;NO MORE THAN 3 ARGS\r
+ CAML AB,[-2,,0] ;NO LESS THAN 2 ARGS\r
+ JRST WNA\r
+ CAML AB,[-4,,0] ;ONLY TWO ARGS SUPPLIED ?\r
+ JRST GETOB ;YES, GET OBLIST FROM CURRENT PATH\r
+ MOVE A,2(AB)\r
+ MOVE B,3(AB)\r
+ MOVE C,5(AB)\r
+ JRST LINKIN\r
+GETOB: MOVSI A,TATOM\r
+ MOVE B,IMQUOTE OBLIST\r
+ PUSHJ P,IDVAL\r
+ CAMN A,$TOBLS\r
+ JRST LINKP\r
+ CAME A,$TLIST\r
+ JRST BADOBL\r
+ JUMPE B,BADLST\r
+ GETYPF A,(B)\r
+ MOVE B,(B)+1\r
+LINKP: MOVE C,B\r
+ MOVE A,2(AB)\r
+ MOVE B,3(AB)\r
+LINKIN: PUSHJ P,IINSRT\r
+ CAMN A,$TFALSE ;LINK NAME ALREADY USED ?\r
+ JRST ALRDY ;YES, LOSE\r
+ MOVE C,B\r
+ MOVE A,(AB)\r
+ MOVE B,1(AB)\r
+ PUSHJ P,CSETG\r
+ JRST FINIS\r
+\r
+\r
+ILINK: CAME A,$TLINK ;FOUND A LINK ?\r
+ POPJ P, ;NO, FINISHED\r
+ MOVSI A,TATOM\r
+ PUSHJ P,IGVAL ;GET THE LINK'S DESTINATION\r
+ CAME A,$TUNBOUND ;WELL FORMED LINK ?\r
+ POPJ P, ;YES\r
+ PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE BAD-LINK\r
+ JRST CALER1\r
+\r
+\f\r
+; THIS SUBROUTINE IMPURIFIES A PURE ATOM TO ALLOW MODIFICATION OF SYSTEM SUBRS\r
+\r
+IMPURIFY:\r
+ PUSH TP,$TATOM\r
+ PUSH TP,B\r
+ MOVE C,B\r
+ MOVEI 0,(C)\r
+ CAIGE 0,HIBOT\r
+ JRST RTNATM ; NOT PURE, RETURN\r
+\r
+; 1) IMPURIFY ITS OBLIST BUCKET\r
+\r
+ SKIPN B,2(C) ; PICKUP OBLIST IF IT EXISTS\r
+ JRST IMPUR1 ; NOT ON ONE, IGNORE THIS CODE\r
+\r
+ ADDI B,(TVP) ; POINT TO SLOT\r
+ MOVE B,(B) ; GET THE REAL THING\r
+ ADD C,[3,,3] ; POINT TO PNAME\r
+ HLRE A,C ; GET LNTH IN WORDS OF PNAME\r
+ MOVNS A\r
+ PUSH P,[IMPUR2] ; FAKE OUT ILOOKC\r
+ PUSH P,(C) ; PUSH UP THE PNAME\r
+ AOBJN C,.-1\r
+ PUSH P,A ; NOW THE COUNT\r
+ JRST ILOOKC ; GO FIND BUCKET\r
+\r
+IMPUR2: JUMPE B,IMPUR1 ; NOT THERE, GO\r
+ PUSH TP,$TOBLS ; SAVE BUCKET\r
+ PUSH TP,E\r
+\r
+ MOVE B,(E) ; GET NEXT ONE\r
+IMPUR4: MOVEI 0,(B)\r
+ CAIGE 0,HIBOT ; SKIP IF PURE\r
+ JRST IMPUR3 ; FOUND IMPURE NESS, SKIP IT\r
+ HLLZ C,(B) ; SET UP ICONS CALL\r
+ HRRZ E,(B)\r
+ MOVE D,1(B)\r
+ PUSHJ P,ICONS ; CONS IT UP\r
+ HRRZ E,(TP) ; RETRV PREV\r
+ HRRM B,(E) ; AND CLOBBER\r
+IMPUR3: MOVSI 0,TLIST\r
+ MOVEM 0,-1(TP) ; FIX TYPE\r
+ HRRZM B,(TP) ; STORE GOODIE\r
+ HRRZ B,(B) ; CDR IT\r
+ JUMPN B,IMPUR4 ; LOOP\r
+ SUB TP,[2,,2] ; FLUSH TP CRUFT\r
+\r
+; 2) GENERATE A DUPLICATE ATOM\r
+\r
+IMPUR1: HLRE A,(TP) ; GET LNTH OF ATOM\r
+ MOVNS A\r
+ PUSH P,A\r
+ PUSHJ P,IBLOCK ; GET NEW BLOCK FOR ATOM\r
+ PUSH TP,$TATOM\r
+ PUSH TP,B\r
+ HRL B,-2(TP) ; SETUP BLT\r
+ POP P,A\r
+ ADDI A,(B) ; END OF BLT\r
+ BLT B,(A) ; CLOBBER NEW ATOM\r
+ MOVSI B,.VECT. ; TURN ON BIT FOR GCHACK\r
+ IORM B,(A)\r
+\r
+; 3) NOW COPY GLOBAL VALUE\r
+\r
+ MOVE B,(TP) ; ATOM BACK\r
+ GETYP 0,(B)\r
+ SKIPE A,1(B) ; NON-ZER POINTER?\r
+ CAIN 0,TUNBOU ; BOUND?\r
+ JRST IMPUR5 ; NO, DONT COPY GLOB VAL\r
+ PUSH TP,$TATOM\r
+ PUSH TP,B\r
+ PUSH TP,(A)\r
+ PUSH TP,1(A) \r
+ SETZM (B)\r
+ SETZM 1(B)\r
+ MCALL 2,SETG\r
+IMPUR5: PUSH TP,$TFIX ;SAVE OLD ATOM WITH FUNNY TYPE TO AVOID LOSSAGE\r
+ PUSH TP,-3(TP)\r
+\r
+; 4) UPDATE ALL POINTERS TO THIS ATOM\r
+\r
+ MOVE A,[PUSHJ P,ATFIX] ; INS TO PASS TO GCHACK\r
+ PUSHJ P,GCHACK\r
+ SUB TP,[4,,4]\r
+\r
+RTNATM: POP TP,B\r
+ POP TP,A\r
+ POPJ P,\r
+\r
+; ROUTINE PASSED TO GCHACK\r
+\r
+ATFIX: CAIE C,TGATOM ; GLOBAL TYPE ATOM\r
+ CAIN C,TATOM\r
+ CAME D,(TP) ; SKIP IF WINNER\r
+ POPJ P,\r
+ MOVE D,-2(TP)\r
+ SKIPE B\r
+ MOVEM D,1(B)\r
+ POPJ P,\r
+\r
+\r
+END\r
+\f\f\r
+TITLE PROCESS-HACKER FOR MUDDLE\r
+\r
+RELOCATABLE\r
+\r
+.INSRT MUDDLE >\r
+\r
+.GLOBAL ICR,NAPT,IGVAL,CHKARG,RESFUN,RETPROC,SWAP,MAINPR,PROCHK,NOTRES\r
+.GLOBAL PSTAT,LSTRES,TOPLEV,MAINPR,1STEPR,INCONS\r
+.GLOBAL TBINIT,APLQ\r
+\r
+MFUNCTION PROCESS,SUBR\r
+\r
+ ENTRY 1\r
+ GETYP A,(AB) ;GET TYPE OF ARG\r
+ ;MUST BE SOME APPLIABLE TYPE\r
+ PUSHJ P,APLQ\r
+ JRST NAPT ;NO, ERROR - NON-APPLIABLE TYPE\r
+OKFUN:\r
+\r
+ PUSHJ P,ICR ;CREATE A NEW PROCESS\r
+ MOVE C,TPSTO+1(B) ;GET ITS SRTACK\r
+ PUSH C,[TENTRY,,TOPLEV]\r
+ PUSH C,[1,,0] ;TIME\r
+ PUSH C,[0]\r
+ PUSH C,SPSTO+1(B)\r
+ PUSH C,PSTO+1(B)\r
+ MOVE D,C\r
+ ADD D,[3,,3]\r
+ PUSH C,D ;SAVED STACK POINTER\r
+ PUSH C,[SUICID]\r
+ MOVEM C,TPSTO+1(B) ;STORE NEW TP\r
+ HRRI D,1(C) ;MAKE A TB\r
+ HRLI D,2 ;WITH A TIME\r
+ MOVEM D,TBINIT+1(B)\r
+ MOVEM D,TBSTO+1(B) ;SAVE ALSO FOR SIMULATED START\r
+ MOVE C,(AB) ;STORE ARG\r
+ MOVEM C,RESFUN(B) ;INTO PV\r
+ MOVE C,1(AB)\r
+ MOVEM C,RESFUN+1(B)\r
+ MOVEI 0,RUNABL\r
+ MOVEM 0,PSTAT+1(B)\r
+ JRST FINIS\r
+\r
+REPEAT 0,[\r
+MFUNCTION RETPROC,SUBR\r
+; WHO KNOWS WHAT THIS SHOULD REALLY DO\r
+;PROBABLY, JUST AN EXIT\r
+;FOR NOW, PRINT OUT AN ERROR MESSAGE\r
+ PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE ATTEMPT-TO-RETURN-OUT-OF-PROCESS\r
+ JRST CALER1\r
+\r
+\r
+\r
+\r
+\r
+\r
+\r
+MFUNCTION RESUME,FSUBR\r
+;RESUME IS CALLED WITH TWO ARGS\r
+;THE FIRST IS A PROCESS FORM OF THE PROCESS TO BE RESUMED\r
+;THE SECOND IS A FUNCTION TO BE CALLED WHEN THIS PROCESS\r
+; (THE PARENT) IS ITSELF RESUMED\r
+;IF THE FUNCTION IS NOT GIVEN SOME STANDARD FUNCTION IS\r
+;PLUGGED IN\r
+;\r
+; NOTE - TYPE AND NUMBER OF ARGS CHECKS MUST BE ADDED TO BOTH RESUME AND CREATE\r
+\r
+ ENTRY 1\r
+ HRRZ C,@1(AB) ;GET CDR ADDRESS\r
+ JUMPE C,NOFUN ;IF NO SECOND ARG, SUPPLY STANDARD\r
+ HLLZ A,(C) ;GET CDR TYPE\r
+ CAME A,$TATOM ;ATOMIC?\r
+ JRST RES2 ;NO, MUST EVAL TO GET FUNCTION\r
+ MOVE B,1(C) ;YES\r
+ PUSHJ P,IGVAL ;TRY TO GET GLOBAL VALUE\r
+ CAMN A,$TUNBOUND ;GLOBALLY UNBOUND?\r
+ JRST LFUN ;YES, TRY FOR LOCAL VALUE\r
+RES1: MOVEM A,RESFUN(PVP) ;STORE IN THIS PROCESS\r
+ MOVEM B,RESFUN+1(PVP)\r
+\r
+ HRRZ C,1(AB) ;GET CAR ADDRESS\r
+ PUSH TP,(C) ;PUSH PROCESS FORM\r
+ PUSH TP,1(C)\r
+ JSP E,CHKARG ;CHECK FOR DEFERED TYPE\r
+ ;INSERT CHECKS FOR PROCESS FORM\r
+ MCALL 1,EVAL ;EVAL PROCESS FORM WHICH WILL SWITCH\r
+ ; PROCESSES\r
+ JRST FINIS\r
+\r
+RES2: PUSH TP,(C) ;PUSH FUNCTION ARG\r
+ PUSH TP,1(C)\r
+ JSP E,CHKARG ;CHECK FOR DEFERED\r
+ MCALL 1,EVAL ;EVAL TO GET FUNCTION\r
+ JRST RES1\r
+\r
+LFUN: HRRZ C,1(AB) ;GET CDR ADDRESS\r
+ PUSH TP,(C)\r
+ PUSH TP,1(C)\r
+ MCALL 1,VALUE ;GET LOCAL VALUE OF ATOM FOR FUNCTION\r
+ JRST RES1\r
+\r
+NOFUN: MOVSI A,TUNBOUND ;MAKE RESUME FUNCTION UNBOUND\r
+ JRST RES1\r
+]\r
+\r
+; PROCHK - SETUP LAST RESUMER SLOT\r
+\r
+PROCHK: CAME B,MAINPR ; MAIN PROCESS?\r
+ MOVEM PVP,LSTRES+1(B)\r
+ POPJ P,\r
+\r
+; THIS FUNCTION RESUMES A PROCESS, CALLED WITH ONE OR TWO ARGS\r
+; THE FIRST IS A VALUE TO RETURN TO THE OTHER PROCESS OR PASS TO ITS\r
+; RESFUN\r
+; THE SECOND IS THE PROCESS TO RESUME (IF NOT SUPPLIED, USE THE LSTRES)\r
+\r
+\r
+MFUNCTION RESUME,SUBR\r
+\r
+ ENTRY\r
+ JUMPGE AB,TFA\r
+ CAMGE AB,[-4,,0]\r
+ JRST TMA\r
+ CAMGE AB,[-2,,0]\r
+ JRST CHPROC ; VALIDITY CHECK ON PROC\r
+ SKIPN B,LSTRES+1(PVP) ; ANY RESUMERS?\r
+ JRST NORES ; NO, COMPLAIN\r
+GOTPRO: MOVE C,AB\r
+ CAMN B,PVP ; DO THEY DIFFER?\r
+ JRST RETARG\r
+ MOVE A,PSTAT+1(B) ; CHECK STATE\r
+ CAIE A,RUNABL ; MUST BE RUNABL\r
+ CAIN A,RESMBL ; OR RESUMABLE\r
+ JRST RESUM1\r
+NOTRES:\r
+NOTRUN: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE PROCESS-NOT-RUNABLE-OR-RESUMABLE\r
+ JRST CALER1\r
+\r
+RESUM1: PUSHJ P,PROCHK ; FIX LISTS UP\r
+ MOVEI A,RESMBL ; GET NEW STATE\r
+ MOVE D,B ; FOR SWAP\r
+STRTN: JSP C,SWAP ; SWAP THEM\r
+ MOVEM A,PSTAT+1(E) ; CLOBBER OTHER STATE\r
+ MOVE A,PSTAT+1(PVP) ; DECIDE HOW TO PROCEED\r
+ MOVEI 0,RUNING\r
+ MOVEM 0,PSTAT+1(PVP) ; NEW STATE\r
+ MOVE C,ABSTO+1(E) ; OLD ARGS\r
+ CAIE A,RESMBL\r
+ JRST DORUN ; THEY DO RUN RUN, THEY DO RUN RUN\r
+RETARG: MOVE A,(C)\r
+ MOVE B,1(C) ; RETURN\r
+ JRST FINIS\r
+\r
+DORUN: PUSH TP,RESFUN(PVP)\r
+ PUSH TP,RESFUN+1(PVP)\r
+ PUSH TP,(C)\r
+ PUSH TP,1(C)\r
+ MCALL 2,APPLY\r
+ PUSH TP,A ; CALL SUICIDE WITH THESE ARGS\r
+ PUSH TP,B\r
+ MCALL 1,SUICID ; IF IT RETURNS, KILL IT\r
+ JRST FINIS\r
+\r
+CHPROC: GETYP A,2(AB)\r
+ CAIE A,TPVP\r
+ JRST WTYP2\r
+ MOVE B,3(AB)\r
+ JRST GOTPRO\r
+\r
+NORES: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE NO-PROCESS-TO-RESUME\r
+ JRST CALER1\r
+\r
+; FUNCTION TO CAUSE PROCESSES TO SELF DESTRUCT\r
+\r
+MFUNCTION SUICIDE,SUBR\r
+\r
+ ENTRY\r
+\r
+ JUMPGE AB,TFA\r
+ HLRE A,AB\r
+ ASH A,-1 ; DIV BY 2\r
+ AOJE A,NOPROC ; NO PROCESS GIVEN\r
+ AOJL A,TMA\r
+ GETYP A,2(AB) ; MAKE SURE OF PROCESS\r
+ CAIE A,TPVP\r
+ JRST WTYP2\r
+ MOVE C,3(AB)\r
+ JRST SUIC2\r
+\r
+NOPROC: SKIPN C,LSTRES+1(PVP) ; MAKE SURE OF EDLIST\r
+ MOVE C,MAINPR ; IF NOT DEFAULT TO MAIN\r
+SUIC2: CAMN C,PVP ; DONT SUICIDE TO SELF\r
+ JRST SUSELF\r
+ MOVE B,PSTAT+1(C)\r
+ CAIE B,RUNABL\r
+ CAIN B,RESMBL\r
+ JRST .+2\r
+ JRST NOTRUN\r
+ MOVE B,C\r
+ PUSHJ P,PROCHK\r
+ MOVE D,B ; RESTORE NEWPROCESS\r
+ MOVEI A,DEAD\r
+ JRST STRTN\r
+\r
+SUSELF: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE ATTEMPT-TO-SUICIDE-TO-SELF\r
+ JRST CALER1\r
+\r
+\r
+MFUNCTION RESER,SUBR,RESUMER\r
+\r
+ ENTRY\r
+ MOVE B,PVP\r
+ JUMPGE AB,GTLAST\r
+ CAMGE AB,[-2,,0]\r
+ JRST TMA\r
+\r
+ GETYP A,(AB) ; CHECK FOR PROCESS\r
+ CAIE A,TPVP\r
+ JRST WTYP1\r
+ MOVE B,1(AB) ; GET PROCESS\r
+GTLAST: MOVSI A,TFALSE ; ASSUME NONE\r
+ SKIPN B,LSTRES+1(B) ; GET IT IF IT EXISTS\r
+ JRST FINIS\r
+ MOVSI A,TPVP ; GET TYPE\r
+ JRST FINIS\r
+\r
+; FUNCTION TO PUT AN EVAL CALL ON ANOTHER PROCESSES STACK\r
+\r
+MFUNCTION BREAKSEQ,SUBR,BREAK-SEQ\r
+\r
+ ENTRY 2\r
+\r
+ GETYP A,2(AB) ; 2D ARG MUST BE PROCESS\r
+ CAIE A,TPVP\r
+ JRST WTYP2\r
+\r
+ MOVE B,3(AB) ; GET PROCESS\r
+ CAMN B,PVP ; SKIP IF NOT ME\r
+ JRST BREAKM\r
+ MOVE A,PSTAT+1(B) ; CHECK STATE\r
+ CAIE A,RESMBL ; BEST BE RESUMEABLE\r
+ JRST NOTRUN\r
+ MOVE C,TBSTO+1(B) ; GET SAVE ACS TO BUILD UP A DUMMY FRAME\r
+ MOVE D,TPSTO+1(B) ; STACK POINTER\r
+ MOVE E,SPSTO+1(B) ; FIX UP OLD FRAME\r
+ MOVEM E,SPSAV(C)\r
+ MOVEI E,CALLEV ; FUNNY PC\r
+ MOVEM E,PCSAV(C)\r
+ MOVE E,PSTO+1(B) ; SET UP P,PP AND TP SAVES\r
+ MOVEM E,PSAV(C)\r
+ PUSH D,[0] ; ALLOCATES SOME SLOTS\r
+ PUSH D,[0]\r
+ PUSH D,(AB) ; NOW THAT WHIC IS TO BE EVALLED\r
+ PUSH D,1(AB)\r
+ MOVEM D,TPSAV(C)\r
+ HRRI E,-1(D) ; BUILD UP ARG POINTER\r
+ HRLI E,-2\r
+ PUSH D,[TENTRY,,BREAKE]\r
+ PUSH D,C ; OLD TB\r
+ PUSH D,E ; NEW ARG POINTER\r
+REPEAT 4,PUSH D,[0] ; OTHER SLOTS\r
+ MOVEM D,TPSTO+1(B)\r
+ MOVEI C,(D) ; BUILD NEW AB\r
+ AOBJN C,.+1\r
+ MOVEM C,TBSTO+1(B) ; STORE IT\r
+ MOVE A,2(AB) ; RETURN PROCESS\r
+ MOVE B,3(AB)\r
+ JRST FINIS\r
+\r
+MQUOTE BREAKER\r
+\r
+BREAKE: \r
+CALLEV: MOVEM A,-3(TP) ; HERE TO EVAL THE GOODIE (SAVE REAL RESULT)\r
+ MOVEM B,-2(TP)\r
+ MCALL 1,EVAL\r
+ POP TP,B\r
+ POP TP,A\r
+ JRST FINIS\r
+\r
+BREAKM: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE ATTEMPT-TO-BREAK-OWN-SEQUENCE\r
+ JRST CALER1\r
+\r
+; FUNCTION TOP PUT PROCESS IN 1 STEP MODE\r
+\r
+MFUNCTION 1STEP,SUBR\r
+ PUSHJ P,1PROC\r
+ MOVEM PVP,1STEPR+1(B) ; CLOBBER TARGET PROCESS\r
+ JRST FINIS\r
+\r
+; FUNCTION TO UNDO ABOVE\r
+\r
+MFUNCTION %%FREE,SUBR,FREE-RUN\r
+ PUSHJ P,1PROC\r
+ CAME PVP,1STEPR+1(B)\r
+ JRST FNDBND\r
+ SETZM 1STEPR+1(B)\r
+ JRST FINIS\r
+\r
+FNDBND: SKIPE 1STEPR+1(B) ; DOES IT HAVE ANY 1STEPPER?\r
+ JRST NOTMIN ; YES, COMPLAIN\r
+ MOVE D,B ; COPY PROCESS\r
+ ADD D,[1STEPR,,1STEPR] ; POINTER FOR SEARCH\r
+ HRRZ C,SPSTO+1(B) ; GET THIS BINDING STACK\r
+\r
+FNDLP: GETYP 0,(C) ; IS THIS A TBVL?\r
+ CAIN 0,TBVL\r
+ CAME D,1(C) ; SKIP IF THIS IS SAVED 1STEP SLOT\r
+ JRST FNDNXT\r
+ SKIPN 3(C) ; IS IT SAVING A REAL 1STEPPER?\r
+ JRST FNDNXT\r
+ CAME PVP,3(C) ; IS IT ME?\r
+ JRST NOTMIN\r
+ SETZM 3(C) ; CLEAR OUT SAVED 1STEPPER\r
+ JRST FINIS\r
+FNDNXT: HRRZ C,(C) ; NEXT BINDING\r
+ JUMPN C,FNDLP\r
+\r
+NOTMIN: MOVE C,$TCHSTR\r
+ MOVE D,CHQUOTE NOT-YOUR-1STEPEE\r
+ PUSHJ P,INCONS\r
+ MOVSI A,TFALSE\r
+ JRST FINIS\r
+\r
+1PROC: ENTRY 1\r
+ GETYP A,(AB)\r
+ CAIE A,TPVP\r
+ JRST WTYP1\r
+ MOVE B,1(AB)\r
+ MOVE A,(AB)\r
+ POPJ P,\r
+\r
+; FUNCTION TO RETRUN THE MAIN PROCESS\r
+\r
+MFUNCTION MAIN%%,SUBR,MAIN\r
+ ENTRY 0\r
+\r
+ MOVE B,MAINPR\r
+MAIN1: MOVSI A,TPVP\r
+ JRST FINIS\r
+\r
+; FUNCTION TO RETURN THE CURRENT PROCESS\r
+\r
+MFUNCTION ME,SUBR\r
+ ENTRY 0\r
+\r
+ MOVE B,PVP\r
+ JRST MAIN1\r
+\r
+; FUNCTION TO RETURN THE STATE OF A PROCESS\r
+\r
+MFUNCTION STATE,SUBR\r
+ ENTRY 1\r
+ GETYP A,(AB)\r
+ CAIE A,TPVP\r
+ JRST WTYP1\r
+ MOVE A,1(AB) ; GET PROCESS\r
+ MOVE A,PSTAT+1(A)\r
+ MOVE B,@STATES(A) ; GET STATE\r
+ MOVSI A,TATOM\r
+ JRST FINIS\r
+\r
+STATES:\r
+ IRP A,,[ILLEGAL,RUNABLE,RESUMABLE,RUNNING,DEAD,BLOCKED]\r
+ MQUOTE A\r
+ TERMIN\r
+\r
+\r
+\r
+END\r
+\f\r
+TITLE DECLARATION PROCESSOR\r
+\r
+RELOCA\r
+\r
+.INSRT MUDDLE >\r
+\r
+.GLOBAL STBL,TYPFND,TYPSGR,CHKDCL,TESTR,VALG,INCR1,TYPG,ISTRUC,TMATCH,SAT\r
+.GLOBAL TYPMIS,CHKAB,CHKARG,IGDECL,LOCQQ,APLQ,CALER,IEQUAL,IIGLOC,IGLOC\r
+.GLOBAL CHLOCI,INCONS,SPCCHK,WTYP1\r
+\r
+; Subr to allow user to access the DECL checking code\r
+\r
+MFUNCTION CHECKD,SUBR,[DECL?]\r
+\r
+ ENTRY 2\r
+\r
+ MOVE C,(AB)\r
+ MOVE D,1(AB)\r
+ MOVE A,2(AB)\r
+ MOVE B,3(AB)\r
+ PUSHJ P,TMATCX ; CHECK THEM\r
+ JRST IFALS\r
+\r
+RETT: MOVSI A,TATOM\r
+ MOVE B,MQUOTE T\r
+ JRST FINIS\r
+\r
+RETF:\r
+IFALS: MOVEI B,0\r
+ MOVSI A,TFALSE\r
+ JRST FINIS\r
+\r
+; Subr to turn DECL checking on and off.\r
+\r
+MFUNCTION %DECL,SUBR,[DECL-CHECK]\r
+\r
+ ENTRY 1\r
+\r
+ GETYP 0,(AB)\r
+ SETZM IGDECL\r
+ CAIN 0,TFALSE\r
+ SETOM IGDECL\r
+ MOVE A,(AB)\r
+ MOVE B,1(AB)\r
+ JRST FINIS\r
+\r
+; Change special unspecial normal mode\r
+\r
+MFUNCTION SPECM%,SUBR,[SPECIAL-MODE]\r
+\r
+ ENTRY\r
+\r
+ CAMGE AB,[-3,,]\r
+ JRST TMA\r
+ MOVE C,SPCCHK ; GET CURRENT\r
+ JUMPGE AB,MODER ; RET CURRENT\r
+ GETYP 0,(AB) ; CHECK IT IS ATOM\r
+ CAIE 0,TATOM\r
+ JRST WTYP1\r
+ MOVE 0,1(AB)\r
+ MOVEI A,1\r
+ CAMN 0,MQUOTE UNSPECIAL\r
+ MOVSI A,(SETZ)\r
+ CAMN 0,MQUOTE SPECIAL\r
+ MOVEI A,0\r
+ JUMPG A,WTYP1\r
+ HLLM A,SPCCHK\r
+\r
+MODER: MOVSI A,TATOM\r
+ MOVE B,MQUOTE SPECIAL\r
+ SKIPGE C\r
+ MOVE B,MQUOTE UNSPECIAL\r
+ JRST FINIS\r
+\r
+; Function to turn special checking on and of\r
+\r
+MFUNCTION SPECC%,SUBR,[SPECIAL-CHECK]\r
+\r
+ ENTRY\r
+ CAMGE AB,[-3,,]\r
+ JRST TMA\r
+\r
+ MOVE C,SPCCHK\r
+ JUMPGE AB,SCHEK1\r
+\r
+ MOVEI A,0\r
+ GETYP 0,(AB)\r
+ CAIE 0,TFALSE\r
+ MOVEI A,1\r
+ HRRM A,SPCCHK\r
+\r
+SCHEK1: TRNN C,1\r
+ JRST IFALS\r
+ JRST RETT\r
+\r
+; Finction to set decls for GLOBAL values.\r
+\r
+MFUNCTION GDECL,FSUBR\r
+\r
+ ENTRY 1\r
+\r
+ GETYP 0,(AB)\r
+ CAIE 0,TLIST\r
+ JRST WTYP1\r
+\r
+ PUSH TP,$TLIST\r
+ PUSH TP,1(AB)\r
+ PUSH TP,$TLIST\r
+ PUSH TP,[0]\r
+ PUSH TP,$TLIST\r
+ PUSH TP,[0]\r
+\r
+GDECL1: INTGO\r
+ SKIPN C,1(TB)\r
+ JRST RETT\r
+ HRRZ D,(C) ; MAKE SURE PAIRS\r
+ JUMPE D,GDECLL ; LOSER, GO AWAY\r
+ GETYP 0,(C)\r
+ CAIE 0,TLIST\r
+ JRST GDECLL\r
+ HRRZ 0,(D)\r
+ MOVEM 0,1(TB) ; READY FOR NEXT CALL\r
+ MOVE C,1(C) ; SAVE ATOM LIST\r
+ MOVEM C,5(TB)\r
+ MOVEM D,3(TB)\r
+\r
+GDECL2: INTGO\r
+ SKIPN C,5(TB)\r
+ JRST GDECL1 ; OUT OF ATOMS\r
+ GETYP 0,(C) ; IS THIS AN ATOM\r
+ CAIE 0,TATOM\r
+ JRST GDECLL ; NO, LOSE\r
+ MOVE B,1(C)\r
+ HRRZ C,(C)\r
+ MOVEM C,5(TB)\r
+ PUSHJ P,IIGLOC ; GET ITS VAL (OR MAKE ONE)\r
+ GETYP 0,(B) ; UNBOUND?\r
+ CAIE 0,TUNBOU\r
+ JRST CHKCUR ; CHECK CURRENT VALUE\r
+ MOVE C,3(TB) ; GET DECL\r
+ HRRM C,-2(B)\r
+ JRST GDECL2\r
+\r
+CHKCUR: HRRZ D,3(TB)\r
+ GETYP A,(D)\r
+ MOVSI A,(A)\r
+ MOVE E,B\r
+ MOVE B,1(D)\r
+ MOVE C,(E)\r
+ MOVE D,1(E)\r
+ PUSH TP,$TVEC\r
+ PUSH TP,E\r
+ JSP E,CHKAB\r
+ PUSHJ P,TMATCH\r
+ JRST TYPMI3\r
+ MOVE E,(TP)\r
+ SUB TP,[2,,2]\r
+ MOVE D,3(TB)\r
+ HRRM D,-2(E)\r
+ JRST GDECL2\r
+\r
+TYPMI3: MOVE E,(TP) ; POINT BACK TO SLOT\r
+ MOVE A,-1(E) ; ATOM TO A\r
+ MOVE B,1(E)\r
+ MOVE D,(E) ; GET OLD VALUE\r
+ MOVE C,3(TB)\r
+ JRST TYPMIS ; GO COMPLAIN\r
+\r
+GDECLL: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE BAD-ARGUMENT-LIST\r
+ JRST CALER1\r
+\r
+MFUNCTION UNMANIFEST,SUBR\r
+\r
+ ENTRY\r
+\r
+ PUSH P,[HLLZS -2(B)]\r
+ JRST MANLP\r
+\r
+MFUNCTION MANIFEST,SUBR\r
+\r
+ ENTRY\r
+\r
+ PUSH P,[HLLOS -2(B)]\r
+MANLP: JUMPGE AB,RETT\r
+ GETYP 0,(AB)\r
+ CAIE 0,TATOM\r
+ JRST WTYP\r
+ MOVE B,1(AB)\r
+ PUSHJ P,IIGLOC\r
+ XCT (P)\r
+ ADD AB,[2,,2]\r
+ JRST MANLP\r
+\r
+MFUNCTION MANIFQ,SUBR,[MANIFEST?]\r
+\r
+ ENTRY 1\r
+\r
+ GETYP 0,(AB)\r
+ CAIE 0,TATOM\r
+ JRST WTYP1\r
+\r
+ MOVE B,1(AB)\r
+ PUSHJ P,IGLOC ; GET POINTER IF ANY\r
+ GETYP 0,A\r
+ CAIN 0,TUNBOU\r
+ JRST RETF\r
+ HRRZ 0,-2(B)\r
+ CAIE 0,-1\r
+ JRST RETF\r
+ JRST RETT\r
+ \r
+MFUNCTION GETDECL,SUBR,[GET-DECL]\r
+\r
+ ENTRY 1\r
+\r
+ PUSHJ P,GTLOC\r
+ JRST GTLOCA\r
+\r
+ HRRZ C,-2(B) ; GET GLOBAL DECL\r
+GETD1: JUMPE C,RETF\r
+ CAIN C,-1\r
+ JRST RETMAN\r
+ GETYP A,(C)\r
+ MOVSI A,(A)\r
+ MOVE B,1(C)\r
+ JSP E,CHKAB\r
+ JRST FINIS\r
+\r
+RETMAN: MOVSI A,TATOM\r
+ MOVE B,MQUOTE MANIFEST\r
+ JRST FINIS\r
+\r
+GTLOCA: HLRZ C,2(B) ; LOCAL DECL\r
+ JRST GETD1\r
+\r
+MFUNCTION PUTDECL,SUBR,[PUT-DECL]\r
+\r
+ ENTRY 2\r
+\r
+ PUSHJ P,GTLOC\r
+ SKIPA E,[HRLM B,2(C)]\r
+ MOVE E,[HRRM B,-2(C)]\r
+ PUSH P,E\r
+ GETYP 0,(B) ; ANY VALUE\r
+ CAIN 0,TUNBOU\r
+ JRST PUTD1\r
+ MOVE C,(B) ; GET CURRENT VALUE\r
+ MOVE D,1(B)\r
+ MOVE A,2(AB)\r
+ MOVE B,3(AB)\r
+ PUSHJ P,TMATCH\r
+ JRST TYPMI4\r
+PUTD1: MOVE C,2(AB) ; GET DECL BACK\r
+ MOVE D,3(AB)\r
+ PUSHJ P,INCONS ; CONS IT UP\r
+ MOVE C,1(AB) ; LOCATIVE BACK\r
+ XCT (P) ; CLOBBER\r
+ MOVE A,(AB)\r
+ MOVE B,1(AB)\r
+ JRST FINIS\r
+\r
+TYPMI4: MOVE E,1(AB) ; GET LOCATIVE\r
+ MOVE A,-1(E) ; NOW ATOM\r
+ MOVEI C,2(AB) ; POINT TO DECL\r
+ MOVE D,(E) ; AND CURRENT VAL\r
+ MOVE B,1(E)\r
+ JRST TYPMIS\r
+\r
+GTLOC: GETYP 0,(AB)\r
+ CAIE 0,TLOCD\r
+ JRST WTYP1\r
+ MOVEI B,(AB)\r
+ PUSHJ P,CHLOCI\r
+ HRRZ 0,(AB) ; LOCAL OR GLOBAL\r
+ SKIPN 0\r
+ AOS (P)\r
+ MOVE B,1(AB) ; RETURN LOCATIVE IN B\r
+ POPJ P,\r
+\r
+; Interface between EVAL and declaration processor.\r
+; E points into stack at a binding and C points to decl list.\r
+\r
+CHKDCL: SKIPE IGDECL ; IGNORING DECLS?\r
+ POPJ P, ; YUP, JUST LEAVE\r
+\r
+ PUSH TP,$TTP ; SAVE BINDING\r
+ PUSH TP,E\r
+ MOVE A,-4(E) ; GET ATOM\r
+ MOVSI 0,TLIST ; SETUP FOR INTERRUPTABLE\r
+ MOVEM 0,CSTO(PVP)\r
+ MOVEM 0,BSTO(PVP)\r
+ MOVSI 0,TATOM\r
+ MOVEM 0,ASTO(PVP)\r
+ SETZB B,0 ; CLOBBER FOR INTGO\r
+\r
+DCL2: INTGO\r
+ HRRZ D,(C) ; MAKE SURE EVEN ELEMENTS\r
+ JUMPE D,BADCL\r
+ GETYP B,(C) ; MUST BE LIST OF ATOMS\r
+ CAIE B,TLIST\r
+ JRST BADCL\r
+ MOVE B,1(C) ; GET LIST\r
+\r
+DCL1: INTGO\r
+ CAMN A,1(B) ; SKIP IF NOT WINNER\r
+ JRST DCLQ ; MAY BE WINNER\r
+DCL3: HRRZ B,(B) ; CDR ON\r
+ JUMPN B,DCL1 ; JUMP IF MORE\r
+\r
+ HRRZ C,(D) ; CDR MAIN LIST\r
+ JUMPN C,DCL2 ; AND JUMP IF WINNING\r
+\r
+ PUSHJ P,E.GET ; GET BINDING BACK\r
+ SUB TP,[2,,2] ; POP OF JUNK\r
+ POPJ P,\r
+\r
+DCLQ: GETYP C,(B) ; CHECK ATOMIC\r
+ CAIE C,TATOM\r
+ JRST BADCL ; LOSER\r
+ PUSHJ P,E.GET ; GOT IT\r
+ PUSH TP,$TLIST ; SAVE PATTERN\r
+ PUSH TP,D\r
+ MOVE B,1(D) ; GET PATTERN\r
+ HLLZ A,(D)\r
+ MOVE C,-3(E) ; PROPOSED VALUE\r
+ MOVE D,-2(E)\r
+ PUSHJ P,TMATCH ; MATCH TYPE\r
+ JRST TYPMI1 ; LOSER\r
+DCLQ1: MOVE E,-2(TP)\r
+ MOVE C,-5(E) ; CHECK FOR SPEC CHANGE\r
+ SKIPE 0 ; MAKE SURE NON ZERO IS -1\r
+ MOVNI 0,1\r
+ SKIPL SPCCHK ; SKIP IF NORMAL UNSPECIAL\r
+ SETCM 0 ; COMPLEMENT\r
+ ANDI 0,1 ; ONE BIT\r
+ CAMN C,[TATOM,,-1]\r
+ JRST .+3\r
+ CAME C,[TATOM,,-2]\r
+ JRST .+3\r
+ ANDCMI C,1\r
+ IOR C,0 ; MUNG BIT\r
+ MOVEM C,-5(E)\r
+ HRRZ C,(TP)\r
+ SUB TP,[4,,4]\r
+ MOVEM C,(E) ; STORE DECLS\r
+ MOVSI C,TLIST\r
+ MOVEM C,-1(E)\r
+ POPJ P,\r
+\r
+TYPMI1: MOVE E,-2(TP)\r
+ GETYP C,-3(E)\r
+ CAIN C,TUNBOU\r
+ JRST DCLQ1\r
+ MOVE E,-2(TP) ; GET POINTER TO BIND\r
+ MOVE D,-3(E) ; GET VAL\r
+ MOVE B,-2(E)\r
+ HRRZ C,(TP) ; DCL LIST\r
+ MOVE A,-4(E) ; GET ATOM\r
+ SUB TP,[4,,4]\r
+TYPMIS: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE TYPE-MISMATCH\r
+ PUSH TP,$TATOM\r
+ PUSH TP,A\r
+ PUSH TP,(C)\r
+ HLLZS (TP)\r
+ PUSH TP,1(C)\r
+ JSP E,CHKARG ; HACK DEFER\r
+ PUSH TP,D\r
+ PUSH TP,B\r
+ MOVEI A,4 ; 3 ERROR ARGS\r
+ JRST CALER\r
+\r
+BADCL: PUSHJ P,E.GET\r
+ PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE BAD-DECLARATION-LIST\r
+ JRST CALER1\r
+\r
+; ROUTINE TO RESSET INT STUFF\r
+\r
+E.GET: MOVE E,(TP)\r
+ SETZM ASTO(PVP)\r
+ SETZM BSTO(PVP)\r
+ SETZM CSTO(PVP)\r
+ POPJ P,\r
+\r
+; Declarations processor for MUDDLE type declarations.\r
+; Receives a pattern in a and B and an object in C and D.\r
+; It skip returns if the object fits otherwise it doesn't.\r
+; Declaration syntax errors are caught and sent to ERROR.\r
+\r
+TMATCH: MOVEI 0,1 ; RET SPECIAL INDICATOR\r
+ SKIPE IGDECL ; IGNORING DECLS?\r
+ JRST CPOPJ1 ; YUP, ACT LIKE THEY WON\r
+\r
+TMATCX: GETYP 0,A ; GET PATTERNS TYPE\r
+ CAIN 0,TFORM ; MUST BE FORM OR ATOM\r
+ JRST TMAT1\r
+ CAIE 0,TATOM\r
+ JRST TERR1 ; WRONG TYPE FOR A DCL\r
+\r
+; SIMPLE TYPE MATCHER\r
+\r
+TYPMAT: GETYP E,C ; OBJECTS TYPE TO E\r
+ PUSH P,E ; SAVE IT\r
+ PUSHJ P,TYPFND ; CONVERT TYPE NAME TO CODE\r
+ JRST SPECS ; NOT A TYPE NAME, TRY SPECIALS\r
+ POP P,E ; RESTORE TYPE OF OBJECT\r
+ MOVEI 0,0 ; SPECIAL INDICATOR\r
+ CAIN E,(D) ; SKIP IF LOSERS\r
+CPOPJ1: AOS (P) ; GOOD RETURN\r
+CPOPJ: POPJ P,\r
+\r
+SPECS: POP P,A ; RESTORE OBJECTS TYPE\r
+ CAMN B,MQUOTE ANY\r
+ JRST CPOPJ1 ; RETURN IMMEDIATELY IF ANYTHING WINS\r
+ CAMN B,MQUOTE STRUCTURED\r
+ JRST ISTRUC ; LET ISTRUC DO THE WORK\r
+ CAMN B,MQUOTE APPLICABLE\r
+ JRST APLQ\r
+ CAME B,MQUOTE LOCATIVE\r
+ JRST TERR2\r
+ JRST LOCQQ\r
+\r
+; ARRIVE HERE FOR A FORM IN THE DCLS\r
+\r
+TMAT1: JUMPE B,TERR3 ; EMPTY FORM LOSES\r
+ HRRZ E,(B) ; CDR IT\r
+ JUMPE E,TMAT3 ; CANT BE SPECIAL/UNSPECIAL, LEAVE\r
+ PUSHJ P,0ATGET ; GET POSSIBLE ATOM IN 0\r
+ JRST TEXP1 ; NOT ATOM\r
+ CAME 0,MQUOTE SPECIAL\r
+ CAMN 0,MQUOTE UNSPECIAL\r
+ JRST TMAT2 ; IGNORE SPECIAL/UNSPECIAL\r
+TMAT3: PUSHJ P,TEXP1\r
+ JRST .+2\r
+ AOS (P)\r
+ MOVEI 0,0 ; RET UNSPECIAL INDICATION\r
+ POPJ P,\r
+\r
+TEXP1: JUMPE B,TERR3 ; EMPTY FORM\r
+ GETYP 0,A ; CHECK CURRENT TYPE\r
+ CAIN 0,TATOM ; IF ATOM,\r
+ JRST TYPMA1 ; SIMPLE MATCH\r
+ CAIE 0,TFORM\r
+ JRST TERR4\r
+ GETYP 0,(B) ; WHAT IS FIRST ELEMEMT\r
+ CAIE 0,TFORM ; FORM=> <<OR ..>....> OR <<PRIMTYPE FOO>....>\r
+ JRST 0,TEXP12\r
+ PUSH TP,$TLIST ; SAVE LIST\r
+ PUSH TP,B\r
+ MOVE B,1(B) ; GET FORM\r
+ PUSH TP,C\r
+ PUSH TP,D\r
+ PUSHJ P,ACTRT1\r
+ TDZA 0,0 ; REMEMBER LACK OF SKIP\r
+ MOVEI 0,1\r
+ POP TP,D\r
+ POP TP,C\r
+ MOVE B,(TP) ; GET BACK SAVED LIST\r
+ SUB TP,[2,,2]\r
+ JUMPE 0,CPOPJ ; LOSERS EXIT IMMEDIATELY\r
+ HRRZ B,(B) ; OTHERWISE REST THE LIST AND FALL INTO ELETYPE\r
+\r
+; CHECKS TYPES OF ELEMENTS OF STRUCTURES\r
+\r
+ELETYP: JUMPE B,CPOPJ1 ; EMPTY=> WON\r
+ PUSH TP,$TLIST ; SAVE DCL LIST\r
+ PUSH TP,B\r
+ MOVE A,C ; GET OBJ IN A AND B\r
+ MOVE B,D\r
+ PUSHJ P,TYPSGR ; GET REST/NTH CODE\r
+ JRST ELETYL ; LOSER\r
+ PUSH TP,DSTO(PVP)\r
+ PUSH TP,D\r
+ PUSH P,C ; SAVE CODE\r
+ PUSH TP,[0] ; AND SLOTS\r
+ PUSH TP,[0]\r
+\r
+; MAIN ELEMENT SCANNING LOOP\r
+\r
+ELETY1: XCT TESTR(C) ; SKIP IF OBJ NOT EMPTY\r
+ JRST ELETY2 ; CHEK EMPTY WINNER\r
+ XCT TYPG(C) ; GET ELEMENT\r
+ XCT VALG(C)\r
+ JSP E,CHKAB ; CHECK OUT DEFER\r
+ MOVEM A,-1(TP) ; AND SAVE IT\r
+ MOVEM B,(TP)\r
+ MOVE C,A\r
+ MOVE D,B ; FOR OTHER MATCHERS\r
+ MOVE B,-4(TP) ; GET PATTERN\r
+ MOVE A,(B)\r
+ GETYP 0,(B) ; GET TYPE OF <1 pattern>\r
+ MOVE B,1(B) ; GET ATOM OR WHATEVER\r
+ CAIE 0,TATOM ; ATOM ... SIMPLE TYPE\r
+ JRST ELETY3\r
+ PUSHJ P,TYPMAT ; DO SIMPLE TYPE MATCH \r
+ JRST ELETY4 ; LOSER\r
+\r
+; HERE TO REST EVERYTHING AND GO ON BACK\r
+\r
+ELETY6: MOVE D,-2(TP) ; GET OBJ POINTER\r
+ MOVE C,(P) ; GET INCREMENT CODE\r
+ XCT INCR1(C)\r
+ MOVEM D,-2(TP) ; SAVED INCREMENTED GOODIR\r
+ MOVE 0,DSTO(PVP)\r
+ MOVEM 0,-3(TP)\r
+\r
+ELETY9: HRRZ B,@-4(TP) ; CDR IT\r
+ MOVEM B,-4(TP)\r
+ JUMPN B,ELETY1\r
+\r
+; HERE IF PATTERN EMPTY\r
+\r
+ELETY8: AOS -1(P) ; SKIP RETURN\r
+ELETY4: SETZM DSTO(PVP)\r
+ SUB P,[1,,1]\r
+ SUB TP,[6,,6]\r
+ POPJ P,\r
+\r
+ELETYL: SUB TP,[2,,2]\r
+ POPJ P,\r
+\r
+; HERE TO HANDLE EMPTY OBJECT\r
+\r
+ELETY2: MOVE B,-4(TP) ; GET PATTERN\r
+ GETYP 0,(B) ; CHECK FOR [REST ...]\r
+ SETZM DSTO(PVP)\r
+ CAIE 0,TVEC\r
+ JRST ELETY4 ; LOSER\r
+ HLRZ 0,1(B) ; SIZE OF IT\r
+ CAILE 0,-4 ; MUST BE 2\r
+ JRST ELETY4\r
+ MOVE B,1(B) ; GET IT\r
+ PUSHJ P,0ATGET ; LOOK FOR REST\r
+ JRST ELETY4\r
+ CAMN 0,MQUOTE REST\r
+ JRST ELETY8 ; WINNER!!!!\r
+ JRST ELETY4 ; LOSER\r
+\r
+; HERE TO CHECK OUT A FORM ELEMNT\r
+\r
+ELETY3: CAIE 0,TFORM\r
+ JRST ELETY7\r
+ SETZM DSTO(PVP)\r
+ PUSHJ P,TEXP1 ; AND ANALYSE IT\r
+ JRST ELETY4 ; LOSER\r
+ MOVE 0,-3(TP) ; RESET DSTO\r
+ MOVEM 0,DSTO(PVP)\r
+ JRST ELETY6 ; WINNER\r
+\r
+; CHECK FOR VECTOR IN PATTERN\r
+\r
+ELETY7: CAIE 0,TVEC ; SKIP IF WINNER\r
+ JRST TERR12 ; YET ANOTHER ERROR\r
+ HLRE C,B ; CHECK LEENGTH\r
+ CAMLE C,[-4] ; MUST BE 2 LONG\r
+ JRST TERR13\r
+ PUSHJ P,0ATGET ; 1ST ELEMENT ATOM?\r
+ JRST ELET71 ; COULD BE FORM\r
+ CAME 0,MQUOTE REST\r
+ JRST TERR14\r
+ MOVNI 0,1 ; FLAG USED IN RESTIT\r
+ PUSHJ P,RESTIT ; CHECK REST OF STRUCTUR\r
+ JRST ELETY4\r
+ JRST ELETY8 ; WIN AND DONE\r
+\r
+; CHECK FOR [fix .... ]\r
+\r
+ELET71: CAIE 0,TFIX\r
+ JRST TERR15\r
+ MOVNS C\r
+ ASH C,-1\r
+ MOVE 0,1(B) ; GET NUMBER\r
+ IMULI 0,-1(C) ; COUNT MORE\r
+ PUSHJ P,RESTIT ; AND CHECK FIX NUM OF ELEMENTS\r
+ JRST ELETY4\r
+ MOVE D,-2(TP) ; GET OBJECT BACK\r
+ MOVE 0,-3(TP) ; RESET DSTO\r
+ MOVEM 0,DSTO(PVP)\r
+ MOVE C,(P) ; RESTORE CODE FOR RESTING ETC.\r
+ JRST ELETY9\r
+\r
+\r
+; HERE TO DO A TASTEFUL TYPMAT\r
+\r
+TYPMA1: PUSH TP,C\r
+ PUSH TP,D\r
+ PUSHJ P,TYPMAT\r
+ TDZA 0,0 ; REMEMBER LOSSAGE\r
+ MOVEI 0,1 ; OR WINNAGE\r
+ POP TP,D\r
+ POP TP,C ; RESTORE OBJECT\r
+ JUMPN 0,CPOPJ1 ; SKIPPED BEFORE, SKIP AGAIN\r
+ POPJ P,\r
+\r
+; HERE TO SKIP SPECIAL/UNSPECIAL\r
+\r
+TMAT2: CAME 0,MQUOTE SPECIAL\r
+ TDZA 0,0\r
+ MOVEI 0,1\r
+ PUSH P,0 ; SAVE INDICATOR\r
+ GETYP A,(E) ; TYPE OF NEW PAT\r
+ MOVE B,1(E) ; VALUE\r
+ MOVSI A,(A)\r
+ PUSHJ P,TEXP1\r
+ JRST .+2\r
+ AOS -1(P)\r
+ POP P,0\r
+ POPJ P,\r
+\r
+; LOOK FOR <OR... OR <PRIMTYPE....\r
+\r
+TEXP12: CAIE 0,TATOM\r
+ JRST TERR5\r
+ MOVE 0,1(B) ; GET ATOM\r
+ CAMN 0,MQUOTE QUOTE\r
+ JRST MQUOT ; MATCH A QUOTED OBJECT\r
+ CAME 0,MQUOTE OR\r
+ CAMN 0,MQUOTE PRIMTYPE\r
+ JRST ACTORT ; FALL INTO ACTOR HACKER\r
+ PUSH TP,$TLIST\r
+ PUSH TP,B\r
+ MOVE B,0 ; GET ATOM\r
+ PUSH TP,C ; SAVE OBJ\r
+ PUSH TP,D\r
+ PUSHJ P,TYPMAT\r
+ TDZA 0,0\r
+ MOVEI 0,1\r
+ MOVE C,-1(TP)\r
+ MOVE D,(TP)\r
+ MOVE B,-2(TP)\r
+ JUMPN 0,.+3 ; TO ELETYP IF WON\r
+ SUB TP,[4,,4]\r
+ POPJ P, ; ELSE LOSE\r
+\r
+ HRRZ 0,(B)\r
+ MOVSI A,TFORM\r
+ JUMPE 0,TERR3\r
+ MOVE B,0\r
+ PUSHJ P,ELETYP\r
+ TDZA 0,0\r
+ MOVEI 0,1\r
+POPPIT: POP TP,D\r
+ POP TP,C\r
+ POP TP,B\r
+ POP TP,A\r
+ JUMPN 0,CPOPJ1\r
+ POPJ P,\r
+ \r
+; THIS CODE HANDLES ORs AND PRIMTYPEs\r
+ACTRT1: SKIPA E,[PACT]\r
+\r
+ACTORT: MOVEI E,TEXP1\r
+ JUMPE B,TERR6 ; EMPTY, LOSE\r
+ PUSHJ P,0ATGET ; ATOM TO 0\r
+ JRST PACT\r
+ CAME 0,MQUOTE OR\r
+ JRST PACT2\r
+ HRRZ 0,(B) ; REST IT FLUSHING OR\r
+ JUMPE 0,TERR7\r
+ PUSH TP,$TLIST ; SAVE LSIT\r
+ PUSH TP,0\r
+ PUSH P,E ; SAVE ELEMENT CHECKER\r
+\r
+ORLP: SKIPN B,(TP) ; ANY LEFT?\r
+ JRST ORDON ; NOPE, LOSE\r
+ HRRZ 0,(B) ; SAVE THE REST\r
+ MOVEM 0,(TP)\r
+ GETYP 0,(B) ; WHAT ARE WE ORing\r
+ MOVE A,(B) ; TYPE WORD\r
+ MOVE B,1(B) ; AND ITEM\r
+ PUSHJ P,@(P) ; EITHER PACT OR TEXP1\r
+ JRST ORLP ; HAVEN'T WON YET\r
+ AOS -1(P) ; SKIP RETURN FOR WINNER\r
+\r
+ORDON: SUB TP,[2,,2] ; FLUSH TEMP\r
+ SUB P,[1,,1]\r
+ POPJ P,\r
+\r
+; HERE TO PRIMTYPE ACTORS\r
+\r
+PACT: CAIE 0,TFORM\r
+ JRST PACT1\r
+ JUMPE B,TERR6 ; EMPTY FORM\r
+ MOVE 0,1(B) ; FIRST ELEMENT MUST BE PRIMTYPE\r
+PACT2: CAME 0,MQUOTE PRIMTYPE\r
+ JRST TERR7\r
+ HRRZ B,(B) ; GET PRIMTYPE\r
+ JUMPE B,TERR7\r
+ GETYP A,C ; GET OBJ TYPE\r
+ GETYP 0,(B) ; GET PATTERN TYPE\r
+ CAIE 0,TATOM ; BETTER BE ATOM\r
+ JRST TERR8\r
+ PUSH TP,$TLIST ; SAVE DCL LIST\r
+ PUSH TP,B\r
+ PUSH TP,C\r
+ PUSH TP,D\r
+ PUSHJ P,SAT ; GET STORAGE TYPE\r
+ CAILE A,NUMSAT\r
+ JRST PTEMP\r
+ MOVE B,@STBL(A) ; GET PRIM NAME\r
+ PUSHJ P,TYPFND\r
+ JFCL ; MUST EXIST\r
+ MOVSI C,(D) ; FAKE OUT TYPMAT\r
+ MOVE B,-2(TP)\r
+ MOVE B,1(B)\r
+ PUSHJ P,TYPMAT\r
+ JRST .+2\r
+ AOS (P)\r
+ MOVE C,-1(TP)\r
+ MOVE D,(TP)\r
+ SUB TP,[4,,4]\r
+ POPJ P,\r
+\r
+PACT1: CAIE 0,TATOM\r
+ JRST TERR4\r
+ JRST TYPMAT\r
+\r
+PTEMP: MOVE B,-2(TP)\r
+ MOVE B,1(B)\r
+ CAMN B,MQUOTE TEMPLATE\r
+ AOS (P)\r
+ SUB TP,[4,,4]\r
+ POPJ P,\r
+\r
+; RESTIT - TYPE CHECK SELECTED NUMBER OF ELEMENTS IN STRUCTURE\r
+\r
+RESTIT: PUSH TP,$TVEC ; SAVE TYPE\r
+ ADD B,[2,,2] ; SKIP OVER CRUFT\r
+ PUSH TP,B ; AND VAL\r
+ PUSH TP,$TVEC\r
+ PUSH TP,B\r
+RESTI1: PUSH P,A ; SAVE DISP HACK\r
+ PUSH P,0 ; AND COUNT HACK\r
+RESTI4: SKIPL (P) ; SKIP IF DOING ALL\r
+ SOSL (P) ; SKIP IF DONE\r
+ JRST RESTI6\r
+ AOS -2(P) ; SKIP RET\r
+RESTI5: SUB P,[2,,2] ; POP JUNK\r
+ SUB TP,[4,,4]\r
+ POPJ P,\r
+RESTI6: MOVE C,-3(P) ; REST CODE\r
+ MOVE D,-6(TP) ; SET UP FOR REST\r
+ MOVE E,-7(TP) ; DONT FORGET DSTO\r
+ MOVEM E,DSTO(PVP)\r
+ XCT TESTR(C) ; DONE?\r
+ JRST RESTI2 ; YES, CHECK WINNAGE\r
+ XCT TYPG(C)\r
+ XCT VALG(C) ; GET VAL ANDTYPE\r
+ JSP E,CHKAB ; CHECK DEFER\r
+ XCT INCR1(C) ; REST IT\r
+ MOVEM D,-6(TP) ; SAVE LIST\r
+ MOVE E,DSTO(PVP)\r
+ MOVEM E,-7(TP) ; FIXUP\r
+ SETZM DSTO(PVP)\r
+ MOVE C,A\r
+ MOVE D,B\r
+ SKIPL A,(TP) ; ANY MORE?\r
+ MOVE A,-2(TP) ; NO RECYCLE\r
+ ADD A,[2,,2] ; BUMP\r
+ MOVEM A,(TP) ; AND SAVE\r
+ MOVE B,-1(A) ; GET ELEMENT\r
+ MOVE A,-2(A)\r
+ GETYP 0,A\r
+ MOVEI E,TERR15\r
+ CAIN 0,TATOM\r
+ MOVEI E,TYPMAT ; ATOM --> SIMPLE TYPE\r
+ CAIN 0,TFORM ; FORM--> HAIRY PATTERN\r
+ MOVEI E,TEXP1\r
+ PUSHJ P,(E) ; DO IT\r
+ JRST RESTI5\r
+ JRST RESTI4\r
+\r
+RESTI2: SKIPGE (P) ; SKIP IF WON\r
+ AOS -2(P) ; COUNTERACT CPOPJ1\r
+ JRST RESTI5\r
+\r
+RESTI3: TEXP1\r
+ TYPMAT\r
+\r
+; HERE TO MATHC A QUOTED OBJ\r
+; B/ FORM QUOTE... C,D/ OBJECT TO MATCH AGAINST\r
+\r
+MQUOT: HRRZ B,(B) ; LOOK AT NEXT\r
+ JUMPE B,TERR7\r
+ GETYP A,(B) ; GET TYPE\r
+ MOVSI A,(A)\r
+ MOVE B,1(B) ; AND VALUE\r
+ JSP E,CHKAB ; HACK DEFER\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ PUSH TP,C\r
+ PUSH TP,D\r
+ MOVEI D,-3(TP)\r
+ MOVEI C,-1(TP)\r
+ PUSHJ P,IEQUAL\r
+ TDZA 0,0\r
+ MOVEI 0,1\r
+ JRST POPPIT\r
+\r
+\r
+; GET ATOM IN AC 0\r
+\r
+0ATGET: GETYP 0,(B)\r
+ CAIE 0,TATOM ; SKIP IF ATOM\r
+ POPJ P,\r
+ MOVE 0,1(B) ; GET ATOM\r
+ JRST CPOPJ1\r
+\r
+TERR9: MOVS A,0 ; TYPE TO A\r
+TERR4:\r
+TERR5:\r
+TERR15:\r
+TERR1: MOVE E,EQUOTE DECL-ELEMENT-NOT-FORM-OR-ATOM\r
+ JRST TERRD\r
+\r
+TERR2: MOVSI A,TATOM\r
+ MOVE E,EQUOTE ATOM-NOT-TYPE-NAME-OR-SPECIAL-SYMBOL\r
+ JRST TERRD\r
+TERR6:\r
+TERR3: MOVE E,EQUOTE EMPTY-FORM-IN-DECL\r
+ JRST TERRD\r
+TERR7: MOVE E,EQUOTE EMPTY-OR/PRIMTYPE-FORM\r
+ JRST TERRD\r
+\r
+TERR8: MOVS A,0 ; TYPE TO A\r
+ MOVE E,EQUOTE NON-TYPE-FOR-PRIMTYPE-ARG\r
+ JRST TERRD\r
+TERR12: MOVE E,EQUOTE ELEMENT-TYPE-NOT-ATOM-FORM-OR-VECTOR\r
+ JRST TERRD\r
+TERR13: MOVE E,EQUOTE VECTOR-LESS-THAN-2-ELEMENTS\r
+ JRST TERRD\r
+TERR14: MOVE E,EQUOTE FIRST-VECTOR-ELEMENT-NOT-REST-OR-A-FIX\r
+\r
+TERRD: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE BAD-TYPE-SPECIFICATION\r
+ PUSH TP,$TATOM\r
+ PUSH TP,E\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ MOVEI A,3\r
+ JRST CALER\r
+\r
+IMPURE\r
+\r
+IGDECL: 0\r
+\r
+PURE\r
+\r
+END\r
+\f\fTITLE EVAL -- MUDDLE EVALUATOR\r
+\r
+RELOCATABLE\r
+\r
+; GERALD JAY SUSSMAN, 1971. REWRITTEN MANY TIMES SINCE C. REEVE (1972--1974)\r
+\r
+\r
+.GLOBAL BINDID,LPROG,GLOBSP,GLOBASE,SPBASE,TPBASE,PTIME,SWAP,CHFRAM\r
+.GLOBAL IGVAL,CHKARG,NXTDCL,TPOVFL,CHFRM,PROCHK,CHFSWP,VECBOT,TYPSGR\r
+.GLOBAL ILVAL,ER1ARG,SPECBIND,MAKACT,SPECSTORE,MAKTUP,TPALOC,IBIND,SSPECS\r
+.GLOBAL IDVAL,EVECTO,EUVECT,CHARGS,BCKTRK,CELL,ILOC,IGLOC,CHKDCL,SSPEC1\r
+.GLOBAL PDLBUF,MESS,FACTI,CHKARG,MAKENV,PSTAT,BNDV,UNBOU,UNAS,IGDECL\r
+.GLOBAL 1STEPR,SEGMNT,SEGLST,NAPT,EVTYPE,EVATYP,APTYPE,APLTYP,APLQ,IDVAL1\r
+.GLOBAL TESTR,VALG,TYPG,INCR1,TMATCH,TYPMIS,SAT,MAKACT,NTPALO,SPECBND\r
+.GLOBAL TPGROW,CHKAB,TYPSEG,NXTLM,MONCH0,CHFINI,RMONC0,IMPURIFY,ICONS,INCONS\r
+.GLOBAL CILVAL,CISET,CIGVAL,CSETG,MAPPLY,CLLOC,CGLOC,CASSQ,CGASSQ,CBOUND\r
+.GLOBAL IIGLOC,CHUNW,IUNWIN,UNWIN2,SPCCHK,CURFCN,TMPLNT,TD.LNT,TBINIT\r
+.GLOBAL SPECBE\r
+.GLOBAL AGC,GVLINC,LVLINC,CGBOUN,IEVECT,MAKTU2\r
+\r
+.INSRT MUDDLE >\r
+\r
+MONITOR\r
+\r
+\f\r
+; ENTRY TO EXPAND A MACRO\r
+\r
+MFUNCTION EXPAND,SUBR\r
+\r
+ ENTRY 1\r
+\r
+ MOVEI A,PVLNT*2+1(PVP)\r
+ HRLI A,TFRAME\r
+ MOVE B,TBINIT+1(PVP)\r
+ HLL B,OTBSAV(B)\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ MOVEI B,-1(TP)\r
+ JRST AEVAL2\r
+\r
+; MAIN EVAL ENTRANCE\r
+\r
+MFUNCTION EVAL,SUBR\r
+\r
+ ENTRY\r
+\r
+ SKIPE C,1STEPR+1(PVP) ; BEING 1 STEPPED?\r
+ JRST 1STEPI ; YES HANDLE\r
+EVALON: HLRZ A,AB ;GET NUMBER OF ARGS\r
+ CAIE A,-2 ;EXACTLY 1?\r
+ JRST AEVAL ;EVAL WITH AN ALIST\r
+SEVAL: GETYP A,(AB) ;GET TYPE OF ARG\r
+ SKIPE C,EVATYP+1(TVP) ; USER TYPE TABLE?\r
+ JRST EVDISP\r
+SEVAL1: CAIG A,NUMPRI ;PRIMITIVE?\r
+ JRST @EVTYPE(A) ;YES-DISPATCH\r
+\r
+SELF: MOVE A,(AB) ;TYPES WHICH EVALUATE \r
+ MOVE B,1(AB)\r
+ JRST EFINIS ;TO SELF-EG NUMBERS\r
+\r
+; HERE FOR USER EVAL DISPATCH\r
+\r
+EVDISP: ADDI C,(A) ; POINT TO SLOT\r
+ ADDI C,(A)\r
+ SKIPE (C) ; SKIP EITHER A LOSER OR JRST DISP\r
+ JRST EVDIS1 ; APPLY EVALUATOR\r
+ SKIPN C,1(C) ; GET ADDR OR GO TO PURE DISP\r
+ JRST SEVAL1\r
+ JRST (C)\r
+\r
+EVDIS1: PUSH TP,(C)\r
+ PUSH TP,1(C)\r
+ PUSH TP,(AB)\r
+ PUSH TP,1(AB)\r
+ MCALL 2,APPLY ; APPLY HACKER TO OBJECT\r
+ JRST EFINIS\r
+\r
+\r
+; EVAL DISPATCH TABLE\r
+\r
+DISTBL EVTYPE,SELF,[[TFORM,EVFORM],[TLIST,EVLIST],[TVEC,EVECT],[TUVEC,EUVEC]\r
+[TSEG,ILLSEG]]\r
+\f\r
+\r
+;WATCH FOR SUBTLE BUG 43 LERR,LPROG OR BINDID\r
+AEVAL:\r
+ CAIE A,-4 ;EXACTLY 2 ARGS?\r
+ JRST WNA ;NO-ERROR\r
+ GETYP A,2(AB) ;CHECK THAT WE HAVE A FRAME\r
+ CAIE A,TACT\r
+ CAIN A,TFRAME\r
+ JRST .+3\r
+ CAIE A,TENV\r
+ JRST TRYPRO ; COULD BE PROCESS\r
+ MOVEI B,2(AB) ; POINT TO FRAME\r
+AEVAL2: PUSHJ P,CHENV ; HACK ENVIRONMENT CHANGE\r
+AEVAL1: PUSH TP,(AB)\r
+ PUSH TP,1(AB)\r
+ MCALL 1,EVAL\r
+AEVAL3: HRRZ 0,FSAV(TB)\r
+ CAIN 0,EVAL\r
+ JRST EFINIS\r
+ JRST FINIS\r
+\r
+TRYPRO: CAIE A,TPVP ; SKIP IF IT IS A PROCESS\r
+ JRST WTYP2\r
+ MOVE C,3(AB) ; GET PROCESS\r
+ CAMN C,PVP ; DIFFERENT FROM ME?\r
+ JRST SEVAL ; NO, NORMAL EVAL WINS\r
+ MOVE B,SPSTO+1(C) ; GET SP FOR PROCESS\r
+ MOVE D,TBSTO+1(C) ; GET TOP FRAME\r
+ HLL D,OTBSAV(D) ; TIME IT\r
+ MOVEI C,PVLNT*2+1(C) ; CONS UP POINTER TO PROC DOPE WORD\r
+ HRLI C,TFRAME ; LOOK LIK E A FRAME\r
+ PUSHJ P,SWITSP ; SPLICE ENVIRONMENT\r
+ JRST AEVAL1\r
+\r
+; ROUTINE TO CHANGE LOOK UP PATH FOR BINDINGS \r
+\r
+CHENV: PUSHJ P,CHFRM ; CHECK OUT FRAME\r
+ MOVE C,(B) ; POINT TO PROCESS\r
+ MOVE D,1(B) ; GET TB POINTER FROM FRAME\r
+ CAMN SP,SPSAV(D) ; CHANGE?\r
+ POPJ P, ; NO, JUST RET\r
+ MOVE B,SPSAV(D) ; GET SP OF INTEREST\r
+SWITSP: MOVSI 0,TSKIP ; SET UP SKIP\r
+ HRRI 0,1(TP) ; POINT TO UNBIND PATH\r
+ MOVE A,PVP\r
+ ADD A,[BINDID,,BINDID] ; BIND THE BINDING ID\r
+ PUSH TP,BNDV\r
+ PUSH TP,A\r
+ PUSH TP,$TFIX\r
+ AOS A,PTIME ; NEW ID\r
+ PUSH TP,A\r
+ MOVE E,TP ; FOR SPECBIND\r
+ PUSH TP,0\r
+ PUSH TP,B\r
+ PUSH TP,C ; SAVE PROCESS\r
+ PUSH TP,D\r
+ PUSHJ P,SPECBE ; BIND BINDID\r
+ MOVE SP,TP ; GET NEW SP\r
+ SUB SP,[3,,3] ; SET UP SP FORK\r
+ POPJ P,\r
+\f\r
+\r
+; HERE TO EVALUATE A FORM (99% OF EVAL'S WORK)\r
+\r
+EVFORM: SKIPN C,1(AB) ; EMPTY FORM, RETURN FALSE\r
+ JRST EFALSE\r
+ GETYP A,(C) ; 1ST ELEMENT OF FORM\r
+ CAIE A,TATOM ; ATOM?\r
+ JRST EV0 ; NO, EVALUATE IT\r
+ MOVE B,1(C) ; GET ATOM\r
+ PUSHJ P,IGVAL ; GET ITS GLOBAL VALUE\r
+\r
+; SPECIAL HACK TO SPEED UP LVAL AND GVAL CALLS\r
+\r
+ CAIE B,LVAL\r
+ CAIN B,GVAL\r
+ JRST ATMVAL ; FAST ATOM VALUE\r
+\r
+ GETYP 0,A\r
+ CAIE 0,TUNBOU ; BOUND?\r
+ JRST IAPPLY ; YES APPLY IT\r
+\r
+ MOVE C,1(AB) ; LOOK FOR LOCAL\r
+ MOVE B,1(C)\r
+ PUSHJ P,ILVAL\r
+ GETYP 0,A\r
+ CAIE 0,TUNBOU\r
+ JRST IAPPLY ; WIN, GO APPLY IT\r
+\r
+ PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE UNBOUND-VARIABLE\r
+ PUSH TP,$TATOM\r
+ MOVE C,1(AB) ; FORM BACK\r
+ PUSH TP,1(C)\r
+ PUSH TP,$TATOM\r
+ PUSH TP,MQUOTE VALUE\r
+ MCALL 3,ERROR ; REPORT THE ERROR\r
+ JRST IAPPLY\r
+\r
+EFALSE: MOVSI A,TFALSE ; SPECIAL FALSE FOR EVAL OF EMPTY FORM\r
+ MOVEI B,0\r
+ JRST EFINIS\r
+\r
+ATMVAL: HRRZ D,(C) ; CDR THE FORM\r
+ HRRZ 0,(D) ; AND AGAIN\r
+ JUMPN 0,IAPPLY\r
+ GETYP 0,(D) ; MAKE SURE APPLYING TO ATOM\r
+ CAIE 0,TATOM\r
+ JRST IAPPLY\r
+ MOVEI E,IGVAL ; ASSUME GLOBAAL\r
+ CAIE B,GVAL ; SKIP IF OK\r
+ MOVEI E,ILVAL ; ELSE USE LOCAL\r
+ PUSH P,B ; SAVE SUBR\r
+ MOVE B,(D)+1 ; CLR BUG #1637 (GET THE ATOM FOR THE SUBR)\r
+ PUSHJ P,(E) ; AND GET VALUE\r
+ CAME A,$TUNBOU\r
+ JRST EFINIS ; RETURN FROM EVAL\r
+ POP P,B\r
+ MOVSI A,TSUBR ; CAUSE REAL SUBR TO GET EROR\r
+ JRST IAPPLY\r
+\f\r
+; HERE FOR 1ST ELEMENT NOT A FORM\r
+\r
+EV0: PUSHJ P,FASTEV ; EVAL IT\r
+\r
+; HERE TO APPLY THINGS IN FORMS\r
+\r
+IAPPLY: PUSH TP,(AB) ; SAVE THE FORM\r
+ PUSH TP,1(AB)\r
+ PUSH TP,A\r
+ PUSH TP,B ; SAVE THE APPLIER\r
+ PUSH TP,$TFIX ; AND THE ARG GETTER\r
+ PUSH TP,[ARGCDR]\r
+ PUSHJ P,APLDIS ; GO TO INTERNAL APPLIER\r
+ JRST EFINIS ; LEAVE EVAL\r
+\r
+; HERE TO EVAL 1ST ELEMENT OF A FORM\r
+\r
+FASTEV: SKIPE 1STEPR+1(PVP) ; BEING 1 STEPPED?\r
+ JRST EV02 ; YES, LET LOSER SEE THIS EVAL\r
+ GETYP A,(C) ; GET TYPE\r
+ SKIPE D,EVATYP+1(TVP) ; USER TABLE?\r
+ JRST EV01 ; YES, HACK IT\r
+EV03: CAIG A,NUMPRI ; SKIP IF SELF\r
+ SKIPA A,EVTYPE(A) ; GET DISPATCH\r
+ MOVEI A,SELF ; USE SLEF\r
+\r
+EV04: CAIE A,SELF ; IF EVAL'S TO SELF, JUST USE IT\r
+ JRST EV02\r
+ MOVSI A,TLIST\r
+ MOVEM A,CSTO(PVP)\r
+ INTGO\r
+ SETZM CSTO(PVP)\r
+ HLLZ A,(C) ; GET IT\r
+ MOVE B,1(C)\r
+ JSP E,CHKAB ; CHECK DEFERS\r
+ POPJ P, ; AND RETURN\r
+\r
+EV01: ADDI D,(A) ; POINT TO SLOT OF USER EVAL TABLE\r
+ ADDI D,(A)\r
+ SKIPE (D) ; EITHER NOT GIVEN OR SIMPLE\r
+ JRST EV02\r
+ SKIPN 1(D) ; SKIP IF SIMPLE\r
+ JRST EV03 ; NOT GIVEN\r
+ MOVE A,1(D)\r
+ JRST EV04\r
+\r
+EV02: PUSH TP,(C)\r
+ HLLZS (TP) ; FIX UP LH\r
+ PUSH TP,1(C)\r
+ JSP E,CHKARG\r
+ MCALL 1,EVAL\r
+ POPJ P,\r
+\r
+\f\r
+; MAPF/MAPR CALL TO APPLY\r
+\r
+ MQUOTE APPLY\r
+\r
+MAPPLY: JRST APPLY\r
+\r
+; APPLY, FALLS INTO EVAL'S APPLY CODE AT APLDIS\r
+\r
+MFUNCTION APPLY,SUBR\r
+\r
+ ENTRY\r
+\r
+ JUMPGE AB,TFA ; MUST BE AT LEAST 1 ARGUMENT\r
+ MOVE A,AB\r
+ ADD A,[2,,2]\r
+ PUSH TP,$TAB\r
+ PUSH TP,A\r
+ PUSH TP,(AB) ; SAVE FCN\r
+ PUSH TP,1(AB)\r
+ PUSH TP,$TFIX ; AND ARG GETTER\r
+ PUSH TP,[SETZ APLARG]\r
+ PUSHJ P,APLDIS\r
+ JRST FINIS\r
+\r
+; STACKFROM, ALSO FALLS INTO EVAL'S APPLIER AT APLDIS\r
+\r
+MFUNCTION STACKFORM,FSUBR\r
+\r
+ ENTRY 1\r
+\r
+ GETYP A,(AB)\r
+ CAIE A,TLIST\r
+ JRST WTYP1\r
+ MOVEI A,3 ; CHECK ALL GOODIES SUPPLIED\r
+ HRRZ B,1(AB)\r
+\r
+ JUMPE B,TFA\r
+ HRRZ B,(B) ; CDR IT\r
+ SOJG A,.-2\r
+\r
+ HRRZ C,1(AB) ; GET LIST BACK\r
+ PUSHJ P,FASTEV ; DO A FAST EVALUATION\r
+ PUSH TP,(AB)\r
+ HRRZ C,@1(AB) ; POINT TO ARG GETTING FORMS\r
+ PUSH TP,C\r
+ PUSH TP,A ; AND FCN\r
+ PUSH TP,B\r
+ PUSH TP,$TFIX\r
+ PUSH TP,[SETZ EVALRG]\r
+ PUSHJ P,APLDIS\r
+ JRST FINIS\r
+\r
+\f\r
+; OFFSETS FOR TEMPORARIES ETC. USED IN APPLYING STUFF\r
+\r
+E.FRM==0 ; POINTS TO FORM BEING EVALED (OR ARGS FOR APPLY STACKFORM)\r
+E.FCN==2 ; FUNCTION/SUBR/RSUBR BEING APPLIED\r
+E.ARG==4 ; POINTS TO ARG GETTING ROUTINE (<0 => MUST EVAL ARGS)\r
+E.EXTR==6 ; CONTAINS 1ST ARG IN USER APPLY CASE\r
+E.SEG==10 ; POINTS TO SEGMENT IN FORM BEING HACKED\r
+E.CNT==12 ; COUNTER FOR TUPLES OF ARGS\r
+E.DECL==14 ; POINTS TO DECLARATION LIST IN FUNCTIONS\r
+E.ARGL==16 ; POINTS TO ARG LIST IN FUNCTIONS\r
+E.HEW==20 ; POINTS TO HEWITT ATOM IF IT EXISTS\r
+\r
+E.VAL==E.ARGL ; VALUE TYPE FOR RSUBRS\r
+\r
+MINTM==E.EXTR+2 ; MIN # OF TEMPS EVER ALLOCATED\r
+E.TSUB==E.CNT+2 ; # OF TEMPS FOR SUBR/NUMBER APPLICATION\r
+XP.TMP==E.HEW-E.EXTR ; # EXTRA TEMPS FOR FUNCTION APPLICATION\r
+R.TMP==4 ; TEMPS AFTER ARGS ARE BOUND\r
+TM.OFF==E.HEW+2-R.TMP ; TEMPS TO FLUSH AFTER BIND OF ARGS\r
+\r
+RE.FCN==0 ; AFTER BINDING CONTAINS FCN BODY\r
+RE.ARG==2 ; ARG LIST AFTER BINDING\r
+\r
+; GENERAL THING APPLYER\r
+\r
+APLDIS: PUSH TP,[0] ; SLOT USED FOR USER APPLYERS\r
+ PUSH TP,[0]\r
+APLDIX: GETYP A,E.FCN(TB) ; GET TYPE\r
+\r
+APLDI: SKIPE D,APLTYP+1(TVP) ; USER TABLE EXISTS?\r
+ JRST APLDI1 ; YES, USE IT\r
+APLDI2: CAIG A,NUMPRI ; SKIP IF NOT PRIM\r
+ JRST @APTYPE(A)\r
+ JRST NAPT\r
+\r
+APLDI1: ADDI D,(A) ; POINT TO SLOT\r
+ ADDI D,(A)\r
+ SKIPE (D) ; SKIP IF NOT GIVEN OR STANDARD\r
+ JRST APLDI3\r
+APLDI4: SKIPE D,1(D) ; GET DISP\r
+ JRST (D)\r
+ JRST APLDI2 ; USE SYSTEM DISPATCH\r
+\r
+APLDI3: SKIPE E.EXTR+1(TB) ; SKIP IF HAVEN'T BEEN HERE BEFORE\r
+ JRST APLDI4\r
+ MOVE A,(D) ; GET ITS HANDLER\r
+ EXCH A,E.FCN(TB) ; AND USE AS FCN\r
+ MOVEM A,E.EXTR(TB) ; SAVE\r
+ MOVE A,1(D)\r
+ EXCH A,E.FCN+1(TB)\r
+ MOVEM A,E.EXTR+1(TB) ; STASH OLD FCN AS EXTRG\r
+ GETYP A,(D) ; GET TYPE\r
+ JRST APLDI\r
+\r
+\r
+; APPLY DISPATCH TABLE\r
+\r
+DISTBL APTYPE,<SETZ NAPTL>,[[TSUBR,APSUBR],[TFSUBR,APFSUB],[TRSUBR,APRSUB],[TFIX,APNUM]\r
+[TEXPR,APEXPR],[TFUNAR,APFUNARG],[TENTER,APENTR],[TMACRO,APMACR]]\f\r
+\r
+; SUBR TO SAY IF TYPE IS APPLICABLE\r
+\r
+MFUNCTION APPLIC,SUBR,[APPLICABLE?]\r
+\r
+ ENTRY 1\r
+\r
+ GETYP A,(AB)\r
+ PUSHJ P,APLQ\r
+ JRST IFALSE\r
+ JRST TRUTH\r
+\r
+; HERE TO DETERMINE IF A TYPE IS APPLICABLE\r
+\r
+APLQ: PUSH P,B\r
+ SKIPN B,APLTYP+1(TVP)\r
+ JRST USEPUR ; USE PURE TABLE\r
+ ADDI B,(A)\r
+ ADDI B,(A) ; POINT TO SLOT\r
+ SKIPG 1(B) ; SKIP IF WINNER\r
+ SKIPE (B) ; SKIP IF POTENIAL LOSER\r
+ JRST CPPJ1B ; WIN\r
+ SKIPE 1(B) ; SKIP IF MUST USE PURE TABBLE\r
+ JRST CPOPJB\r
+USEPUR: CAIG A,NUMPRI ; SKIP IF NOT PRIM\r
+ SKIPL APTYPE(A) ; SKIP IF APLLICABLE\r
+CPPJ1B: AOS -1(P)\r
+CPOPJB: POP P,B\r
+ POPJ P,\r
+\f\r
+; FSUBR APPLYER\r
+\r
+APFSUBR:\r
+ SKIPN E.EXTR(TB) ; IF EXTRA ARG\r
+ SKIPGE E.ARG+1(TB) ; OR APPLY/STACKFORM, LOSE\r
+ JRST BADFSB\r
+ MOVE A,E.FCN+1(TB) ; GET FCN\r
+ HRRZ C,@E.FRM+1(TB) ; GET ARG LIST\r
+ SUB TP,[MINTM,,MINTM] ; FLUSH UNWANTED TEMPS\r
+ PUSH TP,$TLIST\r
+ PUSH TP,C ; ARG TO STACK\r
+ .MCALL 1,(A) ; AND CALL\r
+ POPJ P, ; AND LEAVE\r
+\r
+; SUBR APPLYER\r
+\r
+APSUBR: \r
+ PUSHJ P,PSH4ZR ; SET UP ZEROED SLOTS\r
+ SKIPN A,E.EXTR(TB) ; FUNNY ARGS\r
+ JRST APSUB1 ; NO, GO\r
+ MOVE B,E.EXTR+1(TB) ; YES , GET VAL\r
+ JRST APSUB2 ; AND FALL IN\r
+\r
+APSUB1: PUSHJ P,@E.ARG+1(TB) ; EAT AN ARG\r
+ JRST APSUBD ; DONE\r
+APSUB2: PUSH TP,A\r
+ PUSH TP,B\r
+ AOS E.CNT+1(TB) ; COUNT IT\r
+ JRST APSUB1\r
+\r
+APSUBD: MOVE A,E.CNT+1(TB) ; FINISHED, GET COUNT\r
+ MOVE B,E.FCN+1(TB) ; AND SUBR\r
+ GETYP 0,E.FCN(TB)\r
+ CAIN 0,TENTER\r
+ JRST APENDN\r
+ PUSHJ P,BLTDN ; FLUSH CRUFT\r
+ .ACALL A,(B)\r
+ POPJ P,\r
+\r
+BLTDN: MOVEI C,(TB) ; POINT TO DEST\r
+ HRLI C,E.TSUB(C) ; AND SOURCE\r
+ BLT C,-E.TSUB(TP) ;BL..............T\r
+ SUB TP,[E.TSUB,,E.TSUB]\r
+ POPJ P,\r
+\r
+APENDN: PUSHJ P,BLTDN\r
+APNDN1: .ECALL A,(B)\r
+ POPJ P,\r
+\r
+; FLAGS FOR RSUBR HACKER\r
+\r
+F.STR==1\r
+F.OPT==2\r
+F.QUO==4\r
+F.NFST==10\r
+\r
+; APPLY OBJECTS OF TYPE RSUBR\r
+\r
+APENTR:\r
+APRSUBR:\r
+ MOVE C,E.FCN+1(TB) ; GET THE RSUBR\r
+ CAML C,[-5,,] ; IS IT LONG ENOUGH FOR DECLS\r
+ JRST APSUBR ; NO TREAT AS A SUBR\r
+ GETYP 0,4(C) ; GET TYPE OF 3D ELEMENT\r
+ CAIE 0,TDECL ; DECLARATION?\r
+ JRST APSUBR ; NO, TREAT AS SUBR\r
+ PUSHJ P,PSH4ZR ; ALLOCATE SOME EXTRA ROOM\r
+ PUSH TP,$TDECL ; PUSH UP THE DECLS\r
+ PUSH TP,5(C)\r
+ PUSH TP,$TLOSE ; SAVE ROOM FOR VAL DECL\r
+ PUSH TP,[0]\r
+\r
+ SKIPN E.EXTR(TB) ; "EXTRA" ARG?\r
+ JRST APRSU1 ; NO,\r
+ MOVE 0,[SETZ EXTRGT] ; CHANGE THE ACCESS FCN\r
+ EXCH 0,E.ARG+1(TB)\r
+ HRRM 0,E.ARG(TB) ; REMEMBER IT\r
+\r
+APRSU1: MOVEI 0,0 ; INIT FLAG REGISTER\r
+ PUSH P,0 ; SAVE\r
+\r
+APRSU2: HRRZ A,E.DECL+1(TB) ; GET DECL LIST\r
+ JUMPE A,APRSU3 ; DONE!\r
+ HRRZ B,(A) ; CDR IT\r
+ MOVEM B,E.DECL+1(TB)\r
+ PUSHJ P,NXTDCL ; IS NEXT THING A STRING?\r
+ JRST APRSU4 ; NO, BETTER BE A TYPE\r
+ CAMN B,[ASCII /VALUE/]\r
+ JRST RSBVAL ; SAVE VAL DECL\r
+ TRON 0,F.NFST ; IF NOT FIRST, LOSE\r
+ CAME B,[ASCII /CALL/] ; CALL DECL\r
+ JRST APRSU7\r
+ SKIPGE E.ARG+1(TB) ; LEGAL?\r
+ JRST MPD\r
+ MOVE C,E.FRM(TB)\r
+ MOVE D,E.FRM+1(TB) ; GET FORM\r
+ JRST APRS10 ; HACK IT\r
+\r
+APRSU5: TROE 0,F.STR ; STRING STRING?\r
+ JRST MPD ; LOSER\r
+ CAME B,[<ASCII /OPTIO/>+1] ; OPTIONA?\r
+ JRST APRSU8\r
+ TROE 0,F.OPT ; CHECK AND SET\r
+ JRST MPD ; OPTINAL OPTIONAL LOSES\r
+ JRST APRSU2 ; TO MAIN LOOP\r
+\r
+APRSU7: CAME B,[ASCII /QUOTE/]\r
+ JRST APRSU5\r
+ TRO 0,F.STR\r
+ TROE 0,F.QUO ; TURN ON AND CHECK QUOTE\r
+ JRST MPD ; QUOTE QUOTE LOSES\r
+ JRST APRSU2 ; GO TO END OF LOOP\r
+\f\r
+\r
+APRSU8: CAME B,[ASCII /ARGS/]\r
+ JRST APRSU9\r
+ SKIPGE E.ARG+1(TB) ; SKIP IF LEGAL\r
+ JRST MPD\r
+ HRRZ D,@E.FRM+1(TB) ; GET ARG LIST\r
+ MOVSI C,TLIST\r
+\r
+APRS10: HRRZ A,(A) ; GET THE DECL\r
+ MOVEM A,E.DECL+1(TB) ; CLOBBER\r
+ HRRZ B,(A) ; CHECK FOR TOO MUCH\r
+ JUMPN B,MPD\r
+ MOVE B,1(A) ; GET DECL\r
+ HLLZ A,(A) ; GOT THE DECL\r
+ MOVEM 0,(P) ; SAVE FLAGS\r
+ JSP E,CHKAB ; CHECK DEFER\r
+ PUSH TP,C\r
+ PUSH TP,D ; SAVE\r
+ PUSHJ P,TMATCH\r
+ JRST WTYP\r
+ AOS E.CNT+1(TB) ; COUNT ARG\r
+ JRST APRDON ; GO CALL RSUBR\r
+\r
+RSBVAL: HRRZ A,E.DECL+1(TB) ; GET DECL\r
+ JUMPE A,MPD\r
+ HRRZ B,(A) ; POINT TO DECL\r
+ MOVEM B,E.DECL+1(TB) ; SAVE NEW DECL POINTER\r
+ PUSHJ P,NXTDCL\r
+ JRST .+2\r
+ JRST MPD\r
+ MOVEM A,E.VAL+1(TB) ; SAVE VAL DECL\r
+ MOVSI A,TDCLI\r
+ MOVEM A,E.VAL(TB) ; SET ITS TYPE\r
+ JRST APRSU2\r
+\f\r
+ \r
+APRSU9: CAME B,[ASCII /TUPLE/]\r
+ JRST MPD\r
+ MOVEM 0,(P) ; SAVE FLAGS\r
+ HRRZ A,(A) ; CDR DECLS\r
+ MOVEM A,E.DECL+1(TB)\r
+ HRRZ B,(A)\r
+ JUMPN B,MPD ; LOSER\r
+ PUSH P,[0] ; COUNT ELEMENTS IN TUPLE\r
+\r
+APRTUP: PUSHJ P,@E.ARG+1(TB) ; GOBBLE ARGS\r
+ JRST APRTPD ; DONE\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ AOS (P) ; COUNT IT\r
+ JRST APRTUP ; AND GO\r
+\r
+APRTPD: POP P,C ; GET COUNT\r
+ ADDM C,E.CNT+1(TB) ; UPDATE MAIN COUNT\r
+ ASH C,1 ; # OF WORDS\r
+ HRLI C,TINFO ; BUILD FENCE POST\r
+ PUSH TP,C\r
+ PUSHJ P,TBTOTP ; GEN REL OFFSET TO TOP\r
+ PUSH TP,D\r
+ HRROI D,-1(TP) ; POINT TO TOP\r
+ SUBI D,(C) ; TO BASE\r
+ TLC D,-1(C)\r
+ MOVSI C,TARGS ; BUILD TYPE WORD\r
+ HLR C,OTBSAV(TB)\r
+ MOVE A,E.DECL+1(TB)\r
+ MOVE B,1(A)\r
+ HLLZ A,(A) ; TYPE/VAL\r
+ JSP E,CHKAB ; CHECK\r
+ PUSHJ P,TMATCH ; GOTO TYPE CHECKER\r
+ JRST WTYP\r
+\r
+ SUB TP,[2,,2] ; REMOVE FENCE POST\r
+\r
+APRDON: SUB P,[1,,1] ; FLUSH CRUFT\r
+ MOVE A,E.CNT+1(TB) ; GET # OF ARGS\r
+ MOVE B,E.FCN+1(TB)\r
+ GETYP 0,E.FCN(TB) ; COULD BE ENTRY\r
+ MOVEI C,(TB) ; PREPARE TO BLT DOWN\r
+ HRLI C,E.TSUB+2(C)\r
+ BLT C,-E.TSUB+2(TP)\r
+ SUB TP,[E.TSUB+2,,E.TSUB+2]\r
+ CAIE 0,TRSUBR\r
+ JRST APNDN1\r
+ .ACALL A,(B) ; CALL THE RSUBR\r
+ JRST PFINIS\r
+\f\r
+\r
+\r
+APRSU4: MOVEM 0,(P) ; SAVE FLAGS\r
+ MOVE B,1(A) ; GET DECL\r
+ HLLZ A,(A)\r
+ JSP E,CHKAB\r
+ MOVE 0,(P) ; RESTORE FLAGS\r
+ PUSH TP,A\r
+ PUSH TP,B ; AND SAVE\r
+ SKIPL E.ARG+1(TB) ; ALREADY EVAL'D\r
+ TRZN 0,F.QUO\r
+ JRST APREVA ; MUST EVAL ARG\r
+ MOVEM 0,(P)\r
+ HRRZ C,@E.FRM+1(TB) ; GET ARG?\r
+ TRNE 0,F.OPT ; OPTIONAL\r
+ JUMPE C,APRDN\r
+ JUMPE C,TFA ; NO, TOO FEW ARGS\r
+ MOVEM C,E.FRM+1(TB)\r
+ HLLZ A,(C) ; GET ARG\r
+ MOVE B,1(C)\r
+ JSP E,CHKAB ; CHECK THEM\r
+\r
+APRTYC: MOVE C,A ; SET UP FOR TMATCH\r
+ MOVE D,B\r
+ EXCH B,(TP)\r
+ EXCH A,-1(TP) ; SAVE STUFF\r
+APRS11: PUSHJ P,TMATCH ; CHECK TYPE\r
+ JRST WTYP\r
+\r
+ MOVE 0,(P) ; RESTORE FLAGS\r
+ TRZ 0,F.STR\r
+ AOS E.CNT+1(TB)\r
+ JRST APRSU2 ; AND GO ON\r
+\r
+APREVA: PUSHJ P,@E.ARG+1(TB) ; EVAL ONE\r
+ TDZA C,C ; C=0 ==> NONE LEFT\r
+ MOVEI C,1\r
+ MOVE 0,(P) ; FLAGS\r
+ JUMPN C,APRTYC ; GO CHECK TYPE\r
+APRDN: SUB TP,[2,,2] ; FLUSH DECL\r
+ TRNE 0,F.OPT ; OPTIONAL?\r
+ JRST APRDON ; ALL DONE\r
+ JRST TFA\r
+\r
+APRSU3: TRNE 0,F.STR ; END IN STRING?\b \r
+ JRST MPD\r
+ PUSHJ P,@E.ARG+1(TB) ; SEE IF ANYMORE ARGS\r
+ JRST APRDON\r
+ JRST TMA\r
+\r
+\f\r
+; STANDARD ARGUMENT GETTERS USED IN APPLYING THINGS\r
+\r
+ARGCDR: HRRZ C,@E.FRM+1(TB) ; POINT TO ARGLIST (NOTE: POINTS 1 BEFORE WHERE ARG IS)\r
+ JUMPE C,CPOPJ ; LEAVE IF DONE\r
+ MOVEM C,E.FRM+1(TB)\r
+ GETYP 0,(C) ; GET TYPE OF ARG\r
+ CAIN 0,TSEG\r
+ JRST ARGCD1 ; SEG MENT HACK\r
+ PUSHJ P,FASTEV\r
+ JRST CPOPJ1\r
+\r
+ARGCD1: PUSH TP,$TFORM ; PRETEND WE ARE A FORM\r
+ PUSH TP,1(C)\r
+ MCALL 1,EVAL\r
+ MOVEM A,E.SEG(TB)\r
+ MOVEM B,E.SEG+1(TB)\r
+ PUSHJ P,TYPSEG ; GET SEG TYPE CODE\r
+ HRRM C,E.ARG(TB) ; SAVE IT IN OBSCCURE PLACE\r
+ MOVE C,[SETZ SGARG]\r
+ MOVEM C,E.ARG+1(TB) ; SET NEW ARG GETTER\r
+\r
+; FALL INTO SEGARG\r
+\r
+SGARG: INTGO\r
+ HRRZ C,E.ARG(TB) ; SEG CODE TO C\r
+ MOVE D,E.SEG+1(TB)\r
+ MOVE A,E.SEG(TB)\r
+ MOVEM A,DSTO(PVP)\r
+ PUSHJ P,NXTLM ; GET NEXT ELEMENT\r
+ JRST SEGRG1 ; DONE\r
+ MOVEM D,E.SEG+1(TB)\r
+ MOVE D,DSTO(PVP) ; KEEP TYPE WINNING\r
+ MOVEM D,E.SEG(TB)\r
+ SETZM DSTO(PVP)\r
+ JRST CPOPJ1 ; RETURN\r
+\r
+SEGRG1: SETZM DSTO(PVP)\r
+ MOVEI C,ARGCDR\r
+ MOVEM C,E.ARG+1(TB) ; RESET ARG GETTER\r
+ JRST ARGCDR\r
+\r
+; ARGUMENT GETTER FOR APPLY\r
+\r
+APLARG: INTGO\r
+ SKIPL A,E.FRM+1(TB) ; ANY ARGS LEFT\r
+ POPJ P, ; NO, EXIT IMMEDIATELY\r
+ ADD A,[2,,2]\r
+ MOVEM A,E.FRM+1(TB)\r
+ MOVE B,-1(A) ; RET NEXT ARG\r
+ MOVE A,-2(A)\r
+ JRST CPOPJ1\r
+\r
+; STACKFORM ARG GETTER\r
+\r
+EVALRG: SKIPN C,@E.FRM+1(TB) ; ANY FORM?\r
+ POPJ P,\r
+ PUSHJ P,FASTEV\r
+ GETYP A,A ; CHECK FOR FALSE\r
+ CAIN A,TFALSE\r
+ POPJ P,\r
+ MOVE C,E.FRM+1(TB) ; GET OTHER FORM\r
+ PUSHJ P,FASTEV\r
+ JRST CPOPJ1\r
+\r
+\f\r
+; HERE TOO APPLY NUMBERS\r
+\r
+APNUM: PUSHJ P,PSH4ZR ; TP SLOSTS\r
+ SKIPN A,E.EXTR(TB) ; FUNNY ARG?\r
+ JRST APNUM1 ; NOPE\r
+ MOVE B,E.EXTR+1(TB) ; GET ARG\r
+ JRST APNUM2\r
+\r
+APNUM1: PUSHJ P,@E.ARG+1(TB) ; GET ARG\r
+ JRST TFA\r
+APNUM2: PUSH TP,A\r
+ PUSH TP,B\r
+ PUSH TP,E.FCN(TB)\r
+ PUSH TP,E.FCN+1(TB)\r
+ PUSHJ P,@E.ARG+1(TB)\r
+ JRST .+2\r
+ JRST TMA\r
+ PUSHJ P,BLTDN ; FLUSH JUNK\r
+ MCALL 2,NTH\r
+ POPJ P,\r
+\f\r
+; HERE TO APPLY SUSSMAN FUNARGS\r
+\r
+APFUNARG:\r
+\r
+ SKIPN C,E.FCN+1(TB)\r
+ JRST FUNERR\r
+ HRRZ D,(C) ; MUST BE AT LEAST 2 LONG\r
+ JUMPE D,FUNERR\r
+ GETYP 0,(D) ; CHECK FOR LIST\r
+ CAIE 0,TLIST\r
+ JRST FUNERR\r
+ HRRZ 0,(D) ; SHOULD BE END\r
+ JUMPN 0,FUNERR\r
+ GETYP 0,(C) ; 1ST MUST BE FCN\r
+ CAIE 0,TEXPR\r
+ JRST FUNERR\r
+ SKIPN C,1(C)\r
+ JRST NOBODY\r
+ PUSHJ P,APEXPF ; BIND THE ARGS AND AUX'S\r
+ HRRZ C,RE.FCN+1(TB) ; GET BODY OF FUNARG\r
+ MOVE B,1(C) ; GET FCN\r
+ MOVEM B,RE.FCN+1(TB) ; AND SAVE\r
+ HRRZ C,(C) ; CDR FUNARG BODY\r
+ MOVE C,1(C)\r
+ MOVSI 0,TLIST ; SET UP TYPE\r
+ MOVEM 0,CSTO(PVP) ; FOR INTS TO WIN\r
+\r
+FUNLP: INTGO\r
+ JUMPE C,DOF ; RUN IT\r
+ GETYP 0,(C)\r
+ CAIE 0,TLIST ; BETTER BE LIST\r
+ JRST FUNERR\r
+ PUSH TP,$TLIST\r
+ PUSH TP,C\r
+ PUSHJ P,NEXTDC ; GET POSSIBILITY\r
+ JRST FUNERR ; LOSER\r
+ CAIE A,2\r
+ JRST FUNERR\r
+ HRRZ B,(B) ; GET TO VALUE\r
+ MOVE C,(TP)\r
+ SUB TP,[2,,2]\r
+ PUSH TP,BNDA\r
+ PUSH TP,E\r
+ HLLZ A,(B) ; GET VAL\r
+ MOVE B,1(B)\r
+ JSP E,CHKAB ; HACK DEFER\r
+ PUSHJ P,PSHAB4 ; PUT VAL IN\r
+ HRRZ C,(C) ; CDR\r
+ JUMPN C,FUNLP\r
+\r
+; HERE TO RUN FUNARG\r
+\r
+DOF: SETZM CSTO(PVP) ; DONT CONFUSE GC\r
+ PUSHJ P,SPECBIND ; BIND 'EM UP\r
+ JRST RUNFUN\r
+\r
+\r
+\f\r
+; HERE TO DO MACROS\r
+\r
+APMACR: HRRZ E,OTBSAV(TB)\r
+ HRRZ E,PCSAV(E) ; SEE WHERE FROM\r
+ CAIN E,AEVAL3 ; SKIP IF NOT RIGHT\r
+ JRST APMAC1\r
+ SKIPG E.ARG+1(TB) ; SKIP IF REAL FORM EXISTS\r
+ JRST BADMAC\r
+ MOVE A,E.FRM(TB)\r
+ MOVE B,E.FRM+1(TB)\r
+ SUB TP,[E.EXTR+2,,E.EXTR+2] ; FLUSH JUNK\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ MCALL 1,EXPAND ; EXPAND THE MACRO\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ MCALL 1,EVAL ; EVAL THE RESULT\r
+ POPJ P,\r
+\r
+APMAC1: MOVE C,E.FCN+1(TB) ; GET MACRO BODY\r
+ GETYP A,(C)\r
+ MOVE B,1(C)\r
+ MOVSI A,(A)\r
+ JSP E,CHKAB ; FIX DEFERS\r
+ MOVEM A,E.FCN(TB)\r
+ MOVEM B,E.FCN+1(TB)\r
+ JRST APLDIX\r
+ \r
+; HERE TO APPLY EXPRS (FUNCTIONS)\r
+\r
+APEXPR: PUSHJ P,APEXP ; BIND ARGS AND AUX'S\r
+RUNFUN: HRRZ A,RE.FCN(TB) ; AMOUNT OF FCN TO SKIP\r
+ MOVEI C,RE.FCN+1(TB) ; POINT TO FCN\r
+ HRRZ C,(C) ; SKIP SOMETHING\r
+ SOJGE A,.-1 ; UNTIL 1ST FORM\r
+ MOVEM C,RE.FCN+1(TB) ; AND STORE\r
+ JRST DOPROG ; GO RUN PROGRAM\r
+\r
+APEXP: SKIPN C,E.FCN+1(TB) ; CHECK FRO BODY\r
+ JRST NOBODY\r
+APEXPF: PUSH P,[0] ; COUNT INIT CRAP\r
+ ADD TP,[XP.TMP,,XP.TMP] ; SLOTS FOR HACKING\r
+ SKIPL TP\r
+ PUSHJ P,TPOVFL\r
+ SETZM 1-XP.TMP(TP) ; ZERO OUT\r
+ MOVEI A,-XP.TMP+2(TP)\r
+ HRLI A,-1(A)\r
+ BLT A,(TP) ; ZERO SLOTS\r
+ PUSHJ P,CARATC ; SEE IF HEWITT ATOM EXISTS\r
+ JRST APEXP1 ; NO, GO LOOK FOR ARGLIST\r
+ MOVEM E,E.HEW+1(TB) ; SAVE ATOM\r
+ MOVSM 0,E.HEW(TB) ; AND TYPE\r
+ AOS (P) ; COUNT HEWITT ATOM\r
+APEXP1: GETYP 0,(C) ; LOOK AT NEXT THING\r
+ CAIE 0,TLIST ; BETTER BE LIST!!!\r
+ JRST MPD.0 ; LOSE\r
+ MOVE B,1(C) ; GET LIST\r
+ MOVEM B,E.ARGL+1(TB) ; SAVE\r
+ MOVSM 0,E.ARGL(TB) ; WITH TYPE\r
+ HRRZ C,(C) ; CDR THE FCN\r
+ JUMPE C,NOBODY ; BODYLESS FCN\r
+ GETYP 0,(C) ; SEE IF DCL LIST SUPPLIED\r
+ CAIE 0,TDECL\r
+ JRST APEXP2 ; NO, START PROCESSING ARGS\r
+ AOS (P) ; COUNT DCL\r
+ MOVE B,1(C)\r
+ MOVEM B,E.DECL+1(TB)\r
+ MOVSM 0,E.DECL(TB)\r
+ HRRZ C,(C) ; CDR ON\r
+ JUMPE C,NOBODY\r
+\r
+ ; CHECK FOR EXISTANCE OF EXTRA ARG\r
+\r
+APEXP2: POP P,A ; GET COUNT\r
+ HRRM A,E.FCN(TB) ; AND SAVE\r
+ SKIPN E.EXTR(TB) ; SKIP IF FUNNY EXTRA ARG EXISTS\r
+ JRST APEXP3\r
+ MOVE 0,[SETZ EXTRGT]\r
+ EXCH 0,E.ARG+1(TB)\r
+ HRRM 0,E.ARG(TB) ; SAVE OLD GETTER AROUND\r
+\r
+; FALL THROUGH\r
+ \f\r
+; LOOK FOR "BIND" DECLARATION\r
+\r
+APEXP3: PUSHJ P,UNPROG ; UNASSIGN LPROG IF NEC\r
+APXP3A: SKIPN A,E.ARGL+1(TB) ; GET ARGLIST\r
+ JRST APEXP4 ; NONE, VERIFY NONE WERE GIVEN\r
+ PUSHJ P,NXTDCL ; SEE IF A DECL IS THERE\r
+ JRST BNDRG ; NO, GO BIND NORMAL ARGS\r
+ HRRZ C,(A) ; CDR THE DCLS\r
+ CAME B,[ASCII /BIND/]\r
+ JRST CH.CAL ; GO LOOK FOR "CALL"\r
+ PUSHJ P,CARTMC ; MUST BE AN ATOM\r
+ MOVEM C,E.ARGL+1(TB) ; AND SAVE CDR'D ARGS\r
+ PUSHJ P,MAKENV ; GENERATE AN ENVIRONMENT\r
+ PUSHJ P,PSBND1 ; PUSH THE BINDING AND CHECK THE DCL\r
+ JRST APXP3A ; IN CASE <"BIND" B "BIND" C......\r
+\r
+\r
+; LOOK FOR "CALL" DCL\r
+\r
+CH.CAL: CAME B,[ASCII /CALL/]\r
+ JRST CHOPT ; TRY SOMETHING ELSE\r
+ SKIPG E.ARG+1(TB) ; DONT SKIP IF CANT WIN\r
+ JRST MPD.2\r
+ PUSHJ P,CARTMC ; BETTER BE AN ATOM\r
+ MOVEM C,E.ARGL+1(TB)\r
+ MOVE A,E.FRM(TB) ; RETURN FORM\r
+ MOVE B,E.FRM+1(TB)\r
+ PUSHJ P,PSBND1 ; BIND AND CHECK\r
+ JRST APEXP5\r
+ \f\r
+; BIND NORMAL ARGS BY CALLING BNDEM1, RETURNS WHEN ALL DONE\r
+\r
+BNDRG: PUSHJ P,BNDEM1 ; GO BIND THEM UP\r
+ TRNN A,4 ; SKIP IF HIT A DCL\r
+ JRST APEXP4 ; NOT A DCL, MUST BE DONE\r
+\r
+; LOOK FOR "OPTIONAL" DECLARATION\r
+\r
+CHOPT: CAME B,[<ASCII /OPTIO/>+1]\r
+ JRST CHREST ; TRY TUPLE/ARGS\r
+ MOVEM C,E.ARGL+1(TB) ; SAVE RESTED ARGLIST\r
+ PUSHJ P,BNDEM2 ; DO ALL SUPPLIED OPTIONALS\r
+ TRNN A,4 ; SKIP IF NEW DCL READ\r
+ JRST APEXP4\r
+\r
+; CHECK FOR "ARGS" DCL\r
+\r
+CHREST: CAME B,[ASCII /ARGS/]\r
+ JRST CHRST1 ; GO LOOK FOR "TUPLE"\r
+ SKIPGE E.ARG+1(TB) ; SKIP IF LEGAL \r
+ JRST MPD.3\r
+ PUSHJ P,CARTMC ; GOBBLE ATOM\r
+ MOVEM C,E.ARGL+1(TB) ; SAVE CDR'D ARG\r
+ HRRZ B,@E.FRM+1(TB) ; GET ARG LIST\r
+ MOVSI A,TLIST ; GET TYPE\r
+ PUSHJ P,PSBND1\r
+ JRST APEXP5\r
+\r
+; HERE TO CHECK FOR "TUPLE"\r
+\r
+CHRST1: CAME B,[ASCII /TUPLE/]\r
+ JRST APXP10\r
+ PUSHJ P,CARTMC ; GOBBLE ATOM\r
+ MOVEM C,E.ARGL+1(TB)\r
+ SETZB A,B\r
+ PUSHJ P,PSHBND ; SET UP BINDING\r
+ SETZM E.CNT+1(TB) ; ZERO ARG COUNTER\r
+\r
+TUPLP: PUSHJ P,@E.ARG+1(TB) ; GET AN ARG\r
+ JRST TUPDON ; FINIS\r
+ AOS E.CNT+1(TB)\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ JRST TUPLP\r
+\r
+TUPDON: PUSHJ P,MAKINF ; MAKE INFO CELL\r
+ PUSH TP,$TINFO ; FENCE POST TUPLE\r
+ PUSHJ P,TBTOTP\r
+ ADDI D,TM.OFF ; COMPENSATE FOR MOVEMENT\r
+ PUSH TP,D\r
+ MOVE C,E.CNT+1(TB) ; GET COUNT\r
+ ASH C,1 ; TO WORDS\r
+ HRRM C,-1(TP) ; INTO FENCE POST\r
+ MOVEI B,-TM.OFF-1(TP) ; SETUP ARG POINTER\r
+ SUBI B,(C) ; POINT TO BASE OF TUPLE\r
+ MOVNS C ; FOR AOBJN POINTER\r
+ HRLI B,(C) ; GOOD ARGS POINTER\r
+ MOVEM A,TM.OFF-4(B) ; STORE\r
+ MOVEM B,TM.OFF-3(B)\r
+\r
+\f\r
+; CHECK FOR VALID ENDING TO ARGS\r
+\r
+APEXP5: PUSHJ P,NEXTD ; READ NEXT THING IN ARGLIST\r
+ JRST APEXP8 ; DONE\r
+ TRNN A,4 ; SKIP IF DCL\r
+ JRST MPD.4 ; LOSER\r
+APEXP7: MOVSI A,-NWINS ; CHECK FOR A WINNER\r
+ CAME B,WINRS(A)\r
+ AOBJN A,.-1\r
+ JUMPE A,MPD.6 ; NOT A WINNER\r
+\r
+; HERE TO BLT THE WORLD DOWN ON TOP OF ALL THE USELESS TEMPS\r
+\r
+APEXP8: MOVE 0,E.HEW+1(TB) ; GET HEWITT ATOM\r
+ MOVE E,E.FCN(TB) ; SAVE COUNTER\r
+ MOVE C,E.FCN+1(TB) ; FCN\r
+ MOVE B,E.ARGL+1(TB) ; ARG LIST\r
+ MOVE D,E.DECL+1(TB) ; AND DCLS\r
+ MOVEI A,R.TMP(TB) ; SET UP BLT\r
+ HRLI A,TM.OFF(A)\r
+ BLT A,-TM.OFF(TP) ; BLLLLLLLLLLLLLT\r
+ SUB TP,[TM.OFF,,TM.OFF] ; FLUSH CRUFT\r
+ MOVEM E,RE.FCN(TB)\r
+ MOVEM C,RE.FCN+1(TB)\r
+ MOVEM B,RE.ARGL+1(TB)\r
+ MOVE E,TP\r
+ PUSH TP,$TATOM\r
+ PUSH TP,0\r
+ PUSH TP,$TDECL\r
+ PUSH TP,D\r
+ GETYP A,-5(TP) ; TUPLE ON TOP?\r
+ CAIE A,TINFO ; SKIP IF YES\r
+ JRST APEXP9\r
+ HRRZ A,-5(TP) ; GET SIZE\r
+ ADDI A,2\r
+ HRLI A,(A)\r
+ SUB E,A ; POINT TO BINDINGS\r
+ SKIPE C,(TP) ; IF DCL\r
+ PUSHJ P,CHKDCL ; CHECK TYPE SPEC ON TUPLE\r
+APEXP9: PUSHJ P,USPCBE ; DO ACTUAL BINDING\r
+\r
+ MOVE E,-2(TP) ; RESTORE HEWITT ATOM\r
+ MOVE D,(TP) ; AND DCLS\r
+ SUB TP,[4,,4]\r
+\r
+ JRST AUXBND ; GO BIND AUX'S\r
+\r
+; HERE TO VERIFY CHECK IF ANY ARGS LEFT\r
+\r
+APEXP4: PUSHJ P,@E.ARG+1(TB)\r
+ JRST APEXP8 ; WIN\r
+ JRST TMA ; TOO MANY ARGS\r
+\r
+APXP10: PUSH P,B\r
+ PUSHJ P,@E.ARG+1(TB)\r
+ JRST .+2\r
+ JRST TMA\r
+ POP P,B\r
+ JRST APEXP7\r
+\r
+; LIST OF POSSIBLE TERMINATING NAMES\r
+\r
+WINRS:\r
+AS.ACT: ASCII /ACT/\r
+AS.NAM: ASCII /NAME/\r
+AS.AUX: ASCII /AUX/\r
+AS.EXT: ASCII /EXTRA/\r
+NWINS==.-WINRS\r
+\r
+ \f\r
+; HERE TO BIND AUX VARIABLES FOR PROGS AND FCNS\r
+\r
+AUXBND: PUSH P,E ; SAVE HEWITT ATOM ( WILL PUT ON MARKED STACK\r
+ ; WHEN NECESSARY)\r
+ PUSH P,D ; SAME WITH DCL LIST\r
+ PUSH P,[-1] ; FLAG SAYING WE ARE FCN\r
+ SKIPN C,RE.ARG+1(TB) ; GET ARG LIST\r
+ JRST AUXDON\r
+ GETYP 0,(C) ; GET TYPE\r
+ CAIE 0,TDEFER ; SKIP IF CHSTR\r
+ MOVMS (P) ; SAY WE ARE IN OPTIONALS\r
+ JRST AUXB1\r
+\r
+PRGBND: PUSH P,E\r
+ PUSH P,D\r
+ PUSH P,[0] ; WE ARE IN AUXS\r
+\r
+AUXB1: HRRZ C,RE.ARG+1(TB) ; POINT TO ARGLIST\r
+ PUSHJ P,NEXTDC ; GET NEXT THING OFF OF ARG LIST\r
+ JRST AUXDON\r
+ TRNE A,4 ; SKIP IF SOME KIND OF ATOM\r
+ JRST TRYDCL ; COUDL BE DCL\r
+ TRNN A,1 ; SKIP IF QUOTED\r
+ JRST AUXB2\r
+ SKIPN (P) ; SKIP IF QUOTED OK\r
+ JRST MPD.11\r
+AUXB2: PUSHJ P,PSHBND ; SET UP BINDING\r
+ PUSH TP,$TDECL ; SAVE HEWITT ATOM\r
+ PUSH TP,-1(P)\r
+ PUSH TP,$TATOM ; AND DECLS\r
+ PUSH TP,-2(P)\r
+\r
+ TRNN A,2 ; SKIP IF INIT VAL EXISTS\r
+ JRST AUXB3 ; NO, USE UNBOUND\r
+\r
+; EVALUATE EXPRESSION\r
+\r
+ HRRZ C,(B) ; CDR ATOM OFF\r
+\r
+; CHECK FOR SPECIAL FORMS <TUPLE ...> <ITUPLE ...>\r
+\r
+ GETYP 0,(C) ; GET TYPE OF GOODIE\r
+ CAIE 0,TFORM ; SMELLS LIKE A FORM\r
+ JRST AUXB13\r
+ HRRZ D,1(C) ; GET 1ST ELEMENT\r
+ GETYP 0,(D) ; AND ITS VAL\r
+ CAIE 0,TATOM ; FEELS LIKE THE RIGHT FORM\r
+ JRST AUXB13\r
+\r
+ MOVE 0,1(D) ; GET THE ATOM\r
+ CAME 0,MQUOTE TUPLE\r
+ CAMN 0,MQUOTE ITUPLE\r
+ JRST DOTUPL ; SURE GLAD I DIDN'T STEP IN THAT FORM\r
+\r
+\r
+AUXB13: PUSHJ P,FASTEV\r
+AUXB14: MOVE E,TP\r
+AUXB4: MOVEM A,-7(E) ; STORE VAL IN BINDING\r
+ MOVEM B,-6(E)\r
+\r
+; HERE TO CHECK AGAINST DECLARATIONS AND COMPLETE THE BINDING\r
+\r
+AUXB5: SUB E,[4,,4] ; POINT TO BINDING TOP\r
+ SKIPE C,-2(TP) ; POINT TO DECLARATINS\r
+ PUSHJ P,CHKDCL ; CHECK IT\r
+ PUSHJ P,USPCBE ; AND BIND UP\r
+ SKIPE C,RE.ARG+1(TB) ; CDR DCLS\r
+ HRRZ C,(C) ; IF ANY TO CDR\r
+ MOVEM C,RE.ARG+1(TB)\r
+ MOVE A,(TP) ; NOW PUT HEWITT ATOM AND DCL AWAY\r
+ MOVEM A,-2(P)\r
+ MOVE A,-2(TP)\r
+ MOVEM A,-1(P)\r
+ SUB TP,[4,,4] ; FLUSH SLOTS\r
+ JRST AUXB1\r
+\r
+\r
+AUXB3: MOVNI B,1\r
+ MOVSI A,TUNBOU\r
+ JRST AUXB14\r
+\r
+\f\r
+\r
+; HERE TO HANDLE "CALLS" TO TUPLE AND ITUPLE\r
+\r
+DOTUPL: PUSH TP,$TLIST ; SAVE THE MAGIC FORM\r
+ PUSH TP,D\r
+ CAME 0,MQUOTE TUPLE\r
+ JRST DOITUP ; DO AN ITUPLE\r
+\r
+; FALL INTO A TUPLE PUSHING LOOP\r
+\r
+DOTUP1: HRRZ C,@(TP) ; CDR THE FORM\r
+ JUMPE C,ATUPDN ; FINISHED\r
+ MOVEM C,(TP) ; SAVE CDR'D RESULT\r
+ GETYP 0,(C) ; CHECK FOR SEGMENT\r
+ CAIN 0,TSEG\r
+ JRST DTPSEG ; GO PULL IT APART\r
+ PUSHJ P,FASTEV ; EVAL IT\r
+ PUSHJ P,CNTARG ; PUSH IT UP AND COUNT THEM\r
+ JRST DOTUP1\r
+\r
+; HERE WHEN WE FINISH\r
+\r
+ATUPDN: SUB TP,[2,,2] ; FLUSH THE LIST\r
+ ASH E,1 ; E HAS # OF ARGS DOUBLE IT\r
+ MOVEI D,(TP) ; FIND BASE OF STACK AREA\r
+ SUBI D,(E)\r
+ MOVSI C,-3(D) ; PREPARE BLT POINTER\r
+ BLT C,C ; HEWITT ATOM AND DECL TO 0,A,B,C\r
+\r
+; NOW PREPEARE TO BLT TUPLE DOWN\r
+\r
+ MOVEI D,-3(D) ; NEW DEST\r
+ HRLI D,4(D) ; SOURCE\r
+ BLT D,-4(TP) ; SLURP THEM DOWN\r
+\r
+ HRLI E,TINFO ; SET UP FENCE POST\r
+ MOVEM E,-3(TP) ; AND STORE\r
+ PUSHJ P,TBTOTP ; GET OFFSET\r
+ ADDI D,3 ; FUDGE FOR NOT AT TOP OF STACK\r
+ MOVEM D,-2(TP)\r
+ MOVEM 0,-1(TP) ; RESTORE HEW ATOM AND DECLS\r
+ MOVEM A,(TP)\r
+ PUSH TP,B\r
+ PUSH TP,C\r
+\r
+ PUSHJ P,MAKINF ; MAKE 1ST WORD OF FUNNYS\r
+\r
+ HRRZ E,-5(TP) ; RESTORE WORDS OF TUPLE\r
+ HRROI B,-5(TP) ; POINT TO TOP OF TUPLE\r
+ SUBI B,(E) ; NOW BASE\r
+ TLC B,-1(E) ; FIX UP AOBJN PNTR\r
+ ADDI E,2 ; COPNESATE FOR FENCE PST\r
+ HRLI E,(E)\r
+ SUBM TP,E ; E POINT TO BINDING\r
+ JRST AUXB4 ; GO CLOBBER IT IN\r
+\f\r
+\r
+; HERE TO HANDLE SEGMENTS IN THESE FUNNY FORMS\r
+\r
+DTPSEG: PUSH TP,$TFORM ; SAVE THE HACKER\r
+ PUSH TP,1(C)\r
+ MCALL 1,EVAL ; AND EVALUATE IT\r
+ MOVE D,B ; GET READY FOR A SEG LOOP\r
+ MOVEM A,DSTO(PVP)\r
+ PUSHJ P,TYPSEG ; TYPE AND CHECK IT\r
+\r
+DTPSG1: INTGO ; DONT BLOW YOUR STACK\r
+ PUSHJ P,NXTLM ; ELEMENT TO A AND B\r
+ JRST DTPSG2 ; DONE\r
+ PUSHJ P,CNTARG ; PUSH AND COUNT\r
+ JRST DTPSG1\r
+\r
+DTPSG2: SETZM DSTO(PVP)\r
+ JRST DOTUP1 ; REST OF ARGS STILL TO DO\r
+\r
+; HERE TO HACK <ITUPLE .....>\r
+\r
+DOITUP: HRRZ C,@(TP) ; GET COUNT FILED\r
+ JUMPE C,TUPTFA\r
+ MOVEM C,(TP)\r
+ PUSHJ P,FASTEV ; EVAL IT\r
+ GETYP 0,A\r
+ CAIE 0,TFIX\r
+ JRST WTY1TP\r
+\r
+ JUMPL B,BADNUM\r
+\r
+ HRRZ C,@(TP) ; GET EXP TO EVAL\r
+ MOVEI 0,0 ; DONT LOSE IN 1 ARG CASE\r
+ HRRZ 0,(C) ; VERIFY WINNAGE\r
+ JUMPN 0,TUPTMA ; TOO MANY\r
+\r
+ JUMPE B,DOIDON\r
+ PUSH P,B ; SAVE COUNT\r
+ PUSH P,B\r
+ JUMPE C,DOILOS\r
+ PUSHJ P,FASTEV ; EVAL IT ONCE\r
+ MOVEM A,-1(TP)\r
+ MOVEM B,(TP)\r
+\r
+DOILP: INTGO\r
+ PUSH TP,-1(TP)\r
+ PUSH TP,-1(TP)\r
+ MCALL 1,EVAL\r
+ PUSHJ P,CNTRG\r
+ SOSLE (P)\r
+ JRST DOILP\r
+\r
+DOIDO1: MOVE B,-1(P) ; RESTORE COUNT\r
+ SUB P,[2,,2]\r
+\r
+DOIDON: MOVEI E,(B)\r
+ JRST ATUPDN\r
+\r
+; FOR CASE OF NO EVALE\r
+\r
+DOILOS: SUB TP,[2,,2]\r
+DOILLP: INTGO\r
+ PUSH TP,[0]\r
+ PUSH TP,[0]\r
+ SOSL (P)\r
+ JRST DOILLP\r
+ JRST DOIDO1\r
+\r
+; ROUTINE TO PUSH NEXT TUPLE ELEMENT\r
+\r
+CNTARG: AOS E,-1(TP) ; KEEP ARG COUNT UP TO DATE IN E\r
+CNTRG: EXCH A,-1(TP) ; STORE ELEM AND GET SAVED\r
+ EXCH B,(TP)\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ POPJ P,\r
+\r
+\r
+; DUMMY TUPLE AND ITUPLE \r
+\r
+MFUNCTION TUPLE,SUBR\r
+\r
+ ENTRY\r
+ PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE NOT-IN-ARG-LIST\r
+ JRST CALER1\r
+\r
+MFUNCTIO ITUPLE,SUBR\r
+ JRST TUPLE\r
+\r
+\f\r
+; PROCESS A DCL IN THE AUX VAR LISTS\r
+\r
+TRYDCL: SKIPN (P) ; SKIP IF NOT IN AUX'S\r
+ JRST AUXB7\r
+ CAME B,AS.AUX ; "AUX" ?\r
+ CAMN B,AS.EXT ; OR "EXTRA"\r
+ JRST AUXB9 ; YES\r
+ CAME B,[ASCII /TUPLE/]\r
+ JRST AUXB10\r
+ PUSHJ P,MAKINF ; BUILD EMPTY TUPLE\r
+ MOVEI B,1(TP)\r
+ PUSH TP,$TINFO ; FENCE POST\r
+ PUSHJ P,TBTOTP\r
+ PUSH TP,D\r
+AUXB6: HRRZ C,(C) ; CDR PAST DCL\r
+ MOVEM C,RE.ARG+1(TB)\r
+AUXB8: PUSHJ P,CARTMC ; GET ATOM\r
+AUXB12: PUSHJ P,PSHBND ; UP GOES THE BINDING\r
+ PUSH TP,$TATOM ; HIDE HEWITT ATOM AND DCL\r
+ PUSH TP,-1(P)\r
+ PUSH TP,$TDECL\r
+ PUSH TP,-2(P)\r
+ MOVE E,TP\r
+ JRST AUXB5\r
+\r
+; CHECK FOR ARGS\r
+\r
+AUXB10: CAME B,[ASCII /ARGS/]\r
+ JRST AUXB7\r
+ MOVEI B,0 ; NULL ARG LIST\r
+ MOVSI A,TLIST\r
+ JRST AUXB6 ; GO BIND\r
+\r
+AUXB9: SETZM (P) ; NOW READING AUX\r
+ HRRZ C,(C)\r
+ MOVEM C,RE.ARG+1(TB)\r
+ JRST AUXB1\r
+\r
+; CHECK FOR NAME/ACT\r
+\r
+AUXB7: CAME B,AS.NAM\r
+ CAMN B,AS.ACT\r
+ JRST .+2\r
+ JRST MPD.12 ; LOSER\r
+ HRRZ C,(C) ; CDR ON\r
+ HRRZ 0,(C) ; BETTER BE END\r
+ JUMPN 0,MPD.13\r
+ PUSHJ P,CARTMC ; FORCE ATOM READ\r
+ SETZM RE.ARG+1(TB)\r
+AUXB11: PUSHJ P,MAKACT ; MAKE ACTIVATION\r
+ JRST AUXB12 ; AND BIND IT\r
+\r
+\r
+; DONE BIND HEWITT ATOM IF NECESARY\r
+\r
+AUXDON: SKIPN E,-2(P)\r
+ JRST AUXD1\r
+ SETZM -2(P)\r
+ JRST AUXB11\r
+\r
+; FINISHED, RETURN\r
+\r
+AUXD1: SUB P,[3,,3]\r
+ POPJ P,\r
+\r
+\r
+; MAKE AN ACTIVATION OR ENVIRONMNENT\r
+\r
+MAKACT: MOVEI B,(TB)\r
+ MOVSI A,TACT\r
+MAKAC1: HRRI A,PVLNT*2+1(PVP) ; POINT TO PROCESS\r
+ HLL B,OTBSAV(B) ; GET TIME\r
+ POPJ P,\r
+\r
+MAKENV: MOVSI A,TENV\r
+ HRRZ B,OTBSAV(TB)\r
+ JRST MAKAC1\r
+\f\r
+; SEVERAL USEFUL LITTLE ROUTINES FOR HACKING THIS STUFF\r
+\r
+; CARAT/CARATC/CARATM/CARTMC ALL LOOK FOR THE NEXT ATOM\r
+\r
+CARAT: HRRZ C,E.ARGL+1(TB) ; PICK UP ARGLIST\r
+CARATC: JUMPE C,CPOPJ ; FOUND\r
+ GETYP 0,(C) ; GET ITS TYPE\r
+ CAIE 0,TATOM\r
+CPOPJ: POPJ P, ; RETURN, NOT ATOM\r
+ MOVE E,1(C) ; GET ATOM\r
+ HRRZ C,(C) ; CDR DCLS\r
+ JRST CPOPJ1\r
+\r
+CARATM: HRRZ C,E.ARGL+1(TB)\r
+CARTMC: PUSHJ P,CARATC\r
+ JRST MPD.7 ; REALLY LOSE\r
+ POPJ P,\r
+\r
+\r
+; SUBROUTINES TO PUSH BINDINGS ETC. UP ON THE STACK\r
+\r
+PSBND1: PUSHJ P,PSHBND ; PUSH THEBINDING\r
+ JRST CHDCL ; NOW CHECK IT AGAINST DECLARATION\r
+\r
+PSHBND: SKIPGE SPCCHK ; SKIP IF NORMAL SPECIAL\r
+ PUSH TP,BNDA1 ; ATOM IN E\r
+ SKIPL SPCCHK ; SKIP IF NORMAL UNSPEC OR NO CHECK\r
+ PUSH TP,BNDA\r
+ PUSH TP,E ; PUSH IT\r
+PSHAB4: PUSH TP,A\r
+ PUSH TP,B\r
+ PUSH TP,[0]\r
+ PUSH TP,[0]\r
+ POPJ P,\r
+\r
+; ROUTINE TO PUSH 4 0'S\r
+\r
+PSH4ZR: SETZB A,B\r
+ JRST PSHAB4\r
+\r
+\r
+; EXTRRA ARG GOBBLER\r
+\r
+EXTRGT: HRRZ A,E.ARG(TB) ; RESET SLOT\r
+ CAIE A,ARGCDR ; IF NOT ARGCDR\r
+ TLO A,400000 ; SET FLAG\r
+ MOVEM A,E.ARG+1(TB)\r
+ MOVE A,E.EXTR(TB) ; RET ARG\r
+ MOVE B,E.EXTR+1(TB)\r
+ JRST CPOPJ1\r
+\r
+; CHECK A/B FOR DEFER\r
+\r
+CHKAB: GETYP 0,A\r
+ CAIE 0,TDEFER ; SKIP IF DEFER\r
+ JRST (E)\r
+ MOVE A,(B)\r
+ MOVE B,1(B) ; GET REAL THING\r
+ JRST (E)\r
+; IF DECLARATIONS EXIST, DO THEM\r
+\r
+CHDCL: MOVE E,TP\r
+CHDCLE: SKIPN C,E.DECL+1(TB)\r
+ POPJ P,\r
+ JRST CHKDCL\r
+\f\r
+; ROUTINE TO READ NEXT THING FROM ARGLIST\r
+\r
+NEXTD: HRRZ C,E.ARGL+1(TB) ; GET ARG LIST\r
+NEXTDC: JUMPE C,CPOPJ\r
+ PUSHJ P,CARATC ; TRY FOR AN ATOM\r
+ JRST NEXTD1 ; NO\r
+ MOVEI A,0 ; SET FLAG\r
+ JRST CPOPJ1\r
+\r
+NEXTD1: CAIE 0,TFORM ; FORM?\r
+ JRST NXT.L ; COULD BE LIST\r
+ PUSHJ P,CHQT ; VERIFY 'ATOM\r
+ MOVEI A,1\r
+ JRST CPOPJ1\r
+\r
+NXT.L: CAIE 0,TLIST ; COULD BE (A <EXPRESS>) OR ('A <EXPRESS>)\r
+ JRST NXT.S ; BETTER BE A DCL\r
+ PUSHJ P,LNT.2 ; VERIFY LENGTH IS 2\r
+ JRST MPD.8\r
+ CAIE 0,TATOM ; TYPE OF 1ST RET IN 0\r
+ JRST LST.QT ; MAY BE 'ATOM\r
+ MOVE E,1(B) ; GET ATOM\r
+ MOVEI A,2\r
+ JRST CPOPJ1\r
+LST.QT: CAIE 0,TFORM ; FORM?\r
+ JRST MPD.9 ; LOSE\r
+ PUSH P,C\r
+ MOVEI C,(B) ; VERIFY 'ATOM\r
+ PUSHJ P,CHQT\r
+ MOVEI B,(C) ; POINT BACK TO LIST\r
+ POP P,C\r
+ MOVEI A,3 ; CODE\r
+ JRST CPOPJ1\r
+\r
+NXT.S: MOVEI A,(C) ; LET NXTDCL FIND OUT\r
+ PUSHJ P,NXTDCL\r
+ JRST MPD.3 ; LOSER\r
+ MOVEI A,4 ; SET DCL READ FLAG\r
+ JRST CPOPJ1\r
+\r
+; ROUTINE TO CHECK LENGTH OF LIST/FORM FOR BEING 2\r
+\r
+LNT.2: HRRZ B,1(C) ; GET LIST/FORM\r
+ JUMPE B,CPOPJ\r
+ HRRZ B,(B)\r
+ JUMPE B,CPOPJ\r
+ HRRZ B,(B) ; BETTER END HERE\r
+ JUMPN B,CPOPJ\r
+ HRRZ B,1(C) ; LIST BACK\r
+ GETYP 0,(B) ; TYPE OF 1ST ELEMENT\r
+ JRST CPOPJ1\r
+\r
+; ROUTINE TO VERIFY FORM IS 'ATOM AND RET ATOM\r
+\r
+CHQT: PUSHJ P,LNT.2 ; 1ST LENGTH CHECK\r
+ JRST MPD.5\r
+ CAIE 0,TATOM\r
+ JRST MPD.5\r
+ MOVE 0,1(B)\r
+ CAME 0,MQUOTE QUOTE\r
+ JRST MPD.5 ; BETTER BE QUOTE\r
+ HRRZ E,(B) ; CDR\r
+ GETYP 0,(E) ; TYPE\r
+ CAIE 0,TATOM\r
+ JRST MPD.5\r
+ MOVE E,1(E) ; GET QUOTED ATOM\r
+ POPJ P,\r
+\f\r
+; ARG BINDER FOR REGULAR ARGS AND OPTIONALS\r
+\r
+BNDEM1: PUSH P,[0] ; REGULAR FLAG\r
+ JRST .+2\r
+BNDEM2: PUSH P,[1]\r
+BNDEM: PUSHJ P,NEXTD ; GET NEXT THING\r
+ JRST CCPOPJ ; END OF THINGS\r
+ TRNE A,4 ; CHECK FOR DCL\r
+ JRST BNDEM4\r
+ TRNE A,2 ; SKIP IF NOT (ATM ..) OR ('ATM ...)\r
+ SKIPE (P) ; SKIP IF REG ARGS\r
+ JRST .+2 ; WINNER, GO ON\r
+ JRST MPD.6 ; LOSER\r
+ SKIPGE SPCCHK\r
+ PUSH TP,BNDA1 ; SAVE ATOM\r
+ SKIPL SPCCHK\r
+ PUSH TP,BNDA\r
+ PUSH TP,E\r
+ SKIPL E.ARG+1(TB) ; SKIP IF MUST EVAL ARG\r
+ TRNN A,1 ; SKIP IF ARG QUOTED\r
+ JRST RGLARG\r
+ HRRZ D,@E.FRM+1(TB) ; GET AND CDR ARG\r
+ JUMPE D,TFACHK ; OH OH MAYBE TOO FEW ARGS\r
+ MOVEM D,E.FRM+1(TB) ; STORE WINNER\r
+ HLLZ A,(D) ; GET ARG\r
+ MOVE B,1(D)\r
+ JSP E,CHKAB ; HACK DEFER\r
+ JRST BNDEM3 ; AND GO ON\r
+\r
+RGLARG: PUSH P,A ; SAVE FLAGS\r
+ PUSHJ P,@E.ARG+1(TB)\r
+ JRST TFACH1 ; MAY GE TOO FEW\r
+ SUB P,[1,,1]\r
+BNDEM3: HRRZ C,@E.ARGL+1(TB) ; CDR THHE ARGS\r
+ MOVEM C,E.ARGL+1(TB)\r
+ PUSHJ P,PSHAB4 ; PUSH VALUE AND SLOTS\r
+ PUSHJ P,CHDCL ; CHECK DCLS\r
+ JRST BNDEM ; AND BIND ON!\r
+\r
+; HERE WHEN ARGS RUN OUT, IF NOT OPTIONAL, GIVE TFA\r
+\r
+TFACH1: POP P,A\r
+TFACHK: SUB TP,[2,,2] ; FLUSH ATOM\r
+ SKIPN (P) ; SKIP IF OPTIONALS\r
+ JRST TFA\r
+CCPOPJ: SUB P,[1,,1]\r
+ POPJ P,\r
+\r
+BNDEM4: HRRZ C,@E.ARGL+1(TB) ; POINT TO REST OF ARGL\r
+ JRST CCPOPJ\r
+\f\r
+\r
+; EVALUATE LISTS, VECTORS, UNIFROM VECTORS\r
+\r
+EVLIST: PUSH P,[-1] ;-1 -- THIS IS A LIST\r
+ JRST EVL1 ;GO TO HACKER\r
+\r
+EVECT: PUSH P,[0] ;0 -- THIS IS A GENERAL VECTOR\r
+ JRST EVL1\r
+\r
+EUVEC: PUSH P,[1] ;1 -- THIS IS A UNIFORM VECTOR\r
+\r
+EVL1: PUSH P,[0] ;PUSH A COUNTER\r
+ GETYPF A,(AB) ;GET FULL TYPE\r
+ PUSH TP,A\r
+ PUSH TP,1(AB) ;AND VALUE\r
+\r
+EVL2: INTGO ;CHECK INTERRUPTS\r
+ SKIPN A,1(TB) ;ANYMORE\r
+ JRST EVL3 ;NO, QUIT\r
+ SKIPL -1(P) ;SKIP IF LIST\r
+ JUMPG A,EVL3 ;JUMP IF VECTOR EMPTY\r
+ GETYPF B,(A) ;GET FULL TYPE\r
+ SKIPGE C,-1(P) ;SKIP IF NOT LIST\r
+ HLLZS B ;CLOBBER CDR FIELD\r
+ JUMPG C,EVL7 ;HACK UNIFORM VECS\r
+EVL8: PUSH P,B ;SAVE TYPE WORD ON P\r
+ CAMN B,$TSEG ;SEGMENT?\r
+ MOVSI B,TFORM ;FAKE OUT EVAL\r
+ PUSH TP,B ;PUSH TYPE\r
+ PUSH TP,1(A) ;AND VALUE\r
+ JSP E,CHKARG ; CHECK DEFER\r
+ MCALL 1,EVAL ;AND EVAL IT\r
+ POP P,C ;AND RESTORE REAL TYPE\r
+ CAMN C,$TSEG ;SEGMENT?\r
+ JRST DOSEG ;YES, HACK IT\r
+ AOS (P) ;COUNT ELEMENT\r
+ PUSH TP,A ;AND PUSH IT\r
+ PUSH TP,B\r
+EVL6: SKIPGE A,-1(P) ;DONT SKIP IF LIST\r
+ HRRZ B,@1(TB) ;CDR IT\r
+ JUMPL A,ASTOTB ;AND STORE IT\r
+ MOVE B,1(TB) ;GET VECTOR POINTER\r
+ ADD B,AMNT(A) ;INCR BY APPROPRIATE AMOUNT\r
+ASTOTB: MOVEM B,1(TB) ;AND STORE BACK\r
+ JRST EVL2 ;AND LOOP BACK\r
+\r
+AMNT: 2,,2 ;INCR FOR GENERAL VECTOR\r
+ 1,,1 ;SAME FOR UNIFORM VECTOR\r
+\r
+CHKARG: GETYP A,-1(TP)\r
+ CAIE A,TDEFER\r
+ JRST (E)\r
+ HRRZS (TP) ;MAKE SURE INDIRECT WINS\r
+ MOVE A,@(TP)\r
+ MOVEM A,-1(TP) ;CLOBBER IN TYPE SLOT\r
+ MOVE A,(TP) ;NOW GET POINTER\r
+ MOVE A,1(A) ;GET VALUE\r
+ MOVEM A,(TP) ;CLOBBER IN\r
+ JRST (E)\r
+\r
+\f\r
+\r
+EVL7: HLRE C,A ; FIND TYPE OF UVECTOR\r
+ SUBM A,C ;C POINTS TO DOPE WORD\r
+ GETYP B,(C) ;GET TYPE\r
+ MOVSI B,(B) ;TO LH NOW\r
+ SOJA A,EVL8 ;AND RETURN TO DO EVAL\r
+\r
+EVL3: SKIPL -1(P) ;SKIP IF LIST\r
+ JRST EVL4 ;EITHER VECTOR OR UVECTOR\r
+\r
+ MOVEI B,0 ;GET A NIL\r
+EVL9: MOVSI A,TLIST ;MAKE TYPE WIN\r
+EVL5: SOSGE (P) ;COUNT DOWN\r
+ JRST EVL10 ;DONE, RETURN\r
+ PUSH TP,$TLIST ;SET TO CALL CONS\r
+ PUSH TP,B\r
+ MCALL 2,CONS\r
+ JRST EVL5 ;LOOP TIL DONE\r
+\r
+\r
+EVL4: MOVEI B,EUVECT ;UNIFORM CASE\r
+ SKIPG -1(P) ;SKIP IF UNIFORM CASE\r
+ MOVEI B,EVECTO ;NO, GENERAL CASE\r
+ POP P,A ;GET COUNT\r
+ .ACALL A,(B) ;CALL CREATOR\r
+EVL10: GETYPF A,(AB) ; USE SENT TYPE\r
+ JRST EFINIS\r
+\r
+\f\r
+; PROCESS SEGMENTS FOR THESE HACKS\r
+\r
+DOSEG: PUSHJ P,TYPSEG ; FIND WHAT IS BEING SEGMENTED\r
+ JUMPE C,LSTSEG ; CHECK END SPLICE IF LIST\r
+\r
+SEG3: PUSHJ P,NXTELM ; GET THE NEXTE ELEMT\r
+ JRST SEG4 ; RETURN TO CALLER\r
+ AOS (P) ; COUNT\r
+ JRST SEG3 ; TRY AGAIN\r
+SEG4: SETZM DSTO(PVP)\r
+ JRST EVL6\r
+\r
+TYPSEG: PUSHJ P,TYPSGR\r
+ JRST ILLSEG\r
+ POPJ P,\r
+\r
+TYPSGR: MOVEM A,DSTO(PVP) ;WILL BECOME INTERRUPTABLE WITH GOODIE IN D\r
+ GETYP A,A ; TYPE TO RH\r
+ PUSHJ P,SAT ;GET STORAGE TYPE\r
+ MOVE D,B ; GOODIE TO D\r
+\r
+ MOVNI C,1 ; C <0 IF ILLEGAL\r
+ CAIN A,S2WORD ;LIST?\r
+ MOVEI C,0\r
+ CAIN A,S2NWORD ;GENERAL VECTOR?\r
+ MOVEI C,1\r
+ CAIN A,SNWORD ;UNIFORM VECTOR?\r
+ MOVEI C,2\r
+ CAIN A,SCHSTR\r
+ MOVEI C,3\r
+ CAIN A,SSTORE ;SPECIAL AFREE STORAGE ?\r
+ MOVEI C,2 ;TREAT LIKE A UVECTOR\r
+ CAIN A,SARGS ;ARGS TUPLE?\r
+ JRST SEGARG ;NO, ERROR\r
+ CAILE A,NUMSAT ; SKIP IF NOT TEMPLATE\r
+ JRST SEGTMP\r
+ JUMPGE C,CPOPJ1\r
+ SETZM DSTO(PVP) ; DON'T CONFUSE AGC LATER!\r
+ POPJ P,\r
+\r
+SEGTMP: MOVEI C,4\r
+ HRRM A,DSTO(PVP) ; SAVE FOR HACKERS\r
+ JRST CPOPJ1\r
+\r
+SEGARG: PUSH TP,DSTO(PVP) ;PREPARE TO CHECK ARGS\r
+ PUSH TP,D\r
+ SETZM DSTO(PVP) ;TYPE NOT SPECIAL\r
+ MOVEI B,-1(TP) ;POINT TO SAVED COPY\r
+ PUSHJ P,CHARGS ;CHECK ARG POINTER\r
+ POP TP,D ;AND RESTORE WINNER\r
+ POP TP,DSTO(PVP) ;AND TYPE AND FALL INTO VECTOR CODE\r
+ MOVEI C,1\r
+ JRST CPOPJ1\r
+\r
+LSTSEG: SKIPL -1(P) ;SKIP IF IN A LIST\r
+ JRST SEG3 ;ELSE JOIN COMMON CODE\r
+ HRRZ A,@1(TB) ;CHECK FOR END OF LIST\r
+ JUMPN A,SEG3 ;NO, JOIN COMMON CODE\r
+ SETZM DSTO(PVP) ;CLOBBER SAVED GOODIES\r
+ JRST EVL9 ;AND FINISH UP\r
+\r
+NXTELM: INTGO\r
+ PUSHJ P,NXTLM ; GOODIE TO A AND B\r
+ POPJ P, ; DONE\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ JRST CPOPJ1\r
+NXTLM: XCT TESTR(C) ; SKIP IF MORE IN SEGEMNT\r
+ POPJ P,\r
+ XCT TYPG(C) ; GET THE TYPE\r
+ XCT VALG(C) ; AND VALUE\r
+ JSP E,CHKAB ; CHECK DEFERRED\r
+ XCT INCR1(C) ; AND INCREMENT TO NEXT\r
+CPOPJ1: AOS (P) ; SKIP RETURN\r
+ POPJ P,\r
+\r
+; TABLES FOR SEGMENT OPERATIONS (0->LIST, 1->VECTOR/ARGS, 2->UVEC, 3->STRING)\r
+\r
+TESTR: SKIPN D\r
+ SKIPL D\r
+ SKIPL D\r
+ PUSHJ P,CHRDON\r
+ PUSHJ P,TM1\r
+\r
+TYPG: PUSHJ P,LISTYP\r
+ GETYPF A,(D)\r
+ PUSHJ P,UTYPE\r
+ MOVSI A,TCHRS\r
+ PUSHJ P,TM2\r
+\r
+VALG: MOVE B,1(D)\r
+ MOVE B,1(D)\r
+ MOVE B,(D)\r
+ PUSHJ P,1CHGT\r
+ PUSHJ P,TM3\r
+\r
+INCR1: HRRZ D,(D)\r
+ ADD D,[2,,2]\r
+ ADD D,[1,,1]\r
+ PUSHJ P,1CHINC\r
+ ADD D,[1,,]\r
+\r
+TM1: HRRZ A,DSTO(PVP) ; GET SAT\r
+ SUBI A,NUMSAT+1\r
+ ADD A,TD.LNT+1(TVP)\r
+ EXCH C,D\r
+ XCT (A)\r
+ HLRZ 0,C ; GET AMNT RESTED\r
+ SUB B,0\r
+ EXCH C,D\r
+ TRNE B,-1\r
+ AOS (P)\r
+ POPJ P,\r
+\r
+TM3:\r
+TM2: HRRZ 0,DSTO(PVP)\r
+ PUSH P,C\r
+ PUSH P,D\r
+ PUSH P,E\r
+ MOVE B,D\r
+ MOVEI C,0 ; GET "1ST ELEMENT"\r
+ PUSHJ P,TMPLNT ; GET NTH IN A AND B\r
+ POP P,E\r
+ POP P,D\r
+ POP P,C\r
+ POPJ P,\r
+\r
+\r
+CHRDON: HRRZ B,DSTO(PVP) ; POIT TO DOPE WORD\r
+ JUMPE B,CHRFIN\r
+ AOS (P)\r
+CHRFIN: POPJ P,\r
+\r
+LISTYP: GETYP A,(D)\r
+ MOVSI A,(A)\r
+ POPJ P,\r
+1CHGT: MOVE B,D\r
+ ILDB B,B\r
+ POPJ P,\r
+\r
+1CHINC: SOS DSTO(PVP)\r
+ IBP D\r
+ POPJ P,\r
+\r
+UTYPE: HLRE A,D\r
+ SUBM D,A\r
+ GETYP A,(A)\r
+ MOVSI A,(A)\r
+ POPJ P,\r
+\r
+\r
+;COMPILER's CALL TO DOSEG\r
+SEGMNT: PUSHJ P,TYPSEG\r
+SEGLP1: SETZB A,B\r
+SEGLOP: PUSHJ P,NXTELM\r
+ JRST SEGRET\r
+ AOS (P)-2 ; INCREMENT COMPILER'S COUNT\r
+ JRST SEGLOP\r
+\r
+SEGRET: SETZM DSTO(PVP)\r
+ POPJ P,\r
+\r
+SEGLST: PUSHJ P,TYPSEG\r
+ JUMPN C,SEGLS2\r
+SEGLS3: SETZM DSTO(PVP)\r
+ MOVSI A,TLIST\r
+SEGLS1: SOSGE -2(P) ; START COUNT DOWN\r
+ POPJ P,\r
+ MOVEI E,(B)\r
+ POP TP,D\r
+ POP TP,C\r
+ PUSHJ P,ICONS\r
+ JRST SEGLS1\r
+\r
+SEGLS2: PUSHJ P,NXTELM\r
+ JRST SEGLS4\r
+ AOS -2(P)\r
+ JRST SEGLS2\r
+\r
+SEGLS4: MOVEI B,0\r
+ JRST SEGLS3\r
+\f\r
+\r
+;SPECBIND BINDS IDENTIFIERS. IT IS CALLED BY PUSHJ P,SPECBIND.\r
+;SPECBIND IS PROVIDED WITH A CONTIGUOUS SET OF TRIPLETS ON TP. \r
+;EACH TRIPLET IS AS FOLLOWS:\r
+;THE FIRST ELEMENT IS THE IDENTIFIER TO BE BOUND, ITS TYPE WORD IS [TATOM,,-1],\r
+;THE SECOND IS THE VALUE TO WHICH IT IS TO BE ASSIGNED,\r
+;AND THE THIRD IS A PAIR OF ZEROES.\r
+\r
+BNDA1: TATOM,,-2\r
+BNDA: TATOM,,-1\r
+BNDV: TVEC,,-1\r
+\r
+USPECBIND:\r
+ MOVE E,TP\r
+USPCBE: PUSH P,$TUBIND\r
+ JRST .+3\r
+\r
+SPECBIND:\r
+ MOVE E,TP ;GET THE POINTER TO TOP\r
+SPECBE: PUSH P,$TBIND\r
+ ADD E,[1,,1] ;BUMP POINTER ONCE\r
+ SETZB 0,D ;CLEAR TEMPS\r
+ PUSH P,0\r
+ MOVEI 0,(TB) ; FOR CHECKS\r
+\r
+BINDLP: MOVE A,-4(E) ; CHECK FOR VEC BIND\r
+ CAMN A,BNDV\r
+ JRST NONID\r
+ MOVE A,-6(E) ;GET TYPE\r
+ CAME A,BNDA1 ; FOR UNSPECIAL\r
+ CAMN A,BNDA ;NORMAL ID BIND?\r
+ CAILE 0,-6(E) ; MAKE SURE NOT GOING UNDER FRAME\r
+ JRST SPECBD\r
+ SUB E,[6,,6] ;MOVE PTR\r
+ SKIPE D ;LINK?\r
+ HRRM E,(D) ;YES -- LOBBER\r
+ SKIPN (P) ;UPDATED?\r
+ MOVEM E,(P) ;NO -- DO IT\r
+\r
+ MOVE A,0(E) ;GET ATOM PTR\r
+ MOVE B,1(E) \r
+ PUSHJ P,ILOC ;GET LAST BINDING\r
+ MOVS A,OTBSAV (TB) ;GET TIME\r
+ HRL A,5(E) ; GET DECL POINTER\r
+ MOVEM A,4(E) ;CLOBBER IT AWAY\r
+ MOVE A,(E) ; SEE IF SPEC/UNSPEC\r
+ TRNN A,1 ; SKIP, ALWAYS SPEC\r
+ SKIPA A,-1(P) ; USE SUPPLIED\r
+ MOVSI A,TBIND\r
+ MOVEM A,(E) ;IDENTIFY AS BIND BLOCK\r
+ HRRZ C,SPBASE(PVP) ; CHECK FOR CROSS OF PROC\r
+ MOVEI A,(TP)\r
+ CAIL A,(B) ; LOSER\r
+ CAILE C,(B) ; SKIP IFF WINNER\r
+ JRST .+2\r
+ MOVEM B,5(E) ;IN RESTORE CELLS\r
+\r
+ MOVE C,1(E) ;GET ATOM PTR\r
+ MOVEI A,(C)\r
+ MOVEI B,0 ; FOR SPCUNP\r
+ CAIL A,HIBOT ; SKIP IF IMPURE ATOM\r
+ PUSHJ P,SPCUNP\r
+ HRRZ A,BINDID+1(PVP) ;GET PROCESS NUMBER\r
+ HRLI A,TLOCI ;MAKE LOC PTR\r
+ MOVE B,E ;TO NEW VALUE\r
+ ADD B,[2,,2]\r
+ MOVEM A,(C) ;CLOBBER ITS VALUE\r
+ MOVEM B,1(C) ;CELL\r
+ MOVE D,E ;REMEMBER LINK\r
+ JRST BINDLP ;DO NEXT\r
+\r
+NONID: CAILE 0,-4(E)\r
+ JRST SPECBD\r
+ SUB E,[4,,4]\r
+ SKIPE D\r
+ HRRM E,(D)\r
+ SKIPN (P)\r
+ MOVEM E,(P)\r
+\r
+ MOVE D,1(E) ;GET PTR TO VECTOR\r
+ MOVE C,(D) ;EXCHANGE TYPES\r
+ EXCH C,2(E)\r
+ MOVEM C,(D)\r
+\r
+ MOVE C,1(D) ;EXCHANGE DATUMS\r
+ EXCH C,3(E)\r
+ MOVEM C,1(D)\r
+\r
+ MOVEI A,TBVL \r
+ HRLM A,(E) ;IDENTIFY BIND BLOCK\r
+ MOVE D,E ;REMEMBER LINK\r
+ JRST BINDLP\r
+\r
+SPECBD: SKIPE D\r
+ HRRM SP,(D)\r
+ SKIPE D,(P)\r
+ MOVE SP,D\r
+ SUB P,[2,,2]\r
+ POPJ P,\r
+\r
+\r
+; HERE TO IMPURIFY THE ATOM\r
+\r
+SPCUNP: PUSH TP,$TSP\r
+ PUSH TP,E\r
+ PUSH TP,$TSP\r
+ PUSH TP,-1(P) ; LINK BACK IS AN SP\r
+ PUSH TP,$TSP\r
+ PUSH TP,B\r
+ MOVE B,C\r
+ PUSHJ P,IMPURIFY\r
+ MOVE 0,-2(TP) ; RESTORE LINK BACK POINTER\r
+ MOVEM 0,-1(P)\r
+ MOVE E,-4(TP)\r
+ MOVE C,B\r
+ MOVE B,(TP)\r
+ SUB TP,[6,,6]\r
+ MOVEI 0,(TB)\r
+ POPJ P,\r
+\r
+; ENTRY FROM COMPILER TO SET UP A BINDING\r
+\r
+IBIND: SUBI E,-5(SP) ; CHANGE TO PDL POINTER\r
+ HRLI E,(E)\r
+ ADD E,SP\r
+ MOVEM C,-4(E)\r
+ MOVEM A,-3(E)\r
+ MOVEM B,-2(E)\r
+ HRLOI A,TATOM\r
+ MOVEM A,-5(E)\r
+ MOVSI A,TLIST\r
+ MOVEM A,-1(E)\r
+ MOVEM D,(E)\r
+ JRST SPECB1 ; NOW BIND IT\r
+\r
+; "FAST CALL TO SPECBIND"\r
+\r
+\r
+\r
+; Compiler's call to SPECBIND all atom bindings, no TBVLs etc.\r
+\r
+SPECBND:\r
+ MOVE E,TP ; POINT TO BINDING WITH E\r
+SPECB1: PUSH P,[0] ; SLOTS OF INTEREST\r
+ PUSH P,[0]\r
+ SUBM M,-2(P)\r
+\r
+SPECB2: MOVEI 0,(TB) ; FOR FRAME CHECK\r
+ MOVE A,-5(E) ; LOOK AT FIRST THING\r
+ CAMN A,BNDA ; SKIP IF LOSER\r
+ CAILE 0,-5(E) ; SKIP IF REAL WINNER\r
+ JRST SPECB3\r
+\r
+ SUB E,[5,,5] ; POINT TO BINDING\r
+ SKIPE A,(P) ; LINK?\r
+ HRRM E,(A) ; YES DO IT\r
+ SKIPN -1(P) ; FIRST ONE?\r
+ MOVEM E,-1(P) ; THIS IS IT\r
+\r
+ MOVE A,1(E) ; POINT TO ATOM\r
+ MOVE 0,BINDID+1(PVP) ; QUICK CHECK\r
+ HRLI 0,TLOCI\r
+ CAMN 0,(A) ; WINNERE?\r
+ JRST SPECB4 ; YES, GO ON\r
+\r
+ PUSH P,B ; SAVE REST OF ACS\r
+ PUSH P,C\r
+ PUSH P,D\r
+ MOVE B,A ; FOR ILOC TO WORK\r
+ PUSHJ P,ILOC ; GO LOOK IT UP\r
+ HRRZ C,SPBASE+1(PVP)\r
+ MOVEI A,(TP)\r
+ CAIL A,(B) ; SKIP IF LOSER\r
+ CAILE C,(B) ; SKIP IF WINNER\r
+ MOVEI B,0 ; SAY NO BACK POINTER\r
+ MOVE C,1(E) ; POINT TO ATOM\r
+ MOVEI A,(C) ; PURE ATOM?\r
+ CAIGE A,HIBOT ; SKIP IF OK\r
+ JRST .+4\r
+ PUSH P,-4(P) ; MAKE HAPPINESS\r
+ PUSHJ P,SPCUNP ; IMPURIFY\r
+ POP P,-5(P)\r
+ MOVE A,BINDID+1(PVP)\r
+ HRLI A,TLOCI\r
+ MOVEM A,(C) ; STOR POINTER INDICATOR\r
+ MOVE A,B\r
+ POP P,D\r
+ POP P,C\r
+ POP P,B\r
+ JRST SPECB5\r
+\r
+SPECB4: MOVE A,1(A) ; GET LOCATIVE\r
+SPECB5: EXCH A,5(E) ; CLOBBER INTO REBIND SLOT (GET DECL)\r
+ HLL A,OTBSAV(TB) ; TIME IT\r
+ MOVSM A,4(E) ; SAVE DECL AND TIME\r
+ MOVEI A,TBIND\r
+ HRLM A,(E) ; CHANGE TO A BINDING\r
+ MOVE A,1(E) ; POINT TO ATOM\r
+ MOVEM E,(P) ; REMEMBER THIS GUY\r
+ ADD E,[2,,2] ; POINT TO VAL CELL\r
+ MOVEM E,1(A) ; INTO ATOM SLOT\r
+ SUB E,[3,,3] ; POINT TO NEXT ONE\r
+ JRST SPECB2\r
+\r
+SPECB3: SKIPE A,(P)\r
+ HRRM SP,(A) ; LINK OLD STUFF\r
+ SKIPE A,-1(P) ; NEW SP?\r
+ MOVE SP,A\r
+ SUB P,[2,,2]\r
+ INTGO ; IN CASE BLEW STACK\r
+ SUBM M,(P)\r
+ POPJ P,\r
+\f\r
+\r
+;SPECSTORE RESTORES THE BINDINGS SP TO THE ENVIRONMENT POINTER IN \r
+;SPSAV (TB). IT IS CALLED BY PUSHJ P,SPECSTORE.\r
+\r
+SPECSTORE:\r
+ PUSH P,E\r
+ HRRZ E,SPSAV (TB) ;GET TARGET POINTER\r
+ PUSHJ P,STLOOP\r
+ POP P,E\r
+ MOVE SP,SPSAV(TB) ; GET NEW SP\r
+ POPJ P,\r
+\r
+STLOOP: PUSH P,D\r
+ PUSH P,C\r
+\r
+STLOO1: CAIL E,(SP) ;ARE WE DONE?\r
+ JRST STLOO2\r
+ HLRZ C,(SP) ;GET TYPE OF BIND\r
+ CAIN C,TUBIND\r
+ JRST .+3\r
+ CAIE C,TBIND ;NORMAL IDENTIFIER?\r
+ JRST ISTORE ;NO -- SPECIAL HACK\r
+\r
+\r
+ MOVE C,1(SP) ;GET TOP ATOM\r
+ MOVSI 0,TLOCI ; MAYBE LOCI OR UNBOUND\r
+ SKIPN D,5(SP)\r
+ MOVSI 0,TUNBOU\r
+\r
+ HRR 0,BINDID+1(PVP) ;STORE SIGNATURE\r
+ MOVEM 0,(C) ;CLOBBER INTO ATOM\r
+ MOVEM D,1(C)\r
+ SETZM 4(SP)\r
+SPLP: HRRZ SP,(SP) ;FOLOW LINK\r
+ JUMPN SP,STLOO1 ;IF MORE\r
+ SKIPE E ; OK IF E=0\r
+ FATAL SP OVERPOP\r
+STLOO2: POP P,C\r
+ POP P,D\r
+ POPJ P,\r
+\r
+ISTORE: CAIE C,TBVL\r
+ JRST CHSKIP\r
+ MOVE C,1(SP)\r
+ MOVE D,2(SP)\r
+ MOVEM D,(C)\r
+ MOVE D,3(SP)\r
+ MOVEM D,1(C)\r
+ JRST SPLP\r
+\r
+CHSKIP: CAIN C,TSKIP\r
+ JRST SPLP\r
+ CAIE C,TUNWIN ; UNWIND HACK\r
+ FATAL BAD SP\r
+ HRRZ C,-2(P) ; WHERE FROM?\r
+ CAIE C,CHUNPC\r
+ JRST SPLP ; IGNORE\r
+ MOVEI E,(TP) ; FIXUP SP\r
+ SUBI E,(SP)\r
+ MOVSI E,(E)\r
+ HLL SP,TP\r
+ SUB SP,E\r
+ POP P,C\r
+ POP P,D\r
+ AOS (P)\r
+ POPJ P,\r
+\r
+; ENTRY FOR FUNNY COMPILER UNBIND (1)\r
+\r
+SSPECS: PUSH P,E\r
+ MOVEI E,(TP)\r
+ PUSHJ P,STLOOP\r
+SSPEC2: SUBI E,(SP) ; MAKE SP BE AOBJN\r
+ MOVSI E,(E)\r
+ HLL SP,TP\r
+ SUB SP,E\r
+ POP P,E\r
+ POPJ P,\r
+\r
+; ENTRY FOR FUNNY COMPILER UNBIND (2)\r
+\r
+SSPEC1: PUSH P,E\r
+ SUBI E,1 ; MAKE SURE GET CURRENT BINDING\r
+ PUSHJ P,STLOOP ; UNBIND\r
+ MOVEI E,(TP) ; NOW RESET SP\r
+ JRST SSPEC2\r
+\fEFINIS: SKIPN C,1STEPR+1(PVP) ; SKIP NIF BEING ONE PROCEEDED\r
+ JRST FINIS\r
+ PUSH TP,$TATOM\r
+ PUSH TP,MQUOTE EVLOUT\r
+ PUSH TP,A ;SAVE EVAL RESULTS\r
+ PUSH TP,B\r
+ PUSH TP,[TINFO,,2] ; FENCE POST\r
+ PUSHJ P,TBTOTP\r
+ PUSH TP,D\r
+ PUSHJ P,MAKINF ; MAKE ARG BLOCK INFO\r
+ PUSH TP,A\r
+ MOVEI B,-6(TP)\r
+ HRLI B,-4 ; AOBJN TO ARGS BLOCK\r
+ PUSH TP,B\r
+ PUSH TP,1STEPR(PVP)\r
+ PUSH TP,1STEPR+1(PVP) ; PROCESS DOING THE 1STEPPING\r
+ MCALL 2,RESUME\r
+ MOVE A,-3(TP) ; GET BACK EVAL VALUE\r
+ MOVE B,-2(TP)\r
+ JRST FINIS\r
+\r
+1STEPI: PUSH TP,$TATOM\r
+ PUSH TP,MQUOTE EVLIN\r
+ PUSH TP,$TAB ; PUSH EVALS ARGGS\r
+ PUSH TP,AB\r
+ PUSHJ P,MAKINF ; TURN INTO ARGS BLOCK\r
+ MOVEM A,-1(TP) ; AND CLOBBER\r
+ PUSH TP,[TINFO,,2] ; FENCE POST 2D TUPLE\r
+ PUSHJ P,TBTOTP\r
+ PUSH TP,D\r
+ PUSHJ P,MAKINF ; TURN IT INTO ARGS BLOCK\r
+ PUSH TP,A\r
+ MOVEI B,-6(TP) ; SETUP TUPLE\r
+ HRLI B,-4\r
+ PUSH TP,B\r
+ PUSH TP,1STEPR(PVP)\r
+ PUSH TP,1STEPR+1(PVP)\r
+ MCALL 2,RESUME ; START UP 1STEPERR\r
+ SUB TP,[6,,6] ; REMOVE CRUD\r
+ GETYP A,A ; GET 1STEPPERS TYPE\r
+ CAIE A,TDISMI ; IF DISMISS, STOP 1 STEPPING\r
+ JRST EVALON\r
+\r
+; HERE TO PUSH DOWN THE 1 STEP STATE AND RUN\r
+\r
+ MOVE D,PVP\r
+ ADD D,[1STEPR,,1STEPR] ; POINT TO 1 STEP SLOT\r
+ PUSH TP,$TSP ; SAVE CURRENT SP\r
+ PUSH TP,SP\r
+ PUSH TP,BNDV\r
+ PUSH TP,D ; BIND IT\r
+ PUSH TP,$TPVP\r
+ PUSH TP,[0] ; NO 1 STEPPER UNTIL POPJ\r
+ PUSHJ P,SPECBIND\r
+\r
+; NOW PUSH THE ARGS UP TO RE-CALL EVAL\r
+\r
+ MOVEI A,0\r
+EFARGL: JUMPGE AB,EFCALL\r
+ PUSH TP,(AB)\r
+ PUSH TP,1(AB)\r
+ ADD AB,[2,,2]\r
+ AOJA A,EFARGL\r
+\r
+EFCALL: ACALL A,EVAL ; NOW DO THE EVAL\r
+ MOVE C,(TP) ; PRE-UNBIND\r
+ MOVEM C,1STEPR+1(PVP)\r
+ MOVE SP,-4(TP) ; AVOID THE UNBIND\r
+ SUB TP,[6,,6] ; AND FLUSH LOSERS\r
+ JRST EFINIS ; AND TRY TO FINISH UP\r
+\r
+MAKINF: HLRZ A,OTBSAV(TB) ; TIME IT\r
+ HRLI A,TARGS\r
+ POPJ P,\r
+\r
+\r
+TBTOTP: MOVEI D,(TB) ; COMPUTE REL DIST FROM TP TO TB\r
+ SUBI D,(TP)\r
+ POPJ P,\r
+; ARRIVE HERE TO COMPLETE A COMPILER GENERATED TUPLE\r
+; D/ LENGTH OF THE TUPLE IN WORDS\r
+\r
+MAKTU2: MOVE D,-1(P) ; GET LENGTH\r
+MAKTUP: HRLI D,TINFO ; FIRST WORD OF FENCE POST\r
+ PUSH TP,D\r
+ HRROI B,(TP) ; TOP OF TUPLE\r
+ SUBI B,(D)\r
+ TLC B,-1(D) ; AOBJN IT\r
+ PUSHJ P,TBTOTP\r
+ PUSH TP,D\r
+ HLRZ A,OTBSAV(TB) ; TIME IT\r
+ HRLI A,TARGS\r
+ POPJ P,\r
+\r
+; HERE TO ALLOCATE SLOTS FOR COMPILER (AMNT IN A)\r
+\r
+TPALOC: HRLI A,(A)\r
+ ADD TP,A\r
+ SKIPL TP\r
+ PUSHJ P,TPOVFL ; IN CASE IT LOST\r
+ INTGO ; TAKE THE GC IF NEC\r
+ PUSH P,A\r
+ HRRI A,2(TP)\r
+ SUB A,(P)\r
+ SETZM -1(A) \r
+ HRLI A,-1(A)\r
+ BLT A,(TP)\r
+ SUB P,[1,,1]\r
+ POPJ P,\r
+\r
+NTPALO: PUSH TP,[0]\r
+ SOJG 0,.-1\r
+ POPJ P,\r
+\r
+\f;EVALUATES A IDENTIFIER -- GETS LOCAL VALUE IF THERE IS ONE, OTHERWISE GLOBAL.\r
+\r
+MFUNCTION VALUE,SUBR\r
+ JSP E,CHKAT\r
+ PUSHJ P,IDVAL\r
+ JRST FINIS\r
+\r
+IDVAL: PUSHJ P,IDVAL1\r
+ CAMN A,$TUNBOU\r
+ JRST UNBOU\r
+ POPJ P,\r
+\r
+IDVAL1: PUSH TP,A\r
+ PUSH TP,B ;SAVE ARG IN CASE NEED TO CHECK GLOBAL VALUE\r
+ PUSHJ P,ILVAL ;LOCAL VALUE FINDER\r
+ CAME A,$TUNBOUND ;IF NOT UNBOUND OR UNASSIGNED\r
+ JRST RIDVAL ;DONE - CLEAN UP AND RETURN\r
+ POP TP,B ;GET ARG BACK\r
+ POP TP,A\r
+ JRST IGVAL\r
+RIDVAL: SUB TP,[2,,2]\r
+ POPJ P,\r
+\r
+;GETS THE LOCAL VALUE OF AN IDENTIFIER\r
+\r
+MFUNCTION LVAL,SUBR\r
+ JSP E,CHKAT\r
+ PUSHJ P,AILVAL\r
+ CAME A,$TUNBOUND\r
+ JRST FINIS\r
+ JUMPN B,UNAS\r
+ JRST UNBOU\r
+\r
+; MAKE AN ATOM UNASSIGNED\r
+\r
+MFUNCTION UNASSIGN,SUBR\r
+ JSP E,CHKAT ; GET ATOM ARG\r
+ PUSHJ P,AILOC\r
+UNASIT: CAMN A,$TUNBOU ; IF UNBOUND\r
+ JRST RETATM\r
+ MOVSI A,TUNBOU\r
+ MOVEM A,(B)\r
+ SETOM 1(B) ; MAKE SURE\r
+RETATM: MOVE B,1(AB)\r
+ MOVE A,(AB)\r
+ JRST FINIS\r
+\r
+; UNASSIGN GLOBALLY\r
+\r
+MFUNCTION GUNASSIGN,SUBR\r
+ JSP E,CHKAT2\r
+ PUSHJ P,IGLOC\r
+ CAMN A,$TUNBOU\r
+ JRST RETATM\r
+ MOVE B,1(AB) ; ATOM BACK\r
+ MOVEI 0,(B)\r
+ CAIL 0,HIBOT ; SKIP IF IMPURE\r
+ PUSHJ P,IMPURIFY ; YES, MAKE IT IMPURE\r
+ PUSHJ P,IGLOC ; RESTORE LOCATIVE\r
+ HRRZ 0,-2(B) ; SEE IF MANIFEST\r
+ GETYP A,(B) ; AND CURRENT TYPE\r
+ CAIN 0,-1\r
+ CAIN A,TUNBOU\r
+ JRST UNASIT\r
+ SKIPE IGDECL\r
+ JRST UNASIT\r
+ MOVE D,B\r
+ JRST MANILO\r
+\f\r
+; GETS A LOCATIVE TO THE LOCAL VALUE OF AN IDENTIFIER.\r
+\r
+MFUNCTION LLOC,SUBR\r
+ JSP E,CHKAT\r
+ PUSHJ P,AILOC\r
+ CAMN A,$TUNBOUND\r
+ JRST UNBOU\r
+ MOVSI A,TLOCD\r
+ HRR A,2(B)\r
+ JRST FINIS\r
+\r
+;TESTS TO SEE IF AN IDENTIFIER IS LOCALLY BOUND\r
+\r
+MFUNCTION BOUND,SUBR,[BOUND?]\r
+ JSP E,CHKAT\r
+ PUSHJ P,AILVAL\r
+ CAMN A,$TUNBOUND\r
+ JUMPE B,IFALSE\r
+ JRST TRUTH\r
+\r
+;TESTS TO SEE IF AN IDENTIFIER IS LOCALLY ASSIGNED\r
+\r
+MFUNCTION ASSIGP,SUBR,[ASSIGNED?]\r
+ JSP E,CHKAT\r
+ PUSHJ P,AILVAL\r
+ CAME A,$TUNBOUND\r
+ JRST TRUTH\r
+; JUMPE B,UNBOU\r
+ JRST IFALSE\r
+\r
+;GETS THE GLOBAL VALUE OF AN IDENTIFIER\r
+\r
+MFUNCTION GVAL,SUBR\r
+ JSP E,CHKAT2\r
+ PUSHJ P,IGVAL\r
+ CAMN A,$TUNBOUND\r
+ JRST UNAS\r
+ JRST FINIS\r
+\r
+;GETS A LOCATIVE TO THE GLOBAL VALUE OF AN IDENTIFIER\r
+\r
+MFUNCTION GLOC,SUBR\r
+\r
+ JUMPGE AB,TFA\r
+ CAMGE AB,[-5,,]\r
+ JRST TMA\r
+ JSP E,CHKAT1\r
+ MOVEI E,IGLOC\r
+ CAML AB,[-2,,]\r
+ JRST .+4\r
+ GETYP 0,2(AB)\r
+ CAIE 0,TFALSE\r
+ MOVEI E,IIGLOC\r
+ PUSHJ P,(E)\r
+ CAMN A,$TUNBOUND\r
+ JRST UNAS\r
+ MOVSI A,TLOCD\r
+ MOVE C,1(AB) ; GE ATOM\r
+ MOVEI 0,(C)\r
+ CAIGE 0,HIBOT ; SKIP IF PURE ATOM\r
+ JRST FINIS\r
+\r
+; MAKE ATOM AND VALUE IMPURE IF GETTING GLOC TO IT\r
+\r
+ MOVE B,C ; ATOM TO B\r
+ PUSHJ P,IMPURIFY\r
+ JRST GLOC ; AND TRY AGAIN\r
+\r
+;TESTS TO SEE IF AN IDENTIFIER IS GLOBALLY ASSIGNED\r
+\r
+MFUNCTION GASSIG,SUBR,[GASSIGNED?]\r
+ JSP E,CHKAT2\r
+ PUSHJ P,IGVAL\r
+ CAMN A,$TUNBOUND\r
+ JRST IFALSE\r
+ JRST TRUTH\r
+\r
+; TEST FOR GLOBALLY BOUND\r
+\r
+MFUNCTION GBOUND,SUBR,[GBOUND?]\r
+\r
+ JSP E,CHKAT2\r
+ PUSHJ P,IGLOC\r
+ JUMPE B,IFALSE\r
+ JRST TRUTH\r
+\r
+\f\r
+\r
+CHKAT2: ENTRY 1\r
+CHKAT1: GETYP A,(AB)\r
+ MOVSI A,(A)\r
+ CAME A,$TATOM\r
+ JRST NONATM\r
+ MOVE B,1(AB)\r
+ JRST 2,(E)\r
+\r
+CHKAT: HLRE A,AB ; - # OF ARGS\r
+ ASH A,-1 ; TO ACTUAL WORDS\r
+ JUMPGE AB,TFA\r
+ MOVE C,SP ; FOR BINDING LOOKUPS\r
+ AOJE A,CHKAT1 ; ONLY ONE ARG, NO ENVIRONMENT\r
+ AOJL A,TMA ; TOO MANY\r
+ GETYP A,2(AB) ; MAKE SURE OF TENV OR TFRAME\r
+ CAIE A,TFRAME\r
+ CAIN A,TENV\r
+ JRST CHKAT3\r
+ CAIN A,TACT ; FOR PFISTERS LOSSAGE\r
+ JRST CHKAT3\r
+ CAIE A,TPVP ; OR PROCESS\r
+ JRST WTYP2\r
+ MOVE B,3(AB) ; GET PROCESS\r
+ MOVE C,SP ; IN CASE ITS ME\r
+ CAME B,PVP ; SKIP IF DIFFERENT\r
+ MOVE C,SPSTO+1(B) ; GET ITS SP\r
+ JRST CHKAT1\r
+CHKAT3: MOVEI B,2(AB) ; POINT TO FRAME POINTER\r
+ PUSHJ P,CHFRM ; VALIDITY CHECK\r
+ MOVE B,3(AB) ; GET TB FROM FRAME\r
+ MOVE C,SPSAV(B) ; GET ENVIRONMENT POINTER\r
+ JRST CHKAT1\r
+\r
+\f\r
+\r
+;ILOC RETURNS IN A AND B A LOCATIVE TO THE LOCAL VALUE OF THE IDENTIFIER PASSED TO IT\r
+;IN A AND B. IF THE IDENTIFIER IS LOCALLY UNBOUND IT RETURNS $TUNBOUND IN A AND 0 IN B,\r
+; IT IS CALLED BY PUSHJ P,ILOC.\r
+\r
+ILOC: MOVE C,SP ; SETUP SEARCH START\r
+AILOC: MOVSI A,TLOCI ;MAKE A LOCATIVE TYPE CELL\r
+ PUSH P,E\r
+ PUSH P,D\r
+ MOVEI E,0 ; FLAG TO CLOBBER ATOM\r
+ JUMPE B,SCHSP ; IF LOOKING FOR SLOT, SEARCH NOW\r
+ CAME C,SP ; ENVIRONMENT CHANGE?\r
+ JRST SCHSP ; YES, MUST SEARCH\r
+ HRR A,BINDID+1(PVP) ;FOR THE CURRENT PROCESS\r
+ CAME A,(B) ;IS THERE ONE IN THE VALUE CELL?\r
+ JRST SCHLP ;NO -- SEARCH THE LOCAL BINDINGS\r
+ MOVE B,1(B) ;YES -- GET LOCATIVE POINTER\r
+ MOVE C,PVP\r
+ILCPJ: MOVE E,SPCCHK\r
+ TRNN E,1 ; SKIP IF DOING SPEC UNSPEC CHECK\r
+ JRST ILOCPJ\r
+ HLRZ E,-2(B)\r
+ CAIE E,TUBIND\r
+ JRST ILOCPJ\r
+ CAMGE B,CURFCN+1(PVP)\r
+ JRST UNPJ11\r
+ MOVEI D,-2(B)\r
+ CAIG D,(SP)\r
+ CAMGE B,SPBASE+1(PVP)\r
+ JRST UNPJ11\r
+ILOCPJ: POP P,D\r
+ POP P,E\r
+ POPJ P, ;FROM THE VALUE CELL\r
+\r
+SCHLP: MOVEI D,(B)\r
+ CAIL D,HIBOT ; SKIP IF IMPURE ATOM\r
+SCHSP: MOVEI E,1 ; DONT STORE LOCATIVE\r
+\r
+ PUSH P,E ; PUSH SWITCH\r
+ MOVE E,PVP ; GET PROC\r
+SCHLP1: JUMPE C,UNPJ ;IF NO MORE -- LOSE\r
+ CAMN B,1(C) ;ARE WE POINTING AT THE WINNER?\r
+ JRST SCHFND ;YES\r
+ GETYP D,(C) ; CHECK SKIP\r
+ CAIE D,TSKIP\r
+ JRST SCHLP2\r
+ PUSH P,B ; CHECK DETOUR\r
+ MOVEI B,2(C)\r
+ PUSHJ P,CHFRAM ; NON-FATAL FRAME CHECKER\r
+ HRRZ E,2(C) ; CONS UP PROCESS\r
+ SUBI E,PVLNT*2+1\r
+ HRLI E,-2*PVLNT\r
+ JUMPE B,SCHLP3 ; LOSER, FIX IT\r
+ POP P,B\r
+ MOVEI C,1(C) ; FOLLOW LOOKUP CHAIN\r
+SCHLP2: HRRZ C,(C) ;FOLLOW LINK\r
+ JRST SCHLP1\r
+\r
+SCHLP3: POP P,B\r
+ MOVEI C,(SP) ; *** NDR'S BUG ***\r
+ CAME E,PVP ; USE IF CURRENT PROCESS\r
+ HRRZ C,SPSTO+1(E) ; USE CURRENT SP FOR PROC\r
+ JRST SCHLP1\r
+ \r
+SCHFND: EXCH B,C ;SAVE THE ATOM PTR IN C\r
+ MOVEI B,2(B) ;MAKE UP THE LOCATIVE\r
+ SUB B,TPBASE+1(E)\r
+ HRLI B,(B)\r
+ ADD B,TPBASE+1(E)\r
+ EXCH C,E ; RET PROCESS IN C\r
+ POP P,D ; RESTORE SWITCH\r
+\r
+ JUMPN D,ILOCPJ ; DONT CLOBBER ATOM\r
+ MOVEM A,(E) ;CLOBBER IT AWAY INTO THE\r
+ MOVEM B,1(E) ;ATOM'S VALUE CELL\r
+ JRST ILCPJ\r
+\r
+UNPJ: SUB P,[1,,1] ; FLUSH CRUFT\r
+UNPJ1: MOVE C,E ; RET PROCESS ANYWAY\r
+UNPJ11: POP P,D\r
+ POP P,E\r
+UNPOPJ: MOVSI A,TUNBOUND\r
+ MOVEI B,0\r
+ POPJ P,\r
+\r
+;IGLOC RETURNS IN A AND B A LOCATIVE TO THE GLOBAL VALUE OF THE \r
+;IDENTIFIER PASSED TO IT IN A AND B. IF THE IDENTIFIER IS GLOBALLY\r
+;UNBPOUND IT RETURNS $TUNBOUND IN A AND 0 IN B. IT IS CALLED BY PUSHJ P,IGLOC.\r
+\r
+\r
+IGLOC: MOVSI A,TLOCI ;DO WE HAVE A LOCATIVE TO\r
+ CAME A,(B) ;A PROCESS #0 VALUE?\r
+ JRST SCHGSP ;NO -- SEARCH\r
+ MOVE B,1(B) ;YES -- GET VALUE CELL\r
+ POPJ P,\r
+\r
+SCHGSP: MOVE D,GLOBSP+1(TVP) ;GET GLOBAL SP PTR\r
+\r
+SCHG1: JUMPGE D,UNPOPJ ;IF NO MORE, LEAVE\r
+ CAMN B,1(D) ;ARE WE FOUND?\r
+ JRST GLOCFOUND ;YES\r
+ ADD D,[4,,4] ;NO -- TRY NEXT\r
+ JRST SCHG1\r
+\r
+GLOCFOUND:\r
+ EXCH B,D ;SAVE ATOM PTR\r
+ ADD B,[2,,2] ;MAKE LOCATIVE\r
+ MOVEI 0,(D)\r
+ CAIL 0,HIBOT\r
+ POPJ P,\r
+ MOVEM A,(D) ;CLOBBER IT AWAY\r
+ MOVEM B,1(D)\r
+ POPJ P,\r
+\r
+IIGLOC: PUSH TP,$TATOM\r
+ PUSH TP,B\r
+ PUSHJ P,IGLOC\r
+ MOVE C,(TP)\r
+ SUB TP,[2,,2]\r
+ GETYP 0,A\r
+ CAIE 0,TUNBOU\r
+ POPJ P,\r
+ PUSH TP,$TATOM\r
+ PUSH TP,C\r
+ PUSHJ P,BSETG ; MAKE A SLOT\r
+ SETOM 1(B) ; UNBOUNDIFY IT\r
+ MOVSI A,TLOCD\r
+ MOVSI 0,TUNBOU\r
+ MOVEM 0,(B)\r
+ SUB TP,[2,,2]\r
+ POPJ P,\r
+ \r
+\f\r
+\r
+;ILVAL RETURNS IN A AND B THE LOCAL VALUE OF THE IDENTIFIER PASSED TO IT IN A AND B\r
+;IF THE IDENTIFIER IS UNBOUND ITS VALUE IS $TUNBOUND IN A AND 0 IN B. IF\r
+;IT IS UNASSIGNED ITS VALUE IS $TUNBOUND IN A AND -1 IN B. CALL - PUSHJ P,IVAL\r
+\r
+AILVAL:\r
+ PUSHJ P,AILOC ; USE SUPPLIED SP\r
+ JRST CHVAL\r
+ILVAL:\r
+ PUSHJ P,ILOC ;GET LOCATIVE TO VALUE\r
+CHVAL: CAMN A,$TUNBOUND ;BOUND\r
+ POPJ P, ;NO -- RETURN\r
+ MOVSI A,TLOCD ; GET GOOD TYPE\r
+ HRR A,2(B) ; SHOULD BE TIME OR 0\r
+ PUSH P,0\r
+ PUSHJ P,RMONC0 ; CHECK READ MONITOR\r
+ POP P,0\r
+ MOVE A,(B) ;GET THE TYPE OF THE VALUE\r
+ MOVE B,1(B) ;GET DATUM\r
+ POPJ P,\r
+\r
+;IGVAL -- LIKE ILVAL EXCEPT FOR GLOBAL VALUES\r
+\r
+IGVAL: PUSHJ P,IGLOC\r
+ JRST CHVAL\r
+\r
+\r
+\f\r
+; COMPILERS INTERFACE TO LVAL/GVAL/SETG/SET\r
+\r
+CILVAL: MOVE 0,BINDID+1(PVP) ; CURRENT BIND\r
+ HRLI 0,TLOCI\r
+ CAME 0,(B) ; HURRAY FOR SPEED\r
+ JRST CILVA1 ; TOO BAD\r
+ MOVE C,1(B) ; POINTER\r
+ MOVE A,(C) ; VAL TYPE\r
+ TLNE A,.RDMON ; MONITORS?\r
+ JRST CILVA1\r
+ GETYP 0,A\r
+ CAIN 0,TUNBOU\r
+ JRST CUNAS ; COMPILER ERROR\r
+ MOVE B,1(C) ; GOT VAL\r
+ MOVE 0,SPCCHK\r
+ TRNN 0,1\r
+ POPJ P,\r
+ HLRZ 0,-2(C) ; SPECIAL CHECK\r
+ CAIE 0,TUBIND\r
+ POPJ P, ; RETURN\r
+ CAMGE C,CURFCN+1(PVP)\r
+ JRST CUNAS\r
+ POPJ P,\r
+\r
+CUNAS:\r
+CILVA1: SUBM M,(P) ; FIX (P)\r
+ PUSH TP,$TATOM ; SAVE ATOM\r
+ PUSH TP,B\r
+ MCALL 1,LVAL ; GET ERROR/MONITOR\r
+MPOPJ:\r
+POPJM: SUBM M,(P) ; REPAIR DAMAGE\r
+ POPJ P,\r
+\r
+; COMPILERS INTERFACE TO SET C/ ATOM A,B/ NEW VALUE\r
+\r
+CISET: MOVE 0,BINDID+1(PVP) ; CURRENT BINDING ENVIRONMENT\r
+ HRLI 0,TLOCI\r
+ CAME 0,(C) ; CAN WE WIN?\r
+ JRST CISET1 ; NO, MORE HAIR\r
+ MOVE D,1(C) ; POINT TO SLOT\r
+ HLLZ 0,(D) ; MON CHECK\r
+CISET3: TLNE 0,.WRMON\r
+ JRST CISET4 ; YES, LOSE\r
+ TLZ 0,TYPMSK\r
+ IOR A,0 ; LEAVE MONITOR ON\r
+ MOVE 0,SPCCHK\r
+ TRNE 0,1\r
+ JRST CISET5 ; SPEC/UNSPEC CHECK\r
+CISET6: MOVEM A,(D) ; STORE\r
+ MOVEM B,1(D)\r
+ POPJ P,\r
+\r
+CISET5: HLRZ 0,-2(D)\r
+ CAIE 0,TUBIND\r
+ JRST CISET6\r
+ CAMGE D,CURFCN+1(PVP)\r
+ JRST CISET4\r
+ JRST CISET6\r
+ \r
+CISET1: SUBM M,(P) ; FIX ADDR\r
+ PUSH TP,$TATOM ; SAVE ATOM\r
+ PUSH TP,C\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ MOVE B,C ; GET ATOM\r
+ PUSHJ P,ILOC ; SEARCH\r
+ MOVE D,B ; POSSIBLE POINTER\r
+ GETYP E,A\r
+ MOVE 0,A\r
+ MOVE A,-1(TP) ; VAL BACK\r
+ MOVE B,(TP)\r
+ CAIE E,TUNBOU ; SKIP IF WIN\r
+ JRST CISET2 ; GO CLOBBER IT IN\r
+ MCALL 2,SET\r
+ JRST POPJM\r
+ \r
+CISET2: MOVE C,-2(TP) ; ATOM BACK\r
+ SUBM M,(P) ; RESET (P)\r
+ SUB TP,[4,,4]\r
+ JRST CISET3\r
+\r
+; HERE TO DO A MONITORED SET\r
+\r
+CISET4: SUBM M,(P) ; AGAIN FIX (P)\r
+ PUSH TP,$TATOM\r
+ PUSH TP,C\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ MCALL 2,SET\r
+ JRST POPJM\r
+\r
+; COMPILER LLOC\r
+\r
+CLLOC: MOVE 0,BINDID+1(PVP) ; GET CURRENT LOCATIVE\r
+ HRLI 0,TLOCI\r
+ CAME 0,(B) ; WIN?\r
+ JRST CLLOC1\r
+ MOVE B,1(B)\r
+ MOVE 0,SPCCHK\r
+ TRNE 0,1 ; SKIP IF NOT CHECKING\r
+ JRST CLLOC9\r
+CLLOC3: MOVSI A,TLOCD\r
+ HRR A,2(B) ; GET BIND TIME\r
+ POPJ P,\r
+\r
+CLLOC1: SUBM M,(P)\r
+ PUSH TP,$TATOM\r
+ PUSH TP,B\r
+ PUSHJ P,ILOC ; LOOK IT UP\r
+ JUMPE B,CLLOC2\r
+ SUB TP,[2,,2]\r
+CLLOC4: SUBM M,(P)\r
+ JRST CLLOC3\r
+\r
+CLLOC2: MCALL 1,LLOC\r
+ JRST CLLOC4\r
+\r
+CLLOC9: HLRZ 0,-2(B)\r
+ CAIE 0,TUBIND\r
+ JRST CLLOC3\r
+ CAMGE B,CURFCN+1(PVP)\r
+ JRST CLLOC2\r
+ JRST CLLOC3\r
+\r
+; COMPILER BOUND?\r
+\r
+CBOUND: SUBM M,(P)\r
+ PUSHJ P,ILOC\r
+ JUMPE B,PJFALS ; IF UNBOUND RET FALSE AND NO SSKIP\r
+PJT1: SOS (P)\r
+ MOVSI A,TATOM\r
+ MOVE B,MQUOTE T\r
+ JRST POPJM\r
+\r
+PJFALS: MOVEI B,0\r
+ MOVSI A,TFALSE\r
+ JRST POPJM\r
+\r
+; COMPILER ASSIGNED?\r
+\r
+CASSQ: SUBM M,(P)\r
+ PUSHJ P,ILOC\r
+ JUMPE B,PJFALS\r
+ GETYP 0,(B)\r
+ CAIE 0,TUNBOU\r
+ JRST PJT1\r
+ JRST PJFALS\r
+\f\r
+\r
+; COMPILER GVAL B/ ATOM\r
+\r
+CIGVAL: MOVE 0,(B) ; GLOBAL VAL HERE?\r
+ CAME 0,$TLOCI ; TIME=0 ,TYPE=TLOCI => GLOB VAL\r
+ JRST CIGVA1 ; NO, GO LOOK\r
+ MOVE C,1(B) ; POINT TO SLOT\r
+ MOVE A,(C) ; GET TYPE\r
+ TLNE A,.RDMON\r
+ JRST CIGVA1\r
+ GETYP 0,A ; CHECK FOR UNBOUND\r
+ CAIN 0,TUNBOU ; SKIP IF WINNER\r
+ JRST CGUNAS\r
+ MOVE B,1(C)\r
+ POPJ P,\r
+\r
+CGUNAS:\r
+CIGVA1: SUBM M,(P)\r
+ PUSH TP,$TATOM\r
+ PUSH TP,B\r
+ .MCALL 1,GVAL ; GET ERROR/MONITOR\r
+ JRST POPJM\r
+\r
+; COMPILER INTERFACET TO SETG\r
+\r
+CSETG: MOVE 0,(C) ; GET V CELL\r
+ CAME 0,$TLOCI ; SKIP IF FAST\r
+ JRST CSETG1\r
+ HRRZ D,1(C) ; POINT TO SLOT\r
+ MOVE 0,(D) ; OLD VAL\r
+CSETG3: CAIG D,HIBOT ; SKIP IF PURE ATOM\r
+ TLNE 0,.WRMON ; MONITOR\r
+ JRST CSETG2\r
+ MOVEM A,(D)\r
+ MOVEM B,1(D)\r
+ POPJ P,\r
+\r
+CSETG1: SUBM M,(P) ; FIX UP P\r
+ PUSH TP,$TATOM\r
+ PUSH TP,C\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ MOVE B,C\r
+ PUSHJ P,IGLOC ; FIND GLOB LOCATIVE\r
+ GETYP E,A\r
+ MOVE 0,A\r
+ MOVEI D,(B) ; SETUP TO RESTORE NEW VAL\r
+ MOVE A,-1(TP)\r
+ MOVE B,(TP)\r
+ CAIE E,TUNBOU\r
+ JRST CSETG4\r
+ MCALL 2,SETG\r
+ JRST POPJM\r
+\r
+CSETG4: MOVE C,-2(TP) ; ATOM BACK\r
+ SUBM M,(P) ; RESET (P)\r
+ SUB TP,[4,,4]\r
+ JRST CSETG3\r
+\r
+CSETG2: SUBM M,(P)\r
+ PUSH TP,$TATOM ; CAUSE A SETG MONITOR\r
+ PUSH TP,C\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ MCALL 2,SETG\r
+ JRST POPJM\r
+\r
+; COMPILER GLOC\r
+\r
+CGLOC: MOVE 0,(B) ; GET CURRENT GUY\r
+ CAME 0,$TLOCI ; WIN?\r
+ JRST CGLOC1 ; NOPE\r
+ HRRZ D,1(B) ; POINT TO SLOT\r
+ CAILE D,HIBOT ; PURE?\r
+ JRST CGLOC1\r
+ MOVE A,$TLOCD\r
+ MOVE B,1(B)\r
+ POPJ P,\r
+\r
+CGLOC1: SUBM M,(P)\r
+ PUSH TP,$TATOM\r
+ PUSH TP,B\r
+ MCALL 1,GLOC\r
+ JRST POPJM\r
+\r
+; COMPILERS GASSIGNED?\r
+\r
+CGASSQ: MOVE 0,(B)\r
+ SUBM M,(P)\r
+ CAMN 0,$TLOCD\r
+ JRST PJT1\r
+ PUSHJ P,IGLOC\r
+ JUMPE B,PJFALS\r
+ GETYP 0,(B)\r
+ CAIE 0,TUNBOU\r
+ JRST PJT1\r
+ JRST PJFALS\r
+\r
+; COMPILERS GBOUND?\r
+\r
+CGBOUN: MOVE 0,(B)\r
+ SUBM M,(P)\r
+ CAMN 0,$TLOCD\r
+ JRST PJT1\r
+ PUSHJ P,IGLOC\r
+ JUMPE B,PJFALS\r
+ JRST PJT1\r
+\f\r
+\r
+MFUNCTION REP,FSUBR,[REPEAT]\r
+ JRST PROG\r
+MFUNCTION PROG,FSUBR\r
+ ENTRY 1\r
+ GETYP A,(AB) ;GET ARG TYPE\r
+ CAIE A,TLIST ;IS IT A LIST?\r
+ JRST WRONGT ;WRONG TYPE\r
+ SKIPN C,1(AB) ;GET AND CHECK ARGUMENT\r
+ JRST TFA ;TOO FEW ARGS\r
+ SETZB E,D ; INIT HEWITT ATOM AND DECL\r
+ PUSHJ P,CARATC ; IS 1ST THING AN ATOM\r
+ JFCL\r
+ PUSHJ P,RSATY1 ; CDR AND GET TYPE\r
+ CAIE 0,TLIST ; MUST BE LIST\r
+ JRST MPD.13\r
+ MOVE B,1(C) ; GET ARG LIST\r
+ PUSH TP,$TLIST\r
+ PUSH TP,C\r
+ PUSHJ P,RSATYP\r
+ CAIE 0,TDECL\r
+ JRST NOP.DC ; JUMP IF NO DCL\r
+ MOVE D,1(C)\r
+ MOVEM C,(TP)\r
+ PUSHJ P,RSATYP ; CDR ON\r
+NOP.DC: PUSH TP,$TLIST \r
+ PUSH TP,B ; AND ARG LIST\r
+ PUSHJ P,PRGBND ; BIND AUX VARS\r
+ MOVE E,MQUOTE LPROG,[LPROG ]INTRUP\r
+ PUSHJ P,MAKACT ; MAKE ACTIVATION\r
+ PUSHJ P,PSHBND ; BIND AND CHECK\r
+ PUSHJ P,SPECBI ; NAD BIND IT\r
+\r
+; HERE TO RUN PROGS FUNCTIONS ETC.\r
+\r
+DOPROG: MOVEI A,REPROG\r
+ HRLI A,TDCLI ; FLAG AS FUNNY\r
+ MOVEM A,(TB) ; WHERE TO AGAIN TO\r
+ MOVE C,1(TB)\r
+ MOVEM C,3(TB) ; RESTART POINTER\r
+ JRST .+2 ; START BY SKIPPING DECL\r
+\r
+DOPRG1: PUSHJ P,FASTEV\r
+ HRRZ C,@1(TB) ;GET THE REST OF THE BODY\r
+DOPRG2: MOVEM C,1(TB)\r
+ JUMPN C,DOPRG1\r
+ENDPROG:\r
+ HRRZ C,FSAV(TB)\r
+ CAIN C,REP\r
+REPROG: SKIPN C,@3(TB)\r
+ JRST PFINIS\r
+ HRRZM C,1(TB)\r
+ INTGO\r
+ MOVE C,1(TB)\r
+ JRST DOPRG1\r
+\r
+\r
+PFINIS: GETYP 0,(TB)\r
+ CAIE 0,TDCLI ; DECL'D ?\r
+ JRST PFINI1\r
+ HRRZ 0,(TB) ; SEE IF RSUBR\r
+ JUMPE 0,RSBVCK ; CHECK RSUBR VALUE\r
+ HRRZ C,3(TB) ; GET START OF FCN\r
+ GETYP 0,(C) ; CHECK FOR DECL\r
+ CAIE 0,TDECL\r
+ JRST PFINI1 ; NO, JUST RETURN\r
+ MOVE E,MQUOTE VALUE\r
+ PUSHJ P,PSHBND ; BUILD FAKE BINDING\r
+ MOVE C,1(C) ; GET DECL LIST\r
+ MOVE E,TP\r
+ PUSHJ P,CHKDCL ; AND CHECK IT\r
+ MOVE A,-3(TP) ; GET VAL BAKC\r
+ MOVE B,-2(TP)\r
+ SUB TP,[6,,6]\r
+\r
+PFINI1: HRRZ C,FSAV(TB)\r
+ CAIE C,EVAL\r
+ JRST FINIS\r
+ JRST EFINIS\r
+\r
+RSATYP: HRRZ C,(C)\r
+RSATY1: JUMPE C,TFA\r
+ GETYP 0,(C)\r
+ POPJ P,\r
+\r
+; HERE TO CHECK RSUBR VALUE\r
+\r
+RSBVCK: PUSH TP,A\r
+ PUSH TP,B\r
+ MOVE C,A\r
+ MOVE D,B\r
+ MOVE A,1(TB) ; GET DECL\r
+ MOVE B,1(A)\r
+ HLLZ A,(A)\r
+ PUSHJ P,TMATCH\r
+ JRST RSBVC1\r
+ POP TP,B\r
+ POP TP,A\r
+ POPJ P,\r
+\r
+RSBVC1: MOVE C,1(TB)\r
+ POP TP,B\r
+ POP TP,D\r
+ MOVE A,MQUOTE VALUE\r
+ JRST TYPMIS\r
+\f\r
+\r
+MFUNCTION MRETUR,SUBR,[RETURN]\r
+ ENTRY\r
+ HLRE A,AB ; GET # OF ARGS\r
+ ASH A,-1 ; TO NUMBER\r
+ AOJL A,RET2 ; 2 OR MORE ARGS\r
+ PUSHJ P,PROGCH ;CHECK IN A PROG\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ MOVEI B,-1(TP) ; VERIFY IT\r
+COMRET: PUSHJ P,CHFSWP\r
+ SKIPL C ; ARGS?\r
+ MOVEI C,0 ; REAL NONE\r
+ PUSHJ P,CHUNW\r
+ JUMPN A,CHFINI ; WINNER\r
+ MOVSI A,TATOM\r
+ MOVE B,MQUOTE T\r
+\r
+; SEE IF MUST CHECK RETURNS TYPE\r
+\r
+CHFINI: GETYP 0,(TB) ; SPECIAL TYPE IF SO\r
+ CAIE 0,TDCLI\r
+ JRST FINIS ; NO, JUST FINIS\r
+ MOVEI 0,PFINIS ; CAUSE TO FALL INTO FUNCTION CODE\r
+ HRRM 0,PCSAV(TB)\r
+ JRST CONTIN\r
+\r
+\r
+RET2: AOJL A,TMA\r
+ GETYP A,(AB)+2\r
+ CAIE A,TACT ; AS FOR "EXIT" SHOULD BE ACTIVATION\r
+ JRST WTYP2\r
+ MOVEI B,(AB)+2 ; ADDRESS OF FRAME POINTER\r
+ JRST COMRET\r
+\r
+\r
+\r
+MFUNCTION AGAIN,SUBR\r
+ ENTRY \r
+ HLRZ A,AB ;GET # OF ARGS\r
+ CAIN A,-2 ;1 ARG?\r
+ JRST NLCLA ;YES\r
+ JUMPN A,TMA ;0 ARGS?\r
+ PUSHJ P,PROGCH ;CHECK FOR IN A PROG\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ JRST AGAD\r
+NLCLA: GETYP A,(AB)\r
+ CAIE A,TACT\r
+ JRST WTYP1\r
+ PUSH TP,(AB)\r
+ PUSH TP,1(AB)\r
+AGAD: MOVEI B,-1(TP) ; POINT TO FRAME\r
+ PUSHJ P,CHFSWP\r
+ HRRZ C,(B) ; GET RET POINT\r
+GOJOIN: PUSH TP,$TFIX\r
+ PUSH TP,C\r
+ MOVEI C,-1(TP)\r
+ PUSHJ P,CHUNW ; RESTORE FRAME, UNWIND IF NEC.\r
+ HRRZM B,PCSAV(TB)\r
+ HRRZ 0,FSAV(TB) ; CHECK FOR RSUBR\r
+ CAMGE 0,VECTOP\r
+ CAMG 0,VECBOT\r
+ JRST CONTIN\r
+ HRRZ E,1(TB)\r
+ PUSH TP,$TFIX\r
+ PUSH TP,B\r
+ MOVEI C,-1(TP)\r
+ MOVEI B,(TB)\r
+ PUSHJ P,CHUNW1\r
+ MOVE TP,1(TB)\r
+ MOVEM SP,SPSAV(TB)\r
+ MOVEM TP,TPSAV(TB)\r
+ MOVE C,OTBSAV(TB) ; AND RESTORE P FROM FATHER\r
+ MOVE P,PSAV(C)\r
+ MOVEM P,PSAV(TB)\r
+ HRLI B,M\r
+ MOVEM B,PCSAV(TB)\r
+ JRST CONTIN\r
+\r
+MFUNCTION GO,SUBR\r
+ ENTRY 1\r
+ GETYP A,(AB)\r
+ CAIE A,TATOM\r
+ JRST NLCLGO\r
+ PUSHJ P,PROGCH ;CHECK FOR A PROG\r
+ PUSH TP,A ;SAVE\r
+ PUSH TP,B\r
+ MOVEI B,-1(TP)\r
+ PUSHJ P,CHFSWP\r
+ PUSH TP,$TATOM\r
+ PUSH TP,1(C)\r
+ PUSH TP,2(B)\r
+ PUSH TP,3(B)\r
+ MCALL 2,MEMQ ;DOES IT HAVE THIS TAG?\r
+ JUMPE B,NXTAG ;NO -- ERROR\r
+FNDGO: EXCH B,(TP) ;SAVE PLACE TO GO\r
+ MOVSI D,TLIST\r
+ MOVEM D,-1(TP)\r
+ JRST GODON\r
+\r
+NLCLGO: CAIE A,TTAG ;CHECK TYPE\r
+ JRST WTYP1\r
+ MOVE B,1(AB)\r
+ MOVEI B,2(B) ; POINT TO SLOT\r
+ PUSHJ P,CHFSWP\r
+ MOVE A,1(C)\r
+ GETYP 0,(A) ; SEE IF COMPILED\r
+ CAIE 0,TFIX\r
+ JRST GODON1\r
+ MOVE C,1(A)\r
+ JRST GOJOIN\r
+\r
+GODON1: PUSH TP,(A) ;SAVE BODY\r
+ PUSH TP,1(A)\r
+GODON: MOVEI C,0\r
+ PUSHJ P,CHUNW ;GO BACK TO CORRECT FRAME\r
+ MOVE B,(TP) ;RESTORE ITERATION MARKER\r
+ MOVEM B,1(TB)\r
+ MOVSI A,TFALSE\r
+ MOVEI B,0\r
+ JRST CONTIN\r
+\r
+\f\r
+\r
+\r
+MFUNCTION TAG,SUBR\r
+ ENTRY\r
+ JUMPGE AB,TFA\r
+ HLRZ 0,AB\r
+ GETYP A,(AB) ;GET TYPE OF ARGUMENT\r
+ CAIE A,TFIX ; FIX ==> COMPILED\r
+ JRST ATOTAG\r
+ CAIE 0,-4\r
+ JRST WNA\r
+ GETYP A,2(AB)\r
+ CAIE A,TACT\r
+ JRST WTYP2\r
+ PUSH TP,(AB)\r
+ PUSH TP,1(AB)\r
+ PUSH TP,2(AB)\r
+ PUSH TP,3(AB)\r
+ JRST GENTV\r
+ATOTAG: CAIE A,TATOM ;CHECK THAT IT IS AN ATOM\r
+ JRST WTYP1\r
+ CAIE 0,-2\r
+ JRST TMA\r
+ PUSHJ P,PROGCH ;CHECK PROG\r
+ PUSH TP,A ;SAVE VAL\r
+ PUSH TP,B\r
+ PUSH TP,$TATOM\r
+ PUSH TP,1(AB)\r
+ PUSH TP,2(B)\r
+ PUSH TP,3(B)\r
+ MCALL 2,MEMQ\r
+ JUMPE B,NXTAG ;IF NOT FOUND -- ERROR\r
+ EXCH A,-1(TP) ;SAVE PLACE\r
+ EXCH B,(TP) \r
+ HRLI A,TFRAME\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+GENTV: MOVEI A,2\r
+ PUSHJ P,IEVECT\r
+ MOVSI A,TTAG\r
+ JRST FINIS\r
+\r
+PROGCH: MOVE B,MQUOTE LPROG,[LPROG ]INTRUP\r
+ PUSHJ P,ILVAL ;GET VALUE\r
+ GETYP 0,A\r
+ CAIE 0,TACT\r
+ JRST NXPRG\r
+ POPJ P,\r
+\r
+; HERE TO UNASSIGN LPROG IF NEC\r
+\r
+UNPROG: MOVE B,MQUOTE LPROG,[LPROG ]INTRUP\r
+ PUSHJ P,ILVAL\r
+ GETYP 0,A\r
+ CAIE 0,TACT ; SKIP IF MUST UNBIND\r
+ JRST UNMAP\r
+ MOVSI A,TUNBOU\r
+ MOVNI B,1\r
+ MOVE E,MQUOTE LPROG,[LPROG ]INTRUP\r
+ PUSHJ P,PSHBND\r
+UNMAP: HRRZ 0,FSAV(TB) ; CHECK FOR FUNNY\r
+ CAIN 0,MAPPLY ; SKIP IF NOT\r
+ POPJ P,\r
+ MOVE B,MQUOTE LMAP,[LMAP ]INTRUP\r
+ PUSHJ P,ILVAL\r
+ GETYP 0,A\r
+ CAIE 0,TFRAME\r
+ JRST UNSPEC\r
+ MOVSI A,TUNBOU\r
+ MOVNI B,1\r
+ MOVE E,MQUOTE LMAP,[LMAP ]INTRUP\r
+ PUSHJ P,PSHBND\r
+UNSPEC: PUSH TP,BNDV\r
+ MOVE B,PVP\r
+ ADD B,[CURFCN,,CURFCN]\r
+ PUSH TP,B\r
+ PUSH TP,$TSP\r
+ MOVE E,SP\r
+ ADD E,[3,,3]\r
+ PUSH TP,E\r
+ POPJ P,\r
+\r
+REPEAT 0,[\r
+MFUNCTION MEXIT,SUBR,[EXIT]\r
+ ENTRY 2\r
+ GETYP A,(AB)\r
+ CAIE A,TACT\r
+ JRST WTYP1\r
+ MOVEI B,(AB)\r
+ PUSHJ P,CHFSWP\r
+ ADD C,[2,,2]\r
+ PUSHJ P,CHUNW ;RESTORE FRAME\r
+ JRST CHFINI ; CHECK FOR WINNING VALUE\r
+]\r
+\r
+MFUNCTION COND,FSUBR\r
+ ENTRY 1\r
+ GETYP A,(AB)\r
+ CAIE A,TLIST\r
+ JRST WRONGT\r
+ PUSH TP,(AB)\r
+ PUSH TP,1(AB) ;CREATE UNNAMED TEMP\r
+ MOVEI B,0 ; SET TO FALSE IN CASE\r
+\r
+CLSLUP: SKIPN C,1(TB) ;IS THE CLAUSELIST NIL?\r
+ JRST IFALS1 ;YES -- RETURN NIL\r
+ GETYP A,(C) ;NO -- GET TYPE OF CAR\r
+ CAIE A,TLIST ;IS IT A LIST?\r
+ JRST BADCLS ;\r
+ MOVE A,1(C) ;YES -- GET CLAUSE\r
+ JUMPE A,BADCLS\r
+ GETYPF B,(A)\r
+ PUSH TP,B ; EVALUATION OF\r
+ HLLZS (TP)\r
+ PUSH TP,1(A) ;THE PREDICATE\r
+ JSP E,CHKARG\r
+ MCALL 1,EVAL\r
+ GETYP 0,A\r
+ CAIN 0,TFALSE\r
+ JRST NXTCLS ;FALSE TRY NEXT CLAUSE\r
+ MOVE C,1(TB) ;IF NOT, DO FIRST CLAUSE\r
+ MOVE C,1(C)\r
+ HRRZ C,(C)\r
+ JUMPE C,FINIS ;(UNLESS DONE WITH IT)\r
+ JRST DOPRG2 ;AS THOUGH IT WERE A PROG\r
+NXTCLS: HRRZ C,@1(TB) ;SET THE CLAUSLIST\r
+ HRRZM C,1(TB) ;TO CDR OF THE CLAUSLIST\r
+ JRST CLSLUP\r
+ \r
+IFALSE:\r
+ MOVEI B,0\r
+IFALS1: MOVSI A,TFALSE ;RETURN FALSE\r
+ JRST FINIS\r
+\r
+\r
+\f\r
+MFUNCTION UNWIND,FSUBR\r
+\r
+ ENTRY 1\r
+\r
+ GETYP 0,(AB) ; CHECK THE ARGS FOR WINNAGE\r
+ SKIPN A,1(AB) ; NONE?\r
+ JRST TFA\r
+ HRRZ B,(A) ; CHECK FOR 2D\r
+ JUMPE B,TFA\r
+ HRRZ 0,(B) ; 3D?\r
+ JUMPN 0,TMA\r
+\r
+; Unbind LPROG and LMAPF so that nothing cute happens\r
+\r
+ PUSHJ P,UNPROG\r
+\r
+; Push thing to do upon UNWINDing\r
+\r
+ PUSH TP,$TLIST\r
+ PUSH TP,[0]\r
+\r
+ MOVEI C,UNWIN1\r
+ PUSHJ P,IUNWIN ; GOT TO INTERNAL SET UP\r
+\r
+; Now EVAL the first form\r
+\r
+ MOVE A,1(AB)\r
+ HRRZ 0,(A) ; SAVE POINTER TO OTHER GUY\r
+ MOVEM 0,-12(TP)\r
+ MOVE B,1(A)\r
+ GETYP A,(A)\r
+ MOVSI A,(A)\r
+ JSP E,CHKAB ; DEFER?\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ MCALL 1,EVAL ; EVAL THE LOSER\r
+\r
+ JRST FINIS\r
+\r
+; Now push slots to hold undo info on the way down\r
+\r
+IUNWIN:\r
+REPEAT 0,[\r
+ JUMPE M,NOTRSB\r
+ MOVEI C,(C)\r
+ HLRE 0,M\r
+ SUBM M,0\r
+ ANDI 0,-1\r
+ CAIL C,HIBOT\r
+ JRST NOTRSB\r
+ CAIL C,(M)\r
+ CAML C,0\r
+ JRST .+2\r
+ SUBI C,(M)\r
+NOTRSB:]\r
+ PUSH TP,$TTB ; DESTINATION FRAME\r
+ PUSH TP,[0]\r
+ PUSH TP,[0] ; ARGS TO WHOEVER IS DOING IT\r
+ PUSH TP,[0]\r
+\r
+; Now bind UNWIND word\r
+\r
+ PUSH TP,$TUNWIN ; FIRST WORD OF IT\r
+ HRRM SP,(TP) ; CHAIN\r
+ MOVE SP,TP\r
+ PUSH TP,TB ; AND POINT TO HERE\r
+ PUSH TP,$TTP\r
+ PUSH TP,[0]\r
+ HRLI C,TPDL\r
+ PUSH TP,C\r
+ PUSH TP,P ; SAVE PDL ALSO\r
+ MOVEM TP,-2(TP) ; SAVE FOR LATER\r
+ POPJ P,\r
+\r
+; Do a non-local return with UNWIND checking\r
+\r
+CHUNW: HRRZ E,SPSAV(B) ; GET DESTINATION FRAME\r
+CHUNW1: PUSH TP,(C) ; FINAL VAL\r
+ PUSH TP,1(C)\r
+ JUMPN C,.+3 ; WAS THERE REALLY ANYTHING\r
+ SETZM (TP)\r
+ SETZM -1(TP)\r
+ PUSHJ P,STLOOP ; UNBIND\r
+CHUNPC: SKIPA ; WILL NOT SKIP UNLESS UNWIND FOUND\r
+ JRST GOTUND\r
+ MOVEI A,(TP)\r
+ SUBI A,(SP)\r
+ MOVSI A,(A)\r
+ HLL SP,TP\r
+ SUB SP,A\r
+ HRRI TB,(B) ; UPDATE TB\r
+ POP TP,B\r
+ POP TP,A\r
+ POPJ P,\r
+\r
+; Here if an UNDO found\r
+\r
+GOTUND: MOVE TB,1(SP) ; GET FRAME OF UNDO\r
+ MOVE A,-1(TP) ; GET FUNNY ARG FOR PASS ON\r
+ MOVE C,(TP)\r
+ MOVE TP,3(SP) ; GET FUTURE TP\r
+ MOVEM C,-6(TP) ; SAVE ARG\r
+ MOVEM A,-7(TP)\r
+ MOVE C,(TP) ; SAVED P\r
+ SUB C,[1,,1]\r
+ MOVEM C,PSAV(TB) ; MAKE CONTIN WIN\r
+ MOVEM TP,TPSAV(TB)\r
+ MOVEM SP,SPSAV(TB)\r
+ HRRZ C,(P) ; PC OF CHUNW CALLER\r
+ HRRM C,-11(TP) ; SAVE ALSO AND GET WHERE TO GO PC\r
+ MOVEM B,-10(TP) ; AND DESTINATION FRAME\r
+ HRRZ C,-1(TP) ; WHERE TO UNWIND PC\r
+ HRRZ 0,FSAV(TB) ; RSUBR?\r
+ CAMG 0,VECTOP\r
+ CAMGE 0,VECBOT\r
+ TLZA C,-1 ; 0 LH OF C AND SKIP\r
+ HRLI C,M ; RELATIVIZE\r
+ MOVEM C,PCSAV(TB)\r
+ JRST CONTIN\r
+\r
+UNWIN1: MOVE B,-12(TP) ; POINT TO THING TO DO UNWINDING\r
+ GETYP A,(B)\r
+ MOVSI A,(A)\r
+ MOVE B,1(B)\r
+ JSP E,CHKAB\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ MCALL 1,EVAL\r
+UNWIN2: MOVEI C,-7(TP) ; POINT TO SAVED RET VALS\r
+ MOVE B,-10(TP)\r
+ HRRZ E,-11(TP)\r
+ PUSH P,E\r
+ HRRZ SP,(SP) ; UNBIND THIS GUY\r
+ MOVEI E,(TP) ; AND FIXUP SP\r
+ SUBI E,(SP)\r
+ MOVSI E,(E)\r
+ HLL SP,TP\r
+ SUB SP,E\r
+ JRST CHUNW ; ANY MORE TO UNWIND?\r
+\r
+\f\r
+; CHFSWP - CHECK FRAMES VALIDITY AND SWAP PROCESS IF NECESSARY.\r
+; CALLED BY ALL CONTROL FLOW\r
+; ROUTINES (GO,RETURN,EXIT,AGAIN,ERRET...)\r
+\r
+CHFSWP: PUSHJ P,CHFRM ; CHECK FOR VALID FRAME\r
+ HRRZ D,(B) ; PROCESS VECTOR DOPE WD\r
+ HLRZ C,(D) ; LENGTH\r
+ SUBI D,-1(C) ; POINT TO TOP\r
+ MOVNS C ; NEGATE COUNT\r
+ HRLI D,2(C) ; BUILD PVP\r
+ MOVE E,PVP\r
+ MOVE C,AB\r
+ MOVE A,(B) ; GET FRAME\r
+ MOVE B,1(B)\r
+ CAMN E,D ; SKIP IF SWAP NEEDED\r
+ POPJ P,\r
+ PUSH TP,A ; SAVE FRAME\r
+ PUSH TP,B\r
+ MOVE B,D\r
+ PUSHJ P,PROCHK ; FIX UP PROCESS LISTS\r
+ MOVE A,PSTAT+1(B) ; GET STATE\r
+ CAIE A,RESMBL\r
+ JRST NOTRES\r
+ MOVE D,B ; PREPARE TO SWAP\r
+ POP P,0 ; RET ADDR\r
+ POP TP,B\r
+ POP TP,A\r
+ JSP C,SWAP ; SWAP IN\r
+ MOVE C,ABSTO+1(E) ; GET OLD ARRGS\r
+ MOVEI A,RUNING ; FIX STATES\r
+ MOVEM A,PSTAT+1(PVP)\r
+ MOVEI A,RESMBL\r
+ MOVEM A,PSTAT+1(E)\r
+ JRST @0\r
+\r
+NOTRES: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE PROCESS-NOT-RESUMABLE\r
+ JRST CALER1\r
+\f\r
+\r
+;SETG IS USED TO SET THE GLOBAL VALUE OF ITS FIRST ARGUMENT,\r
+;AN IDENTIFIER, TO THE VALUE OF ITS SECOND ARGUMENT. ITS VALUE IS\r
+; ITS SECOND ARGUMENT.\r
+\r
+MFUNCTION SETG,SUBR\r
+ ENTRY 2\r
+ GETYP A,(AB) ;GET TYPE OF FIRST ARGUMENT\r
+ CAIE A,TATOM ;CHECK THAT IT IS AN ATOM\r
+ JRST NONATM ;IF NOT -- ERROR\r
+ MOVE B,1(AB) ;GET POINTER TO ATOM\r
+ PUSH TP,$TATOM\r
+ PUSH TP,B\r
+ MOVEI 0,(B)\r
+ CAIL 0,HIBOT ; PURE ATOM?\r
+ PUSHJ P,IMPURIFY ; YES IMPURIFY\r
+ PUSHJ P,IGLOC ;GET LOCATIVE TO VALUE\r
+ CAMN A,$TUNBOUND ;IF BOUND\r
+ PUSHJ P,BSETG ;IF NOT -- BIND IT\r
+ MOVE C,2(AB) ; GET PROPOSED VVAL\r
+ MOVE D,3(AB)\r
+ MOVSI A,TLOCD ; MAKE SURE MONCH WINS\r
+ PUSHJ P,MONCH0 ; WOULD YOU BELIEVE MONITORS!!!!\r
+ EXCH D,B ;SAVE PTR\r
+ MOVE A,C\r
+ HRRZ E,-2(D) ; POINT TO POSSIBLE GDECL (OR MAINIFEST)\r
+ JUMPE E,OKSETG ; NONE ,OK\r
+ CAIE E,-1 ; MANIFEST?\r
+ JRST SETGTY\r
+ GETYP 0,(D) ; IF UNBOUND, LET IT HAPPEN\r
+ SKIPN IGDECL\r
+ CAIN 0,TUNBOU\r
+ JRST OKSETG\r
+MANILO: GETYP C,(D)\r
+ GETYP 0,2(AB)\r
+ CAIN 0,(C)\r
+ CAME B,1(D)\r
+ JRST .+2\r
+ JRST OKSETG\r
+ PUSH TP,$TVEC\r
+ PUSH TP,D\r
+ MOVE B,MQUOTE REDEFINE\r
+ PUSHJ P,ILVAL ; SEE IF REDEFINE OK\r
+ GETYP A,A\r
+ CAIE A,TUNBOU\r
+ CAIN A,TFALSE\r
+ JRST .+2\r
+ JRST OKSTG\r
+ PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE ATTEMPT-TO-CHANGE-MANIFEST-VARIABLE\r
+ PUSH TP,$TATOM\r
+ PUSH TP,1(AB)\r
+ MOVEI A,2\r
+ JRST CALER\r
+\r
+SETGTY: PUSH TP,$TVEC\r
+ PUSH TP,D\r
+ MOVE C,A\r
+ MOVE D,B\r
+ GETYP A,(E)\r
+ MOVSI A,(A)\r
+ MOVE B,1(E)\r
+ JSP E,CHKAB\r
+ PUSHJ P,TMATCH\r
+ JRST TYPMI3\r
+\r
+OKSTG: MOVE D,(TP)\r
+ MOVE A,2(AB)\r
+ MOVE B,3(AB)\r
+\r
+OKSETG: MOVEM A,(D) ;DEPOSIT INTO THE \r
+ MOVEM B,1(D) ;INDICATED VALUE CELL\r
+ JRST FINIS\r
+\r
+TYPMI3: MOVE C,(TP)\r
+ HRRZ C,-2(C)\r
+ MOVE D,2(AB)\r
+ MOVE B,3(AB)\r
+ MOVE 0,(AB)\r
+ MOVE A,1(AB)\r
+ JRST TYPMIS\r
+\r
+BSETG: HRRZ A,GLOBASE+1(TVP)\r
+ HRRZ B,GLOBSP+1(TVP)\r
+ SUB B,A\r
+ CAIL B,6\r
+ JRST SETGIT\r
+ MOVEI B,0 ; MAKE SURE OF NO EMPTY SLOTS\r
+ PUSHJ P,IGLOC\r
+ CAMN A,$TUNBOU ; SKIP IF SLOT FOUND\r
+ JRST BSETG1\r
+ MOVE E,(TP) ; GET ATOM\r
+ MOVEM E,-1(B) ; CLOBBER ATOM SLOT\r
+ POPJ P,\r
+; BSETG1: PUSH TP,GLOBASE(TVP) ; MUST REALLY GROW STACK\r
+; PUSH TP,GLOBASE+1 (TVP)\r
+; PUSH TP,$TFIX\r
+; PUSH TP,[0]\r
+; PUSH TP,$TFIX\r
+; PUSH TP,[100]\r
+; MCALL 3,GROW\r
+BSETG1: PUSH P,0\r
+ PUSH P,C\r
+ MOVE C,GLOBASE+1(TVP)\r
+ HLRE B,C\r
+ SUB C,B\r
+ MOVE B,GVLINC ; GROW BY INDICATED GVAL SLOTS\r
+ DPB B,[001100,,(C)]\r
+; MOVEM A,GLOBASE(TVP)\r
+ MOVE C,[6,,4] ; INDICATOR FOR AGC\r
+ PUSHJ P,AGC\r
+ MOVE B,GLOBASE+1(TVP)\r
+ MOVE 0,GVLINC ; ADJUST GLOBAL SPBASE\r
+ ASH 0,6\r
+ SUB B,0\r
+ HRLZS 0\r
+ SUB B,0\r
+ MOVEM B,GLOBASE+1(TVP)\r
+; MOVEM B,GLOBASE+1(TVP)\r
+ POP P,0\r
+ POP P,C\r
+SETGIT:\r
+ MOVE B,GLOBSP+1(TVP)\r
+ SUB B,[4,,4]\r
+ MOVSI C,TGATOM\r
+ MOVEM C,(B)\r
+ MOVE C,(TP)\r
+ MOVEM C,1(B)\r
+ MOVEM B,GLOBSP+1(TVP)\r
+ ADD B,[2,,2]\r
+ MOVSI A,TLOCI\r
+ POPJ P,\r
+\r
+\r
+MFUNCTION DEFMAC,FSUBR\r
+\r
+ ENTRY 1\r
+\r
+ PUSH P,.\r
+ JRST DFNE2\r
+\r
+MFUNCTION DFNE,FSUBR,[DEFINE]\r
+\r
+ ENTRY 1\r
+\r
+ PUSH P,[0]\r
+DFNE2: GETYP A,(AB)\r
+ CAIE A,TLIST\r
+ JRST WRONGT\r
+ SKIPN B,1(AB) ; GET ATOM\r
+ JRST TFA\r
+ GETYP A,(B) ; MAKE SURE ATOM\r
+ MOVSI A,(A)\r
+ PUSH TP,A\r
+ PUSH TP,1(B)\r
+ JSP E,CHKARG\r
+ MCALL 1,EVAL ; EVAL IT TO AN ATOM\r
+ CAME A,$TATOM\r
+ JRST NONATM\r
+ PUSH TP,A ; SAVE TWO COPIES\r
+ PUSH TP,B\r
+ PUSHJ P,IGVAL ; SEE IF A VALUE EXISTS\r
+ CAMN A,$TUNBOU ; SKIP IF A WINNER\r
+ JRST .+3\r
+ PUSHJ P,ASKUSR ; CHECK WITH USER\r
+ JRST DFNE1\r
+ PUSH TP,$TATOM\r
+ PUSH TP,-1(TP)\r
+ MOVE B,1(AB)\r
+ HRRZ B,(B)\r
+ MOVSI A,TEXPR\r
+ SKIPN (P) ; SKIP IF MACRO\r
+ JRST DFNE3\r
+ MOVEI D,(B) ; READY TO CONS\r
+ MOVSI C,TEXPR\r
+ PUSHJ P,INCONS\r
+ MOVSI A,TMACRO\r
+DFNE3: PUSH TP,A\r
+ PUSH TP,B\r
+ MCALL 2,SETG\r
+DFNE1: POP TP,B ; RETURN ATOM\r
+ POP TP,A\r
+ JRST FINIS\r
+\r
+\r
+ASKUSR: MOVE B,MQUOTE REDEFINE\r
+ PUSHJ P,ILVAL ; SEE IF REDEFINE OK\r
+ GETYP A,A\r
+ CAIE A,TUNBOU\r
+ CAIN A,TFALSE\r
+ JRST ASKUS1\r
+ JRST ASKUS2\r
+ASKUS1: PUSH TP,$TATOM\r
+ PUSH TP,-1(TP)\r
+ PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE ALREADY-DEFINED-ERRET-NON-FALSE-TO-REDEFINE\r
+ MCALL 2,ERROR\r
+ GETYP 0,A\r
+ CAIE 0,TFALSE\r
+ASKUS2: AOS (P)\r
+ MOVE B,1(AB)\r
+ POPJ P,\r
+\f\r
+\r
+\r
+;SET CLOBBERS THE LOCAL VALUE OF THE IDENTIFIER GIVEN BY ITS\r
+;FIRST ARGUMENT TO THE SECOND ARG. ITS VALUE IS ITS SECOND ARGUMENT.\r
+\r
+MFUNCTION SET,SUBR\r
+ HLRE D,AB ; 2 TIMES # OF ARGS TO D\r
+ ASH D,-1 ; - # OF ARGS\r
+ ADDI D,2\r
+ JUMPG D,TFA ; NOT ENOUGH\r
+ MOVE B,PVP\r
+ MOVE C,SP\r
+ JUMPE D,SET1 ; NO ENVIRONMENT\r
+ AOJL D,TMA ; TOO MANY\r
+ GETYP A,4(AB) ; CHECK ARG IS A FRAME OR PROCESS\r
+ CAIE A,TFRAME\r
+ CAIN A,TENV\r
+ JRST SET2 ; WINNING ENVIRONMENT/FRAME\r
+ CAIN A,TACT\r
+ JRST SET2 ; TO MAKE PFISTER HAPPY\r
+ CAIE A,TPVP\r
+ JRST WTYP2\r
+ MOVE B,5(AB) ; GET PROCESS\r
+ MOVE C,SPSTO+1(B)\r
+ JRST SET1\r
+SET2: MOVEI B,4(AB) ; POINT TO FRAME\r
+ PUSHJ P,CHFRM ; CHECK IT OUT\r
+ MOVE B,5(AB) ; GET IT BACK\r
+ MOVE C,SPSAV(B) ; GET BINDING POINTER\r
+ HRRZ B,4(AB) ; POINT TO PROCESS\r
+ HLRZ A,(B) ; GET LENGTH\r
+ SUBI B,-1(A) ; POINT TO START THEREOF\r
+ HLL B,PVP ; GET -LNTRH, (ALL PROCESS VECS SAME LENGTH)\r
+SET1: PUSH TP,$TPVP ; SAVE PROCESS\r
+ PUSH TP,B\r
+ PUSH TP,$TSP ; SAVE PATH POINTER\r
+ PUSH TP,C\r
+ GETYP A,(AB) ;GET TYPE OF FIRST\r
+ CAIE A,TATOM ;ARGUMENT -- \r
+ JRST WTYP1 ;BETTER BE AN ATOM\r
+ MOVE B,1(AB) ;GET PTR TO IT\r
+ MOVEI 0,(B)\r
+ CAIL 0,HIBOT\r
+ PUSHJ P,IMPURIFY\r
+ MOVE C,(TP)\r
+ PUSHJ P,AILOC ;GET LOCATIVE TO VALUE\r
+GOTLOC: CAMN A,$TUNBOUND ;BOUND?\r
+ PUSHJ P, BSET ;BIND IT\r
+ SUB TP,[4,,4]\r
+ MOVE C,2(AB) ; GET NEW VAL\r
+ MOVE D,3(AB)\r
+ MOVSI A,TLOCD ; FOR MONCH\r
+ HRR A,2(B)\r
+ PUSHJ P,MONCH0 ; HURRAY FOR MONITORS!!!!!\r
+ MOVE E,B\r
+ HLRZ A,2(E) ; GET DECLS\r
+ JUMPE A,SET3 ; NONE, GO\r
+ PUSH TP,$TSP\r
+ PUSH TP,E\r
+ MOVE B,1(A)\r
+ HLLZ A,(A) ; GET PATTERN\r
+ PUSHJ P,TMATCH ; MATCH TMEM\r
+ JRST TYPMI2 ; LOSES\r
+ MOVE E,(TP)\r
+ SUB TP,[2,,2]\r
+ MOVE C,2(AB)\r
+ MOVE D,3(AB)\r
+SET3: MOVEM C,(E) ;CLOBBER IDENTIFIER\r
+ MOVEM D,1(E)\r
+ MOVE A,C\r
+ MOVE B,D\r
+ JRST FINIS\r
+BSET:\r
+ CAMN PVP,-2(TP) ; SKIP IF PROC DIFFERS\r
+ MOVEM C,-2(TP) ; ELSE USE RESULT FROM LOC SEARCH\r
+ MOVE B,-2(TP) ; GET PROCESS\r
+ HRRZ A,TPBASE+1(B) ;GET ACTUAL STACK BASE\r
+ HRRZ B,SPBASE+1(B) ;AND FIRST BINDING\r
+ SUB B,A ;ARE THERE 6\r
+ CAIL B,6 ;CELLS AVAILABLE?\r
+ JRST SETIT ;YES\r
+ MOVE C,(TP) ; GET POINTER BACK\r
+ MOVEI B,0 ; LOOK FOR EMPTY SLOT\r
+ PUSHJ P,AILOC\r
+ CAMN A,$TUNBOUND ; SKIP IF FOUND\r
+ JRST BSET1\r
+ MOVE E,1(AB) ; GET ATOM\r
+ MOVEM E,-1(B) ; AND STORE\r
+ JRST BSET2\r
+BSET1: MOVE B,-2(TP) ; GET PROCESS\r
+; PUSH TP,TPBASE(B) ;NO -- GROW THE TP\r
+; PUSH TP,TPBASE+1(B) ;AT THE BASE END\r
+; PUSH TP,$TFIX\r
+; PUSH TP,[0]\r
+; PUSH TP,$TFIX\r
+; PUSH TP,[100]\r
+; MCALL 3,GROW\r
+; MOVE C,-2(TP) ; GET PROCESS\r
+; MOVEM A,TPBASE(C) ;SAVE RESULT\r
+ PUSH P,0 ; MANUALLY GROW VECTOR\r
+ PUSH P,C\r
+ MOVE C,TPBASE+1(B)\r
+ HLRE B,C\r
+ SUB C,B\r
+ MOVEI C,1(C)\r
+ CAME C,TPGROW\r
+ ADDI C,PDLBUF\r
+ MOVE D,LVLINC\r
+ DPB D,[001100,,-1(C)]\r
+ MOVE C,[5,,3] ; SET UP INDICATORS FOR AGC\r
+ PUSHJ P,AGC\r
+ MOVE B,TPBASE+1(PVP) ; MODIFY POINTER\r
+ MOVE 0,LVLINC ; ADJUST SPBASE POINTER\r
+ ASH 0,6\r
+ SUB B,0\r
+ HRLZS 0\r
+ SUB B,0\r
+ MOVEM B,TPBASE+1(PVP)\r
+ POP P,C\r
+ POP P,0\r
+; MOVEM B,TPBASE+1(C)\r
+SETIT: MOVE C,-2(TP) ; GET PROCESS\r
+ MOVE B,SPBASE+1(C)\r
+ MOVEI A,-6(B) ;MAKE UP BINDING\r
+ HRRM A,(B) ;LINK PREVIOUS BIND BLOCK\r
+ MOVSI A,TBIND\r
+ MOVEM A,-6(B)\r
+ MOVE A,1(AB)\r
+ MOVEM A,-5(B)\r
+ SUB B,[6,,6]\r
+ MOVEM B,SPBASE+1(C)\r
+ ADD B,[2,,2]\r
+BSET2: MOVE C,-2(TP) ; GET PROC\r
+ MOVSI A,TLOCI\r
+ HRR A,BINDID+1(C)\r
+ HLRZ D,OTBSAV(TB) ; TIME IT\r
+ MOVEM D,2(B) ; AND FIX IT\r
+ POPJ P,\r
+\r
+; HERE TO ELABORATE ON TYPE MISMATCH\r
+\r
+TYPMI2: MOVE C,(TP) ; FIND DECLS\r
+ HLRZ C,2(C)\r
+ MOVE D,2(AB)\r
+ MOVE B,3(AB)\r
+ MOVE 0,(AB) ; GET ATOM\r
+ MOVE A,1(AB)\r
+ JRST TYPMIS\r
+\r
+\f\r
+\r
+MFUNCTION NOT,SUBR\r
+ ENTRY 1\r
+ GETYP A,(AB) ; GET TYPE\r
+ CAIE A,TFALSE ;IS IT FALSE?\r
+ JRST IFALSE ;NO -- RETURN FALSE\r
+\r
+TRUTH:\r
+ MOVSI A,TATOM ;RETURN T (VERITAS) \r
+ MOVE B,MQUOTE T\r
+ JRST FINIS\r
+\r
+MFUNCTION OR,FSUBR\r
+\r
+ PUSH P,[0]\r
+ JRST ANDOR\r
+\r
+MFUNCTION ANDA,FSUBR,AND\r
+\r
+ PUSH P,[1]\r
+ANDOR: ENTRY 1\r
+ GETYP A,(AB)\r
+ CAIE A,TLIST\r
+ JRST WRONGT ;IF ARG DOESN'T CHECK OUT\r
+ MOVE E,(P)\r
+ SKIPN C,1(AB) ;IF NIL\r
+ JRST TF(E) ;RETURN TRUTH\r
+ PUSH TP,$TLIST ;CREATE UNNAMED TEMP\r
+ PUSH TP,C\r
+ANDLP:\r
+ MOVE E,(P)\r
+ JUMPE C,TFI(E) ;ANY MORE ARGS?\r
+ MOVEM C,1(TB) ;STORE CRUFT\r
+ GETYP A,(C)\r
+ MOVSI A,(A)\r
+ PUSH TP,A\r
+ PUSH TP,1(C) ;ARGUMENT\r
+ JSP E,CHKARG\r
+ MCALL 1,EVAL\r
+ GETYP 0,A\r
+ MOVE E,(P)\r
+ XCT TFSKP(E)\r
+ JRST FINIS ;IF FALSE -- RETURN\r
+ HRRZ C,@1(TB) ;GET CDR OF ARGLIST\r
+ JRST ANDLP\r
+\r
+TF: JRST IFALSE\r
+ JRST TRUTH\r
+\r
+TFI: JRST IFALS1\r
+ JRST FINIS\r
+\r
+TFSKP: CAIE 0,TFALSE\r
+ CAIN 0,TFALSE\r
+\r
+MFUNCTION FUNCTION,FSUBR\r
+\r
+ ENTRY 1\r
+\r
+ MOVSI A,TEXPR\r
+ MOVE B,1(AB)\r
+ JRST FINIS\r
+\r
+\f\r
+\r
+MFUNCTION CLOSURE,SUBR\r
+ ENTRY\r
+ SKIPL A,AB ;ANY ARGS\r
+ JRST TFA ;NO -- LOSE\r
+ ADD A,[2,,2] ;POINT AT IDS\r
+ PUSH TP,$TAB\r
+ PUSH TP,A\r
+ PUSH P,[0] ;MAKE COUNTER\r
+\r
+CLOLP: SKIPL A,1(TB) ;ANY MORE IDS?\r
+ JRST CLODON ;NO -- LOSE\r
+ PUSH TP,(A) ;SAVE ID\r
+ PUSH TP,1(A)\r
+ PUSH TP,(A) ;GET ITS VALUE\r
+ PUSH TP,1(A)\r
+ ADD A,[2,,2] ;BUMP POINTER\r
+ MOVEM A,1(TB)\r
+ AOS (P)\r
+ MCALL 1,VALUE\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ MCALL 2,LIST ;MAKE PAIR\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ JRST CLOLP\r
+\r
+CLODON: POP P,A\r
+ ACALL A,LIST ;MAKE UP LIST\r
+ PUSH TP,(AB) ;GET FUNCTION\r
+ PUSH TP,1(AB)\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ MCALL 2,LIST ;MAKE LIST\r
+ MOVSI A,TFUNARG\r
+ JRST FINIS\r
+\r
+\f\r
+\r
+;ERROR COMMENTS FOR EVAL\r
+TUPTFA: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE TOO-FEW-ARGS-FOR-ITUPLE\r
+ JRST CALER1\r
+\r
+TUPTMA: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE TOO-MANY-ARGS-TO-ITUPLE\r
+ JRST CALER1\r
+\r
+BADNUM: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE NEGATIVE-ARG-TO-ITUPLE\r
+ JRST CALER1\r
+\r
+WTY1TP: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE FIRST-ARG-TO-ITUPLE-NOT-FIX\r
+ JRST CALER1\r
+\r
+UNBOU: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE UNBOUND-VARIABLE\r
+ JRST ER1ARG\r
+\r
+UNAS: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE UNASSIGNED-VARIABLE\r
+ JRST ER1ARG\r
+\r
+BADENV:\r
+ PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE BAD-ENVIRONMENT\r
+ JRST CALER1\r
+\r
+FUNERR:\r
+ PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE BAD-FUNARG\r
+ JRST CALER1\r
+\r
+\r
+MPD.0:\r
+MPD.1:\r
+MPD.2:\r
+MPD.3:\r
+MPD.4:\r
+MPD.5:\r
+MPD.6:\r
+MPD.7:\r
+MPD.8:\r
+MPD.9:\r
+MPD.10:\r
+MPD.11:\r
+MPD.12:\r
+MPD.13:\r
+MPD: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE MEANINGLESS-PARAMETER-DECLARATION\r
+ JRST CALER1\r
+\r
+NOBODY: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE HAS-EMPTY-BODY\r
+ JRST CALER1\r
+\r
+BADCLS: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE BAD-CLAUSE\r
+ JRST CALER1\r
+\r
+NXTAG: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE NON-EXISTENT-TAG\r
+ JRST CALER1\r
+\r
+NXPRG: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE NOT-IN-PROG\r
+ JRST CALER1\r
+\r
+NAPTL:\r
+NAPT: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE NON-APPLICABLE-TYPE\r
+ JRST CALER1\r
+\r
+NONEVT: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE NON-EVALUATEABLE-TYPE\r
+ JRST CALER1\r
+\r
+\r
+NONATM: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE NON-ATOMIC-ARGUMENT\r
+ JRST CALER1\r
+\r
+\r
+ILLFRA: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE FRAME-NO-LONGER-EXISTS\r
+ JRST CALER1\r
+\r
+ILLSEG: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE ILLEGAL-SEGMENT\r
+ JRST CALER1\r
+\r
+BADMAC: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE BAD-USE-OF-MACRO\r
+ JRST CALER1\r
+\r
+BADFSB: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE APPLY-OR-STACKFORM-OF-FSUBR\r
+ JRST CALER1\r
+\r
+\r
+ER1ARG: PUSH TP,(AB)\r
+ PUSH TP,1(AB)\r
+ MOVEI A,2\r
+ JRST CALER\r
+\r
+END\r
+\f\f\f\f\fTITLE OPEN - CHANNEL OPENER FOR MUDDLE\r
+\r
+RELOCATABLE\r
+\r
+;C. REEVE MARCH 1973\r
+\r
+.INSRT MUDDLE >\r
+\r
+SYSQ\r
+\r
+IFE ITS,[\r
+IF1, .INSRT MUDSYS;STENEX >\r
+]\r
+;THIS PROGRAM HAS ENTRIES: FOPEN, FCLOSE, RENAME, READB, PRINTB, FILECOPY, READSTRING,\r
+; PRINTSTRING, NETSTATE, NETACC, NETS, AND ACCESS.\r
+\r
+;THESE SUBROUTINES HANDLE I/O STREAMS FOR THE MUDDLE SYSTEM.\r
+\r
+; FOPEN - OPENS A FILE FOR EITHER READING OR WRITING. IT TAKES\r
+; FIVE OPTINAL ARGUMENTS AS FOLLOWS:\r
+\r
+; FOPEN (<DIR>,<FILE NAME1>,<FILE NAME2>,<DEVICE>,<SYSTEM NAME>)\r
+;\r
+; <DIR> - DIRECTION EITHER READ (INPUT) OR PRINT (OUPUT). DEFAULT IS READ\r
+\r
+; <FILE NAME1> - FIRST FILE NAME. DEFAULT INPUT OR OUTPUT.\r
+\r
+; <FILE NAME2> - SECOND FILE NAME. DEFAULT MUDDLE.\r
+\r
+; <DEVICE> - DEVICE FROM WHICH TO OPEN. DEFAULT IS DSK.\r
+\r
+; <SNAME> - SYSTEM (DIRECTORY) NAME. DEFAULT UNAME.\r
+\r
+; FOPEN RETURNS AN OBJECT OF TYPE CHANNEL IF IT SUCCEEDS OTHERWISE NIL\r
+\r
+\r
+; FCLOSE - CLOSES A FILE. TAKES A CHANNEL OBJECT AS ITS ARGUMENT. IT ALSO TAKES\r
+; ACCESS - DOES A .ACCESS ON A CHARACTER BASIS FOR CHARACTER FILES\r
+\r
+\r
+; A CHANNEL OBJECT IS A VECTOR CONTAINIG THE FOLLOWING INFORMATION\r
+\r
+; CHANNO ;ITS I/O CHANNEL NUMBER. 0 MEANS NOT A REAL CHANNEL.\r
+; DIRECT ;DIRECTION (EITHER READ OR PRINT)\r
+; NAME1 ;FIRST NAME OF FILE AS OPENED.\r
+; NAME2 ;SECOND NAME OF FILE\r
+; DEVICE ;DEVICE UPON WHICH THE CHANNEL IS OPEN\r
+; SNAME ;DIRECTORY NAME\r
+; RNAME1 ;REAL FIRST NAME (AS RETURNED BY READING CHANNEL STATUS)\r
+; RNAME2 ;REAL SECOND NAME\r
+; RDEVIC ;REAL DEVICE\r
+; RSNAME ;SYSTEM OR DIRECTORY NAME\r
+; STATUS ;VARIOUS STATUS BITS\r
+; IOINS ;INSTRUCTION EXECUTED TO INPUT OR OUTPUT ONE CHARACTER\r
+; ACCESS ;ACCESS POINTER FOR RAND ACCESS (OR USED FOR DISPLAY INFO)\r
+; RADX ;RADIX FOR CHANNELS NUMBER CONVERSION\r
+\r
+; *** THE FOLLOWING FIELDS FOR OUTPUT ONLY ***\r
+; LINLN ;LENGTH OF A LINE IN CHARACTERS FOR THIS DEVICE\r
+; CHRPOS ;CURRENT POSITION ON CURRENT LINE\r
+; PAGLN ;LENGTH OF A PAGE\r
+; LINPOS ;CURRENT LINE BEING WRITTEN ON\r
+\r
+; *** THE FOLLOWING FILEDS FOR INPUT ONLY ***\r
+; EOFCND ;GETS EVALUATED ON EOF\r
+; LSTCH ;BACKUP CHARACTER\r
+; WAITNS ;FOR TTY INPUT, BECOMES A .SLEEP WHEN WAITING\r
+; EXBUFR ;FOR TTY INPUT, CONTAINS A WAITING BUFFER LIST\r
+; BUFSTR ;A CHARACTER STRING USED AS BUFFER FOR NON-TTY DEVICES\r
+\r
+; THIS DEFINES THE LENGTH OF THE NON-TTY BUFFER\r
+BUFLNT==100\r
+\r
+;THIS DEFINES BLOCK MODE BIT FOR OPENING\r
+BLOCKM==2 ;DEFINED IN THE LEFT HALF\r
+IMAGEM==4\r
+\r
+\f\r
+;THIS IRP DEFINES THE FIELDS AT ASSEMBLY TIME\r
+\r
+ CHANLNT==4 ;INITIAL CHANNEL LENGTH\r
+\r
+; BUILD A PROTOTYPE CHANNEL AND DEFINE FILEDS\r
+BUFRIN==-1 ;SPECIAL HACK SO LOSERS WON'T SEE TTY BUFFER\r
+SCRPTO==-3 ;SPECIAL HACK FOR SCRIPT CHANNELS\r
+PROCHN:\r
+\r
+IRP A,,[[CHANNO,FIX],[DIRECT,CHSTR]\r
+[NAME1,CHSTR],[NAME2,CHSTR],[DEVICE,CHSTR],[SNAME,CHSTR]\r
+[RNAME1,CHSTR],[RNAME2,CHSTR],[RDEVIC,CHSTR],[RSNAME,CHSTR]\r
+[STATUS,FIX],[IOINS,FIX],[LINLN,FIX],[CHRPOS,FIX],[PAGLN,FIX],[LINPOS,FIX]\r
+[ACCESS,FIX],[RADX,FIX],[BUFSTR,CHSTR]]\r
+\r
+ IRP B,C,[A]\r
+ B==CHANLNT-3\r
+ T!C,,0\r
+ 0\r
+ .ISTOP\r
+ TERMIN\r
+ CHANLNT==CHANLNT+2\r
+TERMIN\r
+\r
+\r
+; EQUIVALANCES FOR CHANNELS\r
+\r
+EOFCND==LINLN\r
+LSTCH==CHRPOS\r
+WAITNS==PAGLN\r
+EXBUFR==LINPOS\r
+DISINF==BUFSTR ;DISPLAY INFO\r
+INTFCN==BUFSTR ;FUNCTION (OR SUBR, OR RSUBR) TO BE APPLIED FOR INTERNAL CHNLS\r
+\r
+\r
+;DEFINE VARIABLES ASSOCIATED WITH TTY BUFFERS\r
+\r
+IRP A,,[IOIN2,ECHO,CHRCNT,ERASCH,KILLCH,BRKCH,ESCAP,SYSCHR,BRFCHR,BRFCH2,BYTPTR]\r
+A==.IRPCNT\r
+TERMIN\r
+\r
+EXTBFR==BYTPTR+1+<100./5> ;LENGTH OF ADD'L BUFFER\r
+\r
+\r
+\r
+\r
+.GLOBAL IPNAME,MOPEN,MCLOSE,MIOT,ILOOKU,6TOCHS,ICLOS,OCLOS,RGPARS,RGPRS\r
+.GLOBAL OPNCHN,CHMAK,READC,TYO,SYSCHR,BRFCHR,LSTCH,BRFCH2,EXTBFR\r
+.GLOBAL CHRWRD,STRTO6,TTYBLK,WAITNS,EXBUFR,TTICHN,TTOCHN,GETCHR\r
+.GLOBAL CHANNO,STATUS,LINPOS,PAGLN,CHRPOS,LINLN,IOINS,ACCESS\r
+.GLOBAL DIRECT,DISINF,RADX,EOFCND,BUFSTR,MODE1,MODE2,GCHACK,GMTYO\r
+.GLOBAL T.CHAN,NAME1,BFCLOS,DOIOTI,DOIOTO,DOACCS,NOTTY,BYTDOP,TNXIN\r
+.GLOBAL DISOPN,DISROP,DISCLS,DCHAR,DISLNL,DISPGL,INSTAT,MTYO\r
+.GLOBAL ECHO,ERASCH,KILLCH,BRKCH,BYTPTR,SYSCHR,CHRCNT,ESCAP,N.CHNS\r
+.GLOBAL REOPN,QUITTE,CHNL0,CHNL1,BUFRIN,IOIN2,IFALSE,GFALS,IDVAL\r
+.GLOBAL BADCHN,WRONGD,CHNCLS,GSNAME,GIBLOK,APLQ,NAPT,ICONS,INCONS,IBLOCK,IDVAL1\r
+.GLOBAL GRB,GWB,R1CHAR,W1CHAR,BFCLS1,TTYOP2,MPOPJ,COMPER,R1C,W1C,WXCT,RXCT\r
+.GLOBAL TMTNXS,TNXSTR,RDEVIC\r
+\r
+\f\r
+.VECT.==40000\r
+\r
+; PAIR MOVING MACRO\r
+\r
+DEFINE PMOVEM A,B\r
+ MOVE 0,A\r
+ MOVEM 0,B\r
+ MOVE 0,A+1\r
+ MOVEM 0,B+1\r
+ TERMIN\r
+\r
+; DEFINITIONS OF THE OFFSETS INTO THE TP STACK FOR OPEN\r
+\r
+T.SPDL==0 ; SAVES P STACK BASE\r
+T.DIR==2 ; CONTAINS DIRECTION AND MODE\r
+T.NM1==4 ; NAME 1 OF FILE\r
+T.NM2==6 ; NAME 2 OF FILE\r
+T.DEV==10 ; DEVICE NAME\r
+T.SNM==12 ; SNAME\r
+T.XT==14 ; EXTRA CRUFT IF NECESSARY\r
+T.CHAN==16 ; CHANNEL AS GENERATED\r
+\r
+; OFFSETS FROM PSTACK BASE (USED FOR OPENS, .RCHST AND .FDELES)\r
+\r
+S.DIR==0 ; CODE FOR DIRECTION 0-IN, 1-OUT, 2-BIN, 3-BOUT,4-DISPLAY\r
+IFN ITS,[\r
+S.DEV==1 ; SIXBIT DEVICE RIGHT JUSTIFIED\r
+S.NM1==2 ; SIXBIT NAME1\r
+S.NM2==3 ; SIXBIT NAME2\r
+S.SNM==4 ; SIXBIT SNAME\r
+S.X1==5 ; TEMPS\r
+S.X2==6\r
+S.X3==7\r
+]\r
+\r
+IFE ITS,[\r
+S.DEV==1\r
+S.X1==2\r
+S.X2==3\r
+S.X3==4\r
+]\r
+\r
+\r
+; FLAGS SPECIFYING STATE OF THE WORLD AT VARIOUS TIMES\r
+\r
+NOSTOR==400000 ; ON MEANS DONT BUILD NEW STRINGS\r
+MSTNET==200000 ; ON MEANS ONLY THE "NET" DEVICE CAN WIN\r
+SNSET==100000 ; FLAG, SNAME SUPPLIED\r
+DVSET==040000 ; FLAG, DEV SUPPLIED\r
+N2SET==020000 ; FLAG, NAME2 SET\r
+N1SET==010000 ; FLAG, NAME1 SET\r
+\r
+RMT [EXPUNGE N1SET,N2SET,DVSET,SNSET,MSTNET,NOSTOR\r
+]\r
+\r
+\r
+; TABLE OF LEGAL MODES\r
+\r
+MODES: IRP A,,[READ,PRINT,READB,PRINTB,DISPLAY]\r
+ SIXBIT /A/\r
+ TERMIN\r
+NMODES==.-MODES\r
+\r
+; TABLE OF KNOWN DEVICES AND A POINTER TO THEIR OPENERS\r
+\r
+IFN ITS,[\r
+\r
+DEVS: IRP A,,[DSK,TPL,SYS,COM,TTY,USR,STY,[ST ],NET,DIS,E&S,INT,PTP,PTR\r
+[P ],[DK ],[UT ],[T ],NUL,[AI ]\r
+[ML ],[DM ],[AR ],ARC]B,,[ODSK,ODSK,ODSK,ODSK,OTTY,OUSR,OSTY,OSTY,ONET,ODIS,ODIS\r
+OINT,OPTP,OPTP,ODSK,ODSK,OUTN,OTTY,ONUL,ODSK,ODSK,ODSK,ODSK,ODSK]\r
+ B,,(SIXBIT /A/)\r
+ TERMIN\r
+]\r
+IFE ITS,[\r
+DEVS: IRP A,,[DSK,TTY,INT,NET]B,,[ODSK,OTTY,OINT,ONET]\r
+ B,,(SIXBIT /A/)\r
+ TERMIN\r
+]\r
+NDEVS==.-DEVS\r
+\r
+\r
+\f\r
+;SUBROUTINE TO DO OPENING BEGINS HERE\r
+\r
+MFUNCTION NFOPEN,SUBR,[OPEN-NR]\r
+\r
+ JRST FOPEN1\r
+\r
+MFUNCTION FOPEN,SUBR,[OPEN]\r
+\r
+FOPEN1: ENTRY\r
+ PUSHJ P,MAKCHN ;MAKE THE CHANNEL\r
+ PUSHJ P,OPNCH ;NOW OPEN IT\r
+ JRST FINIS\r
+\r
+; SUBR TO JUST CREATE A CHANNEL\r
+\r
+MFUNCTION CHANNEL,SUBR\r
+\r
+ ENTRY\r
+ PUSHJ P,MAKCHN\r
+ MOVSI A,TCHAN\r
+ JRST FINIS\r
+\r
+\r
+\f\r
+\r
+; THIS ROUTINE PARSES ARGUMENTS TO FOPEN ETC. AND BUILDS A CHANNEL BUT DOESN'T OPEN IT\r
+\r
+MAKCHN: PUSH TP,$TPDL\r
+ PUSH TP,P ; POINT AT CURRENT STACK BASE\r
+ PUSH TP,$TCHSTR\r
+ PUSH TP,CHQUOTE READ\r
+ MOVEI E,10 ; SLOTS OF TP NEEDED\r
+ PUSH TP,[0]\r
+ SOJG E,.-1\r
+ MOVEI E,0\r
+ EXCH E,(P) ; GET RET ADDR IN E\r
+IFE ITS, PUSH P,[0]\r
+IRP ATM,,[DEV,NM1,NM2,SNM]MDF,,[DSK,INPUT,>,[ ]]TMDF,,[DSK,INPUT,MUD,[ ]]\r
+ MOVE B,IMQUOTE ATM\r
+IFN ITS, PUSH P,E\r
+ PUSHJ P,IDVAL1\r
+ GETYP 0,A\r
+ CAIN 0,TCHSTR\r
+ JRST MAK!ATM\r
+\r
+ MOVE A,$TCHSTR\r
+IFN ITS, MOVE B,CHQUOTE MDF\r
+IFE ITS, MOVE B,CHQUOTE TMDF\r
+MAK!ATM:\r
+ MOVEM A,T.!ATM(TB)\r
+ MOVEM B,T.!ATM+1(TB)\r
+IFN ITS,[\r
+ POP P,E\r
+ PUSHJ P,STRTO6 ; RESULT LEFT ON P STACK AS DESIRED\r
+]\r
+ TERMIN\r
+ PUSH TP,[0] ; PUSH SLOTS\r
+ PUSH TP,[0]\r
+\r
+ PUSH P,[0] ; EXT SLOTS\r
+ PUSH P,[0]\r
+ PUSH P,[0]\r
+ PUSH P,E ; PUSH RETURN ADDRESS\r
+ MOVEI A,0\r
+\r
+ JUMPGE AB,MAKCH0 ; NO ARGS, ALREADY DONE\r
+ GETYP 0,(AB) ; 1ST ARG MUST BE A STRING\r
+ CAIE 0,TCHSTR\r
+ JRST WTYP1\r
+ MOVE A,(AB) ; GET ARG\r
+ MOVE B,1(AB)\r
+ PUSHJ P,CHMODE ; CHECK OUT OPEN MODE\r
+\r
+ PMOVEM (AB),T.DIR(TB) ; SAVE MODE NAME IN TEMPS\r
+ ADD AB,[2,,2] ; BUMP PAST DIRECTION\r
+ MOVEI A,0\r
+ JUMPGE AB,MAKCH0 ; CHECK NAME1 BASED ON JUST MODE\r
+\r
+ MOVEI 0,0 ; FLAGS PRESET\r
+ PUSHJ P,RGPARS ; PARSE THE STRING(S)\r
+ JRST TMA\r
+\r
+; ARGUMENTS PARSED, DO FINAL CHECKS AND BUILD CHANNEL\r
+\r
+MAKCH0:\r
+IFN ITS,[\r
+ MOVE C,T.SPDL+1(TB)\r
+ HLRZS D,S.DEV(C) ; GET DEV\r
+]\r
+IFE ITS,[\r
+ MOVE A,T.DEV(TB)\r
+ MOVE B,T.DEV+1(TB)\r
+ PUSHJ P,STRTO6\r
+ POP P,D\r
+ HLRZS D\r
+ MOVE C,T.SPDL+1(TB)\r
+ MOVEM D,S.DEV(C)\r
+]\r
+ CAIE D,(SIXBIT /INT/); INTERNAL?\r
+ JRST CHNET ; NO, MAYBE NET\r
+ SKIPN T.XT+1(TB) ; WAS FCN SUPPLIED?\r
+ JRST TFA\r
+\r
+; FALLS TROUGH IF SKIP\r
+\r
+\f\r
+\r
+; NOW BUILD THE CHANNEL\r
+\r
+ARGSOK: MOVEI A,CHANLNT ; GET LENGTH\r
+ PUSHJ P,GIBLOK ; GET A BLOCK OF STUFF\r
+ ADD B,[4,,4] ; HIDE THE TTY BUFFER SLOT\r
+ PUSH TP,$TCHAN\r
+ PUSH TP,B\r
+ HRLI C,PROCHN ; POINT TO PROTOTYPE\r
+ HRRI C,(B) ; AND NEW ONE\r
+ BLT C,CHANLN-5(B) ; CLOBBER\r
+ MOVSI C,TLIST ; TO GIVE HIM A CLEAN LIST OF SCRIPT CHANS\r
+ MOVEM C,SCRPTO-1(B)\r
+\r
+; NOW BLT IN STUFF FROM THE STACK\r
+\r
+ MOVSI C,T.DIR(TB) ; DIRECTION\r
+ HRRI C,DIRECT-1(B)\r
+ BLT C,SNAME(B)\r
+ MOVEI C,RNAME1-1(B) ; NOW "REAL" SLOTS\r
+ HRLI C,T.NM1(TB)\r
+ BLT C,RSNAME(B)\r
+ POPJ P,\r
+\r
+; HERE TO VALIDIFY ARGUMENTS FOR A NET OPEN\r
+\r
+CHNET: CAIE D,(SIXBIT /NET/) ; IS IT NET\r
+IFN ITS, JRST MAKCH1\r
+IFE ITS,[\r
+ JRST ARGSOK\r
+]\r
+ MOVSI D,TFIX ; FOR TYPES\r
+ MOVEI B,T.NM1(TB) ; MAKE SURE ALL ARE FIXED\r
+ PUSHJ P,CHFIX\r
+ MOVEI B,T.NM2(TB)\r
+ PUSHJ P,CHFIX\r
+ MOVEI B,T.SNM(TB)\r
+ LSH A,-1 ; SKIP DEV FLAG\r
+ PUSHJ P,CHFIX\r
+ JRST ARGSOK\r
+\r
+MAKCH1: TRNN A,MSTNET ; CANT HAVE SEEN A FIX\r
+ JRST ARGSOK\r
+ JRST WRONGT\r
+\r
+IFN ITS,[\r
+CHFIX: TRNE A,N1SET ; SKIP IF NOT SPECIFIED\r
+ JRST CHFIX1\r
+]\r
+ SETOM 1(B) ; SET TO -1\r
+ SETOM S.NM1(C)\r
+ MOVEM D,(B) ; CORRECT TYPE\r
+IFE ITS,CHFIX:\r
+ GETYP 0,(B)\r
+ CAIE 0,TFIX\r
+ JRST PARSQ\r
+CHFIX1: ADDI C,1 ; POINT TO NEXT FIELD\r
+ LSH A,-1 ; AND NEXT FLAG\r
+ POPJ P,\r
+PARSQ: CAIE 0,TCHSTR\r
+ JRST WRONGT\r
+IFE ITS, POPJ P,\r
+IFN ITS,[\r
+ PUSH P,A\r
+ PUSH P,C\r
+ PUSH TP,(B)\r
+ PUSH TP,1(B)\r
+ SUBI B,(TB)\r
+ PUSH P,B\r
+ MCALL 1,PARSE\r
+ GETYP 0,A\r
+ CAIE 0,TFIX\r
+ JRST WRONGT\r
+ POP P,C\r
+ ADDI C,(TB)\r
+ MOVEM A,(C)\r
+ MOVEM B,1(C)\r
+ POP P,C\r
+ POP P,A\r
+ POPJ P,\r
+]\r
+\f\r
+\r
+; SUBROUTINE TO CHECK VALIDITY OF MODE AND SAVE A CODE\r
+\r
+CHMODE: PUSHJ P,CHMOD ; DO IT\r
+ MOVE C,T.SPDL+1(TB)\r
+ HRRZM A,S.DIR(C)\r
+ POPJ P,\r
+\r
+CHMOD: PUSHJ P,STRTO6 ; TO SIXBIT\r
+ POP P,B ; VALUE ENDSUP ON STACK, RESTORE IT\r
+\r
+ CAME B,[SIXBIT /PRINTO/] ; KLUDGE TO MAKE PRINTO AS PRINTB\r
+ JRST .+3\r
+ MOVEI A,3 ; CODE FOR PRINTB\r
+ POPJ P,\r
+\r
+ MOVSI A,-NMODES ; SCAN TO SEE IF LEGAL MODE\r
+ CAME B,MODES(A)\r
+ AOBJN A,.-1\r
+ JUMPGE A,WRONGD ; ILLEGAL MODE NAME\r
+ POPJ P,\r
+\f\r
+IFN ITS,[\r
+; RGPARS -- PARSE THE STRINGS COMPRISING FILE NAMES INTO STANDARD ITS GOODIES\r
+\r
+RGPRS: MOVEI 0,NOSTOR ; DONT STORE STRINGS IF ENTER HERE\r
+\r
+RGPARS: HRLM 0,(P) ; LH IS FLAGS FOR THIS PROG\r
+ MOVSI E,-4 ; FIELDS TO FILL\r
+\r
+RPARGL: GETYP 0,(AB) ; GET TYPE\r
+ CAIE 0,TCHSTR ; STRING?\r
+ JRST ARGCLB ; NO, JUST CLOBBER IT IN RAW\r
+ JUMPGE E,CPOPJ ; DON'T DO ANY MORE\r
+ PUSH TP,(AB) ; GET AN ARG\r
+ PUSH TP,1(AB)\r
+\r
+FPARS: PUSH TP,-1(TP) ; ANOTHER COPY\r
+ PUSH TP,-1(TP)\r
+ PUSHJ P,FLSSP ; NO LEADING SPACES\r
+ MOVEI A,0 ; WILL HOLD SIXBIT\r
+ MOVEI B,6 ; CHARS PER 6BIT WORD\r
+ MOVE C,[440600,,A] ; BYTE POINTER INTO A\r
+\r
+FPARSL: HRRZ 0,-1(TP) ; GET COUNT\r
+ JUMPE 0,PARSD ; DONE\r
+ SOS -1(TP) ; COUNT\r
+ ILDB 0,(TP) ; CHAR TO 0\r
+\r
+ CAIE 0,"\11 ; FILE NAME QUOTE?\r
+ JRST NOCNTQ\r
+ HRRZ 0,-1(TP)\r
+ JUMPE 0,PARSD\r
+ SOS -1(TP)\r
+ ILDB 0,(TP) ; USE THIS\r
+ JRST GOTCNQ\r
+\r
+NOCNTQ: CAIG 0,40 ; SPACE?\r
+ JRST NDFLD ; YES, TERMINATE THIS FIELD\r
+ CAIN 0,": ; DEVICE ENDED?\r
+ JRST GOTDEV\r
+ CAIN 0,"; ; SNAME ENDED\r
+ JRST GOTSNM\r
+\r
+GOTCNQ: PUSHJ P,A0TO6 ; CONVERT TO 6BIT AND CHECK\r
+\r
+ JUMPE B,FPARSL ; IGNORE IF AREADY HAVE 6\r
+ IDPB 0,C\r
+ SOJA B,FPARSL\r
+\r
+; HERE IF SPACE ENCOUNTERED\r
+\r
+NDFLD: MOVEI D,(E) ; COPY GOODIE\r
+ PUSHJ P,FLSSP ; FLUSH REDUNDANT SPACES\r
+ JUMPE 0,PARSD ; NO CHARS LEFT\r
+\r
+NFL0: PUSH P,A ; SAVE SIXBIT WORD\r
+ PUSHJ P,6TOCHS ; CONVERT TO STRING\r
+ HRRZ 0,-1(TP) ; RESTORE CHAR COUNT\r
+\r
+NFL2: MOVEI C,(D) ; COPY REL PNTR\r
+ SKIPGE -1(P) ; SKIP IF STRINGS TO BE STORED\r
+ JRST NFL3\r
+ ASH D,1 ; TIMES 2\r
+ ADDI D,T.NM1(TB)\r
+ MOVEM A,(D) ; STORE\r
+ MOVEM B,1(D)\r
+NFL3: MOVSI A,N1SET ; FLAG IT\r
+ LSH A,(C)\r
+ IORM A,-1(P) ; AND CLOBBER\r
+ MOVE D,T.SPDL+1(TB) ; GET P BASE\r
+ POP P,@SIXTBL(C) ; AND STORE SIXBIT OF IT\r
+\r
+ POP TP,-2(TP) ; MAKE NEW STRING POINTER\r
+ POP TP,-2(TP)\r
+ JUMPE 0,.+3 ; SKIP IF NO MORE CHARS\r
+ AOBJN E,FPARS ; MORE TO PARSE?\r
+CPOPJ: POPJ P, ; RETURN, ALL DONE\r
+\r
+ SUB TP,[2,,2] ; FLUSH OLD STRING\r
+ ADD E,[1,,1]\r
+ ADD AB,[2,,2] ; BUMP ARG\r
+ JUMPL AB,RPARGL ; AND GO ON\r
+CPOPJ1: AOS A,(P) ; PREPARE TO WIN\r
+ HLRZS A\r
+ POPJ P,\r
+\r
+\f\r
+\r
+; HERE IF STRING HAS ENDED\r
+\r
+PARSD: PUSH P,A ; SAVE 6 BIT\r
+ MOVE A,-3(TP) ; CAN USE ARG STRING\r
+ MOVE B,-2(TP)\r
+ MOVEI D,(E)\r
+ JRST NFL2 ; AND CONTINUE\r
+\r
+; HERE IF JUST READ DEV\r
+\r
+GOTDEV: MOVEI D,2 ; CODE FOR DEVICE\r
+ JRST GOTFLD ; GOT A FIELD\r
+\r
+; HERE IF JUST READ SNAME\r
+\r
+GOTSNM: MOVEI D,3\r
+GOTFLD: PUSHJ P,FLSSP\r
+ SOJA E,NFL0\r
+\r
+\r
+; HERE FOR NON STRING ARG ENCOUNTERED\r
+\r
+ARGCLB: SKIPGE (P) ; IF NOT STORING, CONSIDER THIS THE END\r
+\r
+ POPJ P,\r
+ MOVE C,T.SPDL+1(TB) ; GET P-BASE\r
+ HLRZ A,S.DEV(C) ; GET DEVICE\r
+ CAIE A,(SIXBIT /INT/) ; IS IT THE INTERNAL DEVICE\r
+ JRST TRYNET ; NO, COUD BE NET\r
+ MOVE A,0 ; OFFNEDING TYPE TO A\r
+ PUSHJ P,APLQ ; IS IT APPLICABLE\r
+ JRST NAPT ; NO, LOSE\r
+ PMOVEM (AB),T.XT(TB)\r
+ ADD AB,[2,,2] ; MUST BE LAST ARG\r
+ JUMPL AB,TMA\r
+ JRST CPOPJ1 ; ELSE SUCCESSFUL RETURN\r
+TRYNET: CAIE 0,TFIX ; FOR NET DEV, ARGS MUST BE FIX\r
+ JRST WRONGT ; TREAT AS WRONG TYPE\r
+ MOVSI A,MSTNET ; BETTER BE NET EVENTUALLY\r
+ IORM A,(P) ; STORE FLAGS\r
+ MOVSI A,TFIX\r
+ MOVE B,1(AB) ; GET NUMBER\r
+ MOVEI 0,(E) ; MAKE SURE NOT DEVICE\r
+ CAIN 0,2\r
+ JRST WRONGT\r
+ PUSH P,B ; SAVE NUMBER\r
+ MOVEI D,(E) ; SET FOR TABLE OFFSETS\r
+ MOVEI 0,0\r
+ ADD TP,[4,,4]\r
+ JRST NFL2 ; GO CLOBBER IT AWAY\r
+]\r
+\f\r
+\r
+; ROUTINE TO FLUSH LEADING SPACES FROM A FIELD\r
+\r
+FLSSP: HRRZ 0,-1(TP) ; GET CHR COUNNT\r
+ JUMPE 0,CPOPJ ; FINISHED STRING\r
+FLSS1: MOVE B,(TP) ; GET BYTR\r
+ ILDB C,B ; GETCHAR\r
+ CAILE C,40\r
+ JRST FLSS2\r
+ MOVEM B,(TP) ; UPDATE BYTE POINTER\r
+ SOJN 0,FLSS1\r
+\r
+FLSS2: HRRM 0,-1(TP) ; UPDATE STRING\r
+ POPJ P,\r
+\r
+IFN ITS,[\r
+;TABLE FOR STFUFFING SIXBITS AWAY\r
+\r
+SIXTBL: S.NM1(D)\r
+ S.NM2(D)\r
+ S.DEV(D)\r
+ S.SNM(D)\r
+ S.X1(D)\r
+]\r
+\r
+RDTBL: RDEVIC(B)\r
+ RNAME1(B)\r
+ RNAME2(B)\r
+ RSNAME(B)\r
+\r
+\r
+\f\r
+IFE ITS,[\r
+\r
+; TENEX VERSION OF FILE NAME PARSER (ONLY ACCEPT ARGS IN SINGLE STRING)\r
+\r
+RGPRS: MOVEI 0,NOSTOR\r
+\r
+RGPARS: HRLM 0,(P) ; SAVE FOR STORE CHECKING\r
+ CAMGE AB,[-7,,] ; MULTI-STRING CASE POSSIBLE?\r
+ JRST TN.MLT ; YES, GO PROCESS\r
+RGPRSS: GETYP 0,(AB) ; CHECK ARG TYPE\r
+ CAIE 0,TCHSTR\r
+ JRST WRONGT ; FOR NOW ONLY STRING ARGS WIN\r
+ PUSH TP,(AB)\r
+ PUSH TP,1(AB)\r
+ PUSHJ P,FLSSP ; FLUSH LEADING SPACES\r
+ PUSHJ P,RGPRS1\r
+ ADD AB,[2,,2]\r
+CHKLST: JUMPGE AB,CPOPJ1\r
+ SKIPGE (P) ; IF FROM OPEN, ALLOW ONE MORE\r
+ POPJ P,\r
+ PMOVEM (AB),T.XT(TB)\r
+ ADD AB,[2,,2]\r
+ JUMPL AB,TMA\r
+CPOPJ1: AOS (P)\r
+ POPJ P,\r
+\r
+RGPRS1: PUSH P,[0] ; ALLOW A DEVICE SPEC\r
+TN.SNM: MOVE A,(TP)\r
+ HRRZ 0,-1(TP)\r
+ JUMPE 0,RPDONE\r
+ ILDB A,A\r
+ CAIE A,"< ; START "DIRECTORY" ?\r
+ JRST TN.N1 ; NO LOOK FOR NAME1\r
+ SETOM (P) ; DEV NOT ALLOWED\r
+ IBP (TP) ; SKIP CHAR\r
+ SOS -1(TP)\r
+ PUSHJ P,TN.CNT ; COUNT CHARS TO ">"\r
+ JUMPE B,ILLNAM ; RAN OUT\r
+ CAIE A,"> ; SKIP IF WINS\r
+ JRST ILLNAM\r
+ PUSHJ P,TN.CPS ; COPY TO NEW STRING\r
+ MOVEM A,T.SNM(TB)\r
+ MOVEM B,T.SNM+1(TB)\r
+\r
+TN.N1: PUSHJ P,TN.CNT\r
+ JUMPE B,RPDONE\r
+ CAIE A,": ; GOT A DEVICE\r
+ JRST TN.N11\r
+ SKIPE (P)\r
+ JRST ILLNAM\r
+ SETOM (P)\r
+ PUSHJ P,TN.CPS\r
+ MOVEM A,T.DEV(TB)\r
+ MOVEM B,T.DEV+1(TB)\r
+ JRST TN.SNM ; NOW LOOK FOR SNAME\r
+\r
+TN.N11: CAIE A,">\r
+ CAIN A,"<\r
+ JRST ILLNAM\r
+ MOVEM A,(P) ; SAVE END CHAR\r
+ PUSHJ P,TN.CPS ; GEN STRING\r
+ MOVEM A,T.NM1(TB)\r
+ MOVEM B,T.NM1+1(TB)\r
+\r
+TN.N2: SKIPN A,(P) ; GET CHAR BACK\r
+ JRST RPDONE\r
+ CAIN A,"; ; START VERSION?\r
+ JRST .+3\r
+ CAIE A,". ; START NAME2?\r
+ JRST ILLNAM ; I GIVE UP!!!\r
+ HRRZ B,-1(TP) ; GET RMAINS OF STRING\r
+ PUSHJ P,TN.CPS ; AND COPY IT\r
+ MOVEM A,T.NM2(TB)\r
+ MOVEM B,T.NM2+1(TB)\r
+RPDONE: SUB P,[1,,1] ; FLUSH TEMP\r
+ SUB TP,[2,,2]\r
+CPOPJ: POPJ P,\r
+\r
+TN.CNT: HRRZ 0,-1(TP) ; CHAR COUNT\r
+ MOVE C,(TP) ; BPTR\r
+ MOVEI B,0 ; INIT COUNT TO 0\r
+\r
+TN.CN1: MOVEI A,0 ; IN CASE RUN OUT\r
+ SOJL 0,CPOPJ ; RUN OUT?\r
+ ILDB A,C ; TRY ONE\r
+ CAIE A,"\16 ; TNEX FILE QUOTE?\r
+ JRST TN.CN2\r
+ SOJL 0,CPOPJ\r
+ IBP C ; SKIP QUOTED CHAT\r
+ ADDI B,2\r
+ JRST TN.CN1\r
+\r
+TN.CN2: CAIE A,"<\r
+ CAIN A,">\r
+ POPJ P,\r
+\r
+ CAIE A,".\r
+ CAIN A,";\r
+ POPJ P,\r
+ CAIN A,":\r
+ POPJ P,\r
+ AOJA B,TN.CN1\r
+\r
+TN.CPS: PUSH P,B ; # OF CHARS\r
+ MOVEI A,4(B) ; ADD 4 TO B IN A\r
+ IDIVI A,5\r
+ PUSHJ P,IBLOCK ; GET BLOCK OF WORDS FOR STRING\r
+\r
+ POP P,C ; CHAR COUNT BACK\r
+ HRLI B,440700\r
+ MOVSI A,TCHSTR\r
+ HRRI A,(C) ; CHAR STRING\r
+ MOVE D,B ; COPY BYTER\r
+\r
+ JUMPE C,CPOPJ\r
+ ILDB 0,(TP) ; GET CHAR\r
+ IDPB 0,D ; AND STROE\r
+ SOJG C,.-2\r
+\r
+ MOVNI C,(A) ; - LENGTH TO C\r
+ ADDB C,-1(TP) ; DECREMENT WORDS COUNT\r
+ TRNN C,-1 ; SKIP IF EMPTY\r
+ POPJ P,\r
+ IBP (TP)\r
+ SOS -1(TP) ; ELSE FLUSH TERMINATOR\r
+ POPJ P,\r
+\r
+ILLNAM: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE ILLEGAL-TENEX-FILE-NAME\r
+ JRST CALER1\r
+\r
+TN.MLT: MOVEI A,(AB)\r
+ HRLI A,-10\r
+\r
+TN.ML1: GETYP 0,(A)\r
+ CAIE 0,TFIX\r
+ CAIN 0,TCHSTR\r
+ JRST .+2\r
+ JRST RGPRSS ; ASSUME SINGLE STRING \r
+ ADD A,[2,,2]\r
+ JUMPL A,TN.ML1\r
+\r
+ MOVEI A,T.NM1(TB)\r
+ HRLI A,(AB)\r
+ BLT A,T.SNM+1(TB) ; BLT 'EM IN\r
+ ADD AB,[10,,10] ; SKIP THESE GUYS\r
+ JRST CHKLST\r
+\r
+]\r
+\f\r
+\r
+; ROUTINE TO OPEN A CHANNEL FOR ANY DEVICE. NAMES ARE ASSUMED TO ALREADY\r
+; BE ON BOTH TP STACK AND P STACK\r
+\r
+OPNCH: MOVE C,T.SPDL+1(TB) ; GET PDL BASE\r
+ HRRZ A,S.DIR(C)\r
+ ANDI A,1 ; JUST WANT I AND O\r
+ HRLM A,S.DEV(C)\r
+; .TRANS S.DEV(C) ; UNDO ANY TRANSLATIONS\r
+; JRST TRLOST ; COMPLAIN\r
+\r
+ HRRZ A,S.DEV(C) ; GET SIXBIT DEVICE CODE\r
+ MOVEI E,(A) ; COPY TO E\r
+ ANDI E,777700 ; WITHOUT LAST\r
+ MOVEI D,(E) ; AND D\r
+ ANDI D,770000 ; WITH JUST LETTER\r
+ MOVSI B,-NDEVS ; AOBJN COUNTER\r
+\r
+DEVLP: HRRZ 0,DEVS(B) ; GET ONE\r
+ CAIN 0,(A) ; FULL DEV?\r
+ JRST DISPA\r
+ CAIN 0,(D) ; ONE LETTER\r
+ JRST CH2DIG\r
+ CAIN 0,(E) ; 2 LTTERS\r
+ JRST CH1DIG\r
+NXTDEV: AOBJN B,DEVLP ; LOOP THRU\r
+\r
+IFN ITS,[\r
+OUSR: HRRZ A,S.DIR(C) ; BLOCK OR UNIT?\r
+ TRNE A,2 ; SKIP IF UNIT\r
+ JRST ODSK\r
+ PUSHJ P,OPEN1 ; OPEN IT\r
+ PUSHJ P,FIXREA ; AND READCHST IT\r
+ MOVE B,T.CHAN+1(TB) ; RESTORE CHANNEL\r
+ MOVE 0,[PUSHJ P,DOIOT] ; GET AN IOINS\r
+ MOVEM 0,IOINS(B)\r
+ MOVE C,T.SPDL+1(TB)\r
+ HRRZ A,S.DIR(C)\r
+ TRNN A,1\r
+ JRST EOFMAK\r
+ MOVEI 0,80.\r
+ MOVEM 0,LINLN(B)\r
+ JRST OPNWIN\r
+\r
+OSTY: HLRZ A,S.DEV(C)\r
+ IORI A,10 ; THE DONT LOSE BIT (DONT HANG ON INPUT DO ON OUTPUT)\r
+ HRLM A,S.DEV(C)\r
+ JRST OUSR\r
+]\r
+IFE ITS,[\r
+ PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE NO-SUCH-DEVICE?\r
+ JRST CALER1\r
+]\r
+\r
+; MAKE SURE DIGITS EXIST\r
+\r
+CH2DIG: LDB 0,[60600,,A]\r
+ CAIG 0,'9 ; CHECK DIGITNESS\r
+ CAIGE 0,'0\r
+ JRST NXTDEV ; LOSER\r
+\r
+CH1DIG: LDB 0,[600,,A] ; LAST CHAR\r
+ CAIG 0,'9\r
+ CAIGE 0,'0\r
+ JRST NXTDEV\r
+\r
+; HERE TO DISPATCH IF SUCCESSFUL\r
+\r
+DISPA: HLRZ B,DEVS(B)\r
+IFN ITS,[\r
+ HRRZ A,S.DIR(C) ; GET DIR OF OPEN\r
+ CAIN A,5 ; IS IT DISPLAY\r
+ CAIN B,ODIS ; BETTER BE OPENING DISPLAY\r
+ JRST (B) ; GO TO HANDLER\r
+ JRST WRONGD\r
+]\r
+IFE ITS, JRST (B)\r
+\r
+\f\r
+IFN ITS,[\r
+\r
+; DISK DEVICE OPNER COME HERE\r
+\r
+ODSK: MOVE A,S.SNM(C) ; GET SNAME\r
+ .SUSET [.SSNAM,,A] ; CLOBBER IT\r
+ PUSHJ P,OPEN0 ; DO REAL LIVE OPEN\r
+]\r
+IFE ITS,[\r
+\r
+; TENEX DISK FILE OPENER\r
+\r
+ODSK: MOVE B,T.CHAN+1(TB) ; GET CHANNEL\r
+ PUSHJ P,STSTK ; EXPAND STRING ONTO STACK (E POINTS TO OLD P)\r
+ MOVE A,DIRECT-1(B)\r
+ MOVE B,DIRECT(B)\r
+ PUSHJ P,STRTO6 ; GET DIR NAME\r
+ POP P,C\r
+ MOVE D,T.SPDL+1(TB)\r
+ HRRZ D,S.DIR(D)\r
+ CAMN C,[SIXBIT /PRINTO/]\r
+ IORI D,100 ; TURN ON BIT TO SAY USE OLD FILE\r
+ MOVSI A,101 ; START SETTING UP BITS EXTRA BIT FOR MSB\r
+ TRNE D,1 ; SKIP IF INPUT\r
+ TRNE D,100 ; WITE OVER?\r
+ TLOA A,100000 ; FORCE NEW VERSION\r
+ TLO A,400000 ; FORCE OLD\r
+ HRROI B,1(E) ; POIT TO STRING\r
+ GTJFN\r
+ TDZA 0,0 ; SAVE FACT OF NO SKIP\r
+ MOVEI 0,1 ; INDICATE SKIPPED\r
+ MOVE P,E ; RESTORE PSTACK\r
+ JUMPE 0,GTJLOS ; FIND OUT WHAT HAPPENED\r
+\r
+ MOVE B,T.CHAN+1(TB) ; GET CHANNEL\r
+ HRRZM A,CHANNO(B) ; SAVE IT\r
+ ANDI A,-1 ; READ Y TO DO OPEN\r
+ MOVSI B,440000 ; USE 36. BIT BYES\r
+ HRRI B,200000 ; ASSUME READ\r
+ TRNE D,1 ; SKIP IF READ\r
+ HRRI B,300000 ; WRITE BIT\r
+ HRRZ 0,FSAV(TB) ; SEE IF REF DATE HACK\r
+ CAIN 0,NFOPEN\r
+ TRO B,400 ; SET DON'T MUNG REF DATE BIT\r
+ OPENF\r
+ JRST OPFLOS\r
+ MOVEI 0,C.OPN+C.READ\r
+ TRNE D,1 ; SKIP FOR READ\r
+ MOVEI 0,C.OPN+C.PRIN\r
+ MOVE B,T.CHAN+1(TB)\r
+ HRRM 0,-4(B) ; MUNG THOSE BITS\r
+ ASH A,1 ; POINT TO SLOT\r
+ ADDI A,CHNL0(TVP) ; TO REAL SLOT\r
+ MOVEM B,1(A) ; SAVE CHANNEL\r
+ PUSHJ P,TMTNXS ; GET STRING FROM TENEX\r
+ MOVE B,CHANNO(B) ; JFN TO A\r
+ HRROI A,1(E) ; BASE OF STRING\r
+ MOVE C,[111111,,140001] ; WEIRD CONTROL BITS\r
+ JFNS ; GET STRING\r
+ MOVEI B,1(E) ; POINT TO START OF STRING\r
+ SUBM P,E ; RELATIVIZE E\r
+ PUSHJ P,TNXSTR ; MAKE INTO A STRING\r
+ SUB P,E ; BACK TO NORMAL\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ PUSHJ P,RGPRS1 ; PARSE INTO FIELDS\r
+ MOVE B,T.CHAN+1(TB)\r
+ MOVEI C,RNAME1-1(B)\r
+ HRLI C,T.NM1(TB)\r
+ BLT C,RSNAME(B)\r
+ JRST OPBASC\r
+OPFLOS: MOVEI C,(A) ; SAVE ERROR CODE\r
+ MOVE B,T.CHAN+1(TB)\r
+ HRRZ A,CHANNO(B) ; JFN BACK TO A\r
+ RLJFN ; TRY TO RELEASE IT\r
+ JFCL\r
+ MOVEI A,(C) ; ERROR CODE BACK TO A\r
+\r
+GTJLOS: PUSHJ P,TGFALS ; GET A FALSE WITH REASON\r
+ JRST OPNRET\r
+\r
+STSTK: PUSH TP,$TCHAN\r
+ PUSH TP,B\r
+ MOVEI A,4+5 ; COUNT CHARS NEEDED (NEED LAST 0 BYTE)\r
+ MOVE B,(TP)\r
+ ADD A,RDEVIC-1(B)\r
+ ADD A,RNAME1-1(B)\r
+ ADD A,RNAME2-1(B)\r
+ ADD A,RSNAME-1(B)\r
+ ANDI A,-1 ; TO 18 BITS\r
+ IDIVI A,5 ; TO WORDS NEEDED\r
+ POP P,C ; SAVE RET ADDR\r
+ MOVE E,P ; SAVE POINTER\r
+ PUSH P,[0] ; ALOCATE SLOTS\r
+ SOJG A,.-1\r
+ PUSH P,C ; RET ADDR BACK\r
+ INTGO ; IN CASE OVERFLEW\r
+ MOVE B,(TP) ; IN CASE GC'D\r
+ MOVE D,[440700,,1(E)] ; BYTE POINTER TO IT\r
+ MOVEI A,RDEVIC-1(B)\r
+ PUSHJ P,MOVSTR ; FLUSH IT ON\r
+ MOVEI A,":\r
+ IDPB A,D\r
+ HRRZ A,RSNAME-1(B) ; ANY SNAME AT ALL?\r
+ JUMPE A,ST.NM1 ; NOPE, CANT HACK WITH IT\r
+ MOVEI A,"<\r
+ IDPB A,D\r
+ MOVEI A,RSNAME-1(B)\r
+ PUSHJ P,MOVSTR ; SNAME UP\r
+ MOVEI A,">\r
+ IDPB A,D\r
+ MOVEI A,RNAME1-1(B)\r
+ PUSHJ P,MOVSTR\r
+ MOVEI A,".\r
+ IDPB A,D\r
+ST.NM1: MOVEI A,RNAME2-1(B)\r
+ PUSHJ P,MOVSTR\r
+ SUB TP,[2,,2]\r
+ POPJ P,\r
+\r
+MOVSTR: HRRZ 0,(A) ; CHAR COUNT\r
+ MOVE A,1(A) ; BYTE POINTER\r
+ SOJL 0,CPOPJ\r
+ ILDB C,A ; GET CHAR\r
+ IDPB C,D ; MUNG IT UP\r
+ JRST .-3\r
+\r
+; MAKE A TENEX ERROR MESSAGE STRING\r
+\r
+TGFALS: PUSH P,A ; SAVE ERROR CODE\r
+ PUSHJ P,TMTNXS ; STRING ON STACK\r
+ HRROI A,1(E) ; POINT TO SPACE\r
+ MOVE B,(E) ; ERROR CODE\r
+ HRLI B,400000 ; FOR ME\r
+ MOVSI C,-100. ; MAX CHARS\r
+ ERSTR ; GET TENEX STRING\r
+ JRST TGFLS1\r
+ JRST TGFLS1\r
+\r
+ MOVEI B,1(E) ; A AND B BOUND STRING\r
+ SUBM P,E ; RELATIVIZE E\r
+ PUSHJ P,TNXSTR ; BUILD STRING\r
+ SUB P,E ; P BACK TO NORMAL\r
+TGFLS2: SUB P,[1,,1] ; FLUSH ERROR CODE SLOT\r
+ MOVE C,A\r
+ MOVE D,B\r
+ PUSHJ P,INCONS ; BUILD LIST\r
+ MOVSI A,TFALSE ; MAKE IT FALSE\r
+ POPJ P,\r
+\r
+TGFLS1: MOVE P,E ; RESET STACK\r
+ MOVE A,$TCHSTR\r
+ MOVE B,CHQUOTE UNKNOWN PROBLEM IN I/O\r
+ JRST TGFLS2\r
+\r
+]\r
+; OTHER BUFFERED DEVICES JOIN HERE\r
+\r
+OPDSK1:\r
+IFN ITS,[\r
+ PUSHJ P,FIXREA ; STORE THE "REAL" NAMES INTO THE CHANNEL\r
+]\r
+OPBASC: MOVE C,T.SPDL+1(TB) ; C WAS CLOBBERED, GET IT BACK\r
+ HRRZ A,S.DIR(C) ; FIND OUT IF OPEN IS ASCII OR WORD\r
+ TRZN A,2 ; SKIP IF BINARY\r
+ PUSHJ P,OPASCI ; DO IT FOR ASCII\r
+\r
+; NOW SET UP IO INSTRUCTION FOR CHANNEL\r
+\r
+MAKION: MOVE B,T.CHAN+1(TB)\r
+ MOVEI C,GETCHR\r
+ JUMPE A,MAKIO1 ; JUMP IF INPUT\r
+ MOVEI C,PUTCHR ; ELSE GET INPUT\r
+ MOVEI 0,80. ; DEFAULT LINE LNTH\r
+ MOVEM 0,LINLN(B)\r
+ MOVSI 0,TFIX\r
+ MOVEM 0,LINLN-1(B)\r
+MAKIO1:\r
+ HRLI C,(PUSHJ P,)\r
+ MOVEM C,IOINS(B) ; STORE IT\r
+ JUMPN A,OPNWIN ; GET AN EOF FORM FOR INPUT CHANNEL\r
+\r
+; HERE TO CONS UP <ERROR END-OF-FILE>\r
+\r
+EOFMAK: MOVSI C,TATOM\r
+ MOVE D,EQUOTE END-OF-FILE\r
+ PUSHJ P,INCONS\r
+ MOVEI E,(B)\r
+ MOVSI C,TATOM\r
+ MOVE D,IMQUOTE ERROR\r
+ PUSHJ P,ICONS\r
+ MOVE D,T.CHAN+1(TB) ; RESTORE CHANNEL\r
+ MOVSI 0,TFORM\r
+ MOVEM 0,EOFCND-1(D)\r
+ MOVEM B,EOFCND(D)\r
+\r
+OPNWIN: MOVEI 0,10. ; SET UP RADIX\r
+ MOVSI A,TCHAN ; OPEN SUCCEEDED, RET CHANNEL\r
+ MOVE B,T.CHAN+1(TB)\r
+ MOVEM 0,RADX(B)\r
+\r
+OPNRET: MOVE C,(P) ; RET ADDR\r
+ SUB P,[S.X3+2,,S.X3+2]\r
+ SUB TP,[T.CHAN+2,,T.CHAN+2]\r
+ JRST (C)\r
+\f\r
+\r
+; HERE TO CREATE CHARACTER BUFFERS FOR ASCII I/O\r
+\r
+OPASCI: PUSH P,A ; CONTAINS MODE, SAVE IT\r
+ MOVEI A,BUFLNT ; GET SIZE OF BUFFER\r
+ PUSHJ P,IBLOCK ; GET STORAGE\r
+ MOVSI 0,TWORD+.VECT. ; SET UTYPE\r
+ MOVEM 0,BUFLNT(B) ; AND STORE\r
+ MOVSI A,TCHSTR\r
+ SKIPE (P) ; SKIP IF INPUT\r
+ JRST OPASCO\r
+ MOVEI D,BUFLNT(B) ; REST BYTE POINTER\r
+OPASCA: HRLI D,440700\r
+ MOVE B,T.CHAN+1(TB) ; GET CHANNEL BACK\r
+ MOVEI 0,C.BUF\r
+ IORM 0,-4(B) ; TURN ON BUFFER BIT\r
+ MOVEM A,BUFSTR-1(B)\r
+ MOVEM D,BUFSTR(B) ; CLOBBER\r
+ POP P,A\r
+ POPJ P,\r
+\r
+OPASCO: HRROI C,777776\r
+ MOVEM C,(B) ; -1 THE BUFFER (LEAVE OFF LOW BIT)\r
+ MOVSI C,(B)\r
+ HRRI C,1(B) ; BUILD BLT POINTER\r
+ BLT C,BUFLNT-1(B) ; ZAP\r
+ MOVEI D,(B) ; START MAKING STRING POINTER\r
+ HRRI A,BUFLNT*5 ; SET UP CHAR COUNT\r
+ JRST OPASCA\r
+\f\r
+\r
+; OPEN NON FILE ORIENTED DEVICES (NUL, PTR, PTP ETC.)\r
+\r
+ONUL:\r
+OPTP:\r
+OPTR: PUSHJ P,OPEN0 ; SET UP MODE AND OPEN\r
+ SETZM S.NM1(C) ; CLOBBER UNINTERESTING FIELDS\r
+ SETZM S.NM2(C)\r
+ SETZM S.SNM(C)\r
+ JRST OPDSK1\r
+\r
+; OPEN DEVICES THAT IGNORE SNAME\r
+\r
+OUTN: PUSHJ P,OPEN0\r
+ SETZM S.SNM(C)\r
+ JRST OPDSK1\r
+\r
+; OPEN THE DISPLAY DEVICE\r
+\r
+ODIS: MOVEI B,T.DIR(TB) ; GET CHANNEL\r
+ PUSHJ P,CHRWRD ; TO ASCII\r
+ JFCL\r
+ MOVE E,B ; DIR TO E\r
+ MOVE B,T.CHAN+1(TB) ; CHANNEL\r
+ MOVE 0,[PUSHJ P,DCHAR] ; IOINS\r
+ CAIN A,1\r
+ MOVEM 0,IOINS(B)\r
+ PUSHJ P,DISOPN\r
+ JRST DISLOS ; LOSER\r
+\r
+ MOVE D,T.CHAN+1(TB) ; GET CHANNEL\r
+ MOVEI 0,C.OPN+C.PRIN\r
+ HRRM 0,-4(D)\r
+ MOVEM A,DISINF-1(D) ; AND STORE\r
+ MOVEM B,DISINF(D)\r
+ SETZM CHANNO(D) ; NO REAL CHANNEL\r
+ MOVEI 0,DISLNL\r
+ MOVEM 0,LINLN(D)\r
+ MOVEI 0,DISPGL\r
+ MOVEM 0,PAGLN(D)\r
+ MOVEI 0,10. ; SET RADIX\r
+ MOVEM 0,RADX(D)\r
+ JRST SAVCHN ; ADD TO CHANNEL LIST\r
+\f\r
+\r
+; INTERNAL CHANNEL OPENER\r
+\r
+OINT: HRRZ A,S.DIR(C) ; CHECK DIR\r
+ CAIL A,2 ; READ/PRINT?\r
+ JRST WRONGD ; NO, LOSE\r
+\r
+ MOVE 0,INTINS(A) ; GET INS\r
+ MOVE D,T.CHAN+1(TB) ; AND CHANNEL\r
+ MOVEM 0,IOINS(D) ; AND CLOBBER\r
+ MOVEI 0,C.OPN+C.READ\r
+ TRNE A,1\r
+ MOVEI 0,C.OPN+C.PRIN\r
+ HRRM 0,-4(D)\r
+ SETOM STATUS(D) ; MAKE SURE NOT AA TTY\r
+ PMOVEM T.XT(TB),INTFCN-1(D)\r
+\r
+; HERE TO SAVE PSEUDO CHANNELS\r
+\r
+SAVCHN: HRRZ E,CHNL0+1(TVP) ; POINT TO CURRENT LIST\r
+ MOVSI C,TCHAN\r
+ PUSHJ P,ICONS ; CONS IT ON\r
+ HRRZM B,CHNL0+1(TVP)\r
+ JRST OPNWIN\r
+\r
+; INT DEVICE I/O INS\r
+\r
+INTINS: PUSHJ P,GTINTC\r
+ PUSHJ P,PTINTC\r
+\f\r
+\r
+; HERE TO OPEN THE NET DEVICE (I.E. THE ARPA NET)\r
+\r
+IFN ITS,[\r
+ONET: HRRZ A,S.DIR(C) ; DIRECTION CODE\r
+ CAILE A,1 ; ASCII ?\r
+ IORI A,4 ; TURN ON IMAGE BIT\r
+ SKIPGE S.NM1(C) ; NAME1 I.E. LOCAL HOST GIVEN\r
+ IORI A,10 ; NO, WE WILL LET ITS GIVE US ONE\r
+ SKIPGE S.NM2(C) ; NORMAL OR "LISTEN"\r
+ IORI A,20 ; TURN ON LISTEN BIT\r
+ MOVEI 0,7 ; DEFAULT BYTE SIZE\r
+ TRNE A,2 ; UNLESS\r
+ MOVEI 0,36. ; IMAGE WHICH IS 36\r
+ SKIPN T.XT(TB) ; BYTE SIZE GIVEN?\r
+ MOVEM 0,S.X1(C) ; NO, STORE DEFAULT\r
+ SKIPG D,S.X1(C) ; BYTE SIZE REASONABLE?\r
+ JRST RBYTSZ ; NO <0, COMPLAIN\r
+ TRNE A,2 ; SKIP TO CHECK ASCII\r
+ JRST ONET2 ; CHECK IMAGE\r
+ CAIN D,7 ; 7-BIT WINS\r
+ JRST ONET1\r
+ CAIE D,44 ; 36-BIT INDICATES BLOCK ASCII MODE\r
+ JRST .+3\r
+ IORI A,2 ; SET BLOCK FLAG\r
+ JRST ONET1\r
+ IORI A,40 ; USE 8-BIT MODE\r
+ CAIN D,10 ; IS IT RIGHT\r
+ JRST ONET1 ; YES\r
+]\r
+\r
+RBYTSZ: PUSH TP,$TATOM ; CALL ERROR\r
+ PUSH TP,EQUOTE BYTE-SIZE-BAD\r
+ JRST CALER1\r
+\r
+IFN ITS,[\r
+ONET2: CAILE D,36. ; IMAGE SIZE REASONABLE?\r
+ JRST RBYTSZ ; NO\r
+ CAIN D,36. ; NORMAL\r
+ JRST ONET1 ; YES, DONT SET FIELD\r
+\r
+ ASH D,9. ; POSITION FOR FIELD\r
+ IORI A,40(D) ; SET IT AND ITS BIT\r
+\r
+ONET1: HRLM A,S.DEV(C) ; CLOBBER OPEN BLOCK\r
+ MOVE E,A ; SAVE BLOCK MODE INFO\r
+ PUSHJ P,OPEN1 ; DO THE OPEN\r
+ PUSH P,E\r
+\r
+; CLOBBER REAL SLOTS FOR THE OPEN\r
+\r
+ MOVEI A,3 ; GET STATE VECTOR\r
+ PUSHJ P,IBLOCK\r
+ MOVSI A,TUVEC\r
+ MOVE D,T.CHAN+1(TB)\r
+ MOVEM A,BUFRIN-1(D)\r
+ MOVEM B,BUFRIN(D)\r
+ MOVSI A,TFIX+.VECT. ; SET U TYPE\r
+ MOVEM A,3(B)\r
+ MOVE C,T.SPDL+1(TB)\r
+ MOVE B,T.CHAN+1(TB)\r
+\r
+ PUSHJ P,INETST ; GET STATE\r
+\r
+ POP P,A ; IS THIS BLOCK MODE\r
+ MOVEI 0,80. ; POSSIBLE LINE LENGTH\r
+ TRNE A,1 ; SKIP IF INPUT\r
+ MOVEM 0,LINLN(B)\r
+ TRNN A,2 ; BLOCK MODE?\r
+ JRST .+3\r
+ TRNN A,4 ; ASCII MODE?\r
+ JRST OPBASC ; GO SETUP BLOCK ASCII\r
+ MOVE 0,[PUSHJ P,DOIOT]\r
+ MOVEM 0,IOINS(B)\r
+\r
+ JRST OPNWIN\r
+\r
+; INTERNAL ROUTINE TO GET THE CURRENT STATE OF THE NETWROK CHANNEL\r
+\r
+INETST: MOVE A,S.NM1(C)\r
+ MOVEM A,RNAME1(B)\r
+ MOVE A,S.NM2(C)\r
+ MOVEM A,RNAME2(B)\r
+ LDB A,[1100,,S.SNM(C)]\r
+ MOVEM A,RSNAME(B)\r
+\r
+ MOVE E,BUFRIN(B) ; GET STATE BLOCK\r
+INTST1: HRRE 0,S.X1(C)\r
+ MOVEM 0,(E)\r
+ ADDI C,1\r
+ AOBJN E,INTST1\r
+\r
+ POPJ P,\r
+\f\r
+\r
+; ACCEPT A CONNECTION\r
+\r
+MFUNCTION NETACC,SUBR\r
+\r
+ PUSHJ P,ARGNET ; CHECK THAT ARG IS AN OPEN NET CHANNEL\r
+ MOVE A,CHANNO(B) ; GET CHANNEL\r
+ LSH A,23. ; TO AC FIELD\r
+ IOR A,[.NETACC]\r
+ XCT A\r
+ JRST IFALSE ; RETURN FALSE\r
+NETRET: MOVE A,(AB)\r
+ MOVE B,1(AB)\r
+ JRST FINIS\r
+\r
+; FORCE SYSTEM NETWORK BUFFERS TO BE SENT\r
+\r
+MFUNCTION NETS,SUBR\r
+\r
+ PUSHJ P,ARGNET\r
+ CAME A,MODES+1\r
+ CAMN A,MODES+3\r
+ SKIPA A,CHANNO(B) ; GET CHANNEL\r
+ JRST WRONGD\r
+ LSH A,23.\r
+ IOR A,[.NETS]\r
+ XCT A\r
+ JRST NETRET\r
+\r
+; SUBR TO RETURN UPDATED NET STATE\r
+\r
+MFUNCTION NETSTATE,SUBR\r
+\r
+ PUSHJ P,ARGNET ; IS IT A NET CHANNEL\r
+ PUSHJ P,INSTAT\r
+ JRST FINIS\r
+\r
+; INTERNAL NETSTATE ROUTINE\r
+\r
+INSTAT: MOVE C,P ; GET PDL BASE\r
+ MOVEI 0,S.X3 ; # OF SLOTS NEEDED\r
+ PUSH P,[0]\r
+ SOJN 0,.-1\r
+\r
+ MOVEI D,S.DEV(C) ; SETUP FOR .RCHST\r
+ HRL D,CHANNO(B)\r
+ .RCHST D, ; GET THE GOODS\r
+\r
+ PUSHJ P,INETST ; INTO VECTOR\r
+ SUB P,[S.X3,,S.X3]\r
+ MOVE B,BUFRIN(B)\r
+ MOVSI A,TUVEC\r
+ POPJ P,\r
+]\r
+; INTERNAL ROUTINE TO CHECK FOR CORRECT CHANNEL TYPE\r
+\r
+ARGNET: ENTRY 1\r
+ GETYP 0,(AB)\r
+ CAIE 0,TCHAN\r
+ JRST WTYP1\r
+ MOVE B,1(AB) ; GET CHANNEL\r
+ SKIPN CHANNO(B) ; OPEN?\r
+ JRST CHNCLS\r
+ MOVE A,RDEVIC-1(B) ; GET DEV NAME\r
+ MOVE B,RDEVIC(B)\r
+ PUSHJ P,STRTO6\r
+ POP P,A\r
+ CAME A,[SIXBIT /NET /]\r
+ JRST NOTNET\r
+ MOVE B,1(AB)\r
+ MOVE A,DIRECT-1(B) ; CHECK FOR A READ SOCKET\r
+ MOVE B,DIRECT(B)\r
+ PUSHJ P,STRTO6\r
+ MOVE B,1(AB) ; RESTORE CHANNEL\r
+ POP P,A\r
+ POPJ P,\r
+\f\r
+IFE ITS,[\r
+\r
+; TENEX NETWRK OPENING CODE\r
+\r
+ONET: MOVE B,T.CHAN+1(TB) ; GET CHANNEL\r
+ MOVSI C,100700\r
+ HRRI C,1(P)\r
+ MOVE E,P\r
+ PUSH P,[ASCII /NET:/] ; FOR STRINGS\r
+ GETYP 0,RNAME1-1(B) ; CHECK TYPE\r
+ CAIE 0,TFIX ; SKIP IF # SUPPLIED\r
+ JRST ONET1\r
+ MOVE 0,RNAME1(B) ; GET IT\r
+ PUSHJ P,FIXSTK\r
+ JFCL\r
+ JRST ONET2\r
+ONET1: CAIE 0,TCHSTR\r
+ JRST WRONGT\r
+ HRRZ 0,RNAME1-1(B)\r
+ MOVE B,RNAME1(B)\r
+ JUMPE 0,ONET2\r
+ ILDB A,B\r
+ JSP D,ONETCH\r
+ SOJA 0,.-3\r
+ONET2: MOVEI A,".\r
+ JSP D,ONETCH\r
+ MOVE B,T.CHAN+1(TB)\r
+ GETYP 0,RNAME2-1(B)\r
+ CAIE 0,TFIX\r
+ JRST ONET3\r
+ GETYP 0,RSNAME-1(B)\r
+ CAIE 0,TFIX\r
+ JRST WRONGT\r
+ MOVE 0,RSNAME(B)\r
+ PUSHJ P,FIXSTK\r
+ JRST ONET4\r
+ MOVE B,T.CHAN+1(TB)\r
+ MOVEI A,"-\r
+ JSP D,ONETCH\r
+ MOVE 0,RNAME2(B)\r
+ PUSHJ P,FIXSTK\r
+ JRST WRONGT\r
+ JRST ONET4\r
+ONET3: CAIE 0,TCHSTR\r
+ JRST WRONGT\r
+ HRRZ 0,RNAME2-1(B)\r
+ MOVE B,RNAME2(B)\r
+ JUMPE 0,ONET4\r
+ ILDB A,B\r
+ JSP D,ONETCH\r
+ SOJA 0,.-3\r
+\r
+ONET4:\r
+ONET5: MOVE B,T.CHAN+1(TB)\r
+ GETYP 0,RNAME2-1(B)\r
+ CAIN 0,TCHSTR\r
+ JRST ONET6\r
+ MOVEI A,";\r
+ JSP D,ONETCH\r
+ MOVEI A,"T\r
+ JSP D,ONETCH\r
+ONET6: MOVSI A,1\r
+ HRROI B,1(E) ; STRING POINTER\r
+ GTJFN ; GET THE G.D JFN\r
+ TDZA 0,0 ; REMEMBER FAILURE\r
+ MOVEI 0,1\r
+ MOVE P,E ; RESTORE P\r
+ JUMPE 0,GTJLOS ; CONS UP ERROR STRING\r
+\r
+ MOVE B,T.CHAN+1(TB)\r
+ HRRZM A,CHANNO(B) ; SAVE THE JFN\r
+\r
+ MOVE C,T.SPDL+1(TB)\r
+ MOVE D,S.DIR(C)\r
+ MOVEI B,10\r
+ TRNE D,2\r
+ MOVEI B,36.\r
+ SKIPE T.XT(TB)\r
+ MOVE B,T.XT+1(TB)\r
+ JUMPL B,RBYTSZ\r
+ CAILE B,36.\r
+ JRST RBYTSZ\r
+ ROT B,-6\r
+ TLO B,3400\r
+ HRRI B,200000\r
+ TRNE D,1 ; SKIP FOR INPUT\r
+ HRRI B,100000\r
+ ANDI A,-1 ; ISOLATE JFCN\r
+ OPENF\r
+ JRST OPFLOS ; REPORT ERROR\r
+ MOVE B,T.CHAN+1(TB)\r
+ ASH A,1 ; POINT TO SLOT\r
+ ADDI A,CHNL0(TVP) ; TO REAL SLOT\r
+ MOVEM B,1(A) ; SAVE CHANNEL\r
+ MOVE A,CHANNO(B)\r
+ CVSKT ; GET ABS SOCKET #\r
+ FATAL NETWORK BITES THE BAG!\r
+ MOVE D,B\r
+ MOVE B,T.CHAN+1(TB)\r
+ MOVEM D,RNAME1(B)\r
+ MOVSI 0,TFIX\r
+ MOVEM 0,RNAME1-1(B)\r
+\r
+ MOVSI 0,TFIX\r
+ MOVEM 0,RNAME2-1(B)\r
+ MOVEM 0,RSNAME-1(B)\r
+ MOVE C,T.SPDL+1(TB)\r
+ MOVE C,S.DIR(C)\r
+ MOVE 0,[PUSHJ P,DONETO]\r
+ TRNN C,1 ; SKIP FOR OUTPUT\r
+ MOVE 0,[PUSHJ P,DONETI]\r
+ MOVEM 0,IOINS(B)\r
+ MOVEI 0,80. ; LINELENGTH\r
+ TRNE C,1 ; SKIP FOR INPUT\r
+ MOVEM 0,LINLN(B)\r
+ MOVEI A,3 ; GET STATE UVECTOR\r
+ PUSHJ P,IBLOCK\r
+ MOVSI 0,TFIX+.VECT.\r
+ MOVEM 0,3(B)\r
+ MOVE C,B\r
+ MOVE B,T.CHAN+1(TB)\r
+ MOVEM C,BUFRIN(B)\r
+ MOVSI 0,TUVEC\r
+ MOVEM 0,BUFRIN-1(B)\r
+ MOVE A,CHANNO(B) ; GET JFN\r
+ GDSTS ; GET STATE\r
+ MOVE E,T.CHAN+1(TB)\r
+ MOVEM D,RNAME2(E)\r
+ MOVEM C,RSNAME(E)\r
+ MOVE C,BUFRIN(E)\r
+ MOVEM B,(C) ; INITIAL STATE STORED\r
+ MOVE B,E\r
+ JRST OPNWIN\r
+\r
+; DOIOT FOR TENEX NETWRK\r
+\r
+DONETO: PUSH P,0\r
+ MOVE 0,[BOUT]\r
+ JRST .+3\r
+\r
+DONETI: PUSH P,0\r
+ MOVE 0,[BIN]\r
+ PUSH P,0\r
+ PUSH TP,$TCHAN\r
+ PUSH TP,B\r
+ MOVEI 0,(A) ; POSSIBLE OUTPUT CHAR TO 0\r
+ MOVE A,CHANNO(B)\r
+ MOVE B,0\r
+ ENABLE\r
+ XCT (P)\r
+ DISABLE\r
+ MOVEI A,(B) ; RET CHAR IN A\r
+ MOVE B,(TP)\r
+ MOVE 0,-1(P)\r
+ SUB P,[2,,2]\r
+ SUB TP,[2,,2]\r
+ POPJ P,\r
+ \r
+NETPRS: MOVEI D,0\r
+ HRRZ 0,(C)\r
+ MOVE C,1(C)\r
+\r
+ONETL: ILDB A,C\r
+ CAIN A,"#\r
+ POPJ P,\r
+ SUBI A,60\r
+ ASH D,3\r
+ IORI D,(A)\r
+ SOJG 0,ONETL\r
+ AOS (P)\r
+ POPJ P,\r
+\r
+FIXSTK: CAMN 0,[-1]\r
+ POPJ P,\r
+ JFFO 0,FIXS3 ; PUT OCTAL DIGITS INTO STIRNG\r
+ MOVEI A,"0\r
+ POP P,D\r
+ AOJA D,ONETCH\r
+FIXS3: IDIVI A,3\r
+ MOVEI B,12.\r
+ SUBI B,(A)\r
+ HRLM B,(P)\r
+ IMULI A,3\r
+ LSH 0,(A)\r
+ POP P,B\r
+FIXS2: MOVEI A,0\r
+ ROTC 0,3 ; NEXT DIGIT\r
+ ADDI A,60\r
+ JSP D,ONETCH\r
+ SUB B,[1,,0]\r
+ TLNN B,-1\r
+ JRST 1(B)\r
+ JRST FIXS2\r
+\r
+ONETCH: IDPB A,C\r
+ TLNE C,760000 ; SKIP IF NEW WORD\r
+ JRST (D)\r
+ PUSH P,[0]\r
+ JRST (D)\r
+\r
+INSTAT: MOVE E,B\r
+ MOVE A,CHANNO(E)\r
+ GDSTS\r
+ LSH B,-32.\r
+ MOVEM D,RNAME2(E) ; UPDATE FOREIGN SOCHKET\r
+ MOVEM C,RSNAME(E) ; AND HOST\r
+ MOVE C,BUFRIN(E)\r
+ XCT ITSTRN(B) ; XLATE TO LOOK MORE LIKE ITS\r
+ MOVEM B,(C) ; STORE STATE\r
+ MOVE B,E\r
+ POPJ P,\r
+\r
+ITSTRN: MOVEI B,0\r
+ JRST NLOSS\r
+ JRST NLOSS\r
+ MOVEI B,1\r
+ MOVEI B,2\r
+ JRST NLOSS\r
+ MOVEI B,4\r
+ PUSHJ P,NOPND\r
+ MOVEI B,0\r
+ JRST NLOSS\r
+ JRST NLOSS\r
+ PUSHJ P,NCLSD\r
+ MOVEI B,0\r
+ JRST NLOSS\r
+ MOVEI B,0\r
+\r
+NLOSS: FATAL ILLEGAL NETWORK STATE\r
+\r
+NOPND: MOVE B,DIRECT(E) ; SEE IF READ OR PRINT\r
+ ILDB B,B ; GET 1ST CHAR\r
+ CAIE B,"R ; SKIP FOR READ\r
+ JRST NOPNDW\r
+ SIBE ; SEE IF INPUT EXISTS\r
+ JRST .+3\r
+ MOVEI B,5\r
+ POPJ P,\r
+ MOVEM B,2(C) ; STORE BYTES IN STATE VECTOR\r
+ MOVEI B,11 ; RETURN DATA PRESENT STATE\r
+ POPJ P,\r
+\r
+NOPNDW: SOBE ; SEE IF OUTPUT PRESENT\r
+ JRST .+3\r
+ MOVEI B,5\r
+ POPJ P,\r
+\r
+ MOVEI B,6\r
+ POPJ P,\r
+\r
+NCLSD: MOVE B,DIRECT(E)\r
+ ILDB B,B\r
+ CAIE B,"R\r
+ JRST RET0\r
+ SIBE\r
+ JRST .+2\r
+ JRST RET0\r
+ MOVEI B,10\r
+ POPJ P,\r
+\r
+RET0: MOVEI B,0\r
+ POPJ P,\r
+\r
+\r
+MFUNCTION NETSTATE,SUBR\r
+\r
+ PUSHJ P,ARGNET\r
+ PUSHJ P,INSTAT\r
+ MOVE B,BUFRIN(B)\r
+ MOVSI A,TUVEC\r
+ JRST FINIS\r
+\r
+MFUNCTION NETS,SUBR\r
+\r
+ PUSHJ P,ARGNET\r
+ CAME A,MODES+1 ; PRINT OR PRINTB?\r
+ CAMN A,MODES+3\r
+ SKIPA A,CHANNO(B)\r
+ JRST WRONGD\r
+ MOVEI B,21\r
+ MTOPR\r
+NETRET: MOVE B,1(AB)\r
+ MOVSI A,TCHAN\r
+ JRST FINIS\r
+\r
+MFUNCTION NETACC,SUBR\r
+\r
+ PUSHJ P,ARGNET\r
+ MOVE A,CHANNO(B)\r
+ MOVEI B,20\r
+ MTOPR\r
+ JRST NETRET\r
+\r
+]\r
+\f\r
+; HERE TO OPEN TELETYPE DEVICES\r
+\r
+OTTY: HRRZ A,S.DIR(C) ; GET DIR CODE\r
+ TRNE A,2 ; SKIP IF NOT READB/PRINTB\r
+ JRST WRONGD ; CANT DO THAT\r
+\r
+IFN ITS,[\r
+ MOVE A,S.NM1(C) ; CHECK FOR A DIR\r
+ MOVE 0,S.NM2(C)\r
+ CAMN A,[SIXBIT /.FILE./]\r
+ CAME 0,[SIXBIT /(DIR)/]\r
+ SKIPA E,[-15.*2,,]\r
+ JRST OUTN ; DO IT THAT WAY\r
+\r
+ HRRZ A,S.DIR(C) ; CHECK DIR\r
+ TRNE A,1\r
+ JRST TTYLP2\r
+ HRRI E,CHNL1(TVP)\r
+ PUSH P,S.DEV(C) ; SAVE THE SIXBIT DEV NAME\r
+ HRLZS (P) ; POSTITION DEVICE NAME\r
+\r
+TTYLP: SKIPN D,1(E) ; CHANNEL OPEN?\r
+ JRST TTYLP1 ; NO, GO TO NEXT\r
+ MOVE A,RDEVIC-1(D) ; GET DEV NAME\r
+ MOVE B,RDEVIC(D)\r
+ PUSHJ P,STRTO6 ; TO 6 BIT\r
+ POP P,A ; GET RESULT\r
+ CAMN A,(P) ; SAME?\r
+ JRST SAMTYQ ; COULD BE THE SAME\r
+TTYLP1: ADD E,[2,,2]\r
+ JUMPL E,TTYLP\r
+ SUB P,[1,,1] ; THIS ONE MUST BE UNIQUE\r
+TTYLP2: MOVE C,T.SPDL+1(TB) ; POINT TO P BASE\r
+ HRRZ A,S.DIR(C) ; GET DIR OF OPEN\r
+ SKIPE A ; IF OUTPUT,\r
+ IORI A,20 ; THEN USE DISPLAY MODE\r
+ HRLM A,S.DEV(C) ; STORE IN OPEN BLOCK\r
+ PUSHJ P,OPEN2 ; OPEN THE TTY\r
+ HRLZ A,S.DEV(C) ; GET DEVICE NAME\r
+ PUSHJ P,6TOCHS ; TO A STRING\r
+ MOVE D,T.CHAN+1(TB) ; POINT TO CHANNEL\r
+ MOVEM A,RDEVIC-1(D)\r
+ MOVEM B,RDEVIC(D)\r
+ MOVE C,T.SPDL+1(TB) ; RESTORE PDL BASE\r
+ MOVE B,D ; CHANNEL TO B\r
+ HRRZ 0,S.DIR(C) ; AND DIR\r
+ JUMPE 0,TTYSPC\r
+TTY1: DOTCAL TTYGET,[CHANNO(B),[2000,,0],[2000,,A],[2000,,D]]\r
+ FATAL .CALL FAILURE\r
+ DOTCAL TTYSET,[CHANNO(B),MODE1,MODE2,D]\r
+ FATAL .CALL FAILURE\r
+ MOVE A,[PUSHJ P,GMTYO]\r
+ MOVEM A,IOINS(B)\r
+ DOTCAL RSSIZE,[CHANNO(B),[2000,,A],[2000,,D]]\r
+ FATAL .CALL FAILURE\r
+ MOVEM D,LINLN(B)\r
+ MOVEM A,PAGLN(B)\r
+ JRST OPNWIN\r
+\r
+; MAKE AN IOT\r
+\r
+IOTMAK: HRLZ A,CHANNO(B) ; GET CHANNEL\r
+ ROT A,5\r
+ IOR A,[.IOT A] ; BUILD IOT\r
+ MOVEM A,IOINS(B) ; AND STORE IT\r
+ POPJ P,\r
+\f\r
+\r
+; HERE IF POSSIBLY OPENING AN ALREADY OPEN TTY\r
+\r
+SAMTYQ: MOVE D,1(E) ; RESTORE CURRENT CHANNEL\r
+ MOVE A,DIRECT-1(D) ; GET DIR\r
+ MOVE B,DIRECT(D)\r
+ PUSHJ P,STRTO6\r
+ POP P,A ; GET SIXBIT\r
+ MOVE C,T.SPDL+1(TB)\r
+ HRRZ C,S.DIR(C)\r
+ CAME A,MODES(C) ; SKIP IF DIFFERENT DIRECTION\r
+ JRST TTYLP1\r
+\r
+; HERE IF A RE-OPEN ON A TTY\r
+\r
+ HRRZ 0,FSAV(TB) ; IS IT FROM A FOPEN\r
+ CAIN 0,FOPEN\r
+ JRST RETOLD ; RET OLD CHANNEL\r
+\r
+ PUSH TP,$TCHAN\r
+ PUSH TP,1(E) ; PUSH OLD CHANNEL\r
+ PUSH TP,$TFIX\r
+ PUSH TP,T.CHAN+1(TB)\r
+ MOVE A,[PUSHJ P,CHNFIX]\r
+ PUSHJ P,GCHACK\r
+ SUB TP,[4,,4]\r
+ \r
+RETOLD: MOVE B,1(E) ; GET CHANNEL\r
+ AOS CHANNO-1(B) ; AOS REF COUNT\r
+ MOVSI A,TCHAN\r
+ SUB P,[1,,1] ; CLEAN UP STACK\r
+ JRST OPNRET ; AND LEAVE\r
+\r
+\r
+; ROUTINE TO PASS TO GCHACK TO FIX UP CHANNEL POINTER\r
+\r
+CHNFIX: CAIN C,TCHAN\r
+ CAME D,(TP)\r
+ POPJ P,\r
+ MOVE D,-2(TP) ; GET REPLACEMENT\r
+ SKIPE B\r
+ MOVEM D,1(B) ; CLOBBER IT AWAY\r
+ POPJ P,\r
+]\f\r
+\r
+IFE ITS,[\r
+ MOVE C,T.SPDL+1(TB) ; POINT TO P BASE\r
+ HRRZ 0,S.DIR(C) ; 0/ 0 FOR READ 0/ 1 FOR PRINT\r
+ MOVE A,[PUSHJ P,MTYO]\r
+ MOVE B,T.CHAN+1(TB)\r
+ MOVEM A,IOINS(B)\r
+ MOVEI A,100 ; PRIM INPUT JFN\r
+ JUMPN 0,TNXTY1\r
+ MOVEI E,C.OPN+C.READ\r
+ HRRM E,-4(B)\r
+ MOVEM B,CHNL0+2*100+1(TVP)\r
+ JRST TNXTY2\r
+TNXTY1: MOVEM B,CHNL0+2*101+1(TVP)\r
+ MOVEI A,101 ; PRIM OUTPUT JFN\r
+ MOVEI E,C.OPN+C.PRIN\r
+ HRRM E,-4(B)\r
+TNXTY2: MOVEM A,CHANNO(B)\r
+ JUMPN 0,OPNWIN\r
+]\r
+; SETUP FUNNY BUFFER FOR TTY INPUT DEVICES\r
+\r
+TTYSPC: MOVEI A,EXTBFR ; GET EXTRA BUFFER\r
+ PUSHJ P,IBLOCK ; GET BLOCK\r
+ MOVE D,T.CHAN+1(TB) ;RESTORE CHANNEL POINTER\r
+IFN ITS,[\r
+ MOVE A,CHANNO(D)\r
+ LSH A,23.\r
+ IOR A,[.IOT A]\r
+ MOVEM A,IOIN2(B)\r
+]\r
+IFE ITS,[\r
+ MOVE A,[PBIN]\r
+ MOVEM A,IOIN2(B)\r
+]\r
+ MOVSI A,TLIST\r
+ MOVEM A,EXBUFR-1(D) ; FOR WAITING TTY BUFFERS\r
+ SETZM EXBUFR(D) ; NIL LIST\r
+ MOVEM B,BUFRIN(D) ;STORE IN CHANNEL\r
+ MOVSI A,TUVEC ;MAKE SURE TYPE IS UNIFORM VECTOR\r
+ MOVEM A,BUFRIN-1(D)\r
+IFN ITS, MOVEI A,177 ;SET ERASER TO RUBOUT\r
+IFE ITS, MOVEI A,1 ; TRY ^A FOR TENEX\r
+ MOVEM A,ERASCH(B)\r
+ SETZM KILLCH(B) ;NO KILL CHARACTER NEEDED\r
+ MOVEI A,33 ;BREAKCHR TO C.R.\r
+ MOVEM A,BRKCH(B)\r
+ MOVEI A,"\ ;ESCAPER TO \\r
+ MOVEM A,ESCAP(B)\r
+ MOVE A,[010700,,BYTPTR(E)] ;RELATIVE BYTE POINTER\r
+ MOVEM A,BYTPTR(B)\r
+ MOVEI A,14 ;BARF BACK CHARACTER FF\r
+ MOVEM A,BRFCHR(B)\r
+ MOVEI A,^D\r
+ MOVEM A,BRFCH2(B)\r
+\r
+; SETUP DEFAULT TTY INTERRUPT HANDLER\r
+\r
+ PUSH TP,$TATOM\r
+ PUSH TP,MQUOTE CHAR,CHAR,INTRUP\r
+ PUSH TP,$TFIX\r
+ PUSH TP,[10] ; PRIORITY OF CHAR INT\r
+ PUSH TP,$TCHAN\r
+ PUSH TP,D\r
+ MCALL 3,EVENT ; 1ST MAKE AN EVENT EXIST\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ PUSH TP,$TSUBR\r
+ PUSH TP,[QUITTER] ; DEFAULT HANDLER IS QUITTER\r
+ MCALL 2,HANDLER\r
+\r
+; BUILD A NULL STRING\r
+\r
+ MOVEI A,0\r
+ PUSHJ P,IBLOCK ; USE A BLOCK\r
+ MOVE D,T.CHAN+1(TB)\r
+ MOVEI 0,C.BUF\r
+ IORM 0,-4(D)\r
+ HRLI B,440700\r
+ MOVSI A,TCHSTR\r
+ MOVEM A,BUFSTR-1(D)\r
+ MOVEM B,BUFSTR(D)\r
+ MOVEI A,0\r
+ MOVE B,D ; CHANNEL TO B\r
+ JRST MAKION\r
+\f\r
+\r
+; ROUTINE TO OPEN ITS CHANNEL WITHOUT .RCHST\r
+\r
+OPEN2: MOVEI A,S.DEV(C) ; POINT TO OPEN BLOCK\r
+ PUSHJ P,MOPEN ; OPEN THE FILE\r
+ JRST OPNLOS\r
+ MOVE B,T.CHAN+1(TB) ; GET CHANNEL BACK\r
+ MOVEM A,CHANNO(B) ; SAVE THE CHANNEL\r
+ JRST OPEN3\r
+\r
+; FIX UP MODE AND FALL INTO OPEN\r
+\r
+OPEN0: HRRZ A,S.DIR(C) ; GET DIR\r
+ TRNE A,2 ; SKIP IF NOT BLOCK\r
+ IORI A,4 ; TURN ON IMAGE\r
+ IORI A,2 ; AND BLOCK\r
+\r
+ PUSH P,A\r
+ PUSH TP,$TPDL\r
+ PUSH TP,C ; SAVE CRUFT TO CHECK FOR PRINTO, HA HA\r
+ MOVE B,T.CHAN+1(TB)\r
+ MOVE A,DIRECT-1(B)\r
+ MOVE B,DIRECT(B) ; THIS KLUDGE THE MESS OF NDR\r
+ PUSHJ P,STRTO6\r
+ MOVE C,(TP)\r
+ POP P,D ; THE SIXBIT FOR KLUDGE\r
+ POP P,A ; GET BACK THE RANDOM BITS\r
+ SUB TP,[2,,2]\r
+ CAME D,[SIXBIT /PRINTO/]\r
+ JRST OPEN9 ; WELL NOT THIS TIME\r
+ IORI A,100000 ; WRITEOVER BIT\r
+\r
+ HRRZ 0,FSAV(TB)\r
+ CAIN 0,NFOPEN\r
+ IOR A,4 ; DON'T CHANGE REF DATE\r
+OPEN9: HRLM A,S.DEV(C) ; AND STORE IT\r
+\r
+; ROUTINE TO ATTEMPT TO OPEN A REAL ITS CHANNEL\r
+\r
+OPEN1: MOVEI A,S.DEV(C) ; POINT TO OPEN BLOCK\r
+ PUSHJ P,MOPEN\r
+ JRST OPNLOS\r
+ MOVE B,T.CHAN+1(TB) ; GET CHANNEL BACK\r
+ MOVEM A,CHANNO(B) ; CLOBBER INTO CHANNEL\r
+ MOVSI A,(A) ; SET UP READ CHAN STATUS\r
+ HRRI A,S.DEV(C)\r
+ .RCHST A, ; GET THE GOODS\r
+\r
+; NOW CLOBBER THE TVP SLOT FOR THIS CHANNEL\r
+\r
+OPEN3: MOVE A,S.DIR(C)\r
+ MOVEI 0,C.OPN+C.READ\r
+ TRNE A,1\r
+ MOVEI 0,C.OPN+C.PRIN\r
+ TRNE A,2\r
+ TRO 0,C.BIN\r
+ HRRM 0,-4(B)\r
+ MOVE A,CHANNO(B) ; GET CHANNEL #\r
+ ASH A,1\r
+ ADDI A,CHNL0(TVP) ; POINT TO SLOT\r
+ MOVEM B,1(A) ; NOT: TYPE ALREADY SETUP\r
+\r
+; NOW GET STATUS WORD\r
+\r
+DOSTAT: HRLZ A,CHANNO(B) ; NOW GET STATUS WORD\r
+ ROT A,5\r
+ IOR A,[.STATUS STATUS(B)] ; GET INS\r
+ XCT A ; AND DO IT\r
+ POPJ P,\r
+\f\r
+\r
+; HERE IF OPEN FAILS (CHANNEL IS IN A)\r
+\r
+OPNLOS: JUMPL A,NOCHAN ; ALL CHANNELS ARE IN USE\r
+ LSH A,23. ; DO A .STATUS\r
+ IOR A,[.STATUS A]\r
+ XCT A ; STATUS TO A\r
+ PUSHJ P,GFALS ; GET A FALSE WITH A MESSAGE\r
+ SUB P,[1,,1] ; EXTRA RET ADDR FLUSHED\r
+ JRST OPNRET ; AND RETURN\r
+\r
+; ROUTINE TO CONS UP FALSE WITH REASON\r
+\r
+GFALS: PUSH P,[SIXBIT / ERR/] ; SET UP OPEN TO ERR DEV\r
+ PUSH P,[3] ; SAY ITS FOR CHANNEL\r
+ PUSH P,A\r
+ .OPEN 0,-2(P) ; USE CHANNEL 0 FOR THIS\r
+ FATAL CAN'T OPEN ERROR DEVICE\r
+ SUB P,[3,,3] ; DONT WANT OPEN BLOCK NOW\r
+ MOVEI A,0 ; PREPARE TO BUILD STRING ON STACK\r
+EL1: PUSH P,[0] ; WHERE IT WILL GO\r
+ MOVSI B,(<440700,,(P)>) ; BYTE POINTER TO TOP OF STACK\r
+EL2: .IOT 0,0 ; GET A CHAR\r
+ JUMPL 0,EL3 ; JUMP ON -1,,3\r
+ CAIN 0,3 ; EOF?\r
+ JRST EL3 ; YES, MAKE STRING\r
+ CAIN 0,14 ; IGNORE FORM FEEDS\r
+ JRST EL2 ; IGNORE FF\r
+ CAIE 0,15 ; IGNORE CR & LF\r
+ CAIN 0,12\r
+ JRST EL2\r
+ IDPB 0,B ; STUFF IT\r
+ TLNE B,760000 ; SIP IF WORD FULL\r
+ AOJA A,EL2\r
+ AOJA A,EL1 ; COUNT WORD AND GO\r
+\r
+EL3: SKIPN (P) ; ANY CHARS AT END?\r
+ SUB P,[1,,1] ; FLUSH XTRA\r
+ PUSH P,A ; PUT UP COUNT\r
+ .CLOSE 0, ; CLOSE THE ERR DEVICE\r
+ PUSHJ P,CHMAK ; MAKE STRING\r
+ MOVE C,A\r
+ MOVE D,B ; COPY STRING\r
+ PUSHJ P,INCONS ; CONS TO NIL\r
+ MOVSI A,TFALSE ; MAKEIT A FALSE\r
+ POPJ P,\r
+\f\r
+\r
+; ROUTINE TO FILL IN THE "REAL" SLOTS FOR THE CHANNEL\r
+\r
+FIXREA: HRLZS S.DEV(C) ; KILL MODE BITS\r
+ MOVE D,[-4,,S.DEV]\r
+\r
+FIXRE1: MOVEI A,(D) ; COPY REL POINTER\r
+ ADD A,T.SPDL+1(TB) ; POINT TO SLOT\r
+ SKIPN A,(A) ; SKIP IF GOODIE THERE\r
+ JRST FIXRE2\r
+ PUSHJ P,6TOCHS ; MAKE INOT A STRING\r
+ MOVE C,RDTBL-S.DEV(D); GET OFFSET\r
+ ADD C,T.CHAN+1(TB)\r
+ MOVEM A,-1(C)\r
+ MOVEM B,(C)\r
+FIXRE2: AOBJN D,FIXRE1\r
+ POPJ P,\r
+\r
+DOOPN: PUSH P,A\r
+ HRLZ A,CHANNO(B) ; GET CHANNEL\r
+ ASH A,5\r
+ HRR A,(P) ; POINT\r
+ TLO A,(.OPEN)\r
+ XCT A\r
+ SKIPA\r
+ AOS -1(P)\r
+ POP P,A\r
+ POPJ P,\r
+\f\r
+;THIS ROUTINE CONVERTS MUDDLE CHARACTER STRINGS TO SIXBIT FILE NAMES\r
+STRTO6: PUSH TP,A\r
+ PUSH TP,B\r
+ PUSH P,E ;SAVE USEFUL FROB\r
+ MOVEI E,(A) ; CHAR COUNT TO E\r
+ GETYP A,A\r
+ CAIE A,TCHSTR ; IS IT ONE WORD?\r
+ JRST WRONGT ;NO\r
+CHREAD: MOVEI A,0 ;INITIALIZE OUTPUT WORD\r
+ MOVE D,[440600,,A] ;AND BYTE POINTER TO IT\r
+NEXCHR: SOJL E,SIXDON\r
+ ILDB 0,B ; GET NEXT CHAR\r
+ JUMPE 0,SIXDON ;IF NULL, WE ARE FINISHED\r
+ PUSHJ P,A0TO6 ; CONVERT TO SIXBIT\r
+ IDPB 0,D ;DEPOSIT INTO SIX BIT\r
+ TRNN A,77 ;IS OUTPUT FULL\r
+ JRST NEXCHR ; NO, GET NEXT\r
+SIXDON: SUB TP,[2,,2] ;FIX UP TP\r
+ POP P,E\r
+ EXCH A,(P) ;LEAVE RESULT ON P-STACK\r
+ JRST (A) ;NOW RETURN\r
+\r
+\r
+;SUBROUTINE TO CONVERT SIXBIT TO ATOM\r
+\r
+6TOCHS: PUSH P,E\r
+ PUSH P,D\r
+ MOVEI B,0 ;MAX NUMBER OF CHARACTERS\r
+ PUSH P,[0] ;STRING WILL GO ON P SATCK\r
+ JUMPE A,GETATM ; EMPTY, LEAVE\r
+ MOVEI E,-1(P) ;WILL BE BYTE POINTER\r
+ HRLI E,10700 ;SET IT UP\r
+ PUSH P,[0] ;SECOND POSSIBLE WORD\r
+ MOVE D,[440600,,A] ;INPUT BYTE POINTER\r
+6LOOP: ILDB 0,D ;START CHAR GOBBLING\r
+ ADDI 0,40 ;CHANGET TOASCII\r
+ IDPB 0,E ;AND STORE IT\r
+ TLNN D,770000 ; SKIP IF NOT DONE\r
+ JRST 6LOOP1\r
+ TDNN A,MSKS(B) ; CHECK IF JUST SPACES LEFT\r
+ AOJA B,GETATM ; YES, DONE\r
+ AOJA B,6LOOP ;KEEP LOOKING\r
+6LOOP1: PUSH P,[6] ;IF ARRIVE HERE, STRING IS 2 WORDS\r
+ JRST .+2\r
+GETATM: MOVEM B,(P) ;SET STRING LENGTH=1\r
+ PUSHJ P,CHMAK ;MAKE A MUDDLE STRING\r
+ POP P,D\r
+ POP P,E\r
+ POPJ P,\r
+\r
+MSKS: 7777,,-1\r
+ 77,,-1\r
+ ,,-1\r
+ 7777\r
+ 77\r
+\r
+\r
+; CONVERT ONE CHAR\r
+\r
+A0TO6: CAIL 0,141 ;IF IT IS GREATER OR EQUAL TO LOWER A\r
+ CAILE 0,172 ;BUT LESS THAN OR EQUAL TO LOWER Z\r
+ JRST .+2 ;THEN\r
+ SUBI 0,40 ;CONVERT TO UPPER CASE\r
+ SUBI 0,40 ;NOW TO SIX BIT\r
+ JUMPL 0,BAD6 ;CHECK FOR A WINNER\r
+ CAILE 0,77\r
+ JRST BAD6\r
+ POPJ P,\r
+\f\r
+; SUBR TO DELETE AND RENAME FILES\r
+\r
+MFUNCTION RENAME,SUBR\r
+\r
+ ENTRY\r
+\r
+ JUMPGE AB,TFA\r
+ PUSH TP,$TPDL\r
+ PUSH TP,P ; SAVE P-STACK BASE\r
+ GETYP 0,(AB) ; GET 1ST ARG TYPE\r
+IFN ITS,[\r
+ CAIN 0,TCHAN ; CHANNEL?\r
+ JRST CHNRNM ; MUST BE RENAME WHILE OPEN FOR WRITING\r
+]\r
+IFE ITS,[\r
+ PUSH P,[100000,,0]\r
+ PUSH P,[377777,,377777]\r
+]\r
+ MOVSI E,-4 ; 4 THINGS TO PUSH\r
+RNMALP: MOVE B,@RNMTBL(E)\r
+ PUSH P,E\r
+ PUSHJ P,IDVAL1\r
+ POP P,E\r
+ GETYP 0,A\r
+ CAIE 0,TCHSTR ; SKIP IF WINS\r
+ JRST RNMLP1\r
+\r
+IFN ITS, PUSHJ P,STRTO6 ; CONVERT TO SIXBIT\r
+IFE ITS, PUSH P,B ; PUSH BYTE POINTER\r
+ JRST .+2\r
+\r
+RNMLP1: PUSH P,RNSTBL(E) ; USE DEFAULT\r
+ AOBJN E,RNMALP\r
+\r
+IFN ITS,[\r
+ PUSHJ P,RGPRS ; PARSE THE ARGS\r
+ JRST RNM1 ; COULD BE A RENAME\r
+\r
+; HERE TO DELETE A FILE\r
+\r
+DELFIL: MOVEI A,0 ; SETUP FDELE\r
+ EXCH A,(P) ; AND GET SNAME\r
+ .SUSET [.SSNAM,,A]\r
+ HLRZS -3(P) ; FIXUP DEVICE\r
+ .FDELE -3(P) ; DO IT TO IT\r
+ JRST FDLST ; ANALYSE ERROR\r
+\r
+FDLWON: MOVSI A,TATOM\r
+ MOVE B,MQUOTE T\r
+ JRST FINIS\r
+]\r
+IFE ITS,[\r
+ MOVE A,(TP) ; GET BASE OF PDL\r
+ MOVEI A,1(A) ; POINT TO CRAP\r
+ MOVE B,1(AB) ; STRING POINTER\r
+ PUSH P,[0]\r
+ PUSH P,[0]\r
+ PUSH P,[0]\r
+ GTJFN ; GET A JFN\r
+ JRST TDLLOS ; LOST\r
+ ADD AB,[2,,2] ; PAST ARG\r
+ JUMPL AB,RNM1 ; GO TRY FOR RENAME\r
+ MOVE P,(TP) ; RESTORE P STACK\r
+ MOVEI C,(A) ; FOR RELEASE\r
+ DELF ; ATTEMPT DELETE\r
+ JRST DELLOS ; LOSER\r
+ RLJFN ; MAKE SURE FLUSHED\r
+ JFCL\r
+\r
+FDLWON: MOVSI A,TATOM\r
+ MOVE B,MQUOTE T\r
+ JRST FINIS\r
+\r
+RNMLOS: PUSH P,A\r
+ MOVEI A,(B)\r
+ RLJFN\r
+ JFCL\r
+DELLO1: MOVEI A,(C)\r
+ RLJFN\r
+ JFCL\r
+ POP P,A ; ERR NUMBER BACK\r
+TDLLOS: PUSHJ P,TGFALS ; GET FALSE WITH REASON\r
+ JRST FINIS\r
+\r
+DELLOS: PUSH P,A ; SAVE ERROR\r
+ JRST DELLO1\r
+]\r
+\r
+;TABLE OF REANMAE DEFAULTS\r
+IFN ITS,[\r
+RNMTBL: IMQUOTE DEV\r
+ IMQUOTE NM1\r
+ IMQUOTE NM2\r
+ IMQUOTE SNM\r
+\r
+RNSTBL: SIXBIT /DSK _MUDS_> /\r
+]\r
+IFE ITS,[\r
+RNMTBL: IMQUOTE DEV\r
+ IMQUOTE SNM\r
+ IMQUOTE NM1\r
+ IMQUOTE NM2\r
+\r
+RNSTBL: -1,,[ASCIZ /DSK/]\r
+ 0\r
+ -1,,[ASCIZ /_MUDS_/]\r
+ -1,,[ASCIZ /MUD/]\r
+]\r
+; HERE TO DO A RENAME\r
+\r
+RNM1: JUMPGE AB,TMA ; IF ARGS EXHAUSTED, MUST BE TOO MUCH STRING\r
+ GETYP 0,(AB)\r
+ MOVE C,1(AB) ; GET ARG\r
+ CAIN 0,TATOM ; IS IT "TO"\r
+ CAME C,MQUOTE TO\r
+ JRST WRONGT ; NO, LOSE\r
+ ADD AB,[2,,2] ; BUMP PAST "TO"\r
+ JUMPGE AB,TFA\r
+IFN ITS,[\r
+ MOVEM P,T.SPDL+1(TB) ; SAVE NEW P-BASE\r
+\r
+ MOVEI 0,4 ; FOUR DEFAULTS\r
+ PUSH P,-3(P) ; DEFAULT DEVICE IS CURRENT\r
+ SOJN 0,.-1\r
+\r
+ PUSHJ P,RGPRS ; PARSE THE NEXT STRING\r
+ JRST TMA\r
+\r
+ HLRZS A,-7(P) ; FIX AND GET DEV1\r
+ HLRZS B,-3(P) ; SAME FOR DEV2\r
+ CAIE A,(B) ; SAME?\r
+ JRST DEVDIF\r
+\r
+ POP P,A ; GET SNAME 2\r
+ CAME A,(P)-3 ; SNAME 1\r
+ JRST DEVDIF\r
+ .SUSET [.SSNAM,,A]\r
+ POP P,-2(P) ; MOVE NAMES DOWN\r
+ POP P,-2(P)\r
+ .FDELE -4(P) ; TRY THE RENAME\r
+ JRST FDLST\r
+ JRST FDLWON\r
+\r
+; HERE FOR RENAME WHILE OPEN FOR WRITING\r
+\r
+CHNRNM: ADD AB,[2,,2] ; NEXT ARG\r
+ JUMPGE AB,TFA\r
+ MOVE B,-1(AB) ; GET CHANNEL\r
+ SKIPN CHANNO(B) ; SKIP IF OPEN\r
+ JRST BADCHN\r
+ MOVE A,DIRECT-1(B) ; CHECK DIRECTION\r
+ MOVE B,DIRECT(B)\r
+ PUSHJ P,STRTO6 ; TO 6 BIT\r
+ POP P,A\r
+ CAME A,[SIXBIT /PRINT/]\r
+ CAMN A,[SIXBIT /PRINTB/]\r
+ JRST CHNRN1\r
+ CAME A,[SIXBIT /PRINTO/]\r
+ JRST WRONGD\r
+\r
+; SET UP .FDELE BLOCK\r
+\r
+CHNRN1: PUSH P,[0]\r
+ PUSH P,[0]\r
+ MOVEM P,T.SPDL+1(TB)\r
+ PUSH P,[0]\r
+ PUSH P,[SIXBIT /_MUDL_/]\r
+ PUSH P,[SIXBIT />/]\r
+ PUSH P,[0]\r
+\r
+ PUSHJ P,RGPRS ; PARSE THESE\r
+ JRST TMA\r
+\r
+ SUB P,[1,,1] ; SNAME/DEV IGNORED\r
+ MOVE AB,ABSAV(TB) ; GET ORIG ARG POINTER\r
+ MOVE B,1(AB)\r
+ MOVE A,CHANNO(B) ; ITS CHANNEL #\r
+ MOVEM A,-2(P)\r
+ .FDELE -4(P)\r
+ JRST FDLST\r
+ MOVEI A,-4(P) ; SET UP FOR RDCHST\r
+ HRL A,CHANNO(B)\r
+ .RCHST A,\r
+ MOVE A,-3(P) ; UPDATE CHANNEL\r
+ PUSHJ P,6TOCHS ; GET A STRING\r
+ MOVE C,1(AB)\r
+ MOVEM A,RNAME1-1(C)\r
+ MOVEM B,RNAME1(C)\r
+ MOVE A,-2(P)\r
+ PUSHJ P,6TOCHS\r
+ MOVE C,1(AB)\r
+ MOVEM A,RNAME2-1(C)\r
+ MOVEM B,RNAME2(C)\r
+ MOVE B,1(AB)\r
+ MOVSI A,TCHAN\b\r
+ JRST FINIS\r
+]\r
+IFE ITS,[\r
+ PUSH P,A\r
+ MOVE A,(TP) ; PBASE BACK\r
+ PUSH A,[400000,,0]\r
+ MOVEI A,(A)\r
+ MOVE B,1(AB)\r
+ GTJFN\r
+ JRST TDLLOS\r
+ POP P,B\r
+ EXCH A,B\r
+ MOVEI C,(A) ; FOR RELEASE ATTEMPT\r
+ RNAMF\r
+ JRST RNMLOS\r
+ MOVEI A,(B)\r
+ RLJFN ; FLUSH JFN\r
+ JFCL\r
+ MOVEI A,(C) ; MAKE SURR OTHER IS FLUSHED\r
+ RLJFN\r
+ JFCL\r
+ JRST FDLWON\r
+]\r
+; HERE FOR LOSING .FDELE\r
+\r
+FDLST: .STATUS 0,A ; GET STATUS\r
+ PUSHJ P,GFALS ; ANALYZE IT\r
+ JRST FINIS\r
+\r
+; SOME .FDELE ERRORS\r
+\r
+DEVDIF: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE DEVICE-OR-SNAME-DIFFERS\r
+ JRST CALER1\r
+\r
+\f; HERE TO RESET A READ CHANNEL\r
+\r
+MFUNCTION FRESET,SUBR,RESET\r
+\r
+ ENTRY 1\r
+ GETYP A,(AB)\r
+ CAIE A,TCHAN\r
+ JRST WTYP1\r
+ MOVE B,1(AB) ;GET CHANNEL\r
+ SKIPN IOINS(B) ; OPEN?\r
+ JRST REOPE1 ; NO, IGNORE CHECKS\r
+IFN ITS,[\r
+ MOVE A,STATUS(B) ;GET STATUS\r
+ ANDI A,77\r
+ JUMPE A,REOPE1 ;IF IT CLOSED, JUST REOPEN IT, MAYBE?\r
+ CAILE A,2 ;SKIPS IF TTY FLAVOR\r
+ JRST REOPEN\r
+]\r
+IFE ITS,[\r
+ MOVE A,CHANNO(B)\r
+ CAIE A,100 ; TTY-IN\r
+ CAIN A,101 ; TTY-OUT\r
+ JRST .+2\r
+ JRST REOPEN\r
+]\r
+ CAME B,TTICHN+1(TVP)\r
+ CAMN B,TTOCHN+1(TVP)\r
+ JRST REATTY\r
+REATT1: MOVEI B,DIRECT-1(B) ;POINT TO DIRECTION\r
+ PUSHJ P,CHRWRD ;CONVERT TO A WORD\r
+ JFCL\r
+ CAME B,[ASCII /READ/]\r
+ JRST TTYOPN\r
+ MOVE B,1(AB) ;RESTORE CHANNEL\r
+ PUSHJ P,RRESET" ;DO REAL RESET\r
+ JRST TTYOPN\r
+\r
+REOPEN: PUSH TP,(AB) ;FIRST CLOSE IT\r
+ PUSH TP,(AB)+1\r
+ MCALL 1,FCLOSE\r
+ MOVE B,1(AB) ;RESTORE CHANNEL\r
+\r
+; SET UP TEMPS FOR OPNCH\r
+\r
+REOPE1: PUSH P,[0] ; WILL HOLD DIR CODE\r
+ PUSH TP,$TPDL\r
+ PUSH TP,P\r
+ IRP A,,[DIRECT,RNAME1,RNAME2,RDEVIC,RSNAME,ACCESS]\r
+ PUSH TP,A-1(B)\r
+ PUSH TP,A(B)\r
+ TERMIN\r
+\r
+ PUSH TP,$TCHAN\r
+ PUSH TP,1(AB)\r
+\r
+ MOVE A,T.DIR(TB)\r
+ MOVE B,T.DIR+1(TB) ; GET DIRECTION\r
+ PUSHJ P,CHMOD ; CHECK THE MODE\r
+ MOVEM A,(P) ; AND STORE IT\r
+\r
+; NOW SET UP OPEN BLOCK IN SIXBIT\r
+IFN ITS,[\r
+ MOVSI E,-4 ; AOBN PNTR\r
+FRESE2: MOVE B,T.CHAN+1(TB)\r
+ MOVEI A,@RDTBL(E) ; GET ITEM POINTER\r
+ GETYP 0,-1(A) ; GET ITS TYPE\r
+ CAIE 0,TCHSTR\r
+ JRST FRESE1\r
+ MOVE B,(A) ; GET STRING\r
+ MOVE A,-1(A)\r
+ PUSHJ P,STRTO6\r
+FRESE3: AOBJN E,FRESE2\r
+ HLRZS -3(P) ; FIX DEVICE SPEC\r
+]\r
+IFE ITS,[\r
+ MOVE B,T.CHAN+1(TB)\r
+ MOVE A,RDEVIC-1(B)\r
+ MOVE B,RDEVIC(B)\r
+ PUSHJ P,STRTO6 ; RESULT ON STACK\r
+ HLRZS (P)\r
+]\r
+\r
+ PUSH P,[0] ; PUSH UP SOME DUMMIES\r
+ PUSH P,[0]\r
+ PUSH P,[0]\r
+ PUSHJ P,OPNCH ; ATTEMPT TO DO THEOPEN\r
+ GETYP 0,A\r
+ CAIE 0,TCHAN\r
+ JRST FINIS ; LEAVE IF FALSE OR WHATEVER\r
+\r
+DRESET: MOVE A,(AB)\r
+ MOVE B,1(AB)\r
+ SETZM CHRPOS(B) ;INITIALIZE THESE PARAMETERS\r
+ SETZM LINPOS(B)\r
+ SETZM ACCESS(B)\r
+ JRST FINIS\r
+\r
+TTYOPN: MOVE B,1(AB)\r
+ CAME B,TTOCHN+1(TVP)\r
+ CAMN B,TTICHN+1(TVP)\r
+ PUSHJ P,TTYOP2\r
+ PUSHJ P,DOSTAT\r
+ DOTCAL RSSIZE,[CHANNO(B),[2000,,C],[2000,,D]]\r
+ FATAL .CALL FAILURE\r
+ MOVEM C,PAGLN(B)\r
+ MOVEM D,LINLN(B)\r
+ JRST DRESET\r
+\r
+IFN ITS,[\r
+FRESE1: CAIE 0,TFIX\r
+ JRST BADCHN\r
+ PUSH P,(A)\r
+ JRST FRESE3\r
+]\r
+\r
+; INTERFACE TO REOPEN CLOSED CHANNELS\r
+\r
+OPNCHN: PUSH TP,$TCHAN\r
+ PUSH TP,B\r
+ MCALL 1,FRESET\r
+ POPJ P,\r
+\r
+REATTY: PUSHJ P,TTYOP2\r
+ SKIPE NOTTY\r
+ JRST DRESET\r
+ MOVE B,1(AB)\r
+ JRST REATT1\r
+\f\r
+; FUNCTION TO LIST ALL CHANNELS\r
+\r
+MFUNCTION CHANLIST,SUBR\r
+\r
+ ENTRY 0\r
+\r
+ MOVEI A,N.CHNS-1 ;MAX # OF REAL CHANNELS\r
+ MOVEI C,0\r
+ MOVEI B,CHNL1(TVP) ;POINT TO FIRST REAL CHANNEL\r
+\r
+CHNLP: SKIPN 1(B) ;OPEN?\r
+ JRST NXTCHN ;NO, SKIP\r
+ HRRZ E,(B) ; ABOUT TO FLUSH?\r
+ JUMPN E,NXTCHN ; YES, FORGET IT\r
+ MOVE D,1(B) ; GET CHANNEL\r
+ HRRZ E,CHANNO-1(D) ; GET REF COUNT\r
+ PUSH TP,(B)\r
+ PUSH TP,1(B)\r
+ ADDI C,1 ;COUNT WINNERS\r
+ SOJGE E,.-3 ; COUNT THEM\r
+NXTCHN: ADDI B,2\r
+ SOJN A,CHNLP\r
+\r
+ SKIPN B,CHNL0(TVP)+1 ;NOW HACK LIST OF PSUEDO CHANNELS\r
+ JRST MAKLST\r
+CHNLS: PUSH TP,(B)\r
+ PUSH TP,(B)+1\r
+ ADDI C,1\r
+ HRRZ B,(B)\r
+ JUMPN B,CHNLS\r
+\r
+MAKLST: ACALL C,LIST\r
+ JRST FINIS\r
+\r
+\f; ROUTINE TO RESTORE A CLOSED CHANNEL TO ITS PREVIOUS STATE\r
+\r
+\r
+REOPN: PUSH TP,$TCHAN\r
+ PUSH TP,B\r
+ SKIPN CHANNO(B) ; ONLY REAL CHANNELS\r
+ JRST PSUEDO\r
+\r
+IFN ITS,[\r
+ MOVSI E,-4 ; SET UP POINTER FOR NAMES\r
+\r
+GETOPB: MOVE B,(TP) ; GET CHANNEL\r
+ MOVEI A,@RDTBL(E) ; GET POINTER\r
+ MOVE B,(A) ; NOW STRING\r
+ MOVE A,-1(A)\r
+ PUSHJ P,STRTO6 ; LEAVES SIXBIT ON STACK\r
+ AOBJN E,GETOPB\r
+]\r
+IFE ITS,[\r
+ MOVE A,RDEVIC-1(B)\r
+ MOVE B,RDEVIC(B)\r
+ PUSHJ P,STRTO6 ; GET DEV NAME IN SIXBIT\r
+]\r
+ MOVE B,(TP) ; RESTORE CHANNEL\r
+ MOVE A,DIRECT-1(B)\r
+ MOVE B,DIRECT(B)\r
+ PUSHJ P,CHMOD ; CHECK FOR A VALID MODE\r
+\r
+IFN ITS, HLRZS E,-3(P) ; GET DEVICE IN PROPER PLACE\r
+IFE ITS, HLRZS E,(P)\r
+ MOVE B,(TP) ; RESTORE CHANNEL\r
+ CAIN E,(SIXBIT /DSK/)\r
+ JRST DISKH ; DISK WINS IMMEIDATELY\r
+ CAIN E,(SIXBIT /TTY/) ; NO NEED TO RE-OPEN THE TTY\r
+ JRST REOPD1\r
+IFN ITS,[\r
+ ANDI E,777700 ; COULD BE "UTn"\r
+ MOVE D,CHANNO(B) ; GET CHANNEL\r
+ ASH D,1\r
+ ADDI D,CHNL0(TVP) ; DON'T SEEM TO BE OPEN\r
+ SETZM 1(D)\r
+ SETZM CHANNO(B)\r
+ CAIN E,(SIXBIT /UT /)\r
+ JRST REOPD ; CURRENTLY, CANT RESTORE UTAPE CHANNLES\r
+ CAIN E,(SIXBIT /AI /)\r
+ JRST REOPD ; CURRENTLY CANT RESTORE AI CHANNELS\r
+ CAIN E,(SIXBIT /ML /)\r
+ JRST REOPD ; CURRENTLY CANT RESTORE ML CHANNELS\r
+ CAIN E,(SIXBIT /DM /)\r
+ JRST REOPD ; CURRENTLY CANT RESTORE DM CHANNELS\r
+]\r
+ PUSH TP,$TCHAN ; TRY TO RESET IT \r
+ PUSH TP,B\r
+ MCALL 1,FRESET\r
+\r
+IFN ITS,[\r
+REOPD1: AOS -4(P)\r
+REOPD: SUB P,[4,,4]\r
+]\r
+IFE ITS,[\r
+REOPD1: AOS -1(P)\r
+REOPD: SUB P,[1,,1]\r
+]\r
+REOPD0: SUB TP,[2,,2]\r
+ POPJ P,\r
+\r
+IFN ITS,[\r
+DISKH: MOVE C,(P) ; SNAME\r
+ .SUSET [.SSNAM,,C]\r
+]\r
+IFE ITS,[\r
+DISKH: MOVEM A,(P) ; SAVE MODE WORD\r
+ PUSHJ P,STSTK ; STRING TO STACK\r
+ MOVE A,(E) ; RESTORE MODE WORD\r
+ PUSH TP,$TPDL\r
+ PUSH TP,E ; SAVE PDL BASE\r
+ MOVE B,-2(TP) ; CHANNEL BACK TO B\r
+]\r
+ MOVE C,ACCESS(B) ; GET CHANNELS ACCESS\r
+ TRNN A,2 ; SKIP IF NOT ASCII CHANNEL\r
+ JRST DISKH1\r
+ HRRZ D,ACCESS-1(B) ; IF PARTIAL WORD OUT\r
+ IMULI C,5 ; TO CHAR ACCESS\r
+ JUMPE D,DISKH1 ; NO SWEAT\r
+ ADDI C,(D)\r
+ SUBI C,5\r
+DISKH1: HRRZ D,BUFSTR-1(B) ; ANY CHARS IN MUDDLE BUFFER\r
+ JUMPE D,DISKH2\r
+ PUSH P,A\r
+ PUSH P,C\r
+ MOVEI C,BUFSTR-1(B)\r
+ PUSHJ P,BYTDOP ; FIND LENGTH OF WHOLE BUFFER\r
+ HLRZ D,(A) ; LENGTH + 2 TO D\r
+ SUBI D,2\r
+ IMULI D,5 ; TO CHARS\r
+ POP P,C\r
+ POP P,A\r
+DISKH2: SUBI C,(D) ; UPDATE CHAR ACCESS\r
+ IDIVI C,5 ; BACK TO WORD ACCESS\r
+ IORI A,6 ; BLOCK IMAGE\r
+IFN ITS,[\r
+ TRNE A,1\r
+ IORI A,100000 ; WRITE OVER BIT\r
+ HRLM A,-3(P)\r
+ MOVEI A,-3(P)\r
+ PUSHJ P,DOOPN\r
+ JRST REOPD\r
+ MOVE A,C ; ACCESS TO A\r
+ PUSHJ P,GETFLN ; CHECK LENGTH\r
+ CAIGE 0,(A) ; CHECK BOUNDS\r
+ JRST .+3 ; COMPLAIN\r
+ PUSHJ P,DOACCS ; AND ACESS\r
+ JRST REOPD1 ; SUCCESS\r
+\r
+ MOVE A,CHANNO(B) ; CLOSE THE G.D. CHANNEL\r
+ PUSHJ P,MCLOSE\r
+ JRST REOPD\r
+\r
+DOACCS: PUSH P,A\r
+ HRLZ A,CHANNO(B)\r
+ ASH A,5\r
+ IOR A,[.ACCESS (P)]\r
+ XCT A\r
+ POP P,A\r
+ POPJ P,\r
+\r
+DOIOTO:\r
+DOIOTI:\r
+DOIOT:\r
+ PUSH P,0\r
+ MOVSI 0,TCHAN\r
+ MOVEM 0,BSTO(PVP) ; IN CASE OF INTERRUPT\r
+ ENABLE\r
+ HRLZ 0,CHANNO(B)\r
+ ASH 0,5\r
+ IOR 0,[.IOT A]\r
+ XCT 0\r
+ DISABLE\r
+ SETZM BSTO(PVP)\r
+ POP P,0\r
+ POPJ P,\r
+\r
+GETFLN: MOVE 0,CHANNO(B) ; GET CHANNEL\r
+ .CALL FILBLK ; READ LNTH\r
+ .VALUE\r
+ POPJ P,\r
+\r
+FILBLK: SETZ\r
+ SIXBIT /FILLEN/\r
+ 0\r
+ 402000,,0 ; STUFF RESULT IN 0\r
+]\r
+IFE ITS,[\r
+\r
+ HRROI B,1(E) ; TENEX STRING POINTER\r
+ MOVEI A,1(P) ; A POINT TO BLOCK OF INFO\r
+ PUSH P,[100400,,0] ; FORCE JFN REUSE AND ONLY ACCEPT EXISTING FILE\r
+ PUSH P,[377777,,377777] ; NO I/O FOR CORRECTIONS ETC.\r
+ REPEAT 6,PUSH P,[0] ; OTHER SLOTS\r
+ MOVE D,-2(TP) ; CHANNEL BACK\r
+ PUSH P,CHANNO(D) ; AND DESIRED JFN\r
+ GTJFN ; GO GET IT\r
+ JRST RGTJL ; COMPLAIN\r
+ MOVE P,(TP) ; RESTORE P\r
+ MOVE A,(P) ; MODE WORD BACK\r
+ MOVE B,[440000,,200000] ; FLAG BITS\r
+ TRNE A,1 ; SKIP FOR INPUT\r
+ TRC B,300000 ; CHANGE TO WRITE\r
+ MOVE A,CHANNO(D) ; GET JFN\r
+ OPENF\r
+ JRST ROPFLS\r
+ MOVE E,C ; LENGTH TO E\r
+ SIZEF ; GET CURRENT LENGTH\r
+ JRST ROPFLS\r
+ CAMGE B,E ; STILL A WINNER\r
+ JRST ROPFLS\r
+ MOVE A,-2(TP) ; CHANNEL\r
+ MOVE A,CHANNO(A) ; JFN\r
+ MOVE B,C\r
+ SFPTR\r
+ JRST ROPFLS\r
+ SUB TP,[2,,2] ; FLUSH PDL POINTER\r
+ JRST REOPD1\r
+\r
+ROPFLS: MOVE A,-2(TP)\r
+ MOVE A,CHANNO(A)\r
+ CLOSF ; ATTEMPT TO CLOSE\r
+ JFCL ; IGNORE FAILURE\r
+ SKIPA\r
+\r
+RGTJL: MOVE P,(TP)\r
+ SUB TP,[2,,2]\r
+ JRST REOPD\r
+\r
+DOACCS: PUSH P,B\r
+ EXCH A,B\r
+ MOVE A,CHANNO(A)\r
+ SFPTR\r
+ JRST ACCFAI\r
+ POP P,B\r
+ POPJ P,\r
+]\r
+PSUEDO: AOS (P) ; ASSUME SUCCESS FOR NOW\r
+ MOVEI B,RDEVIC-1(B) ; SEE WHAT DEVICE IS\r
+ PUSHJ P,CHRWRD\r
+ JFCL\r
+ CAME B,[ASCII /E&S/] ; DISPLAY ?\r
+ CAMN B,[ASCII /DIS/]\r
+ SKIPA B,(TP) ; YES, REGOBBLE CHANNEL AND CONTINUE\r
+ JRST REOPD0 ; NO, RETURN HAPPY\r
+ PUSHJ P,DISROP\r
+ SOS (P) ; DISPLAY DID NOT REOPEN, UNDO ASSUMPTION OF SUCCESS\r
+ JRST REOPD0\r
+\r
+\f;THIS PROGRAM CLOSES THE SPECIFIED CHANNEL\r
+\r
+MFUNCTION FCLOSE,SUBR,[CLOSE]\r
+\r
+ ENTRY 1 ;ONLY ONE ARG\r
+ GETYP A,(AB) ;CHECK ARGS\r
+ CAIE A,TCHAN ;IS IT A CHANNEL\r
+ JRST WTYP1\r
+ MOVE B,1(AB) ;PICK UP THE CHANNEL\r
+ HRRZ A,CHANNO-1(B) ; GET REF COUNT\r
+ SOJGE A,CFIN5 ; NOT READY TO REALLY CLOSE\r
+ CAME B,TTICHN+1(TVP) ; CHECK FOR TTY\r
+ CAMN B,TTOCHN+1(TVP)\r
+ JRST CLSTTY\r
+ MOVE A,[JRST CHNCLS]\r
+ MOVEM A,IOINS(B) ;CLOBBER THE IO INS\r
+ MOVE A,RDEVIC-1(B) ;GET THE NAME OF THE DEVICE\r
+ MOVE B,RDEVIC(B)\r
+ PUSHJ P,STRTO6\r
+ HLRZS A,(P)\r
+ MOVE B,1(AB) ; RESTORE CHANNEL\r
+ CAIE A,(SIXBIT /E&S/)\r
+ CAIN A,(SIXBIT /DIS/)\r
+ PUSHJ P,DISCLS\r
+ MOVE B,1(AB) ; IN CASE CLOBBERED BY DISCLS\r
+ SKIPN A,CHANNO(B) ;ANY REAL CHANNEL?\r
+ JRST REMOV ; NO, EITHER CLOSED OR PSEUDO CHANNEL\r
+\r
+ MOVE A,DIRECT-1(B) ; POINT TO DIRECTION\r
+ MOVE B,DIRECT(B)\r
+ PUSHJ P,STRTO6 ; CONVERT TO WORD\r
+ POP P,A\r
+ LDB E,[140600,,(P)] ; FIRST CHAR OD DEV NAME\r
+ CAIE E,'T ; SKIP IF TTY\r
+ JRST CFIN4\r
+ CAME A,[SIXBIT /READ/] ; SKIP IF WINNER\r
+ JRST CFIN1\r
+IFN ITS,[\r
+ MOVE B,1(AB) ; IN ITS CHECK STATUS\r
+ LDB A,[600,,STATUS(B)]\r
+ CAILE A,2\r
+ JRST CFIN1\r
+]\r
+ PUSH TP,$TCHSTR\r
+ PUSH TP,CHQUOTE CHAR\r
+ PUSH TP,(AB)\r
+ PUSH TP,1(AB)\r
+ MCALL 2,OFF ; TURN OFF INTERRUPT\r
+CFIN1: MOVE B,1(AB)\r
+ MOVE A,CHANNO(B)\r
+IFN ITS,[\r
+ PUSHJ P,MCLOSE\r
+]\r
+IFE ITS,[\r
+ TLZ A,400000 ; FOR JFN RELEASE\r
+ CLOSF ; CLOSE THE FILE AND RELEASE THE JFN\r
+ JFCL\r
+ MOVE A,CHANNO(B)\r
+]\r
+CFIN: LSH A,1\r
+ ADDI A,CHNL0+1(TVP) ;POINT TO THIS CHANNELS LSOT\r
+ SETZM CHANNO(B)\r
+ SETZM (A) ;AND CLOBBER IT\r
+ HLLZS BUFSTR-1(B)\r
+ SETZM BUFSTR(B)\r
+ HLLZS ACCESS-1(B)\r
+CFIN2: HLLZS -4(B)\r
+ MOVSI A,TCHAN ;RETURN THE CHANNEL\r
+ JRST FINIS\r
+\r
+CLSTTY: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE ATTEMPT-TO-CLOSE-TTY-CHANNEL\r
+ JRST CALER1\r
+\r
+\r
+REMOV: MOVEI D,CHNL0(TVP)+1 ;ATTEMPT TO REMOVE FROM PSUEDO CHANNEL LIST\r
+REMOV0: SKIPN C,D ;FOUND ON LIST ?\r
+ JRST CFIN2 ;NO, JUST IGNORE THIS CLOSED CHANNEL\r
+ HRRZ D,(C) ;GET POINTER TO NEXT\r
+ CAME B,(D)+1 ;FOUND ?\r
+ JRST REMOV0\r
+ HRRZ D,(D) ;YES, SPLICE IT OUT\r
+ HRRM D,(C)\r
+ JRST CFIN2\r
+\r
+\r
+; CLOSE UP ANY LEFTOVER BUFFERS\r
+\r
+CFIN4: CAME A,[SIXBIT /PRINTO/]\r
+ CAMN A,[SIXBIT /PRINTB/]\r
+ JRST .+3\r
+ CAME A,[SIXBIT /PRINT/]\r
+ JRST CFIN1\r
+ MOVE B,1(AB) ; GET CHANNEL\r
+ GETYP 0,BUFSTR-1(B) ; IS THERE AN OUTPUT BUFFER\r
+ SKIPN BUFSTR(B)\r
+ JRST CFIN1\r
+ CAIE 0,TCHSTR\r
+ JRST CFINX1\r
+IFE ITS, PUSH P,A ; SAVE MODE\r
+ PUSHJ P,BFCLOS\r
+IFE ITS,[\r
+ POP P,A ; RESTORE MODE\r
+ MOVE 0,RDEVIC(B)\r
+ ILDB 0,0\r
+ CAIN 0,"D\r
+ CAME A,[SIXBIT /PRINT/]\r
+ JRST CFINX1\r
+ MOVE A,CHANNO(B) ; GET JFN\r
+ TLO A,400000 ; BIT MEANS DONT RELEASE JFN\r
+ CLOSF ; CLOSE THE FILE\r
+ FATAL CLOSF LOST?\r
+ MOVE E,B ; SAVE CHANNEL\r
+ MOVE A,CHANNO(B)\r
+ HRLI A,11\r
+ MOVSI B,7700 ; MASK\r
+ MOVSI C,700 ; MAKE NEW SIZE 7\r
+ CHFDB\r
+ HRLI A,12\r
+ SETOM B\r
+ MOVE C,ACCESS(E) ; LENGTH IN CHARS\r
+ CHFDB\r
+]\r
+ HLLZS BUFSTR-1(B)\r
+ SETZM BUFSTR(B)\r
+CFINX1: HLLZS ACCESS-1(B)\r
+ JRST CFIN1\r
+\r
+CFIN5: HRRM A,CHANNO-1(B)\r
+ JRST CFIN2\r
+\f;SUBR TO DO .ACCESS ON A READ CHANNEL\r
+;FORM: <ACCESS CHANNEL FIX-NUMBER>\r
+;POSITIONS CHANNEL AT CHARACTER POSN FIX-NUMBER\r
+;H. BRODIE 7/26/72\r
+\r
+MFUNCTION MACCESS,SUBR,[ACCESS]\r
+ ENTRY 2 ;ARGS: CHANNEL AND FIX-NUMBER\r
+\r
+;CHECK ARGUMENT TYPES\r
+ GETYP A,(AB)\r
+ CAIE A,TCHAN ;FIRST ARG SHOULD BE CHANNEL\r
+ JRST WTYP1\r
+ GETYP A,2(AB) ;TYPE OF SECOND\r
+ CAIE A,TFIX ;SHOULD BE FIX\r
+ JRST WTYP2\r
+\r
+;CHECK DIRECTION OF CHANNEL\r
+ MOVE B,1(AB) ;B GETS PNTR TO CHANNEL\r
+ MOVEI B,DIRECT-1(B) ;GET DIRECTION OF CHANNEL\r
+ PUSHJ P,CHRWRD ;GRAB THE CHAR STRNG\r
+ JFCL\r
+ CAME B,[<ASCII /PRINT/>+1]\r
+ JRST MACCA\r
+ PUSH P,[2] ;ACCESS ON PRINTB CHANNEL\r
+ MOVE B,1(AB)\r
+ SKIPE BUFSTR(B) ;SEE IF WE MUST FLUSH PART BUFFER\r
+ PUSHJ P,BFCLS1\r
+ JRST MACC\r
+MACCA: PUSH P,[0] ; READ RATHER THAN READB INDICATOR\r
+ CAMN B,[ASCIZ /READ/]\r
+ JRST .+4\r
+ CAME B,[ASCIZ /READB/] ; READB CHANNEL?\r
+ JRST WRONGD\r
+ AOS (P) ; SET INDICATOR FOR BINARY MODE\r
+\r
+;CHECK THAT THE CHANNEL IS OPEN\r
+MACC: MOVE B,1(AB) ;GET BACK PTR TO CHANNEL\r
+ SKIPN CHANNO(B) ;CLOSED CHANNELS HAVE CHANNO ZEROED OUT\r
+ JRST CHNCLS ;IF CHNL CLOSED => ERROR\r
+\r
+;COMPUTE ACCESS PNTR TO ACCESS WORD CHAR IS IN\r
+;REMAINDER IS NUMBER OF TIMES TO INCR BYTE POINTER\r
+ADEVOK: SKIPGE C,3(AB) ;GET CHAR POSN...ALL NEGS = -5\r
+ MOVNI C,-5\r
+;BUT .ACCESS -1 ISN'T IMPLEMENTED ON ITS YET, SO TELL HIM\r
+ JUMPGE C,MACC1\r
+ PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE NEGATIVE-ACCESS-NOT-ON-ITS\r
+ JRST CALER1\r
+MACC1: SKIPN (P)\r
+ IDIVI C,5\r
+\r
+;SETUP THE .ACCESS\r
+ MOVE B,1(AB) ;GET BACK PTR TO CHANNEL\r
+ MOVE A,CHANNO(B) ;A GETS REAL CHANNEL NUMBER\r
+IFN ITS,[\r
+ ROT A,23. ;SET UP IN AC FIELD\r
+ IOR A,[.ACCESS 0,C] ;C CONTAINS PLACE TO ACCESS TO\r
+\r
+;DO IT TO IT!\r
+ XCT A\r
+]\r
+IFE ITS,[\r
+ MOVE B,C\r
+ SFPTR ; DO IT IN TENEX\r
+ JRST ACCFAI\r
+ MOVE B,1(AB) ; RESTORE CHANNEL\r
+]\r
+ POP P,E ; CHECK FOR READB MODE\r
+ CAIN E,2\r
+ JRST DONADV ; PRINTB CHANNEL\r
+ SKIPE BUFSTR(B) ; IS THERE A READ BUFFER TO FLUSH\r
+ JRST .+3\r
+ SETZM LSTCH(B) ; CLEAR OUT POSSIBLE EOF INDICATOR\r
+ JRST DONADV\r
+\r
+;NOW FORCE GETCHR TO DO A .IOT FIRST THING\r
+ MOVEI C,BUFSTR-1(B) ; FIND END OF STRING\r
+ PUSHJ P,BYTDOP"\r
+ SUBI A,2 ; LAST REAL WORD\r
+ HRLI A,010700\r
+ MOVEM A,BUFSTR(B)\r
+ HLLZS BUFSTR-1(B) ; CLOBBER CHAR COUNT\r
+ MOVEM A,BUFSTR(B)\r
+ SETZM LSTCH(B) ;CLOBBER READ'S HIDDEN CHARACTER\r
+\r
+;NOW DO THE APPROPRIATE NUM OF BYTE ADVANCEMENTS\r
+ JUMPLE D,DONADV\r
+ADVPTR: PUSHJ P,GETCHR\r
+ MOVE B,1(AB) ;RESTORE IN CASE CLOBBERED\r
+ SOJG D,ADVPTR\r
+\r
+DONADV: MOVE C,3(AB) ;FIXUP ACCESS SLOT IN CHNL\r
+ MOVEM C,ACCESS(B)\r
+ MOVE A,$TCHAN ;TYPE OF RESULT = "CHANNEL"\r
+ JRST FINIS ;DONE...B CONTAINS CHANNEL\r
+\r
+IFE ITS,[\r
+ACCFAI: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE ACCESS-FAILURE\r
+ JRST CALER1\r
+]\r
+\r
+\r
+;WRONG TYPE OF DEVICE ERROR\r
+WRDEV: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE NON-DSK-DEVICE\r
+ JRST CALER1\r
+\f\r
+; BINARY READ AND PRINT ROUTINES\r
+\r
+MFUNCTION PRINTB,SUBR\r
+\r
+ ENTRY 2\r
+\r
+PBFL: PUSH P,. ; PUSH NON-ZERONESS\r
+ JRST BINI1\r
+\r
+MFUNCTION READB,SUBR\r
+\r
+ ENTRY\r
+\r
+ PUSH P,[0]\r
+ HLRZ 0,AB\r
+ CAIG 0,-3\r
+ CAIG 0,-7\r
+ JRST WNA\r
+\r
+BINI1: GETYP 0,(AB) ; SHOULD BE UVEC OR STORE\r
+ CAIN 0,TUVEC\r
+ JRST BINI2\r
+ CAIE 0,TSTORAGE\r
+ JRST WTYP1 ; ELSE LOSE\r
+BINI2: MOVE B,1(AB) ; GET IT\r
+ HLRE C,B\r
+ SUBI B,(C) ; POINT TO DOPE\r
+ GETYP A,(B)\r
+ PUSHJ P,SAT" ; GET ITS ST.ALOC.TYPE\r
+ CAIE A,S1WORD\r
+ JRST WTYP1\r
+ GETYP 0,2(AB)\r
+ CAIE 0,TCHAN ; BETTER BE A CHANNEL\r
+ JRST WTYP2\r
+ MOVE B,3(AB) ; GET IT\r
+ MOVEI B,DIRECT-1(B) ; GET DIRECTION OF\r
+ PUSHJ P,CHRWRD ; INTO 1 WORD\r
+ JFCL\r
+ MOVNI E,1\r
+ CAMN B,[ASCII /READB/]\r
+ MOVEI E,0\r
+ CAMN B,[<ASCII /PRINT/>+1]\r
+ MOVE E,PBFL\r
+ JUMPL E,WRONGD ; LOSER\r
+ CAME E,(P) ; CHECK WINNGE\r
+ JRST WRONGD\r
+ MOVE B,3(AB) ; GET CHANNEL BACK\r
+ SKIPN A,IOINS(B) ; OPEN?\r
+ PUSHJ P,OPENIT ; LOSE\r
+ CAMN A,[JRST CHNCLS]\r
+ JRST CHNCLS ; LOSE, CLOSED\r
+ JUMPN E,BUFOU1 ; JUMP FOR OUTPUT\r
+ CAML AB,[-5,,] ; SKIP IF EOF GIVEN\r
+ JRST BINI5\r
+ MOVE 0,4(AB)\r
+ MOVEM 0,EOFCND-1(B)\r
+ MOVE 0,5(AB)\r
+ MOVEM 0,EOFCND(B)\r
+BINI5: SKIPE LSTCH(B) ; INDICATES IF EOF HIT\r
+ JRST BINEOF\r
+ MOVE A,1(AB) ; GET VECTOR\r
+ PUSHJ P,PGBIOI ; READ IT\r
+ HLRE C,A ; GET COUNT DONE\r
+ HLRE D,1(AB) ; AND FULL COUNT\r
+ SUB C,D ; C=> TOTAL READ\r
+ ADDM C,ACCESS(B)\r
+ JUMPGE A,BINIOK ; NOT EOF YET\r
+ SETOM LSTCH(B)\r
+BINIOK: MOVE B,C\r
+ MOVSI A,TFIX ; RETURN AMOUNT ACTUALLY READ\r
+ JRST FINIS\r
+\r
+BUFOU1: SKIPE BUFSTR(B) ; ANY BUFFERS AROUND?\r
+ PUSHJ P,BFCLS1 ; GET RID OF SAME\r
+ MOVE A,1(AB)\r
+ PUSHJ P,PGBIOO\r
+ HLRE C,1(AB)\r
+ MOVNS C\r
+ addm c,ACCESS(B)\r
+ MOVE A,(AB) ; RET VECTOR ETC.\r
+ MOVE B,1(AB)\r
+ JRST FINIS\r
+\r
+\r
+BINEOF: PUSH TP,EOFCND-1(B)\r
+ PUSH TP,EOFCND(B)\r
+ PUSH TP,$TCHAN\r
+ PUSH TP,B\r
+ MCALL 1,FCLOSE ; CLOSE THE LOSER\r
+ MCALL 1,EVAL\r
+ JRST FINIS\r
+\r
+OPENIT: PUSH P,E\r
+ PUSHJ P,OPNCHN ;TRY TO OPEN THE LOSER\r
+ JUMPE B,CHNCLS ;FAIL\r
+ POP P,E\r
+ POPJ P,\r
+\f; THESE SUBROUTINES BY NDR 9/16/73 TO FACILITATE THE\r
+; TYPES OF IO NECESSARY TO MAKE MORE EFFICIENT USE OF\r
+; THE NETWORK AND DO RELATED FILE TRANSFER TYPE OF JOBS.\r
+\r
+R1CHAR: SKIPN A,LSTCH(B) ; CHAR READING ROUTINE FOR FCOPY\r
+ PUSHJ P,RXCT\r
+ MOVEM A,LSTCH(B)\r
+ JUMPL A,.+2 ; IN CASE OF -1 ON STY\r
+ TRZN A,400000 ; EXCL HACKER\r
+ JRST .+4\r
+ MOVEM A,LSTCH(B) ; SAVE DE-EXCLED CHAR\r
+ MOVEI A,"!\r
+ JRST .+2\r
+ SETZM LSTCH(B)\r
+ PUSH P,C\r
+ HRRZ C,DIRECT-1(B)\r
+ CAIE C,5 ; IF DIRECTION IS 5 LONG THEN READB\r
+ JRST R1CH1\r
+ AOS C,ACCESS-1(B)\r
+ CAMN C,[TFIX,,1]\r
+ AOS ACCESS(B) ; EVERY FIFTY INCREMENT\r
+ CAMN C,[TFIX,,5]\r
+ HLLZS ACCESS-1(B)\r
+ JRST .+2\r
+R1CH1: AOS ACCESS(B)\r
+ POP P,C\r
+ POPJ P,\r
+\r
+W1CHAR: CAIE A,15 ; CHAR WRITING ROUTINE, TEST FOR CR\r
+ JRST .+3\r
+ SETOM CHRPOS(B)\r
+ AOSA LINPOS(B)\r
+ CAIE A,12 ; TEST FOR LF\r
+ AOS CHRPOS(B) ; IF NOT LF AOS CHARACTE5R POSITION\r
+ CAIE A,14 ; TEST FOR FORM FEED\r
+ JRST .+3\r
+ SETZM CHRPOS(B) ; IF FORM FEED ZERO CHARACTER POSITION\r
+ SETZM LINPOS(B) ; AND LINE POSITION\r
+ CAIE A,11 ; IS THIS A TAB?\r
+ JRST .+6\r
+ MOVE C,CHRPOS(B)\r
+ ADDI C,7\r
+ IDIVI C,8.\r
+ IMULI C,8. ; FIX UP CHAR POS FOR TAB\r
+ MOVEM C,CHRPOS(B) ; AND SAVE\r
+ PUSH P,C\r
+ HRRZ C,DIRECT-1(B)\r
+ CAIE C,6 ; SIX LONG MUST BE PRINTB\r
+ JRST W1CH1\r
+ AOS C,ACCESS-1(B)\r
+ CAMN C,[TFIX,,1]\r
+ AOS ACCESS(B)\r
+ CAMN C,[TFIX,,5]\r
+ HLLZS ACCESS-1(B)\r
+ JRST .+2\r
+W1CH1: AOS ACCESS(B)\r
+ PUSHJ P,WXCT\r
+ POP P,C\r
+ POPJ P,\r
+\r
+R1C: SUBM M,(P) ;LITTLE ENTRY FOR COMPILED STUFF\r
+ PUSH TP,$TCHAN ;SAVE THE CHANNEL TO BLESS IT\r
+ PUSH TP,B\r
+ MOVEI B,DIRECT-1(B)\r
+ PUSHJ P,CHRWRD\r
+ JFCL\r
+ CAME B,[ASCIZ /READ/]\r
+ CAMN B,[ASCII /READB/]\r
+ JRST .+2\r
+ JRST BADCHN\r
+ POP TP,B\r
+ POP TP,(TP)\r
+ SKIPN IOINS(B) ; IS THE CHANNEL OPEN\r
+ PUSHJ P,OPENIT ; NO, GO DO IT\r
+ PUSHJ P,GRB ; MAKE SURE WE HAVE A READ BUFFER\r
+ PUSHJ P,R1CHAR ; AND GET HIM A CHARACTER\r
+ JRST MPOPJ ; THATS ALL FOLKS\r
+\r
+W1C: SUBM M,(P)\r
+ PUSHJ P,W1CI\r
+ JRST MPOPJ\r
+\r
+W1CI: PUSH TP,$TCHAN\r
+ PUSH TP,B\r
+ PUSH P,A ; ASSEMBLER ENTRY TO OUTPUT 1 CHAR\r
+ MOVEI B,DIRECT-1(B)\r
+ PUSHJ P,CHRWRD ; INTERNAL CALL TO W1CHAR\r
+ JFCL\r
+ CAME B,[ASCII /PRINT/]\r
+ CAMN B,[<ASCII /PRINT/>+1]\r
+ JRST .+2\r
+ JRST BADCHN\r
+ POP TP,B\r
+ POP TP,(TP)\r
+ SKIPN IOINS(B) ; MAKE SURE THAT IT IS OPEN\r
+ PUSHJ P,OPENIT\r
+ PUSHJ P,GWB\r
+ POP P,A ; GET THE CHAR TO DO\r
+ JRST W1CHAR\r
+\r
+; ROUTINES TO REPLACE XCT IOINS(B) FOR INPUT AND OUTPUT\r
+; THEY DO THE XCT THEN CHECK OUT POSSIBLE SCRIPTAGE--BLECH.\r
+\r
+\r
+WXCT: PUSH P,A ; SAVE THE CHAR TO WRITE\r
+ PUSH TP,$TCHAN ; AND SAVE THE CHANNEL TOO\r
+ PUSH TP,B\r
+ XCT IOINS(B) ; DO THE REAL ONE\r
+ JRST DOSCPT ; AND CHECK OUT SCRIPTAGE\r
+\r
+RXCT: PUSH TP,$TCHAN\r
+ PUSH TP,B ; DO IT FOR READS, SAVE THE CHAN\r
+ XCT IOINS(B) ; READ IT\r
+ PUSH P,A ; AND SAVE THE CHAR AROUND\r
+ JRST DOSCPT ; AND CHECK OUT SCRIPTAGE\r
+\r
+DOSCPT: MOVE B,(TP) ;CHECK FOR SCRIPTAGE\r
+ SKIPN SCRPTO(B) ; IF ZERO FORGET IT\r
+ JRST SCPTDN ; THATS ALL THERE IS TO IT\r
+ PUSH P,C ; SAVE AN ACCUMULATOR FOR CLEANLINESS\r
+ GETYP C,SCRPTO-1(B) ; IS IT A LIST\r
+ CAIE C,TLIST\r
+ JRST BADCHN\r
+ PUSH TP,$TLIST\r
+ PUSH TP,[0] ; SAVE A SLOT FOR THE LIST\r
+ MOVE C,SCRPTO(B) ; GET THE LIST OF SCRIPT CHANNELS\r
+SCPT1: GETYP B,(C) ; GET THE TYPE OF THIS SCRIPT CHAN\r
+ CAIE B,TCHAN\r
+ JRST BADCHN ; IF IT ISN'T A CHANNEL, COMPLAIN\r
+ HRRZ B,(C) ; GET THE REST OF THE LIST IN B\r
+ MOVEM B,(TP) ; AND STORE ON STACK\r
+ MOVE B,1(C) ; GET THE CHANNEL IN B\r
+ MOVE A,-1(P) ; AND THE CHARACTER IN A\r
+ PUSHJ P,W1CI ; GO TO INTERNAL W1C, IT BLESSES GOODIES\r
+ SKIPE C,(TP) ; GET THE REST OF LIST OF CHANS\r
+ JRST SCPT1 ; AND CYCLE THROUGH\r
+ SUB TP,[2,,2] ; CLEAN OFF THE LIST OF CHANS\r
+ POP P,C ; AND RESTORE ACCUMULATOR C\r
+SCPTDN: POP P,A ; RESTORE THE CHARACTER\r
+ POP TP,B ; AND THE ORIGINAL CHANNEL\r
+ POP TP,(TP)\r
+ POPJ P, ; AND THATS ALL\r
+\r
+\r
+; SUBROUTINE TO COPY FROM INCHAN TO OUTCHAN UNTIL EOF HIT\r
+; ON THE INPUT CHANNEL\r
+; CALL IS <FILECOPY IN OUT> WHERE DEFAULTS ARE INCHAN AND OUTCHAN\r
+\r
+ MFUNCTION FCOPY,SUBR,[FILECOPY]\r
+\r
+ ENTRY\r
+ HLRE 0,AB\r
+ CAMGE 0,[-4]\r
+ JRST WNA ; TAKES FROM 0 TO 2 ARGS\r
+\r
+ JUMPE 0,.+4 ; NO FIRST ARG?\r
+ PUSH TP,(AB)\r
+ PUSH TP,1(AB) ; SAVE IN CHAN\r
+ JRST .+6\r
+ MOVE A,$TATOM\r
+ MOVE B,IMQUOTE INCHAN\r
+ PUSHJ P,IDVAL\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ HLRE 0,AB ; CHECK FOR SECOND ARG\r
+ CAML 0,[-2] ; WAS THERE MORE THAN ONE ARG?\r
+ JRST .+4\r
+ PUSH TP,2(AB) ; SAVE SECOND ARG\r
+ PUSH TP,3(AB)\r
+ JRST .+6\r
+ MOVE A,$TATOM ; LOOK UP OUTCHAN AS DEFAULT\r
+ MOVE B,IMQUOTE OUTCHAN\r
+ PUSHJ P,IDVAL\r
+ PUSH TP,A\r
+ PUSH TP,B ; AND SAVE IT\r
+\r
+ MOVE A,-3(TP)\r
+ MOVE B,-2(TP) ; INPUT CHANNEL\r
+ MOVEI 0,0 ; INDICATE INPUT\r
+ PUSHJ P,CHKCHN ; CHECK FOR GOOD CHANNEL\r
+ MOVE A,-1(TP)\r
+ MOVE B,(TP) ; GET OUT CHAN\r
+ MOVEI 0,1 ; INDICATE OUT CHAN\r
+ PUSHJ P,CHKCHN ; CHECK FOR GOOD OUT CHAN\r
+\r
+ PUSH P,[0] ; COUNT OF CHARS OUTPUT\r
+\r
+ MOVE B,-2(TP)\r
+ PUSHJ P,GRB ; MAKE SURE WE HAVE READ BUFF\r
+ MOVE B,(TP)\r
+ PUSHJ P,GWB ; MAKE SURE WE HAVE WRITE BUFF\r
+\r
+FCLOOP: MOVE B,-2(TP)\r
+ PUSHJ P,R1CHAR ; GET A CHAR\r
+ JUMPL A,FCDON ; IF A NEG NUMBER WE GOT EOF\r
+ MOVE B,(TP) ; GET OUT CHAN\r
+ PUSHJ P,W1CHAR ; SPIT IT OUT\r
+ AOS (P) ; INCREMENT COUNT\r
+ JRST FCLOOP\r
+\r
+FCDON: SUB TP,[2,,2] ; POP OFF OUTCHAN\r
+ MCALL 1,FCLOSE ; CLOSE INCHAN\r
+ MOVE A,$TFIX\r
+ POP P,B ; GET CHAR COUNT TO RETURN\r
+ JRST FINIS\r
+\r
+CHKCHN: PUSH P,0 ; CHECK FOR GOOD TASTING CHANNEL\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ GETYP C,A\r
+ CAIE C,TCHAN\r
+ JRST CHKBDC ; GO COMPLAIN IN RIGHT WAY\r
+ MOVEI B,DIRECT-1(B)\r
+ PUSHJ P,CHRWRD\r
+ JRST CHKBDC\r
+ MOVE C,(P) ; GET CHAN DIRECT\r
+ CAMN B,CHKT(C)\r
+ JRST .+4\r
+ ADDI C,2 ; TEST FOR READB OR PRINTB ALSO\r
+ CAME B,CHKT(C) ; TEST FOR CORRECT DIRECT\r
+ JRST CHKBDC\r
+ MOVE B,(TP)\r
+ SKIPN IOINS(B) ; MAKE SURE IT IS OPEN\r
+ PUSHJ P,OPENIT ; IF ZERO IOINS GO OPEN IT\r
+ SUB TP,[2,,2]\r
+ POP P, ; CLEAN UP STACKS\r
+ POPJ P,\r
+\r
+CHKT: ASCIZ /READ/\r
+ ASCII /PRINT/\r
+ ASCII /READB/\r
+ <ASCII /PRINT/>+1\r
+\r
+CHKBDC: POP P,E\r
+ MOVNI D,2\r
+ IMULI D,1(E)\r
+ HLRE 0,AB\r
+ CAMLE 0,D ; SEE IF THIS WAS HIS ARG OF DEFAULT\r
+ JRST BADCHN\r
+ JUMPE E,WTYP1\r
+ JRST WTYP2\r
+\r
+\f; FUNCTIONS READSTRING AND PRINTSTRING WORK LIKE READB AND PRINTB,\r
+; THAT IS THEY READ INTO AND OUT OF STRINGS. IN ADDITION BOTH ACCEPT\r
+; AN ADDITIONAL ARGUMENT WHICH IS THE NUMBER OF CHARS TO READ OR PRINT, IF\r
+; IT IS DESIRED FOR THIS TO BE DIFFERENT THAN THE LENGTH OF THE STRING.\r
+\r
+; FORMAT IS <READSTRING .STRING .INCHANNEL .EOFCOND .MAXCHARS>\r
+; AND BOTH SUBRS RETURN THE NUMBER OF CHARS READ OR WRITTEN\r
+\r
+; FORMAT FOR PRINTSTRING IS <PRINTSTRING .STRING .OUTCHANNEL .MAXCHARS>\r
+\r
+; THESE WERE CODED 9/16/73 BY NEAL D. RYAN\r
+\r
+ MFUNCTION RSTRNG,SUBR,READSTRING\r
+\r
+ ENTRY\r
+ PUSH P,[0] ; FLAG TO INDICATE READING\r
+ HLRE 0,AB\r
+ CAMG 0,[-1]\r
+ CAMG 0,[-9]\r
+ JRST WNA ; CHECK THAT IT HAS FROM 1 TO 4 ARGS\r
+ JRST STRIO1\r
+\r
+ MFUNCTION PSTRNG,SUBR,PRINTSTRING\r
+\r
+ ENTRY\r
+ PUSH P,[1] ; FLAG TO INDICATE WRITING\r
+ HLRE 0,AB\r
+ CAMG 0,[-1]\r
+ CAMG 0,[-7]\r
+ JRST WNA ; CHECK THAT IT HAS FROM 1 TO 3 ARGS\r
+\r
+STRIO1: PUSH TP,[0] ; SAVE SLOT ON STACK\r
+ PUSH TP,[0]\r
+ GETYP 0,(AB)\r
+ CAIE 0,TCHSTR ; MAKE SURE WE GOT STRING\r
+ JRST WTYP1\r
+ HRRZ 0,(AB) ; CHECK FOR EMPTY STRING\r
+ SKIPN (P)\r
+ JUMPE 0,MTSTRN\r
+ HLRE 0,AB\r
+ CAML 0,[-2] ; WAS A CHANNEL GIVEN\r
+ JRST STRIO2\r
+ GETYP 0,2(AB)\r
+ CAIE 0,TCHAN\r
+ JRST WTYP2 ; SECOND ARG NOT CHANNEL\r
+ MOVE B,3(AB)\r
+ MOVEI B,DIRECT-1(B)\r
+ PUSHJ P,CHRWRD\r
+ JFCL\r
+ MOVNI E,1 ; CHECKING FOR GOOD DIRECTION\r
+ CAMN B,[ASCII /READ/]\r
+ MOVEI E,0\r
+ CAMN B,[ASCII /PRINT/]\r
+ MOVEI E,1\r
+ CAMN B,[<ASCII /PRINT/>+1]\r
+ MOVEI E,1\r
+ CAMN B,[ASCII /READB/]\r
+ MOVEI E,0\r
+ CAME E,(P)\r
+ JRST WRONGD ; MAKE SURE CHANNEL IS OPEN IN RIGHT MODE\r
+ PUSH TP,2(AB)\r
+ PUSH TP,3(AB) ; PUSH ON CHANNEL\r
+ JRST STRIO3\r
+STRIO2: MOVE B,IMQUOTE INCHAN\r
+ MOVSI A,TCHAN\r
+ SKIPE (P)\r
+ MOVE B,IMQUOTE OUTCHAN\r
+ PUSHJ P,IDVAL\r
+ TLZ A,TYPMSK#777777\r
+ CAME A,$TCHAN\r
+ JRST BADCHN ; MAKE SURE WE GOT A GOOD DEFAULT CHANNEL\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+STRIO3: MOVE B,(TP) ; GET CHANNEL\r
+ SKIPN E,IOINS(B) ; MAKE SURE HE IS OPEN\r
+ PUSHJ P,OPENIT ; IF NOT GO OPEN\r
+ CAMN E,[JRST CHNCLS]\r
+ JRST CHNCLS ; CHECK TO SEE THAT CHANNEL ISNT ALREADY CLOSED\r
+STRIO4: HLRE 0,AB\r
+ CAML 0,[-4]\r
+ JRST STRIO5 ; NO COUNT TO WORRY ABOUT\r
+ GETYP 0,4(AB)\r
+ MOVE E,4(AB)\r
+ MOVE C,5(AB)\r
+ CAIE 0,TCHSTR\r
+ CAIN 0,TFIX ; BETTER BE A FIXED NUMBER\r
+ JRST .+2\r
+ JRST WTYP3\r
+ HRRZ D,(AB) ; GET ACTUAL STRING LENGTH\r
+ CAIN 0,TFIX\r
+ JRST .+7\r
+ SKIPE (P) ; TEST FOR WRITING\r
+ JRST .-7 ; IF WRITING WE GOT TROUBLE\r
+ PUSH P,D ; ACTUAL STRING LENGTH\r
+ MOVEM E,(TB) ; STUFF HIS FUNNY DELIM STRING\r
+ MOVEM C,1(TB)\r
+ JRST STRIO7\r
+ CAML D,C ; MAKE SURE THE STRING IS LONG ENOUGH\r
+ JRST .+4 ; WIN\r
+ PUSH TP,$TATOM ; LOSAGE, COUNT TOO GREAT\r
+ PUSH TP,EQUOTE COUNT-GREATER-THAN-STRING-SIZE\r
+ JRST CALER1\r
+ PUSH P,C ; PUSH ON MAX COUNT\r
+ JRST STRIO7\r
+STRIO5:\r
+STRIO6: HRRZ C,(AB) ; GET CHAR COUNT\r
+ PUSH P,C ; AND PUSH IT ON STACK AS NO MAX COUNT GIVEN\r
+STRIO7: HLRE 0,AB\r
+ CAML 0,[-6]\r
+ JRST .+6\r
+ MOVE B,(TP) ; GET THE CHANNEL\r
+ MOVE 0,6(AB)\r
+ MOVEM 0,EOFCND-1(B) ; STUFF IN SLOT IN CHAN\r
+ MOVE 0,7(AB)\r
+ MOVEM 0,EOFCND(B)\r
+ PUSH TP,(AB) ; PUSH ON STRING\r
+ PUSH TP,1(AB)\r
+ PUSH P,[0] ; PUSH ON CURRENT COUNT OF CHARS DONE\r
+ MOVE 0,-2(P) ; GET READ OR WRITE FLAG\r
+ JUMPN 0,OUTLOP ; GO WRITE STUFF\r
+\r
+ MOVE B,-2(TP) ; GET CHANNEL\r
+ PUSHJ P,GRB ; MAKE SURE WE HAVE BUFF\r
+ SKIPGE A,LSTCH(B) ; CHECK FOR EOF ALREADY READ PREVIOUSLY\r
+ JRST SRDOEF ; GO DOES HIS EOF HACKING\r
+INLOP: INTGO\r
+ MOVE B,-2(TP) ; GET CHANNEL\r
+ MOVE C,-1(P) ; MAX COUNT\r
+ CAMG C,(P) ; COMPARE WITH COUNT DONE\r
+ JRST STREOF ; WE HAVE FINISHED\r
+ PUSHJ P,R1CHAR ; GET A CHAR\r
+ JUMPL A,INEOF ; EOF HIT\r
+ MOVE C,1(TB)\r
+ HRRZ E,(TB) ; DO WE HAVE A STRING TO WORRY US?\r
+ SOJL E,INLNT ; GO FINISH STUFFING\r
+ ILDB D,C\r
+ CAME D,A\r
+ JRST .-3\r
+ JRST INEOF\r
+INLNT: IDPB A,(TP) ; STUFF IN STRING\r
+ SOS -1(TP) ; DECREMENT STRING COUNT\r
+ AOS (P) ; INCREMENT CHAR COUNT\r
+ JRST INLOP\r
+\r
+INEOF: SKIPE C,LSTCH(B) ; IS THIS AN ! AND IS THERE A CHAR THERE\r
+ JRST .+3 ; YES\r
+ MOVEM A,LSTCH(B) ; NO SAVE THE CHAR\r
+ JRST .+3\r
+ ADDI C,400000\r
+ MOVEM C,LSTCH(B)\r
+ HRRZ C,DIRECT-1(B) ; GET THE TYPE OF CHAN\r
+ CAIN C,5 ; IS IT READB?\r
+ JRST .+3\r
+ SOS ACCESS(B) ; FIX UP ACCESS FOR READ CHANNEL\r
+ JRST STREOF ; AND THATS IT\r
+ HRRZ C,ACCESS-1(B) ; FOR A READB ITS WORSE\r
+ MOVEI D,5\r
+ SKIPG C\r
+ HRRM D,ACCESS-1(B) ; CHANGE A 0 TO A FIVE\r
+ SOS C,ACCESS-1(B)\r
+ CAMN C,[TFIX,,0]\r
+ SOS ACCESS(B) ; AND SOS THE WORD COUNT MAYBE\r
+ JRST STREOF\r
+\r
+SRDOEF: SETZM LSTCH(B) ; IN CASE OF -1, FLUSH IT\r
+ AOJE A,INLOP ; SKIP OVER -1 ON PTY'S\r
+ SUB TP,[6,,6]\r
+ SUB P,[3,,3] ; POP JUNK OFF STACKS\r
+ PUSH TP,EOFCND-1(B)\r
+ PUSH TP,EOFCND(B) ; WHAT WE NEED TO EVAL\r
+ PUSH TP,$TCHAN\r
+ PUSH TP,B\r
+ MCALL 1,FCLOSE ; CLOSE THE LOOSING CHANNEL\r
+ MCALL 1,EVAL ; EVAL HIS EOF JUNK\r
+ JRST FINIS\r
+\r
+OUTLOP: MOVE B,-2(TP)\r
+ PUSHJ P,GWB ; MAKE SURE WE HAVE BUFF\r
+OUTLP1: INTGO\r
+ MOVE B,-2(TP)\r
+ MOVE C,-1(P) ; MAX COUNT TO DO\r
+ CAMG C,(P) ; HAVE WE DONE ENOUGH\r
+ JRST STREOF\r
+ ILDB A,(TP) ; GET THE CHAR\r
+ SOS -1(TP) ; SUBTRACT FROM STRING LENGTH\r
+ AOS (P) ; INC COUNT OF CHARS DONE\r
+ PUSHJ P,W1CHAR ; GO STUFF CHAR\r
+ JRST OUTLP1\r
+\r
+STREOF: MOVE A,$TFIX\r
+ POP P,B ; RETURN THE LOOSER A COUNT OF WHAT WAS DONE\r
+ SUB P,[2,,2]\r
+ SUB TP,[6,,6]\r
+ JRST FINIS\r
+\r
+\r
+GWB: SKIPE BUFSTR(B)\r
+ POPJ P,\r
+ PUSH TP,$TCHAN\r
+ PUSH TP,B ; GET US A WRITE BUFFER ON PRINTB CHAN\r
+ MOVEI A,BUFLNT\r
+ PUSHJ P,IBLOCK\r
+ MOVSI A,TWORD+.VECT.\r
+ MOVEM A,BUFLNT(B)\r
+ SETOM (B)\r
+ MOVEI C,1(B)\r
+ HRLI C,(B)\r
+ BLT C,BUFLNT-1(B)\r
+ MOVE C,B\r
+ HRLI C,440700\r
+ MOVE B,(TP)\r
+ MOVEI 0,C.BUF\r
+ IORM 0,-4(B)\r
+ MOVEM C,BUFSTR(B)\r
+ MOVE C,[TCHSTR,,BUFLNT*5]\r
+ MOVEM C,BUFSTR-1(B)\r
+ SUB TP,[2,,2]\r
+ POPJ P,\r
+\r
+\r
+GRB: SKIPE BUFSTR(B)\r
+ POPJ P,\r
+ PUSH TP,$TCHAN\r
+ PUSH TP,B ; GET US A READ BUFFER\r
+ MOVEI A,BUFLNT\r
+ PUSHJ P,IBLOCK\r
+ MOVEI C,BUFLNT(B)\r
+ POP TP,B\r
+ MOVEI 0,C.BUF\r
+ IORM 0,-4(B)\r
+ HRLI C,440700\r
+ MOVEM C,BUFSTR(B)\r
+ MOVSI C,TCHSTR\r
+ MOVEM C,BUFSTR-1(B)\r
+ SUB TP,[1,,1]\r
+ POPJ P,\r
+\r
+MTSTRN: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE EMPTY-STRING\r
+ JRST CALER1\r
+\r
+\f; INPUT UNBUFFERING ROUTINE. THIS DOES THE CHARACTER UNBUFFERING\r
+; FOR INPUT. THE OPEN ROUTINE SETUPS A PUSHJ P, TO\r
+; THIS ROUTINE AS THE IOINS FOR A CHANNEL OPEN TO A NON-TTY DEVICE.\r
+\r
+; H. BRODIE 7/19/72\r
+\r
+; CALLING SEQ:\r
+; PUSHJ P,GETCHR\r
+; B/ AOBJN PNTR TO CHANNEL VECTOR\r
+; RETURNS NEXT CHARACTER IN AC A.\r
+; ON ENCOUNTERING EITHER ^C OR NUL(^@) IT ASSUMES EOF AND\r
+; TRANSMITS ONLY ^C ON SUCCESSIVE CALLS\r
+\r
+\r
+GETCHR:\r
+; FIRST GRAB THE BUFFER\r
+ GETYP A,BUFSTR-1(B) ; GET TYPE WORD\r
+ CAIN A,TCHSTR ; SKIPS IF NOT CHSTR (I.E. IF BAD BUFFER)\r
+ JRST GTGBUF ; IS GOOD BUFFER...SKIP ERROR RETURN\r
+BDCHAN: PUSH TP,$TATOM ; ERROR RETURN\r
+ PUSH TP,EQUOTE BAD-INPUT-BUFFER\r
+ JRST CALER1\r
+\r
+; BUFFER WAS GOOD\r
+GTGBUF: HRRZ A,BUFSTR-1(B) ; GET LENGTH OF STRING\r
+ SOJGE A,GTGCHR ; JUMP IF STILL MORE\r
+\r
+; HERE IF THE BUFFER WAS EXHAUSTED (BYTE PNTR POINTS INTO DOPE WDS)\r
+; GENERATE AN .IOT POINTER\r
+;FIRST SAVE C AND D AS I WILL CLOBBER THEM\r
+NEWBUF: PUSH P,C\r
+ PUSH P,D\r
+IFN ITS,[\r
+ LDB C,[600,,STATUS(B)] ; GET TYPE\r
+ CAIG C,2 ; SKIP IF NOT TTY\r
+]\r
+IFE ITS,[\r
+ SKIPE BUFRIN(B)\r
+]\r
+ JRST GETTTY ; GET A TTY BUFFER\r
+\r
+ PUSHJ P,PGBUFI ; RE-FILL BUFFER\r
+\r
+ JUMPGE A,BUFGOO ;SKIPS IF IOT COMPLETED...FIX UP CHANNEL\r
+ MOVEI C,1 ; MAKE SURE LAST EOF REALLY ENDS IT\r
+ ANDCAM C,-1(A)\r
+ MOVSI C,014000 ; GET A ^C\r
+ MOVEM C,(A) ;FAKE AN EOF\r
+\r
+; RESET THE BYTE POINTER IN THE CHANNEL.\r
+; BUILD ONE USING THE PTR TO BEG OF BUFFER SAVED IN D\r
+BUFGOO: HRLI D,440700 ; GENERATE VIRGIN LH\r
+\r
+ MOVEM D,BUFSTR(B) ; STASH IN THE BUFFER BYTE PNTR SLOT\r
+ MOVEI A,BUFLNT*5-1\r
+BUFROK: POP P,D ;RESTORE D\r
+ POP P,C ;RESTORE C\r
+\r
+\r
+; HERE IF THERE ARE CHARS IN BUFFER\r
+GTGCHR: HRRM A,BUFSTR-1(B)\r
+ ILDB A,BUFSTR(B) ; GET A CHAR FROM BUFFER\r
+IFE ITS,[\r
+ CAIN A,32 ; TENEX EOF?\r
+ JRST .+3\r
+]\r
+ CAIE A,3 ; EOF?\r
+ POPJ P, ; AND RETURN\r
+IFN ITS,[\r
+ LDB A,[600,,STATUS(B)] ; CHECK FOR TTY\r
+ CAILE A,2 ; SKIP IF TTY\r
+]\r
+IFE ITS, SKIPN BUFRIN(B)\r
+\r
+ JRST .+3\r
+RETEO1: HRRI A,3\r
+ POPJ P,\r
+\r
+ HRRZ A,@BUFSTR(B) ; SEE IF RSUBR START BIT IS ON\r
+ TRNN A,1\r
+ MOVSI A,-1\r
+ JRST RETEO1\r
+\r
+IFN ITS,[\r
+PGBUFO:\r
+PGBUFI:\r
+]\r
+IFE ITS,[\r
+PGBUFO: SKIPA D,[SOUT]\r
+PGBUFI: MOVE D,[SIN]\r
+]\r
+ SKIPGE A,BUFSTR(B) ; POINT TO CURRENT BUFFER POSIT\r
+ SUBI A,1 ; FOR 440700 AND 010700 START\r
+ SUBI A,BUFLNT-1 ; CALCULATE PNTR TO BEG OF BUFFER\r
+ HRLI A,-BUFLNT ; IOT (AOBJN) PNTR IN A\r
+IFN ITS,[\r
+PGBIOO:\r
+PGBIOI: MOVE D,A ; COPY FOR LATER\r
+ MOVSI C,TUVEC ; PREPARE TO HANDDLE INTS\r
+ MOVEM C,DSTO(PVP)\r
+ MOVEM C,ASTO(PVP)\r
+ MOVSI C,TCHAN\r
+ MOVEM C,BSTO(PVP)\r
+\r
+; BUILD .IOT INSTR\r
+ MOVE C,CHANNO(B) ; CHANNEL NUMBER IN C\r
+ ROT C,23. ; MOVE INTO AC FIELD\r
+ IOR C,[.IOT 0,A] ; IOR IN SKELETON .IOT\r
+\r
+; DO THE .IOT\r
+ ENABLE ; ALLOW INTS\r
+ XCT C ; EXECUTE THE .IOT INSTR\r
+ DISABLE\r
+ SETZM BSTO(PVP)\r
+ SETZM ASTO(PVP)\r
+ SETZM DSTO(PVP)\r
+ POPJ P,\r
+]\r
+\r
+IFE ITS,[\r
+PGBIOT: PUSH P,D\r
+ PUSH TP,$TCHAN\r
+ PUSH TP,B\r
+ MOVEI C,(A) ; POINT TO BUFFER\r
+ HRLI C,444400\r
+ MOVE D,A ; XTRA POINTER\r
+ MOVE A,CHANNO(B) ; FILE JFN\r
+ MOVE B,C\r
+ HLRE C,D ; - COUNT TO C\r
+ XCT (P) ; DO IT TO IT\r
+ MOVEI A,1(B)\r
+ MOVE B,(TP)\r
+ SUB TP,[2,,2]\r
+ SUB P,[1,,1]\r
+ JUMPGE C,CPOPJ ; NO EOF YET\r
+ HRLI A,(C) ; LOOK LIKE AN AOBJN PNTR\r
+ POPJ P,\r
+\r
+PGBIOO: SKIPA D,[SOUT]\r
+PGBIOI: MOVE D,[SIN]\r
+ JRST PGBIOT\r
+DOIOTO: PUSH P,D\r
+ PUSH P,C\r
+ PUSHJ P,PGBIOO\r
+DOIOTE: POP P,C\r
+ POP P,D\r
+ POPJ P,\r
+DOIOTI: PUSH P,D\r
+ PUSH P,C\r
+ PUSHJ P,PGBIOI\r
+ JRST DOIOTE\r
+]\r
+\f\r
+; OUTPUT BUFFERING ROUTINES SIMILAR TO INPUT BUFFERING ROUTINES OF PREV PAGE\r
+\r
+PUTCHR: PUSH P,A\r
+ GETYP A,BUFSTR-1(B) ; CHECK TYPE OF ARG\r
+ CAIE A,TCHSTR ; MUST BE STRING\r
+ JRST BDCHAN\r
+\r
+ HRRZ A,BUFSTR-1(B) ; GET CHAR COUNT\r
+ JUMPE A,REBUFF ; PREV RESET BUFF, UNDO SAME\r
+\r
+PUTCH1: POP P,A ; RESTORE CHAR\r
+ CAMN A,[-1] ; SPECIAL HACK?\r
+ JRST PUTCH2 ; YES GO HANDLE\r
+ IDPB A,BUFSTR(B) ; STUFF IT\r
+PUTCH3: SOS A,BUFSTR-1(B) ; COUNT DOWN STRING\r
+ TRNE A,-1 ; SKIP IF FULL\r
+ POPJ P,\r
+\r
+; HERE TO FLUSH OUT A BUFFER\r
+\r
+ PUSH P,C\r
+ PUSH P,D\r
+ PUSHJ P,PGBUFO ; SETUP AND DO IOT\r
+ HRLI D,440700 ; POINT INTO BUFFER\r
+ MOVEM D,BUFSTR(B) ; STORE IT\r
+ MOVEI A,BUFLNT*5 ; RESET COUNT\r
+ HRRM A,BUFSTR-1(B)\r
+ POP P,D\r
+ POP P,C\r
+ POPJ P,\r
+\r
+;HERE TO DA ^C AND TURN ON MAGIC BIT\r
+\r
+PUTCH2: MOVEI A,3\r
+ IDPB A,BUFSTR(B) ; ZAP OUT THE ^C\r
+ MOVEI A,1 ; GET BIT\r
+ IORM A,@BUFSTR(B) ; ON GOES THE BIT\r
+ JRST PUTCH3\r
+\r
+; RESET A FUNNY BUF\r
+\r
+REBUFF: MOVEI A,BUFLNT*5 ; 1ST COUNT\r
+ HRRM A,BUFSTR-1(B)\r
+ HRRZ A,BUFSTR(B) ; NOW POINTER\r
+ SUBI A,BUFLNT\r
+ HRLI A,440700\r
+ MOVEM A,BUFSTR(B) ; STORE BACK\r
+ JRST PUTCH1\r
+\r
+\r
+; HERE TO FLUSH FINAL BUFFER\r
+\r
+BFCLOS: HLLZS ACCESS-1(B) ; CLEAR OUT KLUDGE PRINTB PART ACCESS COUNT\r
+ MOVE C,B ; THIS BUFFER FLUSHER THE WORK OF NDR\r
+ MOVEI B,RDEVIC-1(B) ; FIND OUT IF THIS IS NET\r
+ PUSHJ P,CHRWRD\r
+ JFCL\r
+ TRZ B,77777 ; LEAVE ONLY HIGH 3 CHARS\r
+ MOVEI A,0 ; FLAG 0=NET 1=DSK\r
+ CAME B,[ASCIZ /NET/] ; IS THIS NET?\r
+ AOS A\r
+ PUSH P,A ; SAVE THE RESULT OF OUR TEST\r
+ MOVE B,C ; RESTORE CHANNEL IN B\r
+ JUMPN A,BFCLNN ; DONT HAVE TO CHECK NET STATE\r
+ PUSH TP,$TCHAN\r
+ PUSH TP,B ; SAVE CHANNEL\r
+ PUSHJ P,INSTAT ; GET CURRENT NETWORK STATE\r
+ MOVE A,(B) ; GET FIRST ELEMENT OF STATE UVECTOR WHICH IS CUR STATE\r
+ POP TP,B ; RESTORE B\r
+ POP TP,\r
+ CAIE A,5 ; IS NET IN OPEN STATE?\r
+ CAIN A,6 ; OR ELSE IS IT IN RFNM WAIT STATE\r
+ JRST BFCLNN ; IF SO TO THE IOT\r
+ POP P, ; ELSE FLUSH CRUFT AND DONT IOT\r
+ POPJ P, ; RETURN DOING NO IOT\r
+BFCLNN: MOVEI C,BUFLNT*5 ; NEW BUFFER FLUSHER BY NDR\r
+ HRRZ D,BUFSTR-1(B) ; SO THAT NET ALSO WORKS RIGHT\r
+ SUBI C,(D) ; GET NUMBER OF CHARS\r
+ IDIVI C,5 ; NUMBER OF FULL WORDS AND REST\r
+ PUSH P,D ; SAVE NUMBER OF ODD CHARS\r
+ SKIPGE A,BUFSTR(B) ; GET CURRENT BUF POSITION\r
+ SUBI A,1 ; FIX FOR 440700 BYTE POINTER\r
+ PUSH P,(A) ; SAVE THE ODD WORD OF BUFFER\r
+ MOVEI D,BUFLNT\r
+ SUBI D,(C)\r
+ SKIPE -1(P)\r
+ SUBI A,1\r
+ ADDI D,1(A) ; FIX UP FOR POSSIBLE ODD CHARS\r
+ PUSH TP,$TUVEC\r
+ PUSH TP,D ; PUSH THE DOPE VECTOR ONTO THE STACK\r
+ JUMPE C,BFCLSR ; IN CASE THERE ARE NO FULL WORDS TO DO\r
+ HRL A,C\r
+ MOVE E,[A,,BUFLNT]\r
+ SUBI E,(C) ; FIX UP FOR BACKWARDS BLT\r
+ POP A,@E ; AMAZING GRACE\r
+ TLNE A,-1\r
+ JRST .-2\r
+ HRRO A,D ; SET UP AOBJN POINTER\r
+ SUBI A,(C)\r
+ TLC A,-1(C)\r
+ PUSHJ P,PGBIOO ; DO THE IOT OF ALL THE FULL WORDS\r
+BFCLSR: HRRO A,(TP) ; GET IOT PTR FOR REST OF JUNK\r
+ SUBI A,1 ; POINT TO WORD BEFORE DOPE WORDS\r
+ POP P,0 ; GET BACK ODD WORD\r
+ POP P,C ; GET BACK ODD CHAR COUNT\r
+ POP P,D ; FLAG FOR NET OR DSK\r
+ JUMPE C,BFCLSD ; IF NO ODD CHARS FINISH UP\r
+ JUMPN D,BFCDSK ; GO FINISH OFF DSK\r
+ MOVEI D,7\r
+ IMULI D,(C) ; FIND NO OF BITS TO SHIFT\r
+ LSH 0,-43(D) ; SHIFT BITS TO RIGHT PLACE\r
+ MOVEM 0,(A) ; STORE IN STRING\r
+ SUBI C,5 ; HOW MANY CHAR POSITIONS TO SKIP\r
+ MOVNI C,(C) ; MAKE C POSITIVE\r
+ LSH C,17\r
+ TLC A,(C) ; MUNG THE AOBJN POINTER TO KLUDGE\r
+ PUSHJ P,PGBIOO ; DO IOT OF ODD CHARS\r
+BFCLSD: HRRZ A,(TP) ; GET PTR TO DOPE WORD\r
+ SUBI A,BUFLNT\r
+ HRLI A,440700 ; AOBJN POINTER TO FIRST OF BUFFER\r
+ MOVEM A,BUFSTR(B)\r
+ MOVEI A,BUFLNT*5\r
+ HRRM A,BUFSTR-1(B)\r
+ SUB TP,[2,,2]\r
+ POPJ P,\r
+\r
+BFCDSK: MOVE C,A ; FOR FUNNY AOBJN PTR\r
+ HLL C,BUFSTR(B) ; POINT INTO WORD AFTER LAST CHAR\r
+ TRZ 0,1\r
+ MOVEM 0,(A)\r
+IFN ITS, MOVEI 0,3 ; CONTROL C\r
+IFE ITS, MOVEI 0,32 ; CNTL Z\r
+ IDPB 0,C\r
+ PUSHJ P,PGBIOO\r
+ JRST BFCLSD\r
+\r
+BFCLS1: HRRZ C,DIRECT-1(B)\r
+ MOVSI 0,(JFCL)\r
+ CAIE C,6\r
+ MOVE 0,[AOS ACCESS(B)]\r
+ PUSH P,0\r
+ HRRZ C,BUFSTR-1(B)\r
+ IDIVI C,5\r
+ JUMPE D,BCLS11\r
+ MOVEI A,40 ; PAD WITH SPACES\r
+ PUSHJ P,PUTCHR\r
+ XCT (P) ; AOS ACCESS IF NECESSARY\r
+ SOJG D,.-3 ; TO END OF WORD\r
+BCLS11: POP P,0\r
+ HLLZS ACCESS-1(B)\r
+ HRRZ C,BUFSTR-1(B)\r
+ CAIE C,BUFLNT*5\r
+ PUSHJ P,BFCLOS\r
+ POPJ P,\r
+\r
+\f\r
+; HERE TO GET A TTY BUFFER\r
+\r
+GETTTY: SKIPN C,EXBUFR(B) ; SKIP IF BUFFERS BACKED UP\r
+ JRST TTYWAI\r
+ HRRZ D,(C) ; CDR THE LIST\r
+ GETYP A,(C) ; CHECK TYPE\r
+ CAIE A,TDEFER ; MUST BE DEFERRED\r
+ JRST BDCHAN\r
+ MOVE C,1(C) ; GET DEFERRED GOODIE\r
+ GETYP A,(C) ; BETTER BE CHSTR\r
+ CAIE A,TCHSTR\r
+ JRST BDCHAN\r
+ MOVE A,(C) ; GET FULL TYPE WORD\r
+ MOVE C,1(C)\r
+ MOVEM D,EXBUFR(B) ; STORE CDR'D LIST\r
+ MOVEM A,BUFSTR-1(B) ; MAKE CURRENT BUFFER\r
+ MOVEM C,BUFSTR(B)\r
+ SOJA A,BUFROK\r
+\r
+TTYWAI: PUSHJ P,TTYBLK ; BLOCKED FOR TTY I/O\r
+ JRST GETTTY ; SHOULD ONLY RETURN HAPPILY\r
+\r
+\f;INTERNAL DEVICE READ ROUTINE.\r
+\r
+;FOR INTERNAL DEVICES THIS ROUTINE APPLIES THE GIVEN OBJECT,\r
+;CHECKS THAT THE RETURNED VALUE IS OF TYPE CHARACTER,\r
+;AND RETURNS THAT AS THE NEXT CHARACTER IN THE "FILE"\r
+\r
+;H. BRODIE 8/31/72\r
+\r
+GTINTC: PUSH TP,$TCHAN ;SAVE THE CHANNEL...WE'LL CLOBBER B\r
+ PUSH TP,B\r
+ PUSH P,C ;AND SAVE THE OTHER ACS\r
+ PUSH P,D\r
+ PUSH P,E\r
+ PUSH P,0\r
+ PUSH TP,INTFCN-1(B)\r
+ PUSH TP,INTFCN(B)\r
+ MCALL 1,APPLY\r
+ GETYP A,A\r
+ CAIE A,TCHRS\r
+ JRST BADRET\r
+ MOVE A,B\r
+INTRET: POP P,0 ;RESTORE THE ACS\r
+ POP P,E\r
+ POP P,D\r
+ POP P,C\r
+ POP TP,B ;RESTORE THE CHANNEL\r
+ SUB TP,[1,,1] ;FLUSH $TCHAN...WE DON'T NEED IT\r
+ POPJ P,\r
+\r
+\r
+BADRET: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE INT-DEVICE-WRONG-TYPE-EVALUATION-RESULT\r
+ JRST CALER1\r
+\r
+;INTERNAL DEVICE PRINT ROUTINE.\r
+\r
+;FOR INTERNAL DEVICES THIS ROUTINE APPLIES THE GIVEN OBJECT,(FUNCTION, SUBR, OR RSUBR)\r
+;TO THE CURRENT CHARACTER BEING "PRINTED".\r
+\r
+PTINTC: PUSH TP,$TCHAN ;SAVE THE CHANNEL...WE'LL CLOBBER B\r
+ PUSH TP,B\r
+ PUSH P,C ;AND SAVE THE OTHER ACS\r
+ PUSH P,D\r
+ PUSH P,E\r
+ PUSH P,0\r
+ PUSH TP,INTFCN-1(B) ;PUSH TYPE OF GIVEN OBJ\r
+ PUSH TP,INTFCN(B) ;PUSH THE SUPPLIED FUNCTION (OR SUBR ETC.)\r
+ PUSH TP,$TCHRS ;PUSH THE TYPE "CHARACTER"\r
+ PUSH TP,A ;PUSH THE CHAR\r
+ MCALL 2,APPLY ;APPLY THE FUNCTION TO THE CHAR\r
+ JRST INTRET\r
+\r
+\r
+\f\r
+; ROUTINE TO FLUSH OUT A PRINT BUFFER\r
+\r
+MFUNCTION BUFOUT,SUBR\r
+\r
+ ENTRY 1\r
+\r
+ GETYP 0,(AB)\r
+ CAIE 0,TCHAN\r
+ JRST WTYP1\r
+\r
+ MOVE B,1(AB)\r
+ MOVEI B,DIRECT-1(B)\r
+ PUSHJ P,CHRWRD ; GET DIR NAME\r
+ JFCL\r
+ CAMN B,[ASCII /PRINT/]\r
+ JRST .+3\r
+ CAME B,[<ASCII /PRINT/>+1]\r
+ JRST WRONGD\r
+ TRNE B,1 ; SKIP IF PRINT\r
+ PUSH P,[JFCL]\r
+ TRNN B,1 ; SKIP IF PRINTB\r
+ PUSH P,[AOS ACCESS(B)]\r
+ MOVE B,1(AB)\r
+ GETYP 0,BUFSTR-1(B)\r
+ CAIN 0,TCHSTR\r
+ SKIPN C,BUFSTR(B) ; BYTE POINTER?\r
+ JRST BFIN1\r
+ HRRZ C,BUFSTR-1(B) ; CHARS LEFT\r
+ IDIVI C,5 ; MULTIPLE OF 5?\r
+ JUMPE D,BFIN2 ; YUP NO EXTRAS\r
+\r
+ MOVEI A,40 ; PAD WITH SPACES\r
+ PUSHJ P,PUTCHR ; OUT IT GOES\r
+ XCT (P) ; MAYBE BUMP ACCESS\r
+ SOJG D,.-3 ; FILL\r
+\r
+BFIN2: PUSHJ P,BFCLOS ; WRITE OUT BUFFER\r
+BFIN1: MOVSI A,TCHAN\r
+ JRST FINIS\r
+\r
+\r
+\r
+; FUNCTION TO GET THE FILE LENGTH OF A READ CHANNEL\r
+\r
+MFUNCTION FILLNT,SUBR,[FILE-LENGTH]\r
+ ENTRY 1\r
+\r
+ GETYP 0,(AB)\r
+ CAIE 0,TCHAN\r
+ JRST WTYP1\r
+ MOVE B,1(AB)\r
+ MOVEI B,DIRECT-1(B) ; GET CHANNEL TYPE\r
+ PUSHJ P,CHRWRD\r
+ JFCL\r
+ CAME B,[ASCIZ /READ/]\r
+ JRST .+3\r
+ PUSH P,[5] ; MULTIPLICATIVE FACTOR FOR READ\r
+ JRST .+4\r
+ CAME B,[ASCII /READB/]\r
+ JRST WRONGD\r
+ PUSH P,[1] ; MULTIPLICATIVE FACTOR FOR READ\r
+ MOVE C,1(AB)\r
+IFN ITS,[\r
+ .CALL FILL1\r
+ JRST FILLOS ; GIVE HIM A NICE FALSE\r
+]\r
+IFE ITS,[\r
+ MOVE A,CHANNO(C)\r
+ SIZEF\r
+ JRST FILLOS\r
+]\r
+ POP P,C\r
+ IMUL B,C\r
+ MOVE A,$TFIX\r
+ JRST FINIS\r
+\r
+IFN ITS,[\r
+FILL1: SETZ ; BLOCK FOR .CALL TO FILLEN\r
+ SIXBIT /FILLEN/\r
+ CHANNO (C)\r
+ SETZM B\r
+\r
+FILLOS: MOVE A,CHANNO(C)\r
+ PUSHJ P,GFALS\r
+ JRST FINIS\r
+]\r
+IFE ITS,[\r
+FILLOS: PUSHJ P,TGFALS\r
+ JRST FINIS\r
+]\r
+\r
+\r
+\f;THREE GENERALLY USEFUL ERROR ROUTINES FOR I/O\r
+\r
+NOTNET:\r
+BADCHN: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE BAD-CHANNEL\r
+ JRST CALER1\r
+\r
+WRONGD: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE WRONG-DIRECTION-CHANNEL\r
+ JRST CALER1\r
+\r
+CHNCLS: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE CHANNEL-CLOSED\r
+ JRST CALER1\r
+\r
+BAD6: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE NON-6-BIT-CHARACTER-IN-FILE-NAME\r
+ JRST CALER1\r
+\r
+DISLOS: MOVE C,$TCHSTR\r
+ MOVE D,CHQUOTE [DISPLAY NOT AVAILABLE]\r
+ PUSHJ P,INCONS\r
+ MOVSI A,TFALSE\r
+ JRST OPNRET\r
+\r
+NOCHAN: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE ITS-CHANNELS-EXHAUSTED\r
+ JRST CALER1\r
+\r
+MODE1: 232020,,202020\r
+MODE2: 232023,,332320\r
+\r
+END\r
+\r
+\f\r
+TITLE GCHACK\r
+\r
+RELOCATABLE\r
+\r
+.INSRT MUDDLE >\r
+\r
+.GLOBAL FRMUNG,PARBOT,TYPVEC,GCHACK,REHASH,IMPURI,NWORDT\r
+.GLOBAL TD.LNT,TD.GET,TD.PUT\r
+\r
+; THIS IS AN INTERNAL MUDDLE SUBROUTINE TO RUN AROUND GC SPACE DOING\r
+; SOMETHING ARBITRARY TO EVERY ENTITY THEREIN\r
+\r
+; CALL --\r
+; A/ INSTRUCTION TO BE EXECUTED\r
+; PUSHJ P,GCHACK\r
+\r
+GCHACK: HRRZ E,TYPVEC+1(TVP) ; SET UP TYPE POINTER\r
+ HRLI E,C ; WILL HAVE TYPE CODE IN C\r
+ MOVE B,PARBOT ; START AT PARBOT\r
+ SETOM 1(TP) ; FENCE POST PDL\r
+ PUSH P,A\r
+ MOVEI A,(TB)\r
+ PUSHJ P,FRMUNG ; MUNG CURRENT FRAME\r
+ POP P,A\r
+\r
+; FIRST HACK PAIR SPACE\r
+\r
+PHACK: CAML B,PARTOP ; SKIP IF MORE PAIRS\r
+ JRST VHACK ; DONE, NOW HACK VECTORS\r
+ GETYP C,(B) ; TYPE OF CURRENT PAIR\r
+ MOVE D,1(B) ; AND ITS DATUM\r
+ XCT A ; APPLY INS\r
+ ADDI B,2\r
+ JRST PHACK\r
+\r
+; NOW DO THE SAME THING TO VECTOR SPACE\r
+\r
+VHACK: MOVE B,VECTOP ; START AT TOP, MOVE DOWN\r
+ SUBI B,1 ; POINT TO TOPMOST VECTOR\r
+VHACK2: CAMG B,VECBOT ; SKIP IF MORE TO DO\r
+ JRST REHASQ ; SEE IF MUST REHASH\r
+\r
+ HLRE D,-1(B) ; GET TYPE FROM D.W.\r
+ HLRZ C,(B) ; AND TOTAL LENGTH\r
+ SUBI B,(C)-1 ; POINT TO START OF VECTOR\r
+ PUSH P,B\r
+ SUBI C,2 ; CHECK WINNAGE\r
+ JUMPL C,BADV ; FATAL LOSSAGE\r
+ PUSH P,C ; SAVE COUNT\r
+ JUMPE C,VHACK1 ; EMPTY VECTOR, FINISHED\r
+\r
+; DECIDE BASED ON TYPE WHETHER GENERAL,UNIFORM OR SPECIAL\r
+\r
+ JUMPGE D,UHACK ; UNIFORM\r
+ TRNE D,377777 ; SKIP IF GENERAL\r
+ JRST SHACK ; SPECIAL\r
+\r
+; FALL THROUGH TO GENERAL\r
+\r
+GHACK1: GETYP C,(B) ; LOOK A T 1ST ELEMENT\r
+ CAIE C,TCBLK\r
+ CAIN C,TENTRY ; FRAME ON STACK\r
+ SOJA B,EHACK\r
+ CAIE C,TUBIND\r
+ CAIN C,TBIND ; BINDING BLOCK\r
+ JRST BHACK\r
+ CAIN C,TGATOM ; ATOM WITH GDECL?\r
+ JRST GDHACK\r
+ MOVE D,1(B) ; GET DATUM\r
+ XCT A ; USER INS\r
+ ADDI B,2 ; NEXT ELEMENT\r
+ SOS (P)\r
+ SOSLE (P) ; COUNT ELEMENTS\r
+ SKIPGE (B) ; OR FENCE POST HIT\r
+ JRST VHACK1\r
+ JRST GHACK1\r
+\r
+; HERE TO GO OVER UVECTORS\r
+\r
+UHACK: CAMN A,[PUSHJ P,SBSTIS]\r
+ JRST VHACK1 ; IF THIS SUBSTITUTE, DONT DO UVEC\r
+ MOVEI C,(D) ; COPY UNIFORM TYPE\r
+ SUBI B,1 ; BACK OFF\r
+\r
+UHACK1: MOVE D,1(B) ; DATUM\r
+ XCT A\r
+ SOSLE (P) ; COUNT DOEN\r
+ AOJA B,UHACK1\r
+ JRST VHACK1\r
+\r
+; HERE TO HACK VARIOUS FLAVORS OF SPECIAL GOODIES\r
+\r
+SHACK: ANDI D,377777 ; KILL EXTRA CRUFT\r
+ CAIN D,SATOM\r
+ JRST ATHACK\r
+ CAIE D,STPSTK ; STACK OR\r
+ CAIN D,SPVP ; PROCESS\r
+ JRST GHACK1 ; TREAT LIKE GENERAL\r
+ CAIN D,SASOC ; ASSOCATION\r
+ JRST ASHACK\r
+ CAIG D,NUMSAT ; TEMPLATE MAYBE?\r
+ JRST BADV ; NO CHANCE\r
+ ADDI C,(B) ; POINT TO DOPE WORDS\r
+ SUBI D,NUMSAT+1\r
+ HRLI D,(D)\r
+ ADD D,TD.LNT+1(TVP)\r
+ JUMPGE D,BADV ; JUMP IF INVALID TEMPLATE HACKER\r
+\r
+ CAMN A,[PUSHJ P,SBSTIS]\r
+ JRST VHACK1\r
+\r
+TD.UPD: PUSH P,A ; INS TO EXECUTE\r
+ XCT (D)\r
+ HLRZ E,B ; POSSIBLE BASIC LENGTH\r
+ PUSH P,[0]\r
+ PUSH P,E\r
+ MOVEI B,(B) ; ISOLATE LENGTH\r
+ PUSH P,C ; SAVE POINTER TO OBJECT\r
+\r
+ PUSH P,[0] ; HOME FOR VALUES\r
+ PUSH P,[0] ; SLOT FOR TEMP\r
+ PUSH P,B ; SAVE\r
+ SUB D,TD.LNT+1(TVP)\r
+ PUSH P,D ; SAVE FOR FINDING OTHER TABLES\r
+ JUMPE E,TD.UP2 ; NO REPEATING SEQ\r
+ ADD D,TD.GET+1(TVP) ; COMP LNTH OF REPEATING SEQ\r
+ HLRE D,(D) ; D ==> - LNTH OF TEMPLATE\r
+ ADDI D,(E) ; D ==> -LENGTH OF REP SEQ\r
+ MOVNS D\r
+ HRLM D,-5(P) ; SAVE IT AND BASIC\r
+\r
+TD.UP2: SKIPG D,-1(P) ; ANY LEFT?\r
+ JRST TD.UP1\r
+\r
+ MOVE E,TD.GET+1(TVP)\r
+ ADD E,(P)\r
+ MOVE E,(E) ; POINTER TO VECTOR IN E\r
+ MOVEM D,-6(P) ; SAVE ELMENT #\r
+ SKIPN B,-5(P) ; SKIP IF "RESTS" EXIST\r
+ SOJA D,TD.UP3\r
+\r
+ MOVEI 0,(B) ; BASIC LNT TO 0\r
+ SUBI 0,(D) ; SEE IF PAST BASIC\r
+ JUMPGE 0,.-3 ; JUMP IF O.K.\r
+ MOVSS B ; REP LNT TO RH, BASIC TO LH\r
+ IDIVI 0,(B) ; A==> -WHICH REPEATER\r
+ MOVNS A\r
+ ADD A,-5(P) ; PLUS BASIC\r
+ ADDI A,1 ; AND FUDGE\r
+ MOVEM A,-6(P) ; SAVE FOR PUTTER\r
+ ADDI E,-1(A) ; POINT\r
+ SOJA D,.+2\r
+\r
+TD.UP3: ADDI E,(D) ; POINT TO SLOT\r
+ XCT (E) ; GET THIS ELEMENT INTO A AND B\r
+ MOVEM A,-3(P) ; SAVE TYPE FOR LATER PUT\r
+ MOVEM B,-2(P)\r
+ GETYP C,A ; TYPE TO C\r
+ MOVE D,B ; DATUME\r
+ MOVEI B,-3(P) ; POINTER TO HOME\r
+ MOVE A,-7(P) ; GET INS\r
+ XCT A ; AND DO IT\r
+ MOVE C,-4(P) ; GET POINTER FOR UPDATE OF ELEMENT\r
+ MOVE E,TD.PUT+1(TVP)\r
+ SOS D,-1(P) ; RESTORE COUNT\r
+ ADD E,(P)\r
+ MOVE E,(E) ; POINTER TO VECTOR IN E\r
+ MOVE B,-6(P) ; SAVED OFFSET\r
+ ADDI E,(B)-1 ; POINT TO SLOT\r
+ MOVE A,-3(P) ; RESTORE TYPE WORD\r
+ MOVE B,-2(P)\r
+ XCT (E) ; SMASH IT BACK\r
+ FATAL TEMPLATE LOSSAGE\r
+ MOVE C,-4(P)\r
+ JRST TD.UP2\r
+\r
+TD.UP1: MOVE A,-7(P) ; RESTORE INS\r
+ SUB P,[10,,10]\r
+ MOVSI D,400000 ; RESTORE MARK/UNMARK BIT\r
+ JRST VHACK1\r
+\r
+; FATAL LOSSAGE ARRIVES HERE\r
+\r
+BADV: FATAL GC SPACE IN A BAD STATE\r
+\r
+; HERE TO HACK SPECIAL CRUFT IN GENERAL VECTORS (STACKS)\r
+\r
+EHACK: MOVSI D,-FRAMLN ; SET UP AOBJN PNTR\r
+\r
+EHACK1: HRRZ C,ETB(D) ; GET 1ST TYPE\r
+ PUSH P,D ; SAVE AOBJN\r
+ MOVE D,1(B) ; GET ITEM\r
+ CAME A,[PUSHJ P,SBSTIS] ; DONT IF SUBSTITUTE DIFFERENT\r
+ XCT A ; USER GOODIE\r
+ POP P,D ; RESTORE AOBJN\r
+ ADDI B,1 ; MOVE ON\r
+ SOSLE (P) ; ALSO COUNT IN TOTAL VECTOR\r
+ AOBJN D,EHACK1\r
+ AOJA B,GHACK1 ; AND GO ON\r
+\r
+; TABLE OF ENTRY BLOCK TYPES\r
+\r
+ETB: TSUBR\r
+ TTB\r
+ TAB\r
+ TSP\r
+ TPDL\r
+ TTP\r
+ TWORD\r
+\r
+; HERE TO GROVEL OVER BINDING BLOCKS\r
+\r
+BHACK: MOVEI C,TATOM ; ALSO TREEAT AS ATOM\r
+ MOVE D,1(B)\r
+ CAME A,[PUSHJ P,SBSTIS] ; DONT IF SUBSTITUTE DIFFERENT\r
+ XCT A\r
+ PUSHJ P,NXTGDY ; NEXT GOODIE\r
+ PUSHJ P,NXTGDY ; AND NEXT\r
+ MOVEI C,TSP ; TYPE THE BACK LOCATIVE\r
+ PUSHJ P,NXTGD1 ; AND NEXT\r
+ PUSH P,B\r
+ HLRZ D,-2(B) ; DECL POINTER\r
+ MOVEI B,0 ; MAKE SURE NO CLOBBER\r
+ MOVEI C,TDECL\r
+ XCT A ; DO THE THING BEING DONE\r
+ POP P,B\r
+ HRLM D,-2(B) ; FIX UP IN CASE CHANGED\r
+ JRST GHACK1\r
+\r
+; HERE TO HACK ATOMS WITH GDECLS\r
+\r
+GDHACK: CAMN A,[PUSHJ P,SBSTIS]\r
+ JRST VHACK1\r
+\r
+ MOVEI C,TATOM ; TREAT LIKE ATOM\r
+ MOVE D,1(B)\r
+ XCT A\r
+ HRRZ D,(B) ; GET DECL\r
+ JUMPE D,VHACK1\r
+ CAIN D,-1 ; WATCH OUT FOR MAINFEST\r
+ JRST VHACK1\r
+ PUSH P,B ; SAVE POINTER\r
+ MOVEI B,0\r
+ MOVEI C,TLIST\r
+ XCT A\r
+ POP P,B\r
+ HRRM D,(B) ; RESET\r
+ JRST VHACK1\r
+\r
+; HERE TO HACK ATOMS\r
+\r
+ATHACK: ADDI B,1 ; POINT PRIOR TO OBL SLOT\r
+ MOVEI C,TOBLS ; GET TYPE\r
+ MOVE D,1(B) ; AND DATUM\r
+ CAME A,[PUSHJ P,SBSTIS] ; DONT IF SUBSTITUTE DIFFERENT\r
+ XCT A\r
+ JRST VHACK1\r
+\r
+; HERE TO HACK ASSOCIATION BLOCKS\r
+\r
+ASHACK: MOVEI D,3 ; COUNT GOODIES TO MARK\r
+\r
+ASHAK1: PUSH P,D\r
+ MOVE D,1(B)\r
+ GETYP C,(B)\r
+ PUSH P,D ; SAVE POINTER\r
+ XCT A\r
+ POP P,D ; GET OLD BACK\r
+ CAME D,1(B) ; CHANGED?\r
+ TLO E,400000 ; SET NON-VIRGIN FLAG\r
+ POP P,D\r
+ PUSHJ P,BMP ; TO NEXT\r
+ SOJG D,ASHAK1\r
+\r
+; HERE TO GOT TO NEXT VECTOR\r
+\r
+VHACK1: MOVE B,-1(P) ; GET POINTER\r
+ SUB P,[2,,2] ; FLUSH CRUFT\r
+ SOJA B,VHACK2 ; FIXUP POINTER AND GO ON\r
+\r
+; ROUTINE TO GET A GOODIE\r
+\r
+NXTGDY: GETYP C,(B)\r
+NXTGD1: MOVE D,1(B)\r
+ XCT A ; DO IT TO IT\r
+BMP: SOS -1(P)\r
+ SOSG -1(P)\r
+ JRST BMP1\r
+ ADDI B,2\r
+ POPJ P,\r
+BMP1: SUB P,[1,,1]\r
+ JRST VHACK1\r
+\r
+REHASQ: JUMPL E,REHASH ; HASH TABLE RAPED, FIX IT\r
+ POPJ P,\r
+\r
+\r
+MFUNCTION SUBSTI,SUBR,[SUBSTITUTE]\r
+\r
+;THIS FUNCTION CODED BY NDR IS AN INCREDIBLE WAY TO\r
+;KILL YOURSELF, EVEN IF YOU THINK YOU REALLY KNOW WHAT\r
+;YOU ARE DOING.\r
+;IT DOES A MINI-GC CHANGING EACH REFERENCE OF THE\r
+;SECOND ITEM TO A REFERENCE OF THE FIRST ITEM, HA HA HA.\r
+;BOTH ITEMS MUST BE OF THE SAME TYPE OR\r
+;IF NOT, NEITHER CAN BE A TYPE REQUIRING TWO WORDS\r
+; OF STORAGE, AND SUBSTITUTION CANT BE DONE IN\r
+; UVECTORS WHEN THEY ARE DIFFERENT, AS WELL AS IN\r
+; A FEW OTHER YUCKY PLACES.\r
+;RETURNS ITEM TWO--THE ONLY WAY TO GET YOUR HANDS BACK ON IT\r
+\r
+ ENTRY 2\r
+\r
+\r
+SBSTI1: GETYP A,2(AB)\r
+ CAIE A,TATOM\r
+ JRST SBSTI2\r
+ MOVE B,3(AB) ; IMPURIFY HASH BUCKET MAYBE?\r
+ PUSHJ P,IMPURI\r
+\r
+SBSTI2: GETYP A,2(AB) ; GET TYPE OF SECOND ARG\r
+ MOVE D,A\r
+ PUSHJ P,NWORDT ; AND STORAGE ALLOCATION\r
+ MOVE E,A\r
+ GETYP A,(AB) ; GET TYPE OF FIRST ARG \r
+ MOVE B,A\r
+ PUSHJ P,NWORDT\r
+ CAMN B,D ; IF TYPES SAME, DONT CHECK FOR ALLOCATION\r
+ JRST SBSTI3\r
+ CAIN E,1\r
+ CAIE A,1\r
+ JRST SBSTIL ; LOOSE, NOT BOTH ONE WORD GOODIES\r
+\r
+SBSTI3: MOVEI C,0\r
+ CAIN D,0 ; IF GOODIE IS OF TYPE ZERO\r
+ MOVEI C,1 ; USE TYPE 1 TO KEEP INFO FROM CLOBBERAGE\r
+ PUSH TP,C\r
+ SUBI E,1\r
+ PUSH TP,E ; 1=DEFERRED TYPE ITEM, 0=ELSE\r
+ PUSH TP,C\r
+ PUSH TP,D ; TYPE OF GOODIE\r
+ PUSH TP,C\r
+ PUSH TP,[0]\r
+ CAIN D,TLIST\r
+ AOS (TP) ; 1=TYPE LIST, 0=ELSE\r
+ PUSH TP,C\r
+ PUSH TP,2(AB) ; TYPE-WORD\r
+ PUSH TP,C\r
+ PUSH TP,3(AB) ; VALUE-WORD\r
+ PUSH TP,(AB)\r
+ PUSH TP,1(AB) ; TYPE-VALUE OF THINGS TO CHANGE INTO\r
+ MOVE A,[PUSHJ P,SBSTIR]\r
+ CAME B,D ; IF NOT SAME TYPE, USE DIFF MUNGER\r
+ MOVE A,[PUSHJ P,SBSTIS]\r
+ PUSHJ P,GCHACK ; DO-IT\r
+ MOVE A,-4(TP)\r
+ MOVE B,-2(TP)\r
+ JRST FINIS ; GIVE THE LOOSER A HANDLE ON HIS GOODIE\r
+\r
+SBSTIR: CAME D,-2(TP)\r
+ JRST LSUB ; THIS IS IT\r
+ CAME C,-10(TP)\r
+ JRST LSUB ; IF ITEM CANT BE SAME CHECK FOR LISTAGE\r
+ JUMPE B,LSUB+1 ; WE GOT HOLD OF A FUNNY GOODIE, JUST IGNORE IT\r
+ MOVE 0,(TP)\r
+ MOVEM 0,1(B) ; SMASH IT\r
+ MOVE 0,-1(TP) ; GET TYPE WORD\r
+ SKIPE -12(TP) ; IF THIS IS A DEFFERABLE ITEM THEN WE MUST\r
+ MOVEM 0,(B) ; ALSO SMASH THE TYPE WORD SLOT\r
+\r
+LSUB: SKIPN -6(TP) ; IF WE ARE LOOKING FOR LISTS, LOOK ON\r
+ POPJ P, ; ELSE THATS ALL\r
+ CAMG B,PARTOP\r
+ CAMGE B,PARBOT ; IS IT IN LIST SPACE?\r
+ POPJ P, ; WELL NO LIST SMASHING THIS TIME\r
+ HRRZ 0,(B) ; GET ITS LIST POINTER\r
+ CAME 0,-2(TP)\r
+ POPJ P, ; THIS ONE DIDNT MATCH\r
+ MOVE 0,(TP) ; GET THE NEW REST OF THE LIST\r
+ HRRM 0,(B) ; AND SMASH INTO THE REST OF THE LIST\r
+ POPJ P,\r
+\r
+SBSTIS: CAMN D,-2(TP)\r
+ CAME C,-10(TP)\r
+ POPJ P,\r
+ SKIPN B ; SEE IF THIS IS A FUNNY GOODIE WE NO TOUCHIE\r
+ POPJ P,\r
+ MOVE 0,(TP)\r
+ MOVEM 0,1(B) ; KLOBBER VALUE CELL\r
+ MOVE 0,-1(TP)\r
+ HLLM 0,(B) ; KLOBBER TYPE CELL, WHICH WE KNOW IS THERE\r
+ POPJ P,\r
+\r
+SBSTIL: PUSH TP,$TATOM ; LOSSAGE ON DIFFERENT TYPES, ONE DOUBLE WORD\r
+ PUSH TP,EQUOTE CANT-SUBSTITUTE-WITH-STRING-OR-TUPLE-AND-OTHER\r
+ JRST CALER1\r
+\r
+END\r
+\r
+\fTITLE INITIALIZATION FOR MUDDLE\r
+\r
+RELOCATABLE\r
+\r
+LAST==1 ;POSSIBLE CHECKS DONE LATER\r
+\r
+.INSRT MUDDLE >\r
+\r
+SYSQ\r
+\r
+IFE ITS,[\r
+FATINS==.FATAL"\r
+SEVEC==104000,,204\r
+]\r
+\r
+IMPURE\r
+\r
+OBSIZE==151. ;DEFAULT OBLIST SIZE\r
+\r
+.LIFG <TVBASE+TVLNT-TVLOC>\r
+.LOP .VALUE\r
+.ELDC\r
+\r
+\r
+.GLOBAL SETUP,TPBAS,GCPDL,GCPVP,PVBASE,PVLNT,PARNEW,AAGC,ICR,SWAP,OBLNT,MSGTYP\r
+.GLOBAL ICLOS,OCLOS,GLOBASE,GLOBSP,PARBOT,PARTOP,CODTOP,START,BEGIN,VECBOT,VECTOP,TPBASE\r
+.GLOBAL LISTEN,ROOT,INITIAL,TBINIT,TOPLEV,INTOBL,ERROBL,MUDOBL,TTYOPE,RESFUN,QUITTER\r
+.GLOBAL IOINS,BUFRIN,IOIN2,ECHO,MTYI,MTYO,MUDSTR,P.TOP,TTICHN,TTOCHN,TYPVEC\r
+.GLOBAL PDLBUF,PHIBOT,%UNAM,PURVEC,STOSTR,ISTOST,TD.LNT,TD.PUT,TD.GET,CAFRE1\r
+; INIITAL AMOUNT OF AFREE SPACE\r
+\r
+STOSTR: BLOCK 400 ; A RANDOM AMOUNT\r
+ISTOST: 401,,0\r
+\r
+SETUP:\r
+IFN ITS, .SUSET [.RUNAM,,%UNAM] ; FOR AGC'S BENFIT\r
+ MOVE P,GCPDL ;GET A PUSH DOWN STACK\r
+IFN ITS, .SUSET [.SMASK,,[200000]] ; ENABLE PDL OVFL\r
+ MOVE TVP,[-TVLNT,,TVBASE] ;GET INITIAL TRANSFER VECTOR\r
+ PUSHJ P,TTYOPE ;OPEN THE TTY\r
+ AOS A,20 ; TOP OF LOW SEGG\r
+ HRRZM A,P.TOP\r
+ SOSN A ; IF NOTHING YET\r
+IFN ITS, .SUSET [.RMEMT,,P.TOP]\r
+IFE ITS, JRST 4,\r
+ HRRE A,P.TOP ; CHECK TOP\r
+ TRNE A,377777 ; SKIP IF ALL LOW SEG\r
+ JUMPL A,PAGLOS ; COMPLAIN\r
+ MOVE A,HITOP ; FIND HI SEG TOP\r
+ ADDI A,1777\r
+ ANDCMI A,1777\r
+ MOVEM A,RHITOP ; SAVE IT\r
+ MOVEI A,200\r
+ SUBI A,PHIBOT\r
+ JUMPE A,HIBOK\r
+ MOVSI A,(A)\r
+ HRRI A,200\r
+IFN ITS,[\r
+ .CALL GIVCOR\r
+ .VALUE\r
+]\r
+HIBOK: MOVEI B,[ASCIZ /MUDDLE INITIALIZATION.\r
+/]\r
+ PUSHJ P,MSGTYP ;PRINT IT\r
+ MOVE A,CODTOP ;CHECK FOR A WINNING LOAD\r
+ CAML A,VECBOT ;IT BETTER BE LESS\r
+ JRST DEATH1 ;LOSE COMPLETELY\r
+ MOVE B,PARBOT ;CHECK FOR ANY PAIRS\r
+ CAME B,PARTOP ;ANY LOAD/ASSEMBLE TIME PAIRS?\r
+ JRST PAIRCH ;YES CHECK THEM\r
+ ADDI A,2000 ;BUMP UP\r
+ ANDCMI A,1777\r
+ MOVEM A,PARBOT ;UPDATE PARBOT AND TOP\r
+ MOVEM A,PARTOP\r
+SETTV: MOVE PVP,[-PVLNT*2,,GCPVP] ;AND A PROCESS VECTOR\r
+ MOVEI A,(PVP) ;SET UP A BLT\r
+ HRLI A,PVBASE ;FROM PROTOTYPE\r
+ BLT A,PVLNT*2-1(PVP) ;INITIALIZE\r
+ MOVE TP,[-ITPLNT,,TPBAS] ;GET A STACK FOR THIS PROCCESS\r
+ MOVEI TB,(TP) ;AND A BASE\r
+ HRLI TB,1\r
+ SUB TP,[1,,1] ;POP ONCE\r
+\r
+; ALLOCATE SOME OBLISTS FOR INITIAL ATOMS\r
+\r
+ PUSH P,[5] ;COUNT INITIAL OBLISTS\r
+\r
+ PUSH P,OBLNT ;SAVE CURRENT OBLIST DEFAULT SIZE\r
+\r
+MAKEOB: SOS A,-1(P)\r
+ MOVE A,OBSZ(A)\r
+ MOVEM A,OBLNT\r
+ MCALL 0,MOBLIST ;GOBBLE AN OBLIST\r
+ PUSH TP,$TOBLS ;AND SAVE THEM\r
+ PUSH TP,B\r
+ MOVE A,(P)-1 ;COUNT DOWN\r
+ MOVEM B,@OBTBL(A) ;STORE\r
+ JUMPN A,MAKEOB\r
+\r
+ POP P,OBLNT ;RESTORE DEFAULT OBLIST SIZE\r
+\r
+ MOVE C,TVP ;MAKE 2 COPIES OF XFER VECTOR POINTER\r
+ MOVE D,TVP\r
+\r
+;MAIN INITIALIZE LOOP - SCAN XFER VECTOR FOR ATOMS, UPDATE\r
+;OFFSETS IN CODE, UNIQUIFY ATOMS AND COMPACT XFER VECTOR\r
+\r
+ILOOP: HLRZ A,(C) ;FIRST TYPE\r
+ JUMPE A,TVEXAU ;USEFUL STUFF EXHAUSTED\r
+ CAIN A,TCHSTR ;CHARACTER STRING?\r
+ JRST CHACK ;YES, GO HACK IT\r
+ CAIN A,TATOM ;ATOM?\r
+ JRST ATOMHK ;YES, CHECK IT OUT\r
+ MOVE A,(C) ;MOVE TO NEW HOME (MAY BE SAME)\r
+ MOVEM A,(D)\r
+ MOVE A,1(C)\r
+ MOVEM A,1(D)\r
+SETLP: AOS (P) ;COUNT NUMBER OF PAIRS IN XFER VECTOR\r
+ ADD D,[2,,2] ;OUT COUNTER\r
+SETLP1: ADD C,[2,,2] ;AND IN COUNTER\r
+ JUMPL C,ILOOP ;JUMP IF MORE TO DO\r
+\f;NEW XFER VECTOR FINISHED, NOW GIVE AWAY THE REST\r
+\r
+TVEXAU: HLRE B,C ;GET -LENGTH\r
+ SUBI C,(B) ;POIT TO DOPE WORD\r
+ ANDI C,-1 ;NO LH\r
+ HLRZ A,1(C) ;INTIAL LENGTH TO A\r
+ MOVEI E,(C) ;COPY OF POINTER TO DOPW WD\r
+ SUBI E,(D) ;AMOUNT LEFT OVER TO E\r
+ HRLZM E,1(C) ;CLOBBER INTO DOPE WORD FOR GARBAGE\r
+ MOVSI E,(E) ;PREPARE TO UPDATE TVP\r
+ ADD TVP,E ;NOW POINTS TO THE RIGHT AMOUNT\r
+ HLRE B,D ;-AMOUNT LEFT TO B\r
+ ADD B,A ;AMOUNT OF GOOD STUFF\r
+ HRLZM B,1(D) ;STORE IT IN GODD DOPE WORD\r
+ MOVSI E,400000 ;CLOBBER TO GENERAL IN BOTH CASES\r
+ MOVEM E,(C)\r
+ MOVEM E,(D)\r
+\r
+\r
+; FIX UP TYPE VECTOR\r
+\r
+ MOVE A,TYPVEC+1(TVP) ;GET POINTER\r
+ MOVEI 0,0 ;FOR POSSIBLE NULL SLOTS\r
+ MOVSI B,TATOM ;SET TYPE TO ATOM\r
+\r
+TYPLP: HLLM B,(A) ;CHANGE TYPE TO ATOM\r
+ MOVE C,@1(A) ;GET ATOM\r
+ MOVEM C,1(A)\r
+ ADD A,[2,,2] ;BUMP\r
+ JUMPL A,TYPLP\r
+\f; CLOSE TTY CHANNELS\r
+IFN ITS,[\r
+\r
+ .CLOSE 1,\r
+ .CLOSE 2,\r
+]\r
+\r
+;GENERAT THE LOGICAL TTY IN AND OUT CHANNELS\r
+\r
+;SETUP CALL TO OPEN OUTPUT TTY CHANNNEL\r
+\r
+ IRP A,,[[PRINT,TCHSTR],[TTY:,TCHSTR]]\r
+ IRP B,C,[A]\r
+ PUSH TP,$!C\r
+ PUSH TP,CHQUOTE B\r
+ .ISTOP\r
+ TERMIN\r
+ TERMIN\r
+\r
+ MCALL 2,FOPEN ;OPEN THE OUT PUT CHANNEL\r
+ MOVEM B,TTOCHN+1(TVP) ;SAVE IT\r
+\r
+;ASSIGN AS GLOBAL VALUE\r
+\r
+ PUSH TP,$TATOM\r
+ PUSH TP,IMQUOTE OUTCHAN\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ MOVE A,[PUSHJ P,MTYO] ;MORE WINNING INS\r
+ MOVEM A,IOINS(B) ;CLOBBER\r
+ MCALL 2,SETG\r
+\r
+;SETUP A CALL TO OPEN THE TTY CHANNEL\r
+\r
+ IRP A,,[[READ,TCHSTR],[TTY:,TCHSTR]]\r
+ IRP B,C,[A]\r
+ PUSH TP,$!C\r
+ PUSH TP,CHQUOTE B\r
+ .ISTOP\r
+ TERMIN\r
+ TERMIN\r
+\r
+ MCALL 2,FOPEN ;OPEN INPUTCHANNEL\r
+ MOVEM B,TTICHN+1(TVP) ;SAVE IT\r
+ PUSH TP,$TATOM ;ASSIGN AS A GLOBAL VALUE\r
+ PUSH TP,IMQUOTE INCHAN\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ MOVE C,BUFRIN(B) ;GET AUX BUFFER PTR\r
+ MOVE A,[PUSHJ P,MTYI]\r
+ MOVEM A,IOIN2(C) ;MORE OF A WINNER\r
+ MOVE A,[PUSHJ P,MTYO]\r
+ MOVEM A,ECHO(C) ;ECHO INS\r
+ MCALL 2,SETG\r
+\r
+;GENERATE AN INITIAL PROCESS AND SWAP IT IN\r
+\r
+ PUSHJ P,ICR ;CREATE IT\r
+ MOVEI 0,RUNING\r
+ MOVEM 0,PSTAT"+1(B)\r
+ MOVE D,B ;SET UP TO CALL SWAP\r
+ JSP C,SWAP ;AND SWAP IN\r
+ MOVEM PVP,MAINPR" ;SAVE AS THE MAIN PROCESS\r
+ PUSH TP,[TENTRY,,TOPLEV] ;BUILD DUMMY FRAME\r
+ PUSH TP,[1,,0]\r
+ MOVEI A,-1(TP)\r
+ PUSH TP,A\r
+ PUSH TP,SP\r
+ PUSH TP,P\r
+ MOVE C,TP ;COPY TP\r
+ ADD C,[3,,3] ;FUDGE\r
+ PUSH TP,C ;TPSAV PUSHED\r
+ PUSH TP,[TOPLEV]\r
+ HRRI TB,(TP) ;SETUP TB\r
+ HRLI TB,2\r
+ ADD TB,[1,,1]\r
+ MOVEM TB,TBINIT+1(PVP)\r
+ MOVSI A,TSUBR\r
+ MOVEM A,RESFUN(PVP)\r
+ MOVEI A,LISTEN"\r
+ MOVEM A,RESFUN+1(PVP)\r
+ PUSH TP,$TATOM\r
+ PUSH TP,IMQUOTE THIS-PROCESS\r
+ PUSH TP,$TPVP\r
+ PUSH TP,PVP\r
+ MCALL 2,SETG\r
+\r
+; FIND TVP OFFSET FOR THE ATOM 'T' FOR TEMPLATE\r
+\r
+ MOVEI A,MQUOTE T\r
+ SUBI A,(TVP)\r
+TVTOFF==0\r
+ ADDSQU TVTOFF\r
+\r
+ MOVEM A,SQULOC-1\r
+\r
+ PUSH TP,$TATOM\r
+ PUSH TP,IMQUOTE TVTOFF,,MUDDLE\r
+ PUSH TP,$TFIX\r
+ PUSH TP,A\r
+ MCALL 2,SETG\r
+\r
+; HERE TO SETUP SQUOZE TABLE IN PURE CORE\r
+\r
+ PUSHJ P,SQSETU ; GO TO ROUTINE\r
+\r
+ MOVEI A,400000 ; FENCE POST PURE SR VECTOR\r
+ HRRM A,PURVEC(TVP)\r
+ MOVE A,TP\r
+ HLRE B,A\r
+ SUBI A,-PDLBUF(B) ;POINT TO DOPE WORDS\r
+ MOVEI B,12 ;GROWTH SPEC\r
+ IORM B,(A)\r
+ MOVEI 0,ISTOST\r
+ MOVEM 0,CODTOP\r
+ PUSHJ P,AAGC ;DO IT\r
+ AOJL A,.-1\r
+ MOVE A,TPBASE+1(PVP)\r
+ SUB A,[640.,,640.]\r
+ MOVEM A,TPBASE+1(PVP)\r
+\r
+; CREATE LIST OF ROOT AND NEW OBLIST\r
+\r
+ MOVEI A,5\r
+ PUSH P,A\r
+\r
+NAMOBL: PUSH TP,$TATOM\r
+ PUSH TP,@OBNAM-1(A) ; NAME\r
+ PUSH TP,$TATOM\r
+ PUSH TP,IMQUOTE OBLIST\r
+ PUSH TP,$TOBLS\r
+ PUSH TP,@OBTBL-1(A)\r
+ MCALL 3,PUT ; NAME IT\r
+ SOS A,(P)\r
+ PUSH TP,$TOBLS\r
+ PUSH TP,@OBTBL(A)\r
+ PUSH TP,$TATOM\r
+ PUSH TP,IMQUOTE OBLIST\r
+ PUSH TP,$TATOM\r
+ PUSH TP,@OBNAM(A)\r
+ MCALL 3,PUT\r
+ SKIPE A,(P)\r
+ JRST NAMOBL\r
+ SUB P,[1,,1]\r
+\r
+;Define MUDDLE version number\r
+ MOVEI A,5\r
+ MOVEI B,0 ;Initialize result\r
+ MOVE C,[440700,,MUDSTR+2]\r
+VERLP: ILDB D,C ;Get next charcter digit\r
+ CAIG D,"9 ;Non-digit ?\r
+ CAIGE D,"0\r
+ JRST VERDEF\r
+ SUBI D,"0 ;Convert to number\r
+ IMULI B,10.\r
+ ADD B,D ;Include number into result\r
+ SOJG A,VERLP ;Finished ?\r
+VERDEF:\r
+ PUSH TP,$TATOM\r
+ PUSH TP,MQUOTE MUDDLE\r
+ PUSH TP,$TFIX\r
+ PUSH TP,B\r
+ MCALL 2,SETG ;Make definition\r
+OPIPC:\r
+IFN ITS,[\r
+ PUSH TP,$TCHSTR\r
+ PUSH TP,CHQUOTE IPC\r
+ PUSH TP,$TATOM\r
+ PUSH TP,MQUOTE IPC-HANDLER\r
+ MCALL 1,GVAL\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ PUSH TP,$TFIX\r
+ PUSH TP,[1]\r
+ MCALL 3,ON\r
+ MCALL 0,IPCON\r
+]\r
+\r
+; Allocate inital template tables\r
+\r
+ MOVEI A,10\r
+ PUSHJ P,CAFRE1\r
+ ADD B,[10,,10] ; REST IT OFF\r
+ MOVEM B,TD.LNT+1(TVP)\r
+ MOVEI A,10\r
+ PUSHJ P,CAFRE1\r
+ MOVEI 0,TUVEC ; SETUP UTYPE\r
+ HRLM 0,10(B)\r
+ MOVEM B,TD.GET+1(TVP)\r
+ MOVEI A,10\r
+ PUSHJ P,CAFRE1\r
+ MOVEI 0,TUVEC ; SETUP UTYPE\r
+ HRLM 0,10(B)\r
+ MOVEM B,TD.PUT+1(TVP)\r
+\r
+PTSTRT: MOVEI A,SETUP\r
+ ADDI A,1\r
+ SUB A,PARBOT ;FIND WHERE PAIRS SHOULD GO\r
+ MOVEM A,PARNEW\r
+IFE ITS,[\r
+ MOVEI A,400000\r
+ MOVE B,[1,,START]\r
+ SEVEC\r
+]\r
+ PUSH P,[14.,,14.] ;PUSH A SMALL PRGRM ONTO P\r
+ MOVEI A,1(P) ;POINT TO ITS START\r
+ PUSH P,[JRST AAGC] ;GO TO AGC\r
+ PUSH P,[MOVE B,PSTO+1(PVP)] ;GET SAVED P\r
+ PUSH P,[SUB B,-13.(P)] ;FUDGE TO POP OFF PROGRAM\r
+ PUSH P,[MOVEM B,PSAV(TB)] ;INTO FRAME\r
+ PUSH P,[MOVE B,TPSTO+1(PVP)] ;GET TP\r
+ PUSH P,[MOVEM B,TPSAV(TB)] ;STORE IT\r
+ PUSH P,[MOVE B,SPSTO+1(PVP)] ;SP\r
+ PUSH P,[MOVEM B,SPSAV(TB)]\r
+ PUSH P,[MOVEI B,TOPLEV] ;WHERE TO GO\r
+ PUSH P,[MOVEM B,PCSAV(TB)]\r
+IFN ITS, PUSH P,[MOVSI B,(.VALUE )]\r
+IFE ITS, PUSH P,[MOVSI B,(JRST 4,)]\r
+ PUSH P,[HRRI B,C]\r
+ PUSH P,[JRST B] ;GO DO VALRET\r
+ PUSH P,[B]\r
+ PUSH P,A ; PUSH START ADDR\r
+ MOVE B,[JRST -11.(P)]\r
+ MOVE 0,[JUMPA START]\r
+ MOVE C,[ASCII \\170/\e9\]\r
+ MOVE D,[ASCII \B/\e1Q\]\r
+ MOVE E,[ASCIZ \\r
+\16*\r
+\] ;TERMINATE\r
+ POPJ P, ; GO\r
+\f\r
+; CHECK PAIR SPACE\r
+\r
+PAIRCH: CAMG A,B\r
+ JRST SETTV ;O.K.\r
+\r
+DEATH1: MOVEI B,[ASCIZ /LOSSAGE--CODE AND DATA OVERLAP\r
+/]\r
+ PUSHJ P,MSGTYP\r
+ .VALUE\r
+\r
+;CHARACTER STRING HACKER\r
+\r
+CHACK: MOVE A,(C) ;GET TYPE\r
+ HLLZM A,(D) ;STORE IN NEW HOME\r
+ MOVE B,1(C) ;GET POINTER\r
+ HLRZ E,B ;-LENGHT\r
+ HRRM E,(D)\r
+ PUSH P,E+1 ; IDIVI WILL CLOBBER\r
+ ADDI E,4+5*2 ; ROUND AND ACCOUNT FOR DOPE WORDS\r
+ IDIVI E,5 ; E/ WORDS LONG\r
+ PUSHJ P,EBPUR ; MAKE A PURIFIED COPY\r
+ POP P,E+1\r
+ HRLI B,440700 ;MAKE POINT BYTER\r
+ MOVEM B,1(D) ;AND STORE IT\r
+ ANDI A,-1 ;CLEAR LH OF A\r
+ JUMPE A,SETLP ;JUMP IF NO REF\r
+ MOVE E,(P) ;GET OFFSET\r
+ LSH E,1\r
+ HRRZ B,-1(A) ;SEE IF PREVIOUS INSTRUCTION REFERS TO $TCHSTR\r
+ CAIE B,$TCHSTR ;SKIP IF IT DOES\r
+ JRST CHACK1 ;NO, JUST DO CHQUOTE PART\r
+ HRRM E,-1(A) ;CLOBBER\r
+ MOVEI B,TVP\r
+ DPB B,[220400,,-1(A)] ;CLOBBER INDEX FIELD\r
+CHACK1: ADDI E,1\r
+ HRRM E,(A) ;STORE INTO REFERENCE\r
+ JRST SETLP\r
+\r
+; SUBROUTINE TO COPY A HUNK OF STRUCTURE TO THE HIGH SEGMENT\r
+\r
+EBPUR: PUSH P,E\r
+ PUSH P,A\r
+ ADD E,HITOP ; GET NEW TOP\r
+ CAMG E,RHITOP ; SKIP IF TOO BIG\r
+ JRST EBPUR1\r
+\r
+; CODE TO GROW HI SEG \r
+\r
+ MOVEI A,2000\r
+ ADDB A,RHITOP ; NEW TOP\r
+IFN ITS,[\r
+ ASH A,-10. ; NUM OF BLOCKS\r
+ SUBI A,1 ; BLOCK TO GET\r
+ .CALL HIGET\r
+ .VALUE\r
+]\r
+\r
+EBPUR1: MOVEI A,-1(E) ; NEEDED TO TERMINATE BLT\r
+ EXCH E,HITOP\r
+ HRLI E,(B)\r
+ MOVEI B,(E)\r
+ BLT E,(A)\r
+ POP P,A\r
+ POP P,E\r
+ POPJ P,\r
+\r
+GIVCOR: SETZ\r
+ SIXBIT /CORBLK/\r
+ 1000,,0\r
+ 1000,,-1\r
+ SETZ A\r
+\r
+HIGET: SETZ\r
+ SIXBIT /CORBLK/\r
+ 1000,,100000\r
+ 1000,,-1\r
+ A\r
+ 401000,,400001\r
+\r
+\f\r
+; PROCESS AN ATOM AND ADD IT TO AN APPROPRIATE OBLIST IF IT ISN'T\r
+; ALREADY THERE\r
+\r
+ATOMHK: PUSH TP,$TOBLS ; SAVE OBLIST\r
+ PUSH TP,[0] ; FILLED IN LATER\r
+ PUSH TP,$TVEC ;SAVE TV POINTERS\r
+ PUSH TP,C\r
+ PUSH TP,$TVEC\r
+ PUSH TP,D\r
+ MOVE B,1(C) ;GET THE ATOM\r
+ PUSH TP,$TATOM ;AND SAVE\r
+ PUSH TP,B\r
+ HRRZ A,(B) ;GET OBLIST SPEC FROM ATOM\r
+ LSH A,1\r
+ ADDI A,1(TB) ;POINT TO ITS HOME\r
+ PUSH TP,$TOBLS\r
+ PUSH TP,(A) ;AND SAV IT\r
+ MOVE A,(A)\r
+ MOVEM A,-10(TP) ; CLOBBER\r
+ HLRE E,A\r
+ MOVNS E\r
+\r
+ ADD B,[3,,3] ;POINT TO ATOM'S PNAME\r
+ MOVEI A,0 ;FOR HASHING\r
+ XOR A,(B)\r
+ AOBJN B,.-1\r
+ TLZ A,400000 ;FORCE POSITIVE RESULT\r
+ IDIV A,E\r
+ HRLS B ;REMAINDER IN B IS BUCKET\r
+ ADDB B,(TP) ;UPDATE POINTER\r
+\r
+ SKIPN C,(B) ;GOBBLE BUCKET CONTENTS\r
+ JRST USEATM ;NONE, LEAVE AND USE THIS ATOM\r
+OBLOO3: MOVE E,-2(TP) ;RE-GOBBLE ATOM\r
+ ADD E,[3,,3] ;POINT TO PNAME\r
+ SKIPN D,1(C) ;CHECK LIST ELEMNT\r
+ JRST NXTBCK ;0, CHECK NEXT IN THIS BUCKET\r
+ ADD D,[3,,3] ;POINT TO PNAME\r
+OBLOO2: MOVE A,(D) ;GET A WORD\r
+ CAME A,(E) ;COMPARE\r
+ JRST NXTBCK ;THEY DIFFER, TRY NEX\r
+OBLOOP: AOBJP E,CHCKD ;COULD BE A MATCH, GO CHECK\r
+ AOBJN D,OBLOO2 ;HAVEN'T LOST YET\r
+\r
+NXTBCK: HRRZ C,(C) ;CDR THE LIST\r
+ JUMPN C,OBLOO3 ;IF NOT NIL, KEEP TRYING\r
+\r
+;HERE IF THIS ATOM MUST BE PUT ON OBLIST\r
+\r
+USEATM: MOVE B,-2(TP) ; GET ATOM\r
+ HLRZ 0,(B) ; SEE IF PURE OR NOT\r
+ TRNN 0,400000 ; SKIP IF IMPURE\r
+ JRST PURATM\r
+ MOVE B,(TP) ;POINTER TO BUCKET\r
+ HRRZ C,(B) ;POINTER TO LIST IN THIS BUCKET\r
+ PUSH TP,$TATOM ;GENERATE CALL TO CONS\r
+ PUSH TP,-3(TP)\r
+ PUSH TP,$TLIST\r
+ PUSH TP,C\r
+ MCALL 2,CONS ;CONS IT UP\r
+ MOVE C,(TP) ;REGOBBLE BUCKET POINTER\r
+ HRRZM B,(C) ;CLOBBER\r
+ MOVE B,-2(TP) ;POINT TO ATOM\r
+ MOVE C,-10(TP) ; GET OBLIST\r
+ MOVEM C,2(B) ; INTO ATOM\r
+ PUSHJ P,VALMAK ;MAKE A GLOBAL VALUE FOR THIS LOSER\r
+PURAT2: MOVE C,-6(TP) ;RESET POINTERS\r
+ MOVE D,-4(TP)\r
+ SUB TP,[12,,12]\r
+ MOVE B,(C) ;MOVE THE ENTRY\r
+ HLLZM B,(D) ;DON'T WANT REF POINTER STORED\r
+ MOVE A,1(C) ;AND MOVE ATOM\r
+ MOVEM A,1(D)\r
+ MOVE A,(P) ;GET CURRENT OFFSET\r
+ LSH A,1\r
+ ADDI A,1\r
+ ANDI B,-1 ;CHECK FOR REAL REF\r
+ JUMPE B,SETLP1 ;DON'T SAVE THIS ATOM ON TVP\r
+ HRRM A,(B) ;CLOBBER CODE\r
+ JRST SETLP\r
+\r
+\r
+; HERE TO MAKE A PURE ATOM\r
+\r
+PURATM: HRRZ B,-2(TP) ; POINT TO IT\r
+ HLRE E,-2(TP) ; - LNTH\r
+ MOVNS E\r
+ ADDI E,2\r
+ PUSHJ P,EBPUR ; PURE COPY\r
+ HRRM B,-2(TP) ; AND STORE BACK\r
+ HRRO B,(TP) ; GET BUCKET BACK\r
+PURAT1: HRRZ C,(B) ; GET CONTENTS\r
+ JUMPE C,HICONS ; AT END, OK\r
+ CAIL C,HIBOT ; SKIP IF IMPURE\r
+ JRST HICONS ; CONS IT ON\r
+ MOVEI B,(C)\r
+ JRST PURAT1\r
+\r
+HICONS: HRLI C,TATOM\r
+ PUSH P,C\r
+ PUSH P,-2(TP)\r
+ PUSH P,B\r
+ MOVEI B,-2(P)\r
+ MOVEI E,2\r
+ PUSHJ P,EBPUR ; MAKE PURE LIST CELL\r
+\r
+ MOVE C,(P)\r
+ SUB P,[3,,3]\r
+ HRRM B,(C) ; STORE IT\r
+ MOVE B,1(B) ; ATOM BACK\r
+ MOVE C,-6(TP) ; GET TVP SLOT\r
+ HRRM B,1(C) ; AND STORE\r
+ HLRZ 0,(B) ; TYPE OF VAL\r
+ MOVE C,B\r
+ CAIN 0,TUNBOU ; NOT UNBOUND?\r
+ JRST PURAT3 ; UNBOUND, NO VAL\r
+ MOVEI E,2 ; COUNT AGAIN\r
+ PUSHJ P,EBPUR ; VALUE CELL\r
+ MOVE C,-2(TP) ; ATOM BACK\r
+ HLLZS (B) ; CLEAR LH\r
+ MOVSI 0,TLOCI\r
+ HLLM 0,(C)\r
+ MOVEM B,1(C)\r
+PURAT3: HRRZ A,(C) ; GET OBLIST CODE\r
+ MOVE A,OBTBL2(A)\r
+ MOVEM A,2(C) ; STORE OBLIST SLOT\r
+ HLLZS (C)\r
+ JRST PURAT2\r
+\f\r
+; A POSSIBLE MATCH ARRIVES HERE\r
+\r
+CHCKD: AOBJN D,NXTBCK ;SIZES DIFFER, JUMP\r
+ MOVE D,1(C) ;THEY MATCH!, GET EXISTING ATOM\r
+ MOVEI A,(D) ;GET TYPE OF IT\r
+ MOVE B,-2(TP) ;GET NEW ATOM\r
+ HLRZ 0,(B)\r
+ TRZ A,377777 ; SAVE ONLY 400000 BIT\r
+ TRZ 0,377777\r
+ CAIN 0,(A) ; SKIP IF WIN\r
+ JRST IM.PUR\r
+ MOVSI 0,400000\r
+ ANDCAM 0,(B)\r
+ ANDCAM 0,(D)\r
+ HLRZ A,(D)\r
+ CAIE A,TUNBOU ;UNBOUND?\r
+ JRST A1VAL ;YES, CONTINUE\r
+ MOVE A,(B) ;MOVE VALUE\r
+ MOVEM A,(D)\r
+ MOVE A,1(B)\r
+ MOVEM A,1(D)\r
+ MOVE B,D ;EXISTING ATOM TO B\r
+ MOVEI 0,(B)\r
+ CAIL 0,HIBOT\r
+ JRST .+3\r
+ PUSHJ P,VALMAK ;MAKE A VALUE\r
+ JRST .+2\r
+ PUSHJ P,PVALM\r
+\r
+;NOW FIND ATOMS OCCURENCE IN XFER VECTOR\r
+\r
+OFFIND: MOVE D,-4(TP) ;GET CURRENT POINTER INTO TP\r
+ MOVE C,TVP ;AND A COPY OF TVP\r
+ MOVEI A,0 ;INITIALIZE COUNTER\r
+ALOOP: CAMN B,1(C) ;IS THIS IT?\r
+ JRST AFOUND\r
+ ADD C,[2,,2] ;BUMP COUNTER\r
+ CAMGE C,D ;HAVE WE HIT END\r
+ AOJA A,ALOOP ;NO, KEEP LOOKING\r
+\r
+ MOVEI B,[ASCIZ /LOSSAGE--ATOM DISAPPEARED\r
+/]\r
+TYPIT: PUSHJ P,MSGTYP\r
+ .VALUE\r
+\r
+AFOUND: LSH A,1 ;FOUND ATOM, GET REAL OFFSET\r
+ ADDI A,1\r
+ MOVE C,-6(TP) ;GET TV POINTER TO NEW ATOM\r
+ HRRZ B,(C) ;POINT TO REFERENCE\r
+ SKIPE B ;ANY THERE?\r
+ HRRM A,(B) ;YES, CLOBBER AWAY\r
+ SUB TP,[12,,12]\r
+ JRST SETLP1 ;AND GO ON\r
+\r
+A1VAL: HLRZ C,(B) ;GET VALUE'S TYPE\r
+ MOVE B,D ;NOW PUT EXISTING ATOM IN B\r
+ CAIN C,TUNBOU ;UNBOUND?\r
+ JRST OFFIND ;YES, WINNER\r
+\r
+ MOVEI B,[ASCIZ /LOSSAGE--ATOM TRIES TO HAVE 2 VALUES\r
+/]\r
+ JRST TYPIT\r
+\r
+\r
+IM.PUR: MOVEI B,[ASCIZ /LOSSAG--ATOM TRIES TO BE BOTH PURE AND IMPURE\r
+/]\r
+ JRST TYPIT\r
+\r
+PAGLOS: MOVEI B,[ASCIZ /LOSSAGE--IMPURE CORE EXTENDS INTO HIGH SEGMENT\r
+/]\r
+ JRST TYPIT\r
+\f\r
+;MAKE A VALUE IN SLOT ON GLOBAL SP\r
+\r
+VALMAK: HLRZ A,(B) ;TYPE OF VALUE\r
+ CAIE A,400000+TUNBOU\r
+ CAIN A,TUNBOU ;VALUE?\r
+ POPJ P, ;NO, ALL DONE\r
+ MOVE A,GLOBSP+1(TVP) ;GET POINTER TO GLOBAL SP\r
+ SUB A,[4,,4] ;ALLOCATE SPACE\r
+ CAMG A,GLOBAS+1(TVP) ;CHECK FOR OVERFLOW\r
+ JRST SPOVFL\r
+ MOVEM A,GLOBSP+1(TVP) ;STORE IT BACK\r
+ MOVE C,(B) ;GET TYPE CELL\r
+ TLZ C,400000\r
+ HLLZM C,2(A) ;INTO TYPE CELL\r
+ MOVE C,1(B) ;GET VALUE\r
+ MOVEM C,3(A) ;INTO VALUE SLOT\r
+ MOVSI C,TGATOM ;GET TATOM,,0\r
+ MOVEM C,(A)\r
+ MOVEM B,1(A) ;AND POINTER TO ATOM\r
+ MOVSI C,TLOCI ;NOW CLOBBER THE ATOM\r
+ MOVEM C,(B) ;INTO TYPE CELL\r
+ ADD A,[2,,2] ;POINT TO VALUE\r
+ MOVEM A,1(B)\r
+ POPJ P,\r
+\r
+SPOVFL: MOVEI B,[ASCIZ /LOSSAGE--GLOBAL SP OVERFLOW\r
+/]\r
+ JRST TYPIT\r
+\r
+\r
+PVALM: HLRZ 0,(B)\r
+ CAIE 0,400000+TUNBOU\r
+ CAIN 0,TUNBOU\r
+ POPJ P,\r
+ MOVEI E,2\r
+ PUSH P,B\r
+ PUSHJ P,EBPUR\r
+ POP P,C\r
+ MOVEM B,1(C)\r
+ MOVSI 0,TLOCI\r
+ MOVEM 0,(C)\r
+ MOVE B,C\r
+ POPJ P,\r
+\f;SET UP LIST OF INTERNAL NAMES AND ADDRESS NEEDED BY COMPILER\r
+\r
+VECTGO DUMMY1\r
+\r
+IRP A,,[FINIS,SPECBIND,MESTBL,WNA,WRONGT,$TLOSE,CALER1\r
+ILOC,IGLOC,IDVAL,ILVAL,IGVAL,INTFLG,LCKINT,TYPLOO,TDEFER\r
+IFALSE,UNAS,UNBOU,RCALL,SEGMNT,SEGLST,NUMPRI,DISXTR,SSPEC1,COMPERR\r
+MAKACT,MAKENV,BFRAME,TTP,TTB,$TTP,$TTB,MAKTUP,TPALOC,IBIND,SSPECS\r
+CILVAL,CISET,CIGVAL,CSETG,IBLOK1,IBLOCK,CLLOC,CGLOC,CASSQ,CGASSQ\r
+CILNT,CILNQ,CILEGQ,CEMPTY,CIEQUA,CIREST,CINTH,CIAT,CSETLO,CIN\r
+CIPUT,CIGET,CIGETL,CIMON,CISTRU,CIMEMQ,CIMEMB,CITOP,CIBACK,TYPSEG\r
+CICONS,CIUVEC,CIVEC,IIFORM,IILIST,CISTNG,HITOP,INCR1,TYPG,VALG,TESTR\r
+OTBSAV,CITYPE,CFRAME,CARGS,CFUNCT,CUTYPE,CPTYPE,CTYPEP,CTYPEQ,CCHUTY\r
+CIREMA,RTFALS,CIGETP,CIGTPR,MPOPJ,TAB,$TAB,ICONS,CSTO,DSTO,NTPALO\r
+CPLUS,CTIMES,CTIME,CDIVID,CMINUS,CLQ,CLEQ,CGQ,CGEQ,CLOG,CSIN,CCOS,CATAN,CSQRT\r
+CFIX,CFLOAT,CEXP,CRAND,CINEQU,SPECBND,PGGIVE,PGFIND,MTYO,CMIN,CMAX,RCL,R1C,W1C\r
+CALLTY,CTYPEC,CTYPEW,NOTTY,CHKAB,CTMPLT,IUNWIN,UNWIN2,NOSHUF,ROOT,ERROBL,INTOBL\r
+CINSER,CIRMV,CLOOKU,CATOM,CIPNAM,ISTRCM,CITERP,CIPRIN,CIPRN1,CIPRNC\r
+CPATM,CP1ATM,CPCATM,CPSTR,CP1STR,CPCSTR,CPCH,CREADC,CNXTCH,CREDC1,CNXTC1\r
+CGBOUN,IIGLOC,MAKTU2,CIFLTZ,CIUPRS]\r
+ .GLOBAL A\r
+ ADDSQU A\r
+ MAKAT [A]TFIX,A,MUDDLE,0\r
+TERMIN\r
+\r
+VECRET\r
+\r
+; ROUTINE TO SORT AND PURIFY SQUOZE TABLE\r
+\r
+SQSETU: MOVE A,[SQUTBL-SQULOC+2,,SQUTBL]\r
+ MOVEI 0,1\r
+SQ2: MOVE B,(A)\r
+ CAMG B,2(A)\r
+ JRST SQ1\r
+ MOVEI 0,0\r
+ EXCH B,2(A)\r
+ MOVEM B,(A)\r
+ MOVE B,1(A)\r
+ EXCH B,3(A)\r
+ MOVEM B,1(A)\r
+SQ1: ADD A,[2,,2]\r
+ JUMPL A,SQ2\r
+ JUMPE 0,SQSETU\r
+ MOVEI E,SQULOC-SQUTBL\r
+ MOVEI B,SQUTBL\r
+ PUSHJ P,EBPUR ; TO THE PURE WORLD\r
+ HRLI B,SQUTBL-SQULOC\r
+ MOVEM B,SQUPNT"\r
+ POPJ P,\r
+ \r
+RHITOP: 0\r
+\r
+OBSZ: 151.\r
+ 151.\r
+ 151.\r
+ 151.\r
+ 317.\r
+\r
+OBTBL2: ROOT+1\r
+ ERROBL+1\r
+ INTOBL+1\r
+ MUDOBL+1\r
+ INITIAL+1\r
+\r
+OBTBL: INITIAL+1(TVP)\r
+ MUDOBL+1(TVP)\r
+ INTOBL+1(TVP)\r
+ ERROBL+1(TVP)\r
+ ROOT+1(TVP)\r
+OBNAM: MQUOTE INITIAL\r
+ MQUOTE MUDDLE\r
+ MQUOTE INTERRUPTS\r
+ MQUOTE ERRORS\r
+ MQUOTE ROOT\r
+\r
+END SETUP\r
+\r
+\r
+\f\f\f\r
+TITLE INTERRUPT HANDLER FOR MUDDLE\r
+\r
+RELOCATABLE\r
+\r
+;C. REEVE APRIL 1971\r
+\r
+.INSRT MUDDLE >\r
+\r
+SYSQ\r
+\r
+IF1,[\r
+IFE ITS,.INSRT MUDSYS;STENEX >\r
+]\r
+\r
+PDLGRO==10000 ;AMOUNT TO GROW A PDL THAT LOSES\r
+NINT==72. ;MAXIMUM NUMBER OF INTERRUPTS POSSIBLE\r
+\r
+IFN ITS,[\r
+;SET UP LOCATION 42 TO POINT TO TSINT\r
+\r
+RMT [\r
+\r
+ZZZ==$. ;SAVE CURRENT LOCATION\r
+\r
+LOC 42\r
+\r
+ JSR MTSINT ;GO TO HANDLER\r
+\r
+LOC ZZZ\r
+]\r
+]\r
+\r
+; GLOBALS NEEDED BY INTERRUPT HANDLER\r
+\r
+.GLOBAL ONINT ; FUDGE INS EXECUTED IF NON ZERO AT START OF INTERRUPT\r
+.GLOBA GCFLG ;TELLS WHETHER OR NOT GARBAGE COLLECTOR IS RUNNING\r
+.GLOBAL GCFLCH ; FLUSH CHARS IMMEDIATE SO GC CAN SEE THEM\r
+.GLOBAL CORTOP ; TOP OF CORE\r
+.GLOBA GCINT ;TELLS GARBAGE COLLECTOR TO SIMULATE AN INTERRUPT\r
+.GLOBAL INTNUM,INTVEC ;TV ENTRIES CONCERNING INTERRUPTS\r
+.GLOBAL AGC ;CALL THE GARBAGE COLLECTOR\r
+.GLOBAL VECNEW,PARNEW,GETNUM ;GC PSEUDO ARGS\r
+.GLOBAL GCPDL ;GARBAGE COLLECTORS PDL\r
+.GLOBAL VECTOP,VECBOT ;DELIMIT VECTOR SPACE\r
+.GLOBAL PURTOP\r
+.GLOBAL PDLBUF ;AMOUNT OF PDL GROWTH\r
+.GLOBAL PGROW ;POINTS TO DOPE WORD OF NEXT PDL TO GROW\r
+.GLOBAL TPGROW ;POINTS TO NEXT MUDDLE PDL TO GROW\r
+.GLOBAL TOPLEV,ERROR%,N.CHNS,CHNL1\r
+.GLOBAL BUFRIN,CHNL0,SYSCHR ;CHANNEL GLOBALS\r
+.GLOBAL IFALSE,TPOVFL,1STEPR,INTOBL,INCHAR,CURPRI,RDEVIC,RDIREC,GFALS,STATUS\r
+.GLOBAL PSTAT,NOTRES,IOIN2,INAME,INTFCN,CHNCNT,CHANNO,GIBLOK,ICONS,INCONS\r
+.GLOBAL IEVECT,INSRTX,ILOOKC,IPUT,IREMAS,IGET,CSTAK,EMERGE\r
+.GLOBAL MTSINT ;BEGINNING OF INTERRUPT HANDLER\r
+.GLOBAL INTINT ;CALLED BY INITIALIZER TO TAKE CARE OF INT PCS\r
+.GLOBAL FRMSTK,APPLY,CHUNW\r
+.GLOBAL IPCGOT,DIRQ ;HANDLE BRANCHING OFF TO IPC KLUDGERY\r
+\r
+; GLOBALS FOR GC\r
+.GLOBAL GCTIM,GCCAUS,GCCALL\r
+\r
+; GLOBALS FOR MONITOR ROUTINES\r
+\r
+.GLOBAL MONCH,MONCH0,RMONCH,RMONC0,LOCQ,SMON,BAPT,APLQ,MAKACT,NAPT\r
+.GLOBAL PURERR,BUFRIN,INSTAT\r
+\r
+MONITOR\r
+\r
+.GLOBAL MSGTYP,MTYI,UPLO,IFLUSH,OCLOS,ERRET,MASK1,MASK2 ;SUBROUTINES USED\r
+.GLOBAL ERROR,LISTEN,ECHO,RRESET,MTYO,GCHAPN,P.CORE,P.TOP,QUEUES,NOTTY,TTYOP2,TTICHN\r
+.GLOBAL INTHLD,BNDV,SPECBE\r
+;BEGINNING OF ACTUAL INTERRUPT HANDLER (MUST BE IMPURE)\r
+\r
+\r
+;***** TEMP FUDGE *******\r
+\r
+QUEUES==INTVEC\r
+\r
+\f\r
+; DECLARATIONS ASSOCIATED WITH INTERRUPT HANDERS AND HEADERS\r
+\r
+; SPECIAL TABLES\r
+\r
+SPECIN: IRP A,,[CHAR,CLOCK,MPV,ILOPR,WRITE,READ,IOC,PURE,SYSDOWN,INFERIOR,RUNT,REALT\r
+PARITY]\r
+ MQUOTE A,[A]INTRUP\r
+ TERMIN\r
+SPECLN==.-SPECIN\r
+\r
+; TABLE OF SPECIAL FINDING ROUTINES\r
+\r
+FNDTBL: IRP A,,[GETCHN,0,0,0,LOCGET,LOCGET,0,0,0,0,0,0,0]\r
+ A\r
+ TERMIN\r
+\r
+; TABLE OF SPECIAL SETUP ROUTINES\r
+\r
+INTBL: IRP A,,[S.CHAR,S.CLOK,S.MPV,S.ILOP,S.WMON,S.RMON,S.IOC,S.PURE,S.DOWN,S.INF\r
+S.RUNT,S.REAL,S.PAR]\r
+ A\r
+ S!A==.IRPCNT\r
+ TERMIN\r
+\r
+IFN ITS,[\r
+\r
+; EXTERNAL INTERRUPT TABLE\r
+\r
+EXTINT: REPEAT NINT-36.,0\r
+ REPEAT 16.,HCHAR\r
+ 0\r
+ 0\r
+ REPEAT 8.,HINF\r
+ REPEAT NINT-62.,0\r
+EXTEND:\r
+\r
+IRP A,,[[HCLOCK,13.],[HMPV,14.],[HILOPR,6],[HIOC,9],[HPURE,26.],[HDOWN,7],[HREAL,35.]\r
+[HRUNT,34.],[HPAR,28.]]\r
+ IRP B,C,[A]\r
+ LOC EXTINT+C\r
+ B\r
+ .ISTOP\r
+ TERMIN\r
+TERMIN\r
+\r
+\r
+LOC EXTEND\r
+]\r
+\f\r
+IFE ITS,[\r
+\r
+; TABLES FOR TENEX INTERRUPT SYSTEM\r
+\r
+LEVTAB: P1 ; POINTS TO INT PC HOLDERS FOR LEVS 1,2 AND 3\r
+ P2\r
+ P3\r
+\r
+CHNMSK==0 ; WILL BE MASK WORD FOR INT SET UP\r
+MFORK==400000\r
+NNETS==10. ; ALLOW 10 NETWRK INTERRUPTS\r
+NETCHN==36.-NNETS\r
+\r
+CHNTAB: ; LOCATION OF INT ROUTINES FOR VARIOUS "CHANNELS"\r
+ BLOCK 36.-NNETS ; THERE AR 36. TENEX INT CHANNELS\r
+\r
+REPEAT NNETS, 1,,INTNET+3*.RPCNT\r
+\r
+IRP A,,[[0,CNTLG],[1,CNTLS],[9.,TNXPDL]]\r
+ IRP B,C,[A]\r
+ LOC CHNTAB+B\r
+ 1,,C\r
+ CHNMSK==CHNMSK+<1_<35.-B>>\r
+ .ISTOP\r
+ TERMIN\r
+TERMIN\r
+LOC CHNTAB+36.\r
+\r
+EXTINT: BLOCK NINT-NNETS\r
+\r
+REPEAT NNETS,HNET\r
+\r
+IRP A,,[[HCNTLG,36.],[HCNTLS,37.]]\r
+ IRP B,C,[A]\r
+ LOC EXTINT+C\r
+ B\r
+ .ISTOP\r
+ TERMIN\r
+TERMIN\r
+LOC EXTINT+NINT\r
+]\r
+\r
+\r
+; HANDLER/HEADER PARAMETERS\r
+\r
+; HEADER BLOCKS\r
+\r
+IHDRLN==4 ; LENGTH OF HEADER BLOCK\r
+\r
+INAME==0 ; NAME OF INTERRUPT\r
+ISTATE==2 ; CURRENT STATE\r
+IHNDLR==4 ; POINTS TO LIST OF HANDLERS\r
+INTPRI==6 ; CONTAINS PRIORITY OF INTERRUPT\r
+\r
+IHANDL==4 ; LENGTH OF A HANDLER BLOCK\r
+\r
+INXT==0 ; POINTS TO NEXTIN CHAIN\r
+IPREV==2 ; POINTS TO PREV IN CHAIN\r
+INTFCN==4 ; FUNCTION ASSOCIATED WITH THIS HANDLER\r
+INTPRO==6 ; PROCESS TO RUN INT IN\r
+\r
+IFN ITS,[\r
+RMT [\r
+IMPURE\r
+TSINT:\r
+MTSINT: 0 ;INTERRUPT BITS GET STORED HERE\r
+TSINTR: 0 ;INTERRUPT PC WORD STORED HERE\r
+ JRST TSINTP ;GO TO PURE CODE\r
+\r
+; SOFTWARE INTERNAL INTERRUPTS JSR TO HERE\r
+\r
+LCKINT: 0\r
+ JRST DOINT\r
+\r
+PURE\r
+]\r
+]\r
+IFE ITS,[\r
+RMT [\r
+; JSR HERE FOR SOFTWARE INTERNAL INTERRUPTS\r
+\r
+LCKINT: 0\r
+ JRST DOINT\r
+]\r
+]\r
+\f\r
+\r
+IFN ITS,[\r
+\r
+;THE REST OF THIS CODE IS PURE\r
+\r
+TSINTP: SOSGE INTFLG ; SKIP IF ENABLED\r
+ SETOM INTFLG ;DONT GET LESS THAN -1\r
+\r
+ MOVEM A,TSAVA ;SAVE TWO ACS\r
+ MOVEM B,TSAVB\r
+ MOVE A,TSINT ;PICK UP INT BIT PATTERN\r
+ JUMPL A,2NDWORD ;DONT CHECK FOR PDL OVERFLOW ETC. IF SIGN BIT ON\r
+\r
+ TRZE A,200000 ;IS THIS A PDL OVERFLOW?\r
+ JRST IPDLOV ;YES, GO HANDLE IT FIRST\r
+\r
+IMPCH: MOVEI B,0\r
+ TRNE A,20000 ;IS IT A MEMORY PROTECTION VIOLATION?\r
+ MOVEI B,1 ; FLAG SAME\r
+\r
+ TRNE A,40 ;ILLEGAL OP CODE?\r
+ MOVEI B,2 ; ALSO FLAG\r
+ TRNN A,400 ; IOC?\r
+ JRST .+3\r
+ SOS TSINTR\r
+ MOVEI B,3\r
+ TLNE A,200 ; PURE?\r
+ MOVEI B,4\r
+ SOJGE B,DO.NOW ; CANT WAIT AROUND\r
+\r
+;DECODE THE REST OF THE INTERRUPTS USING A TABLE\r
+\r
+2NDWORD:\r
+ JUMPL A,GC2 ;2ND WORD?\r
+ IORM A,PIRQ ;NO, INTO WORD 1\r
+ JRST GCQUIT ;AND DISMISS INT\r
+\r
+GC2: TLZ A,400000 ;TURN OFF SIGN BIT\r
+ IORM A,PIRQ2\r
+ TRNE A,177777 ;CHECK FOR CHANNELS\r
+ JRST CHNACT ;GO IF CHANNEL ACTIVITY\r
+]\r
+GCQUIT: SKIPGE INTFLG ;SKIP IF INTERRUPTS ENABLED\r
+ JRST INTDON ;NO, DEFER REAL HANDLING UNTIL LATER\r
+\r
+ MOVE A,TSINTR ;PICKUP RETURN WORD\r
+IFE ITS,[\r
+ TLON A,10000 ; EXEC PC?\r
+ SUBI A,1 ; YES FIXUP PC\r
+]\r
+ MOVEM A,LCKINT ;STORE ELSEWHERE\r
+ MOVEI A,DOINTE ;CAUSE DISMISS TO HANDLER\r
+ HRRM A,TSINTR ;STORE IN INT RETURN\r
+ PUSH P,INTFLG ;SAVE INT FLAG\r
+ SETOM INTFLG ;AND DISABLE\r
+\r
+\r
+INTDON: MOVE A,TSAVA ;RESTORE ACS\r
+ MOVE B,TSAVB\r
+IFN ITS, .DISMISS TSINTR ;AND DISMISS THE INTERRUPT\r
+IFE ITS, DEBRK\r
+\r
+\r
+DO.NOW: SKIPE GCFLG\r
+ JRST DLOSER ; HANDLE FATAL GC ERRORS\r
+ MOVSI B,1\r
+ SKIPGE INTFLG ; IF NOT ENABLED\r
+ MOVEM B,INTFLG ; PRETEND IT IS\r
+ JRST 2NDWORD\r
+\r
+IFE ITS,[\r
+\r
+; HERE FOR TENEX PDL OVER FLOW INTERRUPT\r
+\r
+TNXPDL: SOSGE INTFLG\r
+ SETOM INTFLG\r
+ MOVEM A,TSAVA\r
+ MOVEM B,TSAVB\r
+ JRST IPDLOV ; GO TO COMMON HANDLER\r
+\r
+; HERE FOR TENEX ^G AND ^S INTERRUPTS\r
+\r
+CNTLG: MOVEM A,TSAVA\r
+ MOVEI A,1\r
+ JRST CNTSG\r
+\r
+CNTLS: MOVEM A,TSAVA\r
+ MOVEI A,2\r
+\r
+CNTSG: MOVEM B,TSAVB\r
+ IORM A,PIRQ2 ; SAY FOR MUDDLE LEVEL\r
+ SOSGE INTFLG\r
+ SETOM INTFLG\r
+ JRST GCQUIT\r
+INTNET:\r
+REPEAT NNETS,[\r
+ MOVEM A,TSAVA\r
+ MOVE A,[1_<.RPCNT+NETCHN>]\r
+ JRST CNTSG\r
+]\r
+]\r
+\f\r
+; HERE TO PROCESS INTERRUPTS\r
+\r
+DOINT: SKIPE INTHLD ; GLOBAL LOCK ON INTS\r
+ JRST @LCKINT\r
+ SETOM INTHLD ; DONT LET IT HAPPEN AGAIN\r
+ PUSH P,INTFLG\r
+DOINTE: SKIPE ONINT ; ANY FUDGE?\r
+ XCT ONINT ; YEAH, TRY ONE\r
+ EXCH 0,LCKINT ; RELATIVIZE PC IF FROM RSUBR\r
+ PUSH P,0 ; AND SAVE\r
+ ANDI 0,-1\r
+ CAMG 0,PURTOP\r
+ CAMGE 0,VECBOT\r
+ JRST DONREL\r
+ SUBI 0,(M) ; M IS BASE REG\r
+ HLL 0,(P) ; GET FLAGS\r
+ TLO 0,M ; INDEX IT OFF M\r
+ EXCH 0,(P) ; AND RESTORE TO STACK\r
+DONREL: EXCH 0,LCKINT ; GET BACK SAVED 0\r
+ SETZM INTFLG ;DISABLE\r
+ AOS -1(P) ;INCR SAVED FLAG\r
+\r
+;NOW SAVE WORKING ACS\r
+\r
+ PUSHJ P,SAVACS\r
+ HLRZ A,-1(P) ; HACK FUNNYNESS FOR MPV/ILOPR\r
+ SKIPE A\r
+ SETZM -1(P) ; REALLY DISABLED\r
+\r
+DIRQ: MOVE A,PIRQ ;NOW SATRT PROCESSING\r
+ JFFO A,FIRQ ;COUNT BITS AND GO\r
+ MOVE A,PIRQ2 ;1ST DONE, LOOK AT 2ND\r
+ JFFO A,FIRQ2\r
+\r
+INTDN1: SKIPN GCHAPN ; SKIP IF MUST DO GC INT\r
+ JRST .+3\r
+ SETZM GCHAPN\r
+ PUSHJ P,INTOGC ; AND INTERRUPT\r
+\r
+ PUSHJ P,RESTAC\r
+\r
+IFN ITS,[\r
+ .SUSET [.SPICLR,,[0]] ; DISABLE INTS\r
+]\r
+ POP P,LCKINT\r
+ POP P,INTFLG\r
+ SETZM INTHLD ; RE-ENABLE THE WORLD\r
+IFN ITS,[\r
+ EXCH 0,LCKINT\r
+ HRRI 0,@0 ; EFFECTIVIZE THE ADDRESS\r
+ TLZ 0,37 ; KILL IND AND INDEX\r
+ EXCH 0,LCKINT\r
+ .DISMIS LCKINT\r
+]\r
+IFE ITS, JRST @LCKINT\r
+FIRQ: PUSHJ P,GETBIT ;SET UP THE BIT TO CLOBBER IN PIRQ\r
+ ANDCAM A,PIRQ ;CLOBBER IT\r
+ ADDI B,36. ;OFSET INTO TABLE\r
+ JRST XIRQ ;GO EXECUTE\r
+\r
+FIRQ2: PUSHJ P,GETBIT ;PREPARE TO CLOBBER BIT\r
+ ANDCAM A,PIRQ2 ;CLOBBER IT\r
+ ADDI B,71. ;AGAIN OFFSET INTO TABLE\r
+XIRQ:\r
+ CAIE B,21 ;PDL OVERFLOW?\r
+ JRST FHAND ;YES, HACK APPROPRIATELY\r
+\r
+PDL2: SKIPN A,PGROW\r
+ SKIPE A,TPGROW\r
+ JRST .+2\r
+ JRST DIRQ ; NOTHING GROWING, FALSE ALARM\r
+ MOVEI B,PDLGRO_-6 ;GET GROWTH SPEC\r
+ DPB B,[111100,,-1(A)] ;STORE GROWTH SPEC\r
+REAGC: MOVE C,[10.,,1] ; INDICATOR FOR AGC\r
+ SKIPE PGROW ; P IS GROWING\r
+ ADDI C,6\r
+ SKIPE TPGROW ; TP IS GROWING\r
+ ADDI C,1\r
+ PUSHJ P,AGC ;COLLECT GARBAGE\r
+ SETZM PGROW\r
+ SETZM TPGROW\r
+ AOJL A,REAGC ; IF NO CORE, RETRY\r
+ JRST DIRQ\r
+\r
+SAVACS:\r
+IRP A,,[0,A,B,C,D,E]\r
+ PUSH TP,A!STO(PVP)\r
+ SETZM A!STO(PVP) ;NOW ZERO TYPE\r
+ PUSH TP,A\r
+ TERMIN\r
+ POPJ P,\r
+\r
+RESTAC:\r
+IRP A,,[E,D,C,B,A,0]\r
+ POP TP,A\r
+ POP TP,A!STO(PVP)\r
+ TERMIN\r
+ POPJ P,\r
+\r
+; HERE TO DO GC INTERRUPT AND CLOSE ANY DEAD CHANNELS\r
+\r
+INTOGC: PUSH P,[N.CHNS-1]\r
+ MOVE A,TVP\r
+ ADD A,[CHNL1,,CHNL1]\r
+ PUSH TP,$TVEC\r
+ PUSH TP,A\r
+\r
+INTGC1: MOVE A,(TP) ; GET POINTER\r
+ SKIPN B,1(A) ; ANY CHANNEL?\r
+ JRST INTGC2\r
+ HRRE 0,(A) ; INDICATOR\r
+ JUMPGE 0,INTGC2\r
+ PUSH TP,$TCHAN\r
+ PUSH TP,B\r
+ MCALL 1,FCLOSE\r
+\r
+ MOVE A,(TP)\r
+\r
+INTGC2: HLLZS (A)\r
+ ADD A,[2,,2]\r
+ MOVEM A,(TP)\r
+ SOSE (P)\r
+ JRST INTGC1\r
+\r
+ SUB P,[1,,1]\r
+ SUB TP,[2,,2]\r
+ PUSH TP,$TCHSTR\r
+ PUSH TP,CHQUOTE GC\r
+ PUSH TP,$TFLOAT ; PUSH ON TIME ARGUMENT\r
+ PUSH TP,GCTIM\r
+ PUSH TP,$TFIX ; PUSH ON THE CAUSE ARGUMENT\r
+ PUSH TP,GCCAUS\r
+ PUSH TP,$TATOM ; PUSH ON THE CALL ARGUMENT\r
+ MOVE A,GCCALL\r
+ PUSH TP,@GCALLR(A)\r
+ MCALL 4,INTERR\r
+ POPJ P,\r
+\r
+\r
+GCALLR: 0\r
+ MQUOTE BLOAT\r
+ MQUOTE GROW\r
+ MQUOTE LIST\r
+ MQUOTE VECTOR\r
+ MQUOTE SET\r
+ MQUOTE SETG\r
+ MQUOTE FREEZE\r
+ MQUOTE PURE-PAGE-LOADER\r
+ MQUOTE GC\r
+ MQUOTE INTERRUPT-HANDLER\r
+ MQUOTE NEWTYPE\r
+\r
+\f; OLD "ON" SETS UP EVENT AND HANDLER\r
+\r
+MFUNCTION ON,SUBR\r
+\r
+ ENTRY\r
+\r
+ HLRE 0,AB ; 0=> -2*NUM OF ARGS\r
+ ASH 0,-1 ; TO -NUM\r
+ CAME 0,[-5]\r
+ JRST .+3\r
+ MOVEI B,10(AB) ; LAST MUST BE CHAN OR LOC\r
+ PUSHJ P,CHNORL\r
+ ADDI 0,3\r
+ JUMPG 0,TFA ; AT LEAST 3\r
+ MOVEI A,0 ; SET UP IN CASE NO PROC\r
+ AOJG 0,ONPROC ; JUMP IF NONE\r
+ GETYP C,6(AB) ; CHECK IT\r
+ CAIE C,TPVP\r
+ JRST TRYFIX\r
+ MOVE A,7(AB) ; GET IT\r
+ONPROC: PUSH P,A ; SAVE AS A FLAG\r
+ GETYP A,(AB) ; CHECK PREV EXISTANCE\r
+ PUSH P,0\r
+ CAIN A,TATOM\r
+ JRST .+3\r
+ CAIE A,TCHSTR\r
+ JRST WTYP1\r
+ MOVEI B,(AB) ; FIND IT\r
+ PUSHJ P,FNDINT\r
+ POP P,0 ; REST NUM OF ARGS\r
+ JUMPN B,ON3 ; ALREADY THERE\r
+ SKIPE C ; SKIP IF NOTHING TO FLUSH\r
+ SUB TP,[2,,2]\r
+ PUSH TP,(AB) ; GET NAME\r
+ PUSH TP,1(AB)\r
+ PUSH TP,4(AB)\r
+ PUSH TP,5(AB)\r
+ MOVEI A,2 ; # OF ARGS TO EVENT\r
+ AOJG 0,ON1 ; JUMP IF NO LAST ARG\r
+ PUSH TP,10(AB)\r
+ PUSH TP,11(AB)\r
+ ADDI A,1\r
+ON1: ACALL A,EVENT\r
+\r
+ON3: PUSH TP,A\r
+ PUSH TP,B\r
+ PUSH TP,2(AB) ; NOW FCN\r
+ PUSH TP,3(AB)\r
+ MOVEI A,3 ; NUM OF ARGS\r
+ SKIPN (P)\r
+ SOJA A,ON2 ; NO PROC\r
+ PUSH TP,$TPVP\r
+ PUSH TP,7(AB)\r
+ON2: ACALL A,HANDLER\r
+ JRST FINIS\r
+\r
+\r
+TRYFIX: SKIPN A,7(AB)\r
+ CAIE C,TFIX\r
+ JRST WRONGT\r
+ JRST ONPROC\r
+\f\r
+; ROUTINE TO BUILD AN EVENT\r
+\r
+MFUNCTION EVENT,SUBR\r
+\r
+ ENTRY\r
+\r
+ HLRZ 0,AB\r
+ CAIN 0,-2 ; IF JUST 1\r
+ JRST RE.EVN ; COULD BE EVENT\r
+ CAIL 0,-3 ; MUST BE AT LEAST 2 ARGS\r
+ JRST TFA\r
+ GETYP A,2(AB) ; 2ND ARG MUST BE FIXED POINT PRIORITY\r
+ CAIE A,TFIX\r
+ JRST WTYP2\r
+ GETYP A,(AB) ; FIRST ARG SHOULD BE CHSTR\r
+ CAIN A,TATOM ; ALLOW ACTUAL ATOM\r
+ JRST .+3\r
+ CAIE A,TCHSTR\r
+ JRST WTYP1\r
+ CAIL 0,-5\r
+ JRST GOTRGS\r
+ CAIG 0,-7\r
+ JRST TMA\r
+ MOVEI B,4(AB)\r
+ PUSHJ P,CHNORL ; CHANNEL OR LOCATIVE (PUT ON STACK)\r
+\r
+GOTRGS: MOVEI B,(AB) ; NOW TRY TO FIND HEADER FOR THIS INTERRUPT\r
+ PUSHJ P,FNDINT ; CALL INTERNAL HACKER\r
+ JUMPN B,FINIS ; ALREADY ONE OF THIS NAME\r
+ PUSH P,C\r
+ JUMPE C,.+3 ; GET IT OFF STACK\r
+ POP TP,B\r
+ POP TP,A\r
+ PUSHJ P,MAKINT ; MAKE ONE FOR ME\r
+ MOVSI 0,TFIX\r
+ MOVEM 0,INTPRI(B) ; SET UP PRIORITY\r
+ MOVE 0,3(AB)\r
+ MOVEM 0,INTPRI+1(B)\r
+CH.SPC: POP P,C ; GET CODE BACK\r
+ SKIPGE C\r
+ PUSHJ P,DO.SPC ; DO ANY SPECIAL HACKS\r
+ JRST FINIS\r
+\r
+RE.EVN: GETYP 0,(AB)\r
+ CAIE 0,TINTH\r
+ JRST TFA ; ELSE SAY NOT ENOUGH\r
+ MOVE B,1(AB) ; GET IT\r
+ SETZM ISTATE+1(B) ; MAKE SURE ENABLED\r
+ SETZB D,C\r
+ GETYP A,INAME(B) ; CHECK FOR CHANNEL\r
+ CAIN A,TCHAN ; SKIP IF NOT\r
+ HRROI C,SS.CHA ; SET UP CHANNEL HACK\r
+ HRLZ E,INTPRI(B) ; GET POSSIBLE READ/WRITE BITS\r
+ TLNE E,.WRMON+.RDMON ; SKIP IF NOT MONITORS\r
+ PUSHJ P,GETNM1\r
+ JUMPL C,RE.EV1\r
+ MOVE B,INAME+1(B) ; CHECK FOR SPEC\r
+ PUSHJ P,SPEC1\r
+ MOVE B,1(AB) ; RESTORE IHEADER\r
+RE.EV1: PUSH TP,INAME(B)\r
+ PUSH TP,INAME+1(B)\r
+ PUSH P,C\r
+ MOVSI C,TATOM\r
+ PUSH TP,$TATOM\r
+ SKIPN D\r
+ MOVE D,MQUOTE INTERRUPT\r
+ PUSH TP,D\r
+ MOVE A,INAME(B)\r
+ MOVE B,INAME+1(B) ; GET IT\r
+ PUSHJ P,IGET ; LOOK FOR IT\r
+ JUMPN B,FINIS ; RETURN IT\r
+ MOVE A,(TB)\r
+ MOVE B,1(TB)\r
+ POP TP,D\r
+ POP TP,C\r
+ PUSH TP,(AB)\r
+ PUSH TP,1(AB)\r
+ PUSHJ P,IPUT ; REESTABLISH IT\r
+ MOVE A,(AB)\r
+ MOVE B,1(AB)\r
+ JRST CH.SPC\r
+\r
+\f\r
+; FUNCTION TO GENERATE A HANDLER FOR A GIVEN INTERRUPT\r
+\r
+MFUNCTION HANDLER,SUBR\r
+\r
+ ENTRY\r
+\r
+ HLRZ 0,AB\r
+ CAIL 0,-2 ; MUST BE 2 OR MORE ARGS\r
+ JRST TFA\r
+ GETYP A,(AB)\r
+ CAIE A,TINTH ; EVENT?\r
+ JRST WTYP1\r
+ GETYP A,2(AB)\r
+ CAIN 0,-4 ; IF EXACTLY 2\r
+ CAIE A,THAND ; COULD BE HANDLER\r
+ JRST CHEVNT\r
+\r
+ MOVE B,3(AB) ; GET IT\r
+ SKIPN IPREV+1(B) ; SKIP IF ALREADY IN USE\r
+ JRST HNDOK\r
+ MOVE D,1(AB) ; GET EVENT\r
+ SKIPN D,IHNDLR+1(D) ; GET FIRST HANDLER\r
+ JRST BADHND\r
+ CAMN D,B ; IS THIS IT?\r
+ JRST HFINIS ; YES, ALREADY "HANDLED"\r
+ MOVE D,INXT+1(D) ; GO TO NEXT HANDLER\r
+ JUMPN D,.-3\r
+BADHND: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE HANDLER-ALREADY-IN-USE\r
+ JRST CALER1\r
+\r
+CHEVNT: CAIG 0,-7 ; SKIP IF LESS THAN 4\r
+ JRST TMA\r
+ PUSH TP,$TPVP ; SLOT FOR PROCESS\r
+ PUSH TP,[0]\r
+ CAIE 0,-6 ; IF 3, LOOK FOR PROC\r
+ JRST NOPROC\r
+ GETYP 0,4(AB)\r
+ CAIE 0,TPVP\r
+ JRST WTYP3\r
+ MOVE 0,5(AB)\r
+ MOVEM 0,(TP)\r
+\r
+NOPROC: PUSHJ P,APLQ\r
+ JRST NAPT\r
+ PUSHJ P,MHAND ; MAKE THE HANDLER\r
+ MOVE 0,1(TB) ; GET PROCESS\r
+ MOVEM 0,INTPRO+1(B) ; AND PUT IT INTO HANDLER\r
+ MOVSI 0,TPVP ; SET UP TYPE\r
+ MOVEM 0,INTPRO(B)\r
+ MOVE 0,2(AB) ; SET UP FUNCTION\r
+ MOVEM 0,INTFCN(B)\r
+ MOVE 0,3(AB)\r
+ MOVEM 0,INTFCN+1(B)\r
+\r
+HNDOK: MOVE D,1(AB) ; PICK UP EVEENT\r
+ MOVE E,IHNDLR+1(D) ; GET POINTER TO HANDLERS\r
+ MOVEM B,IHNDLR+1(D) ; PUT NEW ONE IN\r
+ MOVSI 0,TINTH ; GET INT HDR TYPE\r
+ MOVEM 0,IPREV(B) ; INTO BACK POINTER\r
+ MOVEM D,IPREV+1(B) ; AND POINTER ITSELF\r
+ MOVEM E,INXT+1(B) ; NOW NEXT POINTER\r
+ MOVSI 0,THAND ; NOW HANDLER TYPE\r
+ MOVEM 0,IHNDLR(D) ; SET TYPE IN HEADER\r
+ MOVEM 0,INXT(B)\r
+ JUMPE E,HFINIS ; JUMP IF HEADER WAS EMPTY\r
+ MOVEM 0,IPREV(E) ; FIX UP ITS PREV\r
+ MOVEM B,IPREV+1(E)\r
+HFINIS: MOVSI A,THAND\r
+ JRST FINIS\r
+\r
+\f\r
+\r
+; FUNCTIONS TO SET TIME LIMITS FOR REALTIME AND RUNTIME INTS\r
+\r
+MFUNCTION RUNTIMER,SUBR\r
+\r
+ ENTRY 1\r
+\r
+ GETYP 0,(AB)\r
+ JFCL 10,.+1\r
+ MOVE A,1(AB)\r
+ CAIE 0,TFIX\r
+ JRST RUNT1\r
+ IMUL A,[245761.]\r
+ JRST RUNT2\r
+\r
+RUNT1: CAIE 0,TFLOAT\r
+ JRST WTYP1\r
+ FMPR A,[245760.62]\r
+ MULI A,400 ; FIX IT\r
+ TSC A,A\r
+ ASH B,(A)-243\r
+ MOVE A,B\r
+RUNT2: JUMPL A,OUTRNG ; NOT FOR NEG #\r
+ JFCL 10,OUTRNG\r
+ .SUSET [.SRTMR,,A]\r
+ MOVE A,(AB)\r
+ MOVE B,1(AB)\r
+ JRST FINIS\r
+\r
+MFUNCTION REALTIMER,SUBR\r
+\r
+ ENTRY 1\r
+\r
+ JFCL 10,.+1\r
+ GETYP 0,(AB)\r
+ MOVE A,1(AB)\r
+ CAIE 0,TFIX\r
+ JRST REALT1\r
+ IMULI A,60. ; TO 60THS OF SEC\r
+ JRST REALT2\r
+\r
+REALT1: CAIE 0,TFLOAT\r
+ JRST WTYP1\r
+ FMPRI A,(60.0)\r
+ MULI A,400\r
+ TSC A,A\r
+ ASH B,(A)-243\r
+ MOVE A,B\r
+\r
+REALT2: JUMPL A,OUTRNG\r
+ JFCL 10,OUTRNG\r
+ MOVE B,[200000,,A]\r
+ .REALT B,\r
+ JFCL\r
+ MOVE A,(AB)\r
+ MOVE B,1(AB)\r
+ JRST FINIS\r
+\r
+; FUNCTIONS TO ENABLE AND DISABLE INTERRUPTS\r
+\r
+MFUNCTION %ENABL,SUBR,ENABLE\r
+\r
+ PUSHJ P,GTEVNT\r
+ SETZM ISTATE+1(B)\r
+ JRST FINIS\r
+\r
+MFUNCTION %DISABL,SUBR,DISABLE\r
+\r
+\r
+ PUSHJ P,GTEVNT\r
+ SETOM ISTATE+1(B)\r
+ JRST FINIS\r
+\r
+GTEVNT: ENTRY 1\r
+ GETYP 0,(AB)\r
+ CAIE 0,TINTH\r
+ JRST WTYP1\r
+ MOVE A,(AB)\r
+ MOVE B,1(AB)\r
+ POPJ P,\r
+\r
+DO.SPC: HRRZ C,INTBL(C) ; POINT TO SPECIAL CODE\r
+ HLRZ 0,AB ; - TWO TIMES NUM ARGS\r
+ PUSHJ P,(C) ; CALL ROUTINE\r
+ JUMPE E,CPOPJ ; NO BITS TO ENABLE, LEAVE\r
+IFE ITS,[\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ MOVE B,1(TB) ; CHANNEL\r
+ MOVE 0,CHANNO(B)\r
+ MOVEM 0,(E) ; SAVE IN TABLE\r
+ MOVEI E,(E)\r
+ SUBI E,NETJFN-NETCHN\r
+ MOVE A,0 ; SETUP FOR MTOPR\r
+ MOVEI B,24\r
+ MOVSI C,(E)\r
+ TLO C,770000 ; DONT SETUP INR/INS\r
+ MTOPR\r
+ MOVEI 0,1\r
+ MOVNS E\r
+ LSH 0,35.(E)\r
+ IORM 0,MASK1\r
+ MOVE B,MASK1\r
+ MOVEI A,MFORK\r
+ AIC\r
+ \r
+ POP TP,B\r
+ POP TP,A\r
+ POPJ P, ; ***** TEMP ******\r
+]\r
+IFN ITS,[\r
+ CAILE E,35. ; SKIP IF 1ST WORD BIT\r
+ JRST SETW2\r
+ LSH 0,-1(E)\r
+\r
+ IORM 0,MASK1 ; STORE IN PROTOTYPE MASK\r
+ .SUSET [.SMASK,,MASK1]\r
+ POPJ P,\r
+\r
+SETW2: LSH 0,-36.(E)\r
+ IORM 0,MASK2 ; SET UP PROTO MASK2\r
+ .SUSET [.SMSK2,,MASK2]\r
+ POPJ P,\r
+]\r
+\r
+; ROUTINE TO CHECK FOR CHANNEL OR LOCATIVE\r
+\r
+CHNORL: GETYP A,(B) ; GET TYPE\r
+ CAIN A,TCHAN ; IF CHANNEL\r
+ JRST CHNWIN\r
+ PUSH P,0\r
+ PUSHJ P,LOCQ ; ELSE LOOCATIVE\r
+ JRST WRONGT\r
+ POP P,0\r
+CHNWIN: PUSH TP,(B)\r
+ PUSH TP,1(B)\r
+ POPJ P,\r
+\f\r
+; SUBROUTINE TO FIND A HANDLER OF A GIVEN NAME\r
+\r
+FNDINT: PUSHJ P,FNDNM\r
+ JUMPE B,CPOPJ\r
+ PUSHJ P,SPEC1 ; COULD BE FUNNY\r
+\r
+INTASO: PUSH P,C ; C<0 IF SPECIAL\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ MOVSI C,TATOM\r
+ SKIPN D ; COULD BE CHANGED FOR MONITOR\r
+ MOVE D,MQUOTE INTERRUPT\r
+ PUSH TP,C\r
+ PUSH TP,D\r
+ PUSHJ P,IGET\r
+ MOVE D,(TP)\r
+ SUB TP,[2,,2]\r
+ POP P,C ; AND RESTOR SPECIAL INDICATOR\r
+ SKIPE B ; IF FOUND\r
+ SUB TP,[2,,2] ; REMOVE CRUFT\r
+CPOPJ: POPJ P, ; AND RETURN\r
+\r
+; CHECK FOR SPECIAL INTERNAL INTERRUPT HACK\r
+\r
+SPEC1: MOVSI C,-SPECLN ; BUILD AOBJN PNTR\r
+SPCLOP: CAME B,@SPECIN(C) ; SKIP IF SPECIAL\r
+ AOBJN C,.-1 ; UNTIL EXHAUSTED\r
+ JUMPGE C,.+3\r
+ SKIPE E,FNDTBL(C)\r
+ JRST (E)\r
+ MOVEI 0,-1(TB) ; SEE IF OK\r
+ CAIE 0,(TP)\r
+ JRST TMA\r
+ POPJ P,\r
+\r
+; ROUTINE TO CREATE A NEW INTERRUPT (INTERNAL ONLY--NOT ITS FLAVOR)\r
+\r
+MAKINT: JUMPN C,GOTATM ; ALREADY HAVE NAME, GET THING\r
+ MOVEI B,(AB) ; POINT TO STRING\r
+ PUSHJ P,CSTAK ; CHARS TO STAKC\r
+ MOVE B,INTOBL+1(TVP)\r
+ PUSHJ P,INSRTX\r
+ MOVE D,MQUOTE INTERRUPT\r
+GOTATM: PUSH TP,$TINTH ; MAKE SLOT FOR HEADER BLOCK\r
+ PUSH TP,[0]\r
+ PUSH TP,A\r
+ PUSH TP,B ; SAVE ATOM\r
+ PUSH TP,$TATOM\r
+ PUSH TP,D\r
+ MOVEI A,IHDRLN*2\r
+ PUSHJ P,GIBLOK\r
+ MOVE A,-3(TP) ; GET NAME AND STORE SAME\r
+ MOVEM A,INAME(B)\r
+ MOVE A,-2(TP)\r
+ MOVEM A,INAME+1(B)\r
+ SETZM ISTATE+1(B)\r
+ MOVEM B,-4(TP) ; STASH HEADER\r
+ POP TP,D\r
+ POP TP,C\r
+ EXCH B,(TP)\r
+ MOVSI A,TINTH\r
+ EXCH A,-1(TP) ; INTERNAL PUT CALL\r
+ PUSHJ P,IPUT\r
+ POP TP,B\r
+ POP TP,A\r
+ POPJ P,\r
+\r
+; FIND NAME OF INTERRUPT\r
+\r
+FNDNM: GETYP A,(B) ; TYPE\r
+ CAIE A,TCHSTR ; IF STRING\r
+ JRST FNDATM ; DONT HAVE ATOM, OTHERWISE DO\r
+ PUSHJ P,IILOOK\r
+ JRST .+2\r
+FNDATM: MOVE B,1(B)\r
+ SETZB C,D ; PREVENT LOSSAGE LATER\r
+ MOVSI A,TATOM\r
+\r
+; THE NEXT 2 INSTRUCTIONS ARE A KLUDGE TO GET THE RIGHT ERROR ATOM\r
+\r
+ CAMN B,IMQUOTE ERROR\r
+ MOVE B,MQUOTE ERROR,ERROR,INTRUP\r
+ POPJ P,\r
+\r
+IILOOK: PUSHJ P,CSTAK ; PUT CHRS ON STACK\r
+ MOVE B,INTOBL+1(TVP)\r
+ JRST ILOOKC ; LOOK IT UP\r
+\f\r
+; ROUTINE TO MAKE A HANDLER BLOCK\r
+\r
+MHAND: MOVEI A,IHANDL*2\r
+ JRST GIBLOK ; GET BLOCK\r
+\r
+; HERE TO GET CHANNEL FOR "CHAR" INTERRUPT\r
+\r
+GETCHN: GETYP 0,(TB) ; GET TYPE\r
+ CAIE 0,TCHAN ; CHANNL IS WINNER\r
+ JRST WRONGT\r
+ MOVE A,(TB) ; USE THE CHANNEL TO NAME THE INTERRUPT\r
+ MOVE B,1(TB)\r
+ SKIPN CHANNO(B) ; SKIP IF WINNING CHANNEL\r
+ JRST CBDCHN ; LOSER\r
+ POPJ P,\r
+\r
+LOCGET: GETYP 0,(TB) ; TYPE\r
+ CAIN 0,TCHAN ; SKIP IF LOCATIVE\r
+ JRST WRONGT\r
+ MOVE D,B\r
+ MOVE A,(TB)\r
+ MOVE B,1(TB) ; GET LOCATIVE\r
+ POPJ P,\r
+\r
+; FINAL MONITOR SETUP ROUTINES\r
+\r
+S.RMON: SKIPA E,[.RDMON,,]\r
+S.WMON: MOVSI E,.WRMON\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ HLRM E,INTPRI(B) ; SAVE BITS\r
+ MOVEI B,(TB) ; POINT TO LOCATIVE\r
+ HRRZ A,FSAV(TB)\r
+ CAIN A,OFF\r
+ MOVSI D,(ANDCAM E,) ; KILL INST\r
+ CAIN A,EVENT\r
+ MOVSI D,(IORM E,)\r
+ PUSHJ P,SMON ; GO DO IT\r
+ POP TP,B\r
+ POP TP,A\r
+ MOVEI E,0\r
+ POPJ P,\r
+\f\r
+\r
+; SPECIAL SETUP ROUTINES FOR INITIAL INTERRUPTS\r
+\r
+IFN ITS,[\r
+S.CHAR: MOVE E,1(TB) ; GET CHANNEL\r
+ MOVE E,CHANNO(E)\r
+ ADDI E,36. ; GET CORRECT MASK BIT\r
+ONEBIT: MOVEI 0,1 ; BIT FOR INT TO RET\r
+ POPJ P,\r
+]\r
+IFE ITS,[\r
+S.CHAR: MOVE E,1(TB)\r
+ MOVE 0,RDEVIC(E)\r
+ ILDB 0,0 ; 1ST CHAR\r
+ PUSH P,A\r
+ CAIE 0,"N ; NET ?\r
+ JRST S.CHA1\r
+\r
+ MOVEI A,0\r
+ HRRZ 0,CHANNO(E)\r
+ MOVE E,[-NNETS,,NETJFN]\r
+ CAMN 0,(E)\r
+ JRST S.CHA2\r
+ SKIPN (E)\r
+ MOVE A,E ; REMEMBER WHERE\r
+ AOBJN E,.-5\r
+ TLNN A,-1 \r
+ FATAL NO MORE NETWORK\r
+ MOVE E,A\r
+S.CHA1: MOVEI E,0\r
+S.CHA2: POP P,A\r
+ POPJ P,\r
+]\r
+\r
+\r
+; SPECIAL FOR CLOCK\r
+\r
+S.DOWN: SKIPA E,[7]\r
+S.CLOK: MOVEI E,13. ; FOR NOW JUST GET BIT #\r
+ JRST ONEBIT\r
+\r
+S.PAR: MOVEI E,28.\r
+ JRST ONEBIT\r
+\r
+; RUNTIME AND REALTIME INTERRUPTS\r
+\r
+S.RUNT: SKIPA E,[34.]\r
+S.REAL: MOVEI E,35.\r
+ JRST ONEBIT\r
+\r
+S.IOC: SKIPA E,[9.] ; IO CHANNEL ERROR\r
+S.PURE: MOVEI E,26.\r
+ JRST ONEBIT\r
+\r
+; MPV AND ILOPR\r
+\r
+S.MPV: SKIPA E,[14.] ; BIT POS\r
+S.ILOP: MOVEI E,6\r
+ JRST ONEBIT\r
+\r
+; HERE TO TURN ALL INFERIOR INTS\r
+\r
+S.INF: MOVEI E,36.+16.+2 ; START OF BITS\r
+ MOVEI 0,37 ; 8 BITS WORTH\r
+ POPJ P,\r
+\f\r
+\r
+; HERE TO HANDLE ITS INTERRUPTS\r
+\r
+FHAND: SKIPN D,EXTINT(B) ; SKIP IF HANDLERS ARE POSSIBLE\r
+ JRST DIRQ\r
+ JRST (D)\r
+\r
+IFN ITS,[\r
+; SPECIAL CHARACTER HANDLERS\r
+\r
+HCHAR: MOVEI D,CHNL0+1(TVP)\r
+ ADDI D,(B) ; POINT TO CHANNEL SLOT\r
+ ADDI D,(B)\r
+ SKIPN D,-72.(D) ; PICK UP CHANNEL\r
+ JRST IPCGOT ;WELL, IT GOTTA BEE THE THE IPC THEN\r
+ PUSH TP,$TCHAN\r
+ PUSH TP,D\r
+ LDB 0,[600,,STATUS(D)] ; GET DEVICE CODE\r
+ CAILE 0,2 ; SKIP IF A TTY\r
+ JRST HNET ; MAYBE NETWORK CHANNEL\r
+ CAMN D,TTICHN+1(TVP)\r
+ SKIPN NOTTY\r
+ JRST HCHR11\r
+ MOVE B,D ; CHAN TO B\r
+ PUSHJ P,TTYOP2 ; RE-GOBBLE TTY\r
+ MOVE D,(TP)\r
+HCHR11: MOVE D,CHANNO(D) ; GET ITS CHANNEL\r
+ PUSH P,D ; AND SAVE IT\r
+ .CALL HOWMNY ; GET # OF CHARS\r
+ MOVEI B,0 ; IF TTY GONE, NO CHARS\r
+RECHR: ADDI B,1 ; BUMP BY ONE FOR SOSG\r
+ MOVEM B,CHNCNT(D) ; AND SAVE\r
+ IORM A,PIRQ2 ; LEAVE THE INT ON\r
+\r
+CHRLOO: MOVE D,(P) ; GET CHNNAEL NO.\r
+ SOSG CHNCNT(D) ; GET COUNT\r
+ JRST CHRDON\r
+\r
+ MOVE B,(TP)\r
+ MOVE D,BUFRIN(B) ; GET EXTRA BUFFER\r
+ XCT IOIN2(D) ; READ CHAR\r
+ PUSH TP,$TCHSTR\r
+ PUSH TP,CHQUOTE CHAR\r
+ PUSH TP,$TCHRS ; SAVE CHAR FOR CALL \r
+ PUSH TP,A\r
+ PUSH TP,$TCHAN ; SAVE CHANNEL\r
+ PUSH TP,B\r
+ PUSHJ P,INCHAR ; PUT CHAR IN USERS BUFFER\r
+ MCALL 3,INTERRUPT ; RUN THE HANDLERS\r
+ JRST CHRLOO ; AND LOOP\r
+\r
+CHRDON: .CALL HOWMNY\r
+ MOVEI B,0\r
+ MOVEI A,1 ; SET FOR PI WORD CLOBBER\r
+ LSH A,(D)\r
+ JUMPG B,RECHR ; ANY MORE?\r
+ ANDCAM A,PIRQ2\r
+ SUB P,[1,,1]\r
+ SUB TP,[2,,2]\r
+ JRST DIRQ\r
+\r
+\r
+\f\r
+; HERE FOR NET CHANNEL INTERRUPT\r
+\r
+HNET: CAIE 0,26 ; NETWORK?\r
+ JRST HSTYET ; HANDLE PSEUDO TTY ETC.\r
+ PUSH TP,$TATOM\r
+ PUSH TP,MQUOTE CHAR,CHAR,INTRUP\r
+ PUSH TP,$TUVEC\r
+ PUSH TP,BUFRIN(D)\r
+ PUSH TP,$TCHAN\r
+ PUSH TP,D\r
+ MOVE B,D ; CHAN TO B\r
+ PUSHJ P,INSTAT ; UPDATE THE NETWRK STATE\r
+ MCALL 3,INTERRUPT\r
+ SUB TP,[2,,2]\r
+ JRST DIRQ\r
+\r
+HSTYET: PUSH TP,$TATOM\r
+ PUSH TP,MQUOTE CHAR,CHAR,INTRUP\r
+ PUSH TP,$TCHAN\r
+ PUSH TP,D\r
+ MCALL 2,INTERRUPT\r
+ SUB TP,[2,,2]\r
+ JRST DIRQ\r
+\r
+]\r
+CBDCHN: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE BAD-CHANNEL\r
+ JRST CALER1\r
+\r
+IFN ITS,[\r
+\r
+HCLOCK: PUSH TP,$TCHSTR\r
+ PUSH TP,CHQUOTE CLOCK\r
+ MCALL 1,INTERRUPT\r
+ JRST DIRQ\r
+\r
+HRUNT: PUSH TP,$TATOM\r
+ PUSH TP,MQUOTE RUNT,RUNT,INTRUP\r
+ MCALL 1,INTERRUPT\r
+ JRST DIRQ\r
+\r
+HREAL: PUSH TP,$TATOM\r
+ PUSH TP,MQUOTE REALT,REALT,INTRUP\r
+ MCALL 1,INTERRUPT\r
+ JRST DIRQ\r
+\r
+HPAR: MOVE A,MQUOTE PARITY,PARITY,INTRUP\r
+ JRST HMPV1\r
+\r
+HMPV: MOVE A,MQUOTE MPV,MPV,INTRUP\r
+ JRST HMPV1\r
+\r
+HILOPR: MOVE A,MQUOTE ILOPR,ILOPR,INTRUP\r
+ JRST HMPV1\r
+\r
+HPURE: MOVE A,MQUOTE PURE,PURE,INTRUP\r
+HMPV1: PUSH TP,$TATOM\r
+ PUSH TP,A\r
+ PUSH P,LCKINT ; SAVE LOCN\r
+ PUSH TP,$TATOM\r
+ PUSH TP,A\r
+ PUSH TP,$TWORD\r
+ PUSH TP,LCKINT\r
+ MCALL 2,EMERGENCY\r
+ POP P,A\r
+ MOVE C,(TP)\r
+ SUB TP,[2,,2]\r
+ JUMPN B,DIRQ\r
+\r
+ PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE DANGEROUS-INTERRUPT-NOT-HANDLED\r
+ PUSH TP,$TATOM\r
+ PUSH TP,C\r
+ PUSH TP,$TWORD\r
+ PUSH TP,A\r
+ MCALL 3,ERROR\r
+ JRST DIRQ\r
+\r
+\f\r
+\r
+; HERE TO HANDLE SYS DOWN INTERRUPT\r
+\r
+HDOWN: PUSH TP,$TATOM\r
+ PUSH TP,MQUOTE SYSDOWN,SYSDOWN,INTRUP\r
+ .DIETI A, ; HOW LONG?\r
+ PUSH TP,$TFIX\r
+ PUSH TP,A\r
+ PUSH P,A ; FOR MESSAGE\r
+ MCALL 2,INTERRUPT\r
+ POP P,A\r
+ JUMPN B,DIRQ\r
+ .SUSET [.RTTY,,B] ; DO WE NOW HAVE A TTY AT ALL?\r
+ JUMPL B,DIRQ ; DONT HANG AROUND\r
+ PUSH P,A\r
+ MOVEI B,[ASCIZ /\r
+Excuse me, SYSTEM going down in /]\r
+ SKIPG (P) ; SKIP IF REALLY GOING DOWN\r
+ MOVEI B,[ASCIZ /\r
+Excuse me, SYSTEM has been REVIVED!\r
+/]\r
+ PUSHJ P,MSGTYP\r
+ POP P,B\r
+ JUMPE B,DIRQ\r
+ IDIVI B,30. ; TO SECONDS\r
+ IDIVI B,60. ; A/ SECONDS B/ MINUTES\r
+ JUMPE B,NOMIN\r
+ PUSH P,C\r
+ PUSHJ P,DECOUT\r
+ MOVEI B,[ASCIZ / minutes /]\r
+ PUSHJ P,MSGTYP\r
+ POP P,B\r
+ JRST .+2\r
+NOMIN: MOVEI B,(C)\r
+ PUSHJ P,DECOUT\r
+ MOVEI B,[ASCIZ / seconds.\r
+/]\r
+ PUSHJ P,MSGTYP\r
+ JRST DIRQ\r
+\r
+; TWO DIGIT DEC OUT FROM B/\r
+\r
+DECOUT: IDIVI B,10.\r
+ JUMPE B,DECOU1 ; NO TEN\r
+ MOVEI A,60(B)\r
+ PUSHJ P,MTYO\r
+DECOU1: MOVEI A,60(C)\r
+ JRST MTYO\r
+\f\r
+; HERE TO HANDLE I/O CHANNEL ERRORS\r
+\r
+HIOC: .SUSET [.RAPRC,,A] ; CONTAINS CHANNEL OF MOST RECENT LOSSAGE\r
+ LDB A,[330400,,A] ; GET CHAN #\r
+ MOVEI C,(A) ; COPY\r
+ PUSH TP,$TATOM ; PUSH ERROR\r
+ PUSH TP,EQUOTE FILE-SYSTEM-ERROR\r
+\r
+ PUSH TP,$TCHAN \r
+ ASH C,1 ; GET CHANNEL\r
+ ADDI C,CHNL0+1(TVP) ; GET CHANNEL VECTOR\r
+ PUSH TP,(C)\r
+ LSH A,23. ; DO A .STATUS\r
+ IOR A,[.STATUS A]\r
+ XCT A\r
+ PUSHJ P,GFALS ; GEN NAMED FALSE\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ PUSH TP,$TATOM\r
+ PUSH TP,MQUOTE IOC,IOC,INTRUP\r
+\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ PUSH TP,-7(TP)\r
+ PUSH TP,-7(TP)\r
+ MCALL 3,EMERGENCY\r
+ JUMPN B,DIRQ1 ; JUMP IF HANDLED\r
+ MCALL 3,ERROR\r
+ JRST DIRQ\r
+\r
+DIRQ1: SUB TP,[6,,6]\r
+ JRST DIRQ\r
+\r
+; HANDLE INFERIOR KNOCKING AT THE DOOR\r
+\r
+HINF: SUBI B,36.+16.+2 ; CONVERT TO INF #\r
+ PUSH TP,$TATOM\r
+ PUSH TP,MQUOTE INFERIOR,INFERIOR,INTRUP\r
+ PUSH TP,$TFIX\r
+ PUSH TP,B\r
+ MCALL 2,INTERRUPT\r
+ JRST DIRQ\r
+]\f\r
+IFE ITS,[\r
+\r
+; HERE FOR TENEX INTS (FIRST CUT)\r
+\r
+HCNTLG: MOVEI A,7\r
+ JRST HCNGS\r
+\r
+HCNTLS: MOVEI A,23\r
+\r
+HCNGS: PUSH TP,$TATOM\r
+ PUSH TP,MQUOTE CHAR,CHAR,INTRUP\r
+ PUSH TP,$TCHRS\r
+ PUSH TP,A\r
+ PUSH TP,$TCHAN\r
+ PUSH TP,TTICHN+1(TVP)\r
+ MCALL 3,INTERRUPT\r
+ JRST DIRQ\r
+\r
+HNET: MOVE A,NETJFN-NINT+NNETS(B)\r
+ JUMPE A,DIRQ\r
+ ASH A,1\r
+ ADDI A,CHNL0+1(TVP)\r
+ MOVE B,(A)\r
+ PUSH TP,$TATOM\r
+ PUSH TP,MQUOTE CHAR,CHAR,INTRUP\r
+ PUSH TP,$TUVEC\r
+ PUSH TP,BUFRIN(B)\r
+ PUSH TP,$TCHAN\r
+ PUSH TP,B\r
+ PUSHJ P,INSTAT\r
+ MCALL 3,INTERRUPT\r
+ JRST DIRQ\r
+]\r
+\r
+\f\r
+MFUNCTION OFF,SUBR\r
+ ENTRY\r
+\r
+ JUMPGE AB,TFA\r
+ HLRZ 0,AB\r
+ GETYP A,(AB) ; ARG TYPE\r
+ MOVE B,1(AB) ; AND VALUE\r
+ CAIN A,TINTH ; HEADER, GO HACK\r
+ JRST OFFHD ; QUEEN OF HEARTS\r
+ CAIN A,TATOM\r
+ JRST .+3\r
+ CAIE A,TCHSTR\r
+ JRST TRYHAN ; MAYBE INDIVIDUAL HANDLER\r
+ CAIN 0,-2 ; MORE THAN 1 ARG?\r
+ JRST OFFAC1 ; NO, GO ON\r
+ CAIG 0,-5 ; CANT BE MORE THAN 2\r
+ JRST TMA\r
+ MOVEI B,2(AB) ; POINT TO 2D\r
+ PUSHJ P,CHNORL\r
+OFFAC1: MOVEI B,(AB)\r
+ PUSHJ P,FNDINT\r
+ JUMPGE B,NOHAN1 ; NOT HANDLED\r
+\r
+OFFH1: PUSH P,C ; SAVE C FOR BIT CLOBBER\r
+ MOVSI C,TATOM\r
+ SKIPN D\r
+ MOVE D,MQUOTE INTERRUPT\r
+ MOVE A,INAME(B)\r
+ MOVE B,INAME+1(B)\r
+ PUSHJ P,IREMAS\r
+ SKIPE B ; IF NO ASSOC, DONT SMASH\r
+ SETOM ISTATE+1(B) ; DISABLE IN CASE QUEUED\r
+ POP P,C ; SPECIAL?\r
+ JUMPGE C,FINIS ; NO, DONE\r
+\r
+ HRRZ C,INTBL(C) ; POINT TO SPECIAL CODE\r
+ PUSHJ P,(C) ; GO TO SAME\r
+ JUMPE E,OFINIS ; DONE\r
+IFN ITS,[\r
+ CAILE E,35. ; SKIP IF 1ST WORD\r
+ JRST CLRW2 ; CLOBBER 2D WORD BIT\r
+ LSH 0,-1(E) ; POSITION BIT\r
+ ANDCAM 0,MASK1 ; KILL BIT\r
+ .SUSET [.SMASK,,MASK1]\r
+]\r
+IFE ITS,[\r
+ MOVE D,B\r
+ SETZM (E)\r
+ MOVEI E,(E)\r
+ SUBI E,NETJFN-NETCHN\r
+ MOVEI 0,1\r
+ MOVNS E\r
+ LSH 0,35.(E)\r
+ ANDCAM 0,MASK1\r
+ MOVEI A,MFORK\r
+ SETCM B,MASK1\r
+ DIC\r
+ ANDCAM 0,PIRQ ; JUST IN CASE\r
+ MOVE B,D\r
+]\r
+OFINIS: MOVSI A,TINTH\r
+ JRST FINIS\r
+\r
+IFN ITS,[\r
+CLRW2: LSH 0,-36.(E) ; POS BIT FOR 2D WORD\r
+ ANDCAM 0,MASK2\r
+ .SUSET [.SMSK2,,MASK2]\r
+ JRST OFINIS\r
+]\r
+\r
+TRYHAN: CAIE A,THAND ; HANDLER?\r
+ JRST WTYP1\r
+ CAIE 0,-2\r
+ JRST TMA\r
+ GETYP 0,IPREV(B) ; GET TYPE OF PREV\r
+ MOVE A,INXT+1(B)\r
+ MOVE C,IPREV+1(B)\r
+ MOVE D,IPREV(B)\r
+ CAIE 0,THAND\r
+ JRST DOHEAD ; PREV HUST BE HDR\r
+ MOVEM A,INXT+1(C)\r
+ JRST .+2\r
+DOHEAD: MOVEM A,IHNDLR+1(C) ; INTO HDR\r
+ JUMPE A,OFFINI\r
+ MOVEM D,IPREV(A)\r
+ MOVEM C,IPREV+1(A)\r
+OFFINI: SETZM IPREV+1(B)\r
+ SETZM INXT+1(B)\r
+ MOVSI A,THAND\r
+ JRST FINIS\r
+\r
+OFFHD: CAIE 0,-2\r
+ JRST TMA\r
+ PUSHJ P,GETNMS ; GET INFOR ABOUT INT\r
+ JUMPE C,OFFH1\r
+ PUSH TP,INAME(B)\r
+ PUSH TP,INAME+1(B)\r
+ JRST OFFH1\r
+\r
+GETNMS: GETYP A,INAME(B) ; CHECK FOR SPECIAL\r
+ SETZB C,D\r
+ CAIN A,TCHAN\r
+ HRROI C,SS.CHA\r
+ PUSHJ P,LOCQ ; LOCATIVE?\r
+ JRST CHGTNM\r
+\r
+ MOVEI B,INAME(B) ; POINT TO LOCATIVE\r
+ MOVSI D,(MOVE E,)\r
+ PUSHJ P,SMON ; GET MONITOR\r
+ MOVE B,1(AB)\r
+GETNM1: HRROI C,SS.WMO ; ASSUME WRITE\r
+ TLNN E,.WRMON\r
+ HRROI C,SS.RMO\r
+ MOVE D,MQUOTE WRITE,WRITE,INTRUP\r
+ TLNN E,.WRMON\r
+ MOVE D,MQUOTE READ,READ,INTRUP\r
+ POPJ P,\r
+\r
+CHGTNM: JUMPL C,CPOPJ\r
+ MOVE B,INAME+1(B)\r
+ PUSHJ P,SPEC1\r
+ MOVE B,1(AB) ; RESTORE IHEADER\r
+ POPJ P,\r
+\f\r
+; EMERGENCY, CANT DEFER ME!!\r
+\r
+MQUOTE INTERRUPT\r
+\r
+EMERGENCY:\r
+ PUSH P,.\r
+ JRST INTERR+1\r
+\r
+MFUNCTION INTERRUPT,SUBR\r
+\r
+ PUSH P,[0]\r
+\r
+ ENTRY\r
+\r
+ SETZM INTHLD ; RE-ENABLE THE WORLD\r
+ JUMPGE AB,TFA\r
+ MOVE B,1(AB) ; GET HANDLER/NAME\r
+ GETYP A,(AB) ; CAN BE HEADER OR NAME\r
+ CAIN A,TINTH ; SKIP IF NOT HEADER\r
+ JRST GTHEAD\r
+ CAIN A,TATOM\r
+ JRST .+3\r
+ CAIE A,TCHSTR ; SKIP IF CHAR STRING\r
+ JRST WTYP1\r
+ MOVEI B,(AB) ; LOOK UP NAME\r
+ PUSHJ P,FNDNM ; GET NAME\r
+ JUMPE B,IFALSE\r
+ MOVEI D,0\r
+ CAMN B,MQUOTE CHAR,CHAR,INTRUP\r
+ PUSHJ P,CHNGT1\r
+ CAME B,MQUOTE READ,READ,INTRUP\r
+ CAMN B,MQUOTE WRITE,WRITE,INTRUP\r
+ PUSHJ P,GTLOC1\r
+ PUSHJ P,INTASO\r
+ JUMPE B,IFALSE\r
+\r
+GTHEAD: SKIPE ISTATE+1(B) ; ENABLED?\r
+ JRST IFALSE ; IGNORE COMPLETELY\r
+ MOVE A,INTPRI+1(B) ; GET PRIORITY OF INTERRUPT\r
+ CAMLE A,CURPRI ; SEE IF MUST QUEU\r
+ JRST SETPRI ; MAY RUN NOW\r
+ SKIPE (P) ; SKIP IF DEFER OK\r
+ JRST DEFERR\r
+ MOVEM A,(P)\r
+ PUSH TP,$TINTH ; SAVE HEADER\r
+ PUSH TP,B\r
+ MOVEI A,1 ; SAVE OTHER ARGS\r
+PSHARG: ADD AB,[2,,2]\r
+ JUMPGE AB,QUEU1 ; GO MAKE QUEU ENTRY\r
+ PUSH TP,(AB)\r
+ PUSH TP,1(AB)\r
+ AOJA A,PSHARG\r
+QUEU1: PUSHJ P,IEVECT ; GET VECTOR\r
+ PUSH TP,$TVEC\r
+ PUSH TP,[0] ; WILL HOLD QUEUE HEADER\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+\r
+ POP P,A ; RESTORE PRIORITY\r
+\r
+ MOVE B,QUEUES+1(TVP) ; GET INTERRUPT QUEUES\r
+ MOVEI D,0\r
+ JUMPGE B,GQUEU ; MAKE A QUEUE HDR\r
+\r
+NXTQU: CAMN A,1(B) ; GOT PRIORITY?\r
+ JRST ADDQU ; YES, ADD TO THE QUEU\r
+ CAMG A,1(B) ; SKIP IF SPOT NOT FOUND\r
+ JRST GQUEU\r
+ MOVE D,B\r
+ MOVE B,3(B) ; GO TO NXT QUEUE\r
+ JUMPL B,NXTQU\r
+\r
+GQUEU: PUSH TP,$TVEC ; SAVE NEXT POINTER\r
+ PUSH TP,D\r
+ PUSH TP,$TFIX\r
+ PUSH TP,A ; SAVE PRIORITY\r
+ PUSH TP,$TVEC\r
+ PUSH TP,B\r
+ PUSH TP,$TLIST\r
+ PUSH TP,[0]\r
+ PUSH TP,$TLIST\r
+ PUSH TP,[0]\r
+ MOVEI A,4\r
+ PUSHJ P,IEVECT\r
+ MOVE D,(TP) ; NOW SPLICE\r
+ SUB TP,[2,,2]\r
+ JUMPN D,GQUEU1\r
+ MOVEM B,QUEUES+1(TVP)\r
+ JRST .+2\r
+GQUEU1: MOVEM B,3(D)\r
+\r
+ADDQU: MOVEM B,-2(TP) ; SAVE QUEU HDR\r
+ POP TP,D\r
+ POP TP,C\r
+ PUSHJ P,INCONS ; CONS IT\r
+ MOVE C,(TP) ;GET QUEUE HEADER\r
+ SKIPE D,7(C) ; IF END EXISTS\r
+ HRRM B,(D) ; SPLICE\r
+ MOVEM B,7(C)\r
+ SKIPN 5(C) ; SKIP IF START EXISTS\r
+ MOVEM B,5(C)\r
+\r
+IFINI: MOVSI A,TATOM\r
+ MOVE B,MQUOTE T\r
+ JRST FINIS\r
+\r
+SETPRI: EXCH A,CURPRI\r
+ MOVEM A,(P)\r
+\r
+ PUSH TP,$TAB ; PASS AB TO HANDLERS\r
+ PUSH TP,AB\r
+\r
+ PUSHJ P,RUNINT ; RUN THE HANDLERS\r
+ POP P,A ; UNQUEU ANY WAITERS\r
+ PUSHJ P,UNQUEU\r
+\r
+ JRST IFINI\r
+\r
+; HERE TO UNQUEUE WAITING INTERRUPTS\r
+\r
+UNQUEU: PUSH P,A ; SAVE NEW LEVEL\r
+\r
+UNQUE1: MOVE A,(P) ; TARGET LEVEL\r
+ CAMLE A,CURPRI ; CHECK RUG NOT PULLED OUT\r
+ JRST UNDONE\r
+ SKIPE B,QUEUES+1(TVP)\r
+ CAML A,1(B) ; RIGHT LEVEL?\r
+ JRST UNDONE ; FINISHED\r
+\r
+ SKIPN C,5(B) ; ON QUEUEU?\r
+ JRST UNXQ\r
+ HRRZ D,(C) ; CDR THE LIST\r
+ MOVEM D,5(B)\r
+ SKIPN D ; SKIP IF NOT LAST\r
+ SETZM 7(B) ; CLOBBER END POINTER\r
+ MOVE A,1(B) ; GET THIS PRIORITY LEVEL\r
+ MOVEM A,CURPRI ; MAKE IT THE CURRENT ONE\r
+ MOVE D,1(C) ; GET SAVED VECTOR OF INF\r
+\r
+ MOVE B,1(D) ; INT HEADER\r
+ PUSH TP,$TVEC\r
+ PUSH TP,D ; AND ARGS\r
+\r
+ PUSHJ P,RUNINT ; RUN THEM\r
+ JRST UNQUE1\r
+\r
+UNDONE: POP P,CURPRI ; SET CURRENT LEVEL\r
+ MOVE A,CURPRI\r
+ POPJ P,\r
+\r
+UNXQ: MOVE B,3(B) ; GO TO NEXT QUEUE\r
+ MOVEM B,QUEUES+1(TVP)\r
+ JRST UNQUE1\r
+\r
+\r
+\r
+; SUBR TO CHANGE INTERRUPT LEVEL\r
+\r
+MFUNCTION INTLEV,SUBR,[INT-LEVEL]\r
+ ENTRY\r
+ JUMPGE AB,RETLEV ; JUST RETURN CURRENT\r
+ GETYP A,(AB)\r
+ CAIE A,TFIX\r
+ JRST WTYP1 ; LEVEL IS FIXED\r
+ SKIPGE A,1(AB)\r
+ JRST OUTRNG"\r
+ CAMN A,CURPRI ; DIFFERENT?\r
+ JRST RETLEV ; NO RETURN\r
+ PUSH P,CURPRI\r
+ CAMG A,CURPRI ; SKIP IF NO UNQUEUE NEEDED\r
+ PUSHJ P,UNQUEU\r
+ MOVEM A,CURPRI ; SAVE\r
+ POP P,A\r
+ SKIPA B,A\r
+RETLEV: MOVE B,CURPRI\r
+ MOVSI A,TFIX\r
+ JRST FINIS\r
+\r
+RUNINT: PUSH TP,$THAND ; SAVE HANDLERS LIST\r
+ PUSH TP,IHNDLR+1(B)\r
+\r
+ SKIPN ISTATE+1(B) ; SKIP IF DISABLED\r
+ SKIPN B,(TP)\r
+ JRST SUBTP4\r
+NXHND: MOVEM B,(TP) ; SAVE CURRENT HDR\r
+ MOVE A,-2(TP) ; SAVE ARG POINTER\r
+ PUSHJ P,CHSWAP ; SEE IF MUST SWAP\r
+ PUSH TP,[0]\r
+ PUSH TP,[0]\r
+ MOVEI C,1 ; COUNT ARGS\r
+ PUSH TP,$TSP\r
+ PUSH TP,SP\r
+ MOVE D,PVP\r
+ ADD D,[1STEPR,,1STEPR]\r
+ PUSH TP,BNDV\r
+ PUSH TP,D\r
+ PUSH TP,$TPVP\r
+ PUSH TP,[0]\r
+ MOVE E,TP\r
+ PUSH TP,INTFCN(B)\r
+ PUSH TP,INTFCN+1(B)\r
+ ADD A,[2,,2]\r
+ JUMPGE A,DO.HND\r
+ PUSH TP,(A)\r
+ PUSH TP,1(A)\r
+ AOJA C,.-4\r
+DO.HND: PUSH P,C\r
+ PUSHJ P,SPECBE ; BIND 1 STEP FLAG\r
+ POP P,C\r
+ ACALL C,INTAPL\r
+ MOVE SP,-4(TP)\r
+ MOVE C,(TP) ; RESET 1 STEP\r
+ MOVEM C,1STEPR+1(PVP)\r
+ SUB TP,[6,,6]\r
+ PUSHJ P,CHUNSW\r
+ CAMN E,PVP\r
+ SUB TP,[4,,4] ; NO PROCESS CHANGE, POP JUNK\r
+ CAMN E,PVP\r
+ JRST .+4\r
+ MOVE D,TPSTO+1(E)\r
+ SUB D,[4,,4]\r
+ MOVEM D,TPSTO+1(E) ; FIXUP HIS STACK\r
+DO.H1: GETYP A,A ; CHECK FOR A DISMISS\r
+ CAIN A,TDISMI\r
+ JRST SUBTP4\r
+ MOVE B,(TP) ; TRY FOR NEXT HANDLER\r
+ SKIPE B,INXT+1(B)\r
+ JRST NXHND\r
+SUBTP4: SUB TP,[4,,4]\r
+ POPJ P,\r
+\r
+MFUNCTION INTAPL,SUBR,[RUNINT]\r
+ JRST APPLY\r
+\r
+\r
+NOHAND: JUMPE C,NOHAN1\r
+ PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE INTERNAL-INTERRUPT\r
+NOHAN1: PUSH TP,(AB)\r
+ PUSH TP,1(AB)\r
+ PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE NOT-HANDLED\r
+ SKIPE A,C\r
+ MOVEI A,1\r
+ ADDI A,2\r
+ JRST CALER\r
+\r
+DEFERR: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE ATTEMPT-TO-DEFER-UNDEFERABLE-INTERRUPT\r
+ PUSH TP,$TINTH\r
+ PUSH TP,B\r
+ PUSH TP,$TATOM\r
+ PUSH TP,MQUOTE INTERRUPT\r
+ MCALL 3,RERR ; FORCE REAL ERROR\r
+ JRST FINIS\r
+\r
+; FUNCTION TO DISMISS AN INTERRUPT TO AN ARBITRARY ACTIVATION\r
+\r
+MFUNCTION DISMISS,SUBR\r
+\r
+ HLRZ 0,AB\r
+ JUMPGE AB,TFA\r
+ CAIGE 0,-6\r
+ JRST TMA\r
+ MOVNI D,1\r
+ CAIE 0,-6\r
+ JRST DISMI3\r
+ GETYP 0,4(AB)\r
+ CAIE 0,TFIX\r
+ JRST WTYP\r
+ SKIPGE D,5(AB)\r
+ JRST OUTRNG\r
+\r
+DISMI3: MOVEI A,(TB)\r
+\r
+DISMI0: HRRZ B,FSAV(A)\r
+ HRRZ C,PCSAV(A)\r
+ CAIE B,INTAPL\r
+ JRST DISMI1\r
+\r
+ MOVE E,OTBSAV(A)\r
+ MOVEI 0,(A) ; SAVE FRAME\r
+ MOVEI A,DISMI2\r
+ HRRM A,PCSAV(E) ; GET IT BACK HERE\r
+ MOVE A,(AB)\r
+ MOVE B,1(AB)\r
+ MOVE C,TPSAV(E)\r
+ MOVEM A,-7(C)\r
+ MOVEM B,-6(C)\r
+ MOVEI C,0\r
+ CAMGE AB,[-3,,]\r
+ MOVEI C,2(AB)\r
+ MOVE B,0 ; DEST FRAME\r
+ JUMPL D,.+3\r
+ MOVE A,PSAV(E) ; NOW MUNG SAVED INT LEVEL\r
+ MOVEM D,-1(A) ; ZAP YOUR MUNGED\r
+ PUSHJ P,CHUNW ; CHECK ON UNWINDERS\r
+ JRST FINIS ; FALL DOWN\r
+\r
+DISMI1: MOVEI E,(A)\r
+ HRRZ A,OTBSAV(A)\r
+ JUMPN A,DISMI0\r
+\r
+ MOVE A,(AB)\r
+ MOVE B,1(AB)\r
+\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ SKIPGE A,D\r
+ JRST .+4\r
+ CAMG A,CURPRI\r
+ PUSHJ P,UNQUEU\r
+ MOVEM A,CURPRI\r
+ CAML AB,[-3,,]\r
+ JRST .+5\r
+ PUSH TP,2(AB)\r
+ PUSH TP,3(AB)\r
+ MCALL 2,ERRET\r
+ JRST FINIS\r
+\r
+ POP TP,B\r
+ POP TP,A\r
+ JRST FINIS\r
+\r
+DISMI2: MOVE C,(TP)\r
+ MOVEM C,1STEPR+1(PVP)\r
+ MOVE SP,-4(TP)\r
+ SUB TP,[6,,6]\r
+ PUSHJ P,CHUNSW ; UNDO ANY PROCESS HACKING\r
+ MOVE C,TP\r
+ CAME E,PVP ; SWAPED?\r
+ MOVE C,TPSTO+1(E)\r
+ MOVE D,-1(C)\r
+ MOVE 0,(C)\r
+ SUB TP,[4,,4]\r
+ SUB C,[4,,4] ; MAYBE FIXUP OTHER STACK\r
+ CAME E,PVP\r
+ MOVEM C,TPSTO+1(E)\r
+ PUSH TP,D\r
+ PUSH TP,0\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ MOVE A,-1(P) ; SAVED PRIORITY\r
+ CAMG A,CURPRI\r
+ PUSHJ P,UNQUEU\r
+ MOVEM A,CURPRI\r
+ SKIPN -1(TP)\r
+ JRST .+3\r
+ MCALL 2,ERRET\r
+ JRST FINIS\r
+\r
+ SUB TP,[4,,4]\r
+ MOVSI A,TDISMI\r
+ MOVE B,MQUOTE T\r
+ JRST DO.H1\r
+ \r
+CHNGT1: HLRE B,AB\r
+ SUBM AB,B\r
+ GETYP 0,-2(B)\r
+ CAIE 0,TCHAN\r
+ JRST WTYP3\r
+ MOVE B,-1(B)\r
+ MOVSI A,TCHAN\r
+ POPJ P,\r
+\r
+GTLOC1: GETYP A,2(AB)\r
+ PUSHJ P,LOCQ\r
+ JRST WTYP2\r
+ MOVE D,B ; RET ATOM FOR ASSOC\r
+ MOVE A,2(AB)\r
+ MOVE B,3(AB)\r
+ POPJ P,\r
+\f; MONITOR CHECKERS\r
+\r
+MONCH0: HLLZ 0,(B) ; POTENTIAL MONITORS\r
+MONCH: TLZ 0,TYPMSK ; KILL TYPE\r
+ IOR C,0 ; IN NEW TYPE\r
+ PUSH P,0\r
+ MOVEI 0,(B)\r
+ CAIL 0,HIBOT\r
+ JRST PURERR\r
+ POP P,0\r
+ TLNN 0,.WRMON ; SKIP IF WRITE MONIT\r
+ POPJ P,\r
+\r
+; MONITOR IS ON, INVOKE HANDLER\r
+\r
+ PUSH TP,A ; SAVE OBJ\r
+ PUSH TP,B\r
+ PUSH TP,C\r
+ PUSH TP,D ; SAVE DATUM\r
+ MOVSI C,TATOM ; PREPARE TO FIND IT\r
+ MOVE D,MQUOTE WRITE,WRITE,INTRUP\r
+ PUSHJ P,IGET\r
+ JUMPE B,MONCH1 ; NOT FOUND IGNORE FOR NOW\r
+ PUSH TP,A ; START SETTING UP CALL\r
+ PUSH TP,B\r
+ PUSH TP,-5(TP)\r
+ PUSH TP,-5(TP)\r
+ PUSH TP,-5(TP)\r
+ PUSH TP,-5(TP)\r
+ PUSHJ P,FRMSTK ; PUT FRAME ON STAKC\r
+ MCALL 4,EMERGE ; DO IT\r
+MONCH1: POP TP,D\r
+ POP TP,C\r
+ POP TP,B\r
+ POP TP,A\r
+ HLLZ 0,(B) ; UPDATE MONITORS\r
+ TLZ 0,TYPMSK\r
+ IOR C,0\r
+ POPJ P,\r
+\r
+; NOW FOR READ MONITORS\r
+\r
+RMONC0: HLLZ 0,(B)\r
+RMONCH: TLNN 0,.RDMON\r
+ POPJ P,\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ MOVSI C,TATOM\r
+ MOVE D,MQUOTE READ,READ,INTRUP\r
+ PUSHJ P,IGET\r
+ JUMPE B,RMONC1\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ PUSH TP,-3(TP)\r
+ PUSH TP,-3(TP)\r
+ PUSHJ P,FRMSTK ; PUT FRAME ON STACK\r
+ MCALL 3,EMERGE\r
+RMONC1: POP TP,B\r
+ POP TP,A\r
+ POPJ P,\r
+\r
+; PUT THE CURRENT FRAME ON THE STACK\r
+\r
+FRMSTK: PUSHJ P,MAKACT\r
+ HRLI A,TFRAME\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ POPJ P,\r
+\r
+; HERE TO COMPLAIN ABOUT ATTEMPTS TO MUNG PURE CODE\r
+\r
+PURERR: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE ATTEMPT-TO-MUNG-PURE-STRUCTURE\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ MOVEI A,2\r
+ JRST CALER\r
+\f\r
+; PROCESS SWAPPING CODE\r
+\r
+CHSWAP: MOVE E,PVP ; GET CURRENT\r
+ POP P,0\r
+ SKIPE D,INTPRO+1(B) ; SKIP IF NO PROCESS GIVEN\r
+ CAMN D,PVP ; SKIP IF DIFFERENT\r
+ JRST PSHPRO\r
+ \r
+ PUSHJ P,SWAPIT ; DO SWAP\r
+\r
+PSHPRO: PUSH TP,$TPVP\r
+ PUSH TP,E\r
+ JRST @0\r
+\r
+CHUNSW: MOVE E,PVP ; RET OLD PROC\r
+ MOVE D,-2(TP) ; GET SAVED PROC\r
+ CAMN D,PVP ; SWAPPED?\r
+ POPJ P,\r
+\r
+SWAPIT: PUSH P,0\r
+ MOVE 0,PSTAT+1(D) ; CHECK STATE\r
+ CAIE 0,RESMBL\r
+ JRST NOTRES\r
+ MOVEM 0,PSTAT+1(PVP)\r
+ MOVEI 0,RUNING\r
+ MOVEM 0,PSTAT+1(D) ; SAVE NEW STATE\r
+ POP P,0\r
+ POP P,C\r
+ JRST SWAP"\r
+\f\r
+\r
+;SUBROUTINE TO GET BIT FOR CLOBBERAGE\r
+\r
+GETBIT: MOVNS B ;NEGATE\r
+ MOVSI A,400000 ;GET THE BIT\r
+ LSH A,(B) ;SHIFT TO POSITION\r
+ POPJ P, ;AND RETURN\r
+\r
+;HERE TO HANDLE PDL OVERFLOW. ASK FOR A GC\r
+\r
+IPDLOV:\r
+IFN ITS,[\r
+ MOVEM A,TSINT ;SAVE INT WORD\r
+]\r
+\r
+ SKIPE GCFLG ;IS GC RUNNING?\r
+ JRST GCPLOV ;YES, COMPLAIN GROSSLY\r
+\r
+ MOVEI A,200000 ;GET BIT TO CLOBBER\r
+ IORM A,PIRQ ;LEAVE A MESSAGE FOR HIGHER LEVEL\r
+\r
+ EXCH P,GCPDL ;GET A WINNING PDL\r
+ HRRZ B,TSINTR ;GET POINTER TO LOSING INSTRUCTION\r
+ SKIPG GCPDL ; SKIP IF NOT P\r
+ LDB B,[270400,,-1(B)] ;GET AC FIELD\r
+ SKIPL GCPDL ; SKIP IF P\r
+ MOVEI B,P\r
+ MOVEI A,(B) ;COPY IT\r
+ LSH A,1 ;TIMES 2\r
+ ADDI A,0STO(PVP) ;POINT TO THIS ACS CURRENT TYPE\r
+ HLRZ A,(A) ;GET THAT TYPE INTO A\r
+ CAIN B,P ;IS IT P\r
+ MOVEI B,GCPDL ;POINT TO SAVED P\r
+\r
+ CAIN B,B ;OR IS IT B ITSELF\r
+ MOVEI B,TSAVB\r
+ CAIN B,A ;OR A\r
+ MOVEI B,TSAVA\r
+\r
+ CAIN B,C ;OR C\r
+ MOVEI B,1(P) ;C WILL BE ON THE STACK\r
+\r
+ PUSH P,C\r
+ PUSH P,A\r
+\r
+ MOVE A,(B) ;GET THE LOSING POINTER\r
+ MOVEI C,(A) ;AND ISOLATE RH\r
+\r
+ CAMG C,VECTOP ;CHECK IF IN GC SPACE\r
+ CAMG C,VECBOT\r
+ JRST NOGROW ;NO, COMPLAIN\r
+\r
+; FALL THROUGH\r
+\f\r
+\r
+ HLRZ C,A ;GET -LENGTH\r
+ SUBI A,-1(C) ;POINT TO A DOPE WORD\r
+ POP P,C ;RESTORE TYPE INTO C\r
+ PUSH P,D ; SAVE FOR GROWTH HACKER\r
+ MOVEI D,0\r
+ CAIN C,TPDL ; POIN TD TO APPROPRIATE DOPE WORD\r
+ MOVEI D,PGROW\r
+ CAIN C,TTP\r
+ MOVEI D,TPGROW\r
+ JUMPE D,BADPDL ; IF D STILL 0, THIS PDL IS WEIRD\r
+ MOVEI A,PDLBUF(A) ; POINT TO ALLEGED REAL DOPE WORD\r
+ SKIPN (D) ; SKIP IF PREVIOUSLY BLOWN\r
+ MOVEM A,(D) ; CLOBBER IN\r
+ CAME A,(D) ; MAKE SURE IT IS THE SAME\r
+ JRST PDLOSS\r
+ POP P,D ; RESTORE D\r
+\r
+\r
+PNTRHK: MOVE C,(B) ;RESTORE PDL POINTER\r
+ SUB C,[PDLBUF,,0] ;FUDGE THE POINTER\r
+ MOVEM C,(B) ;AND STORE IT\r
+\r
+ POP P,C ;RESTORE THE WORLD\r
+ EXCH P,GCPDL ;GET BACK ORIG PDL\r
+IFN ITS,[\r
+ MOVE A,TSINT ;RESTORE INT WORD\r
+\r
+ JRST IMPCH ;LOOK FOR MORE INTERRUPTS\r
+]\r
+IFE ITS, JRST GCQUIT\r
+\r
+TPOVFL: SETOM INTFLG ;SIMULATE PDL OVFL\r
+ PUSH P,A\r
+ MOVEI A,200000 ;TURN ON THE BIT\r
+ IORM A,PIRQ\r
+ SUB TP,[PDLBUF,,0] ;HACK STACK POINTER\r
+ HLRE A,TP ;FIND DOPEW\r
+ SUBM TP,A ;POINT TO DOPE WORD\r
+ MOVEI A,1(A) ; ZERO LH AND POINT TO DOPEWD\r
+ SKIPN TPGROW\r
+ HRRZM A,TPGROW\r
+ CAME A,TPGROW ; MAKE SURE WINNAGE\r
+ JRST PDLOSS\r
+ POP P,A\r
+ POPJ P,\r
+\r
+\r
+; GROW CORE IF PDL OVERFLOW DURING GC\r
+\r
+GCPLOV: MOVE A,P.TOP ; GET TOP OF IMPURE\r
+ ASH A,-10. ; TO BLOCKS\r
+ EXCH P,GCPDL ; NEED A PDL TO CALL P.CORE\r
+ ADDI A,1 ; GO TO NEXT BLOCK\r
+GRECOR: PUSHJ P,P.CORE ; GET CORE\r
+ JRST SLPCOR ; HANG GETTING THE CORE\r
+ EXCH P,GCPDL ; BPDLS BACK\r
+ ADD P,[-2000,,0]\r
+IFE ITS, JRST GCQUIT\r
+IFN ITS,[\r
+ MOVE A,TSINT\r
+ JRST IMPCH\r
+\r
+\r
+SLPCOR: MOVEI B,1\r
+ .SLEEP B,\r
+ JRST GRECOR\r
+\r
+]\r
+\f\r
+IFN ITS,[\r
+\r
+;HERE TO HANDLE LOW-LEVEL CHANNELS\r
+\r
+\r
+CHNACT: SKIPN GCFLG ;GET A WINNING PDL\r
+ EXCH P,GCPDL\r
+ ANDI A,177777 ;ISOLATE CHANNEL BITS\r
+ PUSH P,0 ;SAVE\r
+\r
+CHNA1: MOVEI B,0 ;BIT COUNTER\r
+ JFFO A,.+2 ;COUNT\r
+ JRST CHNA2\r
+ SUBI B,35. ;NOW HAVE CHANNEL\r
+ MOVMS B ;PLUS IT\r
+ MOVEI 0,1\r
+ LSH 0,(B)\r
+ ANDCM A,0\r
+ MOVEI 0,(B) ; COPY TO 0\r
+ LSH 0,23. ;POSITION FOR A .STATUS\r
+ IOR 0,[.STATUS 0]\r
+ XCT 0 ;DO IT\r
+ ANDI 0,77 ;ISOLATE DEVICE\r
+ CAILE 0,2\r
+ JRST CHNA1\r
+\r
+PMIN4: MOVE 0,B ; CHAN TO 0\r
+ .ITYIC 0, ; INTO 0\r
+ JRST .+2 ; DONE, GO ON\r
+ JRST PMIN4\r
+ SETZM GCFLCH ; LEAVE GC MODE\r
+ JRST CHNA1\r
+\r
+CHNA2: POP P,0\r
+ SKIPN GCFLG\r
+ EXCH P,GCPDL\r
+ JRST GCQUIT\r
+\r
+HOWMNY: SETZ\r
+ SIXBIT /LISTEN/\r
+ D\r
+ 402000,,B\r
+]\r
+\r
+MFUNCTION GASCII,SUBR,ASCII\r
+ ENTRY 1\r
+\r
+ GETYP A,(AB)\r
+ CAIE A,TCHRS\r
+ JRST TRYNUM\r
+\r
+ MOVE B,1(AB)\r
+ MOVSI A,TFIX\r
+ JRST FINIS\r
+\r
+TRYNUM: CAIE A,TFIX\r
+ JRST WTYP1\r
+ SKIPGE B,1(AB) ;GET NUMBER\r
+ JRST TOOBIG\r
+ CAILE B,177 ;CHECK RANGE\r
+ JRST TOOBIG\r
+ MOVSI A,TCHRS\r
+ JRST FINIS\r
+\r
+TOOBIG: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE ARGUMENT-OUT-OF-RANGE\r
+ JRST CALER1\r
+\r
+\f\r
+;HERE IF PDL OVERFLOW DURING GARBAGE COLLECTION\r
+\r
+BADPDL: FATAL NON PDL OVERFLOW\r
+\r
+NOGROW: FATAL PDL OVERFLOW ON NON EXPANDABLE PDL\r
+\r
+PDLOSS: FATAL PDL OVEFLOW BUFFER EXHAUSTED\r
+\r
+DLOSER: PUSH P,LOSRS(B)\r
+ MOVE A,TSAVA\r
+ MOVE B,TSAVB\r
+ POPJ P,\r
+\r
+LOSRS: IMPV\r
+ ILOPR\r
+ IOC\r
+ IPURE\r
+\r
+\r
+;MEMORY PROTECTION INTERRUPT\r
+\r
+IOC: FATAL IO CHANNEL ERROR IN GARBAGE COLLECTOR\r
+IMPV: FATAL MPV IN GARBAGE COLLECTOR\r
+\r
+IPURE: FATAL PURE WRITE IN GARBAGE COLLECTOR\r
+ILOPR: FATAL ILLEGAL OPEREATION IN GARBAGE COLLECTOR\r
+\r
+IFN ITS,[\r
+\r
+;SUBROUTINE TO BE CALLED AT INITIALIZE TIME TO SETUP INTS\r
+\r
+INTINT: SETZM CHNCNT\r
+ MOVE A,[CHNCNT,,CHNCNT+1]\r
+ BLT A,CHNCNT+16.\r
+ SETZM INTFLG\r
+ .SUSET [.SPICLR,,[-1]]\r
+ MOVE A,MASK1 ;SET MASKS\r
+ MOVE B,MASK2\r
+ .SETM2 A, ;SET BOTH MASKS\r
+ MOVSI A,TVEC\r
+ MOVEM A,QUEUES(TVP)\r
+ SETZM QUEUES+1(TVP) ;UNQUEUE ANY OLD INTERRUPTS\r
+ SETZM CURPRI\r
+ POPJ P,\r
+]\r
+IFE ITS,[\r
+\r
+; INITIALIZE TENEX INTERRUPT SYSTEM\r
+\r
+INTINT: CIS ; CLEAR THE INT WORLD\r
+ SETZM INTFLG ; IN CASE RESTART\r
+ MOVSI A,TVEC ; FIXUP QUEUES\r
+ MOVEM A,QUEUES(TVP)\r
+ SETZM QUEUES+1(TVP)\r
+ SETZM CURPRI ; AND PRIORITY LEVEL\r
+ MOVEI A,MFORK ; TURN ON MY INTERRUPTS\r
+ MOVE B,[LEVTAB,,CHNTAB] ; POINT TO TABLES\r
+ SIR ; TELL SYSTEM ABOUT THEM\r
+ MOVE B,MASK1 ; SET UP FOR INT BITS\r
+ AIC ; TURN THEM ON\r
+ MOVSI A,7 ; CNTL G AND CHANNEL 0\r
+ ATI ; ACTIVATE IT\r
+ MOVE A,[23,,1] ; CNTL S AND CHANNEL 1\r
+ ATI ; ACTIVATE IT\r
+ MOVEI A,MFORK ; DO THE ENABLE\r
+ EIR\r
+ POPJ P,\r
+]\r
+\f\r
+\r
+; CNTL-G HANDLER\r
+\r
+MFUNCTION QUITTER,SUBR\r
+\r
+ ENTRY 2\r
+ GETYP A,(AB)\r
+ CAIE A,TCHRS\r
+ JRST WTYP1\r
+ GETYP A,2(AB)\r
+ CAIE A,TCHAN\r
+ JRST WTYP2\r
+ MOVE B,1(AB)\r
+ MOVE A,(AB)\r
+ CAIN B,^S ; HANDLE CNTL-S\r
+ JRST RETLIS\r
+ CAIE B,7\r
+ JRST FINIS\r
+\r
+ PUSHJ P,CLEAN ; CLEAN UP I/O CHANNELS\r
+ PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE CONTROL-G?\r
+ MCALL 1,ERROR\r
+ JRST FINIS\r
+\r
+RETLIS: MOVEI D,(TB) ; FIND A LISTEN OR ERROR TO RET TO\r
+\r
+RETLI1: HRRZ A,OTBSAV(D)\r
+ HRRZ C,FSAV(A) ; CHECK FUNCTION\r
+ CAIE C,LISTEN\r
+ CAIN C,ERROR ; FOUND?\r
+ JRST FNDHIM ; YES, GO TO SAME\r
+ CAIN C,ERROR% ; FUNNY ERROR\r
+ JRST FNDHIM\r
+ CAIN C,TOPLEV ; NO ERROR/LISTEN\r
+ JRST FINIS\r
+ MOVEI D,(A)\r
+ JRST RETLI1\r
+\r
+FNDHIM: PUSH TP,$TTB\r
+ PUSH TP,D\r
+ PUSHJ P,CLEAN\r
+ MOVE B,(TP) ; NEW FRAME\r
+ SUB TP,[2,,2]\r
+ MOVEI C,0\r
+ PUSHJ P,CHUNW ; UNWIND?\r
+ MOVSI A,TATOM\r
+ MOVE B,MQUOTE T\r
+ JRST FINIS\r
+\r
+CLEAN: MOVE B,3(AB) ; GET IN CHAN\r
+ PUSHJ P,RRESET\r
+ MOVE B,3(AB) ; CHANNEL BAKC\r
+ MOVE C,BUFRIN(B)\r
+ SKIPN C,ECHO(C) ; GET ECHO\r
+ JRST CLUNQ\r
+IFN ITS,[\r
+ MOVEI A,2\r
+ CAMN C,[PUSHJ P,MTYO]\r
+ JRST TYONUM\r
+ LDB A,[270400,,C]\r
+TYONUM: LSH A,23.\r
+ IOR A,[.RESET]\r
+ XCT A\r
+]\r
+IFE ITS,[\r
+ MOVEI A,101 ; OUTPUT JFN\r
+ CFOBF\r
+]\r
+\r
+CLUNQ: SETZB A,CURPRI\r
+ JRST UNQUEU\r
+\r
+\f\r
+IMPURE\r
+ONINT: 0 ; INT FUDGER\r
+IFN ITS,[\r
+;RANDOM IMPURE CRUFT NEEDED\r
+CHNCNT: BLOCK 16. ; # OF CHARS IN EACH CHANNEL\r
+\r
+TSAVA: 0\r
+TSAVB: 0\r
+PIRQ: 0 ;HOLDS REQUEST BITS FOR 1ST WORD\r
+PIRQ2: 0 ;SAME FOR WORD 2\r
+PCOFF: 0\r
+MASK1: 1200,,220540 ;FIRST MASK\r
+MASK2: 0 ;SECOND THEREOF\r
+CURPRI: 0 ; CURRENT PRIORITY\r
+]\r
+IFE ITS,[\r
+NETJFN: BLOCK NNETS\r
+MASK1: CHNMSK\r
+TSINTR:\r
+P1: 0 ; PC INT LEVEL 1\r
+P2: 0 ; PC INT LEVEL 2\r
+P3: 0 ; PC INT LEVEL 3\r
+CURPRI: 0\r
+TSAVA: 0\r
+TSAVB: 0\r
+PIRQ: 0\r
+PIRQ2: 0\r
+]\r
+PURE\r
+\r
+END\r
+\fTITLE MAIN LOOP AND GLOBALLY REFERENCED SUBROUTINES\r
+\r
+RELOCA\r
+\r
+.GLOBAL PATCH,TBINIT,PIDSTO,PROCID,PTIME,GCPDL,PBASE,TYPTOP,RERR,FRMSTK,EMERGE\r
+.GLOBAL PAT,PDLBUF,INTINT,START,SWAP,ICR,SPBASE,TPBASE,TPBAS,SAT,CURPRI,CHFINI\r
+.GLOBAL TOPLEVEL,INTOBL,INITIA,ERROBL,MAINPR,RESFUN,STATUS,TYPVEC,ROOT,TTICHN,TTOCHN\r
+.GLOBAL TTYOPE,MOPEN,MCLOSE,MIOT,ILVAL,MESS,ERROR,CHFRM,IGVAL,TYPBOT,ASOVEC\r
+.GLOBAL PRINT,PRIN1,PRINC,MUDSTR,VECBOT,CSTACK,IFALSE,TYPLOO,RCALL,SWAPIN,CTMPLT\r
+.GLOBAL IDPROC,CHFSWP,ILOC,MAKACT,BNDV,SPECSTORE,BINDID,IGLOC,MTYO,MSGTYP,CAFRE1\r
+.GLOBAL EVATYP,EVTYPE,APLTYP,APTYPE,PRNTYP,PRTYPE,AGC,SGSNAM,NAPT,APLQ,STRTO6\r
+.GLOBAL 6TOCHS,TYPFND,STBL,CHNL0,N.CHNS,CLOSAL,%LOGOUT,%SSNAM,%RSNAM,%KILLM\r
+.GLOBAL MAKINF,%VALRET,COMPERR,IPUT,IGET,TMATCH,INITIZ,IPCINI,%UNAM,%JNAM,%RUNAM,%RJNAM\r
+.GLOBAL NOTTY,PATEND,CFRAME,CARGS,CFUNCT,CITYPE,CTYPEQ,CPTYPE,CTYPEP,CUTYPE,CCHUTY\r
+.GLOBAL RTFALS,PGINT,PURCLN,CTYPEC,CTYPEW,IDVAL1,CALLTY,MESSAG,INITFL,WHOAMI\r
+.GLOBAL %SLEEP,%HANG,%TOPLQ,ONINT,CHUNW,CURFCN,BUFRIN,TD.LNT,TD.GET,TD.PUT,MPOPJ\r
+.GLOBAL PURVEC,PLOAD,SSPECS,OUTRNG\r
+.GLOBAL TYPIC\r
+.INSRT MUDDLE >\r
+\r
+MONITS==1 ; SET TO 1 IF PC DEMON WANTED\r
+.VECT.==1 ; BIT TO INDICATE VECTORS FOR GCHACK\r
+\r
+;MAIN LOOP AND STARTUP\r
+\r
+START: MOVEI 0,0 ; SET NO HACKS\r
+ MOVEM 0,WHOAMI ; HACK FOR TS FOO linked to TS MUDDLE\r
+ MOVE PVP,MAINPR ; MAKE SURE WE START IN THE MAIN PROCESS\r
+ JUMPE 0,INITIZ ; MIGHT BE RESTART\r
+ MOVE P,PSTO+1(PVP) ; SET UP FOR BOOTSTRAP HACK\r
+ MOVE TP,TPSTO+1(PVP)\r
+INITIZ: SKIPN P ; IF NO CURRENT P\r
+ MOVE P,PSTO+1(PVP) ; PDL TO GET OFF THE GROUND\r
+ SKIPN TP ; SAME FOR TP\r
+ MOVE TP,TPSTO+1(PVP) ; GET A TP TO WORK WITH\r
+ MOVE TVP,TVPSTO+1(PVP) ; GET A TVP\r
+ SETZB R,M ; RESET RSUBR AC'S\r
+ PUSHJ P,%RUNAM\r
+ PUSHJ P,%RJNAM\r
+ PUSHJ P,TTYOPE ;OPEN THE TTY\r
+ MOVEI B,MUDSTR\r
+ SKIPE WHOAMI ; SKIP IF THIS IS MUDDLE\r
+ JRST .+3 ; ELSE NO MESSAGE\r
+ SKIPN NOTTY ; IF NO TTY, IGNORE\r
+ PUSHJ P,MSGTYP ;TYPE OUT TO USER\r
+\r
+ XCT MESSAG ;MAYBE PRINT A MESSAGE\r
+ PUSHJ P,INTINT ;INITIALIZE INTERRUPT HANDLER\r
+ XCT IPCINI\r
+ PUSHJ P,PURCLN ; CLEAN UP PURE SHARED AREA\r
+RESTART: ;RESTART A PROCESS\r
+STP: MOVEI C,0\r
+ MOVE B,TBINIT+1(PVP) ;POINT INTO STACK AT START\r
+ PUSHJ P,CHUNW ; LEAVE WHILE DOING UNWIND CHECK\r
+ MOVEI E,TOPLEV\r
+ MOVEI A,TFALSE ; IN CASE FALLS OFF PROCESS\r
+ MOVEI B,0\r
+ MOVEM E,-1(TB)\r
+ JRST CONTIN\r
+\r
+ MQUOTE TOPLEVEL\r
+TOPLEVEL:\r
+ MCALL 0,LISTEN\r
+ JRST TOPLEVEL\r
+\f\r
+\r
+MFUNCTION LISTEN,SUBR\r
+\r
+ ENTRY\r
+ PUSH P,[0] ;FLAG: DON'T PRINT ERROR MSG\r
+ JRST ER1\r
+\r
+; USER SUPPLIED ERROR HANDLER, TEMPORARY KLUDGE\r
+ IMQUOTE ERROR\r
+\r
+ERROR: MOVE B,IMQUOTE ERROR\r
+ PUSHJ P,IGVAL ; GET VALUE\r
+ GETYP C,A\r
+ CAIN C,TSUBR ; CHECK FOR NO CHANGE\r
+ CAIE B,RERR1 ; SKIP IF NOT CHANGED\r
+ JRST .+2\r
+ JRST RERR1 ; GO TO THE DEFAULT\r
+ PUSH TP,A ; SAVE VALUE\r
+ PUSH TP,B\r
+ MOVE C,AB ; SAVE AB\r
+ MOVEI D,1 ; AND COUNTER\r
+USER1: PUSH TP,(C) ; PUSH THEM\r
+ PUSH TP,1(C)\r
+ ADD C,[2,,2] ; BUMP\r
+ ADDI D,1\r
+ JUMPL C,USER1\r
+ ACALL D,APPLY ; EVAL USERS ERROR\r
+ JRST FINIS\r
+\r
+\r
+TPSUBR==TSUBR+400000\r
+\r
+MFUNCTION ERROR%,PSUBR,ERROR\r
+\r
+RMT [EXPUNGE TPSUBR\r
+]\r
+RERR1: ENTRY\r
+ PUSH TP,$TATOM\r
+ PUSH TP,MQUOTE ERROR,ERROR,INTRUP\r
+ PUSHJ P,FRMSTK ; PUT ERROR'S FRAME ON STACK\r
+ MOVEI D,2\r
+ MOVE C,AB\r
+RERR2: JUMPGE C,RERR22\r
+ PUSH TP,(C)\r
+ PUSH TP,1(C)\r
+ ADD C,[2,,2]\r
+ AOJA D,RERR2\r
+RERR22: ACALL D,EMERGENCY\r
+ JRST RERR\r
+\r
+IMQUOTE ERROR\r
+RERR: ENTRY\r
+ PUSH P,[-1] ;PRINT ERROR FLAG\r
+\r
+ER1: MOVE B,IMQUOTE INCHAN\r
+ PUSHJ P,ILVAL ; CHECK INPUT CHANNEL IS SOME KIND OF TTY\r
+ GETYP A,A\r
+ CAIE A,TCHAN ; SKIP IF IT IS A CHANNEL\r
+ JRST ER2 ; NO, MUST REBIND\r
+ CAMN B,TTICHN+1(TVP)\r
+ JRST NOTINC\r
+ER2: MOVE B,IMQUOTE INCHAN\r
+ MOVEI C,TTICHN(TVP) ; POINT TO VALU\r
+ PUSHJ P,PUSH6 ; PUSH THE BINDING\r
+ MOVE B,TTICHN+1(TVP) ; GET IN CHAN\r
+NOTINC: SKIPE NOTTY\r
+ JRST NOECHO\r
+ PUSH TP,$TCHAN\r
+ PUSH TP,B\r
+ PUSH TP,$TATOM\r
+ PUSH TP,MQUOTE T\r
+ MCALL 2,TTYECH ; ECHO INPUT\r
+NOECHO: MOVE B,IMQUOTE OUTCHAN\r
+ PUSHJ P,ILVAL ; GET THE VALUE\r
+ GETYP A,A\r
+ CAIE A,TCHAN ; SKIP IF OK CHANNEL\r
+ JRST ER3 ; NOT CHANNEL, MUST REBIND\r
+ CAMN B,TTOCHN+1(TVP)\r
+ JRST NOTOUT\r
+ER3: MOVE B,IMQUOTE OUTCHAN\r
+ MOVEI C,TTOCHN(TVP)\r
+ PUSHJ P,PUSH6 ; PUSH THE BINDINGS\r
+NOTOUT: MOVE B,IMQUOTE OBLIST\r
+ PUSHJ P,ILVAL ; GET THE VALUE OF OBLIST\r
+ PUSHJ P,OBCHK ; IS IT A WINNER ?\r
+ SKIPA A,$TATOM ; NO, SKIP AND CONTINUE\r
+ JRST NOTOBL ; YES, DO NOT DO REBINDING\r
+ MOVE B,IMQUOTE OBLIST\r
+ PUSHJ P,IGLOC\r
+ GETYP 0,A\r
+ CAIN 0,TUNBOU\r
+ JRST MAKOB ; NO GLOBAL OBLIST, MAKE ONE\r
+ MOVEI C,(B) ; COPY ADDRESS\r
+ MOVE A,(C) ; GET THE GVAL\r
+ MOVE B,(C)+1\r
+ PUSHJ P,OBCHK ; IS IT A WINNER ?\r
+ JRST MAKOB ; NO, GO MAKE A NEW ONE\r
+ MOVE B,IMQUOTE OBLIST\r
+ PUSHJ P,PUSH6\r
+\r
+NOTOBL: PUSH TP,[TATOM,,-1] ;FOR BINDING\r
+ PUSH TP,IMQUOTE LER,[LERR ]INTRUP\r
+ PUSHJ P,MAKACT\r
+ HRLI A,TFRAME ; CORRCT TYPE\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ PUSH TP,[0]\r
+ PUSH TP,[0]\r
+ MOVE A,PVP ; GET PROCESS\r
+ ADD A,[PROCID,,PROCID] ; POINT TO ID (ALSO LEVEL)\r
+ PUSH TP,BNDV\r
+ PUSH TP,A\r
+ MOVE A,PROCID(PVP)\r
+ ADDI A,1 ; BUMP ERROR LEVEL\r
+ PUSH TP,A\r
+ PUSH TP,PROCID+1(PVP)\r
+ PUSH P,A\r
+\r
+ MOVE B,IMQUOTE READ-TABLE\r
+ PUSHJ P,IGVAL\r
+ PUSH TP,[TATOM,,-1]\r
+ PUSH TP,IMQUOTE READ-TABLE\r
+ GETYP C,A ; TO GVAL OF READ-TABLE ON ERROR AND\r
+ CAIE C,TVEC ; TOP ERRET'S\r
+ JRST .+4\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ JRST .+3\r
+ PUSH TP,$TUNBOUND\r
+ PUSH TP,[-1]\r
+ PUSH TP,[0]\r
+ PUSH TP,[0]\r
+\r
+ PUSHJ P,SPECBIND ;BIND THE CRETANS\r
+ MOVE A,-1(P) ;RESTORE SWITHC\r
+ JUMPE A,NOERR ;IF 0, DONT PRINT ERROR MESS\r
+ PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE *ERROR*\r
+ MCALL 0,TERPRI\r
+ MCALL 1,PRINC ;PRINT THE MESSAGE\r
+NOERR: MOVE C,AB ;GET A COPY OF AB\r
+\r
+ERRLP: JUMPGE C,LEVPRT ;IF NONE, RE-ENTER READ-EVAL-PRINT LOOP\r
+ PUSH TP,$TAB\r
+ PUSH TP,C\r
+ MOVEI B,PRIN1\r
+ GETYP A,(C) ; GET ARGS TYPE\r
+ CAIE A,TATOM\r
+ JRST ERROK\r
+ MOVE A,1(C) ; GET ATOM\r
+ MOVE A,2(A)\r
+ CAIE A,ERROBL+1\r
+ CAMN A,ERROBL+1(TVP) ; DONT SKIP IF IN ERROR OBLIST\r
+ MOVEI B,PRINC ; DONT PRINT TRAILER\r
+ERROK: PUSH P,B ; SAVE ROUTINE POINTER\r
+ PUSH TP,(C)\r
+ PUSH TP,1(C)\r
+ MCALL 0,TERPRI ; CRLF\r
+ POP P,B ; GET ROUTINE BACK\r
+ .MCALL 1,(B)\r
+ POP TP,C\r
+ SUB TP,[1,,1]\r
+ ADD C,[2,,2] ;BUMP SAVED AB\r
+ JRST ERRLP ;AND CONTINUE\r
+\r
+\r
+LEVPRT: XCT INITFL ;LOAD MUDDLE INIT FILE IF FIRST TIME\r
+ MCALL 0,TERPRI\r
+ PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE [LISTENING-AT-LEVEL ]\r
+ MCALL 1,PRINC ;PRINT LEVEL\r
+ PUSH TP,$TFIX ;READY TO PRINT LEVEL\r
+ HRRZ A,(P) ;GET LEVEL\r
+ SUB P,[2,,2] ;AND POP STACK\r
+ PUSH TP,A\r
+ MCALL 1,PRIN1 ;PRINT WITHOUT SPACES ETC.\r
+ PUSH TP,$TATOM ;NOW PROCESS\r
+ PUSH TP,EQUOTE [ PROCESS ]\r
+ MCALL 1,PRINC ;DONT SLASHIFY SPACES\r
+ PUSH TP,PROCID(PVP) ;NOW ID\r
+ PUSH TP,PROCID+1(PVP)\r
+ MCALL 1,PRIN1\r
+ SKIPN C,CURPRI\r
+ JRST MAINLP\r
+ PUSH TP,$TFIX\r
+ PUSH TP,C\r
+ PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE [ INT-LEVEL ]\r
+ MCALL 1,PRINC\r
+ MCALL 1,PRIN1\r
+ JRST MAINLP ; FALL INTO MAIN LOOP\r
+ \r
+\f;ROUTINES FOR ERROR-LISTEN\r
+\r
+OBCHK: GETYP 0,A\r
+ CAIN 0,TOBLS\r
+ JRST CPOPJ1 ; WIN FOR SINGLE OBLIST\r
+ CAIE 0,TLIST ; IF LIST, MAKE SURE EACH IS AN OBLIST\r
+ JRST CPOPJ ; ELSE, LOSE\r
+\r
+ JUMPE B,CPOPJ ; NIL ,LOSE\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ PUSH P,[0] ;FLAG FOR DEFAULT CHECKING\r
+ MOVEI 0,1000 ; VERY BIG NUMBER FOR CIRCULARITY TEST\r
+\r
+OBCHK0: INTGO\r
+ SOJE 0,OBLOSE ; CIRCULARITY TEST\r
+ HRRZ B,(TP) ; GET LIST POINTER\r
+ GETYP A,(B)\r
+ CAIE A,TOBLS ; SKIP IF WINNER\r
+ JRST DEFCHK ; CHECK FOR SPECIAL ATOM DEFAULT\r
+ HRRZ B,(B)\r
+ MOVEM B,(TP)\r
+ JUMPN B,OBCHK0\r
+OBWIN: AOS (P)-1\r
+OBLOSE: SUB TP,[2,,2]\r
+ SUB P,[1,,1]\r
+ POPJ P,\r
+\r
+DEFCHK: SKIPN (P) ; BEEN HERE BEFORE ?\r
+ CAIE A,TATOM ; OR, NOT AN ATOM ?\r
+ JRST OBLOSE ; YES, LOSE\r
+ MOVE A,(B)+1\r
+ CAME A,MQUOTE DEFAULT\r
+ JRST OBLOSE ; LOSE\r
+ SETOM (P) ; SET FLAG\r
+ HRRZ B,(B) ; CHECK FOR END OF LIST\r
+ MOVEM B,(TP)\r
+ JUMPN B,OBCHK0 ; NOT THE END, CONTINUE LOOKING\r
+ JRST OBLOSE ; LOSE FOR DEFAULT AT THE END\r
+\r
+\r
+\r
+PUSH6: PUSH TP,[TATOM,,-1]\r
+ PUSH TP,B\r
+ PUSH TP,(C)\r
+ PUSH TP,1(C)\r
+ PUSH TP,[0]\r
+ PUSH TP,[0]\r
+ POPJ P,\r
+\r
+\r
+MAKOB: PUSH TP,INITIAL(TVP)\r
+ PUSH TP,INITIAL+1(TVP)\r
+ PUSH TP,ROOT(TVP)\r
+ PUSH TP,ROOT+1(TVP)\r
+ MCALL 2,LIST\r
+ PUSH TP,$TATOM\r
+ PUSH TP,IMQUOTE OBLIST\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ MCALL 2,SETG\r
+ PUSH TP,[TATOM,,-1]\r
+ PUSH TP,IMQUOTE OBLIST\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ PUSH TP,[0]\r
+ PUSH TP,[0]\r
+ JRST NOTOBL\r
+\f\r
+\r
+;THIS IS IT FOLKS...THE MAIN LOOP. READ, EVAL, PRINT\r
+\r
+MAINLP: MOVE A,$TATOM ;KLUDGE BY NDR LIKE ERROR TO LET LOOSER REDEFINE\r
+ MOVE B,MQUOTE REP\r
+ PUSHJ P,ILVAL ;GET ITS LVAL TO SEE IF REDEFINED\r
+ GETYP C,A\r
+ CAIE C,TUNBOUND\r
+ JRST REPCHK\r
+ MOVE A,$TATOM ;SEE IF IT HAS GVAL SINCE NO LVAL\r
+ MOVE B,MQUOTE REP\r
+ PUSHJ P,IGVAL\r
+ GETYP C,A\r
+ CAIN C,TUNBOUN\r
+ JRST IREPER\r
+REPCHK: CAIN C,TSUBR\r
+ CAIE B,REPER\r
+ JRST .+2\r
+ JRST IREPER\r
+REREPE: PUSH TP,A\r
+ PUSH TP,B\r
+ GETYP A,-1(TP)\r
+ PUSHJ P,APLQ\r
+ JRST ERRREP\r
+ MCALL 1,APPLY ;LOOSER HAS REDEFINED SO CALL HIS\r
+ JRST MAINLP\r
+IREPER: PUSH P,[0] ;INDICATE FALL THROUGH\r
+ JRST REPERF\r
+\r
+ERRREP: PUSH TP,[TATOM,,-1]\r
+ PUSH TP,MQUOTE REP\r
+ PUSH TP,$TSUBR\r
+ PUSH TP,[REPER]\r
+ PUSH TP,[0]\r
+ PUSH TP,[0]\r
+ PUSHJ P,SPECBIN\r
+ PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE NON-APPLICABLE-REP\r
+ PUSH TP,-11(TP)\r
+ PUSH TP,-11(TP)\r
+ MCALL 2,ERROR\r
+ SUB TP,[6,,6]\r
+ PUSHJ P,SSPECS\r
+ JRST REREPE\r
+\r
+\r
+MFUNCTION REPER,SUBR,REP\r
+REPER: ENTRY 0\r
+ PUSH P,[1] ;INDICATE DIRECT CALL\r
+REPERF: MCALL 0,TERPRI\r
+ MCALL 0,READ\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ MCALL 0,TERPRI\r
+ MCALL 1,EVAL\r
+ PUSH TP,$TATOM\r
+ PUSH TP,IMQUOTE LAST-OUT\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ MCALL 2,SET\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ MCALL 1,PRIN1\r
+ POP P,C ;FLAG FOR FALL THROUGH OR CALL\r
+ JUMPN C,FINIS ;IN CASE LOOSER CALLED REP\r
+ JRST MAINLP\r
+\r
+\f\r
+;FUNCTION TO RETRY A PREVIOUS FUNCTION CALL\r
+\r
+MFUNCTION RETRY,SUBR\r
+\r
+ ENTRY\r
+ JUMPGE AB,RETRY1 ; USE MOST RECENT\r
+ CAMGE AB,[-2,,0]\r
+ JRST TMA\r
+ GETYP A,(AB) ; CHECK TYPE\r
+ CAIE A,TFRAME\r
+ JRST WTYP1\r
+ MOVEI B,(AB) ; POINT TO ARG\r
+ JRST RETRY2\r
+RETRY1: MOVE B,IMQUOTE LER,[LERR ]INTRUP\r
+ PUSHJ P,ILOC ; LOCATIVE TO FRAME\r
+RETRY2: PUSHJ P,CHFSWP ; CHECK VALIDITY AND SWAP IF NECESSARY\r
+ HRRZ 0,OTBSAV(B) ; CHECK FOR TOP\r
+ JUMPE 0,RESTAR ; YES RE-ENTER TOP LEVEL\r
+ PUSH TP,$TTB\r
+ PUSH TP,B ; SAVE FRAME\r
+ MOVE B,OTBSAV(B) ; GET PRVIOUS FOR UNBIND HACK\r
+ MOVEI C,-1(TP)\r
+ PUSHJ P,CHUNW ; CHECK ANY UNWINDING\r
+ CAME SP,SPSAV(TB) ; UNBINDING NEEDED?\r
+ PUSHJ P,SPECSTORE\r
+ MOVE P,PSAV(TB) ; GET OTHER STUFF\r
+ MOVE AB,ABSAV(B)\r
+ HLRE A,AB ; COMPUTE # OF ARGS\r
+ MOVNI A,-FRAMLN(A) ; MAKE TP POINT PAST FRAME\r
+ HRLI A,(A)\r
+ MOVE C,TPSAV(TB) ; COMPUTE TP\r
+ ADD C,A\r
+ MOVE TP,C\r
+ MOVE TB,B ; FIX UP TB\r
+ HRRZ C,FSAV(TB) ; GET FUNCTION\r
+ CAMGE C,VECTOP ; CHECK FOR RSUBR\r
+ CAMG C,VECBOT\r
+ JRST (C) ; GO\r
+ GETYP 0,(C) ; RSUBR OR ENTRY?\r
+ CAIE 0,TATOM\r
+ CAIN 0,TRSUBR\r
+ JRST RETRNT\r
+ MOVS R,(C) ; SET UP R\r
+ HRRI R,(C)\r
+ MOVEI C,0\r
+ JRST RETRN3\r
+\r
+RETRNT: CAIE 0,TRSUBR\r
+ JRST RETRN1\r
+ MOVE R,1(C)\r
+RETRN4: HRRZ C,2(C) ; OFFSET\r
+RETRN3: SKIPL M,1(R)\r
+ JRST RETRN5\r
+RETRN7: ADDI C,(M)\r
+ JRST (C)\r
+\r
+RETRN5: MOVEI D,(M) ; TOTAL OFFSET\r
+ MOVSS M\r
+ ADD M,PURVEC+1(TVP)\r
+ SKIPL M,1(M)\r
+ JRST RETRN6\r
+ ADDI M,(D)\r
+ JRST RETRN7\r
+RETRN6: HLRZ A,1(R)\r
+ PUSH P,D\r
+ PUSH P,C\r
+ PUSHJ P,PLOAD\r
+ JRST RETRER ; LOSER\r
+ POP P,C\r
+ POP P,D\r
+ MOVE M,B\r
+ JRST RETRN7\r
+\r
+RETRN1: MOVE B,1(C)\r
+ PUSH TP,$TVEC\r
+ PUSH TP,C\r
+ PUSHJ P,IGVAL\r
+ GETYP 0,A\r
+ MOVE C,(TP)\r
+ SUB TP,[2,,2]\r
+ CAIE 0,TRSUBR\r
+ JRST RETRN2\r
+ MOVE R,B\r
+ JRST RETRN3\r
+\r
+RETRN2: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE CANT-RETRY-ENTRY-GONE\r
+ JRST CALER1\r
+\r
+RETRER: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE PURE-LOAD-FAILURE\r
+ JRST CALER1\r
+\r
+\f\r
+;FUNCTION TO DO ERROR RETURN\r
+\r
+MFUNCTION ERRET,SUBR\r
+\r
+ ENTRY\r
+ HLRE A,AB ; -2*# OF ARGS\r
+ JUMPGE A,STP ; RESTART PROCESS\r
+ ASH A,-1 ; -# OF ARGS\r
+ AOJE A,ERRET2 ; NO FRAME SUPPLIED\r
+ AOJL A,TMA\r
+ ADD AB,[2,,2]\r
+ PUSHJ P,OKFRT\r
+ JRST WTYP2\r
+ SUB AB,[2,,2]\r
+ PUSHJ P,CHPROC ; POINT TO FRAME SLOT\r
+ JRST ERRET3\r
+ERRET2: MOVE B,IMQUOTE LER,[LERR ]INTRUP\r
+ PUSHJ P,ILVAL ; GET ITS VALUE\r
+ERRET3: PUSH TP,A\r
+ PUSH TP,B\r
+ MOVEI B,-1(TP)\r
+ PUSHJ P,CHFSWP ; CHECK VALIDITY AND SWAP IF NECESSARY\r
+ HRRZ 0,OTBSAV(B) ; TOP LEVEL?\r
+ JUMPE 0,TOPLOS\r
+ PUSHJ P,CHUNW ; ANY UNWINDING\r
+ JRST CHFINIS\r
+\r
+\r
+; FUNCTION TO RETURN LAST ERROR FRAME OR PREVIOUS FRAME\r
+\r
+MFUNCTION FRAME,SUBR\r
+ ENTRY\r
+ SETZB A,B\r
+ JUMPGE AB,FRM1 ; DEFAULT CASE\r
+ CAMG AB,[-3,,0] ; SKIP IF OK ARGS\r
+ JRST TMA\r
+ PUSHJ P,OKFRT ; A FRAME OR SIMILAR THING?\r
+ JRST WTYP1\r
+\r
+FRM1: PUSHJ P,CFRAME ; GO TO INTERNAL\r
+ JRST FINIS\r
+\r
+CFRAME: JUMPN A,FRM2 ; ARG SUPPLIED?\r
+ MOVE B,IMQUOTE LER,[LERR ]INTRUP\r
+ PUSHJ P,ILVAL\r
+ JRST FRM3\r
+FRM2: PUSHJ P,CHPROC ; CHECK FOR PROCESS\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ MOVEI B,-1(TP) ; POINT TO SLOT\r
+ PUSHJ P,CHFRM ; CHECK IT\r
+ MOVE C,(TP) ; GET FRAME BACK\r
+ MOVE B,OTBSAV(C) ;GET PREVIOUS FRAME\r
+ SUB TP,[2,,2]\r
+ TRNN B,-1 ; SKIP IF OK\r
+ JRST TOPLOSE\r
+\r
+FRM3: JUMPN B,FRM4 ; JUMP IF WINNER\r
+ MOVE B,IMQUOTE THIS-PROCESS\r
+ PUSHJ P,ILVAL ; GET PROCESS OF INTEREST\r
+ GETYP A,A ; CHECK IT\r
+ CAIN A,TUNBOU\r
+ MOVE B,PVP ; USE CURRENT\r
+ MOVEI A,PVLNT*2+1(B) ; POINT TO DOPE WORDS\r
+ MOVE B,TBINIT+1(B) ; AND BASE FRAME\r
+FRM4: HLL B,OTBSAV(B) ;TIME\r
+ HRLI A,TFRAME\r
+ POPJ P,\r
+\r
+OKFRT: AOS (P) ;ASSUME WINNAGE\r
+ GETYP 0,(AB)\r
+ MOVE A,(AB)\r
+ MOVE B,1(AB)\r
+ CAIE 0,TFRAME\r
+ CAIN 0,TENV\r
+ POPJ P,\r
+ CAIE 0,TPVP\r
+ CAIN 0,TACT\r
+ POPJ P,\r
+ SOS (P)\r
+ POPJ P,\r
+\r
+CHPROC: GETYP 0,A ; TYPE\r
+ CAIE 0,TPVP\r
+ POPJ P, ; OK\r
+ MOVEI A,PVLNT*2+1(B)\r
+ CAMN B,PVP ; THIS PROCESS?\r
+ JRST CHPRO1\r
+ MOVE B,TBSTO+1(B)\r
+ JRST FRM4\r
+\r
+CHPRO1: MOVE B,OTBSAV(TB)\r
+ JRST FRM4\r
+\r
+; FUNCTION TO RETURN ARGS TUPLE FOR A FRAME\r
+\r
+MFUNCTION ARGS,SUBR\r
+ ENTRY 1\r
+ PUSHJ P,OKFRT ; CHECK FRAME TYPE\r
+ JRST WTYP1\r
+ PUSHJ P,CARGS\r
+ JRST FINIS\r
+\r
+CARGS: PUSHJ P,CHPROC\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ MOVEI B,-1(TP) ; POINT TO FRAME SLOT\r
+ PUSHJ P,CHFRM ; AND CHECK FOR VALIDITY\r
+ MOVE C,(TP) ; FRAME BACK\r
+ MOVSI A,TARGS\r
+CARGS1: GETYP 0,FSAV(C) ; IS THIS A FUNNY ONE\r
+ CAIE 0,TCBLK ; SKIP IF FUNNY\r
+ JRST .+3 ; NO NORMAL\r
+ MOVE C,OTBSAV(C) ; ASSOCIATE WITH PREVIOUS FRAME\r
+ JRST CARGS1\r
+ HLR A,OTBSAV(C) ; TIME IT AND\r
+ MOVE B,ABSAV(C) ; GET POINTER\r
+ SUB TP,[2,,2] ; FLUSH CRAP\r
+ POPJ P,\r
+\r
+; FUNCTION TO RETURN FUNCTION ASSOCIATED WITH A FRAME\r
+\r
+MFUNCTION FUNCT,SUBR ;RETURNS FUNCTION NAME OF\r
+ ENTRY 1 ; FRAME ARGUMENT\r
+ PUSHJ P,OKFRT ; CHECK TYPE\r
+ JRST WTYP1\r
+ PUSHJ P,CFUNCT\r
+ JRST FINIS\r
+\r
+CFUNCT: PUSHJ P,CHPROC\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ MOVEI B,-1(TP)\r
+ PUSHJ P,CHFRM ; CHECK IT\r
+ MOVE C,(TP) ; RESTORE FRAME\r
+ HRRZ A,FSAV(C) ;FUNCTION POINTER\r
+ CAMG A,VECTOP ;IS THIS AN RSUBR ?\r
+ CAMGE A,VECBOT\r
+ SKIPA B,@-1(A) ;NO, GET SUBR'S NAME POINTER\r
+ MOVE B,(A)+3 ;YES, GET RSUBR'S NAME ENTRY\r
+ MOVSI A,TATOM\r
+ SUB TP,[2,,2]\r
+ POPJ P,\r
+\r
+BADFRAME:\r
+ PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE FRAME-NO-LONGER-EXISTS\r
+ JRST CALER1\r
+\r
+\r
+TOPLOSE:\r
+ PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE TOP-LEVEL-FRAME\r
+ JRST CALER1\r
+\r
+\r
+\f\r
+\f\r
+; ROUTINE TO HANG INDEFINITELY WITH INTERRUPTS ENABLED\r
+\r
+MFUNCTION HANG,SUBR\r
+\r
+ ENTRY\r
+\r
+ JUMPGE AB,HANG1 ; NO PREDICATE\r
+ CAMGE AB,[-3,,]\r
+ JRST TMA\r
+REHANG: MOVE A,[PUSHJ P,CHKPRH]\r
+ MOVEM A,ONINT ; CHECK PREDICATE AFTER ANY INTERRUPT\r
+ PUSH TP,(AB)\r
+ PUSH TP,1(AB)\r
+HANG1: ENABLE ;LET OURSELVES BE INTERRUPTED OUT\r
+ PUSHJ P,%HANG\r
+ DISABLE ;PREVENT INTERRUPTS AT RANDOM TIMES\r
+ SETZM ONINT\r
+ MOVE A,$TATOM\r
+ MOVE B,MQUOTE T\r
+ JRST FINIS\r
+\r
+\r
+; ROUTINE TO SLEEP FOR POSITIVE NUMBER OF SECONDS WITH INTERRUPTS ENABLED\r
+; ARGUMENT SHOULD BE OF TYPE FIX OR FLOAT AND NON-NEGATIVE\r
+\r
+MFUNCTION SLEEP,SUBR\r
+\r
+ ENTRY\r
+\r
+ JUMPGE AB,TFA\r
+ CAML AB,[-3,,]\r
+ JRST SLEEP1\r
+ CAMGE AB,[-5,,]\r
+ JRST TMA\r
+ PUSH TP,2(AB)\r
+ PUSH TP,3(AB)\r
+SLEEP1: GETYP 0,(AB)\r
+ CAIE 0,TFIX\r
+ JRST .+5\r
+ MOVE B,1(AB)\r
+ JUMPL B,OUTRNG ;ARG SHOULDNT BE NEGATIVE\r
+ IMULI B,30. ;CONVERT TO # OF THIRTIETHS OF A SECOND\r
+ JRST SLEEPR ;GO SLEEP\r
+ CAIE 0,TFLOAT ;IF IT WASNT FIX MAKE SURE IT IS FLOAT\r
+ JRST WTYP1 ;WRONG TYPE ARG\r
+ MOVE B,1(AB)\r
+ FMPR B,[30.0] ;CONVERT TO FLOATING # OF THIRTIETHS OF A SECOND\r
+ MULI B,400 ;KLUDGE TO FIX IT\r
+ TSC B,B\r
+ ASH C,(B)-243\r
+ MOVE B,C ;MOVE THE FIXED NUMBER INTO B\r
+ JUMPL B,OUTRNG ;CHECK TO SEE THAT WE HAVE POSITIVE NUMBER\r
+SLEEPR: MOVE A,B\r
+RESLEE: MOVE B,[PUSHJ P,CHKPRS]\r
+ CAMGE AB,[-3,,]\r
+ MOVEM B,ONINT\r
+ ENABLE\r
+ PUSHJ P,%SLEEP\r
+ DISABLE\r
+ SETZM ONINT\r
+ MOVE A,$TATOM\r
+ MOVE B,MQUOTE T\r
+ JRST FINIS\r
+\r
+CHKPRH: PUSH P,B\r
+ MOVEI B,HANGP\r
+ JRST .+3\r
+\r
+CHKPRS: PUSH P,B\r
+ MOVEI B,SLEEPP\r
+ HRRM B,LCKINT\r
+ SETZM ONINT ; TURN OFF FEATURE FOR NOW\r
+ POP P,B\r
+ POPJ P,\r
+\r
+HANGP: SKIPA B,[REHANG]\r
+SLEEPP: MOVEI B,RESLEE\r
+ PUSH P,B\r
+ PUSH P,A\r
+ DISABLE\r
+ PUSH TP,(TB)\r
+ PUSH TP,1(TB)\r
+ MCALL 1,EVAL\r
+ GETYP 0,A\r
+ CAIE 0,TFALSE\r
+ JRST FINIS\r
+ POP P,A\r
+ POPJ P,\r
+\r
+MFUNCTION VALRET,SUBR\r
+; SUBR TO VALRET A STRING TO SUPERIOR ITS PROCESS\r
+\r
+ ENTRY 1\r
+ GETYP A,(AB) ; GET TYPE OF ARGUMENT\r
+ CAIE A,TCHSTR ; IS IT A CHR STRING?\r
+ JRST WTYP1 ; NO...ERROR WRONG TYPE\r
+ PUSHJ P,CSTACK ; COPY THE CHR STRING TO THE STACK\r
+ ; CSTACK IS IN ATOMHK\r
+ MOVEI B,0 ; ASCIZ TERMINATOR\r
+ EXCH B,(P) ; STORE AND RETRIEVE COUNT\r
+\r
+; CALCULATE THE BEGINNING ADDR OF THE STRING\r
+ MOVEI A,-1(P) ; GET ADDR OF TOP OF STACK\r
+ SUBI A,-1(B) ; GET STARTING ADDR\r
+ PUSHJ P,%VALRE ; PASS UP TO MONITOR\r
+ JRST IFALSE ; IF HE RETURNS, RETURN FALSE\r
+\r
+\r
+MFUNCTION LOGOUT,SUBR\r
+\r
+; SUBR TO DO A .LOGOUT (VALID ONLY AT TOP LEVEL)\r
+ ENTRY 0\r
+ PUSHJ P,%TOPLQ ; SKIP IF AT TOP LEVEL\r
+ JRST IFALSE\r
+ PUSHJ P,CLOSAL\r
+ PUSHJ P,%LOGOUT ; TRY TO FLUSH\r
+ JRST IFALSE ; COULDN'T DO IT...RETURN FALSE\r
+\r
+; FUNCTS TO GET UNAME AND JNAME\r
+\r
+MFUNCTION UNAME,SUBR\r
+\r
+ ENTRY 0\r
+\r
+ PUSHJ P,%RUNAM\r
+ JRST RSUJNM\r
+\r
+MFUNCTION JNAME,SUBR\r
+\r
+ ENTRY 0\r
+\r
+ PUSHJ P,%RJNAM\r
+ JRST RSUJNM\r
+\r
+; FUNCTION TO SET AND READ GLOBAL SNAME\r
+\r
+MFUNCTION SNAME,SUBR\r
+\r
+ ENTRY\r
+\r
+ JUMPGE AB,SNAME1\r
+ CAMG AB,[-3,,]\r
+ JRST TMA\r
+ GETYP A,(AB) ; ARG MUST BE STRING\r
+ CAIE A,TCHSTR\r
+ JRST WTYP1\r
+ PUSH TP,$TATOM\r
+ PUSH TP,IMQUOTE SNM\r
+ PUSH TP,(AB)\r
+ PUSH TP,1(AB)\r
+ MCALL 2,SETG\r
+ JRST FINIS\r
+\r
+SNAME1: MOVE B,IMQUOTE SNM\r
+ PUSHJ P,IDVAL1\r
+ GETYP 0,A\r
+ CAIN 0,TCHSTR\r
+ JRST FINIS\r
+ MOVE A,$TCHSTR\r
+ MOVE B,CHQUOTE\r
+ JRST FINIS\r
+\r
+RSUJNM: PUSHJ P,6TOCHS ; CONVERT IT\r
+ JRST FINIS\r
+\r
+\r
+SGSNAM: MOVE B,IMQUOTE SNM\r
+ PUSHJ P,IDVAL1\r
+ GETYP 0,A\r
+ CAIE 0,TCHSTR\r
+ JRST SGSN1\r
+\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ PUSHJ P,STRTO6\r
+ POP P,A\r
+ SUB TP,[2,,2]\r
+ JRST .+2\r
+\r
+SGSN1: MOVEI A,0\r
+ PUSHJ P,%SSNAM ; SET SNAME IN SYSTEM\r
+ POPJ P,\r
+\r
+\f\r
+\r
+;THIS SUBROUTINE ALLOCATES A NEW PROCESS TAKES NO ARGS AND\r
+;IS CALLED BY PUSHJ P,. RETURNS IN A AND B A NEW PROCESS.\r
+\r
+ICR: MOVEI A,PVLNT ;SETUP CALL TO VECTOR FOR PVP\r
+ PUSHJ P,IVECT ;GOBBLE A VECTOR\r
+ HRLI C,PVBASE ;SETUP A BLT POINTER\r
+ HRRI C,(B) ;GET INTO ADDRESS\r
+ BLT C,PVLNT*2-1(B) ;COPY A PROTOTYPE INTO NEW PVP\r
+ MOVSI C,400000+SPVP+.VECT. ;SET SPECIAL TYPE\r
+ MOVEM C,PVLNT*2(B) ;CLOBBER IT IN\r
+ PUSH TP,A ;SAVE THE RESULTS OF VECTOR\r
+ PUSH TP,B\r
+\r
+ PUSH TP,$TFIX ;GET A UNIFORM VECTOR\r
+ PUSH TP,[PLNT]\r
+ MCALL 1,UVECTOR\r
+ ADD B,[PDLBUF-2,,-1] ;FUDGE WITH BUFFER\r
+ MOVE C,(TP) ;REGOBBLE PROCESS POINTER\r
+ MOVEM B,PSTO+1(C) ;STORE IN ALL HOMES\r
+ MOVEM B,PBASE+1(C)\r
+\r
+\r
+ MOVEI A,TPLNT ;PREPARE TO CREATE A TEMPORARY PDL\r
+ PUSHJ P,IVECT ;GET THE TEMP PDL\r
+ ADD B,[PDLBUF,,0] ;PDL GROWTH HACK\r
+ MOVE C,(TP) ;RE-GOBBLE NEW PVP\r
+ SUB B,[1,,1] ;FIX FOR STACK\r
+ MOVEM B,TPBASE+1(C)\r
+\r
+;SETUP INITIAL BINDING\r
+\r
+ PUSH B,$TBIND\r
+ MOVEM B,SPBASE+1(C) ;SAVE AS BASE OF SP\r
+ MOVEM B,SPSTO+1(C) ;AND CURRENT THEREOF\r
+ MOVEM B,CURFCN+1(C) ; AND AS CURRENT FCN FOR SPEC/UNSPEC LOGIC\r
+ PUSH B,IMQUOTE THIS-PROCESS\r
+ PUSH B,$TPVP ;GIVE IT PROCESS AS VALUE\r
+ PUSH B,C\r
+ ADD B,[2,,2] ;FINISH FRAME\r
+ MOVEM B,TPSTO+1(C) ;MAKE THIS THE CURRENT STACK POINTER\r
+ MOVEM C,PVPSTO+1(C) ;SAVE THE NEW PVP ITSELF\r
+ MOVEM TVP,TVPSTO+1(C) ;AND THE GOOD OLD TRANSFER VECTOR\r
+ AOS A,IDPROC ;GOBBLE A UNIQUE PROCESS I.D.\r
+ MOVEM A,PROCID+1(C) ;SAVE THAT ALSO\r
+ AOS A,PTIME ; GET A UNIQUE BINDING ID\r
+ MOVEM A,BINDID+1(C)\r
+\r
+ MOVSI A,TPVP ;CLOBBER THE TYPE\r
+ MOVE B,(TP) ;AND POINTER TO PROCESS\r
+ SUB TP,[2,,2]\r
+ POPJ P,\r
+\r
+;MINI ROUTINE TO CALL VECTOR WITH COUNT IN A\r
+\r
+IVECT: PUSH TP,$TFIX\r
+ PUSH TP,A\r
+ MCALL 1,VECTOR ;GOBBLE THE VECTOR\r
+ POPJ P,\r
+\r
+\r
+;SUBROUTINE TO SWAP A PROCESS IN\r
+;CALLED WITH JSP A,SWAP AND NEW PVP IN B\r
+\r
+SWAP: ;FIRST STORE ALL THE ACS\r
+\r
+ IRP A,,[PVP,TVP,AB,TB,TP,SP,P,M,R]\r
+ MOVEM A,A!STO+1(PVP)\r
+ TERMIN\r
+\r
+ SETOM 1(TP) ; FENCE POST MAIN STACK\r
+ MOVEM TP,TPSAV(TB) ; CORRECT FRAME\r
+ SETZM PSAV(TB) ; CLEAN UP CURRENT FRAME\r
+ SETZM SPSAV(TB)\r
+ SETZM PCSAV(TB)\r
+\r
+ MOVE E,PVP ;RETURN OLD PROCESS IN E\r
+ MOVE PVP,D ;AND MAKE NEW ONE BE D\r
+\r
+SWAPIN:\r
+ ;NOW RESTORE NEW PROCESSES AC'S\r
+\r
+ IRP A,,[PVP,TVP,AB,TB,TP,SP,P,M,R]\r
+ MOVE A,A!STO+1(PVP)\r
+ TERMIN\r
+\r
+ JRST (C) ;AND RETURN\r
+\r
+\r
+\f\r
+\r
+;SUBRS ASSOCIATED WITH TYPES\r
+\r
+;INTERNAL FUNCTION TO GET STRAGE ALLOCATION TYPE\r
+;GETS THE TYPE CODE IN A AND RETURNS SAT IN A.\r
+\r
+SAT: LSH A,1 ;TIMES 2 TO REF VECTOR\r
+ HRLS A ;TO BOTH HALVES TO HACK AOBJN POINTER\r
+ ADD A,TYPVEC+1(TVP) ;ACCESS THE VECTOR\r
+ HRR A,(A) ;GET PROBABLE SAT\r
+ JUMPL A,.+2 ;DID WE REALLY HAVE A VALID TYPE\r
+ MOVEI A,0 ;NO RETURN 0\r
+ ANDI A,SATMSK\r
+ POPJ P, ;AND RETURN\r
+\r
+;TYPE (ITYPE) ARE FUNCTIONS TO RETURN THE ATOMIC NAME OF THE\r
+;TYPE OF A GOODIE. TYPE TAKES ITS ARGS ON AP AND RETURNS IN A AND B.\r
+;ITYPE TAKES ITS ARGS IN A AND B AND RETURNS IN SAME (B=0) FOR INVALID\r
+;TYPECODE.\r
+MFUNCTION TYPE,SUBR\r
+\r
+ ENTRY 1\r
+ GETYP A,(AB) ;TYPE INTO A\r
+TYPE1: PUSHJ P,ITYPE ;GO TO INTERNAL\r
+ JUMPN B,FINIS ;GOOD RETURN\r
+TYPERR: PUSH TP,$TATOM ;SETUP ERROR CALL\r
+ PUSH TP,EQUOTE TYPE-UNDEFINED\r
+ JRST CALER1" ;STANDARD ERROR HACKER\r
+\r
+CITYPE: GETYP A,A ; GET TYPE FOR COMPILER CALL\r
+ITYPE: LSH A,1 ;TIMES 2\r
+ HRLS A ;TO BOTH SIDES\r
+ ADD A,TYPVEC+1(TVP) ;GET ACTUAL LOCATION\r
+ JUMPGE A,TYPERR ;LOST, TYPE OUT OF BOUNDS\r
+ MOVE B,1(A) ;PICKUP TYPE\r
+ HLLZ A,(A)\r
+ POPJ P,\r
+\r
+; PREDICATE -- IS OBJECT OF TYPE SPECIFIED\r
+\r
+MFUNCTION %TYPEQ,SUBR,[TYPE?]\r
+\r
+ ENTRY\r
+\r
+ MOVE D,AB ; GET ARGS\r
+ ADD D,[2,,2]\r
+ JUMPGE D,TFA\r
+ MOVE A,(AB)\r
+ HLRE C,D\r
+ MOVMS C\r
+ ASH C,-1 ; FUDGE\r
+ PUSHJ P,ITYPQ ; GO INTERNAL\r
+ JFCL\r
+ JRST FINIS\r
+\r
+ITYPQ: GETYP A,A ; OBJECT\r
+ PUSHJ P,ITYPE\r
+TYPEQ0: SOJL C,CIFALS\r
+ GETYP 0,(D)\r
+ CAIE 0,TATOM ; Type name must be an atom\r
+ JRST WRONGT\r
+ CAMN B,1(D) ; Same as the OBJECT?\r
+ JRST CPOPJ1 ; Yes, return type name\r
+ ADD D,[2,,2]\r
+ JRST TYPEQ0 ; No, continue comparing\r
+\r
+CIFALS: MOVEI B,0\r
+ MOVSI A,TFALSE\r
+ POPJ P,\r
+\r
+CTYPEQ: SOJE A,CIFALS ; TREAT NO ARGS AS FALSE\r
+ MOVEI D,1(A) ; FIND BASE OF ARGS\r
+ ASH D,1\r
+ HRLI D,(D)\r
+ SUBM TP,D ; D POINTS TO BASE\r
+ MOVE E,D ; SAVE FOR TP RESTORE\r
+ ADD D,[3,,3] ; FUDGE\r
+ MOVEI C,(A) ; NUMBER OF TYPES\r
+ MOVE A,-2(D)\r
+ PUSHJ P,ITYPQ\r
+ JFCL ; IGNORE SKIP FOR NOW\r
+ MOVE TP,E ; SET TP BACK\r
+ JUMPL B,CPOPJ1 ; SKIP\r
+ POPJ P,\r
+\f\r
+; Entries to get type codes for types for fixing up RSUBRs and assembling\r
+\r
+MFUNCTION %TYPEC,SUBR,[TYPE-C]\r
+\r
+ ENTRY\r
+\r
+ JUMPGE AB,TFA\r
+ GETYP 0,(AB)\r
+ CAIE 0,TATOM\r
+ JRST WTYP1\r
+ MOVE B,1(AB)\r
+ CAMGE AB,[-3,,0] ; skip if only type name given\r
+ JRST GTPTYP\r
+ MOVE C,MQUOTE ANY\r
+\r
+TYPEC1: PUSHJ P,CTYPEC ; go to internal\r
+ JRST FINIS\r
+\r
+GTPTYP: CAMGE AB,[-5,,0]\r
+ JRST TMA\r
+ GETYP 0,2(AB)\r
+ CAIE 0,TATOM\r
+ JRST WTYP2\r
+ MOVE C,3(AB)\r
+ JRST TYPEC1\r
+\r
+CTYPEC: PUSH P,C ; save primtype checker\r
+ PUSHJ P,TYPLOO ; search type vector\r
+ POP P,B\r
+ CAMN B,MQUOTE ANY\r
+ JRST CTPEC1\r
+ PUSH P,D\r
+ HRRZ A,(A)\r
+ ANDI A,SATMSK\r
+ PUSH P,A\r
+ PUSHJ P,TYPLOO\r
+ HRRZ 0,(A)\r
+ ANDI 0,SATMSK\r
+ CAME 0,(P)\r
+ JRST TYPDIF\r
+ MOVE D,-1(P)\r
+ SUB P,[2,,2]\r
+CTPEC1: MOVEI B,(D)\r
+ MOVSI A,TTYPEC\r
+ POPJ P,\r
+\r
+MFUNCTION %TYPEW,SUBR,[TYPE-W]\r
+\r
+ ENTRY\r
+\r
+ JUMPGE AB,TFA\r
+ GETYP 0,(AB)\r
+ CAIE 0,TATOM\r
+ JRST WTYP1\r
+ MOVEI D,0\r
+ MOVE C,MQUOTE ANY\r
+ MOVE B,1(AB)\r
+ CAMGE AB,[-3,,0]\r
+ JRST CTYPW1\r
+\r
+CTYPW3: PUSHJ P,CTYPEW\r
+ JRST FINIS\r
+\r
+CTYPW1: GETYP 0,2(AB)\r
+ CAIE 0,TATOM\r
+ JRST WTYP2\r
+ CAMGE AB,[-5,,0] ; JUMP IF RH IS GIVEN\r
+ JRST CTYPW2\r
+ MOVE C,3(AB)\r
+ JRST CTYPW3\r
+\r
+CTYPW2: CAMGE AB,[-7,,0]\r
+ JRST TMA\r
+ GETYP 0,4(AB)\r
+ CAIE 0,TFIX\r
+ JRST WRONGT\r
+ MOVE D,5(AB)\r
+ JRST CTYPW3\r
+\r
+CTYPEW: PUSH P,D\r
+ PUSHJ P,CTYPEC ; GET CODE IN B\r
+ POP P,B\r
+ HRLI B,(D)\r
+ MOVSI A,TTYPEW\r
+ POPJ P,\r
+\f \r
+;PRIMTTYPE RETURNS THE TYPE ATOM OF A PRIMITIVE TYPE IN A CLASS\r
+\r
+STBL: REPEAT NUMSAT,MQUOTE INTERNAL-TYPE\r
+\r
+LOC STBL\r
+\r
+IRP A,,[[1WORD,WORD],[2WORD,LIST],[NWORD,UVECTOR],[2NWORD,VECTOR],[STORE,STORAGE]\r
+[ARGS,TUPLE],[FRAME,FRAME],[ATOM,ATOM],[LOCID,LOCD],[CHSTR,STRING]\r
+[PVP,PROCESS],[ASOC,ASOC],[LOCA,LOCA],[LOCS,LOCS],[LOCU,LOCU],[LOCV,LOCV]\r
+[LOCL,LOCL],[LOCN,LOCAS],[LOCT,LOCT]]\r
+IRP B,C,[A]\r
+LOC STBL+S!B\r
+MQUOTE C\r
+\r
+.ISTOP\r
+\r
+TERMIN\r
+TERMIN\r
+\r
+LOC STBL+NUMSAT+1\r
+\r
+\r
+MFUNCTION TYPEPRIM,SUBR\r
+\r
+ ENTRY 1\r
+ GETYP A,(AB)\r
+ CAIE A,TATOM\r
+ JRST NOTATOM\r
+ MOVE B,1(AB)\r
+ PUSHJ P,CTYPEP\r
+ JRST FINIS\r
+\r
+CTYPEP: PUSHJ P,TYPLOO ; CONVERT ATOM TO CODE\r
+ HRRZ A,(A) ; SAT TO A\r
+ ANDI A,SATMSK\r
+ JRST PTYP1\r
+\r
+MFUNCTION PRIMTYPE,SUBR\r
+\r
+ ENTRY 1\r
+\r
+ MOVE A,(AB) ;GET TYPE\r
+ PUSHJ P,CPTYPE\r
+ JRST FINIS\r
+\r
+CPTYPE: GETYP A,A\r
+ PUSHJ P,SAT ;GET SAT\r
+PTYP1: JUMPE A,TYPERR\r
+ MOVE B,MQUOTE TEMPLATE\r
+ CAIG A,NUMSAT ; IF BIG SAT, THEN TEMPLATE\r
+ MOVE B,@STBL(A)\r
+ MOVSI A,TATOM\r
+ POPJ P,\r
+\f\r
+\r
+; RSUBR MAKES A VECTOR INTO AN OBJECT OF TYPE RSUBR, ALSO SLIGHTLY MUNGING IT\r
+\r
+MFUNCTION RSUBR,SUBR\r
+ ENTRY 1\r
+\r
+ GETYP A,(AB)\r
+ CAIE A,TVEC ; MUST BE VECTOR\r
+ JRST WTYP1\r
+ MOVE B,1(AB) ; GET IT\r
+ GETYP A,(B) ; CHECK 1ST ELEMENTS TYPE\r
+ CAIN A,TPCODE ; PURE CODE\r
+ JRST .+3\r
+ CAIE A,TCODE\r
+ JRST NRSUBR\r
+ HLRM B,(B) ; CLOBEER SPECIAL COUNT FIELD\r
+ MOVSI A,TRSUBR\r
+ JRST FINIS\r
+\r
+NRSUBR: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE FIRST-ELEMENT-OF-VECTOR-NOT-CODE\r
+ JRST CALER1\r
+\r
+; ROUTINE TO GENERATE ENTRYY OTHER THAN FIRST TO RSUBRR\r
+\r
+MFUNCTION MENTRY,SUBR,[RSUBR-ENTRY]\r
+\r
+ ENTRY 2\r
+\r
+ GETYP 0,(AB) ; TYPE OF ARG\r
+ CAIE 0,TVEC ; BETTER BE VECTOR\r
+ JRST WTYP1\r
+ GETYP 0,2(AB)\r
+ CAIE 0,TFIX\r
+ JRST WTYP2\r
+ MOVE B,1(AB) ; GET VECTOR\r
+ CAML B,[-3,,0]\r
+ JRST BENTRY\r
+ GETYP 0,(B) ; FIRST ELEMENT\r
+ CAIE 0,TRSUBR\r
+ JRST MENTR1\r
+MENTR2: GETYP 0,2(B)\r
+ CAIE 0,TATOM\r
+ JRST BENTRY\r
+ MOVE C,3(AB)\r
+ HRRM C,2(B) ; OFFSET INTO VECTOR\r
+ HLRM B,(B)\r
+ MOVSI A,TENTER\r
+ JRST FINIS\r
+\r
+MENTR1: CAIE 0,TATOM\r
+ JRST BENTRY\r
+ MOVE B,1(B) ; GET ATOM\r
+ PUSHJ P,IGVAL ; GET VAL\r
+ GETYP 0,A\r
+ CAIE 0,TRSUBR\r
+ JRST BENTRY\r
+ MOVE B,1(AB) ; RESTORE B\r
+ JRST MENTR2\r
+\r
+BENTRY: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE BAD-VECTOR\r
+ JRST CALER1\r
+ \r
+; SUBR TO GET ENTRIES OFFSET\r
+\r
+MFUNCTION LENTRY,SUBR,[ENTRY-LOC]\r
+\r
+ ENTRY 1\r
+\r
+ GETYP 0,(AB)\r
+ CAIE 0,TENTER\r
+ JRST WTYP1\r
+ MOVE B,1(AB)\r
+ HRRZ B,2(B)\r
+ MOVSI A,TFIX\r
+ JRST FINIS\r
+\r
+; RETURN FALSE\r
+\r
+RTFALS: MOVSI A,TFALSE\r
+ MOVEI B,0\r
+ POPJ P,\r
+\r
+;SUBROUTINE CALL FOR RSUBRs\r
+RCALL: SUBM M,(P) ;CALCULATE PC's OFFSET IN THE RSUBR\r
+ PUSHJ P,@0 ;GO TO THE PROPER SUBROUTINE\r
+ SUBM M,(P) ;RECONSTITUTE THE RSUBR's PC\r
+ POPJ P,\r
+\r
+\r
+; ERRORS IN COMPILED CODE MAY END UP HERE\r
+\r
+COMPERR:\r
+ PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE ERROR-IN-COMPILED-CODE\r
+ JRST CALER1\r
+\f\r
+\r
+;CHTYPE TAKES TWO ARGUMENTS. ANY GOODIE AND A AN ATOMIC TYPE NAME\r
+;IT CHECKS THE STORAGE ALLOCATION TYPES OF THE TWO ARE THE SAME AND\r
+;IF THEY ARE CHANGES THE TYPE OF THE FIRST TO THAT NAME D IN THE SECOND\r
+\r
+MFUNCTION CHTYPE,SUBR\r
+\r
+ ENTRY 2\r
+ GETYP A,2(AB) ;FIRST CHECK THAT ARG 2 IS AN ATOM\r
+ CAIE A,TATOM \r
+ JRST NOTATOM\r
+ MOVE B,3(AB) ;AND TYPE NAME\r
+ PUSHJ P,TYPLOO ;GO LOOKUP TYPE\r
+TFOUND: HRRZ B,(A) ;GOBBLE THE SAT\r
+ TRNE B,CHBIT ; SKIP IF CHTYPABLE\r
+ JRST CANTCH\r
+ TRNE B,TMPLBT ; TEMPLAT\r
+ HRLI B,-1\r
+ AND B,[-1,,SATMSK]\r
+ GETYP A,(AB) ;NOW GET TYPE TO HACK\r
+ PUSHJ P,SAT ;FIND OUT ITS SAT\r
+ JUMPE A,TYPERR ;COMPLAIN\r
+ CAILE A,NUMSAT\r
+ JRST CHTMPL ; JUMP IF TEMPLATE DATA\r
+ CAIE A,(B) ;DO THEY AGREE?\r
+ JRST TYPDIF ;NO, COMPLAIN\r
+CHTMP1: MOVSI A,(D) ;GET NEW TYPE\r
+ HRR A,(AB) ; FOR DEFERRED GOODIES\r
+ JUMPL B,CHMATC ; CHECK IT\r
+ MOVE B,1(AB) ;AND VALUE\r
+ JRST FINIS\r
+\r
+CHTMPL: MOVE E,1(AB) ; GET ARG\r
+ HLRZ A,(E)\r
+ ANDI A,SATMSK\r
+ MOVE 0,3(AB) ; SEE IF TO "TEMPLATE"\r
+ CAME 0,MQUOTE TEMPLATE\r
+ CAIN A,(B)\r
+ JRST CHTMP1\r
+ JRST TYPDIF\r
+\r
+CHMATC: PUSH TP,A\r
+ PUSH TP,1(AB) ; SAVE GOODIE\r
+ MOVSI A,TATOM\r
+ MOVE B,3(AB)\r
+ MOVSI C,TATOM\r
+ MOVE D,MQUOTE DECL\r
+ PUSHJ P,IGET ; FIND THE DECL\r
+ MOVE C,(AB)\r
+ MOVE D,1(AB) ; NOW GGO TO MATCH\r
+ PUSHJ P,TMATCH\r
+ JRST TMPLVIO\r
+ POP TP,B\r
+ POP TP,A\r
+ JRST FINIS\r
+\r
+TYPLOO: PUSHJ P,TYPFND\r
+ JRST .+2\r
+ POPJ P,\r
+ PUSH TP,$TATOM ;LOST, GENERATE ERROR\r
+ PUSH TP,EQUOTE BAD-TYPE-NAME\r
+ JRST CALER1\r
+\r
+TYPFND: MOVE A,TYPVEC+1(TVP) ;GOBBLE DOWN TYPE VECTOR\r
+ MOVEI D,0 ;INITIALIZE TYPE COUNTER\r
+TLOOK: CAMN B,1(A) ;CHECK THIS ONE\r
+ JRST CPOPJ1\r
+ ADDI D,1 ;BUMP COUNTER\r
+ AOBJP A,.+2 ;COUTN DOWN ON VECTOR\r
+ AOBJN A,TLOOK\r
+ POPJ P,\r
+CPOPJ1: AOS (P)\r
+ POPJ P,\r
+\r
+TYPDIF: PUSH TP,$TATOM ;MAKE ERROR MESSAGE\r
+ PUSH TP,EQUOTE STORAGE-TYPES-DIFFER\r
+ JRST CALER1\r
+\r
+\r
+TMPLVI: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE DECL-VIOLATION\r
+ JRST CALER1\r
+\f\r
+\r
+; FUNCTION TO ADD A NEW TYPE TO THE WORLD WITH GIVEN PRIMITIVE TYPE\r
+\r
+MFUNCTION NEWTYPE,SUBR\r
+\r
+ ENTRY\r
+\r
+ HLRZ 0,AB ; CHEC # OF ARGS\r
+ CAILE 0,-4 ; AT LEAST 2\r
+ JRST TFA\r
+ CAIGE 0,-6\r
+ JRST TMA ; NOT MORE THAN 3\r
+ GETYP A,(AB) ; GET 1ST ARGS TYPE (SHOULD BE ATOM)\r
+ GETYP C,2(AB) ; SAME WITH SECOND\r
+ CAIN A,TATOM ; CHECK\r
+ CAIE C,TATOM\r
+ JRST NOTATOM\r
+\r
+ MOVE B,3(AB) ; GET PRIM TYPE NAME\r
+ PUSHJ P,TYPLOO ; LOOK IT UP\r
+ HRRZ A,(A) ; GOBBLE SAT\r
+ HRLI A,TATOM ; MAKE NEW TYPE\r
+ PUSH P,A ; AND SAVE\r
+ MOVE B,1(AB) ; SEE IF PREV EXISTED\r
+ PUSHJ P,TYPFND\r
+ JRST NEWTOK ; DID NOT EXIST BEFORE\r
+ MOVEI B,2(A) ; FOR POSSIBLE TMPLAT BIT\r
+ HRRZ A,(A) ; GET SAT\r
+ HRRZ 0,(P) ; AND PROPOSED\r
+ ANDI 0,SATMSK\r
+ ANDI A,SATMSK\r
+ CAIN 0,(A) ; SKIP IF LOSER\r
+ JRST NEWTFN ; O.K.\r
+\r
+ PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE TYPE-ALREADY-EXISTS\r
+ JRST CALER1\r
+\r
+NEWTOK: POP P,A\r
+ MOVE B,1(AB) ; NEWTYPE NAME\r
+ PUSHJ P,INSNT ; MUNG IN NEW TYPE\r
+\r
+NEWTFN: CAML AB,[-5,,] ; SKIP IF TEMPLAT SUPPLIED\r
+ JRST NEWTF1\r
+ MOVEI 0,TMPLBT ; GET THE BIT\r
+ IORM 0,-2(B) ; INTO WORD\r
+ MOVE A,(AB) ; GET TYPE NAME\r
+ MOVE B,1(AB)\r
+ MOVSI C,TATOM\r
+ MOVE D,MQUOTE DECL\r
+ PUSH TP,4(AB) ; GET TEMLAT\r
+ PUSH TP,5(AB)\r
+ PUSHJ P,IPUT\r
+NEWTF1: MOVE A,(AB)\r
+ MOVE B,1(AB) ; RETURN NAME\r
+ JRST FINIS\r
+\r
+; SET UP GROWTH FIELDS\r
+\r
+IGROWT: SKIPA A,[111100,,(C)]\r
+IGROWB: MOVE A,[001100,,(C)]\r
+ HLRE B,C\r
+ SUB C,B ; POINT TO DOPE WORD\r
+ MOVE B,TYPIC ; INDICATED GROW BLOCK\r
+ DPB B,A\r
+ POPJ P,\r
+\r
+INSNT: PUSH TP,A\r
+ PUSH TP,B ; SAVE NAME OF NEWTYPE\r
+ MOVE C,TYPBOT+1(TVP) ; CHECK GROWTH NEED\r
+ CAMGE C,TYPVEC+1(TVP)\r
+ JRST ADDIT ; STILL ROOM\r
+GAGN: PUSHJ P,IGROWB ; SETUP BOTTOM GROWTH\r
+ SKIPE C,EVATYP+1(TVP)\r
+ PUSHJ P,IGROWT ; SET UP TOP GROWTH\r
+ SKIPE C,APLTYP+1(TVP)\r
+ PUSHJ P,IGROWT\r
+ MOVE C,[11.,,5] ; SET UP INDICATOR FOR AGC\r
+ PUSHJ P,AGC ; GROW THE WORLD\r
+ AOJL A,GAGN ; BAD AGC LOSSAGE\r
+ MOVE 0,[-101,,-100]\r
+ ADDM 0,TYPBOT+1(TVP) ; FIX UP POINTER\r
+\r
+ADDIT: MOVE C,TYPVEC+1(TVP)\r
+ SUB C,[2,,2] ; ALLOCATE ROOM\r
+ MOVEM C,TYPVEC+1(TVP)\r
+ HLRE B,C ; PREPARE TO BLT\r
+ SUBM C,B ; C POINTS DOPE WORD END\r
+ HRLI C,2(C) ; GET BLT AC READY\r
+ BLT C,-3(B)\r
+ POP TP,-1(B) ; CLOBBER IT IN\r
+ POP TP,-2(B)\r
+ POPJ P,\r
+\r
+\f\r
+; Interface to interpreter for setting up tables associated with\r
+; template data structures.\r
+; A/ <\b-name of type>\b-\r
+; B/ <\b-length ins>\b-\r
+; C/ <\b-uvector of length code or 0>\r
+; D/ <\b-uvector of GETTERs>\b-\r
+; E/ <\b-uvector of PUTTERs>\b-\r
+\r
+CTMPLT: SUBM M,(P) ; could possibly gc during this stuff\r
+ SKIPE C ; for now dont handle vector of length ins\r
+ FATAL TEMPLATE DATA WITH COMPUTED LENGTH\r
+ PUSH TP,$TATOM ; save name of type\r
+ PUSH TP,A\r
+ PUSH P,B ; save length instr\r
+ HLRE A,TD.LNT+1(TVP) ; check for template slots left?\r
+ HRRZ B,TD.LNT+1(TVP)\r
+ SUB B,A ; point to dope words\r
+ HLRZ B,1(B) ; get real length\r
+ ADDM B,A ; any room?\r
+ JUMPG A,GOODRM ; jump if ok\r
+\r
+ PUSH TP,$TUVEC ; save getters and putters\r
+ PUSH TP,D\r
+ PUSH TP,$TUVEC\r
+ PUSH TP,E\r
+ MOVEI A,6(B) ; grow it 10 by copying\r
+ PUSH P,A ; save new length\r
+ PUSHJ P,CAFRE1 ; get frozen uvector\r
+ ADD B,[10,,10] ; rest it down some\r
+ HRL C,TD.LNT+1(TVP) ; prepare to BLT in\r
+ MOVEM B,TD.LNT+1(TVP) ; and save as new length vector\r
+ HRRI C,(B) ; destination\r
+ ADD B,(P) ; final destination address\r
+ BLT C,-13(B)\r
+ MOVE A,(P) ; length for new getters\r
+ PUSHJ P,CAFRE1\r
+ MOVE C,TD.GET+1(TVP) ; get old for copy\r
+ MOVEM B,TD.GET+1(TVP)\r
+ HRRI C,(B)\r
+ ADD B,(P)\r
+ BLT C,-13(B) ; zap those guys in\r
+ MOVE A,(P) ; finally putters\r
+ PUSHJ P,CAFRE1\r
+ MOVE C,TD.PUT+1(TVP)\r
+ MOVEM B,TD.PUT+1(TVP)\r
+ HRRI C,(B) ; BLT pointer\r
+ ADD B,(P)\r
+ BLT C,-13(B)\r
+ SUB P,[1,,1] ; flush stack craft\r
+ MOVE E,(TP)\r
+ MOVE D,-2(TP)\r
+ SUB TP,[4,,4]\r
+\r
+GOODRM: MOVE B,TD.LNT+1(TVP) ; move down to fit new guy\r
+ SUB B,[1,,1] ; will always win due to prev checks\r
+ MOVEM B,TD.LNT+1(TVP)\r
+ HRLI B,1(B)\r
+ HLRE A,TD.LNT+1(TVP)\r
+ MOVNS A\r
+ ADDI A,-1(B) ; A/ final destination\r
+ BLT B,-1(A)\r
+ POP P,(A) ; new length ins munged in\r
+ HLRE A,TD.LNT+1(TVP)\r
+ MOVNS A ; A/ offset for other guys\r
+ PUSH P,A ; save it\r
+ ADD A,TD.GET+1(TVP) ; point for storing uvs of ins\r
+ MOVEM D,-1(A)\r
+ MOVE A,(P)\r
+ ADD A,TD.PUT+1(TVP)\r
+ MOVEM E,-1(A) ; store putter also\r
+ POP P,A ; compute primtype\r
+ ADDI A,NUMSAT\r
+ HRLI A,TATOM\r
+ MOVE B,(TP) ; ready to mung type vector\r
+ SUB TP,[2,,2]\r
+ PUSHJ P,INSNT ; insert into vector\r
+ JRST MPOPJ\r
+\f\r
+\r
+; FUNCTIONS TO SET UP EVALUATION AND APPLICATION RULES FOR DATA TYPES\r
+\r
+MFUNCTION EVALTYPE,SUBR\r
+\r
+ ENTRY 2\r
+\r
+ PUSHJ P,CHKARG ; VERIFY WINNAGE IN ARGS\r
+ MOVEI A,EVATYP ; POINT TO TABLE\r
+ MOVEI E,EVTYPE ; POINT TO PURE VERSION\r
+TBLCAL: PUSHJ P,TBLSET ; SETUP TABLE ENTRY\r
+ JRST FINIS\r
+\r
+MFUNCTION APPLYTYPE,SUBR\r
+\r
+ ENTRY 2\r
+\r
+ PUSHJ P,CHKARG\r
+ MOVEI A,APLTYP ; POINT TO APPLY TABLE\r
+ MOVEI E,APTYPE ; PURE TABLE\r
+ JRST TBLCAL\r
+\r
+\r
+MFUNCTION PRINTTYPE,SUBR\r
+\r
+ ENTRY 2\r
+\r
+ PUSHJ P,CHKARG\r
+ MOVEI A,PRNTYP ; POINT TO APPLY TABLE\r
+ MOVEI E,PRTYPE ; PURE TABLE\r
+ JRST TBLCAL\r
+\r
+; CHECK ARGS AND SETUP FOR TABLE HACKER\r
+\r
+CHKARG: GETYP A,(AB) ; 1ST MUST BE TYPE NAME\r
+ CAIE A,TATOM\r
+ JRST WTYP1\r
+ MOVE B,1(AB) ; GET ATOM\r
+ PUSHJ P,TYPLOO ; VERIFY THAT IT IS A TYPE\r
+ PUSH P,D ; SAVE TYPE NO.\r
+ HRRZ A,(A) ; GET SAT\r
+ ANDI A,SATMSK\r
+ PUSH P,A\r
+ GETYP A,2(AB) ; GET 2D TYPE\r
+ CAIE A,TATOM ; EITHER TYPE OR APPLICABLE\r
+ JRST TRYAPL ; TRY APPLICABLE\r
+ MOVE B,3(AB) ; VERIFY IT IS A TYPE\r
+ PUSHJ P,TYPLOO\r
+ HRRZ A,(A) ; GET SAT\r
+ ANDI A,SATMSK\r
+ POP P,C ; RESTORE SAVED SAT\r
+ CAIE A,(C) ; SKIP IF A WINNER\r
+ JRST TYPDIF ; REPORT ERROR\r
+ POP P,C ; GET SAVED TYPE\r
+ MOVEI B,0 ; TELL THAT WE ARE A TYPE\r
+ POPJ P,\r
+\r
+TRYAPL: PUSHJ P,APLQ ; IS THIS APPLICABLE\r
+ JRST NAPT\r
+ SUB P,[1,,1]\r
+ MOVE B,2(AB) ; RETURN SAME\r
+ MOVE D,3(AB)\r
+ POP P,C\r
+ POPJ P,\r
+\r
+\f\r
+; HERE TO PUT ENTRY IN APPROPRIATE TABLE\r
+\r
+TBLSET: HRLI A,(A) ; FOR TVP HACKING\r
+ ADD A,TVP ; POINT TO TVP SLOT\r
+ PUSH TP,B\r
+ PUSH TP,D ; SAVE VALUE \r
+ PUSH TP,$TVEC\r
+ PUSH TP,A\r
+ PUSH P,C ; SAVE TYPE BEING HACKED\r
+ PUSH P,E\r
+ SKIPE B,1(A) ; SKIP IF VECTOR DOESN'T EXIST YET\r
+ JRST TBL.OK\r
+ HLRE A,TYPBOT+1(TVP) ; GET CURRENT TABLE LNTH\r
+ MOVNS A\r
+ ASH A,-1\r
+ PUSHJ P,IVECT ; GET VECTOR\r
+ MOVE C,(TP) ; POINT TO RETURN POINT\r
+ MOVEM B,1(C) ; SAVE VECTOR\r
+\r
+TBL.OK: POP P,E\r
+ POP P,C ; RESTORE TYPE\r
+ SUB TP,[2,,2]\r
+ POP TP,D\r
+ POP TP,A\r
+ JUMPN A,TBLOK1 ; JUMP IF FUNCTION ETC. SUPPLIED\r
+ CAILE D,NUMPRI ; SKIP IF ORIGINAL TYPE\r
+ MOVNI E,(D) ; CAUSE E TO ENDUP 0\r
+ ADDI E,(D) ; POINT TO PURE SLOT\r
+TBLOK1: ADDI C,(C) ; POINT TO VECTOR SLOT\r
+ ADDI C,(B)\r
+ JUMPN A,OK.SET ; OK TO CLOBBER\r
+ ADDI B,(D) ; POINT TO TARGET TYPE'S SLOT\r
+ ADDI B,(D) ; POINT TO TARGET TYPE'S SLOT\r
+ SKIPN A,(B) ; SKIP IF WINNER\r
+ SKIPE 1(B) ; SKIP IF LOSER\r
+ SKIPA D,1(B) ; SETUP D\r
+ JRST CH.PTB ; CHECK PURE TABLE\r
+\r
+OK.SET: MOVEM A,(C) ; STORE\r
+ MOVEM D,1(C)\r
+ MOVE A,(AB) ; RET TYPE\r
+ MOVE B,1(AB)\r
+ JRST FINIS\r
+\r
+CH.PTB: MOVEI A,0\r
+ MOVE D,[SETZ NAPT]\r
+ JUMPE E,OK.SET\r
+ MOVE D,(E)\r
+ JRST OK.SET\r
+\r
+CALLTY: MOVE A,TYPVEC(TVP)\r
+ MOVE B,TYPVEC+1(TVP)\r
+ POPJ P,\r
+\r
+MFUNCTION ALLTYPES,SUBR\r
+\r
+ ENTRY 0\r
+\r
+ MOVE A,TYPVEC(TVP)\r
+ MOVE B,TYPVEC+1(TVP)\r
+ JRST FINIS\r
+\r
+;\f\r
+\r
+;FUNCTION TO RETURN TYPE OF ELEMENTS IN A UVECTOR\r
+\r
+MFUNCTION UTYPE,SUBR\r
+\r
+ ENTRY 1\r
+\r
+ GETYP A,(AB) ;GET U VECTOR\r
+ PUSHJ P,SAT\r
+ CAIE A,SNWORD\r
+ JRST WTYP1\r
+ MOVE B,1(AB) ; GET UVECTOR\r
+ PUSHJ P,CUTYPE\r
+ JRST FINIS\r
+\r
+CUTYPE: HLRE A,B ;GET -LENGTH\r
+ HRRZS B\r
+ SUB B,A ;POINT TO TYPE WORD\r
+ GETYP A,(B)\r
+ JRST ITYPE ; GET NAME OF TYPE\r
+\r
+; FUNCTION TO CHANGE UNIFORM TYPE OF A VECTOR\r
+\r
+MFUNCTION CHUTYPE,SUBR\r
+\r
+ ENTRY 2\r
+\r
+ GETYP A,2(AB) ;GET 2D TYPE\r
+ CAIE A,TATOM\r
+ JRST NOTATO\r
+ GETYP A,(AB) ; CALL WITH UVECTOR?\r
+ PUSHJ P,SAT\r
+ CAIE A,SNWORD\r
+ JRST WTYP1\r
+ MOVE A,1(AB) ; GET UV POINTER\r
+ MOVE B,3(AB) ;GET ATOM\r
+ PUSHJ P,CCHUTY\r
+ MOVE A,(AB) ; RETURN UVECTOR\r
+ MOVE B,1(AB)\r
+ JRST FINIS\r
+\r
+CCHUTY: PUSH TP,$TUVEC\r
+ PUSH TP,A\r
+ PUSHJ P,TYPLOO ;LOOK IT UP\r
+ HRRZ B,(A) ;GET SAT\r
+ TRNE B,CHBIT\r
+ JRST CANTCH\r
+ ANDI B,SATMSK\r
+ HLRE C,(TP) ;-LENGTH\r
+ HRRZ E,(TP)\r
+ SUB E,C ;POINT TO TYPE\r
+ GETYP A,(E) ;GET TYPE\r
+ JUMPE A,WIN0 ;ALLOW TYPE "LOSE" TO CHANGE TO ANYTHING\r
+ PUSHJ P,SAT ;GET SAT\r
+ JUMPE A,TYPERR\r
+ CAIE A,(B) ;COMPARE\r
+ JRST TYPDIF\r
+WIN0: HRLM D,(E) ;CLOBBER NEW ONE\r
+ POP TP,B\r
+ POP TP,A\r
+ POPJ P,\r
+\r
+CANTCH: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE CANT-CHTYPE-INTO\r
+ PUSH TP,2(AB)\r
+ PUSH TP,3(AB)\r
+ MOVEI A,2\r
+ JRST CALER\r
+\r
+NOTATOM:\r
+ PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE NON-ATOMIC-ARGUMENT\r
+ PUSH TP,(AB)\r
+ PUSH TP,1(AB)\r
+ MOVEI A,2\r
+ JRST CALER\r
+\r
+\r
+\f\r
+; SUBROUTINE TO LEAVE MUDDLE CLOSING ALL CHANNELS ON THE WAY\r
+\r
+MFUNCTION QUIT,SUBR\r
+\r
+ ENTRY 0\r
+\r
+\r
+ PUSHJ P,CLOSAL ; DO THE CLOSES\r
+ PUSHJ P,%KILLM\r
+ JRST IFALSE ; JUST IN CASE\r
+\r
+CLOSAL: MOVE B,TVP ; POINT TO XFER VECCTOR\r
+ ADD B,[CHNL0+2,,CHNL0+2] ; POINT TO 1ST (NOT INCLUDING TTY I/O)\r
+ PUSH TP,$TVEC\r
+ PUSH TP,B\r
+ PUSH P,[N.CHNS-1] ; MAX NO. OF CHANS\r
+\r
+CLOSA1: MOVE B,(TP)\r
+ ADD B,[2,,2]\r
+ MOVEM B,(TP)\r
+ SKIPN C,-1(B) ; THIS ONE OPEN?\r
+ JRST CLOSA4 ; NO\r
+ CAME C,TTICHN+1(TVP)\r
+ CAMN C,TTOCHN+1(TVP)\r
+ JRST CLOSA4\r
+ PUSH TP,-2(B) ; PUSH IT\r
+ PUSH TP,-1(B)\r
+ MCALL 1,FCLOSE ; CLOSE IT\r
+CLOSA4: SOSLE (P) ; COUNT DOWN\r
+ JRST CLOSA1\r
+\r
+\r
+ SUB TP,[2,,2]\r
+ SUB P,[1,,1]\r
+\r
+CLOSA3: SKIPN B,CHNL0+1(TVP)\r
+ POPJ P,\r
+ PUSH TP,(B)\r
+ HLLZS (TP)\r
+ PUSH TP,1(B)\r
+ HRRZ B,(B)\r
+ MOVEM B,CHNL0+1(TVP)\r
+ MCALL 1,FCLOSE\r
+ JRST CLOSA3\r
+\f\r
+; LITTLE ROUTINES USED ALL OVER THE PLACE\r
+\r
+CRLF: MOVEI A,15\r
+ PUSHJ P,MTYO\r
+ MOVEI A,12\r
+ JRST MTYO\r
+MSGTYP: HRLI B,440700 ;MAKE BYTE POINTER\r
+MSGTY1: ILDB A,B ;GET NEXT CHARACTER\r
+ JUMPE A,CPOPJ ;NULL ENDS STRING\r
+ CAIE A,177 ; DONT PRINT RUBOUTS\r
+ PUSHJ P,MTYO"\r
+ JRST MSGTY1 ;AND GET NEXT CHARACTER\r
+CPOPJ: POPJ P,\r
+\r
+IMPURE\r
+\r
+WHOAMI: 0 ; SYAYS WHETHER I AM REALLY A MUDDLE OR SOME HACK\r
+\r
+\r
+;GARBAGE COLLECTORS PDLS\r
+\r
+\r
+GCPDL: -GCPLNT,,GCPDL\r
+\r
+ BLOCK GCPLNT\r
+\r
+\r
+PURE\r
+\r
+MUDSTR: ASCII /MUDDLE \7f\7f\7f/\r
+STRNG: -1\r
+ -1\r
+ -1\r
+ ASCIZ / IN OPERATION./\r
+\r
+;MARKED PDLS FOR GC PROCESS\r
+\r
+VECTGO\r
+; DUMMY FRAME FOR INITIALIZER CALLS\r
+\r
+ TENTRY,,LISTEN\r
+ 0\r
+ .-3\r
+ 0\r
+ 0\r
+ -ITPLNT,,TPBAS-1\r
+ 0\r
+\r
+TPBAS: BLOCK ITPLNT+PDLBUF\r
+ GENERAL\r
+ ITPLNT+2+PDLBUF+7,,0\r
+\r
+\r
+VECRET\r
+\r
+\r
+\r
+\r
+$TMATO: TATOM,,-1\r
+\r
+\r
+PATCH:\r
+PAT: BLOCK 100\r
+PATEND: 0\r
+\r
+END\r
+\f\r
+TITLE PURE-PAGE LOADER\r
+\r
+RELOCATABLE\r
+\r
+MAPCH==0 ; channel for MAPing\r
+ELN==3 ; Length of table entry\r
+\r
+.GLOBAL PURVEC,PURTOP,PURBOT,P.TOP,MUDSTR,STRTO6,PLOAD,AGC,GCDOWN\r
+.GLOBAL SQUTOA,IGVAL,IBLOCK,PURCLN,MOVPUR,GETPAG,GCFLG,NOSHUF\r
+\r
+.INSRT MUDDLE >\r
+\r
+SYSQ\r
+\r
+IFE ITS,[\r
+IF1, .INSRT STENEX >\r
+]\r
+\r
+IFN ITS,[\r
+PURDIR==SIXBIT /MUD50/ ; directory containing pure pages\r
+OPURDI==SIXBIT /MHILIB/\r
+OFIXDI==SIXBIT /MHILIB/\r
+FIXDIR==SIXBIT /MUD50/\r
+ARC==1 ; flag saying fixups on archive\r
+]\r
+IFN ITS,[\r
+PGMSK==1777\r
+PGSHFT==10.\r
+]\r
+IFE ITS,[\r
+PGMSK==777\r
+PGSHFT==9.\r
+]\r
+\r
+; This routine taskes a slot offset in register A and\r
+; maps in the associated file. It clobbers all ACs\r
+; It skip returns if it wins.\r
+\r
+PLOAD: PUSH P,A ; save slot offset\r
+ ADD A,PURVEC+1(TVP) ; point into pure vector\r
+ MOVE B,(A) ; get sixbit of name\r
+IFN ITS,[\r
+ MOVE C,MUDSTR+2 ; get version number\r
+ PUSHJ P,CSIXBT ; vers # to six bit\r
+ HRRI C,(SIXBIT /SAV/)\r
+ MOVSS C\r
+ .SUSET [.RSNAM,,0] ; GET CURRENT SNAME TO 0\r
+ .SUSET [.SSNAM,,[PURDIR]] ; get sname for it\r
+ MOVE A,[SIXBIT / &DSK/] ; build open block\r
+ .OPEN MAPCH,A ; try to open file\r
+ JRST FIXITU ; no current version, fix one up\r
+ PUSH P,0 ; for compat wit tenex and save old sname\r
+ DOTCAL FILLEN,[[1000,,MAPCH],[2000,,A]]\r
+ JRST MAPLOS\r
+ ADDI A,PGMSK ; in case not even # of pages\r
+ ASH A,-PGSHFT ; to pages\r
+ PUSH P,A ; save the length\r
+]\r
+IFE ITS,[\r
+ MOVE E,P ; save pdl base\r
+ PUSH P,[0] ; slots for building strings\r
+ PUSH P,[0]\r
+ MOVE A,[440700,,1(E)]\r
+ MOVE C,[440600,,B]\r
+ MOVEI D,6\r
+ ILDB 0,C\r
+ JUMPE 0,.+4 ; violate cardinal ".+ rule"\r
+ ADDI 0,40 ; to ASCII\r
+ IDPB 0,A\r
+ SOJG D,.-4\r
+\r
+ PUSH P,[ASCII / SAV/]\r
+ MOVE C,MUDSTR+2 ; get ascii of vers no.\r
+ IORI C,1 ; hair to change r.o. to space\r
+ MOVE 0,C\r
+ ADDI C,1\r
+ ANDCM C,0 ; C has 1st 1\r
+ JFFO C,.+3\r
+ MOVEI 0,0 ; use zer name\r
+ JRST ZER...\r
+ MOVEI C,(D)\r
+ IDIVI C,7\r
+ AND 0,MSKS(C) ; get rid of r.o.s\r
+ZER...: PUSH P,0\r
+ MOVEI B,-1(P) ; point to it\r
+ HRLI B,260700\r
+ HRROI D,1(E) ; point to name\r
+ MOVEI A,1(P)\r
+\r
+ PUSH P,[100000,,]\r
+ PUSH P,[377777,,377777]\r
+ PUSH P,[-1,,[ASCIZ /DSK/]]\r
+ PUSH P,[-1,,[ASCIZ /MUDLIB/]]\r
+ PUSH P,D\r
+ PUSH P,B\r
+ PUSH P,[0]\r
+ PUSH P,[0]\r
+ PUSH P,[0]\r
+ MOVEI B,0\r
+ MOVE D,4(E) ; save final version string\r
+ GTJFN\r
+ JRST FIXITU\r
+\r
+ MOVE B,[440000,,240000]\r
+ OPENF\r
+ JRST FIXITU\r
+ MOVE P,E ; flush crap\r
+ PUSH P,A\r
+ SIZEF ; get length\r
+ JRST MAPLOS\r
+ PUSH P,C ; save # of pages\r
+ MOVEI A,(C)\r
+]\r
+ PUSHJ P,ALOPAG ; get the necessary pages\r
+ JRST MAPLS1\r
+ PUSH P,B ; save page number\r
+IFN ITS,[\r
+ MOVN A,-1(P) ; get neg count\r
+ MOVSI A,(A) ; build aobjn pointer\r
+ HRR A,(P) ; get page to start\r
+ MOVE B,A ; save for later\r
+ HLLZ 0,A ; page pointer for file\r
+ DOTCAL CORBLK,[[1000,,200000],[1000,,-1],A,[1000,,MAPCH],0]\r
+ JRST MAPLS3 ; total wipe out\r
+ .CLOSE MAPCH, ; no need to have file open anymore\r
+]\r
+IFE ITS,[\r
+ MOVE D,-1(P) ; # of pages to D\r
+ HRLI B,400000 ; specify this fork\r
+ HRROI E,(B) ; build page aobjn for later\r
+ TLC E,-1(D) ; sexy way of doing lh\r
+ HRLZ A,-2(P) ; JFN to lh of A\r
+ MOVSI C,120000 ; bits for read/execute\r
+\r
+ PMAP\r
+ ADDI A,1\r
+ ADDI B,1\r
+ SOJG D,.-3 ; map 'em all\r
+ MOVE A,-2(P)\r
+ CLOSF ; try to close file\r
+ JFCL ; ignore failure\r
+ MOVE B,E\r
+]\r
+\r
+; now try to smash slot in PURVEC\r
+\r
+PLOAD1: MOVE A,PURVEC+1(TVP) ; get pointer to it\r
+ ASH B,PGSHFT ; convert to aobjn pointer to words\r
+ MOVE C,-3(P) ; get slot offset\r
+ ADDI C,(A) ; point to slot\r
+ MOVEM B,1(C) ; clobber it in\r
+ ANDI B,-1 ; isolate address of page\r
+ HRRZ D,PURVEC(TVP) ; get offset into vector for start of chain\r
+ TRNE D,400000 ; skip if not end marker\r
+ JRST SCHAIN\r
+ HRLI D,A ; set up indexed pointer\r
+ ADDI D,1\r
+ HRRZ 0,@D ; get its address\r
+ JUMPE 0,SCHAIN ; no chain exists, start one\r
+ CAILE 0,(B) ; skip if new one should be first\r
+ AOJA D,INLOOP ; jump into the loop\r
+\r
+ SUBI D,1 ; undo ADDI\r
+FCLOB: MOVE E,-3(P) ; get offset for this guy\r
+ HRRM D,2(C) ; link up\r
+ HRRM E,PURVEC(TVP) ; store him away\r
+ JRST PLOADD\r
+\r
+SCHAIN: MOVEI D,400000 ; get end of chain indicator\r
+ JRST FCLOB ; and clobber it in\r
+\r
+INLOOP: MOVE E,D ; save in case of later link up\r
+ HRR D,@D ; point to next table entry\r
+ TRNE D,400000 ; 400000 is the end of chain bit\r
+ JRST SLFOUN ; found a slot, leave loop\r
+ ADDI D,1 ; point to address of progs\r
+ HRRZ 0,@D ; get address of block\r
+ CAILE 0,(B) ; skip if still haven't fit it in\r
+ AOJA D,INLOOP ; back to loop start and point to chain link\r
+ SUBI D,1 ; point back to start of slot\r
+\r
+SLFOUN: MOVE 0,-3(P) ; get offset into vector of this guy\r
+ HRRM 0,@E ; make previous point to us\r
+ HRRM D,2(C) ; link it in\r
+\r
+\r
+PLOADD: AOS -4(P) ; skip return\r
+\r
+MAPLS3: SUB P,[1,,1] ; flush stack crap\r
+MAPLS1: SUB P,[1,,1]\r
+MAPLOS:\r
+IFN ITS,[\r
+ MOVE 0,(P)\r
+ .SUSET [.SSNAM,,0] ; restore SNAME\r
+]\r
+ SUB P,[2,,2]\r
+ POPJ P,\r
+\r
+; Here if no current version exists\r
+\r
+FIXITU: PUSH TP,$TFIX\r
+ PUSH TP,0 ; maybe save sname\r
+\r
+IFN ITS,[\r
+ PUSH P,C ; save final name\r
+ MOVE C,[SIXBIT /FIXUP/] ; name of fixup file\r
+IFN <PURDIR-OFIXDI>,.SUSET [.SSNAM,,[OFIXDI]]\r
+IFN ARC, HRRI A,(SIXBIT /ARC/)\r
+ .OPEN MAPCH,A\r
+IFE ARC, JRST MAPLOS\r
+IFN ARC, PUSHJ P,ARCLOS\r
+ MOVE 0,[-2,,A] ; prepare to read version and length\r
+ PUSH P,B ; save program name\r
+ .IOT MAPCH,0\r
+ SKIPGE 0\r
+ FATAL BAD FIXUP FILE\r
+ PUSH P,B ; save version number of fixup file\r
+ MOVEI A,-2(A) ; length -2 (for vers and length)\r
+ PUSHJ P,IBLOCK ; get a UVECTOR for the fixups\r
+ PUSH TP,$TUVEC ; and save\r
+ PUSH TP,B\r
+ MOVE A,B\r
+ MOVSI 0,TUVEC\r
+ MOVEM 0,ASTO(PVP) ; prepare for moby iot (interruptable)\r
+ ENABLE\r
+ .IOT MAPCH,A ; get fixups\r
+ DISABLE\r
+ .CLOSE MAPCH,\r
+ SETZM ASTO(PVP)\r
+ POP P,A ; restore version number\r
+ IDIVI A,100. ; get 100s digit in a rest in B\r
+ ADDI A,20 ; convert to sixbit\r
+ IDIVI B,10. ; B tens digit C 1s digit\r
+ ADDI B,20\r
+ ADDI C,20\r
+ MOVE 0,[220600,,D]\r
+ MOVSI D,(SIXBIT /SAV/)\r
+ CAIE A,20\r
+ IDPB A,0\r
+ CAIE B,20\r
+ IDPB B,0\r
+ IDPB C,0\r
+ MOVE B,[SIXBIT / &DSK/]\r
+ MOVE C,(P) ; program name\r
+IFN <OPURDI-OFIXDI>,.SUSET [.SSNAM,,[OPURDI]]\r
+ .OPEN MAPCH,B ; try for this one\r
+ JRST MAPLS1\r
+ DOTCAL FILLEN,[[1000,,MAPCH],[2000,,A]]\r
+ JRST MAPLS1\r
+ ADDI A,PGMSK ; in case not exact pages\r
+ ASH A,-PGSHFT ; to pages\r
+ PUSH P,A ; save\r
+ PUSHJ P,ALOPAG ; find some pages\r
+ JRST MAPLS4\r
+ MOVN A,(P) ; build aobjn pointer\r
+ MOVSI A,(A)\r
+ HRRI A,(B)\r
+ MOVE B,A\r
+ HLLZ 0,B\r
+ DOTCAL CORBLK,[[1000,,104000],[1000,,-1],A,[1000,,MAPCH],0]\r
+ JRST MAPLS4\r
+ SUB P,[1,,1]\r
+ .CLOSE MAPCH,\r
+]\r
+IFE ITS,[\r
+ PUSH TP,$TPDL ; save stack pointer\r
+ PUSH TP,E\r
+ PUSH P,D ; save vers string\r
+ HRROI A,[ASCIZ /FIXUP/]\r
+ MOVEM A,10.(E) ; into name slot\r
+ MOVEI A,5(E) ; point to arg block\r
+ SETZB B,C\r
+ GTJFN\r
+ JRST MAPLS4\r
+ MOVEI C,(A) ; save JFN in case OPNEF loses\r
+ MOVE B,[440000,,200000]\r
+ OPENF\r
+ JRST MAPLS4\r
+ BIN ; length of fixups to B\r
+ PUSH P,A ; save JFN\r
+ MOVEI A,-2(B) ; length of uvextor to get\r
+ PUSHJ P,IBLOCK\r
+ PUSH TP,$TUVEC\r
+ PUSH TP,B ; sav it\r
+ POP P,A ; restore JFN\r
+ BIN ; read in vers #\r
+ MOVE D,B ; save vers #\r
+ MOVE B,(TP)\r
+ HLRE C,B\r
+ HRLI B,444400\r
+ SIN ; read in entire fixups\r
+ CLOSF ; and close file of same\r
+ JFCL ; ignore cailure to close\r
+ HRROI C,1(E) ; point to name\r
+ MOVEM C,9.(E)\r
+ MOVEI C,3(E)\r
+ HRLI C,260700\r
+ MOVEM C,10.(E)\r
+ MOVE 0,[ASCII / /]\r
+ MOVEM 0,4(E) ; all spaces\r
+ MOVEI A,(D)\r
+ IDIVI A,100. ; to ascii\r
+ ADDI A,60\r
+ IDIVI B,10.\r
+ ADDI B,60\r
+ ADDI C,60\r
+ MOVE 0,[440700,,4(E)]\r
+ CAIE A,60\r
+ IDPB A,0\r
+ CAIE B,60\r
+ IDPB B,0\r
+ IDPB C,0\r
+ SETZB C,B\r
+ MOVEI A,5(E) ; ready for 'nother GTJFN\r
+ GTJFN\r
+ JRST MAPLS5\r
+ MOVEI C,(A) ; save JFN in case OPENF loses\r
+ MOVE B,[440000,,240000]\r
+ OPENF\r
+ JRST MAPLS5\r
+ SIZEF\r
+ JRST MAPLS5\r
+ PUSH P,A\r
+ PUSH P,C\r
+ MOVEI A,(C)\r
+ PUSHJ P,ALOPAG ; get the pages\r
+ JRST MAPLS5\r
+ MOVEI D,(B) ; save pointer\r
+ MOVN A,(P) ; build page aobjn pntr\r
+ HRLI D,(A)\r
+ EXCH D,(P) ; get length\r
+ HRLI B,400000\r
+\r
+ HRLZ A,-1(P) ; JFN for PMAP\r
+ MOVSI C,120400 ; bits for read/execute/copy-on-write\r
+\r
+ PMAP\r
+ ADDI A,1\r
+ ADDI B,1\r
+ SOJG D,.-3\r
+\r
+ HLRZS A\r
+ CLOSF\r
+ JFCL\r
+ POP P,B ; restore page #\r
+ SUB P,[1,,1]\r
+]\r
+; now to do fixups\r
+\r
+ MOVE A,(TP) ; pointer to them\r
+ ASH B,PGSHFT ; aobjn to program\r
+\r
+FIX1: SKIPL E,(A) ; read one hopefully squoze\r
+ FATAL ATTEMPT TO TYPE FIX PURE\r
+ TLZ E,740000\r
+ PUSHJ P,SQUTOA ; look it up\r
+ FATAL BAD FIXUPS\r
+\r
+ AOBJP A,FIX2\r
+ HLRZ D,(A) ; get old value\r
+ SUBM E,D ; D is diff between old and new\r
+ HRLM E,(A) ; fixup the fixups\r
+ MOVEI 0,0 ; flag for which half\r
+FIX4: JUMPE 0,FIXRH ; jump if getting rh\r
+ MOVEI 0,0 ; next time will get rh\r
+ AOBJP A,FIX2 ; done?\r
+ HLRZ C,(A) ; get lh\r
+ JUMPE C,FIX3 ; 0 terminates\r
+FIX5: ADDI C,(B) ; access the code\r
+ ADDM D,-1(C) ; and fix it up\r
+ JRST FIX4\r
+\r
+FIXRH: MOVEI 0,1 ; change flag\r
+ HRRZ C,(A) ; get it and\r
+ JUMPN C,FIX5\r
+\r
+FIX3: AOBJN A,FIX1 ; do next one\r
+\r
+FIX2:\r
+IFN ITS,[\r
+IFN <PURDIR-OPURDI> .SUSET [.SSNAM,,[PURDIR]]\r
+ .OPEN MAPCH,[SIXBIT / 'DSK_PURE_>/]\r
+ JRST MAPLS1\r
+ MOVE E,B ; save pointer\r
+ ASH E,-PGSHFT ; to page AOBJN\r
+ .IOT MAPCH,B ; write out the goodie\r
+ SETZB 0,A\r
+ MOVEI B,MAPCH\r
+ MOVE C,(P)\r
+ MOVE D,-1(P)\r
+ .FDELE 0 ; attempt to rename to right thing\r
+ JRST MAPLS1\r
+ .CLOSE MAPCH,\r
+ MOVE B,[SIXBIT / &DSK/]\r
+ .OPEN MAPCH,B\r
+ FATAL WHERE DID THE FILE GO?\r
+ HLLZ 0,E ; pointer to file pages\r
+ PUSH P,E ; SAVE FOR END\r
+ DOTCAL CORBLK,[[1000,,200000],[1000,,-1],E,[1000,,MAPCH],0]\r
+ FATAL LOSSAGE LOSSAGE PAGES LOST\r
+ .CLOSE MAPCH,\r
+\r
+ SKIPGE MUDSTR+2 ; skip if not experimental\r
+ JRST NOFIXO\r
+ PUSHJ P,GENVN ; get version number as a number\r
+ MOVE E,(TP)\r
+IFN <PURDIR-FIXDIR>,.SUSET [.SSNAM,,[FIXDIR]]\r
+IFE ARC, .OPEN MAPCH,[SIXBIT / 'DSK_FIXU_>/]\r
+IFN ARC, .OPEN MAPCH,[SIXBIT / 'ARC_FIXU_>/]\r
+IFE ARC, FATAL CANT WRITE FIXUPS\r
+IFN ARC, PUSHJ P,ARCFAT\r
+ HLRE A,E ; get length\r
+ MOVNS A\r
+ ADDI A,2 ; account for these 2 words\r
+ MOVE 0,[-2,,A] ; write version and length\r
+ .IOT MAPCH,0\r
+ .IOT MAPCH,E ; out go the fixups\r
+ SETZB 0,A\r
+ MOVEI B,MAPCH\r
+ MOVE C,-1(P)\r
+ MOVE D,[SIXBIT /FIXUP/]\r
+ .FDELE 0\r
+ FATAL FIXUP WRITE OUT FAILED\r
+ .CLOSE MAPCH,\r
+NOFIXO:\r
+]\r
+IFE ITS,[\r
+ MOVE E,-2(TP) ; restore P-stack base\r
+ MOVEI 0,600000 ; fixup args to GTJFN\r
+ HRLM 0,5(E)\r
+ MOVE D,B ; save page number\r
+ POP P,4(E) ; current version name in\r
+ MOVEI A,5(E) ; pointer ro arg block\r
+ MOVEI B,0\r
+ GTJFN\r
+ FATAL MAP FIXUP LOSSAGE\r
+ MOVE B,[440000,,100000]\r
+ OPENF\r
+ FATAL MAP FIXUP LOSSAGE\r
+ MOVEI B,(D) ; ready to write it out\r
+ HRLI B,444400\r
+ HLRE C,D\r
+ SOUT ; zap it out\r
+ TLO A,400000 ; dont recycle the JFN\r
+ CLOSF\r
+ JFCL\r
+ ANDI A,-1 ; kill sign bit\r
+ MOVE B,[440000,,240000]\r
+ OPENF\r
+ FATAL MAP FIXUP LOSSAGE\r
+ MOVE B,D\r
+ ASH B,-PGSHFT ; aobjn to pages\r
+ PUSH P,B\r
+ HLRE D,B ; -count\r
+ HRLI B,400000\r
+ MOVSI A,(A)\r
+ MOVSI C,120000\r
+\r
+ PMAP\r
+ ADDI A,1\r
+ ADDI B,1\r
+ AOJL D,.-3\r
+\r
+ HLRZS A\r
+ CLOSF\r
+ JFCL\r
+\r
+ HRROI 0,[ASCIZ /FIXUP/] ; now write out new fixup file\r
+ MOVEM 0,10.(E)\r
+ MOVEI A,5(E)\r
+ MOVEI B,0\r
+\r
+ SKIPGE MUDSTR+2\r
+ JRST NOFIXO ; exp vers, dont write out\r
+\r
+ PUSHJ P,GENVN\r
+ MOVEI D,(B) ; save vers in D\r
+ GTJFN\r
+ FATAL MAP FIXUP LOSSAGE\r
+ MOVE B,[440000,,100000]\r
+ OPENF\r
+ FATAL MAP FIXUP LOSSAGE\r
+ HLRE B,(TP) ; length of fixup vector\r
+ MOVNS B\r
+ ADDI B,2 ; for length and version words\r
+ BOUT\r
+ MOVE B,D ; and vers #\r
+ BOUT\r
+ MOVSI B,444400 ; byte pointer to fixups\r
+ HRR B,(TP)\r
+ HLRE C,(TP)\r
+ SOUT\r
+ CLOSF\r
+ JFCL\r
+NOFIXO: MOVE A,(P) ; save aobjn to pages\r
+ MOVE P,-2(TP)\r
+ SUB TP,[2,,2]\r
+ PUSH P,A\r
+]\r
+ HRRZ A,(P) ; get page #\r
+ HLRE C,(P) ; and # of same\r
+ MOVE B,(P) ; set B up for return\r
+ MOVNS C\r
+IFN ITS,[\r
+ SUB P,[2,,2]\r
+ MOVE 0,-2(TP) ; saved sname\r
+ MOVEM 0,(P)\r
+]\r
+ PUSH P,C\r
+ PUSH P,A\r
+ SUB TP,[4,,4]\r
+ JRST PLOAD1\r
+\r
+IFN ITS,[\r
+MAPLS4: .CLOSE MAPCH,\r
+ SUB P,[1,,1]\r
+ JRST MAPLS1\r
+]\r
+IFE ITS,[\r
+MAPLS4: SKIPA A,[4,,4]\r
+MAPLS5: MOVE A,[6,,6]\r
+ MOVE P,E\r
+ SUB TP,A\r
+ SKIPE A,C\r
+ CLOSF\r
+ JFCL\r
+ JRST MAPLOS\r
+]\r
+\r
+IFN ITS,[\r
+IFN ARC,[\r
+ARCLOS: PUSHJ P,CKLOCK\r
+ JRST MAPLS1\r
+\r
+ARCRTR: SOS (P)\r
+ SOS (P)\r
+ POPJ P,\r
+\r
+ARCFAT: PUSHJ P,CKLOCK\r
+ FATAL CANT WRITE FIXUP FILE\r
+ JRST ARCRTR\r
+\r
+CKLOCK: PUSH P,0\r
+ .STATUS MAPCH,0\r
+ LDB 0,[220600,,0]\r
+ CAIN 0,23 ; file locked?\r
+ JRST WAIT ; wait and retry\r
+ POP P,0\r
+ POPJ P,\r
+\r
+WAIT: MOVEI 0,1\r
+ .SLEEP 0,\r
+ POP P,0\r
+ AOS (P)\r
+ POPJ P,\r
+]\r
+]\r
+\r
+; Here to try to get a free page block for new thing\r
+; A/ # of pages to get\r
+\r
+ALOPAG: PUSHJ P,GETPAG ; try to get enough pages\r
+ POPJ P,\r
+ AOS (P) ; won skip return\r
+ MOVEI 0,(B) ; update PURBOT/PURTOP to reflect current state\r
+ ASH 0,PGSHFT\r
+ MOVEM 0,PURBOT\r
+ POPJ P,\r
+\r
+GETPAG: MOVE C,P.TOP ; top of GC space\r
+ ASH C,-PGSHFT ; to page number\r
+ MOVE B,PURBOT ; current bottom of pure space\r
+ ASH B,-PGSHFT ; also to pages\r
+ SUBM B,C ; pages available ==> C\r
+ CAIGE C,(A) ; skip if have enough already\r
+ JRST GETPG1 ; no, try to shuffle around\r
+ SUBI B,(A) ; B/ first new page\r
+ AOS (P)\r
+ POPJ P, ; return with new free page in B\r
+\r
+; Here if shuffle must occur or gc must be done to make room\r
+\r
+GETPG1: MOVEI 0,0\r
+ SKIPE NOSHUF ; if can't shuffle, then ask gc\r
+ JRST ASKAGC\r
+ MOVE 0,PURTOP ; get top of mapped pure area\r
+ SUB 0,P.TOP ; total free words to 0\r
+ ASH 0,-PGSHFT ; to pages\r
+ CAIGE 0,(A) ; skip if winnage possible\r
+ JRST ASKAGC ; please AGC give me some room!!\r
+ SUBM A,C ; C/ amount we must flush to make room\r
+\r
+; Here to find pages for flush using LRU algorithm\r
+\r
+GL1: MOVE B,PURVEC+1(TVP) ; get pointer to pure sr vector\r
+ MOVEI 0,-1 ; get very large age\r
+\r
+GL2: SKIPN 1(B) ; skip if not already flushed\r
+ JRST GL3\r
+ HLRZ D,2(B) ; get this ones age\r
+ CAMLE D,0 ; skip if this is a candidate\r
+ JRST GL3\r
+ MOVE E,B ; point to table entry with E\r
+ MOVEI 0,(D) ; and use as current best\r
+GL3: ADD B,[ELN,,ELN] ; look at next\r
+ JUMPL B,GL2\r
+\r
+ HLRE B,1(E) ; get length of flushee\r
+ ASH B,-PGSHFT ; to negative # of pages\r
+ ADD C,B ; update amount needed\r
+ SETZM 1(E) ; indicate it will be gone\r
+ JUMPG C,GL1 ; jump if more to get\r
+\r
+; Now compact pure space\r
+\r
+ PUSH P,A ; need all acs\r
+ SETZB E,A\r
+ HRRZ D,PURVEC(TVP) ; point to first in core addr order\r
+ HRRZ C,PURTOP ; get destination page\r
+ ASH C,-PGSHFT ; to page number\r
+\r
+CL1: ADD D,PURVEC+1(TVP) ; to real pointer\r
+ SKIPE 1(D) ; skip if this one is a flushee\r
+ JRST CL2\r
+\r
+ HRRZ D,2(D) ; point to next one in chain\r
+ JUMPN E,CL3 ; jump if not first one\r
+ HRRM D,PURVEC(TVP) ; and use its next as first\r
+ JRST CL4\r
+\r
+CL3: HRRM D,2(E) ; link up\r
+ JRST CL4\r
+\r
+; Found a stayer, move it if necessary\r
+\r
+CL2: MOVEI E,(D) ; another pointer to slot\r
+ HLRE B,1(D) ; - length of block\r
+ HRRZ D,1(D) ; pointer to block\r
+ SUB D,B ; point to top of block\r
+ ASH D,-PGSHFT ; to page number\r
+ CAIN D,(C) ; if not moving, jump\r
+ JRST CL6\r
+\r
+ ASH B,-PGSHFT ; to pages\r
+IFN ITS,[\r
+CL5: SUBI C,1 ; move to pointer and from pointer\r
+ SUBI D,1\r
+ DOTCAL CORBLK,[[1000,,200000],[1000,,-1],C,[1000,,-1],D]\r
+ FATAL PURE SHUFFLE LOSSAGE\r
+ AOJL B,CL5 ; count down\r
+]\r
+IFE ITS,[\r
+ PUSH P,B ; save # of pages\r
+ MOVEI A,-1(D) ; copy from pointer\r
+ HRLI A,400000 ; get this fork code\r
+ RMAP ; get a JFN (hopefully)\r
+ EXCH D,(P) ; D # of pages (save from)\r
+ ADDM D,(P) ; update from\r
+ MOVEI B,-1(C) ; to pointer in B\r
+ HRLI B,400000\r
+ MOVSI C,120000 ; read/execute modes\r
+\r
+ PMAP ; move a page\r
+ SUBI A,1\r
+ SUBI B,1\r
+ AOJL D,.-3 ; move them all\r
+\r
+ MOVEI C,1(B)\r
+ POP P,D\r
+ ADDI D,1\r
+]\r
+; Update the table address for this loser\r
+\r
+ SUBM C,D ; compute offset (in pages)\r
+ ASH D,PGSHFT ; to words\r
+ ADDM D,1(E) ; update it\r
+CL7: HRRZ D,2(E) ; chain on\r
+CL4: TRNN D,400000 ; skip if end of chain\r
+ JRST CL1\r
+\r
+ ASH C,PGSHFT ; to words\r
+ MOVEM C,PURBOT ; reset pur bottom\r
+ POP P,A\r
+ JRST GETPAG\r
+\r
+CL6: HRRZ C,1(E) ; get new top of world\r
+ ASH C,-PGSHFT ; to page #\r
+ JRST CL7\r
+\r
+; SUBR to create an entry in the vector for one of these guys\r
+\r
+MFUNCTION PCODE,SUBR\r
+\r
+ ENTRY 2\r
+\r
+ GETYP 0,(AB) ; check 1st arg is string\r
+ CAIE 0,TCHSTR\r
+ JRST WTYP1\r
+ GETYP 0,2(AB) ; second must be fix\r
+ CAIE 0,TFIX\r
+ JRST WTYP2\r
+\r
+ MOVE A,(AB) ; convert name of program to sixbit\r
+ MOVE B,1(AB)\r
+ PUSHJ P,STRTO6\r
+PCODE4: MOVE C,(P) ; get name in sixbit\r
+\r
+; Now look for either this one or an empty slot\r
+\r
+ MOVEI E,0\r
+ MOVE B,PURVEC+1(TVP)\r
+\r
+PCODE2: CAMN C,(B) ; skip if this is not it\r
+ JRST PCODE1 ; found it, drop out of loop\r
+ JUMPN E,.+3 ; dont record another empty if have one\r
+ SKIPN (B) ; skip if slot filled\r
+ MOVE E,B ; remember pointer\r
+ ADD B,[ELN,,ELN]\r
+ JUMPL B,PCODE2 ; jump if more to look at\r
+\r
+ JUMPE E,PCODE3 ; if E=0, error no room\r
+ MOVEM C,(E) ; else stash away name and zero rest\r
+ SETZM 1(E)\r
+ SETZM 2(E)\r
+ JRST .+2\r
+\r
+PCODE1: MOVE E,B ; build <slot #>,,<offset>\r
+ MOVEI 0,0 ; flag whether new slot\r
+ SKIPE 1(E) ; skip if mapped already\r
+ MOVEI 0,1\r
+ MOVE B,3(AB)\r
+ HLRE D,E\r
+ HLRE E,PURVEC+1(TVP)\r
+ SUB D,E\r
+ HRLI B,(D)\r
+ MOVSI A,TPCODE\r
+ SKIPN NOSHUF ; skip if not shuffling\r
+ JRST FINIS\r
+ JUMPN 0,FINIS ; jump if winner\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ HLRZ A,B\r
+ PUSHJ P,PLOAD\r
+ JRST PCOERR\r
+ POP TP,B\r
+ POP TP,A\r
+ JRST FINIS\r
+\r
+PCOERR: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE PURE-LOAD-FAILURE\r
+ JRST CALER1\r
+\r
+\r
+PCODE3: HLRE A,PURVEC+1(TVP) ; get current length\r
+ MOVNS A\r
+ ADDI A,10*ELN ; add 10(8) more entry slots\r
+ PUSHJ P,IBLOCK\r
+ EXCH B,PURVEC+1(TVP) ; store new one and get old\r
+ HLRE A,B ; -old length to A\r
+ MOVSI B,(B) ; start making BLT pointer\r
+ HRR B,PURVEC+1(TVP)\r
+ SUBM B,A ; final dest to A\r
+ BLT B,-1(A)\r
+ JRST PCODE4\r
+\r
+; Here if must try to GC for some more core\r
+\r
+ASKAGC: SKIPE GCFLG ; if already in GC, lose\r
+ POPJ P,\r
+ SUBM A,0 ; amount required to 0\r
+ ASH 0,PGSHFT ; TO WORDS\r
+ MOVEM 0,GCDOWN ; pass as funny arg to AGC\r
+ EXCH A,C ; save A from gc's destruction\r
+IFN ITS, .IOPUSH MAPCH, ; gc uses same channel\r
+ PUSH P,C\r
+ MOVE C,[8,,9.] ; SET UP INDICATORS FOR GC\r
+ PUSHJ P,AGC\r
+ POP P,C\r
+IFN ITS, .IOPOP MAPCH,\r
+ EXCH C,A\r
+ JUMPGE C,GETPAG\r
+ PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE NO-MORE-PAGES\r
+ AOJA TB,CALER1\r
+\r
+; Here to clean up pure space by flushing all shared stuff\r
+\r
+PURCLN: SKIPE NOSHUF\r
+ POPJ P,\r
+ MOVEI B,400000\r
+ HRRM B,PURVEC(TVP) ; flush chain pointer\r
+ MOVE B,PURVEC+1(TVP) ; get pointer to table\r
+ SETZM 1(B) ; zero pointer entry\r
+ SETZM 2(B) ; zero link and age slots\r
+ ADD B,[ELN,,ELN] ; go to next slot\r
+ JUMPL B,.-3 ; do til exhausted\r
+ MOVE B,PURBOT ; now return pages\r
+ SUB B,PURTOP ; compute page AOBJN pointer\r
+ JUMPE B,CPOPJ ; no pure pages?\r
+ MOVSI B,(B)\r
+ HRR B,PURBOT\r
+ ASH B,-PGSHFT\r
+IFN ITS,[\r
+ DOTCAL CORBLK,[[1000,,0],[1000,,-1],B]\r
+ FATAL SYSTEM WONT TAKE CORE BACK?\r
+]\r
+IFE ITS,[\r
+ HLRE D,B ; - # of pges to flush\r
+ HRLI B,400000 ; specify hacking hom fork\r
+ MOVNI A,1\r
+\r
+ PMAP\r
+ ADDI B,1\r
+ AOJL D,.-2\r
+]\r
+ MOVE B,PURTOP ; now fix up pointers\r
+ MOVEM B,PURBOT ; to indicate no pure\r
+CPOPJ: POPJ P,\r
+\r
+; Here to move the entire pure space.\r
+; A/ # and direction of pages to move (+ ==> up)\r
+\r
+MOVPUR: SKIPE NOSHUF\r
+ FATAL CANT MOVE PURE SPACE AROUND\r
+ IFE ITS [ASH A,1]\r
+ SKIPN B,A ; zero movement, ignore call\r
+ POPJ P,\r
+\r
+ ASH B,PGSHFT ; convert to words for pointer update\r
+ MOVE C,PURVEC+1(TVP) ; loop through updating non-zero entries\r
+ SKIPE 1(C)\r
+ ADDM B,1(C)\r
+ ADD C,[ELN,,ELN]\r
+ JUMPL C,.-3\r
+\r
+ MOVE C,PURTOP ; found pages at top and bottom of pure\r
+ ASH C,-PGSHFT\r
+ MOVE D,PURBOT\r
+ ASH D,-PGSHFT\r
+ ADDM B,PURTOP ; update to new boundaries\r
+ ADDM B,PURBOT\r
+ CAIN C,(D) ; differ?\r
+ POPJ P,\r
+ JUMPG A,PUP ; if moving up, go do separate CORBLKs\r
+\r
+IFN ITS,[\r
+ SUBM D,C ; -size of area to C (in pages)\r
+ MOVEI E,(D) ; build pointer to bottom of destination\r
+ ADD E,A\r
+ HRLI E,(C)\r
+ HRLI D,(C)\r
+ DOTCAL CORBLK,[[1000,,200000],[1000,,-1],E,[1000,,-1],D]\r
+ FATAL CANT MOVE PURE\r
+ POPJ P,\r
+\r
+PUP: SUBM C,D ; pages to move to D\r
+ ADDI A,(C) ; point to new top\r
+\r
+PUPL: SUBI C,1\r
+ SUBI A,1\r
+ DOTCAL CORBLK,[[1000,,200000],[1000,,-1],A,[1000,,-1],C]\r
+ FATAL CANT MOVE PURE\r
+ SOJG D,PUPL\r
+ POPJ P,\r
+]\r
+IFE ITS,[\r
+ SUBM D,C ; pages to move to D\r
+ MOVSI E,(C) ; build aobjn pointer\r
+ HRRI E,(D) ; point to lowest\r
+ ADD D,A ; D==> new lowest page\r
+PURCL1: MOVSI A,400000 ; specify here\r
+ HRRI A,(E) ; get a page\r
+ RMAP ; get a real handle on it\r
+ MOVE B,D ; where to go\r
+ HRLI B,400000\r
+ MOVSI C,120000\r
+ PMAP\r
+ ADDI D,1\r
+ AOBJN E,PURCL1\r
+ POPJ P,\r
+\r
+PUP: SUB D,C ; - count to D\r
+ MOVSI E,(D) ; start building AOBJN\r
+ HRRI E,(C) ; aobjn to top\r
+ ADD C,A ; C==> new top\r
+ MOVE D,C\r
+\r
+PUPL: MOVSI A,400000\r
+ HRRI A,(E)\r
+ RMAP ; get real handle\r
+ MOVE B,D\r
+ HRLI B,400000\r
+ MOVSI C,120000\r
+ PMAP\r
+ SUBI E,2\r
+ SUBI D,1\r
+ AOBJN E,PUPL\r
+\r
+ POPJ P,\r
+]\r
+IFN ITS,[\r
+CSIXBT: MOVEI 0,5\r
+ PUSH P,[440700,,C]\r
+ PUSH P,[440600,,D]\r
+ MOVEI D,0\r
+CSXB2: ILDB E,-1(P)\r
+ CAIN E,177\r
+ JRST CSXB1\r
+ SUBI E,40\r
+ IDPB E,(P)\r
+ SOJG 0,CSXB2\r
+CSXB1: SUB P,[2,,2]\r
+ MOVE C,D\r
+ POPJ P,\r
+]\r
+GENVN: MOVE C,[440700,,MUDSTR+2]\r
+ MOVEI D,5\r
+ MOVEI B,0\r
+VNGEN: ILDB 0,C\r
+ CAIN 0,177\r
+ POPJ P,\r
+ IMULI B,10.\r
+ SUBI 0,60\r
+ ADD B,0\r
+ SOJG D,VNGEN\r
+ POPJ P,\r
+\r
+IFE ITS,[\r
+MSKS: 774000,,0\r
+ 777760,,0\r
+ 777777,,700000\r
+ 777777,,777400\r
+ 777777,,777776\r
+]\r
+END\r
+\f\r
+TITLE MAPS -- MAP FUNCTIONS FOR MUDDLE\r
+\r
+RELOCATABLE\r
+\r
+.INSRT MUDDLE >\r
+\r
+.GLOBAL TYPSEG,NXTLM,NAPT,APLQ,INCR1,SPECBI,FRMSTK,MAPPLY\r
+.GLOBAL CHFSWP,SSPEC1,ILVAL,CHUNW\r
+\r
+; PSTACK OFFSETS\r
+\r
+INCNT==0 ; INNER LOOP COUNT\r
+LISTNO==-1 ; ARG NUMBER BEING HACKED\r
+ARGCNT==-2 ; FINAL ARG COUNTER\r
+NARGS==-3 ; NUMBER OF STRUCTURES\r
+NTHRST==-4 ; 0=> MAP REST, OTHERWISE MAP FIRST\r
+\r
+; MAP THE "CAR" OF EACH LIST\r
+\r
+MFUNCTION MAPF,SUBR\r
+\r
+ PUSH P,. ; PUSH NON-ZERO\r
+ JRST MAP1\r
+\r
+; MAP THE "CDR" OF EACH LIST\r
+\r
+MFUNCTION MAPR,SUBR\r
+\r
+ PUSH P,[0]\r
+\r
+MAP1: ENTRY\r
+ HLRE C,AB ; HOW MANY ARGS\r
+ ASH C,-1 ; TO # OF PAIRS\r
+ ADDI C,3 ; AT LEAST 3\r
+ JUMPG C,TFA ; NOT ENOUGH\r
+ GETYP A,(AB) ; TYPE OF CONSTRUCTOR\r
+ CAIN A,TFALSE ; ANY CONSING NEEDE?\r
+ JRST MAP2 ; NO, SKIP CHECK\r
+ PUSHJ P,APLQ ; CHECK IF APPLICABLE\r
+ JRST NAPT ; NO, ERROR\r
+MAP2: MOVNS C ; POS NO. OF ARGS (-3)\r
+ ADDI C,1 ; C/ NOW # OF LISTS...\r
+ PUSH P,C ; SAVE IT\r
+ PUSH TP,[TATOM,,-1] ; ALL **GFP** INSTRUCTIONS ARE TO DO WITH MAPRET\r
+ PUSH TP,MQUOTE LMAP,[LMAP ]INTRUP\r
+ PUSHJ P,FRMSTK ; **GFP**\r
+ PUSH TP,[0] ; **GFP**\r
+ PUSH TP,[0] ; **GFP**\r
+ PUSHJ P,SPECBIND ; **GFP**\r
+ MOVE C,(P) ; RESTORE COUNT OF ARGS\r
+ MOVE A,AB ; COPY ARG POINTER\r
+ MOVSI 0,TAB ; CLOBBER A'S TYPE\r
+ MOVEM 0,ASTO(PVP)\r
+\r
+ARGLP: INTGO ; STACK MAY OVERFLOW\r
+ PUSH TP,4(A) ; SKIP FCNS\r
+ PUSH TP,5(A)\r
+ ADD A,[2,,2]\r
+ SOJG C,ARGLP ; ALL UP ON STACK\r
+\r
+; ALL STRUCTURES ARE ON THE STACK, NOW PUSH THE CONSTRUCTOR\r
+\r
+ PUSH TP,(AB) ; CONSTRUCTOR\r
+ PUSH TP,1(AB)\r
+ SETZM ASTO(PVP)\r
+ PUSH P,[-1] ; FUNNY TEMPS\r
+ PUSH P,[0]\r
+ PUSH P,[0]\r
+\r
+; OUTER LOOP CDRING EACH STRUCTURE\r
+\r
+OUTRLP: SETZM LISTNO(P) ; START AT 0TH LIST\r
+ MOVE 0,NARGS(P) ; TOTAL # OF STRUCS\r
+ MOVEM 0,INCNT(P) ; AS COUNTER IN INNER LOOP\r
+ PUSH TP,2(AB) ; PUSH THE APPLIER\r
+ PUSH TP,3(AB)\r
+\r
+; INNER LOOP, CONS UP EACH APPLICATION\r
+\r
+INRLP: INTGO\r
+ MOVEI E,2 ; READY TO BUMP LISTNO\r
+ ADDB E,LISTNO(P) ; CURRENT STORED AND IN C\r
+ ADDI E,(TB)4 ; POINT TO A STRUCTURE\r
+ MOVE A,(E) ; PICK IT UP\r
+ MOVE B,1(E) ; AND VAL\r
+ PUSHJ P,TYPSEG ; SETUP TO REST IT ETC.\r
+ SKIPL ARGCNT(P) ; DONT INCR THE 1ST TIME\r
+ XCT INCR1(C) ; INCREMENT THE LOSER\r
+ MOVE 0,DSTO(PVP) ; UPDATE THE LIST\r
+ MOVEM 0,(E)\r
+ MOVEM D,1(E) ; CLOBBER AWAY\r
+ PUSH TP,DSTO(PVP) ; FOR REST CASE\r
+ PUSH TP,D\r
+ PUSHJ P,NXTLM ; SKIP IF GOT ONE, ELSE DONT\r
+ JRST DONEIT ; FINISHED\r
+ SETZM DSTO(PVP)\r
+ SKIPN NTHRST(P) ; SKIP IF MAP REST\r
+ JRST INRLP1\r
+ MOVEM A,-1(TP) ; IUSE AS ARG\r
+ MOVEM B,(TP)\r
+INRLP1: SOSE INCNT(P) ; COUNT ARGS\r
+ JRST INRLP ; MORE, GO DO THEM\r
+\r
+\r
+; ALL ARGS PUSHED, APPLY USER FCN\r
+\r
+ SKIPGE ARGCNT(P) ; UN NEGATE ARGCNT\r
+ SETZM ARGCNT(P)\r
+ MOVE A,NARGS(P) ; GET # OF ARGS\r
+ ADDI A,1\r
+ ACALL A,MAPPLY ; APPLY THE BAG BITER\r
+\r
+ GETYP 0,(AB) ; GET TYPE OF CONSTRUCTOR\r
+ CAIN 0,TFALSE ; SKIP IF ONE IS THERE\r
+ JRST OUTRL1\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ AOS ARGCNT(P)\r
+ JRST OUTRLP\r
+\r
+OUTRL1: MOVEM A,-1(TP) ; SAVE PARTIAL VALUE\r
+ MOVEM B,(TP)\r
+ JRST OUTRLP\r
+\r
+; HERE IF ALL FINISHED\r
+\r
+DONEIT: HRLS C,LISTNO(P) ; HOW MANY DONE\r
+ SUB TP,[2,,2] ; FLUSH SAVED VAL\r
+ SUB TP,C ; FLUSH TUPLE OF CRUFT\r
+DONEI1: SKIPGE ARGCNT(P)\r
+ SETZM ARGCNT(P) ; IN CASE STILL NEGATIVE\r
+ SETZM DSTO(PVP) ; UNSCREW\r
+ GETYP 0,(AB) ; ANY CONSTRUCTOR\r
+ CAIN 0,TFALSE\r
+ JRST MFINIS ; NO, LEAVE\r
+ AOS D,ARGCNT(P) ; IF NO ARGS\r
+ ACALL D,APPLY ; APPLY IT\r
+\r
+ JRST FINIS\r
+\r
+; HERE TO FINISH IF CONSTRUCTOR WAS #FALSE ()\r
+\r
+MFINIS: POP TP,B\r
+ POP TP,A\r
+ JRST FINIS\r
+\r
+; **GFP** FROM HERE TO THE END\r
+\r
+MFUNCTION MAPLEAVE,SUBR\r
+\r
+ ENTRY\r
+\r
+ CAMGE AB,[-3,,0]\r
+ JRST TMA\r
+ MOVE B,MQUOTE LMAP,[LMAP ]INTRUP \r
+ PUSHJ P,ILVAL\r
+ GETYP 0,A\r
+ CAIE 0,TFRAME ; MAKE SURE WINNER\r
+ JRST NOTM\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ MOVEI B,-1(TP) ; POINT TO FRAME POINTER\r
+ PUSHJ P,CHFSWP\r
+ PUSHJ P,CHUNW\r
+ JUMPL C,MAPL1 ; RET VAL SUPPLIED\r
+ MOVSI A,TATOM\r
+ MOVE B,MQUOTE T\r
+ JRST FINIS\r
+\r
+MAPL1: MOVE A,(C)\r
+ MOVE B,1(C)\r
+ JRST FINIS\r
+\r
+MFUNCTION MAPSTOP,SUBR\r
+\r
+ ENTRY\r
+\r
+ PUSH P,[1]\r
+ JRST MAPREC\r
+\r
+MFUNCTION MAPRET,SUBR\r
+\r
+ ENTRY\r
+\r
+ PUSH P,[0]\r
+MAPREC: MOVE B,MQUOTE LMAP,[LMAP ]INTRUP\r
+ PUSHJ P,ILVAL ; GET VALUE\r
+ GETYP 0,A ; FRAME?\r
+ CAIE 0,TFRAME\r
+ JRST NOTM\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ MOVEI B,-1(TP)\r
+ POP P,0 ; RET/STOP SWITCH\r
+ JUMPN 0,MAPRC1 ; JUMP IF STOP\r
+ PUSHJ P,CHFSWP ; CHECK IT OUT (AND MAYBE SWAP)\r
+ PUSH P,[NLOCR]\r
+ JRST MAPRC2\r
+MAPRC1: PUSHJ P,CHFSWP\r
+ PUSH P,[NLOCR1]\r
+MAPRC2: HRRZ E,SPSAV(B) ; UNBIND BEFORE RETURN\r
+ PUSH TP,$TAB\r
+ PUSH TP,C\r
+ ADDI E,1 ; FUDGE FOR UNBINDER\r
+ PUSHJ P,SSPEC1 ; UNBINDER\r
+ HLRE D,(TP) ; FIND NUMBER\r
+ JUMPE D,MAPRE1 ; SKIP IF NONE TO MOVE\r
+ MOVNS E,D ; AND PLUS IT\r
+ HRLI E,(E) ; COMPUTE NEW TP\r
+ ADD E,TPSAV(B) ; NEW TP\r
+ HRRZ C,TPSAV(B) ; GET OLD TOP\r
+ MOVEM E,TPSAV(B)\r
+ HRL C,(TP) ; AND NEW BOT\r
+ ADDI C,1\r
+ BLT C,(E) ; BRING IT ALL DOWN\r
+MAPRE1: ASH D,-1 ; NO OF ARGS\r
+ HRRI TB,(B) ; PREPARE TO FINIS\r
+ MOVSI A,TFIX\r
+ MOVEI B,(D)\r
+ POP P,0 ; GET PC TO GO TO\r
+ MOVEM 0,PCSAV(TB)\r
+ JRST CONTIN ; BACK TO MAPPER\r
+\r
+NLOCR1: TDZA A,A ; ZER SW\r
+NLOCR: MOVEI A,1\r
+ GETYP 0,(AB) ; CHECK IF BUILDING\r
+ CAIN 0,TFALSE\r
+ JRST FLUSHM ; REMOVE GOODIES\r
+ ADDM B,ARGCNT(P) ; BUMP ARG COUNTER\r
+NLOCR2: JUMPE A,DONEI1\r
+ JRST OUTRLP\r
+\r
+FLUSHM: ASH B,1 ; FLUSH GOODIES DROPPED\r
+ HRLI B,(B)\r
+ SUB TP,B\r
+ JRST NLOCR2\r
+\r
+NOTM: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE NOT-IN-MAP-FUNCTION\r
+ JRST CALER1\r
+\r
+END\r
+\f; THE FOLLOWING INFORMATION IS MEANT AS GUIDE TO THE CARE AND FEEDING\r
+; OF MUDDLE. IT ATTEMPTS TO SPECIFY PROGRAMMING CONVENTIONS AND\r
+; SUPPLY SYMBOLS AND MACROS NEEDED BY ALL MODULES IN A MUDDLE.\r
+\r
+; FOR EFFICIENCY THE STANDARD MODE OF RUNNING IS UNINTERRUPTABLE.\r
+; WITH EXPLICIT CHECKS FOR PENDING INTERRUPTS. THE INTGO MACRO\r
+; PERFORMS THE APPROPRIATE CHECK\r
+\r
+; FOR INTERRUPTS TO WORK IN INTERRUPTABLE CODE, IT MUST\r
+; BE ABSOLUTELY PURE. BETWEEN ANY TWO INSTRUCTIONS OF\r
+; INTERRUPTABLE CODE THERE MAY BE AN INTERUPT IN WHICH\r
+; A COMPACTING GARBAGE COLLECTION MAY OCCUR.\r
+; NOTE: A SCRATCH AC MAY CONTAIN POINTERS TO GC SPACE IN\r
+; INTERRUPTABLE CODE OR DURING AN INTGO IF THE TYPE CODE FOR THAT AC'S\r
+; SLOT IN THE PROCESS VECTOR IS SET TO REFLECT ITS CONTENTS.\r
+\r
+; ALL ATOM POINTERS WILL BE REFERRED TO IN ASSEMBLED CODE BY\r
+; MQUOTE <PNAME> -- FOR NORMAL ATOMS\r
+; EQUOTE <PNAME> -- FOR ERROR COMMENT ATOMS\r
+\r
+; FUNCTION CALLS TO INITIAL FUNCTIONS WILL BE CALLED USING THE FOLLOWING:\r
+\r
+; MCALL N,<PNAME> ;SEE MCALL MACRO\r
+; ACALL AC,<PNAME> ; SEE ACALL MACRO\r
+\r
+; UNLESS PNAME IS NOT A VALID MIDAS SYMBOL, IN WHICH CASE ANOTHER INTERNAL \r
+; NAME WILL BE USED\r
+\r
+; WHEN CALLING A SUBR THROUGH AN INDEX OR INDIRECT, THE UUOS GENERATED\r
+; BY THE MACROS SHOULLD BE USED.\r
+; THESE ARE .MCALL AND .ACALL -- EXAMPLE:\r
+; .ACALL A,@(B)\r
+\r
+\r
+\r
+\r
+\r
+\f; ORGANIZATION OF CORE STORAGE IN THE MUDDLE SYSTEM (ENVIRONMENT)\r
+\r
+; 20: SPECIAL CODE FOR UUO AND INTERUPTS\r
+\r
+;CODBOT: WORD CONTAINING LOCATION OF BOTTOMMOST WORD OF IMPURE CODE\r
+\r
+; --IMPURE CODE--\r
+\r
+;CODTOP: WORD CONTAINING LOCATION OFWORD AFTER LAST WORD OF CODE\r
+\r
+;PARBOT: WORD CONTAINING LOCATION OFBOTTOMMOST LIST\r
+\r
+; --PAIRSS--\r
+\r
+;PARTOP: WORD CONTAINING LOCATION OFWORD AFTER LAST PAIR WORD\r
+\r
+;VECBOT: WORD CONTAINING LOCATION OFFIRST WORD OF VECTORS\r
+\r
+; --VECTORS--\r
+\r
+;VECTOP: WORD CONTAINING LOCATION OFWORD AFTER TOPMOST VECTOR\r
+; THE WORD BEFORE VECTOP IS THE DOPE FOR THE LAST VECTOR\r
+\r
+; --GC MARK PDL (SOMETIMES NOT THERE)--\r
+\r
+;CORTOP: TOP OF LOW-SEGMENT/IMPURE CORE\r
+\r
+;600000: START OF PURE CODE (SHARED ALSO)\r
+\r
+; --PURE CODE--\r
+\r
+;\r
+\r
+\r
+\f; BASIC DATA TYPES PRE-DEFINED IN MUDDLE\r
+\r
+; PRIMITIVE DATA TYPES\r
+; IF T IS A DATA TYPE THEN $T=[T,,0]\r
+\r
+; DATA TYPES ARE ASSIGNED BY THE TYPMAK MACRO IN SOME ARBITRARY ORDER\r
+\r
+\r
+;TLOSE ;ILLEGAL TYPE (USED PRIMARILY FOR ERRORS)\r
+;TFIX ;FIXED POINT\r
+;TFLOAT ;FLOATING POINT\r
+;TCHRS ;WORD OF UP TO 5 ASCII CHARACTERS\r
+;TENTRY ; MARKS BEGINNING OF A FRAME ON TP STACK\r
+;TSUBR ;BUILT IN FUNCTION WITH EVALUATED ARGS\r
+;TFSUBR ;BUILT IN FUNCTION WITH UN-EVALUATED ARGS\r
+;TUNBOU ;TYPE GIVEN TO UNBOUND OR UNASSIGNED ATOM\r
+;TBIND ;MARKS BEGINNING OF BINDING BLOCK ON TP STACK\r
+;TILLEG ;POINTER PREVIOUSLY HERE NOW ILLEGAL\r
+;TTIME ;UNIQUE NUMBER (SEE FLOAD)\r
+;TLIST ;POINTER TO LIST ELEMENT\r
+;TFORM ;POINTER TO LIST ELEMENT BUT USED AS AN EXPRESSION\r
+;TSEG ;SAME AS FORM BUT VALUE IS MUST BE STRUCTURED AND IS USED \r
+; ;AS A SEGMENT\r
+;TEXPR ;POINTER TO LIST ELEMENT BUT USED AS AN INTERPRETIVE FUNCTION\r
+;TFUNAR ;LIKE TEXPR BUT HAS PARTIALLY EVALUATED ARGS\r
+;TLOCL ;LOCATIVE TO LIST ELEMENT (SEE AT,IN AND SETLOC)\r
+;TFALSE ;NOT TRUTH\r
+;TDEFER ;POINTER TO REAL VALUE (ONLY APPEARS AS CAR OF LIST)\r
+;TUVEC ;AOBJN POINTER TO UNIFORM VECTOR\r
+;TOBLS ;AOBJN TO UVEC OF LISTS OF ATOMS. USED AS SYMBOL TABLE\r
+;TVEC ;VECTOR (AOBJN POINTER TO GENERALIZED VECTOR)\r
+;TCHAN ;VECTOR OF INFO DESCRIBING AN I/O CHANNEL\r
+;TLOCV ;LOCATIVE TO GENERAL VECTOR (SEE AT,IN AND SETLOC)\r
+;TTVP ;POINTER TO TRANSFER VECTOR\r
+;TBVL ;BEGINS A VECTOR BINDING ON THE TP STACK\r
+;TTAG ;VECTOR OF INFO SPECIFYING A GENERALIZED TAG\r
+;TPVP ;POINTER TO PROCESS VECTOR\r
+;TLOCI ;POINTER TO ATOM VALUE ON STACK (INTERNAL NOT SEEN BY USER)\r
+;TTP ;POINTER TO MAIN MARKED STACK\r
+;TSP ;POINTER TO CURRENT BINDINGS ON STACK\r
+;TLOCS ;LOCATIVE TO STACK (NOT CURRENTLY USED)\r
+;TPP ;POINTER TO PLANNER PDL (NOT CURRENTLY USED)\r
+;TPLD ;POINTER TO P-STACK (UNMARKED)\r
+;TARGS ;POINTER TO AN ARG BLOCK (HAIRY KLUDGE)\r
+;TAB ;SAVED AB (NOT GIVEN TO USER)\r
+;TTB ;SAVED TB (NOT GIVEN TO USER)\r
+;TFRAME ;USER POINTER TO STACK FRAME\r
+;TCHSTR ;BYTE POINTER TO STRING OF CHARS (COUNT ALSO INCLUDED)\r
+;TATOM ;POINTER TO ATOM\r
+;TLOCD ;USER LOCATIVE TO ATOM VALUE\r
+;TBYTE :POINTER TO ARBITRARY BYTE STRING (NOT CURRENTLY USED)\r
+;TENV ;USER POINTER TO FRAME USED AS AN ENVIRONMENT\r
+;TACT ;USER POINTER TO FRAME FOR A NAMED ACTIVATION\r
+;TASOC ;ASSOCIATION TRIPLE\r
+;TLOCU ;LOCATIVE TO UVECTOR ELEMENT (SEE AT,IN AND SETLOC)\r
+;TLOCS ;LOCATIVE TO A BYTE IN A CHAR STRING (SEE AT,IN AND SETLOC)\r
+;TLOCA ;LOCATIVE TO ELEMENT IN ARG BLOCK\r
+;TENTS ;NOT USED\r
+;TBS ; ""\r
+;TPLDS ; ""\r
+;TPC ; ""\r
+;TINFO ;POINTER TO LIST ELEMENT USED WITH ARG POINTERS\r
+;TNBS ;NOT USED\r
+;TBVLS ;NOT USED\r
+;TCSUBR ;CARE SUBR (USED ONLY WITH CUDDLE SEE -- WJL)\r
+;TWORD ;36-BIT WORD\r
+;TRSUBR ;COMPILED PROGRAM (ACTUALLY A VECTOR POINTER)\r
+;TCODE ;UNIFORM VECTOR OF INSTRUCTIONS\r
+;TCLIST ;NOT USED\r
+;TBITS ;GENERAL BYTE POINTER\r
+;TSTORA ;POINTER TO NON GC IMPURE STUFF\r
+;TPICTU ;E&S CODE IN NON GC SPACE\r
+;TSKIP ;ENVIRONMENT SPLICE\r
+;TLINK ;LEXICAL LINK \r
+;TINTH ;INTERRUPT HEADER\r
+;THAND ;INTERRUPT HANDLER\r
+;TLOCN ;LOCATIVE TO ASSOCIATION\r
+;TDECL ;POINTER TO LIST OF ATOMS AND TYPE DECLARATIONS\r
+;TDISMI ;TYPE MEANING DONT RUN REST OF HANDLERS\r
+;TDCLI ; INTERNAL TYPE FOR SAVED FUNCTION BODY\r
+;TMENT ; POINTER TO MAIN ENTRY OF WHICH THIS IS PART\r
+;TENTER ; NON-MAIN ENTRY TO AN RSUBR\r
+;TSPLICE ; RETURN FROM READ MACRO MEANS SPLICE SUBELEMENTS IN\r
+;TPCODE ; PURE CODE POINTER IN FUNNY FORMAT\r
+;TTYPEW : TYPE WORD\r
+;TTYPEC ; TYPE CODE\r
+;TGATOM ; ATOM WITH GVALUE\r
+;TREADA ; READ ACTIVATION HACK\r
+;TUNWIN ; INTERNAL FOR UNWIND SPEC ON STACK\r
+;TUBIND ; BINDING OF UNSPECIAL ATOM\r
+;TMACRO ; EVAL MACRO\r
+\f\r
+; STORGE ALLOCATION TYPES. ALLOCATED BY AN "IRP" LATER IN THIS FILE\r
+\r
+\r
+;S1WORD ;UNMARKED STUFF OF NO INTEREST TO AGC\r
+;S2WORD ;POINTERS TO ELEMENTS IN PAIR SPACE (LIST, FORM, EXPR ETC.)\r
+;S2DEFR ;DEFERRED LIST VALUES\r
+;SNWORD ;POINTERS TO UNIFORM VECTORS\r
+;S2NWOR ;POINTERS TO GENERAL VECTORS\r
+;STPSTK ;STACK POINTERS\r
+;SPSTK ;UNMARKED STACK POINTERS\r
+;SARGS ;POINTERS TO ARG BLOCKS (USER)\r
+;SABASE ;POINTER TO ARG BLOCK (INTERNAL)\r
+;STBASE ;POINTER TO FRAME (INTERNAL)\r
+;SFRAME ;POINTER TO FRAME (USER)\r
+;SBYTE ;GENERAL BYTE POINTER\r
+;SATOM ;POINTER TO ATOM\r
+;SLOCID ;POINTER TO VALUE CELL OF ATOM\r
+;SPVP ;PROCESS VECTORS\r
+;SCHSTR ;ASCII BYTE POINTER\r
+;SASOC ;POINTER TO ASSOCIATION BLOCK\r
+;SINFO ;LIST CELL CONTAINING EXTRA ARGBLOCK INFO\r
+;SSTORE ;NON GC STORGAGE POINTER\r
+;SLOCA ;ARG BLOCK LOCATIVE\r
+;SLOCD ;USER VALUE CELL LOCATIVE\r
+;SLOCS ;LOCATIVE TO STRING\r
+;SLOCU ;LOCATIVE TO UVECTOR\r
+;SLOCV ;LOCATIVE TO GENERAL VECTOR\r
+;SLOCL ;LOCATIVE TO LIST ELEENT\r
+;SLOCN ;LOCATIVE TO ASSOCIATION\r
+;SGATOM ;REALLY ATOM BUT SPECIAL GC HACK\r
+\r
+;NOTE: TO FIND OUT IF A GIVEN STORAGE ALLOCATION TYPE NEEDS TO BE DEFERRED, REFER TO\r
+;LOCATION "MKTBS:" OFFSET BY THE STORAGE TYPE. IF IT IS <0, THAT SAT NEEDS TO BE DEFERRED.\r
+;\r
+;ONE WAY TO DO THIS IS TO PUT A REAL TYPE CODE IN AC A AND PUHSJ P,NWORDT\r
+; A WILL CONTAIN 1 IF NO DEFERRED NEEDED OR 2 IF DEFER IS NEEDED\r
+\r
+\f; SOME MUDDLE DATA FORMATS\r
+\r
+; FORMAT OF LIST ELEMENT\r
+\r
+; WORD 1: SIGN BIT, RESERVED FOR GARBAGE COLLECTOR\r
+; BITS 1-17 TYPE OF FIRST ELEMENT OF LIST\r
+; BITS 18-35 POINTS TO REST OF LIST (ALWAYS ANOTHER LIST OR 0)\r
+;\r
+; WORD 2: DATUM OF FIRST ELEMENT OF LIST OF TYPE SPECIFIED\r
+;\r
+; IF DATUM REQUIRES 54 BITS TO SPECIFY, TYPE WILL BE "TDEFER" AND\r
+; VALUE WILL BE AN 18 BIT POINTER TO FULL 2 WORD PAIR\r
+\r
+\r
+\r
+;FORMAT OF GENERAL VECTOR (OF N ELEMENTS)\r
+;POINTED INTO BY AOBJN POINTER\r
+;A GENERAL VECTOR HAS FEWER THAN 2^16 ELEMENTS\r
+\r
+\r
+; TYPE<1> TYPE OF FIRST OBJECT (THE RIGHT HALF OF THE TYPE WORD MIGHT BE NONZERO)\r
+; OBJ<1> OBJECT OF SPECIFIED TYPE\r
+; TYPE<2>\r
+; OBJ<2>\r
+; .\r
+; .\r
+; .\r
+; TYPE<N>\r
+; OBJ<N>\r
+; VD(1)-VECTOR DOPE--SIGN-NOT UNIFORM, BITS 1-17 TYPE,,18-35 GROWTH/SHRINKAGE\r
+; VD(2)-VECTOR DOPE--SIGN-G.C.; BITS 1-17 ARE 2*N+1,,18-35 G.C. RELOCATION EITHER UP OR DOWN\r
+\r
+\r
+\f;SPECIAL VECTORS IN THE INITIAL SYSTEM\r
+\r
+;THE SYSTEM KEEPS RELEVANT INFORMATION CONCERNING ALL TYPES\r
+;IN A TYPE VECTOR, TYPVEC, WHICH MAY BE INDEXED BY THE TYPE NUMBER\r
+;FOUND IN THE TYPE FIELD OF ANY GOODIE. TABLES APLTYP AND EVLTYP ALSO EXIST\r
+;THEY SPECIFY HOW DIFFERENT TYPES EVAL AND APPLY.\r
+\r
+;TYPE IN AC A, PUSHJ P,SAT RETURNS STORAGE TYPE IN A\r
+\r
+;TYPE TO NAME OF TYPE TRANSLATION TABLE\r
+\r
+; TATOM,,<STORAGE ALLOCATION TYPE>+CHBIT+TMPLBT\r
+\r
+; ATOMIC NAME\r
+\r
+; CHBIT ON MEANS YOU CANT RANDOMLY CHTYPE INTO THIS TYPE\r
+; TMPLBT ON MEANS A TEMPLATE EXISTS DESCRIBING THIS\r
+\r
+;AN ATOM IS A BLOCK IN VECTOR SPACE WITH THE FOLLOWING FORMAT\r
+\r
+; <TUNBOU OR TLOCI>,,<0 OR BINDID> ; TLOCI MEANS VAL EXISTS.\r
+ ; 0 MEANS GLOBAL\r
+; ; BINDID SPECS ENV IN\r
+ ; WHICH LOCAL VAL EXISTS\r
+; <LOCATIVE TO VALUE OR 0>\r
+; <POINTER TO OBLIST OR 0>\r
+; <ASCII /PNAME/>\r
+; <400000+SATOM,,0>\r
+; <LNTH>,,0 (SIGN BIT FOR G.C. RH FOR G.C. RELOCATION)\r
+\r
+;POINTERS TO INITIAL STRUCTURES AND ATOMS NEEDED BY COMPILED CODE\r
+;WILL BE POINTED TO BY THE TRANSFER VECTOR\r
+;A POINTER TO THIS VECTOR ALWAYS EXISTS IN AC TVP\r
+;THE FORMAT OF THIS VECTOR IS:\r
+\r
+; TYPE,,0\r
+; VALUE\r
+; .\r
+; .\r
+; .\r
+; TV DOPE WORDS\r
+\r
+\r
+;INFORMATION CONCERNING EACH PROCESS IS KEPT IN THE PROCESS VECTOR\r
+;A POINTER TO THE CURRENT PROCESS ALWAYS EXISTS IN AC PVP\r
+;THE FORMAT OF A PROCESS VECTOR IS:\r
+\r
+; TFIX,,0\r
+; PROCID ;UNIQUE ID OF THIS PROCESS\r
+\r
+; 20 ELEMENTS (I.E. 40 WORDS) CONTAINIG SAVED ACS\r
+; CAN BE REFERENCED SYMBOLICALLY USING SYMBOLS\r
+; OF THE FORM AC!STO(PVP)\r
+\r
+; OTHER PROCESS LOCAL INFO LIKE LEXICAL STATE, PROCESS STATE,LAST RESUMER\r
+; .\r
+; .\r
+; .\r
+; PV DOPE WORDS\r
+\r
+\r
+\r
+\r
+;FORMAT OF PUSH DOWN STACKS USED AND CONVENTIONS\r
+\r
+\fIF1 [\r
+PRINTC /MUDDLE - INSERT FILE FOR ALL PROGRAMS\r
+/\r
+]\r
+\r
+IF2 [PRINTC /MUDDLE\r
+/\r
+]\r
+;AC ASSIGNMNETS\r
+\r
+P"=17 ;THE UNMARKED PDL POINTER (USED BY THE OUTSIDE WORLD AND MUDDLE)\r
+R"=16 ;REFERENCE BASE FOR RSUBRS\r
+M"=15 ;CODE BASE FOR RSUBRS\r
+SP"=14 ;SPECIAL PDL (USED BY MUDDLE FOR VARIABLE BINDINGS)(SPECIAL PDL IS PART OF TP)\r
+TP"=13 ;MARKED PDL (USED BY MUDDLE FOR ARGS TO FUNCTIONS \r
+ ;AND MARKED TEMPORARIES)\r
+TB"=12 ;MARKED PDL BASE POINTER AND CURRENT FRAME POINTER \r
+AB"=11 ;ARGUMENT PDL BASE (MARKED)\r
+ ;AB IS AN AOBJN POINTER TO THE ARGUMENTS\r
+TVP"=7 ;TRANSFER VECTOR POINTER\r
+PVP"=6 ;PROCESS VECTOR POINTER\r
+\r
+;THE FOLLOWING ACS ARE 'SCRATCH' FOR MUDDLE\r
+\r
+A"=1 ; A AND B CONTAIN TYPE AND VALUE UPON FUNCTION RETURNS\r
+B"=2\r
+C"=3\r
+D"=4\r
+E"=5\r
+\r
+NIL"=0 ;END OF LIST MARKER\r
+\r
+;MACRO TO DEFINE MAIN IF NOT DEFINED\r
+\r
+IF1 [\r
+DEFINE SYSQ\r
+ ITS==1\r
+ IFE <<<.AFNM1>_-24.>-<SIXBIT / T./>>,ITS==0\r
+ IFN ITS,[PRINTC /ITS VERSION\r
+/]\r
+ IFE ITS,[PRINTC /TENEX VERSION\r
+/]\r
+ \r
+ TERMIN\r
+\r
+DEFINE DEFMAI ARG,\D\r
+ D==.TYPE ARG\r
+ IFE <D-17>,ARG==0\r
+ EXPUNGE D\r
+ TERMIN\r
+]\r
+\r
+DEFMAI MAIN\r
+DEFMAI READER\r
+\r
+IF2,EXPUNGE DEFMAI\r
+\r
+\f;DEFINE TYPES AND $TYPES AND IF MAIN NOT 0, MAKE THE $TYPE WORDS\r
+\r
+\r
+IFN MAIN,NUMPRI==-1\r
+\r
+IF1 [\r
+NUMPRI==-1 ;NUMBER OF PRIMITIVE TYPES\r
+\r
+DEFINE TYPMAK SAT,LIST\r
+IRP A,,[LIST]\r
+NUMPRI==NUMPRI+1\r
+IRP B,,[A]\r
+T!B==NUMPRI\r
+.GLOBAL $!T!B\r
+IFN MAIN,[$!T!B=[T!B,,0]\r
+]\r
+.ISTOP\r
+TERMIN\r
+IFN MAIN,[\r
+RMT [ADDTYP SAT,A\r
+]]\r
+TERMIN\r
+TERMIN\r
+\r
+;MACRO TO ADD STUFF TO TYPE VECTOR\r
+\r
+IFN MAIN,[\r
+DEFINE ADDTYP SAT,TYPE,NAME,CHF,\CH\r
+ IFSE [CHF],CH==0\r
+ IFSN [CHF],CH==CHBIT\r
+ IFSE [NAME]IN,CH==CHBIT\r
+ IFSN [CHF]-1,[\r
+ TATOM,,CH+SAT\r
+ IFSN [NAME],[IFSE [NAME]IN,MQUOTE INTERNAL\r
+ IFSN [NAME]IN,MQUOTE [NAME]\r
+ ]\r
+ IFSE [NAME],MQUOTE TYPE\r
+ ]\r
+ IFSE [CHF]-1,[\r
+ TATOM,,CH+SAT\r
+ IMQUOTE [NAME]\r
+ ]\r
+ TERMIN\r
+]\r
+]\r
+IF2 [IFE MAIN,[DEFINE TYPMAK SAT,LIST\r
+ RMT [EXPUN [LIST]\r
+]\r
+ TERMIN\r
+]\r
+]\r
+\r
+;DEFINE THE STORAGE ALLOCATION TYPES IN THE WORLD\r
+\r
+\r
+NUMSAT==0\r
+GENERAL==400000,,0 ;FLAG FOR BEING A GENERAL VECTOR\r
+\r
+IF1 [\r
+DEFINE PRMACR HACKER\r
+\r
+IRP A,,[1WORD,2WORD,2DEFRD,NWORD,2NWORD,TPSTK,PSTK,ARGS\r
+ABASE,TBASE,FRAME,BYTE,ATOM,LOCID,PVP,CHSTR,ASOC,INFO,STORE\r
+LOCA,LOCD,LOCS,LOCU,LOCV,LOCL,LOCN,GATOM,LOCT]\r
+\r
+HACKER A\r
+\r
+TERMIN\r
+TERMIN\r
+\r
+\r
+\r
+DEFINE DEFINR B\r
+ NUMSAT==NUMSAT+1\r
+ S!B==NUMSAT\r
+ TERMIN\r
+]\r
+\r
+PRMACR DEFINR\r
+\r
+STMPLT==NUMSAT+1\r
+\r
+;MACRO FOR SAVING STUFF TO DO LATER\r
+\r
+.GSSET 4\r
+\r
+DEFINE HERE G00002,G00003\r
+G00002!G00003!TERMIN\r
+\r
+IF1 [\r
+DEFINE RMT A\r
+HERE [DEFINE HERE G00002,G00003\r
+G00002!][A!G00003!TERMIN]\r
+TERMIN\r
+]\r
+\r
+\r
+RMT [EXPUNGE GENERAL,NUMSTA\r
+]\r
+\r
+DEFINE XPUNGR A\r
+ EXPUNGE S!A\r
+ TERMIN\r
+\r
+IFE MAIN,[\r
+RMT [PRMACR XPUNGR\r
+]\r
+]\r
+\r
+C.BUF==1\r
+C.PRIN==2\r
+C.BIN==4\r
+C.OPN==10\r
+C.READ==40\r
+\r
+; FLAG INDICATING VECTOR FOR GCHACK\r
+\r
+.VECT.==40000\r
+\r
+; DEFINE SYMBLOS FOR VARIOUS OBLISTS\r
+\r
+SYSTEM==0 ;MAIN SYSTEM OBLIST\r
+ERRORS==1 ;ERROR COMMENT OBLIST\r
+INTRUP==2 ;INERRUPT OBLIST\r
+MUDDLE==3 ;MUDDLE GLOBAL SYMBOLS (ADDRESSES)\r
+\r
+RMT [EXPUNGE SYSTEM,ERRORS,INTRUP\r
+]\r
+; DEFINE SYMBOLS FOR PROCESS STATES\r
+\r
+RUNABL==1\r
+RESMBL==2\r
+RUNING==3\r
+DEAD==4\r
+BLOCKED==5\r
+\r
+IFE MAIN,[RMT [EXPUNGE RESMBL,RUNABL,RUNING,DEAD,BLOCKED\r
+]\r
+]\f;BUILD THE TYPE CODES AND ADD STUFF TO TYPVEC AND DEFINE $!TYPE)\r
+\r
+IFN MAIN,[RMT [SAVE==.\r
+ LOC TYPVLC\r
+ ]\r
+ ]\r
+\r
+\r
+TYPMAK S1WORD,[[LOSE],FIX,FLOAT,[CHRS,CHARACTER],[ENTRY,IN],[SUBR,,1],[FSUBR,,1]]\r
+TYPMAK S1WORD,[[UNBOUND,,1],[BIND,IN],[ILLEGAL,,1],TIME]\r
+TYPMAK S2WORD,[LIST,FORM,[SEG,SEGMENT],[EXPR,FUNCTION],[FUNARG,CLOSURE]]\r
+TYPMAK SLOCL,[LOCL]\r
+TYPMAK S2WORD,[FALSE]\r
+TYPMAK S2DEFRD,[[DEFER,IN]]\r
+TYPMAK SNWORD,[[UVEC,UVECTOR],[OBLS,OBLIST,-1]]\r
+TYPMAK S2NWORD,[[VEC,VECTOR],[CHAN,CHANNEL,1]]\r
+TYPMAK SLOCV,[LOCV]\r
+TYPMAK S2NWORD,[[TVP,IN],[BVL,IN],[TAG,,1]]\r
+TYPMAK SPVP,[[PVP,PROCESS]]\r
+TYPMAK STPSTK,[[LOCI,IN],[TP,IN],[SP,IN],[LOCS,IN]]\r
+TYPMAK S2WORD,[[MACRO]]\r
+TYPMAK SPSTK,[[PDL,IN]]\r
+TYPMAK SARGS,[[ARGS,TUPLE]]\r
+TYPMAK SABASE,[[AB,IN]]\r
+TYPMAK STBASE,[[TB,IN]]\r
+TYPMAK SFRAME,[FRAME]\r
+TYPMAK SCHSTR,[[CHSTR,STRING]]\r
+TYPMAK SATOM,[ATOM]\r
+TYPMAK SLOCID,[LOCD]\r
+TYPMAK SBYTE,[BYTE]\r
+TYPMAK SFRAME,[[ENV,ENVIRONMENT],[ACT,ACTIVATION,1]]\r
+TYPMAK SASOC,[ASOC]\r
+TYPMAK SLOCU,[LOCU]\r
+TYPMAK SLOCS,[LOCS]\r
+TYPMAK SLOCA,[LOCA]\r
+TYPMAK S1WORD,[[CBLK,IN]]\r
+TYPMAK STMPLT,[[TMPLT,TEMPLATE]]\r
+TYPMAK SLOCT,[LOCT]\r
+ ;THE FOLLOWING TYPES (THROUGH CSUBR) CAN PROBABLY BE RECYCLED\r
+TYPMAK S1WORD,[[PC,IN]]\r
+TYPMAK SINFO,[[INFO,IN]]\r
+TYPMAK SATOM,[[BNDS,IN]]\r
+TYPMAK S2NWORD,[[BVLS,IN]]\r
+TYPMAK S1WORD,[[CSUBR,,1]]\r
+\r
+TYPMAK S1WORD,[[WORD]]\r
+TYPMAK S2NWORD,[[RSUBR,,1]]\r
+TYPMAK SNWORD,[CODE]\r
+ ;TYPE CLIST CAN PROBABLY BE RECYCLED\r
+TYPMAK S2WORD,[[CLIST,IN]]\r
+TYPMAK S1WORD,[[BITS]]\r
+TYPMAK SSTORE,[STORAGE,PICTURE]\r
+TYPMAK STPSTK,[[SKIP,IN]]\r
+TYPMAK SATOM,[[LINK,,1]]\r
+TYPMAK S2NWORD,[[INTH,IHEADER,1],[HAND,HANDLER,1]]\r
+TYPMAK SLOCN,[[LOCN,LOCAS]]\r
+TYPMAK S2WORD,[DECL]\r
+TYPMAK SATOM,[DISMISS]\r
+TYPMAK S2WORD,[[DCLI,IN]]\r
+TYPMAK S2NWORD,[[ENTER,RSUBR-ENTRY,1]]\r
+TYPMAK S2WORD,[SPLICE]\r
+TYPMAK S1WORD,[[PCODE,PCODE,1],[TYPEW,TYPE-W,1],[TYPEC,TYPE-C,1]]\r
+TYPMAK SGATOM,[[GATOM,IN]]\r
+TYPMAK SFRAME,[[READA,,1]]\r
+TYPMAK STBASE,[[UNWIN,IN]]\r
+TYPMAK S1WORD,[[UBIND,IN]]\r
+IFN MAIN,[RMT [LOC SAVE\r
+ ]\r
+ ]\r
+IF2,EXPUNGE TYPMAK,DOTYPS\r
+\f\r
+RMT [EQUALS XP EXPUNGE\r
+IF2,XP STMPLT\r
+]\r
+IF1 [\r
+\r
+DEFINE EXPUN LIST\r
+ IRP A,,[LIST]\r
+ IRP B,,[A]\r
+ EXPUNGE T!B\r
+ .ISTOP\r
+ TERMIN\r
+ TERMIN\r
+ TERMIN\r
+]\r
+\r
+\r
+TYPMSK==17777\r
+MONMSK==TYPMSK#777777\r
+SATMSK==777\r
+CHBIT==1000\r
+TMPLBT==2000\r
+\r
+IF1 [\r
+DEFINE GETYP AC,ADR\r
+ LDB AC,[221500,,ADR]\r
+ TERMIN\r
+\r
+DEFINE GETYPF AC,ADR\r
+ LDB AC,[003700,,ADR]\r
+ TERMIN\r
+\r
+DEFINE MONITO\r
+ .WRMON==200000\r
+ .RDMON==100000\r
+ .EXMON== 40000\r
+ .GLOBAL .MONWR,.MONRD,.MONEX\r
+ RMT [IF2 IFE MAIN, XP .WRMON,.RDMON,.EXMON\r
+]\r
+ TERMIN\r
+]\r
+\r
+IFN MAIN,MONITO\r
+\r
+IFE MAIN,[RMT [XP SATMSK,TYPMSK,MONMSK,CHBIT\r
+]\r
+]\r
+\f;MUDDLE WIDE GLOBALS\r
+\r
+;DEFINE ENTRIES IN PROCESS VECTOR AS BEING GLOBAL\r
+\r
+IF1 [\r
+IRP A,,[0,A,B,C,D,E,PVP,TVP,TP,TB,AB,P,PB,SP,M,R]\r
+.GLOBAL A!STO\r
+TERMIN\r
+\r
+.GLOBAL CALER1,FINIS,VECTOP,VECBOT,INTFLG\r
+\r
+;GLOBALS FOR MACROS IN VECTOR AND PAIR SPACE\r
+\r
+.GLOBAL VECLOC,PARLOC,TVBASE,TVLOC,PVLOC,PVBASE,SQUTBL,SQULOC\r
+.GLOBAL PARTOP,CODTOP,HITOP,HIBOT,SPECBIND,LCKINT\r
+.GLOBAL GETWNA,WNA,TFA,TMA,WRONGT,WTYP,WTYP1,WTYP2,WTYP3,CALER,CALER1\r
+]\r
+\r
+\r
+;STORAGE ALLOCATIN SPECIFICATION GLOBALS\r
+\r
+NSUBRS==600. ; ESTIMATE OF # OF SUBRS IN WOLD\r
+TPLNT"==2000 ;TEMP PDL LENGTHH\r
+GSPLNT==2000 ;INITIAL GLOBAL SP\r
+GCPLNT"==100. ;GARBAGE COLLECTOR'S PDL LENGTH\r
+PVLNT"==100 ;LENGTH OF INITIAL PROCESS VECTOR\r
+TVLNT"==6000 ;MAX TRANSFER VECTOR\r
+ITPLNT"==100 ;TP FOR GC\r
+PLNT"==1000 ;PDL FOR USER PROCESS\r
+\r
+;LOCATIONS OF VARIOUS STORAGE AREAS\r
+\r
+PARBASE"==32000 ;START OF PAIR SPACE\r
+VECBASE"==44000 ;START OF VECTOR SPACE\r
+IFN MAIN,[PARLOC"==PARBASE\r
+VECLOC"==VECBASE\r
+]\r
+\f\r
+;INITIAL MACROS\r
+\r
+;SYMBLOS ASSOCIATED WITH STACK FRAMES\r
+;TB POINTS TO CURRENT FRAME, THE SYMBOLS BELOW ARE OFFSETS ON TB\r
+\r
+FRAMLN==7 ;LENGTH OF A FRAME\r
+FSAV==-7 ;POINT TO CALLED FUNCTION\r
+OTBSAV==-6 ;POINT TO PREVIOUS FRAME AND CONTAINS TIME\r
+ABSAV==-5 ;ARGUMENT POINTER\r
+SPSAV==-4 ;BINDING POINTER\r
+PSAV==-3 ;SAVED P-STACK\r
+TPSAV==-2 ;TOP OF STACK POINTER\r
+PCSAV==-1 ;PCWORD\r
+\r
+RMT [EXPUNGE FRAMLN\r
+]\r
+IFE MAIN,[RMT [EXPUNGE PCSAV TPSAV SPSAV PSAV ABSAV FSAV OTBSAV \r
+]\r
+]\r
+\r
+;CALL MACRO\r
+; ARGS ARE PUSHED ON THE STACK AS TYPE VALUE PAIRS\r
+\r
+.GLOBAL .MCALL,.ACALL,FINIS,CONTIN,.ECALL,FATINS\r
+\r
+; CALL WITH AN ASSEMBLE TIME KNOWN NUMBER OF ARGUMENTS\r
+\r
+IF1 [\r
+DEFINE MCALL N,F\r
+ .GLOBAL F\r
+ IFGE <17-N>,.MCALL N,F\r
+ IFL <17-N>,[PRINTC /LOSSAGE AT MCALL - TOO MANY ARGS\r
+/\r
+ .MCALL F\r
+ ]\r
+ TERMIN\r
+\r
+; CALL WITH RUN TIME KNOWN NUMBER OF ARGS IN AC SPECIFIED BY N\r
+\r
+DEFINE ACALL N,F\r
+ .GLOBAL F\r
+ .ACALL N,F\r
+ TERMIN\r
+\r
+; STANDARD SUBROUTINE RETURN\r
+\r
+; JRST FINIS\r
+\r
+; ARGUMENTS WILL NO LONGER BE ON THE STACK WHEN RETURN HAS HAPPENED\r
+; VALUE SHOULD BE IN A AND B\r
+\r
+;CHECK THAT THE ENTRY POINT WAS CALLED WITH N ARGUMENTS\r
+\r
+DEFINE ENTRY N\r
+ IFSN N,,[\r
+ HLRZ A,AB\r
+ CAIE A,-2*N\r
+ JSP E,GETWNA]\r
+TERMIN\r
+\f\r
+\r
+; MACROS ASSOCIATED WIT INTERRUPT PROCESSING\r
+;INTERRUPT IF THERE IS A WAITING INTERRUPT\r
+\r
+DEFINE INTGO\r
+ SKIPGE INTFLG\r
+ JSR LCKINT\r
+TERMIN\r
+\r
+;TO BECOME INTERRUPTABLE\r
+\r
+DEFINE ENABLE\r
+ AOSN INTFLG\r
+ JSR LCKINT\r
+TERMIN\r
+\r
+;TO BECOME UNITERRUPTABLE\r
+\r
+DEFINE DISABLE\r
+ SETZM INTFLG\r
+TERMIN\r
+]\r
+\fIF1 [\r
+;MACRO TO BUILD TYPE DISPATCH TABLES EASILY\r
+\r
+DEFINE TBLDIS NAME,DEFAULT,LIST,LNTH\r
+\r
+NAME:\r
+ REPEAT LNTH+1,DEFAULT\r
+ IRP A,,[LIST]\r
+ IRP TYPE,LOCN,[A]\r
+ LOC NAME+TYPE\r
+ LOCN\r
+ .ISTOP\r
+ TERMIN\r
+ TERMIN\r
+ LOC NAME+LNTH+1\r
+TERMIN\r
+\r
+; DISPATCH FOR NUMPRI GOODIES\r
+\r
+DEFINE DISTBL NAME,DEFAULT,LIST\r
+ TBLDIS NAME,DEFAULT,[LIST]NUMPRI\r
+ TERMIN\r
+\r
+DEFINE DISTBS NAME,DEFAULT,LIST\r
+ TBLDIS NAME,DEFAULT,[LIST]NUMSAT\r
+ TERMIN\r
+\r
+]\r
+\f\r
+\r
+VECFLG==0\r
+PARFLG==0\r
+\r
+;MACROS FOR INITIIAL MUDDLE LIST STRUCTURE\r
+\r
+;CHAR STRING MAKER, RETURNS POINTER AND TYPE\r
+\r
+IF1 [\r
+DEFINE MACHAR NAME,TYPE,VAL,\LNT,WHERE,LAST\r
+ TYPE==TCHSTR\r
+ VECTGO WHERE\r
+ LNT==.LENGTH \NAME!\\r
+ ASCII \NAME!\\r
+ LAST==$."\r
+ TCHRS,,0\r
+ $."-WHERE+1,,0\r
+ VAL==LNT,,WHERE\r
+ VECRET\r
+\r
+TERMIN\r
+;MACRO TO DEFINE ATOMS\r
+\r
+DEFINE MAKAT NAME,TYAT,VALU,OBLIS,REFER,LOCN,\TVENT,FIRST\r
+ FIRST==.\r
+ TYAT,,OBLIS\r
+ VALU\r
+ 0\r
+ ASCII \NAME!\\r
+ 400000+SATOM,,0\r
+ .-FIRST+1,,0\r
+ TVENT==FIRST-.+2,,FIRST\r
+ IFSN [LOCN],LOCN==TVENT\r
+ ADDTV TATOM,TVENT,REFER\r
+ TERMIN\r
+\r
+\r
+\r
+\f;MACROS TO SWITCH BACK AND FORTH INTO AND OUT OF VECTOR AND PAIR SPACE\r
+;GENERAL SWITCHER\r
+\r
+DEFINE LOCSET LOCN,RETNAM,NEWLOC,OTHLOC,F1,F2,TOPWRD,\SAVE,SAVEF1,SAVEF2,NEW\r
+\r
+ IFE F1,[SAVE==.\r
+ LOC NEWLOC\r
+ SAVEF2==F2\r
+ IFN F2,OTHLOC==SAVE\r
+ F2==0\r
+ DEFINE RETNAM\r
+ F1==F1-1\r
+ IFE F1,[NEWLOC==.\r
+ F2==SAVEF2\r
+ LOC TOPWRD\r
+ NEWLOC\r
+ LOC SAVE\r
+ ]\r
+ TERMIN\r
+ ]\r
+\r
+ IFN F1,[F1==F1+1\r
+ ]\r
+\r
+ IFSN LOCN,,LOCN==.\r
+ IFE F1,F1==1\r
+\r
+TERMIN\r
+\r
+\r
+DEFINE VECTGO LOCN\r
+ LOCSET LOCN,VECRET,VECLOC,PARLOC,VECFLG,PARFLG,VECTOP\r
+ TERMIN\r
+\r
+DEFINE PARGO LOCN\r
+ LOCSET LOCN,PARRET,PARLOC,VECLOC,PARFLG,VECFLG,PARTOP\r
+ TERMIN\r
+\r
+DEFINE ADDSQU NAME,\SAVE\r
+ SAVE==.\r
+ LOC SQULOC\r
+ SQUOZE 0,NAME\r
+ NAME\r
+ SQULOC==.\r
+ LOC SAVE\r
+ TERMIN\r
+\r
+DEFINE ADDTV TYPE,GOODIE,REFER,\SAVE\r
+ SAVE==.\r
+ LOC TVLOC\r
+ TVOFF==.-TVBASE+1\r
+ TYPE,,REFER\r
+ GOODIE\r
+ TVLOC==.\r
+ LOC SAVE\r
+ TERMIN\r
+\r
+;MACRO TO ADD TO PROCESS VECTOR\r
+\r
+DEFINE ADDPV TYPE,GOODIE,OFFS,\SAVE\r
+ SAVE==.\r
+ LOC PVLOC\r
+ PVOFF==.-PVBASE\r
+ IFSN OFFS,,OFFS==PVOFF\r
+ TYPE,,0\r
+ GOODIE\r
+ PVLOC==.\r
+ LOC SAVE\r
+ TERMIN\r
+\r
+\r
+\r
+\r
+\f\r
+;MACRO TO DEFINE A FUNCTION ATOM\r
+\r
+DEFINE MFUNCTION NAME,TYPE,PNAME\r
+ (TVP)\r
+NAME":\r
+ VECTGO DUMMY1\r
+ ADDSQU NAME\r
+ IFSE [PNAME],MAKAT NAME,T!TYPE,NAME,SYSTEM,<NAME-1>\r
+ IFSN [PNAME],MAKAT [PNAME]T!TYPE,NAME,SYSTEM,<NAME-1>\r
+ VECRET\r
+ TERMIN\r
+\r
+; VERSION OF MQUOTE WITH IMPURE BIT ON\r
+\r
+DEFINE IMQUOTE ARG,PNAME,OBLIS,\LOCN\r
+ (TVP)\r
+\r
+ LOCN==.-1\r
+ VECTGO DUMMY1\r
+ IFSE [PNAME],MAKAT [ARG]<400000+TUNBOU>,0,OBLIS,LOCN\r
+\r
+ IFSN [PNAME],MAKAT [PNAME]<400000+TUNBOU>,0,OBLIS,LOCN\r
+ VECRET\r
+ TERMIN\r
+\r
+;MACRO TO DEFINE QUOTED GOODIE\r
+\r
+DEFINE MQUOTE ARG,PNAME,OBLIS,\LOCN\r
+ (TVP)\r
+\r
+ LOCN==.-1\r
+ VECTGO DUMMY1\r
+ IFSE [PNAME],MAKAT [ARG]TUNBOU,0,OBLIS,LOCN\r
+ IFSN [PNAME],MAKAT [PNAME]TUNBOU,0,OBLIS,LOCN\r
+ VECRET\r
+ TERMIN\r
+\r
+\r
+\r
+\r
+DEFINE CHQUOTE NAME,\LOCN,TYP,VAL\r
+ (TVP)\r
+ LOCN==.-1\r
+ MACHAR [NAME]TYP,VAL\r
+ ADDTV TYP,VAL,LOCN\r
+\r
+ TERMIN\r
+\r
+\r
+; SPECIAL ERROR MQUOTE\r
+\r
+DEFINE EQUOTE ARG,PNAME\r
+ MQUOTE ARG,[PNAME]ERRORS TERMIN\r
+\r
+\r
+; MACRO DO .CALL UUOS\r
+\r
+DEFINE DOTCAL NM,LIST,\LOCN\r
+ .CALL LOCN\r
+ RMT [LOCN==.\r
+ SETZ\r
+ SIXBIT /NM/\r
+ IRP Q,R,[LIST]\r
+ IFSN [R][][Q\r
+ ]\r
+\r
+ IFSE [R][][<SETZ>\<Q>\r
+ ]\r
+ TERMIN\r
+ ]\r
+TERMIN\r
+\r
+; MACRO TO HANDLE FATAL ERRORS\r
+\r
+DEFINE FATAL MSG/\r
+ FATINS [ASCIZ /:\e FATAL ERROR MSG \e\r
+/]\r
+ TERMIN\r
+]\r
+\f\r
+CHRWD==5\r
+\r
+IFN READER,[\r
+NCHARS==177\r
+;CHARACTER TABLE GENERATING MACROS\r
+\r
+DEFINE SETSYM WRDL,BYTL,COD\r
+ WRD!WRDL==<WRD!WRDL>&<MSK!BYTL>\r
+ WRD!WRDL==<WRD!WRDL>\<<COD&177>_<<4-BYTL>*7+1>>\r
+ TERMIN\r
+\r
+DEFINE INIWRD N,INIT\r
+ WRD!N==INIT\r
+ TERMIN\r
+\r
+DEFINE OUTWRD N\r
+ WRD!N\r
+ TERMIN\r
+\r
+;MACRO TO KILL THESE SYMBOLS LATER\r
+\r
+DEFINE KILLWD N\r
+ EXPUNGE WRD!N\r
+ TERMIN\r
+DEFINE SETMSK N\r
+ MSK!N==<177_<<4-N>*7+1>>#<-1>\r
+ TERMIN\r
+\r
+;MACRO TO KILL MASKS LATER\r
+\r
+DEFINE KILMSK N\r
+ EXPUNGE MSK!N\r
+ TERMIN\r
+\r
+NWRDS==<NCHARS+CHRWD-1>/CHRWD\r
+\r
+REPEAT CHRWD,SETMSK \.RPCNT\r
+\r
+REPEAT NWRDS,INIWRD \.RPCNT,004020100402\r
+\r
+DEFINE OUTTBL\r
+ REPEAT NWRDS,OUTWRD \.RPCNT\r
+ TERMIN\r
+\r
+\r
+;MACRO TO GENERATE THE DUMMIES EASLILIER\r
+\r
+DEFINE INITCH \DUM1,DUM2,DUM3\r
+\r
+\r
+DEFINE SETCOD COD,LIST\r
+ IRP CHAR,,[LIST]\r
+ DUM1==CHAR/5\r
+ DUM2==CHAR-DUM1*5\r
+ SETSYM \DUM1,\DUM2,COD\r
+ TERMIN\r
+ TERMIN\r
+\r
+DEFINE SETCHR COD,LIST\r
+ IRPC CHAR,,[LIST]\r
+ DUM3=="CHAR\r
+ DUM1==DUM3/5\r
+ DUM2==DUM3-DUM1*5\r
+ SETSYM \DUM1,\DUM2,COD\r
+ TERMIN\r
+ TERMIN\r
+\r
+DEFINE INCRCO OCOD,LIST\r
+ IRP CHAR,,[LIST]\r
+ DUM1==CHAR/5\r
+ DUM2==CHAR-DUM1*5\r
+ SETSYM \DUM1,\DUM2,\<OCOD+.IRPCN>\r
+ TERMIN\r
+ TERMIN\r
+\r
+DEFINE INCRCH OCOD,LIST\r
+ IRPC CHAR,,[LIST]\r
+ DUM3=="CHAR\r
+ DUM1==DUM3/5\r
+ DUM2==DUM3-DUM1*5\r
+ SETSYM \DUM1,\DUM2,\<OCOD+.IRPCN>\r
+ TERMIN\r
+ TERMIN\r
+ RMT [EXPUNGE DUM1,DUM2,DUM3\r
+ REPEAT NWRDS,KILLWD \.RPCNT\r
+ REPEAT CHRWD,KILMSK \.RPCNT\r
+]\r
+\r
+TERMIN\r
+\r
+INITCH\r
+]\r
+\f\r
+;REDEFINE END DO ALL THE REMOTES (ON LAST PASS ONLY)\r
+\r
+EQUALS E.END END\r
+\r
+DEFINE END ARG\r
+ EQUALS END E.END\r
+ CONSTANTS\r
+\r
+ IMPURE\r
+ VARIABLES\r
+ PURE\r
+ HERE\r
+ .LNKOT\r
+ IF2 GEXPUN\r
+ CONSTANTS\r
+ IMPURE\r
+ VARIABLES\r
+ CODEND==.\r
+ LOC CODTOP\r
+ CODEND\r
+ LOC CODEND\r
+ PURE\r
+ CODEND==.\r
+ LOC HITOP\r
+ CODEND\r
+ LOC CODEND\r
+ IF2 EXPUNGE PARFLG,VECFLG,CHRWD,NN,NUMPRI,PURITY,EAD,ACD,PUSHED\r
+ IF2 EXPUNGE INSTNT,DUMMY1,PRIM,PPLNT,GSPLNT,MEDIAT\r
+ END ARG\r
+ TERMIN\r
+\r
+\r
+;MACROS TO PRINT VERSIONS OF PROGRAMS DURING ASSEMBLY\r
+\r
+IF1 [\r
+DEFINE NUMGEN SYM,\REST,N\r
+ NN==NN-1\r
+ N==<SYM_-30.>&77\r
+ REST==<SYM_6>\r
+ IFN N,IFGE <31-N>,IFGE <N-20>,TOTAL==TOTAL*10.+<N-20>\r
+ IFN NN,NUMGEN REST\r
+ EXPUNGE N,REST\r
+ TERMIN\r
+\r
+DEFINE VERSIO N\r
+ PRINTC /VERSION = N\r
+/\r
+ TERMIN\r
+]\r
+\r
+TOTAL==0\r
+NN==7\r
+\r
+NUMGEN .FNAM2\r
+\r
+IF1 [\r
+RADIX 10.\r
+\r
+VERSIO \TOTAL\r
+\r
+RADIX 8\r
+PROGVN==TOTAL\r
+\r
+\r
+DEFINE VATOM SYM,\LOCN,TV,A,B\r
+ VECTGO\r
+ LOCN==.\r
+ TFIX,,MUDDLE\r
+ PROGVN\r
+ 0\r
+ A==<<<<SYM_-30.>&77>+40>_29.>\r
+ B==<<SYM_-24.>&77>\r
+ IFN B,A==A+<<B+40>_22.>\r
+ B==<<SYM_-18.>&77>\r
+ IFN B,A==A+<<B+40>_15.>\r
+ B==<<SYM_-12.>&77>\r
+ IFN B,A==A+<<B+40>_8.>\r
+ B==<<SYM_-6.>&77>\r
+ IFN B,A==A+<<B+40>_1.>\r
+ A\r
+ IFN <SYM&77>,<<SYM&77>+40>_29.\r
+ 400000+SATOM,,\r
+ .-LOCN+1,,0\r
+ TV==LOCN-.+2,,LOCN\r
+ ADDTV TATOM,TV,0\r
+ VECRET\r
+ TERMIN\r
+\r
+;VATOM .FNAM1 ;"HACK REMOVED FOR EFFICIENCY"\r
+\r
+\r
+;MACRO TO REMMVE SYMBOLS OF THE FORM "GXXXXX"\r
+\r
+DEFINE GEXPUN \SYM\r
+ NN==7\r
+ TOTAL==0\r
+ NUMGEN \<SIXBIT /SYM!/>\r
+ RADIX 10.\r
+ .GSSET 0\r
+ REPEAT TOTAL,XXP\r
+ RADIX 8\r
+TERMIN\r
+\r
+DEFINE XXP \A\r
+ EXPUNGE A\r
+ TERMIN\r
+\r
+\r
+DEFINE ..LOC NEW,OLD\r
+ .LIFS .LPUR"+.LIMPU"\r
+ OLD!"==$."\r
+ LOC NEW!"\r
+ .ELDC\r
+ .LIFS -.LPUR"\r
+ LOC $."\r
+ .ELDC\r
+ .LIFS -.LIMPU\r
+ LOC $."\r
+ .ELDC\r
+ TERMIN\r
+\r
+\r
+; PURE - MACRO TO SWITCH LOADING TO PURE CORE.\r
+\r
+DEFINE PURE\r
+ IFE PURITY-1, ..LOC .LPUR,.LIMPU\r
+ PURITY==0\r
+ TERMIN\r
+\r
+; IMPURE - MACRO TO SWITCH LOADING TO IMPURE CORE.\r
+\r
+DEFINE IMPURE\r
+ IFE PURITY, ..LOC .LIMPU,.LPUR\r
+ PURITY==1\r
+ TERMIN\r
+]\r
+PURITY==0\r
+\f\f\r
+TITLE MUDEX -- TENEX DEPENDANT MUDDLE CODE\r
+\r
+RELOCATABLE\r
+\r
+.INSRT MUDDLE >\r
+.INSRT STENEX >\r
+\r
+MFORK==400000\r
+\r
+MONITS==1\r
+\r
+.GLOBAL %SSNAM,%RSNAM,%KILLM,%LOGOU,%SLEEP,%VALRE,NOTTY,MSGTYP,TTYOP2\r
+.GLOBAL %UNAM,%JNAM,%RUNAM,%RJNAM,%GCJOB,%SHWND,%SHFNT,%GETIP,%INFMP\r
+.GLOBAL GCHN,WNDP,FRNP,MESSAG,INITFL,6TOCHS,SGSNAM,MTYO,PGINT,WHOAMI\r
+.GLOBAL %TOPLQ,IBLOCK,TMTNXS,TNXSTR,%HANG,ILLUUO,UUOH,IPCINI,CTIME,BFLOAT\r
+.GLOBAL GCRSET\r
+\r
+GCHN==0\r
+WRTP==1000,,100000\r
+GCHI==1000,,GCHN\r
+CRJB==1000,,400001\r
+FME==1000,,-1\r
+FLS==1000,,\r
+\r
+CTIME: JOBTM ; get run time in milli secs\r
+ MOVE B,A\r
+ JSP A,BFLOAT ; Convert to floating\r
+ FDVRI B,(1000.0) ; Change to units of seconds\r
+ MOVSI A,TFLOAT\r
+ POPJ P,\r
+\r
+; SET THE SNAME GLOBALLY\r
+\r
+%SSNAM: POPJ P,\r
+\r
+; READ THE GLOBAL SNAME\r
+\r
+%RSNAM: POPJ P,\r
+\r
+; KILL THE CURRENT JOB\r
+\r
+%KILLM: HALTF\r
+ POPJ P,\r
+\r
+; PASS STRING TO SUPERIOR (MONITOR?)\r
+\r
+%VALRE: HALTF\r
+ POPJ P,\r
+\r
+; LOGOUT OF SYSTEM (MUST BE "TOP LEVEL")\r
+\r
+%LOGOU: LGOUT\r
+ POPJ P,\r
+\r
+; GO TO SLEEP A WHILE\r
+\r
+%SLEEP: IMULI A,33. ; TO MILLI SECS\r
+ DISMS\r
+ POPJ P,\r
+\r
+; HANG FOR EVER\r
+\r
+%HANG: WAIT\r
+\r
+; READ JNAME\r
+\r
+%RJNAM: POPJ P,\r
+\r
+; READ UNAME\r
+\r
+%RUNAM: POPJ P,\r
+\r
+; HERE TO SEE IF WE ARE A TOP LEVEL JOB\r
+\r
+%TOPLQ: GJINF\r
+ SKIPGE D\r
+ AOS (P)\r
+ POPJ P,\r
+\r
+; GET AN INFERIOR FOR THE GARBAGE COLLECTOR\r
+\r
+%GCJOB: PUSH P,A\r
+ MOVEI A,200000 ; GET BITS FOR FORK\r
+ CFORK ; MAKE AN IFERIOR FORK\r
+ FATAL CANT GET GC FORK\r
+ MOVEM A,GCFRK ; SAVE HANDLE\r
+ POP P,A ; RESTORE PAGE\r
+ PUSHJ P,%GETIP ; GET IT THERE\r
+ PUSHJ P,%SHWND\r
+ JRST %SHFNT ; AND FRONTIER\r
+\r
+; HERE TO GET A PAGE FOR THE INFERIOR\r
+\r
+%GETIP: POPJ P,\r
+\r
+; HERE TO SHARE WINDOW\r
+\r
+%SHWND: TDZA 0,0 ; FLAG SAYING WINDOW\r
+\r
+; HERE TO SHARE FRONTIER\r
+\r
+%SHFNT: MOVEI 0,1\r
+ PUSH P,A\r
+ PUSH P,B\r
+ PUSH P,C\r
+ MOVEI B,2*FRNP ; FRONTIER (REMEMBER TENEX PAGE SIZE)\r
+ SKIPN 0\r
+ MOVEI B,2*WNDP ; NO,WINDOW\r
+ HRLI B,MFORK\r
+ ASH A,1 ; TIMES 2\r
+ HRL A,GCFRK\r
+ MOVSI C,140000 ; READ AND WRITE ACCESS\r
+\r
+ PMAP\r
+ ADDI A,1\r
+ ADDI B,1\r
+ PMAP\r
+ ASH B,9. ; POINT TO PAGE\r
+ MOVES (B) ; CLOBBER TOP\r
+ MOVES -1(B) ; AND UNDER\r
+ POP P,C\r
+ POP P,B\r
+ POP P,A\r
+ POPJ P,\r
+\r
+; HERE TO MAP INFERIOR BACK AND KILL SAME\r
+\r
+%INFMP: PUSH P,C\r
+ PUSH P,D\r
+ PUSH P,E\r
+ ASH A,1\r
+ ASH B,1\r
+ MOVE D,A ; POINT TO PAGES\r
+ MOVE E,B ; FOR COPYING\r
+ PUSH P,A ; SAVE FOR TOUCHING\r
+ MOVS A,GCFRK\r
+ MOVSI B,MFORK\r
+ MOVSI C,120400 ; READ AND WRITE COPY\r
+\r
+LP1: HRRI A,(E)\r
+ HRRI B,(D)\r
+ PMAP\r
+ ADDI E,1\r
+ AOBJN D,LP1\r
+\r
+; HERE TO TOUCH PAGES TO INSURE KEEPING THEM (KLUDGE)\r
+\r
+ POP P,E ; RESTORE MY FIRST PAGE #\r
+ MOVEI A,(E) ; COPY FOR LOOP\r
+ ASH A,9. ; TO WORD ADDR\r
+ MOVES (A) ; WRITE IT\r
+ AOBJN E,.-3 ; FOR ALL PAGES\r
+\r
+ MOVE A,GCFRK\r
+ KFORK\r
+ POP P,E\r
+ POP P,D\r
+ POP P,C\r
+ POPJ P,\r
+\r
+; HACK TO PRINT MESSAGE OF INTEREST TO USER\r
+\r
+MESOUT: MOVSI A,(JFCL)\r
+ MOVEM A,MESSAG ; DO ONLY ONCE\r
+ MOVEI A,400000\r
+ MOVE B,[1,,ILLUUO]\r
+ MOVE C,[40,,UUOH]\r
+ SCVEC\r
+ SETZ SP, ; HACK TO AVOID LOSSAGE WITH GARBAGE IN SP FIRST TIME\r
+ PUSHJ P,GCRSET\r
+ PUSHJ P,PGINT ; INITIALIZE PAGE MAP\r
+ RESET\r
+ PUSHJ P,TTYOP2\r
+ SKIPE NOTTY ; HAVE A TTY?\r
+ JRST RESNM ; NO, SKIP THIS STUFF\r
+\r
+ MOVEI A,MESBLK\r
+ MOVEI B,0\r
+ GTJFN\r
+ JRST RESNM\r
+ MOVE B,[70000,,200000]\r
+ OPENF\r
+ JRST RESNM\r
+\r
+MSLP: BIN\r
+ MOVE D,B ; SAVE BYTE\r
+ GTSTS\r
+ TLNE B,1000\r
+ JRST RESNM\r
+ EXCH D,A\r
+ CAIN A,14\r
+ PBOUT\r
+ MOVE A,D\r
+ JRST MSLP\r
+\r
+RESNM2: CLOSF\r
+ JFCL\r
+\r
+RESNM:\r
+RESNM1: POPJ P,\r
+\r
+MESBLK: 100000,,\r
+ 377777,,377777\r
+ -1,,[ASCIZ /DSK/]\r
+ -1,,[ASCIZ /VEZZA/]\r
+ -1,,[ASCIZ /MUDDLE/]\r
+ -1,,[ASCIZ /MESSAG/]\r
+ 0\r
+ 0\r
+ 0\r
+\r
+MUDINT: MOVSI 0,(JFCL) ; CLOBBER MUDDLE INIT SWITCH\r
+ MOVEM 0,INITFL\r
+\r
+ GJINF ; GET INFO NEEDED\r
+ PUSHJ P,TMTNXS ; MAKE A TEMP STRING FOR TENEX INFO (POINTER LEFT IN E)\r
+ HRROI A,1(E) ; TNX STRING POINTER\r
+ DIRST\r
+ FATAL ATTACHED DIR DOES NOT EXIST\r
+ MOVEI B,1(E) ; NOW HAVE BOUNDS OF STRING\r
+ SUBM P,E ; RELATIVIZE E\r
+ PUSHJ P,TNXSTR ; MAKE THE STRING\r
+ SUB P,E\r
+ PUSH TP,$TATOM\r
+ PUSH TP,IMQUOTE SNM\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ MCALL 2,SETG\r
+ PUSH TP,$TCHSTR\r
+ PUSH TP,CHQUOTE READ\r
+ PUSH TP,$TCHSTR\r
+ PUSH TP,CHQUOTE MUDDLE.INIT\r
+ MCALL 2,FOPEN\r
+ GETYP A,A\r
+ CAIE A,TCHAN\r
+ POPJ P,\r
+ PUSH TP,$TCHAN\r
+ PUSH TP,B\r
+ MOVEI B,INITSTR ; TELL USER WHAT'S HAPPENING\r
+ SKIPE WHOAMI\r
+ JRST .+3\r
+ SKIPN NOTTY\r
+ PUSHJ P,MSGTYP\r
+ MCALL 1,MLOAD\r
+ POPJ P,\r
+\r
+TMTNXS: POP P,D ; SAVE RET ADDR\r
+ MOVE E,P ; BUILD A STRING SPACE ON PSTACK\r
+ MOVEI 0,20. ; USE 20 WORDS (=100 CHARS)\r
+ PUSH P,[0]\r
+ SOJG 0,.-1\r
+\r
+ JRST (D)\r
+\r
+\r
+TNXSTR: SUBI B,(P)\r
+ PUSH P,B\r
+ ADDI B,-1(P)\r
+ SUBI B,(A) ; WORDS TO B\r
+ IMULI B,5 ; TO CHARS\r
+ LDB 0,[360600,,A] ; GET BYTE POSITION\r
+ IDIVI 0,7 ; TO A REAL BYTE POSITION\r
+ MOVNS 0\r
+ ADDI 0,5\r
+ SUBM 0,B ; FINAL LENGTH IN BYTES TO B\r
+ PUSH P,B ; SAVE IT\r
+ MOVEI A,4(B) ; TO WORDS\r
+ IDIVI A,5\r
+ PUSHJ P,IBLOCK ; GET STRING\r
+ POP P,A\r
+ POP P,C\r
+ ADDI C,(P)\r
+ MOVE D,B ; COPY POINTER\r
+ MOVE 0,(C) ; GET A WORD\r
+ MOVEM 0,(D)\r
+ ADDI C,1\r
+ AOBJN D,.-3\r
+\r
+ HRLI A,TCHSTR\r
+ HRLI B,440700 ; MAKE INTO BYTER\r
+ POPJ P,\r
+\r
+IPCINI: JFCL\r
+IFN MONITS,[\r
+\r
+DEMS: SETZ\r
+ SIXBIT /DEMSIG/\r
+ SETZ [SIXBIT /MUDSTA/]\r
+]\r
+INITSTR: ASCIZ /MUDDLE INIT/\r
+\r
+IMPURE\r
+\r
+GCFRK: 0\r
+\r
+IFN MONITS,[\r
+MESSDM: 30,,(SIXBIT /IPC/)\r
+ .+1\r
+ SIXBIT /MUDDLESTATIS/\r
+ 1\r
+ 1\r
+]\r
+\r
+MESSAG: PUSHJ P,MESOUT ; MESSAGE SWITCH\r
+\r
+INITFL: PUSHJ P,MUDINT ; MUDDLE INIT SWITCH\r
+\r
+PURE\r
+\r
+END\r
+\f\r
+TITLE SQUOZE TABLE HANDLER FOR MUDDLE\r
+\r
+RELOCATABLE\r
+\r
+.INSRT MUDDLE >\r
+\r
+.GLOBAL SQUPNT,ATOSQ,SQUTOA\r
+\r
+; POINTER TO TABLE FILLED IN BY INITM\r
+\r
+SQUPNT: 0\r
+\r
+; GIVEN LOCN OF SUBR RET SQUO NAME ARG AND VAL IN E\r
+\r
+ATOSQ: PUSH P,B\r
+ PUSH P,A\r
+ MOVE A,SQUPNT ; GET TABLE POINTER\r
+ MOVE B,[2,,2]\r
+ CAMN E,1(A)\r
+ JRST ATOSQ1\r
+ ADD A,B\r
+ JUMPL A,.-3\r
+POPABJ: POP P,B\r
+ POP P,A\r
+ POPJ P,\r
+\r
+ATOSQ1: MOVE E,(A)\r
+ AOS -2(P)\r
+ JRST POPABJ\r
+\r
+; BINARY SEARCH FOR SQUOZE SYMBOL ARG IN E\r
+\r
+SQUTOA: PUSH P,A\r
+ PUSH P,B\r
+ PUSH P,C\r
+\r
+ MOVE A,SQUPNT ; POINTER TO TABLE\r
+ HLRE B,SQUPNT\r
+ MOVNS B\r
+ HRLI B,(B) ; B IS CURRENT OFFSET\r
+\r
+UP: ASH B,-1 ; HALVE TABLE\r
+ AND B,[-2,,-2] ; FORCE DIVIS BY 2\r
+ MOVE C,A ; COPY POINTER\r
+ JUMPLE B,LSTHLV ; CANT GET SMALLER\r
+ ADD C,B\r
+ CAMLE E,(C) ; SKIP IF EITHER FOUND OR IN TOP\r
+ MOVE A,C ; POINT TO SECOND HALF\r
+ CAMN E,(C) ; SKIP IF NOT FOUND\r
+ JRST WON\r
+ CAML E,(C) ; SKIP IF IN TOP HALF\r
+ JRST UP\r
+ HLLZS C ; FIX UP OINTER\r
+ SUB A,C\r
+ JRST UP\r
+\r
+WON: MOVE E,1(C) ; RET VAL IN E\r
+ AOS -3(P) ; SKIP RET\r
+WON1: POP P,C\r
+ POP P,B\r
+ POP P,A\r
+ POPJ P,\r
+\r
+LSTHLV: CAMN E,(C) ; LINEAR SERCH REST\r
+ JRST WON\r
+ ADD C,[2,,2]\r
+ JUMPL C,.-3\r
+ JRST WON1 ; ALL GONE, LOSE\r
+\r
+END\r
+\f\r
+TITLE MODIFIED AFREE FOR MUDDLE\r
+\r
+RELOCATABLE\r
+\r
+.INSRT MUDDLE >\r
+\r
+.GLOBAL CAFREE,CAFRET,PARNEW,AGC,PARBOT,CODTOP,CAFRE1\r
+.GLOBAL STOGC,STOSTR,CAFRE,ISTOST,STOLST,SAT,ICONS,BYTDOP\r
+.GLOBAL FLIST,STORIC\r
+MFUNCTION FREEZE,SUBR\r
+\r
+ ENTRY 1\r
+\r
+ GETYP A,(AB) ; get type of it\r
+ PUSH TP,(AB) ; save a copy\r
+ PUSH TP,1(AB)\r
+ PUSH P,[0] ; flag for tupel freeze\r
+ PUSHJ P,SAT ; to SAT\r
+ MOVEI B,0 ; final type\r
+ CAIN A,SNWORD ; check valid types\r
+ MOVSI B,TUVEC ; use UVECTOR\r
+ CAIN A,S2NWOR\r
+ MOVSI B,TVEC\r
+ CAIN A,SARGS\r
+ MOVSI B,TVEC\r
+ CAIN A,SCHSTR\r
+ MOVSI B,TCHSTR\r
+ JUMPE B,WTYP1\r
+ PUSH P,B ; save final type\r
+ CAME B,$TCHSTR ; special chars hack\r
+ JRST OK.FR\r
+ HRR B,(AB) ; fixup count\r
+ MOVEM B,(P)\r
+\r
+ MOVEI C,(TB) ; point to it\r
+ PUSHJ P,BYTDOP ; A==> points to dope word\r
+ HRRO B,1(TB)\r
+ SUBI A,1(B) ; A==> length of block\r
+ TLC B,-1(A)\r
+ MOVEM B,1(TB) ; and save\r
+ MOVSI 0,TUVEC\r
+ MOVEM 0,(TB)\r
+\r
+OK.FR: HLRE A,1(TB) ; get length\r
+ MOVNS A\r
+ PUSH P,A\r
+ ADDI A,2\r
+ PUSHJ P,CAFREE ; get storage\r
+ HRLZ B,1(TB) ; set up to BLT\r
+ HRRI B,(A)\r
+ POP P,C\r
+ ADDI C,(A) ; compute end\r
+ BLT B,(C)\r
+ MOVEI B,(A)\r
+ HLL B,1(AB)\r
+ POP P,A\r
+ JRST FINIS\r
+\r
+ \r
+CAFRE: PUSH P,A\r
+ HRRZ E,STOLST+1(TVP)\r
+ SETZB C,D\r
+ PUSHJ P,ICONS ; get list element\r
+ PUSH TP,$TLIST ; and save\r
+ PUSH TP,B\r
+ MOVE A,(P) ; restore length\r
+ ADDI A,2 ; 2 more for dope words\r
+ PUSHJ P,CAFREE ; get the core and dope words\r
+ POP P,B ; restore count\r
+ MOVNS B ; build AOBJN pointer\r
+ MOVSI B,(B)\r
+ HRRI B,(A)\r
+ MOVE C,(TP)\r
+ MOVEM B,1(C) ; save on list\r
+ MOVSI 0,TSTORA ; and type\r
+ HLLM 0,(C)\r
+ HRRZM C,STOLST+1(TVP) ; and save as new list\r
+ SUB TP,[2,,2]\r
+ POPJ P,\r
+ \r
+CAFRE1: PUSH P,A\r
+ ADDI A,2\r
+ PUSHJ P,CAFREE\r
+ HRROI B,(A) ; pointer to B\r
+ POP P,A ; length back\r
+ TLC B,-1(A)\r
+ POPJ P,\r
+\r
+CAFREE: IRP AC,,[B,C,D,E]\r
+ PUSH P,AC\r
+ TERMIN\r
+ SKIPG A ; make sure arg is a winner\r
+ FATAL BAD CALL TO CAFREE\r
+ MOVSI A,(A) ; count to left half for search\r
+ MOVEI B,FLIST ; get first pointer\r
+ HRRZ C,(B) ; c points to next block\r
+CLOOP: CAMG A,(C) ; skip if not big enough\r
+ JRST CONLIS ; found one\r
+ MOVEI D,(B) ; save in case fall out\r
+ MOVEI B,(C) ; point to new previous\r
+ HRRZ C,(C) ; next block\r
+ JUMPN C,CLOOP ; go on through loop\r
+ HLRZ E,A ; count to E\r
+ CAMGE E,STORIC ; skip if a area or more\r
+ MOVE E,STORIC ; else use a whole area\r
+ MOVE C,PARBOT ; foun out if any funny space\r
+ SUB C,CODTOP ; amount around to C\r
+ CAMLE C,E ; skip if must GC\r
+ JRST CHAVIT ; already have it\r
+ SUBI E,-1(C) ; get needed from agc\r
+ MOVEM E,PARNEW ; funny arg to AGC\r
+ PUSH P,A\r
+ MOVE C,[7,,6] ; SET UP AGC INDICATORS\r
+ PUSHJ P,AGC ; collect that garbage\r
+ SETZM PARNEW ; dont do it again\r
+ AOJL A,GCLOS ; couldn't get core\r
+ POP P,A\r
+\r
+; Make sure pointers still good after GC\r
+\r
+ MOVEI D,FLIST\r
+ HRRZ B,(D)\r
+\r
+ HRRZ E,(B) ; next pointer\r
+ JUMPE E,.+4 ; end of list ok\r
+ MOVEI D,(B)\r
+ MOVEI B,(E)\r
+ JRST .-4 ; look at next\r
+\r
+CHAVIT: MOVE E,PARBOT ; find amount obtained\r
+ SUBI E,1 ; dont use a real pair\r
+ MOVEI C,(E) ; for reset of CODTOP\r
+ SUB E,CODTOP\r
+ EXCH C,CODTOP ; store it back\r
+ CAIE B,(C) ; did we simply grow the last block?\r
+ JRST CSPLIC ; no, splice it in\r
+ HLRZ C,(B) ; length of old guy\r
+ ADDI C,(E) ; total length\r
+ ADDI B,(E) ; point to new last dope word\r
+ HRLZM C,(B) ; clobber final length in\r
+ HRRM B,(D) ; and splice into free list\r
+ MOVEI C,(B) ; reset acs for reentry into loop\r
+ MOVEI B,(D)\r
+ JRST CLOOP\r
+\r
+; Here to splice new core onto end of list.\r
+\r
+CSPLIC: MOVE C,CODTOP ; point to end of new block\r
+ HRLZM E,(C) ; store length of new block in dope words\r
+ HRRM C,(D) ; D is old previous, link it up\r
+ MOVEI B,(D) ; and reset B for reentry into loop\r
+ JRST CLOOP\r
+\r
+; here if an appropriate block is on the list\r
+\r
+CONLIS: HLRZS A ; count back to a rh\r
+ HLRZ D,(C) ; length of proposed block to D\r
+ CAIN A,(D) ; skip if they are different\r
+ JRST CEASY ; just splice it out\r
+ MOVEI B,(C) ; point to block to be chopped up\r
+ SUBI B,-1(D) ; point to beginning of same\r
+ SUBI D,(A) ; amount of block to be left to D\r
+ HRLM D,(C) ; and fix up dope words\r
+ ADDI B,-1(A) ; point to end of same\r
+ HRLZM A,(B)\r
+ HRRM B,(B) ; for GC benefit\r
+\r
+CFREET: CAIE A,1 ; if more than 1\r
+ SETZM -1(B) ; make tasteful dope worda\r
+ SUBI B,-1(A)\r
+ MOVEI A,(B)\r
+ IRP AC,,[E,D,C,B]\r
+ POP P,AC\r
+ TERMIN\r
+ POPJ P,\r
+\r
+CEASY: MOVEI D,(C) ; point to block to return\r
+ HRRZ C,(C) ; point to next of same\r
+ HRRM C,(B) ; smash its previous\r
+ MOVEI B,(D) ; point to block with B\r
+ HRRM B,(B) ; for GC benefit\r
+ JRST CFREET\r
+\r
+GCLOS: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE NO-MORE-STORAGE\r
+ JRST CALER1\r
+\r
+CAFRET: HRROI B,(B) ; prepare to search list\r
+ TLC B,-1(A) ; by making an AOBJN pointer\r
+ HRRZ C,STOLST+1(TVP) ; start of list\r
+ MOVEI D,STOLST+1(TVP)\r
+\r
+CAFRTL: JUMPE C,CPOPJ ; not founc\r
+ CAME B,1(C) ; this it?\r
+ JRST CAFRT1\r
+ HRRZ C,(C) ; yes splice it out\r
+ HRRM C,(D) ; smash it\r
+CPOPJ: POPJ P, ; dont do anything now\r
+\r
+CAFRT1: MOVEI D,(C)\r
+ HRRZ C,(C)\r
+ JRST CAFRTL\r
+\r
+; Here from GC to collect all unused blocks into free list\r
+\r
+STOGC: SETZB C,E ; zero current length and pointer\r
+ MOVE A,CODTOP ; get high end of free space\r
+\r
+STOGCL: CAIG A,STOSTR ; end?\r
+ JRST STOGCE ; yes, cleanup and leave\r
+\r
+ HLRZ 0,(A) ; get length\r
+ ANDI 0,377777\r
+ SKIPGE (A) ; skip if a not used block\r
+ JRST STOGC1 ; jump if marked\r
+\r
+ JUMPE C,STOGC3 ; jump if no block under construction\r
+ ADD C,0 ; else add this length to current\r
+ JRST STOGC4\r
+\r
+STOGC3: MOVEI B,(A) ; save pointer\r
+ MOVE C,0 ; init length\r
+\r
+STOGC4: SUB A,0 ; point to next block\r
+ JRST STOGCL\r
+\r
+STOGC1: ANDCAM D,(A) ; kill mark bit\r
+ JUMPE C,STOGC4 ; if no block under cons, dont fix\r
+ HRLM C,(B) ; store total block length\r
+ HRRM E,(B) ; next pointer hooked in\r
+ MOVEI E,(B) ; new next pointer\r
+ MOVEI C,0\r
+ JRST STOGC4\r
+\r
+STOGCE: JUMPE C,STGCE1 ; jump if no current block\r
+ HRLM C,(B) ; smash in count\r
+ HRRM E,(B) ; smash in next pointer\r
+ MOVEI E,(B) ; and setup E\r
+\r
+STGCE1: HRRZM E,FLIST+1 ; final link up\r
+ POPJ P,\r
+\r
+IMPURE\r
+\r
+FLIST: .+1\r
+ ISTOST\r
+\r
+PURE\r
+\r
+END\r
+\f\r
+TITLE FLOATB--CONVERT FLOATING NUMBER TO ASCII STRING\r
+\r
+RELOCA\r
+\r
+.GLOBAL FLOATB\r
+\r
+ACNUM==1\r
+\r
+IRP A,,[A,B,C,D,E,F,G,H,I,J]\r
+A==ACNUM\r
+ACNUM==ACNUM+1\r
+TERMIN\r
+\r
+P==17\r
+\r
+TEM1==I\r
+\r
+EXPUNGE ACNUM\r
+\r
+FLOATB: PUSH P,B\r
+ PUSH P,C\r
+ PUSH P,D\r
+ PUSH P,F\r
+ PUSH P,G\r
+ PUSH P,H\r
+ PUSH P,I\r
+ PUSH P,0\r
+ PUSH P,J\r
+ MOVSI 0,440700 ; BUILD BYTEPNTR\r
+ HLRZ J,A ; POINT TO BUFFER\r
+ HRRI 0,1(J)\r
+ MOVE A,(A) ; GET NUMBER\r
+ MOVE D,A\r
+ SETZM (J) ; Clear counter\r
+ PUSHJ P,NFLOT\r
+ POP P,J\r
+ POP P,0\r
+ POP P,I\r
+ POP P,H\r
+ POP P,G\r
+ POP P,F\r
+ POP P,D\r
+ POP P,C\r
+ POP P,B\r
+ POPJ P,\r
+\r
+; at this point we enter code abstracted from DDT.\r
+NFLOT: JUMPG A,TFL1\r
+ JUMPE A,FP1A\r
+ MOVNS A\r
+ PUSH P,A\r
+ MOVEI A,"-\r
+ PUSHJ P,CHRO\r
+ POP P,A\r
+ TLZE A,400000\r
+ JRST FP1A\r
+\r
+TFL1: MOVEI B,0\r
+TFLX: CAMGE A,FT01\r
+ JRST FP4\r
+ CAML A,FT8\r
+ AOJA B,FP4\r
+FP1A:\r
+FP3: SETZB C,TEM1 ; CLEAR DIGIT CNTR, C TO RECEIVE FRACTION\r
+ MULI A,400\r
+ ASHC B,-243(A)\r
+ MOVE A,B\r
+ PUSHJ P,FP7\r
+ PUSH P,A\r
+ MOVEI A,".\r
+ PUSHJ P,CHRO\r
+ POP P,A\r
+ MOVNI A,10\r
+ ADD A,TEM1\r
+ MOVE E,C\r
+FP3A: MOVE D,E\r
+ MULI D,12\r
+ PUSHJ P,FP7B\r
+ SKIPE E\r
+ AOJL A,FP3A\r
+ POPJ P, ; ONE return from OFLT here\r
+\r
+FP4: MOVNI C,6\r
+ MOVEI F,0\r
+FP4A: ADDI F,1(F)\r
+ XCT FCP(B)\r
+ SOSA F\r
+ FMPR A,@FCP+1(B)\r
+ AOJN C,FP4A\r
+ PUSH P,EXPSGN(B)\r
+ PUSHJ P,FP3\r
+ PUSH P,A\r
+ MOVEI A,"E\r
+ PUSHJ P,CHRO\r
+ POP P,A\r
+ POP P,D\r
+ PUSHJ P,FDIGIT\r
+ MOVE A,F\r
+\r
+FP7: SKIPE A ; AVOID AOSING TEM1, NOT SIGNIFICANT DIGIT\r
+ AOS TEM1\r
+ IDIVI A,12\r
+ HRLM B,(P)\r
+ JUMPE A,FP7A1\r
+ PUSHJ P,FP7\r
+\r
+FP7A1: HLRZ D,(P)\r
+FP7B: ADDI D,"0\r
+\r
+; type digit\r
+FDIGIT: PUSH P,A\r
+ MOVE A,D\r
+ PUSHJ P,CHRO\r
+ POP P,A\r
+ POPJ P,\r
+\r
+CHRO: AOS (J) ; COUNT CHAR\r
+ IDPB A,0 ; STUFF CHAR\r
+ POPJ P,\r
+\r
+; constants\r
+ 1.0^32.\r
+ 1.0^16.\r
+FT8: 1.0^8\r
+ 1.0^4\r
+ 1.0^2\r
+ 1.0^1\r
+FT: 1.0^0\r
+ 1.0^-32.\r
+ 1.0^-16.\r
+ 1.0^-8\r
+ 1.0^-4\r
+ 1.0^-2\r
+FT01: 1.0^-1\r
+FT0=FT01+1\r
+\r
+; instructions\r
+FCP: CAMLE A, FT0(C)\r
+ CAMGE A, FT(C)\r
+ 0, FT0(C)\r
+\r
+EXPSGN: "-\r
+ "+\r
+\r
+\r
+EXPUNGE A,B,C,D,E,F,G,H,I,J,TEM1,P\r
+\r
+END\r
+\fTITLE PRIMITIVE FUNCTIONS FOR THE MUDDLE SYSTEM\r
+\r
+RELOCATABLE\r
+\r
+.INSRT MUDDLE >\r
+\r
+.GLOBAL TMA,TFA,CELL,IBLOCK,IBLOK1,ICELL2,VECTOP\r
+.GLOBAL NWORDT,CHARGS,CHFRM,CHLOCI,IFALSE,IPUTP,IGETP,BYTDOP\r
+.GLOBAL OUTRNG,IGETLO,CHFRAM,ISTRUC,TYPVEC,SAT,CHKAB,VAL,CELL2,MONCH,MONCH0\r
+.GLOBAL RMONCH,RMONC0,LOCQ,LOCQQ,SMON,PURERR,APLQ,NAPT,TYPSEG,NXTLM\r
+.GLOBAL MAKACT,ILLCHO,COMPER,CEMPTY,CIAT,CIEQUA,CILEGQ,CILNQ,CILNT,CIN,CINTH,CIREST\r
+.GLOBAL CISTRU,CSETLO,CIPUT,CIGET,CIGETL,CIMEMQ,CIMEMB,CIMON,CITOP,CIBACK\r
+.GLOBAL IGET,IGETL,IPUT,CIGETP,CIGTPR,CINEQU,IEQUAL,TD.LNT,TD.GET,TD.PUT,TD.PTY\r
+.GLOBAL TMPLNT,ISTRCM\r
+\r
+; BUILD DISPATCH TABLE FOR PRIMITIVE FUNCTIONS USAGE\r
+\r
+PRMTYP:\r
+\r
+REPEAT NUMSAT,[0] ;INITIALIZE TABLE TO ZEROES\r
+\r
+IRP A,,[2WORD,2NWORD,NWORD,ARGS,CHSTR,BYTE]\r
+\r
+LOC PRMTYP+S!A\r
+P!A==.IRPCN+1\r
+P!A\r
+\r
+TERMIN\r
+\r
+PTMPLT==PBYTE+1\r
+\r
+; FUDGE FOR STRUCTURE LOCATIVES\r
+\r
+IRP A,,[[LOCL,2WORD],[LOCV,2NWORD],[LOCU,NWORD],[LOCS,CHSTR],[LOCA,ARGS]\r
+[LOCT,TMPLT]]\r
+ IRP B,C,[A]\r
+ LOC PRMTYP+S!B\r
+ P!B==P!C,,0\r
+ P!B\r
+ .ISTOP\r
+ TERMIN\r
+TERMIN\r
+\r
+LOC PRMTYP+SSTORE ;SPECIAL HACK FOR AFREE STORAGE\r
+PNWORD\r
+\r
+LOC PRMTYP+NUMSAT+1\r
+\r
+PNUM==PTMPLT+1\r
+\r
+; MACRO TO BUILD PRIMITIVE DISPATCH TABLES\r
+\r
+DEFINE PRDISP NAME,DEFAULT,LIST\r
+ TBLDIS NAME,DEFAULT,[LIST]PNUM\r
+ TERMIN\r
+\r
+\r
+; SUBROUTINE TO RETURN PRIMITIVE TYPE AND PRINT ERROR IF ILLEGAL\r
+\r
+PTYPE: GETYP A,(B) ;CALLE D WITH B POINTING TO PAIR\r
+ CAIN A,TILLEG ;LOSE IF ILLEGAL\r
+ JRST ILLCHOS\r
+\r
+ PUSHJ P,SAT ;GET STORAGE ALLOC TYPE\r
+ CAIE A,SLOCA\r
+ CAIN A,SARGS ;SPECIAL HAIR FOR ARGS\r
+ PUSHJ P,CHARGS\r
+ CAIN A,SFRAME\r
+ PUSHJ P,CHFRM\r
+ CAIN A,SLOCID\r
+ PUSHJ P,CHLOCI\r
+PTYP1: MOVEI 0,(A) ; ALSO RETURN PRIMTYPE\r
+ CAILE A,NUMSAT ; SKIP IF NOT TEMPLATE\r
+ SKIPA A,[PTMPLT]\r
+ MOVE A,PRMTYP(A) ;GET PRIM TYPE,\r
+ POPJ P,\r
+\r
+; COMPILERS CALL TO ABOVE (LESS CHECKING)\r
+\r
+CPTYPE: PUSHJ P,SAT\r
+ MOVEI 0,(A)\r
+ CAILE A,NUMSAT\r
+ SKIPA A,[PTMPLT]\r
+ MOVE A,PRMTYP(A)\r
+ POPJ P,\r
+\r
+\r
+MFUNCTION SUBSTRUC,SUBR\r
+\r
+ ENTRY\r
+ JUMPGE AB,TFA ;need at least one arg\r
+ CAMGE AB,[-10,,0] ;NO MORE THEN 4\r
+ JRST TMA\r
+ MOVE B,AB\r
+ PUSHJ P,PTYPE ;get primtype in A\r
+ PUSH P,A\r
+ JRST @TYTBL(A)\r
+\r
+RESSUB: CAMLE AB,[-2,,0] ;if only one arg skip rest\r
+ JRST @COPYTB(A)\r
+ HLRZ B,(AB)2 ;GET TYPE\r
+ CAIE B,TFIX ;IF FIX OK\r
+ JRST WRONGT\r
+ MOVE B,(AB)1 ;ptr to object of resting\r
+ MOVE C,(AB)3 ;# of times to rest\r
+ MOVEI E,(A)\r
+ MOVE A,(AB)\r
+ PUSHJ P,@MRSTBL(E)\r
+ PUSH TP,A ;type\r
+ PUSH TP,B ;put rested sturc on stack\r
+ JRST ALOCOK\r
+\r
+PRDISP TYTBL,IWTYP1,[[P2WORD,RESSUB],[P2NWORD,RESSUB]\r
+[PNWORD,RESSUB],[PCHSTR,RESSUB]]\r
+\r
+PRDISP MRSTBL,IWTYP1,[[P2WORD,LREST],[P2NWORD,VREST]\r
+[PNWORD,UREST],[PCHSTR,SREST]]\r
+\r
+PRDISP COPYTB,IWTYP1,[[P2WORD,CPYLST],[P2NWORD,CPYVEC]\r
+[PNWORD,CPYUVC],[PCHSTR,CPYSTR]]\r
+\r
+PRDISP ALOCTB,IWTYP1,[[P2WORD,ALLIST],[P2NWORD,ALVEC]\r
+[PNWORD,ALUVEC],[PCHSTR,ALSTR]]\r
+\r
+ALOCFX: MOVE B,(TP) ;missing 3rd arg aloc for "rest" of struc\r
+ MOVE C,-1(TP)\r
+ MOVE A,(P)\r
+ PUSH P,[377777,,-1]\r
+ PUSHJ P,@LENTBL(A) ;get length of rested struc\r
+ SUB P,[1,,1]\r
+ POP P,C\r
+ MOVE A,B ;# of elements needed\r
+ JRST @ALOCTB(C)\r
+\r
+ALOCOK: CAML AB,[-4,,0] ;exactly 3 args\r
+ JRST ALOCFX\r
+ HLRZ C,(AB)4\r
+ CAIE C,TFIX ;OK IF TYPE FIX\r
+ JRST WRONGT\r
+ POP P,C ;C HAS PRIMTYYPE\r
+ MOVE A,(AB)5 ;# of elements needed\r
+ JRST @ALOCTB(C) ;DO ALLOCATION\r
+\r
+\r
+CPYVEC: HLRE A,(AB)1 ;USE WHEN ONLY ONE ARG\r
+ MOVNS A\r
+ ASH A,-1 ;# OF ELEMENTS FOR ALLOCATION\r
+ PUSH TP,(AB)\r
+ PUSH TP,(AB)1\r
+\r
+ALVEC: PUSH P,A \r
+ ASH A,1\r
+ HRLI A,(A)\r
+ ADD A,(TP)\r
+ CAIL A,-1 ;CHK FOR OUT OF RANGE\r
+ JRST OUTRNG\r
+ CAMGE AB,[-6,,] ; SKIP IF WE GET VECTOR\r
+ JRST ALVEC2 ; USER SUPPLIED VECTOR\r
+ MOVE A,(P)\r
+ PUSHJ P,IBLOK1\r
+ALVEC1: MOVE A,(P) ;# OF WORDS TO ALLOCATE\r
+ MOVE C,B ; SAVE VECTOR POINTER\r
+ ASH A,1 ;TIMES 2\r
+ HRLI A,(A)\r
+ ADD A,B ;PTING TO FIRST DOPE WORD -ALLOCATED \r
+ CAIL A,-1\r
+ JRST OUTRNG\r
+ SUBI A,1 ;ptr to last element of the block\r
+ HRL B,(TP) ;bleft-ptr to source , b right -ptr to allocated space\r
+ BLT B,(A)\r
+ MOVE B,C\r
+ POP P,A\r
+ SUB TP,[2,,2]\r
+ MOVSI A,TVEC\r
+ JRST FINIS\r
+\r
+ALVEC2: GETYP 0,6(AB) ; CHECK IT IS A VECTOR\r
+ CAIE 0,TVEC\r
+ JRST WTYP\r
+ HLRE A,7(AB) ; CHECK SIZE\r
+ MOVNS A\r
+ ASH A,-1 ; # OF ELEMENTS\r
+ CAMGE A,(P) ; SKIP IF BIG ENOUGH\r
+ JRST OUTRNG\r
+ MOVE B,7(AB) ; WINNER, JOIN COMMON CODE\r
+ JRST ALVEC1\r
+\r
+CPYUVC: HLRE A,(AB)1 ;# OF ELEMENTS FOR ALLOCATION\r
+ MOVNS A\r
+ PUSH TP,(AB)\r
+ PUSH TP,1(AB)\r
+\r
+ALUVEC: PUSH P,A\r
+ HRLI A,(A)\r
+ ADD A,(TP) ;PTING TO DOPE WORD OF ORIG VEC\r
+ CAIL A,-1\r
+ JRST OUTRNG\r
+ CAMGE AB,[-6,,] ; SKIP IF WE SUPPLY UVECTOR\r
+ JRST ALUVE2\r
+ MOVE A,(P)\r
+ PUSHJ P,IBLOCK\r
+ALUVE1: MOVE A,(P) ;# of owrds to allocate\r
+ HRLI A,(A)\r
+ ADD A,B ;LOCATION O FIRST ALLOCATED DOPE WORD\r
+ HLR D,(AB)1 ;# OF ELEMENTS IN UVECTOR\r
+ MOVNS D\r
+ ADD D,(AB)1 ;LOCATION OF FIRST DOPE WORD FOR SOURCE\r
+ GETYP E,(D) ;GET UTYPE\r
+ CAML AB,[-6,,] ; SKIP IF USER SUPPLIED OUTPUT UVECTOR\r
+ HRLM E,(A) ;DUMP UTYPE INTO DOPE WORD OF ALLOC UVEC\r
+ CAMGE AB,[-6,,]\r
+ CAIN 0,(E) ; 0 HAS USER UVEC UTYPE\r
+ JRST .+2\r
+ JRST WRNGUT\r
+ CAIL A,-1\r
+ JRST OUTRNG\r
+ MOVE C,B ; SAVE POINTER TO FINAL GUY\r
+ HRL C,(TP) ;Bleft- ptr to source, Bright-ptr to allocated space\r
+ BLT C,-1(A)\r
+ POP P,A\r
+ MOVSI A,TUVEC\r
+ JRST FINIS\r
+\r
+ALUVE2: GETYP 0,6(AB) ; CHECK IT IS A VECTOR\r
+ CAIE 0,TUVEC\r
+ JRST WTYP\r
+ HLRE A,7(AB) ; CHECK SIZE\r
+ MOVNS A\r
+ CAMGE A,(P) ; SKIP IF BIG ENOUGH\r
+ JRST OUTRNG\r
+ MOVE B,7(AB) ; WINNER, JOIN COMMON CODE\r
+ HLRE A,B\r
+ SUBM B,A\r
+ GETYP 0,(A) ; GET UTYPE OF USER UVECTOR\r
+ JRST ALUVE1\r
+\r
+CPYSTR: HRR A,(AB) ;#OF CHAR TO COPY\r
+ PUSH TP,(AB) ;ALSTR EXPECTS STRING IN TP\r
+ PUSH TP,1(AB)\r
+\r
+ALSTR: PUSH P,A\r
+ HRRZ 0,-1(TP) ;0 IS LENGTH OFF VECTOR\r
+ CAIGE 0,(A)\r
+ JRST OUTRNG\r
+ CAMGE AB,[-6,,] ; SKIP IF WE SUPPLY STRING\r
+ JRST ALSTR2\r
+ ADDI A,4\r
+ IDIVI A,5\r
+ PUSHJ P,IBLOCK ;ALLOCATE SPACE\r
+ HRLI B,440700\r
+ MOVE A,(P) ; # OF CHARS TO A\r
+ALSTR1: PUSH P,B ;BYTE PTR TO ALOC SPACE\r
+ POP TP,C ;PTR TO ORIGINAL STR\r
+ POP TP,D ;USELESS\r
+COPYST: ILDB D,C ;GET NEW CHAR\r
+ IDPB D,B ;DEPOSIT CHAR\r
+ SOJG A,COPYST ;FINISH TRANSFER?\r
+\r
+CLOSTR: POP P,B ;BYTE PTR TO COPY\r
+ POP P,A ;# FO ELEMENTS\r
+ HRLI A,TCHSTR\r
+ JRST FINIS\r
+\r
+ALSTR2: GETYP 0,6(AB) ; CHECK IT IS A VECTOR\r
+ CAIE 0,TCHSTR\r
+ JRST WTYP\r
+ HRRZ A,6(AB)\r
+ CAMGE A,(P) ; SKIP IF BIG ENOUGH\r
+ JRST OUTRNG\r
+ EXCH A,(P)\r
+ MOVE B,7(AB) ; WINNER, JOIN COMMON CODE\r
+ JRST ALSTR1\r
+\r
+CPYLST: SKIPN 1(AB)\r
+ JRST ZEROLT\r
+ PUSHJ P,CELL2\r
+ POP P,C\r
+ HRLI C,TLIST ;TP JUNK FOR GAR. COLLECTOR\r
+ PUSH TP,C ;TYPE\r
+ PUSH TP,B ;VALUE -PTR TO NEW LIST\r
+ PUSH TP,C ;TYPE\r
+ MOVE C,1(AB) ;PTR TO FIRST ELEMENT OF ORIG. LIST\r
+REPLST: MOVE D,(C)\r
+ MOVE E,1(C) ;GET LIST ELEMENT INTO ALOC SPACE\r
+ HLLM D,(B)\r
+ MOVEM E,1(B) ;PUT INTO ALLOCATED SPACE\r
+ HRRZ C,(C) ;UPDATE PTR\r
+ JUMPE C,CLOSWL ;END OF LIST?\r
+ PUSH TP,B\r
+ PUSHJ P,CELL2\r
+ POP TP,D\r
+ HRRM B,(D) ;LINK ALLOCATED LIST CELLS\r
+ JRST REPLST\r
+\r
+CLOSWL: POP TP,B ;USELESS\r
+ POP TP,B ;PTR TO NEW LIST\r
+ POP TP,A ;TYPE\r
+ JRST FINIS\r
+\r
+\r
+\r
+ALLIST: CAMGE AB,[-6,,] ; SKIP IF WE BUILD THE LIST\r
+ JRST CPYLS2\r
+ JUMPE A,ZEROLT\r
+ PUSH P,A\r
+ PUSHJ P,CELL\r
+ POP P,A ;# OF ELEMENTS\r
+ PUSH P,B ;ptr to allocated list\r
+ POP TP,C ;ptr to orig list\r
+ JRST ENTCOP\r
+\r
+COPYL: ADDI B,2\r
+ HRRM B,-2(B) ;LINK ALOCATED LIST CELLS\r
+ENTCOP: JUMPE C,OUTRNG\r
+ MOVE D,(C) \r
+ MOVE E,1(C) ;get list element into D+E\r
+ HLLM D,(B)\r
+ MOVEM E,1(B) ;put into allocated space\r
+ HRRZ C,(C) ;update ptrs\r
+ SOJG A,COPYL ;finish transfer?\r
+\r
+CLOSEL: POP P,B ;PTR TO NEW LIST\r
+ POP TP,A ;type\r
+ JRST FINIS\r
+\r
+ZEROLT: SUB TP,[1,,1] ;IF RESTED ALL OF LIST\r
+ SUB TP,[1,,1]\r
+ MOVSI A,TLIST\r
+ MOVEI B,0\r
+ JRST FINIS\r
+\r
+CPYLS2: GETYP 0,6(AB)\r
+ CAIE 0,TLIST\r
+ JRST WTYP\r
+ MOVE B,7(AB) ; GET DEST LIST\r
+ MOVE C,(TP)\r
+\r
+ JUMPE A,CPYLS3\r
+CPYLS4: JUMPE B,OUTRNG\r
+ JUMPE C,OUTRNG\r
+ MOVE D,1(C)\r
+ MOVEM D,1(B)\r
+ GETYP 0,(C)\r
+ HRLM 0,(B)\r
+ HRRZ B,(B)\r
+ HRRZ C,(C)\r
+ SOJG A,CPYLS4\r
+\r
+CPYLS3: MOVE B,7(AB)\r
+ MOVSI A,TLIST\r
+ JRST FINIS\r
+\r
+\r
+; PROCESS TYPE ILLEGAL\r
+\r
+ILLCHO: HRRZ B,1(B) ;GET CLOBBERED TYPE\r
+ CAIN B,TARGS ;WAS IT ARGS?\r
+ JRST ILLAR1\r
+ CAIN B,TFRAME ;A FRAME?\r
+ JRST ILFRAM\r
+ CAIN B,TLOCD ;A LOCATIVE TO AN ID\r
+ JRST ILLOC1\r
+\r
+ LSH B,1 ;NONE OF ABOVE LOOK IN TABLE\r
+ ADDI B,TYPVEC+1(TVP)\r
+ PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE ILLEGAL\r
+ PUSH TP,$TATOM\r
+ PUSH TP,(B) ;PUSH ATOMIC NAME\r
+ MOVEI A,2\r
+ JRST CALER ;GO TO ERROR REPORTER\r
+\r
+; CHECK AN ARGS POINTER\r
+\r
+CHARGS: PUSHJ P,ICHARG ; INTERNAL CHECK\r
+ JUMPN B,CPOPJ\r
+\r
+ILLAR1: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE ILLEGAL-ARGUMENT-BLOCK\r
+ JRST CALER1\r
+\r
+ICHARG: PUSH P,A ;SAVE SOME ACS\r
+ PUSH P,B\r
+ PUSH P,C\r
+ SKIPN C,1(B) ;GET POINTER\r
+ JRST ILLARG ; ZERO POINTER IS ILLEGAL\r
+ HLRE A,C ;FIND ASSOCIATED FRAME\r
+ SUBI C,(A) ;C POINTS TO FRAME OR FRAME POINTER\r
+ GETYP A,(C) ;GET TYPE OF NEXT GOODIE\r
+ CAIN A,TCBLK\r
+ JRST CHARG1\r
+ CAIE A,TENTRY ;MUST BE EITHER ENTRY OR TINFO\r
+ CAIN A,TINFO\r
+ JRST CHARG1 ;WINNER\r
+ JRST ILLARG\r
+\r
+CHARG1: CAIN A,TINFO ;POINTER TO FRAME?\r
+ ADD C,1(C) ;YES, GET IT\r
+ CAIE A,TINFO ;POINTS TO ENTRT?\r
+ MOVEI C,FRAMLN(C) ;YES POINT TO END OF FRAME\r
+ HLRZ C,OTBSAV(C) ;GET TIME FROM FRAME\r
+ HRRZ B,(B) ;AND ARGS TIME\r
+ CAIE B,(C) ;SAME?\r
+ILLARG: SETZM -1(P) ; RETURN ZEROED B\r
+POPBCJ: POP P,C\r
+ POP P,B\r
+ POP P,A\r
+ POPJ P, ;GO GET PRIM TYPE\r
+\f\r
+\r
+\r
+; CHECK A FRAME POINTER\r
+\r
+CHFRM: PUSHJ P,CHFRAM\r
+ JUMPN B,CPOPJ\r
+\r
+ILFRAM: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE ILLEGAL-FRAME\r
+ JRST CALER1\r
+\r
+CHFRAM: PUSH P,A ;SAVE SOME REGISTERS\r
+ PUSH P,B\r
+ PUSH P,C\r
+ HRRZ A,(B) ; GE PVP POINTER\r
+ HLRZ C,(A) ; GET LNTH\r
+ SUBI A,-1(C) ; POINT TO TOP\r
+ CAIN A,(PVP) ; SKIP IF NOT THIS PROCESS\r
+ MOVEM TP,TPSTO+1(A) ; MAKE CURRENT BE STORED\r
+ HRRZ A,TPSTO+1(A) ; GET TP FOR THIS PROC\r
+ HRRZ C,1(B) ;GET POINTER PART\r
+ CAILE C,1(A) ;STILL WITHIN STACK\r
+ JRST BDFR\r
+ HLRZ A,FSAV(C) ;CHECK STILL AN ENTRY BLOCK\r
+ CAIN A,TCBLK\r
+ JRST .+3\r
+ CAIE A,TENTRY\r
+ JRST BDFR\r
+ HLRZ A,1(B) ;GET TIME FROM POINTER\r
+ HLRZ C,OTBSAV(C) ;AND FROM FRAME\r
+ CAIE A,(C) ;SAME?\r
+BDFR: SETZM -1(P) ; RETURN 0 IN B\r
+ JRST POPBCJ ;YES, WIN\r
+\r
+; CHECK A LOCATIVE TO AN IDENTIFIER\r
+\r
+CHLOCI: PUSHJ P,ICHLOC\r
+ JUMPN B,CPOPJ\r
+\r
+ILLOC1: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE ILLEGAL-LOCATIVE\r
+ JRST CALER1\r
+\r
+ICHLOC: PUSH P,A\r
+ PUSH P,B\r
+ PUSH P,C\r
+\r
+ HRRZ A,(B) ;GET TIME FROM POINTER\r
+ JUMPE A,POPBCJ ;ZERO, GLOBAL VARIABLE NO TIME\r
+ HRRZ C,1(B) ;POINT TO STACK\r
+ CAMLE C,VECTOP\r
+ JRST ILLOC ;NO\r
+ HRRZ C,2(C) ; SHOULD BE DECL,,TIME\r
+ CAIE A,(C)\r
+ILLOC: SETZM -1(P) ; RET 0 IN B\r
+ JRST POPBCJ\r
+\r
+\r
+ \r
+\f\r
+; PREDICATE TO SEE IF AN OBJECT IS STRUCTURED\r
+\r
+MFUNCTION %STRUC,SUBR,[STRUCTURED?]\r
+\r
+ ENTRY 1\r
+\r
+ GETYP A,(AB) ; GET TYPE\r
+ PUSHJ P,ISTRUC ; INTERNAL\r
+ JRST IFALSE\r
+ JRST ITRUTH\r
+\r
+\r
+; PREDICATE TO CHECK THE LEGALITY OF A FRAME/ARGS TUPLE/IDENTIFIER LOCATIVE\r
+\r
+MFUNCTION %LEGAL,SUBR,[LEGAL?]\r
+\r
+ ENTRY 1\r
+\r
+ MOVEI B,(AB) ; POINT TO ARG\r
+ PUSHJ P,ILEGQ\r
+ JRST IFALSE\r
+ JRST ITRUTH\r
+\r
+ILEGQ: GETYP A,(B)\r
+ CAIN A,TILLEG\r
+ POPJ P,\r
+ PUSHJ P,SAT ; GET STORG TYPE\r
+ CAIN A,SFRAME ; FRAME?\r
+ PUSHJ P,CHFRAM\r
+ CAIN A,SARGS ; ARG TUPLE\r
+ PUSHJ P,ICHARG\r
+ CAIN A,SLOCID ; ID LOCATIVE\r
+ PUSHJ P,ICHLOC\r
+ JUMPE B,CPOPJ\r
+ JRST CPOPJ1\r
+\r
+\r
+; COMPILERS CALL\r
+\r
+CILEGQ: PUSH TP,A\r
+ PUSH TP,B\r
+ MOVEI B,-1(TP)\r
+ PUSHJ P,ILEGQ\r
+ TDZA 0,0\r
+ MOVEI 0,1\r
+ SUB TP,[2,,2]\r
+ JUMPE 0,NO\r
+\r
+YES: MOVSI A,TATOM\r
+ MOVE B,MQUOTE T\r
+ JRST CPOPJ1\r
+\r
+NOM: SUBM M,(P)\r
+NO: MOVSI A,TFALSE\r
+ MOVEI B,0\r
+ POPJ P,\r
+\r
+YESM: SUBM M,(P)\r
+ JRST YES\r
+\f;SUBRS TO DEFINE, GET, AND PUT BIT FIELDS\r
+\r
+MFUNCTION BITS,SUBR\r
+ ENTRY\r
+ JUMPGE AB,TFA ;AT LEAST ONE ARG ?\r
+ GETYP A,(AB)\r
+ CAIE A,TFIX\r
+ JRST WTYP1\r
+ SKIPLE C,(AB)+1 ;GET FIRST AND CHECK TO SEE IF POSITIVE\r
+ CAILE C,44 ;CHECK IF FIELD NOT GREATER THAN WORD SIZE\r
+ JRST OUTRNG\r
+ MOVEI B,0\r
+ CAML AB,[-2,,0] ;ONLY ONE ARG ?\r
+ JRST ONEF ;YES\r
+ CAMGE AB,[-4,,0] ;MORE THAN TWO ARGS ?\r
+ JRST TMA ;YES, LOSE\r
+ GETYP A,(AB)+2\r
+ CAIE A,TFIX\r
+ JRST WTYP2\r
+ SKIPGE B,(AB)+3 ;GET SECOND ARG AND CHECK TO SEE IF NON-NEGATIVE\r
+ JRST OUTRNG\r
+ ADD C,(AB)+3 ;CALCULATE LEFTMOST EXTENT OF THE FIELD\r
+ CAILE C,44 ;SHOULD BE LESS THAN WORD SIZE\r
+ JRST OUTRNG\r
+ LSH B,6\r
+ONEF: ADD B,(AB)+1\r
+ LSH B,30 ;FORM BYTE POINTER'S LEFT HALF\r
+ MOVSI A,TBITS\r
+ JRST FINIS\r
+\r
+\r
+\r
+MFUNCTION GETBITS,SUBR\r
+ ENTRY 2\r
+ GETYP A,(AB)\r
+ PUSHJ P,SAT\r
+ CAIN A,SSTORE\r
+ JRST .+3\r
+ CAIE A,S1WORD\r
+ JRST WTYP1\r
+ GETYP A,(AB)+2\r
+ CAIE A,TBITS\r
+ JRST WTYP2\r
+ MOVEI A,(AB)+1 ;GET ADDRESS OF THE WORD\r
+ HLL A,(AB)+3 ;GET LEFT HALF OF BYTE POINTER\r
+ LDB B,A\r
+ MOVSI A,TWORD ; ALWAYS RETURN WORD\b\b\b\b____\r
+ JRST FINIS\r
+\r
+\r
+MFUNCTION PUTBITS,SUBR\r
+ ENTRY\r
+ CAML AB,[-2,,0] ;AT LEAST TWO ARGS ?\r
+ JRST TFA ;NO, LOSE\r
+ GETYP A,(AB)\r
+ PUSHJ P,SAT\r
+ CAIE A,S1WORD\r
+ JRST WTYP1\r
+ GETYP A,(AB)+2\r
+ CAIE A,TBITS\r
+ JRST WTYP2\r
+ MOVEI B,0 ;EMPTY THIRD ARG DEFAULT\r
+ CAML AB,[-4,,0] ;ONLY TWO ARGS ?\r
+ JRST TWOF\r
+ CAMGE AB,[-6,,0] ;MORE THAN THREE ARGS ?\r
+ JRST TMA ;YES, LOSE\r
+ GETYP A,(AB)+4\r
+ PUSHJ P,SAT\r
+ CAIE A,S1WORD\r
+ JRST WTYP3\r
+ MOVE B,(AB)+5\r
+TWOF: MOVEI A,(AB)+1 ;ADDRESS OF THE TARGET WORD\r
+ HLL A,(AB)+3 ;GET THE LEFT HALF OF THE BYTE POINTER\r
+ DPB B,A\r
+ MOVE B,(AB)+1\r
+ MOVE A,(AB) ;SAME TYPE AS FIRST ARG'S\r
+ JRST FINIS\r
+\f\r
+\r
+; FUNCTION TO GET THE LENGTH OF LISTS,VECTORS AND CHAR STRINGS\r
+\r
+MFUNCTION LNTHQ,SUBR,[LENGTH?]\r
+\r
+ ENTRY 2\r
+ GETYP A,(AB)2\r
+ CAIE A,TFIX\r
+ JRST WTYP2\r
+ PUSH P,(AB)3\r
+ JRST LNTHER\r
+\r
+\r
+MFUNCTION LENGTH,SUBR\r
+\r
+ ENTRY 1\r
+ PUSH P,[377777777777]\r
+LNTHER: MOVE B,AB ;POINT TO ARGS\r
+ PUSHJ P,PTYPE ;GET ITS PRIM TYPE\r
+ MOVE B,1(AB)\r
+ MOVE C,(AB)\r
+ PUSHJ P,@LENTBL(A) ; CALL RIGTH ONE\r
+ JRST LFINIS ;OTHERWISE USE 0\r
+\r
+PRDISP LENTBL,IWTYP1,[[P2WORD,LNLST],[P2NWORD,LNVEC],[PNWORD,LNUVEC]\r
+[PARGS,LNVEC],[PCHSTR,LNCHAR],[PTMPLT,LNTMPL]]\r
+\r
+LNLST: SKIPN C,B ; EMPTY?\r
+ JRST LNLST2 ; YUP, LEAVE\r
+ MOVEI B,1 ; INIT COUNTER\r
+ MOVSI A,TLIST ;WILL BECOME INTERRUPTABLE\r
+ HLLM A,CSTO(PVP) ;AND C WILL BE A LIST POINTER\r
+LNLST1: INTGO ;IN CASE CIRCULAR LIST\r
+ CAMLE B,(P)-1\r
+ JRST LNLST2\r
+ HRRZ C,(C) ;STEP\r
+ JUMPE C,.+2 ;DONE, RETRUN LENGTH\r
+ AOJA B,LNLST1 ;COUNT AND GO\r
+LNLST2: SETZM CSTO(PVP)\r
+ POPJ P,\r
+\r
+LFINIS: POP P,C\r
+ CAMLE B,C\r
+ JRST IFALSE\r
+ MOVSI A,TFIX ;LENGTH IS AN INTEGER\r
+ JRST FINIS\r
+\r
+LNVEC: ASH B,-1 ;GENERAL VECTOR DIVIDE BY 2\r
+LNUVEC: HLRES B ;GET LENGTH\r
+ MOVMS B ;MAKE POS\r
+ POPJ P,\r
+\r
+LNCHAR: HRRZ B,C ; GET COUNT\r
+ POPJ P,\r
+\r
+LNTMPL: GETYP A,(B) ; GET REAL SAT\r
+ SUBI A,NUMSAT+1\r
+ HRLS A ; READY TO HIT TABLE\r
+ ADD A,TD.LNT+1(TVP)\r
+ JUMPGE A,BADTPL\r
+ MOVE C,B ; DATUM TO C\r
+ XCT (A) ; GET LENGTH\r
+ HLRZS C ; REST COUNTER\r
+ SUBI B,(C) ; FLUSH IT OFF\r
+ MOVEI B,(B) ; IN CASE FUNNY STUFF\r
+ MOVSI A,TFIX\r
+ POPJ P,\r
+\r
+; COMPILERS ENTRIES\r
+\r
+CILNT: SUBM M,(P)\r
+ PUSH P,[377777,,-1]\r
+ MOVE C,A\r
+ GETYP A,A\r
+ PUSHJ P,CPTYPE ; GET PRIMTYPE\r
+ JUMPE A,COMPERR\r
+ PUSHJ P,@LENTBL(A) ; DISPATCH\r
+ MOVSI A,TFIX\r
+ SUB P,[1,,1]\r
+MPOPJ: SUBM M,(P)\r
+ POPJ P,\r
+\r
+CILNQ: SUBM M,(P)\r
+ PUSH P,C\r
+ MOVE C,A\r
+ GETYP A,A\r
+ PUSHJ P,CPTYPE\r
+ JUMPE A,COMPERR\r
+ PUSHJ P,@LENTBL(A)\r
+ POP P,C\r
+ SUBM M,(P)\r
+ MOVSI A,TFIX\r
+ CAMG B,C\r
+ JRST CPOPJ1\r
+ MOVSI A,TFALSE\r
+ MOVEI B,0\r
+ POPJ P,\r
+\f\r
+\r
+\r
+IDNT1: MOVE A,(AB) ;RETURN THE FIRST ARG\r
+ MOVE B,1(AB)\r
+ JRST FINIS\r
+\r
+MFUNCTION QUOTE,FSUBR\r
+\r
+ ENTRY 1\r
+\r
+ GETYP A,(AB)\r
+ CAIE A,TLIST ;ARG MUST BE A LIST\r
+ JRST WTYP1\r
+ SKIPN B,1(AB) ;SHOULD HAVE A BODY\r
+ JRST TFA\r
+\r
+ HLLZ A,(B) ; GET IT\r
+ MOVE B,1(B)\r
+ JSP E,CHKAB\r
+ JRST FINIS\r
+\r
+MFUNCTION NEQ,SUBR,[N==?]\r
+ \r
+ MOVEI D,1\r
+ JRST EQR\r
+\r
+MFUNCTION EQ,SUBR,[==?]\r
+\r
+ MOVEI D,0\r
+EQR: ENTRY 2\r
+\r
+ GETYP A,(AB) ;GET 1ST TYPE\r
+ GETYP C,2(AB) ;AND 2D TYPE\r
+ MOVE B,1(AB)\r
+ CAIN A,(C) ;CHECK IT\r
+ CAME B,3(AB)\r
+ JRST @TABLE2(D)\r
+ JRST @TABLE1(D)\r
+\r
+ITRUTH: MOVSI A,TATOM ;RETURN TRUTH\r
+ MOVE B,MQUOTE T\r
+ JRST FINIS\r
+\r
+IFALSE: MOVSI A,TFALSE ;RETURN FALSE\r
+ MOVEI B,0\r
+ JRST FINIS\r
+\r
+TABLE1: ITRUTH\r
+TABLE2: IFALSE\r
+ ITRUTH\r
+\r
+\f\r
+\r
+\r
+MFUNCTION EMPTY,SUBR,EMPTY?\r
+\r
+ ENTRY 1\r
+\r
+ MOVE B,AB\r
+ PUSHJ P,PTYPE ;GET PRIMITIVE TYPE\r
+\r
+ MOVEI A,(A)\r
+ JUMPE A,WTYP1\r
+ SKIPN B,1(AB) ;GET THE ARG\r
+ JRST ITRUTH\r
+\r
+ CAIN A,PTMPLT ; TEMPLATE?\r
+ JRST EMPTPL\r
+ CAIE A,P2WORD ;A LIST?\r
+ JRST EMPT1 ;NO VECTOR OR CHSTR\r
+ JUMPE B,ITRUTH ;0 POINTER MEANS EMPTY LIST\r
+ JRST IFALSE\r
+\r
+\r
+EMPT1: CAIE A,PCHSTR ;CHAR STRING?\r
+ JRST EMPT2 ;NO, VECTOR\r
+ HRRZ B,(AB) ; GET COUNT\r
+ JUMPE B,ITRUTH ;0 STRING WINS\r
+ JRST IFALSE\r
+\r
+EMPT2: JUMPGE B,ITRUTH\r
+ JRST IFALSE\r
+\r
+EMPTPL: PUSHJ P,LNTMPL ; GET LENGTH\r
+ JUMPE B,ITRUTH\r
+ JRST IFALSE\r
+\r
+; COMPILER'S ENTRY TO EMPTY\r
+\r
+CEMPTY: PUSH P,A\r
+ GETYP A,A\r
+ PUSHJ P,CPTYPE\r
+ POP P,0\r
+ JUMPE A,COMPERR\r
+ JUMPE B,YES ; ALWAYS EMPTY\r
+ CAIN A,PTMPLT\r
+ JRST CEMPTP\r
+ CAIN A,P2WORD\r
+ JRST NO\r
+ CAIN A,PCHSTR\r
+ JRST .+3\r
+ JUMPGE B,YES\r
+ JRST NO\r
+ TRNE 0,-1 ; STRING, SKIP ON ZERO LENGTH FIELD\r
+ JRST NO\r
+ JRST YES\r
+\r
+CEMPTP: PUSHJ P,LNTMPL\r
+ JUMPE B,YES\r
+ JRST NO\r
+\r
+MFUNCTION NEQUAL,SUBR,[N=?]\r
+ PUSH P,[1]\r
+ JRST EQUALR\r
+\r
+MFUNCTION EQUAL,SUBR,[=?]\r
+ PUSH P,[0]\r
+EQUALR: ENTRY 2\r
+\r
+ MOVE C,AB ;SET UP TO CALL INTERNAL\r
+ MOVE D,AB\r
+ ADD D,[2,,2] ;C POINTS TO FIRS, D TO SECOND\r
+ PUSHJ P,IEQUAL ;CALL INTERNAL\r
+ JRST EQFALS ;NO SKIP MEANS LOSE\r
+ JRST EQTRUE\r
+EQFALS: POP P,C\r
+ JRST @TABLE2(C)\r
+EQTRUE: POP P,C\r
+ JRST @TABLE1(C)\r
+\r
+\f\r
+; COMPILER'S ENTRY TO =? AND N=?\r
+\r
+CINEQU: PUSH P,[0]\r
+ JRST .+2\r
+\r
+CIEQUA: PUSH P,[1]\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ PUSH TP,C\r
+ PUSH TP,D\r
+ MOVEI C,-3(TP)\r
+ MOVEI D,-1(TP)\r
+ SUBM M,-1(P) ; MAY BECOME INTERRUPTABLE\r
+ PUSHJ P,IEQUAL\r
+ JRST NOE\r
+ POP P,C\r
+ SUB TP,[4,,4] ; FLUSH TEMPS\r
+ JRST @CTAB1(C)\r
+\r
+NOE: POP P,C\r
+ SUB TP,[4,,4]\r
+ JRST @CTAB2(C)\r
+\r
+CTAB1: NOM\r
+CTAB2: YESM\r
+ NOM\r
+ \r
+; INTERNAL EQUAL SUBROUTINE\r
+\r
+IEQUAL: MOVE B,C ;NOW CHECK THE ARGS\r
+ PUSHJ P,PTYPE\r
+ MOVE B,D\r
+ PUSHJ P,PTYPE\r
+ GETYP 0,(C) ;NOW CHECK FOR EQ\r
+ GETYP B,(D)\r
+ MOVE E,1(C)\r
+ CAIN 0,(B) ;DONT SKIP IF POSSIBLE WINNER\r
+ CAME E,1(D) ;DEFINITE WINNER, SKIP\r
+ JRST IEQ1\r
+CPOPJ1: AOS (P) ;EQ, SKIP RETURN\r
+ POPJ P,\r
+\r
+\r
+IEQ1: CAIE 0,(B) ;SKIP IF POSSIBLE MATCH\r
+CPOPJ: POPJ P, ;NOT POSSIBLE WINNERS\r
+ JRST @EQTBL(A) ;DISPATCH\r
+\r
+PRDISP EQTBL,CPOPJ,[[P2WORD,EQLIST],[P2NWORD,EQVEC],[PNWORD,EQUVEC]\r
+[PARGS,EQVEC],[PCHSTR,EQCHST],[PTMPLT,EQTMPL]]\r
+\r
+\r
+EQLIST: PUSHJ P,PUSHCD ;PUT ARGS ON STACK\r
+\r
+EQLST1: INTGO ;IN CASE OF CIRCULAR\r
+ HRRZ C,-2(TP) ;GET FIRST\r
+ HRRZ D,(TP) ;AND 2D\r
+ CAIN C,(D) ;EQUAL?\r
+ JRST EQLST2 ;YES, LEAVE\r
+ JUMPE C,EQLST3 ;NIL LOSES\r
+ JUMPE D,EQLST3\r
+ GETYP 0,(C) ;CHECK DEFERMENT\r
+ CAIN 0,TDEFER\r
+ HRRZ C,1(C) ;PICK UP POINTED TO CROCK\r
+ GETYP 0,(D)\r
+ CAIN 0,TDEFER\r
+ HRRZ D,1(D) ;POINT TO REAL GOODIE\r
+ PUSHJ P,IEQUAL ;CHECK THE CARS\r
+ JRST EQLST3 ;LOSE\r
+ HRRZ C,@-2(TP) ;CDR THE LISTS\r
+ HRRZ D,@(TP\r
+ HRRZM C,-2(TP) ;AND STORE\r
+ HRRZM D,(TP)\r
+ JRST EQLST1\r
+\r
+EQLST2: AOS (P) ;SKIP RETRUN\r
+EQLST3: SUB TP,[4,,4] ;REMOVE CRUFT\r
+ POPJ P,\r
+\f\r
+; HERE FOR HACKING TEMPLATE STRUCTURES\r
+\r
+EQTMPL: PUSHJ P,PUSHCD ; SAVE GOODIES\r
+ PUSHJ P,PUSHCD\r
+ MOVE C,1(C) ; CHECK REAL SATS\r
+ GETYP C,(C)\r
+ MOVE D,1(D)\r
+ GETYP 0,(D)\r
+ CAIE 0,(C) ; SKIP IF WINNERS\r
+ JRST EQTMP4\r
+ PUSH P,0 ; SAVE MAGIC OFFSET\r
+ MOVE B,-2(TP)\r
+ PUSHJ P,TM.LN1 ; RET LENGTH IN B\r
+ MOVEI B,-1(B) ; FLUSH FUNNY\r
+ HLRZ C,-2(TP)\r
+ SUBI B,(C)\r
+ PUSH P,B\r
+ MOVE C,(TP) ; POINTER TO OTHER GUY\r
+ ADD A,TD.LNT+1(TVP)\r
+ XCT (A) ; OTHER LENGTH TO B\r
+ HLRZ 0,B ; REST OFFSETTER\r
+ PUSH P,0\r
+ MOVEI B,-1(B)\r
+ HLRZ C,(TP)\r
+ SUBI B,(C)\r
+ CAME B,-1(P)\r
+ JRST EQTMP1\r
+\r
+EQTMP2: AOS C,(P)\r
+ SOSGE -1(P)\r
+ JRST EQTMP3 ; WIN!!\r
+\r
+ MOVE B,-6(TP) ; POINTER\r
+ MOVE 0,-2(P) ; GET MAGIC OFFSET\r
+ PUSHJ P,TM.TOE ; GET OFFSET TO TEMPLATE\r
+ ADD A,TD.GET+1(TVP)\r
+ MOVE A,(A)\r
+ ADDI E,(A)\r
+ XCT (E) ; VAL TO A AND B\r
+ MOVEM A,-3(TP)\r
+ MOVEM B,-2(TP)\r
+ MOVE C,(P)\r
+ MOVE B,-4(TP) ; OTHER GUY\r
+ MOVE 0,-2(P)\r
+ PUSHJ P,TM.TOE\r
+ ADD A,TD.GET+1(TVP)\r
+ MOVE A,(A)\r
+ ADDI E,(A)\r
+ XCT (E) ; GET OTHER VALUE\r
+ MOVEM A,-1(TP)\r
+ MOVEM B,(TP)\r
+ MOVEI C,-3(TP)\r
+ MOVEI D,-1(TP)\r
+ PUSHJ P,IEQUAL ; RECURSE\r
+ JRST EQTMP1 ; LOSER\r
+ JRST EQTMP2 ; WINNER\r
+\r
+EQTMP3: AOS -3(P) ; WIN RETURN\r
+EQTMP1: SUB P,[3,,3] ; FLUSH JUNK\r
+EQTMP4: SUB TP,[10,,10]\r
+ POPJ P,\r
+\r
+\r
+\r
+EQVEC: HLRE A,1(C) ;GET LENGTHS\r
+ HLRZ B,1(D)\r
+ CAIE B,(A) ;SKIP IF EQUAL LENGTHS\r
+ POPJ P, ;LOSE\r
+ JUMPGE A,CPOPJ1 ;SKIP RETRUN WIN\r
+ PUSHJ P,PUSHCD ;SAVE ARGS\r
+\r
+EQVEC1: INTGO ;IN CASE LONG VECTOR\r
+ MOVE C,(TP)\r
+ MOVE D,-2(TP) ;ARGS TO C AND D\r
+ PUSHJ P,IEQUAL\r
+ JRST EQLST3\r
+ MOVE C,[2,,2] ;GET BUMPER\r
+ ADDM C,(TP)\r
+ ADDB C,-2(TP) ;BUMP BOTH POINTERS\r
+ JUMPL C,EQVEC1\r
+ JRST EQLST2\r
+\r
+EQUVEC: HLRE A,1(C) ;GET LENGTHS\r
+ HLRZ B,1(D)\r
+ CAIE B,(A) ;SKIP IF EQUAL\r
+ POPJ P,\r
+\r
+ HRRZ B,1(C) ;START COMPUTING DOPE WORD LOCN\r
+ SUB B,A ;B POINTS TO DOPE WORD\r
+ GETYP 0,(B) ;GET UNIFORM TYPE\r
+ HRRZ B,1(D) ;NOW FIND OTHER DOPE WORD\r
+ SUB B,A\r
+ HLRZ B,(B) ;OTHER UNIFORM TYPE\r
+ CAIE 0,(B) ;TYPES THE SAME?\r
+ POPJ P, ;NO, LOSE\r
+\r
+ JUMPGE A,CPOPJ1 ;IF ZERO LENGTH ALREADY WON\r
+\r
+ HRLZI B,(B) ;TYPE TO LH\r
+ PUSH P,B ;AND SAVED\r
+ PUSHJ P,PUSHCD ;SAVE ARGS\r
+\r
+EQUV1: MOVEI C,1(TP) ;POINT TO WHERE WILL GO\r
+ PUSH TP,(P)\r
+ MOVE A,-3(TP) ;PUSH ONE OF THE VECTORS\r
+ PUSH TP,(A) ; PUSH ELEMENT\r
+ MOVEI D,1(TP) ;POINT TO 2D ARG\r
+ PUSH TP,(P)\r
+ MOVE A,-3(TP) ;AND PUSH ITS POINTER\r
+ PUSH TP,(A)\r
+ PUSHJ P,IEQUAL\r
+ JRST UNEQUV\r
+\r
+ SUB TP,[4,,4] ;POP TP\r
+ MOVE A,[1,,1]\r
+ ADDM A,(TP) ;BUMP POINTERS\r
+ ADDB A,-2(TP)\r
+ JUMPL A,EQUV1 ;JUMP IF STILL MORE STUFF\r
+ SUB P,[1,,1] ;POP OFF TYPE\r
+ JRST EQLST2\r
+\r
+UNEQUV: SUB P,[1,,1]\r
+ SUB TP,[10,,10]\r
+ POPJ P,\r
+\f\r
+\r
+\r
+EQCHST: HRRZ B,(C) ; GET LENGTHS\r
+ HRRZ A,(D)\r
+ CAIE A,(B) ;SAME\r
+ JRST EQCHS3 ;NO, LOSE\r
+ MOVE C,1(C)\r
+ MOVE D,1(D)\r
+ JUMPE A,EQCHS4 ;BOTH 0 LENGTH, WINS\r
+\r
+EQCHS2:\r
+ ILDB 0,C ;GET NEXT CHARS\r
+ ILDB E,D\r
+ CAIE 0,(E) ; SKIP IF STILL WINNING\r
+ JRST EQCHS3 ; NOT =\r
+ SOJG A,EQCHS2\r
+\r
+EQCHS4: AOS (P)\r
+EQCHS3: POPJ P,\r
+\r
+PUSHCD: PUSH TP,(C)\r
+ PUSH TP,1(C)\r
+ PUSH TP,(D)\r
+ PUSH TP,1(D)\r
+ POPJ P,\r
+\r
+\f\r
+; REST/NTH/AT/PUT/GET\r
+\r
+; ARG CHECKER\r
+\r
+ARGS1: MOVE E,[JRST WTYP2] ; ERROR CONDITION FOR 2D ARG NOT FIXED\r
+ARGS2: HLRE 0,AB ; CHECK NO. OF ARGS\r
+ ASH 0,-1 ; TO - NO. OF ARGS\r
+ AOJG 0,TFA ; 0--TOO FEW\r
+ AOJL 0,TMA ; MORE THAT 2-- TOO MANY\r
+ MOVEI C,1 ; DEFAULT ARG2\r
+ JUMPN 0,ARGS4 ; GET STRUCTURED ARG\r
+ARGS3: GETYP A,2(AB)\r
+ CAIE A,TFIX ; SHOULD BE FIXED NUMBER\r
+ XCT E ; DO ERROR THING\r
+ SKIPGE C,3(AB) ; BETTER BE NON-NEGATIVE\r
+ JRST OUTRNG\r
+ARGS4: MOVEI B,(AB) ; POINT TO STRUCTURED POINTER\r
+ PUSHJ P,PTYPE ; GET PRIM TYPE\r
+ MOVEI E,(A) ; DISPATCH CODE TO E\r
+ MOVE A,(AB) ; GET ARG 1\r
+ MOVE B,1(AB)\r
+ POPJ P,\r
+\r
+; REST \r
+\r
+MFUNCTION REST,SUBR\r
+\r
+ ENTRY\r
+ PUSHJ P,ARGS1 ; GET AND CHECK ARGS\r
+ PUSHJ P,@RESTBL(E) ; DO IT BASED ON TYPE\r
+ MOVE C,A ; THE FOLLOWING IS TO MAKE STORAGE WORK\r
+ GETYP A,(AB)\r
+ PUSHJ P,SAT\r
+ CAIN A,SSTORE ; SKIP IF NOT STORAGE\r
+ MOVSI C,TSTORA ; USE ITS PRIMTYPE\r
+ MOVE A,C\r
+ JRST FINIS\r
+\r
+PRDISP RESTBL,IWTYP1,[[P2WORD,LREST],[PNWORD,UREST],[P2NWOR,VREST],[PARGS,AREST]\r
+[PCHSTR,SREST],[PTMPLT,TMPRST]]\r
+\r
+; AT\r
+\r
+MFUNCTION AT,SUBR\r
+\r
+ ENTRY\r
+ PUSHJ P,ARGS1\r
+ SOJL C,OUTRNG\r
+ PUSHJ P,@ATTBL(E)\r
+ JRST FINIS\r
+\r
+PRDISP ATTBL,IWTYP1,[[P2WORD,LAT],[PNWORD,UAT],[P2NWORD,VAT],[PARGS,AAT]\r
+[PCHSTR,STAT],[PTMPLT,TAT]]\r
+\r
+\f\r
+; NTH\r
+\r
+MFUNCTION NTH,SUBR\r
+\r
+ ENTRY\r
+\r
+ PUSHJ P,ARGS1\r
+ SOJL C,OUTRNG\r
+ PUSHJ P,@NTHTBL(E)\r
+ JRST FINIS\r
+\r
+PRDISP NTHTBL,IWTYP1,[[P2WORD,LNTH],[PNWORD,UNTH],[P2NWOR,VNTH],[PARGS,ANTH]\r
+[PCHSTR,SNTH],[PTMPLT,TMPLNT]]\r
+\r
+; GET\r
+\r
+MFUNCTION GET,SUBR\r
+\r
+ ENTRY\r
+ MOVE E,IIGETP ; MAKE ARG CHECKER FAIL INTO GETPROP\r
+ PUSHJ P,ARGS5 ; CHECK ARGS\r
+ SOJL C,OUTRNG\r
+ SKIPN E,IGETBL(E) ; GET DISPATCH ADR\r
+ JRST IGETP ; REALLY PUTPROP\r
+ JUMPE 0,TMA\r
+ PUSHJ P,(E) ; DISPATCH\r
+ JRST FINIS\r
+\r
+PRDISP IGETBL,0,[[P2WORD,LNTH],[PNWORD,UNTH],[P2NWORD,VNTH],[PARGS,ANTH]\r
+[PCHSTR,SNTH],[PTMPLT,TMPLNT]]\r
+\r
+; GETL\r
+\r
+MFUNCTION GETL,SUBR\r
+\r
+ ENTRY\r
+ MOVE E,IIGETL ; ERROR HACK\r
+ PUSHJ P,ARGS5\r
+ SOJL C,OUTRNG ; LOSER\r
+ SKIPN E,IGTLTB(E)\r
+ JRST IGETLO ; REALLY GETPL\r
+ JUMPE 0,TMA\r
+ PUSHJ P,(E) ; DISPATCH\r
+ JRST FINIS\r
+\r
+IIGETL: JRST IGETLO\r
+\r
+PRDISP IGTLTB,0,[[P2WORD,LAT],[PNWORD,UAT],[P2NWORD,VAT],[PARGS,AAT]\r
+[PCHSTR,STAT]]\r
+\r
+\r
+; ARG CHECKER FOR PUT/GET/GETL\r
+\r
+ARGS5: HLRE 0,AB ; -# OF ARGS\r
+ ASH 0,-1\r
+ ADDI 0,2 ; 0 OR -1 WIN\r
+ JUMPG 0,TFA\r
+ AOJL 0,TMA ; MORE THAN 3\r
+ JRST ARGS3 ; GET ARGS\r
+\f\r
+; PUT\r
+\r
+MFUNCTION PUT,SUBR\r
+\r
+ ENTRY\r
+ MOVE E,IIPUTP\r
+ PUSHJ P,ARGS5 ; GET ARGS\r
+ SKIPN E,IPUTBL(E)\r
+ JRST IPUTP\r
+ CAML AB,[-5,,] ; SKIP IF GOOD ARRGS\r
+ JRST TFA\r
+ SOJL C,OUTRNG\r
+ PUSH TP,4(AB)\r
+ PUSH TP,5(AB)\r
+ PUSHJ P,(E)\r
+ MOVE A,(AB) ; RET STRUCTURE\r
+ MOVE B,1(AB)\r
+ JRST FINIS\r
+\r
+PRDISP IPUTBL,0,[[P2WORD,LPUT],[PNWORD,UPUT],[P2NWORD,VPUT],[PARGS,APUT]\r
+[PCHSTR,SPUT],[PTMPLT,TMPPUT]]\r
+\r
+; IN\r
+\r
+MFUNCTION IN,SUBR\r
+\r
+ ENTRY 1\r
+\r
+ MOVEI B,(AB) ; POINT TO ARG\r
+ PUSHJ P,PTYPE\r
+ MOVS E,A ; REAL DISPATCH TO E\r
+ MOVE B,1(AB)\r
+ MOVE A,(AB)\r
+ GETYP C,A ; IN CASE NEEDED\r
+ PUSHJ P,@INTBL(E)\r
+ JRST FINIS\r
+\r
+PRDISP INTBL,OTHIN,[[P2WORD,LNTH1],[PNWORD,UIN],[P2NWORD,VIN],[PARGS,AIN]\r
+[PCHSTR,SIN],[PTMPLT,TIN]]\r
+\r
+OTHIN: CAIE C,TLOCN ; ASSOCIATION LOCATIVE\r
+ JRST OTHIN1 ; MAYBE LOCD\r
+ HLLZ 0,VAL(B)\r
+ PUSHJ P,RMONCH\r
+ MOVE A,VAL(B)\r
+ MOVE B,VAL+1(B)\r
+ POPJ P,\r
+\r
+OTHIN1: CAIE C,TLOCD\r
+ JRST WTYP1\r
+ JRST VIN\r
+\r
+\f\r
+; SETLOC\r
+\r
+MFUNCTION SETLOC,SUBR\r
+\r
+ ENTRY 2\r
+\r
+ MOVEI B,(AB) ; POINT TO ARG\r
+ PUSHJ P,PTYPE ; DO TYPE\r
+ MOVS E,A ; REAL TYPE\r
+ MOVE B,1(AB)\r
+ MOVE C,2(AB) ; PASS ARG\r
+ MOVE D,3(AB)\r
+ MOVE A,(AB) ; IN CASE\r
+ GETYP 0,A\r
+ PUSHJ P,@SETTBL(E)\r
+ MOVE A,2(AB)\r
+ MOVE B,3(AB)\r
+ JRST FINIS\r
+\r
+PRDISP SETTBL,OTHSET,[[P2WORD,LSTUF],[PNWORD,USTUF],[P2NWORD,VSTUF],[PARGS,ASTUF]\r
+[PCHSTR,SSTUF],[PTMPLT,TSTUF]]\r
+\r
+OTHSET: CAIE 0,TLOCN ; ASSOC?\r
+ JRST OTHSE1\r
+ HLLZ 0,VAL(B) ; GET MONITORS\r
+ PUSHJ P,MONCH\r
+ MOVEM C,VAL(B)\r
+ MOVEM D,VAL+1(B)\r
+ POPJ P,\r
+\r
+OTHSE1: CAIE 0,TLOCD\r
+ JRST WTYP1\r
+ JRST VSTUF\r
+\r
+; LREST -- REST A LIST IN B BY AMOUNT IN C\r
+\r
+LREST: MOVSI A,TLIST\r
+ JUMPE C,CPOPJ\r
+ MOVEM A,BSTO(PVP)\r
+\r
+LREST2: INTGO ;CHECK INTERRUPTS\r
+ JUMPE B,OUTRNG ; CANT CDR NIL\r
+ HRRZ B,(B) ;CDR THE LIST\r
+ SOJG C,LREST2 ;COUNT DOWN\r
+ SETZM BSTO(PVP) ;RESET BSTO\r
+ POPJ P,\r
+\r
+\f\r
+; VREST -- REST A VECTOR, AREST -- REST AN ARG BLOCK\r
+\r
+VREST: SKIPA A,$TVEC ; FINAL TYPE\r
+AREST: HRLI A,TARGS\r
+ ASH C,1 ; TIMES 2\r
+ JRST UREST1\r
+\r
+; UREST -- REST A UVECTOR\r
+\r
+STORST: SKIPA A,$TSTORA\r
+UREST: MOVSI A,TUVEC\r
+UREST1: JUMPE C,CPOPJ\r
+ HRLI C,(C)\r
+ JUMPL C,OUTRNG\r
+ ADD B,C ; REST IT\r
+ CAILE B,-1 ; OUT OF RANGE ?\r
+ JRST OUTRNG\r
+ POPJ P,\r
+\r
+\r
+; SREST -- REST A STRING\r
+\r
+SREST: JUMPE C,SREST1\r
+ PUSH P,A ; SAVE TYPE WORD\r
+ PUSH P,C ; SAVE AMOUNT\r
+ MOVEI D,(A) ; GET LENGTH\r
+ CAILE C,(D) ; SKIP IF OK\r
+ JRST OUTRNG\r
+ LDB D,[366000,,B] ;POSITION FIELD OF BYTE POINTER\r
+ LDB A,[300600,,B] ;SIZE FIELD\r
+ PUSH P,A ;SAVE SIZE\r
+ IDIVI D,(A) ;COMPUT BYTES IN 1ST WORD\r
+ MOVEI 0,36. ;NOW COMPUTE BYTES PER WORD\r
+ IDIVI 0,(A) ;BYTES PER WORD IN 0\r
+ MOVE E,0 ;COPY OF BYTES PER WORD TO E\r
+ SUBI 0,(D) ;0 # OF UNSUED BYTES IN 1ST WORD\r
+ ADDB C,0 ;C AND 0 NO.OF CHARS FROM WORD BOUNDARY\r
+ IDIVI C,(E) ;C/ REL WORD D/ CHAR IN LAST\r
+ ADDI C,(B) ;POINTO WORD WITH C\r
+ POP P,A ;RESTORE BITS PER BYTE\r
+ IMULI A,(D) ;A/ BITS USED IN LAST WORD\r
+ MOVEI 0,36.\r
+ SUBI 0,(A) ;0 HAS NEW POSITION FIELD\r
+ DPB 0,[360600,,B] ;INTO BYTE POINTER\r
+ HRRI B,(C) ;POINT TO RIGHT WORD\r
+ POP P,C ; RESTORE AMOUNT\r
+ POP P,A\r
+ SUBI A,(C) ; NEW LENGTH\r
+SREST1: HRLI A,TCHSTR\r
+ POPJ P,\r
+\r
+; TMPRST -- REST A TEMPLATE DATA STRUCTURE\r
+\r
+TMPRST: PUSHJ P,TM.TOE ; CHECK ALL BOUNDS ETC.\r
+ MOVSI D,(D)\r
+ HLL C,D\r
+ MOVE B,C ; RET IN B\r
+ MOVSI A,TTMPLT\r
+ POPJ P,\r
+\r
+; LAT -- GET A LOCATIVE TO A LIST\r
+\r
+LAT: PUSHJ P,LREST ; GET POINTER\r
+ JUMPE B,OUTRNG ; YOU LOSE!\r
+ MOVSI A,TLOCL ; NEW TYPE\r
+ POPJ P,\r
+\r
+\f\r
+; UAT -- GET A LOCATIVE TO A UVECTOR\r
+\r
+UAT: PUSHJ P,UREST \r
+ MOVSI A,TLOCU\r
+ JRST POPJL\r
+\r
+; VAT -- GET A LOCATIVE TO A VECTOR\r
+\r
+VAT: PUSHJ P,VREST ; REST IT AND TYPE IT\r
+ MOVSI A,TLOCV\r
+ JRST POPJL\r
+\r
+; AAT -- GET A LOCATIVE TO AN ARGS BLOCK\r
+\r
+AAT: PUSHJ P,AREST\r
+ HRLI A,TLOCA\r
+POPJL: JUMPGE B,OUTRNG ; LOST\r
+ POPJ P,\r
+\r
+; STAT -- LOCATIVE TO A STRING\r
+\r
+STAT: PUSHJ P,SREST\r
+ TRNN A,-1 ; SKIP IF ANY LEFT\r
+ JRST OUTRNG\r
+ HRLI A,TLOCS ; LOCATIVE\r
+ POPJ P,\r
+\r
+; TAT -- LOCATIVE TO A TEMPLATE\r
+\r
+TAT: PUSHJ P,TMPRST\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ GETYP A,(B) ; GET REAL SAT\r
+ SUBI A,NUMSAT+1\r
+ HRLS A ; READY TO HIT TABLE\r
+ ADD A,TD.LNT+1(TVP)\r
+ JUMPGE A,BADTPL\r
+ MOVE C,B ; DATUM TO C\r
+ XCT (A) ; GET LENGTH\r
+ HLRZS C ; REST COUNTER\r
+ SUBI B,(C) ; FLUSH IT OFF\r
+ JUMPE B,OUTRNG\r
+ MOVE B,(TP)\r
+ SUB TP,[2,,2]\r
+ MOVSI A,TLOCT\r
+ POPJ P,\r
+ \r
+\r
+; LNTH -- NTH OF LIST\r
+\r
+LNTH: PUSHJ P,LAT\r
+LNTH1: PUSHJ P,RMONC0 ; CHECK READ MONITORS\r
+ HLLZ A,(B) ; GET GOODIE\r
+ MOVE B,1(B)\r
+ JSP E,CHKAB ; HACK DEFER\r
+ POPJ P,\r
+\r
+; VNTH -- NTH A VECTOR, ANTH -- NTH AN ARGS BLOCK\r
+\r
+ANTH: PUSHJ P,AAT\r
+ JRST .+2\r
+\r
+VNTH: PUSHJ P,VAT\r
+AIN:\r
+VIN: PUSHJ P,RMONC0\r
+ MOVE A,(B)\r
+ MOVE B,1(B)\r
+ POPJ P,\r
+\r
+; UNTH -- NTH OF UVECTOR\r
+\r
+UNTH: PUSHJ P,UAT\r
+UIN: HLRE C,B ; FIND DW\r
+ SUBM B,C\r
+ HLLZ 0,(C) ; GET MONITORS\r
+ MOVE D,0\r
+ TLZ D,TYPMSK#<-1>\r
+ PUSH P,D\r
+ PUSHJ P,RMONCH ; CHECK EM\r
+ POP P,A\r
+ MOVE B,(B) ; AND VALUE\r
+ POPJ P,\r
+\r
+\f\r
+; SNTH -- NTH A STRING\r
+\r
+SNTH: PUSHJ P,STAT\r
+SIN: PUSH TP,A\r
+ PUSH TP,B ; SAVE POINT BYTER\r
+ MOVEI C,-1(TP) ; FIND DOPE WORD\r
+ PUSHJ P,BYTDOP\r
+ HLLZ 0,-1(A) ; GET \r
+ POP TP,B\r
+ POP TP,A\r
+ PUSHJ P,RMONCH\r
+ ILDB B,B ; GET CHAR\r
+ MOVSI A,TCHRS\r
+ POPJ P,\r
+\r
+; TIN -- IN OF A TEMPLATE\r
+\r
+TIN: MOVEI C,0\r
+\r
+; TMPLNT -- NTH A TEMPLATE DATA STRUCTURE\r
+\r
+TMPLNT: ADDI C,1\r
+ PUSHJ P,TM.TOE ; GET POINTER TO INS IN E\r
+ ADD A,TD.GET+1(TVP) ; POINT TO GETTER\r
+ MOVE A,(A) ; GET VECTOR OF INS\r
+ ADDI E,-1(A) ; POINT TO INS\r
+ SUBI D,1\r
+ XCT (E) ; DO IT\r
+ POPJ P, ; RETURN\r
+\r
+; LPUT -- PUT ON A LIST\r
+\r
+LPUT: PUSHJ P,LAT ; POSITION\r
+ POP TP,D\r
+ POP TP,C\r
+\r
+; LSTUF -- HERE TO STUFF A LIST ELEMENT\r
+\r
+LSTUF: PUSHJ P,MONCH0 ; CHECK OUT MONITOR BITS\r
+ GETYP A,C ; ISOLATE TYPE\r
+ PUSHJ P,NWORDT ; NEED TO DEFER?\r
+ SOJN A,DEFSTU\r
+ HLLM C,(B) \r
+ MOVEM D,1(B) ; AND VAL\r
+ POPJ P,\r
+\r
+DEFSTU: PUSH TP,$TLIST\r
+ PUSH TP,B\r
+ PUSH TP,C\r
+ PUSH TP,D\r
+ PUSHJ P,CELL2 ; GET WORDS\r
+ POP TP,1(B)\r
+ POP TP,(B)\r
+ MOVE E,(TP)\r
+ SUB TP,[2,,2]\r
+ MOVEM B,1(E)\r
+ HLLZ 0,(E) ; GET OLD MONITORS\r
+ TLZ 0,TYPMSK ; KILL TYPES\r
+ TLO 0,TDEFER ; MAKE DEFERRED\r
+ HLLM 0,(E)\r
+ POPJ P,\r
+\r
+; VPUT -- PUT ON A VECTOR , APUT -- PUT ON AN RG BLOCK\r
+\r
+APUT: PUSHJ P,AAT\r
+ JRST .+2\r
+\r
+VPUT: PUSHJ P,VAT ; TREAT LIKE VECTOR\r
+ POP TP,D ; GET GOODIE BACK\r
+ POP TP,C\r
+\r
+; AVSTUF -- CLOBBER ARGS AND VECTORS\r
+\r
+ASTUF:\r
+VSTUF: PUSHJ P,MONCH0\r
+ MOVEM C,(B)\r
+ MOVEM D,1(B)\r
+ POPJ P,\r
+\r
+\f\r
+\r
+\r
+; UPUT -- CLOBBER A UVECTOR\r
+\r
+UPUT: PUSHJ P,UAT ; GET IT RESTED\r
+ POP TP,D\r
+ POP TP,C\r
+\r
+; USTUF -- HERE TO CLOBBER A UVECTOR\r
+\r
+USTUF: HLRE E,B\r
+ SUBM B,E ; C POINTS TO DOPE\r
+ GETYP A,(E) ; GET UTYPE\r
+ GETYP 0,C\r
+ CAIE 0,(A) ; CHECK SAMENESS\r
+ JRST WRNGUT\r
+ HLLZ 0,(E) ; MONITOR BITS IN DOPE WORD\r
+ MOVSI A,TUVEC\r
+ PUSHJ P,MONCH\r
+ MOVEM D,(B) ; SMASH\r
+ POPJ P,\r
+\r
+; SPUT -- HERE TO PUT A STRING\r
+\r
+SPUT: PUSHJ P,STAT ; REST IT\r
+ POP TP,D\r
+ POP TP,C\r
+\r
+; SSTUF -- STUFF A STRING\r
+\r
+SSTUF: GETYP 0,C ; BETTER BE CHAR\r
+ CAIE 0,TCHRS\r
+ JRST WTYP3\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ MOVEI C,-1(TP) ; FIND D.W.\r
+ PUSHJ P,BYTDOP\r
+ HLLZ 0,(A)-1 ; GET MONITORS\r
+ POP TP,B\r
+ POP TP,A\r
+ MOVSI C,TCHRS\r
+ PUSHJ P,MONCH\r
+ IDPB D,B ; STASH\r
+ POPJ P,\r
+\r
+; TSTUF -- SETLOC A TEMPLATE\r
+\r
+TSTUF: PUSH TP,C\r
+ PUSH TP,D\r
+ MOVEI C,0\r
+\r
+; PUTTMP -- TEMPLATE PUTTER\r
+\r
+TMPPUT: ADDI C,1\r
+ PUSHJ P,TM.TOE ; GET E POINTING TO SLOT #\r
+ ADD A,TD.PUT+1(TVP) ; POINT TO INS\r
+ MOVE A,(A) ; GET VECTOR OF INS\r
+ ADDI E,-1(A)\r
+ POP TP,B ; NEW VAL TO A AND B\r
+ POP TP,A\r
+ SUBI D,1\r
+ XCT (E) ; DO IT\r
+ JRST BADPUT\r
+ POPJ P,\r
+\r
+TM.LN1: SUBI 0,NUMSAT+1\r
+ HRRZ A,0 ; RET FIXED OFFSET\r
+ HRLS 0\r
+ ADD 0,TD.LNT+1(TVP) ; USE LENGTHERS FOR TEST\r
+ JUMPGE 0,BADTPL\r
+ PUSH P,C\r
+ MOVE C,B\r
+ HRRZS 0 ; POINT TO TABLE ENTRY\r
+ PUSH P,A\r
+ XCT @0 ; DO IT\r
+ POP P,A\r
+ POP P,C\r
+ POPJ P,\r
+\r
+TM.TBL: MOVEI E,(D) ; TENTATIVE WINNER IN E\r
+ TLNN B,-1 ; SKIP IF REST HAIR EXISTS\r
+ POPJ P, ; NO, WIN\r
+\r
+ PUSH P,A ; SAVE OFFSET\r
+ HRLS A ; A IS REL OFFSET TO INS TABLE\r
+ ADD A,TD.GET+1(TVP) ; GET ONEOF THE TABLES\r
+ MOVE A,(A) ; TABLE POINTER TO A\r
+ MOVSI 0,-1(D) ; START SEEING IF PAST TEMP SPEC\r
+ ADD 0,A\r
+ JUMPL 0,CPOPJA ; JUMP IF E STILL VALID\r
+ HLRZ E,B ; BASIC LENGTH TO E\r
+ HLRE 0,A ; LENGTH OF TEMPLATE TO 0\r
+ ADDI 0,(E) ; 0 ==> # ELEMENTS IN REPEATING SEQUENCE\r
+ MOVNS 0\r
+ SUBM D,E ; E ==> # PAST BASIC WANTED\r
+ EXCH 0,E\r
+ IDIVI 0,(E) ; A ==> REL REST GUY WANTED\r
+ HLRZ E,B\r
+ ADDI E,1(A)\r
+CPOPJA: POP P,A\r
+ POPJ P,\r
+\r
+; TM.TOE -- GET RIGHT TEMPLATE # IN E\r
+; C/ OBJECT #, B/ OBJECT POINTER\r
+\r
+TM.TOE: GETYP 0,(B) ; GET REAL SAT\r
+ MOVEI D,(C) ; OBJ # TO D\r
+ HLRZ C,B ; REST COUNT\r
+ ADDI D,(C) ; FUDGE FOR REST COUNTER\r
+ MOVE C,B ; POINTER TO C\r
+ PUSHJ P,TM.LN1 ; GET LENGTH IN B (WATCH LH!)\r
+ CAILE D,(B) ; CHECK RANGE\r
+ JRST OUTRNG ; LOSER, QUIT\r
+ JRST TM.TBL ; GO COMPUTE TABLE OFFSET\r
+ \r
+\f; ROUTINE FOR COMPILER CALLS RETS CODE IN E GOODIE IN A AND B\r
+; FIXES (P)\r
+\r
+CPTYEE: MOVE E,A\r
+ GETYP A,A\r
+ PUSHJ P,CPTYPE\r
+ JUMPE A,COMPERR\r
+ SUBM M,-1(P)\r
+ EXCH E,A\r
+ POPJ P,\r
+\r
+; COMPILER CALLS TO MANY OF THESE GUYS\r
+\r
+CIREST: PUSHJ P,CPTYEE ; TYPE OF DISP TO E\r
+ JUMPL C,OUTRNG\r
+ CAIN 0,SSTORE\r
+ JRST CIRST1\r
+ PUSHJ P,@RESTBL(E)\r
+ JRST MPOPJ\r
+\r
+CIRST1: PUSHJ P,STORST\r
+ JRST MPOPJ\r
+\r
+CINTH: PUSHJ P,CPTYEE\r
+ SOJL C,OUTRNG ; CHECK BOUNDS\r
+ PUSHJ P,@NTHTBL(E)\r
+ JRST MPOPJ\r
+\r
+CIAT: PUSHJ P,CPTYEE\r
+ SOJL C,OUTRNG\r
+ PUSHJ P,@ATTBL(E)\r
+ JRST MPOPJ\r
+\r
+CSETLO: PUSHJ P,CTYLOC\r
+ MOVSS E ; REAL DISPATCH\r
+ GETYP 0,A ; INCASE LOCAS OR LOCD\r
+ PUSH TP,C\r
+ PUSH TP,D\r
+ PUSHJ P,@SETTBL(E)\r
+ POP TP,B\r
+ POP TP,A\r
+ JRST MPOPJ\r
+\r
+CIN: PUSHJ P,CTYLOC\r
+ MOVSS E ; REAL DISPATCH\r
+ GETYP C,A\r
+ PUSHJ P,@INTBL(E)\r
+ JRST MPOPJ\r
+\r
+CTYLOC: MOVE E,A\r
+ GETYP A,A\r
+ PUSHJ P,CPTYPE\r
+ SUBM M,-1(P)\r
+ EXCH A,E\r
+ POPJ P,\r
+\r
+; COMPILER'S PUT,GET AND GETL\r
+\r
+CIGET: PUSH P,[0]\r
+ JRST .+2\r
+\r
+CIGETL: PUSH P,[1]\r
+ MOVE E,A\r
+ GETYP A,A\r
+ PUSHJ P,CPTYPE\r
+ EXCH A,E\r
+ JUMPE E,CIGET1 ; REAL GET, NOT NTH\r
+ GETYP 0,C ; INDIC FIX?\r
+ CAIE 0,TFIX\r
+ JRST CIGET1\r
+ POP P,E ; GET FLAG\r
+ AOS (P) ; ALWAYS SKIP\r
+ MOVE C,D ; # TO AN AC\r
+ JRST @.+1(E)\r
+ CINTH\r
+ CIAT\r
+\r
+CIGET1: POP P,E ; GET FLAG\r
+ JRST @GETTR(E) ; DO A REAL GET\r
+\r
+GETTR: CIGTPR\r
+ CIGETP\r
+\r
+CIPUT: SUBM M,(P)\r
+ MOVE E,A\r
+ GETYP A,A\r
+ PUSHJ P,CPTYPE\r
+ EXCH A,E\r
+ PUSH TP,-1(TP) ; PAIN AND SUFFERING\r
+ PUSH TP,-1(TP)\r
+ MOVEM A,-3(TP)\r
+ MOVEM B,-2(TP)\r
+ JUMPE E,CIPUT1\r
+ GETYP 0,C\r
+ CAIE 0,TFIX ; YES DO STRUCT\r
+ JRST CIPUT1\r
+ MOVE C,D\r
+ SOJL C,OUTRNG ; CHECK BOUNDS\r
+ PUSHJ P,@IPUTBL(E)\r
+PMPOPJ: POP TP,B\r
+ POP TP,A\r
+ JRST MPOPJ\r
+\r
+CIPUT1: PUSHJ P,IPUT\r
+ JRST PMPOPJ\r
+\f\r
+; SMON -- SET MONITOR BITS\r
+; B/ <POINTER TO LOCATIVE>\r
+; D/ <IORM> OR <ANDCAM>\r
+; E/ BITS\r
+\r
+SMON: GETYP A,(B)\r
+ PUSHJ P,PTYPE ; TO PRIM TYPE\r
+ HLRZS A\r
+ SKIPE A,SMONTB(A) ; DISPATCH?\r
+ JRST (A)\r
+\r
+; COULD STILL BE LOCN OR LOCD\r
+\r
+ GETYP A,(B) ; TYPE BACK\r
+ CAIE A,TLOCN\r
+ JRST SMON2 ; COULD BE LOCD\r
+ MOVE C,1(B) ; POINT\r
+ HRRI D,VAL(C) ; MAKE INST POINT\r
+ JRST SMON3\r
+\r
+SMON2: CAIE A,TLOCD\r
+ JRST WRONGT\r
+\r
+\r
+; SET LIST/TUPLE/ID LOCATIVE\r
+\r
+SMON4: HRR D,1(B) ; POINT TO TYPE WORD\r
+SMON3: XCT D\r
+ POPJ P,\r
+\r
+; SET UVEC LOC\r
+\r
+SMON5: HRRZ C,1(B) ; POINT TO TOP OF UV\r
+ HLRE 0,1(B)\r
+ SUB C,0 ; POINT TO DOPE\r
+ HRRI D,(C) ; POINT IN INST\r
+ JRST SMON3\r
+\r
+; SET CHSTR LOC\r
+\r
+SMON6: MOVEI C,(B) ; FOR BYTDOP\r
+ PUSHJ P,BYTDOP ; POINT TO DOPE\r
+ HRRI D,(A)-1\r
+ JRST SMON3\r
+\r
+PRDISP SMONTB,0,[[P2WORD,SMON4],[P2NWOR,SMON4],[PARGS,SMON4]\r
+[PNWORD,SMON5],[PCHSTR,SMON6]]\r
+\r
+\f\r
+; COMPILER'S MONAD?\r
+\r
+CIMON: PUSH P,A\r
+ GETYP A,A\r
+ PUSHJ P,CPTYPE\r
+ JUMPE A,CIMON1\r
+ POP P,A\r
+ JRST CEMPTY\r
+\r
+CIMON1: POP P,A\r
+ JRST YES\r
+\r
+; FUNCTION TO DECIDE IF FURTHER DECOMPOSITION POSSIBLE\r
+\r
+MFUNCTION MONAD,SUBR,MONAD?\r
+\r
+ ENTRY 1\r
+\r
+ MOVE B,AB ; CHECK PRIM TYPE\r
+ PUSHJ P,PTYPE\r
+ JUMPE A,ITRUTH ;RETURN ARGUMENT\r
+ SKIPE B,1(AB)\r
+ JRST @MONTBL(A) ;DISPATCH ON PTYPE\r
+ JRST ITRUTH\r
+\r
+PRDISP MONTBL,IFALSE,[[P2NWORD,MON1],[PNWORD,MON1],[PARGS,MON1]\r
+[PCHSTR,CHMON],[PTMPLT,TMPMON]]\r
+\r
+MON1: JUMPGE B,ITRUTH ;EMPTY VECTOR\r
+ JRST IFALSE\r
+\r
+CHMON: HRRZ B,(AB)\r
+ JUMPE B,ITRUTH\r
+ JRST IFALSE\r
+\r
+TMPMON: PUSHJ P,LNTMPL\r
+ JUMPE B,ITRUTH\r
+ JRST IFALSE\r
+\r
+CISTRU: GETYP A,A ; COMPILER CALL\r
+ PUSHJ P,ISTRUC\r
+ JRST NO\r
+ JRST YES\r
+\r
+ISTRUC: PUSHJ P,SAT ; STORAGE TYPE\r
+ SKIPE A,PRMTYP(A)\r
+ AOS (P) ; SKIP IF WINS\r
+ POPJ P,\r
+\r
+; SUBR TO CHECK FOR LOCATIVE\r
+\r
+MFUNCTION %LOCA,SUBR,[LOCATIVE?]\r
+\r
+ ENTRY 1\r
+ GETYP A,(AB) \r
+ PUSHJ P,LOCQQ\r
+ JRST IFALSE\r
+ JRST ITRUTH\r
+\r
+; SKIPS IF TYPE IN A IS A LOCATIVE\r
+\r
+LOCQ: GETYP A,(B) ; GET TYPE\r
+LOCQQ: PUSH P,A ; SAVE FOR LOCN/LOCD\r
+ PUSHJ P,SAT\r
+ MOVE A,PRMTYP(A)\r
+ JUMPE A,LOCQ1\r
+ SUB P,[1,,1]\r
+ TRNN A,-1\r
+LOCQ2: AOS (P)\r
+ POPJ P,\r
+\r
+LOCQ1: POP P,A ; RESTORE TYPE\r
+ CAIE A,TLOCN\r
+ CAIN A,TLOCD\r
+ JRST LOCQ2\r
+ POPJ P,\r
+\r
+\f\r
+; MUDDLE SORT ROUTINE\r
+\r
+; P-STACK OFFSETS MUDDLE SORT ROUTINE\r
+\r
+; P-STACK OFFSETS FOR THIS PROGRAM\r
+\r
+XCHNG==0 ; FLAG SAYING AN EXCHANGE HAS HAPPENED\r
+PLACE==-1 ; WHERE WE ARE NOW\r
+UTYP==-2 ; TYPE OF UNIFORM VECTOR\r
+DELT==-3 ; DIST BETWEEN COMPARERS\r
+\r
+MFUNCTION SORT,SUBR\r
+\r
+ ENTRY\r
+\r
+ HLRZ 0,AB ; CHECK FOR ENOUGH ARGS\r
+ CAILE 0,-4\r
+ JRST TFA\r
+ GETYP A,(AB) ; 1ST MUST EITHER BE FALSE OR APPLICABLE\r
+ CAIN A,TFALSE\r
+ JRST SORT1 ; FALSE, OK\r
+ PUSHJ P,APLQ ; IS IT APPLICABLE\r
+ JRST NAPT ; NO, LOSER\r
+\r
+SORT1: MOVE B,AB\r
+ ADD B,[2,,2] ; BUMP TO POINT TO MAIN ARRAY\r
+ SETZB D,E ; 0 # OF STUCS AND LNTH\r
+\r
+SORT2: GETYP A,(B) ; GET ITS TYPE\r
+ PUSHJ P,PTYPE ; IS IT STRUCTURED?\r
+ MOVEI C,1 ; CHECK TYPE OF STRUC\r
+ CAIN A,PNWORD ; UVEC?\r
+ MOVEI C,0 ; YUP\r
+ CAIE A,PARGS\r
+ CAIN A,P2NWORD ; VECTOR\r
+ MOVNI C,1\r
+ JUMPG C,WTYP\r
+ PUSH TP,(B) ; PUSH IT\r
+ PUSH TP,1(B)\r
+ ADD B,[2,,2] ; GO ON\r
+ MOVEI A,1 ; DEFAULT REC SIZE\r
+ PUSHJ P,NXFIX ; SIZE OF RECORD?\r
+ HLRZ 0,-2(TP) ; -LNTH OF STUC\r
+ HRRZ A,(TP) ; LENGTH OF REC\r
+ IDIVI 0,(A) ; DIV TO GET - # OF RECS\r
+ SKIPN D ; PREV LENGTH EXIST?\r
+ MOVE D,0 ; NO USE THIS\r
+ CAME 0,D\r
+ JRST SLOSE0\r
+ MOVEI A,0 ; DEF REC SIZE\r
+ PUSHJ P,NXFIX ; AND OFFSET OF KEY\r
+ SUBI E,1\r
+ JUMPL B,SORT2 ; GO ON\r
+ HRRM E,4(TB) ; SAVE THAT IN APPROPRIATE PLACE\r
+\r
+ MOVE 0,3(TB)\r
+ CAMG 0,5(TB) ; CHECK FOR BAD OFFSET\r
+ JRST SLOSE3\r
+\r
+; NOW CHECK WHATEVER STUCTURE THIS IS IS UNIFORM AND HAS GOOD ELEMENTS\r
+\r
+ HLRE B,1(TB) ; COMP LENGTH\r
+ MOVNS B\r
+ HRRZ C,2(TB) ; GET VEC/UVEC FLAG\r
+ MOVEI D,(B)\r
+ ASH B,(C) ; FUDGE\r
+ JUMPE C,.+3 ; SKIP FOR UVEC\r
+ MOVE 0,[1,,1] ; ELSE FUDGE KEY OFFSET\r
+ ADDM 0,5(TB)\r
+ HRRZ 0,3(TB) ; GET REC LENGTH\r
+ IDIV D,0 ; # OF RECS\r
+ JUMPN E,SLOSE4\r
+ CAIG D,1 ; MORE THAN 1?\r
+ JRST SORTD ; NO, DONE ALREADY\r
+ GETYP 0,(AB) ; TYPE OF COMPARER\r
+ CAIE 0,TFALSE ; IF FALSE, STRUCT MUST CONTAIN FIX,FLOAT,ATOM OR STRING\r
+ JRST SORT3 ; USER SUPPLIED COMPARER, LET HIM WORRY\r
+\r
+; NOW CHECK OUT ELEMENT TYPES\r
+\r
+ JUMPN C,SORT5 ; JUMP IF GENERAL\r
+ MOVEI D,1(B) ; FIND END OF VECTOR\r
+ ADD D,1(TB) ; D POINTS TO END\r
+ PUSHJ P,TYPCH1 ; GET TYPE AND CHECK IT\r
+ JRST SORT6\r
+\r
+SORT5: MOVE D,1(TB) ; POINT TO VEC\r
+ ADD D,5(TB) ; INTO REC TO KEY\r
+ PUSHJ P,TYPCH1\r
+\r
+SAMELP: GETYP C,-1(D) ; GET TYPE\r
+ CAIE 0,(C) ; COMPARE TYPE\r
+ JRST SLOSE2\r
+ ADD D,3(TB) ; TO NEXT RECORD\r
+ JUMPL D,SAMELP\r
+\r
+SORT6: CAIE A,S1WORD ; 1 WORDS?\r
+ JRST SORT7\r
+ MOVEI E,INTSRT\r
+ MOVSI A,400000 ; SET UP MASK\r
+SORT9: PUSHJ P,ISORT\r
+ MOVE A,2(AB)\r
+ MOVE B,3(AB)\r
+ JRST FINIS\r
+\r
+SORT7: CAIE A,SATOM ; ATOMS?\r
+ JRST SORT8\r
+ MOVE E,[-3,,ATMSRT] ; SET UP FOR ATOMS\r
+ MOVE A,[430140,,3(D)] ; BIT POINTER FOR ATOMS\r
+ JRST SORT9\r
+\r
+SORT8: MOVE E,[1,,STRSRT] ; MUST BE STRING SORT\r
+ MOVE A,[430140,,(D)] ; BYTE POINTER FOR STRINGER\r
+ JRST SORT9\r
+\r
+; TABLES FOR RADIX SORT CHECKERS\r
+\r
+INTSRT==0\r
+ATMSRT==1\r
+STRSRT==2\r
+\r
+TST1: PUSHJ P,I.TST1\r
+ PUSHJ P,A.TST1\r
+ PUSHJ P,S.TST1\r
+\r
+TST2: PUSHJ P,I.TST2\r
+ PUSHJ P,A.TST2\r
+ PUSHJ P,S.TST2\r
+\r
+NXBIT: ROT A,-1\r
+ PUSHJ P,A.NXBI\r
+ PUSHJ P,S.NXBI\r
+\r
+PREBIT: ROT A,1\r
+ PUSHJ P,A.PREB\r
+ PUSHJ P,S.PREB\r
+\r
+ENDTST: SKIPGE A\r
+ TLOE A,40\r
+ TLOE A,40\r
+\r
+; INTEGER SORT SPECIFIC ROUTINES\r
+\r
+I.TST1: JUMPL A,I.TST3\r
+I.TST4: TDNE A,(D)\r
+ AOS (P)\r
+ POPJ P,\r
+\r
+I.TST2: JUMPL A,I.TST4\r
+I.TST3: TDNN A,(D)\r
+ AOS (P)\r
+ POPJ P,\r
+\r
+; ATOM SORT SPECIFIC ROUTINES\r
+\r
+A.TST1: MOVE D,(D) ; GET AN ATOM\r
+ CAMG E,D ; SKIP IF NOT EXHAUSTED\r
+ POPJ P,\r
+ TLZ A,40 ; TELL A BIT HAS HAPPENED\r
+ LDB D,A ; GET THE BIT\r
+ SKIPE D\r
+ AOS (P) ; SKIP IF ON\r
+ POPJ P,\r
+\r
+A.TST2: PUSHJ P,A.TST1 ; USE OTHER ROUTINE\r
+ AOS (P)\r
+ POPJ P,\r
+\r
+A.NXBI: TLNN A,770000 ; CHECK FOR WORD CHANGE\r
+ SUB E,[1,,0] ; FIX WORD CHECKER\r
+ IBP A\r
+ POPJ P,\r
+\r
+A.PREB: ADD A,[10000,,] ; AH FOR A DECR BYTE POINTER\r
+ SKIPG A\r
+ CAMG A,[437777,,-1] ; SKIP IF BACKED OVER WORD\r
+ POPJ P,\r
+ TLZ A,770000 ; CLOBBER POSIT FIELD\r
+ SUBI A,1 ; DECR WORD POS FIELD\r
+ ADD E,[1,,0] ; AND FIX WORD HACKER\r
+ POPJ P,\r
+\r
+; STRING SPECIFIC SORT ROUTINES\r
+\r
+S.TST1: HRLZ 0,-1(D) ; LENGTH OF STRING\r
+ IMULI 0,7 ; IN BITS\r
+ HRRI 0,-1 ; MAKE SURE BIGGER RH\r
+ CAMG 0,E ; SKIP IF MORE BITS LEFT\r
+ POPJ P, ; DON TSKIP\r
+ TLZ A,40 ; BIT FOUND\r
+ HLRZ 0,(D) ; CHECK FOR SIMPLE CASE\r
+ HRRZ D,(D) ; POINT TO STRING\r
+ CAIN 0,440700 ; SKIP IF HAIRY\r
+ JRST S.TST3\r
+\r
+ PUSH P,A ; SAVE BYTER\r
+ MOVEI A,440700 ; COMPUTE BITS NOT USED 1ST WORD\r
+ SUBI A,@0\r
+ HLRZ 0,(P) ; GET BIT POINTER\r
+ SUBI 0,(A) ; UPDATE POS FIELD\r
+ JUMPGE 0,.+2 ; NO NEED FOR NEXT WORD\r
+ ADD 0,[1,,440000]\r
+ MOVSS 0\r
+ HRRZ A,(P) ; REBUILD BYTE POINTER\r
+ ADDI 0,(A)\r
+ LDB 0,0 ; GET THE DAMN BYTE\r
+ POP P,A\r
+ JRST .+2\r
+\r
+S.TST3: LDB 0,A ; GET BYTE FOR EASY CASE\r
+ SKIPE 0\r
+ AOS (P)\r
+ POPJ P,\r
+\r
+S.TST2: PUSHJ P,S.TST1\r
+ AOS (P)\r
+ POPJ P,\r
+\r
+S.NXBI: IBP A ; BUMP BYTER\r
+ TLNN A,770000 ; SKIP IF NOT END BIT\r
+ IBP A ; SKIP END BIT (NOT USED IN ASCII STRINGS)\r
+ ADD E,[1,,0] ; COUNT BIT\r
+ POPJ P,\r
+\r
+S.PREB: SUB E,[1,,0] ; DECR CHAR COUNT\r
+ ADD A,[10000,,0] ; PLEASE GIVE ME A DECRBYTEPNTR\r
+ SKIPG A\r
+ CAMG A,[437777,,-1]\r
+ POPJ P,\r
+ TLC A,450000 ; POINT TO LAST USED BIT IN WORD\r
+ SUBI A,1\r
+ POPJ P,\r
+\r
+; SIMPLE RADIX EXCHANGE\r
+\r
+ISORT: MOVE B,1(TB) ; START OF VECTOR\r
+ HLRE D,B ; COMPUTE POINTER TO END OF IT\r
+ SUBM B,D ; FIND END\r
+ MOVEI C,(D)\r
+\r
+ISORT1: PUSH TP,(TB)\r
+ PUSH TP,C\r
+ MOVE 0,C ; SEE IF HAVE MET AT MIDDLE\r
+ SUB 0,3(TB)\r
+ ANDI 0,-1\r
+ CAIGE 0,(B)\r
+ JRST ISORT7 ; HAVE MET, LEAVE\r
+ PUSH TP,(TB) ; SAVE OTHER POINTER\r
+ PUSH TP,B\r
+\r
+ INTGO\r
+ MOVE B,(TP) ; IN CASE MOVED\r
+ MOVE C,-2(TP)\r
+\r
+ISORT3: HRRZ D,5(TB) ; OFFSET TO KEY\r
+ ADDI D,(B) ; POINT TO KEY\r
+ XCT TST1(E) ; CHECK FOR LOSER\r
+ JRST ISORT4\r
+ SUB C,3(TB) ; IS THERE ONE TO EXCHANGE WITH\r
+ HRRZ D,5(TB)\r
+ ADDI D,(C)\r
+ XCT TST2(E) ; SKIP IF A POSSIBLE EXCHANGE\r
+ JRST ISORT2 ; NO EXCH, KEEP LOOKING\r
+\r
+ PUSHJ P,EXCHM ; DO THE EXCHANGE\r
+\r
+ISORT4: ADD B,3(TB) ; HAVE EXCHANGED, MOVE ON\r
+ISORT2: CAME B,C ; MET?\r
+ JRST ISORT3 ; MORE TO CHECK\r
+ XCT NXBIT(E) ; NEXT BIT\r
+ MOVE B,(TP) ; RESTORE TOP POINTER\r
+ SUB TP,[2,,2] ; FLUSH IT\r
+ XCT ENDTST(E)\r
+ JRST ISORT6\r
+ PUSHJ P,ISORT1 ; SORT SUB AREA\r
+ MOVE C,(TP) ; AND OTHER SUB AREA\r
+ PUSHJ P,ISORT1\r
+ISORT6: XCT PREBIT(E)\r
+ISORT7: MOVE B,(TP)\r
+ SUB TP,[2,,2]\r
+ POPJ P,\r
+\r
+; SCHELL SORT FOR USER SUPPLIED COMPARER\r
+\r
+SORT3: ADDI D,1\r
+ ASH D,-1 ; COMPUTE INITIAL D\r
+ PUSH P,D ; AND SAVE IT\r
+ PUSH P,[0] ; MAY HOLD UTYPE OF VECTOR\r
+ HRRZ 0,(TB) ; 0 NON ZERO MEANS GEN VECT\r
+ JUMPN 0,SSORT1 ; DONT COMPUTE UTYPE\r
+ HLRE C,1(TB)\r
+ HRRZ D,1(TB) ; FIND TYPE\r
+ SUBI D,(C)\r
+ GETYP D,(D)\r
+ MOVSM D,(P) ; AND SAVE\r
+SSORT1: PUSH P,[0] ; CURRENT PLACE IN VECTOR\r
+ PUSH P,[0] ; EXCHANGE FLAG\r
+ PUSH TP,[0]\r
+ PUSH TP,[0]\r
+\r
+; OUTER LOOP STARTS HERE\r
+\r
+OUTRLP: SETZM XCHNG(P) ; NO EXHCANGE YET\r
+ SETZM PLACE(P)\r
+\r
+INRLP: PUSH TP,(AB) ; PUSH USER COMPARE FCN\r
+ PUSH TP,1(AB)\r
+ MOVE C,PLACE(P) ; GET CURRENT PLACE\r
+ ADD C,1(TB) ; ADD POINTER TO VEC IN\r
+ ADD C,5(TB) ; OFFSET TO KEY\r
+ PUSHJ P,GETELM\r
+ MOVE D,3(TB)\r
+ IMUL D,DELT(P) ; TIMES WORDS PER REC\r
+ ADD C,D\r
+ PUSHJ P,GETELM\r
+ MCALL 3,APPLY ; APPLY IT\r
+ GETYP 0,A ; TYPE OF RETURN\r
+ CAIN 0,TFALSE ; SKIP IF MUST CHANGE\r
+ JRST INRLP1\r
+\r
+ MOVE C,1(TB) ; POINT TO START\r
+ ADD C,PLACE(P)\r
+ MOVE B,3(TB)\r
+ IMUL B,DELT(P)\r
+ ADD B,C\r
+ PUSHJ P,EXCHM ; EXCHANGE THEM\r
+ SETOM XCHNG(P) ; SAY AN EXCHANGE TOOK PLACE\r
+\r
+INRLP1: MOVE C,3(TB) ; GET OFFSET\r
+ ADDB C,PLACE(P)\r
+ MOVE D,3(TB)\r
+ IMUL D,DELT(P)\r
+ ADD C,D ; CHECK FOR OVERFLOW\r
+ ADD C,1(TB)\r
+ JUMPL C,INRLP\r
+ SKIPE XCHNG(P) ; ANY EXCHANGES?\r
+ JRST OUTRLP ; YES, RESET PLACE AND GO\r
+ SOSG D,DELT(P) ; SKIP IF DIST WAS 1\r
+ JRST SORTD\r
+ ADDI D,2 ; COMPUTE NEW DIST\r
+ ASH D,-1\r
+ MOVEM D,DELT(P)\r
+ JRST OUTRLP\r
+\r
+SORTD: MOVE A,2(AB) ; DONE, RET 1ST STRUC\r
+ MOVE B,3(AB)\r
+ JRST FINIS\r
+\r
+; ROUTINE TO GET NEXT ARG IF ITS FIX\r
+\r
+NXFIX: JUMPGE B,NXFIX1 ; NONE LEFT, USE DEFAULT\r
+ GETYP 0,(B) ; TYPE\r
+ CAIE 0,TFIX ; FIXED?\r
+ JRST NXFIX1 ; NO, USE DEFAULT\r
+ MOVE A,1(B) ; GET THE NUMBER\r
+ ADD B,[2,,2] ; BUMP TO NEXT ARG\r
+NXFIX1: HRLI C,TFIX\r
+ TRNE C,-1 ; SKIP IF UV\r
+ ASH A,1 ; FUDGE FOR VEC/UVEC\r
+ HRLI A,(A)\r
+ PUSH TP,C\r
+ PUSH TP,A\r
+ POPJ P,\r
+\r
+GETELM: SKIPN A,UTYP-1(P) ; SKIP IF UVECT\r
+ MOVE A,-1(C) ; GGET GEN TYPE\r
+ PUSH TP,A\r
+ PUSH TP,(C)\r
+ POPJ P,\r
+\r
+TYPCH1: GETYP A,-1(D) ; GET TYPE\r
+ MOVEI 0,(A) ; SAVE IN 0\r
+ PUSHJ P,SAT ; AND SAT\r
+ CAIE A,SCHSTR ; STRING\r
+ CAIN A,SATOM\r
+ POPJ P,\r
+ CAIN A,S1WORD ; 1-WORD GOODIE\r
+ POPJ P,\r
+ JRST SLOSE1\r
+\r
+; HERE TO DO EXCHANGE\r
+\r
+EXCHM: PUSH P,E\r
+ PUSH P,A ; SAVE VITAL ACS\r
+ PUSH P,B\r
+ PUSH P,C\r
+ SUB B,1(TB) ; COMPUTE RECORD #\r
+ HLRZS B ; TO RH\r
+ HRRZ 0,3(TB) ; GET REC LENGTH\r
+ IDIV B,0 ; DIV BY REC LENGTH\r
+ MOVE C,(P)\r
+ SUB C,1(TB) ; SAME FOR C\r
+ HLRZS C\r
+ IDIV C,0 ; NOW HAVE OTHER RECORD\r
+\r
+ HRRE D,4(TB) ; - # OF STUCS\r
+ MOVSI D,(D) ; MAKE AN AOBJN POINTER\r
+ HRRI D,(TB) ; TO TEMPPS\r
+\r
+RECLP: HRRZ 0,3(D) ; GET REC LENGTH\r
+ MOVN E,3(D) ; NOW AOBJN TO REC\r
+ MOVSI E,(E)\r
+ HRR E,1(D)\r
+ MOVEI A,(C) ; COMP START OF REC\r
+ IMUL A,0 ; TIMES REC LENGTH\r
+ ADDI E,(A)\r
+ MOVEI A,(B)\r
+ IMUL A,0\r
+ ADD A,1(D) ; POINT TO OTHER RECORD\r
+\r
+EXCHLP: EXCH 0,(A)\r
+ EXCH 0,(E)\r
+ EXCH 0,(A)\r
+ ADDI A,1\r
+ AOBJN E,EXCHLP\r
+\r
+ ADD D,[1,,6] ; TO NEXT STRUC\r
+ JUMPL D,RECLP ; IF MORE\r
+\r
+ POP P,C\r
+ POP P,B\r
+ POP P,A\r
+ POP P,E\r
+ POPJ P,\r
+\f\r
+; FUNCTION TO DETERMINE MEMBERSHIP IN LISTS AND VECTORS\r
+\r
+MFUNCTION MEMBER,SUBR\r
+\r
+ MOVE E,[PUSHJ P,EQLTST] ;TEST ROUTINE IN E\r
+ JRST MEMB\r
+\r
+MFUNCTION MEMQ,SUBR\r
+\r
+ MOVE E,[PUSHJ P,EQTST] ;EQ TESTER\r
+\r
+MEMB: ENTRY 2\r
+ MOVE B,AB ;POINT TO FIRST ARG\r
+ PUSHJ P,PTYPE ;CHECK PRIM TYPE\r
+ ADD B,[2,,2] ;POINT TO 2ND ARG\r
+ PUSHJ P,PTYPE\r
+ JUMPE A,WTYP2 ;2ND WRONG TYPE\r
+ PUSH TP,(AB)\r
+ PUSH TP,1(AB)\r
+ MOVE C,2(AB) ; FOR TUPLE CASE\r
+ SKIPE B,3(AB) ;GOBBLE LIST VECTOR ETC. POINTER\r
+ PUSHJ P,@MEMTBL(A) ;DISPATCH\r
+ JRST IFALSE ;OR REPORT LOSSAGE\r
+ JRST FINIS\r
+\r
+PRDISP MEMTBL,IWTYP2,[[P2WORD,MEMLST],[PNWORD,MUVEC],[P2NWORD,MEMVEC]\r
+[PARGS,MEMTUP],[PCHSTR,MEMCH],[PTMPLT,MEMTMP]]\r
+\r
+\r
+\r
+MEMLST: MOVSI 0,TLIST ;SET B'S TYPE TO LIST\r
+ MOVEM 0,BSTO(PVP)\r
+ JUMPE B,MEMLS6 ; EMPTY LIST LOSE IMMEDIATE\r
+\r
+MEMLS1: INTGO ;CHECK INTERRUPTS\r
+ MOVEI C,(B) ;COPY POINTER\r
+ GETYP D,(C) ;GET TYPE\r
+ MOVSI A,(D) ;COPY\r
+ CAIE D,TDEFER ;DEFERRED?\r
+ JRST MEMLS2\r
+ MOVE C,1(C) ;GET DEFERRED DATUM\r
+ GETYPF A,(C) ;GET FULL TYPE WORD\r
+MEMLS2: MOVE C,1(C) ;GET DATUM\r
+ XCT E ;DO THE COMPARISON\r
+ JRST MEMLS3 ;NO MATCH\r
+ MOVSI A,TLIST\r
+MEMLS5: AOS (P)\r
+MEMLS6: SETZM BSTO(PVP) ;RESET B'S TYPE\r
+ POPJ P,\r
+\r
+MEMLS3: HRRZ B,(B) ;STEP THROGH\r
+ JUMPN B,MEMLS1 ;STILL MORE TO DO\r
+MEMLS4: MOVSI A,TFALSE ;RETURN FALSE\r
+ JRST MEMLS6 ;RETURN 0\r
+\r
+MEMTUP: HRRZ A,C\r
+ TLOA A,TARGS\r
+MEMVEC: MOVSI A,TVEC ;CLOBBER B'S TYPE TO VECTOR\r
+ JUMPGE B,MEMLS4 ;EMPTY VECTOR\r
+ MOVEM A,BSTO(PVP)\r
+\r
+MEMV1: INTGO ;CHECK FOR INTS\r
+ GETYPF A,(B) ;GET FULL TYPE\r
+ MOVE C,1(B) ;AND DATA\r
+ XCT E ;DO COMPARISON INS\r
+ JRST MEMV2 ;NOT EQUAL\r
+ MOVE A,BSTO(PVP)\r
+ JRST MEMLS5 ;RETURN WITH POINTER\r
+\f\r
+MEMV2: ADD B,[2,,2] ;INCREMENT AND GO\r
+ JUMPL B,MEMV1 ;STILL WINNING\r
+MEMV3: MOVEI B,0\r
+ JRST MEMLS4 ;AND RETURN FALSE\r
+\r
+MUVEC: JUMPGE B,MEMLS4\r
+ GETYP A,-1(TP) ;GET TYPE OF GODIE\r
+ HLRE C,B ;LOOK FOR UNIFORM TYPE\r
+ SUBM B,C ;DOPE POINTER TO C\r
+ GETYP C,(C) ;GET THE TYPE\r
+ CAIE A,(C) ;ARE THEY THE SAME?\r
+ JRST MEMLS4 ;NO, LOSE\r
+ MOVSI A,TUVEC\r
+ CAIN 0,SSTORE\r
+ MOVSI A,TSTORA\r
+ PUSH P,A\r
+ MOVEM A,BSTO(PVP)\r
+ MOVSI A,(C) ;TYPE TO LH\r
+ PUSH P,A ; SAVE FOR EACH TEST\r
+\r
+MUVEC1: INTGO ;CHECK OUT INTS\r
+ MOVE C,(B) ;GET DATUM\r
+ MOVE A,(P) ; GET TYPE\r
+ XCT E ;COMPARE\r
+ AOBJN B,MUVEC1 ;LOOP TO WINNAGE\r
+ SUB P,[1,,1]\r
+ POP P,A\r
+ JUMPGE B,MEMV3 ;LOSE RETURN\r
+\r
+MUVEC2: JRST MEMLS5\r
+\r
+\r
+MEMCH: GETYP A,-1(TP) ;IS ARG A SINGLE CHAR\r
+ CAIE A,TCHRS ;SKIP IF POSSIBLE WINNER\r
+ JRST MEMSTR\r
+ MOVEI 0,(C)\r
+ MOVE D,(TP) ; AND CHAR\r
+\r
+MEMCH1: SOJL 0,MEMV3\r
+ MOVE E,B\r
+ ILDB A,B\r
+ CAIE A,(D) ;CHECK IT\r
+ SOJA C,MEMCH1\r
+\r
+MEMCH2: MOVE B,E\r
+ MOVE A,C\r
+ JRST MEMLS5\r
+\r
+MEMSTR: CAME E,[PUSHJ P,EQLTST]\r
+ JRST MEMV3\r
+ HLRZ A,C\r
+ CAIE A, TCHSTR ; A SHOULD HAVE TCHSTR IN RIGHT HALF\r
+ JRST MEMV3\r
+ MOVEI 0,(C) ; GET # OF CHAR INTO 0\r
+ ILDB D,(TP)\r
+ PUSH P,D ; PUTS 1ST CHAR OF 1ST ARG ONTO STACK\r
+\r
+MEMST1: SOJL 0,MEMLS ; HUNTS FOR FIRST MATCHING CHAR\r
+ MOVE E,B\r
+ ILDB A,B\r
+ CAME A,(P)\r
+ SOJA C,MEMST1 ; MATCH FAILS TRY NEXT\r
+\r
+ PUSH P,B\r
+ PUSH P,E\r
+ PUSH P,C\r
+ PUSH P,0\r
+ MOVE E,(TP) ; MATCH WINS SAVE OLD VALUES FOR FAILING LOOP\r
+ HRRZ C,-1(TP) ; LENGTH OF 1ARG\r
+MEMST2: SOJE C,MEMWN ; WON -RAN OUT OF 1ARG FIRST-\r
+ SOJL MEMLSR ; LOST -RAN OUT OF 2ARG-\r
+ ILDB A,B\r
+ ILDB D,E\r
+ CAIN A,(D) ; SKP IF POSSIBLY LOST -BACK TO MEMST1-\r
+ JRST MEMST2\r
+\r
+ POP P,0\r
+ POP P,C\r
+ POP P,E\r
+ POP P,B\r
+ SOJA C,MEMST1\r
+\r
+MEMWN: MOVE B,-2(P) ; SETS UP ARGS LIKE MEMCH2 - HAVE WON\r
+ MOVE A,-1(P)\r
+ SUB P,[5,,5]\r
+ JRST MEMLS5\r
+\r
+MEMLSR: SUB P,[5,,5]\r
+ JRST MEMV3\r
+\r
+MEMLS: SUB P,[1,,1]\r
+ JRST MEMV3\r
+\r
+; MEMBERSHIP FOR TEMPLATE HACKER\r
+\r
+MEMTMP: GETYP 0,(B) ; GET REAL SAT\r
+ PUSH P,E\r
+ PUSH P,0\r
+ PUSH TP,A\r
+ PUSH TP,B ; SAVE GOOEIE\r
+ PUSHJ P,TM.LN1 ; GET LENGTH\r
+ MOVEI B,(B)\r
+ HLRZ A,(TP) ; FUDGE FOR REST\r
+ SUBI B,(A)\r
+ PUSH P,B ; SAVE LENGTH\r
+ PUSH P,[-1]\r
+ POP TP,B\r
+ POP TP,A\r
+ MOVEM A,BSTO+1(PVP)\r
+\r
+MEMTM1: SETZM BSTO(PVP)\r
+ AOS C,(P)\r
+ SOSGE -1(P)\r
+ JRST MEMTM2\r
+ MOVE 0,-2(P)\r
+ PUSHJ P,TMPLNT ; GET ITEM\r
+ EXCH C,B ; VALUE TO C, POINTER BACK TO B\r
+ MOVE E,-3(P)\r
+ MOVSI 0,TTMPLT\r
+ MOVEM 0,BSTO(PVP)\r
+ XCT E\r
+ JRST MEMTM1\r
+\r
+ HRL B,(P) ; DO APPROPRIATE REST\r
+ AOS -4(P)\r
+MEMTM2: SUB P,[4,,4]\r
+ MOVSI A,TTMPLT\r
+ SETZM BSTO(PVP)\r
+ POPJ P,\r
+\r
+EQTST: GETYP A,A\r
+ GETYP 0,-1(TP)\r
+ CAMN C,(TP) ;CHECK VALUE\r
+ CAIE 0,(A) ;AND TYPE\r
+ POPJ P,\r
+ JRST CPOPJ1\r
+\r
+EQLTST: PUSH TP,BSTO(PVP)\r
+ PUSH TP,B\r
+ PUSH TP,A\r
+ PUSH TP,C\r
+ SETZM BSTO(PVP)\r
+ PUSH P,E ;SAVE INS\r
+ MOVEI C,-5(TP) ;SET UP CALL TO IEQUAL\r
+ MOVEI D,-1(TP)\r
+ AOS -1(P) ;ASSUME SKIP\r
+ PUSHJ P,IEQUAL ;GO INO EQUAL\r
+ SOS -1(P) ;UNDO SKIP\r
+ SUB TP,[2,,2] ;AND POOP OF CRAP\r
+ POP TP,B\r
+ POP TP,BSTO(PVP)\r
+ POP P,E\r
+ POPJ P,\r
+\r
+; COMPILER MEMQ AND MEMBER\r
+\r
+CIMEMB: SKIPA E,[PUSHJ P,EQLTST]\r
+\r
+CIMEMQ: MOVE E,[PUSHJ P,EQTST]\r
+ SUBM M,(P)\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ GETYP A,C\r
+ PUSHJ P,CPTYPE\r
+ JUMPE A,COMPERR\r
+ MOVE B,D ; STRUCT TO B\r
+ PUSHJ P,@MEMTBL(A)\r
+ TDZA 0,0 ; FLAG NO SKIP\r
+ MOVEI 0,1 ; FLAG SKIP\r
+ SUB TP,[2,,2]\r
+ JUMPE 0,NOM\r
+ SOS (P) ; SKIP RETURN\r
+ JRST MPOPJ\r
+\f\r
+\r
+; FUNCTION TO RETURN THE TOP OF A VECTOR , CSTRING OR UNIFORM VECTOR\r
+\r
+MFUNCTION TOP,SUBR\r
+\r
+ ENTRY 1\r
+\r
+ MOVE B,AB ;CHECK ARG\r
+ PUSHJ P,PTYPE\r
+ MOVEI E,(A)\r
+ MOVE A,(AB)\r
+ MOVE B,1(AB)\r
+ PUSHJ P,@TOPTBL(E) ;DISPATCH\r
+ JRST FINIS\r
+\r
+PRDISP TOPTBL,IWTYP1,[[PNWORD,UVTOP],[P2NWORD,VTOP],[PCHSTR,CHTOP],[PARGS,ATOP]\r
+[PTMPLT,BCKTOP]]\r
+\r
+BCKTOP: MOVEI B,(B) ; FIX UP POINTER\r
+ MOVSI A,TTMPLT\r
+ POPJ P,\r
+\r
+UVTOP: SKIPA A,$TUVEC\r
+VTOP: MOVSI A,TVEC\r
+ CAIN 0,SSTORE\r
+ MOVSI A,TSTORA\r
+ HLRE C,B ;AND -LENGTH\r
+ HRRZS B\r
+ SUB B,C ;POINT TO DOPE WORD\r
+ HLRZ D,1(B) ;TOTAL LENGTH\r
+ SUBI B,-2(D) ;POINT TO TOP\r
+ MOVNI D,-2(D) ;-LENGTH\r
+ HRLI B,(D) ;B NOW POINTS TO TOP\r
+ POPJ P,\r
+\r
+CHTOP: PUSH TP,A\r
+ PUSH TP,B\r
+ LDB 0,[360600,,(TP)] ; POSITION FIELD\r
+ LDB E,[300600,,(TP)] ; AND SIZE FILED\r
+ IDIVI 0,(E) ; 0/ BYTES IN 1ST WORD\r
+ MOVEI C,36. ; BITS PER WORD\r
+ IDIVI C,(E) ; BYTES PER WORD\r
+ PUSH P,C\r
+ SUBM C,0 ; UNUSED BYTES I 1ST WORD\r
+ ADD 0,-1(TP) ; LENGTH OF WORD BOUNDARIED STRING\r
+ MOVEI C,-1(TP) ; GET DOPE WORD\r
+ PUSHJ P,BYTDOP\r
+ HLRZ C,(A) ; GET LENGTH\r
+ SUBI A,-1(C) ; START +1\r
+ MOVEI B,(A) ; SETUP BYTER\r
+ HRLI B,440000\r
+ SUB A,(TP) ; WORDS DIFFERENT\r
+ IMUL A,(P) ; CHARS EXTRA\r
+ SUBM 0,A ; FINAL TOTAL TO A\r
+ HRLI A,TCHSTR\r
+ POP P,C\r
+ DPB E,[300600,,B]\r
+ SUB TP,[2,,2]\r
+ POPJ P,\r
+\f\r
+\r
+\r
+ATOP:\r
+\r
+GETATO: HLRE C,B ;GET -LENGTH\r
+ HRROS B\r
+ SUB B,C ;POINT PAST\r
+ GETYP 0,(B) ;GET NEXT TYPE (ASSURED OF BEING EITHER TINFO OR TENTRY)\r
+ CAIN 0,TENTRY ;IF ENTRY\r
+ JRST EASYTP ;WANT UNEVALUATED ARGS\r
+ HRRE C,(B) ;ELSE-- GET NO. OF ARGS (*-2)\r
+ SUBI B,(C) ;GO TO TOP\r
+ TLCA B,-1(C) ;STORE NUMBER IN TOP POINTER\r
+EASYTP: MOVE B,FRAMLN+ABSAV(B) ;GET ARG POINTER\r
+ HRLI A,TARGS\r
+ POPJ P,\r
+\r
+; COMPILERS ENTRY TO TOP\r
+\r
+CITOP: PUSHJ P,CPTYEE\r
+ CAIN E,P2WORD ; LIST?\r
+ JRST COMPERR\r
+ PUSHJ P,@TOPTBL(E)\r
+ JRST MPOPJ\r
+\r
+; FUNCTION TO CLOBBER THE CDR OF A LIST\r
+\r
+MFUNCTION PUTREST,SUBR,[PUTREST]\r
+ ENTRY 2\r
+\r
+ MOVE B,AB ;COPY ARG POINTER\r
+ PUSHJ P,PTYPE ;CHECK IT\r
+ CAIE A,P2WORD ;LIST?\r
+ JRST WTYP1 ;NO, LOSE\r
+ ADD B,[2,,2] ;AND NEXT ONE\r
+ PUSHJ P,PTYPE\r
+ CAIE A,P2WORD\r
+ JRST WTYP2 ;NOT LIST, LOSE\r
+ HRRZ B,1(AB) ;GET FIRST\r
+ MOVE D,3(AB) ;AND 2D LIST\r
+ CAIL B,HIBOT\r
+ JRST PURERR\r
+ HRRM D,(B) ;CLOBBER\r
+ MOVE A,(AB) ;RETURN CALLED TYPE\r
+ JRST FINIS\r
+\r
+\f\r
+\r
+; FUNCTION TO BACK UP A VECTOR, UVECTOR OR CHAR STRING\r
+\r
+MFUNCTION BACK,SUBR\r
+\r
+ ENTRY\r
+\r
+ MOVEI C,1 ;ASSUME BACKING UP ONE\r
+ JUMPGE AB,TFA ;NO ARGS IS TOO FEW\r
+ CAML AB,[-2,,0] ;SKIP IF MORE THAN 2 ARGS\r
+ JRST BACK1 ;ONLY ONE ARG\r
+ GETYP A,2(AB) ;GET TYPE\r
+ CAIE A,TFIX ;MUST BE FIXED\r
+ JRST WTYP2\r
+ SKIPGE C,3(AB) ;GET NUMBER\r
+ JRST OUTRNG\r
+ CAMGE AB,[-4,,0] ;SKIP IF WINNING NUMBER OF ARGS\r
+ JRST TMA\r
+BACK1: MOVE B,AB ;SET UP TO FIND TYPE\r
+ PUSHJ P,PTYPE ;GET PRIM TYPE\r
+ MOVEI E,(A)\r
+ MOVE A,(AB)\r
+ MOVE B,1(AB) ;GET DATUM\r
+ PUSHJ P,@BCKTBL(E)\r
+ JRST FINIS\r
+\r
+PRDISP BCKTBL,IWTYP2,[[PNWORD,BACKU],[P2NWORD,BACKV],[PCHSTR,BACKC],[PARGS,BACKA]\r
+[PTMPLT,BCKTMP]]\r
+\r
+BACKV: LSH C,1 ;GENERAL, DOUBLE AMOUNT\r
+ SKIPA A,$TVEC\r
+BACKU: MOVSI A,TUVEC\r
+ CAIN 0,SSTORE\r
+ MOVSI A,TSTORA\r
+ HRLI C,(C) ;TO BOTH HALVES\r
+ SUB B,C ;BACK UP VECTOR POINTER\r
+ HLRE C,B ;FIND OUT IF OVERFLOW\r
+ SUBM B,C ;DOPE POINTER TO C\r
+ HLRZ D,1(C) ;GET LENGTH\r
+ SUBI C,-2(D) ;POINT TO TOP\r
+ ANDI C,-1\r
+ CAILE C,(B) ;SKIP IF A WINNER\r
+ JRST OUTRNG ;COMPLAIN\r
+BACKUV: POPJ P,\r
+\r
+BCKTMP: MOVSI C,(C)\r
+ SUB B,C ; FIX UP POINTER\r
+ JUMPL B,OUTRNG\r
+ MOVSI A,TTMPLT\r
+ POPJ P,\r
+\r
+BACKC: PUSH TP,A\r
+ PUSH TP,B\r
+ ADDI A,(C) ; NEW LENGTH\r
+ HRLI A,TCHSTR\r
+ PUSH P,A ; SAVE COUNT\r
+ LDB E,[300600,,B] ;BYTE SIZE\r
+ MOVEI 0,36. ;BITS PER WORD\r
+ IDIVI 0,(E) ;DIVIDE TO FIND BYTES/WORD\r
+ IDIV C,0 ;C/ WORDS BACK, D/BYTES BACK\r
+ SUBI B,(C) ;BACK WORDS UP\r
+ JUMPE D,CHBOUN ;CHECK BOUNDS\r
+\r
+ IMULI 0,(E) ;0/ BITS OCCUPIED BY FULL WORD\r
+ LDB A,[360600,,B] ;GET POSITION FILED\r
+BACKC2: ADDI A,(E) ;BUMP\r
+ CAIGE A,36.\r
+ JRST BACKC1 ;O.K.\r
+ SUB A,0\r
+ SUBI B,1 ;DECREMENT POINTER PART\r
+BACKC1: SOJG D,BACKC2 ;DO FOR ALL BYTES\r
+\f\r
+\r
+\r
+ DPB A,[360600,,B] ;FIX UP POINT BYTER\r
+CHBOUN: MOVEI C,-1(TP)\r
+ PUSHJ P,BYTDOP ; FIND DOPE WORD\r
+ HLRZ C,(A)\r
+ SUBI A,-1(C) ; POINT TO TOP\r
+ MOVE C,B ; COPY BYTER\r
+ IBP C\r
+ CAILE A,(C) ; SKIP IF OK\r
+ JRST OUTRNG\r
+ POP P,A ; RESTORE COUNT\r
+ SUB TP,[2,,2]\r
+ POPJ P,\r
+\r
+\r
+BACKA: LSH C,1 ;NUMBER TIMES 2\r
+ HRLI C,(C) ;TO BOTH HALVES\r
+ SUB B,C ;FIX POINTER\r
+ MOVE E,B ;AND SAVE\r
+ PUSHJ P,GETATO ;LOOK A T TOP\r
+ CAMLE B,E ;COMPARE\r
+ JRST OUTRNG\r
+ MOVE B,E\r
+ POPJ P,\r
+\r
+; COMPILER'S BACK\r
+\r
+CIBACK: PUSHJ P,CPTYEE\r
+ JUMPL C,OUTRNG\r
+ CAIN E,P2WORD\r
+ JRST COMPERR\r
+ PUSHJ P,@BCKTBL(E)\r
+ JRST MPOPJ\r
+\f\r
+MFUNCTION STRCOMP,SUBR\r
+\r
+ ENTRY 2\r
+\r
+ MOVE A,(AB)\r
+ MOVE B,1(AB)\r
+ MOVE C,2(AB)\r
+ MOVE D,3(AB)\r
+ PUSHJ P,ISTRCM\r
+ JRST FINIS\r
+\r
+ISTRCM: GETYP 0,A\r
+ CAIE 0,TCHSTR\r
+ JRST ATMCMP ; MAYBE ATOMS\r
+\r
+ GETYP 0,C\r
+ CAIE 0,TCHSTR\r
+ JRST WTYP2\r
+\r
+ MOVEI A,(A) ; ISOLATR LENGHTS\r
+ MOVEI C,(C)\r
+\r
+STRCO2: SOJL A,CHOTHE ; ONE STRING EXHAUSTED, CHECK OTHER\r
+ SOJL C,1BIG ; 1ST IS BIGGER\r
+ ILDB 0,B\r
+ ILDB E,D\r
+ CAIN 0,(E) ; SKIP IF DIFFERENT\r
+ JRST STRCO2\r
+ CAIL 0,(E) ; SKIP IF 2D BIGGER THAN 1ST\r
+ JRST 1BIG\r
+2BIG: MOVNI B,1\r
+ JRST RETFIX\r
+\r
+CHOTHE: JUMPN C,2BIG ; 2 IS BIGGER\r
+SM.CMP: TDZA B,B ; RETURN 0\r
+1BIG: MOVEI B,1\r
+RETFIX: MOVSI A,TFIX\r
+ POPJ P,\r
+\r
+ATMCMP: CAIE 0,TATOM ; COULD BE ATOM\r
+ JRST WTYP1 ; NO, QUIT\r
+ GETYP 0,C\r
+ CAIE 0,TATOM\r
+ JRST WTYP2\r
+\r
+ CAMN B,D ; SAME ATOM?\r
+ JRST SM.CMP\r
+ ADD B,[3,,3] ; SKIP VAL CELL ETC.\r
+ ADD D,[3,,3]\r
+\r
+ATMCM1: MOVE 0,(B) ; GET A WORD OF CHARS\r
+ CAME 0,(D) ; SAME?\r
+ JRST ATMCM3 ; NO, GET DIF\r
+ AOBJP B,ATMCM2\r
+ AOBJN D,ATMCM1 ; MORE TO COMPARE\r
+ JRST 1BIG ; 1ST IS BIGGER\r
+\r
+\r
+ATMCM2: AOBJP D,SM.CMP ; EQUAL\r
+ JRST 2BIG\r
+\r
+ATMCM3: LSH 0,-1 ; AVOID SIGN LOSSAGE\r
+ MOVE C,(D)\r
+ LSH C,-1\r
+ CAMG 0,C\r
+ JRST 2BIG\r
+ JRST 1BIG\r
+\r
+\f;ERROR COMMENTS FOR SOME PRIMITIVES\r
+\r
+OUTRNG: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE OUT-OF-BOUNDS\r
+ JRST CALER1\r
+\r
+WRNGUT: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE UNIFORM-VECTORS-TYPE-DIFFERS\r
+ JRST CALER1\r
+\r
+SLOSE0: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE VECTOR-LENGTHS-DIFFER\r
+ JRST CALER1\r
+\r
+SLOSE1: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE KEYS-WRONG-TYPE\r
+ JRST CALER1\r
+\r
+SLOSE2: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE KEY-TYPES-DIFFER\r
+ JRST CALER1\r
+\r
+SLOSE3: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE KEY-OFFSET-OUTSIDE-RECORD\r
+ JRST CALER1\r
+\r
+SLOSE4: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE NON-INTEGER-NO.-OF-RECORDS\r
+ JRST CALER1\r
+\r
+IIGETP: JRST IGETP ;FUDGE FOR MIDAS/STINK LOSSAGE\r
+IIPUTP: JRST IPUTP\r
+\r
+\f;SUPER USEFUL ERROR MESSAGES (USED BY WHOLE WORLD)\r
+\r
+WNA: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE WRONG-NUMBER-OF-ARGUMENTS\r
+ JRST CALER1\r
+\r
+TFA: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE TOO-FEW-ARGUMENTS-SUPPLIED\r
+ JRST CALER1\r
+\r
+TMA: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE TOO-MANY-ARGUMENTS-SUPPLIED\r
+ JRST CALER1\r
+\r
+WRONGT: \r
+WTYP: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE ARG-WRONG-TYPE\r
+ JRST CALER1\r
+\r
+IWTYP1:\r
+WTYP1: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE FIRST-ARG-WRONG-TYPE\r
+ JRST CALER1\r
+\r
+IWTYP2:\r
+WTYP2: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE SECOND-ARG-WRONG-TYPE\r
+ JRST CALER1\r
+\r
+BADTPL: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE BAD-TEMPLATE-DATA\r
+ JRST CALER1\r
+\r
+BADPUT: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE TEMPLATE-TYPE-VIOLATION\r
+ JRST CALER1\r
+\r
+WTYP3: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE THIRD-ARG-WRONG-TYPE\r
+ JRST CALER1\r
+\r
+CALER1: MOVEI A,1\r
+CALER: HRRZ C,FSAV(TB)\r
+ PUSH TP,$TATOM\r
+ CAMGE C,VECTOP\r
+ CAMGE C,VECBOT\r
+ SKIPA C,@-1(C) ; SUBRS AND FSUBRS\r
+ MOVE C,3(C) ; FOR RSUBRS\r
+ PUSH TP,C\r
+ ADDI A,1\r
+ ACALL A,ERROR\r
+ JRST FINIS\r
+ \r
+\r
+GETWNA: HLRZ B,(E)-2 ;GET LOSING COMPARE INSTRUCTION\r
+ CAIE B,(CAIE A,) ;AS EXPECTED ?\r
+ JRST WNA ;NO,\r
+ HRRE B,(E)-2 ;GET DESIRED NUMBER OF ARGS\r
+ HLRE A,AB ;GET ACTUAL NUMBER OF ARGS\r
+ CAMG B,A\r
+ JRST TFA\r
+ JRST TMA\r
+\r
+END\r
+\fTITLE PRINTER ROUTINE FOR MUDDLE\r
+\r
+RELOCATABLE\r
+\r
+.INSRT DSK:MUDDLE >\r
+\r
+.GLOBAL IPNAME,MTYO,FLOATB,RLOOKU,RADX,INAME,INTFCN,LINLN,DOIOTO,BFCLS1,ATOSQ,IGVAL\r
+.GLOBAL BYTPNT,OPNCHN,CHRWRD,IDVAL,CHARGS,CHFRM,CHLOCI,PRNTYP,PRTYPE,IBLOCK,WXCT\r
+.GLOBAL VECBOT,VAL,ITEM,INDIC,IOINS,DIRECT,TYPVEC,CHRPOS,LINPOS,ACCESS,PAGLN,ROOT,PROCID\r
+.GLOBAL BADCHN,WRONGD,CHNCLS,IGET,FNFFL,ILLCHO,BUFSTR,BYTDOP,6TOCHS,PURVEC,STBL,RXCT\r
+.GLOBAL TMPLNT,TD.LNT,MPOPJ,SSPEC1\r
+.GLOBAL CIPRIN,CIPRNC,CIPRN1,CPATM,CP1ATM,CPCATM,CPSTR,CP1STR,CPCSTR\r
+.GLOBAL CIFLTZ,CITERP,CIUPRS,CPCH\r
+\r
+BUFLNT==100 ; BUFFER LENGTH IN WORDS\r
+\r
+FLAGS==0 ;REGISTER USED TO STORE FLAGS\r
+CARRET==15 ;CARRIAGE RETURN CHARACTER\r
+ESCHAR=="\ ;ESCAPE CHARACTER\r
+SPACE==40 ;SPACE CHARACTER\r
+ATMBIT==200000 ;BIT SWITCH FOR ATOM-NAME PRINT\r
+NOQBIT==020000 ;SWITCH FOR NO ESCAPING OF OUTPUT (PRINC)\r
+SEGBIT==010000 ;SWITCH TO INDICATE PRINTING A SEGMENT\r
+SPCBIT==004000 ;SWITCH TO INDICATE "PRINT" CALL (PUT A SPACE AFTER)\r
+FLTBIT==002000 ;SWITCH TO INDICATE "FLATSIZE" CALL\r
+HSHBIT==001000 ;SWITCH TO INDICATE "PHASH" CALL\r
+TERBIT==000400 ;SWITCH TO INDICATE "TERPRI" CALL\r
+UNPRSE==000200 ;SWITCH TO INDICATE "UNPARSE" CALL\r
+ASCBIT==000100 ;SWITCH TO INDICATE USING A "PRINT" CHANNEL\r
+BINBIT==000040 ;SWITCH TO INDICATE USING A "PRINTB" CHANNEL\r
+PJBIT==400000\r
+C.BUF==1\r
+C.PRIN==2\r
+C.BIN==4\r
+C.OPN==10\r
+C.READ==40\r
+\r
+\r
+\fMFUNCTION FLATSIZE,SUBR\r
+ DEFINE FLTMAX\r
+ 4(B) TERMIN\r
+ DEFINE FLTSIZ\r
+ 2(B)TERMIN\r
+;FLATSIZE TAKES TWO OR THREE ARGUMENTS: THE FIRST IS AN OBJECT THE SECOND\r
+;IS THE MAXIMUM SIZE BEFORE IT GIVES UP AN RETURNS FALSE\r
+;THE THIRD (OPTIONAL) ARGUMENT IS A RADIX\r
+ ENTRY\r
+ CAMG AB,[-2,,0] ;CHECK NUMBER OF ARGS\r
+ CAMG AB,[-6,,0]\r
+ JRST WNA\r
+ PUSH P,3(AB)\r
+\r
+ GETYP A,2(AB)\r
+ CAIE A,TFIX\r
+ JRST WTYP2 ;SECOND ARG NOT FIX THEN LOSE\r
+\r
+ CAMG AB,[-4,,0] ;SEE IF THERE IS A RADIX ARGUMENT\r
+ JRST .+3 ; RADIX SUPPLIED\r
+ PUSHJ P,GTRADX ; GET THE RADIX FROM OUTCHAN\r
+ JRST FLTGO\r
+ GETYP A,4(AB) ;CHECK TO SEE THAT RADIX IS FIX\r
+ CAIE A,TFIX\r
+ JRST WTYP ;ERROR THIRD ARGUMENT WRONG TYPE\r
+ MOVE C,5(AB)\r
+ PUSHJ P,GETARG ; GET ARGS INTO A AND B\r
+FLTGO: POP P,D ; RESTORE FLATSIZE MAXIMUM\r
+ PUSHJ P,CIFLTZ\r
+ JFCL\r
+ JRST FINIS\r
+\r
+\r
+\r
+MFUNCTION UNPARSE,SUBR\r
+ DEFINE UPB\r
+ 0(B) TERMIN\r
+\r
+ ENTRY\r
+\r
+ JUMPGE AB,TFA\r
+ MOVE E,TP ;SAVE TP POINTER\r
+\r
+\r
+\r
+;TURN ON FLTBIT TO AVOID PRINTING LOSSAGE\r
+;TURN ON UNPRSE TO CAUSE CHARS TO BE STASHED\r
+ CAMG AB,[-2,,0] ;SKIP IF RADIX SUPPLIED\r
+ JRST .+3\r
+ PUSHJ P,GTRADX ;GET THE RADIX FROM OUTCHAN\r
+ JRST UNPRGO\r
+ CAMGE AB,[-5,,0] ;CHECK FOR TOO MANY\r
+ JRST TMA\r
+ GETYP 0,2(AB)\r
+ CAIE 0,TFIX ;SEE IF RADIX IS FIXED\r
+ JRST WTYP2\r
+ MOVE C,3(AB) ;GET RADIX\r
+ PUSHJ P,GETARG ;GET ARGS INTO A AND B\r
+UNPRGO: PUSHJ P,CIUPRS\r
+ JRST FINIS\r
+ JRST FINIS\r
+\r
+\r
+GTRADX: MOVE B,IMQUOTE OUTCHAN\r
+ PUSH P,0 ;SAVE FLAGS\r
+ PUSHJ P,IDVAL ;GET VALUE FOR OUTCHAN\r
+ POP P,0\r
+ GETYP A,A ;CHECK TYPE OF CHANNEL\r
+ CAIE A,TCHAN\r
+ JRST FUNCH1-1 ;IT IS A TP-POINTER\r
+ MOVE C,RADX(B) ;GET RADIX FROM OUTCHAN\r
+ JRST FUNCH1\r
+ MOVE C,(B)+6 ;GET RADIX FROM STACK\r
+\r
+FUNCH1: CAIG C,1 ;CHECK FOR STRANGE RADIX\r
+ MOVEI C,10. ;DEFAULT IF THIS IS THE CASE\r
+GETARG: MOVE A,(AB)\r
+ MOVE B,1(AB)\r
+ POPJ P,\r
+\r
+\r
+MFUNCTION PRINT,SUBR\r
+ ENTRY \r
+ PUSHJ P,AGET ; GET ARGS\r
+ PUSHJ P,CIPRIN\r
+ JRST FINIS\r
+\r
+MFUNCTION PRINC,SUBR\r
+ ENTRY \r
+ PUSHJ P,AGET ; GET ARGS\r
+ PUSHJ P,CIPRNC\r
+ JRST FINIS\r
+\r
+MFUNCTION PRIN1,SUBR\r
+ ENTRY \r
+ PUSHJ P,AGET\r
+ PUSHJ P,CIPRN1\r
+ JRST FINIS\r
+ JRST PRIN01 ;CALL IPRINT AFTER SAVING STUFF\r
+\r
+\r
+MFUNCTION TERPRI,SUBR\r
+ ENTRY\r
+ PUSHJ P,AGET1\r
+ PUSHJ P,CITERP\r
+ JRST FINIS\r
+\r
+\f\r
+CITERP: SUBM M,(P)\r
+ MOVSI 0,TERBIT+SPCBIT ; SET UP FLAGS\r
+ PUSHJ P,TESTR ; TEST FOR GOOD CHANNEL\r
+ MOVEI A,CARRET ; MOVE IN CARRIAGE-RETURN\r
+ PUSHJ P,PITYO ; PRINT IT OUT\r
+ MOVEI A,12 ; LINE-FEED\r
+ PUSHJ P,PITYO\r
+ MOVSI A,TFALSE ; RETURN A FALSE\r
+ MOVEI B,0\r
+ JRST MPOPJ ; RETURN\r
+\r
+\r
+TESTR: GETYP E,A\r
+ CAIN E,TCHAN ; CHANNEL?\r
+ JRST TESTR1 ; OK?\r
+ CAIE E,TTP\r
+ JRST BADCHN\r
+ HLRZS 0\r
+ IOR 0,A ; RESTORE FLAGS\r
+ HRLZS 0\r
+ POPJ P,\r
+TESTR1: HRRZ E,-4(B) ; GET IN FLAGS FROM CHANNEL\r
+ TRC E,C.PRIN+C.OPN ; CHECK TO SEE THAT CHANNEL IS GOOD\r
+ TRNE E,C.PRIN+C.OPN\r
+ JRST BADCHN ; ITS A LOSER\r
+ TRNE E,C.BIN\r
+ JRST PSHNDL ; DON'T HANDLE BINARY\r
+ TLO ASCBIT ; ITS ASCII\r
+ POPJ P, ; ITS A WINNER\r
+ \r
+PSHNDL: PUSH TP,C ; SAVE ARGS\r
+ PUSH TP,D\r
+ PUSH TP,A ; PUSH CHANNEL ONTO STACK\r
+ PUSH TP,B\r
+ PUSHJ P,BPRINT ; CHECK BUFFER\r
+ POP TP,B\r
+ POP TP,A\r
+ POP TP,D\r
+ POP TP,C\r
+ POPJ P,\r
+\r
+\r
+\f;CIUPRS NEEDS A RADIX IN C AND A TYPE-OBJECT PAIR IN A,B\r
+\r
+CIUPRS: SUBM M,(P) ; MODIFY M-POINTER\r
+ MOVE E,TP ; SAVE TP-POINTER\r
+ PUSH TP,[0] ; SLOT FOR FIRST STRING COPY\r
+ PUSH TP,[0]\r
+ PUSH TP,[0] ; AND SECOND STRING\r
+ PUSH TP,[0]\r
+ PUSH TP,A ; SAVE OBJECTS\r
+ PUSH TP,B\r
+ PUSH TP,$TTP ; SAVE TP POINTER\r
+ PUSH TP,E\r
+ PUSH P,C\r
+ MOVE D,[377777,,-1] ; MOVE IN MAXIMUM NUMBER FOR FLATSIZE\r
+ PUSHJ P,CIFLTZ ; FIND LENGTH OF STRING\r
+ FATAL UNPARSE BLEW IT\r
+ PUSH TP,$TFIX ; MOVE IN ARGUMENT FOR ISTRING\r
+ PUSH TP,B\r
+ MCALL 1,ISTRING\r
+ POP TP,E ; RESTORE TP-POINTER\r
+ SUB TP,[1,,1] ;GET RID OF TYPE WORD\r
+ MOVEM A,1(E) ; SAVE RESULTS\r
+ MOVEM A,3(E)\r
+ MOVEM B,2(E)\r
+ MOVEM B,4(E)\r
+ POP TP,B ; RESTORE THE WORLD\r
+ POP TP,A\r
+ POP P,C\r
+ MOVSI 0,FLTBIT+UNPRSE ; SET UP FLAGS\r
+ PUSHJ P,CUSET\r
+ JRST MPOPJ ; RETURN\r
+\r
+\r
+\r
+; FOR CIFLTZ C CONTAINS THE RADIX, D THE MAXIMUM NUMBER OF CHARACTERS,\r
+; A,B THE TYPE-OBJECT PAIR\r
+\r
+CIFLTZ: SUBM M,(P)\r
+ MOVE E,TP ; SAVE POINTER\r
+ PUSH TP,$TFIX ; PUSH ON FLATSIZE COUNT\r
+ PUSH TP,[0]\r
+ PUSH TP,$TFIX ; PUSH ON FLATSIZE MAXIMUM\r
+ PUSH TP,D\r
+ MOVSI 0,FLTBIT ; MOVE ON FLATSIZE FLAG\r
+ PUSHJ P,CUSET ; CONTINUE\r
+ JRST MPOPJ\r
+ SOS (P) ; SKIP RETURN\r
+ JRST MPOPJ ; RETURN\r
+\r
+; CUSET IS THE ROUTINE USED BY FLATSIZE AND UNPARSE TO DO THE PUSHING,POPING AND CALLING\r
+; NEEDED TO GET A RESULT.\r
+\r
+CUSET: PUSH TP,$TFIX ; PUSH ON RADIX\r
+ PUSH TP,C\r
+ PUSH TP,$TPDL\r
+ PUSH TP,P ; PUSH ON RETURN POINTER IN CASE FLATSIZE GETS A FALSE\r
+ PUSH TP,A ; SAVE OBJECTS\r
+ PUSH TP,B\r
+ MOVSI C,TTP ; CONSTRUCT TP-POINTER\r
+ HLR C,FLAGS ; SAVE FLAGS IN TP-POINTER\r
+ MOVE D,E\r
+ PUSH TP,C ; PUSH ON CHANNEL\r
+ PUSH TP,D\r
+ PUSHJ P,IPRINT ; GO TO INTERNAL PRINTER\r
+ POP TP,B ; GET IN TP POINTER\r
+ MOVE TP,B ; RESTORE POINTER\r
+ TLNN FLAGS,UNPRSE ; SEE IF UNPARSE CALL\r
+ JRST FLTGEN ; ITS A FLATSIZE\r
+ MOVE A,UPB+3 ; RETURN STRING\r
+ MOVE B,UPB+4\r
+ POPJ P, ; DONE\r
+FLTGEN: MOVE A,FLTSIZ-1 ; GET IN COUNT\r
+ MOVE B,FLTSIZ\r
+ AOS (P)\r
+ POPJ P, ; EXIT\r
+\r
+\f\r
+; CIPRIN,CIPRNC,CIPRN1,CPATM,CP1ATM,CPCATM,CPSTR,CP1STR,CPCSTR ALL ASSUME\r
+; THAT C,D CONTAIN THE OBJECT AND A AND B CONTAIN THE CHANNEL\r
+\r
+CIPRIN: SUBM M,(P)\r
+ MOVSI 0,SPCBIT ; SET UP FLAGS\r
+ PUSHJ P,TPRT ; PRINT INITIALIZATION\r
+ PUSHJ P,IPRINT\r
+ JRST TPRTE ; EXIT\r
+\r
+CIPRN1: SUBM M,(P)\r
+ MOVEI FLAGS,0 ; SET UP FLAGS\r
+ PUSHJ P,TPR1 ; INITIALIZATION\r
+ PUSHJ P,IPRINT ; PRINT IT OUT\r
+ JRST TPR1E ; EXIT\r
+\r
+CIPRNC: SUBM M,(P)\r
+ MOVSI FLAGS,NOQBIT ; SET UP FLAGS\r
+ PUSHJ P,TPR1 ; INITIALIZATION\r
+ PUSHJ P,IPRINT\r
+ JRST TPR1E ; EXIT\r
+\f\r
+; INITIALIZATION FOR PRINT ROUTINES\r
+\r
+TPRT: PUSHJ P,TESTR ; SEE IF CHANNEL IS OK\r
+ PUSH TP,C ; SAVE ARGUMENTS\r
+ PUSH TP,D\r
+ PUSH TP,A ; SAVE CHANNEL\r
+ PUSH TP,B\r
+ MOVEI A,CARRET ; PRINT CARRIAGE RETURN\r
+ PUSHJ P,PITYO\r
+ MOVEI A,12 ; AND LF\r
+ PUSHJ P,PITYO\r
+ MOVE A,-3(TP) ; MOVE IN ARGS\r
+ MOVE B,-2(TP)\r
+ POPJ P,\r
+\r
+; EXIT FOR PRINT ROUTINES\r
+\r
+TPRTE: POP TP,B ; RESTORE CHANNEL\r
+ MOVEI A,SPACE ; PRINT TRAILING SPACE\r
+ PUSHJ P,PITYO\r
+ SUB TP,[1,,1] ; GET RID OF CHANNEL TYPE-WORD\r
+ POP TP,B ; RETURN WHAT WAS PASSED\r
+ POP TP,A\r
+ JRST MPOPJ ; EXIT\r
+\r
+; INITIALIZATION FOR PRIN1 AND PRINC ROUTINES\r
+\r
+TPR1: PUSHJ P,TESTR ; SEE IF CHANNEL IS OK\r
+ PUSH TP,C ; SAVE ARGS\r
+ PUSH TP,D\r
+ PUSH TP,A ; SAVE CHANNEL\r
+ PUSH TP,B\r
+ MOVE A,-3(TP) ; GET ARGS\r
+ MOVE B,-2(TP)\r
+ POPJ P,\r
+\r
+; EXIT FOR PRIN1 AND PRINC ROUTINES\r
+\r
+TPR1E: SUB TP,[2,,2] ; REMOVE CHANNEL\r
+ POP TP,B ; RETURN ARGUMENTS THAT WERE GIVEN\r
+ POP TP,A\r
+ JRST MPOPJ ; EXIT\r
+\r
+\r
+\f\r
+CPATM: SUBM M,(P)\r
+ MOVSI C,TATOM ; GET TYPE FOR BINARY\r
+ MOVE 0,$SPCBIT ; SET UP FLAGS\r
+ PUSHJ P,TPRT ; PRINT INITIALIZATION\r
+ PUSHJ P,CPATOM ; PRINT IT OUT\r
+ JRST TPRTE ; EXIT\r
+\r
+CP1ATM: SUBM M,(P)\r
+ MOVE C,$TATOM\r
+ MOVEI FLAGS,0 ; SET UP FLAGS\r
+ PUSHJ P,TPR1 ; INITIALIZATION\r
+ PUSHJ P,CPATOM ; PRINT IT OUT\r
+ JRST TPR1E ; EXIT\r
+\r
+CPCATM: SUBM M,(P)\r
+ MOVE C,$TATOM\r
+ MOVSI FLAGS,NOQBIT ; SET UP FLAGS\r
+ PUSHJ P,TPR1 ; INITIALIZATION\r
+ PUSHJ P,CPATOM ; PRINT IT OUT\r
+ JRST TPR1E ; EXIT\r
+\r
+\r
+; THIS ROUTINE IS USD TO PRINT ONE CHARACTER. THE CHANNEL IS IN A AND B THE \r
+; CHARACTER IS IN C.\r
+CPCH: SUBM M,(P)\r
+ MOVSI FLAGS,NOQBIT\r
+ MOVE C,$TCHRS\r
+ PUSHJ P,TESTR ; SEE IF CHANNEL IS GOOD\r
+ PUSH P,D\r
+ MOVE A,D ; MOVE IN CHARACTER FOR PITYO\r
+ PUSHJ P,PITYO\r
+ MOVE A,$TCHRST ; RETURN THE CHARACTER\r
+ POP P,B\r
+ JRST MPOPJ\r
+\r
+\r
+\r
+\r
+CPSTR: SUBM M,(P)\r
+ HRLI C,TCHSTR\r
+ MOVSI 0,SPCBIT ; SET UP FLAGS\r
+ PUSHJ P,TPRT ; PRINT INITIALIZATION\r
+ PUSHJ P,CPCHST ; PRINT IT OUT\r
+ JRST TPRTE ; EXIT\r
+\r
+CP1STR: SUBM M,(P)\r
+ HRLI C,TCHSTR\r
+ MOVEI FLAGS,0 ; SET UP FLAGS\r
+ PUSHJ P,TPR1 ; INITIALIZATION\r
+ PUSHJ P,CPCHST ; PRINT IT OUT\r
+ JRST TPR1E ; EXIT\r
+\r
+CPCSTR: SUBM M,(P)\r
+ HRLI C,TCHSTR\r
+ MOVSI FLAGS,NOQBIT ; SET UP FLAGS\r
+ PUSHJ P,TPR1 ; INITIALIZATION\r
+ PUSHJ P,CPCHST ; PRINT IT OUT\r
+ JRST TPR1E ; EXIT\r
+\r
+\r
+CPATOM: PUSH TP,A ; COPY ARGS FOR INTERNAL SAKE\r
+ PUSH TP,B\r
+ PUSH P,0 ; ATOM CALLER ROUTINE\r
+ PUSH P,C\r
+ JRST PATOM\r
+\r
+CPCHST: PUSH TP,A ; COPY ARGS FOR INTERNAL SAKE\r
+ PUSH TP,B\r
+ PUSH P,0 ; STRING CALLER ROUTINE\r
+ PUSH P,C\r
+ JRST PCHSTR\r
+\r
+\r
+\f\r
+AGET: MOVEI FLAGS,0\r
+ SKIPL E,AB ; COPY ARG POINTER\r
+ JRST TFA ;NO ARGS IS AN ERROR\r
+ ADD E,[2,,2] ;POINT AT POSSIBLE CHANNEL\r
+ JRST COMPT\r
+AGET1: MOVE E,AB ; GET COPY OF AB\r
+ MOVSI FLAGS,TERBIT\r
+\r
+COMPT: PUSH TP,$TFIX ;LEAVE ROOM ON STACK FOR ONE CHANNEL\r
+ PUSH TP,[0]\r
+ JUMPGE E,DEFCHN ;IF NO CHANNEL ARGUMENT, USE CURRENT BINDING\r
+ CAMG E,[-2,,0] ;IF MORE ARGS THEN ERROR\r
+ JRST TMA\r
+ MOVE A,(E) ;GET CHANNEL\r
+ MOVE B,(E)+1\r
+ JRST NEWCHN\r
+\r
+DEFCHN: MOVE B,IMQUOTE OUTCHAN\r
+ MOVSI A,TATOM\r
+ PUSH P,FLAGS ;SAVE FLAGS\r
+ PUSHJ P,IDVAL ;GET VALUE OF OUTCHAN\r
+ POP P,0\r
+\r
+NEWCHN: TLNE FLAGS,TERBIT ; SEE IF TERPRI\r
+ POPJ P,\r
+ MOVE C,(AB) ; GET ARGS\r
+ MOVE D,1(AB)\r
+ POPJ P,\r
+\r
+; HERE IF USING A PRINTB CHANNEL\r
+\r
+BPRINT: TLO FLAGS,BINBIT\r
+ SKIPE BUFSTR(B) ; ANY OUTPUT BUFFER?\r
+ POPJ P,\r
+\r
+; HERE TO GENERATE A STRING BUFFER\r
+\r
+ PUSH P,FLAGS\r
+ MOVEI A,BUFLNT ; GET BUFFER LENGTH\r
+ PUSHJ P,IBLOCK ; MAKE A BUFFER\r
+ MOVSI 0,TWORD+.VECT. ; CLOBBER U TYPE\r
+ MOVEM 0,BUFLNT(B)\r
+ SETOM (B)) ; -1 THE BUFFER\r
+ MOVEI C,1(B)\r
+ HRLI C,(B)\r
+ BLT C,BUFLNT-1(B)\r
+ HRLI B,440700\r
+ MOVE C,(TP)\r
+ MOVEM B,BUFSTR(C) ; STOR BYTE POINTER\r
+ MOVE 0,[TCHSTR,,BUFLNT*5]\r
+ MOVEM 0,BUFSTR-1(C)\r
+ POP P,FLAGS\r
+\r
+ MOVE B,(TP)\r
+ POPJ P,\r
+\f\r
+\r
+IPRINT: PUSH P,C ; SAVE C\r
+ PUSH P,FLAGS ;SAVE PREVIOUS FLAGS\r
+ PUSH TP,A ;SAVE ARGUMENT ON TP-STACK\r
+ PUSH TP,B\r
+ \r
+ INTGO ;ALLOW INTERRUPTS HERE\r
+ \r
+ GETYP A,-1(TP) ;GET THE TYPE CODE OF THE ITEM\r
+ SKIPE C,PRNTYP+1(TVP) ; USER TYPE TABLE?\r
+ JRST PRDISP\r
+NORMAL: CAIG A,NUMPRI ;PRIMITIVE?\r
+ JRST @PRTYPE(A) ;YES-DISPATCH\r
+ JRST PUNK ;JUMP TO ERROR ROUTINE IF CODE TOO GREAT\r
+\r
+; HERE FOR USER PRINT DISPATCH\r
+\r
+PRDISP: ADDI C,(A) ; POINT TO SLOT\r
+ ADDI C,(A)\r
+ SKIPE (C) ; SKIP EITHER A LOSER OR JRST DISP\r
+ JRST PRDIS1 ; APPLY EVALUATOR\r
+ SKIPN C,1(C) ; GET ADDR OR GO TO PURE DISP\r
+ JRST NORMAL\r
+ JRST (C)\r
+\r
+PRDIS1: PUSH P,C ; SAVE C\r
+ PUSH TP,[TATOM,,-1] ; PUSH ON OUTCHAN FOR SPECBIND\r
+ PUSH TP,IMQUOTE OUTCHAN\r
+ PUSH TP,-5(TP)\r
+ PUSH TP,-5(TP)\r
+ PUSH TP,[0]\r
+ PUSH TP,[0]\r
+ PUSHJ P,SPECBIND\r
+ POP P,C ; RESTORE C\r
+ PUSH TP,(C) ; PUSH ARGS FOR APPLY\r
+ PUSH TP,1(C)\r
+ PUSH TP,-9(TP)\r
+ PUSH TP,-9(TP)\r
+ MCALL 2,APPLY ; APPLY HACKER TO OBJECT\r
+ MOVEI E,-8(TP)\r
+ PUSHJ P,SSPEC1 ;UNBIND OUTCHAN\r
+ SUB TP,[6,,6] ; POP OFF STACK\r
+ JRST PNEXT\r
+\r
+; PRINT DISPATCH TABLE\r
+\r
+DISTBL PRTYPE,PUNK,[[TATOM,PATOM],[TFORM,PFORM],[TSEG,PSEG],[TFIX,PFIX]\r
+[TFLOAT,PFLOAT],[TLIST,PLIST],[TVEC,PVEC],[TCHRS,PCHRS],[TCHSTR,PCHSTR]\r
+[TARGS,PARGS],[TUVEC,PUVEC],[TDEFER,PDEFER],[TINTH,PINTH],[THAND,PHAND]\r
+[TILLEG,ILLCH],[TRSUBR,PRSUBR],[TENTER,PENTRY],[TPCODE,PPCODE],[TTYPEW,PTYPEW]\r
+[TTYPEC,PTYPEC],[TTMPLT,TMPRNT],[TLOCD,LOCPT1]]\r
+\r
+PUNK: MOVE C,TYPVEC+1(TVP) ; GET AOBJN-POINTER TO VECTOR OF TYPE ATOMS\r
+ GETYP B,-1(TP) ; GET THE TYPE CODE INTO REG B\r
+ LSH B,1 ; MULTIPLY BY TWO\r
+ HRL B,B ; DUPLICATE IT IN THE LEFT HALF\r
+ ADD C,B ; INCREMENT THE AOBJN-POINTER\r
+ JUMPGE C,PRERR ; IF POSITIVE, INDEX > VECTOR SIZE\r
+\r
+ MOVE B,-2(TP) ; MOVE IN CHANNEL\r
+ PUSHJ P,RETIF1 ; START NEW LINE IF NO ROOM\r
+ MOVEI A,"# ; INDICATE TYPE-NAME FOLLOWS\r
+ PUSHJ P,PITYO\r
+ MOVE A,(C) ; GET TYPE-ATOM\r
+ MOVE B,1(C)\r
+ PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT\r
+ PUSH TP,-3(TP)\r
+ PUSHJ P,IPRINT ; PRINT ATOM-NAME\r
+ SUB TP,[2,,2] ; POP STACK \r
+ MOVE B,-2(TP) ; MOVE IN CHANNEL\r
+ PUSHJ P,SPACEQ ; MAYBE SPACE\r
+ MOVE B,(B) ; RESET THE REAL ARGUMENT POINTER\r
+ HRRZ A,(C) ; GET THE STORAGE-TYPE\r
+ ANDI A,SATMSK\r
+ CAIG A,NUMSAT ; SKIP IF TEMPLATE\r
+ JRST @UKTBL(A) ; USE DISPATCH TABLE ON STORAGE TYPE\r
+ JRST TMPRNT ; PRINT TEMPLATED DATA STRUCTURE\r
+\r
+DISTBS UKTBL,POCTAL,[[S2WORD,PLIST],[S2NWORD,PVEC],[SNWORD,PUVEC],[SATOM,PATOM]\r
+[SCHSTR,PCHSTR],[SFRAME,PFRAME],[SARGS,PARGS],[SPVP,PPVP],[SLOCID,LOCPT],[SLOCA,LOCP]\r
+[SLOCV,LOCP],[SLOCU,LOCP],[SLOCS,LOCP],[SLOCL,LOCP],[SLOCN,LOCP],[SASOC,ASSPNT]\r
+[SLOCT,LOCP]]\r
+\r
+ ; SELECK AN ILLEGAL\r
+\r
+ILLCH: MOVEI B,-1(TP)\r
+ JRST ILLCHO\r
+\r
+\f; PRINT INTERRUPT HANDLER\r
+\r
+PHAND: MOVE B,-2(TP) ; MOVE CHANNEL INTO B\r
+ PUSHJ P,RETIF1\r
+ MOVEI A,"#\r
+ PUSHJ P,PITYO ; SAY "FUNNY TYPE"\r
+ MOVSI A,TATOM\r
+ MOVE B,MQUOTE HANDLER\r
+ PUSH TP,-3(TP) ; PUSH CHANNEL ON FOR IPRINT\r
+ PUSH TP,-3(TP)\r
+ PUSHJ P,IPRINT ; PRINT THE TYPE NAME\r
+ SUB TP,[2,,2] ; POP CHANNEL OFF STACK\r
+ MOVE B,-2(TP) ; GET CHANNEL\r
+ PUSHJ P,SPACEQ ; SPACE MAYBE\r
+ SKIPN B,(TP) ; GET ARG BACK\r
+ JRST PNEXT\r
+ MOVE A,INTFCN(B) ; PRINT FUNCTION FOR NOW\r
+ MOVE B,INTFCN+1(B)\r
+ PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT\r
+ PUSH TP,-3(TP)\r
+ PUSHJ P,IPRINT ; PRINT THE INT FUNCTION\r
+ SUB TP,[2,,2] ; POP CHANNEL OFF\r
+ JRST PNEXT\r
+\r
+; PRINT INT HEADER\r
+\r
+PINTH: MOVE B,-2(TP) ; GET CHANNEL INTO B\r
+ PUSHJ P,RETIF1\r
+ MOVEI A,"#\r
+ PUSHJ P,PITYO\r
+ MOVSI A,TATOM ; AND NAME\r
+ MOVE B,MQUOTE IHEADER\r
+ PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT\r
+ PUSH TP,-3(TP)\r
+ PUSHJ P,IPRINT\r
+ MOVE B,-4(TP) ; GET CHANNEL INTO B\r
+ PUSHJ P,SPACEQ ; MAYBE SPACE\r
+ SKIPN B,-2(TP) ; INT HEADER BACK\r
+ JRST PNEXT\r
+ MOVE A,INAME(B) ; GET NAME\r
+ MOVE B,INAME+1(B)\r
+ PUSHJ P,IPRINT\r
+ SUB TP,[2,,2] ; CLEAN OFF STACK\r
+ JRST PNEXT\r
+\r
+\r
+; PRINT ASSOCIATION BLOCK\r
+\r
+ASSPNT: MOVEI A,"( ; MAKE IT BE (ITEN INDIC VAL)\r
+ MOVE B,-2(TP) ; GET CHANNEL INTO B\r
+ PUSHJ P,PRETIF ; MAKE ROOM AND PRINT\r
+ SKIPA C,[-3,,0] ; # OF FIELDS\r
+ASSLP: PUSHJ P,SPACEQ\r
+ MOVE D,(TP) ; RESTORE GOODIE\r
+ ADD D,ASSOFF(C) ; POINT TO FIELD\r
+ MOVE A,(D) ; GET IT\r
+ MOVE B,1(D)\r
+ PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT\r
+ PUSH TP,-3(TP)\r
+ PUSHJ P,IPRINT ; AND PRINT IT\r
+ SUB TP,[2,,2] ; POP OFF CHANNEL\r
+ AOBJN C,ASSLP\r
+\r
+ MOVEI A,")\r
+ MOVE B,-2(TP) ; GET CHANNEL INTO B\r
+ PUSHJ P,PRETIF ; CLOSE IT\r
+ JRST PNEXT\r
+\r
+ASSOFF: ITEM\r
+ INDIC\r
+ VAL\r
+\f; PRINT TYPE-C AND TYPE-W\r
+\r
+PTYPEW: HRRZ A,(TP) ; POSSIBLE RH\r
+ HLRZ B,(TP)\r
+ MOVE C,MQUOTE TYPE-W\r
+ JRST PTYPEX\r
+\r
+PTYPEC: HRRZ B,(TP)\r
+ MOVEI A,0\r
+ MOVE C,MQUOTE TYPE-C\r
+\r
+PTYPEX: PUSH P,B\r
+ PUSH P,A\r
+ PUSH TP,$TATOM\r
+ PUSH TP,C\r
+ MOVEI A,2\r
+ MOVE B,-4(TP) ; GET CHANNEL INTO B\r
+ PUSHJ P,RETIF ; ROOM TO START?\r
+ MOVEI A,"%\r
+ PUSHJ P,PITYO\r
+ MOVEI A,"<\r
+ PUSHJ P,PITYO\r
+ POP TP,B ; GET NAME\r
+ POP TP,A\r
+ PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT\r
+ PUSH TP,-3(TP)\r
+ PUSHJ P,IPRINT ; AND PRINT IT AS 1ST ELEMENT\r
+ SUB TP,[2,,2] ; POP OFF CHANNEL\r
+ MOVE B,-2(TP) ; GET CHANNEL INTO B\r
+ PUSHJ P,SPACEQ ; MAYBE SPACE\r
+ MOVE A,-1(P) ; TYPE CODE\r
+ ASH A,1\r
+ HRLI A,(A) ; MAKE SURE WINS\r
+ ADD A,TYPVEC+1(TVP)\r
+ JUMPL A,PTYPX1 ; JUMP FOR A WINNER\r
+ PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE BAD-TYPE-CODE\r
+ JRST CALER1\r
+\r
+PTYPX1: MOVE B,1(A) ; GET TYPE NAME\r
+ HRRZ A,(A) ; AND SAT\r
+ ANDI A,SATMSK\r
+ MOVEM A,-1(P) ; AND SAVE IT\r
+ MOVSI A,TATOM\r
+ PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT\r
+ PUSH TP,-3(TP)\r
+ PUSHJ P,IPRINT ; OUT IT GOES\r
+ SUB TP,[2,,2] ; POP OFF CHANNEL\r
+ MOVE B,-2(TP) ; GET CHANNEL INTO B\r
+ PUSHJ P,SPACEQ ; MAYBE SPACE\r
+ MOVE A,-1(P) ; GET SAT BACK\r
+ MOVE B,@STBL(A)\r
+ MOVSI A,TATOM ; AND PRINT IT\r
+ PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT\r
+ PUSH TP,-3(TP)\r
+ PUSHJ P,IPRINT\r
+ SUB TP,[2,,2] ; POP OFF STACK\r
+ SKIPN B,(P) ; ANY EXTRA CRAP?\r
+ JRST PTYPX2\r
+\r
+ MOVE B,-2(TP) ; GET CHANNEL INTO B\r
+ PUSHJ P,SPACEQ\r
+ MOVE B,(P)\r
+ MOVSI A,TFIX\r
+ PUSH TP,-3(TP) ; PUSH CHANNELS FOR IPRINT\r
+ PUSH TP,-3(TP)\r
+ PUSHJ P,IPRINT ; PRINT EXTRA\r
+ SUB TP,[2,,2] ; POP OFF CHANNEL\r
+\r
+PTYPX2: MOVEI A,">\r
+ MOVE B,-2(TP) ; GET CHANNEL INTO B\r
+ PUSHJ P,PRETIF\r
+ SUB P,[2,,2] ; FLUSH CRUFT\r
+ JRST PNEXT\r
+\r
+\f; PRINT PURE CODE POINTER\r
+\r
+PPCODE: MOVEI A,2\r
+ MOVE B,-2(TP) ; GET CHANNEL INTO B\r
+ PUSHJ P,RETIF\r
+ MOVEI A,"%\r
+ PUSHJ P,PITYO\r
+ MOVEI A,"<\r
+ PUSHJ P,PITYO\r
+ MOVSI A,TATOM ; PRINT SUBR CALL\r
+ MOVE B,MQUOTE PCODE\r
+ PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT\r
+ PUSH TP,-3(TP)\r
+ PUSHJ P,IPRINT\r
+ MOVE B,-4(TP) ; GET CHANNEL INTO B\r
+ PUSHJ P,SPACEQ ; MAYBE SPACE?\r
+ HLRZ A,-2(TP) ; OFFSET TO VECTOR\r
+ ADD A,PURVEC+1(TVP) ; SLOT TO A\r
+ MOVE A,(A) ; SIXBIT NAME\r
+ PUSH P,FLAGS\r
+ PUSHJ P,6TOCHS ; TO A STRING\r
+ POP P,FLAGS\r
+ PUSHJ P,IPRINT\r
+ MOVE B,-4(TP) ; GET CHANNEL INTO B\r
+ PUSHJ P,SPACEQ\r
+ HRRZ B,-2(TP) ; GET OFFSET\r
+ MOVSI A,TFIX\r
+ PUSHJ P,IPRINT\r
+ SUB TP,[2,,2] ; POP CHANNEL OFF STACK\r
+ MOVEI A,">\r
+ MOVE B,-2(TP) ; GET CHANNEL INTO B\r
+ PUSHJ P,PRETIF ; CLOSE THE FORM\r
+ JRST PNEXT\r
+\r
+\r
+\f; PRINT SUB-ENTRY TO RSUBR\r
+\r
+PENTRY: MOVE B,(TP) ; GET BLOCK\r
+ GETYP A,(B) ; TYPE OF 1ST ELEMENT\r
+ CAIE A,TRSUBR ; RSUBR, OK\r
+ JRST PENT1\r
+ MOVSI A,TATOM ; UNLINK\r
+ HLLM A,(B)\r
+ MOVE A,1(B)\r
+ MOVE A,3(A)\r
+ MOVEM A,1(B)\r
+PENT2: MOVEI A,2 ; CHECK ROOM\r
+ MOVE B,-2(TP) ; GET CHANNEL INTO B\r
+ PUSHJ P,RETIF\r
+ MOVEI A,"% ; SETUP READ TIME MACRO\r
+ PUSHJ P,PITYO\r
+ MOVEI A,"<\r
+ PUSHJ P,PITYO\r
+ MOVSI A,TATOM\r
+ MOVE B,MQUOTE RSUBR-ENTRY\r
+ PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT\r
+ PUSH TP,-3(TP)\r
+ PUSHJ P,IPRINT\r
+ MOVE B,-4(TP)\r
+ PUSHJ P,SPACEQ ; MAYBE SPACE\r
+ MOVEI A,"' ; QUOTE TO AVOID EVALING IT\r
+ PUSHJ P,PRETIF\r
+ MOVSI A,TVEC\r
+ MOVE B,-2(TP)\r
+ PUSHJ P,IPRINT\r
+ MOVE B,-4(TP) ; GET CHANNEL INTO B\r
+ PUSHJ P,SPACEQ\r
+ MOVE B,-2(TP)\r
+ HRRZ B,2(B)\r
+ MOVSI A,TFIX\r
+ PUSHJ P,IPRINT\r
+ MOVEI A,">\r
+ SUB TP,[2,,2] ; POP CHANNEL OFF STACK\r
+ MOVE B,-2(TP) ; GET CHANNEL INTO B\r
+ PUSHJ P,PRETIF\r
+ JRST PNEXT\r
+\r
+PENT1: CAIN A,TATOM\r
+ JRST PENT2\r
+ PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE BAD-ENTRY-BLOCK\r
+ JRST CALER1\r
+\r
+\f; HERE TO PRINT TEMPLATED DATA STRUCTURE\r
+\r
+TMPRNT: PUSH P,FLAGS ; SAVE FLAGS\r
+ MOVE A,(TP) ; GET POINTER\r
+ GETYP A,(A) ; GET SAT\r
+ PUSH P,A ; AND SAVE IT\r
+ MOVEI A,"{ ; OPEN SQUIGGLE\r
+ MOVE B,-2(TP) ; GET CHANNEL INTO B\r
+ PUSHJ P,PRETIF ; PRINT WITH CHECKING\r
+ HLRZ A,(TP) ; GET AMOUNT RESTED OFF\r
+ SUBI A,1\r
+ PUSH P,A ; AND SAVE IT\r
+ MOVE A,-1(P) ; GET SAT\r
+ SUBI A,NUMSAT+1 ; FIXIT UP\r
+ HRLI A,(A)\r
+ ADD A,TD.LNT+1(TVP) ; CHECK FOR WINNAGE\r
+ JUMPGE A,BADTPL ; COMPLAIN\r
+ HRRZS C,(TP) ; GET LENGTH\r
+ XCT (A) ; INTO B\r
+ SUB B,(P) ; FUDGE FOR RESTS\r
+ MOVEI B,-1(B) ; FUDGE IT\r
+ PUSH P,B ; AND SAVE IT\r
+\r
+TMPRN1: AOS C,-1(P) ; GET ELEMENT OF INTEREST\r
+ SOSGE (P) ; CHECK FOR ANY LEFT\r
+ JRST TMPRN2 ; ALL DONE\r
+\r
+ MOVE B,(TP) ; POINTER\r
+ HRRZ 0,-2(P) ; SAT\r
+ PUSHJ P,TMPLNT ; GET THE ITEM\r
+ MOVE FLAGS,-3(P) ; RESTORE FLAGS\r
+ PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT\r
+ PUSH TP,-3(TP)\r
+ PUSHJ P,IPRINT ; PRINT THIS ELEMENT\r
+ SUB TP,[2,,2] ; POP CHANNEL OFF STACK\r
+ MOVE B,-2(TP) ; GET CHANNEL INTO B\r
+ SKIPE (P) ; IF NOT LAST ONE THEN\r
+ PUSHJ P,SPACEQ ; SEPARATE WITH A SPACE\r
+ JRST TMPRN1\r
+\r
+TMPRN2: SUB P,[4,,4]\r
+ MOVE B,-2(TP)\r
+ MOVEI A,"} ; CLOSE THIS GUY\r
+ PUSHJ P,PRETIF\r
+ JRST PNEXT\r
+\r
+\r
+\f; RSUBR PRINTING ROUTINES. ON PRINTB CHANNELS, WRITES OUT\r
+; COMPACT BINARY. ON PRINT CHANNELS ALL IS ASCII\r
+\r
+PRSUBR: MOVE A,(TP) ; GET RSUBR IN QUESTION\r
+ GETYP A,(A) ; CHECK FOR PURE RSUBR\r
+ CAIN A,TPCODE\r
+ JRST PRSBRP ; PRINT IT SPECIAL WAY\r
+\r
+ TLNN FLAGS,BINBIT ; SKIP IF BINARY OUTPUT\r
+ JRST ARSUBR\r
+\r
+ PUSH P,FLAGS\r
+ MOVSI A,TRSUBR ; FIND FIXUPS\r
+ MOVE B,(TP)\r
+ HLRE D,1(B) ; -LENGTH OF CODE VEC\r
+ PUSH P,D ; SAVE SAME\r
+ MOVSI C,TATOM\r
+ MOVE D,MQUOTE RSUBR\r
+ PUSHJ P,IGET ; GO GET THEM\r
+ JUMPE B,RCANT ; NO FIXUPS, BINARY LOSES\r
+ PUSH TP,A ; SAVE FIXUP LIST\r
+ PUSH TP,B\r
+\r
+ MOVNI A,1 ; USE ^C AS MARKER FOR RSUBR\r
+ MOVE FLAGS,-1(P) ; RESTORE FLAGS\r
+ MOVE B,-4(TP) ; GET CHANNEL FOR PITYO\r
+ PUSHJ P,PITYO ; OUT IT GOES\r
+\r
+PRSBR1: MOVE B,-4(TP)\r
+ PUSHJ P,BFCLS1 ; FLUSH OUT CURRENT BUFFER\r
+\r
+ MOVE B,-4(TP) ; CHANNEL BACK\r
+ MOVN E,(P) ; LENGTH OF CODE\r
+ PUSH P,E\r
+ HRROI A,(P) ; POINT TO SAME\r
+ PUSHJ P,DOIOTO ; OUT GOES COUNT\r
+ MOVSI C,TCODE\r
+ MOVEM C,ASTO(PVP) ; FOR IOT INTERRUPTS\r
+ MOVE A,-2(TP) ; GET POINTER TO CODE\r
+ MOVE A,1(A)\r
+ PUSHJ P,DOIOTO ; IOT IT OUT\r
+ POP P,E\r
+ ADDI E,1 ; UPDATE ACCESS\r
+ ADDM E,ACCESS(B)\r
+ SETZM ASTO(PVP) ; UNSCREW A\r
+\r
+; NOW PRINT OUT NORMAL RSUBR VECTOR\r
+\r
+ MOVE FLAGS,-1(P) ; RESTORE FLAGS\r
+ SUB P,[1,,1]\r
+ MOVE B,-2(TP) ; GET RSUBR VECTOR\r
+ PUSHJ P,PRBODY ; PRINT ITS BODY\r
+\r
+; HERE TO PRINT BINARY FIXUPS\r
+\r
+ MOVEI E,0 ; 1ST COMPUTE LENGTH OF FIXUPS\r
+ SKIPN A,(TP) ; LIST TO A\r
+ JRST PRSBR5 ; EMPTY, DONE\r
+ JUMPL A,UFIXES ; JUMP IF FIXUPS IN UVECTOR FORM\r
+ ADDI E,1 ; FOR VERS\r
+\r
+PRSBR6: HRRZ A,(A) ; NEXT?\r
+ JUMPE A,PRSBR5\r
+ GETYP B,(A)\r
+ CAIE B,TDEFER ; POSSIBLE STRING\r
+ JRST PRSBR7 ; COULD BE ATOM\r
+ MOVE B,1(A) ; POSSIBLE STRINGER\r
+ GETYP C,(B)\r
+ CAIE C,TCHSTR ; YES!!!\r
+ JRST BADFXU ; LOSING FIXUPS\r
+ HRRZ C,(B) ; # OF CHARS TO C\r
+ ADDI C,5+5 ; ROUND AND ADD FOR COUNT\r
+ IDIVI C,5 ; TO WORDS\r
+ ADDI E,(C)\r
+ JRST FIXLST ; COUNT FOR USE LIST ETC.\r
+\r
+PRSBR7: GETYP B,(A) ; GET TYPE\r
+ CAIE B,TATOM\r
+ JRST BADFXU\r
+ ADDI E,1\r
+\r
+FIXLST: HRRZ A,(A) ; REST IT TO OLD VAL\r
+ JUMPE A,BADFXU\r
+ GETYP B,(A) ; FIX?\r
+ CAIE B,TFIX\r
+ JRST BADFXU\r
+ MOVEI D,1\r
+ HRRZ A,(A) ; TO USE LIST\r
+ JUMPE A,BADFXU\r
+ GETYP B,(A)\r
+ CAIE B,TLIST\r
+ JRST BADFXU ; LOSER\r
+ MOVE C,1(A) ; GET LIST\r
+\r
+PRSBR8: JUMPE C,PRSBR9\r
+ GETYP B,(C) ; TYPE OK?\r
+ CAIE B,TFIX\r
+ JRST BADFXU\r
+ HRRZ C,(C)\r
+ AOJA D,PRSBR8 ; LOOP\r
+\r
+PRSBR9: ADDI D,2 ; ROUND UP\r
+ ASH D,-1 ; DIV BY 2 FOR TWO GOODIES PER HWORD\r
+ ADDI E,(D)\r
+ JRST PRSBR6\r
+\r
+PRSBR5: PUSH P,E ; SAVE LENGTH OF FIXUPS\r
+ PUSH TP,$TUVEC ; SLOT FOR BUFFER POINTER\r
+ PUSH TP,[0]\r
+\r
+PFIXU1: MOVE B,-6(TP) ; START LOOPING THROUGH CHANNELS\r
+ PUSHJ P,BFCLS1 ; FLUSH BUFFER\r
+ MOVE B,-6(TP) ; CHANNEL BACK\r
+ MOVEI C,BUFSTR-1(B) ; SETUP BUFFER\r
+ PUSHJ P,BYTDOP ; FIND D.W.\r
+ SUBI A,BUFLNT+1\r
+ HRLI A,-BUFLNT\r
+ MOVEM A,(TP)\r
+ MOVE E,(P) ; LENGTH OF FIXUPS\r
+ SETZB C,D ; FOR EOUT\r
+ PUSHJ P,EOUT\r
+ MOVE C,-2(TP) ; FIXUP LIST\r
+ MOVE E,1(C) ; HAVE VERS\r
+ PUSHJ P,EOUT ; OUT IT GOES\r
+\r
+PFIXU2: HRRZ C,(C) ; FIRST THING\r
+ JUMPE C,PFIXU3 ; DONE?\r
+ GETYP A,(C) ; STRING OR ATOM\r
+ CAIN A,TATOM ; MUST BE STRING\r
+ JRST PFIXU4\r
+ MOVE A,1(C) ; POINT TO POINTER\r
+ HRRZ D,(A) ; LENGTH\r
+ IDIVI D,5\r
+ PUSH P,E ; SAVE REMAINDER\r
+ MOVEI E,1(D)\r
+ MOVNI D,(D)\r
+ MOVSI D,(D)\r
+ PUSH P,D\r
+ PUSHJ P,EOUT\r
+ MOVEI D,0\r
+PFXU1A: MOVE A,1(C) ; RESTORE POINTER\r
+ HRRZ A,1(A) ; BYTE POINTER\r
+ ADD A,(P)\r
+ MOVE E,(A)\r
+ PUSHJ P,EOUT\r
+ MOVE A,[1,,1]\r
+ ADDB A,(P)\r
+ JUMPL A,PFXU1A\r
+ MOVE D,-1(P) ; LAST WORD\r
+ MOVE A,1(C)\r
+ HRRZ A,1(A)\r
+ ADD A,(P)\r
+ SKIPE E,D\r
+ MOVE E,(A) ; LAST WORD OF CHARS\r
+ IOR E,PADS(D)\r
+ PUSHJ P,EOUT ; OUT\r
+ SUB P,[1,,1]\r
+ JRST PFIXU5\r
+\r
+PADS: ASCII /#####/\r
+ ASCII /####/\r
+ ASCII /\ 2###/\r
+ ASCII /\ 2##/\r
+ ASCII /\ 2\ 2#/\r
+\r
+PFIXU4: HRRZ E,(C) ; GET CURRENT VAL\r
+ MOVE E,1(E)\r
+ PUSHJ P,ATOSQ ; GET SQUOZE\r
+ JRST BADFXU\r
+ TLO E,400000 ; USE TO DIFFERENTIATE BETWEEN STRING\r
+ PUSHJ P,EOUT\r
+\r
+; HERE TO WRITE OUT LISTS\r
+\r
+PFIXU5: HRRZ C,(C) ; POINT TO CURRENT VALUE\r
+ HRLZ E,1(C)\r
+ HRRZ C,(C) ; POINT TO USES LIST\r
+ HRRZ D,1(C) ; GET IT\r
+\r
+PFIXU6: TLCE D,400000 ; SKIP FOR RH\r
+ HRLZ E,1(D) ; SETUP LH\r
+ JUMPG D,.+3\r
+ HRR E,1(D)\r
+ PUSHJ P,EOUT ; WRITE IT OUT\r
+ HRR D,(D)\r
+ TRNE D,-1 ; SKIP IF DONE\r
+ JRST PFIXU6\r
+\r
+ TRNE E,-1 ; SKIP IF ZERO BYTE EXISTS\r
+ MOVEI E,0\r
+ PUSHJ P,EOUT\r
+ JRST PFIXU2 ; DO NEXT\r
+\r
+PFIXU3: HLRE C,(TP) ; -AMNT LEFT IN BUFFER\r
+ MOVN D,C ; PLUS SAME\r
+ ADDI C,BUFLNT ; WORDS USED TO C\r
+ JUMPE C,PFIXU7 ; NONE USED, LEAVE\r
+ MOVSS C ; START SETTING UP BTB\r
+ MOVN A,C ; ALSO FINAL IOT POINTER\r
+ HRR C,(TP) ; PDL POINTER PART OF BTB\r
+ SUBI C,1\r
+ HRLI D,C ; CONTINUE SETTING UP BTB\r
+ POP C,@D ; MOVE 'EM DOWN\r
+ TLNE C,-1\r
+ JRST .-2\r
+ HRRI A,@D ; OUTPUT POINTER\r
+ ADDI A,1\r
+ MOVSI B,TUVEC\r
+ MOVEM B,ASTO(PVP)\r
+ MOVE B,-6(TP)\r
+ PUSHJ P,DOIOTO ; WRITE IT OUT\r
+ SETZM ASTO(PVP)\r
+\r
+PFIXU7: SUB TP,[4,,4]\r
+ SUB P,[2,,2]\r
+ JRST PNEXT\r
+\r
+; ROUTINE TO OUTPUT CONTENTS OF E\r
+\r
+EOUT: MOVE B,-6(TP) ; CHANNEL\r
+ AOS ACCESS(B)\r
+ MOVE A,(TP) ; BUFFER POINTER\r
+ MOVEM E,(A)\r
+ AOBJP A,.+3 ; COUNT AND GO\r
+ MOVEM A,(TP)\r
+ POPJ P,\r
+\r
+ SUBI A,BUFLNT ; SET UP IOT POINTER\r
+ HRLI A,-BUFLNT\r
+ MOVEM A,(TP) ; RESET SAVED POINTER\r
+ MOVSI 0,TUVEC\r
+ MOVEM 0,ASTO(PVP)\r
+ MOVSI 0,TLIST\r
+ MOVEM 0,DSTO(PVP)\r
+ MOVEM 0,CSTO(PVP)\r
+ PUSHJ P,DOIOTO ; OUT IT GOES\r
+ SETZM ASTO(PVP)\r
+ SETZM CSTO(PVP)\r
+ SETZM DSTO(PVP)\r
+ POPJ P,\r
+\r
+; HERE IF UVECOR FORM OF FIXUPS\r
+\r
+UFIXES: PUSH TP,$TUVEC\r
+ PUSH TP,A ; SAVE IT\r
+\r
+UFIX1: MOVE B,-6(TP) ; GET SAME\r
+ PUSHJ P,BFCLS1 ; FLUSH OUT BUFFER\r
+ HLRE C,(TP) ; GET LENGTH\r
+ MOVMS C\r
+ PUSH P,C\r
+ HRROI A,(P) ; READY TO ZAP IT OUT\r
+ PUSHJ P,DOIOTO ; ZAP!\r
+ SUB P,[1,,1]\r
+ HLRE C,(TP) ; LENGTH BACK\r
+ MOVMS C\r
+ ADDI C,1\r
+ ADDM C,ACCESS(B) ; UPDATE ACCESS\r
+ MOVE A,(TP) ; NOW THE UVECTOR\r
+ MOVSI C,TUVEC\r
+ MOVEM C,ASTO(PVP)\r
+ PUSHJ P,DOIOTO ; GO\r
+ SETZM ASTO(PVP)\r
+ SUB P,[1,,1]\r
+ SUB TP,[4,,4]\r
+ JRST PNEXT\r
+\r
+RCANT: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE RSUBR-LACKS-FIXUPS\r
+ JRST CALER1\r
+\r
+\r
+BADFXU: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE BAD-FIXUPS\r
+ JRST CALER1\r
+\r
+PRBODY: TDZA C,C ; FLAG SAYING FLUSH CODE\r
+PRBOD1: MOVEI C,1 ; PRINT CODE ALSO\r
+ PUSH P,FLAGS\r
+ PUSH TP,$TRSUBR\r
+ PUSH TP,B\r
+ PUSH P,C\r
+ MOVEI A,"[ ; START VECTOR TEXT\r
+ MOVE B,-6(TP) ; GET CHANNEL FOR PITYO\r
+ PUSHJ P,PITYO\r
+ POP P,C\r
+ MOVE B,(TP) ; RSUBR BACK\r
+ JUMPN C,PRSON ; GO START PRINTING\r
+ MOVEI A,"0 ; PLACE SAVER FOR CODE VEC\r
+ MOVE B,-6(TP) ; GET CHANNEL FOR PITYO\r
+ PUSHJ P,PITYO\r
+\r
+PRSBR2: MOVE B,[2,,2] ; BUMP VECTOR\r
+ ADDB B,(TP)\r
+ JUMPGE B,PRSBR3 ; NO SPACE IF LAST\r
+ MOVE B,-6(TP) ; GET CHANNEL FOR SPACEQ\r
+ PUSHJ P,SPACEQ\r
+ SKIPA B,(TP) ; GET BACK POINTER\r
+PRSON: JUMPGE B,PRSBR3\r
+ GETYP 0,(B) ; SEE IF RSUBR POINTED TO\r
+ CAIN 0,TENTER\r
+ JRST .+3 ; JUMP IF RSUBR ENTRY\r
+ CAIE 0,TRSUBR ; YES!\r
+ JRST PRSB10 ; COULD BE SUBR/FSUBR\r
+ MOVE C,1(B) ; GET RSUBR\r
+ PUSH P,0 ; SAVE TYPE FOUND\r
+ GETYP 0,2(C) ; SEE IF ATOM\r
+ CAIE 0,TATOM\r
+ JRST PRSBR4\r
+ MOVE B,3(C) ; GET ATOM NAME\r
+ PUSHJ P,IGVAL ; GO LOOK\r
+ MOVE C,(TP) ; ORIG RSUBR BACK\r
+ GETYP A,A\r
+ POP P,0 ; DESIRED TYPE\r
+ CAIE 0,(A) ; SAME TYPE\r
+ JRST PRSBR4\r
+ MOVE D,1(C)\r
+ MOVE 0,3(D) ; NAME OF RSUBR IN QUESTION\r
+ CAME 0,3(B) ; WIN?\r
+ JRST PRSBR4\r
+ MOVEM 0,1(C)\r
+ MOVSI A,TATOM\r
+ MOVEM A,(C) ; UNLINK\r
+\r
+PRSBR4: MOVE FLAGS,(P) ; RESTORE FLAGS\r
+ MOVE B,(TP)\r
+ MOVE A,(B)\r
+ MOVE B,1(B) ; PRINT IT\r
+ PUSH TP,-7(TP) ; PUSH CHANNEL FOR IPRINT\r
+ PUSH TP,-7(TP)\r
+ PUSHJ P,IPRINT\r
+ SUB TP,[2,,2] ; POP OFF CHANNEL\r
+ JRST PRSBR2\r
+\r
+PRSB10: CAIE 0,TSUBR ; SUBR?\r
+ CAIN 0,TFSUBR\r
+ JRST .+2\r
+ JRST PRSBR4\r
+ MOVE C,1(B) ; GET LOCN OF SUBR OR FSUBR\r
+ MOVE C,@-1(C) ; NAME OF IT\r
+ MOVEM C,1(B) ; SMASH\r
+ MOVSI C,TATOM ; AND TYPE\r
+ MOVEM C,(B)\r
+ JRST PRSBR4\r
+\r
+PRSBR3: MOVEI A,"]\r
+ MOVE B,-6(TP)\r
+ PUSHJ P,PRETIF ; CLOSE IT UP\r
+ SUB TP,[2,,2] ; FLUSH CRAP\r
+ POP P,FLAGS\r
+ POPJ P,\r
+\r
+\r
+\f; HERE TO PRINT PURE RSUBRS\r
+\r
+PRSBRP: MOVEI A,2 ; WILL "%<" FIT?\r
+ MOVE B,-2(TP) ; GET CHANNEL FOR RETIF\r
+ PUSHJ P,RETIF\r
+ MOVEI A,"%\r
+ PUSHJ P,PITYO\r
+ MOVEI A,"<\r
+ PUSHJ P,PITYO\r
+ MOVSI A,TATOM\r
+ MOVE B,MQUOTE RSUBR\r
+ PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT\r
+ PUSH TP,-3(TP)\r
+ PUSHJ P,IPRINT ; PRINT IT OUT\r
+ SUB TP,[2,,2] ; POP OFF CHANNEL\r
+ MOVE B,-2(TP)\r
+ PUSHJ P,SPACEQ ; MAYBE SPACE\r
+ MOVEI A,"' ; QUOTE THE VECCTOR\r
+ PUSHJ P,PRETIF\r
+ MOVE B,(TP) ; GET RSUBR BODY BACK\r
+ PUSH TP,$TFIX ; STUFF THE STACK\r
+ PUSH TP,[0]\r
+ PUSHJ P,PRBOD1 ; PRINT AND UNLINK\r
+ SUB TP,[2,,2] ; GET JUNK OFF STACK\r
+ MOVE B,-2(TP) ; GET CHANNEL FOR RETIF\r
+ MOVEI A,">\r
+ PUSHJ P,PRETIF\r
+ JRST PNEXT\r
+\r
+; HERE TO PRINT ASCII RSUBRS\r
+\r
+ARSUBR: PUSH P,FLAGS ; SAVE FROM GET\r
+ MOVSI A,TRSUBR\r
+ MOVE B,(TP)\r
+ MOVSI C,TATOM\r
+ MOVE D,MQUOTE RSUBR\r
+ PUSHJ P,IGET ; TRY TO GET FIXUPS\r
+ POP P,FLAGS\r
+ JUMPE B,PUNK ; NO FIXUPS LOSE\r
+ GETYP A,A\r
+ CAIE A,TLIST ; ARE FIXUPS A LIST?\r
+ JRST PUNK ; NO, AGAIN LOSE\r
+ PUSH TP,$TLIST\r
+ PUSH TP,B ; SAVE FIXUPS\r
+ MOVEI A,17.\r
+\r
+ MOVE B,-4(TP)\r
+ PUSHJ P,RETIF\r
+ PUSH P,[440700,,[ASCIZ /%<FIXUP!-RSUBRS!-/]]\r
+\r
+AL1: ILDB A,(P) ; GET CHAR\r
+ JUMPE A,.+3\r
+ PUSHJ P,PITYO\r
+ JRST AL1\r
+\r
+ SUB P,[1,,1]\r
+ PUSHJ P,SPACEQ\r
+\r
+ MOVEI A,"'\r
+ PUSHJ P,PRETIF ; QUOTE TO AVOID ADDITIONAL EVAL\r
+ MOVE B,-2(TP) ; PRINT ACTUAL KLUDGE\r
+ PUSHJ P,PRBOD1\r
+ MOVE B,-4(TP) ; GET CHANNEL FOR SPACEQ\r
+ PUSHJ P,SPACEQ\r
+ MOVEI A,"' ; DONT EVAL FIXUPS EITHER\r
+ PUSHJ P,PRETIF\r
+ POP TP,B\r
+ POP TP,A\r
+ PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT\r
+ PUSH TP,-3(TP)\r
+ PUSHJ P,IPRINT\r
+ SUB TP,[2,,2] ; POP CHANNEL OFF STACK\r
+ MOVE B,-2(TP) ; GET CHANNEL INTO B\r
+ MOVEI A,">\r
+ PUSHJ P,PRETIF\r
+ JRST PNEXT\r
+\r
+\f; HERE TO DO LOCATIVES (PRINT CONTENTS THEREOF)\r
+\r
+LOCP: PUSH TP,-1(TP)\r
+ PUSH TP,-1(TP)\r
+ PUSH P,0\r
+ MCALL 1,IN ; GET ITS CONTENTS FROM "IN"\r
+ POP P,0\r
+ PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT\r
+ PUSH TP,-3(TP)\r
+ PUSHJ P,IPRINT ; PRINT IT\r
+ SUB TP,[2,,2] ; POP CHANNEL OFF STACK\r
+ JRST PNEXT\r
+\f;INTERNAL SUBROUTINE TO HANDLE CHARACTER OUTPUT\r
+;B CONTAINS CHANNEL\r
+;PRINTER ITYO USED FOR FLATSIZE FAKE OUT\r
+PITYO: TLNN FLAGS,FLTBIT\r
+ JRST ITYO\r
+PITYO1: PUSH TP,[TTP,,0] ; PUSH ON TP POINTER\r
+ PUSH TP,B\r
+ TLNE FLAGS,UNPRSE ;SKIPS UNPRSE NOT SET\r
+ JRST ITYO+2\r
+ AOS FLTSIZ ;FLATSIZE DOESN'T PRINT\r
+ ;INSTEAD IT COUNTS THE CHARACTERS THAT WOULD BE OUTPUT\r
+ SOSGE FLTMAX ;UNLESS THE MAXIMUM IS EXCEEDED\r
+ JRST .+4\r
+ POP TP,B ; GET CHANNEL BACK\r
+ SUB TP,[1,,1]\r
+ POPJ P,\r
+ MOVEI E,(B) ; GET POINTER FOR UNBINDING\r
+ PUSHJ P,SSPEC1\r
+ MOVE P,UPB+8 ; RESTORE P\r
+ POP TP,B ; GET BACK TP POINTER\r
+ PUSH P,0 ; SAVE FLAGS\r
+ MOVE TP,B ; RESTORE TP\r
+PITYO3: MOVEI C,(TB)\r
+ CAILE C,1(TP)\r
+ JRST PITYO2\r
+ POP P,0 ; RESTORE FLAGS\r
+ MOVSI A,TFALSE ;IN WHICH CASE IT IMMEDIATELY GIVES UP AND RETURNS FALSE\r
+ MOVEI B,0\r
+ POPJ P,\r
+\r
+PITYO2: HRR TB,OTBSAV(TB) ; RESTORE TB\r
+ JRST PITYO3\r
+\r
+\r
+\f;THE REAL THING\r
+;NOTE THAT THE FOLLOWING CODE HAS BUGS IF IT IS PRINTING OUT LONG\r
+;CHARACTER STRINGS\r
+; (NOTE THAT THE ABOVE COMMENT, IF TRUE, SHOULD NOT BE ADMITTED.)\r
+ITYO: PUSH TP,$TCHAN\r
+ PUSH TP,B\r
+ PUSH P,FLAGS ;SAVE STUFF\r
+ PUSH P,C\r
+ITYOCH: PUSH P,A ;SAVE OUTPUT CHARACTER\r
+\r
+\r
+ITYO1: TLNE FLAGS,UNPRSE ;SKIPS UNPRSE NOT SET\r
+ JRST UNPROUT ;IF FROM UNPRSE, STASH IN STRING\r
+ CAIE A,^L ;SKIP IF THIS IS A FORM-FEED\r
+ JRST NOTFF\r
+ SETZM LINPOS(B) ;ZERO THE LINE NUMBER\r
+ JRST ITYXT\r
+\r
+NOTFF: CAIE A,15 ;SKIP IF IT IS A CR\r
+ JRST NOTCR\r
+ SETZM CHRPOS(B) ;ZERO THE CHARACTER POSITION\r
+ PUSHJ P,WXCT ;OUTPUT THE C-R\r
+ PUSHJ P,AOSACC ; BUMP COUNT\r
+ AOS C,LINPOS(B) ;ADD ONE TO THE LINE NUMBER\r
+ CAMG C,PAGLN(B) ;SKIP IF THIS TAKES US PAST PAGE END\r
+ JRST ITYXT1\r
+\r
+ SETZM LINPOS(B) ;ZERO THE LINE POSITION\r
+; PUSHJ P,WXCT ; REMOVED FOR NOW\r
+; PUSHJ P,AOSACC\r
+; MOVEI A,^L ; DITTO\r
+ JRST ITYXT1\r
+\r
+NOTCR: CAIN A,^I ;SKIP IF NOT TAB\r
+ JRST TABCNT\r
+ CAIE A,10 ; BACK SPACE\r
+ JRST .+3\r
+ SOS CHRPOS(B) ; BACK UP ONE\r
+ JRST ITYXT\r
+ CAIE A,^J ;SKIP IF LINE FEED\r
+ AOS CHRPOS(B) ;ADD TO CHARACTER NUMBER\r
+\r
+ITYXT: PUSHJ P,AOSACC ; BUMP ACCESS\r
+ITYXTA: PUSHJ P,WXCT ;OUTPUT THE CHARACTER\r
+ITYXT1: POP P,A ;RESTORE THE ORIGINAL CHARACTER\r
+\r
+ITYRET: POP P,C ;RESTORE REGS & RETURN\r
+ POP P,FLAGS\r
+ POP TP,B ; GET CHANNEL BACK\r
+ SUB TP,[1,,1]\r
+ POPJ P,\r
+\r
+TABCNT: PUSH P,D\r
+ MOVE C,CHRPOS(B)\r
+ ADDI C,8. ;INCREMENT COUNT BY EIGHT (MOD EIGHT)\r
+ IDIVI C,8.\r
+ IMULI C,8.\r
+ MOVEM C,CHRPOS(B) ;REPLACE COUNT\r
+ POP P,D\r
+ JRST ITYXT\r
+\r
+UNPROUT: POP P,A ;GET BACK THE ORIG CHAR\r
+ IDPB A,UPB+2 ;DEPOSIT USING BYTE POINTER I PUSHED LONG AGO\r
+ SOS UPB+1\r
+ JRST ITYRET ;RETURN\r
+\r
+AOSACC: TLNN FLAGS,BINBIT\r
+ JRST NRMACC\r
+ AOS C,ACCESS-1(B) ; COUNT CHARS IN WORD\r
+ CAMN C,[TFIX,,1]\r
+ AOS ACCESS(B)\r
+ CAMN C,[TFIX,,5]\r
+ HLLZS ACCESS-1(B)\r
+ POPJ P,\r
+\r
+NRMACC: AOS ACCESS(B)\r
+ POPJ P,\r
+\r
+SPACEQ: MOVEI A,40\r
+ TLNE FLAGS,FLTBIT+BINBIT\r
+ JRST PITYO ; JUST OUTPUT THE SPACE\r
+ PUSH P,[1] ; PRINT SPACE IF NOT END OF LINE\r
+ MOVEI A,1\r
+ JRST RETIF2\r
+\r
+RETIF1: MOVEI A,1\r
+\r
+RETIF: PUSH P,[0]\r
+ TLNE FLAGS,FLTBIT+BINBIT\r
+ JRST SPOPJ ; IF WE ARE IN FLATSIZE THEN ESCAPE\r
+RETIF2: PUSH P,FLAGS\r
+RETCH: PUSH P,A\r
+\r
+RETCH1: ADD A,CHRPOS(B) ;ADD THE CHARACTER POSITION\r
+ SKIPN CHRPOS(B) ; IF JUST RESET, DONT DO IT AGAIN\r
+ JRST RETXT\r
+ CAMG A,LINLN(B) ;SKIP IF GREATER THAN LINE LENGTH\r
+ JRST RETXT1\r
+\r
+ MOVEI A,^M ;FORCE A CARRIAGE RETURN\r
+ SETZM CHRPOS(B)\r
+ PUSHJ P,WXCT\r
+ PUSHJ P,AOSACC ; BUMP CHAR COUNT\r
+ MOVEI A,^J ;AND FORCE A LINE FEED\r
+ PUSHJ P,WXCT\r
+ PUSHJ P,AOSACC ; BUMP CHAR COUNT\r
+ AOS A,LINPOS(B)\r
+ CAMG A,PAGLN(B) ;AT THE END OF THE PAGE ?\r
+ JRST RETXT\r
+; MOVEI A,^L ;IF SO FORCE A FORM FEED\r
+; PUSHJ P,WXCT\r
+; PUSHJ P,AOSACC ; BUMP CHAR COUNT\r
+ SETZM LINPOS(B)\r
+\r
+RETXT: POP P,A\r
+\r
+ POP P,FLAGS\r
+SPOPJ: SUB P,[1,,1]\r
+ POPJ P, ;RETURN\r
+\r
+PRETIF: PUSH P,A ;SAVE CHAR\r
+ PUSHJ P,RETIF1\r
+ POP P,A\r
+ JRST PITYO\r
+\r
+RETIF3: TLNE FLAGS,FLTBIT ; NOTHING ON FLATSIZE\r
+ POPJ P,\r
+ PUSH P,[0]\r
+ PUSH P,FLAGS\r
+ HRRI FLAGS,2 ; PRETEND ONLY 1 CHANNEL\r
+ PUSH P,A\r
+ JRST RETCH1\r
+\r
+RETXT1: SKIPN -2(P) ; SKIP IF SPACE HACK\r
+ JRST RETXT\r
+ MOVEI A,40\r
+ PUSHJ P,WXCT\r
+ AOS CHRPOS(B)\r
+ PUSH P,C\r
+ PUSHJ P,AOSACC\r
+ POP P,C\r
+ JRST RETXT\r
+\r
+\f;THIS IS CODE TO HANDLE UNKNOWN DATA TYPES.\r
+;IT PRINTS "*XXXXXX*XXXXXXXXXXXX*", WHERE THE FIRST NUMBER IS THE\r
+;TYPE CODE IN OCTAL, THE SECOND IS THE VALUE FIELD IN OCTAL.\r
+PRERR: MOVEI A,21. ;CHECK FOR 21. SPACES LEFT ON PRINT LINE\r
+ MOVE B,-2(TP) ; GET CHANNEL INTO B\r
+ PUSHJ P,RETIF ;INSERT CARRIAGE RETURN IF NOT ENOUGH\r
+ MOVEI A,"* ;JUNK TO INDICATE ERROR PRINTOUT IN OCTAL\r
+ PUSHJ P,PITYO ;TYPE IT\r
+\r
+ MOVE E,[000300,,-2(TP)] ;GET POINTER INDEXED OFF TP SO THAT\r
+ ;TYPE CODE MAY BE OBTAINED FOR PRINTING.\r
+ MOVEI D,6 ;# OF OCTAL DIGITS IN HALF WORD\r
+OCTLP1: ILDB A,E ;GET NEXT 3-BIT BYTE OF TYPE CODE\r
+ IORI A,60 ;OR-IN 60 FOR ASCII DIGIT\r
+ PUSHJ P,PITYO ;PRINT IT\r
+ SOJG D,OCTLP1 ;REPEAT FOR SIX CHARACTERS\r
+\r
+PRE01: MOVEI A,"* ;DELIMIT TYPE CODE FROM VALUE FIELD\r
+ PUSHJ P,PITYO\r
+\r
+ HRLZI E,(410300,,(TP)) ;BYTE POINTER TO SECOND WORD\r
+ ;INDEXED OFF TP\r
+ MOVEI D,12. ;# OF OCTAL DIGITS IN A WORD\r
+OCTLP2: LDB A,E ;GET 3 BITS\r
+ IORI A,60 ;CONVERT TO ASCII\r
+ PUSHJ P,PITYO ;PRINT IT\r
+ IBP E ;INCREMENT POINTER TO NEXT BYTE\r
+ SOJG D,OCTLP2 ;REPEAT FOR 12. CHARS\r
+\r
+ MOVEI A,"* ;DELIMIT END OF ERROR TYPEOUT\r
+ PUSHJ P,PITYO ;REPRINT IT\r
+\r
+ JRST PNEXT ;RESTORE REGS & POP UP ONE LEVEL TO CALLER\r
+\r
+POCTAL: MOVEI A,14. ;RETURN TO NEW LINE IF 14. SPACES NOT LEFT\r
+ MOVE B,-2(TP) ; GET CHANNEL INTO B\r
+ PUSHJ P,RETIF\r
+ JRST PRE01 ;PRINT VALUE AS "*XXXXXXXXXXXX*"\r
+\r
+\f;PRINT BINARY INTEGERS IN DECIMAL.\r
+;\r
+PFIX: MOVM E,(TP) ; GET # (MAFNITUDE)\r
+ JUMPL E,POCTAL ; IF ABS VAL IS NEG, MUST BE SETZ\r
+ PUSH P,FLAGS\r
+\r
+PFIX1: MOVE B,-2(TP) ; GET CHANNEL INTO B\r
+PFIX2: MOVE D,UPB+6 ; IF UNPARSE, THIS IS RADIX\r
+ TLNE FLAGS,UNPRSE+FLTBIT ;SKIPS IF NOT FROM UNPARSE OR FLATSIZE\r
+ JRST PFIXU\r
+ MOVE D,RADX(B) ; GET OUTPUT RADIX\r
+PFIXU: CAIG D,1 ; DONT ALLOW FUNNY RADIX\r
+ MOVEI D,10. ; IF IN DOUBT USE 10.\r
+ PUSH P,D\r
+ MOVEI A,1 ; START A COUNTER\r
+ SKIPGE B,(TP) ; CHECK SIGN\r
+ MOVEI A,2 ; NEG, NEED CHAR FOR SIGN\r
+\r
+ IDIV B,D ; START COUNTING\r
+ JUMPE B,.+2\r
+ AOJA A,.-2\r
+\r
+ MOVE B,-2(TP) ; CHANNEL TO B\r
+ TLNN FLAGS,FLTBIT+BINBIT\r
+ PUSHJ P,RETIF3 ; CHECK FOR C.R.\r
+ MOVE B,-2(TP) ; RESTORE CHANNEL\r
+ MOVEI A,"- ; GET SIGN\r
+ SKIPGE (TP) ; SKIP IF NOT NEEDED\r
+ PUSHJ P,PITYO\r
+ MOVM C,(TP) ; GET MAGNITUDE OF #\r
+ MOVE B,-2(TP) ; RESTORE CHANNEL\r
+ POP P,E ; RESTORE RADIX\r
+ PUSHJ P,FIXTYO ; WRITE OUT THE #\r
+ MOVE FLAGS,-1(P)\r
+ SUB P,[1,,1] ; FLUSH P STUFF\r
+ JRST PNEXT\r
+\r
+FIXTYO: IDIV C,E\r
+ HRLM D,(P) ; SAVE REMAINDER\r
+ SKIPE C\r
+ PUSHJ P,FIXTYO\r
+ HLRZ A,(P) ; START GETTING #'S BACK\r
+ ADDI A,60\r
+ MOVE B,-2(TP) ; CHANNEL BACK\r
+ JRST PITYO\r
+\r
+\f;PRINT SINGLE-PRECISION FLOATING POINT NUMBERS IN DECIMAL.\r
+;\r
+PFLOAT: SKIPN A,(TP) ; SKIP IF NUMBER IS NON-ZERO (SPECIAL HACK FOR ZERO)\r
+ JRST PFLT0 ; HACK THAT ZERO\r
+ MOVM E,A ; CHECK FOR NORMALIZED\r
+ TLNN E,400 ; NORMALIZED\r
+ JRST PUNK\r
+ MOVEI E,FLOATB ;ADDRESS OF FLOATING POINT CONVERSION ROUTINE\r
+ MOVE D,[6,,6] ;# WORDS TO GET FROM STACK\r
+\r
+PNUMB: HRLI A,1(P) ;LH(A) TO CONTAIN ADDRESS OF RETURN AREA ON STACK\r
+ HRR A,TP ;RH(A) TO CONTAIN ADDRESS OF DATA ITEM\r
+ HLRZ B,A ;SAVE RETURN AREA ADDRESS IN REG B\r
+ ADD P,D ;ADD # WORDS OF RETURN AREA TO BOTH HALVES OF SP\r
+ JUMPGE P,PDLERR ;PLUS OR ZERO STACK POINTER IS OVERFLOW\r
+PDLWIN: PUSHJ P,(E) ;CALL ROUTINE WHOSE ADDRESS IS IN REG E\r
+\r
+ MOVE C,(B) ;GET COUNT 0F # CHARS RETURNED\r
+ MOVE A,C ;MAKE SURE THAT # WILL FIT ON PRINT LINE\r
+PFLT1: PUSH P,B ; SAVE B\r
+ MOVE B,-2(TP) ; GET CHANNEL INTO B\r
+ PUSHJ P,RETIF ;START NEW LINE IF IT WON'T\r
+ POP P,B ; RESTORE B\r
+\r
+ HRLI B,000700 ;MAKE REG B INTO BYTE POINTER TO FIRST CHAR LESS ONE\r
+PNUM01: ILDB A,B ;GET NEXT BYTE\r
+ PUSH P,B ;SAVE B\r
+ MOVE B,-2(TP) ; GET CHANNEL INTO B\r
+ PUSHJ P,PITYO ;PRINT IT\r
+\r
+ P,B ; RESTORE B\r
+ SOJG C,PNUM01 ;DECREMENT CHAR COUNT: LOOP IF NON-ZERO\r
+\r
+ SUB P,D ;SUBTRACT # WORDS USED ON STACK FOR RETURN\r
+ JRST PNEXT ;STORE REGS & POP UP ONE LEVEL TO CALLER\r
+\r
+\r
+PFLT0: MOVEI A,9. ; WIDTH OF 0.0000000\r
+ MOVEI C,9. ; SEE ABOVE\r
+ MOVEI D,0 ; WE'RE GONNA TEST D SOON...SO WILL DO RIGHT THING\r
+ MOVEI B,[ASCII /0.0000000/]\r
+ SOJA B,PFLT1 ; PT TO 1 BELOW CONST, THEN REJOIN CODE\r
+\r
+\r
+\r
+\r
+PDLERR: SUB P,D ;REST STACK POINTER\r
+REPEAT 6,PUSH P,[0]\r
+ JRST PDLWIN\r
+\f;PRINT SHORT (ONE WORD) CHARACTER STRINGS\r
+;\r
+PCHRS: MOVEI A,3 ;MAX # CHARS PLUS 2 (LESS ESCAPES)\r
+ MOVE B,-2(TP) ; GET CHANNEL INTO B\r
+ TLNE FLAGS,NOQBIT ;SKIP IF QUOTES WILL BE USED\r
+ MOVEI A,1 ;ELSE, JUST ONE CHARACTER POSSIBLE\r
+ PUSHJ P,RETIF ;NEW LINE IF INSUFFICIENT SPACE\r
+ TLNE FLAGS,NOQBIT ;DON'T QUOTE IF IN PRINC MODE\r
+ JRST PCASIS\r
+ MOVEI A,"! ;TYPE A EXCL\r
+ PUSHJ P,PITYO\r
+ MOVEI A,"" ;AND A DOUBLE QUOTE\r
+ PUSHJ P,PITYO\r
+\r
+PCASIS: MOVE A,(TP) ;GET NEXT BYTE FROM WORD\r
+ TLNE FLAGS,NOQBIT ;SKIP IF WE ARE NOT IN PRINC MODE (NOQBIT=0)\r
+ JRST PCPRNT ;IF BIT IS ON, PRINT WITHOUT ESCAPING\r
+ CAIE A,ESCHAR ;SKIP IF NOT THE ESCAPE CHARACTER\r
+ JRST PCPRNT ;ESCAPE THE ESCAPE CHARACTER\r
+\r
+ESCPRT: MOVEI A,ESCHAR ;TYPE THE ESCAPE CHARACTER\r
+ PUSHJ P,PITYO \r
+\r
+PCPRNT: MOVE A,(TP) ;GET THE CHARACTER AGAIN\r
+ PUSHJ P,PITYO ;PRINT IT\r
+ JRST PNEXT\r
+\r
+\r
+\f;PRINT DEFERED (INVISIBLE) ITEMS. (PRINTED AS THE THING POINTED TO)\r
+;\r
+PDEFER: MOVE A,(B) ;GET FIRST WORD OF ITEM\r
+ MOVE B,1(B) ;GET SECOND\r
+ PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT\r
+ PUSH TP,-3(TP)\r
+ PUSHJ P,IPRINT ;PRINT IT\r
+ SUB TP,[2,,2] ; POP OFF CHANNEL\r
+ JRST PNEXT ;GO EXIT\r
+\r
+\r
+; Print an ATOM. TRAILERS are added if the atom is not in the current\r
+; lexical path. Also escaping of charactets is performed to allow READ\r
+; to win.\r
+\r
+PATOM: PUSH P,[440700,,D] ; PUSH BYE POINTER TO FINAL STRING\r
+ SETZB D,E ; SET CHARCOUNT AD DESTINATION TO 0\r
+ HLLZS -1(TP) ; RH OF TATOM,, WILL COUNT ATOMS IN PATH\r
+\r
+PATOM0: PUSH TP,$TPDL ; SAVE CURRENT STAKC FOR \ LOGIC\r
+ PUSH TP,P\r
+ LDB A,[301400,,(P)] ; GET BYTE PTR POSITION\r
+ DPB A,[301400,,E] ; SAVE IN E\r
+ MOVE C,-2(TP) ; GET ATOM POINTER\r
+ ADD C,[3,,3] ; POINT TO PNAME\r
+ HLRE A,C ; -# WORDS TO A\r
+ PUSH P,A ; PUSH THAT FOR "AOSE"\r
+ MOVEI A,177 ; PUT RUBOUT WHERE \ MIGHT GO\r
+ JSP B,DOIDPB\r
+ HRLI C,440700 ; BUILD BYET POINTER\r
+\r
+PATOM1: ILDB A,C ; GET A CHAR\r
+ JUMPE A,PATDON ; END OF PNAME?\r
+ TLNN C,760000 ; SKIP IF NOT WORD BOUNDARY\r
+ AOS (P) ; COUNT WORD\r
+ JRST PENTCH ; ENTER THE CHAR INTO OUTPUT\r
+\r
+PATDON: LDB A,[220600,,E] ; GET "STATE"\r
+ LDB A,STABYT+6 ; SIMULATE "END" CHARACTER\r
+ DPB A,[220600,,E] ; AND STORE\r
+ MOVE B,E ; SETUP BYTE POINTER TO 1ST CHAR\r
+ TLZ B,77\r
+ HRR B,(TP) ; POINT\r
+ SUB TP,[2,,2] ; FLUSH SAVED PDL\r
+ MOVE C,-1(P) ; GET BYE POINTER\r
+ SUB P,[2,,2] ; FLUSH\r
+ PUSH P,D\r
+ MOVEI A,0\r
+ IDPB A,B\r
+ AOS -1(TP) ; COUNT ATOMS\r
+ TLNE FLAGS,NOQBIT ; SKIP IF NOT "PRINC"\r
+ JRST NOLEX4 ; NEEDS NO LEXICAL TRAILERS\r
+ MOVEI A,"\ ; GET QUOTER\r
+ TLNN E,2 ; SKIP IF NEEDED\r
+ JRST PATDO1\r
+ SOS -1(TP) ; DONT COUNT BECAUSE OF SLASH\r
+ DPB A,B ; CLOBBER\r
+PATDO1: MOVEI E,(E) ; CLEAR LH(E)\r
+ PUSH P,C ; SAVE BYTER\r
+ PUSH P,E ; ALSO CHAR COUNT\r
+\r
+ MOVE B,IMQUOTE OBLIST\r
+ PUSH P,FLAGS\r
+ PUSHJ P,IDVAL ; GET LOCAL/GLOBAL VALUE\r
+ POP P,FLAGS ; AND RESTORES FLAGS\r
+ MOVE C,(TP) ; GET ATOM BACK\r
+ SKIPN C,2(C) ; GET ITS OBLIST\r
+ AOJA A,NOOBL1 ; NONE, USE FALSE\r
+ JUMPL C,.+3 ; JUMP IF REAL OBLIST\r
+ ADDI C,(TVP) ; ELSE MUST BE OFFSET\r
+ MOVE C,(C)\r
+ CAME A,$TLIST ; SKIP IF A LIST\r
+ CAMN A,$TOBLS ; SKIP IF UNREASONABLE VALUE\r
+ JRST CHOBL ; WINS, NOW LOCATE IT\r
+\r
+CHROOT: CAME C,ROOT+1(TVP) ; IS THIS ROOT?\r
+ JRST FNDOBL ; MUST FIND THE PATH NAME\r
+ POP P,E ; RESTORE CHAR COUNT\r
+ MOVE D,(P) ; AND PARTIAL WORD\r
+ EXCH D,-1(P) ; STORE BYTE POINTER AND GET PARTIAL WORD\r
+ MOVEI A,"! ; PUT OUT MAGIC\r
+ JSP B,DOIDPB ; INTO BUFFER\r
+ MOVEI A,"- \r
+ JSP B,DOIDPB\r
+ MOVEI A,40\r
+ JSP B,DOIDPB\r
+\r
+NOLEX0: SUB P,[2,,2] ; REMOVE COUNTER AND BYTE POINTER\r
+ PUSH P,D ; PUSH NEXT WORD IF ANY\r
+ JRST NOLEX4\r
+\r
+NOLEX: MOVE E,(P) ; GET COUNT\r
+ SUB P,[2,,2]\r
+NOLEX4: MOVEI E,(E) ; CLOBBER LH(E)\r
+ MOVE A,E ; COUNT TO A\r
+ SKIPN (P) ; FLUSH 0 WORD\r
+ SUB P,[1,,1]\r
+ HRRZ C,-1(TP) ; GET # OF ATOMS\r
+ SUBI A,(C) ; FIX COUNT\r
+ MOVE B,-2(TP) ; GET CHANNEL INTO B\r
+ PUSHJ P,RETIF ; MAY NEED C.R.\r
+ MOVEI C,-1(E) ; COMPUTE WORDS-1\r
+ IDIVI C,5 ; WORDS-1 TO C\r
+ HRLI C,(C)\r
+ MOVE D,P \r
+ SUB D,C ; POINTS TO 1ST WORD OF CHARS\r
+ MOVSI C,440700+D ; BYTEPOINTER TO STRING\r
+ PUSH TP,$TPDL ; SAVE FROM GC\r
+ PUSH TP,D\r
+\r
+PATOUT: ILDB A,C ; READ A CHAR\r
+ SKIPE A ; IGNORE NULS\r
+ PUSHJ P,PITYO ; PRINT IT\r
+ MOVE D,(TP) ; RESTORE POINTER\r
+ SOJG E,PATOUT\r
+\r
+NOLEXD: SUB TP,[2,,2] ; FLUSH TP JUNK\r
+ MOVE P,D ; RESTORE P\r
+ SUB P,[1,,1]\r
+ JRST PNEXT\r
+\r
+\r
+PENTCH: TLNE FLAGS,NOQBIT ; "PRINC"?\r
+ JRST PENTC1 ; YES, AVOID SLASHING\r
+ IDIVI A,CHRWD ; GET CHARS TYPE\r
+ LDB B,BYTPNT(B)\r
+ CAIL B,6 ; SKIP IF NOT SPECIAL\r
+ JRST PENTC2 ; SLASH IMMEDIATE\r
+ LDB A,[220600,,E] ; GET "STATE"\r
+ LDB A,STABYT-1(B) ; GET NEW STATE\r
+ DPB A,[220600,,E] ; AND SAVE IT\r
+PENTC3: LDB A,C ; RESTORE CHARACTER\r
+PENTC1: JSP B,DOIDPB\r
+ SKIPGE (P) ; SKIP IF DONE\r
+ JRST PATOM1 ; CONTINUE\r
+ JRST PATDON\r
+\r
+PENTC2: MOVEI A,"\ ; GET CHAR QUOTER\r
+ JSP B,DOIDPB ; NEEDED, DO IT\r
+ MOVEI A,4 ; PATCH FOR ATOMS ALREADY BACKSLASHED\r
+ JRST PENTC3-1\r
+\r
+; ROUTINE TO PUT ONE CHAR ON STACK BUFFER\r
+\r
+DOIDPB: IDPB A,-1(P) ; DEPOSIT\r
+ TRNN D,377 ; SKIP IF D FULL\r
+ AOJA E,(B)\r
+ PUSH P,(P) ; MOVE TOP OF STACK UP\r
+ MOVEM D,-2(P) ; SAVE WORDS\r
+ MOVE D,[440700,,D]\r
+ MOVEM D,-1(P)\r
+ MOVEI D,0\r
+ AOJA E,(B)\r
+\r
+; CHECK FOR UNIQUENESS LOOKING INTO PATH\r
+\r
+CHOBL: CAME A,$TOBLS ; SINGLE OBLIST?\r
+ JRST LSTOBL ; NO, AL LIST THEREOF\r
+ CAME B,C ; THE RIGTH ONE?\r
+ JRST CHROOT ; NO, CHECK ROOT\r
+ JRST NOLEX ; WINNER, NO TRAILERS!\r
+\r
+LSTOBL: PUSH TP,A ; SCAN A LIST OF OBLISTS\r
+ PUSH TP,B\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ PUSH TP,$TOBLS\r
+ PUSH TP,C\r
+\r
+NXTOB2: INTGO ; LIST LOOP, PREVENT LOSSAGE\r
+ SKIPN C,-2(TP) ; SKIP IF NOT DONE\r
+ JRST CHROO1 ; EMPTY, CHECK ROOT\r
+ MOVE B,1(C) ; GET ONE\r
+ CAME B,(TP) ; WINNER?\r
+ JRST NXTOBL ; NO KEEP LOOKING\r
+ CAMN C,-4(TP) ; SKIP IF NOT FIRST ON LIST\r
+ JRST NOLEX1\r
+ MOVE A,-6(TP) ; GET ATOM BACK\r
+ MOVEI D,0\r
+ ADD A,[3,,3] ; POINT TO PNAME\r
+ PUSH P,0 ; SAVE FROM RLOOKU\r
+ PUSH P,(A)\r
+ ADDI D,5\r
+ AOBJN A,.-2 ; PUSH THE PNAME\r
+ PUSH P,D ; AND CHAR COUNT\r
+ MOVSI A,TLIST ; TELL RLOOKU WE WIN\r
+ MOVE B,-4(TP) ; GET BACK OBLIST LIST\r
+ SUB TP,[6,,6] ; FLUSH CRAP\r
+ PUSHJ P,RLOOKU ; FIND IT\r
+ POP P,0\r
+ CAMN B,(TP) ; SKIP IF NON UNIQUE\r
+ JRST NOLEX ; UNIQUE , NO TRAILER!!\r
+ JRST CHROO2 ; CHECK ROOT\r
+\r
+NXTOBL: HRRZ B,@-2(TP) ; STEP THE LIST\r
+ MOVEM B,-2(TP)\r
+ JRST NXTOB2\r
+\r
+\r
+FNDOBL: MOVE C,(TP) ; GET ATOM\r
+ MOVSI A,TOBLS\r
+ MOVE B,2(C)\r
+ JUMPL B,.+3\r
+ ADDI B,(TVP)\r
+ MOVE B,(B)\r
+ MOVSI C,TATOM\r
+ MOVE D,IMQUOTE OBLIST\r
+ PUSH P,0\r
+ PUSHJ P,IGET\r
+ POP P,0\r
+NOOBL1: POP P,E ; RESTORE CHAR COUNT\r
+ MOVE D,(P) ; GET PARTIAL WORD\r
+ EXCH D,-1(P) ; AND BYTE POINTER\r
+ CAME A,$TATOM ; IF NOT ATOM, USE FALSE\r
+ JRST NOOBL\r
+ MOVEM B,(TP) ; STORE IN ATOM SLOT\r
+ MOVEI A,"!\r
+ JSP B,DOIDPB ; WRITE IT OUT\r
+ MOVEI A,"-\r
+ JSP B,DOIDPB\r
+ SUB P,[1,,1]\r
+ JRST PATOM0 ; AND LOOP\r
+\r
+NOOBL: MOVE C,[440700,,[ASCIZ /!-#FALSE ()/]]\r
+ ILDB A,C\r
+ JUMPE A,NOLEX0\r
+ JSP B,DOIDPB\r
+ JRST .-3\r
+\r
+\r
+NOLEX1: SUB TP,[6,,6] ; FLUSH STUFF\r
+ JRST NOLEX\r
+\r
+CHROO1: SUB TP,[6,,6]\r
+CHROO2: MOVE C,(TP) ; GET ATOM\r
+ SKIPGE C,2(C) ; AND ITS OBLIST\r
+ JRST CHROOT\r
+ ADDI C,(TVP)\r
+ MOVE C,(C)\r
+ JRST CHROOT\r
+\r
+\r
+\f; STATE TABLES FOR \ OF FIRST CHAR\r
+\r
+RADIX 16.\r
+\r
+STATS: 431244000\r
+ 434444400\r
+ 222224200\r
+ 434564200\r
+ 444444400\r
+ 454564200\r
+ 487444200\r
+ 484444400\r
+ 484444200\r
+\r
+RADIX 8.\r
+\r
+STABYT: 400400,,STATS(A)\r
+ 340400,,STATS(A)\r
+ 300400,,STATS(A)\r
+ 240400,,STATS(A)\r
+ 200400,,STATS(A)\r
+ 140400,,STATS(A)\r
+ 100400,,STATS(A)\r
+\r
+\f;PRINT LONG CHARACTER STRINGS.\r
+;\r
+PCHSTR: MOVE B,(TP)\r
+ TLZ FLAGS,ATMBIT ;WE ARE NOT USING ATOM-NAME TYPE ESCAPING\r
+ PUSH P,-1(TP) ; PUSH CHAR COUNT\r
+ MOVE D,[AOS E] ;GET INSTRUCTION TO COUNT CHARACTERS\r
+ SETZM E ;ZERO COUNT\r
+ PUSHJ P,PCHRST ;GO THROUGH STRING, ESCAPING, ETC. AND COUNTING\r
+ MOVE A,E ;PUT COUNT RETURNED IN REG A\r
+ TLNN FLAGS,NOQBIT ;SKIP (NO QUOTES) IF IN PRINC (BIT ON)\r
+ ADDI A,2 ;PLUS TWO FOR QUOTES\r
+ PUSH P,B ; SAVE B\r
+ MOVE B,-2(TP) ; GET CHANNEL INTO B\r
+ PUSHJ P,RETIF ;START NEW LINE IF NO SPACE\r
+ POP P,B ; RESTORE B\r
+ TLNE FLAGS,NOQBIT ;SKIP (PRINT ") IF BIT IS OFF (NOT PRINC)\r
+ JRST PCHS01 ;OTHERWISE, DON'T QUOTE\r
+ MOVEI A,"" ;PRINT A DOUBLE QUOTE\r
+ PUSH P,B ; SAVE B\r
+ MOVE B,-2(TP)\r
+ PUSHJ P,PITYO\r
+ POP P,B ; RESTORE B\r
+\r
+PCHS01: MOVE D,[PUSHJ P,PITYO] ;OUTPUT INSTRUCTION\r
+ MOVEM B,(TP) ;RESET BYTE POINTER\r
+ POP P,-1(TP) ; RESET CHAR COUNT\r
+ PUSHJ P,PCHRST ;TYPE STRING\r
+\r
+ TLNE FLAGS,NOQBIT ;AGAIN, SKIP IF DOUBLE-QUOTING TO BE DONE\r
+ JRST PNEXT ;RESTORE REGS & POP UP ONE LEVEL TO CALLER\r
+ MOVEI A,"" ;PRINT A DOUBLE QUOTE\r
+ MOVE B,-2(TP) ; GET CHANNEL INTO B\r
+ PUSH P,B ; SAVE B\r
+ MOVE B,-2(TP) ; GET CHANNEL\r
+ PUSHJ P,PITYO\r
+ POP P,B ;RESTORE B\r
+ JRST PNEXT\r
+\r
+\r
+;INTERNAL ROUTINE USED TO COUNT OR OUTPUT CHARACTER STRINGS.\r
+;\r
+;THE APPROPRIATE ESCAPING CONVENTIONS ARE USED AS DETERMINED BY THE FLAG BITS.\r
+;\r
+PCHRST: PUSH P,A ;SAVE REGS\r
+ PUSH P,B\r
+ PUSH P,C\r
+ PUSH P,D\r
+\r
+PCHR02: INTGO ; IN CASE VERY LONG STRING\r
+ HRRZ C,-1(TP) ;GET COUNT\r
+ SOJL C,PCSOUT ; DONE?\r
+ HRRM C,-1(TP)\r
+ ILDB A,(TP) ; GET CHAR\r
+\r
+ TLNE FLAGS,NOQBIT ;SKIP IF WE ARE NOT IN PRINC MODE (NOQBIT=0)\r
+ JRST PCSPRT ;IF BIT IS ON, PRINT WITHOUT ESCAPING\r
+ CAIN A,ESCHAR ;SKIP IF NOT THE ESCAPE CHARACTER\r
+ JRST ESCPRN ;ESCAPE THE ESCAPE CHARACTER\r
+ CAIN A,"" ;SKIP IF NOT A DOUBLE QUOTE\r
+ JRST ESCPRN ;OTHERWISE, ESCAPE THE """\r
+ IDIVI A,CHRWD ;CODE HERE FINDS CHARACTER TYPE\r
+ LDB B,BYTPNT(B) ; "\r
+ CAIGE B,6 ;SKIP IF NOT A NUMBER/LETTER\r
+ JRST PCSPRT ;OTHERWISE, PRINT IT\r
+ TLNN FLAGS,ATMBIT ;SKIP IF PRINTING AN ATOM-NAME (UNQUOTED)\r
+ JRST PCSPRT ;OTHERWISE, NO OTHER CHARS TO ESCAPE\r
+\r
+ESCPRN: MOVEI A,ESCHAR ;TYPE THE ESCAPE CHARACTER\r
+ PUSH P,B ; SAVE B\r
+ MOVE B,-2(TP) ; GET CHANNEL INTO B\r
+ XCT (P)-1 \r
+ POP P,B ; RESTORE B\r
+\r
+PCSPRT: LDB A,(TP) ;GET THE CHARACTER AGAIN\r
+ PUSH P,B ; SAVE B\r
+ MOVE B,-2(TP) ; GET CHANNEL INTO B\r
+ XCT (P)-1 ;PRINT IT\r
+ POP P,B ; RESTORE B\r
+ JRST PCHR02 ;LOOP THROUGH STRING\r
+\r
+PCSOUT: POP P,D\r
+ POP P,C ;RESTORE REGS & RETURN\r
+ POP P,B\r
+ POP P,A\r
+ POPJ P,\r
+\r
+\r
+\f;PRINT AN ARGUMENT LIST\r
+;CHECK FOR TIME ERRORS\r
+\r
+PARGS: MOVEI B,-1(TP) ;POINT TO ARGS POINTER\r
+ PUSHJ P,CHARGS ;AND CHECK THEM\r
+ JRST PVEC ; CHEAT TEMPORARILY\r
+\r
+\r
+\r
+;PRINT A FRAME\r
+PFRAME: MOVEI B,-1(TP) ;POINT TO FRAME POINTER\r
+ PUSHJ P,CHFRM\r
+ HRRZ B,(TP) ;POINT TO FRAME ITSELF\r
+ HRRZ B,FSAV(B) ;GET POINTER TO SUBROUTINE\r
+ CAMGE B,VECTOP\r
+ CAMGE B,VECBOT\r
+ SKIPA B,@-1(B) ; SUBRS AND FSUBRS\r
+ MOVE B,3(B) ; FOR RSUBRS\r
+ MOVSI A,TATOM\r
+ PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT\r
+ PUSH TP,-3(TP)\r
+ PUSHJ P,IPRINT ;PRINT FUNCTION NAME\r
+ SUB TP,[2,,2] ; POP CHANNEL OFF STACK\r
+ JRST PNEXT\r
+\r
+PPVP: MOVE B,(TP) ; PROCESS TO B\r
+ MOVSI A,TFIX\r
+ JUMPE B,.+3\r
+ MOVE A,PROCID(B)\r
+ MOVE B,PROCID+1(B) ;GET ID\r
+ PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT\r
+ PUSH TP,-3(TP)\r
+ PUSHJ P,IPRINT\r
+ SUB TP,[2,,2] ; POP CHANNEL OFF STACK\r
+ JRST PNEXT\r
+\r
+; HERE TO PRINT LOCATIVES\r
+\r
+LOCPT1: HRRZ A,-1(TP)\r
+ JUMPN A,PUNK\r
+LOCPT: MOVEI B,-1(TP) ; VALIDITY CHECK\r
+ PUSHJ P,CHLOCI\r
+ HRRZ A,-1(TP)\r
+ JUMPE A,GLOCPT\r
+ MOVE B,(TP)\r
+ MOVE A,(B)\r
+ MOVE B,1(B)\r
+ PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT\r
+ PUSH TP,-3(TP)\r
+ PUSHJ P,IPRINT\r
+ SUB TP,[2,,2] ; POP CHANNEL OFF STACK\r
+ JRST PNEXT\r
+\r
+GLOCPT: MOVEI A,2\r
+ MOVE B,-2(TP) ; GET CHANNEL\r
+ PUSHJ P,RETIF\r
+ MOVEI A,"%\r
+ PUSHJ P,PITYO\r
+ MOVEI A,"<\r
+ PUSHJ P,PITYO\r
+ MOVSI A,TATOM\r
+ MOVE B,MQUOTE GLOC\r
+ PUSH TP,-3(TP)\r
+ PUSH TP,-3(TP)\r
+ PUSHJ P,IPRINT\r
+ SUB TP,[2,,2]\r
+ PUSHJ P,SPACEQ\r
+ MOVE B,(TP)\r
+ MOVSI A,TATOM\r
+ MOVE B,-1(B)\r
+ PUSH TP,-3(TP)\r
+ PUSH TP,-3(TP)\r
+ PUSHJ P,IPRINT\r
+ SUB TP,[2,,2]\r
+ PUSHJ P,SPACEQ\r
+ MOVSI A,TATOM\r
+ MOVE B,MQUOTE T\r
+ PUSH TP,-3(TP)\r
+ PUSH TP,-3(TP)\r
+ PUSHJ P,IPRINT\r
+ SUB TP,[2,,2]\r
+ MOVEI A,">\r
+ PUSHJ P,PRETIF\r
+ JRST PNEXT\r
+\r
+\f;PRINT UNIFORM VECTORS.\r
+;\r
+PUVEC: MOVE B,-2(TP) ; GET CHANNEL INTO B\r
+ MOVEI A,2 ; ROOM FOR ! AND SQ BRACK?\r
+ PUSHJ P,RETIF\r
+ MOVEI A,"! ;TYPE AN ! AND OPEN SQUARE BRACKET\r
+ PUSHJ P,PITYO\r
+ MOVEI A,"[\r
+ PUSHJ P,PITYO\r
+\r
+ MOVE C,(TP) ;GET AOBJN POINTER TO VECTOR\r
+ TLNN C,777777 ;SKIP ONLY IF COUNT IS NOT ZERO\r
+ JRST NULVEC ;ELSE, VECTOR IS EMPTY\r
+\r
+ HLRE A,C ;GET NEG COUNT\r
+ MOVEI D,(C) ;COPY POINTER\r
+ SUB D,A ;POINT TO DOPE WORD\r
+ HLLZ A,(D) ;GET TYPE\r
+ PUSH P,A ;AND SAVE IT\r
+\r
+PUVE02: MOVE A,(P) ;PUT TYPE CODE IN REG A\r
+ MOVE B,(C) ;PUT DATUM INTO REG B\r
+ PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT\r
+ PUSH TP,-3(TP)\r
+ PUSHJ P,IPRINT ;TYPE IT\r
+ SUB TP,[2,,2] ; POP CHANNEL OF STACK\r
+ MOVE C,(TP) ;GET AOBJN POINTER\r
+ AOBJP C,NULVE1 ;JUMP IF COUNT IS ZERO\r
+ MOVEM C,(TP) ;PUT POINTER BACK ONTO STACK\r
+\r
+ MOVE B,-2(TP) ; GET CHANNEL INTO B\r
+ PUSHJ P,SPACEQ\r
+ JRST PUVE02 ;LOOP THROUGH VECTOR\r
+\r
+NULVE1: SUB P,[1,,1] ;REMOVE STACK CRAP\r
+NULVEC: MOVE B,-2(TP) ; GET CHANNEL INTO B\r
+ MOVEI A,"! ;TYPE CLOSE BRACKET\r
+ PUSHJ P,PRETIF\r
+ MOVEI A,"]\r
+ PUSHJ P,PRETIF\r
+ JRST PNEXT\r
+\r
+\f;PRINT A GENERALIZED VECTOR\r
+;\r
+PVEC: MOVE B,-2(TP) ; GET CHANNEL INTO B\r
+ PUSHJ P,RETIF1 ;NEW LINE IF NO ROOM FOR [\r
+ MOVEI A,"[ ;PRINT A LEFT-BRACKET\r
+ PUSHJ P,PITYO\r
+\r
+ MOVE C,(TP) ;GET AOBJN POINTER TO VECTOR\r
+ TLNN C,777777 ;SKIP IF POINTER-COUNT IS NON-ZERO\r
+ JRST PVCEND ;ELSE, FINISHED WITH VECTOR\r
+PVCR01: MOVE A,(C) ;PUT FIRST WORD OF NEXT ELEMENT INTO REG A\r
+ MOVE B,1(C) ;SECOND WORD OF LIST INTO REG B\r
+ PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT\r
+ PUSH TP,-3(TP)\r
+ PUSHJ P,IPRINT ;PRINT THAT ELEMENT\r
+ SUB TP,[2,,2] ; POP CHANNEL OFF STACK\r
+\r
+ MOVE C,(TP) ;GET AOBJN POINTER FROM TP-STACK\r
+ AOBJP C,PVCEND ;POSITIVE HERE SERIOUS ERROR! (THOUGH NOT PDL)\r
+ AOBJN C,.+2 ;SKIP AND CONTINUE LOOP IF COUNT NOT ZERO\r
+ JRST PVCEND ;ELSE, FINISHED WITH VECTOR\r
+ MOVEM C,(TP) ;PUT INCREMENTED POINTER BACK ON TP-STACK\r
+\r
+ MOVE B,-2(TP) ; GET CHANNEL INTO B\r
+ PUSHJ P,SPACEQ\r
+ JRST PVCR01 ;CONTINUE LOOPING THROUGH OBJECTS ON VECTOR\r
+\r
+PVCEND: MOVE B,-2(TP) ; GET CHANNEL INTO B\r
+ PUSHJ P,RETIF1 ;NEW LINE IF NO ROOM FOR ]\r
+ MOVEI A,"] ;PRINT A RIGHT-BRACKET\r
+ PUSHJ P,PITYO\r
+ JRST PNEXT\r
+\r
+\f;PRINT A LIST.\r
+;\r
+PLIST: MOVE B,-2(TP) ; GET CHANNEL INTO B\r
+ PUSHJ P,RETIF1 ;NEW LINE IF NO SPACE LEFT FOR "("\r
+ MOVEI A,"( ;TYPE AN OPEN PAREN\r
+ PUSHJ P,PITYO\r
+ PUSHJ P,LSTPRT ;PRINT THE INSIDES\r
+ MOVE B,-2(TP) ; RESTORE CHANNEL TO B\r
+ PUSHJ P,RETIF1 ;NEW LINE IF NO ROOM FOR THE CLOSE PAREN\r
+ MOVEI A,") ;TYPE A CLOSE PAREN\r
+ PUSHJ P,PITYO\r
+ JRST PNEXT\r
+\r
+PSEG: TLOA FLAGS,SEGBIT ;PRINT A SEGMENT (& SKIP)\r
+\r
+PFORM: TLZ FLAGS,SEGBIT ;PRINT AN ELEMENT\r
+\r
+PLMNT3: MOVE C,(TP)\r
+ JUMPE C,PLMNT1 ;IF THE CALL IS EMPTY GO AWAY\r
+ MOVE B,1(C)\r
+ MOVEI D,0\r
+ CAMN B,MQUOTE LVAL\r
+ MOVEI D,".\r
+ CAMN B,MQUOTE GVAL\r
+ MOVEI D,",\r
+ CAMN B,MQUOTE QUOTE\r
+ MOVEI D,"'\r
+ JUMPE D,PLMNT1 ;NEITHER, LEAVE\r
+\r
+;ITS A SPECIAL HACK\r
+ HRRZ C,(C)\r
+ JUMPE C,PLMNT1 ;NIL BODY?\r
+\r
+;ITS VALUE OF AN ATOM\r
+ HLLZ A,(C)\r
+ MOVE B,1(C)\r
+ HRRZ C,(C)\r
+ JUMPN C,PLMNT1 ;IF TERE ARE EXTRA ARGS GO AWAY\r
+\r
+ PUSH P,D ;PUSH THE CHAR\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ TLNN FLAGS,SEGBIT ;SKIP (CONTINUE) IF THIS IS A SEGMENT\r
+ JRST PLMNT4 ;ELSE DON'T PRINT THE "."\r
+\r
+;ITS A SEGMENT CALL\r
+ MOVE B,-4(TP) ; GET CHANNEL INTO B\r
+ MOVEI A,2 ; ROOM FOR ! AND . OR ,\r
+ PUSHJ P,RETIF\r
+ MOVEI A,"!\r
+ PUSHJ P,PITYO\r
+\r
+PLMNT4: MOVE B,-4(TP) ; GET CHANNEL INTO B\r
+ PUSHJ P,RETIF1\r
+ POP P,A ;RESTORE CHAR\r
+ PUSHJ P,PITYO\r
+ POP TP,B\r
+ POP TP,A\r
+ PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT\r
+ PUSH TP,-3(TP)\r
+ PUSHJ P,IPRINT\r
+ SUB TP,[2,,2] ; POP CHANNEL OFF STACK\r
+ JRST PNEXT\r
+\r
+\r
+PLMNT1: TLNN FLAGS,SEGBIT ;SKIP IF THIS IS A SEGMENT\r
+ JRST PLMNT5 ;ELSE DON'T TYPE THE "!"\r
+\r
+;ITS A SEGMENT CALL\r
+ MOVE B,-2(TP) ; GET CHANNEL INTO B\r
+ MOVEI A,2 ; ROOM FOR ! AND <\r
+ PUSHJ P,RETIF\r
+ MOVEI A,"!\r
+ PUSHJ P,PITYO\r
+\r
+PLMNT5: MOVE B,-2(TP) ; GET CHANNEL FOR B\r
+ PUSHJ P,RETIF1 \r
+ MOVEI A,"<\r
+ PUSHJ P,PITYO\r
+ PUSHJ P,LSTPRT\r
+ MOVEI A,"!\r
+ MOVE B,-2(TP) ; GET CHANNEL INTO B\r
+ TLNE FLAGS,SEGBIT ;SKIP IF NOT SEGEMNT\r
+ PUSHJ P,PRETIF\r
+ MOVEI A,">\r
+ PUSHJ P,PRETIF\r
+ JRST PNEXT\r
+\r
+\r
+\f\r
+LSTPRT: SKIPN C,(TP)\r
+ POPJ P,\r
+ HLLZ A,(C) ;GET NEXT ELEMENT\r
+ MOVE B,1(C)\r
+ HRRZ C,(C) ;CHOP THE LIST\r
+ JUMPN C,PLIST1\r
+ PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT\r
+ PUSH TP,-3(TP)\r
+ PUSHJ P,IPRINT ;PRINT THE LAST ELEMENT\r
+ SUB TP,[2,,2] ; POP CHANNEL OFF STACK\r
+ POPJ P,\r
+\r
+PLIST1: MOVEM C,(TP)\r
+ PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT\r
+ PUSH TP,-3(TP)\r
+ PUSHJ P, IPRINT ;PRINT THE NEXT ELEMENT\r
+ SUB TP,[2,,2] ; POP CHANNEL OFF STACK\r
+ MOVE B,-2(TP) ; GET CHANNEL INTO B\r
+ PUSHJ P,SPACEQ\r
+ JRST LSTPRT ;REPEAT\r
+\r
+PNEXT: POP P,FLAGS ;RESTORE PREVIOUS FLAG BITS\r
+ SUB TP,[2,,2] ;REMOVE INPUT ELEMENT FROM TP-STACK\r
+ POP P,C ;RESTORE REG C\r
+ POPJ P,\r
+\r
+OPENIT: PUSH P,E\r
+ PUSH P,FLAGS\r
+ PUSHJ P,OPNCHN\r
+ POP P,FLAGS\r
+ POP P,E\r
+ JUMPGE B,FNFFL ;ERROR IF IT CANNOT BE OPENED\r
+ POPJ P,\r
+\r
+\r
+END\r
+\f\r
+TITLE GETPUT ASSOCIATION FUNCTIONS FOR MUDDLE\r
+\r
+RELOCATABLE\r
+\r
+.INSRT MUDDLE >\r
+\r
+; COMPONENTS IN AN ASSOCIATION BLOCK\r
+\r
+ITEM==0 ;ITEM TO WHICH INDUCATOR APPLIES\r
+VAL==2 ;VALUE\r
+INDIC==4 ;INDICATOR\r
+NODPNT==6 ;IF NON ZERO POINTS TO CHAIN\r
+PNTRS==7 ;POINTERS NEXT (RH) AND PREV (LH)\r
+\r
+ASOLNT==8 ;NUMBER OF WORDS IN AN ASSOCIATION BLOCK\r
+\r
+.GLOBAL ASOVEC ;POINTER TO HASH VECTOR IN TV\r
+.GLOBAL ASOLNT,ITEM,INDIC,VAL,NODPNT,NODES,IPUTP,IGETP,PUT,IFALSE\r
+.GLOBAL DUMNOD,IGETLO,IBLOCK,MONCH,RMONCH,IPUT,IGETL,IREMAS,IGET\r
+.GLOBAL NWORDT,CIGETP,CIGTPR,CIPUTP,CIREMA,MPOPJ\r
+\r
+MFUNCTION GETP,SUBR,[GETPROP]\r
+\r
+ ENTRY\r
+\r
+IGETP: PUSHJ P,GETLI\r
+ JRST FINIS ; NO SKIP, LOSE\r
+ MOVSI A,TLOCN\r
+ HLLZ 0,VAL(B)\r
+ PUSHJ P,RMONCH ; CHECK MONITOR\r
+ MOVE A,VAL(B) ;ELSE RETURN VALUE\r
+ MOVE B,VAL+1(B)\r
+CFINIS: JRST FINIS\r
+\r
+; FUNCTION TO RETURN LOCATIVE TO ASSOC\r
+\r
+MFUNCTION GETPL,SUBR\r
+\r
+ ENTRY\r
+\r
+IGETLO: PUSHJ P,GETLI\r
+ JRST FINIS\r
+ MOVSI A,TLOCN\r
+ JRST FINIS\r
+\r
+GETLI: PUSHJ P,2OR3 ; GET ARGS\r
+ PUSHJ P,IGETL ;SEE IF ASSOCIATION EXISTS\r
+ SKIPE B\r
+ AOS (P) ; WIN RETURN\r
+ CAMGE AB,[-4,,0] ; ANY ERROR THING\r
+ JUMPE B,CHFIN ;IF 0, NONE EXISTS\r
+ POPJ P,\r
+\r
+CHFIN: PUSH TP,4(AB)\r
+ PUSH TP,5(AB)\r
+ MCALL 1,EVAL\r
+ POPJ P,\r
+\r
+; COMPILER CALLS TO SOME OF THESE\r
+\r
+CIGETP: SUBM M,(P) ; FIX RET ADDR\r
+ PUSHJ P,IGETL ; GO TO INTERNAL\r
+ JUMPE B,MPOPJ\r
+ MOVSI A,TLOCN\r
+MPOPJ1: SOS (P) ; WINNER (SOS BECAUSE OF SUBM M,(P))\r
+MPOPJ: SUBM M,(P)\r
+ POPJ P,\r
+\r
+CIGTPR: SUBM M,(P)\r
+ PUSHJ P,IGETL\r
+ JUMPE B,MPOPJ\r
+ MOVE A,VAL(B) ; GET VAL TYPE\r
+ MOVE B,VAL+1(B)\r
+ JRST MPOPJ1\r
+\r
+CIPUTP: SUBM M,(P)\r
+ PUSH TP,-1(TP) ; SAVE VAL\r
+ PUSH TP,-1(TP)\r
+ PUSHJ P,IPUT ; DO IT\r
+ POP TP,B\r
+ POP TP,A\r
+ JRST MPOPJ\r
+\r
+CIREMA: SUBM M,(P)\r
+ PUSHJ P,IREMAS ; FLUSH IT\r
+ JRST MPOPJ\r
+\r
+; CHECK PUT/GET PUTPROP AND GETPROP ARGS\r
+\r
+2OR3: HLRE 0,AB\r
+ ASH 0,-1 ; TO -# OF ARGS\r
+ ADDI 0,2 ; AT LEAST 2\r
+ JUMPG 0,TFA ; 1 OR LESS, LOSE\r
+ AOJL 0,TMA ; 4 OR MORE, LOSE\r
+ MOVE A,(AB) ; GET ARGS INTO ACS\r
+ MOVE B,1(AB)\r
+ MOVE C,2(AB)\r
+ MOVE D,3(AB)\r
+ POPJ P,\r
+\r
+; INTERNAL GET\r
+\r
+IGET: PUSHJ P,IGETL ; GET LOCATIVE\r
+ JUMPE B,CPOPJ\r
+ MOVE A,VAL(B)\r
+ MOVE B,VAL+1(B)\r
+ POPJ P,\r
+\r
+; FUNCTION TO MAKE AN ASSOCIATION\r
+\r
+MFUNCTION PUTP,SUBR,[PUTPROP]\r
+\r
+ ENTRY\r
+\r
+IPUTP: PUSHJ P,2OR3 ; GET ARGS\r
+ JUMPN 0,REMAS ; REMOVE AN ASSOCIATION\r
+ PUSH TP,4(AB) ; SAVE NEW VAL\r
+ PUSH TP,5(AB)\r
+ PUSHJ P,IPUT ; DO IT\r
+ MOVE A,(AB) ; RETURN NEW VAL\r
+ MOVE B,1(AB)\r
+ JRST FINIS\r
+\r
+REMAS: PUSHJ P,IREMAS\r
+ JRST FINIS\r
+\r
+IPUT: SKIPN DUMNOD+1(TVP) ; NEW DUMMY NEDDED?\r
+ PUSHJ P,DUMMAK ; YES, GO MAKE ONE\r
+IPUT1: PUSHJ P,IGETI ;SEE IF THIS ONE EXISTS\r
+\r
+ JUMPE B,NEWASO ;JUMP IF NEED NEW ASSOCIATION BLOCK\r
+CLOBV: MOVE C,-5(TP) ; RET NEW VAL\r
+ MOVE D,-4(TP)\r
+ SUB TP,[6,,6]\r
+ HLLZ 0,VAL(B)\r
+ MOVSI A,TLOCN\r
+ PUSHJ P,MONCH ; MONITOR CHECK\r
+ MOVEM C,VAL(B) ;STORE IT\r
+ MOVEM D,VAL+1(B)\r
+CPOPJ: POPJ P,\r
+\r
+; HERE TO CREATE A NEW ASSOCIATION\r
+\r
+NEWASO: MOVE B,DUMNOD+1(TVP) ; GET BALNK ASSOCIATION\r
+ SETZM DUMNOD+1(TVP) ; CAUSE NEW ONE NEXT TIME\r
+\r
+\r
+;NOW SPLICE IN CHAIN\r
+\r
+ JUMPE D,PUT1 ;NO OTHERS EXISTED IN THIS BUCKET\r
+ HRLZM C,PNTRS(B) ;CLOBBER PREV POINTER\r
+ HRRM B,PNTRS(C) ;AND NEXT POINTER\r
+ JRST .+2\r
+\r
+PUT1: HRRZM B,(C) ;STORE INTO VECTOR\r
+ HRRZ C,NODES+1(TVP)\r
+ HRLM C,NODPNT(B)\r
+ MOVE D,NODPNT(C)\r
+ HRRZM B,NODPNT(C)\r
+ HRRM D,NODPNT(B)\r
+ HRLM B,NODPNT(D)\r
+ MOVEI C,-3(TP) ;COPY ARG POINTER\r
+ MOVSI A,-4 ;AND COPY POINTER\r
+\r
+PUT2: MOVE D,(C) ;START COPYING\r
+ MOVEM D,@CLOBTB(A)\r
+ ADDI C,1\r
+ AOBJN A,PUT2 ;NOTE *** DEPENDS ON ORDER IN VECTOR ***\r
+\r
+ JRST CLOBV\r
+\r
+;HERE TO REMOVE AN ASSOCIATION\r
+\r
+IREMAS: PUSHJ P,IGETL ;LOOK IT UP\r
+ JUMPE B,CPOPJ ;NEVER EXISTED, IGNORE\r
+ HRRZ A,PNTRS(B) ;NEXT POINTER\r
+ HLRZ E,PNTRS(B) ;PREV POINTER\r
+ SKIPE A ;DOES A NEXT EXIST?\r
+ HRLM E,PNTRS(A) ;YES CLOBBER ITS PREV POINTER\r
+ SKIPN D ;SKIP IF NOT FIRST IN BUCKET\r
+ MOVEM A,(C) ;FIRST STORE NEW ONE\r
+ SKIPE D ;OTHERWISE\r
+ HRRM A,PNTRS(E) ;PATCH NEXT POINTER IN PREVIOUS\r
+ HRRZ A,NODPNT(B) ;SEE IF MUST UNSPLICE NODE\r
+ HLRZ E,NODPNT(B)\r
+ SKIPE A\r
+ HRLM E,NODPNT(A) ;SPLICE\r
+ JUMPE E,PUT4 ;FLUSH IF NO PREV POINTER\r
+ HRRZ C,NODPNT(E) ;GET PREV'S NEXT POINTER\r
+ CAIE C,(B) ;DOES IT POINT TO THIS NODE\r
+ .VALUE [ASCIZ /:\eFATAL PUT LOSSAGE/]\r
+ HRRM A,NODPNT(E) ;YES, SPLICE\r
+PUT4: MOVE A,VAL(B) ;RETURN VALUE\r
+ SETZM PNTRS(B)\r
+ MOVE B,VAL+1(B)\r
+ POPJ P,\r
+\r
+\r
+;INTERNAL GET FUNCTION CALLED BY PUT AND GET\r
+; A AND B ARE THE ITEM\r
+;C AND D ARE THE INDICATOR\r
+\r
+IGETL: PUSHJ P,IGETI\r
+ SUB TP,[4,,4] ; FLUSH CRUFT LEFT BY IGETI\r
+ POPJ P,\r
+\r
+IGETI: PUSHJ P,LHCLR\r
+ EXCH A,C\r
+ PUSHJ P,LHCLR\r
+ EXCH C,A\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ PUSH TP,C ;SAVE C AND D\r
+ PUSH TP,D\r
+ XOR A,B ; BUILD HASH\r
+ XOR A,C\r
+ XOR A,D\r
+ TLZ A,400000 ; FORCE POS A\r
+ HLRZ B,ASOVEC+1(TVP) ;GET LENGTH OF HASH VECTOR\r
+ MOVNS B\r
+ IDIVI A,(B) ;RELATIVE BUCKET NOW IN B\r
+ HRLI B,(B) ;IN CASE GC OCCURS\r
+ ADD B,ASOVEC+1(TVP) ;POINT TO BUCKET\r
+ MOVEI D,0 ;SET FIRST SWITCH\r
+ SKIPN A,(B) ;GET CONTENTS OF BUCKET (DONT SKIP IF EMPTY)\r
+ JRST GFALSE\r
+\r
+ MOVSI 0,TASOC ;FOR INTGOS, MAKE A TASOC\r
+ HLLZM 0,ASTO(PVP)\r
+\r
+IGET1: GETYPF 0,ITEM(A) ;GET ITEMS TYPE\r
+\r
+ MOVE E,ITEM+1(A)\r
+ CAMN 0,-3(TP) ;COMPARE TYPES\r
+ CAME E,-2(TP) ;AND VALUES\r
+ JRST NXTASO ;LOSER\r
+ GETYPF 0,INDIC(A) ;MOW TRY INDICATORS\r
+ MOVE E,INDIC+1(A)\r
+ CAMN 0,-1(TP)\r
+ CAME E,(TP)\r
+ JRST NXTASO\r
+\r
+ SKIPN D ;IF 1ST THEN\r
+ MOVE C,B ;RETURN POINTER IN C\r
+ MOVE B,A ;FOUND, RETURN ASSOCIATION\r
+ MOVSI A,TASOC\r
+IGRET: SETZM ASTO(PVP)\r
+ POPJ P,\r
+\r
+NXTASO: MOVEI D,1 ;SET SWITCH\r
+ MOVE C,A ;CYCLE\r
+ HRRZ A,PNTRS(A) ;STEP\r
+ JUMPN A,IGET1\r
+\r
+ MOVSI A,TFALSE\r
+ MOVEI B,0\r
+ JRST IGRET\r
+\r
+GFALSE: MOVE C,B ;PRESERVE VECTOR POINTER\r
+ MOVSI A,TFALSE\r
+ SETZB B,D\r
+ JRST IGRET\r
+\r
+; FUNCTION TO DO A PUT AND ALSO ADD TO THE NODE FOR THIS GOODIE\r
+\r
+REPEAT 0,[\r
+MFUNCTION PUTN,SUBR\r
+\r
+ ENTRY\r
+\r
+ CAML AB,[-4,,0] ;WAS THIS A REMOVAL\r
+ JRST PUT\r
+\r
+ PUSHJ P,IPUT ;DO THE PUT\r
+ SKIPE NODPNT(C) ;NODE CHAIN EXISTS?\r
+ JRST FINIS\r
+\r
+ PUSH TP,$TASOC ;NO, START TO BUILD\r
+ PUSH TP,C\r
+ SKIPN DUMNOD+1(TVP) ; FIX UP DUMMY?\r
+ PUSHJ P,DUMMAK\r
+CHPT: MOVE C,$TCHSTR\r
+ MOVE D,CHQUOTE NODE\r
+ PUSHJ P,IGETL\r
+ JUMPE B,MAKNOD ;NOT FOUND, LOSE\r
+NODSPL: MOVE C,(TP) ;HERE TO SPLICE IN NEW NODE\r
+ MOVE D,VAL+1(B) ;GET POINTER TO NODE STRING\r
+ HRRM D,NODPNT(C) ;CLOBBER\r
+ HRLM B,NODPNT(C)\r
+ SKIPE D ;SPLICE ONLY IF THERE IS SOMETHING THERE\r
+ HRLM C,NODPNT(D)\r
+ MOVEM C,VAL+1(B) ;COMPLETE NODE CHAIN\r
+ MOVE A,2(AB) ;RETURN VALUE\r
+ MOVE B,3(AB)\r
+ JRST FINIS\r
+\r
+MAKNOD: PUSHJ P,NEWASO ;GENERATE THE NEW ASSOCIATION\r
+ MOVE A,@CHPT ;GET UNIQUE STRING\r
+ MOVEM A,INDIC(C) ;CLOBBER IN INDIC\r
+ MOVE A,@CHPT+1\r
+ MOVEM A,INDIC+1(C)\r
+ MOVE B,C ;POINTER TO B\r
+ HRRZ C,NODES+1(TVP) ;GET POINTER TO CHAIN OF NODES\r
+ HRRZ D,VAL+1(C) ;SKIP DUMMY NODE\r
+ HRRM B,VAL+1(C) ;CLOBBER INTO CHAIN\r
+ HRRM D,NODPNT(B)\r
+ SKIPE D ;SPLICE IF ONLY SOMETHING THERE\r
+ HRLM B,NODPNT(D)\r
+ HRLM C,NODPNT(B)\r
+ MOVSI A,TASOC ;SET TYPE OF VAL TO ASSOCIATION\r
+ MOVEM A,VAL(B)\r
+ SETZM VAL+1(B)\r
+ JRST NODSPL ;GO SPLICE ITEM ONTO NODE\r
+]\r
+\r
+DUMMAK: PUSH TP,A\r
+ PUSH TP,B\r
+ PUSH TP,C\r
+ PUSH TP,D\r
+ MOVEI A,ASOLNT\r
+ PUSHJ P,IBLOCK\r
+ MOVSI A,400000+SASOC+.VECT.\r
+ MOVEM A,ASOLNT(B) ;SET SPECIAL TYPE\r
+ MOVEM B,DUMNOD+1(TVP)\r
+ POP TP,D\r
+ POP TP,C\r
+ POP TP,B\r
+ POP TP,A\r
+ POPJ P,\r
+\r
+CLOBTB: ITEM(B)\r
+ ITEM+1(B)\r
+ INDIC(B)\r
+ INDIC+1(B)\r
+ VAL(B)\r
+ VAL+1(B)\r
+\r
+MFUNCTION ASSOCIATIONS,SUBR\r
+\r
+ ENTRY 0\r
+ MOVE B,NODES+1(TVP)\r
+ASSOC1: MOVSI A,TASOC ; SET TYPE\r
+ HRRZ B,NODPNT(B) ; POINT TO 1ST REAL NODE\r
+ JUMPE B,IFALSE\r
+ JRST FINIS\r
+\r
+; RETURN NEXT ASSOCIATION IN CHAIN OR FALSE\r
+\r
+MFUNCTION NEXT,SUBR\r
+\r
+ ENTRY 1\r
+\r
+ GETYP 0,(AB) ; BETTER BE ASSOC\r
+ CAIE 0,TASOC\r
+ JRST WTYP1 ; LOSE\r
+ MOVE B,1(AB) ; GET ARG\r
+ JRST ASSOC1\r
+\r
+; GET ITEM/INDICATOR/VALUE CELLS\r
+\r
+MFUNCTION %ITEM,SUBR,ITEM\r
+\r
+ MOVEI B,ITEM ; OFFSET\r
+ JRST GETIT\r
+\r
+MFUNCTION INDICATOR,SUBR\r
+\r
+ MOVEI B,INDIC\r
+ JRST GETIT\r
+\r
+MFUNCTION AVALUE,SUBR\r
+\r
+ MOVEI B,VAL\r
+GETIT: ENTRY 1\r
+ GETYP 0,(AB) ; BETTER BE ASSOC\r
+ CAIE 0,TASOC\r
+ JRST WTYP1\r
+ ADD B,1(AB) ; GET ARG\r
+ MOVE A,(B)\r
+ MOVE B,1(B)\r
+ JRST FINIS\r
+\r
+LHCLR: PUSH P,A\r
+ GETYP A,A\r
+ PUSHJ P,NWORDT ; DEFERRED ?\r
+ SOJE A,LHCLR2\r
+ POP P,A\r
+LHCLR1: TLZ A,TYPMSK#<-1>\r
+ POPJ P,\r
+LHCLR2: POP P,A\r
+ HLLZS A\r
+ JRST LHCLR1\r
+\r
+END\r
+\f\r
+TITLE READC TELETYPE DEVICE HANDLER FOR MUDDLE\r
+\r
+RELOCATABLE\r
+\r
+.INSRT MUDDLE >\r
+\r
+SYSQ\r
+\r
+IF1,[\r
+IFE ITS,.INSRT MUDSYS;STENEX >\r
+]\r
+\r
+.GLOBAL BUFRIN,CHRCNT,SYSCHR,ECHO,BYTPTR,ERASCH,KILLCH,BRKCH,AGC,CHRWRD,W1CHAR,GWB\r
+.GLOBAL IOIN2,READC,WRONGC,BRFCHR,ESCAP,TTYOPE,MTYI,MTYO,NOTTY,TTYOP2,IBLOCK\r
+.GLOBAL RRESET,TTICHN,TTOCHN,CHANNO,STATUS,BRFCH2,TTYBLK,TTYUNB,WAITNS\r
+.GLOBAL EXBUFR,INCHAR,BYTDOP,BUFSTR,LSTCH,CHNCNT,DIRECT,IOINS,IBLOCK,INCONS\r
+.GLOBAL BADCHN,WRONGD,CHNLOS,MODE1,MODE2,GMTYO,IDVAL,GETCHR,PAGLN,LINLN\r
+.GLOBAL RDEVIC\r
+TTYOUT==1\r
+TTYIN==2\r
+\r
+; FLAGS CONCERNING TTY CHANNEL STATE\r
+\r
+N.ECHO==1 ; NO INPUT ECHO\r
+N.CNTL==2 ; NO RUBOUT ^L ^D ECHO\r
+N.IMED==4 ; ALL CHARS WAKE UP\r
+N.IME1==10 ; SOON WILL BE N.IMED\r
+\r
+\r
+; OPEN BLOCK MODE BITS\r
+OUT==1\r
+IMAGEM==4\r
+ASCIIM==0\r
+UNIT==0\r
+\r
+\r
+; READC IS CALLED BY PUSHJ P,READC\r
+; B POINTS TO A TTY FLAVOR CHANNEL\r
+; ONE CHARACTER IS RETURNED IN A\r
+; BECOMES INTERRUPTABLE IF NO CHARACTERS EXISTS\r
+\r
+; HERE TO ASK SYSTEM FOR SOME CHARACTERS\r
+\r
+INCHAR: IRP A,,[0,C,D,E] ;SAVE ACS\r
+ PUSH P,A\r
+ TERMIN\r
+ MOVE E,BUFRIN(B) ; GET AUX BUFFER\r
+ MOVE D,BYTPTR(E)\r
+ HLRE 0,E ;FIND END OF BUFFER\r
+ SUBM E,0\r
+ ANDI 0,-1 ;ISOLATE RH\r
+ MOVE C,SYSCHR(E) ; GET FLAGS\r
+\r
+INCHR1: TRNE C,N.IMED+N.CNTL ; SKIP IF NOT IMMEDIATE\r
+ JRST DONE\r
+ TLZE D,40 ; SKIP IF NOT ESCAPED\r
+ JRST INCHR2 ; ESCAPED\r
+ CAMN A,ESCAP(E) ; IF ESCAPE\r
+ TLO D,40 ; REMEMBER\r
+ CAMN A,BRFCH2(E)\r
+ JRST BRF\r
+ CAMN A,BRFCHR(E) ;BUFFER PRINT CHAR\r
+ JRST CLEARQ ;MAYBE CLEAR SCREEN\r
+ CAMN A,BRKCH(E) ;IS THIS A BREAK?\r
+ JRST DONE ;YES, DONE\r
+ CAMN A,ERASCH(E) ;ARE IS IT ERASE?\r
+ JRST ERASE ;YES, GO PROCESS\r
+ CAMN A,KILLCH(E) ;OR KILL\r
+ JRST KILL\r
+\r
+INCHR2: PUSHJ P,PUTCHR ;PUT ACHAR IN BUFFER\r
+INCHR3: MOVEM D,BYTPTR(E)\r
+ JRST DONE1\r
+\r
+DONE: SKIPL A ; IF JUST BUFFER FORCE, SKIP\r
+ PUSHJ P,PUTCHR ; STORE CHAR\r
+ MOVEI A,N.IMED ; TURN OFF IMEDIACY\r
+ ANDCAM A,SYSCHR(E)\r
+ MOVEM D,BYTPTR(E)\r
+ PUSH TP,$TCHAN ; SAVE CHANNEL\r
+ PUSH TP,B\r
+ MOVE A,CHRCNT(E) ; GET # OF CHARS\r
+ SETZM CHRCNT(E)\r
+ PUSH P,A\r
+ ADDI A,4 ; ROUND UP\r
+ IDIVI A,5 ; AND DOWN\r
+ PUSHJ P,IBLOCK ; GET CORE\r
+ HLRE A,B ; FIND D.W.\r
+ SUBM B,A\r
+ MOVSI 0,TCHRS+.VECT. ; GET TYPE\r
+ MOVEM 0,(A) ; AND STORE\r
+ MOVEI D,(B) ; COPY PNTR\r
+ POP P,C ; CHAR COUNT\r
+ HRLI D,440700\r
+ HRLI C,TCHSTR\r
+ PUSH TP,C\r
+ PUSH TP,D\r
+ PUSHJ P,INCONS ; CONS IT ON\r
+ MOVE C,-2(TP) ; GET CHAN BACK\r
+ MOVEI D,EXBUFR(C) ; POINT TO BUFFER LIST\r
+ HRRZ 0,(D) ; LAST?\r
+ JUMPE 0,.+3\r
+ MOVE D,0\r
+ JRST .-3 ; GO UNTIL END\r
+ HRRM B,(D) ; SPLICE\r
+\r
+; HERE TO BLT IN BUFFER\r
+\r
+ MOVE D,BUFRIN(C) ; POINT TO COMPLETED BUFFER\r
+ HRRZ C,(TP) ; START OF NEW STRING\r
+ HRLI C,BYTPTR+1(D) ; 1ST WORD OF CHARS\r
+ MOVE E,[010700,,BYTPTR(E)]\r
+ EXCH E,BYTPTR(D) ; END OF STRING\r
+ MOVEI E,-BYTPTR(E)\r
+ ADD E,(TP) ; ADD TO START\r
+ BLT C,-1(E)\r
+ MOVE B,-2(TP) ; CHANNEL BACK\r
+ SUB TP,[4,,4] ; FLUSH JUNK\r
+ PUSHJ P,TTYUNB ; UNBLOCK THIS TTY\r
+DONE1: IRP A,,[E,D,C,0]\r
+ POP P,A\r
+ TERMIN\r
+ POPJ P,\r
+\r
+\r
+ERASE: SKIPN CHRCNT(E) ;ANYTHING IN BUFFER?\r
+ JRST BARFCR ;NO, MAYBE TYPE CR\r
+\r
+ SOS CHRCNT(E) ;DELETE FROM COUNT\r
+ LDB A,D ;RE-GOBBLE LAST CHAR\r
+IFN ITS,[\r
+ LDB C,[600,,STATUS(B)] ; CHECK FOR IMLAC\r
+ CAIE C,2 ; SKIP IF IT IS\r
+]\r
+ JRST TYPCHR\r
+ SKIPN ECHO(E) ; SKIP IF ECHOABLE\r
+ JRST NECHO\r
+ PUSHJ P,CHRTYP ; FOUND OUT IMALC BEHAVIOR\r
+ SKIPGE C,FIXIM2(C)\r
+ JRST (C)\r
+NOTFUN: PUSHJ P,DELCHR\r
+ SOJG C,.-1\r
+\r
+NECHO: ADD D,[70000,,0] ;DECREMENT BYTE POINTER\r
+ JUMPGE D,INCHR3 ;AND GO ON, UNLESS BYTE POINTER LOST\r
+ SUB D,[430000,,1] ;FIX UP BYTE POINTER\r
+ JRST INCHR3\r
+\r
+LFKILL: PUSHJ P,LNSTRV\r
+ JRST NECHO\r
+\r
+BSKILL: PUSHJ P,GETPOS ; CURRENT POSITION TO A\r
+ PUSHJ P,SETPOS ; POSITION IMLAC CURSOR\r
+ MOVEI A,20 ; ^P\r
+ XCT ECHO(E)\r
+ MOVEI A,"L ; L , DELETE TO END OF LINE\r
+ XCT ECHO(E)\r
+ JRST NECHO\r
+\r
+TBKILL: PUSHJ P,GETPOS\r
+ ANDI A,7\r
+ SUBI A,10 ; A -NUMBER OF DELS TO DO\r
+ PUSH P,A\r
+ PUSHJ P,DELCHR\r
+ AOSE (P)\r
+ JRST .-2\r
+\r
+ SUB P,[1,,1]\r
+ JRST NECHO\r
+TYPCHR:\r
+IFE ITS,[\r
+ PUSH P,A ; USE TENEX SLASH RUBOUT\r
+ MOVEI A,"\\r
+ SKIPE C,ECHO(E)\r
+ XCT C\r
+ POP P,A\r
+]\r
+ SKIPE C,ECHO(E)\r
+ XCT C\r
+ JRST NECHO\r
+\r
+; ROUTINE TO DEL CHAR ON IMLAC\r
+\r
+DELCHR: MOVEI A,20\r
+ XCT ECHO(E)\r
+ MOVEI A,"X\r
+ XCT ECHO(E)\r
+ POPJ P,\r
+\r
+; HERE FOR SPECIAL IMLAC HACKS\r
+\r
+FOURQ: PUSH P,CNOTFU\r
+FOURQ2: MOVEI C,2 ; FOR ^Z AND ^_\r
+ CAMN B,TTICHN+1(TVP) ; SKIP IF NOT CONSOLE TTY\r
+ MOVEI C,4\r
+CNOTFU: POPJ P,NOTFUN\r
+\r
+CNECHO: JRST NECHO\r
+\r
+LNSTRV: MOVEI A,20 ; ^P\r
+ XCT ECHO(E)\r
+ MOVEI A,"U\r
+ XCT ECHO(E)\r
+ POPJ P,\r
+\r
+; HERE IF KILLING A C.R., RE-POSITION CURSOR\r
+\r
+CRKILL: PUSHJ P,GETPOS ; COMPUTE LINE POS\r
+ PUSHJ P,SETPOS\r
+ JRST NECHO\r
+\r
+SETPOS: PUSH P,A ; SAVE POS\r
+ MOVEI A,20\r
+ XCT ECHO(E)\r
+ MOVEI A,"H\r
+ XCT ECHO(E)\r
+ POP P,A\r
+ XCT ECHO(E) ; HORIZ POSIT AT END OF LINE\r
+ POPJ P,0\r
+\r
+GETPOS: PUSH P,0\r
+ MOVEI 0,10 ; MINIMUM CURSOR POS\r
+ PUSH P,[010700,,BYTPTR(E)] ; POINT TO BUFFER\r
+ PUSH P,CHRCNT(E) ; NUMBER THEREOF\r
+\r
+GETPO1: SOSGE (P) ; COUNT DOWN\r
+ JRST GETPO2\r
+ ILDB A,-1(P) ; CHAR FROM BUFFER\r
+ CAIN A,15 ; SKIP IF NOT CR\r
+ MOVEI 0,10 ; C.R., RESET COUNT\r
+ PUSHJ P,CHRTYP ; GET TYPE\r
+ XCT FIXIM3(C) ; GET FIXED COUNT\r
+ ADD 0,C\r
+ JRST GETPO1\r
+\r
+GETPO2: MOVE A,0 ; RET COUNT\r
+ MOVE 0,-2(P) ; RESTORE AC 0\r
+ SUB P,[3,,3]\r
+ POPJ P,\r
+\r
+CHRTYP: MOVEI C,0 ; NUMBER OF FLUSHEES\r
+ CAILE A,37 ; SKIP IF CONTROL CHAR\r
+ POPJ P,\r
+ PUSH TP,$TCHAN\r
+ PUSH TP,B ; SAVE CHAN\r
+ IDIVI A,12. ; FIND SPECIAL HACKS\r
+ MOVE A,FIXIML(A) ; GET CONT WORD\r
+ IMULI B,3\r
+ ROTC A,3(B) ; GET CODE IN B\r
+ ANDI B,7\r
+ MOVEI C,(B)\r
+ MOVE B,(TP) ; RESTORE CHAN\r
+ SUB TP,[2,,2]\r
+ POPJ P,\r
+\r
+FIXIM2: 1\r
+ 2\r
+ SETZ FOURQ\r
+ SETZ CRKILL\r
+ SETZ LFKILL\r
+ SETZ BSKILL\r
+ SETZ TBKILL\r
+\r
+FIXIM3: MOVEI C,1\r
+ MOVEI C,2\r
+ PUSHJ P,FOURQ2\r
+ MOVEI C,0\r
+ MOVEI C,0\r
+ MOVNI C,1\r
+ PUSHJ P,CNTTAB\r
+\r
+CNTTAB: ANDCMI 0,7 ; GET COUNT INCUDING TAB HACK\r
+ ADDI 0,10\r
+ MOVEI C,0\r
+ POPJ P,\r
+ \r
+FIXIML: 111111,,115641 ; CNTL @ABCDE,,FGHIJK\r
+ 131111,,111111 ; LMNOPQ,,RSTUVW\r
+ 112011,,120000 ; XYZ LBRAK \ RBRAK,,^ _\r
+\r
+; HERE TO KILL THE WHOLE BUFFER\r
+\r
+KILL: CLEARM CHRCNT(E) ;NONE LEFT NOW\r
+ MOVE D,[010700,,BYTPTR(E)] ;RESET POINTER\r
+\r
+BARFCR:\r
+IFN ITS,[\r
+ MOVE A,ERASCH(E) ;GET THE ERASE CHAR\r
+ CAIN A,177 ;IS IT RUBOUT?\r
+]\r
+ PUSHJ P,CRLF1 ; PRINT CR-LF\r
+ JRST INCHR3\r
+\r
+CLEARQ:\r
+IFN ITS,[\r
+ MOVE A,STATUS(B) ;CHECK CONSOLE KIND\r
+ ANDI A,77\r
+ CAIN A,2 ;DATAPOINT?\r
+ PUSHJ P,CLR ;YES, CLEAR SCREEN\r
+]\r
+\r
+BRF: MOVE C,[010700,,BYTPTR(E)] ;POINT TO START OF BUFFER\r
+ SKIPN ECHO(E) ;ANY ECHO INS?\r
+ JRST NECHO\r
+\r
+ PUSHJ P,CRLF2\r
+ PUSH P,CHRCNT(E)\r
+\r
+ SOSGE (P)\r
+ JRST DECHO\r
+ ILDB A,C ;GOBBLE CHAR\r
+ XCT ECHO(E) ;ECHO IT\r
+ JRST .-4 ;DO FOR ENTIRE BUFFER\r
+\r
+DECHO: SUB P,[1,,1]\r
+ JRST INCHR3\r
+\r
+CLR: SKIPN C,ECHO(E) ;ONLY IF INS EXISTS\r
+ POPJ P,\r
+ MOVEI A,20 ;ERASE SCREEN\r
+ XCT C\r
+ MOVEI A,103\r
+ XCT C\r
+ POPJ P,\r
+\r
+PUTCHR: AOS CHRCNT(E) ;COUNT THIS CHARACTER\r
+ IBP D ;BUMP BYTE POINTER\r
+ CAIG 0,@D ;DONT SKIP IF BUFFER FULL\r
+ PUSHJ P,BUFULL ;GROW BUFFER\r
+IFE ITS,[\r
+ CAIN A,37 ; CHANGE EOL TO CRLF\r
+ MOVEI A,15\r
+]\r
+ DPB A,D ;CLOBBER BYTE POINTER IN\r
+ MOVE C,SYSCHR(E) ; FLAGS\r
+ TRNN C,N.IMED+N.CNTL\r
+ CAIE A,15 ; IF CR INPUT, FOLLOW WITH LF\r
+ POPJ P,\r
+ MOVEI A,12 ; GET LF\r
+ JRST PUTCHR\r
+\r
+; BUFFER FULL, GROW THE BUFFER\r
+\r
+BUFULL: PUSH TP,$TCHAN ;SAVE B\r
+ PUSH TP,B\r
+ PUSH P,A ; SAVE CURRENT CHAR\r
+ HLRE A,BUFRIN(B)\r
+ MOVNS A\r
+ ADDI A,100 ; MAKE ONE LONGER\r
+ PUSHJ P,IBLOCK ; GET IT\r
+ MOVE A,(TP) ;RESTORE CHANNEL POINTER\r
+ SUB TP,[2,,2] ;AND REMOVE CRUFT\r
+ MOVE E,BUFRIN(A) ;GET AUX BUFFER POINTER\r
+ MOVEM B,BUFRIN(A)\r
+ HLRE 0,E ;RECOMPUTE 0\r
+ MOVSI E,(E)\r
+ HRRI E,(B) ; POINT TO DEST\r
+ SUB B,0\r
+ BLT E,(B)\r
+ MOVEI 0,100-2(B)\r
+ MOVE B,A\r
+ POP P,A\r
+ POPJ P,\r
+\r
+; ROUTINE TO CRLF ON ANY TTY\r
+\r
+CRLF1: SKIPN ECHO(E)\r
+ POPJ P, ; NO ECHO INS\r
+CRLF2: MOVEI A,15\r
+ XCT ECHO(E)\r
+ MOVEI A,12\r
+ XCT ECHO(E)\r
+ POPJ P,\r
+\r
+; SUBROUTINE TO FLUSH BUFFER\r
+\r
+RRESET: SETZM LSTCH(B) ; CLOBBER RE-USE CHAR\r
+ MOVE E,BUFRIN(B) ;GET AUX BUFFER\r
+ SETZM CHRCNT(E)\r
+ MOVEI D,N.IMED+N.IME1\r
+ ANDCAM D,SYSCHR(E)\r
+ MOVE D,[010700,,BYTPTR(E)] ;RESET BYTE POINTER\r
+ MOVEM D,BYTPTR(E)\r
+ MOVE D,CHANNO(B) ;GOBBLE CHANNEL\r
+ SETZM CHNCNT(D) ; FLUSH COUNTERS\r
+IFN ITS,[\r
+ LSH D,23. ;POSITION\r
+ IOR D,[.RESET 0]\r
+ XCT D ;RESET ITS CHANNEL\r
+]\r
+IFE ITS,[\r
+ MOVEI A,100 ; TTY IN JFN\r
+ CFIBF\r
+]\r
+ SETZM EXBUFR(B) ; CLOBBER STAKED BUFFS\r
+ MOVEI C,BUFSTR-1(B) ; FIND D.W.\r
+ PUSHJ P,BYTDOP\r
+ SUBI A,2\r
+ HRLI A,010700\r
+ MOVEM A,BUFSTR(B)\r
+ HLLZS BUFSTR-1(B)\r
+ POPJ P,\r
+\r
+; SUBROUTINE TO ESTABLISH ECHO IOINS\r
+\r
+MFUNCTION ECHOPAIR,SUBR\r
+\r
+ ENTRY 2\r
+\r
+ GETYP A,(AB) ;CHECK ARG TYPES\r
+ GETYP C,2(AB)\r
+ CAIN A,TCHAN ;IS A CHANNEL\r
+ CAIE C,TCHAN ;IS C ALSO\r
+ JRST WRONGT ;NO, ONE OF THEM LOSES\r
+\r
+ MOVE A,1(AB) ;GET CHANNEL\r
+ PUSHJ P,TCHANC ; VERIFY TTY IN\r
+ MOVE D,3(AB) ;GET OTHER CHANNEL\r
+ MOVEI B,DIRECT-1(D) ;AND ITS DIRECTION\r
+ PUSHJ P,CHRWRD\r
+ JFCL\r
+ CAME B,[ASCII /PRINT/]\r
+ JRST WRONGD\r
+\r
+ MOVE B,BUFRIN(A) ;GET A'S AUX BUFFER\r
+ HRLZ C,CHANNO(D) ; GET CHANNEL\r
+ LSH C,5\r
+ IOR C,[.IOT A] ; BUILD AN IOT\r
+ MOVEM C,ECHO(B) ;CLOBBER\r
+CHANRT: MOVE A,(AB)\r
+ MOVE B,1(AB) ;RETURN 1ST ARG\r
+ JRST FINIS\r
+\r
+TCHANC: MOVEI B,DIRECT-1(A) ;GET DIRECTION\r
+ PUSHJ P,CHRWRD ; CONVERT\r
+ JFCL\r
+ CAME B,[ASCII /READ/]\r
+ JRST WRONGD\r
+ LDB C,[600,,STATUS(A)] ;GET A CODE\r
+ CAILE C,2 ;MAKE SURE A TTY FLAVOR DEVICE\r
+ JRST WRONGC\r
+ POPJ P,\r
+IFE ITS,[\r
+TTYOPEN:\r
+TTYOP2: MOVEI A,-1 ; TENEX JFN FOR TERMINAL\r
+ MOVEI 2,145100 ; MAGIC BITS (SEE TENEX MANUAL)\r
+ SFMOD ; ZAP\r
+ RFMOD ; LETS FIND SCREEN SIZE\r
+ LDB A,[220700,,B] ; GET PAGE WIDTH\r
+ LDB B,[310700,,B] ; AND LENGTH\r
+ MOVE C,TTOCHN+1(TVP)\r
+ MOVEM A,LINLN(C)\r
+ MOVEM B,PAGLN(C)\r
+ MOVEI A,-1 ; NOW HACK CNTL CHAR STUFF\r
+ RFCOC ; GET CURRENT\r
+ AND B,[036377,,-1] ; CHANGE FOR ^@, ^A AND ^D (FOR NOW)\r
+ SFCOC ; AND RESUSE IT\r
+\r
+ POPJ P,\r
+]\r
+\r
+IFN ITS,[\r
+TTYOP2: .SUSET [.RTTY,,C]\r
+ SETZM NOTTY\r
+ JUMPL C,TTYNO ; DONT HAVE TTY\r
+\r
+TTYOPEN:\r
+ SKIPE NOTTY\r
+ POPJ P,\r
+ .OPEN TTYIN,[SIXBIT / TTY/]\r
+ JRST TTYNO\r
+ .OPEN TTYOUT,[21,,(SIXBIT /TTY/)] ;AND OUTPUT\r
+ FATAL CANT OPEN TTY\r
+ DOTCAL TTYGET,[[1000,,TTYOUT],[2000,,0],[2000,,A],[2000,,B]]\r
+ FATAL .CALL FAILURE\r
+ DOTCAL TTYSET,[[1000,,TTYOUT],MODE1,MODE2,B]\r
+ FATAL .CALL FAILURE\r
+ \r
+SETCHN: MOVE B,TTICHN+1(TVP) ;GET CHANNEL\r
+ MOVEI C,TTYIN ;GET ITS CHAN #\r
+ MOVEM C,CHANNO(B)\r
+ .STATUS TTYIN,STATUS(B) ;CLOBBER STATUS\r
+\r
+ MOVE B,TTOCHN+1(TVP) ;GET OUT CHAN\r
+ MOVEI C,TTYOUT\r
+ MOVEM C,CHANNO(B)\r
+ .STATUS TTYOUT,STATUS(B)\r
+ SETZM IMAGFL ;RESET IMAGE MODE FLAG\r
+ HLLZS IOINS-1(B)\r
+ DOTCAL RSSIZE,[[1000,,TTYOUT],[2000,,C],[2000,,D]]\r
+ FATAL .CALL RSSIZE LOSSAGE\r
+ MOVEM C,PAGLN(B)\r
+ MOVEM D,LINLN(B)\r
+ POPJ P,\r
+\r
+; HERE IF TTY WONT OPEN\r
+\r
+TTYNO: SETOM NOTTY\r
+ POPJ P,\r
+]\r
+\r
+MTYI: SKIPE NOTTY ; SKIP IF HAVE TTY\r
+ FATAL TRIED TO USE NON-EXISTANT TTY\r
+IFN ITS, .IOT TTYIN,A\r
+IFE ITS, PBIN\r
+ POPJ P,\r
+\r
+MTYO: SKIPE NOTTY\r
+ POPJ P, ; IGNORE, DONT HAVE TTY\r
+ SKIPE IMAGFL ;SKIP RE-OPENING IF ALREADY IN ASCII\r
+ PUSHJ P,MTYO1 ;WAS IN IMAGE...RE-OPEN\r
+ CAIE A,177 ;DONT OUTPUT A DELETE\r
+IFN ITS, .IOT TTYOUT,A\r
+IFE ITS, PBOUT\r
+ POPJ P,\r
+\r
+MTYO1: MOVE B,TTOCHN+1(TVP)\r
+ PUSH P,0\r
+ PUSHJ P,REASCI\r
+ POP P,0\r
+ POPJ P,\r
+\r
+; HERE FOR TYO TO ANY TTY FLAVOR DEVICE\r
+\r
+GMTYO: PUSH P,0\r
+ HRRZ 0,IOINS-1(B) ; GET FLAG\r
+ SKIPE 0\r
+ PUSHJ P,REASCI ; RE-OPEN TTY\r
+ HRLZ 0,CHANNO(B)\r
+ ASH 0,5\r
+ IOR 0,[.IOT A]\r
+ CAIE A,177 ; DONE OUTPUT A DELETE\r
+ XCT 0\r
+ POP P,0\r
+ POPJ P,\r
+\r
+REASCI: PUSH P,A\r
+ PUSH P,C\r
+ PUSHJ P,DEVTOC\r
+ HRLI C,21 ; ASCII GRAPHIC BIT\r
+ MOVE A,CHANNO(B) ; GET CHANNEL\r
+ ASH A,23. ; TO AC FIELD\r
+ IOR A,[.OPEN 0,C]\r
+ XCT A\r
+ FATAL TTY OPEN LOSSAGE\r
+ POP P,C\r
+ POP P,A\r
+ HLLZS IOINS-1(B)\r
+ CAMN B,TTOCHN+1(TVP)\r
+ SETZM IMAGFL\r
+ POPJ P,\r
+\r
+\r
+\r
+WRONGC: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE NOT-A-TTY-TYPE-CHANNEL\r
+ JRST CALER1\r
+\r
+\r
+\r
+; HERE TO HANDLE TTY BLOCKING AND UNBLOCKING\r
+\r
+TTYBLK: PUSH TP,$TCHAN\r
+ PUSH TP,B\r
+ PUSH P,0\r
+ PUSH P,E ; SAVE SOME ACS\r
+IFN ITS,[\r
+ MOVE A,CHANNO(B) ; GET CHANNEL NUMBER\r
+ SOSG CHNCNT(A) ; ANY PENDING CHARS\r
+ JRST TTYBL1\r
+ SETZM CHNCNT(A)\r
+ MOVEI 0,1\r
+ LSH 0,(A)\r
+ .SUSET [.SIFPI,,0] ; SLAM AN INT ON\r
+]\r
+TTYBL1: MOVE C,BUFRIN(B)\r
+ MOVE A,SYSCHR(C) ; GET FLAGS\r
+ TRZ A,N.IMED\r
+ TRZE A,N.IME1 ; IF WILL BE\r
+ TRO A,N.IMED ; THE MAKE IT\r
+ MOVEM A,SYSCHR(C)\r
+IFN ITS,[\r
+ MOVE A,[.CALL TTYIOT]; NON-BUSY WAIT\r
+ SKIPE NOTTY\r
+ MOVE A,[.SLEEP A,]\r
+]\r
+IFE ITS,[\r
+ MOVE A,[PUSHJ P,TNXIN]\r
+]\r
+ MOVEM A,WAITNS(B)\r
+ PUSH TP,$TCHSTR\r
+ PUSH TP,CHQUOTE BLOCKED\r
+ PUSH TP,$TPVP\r
+ PUSH TP,PVP\r
+ MCALL 2,INTERRUPT\r
+ MOVSI A,TCHAN\r
+ MOVEM A,BSTO(PVP)\r
+ MOVE B,(TP)\r
+ ENABLE\r
+REBLK: MOVEI A,-1 ; IN CASE SLEEPING\r
+ XCT WAITNS(B) ; NOW WAIT\r
+ JFCL\r
+IFE ITS, JRST .-3\r
+IFN ITS, JRST CHRSNR ; SNARF CHAR\r
+REBLK1: DISABLE ; FALL THROUG=> UNBLOCKED\r
+ SETZM BSTO(PVP)\r
+ POP P,E\r
+ POP P,0\r
+ MOVE B,(TP)\r
+ SUB TP,[2,,2]\r
+ POPJ P,\r
+\r
+CHRSNR: SKIPE NOTTY ; TTY?\r
+ JRST REBLK ; NO, JUST RESET AND BLOCK\r
+ .SUSET [.SIFPI,,[1_<TTYIN>]]\r
+ JRST REBLK ; AND GO BACK\r
+\r
+TTYIOT: SETZ\r
+ SIXBIT /IOT/\r
+ 1000,,TTYIN\r
+ 0\r
+ 405000,,20000\r
+\r
+; HERE TO UNBLOCK TTY\r
+\r
+TTYUNB: MOVE A,WAITNS(B) ; GET INS\r
+ CAMN A,[JRST REBLK1]\r
+ JRST TTYUN1\r
+ MOVE A,[JRST REBLK1] ; LEAVE THE SLEEP\r
+ MOVEM A,WAITNS(B)\r
+ PUSH TP,$TCHAN\r
+ PUSH TP,B\r
+ PUSH TP,$TCHSTR\r
+ PUSH TP,CHQUOTE UNBLOCKED\r
+ PUSH TP,$TCHAN\r
+ PUSH TP,B\r
+ MCALL 2,INTERRUPT\r
+ MOVE B,(TP) ; RESTORE CHANNEL\r
+ SUB TP,[2,,2]\r
+TTYUN1: POPJ P,\r
+\r
+IFE ITS,[\r
+; TENEX BASIC TTY I/O ROUTINE\r
+\r
+TNXIN: PUSHJ P,MTYI\r
+ PUSHJ P,INCHAR\r
+ POPJ P,\r
+]\r
+MFUNCTION TTYECHO,SUBR\r
+\r
+ ENTRY 2\r
+\r
+ GETYP 0,(AB)\r
+ CAIE 0,TCHAN\r
+ JRST WTYP1\r
+ MOVE A,1(AB) ; GET CHANNEL\r
+ PUSHJ P,TCHANC ; MAKE SURE IT IS TTY INPUT\r
+ MOVE E,BUFRIN(A) ; EXTRA INFO BUFFER\r
+IFN ITS,[\r
+ DOTCAL TTYGET,[CHANNO(A),[2000,,B],[2000,,C],[2000,,0]]\r
+ FATAL .CALL FAILURE\r
+]\r
+IFE ITS,[\r
+ MOVEI A,100 ; TTY JFN\r
+ RFMOD ; MODE IN B\r
+ TRZ B,6000 ; TURN OFF ECHO \r
+]\r
+ GETYP D,2(AB) ; ARG 2\r
+ CAIE D,TFALSE ; SKIP IF WANT ECHO OFF\r
+ JRST ECHOON\r
+\r
+IFN ITS,[\r
+ ANDCM B,[606060,,606060]\r
+ ANDCM C,[606060,,606060]\r
+\r
+ DOTCAL TTYSET,[CHANNO(A),B,C,0]\r
+ FATAL .CALL FAILURE\r
+]\r
+IFE ITS,[\r
+ SFMOD\r
+]\r
+\r
+ MOVEI B,N.ECHO+N.CNTL ; SET FLAGS\r
+ IORM B,SYSCHR(E)\r
+\r
+ JRST CHANRT\r
+\r
+ECHOON:\r
+IFN ITS,[\r
+ IOR B,[202020,,202020]\r
+ IOR C,[202020,,202020]\r
+ DOTCAL TTYSET,[CHANNO(A),B,C,0]\r
+ FATAL .CALL FAILURE\r
+]\r
+IFE ITS,[\r
+ TRO B,4000\r
+ SFMOD\r
+]\r
+ MOVEI A,N.ECHO+N.CNTL\r
+ ANDCAM A,SYSCHR(E)\r
+ JRST CHANRT\r
+\r
+\r
+\r
+; USER SUBR FOR INSTANT CHARACTER SNARFING\r
+\r
+MFUNCTION UTYI,SUBR,TYI\r
+\r
+ ENTRY\r
+ CAMGE AB,[-3,,]\r
+ JRST TMA\r
+ MOVE A,(AB)\r
+ MOVE B,1(AB)\r
+ JUMPL AB,.+3\r
+ MOVE B,IMQUOTE INCHAN\r
+ PUSHJ P,IDVAL ; USE INCHAN\r
+ GETYP 0,A ; GET TYPE\r
+ CAIE 0,TCHAN\r
+ JRST WTYP1\r
+ LDB 0,[600,,STATUS(B)]\r
+ CAILE 0,2\r
+ JRST WTYP1\r
+ SKIPN A,LSTCH(B) ; ANY READ AHEAD CHAR\r
+ JRST UTYI1 ; NO, SKIP\r
+ SETZM LSTCH(B)\r
+ TLZN A,400000 ; ! HACK?\r
+ JRST UTYI2 ; NO, OK\r
+ MOVEM A,LSTCH(B) ; YES SAVE\r
+ MOVEI A,"! ; RET AN !\r
+ JRST UTYI2\r
+\r
+UTYI1: MOVE 0,IOINS(B)\r
+ CAME 0,[PUSHJ P,GETCHR]\r
+ JRST WTYP1\r
+ PUSH TP,$TCHAN\r
+ PUSH TP,B\r
+ MOVE C,BUFRIN(B)\r
+ MOVEI D,N.IME1+N.IMED \r
+ IORM D,SYSCHR(C) ; CLOBBER IT IN\r
+ DOTCAL TTYGET,[CHANNO(B),[2000,,A],[2000,,D],[2000,,0]]\r
+ FATAL .CALL FAILURE\r
+ PUSH P,A\r
+ PUSH P,0\r
+ PUSH P,D ; SAVE THEM\r
+ IOR D,[030303,,030303]\r
+ IOR A,[030303,,030303]\r
+ DOTCAL TTYSET,[CHANNO(B),A,D,0]\r
+ FATAL .CALL FAILURE\r
+ MOVNI A,1\r
+ SKIPE CHRCNT(C) ; ALREADY SOME?\r
+ PUSHJ P,INCHAR\r
+ MOVE C,BUFRIN(B) ; GET BUFFER BACK\r
+ MOVEI D,N.IME1\r
+ IORM D,SYSCHR(C)\r
+ PUSHJ P,GETCHR\r
+ MOVE B,1(TB)\r
+ MOVE C,BUFRIN(B)\r
+ MOVEI D,N.IME1+N.IMED\r
+ ANDCAM D,SYSCHR(C)\r
+ POP P,D\r
+ POP P,0\r
+ POP P,C\r
+ DOTCAL TTYSET,[CHANNO(B),C,D,0]\r
+ FATAL .CALL FAILURE\r
+UTYI2: MOVEI B,(A)\r
+ MOVSI A,TCHRS\r
+ JRST FINIS\r
+\r
+MFUNCTION IMAGE,SUBR\r
+ ENTRY\r
+ JUMPGE AB,TFA ; 1 OR 2 ARGS NEEDED\r
+ GETYP A,(AB) ;GET THE TYPE OF THE ARG\r
+ CAIE A,TFIX ;CHECK IT FOR CORRECT TYPE\r
+ JRST WTYP1 ;WAS WRONG...ERROR EXIT\r
+ HLRZ 0,AB\r
+ CAIL 0,-2\r
+ JRST USEOTC\r
+ CAIE 0,-4\r
+ JRST TMA\r
+ GETYP 0,2(AB)\r
+ CAIE 0,TCHAN\r
+ JRST WTYP2\r
+ MOVE B,3(AB) ; GET CHANNEL\r
+IMAGE1: LDB 0,[600,,STATUS(B)]\r
+ CAILE 0,2 ; MUST BE TTY\r
+ JRST IMAGFO\r
+ MOVE 0,IOINS(B)\r
+ CAMN 0,[PUSHJ P,MTYO]\r
+ JRST .+3\r
+ CAME 0,[PUSHJ P,GMTYO]\r
+ JRST WRONGD\r
+ HRRZ 0,IOINS-1(B)\r
+ JUMPE 0,OPNIMG\r
+IMGIOT: MOVE A,1(AB) ;GET VALUE\r
+ HRLZ 0,CHANNO(B)\r
+ ASH 0,5\r
+ IOR 0,[.IOT A]\r
+ XCT 0\r
+IMGEXT: MOVE A,(AB) ;RETURN THE ORIGINAL ARG\r
+ MOVE B,1(AB)\r
+ JRST FINIS ;EXIT\r
+\r
+\r
+IMAGFO: PUSH TP,$TCHAN ;IMAGE OUTPUT FOR NON TTY\r
+ PUSH TP,B\r
+ MOVEI B,DIRECT-1(B)\r
+ PUSHJ P,CHRWRD\r
+ JFCL\r
+ CAME B,[ASCII /PRINT/]\r
+ CAMN B,[<ASCII /PRINT/>+1]\r
+ JRST .+2\r
+ JRST BADCHN ; CHANNEL COULDNT BE BLESSED\r
+ MOVE B,(TP)\r
+ PUSHJ P,GWB ; MAKE SURE CHANNEL HAS BUFFER\r
+ MOVE A,1(AB) ; GET THE CHARACTER TO DO\r
+ PUSHJ P,W1CHAR\r
+ MOVE A,(AB)\r
+ MOVE B,1(AB) ;RETURN THE FIX\r
+ JRST FINIS\r
+\r
+\r
+USEOTC: MOVSI A,TATOM\r
+ MOVE B,IMQUOTE OUTCHAN\r
+ PUSHJ P,IDVAL\r
+ GETYP 0,A\r
+ CAIE 0,TCHAN\r
+ MOVE B,TTICHN+1(TVP)\r
+ JRST IMAGE1\r
+\r
+OPNIMG: HLLOS IOINS-1(B)\r
+ CAMN B,TTOCHN+1(TVP)\r
+ SETOM IMAGFL\r
+ PUSHJ P,DEVTOC\r
+ HRLI C,41 ; SUPER IMAGE BIT\r
+ MOVE A,CHANNO(B)\r
+ ASH A,23.\r
+ IOR A,[.OPEN 0,C]\r
+ XCT A\r
+ FATAL TTY OPEN LOSSAGE\r
+ JRST IMGIOT\r
+\r
+DEVTOC: PUSH P,D\r
+ PUSH P,E\r
+ PUSH P,0\r
+ PUSH P,A\r
+ MOVE D,RDEVIC(B)\r
+ MOVE E,[220600,,C]\r
+ MOVEI A,3\r
+ MOVEI C,0\r
+ ILDB 0,D\r
+ SUBI 0,40\r
+ IDPB 0,E\r
+ SOJG A,.-3\r
+ POP P,A\r
+ POP P,0\r
+ POP P,E\r
+ POP P,D\r
+ POPJ P,\r
+\r
+IMGBLK: OUT+IMAGEM+UNIT,,(SIXBIT /TTY/)\r
+ 0\r
+ 0\r
+\r
+\r
+\r
+IMPURE\r
+IMAGFL: 0\r
+PURE\r
+\r
+\r
+END\r
+\f\r
+TITLE READER FOR MUDDLE\r
+\r
+;C. REEVE DEC. 1970\r
+\r
+RELOCA\r
+\r
+READER==1 ;TELL MUDDLE > TO USE SOME SPECIAL HACKS\r
+FRMSIN==1 ;FLAG SAYING WHETHER OR "." AND "'" HACKS EXIST\r
+\r
+.INSRT MUDDLE >\r
+\r
+.GLOBAL CONS,VECTOR,NXTCHR,RLOOKU,CRADIX,SPTIME,QUOTE,TENTAB,CHMAK,FLUSCH,ITENTB\r
+.GLOBAL SETDEV,OPNCHN,ILVAL,RADX,IDVAL,LSTCH,EVECTOR,EUVECTOR,CHUNW\r
+.GLOBAL CHRWRD,EOFCND,DIRECT,ACCESS,IOINS,ROOT,DIRECT,DOIOTI,DOACCS,IGVAL,BYTDOP\r
+.GLOBAL ICONS,INCONS,IEVECT,IEUVEC,BUFSTR,TYPFND,SQUTOA,IBLOCK,GRB\r
+.GLOBAL BADCHN,WRONGD,CHNCLS,FNFFL,IPUT,IGET,ILOC,RXCT,WXCT,IUNWIN,UNWIN2\r
+.GLOBAL CNXTCH,CREADC,MPOPJ,CREDC1,CNXTC1,IREMAS\r
+\r
+BUFLNT==100\r
+\r
+FF=0 ;FALG REGISTER DURING NUMBER CONVERSION\r
+\r
+;FLAGS USED (RIGHT HALF)\r
+\r
+NOTNUM==1 ;NOT A NUMBER\r
+NFIRST==2 ;NOT FIRST CHARACTER BEING READ\r
+DECFRC==4 ;FORCE DECIMAL CONVERSION\r
+NEGF==10 ;NEGATE THIS THING\r
+NUMWIN==20 ;DIGIT(S) SEEN\r
+INSTRN==40 ;IN QUOTED CHARACTER STRING\r
+FLONUM==100 ;NUMBER IS FLOOATING POINT\r
+DOTSEN==200 ;. SEEN IN IMPUT STREAM\r
+EFLG==400 ;E SEEN FOR EXPONENT\r
+IFN FRMSIN,[\r
+ FRSDOT==1000 ;. CAME FIRST\r
+ USEAGN==2000 ;SPECIAL DOT HACK\r
+]\r
+OCTWIN==4000\r
+OCTSTR==10000\r
+\r
+;TEMPORARY OFFSETS\r
+\r
+VCNT==0 ;NUMBER OF ELEMENTS IN CURRENT VECTOR\r
+ONUM==1 ;CURRENT NUMBER IN OCTAL\r
+DNUM==3 ;CURRENT NUMBER IN DECIMAL\r
+FNUM==5 ;CURRENTLY UNUSED\r
+CNUM==7 ;IN CURRENT RADIX\r
+NDIGS==11 ;NUMBER OF DIGITS\r
+ENUM==13 ;EXPONENT\r
+\r
+\r
+\f; TEXT FILE LOADING PROGRAM\r
+\r
+MFUNCTION MLOAD,SUBR,[LOAD]\r
+\r
+ ENTRY\r
+\r
+ HLRZ A,AB ;GET NO. OF ARGS\r
+ CAIE A,-4 ;IS IT 2\r
+ JRST TRY2 ;NO, TRY ANOTHER\r
+ GETYP A,2(AB) ;GET TYPE\r
+ CAIE A,TOBLS ;IS IT OBLIST\r
+ CAIN A,TLIST ; OR LIST THEREOF?\r
+ JRST CHECK1\r
+ JRST WTYP2\r
+\r
+TRY2: CAIE A,-2 ;IS ONE SUPPLIED\r
+ JRST WNA\r
+\r
+CHECK1: GETYP A,(AB) ;GET TYPE\r
+ CAIE A,TCHAN ;IS IT A CHANNEL\r
+ JRST WTYP1\r
+\r
+LOAD1: HLRZ A,TB ;GET CURRENT TIME\r
+ PUSH TP,$TTIME ;AND SAVE IT\r
+ PUSH TP,A\r
+\r
+ MOVEI C,CLSNGO ; LOCATION OF FUNNY CLOSER\r
+ PUSHJ P,IUNWIN ; SET UP AS UNWINDER\r
+\r
+LOAD2: PUSH TP,(AB) ;USE SUPPLIED CHANNEL\r
+ PUSH TP,1(AB)\r
+ PUSH TP,(TB) ;USE TIME AS EOF ARG\r
+ PUSH TP,1(TB)\r
+ CAML AB,[-2,,0] ;CHECK FOR 2ND ARG\r
+ JRST LOAD3 ;NONE\r
+ PUSH TP,2(AB) ;PUSH ON 2ND ARG\r
+ PUSH TP,3(AB)\r
+ MCALL 3,READ\r
+ JRST CHKRET ;CHECK FOR EOF RET\r
+\r
+LOAD3: MCALL 2,READ\r
+CHKRET: CAMN A,(TB) ;IS TYPE EOF HACK\r
+ CAME B,1(TB) ;AND IS VALUE\r
+ JRST EVALIT ;NO, GO EVAL RESULT\r
+ PUSH TP,(AB)\r
+ PUSH TP,1(AB)\r
+ MCALL 1,FCLOSE\r
+ MOVE A,$TCHSTR\r
+ MOVE B,CHQUOTE DONE\r
+ JRST FINIS\r
+\r
+CLSNGO: PUSH TP,$TCHAN\r
+ PUSH TP,1(AB)\r
+ MCALL 1,FCLOSE\r
+ JRST UNWIN2 ; CONTINUE UNWINDING\r
+\r
+EVALIT: PUSH TP,A\r
+ PUSH TP,B\r
+ MCALL 1,EVAL\r
+ JRST LOAD2\r
+\r
+\r
+\r
+; OTHER FILE LOADING PROGRAM\r
+\r
+\r
+\f\r
+MFUNCTION FLOAD,SUBR\r
+\r
+ ENTRY\r
+\r
+ MOVEI C,1 ;INITIALIZE OPEN'S ARG COUNT\r
+ PUSH TP,$TAB ;SLOT FOR SAVED AB\r
+ PUSH TP,[0] ;EMPTY FOR NOW\r
+ PUSH TP,$TCHSTR ;PUT IN FIRST ARG\r
+ PUSH TP,CHQUOTE READ\r
+ MOVE A,AB ;COPY OF ARGUMENT POINTER\r
+\r
+FARGS: JUMPGE A,CALOPN ;DONE? IF SO CALL OPEN\r
+ GETYP B,(A) ;NO, CHECK TYPE OF THIS ARG\r
+ CAIE B,TOBLS ;OBLIST?\r
+ CAIN B,TLIST ; OR LIST THEREOF\r
+ JRST OBLSV ;YES, GO SAVE IT\r
+\r
+ PUSH TP,(A) ;SAVE THESE ARGS\r
+ PUSH TP,1(A)\r
+ ADD A,[2,,2] ;BUMP A\r
+ AOJA C,FARGS ;COUNT AND GO\r
+\r
+OBLSV: MOVEM A,1(TB) ;SAVE THE AB\r
+\r
+CALOPN: ACALL C,FOPEN ;OPEN THE FILE\r
+\r
+ JUMPGE B,FNFFL ;FILE MUST NO EXIST\r
+ EXCH A,(TB) ;PLACE CHANNEL ON STACK\r
+ EXCH B,1(TB) ;OBTAINING POSSIBLE OBLIST\r
+ JUMPN B,2ARGS ;OBLIST SUOPPLIED?\r
+\r
+ MCALL 1,MLOAD ;NO, JUST CALL\r
+ JRST FINIS\r
+\r
+\r
+2ARGS: PUSH TP,(B) ;PUSH THE OBLIST\r
+ PUSH TP,1(B)\r
+ MCALL 2,MLOAD\r
+ JRST FINIS\r
+\r
+\r
+FNFFL: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE FILE-SYSTEM-ERROR\r
+ JUMPE B,CALER1\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ MOVEI A,2\r
+ JRST CALER\r
+\r
+\fMFUNCTION READ,SUBR\r
+\r
+ ENTRY\r
+\r
+ PUSH P,[IREAD1] ;WHERE TO GO AFTER BINDING\r
+READ0: PUSH TP,$TTP ;SLOT FOR LAST THING READ (TYPE IS UNREADABLE)\r
+ PUSH TP,[0]\r
+ PUSH TP,$TFIX ;SLOT FOR RADIX\r
+ PUSH TP,[0]\r
+ PUSH TP,$TCHAN ;AND SLOT FOR CHANNEL\r
+ PUSH TP,[0]\r
+ PUSH TP,[0] ; USER DISP SLOT\r
+ PUSH TP,[0]\r
+ PUSH TP,$TSPLICE\r
+ PUSH TP,[0] ;SEGMENT FOR SPLICING MACROS\r
+ JUMPGE AB,READ1 ;NO ARGS, NO BINDING\r
+ GETYP C,(AB) ;ISOLATE TYPE\r
+ CAIN C,TUNBOU\r
+ JRST WTYP1\r
+ PUSH TP,[TATOM,,-1] ;PUSH THE ATOMS\r
+ PUSH TP,IMQUOTE INCHAN\r
+ PUSH TP,(AB) ;PUSH ARGS\r
+ PUSH TP,1(AB)\r
+ PUSH TP,[0] ;DUMMY\r
+ PUSH TP,[0]\r
+ MOVE B,1(AB) ;GET CHANNEL POINTER\r
+ ADD AB,[2,,2] ;AND ARG POINTER\r
+ JUMPGE AB,BINDEM ;MORE?\r
+ PUSH TP,[TVEC,,-1]\r
+ ADD B,[EOFCND-1,,EOFCND-1]\r
+ PUSH TP,B\r
+ PUSH TP,(AB)\r
+ PUSH TP,1(AB)\r
+ ADD AB,[2,,2]\r
+ JUMPGE AB,BINDEM ;IF ANY MORE ARGS GO PROCESS AND BIND THEM\r
+ GETYP C,(AB) ;ISOLATE TYPE\r
+ CAIE C,TLIST\r
+ CAIN C,TOBLS\r
+ SKIPA\r
+ JRST WTYP3\r
+ PUSH TP,[TATOM,,-1] ;PUSH THE ATOMS\r
+ PUSH TP,IMQUOTE OBLIST\r
+ PUSH TP,(AB) ;PUSH ARGS\r
+ PUSH TP,1(AB)\r
+ PUSH TP,[0] ;DUMMY\r
+ PUSH TP,[0]\r
+ ADD AB,[2,,2] ;AND ARG POINTER\r
+ JUMPGE AB,BINDEM ; ALL DONE, BIND ATOMS\r
+ GETYP 0,(AB) ; GET TYPE OF TABLE\r
+ CAIE 0,TVEC ; SKIP IF BAD TYPE\r
+ JRST WTYP ; ELSE COMPLAIN\r
+ PUSH TP,[TATOM,,-1]\r
+ PUSH TP,IMQUOTE READ-TABLE\r
+ PUSH TP,(AB)\r
+ PUSH TP,1(AB)\r
+ PUSH TP,[0]\r
+ PUSH TP,[0]\r
+ ADD AB,[2,,2] ; BUMP TO NEXT ARG\r
+ JUMPL AB,TMA ;MORE ?, ERROR\r
+BINDEM: PUSHJ P,SPECBIND\r
+ JRST READ1\r
+\r
+MFUNCTION RREADC,SUBR,READCHR\r
+\r
+ ENTRY\r
+ PUSH P,[IREADC]\r
+ JRST READC0 ;GO BIND VARIABLES\r
+\r
+MFUNCTION NXTRDC,SUBR,NEXTCHR\r
+\r
+ ENTRY\r
+\r
+ PUSH P,[INXTRD]\r
+READC0: CAMGE AB,[-5,,]\r
+ JRST TMA\r
+ PUSH TP,(AB)\r
+ PUSH TP,1(AB)\r
+ JUMPL AB,READC1\r
+ MOVE B,IMQUOTE INCHAN\r
+ PUSHJ P,IDVAL\r
+ GETYP A,A\r
+ CAIE A,TCHAN\r
+ JRST BADCHN\r
+ MOVEM A,-1(TP)\r
+ MOVEM B,(TP)\r
+READC1: PUSHJ P,@(P)\r
+ JRST .+2\r
+ JRST FINIS\r
+\r
+ PUSH TP,-1(TP)\r
+ PUSH TP,-1(TP)\r
+ MCALL 1,FCLOSE\r
+ MOVE A,EOFCND-1(B)\r
+ MOVE B,EOFCND(B)\r
+ CAML AB,[-3,,]\r
+ JRST .+3\r
+ MOVE A,2(AB)\r
+ MOVE B,3(AB)\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ MCALL 1,EVAL\r
+ JRST FINIS\r
+\r
+\r
+MFUNCTION PARSE,SUBR\r
+\r
+ ENTRY\r
+\r
+ PUSHJ P,GAPRS ;GET ARGS FOR PARSES\r
+ PUSHJ P,GPT ;GET THE PARSE TABLE\r
+ PUSHJ P,NXTCH ; GET A CHAR TO TEST FOR ! ALT\r
+ SKIPN 11.(TB) ; EOF HIT, COMPLAIN TO LOOSER\r
+ JRST NOPRS\r
+ MOVEI A,33 ; CHANGE IT TO AN ALT, SNEAKY HUH?\r
+ CAIN B,MANYT ; TYPE OF MULTIPLE CLOSE, I.E. ! ALT\r
+ MOVEM A,5(TB)\r
+ PUSHJ P,IREAD1 ;GO DO THE READING\r
+ JRST .+2\r
+ JRST LPSRET ;PROPER EXIT\r
+NOPRS: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE CAN'T-PARSE\r
+ JRST CALER1\r
+\r
+MFUNCTION LPARSE,SUBR\r
+\r
+ ENTRY\r
+\r
+ PUSHJ P,GAPRS ;GET THE ARGS TO THE PARSE\r
+ JRST LPRS1\r
+\r
+GAPRS: PUSH TP,$TTP\r
+ PUSH TP,[0]\r
+ PUSH TP,$TFIX\r
+ PUSH TP,[10.]\r
+ PUSH TP,$TFIX\r
+ PUSH TP,[0] ; LETTER SAVE\r
+ PUSH TP,[0]\r
+ PUSH TP,[0] ; PARSE TABLE MAYBE?\r
+ PUSH TP,$TSPLICE\r
+ PUSH TP,[0] ;SEGMENT FOR SPLICING MACROS\r
+ PUSH TP,[0] ;SLOT FOR LOCATIVE TO STRING\r
+ PUSH TP,[0]\r
+ JUMPGE AB,USPSTR\r
+ PUSH TP,[TATOM,,-1]\r
+ PUSH TP,IMQUOTE PARSE-STRING\r
+ PUSH TP,(AB)\r
+ PUSH TP,1(AB) ; BIND OLD PARSE-STRING\r
+ PUSH TP,[0]\r
+ PUSH TP,[0]\r
+ PUSHJ P,SPECBIND\r
+ ADD AB,[2,,2]\r
+ JUMPGE AB,USPSTR\r
+ GETYP 0,(AB)\r
+ CAIE 0,TFIX\r
+ JRST WTYP2\r
+ MOVE 0,1(AB)\r
+ MOVEM 0,3(TB)\r
+ ADD AB,[2,,2]\r
+ JUMPGE AB,USPSTR\r
+ GETYP 0,(AB)\r
+ CAIE 0,TLIST\r
+ CAIN 0,TOBLS\r
+ SKIPA\r
+ JRST WTYP3\r
+ PUSH TP,[TATOM,,-1]\r
+ PUSH TP,IMQUOTE OBLIST\r
+ PUSH TP,(AB)\r
+ PUSH TP,1(AB) ; HE WANTS HIS OWN OBLIST\r
+ PUSH TP,[0]\r
+ PUSH TP,[0]\r
+ PUSHJ P,SPECBIND\r
+ ADD AB,[2,,2]\r
+ JUMPGE AB,USPSTR\r
+ GETYP 0,(AB)\r
+ CAIE 0,TVEC\r
+ JRST WTYP\r
+ PUSH TP,[TATOM,,-1]\r
+ PUSH TP,IMQUOTE PARSE-TABLE\r
+ PUSH TP,(AB)\r
+ PUSH TP,1(AB)\r
+ PUSH TP,[0]\r
+ PUSH TP,[0]\r
+ PUSHJ P,SPECBIND\r
+ ADD AB,[2,,2]\r
+ JUMPGE AB,USPSTR\r
+ GETYP 0,(AB)\r
+ CAIE 0,TCHRS\r
+ JRST WTYP\r
+ MOVE 0,1(AB)\r
+ MOVEM 0,5(TB) ; STUFF IN A LOOK-AHEAD CHARACTER IF HE WANTS\r
+ ADD AB,[2,,2]\r
+ JUMPL AB,TMA\r
+USPSTR: MOVE B,IMQUOTE PARSE-STRING\r
+ PUSHJ P,ILOC ; GET A LOCATIVE TO THE STRING, WHEREVER\r
+ GETYP 0,A\r
+ CAIN 0,TUNBOUND ; NONEXISTANT\r
+ JRST BDPSTR\r
+ GETYP 0,(B) ; IT IS POINTING TO A STRING\r
+ CAIE 0,TCHSTR\r
+ JRST BDPSTR\r
+ MOVEM A,10.(TB)\r
+ MOVEM B,11.(TB)\r
+ POPJ P,\r
+\r
+LPRS1: PUSHJ P,GPT ; GET THE VALUE OF PARSE-TABLE IN SLOT\r
+ PUSH TP,$TLIST\r
+ PUSH TP,[0] ; HERE WE ARE MAKE PLACE TO SAVE GOODIES\r
+ PUSH TP,$TLIST\r
+ PUSH TP,[0]\r
+LPRS2: PUSHJ P,IREAD1\r
+ JRST LPRSDN ; IF WE ARE DONE, WE ARE THROUGH\r
+ MOVE C,A\r
+ MOVE D,B\r
+ PUSHJ P,INCONS\r
+ SKIPN -2(TP)\r
+ MOVEM B,-2(TP) ; SAVE THE BEGINNING ON FIRST\r
+ SKIPE C,(TP)\r
+ HRRM B,(C) ; PUTREST INTO IT\r
+ MOVEM B,(TP)\r
+ JRST LPRS2\r
+LPRSDN: MOVSI A,TLIST\r
+ MOVE B,-2(TP)\r
+LPSRET: SKIPLE C,5(TB) ; EXIT FOR PARSE AND LPARSE\r
+ CAIN C,400033 ; SEE IF NO PEEK AHEAD OR IF ! ALTMODE\r
+ JRST FINIS ; IF SO NO NEED TO BACK STRING ONE\r
+ SKIPN C,11.(TB)\r
+ JRST FINIS ; IF ATE WHOLE STRING, DONT GIVE BACK ANY\r
+BUPRS: MOVEI D,1\r
+ ADDM D,(C) ; AOS THE COUNT OF STRING LENGTH\r
+ SKIPG D,1(C) ; SEXIER THAN CLR'S CODE FOR DECREMENTING\r
+ SUB D,[430000,,1] ; A BYTE POINTER\r
+ ADD D,[70000,,0]\r
+ MOVEM D,1(C)\r
+ HRRZ E,2(TB)\r
+ JUMPE E,FINIS ; SEE IF WE NEED TO BACK UP TWO\r
+ HLLZS 2(TB) ; CLEAR OUT DOUBLE CHR LOOKY FLAG\r
+ JRST BUPRS ; AND BACK UP PARSE STRING A LITTLE MORE\r
+\r
+\f; ARGUMENTS ARE BOUND, NOW GET THE VALUES OF THINGS\r
+\r
+\r
+GRT: MOVE B,IMQUOTE READ-TABLE\r
+ SKIPA ; HERE TO GET TABLE FOR READ\r
+GPT: MOVE B,IMQUOTE PARSE-TABLE\r
+ MOVSI A,TATOM ; TO FILL SLOT WITH PARSE TABLE\r
+ PUSHJ P,ILVAL\r
+ GETYP 0,A\r
+ CAIN 0,TUNBOUND\r
+ POPJ P,\r
+ CAIE 0,TVEC\r
+ JRST BADPTB\r
+ MOVEM A,6(TB)\r
+ MOVEM B,7(TB)\r
+ POPJ P,\r
+\r
+READ1: PUSHJ P,GRT\r
+ MOVE B,IMQUOTE INCHAN\r
+ MOVSI A,TATOM\r
+ PUSHJ P,IDVAL ;NOW GOBBLE THE REAL CHANNEL\r
+ TLZ A,TYPMSK#777777\r
+ HLLZS A ; INCASE OF FUNNY BUG\r
+ CAME A,$TCHAN ;IS IT A CHANNEL\r
+ JRST BADCHN\r
+ MOVEM A,4(TB) ; STORE CHANNEL\r
+ MOVEM B,5(TB)\r
+ HRRZ A,-4(B)\r
+ TRC A,C.OPN+C.READ\r
+ TRNE A,C.OPN+C.READ\r
+ JRST WRONGD\r
+ HLLOS 4(TB)\r
+ TRNE A,C.BIN ; SKIP IF NOT BIN\r
+ JRST BREAD ; CHECK FOR BUFFER\r
+ HLLZS 4(TB)\r
+GETIOA: MOVE B,5(TB)\r
+GETIO: MOVE A,IOINS(B) ;GOBBLE THE I/O INSTRUCTION\r
+ JUMPE A,OPNFIL ;GO REALLY OPEN THE CROCK\r
+ MOVE A,RADX(B) ;GET RADIX\r
+ MOVEM A,3(TB)\r
+ MOVEM B,5(TB) ;SAVE CHANNEL\r
+REREAD: MOVE D,LSTCH(B) ;ANY CHARS AROUND?\r
+ MOVEI 0,33\r
+ CAIN D,400033 ;FLUSH THE TERMINATOR HACK\r
+ MOVEM 0,LSTCH(B) ; MAKE ! ALT INTO JUST ALT IF IT IS STILL AROUND\r
+\r
+ PUSHJ P,@(P) ;CALL INTERNAL READER\r
+ JRST BADTRM ;LOST\r
+RFINIS: SUB P,[1,,1] ;POP OFF LOSER\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ JUMPE C,FLSCOM ; FLUSH TOP LEVEL COMMENT\r
+ PUSH TP,C\r
+ PUSH TP,D\r
+ MOVE A,4(TB)\r
+ MOVE B,5(TB) ; GET CHANNEL\r
+ MOVSI C,TATOM\r
+ MOVE D,MQUOTE COMMENT\r
+ PUSHJ P,IPUT\r
+RFINI1: POP TP,B\r
+ POP TP,A\r
+ JRST FINIS\r
+\r
+FLSCOM: MOVE A,4(TB)\r
+ MOVE B,5(TB)\r
+ MOVSI C,TATOM\r
+ MOVE D,MQUOTE COMMENT\r
+ PUSHJ P,IREMAS\r
+ JRST RFINI1\r
+\r
+BADTRM: MOVE C,5(TB) ; GET CHANNEL\r
+ JUMPGE B,CHLSTC ;NO, MUST BE UNMATCHED PARENS\r
+ SETZM LSTCH(C) ; DONT REUSE EOF CHR\r
+ PUSH TP,4(TB) ;CLOSE THE CHANNEL\r
+ PUSH TP,5(TB)\r
+ MCALL 1,FCLOSE\r
+ PUSH TP,EOFCND-1(B)\r
+ PUSH TP,EOFCND(B)\r
+ MCALL 1,EVAL ;AND EVAL IT\r
+ SETZB C,D\r
+ GETYP 0,A ; CHECK FOR FUNNY ACT\r
+ CAIE 0,TREADA\r
+ JRST RFINIS ; AND RETURN\r
+\r
+ PUSHJ P,CHUNW ; UNWIND TO POINT\r
+ MOVSI A,TREADA ; SEND MESSAGE BACK\r
+ JRST CONTIN\r
+\r
+;HERE TO ATTEMPT TO OPEN A CLOSED CHANNEL\r
+\r
+OPNFIL: PUSHJ P,OPNCHN ;GO DO THE OPEN\r
+ JUMPGE B,FNFFL ;LOSE IC B IS 0\r
+ JRST GETIO\r
+\r
+\r
+CHLSTC: MOVE B,5(TB) ;GET CHANNEL BACK\r
+ JRST REREAD\r
+\r
+\r
+BREAD: MOVE B,5(TB) ; GET CHANNEL\r
+ SKIPE BUFSTR(B)\r
+ JRST GETIO\r
+ MOVEI A,BUFLNT ; GET A BUFFER\r
+ PUSHJ P,IBLOCK\r
+ MOVEI C,BUFLNT(B) ; POINT TO END\r
+ HRLI C,440700\r
+ MOVE B,5(TB) ; CHANNEL BACK\r
+ MOVEI 0,C.BUF\r
+ IORM 0,-4(B)\r
+ MOVEM C,BUFSTR(B)\r
+ MOVSI C,TCHSTR+.VECT.\r
+ MOVEM C,BUFSTR-1(B)\r
+ JRST GETIO\r
+\f;MAIN ENTRY TO READER\r
+\r
+NIREAD: PUSHJ P,LSTCHR\r
+NIREA1: PUSH P,[-1] ; DONT GOBBLE COMMENTS\r
+ JRST IREAD2\r
+\r
+IREAD:\r
+ PUSHJ P,LSTCHR ;DON'T REREAD LAST CHARACTER\r
+IREAD1: PUSH P,[0] ; FLAG SAYING SNARF COMMENTS\r
+IREAD2: INTGO\r
+BDLP: SKIPE C,9.(TB) ;HAVE WE GOT A SPLICING MACRO LEFT\r
+ JRST SPLMAC ;IF SO GIVE HIM SOME OF IT\r
+ PUSHJ P,NXTCH ;GOBBLE CHAR IN A AND TYPE IN D\r
+ MOVMS B ; FOR SPECIAL NEG HACK OF MACRO TABLES\r
+ CAIG B,ENTYPE\r
+ JUMPN B,@DTBL-1(B) ;ERROR ON ZERO TYPE OR FUNNY TYPE\r
+ JRST BADCHR\r
+\r
+\r
+SPLMAC: HRRZ D,(C) ;GET THE REST OF THE SEGMENT\r
+ MOVEM D,9.(TB) ;AND PUT BACK IN PLACE\r
+ GETYP D,(C) ;SEE IF DEFERMENT NEEDED\r
+ CAIN D,TDEFER\r
+ MOVE C,1(C) ;IF SO, DO DEFEREMENT\r
+ MOVE A,(C)\r
+ MOVE B,1(C) ;GET THE GOODIE\r
+ AOS -1(P) ;ALWAYS A SKIP RETURN\r
+ POP P,(P) ;DONT WORRY ABOUT COMMENT SEARCHAGE\r
+ SETZB C,D ;MAKE SURE HE DOESNT THINK WE GOT COMMENT\r
+ POPJ P, ;GIVE HIM WHAT HE DESERVES\r
+\r
+DTBL: NUMLET ;HERE IF NUMBER OR LETTER\r
+ NUMLET ;NUMBER\r
+NUMCOD==.-DTBL\r
+ NUMLET ;+-\r
+PLUMIN==.-DTBL\r
+ NUMLET ;.\r
+DOTTYP==.-DTBL\r
+ NUMLET ;E\r
+NONSPC==.-DTBL ;NUMBER OF NON-SPECIAL CHARACTERS\r
+ SPACE ;SPACING CHAR CR,LF,SP,TAB ETC.\r
+SPATYP==.-DTBL ;TYPE FOR SPACE CHARS\r
+\r
+\r
+;THE FOLLOWING ENTRIES ARE VARIOUS PUNCTUATION CROCKS\r
+\r
+ LPAREN ;( - BEGIN LIST\r
+ RPAREN ;) - END CURRENT LEVEL OF INPUT\r
+ LBRACK ;[ -BEGIN ARRAY\r
+LBRTYP==.-DTBL\r
+ RBRACK ;] - END OF ARRAY\r
+ QUOTIT ;' - QUOTE THE FOLLOWING GOODIE\r
+QUOTYP==.-DTBL\r
+\r
+ MACCAL ;% - INVOKE A READ TIME MACRO\r
+MACTYP==.-DTBL\r
+ CSTRING ;" - CHARACTER STRING\r
+CSTYP==.-DTBL\r
+ NUMLET ;\ - ESCAPE,BEGIN ATOM\r
+\r
+ESCTYP==.-DTBL ;TYPE OF ESCAPE CHARACTER\r
+\r
+ SPECTY ;# - SPECIAL TYPE TO BE READ\r
+SPCTYP==.-DTBL\r
+ OPNANG ;< - BEGIN ELEMENT CALL\r
+\r
+SLMNT==.-DTBL ;TYPE OF START OF SEGMENT\r
+\r
+ CLSANG ;> - END ELEMENT CALL\r
+\r
+\r
+ EOFCHR ;^C - END OF FILE\r
+\r
+ COMNT ;; - BEGIN COMMENT\r
+COMTYP==.-DTBL ;TYPE OF START OF COMMENT\r
+\r
+ GLOVAL ;, - GET GLOBAL VALUE\r
+GLMNT==.-DTBL\r
+ ILLSQG ;{ - START TEMPLATE STRUCTURE\r
+TMPTYP==.-DTBL\r
+ CLSBRA ;} - END TEMPLATE STRUCTURE\r
+\r
+NTYPES==.-DTBL\r
+\f\r
+\r
+\r
+; EXTENDED TABLE FOR ! HACKS\r
+\r
+ NUMLET ; !! FAKE OUT\r
+ SEGDOT ;!. - CALL TO LVAL (SEG)\r
+DOTEXT==.-DTBL\r
+ UVECIN ;![ - INPUT UNIFORM VECTOR ]\r
+LBREXT==.-DTBL\r
+ QUOSEG ;!' - SEG CALL TO QUOTE\r
+QUOEXT==.-DTBL\r
+ SINCHR ;!" - INPUT ONE CHARACTER\r
+CSEXT==.-DTBL\r
+ SEGIN ;!< - SEG CALL\r
+SLMEXT==.-DTBL\r
+ GLOSEG ;!, - SEG CALL TO GVAL\r
+GLMEXT==.-DTBL\r
+ LOSPATH ;!- - PATH NAME SEPARATOR\r
+PATHTY==.-DTBL\r
+ TERM ;!$ - (EXCAL-ALT MODE) PUT ALL CLOSES\r
+MANYT==.-DTBL\r
+ USRDS1 ; DISPATCH FOR USER TABLE (NO !)\r
+USTYP1==.-DTBL\r
+ USRDS2 ; " " " " (WITH !)\r
+USTYP2==.-DTBL\r
+ENTYPE==.-DTBL\r
+\r
+\r
+\r
+SPACE: PUSHJ P,LSTCHR ;DONT REREAD SPACER\r
+ JRST BDLP\r
+\r
+USRDS1: SKIPA B,A ; GET CHAR IN B \r
+USRDS2: MOVEI B,200(A) ; ! CHAR, DISP 200 FURTHER\r
+ ASH B,1\r
+ ADD B,7(TB) ; POINT TO TABLE ENTRY\r
+ GETYP 0,(B)\r
+ CAIN 0,TLIST\r
+ MOVE B,1(B) ; IF LIST, USE FIRST ITEM-SPECIAL NO BREAK HACK\r
+ SKIPL C,5(TB) ; GET CHANNEL POINTER (IF ANY)\r
+ JRST USRDS3\r
+ ADD C,[EOFCND-1,,EOFCND-1]\r
+ PUSH TP,$TBVL\r
+ HRRM SP,(TP) ; BUILD A TBVL\r
+ MOVE SP,TP\r
+ PUSH TP,C\r
+ PUSH TP,(C)\r
+ PUSH TP,1(C)\r
+ MOVEI D,PVLNT*2+1(PVP)\r
+ HRLI D,TREADA\r
+ MOVEM D,(C)\r
+ MOVEI D,(TB)\r
+ HLL D,OTBSAV(TB)\r
+ MOVEM D,1(C)\r
+USRDS3: PUSH TP,(B) ; APPLIER\r
+ PUSH TP,1(B)\r
+ PUSH TP,$TCHRS ; APPLY TO CHARACTER\r
+ PUSH TP,A\r
+ PUSHJ P,LSTCHR ; FLUSH CHAR\r
+ MCALL 2,APPLY ; GO TO USER GOODIE\r
+ HRRZ SP,(SP) ; UNBIND MANUALLY\r
+ MOVEI D,(TP)\r
+ SUBI D,(SP)\r
+ MOVSI D,(D)\r
+ HLL SP,TP\r
+ SUB SP,D\r
+ SUB TP,[4,,4] ; FLUSH TP CRAP\r
+ GETYP 0,A ; CHECK FOR DISMISS?\r
+ CAIN 0,TSPLICE\r
+ JRST GOTSPL ; RETURN OF SEGMENT INDICATES SPLICAGE\r
+ CAIN 0,TREADA ; FUNNY?\r
+ JRST DOEOF\r
+ CAIE 0,TDISMI\r
+ JRST RET ; NO, RETURN FROM IREAD\r
+ JRST BDLP ; YES, IGNORE RETURN\r
+\r
+GOTSPL: MOVEM B,9.(TB) ; STICK IN THE SPLICAGE SLOT SO IREADS WILL GET HIM\r
+ JRST BDLP ; GO BACK AND READ FROM OUR SPLICE, OK?\r
+\r
+\f\r
+;HERE ON NUMBER OR LETTER, START ATOM\r
+\r
+NUMLET: PUSHJ P,GOBBLE ;READ IN THE ATOM AND PUT PNTR ON ARG PDL\r
+ JRST RET ;NO SKIP RETURN I.E. NON NIL\r
+\r
+;HERE TO START BUILDING A CHARACTER STRING GOODIE\r
+\r
+CSTRING: PUSHJ P,GOBBL1 ;READ IN STRING\r
+ JRST RET\r
+\r
+;ARRIVE HERE TO INVOKE A READ TIME MACRO FUNCTION\r
+\r
+MACCAL: PUSHJ P,NXTCH1 ;READ ONE MORE CHARACTER\r
+ CAIE B,MACTYP ;IS IT ANOTHER MACRO CHAR\r
+\r
+ JRST MACAL2 ;NO, CALL MACRO AND USE VALUE\r
+ PUSHJ P,LSTCHR ;DONT REREAD %\r
+ PUSHJ P,MACAL1 ;OTHERWISE, USE SIDE EFFECCT, BUT NOT VALUE\r
+ JRST IREAD2\r
+\r
+MACAL2: PUSH P,CRET\r
+MACAL1: PUSHJ P,IREAD1 ;READ FUNCTION NAME\r
+ JRST RETERR\r
+ PUSH TP,C\r
+ PUSH TP,D ; SAVE COMMENT IF ANY\r
+ PUSH TP,A ;SAVE THE RESULT\r
+ PUSH TP,B ;AND USE IT AS AN ARGUMENT\r
+ MCALL 1,EVAL\r
+ POP TP,D\r
+ POP TP,C ; RESTORE COMMENT IF ANY...\r
+CRET: POPJ P,RET12\r
+\r
+;CALL GOBBLE TO FIND THE TYPE AND THEN IREAD TO READ IT\r
+\r
+SPECTY: PUSHJ P,NIREAD ; READ THE TYPES NAME (SHOULD BE AN ATOM)\r
+ JRST RETERR\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ PUSHJ P,NXTCH ; GET NEXT CHAR\r
+ CAIN B,TMPTYP ; SKIP IF NOT TEMPLATE START\r
+ JRST RDTMPL\r
+ SETZB A,B\r
+ EXCH A,-1(TP)\r
+ EXCH B,(TP)\r
+ PUSH TP,A ;BEGIN SETTING UP CHTYPE CALL\r
+ PUSH TP,B\r
+ PUSHJ P,IREAD1 ;NOW READ STRUCTURE\r
+ JRST RETER1\r
+ MOVEM C,-3(TP) ; SAVE COMMENT\r
+ MOVEM D,-2(TP)\r
+ EXCH A,-1(TP) ;USE AS FIRST ARG\r
+ EXCH B,(TP)\r
+ PUSH TP,A ;USE OTHER AS 2D ARG\r
+ PUSH TP,B\r
+ MCALL 2,CHTYPE ;ATTEMPT TO MUNG\r
+RET13: POP TP,D\r
+ POP TP,C ; RESTORE COMMENT\r
+RET12: SETOM (P) ; DONT LOOOK FOR MORE!\r
+ JRST RET\r
+\r
+RDTMPL: PUSH P,["}] ; SET UP TERMINATE TEST\r
+ MOVE B,(TP)\r
+ PUSHJ P,IGVAL\r
+ MOVEM A,-1(TP)\r
+ MOVEM B,(TP)\r
+ PUSH P,[BLDTMP] ; FLAG FOR VECTOR READING CODE\r
+ JRST LBRAK2\r
+\r
+BLDTMP: ADDI A,1 ; 1 MORE ARGUMENT\r
+ ACALL A,APPLY ; DO IT TO IT\r
+ POPJ P,\r
+\r
+RETER1: SUB TP,[2,,2]\r
+RETERR: SKIPL A,5(TB)\r
+ MOVEI A,5(TB)-LSTCH ;NO CHANNEL, USE SLOT\r
+ MOVEM B,LSTCH(A) ; RESTORE LAST CHAR\r
+ PUSHJ P,ERRPAR\r
+ JRST RET1\r
+\f\r
+;THIS CODE CALLS IREAD RECURSIVELY TO READ THAT WHICH IS\r
+;BETWEEN (), ARRIVED AT WHEN ( IS READ\r
+\r
+SEGIN: PUSH TP,$TSEG\r
+ JRST OPNAN1\r
+\r
+OPNANG: PUSH TP,$TFORM ;SAVE TYPE\r
+OPNAN1: PUSH P,[">]\r
+ JRST LPARN1\r
+\r
+LPAREN: PUSH P,[")]\r
+ PUSH TP,$TLIST ;START BY ASSUMING NIL\r
+LPARN1: PUSH TP,[0]\r
+ PUSHJ P,LSTCHR ;DON'T REREAD PARENS\r
+LLPLOP: PUSHJ P,IREAD1 ;READ IT\r
+ JRST LDONE ;HIT TERMINATOR\r
+\r
+;HERE WHEN MUST ADD CAR TO CURRENT WINNER\r
+\r
+GENCAR: PUSH TP,C ; SAVE COMMENT\r
+ PUSH TP,D\r
+ MOVE C,A ; SET UP CALL\r
+ MOVE D,B\r
+ PUSHJ P,INCONS ; CONS ON TO NIL\r
+ POP TP,D\r
+ POP TP,C\r
+ POP TP,E ;GET CDR\r
+ JUMPN E,CDRIN ;IF STACKED GOODIE NOT NIL SKIP\r
+ PUSH TP,B ;AND USE AS TOTAL VALUE\r
+ PUSH TP,$TLIST ;SAVE THIS AS FIRSST THING ON LIST\r
+ MOVE A,-2(TP) ; GET REAL TYPE\r
+ JRST .+2 ;SKIP CDR SETTING\r
+CDRIN: HRRM B,(E)\r
+ PUSH TP,B ;CLOBBER IN NEW PARTIAL GOODIE\r
+ JUMPE C,LLPLOP ; JUMP IF NO COMMENT\r
+ PUSH TP,C\r
+ PUSH TP,D\r
+ MOVSI C,TATOM\r
+ MOVE D,MQUOTE COMMENT\r
+ PUSHJ P,IPUT\r
+ JRST LLPLOP ;AND CONTINUE\r
+\r
+; HERE TO RAP UP LIST\r
+\r
+LDONE: CAME B,(P) ;CHECK VALIDITY OF CHARACTER\r
+ PUSHJ P,MISMAT ;REPORT MISMATCH\r
+ SUB P, [1,,1]\r
+ POP TP,B ;GET VALUE OF PARTIAL RESULT\r
+ POP TP,A ;AND TYPE OF SAME\r
+ JUMPE B,RET ;VALUE IS NIL, DON'T POP AGAIN\r
+ POP TP,B ;POP FIRST LIST ELEMENT\r
+ POP TP,A ;AND TYPE\r
+ JRST RET\r
+\f\r
+;THIS CODE IS SIMILAR TO LIST GENERATING CODE BUT IS FOR VECTORS\r
+OPNBRA: PUSH P,["}] ; SAVE TERMINATOR\r
+UVECIN: PUSH P,[135] ; CLOSE SQUARE BRACKET\r
+ PUSH P,[IEUVECTOR] ;PUSH NAME OF U VECT HACKER\r
+ JRST LBRAK2 ;AND GO\r
+\r
+LBRACK: PUSH P,[135] ; SAVE TERMINATE\r
+ PUSH P,[IEVECTOR] ;PUSH GEN VECTOR HACKER\r
+LBRAK2: PUSHJ P,LSTCHR ;FORCE READING NEW CHAR\r
+ PUSH P,[0] ; COUNT ELEMENTS\r
+ PUSH TP,$TLIST ; AND SLOT FOR GOODIES\r
+ PUSH TP,[0]\r
+\r
+LBRAK1: PUSHJ P,IREAD1 ;RECURSIVELY READ ELEMENTS OF ARRAY\r
+ JRST LBDONE ;RAP UP ON TERMINATOR\r
+\r
+STAKIT: EXCH A,-1(TP) ; STORE RESULT AND GET CURRENT LIST\r
+ EXCH B,(TP)\r
+ AOS (P) ; COUNT ELEMENTS\r
+ JUMPE C,LBRAK3 ; IF NO COMMENT, GO ON\r
+ MOVEI E,(B) ; GET CDR\r
+ PUSHJ P,ICONS ; CONS IT ON\r
+ MOVEI E,(B) ; SAVE RS\r
+ MOVSI C,TFIX ; AND GET FIXED NUM\r
+ MOVE D,(P)\r
+ PUSHJ P,ICONS\r
+LBRAK3: PUSH TP,A ; SAVE CURRENT COMMENT LIST\r
+ PUSH TP,B\r
+ JRST LBRAK1\r
+\r
+; HERE TO RAP UP VECTOR\r
+\r
+LBDONE: CAME B,-2(P) ; FINISHED RETURN (WAS THE RIGHT STOP USED?)\r
+ PUSHJ P,MISMAB ; WARN USER\r
+ POP TP,1(TB) ; REMOVE COMMENT LIST\r
+ POP TP,(TB)\r
+ MOVE A,(P) ; COUNT TO A\r
+ PUSHJ P,-1@(P) ; MAKE THE VECTOR\r
+ SUB P,[3,,3] \r
+\r
+; PUT COMMENTS ON VECTOR (OR UVECTOR)\r
+\r
+ MOVNI C,1 ; INDICATE TEMPLATE HACK\r
+ CAMN A,$TVEC\r
+ MOVEI C,1\r
+ CAMN A,$TUVEC ; SKIP IF UVECTOR\r
+ MOVEI C,0\r
+ PUSH P,C ; SAVE\r
+ PUSH TP,A ; SAVE VECTOR/UVECTOR\r
+ PUSH TP,B\r
+\r
+VECCOM: SKIPN C,1(TB) ; ANY LEFT?\r
+ JRST RETVEC ; NO, LEAVE\r
+ MOVE A,1(C) ; ASSUME WINNING TYPES\r
+ SUBI A,1\r
+ HRRZ C,(C) ; CDR THE LIST\r
+ HRRZ E,(C) ; AGAIN\r
+ MOVEM E,1(TB) ; SAVE CDR\r
+ GETYP E,(C) ; CHECK DEFFERED\r
+ MOVSI D,(E)\r
+ CAIN E,TDEFER ; SKIP IF NOT DEFERRED\r
+ MOVE C,1(C)\r
+ CAIN E,TDEFER\r
+ GETYPF D,(C) ; GET REAL TYPE\r
+ MOVE B,(TP) ; GET VECTOR POINTER\r
+ SKIPGE (P) ; SKIP IF NOT TEMPLATE\r
+ JRST TMPCOM\r
+ HRLI A,(A) ; COUNTER\r
+ LSH A,@(P) ; MAYBE SHIFT IT\r
+ ADD B,A\r
+ MOVE A,-1(TP) ; TYPE\r
+TMPCO1: PUSH TP,D\r
+ PUSH TP,1(C) ; PUSH THE COMMENT\r
+ MOVSI C,TATOM\r
+ MOVE D,MQUOTE COMMENT\r
+ PUSHJ P,IPUT\r
+ JRST VECCOM\r
+\r
+TMPCOM: MOVSI A,(A)\r
+ ADD B,A\r
+ MOVSI A,TTMPLT\r
+ JRST TMPCO1\r
+\r
+RETVEC: SUB P,[1,,1]\r
+ POP TP,B\r
+ POP TP,A\r
+ JRST RET\r
+ \r
+; BUILD A SINGLE CHARACTER ITEM\r
+\r
+SINCHR: PUSHJ P,NXTC1 ;FORCE READ NEXT\r
+ CAIN B,ESCTYP ;ESCAPE?\r
+ PUSHJ P,NXTC1 ;RETRY\r
+ MOVEI B,(A)\r
+ MOVSI A,TCHRS\r
+ JRST RETCL\r
+\r
+\f\r
+; HERE ON RIGHT PAREN, BRACKET, ANGLE BRACKET OR CTL C\r
+\r
+CLSBRA:\r
+CLSANG: ;CLOSE ANGLE BRACKETS\r
+RBRACK: ;COMMON RETURN FOR END OF ARRAY ALSO\r
+RPAREN: PUSHJ P,LSTCHR ;DON'T REREAD \r
+EOFCH1: MOVE B,A ;GETCHAR IN B\r
+ MOVSI A,TCHRS ;AND TYPE IN A\r
+RET1: SUB P,[1,,1]\r
+ POPJ P,\r
+\r
+EOFCHR: SETZB C,D\r
+ JUMPL A,EOFCH1 ; JUMP ON REAL EOF\r
+ JRST RRSUBR ; MAYBE A BINARY RSUBR\r
+\r
+DOEOF: MOVE A,[-1,,3]\r
+ SETZB C,D\r
+ JRST EOFCH1\r
+\r
+\r
+; NORMAL RETURN FROM IREAD/IREAD1\r
+\r
+RETCL: PUSHJ P,LSTCHR ;DONT REREAD\r
+RET: AOS -1(P) ;SKIP\r
+ POP P,E ; POP FLAG\r
+RETC: JUMPL E,RET2 ; DONT LOOK FOR COMMENTS\r
+ PUSH TP,A ; SAVE ITEM\r
+ PUSH TP,B\r
+CHCOMN: PUSHJ P,NXTCH ; READ A CHARACTER \r
+ CAIE B,COMTYP ; SKIP IF COMMENT\r
+ JRST CHSPA\r
+ PUSHJ P,IREAD ; READ THE COMMENT\r
+ JRST POPAJ\r
+ MOVE C,A\r
+ MOVE D,B\r
+ JRST .+2\r
+POPAJ: SETZB C,D\r
+ POP TP,B\r
+ POP TP,A\r
+RET2: POPJ P,\r
+\r
+CHSPA: CAIN B,SPATYP\r
+ PUSHJ P,SPACEQ ; IS IT A REAL SPACE\r
+ JRST POPAJ\r
+ PUSHJ P,LSTCHR ; FLUSH THE SPACE\r
+ JRST CHCOMN\r
+\r
+;RANDOM MINI-SUBROUTINES USED BY THE READER\r
+\r
+;READ A CHAR INTO A AND TYPE CODE INTO D\r
+\r
+NXTC1: SKIPL B,5(TB) ;GET CHANNEL\r
+ JRST NXTPR1 ;NO CHANNEL, GO READ STRING\r
+ SKIPE LSTCH(B)\r
+ PUSHJ P,CNTACC ; COUNT ON ACCESS POINTER\r
+ JRST NXTC2\r
+NXTC: SKIPL B,5(TB) ;GET CHANNEL\r
+ JRST NXTPRS ;NO CHANNEL, GO READ STRING\r
+ SKIPE A,LSTCH(B) ;CHAR IN A IF REUSE\r
+ JRST PRSRET\r
+NXTC2: PUSHJ P,RXCT ;GET CHAR FROM INPUT\r
+ HLLZS 2(TB) ;FLAG INDICATING ONE CHAR LOOK AHEAD\r
+ MOVEM A,LSTCH(B) ;SAVE THE CHARACTER\r
+PRSRET: TRZE A,400000 ;DONT SKIP IF SPECIAL\r
+ JRST RETYPE ;GO HACK SPECIALLY\r
+GETCTP: CAILE A,177 ; CHECK RANGE\r
+ JRST BADCHR\r
+ PUSH P,A ;AND SAVE FROM DIVISION\r
+ ANDI A,177\r
+ IDIVI A,CHRWD ;YIELDS WORD AND CHAR NUMBER\r
+ LDB B,BYTPNT(B) ;GOBBLE TYPE CODE\r
+ POP P,A\r
+ POPJ P,\r
+\r
+NXTPRS: SKIPE A,5(TB) ;GET OLD CHARACTER IF ONE EXISTS\r
+ JRST PRSRET\r
+NXTPR1: MOVEI A,400033\r
+ PUSH P,C\r
+ MOVE C,11.(TB)\r
+ HRRZ B,(C) ;GET THE STRING\r
+ SOJL B,NXTPR3\r
+ HRRM B,(C)\r
+ ILDB A,1(C) ;GET THE CHARACTER FROM THE STRING\r
+NXTPR2: MOVEM A,5(TB) ;SAVE IT\r
+ POP P,C\r
+ JRST PRSRET ;CONTINUE\r
+NXTPR3: SETZM 8.(TB)\r
+ SETZM 9.(TB) ;CLEAR OUT LOCATIVE, AT END OF STRING\r
+ JRST NXTPR2\r
+\r
+; NXTCH AND NXTCH1 ARE SAME AS NXTC AND NXTC1 EXCEPT THEY CHECK !\r
+; HACKS\r
+\r
+NXTCH1: PUSHJ P,NXTC1 ;READ CHAR\r
+ JRST .+2\r
+NXTCH: PUSHJ P,NXTC ;READ CHAR\r
+ CAIGE B,NTYPES+1 ;IF 1 > THAN MAX, MUST BE SPECIAL\r
+ JRST CHKUS1 ; CHECK FOR USER DISPATCH\r
+\r
+ CAIN B,NTYPES+1 ;FOR OBSCURE BUG FOUND BY MSG\r
+ PUSHJ P,NXTC1 ;READ NEXT ONE\r
+ HLLOS 2(TB) ;FLAG FOR TWO CHAR LOOK AHEAD\r
+\r
+RETYP1: CAIN A,". ;!.\r
+ MOVEI B,DOTEXT ;YES, GET EXTENDED TYPE\r
+ CAIN A,"[\r
+ MOVEI B,LBREXT\r
+ CAIN A,"'\r
+ MOVEI B,QUOEXT\r
+ CAIN A,""\r
+ MOVEI B,CSEXT\r
+ CAIN A,"-\r
+ MOVEI B,PATHTY\r
+ CAIN A,"<\r
+ MOVEI B,SLMEXT\r
+ CAIN A,",\r
+ MOVEI B,GLMEXT\r
+ CAIN A,33\r
+ MOVEI B,MANYT ;! ALTMODE\r
+\r
+CRMLST: ADDI A,400000 ;CLOBBER LASTCHR\r
+ PUSH P,B\r
+ SKIPL B,5(TB) ;POINT TO CHANNEL\r
+ MOVEI B,5(TB)-LSTCH ;NO CHANNEL, POINT AT SLOT\r
+ MOVEM A,LSTCH(B)\r
+ SUBI A,400000 ;DECREASE CHAR\r
+ POP P,B\r
+\r
+CHKUS2: SKIPN 7(TB) ; SKIP IF USER TABLE\r
+ JRST UPLO\r
+ PUSH P,A\r
+ ADDI A,200\r
+ ASH A,1 ; POINT TO SLOT\r
+ HRLS A\r
+ ADD A,7(TB)\r
+ SKIPL A ;IS THERE VECTOR ENOUGH?\r
+ JRST CHKUS4\r
+ SKIPN 1(A) ; NON-ZERO==>USER FCN EXISTS\r
+ JRST CHKUS4 ; HOPE HE APPRECIATES THIS\r
+ MOVEI B,USTYP2\r
+CHKRDO: PUSH P,0 ; CHECK FOR REDOING IF CHAR IN TABLE\r
+ GETYP 0,(A)\r
+ CAIE 0,TCHRS\r
+ JRST CHKUS5\r
+ POP P,0 ;WE ARE TRANSMOGRIFYING\r
+ POP P,(P) ;FLUSH OLD CHAR\r
+ MOVE A,1(A) ;GET NEW CHARACTER\r
+ PUSH P,7(TB)\r
+ PUSH P,2(TB) ; FLAGS FOR NUM OF CHRS IN LOOK AHEAD\r
+ PUSH P,5(TB) ; TO AVOID SMASHING LSTCHR\r
+ SETZM 5(TB) ; CLEAR OUT CHANNEL\r
+ SETZM 7(TB) ;CLEAR OUT TABLE\r
+ TRZE A,200 ; ! HACK\r
+ TRO A,400000 ; TURN ON PROPER BIT\r
+ PUSHJ P,PRSRET\r
+ POP P,5(TB) ; GET BACK CHANNEL\r
+ POP P,2(TB)\r
+ POP P,7(TB) ;GET BACK OLD PARSE TABLE\r
+ POPJ P,\r
+\r
+CHKUS5: CAIE 0,TLIST\r
+ JRST .+4 ; SPECIAL NON-BREAK TYPE HACK\r
+ MOVNS -1(P) ; INDICATE BY NEGATIVE \r
+ MOVE A,1(A) ; GET <1 LIST>\r
+ GETYP 0,(A) ; AND GET THE TYPE OF THAT\r
+ CAIE 0,TFIX ; SEE IF HE WANTS SAME CHAR WITH DIFF TYPE\r
+ JRST CHKUS6 ; JUST A VANILLA HACK\r
+ MOVE A,1(A) ; PRETEND IT IS SAME TYPE AS NEW CHAR\r
+ PUSH P,7(TB) ; CLEAR OUT TRANSLATE TABLE\r
+ PUSH P,2(TB) ; FLAGS FOR # OF CHRS IN LOOK AHEAD\r
+ SETZM 7(TB)\r
+ TRZE A,200\r
+ TRO A,400000 ; TURN ON PROPER BIT IF ! HACK\r
+ PUSHJ P,PRSRET ; REGET TYPE\r
+ POP P,2(TB)\r
+ POP P,7(TB) ; PUT TRANSLATE TABLE BACK\r
+CHKUS6: SKIPGE -1(P) ; SEE IF A SPECIAL NON-BREAK\r
+ MOVNS B ; SEXY, HUH?\r
+ POP P,0\r
+ POP P,A\r
+ MOVMS A ; FIX UP A POSITIVE CHARACTER\r
+ POPJ P,\r
+\r
+CHKUS4: POP P,A\r
+ JRST UPLO\r
+\r
+CHKUS1: SKIPN 7(TB) ; USER CHECK FOR NOT ! CASE\r
+ POPJ P,\r
+ PUSH P,A\r
+ ASH A,1\r
+ HRLS A\r
+ ADD A,7(TB)\r
+ SKIPL A\r
+ JRST CHKUS3\r
+ SKIPN 1(A)\r
+ JRST CHKUS3\r
+ MOVEI B,USTYP1\r
+ JRST CHKRDO ; TRANSMOGRIFY CHARACTER?\r
+\r
+CHKUS3: POP P,A\r
+ POPJ P,\r
+\r
+UPLO: POPJ P, ; LETS NOT AND SAY WE USED TO\r
+ ; AVOID STRANGE ! BLECHAGE\r
+\r
+RETYPE: PUSHJ P,GETCTP ;GET TYPE OF CHAR\r
+ JRST RETYP1\r
+\r
+NXTCS: PUSHJ P,NXTC\r
+ PUSH P,A ; HACK TO NOT TRANSLATE CHAR\r
+ PUSHJ P,CHKUS1 ; BUT DO TRANSLATION OF TYPE IF HE WANTS\r
+ POP P,A ; USED TO BUILD UP STRINGS\r
+ POPJ P,\r
+\r
+CHKALT: CAIN A,33 ;ALT?\r
+ MOVEI B,MANYT\r
+ JRST CRMLST\r
+\r
+\r
+TERM: MOVEI B,0 ;RETURN A 0\r
+ JRST RET1\r
+ ;AND RETURN\r
+\r
+CHKMIN: CAIN A,"- ; IF CHAR IS -, WINNER\r
+ MOVEI B,PATHTY\r
+ JRST CRMLST\r
+\r
+LOSPAT: PUSHJ P,LSTCHR ; FIX RECURSIVE LOSAGE\r
+ PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE UNATTACHED-PATH-NAME-SEPARATOR\r
+ JRST CALER1\r
+\r
+\f\r
+; HERE TO SEE IF READING RSUBR\r
+\r
+RRSUBR: PUSHJ P,LSTCHR ; FLUSH JUST READ CHAR\r
+ SKIPL B,5(TB) ; SKIP IF A CHANNEL EXISTS\r
+ JRST SPACE ; ELSE LIKE A SPACE\r
+ MOVE C,@BUFSTR(B) ; SEE IF FLAG SAYS START OF RSUBR\r
+ TRNN C,1 ; SKIP IF REAL RSUBR\r
+ JRST SPACE ; NO, IGNORE FOR NOW\r
+\r
+; REALLY ARE READING AN RSUBR\r
+\r
+ HRRZ 0,4(TB) ; GET READ/READB INDICATOR\r
+ MOVE C,ACCESS(B) ; GET CURRENT ACCESS\r
+ JUMPN 0,.+3 ; ALREADY WORDS, NO NEED TO DIVIDE\r
+ ADDI C,4 ; ROUND UP\r
+ IDIVI C,5\r
+ PUSH P,C ; SAVE WORD ACCESS\r
+ MOVEI A,(C) ; COPY IT FOR CALL\r
+ JUMPN 0,.+3\r
+ IMULI C,5\r
+ MOVEM C,ACCESS(B) ; FIXUP ACCESS\r
+ HLLZS ACCESS-1(B) ; FOR READB LOSER\r
+ PUSHJ P,DOACCS ; AND GO THERE\r
+ PUSH P,[0] ; FOR READ IN\r
+ HRROI A,(P) ; PREPARE TO READ LENGTH\r
+ PUSHJ P,DOIOTI ; READ IT\r
+ POP P,C ; GET READ GOODIE\r
+ MOVEI A,(C) ; COPY FOR GETTING BLOCK\r
+ ADDI C,1 ; COUNT COUNT WORD\r
+ ADDM C,(P)\r
+ PUSH TP,$TUVEC ; WILL HOLD UVECTOR OF FIXUPS IF THEY STAY\r
+ PUSH TP,[0]\r
+ PUSHJ P,IBLOCK ; GET A BLOCK\r
+ PUSH TP,$TUVEC\r
+ PUSH TP,B ; AND SAVE\r
+ MOVE A,B ; READY TO IOT IT IN\r
+ MOVE B,5(TB) ; GET CHANNEL BACK\r
+ MOVSI 0,TUVEC ; SETUP A'S TYPE\r
+ MOVEM 0,ASTO(PVP)\r
+ PUSHJ P,DOIOTI ; IN COMES THE WHOLE BLOCK\r
+ SETZM ASTO(PVP) ; A NO LONGER SPECIAL\r
+ MOVEI C,BUFSTR-1(B) ; NO RESET BUFFER\r
+ PUSHJ P,BYTDOP ; A POINTS TO DOPW WORD\r
+ SUBI A,2\r
+ HRLI A,010700 ; SETUP BYTE POINTER TO END\r
+ HLLZS BUFSTR-1(B) ; ZERO CHAR COUNNT\r
+ MOVEM A,BUFSTR(B)\r
+ HRRZ A,4(TB) ; READ/READB FLG\r
+ MOVE C,(P) ; ACCESS IN WORDS\r
+ SKIPN A ; SKIP FOR ASCII\r
+ IMULI C,5 ; BUMP\r
+ MOVEM C,ACCESS(B) ; UPDATE ACCESS\r
+ PUSHJ P,NIREAD ; READ RSUBR VECTOR\r
+ JRST BRSUBR ; LOSER\r
+ GETYP A,A ; VERIFY A LITTLE\r
+ CAIE A,TVEC ; DONT SKIP IF BAD\r
+ JRST BRSUBR ; NOT A GOOD FILE\r
+ PUSHJ P,LSTCHR ; FLUSH REREAD CHAR\r
+ MOVE C,(TP) ; CODE VECTOR BACK\r
+ MOVSI A,TCODE\r
+ HLR A,B ; FUNNY COUNT\r
+ MOVEM A,(B) ; CLOBBER\r
+ MOVEM C,1(B)\r
+ PUSH TP,$TRSUBR ; MAKE RSUBR\r
+ PUSH TP,B\r
+\r
+; NOW LOOK OVER FIXUPS\r
+\r
+ MOVE B,5(TB) ; GET CHANNEL\r
+ MOVE C,ACCESS(B)\r
+ HLLZS ACCESS-1(B) ; FOR READB LOSER\r
+ HRRZ 0,4(TB) ; READ/READB FLG\r
+ JUMPN 0,RSUB1\r
+ ADDI C,4 ; ROUND UP\r
+ IDIVI C,5 ; TO WORDS\r
+ MOVEI D,(C) ; FIXUP ACCESS\r
+ IMULI D,5\r
+ MOVEM D,ACCESS(B) ; AND STORE\r
+RSUB1: ADDI C,1 ; ACCOUNT FOR EXTRA COUNTERS\r
+ MOVEM C,(P) ; SAVE FOR LATER\r
+ MOVEI A,-1(C) ; FOR DOACS\r
+ MOVEI C,2 ; UPDATE REAL ACCESS\r
+ SKIPN 0 ; SKIP FOR READB CASE\r
+ MOVEI C,10.\r
+ ADDM C,ACCESS(B)\r
+ PUSHJ P,DOACCS ; DO THE ACCESS\r
+ PUSH TP,$TUVEC ; SLOT FOR FIXUP BUFFER\r
+ PUSH TP,[0]\r
+\r
+; FOUND OUT IF FIXUPS STAY\r
+\r
+ MOVE B,MQUOTE KEEP-FIXUPS\r
+ PUSHJ P,ILVAL ; GET VALUE\r
+ GETYP 0,A\r
+ MOVE B,5(TB) ; CHANNEL BACK TO B\r
+ CAIE 0,TUNBOU\r
+ CAIN 0,TFALSE\r
+ JRST RSUB4 ; NO, NOT KEEPING FIXUPS\r
+ PUSH P,[0] ; SLOT TO READ INTO\r
+ HRROI A,(P) ; GET LENGTH OF SAME\r
+ PUSHJ P,DOIOTI\r
+ POP P,C\r
+ MOVEI A,(C) ; GET UVECTOR FOR KEEPING\r
+ ADDM C,(P) ; ACCESS TO END\r
+ PUSH P,C ; SAVE LENGTH OF FIXUPS\r
+ PUSHJ P,IBLOCK\r
+ MOVEM B,-6(TP) ; AND SAVE\r
+ MOVE A,B ; FOR IOTING THEM IN\r
+ ADD B,[1,,1] ; POINT PAST VERS #\r
+ MOVEM B,(TP)\r
+ MOVSI C,TUVEC\r
+ MOVEM C,ASTO(PVP)\r
+ MOVE B,5(TB) ; AND CHANNEL\r
+ PUSHJ P,DOIOTI ; GET THEM\r
+ SETZM ASTO(PVP)\r
+ MOVE A,(TP) ; GET VERS\r
+ PUSH P,-1(A) ; AND PUSH IT\r
+ JRST RSUB5\r
+\r
+RSUB4: PUSH P,[0]\r
+ PUSH P,[0] ; 2 SLOTS FOR READING\r
+ MOVEI A,-1(P)\r
+ HRLI A,-2\r
+ PUSHJ P,DOIOTI\r
+ MOVE C,-1(P)\r
+ MOVE D,(P)\r
+ ADDM C,-2(P) ; NOW -2(P) IS ACCESS TO END OF FIXUPS\r
+RSUB5: MOVEI C,BUFSTR-1(B) ; FIXUP BUFFER \r
+ PUSHJ P,BYTDOP\r
+ SUBI A,2 ; POINT BEFORE D.W.\r
+ HRLI A,10700\r
+ MOVEM A,BUFSTR(B)\r
+ HLLZS BUFSTR-1(B)\r
+ SKIPE -6(TP)\r
+ JRST RSUB2A\r
+ SUBI A,BUFLNT-1 ; ALSO MAKE AN IOT FLAVOR BUFFER\r
+ HRLI A,-BUFLNT\r
+ MOVEM A,(TP)\r
+ MOVSI C,TUVEC\r
+ MOVEM C,ASTO(PVP)\r
+ PUSHJ P,DOIOTI\r
+ SETZM ASTO(PVP)\r
+RSUB2A: PUSH P,-1(P) ; ANOTHER COPY OF LENGTH OF FIXUPS\r
+\r
+; LOOP FIXING UP NEW TYPES\r
+\r
+RSUB2: PUSHJ P,WRDIN ; SEE WHAT NEXT THING IS\r
+ JRST RSUB3 ; NO MORE, DONE\r
+ JUMPL E,STSQ ; MUST BE FIRST SQUOZE\r
+ MOVNI 0,(E) ; TO UPDATE AMNT OF FIXUPS\r
+ ADDB 0,(P)\r
+ HRLI E,(E) ; IS LENGTH OF STRING IN WORDS\r
+ ADD E,(TP) ; FIXUP BUFFER POINTER\r
+ JUMPL E,.+3\r
+ SUB E,[BUFLNT,,BUFLNT]\r
+ JUMPGE E,.-1 ; STILL NOT RIGHT\r
+ EXCH E,(TP) ; FIX UP SLOT\r
+ HLRE C,E ; FIX BYTE POINTER ALSO\r
+ IMUL C,[-5] ; + CHARS LEFT\r
+ MOVE B,5(TB) ; CHANNEL\r
+ PUSH TP,BUFSTR-1(B)\r
+ PUSH TP,BUFSTR(B)\r
+ HRRM C,BUFSTR-1(B)\r
+ HRLI E,440700 ; AND BYTE POINTER\r
+ MOVEM E,BUFSTR(B)\r
+ PUSHJ P,NIREAD ; READ ATOM NAME OF TYPE\r
+ TDZA 0,0 ; FLAG LOSSAGE\r
+ MOVEI 0,1 ; WINNAGE\r
+ MOVE C,5(TB) ; RESET BUFFER\r
+ POP TP,BUFSTR(C)\r
+ POP TP,BUFSTR-1(C)\r
+ JUMPE 0,BRSUBR ; BAD READ OF RSUBR\r
+ GETYP A,A ; A LITTLE CHECKING\r
+ CAIE A,TATOM\r
+ JRST BRSUBR\r
+ PUSHJ P,LSTCHR ; FLUSH REREAD CHAR\r
+ HRRZ 0,4(TB) ; FIXUP ACCESS PNTR\r
+ MOVE C,5(TB)\r
+ MOVE D,ACCESS(C)\r
+ HLLZS ACCESS-1(C) ; FOR READB HACKER\r
+ ADDI D,4\r
+ IDIVI D,5\r
+ IMULI D,5\r
+ SKIPN 0\r
+ MOVEM D,ACCESS(C) ; RESET\r
+TYFIXE: PUSHJ P,TYPFND ; SEE IF A LEGAL TYPE NAME\r
+ JRST TYPFIX ; GO SEE USER ABOUT THIS\r
+ PUSHJ P,FIXCOD ; GO FIX UP THE CODE\r
+ JRST RSUB2\r
+\r
+; NOW FIX UP SUBRS ETC. IF NECESSARY\r
+\r
+STSQ: MOVE B,MQUOTE MUDDLE\r
+ PUSHJ P,IGVAL ; GET CURRENT VERS\r
+ CAME B,-1(P) ; SKIP IF NO FIXUPS NEEDED\r
+ JRST DOFIX0 ; MUST DO THEM\r
+\r
+; ALL DONE, ACCESS PAST FIXUPS AND RETURN\r
+\r
+RSUB3: MOVE A,-3(P)\r
+ MOVE B,5(TB)\r
+ MOVEI C,(A) ; UPDATE CHANNEL ACCESS IN CASE SKIPPING\r
+ HRRZ 0,4(TB) ; READ/READB FLAG\r
+ SKIPN 0\r
+ IMULI C,5\r
+ MOVEM C,ACCESS(B) ; INTO ACCESS SLOT\r
+ HLLZS ACCESS-1(B)\r
+ PUSHJ P,DOACCS ; ACCESSED\r
+ MOVEI C,BUFSTR-1(B) ; FIX UP BUFFER\r
+ PUSHJ P,BYTDOP\r
+ SUBI A,2\r
+ HRLI A,10700\r
+ MOVEM A,BUFSTR(B)\r
+ HLLZS BUFSTR-1(B)\r
+ SKIPN A,-6(TP) ; SKIP IF KEEPING FIXUPS\r
+ JRST RSUB6\r
+ PUSH TP,$TUVEC\r
+ PUSH TP,A\r
+ MOVSI A,TRSUBR\r
+ MOVE B,-4(TP)\r
+ MOVSI C,TATOM\r
+ MOVE D,MQUOTE RSUBR\r
+ PUSHJ P,IPUT ; DO THE ASSOCIATION\r
+\r
+RSUB6: MOVE B,-2(TP) ; GET RSUBR\r
+ MOVSI A,TRSUBR\r
+ SUB P,[4,,4] ; FLUSH P CRUFT\r
+ SUB TP,[10,,10]\r
+ JRST RET\r
+\r
+; FIXUP SUBRS ETC.\r
+\r
+DOFIX0: SKIPN C,-6(TP) ; GET BUFFER IF KEEPING\r
+ JRST DOFIXE\r
+ MOVEM B,(C) ; CLOBBER\r
+ JRST DOFIXE\r
+\r
+FIXUPL: PUSHJ P,WRDIN\r
+ JRST RSUB3\r
+DOFIXE: JUMPGE E,BRSUBR\r
+ TLZ E,740000 ; KILL BITS\r
+ PUSHJ P,SQUTOA ; LOOK IT UP\r
+ JRST BRSUBR\r
+ MOVEI D,(E) ; FOR FIXCOD\r
+ PUSHJ P,FIXCOD ; FIX 'EM UP\r
+ JRST FIXUPL\r
+\r
+; ROUTINE TO FIXUP ACTUAL CODE\r
+\r
+FIXCOD: MOVEI E,0 ; FOR HWRDIN\r
+ PUSH P,D ; NEW VALUE\r
+ PUSHJ P,HWRDIN ; GET HW NEEDED\r
+ MOVE D,(P) ; GET NEW VAL\r
+ MOVE A,(TP) ; AND BUFFER POINTER\r
+ SKIPE -6(TP) ; SAVING?\r
+ HRLM D,-1(A) ; YES, CLOBBER\r
+ SUB C,(P) ; DIFFERENCE\r
+ MOVN D,C\r
+\r
+FIXLP: PUSHJ P,HWRDIN ; GET AN OFFSET\r
+ JUMPE C,FIXED\r
+ HRRES C ; MAKE NEG IF NEC\r
+ JUMPL C,LHFXUP\r
+ ADD C,-4(TP) ; POINT INTO CODE\r
+ ADDM D,-1(C)\r
+ JRST FIXLP\r
+\r
+LHFXUP: MOVMS C\r
+ ADD C,-4(TP)\r
+ MOVSI 0,(D)\r
+ ADDM 0,-1(C)\r
+ JRST FIXLP\r
+\r
+FIXED: SUB P,[1,,1]\r
+ POPJ P,\r
+\r
+; ROUTINE TO READ A WORD FROM BUFFER\r
+\r
+WRDIN: PUSH P,A\r
+ PUSH P,B\r
+ SOSG -3(P) ; COUNT IT DOWN\r
+ JRST WRDIN1\r
+ AOS -2(P) ; SKIP RETURN\r
+ MOVE B,5(TB) ; CHANNEL\r
+ HRRZ A,4(TB) ; READ/READB SW\r
+ MOVEI E,5\r
+ SKIPE A\r
+ MOVEI E,1\r
+ ADDM E,ACCESS(B)\r
+ MOVE A,(TP) ; BUFFER\r
+ MOVE E,(A)\r
+ AOBJP A,WRDIN2 ; NEED NEW BUFFER\r
+ MOVEM A,(TP)\r
+WRDIN1: POP P,B\r
+ POP P,A\r
+ POPJ P,\r
+\r
+WRDIN2: MOVE B,-3(P) ; IS THIS LAST WORD?\r
+ SOJLE B,WRDIN1 ; YES, DONT RE-IOT\r
+ SUB A,[BUFLNT,,BUFLNT]\r
+ MOVEM A,(TP)\r
+ MOVSI B,TUVEC\r
+ MOVEM B,ASTO(PVP)\r
+ MOVE B,5(TB)\r
+ PUSHJ P,DOIOTI\r
+ SETZM ASTO(PVP)\r
+ JRST WRDIN1\r
+\r
+; READ IN NEXT HALF WORD\r
+\r
+HWRDIN: JUMPN E,NOIOT ; USE EXISTING WORD\r
+ PUSH P,-3(P) ; FAKE OUT WRDIN IF NEC.\r
+ PUSHJ P,WRDIN\r
+ JRST BRSUBR\r
+ POP P,-4(P) ; RESET COUNTER\r
+ HLRZ C,E ; RET LH \r
+ POPJ P,\r
+\r
+NOIOT: HRRZ C,E\r
+ MOVEI E,0\r
+ POPJ P,\r
+\r
+TYPFIX: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE BAD-TYPE-NAME\r
+ PUSH TP,$TATOM\r
+ PUSH TP,B\r
+ PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE ERRET-TYPE-NAME-DESIRED\r
+ MCALL 3,ERROR\r
+ JRST TYFIXE\r
+\r
+BRSUBR: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE RSUBR-IN-BAD-FORMAT\r
+ JRST CALER1\r
+\f\r
+\r
+\r
+;TABLE OF BYTE POINTERS FOR GETTING CHARS\r
+\r
+BYTPNT": 350700,,CHTBL(A)\r
+ 260700,,CHTBL(A)\r
+ 170700,,CHTBL(A)\r
+ 100700,,CHTBL(A)\r
+ 010700,,CHTBL(A)\r
+\r
+;HERE ARE THE TABLES OF CHXRACTERS (NOTE EVERYTHING NOT SPECIFIED IS\r
+;IN THE NUMBER LETTER CATAGORY)\r
+\r
+SETCHR 2,[0123456789]\r
+\r
+SETCHR 3,[+-]\r
+\r
+SETCHR 4,[.]\r
+\r
+SETCHR 5,[Ee]\r
+\r
+SETCOD 6,[15,12,11,14,40,33] ;ALL ARE TYPE 2 (SPACING - FF,TAB,SPACE,ALT-MODE)\r
+\r
+INCRCH 7,[()[]'%"\#<>] ;GIVE THESE INCREASRNG CODES FROM 3\r
+\r
+SETCOD 22,[3] ;^C - EOF CHARACTER\r
+\r
+INCRCH 23,[;,{}!] ;COMMENT AND GLOBAL VALUE AND SPECIAL\r
+\r
+CHTBL:\r
+ OUTTBL ;OUTPUT THE TABLE RIGHT HERE\r
+\r
+\r
+\f; THIS CODE FLUSHES WANDERING COMMENTS\r
+\r
+COMNT: PUSHJ P,IREAD\r
+ JRST COMNT2\r
+ JRST BDLP\r
+\r
+COMNT2: SKIPL A,5(TB) ; RESTORE CHANNEL\r
+ MOVEI A,5(TB)-LSTCH ;NO CHANNEL, POINT AT SLOT\r
+ MOVEM B,LSTCH(A) ; CLOBBER IN CHAR\r
+ PUSHJ P,ERRPAR\r
+ JRST BDLP\r
+\f\r
+;SUBROUTINE TO READ CHARS ONTO STACK\r
+\r
+GOBBL1: MOVEI FF,0 ;KILL ALL FLAGS\r
+ PUSHJ P,LSTCHR ;DON'T REREAD "\r
+ TROA FF,NOTNUM+INSTRN ;SURPRESS NUMBER CONVERSION\r
+GOBBLE: MOVEI FF,0 ;FLAGS CONCERRNING CURRENT GOODIE IN HERE\r
+ MOVE A,TP ;GOBBLE CURRENT TP TO BE PUSHED\r
+ MOVEI C,6 ;NOW PUSH 6 0'S ON TO STACK\r
+ PUSH TP,$TFIX ;TYPE IS FIXED\r
+ PUSH TP,FF ;AND VALUE IS 0\r
+ SOJG C,.-2 ;FOUR OF THEM\r
+ PUSH TP,$TTP ;NOW SAVE OLD TP\r
+ ADD A,[1,,1] ;MAKE IT LOOK LIKE A TB\r
+ PUSH TP,A\r
+ MOVEI D,0 ;ZERO OUT CHARACTER COUNT\r
+GOB1: MOVSI C,(<440700,,(P)>) ;SET UP FIRST WORD OF CHARS\r
+ PUSH P,[0] ;BYTE POINTER\r
+GOB2: PUSH P,FF ;SAVE FLAG REGISTER\r
+ INTGO ; IN CASE P OVERFLOWS\r
+ MOVEI A,NXTCH\r
+ TRNE FF,INSTRN\r
+ MOVEI A,NXTCS ; HACK TO GET MAYBE NEW TYPE WITHOUT CHANGE\r
+ PUSHJ P,(A)\r
+ POP P,FF ;AND RESTORE FLAG REGISTER\r
+ CAIN B,ESCTYP ;IS IT A CHARACTER TO BE ESCAPED\r
+ JRST ESCHK ;GOBBLE THE ESCAPED CHARACTER\r
+ TRNE FF,INSTRN ;ARE WE BUILDING A CHAR STRING\r
+ JRST ADSTRN ;YES, GO READ IN\r
+ CAILE B,NONSPC ;IS IT SPECIAL\r
+ JRST DONEG ;YES, RAP THIS UP\r
+\r
+ TRNE FF,NOTNUM ;IS NUMERIC STILL WINNING\r
+ JRST SYMB2 ;NO, ONLY DO CHARACTER HACKING\r
+ CAIL A,60 ;CHECK FOR DIGIT\r
+ CAILE A,71\r
+ JRST SYMB1 ;NOT A DIGIT\r
+ JRST CNV ;GO CONVERT TO NUMBER\r
+\fCNV:\r
+\r
+;ARRIVE HERE IF STILL BUILDING A NUMBER\r
+CNV: MOVE B,(TP) ;GOBBLE POINTER TO TEMPS\r
+ TRO FF,NUMWIN ;SAY DIGITSSEEN\r
+ SUBI A,60 ;CONVERT TO A NUMBER\r
+ TRNE FF,EFLG ;HAS E BEEN SEEN\r
+ JRST ECNV ;YES, CONVERT EXPONENT\r
+ TRNE FF,DOTSEN ;HAS A DOT BEEN SEEN\r
+\r
+ JRST DECNV ;YES, THIS IS A FLOATING NUMBER\r
+\r
+ MOVE E,ONUM(B) ; OCTAL CONVERT\r
+ LSH E,3\r
+ ADDI E,(A)\r
+ MOVEM E,ONUM(B)\r
+ TRNE FF,OCTSTR ; SKIP OTHER CONVERSIONS IF OCTAL FORCE\r
+ JRST CNV1\r
+\r
+ JFCL 17,.+1 ;KILL ALL FLAGS\r
+ MOVE E,CNUM(B) ;COMPUTE CURRENT RADIX\r
+ IMUL E,3(TB)\r
+ ADD E,A ;ADD IN CURRENT DIGIT\r
+ JFCL 10,.+2\r
+ MOVEM E,CNUM(B) ;AND SAVE IT\r
+\r
+\r
+\r
+;INSERT OCTAL AND CRADIX CROCK HERE IF NECESSSARY\r
+ JRST DECNV1 ;CONVERT TO DECIMAL(FIXED)\r
+\r
+\r
+DECNV: TRO FF,FLONUM ;SET FLOATING FLAG\r
+DECNV1: JFCL 17,.+1 ;CLEAR ALL FLAGS\r
+ MOVE E,DNUM(B) ;GET DECIMAL NUMBER\r
+ IMULI E,10.\r
+ JFCL 10,CNV2 ;JUMP IF OVERFLOW\r
+ ADD E,A ;ADD IN DIGIT\r
+ MOVEM E,DNUM(B)\r
+ TRNE FF,FLONUM ;IS THIS FRACTION?\r
+ SOS NDIGS(B) ;YES, DECREASE EXPONENT BY ONE\r
+\r
+CNV1: PUSHJ P,NXTCH ;RE-GOBBLE CHARACTER\r
+ JRST SYMB2 ;ALSO DEPOSIT INTO SYMBOL BEING MADE\r
+CNV2: ;OVERFLOW IN DECIMAL NUMBER\r
+ TRNE FF,DOTSEN ;IS THIS FRACTION PART?\r
+ JRST CNV1 ;YES,IGNORE DIGIT\r
+ AOS NDIGS(B) ;NO, INCREASE IMPLICIT EXPONENT BY ONE\r
+ TRO FF,FLONUM ;SET FLOATING FLAG BUT \r
+ JRST CNV1 ;DO NOT FORCE DECIMAL(DECFRC)\r
+\r
+ECNV: ;CONVERT A DECIMAL EXPONENT\r
+ HRRZ E,ENUM(B) ;GET EXPONENT\r
+ IMULI E,10.\r
+ ADD E,A ;ADD IN DIGIT\r
+ TLNN E,777777 ;IF OVERFLOW INTO LEFT HALF\r
+ HRRM E,ENUM(B) ;DO NOT STORE(CATCH ERROR LATER)\r
+ JRST CNV1\r
+ JRST SYMB2 ;ALSO DEPOSIT INTO SYMBOL BEING MADE\r
+\r
+\f\r
+;HERE TO PUT INTO IDENTIFIER BEING BUILT\r
+\r
+ESCHK: PUSHJ P,NXTC1 ;GOBBLE NEXT CHAR\r
+SYMB: MOVE B,(TP) ;GET BACK TEM POINTER\r
+ TRNE FF,EFLG ;IF E FLAG SET\r
+ HLRZ FF,ENUM(B) ;RESTORE SAVED FLAGS\r
+ TRO FF,NOTNUM ;SET NOT NUMBER FLAG\r
+SYMB2: TRO FF,NFIRST ;NOT FIRST IN WORLD\r
+SYMB3: IDPB A,C ;INSERT IT\r
+ PUSHJ P,LSTCHR ;READ NEW CHARACTER\r
+ TLNE C,760000 ;WORD FULL?\r
+ AOJA D,GOB2 ;NO, KEEP TRYING\r
+ AOJA D,GOB1 ;COUNT WORD AND GO\r
+\r
+;HERE TO CHECK FOR +,-,. IN NUMBER\r
+\r
+SYMB1: TRNE FF,NFIRST ;IS THIS THE FIRST CHARACTER\r
+ JRST CHECK. ;NO, ONLY LOOK AT DOT\r
+ CAIE A,"- ;IS IT MINUS\r
+ JRST .+3 ;NO CHECK PLUS\r
+ TRO FF,NEGF ;YES, NEGATE AT THE END\r
+ JRST SYMB2\r
+ CAIN A,"+ ;IS IT +\r
+ JRST SYMB2 ;ESSENTIALLY IGNORE IT\r
+ CAIE A,"* ; FUNNY OCTAL CROCK?\r
+ JRST CHECK.\r
+\r
+ TRO FF,OCTSTR\r
+ JRST SYMB2\r
+\r
+;COULD BE .\r
+\r
+CHECK.: PUSHJ P,LSTCHR ;FLUSH LAST CHARACTER\r
+ MOVEI E,0\r
+ TRNN FF,DOTSEN+EFLG ;IF ONE ALREADY SEEN\r
+ CAIE A,".\r
+ JRST CHECKE ;GO LOOK FOR E\r
+\r
+IFN FRMSIN,[\r
+ TRNN FF,NFIRST ;IS IT THE FIRST\r
+ JRST DOT1 ;YES, COULD MEAN EVALUATE A VARIABLE\r
+]\r
+\r
+CHCK.1: TRO FF,DECFRC+DOTSEN ;FORCE DECIMAL \r
+IFN FRMSIN, TRNN FF,FRSDOT ;IF NOT FIRST ., PUT IN CHAR STRING\r
+ JRST SYMB2 ;ENTER INTO SYMBOL\r
+IFN FRMSIN, JRST GOB2 ;IGNORE THE "."\r
+\f\r
+\r
+\r
+IFN FRMSIN,[\r
+\r
+;HERE TO SET UP FOR .FOO ..FOO OR.<ABC>\r
+\r
+DOT1: PUSH P,FF ;SAVE FLAGS\r
+ PUSHJ P,NXTCH1 ;GOBBLE A NEW CHARACTER\r
+ POP P,FF ;RESTORE FLAGS\r
+ TRO FF,FRSDOT ;SET FLAG IN CASE\r
+ CAIN B,NUMCOD ;SKIP IF NOT NUMERIC\r
+ JRST CHCK.1 ;NUMERIC, COULD BE FLONUM\r
+\r
+; CODE TO HANDLE ALL IMPLICIT CALLS I.E. QUOTE, LVAL, GVAL\r
+\r
+ MOVSI B,TFORM ;LVAL\r
+ MOVE A,MQUOTE LVAL\r
+ SUB P,[2,,2] ;POP OFF BYTE POINTER AND GOBBLE CALL\r
+ POP TP,TP\r
+ SUB TP,[1,,1] ;REMOVE TP JUNK\r
+ JRST IMPCA1\r
+\r
+GLOSEG: SKIPA B,$TSEG ;SEG CALL TO GVAL\r
+GLOVAL: MOVSI B,TFORM ;FORM CALL TO SAME\r
+ MOVE A,MQUOTE GVAL\r
+ JRST IMPCAL\r
+\r
+QUOSEG: SKIPA B,$TSEG ;SEG CALL TO QUOTE\r
+QUOTIT: MOVSI B,TFORM\r
+ MOVE A,MQUOTE QUOTE\r
+ JRST IMPCAL\r
+\r
+SEGDOT: MOVSI B,TSEG ;SEG CALL TO LVAL\r
+ MOVE A,MQUOTE LVAL\r
+IMPCAL: PUSHJ P,LSTCHR ;FLUSH LAST CHAR EXCEPT\r
+IMPCA1: PUSH TP,$TATOM ;FOR .FOO FLAVOR\r
+ PUSH TP,A ;PUSH ARGS\r
+ PUSH P,B ;SAVE TYPE\r
+ PUSHJ P,IREAD1 ;READ\r
+ JRST USENIL ; IF NO ARG, USE NIL\r
+IMPCA2: PUSH TP,C\r
+ PUSH TP,D\r
+ MOVE C,A ; GET READ THING\r
+ MOVE D,B\r
+ PUSHJ P,INCONS ; CONS TO NIL\r
+ MOVEI E,(B) ; PREPARE TON CONS ON\r
+POPARE: POP TP,D ; GET ATOM BACK\r
+ POP TP,C\r
+ EXCH C,-1(TP) ; SAVE THAT COMMENT\r
+ EXCH D,(TP)\r
+ PUSHJ P,ICONS\r
+ POP P,A ;GET FINAL TYPE\r
+ JRST RET13 ;AND RETURN\r
+\r
+\r
+USENIL: PUSH TP,C\r
+ PUSH TP,D\r
+ SKIPL A,5(TB) ; RESTOR LAST CHR\r
+ MOVEI A,5(TB)-LSTCH ;NO CHANNEL, POINT AT SLOT\r
+ MOVEM B,LSTCH(A)\r
+ MOVEI E,0\r
+ JRST POPARE\r
+\f\r
+;HERE AFTER READING ATOM TO CALL VALUE\r
+\r
+.SET: SUB P,[1,,1] ;FLUSH GOBBLE CALL\r
+ PUSH P,$TFORM ;GET WINNING TYPE\r
+ MOVE E,(P)\r
+ PUSHJ P,RETC ; CHECK FOR POSSIBLE COMMENT\r
+ PUSH TP,$TATOM\r
+ PUSH TP,MQUOTE LVAL\r
+ JRST IMPCA2 ;GO CONS LIST\r
+\r
+]\r
+\r
+;HERE TO CHECK FOR "E" FLAVOR OF EXPONENT\r
+\r
+CHECKE: CAIN A,"* ; CHECK FOR FINAL *\r
+ JRST SYMB4\r
+ TRNN FF,EFLG ;HAS ONE BEEN SEEN\r
+ CAIE B,NONSPC ;IF NOT, IS THIS ONE\r
+ JRST SYMB ;NO, ENTER AS SYMBOL KILL NUMERIC WIN\r
+\r
+ TRNN FF,NUMWIN ;HAVE DIGITS BEEN SEEN?\r
+ JRST SYMB ;NO, NOT A NUMBER\r
+ MOVE B,(TP) ;GET POINTER TO TEMPS\r
+ HRLM FF,ENUM(B) ;SAVE FLAGS\r
+ HRRI FF,DECFRC+DOTSEN+EFLG ;SET NEW FLAGS\r
+ JRST SYMB3 ;ENTER SYMBOL\r
+\r
+\r
+SYMB4: TRZN FF,OCTSTR\r
+ JRST SYMB\r
+ TRZN FF,OCTWIN ; ALREADY WON?\r
+ TROA FF,OCTWIN ; IF NOT DO IT NOW\r
+ JRST SYMB\r
+ JRST SYMB2\r
+\r
+;HERE ON READING CHARACTER STRING\r
+\r
+ADSTRN: SKIPL A ; EOF?\r
+ CAIN B,MANYT ;TERMINATE?\r
+ JRST DONEG ;YES\r
+ CAIE B,CSTYP\r
+ JRST SYMB2 ;NO JUST INSERT IT\r
+ADSTN1: PUSHJ P,LSTCHR ;DON'T REREAD """\r
+\r
+\f\r
+;HERE TO FINISH THIS CROCK\r
+\r
+DONEG: TRNN FF,OCTSTR ; IF START OCTAL BUT NOT FINISH..\r
+ TRNN FF,NUMWIN ;HAVE DIGITS BEEN SEEN?\r
+ TRO FF,NOTNUM ;NO,SET NOT NUMBER FLAG\r
+ SKIPGE C ; SKIP IF STUFF IN TOP WORD\r
+ SUB P,[1,,1]\r
+ PUSH P,D\r
+ TRNN FF,NOTNUM ;NUMERIC?\r
+ JRST NUMHAK ;IS NUMERIC, GO TO IT\r
+\r
+IFN FRMSIN,[\r
+ MOVE A,(TP) ;GET POINTER TO TEMPS\r
+ MOVEM FF,NDIGS(A) ;USE TO HOLD FLAGS\r
+]\r
+ TRNE FF,INSTRN ;ARE WE BUILDING A STRING\r
+ JRST MAKSTR ;YES, GO COMPLETE SAME\r
+LOOPAT: PUSHJ P,NXTCH ; CHECK FOR TRAILER\r
+ CAIN B,PATHTY ; PATH BEGINNER\r
+ JRST PATH0 ; YES, GO PROCESS\r
+ CAIN B,SPATYP ; SPACER?\r
+ PUSHJ P,SPACEQ ; CHECK FOR REAL SPACE\r
+ JRST PATH2\r
+ PUSHJ P,LSTCHR ; FLUSH IT AND RETRY\r
+ JRST LOOPAT\r
+PATH0: PUSHJ P,NXTCH1 ; READ FORCED NEXT\r
+ CAIE B,SPCTYP ; DO #FALSE () HACK\r
+ CAIN B,ESCTYP\r
+ JRST PATH4\r
+ CAIL B,SPATYP ; SPACER?\r
+ JRST PATH3 ; YES, USE THE ROOT OBLIST\r
+PATH4: PUSHJ P,NIREA1 ; READ NEXT ITEM\r
+ PUSHJ P,ERRPAR ; LOSER\r
+ CAME A,$TATOM ; ONLY ALLOW ATOMS\r
+ JRST BADPAT\r
+\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ PUSH TP,$TATOM\r
+ PUSH TP,IMQUOTE OBLIST\r
+ MCALL 2,GET ; GET THE OBLIST\r
+ CAMN A,$TOBLS ; IF NOT OBLIST, MAKE ONE\r
+ JRST PATH6\r
+ MCALL 1,MOBLIS ; MAKE ONE\r
+ JRST PATH1\r
+\r
+PATH6: SUB TP,[2,,2]\r
+ JRST PATH1\r
+\r
+\r
+PATH3: MOVE B,ROOT+1(TVP) ; GET ROOT OBLIST\r
+ MOVSI A,TOBLS\r
+PATH1: PUSHJ P,RLOOKU ; AND LOOK IT UP\r
+\r
+IFN FRMSIN,[\r
+ MOVE C,(TP) ;SET TO REGOBBLE FLAGS\r
+ MOVE FF,NDIGS(C)\r
+]\r
+ JRST FINID\r
+\r
+\r
+SPACEQ: ANDI A,-1\r
+ CAIE A,33\r
+ CAIN A,400033\r
+ POPJ P,\r
+ CAIE A,3\r
+ AOS (P)\r
+ POPJ P,\r
+\f\r
+;HERE TO RAP UP CHAR STRING ITEM\r
+\r
+MAKSTR: MOVE C,D ;SETUP TO CALL CHMAK\r
+ PUSHJ P,CHMAK ;GO MAKE SAME\r
+ JRST FINID\r
+\r
+\r
+NUMHAK: MOVE C,(TP) ;REGOBBLETEMP POINTER\r
+ POP P,D ;POP OFF STACK TOP\r
+ ADDI D,4\r
+ IDIVI D,5\r
+ HRLI D,(D) ;TOO BOTH HALVES\r
+ SUB P,D ;REMOVE CHAR STRING\r
+ TRNE FF,FLONUM+EFLG ;IS IT A FLOATING POINT NUMBER\r
+ JRST FLOATIT ;YES, GO MAKE IT WIN\r
+ MOVE B,CNUM(C)\r
+ TRNE FF,DECFRC\r
+ MOVE B,DNUM(C) ;GRAB FIXED GOODIE\r
+ TRNE FF,OCTWIN ; SKIP IF NOT OCTAL\r
+ MOVE B,ONUM(C) ; USE OCTAL VALUE\r
+\r
+FINID2: MOVSI A,TFIX ;SAY FIXED POINT\r
+FINID1: TRNE FF,NEGF ;NEGATE\r
+ MOVNS B ;YES\r
+FINID: POP TP,TP ;RESTORE OLD TP\r
+ SUB TP,[1,,1] ;FINISH HACK\r
+IFN FRMSIN,[\r
+ TRNE FF,FRSDOT ;DID . START IT\r
+ JRST .SET ;YES, GO HACK\r
+]\r
+ POPJ P, ;AND RETURN\r
+\r
+\r
+\r
+\r
+PATH2: MOVE B,IMQUOTE OBLIST\r
+ PUSHJ P,IDVAL\r
+ JRST PATH1\r
+\r
+BADPAT: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE NON-ATOMIC-OBLIST-NAME\r
+ JRST CALER1\r
+\r
+\f\r
+FLOATIT:\r
+ JFCL 17,.+1 ;CLEAR ALL ARITHMETIC FLAGS\r
+\r
+ TRNE FF,EFLG ;"E" SEEN?\r
+ JRST EXPDO ;YES, DO EXPONENT\r
+ MOVE D,NDIGS(C) ;GET IMPLICIT EXPONENT\r
+\r
+FLOATE: MOVE A,DNUM(C) ;GET DECIMAL NUMBER\r
+ IDIVI A,400000 ;SPLIT\r
+ FSC A,254 ;CONVERT MOST SIGNIFICANT\r
+ FSC B,233 ; AND LEAST SIGNIFICANT\r
+ FADR B,A ;COMBINE\r
+\r
+ MOVM A,D ;GET MAGNITUDE OF EXPONENT \r
+ CAILE A,37. ;HOW BIG?\r
+ JRST FOOR ;TOO BIG-FLOATING OUT OF RANGE\r
+ JUMPGE D,FLOAT1 ;JUMP IF EXPONENT POSITIVE\r
+ FDVR B,TENTAB(A) ;DIVIDE BY TEN TO THE EXPONENT\r
+ JRST SETFLO\r
+\r
+FLOAT1: FMPR B,TENTAB(A) ;SCALE UP\r
+\r
+SETFLO: JFCL 10,FOOR ;FLOATING OUT OF RANGE ON OVERFLOW\r
+ MOVSI A,TFLOAT\r
+IFN FRMSIN, TRZ FF,FRSDOT ;FLOATING NUMBER NOT VALUE\r
+ JRST FINID1\r
+\r
+EXPDO:\r
+ HRRZ D,ENUM(C) ;GET EXPONENT\r
+ TRNE FF,NEGF ;IS EXPONENT NEGATIVE?\r
+ MOVNS D ;YES\r
+ ADD D,NDIGS(C) ;ADD IMPLICIT EXPONENT\r
+ HLR FF,ENUM(C) ;RESTORE FLAGS\r
+ JUMPL D,FLOATE ;FLOATING IF EXPONENT NEGATIVE\r
+ CAIG D,10. ;OR IF EXPONENT TOO LARGE\r
+ TRNE FF,FLONUM ;OR IF FLAG SET\r
+ JRST FLOATE\r
+ MOVE B,DNUM(C) ;\r
+ IMUL B,ITENTB(D) \r
+ JFCL 10,FLOATE ;IF OVERFLOW, MAKE FLOATING\r
+ JRST FINID2 ;GO MAKE FIXED NUMBER\r
+\f\r
+; HERE TO READ ONE CHARACTER FOR USER.\r
+\r
+CREDC1: SUBM M,(P)\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ PUSHJ P,IREADC\r
+ JFCL\r
+ JRST MPOPJ\r
+\r
+CNXTC1: SUBM M,(P)\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ PUSHJ P,INXTRD\r
+ JFCL\r
+ JRST MPOPJ\r
+\r
+CREADC: SUBM M,(P)\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ PUSHJ P,IREADC\r
+ JRST RMPOPJ\r
+ SOS (P)\r
+ JRST RMPOPJ\r
+\r
+CNXTCH: SUBM M,(P)\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ PUSHJ P,INXTRD\r
+ JRST RMPOPJ\r
+ SOS (P)\r
+RMPOPJ: SUB TP,[2,,2]\r
+ JRST MPOPJ\r
+\r
+INXTRD: TDZA E,E\r
+IREADC: MOVEI E,1\r
+ MOVE B,(TP) ; CHANNEL\r
+ HRRZ A,-4(B) ; GET BLESS BITS\r
+ TRNE A,C.BIN\r
+ TRNE A,C.BUF\r
+ JRST .+3\r
+ PUSHJ P,GRB\r
+ HRRZ A,-4(B)\r
+ TRC A,C.OPN+C.READ\r
+ TRNE A,C.OPN+C.READ\r
+ JRST BADCHN\r
+ SKIPN A,LSTCH(B)\r
+ PUSHJ P,RXCT\r
+ MOVEM A,LSTCH(B) ; SAVE CHAR\r
+ CAMN A,[-1] ; SPECIAL PSEUDO TTY HACK?\r
+ JRST PSEUDO ; YES, RET AS FIX\r
+ TRZN A,400000 ; UNDO ! HACK\r
+ JRST NOEXCL\r
+ SKIPE E\r
+ MOVEM A,LSTCH(B)\r
+ MOVEI A,"! ; RETURN AN !\r
+NOEXC1: SKIPGE B,A ; CHECK EOF\r
+ SOS (P) ; DO EOF RETURN\r
+ MOVE B,A ; CHAR TO B\r
+ MOVSI A,TCHRS\r
+PSEUD1: AOS (P)\r
+ POPJ P,\r
+\r
+PSEUDO: SKIPE E\r
+ PUSHJ P,LSTCH2\r
+ MOVE B,A\r
+ MOVSI A,TFIX\r
+ JRST PSEUD1\r
+\r
+NOEXCL: SKIPE E\r
+ PUSHJ P,LSTCH2\r
+ JRST NOEXC1\r
+\r
+; READER ERRORS COME HERE\r
+\r
+ERRPAR: PUSH TP,$TCHRS ;DO THE OFFENDER\r
+ PUSH TP,B\r
+ PUSH TP,$TCHRS\r
+ PUSH TP,[40] ;SPACE\r
+ PUSH TP,$TCHSTR\r
+ PUSH TP,CHQUOT UNEXPECTED\r
+ JRST MISMA1\r
+\r
+;COMPLAIN ABOUT MISMATCHED CLOSINGS\r
+\r
+MISMAB: SKIPA A,["]]\r
+MISMAT: MOVE A,-1(P) ;GOBBLE THE DESIRED CHARACTER\r
+ JUMPE B,CPOPJ ;IGNORE UNIVERSAL CLOSE\r
+ PUSH TP,$TCHRS\r
+ PUSH TP,B\r
+ PUSH TP,$TCHSTR\r
+ PUSH TP,CHQUOT [ INSTEAD-OF ]\r
+ PUSH TP,$TCHRS\r
+ PUSH TP,A\r
+MISMA1: MCALL 3,STRING\r
+ PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE READER-SYNTAX-ERROR-ERRET-ANYTHING-TO-GO-ON\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ PUSH TP,$TATOM\r
+ PUSH TP,MQUOTE READ\r
+ MCALL 3,ERROR\r
+CPOPJ: POPJ P,\r
+\f\r
+; HERE ON BAD INPUT CHARACTER\r
+\r
+BADCHR: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE BAD-ASCII-CHARACTER\r
+ JRST CALER1\r
+\r
+; HERE ON YUCKY PARSE TABLE\r
+\r
+BADPTB: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE BAD-MACRO-TABLE\r
+ JRST CALER1\r
+\r
+BDPSTR: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE BAD-PARSE-STRING\r
+ JRST CALER1\r
+\r
+ILLSQG: PUSHJ P,LSTCHR ; DON'T MESS WITH IT AGAIN\r
+ PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE BAD-USE-OF-SQUIGGLY-BRACKETS\r
+ JRST CALER1\r
+\r
+\r
+;FLOATING POINT NUMBER TOO LARGE OR SMALL\r
+FOOR: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE NUMBER-OUT-OF-RANGE\r
+ JRST CALER1\r
+\r
+\r
+NILSXP: 0,,0\r
+\r
+LSTCHR: PUSH P,B\r
+ SKIPL B,5(TB) ;GET CHANNEL\r
+ JRST LSTCH1 ;NO CHANNEL, POINT AT SLOT\r
+ PUSHJ P,LSTCH2\r
+ POP P,B\r
+ POPJ P,\r
+\r
+LSTCH2: SKIPE LSTCH(B) ;ARE WE REALLY FLUSHING A REUSE CHARACTER ?\r
+ PUSHJ P,CNTACC\r
+ SETZM LSTCH(B)\r
+ POPJ P,\r
+\r
+LSTCH1: SETZM 5(TB) ;ZERO THE LETTER AND RETURN\r
+ POP P,B\r
+ POPJ P,\r
+\r
+CNTACC: PUSH P,A\r
+ HRRZ A,-4(B) ; GET BITS\r
+ TRNE A,C.BIN\r
+ JRST CNTBIN\r
+ AOS ACCESS(B)\r
+CNTDON: POP P,A\r
+ POPJ P,\r
+\r
+CNTBIN: AOS A,ACCESS-1(B)\r
+ CAMN A,[TFIX,,1]\r
+ AOS ACCESS(B)\r
+ CAMN A,[TFIX,,5]\r
+ HLLZS ACCESS-1(B)\r
+ JRST CNTDON\r
+\r
+\r
+;TABLE OF NAMES OF ARGS AND ALLOWED TYPES\r
+\r
+ARGS:\r
+ IRP A,,[[[CAIN C,TUNBOU]],[[CAIE C,TCHAN],INCHAN],[[PUSHJ P,CHOBL],OBLIST]]\r
+ IRP B,C,[A]\r
+ B\r
+ IFSN [C],IMQUOTE C\r
+ .ISTOP\r
+ TERMIN\r
+ TERMIN\r
+\r
+CHOBL: CAIE C,TLIST ;A LIST OR AN OBLIST\r
+ CAIN C,TOBLS\r
+ AOS (P)\r
+ POPJ P,\r
+\r
+END\r
+\r
+\fTITLE SAVE AND RESTORE STATE OF A MUDDLE\r
+\r
+RELOCATABLE\r
+\r
+.INSRT DSK:MUDDLE >\r
+\r
+SYSQ\r
+\r
+IFE ITS,[\r
+IF1,[\r
+.INSRT STENEX >\r
+EXPUNGE SAVE\r
+]\r
+]\r
+\r
+.GLOBAL MOPEN,MIOT,MCLOSE,MUDSTR,SWAP,STRTO6,GCPDL,RGPRS\r
+.GLOBAL CHNL0,CHNL1,REOPN,AGC,SWAPIN,MASK1,MASK2,IPCBLS\r
+.GLOBAL P.CORE,P.TOP,SGSNAM,%RUNAM,%RJNAM,INTINT,CLOSAL,TTYOPE\r
+.GLOBAL NOTTY,PURCLN,6TOCHS,DISXTR,IDVAL1,N.CHNS\r
+\r
+MFUNCTION FSAVE,SUBR\r
+\r
+ ENTRY\r
+\r
+ PUSH P,. ; SAY WE ARE FAST SAVER\r
+ JRST SAVE1\r
+\r
+MFUNCTION SAVE,SUBR\r
+\r
+ ENTRY\r
+\r
+ PUSH P,[0] ; SAY WE ARE OLD SLOW SAVE\r
+SAVE1: SKIPG MUDSTR+2 ; DON'T SAVE FROM EXPERIMENTAL MUDDLE\r
+ JRST EXPVRS\r
+ PUSH P,[0] ; GC OR NOT?\r
+IFE ITS,[\r
+ MOVE B,[400600,,]\r
+ MOVE C,[440000,,100000]\r
+]\r
+ PUSHJ P,GTFNM ; GET THE FILE NAME ONTO P\r
+ JRST .+2\r
+ JRST SAVEON\r
+ JUMPGE AB,TMA ; TOO MUCH STRING\r
+ GETYP 0,(AB) ; WHAT IS ARG\r
+ CAMGE AB,[-3,,0] ; NOT TOO MANY\r
+ JRST TMA\r
+ CAIN 0,TFALSE\r
+IFN ITS, SETOM -4(P) ; GC FLAG\r
+IFE ITS, SETOM (P)\r
+SAVEON:\r
+IFN ITS,[\r
+ MOVSI A,7 ; IMAGE BLOCK OUT\r
+ HRR A,-2(P) ; DEVICE\r
+ PUSH P,A\r
+ PUSH P,[SIXBIT /_MUDS_/]\r
+ PUSH P,[SIXBIT />/]\r
+ MOVEI A,-2(P) ; POINT TO BLOCK\r
+ PUSHJ P,MOPEN ; ATTEMPT TO OPEN\r
+ JRST CANTOP\r
+ SUB P,[3,,3] ; FLUSH OPEN BLOCK\r
+ PUSH P,-4(P) ; GC FLAG TO TOP OF STACK\r
+]\r
+ EXCH A,(P) ; CHAN TO STACK GC TO A\r
+ JUMPL A,.+2\r
+ MCALL 0,GC\r
+\r
+; NOW GET VERSION OF MUDDLE FOR COMPARISON\r
+\r
+ MOVE A,MUDSTR+2 ; GET #\r
+ MOVEI B,177 ; CHANGE ALL RUBOUT CHARACTERS\r
+ MOVEI C,40 ; ----- TO SPACES\r
+ PUSHJ P,HACKV\r
+\r
+ PUSHJ P,WRDOUT\r
+ MOVEI A,0 ; WRITE ZERO IF FAST\r
+IFN ITS, SKIPE -6(P)\r
+IFE ITS, SKIPE -1(P)\r
+ PUSHJ P,WRDOUT\r
+ MOVE A,VECTOP ; CORE REQUIREMENTS FOR THIS SAVED MUDDLE\r
+ PUSHJ P,WRDOUT\r
+\r
+IFN ITS,[\r
+ SETZB A,B ; FIRST, ALL INTS OFF\r
+ .SETM2 A,\r
+ SKIPE DISXTR ; IF HAVE DISPLAY, CLOSE IT\r
+ .DSTOP ; STOP THE E&S IF RUNNING\r
+\r
+; IF FAST SAVE JUMP OFF HERE\r
+\r
+ SKIPE -6(P)\r
+ JRST FSAVE1\r
+\r
+; NOW DUMP OUT GC SPACE\r
+ MOVEI A,E+1 ; ADDRESS OF FIRST NON-SCRATCH WORD\r
+ POP P,0 ; CHAN TO 0\r
+ LSH 0,23. ; POSITION\r
+ IOR 0,[.IOT A]\r
+]\r
+\r
+IFE ITS,[\r
+ MOVEI A,400000 ; FOR THIS PROCESS\r
+ DIR ; TURN OFF INT SYSTEM\r
+\r
+; IF FAST, LEAVE HERE\r
+\r
+ SKIPE -1(P)\r
+ JRST FSAVE1\r
+\r
+; NOW DUMP OUT GC SPACE\r
+ POP P,0 ; RESTORE JFN\r
+ MOVE A,[-<P-E>,,E] ; NUMBER OF ACS TO GO\r
+ PUSH P,(A)\r
+ AOBJN A,.-1\r
+ MOVE A,0\r
+ MOVE B,P\r
+ BOUT\r
+ MOVEI A,20 ; START AT LOCN 20\r
+]\r
+DMPLP1: MOVEI B,(A) ; POINT TO START OF STUFF\r
+ SUB B,VECTOP ; GET BLOCK LENGTH\r
+ MOVSI B,(B)\r
+ HRRI B,(A) ; HAVE IOT POINTER\r
+ SKIPL B ; SKIP IF OK AOBJN POINTER\r
+ HRLI B,400000 ; OTHER WISE AS MUCH AS POSSIBLE\r
+\r
+; MAIN NON-ZERO DUMPING LOOP\r
+\r
+DMPLP: SKIPN C,(B) ; FIND FIRST NON-ZERO\r
+ AOBJN B,.-1\r
+ JUMPGE B,DMPDON ; NO MORE TO SCAN\r
+\r
+DMP4: MOVEI E,(B) ; FOUND ONE, SAVE POINTER TO IT\r
+DMP3: MOVSI D,-5 ; DUPLICATE COUNTER SETUP\r
+\r
+DMP1: CAMN C,(B) ; IS NEXT SAME AS THIS?\r
+ JRST CNTDUP ; COUNT DUPS\r
+ MOVSI D,-5 ; RESET COUNTER\r
+ SKIPE C,(B) ; SEARCH FOR ZERO\r
+DMP5: AOBJN B,DMP1 ; COUNT AND GO\r
+ JUMPGE B,DMP2 ; JUMP IF BLOCK FINISHED\r
+\r
+ AOBJP B,DMP2 ; CHECK FOR LONE ZERO\r
+ SKIPE C,(B)\r
+ JRST DMP1 ; LONE ZERO, DONT END BLOCK\r
+\r
+DMP2: MOVEI D,(E) ; START COMPUTING OUTPUT IOT\r
+ SUBI D,(B) ; D=> -LNTH OF BLOCK\r
+ HRLI E,(D) ; E=> AOBJN PNTR TO OUTPUT\r
+IFN ITS,[\r
+ HRROI A,E ; MAKE AN IOT POINTER TO IT\r
+ XCT 0 ; WRITE IT\r
+ MOVE A,E ; NOW FOR THE BLOCK\r
+ XCT 0 ; ZAP!, OUT IT GOES\r
+]\r
+IFE ITS,[\r
+ EXCH E,B ; AOBJN TO B\r
+ MOVE A,0 ; JFN TO A\r
+ BOUT ; WRITE IT\r
+ MOVE D,B ; SAVE POINTER\r
+ HRLI B,444400 ; BYTPE POINTER\r
+ HLRE C,D ; # OF BYTES\r
+ SOUT\r
+]\r
+; NOW COMPUTE A CKS\r
+\r
+IFN ITS,[\r
+ MOVE D,E ; FIRST WORD OF CKS\r
+ ROT E,1\r
+ ADD E,(D)\r
+ AOBJN D,.-2 ; COMP CKS\r
+ HRROI A,E\r
+ XCT 0 ; WRITE OUT THE CKS\r
+]\r
+IFE ITS,[\r
+ MOVE B,D\r
+ ROT B,1\r
+ ADD B,(D)\r
+ AOBJN D,.-2\r
+ BOUT\r
+ MOVE B,E ; MAIN POINTER BACK\r
+]\r
+\r
+DMP7: JUMPL B,DMPLP ; MORE TO DO?\r
+DMPDON: SUB B,VECTOP ; DONE?\r
+ JUMPGE B,DMPDN1 ; YES, LEAVE\r
+IFN ITS, MOVEI A,400000+PVP ; POINT TO NEXT WORD TO GO\r
+IFE ITS, MOVEI A,400020\r
+ JRST DMPLP1\r
+IFN ITS,[\r
+DMPDN1: HRROI A,[-1]\r
+ XCT 0 ; EOF\r
+DMPDN2: SETZB A,B ; SET UP RENAME WHILE OPEN ETC.\r
+ MOVE E,(P)\r
+ MOVE D,-1(P)\r
+ LDB C,[270400,,0] ; GET CHANNEL\r
+ .FDELE A ; RENAME IT\r
+ FATAL SAVE RENAME FAILED\r
+ XOR 0,[<.IOT A>#<.CLOSE>] ; CHANGE TO A CLOSE\r
+ XCT 0\r
+\r
+ MOVE A,MASK1 ; TURN INTS BACK ON\r
+ MOVE B,MASK2\r
+ .SETM2 A,\r
+ SKIPE DISXTR ; SKIP IF NO E&S\r
+ .DCONTINUE ; RESTART THE E&S IF WE HAVE IT\r
+]\r
+\r
+IFE ITS,[\r
+DMPDN1: MOVNI B,1\r
+ MOVE A,0 ; WRITE EOF\r
+ BOUT\r
+DMPDN2: MOVE A,0\r
+ CLOSF\r
+ FATAL CANT CLOSE SAVE FILE\r
+ CIS ; CLEAR IT SYSTEM\r
+ MOVEI A,400000\r
+ EIR ; AND RE-ENABLE\r
+]\r
+\r
+SDONE: MOVE A,$TCHSTR\r
+ MOVE B,CHQUOTE SAVED\r
+ JRST FINIS\r
+\r
+; SCAN FOR MANY OCCURENCES OF THE SAME THING\r
+\r
+CNTDUP: AOBJN D,DMP5 ; 4 IN A ROW YET\r
+ CAIN E,-4(B) ; ANY PARTIAL BLOCK?\r
+ JRST DMP6 ; NO, DUMP THESE\r
+ SUB B,[4,,4] ; BACK UP POINTER\r
+ JRST DMP2\r
+DMP6: CAMN C,(B) ; FIND ALL CONTIG\r
+ AOBJN B,.-1\r
+ MOVEI D,(B) ; COMPUTE COUNT\r
+ SUBI D,(E)\r
+ MOVSI D,(D)\r
+ HRRI D,(E) ; HEADER\r
+IFN ITS,[\r
+ HRROI A,D\r
+ XCT 0\r
+ HRROI A,C ; WRITE THE WORD\r
+ XCT 0\r
+]\r
+IFE ITS,[\r
+ MOVE A,0\r
+ EXCH D,B\r
+ BOUT\r
+ MOVE B,C\r
+ BOUT\r
+ MOVE B,D\r
+] JRST DMP7\r
+\r
+; HERE TO WRITE OUT FAST SAVE FILE\r
+\r
+FSAVE1: MOVE A,PARTOP ; DONT WRITE OUT "HOLE"\r
+ ADDI A,1777\r
+ ANDCMI A,1777\r
+ MOVEI E,(A)\r
+ PUSHJ P,WRDOUT\r
+ MOVE A,VECBOT\r
+ ANDCMI A,1777\r
+ HRLI E,(A)\r
+ PUSHJ P,WRDOUT\r
+ POP P,0 ; CHANNEL TO 0\r
+IFN ITS,[\r
+ ASH 0,23. ; TO AC FIELS\r
+ IOR 0,[.IOT A]\r
+ MOVEI A,5 ; START AT WORD 5\r
+]\r
+IFE ITS,[\r
+ MOVE A,[-<P-E>,,E]\r
+ PUSH P,(A)\r
+ AOBJN A,.-1\r
+ MOVE A,0\r
+ MOVE B,P ; WRITE OUT P FOR WIINAGE\r
+ BOUT\r
+ MOVE B,[444400,,20]\r
+ MOVNI C,20-6\r
+ SOUT ; MAKE PAGE BOUNDARIES WIN\r
+ MOVEI A,20 ; START AT 20\r
+]\r
+ MOVEI B,(E) ; PARTOP TO B\r
+ PUSHJ P,FOUT ; WRITE OUT UP TO PAIR TOP\r
+ HLRZ A,E ; VECBOT TO A\r
+ MOVE B,VECTOP ; AND THE REST\r
+ PUSHJ P,FOUT\r
+ JRST DMPDN2\r
+\r
+IFN ITS,[\r
+FOUT: MOVEI D,(A) ; SAVE START\r
+ SUB A,B ; COMPUTE LH OF IOT PNTR\r
+ MOVSI A,(A)\r
+ SKIPL A ; IF + MEANS GROSS CORE SIZE\r
+ MOVSI A,400000 ; USE BIGGEST\r
+ HRRI A,(D)\r
+ XCT 0 ; ZAP, OUT IT GOES\r
+ CAMGE A,B ; SKIP IF ALL WENT\r
+ JRST FOUT ; DO THE REST\r
+ POPJ P, ; GO CLOSE FILE\r
+]\r
+IFE ITS,[\r
+FOUT: MOVEI C,(A)\r
+ SUBI C,(B) ; # OF BYTES TP C\r
+ MOVEI B,(A) ; START TO B\r
+ HRLI B,444400\r
+ MOVE A,0\r
+ SOUT ; WRITE IT OUT\r
+ POPJ P,\r
+]\r
+ \r
+\r
+; HERE TO ATTEMPT TO RESTORE A SAVED STATE\r
+\r
+MFUNCTION RESTORE,SUBR\r
+\r
+ ENTRY\r
+ SKIPG MUDSTR+2 ; DON'T RESTORE FROM EXPERIMENTAL MUDDLE\r
+ JRST EXPVRS\r
+IFE ITS,[\r
+ MOVE B,[100600,,]\r
+ MOVE C,[440000,,240000]\r
+]\r
+ PUSHJ P,GTFNM\r
+ JRST TMA\r
+IFN ITS,[\r
+ MOVEI A,6 ; READ/IMAGE/BLOCK\r
+ HRLM A,-2(P)\r
+ MOVEI A,-2(P)\r
+ PUSHJ P,MOPEN ; OPEN THE LOSER\r
+ JRST FNF\r
+ SUB P,[4,,4] ; REMOVE OPEN BLOCK\r
+\r
+ PUSH P,A ; SAVE CHANNEL\r
+ PUSHJ P,SGSNAM ; SAVE SNAME IN SYSTEM\r
+]\r
+IFE ITS, PUSH P,A ; SAVE JFN\r
+ PUSHJ P,WRDIN ; READ MUDDLE VERSION\r
+ MOVEI B,40 ; CHANGE ALL SPACES\r
+ MOVEI C,177 ; ----- TO RUBOUT CHARACTERS\r
+ PUSHJ P,HACKV\r
+ CAME A,MUDSTR+2 ; AGREE ?\r
+ JRST BADVRS\r
+\r
+IFN ITS, MCALL 0,IPCOFF ; CLOSE ALL IPC CHANS\r
+ PUSHJ P,CLOSAL ; CLOSE CHANNELS\r
+IFN ITS,[\r
+ SETZB A,B ; KILL ALL POSSIBLE INTERRUPTION\r
+ .SETM2 A,\r
+]\r
+IFE ITS,[\r
+ MOVEI A,400000 ; DISABLE INTS\r
+ DIR ; INTS OFF\r
+]\r
+ PUSHJ P,PURCLN ; DONT KEEP PURE SHAREDNESS\r
+ POP P,A ; RETRIEVE CHANNEL\r
+ MOVE P,GCPDL\r
+ PUSH P,A ; AND SAVE IT ON A GOOD PDL\r
+ PUSHJ P,WRDIN ; READ A WORD (VECTOP) OR 0==>FAST I.E. MAP RESTORE\r
+ JUMPE A,FASTR\r
+ MOVEM A,VECTOP ; SAVE FOR LATER\r
+ ASH A,-10. ; TO BLOCKS\r
+ MOVE C,A ; SAVE A COPY\r
+ ADDI A,1 ; ROOM FOR GC PDL\r
+ PUSHJ P,P.CORE\r
+ PUSHJ P,NOCORE ; LOSE,LOSE, LOSE\r
+\r
+; NOW READY TO READ IN GC SPACE\r
+ POP P,0 ; GET CHAN\r
+ MOVEI E+1,0\r
+ MOVE B,[E+1,,E+2] ; BLT SETUP TO ZERO CORE\r
+ MOVE E,NOTTY\r
+ MOVE A,VECTOP\r
+ BLT B,-1+2000(A) ; THE WHOLE THING?\r
+IFN ITS,[\r
+ LSH 0,23.\r
+ IOR 0,[.IOT A] ; BUILD IOT\r
+]\r
+IFE ITS,[\r
+ MOVE A,0\r
+ BIN ; READ IN NEW "P"\r
+ MOVE P,B\r
+]\r
+LDLP:\r
+IFN ITS,[\r
+ HRROI A,B ; READ A HDR\r
+ XCT 0\r
+ JUMPL A,LD1 ; DONE\r
+]\r
+IFE ITS,[\r
+ MOVE A,0\r
+ BIN ; HDR TO B\r
+]\r
+ CAMN B,[-1]\r
+ JRST LD1\r
+\r
+ JUMPGE B,LDDUPS ; JUMP IF LOADING DUPS\r
+IFN ITS,[\r
+ MOVE A,B ; TO IOTER\r
+ XCT 0\r
+\r
+ MOVE C,B ; COMP CKS\r
+ ROT C,1\r
+ ADD C,(B)\r
+ AOBJN B,.-2 ; COMP AWAY\r
+\r
+ HRROI A,D ; GET FILES CKS\r
+ XCT 0\r
+ CAME D,C ; CHECK\r
+ FATAL RESTORE CHECKSUM ERROR\r
+ JRST LDLP ; LOAD MORE\r
+]\r
+IFE ITS,[\r
+ MOVE D,B ; SAVE\r
+ HLRE C,B\r
+ HRLI B,444400\r
+ MOVE A,0\r
+ SIN ; READ IN A BUNCH\r
+\r
+ MOVE B,D\r
+ ROT D,1\r
+ ADD D,(B)\r
+ AOBJN B,.-2\r
+\r
+ BIN ; READ STORED CKS\r
+ CAME D,B\r
+ FATAL RESTORE CHECKSUM ERROR\r
+ JRST LDLP\r
+]\r
+\r
+LDDUPS:\r
+IFN ITS,[\r
+ HRROI A,(B) ; READ 1ST IN PLACE\r
+ XCT 0\r
+]\r
+IFE ITS,[\r
+ MOVE D,B ; SAVE HDR\r
+ BIN ; READ WORD OF INTEREST\r
+ MOVEM B,(D)\r
+ MOVE B,D\r
+]\r
+ HLRZ A,B ; # TO A\r
+ HRLI B,(B) ; BUILD A BLT PONTER\r
+ ADDI B,1\r
+ ADDI A,-2(B)\r
+ BLT B,(A)\r
+ JRST LDLP\r
+\r
+LD1:\r
+IFN ITS,[\r
+ XOR 0,[<.IOT A>#<.CLOSE>] ; CHANGE TO CLOSE\r
+ XCT 0 ; AND DO IT\r
+]\r
+IFE ITS,[\r
+ MOVE A,0\r
+ CLOSF\r
+ JFCL\r
+FASTR1: MOVEI A,P-1\r
+ MOVEI B,P-1-E\r
+ POP P,(A)\r
+ SUBI A,1\r
+ SOJG B,.-2\r
+]\r
+\r
+IFN ITS,[\r
+FASTR1:\r
+]\r
+ MOVE A,VECTOP ; REAL CORE TOP\r
+ ADDI A,2000 ; ROOM FOR GC PDL\r
+ MOVEM A,P.TOP\r
+ MOVEM E,NOTTY ; SAVE TTY FLAG\r
+ PUSHJ P,PURCLN ; IN CASE RESTORED THING HAD PURE STUFF\r
+ PUSHJ P,INTINT ; USE NEW INTRRRUPTS\r
+\r
+; NOW CYCLE THROUGH CHANNELS\r
+ MOVE C,TVP\r
+ ADD C,[CHNL1+2,,CHNL1+2] ; POINT TO REAL CHANNELS SLOTS\r
+ PUSH TP,$TVEC\r
+ PUSH TP,C\r
+ PUSH P,[N.CHNS]\r
+\r
+CHNLP: SKIPN B,-1(C) ; GET CHANNEL\r
+ JRST NXTCHN\r
+ PUSHJ P,REOPN\r
+ PUSHJ P,CHNLOS\r
+ MOVE C,(TP) ; GET POINTER\r
+NXTCHN: ADD C,[2,,2] ; AND BUMP\r
+ MOVEM C,(TP)\r
+ SOSE (P)\r
+ JRST CHNLP\r
+\r
+ SKIPN C,CHNL0(TVP)+1 ; ANY PSUEDO CHANNELS\r
+ JRST RDONE ; NO, JUST GO AWAY\r
+ MOVSI A,TLIST ; YES, REOPEN THEM\r
+ MOVEM A,(TP)-1\r
+CHNLP1: MOVEM C,(TP) ; SAVE POINTER\r
+ SKIPE B,(C)+1 ; GET CHANNEL\r
+ PUSHJ P,REOPN\r
+ PUSHJ P,CHNLO1\r
+ MOVE C,(TP) ; GOBBLE POINTER\r
+ HRRZ C,(C) ; REST LIST OF PSUEDO CHANNELS\r
+ JUMPN C,CHNLP1\r
+\r
+RDONE: SUB TP,[2,,2]\r
+ SUB P,[1,,1]\r
+ PUSHJ P,TTYOPE\r
+IFN ITS,[\r
+ PUSHJ P,IPCBLS ;BLESS ALL THE IPC CHANNELS\r
+ PUSHJ P,SGSNAM ; GET SNAME\r
+ SKIPN A\r
+ .SUSET [.RSNAM,,A]\r
+ PUSHJ P,6TOCHS ; TO STRING\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ MCALL 1,SNAME\r
+]\r
+ PUSHJ P,%RUNAM\r
+ PUSHJ P,%RJNAM\r
+ MOVE A,$TCHSTR\r
+ MOVE B,CHQUOTE RESTORED\r
+ JRST FINIS\r
+\r
+FASTR:\r
+IFN ITS,[\r
+ PUSHJ P,WRDIN ; GET CORE TOP\r
+ ASH A,-10. ; TO PAGES\r
+ MOVEI B,(A) ; SAVE\r
+ ADDI A,1 ; ROOM FOR GC PDL\r
+ PUSHJ P,P.CORE ; GET ALL CORE\r
+ PUSHJ P,NOCORE ; LOSE RETURN\r
+ PUSHJ P,WRDIN ; GET PARTOP\r
+ ASH A,-10. ; TO PAGES\r
+ MOVEI E,(A)\r
+ PUSHJ P,WRDIN ; NOW GET VECBOT\r
+ ASH A,-10. ; TO PAGES\r
+ EXCH A,E ; AND SAVE IN E\r
+ MOVNS A\r
+ MOVSI A,(A) ; TO PAGE AOBJN\r
+ MOVE C,A ; COPY OF POINTER\r
+ MOVE 0,NOTTY ; SAVE NOTTY FLAG AROUND\r
+ MOVE D,(P) ; CHANNEL\r
+ DOTCAL CORBLK,[[1000,,104000],[1000,,-1],A,D,C]\r
+ FATAL CORBLK ON RESTORE LOSSAGE\r
+ SUBM E,B ; AOBJN LH TO E\r
+ HRLI E,(B) ; AOBJN TO CORE\r
+ HRLI C,(B) ; AND TO DISK\r
+ DOTCAL CORBLK,[[1000,,104000],[1000,,-1],E,D,C]\r
+ FATAL CORBLK ON RESTORE LOSSAGE\r
+ MOVSI A,(D) ; CHANNEL BACK\r
+ ASH A,5\r
+ MOVEI B,E ; WHERE TO STRAT IN FILE\r
+ IOR A,[.ACCESS B]\r
+ XCT A ; ACCESS TO RIGHT ACS\r
+ XOR A,[<.IOT B>#<.ACCESS B>]\r
+ MOVE B,[D-P-1,,E]\r
+ XCT A ; GET ACS\r
+ MOVE E,0 ; NO TTY FLAG BACK\r
+ XOR A,[<.IOT B>#<.CLOSE>]\r
+ XCT A\r
+]\r
+IFE ITS,[\r
+FASTR: POP P,A ; JFN TO A\r
+ BIN ; CORE TOP TO B\r
+ MOVE E,B ; SAVE\r
+ BIN ; PARTOP\r
+ MOVE D,B\r
+ BIN ; VECBOT\r
+ MOVE C,B\r
+ BIN ; SAVED P\r
+ MOVE P,B\r
+ MOVE 0,NOTTY ; SAVE NOTTY FLAG AROUND\r
+ HRL E,C ; SAVE VECTOP\r
+ MOVSI A,(A) ; JFN TO LH\r
+ MOVSI B,400000 ; FOR ME\r
+ MOVSI C,120400 ; FLAGS\r
+ ASH D,-9. ; PAGES TO D\r
+ PMAP\r
+ ADDI A,1\r
+ ADDI B,1\r
+ SOJG D,.-3\r
+\r
+ ASH E,-9. ; E==> CORTOP PAGE,,VECBOT PAGE\r
+ HLR B,E ; B NOW READY\r
+ MOVEI D,(E)\r
+ SUBI D,(B)\r
+ PMAP\r
+ ADDI A,1\r
+ ADDI B,1\r
+ SOJG D,.-3\r
+\r
+ HLRZS A\r
+ CLOSF\r
+ FATAL CANT CLOSE RESTORE FILE\r
+ MOVE E,0 ; NOTTY TO E\r
+]\r
+ MOVE A,PARTOP ; ZERO OUT NEW FREE\r
+ HRLI A,(A)\r
+ MOVE B,VECBOT\r
+ SETZM (A)\r
+ ADDI A,1\r
+ BLT A,-1(B) ; ZAP...YOU'RE ZERO\r
+ JRST FASTR1\r
+\r
+\r
+; HERE TO GROCK FILE NAME FROM ARGS\r
+\r
+GTFNM:\r
+IFN ITS,[\r
+ PUSH TP,$TPDL\r
+ PUSH TP,P\r
+\r
+ IRP A,,[DSK,MUDDLE,SAVE]\r
+ PUSH P,[SIXBIT /A/]\r
+ TERMIN\r
+ PUSHJ P,SGSNAM ; GET SNAME\r
+ PUSH P,A ; SAVE SNAME\r
+\r
+ JUMPGE AB,GTFNM1\r
+ PUSHJ P,RGPRS ; PARSE THESE ARGS\r
+ JRST .+2\r
+GTFNM1: AOS -4(P) ; SKIP RETURN\r
+\r
+ POP P,A ; GET SNAME\r
+ .SUSET [.SSNAM,,A]\r
+ MOVE A,-3(P) ; GET RET ADDR\r
+ HLRZS -2(P) ; FIXUP DEVICE SPEC\r
+ SUB TP,[2,,2]\r
+ JRST (A)\r
+\r
+; HERE TOO OUT 1 WORD\r
+\r
+WRDOUT: PUSH P,B\r
+ PUSH P,A\r
+ HRROI B,(P) ; POINT AT C(A)\r
+ MOVE A,-3(P) ; CHANNEL\r
+ PUSHJ P,MIOT ;WRITE IT\r
+POPJB: POP P,A\r
+ POP P,B\r
+ POPJ P,\r
+\r
+; HERE TO READ 1 WORD\r
+WRDIN==WRDOUT\r
+]\r
+IFE ITS,[\r
+ PUSH P,C\r
+ PUSH P,B\r
+ MOVE B,IMQUOTE SNM\r
+ PUSHJ P,IDVAL1\r
+ GETYP 0,A\r
+ CAIN 0,TUNBOU\r
+ MOVEI B,0\r
+ MOVEI A,(P)\r
+ PUSH P,[377777,,377777]\r
+ PUSH P,[-1,,[ASCIZ /DSK/]]\r
+ PUSH P,B\r
+ PUSH P,[-1,,[ASCIZ /MUDDLE/]]\r
+ PUSH P,[-1,,[ASCIZ /SAVE/]]\r
+ PUSH P,[0]\r
+ PUSH P,[0]\r
+ PUSH P,[77] ; USE AN OBSCURE JFN IF POSSIBLE\r
+ MOVE B,1(AB)\r
+ GTJFN\r
+ JRST FNF\r
+ SUB P,[9.,,9.]\r
+ POP P,B\r
+ OPENF\r
+ JRST FNF\r
+ ADD AB,[2,,2]\r
+ SKIPL AB\r
+ AOS (P)\r
+ POPJ P,\r
+\r
+WRDIN: PUSH P,B\r
+ MOVE A,-2(P) ; JFN TO A\r
+ BIN\r
+ MOVE A,B\r
+ POP P,B\r
+ POPJ P,\r
+\r
+WRDOUT: PUSH P,B\r
+ MOVE B,-2(P)\r
+ EXCH A,B\r
+ BOUT\r
+ EXCH A,B\r
+ POP P,B\r
+ POPJ P,\r
+]\r
+\r
+\r
+;REPLACE ALL OCCURANCES OF CHARACTER (B) TO CHARACTER (C) IN A\r
+HACKV: PUSH P,D\r
+ PUSH P,E\r
+ MOVE D,[440700,,A]\r
+ MOVEI E,5\r
+HACKV1: ILDB 0,D\r
+ CAIN 0,(B) ; MATCH ?\r
+ DPB C,D ; YES, CLOBBER\r
+ SOJG E,HACKV1\r
+ POP P,E\r
+ POP P,D\r
+ POPJ P,\r
+\r
+\r
+CANTOP: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE CANT-OPEN-OUTPUT-FILE\r
+ JRST CALER1\r
+\r
+FNF: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE FILE-NOT-FOUND\r
+ JRST CALER1\r
+\r
+BADVRS: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE MUDDLE-VERSIONS-DIFFER\r
+ JRST CALER1\r
+\r
+EXPVRS: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE EXPERIMENTAL-MUDDLE-VERSION\r
+ JRST CALER1\r
+\r
+CHNLO1: MOVE C,(TP)\r
+ SETZM 1(C)\r
+ JRST CHNLO2\r
+\r
+CHNLOS: MOVE C,(TP)\r
+ SETZM (C)-1\r
+CHNLO2: MOVEI B,[ASCIZ /\r
+CHANNEL-NOT-RESTORED\r
+/]\r
+ JRST MSGTYP"\r
+\r
+\r
+NOCORE: PUSH P,A\r
+ PUSH P,B\r
+ MOVEI B,[ASCIZ /\r
+WAIT, CORE NOT YET HERE\r
+/]\r
+ PUSHJ P,MSGTYP"\r
+ MOVE A,(P) ; RESTORE BLOCKS NEEDED\r
+ MOVEI B,1\r
+ .SLEEP B,\r
+ PUSHJ P,P.CORE\r
+ JRST .-4\r
+ MOVEI B,[ASCIZ /\r
+CORE ARRIVED\r
+/]\r
+ PUSHJ P,MSGTYP\r
+ POP P,B\r
+ POP P,A\r
+ POPJ P,\r
+END\r
+\f\fTITLE SPECS FOR MUDDLE\r
+\r
+RELOCA\r
+\r
+MAIN==1\r
+.GLOBAL TYPVLC,PBASE,TYPBOT,MAINPR,PTIME,IDPROC,ROOT,TTICHN,TTOCHN,TYPVEC\r
+.GLOBAL %UNAM,%JNAM,NOTTY,GCHAPN,INTHLD,PURBOT,PURTOP,N.CHNS,SPCCHK,CURFCN\r
+.GLOBAL TD.GET,TD.PUT,TD.LNT,NOSHUF\r
+\r
+\r
+.INSRT MUDDLE >\r
+\r
+SYSQ\r
+\r
+CONSTANTS\r
+\r
+IFN ITS,[\r
+ N.CHNS==16.\r
+ FATINS==.VALUE\r
+]\r
+IFE ITS,[\r
+ N.CHNS==102\r
+]\r
+\r
+IMPURE\r
+\r
+CRADIX: 10.\r
+%UNAM: 0 ; HOLDS UNAME\r
+%JNAM: 0 ; HOLDS JNAME\r
+IDPROC: 0 ; ENVIRONMENT NUMBER GENERATOR\r
+PTIME: 0 ; UNIQUE NUMBER FOR PROCID AND ENVIRONMENTS\r
+OBLNT": 13. ; LENGTH OF DEFAULT OBLISTS (SMALL)\r
+VECTOP": VECLOC ; TOP OF CURRENT GARBAGE COLLECTED SPACE\r
+VECBOT": VECBASE ; BOTTOM OF GARBAGE COLLECTED SPACE\r
+CODBOT: 0 ; ABSOLUTE BOTTOM OF CODE\r
+CODTOP": PARBASE ; TOP OF IMPURE CODE (INCLUDING "STORAGE")\r
+HITOP: 0 ; TOP OF INTERPRETER PURE CORE\r
+PARNEW": 0\r
+PARBOT": PARBASE\r
+PARTOP": PARLOC\r
+VECNEW": 0 ; LOCATION FOR OFFSET BETWWEN OLD GCSTOP AND NEW GCSTOP\r
+INTFLG: 0 ; INTERRUPT PENDING FLAG\r
+MAINPR: 0 ; HOLDS POINTER TO THE MAIN PROCESS\r
+NOTTY: 0 ; NON-ZERO==> THIS MUDDLE HAS NO TTY\r
+GCHAPN: 0 ; NON-ZERO A GC HAS HAPPENED RECENTLY\r
+INTHLD: 0 ; NON-ZERO INTERRUPTS CANT HAPPEN\r
+PURBOT: HIBOT ; BOTTOM OF DYNAMICALLY ALLOCATED PURE\r
+PURTOP: HIBOT ; TOP OF DYNAMICALLY ALLOCATED PURE\r
+SPCCHK: SETZ ; SPECIAL/UNSPECIAL CHECKING?\r
+NOSHUF: 0 ; FLAG TO BUILD A NON MOVING HI SEG\r
+\r
+;PAGE MAP USAGE TABLE FOR MUDDLE\r
+;EACH PAGE IS REPRESENTED BY ONE BIT IN THE TABLE\r
+;IF BIT = 0 THEN PAGE IS FREE OTHERWISE BUSY\r
+;FOR PAGE n USE BIT (n MOD 32.) IN WORD PMAP+n/32.\r
+PMAP": -1 ;SECTION 0 -- BELONGS TO AGC\r
+ -1 ;SECTION 1 -- BELONGS TO AGC\r
+ -1 ;SECTION 2 -- BELONGS TO AGC\r
+ -1 ;SECTION 3 -- BELONGS TO AGC\r
+ -1 ;SECTION 4 -- BELONGS TO AGC\r
+ -1 ;SECTION 5 -- BELONGS TO AGC (DEPENDS ON HIBOT)\r
+ -1 ;SECTION 6 -- START OF PURE CORE (FILLED IN BY INITM)\r
+ -1 ;SECTION 7 -- LAST TWO PAGES BELONG TO AGC'S PAGE MAPPER\r
+\r
+\r
+NINT==72. ; NUMBER OF POSSIBLE ITS INTERRUPTS\r
+NASOCS==159. ; LENGTH OF ASSOCIATION VECTOR\r
+PDLBUF==100 ; EXTRA INSURENCE PDL\r
+ASOLNT==10 ; LENGTH OF ASSOCIATION BLOCKS\r
+\r
+\r
+.GLOBAL PATCH,TBINIT,LERR,LPROG,PIDSTO,PROCID,PTIME,GCPDL,INTFLG,WTYP1,WTYP2\r
+.GLOBAL PAT,PDLBUF,INTINT,PARNEW,GCPVP,START,SWAP,ICR,SPBASE,TPBASE,GLOBAS,GLOBSP,TPBAS\r
+.GLOBAL TOPLEVEL,INTNUM,INTVEC,INTOBL,ASOVEC,ERROBL,MAINPR,RESFUN,.BLOCK,ASOLNT,NODES\r
+.GLOBAL WRONGT,TTYOPE,OPEN,CLOSE,IOT,ILVAL,MESS,FACTI,REFVEC,MUDOBL,INITIA\r
+.GLOBAL LSTRES,BINDID,DUMNOD,PSTAT,1STEPR,IDPROC,EVATYP,APLTYP,PRNTYP,PURVEC,STOLST\r
+\r
+\r
+VECTGO\r
+TVBASE": BLOCK TVLNT\r
+ GENERAL\r
+ TVLNT+2,,0\r
+TVLOC==TVBASE\r
+\r
+\r
+\r
+;INITIAL TYPE TABLE\r
+\r
+TYPVLC":\r
+ BLOCK 2*NUMPRI+2\r
+ GENERAL\r
+ 2*NUMPRI+2+2,,0\r
+\r
+TYPTP==.-2 ; POINT TO TOP OF TYPES\r
+\r
+; INITIAL SYMBOL TABEL FOR RSUBRS\r
+\r
+SQULOC==.\r
+SQUTBL: BLOCK 2*NSUBRS\r
+ TWORD,,0\r
+ 2*NSUBRS+2,,0\r
+\r
+INTVCL: BLOCK 2*NINT\r
+ TLIST,,0\r
+ 2*NINT+2,,0\r
+\r
+NODLST: TTP,,0\r
+ 0\r
+ TASOC,,0\r
+ BLOCK ASOLNT-3\r
+ GENERAL+<SASOC,,0>\r
+ ASOLNT+2,,0\r
+\r
+NODDUM: BLOCK ASOLNT\r
+ GENERAL+<SASOC,,0>\r
+ ASOLNT+2,,0\r
+\r
+\r
+\r
+ASOVCL: BLOCK NASOCS\r
+ TASOC,,0\r
+ NASOCS+2,,0\r
+\r
+\r
+\r
+;THESE ENTRIES MUST NOT MOVE DURING INITILAIZATION\r
+\r
+ADDTV TVEC,[-2*NUMPRI-2,,TYPVLC]\r
+TYPVEC==TVOFF-1\r
+\r
+ADDTV TVEC,[-2*NUMPRI-2,,TYPVLC]\r
+TYPBOT==TVOFF-1 ; POINT TO CURRENT TOP OF TYPE VECTORS\r
+\r
+;ENTRY FOR ROOT,TTICHN,TTOCHN\r
+\r
+ADDTV TCHAN,0\r
+TTICHN==TVOFF-1\r
+\r
+ADDTV TCHAN,0\r
+TTOCHN==TVOFF-1\r
+\r
+ADDTV TOBLS,0\r
+ROOT==TVOFF-1\r
+ADDTV TOBLS,0\r
+INITIA==TVOFF-1\r
+ADDTV TOBLS,0\r
+INTOBL==TVOFF-1\r
+ADDTV TOBLS,0\r
+ERROBL==TVOFF-1\r
+ADDTV TOBLS,0\r
+MUDOBL==TVOFF-1\r
+ADDTV TVEC,0\r
+GRAPHS==TVOFF-1\r
+ADDTV TFIX,0\r
+INTNUM==TVOFF-1\r
+ADDTV TVEC,[-2*NINT,,INTVCL]\r
+INTVEC==TVOFF-1\r
+ADDTV TUVEC,[-NASOCS,,ASOVCL]\r
+ASOVEC==TVOFF-1\r
+\r
+ADDTV TLIST,0\r
+CHNL0"==TVOFF-1 ;LIST FOR CURRENTLY OPEN PSUEDO CHANNELS\r
+\r
+IFN ITS,[\r
+DEFINE ADDCHN N\r
+ ADDTV TCHAN,0\r
+ CHNL!N==TVOFF-1\r
+ .GLOBAL CHNL!N\r
+ TERMIN\r
+\r
+REPEAT 15.,ADDCHN \.RPCNT+1\r
+ \r
+DEFINE ADDIPC N\r
+ ADDTV TLIST,0\r
+ IPCS!N==TVOFF-1\r
+ .GLOBAL IPCS!N\r
+ TERMIN\r
+\r
+REPEAT 15.,ADDIPC \.RPCNT+1\r
+]\r
+\r
+IFE ITS,[\r
+ADDTV TCHAN,0\r
+CHNL1==TVOFF-1\r
+.GLOBAL CHNL1\r
+REPEAT N.CHNS-1,[ADDTV TCHAN,0\r
+]\r
+]\r
+\r
+ADDTV TASOC,[-ASOLNT,,NODLST]\r
+NODES==TVOFF-1\r
+\r
+ADDTV TASOC,[-ASOLNT,,NODDUM]\r
+DUMNOD==TVOFF-1\r
+\r
+ADDTV TVEC,0\r
+EVATYP==TVOFF-1\r
+\r
+ADDTV TVEC,0\r
+APLTYP==TVOFF-1\r
+\r
+ADDTV TVEC,0\r
+PRNTYP==TVOFF-1\r
+\r
+; SLOTS ASSOCIATED WITH TEMPLATE DATA STRUCTURES\r
+\r
+ADDTV TUVEC,0\r
+TD.GET==TVOFF-1\r
+\r
+ADDTV TUVEC,0\r
+TD.PUT==TVOFF-1\r
+\r
+ADDTV TUVEC,0\r
+TD.LNT==TVOFF-1\r
+\r
+ADDTV TUVEC,0\r
+TD.PTY==TVOFF-1\r
+\r
+\r
+\r
+;GLOBAL SPECIAL PDL\r
+\r
+GSP: BLOCK GSPLNT\r
+ GENERAL\r
+ GSPLNT+2,,0\r
+\r
+ADDTV TVEC,[-GSPLNT,,GSP]\r
+GLOBASE==TVOFF-1\r
+GLOB==.-2\r
+ADDTV TVEC,GLOB\r
+GLOBSP==TVOFF-1 ;ENTRY FOR CURRENT POINTER TO GLOBAL SP\r
+\r
+; POINTER VECTOR TO PURE SHARED RSUBRS\r
+\r
+PURV: BLOCK 3*20. ; ENOUGH FOR 20 SUCH (INITIALLY)\r
+ 0\r
+ 3*20.+2,,0\r
+\r
+ADDTV TUVEC,[-3*20.,,PURV]\r
+PURVEC==TVOFF-1\r
+\r
+ADDTV TLIST,0\r
+STOLST==TVOFF-1\r
+\r
+;PROCESS VECTOR FOR GARBAGE COLLECTOR PROCESS\r
+\r
+GCPVP: BLOCK PVLNT*2\r
+ GENERAL\r
+ PVLNT*2+2,,0\r
+\r
+\r
+VECRET\r
+\r
+PURE\r
+\r
+;INITIAL PROCESS VECTOR\r
+\r
+PVBASE": BLOCK PVLNT*2\r
+ GENERAL\r
+ PVLNT*2+2,,0\r
+PVLOC==PVBASE\r
+\r
+\r
+;ENTRY FOR PROCESS I.D.\r
+\r
+ ADDPV TFIX,1,PROCID\r
+;THE FOLLOWING IRP MAKES SPACE FO9 SAVED ACS\r
+\r
+ZZZ==.\r
+\r
+IRP A,,[0,A,B,C,D,E,PVP,TVP,AB,TB,TP,SP,M,R,P]B,,[0\r
+0,0,0,0,0,TPVP,TTVP,TAB,TTB,TTP,TSP,TCODE,TRSUBR,TPDL]\r
+\r
+LOC PVLOC+2*A\r
+A!STO==.-PVBASE\r
+B,,0\r
+0\r
+TERMIN\r
+\r
+PVLOC==PVLOC+16.*2\r
+LOC ZZZ\r
+\r
+\r
+ADDPV TTB,0,TBINIT\r
+ADDPV TTP,0,TPBASE\r
+ADDPV TSP,0,SPBASE\r
+ADDPV TPDL,0,PBASE\r
+ADDPV 0,0,RESFUN\r
+ADDPV TLIST,0,.BLOCK\r
+ADDPV TLIST,0,MESS\r
+ADDPV TACT,0,FACTI\r
+ADDPV TPVP,0,LSTRES\r
+ADDPV TFIX,0,BINDID\r
+ADDPV TFIX,1,PSTAT\r
+ADDPV TPVP,0,1STEPR\r
+ADDPV TSP,0,CURFCN\r
+\r
+\r
+IMPURE\r
+\r
+END\r
+
\f<PACKAGE "TTY"> ;"TENEX VERSION"
\r+\r
+<ENTRY TTY-SET TTY-GET TTY-ON TTY-OFF>\r
+\r
+<SETG CALICO-MOD #WORD *700000*> ;"wakeup on all but alpha, no echo"\r
+MUDDLE-MOD ;"gunnasigned initially"\r
+\r
+<GDECL (CALICO-MOD MUDDLE-MOD) WORD>\r
+\r
+<TITLE TTY-GET>\r
+<PSEUDO <SET SFMOD #OPCODE *104000000110*>> ;"JSYS 110"\r
+<PSEUDO <SET RFMOD #OPCODE *104000000107*>> ;"JSYS 107"\r
+<DECLARE ("VALUE" WORD)>\r
+<HRRZI A* -1> ;"controlling tty file desig"\r
+<RFMOD>\r
+<MOVSI A* TWORD>\r
+<JRST FINIS>\r
+\r
+<TITLE TTY-SET>\r
+<DECLARE ("VALUE" WORD <PRIMTYPE WORD>)>\r
+<HRRZI A* -1>\r
+<MOVE B* 1 (AB)>\r
+<SFMOD>\r
+<MOVE A* (AB)>\r
+<MOVE B* 1 (AB)>\r
+<JRST FINIS>\r
+\r
+<END>\r
+\r
+<DEFINE TTY-OFF ()\r
+<COND (<NOT <GASSIGNED? MUDDLE-MOD>>\r
+ <SETG MUDDLE-MOD <TTY-GET>>)>\r
+ <TTY-SET ,CALICO-MOD>>\r
+\r
+<DEFINE TTY-ON ()\r
+<COND (<NOT <GASSIGNED? MUDDLE-MOD>>\r
+ <SETG MUDDLE-MOD <TTY-GET>>)\r
+ (<TTY-SET ,MUDDLE-MOD>)>>\r
+\r
+\r
+<ENDPACKAGE>\r
+\fTITLE UUO HANDLER FOR MUDDLE AND HYDRA\r
+RELOCATABLE\r
+.INSRT MUDDLE >\r
+\r
+;GLOBALS FOR THIS PROGRAM\r
+\r
+.GLOBAL BACKTR,PRINT,PDLBUF,TPGROW,SPECSTO,TIMOUT,AGC,VECBOT,VECTOP\r
+.GLOBAL BCKTRK,TPOVFL,.MONWR,.MONRD,.MONEX,MAKACT,IGVAL,ILVAL,BFRAME\r
+.GLOBAL PURTOP,PURBOT,PLOAD,PURVEC,STOSTR,MSGTYP,UUOH,ILLUUO\r
+\r
+;SETUP UUO DISPATCH TABLE HERE\r
+\r
+UUOTBL: ILLUUO\r
+\r
+IRP UUOS,,[[DP,DODP],[.MCALL,DMCALL],[.ACALL,DACALL],[.ECALL,DECALL],[.FATAL,DFATAL]]\r
+UUFOO==.IRPCNT+1\r
+IRP UUO,DISP,[UUOS]\r
+.GLOBAL UUO\r
+UUO=UUFOO_33\r
+DISP\r
+.ISTOP\r
+TERMIN\r
+TERMIN\r
+\r
+REPEAT 100-UUFOO,[ILLUUO\r
+]\r
+\r
+\r
+RMT [\r
+IMPURE\r
+\r
+UUOH:\r
+LOC 41\r
+ JSR UUOH\r
+LOC UUOH\r
+ 0\r
+ JRST UUOPUR ;GO TO PURE CODE FOR THIS\r
+\r
+SAVEC: 0 ; USED TO SAVE WORKING AC\r
+NOLINK: 0\r
+\r
+PURE\r
+]\r
+\r
+;SEPARATION OF PURE FROM IMPURE CODE HERE\r
+\r
+UUOPUR: MOVEM C,SAVEC ; SAVE AC\r
+ LDB C,[330900,,40]\r
+ JRST @UUOTBL(C) ;DISPATCH BASED ON THE UUO\r
+\r
+\r
+\r
+ILLUUO: FATAL ILLEGAL UUO\r
+\f;CALL HANDLER\r
+\r
+MQUOTE CALLER\r
+CALLER:\r
+\r
+DMCALL":\r
+ MOVEI D,0 ; FLAG NOT ENTRY CALL\r
+ LDB C,[270400,,40] ; GET AC FIELD OF UUO\r
+COMCAL: LSH C,1 ; TIMES 2\r
+ MOVN AB,C ; GET NEGATED # OF ARGS\r
+ HRLI C,(C) ; TO BOTH SIDES\r
+ SUBM TP,C ; NOW HAVE TP TO SAVE\r
+ MOVEM C,TPSAV(TB) ; SAVE IT\r
+ MOVSI AB,(AB) ; BUILD THE AB POINTER\r
+ HRRI AB,1(C) ; POINT TO ARGS\r
+ HRRZ C,UUOH ; GET PC OF CALL\r
+ CAMG C,PURTOP ; SKIP IF NOT IN GC SPACE\r
+ CAIGE C,STOSTR ; SKIP IF IN GC SPACE\r
+ JRST .+3\r
+ SUBI C,(M) ; RELATIVIZE THE PC\r
+ HRLI C,M ; FOR RETURNER TO WIN\r
+ MOVEM C,PCSAV(TB)\r
+ MOVEM SP,SPSAV(TB) ; SAVE BINDING GOODIE\r
+ MOVSI C,TENTRY ; SET UP ENTRY WORD\r
+ HRR C,40 ; POINT TO CALLED SR\r
+ ADD TP,[FRAMLN,,FRAMLN] ; ALLOCATE NEW FRAME\r
+ JUMPGE TP,TPLOSE\r
+CALDON: MOVEM C,FSAV+1(TP) ; CLOBBER THE FRAME\r
+ MOVEM TB,OTBSAV+1(TP)\r
+ MOVEM AB,ABSAV+1(TP) ; FRAME BUILT\r
+ MOVEM P,PSAV(TB)\r
+ HRRI TB,(TP) ; SETUP NEW TB\r
+ MOVEI C,(C)\r
+ MOVEI M,0 ; UNSETUP M FOR GC WINNAGE\r
+ CAMG C,VECTOP ; SKIP IF NOT RSUBR\r
+ CAMGE C,VECBOT ; SKIP IF RSUBR\r
+ JRST CALLS\r
+ GETYP A,(C) ; GET CONTENTS OF SLOT\r
+ JUMPN D,EVCALL ; EVAL CALLING ENTRY ?\r
+ CAIE A,TRSUBR ; RSUBR CALLING RSUBR ?\r
+ JRST RCHECK ; NO\r
+ MOVE R,(C)+1 ; YES, SETUP R\r
+CALLR0: HRRM R,FSAV+1(TB) ; FIXUP THE PROPER FSAV\r
+CALLR1: AOS E,2(R) ; COUNT THE CALLS\r
+ TRNN E,-1 ; SKIP IF OK\r
+ JRST COUNT1\r
+\r
+ SKIPL M,(R)+1 ; SETUP M\r
+ JRST SETUPM ; JUMP IF A PURE RSUBR IN QUESTION\r
+ AOBJP TB,.+1 ; GO TO CALLED RSUBR\r
+ INTGO ; CHECK FOR INTERRUPTS\r
+ JRST (M)\r
+\r
+COUNT1: SOS 2(R) ; UNDO OVERFLOW\r
+ HLLZS 2(R)\r
+ JRST CALLR1\r
+\r
+CALLS: AOBJP TB,.+1 ; GO TO CALLED SUBR\r
+ INTGO ; CHECK FOR INTERRUPTS\r
+ JRST @C\r
+\f\r
+; HERE TO HANDLE A PURE RSUBR (LOAD IF PUNTED OR OTHERWISE FLUSHED)\r
+\r
+SETUPM: MOVEI C,0 ; OFFSET (FOR MAIN ENTRIES)\r
+STUPM1: MOVEI D,(M) ; GET OFFSET INTO CODE\r
+ HLRS M ; GET VECTOR OFFSET IN BOTH HALVES\r
+ ADD M,PURVEC+1(TVP) ; GET IT\r
+ SKIPL M\r
+ FATAL LOSING PURE RSUBR POINTER\r
+ HLLM TB,2(M) ; MARK FOR LRU ALGORITHM\r
+ SKIPN M,1(M) ; POINT TO CORE IF LOADED\r
+ AOJA TB,STUPM2 ; GO LOAD IT\r
+STUPM3: ADDI M,(D) ; POINT TO REAL THING\r
+ HRLI C,M ; POINT TO START PC\r
+ AOBJP TB,.+1\r
+ INTGO\r
+ JRST @C ; GO TO IT\r
+\r
+STUPM2: HLRZ A,1(R) ; SET UP TO CALL LOADER\r
+ PUSH P,D\r
+ PUSH P,C\r
+ PUSHJ P,PLOAD ; LOAD IT\r
+ JRST PCANT1\r
+ POP P,C\r
+ POP P,D\r
+ MOVE M,B ; GET LOCATION\r
+ SOJA TB,STUPM3\r
+\r
+RCHECK: CAIN A,TPCODE ; PURE RSUBR?\r
+ JRST .+3\r
+ CAIE A,TCODE ; EVALUATOR CALLING RSUBR ?\r
+ JRST SCHECK ; NO\r
+ MOVS R,(C) ; YES, SETUP R\r
+ HRRI R,(C)\r
+ JRST CALLR1 ; GO FINISH THE RSUBR CALL\r
+\r
+\r
+SCHECK: CAIE A,TSUBR ; RSUBR CALLING SUBR AS REFERENCE ?\r
+ CAIN A,TFSUBR\r
+ SKIPA C,(C)+1 ; SKIP AND GET ROUTINE'S ADDRESS\r
+ JRST ECHECK\r
+ HRRM C,FSAV+1(TB) ; FIXUP THE PROPER FSAV\r
+ JRST CALLS ; GO FINISH THE SUBR CALL\r
+\r
+ECHECK: CAIE A,TENTER ; SKIP IF SUB ENTRY OF RSUBR\r
+ JRST ACHECK ; COULD BE EVAL CALLING ONE\r
+ MOVE C,1(C) ; POINT TO SUB ENTRY BLOCK\r
+ECHCK3: GETYP A,(C) ; SEE IF LINKED TO ITS MAIN ENTRY\r
+ MOVE B,1(C)\r
+ CAIN A,TRSUBR\r
+ JRST ECHCK2\r
+\r
+; CHECK IF CAN LINK ATOM\r
+\r
+ CAIE A,TATOM\r
+ JRST BENTRY ; LOSER , COMPLAIN\r
+ECHCK4: MOVE B,1(C) ; GET ATOM\r
+ PUSH TP,$TVEC\r
+ PUSH TP,C\r
+ PUSHJ P,IGVAL ; TRY GLOBAL VALUE\r
+ MOVE C,(TP)\r
+ SUB TP,[2,,2]\r
+ CAMN A,$TUNBOU\r
+ JRST BADVAL\r
+ CAME A,$TRSUBR ; IS IT A WINNER\r
+ JRST BENTRY\r
+ SKIPE NOLINK\r
+ JRST ECHCK2\r
+ HLLM A,(C) ; FIXUP LINKAGE\r
+ MOVEM B,1(C)\r
+ JRST ECHCK2\r
+\r
+EVCALL: CAIN A,TATOM ; EVAL CALLING ENTRY?\r
+ JRST ECHCK4 ; COULD BE MUST FIXUP\r
+ CAIE A,TRSUBR ; YES THIS IS ONE\r
+ JRST BENTRY\r
+ MOVE B,1(C)\r
+ECHCK2: MOVE R,B ; SET UP R\r
+ HRRM C,FSAV+1(TB) ; SET POINTER INTO FRAME\r
+ HRRZ C,2(C) ; FIND OFFSET INTO SAME\r
+ SKIPL M,1(R) ; POINT TO START OF RSUBR\r
+ JRST STUPM1 ; JUMP IF A LOSER\r
+ HRLI C,M\r
+ JRST CALLS ; GO TO SR\r
+\r
+ACHECK: CAIE A,TATOM ; RSUBR CALLING THROUGH REFERENCE ATOM ?\r
+ JRST DOAPP3 ; TRY APPLYING IT\r
+ MOVE A,(C)\r
+ MOVE B,(C)+1\r
+ PUSHJ P,IGVAL\r
+ HRRZ C,40 ; REGOBBLE POINTER TO SLOT\r
+ GETYP 0,A ; GET TYPE\r
+ CAIN 0,TUNBOUND\r
+ JRST TRYLCL\r
+SAVEIT: CAIE 0,TRSUBR\r
+ CAIN 0,TENTER\r
+ JRST SAVEI1 ; WINNER\r
+ CAIE 0,TSUBR\r
+ CAIN 0,TFSUBR\r
+ JRST SUBRIT\r
+ JRST BADVAL ; SOMETHING STRANGE\r
+SAVEI1: SKIPE NOLINK\r
+ JRST .+3\r
+ MOVEM A,(C) ; CLOBBER NEW VALUE\r
+ MOVEM B,(C)+1\r
+ CAIN 0,TENTER\r
+ JRST ENTRIT ; HACK ENTRY TO SUB RSUBR\r
+ MOVE R,B ; SETUP R\r
+ JRST CALLR0 ; GO FINISH THE RSUBR CALL\r
+\r
+ENTRIT: MOVE C,B\r
+ JRST ECHCK3\r
+\r
+SUBRIT: SKIPE NOLINK\r
+ JRST .+3\r
+ MOVEM A,(C)\r
+ MOVEM B,1(C)\r
+ HRRM B,FSAV+1(TB) ; FIXUP THE PROPER FSAV\r
+ MOVEI C,(B)\r
+ JRST CALLS ; GO FINISH THE SUBR CALL\r
+\r
+TRYLCL: MOVE A,(C)\r
+ MOVE B,(C)+1\r
+ PUSHJ P,ILVAL\r
+ GETYP 0,A\r
+ CAIE 0,TUNBOUND\r
+ JRST SAVEIT\r
+ SKIPA D,EQUOTE UNBOUND-VARIABLE\r
+BADVAL: MOVEI D,0\r
+ERCAL: AOBJP TB,.+1 ; MAKE TB A LIGIT FRAME PNTR\r
+ MOVEI E,CALLER\r
+ HRRM E,FSAV(TB) ; SET A WINNING FSAV\r
+ HRRZ C,40 ; REGOBBLE POINTER TO SLOT\r
+ JUMPE D,DOAPPL\r
+ SUBI C,(R) ; CALCULATE OFFSET\r
+ HRLS C\r
+ ADD C,R ; MAKE INTO REAL RSUBR POINTER\r
+ PUSH TP,$TRSUBR ; SAVE\r
+ PUSH TP,C\r
+ HRRZ C,40 ; REGOBBLE POINTER TO SLOT\r
+ PUSH TP,$TATOM\r
+ PUSH TP,D\r
+ PUSH TP,(C)\r
+ PUSH TP,(C)+1\r
+ PUSH TP,$TATOM\r
+ PUSH TP,MQUOTE CALLER\r
+ MCALL 3,ERROR\r
+ MOVE C,(TP) ; GET SAVED RSUBR POINTER\r
+ SUB TP,[2,,2] ; POP STACK\r
+ GETYP 0,A\r
+ HRRM C,40\r
+ SOJA TB,SAVEIT\r
+\r
+BENTRY: MOVE D,EQUOTE BAD-ENTRY-BLOCK\r
+ JRST ERCAL\r
+\r
+;HANDLER FOR CALL WHERE SPECIFIES NUMBER OF ARGS\r
+\r
+DACALL":\r
+ LDB C,[270400,,40] ; GOBBLE THE AC LOCN INTO C\r
+ EXCH C,SAVEC ; C TO SAVE LOC RESTORE C\r
+ MOVE C,@SAVEC ; C NOW HAS NUMBER OF ARGS\r
+ MOVEI D,0 ; FLAG NOT E CALL\r
+ JRST COMCAL ; JOIN MCALL\r
+\r
+; CALL TO ENTRY FROM EVAL (LIKE ACALL)\r
+\r
+DECALL: LDB C,[270400,,40] ; GET NAME OF AC\r
+ EXCH C,SAVEC ; STORE NAME\r
+ MOVE C,@SAVEC ; C NOW HAS NUM OF ARGS\r
+ MOVEI D,1 ; FLAG THIS\r
+ JRST COMCAL\r
+\r
+;HANDLE OVERFLOW IN THE TP\r
+\r
+TPLOSE: PUSHJ P,TPOVFL\r
+ JRST CALDON\r
+\r
+; RSUBR HAS POSSIBLY BEEN REPLACED BY A FUNCTION OR WHATEVER, DO AN APPLY\r
+\r
+DOAPPL: PUSH TP,A ; PUSH THE THING TO APPLY\r
+ PUSH TP,B\r
+ MOVEI A,1\r
+DOAPP2: JUMPGE AB,DOAPP1 ; ARGS DONE\r
+\r
+ PUSH TP,(AB)\r
+ PUSH TP,1(AB)\r
+ ADD AB,[2,,2]\r
+ AOJA A,DOAPP2\r
+\r
+DOAPP1: ACALL A,APPLY ; APPLY THE LOSER\r
+ JRST FINIS\r
+\r
+DOAPP3: MOVE A,(C) ; GET VAL\r
+ MOVE B,1(C)\r
+ JRST BADVAL ; GET SETUP FOR APPLY CALL\r
+\f\r
+; ENTRY TO BUILD A FRAME (USED BY SOME COMPILED PROG/REPEAT)\r
+\r
+BFRAME: HRLI A,M ; RELATIVIZE PC\r
+ MOVEM A,PCSAV(TB) ; CLOBBER PC IN\r
+ MOVEM TP,TPSAV(TB) ; SAVE STATE\r
+ MOVEM SP,SPSAV(TB)\r
+ ADD TP,[FRAMLN,,FRAMLN]\r
+ SKIPL TP\r
+ PUSHJ TPOVFL ; HACK BLOWN PDL\r
+ MOVSI A,TCBLK ; FUNNY FRAME\r
+ HRRI A,(R)\r
+ MOVEM A,FSAV+1(TP) ; CLOBBER\r
+ MOVEM TB,OTBSAV+1(TP)\r
+ MOVEM AB,ABSAV+1(TP)\r
+ POP P,A ; RET ADDR TO A\r
+ MOVEM P,PSAV(TB)\r
+ HRRI TB,(TP)\r
+ AOBJN TB,.+1\r
+ JRST (A)\r
+\f;SUBROUTINE TERMINATION CODE (NOT A UUO BUT HERE FOR COMPLETENENSS)\r
+\r
+FINIS:\r
+CNTIN1: HRRZS C,OTBSAV(TB) ; RESTORE BASE\r
+ HRRI TB,(C)\r
+CONTIN: MOVE TP,TPSAV(TB) ; START HERE FOR FUNNY RESTART\r
+ MOVE P,PSAV(TB)\r
+ CAME SP,SPSAV(TB) ; ANY RESTORATION NEEDED\r
+ PUSHJ P,SPECSTO ; YES, GO UNRAVEL THE WORLDS BINDINGS\r
+ MOVE AB,ABSAV(TB) ; AND GET OLD ARG POINTER\r
+ HRRZ C,FSAV(TB) ; CHECK FOR RSUBR\r
+ MOVEI M,0 ; UNSETUP M FOR GC WINNAGE\r
+ CAMG C,VECTOP\r
+ CAMGE C,VECBOT\r
+ JRST @PCSAV(TB) ; AND RETURN\r
+ GETYP 0,(C) ; RETURN TO MAIN OR SUB ENTRY?\r
+ CAIN 0,TCODE\r
+ JRST .+3\r
+ CAIE 0,TPCODE\r
+ JRST FINIS1\r
+ MOVS R,(C)\r
+ HRRI R,(C) ; RESET R\r
+ SKIPGE M,1(R) ; GET LOC OF REAL SUBR\r
+ JRST @PCSAV(TB)\r
+ JRST FINIS2\r
+\r
+FINIS1: CAIE 0,TRSUBR\r
+ JRST FINISA ; MAY HAVE BEEN PUT BACK TO ATOM\r
+ MOVE R,1(C)\r
+ SKIPGE M,1(R)\r
+ JRST @PCSAV(TB)\r
+\r
+FINIS2: MOVEI C,(M) ; COMPUTE REAL M FOR PURE RSUBR\r
+ HLRS M\r
+ ADD M,PURVEC+1(TVP)\r
+ SKIPN M,1(M) ; SKIP IF LOADED\r
+ JRST FINIS3\r
+ ADDI M,(C) ; POINT TO SUB PART\r
+ JRST @PCSAV(TB)\r
+\r
+FINIS3: PUSH TP,A\r
+ PUSH TP,B\r
+ HLRZ A,1(R) ; RELOAD IT\r
+ PUSHJ P,PLOAD\r
+ JRST PCANT\r
+ POP TP,B\r
+ POP TP,A\r
+ MOVE M,1(R)\r
+ JRST FINIS2\r
+\r
+FINISA: CAIE 0,TATOM\r
+ JRST BADENT\r
+ PUSH TP,A\r
+ PUSH TP,B\r
+ PUSH TP,$TENTER\r
+ HRL C,(C)\r
+ PUSH TP,C\r
+ MOVE B,1(C) ; GET ATOM\r
+ PUSHJ P,IGVAL ; GET VAL\r
+ GETYP 0,A\r
+ CAIE 0,TRSUBR\r
+ JRST BADENT\r
+ MOVE C,(TP)\r
+ HLLM A,(C)\r
+ MOVEM B,1(C)\r
+ MOVE A,-3(TP)\r
+ MOVE B,-2(TP)\r
+ SUB TP,[4,,4]\r
+ JRST FINIS1\r
+\r
+BADENT: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE RSUBR-ENTRY-UNLINKED\r
+ JRST CALER1\r
+\r
+PCANT1: ADD TB,[1,,]\r
+PCANT: PUSH TP,$TATOM\r
+ PUSH TP,EQUOTE PURE-LOAD-FAILURE\r
+ JRST CALER1\r
+ \r
+REPEAT 0,[\r
+BCKTR1: PUSH TP,A ; SAVE VALUE TO BE RETURNED\r
+ PUSH TP,B ; SAVE FRAME ON PP\r
+ PUSHJ P,BCKTRK\r
+ POP TP,B\r
+ POP TP,A\r
+ JRST CNTIN1\r
+]\r
+\f\r
+; SUBR TO ENABLE AND DISABLE LINKING OF RSUBRS AT RUN TIME\r
+\r
+MFUNCTION %RLINK,SUBR,[RSUBR-LINK]\r
+\r
+ ENTRY 1\r
+\r
+ GETYP 0,(AB)\r
+ SETZM NOLINK\r
+ CAIN 0,TFALSE\r
+ SETOM NOLINK\r
+ MOVE A,(AB)\r
+ MOVE B,1(AB)\r
+ JRST FINIS\r
+\r
+;HANDLER FOR DEBUGGING CALL TO PRINT\r
+\r
+DODP":\r
+ PUSH TP, @40\r
+ AOS 40\r
+ PUSH TP,@40\r
+ PUSH P,0\r
+ PUSH P,1\r
+ PUSH P,2\r
+ PUSH P,SAVEC\r
+ PUSH P,4\r
+ PUSH P,5\r
+ PUSH P,40\r
+ PUSH P,UUOH\r
+ MCALL 1,PRINT\r
+ POP P,UUOH\r
+ POP P,40\r
+ POP P,5\r
+ POP P,4\r
+ POP P,3\r
+ POP P,2\r
+ POP P,1\r
+ POP P,0\r
+ JRST 2,@UUOH\r
+\r
+\r
+DFATAL: MOVEM A,20\r
+ MOVEM B,21\r
+ MOVE B,40\r
+ HRLI B,440700\r
+ PUSHJ P,MSGTYP\r
+ JRST 4,.\r
+END\r
+\f\ 3\ 3\ 3
\ No newline at end of file
projects / pdp10-muddle.git / commitdiff