From: Lars Brinkhoff Date: Sat, 9 Apr 2022 11:56:14 +0000 (+0200) Subject: Split up files. X-Git-Url: https://jxself.org/git/?a=commitdiff_plain;h=1c973408824dee4a587c040bc8075cd1bf047ba3;p=pdp10-muddle.git Split up files. --- diff --git a/sumex/agc.mcr273 b/sumex/agc.mcr273 new file mode 100644 index 0000000..b10bc28 --- /dev/null +++ b/sumex/agc.mcr273 @@ -0,0 +1,3868 @@ +TITLE AGC MUDDLE GARBAGE COLLECTOR + +;SYSTEM WIDE DEFINITIONS GO HERE + +.GLOBAL RCL,VECTOP,VECBOT,PARTOP,PARBOT,HITOP,HIBOT,GETPAG +.GLOBAL PDLBUF,PDLEX,PDLEXP,GCFLG,GCPDL,GETNUM,PARNEW,MOVPUR +.GLOBAL PGROW,TPGROW,TIMOUT,MAINPR,%SLEEP,MSGTYP,PURTOP,PURBOT,STOSTR +.GLOBAL MTYI,UPLO,FRMUNG,BYTDOP,GLOBSP,SYSMAX,FREDIF,FREMIN,GCHAPN,INTFLG +.GLOBAL SAT,TTOCHN,TYPVEC,ICONS,INCONS,IBLOCK,IEUVEC,IEVECTI,CELL2 +.GLOBAL GIBLOK,REHASH,IBLOK1,IILIST,IIFORM,CIVEC,CIUVEC,CICONS +.GLOBAL SPBASE,OUTRNG,CISTNG,%RUNAM,PURVEC,GCDOWN,N.CHNS,CHNL1 +.GLOBAL CAFRE,CAFRET,STOGC,GCHN,WNDP,FRNP,%GCJOB,%SHWND,%SHFNT,%INFMP,%GETIP +.GLOBAL TD.PUT,TD.GET,TD.LNT +.GLOBAL CTIME,MTYO,ILOC,GCRSET +.GLOBAL GCTIM,GCCAUS,GCCALL,AAGC,LVLINC,STORIC,GVLINC,TYPIC +; GLOBALS ASSOCIATE WITH THE ASSOCIATION VECTOR + +.GLOBAL ASOVEC,ASOLNT,ITEM,INDIC,VAL,NWORDT,NODPNT,PNTRS +.GLOBAL CELL,BINDID,GCFLCH,TYPBOT,GLOBAS,TPBASE + +.GLOBAL P.TOP,P.CORE,PMAP + +NGCS==8 ; AFTER NGCS, DO HAIRY VAL/ASSOC FLUSH +PDLBUF=100 +TPMAX==20000 ;PDLS LARGER THAN THIS WILL BE SHRUNK +PMAX==4000 ;MAXIMUM PSTACK SIZE +TPMIN==1000 ;MINIMUM PDL SIZES +PMIN==400 +TPGOOD==10000 ; A GOOD STACK SIZE +PGOOD==1000 +.ATOM.==200000 ; FLAG SAYING ATOMS MARKED (FOR VAL FLUSH LOGIC) + +GCHN==0 ; CHANNEL FOR FUNNNY INFERIOR +STATNO==19. ; # OF STATISTICS FOR BLOAT-STAT +STATGC==8. ; # OF GC-STATISTICS FOR BLOAT-STAT + + +RELOCATABLE +.INSRT MUDDLE > + +TYPNT=AB ;SPECIAL AC USAGE DURING GC +F=TP ;ALSO SPECIAL DURING GC +LPVP=SP ;SPECIAL FOR GC, HOLDS POINTER TO PROCESS CHAIN +FPTR=TB ; POINT TO CURRENT FRONTIER OF INFERIOR + + +; WINDOW AND FRONTIER PAGES + +FRONT==776000 ; PAGE 255. IS FRONTIER +WIND==774000 ; PAGE 254. IS WINDOW +FRNP==FRONT/2000 +WNDP==WIND/2000 + + + + + + +.GLOBAL FLIST + +MFUNCTION BLOATSTAT,SUBR,[BLOAT-STAT] + +ENTRY + + JUMPGE AB,GETUVC ; SEE IF THERE IS AN ARGUMENT + GETYP A,(AB) + CAIE A,TUVEC ; SEE IF THE ARGUMENT IS A UVECTOR + JRST WTYP1 ; IF NOT COMPLAIN + HLRE 0,1(AB) + MOVNS 0 + CAIGE 0,STATNO+STATGC ; SEE IF UVECTOR IS RIGHT LENGTH + JRST WTYP1 + CAMGE AB,[-2,,0] ; SEE IF THERE ARE TOO MANY ARGUMENTS + JRST TMA + MOVE A,(AB) ; GET THE UVECTOR + MOVE B,1(AB) + JRST SETUV ; CONTINUE +GETUVC: MOVEI A,STATNO+STATGC ; CREATE A UVECTOR + PUSHJ P,IBLOCK +SETUV: PUSH P,A ; SAVE UVECTOR + PUSH P,B + MOVE 0,NOWFRE ; COMPUTE FREE STORAGE USED SINCE LAST GC + SUB 0,VECBOT + ADD 0,PARTOP + MOVEM 0,CURFRE + HLRE 0,TP ; COMPUTE STACK SPACE USED UP + ADD 0,NOWTP + SUBI 0,PDLBUF + MOVEM 0,CURTP + MOVE B,IMQUOTE THIS-PROCESS + PUSHJ P,ILOC + HRRZS B + HRRZ C,TPBASE+1(PVP) ; CALCULATE # OF ATOM SLOTS + MOVE 0,B + HRRZ D,SPBASE+1(PVP) ; COMPUTE CURRENT # OF BINDINGS + SUB 0,D + IDIVI 0,6 + MOVEM 0,CURLVL + SUB B,C ; TOTAL WORDS ATOM STORAGE + IDIVI B,6 ; COMPUTE # OF SLOTS + MOVEM B,NOWLVL + HRRZ A,GLOBASE+1(TVP) ; COMPUTE TOTAL # OF GLOBAL SLOTS + HLRE 0,GLOBASE+1(TVP) + SUB A,0 ; POINT TO DOPE WORD + HLRZ B,1(A) + ASH B,-2 ; # OF GVAL SLOTS + MOVEM B,NOWGVL + HRRZ 0,GLOBASE+1(TVP) ; COMPUTE # OF GVAL SLOTS IN USE + HRRZ A,GLOBSP+1(TVP) + SUB A,0 + ASH A,-2 ; NEGATIVE # OF SLOTS USED + SUBI B,(A) + MOVEM B,CURGVL + HRRZ A,TYPBOT+1(TVP) ; GET LENGTH OF TYPE VECTOR + HLRE 0,TYPBOT+1(TVP) + SUB A,0 + HLRZ B,1(A) ; # OF WORDS IN TYPE-VECTOR + IDIVI B,2 ; CONVERT TO # OF TYPES + MOVEM B,NOWTYP + HLRE 0,TYPVEC+1(TVP) ; LENGTH OF VISABLE TYPE-VECTOR + MOVNS 0 + IDIVI 0,2 ; GET # OF TYPES + MOVEM 0,CURTYP + MOVE 0,CODTOP ; GET LENGTH OF STATIONARY IMPURE STORAGE + MOVEM 0,NOWSTO + SETZB B,D ; ZERO OUT MAXIMUM + HRRZ C,FLIST +LOOPC: HLRZ 0,(C) ; GET BLK LENGTH + ADD D,0 ; ADD # OF WORDS IN BLOCK + CAMGE B,0 ; SEE IF NEW MAXIMUM + MOVE B,0 + HRRZ C,(C) ; POINT TO NEXT BLOCK + JUMPN C,LOOPC ; REPEAT + MOVEM D,CURSTO + MOVEM B,CURMAX + HLRE 0,P ; GET AMOUNT OF ROOM LEFT ON P + ADD 0,NOWP + SUBI 0,PDLBUF + MOVEM 0,CURP + PUSHJ P,GCSET ; FIX UP BLOAT-STAT PARAMETERS + MOVSI C,BSTGC ; SET UP BLT FOR GC FIGURES + HRRZ B,(P) ; RESTORE B + HRR C,B + BLT C,(B)STATGC-1 + HRLI C,BSTAT ; MODIFY BLT FOR STATS + ADDI C,STATGC ; B HAS ELEMENTS + BLT C,(B)STATGC+STATNO-1 + MOVEI 0,TFIX + HRLM 0,(B)STATNO+STATGC ; MOVE IN UTYPE + POP P,B + POP P,A ; RESTORE TYPE-WORD + JRST FINIS + + +; THIS IS THE SCHEME USED TO UPDATE CERTAIN IMFORMATION USED BY THE +; BLOAT-SPEC ROUTINE TO GIVE USERS IMFORMATION ABOUT USE OF SPACE BY +; THEIR MUDDLE. + +GCRSET: SETZM GCNO ; CALL FROM INIT, ZAP ALL 1ST + MOVE 0,[GCNO,,GCNO+1] + BLT 0,GCCALL + +GCSET: MOVE A,VECBOT ; COMPUTE FREE SPACE AVAILABLE + SUB A,PARTOP + MOVEM A,NOWFRE + CAMLE A,MAXFRE + MOVEM A,MAXFRE ; MODIFY MAXIMUM + HLRE A,TP ; FIND THE DOPE WORD OF THE TP STACK + MOVNS A + ADDI A,1(TP) ; CLOSE TO DOPE WORD + CAME A,TPGROW + ADDI A,PDLBUF ; NOW AT REAL DOPE WORD + HLRZ B,(A) ; GET LENGTH OF TP-STACK + MOVEM B,NOWTP + CAMLE B,CTPMX ; SEE IF THIS IS THE BIGGEST TP + MOVEM B,CTPMX + HLRE B,P ; FIND DOPE WORD OF P-STACK + MOVNS B + ADDI B,1(P) ; CLOSE TO IT + CAME B,PGROW ; SEE IF THE STACK IS BLOWN + ADDI B,PDLBUF ; POINTING TO IT + HLRZ A,(B) ; GET IN LENGTH + MOVEM A,NOWP + CAMLE A,CPMX ; SEE IF WE HAVE THE BIGGEST P STACK + MOVEM A,CPMX + POPJ P, ; EXIT + + +.GLOBAL PGFIND,PGGIVE,PGTAKE,PGINT + +; FIND AND ALLOCATE AS MANY CONTIGUOUS PAGES AS INDICATED BY REG A +; RETURN THE NUMBER (0-255.) OF THE FIRST SUCH PAGE IN REG B +; RETURN -1 IN REG B IF NONE FOUND + +PGFIND: + JUMPLE A,FPLOSS + PUSHJ P,PGFND1 ; SEE IF ALREADY ENOUGH + SKIPL B ; SKIP IF LOST + POPJ P, + + SUBM M,(P) + PUSH P,E + PUSH P,C + PUSH P,D + MOVE C,PURBOT ; CHECK IF ROOM AT ALL + SUB C,P.TOP ; TOTAL SPACE + MOVEI D,(C) ; COPY FOR CONVERSION TO PAGES + ASH D,-10. + CAIGE C,(A) ; SKIP IF COULD WIN + JRST PGFLOS + + MOVNS A ; MOVE PURE AREA DOWN "A" PAGES + PUSHJ P,MOVPUR + MOVE B,PURTOP ; GET FIRST PAGE ALLOCATED + ASH B,-10. ; TO PAGE # +PGFLOS: POP P,D + POP P,C + POP P,E + PUSHJ P,RBLDM ; GET A NEW VALUE FOR M + JRST MPOPJ + +PGFND1: PUSH P,E + PUSH P,D + PUSH P,C + PUSH P,[-1] ;POSSIBLE CONTENTS FOR REG B + PUSH P,A ;SAVE LENGTH OF BLOCK DESIRED FOR LATER USE + SETZB B,C ;INITIAL SECTION AND PAGE NUMBERS + MOVEI 0,0 ;COUNT OF PAGES ALREADY FOUND + PUSHJ P,PINIT +PLOOP: TDNE E,D ;FREE PAGE ? + JRST NOTFRE ;NO + JUMPN 0,NFIRST ;FIRST FREE PAGE OF A BLOCK ? + MOVEI A,(B) ;YES SAVE ADDRESS OF PAGE IN REG A + IMULI A,32. + ADDI A,(C) +NFIRST: ADDI 0,1 + CAML 0,(P) ;TEST IF ENOUGH PAGES HAVE BEEN FOUND + JRST PWIN ;YES, FINISHED + SKIPA +NOTFRE: MOVEI 0,0 ;RESET COUNT + PUSHJ P,PNEXT ;NEXT PAGE + JRST PLOSE ;NONE--LOSE RETURNING -1 IN REG B + JRST PLOOP + +PWIN: MOVEI B,(A) ;GET WINNING ADDRESS + MOVEM B,(P)-1 ;RETURN ADDRESS OF WINNING PAGE + MOVE A,(P) ;RELOAD LENGTH OF BLOCK OF PAGES + MOVE 0,[TDO E,D] ;INST TO SET "BUSY" BITS + JRST ITAKE + +;CLAIM OR RETURN TO FREE STORAGE AS MANY CONTIGUOUS PAGES AS INDICATED BY REG A +;THE NUMBER (0 - 255.) OF THE FIRST SUCH PAGE IS IN REG B +PGGIVE: MOVE 0,[TDZ E,D] ;INST TO SET "FREE" BITS + SKIPA +PGTAKE: MOVE 0,[TDO E,D] ;INST TO SET "BUSY" BITS + JUMPLE A,FPLOSS + CAIL B,0 + CAILE B,255. + JRST FPLOSS + PUSH P,E + PUSH P,D + PUSH P,C + PUSH P,B + PUSH P,A +ITAKE: IDIVI B,32. + PUSHJ P,PINIT + SUBI A,1 +RTL: XCT 0 ;SET APPROPRIATE BIT + PUSHJ P,PNEXT ;NEXT PAGE'S BIT + JUMPG A,FPLOSS ;TOO MANY ? + SOJGE A,RTL + MOVEM E,PMAP(B) ;REPLACE BIT MASK +PLOSE: POP P,A + POP P,B + POP P,C + POP P,D + POP P,E + POPJ P, + + +PINIT: MOVE E,PMAP(B) ;GET BITS FOR THIS SECTION + HRLZI D,400000 ;BIT MASK + MOVNS C + LSH D,(C) ;SHIFT TO APPROPRIATE BIT POSITION + MOVNS C + POPJ P, + +PNEXT: AOS (P) ;FOR SKIP RETURN ON EXPECTED SUCCESS + LSH D,-1 ;CONSIDER NEXT PAGE + CAIGE C,31. ;FINISHED WITH THIS SECTION ? + AOJA C,CPOPJ ;NO, INCREMENT AND CONTINUE + MOVEM E,PMAP(B) ;REPLACE BIT MASK + SETZ C, + CAIGE B,7. ;LAST SECTION ? + AOJA B,PINIT ;NO, INCREMENT AND CONTINUE + SOS (P) ;YES, UNDO SKIP RETURN + POPJ P, + +FPLOSS: FATAL PAGE LOSSAGE + +PGINT: MOVEI B,HIBOT ;INITIALIZE MUDDLE'S PAGE MAP TABLE + IDIVI B,2000 ;FIRST PAGE OF PURE CODE + MOVE C,HITOP + IDIVI C,2000 + MOVEI A,(C)+1 + SUBI A,(B) ;NUMBER OF SUCH PAGES + PUSHJ P,PGTAKE ;MARK THESE PAGES AS TAKEN + POPJ P, +; USER GARBAGE COLLECTOR INTERFACE + +MFUNCTION GC,SUBR + ENTRY + + JUMPGE AB,GC1 + CAMGE AB,[-4,,0] + JRST TMA + PUSHJ P,GETFIX ; GET FREEE MIN IF GIVEN + MOVEM A,FREMIN + ADD AB,[2,,2] ; NEXT ARG + JUMPGE AB,GC1 ; NOT SUPPLIED + PUSHJ P,GETFIX ; GET FREDIF + MOVEM A,FREDIF +GC1: PUSHJ P,COMPRM ; GET CURRENT USED CORE + PUSH P,A + MOVEI A,1 + MOVEM A,GCHAIR ; FORCE FLUSH OF VALS ASSOCS + MOVE C,[11,,0] ; INDICATOR FOR AGC + PUSHJ P,AGC ; COLLECT THAT TRASH + SKIPGE A ; SKIP IF OK + PUSHJ P,FULLOS ; COMPLAIN ABOUT LACK OF SPACE + PUSHJ P,COMPRM ; HOW MUCH ROOM NOW? + POP P,B ; RETURN AMOUNT + SUB B,A + MOVSI A,TFIX + JRST FINIS + + +COMPRM: MOVE A,PARTOP ; USED SPACE + SUB A,PARBOT + ADD A,VECTOP + SUB A,VECBOT + POPJ P, + +MFUNCTION GCDMON,SUBR,[GC-MON] + + ENTRY 1 + + SETZM GCMONF ; ASSUME FALSE + GETYP 0,(AB) + CAIE 0,TFALSE + SETOM GCMONF + MOVE A,(AB) + MOVE B,1(AB) + JRST FINIS +.GLOBAL EVATYP,APLTYP,PRNTYP + + MFUNCTION BLOAT,SUBR + ENTRY + + MOVEI C,0 ; FLAG TO SAY WHETHER NEED A GC + MOVSI E,-NBLO ; AOBJN TO BLOATER TABLE + +BLOAT2: JUMPGE AB,BLOAT1 ; ALL DONE? + PUSHJ P,NXTFIX ; GET NEXT BLOAT PARAM + PUSHJ P,@BLOATER(E) ; DISPATCH + AOBJN E,BLOAT2 ; COUNT PARAMS SET + + JUMPL AB,TMA ; ANY LEFT...ERROR +BLOAT1: JUMPE C,BLOATD ; DONE, NO GC NEEDED + MOVEI 0,1 + MOVEM 0,GCHAIR ; FORCE HAIR TO OCCUR + MOVE C,E ; MOVE IN INDICATOR + HRLI C,1 ; INDICATE THAT IT COMES FROM BLOAT + PUSHJ P,AGC ; DO ONE + SKIPGE A + PUSHJ P,FULLOS ; NO CORE LEFT + SKIPE A,TPBINC ; SMASH POINNTERS + ADDM A,TPBASE+1(PVP) + SKIPE A,GLBINC ; GLOBAL SP + ADDM A,GLOBASE+1(TVP) + SKIPE A,TYPINC + ADDM A,TYPBOT+1(TVP) + SETZM TPBINC ; RESET PARAMS + SETZM GLBINC + SETZM TYPINC + +BLOATD: MOVE B,VECBOT + SUB B,PARTOP + MOVSI A,TFIX ; RETURN CORE FOUND + JRST FINIS + +; TABLE OF BLOAT ROUTINES + +BLOATER: + MAINB + TPBLO + LOBLO + GLBLO + TYBLO + STBLO + PBLO + SFREM + SFRED + SLVL + SGVL + STYP + SSTO + NBLO==.-BLOATER + +; BLOAT MAIN STORAGE AREA + +MAINB: MOVE D,VECBOT ; COMPUTE CURRENT ROOM + SUB D,PARTOP + CAMGE A,D ; NEED MORE? + POPJ P, ; NO, LEAVE + MOVEM A,GETNUM ; SAVE + AOJA C,CPOPJ ; LEAVE SETTING C + +; BLOAT TP STACK (AT TOP) + +TPBLO: HLRE D,TP ; GET -SIZE + MOVNS B,D + ADDI D,1(TP) ; POINT TO DOPE (ALMOST) + CAME D,TPGROW ; BLOWN? + ADDI D,PDLBUF ; POINT TO REAL DOPE WORD + CAMG A,B ; SKIP IF GROWTH NEEDED + POPJ P, + ASH A,-6 ; CONVERT TO 64 WD BLOCKS + CAILE A,377 + JRST OUTRNG + DPB A,[111100,,-1(D)] ; SMASH SPECS IN + AOJA C,CPOPJ + +; BLOAT TOP LEVEL LOCALS + +LOBLO: IMULI A,6 ; 6 WORDS PER BINDING + HRRZ 0,TPBASE+1(PVP) + HRRZ B,SPBASE+1(PVP) ; ROOM AVAIL TO E + SUB B,0 + SUBI A,(B) ; HOW MUCH MORE? + JUMPLE A,CPOPJ ; NONE NEEDED + MOVEI B,TPBINC + PUSHJ P,NUMADJ + DPB A,[1100,,-1(D)] ; SMASH + AOJA C,CPOPJ + +; GLOBAL SLOT GROWER + +GLBLO: ASH A,2 ; 4 WORDS PER VAR + MOVE D,GLOBASE+1(TVP) ; CURRENT LIMITS + HRRZ B,GLOBSP+1(TVP) + SUBI B,(D) + SUBI A,(B) ; NEW AMOUNT NEEDED + JUMPLE A,CPOPJ + MOVEI B,GLBINC ; WHERE TO KEEP UPDATE + PUSHJ P,NUMADJ ; FIX NUMBER + HLRE 0,D + SUB D,0 ; POINT TO DOPE + DPB A,[1100,,(D)] ; AND SMASH + AOJA C,CPOPJ + +; HERE TO GROW TYPE VECTOR (AND FRIENDS) + +TYBLO: ASH A,1 ; TWO WORD PER TYPE + HRRZ B,TYPBOT+1(TVP) ; FIND CURRENT ROOM + MOVE D,TYPVEC+1(TVP) + SUBI B,(D) + SUBI A,(B) ; EXTRA NEEDED TO A + JUMPLE A,CPOPJ ; NONE NEEDED, LEAVE + MOVEI B,TYPINC ; WHERE TO STASH SPEC + PUSHJ P,NUMADJ ; FIX NUMBER + HLRE 0,D ; POINT TO DOPE + SUB D,0 + DPB A,[1100,,(D)] + SKIPE D,EVATYP+1(TVP) ; GROW AUX TYPE VECS IF NEEDED + PUSHJ P,SGROW1 + SKIPE D,APLTYP+1(TVP) + PUSHJ P,SGROW1 + SKIPE D,PRNTYP+1(TVP) + PUSHJ P,SGROW1 + AOJA C,CPOPJ + +; HERE TO CREATE STORAGE SPACE + +STBLO: MOVE D,PARBOT ; HOW MUCH NOW HERE + SUB D,CODTOP + SUBI A,(D) ; MORE NEEDED? + JUMPLE A,CPOPJ + MOVEM A,PARNEW ; FORCE PAIR SPACE TO MOVE ON OUT + AOJA C,CPOPJ + +; BLOAT P STACK + +PBLO: HLRE D,P + MOVNS B,D + SUBI D,5 ; FUDGE FOR THIS CALL + SUBI A,(D) + JUMPLE A,CPOPJ + ADDI B,1(P) ; POINT TO DOPE + CAME B,PGROW ; BLOWN? + ADDI B,PDLBUF ; NOPE, POIN TO REAL D.W. + ASH A,-6 ; TO 64 WRD BLOCKS + CAILE A,377 ; IN RANGE? + JRST OUTRNG + DPB A,[111100,,-1(B)] + AOJA C,CPOPJ + +; SET FREMIN + +SFREM: MOVEM A,FREMIN + POPJ P, + +; SET FREDIF + +SFRED: MOVEM A,FREDIF + POPJ P, + +; SET LVAL INCREMENT + +SLVL: IMULI A,6 ; CALCULATE AMOUNT TO GROW B + IDIVI A,64. ; # OF GROW BLOCKS NEEDED + CAIE B,0 ; DOES B HAVE A REMAINDER + ADDI A,1 ; IF SO ADD A BLOCK + MOVEM A,LVLINC + POPJ P, + +; SET GVAL INCREMENT + +SGVL: IDIVI A,16. ; CALCULATE NUMBER OF GROW BLOCKS NEEDED + CAIE B,0 + ADDI A,1 ; COMPENSATE FOR EXTRA + MOVEM A,GVLINC + POPJ P, + +; SET TYPE INCREMENT + +STYP: IDIVI A,32. ; CALCULATE NUMBER OF GROW BLOCKS NEEDED + CAIE B,0 + ADDI A,1 ; COMPENSATE FOR EXTRA + MOVEM A,TYPIC + POPJ P, + +; SET STORAGE INCREMENT + +SSTO: IDIVI A,2000 ; # OF BLOCKS + CAIE B,0 ; REMAINDER? + ADDI A,1 + IMULI A,2000 ; CONVERT BACK TO WORDS + MOVEM A,STORIC + POPJ P, + + +; GET NEXT (FIX) ARG + +NXTFIX: PUSHJ P,GETFIX + ADD AB,[2,,2] + POPJ P, + +; ROUTINE TO GET POS FIXED ARG + +GETFIX: GETYP A,(AB) + CAIE A,TFIX + JRST WRONGT + SKIPGE A,1(AB) + JRST BADNUM + POPJ P, + + +; GET NUMBERS FIXED UP FOR GROWTH FIELDS + +NUMADJ: ADDI A,77 ; ROUND UP + ANDCMI A,77 ; KILL CRAP + MOVE 0,A + MOVNS A ; COMPUTE ADD FACTOR FOR SPEC. POINTER UPDATE + HRLI A,-1(A) + MOVEM A,(B) ; AND STASH IT + MOVE A,0 + ASH A,-6 ; TO 64 WD BLOCKS + CAILE A,377 ; CHECK FIT + JRST OUTRNG + POPJ P, + +; DO SYMPATHETIC GROWTHS + +SGROW1: HLRE 0,D + SUB D,0 + DPB A,[111100,,(D)] + POPJ P, + + ;FUNCTION TO CONSTRUCT A LIST + +MFUNCTION CONS,SUBR + + ENTRY 2 + GETYP A,2(AB) ;GET TYPE OF 2ND ARG + CAIE A,TLIST ;LIST? + JRST WTYP2 ;NO , COMPLAIN + MOVE C,(AB) ; GET THING TO CONS IN + MOVE D,1(AB) + HRRZ E,3(AB) ; AND LIST + PUSHJ P,ICONS ; INTERNAL CONS + JRST FINIS + +; COMPILER CALL TO CONS + +CICONS: SUBM M,(P) + PUSHJ P,ICONS +MPOPJ: SUBM M,(P) + POPJ P, + +; INTERNAL CONS TO NIL--INCONS + +INCONS: MOVEI E,0 + +; INTERNAL CONS--ICONS; C,D VALUE, E CDR + +ICONS: GETYP A,C ; CHECK TYPE OF VAL + PUSHJ P,NWORDT ; # OF WORDS + SOJN A,ICONS1 ; JUMP IF DEFERMENT NEEDED + PUSHJ P,ICELL2 ; NO DEFER, GET 2 WORDS FROM PAIR SPACE + JRST ICONS2 ; NO CORE, GO GC + HRRI C,(E) ; SET UP CDR +ICONS3: MOVEM C,(B) ; AND STORE + MOVEM D,1(B) +TLPOPJ: MOVSI A,TLIST + POPJ P, + +; HERE IF CONSING DEFERRED + +ICONS1: MOVEI A,4 ; NEED 4 WORDS + PUSHJ P,ICELL ; GO GET 'EM + JRST ICONS2 ; NOT THERE, GC + HRLI E,TDEFER ; CDR AND DEFER + MOVEM E,(B) ; STORE + MOVEI E,2(B) ; POINT E TO VAL CELL + HRRZM E,1(B) + MOVEM C,(E) ; STORE VALUE + MOVEM D,1(E) + JRST TLPOPJ + + + +; HERE TO GC ON A CONS + +ICONS2: PUSH TP,C ; SAVE VAL + PUSH TP,D + PUSH TP,$TLIST + PUSH TP,E ; SAVE VITAL STUFF + MOVEM A,GETNUM ; AMOUNT NEEDED + MOVE C,[3,,1] ; INDICATOR FOR AGC + PUSHJ P,AGC ; ATTEMPT TO WIN + SKIPGE A ; SKIP IF WON + PUSHJ P,FULLOS + MOVE D,-2(TP) ; RESTORE VOLATILE STUFF + MOVE C,-3(TP) + MOVE E,(TP) + SUB TP,[4,,4] + JRST ICONS ; BACK TO DRAWING BOARD + +; SUBROUTINE TO ALLOCATE WORDS IN PAIR SPACE. CALLS AGC IF NEEDED + +CELL2: MOVEI A,2 ; USUAL CASE +CELL: PUSHJ P,ICELL ; INTERNAL + JRST .+2 ; LOSER + POPJ P, + + MOVEM A,GETNUM ; AMOUNT REQUIRED + PUSH P,A ; PREVENT AGC DESTRUCTION + MOVE C,[3,,1] ; INDICATOR FOR AGC + PUSHJ P,AGC + SKIPGE A ; SKIP IF WINNER + PUSHJ P,FULLOS ; REPORT TROUBLE + POP P,A + JRST CELL ; AND TRY AGAIN + +; INTERNAL CELL GETTER, SKIPS IF ROO EXISTS, ELSE DOESN'T + +ICELL2: MOVEI A,2 ; MOST LIKELY CAE +ICELL: SKIPE B,RCL + JRST ICELRC ;SEE IF WE CAN RE-USE A RECYCLE CELL + MOVE B,PARTOP ; GET TOP OF PAIRS + ADDI B,(A) ; BUMP + CAMLE B,VECBOT ; SKIP IF OK. + POPJ P, ; LOSE + EXCH B,PARTOP ; SETUP NEW PARTOP AND RETURN POINTER + PUSH P,B ; MODIFY TOTAL # OF FREE WORDS + MOVE B,USEFRE + ADDI B,(A) + MOVEM B,USEFRE + POP P,B + JRST CPOPJ1 ; SKIP RETURN + +ICELRC: CAIE A,2 + JRST ICELL+2 ;IF HE DOESNT WANT TWO, USE OLD METHOD + PUSH P,A + MOVE A,(B) + HRRZM A,RCL + POP P,A + SETZM (B) ;GIVE HIM A CLEAN RECYCLED CELL + SETZM 1(B) + JRST CPOPJ ;THAT IT + +;SUBROUTINES TO RETURN WORDS NEEDED BASED ON TYPE OR SAT + +NWORDT: PUSHJ P,SAT ;GET STORAGE ALLOC TYPE +NWORDS: CAIG A,NUMSAT ; TEMPLATE? + SKIPL MKTBS(A) ;-ENTRY IN TABLE MEANS 2 NEEDED + SKIPA A,[1] ;NEED ONLY 1 + MOVEI A,2 ;NEED 2 + POPJ P, + + ;FUNCTION TO BUILD A LIST OF MANY ELEMENTS + +MFUNCTION LIST,SUBR + ENTRY + + PUSH P,$TLIST +LIST12: HLRE A,AB ;GET -NUM OF ARGS + SKIPE RCL ;SEE IF WE WANT TO DO ONE AT A TIME + JRST LST12R ;TO GET RECYCLED CELLS + MOVNS A ;MAKE IT + + JUMPE A,LISTN ;JUMP IF 0 + PUSHJ P,CELL ;GET NUMBER OF CELLS + PUSH TP,$TAB + PUSH TP,AB + PUSH TP,(P) ;SAVE IT + PUSH TP,B + SUB P,[1,,1] + LSH A,-1 ;NUMBER OF REAL LIST ELEMENTS + +CHAINL: ADDI B,2 ;LOOP TO CHAIN ELEMENTS + HRRZM B,-2(B) ;CHAIN LAST ONE TO NEXT ONE + SOJG A,.-2 ;LOOP TIL ALL DONE + CLEARM B,-2(B) ;SET THE LAST CDR TO NIL + +; NOW LOBEER THE DATA IN TO THE LIST + + MOVE D,AB ; COPY OF ARG POINTER + MOVE B,(TP) ;RESTORE LIS POINTER +LISTLP: GETYP A,(D) ;GET TYPE + PUSHJ P,NWORDT ;GET NUMBER OF WORDS + SOJN A,LDEFER ;NEED TO DEFER POINTER + GETYP A,(D) ;NOW CLOBBER ELEMENTS + HRLM A,(B) + MOVE A,1(D) ;AND VALUE.. + MOVEM A,1(B) +LISTL2: HRRZ B,(B) ;REST B + ADD D,[2,,2] ;STEP ARGS + JUMPL D,LISTLP + + POP TP,B + POP TP,A + SUB TP,[2,,2] ; CLEANUP STACK + JRST FINIS + + +LST12R: ASH A,-1 ;ONE AT A TIME TO GET RECYCLED CELLS + JUMPE A,LISTN + PUSH P,A ;SAVE COUNT ON STACK + SETZB C,D + SETZM E + PUSHJ P,ICONS + MOVE E,B ;LOOP AND CHAIN TOGETHER + AOSGE (P) + JRST .-3 + PUSH TP,-1(P) ;PUSH ON THE TYPE WE WANT + PUSH TP,B + SUB P,[2,,2] ;CLEAN UP AFTER OURSELVES + JRST LISTLP-2 ;AND REJOIN MAIN STREAM + + +; MAKE A DEFERRED POINTER + +LDEFER: PUSH TP,$TLIST ;SAVE CURRENT POINTER + PUSH TP,B + MOVEM D,1(TB) ; SAVE ARG HACKER + PUSHJ P,CELL2 + MOVE D,1(TB) + GETYPF A,(D) ;GET FULL DATA + MOVE C,1(D) + MOVEM A,(B) + MOVEM C,1(B) + MOVE C,(TP) ;RESTORE LIST POINTER + MOVEM B,1(C) ;AND MAKE THIS BE THE VALUE + MOVSI A,TDEFER + HLLM A,(C) ;AND STORE IT + MOVE B,C + SUB TP,[2,,2] + JRST LISTL2 + +LISTN: MOVEI B,0 + POP P,A + JRST FINIS + +; BUILD A FORM + +MFUNCTION FORM,SUBR + + ENTRY + + PUSH P,$TFORM + JRST LIST12 + + ; COMPILERS CALLS TO FORM AND LIST A/ COUNT ELEMENTS ON STACK + +IILIST: SUBM M,(P) + PUSHJ P,IILST + MOVSI A,TLIST + JRST MPOPJ + +IIFORM: SUBM M,(P) + PUSHJ P,IILST + MOVSI A,TFORM + JRST MPOPJ + +IILST: JUMPE A,IILST0 ; NIL WHATSIT + PUSH P,A + MOVEI E,0 +IILST1: POP TP,D + POP TP,C + PUSHJ P,ICONS ; CONS 'EM UP + MOVEI E,(B) + SOSE (P) ; COUNT + JRST IILST1 + + SUB P,[1,,1] + POPJ P, + +IILST0: MOVEI B,0 + POPJ P, + + ;FUNCTION TO BUILD AN IMPLICIT LIST + +MFUNCTION ILIST,SUBR + ENTRY + PUSH P,$TLIST +ILIST2: JUMPGE AB,TFA ;NEED AT LEAST ONE ARG + CAMGE AB,[-4,,0] ;NO MORE THAN TWO ARGS + JRST TMA + PUSHJ P,GETFIX ; GET POS FIX # + JUMPE A,LISTN ;EMPTY LIST ? + CAML AB,[-2,,0] ;ONLY ONE ARG? + JRST LOSEL ;YES + PUSH P,A ;SAVE THE CURRENT VALUE OF LENGTH FOR LOOP ITERATION +ILIST0: PUSH TP,2(AB) + PUSH TP,(AB)3 + MCALL 1,EVAL + PUSH TP,A + PUSH TP,B + SOSLE (P) + JRST ILIST0 + POP P,C +ILIST1: MOVE C,(AB)+1 ;REGOBBLE LENGTH + ACALL C,LIST +ILIST3: POP P,A ; GET FINAL TYPE + JRST FINIS + + +LOSEL: PUSH P,A ; SAVE COUNT + MOVEI E,0 + +LOSEL1: SETZB C,D ; TLOSE,,0 + PUSHJ P,ICONS + MOVEI E,(B) + SOSLE (P) + JRST LOSEL1 + + SUB P,[1,,1] + JRST ILIST3 + +; IMPLICIT FORM + +MFUNCTION IFORM,SUBR + + ENTRY + PUSH P,$TFORM + JRST ILIST2 + + ; IVECTOR AND IUVECTOR--GET VECTOR AND UVECTOR OF COMPUTED VALUES + +MFUNCTION VECTOR,SUBR,[IVECTOR] + + MOVEI C,1 + JRST VECTO3 + +MFUNCTION UVECTOR,SUBR,[IUVECTOR] + + MOVEI C,0 +VECTO3: ENTRY + JUMPGE AB,TFA ; AT LEAST ONE ARG + CAMGE AB,[-4,,0] ; NOT MORE THAN 2 + JRST TMA + PUSHJ P,GETFIX ; GET A POS FIXED NUMBER + LSH A,(C) ; A-> NUMBER OF WORDS + PUSH P,C ; SAVE FOR LATER + PUSHJ P,IBLOCK ; GET BLOCK (TURN ON BIT APPROPRIATELY) + POP P,C + HLRE A,B ; START TO + SUBM B,A ; FIND DOPE WORD + JUMPE C,VECTO4 + MOVSI D,400000 ; GET NOT UNIFORM BIT + MOVEM D,(A) ; INTO DOPE WORD + SKIPA A,$TVEC ; GET TYPE +VECTO4: MOVSI A,TUVEC + CAML AB,[-2,,0] ; SKIP IF ARGS NEED TO BE HACKED + JRST FINIS + JUMPGE B,FINIS ; DON'T EVAL FOR EMPTY CASE + + PUSH TP,A ; SAVE THE VECTOR + PUSH TP,B + PUSH TP,A + PUSH TP,B + + JUMPE C,UINIT + JUMPGE B,FINIS ; EMPTY VECTOR, LEAVE +INLP: PUSHJ P,IEVAL ; EVAL EXPR + MOVEM A,(C) + MOVEM B,1(C) + ADD C,[2,,2] ; BUMP VECTOR + MOVEM C,(TP) + JUMPL C,INLP ; IF MORE DO IT + +GETVEC: MOVE A,-3(TP) + MOVE B,-2(TP) + SUB TP,[4,,4] + JRST FINIS + +; HERE TO FILL UP A UVECTOR + +UINIT: PUSHJ P,IEVAL ; HACK THE 1ST VALUE + GETYP A,A ; GET TYPE + PUSH P,A ; SAVE TYPE + PUSHJ P,NWORDT ; SEE IF IT CAN BE UNIFORMED + SOJN A,CANTUN ; COMPLAIN +STJOIN: MOVE C,(TP) ; RESTORE POINTER + ADD C,1(AB) ; POINT TO DOPE WORD + MOVE A,(P) ; GET TYPE + HRLZM A,(C) ; STORE IN D.W. + MOVE C,(TP) ; GET BACK VECTOR + SKIPE 1(AB) + JRST UINLP1 ; START FILLING UV + JRST GETVE1 + +UINLP: MOVEM C,(TP) ; SAVE PNTR + PUSHJ P,IEVAL ; EVAL THE EXPR + GETYP A,A ; GET EVALED TYPE + CAIE A,@(P) ; WINNER? + JRST WRNGSU ; SERVICE ERROR FOR UVECTOR,STORAGE +UINLP1: MOVEM B,(C) ; STORE + AOBJN C,UINLP +GETVE1: SUB P,[1,,1] + JRST GETVEC ; AND RETURN VECTOR + +IEVAL: PUSH TP,2(AB) + PUSH TP,3(AB) + MCALL 1,EVAL + MOVE C,(TP) + POPJ P, + +; ISTORAGE -- GET STORAGE OF COMPUTED VALUES + +MFUNCTION ISTORAGE,SUBR + ENTRY + JUMPGE AB,TFA + CAMGE AB,[-4,,0] ; AT LEAST ONE ARG + JRST TMA + PUSHJ P,GETFIX ; POSITIVE COUNT FIRST ARG + PUSHJ P,CAFRE ; GET CORE + MOVN B,1(AB) ; -COUNT + HRL A,B ; PUT IN LHW (A) + MOVM B,B ; +COUNT + HRLI B,2(B) ; LENGTH + 2 + ADDI B,(A) ; MAKE POINTER TO DOPE WORDS + HLLZM B,1(B) ; PUT TOTAL LENGTH IN 2ND DOPE + HRRM A,1(B) ; PUT ADDRESS IN RHW (STORE DOES THIS TOO). + MOVE B,A + MOVSI A,TSTORAGE + CAML AB,[-2,,0] ; SECOND ARG TO EVAL? + JRST FINIS ; IF NOT, RETURN EMPTY + PUSH TP,A + PUSH TP,B + PUSH TP,A + PUSH TP,B + PUSHJ P,IEVAL ; EVALUATE FOR FIRST VALUE + GETYP A,A + PUSH P,A ; FOR COMPARISON LATER + PUSHJ P,SAT + CAIN A,S1WORD + JRST STJOIN ;TREAT LIKE A UVECTOR + ; IF NOT 1-WORD TYPES, CANNOT STORE, SO COMPLAIN + PUSHJ P,FREESV ; FREE STORAGE VECTOR + PUSH TP,$TATOM + PUSH TP,EQUOTE DATA-CAN'T-GO-IN-STORAGE + JRST CALER1 + +; FOR STORAGE, MUST FREE THE CORE ELSE IT IS LOST (NO GC) +FREESV: MOVE A,1(AB) ; GET COUNT + ADDI A,2 ; FOR DOPE + HRRZ B,(TP) ; GET ADDRESS + PUSHJ P,CAFRET ; FREE THE CORE + POPJ P, + + ; INTERNAL VECTOR ALLOCATOR. A/SIZE OF VECTOR (NOT INCLUDING DOPE WORDS) + +IBLOK1: ASH A,1 ; TIMES 2 +GIBLOK: TLOA A,400000 ; FUNNY BIT +IBLOCK: TLZ A,400000 ; NO BIT ON + ADDI A,2 ; COMPENSATE FOR DOPE WORDS +IBLOK2: MOVE B,VECBOT ; POINT TO BOTTOM OF SPACE + SUBI B,(A) ; SUBTRACT NEEDED AMOUNT + CAMGE B,PARTOP ; SKIP IF NO GC NEEDED + JRST IVECT1 + EXCH B,VECBOT ; WIN, GET POINTER TO BLOCK AND UPDATE VECBOT + PUSH P,B + MOVE B,USEFRE + ADDI B,(A) + MOVEM B,USEFRE + POP P,B + HRLZM A,-1(B) ; STORE LENGTH IN DOPE WORD + HLLZM A,-2(B) ; AND BIT + HRRO B,VECBOT ; POINT TO START OF VECTOR + TLC B,-3(A) ; SETUP COUNT + HRRI A,TVEC + SKIPL A + HRRI A,TUVEC + MOVSI A,(A) + POPJ P, + +; HERE TO DO A GC ON A VECTOR ALLOCATION + +IVECT1: PUSH P,A ; SAVE DESIRED LENGTH + HRRZM A,GETNUM ; AND STORE AS DESIRED AMOUNT + MOVE C,[4,,1] ; GET INDICATOR FOR AGC + PUSHJ P,AGC + SKIPGE A + PUSHJ P,FULLOS ; LOST, COMPLAIN + POP P,A + JRST IBLOK2 + + +; INTERNAL EVECTOR (CALLED FROM READ) A/ #OF THINGS +; ITEMS ON TOP OF STACK + +IEVECT: ASH A,1 ; TO NUMBER OF WORDS + PUSH P,A + PUSHJ P,IBLOCK ; GET VECTOR + HLRE D,B ; FIND DW + SUBM B,D ; A POINTS TO DW + MOVSI 0,400000 + MOVEM 0,(D) ; CLOBBER NON UNIF BIT + POP P,A ; RESTORE COUNT + JUMPE A,IVEC1 ; 0 LNTH, DONE + MOVEI C,(TP) ; BUILD BLT + SUBI C,(A)-1 ; C POINTS TO 1ST ITEM ON STACK + MOVSI C,(C) + HRRI C,(B) ; B/ SOURCE,,DEST + BLT C,-1(D) ; XFER THE DATA + HRLI A,(A) + SUB TP,A ; FLUSH STACKAGE +IVEC1: MOVSI A,TVEC + POPJ P, + + +; COMPILERS CALL + +CIVEC: SUBM M,(P) + PUSHJ P,IEVECT + JRST MPOPJ + + + ; INTERNAL CALL TO EUVECTOR + +IEUVEC: PUSH P,A ; SAVE LENGTH + PUSHJ P,IBLOCK + MOVE A,(P) + JUMPE A,IEUVE1 ; EMPTY, LEAVE + ASH A,1 ; NOW FIND STACK POSITION + MOVEI C,(TP) ; POINT TO TOP + MOVE D,B ; COPY VEC POINTER + SUBI C,-1(A) ; POINT TO 1ST DATUM + GETYP A,(C) ; CHECK IT + PUSHJ P,NWORDT + SOJN A,CANTUN ; WONT FIT + GETYP E,(C) + +IEUVE2: GETYP 0,(C) ; TYPE OF EL + CAIE 0,(E) ; MATCH? + JRST WRNGUT + MOVE 0,1(C) + MOVEM 0,(D) ; CLOBBER + ADDI C,2 + AOBJN D,IEUVE2 ; LOOP + HRLZM E,(D) ; STORE UTYPE +IEUVE1: POP P,A ; GET COUNY + ASH A,1 ; MUST FLUSH 2 TIMES # OF ELEMENTS + HRLI A,(A) + SUB TP,A ; CLEAN UP STACK + MOVSI A,TUVEC + POPJ P, + +; COMPILER'S CALL + +CIUVEC: SUBM M,(P) + PUSHJ P,IEUVEC + JRST MPOPJ + +MFUNCTION EVECTOR,SUBR,[VECTOR] + ENTRY + HLRE A,AB + MOVNS A + PUSH P,A ;SAVE NUMBER OF WORDS + PUSHJ P,IBLOCK ; GET WORDS + MOVEI D,-1(B) ; SETUP FOR BLT AND DOPE CLOBBER + JUMPGE B,FINISV ;DONT COPY A ZERO LENGTH VECTOR + + HRLI C,(AB) ;START BUILDING BLT POINTER + HRRI C,(B) ;TO ADDRESS + ADDI D,@(P) ;SET D TO FINAL ADDRESS + BLT C,(D) +FINISV: MOVSI 0,400000 + MOVEM 0,1(D) ; MARK AS GENERAL + SUB P,[1,,1] + MOVSI A,TVEC + JRST FINIS + + + + ;EXPLICIT VECTORS FOR THE UNIFORM CSE + +MFUNCTION EUVECTOR,SUBR,[UVECTOR] + + ENTRY + HLRE A,AB ;-NUM OF ARGS + MOVNS A + ASH A,-1 ;NEED HALF AS MANY WORDS + PUSH P,A + JUMPGE AB,EUV1 ; DONT CHECK FOR EMPTY + GETYP A,(AB) ;GET FIRST ARG + PUSHJ P,NWORDT ;SEE IF NEEDS EXTRA WORDS + SOJN A,CANTUN +EUV1: POP P,A + PUSHJ P,IBLOCK ; GET VECT + JUMPGE B,FINISU + + GETYP C,(AB) ;GET THE FIRST TYPE + MOVE D,AB ;COPY THE ARG POINTER + MOVE E,B ;COPY OF RESULT + +EUVLP: GETYP 0,(D) ;GET A TYPE + CAIE 0,(C) ;SAME? + JRST WRNGUT ;NO , LOSE + MOVE 0,1(D) ;GET GOODIE + MOVEM 0,(E) ;CLOBBER + ADD D,[2,,2] ;BUMP ARGS POINTER + AOBJN E,EUVLP + + HRLM C,(E) ;CLOBBER UNIFORM TYPE IN +FINISU: MOVSI A,TUVEC + JRST FINIS + +WRNGSU: GETYP A,-1(TP) + CAIE A,TSTORAGE + JRST WRNGUT ;IF UVECTOR + PUSHJ P,FREESV ;FREE STORAGE VECTOR + PUSH TP,$TATOM + PUSH TP,EQUOTE TYPES-DIFFER-IN-STORAGE-OBJECT + JRST CALER1 + + +WRNGUT: PUSH TP,$TATOM + PUSH TP,EQUOTE TYPES-DIFFER-IN-UNIFORM-VECTOR + JRST CALER1 + +CANTUN: PUSH TP,$TATOM + PUSH TP,EQUOTE DATA-CANT-GO-IN-UNIFORM-VECTOR + JRST CALER1 + +BADNUM: PUSH TP,$TATOM + PUSH TP,EQUOTE NEGATIVE-ARGUMENT + JRST CALER1 + ; FUNCTION TO GROW A VECTOR + +MFUNCTION GROW,SUBR + + ENTRY 3 + + MOVEI D,0 ;STACK HACKING FLAG + GETYP A,(AB) ;FIRST TYPE + PUSHJ P,SAT ;GET STORAGE TYPE + GETYP B,2(AB) ;2ND ARG + CAIE A,STPSTK ;IS IT ASTACK + CAIN A,SPSTK + AOJA D,GRSTCK ;YES, WIN + CAIE A,SNWORD ;UNIFORM VECTOR + CAIN A,S2NWORD ;OR GENERAL +GRSTCK: CAIE B,TFIX ;IS 2ND FIXED + JRST WTYP2 ;COMPLAIN + GETYP B,4(AB) + CAIE B,TFIX ;3RD ARG + JRST WTYP3 ;LOSE + + MOVEI E,1 ;UNIFORM/GENERAL FLAG + CAIE A,SNWORD ;SKIP IF UNIFORM + CAIN A,SPSTK ;DONT SKIP IF UNIFORM PDL + MOVEI E,0 + + HRRZ B,1(AB) ;POINT TO START + HLRE A,1(AB) ;GET -LENGTH + SUB B,A ;POINT TO DOPE WORD + SKIPE D ;SKIP IF NOT STACK + ADDI B,PDLBUF ;FUDGE FOR PDL + HLLZS (B) ;ZERO OUT GROWTH SPECS + SKIPN A,3(AB) ;ANY TOP GROWTH? + JRST GROW1 ;NO, LOOK FOR BOTTOM GROWTH + ASH A,(E) ;MULT BY 2 IF GENERAL + ADDI A,77 ;ROUND TO NEAREST BLOCK + ANDCMI A,77 ;CLEAR LOW ORDER BITS + ASH A,9-6 ;DIVIDE BY 100 AND SHIFT TO POSTION + TRZE A,400000 ;CONVERT TO SIGN MAGNITUDE + MOVNS A + TLNE A,-1 ;SKIP IF NOT TOO BIG + JRST GTOBIG ;ERROR +GROW1: SKIPN C,5(AB) ;CHECK LOW GROWTH + JRST GROW4 ;NONE, SKIP + ASH C,(E) ;GENRAL FUDGE + ADDI C,77 ;ROUND + ANDCMI C,77 ;FUDGE FOR VALUE RETURN + PUSH P,C ;AND SAVE + ASH C,-6 ;DIVIDE BY 100 + TRZE C,400 ;CONVERT TO SIGN MAGNITUDE + MOVNS C + TDNE C,[-1,,777000] ;CHECK FOR OVERFLOW + JRST GTOBIG +GROW2: HLRZ E,1(B) ;GET TOTAL LENGTH OF VECTOR + MOVNI E,-1(E) + HRLI E,(E) ;TO BOTH HALVES + ADDI E,1(B) ;POINTS TO TOP + SKIPE D ;STACK? + ADD E,[PDLBUF,,0] ;YES, FUDGE LENGTH + SKIPL D,(P) ;SHRINKAGE? + JRST GROW3 ;NO, CONTINUE + MOVNS D ;PLUSIFY + HRLI D,(D) ;TO BOTH HALVES + ADD E,D ;POINT TO NEW LOW ADDR +GROW3: IORI A,(C) ;OR TOGETHER + HRRM A,(B) ;DEPOSIT INTO DOPEWORD + PUSH TP,(AB) ;PUSH TYPE + PUSH TP,E ;AND VALUE + JUMPE A,.+3 ;DON'T GC FOR NOTHING + MOVE C,[2,,0] ; GET INDICATOR FOR AGC + PUSHJ P,AGC + JUMPL A,GROFUL + POP P,C ;RESTORE GROWTH + HRLI C,(C) + POP TP,B ;GET VECTOR POINTER + SUB B,C ;POINT TO NEW TOP + POP TP,A + JRST FINIS + +GROFUL: SUB P,[1,,1] ; CLEAN UP STACK + SUB TP,[2,,2] + PUSHJ P,FULLOS + JRST GROW + +GTOBIG: PUSH TP,$TATOM + PUSH TP,EQUOTE ATTEMPT-TO-GROW-VECTOR-TOO-MUCH + JRST CALER1 +GROW4: PUSH P,[0] ;0 BOTTOM GROWTH + JRST GROW2 + +FULLOS: PUSH TP,$TATOM ; GENERATE ERROR + PUSH TP,@ERRTB(A) + AOJL A,CALER1 ; IF BAD, CALL ERROR + SKIPN GCMONF + POPJ P, + PUSH TP,TTOCHN(TVP) ; FORCE MESSAGES TO TTY + PUSH TP,TTOCHN+1(TVP) + PUSH TP,TTOCHN(TVP) ; FORCE MESSAGES TO TTY + PUSH TP,TTOCHN+1(TVP) + MCALL 1,TERPRI ; JUST PRINT MESSAGE + MCALL 2,PRINC + POPJ P, + + + EQUOTE STILL-NO-STORAGE + EQUOTE NO-STORAGE + EQUOTE STORAGE-LOW +ERRTB==. + ; SUBROUTINE TO BUILD CHARACTER STRING GOODIES + +MFUNCTION STRING,SUBR + + ENTRY + + MOVE B,AB ;COPY ARG POINTER + MOVEI C,0 ;INITIALIZE COUNTER + PUSH TP,$TAB ;SAVE A COPY + PUSH TP,B + HLRE A,B ; GET # OF ARGS + MOVNS A + ASH A,-1 ; 1/2 FOR # OF ARGS + PUSHJ P,IISTRN + JRST FINIS + +IISTRN: SKIPN E,A ; SKIP IF ARGS EXIST + JRST MAKSTR ; ALL DONE + +STRIN2: GETYP D,(B) ;GET TYPE CODE + CAIN D,TCHRS ;SINGLE CHARACTER? + AOJA C,STRIN1 + CAIE D,TCHSTR ;OR STRING + JRST WRONGT ;NEITHER + HRRZ D,(B) ; GET CHAR COUNT + ADDI C,(D) ; AND BUMP + +STRIN1: ADD B,[2,,2] + SOJG A,STRIN2 + +; NOW GET THE NECESSARY VECTOR + +MAKSTR: PUSH P,C ; SAVE CHAR COUNT + PUSH P,E ; SAVE ARG COUNT + MOVEI A,4(C) ; LNTH+4 TO A + IDIVI A,5 + PUSHJ P,IBLOCK + + POP P,A + JUMPGE B,DONEC ; 0 LENGTH, NO STRING + HRLI B,440700 ;CONVERT B TO A BYTE POINTER + MOVE C,(TP) ; POINT TO ARGS AGAIN + +NXTRG1: GETYP D,(C) ;GET AN ARG + CAIE D,TCHRS + JRST TRYSTR + MOVE D,1(C) ; GET IT + IDPB D,B ;AND DEPOSIT IT + JRST NXTARG + +TRYSTR: MOVE E,1(C) ;GET BYTER + HRRZ 0,(C) ;AND COUNT +NXTCHR: SOJL 0,NXTARG ; IF RUNOUT, GET NEXT ARG + ILDB D,E ;AND GET NEXT + IDPB D,B ; AND DEPOSIT SAME + JRST NXTCHR + +NXTARG: ADD C,[2,,2] ;BUMP ARG POINTER + SOJG A,NXTRG1 + ADDI B,1 + +DONEC: MOVSI C,TCHRS + HLLM C,(B) ;AND CLOBBER AWAY + HLRZ C,1(B) ;GET LENGTH BACK + POP P,A + HRLI A,TCHSTR + SUBI B,-2(C) + HRLI B,440700 ;MAKE A BYTE POINTER + POPJ P, + +; COMPILER'S CALL TO MAKE A STRING + +CISTNG: SUBM M,(P) + MOVEI C,0 ; INIT CHAR COUNTER + MOVEI B,(A) ; SET UP STACK POINTER + ASH B,1 ; * 2 FOR NO. OF SLOTS + HRLI B,(B) + SUBM TP,B ; B POINTS TO ARGS + ADD B,[1,,1] + PUSH TP,$TTP + PUSH TP,B + PUSHJ P,IISTRN ; MAKE IT HAPPEN + POP TP,TP ; FLUSH ARGS + SUB TP,[1,,1] + JRST MPOPJ + ;BUILD IMPLICT STRING + +MFUNCTION ISTRING,SUBR + + ENTRY + JUMPGE AB,TFA ; TOO FEW ARGS + CAMGE AB,[-4,,0] ; VERIFY NOT TOO MANY ARGS + JRST TMA + PUSHJ P,GETFIX + ADDI A,4 + IDIVI A,5 ; # OF WORDS NEEDED TO A + PUSH TP,$TFIX + PUSH TP,A + MCALL 1,UVECTOR ; GET SAME + HLRE C,B ; -LENGTH TO C + SUBM B,C ; LOCN OF DOPE WORD TO C + HRLI D,TCHRS ; CLOBBER ITS TYPE + HLLM D,(C) + MOVSI A,TCHSTR + HRR A,1(AB) ; SETUP TYPE'S RH + HRLI B,440700 ; AND BYTE POINTER + SKIPE (AB)+1 ; SKIP IF NO CHARACTERS TO DEPOSIT + CAML AB,[-2,,0] ; SKIP IF 2 ARGS GIVEN + JRST FINIS + PUSH TP,A ;SAVE OUR STRING + PUSH TP,B + PUSH TP,A ;SAVE A TEMPORARY CLOBBER POINTER + PUSH TP,B + PUSH P,(AB)1 ;SAVE COUNT +CLOBST: PUSH TP,(AB)+2 + PUSH TP,(AB)+3 + MCALL 1,EVAL + GETYP C,A ; CHECK IT + CAIE C,TCHRS ; MUST BE A CHARACTER + JRST WTYP2 + IDPB B,(TP) ;CLOBBER + SOSLE (P) ;FINISHED? + JRST CLOBST ;NO + SUB P,[1,,1] + SUB TP,[4,,4] + MOVE A,(TP)+1 + MOVE B,(TP)+2 + JRST FINIS + + + AGC": +;SET FLAG FOR INTERRUPT HANDLER + + SETZB M,RCL ; CLEAR OUT RECYCLE LIST CELLS, AND RSUBR BASE PNTR + PUSH P,B + PUSH P,A + PUSH P,C ; SAVE C + PUSHJ P,CTIME ; GET TIME FOR GIN-GOUT + MOVEM B,GCTIM ; SAVE FOR LATER + MOVEI B,[ASCIZ /GIN /] + SKIPE GCMONF + PUSHJ P,MSGTYP +NOMON1: HRRZ C,(P) ; GET CAUSE OF GC INDICATOR + MOVE B,GCNO(C) ; ADD 1 TO COUNT OF GC'S CAUSED BY GIVEN REASON + ADDI B,1 + MOVEM B,GCNO(C) + MOVEM C,GCCAUS ; SAVE CAUSE OF GC + SKIPN GCMONF ; MONITORING + JRST NOMON2 + MOVE B,MSGGCT(C) ; GET CAUSE MESSAGE + PUSHJ P,MSGTYP +NOMON2: HLRZ C,(P) ; FIND OUT WHO CAUSED THE GC + MOVEM C,GCCALL ; SAVE CALLER OF GC + SKIPN GCMONF ; MONITORING + JRST NOMON3 + MOVE B,MSGGFT(C) + PUSHJ P,MSGTYP +NOMON3: SUB P,[1,,1] ; POP OFF C + POP P,A + POP P,B + JRST .+1 +AAGC: SETZB M,RCL ; ALTERNATE GC-ENTRY POINT FOR INITIALIZATION +INITGC: SETOM GCFLG + +;SAVE AC'S + IRP AC,,[0,A,B,C,D,E,P,R,M,SP,TP,TB,AB,TVP,PVP] + MOVEM AC,AC!STO"+1(PVP) + TERMIN + +; FUDGE NOWFRE FOR LATER WINNING + + MOVE 0,NOWFRE + SUB 0,VECBOT + ADD 0,PARTOP + MOVEM 0,NOWFRE + +; IF IN A PURE RSUBR, FIND ITS LENGTH AND FUDGE ITS LRU + + HRRZ A,FSAV(TB) ; GET NAME OF CURRENT GOODIE + SETZM CURPLN ; CLEAR FOR NONE + CAML A,PURTOP ; IF LESS THAN TOP OF PURE ASSUME RSUBR + JRST NRSUBR + GETYP 0,(A) ; SEE IF PURE + CAIE 0,TPCODE ; SKIP IF IT IS + JRST NRSUBR + HLRZ B,1(A) ; GET SLOT INDICATION + ADD B,PURVEC+1(TVP) ; POINT TO SLOT + HRROS 2(B) ; MUNG AGE + HLRE A,1(B) ; - LENGTH TO A + MOVNM A,CURPLN ; AND STORE +NRSUBR: + +;SET UP E TO POINT TO TYPE VECTOR + GETYP E,TYPVEC(TVP) + CAIE E,TVEC + JRST AGCE1 + HRRZ TYPNT,TYPVEC+1(TVP) + HRLI TYPNT,B + +CHPDL: MOVE D,P ; SAVE FOR LATER + MOVE P,GCPDL ;GET GC'S PDL +CORGET: MOVE A,P.TOP ; UPDATE CORTOP + MOVEM A,CORTOP + MOVE A,VECTOP ; ROOM BETWEEN CORTOP AND VECTOP IS GC MARK PDL + SUB A,CORTOP + MOVSS A ; BUILD A PDL POINTER + ADD A,VECTOP + JUMPGE A,TRYCOR ; NO ROOM, GO GET SOME + MOVE P,A ; SET UP PDL POINTER + +;FENCE POST PDLS AND CHECK IF ANY SHOULD BE SHRUNK + + MOVEI A,(TB) ;POINT TO CURRENT FRAME IN PROCESS + PUSHJ P,FRMUNG ;AND MUNG IT + MOVE A,TP ;THEN TEMPORARY PDL + PUSHJ P,PDLCHK + MOVE A,PSTO+1(PVP) ;AND UNMARKED P STACK + PUSHJ P,PDLCHP + + ; FIRST CREATE INFERIOR TO HOLD NEW PAGES + +INFCRT: MOVE A,PARBOT ; GENERATE NEW PARBOT AND PARNEW + ADD A,PARNEW + ADDI A,1777 + ANDCMI A,1777 ; EVEN PAGE BOUNDARY + HRRM A,BOTNEW ; INTO POINTER WORD + MOVEM A,WNDBOT + MOVEI 0,2000(A) ; BOUNDS OF WINDOW + MOVEM 0,WNDTOP + SUB A,PARBOT + MOVEM A,PARNEW ; FIXED UP PARNEW + HRRZ A,BOTNEW ; GET PAGE TO START INF AT + ASH A,-10. ; TO PAGES + PUSHJ P,%GCJOB ; GET PAGE HOLDER + MOVSI FPTR,-2000 ; FIX UP FRONTIER POINTER + +;MARK PHASE: MARK ALL LISTS AND VECTORS +;POINTED TO WITH ONE BIT IN SIGN BIT +;START AT TRANSFER VECTOR + + SETZB LPVP,VECNUM ;CLEAR NUMBER OF VECTOR WORDS + SETZB PARNUM ;CLEAR NUMBER OF PAIRS + MOVEI 0,NGCS ; SEE IF NEED HAIR + SOSGE GCHAIR + MOVEM 0,GCHAIR ; RESUME COUNTING + SETZM GREW ; ASSUME NO GROW/SHRINK + SETZM SHRUNK + MOVSI D,400000 ;SIGN BIT FOR MARKING + MOVE A,ASOVEC+1(TVP) ;MARK ASSOC. VECTOR NOW + PUSHJ P,PRMRK ; PRE-MARK + MOVE A,GLOBSP+1(TVP) + PUSHJ P,PRMRK + +; HAIR TO DO AUTO CHANNEL CLOSE + + MOVEI 0,N.CHNS-1 ; NUMBER OF CHANNELS + MOVEI A,CHNL1(TVP) ; 1ST SLOT + + SKIPE 1(A) ; NOW A CHANNEL? + SETZM (A) ; DON'T MARK AS CHANNELS + ADDI A,2 + SOJG 0,.-3 + + MOVE A,PVP ;START AT PROCESS VECTOR + MOVEI B,TPVP ;IT IS A PROCESS VECTOR + PUSHJ P,MARK ;AND MARK THIS VECTOR + MOVEI B,TPVP + MOVE A,MAINPR ; MARK MAIN PROCES EVEN IF SWAPPED OUT + PUSHJ P,MARK + +; ASSOCIATION AND VALUE FLUSHING PHASE + + SKIPN GCHAIR ; ONLY IF HAIR + PUSHJ P,VALFLS + + SKIPE GCHAIR ; IF NOT HAIR, DO CHANNELS NOW + PUSHJ P,CHNFLS + +;OPTIONAL RETIMING PHASE +;THIS HAS BEEN FLUSHED BECAUSE OF PLANNER + REPEAT 0,[ + SKIPE A,TIMOUT ;ANY TIME OVERFLOWS + PUSHJ P,RETIME ;YES, RE-CALIBRATE THEM +] +;UPDATE PARTOP + + MOVEI A,@BOTNEW + SUB A,PARNEW + MOVEM A,PARTOP + +;CORE ADJUSTMENT PHASE + MOVE P,GCPDL ; GET A PDL + SETZM CORSET ;CLEAR LATER CORE SETTING + PUSHJ P,CORADJ ;AND MAKE CORE ADJUSTMENTS + +;RELOCATION ESTABLISHMENT PHASE +;1 -- IN VECTOR SPACE, ESTABLISH POINTERS TO TOP OF CORE + MOVE A,VECTOP" ;START AT TOP OF VECTOR SPACE + MOVE B,VECNEW" ;AND SET TO INITIAL OFFSET + SUBI A,1 ;POINT TO DOPE WORDS + ADDI B,(A) ; WHERE TOP VECTOR WILL GO + PUSHJ P,VECREL ;AND ESTABLISH RELOCATION FOR VECTORS + SUBI B,(A) ; RE-RELATIVIZE VECNEW + MOVEM B,VECNEW ;SAVE FINAL OFFSET + + + ; MAP NEW PAIR SPACE IN FOR PAIR SPACE UPDATE + + MOVE B,PARTOP ; POINT TO TOP OF PAIRS + ADDI B,2000 + ANDCMI B,1777 + CAMGE B,VECBOT ; OVERLAP VECTORS + JRST DOMAP + MOVE C,VECBOT + ANDI C,1777 ; REL TO PAGE + ADDI C,FRONT ; 1ST DEST WORD + HRL C,VECBOT + BLT C,FRONT+1777 ; MUNG IT + +DOMAP: ASH B,-10. ; TO PAGES + MOVE A,PARBOT + MOVEI C,(A) ; COMPUTE HIS TOP + ADD C,PARNEW + ASH C,-10. + ASH A,-10. + SUBM A,B ; B==> - # OF PAGES + HRLI A,(B) ; AOBJN TO SOURCE AND DEST + MOVE B,A ; IN CASE OF FUNNY + HRRI B,(C) ; MAP HIS POSSIBLE HIGHER OR LOWER PAGES + PUSHJ P,%INFMP ; NOW FLUSH INF AND MAKE HIS CORE MINE + + ;POINTER UPDATE PHASE +;1 -- UPDATE ALL PAIR POINTERS + MOVE A,PARBOT ;START AT BOTTOM OF PAIR SPACE + PUSHJ P,PARUPD ;AND UPDATE ALL PAIR POINTERS + +;2 -- UPDATE ALL VECTORS + MOVE A,VECTOP ;START AT TOP OF VECTOR SPACE + PUSHJ P,VECUPD ;AND UPDATE THE POINTERS + MOVE A,CODTOP ; NOW UPDATE STORAGE STUFF + MOVEI D,0 ; FAKE OUT TO NOT UNMARK + PUSHJ P,STOUP + MOVSI D,400000 + +;3 -- UPDATE THE PVP AC + MOVEI A,PVP-1 ;SET LOC TO POINT TO PVP + MOVE C,PVP ;GET THE DATUM + PUSHJ P,NWRDUP ;AND UPDATE THIS VALUE +;4 -- UPDATE THE MAIN PROCESS POINTER + MOVEI A,MAINPR-1 ;POINT TO MAIN PROCESS POINTER + MOVE C,MAINPR ;GET CONTENTS IN C + PUSHJ P,NWRDUP ;AND UPDATE IT +;DATA MOVEMMENT ANDCLEANUP PHASE + +;1 -- ADJUST FOR SHRINKING VECTORS + MOVE A,VECTOP ;VECTOR SHRINKING PHASE + SKIPE SHRUNK ; SKIP IF NO SHRINKERS + PUSHJ P,VECSH ;GO SHRINK ANY SHRINKERS + +;2 -- MOVE VECTORS (AND LIST ELEMENTS) + MOVE A,VECTOP ;START AT TOP OF VECTOR SPACE + PUSHJ P,VECMOVE ;AND MOVE THE VECTORS + MOVE A,VECNEW ;GET FINAL CHANGE TO VECBOT + ADDM A,VECBOT ;OFFSET VECBOT TO ITS NEW PLACE + MOVE A,CORTOP ;GET NEW VALUE FOR TOP OF VECTOR SPACE + SUBI A,2000 ; FUDGE FOR MARK PDL + MOVEM A,VECTOP ;AND UPDATE VECTOP + +;3 -- CLEANUP VECTORS (NOTE A CONTAINS NEW VECTOP) + + SKIPE GREW ; SKIP IF NO GROWERS + PUSHJ P,VECZER ; + PUSHJ P,STOGC + +;GARBAGE ZEROING PHASE +GARZER: MOVE A,PARTOP ;FIRST WORD OF GARBAGE IS AFTER PAIR SPACE + HRLS A ;GET FIRST ADDRESS IN LEFT HALF + MOVE B,VECBOT ;LAST ADDRESS OF GARBAGE + 1 + CLEARM (A) ;ZERO THE FIRST WORD + ADDI A,1 ;MAKE A A BLT POINTER + BLT A,-1(B) ;AND COPY ZEROES INTO REST OF AREA + +;FINAL CORE ADJUSTMENT + SKIPE A,CORSET ;IFLESS CORE NEEDED + PUSHJ P,CORADL ;GIVE SOME AWAY. + +;NOW REHASH THE ASSOCIATIONS BASED ON NEW VALUES + + PUSHJ P,REHASH + + ;RESTORE AC'S +TRYCOX: MOVE 0,VECBOT + SUB 0,PARTOP + ADDM 0,NOWFRE + SKIPN GCMONF + JRST NOMONO + MOVEI B,[ASCIZ /GOUT /] + PUSHJ P,MSGTYP +NOMONO: IRP AC,,[0,A,B,C,D,E,P,R,M,SP,TP,TB,AB,PVP,TVP] + MOVE AC,AC!STO+1(PVP) + TERMIN +; CLOSING ROUTINE FOR G-C + PUSH P,A ; SAVE AC'C + PUSH P,B + PUSH P,C + PUSH P,D + PUSHJ P,CTIME + PUSHJ P,FIXSEN ; OUTPUT TIME + SKIPN GCMONF + JRST GCCONT + MOVEI A,15 ; OUTPUT C/R LINE-FEED + PUSHJ P,MTYO + MOVEI A,12 + PUSHJ P,MTYO +GCCONT: POP P,D ; RESTORE AC'C + POP P,C + POP P,B + POP P,A + MOVE A,GCDANG ; ERROR LEVELS TO ACS + ADD A,GCDNTG + SETZM GCDANG ; NOW CLEAR SAME + SETZM GCDNTG + JUMPGE A,AGCWIN + SKIPN GCHAIR ; WAS IT A FLUSHER? + JRST AGCWIN ; YES, NO MORE AVAILABLE + MOVEI A,1 + MOVEM A,GCHAIR ; RE-DO WITH HAIR + MOVE A,SPARNW ; RESET PARNEW + MOVEM A,PARNEW + SETZM SPARNW + MOVE C,[11,10.] ; INDICATOR FOR AGC + JRST AGC ; TRY ONCE MORE + +AGCWIN: SETZM PARNEW ;CLEAR FOR NEXT AGC CALL + SETZM GETNUM ;ALSO CLEAR THIS + SETZM GCFLG + + JUMPGE P,RBLDM ; DONT LOSE ON BLOWN PDLS + JUMPGE TP,RBLDM + CAMGE A,[-1] ; SKIP IF GOOD NEWS + JRST RBLDM + SETZM PGROW ; CLEAR GROWTH + SETZM TPGROW + SETOM GCHAPN ; INDICATE A GC HAS HAPPENED + SETOM INTFLG ; AND REQUEST AN INTERRUPT + SETZM GCDOWN + +RBLDM: JUMPGE R,CPOPJ + SKIPGE M,1(R) ; SKIP IF FUNNY + POPJ P, + + HLRS M + ADD M,PURVEC+1(TVP) + SKIPL M,1(M) + POPJ P, + PUSH P,0 + HRRZ 0,1(R) + ADD M,0 + POP P,0 +CPOPJ: POPJ P, + + +AGCE1: FATAL AGC--TYPE VECTOR NOT OF TYPE VECTOR + + ; CONVERSION FROM FLOAT TO DECIMAL. X 100 AND SEND OUT WITH APPROPRIATELY PLACED DECIMAL +; POINT. + +FIXSEN: PUSH P,B ; SAVE TIME + MOVEI B,[ASCIZ /TIME= /] + SKIPE GCMONF + PUSHJ P,MSGTYP ; PRINT OUT MESSAGE + POP P,B ; RESTORE B + FSBR B,GCTIM ; GET TIME ELAPSED + MOVEM B,GCTIM ; SAVE ELAPSED TIME FOR INT-HANDLER + SKIPN GCMONF + POPJ P, + FMPRI B,(100.0) ; CONVERT TO FIX + MULI B,400 + TSC B,B + ASH C,-163.(B) + MOVEI A,1 ; INITIALIZE COUNT OF CHARACTERS FOR PUTTING OUT TIME + PUSH P,C + IDIVI C,10. ; START COUNTING + JUMPLE C,.+2 + AOJA A,.-2 + POP P,C + CAIN A,1 ; SEE IF THERE IS ONLY ONE CHARACTER + JRST DOT1 +FIXOUT: IDIVI C,10. ; RECOVER NUMBER + HRLM D,(P) + SKIPE C + PUSHJ P,FIXOUT + PUSH P,A ; SAVE A + CAIN A,2 ; DECIMAL POINT HERE? + JRST DOT2 +FIX1: HLRZ A,(P)-1 ; GET NUMBER + ADDI A,60 ; MAKE IT A CHARACTER + PUSHJ P,MTYO ; OUT IT GOES + POP P,A + SOJ A, + POPJ P, +DOT1: MOVEI A,". ; OUTPUT DECIMAL POINT AND PADDING 0 + PUSHJ P,MTYO + MOVEI A,"0 + PUSHJ P,MTYO + JRST FIXOUT ; CONTINUE +DOT2: MOVEI A,". ; OUTPUT DECIMAL POINT + PUSHJ P,MTYO + JRST FIX1 + + ; INITIAL CORE ADJUSTMENT TO OBTAIN SPACE +; FOR MARK PHASE PDL + +TRYCOR: MOVEI A,2000 + ADDB A,CORTOP ; TRY AND GET 1 BLOCK + ASH A,-10. + MOVEI E,(A) ; SAVE FOR LOOPER + PUSHJ P,P.CORE ; GET CORE + JRST TRYCO2 ; FAILED, TAKE MORE ACTION + JRST CORGET + +TRYCO2: MOVNI A,2000 ; FIXUP CORTOP + ADDM A,CORTOP +TRYCO3: MOVE 0,TPGROW + ADD 0,PGROW ; 0/ NEQ 0 IF STACK BLEW + SKIPGE TP ; SKIP IF TP BLOWN + SKIPL PSTO+1(PVP) ; SKIP IF P WINS + MOVEI 0,1 + SKIPN 0 + MOVEI B,[ASCIZ / +CORE NEEDED: + TYPE C TO KEEP TRYING + TYPE N TO GET MUDDLE ERROR + TYPE V TO RETURN TO MONITOR +/] + SKIPE 0 + MOVEI B,[ASCIZ / +CORE NEEDED: + TYPE C TO KEEP TRYING + TYPE V TO RETURN TO MONITOR +/] + PUSH P,0 + PUSHJ P,MSGTYP + SETOM GCFLCH ; TELL INTERRUPT HANDLER TO .ITYIC + PUSHJ P,MTYI + PUSHJ P,UPLO ; IN CASE LOWER CASE TYPED + SETZM GCFLCH + POP P,0 + CAIN A,"C + JRST TRYCO4 + CAIN A,"N + JUMPE 0,TRYCO5 + CAIN A,"V + FATAL CORE LOSSAGE + JRST TRYCO3 + +UPLO: CAIL A,"a + CAILE A,"z + POPJ P, + SUBI A,40 + POPJ P, + +TRYCO4: MOVEI A,(E) +TRYCO9: MOVEI B,1 ; SLEEP AND CORE UNTIL WINNAGE + EXCH A,B + PUSHJ P,%SLEEP ; SLEEP A WHILE + EXCH A,B + PUSHJ P,P.CORE + JRST TRYCO9 + + MOVEI B,[ASCIZ / +WIN! +/] + PUSHJ P,MSGTYP + JRST CORGET + +TRYCO5: MOVNI A,3 ; GIVE WORST ERROR RETURN + MOVEM A,GCDANG + JRST TRYCOX + + + ; SUBROUTINE TO CHECK SIZE OF PDLS AND DO FENCEPOSTING + +PDLCHK: JUMPGE A,CPOPJ + HLRE B,A ;GET NEGATIVE COUNT + MOVE C,A ;SAVE A COPY OF PDL POINTER + SUBI A,-1(B) ;LOCATE DOPE WORD PAIR + HRRZS A ; ISOLATE POINTER + CAME A,TPGROW ;GROWING? + ADDI A,PDLBUF ;NO, POINT TO REAL DOPE WORD + HLRZ D,(A) ;GET COUNT FROM DOPE WORD + MOVNS B ;GET POSITIVE AMOUNT LEFT + SUBI D,2(B) ; PDL FULL? + JUMPE D,NOFENC ;YES NO FENCE POSTING + SETOM 1(C) ;CLOBBER TOP WORD + SOJE D,NOFENC ;STILL MORE? + MOVSI D,1(C) ;YES, SET UP TO BLT FENCE POSTS + HRRI D,2(C) + BLT D,-2(A) ;FENCE POST ALL EXCEPT DOPE WORDS + + +NOFENC: CAIG B,TPMAX ;NOW CHECK SIZE + CAIG B,TPMIN + JRST MUNGTP ;TOO BIG OR TOO SMALL + POPJ P, + +MUNGTP: SUBI B,TPGOOD ;FIND DELTA TP +MUNG3: MOVE C,-1(A) ;IS GROWTH ALREADY SPECIFIED + TRNE C,777000 ;SKIP IF NOT + POPJ P, ;ASSUME GROWTH GIVEN WILL WIN + + ASH B,-6 ;CONVERT TO NUMBER OF BLOCKS + JUMPLE B,MUNGT1 + CAILE B,377 ; SKIP IF BELOW MAX + MOVEI B,377 ; ELSE USE MAX + TRO B,400 ;TURN ON SHRINK BIT + JRST MUNGT2 +MUNGT1: MOVMS B + ANDI B,377 +MUNGT2: DPB B,[111100,,-1(A)] ;STORE IN DOPE WORD + POPJ P, + +; CHECK UNMARKED STACK (NO NEED TO FENCE POST) + +PDLCHP: HLRE B,A ;-LENGTH TO B + MOVE C,A + SUBI A,-1(B) ;POINT TO DOPE WORD + HRRZS A ;ISOLATE POINTER + CAME A,PGROW ;GROWING? + ADDI A,PDLBUF ;NO, POINT TO REAL DOPE WORD + MOVMS B ;PLUS LENGTH + HLRZ D,(A) ; D.W. LENGTH + SUBI D,2(B) ; PDL FULL + JUMPE D,NOPF + SETOM 1(C) ; START FENECE POST + SOJE D,NOPF ; 1 WORD? + MOVSI D,1(C) + HRRI D,2(C) + BLT D,-2(A) + +NOPF: CAIG B,PMAX ;TOO BIG? + CAIG B,PMIN ;OR TOO LITTLE + JRST .+2 ;YES, MUNG IT + POPJ P, + SUBI B,PGOOD + JRST MUNG3 + +;THIS ROUTINE MAKES SURE CURRENT FRAME MAKES SENSE +FRMUNG: MOVEM D,PSAV(A) + MOVEM SP,SPSAV(A) + MOVEM TP,TPSAV(A) ;SAVE FOR MARKING + POPJ P, + +; ROUTINE TO PRE MARK SPECIAL HACKS + +PRMRK: SKIPE GCHAIR ; FLUSH IF NO HAIR + POPJ P, + HLRE B,A + SUBI A,(B) ;POINT TO DOPE WORD + HLRZ B,1(A) ; GET LNTH + ADDM B,VECNUM ; AND UPDATE VECNUM + LDB B,[111100,,(A)] ; GET GROWTHS + TRZE B,400 ; SIGN HACK + MOVNS B + ASH B,6 ; TO WORDS + ADDM B,VECNUM + LDB 0,[001100,,(A)] + TRZE 0,400 + MOVNS 0 + ASH 0,6 + ADDM 0,VECNUM + PUSHJ P,GSHFLG ; SET GROW FLAGS + IORM D,1(A) ;AND MARK + POPJ P, + +; SET UP FLAGS FOR OPTIOANAL GROW/SHRINK PHASES + +GSHFLG: SKIPG B + SKIPLE 0 + SETOM GREW + SKIPL B + SKIPGE 0 + SETOM SHRUNK + POPJ P, + + ;GENERAL MARK SUBROUTINE. CALLED TO MARK ALL THINGS +; A/ GOODIE TO MARK FROM +; B/ TYPE OF A (IN RH) +; C/ TYPE,DATUM PAIR POINTER + +MARK2: HLRZ B,(C) ;GET TYPE +MARK1: MOVE A,1(C) ;GET GOODIE +MARK: JUMPE A,CPOPJ ; NEVER MARK 0 + MOVEI 0,(A) + CAIL 0,@PURBOT ; DONT MARK PURE STUFF + POPJ P, + PUSH P,A ;SAVE GOODIE + HRLM C,-1(P) ;AND POINTER TO IT + ANDI B,TYPMSK ; FLUSH MONITORS + LSH B,1 ;TIMES 2 TO GET SAT + HRRZ B,@TYPNT ;GET SAT + ANDI B,SATMSK + CAIG B,NUMSAT ; SKIP IF TEMPLATE DATA + JRST @MKTBS(B) ;AND GO MARK + JRST TD.MRK + +; DISPATCH TABLE FOR MARK PHASE ("SETZ'D" ENTRIES MUST BE DEFERRED) + +DISTBS MKTBS,GCRET,[[S2WORD,PAIRMK],[S2DEFR,DEFMK],[SNWORD,VECTMK] +[STPSTK,TPMK],[SARGS,],[S2NWORD,VECTMK],[SPSTK,TPMK],[SSTORE,VECTMK] +[SFRAME,],[SBYTE,],[SATOM,ATOMK],[SPVP,VECTMK],[SGATOM,GATOMK] +[SLOCID,],[SCHSTR,],[SASOC,ASMRK],[SLOCL,PAIRMK] +[SLOCA,],[SLOCV,VECTMK],[SLOCU,VECTMK],[SLOCS,],[SLOCN,ASMRK]] + + +;HERE TO MARK THAT WHICH IS POINTED TO BY A DEFERRED POINTER + +DEFMK: TLOA TYPNT,400000 ;USE SIGN BIT AS FLAG + +;HERE TO MARK LIST ELEMENTS + +PAIRMK: TLZ TYPNT,400000 ;TURN OF DEFER BIT + PUSH P,[0] ; WILL HOLD BACK PNTR + MOVEI C,(A) ;POINT TO LIST +PAIRM1: CAMGE C,PARTOP ;CHECK FOR BEING IN BOUNDS + CAMGE C,PARBOT + FATAL AGC--MARKED PAIR OUTSIDE PAIR SPACE + SKIPGE B,(C) ;SKIP IF NOT MARKED + JRST RETNEW ;ALREADY MARKED, RETURN + IORM D,(C) ;MARK IT + AOS PARNUM + MOVEM B,FRONT(FPTR) ; STORE 1ST WORD + MOVE 0,1(C) ; AND 2D + MOVEM 0,FRONT+1(FPTR) + ADD FPTR,[2,,2] ; MOVE ALONG IN FRONTIER + JUMPL FPTR,PAIRM2 ; NOD NEED FOR NEW CORE + +; HERE TO EXTEND THE FRONTIER + + HRRZ A,BOTNEW ; CURRENT BOTTOM OF WINDOW IN INF + ADDI A,2000 ; MOVE IT UP + HRRM A,BOTNEW + ASH A,-10. ; TO PAGES +SYSLO1: PUSHJ P,%GETIP ; GET PAGE + PUSHJ P,%SHFNT ; AND SHARE IT + MOVSI FPTR,-2000 + +PAIRM2: MOVEI A,@BOTNEW ; GET INF ADDR + SUBI A,2 + HRRM A,(C) ; LEAVE A POINTER TO NEW HOME + HRRZ E,(P) ; GET BACK POINTER + JUMPE E,PAIRM7 ; 1ST ONE, NEW FIXUP + MOVSI 0,(HRRM) ; INS FOR CLOBBER + PUSHJ P,SMINF ; SMASH INF'S CORE IMAGE +PAIRM4: MOVEM A,(P) ; NEW BACK POINTER + JUMPL TYPNT,DEFDO ;GO HANDLE DEFERRED POINTER + HRLM B,(P) ; SAVE OLD CDR + PUSHJ P,MARK2 ;MARK THIS DATUM + HRRZ E,(P) ; SMASH CAR IN CASE CHANGED + ADDI E,1 + MOVSI 0,(MOVEM) + PUSHJ P,SMINF + HLRZ C,(P) ;GET CDR OF LIST + CAIGE C,@PURBOT ; SKIP IF PURE (I.E. DONT MARK) + JUMPN C,PAIRM1 ;IF NOT NIL, MARK IT +GCRETP: SUB P,[1,,1] + +GCRET: TLZ TYPNT,400000 ;FOR PAIRMKS BENEFIT + HLRZ C,-1(P) ;RESTORE C + POP P,A + POPJ P, ;AND RETURN TO CALLER + +;HERE TO MARK DEFERRED POINTER + +DEFDO: PUSH P,B ; PUSH OLD PAIR ON STACK + PUSH P,1(C) + MOVEI C,-1(P) ; USE AS NEW DATUM + PUSHJ P,MARK2 ;MARK THE DATUM + HRRZ E,-2(P) ; GET POINTER IN INF CORE + ADDI E,1 + MOVSI 0,(MOVEM) + PUSHJ P,SMINF ; AND CLOBBER + SUB P,[3,,3] + JRST GCRET ;AND RETURN + + +PAIRM7: MOVEM A,-1(P) ; SAVE NEW VAL FOR RETURN + JRST PAIRM4 + +RETNEW: HRRZ A,(C) ; POINT TO NEW WORLD LOCN + HRRZ E,(P) ; BACK POINTER + JUMPE E,RETNW1 ; NONE + MOVSI 0,(HRRM) + PUSHJ P,SMINF + JRST GCRETP + +RETNW1: MOVEM A,-1(P) + JRST GCRETP + +; ROUTINE TO SMASH INFERIORS PPAGES +; E/ ADDR IN INF, A/ THING TO SMASH ,0/ INS TO USE + +SMINF: CAML E,WNDBOT ; SEE IF IN WINDOW + CAML E,WNDTOP + JRST SMINF1 ; NO TRY FRONTIER +SMINF3: SUB E,WNDBOT ; FIX UP + IOR 0,[0 A,WIND(E)] ; FIX INS + XCT 0 + POPJ P, + +SMINF1: PUSH P,0 + HRRZ 0,BOTNEW ; GET FRONTIER RANGE + CAML E,0 ; SKIP IF BELOW + CAIL E,@BOTNEW + JRST SMINF2 + SUB E,0 ; FIXUP E + POP P,0 + IOR 0,[0 A,FRONT(E)] + XCT 0 + POPJ P, + +SMINF2: PUSH P,A + MOVE A,E + ASH A,-10. ; TO PAGES + PUSHJ P,%SHWND + ASH A,10. ; BACK TO WORDS + MOVEM A,WNDBOT + ADDI A,2000 + MOVEM A,WNDTOP + POP P,A + POP P,0 ; RESTORE INS OF INTEREST + JRST SMINF3 + + + ; VECTOR AND TP MARKER, SIGN OF TYPNT IS SET BASED ON WHICH ONE + +TPMK: TLOA TYPNT,400000 ;SET TP MARK FLAG +VECTMK: TLZ TYPNT,400000 + MOVEI E,(A) ;SAVE A POINTER TO THE VECTOR + HLRE B,A ;GET -LNTH + SUB A,B ;LOCATE DOPE WORD + MOVEI A,1(A) ;ZERO LH AND POINT TO 2ND DOPE WORD + PUSHJ P,VECBND ; CHECK IN VECTOR SPACE + JRST VECTB1 ;LOSE, COMPLAIN + + JUMPGE TYPNT,NOBUFR ;IF A VECTOR, NO BUFFER CHECK + CAME A,PGROW ;IS THIS THE BLOWN P + CAMN A,TPGROW ;IS THIS THE GROWING PDL + JRST NOBUFR ;YES, DONT ADD BUFFER + ADDI A,PDLBUF ;POINT TO REAL DOPE WORD + MOVSI 0,-PDLBUF ;ALSO FIX UP POINTER + ADDB 0,1(C) + MOVEM 0,(P) ; FIXUP RET'D PNTR + +NOBUFR: HLRE B,(A) ;GET LENGTH FROM DOPE WORD + JUMPL B,GCRET ; MARKED, LEAVE + ANDI B,377777 ;CLOBBER POSSIBLE MARK BIT + MOVEI F,(A) ;SAVE A POINTER TO DOPE WORD + SUBI F,1(B) ;F POINTS TO START OF VECTOR + HRRZ 0,-1(A) ;SEE IF GROWTH SPECIFIED + MOVEI B,0 ; SET GROWTH 0 + JUMPE 0,NOCHNG ;NONE, JUST CHECK CURRENT SIZES + + LDB B,[001100,,0] ;GET GROWTH FACTOR + TRZE B,400 ;KILL SIGN BIT AND SKIP IF + + MOVNS B ;NEGATE + ASH B,6 ;CONVERT TO NUMBER OF WORDS + SUB F,B ;BOTTOM IS LOWER IN CORE + LDB 0,[111100,,0] ;GET TOP GROWTH + TRZE 0,400 ;HACK SIGN BIT + MOVNS 0 + ASH 0,6 ;CONVERT TO WORDS + PUSHJ P,GSHFLG ; HACK FLAGS FOR GROW/SHRINK + ADD B,0 ;TOTAL GROWTH TO B +NOCHNG: +VECOK: HLRE E,(A) ;GET LENGTH AND MARKING + MOVEI F,(E) ;SAVE A COPY + ADD F,B ;ADD GROWTH + SUBI E,2 ;- DOPE WORD LENGTH + IORM D,(A) ;MAKE SURE NOW MARKED + CAML A,VECBOT ; ONLY IF REALLY IN VEC SPACE + ADDM F,VECNUM ; ADD LENGTH OF VECTOR + JUMPLE E,GCRET ;ALREADY MARKED OR ZERO LENGTH, LEAVE + + SKIPGE B,-1(A) ;SKIP IF UNIFORM + TLNE B,377777 ;SKIP IF NOT SPECIAL + JUMPGE TYPNT,NOTGEN ;JUMP IF NOT A GENERAL VECTOR + +GENRAL: HLRZ 0,B ;CHECK FOR PSTACK + JUMPE 0,NOTGEN ;IT ISN'T GENERAL + SUBI A,1(E) ;POINT TO FIRST ELEMENT + MOVEI C,(A) ;POINT TO FIRST ELEMENT WITH C + + ; LOOP TO MARK ELEMENTS IN A GENERAL VECTOR + PUSH P,[0] +VECTM2: HLRE B,(C) ;GET TYPE AND MARKING + JUMPL B,GCRET1 ;RETURN, (EITHER DOPE WORD OR FENCE POST) + MOVE A,1(C) ;DATUM TO A + ANDI B,TYPMSK ; FLUSH MONITORS + CAIE B,TCBLK ;IS THIS A SAVED FRAME? + CAIN B,TENTRY ;IS THIS A STACK FRAME + JRST MFRAME ;YES, MARK IT + CAIE B,TUBIND ; BIND + CAIN B,TBIND ;OR A BINDING BLOCK + JRST MBIND + +VECTM3: PUSHJ P,MARK ;MARK DATUM + MOVEM A,1(C) ; IN CASE WAS FIXED +VECTM4: ADDI C,2 + JRST VECTM2 + +MFRAME: HRROI C,FRAMLN+FSAV-1(C) ;POINT TO FUNCTION + HRRZ A,1(C) ; GET IT + PUSHJ P,VECBND ; CHECK IN VECTOR SPACE + JRST MFRAM1 ; IGNORE, NOT IN VECTOR SPACE + HRL A,(A) ; GET LENGTH + MOVEI B,TVEC + PUSHJ P,MARK ; AND MARK IT +MFRAM1: HRROI C,SPSAV-FSAV(C) ;POINT TO SAVED SP + MOVEI B,TSP + PUSHJ P,MARK1 ;MARK THE GOODIE + HRROI C,PSAV-SPSAV(C) ;POINT TO SAVED P + MOVEI B,TPDL + PUSHJ P,MARK1 ;AND MARK IT + HRROI C,TPSAV-PSAV(C) ;POINT TO SAVED TP + MOVEI B,TTP + PUSHJ P,MARK1 ;MARK IT ALS + MOVEI C,-TPSAV+1(C) ;POINT PAST THE FRAME + JRST VECTM2 ;AND DO MORE MARKING + + +MBIND: MOVEI B,TATOM ;FIRST MARK ATOM + SKIPN GCHAIR ; IF NO HAIR, MARK ALL NOW + SKIPE (P) ; PASSED MARKER, IF SO DONT SKIP + JRST MBIND2 ; GO MARK + CAME A,IMQUOTE THIS-PROCESS + JRST MBIND1 ; NOT IT, CONTINUE SKIPPING + HRRM LPVP,2(C) ; SAVE IN RH OF TPVP,,0 + MOVEI LPVP,(C) ; POINT + SETOM (P) ; INDICATE PASSAGE +MBIND1: ADDI C,6 ; SKIP BINDING + JRST VECTM2 + +MBIND2: PUSHJ P,MARK1 ; MARK ATOM + ADDI C,2 ; POINT TO VAL + PUSHJ P,MARK2 ; AND MARK IT + MOVEM A,1(C) + ADDI C,2 + MOVEI B,TLIST ; POINT TO DECL SPECS + HLRZ A,(C) + PUSHJ P,MARK ; AND MARK IT + HRLM A,(C) ; LIST FIX UP + MOVEI B,TLOCI ; NOW MARK LOCATIVE + MOVE A,1(C) + JRST VECTM3 + +VECLOS: JUMPL C,CCRET ;JUMP IF CAN'T MUNG TYPE + HLLZ 0,(C) ;GET TYPE + MOVEI B,TILLEG ;GET ILLEGAL TYPE + HRLM B,(C) + MOVEM 0,1(C) ;AND STORE OLD TYPE AS VALUE + JRST GCRET ;RETURN WITHOUT MARKING VECTOR + +CCRET: CLEARM 1(C) ;CLOBBER THE DATUM + JRST GCRET + + +IGBLK: HRRZ B,(C) ;SKIP TO END OF PP BLOCK + ADDI C,3(B) + JRST VECTM2 + ; MARK ARG POINTERS + +ARGMK: HRRZ A,1(C) ; GET POINTER + HLRE B,1(C) ; AND LNTH + SUB A,B ; POINT TO BASE + PUSHJ P,VECBND + JRST ARGMK0 + HLRZ 0,(A) ; GET TYPE + ANDI 0,TYPMSK + CAIN 0,TCBLK + JRST ARGMK1 + CAIE 0,TENTRY ; IS NEXT A WINNER? + CAIN 0,TINFO + JRST ARGMK1 ; YES, GO ON TO WIN CODE + +ARGMK0: SETZB A,1(C) ; CLOBBER THE CELL + SETZM (P) ; AND SAVED COPY + JRST GCRET + +ARGMK1: MOVE B,1(A) ; ASSUME TTB + ADDI B,(A) ; POINT TO FRAME + CAIE 0,TINFO ; IS IT? + MOVEI B,FRAMLN(A) ; NO, USE OTHER GOODIE + HLRZ 0,OTBSAV(B) ; GET TIME + HRRZ A,(C) ; AND FROM POINTER + CAIE 0,(A) ; SKIP IF WINNER + JRST ARGMK0 + HRROI C,TPSAV-1(B) ; MARK FROM TP SLOT + MOVEI B,TTP + MOVE A,1(C) +; PUSHJ P,MARK ; WILL PUT BACK WHEN KNOWN HOW! + JRST GCRET + +; MARK FRAME POINTERS + +FRMK: SUBI C,1 ;PREPARE TO MARK PROCESS VECTOR + HRRZ A,1(C) ;USE AS DATUM + SUBI A,1 ;FUDGE FOR VECTMK + MOVEI B,TPVP ;IT IS A VECTRO + PUSHJ P,MARK ;MARK IT + JRST GCRET + +; MARK BYTE POINTER + +BYTMK: PUSHJ P,BYTDOP ; GET DOPE WORD IN A + SOJG A,VECTMK ;FUDGE DOPE WORD POINTER FOR VECTMK + + FATAL AGC--BYTE POINTER WITH ZERO DOPE WORD POINTER + + ; MARK ATOMS IN GVAL STACK + +GATOMK: HRRZ B,(C) ; POINT TO POSSIBLE GDECL + JUMPE B,ATOMK + CAIN B,-1 + JRST ATOMK + MOVEI A,(B) ; POINT TO DECL FOR MARK + MOVEI B,TLIST + MOVEI C,0 + PUSHJ P,MARK + HLRZ C,-1(P) ; RESTORE HOME POINTER + HRRM A,(C) ; CLOBBER UPDATED LIST IN + MOVE A,1(C) ; RESTORE ATOM POINTER + +; MARK ATOMS + +ATOMK: +REPEAT 0,[ + TLO TYPNT,.ATOM. ; SAY ATOM WAS MARKED + PUSHJ P,GETLNT ;GET LENGTH AND CHECK BOUNDS + HRRZ C,(A) ; IF UNBOUND OR GLOBAL + JUMPE C,MRKOBL ; SKIP + HRRZ C,1(A) ; DONT MARK BUT UPDATE BASED ON TPGROW + HLRE B,1(A) + SUB C,B ; POINT TO DOPE WORD + MOVEI C,1(C) ; POINT TO 2D DOPE WORD + MOVSI B,-PDLBUF ; IN CASE UPDATE + CAME C,TPGROW ; SKIP IF GROWER + ADDM B,1(A) ; OTHERWISE UPDATE +MRKOBL: MOVEI C,1(A) ; POINT TO OBLIST SLOT +] + TLO TYPNT,.ATOM. ; SAY ATOM WAS MARKED + MOVEI C,1(A) + HRRZ 0,(A) + PUSHJ P,GETLNT ;GET LENGTH AND CHECK BOUNDS + JUMPE 0,MRKOBL + HRRZ B,(C) + HLRE 0,(C) + SUB B,0 + MOVEI B,1(B) + MOVSI 0,-PDLBUF + CAME B,TPGROW + ADDM 0,(C) +MRKOBL: MOVEI B,TOBLS + SKIPGE 1(C) ; IF > 0, NOT OBL + PUSHJ P,MARK1 ; AND MARK IT + JRST GCRET ;AND LEAVE + +GETLNT: HLRE B,A ;GET -LNTH + SUB A,B ;POINT TO 1ST DOPE WORD + MOVEI A,1(A) ;POINT TO 2ND DOPE WORD + PUSHJ P,VECBND + JRST VECTB1 ;BAD VECTOR, COMPLAIN + + HLRE B,(A) ;GET LENGTH AND MARKING + IORM D,(A) ;MAKE SURE MARKED + JUMPL B,GCRET1 ;MARKED ALREADY, QUIT + SUBI A,-1(B) ;POINT TO TOP OF ATOM + CAML A,VECBOT ; DONT COUNT STORAGE + ADDM B,VECNUM ;UPDATE VECNUM + POPJ P, ;AND RETURN + +GCRET1: SUB P,[1,,1] ;FLUSH RETURN ADDRESS + JRST GCRET + +VECBND: CAMGE A,VECTOP + CAMGE A,VECBOT + JRST .+2 + JRST CPOPJ1 + + CAMG A,CODTOP + CAIGE A,STOSTR + POPJ P, + JRST CPOPJ1 + +; MARK NON-GENERAL VECTORS + +NOTGEN: CAMN B,[GENERAL+] ;PROCESS VECTOR? + JRST GENRAL ;YES, MARK AS A VECTOR + JUMPL B,SPECLS ; COMPLAIN IF A SPECIAL HACK + SUBI A,1(E) ;POINT TO TOP OF A UNIFORM VECTOR + HLRZS B ;ISOLATE TYPE + ANDI E,TYPMSK + MOVE F,B ; AND COPY IT + LSH B,1 ;FIND OUT WHERE IT WILL GO + HRRZ B,@TYPNT ;GET SAT IN B + ANDI B,SATMSK + MOVEI C,@MKTBS(B) ;POINT TO MARK SR + CAIN C,GCRET ;IF NOT A MARKED FROM GOODIE, IGNORE + JRST GCRET + MOVEI C,-1(A) ;POINT 1 PRIOR TO VECTOR START + PUSH P,E ;SAVE NUMBER OF ELEMENTS + PUSH P,F ;AND UNIFORM TYPE + +UNLOOP: MOVE B,(P) ;GET TYPE + MOVE A,1(C) ;AND GOODIE + TLO C,400000 ;CAN'T MUNG TYPE + PUSHJ P,MARK ;MARK THIS ONE + MOVEM A,1(C) ; LIST FIXUP + SOSE -1(P) ;COUNT + AOJA C,UNLOOP ;IF MORE, DO NEXT + + SUB P,[2,,2] ;REMOVE STACK CRAP + JRST GCRET + + +SPECLS: FATAL AGC--UNRECOGNIZED SPECIAL VECTOR + + ;MARK LOCID TYPE GOODIES + +LOCMK: HRRZ B,(C) ;GET TIME + JUMPE B,LOCMK1 ; SKIP LEGAL CHECK FOR GLOBAL + HRRZ 0,2(A) ; GET OTHER TIME + CAIE 0,(B) ; SAME? + SETZB A,1(C) ; NO, SMASH LOCATIVE + JUMPE A,GCRET ; LEAVE IF DONE +LOCMK1: PUSH P,C + MOVEI B,TATOM ; MARK ATOM + MOVEI C,-2(A) ; POINT TO ATOM + PUSHJ P,MARK1 ; LET LOCATIVE SAVE THE ATOM + POP P,C + HRRZ B,(C) ; TIME BACK + MOVE A,1(C) ; RESTORE POINTER TO STACK + JUMPE B,VECTMK ;IF ZERO, GLOBAL + JRST TPMK ;ELSE, ON TP + +; MARK ASSOCIATION BLOCKS + +ASMRK: HRLI A,-ASOLNT ;LOOK LIKE A VECTOR POINTER + PUSHJ P,GETLNT ;GET LENGTH AND CHECK BOUNDS + MOVEI C,(A) ;COPY POINTER + PUSHJ P,MARK2 ;MARK ITEM CELL + MOVEM A,1(C) + ADDI C,INDIC-ITEM ;POINT TO INDICATOR + PUSHJ P,MARK2 + MOVEM A,1(C) + ADDI C,VAL-INDIC + PUSHJ P,MARK2 + MOVEM A,1(C) + SKIPN GCHAIR ; IF NO HAIR, MARK ALL FRIENDS + JRST GCRET + HRRZ A,NODPNT-VAL(C) ; NEXT + JUMPN A,ASMRK ; IF EXISTS, GO + JRST GCRET + + + +;HERE WHEN A VECTOR POINTER IS BAD + +VECTB1:FATAL AGC--VECTOR POINTS OUTSIDE OF VECTOR SPACE + + ; HERE TO MARK TEMPLATE DATA STRUCTURES + +TD.MRK: HLRZ B,(A) ; GET REAL SPEC TYPE + ANDI B,377777 ; KILL SIGN BIT + MOVEI E,-NUMSAT-1(B) ; GET REL POINTER TO TABLE + HRLI E,(E) + ADD E,TD.LNT+1(TVP) + HRRZS C,A ; FLUSH COUNT AND SAVE + SKIPL E ; WITHIN BOUNDS + FATAL BAD SAT IN AGC + PUSHJ P,GETLNT ; GOODIE IS NOW MARKED + + XCT (E) ; RET # OF ELEMENTS IN B + + HLRZ D,B ; GET POSSIBLE "BASIC LENGTH" FOR RESTS + PUSH P,[0] ; TEMP USED IF RESTS EXIST + PUSH P,D + MOVEI B,(B) ; ZAP TO ONLY LENGTH + PUSH P,C ; SAVE POINTER TO TEMPLATE STRUCTURE + PUSH P,[0] ; HOME FOR VALUES + PUSH P,[0] ; SLOT FOR TEMP + PUSH P,B ; SAVE + SUB E,TD.LNT+1(TVP) + PUSH P,E ; SAVE FOR FINDING OTHER TABLES + JUMPE D,TD.MR2 ; NO REPEATING SEQ + ADD E,TD.GET+1(TVP) ; COMP LNTH OF REPEATING SEQ + HLRE E,(E) ; E ==> - LNTH OF TEMPLATE + ADDI E,(D) ; E ==> -LENGTH OF REP SEQ + MOVNS E + HRLM E,-5(P) ; SAVE IT AND BASIC + +TD.MR2: SKIPG D,-1(P) ; ANY LEFT? + JRST TD.MR1 + + MOVE E,TD.GET+1(TVP) + ADD E,(P) + MOVE E,(E) ; POINTER TO VECTOR IN E + MOVEM D,-6(P) ; SAVE ELMENT # + SKIPN B,-5(P) ; SKIP IF "RESTS" EXIST + SOJA D,TD.MR3 + + MOVEI 0,(B) ; BASIC LNT TO 0 + SUBI 0,(D) ; SEE IF PAST BASIC + JUMPGE 0,.-3 ; JUMP IF O.K. + MOVSS B ; REP LNT TO RH, BASIC TO LH + IDIVI 0,(B) ; A==> -WHICH REPEATER + MOVNS A + ADD A,-5(P) ; PLUS BASIC + ADDI A,1 ; AND FUDGE + MOVEM A,-6(P) ; SAVE FOR PUTTER + ADDI E,-1(A) ; POINT + SOJA D,.+2 + +TD.MR3: ADDI E,(D) ; POINT TO SLOT + XCT (E) ; GET THIS ELEMENT INTO A AND B + MOVEM A,-3(P) ; SAVE TYPE FOR LATER PUT + MOVEM B,-2(P) + EXCH A,B ; REARRANGE + GETYP B,B + MOVEI C,-3(P) ; TELL OTHER GUYS THEY CANT DIRECTLY MUNG + MOVSI D,400000 ; RESET FOR MARK + PUSHJ P,MARK ; AND MARK THIS GUY (RET FIXED POINTER IN A) + MOVE C,-4(P) ; REGOBBLE POINTER TO TEMPLATE + MOVE E,TD.PUT+1(TVP) + MOVE B,-6(P) ; RESTORE COUNT + ADD E,(P) + MOVE E,(E) ; POINTER TO VECTOR IN E + ADDI E,(B)-1 ; POINT TO SLOT + MOVE B,-3(P) ; RESTORE TYPE WORD + EXCH A,B + SOS D,-1(P) ; GET ELEMENT # + XCT (E) ; SMASH IT BACK + FATAL TEMPLATE LOSSAGE + MOVE C,-4(P) ; RESTORE POINTER IN CASE MUNGED + JRST TD.MR2 + +TD.MR1: SUB P,[7,,7] + MOVSI D,400000 ; RESTORE MARK/UNMARK BIT + JRST GCRET + +; This phase attempts to remove any unwanted associations. The program +; loops through the structure marking values of associations. It can only +; stop when no new values (potential items and/or indicators) are marked. + +VALFLS: PUSH P,[0] ; INDICATE WHETHER ANY ON THIS PASS + PUSH P,[0] ; OR THIS BUCKET +ASOMK1: MOVE A,ASOVEC+1(TVP) ; GET VECTOR POINTER + SETOM -1(P) ; INITIALIZE FLAG + +ASOM6: SKIPG C,(A) ; SKIP IF BUCKET TO BE SCANNED + JRST ASOM1 + SETOM (P) ; SAY BUCKET NOT CHANGED + +ASOM2: MOVEI F,(C) ; COPY POINTER + SKIPG ASOLNT+1(C) ; SKIP IF NOT ALREADY MARKED + JRST ASOM4 ; MARKED, GO ON + PUSHJ P,MARKQ ; SEE IF ITEM IS MARKED + JRST ASOM3 ; IT IS NOT, IGNORE IT + MOVEI F,(C) ; IN CASE CLOBBERED BY MARK2 + MOVEI C,INDIC(C) ; POINT TO INDICATOR SLOT + PUSHJ P,MARKQ + JRST ASOM3 ; NOT MARKED + + PUSH P,A ; HERE TO MARK VALUE + PUSH P,F + HLRE F,ASOLNT-INDIC+1(C) ; GET LENGTH + JUMPL F,.+3 ; SKIP IF MARKED + CAML C,VECBOT ; SKIP IF IN NOT VECT SPACE + ADDM F,VECNUM + PUSHJ P,MARK2 ; AND MARK + MOVEM A,1(C) ; LIST FIX UP + ADDI C,ITEM-INDIC ; POINT TO ITEM + PUSHJ P,MARK2 + MOVEM A,1(C) + ADDI C,VAL-ITEM ; POINT TO VALUE + PUSHJ P,MARK2 + MOVEM A,1(C) + IORM D,ASOLNT-VAL+1(C) ; MARK ASOC BLOCK + POP P,F + POP P,A + AOSA -1(P) ; INDICATE A MARK TOOK PLACE + +ASOM3: AOS (P) ; INDICATE AN UNMARKED IN THIS BUCKET +ASOM4: HRRZ C,ASOLNT-1(F) ; POINT TO NEXT IN BUCKET + JUMPN C,ASOM2 ; IF NOT EMPTY, CONTINUE + SKIPGE (P) ; SKIP IF ANY NOT MARKED + HRROS (A) ; MARK BUCKET AS NOT INTERESTING +ASOM1: AOBJN A,ASOM6 ; GO TO NEXT BUCKET + TLZE TYPNT,.ATOM. ; ANY ATOMS MARKED? + JRST VALFLA ; YES, CHECK VALUES +VALFL8: + +; NOW SEE WHICH CHANNELS STILL POINTED TO + +CHNFL3: MOVEI 0,N.CHNS-1 + MOVEI A,CHNL1(TVP) ; SLOTS + HRLI A,TCHAN ; TYPE HERE TOO + +CHNFL2: SKIPN B,1(A) + JRST CHNFL1 + HLRE C,B + SUBI B,(C) ; POINT TO DOPE + HLLM A,(A) ; PUT TYPE BACK + SKIPGE 1(B) + JRST CHNFL1 + HLLOS (A) ; MARK AS A LOSER + PUSH P,A + PUSH P,0 + MOVEI C,(A) + PUSHJ P,MARK2 + POP P,0 + POP P,A + SETZM -1(P) ; SAY MARKED +CHNFL1: ADDI A,2 + SOJG 0,CHNFL2 + + SKIPE GCHAIR ; IF NOT HAIRY CASE + POPJ P, ; LEAVE + + SKIPL -1(P) ; SKIP IF NOTHING NEW MARKED + JRST ASOMK1 + + SUB P,[2,,2] ; REMOVE FLAGS + + + + ; HERE TO REEMOVE UNUSED ASSOCIATIONS + + MOVE A,ASOVEC+1(TVP) ; GET ASOVEC BACK FOR FLUSHES + +ASOFL1: SKIPN C,(A) ; SKIP IF BUCKET NOT EMPTY + JRST ASOFL2 ; EMPTY BUCKET, IGNORE + HRRZS (A) ; UNDO DAMAGE OF BEFORE + +ASOFL5: SKIPGE ASOLNT+1(C) ; SKIP IF UNMARKED + JRST ASOFL3 ; MARKED, DONT FLUSH + + HRRZ B,ASOLNT-1(C) ; GET FORWARD POINTER + HLRZ E,ASOLNT-1(C) ; AND BACK POINTER + JUMPN E,ASOFL4 ; JUMP IF NO BACK POINTER (FIRST IN BUCKET) + HRRZM B,(A) ; FIX BUCKET + JRST .+2 + +ASOFL4: HRRM B,ASOLNT-1(E) ; FIX UP PREVIOUS + JUMPE B,.+2 ; JUMP IF NO NEXT POINTER + HRLM E,ASOLNT-1(B) ; FIX NEXT'S BACK POINTER + HRRZ B,NODPNT(C) ; SPLICE OUT THRAD + HLRZ E,NODPNT(C) + SKIPE E + HRRM B,NODPNT(E) + SKIPE B + HRLM E,NODPNT(B) + +ASOFL3: HRRZ C,ASOLNT-1(C) ; GO TO NEXT + JUMPN C,ASOFL5 +ASOFL2: AOBJN A,ASOFL1 + +; NOW CLOBBER UNMARKED LOCAL NAD GLOBAL VALUES + + MOVE A,GLOBSP+1(TVP) ; GET GLOBAL PDL + +GLOFLS: SKIPGE (A) ; SKIP IF NOT ALREADY MARKED + JRST .+3 ; VIOLATE CARDINAL RULE #69 + MOVSI B,-3 + PUSHJ P,ZERSLT ; CLOBBER THE SLOT + ANDCAM D,(A) ; UNMARK + ADD A,[4,,4] + JUMPL A,GLOFLS ; MORE?, KEEP LOOPING + +LOCFL1: HRRZ A,(LPVP) ; NOW CLOBBER LOCAL SLOTS + HRRZ C,2(LPVP) + HLLZS 2(LPVP) ; NOW CLEAR + MOVEI LPVP,(C) + JUMPE A,LOCFL2 ; NONE TO FLUSH + +LOCFLS: SKIPGE (A) ; MARKDE? + JRST .+3 + MOVSI B,-5 + PUSHJ P,ZERSLT + ANDCAM D,(A) ;UNMARK + HRRZ A,(A) ; GO ON + JUMPN A,LOCFLS +LOCFL2: JUMPN LPVP,LOCFL1 ; JUMP IF MORE PROCESS + POPJ P, + + + +MARK23: PUSH P,A ; SAVE BUCKET POINTER + PUSH P,F + PUSHJ P,MARK2 + MOVEM A,1(C) + POP P,F + POP P,A + AOS -2(P) ; MARKING HAS OCCURRED + IORM D,ASOLNT+1(C) ; MARK IT + JRST MKD + + ; CHANNEL FLUSHER FOR NON HAIRY GC + +CHNFLS: PUSH P,[-1] + SETOM (P) ; RESET FOR RETRY + PUSHJ P,CHNFL3 + SKIPL (P) + JRST .-3 ; REDO + SUB P,[1,,1] + POPJ P, + +; VALUE FLUSHING PHASE, HACKS BOTTOM OF TP AND GLOBAL SP + +VALFLA: MOVE C,GLOBSP+1(TVP) + +VALFL1: SKIPL (C) ; SKIP IF NOT MARKED + PUSHJ P,MARKQ ; SEE IF ATOM IS MARKED + JRST VALFL2 + IORM D,(C) + AOS -1(P) ; INDICATE MARK OCCURRED + PUSH P,C + HRRZ B,(C) ; GET POSSIBLE GDECL + JUMPE B,VLFL10 ; NONE + CAIN B,-1 ; MAINFIFEST + JRST VLFL10 + MOVEI A,(B) + MOVEI B,TLIST + MOVEI C,0 + PUSHJ P,MARK ; MARK IT + MOVE C,(P) ; POINT + HRRM A,(C) ; CLOBBER UPDATE IN +VLFL10: ADD C,[2,,2] ; BUMP TO VALUE + PUSHJ P,MARK2 ; MARK VALUE + MOVEM A,1(C) + POP P,C +VALFL2: ADD C,[4,,4] + JUMPL C,VALFL1 ; JUMP IF MORE + + HRLM LPVP,(P) ; SAVE POINTER +VALFL7: MOVEI C,(LPVP) + MOVEI LPVP,0 +VALFL6: HRRM C,(P) + +VALFL5: HRRZ C,(C) ; CHAIN + JUMPE C,VALFL4 + MOVEI B,TATOM ; TREAT LIKE AN ATOM + SKIPL (C) ; MARKED? + PUSHJ P,MARKQ1 ; NO, SEE + JRST VALFL5 ; LOOP + AOS -1(P) ; MARK WILL OCCUR + IORM D,(C) + ADD C,[2,,2] ; POINT TO VALUE + PUSHJ P,MARK2 ; MARK VALUE + MOVEM A,1(C) + SUBI C,2 + JRST VALFL5 + +VALFL4: HRRZ C,(P) ; GET SAVED LPVP + MOVEI A,(C) + HRRZ C,2(C) ; POINT TO NEXT + JUMPN C,VALFL6 + JUMPE LPVP,VALFL9 + + HRRM LPVP,2(A) ; NEW PROCESS WAS MARKED + JRST VALFL7 + +ZERSLT: HRRI B,(A) ; COPY POINTER + SETZM 1(B) + AOBJN B,.-1 + POPJ P, + +VALFL9: HLRZ LPVP,(P) ; RESTORE CHAIN + JRST VALFL8 + + + ;SUBROUTINE TO SEE IF A GOODIE IS MARKED +;RECEIVES POINTER IN C +;SKIPS IF MARKED NOT OTHERWISE + +MARKQ: HLRZ B,(C) ;TYPE TO B +MARKQ1: MOVE E,1(C) ;DATUM TO C + MOVEI 0,(E) + CAIL 0,@PURBOT ; DONT CHACK PURE + JRST MKD ; ALWAYS MARKED + ANDI B,TYPMSK ; FLUSH MONITORS + LSH B,1 + HRRZ B,@TYPNT ;GOBBLE SAT + ANDI B,SATMSK + CAIG B,NUMSAT ; SKIP FOR TEMPLATE + JRST @MQTBS(B) ;DISPATCH + ANDI E,-1 ; FLUSH REST HACKS + JRST VECMQ + + +DISTBS MQTBS,MKD,[[S2WORD,PAIRMQ],[S2DEFR,PAIRMQ],[SNWORD,VECMQ],[S2NWORD,VECMQ] +[STPSTK,VECMQ],[SARGS,ARGMQ],[SPSTK,VECMQ],[SFRAME,FRMQ],[SBYTE,BYTMQ],[SLOCID,LOCMQ] +[SATOM,VECMQ],[SPVP,VECMQ],[SLOCID,VECMQ],[SCHSTR,BYTMQ],[SLOCA,ARGMQ],[SLOCU,VECMQ] +[SLOCV,VECMQ],[SLOCS,BYTMQ],[SLOCN,ASMQ],[SASOC,ASMQ],[SLOCL,PAIRMQ],[SGATOM,VECMQ]] + +PAIRMQ: JUMPE E,MKD ; NIL ALWAYS MARKED + SKIPL (E) ; SKIP IF MARKED + POPJ P, +CPOPJ1: +ARGMQ: +MKD: AOS (P) + POPJ P, + +BYTMQ: HRRZ E,(C) ;GET DOPE WORD POINTER + SOJA E,VECMQ1 ;TREAT LIKE VECTOR + +FRMQ: HRRZ E,(C) ; POINT TO PV DOPE WORD + SOJA E,VECMQ1 + + +VECMQ: HLRE 0,E ;GET LENGTH + SUB E,0 ;POINT TO DOPE WORDS + +VECMQ1: SKIPGE 1(E) ;SKIP IF NOT MARKED + AOS (P) ;MARKED, CAUSE SKIP RETURN + POPJ P, + +ASMQ: SUBI E,ASOLNT + JRST VECMQ1 + +LOCMQ: HRRZ 0,(C) ; GET TIME + JUMPE 0,VECMQ ; GLOBAL, LIKE VECTOR + HLRE 0,E ; FIND DOPE + SUB E,0 + MOVEI E,1(E) ; POINT TO LAST DOPE + CAMN E,TPGROW ; GROWING? + SOJA E,VECMQ1 ; YES, CHECK + ADDI E,PDLBUF ; FUDGE + MOVSI 0,-PDLBUF + ADDM 0,1(C) + SOJA E,VECMQ1 + REPEAT 0,[ + + + +;RETIME PHASE -- CALLED IFF A FRAME TIME HAS OVERFLOWED +;RECEIVES POINTER TO STACK TO BE RECALIBRATED IN A +;LEAVES HIGHEST TIME IN TIMOUT + +RETIME: HLRE B,A ;GET LENGTH IN B + SUB A,B ;COMPUTE DOPE WORD LOCATION + MOVEI A,1(A) ;POINT TO 2D DOPE WORD AND CLEAR LH + CAME A,TPGROW ;IS THIS ONE BLOWN? + ADDI A,PDLBUF ;NO, POINT TO DOPE WORD + LDB B,[222100,,(A)] ;GET LENGTH FIELD (IGNOREING MARK BIT + SUBI A,-1(B) ;POINT TO PDLS BASE + MOVEI C,1 ;INITIALIZE NEW TIMES + +RETIM1: SKIPGE B,(A) ;IF <0, HIT DOPE WORD OR FENCE POST + JRST RETIM3 + HLRZS B ;ISOLATE TYPE + CAIE B,TENTRY ;FRAME START? + AOJA A,RETIM2 ;NO, TRY BINDING + HRLM C,FRAMLN+OTBSAV(A) ;STORE NEW TIME + ADDI A,FRAMLN ;POINT TO NEXT ELEMENT + AOJA C,RETIM1 ;BUMP TIME AND MOVE ON + +RETIM2: CAIE B,TUBIND + CAIN B,TBIND ;BINDING? + HRRM C,3(A) ;YES, STORE CURRENT TIME + AOJA A,RETIM1 ;AND GO ON + +RETIM3: MOVEM C,TIMOUT ;SAVE TIME + POPJ P, ;RETURN + + +] + + ; Core adjustment phase, try to win in all obscure cases! + +CORADJ: MOVE A,P.TOP ; update AGCs core top + MOVEM A,CORTOP + MOVE A,PARBOT ; figure out all the core needed + ADD A,PARNEW + ADD A,PARNUM + ADD A,PARNUM + ADD A,VECNUM + ADDI A,3777 ; account for gc pdl and round to block + ANDCMI A,1777 + +CORAD3: CAMG A,PURTOP ; any way of winning at all? + JRST CORAD1 ; yes, go try +CORA33: SETOM GCDNTG ; no, can't even grow something + SETOM GCDANG ; or get current request + SKIPL C,PARNEW ; or move pairs up + SETZM PARNEW + MOVEM C,SPARNW ; save attempt in case of retry + +CORAD6: MOVE A,CORTOP ; update core gotton with needed + ASH A,-10. ; to blocks + PUSHJ P,P.CORE ; try to get it (any lossage will retry) + PUSHJ P,SLPM1 +CORA11: MOVE A,CORTOP ; compute new home for vectors + SUB A,VECTOP + SUBI A,2000 ; remember gc pdl + MOVEM A,VECNEW + POPJ P, ; return to main GC loop + +; Here if at least enough for growers + +CORAD1: SKIPN B,GCDOWN ; skip if were called to get pure space + JRST CORAD2 + ADDI A,2000(B) ; A/ enough for move down and minimum free + CAMG A,PURTOP ; any chance of winning? + JRST CORAD4 ; yes, go win some + +; Here if cant move down + + SETOM GCDANG ; complain upon return + SUBI A,2000(B) ; reset for re-entry into loop + CAMLE A,PURTOP ; win? + JRST CORA33 + +; Here if may be able to grant current request + +CORAD2: ADD A,GETNUM ; A/ total neede including request + ADD A,CURPLN ; dont give self away or something + ADDI A,3777 ; at least one free block and round + ANDCMI A,1777 ; to block boundary + CAMG A,PURTOP ; any hope of this? + JRST CORAD5 ; yes, now see if some slop space can appear + + SETOM GCDANG ; tell caller we lost + MOVE A,PURTOP ; try to get as much as possible anyway + SUB A,PURBOT + SUB A,CURPLN +CORAD8: ASH A,-10. ; to pages + PUSHJ P,GETPAG + FATAL PAGES NOT AVAILABLE + MOVSI D,400000 ; wipes out D + MOVE A,PURBOT ; and use current PURBOT as new core top + SUBI A,2000 ; for gc pdl + MOVEM A,CORTOP + JRST CORAD6 ; and allocate necessary pages + +; Here if real necessities taken care of, try for slop space + +CORAD5: ADD A,FREMIN ; try for minimum + SUBI A,2000-1777 ; round and flush min 2000 of before + ANDCMI A,1777 ; round to block boundary + CAMG A,PURTOP ; again, do we win? + JRST CORAD7 ; yes, we win totally + +; Here if cant get desired free but get some + + MOVE A,PURTOP ; compute pages to flush + SUB A,CURPLN ; again dont flush current prog + SUB A,PURBOT ; A/ words to get + JRST CORAD8 ; go do it + +; Here if can get all the free we want + +CORAD7: SUB A,CURPLN + CAMG A,PURBOT ; do any pages get the ax? + JRST CORAD9 ; no, see if can give core back! + SUB A,PURBOT ; words to get purely + JRST CORAD8 + +CORAD9: CAMG A,CORTOP ; skip if must get core + JRST CORA10 + MOVEM A,CORTOP + JRST CORAD6 ; and go get it + +; Here if still may have to give it back + +CORA10: MOVE B,CORTOP + SUB B,A + CAMG B,FREDIF ; skip if giving awy + JRST CORA11 + +CORA12: MOVEM A,CORTOP + ASH A,-10. + MOVEM A,CORSET ; leave to shrink later + JRST CORA11 + +; Here if going down to also get free space + +CORAD4: SUBI A,2000 ; uncompensate for min + ADD A,FREMIN + CAML A,CORTOP ; skip if ok for max + MOVE A,CORTOP ; else use up to pure + SUB A,GCDOWN ; new CORTOP to A + JRST CORA12 ; go set up final shrink + +; routine to wait for core + +SLPM1: MOVEI 0,1 + .SLEEP 0, + SOS (P) + SOS (P) ; ret to prev ins + POPJ P, + +CORADL: PUSHJ P,P.CORE ;SET TO NEW CORE VALUE + FATAL AGC--CANT CORE DOWN + POPJ P, + ;VECTOR RELOCATE --GETS VECTOP IN A +;AND VECNEW IN B +;FILLS IN RELOCATION FIELDS OF MARKED VECTORS +;AND REUTRNS FINAL VECNEW IN B + +VECREL: CAMG A,VECBOT ;PROCESSED TO BOTTOM OF VECTOR SPACE? + POPJ P, ;YES, RETURN + HLRE C,(A) ;GET COUNT FROM DOPE WD, EXTEND MARK BIT + JUMPL C,VECRE1 ;IF MARKED GO PROCESS + HRRM A,(A) ; INDICATE NON-MOVE BY LEAVING SAME + SUBI A,(C) ;MOVE ON TO NEXT VECTOR + SOJG C,VECREL ;AND KEEP SCANNING + JSP D,VCMLOS ;LOSER, LEAVE TRACKS AS TO WHO LOST + +VECRE1: HRRZ E,-1(A) ;GOBBLE THE GROWTH FILEDS + HRRM B,(A) ;STORE RELOCATION + JUMPE E,VECRE2 ;NO GROWTH (OR SHRINKAGE), GO AWAY + LDB F,[111100,,E] ;GET TOP GROWTH IN F + TRZN F,400 ;CHECK AND FLUSH SIGN + MOVNS F ;WAS ON, NEGATE + SKIPE GCDNTG ; SKIP IF GROWTH OK + JUMPL F,VECRE3 ; DONT ALLOW POSITIVE GROWTH + ASH F,6 ;CONVERT TO WORDS + ADD B,F ;UPDATE RELOCATION + HRRM B,(A) ;AND STORE IT +VECRE3: ANDI E,777 ;ISOLATE BOTTOM GROWTH + TRZN E,400 ;CHECK AND CLEAR SIGN + MOVNS E + SKIPE GCDNTG ; SKIP IF GROWTH OK + JUMPL E,VECRE2 + ASH E,6 ;CONVERT TO WORDS + ADD B,E ;UPDATE FUTURE RELOCATIONS +VECRE2: SUBI A,400000(C) ;AND MOVE ON TO NEXT VECTOR + ANDI C,377777 ;KILL MARK + SUBI B,(C) ; UPDATE WHERE TO GO LOCN + SOJG C,VECREL ;AND KEEP GOING + JSP D,VCMLOS ;LOSES, LEAVE TRACKS + +;PAIR SPACE UPDATE + +;GETS PARBOT IN AC A +;UPDATES VALUES AND CDRS UP TO PARTOP + +PARUPD: CAML A,PARTOP ;ARE THERE MORE PAIRS TO PROCESS + POPJ P, ;NO -- RETURN + +;UPDATE VALUE CELL +PARUP1: ANDCAM D,(A) ; KILL MARK BIT + HLRZ B,(A) ;SET RH OF B TO TYPE + MOVE C,1(A) ;SET C TO VALUE + PUSHJ P,VALUPD ;UPDATE THIS VALUE + ADDI A,2 ;MOVE ON TO NEXT PAIR + JRST PARUPD ;AND CONTINUE + + + ;VECTOR SPACE UPDATE +;GETS VECTOP IN A +;UPDATES ALL VALUE CELLS IN MARKED VECTORS +;ESCAPES WHEN IT GETS TO VECBOT + +VECUPD: SUBI A,1 ;MAKE A POINT TO LAST DOPE WD + PUSH P,VECBOT + PUSHJ P,UPD1 + SUB P,[1,,1] + POPJ P, + +; STORAGE SPACE UPDATE + +STOUP: PUSH P,[STOSTR] + PUSHJ P,UPD1 + SUB P,[1,,1] + JRST ENHACK +UPD1: +VECUP1: CAMG A,-1(P) ;ANY MORE VECTORS TO PROCESS? + POPJ P, + SKIPGE B,(A) ;IS DOPE WORD MARKED? + JRST VECUP2 ;YES -- GO PROCESS VALUES IN THIS VECTOR + HLLZS -1(A) ;MAKE SURE NO GROWTH ATTEMPTS + HLRZS B ;NO -- SET RH OF B TO SIZE OF VECTOR +VECUP5: SUB A,B ;SET A TO POINT TO DOPE WD OF NEXT VECTOR + JRST VECUP1 ;AND CONTINUE + +VECUP2: PUSH P,A ;SAVE DOPE WORD POINTER + HLRZ B,(A) ;GET LENGTH OF THIS VECTOR +VECU11: ANDI B,377777 ;TURN OFF MARK BIT + SKIPGE E,-1(A) ;CHECK FOR UNIFORM OR SPECIAL + TLNE E,377777 ;SKIP IF GENERAL + JRST VECUP6 ;UNIFORM OR SPECIAL, GO DO IT +VECU10: SUB A,B ;SET AC A TO NEXT DOPE WORD + ADDI A,1 ;AND ADVANCE TO FIRST ELEMENT OF THIS VECTOR +VECUP3: HLRZ B,(A) ;GET TYPE + TRNE B,400000 ;IF MARK BIT SET + JRST VECUP4 ;DONE WITH THIS VECTOR + ANDI B,TYPMSK + CAIE B,TCBLK + CAIN B,TENTRY ;SPECIAL HACK FOR ENTRY + JRST ENTRUP + CAIE B,TUNWIN + CAIN B,TSKIP ; SKIP POINTER + JRST BINDUP ; HACK APPROPRAITELY + CAIE B,TBVL ;VECTOR BINDING? + CAIN B,TBIND ;AND BINDING BLOCK + JRST BINDUP + CAIN B,TUBIND + JRST BINDUP +VECU15: MOVE C,1(A) ;GET VALUE + PUSHJ P,VALUPD ;UPDATE THIS VALUE +VECU12: ADDI A,2 ;GO ON TO NEXT VECTOR + JRST VECUP3 ;AND CONTINUE + +VECUP4: POP P,A ;SET TO OLD DOPE WORD + ANDCAM D,(A) ;TURN OFF MARK BIT + HLRZ B,(A) ;GET LENGTH + ANDI B,377777 ; IN CASE DING STORAGE + JRST VECUP5 ;GO ON TO NEXT VECTOR + + + +;UPDATE A SAVED SAVE BLOCK +ENTSUP: MOVEI A,FRAMLN+SPSAV-1(A) ;A POINTS BEFORE SAVED SP + MOVEI B,TSP + PUSHJ P,VALPD1 ;UPDATE SPSAV + MOVEI A,PSAV-SPSAV(A) + MOVEI B,TPDL + PUSHJ P,VALPD1 ;UPDATE PSAV + MOVEI A,TPSAV-PSAV(A) + MOVEI B,TTP + PUSHJ P,VALPD1 ;UPDATE TPSAV +;SKIP TO END OF BLOCK + SUBI A,PSAV-1 + JRST VECUP3 + +;IGNORE A BLOCK +IGBLK2: HRRZ B,(A) ;GET DISPLACEMENT + ADDI A,3(B) ;USE IT + JRST VECUP3 ;GO + + ; ENTRY PART OF THE STACK UPDATER + +ENTRUP: ADDI A,FRAMLN-2 ;POINT PAST FRAME + JRST VECU12 ;NOW REJOIN VECTOR UPDATE + +; UPDATE A BINDING BLOCK + +BINDUP: HRRZ C,(A) ;POINT TO CHAIN + JUMPE C,NONEXT ;JUMP IF NO NEXT BINDING IN CHAIN + HRRZ 0,@(P) ; GET OWN DESTINATION + SUBI 0,@(P) ; RELATIVIZE + ADD C,0 ; AND UPDATE + HRRM C,(A) ;AND STORE IT BACK +NONEXT: CAIN B,TUBIND + JRST .+3 + CAIE B,TBIND ;SKIP IF VAR BINDING + JRST VECU14 ;NO, MUST BE A VECTOR BIND + MOVEI B,TATOM ;UPDATE ATOM POINTER + PUSHJ P,VALPD1 + ADDI A,2 + HLRZ B,(A) ;TYPE OF VALUE + PUSHJ P,VALPD1 + ADDI A,2 ; POINT TO PREV LOCATIVE +VECU16: MOVEI B,TLOCI + SKIPN 1(A) ; IF NO LOCATIVE, + MOVEI B,TUNBOU ; SAY UNBOUND + PUSHJ P,VALPD1 + JRST VECU12 + +VECU14: CAIN B,TBVL ; CHANGE BVL TO VEC + MOVEI B,TVEC ;NOW TREAT LIKE A VECTOR + JRST VECU15 + +; NOW SAFE TO UPDATE ALL ENTRY BLOCKS + +ENHACK: HRRZ F,TBSTO(LPVP) ;GET POINTER TO TOP FRAME + HLLZS TBSTO(LPVP) ;CLEAR FIELD + HLLZS TPSTO(LPVP) + JUMPE F,LSTFRM ;FINISHED + +ENHCK1: MOVEI A,FSAV-1(F) ;POINT PRIOR TO SAVED FUNCTION + HRRZ C,1(A) ; GET POINTER TO FCN + CAML C,VECBOT ; SKIP IF A LOSER + CAMLE C,VECTOP ; SKIP IF A WINNER + JRST ENHCK2 + HRL C,(C) ; MAKE INTO AOBJN + MOVEI B,TVEC + PUSHJ P,VALUPD ; AND UPDATE +ENHCK2: HRRZ F,2(A) ;POINT TO PRIOR FRAME + MOVEI B,TTB ;MARK SAVED TB + PUSHJ P,[AOJA A,VALPD1] + MOVEI B,TAB ;MARK ARG POINTER + PUSHJ P,[AOJA A,VALPD1] + MOVEI B,TSP ;SAVED SP + PUSHJ P,[AOJA A,VALPD1] + MOVEI B,TPDL ;SAVED P STACK + PUSHJ P,[AOJA A,VALPD1] + MOVEI B,TTP ;SAVED TP + PUSHJ P,[AOJA A,VALPD1] + JUMPN F,ENHCK1 ;MARK NEXT ONE IF IT EXISTS + +LSTFRM: HRRZ A,BINDID(LPVP) ;NEXT PROCESS + HLLZS BINDID(LPVP) ;CLOBBER + MOVEI LPVP,(A) + JUMPN LPVP,ENHACK ;DO NEXT PROCESS + POPJ P, + + ; UPDATE ELEMENTS IN UNIFROM AND SPECIAL VECTORS + +VECUP6: JUMPL E,VECUP7 ;JUMP IF SPECIAL + CAIG B,2 ;EMPTY UVECTOR ? + JRST VECUP4 ;YES, NOTHING TO UPDATE + HLRZS E ;ISOLATE TYPE + ANDI E,37777 + EXCH E,B ;TYPE TO B AND LENGTH TO E + SUBI A,(E) ;POINT TO NEXT DOPE WORD + LSH B,1 ;FIND SAT + HRRZ B,@TYPNT + ANDI B,SATMSK + MOVE B,UPDTBS(B) ;FIND WHERE POINTS + CAIN B,CPOPJ ;UNMARKED? + JRST VECUP4 ;YES, GO ON TO NEXT VECTOR + PUSH P,B ;SAVE SR POINTER + SUBI E,2 ;DON'T COUNT DOPE WORDS + +VECUP8: MOVE C,1(A) ;GET GOODIE + MOVEI 0,(C) ; ISOLATE ADDR + JUMPE 0,.+3 ; NEVER 0 PNTR + CAIGE 0,@PURBOT ; OR IF PURE + PUSHJ P,@(P) ;CALL UPDATE ROUTINE + ADDI A,1 + SOJG E,VECUP8 ;LOOP FOR ALL ELEMNTS + + SUB P,[1,,1] ;REMOVE RANDOMNESS + JRST VECUP4 + +; SPECIAL VECTOR UPDATE + +VECUP7: HLRZS E ;ISOLATE SPECIAL TYPE + CAIN E,SATOM+400000 ;ATOM? + JRST ATOMUP ;YES, GO DO IT + CAIN E,STPSTK+400000 ;STACK + JRST VECU10 ;TREAT LIKE A VECTOR + CAIN E,SPVP+400000 ;PROCESS VECTOR + JRST PVPUP ;DO SPECIAL STUFF + CAIN E,SASOC+400000 + JRST ASOUP ;UPDATE ASSOCIATION BLOCK + + TRZ E,400000 ; CHECK FOR TEMPLATE VECTOR + CAIG E,NUMSAT ; SKIP IF POSSIBLE + FATAL AGC--UNRECOGNIZED SPECIAL VECTOR (UPDATE) + MOVEI E,-NUMSAT-1(E) + HRLI E,(E) + ADD E,TD.LNT+1(TVP) + SKIPL E + FATAL AGC--BAD TEMPLATE TYPE + +TD.UPD: MOVEI C,-1(A) ; POINTER TO OBJECT IN C + XCT (E) + HLRZ D,B ; POSSIBLE BASIC LENGTH + PUSH P,[0] + PUSH P,D + MOVEI B,(B) ; ISOLATE LENGTH + PUSH P,C ; SAVE POINTER TO OBJECT + + PUSH P,[0] ; HOME FOR VALUES + PUSH P,[0] ; SLOT FOR TEMP + PUSH P,B ; SAVE + SUB E,TD.LNT+1(TVP) + PUSH P,E ; SAVE FOR FINDING OTHER TABLES + JUMPE D,TD.UP2 ; NO REPEATING SEQ + ADD E,TD.GET+1(TVP) ; COMP LNTH OF REPEATING SEQ + HLRE E,(E) ; E ==> - LNTH OF TEMPLATE + ADDI E,(D) ; E ==> -LENGTH OF REP SEQ + MOVNS E + HRLM E,-5(P) ; SAVE IT AND BASIC + +TD.UP2: SKIPG D,-1(P) ; ANY LEFT? + JRST TD.UP1 + + MOVE E,TD.GET+1(TVP) + ADD E,(P) + MOVE E,(E) ; POINTER TO VECTOR IN E + MOVEM D,-6(P) ; SAVE ELMENT # + SKIPN B,-5(P) ; SKIP IF "RESTS" EXIST + SOJA D,TD.UP3 + + MOVEI 0,(B) ; BASIC LNT TO 0 + SUBI 0,(D) ; SEE IF PAST BASIC + JUMPGE 0,.-3 ; JUMP IF O.K. + MOVSS B ; REP LNT TO RH, BASIC TO LH + IDIVI 0,(B) ; A==> -WHICH REPEATER + MOVNS A + ADD A,-5(P) ; PLUS BASIC + ADDI A,1 ; AND FUDGE + MOVEM A,-6(P) ; SAVE FOR PUTTER + ADDI E,-1(A) ; POINT + SOJA D,.+2 + +TD.UP3: ADDI E,(D) ; POINT TO SLOT + XCT (E) ; GET THIS ELEMENT INTO A AND B + MOVEM A,-3(P) ; SAVE TYPE FOR LATER PUT + MOVEM B,-2(P) + MOVE C,B ; VALUE TO C FOR VALUPD + GETYP B,A + MOVEI A,-3(P) ; TELL OTHER GUYS THEY CANT DIRECTLY MUNG + MOVSI D,400000 ; RESET FOR MARK + PUSHJ P,VALUPD ; AND MARK THIS GUY (RET FIXED POINTER IN A) + MOVE C,-4(P) ; GET POINTER FOR UPDATE OF ELEMENT + MOVE E,TD.PUT+1(TVP) + SOS D,-1(P) ; RESTORE COUNT + ADD E,(P) + MOVE E,(E) ; POINTER TO VECTOR IN E + MOVE B,-6(P) ; SAVED OFFSET + ADDI E,(B)-1 ; POINT TO SLOT + MOVE A,-3(P) ; RESTORE TYPE WORD + MOVE B,-2(P) + XCT (E) ; SMASH IT BACK + FATAL TEMPLATE LOSSAGE + MOVE C,-4(P) + JRST TD.UP2 + +TD.UP1: SUB P,[7,,7] + MOVSI D,400000 ; RESTORE MARK/UNMARK BIT + JRST VECUP4 + + ; UPDATE ATOM VALUE CELLS + +ATOMUP: SUBI A,-1(B) ; POINT TO VALUE CELL + HLRZ B,(A) + HRRZ 0,(A) ;GOBBLE BINDID + JUMPN 0,.+3 ;NOT GLOBAL + CAIN B,TLOCI ;IS IT A LOCATIVE? + MOVEI B,TVEC ;MARK AS A VECTOR + HRRZ 0,1(A) ; GET POINTER + CAML 0,VECBOT + CAMLE 0,VECTOP + JRST .+2 ; OUT OF BOUNDS, DONT UPDATE + PUSHJ P,VALPD1 ;UPDATE IT + MOVEI B,TOBLS ; TYPE TO OBLIST + SKIPGE 2(A) + PUSHJ P,[AOJA A,VALPD1] + JRST VECUP4 + +; UPDATE PROCESS VECTOR + +PVPUP: SUBI A,-1(B) ;POINT TO TOP + HRRM LPVP,BINDID(A) ;CHAIN ALL PROCESSES TOGETHER + MOVEI LPVP,(A) + HRRZ 0,TBSTO+1(A) ;POINT TO CURRENT FRAME + HRRM 0,TBSTO(A) ;SAVE + HRRZ 0,TPSTO+1(A) ;0_SAVED TP POINTER + HLRE B,TPSTO+1(A) + SUBI 0,-1(B) ;0 _ POINTER TO OLD DOPE WORD + HRRM 0,TPSTO(A) + JRST VECUP3 + + + ;THIS SUBROUTINE TAKES CARE OF UPDATING ASSOCIATION BLOCKS + +ASOUP: SUBI A,-1(B) ;POINT TO START OF BLOCK + HRRZ B,ASOLNT-1(A) ;POINT TO NEXT + JUMPE B,ASOUP1 + HRRZ C,ASOLNT+1(B) ;AND GET ITS RELOC IN C + SUBI C,ASOLNT+1(B) ; RELATIVIZE + ADDM C,ASOLNT-1(A) ;C NOW HAS UPDATED PONTER +ASOUP1: HLRZ B,ASOLNT-1(A) ;GET PREV BLOCK POINTER + JUMPE B,ASOUP2 + HRRZ F,ASOLNT+1(B) ;AND ITS RELOCATION + SUBI F,ASOLNT+1(B) ; RELATIVIZE + MOVSI F,(F) + ADDM F,ASOLNT-1(A) ;RELOCATE +ASOUP2: HRRZ B,NODPNT(A) ;UPDATE NODE CHAIN + JUMPE B,ASOUP4 + HRRZ C,ASOLNT+1(B) ;GET RELOC + SUBI C,ASOLNT+1(B) ; RELATIVIZE + ADDM C,NODPNT(A) ;ANID UPDATE +ASOUP4: HLRZ B,NODPNT(A) ;GET PREV POINTER + JUMPE B,ASOUP5 + HRRZ F,ASOLNT+1(B) ;RELOC + SUBI F,ASOLNT+1(B) + MOVSI F,(F) + ADDM F,NODPNT(A) +ASOUP5: HRLI A,-3 ;SET TO UPDATE OTHER CONTENTS + +ASOUP3: HLRZ B,(A) ;GET TYPE + PUSHJ P,VALPD1 ;UPDATE + ADD A,[1,,2] ;MOVE POINTER + JUMPL A,ASOUP3 + JRST VECUP4 ;AND QUIT + + ;VALUPD UPDATES A SINLE VALUE FROM EITHER PAIR SPACE OR VECTOR SPACE +;GETS POINTER TO TYPE CELL IN RH OF A +;TYPE IN RH OF B (LH MUST BE 0) +;VALUE IN C + +VALPD1: MOVE C,1(A) ;GET VALUE TO UPDATE +VALUPD: MOVEI 0,(C) + CAIGE 0,@PURBOT ; SKIP IF PURE, I.E. DONT HACK + TRNN C,-1 ;ANY POINTER PART? + JRST CPOPJ ;NO, LEAVE + ANDI B,TYPMSK + LSH B,1 ;SET TYPE TIMES 2 + HRRZ B,@TYPNT ;GET STORAGE ALLOCATION TYPE + ANDI B,SATMSK + CAIG B,NUMSAT ; SKIP IF TEMPLATE + JRST @UPDTBS(B) ;AND DISPATCH THROUGH STORAGE ALLOCATION DISPATCH TABLE + AOJA C,TMPLUP + +;SAT DISPATCH TABLE + +DISTBS UPDTBS,CPOPJ,[[SNWORD,NWRDUP],[STPSTK,STCKUP] +[SFRAME,FRAMUP],[STBASE,TBUP],[SARGS,ARGUP],[SBYTE,BYTUP],[SATOM,NWRDUP],[SPSTK,STCKUP] +[SLOCID,LOCUP],[SPVP,NWRDUP],[S2NWORD,NWRDUP],[SABASE,ABUP],[SCHSTR,BYTUP],[SASOC,ASUP] +[SLOCA,ARGUP],[SLOCU,NWRDUP],[SLOCN,ASUP],[SLOCS,BYTUP],[SGATOM,NWRDUP]] + + + + +;PAIR POINTER UPDATE +2WDUP: MOVEI 0,(C) + CAIGE 0,@PURBOT ; SKIP AND IGNORE IF PURE + TRNN C,-1 ;POINT TO NIL? + POPJ P, ;YES -- NO UPDATE NEEDED + SKIPGE B,(C) ;NO -- IS THIS A BROKEN HEART + HRRM B,1(A) ;YESS -- STORE NEW VALUE + SKIPE B,PARNEW ;IF LIST SPACE IS MOVING + ADDM B,1(A) ;THEN ADD OFFSET TO VALUE + POPJ P, ;FINISHED + +; HERE TO UPDATE ASSOCIATIONS + +ASUP: HRLI C,-ASOLNT ;MAKE INTO VECTOR POINTER + JRST NWRDUP + ;VECTOR, ATOM, STACK, AND BASE POINTER UPDATE + +LOCUP: HRRZ B,(A) ;CHECK IF IT IS TIMED + JUMPN B,LOCUP1 ;JUMP IF TIMED, OTHERWISE TREAT LIKE VECTORE + +NWRDUP: HLRE B,C ;EXTEND COUNT IN B + SUBI C,-1(B) ;SET C TO POINT TO DOPE WORD +TMPLUP: HRRZ B,(C) ;EXTEND RELOCATION IN B + SUBI B,(C) ; RELATIVIZE + ADDM B,1(A) ;AND ADD RELOCATION TO STORED DATUM + HRRZ C,-1(C) ;GET GROWTH SPECS + JUMPE C,CPOPJ ;NO GROWTH, LEAVE + LDB C,[111100,,C] ;GET UPWORD GROWTH + TRZN C,400 ;FLUSH SIGN AN NEGATR DIRECTION + MOVNS C + SKIPE GCDNTG ; SKIP IF GROWTH WINS + JUMPL C,CPOPJ ; POS GROWTH, LOSE + ASH C,6+18. ;TO LH AND TIMES 100(8) + ADDM C,1(A) ;UPDATE POINTER + POPJ P, + + +LOCUP1: +STCKUP: MOVSI B,PDLBUF ;GET OFFSET FOR PDLS + ADDM B,1(A) ;AND ADD TO COUNT + JRST NWRDUP ;NOW TREAT LIKE VECTOR + +BYTUP: MOVEI C,(A) ; SET TO GET DOPE WORD + PUSH P,A + PUSHJ P,BYTDOP + POP P,C + HRRZ B,(A) ;SET B TO RELOCATION FOR THIS VEC + SUBI B,(A) ; RELATIVIZE + ADDM B,1(C) ;AND UPDATE VALUE + MOVE A,C ; FIX UP FOR SCANNER + POPJ P, ;DONE WITH UPDATE + +ARGUP: +ABUP: HLRE B,C ;GET LENGTH + SUB C,B ;POINT TO FRAME + HLRZ B,(C) ;GET TYPE OF NEXT GOODIE + ANDI B,TYPMSK + CAIN B,TINFO ;IS IT A FRAME + ADD C,1(C) ;NO, POINT TO FRAME + CAIE B,TINFO ;IF IT IS A FRAME + ADDI C,FRAMLN ;POINT TO ITS BASE +TBUP: MOVE C,TPSAV(C) ;GET A ASTACK POINTER TO FIND DOPE WORD + HLRE B,C ;UPDATE BASED ON THIS POINTER + SUBI C,(B) +ABUP1: HRRZ B,1(C) ;GET RELOCATION + SUBI B,1(C) ; RELATIVIZE + ADDM B,1(A) ;AND MUNG POINTER + POPJ P, + +FRAMUP: HRRZ B,(A) ;UPDATE PVP + HRRZ C,(B) ;IN CELL + SUBI C,(B) ; RELATIVIZE + ADDM C,(A) + HLRZ C,(B) + ANDI C,377777 + SUBI B,-1(C) ;ADDRESS OF PV + HRRZ C,TPSTO(B) ;IF TPSTO HAS OLD TP DOPE WORD, + JUMPN C,ABUP2 ;USE IT + HRRZ C,TPSTO+1(B) ;ELSE, GENERATE IT + HLRE B,TPSTO+1(B) + SUBI C,-1(B) +ABUP2: SOJA C,ABUP1 ; FUDGE AND GO + + ;VECTOR SHRINKING PHASE + +VECSH: SUBI A,1 ;POOINT TO 1ST DOPE WORD +VECSH1: CAMGE A,VECBOT ;FINISHED + POPJ P, ;YES, QUIT + HRRZ B,-1(A) ;GET A SPEC + JUMPE B,NXTSHN ;IGNORE IF NONE + PUSHJ P,GETGRO ;GET THE SPECS + JUMPGE C,SHRNBT ;SHRINKIGN AT BOTTOM + MOVEI E,(A) ;COPY POINTER + ADD A,C ;POINT TO NEW DOPE LOCATION WITH E + MOVE F,-1(E) ;GET OLD DOPE + ANDCMI F,777000 ;KILL THIS SPEC + MOVEM F,-1(A) ;STORE + MOVE F,(E) ;OTHER DOPE WORD + ADD F,C ; UPDATE DESTINATION + HRLZI C,(C) ;TO LH + ADD F,C ;CHANGE LENGTH + MOVEM F,(A) ;AND STORE + MOVMS C ;PLUSIFY + HRRI C,(E) ; MAKE NOT MOVE + MOVEM C,(E) ;AND STORE + SETZM -1(E) +SHRNBT: JUMPGE B,NXTSHN ;GROWTH, IGNOORE + MOVM E,B ;GET A POSITIVE COPY + HRLZI B,(B) ;TO LH + ADDM B,(A) ;ADD INTO DOPE WORD + MOVEI 0,777 ;SET TO CLOBBER GROWTH + ANDCAM 0,-1(A) ;CLOBBER + HLRZ B,(A) ;GET NEW LENGTH + SUBI A,(B) ;POINT TO LOW END + HRLI E,(A) ; MAKE NON MOVER + MOVSM E,(A) ;STORE + SETZM -1(A) + +NXTSHN: HLRZ B,(A) ;GET LENGTH + JUMPE B,VCMLOS ;LOOSE + SUBI A,(B) ;STEP + JRST VECSH1 + +GETGRO: LDB C,[111100,,B] ;GET UPWARD GROWTH + TRZE C,400 ;CHECK AND MUNG SIGN + MOVNS C + ASH C,6 ;?IMES 100 + ANDI B,777 ;AND GET DOWN GROWTH + TRZE B,400 ;CHECK AND MUNG SIGN + MOVNS B + ASH B,6 + POPJ P, + ;VECMOV -- MOVES VECTOR DATA TO WHERE RELOC FIELDS OF +;VECTORS INDICATE. MOVES DOPEWDS UP FOR VECTORS GROWING AT +;THE END. +;CALLED WITH VECTOP IN A. CALLS PARMOV TO MOVE PAIRS + +VECMOV: SUBI A,1 ;SET A TO ADDR OF TOP DOPE WD + MOVSI D,400000 ;NEGATIVE D MARKS END OF BACK CHAIN + MOVEI TYPNT,0 ;CLEAR ON GOING ADDRESS FOR FORWARD RESUME +VECMO1: CAMGE A,VECBOT ;GOT TO BOTTOM OF VECTORS + JRST PARMOV ;YES, MOVE LIST ELEMENTS AND RETURN + MOVEI C,(A) ;NO, COPY ADDR OF THIS DOPEWD + HRRZ B,(A) ;GET RELOCATION OF THIS VECTOR + SUBI B,(A) ; RELATIVIZE + JUMPL B,VECMO5 ;IF MOVING DOWNWARD, MAKE BACK CHAIN + JUMPE B,VECMO4 ;IF NON MOVER, JUST ADJUST DOPW AND MOVE ON + + ADDI C,(B) ;SET ADDR OF LAST DESTINATION WD + HRLI B,A ;MAKE B INDEX ON A + HLL A,(A) ;COUNT TO A LEFT HALF + + POP A,@B ;MOVE A WORD + TLNE A,-1 ;REACHED END OF MOVING + JRST .-2 ;NO, REPEAT + ;YES, NOTE A HAS ADDR OF NEXT DOPEWD + ;HERE TO ADJUST LOCATION OF DOPEWDS FOR GROWTH (FORWARDLY) +VECMO2: LDB B,[111000,,-1(C)] ;GET HIGH GROWTH FIELD + JUMPE B,VECMO3 ;IF NO GROWTH, DONT MOVE + SKIPE GCDNTG ; SKIP IF GROWTH PERMITTED + JRST VECMO3 + ASH B,6 ;EXPRESS GROWTH IN WORDS + HRLI C,2 ;SET COUNT FOR POPPING 2 DOPEWDS + HRLI B,C ;MAKE B INDEX ON C + POP C,@B ;MOVE PRIME DOPEWD + POP C,@B ;MOVE AUX DOPEWD +VECMO3: JUMPL D,VECMO1 ;IF NO BACK CHAIN THEN MOVE ON + JRST VECMO6 ;YES, BACKCHAINING, CONTINUE SAME + +;HERE TO SKIP OVER STILL VECTORS (FORWARDLY) +VECMO4: HLRZ B,(A) ;GET SIZE OF UNMOVER + SUBI A,(B) ;UPDATE A TO NEXT VECTOR + JRST VECMO2 ;AND GO CLEAN UP GROWTH +;HERE TO ESTABLISH A BACKWARDS CHAIN +VECMO5: EXCH D,(A) ;CHAIN FORWARD + HLRZ B,D ;GET SIZE + SUBI A,(B) ;GO ON TO NEXT VECOTR + CAMGE A,VECBOT ;HAVE WE GOT TO END OF VECTORS? + JRST VECMO7 ;YES, GO MOVE PAIRS AND UNCHAIN + HRRZ B,(A) ;GET RELOCATION OF THIS VECTOR + SUBI B,(A) ; RELATIVIZE + JUMPLE B,VECMO5 ;IF NOT POSITIVE, CONTINUE CHAINING + MOVEM A,TYPNT ;SAVE ADDR FOR FORWARD RESUME + +;HERE TO UNCHAIN A VECTOR, MOVE IT, AND ADJUST DOPEWDS +VECMO6: HLRZ B,D ;GET SIZE + MOVEI F,1(A) ;GET A COPY OF BEGINNING OF VECTOR + ADDI A,(B) ;SET TO POINT TO ADDR OF DOPEWD CURRENTLY IN D + EXCH D,(A) ;AND UNCHAIN + HRRZ B,(A) ;GET RELOCATION FOR THIS VECTOR + SUBI B,(A) ; RELATIVIZE + MOVEI C,(A) ;COPY A POINTER TO DOPEW + SKIPGE D ;HAVE WE REACHED THE TOP OF THE CHAIN? + MOVE A,TYPNT ;YES, RESTORE FORWARD MOVE RESUME ADDR + JUMPE B,VECMO2 ;IF STILL VECTOR,GO ADJUST DOPEWDS + ADDI C,(B) ;MAKE C POINT TO NEW DOPEW ADDR + ADDI B,(F) ;B RH NEW 1ST WORD + HRLI B,(F) ;B LH OLD 1ST WD ADDR + BLT B,(C) ;COPY THE DATA + JRST VECMO2 ;AND GO ADJUST DOPEWDS + +;HERE TO STOP CHAINING BECAUSE OF BOTTOM OF VECTOR SPACE +VECMO7: MOVEM A,TYPNT + PUSH P,D + PUSHJ P,PARMOV + POP P,D + MOVE A,TYPNT + JRST VECMO6 + ;PAIR MOVEMENT PHASE -- USES PARNEW,PARBOT, AND PARTOP TO MOVE PAIRS +;TO NEW HOMES + +PARMOV: SKIPN A,PARNEW ;IS THERE ANY PAIR MOVEMENT? + POPJ P, ;NO, RETURN + JUMPL A,PARMO2 ;YES -- IF MOVING DOWNWARDS, GO DO A BLT + HRLI A,B ;MOVING UPWARDS SETAC A TO INDEX OFF AC B + MOVE B,PARTOP ;GET HIGH PAIR ADDREESS + SUB B,PARBOT ;AND SUBTRACT BOTTOM TO GET NUMBER OF PAIRS + HRLZS B ;PUT COUNT IN LEFT HALF + HRR B,PARTOP ;GET HIGH ADDRESS PLUS ONE IN RH + SUBI B,1 ;AND SUBTRACT ONE TO POINT TO LAST WORD TO BE MOVED + +PARMO1: TLNN B,-1 ;HAS COUNT REACHED ZERO? + JRST PARMO3 ;YES -- FINISH UP + POP B,@A ;NO -- TRANSFER2YU NEXT WORD + JRST PARMO1 ;AND REPEAT + +PARMO2: MOVE B,PARBOT ;GET ADDRESS OF FIRST SOURCE WD + HRLS B ;IN BOTH HALVES OF AC B + ADD B,A ;MAKE RH OF B POINT TO FIRST DESTINATION WORD + ADD A,PARTOP ;MAKE RH OF A POINT TO LAST DESTINATION WORD PLUS ONE + BLT B,-1(A) ;AND TRANSFER THE BLOCK OF PAIRS + +PARMO3: MOVE A,PARNEW ;GET OFFSET FOR PAIR SPACE + ADDM A,PARBOT ;AND CORRECT BOTTOM + ADDM A,PARTOP ;AND CORRECT TOP. + SETZM PARNEW ;CLEAR SO IF CALLED TWICE, NO LOSSAGE + POPJ P, + ;VECZER -- CLEARS DATA IN AREAS JUST GROWN +;UPDATES SIZE OF VECTORS +;CLEARS RELOCATION AND GROWTH FIELDS IN DOPEWDS +;CALLED WITH NEW VECTOP IN A (VECBOT SHOULD BE NEW TOO) + +VECZER: SUBI A,1 ;MAKE A POINT TO HIGH VECTORS +VECZE1: CAMGE A,VECBOT ;REACHED BOTTOM OF VECTORS? + POPJ P, ;YES, RETURN + HLLZS F,(A) ;NO, CLEAR RELOCATION GET SIZE + HLRZS F ;AND PUT SIZE IN RH OF F + HRRZ B,-1(A) ;GET GROWTH INTO B + JUMPN B,VECZE3 ;IF THERE IS SOME GROWTH, GO DO IT +VECZE2: SUBI A,(F) ;GROWTH DONE, MOVE ON TO NEXT VECTOR + JRST VECZE1 ;AND REPEAT + +VECZE3: HLLZS -1(A) ;CLEAR GROWTH IN THE VECTOR + LDB C,[111000,,B] ;GET HIGH ORDER GROWTH IN C + SKIPE GCDNTG + JRST VECZE5 + ANDI B,377 ;AND LIMIT B TO LOW SIDE + ASHC B,6 ;EXPRESS GROWTH IN WORDS + JUMPE C,VECZE4 ;IF NO HIGH GROWTH SKIP TO LOW GROWTH + ADDI F,(C) ;ADD HIGH GROWTH TO SIZE + SUBM A,C ;GET ADDR OF 2ND WD TO BE ZEROED + SETZM -1(C) ;CLEAR 1ST WORD + HRLI C,-1(C) ;MAKE C A CLEARING BLT POINTER + BLT C,-2(A) ;AND CLEAR HIGH END DATA + +VECZE4: JUMPE B,VECZE5 ;IF NO LOW GROWTH SKIP TO SIZE UPDATE + MOVNI C,(F) ;GET NEGATIVE SIZE SO FAR + ADDI C,(A) ;AND MAKE C POINT TO LAST WORD OF STUFF TO BE CLEARED + ADDI F,(B) ;UPDATE SIZE + SUBM C,B ;MAKE B POINT TO LAST WD OF NEXT VECT + ADDI B,2 ;AND NOW TO 2ND DATA WD TO BE CLEARED + SETZM -1(B) ;CLEAR 1ST DATA WD + HRLI B,-1(B) ;MAKE B A CLEARING BLT POINTER + BLT B,(C) ;AND CLEAR THE LOW DATA + +VECZE5: HRLZM F,(A) ;STORE THE NEW SIZE IN DOPEWD + JRST VECZE2 + + ;SUBROUTINE TO REBUILD THE NOW DEFUNCT HASH TABLE + +REHASH: MOVE TVP,TVPSTO+1(PVP) ;RESTORE TV POINTER + MOVE D,ASOVEC+1(TVP) ;GET POINTER TO VECTOR + MOVEI E,(D) + PUSH P,E ;PUSH A POINTER + HLRE A,D ;GET -LENGTH + MOVMS A ;AND PLUSIFY + PUSH P,A ;PUSH IT ALSO + +REH3: HRRZ C,(D) ;POINT TO FIRST BUCKKET + HLRZS (D) ;MAKE SURE NEW POINTER IS IN RH + JUMPE C,REH1 ;BUCKET EMPTY, QUIT + +REH2: MOVEI E,(C) ;MAKE A COPY OF THE POINTER + MOVE A,ITEM(C) ;START HASHING + TLZ A,TYPMSK#777777 ; KILL MONITORS + XOR A,ITEM+1(C) + MOVE 0,INDIC(C) + TLZ 0,TYPMSK#777777 + XOR A,0 + XOR A,INDIC+1(C) + TLZ A,400000 ;MAKE SURE FINAL HASH IS + + IDIV A,(P) ;DIVIDE BY TOTAL LENGTH + ADD B,-1(P) ;POINT TO WINNING BUCKET + + MOVE C,[002200,,(B)] ;BYTE POINTER TO RH + CAILE B,(D) ;IF PAST CURRENT POINT + MOVE C,[222200,,(B)] ;USE LH + LDB A,C ;GET OLD VALUE + DPB E,C ;STORE NEW VALUE + HRRZ B,ASOLNT-1(E) ;GET NEXT POINTER + HRRZM A,ASOLNT-1(E) ;AND CLOBBER IN NEW NEXT + SKIPE A ;SKKIP IF NOTHING PREVIOUSLY IN BUCKET + HRLM E,ASOLNT-1(A) ;OTHERWISE CLOBBER + SKIPE C,B ;SKIP IF END OF CHAIN + JRST REH2 +REH1: AOBJN D,REH3 + + SUB P,[2,,2] ;FLUSH THE JUNK + POPJ P, + VCMLOS: FATAL AGC--VECTOR WITH ZERO IN DOPE WORD LENGTH + + +; THESE ARE THE MESSAGES INDICATING THE CAUSE OF THE GC + +MSGGCT: [ASCIZ /USER CALLED- /] + [ASCIZ /FREE STORAGE- /] + [ASCIZ /TP-STACK- /] + [ASCIZ /TOP-LEVEL LOCALS- /] + [ASCIZ /GLOBAL VALUES- /] + [ASCIZ /TYPES- /] + [ASCIZ /STATIONARY IMPURE STORAGE- /] + [ASCIZ /P-STACK /] + [ASCIZ /BOTH STACKS BLOWN- /] + [ASCIZ /PURE STORAGE- /] + [ASCIZ /GC-RCALL- /] + +; THESE ARE MESSAGES INDICATING WHO CAUSED THE GC + +MSGGFT: 0 + [ASCIZ /BLOAT /] + [ASCIZ /GROW /] + [ASCIZ /LIST /] + [ASCIZ /VECTOR /] + [ASCIZ /SET /] + [ASCIZ /SETG /] + [ASCIZ /FREEZE /] + [ASCIZ /PURE-PAGE LOADER /] + [ASCIZ /GC /] + [ASCIZ /INTERRUPT-HANDLER /] + [ASCIZ /NEWTYPE /] + + + + +;LOCAL VARIABLES + +IMPURE +; LOCATIONS USED BY BLOAT-STAT TO HELP THE USER PICK BLOAT SPECIFICATIONS. +; + +GCNO: 0 ; USER-CALLED GC +BSTGC: 0 ; FREE STORAGE + 0 ; BLOWN TP + 0 ; TOP-LEVEL LVALS + 0 ; GVALS + 0 ; TYPE + 0 ; STORAGE + 0 ; P-STACK + 0 ; BOTH STATCKS BLOWN + 0 ; STORAGE + +BSTAT: +NOWFRE: 0 ; FREE STORAGE FROM LAST GC +CURFRE: 0 ; STORAGE USED SINCE LAST GC +MAXFRE: 0 ; MAXIMUM FREE STORAGE ALLOCATED +USEFRE: 0 ; TOTAL FREE STORAGE USED +NOWTP: 0 ; TP LENGTH FROM LAST GC +CURTP: 0 ; # WORDS ON TP +CTPMX: 0 ; MAXIMUM SIZE OF TP SO FAR +NOWLVL: 0 ; # OF TOP-LEVEL LVAL-SLOTS +CURLVL: 0 ; # OF TOP-LEVEL LVALS +NOWGVL: 0 ; # OF GVAL SLOTS +CURGVL: 0 ; # OF GVALS +NOWTYP: 0 ; SIZE OF TYPE-VECTOR +CURTYP: 0 ; # OF TYPES +NOWSTO: 0 ; SIZE OF STATIONARY STORAGE +CURSTO: 0 ; STATIONARY STORAGE IN USE +CURMAX: 0 ; MAXIMUM BLOCK OF CONTIGUOUS STORAGE +NOWP: 0 ; SIZE OF P-STACK +CURP: 0 ; #WORDS ON P +CPMX: 0 ; MAXIMUM P-STACK LENGTH SO FAR +GCCAUS: 0 ; INDICATOR FOR CAUSE OF GC +GCCALL: 0 ; INDICATOR FOR CALLER OF GC + + +; THIS GROUP OF VARIABLES DETERMINES HOW THINGS GROW +LVLINC: 6 ; LVAL INCREMENT ASSUMED TO BE 64 SLOTS +GVLINC: 4 ; GVAL INCREMENT ASSUMED TO BE 64 SLOTS +TYPIC: 1 ; TYPE INCREMENT ASSUMED TO BE 32 TYPES +STORIC: 2000 ; STORAGE INCREMENT USED BY NFREE (MINIMUM BLOCK-SIZE) + + +RCL: 0 ; POINTER TO LIST OF RECYCLEABLE LIST CELLS +GCMONF: 0 ; NON-ZERO SAY GIN/GOUT +GCDANG: 0 ; NON-ZERO, STORAGE IS LOW +GCDNTG: 0 ; NON-ZERO ABORT GROWTHS +GETNUM: 0 ;NO OF WORDS TO GET +PARNUM: 0 ;NO OF PAIRS MARKED +VECNUM: 0 ;NO OF WORDS IN MARKED VECTORS +CORSET: 0 ;NO OF BLOCKS OF CORE, IF GIVING CORE AWAY +CORTOP: 0 ;CURRENT TOP OF CORE, EXCLUDING ANY TO BE GIVEN AWAY + +;VARIABLES WHICH DETERMIN WHEN MUDDLE WILL ASK FOR MORE CORE, +;AND WHEN IT WILL GET UNHAPPY + +SYSMAX: 50. ;MAXIMUM SIZE OF MUDDLE +FREMIN: 20000 ;MINIMUM FREE WORDS +FREDIF: 10000 ;DIFFERENCE BETWEEN FREMIN AND MAXIMUM NUMBER OF FREE WORDS +;POINTER TO GROWING PDL + +TPGROW: 0 ;POINTS TO A BLOWN TP +PPGROW: 0 ;POINTS TO A BLOWN PP +TIMOUT: 0 ;POINTS TO TIMED OUT PDL +PGROW: 0 ;POINTS TO A BLOWN P + +;IN GC FLAG + +GCFLG: 0 +GCFLCH: 0 ; TELL INT HANDLER TO ITIC CHARS +GCHAIR: 1 ; COUNTS GCS AND TELLS WHEN TO HAIRIFY +SHRUNK: 0 ; NON-ZERO=> AVECTOR(S) SHRUNK +GREW: 0 ; NON-ZERO=> A VECTOR(S) GREW +SPARNW: 0 ; SAVED PARNEW +GCDOWN: 0 ; AMOUNT TO TRY AND MOVE DOWN +CURPLN: 0 ; LENGTH OF CURRENTLY RUNNING PURE RSUBR + +; VARS ASSOCIATED WITH BLOAT LOGIC + +TPBINC: 0 +GLBINC: 0 +TYPINC: 0 + +; VARS FOR PAGE WINDOW HACKS + +WNDBOT: 0 ; BOTTOM OF WINDOW +WNDTOP: 0 +BOTNEW: (FPTR) ; POINTER TO FRONTIER +GCTIM: 0 + +PURE + + +END + + + + + + \ No newline at end of file diff --git a/sumex/arith.mbd079 b/sumex/arith.mbd079 new file mode 100644 index 0000000..fc37da3 --- /dev/null +++ b/sumex/arith.mbd079 @@ -0,0 +1,825 @@ +TITLE ARITHMETIC PRIMITIVES FOR MUDDLE + +.GLOBAL HI,RLOW,CPLUS,CMINUS,CTIMES,CDIVID,CFIX,CFLOAT +.GLOBAL CLQ,CGQ,CLEQ,CGEQ,C1Q,C0Q,CMAX,CMIN,CABS,CMOD,CCOS,CSIN,CATAN,CLOG +.GLOBAL CEXP,CSQRT,CTIME,CORB,CXORB,CANDB,CEQVB,CRAND,SAT,BFLOAT + +;BKD + +;DEFINES MUDDLE PRIMITIVES: FIX,FLOAT,ATAN,IEXP,LOG, +; G?,L?,0?,1?,+,-,*,/,MAX,MIN,ABS,SIN,COS,SQRT,RANDOM, +; TIME,SORT. + +RELOCATABLE + +.INSRT MUDDLE > + +O=0 + + +DEFINE TYP1 + (AB) TERMIN +DEFINE VAL1 + (AB)+1 TERMIN + +DEFINE TYP2 + (AB)+2 TERMIN +DEFINE VAL2 + (AB)+3 TERMIN + +DEFINE TYP3 + (AB)+4 TERMIN +DEFINE VAL3 + (AB)+5 TERMIN + +DEFINE TYPN + (D) TERMIN +DEFINE VALN + (D)+1 TERMIN + + +YES: MOVSI A,TATOM ;RETURN PATH FOR 'TRUE' + MOVE B,MQUOTE T + AOS (P) + POPJ P, + +NO: MOVSI A,TFALSE ;RETURN PATH FOR 'FALSE' + MOVEI B,NIL + POPJ P, + + ;ERROR RETURNS AND OTHER UTILITY ROUTINES + +OVRFLW==10 +OVRFLD: PUSH TP,$TATOM + PUSH TP,EQUOTE OVERFLOW + JRST CALER1 + +CARGCH: GETYP 0,A ; GET TYPE + CAIN 0,TFLOAT + POPJ P, + JSP A,BFLOAT + POPJ P, + +ARGCHK: ;CHECK FOR SINGLE FIXED OR FLOATING + ;ARGUMENT IF FIXED CONVERT TO FLOATING + ;RETURN FLOATING ARGRUMENT IN B ALWAYS + ENTRY 1 + GETYP C,TYP1 + MOVE B,VAL1 + CAIN C,TFLOAT ;FLOATING? + POPJ P, ;YES, RETURN + CAIE C,TFIX ;FIXED? + JRST WTYP1 ;NO, ERROR + JSP A,BFLOAT ;YES, CONVERT TO FLOATING AND RETURN + POPJ P, + +OUTRNG: PUSH TP,$TATOM + PUSH TP,EQUOTE ARGUMENT-OUT-OF-RANGE + JRST CALER1 + +NSQRT: PUSH TP,$TATOM + PUSH TP,EQUOTE NEGATIVE-ARGUMENT + JRST CALER1 + +DEFINE MFLOAT AC + IDIVI AC,400000 + FSC AC+1,233 + FSC AC,254 + FADR AC,AC+1 + TERMIN + +BFLOAT: MFLOAT B + JRST (A) + +OFLOAT: MFLOAT O + JRST (C) + +BFIX: MULI B,400 + TSC B,B + ASH C,(B)-243 + MOVE B,C + JRST (A) + + ;DISPATCH TABLES USED TO CONTROL THE FLOW OF THE VARIOUS PRIMITIVES + +TABLE2: NO ;TABLE2 (0) +TABLE3: YES ;TABLE2 (1) & TABLE3 (0) + NO ;TABLE2 (2) + YES + NO + +TABLE4: NO + NO + YES + YES + + + +FUNC: JSP A,BFIX + JSP A,BFLOAT + SUB B,VALN + IDIV B,VALN + ADD B,VALN + IMUL B,VALN + JSP C,SWITCH + JSP C,SWITCH + + + +FLFUNC==.-2 + FSBR B,O + FDVR B,O + FADR B,O + FMPR B,O + JSP C,FLSWCH + JSP C,FLSWCH + +DEFVAL==.-2 + 0 + 1 + 0 + 1 + 377777,,-1 + 400000,,1 + +DEFTYP==.-2 + TFIX,, + TFIX,, + TFIX,, + TFIX,, + TFLOAT,, + TFLOAT,, + ;PRIMITIVES FLOAT AND FIX + +MFUNCTION FIX,SUBR + + ENTRY 1 + + JSP C,FXFL + MOVE B,1(AB) + CAIE A,TFIX + JSP A,BFIX + MOVSI A,TFIX + JRST FINIS + +MFUNCTION FLOAT,SUBR + + ENTRY 1 + + JSP C,FXFL + MOVE B,1(AB) + CAIE A,TFLOAT + JSP A,BFLOAT + MOVSI A,TFLOAT + JRST FINIS + +CFIX: GETYP 0,A + CAIN 0,TFIX + POPJ P, + JSP A,BFIX + MOVSI A,TFIX + POPJ P, + +CFLOAT: GETYP 0,A + CAIN 0,TFLOAT + POPJ P, + JSP A,BFLOAT + MOVSI A,TFLOAT + POPJ P, + +FXFL: GETYP A,(AB) + CAIE A,TFIX + CAIN A,TFLOAT + JRST (C) + JRST WTYP1 + + +MFUNCTION ABS,SUBR + ENTRY 1 + GETYP A,TYP1 + CAIE A,TFIX + CAIN A,TFLOAT + JRST MOVIT + JRST WTYP1 +MOVIT: MOVM B,VAL1 ;GET ABSOLUTE VALUE OF ARGUMENT +AFINIS: HRLZS A ;MOVE TYPE CODE INTO LEFT HALF + JRST FINIS + + + +MFUNCTION MOD,SUBR + ENTRY 2 + GETYP A,TYP1 + CAIE A,TFIX ;FIRST ARG FIXED ? + JRST WTYP1 + GETYP A,TYP2 + CAIE A,TFIX ;SECOND ARG FIXED ? + JRST WTYP2 + MOVE A,VAL1 + IDIV A,VAL2 ;FORM QUOTIENT & REMAINDER + JUMPGE B,.+2 ;Only return positive remainders + ADD B,VAL2 + MOVSI A,TFIX + JRST FINIS + ;PRIMITIVES PLUS, DIFFERENCE, TIMES, DIVIDE, MIN, AND MAX + +MFUNCTION MIN,SUBR + + ENTRY + + MOVEI E,6 + JRST GOPT + +MFUNCTION MAX,SUBR + + ENTRY + + MOVEI E,7 + JRST GOPT + +MFUNCTION DIVIDE,SUBR,[/] + + ENTRY + + MOVEI E,3 + JRST GOPT + +MFUNCTION DIFFERENCE,SUBR,[-] + + ENTRY + + MOVEI E,2 + JRST GOPT + +MFUNCTION TIMES,SUBR,[*] + + ENTRY + + MOVEI E,5 + JRST GOPT + +MFUNCTION PLUS,SUBR,[+] + + ENTRY + + MOVEI E,4 + +GOPT: MOVE D,AB ;ARGUMENT POINTER + HLRE A,AB + MOVMS A + ASH A,-1 + PUSHJ P,CARITH + JRST FINIS + +; BUILD COMPILER ENTRIES TO THESE ROUTINES + +IRP NAME,,[CMINUS,CDIVID,CPLUS,CTIMES,CMIN,CMAX]CODE,,[2,3,4,5,6,7] + +NAME: MOVEI E,CODE + JRST CARIT1 +TERMIN + +CARIT1: MOVEI D,(A) + ASH D,1 ; TIMES 2 + SUBI D,1 + HRLI D,(D) + SUBM TP,D ; POINT TO ARGS + PUSH TP,$TTP + PUSH TP,D + PUSHJ P,CARITH + POP TP,TP + SUB TP,[1,,1] + POPJ P, + +CARITH: MOVE B,DEFVAL(E) ; GET VAL + JFCL OVRFLW,.+1 + MOVEI 0,TFIX ; FIX UNTIL CHANGE + JUMPN A,ARITH0 ; AT LEAST ONE ARG + MOVE A,DEFTYP(E) + POPJ P, + +ARITH0: SOJE A,ARITH1 ; FALL IN WITH ONE ARG + MOVE B,1(D) + GETYP C,(D) ; TYPE OF 1ST ARG + ADD D,[2,,2] ; GO TO NEXT + CAIN C,TFLOAT + JRST ARITH3 + CAIN C,TFIX + JRST ARITH1 + JRST WRONGT + +ARITH1: GETYP C,(D) ; GET NEXT TYPE + CAIE C,TFIX + JRST ARITH2 ; TO FLOAT LOOP + XCT FUNC(E) ; DO IT + ADD D,[2,,2] + SOJG A,ARITH1 ; KEEP ADDING OR WHATEVER + JFCL OVRFLW,OVRFLD + MOVSI A,TFIX + POPJ P, + +ARITH3: GETYP C,(D) + MOVE 0,1(D) ; GET ARG + CAIE C,TFIX + JRST ARITH4 + PUSH P,A + JSP C,OFLOAT ; FLOAT IT + POP P,A + JRST ARITH5 +ARITH4: CAIE C,TFLOAT + JRST WRONGT + JRST ARITH5 + +ARITH2: CAIE C,TFLOAT ; FLOATER? + JRST WRONGT + PUSH P,A + JSP A,BFLOAT + POP P,A + MOVE 0,1(D) + +ARITH5: XCT FLFUNC(E) + ADD D,[2,,2] + SOJG A,ARITH3 + + JFCL OVRFLW,OVRFLD + MOVSI A,TFLOAT + POPJ P, + +SWITCH: XCT COMPAR(E) ;FOR MAX & MIN TESTING + MOVE B,VALN + JRST (C) +COMPAR==.-6 + CAMLE B,VALN + CAMGE B,VALN + + + +FLSWCH: XCT FLCMPR(E) + MOVE B,O + JRST (C) +FLCMPR==.-6 + CAMLE B,O + CAMGE B,O + ;PRIMITIVES ONEP AND ZEROP + +MFUNCTION ONEP,SUBR,[1?] + MOVEI E,1 + JRST JOIN + +MFUNCTION ZEROP,SUBR,[0?] + MOVEI E, + +JOIN: ENTRY 1 + GETYP A,TYP1 + CAIN A,TFIX ;fixed ? + JRST TESTFX + CAIE A,TFLOAT ;floating ? + JRST WTYP1 + MOVE B,VAL1 + CAMN B,NUMBR(E) ;equal to correct value ? + JRST YES1 + JRST NO1 + +TESTFX: CAMN E,VAL1 ;equal to correct value ? + JRST YES1 + +NO1: MOVSI A,TFALSE + MOVEI B,0 + JRST FINIS + +YES1: MOVSI A,TATOM + MOVE B,MQUOTE T + JRST FINIS + +NUMBR: 0 ;FLOATING PT ZERO + 201400,,0 ;FLOATING PT ONE + ;PRIMITIVES LESSP AND GREATERP + +MFUNCTION LEQP,SUBR,[L=?] + MOVEI E,3 + JRST ARGS + +MFUNCTION GEQP,SUBR,[G=?] + MOVEI E,2 + JRST ARGS + + +MFUNCTION LESSP,SUBR,[L?] + MOVEI E,1 + JRST ARGS + +MFUNCTION GREATERP,SUBR,[G?] + MOVEI E,0 + +ARGS: ENTRY 2 + MOVE B,VAL1 + MOVE A,TYP1 + GETYP 0,A + PUSHJ P,CMPTYP + JRST WTYP1 + MOVE D,VAL2 + MOVE C,TYP2 + GETYP 0,C + PUSHJ P,CMPTYP + JRST WTYP2 + PUSHJ P,ACOMPS + JFCL + JRST FINIS + +; COMPILERS ENTRIES TO THESE GUYS + +IRP NAME,,[CGQ,CLQ,CGEQ,CLEQ]COD,,[0,1,2,3] + +NAME: MOVEI E,COD + JRST ACOMPS +TERMIN + +ACOMPS: GETYP A,A + GETYP 0,C + CAIE 0,(A) + JRST COMPD ; COMPARING FIX AND FLOAT +TEST: CAMN B,D + JRST @TABLE4(E) + CAMG B,D + JRST @TABLE2(E) + JRST @TABLE3(E) + +CMPTYP: CAIE 0,TFIX + CAIN 0,TFLOAT + AOS (P) + POPJ P, +COMPD: EXCH B,D + CAIN A,TFLOAT + JSP A,BFLOAT + EXCH B,D + CAIN 0,TFLOAT + JSP A,BFLOAT +COMPF: JRST TEST + +MFUNCTION RANDOM,SUBR + ENTRY + HLRE A,AB + CAMGE A,[-4] ;At most two arguments to random to set seeds + JRST TMA + JRST RANDGO(A) + MOVE B,VAL2 ;Set second seed + MOVEM B,RLOW + MOVE A,VAL1 ;Set first seed + MOVEM A,RHI +RANDGO: PUSHJ P,CRAND + JRST FINIS + +CRAND: MOVE B,RLOW ;FREDKIN'S RANDOM NUMBER GENERATOR. + MOVE A,RHI + MOVEM A,RLOW + LSHC A,-43 + XORB B,RHI + MOVSI A,TFIX + POPJ P, + + MFUNCTION SQRT,SUBR + PUSHJ P,ARGCHK + JUMPL B,NSQRT + PUSHJ P,ISQRT + JRST FINIS + +ISQRT: MOVE A,B + ASH B,-1 + FSC B,100 +SQ2: MOVE C,B ;NEWTON'S METHOD, SPECINER'S HACK. + FDVRM A,B + FADRM C,B + FSC B,-1 + CAME C,B + JRST SQ2 + MOVSI A,TFLOAT + POPJ P, + +MFUNCTION COS,SUBR + PUSHJ P,ARGCHK + FADR B,[1.570796326] ;COS(X)=SIN (X+PI/2) + PUSHJ P,.SIN + MOVSI A,TFLOAT + JRST FINIS + +MFUNCTION SIN,SUBR + PUSHJ P,ARGCHK + PUSHJ P,.SIN + MOVSI A,TFLOAT + JRST FINIS + +.SIN: MOVM A,B + CAMG A,[.0001] + POPJ P, ;GOSPER'S RECURSIVE SIN. + FDVR B,[-3.0] ;SIN(X)=4*SIN(X/-3)**3-3*SIN(X/-3) + PUSHJ P,.SIN + FSC A,1 + FMPR A,A + FADR A,[-3.0] + FMPRB A,B + POPJ P, + +CSQRT: PUSHJ P,CARGCH + JUMPL B,NSQRT + JRST ISQRT + +CSIN: PUSHJ P,CARGCH +CSIN1: PUSHJ P,.SIN + MOVSI A,TFLOAT + POPJ P, + +CCOS: PUSHJ P,CARGCH + FADR B,[1.570796326] + JRST CSIN1 + MFUNCTION LOG,SUBR + PUSHJ P,ARGCHK ;LEAVES ARGUMENT IN B + PUSHJ P,ILOG + JRST FINIS + +CLOG: PUSHJ P,CARGCH + +ILOG: JUMPLE B,OUTRNG + LDB D,[331100,,B] ;GRAB EXPONENT + SUBI D,201 ;REMOVE BIAS + TLZ B,777000 ;SET EXPONENT + TLO B,201000 ; TO 1 + MOVE A,B + FSBR A,RT2 + FADR B,RT2 + FDVB A,B + FMPR B,B + MOVE C,[0.434259751] + FMPR C,B + FADR C,[0.576584342] + FMPR C,B + FADR C,[0.961800762] + FMPR C,B + FADR C,[2.88539007] + FMPR C,A + FADR C,[0.5] + MOVE B,D + FSC B,233 + FADR B,C + FMPR B,[0.693147180] ;LOG E OF 2 + MOVSI A,TFLOAT + POPJ P, + +RT2: 1.41421356 + MFUNCTION ATAN,SUBR + PUSHJ P,ARGCHK + PUSHJ P,IATAN + JRST FINIS + +CATAN: PUSHJ P,CARGCH + +IATAN: PUSH P,B + MOVM D,B + CAMG D,[0.4^-8] ;SMALL ENOUGH SO ATAN(X)=X? + JRST ATAN3 ;YES + CAML D,[7.0^7] ;LARGE ENOUGH SO THAT ATAN(X)=PI/2? + JRST ATAN1 ;YES + MOVN C,[1.0] + CAMLE D,[1.0] ;IS ABS(X)<1.0? + FDVM C,D ;NO,SCALE IT DOWN + MOVE B,D + FMPR B,B + MOVE C,[1.44863154] + FADR C,B + MOVE A,[-0.264768620] + FDVM A,C + FADR C,B + FADR C,[3.31633543] + MOVE A,[-7.10676005] + FDVM A,C + FADR C,B + FADR C,[6.76213924] + MOVE B,[3.70925626] + FDVR B,C + FADR B,[0.174655439] + FMPR B,D + JUMPG D,ATAN2 ;WAS ARG SCALED? + FADR B,PI2 ;YES, ATAN(X)=PI/2-ATAN(1/X) + JRST ATAN2 +ATAN1: MOVE B,PI2 +ATAN2: SKIPGE (P) ;WAS INPUT NEGATIVE? + MOVNS B ;YES,COMPLEMENT +ATAN3: MOVSI A,TFLOAT + SUB P,[1,,1] + POPJ P, + +PI2: 1.57079632 + MFUNCTION IEXP,SUBR,[EXP] + PUSHJ P,ARGCHK ;LEAVE FLOATING POINT ARG IN B + PUSHJ P,IIEXP + JRST FINIS + +CEXP: PUSHJ P,CARGCH + +IIEXP: PUSH P,B + MOVM A,B + SETZM B + FMPR A,[0.434294481] ;LOG BASE 10 OF E + MOVE D,[1.0] + CAMG A,D + JRST RATEX + MULI A,400 + ASHC B,-243(A) + CAILE B,43 + JRST OUTRNG + CAILE B,7 + JRST EXPR2 +EXPR1: FMPR D,FLOAP1(B) + LDB A,[103300,,C] + SKIPE A + TLO A,177000 + FADR A,A +RATEX: MOVEI B,7 + SETZM C +RATEY: FADR C,COEF2-1(B) + FMPR C,A + SOJN B,RATEY + FADR C,[1.0] + FMPR C,C + FMPR D,C + MOVE B,[1.0] + SKIPL (P) ;SKIP IF INPUT NEGATIVE + SKIPN B,D + FDVR B,D + MOVSI A,TFLOAT + SUB P,[1,,1] + POPJ P, + +EXPR2: LDB E,[030300,,B] + ANDI B,7 + MOVE D,FLOAP1(E) + FMPR D,D ;TO THE 8TH POWER + FMPR D,D + FMPR D,D + JRST EXPR1 + +COEF2: 1.15129278 + 0.662730884 + 0.254393575 + 0.0729517367 + 0.0174211199 + 2.55491796^-3 + 9.3264267^-4 + +FLOAP1: 1.0 + 10.0 + 100.0 + 1000.0 + 10000.0 + 100000.0 + 1000000.0 + 10000000.0 + ;BITWISE BOOLEAN FUNCTIONS + +MFUNCTION %ANDB,SUBR,ANDB + ENTRY + HRREI B,-1 ;START ANDING WITH ALL ONES + MOVE D,[AND B,A] ;LOGICAL INSTRUCTION + JRST LOGFUN ;DO THE OPERATION + +MFUNCTION %ORB,SUBR,ORB + ENTRY + MOVEI B,0 + MOVE D,[IOR B,A] + JRST LOGFUN + +MFUNCTION %XORB,SUBR,XORB + ENTRY + MOVEI B,0 + MOVE D,[XOR B,A] + JRST LOGFUN + +MFUNCTION %EQVB,SUBR,EQVB + ENTRY + HRREI B,-1 + MOVE D,[EQV B,A] + +LOGFUN: JUMPGE AB,ZROARG +LOGTYP: GETYP A,(AB) ;GRAB THE TYPE + PUSHJ P,SAT ;STORAGE ALLOCATION TYPE + CAIE A,S1WORD + JRST WRONGT ;WRONG TYPE...LOSE + MOVE A,1(AB) ;LOAD ARG INTO A + XCT D ;DO THE LOGICAL OPERATION + AOBJP AB,.+2 ;ADD ONE TO BOTH HALVES + AOBJN AB,LOGTYP ;ADD AGAIN AND LOOP IF NEEDED + +ZROARG: MOVE A,$TWORD + JRST FINIS + REPEAT 0,[ +;routine to sort lists or vectors of either fixed point or floating numbers +;the components are interchanged repeatedly to acheive the sort +;first arg: the structure to be sorted +;if no second arg sort in descending order +;second arg: if false then sort in ascending order +; else sort in descending order + +MFUNCTION SORT,SUBR + ENTRY + HLRZ A,AB + CAIGE A,-4 ;Only two arguments allowed + JRST TMA + MOVE O,DESCEND ;Set up "O" to test for descending order as default condition + CAIE A,-4 ;Optional second argument? + JRST .+4 + GETYP B,TYP2 ;See if it is other than false + CAIN B,TFALSE + MOVE O,ASCEND ;Set up "O" to test for ascending order + GETYP A,TYP1 ;CHECK TYPE OF FIRST ARGUMENT + CAIN A,TLIST + JRST LSORT + CAIN A,TVEC + JRST VSORT + JRST WTYP1 + + + + +GOBACK: MOVE A,TYP1 ;RETURN THE SORTED ARGUMENT AS VALUE + MOVE B,VAL1 + JRST FINIS + +DESCEND: CAMG C,(A)+1 +ASCEND: CAML C,(A)+1 + ;ROUTINE TO SORT LISTS IN NUMERICAL ORDER + +LSORT: MOVE A,VAL1 + JUMPE A,GOBACK ;EMPTY LIST? + HLRZ B,(A) ;TYPE OF FIRST COMPONENT + CAIE B,TFIX + CAIN B,TFLOAT + SKIPA + JRST WRONGT + MOVEI E,0 ;FOR COUNT OF LENGTH OF LIST +LCOUNT: JUMPE A,LLSORT ;REACHED END OF LIST? + MOVE A,(A) ;NEXT COMPONENT + TLZ A,(B) ;SAME TYPE AS FIRST COMPONENT? + TLNE A,-1 + JRST WRONGT + AOJA E,LCOUNT ;INCREMENT COUNT AND CONTINUE + +LLSORT: SOJE E,GOBACK ;FINISHED WITH SORTING? + HRRZ A,VAL1 ;START THIS LOOP OF SORTING AT THE BEGINNING + MOVEM E,(P)+1 ;Save the iteration depth +CLSORT: HRRZ B,(A) ;NEXT COMPONENT + MOVE C,(B)+1 ;ITS VALUE + XCT O ;ARE THESE TWO COMPONENTS IN ORDER? + JRST .+4 + MOVE D,(A)+1 ;INTERCHANGE THEM + MOVEM D,(B)+1 + MOVEM C,(A)+1 + MOVE A,B ;MAKE THE COMPONENT IN "B" THE CURRENT ONE + SOJG E,CLSORT + MOVE E,(P)+1 ;Restore the iteration depth + JRST LLSORT + ;ROUTINE TO SORT VECTORS IN NUMERICAL ORDER + +VSORT: HLRE D,VAL1 ;GET COUNT FIELD OF VECTOR + IDIV D,[-2] ;LENGTH + JUMPE D,GOBACK ;EMPTY VECTOR? + MOVE E,D ;SAVE LENGTH IN "E" + HRRZ A,VAL1 ;POINTER TO VECTOR + MOVE B,(A) ;TYPE OF FIRST COMPONENT + CAME B,$TFIX + CAMN B,$TFLOAT + SKIPA + JRST WRONGT + SOJLE D,GOBACK ;IF ONLY ONE COMPONENT THEN FINISHED +VCOUNT: ADDI A,2 ;CHECK NEXT COMPONENT + CAME B,(A) ;SAME TYPE AS FIRST COMPONENT? + JRST WRONGT + SOJG D,VCOUNT ;CONTINUE WITH NEXT COMPONENT + +VVSORT: SOJE E,GOBACK ;FINISHED SORTING? + HRRZ A,VAL1 ;START THIS LOOP OF SORTING AT THE BEGINNING + MOVEM E,(P)+1 ;Save the iteration depth +CVSORT: MOVE C,(A)+3 ;VALUE OF NEXT COMPONENT + XCT O ;ARE THESE TWO COMPONENTS IN ORDER? + JRST .+4 + MOVE D,(A)+1 ;INTERCHANGE THEM + MOVEM D,(A)+3 + MOVEM C,(A)+1 + ADDI A,2 ;UPDATE THE CURRENT COMPONENT + SOJG E,CVSORT + MOVE E,(P)+1 ;Restore the iteration depth + JRST VVSORT +] + +MFUNCTION TIME,SUBR + ENTRY + PUSHJ P,CTIME + JRST FINIS + +IMPURE + +RHI: 267762113337 +RLOW: 155256071112 +PURE + + +END + \ No newline at end of file diff --git a/sumex/atomhk.mcr098 b/sumex/atomhk.mcr098 new file mode 100644 index 0000000..9295fae --- /dev/null +++ b/sumex/atomhk.mcr098 @@ -0,0 +1,919 @@ +TITLE ATOMHACKER FOR MUDDLE + +RELOCATABLE + +.INSRT MUDDLE > +.GLOBAL RLOOKU,CHMAK,OBLNT,ROOT,INTOBL,ERROBL,IFALSE +.GLOBAL .BLOCK,IDVAL,NXTDCL,CHRWRD,CSTACK,CSTAK,ILOOKC,IGVAL,BYTDOP +.GLOBAL ICONS,INCONS,IBLOCK,INSRTX,GCHACK,IMPURIFY +.GLOBAL CINSER,CIRMV,CLOOKU,CATOM,CIPNAM,MPOPJ,CSETG + +.VECT.==40000 ; BIT FOR GCHACK + +; FUNCTION TO GENERATE AN EMPTY OBLIST + +MFUNCTION MOBLIST,SUBR + + ENTRY + CAMGE AB,[-5,,0] ;CHECK NUMBER OF ARGS + JRST TMA + JUMPGE AB,MOBL2 ; NO ARGS + PUSH TP,(AB) + PUSH TP,1(AB) + PUSH TP,$TATOM + PUSH TP,IMQUOTE OBLIST + MCALL 2,GET ; CHECK IF IT EXISTS ALREADY + CAMN A,$TOBLS + JRST FINIS +MOBL2: MOVE A,OBLNT ;GET DEFAULT LENGTH + CAML AB,[-3,,0] ;IS LENGTH SUPPLIED + JRST MOBL1 ;NO, USE STANDARD LENGTH + GETYP C,2(AB) ;GET ARG TYPE + CAIE C,TFIX + JRST WTYP2 ;LOSE + MOVE A,3(AB) ;GET LENGTH +MOBL1: PUSH TP,$TFIX + PUSH TP,A + MCALL 1,UVECTOR ;GET A UNIFORM VECTOR + MOVSI C,TLIST+.VECT. ;IT IS OF TYPE LIST + HLRE D,B ;-LENGTH TO D + SUBM B,D ;D POINTS TO DOPE WORD + MOVEM C,(D) ;CLOBBER TYPE IN + MOVSI A,TOBLS + JUMPGE AB,FINIS ; IF NO ARGS, DONE + GETYP A,(AB) + CAIE A,TATOM + JRST WTYP1 + PUSH TP,$TOBLS + PUSH TP,B + PUSH TP,$TOBLS + PUSH TP,B + PUSH TP,$TATOM + PUSH TP,IMQUOTE OBLIST + PUSH TP,(AB) + PUSH TP,1(AB) + MCALL 3,PUT ; PUT THE NAME ON THE OBLIST + PUSH TP,(AB) + PUSH TP,1(AB) + PUSH TP,$TATOM + PUSH TP,IMQUOTE OBLIST + PUSH TP,(TB) + PUSH TP,1(TB) + MCALL 3,PUT ; PUT THE OBLIST ON THE NAME + + POP TP,B + POP TP,A + JRST FINIS + +MFUNCTION GROOT,SUBR,ROOT + ENTRY 0 + MOVE A,ROOT(TVP) + MOVE B,ROOT+1(TVP) + JRST FINIS + +MFUNCTION GINTS,SUBR,INTERRUPTS + ENTRY 0 + MOVE A,INTOBL(TVP) + MOVE B,INTOBL+1(TVP) + JRST FINIS + +MFUNCTION GERRS,SUBR,ERRORS + ENTRY 0 + MOVE A,ERROBL(TVP) + MOVE B,ERROBL+1(TVP) + JRST FINIS + + +COBLQ: SKIPN B,2(B) ; SKIP IF EXISTS + JRST IFLS + MOVSI A,TOBLS + JUMPL B,CPOPJ1 + ADDI B,(TVP) + MOVE B,(B) +CPOPJ1: AOS (P) + POPJ P, + +IFLS: MOVEI B,0 + MOVSI A,TFALSE + POPJ P, + +MFUNCTION OBLQ,SUBR,[OBLIST?] + + ENTRY 1 + GETYP A,(AB) + CAIE A,TATOM + JRST WTYP1 + MOVE B,1(AB) ; GET ATOM + PUSHJ P,COBLQ + JFCL + JRST FINIS + + ; FUNCTION TO FIND AN ATOM ON A GIVEN OBLIST WITH A GIVEN PNAME + +MFUNCTION LOOKUP,SUBR + + ENTRY 2 + PUSHJ P,ILOOKU ;CALL INTERNAL ROUTINE + JRST FINIS + +CLOOKU: SUBM M,(P) + PUSH TP,A + PUSH TP,B + MOVEI B,-1(TP) + PUSH TP,$TOBLS + PUSH TP,C + GETYP A,A + PUSHJ P,CSTAK + MOVE B,(TP) + PUSHJ P,ILOOK + POP P,D + HRLI D,(D) + SUB P,D + SKIPE B + SOS (P) + SUB TP,[4,,4] + JRST MPOPJ + +ILOOKU: PUSHJ P,ARGCHK ;CHECK ARGS + PUSHJ P,CSTACK ;PUT CHARACTERS ON THE STACK + +CALLIT: MOVE B,3(AB) ;GET OBLIST +ILOOKC: PUSHJ P,ILOOK ;LOOK IT UP + POP P,D ;RESTORE COUNT + HRLI D,(D) ;TO BOTH SIDES + SUB P,D + POPJ P, + +;THIS ROUTINE CHECKS ARG TYPES + +ARGCHK: GETYP A,(AB) ;GET TYPES + GETYP C,2(AB) + CAIE A,TCHRS ;IS IT EITHER CHAR STRING + CAIN A,TCHSTR + CAIE C,TOBLS ;IS 2ND AN OBLIST + JRST WRONGT ;TYPES ARE WRONG + POPJ P, + +;THIS SUBROUTINE PUTS CHARACTERS ON THE STACK (P WILL BE CHANGED) + + +CSTACK: MOVEI B,(AB) +CSTAK: POP P,D ;RETURN ADDRESS TO D + CAIE A,TCHRS ;IMMEDIATE? + JRST NOTIMM ;NO, HAIR + MOVE A,1(B) ; GET CHAR + LSH A,29. ; POSITION + PUSH P,A ;ONTO P + PUSH P,[1] ;WITH NUMBER + JRST (D) ;GO CALL SEARCHER + +NOTIMM: MOVEI A,1 ; CLEAR CHAR COUNT + HRRZ C,(B) ; GET COUNT OF CHARS + JUMPE C,NULST ; FLUSH NULL STRING + MOVE B,1(B) ;GET BYTE POINTER + +CLOOP1: PUSH P,[0] ; STORE CHARS ON STACK + MOVSI E,(<440700,,(P)>) ; SETUP BYTE POINTER +CLOOP: ILDB 0,B ;GET A CHARACTER + IDPB 0,E ;STORE IT + SOJE C,CDONE ; ANY MORE? + TLNE E,760000 ; WORD FULL + JRST CLOOP ;NO CONTINUE + AOJA A,CLOOP1 ;AND CONTINUE + +CDONE: +CDONE1: PUSH P,A ;AND NUMBER OF WORDS + JRST (D) ;RETURN + + +NULST: PUSH TP,$TATOM + PUSH TP,EQUOTE NULL-STRING + JRST CALER1 + ; THIS FUNCTION LOOKS FOR ATOMS. CALLED BY PUSHJ P,ILOOK +; B/ OBLIST POINTER +; -1(P)/ LENGTH IN WORDS OF CHARACTER BLOCK +; CHAR STRING IS ON THE STACK + +ILOOK: MOVN A,-1(P) ;GET -LENGTH + HRLI A,-1(A) ;<-LENGTH-1>,,-LENGTH + PUSH TP,$TFIX ;SAVE + PUSH TP,A + ADDI A,-1(P) ;HAVE AOBJN POINTER TO CHARS + MOVEI D,0 ;HASH WORD + XOR D,(A) + AOBJN A,.-1 ;XOR THEM ALL TOGETHER + HLRE A,B ;GET LENGTH OF OBLIST + MOVNS A + TLZ D,400000 ; MAKE SURE + HASH CODE + IDIVI D,(A) ;DIVIDE + HRLI E,(E) ;TO BOTH HALVES + ADD B,E ;POINT TO BUCKET + + MOVEI 0,(B) ;IN CASE REMOVING 1ST + SKIPN C,(B) ;BUCKET EMPTY? + JRST NOTFND ;YES, GIVE UP +LOOK2: SKIPN A,1(C) ;NIL CAR ON LIST? + JRST NEXT ;YES TRY NEXT + ADD A,[3,,3] ;POINT TO ATOMS PNAME + MOVE D,(TP) ;GET PSEUDO AOBJN POINTER TO CHARS + ADDI D,-1(P) ;NOW ITS A REAL AOBJN POINTER + JUMPE D,CHECK0 ;ONE IS EMPTY +LOOK1: MOVE E,(D) ;GET A WORD + CAME E,(A) ;COMPARE + JRST NEXT ;THIS ONE DOESN'T MATCH + AOBJP D,CHECK ;ONE RAN OUT + AOBJN A,LOOK1 ;JUMP IF STILL MIGHT WIN + +NEXT: MOVEI 0,(C) ;POINT TO PREVIOUS ELEMENT + HRRZ C,(C) ;STEP THROUGH + JUMPN C,LOOK2 + +NOTFND: EXCH C,B ;RETURN BUCKET IN B + MOVSI A,TFALSE +CPOPJT: SUB TP,[2,,2] ;REMOVE RANDOM TP STUFF + POPJ P, + +CHECK0: JUMPN A,NEXT ;JUMP IF NOT ALSO EMPTY + SKIPA +CHECK: AOBJN A,NEXT ;JUMP IF NO MATCH + HLLZ A,(C) + MOVE E,B ; RETURN BUCKET + MOVE B,1(C) ;GET ATOM + JRST CPOPJT + + + ; FUNCTION TO INSERT AN ATOM ON AN OBLIST + +MFUNCTION INSERT,SUBR + + ENTRY 2 + GETYP A,2(AB) + CAIE A,TOBLS + JRST WTYP2 + MOVE A,(AB) + MOVE B,1(AB) + MOVE C,3(AB) + PUSHJ P,IINSRT + JRST FINIS + +CINSER: SUBM M,(P) + PUSHJ P,IINSRT + JRST MPOPJ + +IINSRT: PUSH TP,A + PUSH TP,B + PUSH TP,$TOBLS + PUSH TP,C + GETYP A,A + CAIN A,TATOM + JRST INSRT0 + +;INSERT WITH A GIVEN PNAME + + CAIE A,TCHRS + CAIN A,TCHSTR + JRST .+2 + JRST WTYP1 + + PUSH TP,$TFIX ;FLAG CALL + PUSH TP,[0] + MOVEI B,-5(TP) + PUSHJ P,CSTAK ;COPY ONTO STACK + MOVE B,-2(TP) + PUSHJ P,ILOOK ;LOOK IT UP (BUCKET RETURNS IN C) + JUMPN B,ALRDY ;EXISTS, LOSE + MOVE D,-2(TP) ; GET OBLIST BACK +INSRT1: PUSH TP,$TOBLS ;SAVE BUCKET POINTER + PUSH TP,C + PUSH TP,$TOBLS + PUSH TP,D ; SAVE OBLIST +INSRT3: PUSHJ P,IATOM ; MAKE AN ATOM + PUSHJ P,LINKCK ; A LINK REALLY NEEDED ? + MOVE E,-2(TP) + HRRZ E,(E) ; GET BUCKET + PUSHJ P,ICONS + MOVE C,-2(TP) ;BUCKET AGAIN + HRRM B,(C) ;INTO NEW BUCKET + MOVSI A,TATOM + MOVE B,1(B) ;GET ATOM BACK + MOVE D,(TP) ; GET OBLIST + MOVEM D,2(B) ; AND CLOBBER + MOVE C,-4(TP) ;GET FLAG + SUB TP,[6,,6] ;POP STACK + JUMPN C,(C) + SUB TP,[4,,4] + POPJ P, + +;INSERT WITH GIVEN ATOM +INSRT0: MOVE A,-2(TP) ;GOBBLE PNAME + SKIPE 2(A) ; SKIP IF NOT ON AN OBLIST + JRST ONOBL + ADD A,[3,,3] + HLRE C,A + MOVNS C + PUSH P,(A) ;FLUSH PNAME ONTO P STACK + AOBJN A,.-1 + PUSH P,C + MOVE B,(TP) ; GET OBLIST FOR LOOKUP + PUSHJ P,ILOOK ;ALREADY THERE? + JUMPN B,ALRDY + PUSH TP,$TOBLS ;SAVE NECESSARY STUFF AWAY FROM CONS + PUSH TP,C ;WHICH WILL MAKE A LIST FROM THE ATOM + MOVSI C,TATOM + MOVE D,-4(TP) + PUSHJ P,INCONS + MOVE C,(TP) ;RESTORE + HRRZ D,(C) + HRRM B,(C) + HRRM D,(B) + MOVE C,-2(TP) + MOVE B,-4(TP) ; GET BACK ATOM + MOVEM C,2(B) ; CLOBBER OBLIST IN + MOVSI A,TATOM + SUB TP,[6,,6] + POP P,C + HRLI C,(C) + SUB P,C + POPJ P, + +LINKCK: HRRZ C,FSAV(TB) ;CALLER'S NAME + CAIN C,LINK + SKIPA C,$TLINK ;LET US INSERT A LINK INSTEAD OF AN ATOM + MOVSI C,TATOM ;GET REAL ATOM FOR CALL TO ICONS + MOVE D,B + POPJ P, + + + +ALRDY: PUSH TP,$TATOM + PUSH TP,EQUOTE ATOM-ALREADY-THERE + JRST CALER1 + +ONOBL: PUSH TP,$TATOM + PUSH TP,EQUOTE ON-AN-OBLIST-ALREADY + JRST CALER1 + +; INTERNAL INSERT CALL + +INSRTX: POP P,0 ; GET RET ADDR + PUSH TP,$TFIX + PUSH TP,0 + PUSH TP,$TOBLS + PUSH TP,B + PUSH TP,$TOBLS + PUSH TP,B + PUSHJ P,ILOOK + JUMPN B,INSRXT + MOVEM C,-2(TP) + JRST INSRT3 ; INTO INSERT CODE + +INSRXT: PUSH P,-4(TP) + SUB TP,[6,,6] + POPJ P, + JRST IATM1 + +; FUNCTION TO REMOVE AN ATOM FROM AN OBLIST + +MFUNCTION REMOVE,SUBR + + ENTRY + + JUMPGE AB,TFA + CAMGE AB,[-5,,] + JRST TMA + MOVEI C,0 + CAML AB,[-3,,] ; SKIP IF OBLIST GIVEN + JRST .+5 + GETYP 0,2(AB) + CAIE 0,TOBLS + JRST WTYP2 + MOVE C,3(AB) + MOVE A,(AB) + MOVE B,1(AB) + PUSHJ P,IRMV + JRST FINIS + +CIRMV: SUBM M,(P) + PUSHJ P,IRMV + JRST MPOPJ + +IRMV: PUSH TP,A + PUSH TP,B + PUSH TP,$TOBLS + PUSH TP,C +IRMV1: GETYP 0,A ; CHECK 1ST ARG + CAIN 0,TLINK + JRST .+3 + CAIE 0,TATOM ; ATOM, TREAT ACCORDINGLY + JRST RMV1 + + SKIPN D,2(B) ; SKIP IF ON OBLIST AND GET SAME + JRST IFALSE + JUMPL D,.+3 + ADDI D,(TVP) + MOVE D,(D) + JUMPE C,GOTOBL + CAME C,D ; BETTER BE THE SAME + JRST ONOTH + +GOTOBL: ADD B,[3,,3] ; POINT TO PNAME + HLRE A,B + MOVNS A + PUSH P,(B) ; PUSH PNAME + AOBJN B,.-1 + PUSH P,A + MOVEM D,(TP) ; SAVE OBLIST + JRST RMV3 + +RMV1: JUMPE C,TFA + CAIE 0,TCHRS + CAIN 0,TCHSTR + SKIPA A,0 + JRST WTYP1 + MOVEI B,-3(TP) + PUSHJ P,CSTAK +RMV3: MOVE B,(TP) + PUSHJ P,ILOOK + POP P,D + HRLI D,(D) + SUB P,D + JUMPE B,RMVDON + HRRZ D,0 ;PREPARE TO SPLICE (0 POINTS PRIOR TO LOSING PAIR) + HRRZ C,(C) ;GET NEXT OF LOSING PAIR + MOVEI 0,(B) + CAIGE 0,HIBOT ; SKIP IF PURE + JRST RMV2 + PUSHJ P,IMPURIFY + MOVE A,-3(TP) + MOVE B,-2(TP) + MOVE C,(TP) + JRST IRMV1 +RMV2: HRRM C,(D) ;AND SPLICE + SETZM 2(B) ; CLOBBER OBLIST SLOT +RMVDON: SUB TP,[4,,4] + POPJ P, + + +;INTERNAL CALL FROM THE READER + +RLOOKU: PUSH TP,$TFIX ;PUSH A FLAG + POP P,C ;POP OFF RET ADR + PUSH TP,C ;AND USE AS A FLAG FOR INTERNAL + MOVE C,(P) ; CHANGE CHAR COUNT TO WORD + ADDI C,4 + IDIVI C,5 + MOVEM C,(P) + + CAMN A,$TOBLS ;IS IT ONE OBLIST? + JRST RLOOK1 + CAME A,$TLIST ;IS IT A LIST + JRST BADOBL + + JUMPE B,BADLST + PUSH TP,$TOBLS ; SLOT FOR REMEBERIG + PUSH TP,[0] + PUSH TP,$TOBLS + PUSH TP,[0] + PUSH TP,A + PUSH TP,B + +RLOOK2: GETYP A,(B) ;CHECK THIS IS AN OBLIST + MOVE B,1(B) ;VALUE + CAIE A,TOBLS + JRST DEFALT + PUSHJ P,ILOOK ;LOOK IT UP + JUMPN B,RLOOK3 ;WIN + SKIPE -2(TP) ; SKIP IF DEFAULT NOT STORED + JRST RLOOK4 + HRRZ D,(TP) ; GET CURRENT + MOVE D,1(D) ; OBLIST + MOVEM D,-2(TP) + MOVEM C,-4(TP) ; FOR INSERT IF NEEDED +RLOOK4: INTGO + HRRZ B,@(TP) ;CDR THE LIST + HRRZM B,(TP) + JUMPN B,RLOOK2 + SKIPN D,-2(TP) ; RESTORE FOR INSERT + JRST BADDEF ; NO DEFAULT, USER LOST ON SPECIFICATION + MOVE C,-4(TP) + SUB TP,[6,,6] ; FLUSH CRAP + JRST INSRT1 + +DEFFLG==1 ;SPECIAL FLAG USED TO INDICATE THAT A DEFAULT HAS ALREADY BEEN SPECIFIED +DEFALT: CAIN A,TATOM ;SPECIAL DEFAULT INDICATING ATOM ? + CAME B,MQUOTE DEFAULT + JRST BADDEF ;NO, LOSE + MOVSI A,DEFFLG + XORB A,-6(TP) ;SET AND TEST FLAG + TLNN A,DEFFLG ; HAVE WE BEEN HERE BEFORE ? + JRST BADDEF ; YES, LOSE + SETZM -2(TP) ;ZERO OUT PREVIOUS DEFAULT + SETZM -4(TP) + JRST RLOOK4 ;CONTINUE + +RLOOK1: PUSH TP,$TOBLS + PUSH TP,B ; SAVE OBLIST + PUSHJ P,ILOOK ;LOOK IT UP THERE + MOVE D,(TP) ; GET OBLIST + SUB TP,[2,,2] + JUMPE B,INSRT1 ;GO INSET IT + + +INSRT2: JRST .+2 ; +RLOOK3: SUB TP,[6,,6] ;POP OFF LOSSAGE + PUSHJ P,ILINK ;IF THIS IS A LINK FOLLOW IT + PUSH P,(TP) ;GET BACK RET ADR + SUB TP,[2,,2] ;POP TP + JRST IATM1 ;AND RETURN + + +BADOBL: PUSH TP,$TATOM + PUSH TP,EQUOTE BAD-OBLIST-OR-LIST-THEREOF + JRST CALER1 + +BADDEF: PUSH TP,$TATOM + PUSH TP,EQUOTE BAD-DEFAULT-OBLIST-SPECIFICATION + JRST CALER1 + +ONOTH: PUSH TP,$TATOM + PUSH TP,EQUOTE ATOM-ON-DIFFERENT-OBLIST + JRST CALER1 + ;SUBROUTINE TO MAKE AN ATOM + +MFUNCTION ATOM,SUBR + + ENTRY 1 + + MOVE A,(AB) + MOVE B,1(AB) + PUSHJ P,IATOMI + JRST FINIS + +CATOM: SUBM M,(P) + PUSHJ P,IATOMI + JRST MPOPJ + +IATOMI: GETYP 0,A ;CHECK ARG TYPE + CAIE 0,TCHRS + CAIN 0,TCHSTR + JRST .+2 ;JUMP IF WINNERS + JRST WTYP1 + + PUSH TP,A + PUSH TP,B + MOVEI B,-1(TP) + MOVE A,0 + PUSHJ P,CSTAK ;COPY ONTO STACK + PUSHJ P,IATOM ;NOW MAKE THE ATOM + POPJ P, + +;INTERNAL ATOM MAKER + +IATOM: MOVE A,-1(P) ;GET WORDS IN PNAME + ADDI A,3 ;FOR VALUE CELL + PUSHJ P,IBLOCK ; GET BLOCK + MOVSI C,<(GENERAL)>+SATOM+.VECT. ;FOR TYPE FIELD + MOVE D,-1(P) ;RE-GOBBLE LENGTH + ADDI D,3(B) ;POINT TO DOPE WORD + MOVEM C,(D) + SKIPG -1(P) ;EMPTY PNAME ? + JRST IATM0 ;YES, NO CHARACTERS TO MOVE + MOVE E,B ;COPY ATOM POINTER + ADD E,[3,,3] ;POINT TO PNAME AREA + MOVEI C,-1(P) + SUB C,-1(P) ;POINT TO STRING ON STACK + MOVE D,(C) ;GET SOME CHARS + MOVEM D,(E) ;AND COPY THEM + ADDI C,1 + AOBJN E,.-3 +IATM0: MOVSI A,TATOM ;TYPE TO ATOM +IATM1: POP P,D ;RETURN ADR + POP P,C + HRLI C,(C) + SUB P,C + JRST (D) ;RETURN + + ;SUBROUTINE TO GET AN ATOM'S PNAME + +MFUNCTION PNAME,SUBR + + ENTRY 1 + + GETYP A,(AB) + CAIE A,TATOM ;CHECK TYPE IS ATOM + JRST WTYP1 + MOVE A,1(AB) + PUSHJ P,IPNAME + JRST FINIS + +CIPNAM: SUBM M,(P) + PUSHJ P,IPNAME + JRST MPOPJ + +IPNAME: ADD A,[3,,3] + HLRE B,A + MOVM B,B + PUSH P,(A) ;FLUSH PNAME ONTO P + AOBJN A,.-1 + IMULI B,5 ; CHARS TO B + MOVE 0,(P) ; LAST WORD + MOVE A,0 + SUBI A,1 ; FIND LAST 1 + ANDCM 0,A ; 0 HAS 1ST 1 + JFFO 0,.+1 + HRREI 0,-34.(A) ; FIND HOW MUCH TO ADD + IDIVI 0,7 + ADD B,0 + PUSH P,B + PUSHJ P,CHMAK ;MAKE A STRING + POPJ P, + + ; BLOCK STRUCTURE SUBROUTINES FOR MUDDLE + +MFUNCTION BLK,SUBR,BLOCK + + ENTRY 1 + + GETYP A,(AB) ;CHECK TYPE OF ARG + CAIE A,TOBLS ;IS IT AN OBLIST + CAIN A,TLIST ;OR A LIAT + JRST .+2 + JRST WTYP1 + MOVSI A,TATOM ;LOOK UP OBLIST + MOVE B,IMQUOTE OBLIST + PUSHJ P,IDVAL ;GET VALUE + PUSH TP,A + PUSH TP,B + PUSH TP,.BLOCK(PVP) ;HACK THE LIST + PUSH TP,.BLOCK+1(PVP) + MCALL 2,CONS ;CONS THE LIST + MOVEM A,.BLOCK(PVP) ;STORE IT BACK + MOVEM B,.BLOCK+1(PVP) + PUSH TP,$TATOM + PUSH TP,IMQUOTE OBLIST + PUSH TP,(AB) + PUSH TP,1(AB) + MCALL 2,SET ;SET OBLIST TO ARG + JRST FINIS + +MFUNCTION ENDBLOCK,SUBR + + ENTRY 0 + + SKIPN B,.BLOCK+1(PVP) ;IS THE LIST NIL? + JRST BLKERR ;YES, LOSE + HRRZ C,(B) ;CDR THE LIST + HRRZM C,.BLOCK+1(PVP) + PUSH TP,$TATOM ;NOW RESET OBLIST + PUSH TP,IMQUOTE OBLIST + HLLZ A,(B) ;PUSH THE TYPE OF THE CAR + PUSH TP,A + PUSH TP,1(B) ;AND VALUE OF CAR + MCALL 2,SET + JRST FINIS + +BLKERR: PUSH TP,$TATOM + PUSH TP,EQUOTE UNMATCHED + JRST CALER1 + +BADLST: PUSH TP,$TATOM + PUSH TP,EQUOTE NIL-LIST-OF-OBLISTS + JRST CALER1 + ;SUBROUTINE TO CREATE CHARACTER STRING GOODIE + +CHMAK: MOVE A,-1(P) + ADDI A,4 + IDIVI A,5 + PUSHJ P,IBLOCK + MOVEI C,-1(P) ;FIND START OF CHARS + HLRE E,B ; - LENGTH + ADD C,E ;C POINTS TO START + MOVE D,B ;COPY VECTOR RESULT + JUMPGE D,NULLST ;JUMP IF EMPTY + MOVE A,(C) ;GET ONE + MOVEM A,(D) + ADDI C,1 ;BUMP POINTER + AOBJN D,.-3 ;COPY +NULLST: MOVSI C,TCHRS+.VECT. ;GET TYPE + MOVEM C,(D) ;CLOBBER IT IN + MOVE A,-1(P) ; # WORDS + HRLI A,TCHSTR + HRLI B,440700 + MOVMM E,-1(P) ; SO IATM1 WORKS + JRST IATM1 ;RETURN + +; SUBROUTINE TO READ FIVE CHARS FROM STRING. +; TWO CALLS, ONE WITH A POINTING TO LIST ELEMENT, +; THE OTHER WITH B POINTING TO PAIR. SKIPS IF WINNER, ELSE DOESNT + +NXTDCL: GETYP B,(A) ;CHECK TYPE + CAIE B,TDEFER ;LOSE IF NOT DEFERRED + POPJ P, + + MOVE B,1(A) ;GET REAL BYTE POINTER +CHRWRD: PUSH P,C + GETYP C,(B) ;CHECK IT IS CHSTR + CAIE C,TCHSTR + JRST CPOPJC ;NO, QUIT + PUSH P,D + PUSH P,E + PUSH P,0 + MOVEI E,0 ;INITIALIZE DESTINATION + HRRZ C,(B) ; GET CHAR COUNT + JUMPE C,GOTDCL ; NULL, FINISHED + MOVE B,1(B) ;GET BYTE POINTER + MOVE D,[440700,,E] ;BYTE POINT TO E +CHLOOP: ILDB 0,B ; GET A CHR + IDPB 0,D ;CLOBBER AWAY + SOJE C,GOTDCL ; JUMP IF DONE + TLNE D,760000 ; SKIP IF WORD FULL + JRST CHLOOP ; MORE THAN 5 CHARS + TRO E,1 ; TURN ON FLAG + +GOTDCL: MOVE B,E ;RESULT TO B + AOS -4(P) ;SKIP RETURN +CPOPJ0: POP P,0 + POP P,E + POP P,D +CPOPJC: POP P,C + POPJ P, + +; SUBROUTINE TO FIND A BYTE STRINGS DOPE WORD +; RECEIVES POINTER TO PAIR CONNTAINIGN CHSTR IN C, RETURNS DOPE WORD IN A + +BYTDOP: PUSH P,B ; SAVE SOME ACS + PUSH P,D + PUSH P,E + MOVE B,1(C) ; GET BYTE POINTER + LDB D,[360600,,B] ; POSITION TO D + LDB E,[300600,,B] ; AND BYTE SIZE + MOVEI A,(E) ; A COPY IN A + IDIVI D,(E) ; D=> # OF BYTES IN WORD 1 + HRRZ E,(C) ; GET LENGTH + SUBM E,D ; # OF BYTES IN OTHER WORDS + JUMPL D,BYTDO1 ; NEAR DOPE WORD + MOVEI B,36. ; COMPUTE BYTES PER WORD + IDIVM B,A + ADDI D,-1(A) ; NOW COMPUTE WORDS + IDIVI D,(A) ; D/ # NO. OF WORDS PAST 1ST + ADD D,1(C) ; D POINTS TO DOPE WORD + MOVEI A,2(D) + +BYTDO2: POP P,E + POP P,D + POP P,B + POPJ P, +BYTDO1: MOVEI A,1(B) + CAME D,[-5] + AOJA A,BYTDO2 + JRST BYTDO2 + ;ROUTINES TO DEFINE AND HANDLE LINKS + +MFUNCTION LINK,SUBR + ENTRY + CAML AB,[-6,,0] ;NO MORE THAN 3 ARGS + CAML AB,[-2,,0] ;NO LESS THAN 2 ARGS + JRST WNA + CAML AB,[-4,,0] ;ONLY TWO ARGS SUPPLIED ? + JRST GETOB ;YES, GET OBLIST FROM CURRENT PATH + MOVE A,2(AB) + MOVE B,3(AB) + MOVE C,5(AB) + JRST LINKIN +GETOB: MOVSI A,TATOM + MOVE B,IMQUOTE OBLIST + PUSHJ P,IDVAL + CAMN A,$TOBLS + JRST LINKP + CAME A,$TLIST + JRST BADOBL + JUMPE B,BADLST + GETYPF A,(B) + MOVE B,(B)+1 +LINKP: MOVE C,B + MOVE A,2(AB) + MOVE B,3(AB) +LINKIN: PUSHJ P,IINSRT + CAMN A,$TFALSE ;LINK NAME ALREADY USED ? + JRST ALRDY ;YES, LOSE + MOVE C,B + MOVE A,(AB) + MOVE B,1(AB) + PUSHJ P,CSETG + JRST FINIS + + +ILINK: CAME A,$TLINK ;FOUND A LINK ? + POPJ P, ;NO, FINISHED + MOVSI A,TATOM + PUSHJ P,IGVAL ;GET THE LINK'S DESTINATION + CAME A,$TUNBOUND ;WELL FORMED LINK ? + POPJ P, ;YES + PUSH TP,$TATOM + PUSH TP,EQUOTE BAD-LINK + JRST CALER1 + + +; THIS SUBROUTINE IMPURIFIES A PURE ATOM TO ALLOW MODIFICATION OF SYSTEM SUBRS + +IMPURIFY: + PUSH TP,$TATOM + PUSH TP,B + MOVE C,B + MOVEI 0,(C) + CAIGE 0,HIBOT + JRST RTNATM ; NOT PURE, RETURN + +; 1) IMPURIFY ITS OBLIST BUCKET + + SKIPN B,2(C) ; PICKUP OBLIST IF IT EXISTS + JRST IMPUR1 ; NOT ON ONE, IGNORE THIS CODE + + ADDI B,(TVP) ; POINT TO SLOT + MOVE B,(B) ; GET THE REAL THING + ADD C,[3,,3] ; POINT TO PNAME + HLRE A,C ; GET LNTH IN WORDS OF PNAME + MOVNS A + PUSH P,[IMPUR2] ; FAKE OUT ILOOKC + PUSH P,(C) ; PUSH UP THE PNAME + AOBJN C,.-1 + PUSH P,A ; NOW THE COUNT + JRST ILOOKC ; GO FIND BUCKET + +IMPUR2: JUMPE B,IMPUR1 ; NOT THERE, GO + PUSH TP,$TOBLS ; SAVE BUCKET + PUSH TP,E + + MOVE B,(E) ; GET NEXT ONE +IMPUR4: MOVEI 0,(B) + CAIGE 0,HIBOT ; SKIP IF PURE + JRST IMPUR3 ; FOUND IMPURE NESS, SKIP IT + HLLZ C,(B) ; SET UP ICONS CALL + HRRZ E,(B) + MOVE D,1(B) + PUSHJ P,ICONS ; CONS IT UP + HRRZ E,(TP) ; RETRV PREV + HRRM B,(E) ; AND CLOBBER +IMPUR3: MOVSI 0,TLIST + MOVEM 0,-1(TP) ; FIX TYPE + HRRZM B,(TP) ; STORE GOODIE + HRRZ B,(B) ; CDR IT + JUMPN B,IMPUR4 ; LOOP + SUB TP,[2,,2] ; FLUSH TP CRUFT + +; 2) GENERATE A DUPLICATE ATOM + +IMPUR1: HLRE A,(TP) ; GET LNTH OF ATOM + MOVNS A + PUSH P,A + PUSHJ P,IBLOCK ; GET NEW BLOCK FOR ATOM + PUSH TP,$TATOM + PUSH TP,B + HRL B,-2(TP) ; SETUP BLT + POP P,A + ADDI A,(B) ; END OF BLT + BLT B,(A) ; CLOBBER NEW ATOM + MOVSI B,.VECT. ; TURN ON BIT FOR GCHACK + IORM B,(A) + +; 3) NOW COPY GLOBAL VALUE + + MOVE B,(TP) ; ATOM BACK + GETYP 0,(B) + SKIPE A,1(B) ; NON-ZER POINTER? + CAIN 0,TUNBOU ; BOUND? + JRST IMPUR5 ; NO, DONT COPY GLOB VAL + PUSH TP,$TATOM + PUSH TP,B + PUSH TP,(A) + PUSH TP,1(A) + SETZM (B) + SETZM 1(B) + MCALL 2,SETG +IMPUR5: PUSH TP,$TFIX ;SAVE OLD ATOM WITH FUNNY TYPE TO AVOID LOSSAGE + PUSH TP,-3(TP) + +; 4) UPDATE ALL POINTERS TO THIS ATOM + + MOVE A,[PUSHJ P,ATFIX] ; INS TO PASS TO GCHACK + PUSHJ P,GCHACK + SUB TP,[4,,4] + +RTNATM: POP TP,B + POP TP,A + POPJ P, + +; ROUTINE PASSED TO GCHACK + +ATFIX: CAIE C,TGATOM ; GLOBAL TYPE ATOM + CAIN C,TATOM + CAME D,(TP) ; SKIP IF WINNER + POPJ P, + MOVE D,-2(TP) + SKIPE B + MOVEM D,1(B) + POPJ P, + + +END + diff --git a/sumex/create.mcr035 b/sumex/create.mcr035 new file mode 100644 index 0000000..6cda72e --- /dev/null +++ b/sumex/create.mcr035 @@ -0,0 +1,375 @@ +TITLE PROCESS-HACKER FOR MUDDLE + +RELOCATABLE + +.INSRT MUDDLE > + +.GLOBAL ICR,NAPT,IGVAL,CHKARG,RESFUN,RETPROC,SWAP,MAINPR,PROCHK,NOTRES +.GLOBAL PSTAT,LSTRES,TOPLEV,MAINPR,1STEPR,INCONS +.GLOBAL TBINIT,APLQ + +MFUNCTION PROCESS,SUBR + + ENTRY 1 + GETYP A,(AB) ;GET TYPE OF ARG + ;MUST BE SOME APPLIABLE TYPE + PUSHJ P,APLQ + JRST NAPT ;NO, ERROR - NON-APPLIABLE TYPE +OKFUN: + + PUSHJ P,ICR ;CREATE A NEW PROCESS + MOVE C,TPSTO+1(B) ;GET ITS SRTACK + PUSH C,[TENTRY,,TOPLEV] + PUSH C,[1,,0] ;TIME + PUSH C,[0] + PUSH C,SPSTO+1(B) + PUSH C,PSTO+1(B) + MOVE D,C + ADD D,[3,,3] + PUSH C,D ;SAVED STACK POINTER + PUSH C,[SUICID] + MOVEM C,TPSTO+1(B) ;STORE NEW TP + HRRI D,1(C) ;MAKE A TB + HRLI D,2 ;WITH A TIME + MOVEM D,TBINIT+1(B) + MOVEM D,TBSTO+1(B) ;SAVE ALSO FOR SIMULATED START + MOVE C,(AB) ;STORE ARG + MOVEM C,RESFUN(B) ;INTO PV + MOVE C,1(AB) + MOVEM C,RESFUN+1(B) + MOVEI 0,RUNABL + MOVEM 0,PSTAT+1(B) + JRST FINIS + +REPEAT 0,[ +MFUNCTION RETPROC,SUBR +; WHO KNOWS WHAT THIS SHOULD REALLY DO +;PROBABLY, JUST AN EXIT +;FOR NOW, PRINT OUT AN ERROR MESSAGE + PUSH TP,$TATOM + PUSH TP,EQUOTE ATTEMPT-TO-RETURN-OUT-OF-PROCESS + JRST CALER1 + + + + + + + +MFUNCTION RESUME,FSUBR +;RESUME IS CALLED WITH TWO ARGS +;THE FIRST IS A PROCESS FORM OF THE PROCESS TO BE RESUMED +;THE SECOND IS A FUNCTION TO BE CALLED WHEN THIS PROCESS +; (THE PARENT) IS ITSELF RESUMED +;IF THE FUNCTION IS NOT GIVEN SOME STANDARD FUNCTION IS +;PLUGGED IN +; +; NOTE - TYPE AND NUMBER OF ARGS CHECKS MUST BE ADDED TO BOTH RESUME AND CREATE + + ENTRY 1 + HRRZ C,@1(AB) ;GET CDR ADDRESS + JUMPE C,NOFUN ;IF NO SECOND ARG, SUPPLY STANDARD + HLLZ A,(C) ;GET CDR TYPE + CAME A,$TATOM ;ATOMIC? + JRST RES2 ;NO, MUST EVAL TO GET FUNCTION + MOVE B,1(C) ;YES + PUSHJ P,IGVAL ;TRY TO GET GLOBAL VALUE + CAMN A,$TUNBOUND ;GLOBALLY UNBOUND? + JRST LFUN ;YES, TRY FOR LOCAL VALUE +RES1: MOVEM A,RESFUN(PVP) ;STORE IN THIS PROCESS + MOVEM B,RESFUN+1(PVP) + + HRRZ C,1(AB) ;GET CAR ADDRESS + PUSH TP,(C) ;PUSH PROCESS FORM + PUSH TP,1(C) + JSP E,CHKARG ;CHECK FOR DEFERED TYPE + ;INSERT CHECKS FOR PROCESS FORM + MCALL 1,EVAL ;EVAL PROCESS FORM WHICH WILL SWITCH + ; PROCESSES + JRST FINIS + +RES2: PUSH TP,(C) ;PUSH FUNCTION ARG + PUSH TP,1(C) + JSP E,CHKARG ;CHECK FOR DEFERED + MCALL 1,EVAL ;EVAL TO GET FUNCTION + JRST RES1 + +LFUN: HRRZ C,1(AB) ;GET CDR ADDRESS + PUSH TP,(C) + PUSH TP,1(C) + MCALL 1,VALUE ;GET LOCAL VALUE OF ATOM FOR FUNCTION + JRST RES1 + +NOFUN: MOVSI A,TUNBOUND ;MAKE RESUME FUNCTION UNBOUND + JRST RES1 +] + +; PROCHK - SETUP LAST RESUMER SLOT + +PROCHK: CAME B,MAINPR ; MAIN PROCESS? + MOVEM PVP,LSTRES+1(B) + POPJ P, + +; THIS FUNCTION RESUMES A PROCESS, CALLED WITH ONE OR TWO ARGS +; THE FIRST IS A VALUE TO RETURN TO THE OTHER PROCESS OR PASS TO ITS +; RESFUN +; THE SECOND IS THE PROCESS TO RESUME (IF NOT SUPPLIED, USE THE LSTRES) + + +MFUNCTION RESUME,SUBR + + ENTRY + JUMPGE AB,TFA + CAMGE AB,[-4,,0] + JRST TMA + CAMGE AB,[-2,,0] + JRST CHPROC ; VALIDITY CHECK ON PROC + SKIPN B,LSTRES+1(PVP) ; ANY RESUMERS? + JRST NORES ; NO, COMPLAIN +GOTPRO: MOVE C,AB + CAMN B,PVP ; DO THEY DIFFER? + JRST RETARG + MOVE A,PSTAT+1(B) ; CHECK STATE + CAIE A,RUNABL ; MUST BE RUNABL + CAIN A,RESMBL ; OR RESUMABLE + JRST RESUM1 +NOTRES: +NOTRUN: PUSH TP,$TATOM + PUSH TP,EQUOTE PROCESS-NOT-RUNABLE-OR-RESUMABLE + JRST CALER1 + +RESUM1: PUSHJ P,PROCHK ; FIX LISTS UP + MOVEI A,RESMBL ; GET NEW STATE + MOVE D,B ; FOR SWAP +STRTN: JSP C,SWAP ; SWAP THEM + MOVEM A,PSTAT+1(E) ; CLOBBER OTHER STATE + MOVE A,PSTAT+1(PVP) ; DECIDE HOW TO PROCEED + MOVEI 0,RUNING + MOVEM 0,PSTAT+1(PVP) ; NEW STATE + MOVE C,ABSTO+1(E) ; OLD ARGS + CAIE A,RESMBL + JRST DORUN ; THEY DO RUN RUN, THEY DO RUN RUN +RETARG: MOVE A,(C) + MOVE B,1(C) ; RETURN + JRST FINIS + +DORUN: PUSH TP,RESFUN(PVP) + PUSH TP,RESFUN+1(PVP) + PUSH TP,(C) + PUSH TP,1(C) + MCALL 2,APPLY + PUSH TP,A ; CALL SUICIDE WITH THESE ARGS + PUSH TP,B + MCALL 1,SUICID ; IF IT RETURNS, KILL IT + JRST FINIS + +CHPROC: GETYP A,2(AB) + CAIE A,TPVP + JRST WTYP2 + MOVE B,3(AB) + JRST GOTPRO + +NORES: PUSH TP,$TATOM + PUSH TP,EQUOTE NO-PROCESS-TO-RESUME + JRST CALER1 + +; FUNCTION TO CAUSE PROCESSES TO SELF DESTRUCT + +MFUNCTION SUICIDE,SUBR + + ENTRY + + JUMPGE AB,TFA + HLRE A,AB + ASH A,-1 ; DIV BY 2 + AOJE A,NOPROC ; NO PROCESS GIVEN + AOJL A,TMA + GETYP A,2(AB) ; MAKE SURE OF PROCESS + CAIE A,TPVP + JRST WTYP2 + MOVE C,3(AB) + JRST SUIC2 + +NOPROC: SKIPN C,LSTRES+1(PVP) ; MAKE SURE OF EDLIST + MOVE C,MAINPR ; IF NOT DEFAULT TO MAIN +SUIC2: CAMN C,PVP ; DONT SUICIDE TO SELF + JRST SUSELF + MOVE B,PSTAT+1(C) + CAIE B,RUNABL + CAIN B,RESMBL + JRST .+2 + JRST NOTRUN + MOVE B,C + PUSHJ P,PROCHK + MOVE D,B ; RESTORE NEWPROCESS + MOVEI A,DEAD + JRST STRTN + +SUSELF: PUSH TP,$TATOM + PUSH TP,EQUOTE ATTEMPT-TO-SUICIDE-TO-SELF + JRST CALER1 + + +MFUNCTION RESER,SUBR,RESUMER + + ENTRY + MOVE B,PVP + JUMPGE AB,GTLAST + CAMGE AB,[-2,,0] + JRST TMA + + GETYP A,(AB) ; CHECK FOR PROCESS + CAIE A,TPVP + JRST WTYP1 + MOVE B,1(AB) ; GET PROCESS +GTLAST: MOVSI A,TFALSE ; ASSUME NONE + SKIPN B,LSTRES+1(B) ; GET IT IF IT EXISTS + JRST FINIS + MOVSI A,TPVP ; GET TYPE + JRST FINIS + +; FUNCTION TO PUT AN EVAL CALL ON ANOTHER PROCESSES STACK + +MFUNCTION BREAKSEQ,SUBR,BREAK-SEQ + + ENTRY 2 + + GETYP A,2(AB) ; 2D ARG MUST BE PROCESS + CAIE A,TPVP + JRST WTYP2 + + MOVE B,3(AB) ; GET PROCESS + CAMN B,PVP ; SKIP IF NOT ME + JRST BREAKM + MOVE A,PSTAT+1(B) ; CHECK STATE + CAIE A,RESMBL ; BEST BE RESUMEABLE + JRST NOTRUN + MOVE C,TBSTO+1(B) ; GET SAVE ACS TO BUILD UP A DUMMY FRAME + MOVE D,TPSTO+1(B) ; STACK POINTER + MOVE E,SPSTO+1(B) ; FIX UP OLD FRAME + MOVEM E,SPSAV(C) + MOVEI E,CALLEV ; FUNNY PC + MOVEM E,PCSAV(C) + MOVE E,PSTO+1(B) ; SET UP P,PP AND TP SAVES + MOVEM E,PSAV(C) + PUSH D,[0] ; ALLOCATES SOME SLOTS + PUSH D,[0] + PUSH D,(AB) ; NOW THAT WHIC IS TO BE EVALLED + PUSH D,1(AB) + MOVEM D,TPSAV(C) + HRRI E,-1(D) ; BUILD UP ARG POINTER + HRLI E,-2 + PUSH D,[TENTRY,,BREAKE] + PUSH D,C ; OLD TB + PUSH D,E ; NEW ARG POINTER +REPEAT 4,PUSH D,[0] ; OTHER SLOTS + MOVEM D,TPSTO+1(B) + MOVEI C,(D) ; BUILD NEW AB + AOBJN C,.+1 + MOVEM C,TBSTO+1(B) ; STORE IT + MOVE A,2(AB) ; RETURN PROCESS + MOVE B,3(AB) + JRST FINIS + +MQUOTE BREAKER + +BREAKE: +CALLEV: MOVEM A,-3(TP) ; HERE TO EVAL THE GOODIE (SAVE REAL RESULT) + MOVEM B,-2(TP) + MCALL 1,EVAL + POP TP,B + POP TP,A + JRST FINIS + +BREAKM: PUSH TP,$TATOM + PUSH TP,EQUOTE ATTEMPT-TO-BREAK-OWN-SEQUENCE + JRST CALER1 + +; FUNCTION TOP PUT PROCESS IN 1 STEP MODE + +MFUNCTION 1STEP,SUBR + PUSHJ P,1PROC + MOVEM PVP,1STEPR+1(B) ; CLOBBER TARGET PROCESS + JRST FINIS + +; FUNCTION TO UNDO ABOVE + +MFUNCTION %%FREE,SUBR,FREE-RUN + PUSHJ P,1PROC + CAME PVP,1STEPR+1(B) + JRST FNDBND + SETZM 1STEPR+1(B) + JRST FINIS + +FNDBND: SKIPE 1STEPR+1(B) ; DOES IT HAVE ANY 1STEPPER? + JRST NOTMIN ; YES, COMPLAIN + MOVE D,B ; COPY PROCESS + ADD D,[1STEPR,,1STEPR] ; POINTER FOR SEARCH + HRRZ C,SPSTO+1(B) ; GET THIS BINDING STACK + +FNDLP: GETYP 0,(C) ; IS THIS A TBVL? + CAIN 0,TBVL + CAME D,1(C) ; SKIP IF THIS IS SAVED 1STEP SLOT + JRST FNDNXT + SKIPN 3(C) ; IS IT SAVING A REAL 1STEPPER? + JRST FNDNXT + CAME PVP,3(C) ; IS IT ME? + JRST NOTMIN + SETZM 3(C) ; CLEAR OUT SAVED 1STEPPER + JRST FINIS +FNDNXT: HRRZ C,(C) ; NEXT BINDING + JUMPN C,FNDLP + +NOTMIN: MOVE C,$TCHSTR + MOVE D,CHQUOTE NOT-YOUR-1STEPEE + PUSHJ P,INCONS + MOVSI A,TFALSE + JRST FINIS + +1PROC: ENTRY 1 + GETYP A,(AB) + CAIE A,TPVP + JRST WTYP1 + MOVE B,1(AB) + MOVE A,(AB) + POPJ P, + +; FUNCTION TO RETRUN THE MAIN PROCESS + +MFUNCTION MAIN%%,SUBR,MAIN + ENTRY 0 + + MOVE B,MAINPR +MAIN1: MOVSI A,TPVP + JRST FINIS + +; FUNCTION TO RETURN THE CURRENT PROCESS + +MFUNCTION ME,SUBR + ENTRY 0 + + MOVE B,PVP + JRST MAIN1 + +; FUNCTION TO RETURN THE STATE OF A PROCESS + +MFUNCTION STATE,SUBR + ENTRY 1 + GETYP A,(AB) + CAIE A,TPVP + JRST WTYP1 + MOVE A,1(AB) ; GET PROCESS + MOVE A,PSTAT+1(A) + MOVE B,@STATES(A) ; GET STATE + MOVSI A,TATOM + JRST FINIS + +STATES: + IRP A,,[ILLEGAL,RUNABLE,RESUMABLE,RUNNING,DEAD,BLOCKED] + MQUOTE A + TERMIN + + + +END + diff --git a/sumex/decl.mcr072 b/sumex/decl.mcr072 new file mode 100644 index 0000000..6a41e1c --- /dev/null +++ b/sumex/decl.mcr072 @@ -0,0 +1,852 @@ +TITLE DECLARATION PROCESSOR + +RELOCA + +.INSRT MUDDLE > + +.GLOBAL STBL,TYPFND,TYPSGR,CHKDCL,TESTR,VALG,INCR1,TYPG,ISTRUC,TMATCH,SAT +.GLOBAL TYPMIS,CHKAB,CHKARG,IGDECL,LOCQQ,APLQ,CALER,IEQUAL,IIGLOC,IGLOC +.GLOBAL CHLOCI,INCONS,SPCCHK,WTYP1 + +; Subr to allow user to access the DECL checking code + +MFUNCTION CHECKD,SUBR,[DECL?] + + ENTRY 2 + + MOVE C,(AB) + MOVE D,1(AB) + MOVE A,2(AB) + MOVE B,3(AB) + PUSHJ P,TMATCX ; CHECK THEM + JRST IFALS + +RETT: MOVSI A,TATOM + MOVE B,MQUOTE T + JRST FINIS + +RETF: +IFALS: MOVEI B,0 + MOVSI A,TFALSE + JRST FINIS + +; Subr to turn DECL checking on and off. + +MFUNCTION %DECL,SUBR,[DECL-CHECK] + + ENTRY 1 + + GETYP 0,(AB) + SETZM IGDECL + CAIN 0,TFALSE + SETOM IGDECL + MOVE A,(AB) + MOVE B,1(AB) + JRST FINIS + +; Change special unspecial normal mode + +MFUNCTION SPECM%,SUBR,[SPECIAL-MODE] + + ENTRY + + CAMGE AB,[-3,,] + JRST TMA + MOVE C,SPCCHK ; GET CURRENT + JUMPGE AB,MODER ; RET CURRENT + GETYP 0,(AB) ; CHECK IT IS ATOM + CAIE 0,TATOM + JRST WTYP1 + MOVE 0,1(AB) + MOVEI A,1 + CAMN 0,MQUOTE UNSPECIAL + MOVSI A,(SETZ) + CAMN 0,MQUOTE SPECIAL + MOVEI A,0 + JUMPG A,WTYP1 + HLLM A,SPCCHK + +MODER: MOVSI A,TATOM + MOVE B,MQUOTE SPECIAL + SKIPGE C + MOVE B,MQUOTE UNSPECIAL + JRST FINIS + +; Function to turn special checking on and of + +MFUNCTION SPECC%,SUBR,[SPECIAL-CHECK] + + ENTRY + CAMGE AB,[-3,,] + JRST TMA + + MOVE C,SPCCHK + JUMPGE AB,SCHEK1 + + MOVEI A,0 + GETYP 0,(AB) + CAIE 0,TFALSE + MOVEI A,1 + HRRM A,SPCCHK + +SCHEK1: TRNN C,1 + JRST IFALS + JRST RETT + +; Finction to set decls for GLOBAL values. + +MFUNCTION GDECL,FSUBR + + ENTRY 1 + + GETYP 0,(AB) + CAIE 0,TLIST + JRST WTYP1 + + PUSH TP,$TLIST + PUSH TP,1(AB) + PUSH TP,$TLIST + PUSH TP,[0] + PUSH TP,$TLIST + PUSH TP,[0] + +GDECL1: INTGO + SKIPN C,1(TB) + JRST RETT + HRRZ D,(C) ; MAKE SURE PAIRS + JUMPE D,GDECLL ; LOSER, GO AWAY + GETYP 0,(C) + CAIE 0,TLIST + JRST GDECLL + HRRZ 0,(D) + MOVEM 0,1(TB) ; READY FOR NEXT CALL + MOVE C,1(C) ; SAVE ATOM LIST + MOVEM C,5(TB) + MOVEM D,3(TB) + +GDECL2: INTGO + SKIPN C,5(TB) + JRST GDECL1 ; OUT OF ATOMS + GETYP 0,(C) ; IS THIS AN ATOM + CAIE 0,TATOM + JRST GDECLL ; NO, LOSE + MOVE B,1(C) + HRRZ C,(C) + MOVEM C,5(TB) + PUSHJ P,IIGLOC ; GET ITS VAL (OR MAKE ONE) + GETYP 0,(B) ; UNBOUND? + CAIE 0,TUNBOU + JRST CHKCUR ; CHECK CURRENT VALUE + MOVE C,3(TB) ; GET DECL + HRRM C,-2(B) + JRST GDECL2 + +CHKCUR: HRRZ D,3(TB) + GETYP A,(D) + MOVSI A,(A) + MOVE E,B + MOVE B,1(D) + MOVE C,(E) + MOVE D,1(E) + PUSH TP,$TVEC + PUSH TP,E + JSP E,CHKAB + PUSHJ P,TMATCH + JRST TYPMI3 + MOVE E,(TP) + SUB TP,[2,,2] + MOVE D,3(TB) + HRRM D,-2(E) + JRST GDECL2 + +TYPMI3: MOVE E,(TP) ; POINT BACK TO SLOT + MOVE A,-1(E) ; ATOM TO A + MOVE B,1(E) + MOVE D,(E) ; GET OLD VALUE + MOVE C,3(TB) + JRST TYPMIS ; GO COMPLAIN + +GDECLL: PUSH TP,$TATOM + PUSH TP,EQUOTE BAD-ARGUMENT-LIST + JRST CALER1 + +MFUNCTION UNMANIFEST,SUBR + + ENTRY + + PUSH P,[HLLZS -2(B)] + JRST MANLP + +MFUNCTION MANIFEST,SUBR + + ENTRY + + PUSH P,[HLLOS -2(B)] +MANLP: JUMPGE AB,RETT + GETYP 0,(AB) + CAIE 0,TATOM + JRST WTYP + MOVE B,1(AB) + PUSHJ P,IIGLOC + XCT (P) + ADD AB,[2,,2] + JRST MANLP + +MFUNCTION MANIFQ,SUBR,[MANIFEST?] + + ENTRY 1 + + GETYP 0,(AB) + CAIE 0,TATOM + JRST WTYP1 + + MOVE B,1(AB) + PUSHJ P,IGLOC ; GET POINTER IF ANY + GETYP 0,A + CAIN 0,TUNBOU + JRST RETF + HRRZ 0,-2(B) + CAIE 0,-1 + JRST RETF + JRST RETT + +MFUNCTION GETDECL,SUBR,[GET-DECL] + + ENTRY 1 + + PUSHJ P,GTLOC + JRST GTLOCA + + HRRZ C,-2(B) ; GET GLOBAL DECL +GETD1: JUMPE C,RETF + CAIN C,-1 + JRST RETMAN + GETYP A,(C) + MOVSI A,(A) + MOVE B,1(C) + JSP E,CHKAB + JRST FINIS + +RETMAN: MOVSI A,TATOM + MOVE B,MQUOTE MANIFEST + JRST FINIS + +GTLOCA: HLRZ C,2(B) ; LOCAL DECL + JRST GETD1 + +MFUNCTION PUTDECL,SUBR,[PUT-DECL] + + ENTRY 2 + + PUSHJ P,GTLOC + SKIPA E,[HRLM B,2(C)] + MOVE E,[HRRM B,-2(C)] + PUSH P,E + GETYP 0,(B) ; ANY VALUE + CAIN 0,TUNBOU + JRST PUTD1 + MOVE C,(B) ; GET CURRENT VALUE + MOVE D,1(B) + MOVE A,2(AB) + MOVE B,3(AB) + PUSHJ P,TMATCH + JRST TYPMI4 +PUTD1: MOVE C,2(AB) ; GET DECL BACK + MOVE D,3(AB) + PUSHJ P,INCONS ; CONS IT UP + MOVE C,1(AB) ; LOCATIVE BACK + XCT (P) ; CLOBBER + MOVE A,(AB) + MOVE B,1(AB) + JRST FINIS + +TYPMI4: MOVE E,1(AB) ; GET LOCATIVE + MOVE A,-1(E) ; NOW ATOM + MOVEI C,2(AB) ; POINT TO DECL + MOVE D,(E) ; AND CURRENT VAL + MOVE B,1(E) + JRST TYPMIS + +GTLOC: GETYP 0,(AB) + CAIE 0,TLOCD + JRST WTYP1 + MOVEI B,(AB) + PUSHJ P,CHLOCI + HRRZ 0,(AB) ; LOCAL OR GLOBAL + SKIPN 0 + AOS (P) + MOVE B,1(AB) ; RETURN LOCATIVE IN B + POPJ P, + +; Interface between EVAL and declaration processor. +; E points into stack at a binding and C points to decl list. + +CHKDCL: SKIPE IGDECL ; IGNORING DECLS? + POPJ P, ; YUP, JUST LEAVE + + PUSH TP,$TTP ; SAVE BINDING + PUSH TP,E + MOVE A,-4(E) ; GET ATOM + MOVSI 0,TLIST ; SETUP FOR INTERRUPTABLE + MOVEM 0,CSTO(PVP) + MOVEM 0,BSTO(PVP) + MOVSI 0,TATOM + MOVEM 0,ASTO(PVP) + SETZB B,0 ; CLOBBER FOR INTGO + +DCL2: INTGO + HRRZ D,(C) ; MAKE SURE EVEN ELEMENTS + JUMPE D,BADCL + GETYP B,(C) ; MUST BE LIST OF ATOMS + CAIE B,TLIST + JRST BADCL + MOVE B,1(C) ; GET LIST + +DCL1: INTGO + CAMN A,1(B) ; SKIP IF NOT WINNER + JRST DCLQ ; MAY BE WINNER +DCL3: HRRZ B,(B) ; CDR ON + JUMPN B,DCL1 ; JUMP IF MORE + + HRRZ C,(D) ; CDR MAIN LIST + JUMPN C,DCL2 ; AND JUMP IF WINNING + + PUSHJ P,E.GET ; GET BINDING BACK + SUB TP,[2,,2] ; POP OF JUNK + POPJ P, + +DCLQ: GETYP C,(B) ; CHECK ATOMIC + CAIE C,TATOM + JRST BADCL ; LOSER + PUSHJ P,E.GET ; GOT IT + PUSH TP,$TLIST ; SAVE PATTERN + PUSH TP,D + MOVE B,1(D) ; GET PATTERN + HLLZ A,(D) + MOVE C,-3(E) ; PROPOSED VALUE + MOVE D,-2(E) + PUSHJ P,TMATCH ; MATCH TYPE + JRST TYPMI1 ; LOSER +DCLQ1: MOVE E,-2(TP) + MOVE C,-5(E) ; CHECK FOR SPEC CHANGE + SKIPE 0 ; MAKE SURE NON ZERO IS -1 + MOVNI 0,1 + SKIPL SPCCHK ; SKIP IF NORMAL UNSPECIAL + SETCM 0 ; COMPLEMENT + ANDI 0,1 ; ONE BIT + CAMN C,[TATOM,,-1] + JRST .+3 + CAME C,[TATOM,,-2] + JRST .+3 + ANDCMI C,1 + IOR C,0 ; MUNG BIT + MOVEM C,-5(E) + HRRZ C,(TP) + SUB TP,[4,,4] + MOVEM C,(E) ; STORE DECLS + MOVSI C,TLIST + MOVEM C,-1(E) + POPJ P, + +TYPMI1: MOVE E,-2(TP) + GETYP C,-3(E) + CAIN C,TUNBOU + JRST DCLQ1 + MOVE E,-2(TP) ; GET POINTER TO BIND + MOVE D,-3(E) ; GET VAL + MOVE B,-2(E) + HRRZ C,(TP) ; DCL LIST + MOVE A,-4(E) ; GET ATOM + SUB TP,[4,,4] +TYPMIS: PUSH TP,$TATOM + PUSH TP,EQUOTE TYPE-MISMATCH + PUSH TP,$TATOM + PUSH TP,A + PUSH TP,(C) + HLLZS (TP) + PUSH TP,1(C) + JSP E,CHKARG ; HACK DEFER + PUSH TP,D + PUSH TP,B + MOVEI A,4 ; 3 ERROR ARGS + JRST CALER + +BADCL: PUSHJ P,E.GET + PUSH TP,$TATOM + PUSH TP,EQUOTE BAD-DECLARATION-LIST + JRST CALER1 + +; ROUTINE TO RESSET INT STUFF + +E.GET: MOVE E,(TP) + SETZM ASTO(PVP) + SETZM BSTO(PVP) + SETZM CSTO(PVP) + POPJ P, + +; Declarations processor for MUDDLE type declarations. +; Receives a pattern in a and B and an object in C and D. +; It skip returns if the object fits otherwise it doesn't. +; Declaration syntax errors are caught and sent to ERROR. + +TMATCH: MOVEI 0,1 ; RET SPECIAL INDICATOR + SKIPE IGDECL ; IGNORING DECLS? + JRST CPOPJ1 ; YUP, ACT LIKE THEY WON + +TMATCX: GETYP 0,A ; GET PATTERNS TYPE + CAIN 0,TFORM ; MUST BE FORM OR ATOM + JRST TMAT1 + CAIE 0,TATOM + JRST TERR1 ; WRONG TYPE FOR A DCL + +; SIMPLE TYPE MATCHER + +TYPMAT: GETYP E,C ; OBJECTS TYPE TO E + PUSH P,E ; SAVE IT + PUSHJ P,TYPFND ; CONVERT TYPE NAME TO CODE + JRST SPECS ; NOT A TYPE NAME, TRY SPECIALS + POP P,E ; RESTORE TYPE OF OBJECT + MOVEI 0,0 ; SPECIAL INDICATOR + CAIN E,(D) ; SKIP IF LOSERS +CPOPJ1: AOS (P) ; GOOD RETURN +CPOPJ: POPJ P, + +SPECS: POP P,A ; RESTORE OBJECTS TYPE + CAMN B,MQUOTE ANY + JRST CPOPJ1 ; RETURN IMMEDIATELY IF ANYTHING WINS + CAMN B,MQUOTE STRUCTURED + JRST ISTRUC ; LET ISTRUC DO THE WORK + CAMN B,MQUOTE APPLICABLE + JRST APLQ + CAME B,MQUOTE LOCATIVE + JRST TERR2 + JRST LOCQQ + +; ARRIVE HERE FOR A FORM IN THE DCLS + +TMAT1: JUMPE B,TERR3 ; EMPTY FORM LOSES + HRRZ E,(B) ; CDR IT + JUMPE E,TMAT3 ; CANT BE SPECIAL/UNSPECIAL, LEAVE + PUSHJ P,0ATGET ; GET POSSIBLE ATOM IN 0 + JRST TEXP1 ; NOT ATOM + CAME 0,MQUOTE SPECIAL + CAMN 0,MQUOTE UNSPECIAL + JRST TMAT2 ; IGNORE SPECIAL/UNSPECIAL +TMAT3: PUSHJ P,TEXP1 + JRST .+2 + AOS (P) + MOVEI 0,0 ; RET UNSPECIAL INDICATION + POPJ P, + +TEXP1: JUMPE B,TERR3 ; EMPTY FORM + GETYP 0,A ; CHECK CURRENT TYPE + CAIN 0,TATOM ; IF ATOM, + JRST TYPMA1 ; SIMPLE MATCH + CAIE 0,TFORM + JRST TERR4 + GETYP 0,(B) ; WHAT IS FIRST ELEMEMT + CAIE 0,TFORM ; FORM=> <....> OR <....> + JRST 0,TEXP12 + PUSH TP,$TLIST ; SAVE LIST + PUSH TP,B + MOVE B,1(B) ; GET FORM + PUSH TP,C + PUSH TP,D + PUSHJ P,ACTRT1 + TDZA 0,0 ; REMEMBER LACK OF SKIP + MOVEI 0,1 + POP TP,D + POP TP,C + MOVE B,(TP) ; GET BACK SAVED LIST + SUB TP,[2,,2] + JUMPE 0,CPOPJ ; LOSERS EXIT IMMEDIATELY + HRRZ B,(B) ; OTHERWISE REST THE LIST AND FALL INTO ELETYPE + +; CHECKS TYPES OF ELEMENTS OF STRUCTURES + +ELETYP: JUMPE B,CPOPJ1 ; EMPTY=> WON + PUSH TP,$TLIST ; SAVE DCL LIST + PUSH TP,B + MOVE A,C ; GET OBJ IN A AND B + MOVE B,D + PUSHJ P,TYPSGR ; GET REST/NTH CODE + JRST ELETYL ; LOSER + PUSH TP,DSTO(PVP) + PUSH TP,D + PUSH P,C ; SAVE CODE + PUSH TP,[0] ; AND SLOTS + PUSH TP,[0] + +; MAIN ELEMENT SCANNING LOOP + +ELETY1: XCT TESTR(C) ; SKIP IF OBJ NOT EMPTY + JRST ELETY2 ; CHEK EMPTY WINNER + XCT TYPG(C) ; GET ELEMENT + XCT VALG(C) + JSP E,CHKAB ; CHECK OUT DEFER + MOVEM A,-1(TP) ; AND SAVE IT + MOVEM B,(TP) + MOVE C,A + MOVE D,B ; FOR OTHER MATCHERS + MOVE B,-4(TP) ; GET PATTERN + MOVE A,(B) + GETYP 0,(B) ; GET TYPE OF <1 pattern> + MOVE B,1(B) ; GET ATOM OR WHATEVER + CAIE 0,TATOM ; ATOM ... SIMPLE TYPE + JRST ELETY3 + PUSHJ P,TYPMAT ; DO SIMPLE TYPE MATCH + JRST ELETY4 ; LOSER + +; HERE TO REST EVERYTHING AND GO ON BACK + +ELETY6: MOVE D,-2(TP) ; GET OBJ POINTER + MOVE C,(P) ; GET INCREMENT CODE + XCT INCR1(C) + MOVEM D,-2(TP) ; SAVED INCREMENTED GOODIR + MOVE 0,DSTO(PVP) + MOVEM 0,-3(TP) + +ELETY9: HRRZ B,@-4(TP) ; CDR IT + MOVEM B,-4(TP) + JUMPN B,ELETY1 + +; HERE IF PATTERN EMPTY + +ELETY8: AOS -1(P) ; SKIP RETURN +ELETY4: SETZM DSTO(PVP) + SUB P,[1,,1] + SUB TP,[6,,6] + POPJ P, + +ELETYL: SUB TP,[2,,2] + POPJ P, + +; HERE TO HANDLE EMPTY OBJECT + +ELETY2: MOVE B,-4(TP) ; GET PATTERN + GETYP 0,(B) ; CHECK FOR [REST ...] + SETZM DSTO(PVP) + CAIE 0,TVEC + JRST ELETY4 ; LOSER + HLRZ 0,1(B) ; SIZE OF IT + CAILE 0,-4 ; MUST BE 2 + JRST ELETY4 + MOVE B,1(B) ; GET IT + PUSHJ P,0ATGET ; LOOK FOR REST + JRST ELETY4 + CAMN 0,MQUOTE REST + JRST ELETY8 ; WINNER!!!! + JRST ELETY4 ; LOSER + +; HERE TO CHECK OUT A FORM ELEMNT + +ELETY3: CAIE 0,TFORM + JRST ELETY7 + SETZM DSTO(PVP) + PUSHJ P,TEXP1 ; AND ANALYSE IT + JRST ELETY4 ; LOSER + MOVE 0,-3(TP) ; RESET DSTO + MOVEM 0,DSTO(PVP) + JRST ELETY6 ; WINNER + +; CHECK FOR VECTOR IN PATTERN + +ELETY7: CAIE 0,TVEC ; SKIP IF WINNER + JRST TERR12 ; YET ANOTHER ERROR + HLRE C,B ; CHECK LEENGTH + CAMLE C,[-4] ; MUST BE 2 LONG + JRST TERR13 + PUSHJ P,0ATGET ; 1ST ELEMENT ATOM? + JRST ELET71 ; COULD BE FORM + CAME 0,MQUOTE REST + JRST TERR14 + MOVNI 0,1 ; FLAG USED IN RESTIT + PUSHJ P,RESTIT ; CHECK REST OF STRUCTUR + JRST ELETY4 + JRST ELETY8 ; WIN AND DONE + +; CHECK FOR [fix .... ] + +ELET71: CAIE 0,TFIX + JRST TERR15 + MOVNS C + ASH C,-1 + MOVE 0,1(B) ; GET NUMBER + IMULI 0,-1(C) ; COUNT MORE + PUSHJ P,RESTIT ; AND CHECK FIX NUM OF ELEMENTS + JRST ELETY4 + MOVE D,-2(TP) ; GET OBJECT BACK + MOVE 0,-3(TP) ; RESET DSTO + MOVEM 0,DSTO(PVP) + MOVE C,(P) ; RESTORE CODE FOR RESTING ETC. + JRST ELETY9 + + +; HERE TO DO A TASTEFUL TYPMAT + +TYPMA1: PUSH TP,C + PUSH TP,D + PUSHJ P,TYPMAT + TDZA 0,0 ; REMEMBER LOSSAGE + MOVEI 0,1 ; OR WINNAGE + POP TP,D + POP TP,C ; RESTORE OBJECT + JUMPN 0,CPOPJ1 ; SKIPPED BEFORE, SKIP AGAIN + POPJ P, + +; HERE TO SKIP SPECIAL/UNSPECIAL + +TMAT2: CAME 0,MQUOTE SPECIAL + TDZA 0,0 + MOVEI 0,1 + PUSH P,0 ; SAVE INDICATOR + GETYP A,(E) ; TYPE OF NEW PAT + MOVE B,1(E) ; VALUE + MOVSI A,(A) + PUSHJ P,TEXP1 + JRST .+2 + AOS -1(P) + POP P,0 + POPJ P, + +; LOOK FOR SIMPLE TYPE + CAIN 0,TFORM ; FORM--> HAIRY PATTERN + MOVEI E,TEXP1 + PUSHJ P,(E) ; DO IT + JRST RESTI5 + JRST RESTI4 + +RESTI2: SKIPGE (P) ; SKIP IF WON + AOS -2(P) ; COUNTERACT CPOPJ1 + JRST RESTI5 + +RESTI3: TEXP1 + TYPMAT + +; HERE TO MATHC A QUOTED OBJ +; B/ FORM QUOTE... C,D/ OBJECT TO MATCH AGAINST + +MQUOT: HRRZ B,(B) ; LOOK AT NEXT + JUMPE B,TERR7 + GETYP A,(B) ; GET TYPE + MOVSI A,(A) + MOVE B,1(B) ; AND VALUE + JSP E,CHKAB ; HACK DEFER + PUSH TP,A + PUSH TP,B + PUSH TP,C + PUSH TP,D + MOVEI D,-3(TP) + MOVEI C,-1(TP) + PUSHJ P,IEQUAL + TDZA 0,0 + MOVEI 0,1 + JRST POPPIT + + +; GET ATOM IN AC 0 + +0ATGET: GETYP 0,(B) + CAIE 0,TATOM ; SKIP IF ATOM + POPJ P, + MOVE 0,1(B) ; GET ATOM + JRST CPOPJ1 + +TERR9: MOVS A,0 ; TYPE TO A +TERR4: +TERR5: +TERR15: +TERR1: MOVE E,EQUOTE DECL-ELEMENT-NOT-FORM-OR-ATOM + JRST TERRD + +TERR2: MOVSI A,TATOM + MOVE E,EQUOTE ATOM-NOT-TYPE-NAME-OR-SPECIAL-SYMBOL + JRST TERRD +TERR6: +TERR3: MOVE E,EQUOTE EMPTY-FORM-IN-DECL + JRST TERRD +TERR7: MOVE E,EQUOTE EMPTY-OR/PRIMTYPE-FORM + JRST TERRD + +TERR8: MOVS A,0 ; TYPE TO A + MOVE E,EQUOTE NON-TYPE-FOR-PRIMTYPE-ARG + JRST TERRD +TERR12: MOVE E,EQUOTE ELEMENT-TYPE-NOT-ATOM-FORM-OR-VECTOR + JRST TERRD +TERR13: MOVE E,EQUOTE VECTOR-LESS-THAN-2-ELEMENTS + JRST TERRD +TERR14: MOVE E,EQUOTE FIRST-VECTOR-ELEMENT-NOT-REST-OR-A-FIX + +TERRD: PUSH TP,$TATOM + PUSH TP,EQUOTE BAD-TYPE-SPECIFICATION + PUSH TP,$TATOM + PUSH TP,E + PUSH TP,A + PUSH TP,B + MOVEI A,3 + JRST CALER + +IMPURE + +IGDECL: 0 + +PURE + +END + \ No newline at end of file diff --git a/sumex/eval.mcr349 b/sumex/eval.mcr349 new file mode 100644 index 0000000..efdc14d --- /dev/null +++ b/sumex/eval.mcr349 @@ -0,0 +1,3935 @@ +TITLE EVAL -- MUDDLE EVALUATOR + +RELOCATABLE + +; GERALD JAY SUSSMAN, 1971. REWRITTEN MANY TIMES SINCE C. REEVE (1972--1974) + + +.GLOBAL BINDID,LPROG,GLOBSP,GLOBASE,SPBASE,TPBASE,PTIME,SWAP,CHFRAM +.GLOBAL IGVAL,CHKARG,NXTDCL,TPOVFL,CHFRM,PROCHK,CHFSWP,VECBOT,TYPSGR +.GLOBAL ILVAL,ER1ARG,SPECBIND,MAKACT,SPECSTORE,MAKTUP,TPALOC,IBIND,SSPECS +.GLOBAL IDVAL,EVECTO,EUVECT,CHARGS,BCKTRK,CELL,ILOC,IGLOC,CHKDCL,SSPEC1 +.GLOBAL PDLBUF,MESS,FACTI,CHKARG,MAKENV,PSTAT,BNDV,UNBOU,UNAS,IGDECL +.GLOBAL 1STEPR,SEGMNT,SEGLST,NAPT,EVTYPE,EVATYP,APTYPE,APLTYP,APLQ,IDVAL1 +.GLOBAL TESTR,VALG,TYPG,INCR1,TMATCH,TYPMIS,SAT,MAKACT,NTPALO,SPECBND +.GLOBAL TPGROW,CHKAB,TYPSEG,NXTLM,MONCH0,CHFINI,RMONC0,IMPURIFY,ICONS,INCONS +.GLOBAL CILVAL,CISET,CIGVAL,CSETG,MAPPLY,CLLOC,CGLOC,CASSQ,CGASSQ,CBOUND +.GLOBAL IIGLOC,CHUNW,IUNWIN,UNWIN2,SPCCHK,CURFCN,TMPLNT,TD.LNT,TBINIT +.GLOBAL SPECBE +.GLOBAL AGC,GVLINC,LVLINC,CGBOUN,IEVECT,MAKTU2 + +.INSRT MUDDLE > + +MONITOR + + +; ENTRY TO EXPAND A MACRO + +MFUNCTION EXPAND,SUBR + + ENTRY 1 + + MOVEI A,PVLNT*2+1(PVP) + HRLI A,TFRAME + MOVE B,TBINIT+1(PVP) + HLL B,OTBSAV(B) + PUSH TP,A + PUSH TP,B + MOVEI B,-1(TP) + JRST AEVAL2 + +; MAIN EVAL ENTRANCE + +MFUNCTION EVAL,SUBR + + ENTRY + + SKIPE C,1STEPR+1(PVP) ; BEING 1 STEPPED? + JRST 1STEPI ; YES HANDLE +EVALON: HLRZ A,AB ;GET NUMBER OF ARGS + CAIE A,-2 ;EXACTLY 1? + JRST AEVAL ;EVAL WITH AN ALIST +SEVAL: GETYP A,(AB) ;GET TYPE OF ARG + SKIPE C,EVATYP+1(TVP) ; USER TYPE TABLE? + JRST EVDISP +SEVAL1: CAIG A,NUMPRI ;PRIMITIVE? + JRST @EVTYPE(A) ;YES-DISPATCH + +SELF: MOVE A,(AB) ;TYPES WHICH EVALUATE + MOVE B,1(AB) + JRST EFINIS ;TO SELF-EG NUMBERS + +; HERE FOR USER EVAL DISPATCH + +EVDISP: ADDI C,(A) ; POINT TO SLOT + ADDI C,(A) + SKIPE (C) ; SKIP EITHER A LOSER OR JRST DISP + JRST EVDIS1 ; APPLY EVALUATOR + SKIPN C,1(C) ; GET ADDR OR GO TO PURE DISP + JRST SEVAL1 + JRST (C) + +EVDIS1: PUSH TP,(C) + PUSH TP,1(C) + PUSH TP,(AB) + PUSH TP,1(AB) + MCALL 2,APPLY ; APPLY HACKER TO OBJECT + JRST EFINIS + + +; EVAL DISPATCH TABLE + +DISTBL EVTYPE,SELF,[[TFORM,EVFORM],[TLIST,EVLIST],[TVEC,EVECT],[TUVEC,EUVEC] +[TSEG,ILLSEG]] + + +;WATCH FOR SUBTLE BUG 43 LERR,LPROG OR BINDID +AEVAL: + CAIE A,-4 ;EXACTLY 2 ARGS? + JRST WNA ;NO-ERROR + GETYP A,2(AB) ;CHECK THAT WE HAVE A FRAME + CAIE A,TACT + CAIN A,TFRAME + JRST .+3 + CAIE A,TENV + JRST TRYPRO ; COULD BE PROCESS + MOVEI B,2(AB) ; POINT TO FRAME +AEVAL2: PUSHJ P,CHENV ; HACK ENVIRONMENT CHANGE +AEVAL1: PUSH TP,(AB) + PUSH TP,1(AB) + MCALL 1,EVAL +AEVAL3: HRRZ 0,FSAV(TB) + CAIN 0,EVAL + JRST EFINIS + JRST FINIS + +TRYPRO: CAIE A,TPVP ; SKIP IF IT IS A PROCESS + JRST WTYP2 + MOVE C,3(AB) ; GET PROCESS + CAMN C,PVP ; DIFFERENT FROM ME? + JRST SEVAL ; NO, NORMAL EVAL WINS + MOVE B,SPSTO+1(C) ; GET SP FOR PROCESS + MOVE D,TBSTO+1(C) ; GET TOP FRAME + HLL D,OTBSAV(D) ; TIME IT + MOVEI C,PVLNT*2+1(C) ; CONS UP POINTER TO PROC DOPE WORD + HRLI C,TFRAME ; LOOK LIK E A FRAME + PUSHJ P,SWITSP ; SPLICE ENVIRONMENT + JRST AEVAL1 + +; ROUTINE TO CHANGE LOOK UP PATH FOR BINDINGS + +CHENV: PUSHJ P,CHFRM ; CHECK OUT FRAME + MOVE C,(B) ; POINT TO PROCESS + MOVE D,1(B) ; GET TB POINTER FROM FRAME + CAMN SP,SPSAV(D) ; CHANGE? + POPJ P, ; NO, JUST RET + MOVE B,SPSAV(D) ; GET SP OF INTEREST +SWITSP: MOVSI 0,TSKIP ; SET UP SKIP + HRRI 0,1(TP) ; POINT TO UNBIND PATH + MOVE A,PVP + ADD A,[BINDID,,BINDID] ; BIND THE BINDING ID + PUSH TP,BNDV + PUSH TP,A + PUSH TP,$TFIX + AOS A,PTIME ; NEW ID + PUSH TP,A + MOVE E,TP ; FOR SPECBIND + PUSH TP,0 + PUSH TP,B + PUSH TP,C ; SAVE PROCESS + PUSH TP,D + PUSHJ P,SPECBE ; BIND BINDID + MOVE SP,TP ; GET NEW SP + SUB SP,[3,,3] ; SET UP SP FORK + POPJ P, + + +; HERE TO EVALUATE A FORM (99% OF EVAL'S WORK) + +EVFORM: SKIPN C,1(AB) ; EMPTY FORM, RETURN FALSE + JRST EFALSE + GETYP A,(C) ; 1ST ELEMENT OF FORM + CAIE A,TATOM ; ATOM? + JRST EV0 ; NO, EVALUATE IT + MOVE B,1(C) ; GET ATOM + PUSHJ P,IGVAL ; GET ITS GLOBAL VALUE + +; SPECIAL HACK TO SPEED UP LVAL AND GVAL CALLS + + CAIE B,LVAL + CAIN B,GVAL + JRST ATMVAL ; FAST ATOM VALUE + + GETYP 0,A + CAIE 0,TUNBOU ; BOUND? + JRST IAPPLY ; YES APPLY IT + + MOVE C,1(AB) ; LOOK FOR LOCAL + MOVE B,1(C) + PUSHJ P,ILVAL + GETYP 0,A + CAIE 0,TUNBOU + JRST IAPPLY ; WIN, GO APPLY IT + + PUSH TP,$TATOM + PUSH TP,EQUOTE UNBOUND-VARIABLE + PUSH TP,$TATOM + MOVE C,1(AB) ; FORM BACK + PUSH TP,1(C) + PUSH TP,$TATOM + PUSH TP,MQUOTE VALUE + MCALL 3,ERROR ; REPORT THE ERROR + JRST IAPPLY + +EFALSE: MOVSI A,TFALSE ; SPECIAL FALSE FOR EVAL OF EMPTY FORM + MOVEI B,0 + JRST EFINIS + +ATMVAL: HRRZ D,(C) ; CDR THE FORM + HRRZ 0,(D) ; AND AGAIN + JUMPN 0,IAPPLY + GETYP 0,(D) ; MAKE SURE APPLYING TO ATOM + CAIE 0,TATOM + JRST IAPPLY + MOVEI E,IGVAL ; ASSUME GLOBAAL + CAIE B,GVAL ; SKIP IF OK + MOVEI E,ILVAL ; ELSE USE LOCAL + PUSH P,B ; SAVE SUBR + MOVE B,(D)+1 ; CLR BUG #1637 (GET THE ATOM FOR THE SUBR) + PUSHJ P,(E) ; AND GET VALUE + CAME A,$TUNBOU + JRST EFINIS ; RETURN FROM EVAL + POP P,B + MOVSI A,TSUBR ; CAUSE REAL SUBR TO GET EROR + JRST IAPPLY + +; HERE FOR 1ST ELEMENT NOT A FORM + +EV0: PUSHJ P,FASTEV ; EVAL IT + +; HERE TO APPLY THINGS IN FORMS + +IAPPLY: PUSH TP,(AB) ; SAVE THE FORM + PUSH TP,1(AB) + PUSH TP,A + PUSH TP,B ; SAVE THE APPLIER + PUSH TP,$TFIX ; AND THE ARG GETTER + PUSH TP,[ARGCDR] + PUSHJ P,APLDIS ; GO TO INTERNAL APPLIER + JRST EFINIS ; LEAVE EVAL + +; HERE TO EVAL 1ST ELEMENT OF A FORM + +FASTEV: SKIPE 1STEPR+1(PVP) ; BEING 1 STEPPED? + JRST EV02 ; YES, LET LOSER SEE THIS EVAL + GETYP A,(C) ; GET TYPE + SKIPE D,EVATYP+1(TVP) ; USER TABLE? + JRST EV01 ; YES, HACK IT +EV03: CAIG A,NUMPRI ; SKIP IF SELF + SKIPA A,EVTYPE(A) ; GET DISPATCH + MOVEI A,SELF ; USE SLEF + +EV04: CAIE A,SELF ; IF EVAL'S TO SELF, JUST USE IT + JRST EV02 + MOVSI A,TLIST + MOVEM A,CSTO(PVP) + INTGO + SETZM CSTO(PVP) + HLLZ A,(C) ; GET IT + MOVE B,1(C) + JSP E,CHKAB ; CHECK DEFERS + POPJ P, ; AND RETURN + +EV01: ADDI D,(A) ; POINT TO SLOT OF USER EVAL TABLE + ADDI D,(A) + SKIPE (D) ; EITHER NOT GIVEN OR SIMPLE + JRST EV02 + SKIPN 1(D) ; SKIP IF SIMPLE + JRST EV03 ; NOT GIVEN + MOVE A,1(D) + JRST EV04 + +EV02: PUSH TP,(C) + HLLZS (TP) ; FIX UP LH + PUSH TP,1(C) + JSP E,CHKARG + MCALL 1,EVAL + POPJ P, + + +; MAPF/MAPR CALL TO APPLY + + MQUOTE APPLY + +MAPPLY: JRST APPLY + +; APPLY, FALLS INTO EVAL'S APPLY CODE AT APLDIS + +MFUNCTION APPLY,SUBR + + ENTRY + + JUMPGE AB,TFA ; MUST BE AT LEAST 1 ARGUMENT + MOVE A,AB + ADD A,[2,,2] + PUSH TP,$TAB + PUSH TP,A + PUSH TP,(AB) ; SAVE FCN + PUSH TP,1(AB) + PUSH TP,$TFIX ; AND ARG GETTER + PUSH TP,[SETZ APLARG] + PUSHJ P,APLDIS + JRST FINIS + +; STACKFROM, ALSO FALLS INTO EVAL'S APPLIER AT APLDIS + +MFUNCTION STACKFORM,FSUBR + + ENTRY 1 + + GETYP A,(AB) + CAIE A,TLIST + JRST WTYP1 + MOVEI A,3 ; CHECK ALL GOODIES SUPPLIED + HRRZ B,1(AB) + + JUMPE B,TFA + HRRZ B,(B) ; CDR IT + SOJG A,.-2 + + HRRZ C,1(AB) ; GET LIST BACK + PUSHJ P,FASTEV ; DO A FAST EVALUATION + PUSH TP,(AB) + HRRZ C,@1(AB) ; POINT TO ARG GETTING FORMS + PUSH TP,C + PUSH TP,A ; AND FCN + PUSH TP,B + PUSH TP,$TFIX + PUSH TP,[SETZ EVALRG] + PUSHJ P,APLDIS + JRST FINIS + + +; OFFSETS FOR TEMPORARIES ETC. USED IN APPLYING STUFF + +E.FRM==0 ; POINTS TO FORM BEING EVALED (OR ARGS FOR APPLY STACKFORM) +E.FCN==2 ; FUNCTION/SUBR/RSUBR BEING APPLIED +E.ARG==4 ; POINTS TO ARG GETTING ROUTINE (<0 => MUST EVAL ARGS) +E.EXTR==6 ; CONTAINS 1ST ARG IN USER APPLY CASE +E.SEG==10 ; POINTS TO SEGMENT IN FORM BEING HACKED +E.CNT==12 ; COUNTER FOR TUPLES OF ARGS +E.DECL==14 ; POINTS TO DECLARATION LIST IN FUNCTIONS +E.ARGL==16 ; POINTS TO ARG LIST IN FUNCTIONS +E.HEW==20 ; POINTS TO HEWITT ATOM IF IT EXISTS + +E.VAL==E.ARGL ; VALUE TYPE FOR RSUBRS + +MINTM==E.EXTR+2 ; MIN # OF TEMPS EVER ALLOCATED +E.TSUB==E.CNT+2 ; # OF TEMPS FOR SUBR/NUMBER APPLICATION +XP.TMP==E.HEW-E.EXTR ; # EXTRA TEMPS FOR FUNCTION APPLICATION +R.TMP==4 ; TEMPS AFTER ARGS ARE BOUND +TM.OFF==E.HEW+2-R.TMP ; TEMPS TO FLUSH AFTER BIND OF ARGS + +RE.FCN==0 ; AFTER BINDING CONTAINS FCN BODY +RE.ARG==2 ; ARG LIST AFTER BINDING + +; GENERAL THING APPLYER + +APLDIS: PUSH TP,[0] ; SLOT USED FOR USER APPLYERS + PUSH TP,[0] +APLDIX: GETYP A,E.FCN(TB) ; GET TYPE + +APLDI: SKIPE D,APLTYP+1(TVP) ; USER TABLE EXISTS? + JRST APLDI1 ; YES, USE IT +APLDI2: CAIG A,NUMPRI ; SKIP IF NOT PRIM + JRST @APTYPE(A) + JRST NAPT + +APLDI1: ADDI D,(A) ; POINT TO SLOT + ADDI D,(A) + SKIPE (D) ; SKIP IF NOT GIVEN OR STANDARD + JRST APLDI3 +APLDI4: SKIPE D,1(D) ; GET DISP + JRST (D) + JRST APLDI2 ; USE SYSTEM DISPATCH + +APLDI3: SKIPE E.EXTR+1(TB) ; SKIP IF HAVEN'T BEEN HERE BEFORE + JRST APLDI4 + MOVE A,(D) ; GET ITS HANDLER + EXCH A,E.FCN(TB) ; AND USE AS FCN + MOVEM A,E.EXTR(TB) ; SAVE + MOVE A,1(D) + EXCH A,E.FCN+1(TB) + MOVEM A,E.EXTR+1(TB) ; STASH OLD FCN AS EXTRG + GETYP A,(D) ; GET TYPE + JRST APLDI + + +; APPLY DISPATCH TABLE + +DISTBL APTYPE,,[[TSUBR,APSUBR],[TFSUBR,APFSUB],[TRSUBR,APRSUB],[TFIX,APNUM] +[TEXPR,APEXPR],[TFUNAR,APFUNARG],[TENTER,APENTR],[TMACRO,APMACR]] + +; SUBR TO SAY IF TYPE IS APPLICABLE + +MFUNCTION APPLIC,SUBR,[APPLICABLE?] + + ENTRY 1 + + GETYP A,(AB) + PUSHJ P,APLQ + JRST IFALSE + JRST TRUTH + +; HERE TO DETERMINE IF A TYPE IS APPLICABLE + +APLQ: PUSH P,B + SKIPN B,APLTYP+1(TVP) + JRST USEPUR ; USE PURE TABLE + ADDI B,(A) + ADDI B,(A) ; POINT TO SLOT + SKIPG 1(B) ; SKIP IF WINNER + SKIPE (B) ; SKIP IF POTENIAL LOSER + JRST CPPJ1B ; WIN + SKIPE 1(B) ; SKIP IF MUST USE PURE TABBLE + JRST CPOPJB +USEPUR: CAIG A,NUMPRI ; SKIP IF NOT PRIM + SKIPL APTYPE(A) ; SKIP IF APLLICABLE +CPPJ1B: AOS -1(P) +CPOPJB: POP P,B + POPJ P, + +; FSUBR APPLYER + +APFSUBR: + SKIPN E.EXTR(TB) ; IF EXTRA ARG + SKIPGE E.ARG+1(TB) ; OR APPLY/STACKFORM, LOSE + JRST BADFSB + MOVE A,E.FCN+1(TB) ; GET FCN + HRRZ C,@E.FRM+1(TB) ; GET ARG LIST + SUB TP,[MINTM,,MINTM] ; FLUSH UNWANTED TEMPS + PUSH TP,$TLIST + PUSH TP,C ; ARG TO STACK + .MCALL 1,(A) ; AND CALL + POPJ P, ; AND LEAVE + +; SUBR APPLYER + +APSUBR: + PUSHJ P,PSH4ZR ; SET UP ZEROED SLOTS + SKIPN A,E.EXTR(TB) ; FUNNY ARGS + JRST APSUB1 ; NO, GO + MOVE B,E.EXTR+1(TB) ; YES , GET VAL + JRST APSUB2 ; AND FALL IN + +APSUB1: PUSHJ P,@E.ARG+1(TB) ; EAT AN ARG + JRST APSUBD ; DONE +APSUB2: PUSH TP,A + PUSH TP,B + AOS E.CNT+1(TB) ; COUNT IT + JRST APSUB1 + +APSUBD: MOVE A,E.CNT+1(TB) ; FINISHED, GET COUNT + MOVE B,E.FCN+1(TB) ; AND SUBR + GETYP 0,E.FCN(TB) + CAIN 0,TENTER + JRST APENDN + PUSHJ P,BLTDN ; FLUSH CRUFT + .ACALL A,(B) + POPJ P, + +BLTDN: MOVEI C,(TB) ; POINT TO DEST + HRLI C,E.TSUB(C) ; AND SOURCE + BLT C,-E.TSUB(TP) ;BL..............T + SUB TP,[E.TSUB,,E.TSUB] + POPJ P, + +APENDN: PUSHJ P,BLTDN +APNDN1: .ECALL A,(B) + POPJ P, + +; FLAGS FOR RSUBR HACKER + +F.STR==1 +F.OPT==2 +F.QUO==4 +F.NFST==10 + +; APPLY OBJECTS OF TYPE RSUBR + +APENTR: +APRSUBR: + MOVE C,E.FCN+1(TB) ; GET THE RSUBR + CAML C,[-5,,] ; IS IT LONG ENOUGH FOR DECLS + JRST APSUBR ; NO TREAT AS A SUBR + GETYP 0,4(C) ; GET TYPE OF 3D ELEMENT + CAIE 0,TDECL ; DECLARATION? + JRST APSUBR ; NO, TREAT AS SUBR + PUSHJ P,PSH4ZR ; ALLOCATE SOME EXTRA ROOM + PUSH TP,$TDECL ; PUSH UP THE DECLS + PUSH TP,5(C) + PUSH TP,$TLOSE ; SAVE ROOM FOR VAL DECL + PUSH TP,[0] + + SKIPN E.EXTR(TB) ; "EXTRA" ARG? + JRST APRSU1 ; NO, + MOVE 0,[SETZ EXTRGT] ; CHANGE THE ACCESS FCN + EXCH 0,E.ARG+1(TB) + HRRM 0,E.ARG(TB) ; REMEMBER IT + +APRSU1: MOVEI 0,0 ; INIT FLAG REGISTER + PUSH P,0 ; SAVE + +APRSU2: HRRZ A,E.DECL+1(TB) ; GET DECL LIST + JUMPE A,APRSU3 ; DONE! + HRRZ B,(A) ; CDR IT + MOVEM B,E.DECL+1(TB) + PUSHJ P,NXTDCL ; IS NEXT THING A STRING? + JRST APRSU4 ; NO, BETTER BE A TYPE + CAMN B,[ASCII /VALUE/] + JRST RSBVAL ; SAVE VAL DECL + TRON 0,F.NFST ; IF NOT FIRST, LOSE + CAME B,[ASCII /CALL/] ; CALL DECL + JRST APRSU7 + SKIPGE E.ARG+1(TB) ; LEGAL? + JRST MPD + MOVE C,E.FRM(TB) + MOVE D,E.FRM+1(TB) ; GET FORM + JRST APRS10 ; HACK IT + +APRSU5: TROE 0,F.STR ; STRING STRING? + JRST MPD ; LOSER + CAME B,[+1] ; OPTIONA? + JRST APRSU8 + TROE 0,F.OPT ; CHECK AND SET + JRST MPD ; OPTINAL OPTIONAL LOSES + JRST APRSU2 ; TO MAIN LOOP + +APRSU7: CAME B,[ASCII /QUOTE/] + JRST APRSU5 + TRO 0,F.STR + TROE 0,F.QUO ; TURN ON AND CHECK QUOTE + JRST MPD ; QUOTE QUOTE LOSES + JRST APRSU2 ; GO TO END OF LOOP + + +APRSU8: CAME B,[ASCII /ARGS/] + JRST APRSU9 + SKIPGE E.ARG+1(TB) ; SKIP IF LEGAL + JRST MPD + HRRZ D,@E.FRM+1(TB) ; GET ARG LIST + MOVSI C,TLIST + +APRS10: HRRZ A,(A) ; GET THE DECL + MOVEM A,E.DECL+1(TB) ; CLOBBER + HRRZ B,(A) ; CHECK FOR TOO MUCH + JUMPN B,MPD + MOVE B,1(A) ; GET DECL + HLLZ A,(A) ; GOT THE DECL + MOVEM 0,(P) ; SAVE FLAGS + JSP E,CHKAB ; CHECK DEFER + PUSH TP,C + PUSH TP,D ; SAVE + PUSHJ P,TMATCH + JRST WTYP + AOS E.CNT+1(TB) ; COUNT ARG + JRST APRDON ; GO CALL RSUBR + +RSBVAL: HRRZ A,E.DECL+1(TB) ; GET DECL + JUMPE A,MPD + HRRZ B,(A) ; POINT TO DECL + MOVEM B,E.DECL+1(TB) ; SAVE NEW DECL POINTER + PUSHJ P,NXTDCL + JRST .+2 + JRST MPD + MOVEM A,E.VAL+1(TB) ; SAVE VAL DECL + MOVSI A,TDCLI + MOVEM A,E.VAL(TB) ; SET ITS TYPE + JRST APRSU2 + + +APRSU9: CAME B,[ASCII /TUPLE/] + JRST MPD + MOVEM 0,(P) ; SAVE FLAGS + HRRZ A,(A) ; CDR DECLS + MOVEM A,E.DECL+1(TB) + HRRZ B,(A) + JUMPN B,MPD ; LOSER + PUSH P,[0] ; COUNT ELEMENTS IN TUPLE + +APRTUP: PUSHJ P,@E.ARG+1(TB) ; GOBBLE ARGS + JRST APRTPD ; DONE + PUSH TP,A + PUSH TP,B + AOS (P) ; COUNT IT + JRST APRTUP ; AND GO + +APRTPD: POP P,C ; GET COUNT + ADDM C,E.CNT+1(TB) ; UPDATE MAIN COUNT + ASH C,1 ; # OF WORDS + HRLI C,TINFO ; BUILD FENCE POST + PUSH TP,C + PUSHJ P,TBTOTP ; GEN REL OFFSET TO TOP + PUSH TP,D + HRROI D,-1(TP) ; POINT TO TOP + SUBI D,(C) ; TO BASE + TLC D,-1(C) + MOVSI C,TARGS ; BUILD TYPE WORD + HLR C,OTBSAV(TB) + MOVE A,E.DECL+1(TB) + MOVE B,1(A) + HLLZ A,(A) ; TYPE/VAL + JSP E,CHKAB ; CHECK + PUSHJ P,TMATCH ; GOTO TYPE CHECKER + JRST WTYP + + SUB TP,[2,,2] ; REMOVE FENCE POST + +APRDON: SUB P,[1,,1] ; FLUSH CRUFT + MOVE A,E.CNT+1(TB) ; GET # OF ARGS + MOVE B,E.FCN+1(TB) + GETYP 0,E.FCN(TB) ; COULD BE ENTRY + MOVEI C,(TB) ; PREPARE TO BLT DOWN + HRLI C,E.TSUB+2(C) + BLT C,-E.TSUB+2(TP) + SUB TP,[E.TSUB+2,,E.TSUB+2] + CAIE 0,TRSUBR + JRST APNDN1 + .ACALL A,(B) ; CALL THE RSUBR + JRST PFINIS + + + +APRSU4: MOVEM 0,(P) ; SAVE FLAGS + MOVE B,1(A) ; GET DECL + HLLZ A,(A) + JSP E,CHKAB + MOVE 0,(P) ; RESTORE FLAGS + PUSH TP,A + PUSH TP,B ; AND SAVE + SKIPL E.ARG+1(TB) ; ALREADY EVAL'D + TRZN 0,F.QUO + JRST APREVA ; MUST EVAL ARG + MOVEM 0,(P) + HRRZ C,@E.FRM+1(TB) ; GET ARG? + TRNE 0,F.OPT ; OPTIONAL + JUMPE C,APRDN + JUMPE C,TFA ; NO, TOO FEW ARGS + MOVEM C,E.FRM+1(TB) + HLLZ A,(C) ; GET ARG + MOVE B,1(C) + JSP E,CHKAB ; CHECK THEM + +APRTYC: MOVE C,A ; SET UP FOR TMATCH + MOVE D,B + EXCH B,(TP) + EXCH A,-1(TP) ; SAVE STUFF +APRS11: PUSHJ P,TMATCH ; CHECK TYPE + JRST WTYP + + MOVE 0,(P) ; RESTORE FLAGS + TRZ 0,F.STR + AOS E.CNT+1(TB) + JRST APRSU2 ; AND GO ON + +APREVA: PUSHJ P,@E.ARG+1(TB) ; EVAL ONE + TDZA C,C ; C=0 ==> NONE LEFT + MOVEI C,1 + MOVE 0,(P) ; FLAGS + JUMPN C,APRTYC ; GO CHECK TYPE +APRDN: SUB TP,[2,,2] ; FLUSH DECL + TRNE 0,F.OPT ; OPTIONAL? + JRST APRDON ; ALL DONE + JRST TFA + +APRSU3: TRNE 0,F.STR ; END IN STRING? + JRST MPD + PUSHJ P,@E.ARG+1(TB) ; SEE IF ANYMORE ARGS + JRST APRDON + JRST TMA + + +; STANDARD ARGUMENT GETTERS USED IN APPLYING THINGS + +ARGCDR: HRRZ C,@E.FRM+1(TB) ; POINT TO ARGLIST (NOTE: POINTS 1 BEFORE WHERE ARG IS) + JUMPE C,CPOPJ ; LEAVE IF DONE + MOVEM C,E.FRM+1(TB) + GETYP 0,(C) ; GET TYPE OF ARG + CAIN 0,TSEG + JRST ARGCD1 ; SEG MENT HACK + PUSHJ P,FASTEV + JRST CPOPJ1 + +ARGCD1: PUSH TP,$TFORM ; PRETEND WE ARE A FORM + PUSH TP,1(C) + MCALL 1,EVAL + MOVEM A,E.SEG(TB) + MOVEM B,E.SEG+1(TB) + PUSHJ P,TYPSEG ; GET SEG TYPE CODE + HRRM C,E.ARG(TB) ; SAVE IT IN OBSCCURE PLACE + MOVE C,[SETZ SGARG] + MOVEM C,E.ARG+1(TB) ; SET NEW ARG GETTER + +; FALL INTO SEGARG + +SGARG: INTGO + HRRZ C,E.ARG(TB) ; SEG CODE TO C + MOVE D,E.SEG+1(TB) + MOVE A,E.SEG(TB) + MOVEM A,DSTO(PVP) + PUSHJ P,NXTLM ; GET NEXT ELEMENT + JRST SEGRG1 ; DONE + MOVEM D,E.SEG+1(TB) + MOVE D,DSTO(PVP) ; KEEP TYPE WINNING + MOVEM D,E.SEG(TB) + SETZM DSTO(PVP) + JRST CPOPJ1 ; RETURN + +SEGRG1: SETZM DSTO(PVP) + MOVEI C,ARGCDR + MOVEM C,E.ARG+1(TB) ; RESET ARG GETTER + JRST ARGCDR + +; ARGUMENT GETTER FOR APPLY + +APLARG: INTGO + SKIPL A,E.FRM+1(TB) ; ANY ARGS LEFT + POPJ P, ; NO, EXIT IMMEDIATELY + ADD A,[2,,2] + MOVEM A,E.FRM+1(TB) + MOVE B,-1(A) ; RET NEXT ARG + MOVE A,-2(A) + JRST CPOPJ1 + +; STACKFORM ARG GETTER + +EVALRG: SKIPN C,@E.FRM+1(TB) ; ANY FORM? + POPJ P, + PUSHJ P,FASTEV + GETYP A,A ; CHECK FOR FALSE + CAIN A,TFALSE + POPJ P, + MOVE C,E.FRM+1(TB) ; GET OTHER FORM + PUSHJ P,FASTEV + JRST CPOPJ1 + + +; HERE TOO APPLY NUMBERS + +APNUM: PUSHJ P,PSH4ZR ; TP SLOSTS + SKIPN A,E.EXTR(TB) ; FUNNY ARG? + JRST APNUM1 ; NOPE + MOVE B,E.EXTR+1(TB) ; GET ARG + JRST APNUM2 + +APNUM1: PUSHJ P,@E.ARG+1(TB) ; GET ARG + JRST TFA +APNUM2: PUSH TP,A + PUSH TP,B + PUSH TP,E.FCN(TB) + PUSH TP,E.FCN+1(TB) + PUSHJ P,@E.ARG+1(TB) + JRST .+2 + JRST TMA + PUSHJ P,BLTDN ; FLUSH JUNK + MCALL 2,NTH + POPJ P, + +; HERE TO APPLY SUSSMAN FUNARGS + +APFUNARG: + + SKIPN C,E.FCN+1(TB) + JRST FUNERR + HRRZ D,(C) ; MUST BE AT LEAST 2 LONG + JUMPE D,FUNERR + GETYP 0,(D) ; CHECK FOR LIST + CAIE 0,TLIST + JRST FUNERR + HRRZ 0,(D) ; SHOULD BE END + JUMPN 0,FUNERR + GETYP 0,(C) ; 1ST MUST BE FCN + CAIE 0,TEXPR + JRST FUNERR + SKIPN C,1(C) + JRST NOBODY + PUSHJ P,APEXPF ; BIND THE ARGS AND AUX'S + HRRZ C,RE.FCN+1(TB) ; GET BODY OF FUNARG + MOVE B,1(C) ; GET FCN + MOVEM B,RE.FCN+1(TB) ; AND SAVE + HRRZ C,(C) ; CDR FUNARG BODY + MOVE C,1(C) + MOVSI 0,TLIST ; SET UP TYPE + MOVEM 0,CSTO(PVP) ; FOR INTS TO WIN + +FUNLP: INTGO + JUMPE C,DOF ; RUN IT + GETYP 0,(C) + CAIE 0,TLIST ; BETTER BE LIST + JRST FUNERR + PUSH TP,$TLIST + PUSH TP,C + PUSHJ P,NEXTDC ; GET POSSIBILITY + JRST FUNERR ; LOSER + CAIE A,2 + JRST FUNERR + HRRZ B,(B) ; GET TO VALUE + MOVE C,(TP) + SUB TP,[2,,2] + PUSH TP,BNDA + PUSH TP,E + HLLZ A,(B) ; GET VAL + MOVE B,1(B) + JSP E,CHKAB ; HACK DEFER + PUSHJ P,PSHAB4 ; PUT VAL IN + HRRZ C,(C) ; CDR + JUMPN C,FUNLP + +; HERE TO RUN FUNARG + +DOF: SETZM CSTO(PVP) ; DONT CONFUSE GC + PUSHJ P,SPECBIND ; BIND 'EM UP + JRST RUNFUN + + + +; HERE TO DO MACROS + +APMACR: HRRZ E,OTBSAV(TB) + HRRZ E,PCSAV(E) ; SEE WHERE FROM + CAIN E,AEVAL3 ; SKIP IF NOT RIGHT + JRST APMAC1 + SKIPG E.ARG+1(TB) ; SKIP IF REAL FORM EXISTS + JRST BADMAC + MOVE A,E.FRM(TB) + MOVE B,E.FRM+1(TB) + SUB TP,[E.EXTR+2,,E.EXTR+2] ; FLUSH JUNK + PUSH TP,A + PUSH TP,B + MCALL 1,EXPAND ; EXPAND THE MACRO + PUSH TP,A + PUSH TP,B + MCALL 1,EVAL ; EVAL THE RESULT + POPJ P, + +APMAC1: MOVE C,E.FCN+1(TB) ; GET MACRO BODY + GETYP A,(C) + MOVE B,1(C) + MOVSI A,(A) + JSP E,CHKAB ; FIX DEFERS + MOVEM A,E.FCN(TB) + MOVEM B,E.FCN+1(TB) + JRST APLDIX + +; HERE TO APPLY EXPRS (FUNCTIONS) + +APEXPR: PUSHJ P,APEXP ; BIND ARGS AND AUX'S +RUNFUN: HRRZ A,RE.FCN(TB) ; AMOUNT OF FCN TO SKIP + MOVEI C,RE.FCN+1(TB) ; POINT TO FCN + HRRZ C,(C) ; SKIP SOMETHING + SOJGE A,.-1 ; UNTIL 1ST FORM + MOVEM C,RE.FCN+1(TB) ; AND STORE + JRST DOPROG ; GO RUN PROGRAM + +APEXP: SKIPN C,E.FCN+1(TB) ; CHECK FRO BODY + JRST NOBODY +APEXPF: PUSH P,[0] ; COUNT INIT CRAP + ADD TP,[XP.TMP,,XP.TMP] ; SLOTS FOR HACKING + SKIPL TP + PUSHJ P,TPOVFL + SETZM 1-XP.TMP(TP) ; ZERO OUT + MOVEI A,-XP.TMP+2(TP) + HRLI A,-1(A) + BLT A,(TP) ; ZERO SLOTS + PUSHJ P,CARATC ; SEE IF HEWITT ATOM EXISTS + JRST APEXP1 ; NO, GO LOOK FOR ARGLIST + MOVEM E,E.HEW+1(TB) ; SAVE ATOM + MOVSM 0,E.HEW(TB) ; AND TYPE + AOS (P) ; COUNT HEWITT ATOM +APEXP1: GETYP 0,(C) ; LOOK AT NEXT THING + CAIE 0,TLIST ; BETTER BE LIST!!! + JRST MPD.0 ; LOSE + MOVE B,1(C) ; GET LIST + MOVEM B,E.ARGL+1(TB) ; SAVE + MOVSM 0,E.ARGL(TB) ; WITH TYPE + HRRZ C,(C) ; CDR THE FCN + JUMPE C,NOBODY ; BODYLESS FCN + GETYP 0,(C) ; SEE IF DCL LIST SUPPLIED + CAIE 0,TDECL + JRST APEXP2 ; NO, START PROCESSING ARGS + AOS (P) ; COUNT DCL + MOVE B,1(C) + MOVEM B,E.DECL+1(TB) + MOVSM 0,E.DECL(TB) + HRRZ C,(C) ; CDR ON + JUMPE C,NOBODY + + ; CHECK FOR EXISTANCE OF EXTRA ARG + +APEXP2: POP P,A ; GET COUNT + HRRM A,E.FCN(TB) ; AND SAVE + SKIPN E.EXTR(TB) ; SKIP IF FUNNY EXTRA ARG EXISTS + JRST APEXP3 + MOVE 0,[SETZ EXTRGT] + EXCH 0,E.ARG+1(TB) + HRRM 0,E.ARG(TB) ; SAVE OLD GETTER AROUND + +; FALL THROUGH + +; LOOK FOR "BIND" DECLARATION + +APEXP3: PUSHJ P,UNPROG ; UNASSIGN LPROG IF NEC +APXP3A: SKIPN A,E.ARGL+1(TB) ; GET ARGLIST + JRST APEXP4 ; NONE, VERIFY NONE WERE GIVEN + PUSHJ P,NXTDCL ; SEE IF A DECL IS THERE + JRST BNDRG ; NO, GO BIND NORMAL ARGS + HRRZ C,(A) ; CDR THE DCLS + CAME B,[ASCII /BIND/] + JRST CH.CAL ; GO LOOK FOR "CALL" + PUSHJ P,CARTMC ; MUST BE AN ATOM + MOVEM C,E.ARGL+1(TB) ; AND SAVE CDR'D ARGS + PUSHJ P,MAKENV ; GENERATE AN ENVIRONMENT + PUSHJ P,PSBND1 ; PUSH THE BINDING AND CHECK THE DCL + JRST APXP3A ; IN CASE <"BIND" B "BIND" C...... + + +; LOOK FOR "CALL" DCL + +CH.CAL: CAME B,[ASCII /CALL/] + JRST CHOPT ; TRY SOMETHING ELSE + SKIPG E.ARG+1(TB) ; DONT SKIP IF CANT WIN + JRST MPD.2 + PUSHJ P,CARTMC ; BETTER BE AN ATOM + MOVEM C,E.ARGL+1(TB) + MOVE A,E.FRM(TB) ; RETURN FORM + MOVE B,E.FRM+1(TB) + PUSHJ P,PSBND1 ; BIND AND CHECK + JRST APEXP5 + +; BIND NORMAL ARGS BY CALLING BNDEM1, RETURNS WHEN ALL DONE + +BNDRG: PUSHJ P,BNDEM1 ; GO BIND THEM UP + TRNN A,4 ; SKIP IF HIT A DCL + JRST APEXP4 ; NOT A DCL, MUST BE DONE + +; LOOK FOR "OPTIONAL" DECLARATION + +CHOPT: CAME B,[+1] + JRST CHREST ; TRY TUPLE/ARGS + MOVEM C,E.ARGL+1(TB) ; SAVE RESTED ARGLIST + PUSHJ P,BNDEM2 ; DO ALL SUPPLIED OPTIONALS + TRNN A,4 ; SKIP IF NEW DCL READ + JRST APEXP4 + +; CHECK FOR "ARGS" DCL + +CHREST: CAME B,[ASCII /ARGS/] + JRST CHRST1 ; GO LOOK FOR "TUPLE" + SKIPGE E.ARG+1(TB) ; SKIP IF LEGAL + JRST MPD.3 + PUSHJ P,CARTMC ; GOBBLE ATOM + MOVEM C,E.ARGL+1(TB) ; SAVE CDR'D ARG + HRRZ B,@E.FRM+1(TB) ; GET ARG LIST + MOVSI A,TLIST ; GET TYPE + PUSHJ P,PSBND1 + JRST APEXP5 + +; HERE TO CHECK FOR "TUPLE" + +CHRST1: CAME B,[ASCII /TUPLE/] + JRST APXP10 + PUSHJ P,CARTMC ; GOBBLE ATOM + MOVEM C,E.ARGL+1(TB) + SETZB A,B + PUSHJ P,PSHBND ; SET UP BINDING + SETZM E.CNT+1(TB) ; ZERO ARG COUNTER + +TUPLP: PUSHJ P,@E.ARG+1(TB) ; GET AN ARG + JRST TUPDON ; FINIS + AOS E.CNT+1(TB) + PUSH TP,A + PUSH TP,B + JRST TUPLP + +TUPDON: PUSHJ P,MAKINF ; MAKE INFO CELL + PUSH TP,$TINFO ; FENCE POST TUPLE + PUSHJ P,TBTOTP + ADDI D,TM.OFF ; COMPENSATE FOR MOVEMENT + PUSH TP,D + MOVE C,E.CNT+1(TB) ; GET COUNT + ASH C,1 ; TO WORDS + HRRM C,-1(TP) ; INTO FENCE POST + MOVEI B,-TM.OFF-1(TP) ; SETUP ARG POINTER + SUBI B,(C) ; POINT TO BASE OF TUPLE + MOVNS C ; FOR AOBJN POINTER + HRLI B,(C) ; GOOD ARGS POINTER + MOVEM A,TM.OFF-4(B) ; STORE + MOVEM B,TM.OFF-3(B) + + +; CHECK FOR VALID ENDING TO ARGS + +APEXP5: PUSHJ P,NEXTD ; READ NEXT THING IN ARGLIST + JRST APEXP8 ; DONE + TRNN A,4 ; SKIP IF DCL + JRST MPD.4 ; LOSER +APEXP7: MOVSI A,-NWINS ; CHECK FOR A WINNER + CAME B,WINRS(A) + AOBJN A,.-1 + JUMPE A,MPD.6 ; NOT A WINNER + +; HERE TO BLT THE WORLD DOWN ON TOP OF ALL THE USELESS TEMPS + +APEXP8: MOVE 0,E.HEW+1(TB) ; GET HEWITT ATOM + MOVE E,E.FCN(TB) ; SAVE COUNTER + MOVE C,E.FCN+1(TB) ; FCN + MOVE B,E.ARGL+1(TB) ; ARG LIST + MOVE D,E.DECL+1(TB) ; AND DCLS + MOVEI A,R.TMP(TB) ; SET UP BLT + HRLI A,TM.OFF(A) + BLT A,-TM.OFF(TP) ; BLLLLLLLLLLLLLT + SUB TP,[TM.OFF,,TM.OFF] ; FLUSH CRUFT + MOVEM E,RE.FCN(TB) + MOVEM C,RE.FCN+1(TB) + MOVEM B,RE.ARGL+1(TB) + MOVE E,TP + PUSH TP,$TATOM + PUSH TP,0 + PUSH TP,$TDECL + PUSH TP,D + GETYP A,-5(TP) ; TUPLE ON TOP? + CAIE A,TINFO ; SKIP IF YES + JRST APEXP9 + HRRZ A,-5(TP) ; GET SIZE + ADDI A,2 + HRLI A,(A) + SUB E,A ; POINT TO BINDINGS + SKIPE C,(TP) ; IF DCL + PUSHJ P,CHKDCL ; CHECK TYPE SPEC ON TUPLE +APEXP9: PUSHJ P,USPCBE ; DO ACTUAL BINDING + + MOVE E,-2(TP) ; RESTORE HEWITT ATOM + MOVE D,(TP) ; AND DCLS + SUB TP,[4,,4] + + JRST AUXBND ; GO BIND AUX'S + +; HERE TO VERIFY CHECK IF ANY ARGS LEFT + +APEXP4: PUSHJ P,@E.ARG+1(TB) + JRST APEXP8 ; WIN + JRST TMA ; TOO MANY ARGS + +APXP10: PUSH P,B + PUSHJ P,@E.ARG+1(TB) + JRST .+2 + JRST TMA + POP P,B + JRST APEXP7 + +; LIST OF POSSIBLE TERMINATING NAMES + +WINRS: +AS.ACT: ASCII /ACT/ +AS.NAM: ASCII /NAME/ +AS.AUX: ASCII /AUX/ +AS.EXT: ASCII /EXTRA/ +NWINS==.-WINRS + + +; HERE TO BIND AUX VARIABLES FOR PROGS AND FCNS + +AUXBND: PUSH P,E ; SAVE HEWITT ATOM ( WILL PUT ON MARKED STACK + ; WHEN NECESSARY) + PUSH P,D ; SAME WITH DCL LIST + PUSH P,[-1] ; FLAG SAYING WE ARE FCN + SKIPN C,RE.ARG+1(TB) ; GET ARG LIST + JRST AUXDON + GETYP 0,(C) ; GET TYPE + CAIE 0,TDEFER ; SKIP IF CHSTR + MOVMS (P) ; SAY WE ARE IN OPTIONALS + JRST AUXB1 + +PRGBND: PUSH P,E + PUSH P,D + PUSH P,[0] ; WE ARE IN AUXS + +AUXB1: HRRZ C,RE.ARG+1(TB) ; POINT TO ARGLIST + PUSHJ P,NEXTDC ; GET NEXT THING OFF OF ARG LIST + JRST AUXDON + TRNE A,4 ; SKIP IF SOME KIND OF ATOM + JRST TRYDCL ; COUDL BE DCL + TRNN A,1 ; SKIP IF QUOTED + JRST AUXB2 + SKIPN (P) ; SKIP IF QUOTED OK + JRST MPD.11 +AUXB2: PUSHJ P,PSHBND ; SET UP BINDING + PUSH TP,$TDECL ; SAVE HEWITT ATOM + PUSH TP,-1(P) + PUSH TP,$TATOM ; AND DECLS + PUSH TP,-2(P) + + TRNN A,2 ; SKIP IF INIT VAL EXISTS + JRST AUXB3 ; NO, USE UNBOUND + +; EVALUATE EXPRESSION + + HRRZ C,(B) ; CDR ATOM OFF + +; CHECK FOR SPECIAL FORMS + + GETYP 0,(C) ; GET TYPE OF GOODIE + CAIE 0,TFORM ; SMELLS LIKE A FORM + JRST AUXB13 + HRRZ D,1(C) ; GET 1ST ELEMENT + GETYP 0,(D) ; AND ITS VAL + CAIE 0,TATOM ; FEELS LIKE THE RIGHT FORM + JRST AUXB13 + + MOVE 0,1(D) ; GET THE ATOM + CAME 0,MQUOTE TUPLE + CAMN 0,MQUOTE ITUPLE + JRST DOTUPL ; SURE GLAD I DIDN'T STEP IN THAT FORM + + +AUXB13: PUSHJ P,FASTEV +AUXB14: MOVE E,TP +AUXB4: MOVEM A,-7(E) ; STORE VAL IN BINDING + MOVEM B,-6(E) + +; HERE TO CHECK AGAINST DECLARATIONS AND COMPLETE THE BINDING + +AUXB5: SUB E,[4,,4] ; POINT TO BINDING TOP + SKIPE C,-2(TP) ; POINT TO DECLARATINS + PUSHJ P,CHKDCL ; CHECK IT + PUSHJ P,USPCBE ; AND BIND UP + SKIPE C,RE.ARG+1(TB) ; CDR DCLS + HRRZ C,(C) ; IF ANY TO CDR + MOVEM C,RE.ARG+1(TB) + MOVE A,(TP) ; NOW PUT HEWITT ATOM AND DCL AWAY + MOVEM A,-2(P) + MOVE A,-2(TP) + MOVEM A,-1(P) + SUB TP,[4,,4] ; FLUSH SLOTS + JRST AUXB1 + + +AUXB3: MOVNI B,1 + MOVSI A,TUNBOU + JRST AUXB14 + + + +; HERE TO HANDLE "CALLS" TO TUPLE AND ITUPLE + +DOTUPL: PUSH TP,$TLIST ; SAVE THE MAGIC FORM + PUSH TP,D + CAME 0,MQUOTE TUPLE + JRST DOITUP ; DO AN ITUPLE + +; FALL INTO A TUPLE PUSHING LOOP + +DOTUP1: HRRZ C,@(TP) ; CDR THE FORM + JUMPE C,ATUPDN ; FINISHED + MOVEM C,(TP) ; SAVE CDR'D RESULT + GETYP 0,(C) ; CHECK FOR SEGMENT + CAIN 0,TSEG + JRST DTPSEG ; GO PULL IT APART + PUSHJ P,FASTEV ; EVAL IT + PUSHJ P,CNTARG ; PUSH IT UP AND COUNT THEM + JRST DOTUP1 + +; HERE WHEN WE FINISH + +ATUPDN: SUB TP,[2,,2] ; FLUSH THE LIST + ASH E,1 ; E HAS # OF ARGS DOUBLE IT + MOVEI D,(TP) ; FIND BASE OF STACK AREA + SUBI D,(E) + MOVSI C,-3(D) ; PREPARE BLT POINTER + BLT C,C ; HEWITT ATOM AND DECL TO 0,A,B,C + +; NOW PREPEARE TO BLT TUPLE DOWN + + MOVEI D,-3(D) ; NEW DEST + HRLI D,4(D) ; SOURCE + BLT D,-4(TP) ; SLURP THEM DOWN + + HRLI E,TINFO ; SET UP FENCE POST + MOVEM E,-3(TP) ; AND STORE + PUSHJ P,TBTOTP ; GET OFFSET + ADDI D,3 ; FUDGE FOR NOT AT TOP OF STACK + MOVEM D,-2(TP) + MOVEM 0,-1(TP) ; RESTORE HEW ATOM AND DECLS + MOVEM A,(TP) + PUSH TP,B + PUSH TP,C + + PUSHJ P,MAKINF ; MAKE 1ST WORD OF FUNNYS + + HRRZ E,-5(TP) ; RESTORE WORDS OF TUPLE + HRROI B,-5(TP) ; POINT TO TOP OF TUPLE + SUBI B,(E) ; NOW BASE + TLC B,-1(E) ; FIX UP AOBJN PNTR + ADDI E,2 ; COPNESATE FOR FENCE PST + HRLI E,(E) + SUBM TP,E ; E POINT TO BINDING + JRST AUXB4 ; GO CLOBBER IT IN + + +; HERE TO HANDLE SEGMENTS IN THESE FUNNY FORMS + +DTPSEG: PUSH TP,$TFORM ; SAVE THE HACKER + PUSH TP,1(C) + MCALL 1,EVAL ; AND EVALUATE IT + MOVE D,B ; GET READY FOR A SEG LOOP + MOVEM A,DSTO(PVP) + PUSHJ P,TYPSEG ; TYPE AND CHECK IT + +DTPSG1: INTGO ; DONT BLOW YOUR STACK + PUSHJ P,NXTLM ; ELEMENT TO A AND B + JRST DTPSG2 ; DONE + PUSHJ P,CNTARG ; PUSH AND COUNT + JRST DTPSG1 + +DTPSG2: SETZM DSTO(PVP) + JRST DOTUP1 ; REST OF ARGS STILL TO DO + +; HERE TO HACK + +DOITUP: HRRZ C,@(TP) ; GET COUNT FILED + JUMPE C,TUPTFA + MOVEM C,(TP) + PUSHJ P,FASTEV ; EVAL IT + GETYP 0,A + CAIE 0,TFIX + JRST WTY1TP + + JUMPL B,BADNUM + + HRRZ C,@(TP) ; GET EXP TO EVAL + MOVEI 0,0 ; DONT LOSE IN 1 ARG CASE + HRRZ 0,(C) ; VERIFY WINNAGE + JUMPN 0,TUPTMA ; TOO MANY + + JUMPE B,DOIDON + PUSH P,B ; SAVE COUNT + PUSH P,B + JUMPE C,DOILOS + PUSHJ P,FASTEV ; EVAL IT ONCE + MOVEM A,-1(TP) + MOVEM B,(TP) + +DOILP: INTGO + PUSH TP,-1(TP) + PUSH TP,-1(TP) + MCALL 1,EVAL + PUSHJ P,CNTRG + SOSLE (P) + JRST DOILP + +DOIDO1: MOVE B,-1(P) ; RESTORE COUNT + SUB P,[2,,2] + +DOIDON: MOVEI E,(B) + JRST ATUPDN + +; FOR CASE OF NO EVALE + +DOILOS: SUB TP,[2,,2] +DOILLP: INTGO + PUSH TP,[0] + PUSH TP,[0] + SOSL (P) + JRST DOILLP + JRST DOIDO1 + +; ROUTINE TO PUSH NEXT TUPLE ELEMENT + +CNTARG: AOS E,-1(TP) ; KEEP ARG COUNT UP TO DATE IN E +CNTRG: EXCH A,-1(TP) ; STORE ELEM AND GET SAVED + EXCH B,(TP) + PUSH TP,A + PUSH TP,B + POPJ P, + + +; DUMMY TUPLE AND ITUPLE + +MFUNCTION TUPLE,SUBR + + ENTRY + PUSH TP,$TATOM + PUSH TP,EQUOTE NOT-IN-ARG-LIST + JRST CALER1 + +MFUNCTIO ITUPLE,SUBR + JRST TUPLE + + +; PROCESS A DCL IN THE AUX VAR LISTS + +TRYDCL: SKIPN (P) ; SKIP IF NOT IN AUX'S + JRST AUXB7 + CAME B,AS.AUX ; "AUX" ? + CAMN B,AS.EXT ; OR "EXTRA" + JRST AUXB9 ; YES + CAME B,[ASCII /TUPLE/] + JRST AUXB10 + PUSHJ P,MAKINF ; BUILD EMPTY TUPLE + MOVEI B,1(TP) + PUSH TP,$TINFO ; FENCE POST + PUSHJ P,TBTOTP + PUSH TP,D +AUXB6: HRRZ C,(C) ; CDR PAST DCL + MOVEM C,RE.ARG+1(TB) +AUXB8: PUSHJ P,CARTMC ; GET ATOM +AUXB12: PUSHJ P,PSHBND ; UP GOES THE BINDING + PUSH TP,$TATOM ; HIDE HEWITT ATOM AND DCL + PUSH TP,-1(P) + PUSH TP,$TDECL + PUSH TP,-2(P) + MOVE E,TP + JRST AUXB5 + +; CHECK FOR ARGS + +AUXB10: CAME B,[ASCII /ARGS/] + JRST AUXB7 + MOVEI B,0 ; NULL ARG LIST + MOVSI A,TLIST + JRST AUXB6 ; GO BIND + +AUXB9: SETZM (P) ; NOW READING AUX + HRRZ C,(C) + MOVEM C,RE.ARG+1(TB) + JRST AUXB1 + +; CHECK FOR NAME/ACT + +AUXB7: CAME B,AS.NAM + CAMN B,AS.ACT + JRST .+2 + JRST MPD.12 ; LOSER + HRRZ C,(C) ; CDR ON + HRRZ 0,(C) ; BETTER BE END + JUMPN 0,MPD.13 + PUSHJ P,CARTMC ; FORCE ATOM READ + SETZM RE.ARG+1(TB) +AUXB11: PUSHJ P,MAKACT ; MAKE ACTIVATION + JRST AUXB12 ; AND BIND IT + + +; DONE BIND HEWITT ATOM IF NECESARY + +AUXDON: SKIPN E,-2(P) + JRST AUXD1 + SETZM -2(P) + JRST AUXB11 + +; FINISHED, RETURN + +AUXD1: SUB P,[3,,3] + POPJ P, + + +; MAKE AN ACTIVATION OR ENVIRONMNENT + +MAKACT: MOVEI B,(TB) + MOVSI A,TACT +MAKAC1: HRRI A,PVLNT*2+1(PVP) ; POINT TO PROCESS + HLL B,OTBSAV(B) ; GET TIME + POPJ P, + +MAKENV: MOVSI A,TENV + HRRZ B,OTBSAV(TB) + JRST MAKAC1 + +; SEVERAL USEFUL LITTLE ROUTINES FOR HACKING THIS STUFF + +; CARAT/CARATC/CARATM/CARTMC ALL LOOK FOR THE NEXT ATOM + +CARAT: HRRZ C,E.ARGL+1(TB) ; PICK UP ARGLIST +CARATC: JUMPE C,CPOPJ ; FOUND + GETYP 0,(C) ; GET ITS TYPE + CAIE 0,TATOM +CPOPJ: POPJ P, ; RETURN, NOT ATOM + MOVE E,1(C) ; GET ATOM + HRRZ C,(C) ; CDR DCLS + JRST CPOPJ1 + +CARATM: HRRZ C,E.ARGL+1(TB) +CARTMC: PUSHJ P,CARATC + JRST MPD.7 ; REALLY LOSE + POPJ P, + + +; SUBROUTINES TO PUSH BINDINGS ETC. UP ON THE STACK + +PSBND1: PUSHJ P,PSHBND ; PUSH THEBINDING + JRST CHDCL ; NOW CHECK IT AGAINST DECLARATION + +PSHBND: SKIPGE SPCCHK ; SKIP IF NORMAL SPECIAL + PUSH TP,BNDA1 ; ATOM IN E + SKIPL SPCCHK ; SKIP IF NORMAL UNSPEC OR NO CHECK + PUSH TP,BNDA + PUSH TP,E ; PUSH IT +PSHAB4: PUSH TP,A + PUSH TP,B + PUSH TP,[0] + PUSH TP,[0] + POPJ P, + +; ROUTINE TO PUSH 4 0'S + +PSH4ZR: SETZB A,B + JRST PSHAB4 + + +; EXTRRA ARG GOBBLER + +EXTRGT: HRRZ A,E.ARG(TB) ; RESET SLOT + CAIE A,ARGCDR ; IF NOT ARGCDR + TLO A,400000 ; SET FLAG + MOVEM A,E.ARG+1(TB) + MOVE A,E.EXTR(TB) ; RET ARG + MOVE B,E.EXTR+1(TB) + JRST CPOPJ1 + +; CHECK A/B FOR DEFER + +CHKAB: GETYP 0,A + CAIE 0,TDEFER ; SKIP IF DEFER + JRST (E) + MOVE A,(B) + MOVE B,1(B) ; GET REAL THING + JRST (E) +; IF DECLARATIONS EXIST, DO THEM + +CHDCL: MOVE E,TP +CHDCLE: SKIPN C,E.DECL+1(TB) + POPJ P, + JRST CHKDCL + +; ROUTINE TO READ NEXT THING FROM ARGLIST + +NEXTD: HRRZ C,E.ARGL+1(TB) ; GET ARG LIST +NEXTDC: JUMPE C,CPOPJ + PUSHJ P,CARATC ; TRY FOR AN ATOM + JRST NEXTD1 ; NO + MOVEI A,0 ; SET FLAG + JRST CPOPJ1 + +NEXTD1: CAIE 0,TFORM ; FORM? + JRST NXT.L ; COULD BE LIST + PUSHJ P,CHQT ; VERIFY 'ATOM + MOVEI A,1 + JRST CPOPJ1 + +NXT.L: CAIE 0,TLIST ; COULD BE (A ) OR ('A ) + JRST NXT.S ; BETTER BE A DCL + PUSHJ P,LNT.2 ; VERIFY LENGTH IS 2 + JRST MPD.8 + CAIE 0,TATOM ; TYPE OF 1ST RET IN 0 + JRST LST.QT ; MAY BE 'ATOM + MOVE E,1(B) ; GET ATOM + MOVEI A,2 + JRST CPOPJ1 +LST.QT: CAIE 0,TFORM ; FORM? + JRST MPD.9 ; LOSE + PUSH P,C + MOVEI C,(B) ; VERIFY 'ATOM + PUSHJ P,CHQT + MOVEI B,(C) ; POINT BACK TO LIST + POP P,C + MOVEI A,3 ; CODE + JRST CPOPJ1 + +NXT.S: MOVEI A,(C) ; LET NXTDCL FIND OUT + PUSHJ P,NXTDCL + JRST MPD.3 ; LOSER + MOVEI A,4 ; SET DCL READ FLAG + JRST CPOPJ1 + +; ROUTINE TO CHECK LENGTH OF LIST/FORM FOR BEING 2 + +LNT.2: HRRZ B,1(C) ; GET LIST/FORM + JUMPE B,CPOPJ + HRRZ B,(B) + JUMPE B,CPOPJ + HRRZ B,(B) ; BETTER END HERE + JUMPN B,CPOPJ + HRRZ B,1(C) ; LIST BACK + GETYP 0,(B) ; TYPE OF 1ST ELEMENT + JRST CPOPJ1 + +; ROUTINE TO VERIFY FORM IS 'ATOM AND RET ATOM + +CHQT: PUSHJ P,LNT.2 ; 1ST LENGTH CHECK + JRST MPD.5 + CAIE 0,TATOM + JRST MPD.5 + MOVE 0,1(B) + CAME 0,MQUOTE QUOTE + JRST MPD.5 ; BETTER BE QUOTE + HRRZ E,(B) ; CDR + GETYP 0,(E) ; TYPE + CAIE 0,TATOM + JRST MPD.5 + MOVE E,1(E) ; GET QUOTED ATOM + POPJ P, + +; ARG BINDER FOR REGULAR ARGS AND OPTIONALS + +BNDEM1: PUSH P,[0] ; REGULAR FLAG + JRST .+2 +BNDEM2: PUSH P,[1] +BNDEM: PUSHJ P,NEXTD ; GET NEXT THING + JRST CCPOPJ ; END OF THINGS + TRNE A,4 ; CHECK FOR DCL + JRST BNDEM4 + TRNE A,2 ; SKIP IF NOT (ATM ..) OR ('ATM ...) + SKIPE (P) ; SKIP IF REG ARGS + JRST .+2 ; WINNER, GO ON + JRST MPD.6 ; LOSER + SKIPGE SPCCHK + PUSH TP,BNDA1 ; SAVE ATOM + SKIPL SPCCHK + PUSH TP,BNDA + PUSH TP,E + SKIPL E.ARG+1(TB) ; SKIP IF MUST EVAL ARG + TRNN A,1 ; SKIP IF ARG QUOTED + JRST RGLARG + HRRZ D,@E.FRM+1(TB) ; GET AND CDR ARG + JUMPE D,TFACHK ; OH OH MAYBE TOO FEW ARGS + MOVEM D,E.FRM+1(TB) ; STORE WINNER + HLLZ A,(D) ; GET ARG + MOVE B,1(D) + JSP E,CHKAB ; HACK DEFER + JRST BNDEM3 ; AND GO ON + +RGLARG: PUSH P,A ; SAVE FLAGS + PUSHJ P,@E.ARG+1(TB) + JRST TFACH1 ; MAY GE TOO FEW + SUB P,[1,,1] +BNDEM3: HRRZ C,@E.ARGL+1(TB) ; CDR THHE ARGS + MOVEM C,E.ARGL+1(TB) + PUSHJ P,PSHAB4 ; PUSH VALUE AND SLOTS + PUSHJ P,CHDCL ; CHECK DCLS + JRST BNDEM ; AND BIND ON! + +; HERE WHEN ARGS RUN OUT, IF NOT OPTIONAL, GIVE TFA + +TFACH1: POP P,A +TFACHK: SUB TP,[2,,2] ; FLUSH ATOM + SKIPN (P) ; SKIP IF OPTIONALS + JRST TFA +CCPOPJ: SUB P,[1,,1] + POPJ P, + +BNDEM4: HRRZ C,@E.ARGL+1(TB) ; POINT TO REST OF ARGL + JRST CCPOPJ + + +; EVALUATE LISTS, VECTORS, UNIFROM VECTORS + +EVLIST: PUSH P,[-1] ;-1 -- THIS IS A LIST + JRST EVL1 ;GO TO HACKER + +EVECT: PUSH P,[0] ;0 -- THIS IS A GENERAL VECTOR + JRST EVL1 + +EUVEC: PUSH P,[1] ;1 -- THIS IS A UNIFORM VECTOR + +EVL1: PUSH P,[0] ;PUSH A COUNTER + GETYPF A,(AB) ;GET FULL TYPE + PUSH TP,A + PUSH TP,1(AB) ;AND VALUE + +EVL2: INTGO ;CHECK INTERRUPTS + SKIPN A,1(TB) ;ANYMORE + JRST EVL3 ;NO, QUIT + SKIPL -1(P) ;SKIP IF LIST + JUMPG A,EVL3 ;JUMP IF VECTOR EMPTY + GETYPF B,(A) ;GET FULL TYPE + SKIPGE C,-1(P) ;SKIP IF NOT LIST + HLLZS B ;CLOBBER CDR FIELD + JUMPG C,EVL7 ;HACK UNIFORM VECS +EVL8: PUSH P,B ;SAVE TYPE WORD ON P + CAMN B,$TSEG ;SEGMENT? + MOVSI B,TFORM ;FAKE OUT EVAL + PUSH TP,B ;PUSH TYPE + PUSH TP,1(A) ;AND VALUE + JSP E,CHKARG ; CHECK DEFER + MCALL 1,EVAL ;AND EVAL IT + POP P,C ;AND RESTORE REAL TYPE + CAMN C,$TSEG ;SEGMENT? + JRST DOSEG ;YES, HACK IT + AOS (P) ;COUNT ELEMENT + PUSH TP,A ;AND PUSH IT + PUSH TP,B +EVL6: SKIPGE A,-1(P) ;DONT SKIP IF LIST + HRRZ B,@1(TB) ;CDR IT + JUMPL A,ASTOTB ;AND STORE IT + MOVE B,1(TB) ;GET VECTOR POINTER + ADD B,AMNT(A) ;INCR BY APPROPRIATE AMOUNT +ASTOTB: MOVEM B,1(TB) ;AND STORE BACK + JRST EVL2 ;AND LOOP BACK + +AMNT: 2,,2 ;INCR FOR GENERAL VECTOR + 1,,1 ;SAME FOR UNIFORM VECTOR + +CHKARG: GETYP A,-1(TP) + CAIE A,TDEFER + JRST (E) + HRRZS (TP) ;MAKE SURE INDIRECT WINS + MOVE A,@(TP) + MOVEM A,-1(TP) ;CLOBBER IN TYPE SLOT + MOVE A,(TP) ;NOW GET POINTER + MOVE A,1(A) ;GET VALUE + MOVEM A,(TP) ;CLOBBER IN + JRST (E) + + + +EVL7: HLRE C,A ; FIND TYPE OF UVECTOR + SUBM A,C ;C POINTS TO DOPE WORD + GETYP B,(C) ;GET TYPE + MOVSI B,(B) ;TO LH NOW + SOJA A,EVL8 ;AND RETURN TO DO EVAL + +EVL3: SKIPL -1(P) ;SKIP IF LIST + JRST EVL4 ;EITHER VECTOR OR UVECTOR + + MOVEI B,0 ;GET A NIL +EVL9: MOVSI A,TLIST ;MAKE TYPE WIN +EVL5: SOSGE (P) ;COUNT DOWN + JRST EVL10 ;DONE, RETURN + PUSH TP,$TLIST ;SET TO CALL CONS + PUSH TP,B + MCALL 2,CONS + JRST EVL5 ;LOOP TIL DONE + + +EVL4: MOVEI B,EUVECT ;UNIFORM CASE + SKIPG -1(P) ;SKIP IF UNIFORM CASE + MOVEI B,EVECTO ;NO, GENERAL CASE + POP P,A ;GET COUNT + .ACALL A,(B) ;CALL CREATOR +EVL10: GETYPF A,(AB) ; USE SENT TYPE + JRST EFINIS + + +; PROCESS SEGMENTS FOR THESE HACKS + +DOSEG: PUSHJ P,TYPSEG ; FIND WHAT IS BEING SEGMENTED + JUMPE C,LSTSEG ; CHECK END SPLICE IF LIST + +SEG3: PUSHJ P,NXTELM ; GET THE NEXTE ELEMT + JRST SEG4 ; RETURN TO CALLER + AOS (P) ; COUNT + JRST SEG3 ; TRY AGAIN +SEG4: SETZM DSTO(PVP) + JRST EVL6 + +TYPSEG: PUSHJ P,TYPSGR + JRST ILLSEG + POPJ P, + +TYPSGR: MOVEM A,DSTO(PVP) ;WILL BECOME INTERRUPTABLE WITH GOODIE IN D + GETYP A,A ; TYPE TO RH + PUSHJ P,SAT ;GET STORAGE TYPE + MOVE D,B ; GOODIE TO D + + MOVNI C,1 ; C <0 IF ILLEGAL + CAIN A,S2WORD ;LIST? + MOVEI C,0 + CAIN A,S2NWORD ;GENERAL VECTOR? + MOVEI C,1 + CAIN A,SNWORD ;UNIFORM VECTOR? + MOVEI C,2 + CAIN A,SCHSTR + MOVEI C,3 + CAIN A,SSTORE ;SPECIAL AFREE STORAGE ? + MOVEI C,2 ;TREAT LIKE A UVECTOR + CAIN A,SARGS ;ARGS TUPLE? + JRST SEGARG ;NO, ERROR + CAILE A,NUMSAT ; SKIP IF NOT TEMPLATE + JRST SEGTMP + JUMPGE C,CPOPJ1 + SETZM DSTO(PVP) ; DON'T CONFUSE AGC LATER! + POPJ P, + +SEGTMP: MOVEI C,4 + HRRM A,DSTO(PVP) ; SAVE FOR HACKERS + JRST CPOPJ1 + +SEGARG: PUSH TP,DSTO(PVP) ;PREPARE TO CHECK ARGS + PUSH TP,D + SETZM DSTO(PVP) ;TYPE NOT SPECIAL + MOVEI B,-1(TP) ;POINT TO SAVED COPY + PUSHJ P,CHARGS ;CHECK ARG POINTER + POP TP,D ;AND RESTORE WINNER + POP TP,DSTO(PVP) ;AND TYPE AND FALL INTO VECTOR CODE + MOVEI C,1 + JRST CPOPJ1 + +LSTSEG: SKIPL -1(P) ;SKIP IF IN A LIST + JRST SEG3 ;ELSE JOIN COMMON CODE + HRRZ A,@1(TB) ;CHECK FOR END OF LIST + JUMPN A,SEG3 ;NO, JOIN COMMON CODE + SETZM DSTO(PVP) ;CLOBBER SAVED GOODIES + JRST EVL9 ;AND FINISH UP + +NXTELM: INTGO + PUSHJ P,NXTLM ; GOODIE TO A AND B + POPJ P, ; DONE + PUSH TP,A + PUSH TP,B + JRST CPOPJ1 +NXTLM: XCT TESTR(C) ; SKIP IF MORE IN SEGEMNT + POPJ P, + XCT TYPG(C) ; GET THE TYPE + XCT VALG(C) ; AND VALUE + JSP E,CHKAB ; CHECK DEFERRED + XCT INCR1(C) ; AND INCREMENT TO NEXT +CPOPJ1: AOS (P) ; SKIP RETURN + POPJ P, + +; TABLES FOR SEGMENT OPERATIONS (0->LIST, 1->VECTOR/ARGS, 2->UVEC, 3->STRING) + +TESTR: SKIPN D + SKIPL D + SKIPL D + PUSHJ P,CHRDON + PUSHJ P,TM1 + +TYPG: PUSHJ P,LISTYP + GETYPF A,(D) + PUSHJ P,UTYPE + MOVSI A,TCHRS + PUSHJ P,TM2 + +VALG: MOVE B,1(D) + MOVE B,1(D) + MOVE B,(D) + PUSHJ P,1CHGT + PUSHJ P,TM3 + +INCR1: HRRZ D,(D) + ADD D,[2,,2] + ADD D,[1,,1] + PUSHJ P,1CHINC + ADD D,[1,,] + +TM1: HRRZ A,DSTO(PVP) ; GET SAT + SUBI A,NUMSAT+1 + ADD A,TD.LNT+1(TVP) + EXCH C,D + XCT (A) + HLRZ 0,C ; GET AMNT RESTED + SUB B,0 + EXCH C,D + TRNE B,-1 + AOS (P) + POPJ P, + +TM3: +TM2: HRRZ 0,DSTO(PVP) + PUSH P,C + PUSH P,D + PUSH P,E + MOVE B,D + MOVEI C,0 ; GET "1ST ELEMENT" + PUSHJ P,TMPLNT ; GET NTH IN A AND B + POP P,E + POP P,D + POP P,C + POPJ P, + + +CHRDON: HRRZ B,DSTO(PVP) ; POIT TO DOPE WORD + JUMPE B,CHRFIN + AOS (P) +CHRFIN: POPJ P, + +LISTYP: GETYP A,(D) + MOVSI A,(A) + POPJ P, +1CHGT: MOVE B,D + ILDB B,B + POPJ P, + +1CHINC: SOS DSTO(PVP) + IBP D + POPJ P, + +UTYPE: HLRE A,D + SUBM D,A + GETYP A,(A) + MOVSI A,(A) + POPJ P, + + +;COMPILER's CALL TO DOSEG +SEGMNT: PUSHJ P,TYPSEG +SEGLP1: SETZB A,B +SEGLOP: PUSHJ P,NXTELM + JRST SEGRET + AOS (P)-2 ; INCREMENT COMPILER'S COUNT + JRST SEGLOP + +SEGRET: SETZM DSTO(PVP) + POPJ P, + +SEGLST: PUSHJ P,TYPSEG + JUMPN C,SEGLS2 +SEGLS3: SETZM DSTO(PVP) + MOVSI A,TLIST +SEGLS1: SOSGE -2(P) ; START COUNT DOWN + POPJ P, + MOVEI E,(B) + POP TP,D + POP TP,C + PUSHJ P,ICONS + JRST SEGLS1 + +SEGLS2: PUSHJ P,NXTELM + JRST SEGLS4 + AOS -2(P) + JRST SEGLS2 + +SEGLS4: MOVEI B,0 + JRST SEGLS3 + + +;SPECBIND BINDS IDENTIFIERS. IT IS CALLED BY PUSHJ P,SPECBIND. +;SPECBIND IS PROVIDED WITH A CONTIGUOUS SET OF TRIPLETS ON TP. +;EACH TRIPLET IS AS FOLLOWS: +;THE FIRST ELEMENT IS THE IDENTIFIER TO BE BOUND, ITS TYPE WORD IS [TATOM,,-1], +;THE SECOND IS THE VALUE TO WHICH IT IS TO BE ASSIGNED, +;AND THE THIRD IS A PAIR OF ZEROES. + +BNDA1: TATOM,,-2 +BNDA: TATOM,,-1 +BNDV: TVEC,,-1 + +USPECBIND: + MOVE E,TP +USPCBE: PUSH P,$TUBIND + JRST .+3 + +SPECBIND: + MOVE E,TP ;GET THE POINTER TO TOP +SPECBE: PUSH P,$TBIND + ADD E,[1,,1] ;BUMP POINTER ONCE + SETZB 0,D ;CLEAR TEMPS + PUSH P,0 + MOVEI 0,(TB) ; FOR CHECKS + +BINDLP: MOVE A,-4(E) ; CHECK FOR VEC BIND + CAMN A,BNDV + JRST NONID + MOVE A,-6(E) ;GET TYPE + CAME A,BNDA1 ; FOR UNSPECIAL + CAMN A,BNDA ;NORMAL ID BIND? + CAILE 0,-6(E) ; MAKE SURE NOT GOING UNDER FRAME + JRST SPECBD + SUB E,[6,,6] ;MOVE PTR + SKIPE D ;LINK? + HRRM E,(D) ;YES -- LOBBER + SKIPN (P) ;UPDATED? + MOVEM E,(P) ;NO -- DO IT + + MOVE A,0(E) ;GET ATOM PTR + MOVE B,1(E) + PUSHJ P,ILOC ;GET LAST BINDING + MOVS A,OTBSAV (TB) ;GET TIME + HRL A,5(E) ; GET DECL POINTER + MOVEM A,4(E) ;CLOBBER IT AWAY + MOVE A,(E) ; SEE IF SPEC/UNSPEC + TRNN A,1 ; SKIP, ALWAYS SPEC + SKIPA A,-1(P) ; USE SUPPLIED + MOVSI A,TBIND + MOVEM A,(E) ;IDENTIFY AS BIND BLOCK + HRRZ C,SPBASE(PVP) ; CHECK FOR CROSS OF PROC + MOVEI A,(TP) + CAIL A,(B) ; LOSER + CAILE C,(B) ; SKIP IFF WINNER + JRST .+2 + MOVEM B,5(E) ;IN RESTORE CELLS + + MOVE C,1(E) ;GET ATOM PTR + MOVEI A,(C) + MOVEI B,0 ; FOR SPCUNP + CAIL A,HIBOT ; SKIP IF IMPURE ATOM + PUSHJ P,SPCUNP + HRRZ A,BINDID+1(PVP) ;GET PROCESS NUMBER + HRLI A,TLOCI ;MAKE LOC PTR + MOVE B,E ;TO NEW VALUE + ADD B,[2,,2] + MOVEM A,(C) ;CLOBBER ITS VALUE + MOVEM B,1(C) ;CELL + MOVE D,E ;REMEMBER LINK + JRST BINDLP ;DO NEXT + +NONID: CAILE 0,-4(E) + JRST SPECBD + SUB E,[4,,4] + SKIPE D + HRRM E,(D) + SKIPN (P) + MOVEM E,(P) + + MOVE D,1(E) ;GET PTR TO VECTOR + MOVE C,(D) ;EXCHANGE TYPES + EXCH C,2(E) + MOVEM C,(D) + + MOVE C,1(D) ;EXCHANGE DATUMS + EXCH C,3(E) + MOVEM C,1(D) + + MOVEI A,TBVL + HRLM A,(E) ;IDENTIFY BIND BLOCK + MOVE D,E ;REMEMBER LINK + JRST BINDLP + +SPECBD: SKIPE D + HRRM SP,(D) + SKIPE D,(P) + MOVE SP,D + SUB P,[2,,2] + POPJ P, + + +; HERE TO IMPURIFY THE ATOM + +SPCUNP: PUSH TP,$TSP + PUSH TP,E + PUSH TP,$TSP + PUSH TP,-1(P) ; LINK BACK IS AN SP + PUSH TP,$TSP + PUSH TP,B + MOVE B,C + PUSHJ P,IMPURIFY + MOVE 0,-2(TP) ; RESTORE LINK BACK POINTER + MOVEM 0,-1(P) + MOVE E,-4(TP) + MOVE C,B + MOVE B,(TP) + SUB TP,[6,,6] + MOVEI 0,(TB) + POPJ P, + +; ENTRY FROM COMPILER TO SET UP A BINDING + +IBIND: SUBI E,-5(SP) ; CHANGE TO PDL POINTER + HRLI E,(E) + ADD E,SP + MOVEM C,-4(E) + MOVEM A,-3(E) + MOVEM B,-2(E) + HRLOI A,TATOM + MOVEM A,-5(E) + MOVSI A,TLIST + MOVEM A,-1(E) + MOVEM D,(E) + JRST SPECB1 ; NOW BIND IT + +; "FAST CALL TO SPECBIND" + + + +; Compiler's call to SPECBIND all atom bindings, no TBVLs etc. + +SPECBND: + MOVE E,TP ; POINT TO BINDING WITH E +SPECB1: PUSH P,[0] ; SLOTS OF INTEREST + PUSH P,[0] + SUBM M,-2(P) + +SPECB2: MOVEI 0,(TB) ; FOR FRAME CHECK + MOVE A,-5(E) ; LOOK AT FIRST THING + CAMN A,BNDA ; SKIP IF LOSER + CAILE 0,-5(E) ; SKIP IF REAL WINNER + JRST SPECB3 + + SUB E,[5,,5] ; POINT TO BINDING + SKIPE A,(P) ; LINK? + HRRM E,(A) ; YES DO IT + SKIPN -1(P) ; FIRST ONE? + MOVEM E,-1(P) ; THIS IS IT + + MOVE A,1(E) ; POINT TO ATOM + MOVE 0,BINDID+1(PVP) ; QUICK CHECK + HRLI 0,TLOCI + CAMN 0,(A) ; WINNERE? + JRST SPECB4 ; YES, GO ON + + PUSH P,B ; SAVE REST OF ACS + PUSH P,C + PUSH P,D + MOVE B,A ; FOR ILOC TO WORK + PUSHJ P,ILOC ; GO LOOK IT UP + HRRZ C,SPBASE+1(PVP) + MOVEI A,(TP) + CAIL A,(B) ; SKIP IF LOSER + CAILE C,(B) ; SKIP IF WINNER + MOVEI B,0 ; SAY NO BACK POINTER + MOVE C,1(E) ; POINT TO ATOM + MOVEI A,(C) ; PURE ATOM? + CAIGE A,HIBOT ; SKIP IF OK + JRST .+4 + PUSH P,-4(P) ; MAKE HAPPINESS + PUSHJ P,SPCUNP ; IMPURIFY + POP P,-5(P) + MOVE A,BINDID+1(PVP) + HRLI A,TLOCI + MOVEM A,(C) ; STOR POINTER INDICATOR + MOVE A,B + POP P,D + POP P,C + POP P,B + JRST SPECB5 + +SPECB4: MOVE A,1(A) ; GET LOCATIVE +SPECB5: EXCH A,5(E) ; CLOBBER INTO REBIND SLOT (GET DECL) + HLL A,OTBSAV(TB) ; TIME IT + MOVSM A,4(E) ; SAVE DECL AND TIME + MOVEI A,TBIND + HRLM A,(E) ; CHANGE TO A BINDING + MOVE A,1(E) ; POINT TO ATOM + MOVEM E,(P) ; REMEMBER THIS GUY + ADD E,[2,,2] ; POINT TO VAL CELL + MOVEM E,1(A) ; INTO ATOM SLOT + SUB E,[3,,3] ; POINT TO NEXT ONE + JRST SPECB2 + +SPECB3: SKIPE A,(P) + HRRM SP,(A) ; LINK OLD STUFF + SKIPE A,-1(P) ; NEW SP? + MOVE SP,A + SUB P,[2,,2] + INTGO ; IN CASE BLEW STACK + SUBM M,(P) + POPJ P, + + +;SPECSTORE RESTORES THE BINDINGS SP TO THE ENVIRONMENT POINTER IN +;SPSAV (TB). IT IS CALLED BY PUSHJ P,SPECSTORE. + +SPECSTORE: + PUSH P,E + HRRZ E,SPSAV (TB) ;GET TARGET POINTER + PUSHJ P,STLOOP + POP P,E + MOVE SP,SPSAV(TB) ; GET NEW SP + POPJ P, + +STLOOP: PUSH P,D + PUSH P,C + +STLOO1: CAIL E,(SP) ;ARE WE DONE? + JRST STLOO2 + HLRZ C,(SP) ;GET TYPE OF BIND + CAIN C,TUBIND + JRST .+3 + CAIE C,TBIND ;NORMAL IDENTIFIER? + JRST ISTORE ;NO -- SPECIAL HACK + + + MOVE C,1(SP) ;GET TOP ATOM + MOVSI 0,TLOCI ; MAYBE LOCI OR UNBOUND + SKIPN D,5(SP) + MOVSI 0,TUNBOU + + HRR 0,BINDID+1(PVP) ;STORE SIGNATURE + MOVEM 0,(C) ;CLOBBER INTO ATOM + MOVEM D,1(C) + SETZM 4(SP) +SPLP: HRRZ SP,(SP) ;FOLOW LINK + JUMPN SP,STLOO1 ;IF MORE + SKIPE E ; OK IF E=0 + FATAL SP OVERPOP +STLOO2: POP P,C + POP P,D + POPJ P, + +ISTORE: CAIE C,TBVL + JRST CHSKIP + MOVE C,1(SP) + MOVE D,2(SP) + MOVEM D,(C) + MOVE D,3(SP) + MOVEM D,1(C) + JRST SPLP + +CHSKIP: CAIN C,TSKIP + JRST SPLP + CAIE C,TUNWIN ; UNWIND HACK + FATAL BAD SP + HRRZ C,-2(P) ; WHERE FROM? + CAIE C,CHUNPC + JRST SPLP ; IGNORE + MOVEI E,(TP) ; FIXUP SP + SUBI E,(SP) + MOVSI E,(E) + HLL SP,TP + SUB SP,E + POP P,C + POP P,D + AOS (P) + POPJ P, + +; ENTRY FOR FUNNY COMPILER UNBIND (1) + +SSPECS: PUSH P,E + MOVEI E,(TP) + PUSHJ P,STLOOP +SSPEC2: SUBI E,(SP) ; MAKE SP BE AOBJN + MOVSI E,(E) + HLL SP,TP + SUB SP,E + POP P,E + POPJ P, + +; ENTRY FOR FUNNY COMPILER UNBIND (2) + +SSPEC1: PUSH P,E + SUBI E,1 ; MAKE SURE GET CURRENT BINDING + PUSHJ P,STLOOP ; UNBIND + MOVEI E,(TP) ; NOW RESET SP + JRST SSPEC2 + EFINIS: SKIPN C,1STEPR+1(PVP) ; SKIP NIF BEING ONE PROCEEDED + JRST FINIS + PUSH TP,$TATOM + PUSH TP,MQUOTE EVLOUT + PUSH TP,A ;SAVE EVAL RESULTS + PUSH TP,B + PUSH TP,[TINFO,,2] ; FENCE POST + PUSHJ P,TBTOTP + PUSH TP,D + PUSHJ P,MAKINF ; MAKE ARG BLOCK INFO + PUSH TP,A + MOVEI B,-6(TP) + HRLI B,-4 ; AOBJN TO ARGS BLOCK + PUSH TP,B + PUSH TP,1STEPR(PVP) + PUSH TP,1STEPR+1(PVP) ; PROCESS DOING THE 1STEPPING + MCALL 2,RESUME + MOVE A,-3(TP) ; GET BACK EVAL VALUE + MOVE B,-2(TP) + JRST FINIS + +1STEPI: PUSH TP,$TATOM + PUSH TP,MQUOTE EVLIN + PUSH TP,$TAB ; PUSH EVALS ARGGS + PUSH TP,AB + PUSHJ P,MAKINF ; TURN INTO ARGS BLOCK + MOVEM A,-1(TP) ; AND CLOBBER + PUSH TP,[TINFO,,2] ; FENCE POST 2D TUPLE + PUSHJ P,TBTOTP + PUSH TP,D + PUSHJ P,MAKINF ; TURN IT INTO ARGS BLOCK + PUSH TP,A + MOVEI B,-6(TP) ; SETUP TUPLE + HRLI B,-4 + PUSH TP,B + PUSH TP,1STEPR(PVP) + PUSH TP,1STEPR+1(PVP) + MCALL 2,RESUME ; START UP 1STEPERR + SUB TP,[6,,6] ; REMOVE CRUD + GETYP A,A ; GET 1STEPPERS TYPE + CAIE A,TDISMI ; IF DISMISS, STOP 1 STEPPING + JRST EVALON + +; HERE TO PUSH DOWN THE 1 STEP STATE AND RUN + + MOVE D,PVP + ADD D,[1STEPR,,1STEPR] ; POINT TO 1 STEP SLOT + PUSH TP,$TSP ; SAVE CURRENT SP + PUSH TP,SP + PUSH TP,BNDV + PUSH TP,D ; BIND IT + PUSH TP,$TPVP + PUSH TP,[0] ; NO 1 STEPPER UNTIL POPJ + PUSHJ P,SPECBIND + +; NOW PUSH THE ARGS UP TO RE-CALL EVAL + + MOVEI A,0 +EFARGL: JUMPGE AB,EFCALL + PUSH TP,(AB) + PUSH TP,1(AB) + ADD AB,[2,,2] + AOJA A,EFARGL + +EFCALL: ACALL A,EVAL ; NOW DO THE EVAL + MOVE C,(TP) ; PRE-UNBIND + MOVEM C,1STEPR+1(PVP) + MOVE SP,-4(TP) ; AVOID THE UNBIND + SUB TP,[6,,6] ; AND FLUSH LOSERS + JRST EFINIS ; AND TRY TO FINISH UP + +MAKINF: HLRZ A,OTBSAV(TB) ; TIME IT + HRLI A,TARGS + POPJ P, + + +TBTOTP: MOVEI D,(TB) ; COMPUTE REL DIST FROM TP TO TB + SUBI D,(TP) + POPJ P, +; ARRIVE HERE TO COMPLETE A COMPILER GENERATED TUPLE +; D/ LENGTH OF THE TUPLE IN WORDS + +MAKTU2: MOVE D,-1(P) ; GET LENGTH +MAKTUP: HRLI D,TINFO ; FIRST WORD OF FENCE POST + PUSH TP,D + HRROI B,(TP) ; TOP OF TUPLE + SUBI B,(D) + TLC B,-1(D) ; AOBJN IT + PUSHJ P,TBTOTP + PUSH TP,D + HLRZ A,OTBSAV(TB) ; TIME IT + HRLI A,TARGS + POPJ P, + +; HERE TO ALLOCATE SLOTS FOR COMPILER (AMNT IN A) + +TPALOC: HRLI A,(A) + ADD TP,A + SKIPL TP + PUSHJ P,TPOVFL ; IN CASE IT LOST + INTGO ; TAKE THE GC IF NEC + PUSH P,A + HRRI A,2(TP) + SUB A,(P) + SETZM -1(A) + HRLI A,-1(A) + BLT A,(TP) + SUB P,[1,,1] + POPJ P, + +NTPALO: PUSH TP,[0] + SOJG 0,.-1 + POPJ P, + + ;EVALUATES A IDENTIFIER -- GETS LOCAL VALUE IF THERE IS ONE, OTHERWISE GLOBAL. + +MFUNCTION VALUE,SUBR + JSP E,CHKAT + PUSHJ P,IDVAL + JRST FINIS + +IDVAL: PUSHJ P,IDVAL1 + CAMN A,$TUNBOU + JRST UNBOU + POPJ P, + +IDVAL1: PUSH TP,A + PUSH TP,B ;SAVE ARG IN CASE NEED TO CHECK GLOBAL VALUE + PUSHJ P,ILVAL ;LOCAL VALUE FINDER + CAME A,$TUNBOUND ;IF NOT UNBOUND OR UNASSIGNED + JRST RIDVAL ;DONE - CLEAN UP AND RETURN + POP TP,B ;GET ARG BACK + POP TP,A + JRST IGVAL +RIDVAL: SUB TP,[2,,2] + POPJ P, + +;GETS THE LOCAL VALUE OF AN IDENTIFIER + +MFUNCTION LVAL,SUBR + JSP E,CHKAT + PUSHJ P,AILVAL + CAME A,$TUNBOUND + JRST FINIS + JUMPN B,UNAS + JRST UNBOU + +; MAKE AN ATOM UNASSIGNED + +MFUNCTION UNASSIGN,SUBR + JSP E,CHKAT ; GET ATOM ARG + PUSHJ P,AILOC +UNASIT: CAMN A,$TUNBOU ; IF UNBOUND + JRST RETATM + MOVSI A,TUNBOU + MOVEM A,(B) + SETOM 1(B) ; MAKE SURE +RETATM: MOVE B,1(AB) + MOVE A,(AB) + JRST FINIS + +; UNASSIGN GLOBALLY + +MFUNCTION GUNASSIGN,SUBR + JSP E,CHKAT2 + PUSHJ P,IGLOC + CAMN A,$TUNBOU + JRST RETATM + MOVE B,1(AB) ; ATOM BACK + MOVEI 0,(B) + CAIL 0,HIBOT ; SKIP IF IMPURE + PUSHJ P,IMPURIFY ; YES, MAKE IT IMPURE + PUSHJ P,IGLOC ; RESTORE LOCATIVE + HRRZ 0,-2(B) ; SEE IF MANIFEST + GETYP A,(B) ; AND CURRENT TYPE + CAIN 0,-1 + CAIN A,TUNBOU + JRST UNASIT + SKIPE IGDECL + JRST UNASIT + MOVE D,B + JRST MANILO + +; GETS A LOCATIVE TO THE LOCAL VALUE OF AN IDENTIFIER. + +MFUNCTION LLOC,SUBR + JSP E,CHKAT + PUSHJ P,AILOC + CAMN A,$TUNBOUND + JRST UNBOU + MOVSI A,TLOCD + HRR A,2(B) + JRST FINIS + +;TESTS TO SEE IF AN IDENTIFIER IS LOCALLY BOUND + +MFUNCTION BOUND,SUBR,[BOUND?] + JSP E,CHKAT + PUSHJ P,AILVAL + CAMN A,$TUNBOUND + JUMPE B,IFALSE + JRST TRUTH + +;TESTS TO SEE IF AN IDENTIFIER IS LOCALLY ASSIGNED + +MFUNCTION ASSIGP,SUBR,[ASSIGNED?] + JSP E,CHKAT + PUSHJ P,AILVAL + CAME A,$TUNBOUND + JRST TRUTH +; JUMPE B,UNBOU + JRST IFALSE + +;GETS THE GLOBAL VALUE OF AN IDENTIFIER + +MFUNCTION GVAL,SUBR + JSP E,CHKAT2 + PUSHJ P,IGVAL + CAMN A,$TUNBOUND + JRST UNAS + JRST FINIS + +;GETS A LOCATIVE TO THE GLOBAL VALUE OF AN IDENTIFIER + +MFUNCTION GLOC,SUBR + + JUMPGE AB,TFA + CAMGE AB,[-5,,] + JRST TMA + JSP E,CHKAT1 + MOVEI E,IGLOC + CAML AB,[-2,,] + JRST .+4 + GETYP 0,2(AB) + CAIE 0,TFALSE + MOVEI E,IIGLOC + PUSHJ P,(E) + CAMN A,$TUNBOUND + JRST UNAS + MOVSI A,TLOCD + MOVE C,1(AB) ; GE ATOM + MOVEI 0,(C) + CAIGE 0,HIBOT ; SKIP IF PURE ATOM + JRST FINIS + +; MAKE ATOM AND VALUE IMPURE IF GETTING GLOC TO IT + + MOVE B,C ; ATOM TO B + PUSHJ P,IMPURIFY + JRST GLOC ; AND TRY AGAIN + +;TESTS TO SEE IF AN IDENTIFIER IS GLOBALLY ASSIGNED + +MFUNCTION GASSIG,SUBR,[GASSIGNED?] + JSP E,CHKAT2 + PUSHJ P,IGVAL + CAMN A,$TUNBOUND + JRST IFALSE + JRST TRUTH + +; TEST FOR GLOBALLY BOUND + +MFUNCTION GBOUND,SUBR,[GBOUND?] + + JSP E,CHKAT2 + PUSHJ P,IGLOC + JUMPE B,IFALSE + JRST TRUTH + + + +CHKAT2: ENTRY 1 +CHKAT1: GETYP A,(AB) + MOVSI A,(A) + CAME A,$TATOM + JRST NONATM + MOVE B,1(AB) + JRST 2,(E) + +CHKAT: HLRE A,AB ; - # OF ARGS + ASH A,-1 ; TO ACTUAL WORDS + JUMPGE AB,TFA + MOVE C,SP ; FOR BINDING LOOKUPS + AOJE A,CHKAT1 ; ONLY ONE ARG, NO ENVIRONMENT + AOJL A,TMA ; TOO MANY + GETYP A,2(AB) ; MAKE SURE OF TENV OR TFRAME + CAIE A,TFRAME + CAIN A,TENV + JRST CHKAT3 + CAIN A,TACT ; FOR PFISTERS LOSSAGE + JRST CHKAT3 + CAIE A,TPVP ; OR PROCESS + JRST WTYP2 + MOVE B,3(AB) ; GET PROCESS + MOVE C,SP ; IN CASE ITS ME + CAME B,PVP ; SKIP IF DIFFERENT + MOVE C,SPSTO+1(B) ; GET ITS SP + JRST CHKAT1 +CHKAT3: MOVEI B,2(AB) ; POINT TO FRAME POINTER + PUSHJ P,CHFRM ; VALIDITY CHECK + MOVE B,3(AB) ; GET TB FROM FRAME + MOVE C,SPSAV(B) ; GET ENVIRONMENT POINTER + JRST CHKAT1 + + + +;ILOC RETURNS IN A AND B A LOCATIVE TO THE LOCAL VALUE OF THE IDENTIFIER PASSED TO IT +;IN A AND B. IF THE IDENTIFIER IS LOCALLY UNBOUND IT RETURNS $TUNBOUND IN A AND 0 IN B, +; IT IS CALLED BY PUSHJ P,ILOC. + +ILOC: MOVE C,SP ; SETUP SEARCH START +AILOC: MOVSI A,TLOCI ;MAKE A LOCATIVE TYPE CELL + PUSH P,E + PUSH P,D + MOVEI E,0 ; FLAG TO CLOBBER ATOM + JUMPE B,SCHSP ; IF LOOKING FOR SLOT, SEARCH NOW + CAME C,SP ; ENVIRONMENT CHANGE? + JRST SCHSP ; YES, MUST SEARCH + HRR A,BINDID+1(PVP) ;FOR THE CURRENT PROCESS + CAME A,(B) ;IS THERE ONE IN THE VALUE CELL? + JRST SCHLP ;NO -- SEARCH THE LOCAL BINDINGS + MOVE B,1(B) ;YES -- GET LOCATIVE POINTER + MOVE C,PVP +ILCPJ: MOVE E,SPCCHK + TRNN E,1 ; SKIP IF DOING SPEC UNSPEC CHECK + JRST ILOCPJ + HLRZ E,-2(B) + CAIE E,TUBIND + JRST ILOCPJ + CAMGE B,CURFCN+1(PVP) + JRST UNPJ11 + MOVEI D,-2(B) + CAIG D,(SP) + CAMGE B,SPBASE+1(PVP) + JRST UNPJ11 +ILOCPJ: POP P,D + POP P,E + POPJ P, ;FROM THE VALUE CELL + +SCHLP: MOVEI D,(B) + CAIL D,HIBOT ; SKIP IF IMPURE ATOM +SCHSP: MOVEI E,1 ; DONT STORE LOCATIVE + + PUSH P,E ; PUSH SWITCH + MOVE E,PVP ; GET PROC +SCHLP1: JUMPE C,UNPJ ;IF NO MORE -- LOSE + CAMN B,1(C) ;ARE WE POINTING AT THE WINNER? + JRST SCHFND ;YES + GETYP D,(C) ; CHECK SKIP + CAIE D,TSKIP + JRST SCHLP2 + PUSH P,B ; CHECK DETOUR + MOVEI B,2(C) + PUSHJ P,CHFRAM ; NON-FATAL FRAME CHECKER + HRRZ E,2(C) ; CONS UP PROCESS + SUBI E,PVLNT*2+1 + HRLI E,-2*PVLNT + JUMPE B,SCHLP3 ; LOSER, FIX IT + POP P,B + MOVEI C,1(C) ; FOLLOW LOOKUP CHAIN +SCHLP2: HRRZ C,(C) ;FOLLOW LINK + JRST SCHLP1 + +SCHLP3: POP P,B + MOVEI C,(SP) ; *** NDR'S BUG *** + CAME E,PVP ; USE IF CURRENT PROCESS + HRRZ C,SPSTO+1(E) ; USE CURRENT SP FOR PROC + JRST SCHLP1 + +SCHFND: EXCH B,C ;SAVE THE ATOM PTR IN C + MOVEI B,2(B) ;MAKE UP THE LOCATIVE + SUB B,TPBASE+1(E) + HRLI B,(B) + ADD B,TPBASE+1(E) + EXCH C,E ; RET PROCESS IN C + POP P,D ; RESTORE SWITCH + + JUMPN D,ILOCPJ ; DONT CLOBBER ATOM + MOVEM A,(E) ;CLOBBER IT AWAY INTO THE + MOVEM B,1(E) ;ATOM'S VALUE CELL + JRST ILCPJ + +UNPJ: SUB P,[1,,1] ; FLUSH CRUFT +UNPJ1: MOVE C,E ; RET PROCESS ANYWAY +UNPJ11: POP P,D + POP P,E +UNPOPJ: MOVSI A,TUNBOUND + MOVEI B,0 + POPJ P, + +;IGLOC RETURNS IN A AND B A LOCATIVE TO THE GLOBAL VALUE OF THE +;IDENTIFIER PASSED TO IT IN A AND B. IF THE IDENTIFIER IS GLOBALLY +;UNBPOUND IT RETURNS $TUNBOUND IN A AND 0 IN B. IT IS CALLED BY PUSHJ P,IGLOC. + + +IGLOC: MOVSI A,TLOCI ;DO WE HAVE A LOCATIVE TO + CAME A,(B) ;A PROCESS #0 VALUE? + JRST SCHGSP ;NO -- SEARCH + MOVE B,1(B) ;YES -- GET VALUE CELL + POPJ P, + +SCHGSP: MOVE D,GLOBSP+1(TVP) ;GET GLOBAL SP PTR + +SCHG1: JUMPGE D,UNPOPJ ;IF NO MORE, LEAVE + CAMN B,1(D) ;ARE WE FOUND? + JRST GLOCFOUND ;YES + ADD D,[4,,4] ;NO -- TRY NEXT + JRST SCHG1 + +GLOCFOUND: + EXCH B,D ;SAVE ATOM PTR + ADD B,[2,,2] ;MAKE LOCATIVE + MOVEI 0,(D) + CAIL 0,HIBOT + POPJ P, + MOVEM A,(D) ;CLOBBER IT AWAY + MOVEM B,1(D) + POPJ P, + +IIGLOC: PUSH TP,$TATOM + PUSH TP,B + PUSHJ P,IGLOC + MOVE C,(TP) + SUB TP,[2,,2] + GETYP 0,A + CAIE 0,TUNBOU + POPJ P, + PUSH TP,$TATOM + PUSH TP,C + PUSHJ P,BSETG ; MAKE A SLOT + SETOM 1(B) ; UNBOUNDIFY IT + MOVSI A,TLOCD + MOVSI 0,TUNBOU + MOVEM 0,(B) + SUB TP,[2,,2] + POPJ P, + + + +;ILVAL RETURNS IN A AND B THE LOCAL VALUE OF THE IDENTIFIER PASSED TO IT IN A AND B +;IF THE IDENTIFIER IS UNBOUND ITS VALUE IS $TUNBOUND IN A AND 0 IN B. IF +;IT IS UNASSIGNED ITS VALUE IS $TUNBOUND IN A AND -1 IN B. CALL - PUSHJ P,IVAL + +AILVAL: + PUSHJ P,AILOC ; USE SUPPLIED SP + JRST CHVAL +ILVAL: + PUSHJ P,ILOC ;GET LOCATIVE TO VALUE +CHVAL: CAMN A,$TUNBOUND ;BOUND + POPJ P, ;NO -- RETURN + MOVSI A,TLOCD ; GET GOOD TYPE + HRR A,2(B) ; SHOULD BE TIME OR 0 + PUSH P,0 + PUSHJ P,RMONC0 ; CHECK READ MONITOR + POP P,0 + MOVE A,(B) ;GET THE TYPE OF THE VALUE + MOVE B,1(B) ;GET DATUM + POPJ P, + +;IGVAL -- LIKE ILVAL EXCEPT FOR GLOBAL VALUES + +IGVAL: PUSHJ P,IGLOC + JRST CHVAL + + + +; COMPILERS INTERFACE TO LVAL/GVAL/SETG/SET + +CILVAL: MOVE 0,BINDID+1(PVP) ; CURRENT BIND + HRLI 0,TLOCI + CAME 0,(B) ; HURRAY FOR SPEED + JRST CILVA1 ; TOO BAD + MOVE C,1(B) ; POINTER + MOVE A,(C) ; VAL TYPE + TLNE A,.RDMON ; MONITORS? + JRST CILVA1 + GETYP 0,A + CAIN 0,TUNBOU + JRST CUNAS ; COMPILER ERROR + MOVE B,1(C) ; GOT VAL + MOVE 0,SPCCHK + TRNN 0,1 + POPJ P, + HLRZ 0,-2(C) ; SPECIAL CHECK + CAIE 0,TUBIND + POPJ P, ; RETURN + CAMGE C,CURFCN+1(PVP) + JRST CUNAS + POPJ P, + +CUNAS: +CILVA1: SUBM M,(P) ; FIX (P) + PUSH TP,$TATOM ; SAVE ATOM + PUSH TP,B + MCALL 1,LVAL ; GET ERROR/MONITOR +MPOPJ: +POPJM: SUBM M,(P) ; REPAIR DAMAGE + POPJ P, + +; COMPILERS INTERFACE TO SET C/ ATOM A,B/ NEW VALUE + +CISET: MOVE 0,BINDID+1(PVP) ; CURRENT BINDING ENVIRONMENT + HRLI 0,TLOCI + CAME 0,(C) ; CAN WE WIN? + JRST CISET1 ; NO, MORE HAIR + MOVE D,1(C) ; POINT TO SLOT + HLLZ 0,(D) ; MON CHECK +CISET3: TLNE 0,.WRMON + JRST CISET4 ; YES, LOSE + TLZ 0,TYPMSK + IOR A,0 ; LEAVE MONITOR ON + MOVE 0,SPCCHK + TRNE 0,1 + JRST CISET5 ; SPEC/UNSPEC CHECK +CISET6: MOVEM A,(D) ; STORE + MOVEM B,1(D) + POPJ P, + +CISET5: HLRZ 0,-2(D) + CAIE 0,TUBIND + JRST CISET6 + CAMGE D,CURFCN+1(PVP) + JRST CISET4 + JRST CISET6 + +CISET1: SUBM M,(P) ; FIX ADDR + PUSH TP,$TATOM ; SAVE ATOM + PUSH TP,C + PUSH TP,A + PUSH TP,B + MOVE B,C ; GET ATOM + PUSHJ P,ILOC ; SEARCH + MOVE D,B ; POSSIBLE POINTER + GETYP E,A + MOVE 0,A + MOVE A,-1(TP) ; VAL BACK + MOVE B,(TP) + CAIE E,TUNBOU ; SKIP IF WIN + JRST CISET2 ; GO CLOBBER IT IN + MCALL 2,SET + JRST POPJM + +CISET2: MOVE C,-2(TP) ; ATOM BACK + SUBM M,(P) ; RESET (P) + SUB TP,[4,,4] + JRST CISET3 + +; HERE TO DO A MONITORED SET + +CISET4: SUBM M,(P) ; AGAIN FIX (P) + PUSH TP,$TATOM + PUSH TP,C + PUSH TP,A + PUSH TP,B + MCALL 2,SET + JRST POPJM + +; COMPILER LLOC + +CLLOC: MOVE 0,BINDID+1(PVP) ; GET CURRENT LOCATIVE + HRLI 0,TLOCI + CAME 0,(B) ; WIN? + JRST CLLOC1 + MOVE B,1(B) + MOVE 0,SPCCHK + TRNE 0,1 ; SKIP IF NOT CHECKING + JRST CLLOC9 +CLLOC3: MOVSI A,TLOCD + HRR A,2(B) ; GET BIND TIME + POPJ P, + +CLLOC1: SUBM M,(P) + PUSH TP,$TATOM + PUSH TP,B + PUSHJ P,ILOC ; LOOK IT UP + JUMPE B,CLLOC2 + SUB TP,[2,,2] +CLLOC4: SUBM M,(P) + JRST CLLOC3 + +CLLOC2: MCALL 1,LLOC + JRST CLLOC4 + +CLLOC9: HLRZ 0,-2(B) + CAIE 0,TUBIND + JRST CLLOC3 + CAMGE B,CURFCN+1(PVP) + JRST CLLOC2 + JRST CLLOC3 + +; COMPILER BOUND? + +CBOUND: SUBM M,(P) + PUSHJ P,ILOC + JUMPE B,PJFALS ; IF UNBOUND RET FALSE AND NO SSKIP +PJT1: SOS (P) + MOVSI A,TATOM + MOVE B,MQUOTE T + JRST POPJM + +PJFALS: MOVEI B,0 + MOVSI A,TFALSE + JRST POPJM + +; COMPILER ASSIGNED? + +CASSQ: SUBM M,(P) + PUSHJ P,ILOC + JUMPE B,PJFALS + GETYP 0,(B) + CAIE 0,TUNBOU + JRST PJT1 + JRST PJFALS + + +; COMPILER GVAL B/ ATOM + +CIGVAL: MOVE 0,(B) ; GLOBAL VAL HERE? + CAME 0,$TLOCI ; TIME=0 ,TYPE=TLOCI => GLOB VAL + JRST CIGVA1 ; NO, GO LOOK + MOVE C,1(B) ; POINT TO SLOT + MOVE A,(C) ; GET TYPE + TLNE A,.RDMON + JRST CIGVA1 + GETYP 0,A ; CHECK FOR UNBOUND + CAIN 0,TUNBOU ; SKIP IF WINNER + JRST CGUNAS + MOVE B,1(C) + POPJ P, + +CGUNAS: +CIGVA1: SUBM M,(P) + PUSH TP,$TATOM + PUSH TP,B + .MCALL 1,GVAL ; GET ERROR/MONITOR + JRST POPJM + +; COMPILER INTERFACET TO SETG + +CSETG: MOVE 0,(C) ; GET V CELL + CAME 0,$TLOCI ; SKIP IF FAST + JRST CSETG1 + HRRZ D,1(C) ; POINT TO SLOT + MOVE 0,(D) ; OLD VAL +CSETG3: CAIG D,HIBOT ; SKIP IF PURE ATOM + TLNE 0,.WRMON ; MONITOR + JRST CSETG2 + MOVEM A,(D) + MOVEM B,1(D) + POPJ P, + +CSETG1: SUBM M,(P) ; FIX UP P + PUSH TP,$TATOM + PUSH TP,C + PUSH TP,A + PUSH TP,B + MOVE B,C + PUSHJ P,IGLOC ; FIND GLOB LOCATIVE + GETYP E,A + MOVE 0,A + MOVEI D,(B) ; SETUP TO RESTORE NEW VAL + MOVE A,-1(TP) + MOVE B,(TP) + CAIE E,TUNBOU + JRST CSETG4 + MCALL 2,SETG + JRST POPJM + +CSETG4: MOVE C,-2(TP) ; ATOM BACK + SUBM M,(P) ; RESET (P) + SUB TP,[4,,4] + JRST CSETG3 + +CSETG2: SUBM M,(P) + PUSH TP,$TATOM ; CAUSE A SETG MONITOR + PUSH TP,C + PUSH TP,A + PUSH TP,B + MCALL 2,SETG + JRST POPJM + +; COMPILER GLOC + +CGLOC: MOVE 0,(B) ; GET CURRENT GUY + CAME 0,$TLOCI ; WIN? + JRST CGLOC1 ; NOPE + HRRZ D,1(B) ; POINT TO SLOT + CAILE D,HIBOT ; PURE? + JRST CGLOC1 + MOVE A,$TLOCD + MOVE B,1(B) + POPJ P, + +CGLOC1: SUBM M,(P) + PUSH TP,$TATOM + PUSH TP,B + MCALL 1,GLOC + JRST POPJM + +; COMPILERS GASSIGNED? + +CGASSQ: MOVE 0,(B) + SUBM M,(P) + CAMN 0,$TLOCD + JRST PJT1 + PUSHJ P,IGLOC + JUMPE B,PJFALS + GETYP 0,(B) + CAIE 0,TUNBOU + JRST PJT1 + JRST PJFALS + +; COMPILERS GBOUND? + +CGBOUN: MOVE 0,(B) + SUBM M,(P) + CAMN 0,$TLOCD + JRST PJT1 + PUSHJ P,IGLOC + JUMPE B,PJFALS + JRST PJT1 + + +MFUNCTION REP,FSUBR,[REPEAT] + JRST PROG +MFUNCTION PROG,FSUBR + ENTRY 1 + GETYP A,(AB) ;GET ARG TYPE + CAIE A,TLIST ;IS IT A LIST? + JRST WRONGT ;WRONG TYPE + SKIPN C,1(AB) ;GET AND CHECK ARGUMENT + JRST TFA ;TOO FEW ARGS + SETZB E,D ; INIT HEWITT ATOM AND DECL + PUSHJ P,CARATC ; IS 1ST THING AN ATOM + JFCL + PUSHJ P,RSATY1 ; CDR AND GET TYPE + CAIE 0,TLIST ; MUST BE LIST + JRST MPD.13 + MOVE B,1(C) ; GET ARG LIST + PUSH TP,$TLIST + PUSH TP,C + PUSHJ P,RSATYP + CAIE 0,TDECL + JRST NOP.DC ; JUMP IF NO DCL + MOVE D,1(C) + MOVEM C,(TP) + PUSHJ P,RSATYP ; CDR ON +NOP.DC: PUSH TP,$TLIST + PUSH TP,B ; AND ARG LIST + PUSHJ P,PRGBND ; BIND AUX VARS + MOVE E,MQUOTE LPROG,[LPROG ]INTRUP + PUSHJ P,MAKACT ; MAKE ACTIVATION + PUSHJ P,PSHBND ; BIND AND CHECK + PUSHJ P,SPECBI ; NAD BIND IT + +; HERE TO RUN PROGS FUNCTIONS ETC. + +DOPROG: MOVEI A,REPROG + HRLI A,TDCLI ; FLAG AS FUNNY + MOVEM A,(TB) ; WHERE TO AGAIN TO + MOVE C,1(TB) + MOVEM C,3(TB) ; RESTART POINTER + JRST .+2 ; START BY SKIPPING DECL + +DOPRG1: PUSHJ P,FASTEV + HRRZ C,@1(TB) ;GET THE REST OF THE BODY +DOPRG2: MOVEM C,1(TB) + JUMPN C,DOPRG1 +ENDPROG: + HRRZ C,FSAV(TB) + CAIN C,REP +REPROG: SKIPN C,@3(TB) + JRST PFINIS + HRRZM C,1(TB) + INTGO + MOVE C,1(TB) + JRST DOPRG1 + + +PFINIS: GETYP 0,(TB) + CAIE 0,TDCLI ; DECL'D ? + JRST PFINI1 + HRRZ 0,(TB) ; SEE IF RSUBR + JUMPE 0,RSBVCK ; CHECK RSUBR VALUE + HRRZ C,3(TB) ; GET START OF FCN + GETYP 0,(C) ; CHECK FOR DECL + CAIE 0,TDECL + JRST PFINI1 ; NO, JUST RETURN + MOVE E,MQUOTE VALUE + PUSHJ P,PSHBND ; BUILD FAKE BINDING + MOVE C,1(C) ; GET DECL LIST + MOVE E,TP + PUSHJ P,CHKDCL ; AND CHECK IT + MOVE A,-3(TP) ; GET VAL BAKC + MOVE B,-2(TP) + SUB TP,[6,,6] + +PFINI1: HRRZ C,FSAV(TB) + CAIE C,EVAL + JRST FINIS + JRST EFINIS + +RSATYP: HRRZ C,(C) +RSATY1: JUMPE C,TFA + GETYP 0,(C) + POPJ P, + +; HERE TO CHECK RSUBR VALUE + +RSBVCK: PUSH TP,A + PUSH TP,B + MOVE C,A + MOVE D,B + MOVE A,1(TB) ; GET DECL + MOVE B,1(A) + HLLZ A,(A) + PUSHJ P,TMATCH + JRST RSBVC1 + POP TP,B + POP TP,A + POPJ P, + +RSBVC1: MOVE C,1(TB) + POP TP,B + POP TP,D + MOVE A,MQUOTE VALUE + JRST TYPMIS + + +MFUNCTION MRETUR,SUBR,[RETURN] + ENTRY + HLRE A,AB ; GET # OF ARGS + ASH A,-1 ; TO NUMBER + AOJL A,RET2 ; 2 OR MORE ARGS + PUSHJ P,PROGCH ;CHECK IN A PROG + PUSH TP,A + PUSH TP,B + MOVEI B,-1(TP) ; VERIFY IT +COMRET: PUSHJ P,CHFSWP + SKIPL C ; ARGS? + MOVEI C,0 ; REAL NONE + PUSHJ P,CHUNW + JUMPN A,CHFINI ; WINNER + MOVSI A,TATOM + MOVE B,MQUOTE T + +; SEE IF MUST CHECK RETURNS TYPE + +CHFINI: GETYP 0,(TB) ; SPECIAL TYPE IF SO + CAIE 0,TDCLI + JRST FINIS ; NO, JUST FINIS + MOVEI 0,PFINIS ; CAUSE TO FALL INTO FUNCTION CODE + HRRM 0,PCSAV(TB) + JRST CONTIN + + +RET2: AOJL A,TMA + GETYP A,(AB)+2 + CAIE A,TACT ; AS FOR "EXIT" SHOULD BE ACTIVATION + JRST WTYP2 + MOVEI B,(AB)+2 ; ADDRESS OF FRAME POINTER + JRST COMRET + + + +MFUNCTION AGAIN,SUBR + ENTRY + HLRZ A,AB ;GET # OF ARGS + CAIN A,-2 ;1 ARG? + JRST NLCLA ;YES + JUMPN A,TMA ;0 ARGS? + PUSHJ P,PROGCH ;CHECK FOR IN A PROG + PUSH TP,A + PUSH TP,B + JRST AGAD +NLCLA: GETYP A,(AB) + CAIE A,TACT + JRST WTYP1 + PUSH TP,(AB) + PUSH TP,1(AB) +AGAD: MOVEI B,-1(TP) ; POINT TO FRAME + PUSHJ P,CHFSWP + HRRZ C,(B) ; GET RET POINT +GOJOIN: PUSH TP,$TFIX + PUSH TP,C + MOVEI C,-1(TP) + PUSHJ P,CHUNW ; RESTORE FRAME, UNWIND IF NEC. + HRRZM B,PCSAV(TB) + HRRZ 0,FSAV(TB) ; CHECK FOR RSUBR + CAMGE 0,VECTOP + CAMG 0,VECBOT + JRST CONTIN + HRRZ E,1(TB) + PUSH TP,$TFIX + PUSH TP,B + MOVEI C,-1(TP) + MOVEI B,(TB) + PUSHJ P,CHUNW1 + MOVE TP,1(TB) + MOVEM SP,SPSAV(TB) + MOVEM TP,TPSAV(TB) + MOVE C,OTBSAV(TB) ; AND RESTORE P FROM FATHER + MOVE P,PSAV(C) + MOVEM P,PSAV(TB) + HRLI B,M + MOVEM B,PCSAV(TB) + JRST CONTIN + +MFUNCTION GO,SUBR + ENTRY 1 + GETYP A,(AB) + CAIE A,TATOM + JRST NLCLGO + PUSHJ P,PROGCH ;CHECK FOR A PROG + PUSH TP,A ;SAVE + PUSH TP,B + MOVEI B,-1(TP) + PUSHJ P,CHFSWP + PUSH TP,$TATOM + PUSH TP,1(C) + PUSH TP,2(B) + PUSH TP,3(B) + MCALL 2,MEMQ ;DOES IT HAVE THIS TAG? + JUMPE B,NXTAG ;NO -- ERROR +FNDGO: EXCH B,(TP) ;SAVE PLACE TO GO + MOVSI D,TLIST + MOVEM D,-1(TP) + JRST GODON + +NLCLGO: CAIE A,TTAG ;CHECK TYPE + JRST WTYP1 + MOVE B,1(AB) + MOVEI B,2(B) ; POINT TO SLOT + PUSHJ P,CHFSWP + MOVE A,1(C) + GETYP 0,(A) ; SEE IF COMPILED + CAIE 0,TFIX + JRST GODON1 + MOVE C,1(A) + JRST GOJOIN + +GODON1: PUSH TP,(A) ;SAVE BODY + PUSH TP,1(A) +GODON: MOVEI C,0 + PUSHJ P,CHUNW ;GO BACK TO CORRECT FRAME + MOVE B,(TP) ;RESTORE ITERATION MARKER + MOVEM B,1(TB) + MOVSI A,TFALSE + MOVEI B,0 + JRST CONTIN + + + + +MFUNCTION TAG,SUBR + ENTRY + JUMPGE AB,TFA + HLRZ 0,AB + GETYP A,(AB) ;GET TYPE OF ARGUMENT + CAIE A,TFIX ; FIX ==> COMPILED + JRST ATOTAG + CAIE 0,-4 + JRST WNA + GETYP A,2(AB) + CAIE A,TACT + JRST WTYP2 + PUSH TP,(AB) + PUSH TP,1(AB) + PUSH TP,2(AB) + PUSH TP,3(AB) + JRST GENTV +ATOTAG: CAIE A,TATOM ;CHECK THAT IT IS AN ATOM + JRST WTYP1 + CAIE 0,-2 + JRST TMA + PUSHJ P,PROGCH ;CHECK PROG + PUSH TP,A ;SAVE VAL + PUSH TP,B + PUSH TP,$TATOM + PUSH TP,1(AB) + PUSH TP,2(B) + PUSH TP,3(B) + MCALL 2,MEMQ + JUMPE B,NXTAG ;IF NOT FOUND -- ERROR + EXCH A,-1(TP) ;SAVE PLACE + EXCH B,(TP) + HRLI A,TFRAME + PUSH TP,A + PUSH TP,B +GENTV: MOVEI A,2 + PUSHJ P,IEVECT + MOVSI A,TTAG + JRST FINIS + +PROGCH: MOVE B,MQUOTE LPROG,[LPROG ]INTRUP + PUSHJ P,ILVAL ;GET VALUE + GETYP 0,A + CAIE 0,TACT + JRST NXPRG + POPJ P, + +; HERE TO UNASSIGN LPROG IF NEC + +UNPROG: MOVE B,MQUOTE LPROG,[LPROG ]INTRUP + PUSHJ P,ILVAL + GETYP 0,A + CAIE 0,TACT ; SKIP IF MUST UNBIND + JRST UNMAP + MOVSI A,TUNBOU + MOVNI B,1 + MOVE E,MQUOTE LPROG,[LPROG ]INTRUP + PUSHJ P,PSHBND +UNMAP: HRRZ 0,FSAV(TB) ; CHECK FOR FUNNY + CAIN 0,MAPPLY ; SKIP IF NOT + POPJ P, + MOVE B,MQUOTE LMAP,[LMAP ]INTRUP + PUSHJ P,ILVAL + GETYP 0,A + CAIE 0,TFRAME + JRST UNSPEC + MOVSI A,TUNBOU + MOVNI B,1 + MOVE E,MQUOTE LMAP,[LMAP ]INTRUP + PUSHJ P,PSHBND +UNSPEC: PUSH TP,BNDV + MOVE B,PVP + ADD B,[CURFCN,,CURFCN] + PUSH TP,B + PUSH TP,$TSP + MOVE E,SP + ADD E,[3,,3] + PUSH TP,E + POPJ P, + +REPEAT 0,[ +MFUNCTION MEXIT,SUBR,[EXIT] + ENTRY 2 + GETYP A,(AB) + CAIE A,TACT + JRST WTYP1 + MOVEI B,(AB) + PUSHJ P,CHFSWP + ADD C,[2,,2] + PUSHJ P,CHUNW ;RESTORE FRAME + JRST CHFINI ; CHECK FOR WINNING VALUE +] + +MFUNCTION COND,FSUBR + ENTRY 1 + GETYP A,(AB) + CAIE A,TLIST + JRST WRONGT + PUSH TP,(AB) + PUSH TP,1(AB) ;CREATE UNNAMED TEMP + MOVEI B,0 ; SET TO FALSE IN CASE + +CLSLUP: SKIPN C,1(TB) ;IS THE CLAUSELIST NIL? + JRST IFALS1 ;YES -- RETURN NIL + GETYP A,(C) ;NO -- GET TYPE OF CAR + CAIE A,TLIST ;IS IT A LIST? + JRST BADCLS ; + MOVE A,1(C) ;YES -- GET CLAUSE + JUMPE A,BADCLS + GETYPF B,(A) + PUSH TP,B ; EVALUATION OF + HLLZS (TP) + PUSH TP,1(A) ;THE PREDICATE + JSP E,CHKARG + MCALL 1,EVAL + GETYP 0,A + CAIN 0,TFALSE + JRST NXTCLS ;FALSE TRY NEXT CLAUSE + MOVE C,1(TB) ;IF NOT, DO FIRST CLAUSE + MOVE C,1(C) + HRRZ C,(C) + JUMPE C,FINIS ;(UNLESS DONE WITH IT) + JRST DOPRG2 ;AS THOUGH IT WERE A PROG +NXTCLS: HRRZ C,@1(TB) ;SET THE CLAUSLIST + HRRZM C,1(TB) ;TO CDR OF THE CLAUSLIST + JRST CLSLUP + +IFALSE: + MOVEI B,0 +IFALS1: MOVSI A,TFALSE ;RETURN FALSE + JRST FINIS + + + +MFUNCTION UNWIND,FSUBR + + ENTRY 1 + + GETYP 0,(AB) ; CHECK THE ARGS FOR WINNAGE + SKIPN A,1(AB) ; NONE? + JRST TFA + HRRZ B,(A) ; CHECK FOR 2D + JUMPE B,TFA + HRRZ 0,(B) ; 3D? + JUMPN 0,TMA + +; Unbind LPROG and LMAPF so that nothing cute happens + + PUSHJ P,UNPROG + +; Push thing to do upon UNWINDing + + PUSH TP,$TLIST + PUSH TP,[0] + + MOVEI C,UNWIN1 + PUSHJ P,IUNWIN ; GOT TO INTERNAL SET UP + +; Now EVAL the first form + + MOVE A,1(AB) + HRRZ 0,(A) ; SAVE POINTER TO OTHER GUY + MOVEM 0,-12(TP) + MOVE B,1(A) + GETYP A,(A) + MOVSI A,(A) + JSP E,CHKAB ; DEFER? + PUSH TP,A + PUSH TP,B + MCALL 1,EVAL ; EVAL THE LOSER + + JRST FINIS + +; Now push slots to hold undo info on the way down + +IUNWIN: +REPEAT 0,[ + JUMPE M,NOTRSB + MOVEI C,(C) + HLRE 0,M + SUBM M,0 + ANDI 0,-1 + CAIL C,HIBOT + JRST NOTRSB + CAIL C,(M) + CAML C,0 + JRST .+2 + SUBI C,(M) +NOTRSB:] + PUSH TP,$TTB ; DESTINATION FRAME + PUSH TP,[0] + PUSH TP,[0] ; ARGS TO WHOEVER IS DOING IT + PUSH TP,[0] + +; Now bind UNWIND word + + PUSH TP,$TUNWIN ; FIRST WORD OF IT + HRRM SP,(TP) ; CHAIN + MOVE SP,TP + PUSH TP,TB ; AND POINT TO HERE + PUSH TP,$TTP + PUSH TP,[0] + HRLI C,TPDL + PUSH TP,C + PUSH TP,P ; SAVE PDL ALSO + MOVEM TP,-2(TP) ; SAVE FOR LATER + POPJ P, + +; Do a non-local return with UNWIND checking + +CHUNW: HRRZ E,SPSAV(B) ; GET DESTINATION FRAME +CHUNW1: PUSH TP,(C) ; FINAL VAL + PUSH TP,1(C) + JUMPN C,.+3 ; WAS THERE REALLY ANYTHING + SETZM (TP) + SETZM -1(TP) + PUSHJ P,STLOOP ; UNBIND +CHUNPC: SKIPA ; WILL NOT SKIP UNLESS UNWIND FOUND + JRST GOTUND + MOVEI A,(TP) + SUBI A,(SP) + MOVSI A,(A) + HLL SP,TP + SUB SP,A + HRRI TB,(B) ; UPDATE TB + POP TP,B + POP TP,A + POPJ P, + +; Here if an UNDO found + +GOTUND: MOVE TB,1(SP) ; GET FRAME OF UNDO + MOVE A,-1(TP) ; GET FUNNY ARG FOR PASS ON + MOVE C,(TP) + MOVE TP,3(SP) ; GET FUTURE TP + MOVEM C,-6(TP) ; SAVE ARG + MOVEM A,-7(TP) + MOVE C,(TP) ; SAVED P + SUB C,[1,,1] + MOVEM C,PSAV(TB) ; MAKE CONTIN WIN + MOVEM TP,TPSAV(TB) + MOVEM SP,SPSAV(TB) + HRRZ C,(P) ; PC OF CHUNW CALLER + HRRM C,-11(TP) ; SAVE ALSO AND GET WHERE TO GO PC + MOVEM B,-10(TP) ; AND DESTINATION FRAME + HRRZ C,-1(TP) ; WHERE TO UNWIND PC + HRRZ 0,FSAV(TB) ; RSUBR? + CAMG 0,VECTOP + CAMGE 0,VECBOT + TLZA C,-1 ; 0 LH OF C AND SKIP + HRLI C,M ; RELATIVIZE + MOVEM C,PCSAV(TB) + JRST CONTIN + +UNWIN1: MOVE B,-12(TP) ; POINT TO THING TO DO UNWINDING + GETYP A,(B) + MOVSI A,(A) + MOVE B,1(B) + JSP E,CHKAB + PUSH TP,A + PUSH TP,B + MCALL 1,EVAL +UNWIN2: MOVEI C,-7(TP) ; POINT TO SAVED RET VALS + MOVE B,-10(TP) + HRRZ E,-11(TP) + PUSH P,E + HRRZ SP,(SP) ; UNBIND THIS GUY + MOVEI E,(TP) ; AND FIXUP SP + SUBI E,(SP) + MOVSI E,(E) + HLL SP,TP + SUB SP,E + JRST CHUNW ; ANY MORE TO UNWIND? + + +; CHFSWP - CHECK FRAMES VALIDITY AND SWAP PROCESS IF NECESSARY. +; CALLED BY ALL CONTROL FLOW +; ROUTINES (GO,RETURN,EXIT,AGAIN,ERRET...) + +CHFSWP: PUSHJ P,CHFRM ; CHECK FOR VALID FRAME + HRRZ D,(B) ; PROCESS VECTOR DOPE WD + HLRZ C,(D) ; LENGTH + SUBI D,-1(C) ; POINT TO TOP + MOVNS C ; NEGATE COUNT + HRLI D,2(C) ; BUILD PVP + MOVE E,PVP + MOVE C,AB + MOVE A,(B) ; GET FRAME + MOVE B,1(B) + CAMN E,D ; SKIP IF SWAP NEEDED + POPJ P, + PUSH TP,A ; SAVE FRAME + PUSH TP,B + MOVE B,D + PUSHJ P,PROCHK ; FIX UP PROCESS LISTS + MOVE A,PSTAT+1(B) ; GET STATE + CAIE A,RESMBL + JRST NOTRES + MOVE D,B ; PREPARE TO SWAP + POP P,0 ; RET ADDR + POP TP,B + POP TP,A + JSP C,SWAP ; SWAP IN + MOVE C,ABSTO+1(E) ; GET OLD ARRGS + MOVEI A,RUNING ; FIX STATES + MOVEM A,PSTAT+1(PVP) + MOVEI A,RESMBL + MOVEM A,PSTAT+1(E) + JRST @0 + +NOTRES: PUSH TP,$TATOM + PUSH TP,EQUOTE PROCESS-NOT-RESUMABLE + JRST CALER1 + + +;SETG IS USED TO SET THE GLOBAL VALUE OF ITS FIRST ARGUMENT, +;AN IDENTIFIER, TO THE VALUE OF ITS SECOND ARGUMENT. ITS VALUE IS +; ITS SECOND ARGUMENT. + +MFUNCTION SETG,SUBR + ENTRY 2 + GETYP A,(AB) ;GET TYPE OF FIRST ARGUMENT + CAIE A,TATOM ;CHECK THAT IT IS AN ATOM + JRST NONATM ;IF NOT -- ERROR + MOVE B,1(AB) ;GET POINTER TO ATOM + PUSH TP,$TATOM + PUSH TP,B + MOVEI 0,(B) + CAIL 0,HIBOT ; PURE ATOM? + PUSHJ P,IMPURIFY ; YES IMPURIFY + PUSHJ P,IGLOC ;GET LOCATIVE TO VALUE + CAMN A,$TUNBOUND ;IF BOUND + PUSHJ P,BSETG ;IF NOT -- BIND IT + MOVE C,2(AB) ; GET PROPOSED VVAL + MOVE D,3(AB) + MOVSI A,TLOCD ; MAKE SURE MONCH WINS + PUSHJ P,MONCH0 ; WOULD YOU BELIEVE MONITORS!!!! + EXCH D,B ;SAVE PTR + MOVE A,C + HRRZ E,-2(D) ; POINT TO POSSIBLE GDECL (OR MAINIFEST) + JUMPE E,OKSETG ; NONE ,OK + CAIE E,-1 ; MANIFEST? + JRST SETGTY + GETYP 0,(D) ; IF UNBOUND, LET IT HAPPEN + SKIPN IGDECL + CAIN 0,TUNBOU + JRST OKSETG +MANILO: GETYP C,(D) + GETYP 0,2(AB) + CAIN 0,(C) + CAME B,1(D) + JRST .+2 + JRST OKSETG + PUSH TP,$TVEC + PUSH TP,D + MOVE B,MQUOTE REDEFINE + PUSHJ P,ILVAL ; SEE IF REDEFINE OK + GETYP A,A + CAIE A,TUNBOU + CAIN A,TFALSE + JRST .+2 + JRST OKSTG + PUSH TP,$TATOM + PUSH TP,EQUOTE ATTEMPT-TO-CHANGE-MANIFEST-VARIABLE + PUSH TP,$TATOM + PUSH TP,1(AB) + MOVEI A,2 + JRST CALER + +SETGTY: PUSH TP,$TVEC + PUSH TP,D + MOVE C,A + MOVE D,B + GETYP A,(E) + MOVSI A,(A) + MOVE B,1(E) + JSP E,CHKAB + PUSHJ P,TMATCH + JRST TYPMI3 + +OKSTG: MOVE D,(TP) + MOVE A,2(AB) + MOVE B,3(AB) + +OKSETG: MOVEM A,(D) ;DEPOSIT INTO THE + MOVEM B,1(D) ;INDICATED VALUE CELL + JRST FINIS + +TYPMI3: MOVE C,(TP) + HRRZ C,-2(C) + MOVE D,2(AB) + MOVE B,3(AB) + MOVE 0,(AB) + MOVE A,1(AB) + JRST TYPMIS + +BSETG: HRRZ A,GLOBASE+1(TVP) + HRRZ B,GLOBSP+1(TVP) + SUB B,A + CAIL B,6 + JRST SETGIT + MOVEI B,0 ; MAKE SURE OF NO EMPTY SLOTS + PUSHJ P,IGLOC + CAMN A,$TUNBOU ; SKIP IF SLOT FOUND + JRST BSETG1 + MOVE E,(TP) ; GET ATOM + MOVEM E,-1(B) ; CLOBBER ATOM SLOT + POPJ P, +; BSETG1: PUSH TP,GLOBASE(TVP) ; MUST REALLY GROW STACK +; PUSH TP,GLOBASE+1 (TVP) +; PUSH TP,$TFIX +; PUSH TP,[0] +; PUSH TP,$TFIX +; PUSH TP,[100] +; MCALL 3,GROW +BSETG1: PUSH P,0 + PUSH P,C + MOVE C,GLOBASE+1(TVP) + HLRE B,C + SUB C,B + MOVE B,GVLINC ; GROW BY INDICATED GVAL SLOTS + DPB B,[001100,,(C)] +; MOVEM A,GLOBASE(TVP) + MOVE C,[6,,4] ; INDICATOR FOR AGC + PUSHJ P,AGC + MOVE B,GLOBASE+1(TVP) + MOVE 0,GVLINC ; ADJUST GLOBAL SPBASE + ASH 0,6 + SUB B,0 + HRLZS 0 + SUB B,0 + MOVEM B,GLOBASE+1(TVP) +; MOVEM B,GLOBASE+1(TVP) + POP P,0 + POP P,C +SETGIT: + MOVE B,GLOBSP+1(TVP) + SUB B,[4,,4] + MOVSI C,TGATOM + MOVEM C,(B) + MOVE C,(TP) + MOVEM C,1(B) + MOVEM B,GLOBSP+1(TVP) + ADD B,[2,,2] + MOVSI A,TLOCI + POPJ P, + + +MFUNCTION DEFMAC,FSUBR + + ENTRY 1 + + PUSH P,. + JRST DFNE2 + +MFUNCTION DFNE,FSUBR,[DEFINE] + + ENTRY 1 + + PUSH P,[0] +DFNE2: GETYP A,(AB) + CAIE A,TLIST + JRST WRONGT + SKIPN B,1(AB) ; GET ATOM + JRST TFA + GETYP A,(B) ; MAKE SURE ATOM + MOVSI A,(A) + PUSH TP,A + PUSH TP,1(B) + JSP E,CHKARG + MCALL 1,EVAL ; EVAL IT TO AN ATOM + CAME A,$TATOM + JRST NONATM + PUSH TP,A ; SAVE TWO COPIES + PUSH TP,B + PUSHJ P,IGVAL ; SEE IF A VALUE EXISTS + CAMN A,$TUNBOU ; SKIP IF A WINNER + JRST .+3 + PUSHJ P,ASKUSR ; CHECK WITH USER + JRST DFNE1 + PUSH TP,$TATOM + PUSH TP,-1(TP) + MOVE B,1(AB) + HRRZ B,(B) + MOVSI A,TEXPR + SKIPN (P) ; SKIP IF MACRO + JRST DFNE3 + MOVEI D,(B) ; READY TO CONS + MOVSI C,TEXPR + PUSHJ P,INCONS + MOVSI A,TMACRO +DFNE3: PUSH TP,A + PUSH TP,B + MCALL 2,SETG +DFNE1: POP TP,B ; RETURN ATOM + POP TP,A + JRST FINIS + + +ASKUSR: MOVE B,MQUOTE REDEFINE + PUSHJ P,ILVAL ; SEE IF REDEFINE OK + GETYP A,A + CAIE A,TUNBOU + CAIN A,TFALSE + JRST ASKUS1 + JRST ASKUS2 +ASKUS1: PUSH TP,$TATOM + PUSH TP,-1(TP) + PUSH TP,$TATOM + PUSH TP,EQUOTE ALREADY-DEFINED-ERRET-NON-FALSE-TO-REDEFINE + MCALL 2,ERROR + GETYP 0,A + CAIE 0,TFALSE +ASKUS2: AOS (P) + MOVE B,1(AB) + POPJ P, + + + +;SET CLOBBERS THE LOCAL VALUE OF THE IDENTIFIER GIVEN BY ITS +;FIRST ARGUMENT TO THE SECOND ARG. ITS VALUE IS ITS SECOND ARGUMENT. + +MFUNCTION SET,SUBR + HLRE D,AB ; 2 TIMES # OF ARGS TO D + ASH D,-1 ; - # OF ARGS + ADDI D,2 + JUMPG D,TFA ; NOT ENOUGH + MOVE B,PVP + MOVE C,SP + JUMPE D,SET1 ; NO ENVIRONMENT + AOJL D,TMA ; TOO MANY + GETYP A,4(AB) ; CHECK ARG IS A FRAME OR PROCESS + CAIE A,TFRAME + CAIN A,TENV + JRST SET2 ; WINNING ENVIRONMENT/FRAME + CAIN A,TACT + JRST SET2 ; TO MAKE PFISTER HAPPY + CAIE A,TPVP + JRST WTYP2 + MOVE B,5(AB) ; GET PROCESS + MOVE C,SPSTO+1(B) + JRST SET1 +SET2: MOVEI B,4(AB) ; POINT TO FRAME + PUSHJ P,CHFRM ; CHECK IT OUT + MOVE B,5(AB) ; GET IT BACK + MOVE C,SPSAV(B) ; GET BINDING POINTER + HRRZ B,4(AB) ; POINT TO PROCESS + HLRZ A,(B) ; GET LENGTH + SUBI B,-1(A) ; POINT TO START THEREOF + HLL B,PVP ; GET -LNTRH, (ALL PROCESS VECS SAME LENGTH) +SET1: PUSH TP,$TPVP ; SAVE PROCESS + PUSH TP,B + PUSH TP,$TSP ; SAVE PATH POINTER + PUSH TP,C + GETYP A,(AB) ;GET TYPE OF FIRST + CAIE A,TATOM ;ARGUMENT -- + JRST WTYP1 ;BETTER BE AN ATOM + MOVE B,1(AB) ;GET PTR TO IT + MOVEI 0,(B) + CAIL 0,HIBOT + PUSHJ P,IMPURIFY + MOVE C,(TP) + PUSHJ P,AILOC ;GET LOCATIVE TO VALUE +GOTLOC: CAMN A,$TUNBOUND ;BOUND? + PUSHJ P, BSET ;BIND IT + SUB TP,[4,,4] + MOVE C,2(AB) ; GET NEW VAL + MOVE D,3(AB) + MOVSI A,TLOCD ; FOR MONCH + HRR A,2(B) + PUSHJ P,MONCH0 ; HURRAY FOR MONITORS!!!!! + MOVE E,B + HLRZ A,2(E) ; GET DECLS + JUMPE A,SET3 ; NONE, GO + PUSH TP,$TSP + PUSH TP,E + MOVE B,1(A) + HLLZ A,(A) ; GET PATTERN + PUSHJ P,TMATCH ; MATCH TMEM + JRST TYPMI2 ; LOSES + MOVE E,(TP) + SUB TP,[2,,2] + MOVE C,2(AB) + MOVE D,3(AB) +SET3: MOVEM C,(E) ;CLOBBER IDENTIFIER + MOVEM D,1(E) + MOVE A,C + MOVE B,D + JRST FINIS +BSET: + CAMN PVP,-2(TP) ; SKIP IF PROC DIFFERS + MOVEM C,-2(TP) ; ELSE USE RESULT FROM LOC SEARCH + MOVE B,-2(TP) ; GET PROCESS + HRRZ A,TPBASE+1(B) ;GET ACTUAL STACK BASE + HRRZ B,SPBASE+1(B) ;AND FIRST BINDING + SUB B,A ;ARE THERE 6 + CAIL B,6 ;CELLS AVAILABLE? + JRST SETIT ;YES + MOVE C,(TP) ; GET POINTER BACK + MOVEI B,0 ; LOOK FOR EMPTY SLOT + PUSHJ P,AILOC + CAMN A,$TUNBOUND ; SKIP IF FOUND + JRST BSET1 + MOVE E,1(AB) ; GET ATOM + MOVEM E,-1(B) ; AND STORE + JRST BSET2 +BSET1: MOVE B,-2(TP) ; GET PROCESS +; PUSH TP,TPBASE(B) ;NO -- GROW THE TP +; PUSH TP,TPBASE+1(B) ;AT THE BASE END +; PUSH TP,$TFIX +; PUSH TP,[0] +; PUSH TP,$TFIX +; PUSH TP,[100] +; MCALL 3,GROW +; MOVE C,-2(TP) ; GET PROCESS +; MOVEM A,TPBASE(C) ;SAVE RESULT + PUSH P,0 ; MANUALLY GROW VECTOR + PUSH P,C + MOVE C,TPBASE+1(B) + HLRE B,C + SUB C,B + MOVEI C,1(C) + CAME C,TPGROW + ADDI C,PDLBUF + MOVE D,LVLINC + DPB D,[001100,,-1(C)] + MOVE C,[5,,3] ; SET UP INDICATORS FOR AGC + PUSHJ P,AGC + MOVE B,TPBASE+1(PVP) ; MODIFY POINTER + MOVE 0,LVLINC ; ADJUST SPBASE POINTER + ASH 0,6 + SUB B,0 + HRLZS 0 + SUB B,0 + MOVEM B,TPBASE+1(PVP) + POP P,C + POP P,0 +; MOVEM B,TPBASE+1(C) +SETIT: MOVE C,-2(TP) ; GET PROCESS + MOVE B,SPBASE+1(C) + MOVEI A,-6(B) ;MAKE UP BINDING + HRRM A,(B) ;LINK PREVIOUS BIND BLOCK + MOVSI A,TBIND + MOVEM A,-6(B) + MOVE A,1(AB) + MOVEM A,-5(B) + SUB B,[6,,6] + MOVEM B,SPBASE+1(C) + ADD B,[2,,2] +BSET2: MOVE C,-2(TP) ; GET PROC + MOVSI A,TLOCI + HRR A,BINDID+1(C) + HLRZ D,OTBSAV(TB) ; TIME IT + MOVEM D,2(B) ; AND FIX IT + POPJ P, + +; HERE TO ELABORATE ON TYPE MISMATCH + +TYPMI2: MOVE C,(TP) ; FIND DECLS + HLRZ C,2(C) + MOVE D,2(AB) + MOVE B,3(AB) + MOVE 0,(AB) ; GET ATOM + MOVE A,1(AB) + JRST TYPMIS + + + +MFUNCTION NOT,SUBR + ENTRY 1 + GETYP A,(AB) ; GET TYPE + CAIE A,TFALSE ;IS IT FALSE? + JRST IFALSE ;NO -- RETURN FALSE + +TRUTH: + MOVSI A,TATOM ;RETURN T (VERITAS) + MOVE B,MQUOTE T + JRST FINIS + +MFUNCTION OR,FSUBR + + PUSH P,[0] + JRST ANDOR + +MFUNCTION ANDA,FSUBR,AND + + PUSH P,[1] +ANDOR: ENTRY 1 + GETYP A,(AB) + CAIE A,TLIST + JRST WRONGT ;IF ARG DOESN'T CHECK OUT + MOVE E,(P) + SKIPN C,1(AB) ;IF NIL + JRST TF(E) ;RETURN TRUTH + PUSH TP,$TLIST ;CREATE UNNAMED TEMP + PUSH TP,C +ANDLP: + MOVE E,(P) + JUMPE C,TFI(E) ;ANY MORE ARGS? + MOVEM C,1(TB) ;STORE CRUFT + GETYP A,(C) + MOVSI A,(A) + PUSH TP,A + PUSH TP,1(C) ;ARGUMENT + JSP E,CHKARG + MCALL 1,EVAL + GETYP 0,A + MOVE E,(P) + XCT TFSKP(E) + JRST FINIS ;IF FALSE -- RETURN + HRRZ C,@1(TB) ;GET CDR OF ARGLIST + JRST ANDLP + +TF: JRST IFALSE + JRST TRUTH + +TFI: JRST IFALS1 + JRST FINIS + +TFSKP: CAIE 0,TFALSE + CAIN 0,TFALSE + +MFUNCTION FUNCTION,FSUBR + + ENTRY 1 + + MOVSI A,TEXPR + MOVE B,1(AB) + JRST FINIS + + + +MFUNCTION CLOSURE,SUBR + ENTRY + SKIPL A,AB ;ANY ARGS + JRST TFA ;NO -- LOSE + ADD A,[2,,2] ;POINT AT IDS + PUSH TP,$TAB + PUSH TP,A + PUSH P,[0] ;MAKE COUNTER + +CLOLP: SKIPL A,1(TB) ;ANY MORE IDS? + JRST CLODON ;NO -- LOSE + PUSH TP,(A) ;SAVE ID + PUSH TP,1(A) + PUSH TP,(A) ;GET ITS VALUE + PUSH TP,1(A) + ADD A,[2,,2] ;BUMP POINTER + MOVEM A,1(TB) + AOS (P) + MCALL 1,VALUE + PUSH TP,A + PUSH TP,B + MCALL 2,LIST ;MAKE PAIR + PUSH TP,A + PUSH TP,B + JRST CLOLP + +CLODON: POP P,A + ACALL A,LIST ;MAKE UP LIST + PUSH TP,(AB) ;GET FUNCTION + PUSH TP,1(AB) + PUSH TP,A + PUSH TP,B + MCALL 2,LIST ;MAKE LIST + MOVSI A,TFUNARG + JRST FINIS + + + +;ERROR COMMENTS FOR EVAL +TUPTFA: PUSH TP,$TATOM + PUSH TP,EQUOTE TOO-FEW-ARGS-FOR-ITUPLE + JRST CALER1 + +TUPTMA: PUSH TP,$TATOM + PUSH TP,EQUOTE TOO-MANY-ARGS-TO-ITUPLE + JRST CALER1 + +BADNUM: PUSH TP,$TATOM + PUSH TP,EQUOTE NEGATIVE-ARG-TO-ITUPLE + JRST CALER1 + +WTY1TP: PUSH TP,$TATOM + PUSH TP,EQUOTE FIRST-ARG-TO-ITUPLE-NOT-FIX + JRST CALER1 + +UNBOU: PUSH TP,$TATOM + PUSH TP,EQUOTE UNBOUND-VARIABLE + JRST ER1ARG + +UNAS: PUSH TP,$TATOM + PUSH TP,EQUOTE UNASSIGNED-VARIABLE + JRST ER1ARG + +BADENV: + PUSH TP,$TATOM + PUSH TP,EQUOTE BAD-ENVIRONMENT + JRST CALER1 + +FUNERR: + PUSH TP,$TATOM + PUSH TP,EQUOTE BAD-FUNARG + JRST CALER1 + + +MPD.0: +MPD.1: +MPD.2: +MPD.3: +MPD.4: +MPD.5: +MPD.6: +MPD.7: +MPD.8: +MPD.9: +MPD.10: +MPD.11: +MPD.12: +MPD.13: +MPD: PUSH TP,$TATOM + PUSH TP,EQUOTE MEANINGLESS-PARAMETER-DECLARATION + JRST CALER1 + +NOBODY: PUSH TP,$TATOM + PUSH TP,EQUOTE HAS-EMPTY-BODY + JRST CALER1 + +BADCLS: PUSH TP,$TATOM + PUSH TP,EQUOTE BAD-CLAUSE + JRST CALER1 + +NXTAG: PUSH TP,$TATOM + PUSH TP,EQUOTE NON-EXISTENT-TAG + JRST CALER1 + +NXPRG: PUSH TP,$TATOM + PUSH TP,EQUOTE NOT-IN-PROG + JRST CALER1 + +NAPTL: +NAPT: PUSH TP,$TATOM + PUSH TP,EQUOTE NON-APPLICABLE-TYPE + JRST CALER1 + +NONEVT: PUSH TP,$TATOM + PUSH TP,EQUOTE NON-EVALUATEABLE-TYPE + JRST CALER1 + + +NONATM: PUSH TP,$TATOM + PUSH TP,EQUOTE NON-ATOMIC-ARGUMENT + JRST CALER1 + + +ILLFRA: PUSH TP,$TATOM + PUSH TP,EQUOTE FRAME-NO-LONGER-EXISTS + JRST CALER1 + +ILLSEG: PUSH TP,$TATOM + PUSH TP,EQUOTE ILLEGAL-SEGMENT + JRST CALER1 + +BADMAC: PUSH TP,$TATOM + PUSH TP,EQUOTE BAD-USE-OF-MACRO + JRST CALER1 + +BADFSB: PUSH TP,$TATOM + PUSH TP,EQUOTE APPLY-OR-STACKFORM-OF-FSUBR + JRST CALER1 + + +ER1ARG: PUSH TP,(AB) + PUSH TP,1(AB) + MOVEI A,2 + JRST CALER + +END + \ No newline at end of file diff --git a/sumex/fopen.mcr352 b/sumex/fopen.mcr352 new file mode 100644 index 0000000..7f0e38f --- /dev/null +++ b/sumex/fopen.mcr352 @@ -0,0 +1,3957 @@ +TITLE OPEN - CHANNEL OPENER FOR MUDDLE + +RELOCATABLE + +;C. REEVE MARCH 1973 + +.INSRT MUDDLE > + +SYSQ + +IFE ITS,[ +IF1, .INSRT MUDSYS;STENEX > +] +;THIS PROGRAM HAS ENTRIES: FOPEN, FCLOSE, RENAME, READB, PRINTB, FILECOPY, READSTRING, +; PRINTSTRING, NETSTATE, NETACC, NETS, AND ACCESS. + +;THESE SUBROUTINES HANDLE I/O STREAMS FOR THE MUDDLE SYSTEM. + +; FOPEN - OPENS A FILE FOR EITHER READING OR WRITING. IT TAKES +; FIVE OPTINAL ARGUMENTS AS FOLLOWS: + +; FOPEN (,,,,) +; +; - DIRECTION EITHER READ (INPUT) OR PRINT (OUPUT). DEFAULT IS READ + +; - FIRST FILE NAME. DEFAULT INPUT OR OUTPUT. + +; - SECOND FILE NAME. DEFAULT MUDDLE. + +; - DEVICE FROM WHICH TO OPEN. DEFAULT IS DSK. + +; - SYSTEM (DIRECTORY) NAME. DEFAULT UNAME. + +; FOPEN RETURNS AN OBJECT OF TYPE CHANNEL IF IT SUCCEEDS OTHERWISE NIL + + +; FCLOSE - CLOSES A FILE. TAKES A CHANNEL OBJECT AS ITS ARGUMENT. IT ALSO TAKES +; ACCESS - DOES A .ACCESS ON A CHARACTER BASIS FOR CHARACTER FILES + + +; A CHANNEL OBJECT IS A VECTOR CONTAINIG THE FOLLOWING INFORMATION + +; CHANNO ;ITS I/O CHANNEL NUMBER. 0 MEANS NOT A REAL CHANNEL. +; DIRECT ;DIRECTION (EITHER READ OR PRINT) +; NAME1 ;FIRST NAME OF FILE AS OPENED. +; NAME2 ;SECOND NAME OF FILE +; DEVICE ;DEVICE UPON WHICH THE CHANNEL IS OPEN +; SNAME ;DIRECTORY NAME +; RNAME1 ;REAL FIRST NAME (AS RETURNED BY READING CHANNEL STATUS) +; RNAME2 ;REAL SECOND NAME +; RDEVIC ;REAL DEVICE +; RSNAME ;SYSTEM OR DIRECTORY NAME +; STATUS ;VARIOUS STATUS BITS +; IOINS ;INSTRUCTION EXECUTED TO INPUT OR OUTPUT ONE CHARACTER +; ACCESS ;ACCESS POINTER FOR RAND ACCESS (OR USED FOR DISPLAY INFO) +; RADX ;RADIX FOR CHANNELS NUMBER CONVERSION + +; *** THE FOLLOWING FIELDS FOR OUTPUT ONLY *** +; LINLN ;LENGTH OF A LINE IN CHARACTERS FOR THIS DEVICE +; CHRPOS ;CURRENT POSITION ON CURRENT LINE +; PAGLN ;LENGTH OF A PAGE +; LINPOS ;CURRENT LINE BEING WRITTEN ON + +; *** THE FOLLOWING FILEDS FOR INPUT ONLY *** +; EOFCND ;GETS EVALUATED ON EOF +; LSTCH ;BACKUP CHARACTER +; WAITNS ;FOR TTY INPUT, BECOMES A .SLEEP WHEN WAITING +; EXBUFR ;FOR TTY INPUT, CONTAINS A WAITING BUFFER LIST +; BUFSTR ;A CHARACTER STRING USED AS BUFFER FOR NON-TTY DEVICES + +; THIS DEFINES THE LENGTH OF THE NON-TTY BUFFER +BUFLNT==100 + +;THIS DEFINES BLOCK MODE BIT FOR OPENING +BLOCKM==2 ;DEFINED IN THE LEFT HALF +IMAGEM==4 + + +;THIS IRP DEFINES THE FIELDS AT ASSEMBLY TIME + + CHANLNT==4 ;INITIAL CHANNEL LENGTH + +; BUILD A PROTOTYPE CHANNEL AND DEFINE FILEDS +BUFRIN==-1 ;SPECIAL HACK SO LOSERS WON'T SEE TTY BUFFER +SCRPTO==-3 ;SPECIAL HACK FOR SCRIPT CHANNELS +PROCHN: + +IRP A,,[[CHANNO,FIX],[DIRECT,CHSTR] +[NAME1,CHSTR],[NAME2,CHSTR],[DEVICE,CHSTR],[SNAME,CHSTR] +[RNAME1,CHSTR],[RNAME2,CHSTR],[RDEVIC,CHSTR],[RSNAME,CHSTR] +[STATUS,FIX],[IOINS,FIX],[LINLN,FIX],[CHRPOS,FIX],[PAGLN,FIX],[LINPOS,FIX] +[ACCESS,FIX],[RADX,FIX],[BUFSTR,CHSTR]] + + IRP B,C,[A] + B==CHANLNT-3 + T!C,,0 + 0 + .ISTOP + TERMIN + CHANLNT==CHANLNT+2 +TERMIN + + +; EQUIVALANCES FOR CHANNELS + +EOFCND==LINLN +LSTCH==CHRPOS +WAITNS==PAGLN +EXBUFR==LINPOS +DISINF==BUFSTR ;DISPLAY INFO +INTFCN==BUFSTR ;FUNCTION (OR SUBR, OR RSUBR) TO BE APPLIED FOR INTERNAL CHNLS + + +;DEFINE VARIABLES ASSOCIATED WITH TTY BUFFERS + +IRP A,,[IOIN2,ECHO,CHRCNT,ERASCH,KILLCH,BRKCH,ESCAP,SYSCHR,BRFCHR,BRFCH2,BYTPTR] +A==.IRPCNT +TERMIN + +EXTBFR==BYTPTR+1+<100./5> ;LENGTH OF ADD'L BUFFER + + + + +.GLOBAL IPNAME,MOPEN,MCLOSE,MIOT,ILOOKU,6TOCHS,ICLOS,OCLOS,RGPARS,RGPRS +.GLOBAL OPNCHN,CHMAK,READC,TYO,SYSCHR,BRFCHR,LSTCH,BRFCH2,EXTBFR +.GLOBAL CHRWRD,STRTO6,TTYBLK,WAITNS,EXBUFR,TTICHN,TTOCHN,GETCHR +.GLOBAL CHANNO,STATUS,LINPOS,PAGLN,CHRPOS,LINLN,IOINS,ACCESS +.GLOBAL DIRECT,DISINF,RADX,EOFCND,BUFSTR,MODE1,MODE2,GCHACK,GMTYO +.GLOBAL T.CHAN,NAME1,BFCLOS,DOIOTI,DOIOTO,DOACCS,NOTTY,BYTDOP,TNXIN +.GLOBAL DISOPN,DISROP,DISCLS,DCHAR,DISLNL,DISPGL,INSTAT,MTYO +.GLOBAL ECHO,ERASCH,KILLCH,BRKCH,BYTPTR,SYSCHR,CHRCNT,ESCAP,N.CHNS +.GLOBAL REOPN,QUITTE,CHNL0,CHNL1,BUFRIN,IOIN2,IFALSE,GFALS,IDVAL +.GLOBAL BADCHN,WRONGD,CHNCLS,GSNAME,GIBLOK,APLQ,NAPT,ICONS,INCONS,IBLOCK,IDVAL1 +.GLOBAL GRB,GWB,R1CHAR,W1CHAR,BFCLS1,TTYOP2,MPOPJ,COMPER,R1C,W1C,WXCT,RXCT +.GLOBAL TMTNXS,TNXSTR,RDEVIC + + +.VECT.==40000 + +; PAIR MOVING MACRO + +DEFINE PMOVEM A,B + MOVE 0,A + MOVEM 0,B + MOVE 0,A+1 + MOVEM 0,B+1 + TERMIN + +; DEFINITIONS OF THE OFFSETS INTO THE TP STACK FOR OPEN + +T.SPDL==0 ; SAVES P STACK BASE +T.DIR==2 ; CONTAINS DIRECTION AND MODE +T.NM1==4 ; NAME 1 OF FILE +T.NM2==6 ; NAME 2 OF FILE +T.DEV==10 ; DEVICE NAME +T.SNM==12 ; SNAME +T.XT==14 ; EXTRA CRUFT IF NECESSARY +T.CHAN==16 ; CHANNEL AS GENERATED + +; OFFSETS FROM PSTACK BASE (USED FOR OPENS, .RCHST AND .FDELES) + +S.DIR==0 ; CODE FOR DIRECTION 0-IN, 1-OUT, 2-BIN, 3-BOUT,4-DISPLAY +IFN ITS,[ +S.DEV==1 ; SIXBIT DEVICE RIGHT JUSTIFIED +S.NM1==2 ; SIXBIT NAME1 +S.NM2==3 ; SIXBIT NAME2 +S.SNM==4 ; SIXBIT SNAME +S.X1==5 ; TEMPS +S.X2==6 +S.X3==7 +] + +IFE ITS,[ +S.DEV==1 +S.X1==2 +S.X2==3 +S.X3==4 +] + + +; FLAGS SPECIFYING STATE OF THE WORLD AT VARIOUS TIMES + +NOSTOR==400000 ; ON MEANS DONT BUILD NEW STRINGS +MSTNET==200000 ; ON MEANS ONLY THE "NET" DEVICE CAN WIN +SNSET==100000 ; FLAG, SNAME SUPPLIED +DVSET==040000 ; FLAG, DEV SUPPLIED +N2SET==020000 ; FLAG, NAME2 SET +N1SET==010000 ; FLAG, NAME1 SET + +RMT [EXPUNGE N1SET,N2SET,DVSET,SNSET,MSTNET,NOSTOR +] + + +; TABLE OF LEGAL MODES + +MODES: IRP A,,[READ,PRINT,READB,PRINTB,DISPLAY] + SIXBIT /A/ + TERMIN +NMODES==.-MODES + +; TABLE OF KNOWN DEVICES AND A POINTER TO THEIR OPENERS + +IFN ITS,[ + +DEVS: IRP A,,[DSK,TPL,SYS,COM,TTY,USR,STY,[ST ],NET,DIS,E&S,INT,PTP,PTR +[P ],[DK ],[UT ],[T ],NUL,[AI ] +[ML ],[DM ],[AR ],ARC]B,,[ODSK,ODSK,ODSK,ODSK,OTTY,OUSR,OSTY,OSTY,ONET,ODIS,ODIS +OINT,OPTP,OPTP,ODSK,ODSK,OUTN,OTTY,ONUL,ODSK,ODSK,ODSK,ODSK,ODSK] + B,,(SIXBIT /A/) + TERMIN +] +IFE ITS,[ +DEVS: IRP A,,[DSK,TTY,INT,NET]B,,[ODSK,OTTY,OINT,ONET] + B,,(SIXBIT /A/) + TERMIN +] +NDEVS==.-DEVS + + + +;SUBROUTINE TO DO OPENING BEGINS HERE + +MFUNCTION NFOPEN,SUBR,[OPEN-NR] + + JRST FOPEN1 + +MFUNCTION FOPEN,SUBR,[OPEN] + +FOPEN1: ENTRY + PUSHJ P,MAKCHN ;MAKE THE CHANNEL + PUSHJ P,OPNCH ;NOW OPEN IT + JRST FINIS + +; SUBR TO JUST CREATE A CHANNEL + +MFUNCTION CHANNEL,SUBR + + ENTRY + PUSHJ P,MAKCHN + MOVSI A,TCHAN + JRST FINIS + + + + +; THIS ROUTINE PARSES ARGUMENTS TO FOPEN ETC. AND BUILDS A CHANNEL BUT DOESN'T OPEN IT + +MAKCHN: PUSH TP,$TPDL + PUSH TP,P ; POINT AT CURRENT STACK BASE + PUSH TP,$TCHSTR + PUSH TP,CHQUOTE READ + MOVEI E,10 ; SLOTS OF TP NEEDED + PUSH TP,[0] + SOJG E,.-1 + MOVEI E,0 + EXCH E,(P) ; GET RET ADDR IN E +IFE ITS, PUSH P,[0] +IRP ATM,,[DEV,NM1,NM2,SNM]MDF,,[DSK,INPUT,>,[ ]]TMDF,,[DSK,INPUT,MUD,[ ]] + MOVE B,IMQUOTE ATM +IFN ITS, PUSH P,E + PUSHJ P,IDVAL1 + GETYP 0,A + CAIN 0,TCHSTR + JRST MAK!ATM + + MOVE A,$TCHSTR +IFN ITS, MOVE B,CHQUOTE MDF +IFE ITS, MOVE B,CHQUOTE TMDF +MAK!ATM: + MOVEM A,T.!ATM(TB) + MOVEM B,T.!ATM+1(TB) +IFN ITS,[ + POP P,E + PUSHJ P,STRTO6 ; RESULT LEFT ON P STACK AS DESIRED +] + TERMIN + PUSH TP,[0] ; PUSH SLOTS + PUSH TP,[0] + + PUSH P,[0] ; EXT SLOTS + PUSH P,[0] + PUSH P,[0] + PUSH P,E ; PUSH RETURN ADDRESS + MOVEI A,0 + + JUMPGE AB,MAKCH0 ; NO ARGS, ALREADY DONE + GETYP 0,(AB) ; 1ST ARG MUST BE A STRING + CAIE 0,TCHSTR + JRST WTYP1 + MOVE A,(AB) ; GET ARG + MOVE B,1(AB) + PUSHJ P,CHMODE ; CHECK OUT OPEN MODE + + PMOVEM (AB),T.DIR(TB) ; SAVE MODE NAME IN TEMPS + ADD AB,[2,,2] ; BUMP PAST DIRECTION + MOVEI A,0 + JUMPGE AB,MAKCH0 ; CHECK NAME1 BASED ON JUST MODE + + MOVEI 0,0 ; FLAGS PRESET + PUSHJ P,RGPARS ; PARSE THE STRING(S) + JRST TMA + +; ARGUMENTS PARSED, DO FINAL CHECKS AND BUILD CHANNEL + +MAKCH0: +IFN ITS,[ + MOVE C,T.SPDL+1(TB) + HLRZS D,S.DEV(C) ; GET DEV +] +IFE ITS,[ + MOVE A,T.DEV(TB) + MOVE B,T.DEV+1(TB) + PUSHJ P,STRTO6 + POP P,D + HLRZS D + MOVE C,T.SPDL+1(TB) + MOVEM D,S.DEV(C) +] + CAIE D,(SIXBIT /INT/); INTERNAL? + JRST CHNET ; NO, MAYBE NET + SKIPN T.XT+1(TB) ; WAS FCN SUPPLIED? + JRST TFA + +; FALLS TROUGH IF SKIP + + + +; NOW BUILD THE CHANNEL + +ARGSOK: MOVEI A,CHANLNT ; GET LENGTH + PUSHJ P,GIBLOK ; GET A BLOCK OF STUFF + ADD B,[4,,4] ; HIDE THE TTY BUFFER SLOT + PUSH TP,$TCHAN + PUSH TP,B + HRLI C,PROCHN ; POINT TO PROTOTYPE + HRRI C,(B) ; AND NEW ONE + BLT C,CHANLN-5(B) ; CLOBBER + MOVSI C,TLIST ; TO GIVE HIM A CLEAN LIST OF SCRIPT CHANS + MOVEM C,SCRPTO-1(B) + +; NOW BLT IN STUFF FROM THE STACK + + MOVSI C,T.DIR(TB) ; DIRECTION + HRRI C,DIRECT-1(B) + BLT C,SNAME(B) + MOVEI C,RNAME1-1(B) ; NOW "REAL" SLOTS + HRLI C,T.NM1(TB) + BLT C,RSNAME(B) + POPJ P, + +; HERE TO VALIDIFY ARGUMENTS FOR A NET OPEN + +CHNET: CAIE D,(SIXBIT /NET/) ; IS IT NET +IFN ITS, JRST MAKCH1 +IFE ITS,[ + JRST ARGSOK +] + MOVSI D,TFIX ; FOR TYPES + MOVEI B,T.NM1(TB) ; MAKE SURE ALL ARE FIXED + PUSHJ P,CHFIX + MOVEI B,T.NM2(TB) + PUSHJ P,CHFIX + MOVEI B,T.SNM(TB) + LSH A,-1 ; SKIP DEV FLAG + PUSHJ P,CHFIX + JRST ARGSOK + +MAKCH1: TRNN A,MSTNET ; CANT HAVE SEEN A FIX + JRST ARGSOK + JRST WRONGT + +IFN ITS,[ +CHFIX: TRNE A,N1SET ; SKIP IF NOT SPECIFIED + JRST CHFIX1 +] + SETOM 1(B) ; SET TO -1 + SETOM S.NM1(C) + MOVEM D,(B) ; CORRECT TYPE +IFE ITS,CHFIX: + GETYP 0,(B) + CAIE 0,TFIX + JRST PARSQ +CHFIX1: ADDI C,1 ; POINT TO NEXT FIELD + LSH A,-1 ; AND NEXT FLAG + POPJ P, +PARSQ: CAIE 0,TCHSTR + JRST WRONGT +IFE ITS, POPJ P, +IFN ITS,[ + PUSH P,A + PUSH P,C + PUSH TP,(B) + PUSH TP,1(B) + SUBI B,(TB) + PUSH P,B + MCALL 1,PARSE + GETYP 0,A + CAIE 0,TFIX + JRST WRONGT + POP P,C + ADDI C,(TB) + MOVEM A,(C) + MOVEM B,1(C) + POP P,C + POP P,A + POPJ P, +] + + +; SUBROUTINE TO CHECK VALIDITY OF MODE AND SAVE A CODE + +CHMODE: PUSHJ P,CHMOD ; DO IT + MOVE C,T.SPDL+1(TB) + HRRZM A,S.DIR(C) + POPJ P, + +CHMOD: PUSHJ P,STRTO6 ; TO SIXBIT + POP P,B ; VALUE ENDSUP ON STACK, RESTORE IT + + CAME B,[SIXBIT /PRINTO/] ; KLUDGE TO MAKE PRINTO AS PRINTB + JRST .+3 + MOVEI A,3 ; CODE FOR PRINTB + POPJ P, + + MOVSI A,-NMODES ; SCAN TO SEE IF LEGAL MODE + CAME B,MODES(A) + AOBJN A,.-1 + JUMPGE A,WRONGD ; ILLEGAL MODE NAME + POPJ P, + +IFN ITS,[ +; RGPARS -- PARSE THE STRINGS COMPRISING FILE NAMES INTO STANDARD ITS GOODIES + +RGPRS: MOVEI 0,NOSTOR ; DONT STORE STRINGS IF ENTER HERE + +RGPARS: HRLM 0,(P) ; LH IS FLAGS FOR THIS PROG + MOVSI E,-4 ; FIELDS TO FILL + +RPARGL: GETYP 0,(AB) ; GET TYPE + CAIE 0,TCHSTR ; STRING? + JRST ARGCLB ; NO, JUST CLOBBER IT IN RAW + JUMPGE E,CPOPJ ; DON'T DO ANY MORE + PUSH TP,(AB) ; GET AN ARG + PUSH TP,1(AB) + +FPARS: PUSH TP,-1(TP) ; ANOTHER COPY + PUSH TP,-1(TP) + PUSHJ P,FLSSP ; NO LEADING SPACES + MOVEI A,0 ; WILL HOLD SIXBIT + MOVEI B,6 ; CHARS PER 6BIT WORD + MOVE C,[440600,,A] ; BYTE POINTER INTO A + +FPARSL: HRRZ 0,-1(TP) ; GET COUNT + JUMPE 0,PARSD ; DONE + SOS -1(TP) ; COUNT + ILDB 0,(TP) ; CHAR TO 0 + + CAIE 0," ; FILE NAME QUOTE? + JRST NOCNTQ + HRRZ 0,-1(TP) + JUMPE 0,PARSD + SOS -1(TP) + ILDB 0,(TP) ; USE THIS + JRST GOTCNQ + +NOCNTQ: CAIG 0,40 ; SPACE? + JRST NDFLD ; YES, TERMINATE THIS FIELD + CAIN 0,": ; DEVICE ENDED? + JRST GOTDEV + CAIN 0,"; ; SNAME ENDED + JRST GOTSNM + +GOTCNQ: PUSHJ P,A0TO6 ; CONVERT TO 6BIT AND CHECK + + JUMPE B,FPARSL ; IGNORE IF AREADY HAVE 6 + IDPB 0,C + SOJA B,FPARSL + +; HERE IF SPACE ENCOUNTERED + +NDFLD: MOVEI D,(E) ; COPY GOODIE + PUSHJ P,FLSSP ; FLUSH REDUNDANT SPACES + JUMPE 0,PARSD ; NO CHARS LEFT + +NFL0: PUSH P,A ; SAVE SIXBIT WORD + PUSHJ P,6TOCHS ; CONVERT TO STRING + HRRZ 0,-1(TP) ; RESTORE CHAR COUNT + +NFL2: MOVEI C,(D) ; COPY REL PNTR + SKIPGE -1(P) ; SKIP IF STRINGS TO BE STORED + JRST NFL3 + ASH D,1 ; TIMES 2 + ADDI D,T.NM1(TB) + MOVEM A,(D) ; STORE + MOVEM B,1(D) +NFL3: MOVSI A,N1SET ; FLAG IT + LSH A,(C) + IORM A,-1(P) ; AND CLOBBER + MOVE D,T.SPDL+1(TB) ; GET P BASE + POP P,@SIXTBL(C) ; AND STORE SIXBIT OF IT + + POP TP,-2(TP) ; MAKE NEW STRING POINTER + POP TP,-2(TP) + JUMPE 0,.+3 ; SKIP IF NO MORE CHARS + AOBJN E,FPARS ; MORE TO PARSE? +CPOPJ: POPJ P, ; RETURN, ALL DONE + + SUB TP,[2,,2] ; FLUSH OLD STRING + ADD E,[1,,1] + ADD AB,[2,,2] ; BUMP ARG + JUMPL AB,RPARGL ; AND GO ON +CPOPJ1: AOS A,(P) ; PREPARE TO WIN + HLRZS A + POPJ P, + + + +; HERE IF STRING HAS ENDED + +PARSD: PUSH P,A ; SAVE 6 BIT + MOVE A,-3(TP) ; CAN USE ARG STRING + MOVE B,-2(TP) + MOVEI D,(E) + JRST NFL2 ; AND CONTINUE + +; HERE IF JUST READ DEV + +GOTDEV: MOVEI D,2 ; CODE FOR DEVICE + JRST GOTFLD ; GOT A FIELD + +; HERE IF JUST READ SNAME + +GOTSNM: MOVEI D,3 +GOTFLD: PUSHJ P,FLSSP + SOJA E,NFL0 + + +; HERE FOR NON STRING ARG ENCOUNTERED + +ARGCLB: SKIPGE (P) ; IF NOT STORING, CONSIDER THIS THE END + + POPJ P, + MOVE C,T.SPDL+1(TB) ; GET P-BASE + HLRZ A,S.DEV(C) ; GET DEVICE + CAIE A,(SIXBIT /INT/) ; IS IT THE INTERNAL DEVICE + JRST TRYNET ; NO, COUD BE NET + MOVE A,0 ; OFFNEDING TYPE TO A + PUSHJ P,APLQ ; IS IT APPLICABLE + JRST NAPT ; NO, LOSE + PMOVEM (AB),T.XT(TB) + ADD AB,[2,,2] ; MUST BE LAST ARG + JUMPL AB,TMA + JRST CPOPJ1 ; ELSE SUCCESSFUL RETURN +TRYNET: CAIE 0,TFIX ; FOR NET DEV, ARGS MUST BE FIX + JRST WRONGT ; TREAT AS WRONG TYPE + MOVSI A,MSTNET ; BETTER BE NET EVENTUALLY + IORM A,(P) ; STORE FLAGS + MOVSI A,TFIX + MOVE B,1(AB) ; GET NUMBER + MOVEI 0,(E) ; MAKE SURE NOT DEVICE + CAIN 0,2 + JRST WRONGT + PUSH P,B ; SAVE NUMBER + MOVEI D,(E) ; SET FOR TABLE OFFSETS + MOVEI 0,0 + ADD TP,[4,,4] + JRST NFL2 ; GO CLOBBER IT AWAY +] + + +; ROUTINE TO FLUSH LEADING SPACES FROM A FIELD + +FLSSP: HRRZ 0,-1(TP) ; GET CHR COUNNT + JUMPE 0,CPOPJ ; FINISHED STRING +FLSS1: MOVE B,(TP) ; GET BYTR + ILDB C,B ; GETCHAR + CAILE C,40 + JRST FLSS2 + MOVEM B,(TP) ; UPDATE BYTE POINTER + SOJN 0,FLSS1 + +FLSS2: HRRM 0,-1(TP) ; UPDATE STRING + POPJ P, + +IFN ITS,[ +;TABLE FOR STFUFFING SIXBITS AWAY + +SIXTBL: S.NM1(D) + S.NM2(D) + S.DEV(D) + S.SNM(D) + S.X1(D) +] + +RDTBL: RDEVIC(B) + RNAME1(B) + RNAME2(B) + RSNAME(B) + + + +IFE ITS,[ + +; TENEX VERSION OF FILE NAME PARSER (ONLY ACCEPT ARGS IN SINGLE STRING) + +RGPRS: MOVEI 0,NOSTOR + +RGPARS: HRLM 0,(P) ; SAVE FOR STORE CHECKING + CAMGE AB,[-7,,] ; MULTI-STRING CASE POSSIBLE? + JRST TN.MLT ; YES, GO PROCESS +RGPRSS: GETYP 0,(AB) ; CHECK ARG TYPE + CAIE 0,TCHSTR + JRST WRONGT ; FOR NOW ONLY STRING ARGS WIN + PUSH TP,(AB) + PUSH TP,1(AB) + PUSHJ P,FLSSP ; FLUSH LEADING SPACES + PUSHJ P,RGPRS1 + ADD AB,[2,,2] +CHKLST: JUMPGE AB,CPOPJ1 + SKIPGE (P) ; IF FROM OPEN, ALLOW ONE MORE + POPJ P, + PMOVEM (AB),T.XT(TB) + ADD AB,[2,,2] + JUMPL AB,TMA +CPOPJ1: AOS (P) + POPJ P, + +RGPRS1: PUSH P,[0] ; ALLOW A DEVICE SPEC +TN.SNM: MOVE A,(TP) + HRRZ 0,-1(TP) + JUMPE 0,RPDONE + ILDB A,A + CAIE A,"< ; START "DIRECTORY" ? + JRST TN.N1 ; NO LOOK FOR NAME1 + SETOM (P) ; DEV NOT ALLOWED + IBP (TP) ; SKIP CHAR + SOS -1(TP) + PUSHJ P,TN.CNT ; COUNT CHARS TO ">" + JUMPE B,ILLNAM ; RAN OUT + CAIE A,"> ; SKIP IF WINS + JRST ILLNAM + PUSHJ P,TN.CPS ; COPY TO NEW STRING + MOVEM A,T.SNM(TB) + MOVEM B,T.SNM+1(TB) + +TN.N1: PUSHJ P,TN.CNT + JUMPE B,RPDONE + CAIE A,": ; GOT A DEVICE + JRST TN.N11 + SKIPE (P) + JRST ILLNAM + SETOM (P) + PUSHJ P,TN.CPS + MOVEM A,T.DEV(TB) + MOVEM B,T.DEV+1(TB) + JRST TN.SNM ; NOW LOOK FOR SNAME + +TN.N11: CAIE A,"> + CAIN A,"< + JRST ILLNAM + MOVEM A,(P) ; SAVE END CHAR + PUSHJ P,TN.CPS ; GEN STRING + MOVEM A,T.NM1(TB) + MOVEM B,T.NM1+1(TB) + +TN.N2: SKIPN A,(P) ; GET CHAR BACK + JRST RPDONE + CAIN A,"; ; START VERSION? + JRST .+3 + CAIE A,". ; START NAME2? + JRST ILLNAM ; I GIVE UP!!! + HRRZ B,-1(TP) ; GET RMAINS OF STRING + PUSHJ P,TN.CPS ; AND COPY IT + MOVEM A,T.NM2(TB) + MOVEM B,T.NM2+1(TB) +RPDONE: SUB P,[1,,1] ; FLUSH TEMP + SUB TP,[2,,2] +CPOPJ: POPJ P, + +TN.CNT: HRRZ 0,-1(TP) ; CHAR COUNT + MOVE C,(TP) ; BPTR + MOVEI B,0 ; INIT COUNT TO 0 + +TN.CN1: MOVEI A,0 ; IN CASE RUN OUT + SOJL 0,CPOPJ ; RUN OUT? + ILDB A,C ; TRY ONE + CAIE A," ; TNEX FILE QUOTE? + JRST TN.CN2 + SOJL 0,CPOPJ + IBP C ; SKIP QUOTED CHAT + ADDI B,2 + JRST TN.CN1 + +TN.CN2: CAIE A,"< + CAIN A,"> + POPJ P, + + CAIE A,". + CAIN A,"; + POPJ P, + CAIN A,": + POPJ P, + AOJA B,TN.CN1 + +TN.CPS: PUSH P,B ; # OF CHARS + MOVEI A,4(B) ; ADD 4 TO B IN A + IDIVI A,5 + PUSHJ P,IBLOCK ; GET BLOCK OF WORDS FOR STRING + + POP P,C ; CHAR COUNT BACK + HRLI B,440700 + MOVSI A,TCHSTR + HRRI A,(C) ; CHAR STRING + MOVE D,B ; COPY BYTER + + JUMPE C,CPOPJ + ILDB 0,(TP) ; GET CHAR + IDPB 0,D ; AND STROE + SOJG C,.-2 + + MOVNI C,(A) ; - LENGTH TO C + ADDB C,-1(TP) ; DECREMENT WORDS COUNT + TRNN C,-1 ; SKIP IF EMPTY + POPJ P, + IBP (TP) + SOS -1(TP) ; ELSE FLUSH TERMINATOR + POPJ P, + +ILLNAM: PUSH TP,$TATOM + PUSH TP,EQUOTE ILLEGAL-TENEX-FILE-NAME + JRST CALER1 + +TN.MLT: MOVEI A,(AB) + HRLI A,-10 + +TN.ML1: GETYP 0,(A) + CAIE 0,TFIX + CAIN 0,TCHSTR + JRST .+2 + JRST RGPRSS ; ASSUME SINGLE STRING + ADD A,[2,,2] + JUMPL A,TN.ML1 + + MOVEI A,T.NM1(TB) + HRLI A,(AB) + BLT A,T.SNM+1(TB) ; BLT 'EM IN + ADD AB,[10,,10] ; SKIP THESE GUYS + JRST CHKLST + +] + + +; ROUTINE TO OPEN A CHANNEL FOR ANY DEVICE. NAMES ARE ASSUMED TO ALREADY +; BE ON BOTH TP STACK AND P STACK + +OPNCH: MOVE C,T.SPDL+1(TB) ; GET PDL BASE + HRRZ A,S.DIR(C) + ANDI A,1 ; JUST WANT I AND O + HRLM A,S.DEV(C) +; .TRANS S.DEV(C) ; UNDO ANY TRANSLATIONS +; JRST TRLOST ; COMPLAIN + + HRRZ A,S.DEV(C) ; GET SIXBIT DEVICE CODE + MOVEI E,(A) ; COPY TO E + ANDI E,777700 ; WITHOUT LAST + MOVEI D,(E) ; AND D + ANDI D,770000 ; WITH JUST LETTER + MOVSI B,-NDEVS ; AOBJN COUNTER + +DEVLP: HRRZ 0,DEVS(B) ; GET ONE + CAIN 0,(A) ; FULL DEV? + JRST DISPA + CAIN 0,(D) ; ONE LETTER + JRST CH2DIG + CAIN 0,(E) ; 2 LTTERS + JRST CH1DIG +NXTDEV: AOBJN B,DEVLP ; LOOP THRU + +IFN ITS,[ +OUSR: HRRZ A,S.DIR(C) ; BLOCK OR UNIT? + TRNE A,2 ; SKIP IF UNIT + JRST ODSK + PUSHJ P,OPEN1 ; OPEN IT + PUSHJ P,FIXREA ; AND READCHST IT + MOVE B,T.CHAN+1(TB) ; RESTORE CHANNEL + MOVE 0,[PUSHJ P,DOIOT] ; GET AN IOINS + MOVEM 0,IOINS(B) + MOVE C,T.SPDL+1(TB) + HRRZ A,S.DIR(C) + TRNN A,1 + JRST EOFMAK + MOVEI 0,80. + MOVEM 0,LINLN(B) + JRST OPNWIN + +OSTY: HLRZ A,S.DEV(C) + IORI A,10 ; THE DONT LOSE BIT (DONT HANG ON INPUT DO ON OUTPUT) + HRLM A,S.DEV(C) + JRST OUSR +] +IFE ITS,[ + PUSH TP,$TATOM + PUSH TP,EQUOTE NO-SUCH-DEVICE? + JRST CALER1 +] + +; MAKE SURE DIGITS EXIST + +CH2DIG: LDB 0,[60600,,A] + CAIG 0,'9 ; CHECK DIGITNESS + CAIGE 0,'0 + JRST NXTDEV ; LOSER + +CH1DIG: LDB 0,[600,,A] ; LAST CHAR + CAIG 0,'9 + CAIGE 0,'0 + JRST NXTDEV + +; HERE TO DISPATCH IF SUCCESSFUL + +DISPA: HLRZ B,DEVS(B) +IFN ITS,[ + HRRZ A,S.DIR(C) ; GET DIR OF OPEN + CAIN A,5 ; IS IT DISPLAY + CAIN B,ODIS ; BETTER BE OPENING DISPLAY + JRST (B) ; GO TO HANDLER + JRST WRONGD +] +IFE ITS, JRST (B) + + +IFN ITS,[ + +; DISK DEVICE OPNER COME HERE + +ODSK: MOVE A,S.SNM(C) ; GET SNAME + .SUSET [.SSNAM,,A] ; CLOBBER IT + PUSHJ P,OPEN0 ; DO REAL LIVE OPEN +] +IFE ITS,[ + +; TENEX DISK FILE OPENER + +ODSK: MOVE B,T.CHAN+1(TB) ; GET CHANNEL + PUSHJ P,STSTK ; EXPAND STRING ONTO STACK (E POINTS TO OLD P) + MOVE A,DIRECT-1(B) + MOVE B,DIRECT(B) + PUSHJ P,STRTO6 ; GET DIR NAME + POP P,C + MOVE D,T.SPDL+1(TB) + HRRZ D,S.DIR(D) + CAMN C,[SIXBIT /PRINTO/] + IORI D,100 ; TURN ON BIT TO SAY USE OLD FILE + MOVSI A,101 ; START SETTING UP BITS EXTRA BIT FOR MSB + TRNE D,1 ; SKIP IF INPUT + TRNE D,100 ; WITE OVER? + TLOA A,100000 ; FORCE NEW VERSION + TLO A,400000 ; FORCE OLD + HRROI B,1(E) ; POIT TO STRING + GTJFN + TDZA 0,0 ; SAVE FACT OF NO SKIP + MOVEI 0,1 ; INDICATE SKIPPED + MOVE P,E ; RESTORE PSTACK + JUMPE 0,GTJLOS ; FIND OUT WHAT HAPPENED + + MOVE B,T.CHAN+1(TB) ; GET CHANNEL + HRRZM A,CHANNO(B) ; SAVE IT + ANDI A,-1 ; READ Y TO DO OPEN + MOVSI B,440000 ; USE 36. BIT BYES + HRRI B,200000 ; ASSUME READ + TRNE D,1 ; SKIP IF READ + HRRI B,300000 ; WRITE BIT + HRRZ 0,FSAV(TB) ; SEE IF REF DATE HACK + CAIN 0,NFOPEN + TRO B,400 ; SET DON'T MUNG REF DATE BIT + OPENF + JRST OPFLOS + MOVEI 0,C.OPN+C.READ + TRNE D,1 ; SKIP FOR READ + MOVEI 0,C.OPN+C.PRIN + MOVE B,T.CHAN+1(TB) + HRRM 0,-4(B) ; MUNG THOSE BITS + ASH A,1 ; POINT TO SLOT + ADDI A,CHNL0(TVP) ; TO REAL SLOT + MOVEM B,1(A) ; SAVE CHANNEL + PUSHJ P,TMTNXS ; GET STRING FROM TENEX + MOVE B,CHANNO(B) ; JFN TO A + HRROI A,1(E) ; BASE OF STRING + MOVE C,[111111,,140001] ; WEIRD CONTROL BITS + JFNS ; GET STRING + MOVEI B,1(E) ; POINT TO START OF STRING + SUBM P,E ; RELATIVIZE E + PUSHJ P,TNXSTR ; MAKE INTO A STRING + SUB P,E ; BACK TO NORMAL + PUSH TP,A + PUSH TP,B + PUSHJ P,RGPRS1 ; PARSE INTO FIELDS + MOVE B,T.CHAN+1(TB) + MOVEI C,RNAME1-1(B) + HRLI C,T.NM1(TB) + BLT C,RSNAME(B) + JRST OPBASC +OPFLOS: MOVEI C,(A) ; SAVE ERROR CODE + MOVE B,T.CHAN+1(TB) + HRRZ A,CHANNO(B) ; JFN BACK TO A + RLJFN ; TRY TO RELEASE IT + JFCL + MOVEI A,(C) ; ERROR CODE BACK TO A + +GTJLOS: PUSHJ P,TGFALS ; GET A FALSE WITH REASON + JRST OPNRET + +STSTK: PUSH TP,$TCHAN + PUSH TP,B + MOVEI A,4+5 ; COUNT CHARS NEEDED (NEED LAST 0 BYTE) + MOVE B,(TP) + ADD A,RDEVIC-1(B) + ADD A,RNAME1-1(B) + ADD A,RNAME2-1(B) + ADD A,RSNAME-1(B) + ANDI A,-1 ; TO 18 BITS + IDIVI A,5 ; TO WORDS NEEDED + POP P,C ; SAVE RET ADDR + MOVE E,P ; SAVE POINTER + PUSH P,[0] ; ALOCATE SLOTS + SOJG A,.-1 + PUSH P,C ; RET ADDR BACK + INTGO ; IN CASE OVERFLEW + MOVE B,(TP) ; IN CASE GC'D + MOVE D,[440700,,1(E)] ; BYTE POINTER TO IT + MOVEI A,RDEVIC-1(B) + PUSHJ P,MOVSTR ; FLUSH IT ON + MOVEI A,": + IDPB A,D + HRRZ A,RSNAME-1(B) ; ANY SNAME AT ALL? + JUMPE A,ST.NM1 ; NOPE, CANT HACK WITH IT + MOVEI A,"< + IDPB A,D + MOVEI A,RSNAME-1(B) + PUSHJ P,MOVSTR ; SNAME UP + MOVEI A,"> + IDPB A,D + MOVEI A,RNAME1-1(B) + PUSHJ P,MOVSTR + MOVEI A,". + IDPB A,D +ST.NM1: MOVEI A,RNAME2-1(B) + PUSHJ P,MOVSTR + SUB TP,[2,,2] + POPJ P, + +MOVSTR: HRRZ 0,(A) ; CHAR COUNT + MOVE A,1(A) ; BYTE POINTER + SOJL 0,CPOPJ + ILDB C,A ; GET CHAR + IDPB C,D ; MUNG IT UP + JRST .-3 + +; MAKE A TENEX ERROR MESSAGE STRING + +TGFALS: PUSH P,A ; SAVE ERROR CODE + PUSHJ P,TMTNXS ; STRING ON STACK + HRROI A,1(E) ; POINT TO SPACE + MOVE B,(E) ; ERROR CODE + HRLI B,400000 ; FOR ME + MOVSI C,-100. ; MAX CHARS + ERSTR ; GET TENEX STRING + JRST TGFLS1 + JRST TGFLS1 + + MOVEI B,1(E) ; A AND B BOUND STRING + SUBM P,E ; RELATIVIZE E + PUSHJ P,TNXSTR ; BUILD STRING + SUB P,E ; P BACK TO NORMAL +TGFLS2: SUB P,[1,,1] ; FLUSH ERROR CODE SLOT + MOVE C,A + MOVE D,B + PUSHJ P,INCONS ; BUILD LIST + MOVSI A,TFALSE ; MAKE IT FALSE + POPJ P, + +TGFLS1: MOVE P,E ; RESET STACK + MOVE A,$TCHSTR + MOVE B,CHQUOTE UNKNOWN PROBLEM IN I/O + JRST TGFLS2 + +] +; OTHER BUFFERED DEVICES JOIN HERE + +OPDSK1: +IFN ITS,[ + PUSHJ P,FIXREA ; STORE THE "REAL" NAMES INTO THE CHANNEL +] +OPBASC: MOVE C,T.SPDL+1(TB) ; C WAS CLOBBERED, GET IT BACK + HRRZ A,S.DIR(C) ; FIND OUT IF OPEN IS ASCII OR WORD + TRZN A,2 ; SKIP IF BINARY + PUSHJ P,OPASCI ; DO IT FOR ASCII + +; NOW SET UP IO INSTRUCTION FOR CHANNEL + +MAKION: MOVE B,T.CHAN+1(TB) + MOVEI C,GETCHR + JUMPE A,MAKIO1 ; JUMP IF INPUT + MOVEI C,PUTCHR ; ELSE GET INPUT + MOVEI 0,80. ; DEFAULT LINE LNTH + MOVEM 0,LINLN(B) + MOVSI 0,TFIX + MOVEM 0,LINLN-1(B) +MAKIO1: + HRLI C,(PUSHJ P,) + MOVEM C,IOINS(B) ; STORE IT + JUMPN A,OPNWIN ; GET AN EOF FORM FOR INPUT CHANNEL + +; HERE TO CONS UP + +EOFMAK: MOVSI C,TATOM + MOVE D,EQUOTE END-OF-FILE + PUSHJ P,INCONS + MOVEI E,(B) + MOVSI C,TATOM + MOVE D,IMQUOTE ERROR + PUSHJ P,ICONS + MOVE D,T.CHAN+1(TB) ; RESTORE CHANNEL + MOVSI 0,TFORM + MOVEM 0,EOFCND-1(D) + MOVEM B,EOFCND(D) + +OPNWIN: MOVEI 0,10. ; SET UP RADIX + MOVSI A,TCHAN ; OPEN SUCCEEDED, RET CHANNEL + MOVE B,T.CHAN+1(TB) + MOVEM 0,RADX(B) + +OPNRET: MOVE C,(P) ; RET ADDR + SUB P,[S.X3+2,,S.X3+2] + SUB TP,[T.CHAN+2,,T.CHAN+2] + JRST (C) + + +; HERE TO CREATE CHARACTER BUFFERS FOR ASCII I/O + +OPASCI: PUSH P,A ; CONTAINS MODE, SAVE IT + MOVEI A,BUFLNT ; GET SIZE OF BUFFER + PUSHJ P,IBLOCK ; GET STORAGE + MOVSI 0,TWORD+.VECT. ; SET UTYPE + MOVEM 0,BUFLNT(B) ; AND STORE + MOVSI A,TCHSTR + SKIPE (P) ; SKIP IF INPUT + JRST OPASCO + MOVEI D,BUFLNT(B) ; REST BYTE POINTER +OPASCA: HRLI D,440700 + MOVE B,T.CHAN+1(TB) ; GET CHANNEL BACK + MOVEI 0,C.BUF + IORM 0,-4(B) ; TURN ON BUFFER BIT + MOVEM A,BUFSTR-1(B) + MOVEM D,BUFSTR(B) ; CLOBBER + POP P,A + POPJ P, + +OPASCO: HRROI C,777776 + MOVEM C,(B) ; -1 THE BUFFER (LEAVE OFF LOW BIT) + MOVSI C,(B) + HRRI C,1(B) ; BUILD BLT POINTER + BLT C,BUFLNT-1(B) ; ZAP + MOVEI D,(B) ; START MAKING STRING POINTER + HRRI A,BUFLNT*5 ; SET UP CHAR COUNT + JRST OPASCA + + +; OPEN NON FILE ORIENTED DEVICES (NUL, PTR, PTP ETC.) + +ONUL: +OPTP: +OPTR: PUSHJ P,OPEN0 ; SET UP MODE AND OPEN + SETZM S.NM1(C) ; CLOBBER UNINTERESTING FIELDS + SETZM S.NM2(C) + SETZM S.SNM(C) + JRST OPDSK1 + +; OPEN DEVICES THAT IGNORE SNAME + +OUTN: PUSHJ P,OPEN0 + SETZM S.SNM(C) + JRST OPDSK1 + +; OPEN THE DISPLAY DEVICE + +ODIS: MOVEI B,T.DIR(TB) ; GET CHANNEL + PUSHJ P,CHRWRD ; TO ASCII + JFCL + MOVE E,B ; DIR TO E + MOVE B,T.CHAN+1(TB) ; CHANNEL + MOVE 0,[PUSHJ P,DCHAR] ; IOINS + CAIN A,1 + MOVEM 0,IOINS(B) + PUSHJ P,DISOPN + JRST DISLOS ; LOSER + + MOVE D,T.CHAN+1(TB) ; GET CHANNEL + MOVEI 0,C.OPN+C.PRIN + HRRM 0,-4(D) + MOVEM A,DISINF-1(D) ; AND STORE + MOVEM B,DISINF(D) + SETZM CHANNO(D) ; NO REAL CHANNEL + MOVEI 0,DISLNL + MOVEM 0,LINLN(D) + MOVEI 0,DISPGL + MOVEM 0,PAGLN(D) + MOVEI 0,10. ; SET RADIX + MOVEM 0,RADX(D) + JRST SAVCHN ; ADD TO CHANNEL LIST + + +; INTERNAL CHANNEL OPENER + +OINT: HRRZ A,S.DIR(C) ; CHECK DIR + CAIL A,2 ; READ/PRINT? + JRST WRONGD ; NO, LOSE + + MOVE 0,INTINS(A) ; GET INS + MOVE D,T.CHAN+1(TB) ; AND CHANNEL + MOVEM 0,IOINS(D) ; AND CLOBBER + MOVEI 0,C.OPN+C.READ + TRNE A,1 + MOVEI 0,C.OPN+C.PRIN + HRRM 0,-4(D) + SETOM STATUS(D) ; MAKE SURE NOT AA TTY + PMOVEM T.XT(TB),INTFCN-1(D) + +; HERE TO SAVE PSEUDO CHANNELS + +SAVCHN: HRRZ E,CHNL0+1(TVP) ; POINT TO CURRENT LIST + MOVSI C,TCHAN + PUSHJ P,ICONS ; CONS IT ON + HRRZM B,CHNL0+1(TVP) + JRST OPNWIN + +; INT DEVICE I/O INS + +INTINS: PUSHJ P,GTINTC + PUSHJ P,PTINTC + + +; HERE TO OPEN THE NET DEVICE (I.E. THE ARPA NET) + +IFN ITS,[ +ONET: HRRZ A,S.DIR(C) ; DIRECTION CODE + CAILE A,1 ; ASCII ? + IORI A,4 ; TURN ON IMAGE BIT + SKIPGE S.NM1(C) ; NAME1 I.E. LOCAL HOST GIVEN + IORI A,10 ; NO, WE WILL LET ITS GIVE US ONE + SKIPGE S.NM2(C) ; NORMAL OR "LISTEN" + IORI A,20 ; TURN ON LISTEN BIT + MOVEI 0,7 ; DEFAULT BYTE SIZE + TRNE A,2 ; UNLESS + MOVEI 0,36. ; IMAGE WHICH IS 36 + SKIPN T.XT(TB) ; BYTE SIZE GIVEN? + MOVEM 0,S.X1(C) ; NO, STORE DEFAULT + SKIPG D,S.X1(C) ; BYTE SIZE REASONABLE? + JRST RBYTSZ ; NO <0, COMPLAIN + TRNE A,2 ; SKIP TO CHECK ASCII + JRST ONET2 ; CHECK IMAGE + CAIN D,7 ; 7-BIT WINS + JRST ONET1 + CAIE D,44 ; 36-BIT INDICATES BLOCK ASCII MODE + JRST .+3 + IORI A,2 ; SET BLOCK FLAG + JRST ONET1 + IORI A,40 ; USE 8-BIT MODE + CAIN D,10 ; IS IT RIGHT + JRST ONET1 ; YES +] + +RBYTSZ: PUSH TP,$TATOM ; CALL ERROR + PUSH TP,EQUOTE BYTE-SIZE-BAD + JRST CALER1 + +IFN ITS,[ +ONET2: CAILE D,36. ; IMAGE SIZE REASONABLE? + JRST RBYTSZ ; NO + CAIN D,36. ; NORMAL + JRST ONET1 ; YES, DONT SET FIELD + + ASH D,9. ; POSITION FOR FIELD + IORI A,40(D) ; SET IT AND ITS BIT + +ONET1: HRLM A,S.DEV(C) ; CLOBBER OPEN BLOCK + MOVE E,A ; SAVE BLOCK MODE INFO + PUSHJ P,OPEN1 ; DO THE OPEN + PUSH P,E + +; CLOBBER REAL SLOTS FOR THE OPEN + + MOVEI A,3 ; GET STATE VECTOR + PUSHJ P,IBLOCK + MOVSI A,TUVEC + MOVE D,T.CHAN+1(TB) + MOVEM A,BUFRIN-1(D) + MOVEM B,BUFRIN(D) + MOVSI A,TFIX+.VECT. ; SET U TYPE + MOVEM A,3(B) + MOVE C,T.SPDL+1(TB) + MOVE B,T.CHAN+1(TB) + + PUSHJ P,INETST ; GET STATE + + POP P,A ; IS THIS BLOCK MODE + MOVEI 0,80. ; POSSIBLE LINE LENGTH + TRNE A,1 ; SKIP IF INPUT + MOVEM 0,LINLN(B) + TRNN A,2 ; BLOCK MODE? + JRST .+3 + TRNN A,4 ; ASCII MODE? + JRST OPBASC ; GO SETUP BLOCK ASCII + MOVE 0,[PUSHJ P,DOIOT] + MOVEM 0,IOINS(B) + + JRST OPNWIN + +; INTERNAL ROUTINE TO GET THE CURRENT STATE OF THE NETWROK CHANNEL + +INETST: MOVE A,S.NM1(C) + MOVEM A,RNAME1(B) + MOVE A,S.NM2(C) + MOVEM A,RNAME2(B) + LDB A,[1100,,S.SNM(C)] + MOVEM A,RSNAME(B) + + MOVE E,BUFRIN(B) ; GET STATE BLOCK +INTST1: HRRE 0,S.X1(C) + MOVEM 0,(E) + ADDI C,1 + AOBJN E,INTST1 + + POPJ P, + + +; ACCEPT A CONNECTION + +MFUNCTION NETACC,SUBR + + PUSHJ P,ARGNET ; CHECK THAT ARG IS AN OPEN NET CHANNEL + MOVE A,CHANNO(B) ; GET CHANNEL + LSH A,23. ; TO AC FIELD + IOR A,[.NETACC] + XCT A + JRST IFALSE ; RETURN FALSE +NETRET: MOVE A,(AB) + MOVE B,1(AB) + JRST FINIS + +; FORCE SYSTEM NETWORK BUFFERS TO BE SENT + +MFUNCTION NETS,SUBR + + PUSHJ P,ARGNET + CAME A,MODES+1 + CAMN A,MODES+3 + SKIPA A,CHANNO(B) ; GET CHANNEL + JRST WRONGD + LSH A,23. + IOR A,[.NETS] + XCT A + JRST NETRET + +; SUBR TO RETURN UPDATED NET STATE + +MFUNCTION NETSTATE,SUBR + + PUSHJ P,ARGNET ; IS IT A NET CHANNEL + PUSHJ P,INSTAT + JRST FINIS + +; INTERNAL NETSTATE ROUTINE + +INSTAT: MOVE C,P ; GET PDL BASE + MOVEI 0,S.X3 ; # OF SLOTS NEEDED + PUSH P,[0] + SOJN 0,.-1 + + MOVEI D,S.DEV(C) ; SETUP FOR .RCHST + HRL D,CHANNO(B) + .RCHST D, ; GET THE GOODS + + PUSHJ P,INETST ; INTO VECTOR + SUB P,[S.X3,,S.X3] + MOVE B,BUFRIN(B) + MOVSI A,TUVEC + POPJ P, +] +; INTERNAL ROUTINE TO CHECK FOR CORRECT CHANNEL TYPE + +ARGNET: ENTRY 1 + GETYP 0,(AB) + CAIE 0,TCHAN + JRST WTYP1 + MOVE B,1(AB) ; GET CHANNEL + SKIPN CHANNO(B) ; OPEN? + JRST CHNCLS + MOVE A,RDEVIC-1(B) ; GET DEV NAME + MOVE B,RDEVIC(B) + PUSHJ P,STRTO6 + POP P,A + CAME A,[SIXBIT /NET /] + JRST NOTNET + MOVE B,1(AB) + MOVE A,DIRECT-1(B) ; CHECK FOR A READ SOCKET + MOVE B,DIRECT(B) + PUSHJ P,STRTO6 + MOVE B,1(AB) ; RESTORE CHANNEL + POP P,A + POPJ P, + +IFE ITS,[ + +; TENEX NETWRK OPENING CODE + +ONET: MOVE B,T.CHAN+1(TB) ; GET CHANNEL + MOVSI C,100700 + HRRI C,1(P) + MOVE E,P + PUSH P,[ASCII /NET:/] ; FOR STRINGS + GETYP 0,RNAME1-1(B) ; CHECK TYPE + CAIE 0,TFIX ; SKIP IF # SUPPLIED + JRST ONET1 + MOVE 0,RNAME1(B) ; GET IT + PUSHJ P,FIXSTK + JFCL + JRST ONET2 +ONET1: CAIE 0,TCHSTR + JRST WRONGT + HRRZ 0,RNAME1-1(B) + MOVE B,RNAME1(B) + JUMPE 0,ONET2 + ILDB A,B + JSP D,ONETCH + SOJA 0,.-3 +ONET2: MOVEI A,". + JSP D,ONETCH + MOVE B,T.CHAN+1(TB) + GETYP 0,RNAME2-1(B) + CAIE 0,TFIX + JRST ONET3 + GETYP 0,RSNAME-1(B) + CAIE 0,TFIX + JRST WRONGT + MOVE 0,RSNAME(B) + PUSHJ P,FIXSTK + JRST ONET4 + MOVE B,T.CHAN+1(TB) + MOVEI A,"- + JSP D,ONETCH + MOVE 0,RNAME2(B) + PUSHJ P,FIXSTK + JRST WRONGT + JRST ONET4 +ONET3: CAIE 0,TCHSTR + JRST WRONGT + HRRZ 0,RNAME2-1(B) + MOVE B,RNAME2(B) + JUMPE 0,ONET4 + ILDB A,B + JSP D,ONETCH + SOJA 0,.-3 + +ONET4: +ONET5: MOVE B,T.CHAN+1(TB) + GETYP 0,RNAME2-1(B) + CAIN 0,TCHSTR + JRST ONET6 + MOVEI A,"; + JSP D,ONETCH + MOVEI A,"T + JSP D,ONETCH +ONET6: MOVSI A,1 + HRROI B,1(E) ; STRING POINTER + GTJFN ; GET THE G.D JFN + TDZA 0,0 ; REMEMBER FAILURE + MOVEI 0,1 + MOVE P,E ; RESTORE P + JUMPE 0,GTJLOS ; CONS UP ERROR STRING + + MOVE B,T.CHAN+1(TB) + HRRZM A,CHANNO(B) ; SAVE THE JFN + + MOVE C,T.SPDL+1(TB) + MOVE D,S.DIR(C) + MOVEI B,10 + TRNE D,2 + MOVEI B,36. + SKIPE T.XT(TB) + MOVE B,T.XT+1(TB) + JUMPL B,RBYTSZ + CAILE B,36. + JRST RBYTSZ + ROT B,-6 + TLO B,3400 + HRRI B,200000 + TRNE D,1 ; SKIP FOR INPUT + HRRI B,100000 + ANDI A,-1 ; ISOLATE JFCN + OPENF + JRST OPFLOS ; REPORT ERROR + MOVE B,T.CHAN+1(TB) + ASH A,1 ; POINT TO SLOT + ADDI A,CHNL0(TVP) ; TO REAL SLOT + MOVEM B,1(A) ; SAVE CHANNEL + MOVE A,CHANNO(B) + CVSKT ; GET ABS SOCKET # + FATAL NETWORK BITES THE BAG! + MOVE D,B + MOVE B,T.CHAN+1(TB) + MOVEM D,RNAME1(B) + MOVSI 0,TFIX + MOVEM 0,RNAME1-1(B) + + MOVSI 0,TFIX + MOVEM 0,RNAME2-1(B) + MOVEM 0,RSNAME-1(B) + MOVE C,T.SPDL+1(TB) + MOVE C,S.DIR(C) + MOVE 0,[PUSHJ P,DONETO] + TRNN C,1 ; SKIP FOR OUTPUT + MOVE 0,[PUSHJ P,DONETI] + MOVEM 0,IOINS(B) + MOVEI 0,80. ; LINELENGTH + TRNE C,1 ; SKIP FOR INPUT + MOVEM 0,LINLN(B) + MOVEI A,3 ; GET STATE UVECTOR + PUSHJ P,IBLOCK + MOVSI 0,TFIX+.VECT. + MOVEM 0,3(B) + MOVE C,B + MOVE B,T.CHAN+1(TB) + MOVEM C,BUFRIN(B) + MOVSI 0,TUVEC + MOVEM 0,BUFRIN-1(B) + MOVE A,CHANNO(B) ; GET JFN + GDSTS ; GET STATE + MOVE E,T.CHAN+1(TB) + MOVEM D,RNAME2(E) + MOVEM C,RSNAME(E) + MOVE C,BUFRIN(E) + MOVEM B,(C) ; INITIAL STATE STORED + MOVE B,E + JRST OPNWIN + +; DOIOT FOR TENEX NETWRK + +DONETO: PUSH P,0 + MOVE 0,[BOUT] + JRST .+3 + +DONETI: PUSH P,0 + MOVE 0,[BIN] + PUSH P,0 + PUSH TP,$TCHAN + PUSH TP,B + MOVEI 0,(A) ; POSSIBLE OUTPUT CHAR TO 0 + MOVE A,CHANNO(B) + MOVE B,0 + ENABLE + XCT (P) + DISABLE + MOVEI A,(B) ; RET CHAR IN A + MOVE B,(TP) + MOVE 0,-1(P) + SUB P,[2,,2] + SUB TP,[2,,2] + POPJ P, + +NETPRS: MOVEI D,0 + HRRZ 0,(C) + MOVE C,1(C) + +ONETL: ILDB A,C + CAIN A,"# + POPJ P, + SUBI A,60 + ASH D,3 + IORI D,(A) + SOJG 0,ONETL + AOS (P) + POPJ P, + +FIXSTK: CAMN 0,[-1] + POPJ P, + JFFO 0,FIXS3 ; PUT OCTAL DIGITS INTO STIRNG + MOVEI A,"0 + POP P,D + AOJA D,ONETCH +FIXS3: IDIVI A,3 + MOVEI B,12. + SUBI B,(A) + HRLM B,(P) + IMULI A,3 + LSH 0,(A) + POP P,B +FIXS2: MOVEI A,0 + ROTC 0,3 ; NEXT DIGIT + ADDI A,60 + JSP D,ONETCH + SUB B,[1,,0] + TLNN B,-1 + JRST 1(B) + JRST FIXS2 + +ONETCH: IDPB A,C + TLNE C,760000 ; SKIP IF NEW WORD + JRST (D) + PUSH P,[0] + JRST (D) + +INSTAT: MOVE E,B + MOVE A,CHANNO(E) + GDSTS + LSH B,-32. + MOVEM D,RNAME2(E) ; UPDATE FOREIGN SOCHKET + MOVEM C,RSNAME(E) ; AND HOST + MOVE C,BUFRIN(E) + XCT ITSTRN(B) ; XLATE TO LOOK MORE LIKE ITS + MOVEM B,(C) ; STORE STATE + MOVE B,E + POPJ P, + +ITSTRN: MOVEI B,0 + JRST NLOSS + JRST NLOSS + MOVEI B,1 + MOVEI B,2 + JRST NLOSS + MOVEI B,4 + PUSHJ P,NOPND + MOVEI B,0 + JRST NLOSS + JRST NLOSS + PUSHJ P,NCLSD + MOVEI B,0 + JRST NLOSS + MOVEI B,0 + +NLOSS: FATAL ILLEGAL NETWORK STATE + +NOPND: MOVE B,DIRECT(E) ; SEE IF READ OR PRINT + ILDB B,B ; GET 1ST CHAR + CAIE B,"R ; SKIP FOR READ + JRST NOPNDW + SIBE ; SEE IF INPUT EXISTS + JRST .+3 + MOVEI B,5 + POPJ P, + MOVEM B,2(C) ; STORE BYTES IN STATE VECTOR + MOVEI B,11 ; RETURN DATA PRESENT STATE + POPJ P, + +NOPNDW: SOBE ; SEE IF OUTPUT PRESENT + JRST .+3 + MOVEI B,5 + POPJ P, + + MOVEI B,6 + POPJ P, + +NCLSD: MOVE B,DIRECT(E) + ILDB B,B + CAIE B,"R + JRST RET0 + SIBE + JRST .+2 + JRST RET0 + MOVEI B,10 + POPJ P, + +RET0: MOVEI B,0 + POPJ P, + + +MFUNCTION NETSTATE,SUBR + + PUSHJ P,ARGNET + PUSHJ P,INSTAT + MOVE B,BUFRIN(B) + MOVSI A,TUVEC + JRST FINIS + +MFUNCTION NETS,SUBR + + PUSHJ P,ARGNET + CAME A,MODES+1 ; PRINT OR PRINTB? + CAMN A,MODES+3 + SKIPA A,CHANNO(B) + JRST WRONGD + MOVEI B,21 + MTOPR +NETRET: MOVE B,1(AB) + MOVSI A,TCHAN + JRST FINIS + +MFUNCTION NETACC,SUBR + + PUSHJ P,ARGNET + MOVE A,CHANNO(B) + MOVEI B,20 + MTOPR + JRST NETRET + +] + +; HERE TO OPEN TELETYPE DEVICES + +OTTY: HRRZ A,S.DIR(C) ; GET DIR CODE + TRNE A,2 ; SKIP IF NOT READB/PRINTB + JRST WRONGD ; CANT DO THAT + +IFN ITS,[ + MOVE A,S.NM1(C) ; CHECK FOR A DIR + MOVE 0,S.NM2(C) + CAMN A,[SIXBIT /.FILE./] + CAME 0,[SIXBIT /(DIR)/] + SKIPA E,[-15.*2,,] + JRST OUTN ; DO IT THAT WAY + + HRRZ A,S.DIR(C) ; CHECK DIR + TRNE A,1 + JRST TTYLP2 + HRRI E,CHNL1(TVP) + PUSH P,S.DEV(C) ; SAVE THE SIXBIT DEV NAME + HRLZS (P) ; POSTITION DEVICE NAME + +TTYLP: SKIPN D,1(E) ; CHANNEL OPEN? + JRST TTYLP1 ; NO, GO TO NEXT + MOVE A,RDEVIC-1(D) ; GET DEV NAME + MOVE B,RDEVIC(D) + PUSHJ P,STRTO6 ; TO 6 BIT + POP P,A ; GET RESULT + CAMN A,(P) ; SAME? + JRST SAMTYQ ; COULD BE THE SAME +TTYLP1: ADD E,[2,,2] + JUMPL E,TTYLP + SUB P,[1,,1] ; THIS ONE MUST BE UNIQUE +TTYLP2: MOVE C,T.SPDL+1(TB) ; POINT TO P BASE + HRRZ A,S.DIR(C) ; GET DIR OF OPEN + SKIPE A ; IF OUTPUT, + IORI A,20 ; THEN USE DISPLAY MODE + HRLM A,S.DEV(C) ; STORE IN OPEN BLOCK + PUSHJ P,OPEN2 ; OPEN THE TTY + HRLZ A,S.DEV(C) ; GET DEVICE NAME + PUSHJ P,6TOCHS ; TO A STRING + MOVE D,T.CHAN+1(TB) ; POINT TO CHANNEL + MOVEM A,RDEVIC-1(D) + MOVEM B,RDEVIC(D) + MOVE C,T.SPDL+1(TB) ; RESTORE PDL BASE + MOVE B,D ; CHANNEL TO B + HRRZ 0,S.DIR(C) ; AND DIR + JUMPE 0,TTYSPC +TTY1: DOTCAL TTYGET,[CHANNO(B),[2000,,0],[2000,,A],[2000,,D]] + FATAL .CALL FAILURE + DOTCAL TTYSET,[CHANNO(B),MODE1,MODE2,D] + FATAL .CALL FAILURE + MOVE A,[PUSHJ P,GMTYO] + MOVEM A,IOINS(B) + DOTCAL RSSIZE,[CHANNO(B),[2000,,A],[2000,,D]] + FATAL .CALL FAILURE + MOVEM D,LINLN(B) + MOVEM A,PAGLN(B) + JRST OPNWIN + +; MAKE AN IOT + +IOTMAK: HRLZ A,CHANNO(B) ; GET CHANNEL + ROT A,5 + IOR A,[.IOT A] ; BUILD IOT + MOVEM A,IOINS(B) ; AND STORE IT + POPJ P, + + +; HERE IF POSSIBLY OPENING AN ALREADY OPEN TTY + +SAMTYQ: MOVE D,1(E) ; RESTORE CURRENT CHANNEL + MOVE A,DIRECT-1(D) ; GET DIR + MOVE B,DIRECT(D) + PUSHJ P,STRTO6 + POP P,A ; GET SIXBIT + MOVE C,T.SPDL+1(TB) + HRRZ C,S.DIR(C) + CAME A,MODES(C) ; SKIP IF DIFFERENT DIRECTION + JRST TTYLP1 + +; HERE IF A RE-OPEN ON A TTY + + HRRZ 0,FSAV(TB) ; IS IT FROM A FOPEN + CAIN 0,FOPEN + JRST RETOLD ; RET OLD CHANNEL + + PUSH TP,$TCHAN + PUSH TP,1(E) ; PUSH OLD CHANNEL + PUSH TP,$TFIX + PUSH TP,T.CHAN+1(TB) + MOVE A,[PUSHJ P,CHNFIX] + PUSHJ P,GCHACK + SUB TP,[4,,4] + +RETOLD: MOVE B,1(E) ; GET CHANNEL + AOS CHANNO-1(B) ; AOS REF COUNT + MOVSI A,TCHAN + SUB P,[1,,1] ; CLEAN UP STACK + JRST OPNRET ; AND LEAVE + + +; ROUTINE TO PASS TO GCHACK TO FIX UP CHANNEL POINTER + +CHNFIX: CAIN C,TCHAN + CAME D,(TP) + POPJ P, + MOVE D,-2(TP) ; GET REPLACEMENT + SKIPE B + MOVEM D,1(B) ; CLOBBER IT AWAY + POPJ P, +] + +IFE ITS,[ + MOVE C,T.SPDL+1(TB) ; POINT TO P BASE + HRRZ 0,S.DIR(C) ; 0/ 0 FOR READ 0/ 1 FOR PRINT + MOVE A,[PUSHJ P,MTYO] + MOVE B,T.CHAN+1(TB) + MOVEM A,IOINS(B) + MOVEI A,100 ; PRIM INPUT JFN + JUMPN 0,TNXTY1 + MOVEI E,C.OPN+C.READ + HRRM E,-4(B) + MOVEM B,CHNL0+2*100+1(TVP) + JRST TNXTY2 +TNXTY1: MOVEM B,CHNL0+2*101+1(TVP) + MOVEI A,101 ; PRIM OUTPUT JFN + MOVEI E,C.OPN+C.PRIN + HRRM E,-4(B) +TNXTY2: MOVEM A,CHANNO(B) + JUMPN 0,OPNWIN +] +; SETUP FUNNY BUFFER FOR TTY INPUT DEVICES + +TTYSPC: MOVEI A,EXTBFR ; GET EXTRA BUFFER + PUSHJ P,IBLOCK ; GET BLOCK + MOVE D,T.CHAN+1(TB) ;RESTORE CHANNEL POINTER +IFN ITS,[ + MOVE A,CHANNO(D) + LSH A,23. + IOR A,[.IOT A] + MOVEM A,IOIN2(B) +] +IFE ITS,[ + MOVE A,[PBIN] + MOVEM A,IOIN2(B) +] + MOVSI A,TLIST + MOVEM A,EXBUFR-1(D) ; FOR WAITING TTY BUFFERS + SETZM EXBUFR(D) ; NIL LIST + MOVEM B,BUFRIN(D) ;STORE IN CHANNEL + MOVSI A,TUVEC ;MAKE SURE TYPE IS UNIFORM VECTOR + MOVEM A,BUFRIN-1(D) +IFN ITS, MOVEI A,177 ;SET ERASER TO RUBOUT +IFE ITS, MOVEI A,1 ; TRY ^A FOR TENEX + MOVEM A,ERASCH(B) + SETZM KILLCH(B) ;NO KILL CHARACTER NEEDED + MOVEI A,33 ;BREAKCHR TO C.R. + MOVEM A,BRKCH(B) + MOVEI A,"\ ;ESCAPER TO \ + MOVEM A,ESCAP(B) + MOVE A,[010700,,BYTPTR(E)] ;RELATIVE BYTE POINTER + MOVEM A,BYTPTR(B) + MOVEI A,14 ;BARF BACK CHARACTER FF + MOVEM A,BRFCHR(B) + MOVEI A,^D + MOVEM A,BRFCH2(B) + +; SETUP DEFAULT TTY INTERRUPT HANDLER + + PUSH TP,$TATOM + PUSH TP,MQUOTE CHAR,CHAR,INTRUP + PUSH TP,$TFIX + PUSH TP,[10] ; PRIORITY OF CHAR INT + PUSH TP,$TCHAN + PUSH TP,D + MCALL 3,EVENT ; 1ST MAKE AN EVENT EXIST + PUSH TP,A + PUSH TP,B + PUSH TP,$TSUBR + PUSH TP,[QUITTER] ; DEFAULT HANDLER IS QUITTER + MCALL 2,HANDLER + +; BUILD A NULL STRING + + MOVEI A,0 + PUSHJ P,IBLOCK ; USE A BLOCK + MOVE D,T.CHAN+1(TB) + MOVEI 0,C.BUF + IORM 0,-4(D) + HRLI B,440700 + MOVSI A,TCHSTR + MOVEM A,BUFSTR-1(D) + MOVEM B,BUFSTR(D) + MOVEI A,0 + MOVE B,D ; CHANNEL TO B + JRST MAKION + + +; ROUTINE TO OPEN ITS CHANNEL WITHOUT .RCHST + +OPEN2: MOVEI A,S.DEV(C) ; POINT TO OPEN BLOCK + PUSHJ P,MOPEN ; OPEN THE FILE + JRST OPNLOS + MOVE B,T.CHAN+1(TB) ; GET CHANNEL BACK + MOVEM A,CHANNO(B) ; SAVE THE CHANNEL + JRST OPEN3 + +; FIX UP MODE AND FALL INTO OPEN + +OPEN0: HRRZ A,S.DIR(C) ; GET DIR + TRNE A,2 ; SKIP IF NOT BLOCK + IORI A,4 ; TURN ON IMAGE + IORI A,2 ; AND BLOCK + + PUSH P,A + PUSH TP,$TPDL + PUSH TP,C ; SAVE CRUFT TO CHECK FOR PRINTO, HA HA + MOVE B,T.CHAN+1(TB) + MOVE A,DIRECT-1(B) + MOVE B,DIRECT(B) ; THIS KLUDGE THE MESS OF NDR + PUSHJ P,STRTO6 + MOVE C,(TP) + POP P,D ; THE SIXBIT FOR KLUDGE + POP P,A ; GET BACK THE RANDOM BITS + SUB TP,[2,,2] + CAME D,[SIXBIT /PRINTO/] + JRST OPEN9 ; WELL NOT THIS TIME + IORI A,100000 ; WRITEOVER BIT + + HRRZ 0,FSAV(TB) + CAIN 0,NFOPEN + IOR A,4 ; DON'T CHANGE REF DATE +OPEN9: HRLM A,S.DEV(C) ; AND STORE IT + +; ROUTINE TO ATTEMPT TO OPEN A REAL ITS CHANNEL + +OPEN1: MOVEI A,S.DEV(C) ; POINT TO OPEN BLOCK + PUSHJ P,MOPEN + JRST OPNLOS + MOVE B,T.CHAN+1(TB) ; GET CHANNEL BACK + MOVEM A,CHANNO(B) ; CLOBBER INTO CHANNEL + MOVSI A,(A) ; SET UP READ CHAN STATUS + HRRI A,S.DEV(C) + .RCHST A, ; GET THE GOODS + +; NOW CLOBBER THE TVP SLOT FOR THIS CHANNEL + +OPEN3: MOVE A,S.DIR(C) + MOVEI 0,C.OPN+C.READ + TRNE A,1 + MOVEI 0,C.OPN+C.PRIN + TRNE A,2 + TRO 0,C.BIN + HRRM 0,-4(B) + MOVE A,CHANNO(B) ; GET CHANNEL # + ASH A,1 + ADDI A,CHNL0(TVP) ; POINT TO SLOT + MOVEM B,1(A) ; NOT: TYPE ALREADY SETUP + +; NOW GET STATUS WORD + +DOSTAT: HRLZ A,CHANNO(B) ; NOW GET STATUS WORD + ROT A,5 + IOR A,[.STATUS STATUS(B)] ; GET INS + XCT A ; AND DO IT + POPJ P, + + +; HERE IF OPEN FAILS (CHANNEL IS IN A) + +OPNLOS: JUMPL A,NOCHAN ; ALL CHANNELS ARE IN USE + LSH A,23. ; DO A .STATUS + IOR A,[.STATUS A] + XCT A ; STATUS TO A + PUSHJ P,GFALS ; GET A FALSE WITH A MESSAGE + SUB P,[1,,1] ; EXTRA RET ADDR FLUSHED + JRST OPNRET ; AND RETURN + +; ROUTINE TO CONS UP FALSE WITH REASON + +GFALS: PUSH P,[SIXBIT / ERR/] ; SET UP OPEN TO ERR DEV + PUSH P,[3] ; SAY ITS FOR CHANNEL + PUSH P,A + .OPEN 0,-2(P) ; USE CHANNEL 0 FOR THIS + FATAL CAN'T OPEN ERROR DEVICE + SUB P,[3,,3] ; DONT WANT OPEN BLOCK NOW + MOVEI A,0 ; PREPARE TO BUILD STRING ON STACK +EL1: PUSH P,[0] ; WHERE IT WILL GO + MOVSI B,(<440700,,(P)>) ; BYTE POINTER TO TOP OF STACK +EL2: .IOT 0,0 ; GET A CHAR + JUMPL 0,EL3 ; JUMP ON -1,,3 + CAIN 0,3 ; EOF? + JRST EL3 ; YES, MAKE STRING + CAIN 0,14 ; IGNORE FORM FEEDS + JRST EL2 ; IGNORE FF + CAIE 0,15 ; IGNORE CR & LF + CAIN 0,12 + JRST EL2 + IDPB 0,B ; STUFF IT + TLNE B,760000 ; SIP IF WORD FULL + AOJA A,EL2 + AOJA A,EL1 ; COUNT WORD AND GO + +EL3: SKIPN (P) ; ANY CHARS AT END? + SUB P,[1,,1] ; FLUSH XTRA + PUSH P,A ; PUT UP COUNT + .CLOSE 0, ; CLOSE THE ERR DEVICE + PUSHJ P,CHMAK ; MAKE STRING + MOVE C,A + MOVE D,B ; COPY STRING + PUSHJ P,INCONS ; CONS TO NIL + MOVSI A,TFALSE ; MAKEIT A FALSE + POPJ P, + + +; ROUTINE TO FILL IN THE "REAL" SLOTS FOR THE CHANNEL + +FIXREA: HRLZS S.DEV(C) ; KILL MODE BITS + MOVE D,[-4,,S.DEV] + +FIXRE1: MOVEI A,(D) ; COPY REL POINTER + ADD A,T.SPDL+1(TB) ; POINT TO SLOT + SKIPN A,(A) ; SKIP IF GOODIE THERE + JRST FIXRE2 + PUSHJ P,6TOCHS ; MAKE INOT A STRING + MOVE C,RDTBL-S.DEV(D); GET OFFSET + ADD C,T.CHAN+1(TB) + MOVEM A,-1(C) + MOVEM B,(C) +FIXRE2: AOBJN D,FIXRE1 + POPJ P, + +DOOPN: PUSH P,A + HRLZ A,CHANNO(B) ; GET CHANNEL + ASH A,5 + HRR A,(P) ; POINT + TLO A,(.OPEN) + XCT A + SKIPA + AOS -1(P) + POP P,A + POPJ P, + +;THIS ROUTINE CONVERTS MUDDLE CHARACTER STRINGS TO SIXBIT FILE NAMES +STRTO6: PUSH TP,A + PUSH TP,B + PUSH P,E ;SAVE USEFUL FROB + MOVEI E,(A) ; CHAR COUNT TO E + GETYP A,A + CAIE A,TCHSTR ; IS IT ONE WORD? + JRST WRONGT ;NO +CHREAD: MOVEI A,0 ;INITIALIZE OUTPUT WORD + MOVE D,[440600,,A] ;AND BYTE POINTER TO IT +NEXCHR: SOJL E,SIXDON + ILDB 0,B ; GET NEXT CHAR + JUMPE 0,SIXDON ;IF NULL, WE ARE FINISHED + PUSHJ P,A0TO6 ; CONVERT TO SIXBIT + IDPB 0,D ;DEPOSIT INTO SIX BIT + TRNN A,77 ;IS OUTPUT FULL + JRST NEXCHR ; NO, GET NEXT +SIXDON: SUB TP,[2,,2] ;FIX UP TP + POP P,E + EXCH A,(P) ;LEAVE RESULT ON P-STACK + JRST (A) ;NOW RETURN + + +;SUBROUTINE TO CONVERT SIXBIT TO ATOM + +6TOCHS: PUSH P,E + PUSH P,D + MOVEI B,0 ;MAX NUMBER OF CHARACTERS + PUSH P,[0] ;STRING WILL GO ON P SATCK + JUMPE A,GETATM ; EMPTY, LEAVE + MOVEI E,-1(P) ;WILL BE BYTE POINTER + HRLI E,10700 ;SET IT UP + PUSH P,[0] ;SECOND POSSIBLE WORD + MOVE D,[440600,,A] ;INPUT BYTE POINTER +6LOOP: ILDB 0,D ;START CHAR GOBBLING + ADDI 0,40 ;CHANGET TOASCII + IDPB 0,E ;AND STORE IT + TLNN D,770000 ; SKIP IF NOT DONE + JRST 6LOOP1 + TDNN A,MSKS(B) ; CHECK IF JUST SPACES LEFT + AOJA B,GETATM ; YES, DONE + AOJA B,6LOOP ;KEEP LOOKING +6LOOP1: PUSH P,[6] ;IF ARRIVE HERE, STRING IS 2 WORDS + JRST .+2 +GETATM: MOVEM B,(P) ;SET STRING LENGTH=1 + PUSHJ P,CHMAK ;MAKE A MUDDLE STRING + POP P,D + POP P,E + POPJ P, + +MSKS: 7777,,-1 + 77,,-1 + ,,-1 + 7777 + 77 + + +; CONVERT ONE CHAR + +A0TO6: CAIL 0,141 ;IF IT IS GREATER OR EQUAL TO LOWER A + CAILE 0,172 ;BUT LESS THAN OR EQUAL TO LOWER Z + JRST .+2 ;THEN + SUBI 0,40 ;CONVERT TO UPPER CASE + SUBI 0,40 ;NOW TO SIX BIT + JUMPL 0,BAD6 ;CHECK FOR A WINNER + CAILE 0,77 + JRST BAD6 + POPJ P, + +; SUBR TO DELETE AND RENAME FILES + +MFUNCTION RENAME,SUBR + + ENTRY + + JUMPGE AB,TFA + PUSH TP,$TPDL + PUSH TP,P ; SAVE P-STACK BASE + GETYP 0,(AB) ; GET 1ST ARG TYPE +IFN ITS,[ + CAIN 0,TCHAN ; CHANNEL? + JRST CHNRNM ; MUST BE RENAME WHILE OPEN FOR WRITING +] +IFE ITS,[ + PUSH P,[100000,,0] + PUSH P,[377777,,377777] +] + MOVSI E,-4 ; 4 THINGS TO PUSH +RNMALP: MOVE B,@RNMTBL(E) + PUSH P,E + PUSHJ P,IDVAL1 + POP P,E + GETYP 0,A + CAIE 0,TCHSTR ; SKIP IF WINS + JRST RNMLP1 + +IFN ITS, PUSHJ P,STRTO6 ; CONVERT TO SIXBIT +IFE ITS, PUSH P,B ; PUSH BYTE POINTER + JRST .+2 + +RNMLP1: PUSH P,RNSTBL(E) ; USE DEFAULT + AOBJN E,RNMALP + +IFN ITS,[ + PUSHJ P,RGPRS ; PARSE THE ARGS + JRST RNM1 ; COULD BE A RENAME + +; HERE TO DELETE A FILE + +DELFIL: MOVEI A,0 ; SETUP FDELE + EXCH A,(P) ; AND GET SNAME + .SUSET [.SSNAM,,A] + HLRZS -3(P) ; FIXUP DEVICE + .FDELE -3(P) ; DO IT TO IT + JRST FDLST ; ANALYSE ERROR + +FDLWON: MOVSI A,TATOM + MOVE B,MQUOTE T + JRST FINIS +] +IFE ITS,[ + MOVE A,(TP) ; GET BASE OF PDL + MOVEI A,1(A) ; POINT TO CRAP + MOVE B,1(AB) ; STRING POINTER + PUSH P,[0] + PUSH P,[0] + PUSH P,[0] + GTJFN ; GET A JFN + JRST TDLLOS ; LOST + ADD AB,[2,,2] ; PAST ARG + JUMPL AB,RNM1 ; GO TRY FOR RENAME + MOVE P,(TP) ; RESTORE P STACK + MOVEI C,(A) ; FOR RELEASE + DELF ; ATTEMPT DELETE + JRST DELLOS ; LOSER + RLJFN ; MAKE SURE FLUSHED + JFCL + +FDLWON: MOVSI A,TATOM + MOVE B,MQUOTE T + JRST FINIS + +RNMLOS: PUSH P,A + MOVEI A,(B) + RLJFN + JFCL +DELLO1: MOVEI A,(C) + RLJFN + JFCL + POP P,A ; ERR NUMBER BACK +TDLLOS: PUSHJ P,TGFALS ; GET FALSE WITH REASON + JRST FINIS + +DELLOS: PUSH P,A ; SAVE ERROR + JRST DELLO1 +] + +;TABLE OF REANMAE DEFAULTS +IFN ITS,[ +RNMTBL: IMQUOTE DEV + IMQUOTE NM1 + IMQUOTE NM2 + IMQUOTE SNM + +RNSTBL: SIXBIT /DSK _MUDS_> / +] +IFE ITS,[ +RNMTBL: IMQUOTE DEV + IMQUOTE SNM + IMQUOTE NM1 + IMQUOTE NM2 + +RNSTBL: -1,,[ASCIZ /DSK/] + 0 + -1,,[ASCIZ /_MUDS_/] + -1,,[ASCIZ /MUD/] +] +; HERE TO DO A RENAME + +RNM1: JUMPGE AB,TMA ; IF ARGS EXHAUSTED, MUST BE TOO MUCH STRING + GETYP 0,(AB) + MOVE C,1(AB) ; GET ARG + CAIN 0,TATOM ; IS IT "TO" + CAME C,MQUOTE TO + JRST WRONGT ; NO, LOSE + ADD AB,[2,,2] ; BUMP PAST "TO" + JUMPGE AB,TFA +IFN ITS,[ + MOVEM P,T.SPDL+1(TB) ; SAVE NEW P-BASE + + MOVEI 0,4 ; FOUR DEFAULTS + PUSH P,-3(P) ; DEFAULT DEVICE IS CURRENT + SOJN 0,.-1 + + PUSHJ P,RGPRS ; PARSE THE NEXT STRING + JRST TMA + + HLRZS A,-7(P) ; FIX AND GET DEV1 + HLRZS B,-3(P) ; SAME FOR DEV2 + CAIE A,(B) ; SAME? + JRST DEVDIF + + POP P,A ; GET SNAME 2 + CAME A,(P)-3 ; SNAME 1 + JRST DEVDIF + .SUSET [.SSNAM,,A] + POP P,-2(P) ; MOVE NAMES DOWN + POP P,-2(P) + .FDELE -4(P) ; TRY THE RENAME + JRST FDLST + JRST FDLWON + +; HERE FOR RENAME WHILE OPEN FOR WRITING + +CHNRNM: ADD AB,[2,,2] ; NEXT ARG + JUMPGE AB,TFA + MOVE B,-1(AB) ; GET CHANNEL + SKIPN CHANNO(B) ; SKIP IF OPEN + JRST BADCHN + MOVE A,DIRECT-1(B) ; CHECK DIRECTION + MOVE B,DIRECT(B) + PUSHJ P,STRTO6 ; TO 6 BIT + POP P,A + CAME A,[SIXBIT /PRINT/] + CAMN A,[SIXBIT /PRINTB/] + JRST CHNRN1 + CAME A,[SIXBIT /PRINTO/] + JRST WRONGD + +; SET UP .FDELE BLOCK + +CHNRN1: PUSH P,[0] + PUSH P,[0] + MOVEM P,T.SPDL+1(TB) + PUSH P,[0] + PUSH P,[SIXBIT /_MUDL_/] + PUSH P,[SIXBIT />/] + PUSH P,[0] + + PUSHJ P,RGPRS ; PARSE THESE + JRST TMA + + SUB P,[1,,1] ; SNAME/DEV IGNORED + MOVE AB,ABSAV(TB) ; GET ORIG ARG POINTER + MOVE B,1(AB) + MOVE A,CHANNO(B) ; ITS CHANNEL # + MOVEM A,-2(P) + .FDELE -4(P) + JRST FDLST + MOVEI A,-4(P) ; SET UP FOR RDCHST + HRL A,CHANNO(B) + .RCHST A, + MOVE A,-3(P) ; UPDATE CHANNEL + PUSHJ P,6TOCHS ; GET A STRING + MOVE C,1(AB) + MOVEM A,RNAME1-1(C) + MOVEM B,RNAME1(C) + MOVE A,-2(P) + PUSHJ P,6TOCHS + MOVE C,1(AB) + MOVEM A,RNAME2-1(C) + MOVEM B,RNAME2(C) + MOVE B,1(AB) + MOVSI A,TCHAN + JRST FINIS +] +IFE ITS,[ + PUSH P,A + MOVE A,(TP) ; PBASE BACK + PUSH A,[400000,,0] + MOVEI A,(A) + MOVE B,1(AB) + GTJFN + JRST TDLLOS + POP P,B + EXCH A,B + MOVEI C,(A) ; FOR RELEASE ATTEMPT + RNAMF + JRST RNMLOS + MOVEI A,(B) + RLJFN ; FLUSH JFN + JFCL + MOVEI A,(C) ; MAKE SURR OTHER IS FLUSHED + RLJFN + JFCL + JRST FDLWON +] +; HERE FOR LOSING .FDELE + +FDLST: .STATUS 0,A ; GET STATUS + PUSHJ P,GFALS ; ANALYZE IT + JRST FINIS + +; SOME .FDELE ERRORS + +DEVDIF: PUSH TP,$TATOM + PUSH TP,EQUOTE DEVICE-OR-SNAME-DIFFERS + JRST CALER1 + + ; HERE TO RESET A READ CHANNEL + +MFUNCTION FRESET,SUBR,RESET + + ENTRY 1 + GETYP A,(AB) + CAIE A,TCHAN + JRST WTYP1 + MOVE B,1(AB) ;GET CHANNEL + SKIPN IOINS(B) ; OPEN? + JRST REOPE1 ; NO, IGNORE CHECKS +IFN ITS,[ + MOVE A,STATUS(B) ;GET STATUS + ANDI A,77 + JUMPE A,REOPE1 ;IF IT CLOSED, JUST REOPEN IT, MAYBE? + CAILE A,2 ;SKIPS IF TTY FLAVOR + JRST REOPEN +] +IFE ITS,[ + MOVE A,CHANNO(B) + CAIE A,100 ; TTY-IN + CAIN A,101 ; TTY-OUT + JRST .+2 + JRST REOPEN +] + CAME B,TTICHN+1(TVP) + CAMN B,TTOCHN+1(TVP) + JRST REATTY +REATT1: MOVEI B,DIRECT-1(B) ;POINT TO DIRECTION + PUSHJ P,CHRWRD ;CONVERT TO A WORD + JFCL + CAME B,[ASCII /READ/] + JRST TTYOPN + MOVE B,1(AB) ;RESTORE CHANNEL + PUSHJ P,RRESET" ;DO REAL RESET + JRST TTYOPN + +REOPEN: PUSH TP,(AB) ;FIRST CLOSE IT + PUSH TP,(AB)+1 + MCALL 1,FCLOSE + MOVE B,1(AB) ;RESTORE CHANNEL + +; SET UP TEMPS FOR OPNCH + +REOPE1: PUSH P,[0] ; WILL HOLD DIR CODE + PUSH TP,$TPDL + PUSH TP,P + IRP A,,[DIRECT,RNAME1,RNAME2,RDEVIC,RSNAME,ACCESS] + PUSH TP,A-1(B) + PUSH TP,A(B) + TERMIN + + PUSH TP,$TCHAN + PUSH TP,1(AB) + + MOVE A,T.DIR(TB) + MOVE B,T.DIR+1(TB) ; GET DIRECTION + PUSHJ P,CHMOD ; CHECK THE MODE + MOVEM A,(P) ; AND STORE IT + +; NOW SET UP OPEN BLOCK IN SIXBIT +IFN ITS,[ + MOVSI E,-4 ; AOBN PNTR +FRESE2: MOVE B,T.CHAN+1(TB) + MOVEI A,@RDTBL(E) ; GET ITEM POINTER + GETYP 0,-1(A) ; GET ITS TYPE + CAIE 0,TCHSTR + JRST FRESE1 + MOVE B,(A) ; GET STRING + MOVE A,-1(A) + PUSHJ P,STRTO6 +FRESE3: AOBJN E,FRESE2 + HLRZS -3(P) ; FIX DEVICE SPEC +] +IFE ITS,[ + MOVE B,T.CHAN+1(TB) + MOVE A,RDEVIC-1(B) + MOVE B,RDEVIC(B) + PUSHJ P,STRTO6 ; RESULT ON STACK + HLRZS (P) +] + + PUSH P,[0] ; PUSH UP SOME DUMMIES + PUSH P,[0] + PUSH P,[0] + PUSHJ P,OPNCH ; ATTEMPT TO DO THEOPEN + GETYP 0,A + CAIE 0,TCHAN + JRST FINIS ; LEAVE IF FALSE OR WHATEVER + +DRESET: MOVE A,(AB) + MOVE B,1(AB) + SETZM CHRPOS(B) ;INITIALIZE THESE PARAMETERS + SETZM LINPOS(B) + SETZM ACCESS(B) + JRST FINIS + +TTYOPN: MOVE B,1(AB) + CAME B,TTOCHN+1(TVP) + CAMN B,TTICHN+1(TVP) + PUSHJ P,TTYOP2 + PUSHJ P,DOSTAT + DOTCAL RSSIZE,[CHANNO(B),[2000,,C],[2000,,D]] + FATAL .CALL FAILURE + MOVEM C,PAGLN(B) + MOVEM D,LINLN(B) + JRST DRESET + +IFN ITS,[ +FRESE1: CAIE 0,TFIX + JRST BADCHN + PUSH P,(A) + JRST FRESE3 +] + +; INTERFACE TO REOPEN CLOSED CHANNELS + +OPNCHN: PUSH TP,$TCHAN + PUSH TP,B + MCALL 1,FRESET + POPJ P, + +REATTY: PUSHJ P,TTYOP2 + SKIPE NOTTY + JRST DRESET + MOVE B,1(AB) + JRST REATT1 + +; FUNCTION TO LIST ALL CHANNELS + +MFUNCTION CHANLIST,SUBR + + ENTRY 0 + + MOVEI A,N.CHNS-1 ;MAX # OF REAL CHANNELS + MOVEI C,0 + MOVEI B,CHNL1(TVP) ;POINT TO FIRST REAL CHANNEL + +CHNLP: SKIPN 1(B) ;OPEN? + JRST NXTCHN ;NO, SKIP + HRRZ E,(B) ; ABOUT TO FLUSH? + JUMPN E,NXTCHN ; YES, FORGET IT + MOVE D,1(B) ; GET CHANNEL + HRRZ E,CHANNO-1(D) ; GET REF COUNT + PUSH TP,(B) + PUSH TP,1(B) + ADDI C,1 ;COUNT WINNERS + SOJGE E,.-3 ; COUNT THEM +NXTCHN: ADDI B,2 + SOJN A,CHNLP + + SKIPN B,CHNL0(TVP)+1 ;NOW HACK LIST OF PSUEDO CHANNELS + JRST MAKLST +CHNLS: PUSH TP,(B) + PUSH TP,(B)+1 + ADDI C,1 + HRRZ B,(B) + JUMPN B,CHNLS + +MAKLST: ACALL C,LIST + JRST FINIS + + ; ROUTINE TO RESTORE A CLOSED CHANNEL TO ITS PREVIOUS STATE + + +REOPN: PUSH TP,$TCHAN + PUSH TP,B + SKIPN CHANNO(B) ; ONLY REAL CHANNELS + JRST PSUEDO + +IFN ITS,[ + MOVSI E,-4 ; SET UP POINTER FOR NAMES + +GETOPB: MOVE B,(TP) ; GET CHANNEL + MOVEI A,@RDTBL(E) ; GET POINTER + MOVE B,(A) ; NOW STRING + MOVE A,-1(A) + PUSHJ P,STRTO6 ; LEAVES SIXBIT ON STACK + AOBJN E,GETOPB +] +IFE ITS,[ + MOVE A,RDEVIC-1(B) + MOVE B,RDEVIC(B) + PUSHJ P,STRTO6 ; GET DEV NAME IN SIXBIT +] + MOVE B,(TP) ; RESTORE CHANNEL + MOVE A,DIRECT-1(B) + MOVE B,DIRECT(B) + PUSHJ P,CHMOD ; CHECK FOR A VALID MODE + +IFN ITS, HLRZS E,-3(P) ; GET DEVICE IN PROPER PLACE +IFE ITS, HLRZS E,(P) + MOVE B,(TP) ; RESTORE CHANNEL + CAIN E,(SIXBIT /DSK/) + JRST DISKH ; DISK WINS IMMEIDATELY + CAIN E,(SIXBIT /TTY/) ; NO NEED TO RE-OPEN THE TTY + JRST REOPD1 +IFN ITS,[ + ANDI E,777700 ; COULD BE "UTn" + MOVE D,CHANNO(B) ; GET CHANNEL + ASH D,1 + ADDI D,CHNL0(TVP) ; DON'T SEEM TO BE OPEN + SETZM 1(D) + SETZM CHANNO(B) + CAIN E,(SIXBIT /UT /) + JRST REOPD ; CURRENTLY, CANT RESTORE UTAPE CHANNLES + CAIN E,(SIXBIT /AI /) + JRST REOPD ; CURRENTLY CANT RESTORE AI CHANNELS + CAIN E,(SIXBIT /ML /) + JRST REOPD ; CURRENTLY CANT RESTORE ML CHANNELS + CAIN E,(SIXBIT /DM /) + JRST REOPD ; CURRENTLY CANT RESTORE DM CHANNELS +] + PUSH TP,$TCHAN ; TRY TO RESET IT + PUSH TP,B + MCALL 1,FRESET + +IFN ITS,[ +REOPD1: AOS -4(P) +REOPD: SUB P,[4,,4] +] +IFE ITS,[ +REOPD1: AOS -1(P) +REOPD: SUB P,[1,,1] +] +REOPD0: SUB TP,[2,,2] + POPJ P, + +IFN ITS,[ +DISKH: MOVE C,(P) ; SNAME + .SUSET [.SSNAM,,C] +] +IFE ITS,[ +DISKH: MOVEM A,(P) ; SAVE MODE WORD + PUSHJ P,STSTK ; STRING TO STACK + MOVE A,(E) ; RESTORE MODE WORD + PUSH TP,$TPDL + PUSH TP,E ; SAVE PDL BASE + MOVE B,-2(TP) ; CHANNEL BACK TO B +] + MOVE C,ACCESS(B) ; GET CHANNELS ACCESS + TRNN A,2 ; SKIP IF NOT ASCII CHANNEL + JRST DISKH1 + HRRZ D,ACCESS-1(B) ; IF PARTIAL WORD OUT + IMULI C,5 ; TO CHAR ACCESS + JUMPE D,DISKH1 ; NO SWEAT + ADDI C,(D) + SUBI C,5 +DISKH1: HRRZ D,BUFSTR-1(B) ; ANY CHARS IN MUDDLE BUFFER + JUMPE D,DISKH2 + PUSH P,A + PUSH P,C + MOVEI C,BUFSTR-1(B) + PUSHJ P,BYTDOP ; FIND LENGTH OF WHOLE BUFFER + HLRZ D,(A) ; LENGTH + 2 TO D + SUBI D,2 + IMULI D,5 ; TO CHARS + POP P,C + POP P,A +DISKH2: SUBI C,(D) ; UPDATE CHAR ACCESS + IDIVI C,5 ; BACK TO WORD ACCESS + IORI A,6 ; BLOCK IMAGE +IFN ITS,[ + TRNE A,1 + IORI A,100000 ; WRITE OVER BIT + HRLM A,-3(P) + MOVEI A,-3(P) + PUSHJ P,DOOPN + JRST REOPD + MOVE A,C ; ACCESS TO A + PUSHJ P,GETFLN ; CHECK LENGTH + CAIGE 0,(A) ; CHECK BOUNDS + JRST .+3 ; COMPLAIN + PUSHJ P,DOACCS ; AND ACESS + JRST REOPD1 ; SUCCESS + + MOVE A,CHANNO(B) ; CLOSE THE G.D. CHANNEL + PUSHJ P,MCLOSE + JRST REOPD + +DOACCS: PUSH P,A + HRLZ A,CHANNO(B) + ASH A,5 + IOR A,[.ACCESS (P)] + XCT A + POP P,A + POPJ P, + +DOIOTO: +DOIOTI: +DOIOT: + PUSH P,0 + MOVSI 0,TCHAN + MOVEM 0,BSTO(PVP) ; IN CASE OF INTERRUPT + ENABLE + HRLZ 0,CHANNO(B) + ASH 0,5 + IOR 0,[.IOT A] + XCT 0 + DISABLE + SETZM BSTO(PVP) + POP P,0 + POPJ P, + +GETFLN: MOVE 0,CHANNO(B) ; GET CHANNEL + .CALL FILBLK ; READ LNTH + .VALUE + POPJ P, + +FILBLK: SETZ + SIXBIT /FILLEN/ + 0 + 402000,,0 ; STUFF RESULT IN 0 +] +IFE ITS,[ + + HRROI B,1(E) ; TENEX STRING POINTER + MOVEI A,1(P) ; A POINT TO BLOCK OF INFO + PUSH P,[100400,,0] ; FORCE JFN REUSE AND ONLY ACCEPT EXISTING FILE + PUSH P,[377777,,377777] ; NO I/O FOR CORRECTIONS ETC. + REPEAT 6,PUSH P,[0] ; OTHER SLOTS + MOVE D,-2(TP) ; CHANNEL BACK + PUSH P,CHANNO(D) ; AND DESIRED JFN + GTJFN ; GO GET IT + JRST RGTJL ; COMPLAIN + MOVE P,(TP) ; RESTORE P + MOVE A,(P) ; MODE WORD BACK + MOVE B,[440000,,200000] ; FLAG BITS + TRNE A,1 ; SKIP FOR INPUT + TRC B,300000 ; CHANGE TO WRITE + MOVE A,CHANNO(D) ; GET JFN + OPENF + JRST ROPFLS + MOVE E,C ; LENGTH TO E + SIZEF ; GET CURRENT LENGTH + JRST ROPFLS + CAMGE B,E ; STILL A WINNER + JRST ROPFLS + MOVE A,-2(TP) ; CHANNEL + MOVE A,CHANNO(A) ; JFN + MOVE B,C + SFPTR + JRST ROPFLS + SUB TP,[2,,2] ; FLUSH PDL POINTER + JRST REOPD1 + +ROPFLS: MOVE A,-2(TP) + MOVE A,CHANNO(A) + CLOSF ; ATTEMPT TO CLOSE + JFCL ; IGNORE FAILURE + SKIPA + +RGTJL: MOVE P,(TP) + SUB TP,[2,,2] + JRST REOPD + +DOACCS: PUSH P,B + EXCH A,B + MOVE A,CHANNO(A) + SFPTR + JRST ACCFAI + POP P,B + POPJ P, +] +PSUEDO: AOS (P) ; ASSUME SUCCESS FOR NOW + MOVEI B,RDEVIC-1(B) ; SEE WHAT DEVICE IS + PUSHJ P,CHRWRD + JFCL + CAME B,[ASCII /E&S/] ; DISPLAY ? + CAMN B,[ASCII /DIS/] + SKIPA B,(TP) ; YES, REGOBBLE CHANNEL AND CONTINUE + JRST REOPD0 ; NO, RETURN HAPPY + PUSHJ P,DISROP + SOS (P) ; DISPLAY DID NOT REOPEN, UNDO ASSUMPTION OF SUCCESS + JRST REOPD0 + + ;THIS PROGRAM CLOSES THE SPECIFIED CHANNEL + +MFUNCTION FCLOSE,SUBR,[CLOSE] + + ENTRY 1 ;ONLY ONE ARG + GETYP A,(AB) ;CHECK ARGS + CAIE A,TCHAN ;IS IT A CHANNEL + JRST WTYP1 + MOVE B,1(AB) ;PICK UP THE CHANNEL + HRRZ A,CHANNO-1(B) ; GET REF COUNT + SOJGE A,CFIN5 ; NOT READY TO REALLY CLOSE + CAME B,TTICHN+1(TVP) ; CHECK FOR TTY + CAMN B,TTOCHN+1(TVP) + JRST CLSTTY + MOVE A,[JRST CHNCLS] + MOVEM A,IOINS(B) ;CLOBBER THE IO INS + MOVE A,RDEVIC-1(B) ;GET THE NAME OF THE DEVICE + MOVE B,RDEVIC(B) + PUSHJ P,STRTO6 + HLRZS A,(P) + MOVE B,1(AB) ; RESTORE CHANNEL + CAIE A,(SIXBIT /E&S/) + CAIN A,(SIXBIT /DIS/) + PUSHJ P,DISCLS + MOVE B,1(AB) ; IN CASE CLOBBERED BY DISCLS + SKIPN A,CHANNO(B) ;ANY REAL CHANNEL? + JRST REMOV ; NO, EITHER CLOSED OR PSEUDO CHANNEL + + MOVE A,DIRECT-1(B) ; POINT TO DIRECTION + MOVE B,DIRECT(B) + PUSHJ P,STRTO6 ; CONVERT TO WORD + POP P,A + LDB E,[140600,,(P)] ; FIRST CHAR OD DEV NAME + CAIE E,'T ; SKIP IF TTY + JRST CFIN4 + CAME A,[SIXBIT /READ/] ; SKIP IF WINNER + JRST CFIN1 +IFN ITS,[ + MOVE B,1(AB) ; IN ITS CHECK STATUS + LDB A,[600,,STATUS(B)] + CAILE A,2 + JRST CFIN1 +] + PUSH TP,$TCHSTR + PUSH TP,CHQUOTE CHAR + PUSH TP,(AB) + PUSH TP,1(AB) + MCALL 2,OFF ; TURN OFF INTERRUPT +CFIN1: MOVE B,1(AB) + MOVE A,CHANNO(B) +IFN ITS,[ + PUSHJ P,MCLOSE +] +IFE ITS,[ + TLZ A,400000 ; FOR JFN RELEASE + CLOSF ; CLOSE THE FILE AND RELEASE THE JFN + JFCL + MOVE A,CHANNO(B) +] +CFIN: LSH A,1 + ADDI A,CHNL0+1(TVP) ;POINT TO THIS CHANNELS LSOT + SETZM CHANNO(B) + SETZM (A) ;AND CLOBBER IT + HLLZS BUFSTR-1(B) + SETZM BUFSTR(B) + HLLZS ACCESS-1(B) +CFIN2: HLLZS -4(B) + MOVSI A,TCHAN ;RETURN THE CHANNEL + JRST FINIS + +CLSTTY: PUSH TP,$TATOM + PUSH TP,EQUOTE ATTEMPT-TO-CLOSE-TTY-CHANNEL + JRST CALER1 + + +REMOV: MOVEI D,CHNL0(TVP)+1 ;ATTEMPT TO REMOVE FROM PSUEDO CHANNEL LIST +REMOV0: SKIPN C,D ;FOUND ON LIST ? + JRST CFIN2 ;NO, JUST IGNORE THIS CLOSED CHANNEL + HRRZ D,(C) ;GET POINTER TO NEXT + CAME B,(D)+1 ;FOUND ? + JRST REMOV0 + HRRZ D,(D) ;YES, SPLICE IT OUT + HRRM D,(C) + JRST CFIN2 + + +; CLOSE UP ANY LEFTOVER BUFFERS + +CFIN4: CAME A,[SIXBIT /PRINTO/] + CAMN A,[SIXBIT /PRINTB/] + JRST .+3 + CAME A,[SIXBIT /PRINT/] + JRST CFIN1 + MOVE B,1(AB) ; GET CHANNEL + GETYP 0,BUFSTR-1(B) ; IS THERE AN OUTPUT BUFFER + SKIPN BUFSTR(B) + JRST CFIN1 + CAIE 0,TCHSTR + JRST CFINX1 +IFE ITS, PUSH P,A ; SAVE MODE + PUSHJ P,BFCLOS +IFE ITS,[ + POP P,A ; RESTORE MODE + MOVE 0,RDEVIC(B) + ILDB 0,0 + CAIN 0,"D + CAME A,[SIXBIT /PRINT/] + JRST CFINX1 + MOVE A,CHANNO(B) ; GET JFN + TLO A,400000 ; BIT MEANS DONT RELEASE JFN + CLOSF ; CLOSE THE FILE + FATAL CLOSF LOST? + MOVE E,B ; SAVE CHANNEL + MOVE A,CHANNO(B) + HRLI A,11 + MOVSI B,7700 ; MASK + MOVSI C,700 ; MAKE NEW SIZE 7 + CHFDB + HRLI A,12 + SETOM B + MOVE C,ACCESS(E) ; LENGTH IN CHARS + CHFDB +] + HLLZS BUFSTR-1(B) + SETZM BUFSTR(B) +CFINX1: HLLZS ACCESS-1(B) + JRST CFIN1 + +CFIN5: HRRM A,CHANNO-1(B) + JRST CFIN2 + ;SUBR TO DO .ACCESS ON A READ CHANNEL +;FORM: +;POSITIONS CHANNEL AT CHARACTER POSN FIX-NUMBER +;H. BRODIE 7/26/72 + +MFUNCTION MACCESS,SUBR,[ACCESS] + ENTRY 2 ;ARGS: CHANNEL AND FIX-NUMBER + +;CHECK ARGUMENT TYPES + GETYP A,(AB) + CAIE A,TCHAN ;FIRST ARG SHOULD BE CHANNEL + JRST WTYP1 + GETYP A,2(AB) ;TYPE OF SECOND + CAIE A,TFIX ;SHOULD BE FIX + JRST WTYP2 + +;CHECK DIRECTION OF CHANNEL + MOVE B,1(AB) ;B GETS PNTR TO CHANNEL + MOVEI B,DIRECT-1(B) ;GET DIRECTION OF CHANNEL + PUSHJ P,CHRWRD ;GRAB THE CHAR STRNG + JFCL + CAME B,[+1] + JRST MACCA + PUSH P,[2] ;ACCESS ON PRINTB CHANNEL + MOVE B,1(AB) + SKIPE BUFSTR(B) ;SEE IF WE MUST FLUSH PART BUFFER + PUSHJ P,BFCLS1 + JRST MACC +MACCA: PUSH P,[0] ; READ RATHER THAN READB INDICATOR + CAMN B,[ASCIZ /READ/] + JRST .+4 + CAME B,[ASCIZ /READB/] ; READB CHANNEL? + JRST WRONGD + AOS (P) ; SET INDICATOR FOR BINARY MODE + +;CHECK THAT THE CHANNEL IS OPEN +MACC: MOVE B,1(AB) ;GET BACK PTR TO CHANNEL + SKIPN CHANNO(B) ;CLOSED CHANNELS HAVE CHANNO ZEROED OUT + JRST CHNCLS ;IF CHNL CLOSED => ERROR + +;COMPUTE ACCESS PNTR TO ACCESS WORD CHAR IS IN +;REMAINDER IS NUMBER OF TIMES TO INCR BYTE POINTER +ADEVOK: SKIPGE C,3(AB) ;GET CHAR POSN...ALL NEGS = -5 + MOVNI C,-5 +;BUT .ACCESS -1 ISN'T IMPLEMENTED ON ITS YET, SO TELL HIM + JUMPGE C,MACC1 + PUSH TP,$TATOM + PUSH TP,EQUOTE NEGATIVE-ACCESS-NOT-ON-ITS + JRST CALER1 +MACC1: SKIPN (P) + IDIVI C,5 + +;SETUP THE .ACCESS + MOVE B,1(AB) ;GET BACK PTR TO CHANNEL + MOVE A,CHANNO(B) ;A GETS REAL CHANNEL NUMBER +IFN ITS,[ + ROT A,23. ;SET UP IN AC FIELD + IOR A,[.ACCESS 0,C] ;C CONTAINS PLACE TO ACCESS TO + +;DO IT TO IT! + XCT A +] +IFE ITS,[ + MOVE B,C + SFPTR ; DO IT IN TENEX + JRST ACCFAI + MOVE B,1(AB) ; RESTORE CHANNEL +] + POP P,E ; CHECK FOR READB MODE + CAIN E,2 + JRST DONADV ; PRINTB CHANNEL + SKIPE BUFSTR(B) ; IS THERE A READ BUFFER TO FLUSH + JRST .+3 + SETZM LSTCH(B) ; CLEAR OUT POSSIBLE EOF INDICATOR + JRST DONADV + +;NOW FORCE GETCHR TO DO A .IOT FIRST THING + MOVEI C,BUFSTR-1(B) ; FIND END OF STRING + PUSHJ P,BYTDOP" + SUBI A,2 ; LAST REAL WORD + HRLI A,010700 + MOVEM A,BUFSTR(B) + HLLZS BUFSTR-1(B) ; CLOBBER CHAR COUNT + MOVEM A,BUFSTR(B) + SETZM LSTCH(B) ;CLOBBER READ'S HIDDEN CHARACTER + +;NOW DO THE APPROPRIATE NUM OF BYTE ADVANCEMENTS + JUMPLE D,DONADV +ADVPTR: PUSHJ P,GETCHR + MOVE B,1(AB) ;RESTORE IN CASE CLOBBERED + SOJG D,ADVPTR + +DONADV: MOVE C,3(AB) ;FIXUP ACCESS SLOT IN CHNL + MOVEM C,ACCESS(B) + MOVE A,$TCHAN ;TYPE OF RESULT = "CHANNEL" + JRST FINIS ;DONE...B CONTAINS CHANNEL + +IFE ITS,[ +ACCFAI: PUSH TP,$TATOM + PUSH TP,EQUOTE ACCESS-FAILURE + JRST CALER1 +] + + +;WRONG TYPE OF DEVICE ERROR +WRDEV: PUSH TP,$TATOM + PUSH TP,EQUOTE NON-DSK-DEVICE + JRST CALER1 + +; BINARY READ AND PRINT ROUTINES + +MFUNCTION PRINTB,SUBR + + ENTRY 2 + +PBFL: PUSH P,. ; PUSH NON-ZERONESS + JRST BINI1 + +MFUNCTION READB,SUBR + + ENTRY + + PUSH P,[0] + HLRZ 0,AB + CAIG 0,-3 + CAIG 0,-7 + JRST WNA + +BINI1: GETYP 0,(AB) ; SHOULD BE UVEC OR STORE + CAIN 0,TUVEC + JRST BINI2 + CAIE 0,TSTORAGE + JRST WTYP1 ; ELSE LOSE +BINI2: MOVE B,1(AB) ; GET IT + HLRE C,B + SUBI B,(C) ; POINT TO DOPE + GETYP A,(B) + PUSHJ P,SAT" ; GET ITS ST.ALOC.TYPE + CAIE A,S1WORD + JRST WTYP1 + GETYP 0,2(AB) + CAIE 0,TCHAN ; BETTER BE A CHANNEL + JRST WTYP2 + MOVE B,3(AB) ; GET IT + MOVEI B,DIRECT-1(B) ; GET DIRECTION OF + PUSHJ P,CHRWRD ; INTO 1 WORD + JFCL + MOVNI E,1 + CAMN B,[ASCII /READB/] + MOVEI E,0 + CAMN B,[+1] + MOVE E,PBFL + JUMPL E,WRONGD ; LOSER + CAME E,(P) ; CHECK WINNGE + JRST WRONGD + MOVE B,3(AB) ; GET CHANNEL BACK + SKIPN A,IOINS(B) ; OPEN? + PUSHJ P,OPENIT ; LOSE + CAMN A,[JRST CHNCLS] + JRST CHNCLS ; LOSE, CLOSED + JUMPN E,BUFOU1 ; JUMP FOR OUTPUT + CAML AB,[-5,,] ; SKIP IF EOF GIVEN + JRST BINI5 + MOVE 0,4(AB) + MOVEM 0,EOFCND-1(B) + MOVE 0,5(AB) + MOVEM 0,EOFCND(B) +BINI5: SKIPE LSTCH(B) ; INDICATES IF EOF HIT + JRST BINEOF + MOVE A,1(AB) ; GET VECTOR + PUSHJ P,PGBIOI ; READ IT + HLRE C,A ; GET COUNT DONE + HLRE D,1(AB) ; AND FULL COUNT + SUB C,D ; C=> TOTAL READ + ADDM C,ACCESS(B) + JUMPGE A,BINIOK ; NOT EOF YET + SETOM LSTCH(B) +BINIOK: MOVE B,C + MOVSI A,TFIX ; RETURN AMOUNT ACTUALLY READ + JRST FINIS + +BUFOU1: SKIPE BUFSTR(B) ; ANY BUFFERS AROUND? + PUSHJ P,BFCLS1 ; GET RID OF SAME + MOVE A,1(AB) + PUSHJ P,PGBIOO + HLRE C,1(AB) + MOVNS C + addm c,ACCESS(B) + MOVE A,(AB) ; RET VECTOR ETC. + MOVE B,1(AB) + JRST FINIS + + +BINEOF: PUSH TP,EOFCND-1(B) + PUSH TP,EOFCND(B) + PUSH TP,$TCHAN + PUSH TP,B + MCALL 1,FCLOSE ; CLOSE THE LOSER + MCALL 1,EVAL + JRST FINIS + +OPENIT: PUSH P,E + PUSHJ P,OPNCHN ;TRY TO OPEN THE LOSER + JUMPE B,CHNCLS ;FAIL + POP P,E + POPJ P, + ; THESE SUBROUTINES BY NDR 9/16/73 TO FACILITATE THE +; TYPES OF IO NECESSARY TO MAKE MORE EFFICIENT USE OF +; THE NETWORK AND DO RELATED FILE TRANSFER TYPE OF JOBS. + +R1CHAR: SKIPN A,LSTCH(B) ; CHAR READING ROUTINE FOR FCOPY + PUSHJ P,RXCT + MOVEM A,LSTCH(B) + JUMPL A,.+2 ; IN CASE OF -1 ON STY + TRZN A,400000 ; EXCL HACKER + JRST .+4 + MOVEM A,LSTCH(B) ; SAVE DE-EXCLED CHAR + MOVEI A,"! + JRST .+2 + SETZM LSTCH(B) + PUSH P,C + HRRZ C,DIRECT-1(B) + CAIE C,5 ; IF DIRECTION IS 5 LONG THEN READB + JRST R1CH1 + AOS C,ACCESS-1(B) + CAMN C,[TFIX,,1] + AOS ACCESS(B) ; EVERY FIFTY INCREMENT + CAMN C,[TFIX,,5] + HLLZS ACCESS-1(B) + JRST .+2 +R1CH1: AOS ACCESS(B) + POP P,C + POPJ P, + +W1CHAR: CAIE A,15 ; CHAR WRITING ROUTINE, TEST FOR CR + JRST .+3 + SETOM CHRPOS(B) + AOSA LINPOS(B) + CAIE A,12 ; TEST FOR LF + AOS CHRPOS(B) ; IF NOT LF AOS CHARACTE5R POSITION + CAIE A,14 ; TEST FOR FORM FEED + JRST .+3 + SETZM CHRPOS(B) ; IF FORM FEED ZERO CHARACTER POSITION + SETZM LINPOS(B) ; AND LINE POSITION + CAIE A,11 ; IS THIS A TAB? + JRST .+6 + MOVE C,CHRPOS(B) + ADDI C,7 + IDIVI C,8. + IMULI C,8. ; FIX UP CHAR POS FOR TAB + MOVEM C,CHRPOS(B) ; AND SAVE + PUSH P,C + HRRZ C,DIRECT-1(B) + CAIE C,6 ; SIX LONG MUST BE PRINTB + JRST W1CH1 + AOS C,ACCESS-1(B) + CAMN C,[TFIX,,1] + AOS ACCESS(B) + CAMN C,[TFIX,,5] + HLLZS ACCESS-1(B) + JRST .+2 +W1CH1: AOS ACCESS(B) + PUSHJ P,WXCT + POP P,C + POPJ P, + +R1C: SUBM M,(P) ;LITTLE ENTRY FOR COMPILED STUFF + PUSH TP,$TCHAN ;SAVE THE CHANNEL TO BLESS IT + PUSH TP,B + MOVEI B,DIRECT-1(B) + PUSHJ P,CHRWRD + JFCL + CAME B,[ASCIZ /READ/] + CAMN B,[ASCII /READB/] + JRST .+2 + JRST BADCHN + POP TP,B + POP TP,(TP) + SKIPN IOINS(B) ; IS THE CHANNEL OPEN + PUSHJ P,OPENIT ; NO, GO DO IT + PUSHJ P,GRB ; MAKE SURE WE HAVE A READ BUFFER + PUSHJ P,R1CHAR ; AND GET HIM A CHARACTER + JRST MPOPJ ; THATS ALL FOLKS + +W1C: SUBM M,(P) + PUSHJ P,W1CI + JRST MPOPJ + +W1CI: PUSH TP,$TCHAN + PUSH TP,B + PUSH P,A ; ASSEMBLER ENTRY TO OUTPUT 1 CHAR + MOVEI B,DIRECT-1(B) + PUSHJ P,CHRWRD ; INTERNAL CALL TO W1CHAR + JFCL + CAME B,[ASCII /PRINT/] + CAMN B,[+1] + JRST .+2 + JRST BADCHN + POP TP,B + POP TP,(TP) + SKIPN IOINS(B) ; MAKE SURE THAT IT IS OPEN + PUSHJ P,OPENIT + PUSHJ P,GWB + POP P,A ; GET THE CHAR TO DO + JRST W1CHAR + +; ROUTINES TO REPLACE XCT IOINS(B) FOR INPUT AND OUTPUT +; THEY DO THE XCT THEN CHECK OUT POSSIBLE SCRIPTAGE--BLECH. + + +WXCT: PUSH P,A ; SAVE THE CHAR TO WRITE + PUSH TP,$TCHAN ; AND SAVE THE CHANNEL TOO + PUSH TP,B + XCT IOINS(B) ; DO THE REAL ONE + JRST DOSCPT ; AND CHECK OUT SCRIPTAGE + +RXCT: PUSH TP,$TCHAN + PUSH TP,B ; DO IT FOR READS, SAVE THE CHAN + XCT IOINS(B) ; READ IT + PUSH P,A ; AND SAVE THE CHAR AROUND + JRST DOSCPT ; AND CHECK OUT SCRIPTAGE + +DOSCPT: MOVE B,(TP) ;CHECK FOR SCRIPTAGE + SKIPN SCRPTO(B) ; IF ZERO FORGET IT + JRST SCPTDN ; THATS ALL THERE IS TO IT + PUSH P,C ; SAVE AN ACCUMULATOR FOR CLEANLINESS + GETYP C,SCRPTO-1(B) ; IS IT A LIST + CAIE C,TLIST + JRST BADCHN + PUSH TP,$TLIST + PUSH TP,[0] ; SAVE A SLOT FOR THE LIST + MOVE C,SCRPTO(B) ; GET THE LIST OF SCRIPT CHANNELS +SCPT1: GETYP B,(C) ; GET THE TYPE OF THIS SCRIPT CHAN + CAIE B,TCHAN + JRST BADCHN ; IF IT ISN'T A CHANNEL, COMPLAIN + HRRZ B,(C) ; GET THE REST OF THE LIST IN B + MOVEM B,(TP) ; AND STORE ON STACK + MOVE B,1(C) ; GET THE CHANNEL IN B + MOVE A,-1(P) ; AND THE CHARACTER IN A + PUSHJ P,W1CI ; GO TO INTERNAL W1C, IT BLESSES GOODIES + SKIPE C,(TP) ; GET THE REST OF LIST OF CHANS + JRST SCPT1 ; AND CYCLE THROUGH + SUB TP,[2,,2] ; CLEAN OFF THE LIST OF CHANS + POP P,C ; AND RESTORE ACCUMULATOR C +SCPTDN: POP P,A ; RESTORE THE CHARACTER + POP TP,B ; AND THE ORIGINAL CHANNEL + POP TP,(TP) + POPJ P, ; AND THATS ALL + + +; SUBROUTINE TO COPY FROM INCHAN TO OUTCHAN UNTIL EOF HIT +; ON THE INPUT CHANNEL +; CALL IS WHERE DEFAULTS ARE INCHAN AND OUTCHAN + + MFUNCTION FCOPY,SUBR,[FILECOPY] + + ENTRY + HLRE 0,AB + CAMGE 0,[-4] + JRST WNA ; TAKES FROM 0 TO 2 ARGS + + JUMPE 0,.+4 ; NO FIRST ARG? + PUSH TP,(AB) + PUSH TP,1(AB) ; SAVE IN CHAN + JRST .+6 + MOVE A,$TATOM + MOVE B,IMQUOTE INCHAN + PUSHJ P,IDVAL + PUSH TP,A + PUSH TP,B + HLRE 0,AB ; CHECK FOR SECOND ARG + CAML 0,[-2] ; WAS THERE MORE THAN ONE ARG? + JRST .+4 + PUSH TP,2(AB) ; SAVE SECOND ARG + PUSH TP,3(AB) + JRST .+6 + MOVE A,$TATOM ; LOOK UP OUTCHAN AS DEFAULT + MOVE B,IMQUOTE OUTCHAN + PUSHJ P,IDVAL + PUSH TP,A + PUSH TP,B ; AND SAVE IT + + MOVE A,-3(TP) + MOVE B,-2(TP) ; INPUT CHANNEL + MOVEI 0,0 ; INDICATE INPUT + PUSHJ P,CHKCHN ; CHECK FOR GOOD CHANNEL + MOVE A,-1(TP) + MOVE B,(TP) ; GET OUT CHAN + MOVEI 0,1 ; INDICATE OUT CHAN + PUSHJ P,CHKCHN ; CHECK FOR GOOD OUT CHAN + + PUSH P,[0] ; COUNT OF CHARS OUTPUT + + MOVE B,-2(TP) + PUSHJ P,GRB ; MAKE SURE WE HAVE READ BUFF + MOVE B,(TP) + PUSHJ P,GWB ; MAKE SURE WE HAVE WRITE BUFF + +FCLOOP: MOVE B,-2(TP) + PUSHJ P,R1CHAR ; GET A CHAR + JUMPL A,FCDON ; IF A NEG NUMBER WE GOT EOF + MOVE B,(TP) ; GET OUT CHAN + PUSHJ P,W1CHAR ; SPIT IT OUT + AOS (P) ; INCREMENT COUNT + JRST FCLOOP + +FCDON: SUB TP,[2,,2] ; POP OFF OUTCHAN + MCALL 1,FCLOSE ; CLOSE INCHAN + MOVE A,$TFIX + POP P,B ; GET CHAR COUNT TO RETURN + JRST FINIS + +CHKCHN: PUSH P,0 ; CHECK FOR GOOD TASTING CHANNEL + PUSH TP,A + PUSH TP,B + GETYP C,A + CAIE C,TCHAN + JRST CHKBDC ; GO COMPLAIN IN RIGHT WAY + MOVEI B,DIRECT-1(B) + PUSHJ P,CHRWRD + JRST CHKBDC + MOVE C,(P) ; GET CHAN DIRECT + CAMN B,CHKT(C) + JRST .+4 + ADDI C,2 ; TEST FOR READB OR PRINTB ALSO + CAME B,CHKT(C) ; TEST FOR CORRECT DIRECT + JRST CHKBDC + MOVE B,(TP) + SKIPN IOINS(B) ; MAKE SURE IT IS OPEN + PUSHJ P,OPENIT ; IF ZERO IOINS GO OPEN IT + SUB TP,[2,,2] + POP P, ; CLEAN UP STACKS + POPJ P, + +CHKT: ASCIZ /READ/ + ASCII /PRINT/ + ASCII /READB/ + +1 + +CHKBDC: POP P,E + MOVNI D,2 + IMULI D,1(E) + HLRE 0,AB + CAMLE 0,D ; SEE IF THIS WAS HIS ARG OF DEFAULT + JRST BADCHN + JUMPE E,WTYP1 + JRST WTYP2 + + ; FUNCTIONS READSTRING AND PRINTSTRING WORK LIKE READB AND PRINTB, +; THAT IS THEY READ INTO AND OUT OF STRINGS. IN ADDITION BOTH ACCEPT +; AN ADDITIONAL ARGUMENT WHICH IS THE NUMBER OF CHARS TO READ OR PRINT, IF +; IT IS DESIRED FOR THIS TO BE DIFFERENT THAN THE LENGTH OF THE STRING. + +; FORMAT IS +; AND BOTH SUBRS RETURN THE NUMBER OF CHARS READ OR WRITTEN + +; FORMAT FOR PRINTSTRING IS + +; THESE WERE CODED 9/16/73 BY NEAL D. RYAN + + MFUNCTION RSTRNG,SUBR,READSTRING + + ENTRY + PUSH P,[0] ; FLAG TO INDICATE READING + HLRE 0,AB + CAMG 0,[-1] + CAMG 0,[-9] + JRST WNA ; CHECK THAT IT HAS FROM 1 TO 4 ARGS + JRST STRIO1 + + MFUNCTION PSTRNG,SUBR,PRINTSTRING + + ENTRY + PUSH P,[1] ; FLAG TO INDICATE WRITING + HLRE 0,AB + CAMG 0,[-1] + CAMG 0,[-7] + JRST WNA ; CHECK THAT IT HAS FROM 1 TO 3 ARGS + +STRIO1: PUSH TP,[0] ; SAVE SLOT ON STACK + PUSH TP,[0] + GETYP 0,(AB) + CAIE 0,TCHSTR ; MAKE SURE WE GOT STRING + JRST WTYP1 + HRRZ 0,(AB) ; CHECK FOR EMPTY STRING + SKIPN (P) + JUMPE 0,MTSTRN + HLRE 0,AB + CAML 0,[-2] ; WAS A CHANNEL GIVEN + JRST STRIO2 + GETYP 0,2(AB) + CAIE 0,TCHAN + JRST WTYP2 ; SECOND ARG NOT CHANNEL + MOVE B,3(AB) + MOVEI B,DIRECT-1(B) + PUSHJ P,CHRWRD + JFCL + MOVNI E,1 ; CHECKING FOR GOOD DIRECTION + CAMN B,[ASCII /READ/] + MOVEI E,0 + CAMN B,[ASCII /PRINT/] + MOVEI E,1 + CAMN B,[+1] + MOVEI E,1 + CAMN B,[ASCII /READB/] + MOVEI E,0 + CAME E,(P) + JRST WRONGD ; MAKE SURE CHANNEL IS OPEN IN RIGHT MODE + PUSH TP,2(AB) + PUSH TP,3(AB) ; PUSH ON CHANNEL + JRST STRIO3 +STRIO2: MOVE B,IMQUOTE INCHAN + MOVSI A,TCHAN + SKIPE (P) + MOVE B,IMQUOTE OUTCHAN + PUSHJ P,IDVAL + TLZ A,TYPMSK#777777 + CAME A,$TCHAN + JRST BADCHN ; MAKE SURE WE GOT A GOOD DEFAULT CHANNEL + PUSH TP,A + PUSH TP,B +STRIO3: MOVE B,(TP) ; GET CHANNEL + SKIPN E,IOINS(B) ; MAKE SURE HE IS OPEN + PUSHJ P,OPENIT ; IF NOT GO OPEN + CAMN E,[JRST CHNCLS] + JRST CHNCLS ; CHECK TO SEE THAT CHANNEL ISNT ALREADY CLOSED +STRIO4: HLRE 0,AB + CAML 0,[-4] + JRST STRIO5 ; NO COUNT TO WORRY ABOUT + GETYP 0,4(AB) + MOVE E,4(AB) + MOVE C,5(AB) + CAIE 0,TCHSTR + CAIN 0,TFIX ; BETTER BE A FIXED NUMBER + JRST .+2 + JRST WTYP3 + HRRZ D,(AB) ; GET ACTUAL STRING LENGTH + CAIN 0,TFIX + JRST .+7 + SKIPE (P) ; TEST FOR WRITING + JRST .-7 ; IF WRITING WE GOT TROUBLE + PUSH P,D ; ACTUAL STRING LENGTH + MOVEM E,(TB) ; STUFF HIS FUNNY DELIM STRING + MOVEM C,1(TB) + JRST STRIO7 + CAML D,C ; MAKE SURE THE STRING IS LONG ENOUGH + JRST .+4 ; WIN + PUSH TP,$TATOM ; LOSAGE, COUNT TOO GREAT + PUSH TP,EQUOTE COUNT-GREATER-THAN-STRING-SIZE + JRST CALER1 + PUSH P,C ; PUSH ON MAX COUNT + JRST STRIO7 +STRIO5: +STRIO6: HRRZ C,(AB) ; GET CHAR COUNT + PUSH P,C ; AND PUSH IT ON STACK AS NO MAX COUNT GIVEN +STRIO7: HLRE 0,AB + CAML 0,[-6] + JRST .+6 + MOVE B,(TP) ; GET THE CHANNEL + MOVE 0,6(AB) + MOVEM 0,EOFCND-1(B) ; STUFF IN SLOT IN CHAN + MOVE 0,7(AB) + MOVEM 0,EOFCND(B) + PUSH TP,(AB) ; PUSH ON STRING + PUSH TP,1(AB) + PUSH P,[0] ; PUSH ON CURRENT COUNT OF CHARS DONE + MOVE 0,-2(P) ; GET READ OR WRITE FLAG + JUMPN 0,OUTLOP ; GO WRITE STUFF + + MOVE B,-2(TP) ; GET CHANNEL + PUSHJ P,GRB ; MAKE SURE WE HAVE BUFF + SKIPGE A,LSTCH(B) ; CHECK FOR EOF ALREADY READ PREVIOUSLY + JRST SRDOEF ; GO DOES HIS EOF HACKING +INLOP: INTGO + MOVE B,-2(TP) ; GET CHANNEL + MOVE C,-1(P) ; MAX COUNT + CAMG C,(P) ; COMPARE WITH COUNT DONE + JRST STREOF ; WE HAVE FINISHED + PUSHJ P,R1CHAR ; GET A CHAR + JUMPL A,INEOF ; EOF HIT + MOVE C,1(TB) + HRRZ E,(TB) ; DO WE HAVE A STRING TO WORRY US? + SOJL E,INLNT ; GO FINISH STUFFING + ILDB D,C + CAME D,A + JRST .-3 + JRST INEOF +INLNT: IDPB A,(TP) ; STUFF IN STRING + SOS -1(TP) ; DECREMENT STRING COUNT + AOS (P) ; INCREMENT CHAR COUNT + JRST INLOP + +INEOF: SKIPE C,LSTCH(B) ; IS THIS AN ! AND IS THERE A CHAR THERE + JRST .+3 ; YES + MOVEM A,LSTCH(B) ; NO SAVE THE CHAR + JRST .+3 + ADDI C,400000 + MOVEM C,LSTCH(B) + HRRZ C,DIRECT-1(B) ; GET THE TYPE OF CHAN + CAIN C,5 ; IS IT READB? + JRST .+3 + SOS ACCESS(B) ; FIX UP ACCESS FOR READ CHANNEL + JRST STREOF ; AND THATS IT + HRRZ C,ACCESS-1(B) ; FOR A READB ITS WORSE + MOVEI D,5 + SKIPG C + HRRM D,ACCESS-1(B) ; CHANGE A 0 TO A FIVE + SOS C,ACCESS-1(B) + CAMN C,[TFIX,,0] + SOS ACCESS(B) ; AND SOS THE WORD COUNT MAYBE + JRST STREOF + +SRDOEF: SETZM LSTCH(B) ; IN CASE OF -1, FLUSH IT + AOJE A,INLOP ; SKIP OVER -1 ON PTY'S + SUB TP,[6,,6] + SUB P,[3,,3] ; POP JUNK OFF STACKS + PUSH TP,EOFCND-1(B) + PUSH TP,EOFCND(B) ; WHAT WE NEED TO EVAL + PUSH TP,$TCHAN + PUSH TP,B + MCALL 1,FCLOSE ; CLOSE THE LOOSING CHANNEL + MCALL 1,EVAL ; EVAL HIS EOF JUNK + JRST FINIS + +OUTLOP: MOVE B,-2(TP) + PUSHJ P,GWB ; MAKE SURE WE HAVE BUFF +OUTLP1: INTGO + MOVE B,-2(TP) + MOVE C,-1(P) ; MAX COUNT TO DO + CAMG C,(P) ; HAVE WE DONE ENOUGH + JRST STREOF + ILDB A,(TP) ; GET THE CHAR + SOS -1(TP) ; SUBTRACT FROM STRING LENGTH + AOS (P) ; INC COUNT OF CHARS DONE + PUSHJ P,W1CHAR ; GO STUFF CHAR + JRST OUTLP1 + +STREOF: MOVE A,$TFIX + POP P,B ; RETURN THE LOOSER A COUNT OF WHAT WAS DONE + SUB P,[2,,2] + SUB TP,[6,,6] + JRST FINIS + + +GWB: SKIPE BUFSTR(B) + POPJ P, + PUSH TP,$TCHAN + PUSH TP,B ; GET US A WRITE BUFFER ON PRINTB CHAN + MOVEI A,BUFLNT + PUSHJ P,IBLOCK + MOVSI A,TWORD+.VECT. + MOVEM A,BUFLNT(B) + SETOM (B) + MOVEI C,1(B) + HRLI C,(B) + BLT C,BUFLNT-1(B) + MOVE C,B + HRLI C,440700 + MOVE B,(TP) + MOVEI 0,C.BUF + IORM 0,-4(B) + MOVEM C,BUFSTR(B) + MOVE C,[TCHSTR,,BUFLNT*5] + MOVEM C,BUFSTR-1(B) + SUB TP,[2,,2] + POPJ P, + + +GRB: SKIPE BUFSTR(B) + POPJ P, + PUSH TP,$TCHAN + PUSH TP,B ; GET US A READ BUFFER + MOVEI A,BUFLNT + PUSHJ P,IBLOCK + MOVEI C,BUFLNT(B) + POP TP,B + MOVEI 0,C.BUF + IORM 0,-4(B) + HRLI C,440700 + MOVEM C,BUFSTR(B) + MOVSI C,TCHSTR + MOVEM C,BUFSTR-1(B) + SUB TP,[1,,1] + POPJ P, + +MTSTRN: PUSH TP,$TATOM + PUSH TP,EQUOTE EMPTY-STRING + JRST CALER1 + + ; INPUT UNBUFFERING ROUTINE. THIS DOES THE CHARACTER UNBUFFERING +; FOR INPUT. THE OPEN ROUTINE SETUPS A PUSHJ P, TO +; THIS ROUTINE AS THE IOINS FOR A CHANNEL OPEN TO A NON-TTY DEVICE. + +; H. BRODIE 7/19/72 + +; CALLING SEQ: +; PUSHJ P,GETCHR +; B/ AOBJN PNTR TO CHANNEL VECTOR +; RETURNS NEXT CHARACTER IN AC A. +; ON ENCOUNTERING EITHER ^C OR NUL(^@) IT ASSUMES EOF AND +; TRANSMITS ONLY ^C ON SUCCESSIVE CALLS + + +GETCHR: +; FIRST GRAB THE BUFFER + GETYP A,BUFSTR-1(B) ; GET TYPE WORD + CAIN A,TCHSTR ; SKIPS IF NOT CHSTR (I.E. IF BAD BUFFER) + JRST GTGBUF ; IS GOOD BUFFER...SKIP ERROR RETURN +BDCHAN: PUSH TP,$TATOM ; ERROR RETURN + PUSH TP,EQUOTE BAD-INPUT-BUFFER + JRST CALER1 + +; BUFFER WAS GOOD +GTGBUF: HRRZ A,BUFSTR-1(B) ; GET LENGTH OF STRING + SOJGE A,GTGCHR ; JUMP IF STILL MORE + +; HERE IF THE BUFFER WAS EXHAUSTED (BYTE PNTR POINTS INTO DOPE WDS) +; GENERATE AN .IOT POINTER +;FIRST SAVE C AND D AS I WILL CLOBBER THEM +NEWBUF: PUSH P,C + PUSH P,D +IFN ITS,[ + LDB C,[600,,STATUS(B)] ; GET TYPE + CAIG C,2 ; SKIP IF NOT TTY +] +IFE ITS,[ + SKIPE BUFRIN(B) +] + JRST GETTTY ; GET A TTY BUFFER + + PUSHJ P,PGBUFI ; RE-FILL BUFFER + + JUMPGE A,BUFGOO ;SKIPS IF IOT COMPLETED...FIX UP CHANNEL + MOVEI C,1 ; MAKE SURE LAST EOF REALLY ENDS IT + ANDCAM C,-1(A) + MOVSI C,014000 ; GET A ^C + MOVEM C,(A) ;FAKE AN EOF + +; RESET THE BYTE POINTER IN THE CHANNEL. +; BUILD ONE USING THE PTR TO BEG OF BUFFER SAVED IN D +BUFGOO: HRLI D,440700 ; GENERATE VIRGIN LH + + MOVEM D,BUFSTR(B) ; STASH IN THE BUFFER BYTE PNTR SLOT + MOVEI A,BUFLNT*5-1 +BUFROK: POP P,D ;RESTORE D + POP P,C ;RESTORE C + + +; HERE IF THERE ARE CHARS IN BUFFER +GTGCHR: HRRM A,BUFSTR-1(B) + ILDB A,BUFSTR(B) ; GET A CHAR FROM BUFFER +IFE ITS,[ + CAIN A,32 ; TENEX EOF? + JRST .+3 +] + CAIE A,3 ; EOF? + POPJ P, ; AND RETURN +IFN ITS,[ + LDB A,[600,,STATUS(B)] ; CHECK FOR TTY + CAILE A,2 ; SKIP IF TTY +] +IFE ITS, SKIPN BUFRIN(B) + + JRST .+3 +RETEO1: HRRI A,3 + POPJ P, + + HRRZ A,@BUFSTR(B) ; SEE IF RSUBR START BIT IS ON + TRNN A,1 + MOVSI A,-1 + JRST RETEO1 + +IFN ITS,[ +PGBUFO: +PGBUFI: +] +IFE ITS,[ +PGBUFO: SKIPA D,[SOUT] +PGBUFI: MOVE D,[SIN] +] + SKIPGE A,BUFSTR(B) ; POINT TO CURRENT BUFFER POSIT + SUBI A,1 ; FOR 440700 AND 010700 START + SUBI A,BUFLNT-1 ; CALCULATE PNTR TO BEG OF BUFFER + HRLI A,-BUFLNT ; IOT (AOBJN) PNTR IN A +IFN ITS,[ +PGBIOO: +PGBIOI: MOVE D,A ; COPY FOR LATER + MOVSI C,TUVEC ; PREPARE TO HANDDLE INTS + MOVEM C,DSTO(PVP) + MOVEM C,ASTO(PVP) + MOVSI C,TCHAN + MOVEM C,BSTO(PVP) + +; BUILD .IOT INSTR + MOVE C,CHANNO(B) ; CHANNEL NUMBER IN C + ROT C,23. ; MOVE INTO AC FIELD + IOR C,[.IOT 0,A] ; IOR IN SKELETON .IOT + +; DO THE .IOT + ENABLE ; ALLOW INTS + XCT C ; EXECUTE THE .IOT INSTR + DISABLE + SETZM BSTO(PVP) + SETZM ASTO(PVP) + SETZM DSTO(PVP) + POPJ P, +] + +IFE ITS,[ +PGBIOT: PUSH P,D + PUSH TP,$TCHAN + PUSH TP,B + MOVEI C,(A) ; POINT TO BUFFER + HRLI C,444400 + MOVE D,A ; XTRA POINTER + MOVE A,CHANNO(B) ; FILE JFN + MOVE B,C + HLRE C,D ; - COUNT TO C + XCT (P) ; DO IT TO IT + MOVEI A,1(B) + MOVE B,(TP) + SUB TP,[2,,2] + SUB P,[1,,1] + JUMPGE C,CPOPJ ; NO EOF YET + HRLI A,(C) ; LOOK LIKE AN AOBJN PNTR + POPJ P, + +PGBIOO: SKIPA D,[SOUT] +PGBIOI: MOVE D,[SIN] + JRST PGBIOT +DOIOTO: PUSH P,D + PUSH P,C + PUSHJ P,PGBIOO +DOIOTE: POP P,C + POP P,D + POPJ P, +DOIOTI: PUSH P,D + PUSH P,C + PUSHJ P,PGBIOI + JRST DOIOTE +] + +; OUTPUT BUFFERING ROUTINES SIMILAR TO INPUT BUFFERING ROUTINES OF PREV PAGE + +PUTCHR: PUSH P,A + GETYP A,BUFSTR-1(B) ; CHECK TYPE OF ARG + CAIE A,TCHSTR ; MUST BE STRING + JRST BDCHAN + + HRRZ A,BUFSTR-1(B) ; GET CHAR COUNT + JUMPE A,REBUFF ; PREV RESET BUFF, UNDO SAME + +PUTCH1: POP P,A ; RESTORE CHAR + CAMN A,[-1] ; SPECIAL HACK? + JRST PUTCH2 ; YES GO HANDLE + IDPB A,BUFSTR(B) ; STUFF IT +PUTCH3: SOS A,BUFSTR-1(B) ; COUNT DOWN STRING + TRNE A,-1 ; SKIP IF FULL + POPJ P, + +; HERE TO FLUSH OUT A BUFFER + + PUSH P,C + PUSH P,D + PUSHJ P,PGBUFO ; SETUP AND DO IOT + HRLI D,440700 ; POINT INTO BUFFER + MOVEM D,BUFSTR(B) ; STORE IT + MOVEI A,BUFLNT*5 ; RESET COUNT + HRRM A,BUFSTR-1(B) + POP P,D + POP P,C + POPJ P, + +;HERE TO DA ^C AND TURN ON MAGIC BIT + +PUTCH2: MOVEI A,3 + IDPB A,BUFSTR(B) ; ZAP OUT THE ^C + MOVEI A,1 ; GET BIT + IORM A,@BUFSTR(B) ; ON GOES THE BIT + JRST PUTCH3 + +; RESET A FUNNY BUF + +REBUFF: MOVEI A,BUFLNT*5 ; 1ST COUNT + HRRM A,BUFSTR-1(B) + HRRZ A,BUFSTR(B) ; NOW POINTER + SUBI A,BUFLNT + HRLI A,440700 + MOVEM A,BUFSTR(B) ; STORE BACK + JRST PUTCH1 + + +; HERE TO FLUSH FINAL BUFFER + +BFCLOS: HLLZS ACCESS-1(B) ; CLEAR OUT KLUDGE PRINTB PART ACCESS COUNT + MOVE C,B ; THIS BUFFER FLUSHER THE WORK OF NDR + MOVEI B,RDEVIC-1(B) ; FIND OUT IF THIS IS NET + PUSHJ P,CHRWRD + JFCL + TRZ B,77777 ; LEAVE ONLY HIGH 3 CHARS + MOVEI A,0 ; FLAG 0=NET 1=DSK + CAME B,[ASCIZ /NET/] ; IS THIS NET? + AOS A + PUSH P,A ; SAVE THE RESULT OF OUR TEST + MOVE B,C ; RESTORE CHANNEL IN B + JUMPN A,BFCLNN ; DONT HAVE TO CHECK NET STATE + PUSH TP,$TCHAN + PUSH TP,B ; SAVE CHANNEL + PUSHJ P,INSTAT ; GET CURRENT NETWORK STATE + MOVE A,(B) ; GET FIRST ELEMENT OF STATE UVECTOR WHICH IS CUR STATE + POP TP,B ; RESTORE B + POP TP, + CAIE A,5 ; IS NET IN OPEN STATE? + CAIN A,6 ; OR ELSE IS IT IN RFNM WAIT STATE + JRST BFCLNN ; IF SO TO THE IOT + POP P, ; ELSE FLUSH CRUFT AND DONT IOT + POPJ P, ; RETURN DOING NO IOT +BFCLNN: MOVEI C,BUFLNT*5 ; NEW BUFFER FLUSHER BY NDR + HRRZ D,BUFSTR-1(B) ; SO THAT NET ALSO WORKS RIGHT + SUBI C,(D) ; GET NUMBER OF CHARS + IDIVI C,5 ; NUMBER OF FULL WORDS AND REST + PUSH P,D ; SAVE NUMBER OF ODD CHARS + SKIPGE A,BUFSTR(B) ; GET CURRENT BUF POSITION + SUBI A,1 ; FIX FOR 440700 BYTE POINTER + PUSH P,(A) ; SAVE THE ODD WORD OF BUFFER + MOVEI D,BUFLNT + SUBI D,(C) + SKIPE -1(P) + SUBI A,1 + ADDI D,1(A) ; FIX UP FOR POSSIBLE ODD CHARS + PUSH TP,$TUVEC + PUSH TP,D ; PUSH THE DOPE VECTOR ONTO THE STACK + JUMPE C,BFCLSR ; IN CASE THERE ARE NO FULL WORDS TO DO + HRL A,C + MOVE E,[A,,BUFLNT] + SUBI E,(C) ; FIX UP FOR BACKWARDS BLT + POP A,@E ; AMAZING GRACE + TLNE A,-1 + JRST .-2 + HRRO A,D ; SET UP AOBJN POINTER + SUBI A,(C) + TLC A,-1(C) + PUSHJ P,PGBIOO ; DO THE IOT OF ALL THE FULL WORDS +BFCLSR: HRRO A,(TP) ; GET IOT PTR FOR REST OF JUNK + SUBI A,1 ; POINT TO WORD BEFORE DOPE WORDS + POP P,0 ; GET BACK ODD WORD + POP P,C ; GET BACK ODD CHAR COUNT + POP P,D ; FLAG FOR NET OR DSK + JUMPE C,BFCLSD ; IF NO ODD CHARS FINISH UP + JUMPN D,BFCDSK ; GO FINISH OFF DSK + MOVEI D,7 + IMULI D,(C) ; FIND NO OF BITS TO SHIFT + LSH 0,-43(D) ; SHIFT BITS TO RIGHT PLACE + MOVEM 0,(A) ; STORE IN STRING + SUBI C,5 ; HOW MANY CHAR POSITIONS TO SKIP + MOVNI C,(C) ; MAKE C POSITIVE + LSH C,17 + TLC A,(C) ; MUNG THE AOBJN POINTER TO KLUDGE + PUSHJ P,PGBIOO ; DO IOT OF ODD CHARS +BFCLSD: HRRZ A,(TP) ; GET PTR TO DOPE WORD + SUBI A,BUFLNT + HRLI A,440700 ; AOBJN POINTER TO FIRST OF BUFFER + MOVEM A,BUFSTR(B) + MOVEI A,BUFLNT*5 + HRRM A,BUFSTR-1(B) + SUB TP,[2,,2] + POPJ P, + +BFCDSK: MOVE C,A ; FOR FUNNY AOBJN PTR + HLL C,BUFSTR(B) ; POINT INTO WORD AFTER LAST CHAR + TRZ 0,1 + MOVEM 0,(A) +IFN ITS, MOVEI 0,3 ; CONTROL C +IFE ITS, MOVEI 0,32 ; CNTL Z + IDPB 0,C + PUSHJ P,PGBIOO + JRST BFCLSD + +BFCLS1: HRRZ C,DIRECT-1(B) + MOVSI 0,(JFCL) + CAIE C,6 + MOVE 0,[AOS ACCESS(B)] + PUSH P,0 + HRRZ C,BUFSTR-1(B) + IDIVI C,5 + JUMPE D,BCLS11 + MOVEI A,40 ; PAD WITH SPACES + PUSHJ P,PUTCHR + XCT (P) ; AOS ACCESS IF NECESSARY + SOJG D,.-3 ; TO END OF WORD +BCLS11: POP P,0 + HLLZS ACCESS-1(B) + HRRZ C,BUFSTR-1(B) + CAIE C,BUFLNT*5 + PUSHJ P,BFCLOS + POPJ P, + + +; HERE TO GET A TTY BUFFER + +GETTTY: SKIPN C,EXBUFR(B) ; SKIP IF BUFFERS BACKED UP + JRST TTYWAI + HRRZ D,(C) ; CDR THE LIST + GETYP A,(C) ; CHECK TYPE + CAIE A,TDEFER ; MUST BE DEFERRED + JRST BDCHAN + MOVE C,1(C) ; GET DEFERRED GOODIE + GETYP A,(C) ; BETTER BE CHSTR + CAIE A,TCHSTR + JRST BDCHAN + MOVE A,(C) ; GET FULL TYPE WORD + MOVE C,1(C) + MOVEM D,EXBUFR(B) ; STORE CDR'D LIST + MOVEM A,BUFSTR-1(B) ; MAKE CURRENT BUFFER + MOVEM C,BUFSTR(B) + SOJA A,BUFROK + +TTYWAI: PUSHJ P,TTYBLK ; BLOCKED FOR TTY I/O + JRST GETTTY ; SHOULD ONLY RETURN HAPPILY + + ;INTERNAL DEVICE READ ROUTINE. + +;FOR INTERNAL DEVICES THIS ROUTINE APPLIES THE GIVEN OBJECT, +;CHECKS THAT THE RETURNED VALUE IS OF TYPE CHARACTER, +;AND RETURNS THAT AS THE NEXT CHARACTER IN THE "FILE" + +;H. BRODIE 8/31/72 + +GTINTC: PUSH TP,$TCHAN ;SAVE THE CHANNEL...WE'LL CLOBBER B + PUSH TP,B + PUSH P,C ;AND SAVE THE OTHER ACS + PUSH P,D + PUSH P,E + PUSH P,0 + PUSH TP,INTFCN-1(B) + PUSH TP,INTFCN(B) + MCALL 1,APPLY + GETYP A,A + CAIE A,TCHRS + JRST BADRET + MOVE A,B +INTRET: POP P,0 ;RESTORE THE ACS + POP P,E + POP P,D + POP P,C + POP TP,B ;RESTORE THE CHANNEL + SUB TP,[1,,1] ;FLUSH $TCHAN...WE DON'T NEED IT + POPJ P, + + +BADRET: PUSH TP,$TATOM + PUSH TP,EQUOTE INT-DEVICE-WRONG-TYPE-EVALUATION-RESULT + JRST CALER1 + +;INTERNAL DEVICE PRINT ROUTINE. + +;FOR INTERNAL DEVICES THIS ROUTINE APPLIES THE GIVEN OBJECT,(FUNCTION, SUBR, OR RSUBR) +;TO THE CURRENT CHARACTER BEING "PRINTED". + +PTINTC: PUSH TP,$TCHAN ;SAVE THE CHANNEL...WE'LL CLOBBER B + PUSH TP,B + PUSH P,C ;AND SAVE THE OTHER ACS + PUSH P,D + PUSH P,E + PUSH P,0 + PUSH TP,INTFCN-1(B) ;PUSH TYPE OF GIVEN OBJ + PUSH TP,INTFCN(B) ;PUSH THE SUPPLIED FUNCTION (OR SUBR ETC.) + PUSH TP,$TCHRS ;PUSH THE TYPE "CHARACTER" + PUSH TP,A ;PUSH THE CHAR + MCALL 2,APPLY ;APPLY THE FUNCTION TO THE CHAR + JRST INTRET + + + +; ROUTINE TO FLUSH OUT A PRINT BUFFER + +MFUNCTION BUFOUT,SUBR + + ENTRY 1 + + GETYP 0,(AB) + CAIE 0,TCHAN + JRST WTYP1 + + MOVE B,1(AB) + MOVEI B,DIRECT-1(B) + PUSHJ P,CHRWRD ; GET DIR NAME + JFCL + CAMN B,[ASCII /PRINT/] + JRST .+3 + CAME B,[+1] + JRST WRONGD + TRNE B,1 ; SKIP IF PRINT + PUSH P,[JFCL] + TRNN B,1 ; SKIP IF PRINTB + PUSH P,[AOS ACCESS(B)] + MOVE B,1(AB) + GETYP 0,BUFSTR-1(B) + CAIN 0,TCHSTR + SKIPN C,BUFSTR(B) ; BYTE POINTER? + JRST BFIN1 + HRRZ C,BUFSTR-1(B) ; CHARS LEFT + IDIVI C,5 ; MULTIPLE OF 5? + JUMPE D,BFIN2 ; YUP NO EXTRAS + + MOVEI A,40 ; PAD WITH SPACES + PUSHJ P,PUTCHR ; OUT IT GOES + XCT (P) ; MAYBE BUMP ACCESS + SOJG D,.-3 ; FILL + +BFIN2: PUSHJ P,BFCLOS ; WRITE OUT BUFFER +BFIN1: MOVSI A,TCHAN + JRST FINIS + + + +; FUNCTION TO GET THE FILE LENGTH OF A READ CHANNEL + +MFUNCTION FILLNT,SUBR,[FILE-LENGTH] + ENTRY 1 + + GETYP 0,(AB) + CAIE 0,TCHAN + JRST WTYP1 + MOVE B,1(AB) + MOVEI B,DIRECT-1(B) ; GET CHANNEL TYPE + PUSHJ P,CHRWRD + JFCL + CAME B,[ASCIZ /READ/] + JRST .+3 + PUSH P,[5] ; MULTIPLICATIVE FACTOR FOR READ + JRST .+4 + CAME B,[ASCII /READB/] + JRST WRONGD + PUSH P,[1] ; MULTIPLICATIVE FACTOR FOR READ + MOVE C,1(AB) +IFN ITS,[ + .CALL FILL1 + JRST FILLOS ; GIVE HIM A NICE FALSE +] +IFE ITS,[ + MOVE A,CHANNO(C) + SIZEF + JRST FILLOS +] + POP P,C + IMUL B,C + MOVE A,$TFIX + JRST FINIS + +IFN ITS,[ +FILL1: SETZ ; BLOCK FOR .CALL TO FILLEN + SIXBIT /FILLEN/ + CHANNO (C) + SETZM B + +FILLOS: MOVE A,CHANNO(C) + PUSHJ P,GFALS + JRST FINIS +] +IFE ITS,[ +FILLOS: PUSHJ P,TGFALS + JRST FINIS +] + + + ;THREE GENERALLY USEFUL ERROR ROUTINES FOR I/O + +NOTNET: +BADCHN: PUSH TP,$TATOM + PUSH TP,EQUOTE BAD-CHANNEL + JRST CALER1 + +WRONGD: PUSH TP,$TATOM + PUSH TP,EQUOTE WRONG-DIRECTION-CHANNEL + JRST CALER1 + +CHNCLS: PUSH TP,$TATOM + PUSH TP,EQUOTE CHANNEL-CLOSED + JRST CALER1 + +BAD6: PUSH TP,$TATOM + PUSH TP,EQUOTE NON-6-BIT-CHARACTER-IN-FILE-NAME + JRST CALER1 + +DISLOS: MOVE C,$TCHSTR + MOVE D,CHQUOTE [DISPLAY NOT AVAILABLE] + PUSHJ P,INCONS + MOVSI A,TFALSE + JRST OPNRET + +NOCHAN: PUSH TP,$TATOM + PUSH TP,EQUOTE ITS-CHANNELS-EXHAUSTED + JRST CALER1 + +MODE1: 232020,,202020 +MODE2: 232023,,332320 + +END + + diff --git a/sumex/gchack.mcr020 b/sumex/gchack.mcr020 new file mode 100644 index 0000000..35a4123 --- /dev/null +++ b/sumex/gchack.mcr020 @@ -0,0 +1,400 @@ +TITLE GCHACK + +RELOCATABLE + +.INSRT MUDDLE > + +.GLOBAL FRMUNG,PARBOT,TYPVEC,GCHACK,REHASH,IMPURI,NWORDT +.GLOBAL TD.LNT,TD.GET,TD.PUT + +; THIS IS AN INTERNAL MUDDLE SUBROUTINE TO RUN AROUND GC SPACE DOING +; SOMETHING ARBITRARY TO EVERY ENTITY THEREIN + +; CALL -- +; A/ INSTRUCTION TO BE EXECUTED +; PUSHJ P,GCHACK + +GCHACK: HRRZ E,TYPVEC+1(TVP) ; SET UP TYPE POINTER + HRLI E,C ; WILL HAVE TYPE CODE IN C + MOVE B,PARBOT ; START AT PARBOT + SETOM 1(TP) ; FENCE POST PDL + PUSH P,A + MOVEI A,(TB) + PUSHJ P,FRMUNG ; MUNG CURRENT FRAME + POP P,A + +; FIRST HACK PAIR SPACE + +PHACK: CAML B,PARTOP ; SKIP IF MORE PAIRS + JRST VHACK ; DONE, NOW HACK VECTORS + GETYP C,(B) ; TYPE OF CURRENT PAIR + MOVE D,1(B) ; AND ITS DATUM + XCT A ; APPLY INS + ADDI B,2 + JRST PHACK + +; NOW DO THE SAME THING TO VECTOR SPACE + +VHACK: MOVE B,VECTOP ; START AT TOP, MOVE DOWN + SUBI B,1 ; POINT TO TOPMOST VECTOR +VHACK2: CAMG B,VECBOT ; SKIP IF MORE TO DO + JRST REHASQ ; SEE IF MUST REHASH + + HLRE D,-1(B) ; GET TYPE FROM D.W. + HLRZ C,(B) ; AND TOTAL LENGTH + SUBI B,(C)-1 ; POINT TO START OF VECTOR + PUSH P,B + SUBI C,2 ; CHECK WINNAGE + JUMPL C,BADV ; FATAL LOSSAGE + PUSH P,C ; SAVE COUNT + JUMPE C,VHACK1 ; EMPTY VECTOR, FINISHED + +; DECIDE BASED ON TYPE WHETHER GENERAL,UNIFORM OR SPECIAL + + JUMPGE D,UHACK ; UNIFORM + TRNE D,377777 ; SKIP IF GENERAL + JRST SHACK ; SPECIAL + +; FALL THROUGH TO GENERAL + +GHACK1: GETYP C,(B) ; LOOK A T 1ST ELEMENT + CAIE C,TCBLK + CAIN C,TENTRY ; FRAME ON STACK + SOJA B,EHACK + CAIE C,TUBIND + CAIN C,TBIND ; BINDING BLOCK + JRST BHACK + CAIN C,TGATOM ; ATOM WITH GDECL? + JRST GDHACK + MOVE D,1(B) ; GET DATUM + XCT A ; USER INS + ADDI B,2 ; NEXT ELEMENT + SOS (P) + SOSLE (P) ; COUNT ELEMENTS + SKIPGE (B) ; OR FENCE POST HIT + JRST VHACK1 + JRST GHACK1 + +; HERE TO GO OVER UVECTORS + +UHACK: CAMN A,[PUSHJ P,SBSTIS] + JRST VHACK1 ; IF THIS SUBSTITUTE, DONT DO UVEC + MOVEI C,(D) ; COPY UNIFORM TYPE + SUBI B,1 ; BACK OFF + +UHACK1: MOVE D,1(B) ; DATUM + XCT A + SOSLE (P) ; COUNT DOEN + AOJA B,UHACK1 + JRST VHACK1 + +; HERE TO HACK VARIOUS FLAVORS OF SPECIAL GOODIES + +SHACK: ANDI D,377777 ; KILL EXTRA CRUFT + CAIN D,SATOM + JRST ATHACK + CAIE D,STPSTK ; STACK OR + CAIN D,SPVP ; PROCESS + JRST GHACK1 ; TREAT LIKE GENERAL + CAIN D,SASOC ; ASSOCATION + JRST ASHACK + CAIG D,NUMSAT ; TEMPLATE MAYBE? + JRST BADV ; NO CHANCE + ADDI C,(B) ; POINT TO DOPE WORDS + SUBI D,NUMSAT+1 + HRLI D,(D) + ADD D,TD.LNT+1(TVP) + JUMPGE D,BADV ; JUMP IF INVALID TEMPLATE HACKER + + CAMN A,[PUSHJ P,SBSTIS] + JRST VHACK1 + +TD.UPD: PUSH P,A ; INS TO EXECUTE + XCT (D) + HLRZ E,B ; POSSIBLE BASIC LENGTH + PUSH P,[0] + PUSH P,E + MOVEI B,(B) ; ISOLATE LENGTH + PUSH P,C ; SAVE POINTER TO OBJECT + + PUSH P,[0] ; HOME FOR VALUES + PUSH P,[0] ; SLOT FOR TEMP + PUSH P,B ; SAVE + SUB D,TD.LNT+1(TVP) + PUSH P,D ; SAVE FOR FINDING OTHER TABLES + JUMPE E,TD.UP2 ; NO REPEATING SEQ + ADD D,TD.GET+1(TVP) ; COMP LNTH OF REPEATING SEQ + HLRE D,(D) ; D ==> - LNTH OF TEMPLATE + ADDI D,(E) ; D ==> -LENGTH OF REP SEQ + MOVNS D + HRLM D,-5(P) ; SAVE IT AND BASIC + +TD.UP2: SKIPG D,-1(P) ; ANY LEFT? + JRST TD.UP1 + + MOVE E,TD.GET+1(TVP) + ADD E,(P) + MOVE E,(E) ; POINTER TO VECTOR IN E + MOVEM D,-6(P) ; SAVE ELMENT # + SKIPN B,-5(P) ; SKIP IF "RESTS" EXIST + SOJA D,TD.UP3 + + MOVEI 0,(B) ; BASIC LNT TO 0 + SUBI 0,(D) ; SEE IF PAST BASIC + JUMPGE 0,.-3 ; JUMP IF O.K. + MOVSS B ; REP LNT TO RH, BASIC TO LH + IDIVI 0,(B) ; A==> -WHICH REPEATER + MOVNS A + ADD A,-5(P) ; PLUS BASIC + ADDI A,1 ; AND FUDGE + MOVEM A,-6(P) ; SAVE FOR PUTTER + ADDI E,-1(A) ; POINT + SOJA D,.+2 + +TD.UP3: ADDI E,(D) ; POINT TO SLOT + XCT (E) ; GET THIS ELEMENT INTO A AND B + MOVEM A,-3(P) ; SAVE TYPE FOR LATER PUT + MOVEM B,-2(P) + GETYP C,A ; TYPE TO C + MOVE D,B ; DATUME + MOVEI B,-3(P) ; POINTER TO HOME + MOVE A,-7(P) ; GET INS + XCT A ; AND DO IT + MOVE C,-4(P) ; GET POINTER FOR UPDATE OF ELEMENT + MOVE E,TD.PUT+1(TVP) + SOS D,-1(P) ; RESTORE COUNT + ADD E,(P) + MOVE E,(E) ; POINTER TO VECTOR IN E + MOVE B,-6(P) ; SAVED OFFSET + ADDI E,(B)-1 ; POINT TO SLOT + MOVE A,-3(P) ; RESTORE TYPE WORD + MOVE B,-2(P) + XCT (E) ; SMASH IT BACK + FATAL TEMPLATE LOSSAGE + MOVE C,-4(P) + JRST TD.UP2 + +TD.UP1: MOVE A,-7(P) ; RESTORE INS + SUB P,[10,,10] + MOVSI D,400000 ; RESTORE MARK/UNMARK BIT + JRST VHACK1 + +; FATAL LOSSAGE ARRIVES HERE + +BADV: FATAL GC SPACE IN A BAD STATE + +; HERE TO HACK SPECIAL CRUFT IN GENERAL VECTORS (STACKS) + +EHACK: MOVSI D,-FRAMLN ; SET UP AOBJN PNTR + +EHACK1: HRRZ C,ETB(D) ; GET 1ST TYPE + PUSH P,D ; SAVE AOBJN + MOVE D,1(B) ; GET ITEM + CAME A,[PUSHJ P,SBSTIS] ; DONT IF SUBSTITUTE DIFFERENT + XCT A ; USER GOODIE + POP P,D ; RESTORE AOBJN + ADDI B,1 ; MOVE ON + SOSLE (P) ; ALSO COUNT IN TOTAL VECTOR + AOBJN D,EHACK1 + AOJA B,GHACK1 ; AND GO ON + +; TABLE OF ENTRY BLOCK TYPES + +ETB: TSUBR + TTB + TAB + TSP + TPDL + TTP + TWORD + +; HERE TO GROVEL OVER BINDING BLOCKS + +BHACK: MOVEI C,TATOM ; ALSO TREEAT AS ATOM + MOVE D,1(B) + CAME A,[PUSHJ P,SBSTIS] ; DONT IF SUBSTITUTE DIFFERENT + XCT A + PUSHJ P,NXTGDY ; NEXT GOODIE + PUSHJ P,NXTGDY ; AND NEXT + MOVEI C,TSP ; TYPE THE BACK LOCATIVE + PUSHJ P,NXTGD1 ; AND NEXT + PUSH P,B + HLRZ D,-2(B) ; DECL POINTER + MOVEI B,0 ; MAKE SURE NO CLOBBER + MOVEI C,TDECL + XCT A ; DO THE THING BEING DONE + POP P,B + HRLM D,-2(B) ; FIX UP IN CASE CHANGED + JRST GHACK1 + +; HERE TO HACK ATOMS WITH GDECLS + +GDHACK: CAMN A,[PUSHJ P,SBSTIS] + JRST VHACK1 + + MOVEI C,TATOM ; TREAT LIKE ATOM + MOVE D,1(B) + XCT A + HRRZ D,(B) ; GET DECL + JUMPE D,VHACK1 + CAIN D,-1 ; WATCH OUT FOR MAINFEST + JRST VHACK1 + PUSH P,B ; SAVE POINTER + MOVEI B,0 + MOVEI C,TLIST + XCT A + POP P,B + HRRM D,(B) ; RESET + JRST VHACK1 + +; HERE TO HACK ATOMS + +ATHACK: ADDI B,1 ; POINT PRIOR TO OBL SLOT + MOVEI C,TOBLS ; GET TYPE + MOVE D,1(B) ; AND DATUM + CAME A,[PUSHJ P,SBSTIS] ; DONT IF SUBSTITUTE DIFFERENT + XCT A + JRST VHACK1 + +; HERE TO HACK ASSOCIATION BLOCKS + +ASHACK: MOVEI D,3 ; COUNT GOODIES TO MARK + +ASHAK1: PUSH P,D + MOVE D,1(B) + GETYP C,(B) + PUSH P,D ; SAVE POINTER + XCT A + POP P,D ; GET OLD BACK + CAME D,1(B) ; CHANGED? + TLO E,400000 ; SET NON-VIRGIN FLAG + POP P,D + PUSHJ P,BMP ; TO NEXT + SOJG D,ASHAK1 + +; HERE TO GOT TO NEXT VECTOR + +VHACK1: MOVE B,-1(P) ; GET POINTER + SUB P,[2,,2] ; FLUSH CRUFT + SOJA B,VHACK2 ; FIXUP POINTER AND GO ON + +; ROUTINE TO GET A GOODIE + +NXTGDY: GETYP C,(B) +NXTGD1: MOVE D,1(B) + XCT A ; DO IT TO IT +BMP: SOS -1(P) + SOSG -1(P) + JRST BMP1 + ADDI B,2 + POPJ P, +BMP1: SUB P,[1,,1] + JRST VHACK1 + +REHASQ: JUMPL E,REHASH ; HASH TABLE RAPED, FIX IT + POPJ P, + + +MFUNCTION SUBSTI,SUBR,[SUBSTITUTE] + +;THIS FUNCTION CODED BY NDR IS AN INCREDIBLE WAY TO +;KILL YOURSELF, EVEN IF YOU THINK YOU REALLY KNOW WHAT +;YOU ARE DOING. +;IT DOES A MINI-GC CHANGING EACH REFERENCE OF THE +;SECOND ITEM TO A REFERENCE OF THE FIRST ITEM, HA HA HA. +;BOTH ITEMS MUST BE OF THE SAME TYPE OR +;IF NOT, NEITHER CAN BE A TYPE REQUIRING TWO WORDS +; OF STORAGE, AND SUBSTITUTION CANT BE DONE IN +; UVECTORS WHEN THEY ARE DIFFERENT, AS WELL AS IN +; A FEW OTHER YUCKY PLACES. +;RETURNS ITEM TWO--THE ONLY WAY TO GET YOUR HANDS BACK ON IT + + ENTRY 2 + + +SBSTI1: GETYP A,2(AB) + CAIE A,TATOM + JRST SBSTI2 + MOVE B,3(AB) ; IMPURIFY HASH BUCKET MAYBE? + PUSHJ P,IMPURI + +SBSTI2: GETYP A,2(AB) ; GET TYPE OF SECOND ARG + MOVE D,A + PUSHJ P,NWORDT ; AND STORAGE ALLOCATION + MOVE E,A + GETYP A,(AB) ; GET TYPE OF FIRST ARG + MOVE B,A + PUSHJ P,NWORDT + CAMN B,D ; IF TYPES SAME, DONT CHECK FOR ALLOCATION + JRST SBSTI3 + CAIN E,1 + CAIE A,1 + JRST SBSTIL ; LOOSE, NOT BOTH ONE WORD GOODIES + +SBSTI3: MOVEI C,0 + CAIN D,0 ; IF GOODIE IS OF TYPE ZERO + MOVEI C,1 ; USE TYPE 1 TO KEEP INFO FROM CLOBBERAGE + PUSH TP,C + SUBI E,1 + PUSH TP,E ; 1=DEFERRED TYPE ITEM, 0=ELSE + PUSH TP,C + PUSH TP,D ; TYPE OF GOODIE + PUSH TP,C + PUSH TP,[0] + CAIN D,TLIST + AOS (TP) ; 1=TYPE LIST, 0=ELSE + PUSH TP,C + PUSH TP,2(AB) ; TYPE-WORD + PUSH TP,C + PUSH TP,3(AB) ; VALUE-WORD + PUSH TP,(AB) + PUSH TP,1(AB) ; TYPE-VALUE OF THINGS TO CHANGE INTO + MOVE A,[PUSHJ P,SBSTIR] + CAME B,D ; IF NOT SAME TYPE, USE DIFF MUNGER + MOVE A,[PUSHJ P,SBSTIS] + PUSHJ P,GCHACK ; DO-IT + MOVE A,-4(TP) + MOVE B,-2(TP) + JRST FINIS ; GIVE THE LOOSER A HANDLE ON HIS GOODIE + +SBSTIR: CAME D,-2(TP) + JRST LSUB ; THIS IS IT + CAME C,-10(TP) + JRST LSUB ; IF ITEM CANT BE SAME CHECK FOR LISTAGE + JUMPE B,LSUB+1 ; WE GOT HOLD OF A FUNNY GOODIE, JUST IGNORE IT + MOVE 0,(TP) + MOVEM 0,1(B) ; SMASH IT + MOVE 0,-1(TP) ; GET TYPE WORD + SKIPE -12(TP) ; IF THIS IS A DEFFERABLE ITEM THEN WE MUST + MOVEM 0,(B) ; ALSO SMASH THE TYPE WORD SLOT + +LSUB: SKIPN -6(TP) ; IF WE ARE LOOKING FOR LISTS, LOOK ON + POPJ P, ; ELSE THATS ALL + CAMG B,PARTOP + CAMGE B,PARBOT ; IS IT IN LIST SPACE? + POPJ P, ; WELL NO LIST SMASHING THIS TIME + HRRZ 0,(B) ; GET ITS LIST POINTER + CAME 0,-2(TP) + POPJ P, ; THIS ONE DIDNT MATCH + MOVE 0,(TP) ; GET THE NEW REST OF THE LIST + HRRM 0,(B) ; AND SMASH INTO THE REST OF THE LIST + POPJ P, + +SBSTIS: CAMN D,-2(TP) + CAME C,-10(TP) + POPJ P, + SKIPN B ; SEE IF THIS IS A FUNNY GOODIE WE NO TOUCHIE + POPJ P, + MOVE 0,(TP) + MOVEM 0,1(B) ; KLOBBER VALUE CELL + MOVE 0,-1(TP) + HLLM 0,(B) ; KLOBBER TYPE CELL, WHICH WE KNOW IS THERE + POPJ P, + +SBSTIL: PUSH TP,$TATOM ; LOSSAGE ON DIFFERENT TYPES, ONE DOUBLE WORD + PUSH TP,EQUOTE CANT-SUBSTITUTE-WITH-STRING-OR-TUPLE-AND-OTHER + JRST CALER1 + +END + + \ No newline at end of file diff --git a/sumex/initm.mcr186 b/sumex/initm.mcr186 new file mode 100644 index 0000000..e200eca --- /dev/null +++ b/sumex/initm.mcr186 @@ -0,0 +1,785 @@ +TITLE INITIALIZATION FOR MUDDLE + +RELOCATABLE + +LAST==1 ;POSSIBLE CHECKS DONE LATER + +.INSRT MUDDLE > + +SYSQ + +IFE ITS,[ +FATINS==.FATAL" +SEVEC==104000,,204 +] + +IMPURE + +OBSIZE==151. ;DEFAULT OBLIST SIZE + +.LIFG +.LOP .VALUE +.ELDC + + +.GLOBAL SETUP,TPBAS,GCPDL,GCPVP,PVBASE,PVLNT,PARNEW,AAGC,ICR,SWAP,OBLNT,MSGTYP +.GLOBAL ICLOS,OCLOS,GLOBASE,GLOBSP,PARBOT,PARTOP,CODTOP,START,BEGIN,VECBOT,VECTOP,TPBASE +.GLOBAL LISTEN,ROOT,INITIAL,TBINIT,TOPLEV,INTOBL,ERROBL,MUDOBL,TTYOPE,RESFUN,QUITTER +.GLOBAL IOINS,BUFRIN,IOIN2,ECHO,MTYI,MTYO,MUDSTR,P.TOP,TTICHN,TTOCHN,TYPVEC +.GLOBAL PDLBUF,PHIBOT,%UNAM,PURVEC,STOSTR,ISTOST,TD.LNT,TD.PUT,TD.GET,CAFRE1 +; INIITAL AMOUNT OF AFREE SPACE + +STOSTR: BLOCK 400 ; A RANDOM AMOUNT +ISTOST: 401,,0 + +SETUP: +IFN ITS, .SUSET [.RUNAM,,%UNAM] ; FOR AGC'S BENFIT + MOVE P,GCPDL ;GET A PUSH DOWN STACK +IFN ITS, .SUSET [.SMASK,,[200000]] ; ENABLE PDL OVFL + MOVE TVP,[-TVLNT,,TVBASE] ;GET INITIAL TRANSFER VECTOR + PUSHJ P,TTYOPE ;OPEN THE TTY + AOS A,20 ; TOP OF LOW SEGG + HRRZM A,P.TOP + SOSN A ; IF NOTHING YET +IFN ITS, .SUSET [.RMEMT,,P.TOP] +IFE ITS, JRST 4, + HRRE A,P.TOP ; CHECK TOP + TRNE A,377777 ; SKIP IF ALL LOW SEG + JUMPL A,PAGLOS ; COMPLAIN + MOVE A,HITOP ; FIND HI SEG TOP + ADDI A,1777 + ANDCMI A,1777 + MOVEM A,RHITOP ; SAVE IT + MOVEI A,200 + SUBI A,PHIBOT + JUMPE A,HIBOK + MOVSI A,(A) + HRRI A,200 +IFN ITS,[ + .CALL GIVCOR + .VALUE +] +HIBOK: MOVEI B,[ASCIZ /MUDDLE INITIALIZATION. +/] + PUSHJ P,MSGTYP ;PRINT IT + MOVE A,CODTOP ;CHECK FOR A WINNING LOAD + CAML A,VECBOT ;IT BETTER BE LESS + JRST DEATH1 ;LOSE COMPLETELY + MOVE B,PARBOT ;CHECK FOR ANY PAIRS + CAME B,PARTOP ;ANY LOAD/ASSEMBLE TIME PAIRS? + JRST PAIRCH ;YES CHECK THEM + ADDI A,2000 ;BUMP UP + ANDCMI A,1777 + MOVEM A,PARBOT ;UPDATE PARBOT AND TOP + MOVEM A,PARTOP +SETTV: MOVE PVP,[-PVLNT*2,,GCPVP] ;AND A PROCESS VECTOR + MOVEI A,(PVP) ;SET UP A BLT + HRLI A,PVBASE ;FROM PROTOTYPE + BLT A,PVLNT*2-1(PVP) ;INITIALIZE + MOVE TP,[-ITPLNT,,TPBAS] ;GET A STACK FOR THIS PROCCESS + MOVEI TB,(TP) ;AND A BASE + HRLI TB,1 + SUB TP,[1,,1] ;POP ONCE + +; ALLOCATE SOME OBLISTS FOR INITIAL ATOMS + + PUSH P,[5] ;COUNT INITIAL OBLISTS + + PUSH P,OBLNT ;SAVE CURRENT OBLIST DEFAULT SIZE + +MAKEOB: SOS A,-1(P) + MOVE A,OBSZ(A) + MOVEM A,OBLNT + MCALL 0,MOBLIST ;GOBBLE AN OBLIST + PUSH TP,$TOBLS ;AND SAVE THEM + PUSH TP,B + MOVE A,(P)-1 ;COUNT DOWN + MOVEM B,@OBTBL(A) ;STORE + JUMPN A,MAKEOB + + POP P,OBLNT ;RESTORE DEFAULT OBLIST SIZE + + MOVE C,TVP ;MAKE 2 COPIES OF XFER VECTOR POINTER + MOVE D,TVP + +;MAIN INITIALIZE LOOP - SCAN XFER VECTOR FOR ATOMS, UPDATE +;OFFSETS IN CODE, UNIQUIFY ATOMS AND COMPACT XFER VECTOR + +ILOOP: HLRZ A,(C) ;FIRST TYPE + JUMPE A,TVEXAU ;USEFUL STUFF EXHAUSTED + CAIN A,TCHSTR ;CHARACTER STRING? + JRST CHACK ;YES, GO HACK IT + CAIN A,TATOM ;ATOM? + JRST ATOMHK ;YES, CHECK IT OUT + MOVE A,(C) ;MOVE TO NEW HOME (MAY BE SAME) + MOVEM A,(D) + MOVE A,1(C) + MOVEM A,1(D) +SETLP: AOS (P) ;COUNT NUMBER OF PAIRS IN XFER VECTOR + ADD D,[2,,2] ;OUT COUNTER +SETLP1: ADD C,[2,,2] ;AND IN COUNTER + JUMPL C,ILOOP ;JUMP IF MORE TO DO + ;NEW XFER VECTOR FINISHED, NOW GIVE AWAY THE REST + +TVEXAU: HLRE B,C ;GET -LENGTH + SUBI C,(B) ;POIT TO DOPE WORD + ANDI C,-1 ;NO LH + HLRZ A,1(C) ;INTIAL LENGTH TO A + MOVEI E,(C) ;COPY OF POINTER TO DOPW WD + SUBI E,(D) ;AMOUNT LEFT OVER TO E + HRLZM E,1(C) ;CLOBBER INTO DOPE WORD FOR GARBAGE + MOVSI E,(E) ;PREPARE TO UPDATE TVP + ADD TVP,E ;NOW POINTS TO THE RIGHT AMOUNT + HLRE B,D ;-AMOUNT LEFT TO B + ADD B,A ;AMOUNT OF GOOD STUFF + HRLZM B,1(D) ;STORE IT IN GODD DOPE WORD + MOVSI E,400000 ;CLOBBER TO GENERAL IN BOTH CASES + MOVEM E,(C) + MOVEM E,(D) + + +; FIX UP TYPE VECTOR + + MOVE A,TYPVEC+1(TVP) ;GET POINTER + MOVEI 0,0 ;FOR POSSIBLE NULL SLOTS + MOVSI B,TATOM ;SET TYPE TO ATOM + +TYPLP: HLLM B,(A) ;CHANGE TYPE TO ATOM + MOVE C,@1(A) ;GET ATOM + MOVEM C,1(A) + ADD A,[2,,2] ;BUMP + JUMPL A,TYPLP + ; CLOSE TTY CHANNELS +IFN ITS,[ + + .CLOSE 1, + .CLOSE 2, +] + +;GENERAT THE LOGICAL TTY IN AND OUT CHANNELS + +;SETUP CALL TO OPEN OUTPUT TTY CHANNNEL + + IRP A,,[[PRINT,TCHSTR],[TTY:,TCHSTR]] + IRP B,C,[A] + PUSH TP,$!C + PUSH TP,CHQUOTE B + .ISTOP + TERMIN + TERMIN + + MCALL 2,FOPEN ;OPEN THE OUT PUT CHANNEL + MOVEM B,TTOCHN+1(TVP) ;SAVE IT + +;ASSIGN AS GLOBAL VALUE + + PUSH TP,$TATOM + PUSH TP,IMQUOTE OUTCHAN + PUSH TP,A + PUSH TP,B + MOVE A,[PUSHJ P,MTYO] ;MORE WINNING INS + MOVEM A,IOINS(B) ;CLOBBER + MCALL 2,SETG + +;SETUP A CALL TO OPEN THE TTY CHANNEL + + IRP A,,[[READ,TCHSTR],[TTY:,TCHSTR]] + IRP B,C,[A] + PUSH TP,$!C + PUSH TP,CHQUOTE B + .ISTOP + TERMIN + TERMIN + + MCALL 2,FOPEN ;OPEN INPUTCHANNEL + MOVEM B,TTICHN+1(TVP) ;SAVE IT + PUSH TP,$TATOM ;ASSIGN AS A GLOBAL VALUE + PUSH TP,IMQUOTE INCHAN + PUSH TP,A + PUSH TP,B + MOVE C,BUFRIN(B) ;GET AUX BUFFER PTR + MOVE A,[PUSHJ P,MTYI] + MOVEM A,IOIN2(C) ;MORE OF A WINNER + MOVE A,[PUSHJ P,MTYO] + MOVEM A,ECHO(C) ;ECHO INS + MCALL 2,SETG + +;GENERATE AN INITIAL PROCESS AND SWAP IT IN + + PUSHJ P,ICR ;CREATE IT + MOVEI 0,RUNING + MOVEM 0,PSTAT"+1(B) + MOVE D,B ;SET UP TO CALL SWAP + JSP C,SWAP ;AND SWAP IN + MOVEM PVP,MAINPR" ;SAVE AS THE MAIN PROCESS + PUSH TP,[TENTRY,,TOPLEV] ;BUILD DUMMY FRAME + PUSH TP,[1,,0] + MOVEI A,-1(TP) + PUSH TP,A + PUSH TP,SP + PUSH TP,P + MOVE C,TP ;COPY TP + ADD C,[3,,3] ;FUDGE + PUSH TP,C ;TPSAV PUSHED + PUSH TP,[TOPLEV] + HRRI TB,(TP) ;SETUP TB + HRLI TB,2 + ADD TB,[1,,1] + MOVEM TB,TBINIT+1(PVP) + MOVSI A,TSUBR + MOVEM A,RESFUN(PVP) + MOVEI A,LISTEN" + MOVEM A,RESFUN+1(PVP) + PUSH TP,$TATOM + PUSH TP,IMQUOTE THIS-PROCESS + PUSH TP,$TPVP + PUSH TP,PVP + MCALL 2,SETG + +; FIND TVP OFFSET FOR THE ATOM 'T' FOR TEMPLATE + + MOVEI A,MQUOTE T + SUBI A,(TVP) +TVTOFF==0 + ADDSQU TVTOFF + + MOVEM A,SQULOC-1 + + PUSH TP,$TATOM + PUSH TP,IMQUOTE TVTOFF,,MUDDLE + PUSH TP,$TFIX + PUSH TP,A + MCALL 2,SETG + +; HERE TO SETUP SQUOZE TABLE IN PURE CORE + + PUSHJ P,SQSETU ; GO TO ROUTINE + + MOVEI A,400000 ; FENCE POST PURE SR VECTOR + HRRM A,PURVEC(TVP) + MOVE A,TP + HLRE B,A + SUBI A,-PDLBUF(B) ;POINT TO DOPE WORDS + MOVEI B,12 ;GROWTH SPEC + IORM B,(A) + MOVEI 0,ISTOST + MOVEM 0,CODTOP + PUSHJ P,AAGC ;DO IT + AOJL A,.-1 + MOVE A,TPBASE+1(PVP) + SUB A,[640.,,640.] + MOVEM A,TPBASE+1(PVP) + +; CREATE LIST OF ROOT AND NEW OBLIST + + MOVEI A,5 + PUSH P,A + +NAMOBL: PUSH TP,$TATOM + PUSH TP,@OBNAM-1(A) ; NAME + PUSH TP,$TATOM + PUSH TP,IMQUOTE OBLIST + PUSH TP,$TOBLS + PUSH TP,@OBTBL-1(A) + MCALL 3,PUT ; NAME IT + SOS A,(P) + PUSH TP,$TOBLS + PUSH TP,@OBTBL(A) + PUSH TP,$TATOM + PUSH TP,IMQUOTE OBLIST + PUSH TP,$TATOM + PUSH TP,@OBNAM(A) + MCALL 3,PUT + SKIPE A,(P) + JRST NAMOBL + SUB P,[1,,1] + +;Define MUDDLE version number + MOVEI A,5 + MOVEI B,0 ;Initialize result + MOVE C,[440700,,MUDSTR+2] +VERLP: ILDB D,C ;Get next charcter digit + CAIG D,"9 ;Non-digit ? + CAIGE D,"0 + JRST VERDEF + SUBI D,"0 ;Convert to number + IMULI B,10. + ADD B,D ;Include number into result + SOJG A,VERLP ;Finished ? +VERDEF: + PUSH TP,$TATOM + PUSH TP,MQUOTE MUDDLE + PUSH TP,$TFIX + PUSH TP,B + MCALL 2,SETG ;Make definition +OPIPC: +IFN ITS,[ + PUSH TP,$TCHSTR + PUSH TP,CHQUOTE IPC + PUSH TP,$TATOM + PUSH TP,MQUOTE IPC-HANDLER + MCALL 1,GVAL + PUSH TP,A + PUSH TP,B + PUSH TP,$TFIX + PUSH TP,[1] + MCALL 3,ON + MCALL 0,IPCON +] + +; Allocate inital template tables + + MOVEI A,10 + PUSHJ P,CAFRE1 + ADD B,[10,,10] ; REST IT OFF + MOVEM B,TD.LNT+1(TVP) + MOVEI A,10 + PUSHJ P,CAFRE1 + MOVEI 0,TUVEC ; SETUP UTYPE + HRLM 0,10(B) + MOVEM B,TD.GET+1(TVP) + MOVEI A,10 + PUSHJ P,CAFRE1 + MOVEI 0,TUVEC ; SETUP UTYPE + HRLM 0,10(B) + MOVEM B,TD.PUT+1(TVP) + +PTSTRT: MOVEI A,SETUP + ADDI A,1 + SUB A,PARBOT ;FIND WHERE PAIRS SHOULD GO + MOVEM A,PARNEW +IFE ITS,[ + MOVEI A,400000 + MOVE B,[1,,START] + SEVEC +] + PUSH P,[14.,,14.] ;PUSH A SMALL PRGRM ONTO P + MOVEI A,1(P) ;POINT TO ITS START + PUSH P,[JRST AAGC] ;GO TO AGC + PUSH P,[MOVE B,PSTO+1(PVP)] ;GET SAVED P + PUSH P,[SUB B,-13.(P)] ;FUDGE TO POP OFF PROGRAM + PUSH P,[MOVEM B,PSAV(TB)] ;INTO FRAME + PUSH P,[MOVE B,TPSTO+1(PVP)] ;GET TP + PUSH P,[MOVEM B,TPSAV(TB)] ;STORE IT + PUSH P,[MOVE B,SPSTO+1(PVP)] ;SP + PUSH P,[MOVEM B,SPSAV(TB)] + PUSH P,[MOVEI B,TOPLEV] ;WHERE TO GO + PUSH P,[MOVEM B,PCSAV(TB)] +IFN ITS, PUSH P,[MOVSI B,(.VALUE )] +IFE ITS, PUSH P,[MOVSI B,(JRST 4,)] + PUSH P,[HRRI B,C] + PUSH P,[JRST B] ;GO DO VALRET + PUSH P,[B] + PUSH P,A ; PUSH START ADDR + MOVE B,[JRST -11.(P)] + MOVE 0,[JUMPA START] + MOVE C,[ASCII \0/9\] + MOVE D,[ASCII \B/1Q\] + MOVE E,[ASCIZ \ +* +\] ;TERMINATE + POPJ P, ; GO + +; CHECK PAIR SPACE + +PAIRCH: CAMG A,B + JRST SETTV ;O.K. + +DEATH1: MOVEI B,[ASCIZ /LOSSAGE--CODE AND DATA OVERLAP +/] + PUSHJ P,MSGTYP + .VALUE + +;CHARACTER STRING HACKER + +CHACK: MOVE A,(C) ;GET TYPE + HLLZM A,(D) ;STORE IN NEW HOME + MOVE B,1(C) ;GET POINTER + HLRZ E,B ;-LENGHT + HRRM E,(D) + PUSH P,E+1 ; IDIVI WILL CLOBBER + ADDI E,4+5*2 ; ROUND AND ACCOUNT FOR DOPE WORDS + IDIVI E,5 ; E/ WORDS LONG + PUSHJ P,EBPUR ; MAKE A PURIFIED COPY + POP P,E+1 + HRLI B,440700 ;MAKE POINT BYTER + MOVEM B,1(D) ;AND STORE IT + ANDI A,-1 ;CLEAR LH OF A + JUMPE A,SETLP ;JUMP IF NO REF + MOVE E,(P) ;GET OFFSET + LSH E,1 + HRRZ B,-1(A) ;SEE IF PREVIOUS INSTRUCTION REFERS TO $TCHSTR + CAIE B,$TCHSTR ;SKIP IF IT DOES + JRST CHACK1 ;NO, JUST DO CHQUOTE PART + HRRM E,-1(A) ;CLOBBER + MOVEI B,TVP + DPB B,[220400,,-1(A)] ;CLOBBER INDEX FIELD +CHACK1: ADDI E,1 + HRRM E,(A) ;STORE INTO REFERENCE + JRST SETLP + +; SUBROUTINE TO COPY A HUNK OF STRUCTURE TO THE HIGH SEGMENT + +EBPUR: PUSH P,E + PUSH P,A + ADD E,HITOP ; GET NEW TOP + CAMG E,RHITOP ; SKIP IF TOO BIG + JRST EBPUR1 + +; CODE TO GROW HI SEG + + MOVEI A,2000 + ADDB A,RHITOP ; NEW TOP +IFN ITS,[ + ASH A,-10. ; NUM OF BLOCKS + SUBI A,1 ; BLOCK TO GET + .CALL HIGET + .VALUE +] + +EBPUR1: MOVEI A,-1(E) ; NEEDED TO TERMINATE BLT + EXCH E,HITOP + HRLI E,(B) + MOVEI B,(E) + BLT E,(A) + POP P,A + POP P,E + POPJ P, + +GIVCOR: SETZ + SIXBIT /CORBLK/ + 1000,,0 + 1000,,-1 + SETZ A + +HIGET: SETZ + SIXBIT /CORBLK/ + 1000,,100000 + 1000,,-1 + A + 401000,,400001 + + +; PROCESS AN ATOM AND ADD IT TO AN APPROPRIATE OBLIST IF IT ISN'T +; ALREADY THERE + +ATOMHK: PUSH TP,$TOBLS ; SAVE OBLIST + PUSH TP,[0] ; FILLED IN LATER + PUSH TP,$TVEC ;SAVE TV POINTERS + PUSH TP,C + PUSH TP,$TVEC + PUSH TP,D + MOVE B,1(C) ;GET THE ATOM + PUSH TP,$TATOM ;AND SAVE + PUSH TP,B + HRRZ A,(B) ;GET OBLIST SPEC FROM ATOM + LSH A,1 + ADDI A,1(TB) ;POINT TO ITS HOME + PUSH TP,$TOBLS + PUSH TP,(A) ;AND SAV IT + MOVE A,(A) + MOVEM A,-10(TP) ; CLOBBER + HLRE E,A + MOVNS E + + ADD B,[3,,3] ;POINT TO ATOM'S PNAME + MOVEI A,0 ;FOR HASHING + XOR A,(B) + AOBJN B,.-1 + TLZ A,400000 ;FORCE POSITIVE RESULT + IDIV A,E + HRLS B ;REMAINDER IN B IS BUCKET + ADDB B,(TP) ;UPDATE POINTER + + SKIPN C,(B) ;GOBBLE BUCKET CONTENTS + JRST USEATM ;NONE, LEAVE AND USE THIS ATOM +OBLOO3: MOVE E,-2(TP) ;RE-GOBBLE ATOM + ADD E,[3,,3] ;POINT TO PNAME + SKIPN D,1(C) ;CHECK LIST ELEMNT + JRST NXTBCK ;0, CHECK NEXT IN THIS BUCKET + ADD D,[3,,3] ;POINT TO PNAME +OBLOO2: MOVE A,(D) ;GET A WORD + CAME A,(E) ;COMPARE + JRST NXTBCK ;THEY DIFFER, TRY NEX +OBLOOP: AOBJP E,CHCKD ;COULD BE A MATCH, GO CHECK + AOBJN D,OBLOO2 ;HAVEN'T LOST YET + +NXTBCK: HRRZ C,(C) ;CDR THE LIST + JUMPN C,OBLOO3 ;IF NOT NIL, KEEP TRYING + +;HERE IF THIS ATOM MUST BE PUT ON OBLIST + +USEATM: MOVE B,-2(TP) ; GET ATOM + HLRZ 0,(B) ; SEE IF PURE OR NOT + TRNN 0,400000 ; SKIP IF IMPURE + JRST PURATM + MOVE B,(TP) ;POINTER TO BUCKET + HRRZ C,(B) ;POINTER TO LIST IN THIS BUCKET + PUSH TP,$TATOM ;GENERATE CALL TO CONS + PUSH TP,-3(TP) + PUSH TP,$TLIST + PUSH TP,C + MCALL 2,CONS ;CONS IT UP + MOVE C,(TP) ;REGOBBLE BUCKET POINTER + HRRZM B,(C) ;CLOBBER + MOVE B,-2(TP) ;POINT TO ATOM + MOVE C,-10(TP) ; GET OBLIST + MOVEM C,2(B) ; INTO ATOM + PUSHJ P,VALMAK ;MAKE A GLOBAL VALUE FOR THIS LOSER +PURAT2: MOVE C,-6(TP) ;RESET POINTERS + MOVE D,-4(TP) + SUB TP,[12,,12] + MOVE B,(C) ;MOVE THE ENTRY + HLLZM B,(D) ;DON'T WANT REF POINTER STORED + MOVE A,1(C) ;AND MOVE ATOM + MOVEM A,1(D) + MOVE A,(P) ;GET CURRENT OFFSET + LSH A,1 + ADDI A,1 + ANDI B,-1 ;CHECK FOR REAL REF + JUMPE B,SETLP1 ;DON'T SAVE THIS ATOM ON TVP + HRRM A,(B) ;CLOBBER CODE + JRST SETLP + + +; HERE TO MAKE A PURE ATOM + +PURATM: HRRZ B,-2(TP) ; POINT TO IT + HLRE E,-2(TP) ; - LNTH + MOVNS E + ADDI E,2 + PUSHJ P,EBPUR ; PURE COPY + HRRM B,-2(TP) ; AND STORE BACK + HRRO B,(TP) ; GET BUCKET BACK +PURAT1: HRRZ C,(B) ; GET CONTENTS + JUMPE C,HICONS ; AT END, OK + CAIL C,HIBOT ; SKIP IF IMPURE + JRST HICONS ; CONS IT ON + MOVEI B,(C) + JRST PURAT1 + +HICONS: HRLI C,TATOM + PUSH P,C + PUSH P,-2(TP) + PUSH P,B + MOVEI B,-2(P) + MOVEI E,2 + PUSHJ P,EBPUR ; MAKE PURE LIST CELL + + MOVE C,(P) + SUB P,[3,,3] + HRRM B,(C) ; STORE IT + MOVE B,1(B) ; ATOM BACK + MOVE C,-6(TP) ; GET TVP SLOT + HRRM B,1(C) ; AND STORE + HLRZ 0,(B) ; TYPE OF VAL + MOVE C,B + CAIN 0,TUNBOU ; NOT UNBOUND? + JRST PURAT3 ; UNBOUND, NO VAL + MOVEI E,2 ; COUNT AGAIN + PUSHJ P,EBPUR ; VALUE CELL + MOVE C,-2(TP) ; ATOM BACK + HLLZS (B) ; CLEAR LH + MOVSI 0,TLOCI + HLLM 0,(C) + MOVEM B,1(C) +PURAT3: HRRZ A,(C) ; GET OBLIST CODE + MOVE A,OBTBL2(A) + MOVEM A,2(C) ; STORE OBLIST SLOT + HLLZS (C) + JRST PURAT2 + +; A POSSIBLE MATCH ARRIVES HERE + +CHCKD: AOBJN D,NXTBCK ;SIZES DIFFER, JUMP + MOVE D,1(C) ;THEY MATCH!, GET EXISTING ATOM + MOVEI A,(D) ;GET TYPE OF IT + MOVE B,-2(TP) ;GET NEW ATOM + HLRZ 0,(B) + TRZ A,377777 ; SAVE ONLY 400000 BIT + TRZ 0,377777 + CAIN 0,(A) ; SKIP IF WIN + JRST IM.PUR + MOVSI 0,400000 + ANDCAM 0,(B) + ANDCAM 0,(D) + HLRZ A,(D) + CAIE A,TUNBOU ;UNBOUND? + JRST A1VAL ;YES, CONTINUE + MOVE A,(B) ;MOVE VALUE + MOVEM A,(D) + MOVE A,1(B) + MOVEM A,1(D) + MOVE B,D ;EXISTING ATOM TO B + MOVEI 0,(B) + CAIL 0,HIBOT + JRST .+3 + PUSHJ P,VALMAK ;MAKE A VALUE + JRST .+2 + PUSHJ P,PVALM + +;NOW FIND ATOMS OCCURENCE IN XFER VECTOR + +OFFIND: MOVE D,-4(TP) ;GET CURRENT POINTER INTO TP + MOVE C,TVP ;AND A COPY OF TVP + MOVEI A,0 ;INITIALIZE COUNTER +ALOOP: CAMN B,1(C) ;IS THIS IT? + JRST AFOUND + ADD C,[2,,2] ;BUMP COUNTER + CAMGE C,D ;HAVE WE HIT END + AOJA A,ALOOP ;NO, KEEP LOOKING + + MOVEI B,[ASCIZ /LOSSAGE--ATOM DISAPPEARED +/] +TYPIT: PUSHJ P,MSGTYP + .VALUE + +AFOUND: LSH A,1 ;FOUND ATOM, GET REAL OFFSET + ADDI A,1 + MOVE C,-6(TP) ;GET TV POINTER TO NEW ATOM + HRRZ B,(C) ;POINT TO REFERENCE + SKIPE B ;ANY THERE? + HRRM A,(B) ;YES, CLOBBER AWAY + SUB TP,[12,,12] + JRST SETLP1 ;AND GO ON + +A1VAL: HLRZ C,(B) ;GET VALUE'S TYPE + MOVE B,D ;NOW PUT EXISTING ATOM IN B + CAIN C,TUNBOU ;UNBOUND? + JRST OFFIND ;YES, WINNER + + MOVEI B,[ASCIZ /LOSSAGE--ATOM TRIES TO HAVE 2 VALUES +/] + JRST TYPIT + + +IM.PUR: MOVEI B,[ASCIZ /LOSSAG--ATOM TRIES TO BE BOTH PURE AND IMPURE +/] + JRST TYPIT + +PAGLOS: MOVEI B,[ASCIZ /LOSSAGE--IMPURE CORE EXTENDS INTO HIGH SEGMENT +/] + JRST TYPIT + +;MAKE A VALUE IN SLOT ON GLOBAL SP + +VALMAK: HLRZ A,(B) ;TYPE OF VALUE + CAIE A,400000+TUNBOU + CAIN A,TUNBOU ;VALUE? + POPJ P, ;NO, ALL DONE + MOVE A,GLOBSP+1(TVP) ;GET POINTER TO GLOBAL SP + SUB A,[4,,4] ;ALLOCATE SPACE + CAMG A,GLOBAS+1(TVP) ;CHECK FOR OVERFLOW + JRST SPOVFL + MOVEM A,GLOBSP+1(TVP) ;STORE IT BACK + MOVE C,(B) ;GET TYPE CELL + TLZ C,400000 + HLLZM C,2(A) ;INTO TYPE CELL + MOVE C,1(B) ;GET VALUE + MOVEM C,3(A) ;INTO VALUE SLOT + MOVSI C,TGATOM ;GET TATOM,,0 + MOVEM C,(A) + MOVEM B,1(A) ;AND POINTER TO ATOM + MOVSI C,TLOCI ;NOW CLOBBER THE ATOM + MOVEM C,(B) ;INTO TYPE CELL + ADD A,[2,,2] ;POINT TO VALUE + MOVEM A,1(B) + POPJ P, + +SPOVFL: MOVEI B,[ASCIZ /LOSSAGE--GLOBAL SP OVERFLOW +/] + JRST TYPIT + + +PVALM: HLRZ 0,(B) + CAIE 0,400000+TUNBOU + CAIN 0,TUNBOU + POPJ P, + MOVEI E,2 + PUSH P,B + PUSHJ P,EBPUR + POP P,C + MOVEM B,1(C) + MOVSI 0,TLOCI + MOVEM 0,(C) + MOVE B,C + POPJ P, + ;SET UP LIST OF INTERNAL NAMES AND ADDRESS NEEDED BY COMPILER + +VECTGO DUMMY1 + +IRP A,,[FINIS,SPECBIND,MESTBL,WNA,WRONGT,$TLOSE,CALER1 +ILOC,IGLOC,IDVAL,ILVAL,IGVAL,INTFLG,LCKINT,TYPLOO,TDEFER +IFALSE,UNAS,UNBOU,RCALL,SEGMNT,SEGLST,NUMPRI,DISXTR,SSPEC1,COMPERR +MAKACT,MAKENV,BFRAME,TTP,TTB,$TTP,$TTB,MAKTUP,TPALOC,IBIND,SSPECS +CILVAL,CISET,CIGVAL,CSETG,IBLOK1,IBLOCK,CLLOC,CGLOC,CASSQ,CGASSQ +CILNT,CILNQ,CILEGQ,CEMPTY,CIEQUA,CIREST,CINTH,CIAT,CSETLO,CIN +CIPUT,CIGET,CIGETL,CIMON,CISTRU,CIMEMQ,CIMEMB,CITOP,CIBACK,TYPSEG +CICONS,CIUVEC,CIVEC,IIFORM,IILIST,CISTNG,HITOP,INCR1,TYPG,VALG,TESTR +OTBSAV,CITYPE,CFRAME,CARGS,CFUNCT,CUTYPE,CPTYPE,CTYPEP,CTYPEQ,CCHUTY +CIREMA,RTFALS,CIGETP,CIGTPR,MPOPJ,TAB,$TAB,ICONS,CSTO,DSTO,NTPALO +CPLUS,CTIMES,CTIME,CDIVID,CMINUS,CLQ,CLEQ,CGQ,CGEQ,CLOG,CSIN,CCOS,CATAN,CSQRT +CFIX,CFLOAT,CEXP,CRAND,CINEQU,SPECBND,PGGIVE,PGFIND,MTYO,CMIN,CMAX,RCL,R1C,W1C +CALLTY,CTYPEC,CTYPEW,NOTTY,CHKAB,CTMPLT,IUNWIN,UNWIN2,NOSHUF,ROOT,ERROBL,INTOBL +CINSER,CIRMV,CLOOKU,CATOM,CIPNAM,ISTRCM,CITERP,CIPRIN,CIPRN1,CIPRNC +CPATM,CP1ATM,CPCATM,CPSTR,CP1STR,CPCSTR,CPCH,CREADC,CNXTCH,CREDC1,CNXTC1 +CGBOUN,IIGLOC,MAKTU2,CIFLTZ,CIUPRS] + .GLOBAL A + ADDSQU A + MAKAT [A]TFIX,A,MUDDLE,0 +TERMIN + +VECRET + +; ROUTINE TO SORT AND PURIFY SQUOZE TABLE + +SQSETU: MOVE A,[SQUTBL-SQULOC+2,,SQUTBL] + MOVEI 0,1 +SQ2: MOVE B,(A) + CAMG B,2(A) + JRST SQ1 + MOVEI 0,0 + EXCH B,2(A) + MOVEM B,(A) + MOVE B,1(A) + EXCH B,3(A) + MOVEM B,1(A) +SQ1: ADD A,[2,,2] + JUMPL A,SQ2 + JUMPE 0,SQSETU + MOVEI E,SQULOC-SQUTBL + MOVEI B,SQUTBL + PUSHJ P,EBPUR ; TO THE PURE WORLD + HRLI B,SQUTBL-SQULOC + MOVEM B,SQUPNT" + POPJ P, + +RHITOP: 0 + +OBSZ: 151. + 151. + 151. + 151. + 317. + +OBTBL2: ROOT+1 + ERROBL+1 + INTOBL+1 + MUDOBL+1 + INITIAL+1 + +OBTBL: INITIAL+1(TVP) + MUDOBL+1(TVP) + INTOBL+1(TVP) + ERROBL+1(TVP) + ROOT+1(TVP) +OBNAM: MQUOTE INITIAL + MQUOTE MUDDLE + MQUOTE INTERRUPTS + MQUOTE ERRORS + MQUOTE ROOT + +END SETUP + + + diff --git a/sumex/interr.mcr239 b/sumex/interr.mcr239 new file mode 100644 index 0000000..b71bf2d --- /dev/null +++ b/sumex/interr.mcr239 @@ -0,0 +1,2261 @@ +TITLE INTERRUPT HANDLER FOR MUDDLE + +RELOCATABLE + +;C. REEVE APRIL 1971 + +.INSRT MUDDLE > + +SYSQ + +IF1,[ +IFE ITS,.INSRT MUDSYS;STENEX > +] + +PDLGRO==10000 ;AMOUNT TO GROW A PDL THAT LOSES +NINT==72. ;MAXIMUM NUMBER OF INTERRUPTS POSSIBLE + +IFN ITS,[ +;SET UP LOCATION 42 TO POINT TO TSINT + +RMT [ + +ZZZ==$. ;SAVE CURRENT LOCATION + +LOC 42 + + JSR MTSINT ;GO TO HANDLER + +LOC ZZZ +] +] + +; GLOBALS NEEDED BY INTERRUPT HANDLER + +.GLOBAL ONINT ; FUDGE INS EXECUTED IF NON ZERO AT START OF INTERRUPT +.GLOBA GCFLG ;TELLS WHETHER OR NOT GARBAGE COLLECTOR IS RUNNING +.GLOBAL GCFLCH ; FLUSH CHARS IMMEDIATE SO GC CAN SEE THEM +.GLOBAL CORTOP ; TOP OF CORE +.GLOBA GCINT ;TELLS GARBAGE COLLECTOR TO SIMULATE AN INTERRUPT +.GLOBAL INTNUM,INTVEC ;TV ENTRIES CONCERNING INTERRUPTS +.GLOBAL AGC ;CALL THE GARBAGE COLLECTOR +.GLOBAL VECNEW,PARNEW,GETNUM ;GC PSEUDO ARGS +.GLOBAL GCPDL ;GARBAGE COLLECTORS PDL +.GLOBAL VECTOP,VECBOT ;DELIMIT VECTOR SPACE +.GLOBAL PURTOP +.GLOBAL PDLBUF ;AMOUNT OF PDL GROWTH +.GLOBAL PGROW ;POINTS TO DOPE WORD OF NEXT PDL TO GROW +.GLOBAL TPGROW ;POINTS TO NEXT MUDDLE PDL TO GROW +.GLOBAL TOPLEV,ERROR%,N.CHNS,CHNL1 +.GLOBAL BUFRIN,CHNL0,SYSCHR ;CHANNEL GLOBALS +.GLOBAL IFALSE,TPOVFL,1STEPR,INTOBL,INCHAR,CURPRI,RDEVIC,RDIREC,GFALS,STATUS +.GLOBAL PSTAT,NOTRES,IOIN2,INAME,INTFCN,CHNCNT,CHANNO,GIBLOK,ICONS,INCONS +.GLOBAL IEVECT,INSRTX,ILOOKC,IPUT,IREMAS,IGET,CSTAK,EMERGE +.GLOBAL MTSINT ;BEGINNING OF INTERRUPT HANDLER +.GLOBAL INTINT ;CALLED BY INITIALIZER TO TAKE CARE OF INT PCS +.GLOBAL FRMSTK,APPLY,CHUNW +.GLOBAL IPCGOT,DIRQ ;HANDLE BRANCHING OFF TO IPC KLUDGERY + +; GLOBALS FOR GC +.GLOBAL GCTIM,GCCAUS,GCCALL + +; GLOBALS FOR MONITOR ROUTINES + +.GLOBAL MONCH,MONCH0,RMONCH,RMONC0,LOCQ,SMON,BAPT,APLQ,MAKACT,NAPT +.GLOBAL PURERR,BUFRIN,INSTAT + +MONITOR + +.GLOBAL MSGTYP,MTYI,UPLO,IFLUSH,OCLOS,ERRET,MASK1,MASK2 ;SUBROUTINES USED +.GLOBAL ERROR,LISTEN,ECHO,RRESET,MTYO,GCHAPN,P.CORE,P.TOP,QUEUES,NOTTY,TTYOP2,TTICHN +.GLOBAL INTHLD,BNDV,SPECBE +;BEGINNING OF ACTUAL INTERRUPT HANDLER (MUST BE IMPURE) + + +;***** TEMP FUDGE ******* + +QUEUES==INTVEC + + +; DECLARATIONS ASSOCIATED WITH INTERRUPT HANDERS AND HEADERS + +; SPECIAL TABLES + +SPECIN: IRP A,,[CHAR,CLOCK,MPV,ILOPR,WRITE,READ,IOC,PURE,SYSDOWN,INFERIOR,RUNT,REALT +PARITY] + MQUOTE A,[A]INTRUP + TERMIN +SPECLN==.-SPECIN + +; TABLE OF SPECIAL FINDING ROUTINES + +FNDTBL: IRP A,,[GETCHN,0,0,0,LOCGET,LOCGET,0,0,0,0,0,0,0] + A + TERMIN + +; TABLE OF SPECIAL SETUP ROUTINES + +INTBL: IRP A,,[S.CHAR,S.CLOK,S.MPV,S.ILOP,S.WMON,S.RMON,S.IOC,S.PURE,S.DOWN,S.INF +S.RUNT,S.REAL,S.PAR] + A + S!A==.IRPCNT + TERMIN + +IFN ITS,[ + +; EXTERNAL INTERRUPT TABLE + +EXTINT: REPEAT NINT-36.,0 + REPEAT 16.,HCHAR + 0 + 0 + REPEAT 8.,HINF + REPEAT NINT-62.,0 +EXTEND: + +IRP A,,[[HCLOCK,13.],[HMPV,14.],[HILOPR,6],[HIOC,9],[HPURE,26.],[HDOWN,7],[HREAL,35.] +[HRUNT,34.],[HPAR,28.]] + IRP B,C,[A] + LOC EXTINT+C + B + .ISTOP + TERMIN +TERMIN + + +LOC EXTEND +] + +IFE ITS,[ + +; TABLES FOR TENEX INTERRUPT SYSTEM + +LEVTAB: P1 ; POINTS TO INT PC HOLDERS FOR LEVS 1,2 AND 3 + P2 + P3 + +CHNMSK==0 ; WILL BE MASK WORD FOR INT SET UP +MFORK==400000 +NNETS==10. ; ALLOW 10 NETWRK INTERRUPTS +NETCHN==36.-NNETS + +CHNTAB: ; LOCATION OF INT ROUTINES FOR VARIOUS "CHANNELS" + BLOCK 36.-NNETS ; THERE AR 36. TENEX INT CHANNELS + +REPEAT NNETS, 1,,INTNET+3*.RPCNT + +IRP A,,[[0,CNTLG],[1,CNTLS],[9.,TNXPDL]] + IRP B,C,[A] + LOC CHNTAB+B + 1,,C + CHNMSK==CHNMSK+<1_<35.-B>> + .ISTOP + TERMIN +TERMIN +LOC CHNTAB+36. + +EXTINT: BLOCK NINT-NNETS + +REPEAT NNETS,HNET + +IRP A,,[[HCNTLG,36.],[HCNTLS,37.]] + IRP B,C,[A] + LOC EXTINT+C + B + .ISTOP + TERMIN +TERMIN +LOC EXTINT+NINT +] + + +; HANDLER/HEADER PARAMETERS + +; HEADER BLOCKS + +IHDRLN==4 ; LENGTH OF HEADER BLOCK + +INAME==0 ; NAME OF INTERRUPT +ISTATE==2 ; CURRENT STATE +IHNDLR==4 ; POINTS TO LIST OF HANDLERS +INTPRI==6 ; CONTAINS PRIORITY OF INTERRUPT + +IHANDL==4 ; LENGTH OF A HANDLER BLOCK + +INXT==0 ; POINTS TO NEXTIN CHAIN +IPREV==2 ; POINTS TO PREV IN CHAIN +INTFCN==4 ; FUNCTION ASSOCIATED WITH THIS HANDLER +INTPRO==6 ; PROCESS TO RUN INT IN + +IFN ITS,[ +RMT [ +IMPURE +TSINT: +MTSINT: 0 ;INTERRUPT BITS GET STORED HERE +TSINTR: 0 ;INTERRUPT PC WORD STORED HERE + JRST TSINTP ;GO TO PURE CODE + +; SOFTWARE INTERNAL INTERRUPTS JSR TO HERE + +LCKINT: 0 + JRST DOINT + +PURE +] +] +IFE ITS,[ +RMT [ +; JSR HERE FOR SOFTWARE INTERNAL INTERRUPTS + +LCKINT: 0 + JRST DOINT +] +] + + +IFN ITS,[ + +;THE REST OF THIS CODE IS PURE + +TSINTP: SOSGE INTFLG ; SKIP IF ENABLED + SETOM INTFLG ;DONT GET LESS THAN -1 + + MOVEM A,TSAVA ;SAVE TWO ACS + MOVEM B,TSAVB + MOVE A,TSINT ;PICK UP INT BIT PATTERN + JUMPL A,2NDWORD ;DONT CHECK FOR PDL OVERFLOW ETC. IF SIGN BIT ON + + TRZE A,200000 ;IS THIS A PDL OVERFLOW? + JRST IPDLOV ;YES, GO HANDLE IT FIRST + +IMPCH: MOVEI B,0 + TRNE A,20000 ;IS IT A MEMORY PROTECTION VIOLATION? + MOVEI B,1 ; FLAG SAME + + TRNE A,40 ;ILLEGAL OP CODE? + MOVEI B,2 ; ALSO FLAG + TRNN A,400 ; IOC? + JRST .+3 + SOS TSINTR + MOVEI B,3 + TLNE A,200 ; PURE? + MOVEI B,4 + SOJGE B,DO.NOW ; CANT WAIT AROUND + +;DECODE THE REST OF THE INTERRUPTS USING A TABLE + +2NDWORD: + JUMPL A,GC2 ;2ND WORD? + IORM A,PIRQ ;NO, INTO WORD 1 + JRST GCQUIT ;AND DISMISS INT + +GC2: TLZ A,400000 ;TURN OFF SIGN BIT + IORM A,PIRQ2 + TRNE A,177777 ;CHECK FOR CHANNELS + JRST CHNACT ;GO IF CHANNEL ACTIVITY +] +GCQUIT: SKIPGE INTFLG ;SKIP IF INTERRUPTS ENABLED + JRST INTDON ;NO, DEFER REAL HANDLING UNTIL LATER + + MOVE A,TSINTR ;PICKUP RETURN WORD +IFE ITS,[ + TLON A,10000 ; EXEC PC? + SUBI A,1 ; YES FIXUP PC +] + MOVEM A,LCKINT ;STORE ELSEWHERE + MOVEI A,DOINTE ;CAUSE DISMISS TO HANDLER + HRRM A,TSINTR ;STORE IN INT RETURN + PUSH P,INTFLG ;SAVE INT FLAG + SETOM INTFLG ;AND DISABLE + + +INTDON: MOVE A,TSAVA ;RESTORE ACS + MOVE B,TSAVB +IFN ITS, .DISMISS TSINTR ;AND DISMISS THE INTERRUPT +IFE ITS, DEBRK + + +DO.NOW: SKIPE GCFLG + JRST DLOSER ; HANDLE FATAL GC ERRORS + MOVSI B,1 + SKIPGE INTFLG ; IF NOT ENABLED + MOVEM B,INTFLG ; PRETEND IT IS + JRST 2NDWORD + +IFE ITS,[ + +; HERE FOR TENEX PDL OVER FLOW INTERRUPT + +TNXPDL: SOSGE INTFLG + SETOM INTFLG + MOVEM A,TSAVA + MOVEM B,TSAVB + JRST IPDLOV ; GO TO COMMON HANDLER + +; HERE FOR TENEX ^G AND ^S INTERRUPTS + +CNTLG: MOVEM A,TSAVA + MOVEI A,1 + JRST CNTSG + +CNTLS: MOVEM A,TSAVA + MOVEI A,2 + +CNTSG: MOVEM B,TSAVB + IORM A,PIRQ2 ; SAY FOR MUDDLE LEVEL + SOSGE INTFLG + SETOM INTFLG + JRST GCQUIT +INTNET: +REPEAT NNETS,[ + MOVEM A,TSAVA + MOVE A,[1_<.RPCNT+NETCHN>] + JRST CNTSG +] +] + +; HERE TO PROCESS INTERRUPTS + +DOINT: SKIPE INTHLD ; GLOBAL LOCK ON INTS + JRST @LCKINT + SETOM INTHLD ; DONT LET IT HAPPEN AGAIN + PUSH P,INTFLG +DOINTE: SKIPE ONINT ; ANY FUDGE? + XCT ONINT ; YEAH, TRY ONE + EXCH 0,LCKINT ; RELATIVIZE PC IF FROM RSUBR + PUSH P,0 ; AND SAVE + ANDI 0,-1 + CAMG 0,PURTOP + CAMGE 0,VECBOT + JRST DONREL + SUBI 0,(M) ; M IS BASE REG + HLL 0,(P) ; GET FLAGS + TLO 0,M ; INDEX IT OFF M + EXCH 0,(P) ; AND RESTORE TO STACK +DONREL: EXCH 0,LCKINT ; GET BACK SAVED 0 + SETZM INTFLG ;DISABLE + AOS -1(P) ;INCR SAVED FLAG + +;NOW SAVE WORKING ACS + + PUSHJ P,SAVACS + HLRZ A,-1(P) ; HACK FUNNYNESS FOR MPV/ILOPR + SKIPE A + SETZM -1(P) ; REALLY DISABLED + +DIRQ: MOVE A,PIRQ ;NOW SATRT PROCESSING + JFFO A,FIRQ ;COUNT BITS AND GO + MOVE A,PIRQ2 ;1ST DONE, LOOK AT 2ND + JFFO A,FIRQ2 + +INTDN1: SKIPN GCHAPN ; SKIP IF MUST DO GC INT + JRST .+3 + SETZM GCHAPN + PUSHJ P,INTOGC ; AND INTERRUPT + + PUSHJ P,RESTAC + +IFN ITS,[ + .SUSET [.SPICLR,,[0]] ; DISABLE INTS +] + POP P,LCKINT + POP P,INTFLG + SETZM INTHLD ; RE-ENABLE THE WORLD +IFN ITS,[ + EXCH 0,LCKINT + HRRI 0,@0 ; EFFECTIVIZE THE ADDRESS + TLZ 0,37 ; KILL IND AND INDEX + EXCH 0,LCKINT + .DISMIS LCKINT +] +IFE ITS, JRST @LCKINT +FIRQ: PUSHJ P,GETBIT ;SET UP THE BIT TO CLOBBER IN PIRQ + ANDCAM A,PIRQ ;CLOBBER IT + ADDI B,36. ;OFSET INTO TABLE + JRST XIRQ ;GO EXECUTE + +FIRQ2: PUSHJ P,GETBIT ;PREPARE TO CLOBBER BIT + ANDCAM A,PIRQ2 ;CLOBBER IT + ADDI B,71. ;AGAIN OFFSET INTO TABLE +XIRQ: + CAIE B,21 ;PDL OVERFLOW? + JRST FHAND ;YES, HACK APPROPRIATELY + +PDL2: SKIPN A,PGROW + SKIPE A,TPGROW + JRST .+2 + JRST DIRQ ; NOTHING GROWING, FALSE ALARM + MOVEI B,PDLGRO_-6 ;GET GROWTH SPEC + DPB B,[111100,,-1(A)] ;STORE GROWTH SPEC +REAGC: MOVE C,[10.,,1] ; INDICATOR FOR AGC + SKIPE PGROW ; P IS GROWING + ADDI C,6 + SKIPE TPGROW ; TP IS GROWING + ADDI C,1 + PUSHJ P,AGC ;COLLECT GARBAGE + SETZM PGROW + SETZM TPGROW + AOJL A,REAGC ; IF NO CORE, RETRY + JRST DIRQ + +SAVACS: +IRP A,,[0,A,B,C,D,E] + PUSH TP,A!STO(PVP) + SETZM A!STO(PVP) ;NOW ZERO TYPE + PUSH TP,A + TERMIN + POPJ P, + +RESTAC: +IRP A,,[E,D,C,B,A,0] + POP TP,A + POP TP,A!STO(PVP) + TERMIN + POPJ P, + +; HERE TO DO GC INTERRUPT AND CLOSE ANY DEAD CHANNELS + +INTOGC: PUSH P,[N.CHNS-1] + MOVE A,TVP + ADD A,[CHNL1,,CHNL1] + PUSH TP,$TVEC + PUSH TP,A + +INTGC1: MOVE A,(TP) ; GET POINTER + SKIPN B,1(A) ; ANY CHANNEL? + JRST INTGC2 + HRRE 0,(A) ; INDICATOR + JUMPGE 0,INTGC2 + PUSH TP,$TCHAN + PUSH TP,B + MCALL 1,FCLOSE + + MOVE A,(TP) + +INTGC2: HLLZS (A) + ADD A,[2,,2] + MOVEM A,(TP) + SOSE (P) + JRST INTGC1 + + SUB P,[1,,1] + SUB TP,[2,,2] + PUSH TP,$TCHSTR + PUSH TP,CHQUOTE GC + PUSH TP,$TFLOAT ; PUSH ON TIME ARGUMENT + PUSH TP,GCTIM + PUSH TP,$TFIX ; PUSH ON THE CAUSE ARGUMENT + PUSH TP,GCCAUS + PUSH TP,$TATOM ; PUSH ON THE CALL ARGUMENT + MOVE A,GCCALL + PUSH TP,@GCALLR(A) + MCALL 4,INTERR + POPJ P, + + +GCALLR: 0 + MQUOTE BLOAT + MQUOTE GROW + MQUOTE LIST + MQUOTE VECTOR + MQUOTE SET + MQUOTE SETG + MQUOTE FREEZE + MQUOTE PURE-PAGE-LOADER + MQUOTE GC + MQUOTE INTERRUPT-HANDLER + MQUOTE NEWTYPE + + ; OLD "ON" SETS UP EVENT AND HANDLER + +MFUNCTION ON,SUBR + + ENTRY + + HLRE 0,AB ; 0=> -2*NUM OF ARGS + ASH 0,-1 ; TO -NUM + CAME 0,[-5] + JRST .+3 + MOVEI B,10(AB) ; LAST MUST BE CHAN OR LOC + PUSHJ P,CHNORL + ADDI 0,3 + JUMPG 0,TFA ; AT LEAST 3 + MOVEI A,0 ; SET UP IN CASE NO PROC + AOJG 0,ONPROC ; JUMP IF NONE + GETYP C,6(AB) ; CHECK IT + CAIE C,TPVP + JRST TRYFIX + MOVE A,7(AB) ; GET IT +ONPROC: PUSH P,A ; SAVE AS A FLAG + GETYP A,(AB) ; CHECK PREV EXISTANCE + PUSH P,0 + CAIN A,TATOM + JRST .+3 + CAIE A,TCHSTR + JRST WTYP1 + MOVEI B,(AB) ; FIND IT + PUSHJ P,FNDINT + POP P,0 ; REST NUM OF ARGS + JUMPN B,ON3 ; ALREADY THERE + SKIPE C ; SKIP IF NOTHING TO FLUSH + SUB TP,[2,,2] + PUSH TP,(AB) ; GET NAME + PUSH TP,1(AB) + PUSH TP,4(AB) + PUSH TP,5(AB) + MOVEI A,2 ; # OF ARGS TO EVENT + AOJG 0,ON1 ; JUMP IF NO LAST ARG + PUSH TP,10(AB) + PUSH TP,11(AB) + ADDI A,1 +ON1: ACALL A,EVENT + +ON3: PUSH TP,A + PUSH TP,B + PUSH TP,2(AB) ; NOW FCN + PUSH TP,3(AB) + MOVEI A,3 ; NUM OF ARGS + SKIPN (P) + SOJA A,ON2 ; NO PROC + PUSH TP,$TPVP + PUSH TP,7(AB) +ON2: ACALL A,HANDLER + JRST FINIS + + +TRYFIX: SKIPN A,7(AB) + CAIE C,TFIX + JRST WRONGT + JRST ONPROC + +; ROUTINE TO BUILD AN EVENT + +MFUNCTION EVENT,SUBR + + ENTRY + + HLRZ 0,AB + CAIN 0,-2 ; IF JUST 1 + JRST RE.EVN ; COULD BE EVENT + CAIL 0,-3 ; MUST BE AT LEAST 2 ARGS + JRST TFA + GETYP A,2(AB) ; 2ND ARG MUST BE FIXED POINT PRIORITY + CAIE A,TFIX + JRST WTYP2 + GETYP A,(AB) ; FIRST ARG SHOULD BE CHSTR + CAIN A,TATOM ; ALLOW ACTUAL ATOM + JRST .+3 + CAIE A,TCHSTR + JRST WTYP1 + CAIL 0,-5 + JRST GOTRGS + CAIG 0,-7 + JRST TMA + MOVEI B,4(AB) + PUSHJ P,CHNORL ; CHANNEL OR LOCATIVE (PUT ON STACK) + +GOTRGS: MOVEI B,(AB) ; NOW TRY TO FIND HEADER FOR THIS INTERRUPT + PUSHJ P,FNDINT ; CALL INTERNAL HACKER + JUMPN B,FINIS ; ALREADY ONE OF THIS NAME + PUSH P,C + JUMPE C,.+3 ; GET IT OFF STACK + POP TP,B + POP TP,A + PUSHJ P,MAKINT ; MAKE ONE FOR ME + MOVSI 0,TFIX + MOVEM 0,INTPRI(B) ; SET UP PRIORITY + MOVE 0,3(AB) + MOVEM 0,INTPRI+1(B) +CH.SPC: POP P,C ; GET CODE BACK + SKIPGE C + PUSHJ P,DO.SPC ; DO ANY SPECIAL HACKS + JRST FINIS + +RE.EVN: GETYP 0,(AB) + CAIE 0,TINTH + JRST TFA ; ELSE SAY NOT ENOUGH + MOVE B,1(AB) ; GET IT + SETZM ISTATE+1(B) ; MAKE SURE ENABLED + SETZB D,C + GETYP A,INAME(B) ; CHECK FOR CHANNEL + CAIN A,TCHAN ; SKIP IF NOT + HRROI C,SS.CHA ; SET UP CHANNEL HACK + HRLZ E,INTPRI(B) ; GET POSSIBLE READ/WRITE BITS + TLNE E,.WRMON+.RDMON ; SKIP IF NOT MONITORS + PUSHJ P,GETNM1 + JUMPL C,RE.EV1 + MOVE B,INAME+1(B) ; CHECK FOR SPEC + PUSHJ P,SPEC1 + MOVE B,1(AB) ; RESTORE IHEADER +RE.EV1: PUSH TP,INAME(B) + PUSH TP,INAME+1(B) + PUSH P,C + MOVSI C,TATOM + PUSH TP,$TATOM + SKIPN D + MOVE D,MQUOTE INTERRUPT + PUSH TP,D + MOVE A,INAME(B) + MOVE B,INAME+1(B) ; GET IT + PUSHJ P,IGET ; LOOK FOR IT + JUMPN B,FINIS ; RETURN IT + MOVE A,(TB) + MOVE B,1(TB) + POP TP,D + POP TP,C + PUSH TP,(AB) + PUSH TP,1(AB) + PUSHJ P,IPUT ; REESTABLISH IT + MOVE A,(AB) + MOVE B,1(AB) + JRST CH.SPC + + +; FUNCTION TO GENERATE A HANDLER FOR A GIVEN INTERRUPT + +MFUNCTION HANDLER,SUBR + + ENTRY + + HLRZ 0,AB + CAIL 0,-2 ; MUST BE 2 OR MORE ARGS + JRST TFA + GETYP A,(AB) + CAIE A,TINTH ; EVENT? + JRST WTYP1 + GETYP A,2(AB) + CAIN 0,-4 ; IF EXACTLY 2 + CAIE A,THAND ; COULD BE HANDLER + JRST CHEVNT + + MOVE B,3(AB) ; GET IT + SKIPN IPREV+1(B) ; SKIP IF ALREADY IN USE + JRST HNDOK + MOVE D,1(AB) ; GET EVENT + SKIPN D,IHNDLR+1(D) ; GET FIRST HANDLER + JRST BADHND + CAMN D,B ; IS THIS IT? + JRST HFINIS ; YES, ALREADY "HANDLED" + MOVE D,INXT+1(D) ; GO TO NEXT HANDLER + JUMPN D,.-3 +BADHND: PUSH TP,$TATOM + PUSH TP,EQUOTE HANDLER-ALREADY-IN-USE + JRST CALER1 + +CHEVNT: CAIG 0,-7 ; SKIP IF LESS THAN 4 + JRST TMA + PUSH TP,$TPVP ; SLOT FOR PROCESS + PUSH TP,[0] + CAIE 0,-6 ; IF 3, LOOK FOR PROC + JRST NOPROC + GETYP 0,4(AB) + CAIE 0,TPVP + JRST WTYP3 + MOVE 0,5(AB) + MOVEM 0,(TP) + +NOPROC: PUSHJ P,APLQ + JRST NAPT + PUSHJ P,MHAND ; MAKE THE HANDLER + MOVE 0,1(TB) ; GET PROCESS + MOVEM 0,INTPRO+1(B) ; AND PUT IT INTO HANDLER + MOVSI 0,TPVP ; SET UP TYPE + MOVEM 0,INTPRO(B) + MOVE 0,2(AB) ; SET UP FUNCTION + MOVEM 0,INTFCN(B) + MOVE 0,3(AB) + MOVEM 0,INTFCN+1(B) + +HNDOK: MOVE D,1(AB) ; PICK UP EVEENT + MOVE E,IHNDLR+1(D) ; GET POINTER TO HANDLERS + MOVEM B,IHNDLR+1(D) ; PUT NEW ONE IN + MOVSI 0,TINTH ; GET INT HDR TYPE + MOVEM 0,IPREV(B) ; INTO BACK POINTER + MOVEM D,IPREV+1(B) ; AND POINTER ITSELF + MOVEM E,INXT+1(B) ; NOW NEXT POINTER + MOVSI 0,THAND ; NOW HANDLER TYPE + MOVEM 0,IHNDLR(D) ; SET TYPE IN HEADER + MOVEM 0,INXT(B) + JUMPE E,HFINIS ; JUMP IF HEADER WAS EMPTY + MOVEM 0,IPREV(E) ; FIX UP ITS PREV + MOVEM B,IPREV+1(E) +HFINIS: MOVSI A,THAND + JRST FINIS + + + +; FUNCTIONS TO SET TIME LIMITS FOR REALTIME AND RUNTIME INTS + +MFUNCTION RUNTIMER,SUBR + + ENTRY 1 + + GETYP 0,(AB) + JFCL 10,.+1 + MOVE A,1(AB) + CAIE 0,TFIX + JRST RUNT1 + IMUL A,[245761.] + JRST RUNT2 + +RUNT1: CAIE 0,TFLOAT + JRST WTYP1 + FMPR A,[245760.62] + MULI A,400 ; FIX IT + TSC A,A + ASH B,(A)-243 + MOVE A,B +RUNT2: JUMPL A,OUTRNG ; NOT FOR NEG # + JFCL 10,OUTRNG + .SUSET [.SRTMR,,A] + MOVE A,(AB) + MOVE B,1(AB) + JRST FINIS + +MFUNCTION REALTIMER,SUBR + + ENTRY 1 + + JFCL 10,.+1 + GETYP 0,(AB) + MOVE A,1(AB) + CAIE 0,TFIX + JRST REALT1 + IMULI A,60. ; TO 60THS OF SEC + JRST REALT2 + +REALT1: CAIE 0,TFLOAT + JRST WTYP1 + FMPRI A,(60.0) + MULI A,400 + TSC A,A + ASH B,(A)-243 + MOVE A,B + +REALT2: JUMPL A,OUTRNG + JFCL 10,OUTRNG + MOVE B,[200000,,A] + .REALT B, + JFCL + MOVE A,(AB) + MOVE B,1(AB) + JRST FINIS + +; FUNCTIONS TO ENABLE AND DISABLE INTERRUPTS + +MFUNCTION %ENABL,SUBR,ENABLE + + PUSHJ P,GTEVNT + SETZM ISTATE+1(B) + JRST FINIS + +MFUNCTION %DISABL,SUBR,DISABLE + + + PUSHJ P,GTEVNT + SETOM ISTATE+1(B) + JRST FINIS + +GTEVNT: ENTRY 1 + GETYP 0,(AB) + CAIE 0,TINTH + JRST WTYP1 + MOVE A,(AB) + MOVE B,1(AB) + POPJ P, + +DO.SPC: HRRZ C,INTBL(C) ; POINT TO SPECIAL CODE + HLRZ 0,AB ; - TWO TIMES NUM ARGS + PUSHJ P,(C) ; CALL ROUTINE + JUMPE E,CPOPJ ; NO BITS TO ENABLE, LEAVE +IFE ITS,[ + PUSH TP,A + PUSH TP,B + MOVE B,1(TB) ; CHANNEL + MOVE 0,CHANNO(B) + MOVEM 0,(E) ; SAVE IN TABLE + MOVEI E,(E) + SUBI E,NETJFN-NETCHN + MOVE A,0 ; SETUP FOR MTOPR + MOVEI B,24 + MOVSI C,(E) + TLO C,770000 ; DONT SETUP INR/INS + MTOPR + MOVEI 0,1 + MOVNS E + LSH 0,35.(E) + IORM 0,MASK1 + MOVE B,MASK1 + MOVEI A,MFORK + AIC + + POP TP,B + POP TP,A + POPJ P, ; ***** TEMP ****** +] +IFN ITS,[ + CAILE E,35. ; SKIP IF 1ST WORD BIT + JRST SETW2 + LSH 0,-1(E) + + IORM 0,MASK1 ; STORE IN PROTOTYPE MASK + .SUSET [.SMASK,,MASK1] + POPJ P, + +SETW2: LSH 0,-36.(E) + IORM 0,MASK2 ; SET UP PROTO MASK2 + .SUSET [.SMSK2,,MASK2] + POPJ P, +] + +; ROUTINE TO CHECK FOR CHANNEL OR LOCATIVE + +CHNORL: GETYP A,(B) ; GET TYPE + CAIN A,TCHAN ; IF CHANNEL + JRST CHNWIN + PUSH P,0 + PUSHJ P,LOCQ ; ELSE LOOCATIVE + JRST WRONGT + POP P,0 +CHNWIN: PUSH TP,(B) + PUSH TP,1(B) + POPJ P, + +; SUBROUTINE TO FIND A HANDLER OF A GIVEN NAME + +FNDINT: PUSHJ P,FNDNM + JUMPE B,CPOPJ + PUSHJ P,SPEC1 ; COULD BE FUNNY + +INTASO: PUSH P,C ; C<0 IF SPECIAL + PUSH TP,A + PUSH TP,B + MOVSI C,TATOM + SKIPN D ; COULD BE CHANGED FOR MONITOR + MOVE D,MQUOTE INTERRUPT + PUSH TP,C + PUSH TP,D + PUSHJ P,IGET + MOVE D,(TP) + SUB TP,[2,,2] + POP P,C ; AND RESTOR SPECIAL INDICATOR + SKIPE B ; IF FOUND + SUB TP,[2,,2] ; REMOVE CRUFT +CPOPJ: POPJ P, ; AND RETURN + +; CHECK FOR SPECIAL INTERNAL INTERRUPT HACK + +SPEC1: MOVSI C,-SPECLN ; BUILD AOBJN PNTR +SPCLOP: CAME B,@SPECIN(C) ; SKIP IF SPECIAL + AOBJN C,.-1 ; UNTIL EXHAUSTED + JUMPGE C,.+3 + SKIPE E,FNDTBL(C) + JRST (E) + MOVEI 0,-1(TB) ; SEE IF OK + CAIE 0,(TP) + JRST TMA + POPJ P, + +; ROUTINE TO CREATE A NEW INTERRUPT (INTERNAL ONLY--NOT ITS FLAVOR) + +MAKINT: JUMPN C,GOTATM ; ALREADY HAVE NAME, GET THING + MOVEI B,(AB) ; POINT TO STRING + PUSHJ P,CSTAK ; CHARS TO STAKC + MOVE B,INTOBL+1(TVP) + PUSHJ P,INSRTX + MOVE D,MQUOTE INTERRUPT +GOTATM: PUSH TP,$TINTH ; MAKE SLOT FOR HEADER BLOCK + PUSH TP,[0] + PUSH TP,A + PUSH TP,B ; SAVE ATOM + PUSH TP,$TATOM + PUSH TP,D + MOVEI A,IHDRLN*2 + PUSHJ P,GIBLOK + MOVE A,-3(TP) ; GET NAME AND STORE SAME + MOVEM A,INAME(B) + MOVE A,-2(TP) + MOVEM A,INAME+1(B) + SETZM ISTATE+1(B) + MOVEM B,-4(TP) ; STASH HEADER + POP TP,D + POP TP,C + EXCH B,(TP) + MOVSI A,TINTH + EXCH A,-1(TP) ; INTERNAL PUT CALL + PUSHJ P,IPUT + POP TP,B + POP TP,A + POPJ P, + +; FIND NAME OF INTERRUPT + +FNDNM: GETYP A,(B) ; TYPE + CAIE A,TCHSTR ; IF STRING + JRST FNDATM ; DONT HAVE ATOM, OTHERWISE DO + PUSHJ P,IILOOK + JRST .+2 +FNDATM: MOVE B,1(B) + SETZB C,D ; PREVENT LOSSAGE LATER + MOVSI A,TATOM + +; THE NEXT 2 INSTRUCTIONS ARE A KLUDGE TO GET THE RIGHT ERROR ATOM + + CAMN B,IMQUOTE ERROR + MOVE B,MQUOTE ERROR,ERROR,INTRUP + POPJ P, + +IILOOK: PUSHJ P,CSTAK ; PUT CHRS ON STACK + MOVE B,INTOBL+1(TVP) + JRST ILOOKC ; LOOK IT UP + +; ROUTINE TO MAKE A HANDLER BLOCK + +MHAND: MOVEI A,IHANDL*2 + JRST GIBLOK ; GET BLOCK + +; HERE TO GET CHANNEL FOR "CHAR" INTERRUPT + +GETCHN: GETYP 0,(TB) ; GET TYPE + CAIE 0,TCHAN ; CHANNL IS WINNER + JRST WRONGT + MOVE A,(TB) ; USE THE CHANNEL TO NAME THE INTERRUPT + MOVE B,1(TB) + SKIPN CHANNO(B) ; SKIP IF WINNING CHANNEL + JRST CBDCHN ; LOSER + POPJ P, + +LOCGET: GETYP 0,(TB) ; TYPE + CAIN 0,TCHAN ; SKIP IF LOCATIVE + JRST WRONGT + MOVE D,B + MOVE A,(TB) + MOVE B,1(TB) ; GET LOCATIVE + POPJ P, + +; FINAL MONITOR SETUP ROUTINES + +S.RMON: SKIPA E,[.RDMON,,] +S.WMON: MOVSI E,.WRMON + PUSH TP,A + PUSH TP,B + HLRM E,INTPRI(B) ; SAVE BITS + MOVEI B,(TB) ; POINT TO LOCATIVE + HRRZ A,FSAV(TB) + CAIN A,OFF + MOVSI D,(ANDCAM E,) ; KILL INST + CAIN A,EVENT + MOVSI D,(IORM E,) + PUSHJ P,SMON ; GO DO IT + POP TP,B + POP TP,A + MOVEI E,0 + POPJ P, + + +; SPECIAL SETUP ROUTINES FOR INITIAL INTERRUPTS + +IFN ITS,[ +S.CHAR: MOVE E,1(TB) ; GET CHANNEL + MOVE E,CHANNO(E) + ADDI E,36. ; GET CORRECT MASK BIT +ONEBIT: MOVEI 0,1 ; BIT FOR INT TO RET + POPJ P, +] +IFE ITS,[ +S.CHAR: MOVE E,1(TB) + MOVE 0,RDEVIC(E) + ILDB 0,0 ; 1ST CHAR + PUSH P,A + CAIE 0,"N ; NET ? + JRST S.CHA1 + + MOVEI A,0 + HRRZ 0,CHANNO(E) + MOVE E,[-NNETS,,NETJFN] + CAMN 0,(E) + JRST S.CHA2 + SKIPN (E) + MOVE A,E ; REMEMBER WHERE + AOBJN E,.-5 + TLNN A,-1 + FATAL NO MORE NETWORK + MOVE E,A +S.CHA1: MOVEI E,0 +S.CHA2: POP P,A + POPJ P, +] + + +; SPECIAL FOR CLOCK + +S.DOWN: SKIPA E,[7] +S.CLOK: MOVEI E,13. ; FOR NOW JUST GET BIT # + JRST ONEBIT + +S.PAR: MOVEI E,28. + JRST ONEBIT + +; RUNTIME AND REALTIME INTERRUPTS + +S.RUNT: SKIPA E,[34.] +S.REAL: MOVEI E,35. + JRST ONEBIT + +S.IOC: SKIPA E,[9.] ; IO CHANNEL ERROR +S.PURE: MOVEI E,26. + JRST ONEBIT + +; MPV AND ILOPR + +S.MPV: SKIPA E,[14.] ; BIT POS +S.ILOP: MOVEI E,6 + JRST ONEBIT + +; HERE TO TURN ALL INFERIOR INTS + +S.INF: MOVEI E,36.+16.+2 ; START OF BITS + MOVEI 0,37 ; 8 BITS WORTH + POPJ P, + + +; HERE TO HANDLE ITS INTERRUPTS + +FHAND: SKIPN D,EXTINT(B) ; SKIP IF HANDLERS ARE POSSIBLE + JRST DIRQ + JRST (D) + +IFN ITS,[ +; SPECIAL CHARACTER HANDLERS + +HCHAR: MOVEI D,CHNL0+1(TVP) + ADDI D,(B) ; POINT TO CHANNEL SLOT + ADDI D,(B) + SKIPN D,-72.(D) ; PICK UP CHANNEL + JRST IPCGOT ;WELL, IT GOTTA BEE THE THE IPC THEN + PUSH TP,$TCHAN + PUSH TP,D + LDB 0,[600,,STATUS(D)] ; GET DEVICE CODE + CAILE 0,2 ; SKIP IF A TTY + JRST HNET ; MAYBE NETWORK CHANNEL + CAMN D,TTICHN+1(TVP) + SKIPN NOTTY + JRST HCHR11 + MOVE B,D ; CHAN TO B + PUSHJ P,TTYOP2 ; RE-GOBBLE TTY + MOVE D,(TP) +HCHR11: MOVE D,CHANNO(D) ; GET ITS CHANNEL + PUSH P,D ; AND SAVE IT + .CALL HOWMNY ; GET # OF CHARS + MOVEI B,0 ; IF TTY GONE, NO CHARS +RECHR: ADDI B,1 ; BUMP BY ONE FOR SOSG + MOVEM B,CHNCNT(D) ; AND SAVE + IORM A,PIRQ2 ; LEAVE THE INT ON + +CHRLOO: MOVE D,(P) ; GET CHNNAEL NO. + SOSG CHNCNT(D) ; GET COUNT + JRST CHRDON + + MOVE B,(TP) + MOVE D,BUFRIN(B) ; GET EXTRA BUFFER + XCT IOIN2(D) ; READ CHAR + PUSH TP,$TCHSTR + PUSH TP,CHQUOTE CHAR + PUSH TP,$TCHRS ; SAVE CHAR FOR CALL + PUSH TP,A + PUSH TP,$TCHAN ; SAVE CHANNEL + PUSH TP,B + PUSHJ P,INCHAR ; PUT CHAR IN USERS BUFFER + MCALL 3,INTERRUPT ; RUN THE HANDLERS + JRST CHRLOO ; AND LOOP + +CHRDON: .CALL HOWMNY + MOVEI B,0 + MOVEI A,1 ; SET FOR PI WORD CLOBBER + LSH A,(D) + JUMPG B,RECHR ; ANY MORE? + ANDCAM A,PIRQ2 + SUB P,[1,,1] + SUB TP,[2,,2] + JRST DIRQ + + + +; HERE FOR NET CHANNEL INTERRUPT + +HNET: CAIE 0,26 ; NETWORK? + JRST HSTYET ; HANDLE PSEUDO TTY ETC. + PUSH TP,$TATOM + PUSH TP,MQUOTE CHAR,CHAR,INTRUP + PUSH TP,$TUVEC + PUSH TP,BUFRIN(D) + PUSH TP,$TCHAN + PUSH TP,D + MOVE B,D ; CHAN TO B + PUSHJ P,INSTAT ; UPDATE THE NETWRK STATE + MCALL 3,INTERRUPT + SUB TP,[2,,2] + JRST DIRQ + +HSTYET: PUSH TP,$TATOM + PUSH TP,MQUOTE CHAR,CHAR,INTRUP + PUSH TP,$TCHAN + PUSH TP,D + MCALL 2,INTERRUPT + SUB TP,[2,,2] + JRST DIRQ + +] +CBDCHN: PUSH TP,$TATOM + PUSH TP,EQUOTE BAD-CHANNEL + JRST CALER1 + +IFN ITS,[ + +HCLOCK: PUSH TP,$TCHSTR + PUSH TP,CHQUOTE CLOCK + MCALL 1,INTERRUPT + JRST DIRQ + +HRUNT: PUSH TP,$TATOM + PUSH TP,MQUOTE RUNT,RUNT,INTRUP + MCALL 1,INTERRUPT + JRST DIRQ + +HREAL: PUSH TP,$TATOM + PUSH TP,MQUOTE REALT,REALT,INTRUP + MCALL 1,INTERRUPT + JRST DIRQ + +HPAR: MOVE A,MQUOTE PARITY,PARITY,INTRUP + JRST HMPV1 + +HMPV: MOVE A,MQUOTE MPV,MPV,INTRUP + JRST HMPV1 + +HILOPR: MOVE A,MQUOTE ILOPR,ILOPR,INTRUP + JRST HMPV1 + +HPURE: MOVE A,MQUOTE PURE,PURE,INTRUP +HMPV1: PUSH TP,$TATOM + PUSH TP,A + PUSH P,LCKINT ; SAVE LOCN + PUSH TP,$TATOM + PUSH TP,A + PUSH TP,$TWORD + PUSH TP,LCKINT + MCALL 2,EMERGENCY + POP P,A + MOVE C,(TP) + SUB TP,[2,,2] + JUMPN B,DIRQ + + PUSH TP,$TATOM + PUSH TP,EQUOTE DANGEROUS-INTERRUPT-NOT-HANDLED + PUSH TP,$TATOM + PUSH TP,C + PUSH TP,$TWORD + PUSH TP,A + MCALL 3,ERROR + JRST DIRQ + + + +; HERE TO HANDLE SYS DOWN INTERRUPT + +HDOWN: PUSH TP,$TATOM + PUSH TP,MQUOTE SYSDOWN,SYSDOWN,INTRUP + .DIETI A, ; HOW LONG? + PUSH TP,$TFIX + PUSH TP,A + PUSH P,A ; FOR MESSAGE + MCALL 2,INTERRUPT + POP P,A + JUMPN B,DIRQ + .SUSET [.RTTY,,B] ; DO WE NOW HAVE A TTY AT ALL? + JUMPL B,DIRQ ; DONT HANG AROUND + PUSH P,A + MOVEI B,[ASCIZ / +Excuse me, SYSTEM going down in /] + SKIPG (P) ; SKIP IF REALLY GOING DOWN + MOVEI B,[ASCIZ / +Excuse me, SYSTEM has been REVIVED! +/] + PUSHJ P,MSGTYP + POP P,B + JUMPE B,DIRQ + IDIVI B,30. ; TO SECONDS + IDIVI B,60. ; A/ SECONDS B/ MINUTES + JUMPE B,NOMIN + PUSH P,C + PUSHJ P,DECOUT + MOVEI B,[ASCIZ / minutes /] + PUSHJ P,MSGTYP + POP P,B + JRST .+2 +NOMIN: MOVEI B,(C) + PUSHJ P,DECOUT + MOVEI B,[ASCIZ / seconds. +/] + PUSHJ P,MSGTYP + JRST DIRQ + +; TWO DIGIT DEC OUT FROM B/ + +DECOUT: IDIVI B,10. + JUMPE B,DECOU1 ; NO TEN + MOVEI A,60(B) + PUSHJ P,MTYO +DECOU1: MOVEI A,60(C) + JRST MTYO + +; HERE TO HANDLE I/O CHANNEL ERRORS + +HIOC: .SUSET [.RAPRC,,A] ; CONTAINS CHANNEL OF MOST RECENT LOSSAGE + LDB A,[330400,,A] ; GET CHAN # + MOVEI C,(A) ; COPY + PUSH TP,$TATOM ; PUSH ERROR + PUSH TP,EQUOTE FILE-SYSTEM-ERROR + + PUSH TP,$TCHAN + ASH C,1 ; GET CHANNEL + ADDI C,CHNL0+1(TVP) ; GET CHANNEL VECTOR + PUSH TP,(C) + LSH A,23. ; DO A .STATUS + IOR A,[.STATUS A] + XCT A + PUSHJ P,GFALS ; GEN NAMED FALSE + PUSH TP,A + PUSH TP,B + PUSH TP,$TATOM + PUSH TP,MQUOTE IOC,IOC,INTRUP + + PUSH TP,A + PUSH TP,B + PUSH TP,-7(TP) + PUSH TP,-7(TP) + MCALL 3,EMERGENCY + JUMPN B,DIRQ1 ; JUMP IF HANDLED + MCALL 3,ERROR + JRST DIRQ + +DIRQ1: SUB TP,[6,,6] + JRST DIRQ + +; HANDLE INFERIOR KNOCKING AT THE DOOR + +HINF: SUBI B,36.+16.+2 ; CONVERT TO INF # + PUSH TP,$TATOM + PUSH TP,MQUOTE INFERIOR,INFERIOR,INTRUP + PUSH TP,$TFIX + PUSH TP,B + MCALL 2,INTERRUPT + JRST DIRQ +] +IFE ITS,[ + +; HERE FOR TENEX INTS (FIRST CUT) + +HCNTLG: MOVEI A,7 + JRST HCNGS + +HCNTLS: MOVEI A,23 + +HCNGS: PUSH TP,$TATOM + PUSH TP,MQUOTE CHAR,CHAR,INTRUP + PUSH TP,$TCHRS + PUSH TP,A + PUSH TP,$TCHAN + PUSH TP,TTICHN+1(TVP) + MCALL 3,INTERRUPT + JRST DIRQ + +HNET: MOVE A,NETJFN-NINT+NNETS(B) + JUMPE A,DIRQ + ASH A,1 + ADDI A,CHNL0+1(TVP) + MOVE B,(A) + PUSH TP,$TATOM + PUSH TP,MQUOTE CHAR,CHAR,INTRUP + PUSH TP,$TUVEC + PUSH TP,BUFRIN(B) + PUSH TP,$TCHAN + PUSH TP,B + PUSHJ P,INSTAT + MCALL 3,INTERRUPT + JRST DIRQ +] + + +MFUNCTION OFF,SUBR + ENTRY + + JUMPGE AB,TFA + HLRZ 0,AB + GETYP A,(AB) ; ARG TYPE + MOVE B,1(AB) ; AND VALUE + CAIN A,TINTH ; HEADER, GO HACK + JRST OFFHD ; QUEEN OF HEARTS + CAIN A,TATOM + JRST .+3 + CAIE A,TCHSTR + JRST TRYHAN ; MAYBE INDIVIDUAL HANDLER + CAIN 0,-2 ; MORE THAN 1 ARG? + JRST OFFAC1 ; NO, GO ON + CAIG 0,-5 ; CANT BE MORE THAN 2 + JRST TMA + MOVEI B,2(AB) ; POINT TO 2D + PUSHJ P,CHNORL +OFFAC1: MOVEI B,(AB) + PUSHJ P,FNDINT + JUMPGE B,NOHAN1 ; NOT HANDLED + +OFFH1: PUSH P,C ; SAVE C FOR BIT CLOBBER + MOVSI C,TATOM + SKIPN D + MOVE D,MQUOTE INTERRUPT + MOVE A,INAME(B) + MOVE B,INAME+1(B) + PUSHJ P,IREMAS + SKIPE B ; IF NO ASSOC, DONT SMASH + SETOM ISTATE+1(B) ; DISABLE IN CASE QUEUED + POP P,C ; SPECIAL? + JUMPGE C,FINIS ; NO, DONE + + HRRZ C,INTBL(C) ; POINT TO SPECIAL CODE + PUSHJ P,(C) ; GO TO SAME + JUMPE E,OFINIS ; DONE +IFN ITS,[ + CAILE E,35. ; SKIP IF 1ST WORD + JRST CLRW2 ; CLOBBER 2D WORD BIT + LSH 0,-1(E) ; POSITION BIT + ANDCAM 0,MASK1 ; KILL BIT + .SUSET [.SMASK,,MASK1] +] +IFE ITS,[ + MOVE D,B + SETZM (E) + MOVEI E,(E) + SUBI E,NETJFN-NETCHN + MOVEI 0,1 + MOVNS E + LSH 0,35.(E) + ANDCAM 0,MASK1 + MOVEI A,MFORK + SETCM B,MASK1 + DIC + ANDCAM 0,PIRQ ; JUST IN CASE + MOVE B,D +] +OFINIS: MOVSI A,TINTH + JRST FINIS + +IFN ITS,[ +CLRW2: LSH 0,-36.(E) ; POS BIT FOR 2D WORD + ANDCAM 0,MASK2 + .SUSET [.SMSK2,,MASK2] + JRST OFINIS +] + +TRYHAN: CAIE A,THAND ; HANDLER? + JRST WTYP1 + CAIE 0,-2 + JRST TMA + GETYP 0,IPREV(B) ; GET TYPE OF PREV + MOVE A,INXT+1(B) + MOVE C,IPREV+1(B) + MOVE D,IPREV(B) + CAIE 0,THAND + JRST DOHEAD ; PREV HUST BE HDR + MOVEM A,INXT+1(C) + JRST .+2 +DOHEAD: MOVEM A,IHNDLR+1(C) ; INTO HDR + JUMPE A,OFFINI + MOVEM D,IPREV(A) + MOVEM C,IPREV+1(A) +OFFINI: SETZM IPREV+1(B) + SETZM INXT+1(B) + MOVSI A,THAND + JRST FINIS + +OFFHD: CAIE 0,-2 + JRST TMA + PUSHJ P,GETNMS ; GET INFOR ABOUT INT + JUMPE C,OFFH1 + PUSH TP,INAME(B) + PUSH TP,INAME+1(B) + JRST OFFH1 + +GETNMS: GETYP A,INAME(B) ; CHECK FOR SPECIAL + SETZB C,D + CAIN A,TCHAN + HRROI C,SS.CHA + PUSHJ P,LOCQ ; LOCATIVE? + JRST CHGTNM + + MOVEI B,INAME(B) ; POINT TO LOCATIVE + MOVSI D,(MOVE E,) + PUSHJ P,SMON ; GET MONITOR + MOVE B,1(AB) +GETNM1: HRROI C,SS.WMO ; ASSUME WRITE + TLNN E,.WRMON + HRROI C,SS.RMO + MOVE D,MQUOTE WRITE,WRITE,INTRUP + TLNN E,.WRMON + MOVE D,MQUOTE READ,READ,INTRUP + POPJ P, + +CHGTNM: JUMPL C,CPOPJ + MOVE B,INAME+1(B) + PUSHJ P,SPEC1 + MOVE B,1(AB) ; RESTORE IHEADER + POPJ P, + +; EMERGENCY, CANT DEFER ME!! + +MQUOTE INTERRUPT + +EMERGENCY: + PUSH P,. + JRST INTERR+1 + +MFUNCTION INTERRUPT,SUBR + + PUSH P,[0] + + ENTRY + + SETZM INTHLD ; RE-ENABLE THE WORLD + JUMPGE AB,TFA + MOVE B,1(AB) ; GET HANDLER/NAME + GETYP A,(AB) ; CAN BE HEADER OR NAME + CAIN A,TINTH ; SKIP IF NOT HEADER + JRST GTHEAD + CAIN A,TATOM + JRST .+3 + CAIE A,TCHSTR ; SKIP IF CHAR STRING + JRST WTYP1 + MOVEI B,(AB) ; LOOK UP NAME + PUSHJ P,FNDNM ; GET NAME + JUMPE B,IFALSE + MOVEI D,0 + CAMN B,MQUOTE CHAR,CHAR,INTRUP + PUSHJ P,CHNGT1 + CAME B,MQUOTE READ,READ,INTRUP + CAMN B,MQUOTE WRITE,WRITE,INTRUP + PUSHJ P,GTLOC1 + PUSHJ P,INTASO + JUMPE B,IFALSE + +GTHEAD: SKIPE ISTATE+1(B) ; ENABLED? + JRST IFALSE ; IGNORE COMPLETELY + MOVE A,INTPRI+1(B) ; GET PRIORITY OF INTERRUPT + CAMLE A,CURPRI ; SEE IF MUST QUEU + JRST SETPRI ; MAY RUN NOW + SKIPE (P) ; SKIP IF DEFER OK + JRST DEFERR + MOVEM A,(P) + PUSH TP,$TINTH ; SAVE HEADER + PUSH TP,B + MOVEI A,1 ; SAVE OTHER ARGS +PSHARG: ADD AB,[2,,2] + JUMPGE AB,QUEU1 ; GO MAKE QUEU ENTRY + PUSH TP,(AB) + PUSH TP,1(AB) + AOJA A,PSHARG +QUEU1: PUSHJ P,IEVECT ; GET VECTOR + PUSH TP,$TVEC + PUSH TP,[0] ; WILL HOLD QUEUE HEADER + PUSH TP,A + PUSH TP,B + + POP P,A ; RESTORE PRIORITY + + MOVE B,QUEUES+1(TVP) ; GET INTERRUPT QUEUES + MOVEI D,0 + JUMPGE B,GQUEU ; MAKE A QUEUE HDR + +NXTQU: CAMN A,1(B) ; GOT PRIORITY? + JRST ADDQU ; YES, ADD TO THE QUEU + CAMG A,1(B) ; SKIP IF SPOT NOT FOUND + JRST GQUEU + MOVE D,B + MOVE B,3(B) ; GO TO NXT QUEUE + JUMPL B,NXTQU + +GQUEU: PUSH TP,$TVEC ; SAVE NEXT POINTER + PUSH TP,D + PUSH TP,$TFIX + PUSH TP,A ; SAVE PRIORITY + PUSH TP,$TVEC + PUSH TP,B + PUSH TP,$TLIST + PUSH TP,[0] + PUSH TP,$TLIST + PUSH TP,[0] + MOVEI A,4 + PUSHJ P,IEVECT + MOVE D,(TP) ; NOW SPLICE + SUB TP,[2,,2] + JUMPN D,GQUEU1 + MOVEM B,QUEUES+1(TVP) + JRST .+2 +GQUEU1: MOVEM B,3(D) + +ADDQU: MOVEM B,-2(TP) ; SAVE QUEU HDR + POP TP,D + POP TP,C + PUSHJ P,INCONS ; CONS IT + MOVE C,(TP) ;GET QUEUE HEADER + SKIPE D,7(C) ; IF END EXISTS + HRRM B,(D) ; SPLICE + MOVEM B,7(C) + SKIPN 5(C) ; SKIP IF START EXISTS + MOVEM B,5(C) + +IFINI: MOVSI A,TATOM + MOVE B,MQUOTE T + JRST FINIS + +SETPRI: EXCH A,CURPRI + MOVEM A,(P) + + PUSH TP,$TAB ; PASS AB TO HANDLERS + PUSH TP,AB + + PUSHJ P,RUNINT ; RUN THE HANDLERS + POP P,A ; UNQUEU ANY WAITERS + PUSHJ P,UNQUEU + + JRST IFINI + +; HERE TO UNQUEUE WAITING INTERRUPTS + +UNQUEU: PUSH P,A ; SAVE NEW LEVEL + +UNQUE1: MOVE A,(P) ; TARGET LEVEL + CAMLE A,CURPRI ; CHECK RUG NOT PULLED OUT + JRST UNDONE + SKIPE B,QUEUES+1(TVP) + CAML A,1(B) ; RIGHT LEVEL? + JRST UNDONE ; FINISHED + + SKIPN C,5(B) ; ON QUEUEU? + JRST UNXQ + HRRZ D,(C) ; CDR THE LIST + MOVEM D,5(B) + SKIPN D ; SKIP IF NOT LAST + SETZM 7(B) ; CLOBBER END POINTER + MOVE A,1(B) ; GET THIS PRIORITY LEVEL + MOVEM A,CURPRI ; MAKE IT THE CURRENT ONE + MOVE D,1(C) ; GET SAVED VECTOR OF INF + + MOVE B,1(D) ; INT HEADER + PUSH TP,$TVEC + PUSH TP,D ; AND ARGS + + PUSHJ P,RUNINT ; RUN THEM + JRST UNQUE1 + +UNDONE: POP P,CURPRI ; SET CURRENT LEVEL + MOVE A,CURPRI + POPJ P, + +UNXQ: MOVE B,3(B) ; GO TO NEXT QUEUE + MOVEM B,QUEUES+1(TVP) + JRST UNQUE1 + + + +; SUBR TO CHANGE INTERRUPT LEVEL + +MFUNCTION INTLEV,SUBR,[INT-LEVEL] + ENTRY + JUMPGE AB,RETLEV ; JUST RETURN CURRENT + GETYP A,(AB) + CAIE A,TFIX + JRST WTYP1 ; LEVEL IS FIXED + SKIPGE A,1(AB) + JRST OUTRNG" + CAMN A,CURPRI ; DIFFERENT? + JRST RETLEV ; NO RETURN + PUSH P,CURPRI + CAMG A,CURPRI ; SKIP IF NO UNQUEUE NEEDED + PUSHJ P,UNQUEU + MOVEM A,CURPRI ; SAVE + POP P,A + SKIPA B,A +RETLEV: MOVE B,CURPRI + MOVSI A,TFIX + JRST FINIS + +RUNINT: PUSH TP,$THAND ; SAVE HANDLERS LIST + PUSH TP,IHNDLR+1(B) + + SKIPN ISTATE+1(B) ; SKIP IF DISABLED + SKIPN B,(TP) + JRST SUBTP4 +NXHND: MOVEM B,(TP) ; SAVE CURRENT HDR + MOVE A,-2(TP) ; SAVE ARG POINTER + PUSHJ P,CHSWAP ; SEE IF MUST SWAP + PUSH TP,[0] + PUSH TP,[0] + MOVEI C,1 ; COUNT ARGS + PUSH TP,$TSP + PUSH TP,SP + MOVE D,PVP + ADD D,[1STEPR,,1STEPR] + PUSH TP,BNDV + PUSH TP,D + PUSH TP,$TPVP + PUSH TP,[0] + MOVE E,TP + PUSH TP,INTFCN(B) + PUSH TP,INTFCN+1(B) + ADD A,[2,,2] + JUMPGE A,DO.HND + PUSH TP,(A) + PUSH TP,1(A) + AOJA C,.-4 +DO.HND: PUSH P,C + PUSHJ P,SPECBE ; BIND 1 STEP FLAG + POP P,C + ACALL C,INTAPL + MOVE SP,-4(TP) + MOVE C,(TP) ; RESET 1 STEP + MOVEM C,1STEPR+1(PVP) + SUB TP,[6,,6] + PUSHJ P,CHUNSW + CAMN E,PVP + SUB TP,[4,,4] ; NO PROCESS CHANGE, POP JUNK + CAMN E,PVP + JRST .+4 + MOVE D,TPSTO+1(E) + SUB D,[4,,4] + MOVEM D,TPSTO+1(E) ; FIXUP HIS STACK +DO.H1: GETYP A,A ; CHECK FOR A DISMISS + CAIN A,TDISMI + JRST SUBTP4 + MOVE B,(TP) ; TRY FOR NEXT HANDLER + SKIPE B,INXT+1(B) + JRST NXHND +SUBTP4: SUB TP,[4,,4] + POPJ P, + +MFUNCTION INTAPL,SUBR,[RUNINT] + JRST APPLY + + +NOHAND: JUMPE C,NOHAN1 + PUSH TP,$TATOM + PUSH TP,EQUOTE INTERNAL-INTERRUPT +NOHAN1: PUSH TP,(AB) + PUSH TP,1(AB) + PUSH TP,$TATOM + PUSH TP,EQUOTE NOT-HANDLED + SKIPE A,C + MOVEI A,1 + ADDI A,2 + JRST CALER + +DEFERR: PUSH TP,$TATOM + PUSH TP,EQUOTE ATTEMPT-TO-DEFER-UNDEFERABLE-INTERRUPT + PUSH TP,$TINTH + PUSH TP,B + PUSH TP,$TATOM + PUSH TP,MQUOTE INTERRUPT + MCALL 3,RERR ; FORCE REAL ERROR + JRST FINIS + +; FUNCTION TO DISMISS AN INTERRUPT TO AN ARBITRARY ACTIVATION + +MFUNCTION DISMISS,SUBR + + HLRZ 0,AB + JUMPGE AB,TFA + CAIGE 0,-6 + JRST TMA + MOVNI D,1 + CAIE 0,-6 + JRST DISMI3 + GETYP 0,4(AB) + CAIE 0,TFIX + JRST WTYP + SKIPGE D,5(AB) + JRST OUTRNG + +DISMI3: MOVEI A,(TB) + +DISMI0: HRRZ B,FSAV(A) + HRRZ C,PCSAV(A) + CAIE B,INTAPL + JRST DISMI1 + + MOVE E,OTBSAV(A) + MOVEI 0,(A) ; SAVE FRAME + MOVEI A,DISMI2 + HRRM A,PCSAV(E) ; GET IT BACK HERE + MOVE A,(AB) + MOVE B,1(AB) + MOVE C,TPSAV(E) + MOVEM A,-7(C) + MOVEM B,-6(C) + MOVEI C,0 + CAMGE AB,[-3,,] + MOVEI C,2(AB) + MOVE B,0 ; DEST FRAME + JUMPL D,.+3 + MOVE A,PSAV(E) ; NOW MUNG SAVED INT LEVEL + MOVEM D,-1(A) ; ZAP YOUR MUNGED + PUSHJ P,CHUNW ; CHECK ON UNWINDERS + JRST FINIS ; FALL DOWN + +DISMI1: MOVEI E,(A) + HRRZ A,OTBSAV(A) + JUMPN A,DISMI0 + + MOVE A,(AB) + MOVE B,1(AB) + + PUSH TP,A + PUSH TP,B + SKIPGE A,D + JRST .+4 + CAMG A,CURPRI + PUSHJ P,UNQUEU + MOVEM A,CURPRI + CAML AB,[-3,,] + JRST .+5 + PUSH TP,2(AB) + PUSH TP,3(AB) + MCALL 2,ERRET + JRST FINIS + + POP TP,B + POP TP,A + JRST FINIS + +DISMI2: MOVE C,(TP) + MOVEM C,1STEPR+1(PVP) + MOVE SP,-4(TP) + SUB TP,[6,,6] + PUSHJ P,CHUNSW ; UNDO ANY PROCESS HACKING + MOVE C,TP + CAME E,PVP ; SWAPED? + MOVE C,TPSTO+1(E) + MOVE D,-1(C) + MOVE 0,(C) + SUB TP,[4,,4] + SUB C,[4,,4] ; MAYBE FIXUP OTHER STACK + CAME E,PVP + MOVEM C,TPSTO+1(E) + PUSH TP,D + PUSH TP,0 + PUSH TP,A + PUSH TP,B + MOVE A,-1(P) ; SAVED PRIORITY + CAMG A,CURPRI + PUSHJ P,UNQUEU + MOVEM A,CURPRI + SKIPN -1(TP) + JRST .+3 + MCALL 2,ERRET + JRST FINIS + + SUB TP,[4,,4] + MOVSI A,TDISMI + MOVE B,MQUOTE T + JRST DO.H1 + +CHNGT1: HLRE B,AB + SUBM AB,B + GETYP 0,-2(B) + CAIE 0,TCHAN + JRST WTYP3 + MOVE B,-1(B) + MOVSI A,TCHAN + POPJ P, + +GTLOC1: GETYP A,2(AB) + PUSHJ P,LOCQ + JRST WTYP2 + MOVE D,B ; RET ATOM FOR ASSOC + MOVE A,2(AB) + MOVE B,3(AB) + POPJ P, + ; MONITOR CHECKERS + +MONCH0: HLLZ 0,(B) ; POTENTIAL MONITORS +MONCH: TLZ 0,TYPMSK ; KILL TYPE + IOR C,0 ; IN NEW TYPE + PUSH P,0 + MOVEI 0,(B) + CAIL 0,HIBOT + JRST PURERR + POP P,0 + TLNN 0,.WRMON ; SKIP IF WRITE MONIT + POPJ P, + +; MONITOR IS ON, INVOKE HANDLER + + PUSH TP,A ; SAVE OBJ + PUSH TP,B + PUSH TP,C + PUSH TP,D ; SAVE DATUM + MOVSI C,TATOM ; PREPARE TO FIND IT + MOVE D,MQUOTE WRITE,WRITE,INTRUP + PUSHJ P,IGET + JUMPE B,MONCH1 ; NOT FOUND IGNORE FOR NOW + PUSH TP,A ; START SETTING UP CALL + PUSH TP,B + PUSH TP,-5(TP) + PUSH TP,-5(TP) + PUSH TP,-5(TP) + PUSH TP,-5(TP) + PUSHJ P,FRMSTK ; PUT FRAME ON STAKC + MCALL 4,EMERGE ; DO IT +MONCH1: POP TP,D + POP TP,C + POP TP,B + POP TP,A + HLLZ 0,(B) ; UPDATE MONITORS + TLZ 0,TYPMSK + IOR C,0 + POPJ P, + +; NOW FOR READ MONITORS + +RMONC0: HLLZ 0,(B) +RMONCH: TLNN 0,.RDMON + POPJ P, + PUSH TP,A + PUSH TP,B + MOVSI C,TATOM + MOVE D,MQUOTE READ,READ,INTRUP + PUSHJ P,IGET + JUMPE B,RMONC1 + PUSH TP,A + PUSH TP,B + PUSH TP,-3(TP) + PUSH TP,-3(TP) + PUSHJ P,FRMSTK ; PUT FRAME ON STACK + MCALL 3,EMERGE +RMONC1: POP TP,B + POP TP,A + POPJ P, + +; PUT THE CURRENT FRAME ON THE STACK + +FRMSTK: PUSHJ P,MAKACT + HRLI A,TFRAME + PUSH TP,A + PUSH TP,B + POPJ P, + +; HERE TO COMPLAIN ABOUT ATTEMPTS TO MUNG PURE CODE + +PURERR: PUSH TP,$TATOM + PUSH TP,EQUOTE ATTEMPT-TO-MUNG-PURE-STRUCTURE + PUSH TP,A + PUSH TP,B + MOVEI A,2 + JRST CALER + +; PROCESS SWAPPING CODE + +CHSWAP: MOVE E,PVP ; GET CURRENT + POP P,0 + SKIPE D,INTPRO+1(B) ; SKIP IF NO PROCESS GIVEN + CAMN D,PVP ; SKIP IF DIFFERENT + JRST PSHPRO + + PUSHJ P,SWAPIT ; DO SWAP + +PSHPRO: PUSH TP,$TPVP + PUSH TP,E + JRST @0 + +CHUNSW: MOVE E,PVP ; RET OLD PROC + MOVE D,-2(TP) ; GET SAVED PROC + CAMN D,PVP ; SWAPPED? + POPJ P, + +SWAPIT: PUSH P,0 + MOVE 0,PSTAT+1(D) ; CHECK STATE + CAIE 0,RESMBL + JRST NOTRES + MOVEM 0,PSTAT+1(PVP) + MOVEI 0,RUNING + MOVEM 0,PSTAT+1(D) ; SAVE NEW STATE + POP P,0 + POP P,C + JRST SWAP" + + +;SUBROUTINE TO GET BIT FOR CLOBBERAGE + +GETBIT: MOVNS B ;NEGATE + MOVSI A,400000 ;GET THE BIT + LSH A,(B) ;SHIFT TO POSITION + POPJ P, ;AND RETURN + +;HERE TO HANDLE PDL OVERFLOW. ASK FOR A GC + +IPDLOV: +IFN ITS,[ + MOVEM A,TSINT ;SAVE INT WORD +] + + SKIPE GCFLG ;IS GC RUNNING? + JRST GCPLOV ;YES, COMPLAIN GROSSLY + + MOVEI A,200000 ;GET BIT TO CLOBBER + IORM A,PIRQ ;LEAVE A MESSAGE FOR HIGHER LEVEL + + EXCH P,GCPDL ;GET A WINNING PDL + HRRZ B,TSINTR ;GET POINTER TO LOSING INSTRUCTION + SKIPG GCPDL ; SKIP IF NOT P + LDB B,[270400,,-1(B)] ;GET AC FIELD + SKIPL GCPDL ; SKIP IF P + MOVEI B,P + MOVEI A,(B) ;COPY IT + LSH A,1 ;TIMES 2 + ADDI A,0STO(PVP) ;POINT TO THIS ACS CURRENT TYPE + HLRZ A,(A) ;GET THAT TYPE INTO A + CAIN B,P ;IS IT P + MOVEI B,GCPDL ;POINT TO SAVED P + + CAIN B,B ;OR IS IT B ITSELF + MOVEI B,TSAVB + CAIN B,A ;OR A + MOVEI B,TSAVA + + CAIN B,C ;OR C + MOVEI B,1(P) ;C WILL BE ON THE STACK + + PUSH P,C + PUSH P,A + + MOVE A,(B) ;GET THE LOSING POINTER + MOVEI C,(A) ;AND ISOLATE RH + + CAMG C,VECTOP ;CHECK IF IN GC SPACE + CAMG C,VECBOT + JRST NOGROW ;NO, COMPLAIN + +; FALL THROUGH + + + HLRZ C,A ;GET -LENGTH + SUBI A,-1(C) ;POINT TO A DOPE WORD + POP P,C ;RESTORE TYPE INTO C + PUSH P,D ; SAVE FOR GROWTH HACKER + MOVEI D,0 + CAIN C,TPDL ; POIN TD TO APPROPRIATE DOPE WORD + MOVEI D,PGROW + CAIN C,TTP + MOVEI D,TPGROW + JUMPE D,BADPDL ; IF D STILL 0, THIS PDL IS WEIRD + MOVEI A,PDLBUF(A) ; POINT TO ALLEGED REAL DOPE WORD + SKIPN (D) ; SKIP IF PREVIOUSLY BLOWN + MOVEM A,(D) ; CLOBBER IN + CAME A,(D) ; MAKE SURE IT IS THE SAME + JRST PDLOSS + POP P,D ; RESTORE D + + +PNTRHK: MOVE C,(B) ;RESTORE PDL POINTER + SUB C,[PDLBUF,,0] ;FUDGE THE POINTER + MOVEM C,(B) ;AND STORE IT + + POP P,C ;RESTORE THE WORLD + EXCH P,GCPDL ;GET BACK ORIG PDL +IFN ITS,[ + MOVE A,TSINT ;RESTORE INT WORD + + JRST IMPCH ;LOOK FOR MORE INTERRUPTS +] +IFE ITS, JRST GCQUIT + +TPOVFL: SETOM INTFLG ;SIMULATE PDL OVFL + PUSH P,A + MOVEI A,200000 ;TURN ON THE BIT + IORM A,PIRQ + SUB TP,[PDLBUF,,0] ;HACK STACK POINTER + HLRE A,TP ;FIND DOPEW + SUBM TP,A ;POINT TO DOPE WORD + MOVEI A,1(A) ; ZERO LH AND POINT TO DOPEWD + SKIPN TPGROW + HRRZM A,TPGROW + CAME A,TPGROW ; MAKE SURE WINNAGE + JRST PDLOSS + POP P,A + POPJ P, + + +; GROW CORE IF PDL OVERFLOW DURING GC + +GCPLOV: MOVE A,P.TOP ; GET TOP OF IMPURE + ASH A,-10. ; TO BLOCKS + EXCH P,GCPDL ; NEED A PDL TO CALL P.CORE + ADDI A,1 ; GO TO NEXT BLOCK +GRECOR: PUSHJ P,P.CORE ; GET CORE + JRST SLPCOR ; HANG GETTING THE CORE + EXCH P,GCPDL ; BPDLS BACK + ADD P,[-2000,,0] +IFE ITS, JRST GCQUIT +IFN ITS,[ + MOVE A,TSINT + JRST IMPCH + + +SLPCOR: MOVEI B,1 + .SLEEP B, + JRST GRECOR + +] + +IFN ITS,[ + +;HERE TO HANDLE LOW-LEVEL CHANNELS + + +CHNACT: SKIPN GCFLG ;GET A WINNING PDL + EXCH P,GCPDL + ANDI A,177777 ;ISOLATE CHANNEL BITS + PUSH P,0 ;SAVE + +CHNA1: MOVEI B,0 ;BIT COUNTER + JFFO A,.+2 ;COUNT + JRST CHNA2 + SUBI B,35. ;NOW HAVE CHANNEL + MOVMS B ;PLUS IT + MOVEI 0,1 + LSH 0,(B) + ANDCM A,0 + MOVEI 0,(B) ; COPY TO 0 + LSH 0,23. ;POSITION FOR A .STATUS + IOR 0,[.STATUS 0] + XCT 0 ;DO IT + ANDI 0,77 ;ISOLATE DEVICE + CAILE 0,2 + JRST CHNA1 + +PMIN4: MOVE 0,B ; CHAN TO 0 + .ITYIC 0, ; INTO 0 + JRST .+2 ; DONE, GO ON + JRST PMIN4 + SETZM GCFLCH ; LEAVE GC MODE + JRST CHNA1 + +CHNA2: POP P,0 + SKIPN GCFLG + EXCH P,GCPDL + JRST GCQUIT + +HOWMNY: SETZ + SIXBIT /LISTEN/ + D + 402000,,B +] + +MFUNCTION GASCII,SUBR,ASCII + ENTRY 1 + + GETYP A,(AB) + CAIE A,TCHRS + JRST TRYNUM + + MOVE B,1(AB) + MOVSI A,TFIX + JRST FINIS + +TRYNUM: CAIE A,TFIX + JRST WTYP1 + SKIPGE B,1(AB) ;GET NUMBER + JRST TOOBIG + CAILE B,177 ;CHECK RANGE + JRST TOOBIG + MOVSI A,TCHRS + JRST FINIS + +TOOBIG: PUSH TP,$TATOM + PUSH TP,EQUOTE ARGUMENT-OUT-OF-RANGE + JRST CALER1 + + +;HERE IF PDL OVERFLOW DURING GARBAGE COLLECTION + +BADPDL: FATAL NON PDL OVERFLOW + +NOGROW: FATAL PDL OVERFLOW ON NON EXPANDABLE PDL + +PDLOSS: FATAL PDL OVEFLOW BUFFER EXHAUSTED + +DLOSER: PUSH P,LOSRS(B) + MOVE A,TSAVA + MOVE B,TSAVB + POPJ P, + +LOSRS: IMPV + ILOPR + IOC + IPURE + + +;MEMORY PROTECTION INTERRUPT + +IOC: FATAL IO CHANNEL ERROR IN GARBAGE COLLECTOR +IMPV: FATAL MPV IN GARBAGE COLLECTOR + +IPURE: FATAL PURE WRITE IN GARBAGE COLLECTOR +ILOPR: FATAL ILLEGAL OPEREATION IN GARBAGE COLLECTOR + +IFN ITS,[ + +;SUBROUTINE TO BE CALLED AT INITIALIZE TIME TO SETUP INTS + +INTINT: SETZM CHNCNT + MOVE A,[CHNCNT,,CHNCNT+1] + BLT A,CHNCNT+16. + SETZM INTFLG + .SUSET [.SPICLR,,[-1]] + MOVE A,MASK1 ;SET MASKS + MOVE B,MASK2 + .SETM2 A, ;SET BOTH MASKS + MOVSI A,TVEC + MOVEM A,QUEUES(TVP) + SETZM QUEUES+1(TVP) ;UNQUEUE ANY OLD INTERRUPTS + SETZM CURPRI + POPJ P, +] +IFE ITS,[ + +; INITIALIZE TENEX INTERRUPT SYSTEM + +INTINT: CIS ; CLEAR THE INT WORLD + SETZM INTFLG ; IN CASE RESTART + MOVSI A,TVEC ; FIXUP QUEUES + MOVEM A,QUEUES(TVP) + SETZM QUEUES+1(TVP) + SETZM CURPRI ; AND PRIORITY LEVEL + MOVEI A,MFORK ; TURN ON MY INTERRUPTS + MOVE B,[LEVTAB,,CHNTAB] ; POINT TO TABLES + SIR ; TELL SYSTEM ABOUT THEM + MOVE B,MASK1 ; SET UP FOR INT BITS + AIC ; TURN THEM ON + MOVSI A,7 ; CNTL G AND CHANNEL 0 + ATI ; ACTIVATE IT + MOVE A,[23,,1] ; CNTL S AND CHANNEL 1 + ATI ; ACTIVATE IT + MOVEI A,MFORK ; DO THE ENABLE + EIR + POPJ P, +] + + +; CNTL-G HANDLER + +MFUNCTION QUITTER,SUBR + + ENTRY 2 + GETYP A,(AB) + CAIE A,TCHRS + JRST WTYP1 + GETYP A,2(AB) + CAIE A,TCHAN + JRST WTYP2 + MOVE B,1(AB) + MOVE A,(AB) + CAIN B,^S ; HANDLE CNTL-S + JRST RETLIS + CAIE B,7 + JRST FINIS + + PUSHJ P,CLEAN ; CLEAN UP I/O CHANNELS + PUSH TP,$TATOM + PUSH TP,EQUOTE CONTROL-G? + MCALL 1,ERROR + JRST FINIS + +RETLIS: MOVEI D,(TB) ; FIND A LISTEN OR ERROR TO RET TO + +RETLI1: HRRZ A,OTBSAV(D) + HRRZ C,FSAV(A) ; CHECK FUNCTION + CAIE C,LISTEN + CAIN C,ERROR ; FOUND? + JRST FNDHIM ; YES, GO TO SAME + CAIN C,ERROR% ; FUNNY ERROR + JRST FNDHIM + CAIN C,TOPLEV ; NO ERROR/LISTEN + JRST FINIS + MOVEI D,(A) + JRST RETLI1 + +FNDHIM: PUSH TP,$TTB + PUSH TP,D + PUSHJ P,CLEAN + MOVE B,(TP) ; NEW FRAME + SUB TP,[2,,2] + MOVEI C,0 + PUSHJ P,CHUNW ; UNWIND? + MOVSI A,TATOM + MOVE B,MQUOTE T + JRST FINIS + +CLEAN: MOVE B,3(AB) ; GET IN CHAN + PUSHJ P,RRESET + MOVE B,3(AB) ; CHANNEL BAKC + MOVE C,BUFRIN(B) + SKIPN C,ECHO(C) ; GET ECHO + JRST CLUNQ +IFN ITS,[ + MOVEI A,2 + CAMN C,[PUSHJ P,MTYO] + JRST TYONUM + LDB A,[270400,,C] +TYONUM: LSH A,23. + IOR A,[.RESET] + XCT A +] +IFE ITS,[ + MOVEI A,101 ; OUTPUT JFN + CFOBF +] + +CLUNQ: SETZB A,CURPRI + JRST UNQUEU + + +IMPURE +ONINT: 0 ; INT FUDGER +IFN ITS,[ +;RANDOM IMPURE CRUFT NEEDED +CHNCNT: BLOCK 16. ; # OF CHARS IN EACH CHANNEL + +TSAVA: 0 +TSAVB: 0 +PIRQ: 0 ;HOLDS REQUEST BITS FOR 1ST WORD +PIRQ2: 0 ;SAME FOR WORD 2 +PCOFF: 0 +MASK1: 1200,,220540 ;FIRST MASK +MASK2: 0 ;SECOND THEREOF +CURPRI: 0 ; CURRENT PRIORITY +] +IFE ITS,[ +NETJFN: BLOCK NNETS +MASK1: CHNMSK +TSINTR: +P1: 0 ; PC INT LEVEL 1 +P2: 0 ; PC INT LEVEL 2 +P3: 0 ; PC INT LEVEL 3 +CURPRI: 0 +TSAVA: 0 +TSAVB: 0 +PIRQ: 0 +PIRQ2: 0 +] +PURE + +END + \ No newline at end of file diff --git a/sumex/main.mcr227 b/sumex/main.mcr227 new file mode 100644 index 0000000..e006ec2 --- /dev/null +++ b/sumex/main.mcr227 @@ -0,0 +1,1819 @@ +TITLE MAIN LOOP AND GLOBALLY REFERENCED SUBROUTINES + +RELOCA + +.GLOBAL PATCH,TBINIT,PIDSTO,PROCID,PTIME,GCPDL,PBASE,TYPTOP,RERR,FRMSTK,EMERGE +.GLOBAL PAT,PDLBUF,INTINT,START,SWAP,ICR,SPBASE,TPBASE,TPBAS,SAT,CURPRI,CHFINI +.GLOBAL TOPLEVEL,INTOBL,INITIA,ERROBL,MAINPR,RESFUN,STATUS,TYPVEC,ROOT,TTICHN,TTOCHN +.GLOBAL TTYOPE,MOPEN,MCLOSE,MIOT,ILVAL,MESS,ERROR,CHFRM,IGVAL,TYPBOT,ASOVEC +.GLOBAL PRINT,PRIN1,PRINC,MUDSTR,VECBOT,CSTACK,IFALSE,TYPLOO,RCALL,SWAPIN,CTMPLT +.GLOBAL IDPROC,CHFSWP,ILOC,MAKACT,BNDV,SPECSTORE,BINDID,IGLOC,MTYO,MSGTYP,CAFRE1 +.GLOBAL EVATYP,EVTYPE,APLTYP,APTYPE,PRNTYP,PRTYPE,AGC,SGSNAM,NAPT,APLQ,STRTO6 +.GLOBAL 6TOCHS,TYPFND,STBL,CHNL0,N.CHNS,CLOSAL,%LOGOUT,%SSNAM,%RSNAM,%KILLM +.GLOBAL MAKINF,%VALRET,COMPERR,IPUT,IGET,TMATCH,INITIZ,IPCINI,%UNAM,%JNAM,%RUNAM,%RJNAM +.GLOBAL NOTTY,PATEND,CFRAME,CARGS,CFUNCT,CITYPE,CTYPEQ,CPTYPE,CTYPEP,CUTYPE,CCHUTY +.GLOBAL RTFALS,PGINT,PURCLN,CTYPEC,CTYPEW,IDVAL1,CALLTY,MESSAG,INITFL,WHOAMI +.GLOBAL %SLEEP,%HANG,%TOPLQ,ONINT,CHUNW,CURFCN,BUFRIN,TD.LNT,TD.GET,TD.PUT,MPOPJ +.GLOBAL PURVEC,PLOAD,SSPECS,OUTRNG +.GLOBAL TYPIC +.INSRT MUDDLE > + +MONITS==1 ; SET TO 1 IF PC DEMON WANTED +.VECT.==1 ; BIT TO INDICATE VECTORS FOR GCHACK + +;MAIN LOOP AND STARTUP + +START: MOVEI 0,0 ; SET NO HACKS + MOVEM 0,WHOAMI ; HACK FOR TS FOO linked to TS MUDDLE + MOVE PVP,MAINPR ; MAKE SURE WE START IN THE MAIN PROCESS + JUMPE 0,INITIZ ; MIGHT BE RESTART + MOVE P,PSTO+1(PVP) ; SET UP FOR BOOTSTRAP HACK + MOVE TP,TPSTO+1(PVP) +INITIZ: SKIPN P ; IF NO CURRENT P + MOVE P,PSTO+1(PVP) ; PDL TO GET OFF THE GROUND + SKIPN TP ; SAME FOR TP + MOVE TP,TPSTO+1(PVP) ; GET A TP TO WORK WITH + MOVE TVP,TVPSTO+1(PVP) ; GET A TVP + SETZB R,M ; RESET RSUBR AC'S + PUSHJ P,%RUNAM + PUSHJ P,%RJNAM + PUSHJ P,TTYOPE ;OPEN THE TTY + MOVEI B,MUDSTR + SKIPE WHOAMI ; SKIP IF THIS IS MUDDLE + JRST .+3 ; ELSE NO MESSAGE + SKIPN NOTTY ; IF NO TTY, IGNORE + PUSHJ P,MSGTYP ;TYPE OUT TO USER + + XCT MESSAG ;MAYBE PRINT A MESSAGE + PUSHJ P,INTINT ;INITIALIZE INTERRUPT HANDLER + XCT IPCINI + PUSHJ P,PURCLN ; CLEAN UP PURE SHARED AREA +RESTART: ;RESTART A PROCESS +STP: MOVEI C,0 + MOVE B,TBINIT+1(PVP) ;POINT INTO STACK AT START + PUSHJ P,CHUNW ; LEAVE WHILE DOING UNWIND CHECK + MOVEI E,TOPLEV + MOVEI A,TFALSE ; IN CASE FALLS OFF PROCESS + MOVEI B,0 + MOVEM E,-1(TB) + JRST CONTIN + + MQUOTE TOPLEVEL +TOPLEVEL: + MCALL 0,LISTEN + JRST TOPLEVEL + + +MFUNCTION LISTEN,SUBR + + ENTRY + PUSH P,[0] ;FLAG: DON'T PRINT ERROR MSG + JRST ER1 + +; USER SUPPLIED ERROR HANDLER, TEMPORARY KLUDGE + IMQUOTE ERROR + +ERROR: MOVE B,IMQUOTE ERROR + PUSHJ P,IGVAL ; GET VALUE + GETYP C,A + CAIN C,TSUBR ; CHECK FOR NO CHANGE + CAIE B,RERR1 ; SKIP IF NOT CHANGED + JRST .+2 + JRST RERR1 ; GO TO THE DEFAULT + PUSH TP,A ; SAVE VALUE + PUSH TP,B + MOVE C,AB ; SAVE AB + MOVEI D,1 ; AND COUNTER +USER1: PUSH TP,(C) ; PUSH THEM + PUSH TP,1(C) + ADD C,[2,,2] ; BUMP + ADDI D,1 + JUMPL C,USER1 + ACALL D,APPLY ; EVAL USERS ERROR + JRST FINIS + + +TPSUBR==TSUBR+400000 + +MFUNCTION ERROR%,PSUBR,ERROR + +RMT [EXPUNGE TPSUBR +] +RERR1: ENTRY + PUSH TP,$TATOM + PUSH TP,MQUOTE ERROR,ERROR,INTRUP + PUSHJ P,FRMSTK ; PUT ERROR'S FRAME ON STACK + MOVEI D,2 + MOVE C,AB +RERR2: JUMPGE C,RERR22 + PUSH TP,(C) + PUSH TP,1(C) + ADD C,[2,,2] + AOJA D,RERR2 +RERR22: ACALL D,EMERGENCY + JRST RERR + +IMQUOTE ERROR +RERR: ENTRY + PUSH P,[-1] ;PRINT ERROR FLAG + +ER1: MOVE B,IMQUOTE INCHAN + PUSHJ P,ILVAL ; CHECK INPUT CHANNEL IS SOME KIND OF TTY + GETYP A,A + CAIE A,TCHAN ; SKIP IF IT IS A CHANNEL + JRST ER2 ; NO, MUST REBIND + CAMN B,TTICHN+1(TVP) + JRST NOTINC +ER2: MOVE B,IMQUOTE INCHAN + MOVEI C,TTICHN(TVP) ; POINT TO VALU + PUSHJ P,PUSH6 ; PUSH THE BINDING + MOVE B,TTICHN+1(TVP) ; GET IN CHAN +NOTINC: SKIPE NOTTY + JRST NOECHO + PUSH TP,$TCHAN + PUSH TP,B + PUSH TP,$TATOM + PUSH TP,MQUOTE T + MCALL 2,TTYECH ; ECHO INPUT +NOECHO: MOVE B,IMQUOTE OUTCHAN + PUSHJ P,ILVAL ; GET THE VALUE + GETYP A,A + CAIE A,TCHAN ; SKIP IF OK CHANNEL + JRST ER3 ; NOT CHANNEL, MUST REBIND + CAMN B,TTOCHN+1(TVP) + JRST NOTOUT +ER3: MOVE B,IMQUOTE OUTCHAN + MOVEI C,TTOCHN(TVP) + PUSHJ P,PUSH6 ; PUSH THE BINDINGS +NOTOUT: MOVE B,IMQUOTE OBLIST + PUSHJ P,ILVAL ; GET THE VALUE OF OBLIST + PUSHJ P,OBCHK ; IS IT A WINNER ? + SKIPA A,$TATOM ; NO, SKIP AND CONTINUE + JRST NOTOBL ; YES, DO NOT DO REBINDING + MOVE B,IMQUOTE OBLIST + PUSHJ P,IGLOC + GETYP 0,A + CAIN 0,TUNBOU + JRST MAKOB ; NO GLOBAL OBLIST, MAKE ONE + MOVEI C,(B) ; COPY ADDRESS + MOVE A,(C) ; GET THE GVAL + MOVE B,(C)+1 + PUSHJ P,OBCHK ; IS IT A WINNER ? + JRST MAKOB ; NO, GO MAKE A NEW ONE + MOVE B,IMQUOTE OBLIST + PUSHJ P,PUSH6 + +NOTOBL: PUSH TP,[TATOM,,-1] ;FOR BINDING + PUSH TP,IMQUOTE LER,[LERR ]INTRUP + PUSHJ P,MAKACT + HRLI A,TFRAME ; CORRCT TYPE + PUSH TP,A + PUSH TP,B + PUSH TP,[0] + PUSH TP,[0] + MOVE A,PVP ; GET PROCESS + ADD A,[PROCID,,PROCID] ; POINT TO ID (ALSO LEVEL) + PUSH TP,BNDV + PUSH TP,A + MOVE A,PROCID(PVP) + ADDI A,1 ; BUMP ERROR LEVEL + PUSH TP,A + PUSH TP,PROCID+1(PVP) + PUSH P,A + + MOVE B,IMQUOTE READ-TABLE + PUSHJ P,IGVAL + PUSH TP,[TATOM,,-1] + PUSH TP,IMQUOTE READ-TABLE + GETYP C,A ; TO GVAL OF READ-TABLE ON ERROR AND + CAIE C,TVEC ; TOP ERRET'S + JRST .+4 + PUSH TP,A + PUSH TP,B + JRST .+3 + PUSH TP,$TUNBOUND + PUSH TP,[-1] + PUSH TP,[0] + PUSH TP,[0] + + PUSHJ P,SPECBIND ;BIND THE CRETANS + MOVE A,-1(P) ;RESTORE SWITHC + JUMPE A,NOERR ;IF 0, DONT PRINT ERROR MESS + PUSH TP,$TATOM + PUSH TP,EQUOTE *ERROR* + MCALL 0,TERPRI + MCALL 1,PRINC ;PRINT THE MESSAGE +NOERR: MOVE C,AB ;GET A COPY OF AB + +ERRLP: JUMPGE C,LEVPRT ;IF NONE, RE-ENTER READ-EVAL-PRINT LOOP + PUSH TP,$TAB + PUSH TP,C + MOVEI B,PRIN1 + GETYP A,(C) ; GET ARGS TYPE + CAIE A,TATOM + JRST ERROK + MOVE A,1(C) ; GET ATOM + MOVE A,2(A) + CAIE A,ERROBL+1 + CAMN A,ERROBL+1(TVP) ; DONT SKIP IF IN ERROR OBLIST + MOVEI B,PRINC ; DONT PRINT TRAILER +ERROK: PUSH P,B ; SAVE ROUTINE POINTER + PUSH TP,(C) + PUSH TP,1(C) + MCALL 0,TERPRI ; CRLF + POP P,B ; GET ROUTINE BACK + .MCALL 1,(B) + POP TP,C + SUB TP,[1,,1] + ADD C,[2,,2] ;BUMP SAVED AB + JRST ERRLP ;AND CONTINUE + + +LEVPRT: XCT INITFL ;LOAD MUDDLE INIT FILE IF FIRST TIME + MCALL 0,TERPRI + PUSH TP,$TATOM + PUSH TP,EQUOTE [LISTENING-AT-LEVEL ] + MCALL 1,PRINC ;PRINT LEVEL + PUSH TP,$TFIX ;READY TO PRINT LEVEL + HRRZ A,(P) ;GET LEVEL + SUB P,[2,,2] ;AND POP STACK + PUSH TP,A + MCALL 1,PRIN1 ;PRINT WITHOUT SPACES ETC. + PUSH TP,$TATOM ;NOW PROCESS + PUSH TP,EQUOTE [ PROCESS ] + MCALL 1,PRINC ;DONT SLASHIFY SPACES + PUSH TP,PROCID(PVP) ;NOW ID + PUSH TP,PROCID+1(PVP) + MCALL 1,PRIN1 + SKIPN C,CURPRI + JRST MAINLP + PUSH TP,$TFIX + PUSH TP,C + PUSH TP,$TATOM + PUSH TP,EQUOTE [ INT-LEVEL ] + MCALL 1,PRINC + MCALL 1,PRIN1 + JRST MAINLP ; FALL INTO MAIN LOOP + + ;ROUTINES FOR ERROR-LISTEN + +OBCHK: GETYP 0,A + CAIN 0,TOBLS + JRST CPOPJ1 ; WIN FOR SINGLE OBLIST + CAIE 0,TLIST ; IF LIST, MAKE SURE EACH IS AN OBLIST + JRST CPOPJ ; ELSE, LOSE + + JUMPE B,CPOPJ ; NIL ,LOSE + PUSH TP,A + PUSH TP,B + PUSH P,[0] ;FLAG FOR DEFAULT CHECKING + MOVEI 0,1000 ; VERY BIG NUMBER FOR CIRCULARITY TEST + +OBCHK0: INTGO + SOJE 0,OBLOSE ; CIRCULARITY TEST + HRRZ B,(TP) ; GET LIST POINTER + GETYP A,(B) + CAIE A,TOBLS ; SKIP IF WINNER + JRST DEFCHK ; CHECK FOR SPECIAL ATOM DEFAULT + HRRZ B,(B) + MOVEM B,(TP) + JUMPN B,OBCHK0 +OBWIN: AOS (P)-1 +OBLOSE: SUB TP,[2,,2] + SUB P,[1,,1] + POPJ P, + +DEFCHK: SKIPN (P) ; BEEN HERE BEFORE ? + CAIE A,TATOM ; OR, NOT AN ATOM ? + JRST OBLOSE ; YES, LOSE + MOVE A,(B)+1 + CAME A,MQUOTE DEFAULT + JRST OBLOSE ; LOSE + SETOM (P) ; SET FLAG + HRRZ B,(B) ; CHECK FOR END OF LIST + MOVEM B,(TP) + JUMPN B,OBCHK0 ; NOT THE END, CONTINUE LOOKING + JRST OBLOSE ; LOSE FOR DEFAULT AT THE END + + + +PUSH6: PUSH TP,[TATOM,,-1] + PUSH TP,B + PUSH TP,(C) + PUSH TP,1(C) + PUSH TP,[0] + PUSH TP,[0] + POPJ P, + + +MAKOB: PUSH TP,INITIAL(TVP) + PUSH TP,INITIAL+1(TVP) + PUSH TP,ROOT(TVP) + PUSH TP,ROOT+1(TVP) + MCALL 2,LIST + PUSH TP,$TATOM + PUSH TP,IMQUOTE OBLIST + PUSH TP,A + PUSH TP,B + MCALL 2,SETG + PUSH TP,[TATOM,,-1] + PUSH TP,IMQUOTE OBLIST + PUSH TP,A + PUSH TP,B + PUSH TP,[0] + PUSH TP,[0] + JRST NOTOBL + + +;THIS IS IT FOLKS...THE MAIN LOOP. READ, EVAL, PRINT + +MAINLP: MOVE A,$TATOM ;KLUDGE BY NDR LIKE ERROR TO LET LOOSER REDEFINE + MOVE B,MQUOTE REP + PUSHJ P,ILVAL ;GET ITS LVAL TO SEE IF REDEFINED + GETYP C,A + CAIE C,TUNBOUND + JRST REPCHK + MOVE A,$TATOM ;SEE IF IT HAS GVAL SINCE NO LVAL + MOVE B,MQUOTE REP + PUSHJ P,IGVAL + GETYP C,A + CAIN C,TUNBOUN + JRST IREPER +REPCHK: CAIN C,TSUBR + CAIE B,REPER + JRST .+2 + JRST IREPER +REREPE: PUSH TP,A + PUSH TP,B + GETYP A,-1(TP) + PUSHJ P,APLQ + JRST ERRREP + MCALL 1,APPLY ;LOOSER HAS REDEFINED SO CALL HIS + JRST MAINLP +IREPER: PUSH P,[0] ;INDICATE FALL THROUGH + JRST REPERF + +ERRREP: PUSH TP,[TATOM,,-1] + PUSH TP,MQUOTE REP + PUSH TP,$TSUBR + PUSH TP,[REPER] + PUSH TP,[0] + PUSH TP,[0] + PUSHJ P,SPECBIN + PUSH TP,$TATOM + PUSH TP,EQUOTE NON-APPLICABLE-REP + PUSH TP,-11(TP) + PUSH TP,-11(TP) + MCALL 2,ERROR + SUB TP,[6,,6] + PUSHJ P,SSPECS + JRST REREPE + + +MFUNCTION REPER,SUBR,REP +REPER: ENTRY 0 + PUSH P,[1] ;INDICATE DIRECT CALL +REPERF: MCALL 0,TERPRI + MCALL 0,READ + PUSH TP,A + PUSH TP,B + MCALL 0,TERPRI + MCALL 1,EVAL + PUSH TP,$TATOM + PUSH TP,IMQUOTE LAST-OUT + PUSH TP,A + PUSH TP,B + MCALL 2,SET + PUSH TP,A + PUSH TP,B + MCALL 1,PRIN1 + POP P,C ;FLAG FOR FALL THROUGH OR CALL + JUMPN C,FINIS ;IN CASE LOOSER CALLED REP + JRST MAINLP + + +;FUNCTION TO RETRY A PREVIOUS FUNCTION CALL + +MFUNCTION RETRY,SUBR + + ENTRY + JUMPGE AB,RETRY1 ; USE MOST RECENT + CAMGE AB,[-2,,0] + JRST TMA + GETYP A,(AB) ; CHECK TYPE + CAIE A,TFRAME + JRST WTYP1 + MOVEI B,(AB) ; POINT TO ARG + JRST RETRY2 +RETRY1: MOVE B,IMQUOTE LER,[LERR ]INTRUP + PUSHJ P,ILOC ; LOCATIVE TO FRAME +RETRY2: PUSHJ P,CHFSWP ; CHECK VALIDITY AND SWAP IF NECESSARY + HRRZ 0,OTBSAV(B) ; CHECK FOR TOP + JUMPE 0,RESTAR ; YES RE-ENTER TOP LEVEL + PUSH TP,$TTB + PUSH TP,B ; SAVE FRAME + MOVE B,OTBSAV(B) ; GET PRVIOUS FOR UNBIND HACK + MOVEI C,-1(TP) + PUSHJ P,CHUNW ; CHECK ANY UNWINDING + CAME SP,SPSAV(TB) ; UNBINDING NEEDED? + PUSHJ P,SPECSTORE + MOVE P,PSAV(TB) ; GET OTHER STUFF + MOVE AB,ABSAV(B) + HLRE A,AB ; COMPUTE # OF ARGS + MOVNI A,-FRAMLN(A) ; MAKE TP POINT PAST FRAME + HRLI A,(A) + MOVE C,TPSAV(TB) ; COMPUTE TP + ADD C,A + MOVE TP,C + MOVE TB,B ; FIX UP TB + HRRZ C,FSAV(TB) ; GET FUNCTION + CAMGE C,VECTOP ; CHECK FOR RSUBR + CAMG C,VECBOT + JRST (C) ; GO + GETYP 0,(C) ; RSUBR OR ENTRY? + CAIE 0,TATOM + CAIN 0,TRSUBR + JRST RETRNT + MOVS R,(C) ; SET UP R + HRRI R,(C) + MOVEI C,0 + JRST RETRN3 + +RETRNT: CAIE 0,TRSUBR + JRST RETRN1 + MOVE R,1(C) +RETRN4: HRRZ C,2(C) ; OFFSET +RETRN3: SKIPL M,1(R) + JRST RETRN5 +RETRN7: ADDI C,(M) + JRST (C) + +RETRN5: MOVEI D,(M) ; TOTAL OFFSET + MOVSS M + ADD M,PURVEC+1(TVP) + SKIPL M,1(M) + JRST RETRN6 + ADDI M,(D) + JRST RETRN7 +RETRN6: HLRZ A,1(R) + PUSH P,D + PUSH P,C + PUSHJ P,PLOAD + JRST RETRER ; LOSER + POP P,C + POP P,D + MOVE M,B + JRST RETRN7 + +RETRN1: MOVE B,1(C) + PUSH TP,$TVEC + PUSH TP,C + PUSHJ P,IGVAL + GETYP 0,A + MOVE C,(TP) + SUB TP,[2,,2] + CAIE 0,TRSUBR + JRST RETRN2 + MOVE R,B + JRST RETRN3 + +RETRN2: PUSH TP,$TATOM + PUSH TP,EQUOTE CANT-RETRY-ENTRY-GONE + JRST CALER1 + +RETRER: PUSH TP,$TATOM + PUSH TP,EQUOTE PURE-LOAD-FAILURE + JRST CALER1 + + +;FUNCTION TO DO ERROR RETURN + +MFUNCTION ERRET,SUBR + + ENTRY + HLRE A,AB ; -2*# OF ARGS + JUMPGE A,STP ; RESTART PROCESS + ASH A,-1 ; -# OF ARGS + AOJE A,ERRET2 ; NO FRAME SUPPLIED + AOJL A,TMA + ADD AB,[2,,2] + PUSHJ P,OKFRT + JRST WTYP2 + SUB AB,[2,,2] + PUSHJ P,CHPROC ; POINT TO FRAME SLOT + JRST ERRET3 +ERRET2: MOVE B,IMQUOTE LER,[LERR ]INTRUP + PUSHJ P,ILVAL ; GET ITS VALUE +ERRET3: PUSH TP,A + PUSH TP,B + MOVEI B,-1(TP) + PUSHJ P,CHFSWP ; CHECK VALIDITY AND SWAP IF NECESSARY + HRRZ 0,OTBSAV(B) ; TOP LEVEL? + JUMPE 0,TOPLOS + PUSHJ P,CHUNW ; ANY UNWINDING + JRST CHFINIS + + +; FUNCTION TO RETURN LAST ERROR FRAME OR PREVIOUS FRAME + +MFUNCTION FRAME,SUBR + ENTRY + SETZB A,B + JUMPGE AB,FRM1 ; DEFAULT CASE + CAMG AB,[-3,,0] ; SKIP IF OK ARGS + JRST TMA + PUSHJ P,OKFRT ; A FRAME OR SIMILAR THING? + JRST WTYP1 + +FRM1: PUSHJ P,CFRAME ; GO TO INTERNAL + JRST FINIS + +CFRAME: JUMPN A,FRM2 ; ARG SUPPLIED? + MOVE B,IMQUOTE LER,[LERR ]INTRUP + PUSHJ P,ILVAL + JRST FRM3 +FRM2: PUSHJ P,CHPROC ; CHECK FOR PROCESS + PUSH TP,A + PUSH TP,B + MOVEI B,-1(TP) ; POINT TO SLOT + PUSHJ P,CHFRM ; CHECK IT + MOVE C,(TP) ; GET FRAME BACK + MOVE B,OTBSAV(C) ;GET PREVIOUS FRAME + SUB TP,[2,,2] + TRNN B,-1 ; SKIP IF OK + JRST TOPLOSE + +FRM3: JUMPN B,FRM4 ; JUMP IF WINNER + MOVE B,IMQUOTE THIS-PROCESS + PUSHJ P,ILVAL ; GET PROCESS OF INTEREST + GETYP A,A ; CHECK IT + CAIN A,TUNBOU + MOVE B,PVP ; USE CURRENT + MOVEI A,PVLNT*2+1(B) ; POINT TO DOPE WORDS + MOVE B,TBINIT+1(B) ; AND BASE FRAME +FRM4: HLL B,OTBSAV(B) ;TIME + HRLI A,TFRAME + POPJ P, + +OKFRT: AOS (P) ;ASSUME WINNAGE + GETYP 0,(AB) + MOVE A,(AB) + MOVE B,1(AB) + CAIE 0,TFRAME + CAIN 0,TENV + POPJ P, + CAIE 0,TPVP + CAIN 0,TACT + POPJ P, + SOS (P) + POPJ P, + +CHPROC: GETYP 0,A ; TYPE + CAIE 0,TPVP + POPJ P, ; OK + MOVEI A,PVLNT*2+1(B) + CAMN B,PVP ; THIS PROCESS? + JRST CHPRO1 + MOVE B,TBSTO+1(B) + JRST FRM4 + +CHPRO1: MOVE B,OTBSAV(TB) + JRST FRM4 + +; FUNCTION TO RETURN ARGS TUPLE FOR A FRAME + +MFUNCTION ARGS,SUBR + ENTRY 1 + PUSHJ P,OKFRT ; CHECK FRAME TYPE + JRST WTYP1 + PUSHJ P,CARGS + JRST FINIS + +CARGS: PUSHJ P,CHPROC + PUSH TP,A + PUSH TP,B + MOVEI B,-1(TP) ; POINT TO FRAME SLOT + PUSHJ P,CHFRM ; AND CHECK FOR VALIDITY + MOVE C,(TP) ; FRAME BACK + MOVSI A,TARGS +CARGS1: GETYP 0,FSAV(C) ; IS THIS A FUNNY ONE + CAIE 0,TCBLK ; SKIP IF FUNNY + JRST .+3 ; NO NORMAL + MOVE C,OTBSAV(C) ; ASSOCIATE WITH PREVIOUS FRAME + JRST CARGS1 + HLR A,OTBSAV(C) ; TIME IT AND + MOVE B,ABSAV(C) ; GET POINTER + SUB TP,[2,,2] ; FLUSH CRAP + POPJ P, + +; FUNCTION TO RETURN FUNCTION ASSOCIATED WITH A FRAME + +MFUNCTION FUNCT,SUBR ;RETURNS FUNCTION NAME OF + ENTRY 1 ; FRAME ARGUMENT + PUSHJ P,OKFRT ; CHECK TYPE + JRST WTYP1 + PUSHJ P,CFUNCT + JRST FINIS + +CFUNCT: PUSHJ P,CHPROC + PUSH TP,A + PUSH TP,B + MOVEI B,-1(TP) + PUSHJ P,CHFRM ; CHECK IT + MOVE C,(TP) ; RESTORE FRAME + HRRZ A,FSAV(C) ;FUNCTION POINTER + CAMG A,VECTOP ;IS THIS AN RSUBR ? + CAMGE A,VECBOT + SKIPA B,@-1(A) ;NO, GET SUBR'S NAME POINTER + MOVE B,(A)+3 ;YES, GET RSUBR'S NAME ENTRY + MOVSI A,TATOM + SUB TP,[2,,2] + POPJ P, + +BADFRAME: + PUSH TP,$TATOM + PUSH TP,EQUOTE FRAME-NO-LONGER-EXISTS + JRST CALER1 + + +TOPLOSE: + PUSH TP,$TATOM + PUSH TP,EQUOTE TOP-LEVEL-FRAME + JRST CALER1 + + + + +; ROUTINE TO HANG INDEFINITELY WITH INTERRUPTS ENABLED + +MFUNCTION HANG,SUBR + + ENTRY + + JUMPGE AB,HANG1 ; NO PREDICATE + CAMGE AB,[-3,,] + JRST TMA +REHANG: MOVE A,[PUSHJ P,CHKPRH] + MOVEM A,ONINT ; CHECK PREDICATE AFTER ANY INTERRUPT + PUSH TP,(AB) + PUSH TP,1(AB) +HANG1: ENABLE ;LET OURSELVES BE INTERRUPTED OUT + PUSHJ P,%HANG + DISABLE ;PREVENT INTERRUPTS AT RANDOM TIMES + SETZM ONINT + MOVE A,$TATOM + MOVE B,MQUOTE T + JRST FINIS + + +; ROUTINE TO SLEEP FOR POSITIVE NUMBER OF SECONDS WITH INTERRUPTS ENABLED +; ARGUMENT SHOULD BE OF TYPE FIX OR FLOAT AND NON-NEGATIVE + +MFUNCTION SLEEP,SUBR + + ENTRY + + JUMPGE AB,TFA + CAML AB,[-3,,] + JRST SLEEP1 + CAMGE AB,[-5,,] + JRST TMA + PUSH TP,2(AB) + PUSH TP,3(AB) +SLEEP1: GETYP 0,(AB) + CAIE 0,TFIX + JRST .+5 + MOVE B,1(AB) + JUMPL B,OUTRNG ;ARG SHOULDNT BE NEGATIVE + IMULI B,30. ;CONVERT TO # OF THIRTIETHS OF A SECOND + JRST SLEEPR ;GO SLEEP + CAIE 0,TFLOAT ;IF IT WASNT FIX MAKE SURE IT IS FLOAT + JRST WTYP1 ;WRONG TYPE ARG + MOVE B,1(AB) + FMPR B,[30.0] ;CONVERT TO FLOATING # OF THIRTIETHS OF A SECOND + MULI B,400 ;KLUDGE TO FIX IT + TSC B,B + ASH C,(B)-243 + MOVE B,C ;MOVE THE FIXED NUMBER INTO B + JUMPL B,OUTRNG ;CHECK TO SEE THAT WE HAVE POSITIVE NUMBER +SLEEPR: MOVE A,B +RESLEE: MOVE B,[PUSHJ P,CHKPRS] + CAMGE AB,[-3,,] + MOVEM B,ONINT + ENABLE + PUSHJ P,%SLEEP + DISABLE + SETZM ONINT + MOVE A,$TATOM + MOVE B,MQUOTE T + JRST FINIS + +CHKPRH: PUSH P,B + MOVEI B,HANGP + JRST .+3 + +CHKPRS: PUSH P,B + MOVEI B,SLEEPP + HRRM B,LCKINT + SETZM ONINT ; TURN OFF FEATURE FOR NOW + POP P,B + POPJ P, + +HANGP: SKIPA B,[REHANG] +SLEEPP: MOVEI B,RESLEE + PUSH P,B + PUSH P,A + DISABLE + PUSH TP,(TB) + PUSH TP,1(TB) + MCALL 1,EVAL + GETYP 0,A + CAIE 0,TFALSE + JRST FINIS + POP P,A + POPJ P, + +MFUNCTION VALRET,SUBR +; SUBR TO VALRET A STRING TO SUPERIOR ITS PROCESS + + ENTRY 1 + GETYP A,(AB) ; GET TYPE OF ARGUMENT + CAIE A,TCHSTR ; IS IT A CHR STRING? + JRST WTYP1 ; NO...ERROR WRONG TYPE + PUSHJ P,CSTACK ; COPY THE CHR STRING TO THE STACK + ; CSTACK IS IN ATOMHK + MOVEI B,0 ; ASCIZ TERMINATOR + EXCH B,(P) ; STORE AND RETRIEVE COUNT + +; CALCULATE THE BEGINNING ADDR OF THE STRING + MOVEI A,-1(P) ; GET ADDR OF TOP OF STACK + SUBI A,-1(B) ; GET STARTING ADDR + PUSHJ P,%VALRE ; PASS UP TO MONITOR + JRST IFALSE ; IF HE RETURNS, RETURN FALSE + + +MFUNCTION LOGOUT,SUBR + +; SUBR TO DO A .LOGOUT (VALID ONLY AT TOP LEVEL) + ENTRY 0 + PUSHJ P,%TOPLQ ; SKIP IF AT TOP LEVEL + JRST IFALSE + PUSHJ P,CLOSAL + PUSHJ P,%LOGOUT ; TRY TO FLUSH + JRST IFALSE ; COULDN'T DO IT...RETURN FALSE + +; FUNCTS TO GET UNAME AND JNAME + +MFUNCTION UNAME,SUBR + + ENTRY 0 + + PUSHJ P,%RUNAM + JRST RSUJNM + +MFUNCTION JNAME,SUBR + + ENTRY 0 + + PUSHJ P,%RJNAM + JRST RSUJNM + +; FUNCTION TO SET AND READ GLOBAL SNAME + +MFUNCTION SNAME,SUBR + + ENTRY + + JUMPGE AB,SNAME1 + CAMG AB,[-3,,] + JRST TMA + GETYP A,(AB) ; ARG MUST BE STRING + CAIE A,TCHSTR + JRST WTYP1 + PUSH TP,$TATOM + PUSH TP,IMQUOTE SNM + PUSH TP,(AB) + PUSH TP,1(AB) + MCALL 2,SETG + JRST FINIS + +SNAME1: MOVE B,IMQUOTE SNM + PUSHJ P,IDVAL1 + GETYP 0,A + CAIN 0,TCHSTR + JRST FINIS + MOVE A,$TCHSTR + MOVE B,CHQUOTE + JRST FINIS + +RSUJNM: PUSHJ P,6TOCHS ; CONVERT IT + JRST FINIS + + +SGSNAM: MOVE B,IMQUOTE SNM + PUSHJ P,IDVAL1 + GETYP 0,A + CAIE 0,TCHSTR + JRST SGSN1 + + PUSH TP,A + PUSH TP,B + PUSHJ P,STRTO6 + POP P,A + SUB TP,[2,,2] + JRST .+2 + +SGSN1: MOVEI A,0 + PUSHJ P,%SSNAM ; SET SNAME IN SYSTEM + POPJ P, + + + +;THIS SUBROUTINE ALLOCATES A NEW PROCESS TAKES NO ARGS AND +;IS CALLED BY PUSHJ P,. RETURNS IN A AND B A NEW PROCESS. + +ICR: MOVEI A,PVLNT ;SETUP CALL TO VECTOR FOR PVP + PUSHJ P,IVECT ;GOBBLE A VECTOR + HRLI C,PVBASE ;SETUP A BLT POINTER + HRRI C,(B) ;GET INTO ADDRESS + BLT C,PVLNT*2-1(B) ;COPY A PROTOTYPE INTO NEW PVP + MOVSI C,400000+SPVP+.VECT. ;SET SPECIAL TYPE + MOVEM C,PVLNT*2(B) ;CLOBBER IT IN + PUSH TP,A ;SAVE THE RESULTS OF VECTOR + PUSH TP,B + + PUSH TP,$TFIX ;GET A UNIFORM VECTOR + PUSH TP,[PLNT] + MCALL 1,UVECTOR + ADD B,[PDLBUF-2,,-1] ;FUDGE WITH BUFFER + MOVE C,(TP) ;REGOBBLE PROCESS POINTER + MOVEM B,PSTO+1(C) ;STORE IN ALL HOMES + MOVEM B,PBASE+1(C) + + + MOVEI A,TPLNT ;PREPARE TO CREATE A TEMPORARY PDL + PUSHJ P,IVECT ;GET THE TEMP PDL + ADD B,[PDLBUF,,0] ;PDL GROWTH HACK + MOVE C,(TP) ;RE-GOBBLE NEW PVP + SUB B,[1,,1] ;FIX FOR STACK + MOVEM B,TPBASE+1(C) + +;SETUP INITIAL BINDING + + PUSH B,$TBIND + MOVEM B,SPBASE+1(C) ;SAVE AS BASE OF SP + MOVEM B,SPSTO+1(C) ;AND CURRENT THEREOF + MOVEM B,CURFCN+1(C) ; AND AS CURRENT FCN FOR SPEC/UNSPEC LOGIC + PUSH B,IMQUOTE THIS-PROCESS + PUSH B,$TPVP ;GIVE IT PROCESS AS VALUE + PUSH B,C + ADD B,[2,,2] ;FINISH FRAME + MOVEM B,TPSTO+1(C) ;MAKE THIS THE CURRENT STACK POINTER + MOVEM C,PVPSTO+1(C) ;SAVE THE NEW PVP ITSELF + MOVEM TVP,TVPSTO+1(C) ;AND THE GOOD OLD TRANSFER VECTOR + AOS A,IDPROC ;GOBBLE A UNIQUE PROCESS I.D. + MOVEM A,PROCID+1(C) ;SAVE THAT ALSO + AOS A,PTIME ; GET A UNIQUE BINDING ID + MOVEM A,BINDID+1(C) + + MOVSI A,TPVP ;CLOBBER THE TYPE + MOVE B,(TP) ;AND POINTER TO PROCESS + SUB TP,[2,,2] + POPJ P, + +;MINI ROUTINE TO CALL VECTOR WITH COUNT IN A + +IVECT: PUSH TP,$TFIX + PUSH TP,A + MCALL 1,VECTOR ;GOBBLE THE VECTOR + POPJ P, + + +;SUBROUTINE TO SWAP A PROCESS IN +;CALLED WITH JSP A,SWAP AND NEW PVP IN B + +SWAP: ;FIRST STORE ALL THE ACS + + IRP A,,[PVP,TVP,AB,TB,TP,SP,P,M,R] + MOVEM A,A!STO+1(PVP) + TERMIN + + SETOM 1(TP) ; FENCE POST MAIN STACK + MOVEM TP,TPSAV(TB) ; CORRECT FRAME + SETZM PSAV(TB) ; CLEAN UP CURRENT FRAME + SETZM SPSAV(TB) + SETZM PCSAV(TB) + + MOVE E,PVP ;RETURN OLD PROCESS IN E + MOVE PVP,D ;AND MAKE NEW ONE BE D + +SWAPIN: + ;NOW RESTORE NEW PROCESSES AC'S + + IRP A,,[PVP,TVP,AB,TB,TP,SP,P,M,R] + MOVE A,A!STO+1(PVP) + TERMIN + + JRST (C) ;AND RETURN + + + + +;SUBRS ASSOCIATED WITH TYPES + +;INTERNAL FUNCTION TO GET STRAGE ALLOCATION TYPE +;GETS THE TYPE CODE IN A AND RETURNS SAT IN A. + +SAT: LSH A,1 ;TIMES 2 TO REF VECTOR + HRLS A ;TO BOTH HALVES TO HACK AOBJN POINTER + ADD A,TYPVEC+1(TVP) ;ACCESS THE VECTOR + HRR A,(A) ;GET PROBABLE SAT + JUMPL A,.+2 ;DID WE REALLY HAVE A VALID TYPE + MOVEI A,0 ;NO RETURN 0 + ANDI A,SATMSK + POPJ P, ;AND RETURN + +;TYPE (ITYPE) ARE FUNCTIONS TO RETURN THE ATOMIC NAME OF THE +;TYPE OF A GOODIE. TYPE TAKES ITS ARGS ON AP AND RETURNS IN A AND B. +;ITYPE TAKES ITS ARGS IN A AND B AND RETURNS IN SAME (B=0) FOR INVALID +;TYPECODE. +MFUNCTION TYPE,SUBR + + ENTRY 1 + GETYP A,(AB) ;TYPE INTO A +TYPE1: PUSHJ P,ITYPE ;GO TO INTERNAL + JUMPN B,FINIS ;GOOD RETURN +TYPERR: PUSH TP,$TATOM ;SETUP ERROR CALL + PUSH TP,EQUOTE TYPE-UNDEFINED + JRST CALER1" ;STANDARD ERROR HACKER + +CITYPE: GETYP A,A ; GET TYPE FOR COMPILER CALL +ITYPE: LSH A,1 ;TIMES 2 + HRLS A ;TO BOTH SIDES + ADD A,TYPVEC+1(TVP) ;GET ACTUAL LOCATION + JUMPGE A,TYPERR ;LOST, TYPE OUT OF BOUNDS + MOVE B,1(A) ;PICKUP TYPE + HLLZ A,(A) + POPJ P, + +; PREDICATE -- IS OBJECT OF TYPE SPECIFIED + +MFUNCTION %TYPEQ,SUBR,[TYPE?] + + ENTRY + + MOVE D,AB ; GET ARGS + ADD D,[2,,2] + JUMPGE D,TFA + MOVE A,(AB) + HLRE C,D + MOVMS C + ASH C,-1 ; FUDGE + PUSHJ P,ITYPQ ; GO INTERNAL + JFCL + JRST FINIS + +ITYPQ: GETYP A,A ; OBJECT + PUSHJ P,ITYPE +TYPEQ0: SOJL C,CIFALS + GETYP 0,(D) + CAIE 0,TATOM ; Type name must be an atom + JRST WRONGT + CAMN B,1(D) ; Same as the OBJECT? + JRST CPOPJ1 ; Yes, return type name + ADD D,[2,,2] + JRST TYPEQ0 ; No, continue comparing + +CIFALS: MOVEI B,0 + MOVSI A,TFALSE + POPJ P, + +CTYPEQ: SOJE A,CIFALS ; TREAT NO ARGS AS FALSE + MOVEI D,1(A) ; FIND BASE OF ARGS + ASH D,1 + HRLI D,(D) + SUBM TP,D ; D POINTS TO BASE + MOVE E,D ; SAVE FOR TP RESTORE + ADD D,[3,,3] ; FUDGE + MOVEI C,(A) ; NUMBER OF TYPES + MOVE A,-2(D) + PUSHJ P,ITYPQ + JFCL ; IGNORE SKIP FOR NOW + MOVE TP,E ; SET TP BACK + JUMPL B,CPOPJ1 ; SKIP + POPJ P, + +; Entries to get type codes for types for fixing up RSUBRs and assembling + +MFUNCTION %TYPEC,SUBR,[TYPE-C] + + ENTRY + + JUMPGE AB,TFA + GETYP 0,(AB) + CAIE 0,TATOM + JRST WTYP1 + MOVE B,1(AB) + CAMGE AB,[-3,,0] ; skip if only type name given + JRST GTPTYP + MOVE C,MQUOTE ANY + +TYPEC1: PUSHJ P,CTYPEC ; go to internal + JRST FINIS + +GTPTYP: CAMGE AB,[-5,,0] + JRST TMA + GETYP 0,2(AB) + CAIE 0,TATOM + JRST WTYP2 + MOVE C,3(AB) + JRST TYPEC1 + +CTYPEC: PUSH P,C ; save primtype checker + PUSHJ P,TYPLOO ; search type vector + POP P,B + CAMN B,MQUOTE ANY + JRST CTPEC1 + PUSH P,D + HRRZ A,(A) + ANDI A,SATMSK + PUSH P,A + PUSHJ P,TYPLOO + HRRZ 0,(A) + ANDI 0,SATMSK + CAME 0,(P) + JRST TYPDIF + MOVE D,-1(P) + SUB P,[2,,2] +CTPEC1: MOVEI B,(D) + MOVSI A,TTYPEC + POPJ P, + +MFUNCTION %TYPEW,SUBR,[TYPE-W] + + ENTRY + + JUMPGE AB,TFA + GETYP 0,(AB) + CAIE 0,TATOM + JRST WTYP1 + MOVEI D,0 + MOVE C,MQUOTE ANY + MOVE B,1(AB) + CAMGE AB,[-3,,0] + JRST CTYPW1 + +CTYPW3: PUSHJ P,CTYPEW + JRST FINIS + +CTYPW1: GETYP 0,2(AB) + CAIE 0,TATOM + JRST WTYP2 + CAMGE AB,[-5,,0] ; JUMP IF RH IS GIVEN + JRST CTYPW2 + MOVE C,3(AB) + JRST CTYPW3 + +CTYPW2: CAMGE AB,[-7,,0] + JRST TMA + GETYP 0,4(AB) + CAIE 0,TFIX + JRST WRONGT + MOVE D,5(AB) + JRST CTYPW3 + +CTYPEW: PUSH P,D + PUSHJ P,CTYPEC ; GET CODE IN B + POP P,B + HRLI B,(D) + MOVSI A,TTYPEW + POPJ P, + +;PRIMTTYPE RETURNS THE TYPE ATOM OF A PRIMITIVE TYPE IN A CLASS + +STBL: REPEAT NUMSAT,MQUOTE INTERNAL-TYPE + +LOC STBL + +IRP A,,[[1WORD,WORD],[2WORD,LIST],[NWORD,UVECTOR],[2NWORD,VECTOR],[STORE,STORAGE] +[ARGS,TUPLE],[FRAME,FRAME],[ATOM,ATOM],[LOCID,LOCD],[CHSTR,STRING] +[PVP,PROCESS],[ASOC,ASOC],[LOCA,LOCA],[LOCS,LOCS],[LOCU,LOCU],[LOCV,LOCV] +[LOCL,LOCL],[LOCN,LOCAS],[LOCT,LOCT]] +IRP B,C,[A] +LOC STBL+S!B +MQUOTE C + +.ISTOP + +TERMIN +TERMIN + +LOC STBL+NUMSAT+1 + + +MFUNCTION TYPEPRIM,SUBR + + ENTRY 1 + GETYP A,(AB) + CAIE A,TATOM + JRST NOTATOM + MOVE B,1(AB) + PUSHJ P,CTYPEP + JRST FINIS + +CTYPEP: PUSHJ P,TYPLOO ; CONVERT ATOM TO CODE + HRRZ A,(A) ; SAT TO A + ANDI A,SATMSK + JRST PTYP1 + +MFUNCTION PRIMTYPE,SUBR + + ENTRY 1 + + MOVE A,(AB) ;GET TYPE + PUSHJ P,CPTYPE + JRST FINIS + +CPTYPE: GETYP A,A + PUSHJ P,SAT ;GET SAT +PTYP1: JUMPE A,TYPERR + MOVE B,MQUOTE TEMPLATE + CAIG A,NUMSAT ; IF BIG SAT, THEN TEMPLATE + MOVE B,@STBL(A) + MOVSI A,TATOM + POPJ P, + + +; RSUBR MAKES A VECTOR INTO AN OBJECT OF TYPE RSUBR, ALSO SLIGHTLY MUNGING IT + +MFUNCTION RSUBR,SUBR + ENTRY 1 + + GETYP A,(AB) + CAIE A,TVEC ; MUST BE VECTOR + JRST WTYP1 + MOVE B,1(AB) ; GET IT + GETYP A,(B) ; CHECK 1ST ELEMENTS TYPE + CAIN A,TPCODE ; PURE CODE + JRST .+3 + CAIE A,TCODE + JRST NRSUBR + HLRM B,(B) ; CLOBEER SPECIAL COUNT FIELD + MOVSI A,TRSUBR + JRST FINIS + +NRSUBR: PUSH TP,$TATOM + PUSH TP,EQUOTE FIRST-ELEMENT-OF-VECTOR-NOT-CODE + JRST CALER1 + +; ROUTINE TO GENERATE ENTRYY OTHER THAN FIRST TO RSUBRR + +MFUNCTION MENTRY,SUBR,[RSUBR-ENTRY] + + ENTRY 2 + + GETYP 0,(AB) ; TYPE OF ARG + CAIE 0,TVEC ; BETTER BE VECTOR + JRST WTYP1 + GETYP 0,2(AB) + CAIE 0,TFIX + JRST WTYP2 + MOVE B,1(AB) ; GET VECTOR + CAML B,[-3,,0] + JRST BENTRY + GETYP 0,(B) ; FIRST ELEMENT + CAIE 0,TRSUBR + JRST MENTR1 +MENTR2: GETYP 0,2(B) + CAIE 0,TATOM + JRST BENTRY + MOVE C,3(AB) + HRRM C,2(B) ; OFFSET INTO VECTOR + HLRM B,(B) + MOVSI A,TENTER + JRST FINIS + +MENTR1: CAIE 0,TATOM + JRST BENTRY + MOVE B,1(B) ; GET ATOM + PUSHJ P,IGVAL ; GET VAL + GETYP 0,A + CAIE 0,TRSUBR + JRST BENTRY + MOVE B,1(AB) ; RESTORE B + JRST MENTR2 + +BENTRY: PUSH TP,$TATOM + PUSH TP,EQUOTE BAD-VECTOR + JRST CALER1 + +; SUBR TO GET ENTRIES OFFSET + +MFUNCTION LENTRY,SUBR,[ENTRY-LOC] + + ENTRY 1 + + GETYP 0,(AB) + CAIE 0,TENTER + JRST WTYP1 + MOVE B,1(AB) + HRRZ B,2(B) + MOVSI A,TFIX + JRST FINIS + +; RETURN FALSE + +RTFALS: MOVSI A,TFALSE + MOVEI B,0 + POPJ P, + +;SUBROUTINE CALL FOR RSUBRs +RCALL: SUBM M,(P) ;CALCULATE PC's OFFSET IN THE RSUBR + PUSHJ P,@0 ;GO TO THE PROPER SUBROUTINE + SUBM M,(P) ;RECONSTITUTE THE RSUBR's PC + POPJ P, + + +; ERRORS IN COMPILED CODE MAY END UP HERE + +COMPERR: + PUSH TP,$TATOM + PUSH TP,EQUOTE ERROR-IN-COMPILED-CODE + JRST CALER1 + + +;CHTYPE TAKES TWO ARGUMENTS. ANY GOODIE AND A AN ATOMIC TYPE NAME +;IT CHECKS THE STORAGE ALLOCATION TYPES OF THE TWO ARE THE SAME AND +;IF THEY ARE CHANGES THE TYPE OF THE FIRST TO THAT NAME D IN THE SECOND + +MFUNCTION CHTYPE,SUBR + + ENTRY 2 + GETYP A,2(AB) ;FIRST CHECK THAT ARG 2 IS AN ATOM + CAIE A,TATOM + JRST NOTATOM + MOVE B,3(AB) ;AND TYPE NAME + PUSHJ P,TYPLOO ;GO LOOKUP TYPE +TFOUND: HRRZ B,(A) ;GOBBLE THE SAT + TRNE B,CHBIT ; SKIP IF CHTYPABLE + JRST CANTCH + TRNE B,TMPLBT ; TEMPLAT + HRLI B,-1 + AND B,[-1,,SATMSK] + GETYP A,(AB) ;NOW GET TYPE TO HACK + PUSHJ P,SAT ;FIND OUT ITS SAT + JUMPE A,TYPERR ;COMPLAIN + CAILE A,NUMSAT + JRST CHTMPL ; JUMP IF TEMPLATE DATA + CAIE A,(B) ;DO THEY AGREE? + JRST TYPDIF ;NO, COMPLAIN +CHTMP1: MOVSI A,(D) ;GET NEW TYPE + HRR A,(AB) ; FOR DEFERRED GOODIES + JUMPL B,CHMATC ; CHECK IT + MOVE B,1(AB) ;AND VALUE + JRST FINIS + +CHTMPL: MOVE E,1(AB) ; GET ARG + HLRZ A,(E) + ANDI A,SATMSK + MOVE 0,3(AB) ; SEE IF TO "TEMPLATE" + CAME 0,MQUOTE TEMPLATE + CAIN A,(B) + JRST CHTMP1 + JRST TYPDIF + +CHMATC: PUSH TP,A + PUSH TP,1(AB) ; SAVE GOODIE + MOVSI A,TATOM + MOVE B,3(AB) + MOVSI C,TATOM + MOVE D,MQUOTE DECL + PUSHJ P,IGET ; FIND THE DECL + MOVE C,(AB) + MOVE D,1(AB) ; NOW GGO TO MATCH + PUSHJ P,TMATCH + JRST TMPLVIO + POP TP,B + POP TP,A + JRST FINIS + +TYPLOO: PUSHJ P,TYPFND + JRST .+2 + POPJ P, + PUSH TP,$TATOM ;LOST, GENERATE ERROR + PUSH TP,EQUOTE BAD-TYPE-NAME + JRST CALER1 + +TYPFND: MOVE A,TYPVEC+1(TVP) ;GOBBLE DOWN TYPE VECTOR + MOVEI D,0 ;INITIALIZE TYPE COUNTER +TLOOK: CAMN B,1(A) ;CHECK THIS ONE + JRST CPOPJ1 + ADDI D,1 ;BUMP COUNTER + AOBJP A,.+2 ;COUTN DOWN ON VECTOR + AOBJN A,TLOOK + POPJ P, +CPOPJ1: AOS (P) + POPJ P, + +TYPDIF: PUSH TP,$TATOM ;MAKE ERROR MESSAGE + PUSH TP,EQUOTE STORAGE-TYPES-DIFFER + JRST CALER1 + + +TMPLVI: PUSH TP,$TATOM + PUSH TP,EQUOTE DECL-VIOLATION + JRST CALER1 + + +; FUNCTION TO ADD A NEW TYPE TO THE WORLD WITH GIVEN PRIMITIVE TYPE + +MFUNCTION NEWTYPE,SUBR + + ENTRY + + HLRZ 0,AB ; CHEC # OF ARGS + CAILE 0,-4 ; AT LEAST 2 + JRST TFA + CAIGE 0,-6 + JRST TMA ; NOT MORE THAN 3 + GETYP A,(AB) ; GET 1ST ARGS TYPE (SHOULD BE ATOM) + GETYP C,2(AB) ; SAME WITH SECOND + CAIN A,TATOM ; CHECK + CAIE C,TATOM + JRST NOTATOM + + MOVE B,3(AB) ; GET PRIM TYPE NAME + PUSHJ P,TYPLOO ; LOOK IT UP + HRRZ A,(A) ; GOBBLE SAT + HRLI A,TATOM ; MAKE NEW TYPE + PUSH P,A ; AND SAVE + MOVE B,1(AB) ; SEE IF PREV EXISTED + PUSHJ P,TYPFND + JRST NEWTOK ; DID NOT EXIST BEFORE + MOVEI B,2(A) ; FOR POSSIBLE TMPLAT BIT + HRRZ A,(A) ; GET SAT + HRRZ 0,(P) ; AND PROPOSED + ANDI 0,SATMSK + ANDI A,SATMSK + CAIN 0,(A) ; SKIP IF LOSER + JRST NEWTFN ; O.K. + + PUSH TP,$TATOM + PUSH TP,EQUOTE TYPE-ALREADY-EXISTS + JRST CALER1 + +NEWTOK: POP P,A + MOVE B,1(AB) ; NEWTYPE NAME + PUSHJ P,INSNT ; MUNG IN NEW TYPE + +NEWTFN: CAML AB,[-5,,] ; SKIP IF TEMPLAT SUPPLIED + JRST NEWTF1 + MOVEI 0,TMPLBT ; GET THE BIT + IORM 0,-2(B) ; INTO WORD + MOVE A,(AB) ; GET TYPE NAME + MOVE B,1(AB) + MOVSI C,TATOM + MOVE D,MQUOTE DECL + PUSH TP,4(AB) ; GET TEMLAT + PUSH TP,5(AB) + PUSHJ P,IPUT +NEWTF1: MOVE A,(AB) + MOVE B,1(AB) ; RETURN NAME + JRST FINIS + +; SET UP GROWTH FIELDS + +IGROWT: SKIPA A,[111100,,(C)] +IGROWB: MOVE A,[001100,,(C)] + HLRE B,C + SUB C,B ; POINT TO DOPE WORD + MOVE B,TYPIC ; INDICATED GROW BLOCK + DPB B,A + POPJ P, + +INSNT: PUSH TP,A + PUSH TP,B ; SAVE NAME OF NEWTYPE + MOVE C,TYPBOT+1(TVP) ; CHECK GROWTH NEED + CAMGE C,TYPVEC+1(TVP) + JRST ADDIT ; STILL ROOM +GAGN: PUSHJ P,IGROWB ; SETUP BOTTOM GROWTH + SKIPE C,EVATYP+1(TVP) + PUSHJ P,IGROWT ; SET UP TOP GROWTH + SKIPE C,APLTYP+1(TVP) + PUSHJ P,IGROWT + MOVE C,[11.,,5] ; SET UP INDICATOR FOR AGC + PUSHJ P,AGC ; GROW THE WORLD + AOJL A,GAGN ; BAD AGC LOSSAGE + MOVE 0,[-101,,-100] + ADDM 0,TYPBOT+1(TVP) ; FIX UP POINTER + +ADDIT: MOVE C,TYPVEC+1(TVP) + SUB C,[2,,2] ; ALLOCATE ROOM + MOVEM C,TYPVEC+1(TVP) + HLRE B,C ; PREPARE TO BLT + SUBM C,B ; C POINTS DOPE WORD END + HRLI C,2(C) ; GET BLT AC READY + BLT C,-3(B) + POP TP,-1(B) ; CLOBBER IT IN + POP TP,-2(B) + POPJ P, + + +; Interface to interpreter for setting up tables associated with +; template data structures. +; A/ <-name of type>- +; B/ <-length ins>- +; C/ <-uvector of length code or 0> +; D/ <-uvector of GETTERs>- +; E/ <-uvector of PUTTERs>- + +CTMPLT: SUBM M,(P) ; could possibly gc during this stuff + SKIPE C ; for now dont handle vector of length ins + FATAL TEMPLATE DATA WITH COMPUTED LENGTH + PUSH TP,$TATOM ; save name of type + PUSH TP,A + PUSH P,B ; save length instr + HLRE A,TD.LNT+1(TVP) ; check for template slots left? + HRRZ B,TD.LNT+1(TVP) + SUB B,A ; point to dope words + HLRZ B,1(B) ; get real length + ADDM B,A ; any room? + JUMPG A,GOODRM ; jump if ok + + PUSH TP,$TUVEC ; save getters and putters + PUSH TP,D + PUSH TP,$TUVEC + PUSH TP,E + MOVEI A,6(B) ; grow it 10 by copying + PUSH P,A ; save new length + PUSHJ P,CAFRE1 ; get frozen uvector + ADD B,[10,,10] ; rest it down some + HRL C,TD.LNT+1(TVP) ; prepare to BLT in + MOVEM B,TD.LNT+1(TVP) ; and save as new length vector + HRRI C,(B) ; destination + ADD B,(P) ; final destination address + BLT C,-13(B) + MOVE A,(P) ; length for new getters + PUSHJ P,CAFRE1 + MOVE C,TD.GET+1(TVP) ; get old for copy + MOVEM B,TD.GET+1(TVP) + HRRI C,(B) + ADD B,(P) + BLT C,-13(B) ; zap those guys in + MOVE A,(P) ; finally putters + PUSHJ P,CAFRE1 + MOVE C,TD.PUT+1(TVP) + MOVEM B,TD.PUT+1(TVP) + HRRI C,(B) ; BLT pointer + ADD B,(P) + BLT C,-13(B) + SUB P,[1,,1] ; flush stack craft + MOVE E,(TP) + MOVE D,-2(TP) + SUB TP,[4,,4] + +GOODRM: MOVE B,TD.LNT+1(TVP) ; move down to fit new guy + SUB B,[1,,1] ; will always win due to prev checks + MOVEM B,TD.LNT+1(TVP) + HRLI B,1(B) + HLRE A,TD.LNT+1(TVP) + MOVNS A + ADDI A,-1(B) ; A/ final destination + BLT B,-1(A) + POP P,(A) ; new length ins munged in + HLRE A,TD.LNT+1(TVP) + MOVNS A ; A/ offset for other guys + PUSH P,A ; save it + ADD A,TD.GET+1(TVP) ; point for storing uvs of ins + MOVEM D,-1(A) + MOVE A,(P) + ADD A,TD.PUT+1(TVP) + MOVEM E,-1(A) ; store putter also + POP P,A ; compute primtype + ADDI A,NUMSAT + HRLI A,TATOM + MOVE B,(TP) ; ready to mung type vector + SUB TP,[2,,2] + PUSHJ P,INSNT ; insert into vector + JRST MPOPJ + + +; FUNCTIONS TO SET UP EVALUATION AND APPLICATION RULES FOR DATA TYPES + +MFUNCTION EVALTYPE,SUBR + + ENTRY 2 + + PUSHJ P,CHKARG ; VERIFY WINNAGE IN ARGS + MOVEI A,EVATYP ; POINT TO TABLE + MOVEI E,EVTYPE ; POINT TO PURE VERSION +TBLCAL: PUSHJ P,TBLSET ; SETUP TABLE ENTRY + JRST FINIS + +MFUNCTION APPLYTYPE,SUBR + + ENTRY 2 + + PUSHJ P,CHKARG + MOVEI A,APLTYP ; POINT TO APPLY TABLE + MOVEI E,APTYPE ; PURE TABLE + JRST TBLCAL + + +MFUNCTION PRINTTYPE,SUBR + + ENTRY 2 + + PUSHJ P,CHKARG + MOVEI A,PRNTYP ; POINT TO APPLY TABLE + MOVEI E,PRTYPE ; PURE TABLE + JRST TBLCAL + +; CHECK ARGS AND SETUP FOR TABLE HACKER + +CHKARG: GETYP A,(AB) ; 1ST MUST BE TYPE NAME + CAIE A,TATOM + JRST WTYP1 + MOVE B,1(AB) ; GET ATOM + PUSHJ P,TYPLOO ; VERIFY THAT IT IS A TYPE + PUSH P,D ; SAVE TYPE NO. + HRRZ A,(A) ; GET SAT + ANDI A,SATMSK + PUSH P,A + GETYP A,2(AB) ; GET 2D TYPE + CAIE A,TATOM ; EITHER TYPE OR APPLICABLE + JRST TRYAPL ; TRY APPLICABLE + MOVE B,3(AB) ; VERIFY IT IS A TYPE + PUSHJ P,TYPLOO + HRRZ A,(A) ; GET SAT + ANDI A,SATMSK + POP P,C ; RESTORE SAVED SAT + CAIE A,(C) ; SKIP IF A WINNER + JRST TYPDIF ; REPORT ERROR + POP P,C ; GET SAVED TYPE + MOVEI B,0 ; TELL THAT WE ARE A TYPE + POPJ P, + +TRYAPL: PUSHJ P,APLQ ; IS THIS APPLICABLE + JRST NAPT + SUB P,[1,,1] + MOVE B,2(AB) ; RETURN SAME + MOVE D,3(AB) + POP P,C + POPJ P, + + +; HERE TO PUT ENTRY IN APPROPRIATE TABLE + +TBLSET: HRLI A,(A) ; FOR TVP HACKING + ADD A,TVP ; POINT TO TVP SLOT + PUSH TP,B + PUSH TP,D ; SAVE VALUE + PUSH TP,$TVEC + PUSH TP,A + PUSH P,C ; SAVE TYPE BEING HACKED + PUSH P,E + SKIPE B,1(A) ; SKIP IF VECTOR DOESN'T EXIST YET + JRST TBL.OK + HLRE A,TYPBOT+1(TVP) ; GET CURRENT TABLE LNTH + MOVNS A + ASH A,-1 + PUSHJ P,IVECT ; GET VECTOR + MOVE C,(TP) ; POINT TO RETURN POINT + MOVEM B,1(C) ; SAVE VECTOR + +TBL.OK: POP P,E + POP P,C ; RESTORE TYPE + SUB TP,[2,,2] + POP TP,D + POP TP,A + JUMPN A,TBLOK1 ; JUMP IF FUNCTION ETC. SUPPLIED + CAILE D,NUMPRI ; SKIP IF ORIGINAL TYPE + MOVNI E,(D) ; CAUSE E TO ENDUP 0 + ADDI E,(D) ; POINT TO PURE SLOT +TBLOK1: ADDI C,(C) ; POINT TO VECTOR SLOT + ADDI C,(B) + JUMPN A,OK.SET ; OK TO CLOBBER + ADDI B,(D) ; POINT TO TARGET TYPE'S SLOT + ADDI B,(D) ; POINT TO TARGET TYPE'S SLOT + SKIPN A,(B) ; SKIP IF WINNER + SKIPE 1(B) ; SKIP IF LOSER + SKIPA D,1(B) ; SETUP D + JRST CH.PTB ; CHECK PURE TABLE + +OK.SET: MOVEM A,(C) ; STORE + MOVEM D,1(C) + MOVE A,(AB) ; RET TYPE + MOVE B,1(AB) + JRST FINIS + +CH.PTB: MOVEI A,0 + MOVE D,[SETZ NAPT] + JUMPE E,OK.SET + MOVE D,(E) + JRST OK.SET + +CALLTY: MOVE A,TYPVEC(TVP) + MOVE B,TYPVEC+1(TVP) + POPJ P, + +MFUNCTION ALLTYPES,SUBR + + ENTRY 0 + + MOVE A,TYPVEC(TVP) + MOVE B,TYPVEC+1(TVP) + JRST FINIS + +; + +;FUNCTION TO RETURN TYPE OF ELEMENTS IN A UVECTOR + +MFUNCTION UTYPE,SUBR + + ENTRY 1 + + GETYP A,(AB) ;GET U VECTOR + PUSHJ P,SAT + CAIE A,SNWORD + JRST WTYP1 + MOVE B,1(AB) ; GET UVECTOR + PUSHJ P,CUTYPE + JRST FINIS + +CUTYPE: HLRE A,B ;GET -LENGTH + HRRZS B + SUB B,A ;POINT TO TYPE WORD + GETYP A,(B) + JRST ITYPE ; GET NAME OF TYPE + +; FUNCTION TO CHANGE UNIFORM TYPE OF A VECTOR + +MFUNCTION CHUTYPE,SUBR + + ENTRY 2 + + GETYP A,2(AB) ;GET 2D TYPE + CAIE A,TATOM + JRST NOTATO + GETYP A,(AB) ; CALL WITH UVECTOR? + PUSHJ P,SAT + CAIE A,SNWORD + JRST WTYP1 + MOVE A,1(AB) ; GET UV POINTER + MOVE B,3(AB) ;GET ATOM + PUSHJ P,CCHUTY + MOVE A,(AB) ; RETURN UVECTOR + MOVE B,1(AB) + JRST FINIS + +CCHUTY: PUSH TP,$TUVEC + PUSH TP,A + PUSHJ P,TYPLOO ;LOOK IT UP + HRRZ B,(A) ;GET SAT + TRNE B,CHBIT + JRST CANTCH + ANDI B,SATMSK + HLRE C,(TP) ;-LENGTH + HRRZ E,(TP) + SUB E,C ;POINT TO TYPE + GETYP A,(E) ;GET TYPE + JUMPE A,WIN0 ;ALLOW TYPE "LOSE" TO CHANGE TO ANYTHING + PUSHJ P,SAT ;GET SAT + JUMPE A,TYPERR + CAIE A,(B) ;COMPARE + JRST TYPDIF +WIN0: HRLM D,(E) ;CLOBBER NEW ONE + POP TP,B + POP TP,A + POPJ P, + +CANTCH: PUSH TP,$TATOM + PUSH TP,EQUOTE CANT-CHTYPE-INTO + PUSH TP,2(AB) + PUSH TP,3(AB) + MOVEI A,2 + JRST CALER + +NOTATOM: + PUSH TP,$TATOM + PUSH TP,EQUOTE NON-ATOMIC-ARGUMENT + PUSH TP,(AB) + PUSH TP,1(AB) + MOVEI A,2 + JRST CALER + + + +; SUBROUTINE TO LEAVE MUDDLE CLOSING ALL CHANNELS ON THE WAY + +MFUNCTION QUIT,SUBR + + ENTRY 0 + + + PUSHJ P,CLOSAL ; DO THE CLOSES + PUSHJ P,%KILLM + JRST IFALSE ; JUST IN CASE + +CLOSAL: MOVE B,TVP ; POINT TO XFER VECCTOR + ADD B,[CHNL0+2,,CHNL0+2] ; POINT TO 1ST (NOT INCLUDING TTY I/O) + PUSH TP,$TVEC + PUSH TP,B + PUSH P,[N.CHNS-1] ; MAX NO. OF CHANS + +CLOSA1: MOVE B,(TP) + ADD B,[2,,2] + MOVEM B,(TP) + SKIPN C,-1(B) ; THIS ONE OPEN? + JRST CLOSA4 ; NO + CAME C,TTICHN+1(TVP) + CAMN C,TTOCHN+1(TVP) + JRST CLOSA4 + PUSH TP,-2(B) ; PUSH IT + PUSH TP,-1(B) + MCALL 1,FCLOSE ; CLOSE IT +CLOSA4: SOSLE (P) ; COUNT DOWN + JRST CLOSA1 + + + SUB TP,[2,,2] + SUB P,[1,,1] + +CLOSA3: SKIPN B,CHNL0+1(TVP) + POPJ P, + PUSH TP,(B) + HLLZS (TP) + PUSH TP,1(B) + HRRZ B,(B) + MOVEM B,CHNL0+1(TVP) + MCALL 1,FCLOSE + JRST CLOSA3 + +; LITTLE ROUTINES USED ALL OVER THE PLACE + +CRLF: MOVEI A,15 + PUSHJ P,MTYO + MOVEI A,12 + JRST MTYO +MSGTYP: HRLI B,440700 ;MAKE BYTE POINTER +MSGTY1: ILDB A,B ;GET NEXT CHARACTER + JUMPE A,CPOPJ ;NULL ENDS STRING + CAIE A,177 ; DONT PRINT RUBOUTS + PUSHJ P,MTYO" + JRST MSGTY1 ;AND GET NEXT CHARACTER +CPOPJ: POPJ P, + +IMPURE + +WHOAMI: 0 ; SYAYS WHETHER I AM REALLY A MUDDLE OR SOME HACK + + +;GARBAGE COLLECTORS PDLS + + +GCPDL: -GCPLNT,,GCPDL + + BLOCK GCPLNT + + +PURE + +MUDSTR: ASCII /MUDDLE / +STRNG: -1 + -1 + -1 + ASCIZ / IN OPERATION./ + +;MARKED PDLS FOR GC PROCESS + +VECTGO +; DUMMY FRAME FOR INITIALIZER CALLS + + TENTRY,,LISTEN + 0 + .-3 + 0 + 0 + -ITPLNT,,TPBAS-1 + 0 + +TPBAS: BLOCK ITPLNT+PDLBUF + GENERAL + ITPLNT+2+PDLBUF+7,,0 + + +VECRET + + + + +$TMATO: TATOM,,-1 + + +PATCH: +PAT: BLOCK 100 +PATEND: 0 + +END + diff --git a/sumex/mappur.mcr078 b/sumex/mappur.mcr078 new file mode 100644 index 0000000..c7ef58b --- /dev/null +++ b/sumex/mappur.mcr078 @@ -0,0 +1,936 @@ +TITLE PURE-PAGE LOADER + +RELOCATABLE + +MAPCH==0 ; channel for MAPing +ELN==3 ; Length of table entry + +.GLOBAL PURVEC,PURTOP,PURBOT,P.TOP,MUDSTR,STRTO6,PLOAD,AGC,GCDOWN +.GLOBAL SQUTOA,IGVAL,IBLOCK,PURCLN,MOVPUR,GETPAG,GCFLG,NOSHUF + +.INSRT MUDDLE > + +SYSQ + +IFE ITS,[ +IF1, .INSRT STENEX > +] + +IFN ITS,[ +PURDIR==SIXBIT /MUD50/ ; directory containing pure pages +OPURDI==SIXBIT /MHILIB/ +OFIXDI==SIXBIT /MHILIB/ +FIXDIR==SIXBIT /MUD50/ +ARC==1 ; flag saying fixups on archive +] +IFN ITS,[ +PGMSK==1777 +PGSHFT==10. +] +IFE ITS,[ +PGMSK==777 +PGSHFT==9. +] + +; This routine taskes a slot offset in register A and +; maps in the associated file. It clobbers all ACs +; It skip returns if it wins. + +PLOAD: PUSH P,A ; save slot offset + ADD A,PURVEC+1(TVP) ; point into pure vector + MOVE B,(A) ; get sixbit of name +IFN ITS,[ + MOVE C,MUDSTR+2 ; get version number + PUSHJ P,CSIXBT ; vers # to six bit + HRRI C,(SIXBIT /SAV/) + MOVSS C + .SUSET [.RSNAM,,0] ; GET CURRENT SNAME TO 0 + .SUSET [.SSNAM,,[PURDIR]] ; get sname for it + MOVE A,[SIXBIT / &DSK/] ; build open block + .OPEN MAPCH,A ; try to open file + JRST FIXITU ; no current version, fix one up + PUSH P,0 ; for compat wit tenex and save old sname + DOTCAL FILLEN,[[1000,,MAPCH],[2000,,A]] + JRST MAPLOS + ADDI A,PGMSK ; in case not even # of pages + ASH A,-PGSHFT ; to pages + PUSH P,A ; save the length +] +IFE ITS,[ + MOVE E,P ; save pdl base + PUSH P,[0] ; slots for building strings + PUSH P,[0] + MOVE A,[440700,,1(E)] + MOVE C,[440600,,B] + MOVEI D,6 + ILDB 0,C + JUMPE 0,.+4 ; violate cardinal ".+ rule" + ADDI 0,40 ; to ASCII + IDPB 0,A + SOJG D,.-4 + + PUSH P,[ASCII / SAV/] + MOVE C,MUDSTR+2 ; get ascii of vers no. + IORI C,1 ; hair to change r.o. to space + MOVE 0,C + ADDI C,1 + ANDCM C,0 ; C has 1st 1 + JFFO C,.+3 + MOVEI 0,0 ; use zer name + JRST ZER... + MOVEI C,(D) + IDIVI C,7 + AND 0,MSKS(C) ; get rid of r.o.s +ZER...: PUSH P,0 + MOVEI B,-1(P) ; point to it + HRLI B,260700 + HRROI D,1(E) ; point to name + MOVEI A,1(P) + + PUSH P,[100000,,] + PUSH P,[377777,,377777] + PUSH P,[-1,,[ASCIZ /DSK/]] + PUSH P,[-1,,[ASCIZ /MUDLIB/]] + PUSH P,D + PUSH P,B + PUSH P,[0] + PUSH P,[0] + PUSH P,[0] + MOVEI B,0 + MOVE D,4(E) ; save final version string + GTJFN + JRST FIXITU + + MOVE B,[440000,,240000] + OPENF + JRST FIXITU + MOVE P,E ; flush crap + PUSH P,A + SIZEF ; get length + JRST MAPLOS + PUSH P,C ; save # of pages + MOVEI A,(C) +] + PUSHJ P,ALOPAG ; get the necessary pages + JRST MAPLS1 + PUSH P,B ; save page number +IFN ITS,[ + MOVN A,-1(P) ; get neg count + MOVSI A,(A) ; build aobjn pointer + HRR A,(P) ; get page to start + MOVE B,A ; save for later + HLLZ 0,A ; page pointer for file + DOTCAL CORBLK,[[1000,,200000],[1000,,-1],A,[1000,,MAPCH],0] + JRST MAPLS3 ; total wipe out + .CLOSE MAPCH, ; no need to have file open anymore +] +IFE ITS,[ + MOVE D,-1(P) ; # of pages to D + HRLI B,400000 ; specify this fork + HRROI E,(B) ; build page aobjn for later + TLC E,-1(D) ; sexy way of doing lh + HRLZ A,-2(P) ; JFN to lh of A + MOVSI C,120000 ; bits for read/execute + + PMAP + ADDI A,1 + ADDI B,1 + SOJG D,.-3 ; map 'em all + MOVE A,-2(P) + CLOSF ; try to close file + JFCL ; ignore failure + MOVE B,E +] + +; now try to smash slot in PURVEC + +PLOAD1: MOVE A,PURVEC+1(TVP) ; get pointer to it + ASH B,PGSHFT ; convert to aobjn pointer to words + MOVE C,-3(P) ; get slot offset + ADDI C,(A) ; point to slot + MOVEM B,1(C) ; clobber it in + ANDI B,-1 ; isolate address of page + HRRZ D,PURVEC(TVP) ; get offset into vector for start of chain + TRNE D,400000 ; skip if not end marker + JRST SCHAIN + HRLI D,A ; set up indexed pointer + ADDI D,1 + HRRZ 0,@D ; get its address + JUMPE 0,SCHAIN ; no chain exists, start one + CAILE 0,(B) ; skip if new one should be first + AOJA D,INLOOP ; jump into the loop + + SUBI D,1 ; undo ADDI +FCLOB: MOVE E,-3(P) ; get offset for this guy + HRRM D,2(C) ; link up + HRRM E,PURVEC(TVP) ; store him away + JRST PLOADD + +SCHAIN: MOVEI D,400000 ; get end of chain indicator + JRST FCLOB ; and clobber it in + +INLOOP: MOVE E,D ; save in case of later link up + HRR D,@D ; point to next table entry + TRNE D,400000 ; 400000 is the end of chain bit + JRST SLFOUN ; found a slot, leave loop + ADDI D,1 ; point to address of progs + HRRZ 0,@D ; get address of block + CAILE 0,(B) ; skip if still haven't fit it in + AOJA D,INLOOP ; back to loop start and point to chain link + SUBI D,1 ; point back to start of slot + +SLFOUN: MOVE 0,-3(P) ; get offset into vector of this guy + HRRM 0,@E ; make previous point to us + HRRM D,2(C) ; link it in + + +PLOADD: AOS -4(P) ; skip return + +MAPLS3: SUB P,[1,,1] ; flush stack crap +MAPLS1: SUB P,[1,,1] +MAPLOS: +IFN ITS,[ + MOVE 0,(P) + .SUSET [.SSNAM,,0] ; restore SNAME +] + SUB P,[2,,2] + POPJ P, + +; Here if no current version exists + +FIXITU: PUSH TP,$TFIX + PUSH TP,0 ; maybe save sname + +IFN ITS,[ + PUSH P,C ; save final name + MOVE C,[SIXBIT /FIXUP/] ; name of fixup file +IFN ,.SUSET [.SSNAM,,[OFIXDI]] +IFN ARC, HRRI A,(SIXBIT /ARC/) + .OPEN MAPCH,A +IFE ARC, JRST MAPLOS +IFN ARC, PUSHJ P,ARCLOS + MOVE 0,[-2,,A] ; prepare to read version and length + PUSH P,B ; save program name + .IOT MAPCH,0 + SKIPGE 0 + FATAL BAD FIXUP FILE + PUSH P,B ; save version number of fixup file + MOVEI A,-2(A) ; length -2 (for vers and length) + PUSHJ P,IBLOCK ; get a UVECTOR for the fixups + PUSH TP,$TUVEC ; and save + PUSH TP,B + MOVE A,B + MOVSI 0,TUVEC + MOVEM 0,ASTO(PVP) ; prepare for moby iot (interruptable) + ENABLE + .IOT MAPCH,A ; get fixups + DISABLE + .CLOSE MAPCH, + SETZM ASTO(PVP) + POP P,A ; restore version number + IDIVI A,100. ; get 100s digit in a rest in B + ADDI A,20 ; convert to sixbit + IDIVI B,10. ; B tens digit C 1s digit + ADDI B,20 + ADDI C,20 + MOVE 0,[220600,,D] + MOVSI D,(SIXBIT /SAV/) + CAIE A,20 + IDPB A,0 + CAIE B,20 + IDPB B,0 + IDPB C,0 + MOVE B,[SIXBIT / &DSK/] + MOVE C,(P) ; program name +IFN ,.SUSET [.SSNAM,,[OPURDI]] + .OPEN MAPCH,B ; try for this one + JRST MAPLS1 + DOTCAL FILLEN,[[1000,,MAPCH],[2000,,A]] + JRST MAPLS1 + ADDI A,PGMSK ; in case not exact pages + ASH A,-PGSHFT ; to pages + PUSH P,A ; save + PUSHJ P,ALOPAG ; find some pages + JRST MAPLS4 + MOVN A,(P) ; build aobjn pointer + MOVSI A,(A) + HRRI A,(B) + MOVE B,A + HLLZ 0,B + DOTCAL CORBLK,[[1000,,104000],[1000,,-1],A,[1000,,MAPCH],0] + JRST MAPLS4 + SUB P,[1,,1] + .CLOSE MAPCH, +] +IFE ITS,[ + PUSH TP,$TPDL ; save stack pointer + PUSH TP,E + PUSH P,D ; save vers string + HRROI A,[ASCIZ /FIXUP/] + MOVEM A,10.(E) ; into name slot + MOVEI A,5(E) ; point to arg block + SETZB B,C + GTJFN + JRST MAPLS4 + MOVEI C,(A) ; save JFN in case OPNEF loses + MOVE B,[440000,,200000] + OPENF + JRST MAPLS4 + BIN ; length of fixups to B + PUSH P,A ; save JFN + MOVEI A,-2(B) ; length of uvextor to get + PUSHJ P,IBLOCK + PUSH TP,$TUVEC + PUSH TP,B ; sav it + POP P,A ; restore JFN + BIN ; read in vers # + MOVE D,B ; save vers # + MOVE B,(TP) + HLRE C,B + HRLI B,444400 + SIN ; read in entire fixups + CLOSF ; and close file of same + JFCL ; ignore cailure to close + HRROI C,1(E) ; point to name + MOVEM C,9.(E) + MOVEI C,3(E) + HRLI C,260700 + MOVEM C,10.(E) + MOVE 0,[ASCII / /] + MOVEM 0,4(E) ; all spaces + MOVEI A,(D) + IDIVI A,100. ; to ascii + ADDI A,60 + IDIVI B,10. + ADDI B,60 + ADDI C,60 + MOVE 0,[440700,,4(E)] + CAIE A,60 + IDPB A,0 + CAIE B,60 + IDPB B,0 + IDPB C,0 + SETZB C,B + MOVEI A,5(E) ; ready for 'nother GTJFN + GTJFN + JRST MAPLS5 + MOVEI C,(A) ; save JFN in case OPENF loses + MOVE B,[440000,,240000] + OPENF + JRST MAPLS5 + SIZEF + JRST MAPLS5 + PUSH P,A + PUSH P,C + MOVEI A,(C) + PUSHJ P,ALOPAG ; get the pages + JRST MAPLS5 + MOVEI D,(B) ; save pointer + MOVN A,(P) ; build page aobjn pntr + HRLI D,(A) + EXCH D,(P) ; get length + HRLI B,400000 + + HRLZ A,-1(P) ; JFN for PMAP + MOVSI C,120400 ; bits for read/execute/copy-on-write + + PMAP + ADDI A,1 + ADDI B,1 + SOJG D,.-3 + + HLRZS A + CLOSF + JFCL + POP P,B ; restore page # + SUB P,[1,,1] +] +; now to do fixups + + MOVE A,(TP) ; pointer to them + ASH B,PGSHFT ; aobjn to program + +FIX1: SKIPL E,(A) ; read one hopefully squoze + FATAL ATTEMPT TO TYPE FIX PURE + TLZ E,740000 + PUSHJ P,SQUTOA ; look it up + FATAL BAD FIXUPS + + AOBJP A,FIX2 + HLRZ D,(A) ; get old value + SUBM E,D ; D is diff between old and new + HRLM E,(A) ; fixup the fixups + MOVEI 0,0 ; flag for which half +FIX4: JUMPE 0,FIXRH ; jump if getting rh + MOVEI 0,0 ; next time will get rh + AOBJP A,FIX2 ; done? + HLRZ C,(A) ; get lh + JUMPE C,FIX3 ; 0 terminates +FIX5: ADDI C,(B) ; access the code + ADDM D,-1(C) ; and fix it up + JRST FIX4 + +FIXRH: MOVEI 0,1 ; change flag + HRRZ C,(A) ; get it and + JUMPN C,FIX5 + +FIX3: AOBJN A,FIX1 ; do next one + +FIX2: +IFN ITS,[ +IFN .SUSET [.SSNAM,,[PURDIR]] + .OPEN MAPCH,[SIXBIT / 'DSK_PURE_>/] + JRST MAPLS1 + MOVE E,B ; save pointer + ASH E,-PGSHFT ; to page AOBJN + .IOT MAPCH,B ; write out the goodie + SETZB 0,A + MOVEI B,MAPCH + MOVE C,(P) + MOVE D,-1(P) + .FDELE 0 ; attempt to rename to right thing + JRST MAPLS1 + .CLOSE MAPCH, + MOVE B,[SIXBIT / &DSK/] + .OPEN MAPCH,B + FATAL WHERE DID THE FILE GO? + HLLZ 0,E ; pointer to file pages + PUSH P,E ; SAVE FOR END + DOTCAL CORBLK,[[1000,,200000],[1000,,-1],E,[1000,,MAPCH],0] + FATAL LOSSAGE LOSSAGE PAGES LOST + .CLOSE MAPCH, + + SKIPGE MUDSTR+2 ; skip if not experimental + JRST NOFIXO + PUSHJ P,GENVN ; get version number as a number + MOVE E,(TP) +IFN ,.SUSET [.SSNAM,,[FIXDIR]] +IFE ARC, .OPEN MAPCH,[SIXBIT / 'DSK_FIXU_>/] +IFN ARC, .OPEN MAPCH,[SIXBIT / 'ARC_FIXU_>/] +IFE ARC, FATAL CANT WRITE FIXUPS +IFN ARC, PUSHJ P,ARCFAT + HLRE A,E ; get length + MOVNS A + ADDI A,2 ; account for these 2 words + MOVE 0,[-2,,A] ; write version and length + .IOT MAPCH,0 + .IOT MAPCH,E ; out go the fixups + SETZB 0,A + MOVEI B,MAPCH + MOVE C,-1(P) + MOVE D,[SIXBIT /FIXUP/] + .FDELE 0 + FATAL FIXUP WRITE OUT FAILED + .CLOSE MAPCH, +NOFIXO: +] +IFE ITS,[ + MOVE E,-2(TP) ; restore P-stack base + MOVEI 0,600000 ; fixup args to GTJFN + HRLM 0,5(E) + MOVE D,B ; save page number + POP P,4(E) ; current version name in + MOVEI A,5(E) ; pointer ro arg block + MOVEI B,0 + GTJFN + FATAL MAP FIXUP LOSSAGE + MOVE B,[440000,,100000] + OPENF + FATAL MAP FIXUP LOSSAGE + MOVEI B,(D) ; ready to write it out + HRLI B,444400 + HLRE C,D + SOUT ; zap it out + TLO A,400000 ; dont recycle the JFN + CLOSF + JFCL + ANDI A,-1 ; kill sign bit + MOVE B,[440000,,240000] + OPENF + FATAL MAP FIXUP LOSSAGE + MOVE B,D + ASH B,-PGSHFT ; aobjn to pages + PUSH P,B + HLRE D,B ; -count + HRLI B,400000 + MOVSI A,(A) + MOVSI C,120000 + + PMAP + ADDI A,1 + ADDI B,1 + AOJL D,.-3 + + HLRZS A + CLOSF + JFCL + + HRROI 0,[ASCIZ /FIXUP/] ; now write out new fixup file + MOVEM 0,10.(E) + MOVEI A,5(E) + MOVEI B,0 + + SKIPGE MUDSTR+2 + JRST NOFIXO ; exp vers, dont write out + + PUSHJ P,GENVN + MOVEI D,(B) ; save vers in D + GTJFN + FATAL MAP FIXUP LOSSAGE + MOVE B,[440000,,100000] + OPENF + FATAL MAP FIXUP LOSSAGE + HLRE B,(TP) ; length of fixup vector + MOVNS B + ADDI B,2 ; for length and version words + BOUT + MOVE B,D ; and vers # + BOUT + MOVSI B,444400 ; byte pointer to fixups + HRR B,(TP) + HLRE C,(TP) + SOUT + CLOSF + JFCL +NOFIXO: MOVE A,(P) ; save aobjn to pages + MOVE P,-2(TP) + SUB TP,[2,,2] + PUSH P,A +] + HRRZ A,(P) ; get page # + HLRE C,(P) ; and # of same + MOVE B,(P) ; set B up for return + MOVNS C +IFN ITS,[ + SUB P,[2,,2] + MOVE 0,-2(TP) ; saved sname + MOVEM 0,(P) +] + PUSH P,C + PUSH P,A + SUB TP,[4,,4] + JRST PLOAD1 + +IFN ITS,[ +MAPLS4: .CLOSE MAPCH, + SUB P,[1,,1] + JRST MAPLS1 +] +IFE ITS,[ +MAPLS4: SKIPA A,[4,,4] +MAPLS5: MOVE A,[6,,6] + MOVE P,E + SUB TP,A + SKIPE A,C + CLOSF + JFCL + JRST MAPLOS +] + +IFN ITS,[ +IFN ARC,[ +ARCLOS: PUSHJ P,CKLOCK + JRST MAPLS1 + +ARCRTR: SOS (P) + SOS (P) + POPJ P, + +ARCFAT: PUSHJ P,CKLOCK + FATAL CANT WRITE FIXUP FILE + JRST ARCRTR + +CKLOCK: PUSH P,0 + .STATUS MAPCH,0 + LDB 0,[220600,,0] + CAIN 0,23 ; file locked? + JRST WAIT ; wait and retry + POP P,0 + POPJ P, + +WAIT: MOVEI 0,1 + .SLEEP 0, + POP P,0 + AOS (P) + POPJ P, +] +] + +; Here to try to get a free page block for new thing +; A/ # of pages to get + +ALOPAG: PUSHJ P,GETPAG ; try to get enough pages + POPJ P, + AOS (P) ; won skip return + MOVEI 0,(B) ; update PURBOT/PURTOP to reflect current state + ASH 0,PGSHFT + MOVEM 0,PURBOT + POPJ P, + +GETPAG: MOVE C,P.TOP ; top of GC space + ASH C,-PGSHFT ; to page number + MOVE B,PURBOT ; current bottom of pure space + ASH B,-PGSHFT ; also to pages + SUBM B,C ; pages available ==> C + CAIGE C,(A) ; skip if have enough already + JRST GETPG1 ; no, try to shuffle around + SUBI B,(A) ; B/ first new page + AOS (P) + POPJ P, ; return with new free page in B + +; Here if shuffle must occur or gc must be done to make room + +GETPG1: MOVEI 0,0 + SKIPE NOSHUF ; if can't shuffle, then ask gc + JRST ASKAGC + MOVE 0,PURTOP ; get top of mapped pure area + SUB 0,P.TOP ; total free words to 0 + ASH 0,-PGSHFT ; to pages + CAIGE 0,(A) ; skip if winnage possible + JRST ASKAGC ; please AGC give me some room!! + SUBM A,C ; C/ amount we must flush to make room + +; Here to find pages for flush using LRU algorithm + +GL1: MOVE B,PURVEC+1(TVP) ; get pointer to pure sr vector + MOVEI 0,-1 ; get very large age + +GL2: SKIPN 1(B) ; skip if not already flushed + JRST GL3 + HLRZ D,2(B) ; get this ones age + CAMLE D,0 ; skip if this is a candidate + JRST GL3 + MOVE E,B ; point to table entry with E + MOVEI 0,(D) ; and use as current best +GL3: ADD B,[ELN,,ELN] ; look at next + JUMPL B,GL2 + + HLRE B,1(E) ; get length of flushee + ASH B,-PGSHFT ; to negative # of pages + ADD C,B ; update amount needed + SETZM 1(E) ; indicate it will be gone + JUMPG C,GL1 ; jump if more to get + +; Now compact pure space + + PUSH P,A ; need all acs + SETZB E,A + HRRZ D,PURVEC(TVP) ; point to first in core addr order + HRRZ C,PURTOP ; get destination page + ASH C,-PGSHFT ; to page number + +CL1: ADD D,PURVEC+1(TVP) ; to real pointer + SKIPE 1(D) ; skip if this one is a flushee + JRST CL2 + + HRRZ D,2(D) ; point to next one in chain + JUMPN E,CL3 ; jump if not first one + HRRM D,PURVEC(TVP) ; and use its next as first + JRST CL4 + +CL3: HRRM D,2(E) ; link up + JRST CL4 + +; Found a stayer, move it if necessary + +CL2: MOVEI E,(D) ; another pointer to slot + HLRE B,1(D) ; - length of block + HRRZ D,1(D) ; pointer to block + SUB D,B ; point to top of block + ASH D,-PGSHFT ; to page number + CAIN D,(C) ; if not moving, jump + JRST CL6 + + ASH B,-PGSHFT ; to pages +IFN ITS,[ +CL5: SUBI C,1 ; move to pointer and from pointer + SUBI D,1 + DOTCAL CORBLK,[[1000,,200000],[1000,,-1],C,[1000,,-1],D] + FATAL PURE SHUFFLE LOSSAGE + AOJL B,CL5 ; count down +] +IFE ITS,[ + PUSH P,B ; save # of pages + MOVEI A,-1(D) ; copy from pointer + HRLI A,400000 ; get this fork code + RMAP ; get a JFN (hopefully) + EXCH D,(P) ; D # of pages (save from) + ADDM D,(P) ; update from + MOVEI B,-1(C) ; to pointer in B + HRLI B,400000 + MOVSI C,120000 ; read/execute modes + + PMAP ; move a page + SUBI A,1 + SUBI B,1 + AOJL D,.-3 ; move them all + + MOVEI C,1(B) + POP P,D + ADDI D,1 +] +; Update the table address for this loser + + SUBM C,D ; compute offset (in pages) + ASH D,PGSHFT ; to words + ADDM D,1(E) ; update it +CL7: HRRZ D,2(E) ; chain on +CL4: TRNN D,400000 ; skip if end of chain + JRST CL1 + + ASH C,PGSHFT ; to words + MOVEM C,PURBOT ; reset pur bottom + POP P,A + JRST GETPAG + +CL6: HRRZ C,1(E) ; get new top of world + ASH C,-PGSHFT ; to page # + JRST CL7 + +; SUBR to create an entry in the vector for one of these guys + +MFUNCTION PCODE,SUBR + + ENTRY 2 + + GETYP 0,(AB) ; check 1st arg is string + CAIE 0,TCHSTR + JRST WTYP1 + GETYP 0,2(AB) ; second must be fix + CAIE 0,TFIX + JRST WTYP2 + + MOVE A,(AB) ; convert name of program to sixbit + MOVE B,1(AB) + PUSHJ P,STRTO6 +PCODE4: MOVE C,(P) ; get name in sixbit + +; Now look for either this one or an empty slot + + MOVEI E,0 + MOVE B,PURVEC+1(TVP) + +PCODE2: CAMN C,(B) ; skip if this is not it + JRST PCODE1 ; found it, drop out of loop + JUMPN E,.+3 ; dont record another empty if have one + SKIPN (B) ; skip if slot filled + MOVE E,B ; remember pointer + ADD B,[ELN,,ELN] + JUMPL B,PCODE2 ; jump if more to look at + + JUMPE E,PCODE3 ; if E=0, error no room + MOVEM C,(E) ; else stash away name and zero rest + SETZM 1(E) + SETZM 2(E) + JRST .+2 + +PCODE1: MOVE E,B ; build ,, + MOVEI 0,0 ; flag whether new slot + SKIPE 1(E) ; skip if mapped already + MOVEI 0,1 + MOVE B,3(AB) + HLRE D,E + HLRE E,PURVEC+1(TVP) + SUB D,E + HRLI B,(D) + MOVSI A,TPCODE + SKIPN NOSHUF ; skip if not shuffling + JRST FINIS + JUMPN 0,FINIS ; jump if winner + PUSH TP,A + PUSH TP,B + HLRZ A,B + PUSHJ P,PLOAD + JRST PCOERR + POP TP,B + POP TP,A + JRST FINIS + +PCOERR: PUSH TP,$TATOM + PUSH TP,EQUOTE PURE-LOAD-FAILURE + JRST CALER1 + + +PCODE3: HLRE A,PURVEC+1(TVP) ; get current length + MOVNS A + ADDI A,10*ELN ; add 10(8) more entry slots + PUSHJ P,IBLOCK + EXCH B,PURVEC+1(TVP) ; store new one and get old + HLRE A,B ; -old length to A + MOVSI B,(B) ; start making BLT pointer + HRR B,PURVEC+1(TVP) + SUBM B,A ; final dest to A + BLT B,-1(A) + JRST PCODE4 + +; Here if must try to GC for some more core + +ASKAGC: SKIPE GCFLG ; if already in GC, lose + POPJ P, + SUBM A,0 ; amount required to 0 + ASH 0,PGSHFT ; TO WORDS + MOVEM 0,GCDOWN ; pass as funny arg to AGC + EXCH A,C ; save A from gc's destruction +IFN ITS, .IOPUSH MAPCH, ; gc uses same channel + PUSH P,C + MOVE C,[8,,9.] ; SET UP INDICATORS FOR GC + PUSHJ P,AGC + POP P,C +IFN ITS, .IOPOP MAPCH, + EXCH C,A + JUMPGE C,GETPAG + PUSH TP,$TATOM + PUSH TP,EQUOTE NO-MORE-PAGES + AOJA TB,CALER1 + +; Here to clean up pure space by flushing all shared stuff + +PURCLN: SKIPE NOSHUF + POPJ P, + MOVEI B,400000 + HRRM B,PURVEC(TVP) ; flush chain pointer + MOVE B,PURVEC+1(TVP) ; get pointer to table + SETZM 1(B) ; zero pointer entry + SETZM 2(B) ; zero link and age slots + ADD B,[ELN,,ELN] ; go to next slot + JUMPL B,.-3 ; do til exhausted + MOVE B,PURBOT ; now return pages + SUB B,PURTOP ; compute page AOBJN pointer + JUMPE B,CPOPJ ; no pure pages? + MOVSI B,(B) + HRR B,PURBOT + ASH B,-PGSHFT +IFN ITS,[ + DOTCAL CORBLK,[[1000,,0],[1000,,-1],B] + FATAL SYSTEM WONT TAKE CORE BACK? +] +IFE ITS,[ + HLRE D,B ; - # of pges to flush + HRLI B,400000 ; specify hacking hom fork + MOVNI A,1 + + PMAP + ADDI B,1 + AOJL D,.-2 +] + MOVE B,PURTOP ; now fix up pointers + MOVEM B,PURBOT ; to indicate no pure +CPOPJ: POPJ P, + +; Here to move the entire pure space. +; A/ # and direction of pages to move (+ ==> up) + +MOVPUR: SKIPE NOSHUF + FATAL CANT MOVE PURE SPACE AROUND + IFE ITS [ASH A,1] + SKIPN B,A ; zero movement, ignore call + POPJ P, + + ASH B,PGSHFT ; convert to words for pointer update + MOVE C,PURVEC+1(TVP) ; loop through updating non-zero entries + SKIPE 1(C) + ADDM B,1(C) + ADD C,[ELN,,ELN] + JUMPL C,.-3 + + MOVE C,PURTOP ; found pages at top and bottom of pure + ASH C,-PGSHFT + MOVE D,PURBOT + ASH D,-PGSHFT + ADDM B,PURTOP ; update to new boundaries + ADDM B,PURBOT + CAIN C,(D) ; differ? + POPJ P, + JUMPG A,PUP ; if moving up, go do separate CORBLKs + +IFN ITS,[ + SUBM D,C ; -size of area to C (in pages) + MOVEI E,(D) ; build pointer to bottom of destination + ADD E,A + HRLI E,(C) + HRLI D,(C) + DOTCAL CORBLK,[[1000,,200000],[1000,,-1],E,[1000,,-1],D] + FATAL CANT MOVE PURE + POPJ P, + +PUP: SUBM C,D ; pages to move to D + ADDI A,(C) ; point to new top + +PUPL: SUBI C,1 + SUBI A,1 + DOTCAL CORBLK,[[1000,,200000],[1000,,-1],A,[1000,,-1],C] + FATAL CANT MOVE PURE + SOJG D,PUPL + POPJ P, +] +IFE ITS,[ + SUBM D,C ; pages to move to D + MOVSI E,(C) ; build aobjn pointer + HRRI E,(D) ; point to lowest + ADD D,A ; D==> new lowest page +PURCL1: MOVSI A,400000 ; specify here + HRRI A,(E) ; get a page + RMAP ; get a real handle on it + MOVE B,D ; where to go + HRLI B,400000 + MOVSI C,120000 + PMAP + ADDI D,1 + AOBJN E,PURCL1 + POPJ P, + +PUP: SUB D,C ; - count to D + MOVSI E,(D) ; start building AOBJN + HRRI E,(C) ; aobjn to top + ADD C,A ; C==> new top + MOVE D,C + +PUPL: MOVSI A,400000 + HRRI A,(E) + RMAP ; get real handle + MOVE B,D + HRLI B,400000 + MOVSI C,120000 + PMAP + SUBI E,2 + SUBI D,1 + AOBJN E,PUPL + + POPJ P, +] +IFN ITS,[ +CSIXBT: MOVEI 0,5 + PUSH P,[440700,,C] + PUSH P,[440600,,D] + MOVEI D,0 +CSXB2: ILDB E,-1(P) + CAIN E,177 + JRST CSXB1 + SUBI E,40 + IDPB E,(P) + SOJG 0,CSXB2 +CSXB1: SUB P,[2,,2] + MOVE C,D + POPJ P, +] +GENVN: MOVE C,[440700,,MUDSTR+2] + MOVEI D,5 + MOVEI B,0 +VNGEN: ILDB 0,C + CAIN 0,177 + POPJ P, + IMULI B,10. + SUBI 0,60 + ADD B,0 + SOJG D,VNGEN + POPJ P, + +IFE ITS,[ +MSKS: 774000,,0 + 777760,,0 + 777777,,700000 + 777777,,777400 + 777777,,777776 +] +END + diff --git a/sumex/maps.mcr017 b/sumex/maps.mcr017 new file mode 100644 index 0000000..dbed713 --- /dev/null +++ b/sumex/maps.mcr017 @@ -0,0 +1,243 @@ +TITLE MAPS -- MAP FUNCTIONS FOR MUDDLE + +RELOCATABLE + +.INSRT MUDDLE > + +.GLOBAL TYPSEG,NXTLM,NAPT,APLQ,INCR1,SPECBI,FRMSTK,MAPPLY +.GLOBAL CHFSWP,SSPEC1,ILVAL,CHUNW + +; PSTACK OFFSETS + +INCNT==0 ; INNER LOOP COUNT +LISTNO==-1 ; ARG NUMBER BEING HACKED +ARGCNT==-2 ; FINAL ARG COUNTER +NARGS==-3 ; NUMBER OF STRUCTURES +NTHRST==-4 ; 0=> MAP REST, OTHERWISE MAP FIRST + +; MAP THE "CAR" OF EACH LIST + +MFUNCTION MAPF,SUBR + + PUSH P,. ; PUSH NON-ZERO + JRST MAP1 + +; MAP THE "CDR" OF EACH LIST + +MFUNCTION MAPR,SUBR + + PUSH P,[0] + +MAP1: ENTRY + HLRE C,AB ; HOW MANY ARGS + ASH C,-1 ; TO # OF PAIRS + ADDI C,3 ; AT LEAST 3 + JUMPG C,TFA ; NOT ENOUGH + GETYP A,(AB) ; TYPE OF CONSTRUCTOR + CAIN A,TFALSE ; ANY CONSING NEEDE? + JRST MAP2 ; NO, SKIP CHECK + PUSHJ P,APLQ ; CHECK IF APPLICABLE + JRST NAPT ; NO, ERROR +MAP2: MOVNS C ; POS NO. OF ARGS (-3) + ADDI C,1 ; C/ NOW # OF LISTS... + PUSH P,C ; SAVE IT + PUSH TP,[TATOM,,-1] ; ALL **GFP** INSTRUCTIONS ARE TO DO WITH MAPRET + PUSH TP,MQUOTE LMAP,[LMAP ]INTRUP + PUSHJ P,FRMSTK ; **GFP** + PUSH TP,[0] ; **GFP** + PUSH TP,[0] ; **GFP** + PUSHJ P,SPECBIND ; **GFP** + MOVE C,(P) ; RESTORE COUNT OF ARGS + MOVE A,AB ; COPY ARG POINTER + MOVSI 0,TAB ; CLOBBER A'S TYPE + MOVEM 0,ASTO(PVP) + +ARGLP: INTGO ; STACK MAY OVERFLOW + PUSH TP,4(A) ; SKIP FCNS + PUSH TP,5(A) + ADD A,[2,,2] + SOJG C,ARGLP ; ALL UP ON STACK + +; ALL STRUCTURES ARE ON THE STACK, NOW PUSH THE CONSTRUCTOR + + PUSH TP,(AB) ; CONSTRUCTOR + PUSH TP,1(AB) + SETZM ASTO(PVP) + PUSH P,[-1] ; FUNNY TEMPS + PUSH P,[0] + PUSH P,[0] + +; OUTER LOOP CDRING EACH STRUCTURE + +OUTRLP: SETZM LISTNO(P) ; START AT 0TH LIST + MOVE 0,NARGS(P) ; TOTAL # OF STRUCS + MOVEM 0,INCNT(P) ; AS COUNTER IN INNER LOOP + PUSH TP,2(AB) ; PUSH THE APPLIER + PUSH TP,3(AB) + +; INNER LOOP, CONS UP EACH APPLICATION + +INRLP: INTGO + MOVEI E,2 ; READY TO BUMP LISTNO + ADDB E,LISTNO(P) ; CURRENT STORED AND IN C + ADDI E,(TB)4 ; POINT TO A STRUCTURE + MOVE A,(E) ; PICK IT UP + MOVE B,1(E) ; AND VAL + PUSHJ P,TYPSEG ; SETUP TO REST IT ETC. + SKIPL ARGCNT(P) ; DONT INCR THE 1ST TIME + XCT INCR1(C) ; INCREMENT THE LOSER + MOVE 0,DSTO(PVP) ; UPDATE THE LIST + MOVEM 0,(E) + MOVEM D,1(E) ; CLOBBER AWAY + PUSH TP,DSTO(PVP) ; FOR REST CASE + PUSH TP,D + PUSHJ P,NXTLM ; SKIP IF GOT ONE, ELSE DONT + JRST DONEIT ; FINISHED + SETZM DSTO(PVP) + SKIPN NTHRST(P) ; SKIP IF MAP REST + JRST INRLP1 + MOVEM A,-1(TP) ; IUSE AS ARG + MOVEM B,(TP) +INRLP1: SOSE INCNT(P) ; COUNT ARGS + JRST INRLP ; MORE, GO DO THEM + + +; ALL ARGS PUSHED, APPLY USER FCN + + SKIPGE ARGCNT(P) ; UN NEGATE ARGCNT + SETZM ARGCNT(P) + MOVE A,NARGS(P) ; GET # OF ARGS + ADDI A,1 + ACALL A,MAPPLY ; APPLY THE BAG BITER + + GETYP 0,(AB) ; GET TYPE OF CONSTRUCTOR + CAIN 0,TFALSE ; SKIP IF ONE IS THERE + JRST OUTRL1 + PUSH TP,A + PUSH TP,B + AOS ARGCNT(P) + JRST OUTRLP + +OUTRL1: MOVEM A,-1(TP) ; SAVE PARTIAL VALUE + MOVEM B,(TP) + JRST OUTRLP + +; HERE IF ALL FINISHED + +DONEIT: HRLS C,LISTNO(P) ; HOW MANY DONE + SUB TP,[2,,2] ; FLUSH SAVED VAL + SUB TP,C ; FLUSH TUPLE OF CRUFT +DONEI1: SKIPGE ARGCNT(P) + SETZM ARGCNT(P) ; IN CASE STILL NEGATIVE + SETZM DSTO(PVP) ; UNSCREW + GETYP 0,(AB) ; ANY CONSTRUCTOR + CAIN 0,TFALSE + JRST MFINIS ; NO, LEAVE + AOS D,ARGCNT(P) ; IF NO ARGS + ACALL D,APPLY ; APPLY IT + + JRST FINIS + +; HERE TO FINISH IF CONSTRUCTOR WAS #FALSE () + +MFINIS: POP TP,B + POP TP,A + JRST FINIS + +; **GFP** FROM HERE TO THE END + +MFUNCTION MAPLEAVE,SUBR + + ENTRY + + CAMGE AB,[-3,,0] + JRST TMA + MOVE B,MQUOTE LMAP,[LMAP ]INTRUP + PUSHJ P,ILVAL + GETYP 0,A + CAIE 0,TFRAME ; MAKE SURE WINNER + JRST NOTM + PUSH TP,A + PUSH TP,B + MOVEI B,-1(TP) ; POINT TO FRAME POINTER + PUSHJ P,CHFSWP + PUSHJ P,CHUNW + JUMPL C,MAPL1 ; RET VAL SUPPLIED + MOVSI A,TATOM + MOVE B,MQUOTE T + JRST FINIS + +MAPL1: MOVE A,(C) + MOVE B,1(C) + JRST FINIS + +MFUNCTION MAPSTOP,SUBR + + ENTRY + + PUSH P,[1] + JRST MAPREC + +MFUNCTION MAPRET,SUBR + + ENTRY + + PUSH P,[0] +MAPREC: MOVE B,MQUOTE LMAP,[LMAP ]INTRUP + PUSHJ P,ILVAL ; GET VALUE + GETYP 0,A ; FRAME? + CAIE 0,TFRAME + JRST NOTM + PUSH TP,A + PUSH TP,B + MOVEI B,-1(TP) + POP P,0 ; RET/STOP SWITCH + JUMPN 0,MAPRC1 ; JUMP IF STOP + PUSHJ P,CHFSWP ; CHECK IT OUT (AND MAYBE SWAP) + PUSH P,[NLOCR] + JRST MAPRC2 +MAPRC1: PUSHJ P,CHFSWP + PUSH P,[NLOCR1] +MAPRC2: HRRZ E,SPSAV(B) ; UNBIND BEFORE RETURN + PUSH TP,$TAB + PUSH TP,C + ADDI E,1 ; FUDGE FOR UNBINDER + PUSHJ P,SSPEC1 ; UNBINDER + HLRE D,(TP) ; FIND NUMBER + JUMPE D,MAPRE1 ; SKIP IF NONE TO MOVE + MOVNS E,D ; AND PLUS IT + HRLI E,(E) ; COMPUTE NEW TP + ADD E,TPSAV(B) ; NEW TP + HRRZ C,TPSAV(B) ; GET OLD TOP + MOVEM E,TPSAV(B) + HRL C,(TP) ; AND NEW BOT + ADDI C,1 + BLT C,(E) ; BRING IT ALL DOWN +MAPRE1: ASH D,-1 ; NO OF ARGS + HRRI TB,(B) ; PREPARE TO FINIS + MOVSI A,TFIX + MOVEI B,(D) + POP P,0 ; GET PC TO GO TO + MOVEM 0,PCSAV(TB) + JRST CONTIN ; BACK TO MAPPER + +NLOCR1: TDZA A,A ; ZER SW +NLOCR: MOVEI A,1 + GETYP 0,(AB) ; CHECK IF BUILDING + CAIN 0,TFALSE + JRST FLUSHM ; REMOVE GOODIES + ADDM B,ARGCNT(P) ; BUMP ARG COUNTER +NLOCR2: JUMPE A,DONEI1 + JRST OUTRLP + +FLUSHM: ASH B,1 ; FLUSH GOODIES DROPPED + HRLI B,(B) + SUB TP,B + JRST NLOCR2 + +NOTM: PUSH TP,$TATOM + PUSH TP,EQUOTE NOT-IN-MAP-FUNCTION + JRST CALER1 + +END + \ No newline at end of file diff --git a/sumex/muddle.all-750609.1.txt b/sumex/muddle.all-750609.1.txt deleted file mode 100644 index 26d2b3d..0000000 --- a/sumex/muddle.all-750609.1.txt +++ /dev/null @@ -1,33227 +0,0 @@ -TITLE AGC MUDDLE GARBAGE COLLECTOR - -;SYSTEM WIDE DEFINITIONS GO HERE - -.GLOBAL RCL,VECTOP,VECBOT,PARTOP,PARBOT,HITOP,HIBOT,GETPAG -.GLOBAL PDLBUF,PDLEX,PDLEXP,GCFLG,GCPDL,GETNUM,PARNEW,MOVPUR -.GLOBAL PGROW,TPGROW,TIMOUT,MAINPR,%SLEEP,MSGTYP,PURTOP,PURBOT,STOSTR -.GLOBAL MTYI,UPLO,FRMUNG,BYTDOP,GLOBSP,SYSMAX,FREDIF,FREMIN,GCHAPN,INTFLG -.GLOBAL SAT,TTOCHN,TYPVEC,ICONS,INCONS,IBLOCK,IEUVEC,IEVECTI,CELL2 -.GLOBAL GIBLOK,REHASH,IBLOK1,IILIST,IIFORM,CIVEC,CIUVEC,CICONS -.GLOBAL SPBASE,OUTRNG,CISTNG,%RUNAM,PURVEC,GCDOWN,N.CHNS,CHNL1 -.GLOBAL CAFRE,CAFRET,STOGC,GCHN,WNDP,FRNP,%GCJOB,%SHWND,%SHFNT,%INFMP,%GETIP -.GLOBAL TD.PUT,TD.GET,TD.LNT -.GLOBAL CTIME,MTYO,ILOC,GCRSET -.GLOBAL GCTIM,GCCAUS,GCCALL,AAGC,LVLINC,STORIC,GVLINC,TYPIC -; GLOBALS ASSOCIATE WITH THE ASSOCIATION VECTOR - -.GLOBAL ASOVEC,ASOLNT,ITEM,INDIC,VAL,NWORDT,NODPNT,PNTRS -.GLOBAL CELL,BINDID,GCFLCH,TYPBOT,GLOBAS,TPBASE - -.GLOBAL P.TOP,P.CORE,PMAP - -NGCS==8 ; AFTER NGCS, DO HAIRY VAL/ASSOC FLUSH -PDLBUF=100 -TPMAX==20000 ;PDLS LARGER THAN THIS WILL BE SHRUNK -PMAX==4000 ;MAXIMUM PSTACK SIZE -TPMIN==1000 ;MINIMUM PDL SIZES -PMIN==400 -TPGOOD==10000 ; A GOOD STACK SIZE -PGOOD==1000 -.ATOM.==200000 ; FLAG SAYING ATOMS MARKED (FOR VAL FLUSH LOGIC) - -GCHN==0 ; CHANNEL FOR FUNNNY INFERIOR -STATNO==19. ; # OF STATISTICS FOR BLOAT-STAT -STATGC==8. ; # OF GC-STATISTICS FOR BLOAT-STAT - - -RELOCATABLE -.INSRT MUDDLE > - -TYPNT=AB ;SPECIAL AC USAGE DURING GC -F=TP ;ALSO SPECIAL DURING GC -LPVP=SP ;SPECIAL FOR GC, HOLDS POINTER TO PROCESS CHAIN -FPTR=TB ; POINT TO CURRENT FRONTIER OF INFERIOR - - -; WINDOW AND FRONTIER PAGES - -FRONT==776000 ; PAGE 255. IS FRONTIER -WIND==774000 ; PAGE 254. IS WINDOW -FRNP==FRONT/2000 -WNDP==WIND/2000 - - - - - - -.GLOBAL FLIST - -MFUNCTION BLOATSTAT,SUBR,[BLOAT-STAT] - -ENTRY - - JUMPGE AB,GETUVC ; SEE IF THERE IS AN ARGUMENT - GETYP A,(AB) - CAIE A,TUVEC ; SEE IF THE ARGUMENT IS A UVECTOR - JRST WTYP1 ; IF NOT COMPLAIN - HLRE 0,1(AB) - MOVNS 0 - CAIGE 0,STATNO+STATGC ; SEE IF UVECTOR IS RIGHT LENGTH - JRST WTYP1 - CAMGE AB,[-2,,0] ; SEE IF THERE ARE TOO MANY ARGUMENTS - JRST TMA - MOVE A,(AB) ; GET THE UVECTOR - MOVE B,1(AB) - JRST SETUV ; CONTINUE -GETUVC: MOVEI A,STATNO+STATGC ; CREATE A UVECTOR - PUSHJ P,IBLOCK -SETUV: PUSH P,A ; SAVE UVECTOR - PUSH P,B - MOVE 0,NOWFRE ; COMPUTE FREE STORAGE USED SINCE LAST GC - SUB 0,VECBOT - ADD 0,PARTOP - MOVEM 0,CURFRE - HLRE 0,TP ; COMPUTE STACK SPACE USED UP - ADD 0,NOWTP - SUBI 0,PDLBUF - MOVEM 0,CURTP - MOVE B,IMQUOTE THIS-PROCESS - PUSHJ P,ILOC - HRRZS B - HRRZ C,TPBASE+1(PVP) ; CALCULATE # OF ATOM SLOTS - MOVE 0,B - HRRZ D,SPBASE+1(PVP) ; COMPUTE CURRENT # OF BINDINGS - SUB 0,D - IDIVI 0,6 - MOVEM 0,CURLVL - SUB B,C ; TOTAL WORDS ATOM STORAGE - IDIVI B,6 ; COMPUTE # OF SLOTS - MOVEM B,NOWLVL - HRRZ A,GLOBASE+1(TVP) ; COMPUTE TOTAL # OF GLOBAL SLOTS - HLRE 0,GLOBASE+1(TVP) - SUB A,0 ; POINT TO DOPE WORD - HLRZ B,1(A) - ASH B,-2 ; # OF GVAL SLOTS - MOVEM B,NOWGVL - HRRZ 0,GLOBASE+1(TVP) ; COMPUTE # OF GVAL SLOTS IN USE - HRRZ A,GLOBSP+1(TVP) - SUB A,0 - ASH A,-2 ; NEGATIVE # OF SLOTS USED - SUBI B,(A) - MOVEM B,CURGVL - HRRZ A,TYPBOT+1(TVP) ; GET LENGTH OF TYPE VECTOR - HLRE 0,TYPBOT+1(TVP) - SUB A,0 - HLRZ B,1(A) ; # OF WORDS IN TYPE-VECTOR - IDIVI B,2 ; CONVERT TO # OF TYPES - MOVEM B,NOWTYP - HLRE 0,TYPVEC+1(TVP) ; LENGTH OF VISABLE TYPE-VECTOR - MOVNS 0 - IDIVI 0,2 ; GET # OF TYPES - MOVEM 0,CURTYP - MOVE 0,CODTOP ; GET LENGTH OF STATIONARY IMPURE STORAGE - MOVEM 0,NOWSTO - SETZB B,D ; ZERO OUT MAXIMUM - HRRZ C,FLIST -LOOPC: HLRZ 0,(C) ; GET BLK LENGTH - ADD D,0 ; ADD # OF WORDS IN BLOCK - CAMGE B,0 ; SEE IF NEW MAXIMUM - MOVE B,0 - HRRZ C,(C) ; POINT TO NEXT BLOCK - JUMPN C,LOOPC ; REPEAT - MOVEM D,CURSTO - MOVEM B,CURMAX - HLRE 0,P ; GET AMOUNT OF ROOM LEFT ON P - ADD 0,NOWP - SUBI 0,PDLBUF - MOVEM 0,CURP - PUSHJ P,GCSET ; FIX UP BLOAT-STAT PARAMETERS - MOVSI C,BSTGC ; SET UP BLT FOR GC FIGURES - HRRZ B,(P) ; RESTORE B - HRR C,B - BLT C,(B)STATGC-1 - HRLI C,BSTAT ; MODIFY BLT FOR STATS - ADDI C,STATGC ; B HAS ELEMENTS - BLT C,(B)STATGC+STATNO-1 - MOVEI 0,TFIX - HRLM 0,(B)STATNO+STATGC ; MOVE IN UTYPE - POP P,B - POP P,A ; RESTORE TYPE-WORD - JRST FINIS - - -; THIS IS THE SCHEME USED TO UPDATE CERTAIN IMFORMATION USED BY THE -; BLOAT-SPEC ROUTINE TO GIVE USERS IMFORMATION ABOUT USE OF SPACE BY -; THEIR MUDDLE. - -GCRSET: SETZM GCNO ; CALL FROM INIT, ZAP ALL 1ST - MOVE 0,[GCNO,,GCNO+1] - BLT 0,GCCALL - -GCSET: MOVE A,VECBOT ; COMPUTE FREE SPACE AVAILABLE - SUB A,PARTOP - MOVEM A,NOWFRE - CAMLE A,MAXFRE - MOVEM A,MAXFRE ; MODIFY MAXIMUM - HLRE A,TP ; FIND THE DOPE WORD OF THE TP STACK - MOVNS A - ADDI A,1(TP) ; CLOSE TO DOPE WORD - CAME A,TPGROW - ADDI A,PDLBUF ; NOW AT REAL DOPE WORD - HLRZ B,(A) ; GET LENGTH OF TP-STACK - MOVEM B,NOWTP - CAMLE B,CTPMX ; SEE IF THIS IS THE BIGGEST TP - MOVEM B,CTPMX - HLRE B,P ; FIND DOPE WORD OF P-STACK - MOVNS B - ADDI B,1(P) ; CLOSE TO IT - CAME B,PGROW ; SEE IF THE STACK IS BLOWN - ADDI B,PDLBUF ; POINTING TO IT - HLRZ A,(B) ; GET IN LENGTH - MOVEM A,NOWP - CAMLE A,CPMX ; SEE IF WE HAVE THE BIGGEST P STACK - MOVEM A,CPMX - POPJ P, ; EXIT - - -.GLOBAL PGFIND,PGGIVE,PGTAKE,PGINT - -; FIND AND ALLOCATE AS MANY CONTIGUOUS PAGES AS INDICATED BY REG A -; RETURN THE NUMBER (0-255.) OF THE FIRST SUCH PAGE IN REG B -; RETURN -1 IN REG B IF NONE FOUND - -PGFIND: - JUMPLE A,FPLOSS - PUSHJ P,PGFND1 ; SEE IF ALREADY ENOUGH - SKIPL B ; SKIP IF LOST - POPJ P, - - SUBM M,(P) - PUSH P,E - PUSH P,C - PUSH P,D - MOVE C,PURBOT ; CHECK IF ROOM AT ALL - SUB C,P.TOP ; TOTAL SPACE - MOVEI D,(C) ; COPY FOR CONVERSION TO PAGES - ASH D,-10. - CAIGE C,(A) ; SKIP IF COULD WIN - JRST PGFLOS - - MOVNS A ; MOVE PURE AREA DOWN "A" PAGES - PUSHJ P,MOVPUR - MOVE B,PURTOP ; GET FIRST PAGE ALLOCATED - ASH B,-10. ; TO PAGE # -PGFLOS: POP P,D - POP P,C - POP P,E - PUSHJ P,RBLDM ; GET A NEW VALUE FOR M - JRST MPOPJ - -PGFND1: PUSH P,E - PUSH P,D - PUSH P,C - PUSH P,[-1] ;POSSIBLE CONTENTS FOR REG B - PUSH P,A ;SAVE LENGTH OF BLOCK DESIRED FOR LATER USE - SETZB B,C ;INITIAL SECTION AND PAGE NUMBERS - MOVEI 0,0 ;COUNT OF PAGES ALREADY FOUND - PUSHJ P,PINIT -PLOOP: TDNE E,D ;FREE PAGE ? - JRST NOTFRE ;NO - JUMPN 0,NFIRST ;FIRST FREE PAGE OF A BLOCK ? - MOVEI A,(B) ;YES SAVE ADDRESS OF PAGE IN REG A - IMULI A,32. - ADDI A,(C) -NFIRST: ADDI 0,1 - CAML 0,(P) ;TEST IF ENOUGH PAGES HAVE BEEN FOUND - JRST PWIN ;YES, FINISHED - SKIPA -NOTFRE: MOVEI 0,0 ;RESET COUNT - PUSHJ P,PNEXT ;NEXT PAGE - JRST PLOSE ;NONE--LOSE RETURNING -1 IN REG B - JRST PLOOP - -PWIN: MOVEI B,(A) ;GET WINNING ADDRESS - MOVEM B,(P)-1 ;RETURN ADDRESS OF WINNING PAGE - MOVE A,(P) ;RELOAD LENGTH OF BLOCK OF PAGES - MOVE 0,[TDO E,D] ;INST TO SET "BUSY" BITS - JRST ITAKE - -;CLAIM OR RETURN TO FREE STORAGE AS MANY CONTIGUOUS PAGES AS INDICATED BY REG A -;THE NUMBER (0 - 255.) OF THE FIRST SUCH PAGE IS IN REG B -PGGIVE: MOVE 0,[TDZ E,D] ;INST TO SET "FREE" BITS - SKIPA -PGTAKE: MOVE 0,[TDO E,D] ;INST TO SET "BUSY" BITS - JUMPLE A,FPLOSS - CAIL B,0 - CAILE B,255. - JRST FPLOSS - PUSH P,E - PUSH P,D - PUSH P,C - PUSH P,B - PUSH P,A -ITAKE: IDIVI B,32. - PUSHJ P,PINIT - SUBI A,1 -RTL: XCT 0 ;SET APPROPRIATE BIT - PUSHJ P,PNEXT ;NEXT PAGE'S BIT - JUMPG A,FPLOSS ;TOO MANY ? - SOJGE A,RTL - MOVEM E,PMAP(B) ;REPLACE BIT MASK -PLOSE: POP P,A - POP P,B - POP P,C - POP P,D - POP P,E - POPJ P, - - -PINIT: MOVE E,PMAP(B) ;GET BITS FOR THIS SECTION - HRLZI D,400000 ;BIT MASK - MOVNS C - LSH D,(C) ;SHIFT TO APPROPRIATE BIT POSITION - MOVNS C - POPJ P, - -PNEXT: AOS (P) ;FOR SKIP RETURN ON EXPECTED SUCCESS - LSH D,-1 ;CONSIDER NEXT PAGE - CAIGE C,31. ;FINISHED WITH THIS SECTION ? - AOJA C,CPOPJ ;NO, INCREMENT AND CONTINUE - MOVEM E,PMAP(B) ;REPLACE BIT MASK - SETZ C, - CAIGE B,7. ;LAST SECTION ? - AOJA B,PINIT ;NO, INCREMENT AND CONTINUE - SOS (P) ;YES, UNDO SKIP RETURN - POPJ P, - -FPLOSS: FATAL PAGE LOSSAGE - -PGINT: MOVEI B,HIBOT ;INITIALIZE MUDDLE'S PAGE MAP TABLE - IDIVI B,2000 ;FIRST PAGE OF PURE CODE - MOVE C,HITOP - IDIVI C,2000 - MOVEI A,(C)+1 - SUBI A,(B) ;NUMBER OF SUCH PAGES - PUSHJ P,PGTAKE ;MARK THESE PAGES AS TAKEN - POPJ P, -; USER GARBAGE COLLECTOR INTERFACE - -MFUNCTION GC,SUBR - ENTRY - - JUMPGE AB,GC1 - CAMGE AB,[-4,,0] - JRST TMA - PUSHJ P,GETFIX ; GET FREEE MIN IF GIVEN - MOVEM A,FREMIN - ADD AB,[2,,2] ; NEXT ARG - JUMPGE AB,GC1 ; NOT SUPPLIED - PUSHJ P,GETFIX ; GET FREDIF - MOVEM A,FREDIF -GC1: PUSHJ P,COMPRM ; GET CURRENT USED CORE - PUSH P,A - MOVEI A,1 - MOVEM A,GCHAIR ; FORCE FLUSH OF VALS ASSOCS - MOVE C,[11,,0] ; INDICATOR FOR AGC - PUSHJ P,AGC ; COLLECT THAT TRASH - SKIPGE A ; SKIP IF OK - PUSHJ P,FULLOS ; COMPLAIN ABOUT LACK OF SPACE - PUSHJ P,COMPRM ; HOW MUCH ROOM NOW? - POP P,B ; RETURN AMOUNT - SUB B,A - MOVSI A,TFIX - JRST FINIS - - -COMPRM: MOVE A,PARTOP ; USED SPACE - SUB A,PARBOT - ADD A,VECTOP - SUB A,VECBOT - POPJ P, - -MFUNCTION GCDMON,SUBR,[GC-MON] - - ENTRY 1 - - SETZM GCMONF ; ASSUME FALSE - GETYP 0,(AB) - CAIE 0,TFALSE - SETOM GCMONF - MOVE A,(AB) - MOVE B,1(AB) - JRST FINIS -.GLOBAL EVATYP,APLTYP,PRNTYP - - MFUNCTION BLOAT,SUBR - ENTRY - - MOVEI C,0 ; FLAG TO SAY WHETHER NEED A GC - MOVSI E,-NBLO ; AOBJN TO BLOATER TABLE - -BLOAT2: JUMPGE AB,BLOAT1 ; ALL DONE? - PUSHJ P,NXTFIX ; GET NEXT BLOAT PARAM - PUSHJ P,@BLOATER(E) ; DISPATCH - AOBJN E,BLOAT2 ; COUNT PARAMS SET - - JUMPL AB,TMA ; ANY LEFT...ERROR -BLOAT1: JUMPE C,BLOATD ; DONE, NO GC NEEDED - MOVEI 0,1 - MOVEM 0,GCHAIR ; FORCE HAIR TO OCCUR - MOVE C,E ; MOVE IN INDICATOR - HRLI C,1 ; INDICATE THAT IT COMES FROM BLOAT - PUSHJ P,AGC ; DO ONE - SKIPGE A - PUSHJ P,FULLOS ; NO CORE LEFT - SKIPE A,TPBINC ; SMASH POINNTERS - ADDM A,TPBASE+1(PVP) - SKIPE A,GLBINC ; GLOBAL SP - ADDM A,GLOBASE+1(TVP) - SKIPE A,TYPINC - ADDM A,TYPBOT+1(TVP) - SETZM TPBINC ; RESET PARAMS - SETZM GLBINC - SETZM TYPINC - -BLOATD: MOVE B,VECBOT - SUB B,PARTOP - MOVSI A,TFIX ; RETURN CORE FOUND - JRST FINIS - -; TABLE OF BLOAT ROUTINES - -BLOATER: - MAINB - TPBLO - LOBLO - GLBLO - TYBLO - STBLO - PBLO - SFREM - SFRED - SLVL - SGVL - STYP - SSTO - NBLO==.-BLOATER - -; BLOAT MAIN STORAGE AREA - -MAINB: MOVE D,VECBOT ; COMPUTE CURRENT ROOM - SUB D,PARTOP - CAMGE A,D ; NEED MORE? - POPJ P, ; NO, LEAVE - MOVEM A,GETNUM ; SAVE - AOJA C,CPOPJ ; LEAVE SETTING C - -; BLOAT TP STACK (AT TOP) - -TPBLO: HLRE D,TP ; GET -SIZE - MOVNS B,D - ADDI D,1(TP) ; POINT TO DOPE (ALMOST) - CAME D,TPGROW ; BLOWN? - ADDI D,PDLBUF ; POINT TO REAL DOPE WORD - CAMG A,B ; SKIP IF GROWTH NEEDED - POPJ P, - ASH A,-6 ; CONVERT TO 64 WD BLOCKS - CAILE A,377 - JRST OUTRNG - DPB A,[111100,,-1(D)] ; SMASH SPECS IN - AOJA C,CPOPJ - -; BLOAT TOP LEVEL LOCALS - -LOBLO: IMULI A,6 ; 6 WORDS PER BINDING - HRRZ 0,TPBASE+1(PVP) - HRRZ B,SPBASE+1(PVP) ; ROOM AVAIL TO E - SUB B,0 - SUBI A,(B) ; HOW MUCH MORE? - JUMPLE A,CPOPJ ; NONE NEEDED - MOVEI B,TPBINC - PUSHJ P,NUMADJ - DPB A,[1100,,-1(D)] ; SMASH - AOJA C,CPOPJ - -; GLOBAL SLOT GROWER - -GLBLO: ASH A,2 ; 4 WORDS PER VAR - MOVE D,GLOBASE+1(TVP) ; CURRENT LIMITS - HRRZ B,GLOBSP+1(TVP) - SUBI B,(D) - SUBI A,(B) ; NEW AMOUNT NEEDED - JUMPLE A,CPOPJ - MOVEI B,GLBINC ; WHERE TO KEEP UPDATE - PUSHJ P,NUMADJ ; FIX NUMBER - HLRE 0,D - SUB D,0 ; POINT TO DOPE - DPB A,[1100,,(D)] ; AND SMASH - AOJA C,CPOPJ - -; HERE TO GROW TYPE VECTOR (AND FRIENDS) - -TYBLO: ASH A,1 ; TWO WORD PER TYPE - HRRZ B,TYPBOT+1(TVP) ; FIND CURRENT ROOM - MOVE D,TYPVEC+1(TVP) - SUBI B,(D) - SUBI A,(B) ; EXTRA NEEDED TO A - JUMPLE A,CPOPJ ; NONE NEEDED, LEAVE - MOVEI B,TYPINC ; WHERE TO STASH SPEC - PUSHJ P,NUMADJ ; FIX NUMBER - HLRE 0,D ; POINT TO DOPE - SUB D,0 - DPB A,[1100,,(D)] - SKIPE D,EVATYP+1(TVP) ; GROW AUX TYPE VECS IF NEEDED - PUSHJ P,SGROW1 - SKIPE D,APLTYP+1(TVP) - PUSHJ P,SGROW1 - SKIPE D,PRNTYP+1(TVP) - PUSHJ P,SGROW1 - AOJA C,CPOPJ - -; HERE TO CREATE STORAGE SPACE - -STBLO: MOVE D,PARBOT ; HOW MUCH NOW HERE - SUB D,CODTOP - SUBI A,(D) ; MORE NEEDED? - JUMPLE A,CPOPJ - MOVEM A,PARNEW ; FORCE PAIR SPACE TO MOVE ON OUT - AOJA C,CPOPJ - -; BLOAT P STACK - -PBLO: HLRE D,P - MOVNS B,D - SUBI D,5 ; FUDGE FOR THIS CALL - SUBI A,(D) - JUMPLE A,CPOPJ - ADDI B,1(P) ; POINT TO DOPE - CAME B,PGROW ; BLOWN? - ADDI B,PDLBUF ; NOPE, POIN TO REAL D.W. - ASH A,-6 ; TO 64 WRD BLOCKS - CAILE A,377 ; IN RANGE? - JRST OUTRNG - DPB A,[111100,,-1(B)] - AOJA C,CPOPJ - -; SET FREMIN - -SFREM: MOVEM A,FREMIN - POPJ P, - -; SET FREDIF - -SFRED: MOVEM A,FREDIF - POPJ P, - -; SET LVAL INCREMENT - -SLVL: IMULI A,6 ; CALCULATE AMOUNT TO GROW B - IDIVI A,64. ; # OF GROW BLOCKS NEEDED - CAIE B,0 ; DOES B HAVE A REMAINDER - ADDI A,1 ; IF SO ADD A BLOCK - MOVEM A,LVLINC - POPJ P, - -; SET GVAL INCREMENT - -SGVL: IDIVI A,16. ; CALCULATE NUMBER OF GROW BLOCKS NEEDED - CAIE B,0 - ADDI A,1 ; COMPENSATE FOR EXTRA - MOVEM A,GVLINC - POPJ P, - -; SET TYPE INCREMENT - -STYP: IDIVI A,32. ; CALCULATE NUMBER OF GROW BLOCKS NEEDED - CAIE B,0 - ADDI A,1 ; COMPENSATE FOR EXTRA - MOVEM A,TYPIC - POPJ P, - -; SET STORAGE INCREMENT - -SSTO: IDIVI A,2000 ; # OF BLOCKS - CAIE B,0 ; REMAINDER? - ADDI A,1 - IMULI A,2000 ; CONVERT BACK TO WORDS - MOVEM A,STORIC - POPJ P, - - -; GET NEXT (FIX) ARG - -NXTFIX: PUSHJ P,GETFIX - ADD AB,[2,,2] - POPJ P, - -; ROUTINE TO GET POS FIXED ARG - -GETFIX: GETYP A,(AB) - CAIE A,TFIX - JRST WRONGT - SKIPGE A,1(AB) - JRST BADNUM - POPJ P, - - -; GET NUMBERS FIXED UP FOR GROWTH FIELDS - -NUMADJ: ADDI A,77 ; ROUND UP - ANDCMI A,77 ; KILL CRAP - MOVE 0,A - MOVNS A ; COMPUTE ADD FACTOR FOR SPEC. POINTER UPDATE - HRLI A,-1(A) - MOVEM A,(B) ; AND STASH IT - MOVE A,0 - ASH A,-6 ; TO 64 WD BLOCKS - CAILE A,377 ; CHECK FIT - JRST OUTRNG - POPJ P, - -; DO SYMPATHETIC GROWTHS - -SGROW1: HLRE 0,D - SUB D,0 - DPB A,[111100,,(D)] - POPJ P, - - ;FUNCTION TO CONSTRUCT A LIST - -MFUNCTION CONS,SUBR - - ENTRY 2 - GETYP A,2(AB) ;GET TYPE OF 2ND ARG - CAIE A,TLIST ;LIST? - JRST WTYP2 ;NO , COMPLAIN - MOVE C,(AB) ; GET THING TO CONS IN - MOVE D,1(AB) - HRRZ E,3(AB) ; AND LIST - PUSHJ P,ICONS ; INTERNAL CONS - JRST FINIS - -; COMPILER CALL TO CONS - -CICONS: SUBM M,(P) - PUSHJ P,ICONS -MPOPJ: SUBM M,(P) - POPJ P, - -; INTERNAL CONS TO NIL--INCONS - -INCONS: MOVEI E,0 - -; INTERNAL CONS--ICONS; C,D VALUE, E CDR - -ICONS: GETYP A,C ; CHECK TYPE OF VAL - PUSHJ P,NWORDT ; # OF WORDS - SOJN A,ICONS1 ; JUMP IF DEFERMENT NEEDED - PUSHJ P,ICELL2 ; NO DEFER, GET 2 WORDS FROM PAIR SPACE - JRST ICONS2 ; NO CORE, GO GC - HRRI C,(E) ; SET UP CDR -ICONS3: MOVEM C,(B) ; AND STORE - MOVEM D,1(B) -TLPOPJ: MOVSI A,TLIST - POPJ P, - -; HERE IF CONSING DEFERRED - -ICONS1: MOVEI A,4 ; NEED 4 WORDS - PUSHJ P,ICELL ; GO GET 'EM - JRST ICONS2 ; NOT THERE, GC - HRLI E,TDEFER ; CDR AND DEFER - MOVEM E,(B) ; STORE - MOVEI E,2(B) ; POINT E TO VAL CELL - HRRZM E,1(B) - MOVEM C,(E) ; STORE VALUE - MOVEM D,1(E) - JRST TLPOPJ - - - -; HERE TO GC ON A CONS - -ICONS2: PUSH TP,C ; SAVE VAL - PUSH TP,D - PUSH TP,$TLIST - PUSH TP,E ; SAVE VITAL STUFF - MOVEM A,GETNUM ; AMOUNT NEEDED - MOVE C,[3,,1] ; INDICATOR FOR AGC - PUSHJ P,AGC ; ATTEMPT TO WIN - SKIPGE A ; SKIP IF WON - PUSHJ P,FULLOS - MOVE D,-2(TP) ; RESTORE VOLATILE STUFF - MOVE C,-3(TP) - MOVE E,(TP) - SUB TP,[4,,4] - JRST ICONS ; BACK TO DRAWING BOARD - -; SUBROUTINE TO ALLOCATE WORDS IN PAIR SPACE. CALLS AGC IF NEEDED - -CELL2: MOVEI A,2 ; USUAL CASE -CELL: PUSHJ P,ICELL ; INTERNAL - JRST .+2 ; LOSER - POPJ P, - - MOVEM A,GETNUM ; AMOUNT REQUIRED - PUSH P,A ; PREVENT AGC DESTRUCTION - MOVE C,[3,,1] ; INDICATOR FOR AGC - PUSHJ P,AGC - SKIPGE A ; SKIP IF WINNER - PUSHJ P,FULLOS ; REPORT TROUBLE - POP P,A - JRST CELL ; AND TRY AGAIN - -; INTERNAL CELL GETTER, SKIPS IF ROO EXISTS, ELSE DOESN'T - -ICELL2: MOVEI A,2 ; MOST LIKELY CAE -ICELL: SKIPE B,RCL - JRST ICELRC ;SEE IF WE CAN RE-USE A RECYCLE CELL - MOVE B,PARTOP ; GET TOP OF PAIRS - ADDI B,(A) ; BUMP - CAMLE B,VECBOT ; SKIP IF OK. - POPJ P, ; LOSE - EXCH B,PARTOP ; SETUP NEW PARTOP AND RETURN POINTER - PUSH P,B ; MODIFY TOTAL # OF FREE WORDS - MOVE B,USEFRE - ADDI B,(A) - MOVEM B,USEFRE - POP P,B - JRST CPOPJ1 ; SKIP RETURN - -ICELRC: CAIE A,2 - JRST ICELL+2 ;IF HE DOESNT WANT TWO, USE OLD METHOD - PUSH P,A - MOVE A,(B) - HRRZM A,RCL - POP P,A - SETZM (B) ;GIVE HIM A CLEAN RECYCLED CELL - SETZM 1(B) - JRST CPOPJ ;THAT IT - -;SUBROUTINES TO RETURN WORDS NEEDED BASED ON TYPE OR SAT - -NWORDT: PUSHJ P,SAT ;GET STORAGE ALLOC TYPE -NWORDS: CAIG A,NUMSAT ; TEMPLATE? - SKIPL MKTBS(A) ;-ENTRY IN TABLE MEANS 2 NEEDED - SKIPA A,[1] ;NEED ONLY 1 - MOVEI A,2 ;NEED 2 - POPJ P, - - ;FUNCTION TO BUILD A LIST OF MANY ELEMENTS - -MFUNCTION LIST,SUBR - ENTRY - - PUSH P,$TLIST -LIST12: HLRE A,AB ;GET -NUM OF ARGS - SKIPE RCL ;SEE IF WE WANT TO DO ONE AT A TIME - JRST LST12R ;TO GET RECYCLED CELLS - MOVNS A ;MAKE IT + - JUMPE A,LISTN ;JUMP IF 0 - PUSHJ P,CELL ;GET NUMBER OF CELLS - PUSH TP,$TAB - PUSH TP,AB - PUSH TP,(P) ;SAVE IT - PUSH TP,B - SUB P,[1,,1] - LSH A,-1 ;NUMBER OF REAL LIST ELEMENTS - -CHAINL: ADDI B,2 ;LOOP TO CHAIN ELEMENTS - HRRZM B,-2(B) ;CHAIN LAST ONE TO NEXT ONE - SOJG A,.-2 ;LOOP TIL ALL DONE - CLEARM B,-2(B) ;SET THE LAST CDR TO NIL - -; NOW LOBEER THE DATA IN TO THE LIST - - MOVE D,AB ; COPY OF ARG POINTER - MOVE B,(TP) ;RESTORE LIS POINTER -LISTLP: GETYP A,(D) ;GET TYPE - PUSHJ P,NWORDT ;GET NUMBER OF WORDS - SOJN A,LDEFER ;NEED TO DEFER POINTER - GETYP A,(D) ;NOW CLOBBER ELEMENTS - HRLM A,(B) - MOVE A,1(D) ;AND VALUE.. - MOVEM A,1(B) -LISTL2: HRRZ B,(B) ;REST B - ADD D,[2,,2] ;STEP ARGS - JUMPL D,LISTLP - - POP TP,B - POP TP,A - SUB TP,[2,,2] ; CLEANUP STACK - JRST FINIS - - -LST12R: ASH A,-1 ;ONE AT A TIME TO GET RECYCLED CELLS - JUMPE A,LISTN - PUSH P,A ;SAVE COUNT ON STACK - SETZB C,D - SETZM E - PUSHJ P,ICONS - MOVE E,B ;LOOP AND CHAIN TOGETHER - AOSGE (P) - JRST .-3 - PUSH TP,-1(P) ;PUSH ON THE TYPE WE WANT - PUSH TP,B - SUB P,[2,,2] ;CLEAN UP AFTER OURSELVES - JRST LISTLP-2 ;AND REJOIN MAIN STREAM - - -; MAKE A DEFERRED POINTER - -LDEFER: PUSH TP,$TLIST ;SAVE CURRENT POINTER - PUSH TP,B - MOVEM D,1(TB) ; SAVE ARG HACKER - PUSHJ P,CELL2 - MOVE D,1(TB) - GETYPF A,(D) ;GET FULL DATA - MOVE C,1(D) - MOVEM A,(B) - MOVEM C,1(B) - MOVE C,(TP) ;RESTORE LIST POINTER - MOVEM B,1(C) ;AND MAKE THIS BE THE VALUE - MOVSI A,TDEFER - HLLM A,(C) ;AND STORE IT - MOVE B,C - SUB TP,[2,,2] - JRST LISTL2 - -LISTN: MOVEI B,0 - POP P,A - JRST FINIS - -; BUILD A FORM - -MFUNCTION FORM,SUBR - - ENTRY - - PUSH P,$TFORM - JRST LIST12 - - ; COMPILERS CALLS TO FORM AND LIST A/ COUNT ELEMENTS ON STACK - -IILIST: SUBM M,(P) - PUSHJ P,IILST - MOVSI A,TLIST - JRST MPOPJ - -IIFORM: SUBM M,(P) - PUSHJ P,IILST - MOVSI A,TFORM - JRST MPOPJ - -IILST: JUMPE A,IILST0 ; NIL WHATSIT - PUSH P,A - MOVEI E,0 -IILST1: POP TP,D - POP TP,C - PUSHJ P,ICONS ; CONS 'EM UP - MOVEI E,(B) - SOSE (P) ; COUNT - JRST IILST1 - - SUB P,[1,,1] - POPJ P, - -IILST0: MOVEI B,0 - POPJ P, - - ;FUNCTION TO BUILD AN IMPLICIT LIST - -MFUNCTION ILIST,SUBR - ENTRY - PUSH P,$TLIST -ILIST2: JUMPGE AB,TFA ;NEED AT LEAST ONE ARG - CAMGE AB,[-4,,0] ;NO MORE THAN TWO ARGS - JRST TMA - PUSHJ P,GETFIX ; GET POS FIX # - JUMPE A,LISTN ;EMPTY LIST ? - CAML AB,[-2,,0] ;ONLY ONE ARG? - JRST LOSEL ;YES - PUSH P,A ;SAVE THE CURRENT VALUE OF LENGTH FOR LOOP ITERATION -ILIST0: PUSH TP,2(AB) - PUSH TP,(AB)3 - MCALL 1,EVAL - PUSH TP,A - PUSH TP,B - SOSLE (P) - JRST ILIST0 - POP P,C -ILIST1: MOVE C,(AB)+1 ;REGOBBLE LENGTH - ACALL C,LIST -ILIST3: POP P,A ; GET FINAL TYPE - JRST FINIS - - -LOSEL: PUSH P,A ; SAVE COUNT - MOVEI E,0 - -LOSEL1: SETZB C,D ; TLOSE,,0 - PUSHJ P,ICONS - MOVEI E,(B) - SOSLE (P) - JRST LOSEL1 - - SUB P,[1,,1] - JRST ILIST3 - -; IMPLICIT FORM - -MFUNCTION IFORM,SUBR - - ENTRY - PUSH P,$TFORM - JRST ILIST2 - - ; IVECTOR AND IUVECTOR--GET VECTOR AND UVECTOR OF COMPUTED VALUES - -MFUNCTION VECTOR,SUBR,[IVECTOR] - - MOVEI C,1 - JRST VECTO3 - -MFUNCTION UVECTOR,SUBR,[IUVECTOR] - - MOVEI C,0 -VECTO3: ENTRY - JUMPGE AB,TFA ; AT LEAST ONE ARG - CAMGE AB,[-4,,0] ; NOT MORE THAN 2 - JRST TMA - PUSHJ P,GETFIX ; GET A POS FIXED NUMBER - LSH A,(C) ; A-> NUMBER OF WORDS - PUSH P,C ; SAVE FOR LATER - PUSHJ P,IBLOCK ; GET BLOCK (TURN ON BIT APPROPRIATELY) - POP P,C - HLRE A,B ; START TO - SUBM B,A ; FIND DOPE WORD - JUMPE C,VECTO4 - MOVSI D,400000 ; GET NOT UNIFORM BIT - MOVEM D,(A) ; INTO DOPE WORD - SKIPA A,$TVEC ; GET TYPE -VECTO4: MOVSI A,TUVEC - CAML AB,[-2,,0] ; SKIP IF ARGS NEED TO BE HACKED - JRST FINIS - JUMPGE B,FINIS ; DON'T EVAL FOR EMPTY CASE - - PUSH TP,A ; SAVE THE VECTOR - PUSH TP,B - PUSH TP,A - PUSH TP,B - - JUMPE C,UINIT - JUMPGE B,FINIS ; EMPTY VECTOR, LEAVE -INLP: PUSHJ P,IEVAL ; EVAL EXPR - MOVEM A,(C) - MOVEM B,1(C) - ADD C,[2,,2] ; BUMP VECTOR - MOVEM C,(TP) - JUMPL C,INLP ; IF MORE DO IT - -GETVEC: MOVE A,-3(TP) - MOVE B,-2(TP) - SUB TP,[4,,4] - JRST FINIS - -; HERE TO FILL UP A UVECTOR - -UINIT: PUSHJ P,IEVAL ; HACK THE 1ST VALUE - GETYP A,A ; GET TYPE - PUSH P,A ; SAVE TYPE - PUSHJ P,NWORDT ; SEE IF IT CAN BE UNIFORMED - SOJN A,CANTUN ; COMPLAIN -STJOIN: MOVE C,(TP) ; RESTORE POINTER - ADD C,1(AB) ; POINT TO DOPE WORD - MOVE A,(P) ; GET TYPE - HRLZM A,(C) ; STORE IN D.W. - MOVE C,(TP) ; GET BACK VECTOR - SKIPE 1(AB) - JRST UINLP1 ; START FILLING UV - JRST GETVE1 - -UINLP: MOVEM C,(TP) ; SAVE PNTR - PUSHJ P,IEVAL ; EVAL THE EXPR - GETYP A,A ; GET EVALED TYPE - CAIE A,@(P) ; WINNER? - JRST WRNGSU ; SERVICE ERROR FOR UVECTOR,STORAGE -UINLP1: MOVEM B,(C) ; STORE - AOBJN C,UINLP -GETVE1: SUB P,[1,,1] - JRST GETVEC ; AND RETURN VECTOR - -IEVAL: PUSH TP,2(AB) - PUSH TP,3(AB) - MCALL 1,EVAL - MOVE C,(TP) - POPJ P, - -; ISTORAGE -- GET STORAGE OF COMPUTED VALUES - -MFUNCTION ISTORAGE,SUBR - ENTRY - JUMPGE AB,TFA - CAMGE AB,[-4,,0] ; AT LEAST ONE ARG - JRST TMA - PUSHJ P,GETFIX ; POSITIVE COUNT FIRST ARG - PUSHJ P,CAFRE ; GET CORE - MOVN B,1(AB) ; -COUNT - HRL A,B ; PUT IN LHW (A) - MOVM B,B ; +COUNT - HRLI B,2(B) ; LENGTH + 2 - ADDI B,(A) ; MAKE POINTER TO DOPE WORDS - HLLZM B,1(B) ; PUT TOTAL LENGTH IN 2ND DOPE - HRRM A,1(B) ; PUT ADDRESS IN RHW (STORE DOES THIS TOO). - MOVE B,A - MOVSI A,TSTORAGE - CAML AB,[-2,,0] ; SECOND ARG TO EVAL? - JRST FINIS ; IF NOT, RETURN EMPTY - PUSH TP,A - PUSH TP,B - PUSH TP,A - PUSH TP,B - PUSHJ P,IEVAL ; EVALUATE FOR FIRST VALUE - GETYP A,A - PUSH P,A ; FOR COMPARISON LATER - PUSHJ P,SAT - CAIN A,S1WORD - JRST STJOIN ;TREAT LIKE A UVECTOR - ; IF NOT 1-WORD TYPES, CANNOT STORE, SO COMPLAIN - PUSHJ P,FREESV ; FREE STORAGE VECTOR - PUSH TP,$TATOM - PUSH TP,EQUOTE DATA-CAN'T-GO-IN-STORAGE - JRST CALER1 - -; FOR STORAGE, MUST FREE THE CORE ELSE IT IS LOST (NO GC) -FREESV: MOVE A,1(AB) ; GET COUNT - ADDI A,2 ; FOR DOPE - HRRZ B,(TP) ; GET ADDRESS - PUSHJ P,CAFRET ; FREE THE CORE - POPJ P, - - ; INTERNAL VECTOR ALLOCATOR. A/SIZE OF VECTOR (NOT INCLUDING DOPE WORDS) - -IBLOK1: ASH A,1 ; TIMES 2 -GIBLOK: TLOA A,400000 ; FUNNY BIT -IBLOCK: TLZ A,400000 ; NO BIT ON - ADDI A,2 ; COMPENSATE FOR DOPE WORDS -IBLOK2: MOVE B,VECBOT ; POINT TO BOTTOM OF SPACE - SUBI B,(A) ; SUBTRACT NEEDED AMOUNT - CAMGE B,PARTOP ; SKIP IF NO GC NEEDED - JRST IVECT1 - EXCH B,VECBOT ; WIN, GET POINTER TO BLOCK AND UPDATE VECBOT - PUSH P,B - MOVE B,USEFRE - ADDI B,(A) - MOVEM B,USEFRE - POP P,B - HRLZM A,-1(B) ; STORE LENGTH IN DOPE WORD - HLLZM A,-2(B) ; AND BIT - HRRO B,VECBOT ; POINT TO START OF VECTOR - TLC B,-3(A) ; SETUP COUNT - HRRI A,TVEC - SKIPL A - HRRI A,TUVEC - MOVSI A,(A) - POPJ P, - -; HERE TO DO A GC ON A VECTOR ALLOCATION - -IVECT1: PUSH P,A ; SAVE DESIRED LENGTH - HRRZM A,GETNUM ; AND STORE AS DESIRED AMOUNT - MOVE C,[4,,1] ; GET INDICATOR FOR AGC - PUSHJ P,AGC - SKIPGE A - PUSHJ P,FULLOS ; LOST, COMPLAIN - POP P,A - JRST IBLOK2 - - -; INTERNAL EVECTOR (CALLED FROM READ) A/ #OF THINGS -; ITEMS ON TOP OF STACK - -IEVECT: ASH A,1 ; TO NUMBER OF WORDS - PUSH P,A - PUSHJ P,IBLOCK ; GET VECTOR - HLRE D,B ; FIND DW - SUBM B,D ; A POINTS TO DW - MOVSI 0,400000 - MOVEM 0,(D) ; CLOBBER NON UNIF BIT - POP P,A ; RESTORE COUNT - JUMPE A,IVEC1 ; 0 LNTH, DONE - MOVEI C,(TP) ; BUILD BLT - SUBI C,(A)-1 ; C POINTS TO 1ST ITEM ON STACK - MOVSI C,(C) - HRRI C,(B) ; B/ SOURCE,,DEST - BLT C,-1(D) ; XFER THE DATA - HRLI A,(A) - SUB TP,A ; FLUSH STACKAGE -IVEC1: MOVSI A,TVEC - POPJ P, - - -; COMPILERS CALL - -CIVEC: SUBM M,(P) - PUSHJ P,IEVECT - JRST MPOPJ - - - ; INTERNAL CALL TO EUVECTOR - -IEUVEC: PUSH P,A ; SAVE LENGTH - PUSHJ P,IBLOCK - MOVE A,(P) - JUMPE A,IEUVE1 ; EMPTY, LEAVE - ASH A,1 ; NOW FIND STACK POSITION - MOVEI C,(TP) ; POINT TO TOP - MOVE D,B ; COPY VEC POINTER - SUBI C,-1(A) ; POINT TO 1ST DATUM - GETYP A,(C) ; CHECK IT - PUSHJ P,NWORDT - SOJN A,CANTUN ; WONT FIT - GETYP E,(C) - -IEUVE2: GETYP 0,(C) ; TYPE OF EL - CAIE 0,(E) ; MATCH? - JRST WRNGUT - MOVE 0,1(C) - MOVEM 0,(D) ; CLOBBER - ADDI C,2 - AOBJN D,IEUVE2 ; LOOP - HRLZM E,(D) ; STORE UTYPE -IEUVE1: POP P,A ; GET COUNY - ASH A,1 ; MUST FLUSH 2 TIMES # OF ELEMENTS - HRLI A,(A) - SUB TP,A ; CLEAN UP STACK - MOVSI A,TUVEC - POPJ P, - -; COMPILER'S CALL - -CIUVEC: SUBM M,(P) - PUSHJ P,IEUVEC - JRST MPOPJ - -MFUNCTION EVECTOR,SUBR,[VECTOR] - ENTRY - HLRE A,AB - MOVNS A - PUSH P,A ;SAVE NUMBER OF WORDS - PUSHJ P,IBLOCK ; GET WORDS - MOVEI D,-1(B) ; SETUP FOR BLT AND DOPE CLOBBER - JUMPGE B,FINISV ;DONT COPY A ZERO LENGTH VECTOR - - HRLI C,(AB) ;START BUILDING BLT POINTER - HRRI C,(B) ;TO ADDRESS - ADDI D,@(P) ;SET D TO FINAL ADDRESS - BLT C,(D) -FINISV: MOVSI 0,400000 - MOVEM 0,1(D) ; MARK AS GENERAL - SUB P,[1,,1] - MOVSI A,TVEC - JRST FINIS - - - - ;EXPLICIT VECTORS FOR THE UNIFORM CSE - -MFUNCTION EUVECTOR,SUBR,[UVECTOR] - - ENTRY - HLRE A,AB ;-NUM OF ARGS - MOVNS A - ASH A,-1 ;NEED HALF AS MANY WORDS - PUSH P,A - JUMPGE AB,EUV1 ; DONT CHECK FOR EMPTY - GETYP A,(AB) ;GET FIRST ARG - PUSHJ P,NWORDT ;SEE IF NEEDS EXTRA WORDS - SOJN A,CANTUN -EUV1: POP P,A - PUSHJ P,IBLOCK ; GET VECT - JUMPGE B,FINISU - - GETYP C,(AB) ;GET THE FIRST TYPE - MOVE D,AB ;COPY THE ARG POINTER - MOVE E,B ;COPY OF RESULT - -EUVLP: GETYP 0,(D) ;GET A TYPE - CAIE 0,(C) ;SAME? - JRST WRNGUT ;NO , LOSE - MOVE 0,1(D) ;GET GOODIE - MOVEM 0,(E) ;CLOBBER - ADD D,[2,,2] ;BUMP ARGS POINTER - AOBJN E,EUVLP - - HRLM C,(E) ;CLOBBER UNIFORM TYPE IN -FINISU: MOVSI A,TUVEC - JRST FINIS - -WRNGSU: GETYP A,-1(TP) - CAIE A,TSTORAGE - JRST WRNGUT ;IF UVECTOR - PUSHJ P,FREESV ;FREE STORAGE VECTOR - PUSH TP,$TATOM - PUSH TP,EQUOTE TYPES-DIFFER-IN-STORAGE-OBJECT - JRST CALER1 - - -WRNGUT: PUSH TP,$TATOM - PUSH TP,EQUOTE TYPES-DIFFER-IN-UNIFORM-VECTOR - JRST CALER1 - -CANTUN: PUSH TP,$TATOM - PUSH TP,EQUOTE DATA-CANT-GO-IN-UNIFORM-VECTOR - JRST CALER1 - -BADNUM: PUSH TP,$TATOM - PUSH TP,EQUOTE NEGATIVE-ARGUMENT - JRST CALER1 - ; FUNCTION TO GROW A VECTOR - -MFUNCTION GROW,SUBR - - ENTRY 3 - - MOVEI D,0 ;STACK HACKING FLAG - GETYP A,(AB) ;FIRST TYPE - PUSHJ P,SAT ;GET STORAGE TYPE - GETYP B,2(AB) ;2ND ARG - CAIE A,STPSTK ;IS IT ASTACK - CAIN A,SPSTK - AOJA D,GRSTCK ;YES, WIN - CAIE A,SNWORD ;UNIFORM VECTOR - CAIN A,S2NWORD ;OR GENERAL -GRSTCK: CAIE B,TFIX ;IS 2ND FIXED - JRST WTYP2 ;COMPLAIN - GETYP B,4(AB) - CAIE B,TFIX ;3RD ARG - JRST WTYP3 ;LOSE - - MOVEI E,1 ;UNIFORM/GENERAL FLAG - CAIE A,SNWORD ;SKIP IF UNIFORM - CAIN A,SPSTK ;DONT SKIP IF UNIFORM PDL - MOVEI E,0 - - HRRZ B,1(AB) ;POINT TO START - HLRE A,1(AB) ;GET -LENGTH - SUB B,A ;POINT TO DOPE WORD - SKIPE D ;SKIP IF NOT STACK - ADDI B,PDLBUF ;FUDGE FOR PDL - HLLZS (B) ;ZERO OUT GROWTH SPECS - SKIPN A,3(AB) ;ANY TOP GROWTH? - JRST GROW1 ;NO, LOOK FOR BOTTOM GROWTH - ASH A,(E) ;MULT BY 2 IF GENERAL - ADDI A,77 ;ROUND TO NEAREST BLOCK - ANDCMI A,77 ;CLEAR LOW ORDER BITS - ASH A,9-6 ;DIVIDE BY 100 AND SHIFT TO POSTION - TRZE A,400000 ;CONVERT TO SIGN MAGNITUDE - MOVNS A - TLNE A,-1 ;SKIP IF NOT TOO BIG - JRST GTOBIG ;ERROR -GROW1: SKIPN C,5(AB) ;CHECK LOW GROWTH - JRST GROW4 ;NONE, SKIP - ASH C,(E) ;GENRAL FUDGE - ADDI C,77 ;ROUND - ANDCMI C,77 ;FUDGE FOR VALUE RETURN - PUSH P,C ;AND SAVE - ASH C,-6 ;DIVIDE BY 100 - TRZE C,400 ;CONVERT TO SIGN MAGNITUDE - MOVNS C - TDNE C,[-1,,777000] ;CHECK FOR OVERFLOW - JRST GTOBIG -GROW2: HLRZ E,1(B) ;GET TOTAL LENGTH OF VECTOR - MOVNI E,-1(E) - HRLI E,(E) ;TO BOTH HALVES - ADDI E,1(B) ;POINTS TO TOP - SKIPE D ;STACK? - ADD E,[PDLBUF,,0] ;YES, FUDGE LENGTH - SKIPL D,(P) ;SHRINKAGE? - JRST GROW3 ;NO, CONTINUE - MOVNS D ;PLUSIFY - HRLI D,(D) ;TO BOTH HALVES - ADD E,D ;POINT TO NEW LOW ADDR -GROW3: IORI A,(C) ;OR TOGETHER - HRRM A,(B) ;DEPOSIT INTO DOPEWORD - PUSH TP,(AB) ;PUSH TYPE - PUSH TP,E ;AND VALUE - JUMPE A,.+3 ;DON'T GC FOR NOTHING - MOVE C,[2,,0] ; GET INDICATOR FOR AGC - PUSHJ P,AGC - JUMPL A,GROFUL - POP P,C ;RESTORE GROWTH - HRLI C,(C) - POP TP,B ;GET VECTOR POINTER - SUB B,C ;POINT TO NEW TOP - POP TP,A - JRST FINIS - -GROFUL: SUB P,[1,,1] ; CLEAN UP STACK - SUB TP,[2,,2] - PUSHJ P,FULLOS - JRST GROW - -GTOBIG: PUSH TP,$TATOM - PUSH TP,EQUOTE ATTEMPT-TO-GROW-VECTOR-TOO-MUCH - JRST CALER1 -GROW4: PUSH P,[0] ;0 BOTTOM GROWTH - JRST GROW2 - -FULLOS: PUSH TP,$TATOM ; GENERATE ERROR - PUSH TP,@ERRTB(A) - AOJL A,CALER1 ; IF BAD, CALL ERROR - SKIPN GCMONF - POPJ P, - PUSH TP,TTOCHN(TVP) ; FORCE MESSAGES TO TTY - PUSH TP,TTOCHN+1(TVP) - PUSH TP,TTOCHN(TVP) ; FORCE MESSAGES TO TTY - PUSH TP,TTOCHN+1(TVP) - MCALL 1,TERPRI ; JUST PRINT MESSAGE - MCALL 2,PRINC - POPJ P, - - - EQUOTE STILL-NO-STORAGE - EQUOTE NO-STORAGE - EQUOTE STORAGE-LOW -ERRTB==. - ; SUBROUTINE TO BUILD CHARACTER STRING GOODIES - -MFUNCTION STRING,SUBR - - ENTRY - - MOVE B,AB ;COPY ARG POINTER - MOVEI C,0 ;INITIALIZE COUNTER - PUSH TP,$TAB ;SAVE A COPY - PUSH TP,B - HLRE A,B ; GET # OF ARGS - MOVNS A - ASH A,-1 ; 1/2 FOR # OF ARGS - PUSHJ P,IISTRN - JRST FINIS - -IISTRN: SKIPN E,A ; SKIP IF ARGS EXIST - JRST MAKSTR ; ALL DONE - -STRIN2: GETYP D,(B) ;GET TYPE CODE - CAIN D,TCHRS ;SINGLE CHARACTER? - AOJA C,STRIN1 - CAIE D,TCHSTR ;OR STRING - JRST WRONGT ;NEITHER - HRRZ D,(B) ; GET CHAR COUNT - ADDI C,(D) ; AND BUMP - -STRIN1: ADD B,[2,,2] - SOJG A,STRIN2 - -; NOW GET THE NECESSARY VECTOR - -MAKSTR: PUSH P,C ; SAVE CHAR COUNT - PUSH P,E ; SAVE ARG COUNT - MOVEI A,4(C) ; LNTH+4 TO A - IDIVI A,5 - PUSHJ P,IBLOCK - - POP P,A - JUMPGE B,DONEC ; 0 LENGTH, NO STRING - HRLI B,440700 ;CONVERT B TO A BYTE POINTER - MOVE C,(TP) ; POINT TO ARGS AGAIN - -NXTRG1: GETYP D,(C) ;GET AN ARG - CAIE D,TCHRS - JRST TRYSTR - MOVE D,1(C) ; GET IT - IDPB D,B ;AND DEPOSIT IT - JRST NXTARG - -TRYSTR: MOVE E,1(C) ;GET BYTER - HRRZ 0,(C) ;AND COUNT -NXTCHR: SOJL 0,NXTARG ; IF RUNOUT, GET NEXT ARG - ILDB D,E ;AND GET NEXT - IDPB D,B ; AND DEPOSIT SAME - JRST NXTCHR - -NXTARG: ADD C,[2,,2] ;BUMP ARG POINTER - SOJG A,NXTRG1 - ADDI B,1 - -DONEC: MOVSI C,TCHRS - HLLM C,(B) ;AND CLOBBER AWAY - HLRZ C,1(B) ;GET LENGTH BACK - POP P,A - HRLI A,TCHSTR - SUBI B,-2(C) - HRLI B,440700 ;MAKE A BYTE POINTER - POPJ P, - -; COMPILER'S CALL TO MAKE A STRING - -CISTNG: SUBM M,(P) - MOVEI C,0 ; INIT CHAR COUNTER - MOVEI B,(A) ; SET UP STACK POINTER - ASH B,1 ; * 2 FOR NO. OF SLOTS - HRLI B,(B) - SUBM TP,B ; B POINTS TO ARGS - ADD B,[1,,1] - PUSH TP,$TTP - PUSH TP,B - PUSHJ P,IISTRN ; MAKE IT HAPPEN - POP TP,TP ; FLUSH ARGS - SUB TP,[1,,1] - JRST MPOPJ - ;BUILD IMPLICT STRING - -MFUNCTION ISTRING,SUBR - - ENTRY - JUMPGE AB,TFA ; TOO FEW ARGS - CAMGE AB,[-4,,0] ; VERIFY NOT TOO MANY ARGS - JRST TMA - PUSHJ P,GETFIX - ADDI A,4 - IDIVI A,5 ; # OF WORDS NEEDED TO A - PUSH TP,$TFIX - PUSH TP,A - MCALL 1,UVECTOR ; GET SAME - HLRE C,B ; -LENGTH TO C - SUBM B,C ; LOCN OF DOPE WORD TO C - HRLI D,TCHRS ; CLOBBER ITS TYPE - HLLM D,(C) - MOVSI A,TCHSTR - HRR A,1(AB) ; SETUP TYPE'S RH - HRLI B,440700 ; AND BYTE POINTER - SKIPE (AB)+1 ; SKIP IF NO CHARACTERS TO DEPOSIT - CAML AB,[-2,,0] ; SKIP IF 2 ARGS GIVEN - JRST FINIS - PUSH TP,A ;SAVE OUR STRING - PUSH TP,B - PUSH TP,A ;SAVE A TEMPORARY CLOBBER POINTER - PUSH TP,B - PUSH P,(AB)1 ;SAVE COUNT -CLOBST: PUSH TP,(AB)+2 - PUSH TP,(AB)+3 - MCALL 1,EVAL - GETYP C,A ; CHECK IT - CAIE C,TCHRS ; MUST BE A CHARACTER - JRST WTYP2 - IDPB B,(TP) ;CLOBBER - SOSLE (P) ;FINISHED? - JRST CLOBST ;NO - SUB P,[1,,1] - SUB TP,[4,,4] - MOVE A,(TP)+1 - MOVE B,(TP)+2 - JRST FINIS - - - AGC": -;SET FLAG FOR INTERRUPT HANDLER - - SETZB M,RCL ; CLEAR OUT RECYCLE LIST CELLS, AND RSUBR BASE PNTR - PUSH P,B - PUSH P,A - PUSH P,C ; SAVE C - PUSHJ P,CTIME ; GET TIME FOR GIN-GOUT - MOVEM B,GCTIM ; SAVE FOR LATER - MOVEI B,[ASCIZ /GIN /] - SKIPE GCMONF - PUSHJ P,MSGTYP -NOMON1: HRRZ C,(P) ; GET CAUSE OF GC INDICATOR - MOVE B,GCNO(C) ; ADD 1 TO COUNT OF GC'S CAUSED BY GIVEN REASON - ADDI B,1 - MOVEM B,GCNO(C) - MOVEM C,GCCAUS ; SAVE CAUSE OF GC - SKIPN GCMONF ; MONITORING - JRST NOMON2 - MOVE B,MSGGCT(C) ; GET CAUSE MESSAGE - PUSHJ P,MSGTYP -NOMON2: HLRZ C,(P) ; FIND OUT WHO CAUSED THE GC - MOVEM C,GCCALL ; SAVE CALLER OF GC - SKIPN GCMONF ; MONITORING - JRST NOMON3 - MOVE B,MSGGFT(C) - PUSHJ P,MSGTYP -NOMON3: SUB P,[1,,1] ; POP OFF C - POP P,A - POP P,B - JRST .+1 -AAGC: SETZB M,RCL ; ALTERNATE GC-ENTRY POINT FOR INITIALIZATION -INITGC: SETOM GCFLG - -;SAVE AC'S - IRP AC,,[0,A,B,C,D,E,P,R,M,SP,TP,TB,AB,TVP,PVP] - MOVEM AC,AC!STO"+1(PVP) - TERMIN - -; FUDGE NOWFRE FOR LATER WINNING - - MOVE 0,NOWFRE - SUB 0,VECBOT - ADD 0,PARTOP - MOVEM 0,NOWFRE - -; IF IN A PURE RSUBR, FIND ITS LENGTH AND FUDGE ITS LRU - - HRRZ A,FSAV(TB) ; GET NAME OF CURRENT GOODIE - SETZM CURPLN ; CLEAR FOR NONE - CAML A,PURTOP ; IF LESS THAN TOP OF PURE ASSUME RSUBR - JRST NRSUBR - GETYP 0,(A) ; SEE IF PURE - CAIE 0,TPCODE ; SKIP IF IT IS - JRST NRSUBR - HLRZ B,1(A) ; GET SLOT INDICATION - ADD B,PURVEC+1(TVP) ; POINT TO SLOT - HRROS 2(B) ; MUNG AGE - HLRE A,1(B) ; - LENGTH TO A - MOVNM A,CURPLN ; AND STORE -NRSUBR: - -;SET UP E TO POINT TO TYPE VECTOR - GETYP E,TYPVEC(TVP) - CAIE E,TVEC - JRST AGCE1 - HRRZ TYPNT,TYPVEC+1(TVP) - HRLI TYPNT,B - -CHPDL: MOVE D,P ; SAVE FOR LATER - MOVE P,GCPDL ;GET GC'S PDL -CORGET: MOVE A,P.TOP ; UPDATE CORTOP - MOVEM A,CORTOP - MOVE A,VECTOP ; ROOM BETWEEN CORTOP AND VECTOP IS GC MARK PDL - SUB A,CORTOP - MOVSS A ; BUILD A PDL POINTER - ADD A,VECTOP - JUMPGE A,TRYCOR ; NO ROOM, GO GET SOME - MOVE P,A ; SET UP PDL POINTER - -;FENCE POST PDLS AND CHECK IF ANY SHOULD BE SHRUNK - - MOVEI A,(TB) ;POINT TO CURRENT FRAME IN PROCESS - PUSHJ P,FRMUNG ;AND MUNG IT - MOVE A,TP ;THEN TEMPORARY PDL - PUSHJ P,PDLCHK - MOVE A,PSTO+1(PVP) ;AND UNMARKED P STACK - PUSHJ P,PDLCHP - - ; FIRST CREATE INFERIOR TO HOLD NEW PAGES - -INFCRT: MOVE A,PARBOT ; GENERATE NEW PARBOT AND PARNEW - ADD A,PARNEW - ADDI A,1777 - ANDCMI A,1777 ; EVEN PAGE BOUNDARY - HRRM A,BOTNEW ; INTO POINTER WORD - MOVEM A,WNDBOT - MOVEI 0,2000(A) ; BOUNDS OF WINDOW - MOVEM 0,WNDTOP - SUB A,PARBOT - MOVEM A,PARNEW ; FIXED UP PARNEW - HRRZ A,BOTNEW ; GET PAGE TO START INF AT - ASH A,-10. ; TO PAGES - PUSHJ P,%GCJOB ; GET PAGE HOLDER - MOVSI FPTR,-2000 ; FIX UP FRONTIER POINTER - -;MARK PHASE: MARK ALL LISTS AND VECTORS -;POINTED TO WITH ONE BIT IN SIGN BIT -;START AT TRANSFER VECTOR - - SETZB LPVP,VECNUM ;CLEAR NUMBER OF VECTOR WORDS - SETZB PARNUM ;CLEAR NUMBER OF PAIRS - MOVEI 0,NGCS ; SEE IF NEED HAIR - SOSGE GCHAIR - MOVEM 0,GCHAIR ; RESUME COUNTING - SETZM GREW ; ASSUME NO GROW/SHRINK - SETZM SHRUNK - MOVSI D,400000 ;SIGN BIT FOR MARKING - MOVE A,ASOVEC+1(TVP) ;MARK ASSOC. VECTOR NOW - PUSHJ P,PRMRK ; PRE-MARK - MOVE A,GLOBSP+1(TVP) - PUSHJ P,PRMRK - -; HAIR TO DO AUTO CHANNEL CLOSE - - MOVEI 0,N.CHNS-1 ; NUMBER OF CHANNELS - MOVEI A,CHNL1(TVP) ; 1ST SLOT - - SKIPE 1(A) ; NOW A CHANNEL? - SETZM (A) ; DON'T MARK AS CHANNELS - ADDI A,2 - SOJG 0,.-3 - - MOVE A,PVP ;START AT PROCESS VECTOR - MOVEI B,TPVP ;IT IS A PROCESS VECTOR - PUSHJ P,MARK ;AND MARK THIS VECTOR - MOVEI B,TPVP - MOVE A,MAINPR ; MARK MAIN PROCES EVEN IF SWAPPED OUT - PUSHJ P,MARK - -; ASSOCIATION AND VALUE FLUSHING PHASE - - SKIPN GCHAIR ; ONLY IF HAIR - PUSHJ P,VALFLS - - SKIPE GCHAIR ; IF NOT HAIR, DO CHANNELS NOW - PUSHJ P,CHNFLS - -;OPTIONAL RETIMING PHASE -;THIS HAS BEEN FLUSHED BECAUSE OF PLANNER - REPEAT 0,[ - SKIPE A,TIMOUT ;ANY TIME OVERFLOWS - PUSHJ P,RETIME ;YES, RE-CALIBRATE THEM -] -;UPDATE PARTOP - - MOVEI A,@BOTNEW - SUB A,PARNEW - MOVEM A,PARTOP - -;CORE ADJUSTMENT PHASE - MOVE P,GCPDL ; GET A PDL - SETZM CORSET ;CLEAR LATER CORE SETTING - PUSHJ P,CORADJ ;AND MAKE CORE ADJUSTMENTS - -;RELOCATION ESTABLISHMENT PHASE -;1 -- IN VECTOR SPACE, ESTABLISH POINTERS TO TOP OF CORE - MOVE A,VECTOP" ;START AT TOP OF VECTOR SPACE - MOVE B,VECNEW" ;AND SET TO INITIAL OFFSET - SUBI A,1 ;POINT TO DOPE WORDS - ADDI B,(A) ; WHERE TOP VECTOR WILL GO - PUSHJ P,VECREL ;AND ESTABLISH RELOCATION FOR VECTORS - SUBI B,(A) ; RE-RELATIVIZE VECNEW - MOVEM B,VECNEW ;SAVE FINAL OFFSET - - - ; MAP NEW PAIR SPACE IN FOR PAIR SPACE UPDATE - - MOVE B,PARTOP ; POINT TO TOP OF PAIRS - ADDI B,2000 - ANDCMI B,1777 - CAMGE B,VECBOT ; OVERLAP VECTORS - JRST DOMAP - MOVE C,VECBOT - ANDI C,1777 ; REL TO PAGE - ADDI C,FRONT ; 1ST DEST WORD - HRL C,VECBOT - BLT C,FRONT+1777 ; MUNG IT - -DOMAP: ASH B,-10. ; TO PAGES - MOVE A,PARBOT - MOVEI C,(A) ; COMPUTE HIS TOP - ADD C,PARNEW - ASH C,-10. - ASH A,-10. - SUBM A,B ; B==> - # OF PAGES - HRLI A,(B) ; AOBJN TO SOURCE AND DEST - MOVE B,A ; IN CASE OF FUNNY - HRRI B,(C) ; MAP HIS POSSIBLE HIGHER OR LOWER PAGES - PUSHJ P,%INFMP ; NOW FLUSH INF AND MAKE HIS CORE MINE - - ;POINTER UPDATE PHASE -;1 -- UPDATE ALL PAIR POINTERS - MOVE A,PARBOT ;START AT BOTTOM OF PAIR SPACE - PUSHJ P,PARUPD ;AND UPDATE ALL PAIR POINTERS - -;2 -- UPDATE ALL VECTORS - MOVE A,VECTOP ;START AT TOP OF VECTOR SPACE - PUSHJ P,VECUPD ;AND UPDATE THE POINTERS - MOVE A,CODTOP ; NOW UPDATE STORAGE STUFF - MOVEI D,0 ; FAKE OUT TO NOT UNMARK - PUSHJ P,STOUP - MOVSI D,400000 - -;3 -- UPDATE THE PVP AC - MOVEI A,PVP-1 ;SET LOC TO POINT TO PVP - MOVE C,PVP ;GET THE DATUM - PUSHJ P,NWRDUP ;AND UPDATE THIS VALUE -;4 -- UPDATE THE MAIN PROCESS POINTER - MOVEI A,MAINPR-1 ;POINT TO MAIN PROCESS POINTER - MOVE C,MAINPR ;GET CONTENTS IN C - PUSHJ P,NWRDUP ;AND UPDATE IT -;DATA MOVEMMENT ANDCLEANUP PHASE - -;1 -- ADJUST FOR SHRINKING VECTORS - MOVE A,VECTOP ;VECTOR SHRINKING PHASE - SKIPE SHRUNK ; SKIP IF NO SHRINKERS - PUSHJ P,VECSH ;GO SHRINK ANY SHRINKERS - -;2 -- MOVE VECTORS (AND LIST ELEMENTS) - MOVE A,VECTOP ;START AT TOP OF VECTOR SPACE - PUSHJ P,VECMOVE ;AND MOVE THE VECTORS - MOVE A,VECNEW ;GET FINAL CHANGE TO VECBOT - ADDM A,VECBOT ;OFFSET VECBOT TO ITS NEW PLACE - MOVE A,CORTOP ;GET NEW VALUE FOR TOP OF VECTOR SPACE - SUBI A,2000 ; FUDGE FOR MARK PDL - MOVEM A,VECTOP ;AND UPDATE VECTOP - -;3 -- CLEANUP VECTORS (NOTE A CONTAINS NEW VECTOP) - - SKIPE GREW ; SKIP IF NO GROWERS - PUSHJ P,VECZER ; - PUSHJ P,STOGC - -;GARBAGE ZEROING PHASE -GARZER: MOVE A,PARTOP ;FIRST WORD OF GARBAGE IS AFTER PAIR SPACE - HRLS A ;GET FIRST ADDRESS IN LEFT HALF - MOVE B,VECBOT ;LAST ADDRESS OF GARBAGE + 1 - CLEARM (A) ;ZERO THE FIRST WORD - ADDI A,1 ;MAKE A A BLT POINTER - BLT A,-1(B) ;AND COPY ZEROES INTO REST OF AREA - -;FINAL CORE ADJUSTMENT - SKIPE A,CORSET ;IFLESS CORE NEEDED - PUSHJ P,CORADL ;GIVE SOME AWAY. - -;NOW REHASH THE ASSOCIATIONS BASED ON NEW VALUES - - PUSHJ P,REHASH - - ;RESTORE AC'S -TRYCOX: MOVE 0,VECBOT - SUB 0,PARTOP - ADDM 0,NOWFRE - SKIPN GCMONF - JRST NOMONO - MOVEI B,[ASCIZ /GOUT /] - PUSHJ P,MSGTYP -NOMONO: IRP AC,,[0,A,B,C,D,E,P,R,M,SP,TP,TB,AB,PVP,TVP] - MOVE AC,AC!STO+1(PVP) - TERMIN -; CLOSING ROUTINE FOR G-C - PUSH P,A ; SAVE AC'C - PUSH P,B - PUSH P,C - PUSH P,D - PUSHJ P,CTIME - PUSHJ P,FIXSEN ; OUTPUT TIME - SKIPN GCMONF - JRST GCCONT - MOVEI A,15 ; OUTPUT C/R LINE-FEED - PUSHJ P,MTYO - MOVEI A,12 - PUSHJ P,MTYO -GCCONT: POP P,D ; RESTORE AC'C - POP P,C - POP P,B - POP P,A - MOVE A,GCDANG ; ERROR LEVELS TO ACS - ADD A,GCDNTG - SETZM GCDANG ; NOW CLEAR SAME - SETZM GCDNTG - JUMPGE A,AGCWIN - SKIPN GCHAIR ; WAS IT A FLUSHER? - JRST AGCWIN ; YES, NO MORE AVAILABLE - MOVEI A,1 - MOVEM A,GCHAIR ; RE-DO WITH HAIR - MOVE A,SPARNW ; RESET PARNEW - MOVEM A,PARNEW - SETZM SPARNW - MOVE C,[11,10.] ; INDICATOR FOR AGC - JRST AGC ; TRY ONCE MORE - -AGCWIN: SETZM PARNEW ;CLEAR FOR NEXT AGC CALL - SETZM GETNUM ;ALSO CLEAR THIS - SETZM GCFLG - - JUMPGE P,RBLDM ; DONT LOSE ON BLOWN PDLS - JUMPGE TP,RBLDM - CAMGE A,[-1] ; SKIP IF GOOD NEWS - JRST RBLDM - SETZM PGROW ; CLEAR GROWTH - SETZM TPGROW - SETOM GCHAPN ; INDICATE A GC HAS HAPPENED - SETOM INTFLG ; AND REQUEST AN INTERRUPT - SETZM GCDOWN - -RBLDM: JUMPGE R,CPOPJ - SKIPGE M,1(R) ; SKIP IF FUNNY - POPJ P, - - HLRS M - ADD M,PURVEC+1(TVP) - SKIPL M,1(M) - POPJ P, - PUSH P,0 - HRRZ 0,1(R) - ADD M,0 - POP P,0 -CPOPJ: POPJ P, - - -AGCE1: FATAL AGC--TYPE VECTOR NOT OF TYPE VECTOR - - ; CONVERSION FROM FLOAT TO DECIMAL. X 100 AND SEND OUT WITH APPROPRIATELY PLACED DECIMAL -; POINT. - -FIXSEN: PUSH P,B ; SAVE TIME - MOVEI B,[ASCIZ /TIME= /] - SKIPE GCMONF - PUSHJ P,MSGTYP ; PRINT OUT MESSAGE - POP P,B ; RESTORE B - FSBR B,GCTIM ; GET TIME ELAPSED - MOVEM B,GCTIM ; SAVE ELAPSED TIME FOR INT-HANDLER - SKIPN GCMONF - POPJ P, - FMPRI B,(100.0) ; CONVERT TO FIX - MULI B,400 - TSC B,B - ASH C,-163.(B) - MOVEI A,1 ; INITIALIZE COUNT OF CHARACTERS FOR PUTTING OUT TIME - PUSH P,C - IDIVI C,10. ; START COUNTING - JUMPLE C,.+2 - AOJA A,.-2 - POP P,C - CAIN A,1 ; SEE IF THERE IS ONLY ONE CHARACTER - JRST DOT1 -FIXOUT: IDIVI C,10. ; RECOVER NUMBER - HRLM D,(P) - SKIPE C - PUSHJ P,FIXOUT - PUSH P,A ; SAVE A - CAIN A,2 ; DECIMAL POINT HERE? - JRST DOT2 -FIX1: HLRZ A,(P)-1 ; GET NUMBER - ADDI A,60 ; MAKE IT A CHARACTER - PUSHJ P,MTYO ; OUT IT GOES - POP P,A - SOJ A, - POPJ P, -DOT1: MOVEI A,". ; OUTPUT DECIMAL POINT AND PADDING 0 - PUSHJ P,MTYO - MOVEI A,"0 - PUSHJ P,MTYO - JRST FIXOUT ; CONTINUE -DOT2: MOVEI A,". ; OUTPUT DECIMAL POINT - PUSHJ P,MTYO - JRST FIX1 - - ; INITIAL CORE ADJUSTMENT TO OBTAIN SPACE -; FOR MARK PHASE PDL - -TRYCOR: MOVEI A,2000 - ADDB A,CORTOP ; TRY AND GET 1 BLOCK - ASH A,-10. - MOVEI E,(A) ; SAVE FOR LOOPER - PUSHJ P,P.CORE ; GET CORE - JRST TRYCO2 ; FAILED, TAKE MORE ACTION - JRST CORGET - -TRYCO2: MOVNI A,2000 ; FIXUP CORTOP - ADDM A,CORTOP -TRYCO3: MOVE 0,TPGROW - ADD 0,PGROW ; 0/ NEQ 0 IF STACK BLEW - SKIPGE TP ; SKIP IF TP BLOWN - SKIPL PSTO+1(PVP) ; SKIP IF P WINS - MOVEI 0,1 - SKIPN 0 - MOVEI B,[ASCIZ / -CORE NEEDED: - TYPE C TO KEEP TRYING - TYPE N TO GET MUDDLE ERROR - TYPE V TO RETURN TO MONITOR -/] - SKIPE 0 - MOVEI B,[ASCIZ / -CORE NEEDED: - TYPE C TO KEEP TRYING - TYPE V TO RETURN TO MONITOR -/] - PUSH P,0 - PUSHJ P,MSGTYP - SETOM GCFLCH ; TELL INTERRUPT HANDLER TO .ITYIC - PUSHJ P,MTYI - PUSHJ P,UPLO ; IN CASE LOWER CASE TYPED - SETZM GCFLCH - POP P,0 - CAIN A,"C - JRST TRYCO4 - CAIN A,"N - JUMPE 0,TRYCO5 - CAIN A,"V - FATAL CORE LOSSAGE - JRST TRYCO3 - -UPLO: CAIL A,"a - CAILE A,"z - POPJ P, - SUBI A,40 - POPJ P, - -TRYCO4: MOVEI A,(E) -TRYCO9: MOVEI B,1 ; SLEEP AND CORE UNTIL WINNAGE - EXCH A,B - PUSHJ P,%SLEEP ; SLEEP A WHILE - EXCH A,B - PUSHJ P,P.CORE - JRST TRYCO9 - - MOVEI B,[ASCIZ / -WIN! -/] - PUSHJ P,MSGTYP - JRST CORGET - -TRYCO5: MOVNI A,3 ; GIVE WORST ERROR RETURN - MOVEM A,GCDANG - JRST TRYCOX - - - ; SUBROUTINE TO CHECK SIZE OF PDLS AND DO FENCEPOSTING - -PDLCHK: JUMPGE A,CPOPJ - HLRE B,A ;GET NEGATIVE COUNT - MOVE C,A ;SAVE A COPY OF PDL POINTER - SUBI A,-1(B) ;LOCATE DOPE WORD PAIR - HRRZS A ; ISOLATE POINTER - CAME A,TPGROW ;GROWING? - ADDI A,PDLBUF ;NO, POINT TO REAL DOPE WORD - HLRZ D,(A) ;GET COUNT FROM DOPE WORD - MOVNS B ;GET POSITIVE AMOUNT LEFT - SUBI D,2(B) ; PDL FULL? - JUMPE D,NOFENC ;YES NO FENCE POSTING - SETOM 1(C) ;CLOBBER TOP WORD - SOJE D,NOFENC ;STILL MORE? - MOVSI D,1(C) ;YES, SET UP TO BLT FENCE POSTS - HRRI D,2(C) - BLT D,-2(A) ;FENCE POST ALL EXCEPT DOPE WORDS - - -NOFENC: CAIG B,TPMAX ;NOW CHECK SIZE - CAIG B,TPMIN - JRST MUNGTP ;TOO BIG OR TOO SMALL - POPJ P, - -MUNGTP: SUBI B,TPGOOD ;FIND DELTA TP -MUNG3: MOVE C,-1(A) ;IS GROWTH ALREADY SPECIFIED - TRNE C,777000 ;SKIP IF NOT - POPJ P, ;ASSUME GROWTH GIVEN WILL WIN - - ASH B,-6 ;CONVERT TO NUMBER OF BLOCKS - JUMPLE B,MUNGT1 - CAILE B,377 ; SKIP IF BELOW MAX - MOVEI B,377 ; ELSE USE MAX - TRO B,400 ;TURN ON SHRINK BIT - JRST MUNGT2 -MUNGT1: MOVMS B - ANDI B,377 -MUNGT2: DPB B,[111100,,-1(A)] ;STORE IN DOPE WORD - POPJ P, - -; CHECK UNMARKED STACK (NO NEED TO FENCE POST) - -PDLCHP: HLRE B,A ;-LENGTH TO B - MOVE C,A - SUBI A,-1(B) ;POINT TO DOPE WORD - HRRZS A ;ISOLATE POINTER - CAME A,PGROW ;GROWING? - ADDI A,PDLBUF ;NO, POINT TO REAL DOPE WORD - MOVMS B ;PLUS LENGTH - HLRZ D,(A) ; D.W. LENGTH - SUBI D,2(B) ; PDL FULL - JUMPE D,NOPF - SETOM 1(C) ; START FENECE POST - SOJE D,NOPF ; 1 WORD? - MOVSI D,1(C) - HRRI D,2(C) - BLT D,-2(A) - -NOPF: CAIG B,PMAX ;TOO BIG? - CAIG B,PMIN ;OR TOO LITTLE - JRST .+2 ;YES, MUNG IT - POPJ P, - SUBI B,PGOOD - JRST MUNG3 - -;THIS ROUTINE MAKES SURE CURRENT FRAME MAKES SENSE -FRMUNG: MOVEM D,PSAV(A) - MOVEM SP,SPSAV(A) - MOVEM TP,TPSAV(A) ;SAVE FOR MARKING - POPJ P, - -; ROUTINE TO PRE MARK SPECIAL HACKS - -PRMRK: SKIPE GCHAIR ; FLUSH IF NO HAIR - POPJ P, - HLRE B,A - SUBI A,(B) ;POINT TO DOPE WORD - HLRZ B,1(A) ; GET LNTH - ADDM B,VECNUM ; AND UPDATE VECNUM - LDB B,[111100,,(A)] ; GET GROWTHS - TRZE B,400 ; SIGN HACK - MOVNS B - ASH B,6 ; TO WORDS - ADDM B,VECNUM - LDB 0,[001100,,(A)] - TRZE 0,400 - MOVNS 0 - ASH 0,6 - ADDM 0,VECNUM - PUSHJ P,GSHFLG ; SET GROW FLAGS - IORM D,1(A) ;AND MARK - POPJ P, - -; SET UP FLAGS FOR OPTIOANAL GROW/SHRINK PHASES - -GSHFLG: SKIPG B - SKIPLE 0 - SETOM GREW - SKIPL B - SKIPGE 0 - SETOM SHRUNK - POPJ P, - - ;GENERAL MARK SUBROUTINE. CALLED TO MARK ALL THINGS -; A/ GOODIE TO MARK FROM -; B/ TYPE OF A (IN RH) -; C/ TYPE,DATUM PAIR POINTER - -MARK2: HLRZ B,(C) ;GET TYPE -MARK1: MOVE A,1(C) ;GET GOODIE -MARK: JUMPE A,CPOPJ ; NEVER MARK 0 - MOVEI 0,(A) - CAIL 0,@PURBOT ; DONT MARK PURE STUFF - POPJ P, - PUSH P,A ;SAVE GOODIE - HRLM C,-1(P) ;AND POINTER TO IT - ANDI B,TYPMSK ; FLUSH MONITORS - LSH B,1 ;TIMES 2 TO GET SAT - HRRZ B,@TYPNT ;GET SAT - ANDI B,SATMSK - CAIG B,NUMSAT ; SKIP IF TEMPLATE DATA - JRST @MKTBS(B) ;AND GO MARK - JRST TD.MRK - -; DISPATCH TABLE FOR MARK PHASE ("SETZ'D" ENTRIES MUST BE DEFERRED) - -DISTBS MKTBS,GCRET,[[S2WORD,PAIRMK],[S2DEFR,DEFMK],[SNWORD,VECTMK] -[STPSTK,TPMK],[SARGS,],[S2NWORD,VECTMK],[SPSTK,TPMK],[SSTORE,VECTMK] -[SFRAME,],[SBYTE,],[SATOM,ATOMK],[SPVP,VECTMK],[SGATOM,GATOMK] -[SLOCID,],[SCHSTR,],[SASOC,ASMRK],[SLOCL,PAIRMK] -[SLOCA,],[SLOCV,VECTMK],[SLOCU,VECTMK],[SLOCS,],[SLOCN,ASMRK]] - - -;HERE TO MARK THAT WHICH IS POINTED TO BY A DEFERRED POINTER - -DEFMK: TLOA TYPNT,400000 ;USE SIGN BIT AS FLAG - -;HERE TO MARK LIST ELEMENTS - -PAIRMK: TLZ TYPNT,400000 ;TURN OF DEFER BIT - PUSH P,[0] ; WILL HOLD BACK PNTR - MOVEI C,(A) ;POINT TO LIST -PAIRM1: CAMGE C,PARTOP ;CHECK FOR BEING IN BOUNDS - CAMGE C,PARBOT - FATAL AGC--MARKED PAIR OUTSIDE PAIR SPACE - SKIPGE B,(C) ;SKIP IF NOT MARKED - JRST RETNEW ;ALREADY MARKED, RETURN - IORM D,(C) ;MARK IT - AOS PARNUM - MOVEM B,FRONT(FPTR) ; STORE 1ST WORD - MOVE 0,1(C) ; AND 2D - MOVEM 0,FRONT+1(FPTR) - ADD FPTR,[2,,2] ; MOVE ALONG IN FRONTIER - JUMPL FPTR,PAIRM2 ; NOD NEED FOR NEW CORE - -; HERE TO EXTEND THE FRONTIER - - HRRZ A,BOTNEW ; CURRENT BOTTOM OF WINDOW IN INF - ADDI A,2000 ; MOVE IT UP - HRRM A,BOTNEW - ASH A,-10. ; TO PAGES -SYSLO1: PUSHJ P,%GETIP ; GET PAGE - PUSHJ P,%SHFNT ; AND SHARE IT - MOVSI FPTR,-2000 - -PAIRM2: MOVEI A,@BOTNEW ; GET INF ADDR - SUBI A,2 - HRRM A,(C) ; LEAVE A POINTER TO NEW HOME - HRRZ E,(P) ; GET BACK POINTER - JUMPE E,PAIRM7 ; 1ST ONE, NEW FIXUP - MOVSI 0,(HRRM) ; INS FOR CLOBBER - PUSHJ P,SMINF ; SMASH INF'S CORE IMAGE -PAIRM4: MOVEM A,(P) ; NEW BACK POINTER - JUMPL TYPNT,DEFDO ;GO HANDLE DEFERRED POINTER - HRLM B,(P) ; SAVE OLD CDR - PUSHJ P,MARK2 ;MARK THIS DATUM - HRRZ E,(P) ; SMASH CAR IN CASE CHANGED - ADDI E,1 - MOVSI 0,(MOVEM) - PUSHJ P,SMINF - HLRZ C,(P) ;GET CDR OF LIST - CAIGE C,@PURBOT ; SKIP IF PURE (I.E. DONT MARK) - JUMPN C,PAIRM1 ;IF NOT NIL, MARK IT -GCRETP: SUB P,[1,,1] - -GCRET: TLZ TYPNT,400000 ;FOR PAIRMKS BENEFIT - HLRZ C,-1(P) ;RESTORE C - POP P,A - POPJ P, ;AND RETURN TO CALLER - -;HERE TO MARK DEFERRED POINTER - -DEFDO: PUSH P,B ; PUSH OLD PAIR ON STACK - PUSH P,1(C) - MOVEI C,-1(P) ; USE AS NEW DATUM - PUSHJ P,MARK2 ;MARK THE DATUM - HRRZ E,-2(P) ; GET POINTER IN INF CORE - ADDI E,1 - MOVSI 0,(MOVEM) - PUSHJ P,SMINF ; AND CLOBBER - SUB P,[3,,3] - JRST GCRET ;AND RETURN - - -PAIRM7: MOVEM A,-1(P) ; SAVE NEW VAL FOR RETURN - JRST PAIRM4 - -RETNEW: HRRZ A,(C) ; POINT TO NEW WORLD LOCN - HRRZ E,(P) ; BACK POINTER - JUMPE E,RETNW1 ; NONE - MOVSI 0,(HRRM) - PUSHJ P,SMINF - JRST GCRETP - -RETNW1: MOVEM A,-1(P) - JRST GCRETP - -; ROUTINE TO SMASH INFERIORS PPAGES -; E/ ADDR IN INF, A/ THING TO SMASH ,0/ INS TO USE - -SMINF: CAML E,WNDBOT ; SEE IF IN WINDOW - CAML E,WNDTOP - JRST SMINF1 ; NO TRY FRONTIER -SMINF3: SUB E,WNDBOT ; FIX UP - IOR 0,[0 A,WIND(E)] ; FIX INS - XCT 0 - POPJ P, - -SMINF1: PUSH P,0 - HRRZ 0,BOTNEW ; GET FRONTIER RANGE - CAML E,0 ; SKIP IF BELOW - CAIL E,@BOTNEW - JRST SMINF2 - SUB E,0 ; FIXUP E - POP P,0 - IOR 0,[0 A,FRONT(E)] - XCT 0 - POPJ P, - -SMINF2: PUSH P,A - MOVE A,E - ASH A,-10. ; TO PAGES - PUSHJ P,%SHWND - ASH A,10. ; BACK TO WORDS - MOVEM A,WNDBOT - ADDI A,2000 - MOVEM A,WNDTOP - POP P,A - POP P,0 ; RESTORE INS OF INTEREST - JRST SMINF3 - - - ; VECTOR AND TP MARKER, SIGN OF TYPNT IS SET BASED ON WHICH ONE - -TPMK: TLOA TYPNT,400000 ;SET TP MARK FLAG -VECTMK: TLZ TYPNT,400000 - MOVEI E,(A) ;SAVE A POINTER TO THE VECTOR - HLRE B,A ;GET -LNTH - SUB A,B ;LOCATE DOPE WORD - MOVEI A,1(A) ;ZERO LH AND POINT TO 2ND DOPE WORD - PUSHJ P,VECBND ; CHECK IN VECTOR SPACE - JRST VECTB1 ;LOSE, COMPLAIN - - JUMPGE TYPNT,NOBUFR ;IF A VECTOR, NO BUFFER CHECK - CAME A,PGROW ;IS THIS THE BLOWN P - CAMN A,TPGROW ;IS THIS THE GROWING PDL - JRST NOBUFR ;YES, DONT ADD BUFFER - ADDI A,PDLBUF ;POINT TO REAL DOPE WORD - MOVSI 0,-PDLBUF ;ALSO FIX UP POINTER - ADDB 0,1(C) - MOVEM 0,(P) ; FIXUP RET'D PNTR - -NOBUFR: HLRE B,(A) ;GET LENGTH FROM DOPE WORD - JUMPL B,GCRET ; MARKED, LEAVE - ANDI B,377777 ;CLOBBER POSSIBLE MARK BIT - MOVEI F,(A) ;SAVE A POINTER TO DOPE WORD - SUBI F,1(B) ;F POINTS TO START OF VECTOR - HRRZ 0,-1(A) ;SEE IF GROWTH SPECIFIED - MOVEI B,0 ; SET GROWTH 0 - JUMPE 0,NOCHNG ;NONE, JUST CHECK CURRENT SIZES - - LDB B,[001100,,0] ;GET GROWTH FACTOR - TRZE B,400 ;KILL SIGN BIT AND SKIP IF + - MOVNS B ;NEGATE - ASH B,6 ;CONVERT TO NUMBER OF WORDS - SUB F,B ;BOTTOM IS LOWER IN CORE - LDB 0,[111100,,0] ;GET TOP GROWTH - TRZE 0,400 ;HACK SIGN BIT - MOVNS 0 - ASH 0,6 ;CONVERT TO WORDS - PUSHJ P,GSHFLG ; HACK FLAGS FOR GROW/SHRINK - ADD B,0 ;TOTAL GROWTH TO B -NOCHNG: -VECOK: HLRE E,(A) ;GET LENGTH AND MARKING - MOVEI F,(E) ;SAVE A COPY - ADD F,B ;ADD GROWTH - SUBI E,2 ;- DOPE WORD LENGTH - IORM D,(A) ;MAKE SURE NOW MARKED - CAML A,VECBOT ; ONLY IF REALLY IN VEC SPACE - ADDM F,VECNUM ; ADD LENGTH OF VECTOR - JUMPLE E,GCRET ;ALREADY MARKED OR ZERO LENGTH, LEAVE - - SKIPGE B,-1(A) ;SKIP IF UNIFORM - TLNE B,377777 ;SKIP IF NOT SPECIAL - JUMPGE TYPNT,NOTGEN ;JUMP IF NOT A GENERAL VECTOR - -GENRAL: HLRZ 0,B ;CHECK FOR PSTACK - JUMPE 0,NOTGEN ;IT ISN'T GENERAL - SUBI A,1(E) ;POINT TO FIRST ELEMENT - MOVEI C,(A) ;POINT TO FIRST ELEMENT WITH C - - ; LOOP TO MARK ELEMENTS IN A GENERAL VECTOR - PUSH P,[0] -VECTM2: HLRE B,(C) ;GET TYPE AND MARKING - JUMPL B,GCRET1 ;RETURN, (EITHER DOPE WORD OR FENCE POST) - MOVE A,1(C) ;DATUM TO A - ANDI B,TYPMSK ; FLUSH MONITORS - CAIE B,TCBLK ;IS THIS A SAVED FRAME? - CAIN B,TENTRY ;IS THIS A STACK FRAME - JRST MFRAME ;YES, MARK IT - CAIE B,TUBIND ; BIND - CAIN B,TBIND ;OR A BINDING BLOCK - JRST MBIND - -VECTM3: PUSHJ P,MARK ;MARK DATUM - MOVEM A,1(C) ; IN CASE WAS FIXED -VECTM4: ADDI C,2 - JRST VECTM2 - -MFRAME: HRROI C,FRAMLN+FSAV-1(C) ;POINT TO FUNCTION - HRRZ A,1(C) ; GET IT - PUSHJ P,VECBND ; CHECK IN VECTOR SPACE - JRST MFRAM1 ; IGNORE, NOT IN VECTOR SPACE - HRL A,(A) ; GET LENGTH - MOVEI B,TVEC - PUSHJ P,MARK ; AND MARK IT -MFRAM1: HRROI C,SPSAV-FSAV(C) ;POINT TO SAVED SP - MOVEI B,TSP - PUSHJ P,MARK1 ;MARK THE GOODIE - HRROI C,PSAV-SPSAV(C) ;POINT TO SAVED P - MOVEI B,TPDL - PUSHJ P,MARK1 ;AND MARK IT - HRROI C,TPSAV-PSAV(C) ;POINT TO SAVED TP - MOVEI B,TTP - PUSHJ P,MARK1 ;MARK IT ALS - MOVEI C,-TPSAV+1(C) ;POINT PAST THE FRAME - JRST VECTM2 ;AND DO MORE MARKING - - -MBIND: MOVEI B,TATOM ;FIRST MARK ATOM - SKIPN GCHAIR ; IF NO HAIR, MARK ALL NOW - SKIPE (P) ; PASSED MARKER, IF SO DONT SKIP - JRST MBIND2 ; GO MARK - CAME A,IMQUOTE THIS-PROCESS - JRST MBIND1 ; NOT IT, CONTINUE SKIPPING - HRRM LPVP,2(C) ; SAVE IN RH OF TPVP,,0 - MOVEI LPVP,(C) ; POINT - SETOM (P) ; INDICATE PASSAGE -MBIND1: ADDI C,6 ; SKIP BINDING - JRST VECTM2 - -MBIND2: PUSHJ P,MARK1 ; MARK ATOM - ADDI C,2 ; POINT TO VAL - PUSHJ P,MARK2 ; AND MARK IT - MOVEM A,1(C) - ADDI C,2 - MOVEI B,TLIST ; POINT TO DECL SPECS - HLRZ A,(C) - PUSHJ P,MARK ; AND MARK IT - HRLM A,(C) ; LIST FIX UP - MOVEI B,TLOCI ; NOW MARK LOCATIVE - MOVE A,1(C) - JRST VECTM3 - -VECLOS: JUMPL C,CCRET ;JUMP IF CAN'T MUNG TYPE - HLLZ 0,(C) ;GET TYPE - MOVEI B,TILLEG ;GET ILLEGAL TYPE - HRLM B,(C) - MOVEM 0,1(C) ;AND STORE OLD TYPE AS VALUE - JRST GCRET ;RETURN WITHOUT MARKING VECTOR - -CCRET: CLEARM 1(C) ;CLOBBER THE DATUM - JRST GCRET - - -IGBLK: HRRZ B,(C) ;SKIP TO END OF PP BLOCK - ADDI C,3(B) - JRST VECTM2 - ; MARK ARG POINTERS - -ARGMK: HRRZ A,1(C) ; GET POINTER - HLRE B,1(C) ; AND LNTH - SUB A,B ; POINT TO BASE - PUSHJ P,VECBND - JRST ARGMK0 - HLRZ 0,(A) ; GET TYPE - ANDI 0,TYPMSK - CAIN 0,TCBLK - JRST ARGMK1 - CAIE 0,TENTRY ; IS NEXT A WINNER? - CAIN 0,TINFO - JRST ARGMK1 ; YES, GO ON TO WIN CODE - -ARGMK0: SETZB A,1(C) ; CLOBBER THE CELL - SETZM (P) ; AND SAVED COPY - JRST GCRET - -ARGMK1: MOVE B,1(A) ; ASSUME TTB - ADDI B,(A) ; POINT TO FRAME - CAIE 0,TINFO ; IS IT? - MOVEI B,FRAMLN(A) ; NO, USE OTHER GOODIE - HLRZ 0,OTBSAV(B) ; GET TIME - HRRZ A,(C) ; AND FROM POINTER - CAIE 0,(A) ; SKIP IF WINNER - JRST ARGMK0 - HRROI C,TPSAV-1(B) ; MARK FROM TP SLOT - MOVEI B,TTP - MOVE A,1(C) -; PUSHJ P,MARK ; WILL PUT BACK WHEN KNOWN HOW! - JRST GCRET - -; MARK FRAME POINTERS - -FRMK: SUBI C,1 ;PREPARE TO MARK PROCESS VECTOR - HRRZ A,1(C) ;USE AS DATUM - SUBI A,1 ;FUDGE FOR VECTMK - MOVEI B,TPVP ;IT IS A VECTRO - PUSHJ P,MARK ;MARK IT - JRST GCRET - -; MARK BYTE POINTER - -BYTMK: PUSHJ P,BYTDOP ; GET DOPE WORD IN A - SOJG A,VECTMK ;FUDGE DOPE WORD POINTER FOR VECTMK - - FATAL AGC--BYTE POINTER WITH ZERO DOPE WORD POINTER - - ; MARK ATOMS IN GVAL STACK - -GATOMK: HRRZ B,(C) ; POINT TO POSSIBLE GDECL - JUMPE B,ATOMK - CAIN B,-1 - JRST ATOMK - MOVEI A,(B) ; POINT TO DECL FOR MARK - MOVEI B,TLIST - MOVEI C,0 - PUSHJ P,MARK - HLRZ C,-1(P) ; RESTORE HOME POINTER - HRRM A,(C) ; CLOBBER UPDATED LIST IN - MOVE A,1(C) ; RESTORE ATOM POINTER - -; MARK ATOMS - -ATOMK: -REPEAT 0,[ - TLO TYPNT,.ATOM. ; SAY ATOM WAS MARKED - PUSHJ P,GETLNT ;GET LENGTH AND CHECK BOUNDS - HRRZ C,(A) ; IF UNBOUND OR GLOBAL - JUMPE C,MRKOBL ; SKIP - HRRZ C,1(A) ; DONT MARK BUT UPDATE BASED ON TPGROW - HLRE B,1(A) - SUB C,B ; POINT TO DOPE WORD - MOVEI C,1(C) ; POINT TO 2D DOPE WORD - MOVSI B,-PDLBUF ; IN CASE UPDATE - CAME C,TPGROW ; SKIP IF GROWER - ADDM B,1(A) ; OTHERWISE UPDATE -MRKOBL: MOVEI C,1(A) ; POINT TO OBLIST SLOT -] - TLO TYPNT,.ATOM. ; SAY ATOM WAS MARKED - MOVEI C,1(A) - HRRZ 0,(A) - PUSHJ P,GETLNT ;GET LENGTH AND CHECK BOUNDS - JUMPE 0,MRKOBL - HRRZ B,(C) - HLRE 0,(C) - SUB B,0 - MOVEI B,1(B) - MOVSI 0,-PDLBUF - CAME B,TPGROW - ADDM 0,(C) -MRKOBL: MOVEI B,TOBLS - SKIPGE 1(C) ; IF > 0, NOT OBL - PUSHJ P,MARK1 ; AND MARK IT - JRST GCRET ;AND LEAVE - -GETLNT: HLRE B,A ;GET -LNTH - SUB A,B ;POINT TO 1ST DOPE WORD - MOVEI A,1(A) ;POINT TO 2ND DOPE WORD - PUSHJ P,VECBND - JRST VECTB1 ;BAD VECTOR, COMPLAIN - - HLRE B,(A) ;GET LENGTH AND MARKING - IORM D,(A) ;MAKE SURE MARKED - JUMPL B,GCRET1 ;MARKED ALREADY, QUIT - SUBI A,-1(B) ;POINT TO TOP OF ATOM - CAML A,VECBOT ; DONT COUNT STORAGE - ADDM B,VECNUM ;UPDATE VECNUM - POPJ P, ;AND RETURN - -GCRET1: SUB P,[1,,1] ;FLUSH RETURN ADDRESS - JRST GCRET - -VECBND: CAMGE A,VECTOP - CAMGE A,VECBOT - JRST .+2 - JRST CPOPJ1 - - CAMG A,CODTOP - CAIGE A,STOSTR - POPJ P, - JRST CPOPJ1 - -; MARK NON-GENERAL VECTORS - -NOTGEN: CAMN B,[GENERAL+] ;PROCESS VECTOR? - JRST GENRAL ;YES, MARK AS A VECTOR - JUMPL B,SPECLS ; COMPLAIN IF A SPECIAL HACK - SUBI A,1(E) ;POINT TO TOP OF A UNIFORM VECTOR - HLRZS B ;ISOLATE TYPE - ANDI E,TYPMSK - MOVE F,B ; AND COPY IT - LSH B,1 ;FIND OUT WHERE IT WILL GO - HRRZ B,@TYPNT ;GET SAT IN B - ANDI B,SATMSK - MOVEI C,@MKTBS(B) ;POINT TO MARK SR - CAIN C,GCRET ;IF NOT A MARKED FROM GOODIE, IGNORE - JRST GCRET - MOVEI C,-1(A) ;POINT 1 PRIOR TO VECTOR START - PUSH P,E ;SAVE NUMBER OF ELEMENTS - PUSH P,F ;AND UNIFORM TYPE - -UNLOOP: MOVE B,(P) ;GET TYPE - MOVE A,1(C) ;AND GOODIE - TLO C,400000 ;CAN'T MUNG TYPE - PUSHJ P,MARK ;MARK THIS ONE - MOVEM A,1(C) ; LIST FIXUP - SOSE -1(P) ;COUNT - AOJA C,UNLOOP ;IF MORE, DO NEXT - - SUB P,[2,,2] ;REMOVE STACK CRAP - JRST GCRET - - -SPECLS: FATAL AGC--UNRECOGNIZED SPECIAL VECTOR - - ;MARK LOCID TYPE GOODIES - -LOCMK: HRRZ B,(C) ;GET TIME - JUMPE B,LOCMK1 ; SKIP LEGAL CHECK FOR GLOBAL - HRRZ 0,2(A) ; GET OTHER TIME - CAIE 0,(B) ; SAME? - SETZB A,1(C) ; NO, SMASH LOCATIVE - JUMPE A,GCRET ; LEAVE IF DONE -LOCMK1: PUSH P,C - MOVEI B,TATOM ; MARK ATOM - MOVEI C,-2(A) ; POINT TO ATOM - PUSHJ P,MARK1 ; LET LOCATIVE SAVE THE ATOM - POP P,C - HRRZ B,(C) ; TIME BACK - MOVE A,1(C) ; RESTORE POINTER TO STACK - JUMPE B,VECTMK ;IF ZERO, GLOBAL - JRST TPMK ;ELSE, ON TP - -; MARK ASSOCIATION BLOCKS - -ASMRK: HRLI A,-ASOLNT ;LOOK LIKE A VECTOR POINTER - PUSHJ P,GETLNT ;GET LENGTH AND CHECK BOUNDS - MOVEI C,(A) ;COPY POINTER - PUSHJ P,MARK2 ;MARK ITEM CELL - MOVEM A,1(C) - ADDI C,INDIC-ITEM ;POINT TO INDICATOR - PUSHJ P,MARK2 - MOVEM A,1(C) - ADDI C,VAL-INDIC - PUSHJ P,MARK2 - MOVEM A,1(C) - SKIPN GCHAIR ; IF NO HAIR, MARK ALL FRIENDS - JRST GCRET - HRRZ A,NODPNT-VAL(C) ; NEXT - JUMPN A,ASMRK ; IF EXISTS, GO - JRST GCRET - - - -;HERE WHEN A VECTOR POINTER IS BAD - -VECTB1:FATAL AGC--VECTOR POINTS OUTSIDE OF VECTOR SPACE - - ; HERE TO MARK TEMPLATE DATA STRUCTURES - -TD.MRK: HLRZ B,(A) ; GET REAL SPEC TYPE - ANDI B,377777 ; KILL SIGN BIT - MOVEI E,-NUMSAT-1(B) ; GET REL POINTER TO TABLE - HRLI E,(E) - ADD E,TD.LNT+1(TVP) - HRRZS C,A ; FLUSH COUNT AND SAVE - SKIPL E ; WITHIN BOUNDS - FATAL BAD SAT IN AGC - PUSHJ P,GETLNT ; GOODIE IS NOW MARKED - - XCT (E) ; RET # OF ELEMENTS IN B - - HLRZ D,B ; GET POSSIBLE "BASIC LENGTH" FOR RESTS - PUSH P,[0] ; TEMP USED IF RESTS EXIST - PUSH P,D - MOVEI B,(B) ; ZAP TO ONLY LENGTH - PUSH P,C ; SAVE POINTER TO TEMPLATE STRUCTURE - PUSH P,[0] ; HOME FOR VALUES - PUSH P,[0] ; SLOT FOR TEMP - PUSH P,B ; SAVE - SUB E,TD.LNT+1(TVP) - PUSH P,E ; SAVE FOR FINDING OTHER TABLES - JUMPE D,TD.MR2 ; NO REPEATING SEQ - ADD E,TD.GET+1(TVP) ; COMP LNTH OF REPEATING SEQ - HLRE E,(E) ; E ==> - LNTH OF TEMPLATE - ADDI E,(D) ; E ==> -LENGTH OF REP SEQ - MOVNS E - HRLM E,-5(P) ; SAVE IT AND BASIC - -TD.MR2: SKIPG D,-1(P) ; ANY LEFT? - JRST TD.MR1 - - MOVE E,TD.GET+1(TVP) - ADD E,(P) - MOVE E,(E) ; POINTER TO VECTOR IN E - MOVEM D,-6(P) ; SAVE ELMENT # - SKIPN B,-5(P) ; SKIP IF "RESTS" EXIST - SOJA D,TD.MR3 - - MOVEI 0,(B) ; BASIC LNT TO 0 - SUBI 0,(D) ; SEE IF PAST BASIC - JUMPGE 0,.-3 ; JUMP IF O.K. - MOVSS B ; REP LNT TO RH, BASIC TO LH - IDIVI 0,(B) ; A==> -WHICH REPEATER - MOVNS A - ADD A,-5(P) ; PLUS BASIC - ADDI A,1 ; AND FUDGE - MOVEM A,-6(P) ; SAVE FOR PUTTER - ADDI E,-1(A) ; POINT - SOJA D,.+2 - -TD.MR3: ADDI E,(D) ; POINT TO SLOT - XCT (E) ; GET THIS ELEMENT INTO A AND B - MOVEM A,-3(P) ; SAVE TYPE FOR LATER PUT - MOVEM B,-2(P) - EXCH A,B ; REARRANGE - GETYP B,B - MOVEI C,-3(P) ; TELL OTHER GUYS THEY CANT DIRECTLY MUNG - MOVSI D,400000 ; RESET FOR MARK - PUSHJ P,MARK ; AND MARK THIS GUY (RET FIXED POINTER IN A) - MOVE C,-4(P) ; REGOBBLE POINTER TO TEMPLATE - MOVE E,TD.PUT+1(TVP) - MOVE B,-6(P) ; RESTORE COUNT - ADD E,(P) - MOVE E,(E) ; POINTER TO VECTOR IN E - ADDI E,(B)-1 ; POINT TO SLOT - MOVE B,-3(P) ; RESTORE TYPE WORD - EXCH A,B - SOS D,-1(P) ; GET ELEMENT # - XCT (E) ; SMASH IT BACK - FATAL TEMPLATE LOSSAGE - MOVE C,-4(P) ; RESTORE POINTER IN CASE MUNGED - JRST TD.MR2 - -TD.MR1: SUB P,[7,,7] - MOVSI D,400000 ; RESTORE MARK/UNMARK BIT - JRST GCRET - -; This phase attempts to remove any unwanted associations. The program -; loops through the structure marking values of associations. It can only -; stop when no new values (potential items and/or indicators) are marked. - -VALFLS: PUSH P,[0] ; INDICATE WHETHER ANY ON THIS PASS - PUSH P,[0] ; OR THIS BUCKET -ASOMK1: MOVE A,ASOVEC+1(TVP) ; GET VECTOR POINTER - SETOM -1(P) ; INITIALIZE FLAG - -ASOM6: SKIPG C,(A) ; SKIP IF BUCKET TO BE SCANNED - JRST ASOM1 - SETOM (P) ; SAY BUCKET NOT CHANGED - -ASOM2: MOVEI F,(C) ; COPY POINTER - SKIPG ASOLNT+1(C) ; SKIP IF NOT ALREADY MARKED - JRST ASOM4 ; MARKED, GO ON - PUSHJ P,MARKQ ; SEE IF ITEM IS MARKED - JRST ASOM3 ; IT IS NOT, IGNORE IT - MOVEI F,(C) ; IN CASE CLOBBERED BY MARK2 - MOVEI C,INDIC(C) ; POINT TO INDICATOR SLOT - PUSHJ P,MARKQ - JRST ASOM3 ; NOT MARKED - - PUSH P,A ; HERE TO MARK VALUE - PUSH P,F - HLRE F,ASOLNT-INDIC+1(C) ; GET LENGTH - JUMPL F,.+3 ; SKIP IF MARKED - CAML C,VECBOT ; SKIP IF IN NOT VECT SPACE - ADDM F,VECNUM - PUSHJ P,MARK2 ; AND MARK - MOVEM A,1(C) ; LIST FIX UP - ADDI C,ITEM-INDIC ; POINT TO ITEM - PUSHJ P,MARK2 - MOVEM A,1(C) - ADDI C,VAL-ITEM ; POINT TO VALUE - PUSHJ P,MARK2 - MOVEM A,1(C) - IORM D,ASOLNT-VAL+1(C) ; MARK ASOC BLOCK - POP P,F - POP P,A - AOSA -1(P) ; INDICATE A MARK TOOK PLACE - -ASOM3: AOS (P) ; INDICATE AN UNMARKED IN THIS BUCKET -ASOM4: HRRZ C,ASOLNT-1(F) ; POINT TO NEXT IN BUCKET - JUMPN C,ASOM2 ; IF NOT EMPTY, CONTINUE - SKIPGE (P) ; SKIP IF ANY NOT MARKED - HRROS (A) ; MARK BUCKET AS NOT INTERESTING -ASOM1: AOBJN A,ASOM6 ; GO TO NEXT BUCKET - TLZE TYPNT,.ATOM. ; ANY ATOMS MARKED? - JRST VALFLA ; YES, CHECK VALUES -VALFL8: - -; NOW SEE WHICH CHANNELS STILL POINTED TO - -CHNFL3: MOVEI 0,N.CHNS-1 - MOVEI A,CHNL1(TVP) ; SLOTS - HRLI A,TCHAN ; TYPE HERE TOO - -CHNFL2: SKIPN B,1(A) - JRST CHNFL1 - HLRE C,B - SUBI B,(C) ; POINT TO DOPE - HLLM A,(A) ; PUT TYPE BACK - SKIPGE 1(B) - JRST CHNFL1 - HLLOS (A) ; MARK AS A LOSER - PUSH P,A - PUSH P,0 - MOVEI C,(A) - PUSHJ P,MARK2 - POP P,0 - POP P,A - SETZM -1(P) ; SAY MARKED -CHNFL1: ADDI A,2 - SOJG 0,CHNFL2 - - SKIPE GCHAIR ; IF NOT HAIRY CASE - POPJ P, ; LEAVE - - SKIPL -1(P) ; SKIP IF NOTHING NEW MARKED - JRST ASOMK1 - - SUB P,[2,,2] ; REMOVE FLAGS - - - - ; HERE TO REEMOVE UNUSED ASSOCIATIONS - - MOVE A,ASOVEC+1(TVP) ; GET ASOVEC BACK FOR FLUSHES - -ASOFL1: SKIPN C,(A) ; SKIP IF BUCKET NOT EMPTY - JRST ASOFL2 ; EMPTY BUCKET, IGNORE - HRRZS (A) ; UNDO DAMAGE OF BEFORE - -ASOFL5: SKIPGE ASOLNT+1(C) ; SKIP IF UNMARKED - JRST ASOFL3 ; MARKED, DONT FLUSH - - HRRZ B,ASOLNT-1(C) ; GET FORWARD POINTER - HLRZ E,ASOLNT-1(C) ; AND BACK POINTER - JUMPN E,ASOFL4 ; JUMP IF NO BACK POINTER (FIRST IN BUCKET) - HRRZM B,(A) ; FIX BUCKET - JRST .+2 - -ASOFL4: HRRM B,ASOLNT-1(E) ; FIX UP PREVIOUS - JUMPE B,.+2 ; JUMP IF NO NEXT POINTER - HRLM E,ASOLNT-1(B) ; FIX NEXT'S BACK POINTER - HRRZ B,NODPNT(C) ; SPLICE OUT THRAD - HLRZ E,NODPNT(C) - SKIPE E - HRRM B,NODPNT(E) - SKIPE B - HRLM E,NODPNT(B) - -ASOFL3: HRRZ C,ASOLNT-1(C) ; GO TO NEXT - JUMPN C,ASOFL5 -ASOFL2: AOBJN A,ASOFL1 - -; NOW CLOBBER UNMARKED LOCAL NAD GLOBAL VALUES - - MOVE A,GLOBSP+1(TVP) ; GET GLOBAL PDL - -GLOFLS: SKIPGE (A) ; SKIP IF NOT ALREADY MARKED - JRST .+3 ; VIOLATE CARDINAL RULE #69 - MOVSI B,-3 - PUSHJ P,ZERSLT ; CLOBBER THE SLOT - ANDCAM D,(A) ; UNMARK - ADD A,[4,,4] - JUMPL A,GLOFLS ; MORE?, KEEP LOOPING - -LOCFL1: HRRZ A,(LPVP) ; NOW CLOBBER LOCAL SLOTS - HRRZ C,2(LPVP) - HLLZS 2(LPVP) ; NOW CLEAR - MOVEI LPVP,(C) - JUMPE A,LOCFL2 ; NONE TO FLUSH - -LOCFLS: SKIPGE (A) ; MARKDE? - JRST .+3 - MOVSI B,-5 - PUSHJ P,ZERSLT - ANDCAM D,(A) ;UNMARK - HRRZ A,(A) ; GO ON - JUMPN A,LOCFLS -LOCFL2: JUMPN LPVP,LOCFL1 ; JUMP IF MORE PROCESS - POPJ P, - - - -MARK23: PUSH P,A ; SAVE BUCKET POINTER - PUSH P,F - PUSHJ P,MARK2 - MOVEM A,1(C) - POP P,F - POP P,A - AOS -2(P) ; MARKING HAS OCCURRED - IORM D,ASOLNT+1(C) ; MARK IT - JRST MKD - - ; CHANNEL FLUSHER FOR NON HAIRY GC - -CHNFLS: PUSH P,[-1] - SETOM (P) ; RESET FOR RETRY - PUSHJ P,CHNFL3 - SKIPL (P) - JRST .-3 ; REDO - SUB P,[1,,1] - POPJ P, - -; VALUE FLUSHING PHASE, HACKS BOTTOM OF TP AND GLOBAL SP - -VALFLA: MOVE C,GLOBSP+1(TVP) - -VALFL1: SKIPL (C) ; SKIP IF NOT MARKED - PUSHJ P,MARKQ ; SEE IF ATOM IS MARKED - JRST VALFL2 - IORM D,(C) - AOS -1(P) ; INDICATE MARK OCCURRED - PUSH P,C - HRRZ B,(C) ; GET POSSIBLE GDECL - JUMPE B,VLFL10 ; NONE - CAIN B,-1 ; MAINFIFEST - JRST VLFL10 - MOVEI A,(B) - MOVEI B,TLIST - MOVEI C,0 - PUSHJ P,MARK ; MARK IT - MOVE C,(P) ; POINT - HRRM A,(C) ; CLOBBER UPDATE IN -VLFL10: ADD C,[2,,2] ; BUMP TO VALUE - PUSHJ P,MARK2 ; MARK VALUE - MOVEM A,1(C) - POP P,C -VALFL2: ADD C,[4,,4] - JUMPL C,VALFL1 ; JUMP IF MORE - - HRLM LPVP,(P) ; SAVE POINTER -VALFL7: MOVEI C,(LPVP) - MOVEI LPVP,0 -VALFL6: HRRM C,(P) - -VALFL5: HRRZ C,(C) ; CHAIN - JUMPE C,VALFL4 - MOVEI B,TATOM ; TREAT LIKE AN ATOM - SKIPL (C) ; MARKED? - PUSHJ P,MARKQ1 ; NO, SEE - JRST VALFL5 ; LOOP - AOS -1(P) ; MARK WILL OCCUR - IORM D,(C) - ADD C,[2,,2] ; POINT TO VALUE - PUSHJ P,MARK2 ; MARK VALUE - MOVEM A,1(C) - SUBI C,2 - JRST VALFL5 - -VALFL4: HRRZ C,(P) ; GET SAVED LPVP - MOVEI A,(C) - HRRZ C,2(C) ; POINT TO NEXT - JUMPN C,VALFL6 - JUMPE LPVP,VALFL9 - - HRRM LPVP,2(A) ; NEW PROCESS WAS MARKED - JRST VALFL7 - -ZERSLT: HRRI B,(A) ; COPY POINTER - SETZM 1(B) - AOBJN B,.-1 - POPJ P, - -VALFL9: HLRZ LPVP,(P) ; RESTORE CHAIN - JRST VALFL8 - - - ;SUBROUTINE TO SEE IF A GOODIE IS MARKED -;RECEIVES POINTER IN C -;SKIPS IF MARKED NOT OTHERWISE - -MARKQ: HLRZ B,(C) ;TYPE TO B -MARKQ1: MOVE E,1(C) ;DATUM TO C - MOVEI 0,(E) - CAIL 0,@PURBOT ; DONT CHACK PURE - JRST MKD ; ALWAYS MARKED - ANDI B,TYPMSK ; FLUSH MONITORS - LSH B,1 - HRRZ B,@TYPNT ;GOBBLE SAT - ANDI B,SATMSK - CAIG B,NUMSAT ; SKIP FOR TEMPLATE - JRST @MQTBS(B) ;DISPATCH - ANDI E,-1 ; FLUSH REST HACKS - JRST VECMQ - - -DISTBS MQTBS,MKD,[[S2WORD,PAIRMQ],[S2DEFR,PAIRMQ],[SNWORD,VECMQ],[S2NWORD,VECMQ] -[STPSTK,VECMQ],[SARGS,ARGMQ],[SPSTK,VECMQ],[SFRAME,FRMQ],[SBYTE,BYTMQ],[SLOCID,LOCMQ] -[SATOM,VECMQ],[SPVP,VECMQ],[SLOCID,VECMQ],[SCHSTR,BYTMQ],[SLOCA,ARGMQ],[SLOCU,VECMQ] -[SLOCV,VECMQ],[SLOCS,BYTMQ],[SLOCN,ASMQ],[SASOC,ASMQ],[SLOCL,PAIRMQ],[SGATOM,VECMQ]] - -PAIRMQ: JUMPE E,MKD ; NIL ALWAYS MARKED - SKIPL (E) ; SKIP IF MARKED - POPJ P, -CPOPJ1: -ARGMQ: -MKD: AOS (P) - POPJ P, - -BYTMQ: HRRZ E,(C) ;GET DOPE WORD POINTER - SOJA E,VECMQ1 ;TREAT LIKE VECTOR - -FRMQ: HRRZ E,(C) ; POINT TO PV DOPE WORD - SOJA E,VECMQ1 - - -VECMQ: HLRE 0,E ;GET LENGTH - SUB E,0 ;POINT TO DOPE WORDS - -VECMQ1: SKIPGE 1(E) ;SKIP IF NOT MARKED - AOS (P) ;MARKED, CAUSE SKIP RETURN - POPJ P, - -ASMQ: SUBI E,ASOLNT - JRST VECMQ1 - -LOCMQ: HRRZ 0,(C) ; GET TIME - JUMPE 0,VECMQ ; GLOBAL, LIKE VECTOR - HLRE 0,E ; FIND DOPE - SUB E,0 - MOVEI E,1(E) ; POINT TO LAST DOPE - CAMN E,TPGROW ; GROWING? - SOJA E,VECMQ1 ; YES, CHECK - ADDI E,PDLBUF ; FUDGE - MOVSI 0,-PDLBUF - ADDM 0,1(C) - SOJA E,VECMQ1 - REPEAT 0,[ - - - -;RETIME PHASE -- CALLED IFF A FRAME TIME HAS OVERFLOWED -;RECEIVES POINTER TO STACK TO BE RECALIBRATED IN A -;LEAVES HIGHEST TIME IN TIMOUT - -RETIME: HLRE B,A ;GET LENGTH IN B - SUB A,B ;COMPUTE DOPE WORD LOCATION - MOVEI A,1(A) ;POINT TO 2D DOPE WORD AND CLEAR LH - CAME A,TPGROW ;IS THIS ONE BLOWN? - ADDI A,PDLBUF ;NO, POINT TO DOPE WORD - LDB B,[222100,,(A)] ;GET LENGTH FIELD (IGNOREING MARK BIT - SUBI A,-1(B) ;POINT TO PDLS BASE - MOVEI C,1 ;INITIALIZE NEW TIMES - -RETIM1: SKIPGE B,(A) ;IF <0, HIT DOPE WORD OR FENCE POST - JRST RETIM3 - HLRZS B ;ISOLATE TYPE - CAIE B,TENTRY ;FRAME START? - AOJA A,RETIM2 ;NO, TRY BINDING - HRLM C,FRAMLN+OTBSAV(A) ;STORE NEW TIME - ADDI A,FRAMLN ;POINT TO NEXT ELEMENT - AOJA C,RETIM1 ;BUMP TIME AND MOVE ON - -RETIM2: CAIE B,TUBIND - CAIN B,TBIND ;BINDING? - HRRM C,3(A) ;YES, STORE CURRENT TIME - AOJA A,RETIM1 ;AND GO ON - -RETIM3: MOVEM C,TIMOUT ;SAVE TIME - POPJ P, ;RETURN - - -] - - ; Core adjustment phase, try to win in all obscure cases! - -CORADJ: MOVE A,P.TOP ; update AGCs core top - MOVEM A,CORTOP - MOVE A,PARBOT ; figure out all the core needed - ADD A,PARNEW - ADD A,PARNUM - ADD A,PARNUM - ADD A,VECNUM - ADDI A,3777 ; account for gc pdl and round to block - ANDCMI A,1777 - -CORAD3: CAMG A,PURTOP ; any way of winning at all? - JRST CORAD1 ; yes, go try -CORA33: SETOM GCDNTG ; no, can't even grow something - SETOM GCDANG ; or get current request - SKIPL C,PARNEW ; or move pairs up - SETZM PARNEW - MOVEM C,SPARNW ; save attempt in case of retry - -CORAD6: MOVE A,CORTOP ; update core gotton with needed - ASH A,-10. ; to blocks - PUSHJ P,P.CORE ; try to get it (any lossage will retry) - PUSHJ P,SLPM1 -CORA11: MOVE A,CORTOP ; compute new home for vectors - SUB A,VECTOP - SUBI A,2000 ; remember gc pdl - MOVEM A,VECNEW - POPJ P, ; return to main GC loop - -; Here if at least enough for growers - -CORAD1: SKIPN B,GCDOWN ; skip if were called to get pure space - JRST CORAD2 - ADDI A,2000(B) ; A/ enough for move down and minimum free - CAMG A,PURTOP ; any chance of winning? - JRST CORAD4 ; yes, go win some - -; Here if cant move down - - SETOM GCDANG ; complain upon return - SUBI A,2000(B) ; reset for re-entry into loop - CAMLE A,PURTOP ; win? - JRST CORA33 - -; Here if may be able to grant current request - -CORAD2: ADD A,GETNUM ; A/ total neede including request - ADD A,CURPLN ; dont give self away or something - ADDI A,3777 ; at least one free block and round - ANDCMI A,1777 ; to block boundary - CAMG A,PURTOP ; any hope of this? - JRST CORAD5 ; yes, now see if some slop space can appear - - SETOM GCDANG ; tell caller we lost - MOVE A,PURTOP ; try to get as much as possible anyway - SUB A,PURBOT - SUB A,CURPLN -CORAD8: ASH A,-10. ; to pages - PUSHJ P,GETPAG - FATAL PAGES NOT AVAILABLE - MOVSI D,400000 ; wipes out D - MOVE A,PURBOT ; and use current PURBOT as new core top - SUBI A,2000 ; for gc pdl - MOVEM A,CORTOP - JRST CORAD6 ; and allocate necessary pages - -; Here if real necessities taken care of, try for slop space - -CORAD5: ADD A,FREMIN ; try for minimum - SUBI A,2000-1777 ; round and flush min 2000 of before - ANDCMI A,1777 ; round to block boundary - CAMG A,PURTOP ; again, do we win? - JRST CORAD7 ; yes, we win totally - -; Here if cant get desired free but get some - - MOVE A,PURTOP ; compute pages to flush - SUB A,CURPLN ; again dont flush current prog - SUB A,PURBOT ; A/ words to get - JRST CORAD8 ; go do it - -; Here if can get all the free we want - -CORAD7: SUB A,CURPLN - CAMG A,PURBOT ; do any pages get the ax? - JRST CORAD9 ; no, see if can give core back! - SUB A,PURBOT ; words to get purely - JRST CORAD8 - -CORAD9: CAMG A,CORTOP ; skip if must get core - JRST CORA10 - MOVEM A,CORTOP - JRST CORAD6 ; and go get it - -; Here if still may have to give it back - -CORA10: MOVE B,CORTOP - SUB B,A - CAMG B,FREDIF ; skip if giving awy - JRST CORA11 - -CORA12: MOVEM A,CORTOP - ASH A,-10. - MOVEM A,CORSET ; leave to shrink later - JRST CORA11 - -; Here if going down to also get free space - -CORAD4: SUBI A,2000 ; uncompensate for min - ADD A,FREMIN - CAML A,CORTOP ; skip if ok for max - MOVE A,CORTOP ; else use up to pure - SUB A,GCDOWN ; new CORTOP to A - JRST CORA12 ; go set up final shrink - -; routine to wait for core - -SLPM1: MOVEI 0,1 - .SLEEP 0, - SOS (P) - SOS (P) ; ret to prev ins - POPJ P, - -CORADL: PUSHJ P,P.CORE ;SET TO NEW CORE VALUE - FATAL AGC--CANT CORE DOWN - POPJ P, - ;VECTOR RELOCATE --GETS VECTOP IN A -;AND VECNEW IN B -;FILLS IN RELOCATION FIELDS OF MARKED VECTORS -;AND REUTRNS FINAL VECNEW IN B - -VECREL: CAMG A,VECBOT ;PROCESSED TO BOTTOM OF VECTOR SPACE? - POPJ P, ;YES, RETURN - HLRE C,(A) ;GET COUNT FROM DOPE WD, EXTEND MARK BIT - JUMPL C,VECRE1 ;IF MARKED GO PROCESS - HRRM A,(A) ; INDICATE NON-MOVE BY LEAVING SAME - SUBI A,(C) ;MOVE ON TO NEXT VECTOR - SOJG C,VECREL ;AND KEEP SCANNING - JSP D,VCMLOS ;LOSER, LEAVE TRACKS AS TO WHO LOST - -VECRE1: HRRZ E,-1(A) ;GOBBLE THE GROWTH FILEDS - HRRM B,(A) ;STORE RELOCATION - JUMPE E,VECRE2 ;NO GROWTH (OR SHRINKAGE), GO AWAY - LDB F,[111100,,E] ;GET TOP GROWTH IN F - TRZN F,400 ;CHECK AND FLUSH SIGN - MOVNS F ;WAS ON, NEGATE - SKIPE GCDNTG ; SKIP IF GROWTH OK - JUMPL F,VECRE3 ; DONT ALLOW POSITIVE GROWTH - ASH F,6 ;CONVERT TO WORDS - ADD B,F ;UPDATE RELOCATION - HRRM B,(A) ;AND STORE IT -VECRE3: ANDI E,777 ;ISOLATE BOTTOM GROWTH - TRZN E,400 ;CHECK AND CLEAR SIGN - MOVNS E - SKIPE GCDNTG ; SKIP IF GROWTH OK - JUMPL E,VECRE2 - ASH E,6 ;CONVERT TO WORDS - ADD B,E ;UPDATE FUTURE RELOCATIONS -VECRE2: SUBI A,400000(C) ;AND MOVE ON TO NEXT VECTOR - ANDI C,377777 ;KILL MARK - SUBI B,(C) ; UPDATE WHERE TO GO LOCN - SOJG C,VECREL ;AND KEEP GOING - JSP D,VCMLOS ;LOSES, LEAVE TRACKS - -;PAIR SPACE UPDATE - -;GETS PARBOT IN AC A -;UPDATES VALUES AND CDRS UP TO PARTOP - -PARUPD: CAML A,PARTOP ;ARE THERE MORE PAIRS TO PROCESS - POPJ P, ;NO -- RETURN - -;UPDATE VALUE CELL -PARUP1: ANDCAM D,(A) ; KILL MARK BIT - HLRZ B,(A) ;SET RH OF B TO TYPE - MOVE C,1(A) ;SET C TO VALUE - PUSHJ P,VALUPD ;UPDATE THIS VALUE - ADDI A,2 ;MOVE ON TO NEXT PAIR - JRST PARUPD ;AND CONTINUE - - - ;VECTOR SPACE UPDATE -;GETS VECTOP IN A -;UPDATES ALL VALUE CELLS IN MARKED VECTORS -;ESCAPES WHEN IT GETS TO VECBOT - -VECUPD: SUBI A,1 ;MAKE A POINT TO LAST DOPE WD - PUSH P,VECBOT - PUSHJ P,UPD1 - SUB P,[1,,1] - POPJ P, - -; STORAGE SPACE UPDATE - -STOUP: PUSH P,[STOSTR] - PUSHJ P,UPD1 - SUB P,[1,,1] - JRST ENHACK -UPD1: -VECUP1: CAMG A,-1(P) ;ANY MORE VECTORS TO PROCESS? - POPJ P, - SKIPGE B,(A) ;IS DOPE WORD MARKED? - JRST VECUP2 ;YES -- GO PROCESS VALUES IN THIS VECTOR - HLLZS -1(A) ;MAKE SURE NO GROWTH ATTEMPTS - HLRZS B ;NO -- SET RH OF B TO SIZE OF VECTOR -VECUP5: SUB A,B ;SET A TO POINT TO DOPE WD OF NEXT VECTOR - JRST VECUP1 ;AND CONTINUE - -VECUP2: PUSH P,A ;SAVE DOPE WORD POINTER - HLRZ B,(A) ;GET LENGTH OF THIS VECTOR -VECU11: ANDI B,377777 ;TURN OFF MARK BIT - SKIPGE E,-1(A) ;CHECK FOR UNIFORM OR SPECIAL - TLNE E,377777 ;SKIP IF GENERAL - JRST VECUP6 ;UNIFORM OR SPECIAL, GO DO IT -VECU10: SUB A,B ;SET AC A TO NEXT DOPE WORD - ADDI A,1 ;AND ADVANCE TO FIRST ELEMENT OF THIS VECTOR -VECUP3: HLRZ B,(A) ;GET TYPE - TRNE B,400000 ;IF MARK BIT SET - JRST VECUP4 ;DONE WITH THIS VECTOR - ANDI B,TYPMSK - CAIE B,TCBLK - CAIN B,TENTRY ;SPECIAL HACK FOR ENTRY - JRST ENTRUP - CAIE B,TUNWIN - CAIN B,TSKIP ; SKIP POINTER - JRST BINDUP ; HACK APPROPRAITELY - CAIE B,TBVL ;VECTOR BINDING? - CAIN B,TBIND ;AND BINDING BLOCK - JRST BINDUP - CAIN B,TUBIND - JRST BINDUP -VECU15: MOVE C,1(A) ;GET VALUE - PUSHJ P,VALUPD ;UPDATE THIS VALUE -VECU12: ADDI A,2 ;GO ON TO NEXT VECTOR - JRST VECUP3 ;AND CONTINUE - -VECUP4: POP P,A ;SET TO OLD DOPE WORD - ANDCAM D,(A) ;TURN OFF MARK BIT - HLRZ B,(A) ;GET LENGTH - ANDI B,377777 ; IN CASE DING STORAGE - JRST VECUP5 ;GO ON TO NEXT VECTOR - - - -;UPDATE A SAVED SAVE BLOCK -ENTSUP: MOVEI A,FRAMLN+SPSAV-1(A) ;A POINTS BEFORE SAVED SP - MOVEI B,TSP - PUSHJ P,VALPD1 ;UPDATE SPSAV - MOVEI A,PSAV-SPSAV(A) - MOVEI B,TPDL - PUSHJ P,VALPD1 ;UPDATE PSAV - MOVEI A,TPSAV-PSAV(A) - MOVEI B,TTP - PUSHJ P,VALPD1 ;UPDATE TPSAV -;SKIP TO END OF BLOCK - SUBI A,PSAV-1 - JRST VECUP3 - -;IGNORE A BLOCK -IGBLK2: HRRZ B,(A) ;GET DISPLACEMENT - ADDI A,3(B) ;USE IT - JRST VECUP3 ;GO - - ; ENTRY PART OF THE STACK UPDATER - -ENTRUP: ADDI A,FRAMLN-2 ;POINT PAST FRAME - JRST VECU12 ;NOW REJOIN VECTOR UPDATE - -; UPDATE A BINDING BLOCK - -BINDUP: HRRZ C,(A) ;POINT TO CHAIN - JUMPE C,NONEXT ;JUMP IF NO NEXT BINDING IN CHAIN - HRRZ 0,@(P) ; GET OWN DESTINATION - SUBI 0,@(P) ; RELATIVIZE - ADD C,0 ; AND UPDATE - HRRM C,(A) ;AND STORE IT BACK -NONEXT: CAIN B,TUBIND - JRST .+3 - CAIE B,TBIND ;SKIP IF VAR BINDING - JRST VECU14 ;NO, MUST BE A VECTOR BIND - MOVEI B,TATOM ;UPDATE ATOM POINTER - PUSHJ P,VALPD1 - ADDI A,2 - HLRZ B,(A) ;TYPE OF VALUE - PUSHJ P,VALPD1 - ADDI A,2 ; POINT TO PREV LOCATIVE -VECU16: MOVEI B,TLOCI - SKIPN 1(A) ; IF NO LOCATIVE, - MOVEI B,TUNBOU ; SAY UNBOUND - PUSHJ P,VALPD1 - JRST VECU12 - -VECU14: CAIN B,TBVL ; CHANGE BVL TO VEC - MOVEI B,TVEC ;NOW TREAT LIKE A VECTOR - JRST VECU15 - -; NOW SAFE TO UPDATE ALL ENTRY BLOCKS - -ENHACK: HRRZ F,TBSTO(LPVP) ;GET POINTER TO TOP FRAME - HLLZS TBSTO(LPVP) ;CLEAR FIELD - HLLZS TPSTO(LPVP) - JUMPE F,LSTFRM ;FINISHED - -ENHCK1: MOVEI A,FSAV-1(F) ;POINT PRIOR TO SAVED FUNCTION - HRRZ C,1(A) ; GET POINTER TO FCN - CAML C,VECBOT ; SKIP IF A LOSER - CAMLE C,VECTOP ; SKIP IF A WINNER - JRST ENHCK2 - HRL C,(C) ; MAKE INTO AOBJN - MOVEI B,TVEC - PUSHJ P,VALUPD ; AND UPDATE -ENHCK2: HRRZ F,2(A) ;POINT TO PRIOR FRAME - MOVEI B,TTB ;MARK SAVED TB - PUSHJ P,[AOJA A,VALPD1] - MOVEI B,TAB ;MARK ARG POINTER - PUSHJ P,[AOJA A,VALPD1] - MOVEI B,TSP ;SAVED SP - PUSHJ P,[AOJA A,VALPD1] - MOVEI B,TPDL ;SAVED P STACK - PUSHJ P,[AOJA A,VALPD1] - MOVEI B,TTP ;SAVED TP - PUSHJ P,[AOJA A,VALPD1] - JUMPN F,ENHCK1 ;MARK NEXT ONE IF IT EXISTS - -LSTFRM: HRRZ A,BINDID(LPVP) ;NEXT PROCESS - HLLZS BINDID(LPVP) ;CLOBBER - MOVEI LPVP,(A) - JUMPN LPVP,ENHACK ;DO NEXT PROCESS - POPJ P, - - ; UPDATE ELEMENTS IN UNIFROM AND SPECIAL VECTORS - -VECUP6: JUMPL E,VECUP7 ;JUMP IF SPECIAL - CAIG B,2 ;EMPTY UVECTOR ? - JRST VECUP4 ;YES, NOTHING TO UPDATE - HLRZS E ;ISOLATE TYPE - ANDI E,37777 - EXCH E,B ;TYPE TO B AND LENGTH TO E - SUBI A,(E) ;POINT TO NEXT DOPE WORD - LSH B,1 ;FIND SAT - HRRZ B,@TYPNT - ANDI B,SATMSK - MOVE B,UPDTBS(B) ;FIND WHERE POINTS - CAIN B,CPOPJ ;UNMARKED? - JRST VECUP4 ;YES, GO ON TO NEXT VECTOR - PUSH P,B ;SAVE SR POINTER - SUBI E,2 ;DON'T COUNT DOPE WORDS - -VECUP8: MOVE C,1(A) ;GET GOODIE - MOVEI 0,(C) ; ISOLATE ADDR - JUMPE 0,.+3 ; NEVER 0 PNTR - CAIGE 0,@PURBOT ; OR IF PURE - PUSHJ P,@(P) ;CALL UPDATE ROUTINE - ADDI A,1 - SOJG E,VECUP8 ;LOOP FOR ALL ELEMNTS - - SUB P,[1,,1] ;REMOVE RANDOMNESS - JRST VECUP4 - -; SPECIAL VECTOR UPDATE - -VECUP7: HLRZS E ;ISOLATE SPECIAL TYPE - CAIN E,SATOM+400000 ;ATOM? - JRST ATOMUP ;YES, GO DO IT - CAIN E,STPSTK+400000 ;STACK - JRST VECU10 ;TREAT LIKE A VECTOR - CAIN E,SPVP+400000 ;PROCESS VECTOR - JRST PVPUP ;DO SPECIAL STUFF - CAIN E,SASOC+400000 - JRST ASOUP ;UPDATE ASSOCIATION BLOCK - - TRZ E,400000 ; CHECK FOR TEMPLATE VECTOR - CAIG E,NUMSAT ; SKIP IF POSSIBLE - FATAL AGC--UNRECOGNIZED SPECIAL VECTOR (UPDATE) - MOVEI E,-NUMSAT-1(E) - HRLI E,(E) - ADD E,TD.LNT+1(TVP) - SKIPL E - FATAL AGC--BAD TEMPLATE TYPE - -TD.UPD: MOVEI C,-1(A) ; POINTER TO OBJECT IN C - XCT (E) - HLRZ D,B ; POSSIBLE BASIC LENGTH - PUSH P,[0] - PUSH P,D - MOVEI B,(B) ; ISOLATE LENGTH - PUSH P,C ; SAVE POINTER TO OBJECT - - PUSH P,[0] ; HOME FOR VALUES - PUSH P,[0] ; SLOT FOR TEMP - PUSH P,B ; SAVE - SUB E,TD.LNT+1(TVP) - PUSH P,E ; SAVE FOR FINDING OTHER TABLES - JUMPE D,TD.UP2 ; NO REPEATING SEQ - ADD E,TD.GET+1(TVP) ; COMP LNTH OF REPEATING SEQ - HLRE E,(E) ; E ==> - LNTH OF TEMPLATE - ADDI E,(D) ; E ==> -LENGTH OF REP SEQ - MOVNS E - HRLM E,-5(P) ; SAVE IT AND BASIC - -TD.UP2: SKIPG D,-1(P) ; ANY LEFT? - JRST TD.UP1 - - MOVE E,TD.GET+1(TVP) - ADD E,(P) - MOVE E,(E) ; POINTER TO VECTOR IN E - MOVEM D,-6(P) ; SAVE ELMENT # - SKIPN B,-5(P) ; SKIP IF "RESTS" EXIST - SOJA D,TD.UP3 - - MOVEI 0,(B) ; BASIC LNT TO 0 - SUBI 0,(D) ; SEE IF PAST BASIC - JUMPGE 0,.-3 ; JUMP IF O.K. - MOVSS B ; REP LNT TO RH, BASIC TO LH - IDIVI 0,(B) ; A==> -WHICH REPEATER - MOVNS A - ADD A,-5(P) ; PLUS BASIC - ADDI A,1 ; AND FUDGE - MOVEM A,-6(P) ; SAVE FOR PUTTER - ADDI E,-1(A) ; POINT - SOJA D,.+2 - -TD.UP3: ADDI E,(D) ; POINT TO SLOT - XCT (E) ; GET THIS ELEMENT INTO A AND B - MOVEM A,-3(P) ; SAVE TYPE FOR LATER PUT - MOVEM B,-2(P) - MOVE C,B ; VALUE TO C FOR VALUPD - GETYP B,A - MOVEI A,-3(P) ; TELL OTHER GUYS THEY CANT DIRECTLY MUNG - MOVSI D,400000 ; RESET FOR MARK - PUSHJ P,VALUPD ; AND MARK THIS GUY (RET FIXED POINTER IN A) - MOVE C,-4(P) ; GET POINTER FOR UPDATE OF ELEMENT - MOVE E,TD.PUT+1(TVP) - SOS D,-1(P) ; RESTORE COUNT - ADD E,(P) - MOVE E,(E) ; POINTER TO VECTOR IN E - MOVE B,-6(P) ; SAVED OFFSET - ADDI E,(B)-1 ; POINT TO SLOT - MOVE A,-3(P) ; RESTORE TYPE WORD - MOVE B,-2(P) - XCT (E) ; SMASH IT BACK - FATAL TEMPLATE LOSSAGE - MOVE C,-4(P) - JRST TD.UP2 - -TD.UP1: SUB P,[7,,7] - MOVSI D,400000 ; RESTORE MARK/UNMARK BIT - JRST VECUP4 - - ; UPDATE ATOM VALUE CELLS - -ATOMUP: SUBI A,-1(B) ; POINT TO VALUE CELL - HLRZ B,(A) - HRRZ 0,(A) ;GOBBLE BINDID - JUMPN 0,.+3 ;NOT GLOBAL - CAIN B,TLOCI ;IS IT A LOCATIVE? - MOVEI B,TVEC ;MARK AS A VECTOR - HRRZ 0,1(A) ; GET POINTER - CAML 0,VECBOT - CAMLE 0,VECTOP - JRST .+2 ; OUT OF BOUNDS, DONT UPDATE - PUSHJ P,VALPD1 ;UPDATE IT - MOVEI B,TOBLS ; TYPE TO OBLIST - SKIPGE 2(A) - PUSHJ P,[AOJA A,VALPD1] - JRST VECUP4 - -; UPDATE PROCESS VECTOR - -PVPUP: SUBI A,-1(B) ;POINT TO TOP - HRRM LPVP,BINDID(A) ;CHAIN ALL PROCESSES TOGETHER - MOVEI LPVP,(A) - HRRZ 0,TBSTO+1(A) ;POINT TO CURRENT FRAME - HRRM 0,TBSTO(A) ;SAVE - HRRZ 0,TPSTO+1(A) ;0_SAVED TP POINTER - HLRE B,TPSTO+1(A) - SUBI 0,-1(B) ;0 _ POINTER TO OLD DOPE WORD - HRRM 0,TPSTO(A) - JRST VECUP3 - - - ;THIS SUBROUTINE TAKES CARE OF UPDATING ASSOCIATION BLOCKS - -ASOUP: SUBI A,-1(B) ;POINT TO START OF BLOCK - HRRZ B,ASOLNT-1(A) ;POINT TO NEXT - JUMPE B,ASOUP1 - HRRZ C,ASOLNT+1(B) ;AND GET ITS RELOC IN C - SUBI C,ASOLNT+1(B) ; RELATIVIZE - ADDM C,ASOLNT-1(A) ;C NOW HAS UPDATED PONTER -ASOUP1: HLRZ B,ASOLNT-1(A) ;GET PREV BLOCK POINTER - JUMPE B,ASOUP2 - HRRZ F,ASOLNT+1(B) ;AND ITS RELOCATION - SUBI F,ASOLNT+1(B) ; RELATIVIZE - MOVSI F,(F) - ADDM F,ASOLNT-1(A) ;RELOCATE -ASOUP2: HRRZ B,NODPNT(A) ;UPDATE NODE CHAIN - JUMPE B,ASOUP4 - HRRZ C,ASOLNT+1(B) ;GET RELOC - SUBI C,ASOLNT+1(B) ; RELATIVIZE - ADDM C,NODPNT(A) ;ANID UPDATE -ASOUP4: HLRZ B,NODPNT(A) ;GET PREV POINTER - JUMPE B,ASOUP5 - HRRZ F,ASOLNT+1(B) ;RELOC - SUBI F,ASOLNT+1(B) - MOVSI F,(F) - ADDM F,NODPNT(A) -ASOUP5: HRLI A,-3 ;SET TO UPDATE OTHER CONTENTS - -ASOUP3: HLRZ B,(A) ;GET TYPE - PUSHJ P,VALPD1 ;UPDATE - ADD A,[1,,2] ;MOVE POINTER - JUMPL A,ASOUP3 - JRST VECUP4 ;AND QUIT - - ;VALUPD UPDATES A SINLE VALUE FROM EITHER PAIR SPACE OR VECTOR SPACE -;GETS POINTER TO TYPE CELL IN RH OF A -;TYPE IN RH OF B (LH MUST BE 0) -;VALUE IN C - -VALPD1: MOVE C,1(A) ;GET VALUE TO UPDATE -VALUPD: MOVEI 0,(C) - CAIGE 0,@PURBOT ; SKIP IF PURE, I.E. DONT HACK - TRNN C,-1 ;ANY POINTER PART? - JRST CPOPJ ;NO, LEAVE - ANDI B,TYPMSK - LSH B,1 ;SET TYPE TIMES 2 - HRRZ B,@TYPNT ;GET STORAGE ALLOCATION TYPE - ANDI B,SATMSK - CAIG B,NUMSAT ; SKIP IF TEMPLATE - JRST @UPDTBS(B) ;AND DISPATCH THROUGH STORAGE ALLOCATION DISPATCH TABLE - AOJA C,TMPLUP - -;SAT DISPATCH TABLE - -DISTBS UPDTBS,CPOPJ,[[SNWORD,NWRDUP],[STPSTK,STCKUP] -[SFRAME,FRAMUP],[STBASE,TBUP],[SARGS,ARGUP],[SBYTE,BYTUP],[SATOM,NWRDUP],[SPSTK,STCKUP] -[SLOCID,LOCUP],[SPVP,NWRDUP],[S2NWORD,NWRDUP],[SABASE,ABUP],[SCHSTR,BYTUP],[SASOC,ASUP] -[SLOCA,ARGUP],[SLOCU,NWRDUP],[SLOCN,ASUP],[SLOCS,BYTUP],[SGATOM,NWRDUP]] - - - - -;PAIR POINTER UPDATE -2WDUP: MOVEI 0,(C) - CAIGE 0,@PURBOT ; SKIP AND IGNORE IF PURE - TRNN C,-1 ;POINT TO NIL? - POPJ P, ;YES -- NO UPDATE NEEDED - SKIPGE B,(C) ;NO -- IS THIS A BROKEN HEART - HRRM B,1(A) ;YESS -- STORE NEW VALUE - SKIPE B,PARNEW ;IF LIST SPACE IS MOVING - ADDM B,1(A) ;THEN ADD OFFSET TO VALUE - POPJ P, ;FINISHED - -; HERE TO UPDATE ASSOCIATIONS - -ASUP: HRLI C,-ASOLNT ;MAKE INTO VECTOR POINTER - JRST NWRDUP - ;VECTOR, ATOM, STACK, AND BASE POINTER UPDATE - -LOCUP: HRRZ B,(A) ;CHECK IF IT IS TIMED - JUMPN B,LOCUP1 ;JUMP IF TIMED, OTHERWISE TREAT LIKE VECTORE - -NWRDUP: HLRE B,C ;EXTEND COUNT IN B - SUBI C,-1(B) ;SET C TO POINT TO DOPE WORD -TMPLUP: HRRZ B,(C) ;EXTEND RELOCATION IN B - SUBI B,(C) ; RELATIVIZE - ADDM B,1(A) ;AND ADD RELOCATION TO STORED DATUM - HRRZ C,-1(C) ;GET GROWTH SPECS - JUMPE C,CPOPJ ;NO GROWTH, LEAVE - LDB C,[111100,,C] ;GET UPWORD GROWTH - TRZN C,400 ;FLUSH SIGN AN NEGATR DIRECTION - MOVNS C - SKIPE GCDNTG ; SKIP IF GROWTH WINS - JUMPL C,CPOPJ ; POS GROWTH, LOSE - ASH C,6+18. ;TO LH AND TIMES 100(8) - ADDM C,1(A) ;UPDATE POINTER - POPJ P, - - -LOCUP1: -STCKUP: MOVSI B,PDLBUF ;GET OFFSET FOR PDLS - ADDM B,1(A) ;AND ADD TO COUNT - JRST NWRDUP ;NOW TREAT LIKE VECTOR - -BYTUP: MOVEI C,(A) ; SET TO GET DOPE WORD - PUSH P,A - PUSHJ P,BYTDOP - POP P,C - HRRZ B,(A) ;SET B TO RELOCATION FOR THIS VEC - SUBI B,(A) ; RELATIVIZE - ADDM B,1(C) ;AND UPDATE VALUE - MOVE A,C ; FIX UP FOR SCANNER - POPJ P, ;DONE WITH UPDATE - -ARGUP: -ABUP: HLRE B,C ;GET LENGTH - SUB C,B ;POINT TO FRAME - HLRZ B,(C) ;GET TYPE OF NEXT GOODIE - ANDI B,TYPMSK - CAIN B,TINFO ;IS IT A FRAME - ADD C,1(C) ;NO, POINT TO FRAME - CAIE B,TINFO ;IF IT IS A FRAME - ADDI C,FRAMLN ;POINT TO ITS BASE -TBUP: MOVE C,TPSAV(C) ;GET A ASTACK POINTER TO FIND DOPE WORD - HLRE B,C ;UPDATE BASED ON THIS POINTER - SUBI C,(B) -ABUP1: HRRZ B,1(C) ;GET RELOCATION - SUBI B,1(C) ; RELATIVIZE - ADDM B,1(A) ;AND MUNG POINTER - POPJ P, - -FRAMUP: HRRZ B,(A) ;UPDATE PVP - HRRZ C,(B) ;IN CELL - SUBI C,(B) ; RELATIVIZE - ADDM C,(A) - HLRZ C,(B) - ANDI C,377777 - SUBI B,-1(C) ;ADDRESS OF PV - HRRZ C,TPSTO(B) ;IF TPSTO HAS OLD TP DOPE WORD, - JUMPN C,ABUP2 ;USE IT - HRRZ C,TPSTO+1(B) ;ELSE, GENERATE IT - HLRE B,TPSTO+1(B) - SUBI C,-1(B) -ABUP2: SOJA C,ABUP1 ; FUDGE AND GO - - ;VECTOR SHRINKING PHASE - -VECSH: SUBI A,1 ;POOINT TO 1ST DOPE WORD -VECSH1: CAMGE A,VECBOT ;FINISHED - POPJ P, ;YES, QUIT - HRRZ B,-1(A) ;GET A SPEC - JUMPE B,NXTSHN ;IGNORE IF NONE - PUSHJ P,GETGRO ;GET THE SPECS - JUMPGE C,SHRNBT ;SHRINKIGN AT BOTTOM - MOVEI E,(A) ;COPY POINTER - ADD A,C ;POINT TO NEW DOPE LOCATION WITH E - MOVE F,-1(E) ;GET OLD DOPE - ANDCMI F,777000 ;KILL THIS SPEC - MOVEM F,-1(A) ;STORE - MOVE F,(E) ;OTHER DOPE WORD - ADD F,C ; UPDATE DESTINATION - HRLZI C,(C) ;TO LH - ADD F,C ;CHANGE LENGTH - MOVEM F,(A) ;AND STORE - MOVMS C ;PLUSIFY - HRRI C,(E) ; MAKE NOT MOVE - MOVEM C,(E) ;AND STORE - SETZM -1(E) -SHRNBT: JUMPGE B,NXTSHN ;GROWTH, IGNOORE - MOVM E,B ;GET A POSITIVE COPY - HRLZI B,(B) ;TO LH - ADDM B,(A) ;ADD INTO DOPE WORD - MOVEI 0,777 ;SET TO CLOBBER GROWTH - ANDCAM 0,-1(A) ;CLOBBER - HLRZ B,(A) ;GET NEW LENGTH - SUBI A,(B) ;POINT TO LOW END - HRLI E,(A) ; MAKE NON MOVER - MOVSM E,(A) ;STORE - SETZM -1(A) - -NXTSHN: HLRZ B,(A) ;GET LENGTH - JUMPE B,VCMLOS ;LOOSE - SUBI A,(B) ;STEP - JRST VECSH1 - -GETGRO: LDB C,[111100,,B] ;GET UPWARD GROWTH - TRZE C,400 ;CHECK AND MUNG SIGN - MOVNS C - ASH C,6 ;?IMES 100 - ANDI B,777 ;AND GET DOWN GROWTH - TRZE B,400 ;CHECK AND MUNG SIGN - MOVNS B - ASH B,6 - POPJ P, - ;VECMOV -- MOVES VECTOR DATA TO WHERE RELOC FIELDS OF -;VECTORS INDICATE. MOVES DOPEWDS UP FOR VECTORS GROWING AT -;THE END. -;CALLED WITH VECTOP IN A. CALLS PARMOV TO MOVE PAIRS - -VECMOV: SUBI A,1 ;SET A TO ADDR OF TOP DOPE WD - MOVSI D,400000 ;NEGATIVE D MARKS END OF BACK CHAIN - MOVEI TYPNT,0 ;CLEAR ON GOING ADDRESS FOR FORWARD RESUME -VECMO1: CAMGE A,VECBOT ;GOT TO BOTTOM OF VECTORS - JRST PARMOV ;YES, MOVE LIST ELEMENTS AND RETURN - MOVEI C,(A) ;NO, COPY ADDR OF THIS DOPEWD - HRRZ B,(A) ;GET RELOCATION OF THIS VECTOR - SUBI B,(A) ; RELATIVIZE - JUMPL B,VECMO5 ;IF MOVING DOWNWARD, MAKE BACK CHAIN - JUMPE B,VECMO4 ;IF NON MOVER, JUST ADJUST DOPW AND MOVE ON - - ADDI C,(B) ;SET ADDR OF LAST DESTINATION WD - HRLI B,A ;MAKE B INDEX ON A - HLL A,(A) ;COUNT TO A LEFT HALF - - POP A,@B ;MOVE A WORD - TLNE A,-1 ;REACHED END OF MOVING - JRST .-2 ;NO, REPEAT - ;YES, NOTE A HAS ADDR OF NEXT DOPEWD - ;HERE TO ADJUST LOCATION OF DOPEWDS FOR GROWTH (FORWARDLY) -VECMO2: LDB B,[111000,,-1(C)] ;GET HIGH GROWTH FIELD - JUMPE B,VECMO3 ;IF NO GROWTH, DONT MOVE - SKIPE GCDNTG ; SKIP IF GROWTH PERMITTED - JRST VECMO3 - ASH B,6 ;EXPRESS GROWTH IN WORDS - HRLI C,2 ;SET COUNT FOR POPPING 2 DOPEWDS - HRLI B,C ;MAKE B INDEX ON C - POP C,@B ;MOVE PRIME DOPEWD - POP C,@B ;MOVE AUX DOPEWD -VECMO3: JUMPL D,VECMO1 ;IF NO BACK CHAIN THEN MOVE ON - JRST VECMO6 ;YES, BACKCHAINING, CONTINUE SAME - -;HERE TO SKIP OVER STILL VECTORS (FORWARDLY) -VECMO4: HLRZ B,(A) ;GET SIZE OF UNMOVER - SUBI A,(B) ;UPDATE A TO NEXT VECTOR - JRST VECMO2 ;AND GO CLEAN UP GROWTH -;HERE TO ESTABLISH A BACKWARDS CHAIN -VECMO5: EXCH D,(A) ;CHAIN FORWARD - HLRZ B,D ;GET SIZE - SUBI A,(B) ;GO ON TO NEXT VECOTR - CAMGE A,VECBOT ;HAVE WE GOT TO END OF VECTORS? - JRST VECMO7 ;YES, GO MOVE PAIRS AND UNCHAIN - HRRZ B,(A) ;GET RELOCATION OF THIS VECTOR - SUBI B,(A) ; RELATIVIZE - JUMPLE B,VECMO5 ;IF NOT POSITIVE, CONTINUE CHAINING - MOVEM A,TYPNT ;SAVE ADDR FOR FORWARD RESUME - -;HERE TO UNCHAIN A VECTOR, MOVE IT, AND ADJUST DOPEWDS -VECMO6: HLRZ B,D ;GET SIZE - MOVEI F,1(A) ;GET A COPY OF BEGINNING OF VECTOR - ADDI A,(B) ;SET TO POINT TO ADDR OF DOPEWD CURRENTLY IN D - EXCH D,(A) ;AND UNCHAIN - HRRZ B,(A) ;GET RELOCATION FOR THIS VECTOR - SUBI B,(A) ; RELATIVIZE - MOVEI C,(A) ;COPY A POINTER TO DOPEW - SKIPGE D ;HAVE WE REACHED THE TOP OF THE CHAIN? - MOVE A,TYPNT ;YES, RESTORE FORWARD MOVE RESUME ADDR - JUMPE B,VECMO2 ;IF STILL VECTOR,GO ADJUST DOPEWDS - ADDI C,(B) ;MAKE C POINT TO NEW DOPEW ADDR - ADDI B,(F) ;B RH NEW 1ST WORD - HRLI B,(F) ;B LH OLD 1ST WD ADDR - BLT B,(C) ;COPY THE DATA - JRST VECMO2 ;AND GO ADJUST DOPEWDS - -;HERE TO STOP CHAINING BECAUSE OF BOTTOM OF VECTOR SPACE -VECMO7: MOVEM A,TYPNT - PUSH P,D - PUSHJ P,PARMOV - POP P,D - MOVE A,TYPNT - JRST VECMO6 - ;PAIR MOVEMENT PHASE -- USES PARNEW,PARBOT, AND PARTOP TO MOVE PAIRS -;TO NEW HOMES - -PARMOV: SKIPN A,PARNEW ;IS THERE ANY PAIR MOVEMENT? - POPJ P, ;NO, RETURN - JUMPL A,PARMO2 ;YES -- IF MOVING DOWNWARDS, GO DO A BLT - HRLI A,B ;MOVING UPWARDS SETAC A TO INDEX OFF AC B - MOVE B,PARTOP ;GET HIGH PAIR ADDREESS - SUB B,PARBOT ;AND SUBTRACT BOTTOM TO GET NUMBER OF PAIRS - HRLZS B ;PUT COUNT IN LEFT HALF - HRR B,PARTOP ;GET HIGH ADDRESS PLUS ONE IN RH - SUBI B,1 ;AND SUBTRACT ONE TO POINT TO LAST WORD TO BE MOVED - -PARMO1: TLNN B,-1 ;HAS COUNT REACHED ZERO? - JRST PARMO3 ;YES -- FINISH UP - POP B,@A ;NO -- TRANSFER2YU NEXT WORD - JRST PARMO1 ;AND REPEAT - -PARMO2: MOVE B,PARBOT ;GET ADDRESS OF FIRST SOURCE WD - HRLS B ;IN BOTH HALVES OF AC B - ADD B,A ;MAKE RH OF B POINT TO FIRST DESTINATION WORD - ADD A,PARTOP ;MAKE RH OF A POINT TO LAST DESTINATION WORD PLUS ONE - BLT B,-1(A) ;AND TRANSFER THE BLOCK OF PAIRS - -PARMO3: MOVE A,PARNEW ;GET OFFSET FOR PAIR SPACE - ADDM A,PARBOT ;AND CORRECT BOTTOM - ADDM A,PARTOP ;AND CORRECT TOP. - SETZM PARNEW ;CLEAR SO IF CALLED TWICE, NO LOSSAGE - POPJ P, - ;VECZER -- CLEARS DATA IN AREAS JUST GROWN -;UPDATES SIZE OF VECTORS -;CLEARS RELOCATION AND GROWTH FIELDS IN DOPEWDS -;CALLED WITH NEW VECTOP IN A (VECBOT SHOULD BE NEW TOO) - -VECZER: SUBI A,1 ;MAKE A POINT TO HIGH VECTORS -VECZE1: CAMGE A,VECBOT ;REACHED BOTTOM OF VECTORS? - POPJ P, ;YES, RETURN - HLLZS F,(A) ;NO, CLEAR RELOCATION GET SIZE - HLRZS F ;AND PUT SIZE IN RH OF F - HRRZ B,-1(A) ;GET GROWTH INTO B - JUMPN B,VECZE3 ;IF THERE IS SOME GROWTH, GO DO IT -VECZE2: SUBI A,(F) ;GROWTH DONE, MOVE ON TO NEXT VECTOR - JRST VECZE1 ;AND REPEAT - -VECZE3: HLLZS -1(A) ;CLEAR GROWTH IN THE VECTOR - LDB C,[111000,,B] ;GET HIGH ORDER GROWTH IN C - SKIPE GCDNTG - JRST VECZE5 - ANDI B,377 ;AND LIMIT B TO LOW SIDE - ASHC B,6 ;EXPRESS GROWTH IN WORDS - JUMPE C,VECZE4 ;IF NO HIGH GROWTH SKIP TO LOW GROWTH - ADDI F,(C) ;ADD HIGH GROWTH TO SIZE - SUBM A,C ;GET ADDR OF 2ND WD TO BE ZEROED - SETZM -1(C) ;CLEAR 1ST WORD - HRLI C,-1(C) ;MAKE C A CLEARING BLT POINTER - BLT C,-2(A) ;AND CLEAR HIGH END DATA - -VECZE4: JUMPE B,VECZE5 ;IF NO LOW GROWTH SKIP TO SIZE UPDATE - MOVNI C,(F) ;GET NEGATIVE SIZE SO FAR - ADDI C,(A) ;AND MAKE C POINT TO LAST WORD OF STUFF TO BE CLEARED - ADDI F,(B) ;UPDATE SIZE - SUBM C,B ;MAKE B POINT TO LAST WD OF NEXT VECT - ADDI B,2 ;AND NOW TO 2ND DATA WD TO BE CLEARED - SETZM -1(B) ;CLEAR 1ST DATA WD - HRLI B,-1(B) ;MAKE B A CLEARING BLT POINTER - BLT B,(C) ;AND CLEAR THE LOW DATA - -VECZE5: HRLZM F,(A) ;STORE THE NEW SIZE IN DOPEWD - JRST VECZE2 - - ;SUBROUTINE TO REBUILD THE NOW DEFUNCT HASH TABLE - -REHASH: MOVE TVP,TVPSTO+1(PVP) ;RESTORE TV POINTER - MOVE D,ASOVEC+1(TVP) ;GET POINTER TO VECTOR - MOVEI E,(D) - PUSH P,E ;PUSH A POINTER - HLRE A,D ;GET -LENGTH - MOVMS A ;AND PLUSIFY - PUSH P,A ;PUSH IT ALSO - -REH3: HRRZ C,(D) ;POINT TO FIRST BUCKKET - HLRZS (D) ;MAKE SURE NEW POINTER IS IN RH - JUMPE C,REH1 ;BUCKET EMPTY, QUIT - -REH2: MOVEI E,(C) ;MAKE A COPY OF THE POINTER - MOVE A,ITEM(C) ;START HASHING - TLZ A,TYPMSK#777777 ; KILL MONITORS - XOR A,ITEM+1(C) - MOVE 0,INDIC(C) - TLZ 0,TYPMSK#777777 - XOR A,0 - XOR A,INDIC+1(C) - TLZ A,400000 ;MAKE SURE FINAL HASH IS + - IDIV A,(P) ;DIVIDE BY TOTAL LENGTH - ADD B,-1(P) ;POINT TO WINNING BUCKET - - MOVE C,[002200,,(B)] ;BYTE POINTER TO RH - CAILE B,(D) ;IF PAST CURRENT POINT - MOVE C,[222200,,(B)] ;USE LH - LDB A,C ;GET OLD VALUE - DPB E,C ;STORE NEW VALUE - HRRZ B,ASOLNT-1(E) ;GET NEXT POINTER - HRRZM A,ASOLNT-1(E) ;AND CLOBBER IN NEW NEXT - SKIPE A ;SKKIP IF NOTHING PREVIOUSLY IN BUCKET - HRLM E,ASOLNT-1(A) ;OTHERWISE CLOBBER - SKIPE C,B ;SKIP IF END OF CHAIN - JRST REH2 -REH1: AOBJN D,REH3 - - SUB P,[2,,2] ;FLUSH THE JUNK - POPJ P, - VCMLOS: FATAL AGC--VECTOR WITH ZERO IN DOPE WORD LENGTH - - -; THESE ARE THE MESSAGES INDICATING THE CAUSE OF THE GC - -MSGGCT: [ASCIZ /USER CALLED- /] - [ASCIZ /FREE STORAGE- /] - [ASCIZ /TP-STACK- /] - [ASCIZ /TOP-LEVEL LOCALS- /] - [ASCIZ /GLOBAL VALUES- /] - [ASCIZ /TYPES- /] - [ASCIZ /STATIONARY IMPURE STORAGE- /] - [ASCIZ /P-STACK /] - [ASCIZ /BOTH STACKS BLOWN- /] - [ASCIZ /PURE STORAGE- /] - [ASCIZ /GC-RCALL- /] - -; THESE ARE MESSAGES INDICATING WHO CAUSED THE GC - -MSGGFT: 0 - [ASCIZ /BLOAT /] - [ASCIZ /GROW /] - [ASCIZ /LIST /] - [ASCIZ /VECTOR /] - [ASCIZ /SET /] - [ASCIZ /SETG /] - [ASCIZ /FREEZE /] - [ASCIZ /PURE-PAGE LOADER /] - [ASCIZ /GC /] - [ASCIZ /INTERRUPT-HANDLER /] - [ASCIZ /NEWTYPE /] - - - - -;LOCAL VARIABLES - -IMPURE -; LOCATIONS USED BY BLOAT-STAT TO HELP THE USER PICK BLOAT SPECIFICATIONS. -; - -GCNO: 0 ; USER-CALLED GC -BSTGC: 0 ; FREE STORAGE - 0 ; BLOWN TP - 0 ; TOP-LEVEL LVALS - 0 ; GVALS - 0 ; TYPE - 0 ; STORAGE - 0 ; P-STACK - 0 ; BOTH STATCKS BLOWN - 0 ; STORAGE - -BSTAT: -NOWFRE: 0 ; FREE STORAGE FROM LAST GC -CURFRE: 0 ; STORAGE USED SINCE LAST GC -MAXFRE: 0 ; MAXIMUM FREE STORAGE ALLOCATED -USEFRE: 0 ; TOTAL FREE STORAGE USED -NOWTP: 0 ; TP LENGTH FROM LAST GC -CURTP: 0 ; # WORDS ON TP -CTPMX: 0 ; MAXIMUM SIZE OF TP SO FAR -NOWLVL: 0 ; # OF TOP-LEVEL LVAL-SLOTS -CURLVL: 0 ; # OF TOP-LEVEL LVALS -NOWGVL: 0 ; # OF GVAL SLOTS -CURGVL: 0 ; # OF GVALS -NOWTYP: 0 ; SIZE OF TYPE-VECTOR -CURTYP: 0 ; # OF TYPES -NOWSTO: 0 ; SIZE OF STATIONARY STORAGE -CURSTO: 0 ; STATIONARY STORAGE IN USE -CURMAX: 0 ; MAXIMUM BLOCK OF CONTIGUOUS STORAGE -NOWP: 0 ; SIZE OF P-STACK -CURP: 0 ; #WORDS ON P -CPMX: 0 ; MAXIMUM P-STACK LENGTH SO FAR -GCCAUS: 0 ; INDICATOR FOR CAUSE OF GC -GCCALL: 0 ; INDICATOR FOR CALLER OF GC - - -; THIS GROUP OF VARIABLES DETERMINES HOW THINGS GROW -LVLINC: 6 ; LVAL INCREMENT ASSUMED TO BE 64 SLOTS -GVLINC: 4 ; GVAL INCREMENT ASSUMED TO BE 64 SLOTS -TYPIC: 1 ; TYPE INCREMENT ASSUMED TO BE 32 TYPES -STORIC: 2000 ; STORAGE INCREMENT USED BY NFREE (MINIMUM BLOCK-SIZE) - - -RCL: 0 ; POINTER TO LIST OF RECYCLEABLE LIST CELLS -GCMONF: 0 ; NON-ZERO SAY GIN/GOUT -GCDANG: 0 ; NON-ZERO, STORAGE IS LOW -GCDNTG: 0 ; NON-ZERO ABORT GROWTHS -GETNUM: 0 ;NO OF WORDS TO GET -PARNUM: 0 ;NO OF PAIRS MARKED -VECNUM: 0 ;NO OF WORDS IN MARKED VECTORS -CORSET: 0 ;NO OF BLOCKS OF CORE, IF GIVING CORE AWAY -CORTOP: 0 ;CURRENT TOP OF CORE, EXCLUDING ANY TO BE GIVEN AWAY - -;VARIABLES WHICH DETERMIN WHEN MUDDLE WILL ASK FOR MORE CORE, -;AND WHEN IT WILL GET UNHAPPY - -SYSMAX: 50. ;MAXIMUM SIZE OF MUDDLE -FREMIN: 20000 ;MINIMUM FREE WORDS -FREDIF: 10000 ;DIFFERENCE BETWEEN FREMIN AND MAXIMUM NUMBER OF FREE WORDS -;POINTER TO GROWING PDL - -TPGROW: 0 ;POINTS TO A BLOWN TP -PPGROW: 0 ;POINTS TO A BLOWN PP -TIMOUT: 0 ;POINTS TO TIMED OUT PDL -PGROW: 0 ;POINTS TO A BLOWN P - -;IN GC FLAG - -GCFLG: 0 -GCFLCH: 0 ; TELL INT HANDLER TO ITIC CHARS -GCHAIR: 1 ; COUNTS GCS AND TELLS WHEN TO HAIRIFY -SHRUNK: 0 ; NON-ZERO=> AVECTOR(S) SHRUNK -GREW: 0 ; NON-ZERO=> A VECTOR(S) GREW -SPARNW: 0 ; SAVED PARNEW -GCDOWN: 0 ; AMOUNT TO TRY AND MOVE DOWN -CURPLN: 0 ; LENGTH OF CURRENTLY RUNNING PURE RSUBR - -; VARS ASSOCIATED WITH BLOAT LOGIC - -TPBINC: 0 -GLBINC: 0 -TYPINC: 0 - -; VARS FOR PAGE WINDOW HACKS - -WNDBOT: 0 ; BOTTOM OF WINDOW -WNDTOP: 0 -BOTNEW: (FPTR) ; POINTER TO FRONTIER -GCTIM: 0 - -PURE - - -END - - - - - - TITLE ARITHMETIC PRIMITIVES FOR MUDDLE - -.GLOBAL HI,RLOW,CPLUS,CMINUS,CTIMES,CDIVID,CFIX,CFLOAT -.GLOBAL CLQ,CGQ,CLEQ,CGEQ,C1Q,C0Q,CMAX,CMIN,CABS,CMOD,CCOS,CSIN,CATAN,CLOG -.GLOBAL CEXP,CSQRT,CTIME,CORB,CXORB,CANDB,CEQVB,CRAND,SAT,BFLOAT - -;BKD - -;DEFINES MUDDLE PRIMITIVES: FIX,FLOAT,ATAN,IEXP,LOG, -; G?,L?,0?,1?,+,-,*,/,MAX,MIN,ABS,SIN,COS,SQRT,RANDOM, -; TIME,SORT. - -RELOCATABLE - -.INSRT MUDDLE > - -O=0 - - -DEFINE TYP1 - (AB) TERMIN -DEFINE VAL1 - (AB)+1 TERMIN - -DEFINE TYP2 - (AB)+2 TERMIN -DEFINE VAL2 - (AB)+3 TERMIN - -DEFINE TYP3 - (AB)+4 TERMIN -DEFINE VAL3 - (AB)+5 TERMIN - -DEFINE TYPN - (D) TERMIN -DEFINE VALN - (D)+1 TERMIN - - -YES: MOVSI A,TATOM ;RETURN PATH FOR 'TRUE' - MOVE B,MQUOTE T - AOS (P) - POPJ P, - -NO: MOVSI A,TFALSE ;RETURN PATH FOR 'FALSE' - MOVEI B,NIL - POPJ P, - - ;ERROR RETURNS AND OTHER UTILITY ROUTINES - -OVRFLW==10 -OVRFLD: PUSH TP,$TATOM - PUSH TP,EQUOTE OVERFLOW - JRST CALER1 - -CARGCH: GETYP 0,A ; GET TYPE - CAIN 0,TFLOAT - POPJ P, - JSP A,BFLOAT - POPJ P, - -ARGCHK: ;CHECK FOR SINGLE FIXED OR FLOATING - ;ARGUMENT IF FIXED CONVERT TO FLOATING - ;RETURN FLOATING ARGRUMENT IN B ALWAYS - ENTRY 1 - GETYP C,TYP1 - MOVE B,VAL1 - CAIN C,TFLOAT ;FLOATING? - POPJ P, ;YES, RETURN - CAIE C,TFIX ;FIXED? - JRST WTYP1 ;NO, ERROR - JSP A,BFLOAT ;YES, CONVERT TO FLOATING AND RETURN - POPJ P, - -OUTRNG: PUSH TP,$TATOM - PUSH TP,EQUOTE ARGUMENT-OUT-OF-RANGE - JRST CALER1 - -NSQRT: PUSH TP,$TATOM - PUSH TP,EQUOTE NEGATIVE-ARGUMENT - JRST CALER1 - -DEFINE MFLOAT AC - IDIVI AC,400000 - FSC AC+1,233 - FSC AC,254 - FADR AC,AC+1 - TERMIN - -BFLOAT: MFLOAT B - JRST (A) - -OFLOAT: MFLOAT O - JRST (C) - -BFIX: MULI B,400 - TSC B,B - ASH C,(B)-243 - MOVE B,C - JRST (A) - - ;DISPATCH TABLES USED TO CONTROL THE FLOW OF THE VARIOUS PRIMITIVES - -TABLE2: NO ;TABLE2 (0) -TABLE3: YES ;TABLE2 (1) & TABLE3 (0) - NO ;TABLE2 (2) - YES - NO - -TABLE4: NO - NO - YES - YES - - - -FUNC: JSP A,BFIX - JSP A,BFLOAT - SUB B,VALN - IDIV B,VALN - ADD B,VALN - IMUL B,VALN - JSP C,SWITCH - JSP C,SWITCH - - - -FLFUNC==.-2 - FSBR B,O - FDVR B,O - FADR B,O - FMPR B,O - JSP C,FLSWCH - JSP C,FLSWCH - -DEFVAL==.-2 - 0 - 1 - 0 - 1 - 377777,,-1 - 400000,,1 - -DEFTYP==.-2 - TFIX,, - TFIX,, - TFIX,, - TFIX,, - TFLOAT,, - TFLOAT,, - ;PRIMITIVES FLOAT AND FIX - -MFUNCTION FIX,SUBR - - ENTRY 1 - - JSP C,FXFL - MOVE B,1(AB) - CAIE A,TFIX - JSP A,BFIX - MOVSI A,TFIX - JRST FINIS - -MFUNCTION FLOAT,SUBR - - ENTRY 1 - - JSP C,FXFL - MOVE B,1(AB) - CAIE A,TFLOAT - JSP A,BFLOAT - MOVSI A,TFLOAT - JRST FINIS - -CFIX: GETYP 0,A - CAIN 0,TFIX - POPJ P, - JSP A,BFIX - MOVSI A,TFIX - POPJ P, - -CFLOAT: GETYP 0,A - CAIN 0,TFLOAT - POPJ P, - JSP A,BFLOAT - MOVSI A,TFLOAT - POPJ P, - -FXFL: GETYP A,(AB) - CAIE A,TFIX - CAIN A,TFLOAT - JRST (C) - JRST WTYP1 - - -MFUNCTION ABS,SUBR - ENTRY 1 - GETYP A,TYP1 - CAIE A,TFIX - CAIN A,TFLOAT - JRST MOVIT - JRST WTYP1 -MOVIT: MOVM B,VAL1 ;GET ABSOLUTE VALUE OF ARGUMENT -AFINIS: HRLZS A ;MOVE TYPE CODE INTO LEFT HALF - JRST FINIS - - - -MFUNCTION MOD,SUBR - ENTRY 2 - GETYP A,TYP1 - CAIE A,TFIX ;FIRST ARG FIXED ? - JRST WTYP1 - GETYP A,TYP2 - CAIE A,TFIX ;SECOND ARG FIXED ? - JRST WTYP2 - MOVE A,VAL1 - IDIV A,VAL2 ;FORM QUOTIENT & REMAINDER - JUMPGE B,.+2 ;Only return positive remainders - ADD B,VAL2 - MOVSI A,TFIX - JRST FINIS - ;PRIMITIVES PLUS, DIFFERENCE, TIMES, DIVIDE, MIN, AND MAX - -MFUNCTION MIN,SUBR - - ENTRY - - MOVEI E,6 - JRST GOPT - -MFUNCTION MAX,SUBR - - ENTRY - - MOVEI E,7 - JRST GOPT - -MFUNCTION DIVIDE,SUBR,[/] - - ENTRY - - MOVEI E,3 - JRST GOPT - -MFUNCTION DIFFERENCE,SUBR,[-] - - ENTRY - - MOVEI E,2 - JRST GOPT - -MFUNCTION TIMES,SUBR,[*] - - ENTRY - - MOVEI E,5 - JRST GOPT - -MFUNCTION PLUS,SUBR,[+] - - ENTRY - - MOVEI E,4 - -GOPT: MOVE D,AB ;ARGUMENT POINTER - HLRE A,AB - MOVMS A - ASH A,-1 - PUSHJ P,CARITH - JRST FINIS - -; BUILD COMPILER ENTRIES TO THESE ROUTINES - -IRP NAME,,[CMINUS,CDIVID,CPLUS,CTIMES,CMIN,CMAX]CODE,,[2,3,4,5,6,7] - -NAME: MOVEI E,CODE - JRST CARIT1 -TERMIN - -CARIT1: MOVEI D,(A) - ASH D,1 ; TIMES 2 - SUBI D,1 - HRLI D,(D) - SUBM TP,D ; POINT TO ARGS - PUSH TP,$TTP - PUSH TP,D - PUSHJ P,CARITH - POP TP,TP - SUB TP,[1,,1] - POPJ P, - -CARITH: MOVE B,DEFVAL(E) ; GET VAL - JFCL OVRFLW,.+1 - MOVEI 0,TFIX ; FIX UNTIL CHANGE - JUMPN A,ARITH0 ; AT LEAST ONE ARG - MOVE A,DEFTYP(E) - POPJ P, - -ARITH0: SOJE A,ARITH1 ; FALL IN WITH ONE ARG - MOVE B,1(D) - GETYP C,(D) ; TYPE OF 1ST ARG - ADD D,[2,,2] ; GO TO NEXT - CAIN C,TFLOAT - JRST ARITH3 - CAIN C,TFIX - JRST ARITH1 - JRST WRONGT - -ARITH1: GETYP C,(D) ; GET NEXT TYPE - CAIE C,TFIX - JRST ARITH2 ; TO FLOAT LOOP - XCT FUNC(E) ; DO IT - ADD D,[2,,2] - SOJG A,ARITH1 ; KEEP ADDING OR WHATEVER - JFCL OVRFLW,OVRFLD - MOVSI A,TFIX - POPJ P, - -ARITH3: GETYP C,(D) - MOVE 0,1(D) ; GET ARG - CAIE C,TFIX - JRST ARITH4 - PUSH P,A - JSP C,OFLOAT ; FLOAT IT - POP P,A - JRST ARITH5 -ARITH4: CAIE C,TFLOAT - JRST WRONGT - JRST ARITH5 - -ARITH2: CAIE C,TFLOAT ; FLOATER? - JRST WRONGT - PUSH P,A - JSP A,BFLOAT - POP P,A - MOVE 0,1(D) - -ARITH5: XCT FLFUNC(E) - ADD D,[2,,2] - SOJG A,ARITH3 - - JFCL OVRFLW,OVRFLD - MOVSI A,TFLOAT - POPJ P, - -SWITCH: XCT COMPAR(E) ;FOR MAX & MIN TESTING - MOVE B,VALN - JRST (C) -COMPAR==.-6 - CAMLE B,VALN - CAMGE B,VALN - - - -FLSWCH: XCT FLCMPR(E) - MOVE B,O - JRST (C) -FLCMPR==.-6 - CAMLE B,O - CAMGE B,O - ;PRIMITIVES ONEP AND ZEROP - -MFUNCTION ONEP,SUBR,[1?] - MOVEI E,1 - JRST JOIN - -MFUNCTION ZEROP,SUBR,[0?] - MOVEI E, - -JOIN: ENTRY 1 - GETYP A,TYP1 - CAIN A,TFIX ;fixed ? - JRST TESTFX - CAIE A,TFLOAT ;floating ? - JRST WTYP1 - MOVE B,VAL1 - CAMN B,NUMBR(E) ;equal to correct value ? - JRST YES1 - JRST NO1 - -TESTFX: CAMN E,VAL1 ;equal to correct value ? - JRST YES1 - -NO1: MOVSI A,TFALSE - MOVEI B,0 - JRST FINIS - -YES1: MOVSI A,TATOM - MOVE B,MQUOTE T - JRST FINIS - -NUMBR: 0 ;FLOATING PT ZERO - 201400,,0 ;FLOATING PT ONE - ;PRIMITIVES LESSP AND GREATERP - -MFUNCTION LEQP,SUBR,[L=?] - MOVEI E,3 - JRST ARGS - -MFUNCTION GEQP,SUBR,[G=?] - MOVEI E,2 - JRST ARGS - - -MFUNCTION LESSP,SUBR,[L?] - MOVEI E,1 - JRST ARGS - -MFUNCTION GREATERP,SUBR,[G?] - MOVEI E,0 - -ARGS: ENTRY 2 - MOVE B,VAL1 - MOVE A,TYP1 - GETYP 0,A - PUSHJ P,CMPTYP - JRST WTYP1 - MOVE D,VAL2 - MOVE C,TYP2 - GETYP 0,C - PUSHJ P,CMPTYP - JRST WTYP2 - PUSHJ P,ACOMPS - JFCL - JRST FINIS - -; COMPILERS ENTRIES TO THESE GUYS - -IRP NAME,,[CGQ,CLQ,CGEQ,CLEQ]COD,,[0,1,2,3] - -NAME: MOVEI E,COD - JRST ACOMPS -TERMIN - -ACOMPS: GETYP A,A - GETYP 0,C - CAIE 0,(A) - JRST COMPD ; COMPARING FIX AND FLOAT -TEST: CAMN B,D - JRST @TABLE4(E) - CAMG B,D - JRST @TABLE2(E) - JRST @TABLE3(E) - -CMPTYP: CAIE 0,TFIX - CAIN 0,TFLOAT - AOS (P) - POPJ P, -COMPD: EXCH B,D - CAIN A,TFLOAT - JSP A,BFLOAT - EXCH B,D - CAIN 0,TFLOAT - JSP A,BFLOAT -COMPF: JRST TEST - -MFUNCTION RANDOM,SUBR - ENTRY - HLRE A,AB - CAMGE A,[-4] ;At most two arguments to random to set seeds - JRST TMA - JRST RANDGO(A) - MOVE B,VAL2 ;Set second seed - MOVEM B,RLOW - MOVE A,VAL1 ;Set first seed - MOVEM A,RHI -RANDGO: PUSHJ P,CRAND - JRST FINIS - -CRAND: MOVE B,RLOW ;FREDKIN'S RANDOM NUMBER GENERATOR. - MOVE A,RHI - MOVEM A,RLOW - LSHC A,-43 - XORB B,RHI - MOVSI A,TFIX - POPJ P, - - MFUNCTION SQRT,SUBR - PUSHJ P,ARGCHK - JUMPL B,NSQRT - PUSHJ P,ISQRT - JRST FINIS - -ISQRT: MOVE A,B - ASH B,-1 - FSC B,100 -SQ2: MOVE C,B ;NEWTON'S METHOD, SPECINER'S HACK. - FDVRM A,B - FADRM C,B - FSC B,-1 - CAME C,B - JRST SQ2 - MOVSI A,TFLOAT - POPJ P, - -MFUNCTION COS,SUBR - PUSHJ P,ARGCHK - FADR B,[1.570796326] ;COS(X)=SIN (X+PI/2) - PUSHJ P,.SIN - MOVSI A,TFLOAT - JRST FINIS - -MFUNCTION SIN,SUBR - PUSHJ P,ARGCHK - PUSHJ P,.SIN - MOVSI A,TFLOAT - JRST FINIS - -.SIN: MOVM A,B - CAMG A,[.0001] - POPJ P, ;GOSPER'S RECURSIVE SIN. - FDVR B,[-3.0] ;SIN(X)=4*SIN(X/-3)**3-3*SIN(X/-3) - PUSHJ P,.SIN - FSC A,1 - FMPR A,A - FADR A,[-3.0] - FMPRB A,B - POPJ P, - -CSQRT: PUSHJ P,CARGCH - JUMPL B,NSQRT - JRST ISQRT - -CSIN: PUSHJ P,CARGCH -CSIN1: PUSHJ P,.SIN - MOVSI A,TFLOAT - POPJ P, - -CCOS: PUSHJ P,CARGCH - FADR B,[1.570796326] - JRST CSIN1 - MFUNCTION LOG,SUBR - PUSHJ P,ARGCHK ;LEAVES ARGUMENT IN B - PUSHJ P,ILOG - JRST FINIS - -CLOG: PUSHJ P,CARGCH - -ILOG: JUMPLE B,OUTRNG - LDB D,[331100,,B] ;GRAB EXPONENT - SUBI D,201 ;REMOVE BIAS - TLZ B,777000 ;SET EXPONENT - TLO B,201000 ; TO 1 - MOVE A,B - FSBR A,RT2 - FADR B,RT2 - FDVB A,B - FMPR B,B - MOVE C,[0.434259751] - FMPR C,B - FADR C,[0.576584342] - FMPR C,B - FADR C,[0.961800762] - FMPR C,B - FADR C,[2.88539007] - FMPR C,A - FADR C,[0.5] - MOVE B,D - FSC B,233 - FADR B,C - FMPR B,[0.693147180] ;LOG E OF 2 - MOVSI A,TFLOAT - POPJ P, - -RT2: 1.41421356 - MFUNCTION ATAN,SUBR - PUSHJ P,ARGCHK - PUSHJ P,IATAN - JRST FINIS - -CATAN: PUSHJ P,CARGCH - -IATAN: PUSH P,B - MOVM D,B - CAMG D,[0.4^-8] ;SMALL ENOUGH SO ATAN(X)=X? - JRST ATAN3 ;YES - CAML D,[7.0^7] ;LARGE ENOUGH SO THAT ATAN(X)=PI/2? - JRST ATAN1 ;YES - MOVN C,[1.0] - CAMLE D,[1.0] ;IS ABS(X)<1.0? - FDVM C,D ;NO,SCALE IT DOWN - MOVE B,D - FMPR B,B - MOVE C,[1.44863154] - FADR C,B - MOVE A,[-0.264768620] - FDVM A,C - FADR C,B - FADR C,[3.31633543] - MOVE A,[-7.10676005] - FDVM A,C - FADR C,B - FADR C,[6.76213924] - MOVE B,[3.70925626] - FDVR B,C - FADR B,[0.174655439] - FMPR B,D - JUMPG D,ATAN2 ;WAS ARG SCALED? - FADR B,PI2 ;YES, ATAN(X)=PI/2-ATAN(1/X) - JRST ATAN2 -ATAN1: MOVE B,PI2 -ATAN2: SKIPGE (P) ;WAS INPUT NEGATIVE? - MOVNS B ;YES,COMPLEMENT -ATAN3: MOVSI A,TFLOAT - SUB P,[1,,1] - POPJ P, - -PI2: 1.57079632 - MFUNCTION IEXP,SUBR,[EXP] - PUSHJ P,ARGCHK ;LEAVE FLOATING POINT ARG IN B - PUSHJ P,IIEXP - JRST FINIS - -CEXP: PUSHJ P,CARGCH - -IIEXP: PUSH P,B - MOVM A,B - SETZM B - FMPR A,[0.434294481] ;LOG BASE 10 OF E - MOVE D,[1.0] - CAMG A,D - JRST RATEX - MULI A,400 - ASHC B,-243(A) - CAILE B,43 - JRST OUTRNG - CAILE B,7 - JRST EXPR2 -EXPR1: FMPR D,FLOAP1(B) - LDB A,[103300,,C] - SKIPE A - TLO A,177000 - FADR A,A -RATEX: MOVEI B,7 - SETZM C -RATEY: FADR C,COEF2-1(B) - FMPR C,A - SOJN B,RATEY - FADR C,[1.0] - FMPR C,C - FMPR D,C - MOVE B,[1.0] - SKIPL (P) ;SKIP IF INPUT NEGATIVE - SKIPN B,D - FDVR B,D - MOVSI A,TFLOAT - SUB P,[1,,1] - POPJ P, - -EXPR2: LDB E,[030300,,B] - ANDI B,7 - MOVE D,FLOAP1(E) - FMPR D,D ;TO THE 8TH POWER - FMPR D,D - FMPR D,D - JRST EXPR1 - -COEF2: 1.15129278 - 0.662730884 - 0.254393575 - 0.0729517367 - 0.0174211199 - 2.55491796^-3 - 9.3264267^-4 - -FLOAP1: 1.0 - 10.0 - 100.0 - 1000.0 - 10000.0 - 100000.0 - 1000000.0 - 10000000.0 - ;BITWISE BOOLEAN FUNCTIONS - -MFUNCTION %ANDB,SUBR,ANDB - ENTRY - HRREI B,-1 ;START ANDING WITH ALL ONES - MOVE D,[AND B,A] ;LOGICAL INSTRUCTION - JRST LOGFUN ;DO THE OPERATION - -MFUNCTION %ORB,SUBR,ORB - ENTRY - MOVEI B,0 - MOVE D,[IOR B,A] - JRST LOGFUN - -MFUNCTION %XORB,SUBR,XORB - ENTRY - MOVEI B,0 - MOVE D,[XOR B,A] - JRST LOGFUN - -MFUNCTION %EQVB,SUBR,EQVB - ENTRY - HRREI B,-1 - MOVE D,[EQV B,A] - -LOGFUN: JUMPGE AB,ZROARG -LOGTYP: GETYP A,(AB) ;GRAB THE TYPE - PUSHJ P,SAT ;STORAGE ALLOCATION TYPE - CAIE A,S1WORD - JRST WRONGT ;WRONG TYPE...LOSE - MOVE A,1(AB) ;LOAD ARG INTO A - XCT D ;DO THE LOGICAL OPERATION - AOBJP AB,.+2 ;ADD ONE TO BOTH HALVES - AOBJN AB,LOGTYP ;ADD AGAIN AND LOOP IF NEEDED - -ZROARG: MOVE A,$TWORD - JRST FINIS - REPEAT 0,[ -;routine to sort lists or vectors of either fixed point or floating numbers -;the components are interchanged repeatedly to acheive the sort -;first arg: the structure to be sorted -;if no second arg sort in descending order -;second arg: if false then sort in ascending order -; else sort in descending order - -MFUNCTION SORT,SUBR - ENTRY - HLRZ A,AB - CAIGE A,-4 ;Only two arguments allowed - JRST TMA - MOVE O,DESCEND ;Set up "O" to test for descending order as default condition - CAIE A,-4 ;Optional second argument? - JRST .+4 - GETYP B,TYP2 ;See if it is other than false - CAIN B,TFALSE - MOVE O,ASCEND ;Set up "O" to test for ascending order - GETYP A,TYP1 ;CHECK TYPE OF FIRST ARGUMENT - CAIN A,TLIST - JRST LSORT - CAIN A,TVEC - JRST VSORT - JRST WTYP1 - - - - -GOBACK: MOVE A,TYP1 ;RETURN THE SORTED ARGUMENT AS VALUE - MOVE B,VAL1 - JRST FINIS - -DESCEND: CAMG C,(A)+1 -ASCEND: CAML C,(A)+1 - ;ROUTINE TO SORT LISTS IN NUMERICAL ORDER - -LSORT: MOVE A,VAL1 - JUMPE A,GOBACK ;EMPTY LIST? - HLRZ B,(A) ;TYPE OF FIRST COMPONENT - CAIE B,TFIX - CAIN B,TFLOAT - SKIPA - JRST WRONGT - MOVEI E,0 ;FOR COUNT OF LENGTH OF LIST -LCOUNT: JUMPE A,LLSORT ;REACHED END OF LIST? - MOVE A,(A) ;NEXT COMPONENT - TLZ A,(B) ;SAME TYPE AS FIRST COMPONENT? - TLNE A,-1 - JRST WRONGT - AOJA E,LCOUNT ;INCREMENT COUNT AND CONTINUE - -LLSORT: SOJE E,GOBACK ;FINISHED WITH SORTING? - HRRZ A,VAL1 ;START THIS LOOP OF SORTING AT THE BEGINNING - MOVEM E,(P)+1 ;Save the iteration depth -CLSORT: HRRZ B,(A) ;NEXT COMPONENT - MOVE C,(B)+1 ;ITS VALUE - XCT O ;ARE THESE TWO COMPONENTS IN ORDER? - JRST .+4 - MOVE D,(A)+1 ;INTERCHANGE THEM - MOVEM D,(B)+1 - MOVEM C,(A)+1 - MOVE A,B ;MAKE THE COMPONENT IN "B" THE CURRENT ONE - SOJG E,CLSORT - MOVE E,(P)+1 ;Restore the iteration depth - JRST LLSORT - ;ROUTINE TO SORT VECTORS IN NUMERICAL ORDER - -VSORT: HLRE D,VAL1 ;GET COUNT FIELD OF VECTOR - IDIV D,[-2] ;LENGTH - JUMPE D,GOBACK ;EMPTY VECTOR? - MOVE E,D ;SAVE LENGTH IN "E" - HRRZ A,VAL1 ;POINTER TO VECTOR - MOVE B,(A) ;TYPE OF FIRST COMPONENT - CAME B,$TFIX - CAMN B,$TFLOAT - SKIPA - JRST WRONGT - SOJLE D,GOBACK ;IF ONLY ONE COMPONENT THEN FINISHED -VCOUNT: ADDI A,2 ;CHECK NEXT COMPONENT - CAME B,(A) ;SAME TYPE AS FIRST COMPONENT? - JRST WRONGT - SOJG D,VCOUNT ;CONTINUE WITH NEXT COMPONENT - -VVSORT: SOJE E,GOBACK ;FINISHED SORTING? - HRRZ A,VAL1 ;START THIS LOOP OF SORTING AT THE BEGINNING - MOVEM E,(P)+1 ;Save the iteration depth -CVSORT: MOVE C,(A)+3 ;VALUE OF NEXT COMPONENT - XCT O ;ARE THESE TWO COMPONENTS IN ORDER? - JRST .+4 - MOVE D,(A)+1 ;INTERCHANGE THEM - MOVEM D,(A)+3 - MOVEM C,(A)+1 - ADDI A,2 ;UPDATE THE CURRENT COMPONENT - SOJG E,CVSORT - MOVE E,(P)+1 ;Restore the iteration depth - JRST VVSORT -] - -MFUNCTION TIME,SUBR - ENTRY - PUSHJ P,CTIME - JRST FINIS - -IMPURE - -RHI: 267762113337 -RLOW: 155256071112 -PURE - - -END - TITLE ATOMHACKER FOR MUDDLE - -RELOCATABLE - -.INSRT MUDDLE > -.GLOBAL RLOOKU,CHMAK,OBLNT,ROOT,INTOBL,ERROBL,IFALSE -.GLOBAL .BLOCK,IDVAL,NXTDCL,CHRWRD,CSTACK,CSTAK,ILOOKC,IGVAL,BYTDOP -.GLOBAL ICONS,INCONS,IBLOCK,INSRTX,GCHACK,IMPURIFY -.GLOBAL CINSER,CIRMV,CLOOKU,CATOM,CIPNAM,MPOPJ,CSETG - -.VECT.==40000 ; BIT FOR GCHACK - -; FUNCTION TO GENERATE AN EMPTY OBLIST - -MFUNCTION MOBLIST,SUBR - - ENTRY - CAMGE AB,[-5,,0] ;CHECK NUMBER OF ARGS - JRST TMA - JUMPGE AB,MOBL2 ; NO ARGS - PUSH TP,(AB) - PUSH TP,1(AB) - PUSH TP,$TATOM - PUSH TP,IMQUOTE OBLIST - MCALL 2,GET ; CHECK IF IT EXISTS ALREADY - CAMN A,$TOBLS - JRST FINIS -MOBL2: MOVE A,OBLNT ;GET DEFAULT LENGTH - CAML AB,[-3,,0] ;IS LENGTH SUPPLIED - JRST MOBL1 ;NO, USE STANDARD LENGTH - GETYP C,2(AB) ;GET ARG TYPE - CAIE C,TFIX - JRST WTYP2 ;LOSE - MOVE A,3(AB) ;GET LENGTH -MOBL1: PUSH TP,$TFIX - PUSH TP,A - MCALL 1,UVECTOR ;GET A UNIFORM VECTOR - MOVSI C,TLIST+.VECT. ;IT IS OF TYPE LIST - HLRE D,B ;-LENGTH TO D - SUBM B,D ;D POINTS TO DOPE WORD - MOVEM C,(D) ;CLOBBER TYPE IN - MOVSI A,TOBLS - JUMPGE AB,FINIS ; IF NO ARGS, DONE - GETYP A,(AB) - CAIE A,TATOM - JRST WTYP1 - PUSH TP,$TOBLS - PUSH TP,B - PUSH TP,$TOBLS - PUSH TP,B - PUSH TP,$TATOM - PUSH TP,IMQUOTE OBLIST - PUSH TP,(AB) - PUSH TP,1(AB) - MCALL 3,PUT ; PUT THE NAME ON THE OBLIST - PUSH TP,(AB) - PUSH TP,1(AB) - PUSH TP,$TATOM - PUSH TP,IMQUOTE OBLIST - PUSH TP,(TB) - PUSH TP,1(TB) - MCALL 3,PUT ; PUT THE OBLIST ON THE NAME - - POP TP,B - POP TP,A - JRST FINIS - -MFUNCTION GROOT,SUBR,ROOT - ENTRY 0 - MOVE A,ROOT(TVP) - MOVE B,ROOT+1(TVP) - JRST FINIS - -MFUNCTION GINTS,SUBR,INTERRUPTS - ENTRY 0 - MOVE A,INTOBL(TVP) - MOVE B,INTOBL+1(TVP) - JRST FINIS - -MFUNCTION GERRS,SUBR,ERRORS - ENTRY 0 - MOVE A,ERROBL(TVP) - MOVE B,ERROBL+1(TVP) - JRST FINIS - - -COBLQ: SKIPN B,2(B) ; SKIP IF EXISTS - JRST IFLS - MOVSI A,TOBLS - JUMPL B,CPOPJ1 - ADDI B,(TVP) - MOVE B,(B) -CPOPJ1: AOS (P) - POPJ P, - -IFLS: MOVEI B,0 - MOVSI A,TFALSE - POPJ P, - -MFUNCTION OBLQ,SUBR,[OBLIST?] - - ENTRY 1 - GETYP A,(AB) - CAIE A,TATOM - JRST WTYP1 - MOVE B,1(AB) ; GET ATOM - PUSHJ P,COBLQ - JFCL - JRST FINIS - - ; FUNCTION TO FIND AN ATOM ON A GIVEN OBLIST WITH A GIVEN PNAME - -MFUNCTION LOOKUP,SUBR - - ENTRY 2 - PUSHJ P,ILOOKU ;CALL INTERNAL ROUTINE - JRST FINIS - -CLOOKU: SUBM M,(P) - PUSH TP,A - PUSH TP,B - MOVEI B,-1(TP) - PUSH TP,$TOBLS - PUSH TP,C - GETYP A,A - PUSHJ P,CSTAK - MOVE B,(TP) - PUSHJ P,ILOOK - POP P,D - HRLI D,(D) - SUB P,D - SKIPE B - SOS (P) - SUB TP,[4,,4] - JRST MPOPJ - -ILOOKU: PUSHJ P,ARGCHK ;CHECK ARGS - PUSHJ P,CSTACK ;PUT CHARACTERS ON THE STACK - -CALLIT: MOVE B,3(AB) ;GET OBLIST -ILOOKC: PUSHJ P,ILOOK ;LOOK IT UP - POP P,D ;RESTORE COUNT - HRLI D,(D) ;TO BOTH SIDES - SUB P,D - POPJ P, - -;THIS ROUTINE CHECKS ARG TYPES - -ARGCHK: GETYP A,(AB) ;GET TYPES - GETYP C,2(AB) - CAIE A,TCHRS ;IS IT EITHER CHAR STRING - CAIN A,TCHSTR - CAIE C,TOBLS ;IS 2ND AN OBLIST - JRST WRONGT ;TYPES ARE WRONG - POPJ P, - -;THIS SUBROUTINE PUTS CHARACTERS ON THE STACK (P WILL BE CHANGED) - - -CSTACK: MOVEI B,(AB) -CSTAK: POP P,D ;RETURN ADDRESS TO D - CAIE A,TCHRS ;IMMEDIATE? - JRST NOTIMM ;NO, HAIR - MOVE A,1(B) ; GET CHAR - LSH A,29. ; POSITION - PUSH P,A ;ONTO P - PUSH P,[1] ;WITH NUMBER - JRST (D) ;GO CALL SEARCHER - -NOTIMM: MOVEI A,1 ; CLEAR CHAR COUNT - HRRZ C,(B) ; GET COUNT OF CHARS - JUMPE C,NULST ; FLUSH NULL STRING - MOVE B,1(B) ;GET BYTE POINTER - -CLOOP1: PUSH P,[0] ; STORE CHARS ON STACK - MOVSI E,(<440700,,(P)>) ; SETUP BYTE POINTER -CLOOP: ILDB 0,B ;GET A CHARACTER - IDPB 0,E ;STORE IT - SOJE C,CDONE ; ANY MORE? - TLNE E,760000 ; WORD FULL - JRST CLOOP ;NO CONTINUE - AOJA A,CLOOP1 ;AND CONTINUE - -CDONE: -CDONE1: PUSH P,A ;AND NUMBER OF WORDS - JRST (D) ;RETURN - - -NULST: PUSH TP,$TATOM - PUSH TP,EQUOTE NULL-STRING - JRST CALER1 - ; THIS FUNCTION LOOKS FOR ATOMS. CALLED BY PUSHJ P,ILOOK -; B/ OBLIST POINTER -; -1(P)/ LENGTH IN WORDS OF CHARACTER BLOCK -; CHAR STRING IS ON THE STACK - -ILOOK: MOVN A,-1(P) ;GET -LENGTH - HRLI A,-1(A) ;<-LENGTH-1>,,-LENGTH - PUSH TP,$TFIX ;SAVE - PUSH TP,A - ADDI A,-1(P) ;HAVE AOBJN POINTER TO CHARS - MOVEI D,0 ;HASH WORD - XOR D,(A) - AOBJN A,.-1 ;XOR THEM ALL TOGETHER - HLRE A,B ;GET LENGTH OF OBLIST - MOVNS A - TLZ D,400000 ; MAKE SURE + HASH CODE - IDIVI D,(A) ;DIVIDE - HRLI E,(E) ;TO BOTH HALVES - ADD B,E ;POINT TO BUCKET - - MOVEI 0,(B) ;IN CASE REMOVING 1ST - SKIPN C,(B) ;BUCKET EMPTY? - JRST NOTFND ;YES, GIVE UP -LOOK2: SKIPN A,1(C) ;NIL CAR ON LIST? - JRST NEXT ;YES TRY NEXT - ADD A,[3,,3] ;POINT TO ATOMS PNAME - MOVE D,(TP) ;GET PSEUDO AOBJN POINTER TO CHARS - ADDI D,-1(P) ;NOW ITS A REAL AOBJN POINTER - JUMPE D,CHECK0 ;ONE IS EMPTY -LOOK1: MOVE E,(D) ;GET A WORD - CAME E,(A) ;COMPARE - JRST NEXT ;THIS ONE DOESN'T MATCH - AOBJP D,CHECK ;ONE RAN OUT - AOBJN A,LOOK1 ;JUMP IF STILL MIGHT WIN - -NEXT: MOVEI 0,(C) ;POINT TO PREVIOUS ELEMENT - HRRZ C,(C) ;STEP THROUGH - JUMPN C,LOOK2 - -NOTFND: EXCH C,B ;RETURN BUCKET IN B - MOVSI A,TFALSE -CPOPJT: SUB TP,[2,,2] ;REMOVE RANDOM TP STUFF - POPJ P, - -CHECK0: JUMPN A,NEXT ;JUMP IF NOT ALSO EMPTY - SKIPA -CHECK: AOBJN A,NEXT ;JUMP IF NO MATCH - HLLZ A,(C) - MOVE E,B ; RETURN BUCKET - MOVE B,1(C) ;GET ATOM - JRST CPOPJT - - - ; FUNCTION TO INSERT AN ATOM ON AN OBLIST - -MFUNCTION INSERT,SUBR - - ENTRY 2 - GETYP A,2(AB) - CAIE A,TOBLS - JRST WTYP2 - MOVE A,(AB) - MOVE B,1(AB) - MOVE C,3(AB) - PUSHJ P,IINSRT - JRST FINIS - -CINSER: SUBM M,(P) - PUSHJ P,IINSRT - JRST MPOPJ - -IINSRT: PUSH TP,A - PUSH TP,B - PUSH TP,$TOBLS - PUSH TP,C - GETYP A,A - CAIN A,TATOM - JRST INSRT0 - -;INSERT WITH A GIVEN PNAME - - CAIE A,TCHRS - CAIN A,TCHSTR - JRST .+2 - JRST WTYP1 - - PUSH TP,$TFIX ;FLAG CALL - PUSH TP,[0] - MOVEI B,-5(TP) - PUSHJ P,CSTAK ;COPY ONTO STACK - MOVE B,-2(TP) - PUSHJ P,ILOOK ;LOOK IT UP (BUCKET RETURNS IN C) - JUMPN B,ALRDY ;EXISTS, LOSE - MOVE D,-2(TP) ; GET OBLIST BACK -INSRT1: PUSH TP,$TOBLS ;SAVE BUCKET POINTER - PUSH TP,C - PUSH TP,$TOBLS - PUSH TP,D ; SAVE OBLIST -INSRT3: PUSHJ P,IATOM ; MAKE AN ATOM - PUSHJ P,LINKCK ; A LINK REALLY NEEDED ? - MOVE E,-2(TP) - HRRZ E,(E) ; GET BUCKET - PUSHJ P,ICONS - MOVE C,-2(TP) ;BUCKET AGAIN - HRRM B,(C) ;INTO NEW BUCKET - MOVSI A,TATOM - MOVE B,1(B) ;GET ATOM BACK - MOVE D,(TP) ; GET OBLIST - MOVEM D,2(B) ; AND CLOBBER - MOVE C,-4(TP) ;GET FLAG - SUB TP,[6,,6] ;POP STACK - JUMPN C,(C) - SUB TP,[4,,4] - POPJ P, - -;INSERT WITH GIVEN ATOM -INSRT0: MOVE A,-2(TP) ;GOBBLE PNAME - SKIPE 2(A) ; SKIP IF NOT ON AN OBLIST - JRST ONOBL - ADD A,[3,,3] - HLRE C,A - MOVNS C - PUSH P,(A) ;FLUSH PNAME ONTO P STACK - AOBJN A,.-1 - PUSH P,C - MOVE B,(TP) ; GET OBLIST FOR LOOKUP - PUSHJ P,ILOOK ;ALREADY THERE? - JUMPN B,ALRDY - PUSH TP,$TOBLS ;SAVE NECESSARY STUFF AWAY FROM CONS - PUSH TP,C ;WHICH WILL MAKE A LIST FROM THE ATOM - MOVSI C,TATOM - MOVE D,-4(TP) - PUSHJ P,INCONS - MOVE C,(TP) ;RESTORE - HRRZ D,(C) - HRRM B,(C) - HRRM D,(B) - MOVE C,-2(TP) - MOVE B,-4(TP) ; GET BACK ATOM - MOVEM C,2(B) ; CLOBBER OBLIST IN - MOVSI A,TATOM - SUB TP,[6,,6] - POP P,C - HRLI C,(C) - SUB P,C - POPJ P, - -LINKCK: HRRZ C,FSAV(TB) ;CALLER'S NAME - CAIN C,LINK - SKIPA C,$TLINK ;LET US INSERT A LINK INSTEAD OF AN ATOM - MOVSI C,TATOM ;GET REAL ATOM FOR CALL TO ICONS - MOVE D,B - POPJ P, - - - -ALRDY: PUSH TP,$TATOM - PUSH TP,EQUOTE ATOM-ALREADY-THERE - JRST CALER1 - -ONOBL: PUSH TP,$TATOM - PUSH TP,EQUOTE ON-AN-OBLIST-ALREADY - JRST CALER1 - -; INTERNAL INSERT CALL - -INSRTX: POP P,0 ; GET RET ADDR - PUSH TP,$TFIX - PUSH TP,0 - PUSH TP,$TOBLS - PUSH TP,B - PUSH TP,$TOBLS - PUSH TP,B - PUSHJ P,ILOOK - JUMPN B,INSRXT - MOVEM C,-2(TP) - JRST INSRT3 ; INTO INSERT CODE - -INSRXT: PUSH P,-4(TP) - SUB TP,[6,,6] - POPJ P, - JRST IATM1 - -; FUNCTION TO REMOVE AN ATOM FROM AN OBLIST - -MFUNCTION REMOVE,SUBR - - ENTRY - - JUMPGE AB,TFA - CAMGE AB,[-5,,] - JRST TMA - MOVEI C,0 - CAML AB,[-3,,] ; SKIP IF OBLIST GIVEN - JRST .+5 - GETYP 0,2(AB) - CAIE 0,TOBLS - JRST WTYP2 - MOVE C,3(AB) - MOVE A,(AB) - MOVE B,1(AB) - PUSHJ P,IRMV - JRST FINIS - -CIRMV: SUBM M,(P) - PUSHJ P,IRMV - JRST MPOPJ - -IRMV: PUSH TP,A - PUSH TP,B - PUSH TP,$TOBLS - PUSH TP,C -IRMV1: GETYP 0,A ; CHECK 1ST ARG - CAIN 0,TLINK - JRST .+3 - CAIE 0,TATOM ; ATOM, TREAT ACCORDINGLY - JRST RMV1 - - SKIPN D,2(B) ; SKIP IF ON OBLIST AND GET SAME - JRST IFALSE - JUMPL D,.+3 - ADDI D,(TVP) - MOVE D,(D) - JUMPE C,GOTOBL - CAME C,D ; BETTER BE THE SAME - JRST ONOTH - -GOTOBL: ADD B,[3,,3] ; POINT TO PNAME - HLRE A,B - MOVNS A - PUSH P,(B) ; PUSH PNAME - AOBJN B,.-1 - PUSH P,A - MOVEM D,(TP) ; SAVE OBLIST - JRST RMV3 - -RMV1: JUMPE C,TFA - CAIE 0,TCHRS - CAIN 0,TCHSTR - SKIPA A,0 - JRST WTYP1 - MOVEI B,-3(TP) - PUSHJ P,CSTAK -RMV3: MOVE B,(TP) - PUSHJ P,ILOOK - POP P,D - HRLI D,(D) - SUB P,D - JUMPE B,RMVDON - HRRZ D,0 ;PREPARE TO SPLICE (0 POINTS PRIOR TO LOSING PAIR) - HRRZ C,(C) ;GET NEXT OF LOSING PAIR - MOVEI 0,(B) - CAIGE 0,HIBOT ; SKIP IF PURE - JRST RMV2 - PUSHJ P,IMPURIFY - MOVE A,-3(TP) - MOVE B,-2(TP) - MOVE C,(TP) - JRST IRMV1 -RMV2: HRRM C,(D) ;AND SPLICE - SETZM 2(B) ; CLOBBER OBLIST SLOT -RMVDON: SUB TP,[4,,4] - POPJ P, - - -;INTERNAL CALL FROM THE READER - -RLOOKU: PUSH TP,$TFIX ;PUSH A FLAG - POP P,C ;POP OFF RET ADR - PUSH TP,C ;AND USE AS A FLAG FOR INTERNAL - MOVE C,(P) ; CHANGE CHAR COUNT TO WORD - ADDI C,4 - IDIVI C,5 - MOVEM C,(P) - - CAMN A,$TOBLS ;IS IT ONE OBLIST? - JRST RLOOK1 - CAME A,$TLIST ;IS IT A LIST - JRST BADOBL - - JUMPE B,BADLST - PUSH TP,$TOBLS ; SLOT FOR REMEBERIG - PUSH TP,[0] - PUSH TP,$TOBLS - PUSH TP,[0] - PUSH TP,A - PUSH TP,B - -RLOOK2: GETYP A,(B) ;CHECK THIS IS AN OBLIST - MOVE B,1(B) ;VALUE - CAIE A,TOBLS - JRST DEFALT - PUSHJ P,ILOOK ;LOOK IT UP - JUMPN B,RLOOK3 ;WIN - SKIPE -2(TP) ; SKIP IF DEFAULT NOT STORED - JRST RLOOK4 - HRRZ D,(TP) ; GET CURRENT - MOVE D,1(D) ; OBLIST - MOVEM D,-2(TP) - MOVEM C,-4(TP) ; FOR INSERT IF NEEDED -RLOOK4: INTGO - HRRZ B,@(TP) ;CDR THE LIST - HRRZM B,(TP) - JUMPN B,RLOOK2 - SKIPN D,-2(TP) ; RESTORE FOR INSERT - JRST BADDEF ; NO DEFAULT, USER LOST ON SPECIFICATION - MOVE C,-4(TP) - SUB TP,[6,,6] ; FLUSH CRAP - JRST INSRT1 - -DEFFLG==1 ;SPECIAL FLAG USED TO INDICATE THAT A DEFAULT HAS ALREADY BEEN SPECIFIED -DEFALT: CAIN A,TATOM ;SPECIAL DEFAULT INDICATING ATOM ? - CAME B,MQUOTE DEFAULT - JRST BADDEF ;NO, LOSE - MOVSI A,DEFFLG - XORB A,-6(TP) ;SET AND TEST FLAG - TLNN A,DEFFLG ; HAVE WE BEEN HERE BEFORE ? - JRST BADDEF ; YES, LOSE - SETZM -2(TP) ;ZERO OUT PREVIOUS DEFAULT - SETZM -4(TP) - JRST RLOOK4 ;CONTINUE - -RLOOK1: PUSH TP,$TOBLS - PUSH TP,B ; SAVE OBLIST - PUSHJ P,ILOOK ;LOOK IT UP THERE - MOVE D,(TP) ; GET OBLIST - SUB TP,[2,,2] - JUMPE B,INSRT1 ;GO INSET IT - - -INSRT2: JRST .+2 ; -RLOOK3: SUB TP,[6,,6] ;POP OFF LOSSAGE - PUSHJ P,ILINK ;IF THIS IS A LINK FOLLOW IT - PUSH P,(TP) ;GET BACK RET ADR - SUB TP,[2,,2] ;POP TP - JRST IATM1 ;AND RETURN - - -BADOBL: PUSH TP,$TATOM - PUSH TP,EQUOTE BAD-OBLIST-OR-LIST-THEREOF - JRST CALER1 - -BADDEF: PUSH TP,$TATOM - PUSH TP,EQUOTE BAD-DEFAULT-OBLIST-SPECIFICATION - JRST CALER1 - -ONOTH: PUSH TP,$TATOM - PUSH TP,EQUOTE ATOM-ON-DIFFERENT-OBLIST - JRST CALER1 - ;SUBROUTINE TO MAKE AN ATOM - -MFUNCTION ATOM,SUBR - - ENTRY 1 - - MOVE A,(AB) - MOVE B,1(AB) - PUSHJ P,IATOMI - JRST FINIS - -CATOM: SUBM M,(P) - PUSHJ P,IATOMI - JRST MPOPJ - -IATOMI: GETYP 0,A ;CHECK ARG TYPE - CAIE 0,TCHRS - CAIN 0,TCHSTR - JRST .+2 ;JUMP IF WINNERS - JRST WTYP1 - - PUSH TP,A - PUSH TP,B - MOVEI B,-1(TP) - MOVE A,0 - PUSHJ P,CSTAK ;COPY ONTO STACK - PUSHJ P,IATOM ;NOW MAKE THE ATOM - POPJ P, - -;INTERNAL ATOM MAKER - -IATOM: MOVE A,-1(P) ;GET WORDS IN PNAME - ADDI A,3 ;FOR VALUE CELL - PUSHJ P,IBLOCK ; GET BLOCK - MOVSI C,<(GENERAL)>+SATOM+.VECT. ;FOR TYPE FIELD - MOVE D,-1(P) ;RE-GOBBLE LENGTH - ADDI D,3(B) ;POINT TO DOPE WORD - MOVEM C,(D) - SKIPG -1(P) ;EMPTY PNAME ? - JRST IATM0 ;YES, NO CHARACTERS TO MOVE - MOVE E,B ;COPY ATOM POINTER - ADD E,[3,,3] ;POINT TO PNAME AREA - MOVEI C,-1(P) - SUB C,-1(P) ;POINT TO STRING ON STACK - MOVE D,(C) ;GET SOME CHARS - MOVEM D,(E) ;AND COPY THEM - ADDI C,1 - AOBJN E,.-3 -IATM0: MOVSI A,TATOM ;TYPE TO ATOM -IATM1: POP P,D ;RETURN ADR - POP P,C - HRLI C,(C) - SUB P,C - JRST (D) ;RETURN - - ;SUBROUTINE TO GET AN ATOM'S PNAME - -MFUNCTION PNAME,SUBR - - ENTRY 1 - - GETYP A,(AB) - CAIE A,TATOM ;CHECK TYPE IS ATOM - JRST WTYP1 - MOVE A,1(AB) - PUSHJ P,IPNAME - JRST FINIS - -CIPNAM: SUBM M,(P) - PUSHJ P,IPNAME - JRST MPOPJ - -IPNAME: ADD A,[3,,3] - HLRE B,A - MOVM B,B - PUSH P,(A) ;FLUSH PNAME ONTO P - AOBJN A,.-1 - IMULI B,5 ; CHARS TO B - MOVE 0,(P) ; LAST WORD - MOVE A,0 - SUBI A,1 ; FIND LAST 1 - ANDCM 0,A ; 0 HAS 1ST 1 - JFFO 0,.+1 - HRREI 0,-34.(A) ; FIND HOW MUCH TO ADD - IDIVI 0,7 - ADD B,0 - PUSH P,B - PUSHJ P,CHMAK ;MAKE A STRING - POPJ P, - - ; BLOCK STRUCTURE SUBROUTINES FOR MUDDLE - -MFUNCTION BLK,SUBR,BLOCK - - ENTRY 1 - - GETYP A,(AB) ;CHECK TYPE OF ARG - CAIE A,TOBLS ;IS IT AN OBLIST - CAIN A,TLIST ;OR A LIAT - JRST .+2 - JRST WTYP1 - MOVSI A,TATOM ;LOOK UP OBLIST - MOVE B,IMQUOTE OBLIST - PUSHJ P,IDVAL ;GET VALUE - PUSH TP,A - PUSH TP,B - PUSH TP,.BLOCK(PVP) ;HACK THE LIST - PUSH TP,.BLOCK+1(PVP) - MCALL 2,CONS ;CONS THE LIST - MOVEM A,.BLOCK(PVP) ;STORE IT BACK - MOVEM B,.BLOCK+1(PVP) - PUSH TP,$TATOM - PUSH TP,IMQUOTE OBLIST - PUSH TP,(AB) - PUSH TP,1(AB) - MCALL 2,SET ;SET OBLIST TO ARG - JRST FINIS - -MFUNCTION ENDBLOCK,SUBR - - ENTRY 0 - - SKIPN B,.BLOCK+1(PVP) ;IS THE LIST NIL? - JRST BLKERR ;YES, LOSE - HRRZ C,(B) ;CDR THE LIST - HRRZM C,.BLOCK+1(PVP) - PUSH TP,$TATOM ;NOW RESET OBLIST - PUSH TP,IMQUOTE OBLIST - HLLZ A,(B) ;PUSH THE TYPE OF THE CAR - PUSH TP,A - PUSH TP,1(B) ;AND VALUE OF CAR - MCALL 2,SET - JRST FINIS - -BLKERR: PUSH TP,$TATOM - PUSH TP,EQUOTE UNMATCHED - JRST CALER1 - -BADLST: PUSH TP,$TATOM - PUSH TP,EQUOTE NIL-LIST-OF-OBLISTS - JRST CALER1 - ;SUBROUTINE TO CREATE CHARACTER STRING GOODIE - -CHMAK: MOVE A,-1(P) - ADDI A,4 - IDIVI A,5 - PUSHJ P,IBLOCK - MOVEI C,-1(P) ;FIND START OF CHARS - HLRE E,B ; - LENGTH - ADD C,E ;C POINTS TO START - MOVE D,B ;COPY VECTOR RESULT - JUMPGE D,NULLST ;JUMP IF EMPTY - MOVE A,(C) ;GET ONE - MOVEM A,(D) - ADDI C,1 ;BUMP POINTER - AOBJN D,.-3 ;COPY -NULLST: MOVSI C,TCHRS+.VECT. ;GET TYPE - MOVEM C,(D) ;CLOBBER IT IN - MOVE A,-1(P) ; # WORDS - HRLI A,TCHSTR - HRLI B,440700 - MOVMM E,-1(P) ; SO IATM1 WORKS - JRST IATM1 ;RETURN - -; SUBROUTINE TO READ FIVE CHARS FROM STRING. -; TWO CALLS, ONE WITH A POINTING TO LIST ELEMENT, -; THE OTHER WITH B POINTING TO PAIR. SKIPS IF WINNER, ELSE DOESNT - -NXTDCL: GETYP B,(A) ;CHECK TYPE - CAIE B,TDEFER ;LOSE IF NOT DEFERRED - POPJ P, - - MOVE B,1(A) ;GET REAL BYTE POINTER -CHRWRD: PUSH P,C - GETYP C,(B) ;CHECK IT IS CHSTR - CAIE C,TCHSTR - JRST CPOPJC ;NO, QUIT - PUSH P,D - PUSH P,E - PUSH P,0 - MOVEI E,0 ;INITIALIZE DESTINATION - HRRZ C,(B) ; GET CHAR COUNT - JUMPE C,GOTDCL ; NULL, FINISHED - MOVE B,1(B) ;GET BYTE POINTER - MOVE D,[440700,,E] ;BYTE POINT TO E -CHLOOP: ILDB 0,B ; GET A CHR - IDPB 0,D ;CLOBBER AWAY - SOJE C,GOTDCL ; JUMP IF DONE - TLNE D,760000 ; SKIP IF WORD FULL - JRST CHLOOP ; MORE THAN 5 CHARS - TRO E,1 ; TURN ON FLAG - -GOTDCL: MOVE B,E ;RESULT TO B - AOS -4(P) ;SKIP RETURN -CPOPJ0: POP P,0 - POP P,E - POP P,D -CPOPJC: POP P,C - POPJ P, - -; SUBROUTINE TO FIND A BYTE STRINGS DOPE WORD -; RECEIVES POINTER TO PAIR CONNTAINIGN CHSTR IN C, RETURNS DOPE WORD IN A - -BYTDOP: PUSH P,B ; SAVE SOME ACS - PUSH P,D - PUSH P,E - MOVE B,1(C) ; GET BYTE POINTER - LDB D,[360600,,B] ; POSITION TO D - LDB E,[300600,,B] ; AND BYTE SIZE - MOVEI A,(E) ; A COPY IN A - IDIVI D,(E) ; D=> # OF BYTES IN WORD 1 - HRRZ E,(C) ; GET LENGTH - SUBM E,D ; # OF BYTES IN OTHER WORDS - JUMPL D,BYTDO1 ; NEAR DOPE WORD - MOVEI B,36. ; COMPUTE BYTES PER WORD - IDIVM B,A - ADDI D,-1(A) ; NOW COMPUTE WORDS - IDIVI D,(A) ; D/ # NO. OF WORDS PAST 1ST - ADD D,1(C) ; D POINTS TO DOPE WORD - MOVEI A,2(D) - -BYTDO2: POP P,E - POP P,D - POP P,B - POPJ P, -BYTDO1: MOVEI A,1(B) - CAME D,[-5] - AOJA A,BYTDO2 - JRST BYTDO2 - ;ROUTINES TO DEFINE AND HANDLE LINKS - -MFUNCTION LINK,SUBR - ENTRY - CAML AB,[-6,,0] ;NO MORE THAN 3 ARGS - CAML AB,[-2,,0] ;NO LESS THAN 2 ARGS - JRST WNA - CAML AB,[-4,,0] ;ONLY TWO ARGS SUPPLIED ? - JRST GETOB ;YES, GET OBLIST FROM CURRENT PATH - MOVE A,2(AB) - MOVE B,3(AB) - MOVE C,5(AB) - JRST LINKIN -GETOB: MOVSI A,TATOM - MOVE B,IMQUOTE OBLIST - PUSHJ P,IDVAL - CAMN A,$TOBLS - JRST LINKP - CAME A,$TLIST - JRST BADOBL - JUMPE B,BADLST - GETYPF A,(B) - MOVE B,(B)+1 -LINKP: MOVE C,B - MOVE A,2(AB) - MOVE B,3(AB) -LINKIN: PUSHJ P,IINSRT - CAMN A,$TFALSE ;LINK NAME ALREADY USED ? - JRST ALRDY ;YES, LOSE - MOVE C,B - MOVE A,(AB) - MOVE B,1(AB) - PUSHJ P,CSETG - JRST FINIS - - -ILINK: CAME A,$TLINK ;FOUND A LINK ? - POPJ P, ;NO, FINISHED - MOVSI A,TATOM - PUSHJ P,IGVAL ;GET THE LINK'S DESTINATION - CAME A,$TUNBOUND ;WELL FORMED LINK ? - POPJ P, ;YES - PUSH TP,$TATOM - PUSH TP,EQUOTE BAD-LINK - JRST CALER1 - - -; THIS SUBROUTINE IMPURIFIES A PURE ATOM TO ALLOW MODIFICATION OF SYSTEM SUBRS - -IMPURIFY: - PUSH TP,$TATOM - PUSH TP,B - MOVE C,B - MOVEI 0,(C) - CAIGE 0,HIBOT - JRST RTNATM ; NOT PURE, RETURN - -; 1) IMPURIFY ITS OBLIST BUCKET - - SKIPN B,2(C) ; PICKUP OBLIST IF IT EXISTS - JRST IMPUR1 ; NOT ON ONE, IGNORE THIS CODE - - ADDI B,(TVP) ; POINT TO SLOT - MOVE B,(B) ; GET THE REAL THING - ADD C,[3,,3] ; POINT TO PNAME - HLRE A,C ; GET LNTH IN WORDS OF PNAME - MOVNS A - PUSH P,[IMPUR2] ; FAKE OUT ILOOKC - PUSH P,(C) ; PUSH UP THE PNAME - AOBJN C,.-1 - PUSH P,A ; NOW THE COUNT - JRST ILOOKC ; GO FIND BUCKET - -IMPUR2: JUMPE B,IMPUR1 ; NOT THERE, GO - PUSH TP,$TOBLS ; SAVE BUCKET - PUSH TP,E - - MOVE B,(E) ; GET NEXT ONE -IMPUR4: MOVEI 0,(B) - CAIGE 0,HIBOT ; SKIP IF PURE - JRST IMPUR3 ; FOUND IMPURE NESS, SKIP IT - HLLZ C,(B) ; SET UP ICONS CALL - HRRZ E,(B) - MOVE D,1(B) - PUSHJ P,ICONS ; CONS IT UP - HRRZ E,(TP) ; RETRV PREV - HRRM B,(E) ; AND CLOBBER -IMPUR3: MOVSI 0,TLIST - MOVEM 0,-1(TP) ; FIX TYPE - HRRZM B,(TP) ; STORE GOODIE - HRRZ B,(B) ; CDR IT - JUMPN B,IMPUR4 ; LOOP - SUB TP,[2,,2] ; FLUSH TP CRUFT - -; 2) GENERATE A DUPLICATE ATOM - -IMPUR1: HLRE A,(TP) ; GET LNTH OF ATOM - MOVNS A - PUSH P,A - PUSHJ P,IBLOCK ; GET NEW BLOCK FOR ATOM - PUSH TP,$TATOM - PUSH TP,B - HRL B,-2(TP) ; SETUP BLT - POP P,A - ADDI A,(B) ; END OF BLT - BLT B,(A) ; CLOBBER NEW ATOM - MOVSI B,.VECT. ; TURN ON BIT FOR GCHACK - IORM B,(A) - -; 3) NOW COPY GLOBAL VALUE - - MOVE B,(TP) ; ATOM BACK - GETYP 0,(B) - SKIPE A,1(B) ; NON-ZER POINTER? - CAIN 0,TUNBOU ; BOUND? - JRST IMPUR5 ; NO, DONT COPY GLOB VAL - PUSH TP,$TATOM - PUSH TP,B - PUSH TP,(A) - PUSH TP,1(A) - SETZM (B) - SETZM 1(B) - MCALL 2,SETG -IMPUR5: PUSH TP,$TFIX ;SAVE OLD ATOM WITH FUNNY TYPE TO AVOID LOSSAGE - PUSH TP,-3(TP) - -; 4) UPDATE ALL POINTERS TO THIS ATOM - - MOVE A,[PUSHJ P,ATFIX] ; INS TO PASS TO GCHACK - PUSHJ P,GCHACK - SUB TP,[4,,4] - -RTNATM: POP TP,B - POP TP,A - POPJ P, - -; ROUTINE PASSED TO GCHACK - -ATFIX: CAIE C,TGATOM ; GLOBAL TYPE ATOM - CAIN C,TATOM - CAME D,(TP) ; SKIP IF WINNER - POPJ P, - MOVE D,-2(TP) - SKIPE B - MOVEM D,1(B) - POPJ P, - - -END - -TITLE PROCESS-HACKER FOR MUDDLE - -RELOCATABLE - -.INSRT MUDDLE > - -.GLOBAL ICR,NAPT,IGVAL,CHKARG,RESFUN,RETPROC,SWAP,MAINPR,PROCHK,NOTRES -.GLOBAL PSTAT,LSTRES,TOPLEV,MAINPR,1STEPR,INCONS -.GLOBAL TBINIT,APLQ - -MFUNCTION PROCESS,SUBR - - ENTRY 1 - GETYP A,(AB) ;GET TYPE OF ARG - ;MUST BE SOME APPLIABLE TYPE - PUSHJ P,APLQ - JRST NAPT ;NO, ERROR - NON-APPLIABLE TYPE -OKFUN: - - PUSHJ P,ICR ;CREATE A NEW PROCESS - MOVE C,TPSTO+1(B) ;GET ITS SRTACK - PUSH C,[TENTRY,,TOPLEV] - PUSH C,[1,,0] ;TIME - PUSH C,[0] - PUSH C,SPSTO+1(B) - PUSH C,PSTO+1(B) - MOVE D,C - ADD D,[3,,3] - PUSH C,D ;SAVED STACK POINTER - PUSH C,[SUICID] - MOVEM C,TPSTO+1(B) ;STORE NEW TP - HRRI D,1(C) ;MAKE A TB - HRLI D,2 ;WITH A TIME - MOVEM D,TBINIT+1(B) - MOVEM D,TBSTO+1(B) ;SAVE ALSO FOR SIMULATED START - MOVE C,(AB) ;STORE ARG - MOVEM C,RESFUN(B) ;INTO PV - MOVE C,1(AB) - MOVEM C,RESFUN+1(B) - MOVEI 0,RUNABL - MOVEM 0,PSTAT+1(B) - JRST FINIS - -REPEAT 0,[ -MFUNCTION RETPROC,SUBR -; WHO KNOWS WHAT THIS SHOULD REALLY DO -;PROBABLY, JUST AN EXIT -;FOR NOW, PRINT OUT AN ERROR MESSAGE - PUSH TP,$TATOM - PUSH TP,EQUOTE ATTEMPT-TO-RETURN-OUT-OF-PROCESS - JRST CALER1 - - - - - - - -MFUNCTION RESUME,FSUBR -;RESUME IS CALLED WITH TWO ARGS -;THE FIRST IS A PROCESS FORM OF THE PROCESS TO BE RESUMED -;THE SECOND IS A FUNCTION TO BE CALLED WHEN THIS PROCESS -; (THE PARENT) IS ITSELF RESUMED -;IF THE FUNCTION IS NOT GIVEN SOME STANDARD FUNCTION IS -;PLUGGED IN -; -; NOTE - TYPE AND NUMBER OF ARGS CHECKS MUST BE ADDED TO BOTH RESUME AND CREATE - - ENTRY 1 - HRRZ C,@1(AB) ;GET CDR ADDRESS - JUMPE C,NOFUN ;IF NO SECOND ARG, SUPPLY STANDARD - HLLZ A,(C) ;GET CDR TYPE - CAME A,$TATOM ;ATOMIC? - JRST RES2 ;NO, MUST EVAL TO GET FUNCTION - MOVE B,1(C) ;YES - PUSHJ P,IGVAL ;TRY TO GET GLOBAL VALUE - CAMN A,$TUNBOUND ;GLOBALLY UNBOUND? - JRST LFUN ;YES, TRY FOR LOCAL VALUE -RES1: MOVEM A,RESFUN(PVP) ;STORE IN THIS PROCESS - MOVEM B,RESFUN+1(PVP) - - HRRZ C,1(AB) ;GET CAR ADDRESS - PUSH TP,(C) ;PUSH PROCESS FORM - PUSH TP,1(C) - JSP E,CHKARG ;CHECK FOR DEFERED TYPE - ;INSERT CHECKS FOR PROCESS FORM - MCALL 1,EVAL ;EVAL PROCESS FORM WHICH WILL SWITCH - ; PROCESSES - JRST FINIS - -RES2: PUSH TP,(C) ;PUSH FUNCTION ARG - PUSH TP,1(C) - JSP E,CHKARG ;CHECK FOR DEFERED - MCALL 1,EVAL ;EVAL TO GET FUNCTION - JRST RES1 - -LFUN: HRRZ C,1(AB) ;GET CDR ADDRESS - PUSH TP,(C) - PUSH TP,1(C) - MCALL 1,VALUE ;GET LOCAL VALUE OF ATOM FOR FUNCTION - JRST RES1 - -NOFUN: MOVSI A,TUNBOUND ;MAKE RESUME FUNCTION UNBOUND - JRST RES1 -] - -; PROCHK - SETUP LAST RESUMER SLOT - -PROCHK: CAME B,MAINPR ; MAIN PROCESS? - MOVEM PVP,LSTRES+1(B) - POPJ P, - -; THIS FUNCTION RESUMES A PROCESS, CALLED WITH ONE OR TWO ARGS -; THE FIRST IS A VALUE TO RETURN TO THE OTHER PROCESS OR PASS TO ITS -; RESFUN -; THE SECOND IS THE PROCESS TO RESUME (IF NOT SUPPLIED, USE THE LSTRES) - - -MFUNCTION RESUME,SUBR - - ENTRY - JUMPGE AB,TFA - CAMGE AB,[-4,,0] - JRST TMA - CAMGE AB,[-2,,0] - JRST CHPROC ; VALIDITY CHECK ON PROC - SKIPN B,LSTRES+1(PVP) ; ANY RESUMERS? - JRST NORES ; NO, COMPLAIN -GOTPRO: MOVE C,AB - CAMN B,PVP ; DO THEY DIFFER? - JRST RETARG - MOVE A,PSTAT+1(B) ; CHECK STATE - CAIE A,RUNABL ; MUST BE RUNABL - CAIN A,RESMBL ; OR RESUMABLE - JRST RESUM1 -NOTRES: -NOTRUN: PUSH TP,$TATOM - PUSH TP,EQUOTE PROCESS-NOT-RUNABLE-OR-RESUMABLE - JRST CALER1 - -RESUM1: PUSHJ P,PROCHK ; FIX LISTS UP - MOVEI A,RESMBL ; GET NEW STATE - MOVE D,B ; FOR SWAP -STRTN: JSP C,SWAP ; SWAP THEM - MOVEM A,PSTAT+1(E) ; CLOBBER OTHER STATE - MOVE A,PSTAT+1(PVP) ; DECIDE HOW TO PROCEED - MOVEI 0,RUNING - MOVEM 0,PSTAT+1(PVP) ; NEW STATE - MOVE C,ABSTO+1(E) ; OLD ARGS - CAIE A,RESMBL - JRST DORUN ; THEY DO RUN RUN, THEY DO RUN RUN -RETARG: MOVE A,(C) - MOVE B,1(C) ; RETURN - JRST FINIS - -DORUN: PUSH TP,RESFUN(PVP) - PUSH TP,RESFUN+1(PVP) - PUSH TP,(C) - PUSH TP,1(C) - MCALL 2,APPLY - PUSH TP,A ; CALL SUICIDE WITH THESE ARGS - PUSH TP,B - MCALL 1,SUICID ; IF IT RETURNS, KILL IT - JRST FINIS - -CHPROC: GETYP A,2(AB) - CAIE A,TPVP - JRST WTYP2 - MOVE B,3(AB) - JRST GOTPRO - -NORES: PUSH TP,$TATOM - PUSH TP,EQUOTE NO-PROCESS-TO-RESUME - JRST CALER1 - -; FUNCTION TO CAUSE PROCESSES TO SELF DESTRUCT - -MFUNCTION SUICIDE,SUBR - - ENTRY - - JUMPGE AB,TFA - HLRE A,AB - ASH A,-1 ; DIV BY 2 - AOJE A,NOPROC ; NO PROCESS GIVEN - AOJL A,TMA - GETYP A,2(AB) ; MAKE SURE OF PROCESS - CAIE A,TPVP - JRST WTYP2 - MOVE C,3(AB) - JRST SUIC2 - -NOPROC: SKIPN C,LSTRES+1(PVP) ; MAKE SURE OF EDLIST - MOVE C,MAINPR ; IF NOT DEFAULT TO MAIN -SUIC2: CAMN C,PVP ; DONT SUICIDE TO SELF - JRST SUSELF - MOVE B,PSTAT+1(C) - CAIE B,RUNABL - CAIN B,RESMBL - JRST .+2 - JRST NOTRUN - MOVE B,C - PUSHJ P,PROCHK - MOVE D,B ; RESTORE NEWPROCESS - MOVEI A,DEAD - JRST STRTN - -SUSELF: PUSH TP,$TATOM - PUSH TP,EQUOTE ATTEMPT-TO-SUICIDE-TO-SELF - JRST CALER1 - - -MFUNCTION RESER,SUBR,RESUMER - - ENTRY - MOVE B,PVP - JUMPGE AB,GTLAST - CAMGE AB,[-2,,0] - JRST TMA - - GETYP A,(AB) ; CHECK FOR PROCESS - CAIE A,TPVP - JRST WTYP1 - MOVE B,1(AB) ; GET PROCESS -GTLAST: MOVSI A,TFALSE ; ASSUME NONE - SKIPN B,LSTRES+1(B) ; GET IT IF IT EXISTS - JRST FINIS - MOVSI A,TPVP ; GET TYPE - JRST FINIS - -; FUNCTION TO PUT AN EVAL CALL ON ANOTHER PROCESSES STACK - -MFUNCTION BREAKSEQ,SUBR,BREAK-SEQ - - ENTRY 2 - - GETYP A,2(AB) ; 2D ARG MUST BE PROCESS - CAIE A,TPVP - JRST WTYP2 - - MOVE B,3(AB) ; GET PROCESS - CAMN B,PVP ; SKIP IF NOT ME - JRST BREAKM - MOVE A,PSTAT+1(B) ; CHECK STATE - CAIE A,RESMBL ; BEST BE RESUMEABLE - JRST NOTRUN - MOVE C,TBSTO+1(B) ; GET SAVE ACS TO BUILD UP A DUMMY FRAME - MOVE D,TPSTO+1(B) ; STACK POINTER - MOVE E,SPSTO+1(B) ; FIX UP OLD FRAME - MOVEM E,SPSAV(C) - MOVEI E,CALLEV ; FUNNY PC - MOVEM E,PCSAV(C) - MOVE E,PSTO+1(B) ; SET UP P,PP AND TP SAVES - MOVEM E,PSAV(C) - PUSH D,[0] ; ALLOCATES SOME SLOTS - PUSH D,[0] - PUSH D,(AB) ; NOW THAT WHIC IS TO BE EVALLED - PUSH D,1(AB) - MOVEM D,TPSAV(C) - HRRI E,-1(D) ; BUILD UP ARG POINTER - HRLI E,-2 - PUSH D,[TENTRY,,BREAKE] - PUSH D,C ; OLD TB - PUSH D,E ; NEW ARG POINTER -REPEAT 4,PUSH D,[0] ; OTHER SLOTS - MOVEM D,TPSTO+1(B) - MOVEI C,(D) ; BUILD NEW AB - AOBJN C,.+1 - MOVEM C,TBSTO+1(B) ; STORE IT - MOVE A,2(AB) ; RETURN PROCESS - MOVE B,3(AB) - JRST FINIS - -MQUOTE BREAKER - -BREAKE: -CALLEV: MOVEM A,-3(TP) ; HERE TO EVAL THE GOODIE (SAVE REAL RESULT) - MOVEM B,-2(TP) - MCALL 1,EVAL - POP TP,B - POP TP,A - JRST FINIS - -BREAKM: PUSH TP,$TATOM - PUSH TP,EQUOTE ATTEMPT-TO-BREAK-OWN-SEQUENCE - JRST CALER1 - -; FUNCTION TOP PUT PROCESS IN 1 STEP MODE - -MFUNCTION 1STEP,SUBR - PUSHJ P,1PROC - MOVEM PVP,1STEPR+1(B) ; CLOBBER TARGET PROCESS - JRST FINIS - -; FUNCTION TO UNDO ABOVE - -MFUNCTION %%FREE,SUBR,FREE-RUN - PUSHJ P,1PROC - CAME PVP,1STEPR+1(B) - JRST FNDBND - SETZM 1STEPR+1(B) - JRST FINIS - -FNDBND: SKIPE 1STEPR+1(B) ; DOES IT HAVE ANY 1STEPPER? - JRST NOTMIN ; YES, COMPLAIN - MOVE D,B ; COPY PROCESS - ADD D,[1STEPR,,1STEPR] ; POINTER FOR SEARCH - HRRZ C,SPSTO+1(B) ; GET THIS BINDING STACK - -FNDLP: GETYP 0,(C) ; IS THIS A TBVL? - CAIN 0,TBVL - CAME D,1(C) ; SKIP IF THIS IS SAVED 1STEP SLOT - JRST FNDNXT - SKIPN 3(C) ; IS IT SAVING A REAL 1STEPPER? - JRST FNDNXT - CAME PVP,3(C) ; IS IT ME? - JRST NOTMIN - SETZM 3(C) ; CLEAR OUT SAVED 1STEPPER - JRST FINIS -FNDNXT: HRRZ C,(C) ; NEXT BINDING - JUMPN C,FNDLP - -NOTMIN: MOVE C,$TCHSTR - MOVE D,CHQUOTE NOT-YOUR-1STEPEE - PUSHJ P,INCONS - MOVSI A,TFALSE - JRST FINIS - -1PROC: ENTRY 1 - GETYP A,(AB) - CAIE A,TPVP - JRST WTYP1 - MOVE B,1(AB) - MOVE A,(AB) - POPJ P, - -; FUNCTION TO RETRUN THE MAIN PROCESS - -MFUNCTION MAIN%%,SUBR,MAIN - ENTRY 0 - - MOVE B,MAINPR -MAIN1: MOVSI A,TPVP - JRST FINIS - -; FUNCTION TO RETURN THE CURRENT PROCESS - -MFUNCTION ME,SUBR - ENTRY 0 - - MOVE B,PVP - JRST MAIN1 - -; FUNCTION TO RETURN THE STATE OF A PROCESS - -MFUNCTION STATE,SUBR - ENTRY 1 - GETYP A,(AB) - CAIE A,TPVP - JRST WTYP1 - MOVE A,1(AB) ; GET PROCESS - MOVE A,PSTAT+1(A) - MOVE B,@STATES(A) ; GET STATE - MOVSI A,TATOM - JRST FINIS - -STATES: - IRP A,,[ILLEGAL,RUNABLE,RESUMABLE,RUNNING,DEAD,BLOCKED] - MQUOTE A - TERMIN - - - -END - -TITLE DECLARATION PROCESSOR - -RELOCA - -.INSRT MUDDLE > - -.GLOBAL STBL,TYPFND,TYPSGR,CHKDCL,TESTR,VALG,INCR1,TYPG,ISTRUC,TMATCH,SAT -.GLOBAL TYPMIS,CHKAB,CHKARG,IGDECL,LOCQQ,APLQ,CALER,IEQUAL,IIGLOC,IGLOC -.GLOBAL CHLOCI,INCONS,SPCCHK,WTYP1 - -; Subr to allow user to access the DECL checking code - -MFUNCTION CHECKD,SUBR,[DECL?] - - ENTRY 2 - - MOVE C,(AB) - MOVE D,1(AB) - MOVE A,2(AB) - MOVE B,3(AB) - PUSHJ P,TMATCX ; CHECK THEM - JRST IFALS - -RETT: MOVSI A,TATOM - MOVE B,MQUOTE T - JRST FINIS - -RETF: -IFALS: MOVEI B,0 - MOVSI A,TFALSE - JRST FINIS - -; Subr to turn DECL checking on and off. - -MFUNCTION %DECL,SUBR,[DECL-CHECK] - - ENTRY 1 - - GETYP 0,(AB) - SETZM IGDECL - CAIN 0,TFALSE - SETOM IGDECL - MOVE A,(AB) - MOVE B,1(AB) - JRST FINIS - -; Change special unspecial normal mode - -MFUNCTION SPECM%,SUBR,[SPECIAL-MODE] - - ENTRY - - CAMGE AB,[-3,,] - JRST TMA - MOVE C,SPCCHK ; GET CURRENT - JUMPGE AB,MODER ; RET CURRENT - GETYP 0,(AB) ; CHECK IT IS ATOM - CAIE 0,TATOM - JRST WTYP1 - MOVE 0,1(AB) - MOVEI A,1 - CAMN 0,MQUOTE UNSPECIAL - MOVSI A,(SETZ) - CAMN 0,MQUOTE SPECIAL - MOVEI A,0 - JUMPG A,WTYP1 - HLLM A,SPCCHK - -MODER: MOVSI A,TATOM - MOVE B,MQUOTE SPECIAL - SKIPGE C - MOVE B,MQUOTE UNSPECIAL - JRST FINIS - -; Function to turn special checking on and of - -MFUNCTION SPECC%,SUBR,[SPECIAL-CHECK] - - ENTRY - CAMGE AB,[-3,,] - JRST TMA - - MOVE C,SPCCHK - JUMPGE AB,SCHEK1 - - MOVEI A,0 - GETYP 0,(AB) - CAIE 0,TFALSE - MOVEI A,1 - HRRM A,SPCCHK - -SCHEK1: TRNN C,1 - JRST IFALS - JRST RETT - -; Finction to set decls for GLOBAL values. - -MFUNCTION GDECL,FSUBR - - ENTRY 1 - - GETYP 0,(AB) - CAIE 0,TLIST - JRST WTYP1 - - PUSH TP,$TLIST - PUSH TP,1(AB) - PUSH TP,$TLIST - PUSH TP,[0] - PUSH TP,$TLIST - PUSH TP,[0] - -GDECL1: INTGO - SKIPN C,1(TB) - JRST RETT - HRRZ D,(C) ; MAKE SURE PAIRS - JUMPE D,GDECLL ; LOSER, GO AWAY - GETYP 0,(C) - CAIE 0,TLIST - JRST GDECLL - HRRZ 0,(D) - MOVEM 0,1(TB) ; READY FOR NEXT CALL - MOVE C,1(C) ; SAVE ATOM LIST - MOVEM C,5(TB) - MOVEM D,3(TB) - -GDECL2: INTGO - SKIPN C,5(TB) - JRST GDECL1 ; OUT OF ATOMS - GETYP 0,(C) ; IS THIS AN ATOM - CAIE 0,TATOM - JRST GDECLL ; NO, LOSE - MOVE B,1(C) - HRRZ C,(C) - MOVEM C,5(TB) - PUSHJ P,IIGLOC ; GET ITS VAL (OR MAKE ONE) - GETYP 0,(B) ; UNBOUND? - CAIE 0,TUNBOU - JRST CHKCUR ; CHECK CURRENT VALUE - MOVE C,3(TB) ; GET DECL - HRRM C,-2(B) - JRST GDECL2 - -CHKCUR: HRRZ D,3(TB) - GETYP A,(D) - MOVSI A,(A) - MOVE E,B - MOVE B,1(D) - MOVE C,(E) - MOVE D,1(E) - PUSH TP,$TVEC - PUSH TP,E - JSP E,CHKAB - PUSHJ P,TMATCH - JRST TYPMI3 - MOVE E,(TP) - SUB TP,[2,,2] - MOVE D,3(TB) - HRRM D,-2(E) - JRST GDECL2 - -TYPMI3: MOVE E,(TP) ; POINT BACK TO SLOT - MOVE A,-1(E) ; ATOM TO A - MOVE B,1(E) - MOVE D,(E) ; GET OLD VALUE - MOVE C,3(TB) - JRST TYPMIS ; GO COMPLAIN - -GDECLL: PUSH TP,$TATOM - PUSH TP,EQUOTE BAD-ARGUMENT-LIST - JRST CALER1 - -MFUNCTION UNMANIFEST,SUBR - - ENTRY - - PUSH P,[HLLZS -2(B)] - JRST MANLP - -MFUNCTION MANIFEST,SUBR - - ENTRY - - PUSH P,[HLLOS -2(B)] -MANLP: JUMPGE AB,RETT - GETYP 0,(AB) - CAIE 0,TATOM - JRST WTYP - MOVE B,1(AB) - PUSHJ P,IIGLOC - XCT (P) - ADD AB,[2,,2] - JRST MANLP - -MFUNCTION MANIFQ,SUBR,[MANIFEST?] - - ENTRY 1 - - GETYP 0,(AB) - CAIE 0,TATOM - JRST WTYP1 - - MOVE B,1(AB) - PUSHJ P,IGLOC ; GET POINTER IF ANY - GETYP 0,A - CAIN 0,TUNBOU - JRST RETF - HRRZ 0,-2(B) - CAIE 0,-1 - JRST RETF - JRST RETT - -MFUNCTION GETDECL,SUBR,[GET-DECL] - - ENTRY 1 - - PUSHJ P,GTLOC - JRST GTLOCA - - HRRZ C,-2(B) ; GET GLOBAL DECL -GETD1: JUMPE C,RETF - CAIN C,-1 - JRST RETMAN - GETYP A,(C) - MOVSI A,(A) - MOVE B,1(C) - JSP E,CHKAB - JRST FINIS - -RETMAN: MOVSI A,TATOM - MOVE B,MQUOTE MANIFEST - JRST FINIS - -GTLOCA: HLRZ C,2(B) ; LOCAL DECL - JRST GETD1 - -MFUNCTION PUTDECL,SUBR,[PUT-DECL] - - ENTRY 2 - - PUSHJ P,GTLOC - SKIPA E,[HRLM B,2(C)] - MOVE E,[HRRM B,-2(C)] - PUSH P,E - GETYP 0,(B) ; ANY VALUE - CAIN 0,TUNBOU - JRST PUTD1 - MOVE C,(B) ; GET CURRENT VALUE - MOVE D,1(B) - MOVE A,2(AB) - MOVE B,3(AB) - PUSHJ P,TMATCH - JRST TYPMI4 -PUTD1: MOVE C,2(AB) ; GET DECL BACK - MOVE D,3(AB) - PUSHJ P,INCONS ; CONS IT UP - MOVE C,1(AB) ; LOCATIVE BACK - XCT (P) ; CLOBBER - MOVE A,(AB) - MOVE B,1(AB) - JRST FINIS - -TYPMI4: MOVE E,1(AB) ; GET LOCATIVE - MOVE A,-1(E) ; NOW ATOM - MOVEI C,2(AB) ; POINT TO DECL - MOVE D,(E) ; AND CURRENT VAL - MOVE B,1(E) - JRST TYPMIS - -GTLOC: GETYP 0,(AB) - CAIE 0,TLOCD - JRST WTYP1 - MOVEI B,(AB) - PUSHJ P,CHLOCI - HRRZ 0,(AB) ; LOCAL OR GLOBAL - SKIPN 0 - AOS (P) - MOVE B,1(AB) ; RETURN LOCATIVE IN B - POPJ P, - -; Interface between EVAL and declaration processor. -; E points into stack at a binding and C points to decl list. - -CHKDCL: SKIPE IGDECL ; IGNORING DECLS? - POPJ P, ; YUP, JUST LEAVE - - PUSH TP,$TTP ; SAVE BINDING - PUSH TP,E - MOVE A,-4(E) ; GET ATOM - MOVSI 0,TLIST ; SETUP FOR INTERRUPTABLE - MOVEM 0,CSTO(PVP) - MOVEM 0,BSTO(PVP) - MOVSI 0,TATOM - MOVEM 0,ASTO(PVP) - SETZB B,0 ; CLOBBER FOR INTGO - -DCL2: INTGO - HRRZ D,(C) ; MAKE SURE EVEN ELEMENTS - JUMPE D,BADCL - GETYP B,(C) ; MUST BE LIST OF ATOMS - CAIE B,TLIST - JRST BADCL - MOVE B,1(C) ; GET LIST - -DCL1: INTGO - CAMN A,1(B) ; SKIP IF NOT WINNER - JRST DCLQ ; MAY BE WINNER -DCL3: HRRZ B,(B) ; CDR ON - JUMPN B,DCL1 ; JUMP IF MORE - - HRRZ C,(D) ; CDR MAIN LIST - JUMPN C,DCL2 ; AND JUMP IF WINNING - - PUSHJ P,E.GET ; GET BINDING BACK - SUB TP,[2,,2] ; POP OF JUNK - POPJ P, - -DCLQ: GETYP C,(B) ; CHECK ATOMIC - CAIE C,TATOM - JRST BADCL ; LOSER - PUSHJ P,E.GET ; GOT IT - PUSH TP,$TLIST ; SAVE PATTERN - PUSH TP,D - MOVE B,1(D) ; GET PATTERN - HLLZ A,(D) - MOVE C,-3(E) ; PROPOSED VALUE - MOVE D,-2(E) - PUSHJ P,TMATCH ; MATCH TYPE - JRST TYPMI1 ; LOSER -DCLQ1: MOVE E,-2(TP) - MOVE C,-5(E) ; CHECK FOR SPEC CHANGE - SKIPE 0 ; MAKE SURE NON ZERO IS -1 - MOVNI 0,1 - SKIPL SPCCHK ; SKIP IF NORMAL UNSPECIAL - SETCM 0 ; COMPLEMENT - ANDI 0,1 ; ONE BIT - CAMN C,[TATOM,,-1] - JRST .+3 - CAME C,[TATOM,,-2] - JRST .+3 - ANDCMI C,1 - IOR C,0 ; MUNG BIT - MOVEM C,-5(E) - HRRZ C,(TP) - SUB TP,[4,,4] - MOVEM C,(E) ; STORE DECLS - MOVSI C,TLIST - MOVEM C,-1(E) - POPJ P, - -TYPMI1: MOVE E,-2(TP) - GETYP C,-3(E) - CAIN C,TUNBOU - JRST DCLQ1 - MOVE E,-2(TP) ; GET POINTER TO BIND - MOVE D,-3(E) ; GET VAL - MOVE B,-2(E) - HRRZ C,(TP) ; DCL LIST - MOVE A,-4(E) ; GET ATOM - SUB TP,[4,,4] -TYPMIS: PUSH TP,$TATOM - PUSH TP,EQUOTE TYPE-MISMATCH - PUSH TP,$TATOM - PUSH TP,A - PUSH TP,(C) - HLLZS (TP) - PUSH TP,1(C) - JSP E,CHKARG ; HACK DEFER - PUSH TP,D - PUSH TP,B - MOVEI A,4 ; 3 ERROR ARGS - JRST CALER - -BADCL: PUSHJ P,E.GET - PUSH TP,$TATOM - PUSH TP,EQUOTE BAD-DECLARATION-LIST - JRST CALER1 - -; ROUTINE TO RESSET INT STUFF - -E.GET: MOVE E,(TP) - SETZM ASTO(PVP) - SETZM BSTO(PVP) - SETZM CSTO(PVP) - POPJ P, - -; Declarations processor for MUDDLE type declarations. -; Receives a pattern in a and B and an object in C and D. -; It skip returns if the object fits otherwise it doesn't. -; Declaration syntax errors are caught and sent to ERROR. - -TMATCH: MOVEI 0,1 ; RET SPECIAL INDICATOR - SKIPE IGDECL ; IGNORING DECLS? - JRST CPOPJ1 ; YUP, ACT LIKE THEY WON - -TMATCX: GETYP 0,A ; GET PATTERNS TYPE - CAIN 0,TFORM ; MUST BE FORM OR ATOM - JRST TMAT1 - CAIE 0,TATOM - JRST TERR1 ; WRONG TYPE FOR A DCL - -; SIMPLE TYPE MATCHER - -TYPMAT: GETYP E,C ; OBJECTS TYPE TO E - PUSH P,E ; SAVE IT - PUSHJ P,TYPFND ; CONVERT TYPE NAME TO CODE - JRST SPECS ; NOT A TYPE NAME, TRY SPECIALS - POP P,E ; RESTORE TYPE OF OBJECT - MOVEI 0,0 ; SPECIAL INDICATOR - CAIN E,(D) ; SKIP IF LOSERS -CPOPJ1: AOS (P) ; GOOD RETURN -CPOPJ: POPJ P, - -SPECS: POP P,A ; RESTORE OBJECTS TYPE - CAMN B,MQUOTE ANY - JRST CPOPJ1 ; RETURN IMMEDIATELY IF ANYTHING WINS - CAMN B,MQUOTE STRUCTURED - JRST ISTRUC ; LET ISTRUC DO THE WORK - CAMN B,MQUOTE APPLICABLE - JRST APLQ - CAME B,MQUOTE LOCATIVE - JRST TERR2 - JRST LOCQQ - -; ARRIVE HERE FOR A FORM IN THE DCLS - -TMAT1: JUMPE B,TERR3 ; EMPTY FORM LOSES - HRRZ E,(B) ; CDR IT - JUMPE E,TMAT3 ; CANT BE SPECIAL/UNSPECIAL, LEAVE - PUSHJ P,0ATGET ; GET POSSIBLE ATOM IN 0 - JRST TEXP1 ; NOT ATOM - CAME 0,MQUOTE SPECIAL - CAMN 0,MQUOTE UNSPECIAL - JRST TMAT2 ; IGNORE SPECIAL/UNSPECIAL -TMAT3: PUSHJ P,TEXP1 - JRST .+2 - AOS (P) - MOVEI 0,0 ; RET UNSPECIAL INDICATION - POPJ P, - -TEXP1: JUMPE B,TERR3 ; EMPTY FORM - GETYP 0,A ; CHECK CURRENT TYPE - CAIN 0,TATOM ; IF ATOM, - JRST TYPMA1 ; SIMPLE MATCH - CAIE 0,TFORM - JRST TERR4 - GETYP 0,(B) ; WHAT IS FIRST ELEMEMT - CAIE 0,TFORM ; FORM=> <....> OR <....> - JRST 0,TEXP12 - PUSH TP,$TLIST ; SAVE LIST - PUSH TP,B - MOVE B,1(B) ; GET FORM - PUSH TP,C - PUSH TP,D - PUSHJ P,ACTRT1 - TDZA 0,0 ; REMEMBER LACK OF SKIP - MOVEI 0,1 - POP TP,D - POP TP,C - MOVE B,(TP) ; GET BACK SAVED LIST - SUB TP,[2,,2] - JUMPE 0,CPOPJ ; LOSERS EXIT IMMEDIATELY - HRRZ B,(B) ; OTHERWISE REST THE LIST AND FALL INTO ELETYPE - -; CHECKS TYPES OF ELEMENTS OF STRUCTURES - -ELETYP: JUMPE B,CPOPJ1 ; EMPTY=> WON - PUSH TP,$TLIST ; SAVE DCL LIST - PUSH TP,B - MOVE A,C ; GET OBJ IN A AND B - MOVE B,D - PUSHJ P,TYPSGR ; GET REST/NTH CODE - JRST ELETYL ; LOSER - PUSH TP,DSTO(PVP) - PUSH TP,D - PUSH P,C ; SAVE CODE - PUSH TP,[0] ; AND SLOTS - PUSH TP,[0] - -; MAIN ELEMENT SCANNING LOOP - -ELETY1: XCT TESTR(C) ; SKIP IF OBJ NOT EMPTY - JRST ELETY2 ; CHEK EMPTY WINNER - XCT TYPG(C) ; GET ELEMENT - XCT VALG(C) - JSP E,CHKAB ; CHECK OUT DEFER - MOVEM A,-1(TP) ; AND SAVE IT - MOVEM B,(TP) - MOVE C,A - MOVE D,B ; FOR OTHER MATCHERS - MOVE B,-4(TP) ; GET PATTERN - MOVE A,(B) - GETYP 0,(B) ; GET TYPE OF <1 pattern> - MOVE B,1(B) ; GET ATOM OR WHATEVER - CAIE 0,TATOM ; ATOM ... SIMPLE TYPE - JRST ELETY3 - PUSHJ P,TYPMAT ; DO SIMPLE TYPE MATCH - JRST ELETY4 ; LOSER - -; HERE TO REST EVERYTHING AND GO ON BACK - -ELETY6: MOVE D,-2(TP) ; GET OBJ POINTER - MOVE C,(P) ; GET INCREMENT CODE - XCT INCR1(C) - MOVEM D,-2(TP) ; SAVED INCREMENTED GOODIR - MOVE 0,DSTO(PVP) - MOVEM 0,-3(TP) - -ELETY9: HRRZ B,@-4(TP) ; CDR IT - MOVEM B,-4(TP) - JUMPN B,ELETY1 - -; HERE IF PATTERN EMPTY - -ELETY8: AOS -1(P) ; SKIP RETURN -ELETY4: SETZM DSTO(PVP) - SUB P,[1,,1] - SUB TP,[6,,6] - POPJ P, - -ELETYL: SUB TP,[2,,2] - POPJ P, - -; HERE TO HANDLE EMPTY OBJECT - -ELETY2: MOVE B,-4(TP) ; GET PATTERN - GETYP 0,(B) ; CHECK FOR [REST ...] - SETZM DSTO(PVP) - CAIE 0,TVEC - JRST ELETY4 ; LOSER - HLRZ 0,1(B) ; SIZE OF IT - CAILE 0,-4 ; MUST BE 2 - JRST ELETY4 - MOVE B,1(B) ; GET IT - PUSHJ P,0ATGET ; LOOK FOR REST - JRST ELETY4 - CAMN 0,MQUOTE REST - JRST ELETY8 ; WINNER!!!! - JRST ELETY4 ; LOSER - -; HERE TO CHECK OUT A FORM ELEMNT - -ELETY3: CAIE 0,TFORM - JRST ELETY7 - SETZM DSTO(PVP) - PUSHJ P,TEXP1 ; AND ANALYSE IT - JRST ELETY4 ; LOSER - MOVE 0,-3(TP) ; RESET DSTO - MOVEM 0,DSTO(PVP) - JRST ELETY6 ; WINNER - -; CHECK FOR VECTOR IN PATTERN - -ELETY7: CAIE 0,TVEC ; SKIP IF WINNER - JRST TERR12 ; YET ANOTHER ERROR - HLRE C,B ; CHECK LEENGTH - CAMLE C,[-4] ; MUST BE 2 LONG - JRST TERR13 - PUSHJ P,0ATGET ; 1ST ELEMENT ATOM? - JRST ELET71 ; COULD BE FORM - CAME 0,MQUOTE REST - JRST TERR14 - MOVNI 0,1 ; FLAG USED IN RESTIT - PUSHJ P,RESTIT ; CHECK REST OF STRUCTUR - JRST ELETY4 - JRST ELETY8 ; WIN AND DONE - -; CHECK FOR [fix .... ] - -ELET71: CAIE 0,TFIX - JRST TERR15 - MOVNS C - ASH C,-1 - MOVE 0,1(B) ; GET NUMBER - IMULI 0,-1(C) ; COUNT MORE - PUSHJ P,RESTIT ; AND CHECK FIX NUM OF ELEMENTS - JRST ELETY4 - MOVE D,-2(TP) ; GET OBJECT BACK - MOVE 0,-3(TP) ; RESET DSTO - MOVEM 0,DSTO(PVP) - MOVE C,(P) ; RESTORE CODE FOR RESTING ETC. - JRST ELETY9 - - -; HERE TO DO A TASTEFUL TYPMAT - -TYPMA1: PUSH TP,C - PUSH TP,D - PUSHJ P,TYPMAT - TDZA 0,0 ; REMEMBER LOSSAGE - MOVEI 0,1 ; OR WINNAGE - POP TP,D - POP TP,C ; RESTORE OBJECT - JUMPN 0,CPOPJ1 ; SKIPPED BEFORE, SKIP AGAIN - POPJ P, - -; HERE TO SKIP SPECIAL/UNSPECIAL - -TMAT2: CAME 0,MQUOTE SPECIAL - TDZA 0,0 - MOVEI 0,1 - PUSH P,0 ; SAVE INDICATOR - GETYP A,(E) ; TYPE OF NEW PAT - MOVE B,1(E) ; VALUE - MOVSI A,(A) - PUSHJ P,TEXP1 - JRST .+2 - AOS -1(P) - POP P,0 - POPJ P, - -; LOOK FOR SIMPLE TYPE - CAIN 0,TFORM ; FORM--> HAIRY PATTERN - MOVEI E,TEXP1 - PUSHJ P,(E) ; DO IT - JRST RESTI5 - JRST RESTI4 - -RESTI2: SKIPGE (P) ; SKIP IF WON - AOS -2(P) ; COUNTERACT CPOPJ1 - JRST RESTI5 - -RESTI3: TEXP1 - TYPMAT - -; HERE TO MATHC A QUOTED OBJ -; B/ FORM QUOTE... C,D/ OBJECT TO MATCH AGAINST - -MQUOT: HRRZ B,(B) ; LOOK AT NEXT - JUMPE B,TERR7 - GETYP A,(B) ; GET TYPE - MOVSI A,(A) - MOVE B,1(B) ; AND VALUE - JSP E,CHKAB ; HACK DEFER - PUSH TP,A - PUSH TP,B - PUSH TP,C - PUSH TP,D - MOVEI D,-3(TP) - MOVEI C,-1(TP) - PUSHJ P,IEQUAL - TDZA 0,0 - MOVEI 0,1 - JRST POPPIT - - -; GET ATOM IN AC 0 - -0ATGET: GETYP 0,(B) - CAIE 0,TATOM ; SKIP IF ATOM - POPJ P, - MOVE 0,1(B) ; GET ATOM - JRST CPOPJ1 - -TERR9: MOVS A,0 ; TYPE TO A -TERR4: -TERR5: -TERR15: -TERR1: MOVE E,EQUOTE DECL-ELEMENT-NOT-FORM-OR-ATOM - JRST TERRD - -TERR2: MOVSI A,TATOM - MOVE E,EQUOTE ATOM-NOT-TYPE-NAME-OR-SPECIAL-SYMBOL - JRST TERRD -TERR6: -TERR3: MOVE E,EQUOTE EMPTY-FORM-IN-DECL - JRST TERRD -TERR7: MOVE E,EQUOTE EMPTY-OR/PRIMTYPE-FORM - JRST TERRD - -TERR8: MOVS A,0 ; TYPE TO A - MOVE E,EQUOTE NON-TYPE-FOR-PRIMTYPE-ARG - JRST TERRD -TERR12: MOVE E,EQUOTE ELEMENT-TYPE-NOT-ATOM-FORM-OR-VECTOR - JRST TERRD -TERR13: MOVE E,EQUOTE VECTOR-LESS-THAN-2-ELEMENTS - JRST TERRD -TERR14: MOVE E,EQUOTE FIRST-VECTOR-ELEMENT-NOT-REST-OR-A-FIX - -TERRD: PUSH TP,$TATOM - PUSH TP,EQUOTE BAD-TYPE-SPECIFICATION - PUSH TP,$TATOM - PUSH TP,E - PUSH TP,A - PUSH TP,B - MOVEI A,3 - JRST CALER - -IMPURE - -IGDECL: 0 - -PURE - -END - TITLE EVAL -- MUDDLE EVALUATOR - -RELOCATABLE - -; GERALD JAY SUSSMAN, 1971. REWRITTEN MANY TIMES SINCE C. REEVE (1972--1974) - - -.GLOBAL BINDID,LPROG,GLOBSP,GLOBASE,SPBASE,TPBASE,PTIME,SWAP,CHFRAM -.GLOBAL IGVAL,CHKARG,NXTDCL,TPOVFL,CHFRM,PROCHK,CHFSWP,VECBOT,TYPSGR -.GLOBAL ILVAL,ER1ARG,SPECBIND,MAKACT,SPECSTORE,MAKTUP,TPALOC,IBIND,SSPECS -.GLOBAL IDVAL,EVECTO,EUVECT,CHARGS,BCKTRK,CELL,ILOC,IGLOC,CHKDCL,SSPEC1 -.GLOBAL PDLBUF,MESS,FACTI,CHKARG,MAKENV,PSTAT,BNDV,UNBOU,UNAS,IGDECL -.GLOBAL 1STEPR,SEGMNT,SEGLST,NAPT,EVTYPE,EVATYP,APTYPE,APLTYP,APLQ,IDVAL1 -.GLOBAL TESTR,VALG,TYPG,INCR1,TMATCH,TYPMIS,SAT,MAKACT,NTPALO,SPECBND -.GLOBAL TPGROW,CHKAB,TYPSEG,NXTLM,MONCH0,CHFINI,RMONC0,IMPURIFY,ICONS,INCONS -.GLOBAL CILVAL,CISET,CIGVAL,CSETG,MAPPLY,CLLOC,CGLOC,CASSQ,CGASSQ,CBOUND -.GLOBAL IIGLOC,CHUNW,IUNWIN,UNWIN2,SPCCHK,CURFCN,TMPLNT,TD.LNT,TBINIT -.GLOBAL SPECBE -.GLOBAL AGC,GVLINC,LVLINC,CGBOUN,IEVECT,MAKTU2 - -.INSRT MUDDLE > - -MONITOR - - -; ENTRY TO EXPAND A MACRO - -MFUNCTION EXPAND,SUBR - - ENTRY 1 - - MOVEI A,PVLNT*2+1(PVP) - HRLI A,TFRAME - MOVE B,TBINIT+1(PVP) - HLL B,OTBSAV(B) - PUSH TP,A - PUSH TP,B - MOVEI B,-1(TP) - JRST AEVAL2 - -; MAIN EVAL ENTRANCE - -MFUNCTION EVAL,SUBR - - ENTRY - - SKIPE C,1STEPR+1(PVP) ; BEING 1 STEPPED? - JRST 1STEPI ; YES HANDLE -EVALON: HLRZ A,AB ;GET NUMBER OF ARGS - CAIE A,-2 ;EXACTLY 1? - JRST AEVAL ;EVAL WITH AN ALIST -SEVAL: GETYP A,(AB) ;GET TYPE OF ARG - SKIPE C,EVATYP+1(TVP) ; USER TYPE TABLE? - JRST EVDISP -SEVAL1: CAIG A,NUMPRI ;PRIMITIVE? - JRST @EVTYPE(A) ;YES-DISPATCH - -SELF: MOVE A,(AB) ;TYPES WHICH EVALUATE - MOVE B,1(AB) - JRST EFINIS ;TO SELF-EG NUMBERS - -; HERE FOR USER EVAL DISPATCH - -EVDISP: ADDI C,(A) ; POINT TO SLOT - ADDI C,(A) - SKIPE (C) ; SKIP EITHER A LOSER OR JRST DISP - JRST EVDIS1 ; APPLY EVALUATOR - SKIPN C,1(C) ; GET ADDR OR GO TO PURE DISP - JRST SEVAL1 - JRST (C) - -EVDIS1: PUSH TP,(C) - PUSH TP,1(C) - PUSH TP,(AB) - PUSH TP,1(AB) - MCALL 2,APPLY ; APPLY HACKER TO OBJECT - JRST EFINIS - - -; EVAL DISPATCH TABLE - -DISTBL EVTYPE,SELF,[[TFORM,EVFORM],[TLIST,EVLIST],[TVEC,EVECT],[TUVEC,EUVEC] -[TSEG,ILLSEG]] - - -;WATCH FOR SUBTLE BUG 43 LERR,LPROG OR BINDID -AEVAL: - CAIE A,-4 ;EXACTLY 2 ARGS? - JRST WNA ;NO-ERROR - GETYP A,2(AB) ;CHECK THAT WE HAVE A FRAME - CAIE A,TACT - CAIN A,TFRAME - JRST .+3 - CAIE A,TENV - JRST TRYPRO ; COULD BE PROCESS - MOVEI B,2(AB) ; POINT TO FRAME -AEVAL2: PUSHJ P,CHENV ; HACK ENVIRONMENT CHANGE -AEVAL1: PUSH TP,(AB) - PUSH TP,1(AB) - MCALL 1,EVAL -AEVAL3: HRRZ 0,FSAV(TB) - CAIN 0,EVAL - JRST EFINIS - JRST FINIS - -TRYPRO: CAIE A,TPVP ; SKIP IF IT IS A PROCESS - JRST WTYP2 - MOVE C,3(AB) ; GET PROCESS - CAMN C,PVP ; DIFFERENT FROM ME? - JRST SEVAL ; NO, NORMAL EVAL WINS - MOVE B,SPSTO+1(C) ; GET SP FOR PROCESS - MOVE D,TBSTO+1(C) ; GET TOP FRAME - HLL D,OTBSAV(D) ; TIME IT - MOVEI C,PVLNT*2+1(C) ; CONS UP POINTER TO PROC DOPE WORD - HRLI C,TFRAME ; LOOK LIK E A FRAME - PUSHJ P,SWITSP ; SPLICE ENVIRONMENT - JRST AEVAL1 - -; ROUTINE TO CHANGE LOOK UP PATH FOR BINDINGS - -CHENV: PUSHJ P,CHFRM ; CHECK OUT FRAME - MOVE C,(B) ; POINT TO PROCESS - MOVE D,1(B) ; GET TB POINTER FROM FRAME - CAMN SP,SPSAV(D) ; CHANGE? - POPJ P, ; NO, JUST RET - MOVE B,SPSAV(D) ; GET SP OF INTEREST -SWITSP: MOVSI 0,TSKIP ; SET UP SKIP - HRRI 0,1(TP) ; POINT TO UNBIND PATH - MOVE A,PVP - ADD A,[BINDID,,BINDID] ; BIND THE BINDING ID - PUSH TP,BNDV - PUSH TP,A - PUSH TP,$TFIX - AOS A,PTIME ; NEW ID - PUSH TP,A - MOVE E,TP ; FOR SPECBIND - PUSH TP,0 - PUSH TP,B - PUSH TP,C ; SAVE PROCESS - PUSH TP,D - PUSHJ P,SPECBE ; BIND BINDID - MOVE SP,TP ; GET NEW SP - SUB SP,[3,,3] ; SET UP SP FORK - POPJ P, - - -; HERE TO EVALUATE A FORM (99% OF EVAL'S WORK) - -EVFORM: SKIPN C,1(AB) ; EMPTY FORM, RETURN FALSE - JRST EFALSE - GETYP A,(C) ; 1ST ELEMENT OF FORM - CAIE A,TATOM ; ATOM? - JRST EV0 ; NO, EVALUATE IT - MOVE B,1(C) ; GET ATOM - PUSHJ P,IGVAL ; GET ITS GLOBAL VALUE - -; SPECIAL HACK TO SPEED UP LVAL AND GVAL CALLS - - CAIE B,LVAL - CAIN B,GVAL - JRST ATMVAL ; FAST ATOM VALUE - - GETYP 0,A - CAIE 0,TUNBOU ; BOUND? - JRST IAPPLY ; YES APPLY IT - - MOVE C,1(AB) ; LOOK FOR LOCAL - MOVE B,1(C) - PUSHJ P,ILVAL - GETYP 0,A - CAIE 0,TUNBOU - JRST IAPPLY ; WIN, GO APPLY IT - - PUSH TP,$TATOM - PUSH TP,EQUOTE UNBOUND-VARIABLE - PUSH TP,$TATOM - MOVE C,1(AB) ; FORM BACK - PUSH TP,1(C) - PUSH TP,$TATOM - PUSH TP,MQUOTE VALUE - MCALL 3,ERROR ; REPORT THE ERROR - JRST IAPPLY - -EFALSE: MOVSI A,TFALSE ; SPECIAL FALSE FOR EVAL OF EMPTY FORM - MOVEI B,0 - JRST EFINIS - -ATMVAL: HRRZ D,(C) ; CDR THE FORM - HRRZ 0,(D) ; AND AGAIN - JUMPN 0,IAPPLY - GETYP 0,(D) ; MAKE SURE APPLYING TO ATOM - CAIE 0,TATOM - JRST IAPPLY - MOVEI E,IGVAL ; ASSUME GLOBAAL - CAIE B,GVAL ; SKIP IF OK - MOVEI E,ILVAL ; ELSE USE LOCAL - PUSH P,B ; SAVE SUBR - MOVE B,(D)+1 ; CLR BUG #1637 (GET THE ATOM FOR THE SUBR) - PUSHJ P,(E) ; AND GET VALUE - CAME A,$TUNBOU - JRST EFINIS ; RETURN FROM EVAL - POP P,B - MOVSI A,TSUBR ; CAUSE REAL SUBR TO GET EROR - JRST IAPPLY - -; HERE FOR 1ST ELEMENT NOT A FORM - -EV0: PUSHJ P,FASTEV ; EVAL IT - -; HERE TO APPLY THINGS IN FORMS - -IAPPLY: PUSH TP,(AB) ; SAVE THE FORM - PUSH TP,1(AB) - PUSH TP,A - PUSH TP,B ; SAVE THE APPLIER - PUSH TP,$TFIX ; AND THE ARG GETTER - PUSH TP,[ARGCDR] - PUSHJ P,APLDIS ; GO TO INTERNAL APPLIER - JRST EFINIS ; LEAVE EVAL - -; HERE TO EVAL 1ST ELEMENT OF A FORM - -FASTEV: SKIPE 1STEPR+1(PVP) ; BEING 1 STEPPED? - JRST EV02 ; YES, LET LOSER SEE THIS EVAL - GETYP A,(C) ; GET TYPE - SKIPE D,EVATYP+1(TVP) ; USER TABLE? - JRST EV01 ; YES, HACK IT -EV03: CAIG A,NUMPRI ; SKIP IF SELF - SKIPA A,EVTYPE(A) ; GET DISPATCH - MOVEI A,SELF ; USE SLEF - -EV04: CAIE A,SELF ; IF EVAL'S TO SELF, JUST USE IT - JRST EV02 - MOVSI A,TLIST - MOVEM A,CSTO(PVP) - INTGO - SETZM CSTO(PVP) - HLLZ A,(C) ; GET IT - MOVE B,1(C) - JSP E,CHKAB ; CHECK DEFERS - POPJ P, ; AND RETURN - -EV01: ADDI D,(A) ; POINT TO SLOT OF USER EVAL TABLE - ADDI D,(A) - SKIPE (D) ; EITHER NOT GIVEN OR SIMPLE - JRST EV02 - SKIPN 1(D) ; SKIP IF SIMPLE - JRST EV03 ; NOT GIVEN - MOVE A,1(D) - JRST EV04 - -EV02: PUSH TP,(C) - HLLZS (TP) ; FIX UP LH - PUSH TP,1(C) - JSP E,CHKARG - MCALL 1,EVAL - POPJ P, - - -; MAPF/MAPR CALL TO APPLY - - MQUOTE APPLY - -MAPPLY: JRST APPLY - -; APPLY, FALLS INTO EVAL'S APPLY CODE AT APLDIS - -MFUNCTION APPLY,SUBR - - ENTRY - - JUMPGE AB,TFA ; MUST BE AT LEAST 1 ARGUMENT - MOVE A,AB - ADD A,[2,,2] - PUSH TP,$TAB - PUSH TP,A - PUSH TP,(AB) ; SAVE FCN - PUSH TP,1(AB) - PUSH TP,$TFIX ; AND ARG GETTER - PUSH TP,[SETZ APLARG] - PUSHJ P,APLDIS - JRST FINIS - -; STACKFROM, ALSO FALLS INTO EVAL'S APPLIER AT APLDIS - -MFUNCTION STACKFORM,FSUBR - - ENTRY 1 - - GETYP A,(AB) - CAIE A,TLIST - JRST WTYP1 - MOVEI A,3 ; CHECK ALL GOODIES SUPPLIED - HRRZ B,1(AB) - - JUMPE B,TFA - HRRZ B,(B) ; CDR IT - SOJG A,.-2 - - HRRZ C,1(AB) ; GET LIST BACK - PUSHJ P,FASTEV ; DO A FAST EVALUATION - PUSH TP,(AB) - HRRZ C,@1(AB) ; POINT TO ARG GETTING FORMS - PUSH TP,C - PUSH TP,A ; AND FCN - PUSH TP,B - PUSH TP,$TFIX - PUSH TP,[SETZ EVALRG] - PUSHJ P,APLDIS - JRST FINIS - - -; OFFSETS FOR TEMPORARIES ETC. USED IN APPLYING STUFF - -E.FRM==0 ; POINTS TO FORM BEING EVALED (OR ARGS FOR APPLY STACKFORM) -E.FCN==2 ; FUNCTION/SUBR/RSUBR BEING APPLIED -E.ARG==4 ; POINTS TO ARG GETTING ROUTINE (<0 => MUST EVAL ARGS) -E.EXTR==6 ; CONTAINS 1ST ARG IN USER APPLY CASE -E.SEG==10 ; POINTS TO SEGMENT IN FORM BEING HACKED -E.CNT==12 ; COUNTER FOR TUPLES OF ARGS -E.DECL==14 ; POINTS TO DECLARATION LIST IN FUNCTIONS -E.ARGL==16 ; POINTS TO ARG LIST IN FUNCTIONS -E.HEW==20 ; POINTS TO HEWITT ATOM IF IT EXISTS - -E.VAL==E.ARGL ; VALUE TYPE FOR RSUBRS - -MINTM==E.EXTR+2 ; MIN # OF TEMPS EVER ALLOCATED -E.TSUB==E.CNT+2 ; # OF TEMPS FOR SUBR/NUMBER APPLICATION -XP.TMP==E.HEW-E.EXTR ; # EXTRA TEMPS FOR FUNCTION APPLICATION -R.TMP==4 ; TEMPS AFTER ARGS ARE BOUND -TM.OFF==E.HEW+2-R.TMP ; TEMPS TO FLUSH AFTER BIND OF ARGS - -RE.FCN==0 ; AFTER BINDING CONTAINS FCN BODY -RE.ARG==2 ; ARG LIST AFTER BINDING - -; GENERAL THING APPLYER - -APLDIS: PUSH TP,[0] ; SLOT USED FOR USER APPLYERS - PUSH TP,[0] -APLDIX: GETYP A,E.FCN(TB) ; GET TYPE - -APLDI: SKIPE D,APLTYP+1(TVP) ; USER TABLE EXISTS? - JRST APLDI1 ; YES, USE IT -APLDI2: CAIG A,NUMPRI ; SKIP IF NOT PRIM - JRST @APTYPE(A) - JRST NAPT - -APLDI1: ADDI D,(A) ; POINT TO SLOT - ADDI D,(A) - SKIPE (D) ; SKIP IF NOT GIVEN OR STANDARD - JRST APLDI3 -APLDI4: SKIPE D,1(D) ; GET DISP - JRST (D) - JRST APLDI2 ; USE SYSTEM DISPATCH - -APLDI3: SKIPE E.EXTR+1(TB) ; SKIP IF HAVEN'T BEEN HERE BEFORE - JRST APLDI4 - MOVE A,(D) ; GET ITS HANDLER - EXCH A,E.FCN(TB) ; AND USE AS FCN - MOVEM A,E.EXTR(TB) ; SAVE - MOVE A,1(D) - EXCH A,E.FCN+1(TB) - MOVEM A,E.EXTR+1(TB) ; STASH OLD FCN AS EXTRG - GETYP A,(D) ; GET TYPE - JRST APLDI - - -; APPLY DISPATCH TABLE - -DISTBL APTYPE,,[[TSUBR,APSUBR],[TFSUBR,APFSUB],[TRSUBR,APRSUB],[TFIX,APNUM] -[TEXPR,APEXPR],[TFUNAR,APFUNARG],[TENTER,APENTR],[TMACRO,APMACR]] - -; SUBR TO SAY IF TYPE IS APPLICABLE - -MFUNCTION APPLIC,SUBR,[APPLICABLE?] - - ENTRY 1 - - GETYP A,(AB) - PUSHJ P,APLQ - JRST IFALSE - JRST TRUTH - -; HERE TO DETERMINE IF A TYPE IS APPLICABLE - -APLQ: PUSH P,B - SKIPN B,APLTYP+1(TVP) - JRST USEPUR ; USE PURE TABLE - ADDI B,(A) - ADDI B,(A) ; POINT TO SLOT - SKIPG 1(B) ; SKIP IF WINNER - SKIPE (B) ; SKIP IF POTENIAL LOSER - JRST CPPJ1B ; WIN - SKIPE 1(B) ; SKIP IF MUST USE PURE TABBLE - JRST CPOPJB -USEPUR: CAIG A,NUMPRI ; SKIP IF NOT PRIM - SKIPL APTYPE(A) ; SKIP IF APLLICABLE -CPPJ1B: AOS -1(P) -CPOPJB: POP P,B - POPJ P, - -; FSUBR APPLYER - -APFSUBR: - SKIPN E.EXTR(TB) ; IF EXTRA ARG - SKIPGE E.ARG+1(TB) ; OR APPLY/STACKFORM, LOSE - JRST BADFSB - MOVE A,E.FCN+1(TB) ; GET FCN - HRRZ C,@E.FRM+1(TB) ; GET ARG LIST - SUB TP,[MINTM,,MINTM] ; FLUSH UNWANTED TEMPS - PUSH TP,$TLIST - PUSH TP,C ; ARG TO STACK - .MCALL 1,(A) ; AND CALL - POPJ P, ; AND LEAVE - -; SUBR APPLYER - -APSUBR: - PUSHJ P,PSH4ZR ; SET UP ZEROED SLOTS - SKIPN A,E.EXTR(TB) ; FUNNY ARGS - JRST APSUB1 ; NO, GO - MOVE B,E.EXTR+1(TB) ; YES , GET VAL - JRST APSUB2 ; AND FALL IN - -APSUB1: PUSHJ P,@E.ARG+1(TB) ; EAT AN ARG - JRST APSUBD ; DONE -APSUB2: PUSH TP,A - PUSH TP,B - AOS E.CNT+1(TB) ; COUNT IT - JRST APSUB1 - -APSUBD: MOVE A,E.CNT+1(TB) ; FINISHED, GET COUNT - MOVE B,E.FCN+1(TB) ; AND SUBR - GETYP 0,E.FCN(TB) - CAIN 0,TENTER - JRST APENDN - PUSHJ P,BLTDN ; FLUSH CRUFT - .ACALL A,(B) - POPJ P, - -BLTDN: MOVEI C,(TB) ; POINT TO DEST - HRLI C,E.TSUB(C) ; AND SOURCE - BLT C,-E.TSUB(TP) ;BL..............T - SUB TP,[E.TSUB,,E.TSUB] - POPJ P, - -APENDN: PUSHJ P,BLTDN -APNDN1: .ECALL A,(B) - POPJ P, - -; FLAGS FOR RSUBR HACKER - -F.STR==1 -F.OPT==2 -F.QUO==4 -F.NFST==10 - -; APPLY OBJECTS OF TYPE RSUBR - -APENTR: -APRSUBR: - MOVE C,E.FCN+1(TB) ; GET THE RSUBR - CAML C,[-5,,] ; IS IT LONG ENOUGH FOR DECLS - JRST APSUBR ; NO TREAT AS A SUBR - GETYP 0,4(C) ; GET TYPE OF 3D ELEMENT - CAIE 0,TDECL ; DECLARATION? - JRST APSUBR ; NO, TREAT AS SUBR - PUSHJ P,PSH4ZR ; ALLOCATE SOME EXTRA ROOM - PUSH TP,$TDECL ; PUSH UP THE DECLS - PUSH TP,5(C) - PUSH TP,$TLOSE ; SAVE ROOM FOR VAL DECL - PUSH TP,[0] - - SKIPN E.EXTR(TB) ; "EXTRA" ARG? - JRST APRSU1 ; NO, - MOVE 0,[SETZ EXTRGT] ; CHANGE THE ACCESS FCN - EXCH 0,E.ARG+1(TB) - HRRM 0,E.ARG(TB) ; REMEMBER IT - -APRSU1: MOVEI 0,0 ; INIT FLAG REGISTER - PUSH P,0 ; SAVE - -APRSU2: HRRZ A,E.DECL+1(TB) ; GET DECL LIST - JUMPE A,APRSU3 ; DONE! - HRRZ B,(A) ; CDR IT - MOVEM B,E.DECL+1(TB) - PUSHJ P,NXTDCL ; IS NEXT THING A STRING? - JRST APRSU4 ; NO, BETTER BE A TYPE - CAMN B,[ASCII /VALUE/] - JRST RSBVAL ; SAVE VAL DECL - TRON 0,F.NFST ; IF NOT FIRST, LOSE - CAME B,[ASCII /CALL/] ; CALL DECL - JRST APRSU7 - SKIPGE E.ARG+1(TB) ; LEGAL? - JRST MPD - MOVE C,E.FRM(TB) - MOVE D,E.FRM+1(TB) ; GET FORM - JRST APRS10 ; HACK IT - -APRSU5: TROE 0,F.STR ; STRING STRING? - JRST MPD ; LOSER - CAME B,[+1] ; OPTIONA? - JRST APRSU8 - TROE 0,F.OPT ; CHECK AND SET - JRST MPD ; OPTINAL OPTIONAL LOSES - JRST APRSU2 ; TO MAIN LOOP - -APRSU7: CAME B,[ASCII /QUOTE/] - JRST APRSU5 - TRO 0,F.STR - TROE 0,F.QUO ; TURN ON AND CHECK QUOTE - JRST MPD ; QUOTE QUOTE LOSES - JRST APRSU2 ; GO TO END OF LOOP - - -APRSU8: CAME B,[ASCII /ARGS/] - JRST APRSU9 - SKIPGE E.ARG+1(TB) ; SKIP IF LEGAL - JRST MPD - HRRZ D,@E.FRM+1(TB) ; GET ARG LIST - MOVSI C,TLIST - -APRS10: HRRZ A,(A) ; GET THE DECL - MOVEM A,E.DECL+1(TB) ; CLOBBER - HRRZ B,(A) ; CHECK FOR TOO MUCH - JUMPN B,MPD - MOVE B,1(A) ; GET DECL - HLLZ A,(A) ; GOT THE DECL - MOVEM 0,(P) ; SAVE FLAGS - JSP E,CHKAB ; CHECK DEFER - PUSH TP,C - PUSH TP,D ; SAVE - PUSHJ P,TMATCH - JRST WTYP - AOS E.CNT+1(TB) ; COUNT ARG - JRST APRDON ; GO CALL RSUBR - -RSBVAL: HRRZ A,E.DECL+1(TB) ; GET DECL - JUMPE A,MPD - HRRZ B,(A) ; POINT TO DECL - MOVEM B,E.DECL+1(TB) ; SAVE NEW DECL POINTER - PUSHJ P,NXTDCL - JRST .+2 - JRST MPD - MOVEM A,E.VAL+1(TB) ; SAVE VAL DECL - MOVSI A,TDCLI - MOVEM A,E.VAL(TB) ; SET ITS TYPE - JRST APRSU2 - - -APRSU9: CAME B,[ASCII /TUPLE/] - JRST MPD - MOVEM 0,(P) ; SAVE FLAGS - HRRZ A,(A) ; CDR DECLS - MOVEM A,E.DECL+1(TB) - HRRZ B,(A) - JUMPN B,MPD ; LOSER - PUSH P,[0] ; COUNT ELEMENTS IN TUPLE - -APRTUP: PUSHJ P,@E.ARG+1(TB) ; GOBBLE ARGS - JRST APRTPD ; DONE - PUSH TP,A - PUSH TP,B - AOS (P) ; COUNT IT - JRST APRTUP ; AND GO - -APRTPD: POP P,C ; GET COUNT - ADDM C,E.CNT+1(TB) ; UPDATE MAIN COUNT - ASH C,1 ; # OF WORDS - HRLI C,TINFO ; BUILD FENCE POST - PUSH TP,C - PUSHJ P,TBTOTP ; GEN REL OFFSET TO TOP - PUSH TP,D - HRROI D,-1(TP) ; POINT TO TOP - SUBI D,(C) ; TO BASE - TLC D,-1(C) - MOVSI C,TARGS ; BUILD TYPE WORD - HLR C,OTBSAV(TB) - MOVE A,E.DECL+1(TB) - MOVE B,1(A) - HLLZ A,(A) ; TYPE/VAL - JSP E,CHKAB ; CHECK - PUSHJ P,TMATCH ; GOTO TYPE CHECKER - JRST WTYP - - SUB TP,[2,,2] ; REMOVE FENCE POST - -APRDON: SUB P,[1,,1] ; FLUSH CRUFT - MOVE A,E.CNT+1(TB) ; GET # OF ARGS - MOVE B,E.FCN+1(TB) - GETYP 0,E.FCN(TB) ; COULD BE ENTRY - MOVEI C,(TB) ; PREPARE TO BLT DOWN - HRLI C,E.TSUB+2(C) - BLT C,-E.TSUB+2(TP) - SUB TP,[E.TSUB+2,,E.TSUB+2] - CAIE 0,TRSUBR - JRST APNDN1 - .ACALL A,(B) ; CALL THE RSUBR - JRST PFINIS - - - -APRSU4: MOVEM 0,(P) ; SAVE FLAGS - MOVE B,1(A) ; GET DECL - HLLZ A,(A) - JSP E,CHKAB - MOVE 0,(P) ; RESTORE FLAGS - PUSH TP,A - PUSH TP,B ; AND SAVE - SKIPL E.ARG+1(TB) ; ALREADY EVAL'D - TRZN 0,F.QUO - JRST APREVA ; MUST EVAL ARG - MOVEM 0,(P) - HRRZ C,@E.FRM+1(TB) ; GET ARG? - TRNE 0,F.OPT ; OPTIONAL - JUMPE C,APRDN - JUMPE C,TFA ; NO, TOO FEW ARGS - MOVEM C,E.FRM+1(TB) - HLLZ A,(C) ; GET ARG - MOVE B,1(C) - JSP E,CHKAB ; CHECK THEM - -APRTYC: MOVE C,A ; SET UP FOR TMATCH - MOVE D,B - EXCH B,(TP) - EXCH A,-1(TP) ; SAVE STUFF -APRS11: PUSHJ P,TMATCH ; CHECK TYPE - JRST WTYP - - MOVE 0,(P) ; RESTORE FLAGS - TRZ 0,F.STR - AOS E.CNT+1(TB) - JRST APRSU2 ; AND GO ON - -APREVA: PUSHJ P,@E.ARG+1(TB) ; EVAL ONE - TDZA C,C ; C=0 ==> NONE LEFT - MOVEI C,1 - MOVE 0,(P) ; FLAGS - JUMPN C,APRTYC ; GO CHECK TYPE -APRDN: SUB TP,[2,,2] ; FLUSH DECL - TRNE 0,F.OPT ; OPTIONAL? - JRST APRDON ; ALL DONE - JRST TFA - -APRSU3: TRNE 0,F.STR ; END IN STRING? - JRST MPD - PUSHJ P,@E.ARG+1(TB) ; SEE IF ANYMORE ARGS - JRST APRDON - JRST TMA - - -; STANDARD ARGUMENT GETTERS USED IN APPLYING THINGS - -ARGCDR: HRRZ C,@E.FRM+1(TB) ; POINT TO ARGLIST (NOTE: POINTS 1 BEFORE WHERE ARG IS) - JUMPE C,CPOPJ ; LEAVE IF DONE - MOVEM C,E.FRM+1(TB) - GETYP 0,(C) ; GET TYPE OF ARG - CAIN 0,TSEG - JRST ARGCD1 ; SEG MENT HACK - PUSHJ P,FASTEV - JRST CPOPJ1 - -ARGCD1: PUSH TP,$TFORM ; PRETEND WE ARE A FORM - PUSH TP,1(C) - MCALL 1,EVAL - MOVEM A,E.SEG(TB) - MOVEM B,E.SEG+1(TB) - PUSHJ P,TYPSEG ; GET SEG TYPE CODE - HRRM C,E.ARG(TB) ; SAVE IT IN OBSCCURE PLACE - MOVE C,[SETZ SGARG] - MOVEM C,E.ARG+1(TB) ; SET NEW ARG GETTER - -; FALL INTO SEGARG - -SGARG: INTGO - HRRZ C,E.ARG(TB) ; SEG CODE TO C - MOVE D,E.SEG+1(TB) - MOVE A,E.SEG(TB) - MOVEM A,DSTO(PVP) - PUSHJ P,NXTLM ; GET NEXT ELEMENT - JRST SEGRG1 ; DONE - MOVEM D,E.SEG+1(TB) - MOVE D,DSTO(PVP) ; KEEP TYPE WINNING - MOVEM D,E.SEG(TB) - SETZM DSTO(PVP) - JRST CPOPJ1 ; RETURN - -SEGRG1: SETZM DSTO(PVP) - MOVEI C,ARGCDR - MOVEM C,E.ARG+1(TB) ; RESET ARG GETTER - JRST ARGCDR - -; ARGUMENT GETTER FOR APPLY - -APLARG: INTGO - SKIPL A,E.FRM+1(TB) ; ANY ARGS LEFT - POPJ P, ; NO, EXIT IMMEDIATELY - ADD A,[2,,2] - MOVEM A,E.FRM+1(TB) - MOVE B,-1(A) ; RET NEXT ARG - MOVE A,-2(A) - JRST CPOPJ1 - -; STACKFORM ARG GETTER - -EVALRG: SKIPN C,@E.FRM+1(TB) ; ANY FORM? - POPJ P, - PUSHJ P,FASTEV - GETYP A,A ; CHECK FOR FALSE - CAIN A,TFALSE - POPJ P, - MOVE C,E.FRM+1(TB) ; GET OTHER FORM - PUSHJ P,FASTEV - JRST CPOPJ1 - - -; HERE TOO APPLY NUMBERS - -APNUM: PUSHJ P,PSH4ZR ; TP SLOSTS - SKIPN A,E.EXTR(TB) ; FUNNY ARG? - JRST APNUM1 ; NOPE - MOVE B,E.EXTR+1(TB) ; GET ARG - JRST APNUM2 - -APNUM1: PUSHJ P,@E.ARG+1(TB) ; GET ARG - JRST TFA -APNUM2: PUSH TP,A - PUSH TP,B - PUSH TP,E.FCN(TB) - PUSH TP,E.FCN+1(TB) - PUSHJ P,@E.ARG+1(TB) - JRST .+2 - JRST TMA - PUSHJ P,BLTDN ; FLUSH JUNK - MCALL 2,NTH - POPJ P, - -; HERE TO APPLY SUSSMAN FUNARGS - -APFUNARG: - - SKIPN C,E.FCN+1(TB) - JRST FUNERR - HRRZ D,(C) ; MUST BE AT LEAST 2 LONG - JUMPE D,FUNERR - GETYP 0,(D) ; CHECK FOR LIST - CAIE 0,TLIST - JRST FUNERR - HRRZ 0,(D) ; SHOULD BE END - JUMPN 0,FUNERR - GETYP 0,(C) ; 1ST MUST BE FCN - CAIE 0,TEXPR - JRST FUNERR - SKIPN C,1(C) - JRST NOBODY - PUSHJ P,APEXPF ; BIND THE ARGS AND AUX'S - HRRZ C,RE.FCN+1(TB) ; GET BODY OF FUNARG - MOVE B,1(C) ; GET FCN - MOVEM B,RE.FCN+1(TB) ; AND SAVE - HRRZ C,(C) ; CDR FUNARG BODY - MOVE C,1(C) - MOVSI 0,TLIST ; SET UP TYPE - MOVEM 0,CSTO(PVP) ; FOR INTS TO WIN - -FUNLP: INTGO - JUMPE C,DOF ; RUN IT - GETYP 0,(C) - CAIE 0,TLIST ; BETTER BE LIST - JRST FUNERR - PUSH TP,$TLIST - PUSH TP,C - PUSHJ P,NEXTDC ; GET POSSIBILITY - JRST FUNERR ; LOSER - CAIE A,2 - JRST FUNERR - HRRZ B,(B) ; GET TO VALUE - MOVE C,(TP) - SUB TP,[2,,2] - PUSH TP,BNDA - PUSH TP,E - HLLZ A,(B) ; GET VAL - MOVE B,1(B) - JSP E,CHKAB ; HACK DEFER - PUSHJ P,PSHAB4 ; PUT VAL IN - HRRZ C,(C) ; CDR - JUMPN C,FUNLP - -; HERE TO RUN FUNARG - -DOF: SETZM CSTO(PVP) ; DONT CONFUSE GC - PUSHJ P,SPECBIND ; BIND 'EM UP - JRST RUNFUN - - - -; HERE TO DO MACROS - -APMACR: HRRZ E,OTBSAV(TB) - HRRZ E,PCSAV(E) ; SEE WHERE FROM - CAIN E,AEVAL3 ; SKIP IF NOT RIGHT - JRST APMAC1 - SKIPG E.ARG+1(TB) ; SKIP IF REAL FORM EXISTS - JRST BADMAC - MOVE A,E.FRM(TB) - MOVE B,E.FRM+1(TB) - SUB TP,[E.EXTR+2,,E.EXTR+2] ; FLUSH JUNK - PUSH TP,A - PUSH TP,B - MCALL 1,EXPAND ; EXPAND THE MACRO - PUSH TP,A - PUSH TP,B - MCALL 1,EVAL ; EVAL THE RESULT - POPJ P, - -APMAC1: MOVE C,E.FCN+1(TB) ; GET MACRO BODY - GETYP A,(C) - MOVE B,1(C) - MOVSI A,(A) - JSP E,CHKAB ; FIX DEFERS - MOVEM A,E.FCN(TB) - MOVEM B,E.FCN+1(TB) - JRST APLDIX - -; HERE TO APPLY EXPRS (FUNCTIONS) - -APEXPR: PUSHJ P,APEXP ; BIND ARGS AND AUX'S -RUNFUN: HRRZ A,RE.FCN(TB) ; AMOUNT OF FCN TO SKIP - MOVEI C,RE.FCN+1(TB) ; POINT TO FCN - HRRZ C,(C) ; SKIP SOMETHING - SOJGE A,.-1 ; UNTIL 1ST FORM - MOVEM C,RE.FCN+1(TB) ; AND STORE - JRST DOPROG ; GO RUN PROGRAM - -APEXP: SKIPN C,E.FCN+1(TB) ; CHECK FRO BODY - JRST NOBODY -APEXPF: PUSH P,[0] ; COUNT INIT CRAP - ADD TP,[XP.TMP,,XP.TMP] ; SLOTS FOR HACKING - SKIPL TP - PUSHJ P,TPOVFL - SETZM 1-XP.TMP(TP) ; ZERO OUT - MOVEI A,-XP.TMP+2(TP) - HRLI A,-1(A) - BLT A,(TP) ; ZERO SLOTS - PUSHJ P,CARATC ; SEE IF HEWITT ATOM EXISTS - JRST APEXP1 ; NO, GO LOOK FOR ARGLIST - MOVEM E,E.HEW+1(TB) ; SAVE ATOM - MOVSM 0,E.HEW(TB) ; AND TYPE - AOS (P) ; COUNT HEWITT ATOM -APEXP1: GETYP 0,(C) ; LOOK AT NEXT THING - CAIE 0,TLIST ; BETTER BE LIST!!! - JRST MPD.0 ; LOSE - MOVE B,1(C) ; GET LIST - MOVEM B,E.ARGL+1(TB) ; SAVE - MOVSM 0,E.ARGL(TB) ; WITH TYPE - HRRZ C,(C) ; CDR THE FCN - JUMPE C,NOBODY ; BODYLESS FCN - GETYP 0,(C) ; SEE IF DCL LIST SUPPLIED - CAIE 0,TDECL - JRST APEXP2 ; NO, START PROCESSING ARGS - AOS (P) ; COUNT DCL - MOVE B,1(C) - MOVEM B,E.DECL+1(TB) - MOVSM 0,E.DECL(TB) - HRRZ C,(C) ; CDR ON - JUMPE C,NOBODY - - ; CHECK FOR EXISTANCE OF EXTRA ARG - -APEXP2: POP P,A ; GET COUNT - HRRM A,E.FCN(TB) ; AND SAVE - SKIPN E.EXTR(TB) ; SKIP IF FUNNY EXTRA ARG EXISTS - JRST APEXP3 - MOVE 0,[SETZ EXTRGT] - EXCH 0,E.ARG+1(TB) - HRRM 0,E.ARG(TB) ; SAVE OLD GETTER AROUND - -; FALL THROUGH - -; LOOK FOR "BIND" DECLARATION - -APEXP3: PUSHJ P,UNPROG ; UNASSIGN LPROG IF NEC -APXP3A: SKIPN A,E.ARGL+1(TB) ; GET ARGLIST - JRST APEXP4 ; NONE, VERIFY NONE WERE GIVEN - PUSHJ P,NXTDCL ; SEE IF A DECL IS THERE - JRST BNDRG ; NO, GO BIND NORMAL ARGS - HRRZ C,(A) ; CDR THE DCLS - CAME B,[ASCII /BIND/] - JRST CH.CAL ; GO LOOK FOR "CALL" - PUSHJ P,CARTMC ; MUST BE AN ATOM - MOVEM C,E.ARGL+1(TB) ; AND SAVE CDR'D ARGS - PUSHJ P,MAKENV ; GENERATE AN ENVIRONMENT - PUSHJ P,PSBND1 ; PUSH THE BINDING AND CHECK THE DCL - JRST APXP3A ; IN CASE <"BIND" B "BIND" C...... - - -; LOOK FOR "CALL" DCL - -CH.CAL: CAME B,[ASCII /CALL/] - JRST CHOPT ; TRY SOMETHING ELSE - SKIPG E.ARG+1(TB) ; DONT SKIP IF CANT WIN - JRST MPD.2 - PUSHJ P,CARTMC ; BETTER BE AN ATOM - MOVEM C,E.ARGL+1(TB) - MOVE A,E.FRM(TB) ; RETURN FORM - MOVE B,E.FRM+1(TB) - PUSHJ P,PSBND1 ; BIND AND CHECK - JRST APEXP5 - -; BIND NORMAL ARGS BY CALLING BNDEM1, RETURNS WHEN ALL DONE - -BNDRG: PUSHJ P,BNDEM1 ; GO BIND THEM UP - TRNN A,4 ; SKIP IF HIT A DCL - JRST APEXP4 ; NOT A DCL, MUST BE DONE - -; LOOK FOR "OPTIONAL" DECLARATION - -CHOPT: CAME B,[+1] - JRST CHREST ; TRY TUPLE/ARGS - MOVEM C,E.ARGL+1(TB) ; SAVE RESTED ARGLIST - PUSHJ P,BNDEM2 ; DO ALL SUPPLIED OPTIONALS - TRNN A,4 ; SKIP IF NEW DCL READ - JRST APEXP4 - -; CHECK FOR "ARGS" DCL - -CHREST: CAME B,[ASCII /ARGS/] - JRST CHRST1 ; GO LOOK FOR "TUPLE" - SKIPGE E.ARG+1(TB) ; SKIP IF LEGAL - JRST MPD.3 - PUSHJ P,CARTMC ; GOBBLE ATOM - MOVEM C,E.ARGL+1(TB) ; SAVE CDR'D ARG - HRRZ B,@E.FRM+1(TB) ; GET ARG LIST - MOVSI A,TLIST ; GET TYPE - PUSHJ P,PSBND1 - JRST APEXP5 - -; HERE TO CHECK FOR "TUPLE" - -CHRST1: CAME B,[ASCII /TUPLE/] - JRST APXP10 - PUSHJ P,CARTMC ; GOBBLE ATOM - MOVEM C,E.ARGL+1(TB) - SETZB A,B - PUSHJ P,PSHBND ; SET UP BINDING - SETZM E.CNT+1(TB) ; ZERO ARG COUNTER - -TUPLP: PUSHJ P,@E.ARG+1(TB) ; GET AN ARG - JRST TUPDON ; FINIS - AOS E.CNT+1(TB) - PUSH TP,A - PUSH TP,B - JRST TUPLP - -TUPDON: PUSHJ P,MAKINF ; MAKE INFO CELL - PUSH TP,$TINFO ; FENCE POST TUPLE - PUSHJ P,TBTOTP - ADDI D,TM.OFF ; COMPENSATE FOR MOVEMENT - PUSH TP,D - MOVE C,E.CNT+1(TB) ; GET COUNT - ASH C,1 ; TO WORDS - HRRM C,-1(TP) ; INTO FENCE POST - MOVEI B,-TM.OFF-1(TP) ; SETUP ARG POINTER - SUBI B,(C) ; POINT TO BASE OF TUPLE - MOVNS C ; FOR AOBJN POINTER - HRLI B,(C) ; GOOD ARGS POINTER - MOVEM A,TM.OFF-4(B) ; STORE - MOVEM B,TM.OFF-3(B) - - -; CHECK FOR VALID ENDING TO ARGS - -APEXP5: PUSHJ P,NEXTD ; READ NEXT THING IN ARGLIST - JRST APEXP8 ; DONE - TRNN A,4 ; SKIP IF DCL - JRST MPD.4 ; LOSER -APEXP7: MOVSI A,-NWINS ; CHECK FOR A WINNER - CAME B,WINRS(A) - AOBJN A,.-1 - JUMPE A,MPD.6 ; NOT A WINNER - -; HERE TO BLT THE WORLD DOWN ON TOP OF ALL THE USELESS TEMPS - -APEXP8: MOVE 0,E.HEW+1(TB) ; GET HEWITT ATOM - MOVE E,E.FCN(TB) ; SAVE COUNTER - MOVE C,E.FCN+1(TB) ; FCN - MOVE B,E.ARGL+1(TB) ; ARG LIST - MOVE D,E.DECL+1(TB) ; AND DCLS - MOVEI A,R.TMP(TB) ; SET UP BLT - HRLI A,TM.OFF(A) - BLT A,-TM.OFF(TP) ; BLLLLLLLLLLLLLT - SUB TP,[TM.OFF,,TM.OFF] ; FLUSH CRUFT - MOVEM E,RE.FCN(TB) - MOVEM C,RE.FCN+1(TB) - MOVEM B,RE.ARGL+1(TB) - MOVE E,TP - PUSH TP,$TATOM - PUSH TP,0 - PUSH TP,$TDECL - PUSH TP,D - GETYP A,-5(TP) ; TUPLE ON TOP? - CAIE A,TINFO ; SKIP IF YES - JRST APEXP9 - HRRZ A,-5(TP) ; GET SIZE - ADDI A,2 - HRLI A,(A) - SUB E,A ; POINT TO BINDINGS - SKIPE C,(TP) ; IF DCL - PUSHJ P,CHKDCL ; CHECK TYPE SPEC ON TUPLE -APEXP9: PUSHJ P,USPCBE ; DO ACTUAL BINDING - - MOVE E,-2(TP) ; RESTORE HEWITT ATOM - MOVE D,(TP) ; AND DCLS - SUB TP,[4,,4] - - JRST AUXBND ; GO BIND AUX'S - -; HERE TO VERIFY CHECK IF ANY ARGS LEFT - -APEXP4: PUSHJ P,@E.ARG+1(TB) - JRST APEXP8 ; WIN - JRST TMA ; TOO MANY ARGS - -APXP10: PUSH P,B - PUSHJ P,@E.ARG+1(TB) - JRST .+2 - JRST TMA - POP P,B - JRST APEXP7 - -; LIST OF POSSIBLE TERMINATING NAMES - -WINRS: -AS.ACT: ASCII /ACT/ -AS.NAM: ASCII /NAME/ -AS.AUX: ASCII /AUX/ -AS.EXT: ASCII /EXTRA/ -NWINS==.-WINRS - - -; HERE TO BIND AUX VARIABLES FOR PROGS AND FCNS - -AUXBND: PUSH P,E ; SAVE HEWITT ATOM ( WILL PUT ON MARKED STACK - ; WHEN NECESSARY) - PUSH P,D ; SAME WITH DCL LIST - PUSH P,[-1] ; FLAG SAYING WE ARE FCN - SKIPN C,RE.ARG+1(TB) ; GET ARG LIST - JRST AUXDON - GETYP 0,(C) ; GET TYPE - CAIE 0,TDEFER ; SKIP IF CHSTR - MOVMS (P) ; SAY WE ARE IN OPTIONALS - JRST AUXB1 - -PRGBND: PUSH P,E - PUSH P,D - PUSH P,[0] ; WE ARE IN AUXS - -AUXB1: HRRZ C,RE.ARG+1(TB) ; POINT TO ARGLIST - PUSHJ P,NEXTDC ; GET NEXT THING OFF OF ARG LIST - JRST AUXDON - TRNE A,4 ; SKIP IF SOME KIND OF ATOM - JRST TRYDCL ; COUDL BE DCL - TRNN A,1 ; SKIP IF QUOTED - JRST AUXB2 - SKIPN (P) ; SKIP IF QUOTED OK - JRST MPD.11 -AUXB2: PUSHJ P,PSHBND ; SET UP BINDING - PUSH TP,$TDECL ; SAVE HEWITT ATOM - PUSH TP,-1(P) - PUSH TP,$TATOM ; AND DECLS - PUSH TP,-2(P) - - TRNN A,2 ; SKIP IF INIT VAL EXISTS - JRST AUXB3 ; NO, USE UNBOUND - -; EVALUATE EXPRESSION - - HRRZ C,(B) ; CDR ATOM OFF - -; CHECK FOR SPECIAL FORMS - - GETYP 0,(C) ; GET TYPE OF GOODIE - CAIE 0,TFORM ; SMELLS LIKE A FORM - JRST AUXB13 - HRRZ D,1(C) ; GET 1ST ELEMENT - GETYP 0,(D) ; AND ITS VAL - CAIE 0,TATOM ; FEELS LIKE THE RIGHT FORM - JRST AUXB13 - - MOVE 0,1(D) ; GET THE ATOM - CAME 0,MQUOTE TUPLE - CAMN 0,MQUOTE ITUPLE - JRST DOTUPL ; SURE GLAD I DIDN'T STEP IN THAT FORM - - -AUXB13: PUSHJ P,FASTEV -AUXB14: MOVE E,TP -AUXB4: MOVEM A,-7(E) ; STORE VAL IN BINDING - MOVEM B,-6(E) - -; HERE TO CHECK AGAINST DECLARATIONS AND COMPLETE THE BINDING - -AUXB5: SUB E,[4,,4] ; POINT TO BINDING TOP - SKIPE C,-2(TP) ; POINT TO DECLARATINS - PUSHJ P,CHKDCL ; CHECK IT - PUSHJ P,USPCBE ; AND BIND UP - SKIPE C,RE.ARG+1(TB) ; CDR DCLS - HRRZ C,(C) ; IF ANY TO CDR - MOVEM C,RE.ARG+1(TB) - MOVE A,(TP) ; NOW PUT HEWITT ATOM AND DCL AWAY - MOVEM A,-2(P) - MOVE A,-2(TP) - MOVEM A,-1(P) - SUB TP,[4,,4] ; FLUSH SLOTS - JRST AUXB1 - - -AUXB3: MOVNI B,1 - MOVSI A,TUNBOU - JRST AUXB14 - - - -; HERE TO HANDLE "CALLS" TO TUPLE AND ITUPLE - -DOTUPL: PUSH TP,$TLIST ; SAVE THE MAGIC FORM - PUSH TP,D - CAME 0,MQUOTE TUPLE - JRST DOITUP ; DO AN ITUPLE - -; FALL INTO A TUPLE PUSHING LOOP - -DOTUP1: HRRZ C,@(TP) ; CDR THE FORM - JUMPE C,ATUPDN ; FINISHED - MOVEM C,(TP) ; SAVE CDR'D RESULT - GETYP 0,(C) ; CHECK FOR SEGMENT - CAIN 0,TSEG - JRST DTPSEG ; GO PULL IT APART - PUSHJ P,FASTEV ; EVAL IT - PUSHJ P,CNTARG ; PUSH IT UP AND COUNT THEM - JRST DOTUP1 - -; HERE WHEN WE FINISH - -ATUPDN: SUB TP,[2,,2] ; FLUSH THE LIST - ASH E,1 ; E HAS # OF ARGS DOUBLE IT - MOVEI D,(TP) ; FIND BASE OF STACK AREA - SUBI D,(E) - MOVSI C,-3(D) ; PREPARE BLT POINTER - BLT C,C ; HEWITT ATOM AND DECL TO 0,A,B,C - -; NOW PREPEARE TO BLT TUPLE DOWN - - MOVEI D,-3(D) ; NEW DEST - HRLI D,4(D) ; SOURCE - BLT D,-4(TP) ; SLURP THEM DOWN - - HRLI E,TINFO ; SET UP FENCE POST - MOVEM E,-3(TP) ; AND STORE - PUSHJ P,TBTOTP ; GET OFFSET - ADDI D,3 ; FUDGE FOR NOT AT TOP OF STACK - MOVEM D,-2(TP) - MOVEM 0,-1(TP) ; RESTORE HEW ATOM AND DECLS - MOVEM A,(TP) - PUSH TP,B - PUSH TP,C - - PUSHJ P,MAKINF ; MAKE 1ST WORD OF FUNNYS - - HRRZ E,-5(TP) ; RESTORE WORDS OF TUPLE - HRROI B,-5(TP) ; POINT TO TOP OF TUPLE - SUBI B,(E) ; NOW BASE - TLC B,-1(E) ; FIX UP AOBJN PNTR - ADDI E,2 ; COPNESATE FOR FENCE PST - HRLI E,(E) - SUBM TP,E ; E POINT TO BINDING - JRST AUXB4 ; GO CLOBBER IT IN - - -; HERE TO HANDLE SEGMENTS IN THESE FUNNY FORMS - -DTPSEG: PUSH TP,$TFORM ; SAVE THE HACKER - PUSH TP,1(C) - MCALL 1,EVAL ; AND EVALUATE IT - MOVE D,B ; GET READY FOR A SEG LOOP - MOVEM A,DSTO(PVP) - PUSHJ P,TYPSEG ; TYPE AND CHECK IT - -DTPSG1: INTGO ; DONT BLOW YOUR STACK - PUSHJ P,NXTLM ; ELEMENT TO A AND B - JRST DTPSG2 ; DONE - PUSHJ P,CNTARG ; PUSH AND COUNT - JRST DTPSG1 - -DTPSG2: SETZM DSTO(PVP) - JRST DOTUP1 ; REST OF ARGS STILL TO DO - -; HERE TO HACK - -DOITUP: HRRZ C,@(TP) ; GET COUNT FILED - JUMPE C,TUPTFA - MOVEM C,(TP) - PUSHJ P,FASTEV ; EVAL IT - GETYP 0,A - CAIE 0,TFIX - JRST WTY1TP - - JUMPL B,BADNUM - - HRRZ C,@(TP) ; GET EXP TO EVAL - MOVEI 0,0 ; DONT LOSE IN 1 ARG CASE - HRRZ 0,(C) ; VERIFY WINNAGE - JUMPN 0,TUPTMA ; TOO MANY - - JUMPE B,DOIDON - PUSH P,B ; SAVE COUNT - PUSH P,B - JUMPE C,DOILOS - PUSHJ P,FASTEV ; EVAL IT ONCE - MOVEM A,-1(TP) - MOVEM B,(TP) - -DOILP: INTGO - PUSH TP,-1(TP) - PUSH TP,-1(TP) - MCALL 1,EVAL - PUSHJ P,CNTRG - SOSLE (P) - JRST DOILP - -DOIDO1: MOVE B,-1(P) ; RESTORE COUNT - SUB P,[2,,2] - -DOIDON: MOVEI E,(B) - JRST ATUPDN - -; FOR CASE OF NO EVALE - -DOILOS: SUB TP,[2,,2] -DOILLP: INTGO - PUSH TP,[0] - PUSH TP,[0] - SOSL (P) - JRST DOILLP - JRST DOIDO1 - -; ROUTINE TO PUSH NEXT TUPLE ELEMENT - -CNTARG: AOS E,-1(TP) ; KEEP ARG COUNT UP TO DATE IN E -CNTRG: EXCH A,-1(TP) ; STORE ELEM AND GET SAVED - EXCH B,(TP) - PUSH TP,A - PUSH TP,B - POPJ P, - - -; DUMMY TUPLE AND ITUPLE - -MFUNCTION TUPLE,SUBR - - ENTRY - PUSH TP,$TATOM - PUSH TP,EQUOTE NOT-IN-ARG-LIST - JRST CALER1 - -MFUNCTIO ITUPLE,SUBR - JRST TUPLE - - -; PROCESS A DCL IN THE AUX VAR LISTS - -TRYDCL: SKIPN (P) ; SKIP IF NOT IN AUX'S - JRST AUXB7 - CAME B,AS.AUX ; "AUX" ? - CAMN B,AS.EXT ; OR "EXTRA" - JRST AUXB9 ; YES - CAME B,[ASCII /TUPLE/] - JRST AUXB10 - PUSHJ P,MAKINF ; BUILD EMPTY TUPLE - MOVEI B,1(TP) - PUSH TP,$TINFO ; FENCE POST - PUSHJ P,TBTOTP - PUSH TP,D -AUXB6: HRRZ C,(C) ; CDR PAST DCL - MOVEM C,RE.ARG+1(TB) -AUXB8: PUSHJ P,CARTMC ; GET ATOM -AUXB12: PUSHJ P,PSHBND ; UP GOES THE BINDING - PUSH TP,$TATOM ; HIDE HEWITT ATOM AND DCL - PUSH TP,-1(P) - PUSH TP,$TDECL - PUSH TP,-2(P) - MOVE E,TP - JRST AUXB5 - -; CHECK FOR ARGS - -AUXB10: CAME B,[ASCII /ARGS/] - JRST AUXB7 - MOVEI B,0 ; NULL ARG LIST - MOVSI A,TLIST - JRST AUXB6 ; GO BIND - -AUXB9: SETZM (P) ; NOW READING AUX - HRRZ C,(C) - MOVEM C,RE.ARG+1(TB) - JRST AUXB1 - -; CHECK FOR NAME/ACT - -AUXB7: CAME B,AS.NAM - CAMN B,AS.ACT - JRST .+2 - JRST MPD.12 ; LOSER - HRRZ C,(C) ; CDR ON - HRRZ 0,(C) ; BETTER BE END - JUMPN 0,MPD.13 - PUSHJ P,CARTMC ; FORCE ATOM READ - SETZM RE.ARG+1(TB) -AUXB11: PUSHJ P,MAKACT ; MAKE ACTIVATION - JRST AUXB12 ; AND BIND IT - - -; DONE BIND HEWITT ATOM IF NECESARY - -AUXDON: SKIPN E,-2(P) - JRST AUXD1 - SETZM -2(P) - JRST AUXB11 - -; FINISHED, RETURN - -AUXD1: SUB P,[3,,3] - POPJ P, - - -; MAKE AN ACTIVATION OR ENVIRONMNENT - -MAKACT: MOVEI B,(TB) - MOVSI A,TACT -MAKAC1: HRRI A,PVLNT*2+1(PVP) ; POINT TO PROCESS - HLL B,OTBSAV(B) ; GET TIME - POPJ P, - -MAKENV: MOVSI A,TENV - HRRZ B,OTBSAV(TB) - JRST MAKAC1 - -; SEVERAL USEFUL LITTLE ROUTINES FOR HACKING THIS STUFF - -; CARAT/CARATC/CARATM/CARTMC ALL LOOK FOR THE NEXT ATOM - -CARAT: HRRZ C,E.ARGL+1(TB) ; PICK UP ARGLIST -CARATC: JUMPE C,CPOPJ ; FOUND - GETYP 0,(C) ; GET ITS TYPE - CAIE 0,TATOM -CPOPJ: POPJ P, ; RETURN, NOT ATOM - MOVE E,1(C) ; GET ATOM - HRRZ C,(C) ; CDR DCLS - JRST CPOPJ1 - -CARATM: HRRZ C,E.ARGL+1(TB) -CARTMC: PUSHJ P,CARATC - JRST MPD.7 ; REALLY LOSE - POPJ P, - - -; SUBROUTINES TO PUSH BINDINGS ETC. UP ON THE STACK - -PSBND1: PUSHJ P,PSHBND ; PUSH THEBINDING - JRST CHDCL ; NOW CHECK IT AGAINST DECLARATION - -PSHBND: SKIPGE SPCCHK ; SKIP IF NORMAL SPECIAL - PUSH TP,BNDA1 ; ATOM IN E - SKIPL SPCCHK ; SKIP IF NORMAL UNSPEC OR NO CHECK - PUSH TP,BNDA - PUSH TP,E ; PUSH IT -PSHAB4: PUSH TP,A - PUSH TP,B - PUSH TP,[0] - PUSH TP,[0] - POPJ P, - -; ROUTINE TO PUSH 4 0'S - -PSH4ZR: SETZB A,B - JRST PSHAB4 - - -; EXTRRA ARG GOBBLER - -EXTRGT: HRRZ A,E.ARG(TB) ; RESET SLOT - CAIE A,ARGCDR ; IF NOT ARGCDR - TLO A,400000 ; SET FLAG - MOVEM A,E.ARG+1(TB) - MOVE A,E.EXTR(TB) ; RET ARG - MOVE B,E.EXTR+1(TB) - JRST CPOPJ1 - -; CHECK A/B FOR DEFER - -CHKAB: GETYP 0,A - CAIE 0,TDEFER ; SKIP IF DEFER - JRST (E) - MOVE A,(B) - MOVE B,1(B) ; GET REAL THING - JRST (E) -; IF DECLARATIONS EXIST, DO THEM - -CHDCL: MOVE E,TP -CHDCLE: SKIPN C,E.DECL+1(TB) - POPJ P, - JRST CHKDCL - -; ROUTINE TO READ NEXT THING FROM ARGLIST - -NEXTD: HRRZ C,E.ARGL+1(TB) ; GET ARG LIST -NEXTDC: JUMPE C,CPOPJ - PUSHJ P,CARATC ; TRY FOR AN ATOM - JRST NEXTD1 ; NO - MOVEI A,0 ; SET FLAG - JRST CPOPJ1 - -NEXTD1: CAIE 0,TFORM ; FORM? - JRST NXT.L ; COULD BE LIST - PUSHJ P,CHQT ; VERIFY 'ATOM - MOVEI A,1 - JRST CPOPJ1 - -NXT.L: CAIE 0,TLIST ; COULD BE (A ) OR ('A ) - JRST NXT.S ; BETTER BE A DCL - PUSHJ P,LNT.2 ; VERIFY LENGTH IS 2 - JRST MPD.8 - CAIE 0,TATOM ; TYPE OF 1ST RET IN 0 - JRST LST.QT ; MAY BE 'ATOM - MOVE E,1(B) ; GET ATOM - MOVEI A,2 - JRST CPOPJ1 -LST.QT: CAIE 0,TFORM ; FORM? - JRST MPD.9 ; LOSE - PUSH P,C - MOVEI C,(B) ; VERIFY 'ATOM - PUSHJ P,CHQT - MOVEI B,(C) ; POINT BACK TO LIST - POP P,C - MOVEI A,3 ; CODE - JRST CPOPJ1 - -NXT.S: MOVEI A,(C) ; LET NXTDCL FIND OUT - PUSHJ P,NXTDCL - JRST MPD.3 ; LOSER - MOVEI A,4 ; SET DCL READ FLAG - JRST CPOPJ1 - -; ROUTINE TO CHECK LENGTH OF LIST/FORM FOR BEING 2 - -LNT.2: HRRZ B,1(C) ; GET LIST/FORM - JUMPE B,CPOPJ - HRRZ B,(B) - JUMPE B,CPOPJ - HRRZ B,(B) ; BETTER END HERE - JUMPN B,CPOPJ - HRRZ B,1(C) ; LIST BACK - GETYP 0,(B) ; TYPE OF 1ST ELEMENT - JRST CPOPJ1 - -; ROUTINE TO VERIFY FORM IS 'ATOM AND RET ATOM - -CHQT: PUSHJ P,LNT.2 ; 1ST LENGTH CHECK - JRST MPD.5 - CAIE 0,TATOM - JRST MPD.5 - MOVE 0,1(B) - CAME 0,MQUOTE QUOTE - JRST MPD.5 ; BETTER BE QUOTE - HRRZ E,(B) ; CDR - GETYP 0,(E) ; TYPE - CAIE 0,TATOM - JRST MPD.5 - MOVE E,1(E) ; GET QUOTED ATOM - POPJ P, - -; ARG BINDER FOR REGULAR ARGS AND OPTIONALS - -BNDEM1: PUSH P,[0] ; REGULAR FLAG - JRST .+2 -BNDEM2: PUSH P,[1] -BNDEM: PUSHJ P,NEXTD ; GET NEXT THING - JRST CCPOPJ ; END OF THINGS - TRNE A,4 ; CHECK FOR DCL - JRST BNDEM4 - TRNE A,2 ; SKIP IF NOT (ATM ..) OR ('ATM ...) - SKIPE (P) ; SKIP IF REG ARGS - JRST .+2 ; WINNER, GO ON - JRST MPD.6 ; LOSER - SKIPGE SPCCHK - PUSH TP,BNDA1 ; SAVE ATOM - SKIPL SPCCHK - PUSH TP,BNDA - PUSH TP,E - SKIPL E.ARG+1(TB) ; SKIP IF MUST EVAL ARG - TRNN A,1 ; SKIP IF ARG QUOTED - JRST RGLARG - HRRZ D,@E.FRM+1(TB) ; GET AND CDR ARG - JUMPE D,TFACHK ; OH OH MAYBE TOO FEW ARGS - MOVEM D,E.FRM+1(TB) ; STORE WINNER - HLLZ A,(D) ; GET ARG - MOVE B,1(D) - JSP E,CHKAB ; HACK DEFER - JRST BNDEM3 ; AND GO ON - -RGLARG: PUSH P,A ; SAVE FLAGS - PUSHJ P,@E.ARG+1(TB) - JRST TFACH1 ; MAY GE TOO FEW - SUB P,[1,,1] -BNDEM3: HRRZ C,@E.ARGL+1(TB) ; CDR THHE ARGS - MOVEM C,E.ARGL+1(TB) - PUSHJ P,PSHAB4 ; PUSH VALUE AND SLOTS - PUSHJ P,CHDCL ; CHECK DCLS - JRST BNDEM ; AND BIND ON! - -; HERE WHEN ARGS RUN OUT, IF NOT OPTIONAL, GIVE TFA - -TFACH1: POP P,A -TFACHK: SUB TP,[2,,2] ; FLUSH ATOM - SKIPN (P) ; SKIP IF OPTIONALS - JRST TFA -CCPOPJ: SUB P,[1,,1] - POPJ P, - -BNDEM4: HRRZ C,@E.ARGL+1(TB) ; POINT TO REST OF ARGL - JRST CCPOPJ - - -; EVALUATE LISTS, VECTORS, UNIFROM VECTORS - -EVLIST: PUSH P,[-1] ;-1 -- THIS IS A LIST - JRST EVL1 ;GO TO HACKER - -EVECT: PUSH P,[0] ;0 -- THIS IS A GENERAL VECTOR - JRST EVL1 - -EUVEC: PUSH P,[1] ;1 -- THIS IS A UNIFORM VECTOR - -EVL1: PUSH P,[0] ;PUSH A COUNTER - GETYPF A,(AB) ;GET FULL TYPE - PUSH TP,A - PUSH TP,1(AB) ;AND VALUE - -EVL2: INTGO ;CHECK INTERRUPTS - SKIPN A,1(TB) ;ANYMORE - JRST EVL3 ;NO, QUIT - SKIPL -1(P) ;SKIP IF LIST - JUMPG A,EVL3 ;JUMP IF VECTOR EMPTY - GETYPF B,(A) ;GET FULL TYPE - SKIPGE C,-1(P) ;SKIP IF NOT LIST - HLLZS B ;CLOBBER CDR FIELD - JUMPG C,EVL7 ;HACK UNIFORM VECS -EVL8: PUSH P,B ;SAVE TYPE WORD ON P - CAMN B,$TSEG ;SEGMENT? - MOVSI B,TFORM ;FAKE OUT EVAL - PUSH TP,B ;PUSH TYPE - PUSH TP,1(A) ;AND VALUE - JSP E,CHKARG ; CHECK DEFER - MCALL 1,EVAL ;AND EVAL IT - POP P,C ;AND RESTORE REAL TYPE - CAMN C,$TSEG ;SEGMENT? - JRST DOSEG ;YES, HACK IT - AOS (P) ;COUNT ELEMENT - PUSH TP,A ;AND PUSH IT - PUSH TP,B -EVL6: SKIPGE A,-1(P) ;DONT SKIP IF LIST - HRRZ B,@1(TB) ;CDR IT - JUMPL A,ASTOTB ;AND STORE IT - MOVE B,1(TB) ;GET VECTOR POINTER - ADD B,AMNT(A) ;INCR BY APPROPRIATE AMOUNT -ASTOTB: MOVEM B,1(TB) ;AND STORE BACK - JRST EVL2 ;AND LOOP BACK - -AMNT: 2,,2 ;INCR FOR GENERAL VECTOR - 1,,1 ;SAME FOR UNIFORM VECTOR - -CHKARG: GETYP A,-1(TP) - CAIE A,TDEFER - JRST (E) - HRRZS (TP) ;MAKE SURE INDIRECT WINS - MOVE A,@(TP) - MOVEM A,-1(TP) ;CLOBBER IN TYPE SLOT - MOVE A,(TP) ;NOW GET POINTER - MOVE A,1(A) ;GET VALUE - MOVEM A,(TP) ;CLOBBER IN - JRST (E) - - - -EVL7: HLRE C,A ; FIND TYPE OF UVECTOR - SUBM A,C ;C POINTS TO DOPE WORD - GETYP B,(C) ;GET TYPE - MOVSI B,(B) ;TO LH NOW - SOJA A,EVL8 ;AND RETURN TO DO EVAL - -EVL3: SKIPL -1(P) ;SKIP IF LIST - JRST EVL4 ;EITHER VECTOR OR UVECTOR - - MOVEI B,0 ;GET A NIL -EVL9: MOVSI A,TLIST ;MAKE TYPE WIN -EVL5: SOSGE (P) ;COUNT DOWN - JRST EVL10 ;DONE, RETURN - PUSH TP,$TLIST ;SET TO CALL CONS - PUSH TP,B - MCALL 2,CONS - JRST EVL5 ;LOOP TIL DONE - - -EVL4: MOVEI B,EUVECT ;UNIFORM CASE - SKIPG -1(P) ;SKIP IF UNIFORM CASE - MOVEI B,EVECTO ;NO, GENERAL CASE - POP P,A ;GET COUNT - .ACALL A,(B) ;CALL CREATOR -EVL10: GETYPF A,(AB) ; USE SENT TYPE - JRST EFINIS - - -; PROCESS SEGMENTS FOR THESE HACKS - -DOSEG: PUSHJ P,TYPSEG ; FIND WHAT IS BEING SEGMENTED - JUMPE C,LSTSEG ; CHECK END SPLICE IF LIST - -SEG3: PUSHJ P,NXTELM ; GET THE NEXTE ELEMT - JRST SEG4 ; RETURN TO CALLER - AOS (P) ; COUNT - JRST SEG3 ; TRY AGAIN -SEG4: SETZM DSTO(PVP) - JRST EVL6 - -TYPSEG: PUSHJ P,TYPSGR - JRST ILLSEG - POPJ P, - -TYPSGR: MOVEM A,DSTO(PVP) ;WILL BECOME INTERRUPTABLE WITH GOODIE IN D - GETYP A,A ; TYPE TO RH - PUSHJ P,SAT ;GET STORAGE TYPE - MOVE D,B ; GOODIE TO D - - MOVNI C,1 ; C <0 IF ILLEGAL - CAIN A,S2WORD ;LIST? - MOVEI C,0 - CAIN A,S2NWORD ;GENERAL VECTOR? - MOVEI C,1 - CAIN A,SNWORD ;UNIFORM VECTOR? - MOVEI C,2 - CAIN A,SCHSTR - MOVEI C,3 - CAIN A,SSTORE ;SPECIAL AFREE STORAGE ? - MOVEI C,2 ;TREAT LIKE A UVECTOR - CAIN A,SARGS ;ARGS TUPLE? - JRST SEGARG ;NO, ERROR - CAILE A,NUMSAT ; SKIP IF NOT TEMPLATE - JRST SEGTMP - JUMPGE C,CPOPJ1 - SETZM DSTO(PVP) ; DON'T CONFUSE AGC LATER! - POPJ P, - -SEGTMP: MOVEI C,4 - HRRM A,DSTO(PVP) ; SAVE FOR HACKERS - JRST CPOPJ1 - -SEGARG: PUSH TP,DSTO(PVP) ;PREPARE TO CHECK ARGS - PUSH TP,D - SETZM DSTO(PVP) ;TYPE NOT SPECIAL - MOVEI B,-1(TP) ;POINT TO SAVED COPY - PUSHJ P,CHARGS ;CHECK ARG POINTER - POP TP,D ;AND RESTORE WINNER - POP TP,DSTO(PVP) ;AND TYPE AND FALL INTO VECTOR CODE - MOVEI C,1 - JRST CPOPJ1 - -LSTSEG: SKIPL -1(P) ;SKIP IF IN A LIST - JRST SEG3 ;ELSE JOIN COMMON CODE - HRRZ A,@1(TB) ;CHECK FOR END OF LIST - JUMPN A,SEG3 ;NO, JOIN COMMON CODE - SETZM DSTO(PVP) ;CLOBBER SAVED GOODIES - JRST EVL9 ;AND FINISH UP - -NXTELM: INTGO - PUSHJ P,NXTLM ; GOODIE TO A AND B - POPJ P, ; DONE - PUSH TP,A - PUSH TP,B - JRST CPOPJ1 -NXTLM: XCT TESTR(C) ; SKIP IF MORE IN SEGEMNT - POPJ P, - XCT TYPG(C) ; GET THE TYPE - XCT VALG(C) ; AND VALUE - JSP E,CHKAB ; CHECK DEFERRED - XCT INCR1(C) ; AND INCREMENT TO NEXT -CPOPJ1: AOS (P) ; SKIP RETURN - POPJ P, - -; TABLES FOR SEGMENT OPERATIONS (0->LIST, 1->VECTOR/ARGS, 2->UVEC, 3->STRING) - -TESTR: SKIPN D - SKIPL D - SKIPL D - PUSHJ P,CHRDON - PUSHJ P,TM1 - -TYPG: PUSHJ P,LISTYP - GETYPF A,(D) - PUSHJ P,UTYPE - MOVSI A,TCHRS - PUSHJ P,TM2 - -VALG: MOVE B,1(D) - MOVE B,1(D) - MOVE B,(D) - PUSHJ P,1CHGT - PUSHJ P,TM3 - -INCR1: HRRZ D,(D) - ADD D,[2,,2] - ADD D,[1,,1] - PUSHJ P,1CHINC - ADD D,[1,,] - -TM1: HRRZ A,DSTO(PVP) ; GET SAT - SUBI A,NUMSAT+1 - ADD A,TD.LNT+1(TVP) - EXCH C,D - XCT (A) - HLRZ 0,C ; GET AMNT RESTED - SUB B,0 - EXCH C,D - TRNE B,-1 - AOS (P) - POPJ P, - -TM3: -TM2: HRRZ 0,DSTO(PVP) - PUSH P,C - PUSH P,D - PUSH P,E - MOVE B,D - MOVEI C,0 ; GET "1ST ELEMENT" - PUSHJ P,TMPLNT ; GET NTH IN A AND B - POP P,E - POP P,D - POP P,C - POPJ P, - - -CHRDON: HRRZ B,DSTO(PVP) ; POIT TO DOPE WORD - JUMPE B,CHRFIN - AOS (P) -CHRFIN: POPJ P, - -LISTYP: GETYP A,(D) - MOVSI A,(A) - POPJ P, -1CHGT: MOVE B,D - ILDB B,B - POPJ P, - -1CHINC: SOS DSTO(PVP) - IBP D - POPJ P, - -UTYPE: HLRE A,D - SUBM D,A - GETYP A,(A) - MOVSI A,(A) - POPJ P, - - -;COMPILER's CALL TO DOSEG -SEGMNT: PUSHJ P,TYPSEG -SEGLP1: SETZB A,B -SEGLOP: PUSHJ P,NXTELM - JRST SEGRET - AOS (P)-2 ; INCREMENT COMPILER'S COUNT - JRST SEGLOP - -SEGRET: SETZM DSTO(PVP) - POPJ P, - -SEGLST: PUSHJ P,TYPSEG - JUMPN C,SEGLS2 -SEGLS3: SETZM DSTO(PVP) - MOVSI A,TLIST -SEGLS1: SOSGE -2(P) ; START COUNT DOWN - POPJ P, - MOVEI E,(B) - POP TP,D - POP TP,C - PUSHJ P,ICONS - JRST SEGLS1 - -SEGLS2: PUSHJ P,NXTELM - JRST SEGLS4 - AOS -2(P) - JRST SEGLS2 - -SEGLS4: MOVEI B,0 - JRST SEGLS3 - - -;SPECBIND BINDS IDENTIFIERS. IT IS CALLED BY PUSHJ P,SPECBIND. -;SPECBIND IS PROVIDED WITH A CONTIGUOUS SET OF TRIPLETS ON TP. -;EACH TRIPLET IS AS FOLLOWS: -;THE FIRST ELEMENT IS THE IDENTIFIER TO BE BOUND, ITS TYPE WORD IS [TATOM,,-1], -;THE SECOND IS THE VALUE TO WHICH IT IS TO BE ASSIGNED, -;AND THE THIRD IS A PAIR OF ZEROES. - -BNDA1: TATOM,,-2 -BNDA: TATOM,,-1 -BNDV: TVEC,,-1 - -USPECBIND: - MOVE E,TP -USPCBE: PUSH P,$TUBIND - JRST .+3 - -SPECBIND: - MOVE E,TP ;GET THE POINTER TO TOP -SPECBE: PUSH P,$TBIND - ADD E,[1,,1] ;BUMP POINTER ONCE - SETZB 0,D ;CLEAR TEMPS - PUSH P,0 - MOVEI 0,(TB) ; FOR CHECKS - -BINDLP: MOVE A,-4(E) ; CHECK FOR VEC BIND - CAMN A,BNDV - JRST NONID - MOVE A,-6(E) ;GET TYPE - CAME A,BNDA1 ; FOR UNSPECIAL - CAMN A,BNDA ;NORMAL ID BIND? - CAILE 0,-6(E) ; MAKE SURE NOT GOING UNDER FRAME - JRST SPECBD - SUB E,[6,,6] ;MOVE PTR - SKIPE D ;LINK? - HRRM E,(D) ;YES -- LOBBER - SKIPN (P) ;UPDATED? - MOVEM E,(P) ;NO -- DO IT - - MOVE A,0(E) ;GET ATOM PTR - MOVE B,1(E) - PUSHJ P,ILOC ;GET LAST BINDING - MOVS A,OTBSAV (TB) ;GET TIME - HRL A,5(E) ; GET DECL POINTER - MOVEM A,4(E) ;CLOBBER IT AWAY - MOVE A,(E) ; SEE IF SPEC/UNSPEC - TRNN A,1 ; SKIP, ALWAYS SPEC - SKIPA A,-1(P) ; USE SUPPLIED - MOVSI A,TBIND - MOVEM A,(E) ;IDENTIFY AS BIND BLOCK - HRRZ C,SPBASE(PVP) ; CHECK FOR CROSS OF PROC - MOVEI A,(TP) - CAIL A,(B) ; LOSER - CAILE C,(B) ; SKIP IFF WINNER - JRST .+2 - MOVEM B,5(E) ;IN RESTORE CELLS - - MOVE C,1(E) ;GET ATOM PTR - MOVEI A,(C) - MOVEI B,0 ; FOR SPCUNP - CAIL A,HIBOT ; SKIP IF IMPURE ATOM - PUSHJ P,SPCUNP - HRRZ A,BINDID+1(PVP) ;GET PROCESS NUMBER - HRLI A,TLOCI ;MAKE LOC PTR - MOVE B,E ;TO NEW VALUE - ADD B,[2,,2] - MOVEM A,(C) ;CLOBBER ITS VALUE - MOVEM B,1(C) ;CELL - MOVE D,E ;REMEMBER LINK - JRST BINDLP ;DO NEXT - -NONID: CAILE 0,-4(E) - JRST SPECBD - SUB E,[4,,4] - SKIPE D - HRRM E,(D) - SKIPN (P) - MOVEM E,(P) - - MOVE D,1(E) ;GET PTR TO VECTOR - MOVE C,(D) ;EXCHANGE TYPES - EXCH C,2(E) - MOVEM C,(D) - - MOVE C,1(D) ;EXCHANGE DATUMS - EXCH C,3(E) - MOVEM C,1(D) - - MOVEI A,TBVL - HRLM A,(E) ;IDENTIFY BIND BLOCK - MOVE D,E ;REMEMBER LINK - JRST BINDLP - -SPECBD: SKIPE D - HRRM SP,(D) - SKIPE D,(P) - MOVE SP,D - SUB P,[2,,2] - POPJ P, - - -; HERE TO IMPURIFY THE ATOM - -SPCUNP: PUSH TP,$TSP - PUSH TP,E - PUSH TP,$TSP - PUSH TP,-1(P) ; LINK BACK IS AN SP - PUSH TP,$TSP - PUSH TP,B - MOVE B,C - PUSHJ P,IMPURIFY - MOVE 0,-2(TP) ; RESTORE LINK BACK POINTER - MOVEM 0,-1(P) - MOVE E,-4(TP) - MOVE C,B - MOVE B,(TP) - SUB TP,[6,,6] - MOVEI 0,(TB) - POPJ P, - -; ENTRY FROM COMPILER TO SET UP A BINDING - -IBIND: SUBI E,-5(SP) ; CHANGE TO PDL POINTER - HRLI E,(E) - ADD E,SP - MOVEM C,-4(E) - MOVEM A,-3(E) - MOVEM B,-2(E) - HRLOI A,TATOM - MOVEM A,-5(E) - MOVSI A,TLIST - MOVEM A,-1(E) - MOVEM D,(E) - JRST SPECB1 ; NOW BIND IT - -; "FAST CALL TO SPECBIND" - - - -; Compiler's call to SPECBIND all atom bindings, no TBVLs etc. - -SPECBND: - MOVE E,TP ; POINT TO BINDING WITH E -SPECB1: PUSH P,[0] ; SLOTS OF INTEREST - PUSH P,[0] - SUBM M,-2(P) - -SPECB2: MOVEI 0,(TB) ; FOR FRAME CHECK - MOVE A,-5(E) ; LOOK AT FIRST THING - CAMN A,BNDA ; SKIP IF LOSER - CAILE 0,-5(E) ; SKIP IF REAL WINNER - JRST SPECB3 - - SUB E,[5,,5] ; POINT TO BINDING - SKIPE A,(P) ; LINK? - HRRM E,(A) ; YES DO IT - SKIPN -1(P) ; FIRST ONE? - MOVEM E,-1(P) ; THIS IS IT - - MOVE A,1(E) ; POINT TO ATOM - MOVE 0,BINDID+1(PVP) ; QUICK CHECK - HRLI 0,TLOCI - CAMN 0,(A) ; WINNERE? - JRST SPECB4 ; YES, GO ON - - PUSH P,B ; SAVE REST OF ACS - PUSH P,C - PUSH P,D - MOVE B,A ; FOR ILOC TO WORK - PUSHJ P,ILOC ; GO LOOK IT UP - HRRZ C,SPBASE+1(PVP) - MOVEI A,(TP) - CAIL A,(B) ; SKIP IF LOSER - CAILE C,(B) ; SKIP IF WINNER - MOVEI B,0 ; SAY NO BACK POINTER - MOVE C,1(E) ; POINT TO ATOM - MOVEI A,(C) ; PURE ATOM? - CAIGE A,HIBOT ; SKIP IF OK - JRST .+4 - PUSH P,-4(P) ; MAKE HAPPINESS - PUSHJ P,SPCUNP ; IMPURIFY - POP P,-5(P) - MOVE A,BINDID+1(PVP) - HRLI A,TLOCI - MOVEM A,(C) ; STOR POINTER INDICATOR - MOVE A,B - POP P,D - POP P,C - POP P,B - JRST SPECB5 - -SPECB4: MOVE A,1(A) ; GET LOCATIVE -SPECB5: EXCH A,5(E) ; CLOBBER INTO REBIND SLOT (GET DECL) - HLL A,OTBSAV(TB) ; TIME IT - MOVSM A,4(E) ; SAVE DECL AND TIME - MOVEI A,TBIND - HRLM A,(E) ; CHANGE TO A BINDING - MOVE A,1(E) ; POINT TO ATOM - MOVEM E,(P) ; REMEMBER THIS GUY - ADD E,[2,,2] ; POINT TO VAL CELL - MOVEM E,1(A) ; INTO ATOM SLOT - SUB E,[3,,3] ; POINT TO NEXT ONE - JRST SPECB2 - -SPECB3: SKIPE A,(P) - HRRM SP,(A) ; LINK OLD STUFF - SKIPE A,-1(P) ; NEW SP? - MOVE SP,A - SUB P,[2,,2] - INTGO ; IN CASE BLEW STACK - SUBM M,(P) - POPJ P, - - -;SPECSTORE RESTORES THE BINDINGS SP TO THE ENVIRONMENT POINTER IN -;SPSAV (TB). IT IS CALLED BY PUSHJ P,SPECSTORE. - -SPECSTORE: - PUSH P,E - HRRZ E,SPSAV (TB) ;GET TARGET POINTER - PUSHJ P,STLOOP - POP P,E - MOVE SP,SPSAV(TB) ; GET NEW SP - POPJ P, - -STLOOP: PUSH P,D - PUSH P,C - -STLOO1: CAIL E,(SP) ;ARE WE DONE? - JRST STLOO2 - HLRZ C,(SP) ;GET TYPE OF BIND - CAIN C,TUBIND - JRST .+3 - CAIE C,TBIND ;NORMAL IDENTIFIER? - JRST ISTORE ;NO -- SPECIAL HACK - - - MOVE C,1(SP) ;GET TOP ATOM - MOVSI 0,TLOCI ; MAYBE LOCI OR UNBOUND - SKIPN D,5(SP) - MOVSI 0,TUNBOU - - HRR 0,BINDID+1(PVP) ;STORE SIGNATURE - MOVEM 0,(C) ;CLOBBER INTO ATOM - MOVEM D,1(C) - SETZM 4(SP) -SPLP: HRRZ SP,(SP) ;FOLOW LINK - JUMPN SP,STLOO1 ;IF MORE - SKIPE E ; OK IF E=0 - FATAL SP OVERPOP -STLOO2: POP P,C - POP P,D - POPJ P, - -ISTORE: CAIE C,TBVL - JRST CHSKIP - MOVE C,1(SP) - MOVE D,2(SP) - MOVEM D,(C) - MOVE D,3(SP) - MOVEM D,1(C) - JRST SPLP - -CHSKIP: CAIN C,TSKIP - JRST SPLP - CAIE C,TUNWIN ; UNWIND HACK - FATAL BAD SP - HRRZ C,-2(P) ; WHERE FROM? - CAIE C,CHUNPC - JRST SPLP ; IGNORE - MOVEI E,(TP) ; FIXUP SP - SUBI E,(SP) - MOVSI E,(E) - HLL SP,TP - SUB SP,E - POP P,C - POP P,D - AOS (P) - POPJ P, - -; ENTRY FOR FUNNY COMPILER UNBIND (1) - -SSPECS: PUSH P,E - MOVEI E,(TP) - PUSHJ P,STLOOP -SSPEC2: SUBI E,(SP) ; MAKE SP BE AOBJN - MOVSI E,(E) - HLL SP,TP - SUB SP,E - POP P,E - POPJ P, - -; ENTRY FOR FUNNY COMPILER UNBIND (2) - -SSPEC1: PUSH P,E - SUBI E,1 ; MAKE SURE GET CURRENT BINDING - PUSHJ P,STLOOP ; UNBIND - MOVEI E,(TP) ; NOW RESET SP - JRST SSPEC2 - EFINIS: SKIPN C,1STEPR+1(PVP) ; SKIP NIF BEING ONE PROCEEDED - JRST FINIS - PUSH TP,$TATOM - PUSH TP,MQUOTE EVLOUT - PUSH TP,A ;SAVE EVAL RESULTS - PUSH TP,B - PUSH TP,[TINFO,,2] ; FENCE POST - PUSHJ P,TBTOTP - PUSH TP,D - PUSHJ P,MAKINF ; MAKE ARG BLOCK INFO - PUSH TP,A - MOVEI B,-6(TP) - HRLI B,-4 ; AOBJN TO ARGS BLOCK - PUSH TP,B - PUSH TP,1STEPR(PVP) - PUSH TP,1STEPR+1(PVP) ; PROCESS DOING THE 1STEPPING - MCALL 2,RESUME - MOVE A,-3(TP) ; GET BACK EVAL VALUE - MOVE B,-2(TP) - JRST FINIS - -1STEPI: PUSH TP,$TATOM - PUSH TP,MQUOTE EVLIN - PUSH TP,$TAB ; PUSH EVALS ARGGS - PUSH TP,AB - PUSHJ P,MAKINF ; TURN INTO ARGS BLOCK - MOVEM A,-1(TP) ; AND CLOBBER - PUSH TP,[TINFO,,2] ; FENCE POST 2D TUPLE - PUSHJ P,TBTOTP - PUSH TP,D - PUSHJ P,MAKINF ; TURN IT INTO ARGS BLOCK - PUSH TP,A - MOVEI B,-6(TP) ; SETUP TUPLE - HRLI B,-4 - PUSH TP,B - PUSH TP,1STEPR(PVP) - PUSH TP,1STEPR+1(PVP) - MCALL 2,RESUME ; START UP 1STEPERR - SUB TP,[6,,6] ; REMOVE CRUD - GETYP A,A ; GET 1STEPPERS TYPE - CAIE A,TDISMI ; IF DISMISS, STOP 1 STEPPING - JRST EVALON - -; HERE TO PUSH DOWN THE 1 STEP STATE AND RUN - - MOVE D,PVP - ADD D,[1STEPR,,1STEPR] ; POINT TO 1 STEP SLOT - PUSH TP,$TSP ; SAVE CURRENT SP - PUSH TP,SP - PUSH TP,BNDV - PUSH TP,D ; BIND IT - PUSH TP,$TPVP - PUSH TP,[0] ; NO 1 STEPPER UNTIL POPJ - PUSHJ P,SPECBIND - -; NOW PUSH THE ARGS UP TO RE-CALL EVAL - - MOVEI A,0 -EFARGL: JUMPGE AB,EFCALL - PUSH TP,(AB) - PUSH TP,1(AB) - ADD AB,[2,,2] - AOJA A,EFARGL - -EFCALL: ACALL A,EVAL ; NOW DO THE EVAL - MOVE C,(TP) ; PRE-UNBIND - MOVEM C,1STEPR+1(PVP) - MOVE SP,-4(TP) ; AVOID THE UNBIND - SUB TP,[6,,6] ; AND FLUSH LOSERS - JRST EFINIS ; AND TRY TO FINISH UP - -MAKINF: HLRZ A,OTBSAV(TB) ; TIME IT - HRLI A,TARGS - POPJ P, - - -TBTOTP: MOVEI D,(TB) ; COMPUTE REL DIST FROM TP TO TB - SUBI D,(TP) - POPJ P, -; ARRIVE HERE TO COMPLETE A COMPILER GENERATED TUPLE -; D/ LENGTH OF THE TUPLE IN WORDS - -MAKTU2: MOVE D,-1(P) ; GET LENGTH -MAKTUP: HRLI D,TINFO ; FIRST WORD OF FENCE POST - PUSH TP,D - HRROI B,(TP) ; TOP OF TUPLE - SUBI B,(D) - TLC B,-1(D) ; AOBJN IT - PUSHJ P,TBTOTP - PUSH TP,D - HLRZ A,OTBSAV(TB) ; TIME IT - HRLI A,TARGS - POPJ P, - -; HERE TO ALLOCATE SLOTS FOR COMPILER (AMNT IN A) - -TPALOC: HRLI A,(A) - ADD TP,A - SKIPL TP - PUSHJ P,TPOVFL ; IN CASE IT LOST - INTGO ; TAKE THE GC IF NEC - PUSH P,A - HRRI A,2(TP) - SUB A,(P) - SETZM -1(A) - HRLI A,-1(A) - BLT A,(TP) - SUB P,[1,,1] - POPJ P, - -NTPALO: PUSH TP,[0] - SOJG 0,.-1 - POPJ P, - - ;EVALUATES A IDENTIFIER -- GETS LOCAL VALUE IF THERE IS ONE, OTHERWISE GLOBAL. - -MFUNCTION VALUE,SUBR - JSP E,CHKAT - PUSHJ P,IDVAL - JRST FINIS - -IDVAL: PUSHJ P,IDVAL1 - CAMN A,$TUNBOU - JRST UNBOU - POPJ P, - -IDVAL1: PUSH TP,A - PUSH TP,B ;SAVE ARG IN CASE NEED TO CHECK GLOBAL VALUE - PUSHJ P,ILVAL ;LOCAL VALUE FINDER - CAME A,$TUNBOUND ;IF NOT UNBOUND OR UNASSIGNED - JRST RIDVAL ;DONE - CLEAN UP AND RETURN - POP TP,B ;GET ARG BACK - POP TP,A - JRST IGVAL -RIDVAL: SUB TP,[2,,2] - POPJ P, - -;GETS THE LOCAL VALUE OF AN IDENTIFIER - -MFUNCTION LVAL,SUBR - JSP E,CHKAT - PUSHJ P,AILVAL - CAME A,$TUNBOUND - JRST FINIS - JUMPN B,UNAS - JRST UNBOU - -; MAKE AN ATOM UNASSIGNED - -MFUNCTION UNASSIGN,SUBR - JSP E,CHKAT ; GET ATOM ARG - PUSHJ P,AILOC -UNASIT: CAMN A,$TUNBOU ; IF UNBOUND - JRST RETATM - MOVSI A,TUNBOU - MOVEM A,(B) - SETOM 1(B) ; MAKE SURE -RETATM: MOVE B,1(AB) - MOVE A,(AB) - JRST FINIS - -; UNASSIGN GLOBALLY - -MFUNCTION GUNASSIGN,SUBR - JSP E,CHKAT2 - PUSHJ P,IGLOC - CAMN A,$TUNBOU - JRST RETATM - MOVE B,1(AB) ; ATOM BACK - MOVEI 0,(B) - CAIL 0,HIBOT ; SKIP IF IMPURE - PUSHJ P,IMPURIFY ; YES, MAKE IT IMPURE - PUSHJ P,IGLOC ; RESTORE LOCATIVE - HRRZ 0,-2(B) ; SEE IF MANIFEST - GETYP A,(B) ; AND CURRENT TYPE - CAIN 0,-1 - CAIN A,TUNBOU - JRST UNASIT - SKIPE IGDECL - JRST UNASIT - MOVE D,B - JRST MANILO - -; GETS A LOCATIVE TO THE LOCAL VALUE OF AN IDENTIFIER. - -MFUNCTION LLOC,SUBR - JSP E,CHKAT - PUSHJ P,AILOC - CAMN A,$TUNBOUND - JRST UNBOU - MOVSI A,TLOCD - HRR A,2(B) - JRST FINIS - -;TESTS TO SEE IF AN IDENTIFIER IS LOCALLY BOUND - -MFUNCTION BOUND,SUBR,[BOUND?] - JSP E,CHKAT - PUSHJ P,AILVAL - CAMN A,$TUNBOUND - JUMPE B,IFALSE - JRST TRUTH - -;TESTS TO SEE IF AN IDENTIFIER IS LOCALLY ASSIGNED - -MFUNCTION ASSIGP,SUBR,[ASSIGNED?] - JSP E,CHKAT - PUSHJ P,AILVAL - CAME A,$TUNBOUND - JRST TRUTH -; JUMPE B,UNBOU - JRST IFALSE - -;GETS THE GLOBAL VALUE OF AN IDENTIFIER - -MFUNCTION GVAL,SUBR - JSP E,CHKAT2 - PUSHJ P,IGVAL - CAMN A,$TUNBOUND - JRST UNAS - JRST FINIS - -;GETS A LOCATIVE TO THE GLOBAL VALUE OF AN IDENTIFIER - -MFUNCTION GLOC,SUBR - - JUMPGE AB,TFA - CAMGE AB,[-5,,] - JRST TMA - JSP E,CHKAT1 - MOVEI E,IGLOC - CAML AB,[-2,,] - JRST .+4 - GETYP 0,2(AB) - CAIE 0,TFALSE - MOVEI E,IIGLOC - PUSHJ P,(E) - CAMN A,$TUNBOUND - JRST UNAS - MOVSI A,TLOCD - MOVE C,1(AB) ; GE ATOM - MOVEI 0,(C) - CAIGE 0,HIBOT ; SKIP IF PURE ATOM - JRST FINIS - -; MAKE ATOM AND VALUE IMPURE IF GETTING GLOC TO IT - - MOVE B,C ; ATOM TO B - PUSHJ P,IMPURIFY - JRST GLOC ; AND TRY AGAIN - -;TESTS TO SEE IF AN IDENTIFIER IS GLOBALLY ASSIGNED - -MFUNCTION GASSIG,SUBR,[GASSIGNED?] - JSP E,CHKAT2 - PUSHJ P,IGVAL - CAMN A,$TUNBOUND - JRST IFALSE - JRST TRUTH - -; TEST FOR GLOBALLY BOUND - -MFUNCTION GBOUND,SUBR,[GBOUND?] - - JSP E,CHKAT2 - PUSHJ P,IGLOC - JUMPE B,IFALSE - JRST TRUTH - - - -CHKAT2: ENTRY 1 -CHKAT1: GETYP A,(AB) - MOVSI A,(A) - CAME A,$TATOM - JRST NONATM - MOVE B,1(AB) - JRST 2,(E) - -CHKAT: HLRE A,AB ; - # OF ARGS - ASH A,-1 ; TO ACTUAL WORDS - JUMPGE AB,TFA - MOVE C,SP ; FOR BINDING LOOKUPS - AOJE A,CHKAT1 ; ONLY ONE ARG, NO ENVIRONMENT - AOJL A,TMA ; TOO MANY - GETYP A,2(AB) ; MAKE SURE OF TENV OR TFRAME - CAIE A,TFRAME - CAIN A,TENV - JRST CHKAT3 - CAIN A,TACT ; FOR PFISTERS LOSSAGE - JRST CHKAT3 - CAIE A,TPVP ; OR PROCESS - JRST WTYP2 - MOVE B,3(AB) ; GET PROCESS - MOVE C,SP ; IN CASE ITS ME - CAME B,PVP ; SKIP IF DIFFERENT - MOVE C,SPSTO+1(B) ; GET ITS SP - JRST CHKAT1 -CHKAT3: MOVEI B,2(AB) ; POINT TO FRAME POINTER - PUSHJ P,CHFRM ; VALIDITY CHECK - MOVE B,3(AB) ; GET TB FROM FRAME - MOVE C,SPSAV(B) ; GET ENVIRONMENT POINTER - JRST CHKAT1 - - - -;ILOC RETURNS IN A AND B A LOCATIVE TO THE LOCAL VALUE OF THE IDENTIFIER PASSED TO IT -;IN A AND B. IF THE IDENTIFIER IS LOCALLY UNBOUND IT RETURNS $TUNBOUND IN A AND 0 IN B, -; IT IS CALLED BY PUSHJ P,ILOC. - -ILOC: MOVE C,SP ; SETUP SEARCH START -AILOC: MOVSI A,TLOCI ;MAKE A LOCATIVE TYPE CELL - PUSH P,E - PUSH P,D - MOVEI E,0 ; FLAG TO CLOBBER ATOM - JUMPE B,SCHSP ; IF LOOKING FOR SLOT, SEARCH NOW - CAME C,SP ; ENVIRONMENT CHANGE? - JRST SCHSP ; YES, MUST SEARCH - HRR A,BINDID+1(PVP) ;FOR THE CURRENT PROCESS - CAME A,(B) ;IS THERE ONE IN THE VALUE CELL? - JRST SCHLP ;NO -- SEARCH THE LOCAL BINDINGS - MOVE B,1(B) ;YES -- GET LOCATIVE POINTER - MOVE C,PVP -ILCPJ: MOVE E,SPCCHK - TRNN E,1 ; SKIP IF DOING SPEC UNSPEC CHECK - JRST ILOCPJ - HLRZ E,-2(B) - CAIE E,TUBIND - JRST ILOCPJ - CAMGE B,CURFCN+1(PVP) - JRST UNPJ11 - MOVEI D,-2(B) - CAIG D,(SP) - CAMGE B,SPBASE+1(PVP) - JRST UNPJ11 -ILOCPJ: POP P,D - POP P,E - POPJ P, ;FROM THE VALUE CELL - -SCHLP: MOVEI D,(B) - CAIL D,HIBOT ; SKIP IF IMPURE ATOM -SCHSP: MOVEI E,1 ; DONT STORE LOCATIVE - - PUSH P,E ; PUSH SWITCH - MOVE E,PVP ; GET PROC -SCHLP1: JUMPE C,UNPJ ;IF NO MORE -- LOSE - CAMN B,1(C) ;ARE WE POINTING AT THE WINNER? - JRST SCHFND ;YES - GETYP D,(C) ; CHECK SKIP - CAIE D,TSKIP - JRST SCHLP2 - PUSH P,B ; CHECK DETOUR - MOVEI B,2(C) - PUSHJ P,CHFRAM ; NON-FATAL FRAME CHECKER - HRRZ E,2(C) ; CONS UP PROCESS - SUBI E,PVLNT*2+1 - HRLI E,-2*PVLNT - JUMPE B,SCHLP3 ; LOSER, FIX IT - POP P,B - MOVEI C,1(C) ; FOLLOW LOOKUP CHAIN -SCHLP2: HRRZ C,(C) ;FOLLOW LINK - JRST SCHLP1 - -SCHLP3: POP P,B - MOVEI C,(SP) ; *** NDR'S BUG *** - CAME E,PVP ; USE IF CURRENT PROCESS - HRRZ C,SPSTO+1(E) ; USE CURRENT SP FOR PROC - JRST SCHLP1 - -SCHFND: EXCH B,C ;SAVE THE ATOM PTR IN C - MOVEI B,2(B) ;MAKE UP THE LOCATIVE - SUB B,TPBASE+1(E) - HRLI B,(B) - ADD B,TPBASE+1(E) - EXCH C,E ; RET PROCESS IN C - POP P,D ; RESTORE SWITCH - - JUMPN D,ILOCPJ ; DONT CLOBBER ATOM - MOVEM A,(E) ;CLOBBER IT AWAY INTO THE - MOVEM B,1(E) ;ATOM'S VALUE CELL - JRST ILCPJ - -UNPJ: SUB P,[1,,1] ; FLUSH CRUFT -UNPJ1: MOVE C,E ; RET PROCESS ANYWAY -UNPJ11: POP P,D - POP P,E -UNPOPJ: MOVSI A,TUNBOUND - MOVEI B,0 - POPJ P, - -;IGLOC RETURNS IN A AND B A LOCATIVE TO THE GLOBAL VALUE OF THE -;IDENTIFIER PASSED TO IT IN A AND B. IF THE IDENTIFIER IS GLOBALLY -;UNBPOUND IT RETURNS $TUNBOUND IN A AND 0 IN B. IT IS CALLED BY PUSHJ P,IGLOC. - - -IGLOC: MOVSI A,TLOCI ;DO WE HAVE A LOCATIVE TO - CAME A,(B) ;A PROCESS #0 VALUE? - JRST SCHGSP ;NO -- SEARCH - MOVE B,1(B) ;YES -- GET VALUE CELL - POPJ P, - -SCHGSP: MOVE D,GLOBSP+1(TVP) ;GET GLOBAL SP PTR - -SCHG1: JUMPGE D,UNPOPJ ;IF NO MORE, LEAVE - CAMN B,1(D) ;ARE WE FOUND? - JRST GLOCFOUND ;YES - ADD D,[4,,4] ;NO -- TRY NEXT - JRST SCHG1 - -GLOCFOUND: - EXCH B,D ;SAVE ATOM PTR - ADD B,[2,,2] ;MAKE LOCATIVE - MOVEI 0,(D) - CAIL 0,HIBOT - POPJ P, - MOVEM A,(D) ;CLOBBER IT AWAY - MOVEM B,1(D) - POPJ P, - -IIGLOC: PUSH TP,$TATOM - PUSH TP,B - PUSHJ P,IGLOC - MOVE C,(TP) - SUB TP,[2,,2] - GETYP 0,A - CAIE 0,TUNBOU - POPJ P, - PUSH TP,$TATOM - PUSH TP,C - PUSHJ P,BSETG ; MAKE A SLOT - SETOM 1(B) ; UNBOUNDIFY IT - MOVSI A,TLOCD - MOVSI 0,TUNBOU - MOVEM 0,(B) - SUB TP,[2,,2] - POPJ P, - - - -;ILVAL RETURNS IN A AND B THE LOCAL VALUE OF THE IDENTIFIER PASSED TO IT IN A AND B -;IF THE IDENTIFIER IS UNBOUND ITS VALUE IS $TUNBOUND IN A AND 0 IN B. IF -;IT IS UNASSIGNED ITS VALUE IS $TUNBOUND IN A AND -1 IN B. CALL - PUSHJ P,IVAL - -AILVAL: - PUSHJ P,AILOC ; USE SUPPLIED SP - JRST CHVAL -ILVAL: - PUSHJ P,ILOC ;GET LOCATIVE TO VALUE -CHVAL: CAMN A,$TUNBOUND ;BOUND - POPJ P, ;NO -- RETURN - MOVSI A,TLOCD ; GET GOOD TYPE - HRR A,2(B) ; SHOULD BE TIME OR 0 - PUSH P,0 - PUSHJ P,RMONC0 ; CHECK READ MONITOR - POP P,0 - MOVE A,(B) ;GET THE TYPE OF THE VALUE - MOVE B,1(B) ;GET DATUM - POPJ P, - -;IGVAL -- LIKE ILVAL EXCEPT FOR GLOBAL VALUES - -IGVAL: PUSHJ P,IGLOC - JRST CHVAL - - - -; COMPILERS INTERFACE TO LVAL/GVAL/SETG/SET - -CILVAL: MOVE 0,BINDID+1(PVP) ; CURRENT BIND - HRLI 0,TLOCI - CAME 0,(B) ; HURRAY FOR SPEED - JRST CILVA1 ; TOO BAD - MOVE C,1(B) ; POINTER - MOVE A,(C) ; VAL TYPE - TLNE A,.RDMON ; MONITORS? - JRST CILVA1 - GETYP 0,A - CAIN 0,TUNBOU - JRST CUNAS ; COMPILER ERROR - MOVE B,1(C) ; GOT VAL - MOVE 0,SPCCHK - TRNN 0,1 - POPJ P, - HLRZ 0,-2(C) ; SPECIAL CHECK - CAIE 0,TUBIND - POPJ P, ; RETURN - CAMGE C,CURFCN+1(PVP) - JRST CUNAS - POPJ P, - -CUNAS: -CILVA1: SUBM M,(P) ; FIX (P) - PUSH TP,$TATOM ; SAVE ATOM - PUSH TP,B - MCALL 1,LVAL ; GET ERROR/MONITOR -MPOPJ: -POPJM: SUBM M,(P) ; REPAIR DAMAGE - POPJ P, - -; COMPILERS INTERFACE TO SET C/ ATOM A,B/ NEW VALUE - -CISET: MOVE 0,BINDID+1(PVP) ; CURRENT BINDING ENVIRONMENT - HRLI 0,TLOCI - CAME 0,(C) ; CAN WE WIN? - JRST CISET1 ; NO, MORE HAIR - MOVE D,1(C) ; POINT TO SLOT - HLLZ 0,(D) ; MON CHECK -CISET3: TLNE 0,.WRMON - JRST CISET4 ; YES, LOSE - TLZ 0,TYPMSK - IOR A,0 ; LEAVE MONITOR ON - MOVE 0,SPCCHK - TRNE 0,1 - JRST CISET5 ; SPEC/UNSPEC CHECK -CISET6: MOVEM A,(D) ; STORE - MOVEM B,1(D) - POPJ P, - -CISET5: HLRZ 0,-2(D) - CAIE 0,TUBIND - JRST CISET6 - CAMGE D,CURFCN+1(PVP) - JRST CISET4 - JRST CISET6 - -CISET1: SUBM M,(P) ; FIX ADDR - PUSH TP,$TATOM ; SAVE ATOM - PUSH TP,C - PUSH TP,A - PUSH TP,B - MOVE B,C ; GET ATOM - PUSHJ P,ILOC ; SEARCH - MOVE D,B ; POSSIBLE POINTER - GETYP E,A - MOVE 0,A - MOVE A,-1(TP) ; VAL BACK - MOVE B,(TP) - CAIE E,TUNBOU ; SKIP IF WIN - JRST CISET2 ; GO CLOBBER IT IN - MCALL 2,SET - JRST POPJM - -CISET2: MOVE C,-2(TP) ; ATOM BACK - SUBM M,(P) ; RESET (P) - SUB TP,[4,,4] - JRST CISET3 - -; HERE TO DO A MONITORED SET - -CISET4: SUBM M,(P) ; AGAIN FIX (P) - PUSH TP,$TATOM - PUSH TP,C - PUSH TP,A - PUSH TP,B - MCALL 2,SET - JRST POPJM - -; COMPILER LLOC - -CLLOC: MOVE 0,BINDID+1(PVP) ; GET CURRENT LOCATIVE - HRLI 0,TLOCI - CAME 0,(B) ; WIN? - JRST CLLOC1 - MOVE B,1(B) - MOVE 0,SPCCHK - TRNE 0,1 ; SKIP IF NOT CHECKING - JRST CLLOC9 -CLLOC3: MOVSI A,TLOCD - HRR A,2(B) ; GET BIND TIME - POPJ P, - -CLLOC1: SUBM M,(P) - PUSH TP,$TATOM - PUSH TP,B - PUSHJ P,ILOC ; LOOK IT UP - JUMPE B,CLLOC2 - SUB TP,[2,,2] -CLLOC4: SUBM M,(P) - JRST CLLOC3 - -CLLOC2: MCALL 1,LLOC - JRST CLLOC4 - -CLLOC9: HLRZ 0,-2(B) - CAIE 0,TUBIND - JRST CLLOC3 - CAMGE B,CURFCN+1(PVP) - JRST CLLOC2 - JRST CLLOC3 - -; COMPILER BOUND? - -CBOUND: SUBM M,(P) - PUSHJ P,ILOC - JUMPE B,PJFALS ; IF UNBOUND RET FALSE AND NO SSKIP -PJT1: SOS (P) - MOVSI A,TATOM - MOVE B,MQUOTE T - JRST POPJM - -PJFALS: MOVEI B,0 - MOVSI A,TFALSE - JRST POPJM - -; COMPILER ASSIGNED? - -CASSQ: SUBM M,(P) - PUSHJ P,ILOC - JUMPE B,PJFALS - GETYP 0,(B) - CAIE 0,TUNBOU - JRST PJT1 - JRST PJFALS - - -; COMPILER GVAL B/ ATOM - -CIGVAL: MOVE 0,(B) ; GLOBAL VAL HERE? - CAME 0,$TLOCI ; TIME=0 ,TYPE=TLOCI => GLOB VAL - JRST CIGVA1 ; NO, GO LOOK - MOVE C,1(B) ; POINT TO SLOT - MOVE A,(C) ; GET TYPE - TLNE A,.RDMON - JRST CIGVA1 - GETYP 0,A ; CHECK FOR UNBOUND - CAIN 0,TUNBOU ; SKIP IF WINNER - JRST CGUNAS - MOVE B,1(C) - POPJ P, - -CGUNAS: -CIGVA1: SUBM M,(P) - PUSH TP,$TATOM - PUSH TP,B - .MCALL 1,GVAL ; GET ERROR/MONITOR - JRST POPJM - -; COMPILER INTERFACET TO SETG - -CSETG: MOVE 0,(C) ; GET V CELL - CAME 0,$TLOCI ; SKIP IF FAST - JRST CSETG1 - HRRZ D,1(C) ; POINT TO SLOT - MOVE 0,(D) ; OLD VAL -CSETG3: CAIG D,HIBOT ; SKIP IF PURE ATOM - TLNE 0,.WRMON ; MONITOR - JRST CSETG2 - MOVEM A,(D) - MOVEM B,1(D) - POPJ P, - -CSETG1: SUBM M,(P) ; FIX UP P - PUSH TP,$TATOM - PUSH TP,C - PUSH TP,A - PUSH TP,B - MOVE B,C - PUSHJ P,IGLOC ; FIND GLOB LOCATIVE - GETYP E,A - MOVE 0,A - MOVEI D,(B) ; SETUP TO RESTORE NEW VAL - MOVE A,-1(TP) - MOVE B,(TP) - CAIE E,TUNBOU - JRST CSETG4 - MCALL 2,SETG - JRST POPJM - -CSETG4: MOVE C,-2(TP) ; ATOM BACK - SUBM M,(P) ; RESET (P) - SUB TP,[4,,4] - JRST CSETG3 - -CSETG2: SUBM M,(P) - PUSH TP,$TATOM ; CAUSE A SETG MONITOR - PUSH TP,C - PUSH TP,A - PUSH TP,B - MCALL 2,SETG - JRST POPJM - -; COMPILER GLOC - -CGLOC: MOVE 0,(B) ; GET CURRENT GUY - CAME 0,$TLOCI ; WIN? - JRST CGLOC1 ; NOPE - HRRZ D,1(B) ; POINT TO SLOT - CAILE D,HIBOT ; PURE? - JRST CGLOC1 - MOVE A,$TLOCD - MOVE B,1(B) - POPJ P, - -CGLOC1: SUBM M,(P) - PUSH TP,$TATOM - PUSH TP,B - MCALL 1,GLOC - JRST POPJM - -; COMPILERS GASSIGNED? - -CGASSQ: MOVE 0,(B) - SUBM M,(P) - CAMN 0,$TLOCD - JRST PJT1 - PUSHJ P,IGLOC - JUMPE B,PJFALS - GETYP 0,(B) - CAIE 0,TUNBOU - JRST PJT1 - JRST PJFALS - -; COMPILERS GBOUND? - -CGBOUN: MOVE 0,(B) - SUBM M,(P) - CAMN 0,$TLOCD - JRST PJT1 - PUSHJ P,IGLOC - JUMPE B,PJFALS - JRST PJT1 - - -MFUNCTION REP,FSUBR,[REPEAT] - JRST PROG -MFUNCTION PROG,FSUBR - ENTRY 1 - GETYP A,(AB) ;GET ARG TYPE - CAIE A,TLIST ;IS IT A LIST? - JRST WRONGT ;WRONG TYPE - SKIPN C,1(AB) ;GET AND CHECK ARGUMENT - JRST TFA ;TOO FEW ARGS - SETZB E,D ; INIT HEWITT ATOM AND DECL - PUSHJ P,CARATC ; IS 1ST THING AN ATOM - JFCL - PUSHJ P,RSATY1 ; CDR AND GET TYPE - CAIE 0,TLIST ; MUST BE LIST - JRST MPD.13 - MOVE B,1(C) ; GET ARG LIST - PUSH TP,$TLIST - PUSH TP,C - PUSHJ P,RSATYP - CAIE 0,TDECL - JRST NOP.DC ; JUMP IF NO DCL - MOVE D,1(C) - MOVEM C,(TP) - PUSHJ P,RSATYP ; CDR ON -NOP.DC: PUSH TP,$TLIST - PUSH TP,B ; AND ARG LIST - PUSHJ P,PRGBND ; BIND AUX VARS - MOVE E,MQUOTE LPROG,[LPROG ]INTRUP - PUSHJ P,MAKACT ; MAKE ACTIVATION - PUSHJ P,PSHBND ; BIND AND CHECK - PUSHJ P,SPECBI ; NAD BIND IT - -; HERE TO RUN PROGS FUNCTIONS ETC. - -DOPROG: MOVEI A,REPROG - HRLI A,TDCLI ; FLAG AS FUNNY - MOVEM A,(TB) ; WHERE TO AGAIN TO - MOVE C,1(TB) - MOVEM C,3(TB) ; RESTART POINTER - JRST .+2 ; START BY SKIPPING DECL - -DOPRG1: PUSHJ P,FASTEV - HRRZ C,@1(TB) ;GET THE REST OF THE BODY -DOPRG2: MOVEM C,1(TB) - JUMPN C,DOPRG1 -ENDPROG: - HRRZ C,FSAV(TB) - CAIN C,REP -REPROG: SKIPN C,@3(TB) - JRST PFINIS - HRRZM C,1(TB) - INTGO - MOVE C,1(TB) - JRST DOPRG1 - - -PFINIS: GETYP 0,(TB) - CAIE 0,TDCLI ; DECL'D ? - JRST PFINI1 - HRRZ 0,(TB) ; SEE IF RSUBR - JUMPE 0,RSBVCK ; CHECK RSUBR VALUE - HRRZ C,3(TB) ; GET START OF FCN - GETYP 0,(C) ; CHECK FOR DECL - CAIE 0,TDECL - JRST PFINI1 ; NO, JUST RETURN - MOVE E,MQUOTE VALUE - PUSHJ P,PSHBND ; BUILD FAKE BINDING - MOVE C,1(C) ; GET DECL LIST - MOVE E,TP - PUSHJ P,CHKDCL ; AND CHECK IT - MOVE A,-3(TP) ; GET VAL BAKC - MOVE B,-2(TP) - SUB TP,[6,,6] - -PFINI1: HRRZ C,FSAV(TB) - CAIE C,EVAL - JRST FINIS - JRST EFINIS - -RSATYP: HRRZ C,(C) -RSATY1: JUMPE C,TFA - GETYP 0,(C) - POPJ P, - -; HERE TO CHECK RSUBR VALUE - -RSBVCK: PUSH TP,A - PUSH TP,B - MOVE C,A - MOVE D,B - MOVE A,1(TB) ; GET DECL - MOVE B,1(A) - HLLZ A,(A) - PUSHJ P,TMATCH - JRST RSBVC1 - POP TP,B - POP TP,A - POPJ P, - -RSBVC1: MOVE C,1(TB) - POP TP,B - POP TP,D - MOVE A,MQUOTE VALUE - JRST TYPMIS - - -MFUNCTION MRETUR,SUBR,[RETURN] - ENTRY - HLRE A,AB ; GET # OF ARGS - ASH A,-1 ; TO NUMBER - AOJL A,RET2 ; 2 OR MORE ARGS - PUSHJ P,PROGCH ;CHECK IN A PROG - PUSH TP,A - PUSH TP,B - MOVEI B,-1(TP) ; VERIFY IT -COMRET: PUSHJ P,CHFSWP - SKIPL C ; ARGS? - MOVEI C,0 ; REAL NONE - PUSHJ P,CHUNW - JUMPN A,CHFINI ; WINNER - MOVSI A,TATOM - MOVE B,MQUOTE T - -; SEE IF MUST CHECK RETURNS TYPE - -CHFINI: GETYP 0,(TB) ; SPECIAL TYPE IF SO - CAIE 0,TDCLI - JRST FINIS ; NO, JUST FINIS - MOVEI 0,PFINIS ; CAUSE TO FALL INTO FUNCTION CODE - HRRM 0,PCSAV(TB) - JRST CONTIN - - -RET2: AOJL A,TMA - GETYP A,(AB)+2 - CAIE A,TACT ; AS FOR "EXIT" SHOULD BE ACTIVATION - JRST WTYP2 - MOVEI B,(AB)+2 ; ADDRESS OF FRAME POINTER - JRST COMRET - - - -MFUNCTION AGAIN,SUBR - ENTRY - HLRZ A,AB ;GET # OF ARGS - CAIN A,-2 ;1 ARG? - JRST NLCLA ;YES - JUMPN A,TMA ;0 ARGS? - PUSHJ P,PROGCH ;CHECK FOR IN A PROG - PUSH TP,A - PUSH TP,B - JRST AGAD -NLCLA: GETYP A,(AB) - CAIE A,TACT - JRST WTYP1 - PUSH TP,(AB) - PUSH TP,1(AB) -AGAD: MOVEI B,-1(TP) ; POINT TO FRAME - PUSHJ P,CHFSWP - HRRZ C,(B) ; GET RET POINT -GOJOIN: PUSH TP,$TFIX - PUSH TP,C - MOVEI C,-1(TP) - PUSHJ P,CHUNW ; RESTORE FRAME, UNWIND IF NEC. - HRRZM B,PCSAV(TB) - HRRZ 0,FSAV(TB) ; CHECK FOR RSUBR - CAMGE 0,VECTOP - CAMG 0,VECBOT - JRST CONTIN - HRRZ E,1(TB) - PUSH TP,$TFIX - PUSH TP,B - MOVEI C,-1(TP) - MOVEI B,(TB) - PUSHJ P,CHUNW1 - MOVE TP,1(TB) - MOVEM SP,SPSAV(TB) - MOVEM TP,TPSAV(TB) - MOVE C,OTBSAV(TB) ; AND RESTORE P FROM FATHER - MOVE P,PSAV(C) - MOVEM P,PSAV(TB) - HRLI B,M - MOVEM B,PCSAV(TB) - JRST CONTIN - -MFUNCTION GO,SUBR - ENTRY 1 - GETYP A,(AB) - CAIE A,TATOM - JRST NLCLGO - PUSHJ P,PROGCH ;CHECK FOR A PROG - PUSH TP,A ;SAVE - PUSH TP,B - MOVEI B,-1(TP) - PUSHJ P,CHFSWP - PUSH TP,$TATOM - PUSH TP,1(C) - PUSH TP,2(B) - PUSH TP,3(B) - MCALL 2,MEMQ ;DOES IT HAVE THIS TAG? - JUMPE B,NXTAG ;NO -- ERROR -FNDGO: EXCH B,(TP) ;SAVE PLACE TO GO - MOVSI D,TLIST - MOVEM D,-1(TP) - JRST GODON - -NLCLGO: CAIE A,TTAG ;CHECK TYPE - JRST WTYP1 - MOVE B,1(AB) - MOVEI B,2(B) ; POINT TO SLOT - PUSHJ P,CHFSWP - MOVE A,1(C) - GETYP 0,(A) ; SEE IF COMPILED - CAIE 0,TFIX - JRST GODON1 - MOVE C,1(A) - JRST GOJOIN - -GODON1: PUSH TP,(A) ;SAVE BODY - PUSH TP,1(A) -GODON: MOVEI C,0 - PUSHJ P,CHUNW ;GO BACK TO CORRECT FRAME - MOVE B,(TP) ;RESTORE ITERATION MARKER - MOVEM B,1(TB) - MOVSI A,TFALSE - MOVEI B,0 - JRST CONTIN - - - - -MFUNCTION TAG,SUBR - ENTRY - JUMPGE AB,TFA - HLRZ 0,AB - GETYP A,(AB) ;GET TYPE OF ARGUMENT - CAIE A,TFIX ; FIX ==> COMPILED - JRST ATOTAG - CAIE 0,-4 - JRST WNA - GETYP A,2(AB) - CAIE A,TACT - JRST WTYP2 - PUSH TP,(AB) - PUSH TP,1(AB) - PUSH TP,2(AB) - PUSH TP,3(AB) - JRST GENTV -ATOTAG: CAIE A,TATOM ;CHECK THAT IT IS AN ATOM - JRST WTYP1 - CAIE 0,-2 - JRST TMA - PUSHJ P,PROGCH ;CHECK PROG - PUSH TP,A ;SAVE VAL - PUSH TP,B - PUSH TP,$TATOM - PUSH TP,1(AB) - PUSH TP,2(B) - PUSH TP,3(B) - MCALL 2,MEMQ - JUMPE B,NXTAG ;IF NOT FOUND -- ERROR - EXCH A,-1(TP) ;SAVE PLACE - EXCH B,(TP) - HRLI A,TFRAME - PUSH TP,A - PUSH TP,B -GENTV: MOVEI A,2 - PUSHJ P,IEVECT - MOVSI A,TTAG - JRST FINIS - -PROGCH: MOVE B,MQUOTE LPROG,[LPROG ]INTRUP - PUSHJ P,ILVAL ;GET VALUE - GETYP 0,A - CAIE 0,TACT - JRST NXPRG - POPJ P, - -; HERE TO UNASSIGN LPROG IF NEC - -UNPROG: MOVE B,MQUOTE LPROG,[LPROG ]INTRUP - PUSHJ P,ILVAL - GETYP 0,A - CAIE 0,TACT ; SKIP IF MUST UNBIND - JRST UNMAP - MOVSI A,TUNBOU - MOVNI B,1 - MOVE E,MQUOTE LPROG,[LPROG ]INTRUP - PUSHJ P,PSHBND -UNMAP: HRRZ 0,FSAV(TB) ; CHECK FOR FUNNY - CAIN 0,MAPPLY ; SKIP IF NOT - POPJ P, - MOVE B,MQUOTE LMAP,[LMAP ]INTRUP - PUSHJ P,ILVAL - GETYP 0,A - CAIE 0,TFRAME - JRST UNSPEC - MOVSI A,TUNBOU - MOVNI B,1 - MOVE E,MQUOTE LMAP,[LMAP ]INTRUP - PUSHJ P,PSHBND -UNSPEC: PUSH TP,BNDV - MOVE B,PVP - ADD B,[CURFCN,,CURFCN] - PUSH TP,B - PUSH TP,$TSP - MOVE E,SP - ADD E,[3,,3] - PUSH TP,E - POPJ P, - -REPEAT 0,[ -MFUNCTION MEXIT,SUBR,[EXIT] - ENTRY 2 - GETYP A,(AB) - CAIE A,TACT - JRST WTYP1 - MOVEI B,(AB) - PUSHJ P,CHFSWP - ADD C,[2,,2] - PUSHJ P,CHUNW ;RESTORE FRAME - JRST CHFINI ; CHECK FOR WINNING VALUE -] - -MFUNCTION COND,FSUBR - ENTRY 1 - GETYP A,(AB) - CAIE A,TLIST - JRST WRONGT - PUSH TP,(AB) - PUSH TP,1(AB) ;CREATE UNNAMED TEMP - MOVEI B,0 ; SET TO FALSE IN CASE - -CLSLUP: SKIPN C,1(TB) ;IS THE CLAUSELIST NIL? - JRST IFALS1 ;YES -- RETURN NIL - GETYP A,(C) ;NO -- GET TYPE OF CAR - CAIE A,TLIST ;IS IT A LIST? - JRST BADCLS ; - MOVE A,1(C) ;YES -- GET CLAUSE - JUMPE A,BADCLS - GETYPF B,(A) - PUSH TP,B ; EVALUATION OF - HLLZS (TP) - PUSH TP,1(A) ;THE PREDICATE - JSP E,CHKARG - MCALL 1,EVAL - GETYP 0,A - CAIN 0,TFALSE - JRST NXTCLS ;FALSE TRY NEXT CLAUSE - MOVE C,1(TB) ;IF NOT, DO FIRST CLAUSE - MOVE C,1(C) - HRRZ C,(C) - JUMPE C,FINIS ;(UNLESS DONE WITH IT) - JRST DOPRG2 ;AS THOUGH IT WERE A PROG -NXTCLS: HRRZ C,@1(TB) ;SET THE CLAUSLIST - HRRZM C,1(TB) ;TO CDR OF THE CLAUSLIST - JRST CLSLUP - -IFALSE: - MOVEI B,0 -IFALS1: MOVSI A,TFALSE ;RETURN FALSE - JRST FINIS - - - -MFUNCTION UNWIND,FSUBR - - ENTRY 1 - - GETYP 0,(AB) ; CHECK THE ARGS FOR WINNAGE - SKIPN A,1(AB) ; NONE? - JRST TFA - HRRZ B,(A) ; CHECK FOR 2D - JUMPE B,TFA - HRRZ 0,(B) ; 3D? - JUMPN 0,TMA - -; Unbind LPROG and LMAPF so that nothing cute happens - - PUSHJ P,UNPROG - -; Push thing to do upon UNWINDing - - PUSH TP,$TLIST - PUSH TP,[0] - - MOVEI C,UNWIN1 - PUSHJ P,IUNWIN ; GOT TO INTERNAL SET UP - -; Now EVAL the first form - - MOVE A,1(AB) - HRRZ 0,(A) ; SAVE POINTER TO OTHER GUY - MOVEM 0,-12(TP) - MOVE B,1(A) - GETYP A,(A) - MOVSI A,(A) - JSP E,CHKAB ; DEFER? - PUSH TP,A - PUSH TP,B - MCALL 1,EVAL ; EVAL THE LOSER - - JRST FINIS - -; Now push slots to hold undo info on the way down - -IUNWIN: -REPEAT 0,[ - JUMPE M,NOTRSB - MOVEI C,(C) - HLRE 0,M - SUBM M,0 - ANDI 0,-1 - CAIL C,HIBOT - JRST NOTRSB - CAIL C,(M) - CAML C,0 - JRST .+2 - SUBI C,(M) -NOTRSB:] - PUSH TP,$TTB ; DESTINATION FRAME - PUSH TP,[0] - PUSH TP,[0] ; ARGS TO WHOEVER IS DOING IT - PUSH TP,[0] - -; Now bind UNWIND word - - PUSH TP,$TUNWIN ; FIRST WORD OF IT - HRRM SP,(TP) ; CHAIN - MOVE SP,TP - PUSH TP,TB ; AND POINT TO HERE - PUSH TP,$TTP - PUSH TP,[0] - HRLI C,TPDL - PUSH TP,C - PUSH TP,P ; SAVE PDL ALSO - MOVEM TP,-2(TP) ; SAVE FOR LATER - POPJ P, - -; Do a non-local return with UNWIND checking - -CHUNW: HRRZ E,SPSAV(B) ; GET DESTINATION FRAME -CHUNW1: PUSH TP,(C) ; FINAL VAL - PUSH TP,1(C) - JUMPN C,.+3 ; WAS THERE REALLY ANYTHING - SETZM (TP) - SETZM -1(TP) - PUSHJ P,STLOOP ; UNBIND -CHUNPC: SKIPA ; WILL NOT SKIP UNLESS UNWIND FOUND - JRST GOTUND - MOVEI A,(TP) - SUBI A,(SP) - MOVSI A,(A) - HLL SP,TP - SUB SP,A - HRRI TB,(B) ; UPDATE TB - POP TP,B - POP TP,A - POPJ P, - -; Here if an UNDO found - -GOTUND: MOVE TB,1(SP) ; GET FRAME OF UNDO - MOVE A,-1(TP) ; GET FUNNY ARG FOR PASS ON - MOVE C,(TP) - MOVE TP,3(SP) ; GET FUTURE TP - MOVEM C,-6(TP) ; SAVE ARG - MOVEM A,-7(TP) - MOVE C,(TP) ; SAVED P - SUB C,[1,,1] - MOVEM C,PSAV(TB) ; MAKE CONTIN WIN - MOVEM TP,TPSAV(TB) - MOVEM SP,SPSAV(TB) - HRRZ C,(P) ; PC OF CHUNW CALLER - HRRM C,-11(TP) ; SAVE ALSO AND GET WHERE TO GO PC - MOVEM B,-10(TP) ; AND DESTINATION FRAME - HRRZ C,-1(TP) ; WHERE TO UNWIND PC - HRRZ 0,FSAV(TB) ; RSUBR? - CAMG 0,VECTOP - CAMGE 0,VECBOT - TLZA C,-1 ; 0 LH OF C AND SKIP - HRLI C,M ; RELATIVIZE - MOVEM C,PCSAV(TB) - JRST CONTIN - -UNWIN1: MOVE B,-12(TP) ; POINT TO THING TO DO UNWINDING - GETYP A,(B) - MOVSI A,(A) - MOVE B,1(B) - JSP E,CHKAB - PUSH TP,A - PUSH TP,B - MCALL 1,EVAL -UNWIN2: MOVEI C,-7(TP) ; POINT TO SAVED RET VALS - MOVE B,-10(TP) - HRRZ E,-11(TP) - PUSH P,E - HRRZ SP,(SP) ; UNBIND THIS GUY - MOVEI E,(TP) ; AND FIXUP SP - SUBI E,(SP) - MOVSI E,(E) - HLL SP,TP - SUB SP,E - JRST CHUNW ; ANY MORE TO UNWIND? - - -; CHFSWP - CHECK FRAMES VALIDITY AND SWAP PROCESS IF NECESSARY. -; CALLED BY ALL CONTROL FLOW -; ROUTINES (GO,RETURN,EXIT,AGAIN,ERRET...) - -CHFSWP: PUSHJ P,CHFRM ; CHECK FOR VALID FRAME - HRRZ D,(B) ; PROCESS VECTOR DOPE WD - HLRZ C,(D) ; LENGTH - SUBI D,-1(C) ; POINT TO TOP - MOVNS C ; NEGATE COUNT - HRLI D,2(C) ; BUILD PVP - MOVE E,PVP - MOVE C,AB - MOVE A,(B) ; GET FRAME - MOVE B,1(B) - CAMN E,D ; SKIP IF SWAP NEEDED - POPJ P, - PUSH TP,A ; SAVE FRAME - PUSH TP,B - MOVE B,D - PUSHJ P,PROCHK ; FIX UP PROCESS LISTS - MOVE A,PSTAT+1(B) ; GET STATE - CAIE A,RESMBL - JRST NOTRES - MOVE D,B ; PREPARE TO SWAP - POP P,0 ; RET ADDR - POP TP,B - POP TP,A - JSP C,SWAP ; SWAP IN - MOVE C,ABSTO+1(E) ; GET OLD ARRGS - MOVEI A,RUNING ; FIX STATES - MOVEM A,PSTAT+1(PVP) - MOVEI A,RESMBL - MOVEM A,PSTAT+1(E) - JRST @0 - -NOTRES: PUSH TP,$TATOM - PUSH TP,EQUOTE PROCESS-NOT-RESUMABLE - JRST CALER1 - - -;SETG IS USED TO SET THE GLOBAL VALUE OF ITS FIRST ARGUMENT, -;AN IDENTIFIER, TO THE VALUE OF ITS SECOND ARGUMENT. ITS VALUE IS -; ITS SECOND ARGUMENT. - -MFUNCTION SETG,SUBR - ENTRY 2 - GETYP A,(AB) ;GET TYPE OF FIRST ARGUMENT - CAIE A,TATOM ;CHECK THAT IT IS AN ATOM - JRST NONATM ;IF NOT -- ERROR - MOVE B,1(AB) ;GET POINTER TO ATOM - PUSH TP,$TATOM - PUSH TP,B - MOVEI 0,(B) - CAIL 0,HIBOT ; PURE ATOM? - PUSHJ P,IMPURIFY ; YES IMPURIFY - PUSHJ P,IGLOC ;GET LOCATIVE TO VALUE - CAMN A,$TUNBOUND ;IF BOUND - PUSHJ P,BSETG ;IF NOT -- BIND IT - MOVE C,2(AB) ; GET PROPOSED VVAL - MOVE D,3(AB) - MOVSI A,TLOCD ; MAKE SURE MONCH WINS - PUSHJ P,MONCH0 ; WOULD YOU BELIEVE MONITORS!!!! - EXCH D,B ;SAVE PTR - MOVE A,C - HRRZ E,-2(D) ; POINT TO POSSIBLE GDECL (OR MAINIFEST) - JUMPE E,OKSETG ; NONE ,OK - CAIE E,-1 ; MANIFEST? - JRST SETGTY - GETYP 0,(D) ; IF UNBOUND, LET IT HAPPEN - SKIPN IGDECL - CAIN 0,TUNBOU - JRST OKSETG -MANILO: GETYP C,(D) - GETYP 0,2(AB) - CAIN 0,(C) - CAME B,1(D) - JRST .+2 - JRST OKSETG - PUSH TP,$TVEC - PUSH TP,D - MOVE B,MQUOTE REDEFINE - PUSHJ P,ILVAL ; SEE IF REDEFINE OK - GETYP A,A - CAIE A,TUNBOU - CAIN A,TFALSE - JRST .+2 - JRST OKSTG - PUSH TP,$TATOM - PUSH TP,EQUOTE ATTEMPT-TO-CHANGE-MANIFEST-VARIABLE - PUSH TP,$TATOM - PUSH TP,1(AB) - MOVEI A,2 - JRST CALER - -SETGTY: PUSH TP,$TVEC - PUSH TP,D - MOVE C,A - MOVE D,B - GETYP A,(E) - MOVSI A,(A) - MOVE B,1(E) - JSP E,CHKAB - PUSHJ P,TMATCH - JRST TYPMI3 - -OKSTG: MOVE D,(TP) - MOVE A,2(AB) - MOVE B,3(AB) - -OKSETG: MOVEM A,(D) ;DEPOSIT INTO THE - MOVEM B,1(D) ;INDICATED VALUE CELL - JRST FINIS - -TYPMI3: MOVE C,(TP) - HRRZ C,-2(C) - MOVE D,2(AB) - MOVE B,3(AB) - MOVE 0,(AB) - MOVE A,1(AB) - JRST TYPMIS - -BSETG: HRRZ A,GLOBASE+1(TVP) - HRRZ B,GLOBSP+1(TVP) - SUB B,A - CAIL B,6 - JRST SETGIT - MOVEI B,0 ; MAKE SURE OF NO EMPTY SLOTS - PUSHJ P,IGLOC - CAMN A,$TUNBOU ; SKIP IF SLOT FOUND - JRST BSETG1 - MOVE E,(TP) ; GET ATOM - MOVEM E,-1(B) ; CLOBBER ATOM SLOT - POPJ P, -; BSETG1: PUSH TP,GLOBASE(TVP) ; MUST REALLY GROW STACK -; PUSH TP,GLOBASE+1 (TVP) -; PUSH TP,$TFIX -; PUSH TP,[0] -; PUSH TP,$TFIX -; PUSH TP,[100] -; MCALL 3,GROW -BSETG1: PUSH P,0 - PUSH P,C - MOVE C,GLOBASE+1(TVP) - HLRE B,C - SUB C,B - MOVE B,GVLINC ; GROW BY INDICATED GVAL SLOTS - DPB B,[001100,,(C)] -; MOVEM A,GLOBASE(TVP) - MOVE C,[6,,4] ; INDICATOR FOR AGC - PUSHJ P,AGC - MOVE B,GLOBASE+1(TVP) - MOVE 0,GVLINC ; ADJUST GLOBAL SPBASE - ASH 0,6 - SUB B,0 - HRLZS 0 - SUB B,0 - MOVEM B,GLOBASE+1(TVP) -; MOVEM B,GLOBASE+1(TVP) - POP P,0 - POP P,C -SETGIT: - MOVE B,GLOBSP+1(TVP) - SUB B,[4,,4] - MOVSI C,TGATOM - MOVEM C,(B) - MOVE C,(TP) - MOVEM C,1(B) - MOVEM B,GLOBSP+1(TVP) - ADD B,[2,,2] - MOVSI A,TLOCI - POPJ P, - - -MFUNCTION DEFMAC,FSUBR - - ENTRY 1 - - PUSH P,. - JRST DFNE2 - -MFUNCTION DFNE,FSUBR,[DEFINE] - - ENTRY 1 - - PUSH P,[0] -DFNE2: GETYP A,(AB) - CAIE A,TLIST - JRST WRONGT - SKIPN B,1(AB) ; GET ATOM - JRST TFA - GETYP A,(B) ; MAKE SURE ATOM - MOVSI A,(A) - PUSH TP,A - PUSH TP,1(B) - JSP E,CHKARG - MCALL 1,EVAL ; EVAL IT TO AN ATOM - CAME A,$TATOM - JRST NONATM - PUSH TP,A ; SAVE TWO COPIES - PUSH TP,B - PUSHJ P,IGVAL ; SEE IF A VALUE EXISTS - CAMN A,$TUNBOU ; SKIP IF A WINNER - JRST .+3 - PUSHJ P,ASKUSR ; CHECK WITH USER - JRST DFNE1 - PUSH TP,$TATOM - PUSH TP,-1(TP) - MOVE B,1(AB) - HRRZ B,(B) - MOVSI A,TEXPR - SKIPN (P) ; SKIP IF MACRO - JRST DFNE3 - MOVEI D,(B) ; READY TO CONS - MOVSI C,TEXPR - PUSHJ P,INCONS - MOVSI A,TMACRO -DFNE3: PUSH TP,A - PUSH TP,B - MCALL 2,SETG -DFNE1: POP TP,B ; RETURN ATOM - POP TP,A - JRST FINIS - - -ASKUSR: MOVE B,MQUOTE REDEFINE - PUSHJ P,ILVAL ; SEE IF REDEFINE OK - GETYP A,A - CAIE A,TUNBOU - CAIN A,TFALSE - JRST ASKUS1 - JRST ASKUS2 -ASKUS1: PUSH TP,$TATOM - PUSH TP,-1(TP) - PUSH TP,$TATOM - PUSH TP,EQUOTE ALREADY-DEFINED-ERRET-NON-FALSE-TO-REDEFINE - MCALL 2,ERROR - GETYP 0,A - CAIE 0,TFALSE -ASKUS2: AOS (P) - MOVE B,1(AB) - POPJ P, - - - -;SET CLOBBERS THE LOCAL VALUE OF THE IDENTIFIER GIVEN BY ITS -;FIRST ARGUMENT TO THE SECOND ARG. ITS VALUE IS ITS SECOND ARGUMENT. - -MFUNCTION SET,SUBR - HLRE D,AB ; 2 TIMES # OF ARGS TO D - ASH D,-1 ; - # OF ARGS - ADDI D,2 - JUMPG D,TFA ; NOT ENOUGH - MOVE B,PVP - MOVE C,SP - JUMPE D,SET1 ; NO ENVIRONMENT - AOJL D,TMA ; TOO MANY - GETYP A,4(AB) ; CHECK ARG IS A FRAME OR PROCESS - CAIE A,TFRAME - CAIN A,TENV - JRST SET2 ; WINNING ENVIRONMENT/FRAME - CAIN A,TACT - JRST SET2 ; TO MAKE PFISTER HAPPY - CAIE A,TPVP - JRST WTYP2 - MOVE B,5(AB) ; GET PROCESS - MOVE C,SPSTO+1(B) - JRST SET1 -SET2: MOVEI B,4(AB) ; POINT TO FRAME - PUSHJ P,CHFRM ; CHECK IT OUT - MOVE B,5(AB) ; GET IT BACK - MOVE C,SPSAV(B) ; GET BINDING POINTER - HRRZ B,4(AB) ; POINT TO PROCESS - HLRZ A,(B) ; GET LENGTH - SUBI B,-1(A) ; POINT TO START THEREOF - HLL B,PVP ; GET -LNTRH, (ALL PROCESS VECS SAME LENGTH) -SET1: PUSH TP,$TPVP ; SAVE PROCESS - PUSH TP,B - PUSH TP,$TSP ; SAVE PATH POINTER - PUSH TP,C - GETYP A,(AB) ;GET TYPE OF FIRST - CAIE A,TATOM ;ARGUMENT -- - JRST WTYP1 ;BETTER BE AN ATOM - MOVE B,1(AB) ;GET PTR TO IT - MOVEI 0,(B) - CAIL 0,HIBOT - PUSHJ P,IMPURIFY - MOVE C,(TP) - PUSHJ P,AILOC ;GET LOCATIVE TO VALUE -GOTLOC: CAMN A,$TUNBOUND ;BOUND? - PUSHJ P, BSET ;BIND IT - SUB TP,[4,,4] - MOVE C,2(AB) ; GET NEW VAL - MOVE D,3(AB) - MOVSI A,TLOCD ; FOR MONCH - HRR A,2(B) - PUSHJ P,MONCH0 ; HURRAY FOR MONITORS!!!!! - MOVE E,B - HLRZ A,2(E) ; GET DECLS - JUMPE A,SET3 ; NONE, GO - PUSH TP,$TSP - PUSH TP,E - MOVE B,1(A) - HLLZ A,(A) ; GET PATTERN - PUSHJ P,TMATCH ; MATCH TMEM - JRST TYPMI2 ; LOSES - MOVE E,(TP) - SUB TP,[2,,2] - MOVE C,2(AB) - MOVE D,3(AB) -SET3: MOVEM C,(E) ;CLOBBER IDENTIFIER - MOVEM D,1(E) - MOVE A,C - MOVE B,D - JRST FINIS -BSET: - CAMN PVP,-2(TP) ; SKIP IF PROC DIFFERS - MOVEM C,-2(TP) ; ELSE USE RESULT FROM LOC SEARCH - MOVE B,-2(TP) ; GET PROCESS - HRRZ A,TPBASE+1(B) ;GET ACTUAL STACK BASE - HRRZ B,SPBASE+1(B) ;AND FIRST BINDING - SUB B,A ;ARE THERE 6 - CAIL B,6 ;CELLS AVAILABLE? - JRST SETIT ;YES - MOVE C,(TP) ; GET POINTER BACK - MOVEI B,0 ; LOOK FOR EMPTY SLOT - PUSHJ P,AILOC - CAMN A,$TUNBOUND ; SKIP IF FOUND - JRST BSET1 - MOVE E,1(AB) ; GET ATOM - MOVEM E,-1(B) ; AND STORE - JRST BSET2 -BSET1: MOVE B,-2(TP) ; GET PROCESS -; PUSH TP,TPBASE(B) ;NO -- GROW THE TP -; PUSH TP,TPBASE+1(B) ;AT THE BASE END -; PUSH TP,$TFIX -; PUSH TP,[0] -; PUSH TP,$TFIX -; PUSH TP,[100] -; MCALL 3,GROW -; MOVE C,-2(TP) ; GET PROCESS -; MOVEM A,TPBASE(C) ;SAVE RESULT - PUSH P,0 ; MANUALLY GROW VECTOR - PUSH P,C - MOVE C,TPBASE+1(B) - HLRE B,C - SUB C,B - MOVEI C,1(C) - CAME C,TPGROW - ADDI C,PDLBUF - MOVE D,LVLINC - DPB D,[001100,,-1(C)] - MOVE C,[5,,3] ; SET UP INDICATORS FOR AGC - PUSHJ P,AGC - MOVE B,TPBASE+1(PVP) ; MODIFY POINTER - MOVE 0,LVLINC ; ADJUST SPBASE POINTER - ASH 0,6 - SUB B,0 - HRLZS 0 - SUB B,0 - MOVEM B,TPBASE+1(PVP) - POP P,C - POP P,0 -; MOVEM B,TPBASE+1(C) -SETIT: MOVE C,-2(TP) ; GET PROCESS - MOVE B,SPBASE+1(C) - MOVEI A,-6(B) ;MAKE UP BINDING - HRRM A,(B) ;LINK PREVIOUS BIND BLOCK - MOVSI A,TBIND - MOVEM A,-6(B) - MOVE A,1(AB) - MOVEM A,-5(B) - SUB B,[6,,6] - MOVEM B,SPBASE+1(C) - ADD B,[2,,2] -BSET2: MOVE C,-2(TP) ; GET PROC - MOVSI A,TLOCI - HRR A,BINDID+1(C) - HLRZ D,OTBSAV(TB) ; TIME IT - MOVEM D,2(B) ; AND FIX IT - POPJ P, - -; HERE TO ELABORATE ON TYPE MISMATCH - -TYPMI2: MOVE C,(TP) ; FIND DECLS - HLRZ C,2(C) - MOVE D,2(AB) - MOVE B,3(AB) - MOVE 0,(AB) ; GET ATOM - MOVE A,1(AB) - JRST TYPMIS - - - -MFUNCTION NOT,SUBR - ENTRY 1 - GETYP A,(AB) ; GET TYPE - CAIE A,TFALSE ;IS IT FALSE? - JRST IFALSE ;NO -- RETURN FALSE - -TRUTH: - MOVSI A,TATOM ;RETURN T (VERITAS) - MOVE B,MQUOTE T - JRST FINIS - -MFUNCTION OR,FSUBR - - PUSH P,[0] - JRST ANDOR - -MFUNCTION ANDA,FSUBR,AND - - PUSH P,[1] -ANDOR: ENTRY 1 - GETYP A,(AB) - CAIE A,TLIST - JRST WRONGT ;IF ARG DOESN'T CHECK OUT - MOVE E,(P) - SKIPN C,1(AB) ;IF NIL - JRST TF(E) ;RETURN TRUTH - PUSH TP,$TLIST ;CREATE UNNAMED TEMP - PUSH TP,C -ANDLP: - MOVE E,(P) - JUMPE C,TFI(E) ;ANY MORE ARGS? - MOVEM C,1(TB) ;STORE CRUFT - GETYP A,(C) - MOVSI A,(A) - PUSH TP,A - PUSH TP,1(C) ;ARGUMENT - JSP E,CHKARG - MCALL 1,EVAL - GETYP 0,A - MOVE E,(P) - XCT TFSKP(E) - JRST FINIS ;IF FALSE -- RETURN - HRRZ C,@1(TB) ;GET CDR OF ARGLIST - JRST ANDLP - -TF: JRST IFALSE - JRST TRUTH - -TFI: JRST IFALS1 - JRST FINIS - -TFSKP: CAIE 0,TFALSE - CAIN 0,TFALSE - -MFUNCTION FUNCTION,FSUBR - - ENTRY 1 - - MOVSI A,TEXPR - MOVE B,1(AB) - JRST FINIS - - - -MFUNCTION CLOSURE,SUBR - ENTRY - SKIPL A,AB ;ANY ARGS - JRST TFA ;NO -- LOSE - ADD A,[2,,2] ;POINT AT IDS - PUSH TP,$TAB - PUSH TP,A - PUSH P,[0] ;MAKE COUNTER - -CLOLP: SKIPL A,1(TB) ;ANY MORE IDS? - JRST CLODON ;NO -- LOSE - PUSH TP,(A) ;SAVE ID - PUSH TP,1(A) - PUSH TP,(A) ;GET ITS VALUE - PUSH TP,1(A) - ADD A,[2,,2] ;BUMP POINTER - MOVEM A,1(TB) - AOS (P) - MCALL 1,VALUE - PUSH TP,A - PUSH TP,B - MCALL 2,LIST ;MAKE PAIR - PUSH TP,A - PUSH TP,B - JRST CLOLP - -CLODON: POP P,A - ACALL A,LIST ;MAKE UP LIST - PUSH TP,(AB) ;GET FUNCTION - PUSH TP,1(AB) - PUSH TP,A - PUSH TP,B - MCALL 2,LIST ;MAKE LIST - MOVSI A,TFUNARG - JRST FINIS - - - -;ERROR COMMENTS FOR EVAL -TUPTFA: PUSH TP,$TATOM - PUSH TP,EQUOTE TOO-FEW-ARGS-FOR-ITUPLE - JRST CALER1 - -TUPTMA: PUSH TP,$TATOM - PUSH TP,EQUOTE TOO-MANY-ARGS-TO-ITUPLE - JRST CALER1 - -BADNUM: PUSH TP,$TATOM - PUSH TP,EQUOTE NEGATIVE-ARG-TO-ITUPLE - JRST CALER1 - -WTY1TP: PUSH TP,$TATOM - PUSH TP,EQUOTE FIRST-ARG-TO-ITUPLE-NOT-FIX - JRST CALER1 - -UNBOU: PUSH TP,$TATOM - PUSH TP,EQUOTE UNBOUND-VARIABLE - JRST ER1ARG - -UNAS: PUSH TP,$TATOM - PUSH TP,EQUOTE UNASSIGNED-VARIABLE - JRST ER1ARG - -BADENV: - PUSH TP,$TATOM - PUSH TP,EQUOTE BAD-ENVIRONMENT - JRST CALER1 - -FUNERR: - PUSH TP,$TATOM - PUSH TP,EQUOTE BAD-FUNARG - JRST CALER1 - - -MPD.0: -MPD.1: -MPD.2: -MPD.3: -MPD.4: -MPD.5: -MPD.6: -MPD.7: -MPD.8: -MPD.9: -MPD.10: -MPD.11: -MPD.12: -MPD.13: -MPD: PUSH TP,$TATOM - PUSH TP,EQUOTE MEANINGLESS-PARAMETER-DECLARATION - JRST CALER1 - -NOBODY: PUSH TP,$TATOM - PUSH TP,EQUOTE HAS-EMPTY-BODY - JRST CALER1 - -BADCLS: PUSH TP,$TATOM - PUSH TP,EQUOTE BAD-CLAUSE - JRST CALER1 - -NXTAG: PUSH TP,$TATOM - PUSH TP,EQUOTE NON-EXISTENT-TAG - JRST CALER1 - -NXPRG: PUSH TP,$TATOM - PUSH TP,EQUOTE NOT-IN-PROG - JRST CALER1 - -NAPTL: -NAPT: PUSH TP,$TATOM - PUSH TP,EQUOTE NON-APPLICABLE-TYPE - JRST CALER1 - -NONEVT: PUSH TP,$TATOM - PUSH TP,EQUOTE NON-EVALUATEABLE-TYPE - JRST CALER1 - - -NONATM: PUSH TP,$TATOM - PUSH TP,EQUOTE NON-ATOMIC-ARGUMENT - JRST CALER1 - - -ILLFRA: PUSH TP,$TATOM - PUSH TP,EQUOTE FRAME-NO-LONGER-EXISTS - JRST CALER1 - -ILLSEG: PUSH TP,$TATOM - PUSH TP,EQUOTE ILLEGAL-SEGMENT - JRST CALER1 - -BADMAC: PUSH TP,$TATOM - PUSH TP,EQUOTE BAD-USE-OF-MACRO - JRST CALER1 - -BADFSB: PUSH TP,$TATOM - PUSH TP,EQUOTE APPLY-OR-STACKFORM-OF-FSUBR - JRST CALER1 - - -ER1ARG: PUSH TP,(AB) - PUSH TP,1(AB) - MOVEI A,2 - JRST CALER - -END - TITLE OPEN - CHANNEL OPENER FOR MUDDLE - -RELOCATABLE - -;C. REEVE MARCH 1973 - -.INSRT MUDDLE > - -SYSQ - -IFE ITS,[ -IF1, .INSRT MUDSYS;STENEX > -] -;THIS PROGRAM HAS ENTRIES: FOPEN, FCLOSE, RENAME, READB, PRINTB, FILECOPY, READSTRING, -; PRINTSTRING, NETSTATE, NETACC, NETS, AND ACCESS. - -;THESE SUBROUTINES HANDLE I/O STREAMS FOR THE MUDDLE SYSTEM. - -; FOPEN - OPENS A FILE FOR EITHER READING OR WRITING. IT TAKES -; FIVE OPTINAL ARGUMENTS AS FOLLOWS: - -; FOPEN (,,,,) -; -; - DIRECTION EITHER READ (INPUT) OR PRINT (OUPUT). DEFAULT IS READ - -; - FIRST FILE NAME. DEFAULT INPUT OR OUTPUT. - -; - SECOND FILE NAME. DEFAULT MUDDLE. - -; - DEVICE FROM WHICH TO OPEN. DEFAULT IS DSK. - -; - SYSTEM (DIRECTORY) NAME. DEFAULT UNAME. - -; FOPEN RETURNS AN OBJECT OF TYPE CHANNEL IF IT SUCCEEDS OTHERWISE NIL - - -; FCLOSE - CLOSES A FILE. TAKES A CHANNEL OBJECT AS ITS ARGUMENT. IT ALSO TAKES -; ACCESS - DOES A .ACCESS ON A CHARACTER BASIS FOR CHARACTER FILES - - -; A CHANNEL OBJECT IS A VECTOR CONTAINIG THE FOLLOWING INFORMATION - -; CHANNO ;ITS I/O CHANNEL NUMBER. 0 MEANS NOT A REAL CHANNEL. -; DIRECT ;DIRECTION (EITHER READ OR PRINT) -; NAME1 ;FIRST NAME OF FILE AS OPENED. -; NAME2 ;SECOND NAME OF FILE -; DEVICE ;DEVICE UPON WHICH THE CHANNEL IS OPEN -; SNAME ;DIRECTORY NAME -; RNAME1 ;REAL FIRST NAME (AS RETURNED BY READING CHANNEL STATUS) -; RNAME2 ;REAL SECOND NAME -; RDEVIC ;REAL DEVICE -; RSNAME ;SYSTEM OR DIRECTORY NAME -; STATUS ;VARIOUS STATUS BITS -; IOINS ;INSTRUCTION EXECUTED TO INPUT OR OUTPUT ONE CHARACTER -; ACCESS ;ACCESS POINTER FOR RAND ACCESS (OR USED FOR DISPLAY INFO) -; RADX ;RADIX FOR CHANNELS NUMBER CONVERSION - -; *** THE FOLLOWING FIELDS FOR OUTPUT ONLY *** -; LINLN ;LENGTH OF A LINE IN CHARACTERS FOR THIS DEVICE -; CHRPOS ;CURRENT POSITION ON CURRENT LINE -; PAGLN ;LENGTH OF A PAGE -; LINPOS ;CURRENT LINE BEING WRITTEN ON - -; *** THE FOLLOWING FILEDS FOR INPUT ONLY *** -; EOFCND ;GETS EVALUATED ON EOF -; LSTCH ;BACKUP CHARACTER -; WAITNS ;FOR TTY INPUT, BECOMES A .SLEEP WHEN WAITING -; EXBUFR ;FOR TTY INPUT, CONTAINS A WAITING BUFFER LIST -; BUFSTR ;A CHARACTER STRING USED AS BUFFER FOR NON-TTY DEVICES - -; THIS DEFINES THE LENGTH OF THE NON-TTY BUFFER -BUFLNT==100 - -;THIS DEFINES BLOCK MODE BIT FOR OPENING -BLOCKM==2 ;DEFINED IN THE LEFT HALF -IMAGEM==4 - - -;THIS IRP DEFINES THE FIELDS AT ASSEMBLY TIME - - CHANLNT==4 ;INITIAL CHANNEL LENGTH - -; BUILD A PROTOTYPE CHANNEL AND DEFINE FILEDS -BUFRIN==-1 ;SPECIAL HACK SO LOSERS WON'T SEE TTY BUFFER -SCRPTO==-3 ;SPECIAL HACK FOR SCRIPT CHANNELS -PROCHN: - -IRP A,,[[CHANNO,FIX],[DIRECT,CHSTR] -[NAME1,CHSTR],[NAME2,CHSTR],[DEVICE,CHSTR],[SNAME,CHSTR] -[RNAME1,CHSTR],[RNAME2,CHSTR],[RDEVIC,CHSTR],[RSNAME,CHSTR] -[STATUS,FIX],[IOINS,FIX],[LINLN,FIX],[CHRPOS,FIX],[PAGLN,FIX],[LINPOS,FIX] -[ACCESS,FIX],[RADX,FIX],[BUFSTR,CHSTR]] - - IRP B,C,[A] - B==CHANLNT-3 - T!C,,0 - 0 - .ISTOP - TERMIN - CHANLNT==CHANLNT+2 -TERMIN - - -; EQUIVALANCES FOR CHANNELS - -EOFCND==LINLN -LSTCH==CHRPOS -WAITNS==PAGLN -EXBUFR==LINPOS -DISINF==BUFSTR ;DISPLAY INFO -INTFCN==BUFSTR ;FUNCTION (OR SUBR, OR RSUBR) TO BE APPLIED FOR INTERNAL CHNLS - - -;DEFINE VARIABLES ASSOCIATED WITH TTY BUFFERS - -IRP A,,[IOIN2,ECHO,CHRCNT,ERASCH,KILLCH,BRKCH,ESCAP,SYSCHR,BRFCHR,BRFCH2,BYTPTR] -A==.IRPCNT -TERMIN - -EXTBFR==BYTPTR+1+<100./5> ;LENGTH OF ADD'L BUFFER - - - - -.GLOBAL IPNAME,MOPEN,MCLOSE,MIOT,ILOOKU,6TOCHS,ICLOS,OCLOS,RGPARS,RGPRS -.GLOBAL OPNCHN,CHMAK,READC,TYO,SYSCHR,BRFCHR,LSTCH,BRFCH2,EXTBFR -.GLOBAL CHRWRD,STRTO6,TTYBLK,WAITNS,EXBUFR,TTICHN,TTOCHN,GETCHR -.GLOBAL CHANNO,STATUS,LINPOS,PAGLN,CHRPOS,LINLN,IOINS,ACCESS -.GLOBAL DIRECT,DISINF,RADX,EOFCND,BUFSTR,MODE1,MODE2,GCHACK,GMTYO -.GLOBAL T.CHAN,NAME1,BFCLOS,DOIOTI,DOIOTO,DOACCS,NOTTY,BYTDOP,TNXIN -.GLOBAL DISOPN,DISROP,DISCLS,DCHAR,DISLNL,DISPGL,INSTAT,MTYO -.GLOBAL ECHO,ERASCH,KILLCH,BRKCH,BYTPTR,SYSCHR,CHRCNT,ESCAP,N.CHNS -.GLOBAL REOPN,QUITTE,CHNL0,CHNL1,BUFRIN,IOIN2,IFALSE,GFALS,IDVAL -.GLOBAL BADCHN,WRONGD,CHNCLS,GSNAME,GIBLOK,APLQ,NAPT,ICONS,INCONS,IBLOCK,IDVAL1 -.GLOBAL GRB,GWB,R1CHAR,W1CHAR,BFCLS1,TTYOP2,MPOPJ,COMPER,R1C,W1C,WXCT,RXCT -.GLOBAL TMTNXS,TNXSTR,RDEVIC - - -.VECT.==40000 - -; PAIR MOVING MACRO - -DEFINE PMOVEM A,B - MOVE 0,A - MOVEM 0,B - MOVE 0,A+1 - MOVEM 0,B+1 - TERMIN - -; DEFINITIONS OF THE OFFSETS INTO THE TP STACK FOR OPEN - -T.SPDL==0 ; SAVES P STACK BASE -T.DIR==2 ; CONTAINS DIRECTION AND MODE -T.NM1==4 ; NAME 1 OF FILE -T.NM2==6 ; NAME 2 OF FILE -T.DEV==10 ; DEVICE NAME -T.SNM==12 ; SNAME -T.XT==14 ; EXTRA CRUFT IF NECESSARY -T.CHAN==16 ; CHANNEL AS GENERATED - -; OFFSETS FROM PSTACK BASE (USED FOR OPENS, .RCHST AND .FDELES) - -S.DIR==0 ; CODE FOR DIRECTION 0-IN, 1-OUT, 2-BIN, 3-BOUT,4-DISPLAY -IFN ITS,[ -S.DEV==1 ; SIXBIT DEVICE RIGHT JUSTIFIED -S.NM1==2 ; SIXBIT NAME1 -S.NM2==3 ; SIXBIT NAME2 -S.SNM==4 ; SIXBIT SNAME -S.X1==5 ; TEMPS -S.X2==6 -S.X3==7 -] - -IFE ITS,[ -S.DEV==1 -S.X1==2 -S.X2==3 -S.X3==4 -] - - -; FLAGS SPECIFYING STATE OF THE WORLD AT VARIOUS TIMES - -NOSTOR==400000 ; ON MEANS DONT BUILD NEW STRINGS -MSTNET==200000 ; ON MEANS ONLY THE "NET" DEVICE CAN WIN -SNSET==100000 ; FLAG, SNAME SUPPLIED -DVSET==040000 ; FLAG, DEV SUPPLIED -N2SET==020000 ; FLAG, NAME2 SET -N1SET==010000 ; FLAG, NAME1 SET - -RMT [EXPUNGE N1SET,N2SET,DVSET,SNSET,MSTNET,NOSTOR -] - - -; TABLE OF LEGAL MODES - -MODES: IRP A,,[READ,PRINT,READB,PRINTB,DISPLAY] - SIXBIT /A/ - TERMIN -NMODES==.-MODES - -; TABLE OF KNOWN DEVICES AND A POINTER TO THEIR OPENERS - -IFN ITS,[ - -DEVS: IRP A,,[DSK,TPL,SYS,COM,TTY,USR,STY,[ST ],NET,DIS,E&S,INT,PTP,PTR -[P ],[DK ],[UT ],[T ],NUL,[AI ] -[ML ],[DM ],[AR ],ARC]B,,[ODSK,ODSK,ODSK,ODSK,OTTY,OUSR,OSTY,OSTY,ONET,ODIS,ODIS -OINT,OPTP,OPTP,ODSK,ODSK,OUTN,OTTY,ONUL,ODSK,ODSK,ODSK,ODSK,ODSK] - B,,(SIXBIT /A/) - TERMIN -] -IFE ITS,[ -DEVS: IRP A,,[DSK,TTY,INT,NET]B,,[ODSK,OTTY,OINT,ONET] - B,,(SIXBIT /A/) - TERMIN -] -NDEVS==.-DEVS - - - -;SUBROUTINE TO DO OPENING BEGINS HERE - -MFUNCTION NFOPEN,SUBR,[OPEN-NR] - - JRST FOPEN1 - -MFUNCTION FOPEN,SUBR,[OPEN] - -FOPEN1: ENTRY - PUSHJ P,MAKCHN ;MAKE THE CHANNEL - PUSHJ P,OPNCH ;NOW OPEN IT - JRST FINIS - -; SUBR TO JUST CREATE A CHANNEL - -MFUNCTION CHANNEL,SUBR - - ENTRY - PUSHJ P,MAKCHN - MOVSI A,TCHAN - JRST FINIS - - - - -; THIS ROUTINE PARSES ARGUMENTS TO FOPEN ETC. AND BUILDS A CHANNEL BUT DOESN'T OPEN IT - -MAKCHN: PUSH TP,$TPDL - PUSH TP,P ; POINT AT CURRENT STACK BASE - PUSH TP,$TCHSTR - PUSH TP,CHQUOTE READ - MOVEI E,10 ; SLOTS OF TP NEEDED - PUSH TP,[0] - SOJG E,.-1 - MOVEI E,0 - EXCH E,(P) ; GET RET ADDR IN E -IFE ITS, PUSH P,[0] -IRP ATM,,[DEV,NM1,NM2,SNM]MDF,,[DSK,INPUT,>,[ ]]TMDF,,[DSK,INPUT,MUD,[ ]] - MOVE B,IMQUOTE ATM -IFN ITS, PUSH P,E - PUSHJ P,IDVAL1 - GETYP 0,A - CAIN 0,TCHSTR - JRST MAK!ATM - - MOVE A,$TCHSTR -IFN ITS, MOVE B,CHQUOTE MDF -IFE ITS, MOVE B,CHQUOTE TMDF -MAK!ATM: - MOVEM A,T.!ATM(TB) - MOVEM B,T.!ATM+1(TB) -IFN ITS,[ - POP P,E - PUSHJ P,STRTO6 ; RESULT LEFT ON P STACK AS DESIRED -] - TERMIN - PUSH TP,[0] ; PUSH SLOTS - PUSH TP,[0] - - PUSH P,[0] ; EXT SLOTS - PUSH P,[0] - PUSH P,[0] - PUSH P,E ; PUSH RETURN ADDRESS - MOVEI A,0 - - JUMPGE AB,MAKCH0 ; NO ARGS, ALREADY DONE - GETYP 0,(AB) ; 1ST ARG MUST BE A STRING - CAIE 0,TCHSTR - JRST WTYP1 - MOVE A,(AB) ; GET ARG - MOVE B,1(AB) - PUSHJ P,CHMODE ; CHECK OUT OPEN MODE - - PMOVEM (AB),T.DIR(TB) ; SAVE MODE NAME IN TEMPS - ADD AB,[2,,2] ; BUMP PAST DIRECTION - MOVEI A,0 - JUMPGE AB,MAKCH0 ; CHECK NAME1 BASED ON JUST MODE - - MOVEI 0,0 ; FLAGS PRESET - PUSHJ P,RGPARS ; PARSE THE STRING(S) - JRST TMA - -; ARGUMENTS PARSED, DO FINAL CHECKS AND BUILD CHANNEL - -MAKCH0: -IFN ITS,[ - MOVE C,T.SPDL+1(TB) - HLRZS D,S.DEV(C) ; GET DEV -] -IFE ITS,[ - MOVE A,T.DEV(TB) - MOVE B,T.DEV+1(TB) - PUSHJ P,STRTO6 - POP P,D - HLRZS D - MOVE C,T.SPDL+1(TB) - MOVEM D,S.DEV(C) -] - CAIE D,(SIXBIT /INT/); INTERNAL? - JRST CHNET ; NO, MAYBE NET - SKIPN T.XT+1(TB) ; WAS FCN SUPPLIED? - JRST TFA - -; FALLS TROUGH IF SKIP - - - -; NOW BUILD THE CHANNEL - -ARGSOK: MOVEI A,CHANLNT ; GET LENGTH - PUSHJ P,GIBLOK ; GET A BLOCK OF STUFF - ADD B,[4,,4] ; HIDE THE TTY BUFFER SLOT - PUSH TP,$TCHAN - PUSH TP,B - HRLI C,PROCHN ; POINT TO PROTOTYPE - HRRI C,(B) ; AND NEW ONE - BLT C,CHANLN-5(B) ; CLOBBER - MOVSI C,TLIST ; TO GIVE HIM A CLEAN LIST OF SCRIPT CHANS - MOVEM C,SCRPTO-1(B) - -; NOW BLT IN STUFF FROM THE STACK - - MOVSI C,T.DIR(TB) ; DIRECTION - HRRI C,DIRECT-1(B) - BLT C,SNAME(B) - MOVEI C,RNAME1-1(B) ; NOW "REAL" SLOTS - HRLI C,T.NM1(TB) - BLT C,RSNAME(B) - POPJ P, - -; HERE TO VALIDIFY ARGUMENTS FOR A NET OPEN - -CHNET: CAIE D,(SIXBIT /NET/) ; IS IT NET -IFN ITS, JRST MAKCH1 -IFE ITS,[ - JRST ARGSOK -] - MOVSI D,TFIX ; FOR TYPES - MOVEI B,T.NM1(TB) ; MAKE SURE ALL ARE FIXED - PUSHJ P,CHFIX - MOVEI B,T.NM2(TB) - PUSHJ P,CHFIX - MOVEI B,T.SNM(TB) - LSH A,-1 ; SKIP DEV FLAG - PUSHJ P,CHFIX - JRST ARGSOK - -MAKCH1: TRNN A,MSTNET ; CANT HAVE SEEN A FIX - JRST ARGSOK - JRST WRONGT - -IFN ITS,[ -CHFIX: TRNE A,N1SET ; SKIP IF NOT SPECIFIED - JRST CHFIX1 -] - SETOM 1(B) ; SET TO -1 - SETOM S.NM1(C) - MOVEM D,(B) ; CORRECT TYPE -IFE ITS,CHFIX: - GETYP 0,(B) - CAIE 0,TFIX - JRST PARSQ -CHFIX1: ADDI C,1 ; POINT TO NEXT FIELD - LSH A,-1 ; AND NEXT FLAG - POPJ P, -PARSQ: CAIE 0,TCHSTR - JRST WRONGT -IFE ITS, POPJ P, -IFN ITS,[ - PUSH P,A - PUSH P,C - PUSH TP,(B) - PUSH TP,1(B) - SUBI B,(TB) - PUSH P,B - MCALL 1,PARSE - GETYP 0,A - CAIE 0,TFIX - JRST WRONGT - POP P,C - ADDI C,(TB) - MOVEM A,(C) - MOVEM B,1(C) - POP P,C - POP P,A - POPJ P, -] - - -; SUBROUTINE TO CHECK VALIDITY OF MODE AND SAVE A CODE - -CHMODE: PUSHJ P,CHMOD ; DO IT - MOVE C,T.SPDL+1(TB) - HRRZM A,S.DIR(C) - POPJ P, - -CHMOD: PUSHJ P,STRTO6 ; TO SIXBIT - POP P,B ; VALUE ENDSUP ON STACK, RESTORE IT - - CAME B,[SIXBIT /PRINTO/] ; KLUDGE TO MAKE PRINTO AS PRINTB - JRST .+3 - MOVEI A,3 ; CODE FOR PRINTB - POPJ P, - - MOVSI A,-NMODES ; SCAN TO SEE IF LEGAL MODE - CAME B,MODES(A) - AOBJN A,.-1 - JUMPGE A,WRONGD ; ILLEGAL MODE NAME - POPJ P, - -IFN ITS,[ -; RGPARS -- PARSE THE STRINGS COMPRISING FILE NAMES INTO STANDARD ITS GOODIES - -RGPRS: MOVEI 0,NOSTOR ; DONT STORE STRINGS IF ENTER HERE - -RGPARS: HRLM 0,(P) ; LH IS FLAGS FOR THIS PROG - MOVSI E,-4 ; FIELDS TO FILL - -RPARGL: GETYP 0,(AB) ; GET TYPE - CAIE 0,TCHSTR ; STRING? - JRST ARGCLB ; NO, JUST CLOBBER IT IN RAW - JUMPGE E,CPOPJ ; DON'T DO ANY MORE - PUSH TP,(AB) ; GET AN ARG - PUSH TP,1(AB) - -FPARS: PUSH TP,-1(TP) ; ANOTHER COPY - PUSH TP,-1(TP) - PUSHJ P,FLSSP ; NO LEADING SPACES - MOVEI A,0 ; WILL HOLD SIXBIT - MOVEI B,6 ; CHARS PER 6BIT WORD - MOVE C,[440600,,A] ; BYTE POINTER INTO A - -FPARSL: HRRZ 0,-1(TP) ; GET COUNT - JUMPE 0,PARSD ; DONE - SOS -1(TP) ; COUNT - ILDB 0,(TP) ; CHAR TO 0 - - CAIE 0," ; FILE NAME QUOTE? - JRST NOCNTQ - HRRZ 0,-1(TP) - JUMPE 0,PARSD - SOS -1(TP) - ILDB 0,(TP) ; USE THIS - JRST GOTCNQ - -NOCNTQ: CAIG 0,40 ; SPACE? - JRST NDFLD ; YES, TERMINATE THIS FIELD - CAIN 0,": ; DEVICE ENDED? - JRST GOTDEV - CAIN 0,"; ; SNAME ENDED - JRST GOTSNM - -GOTCNQ: PUSHJ P,A0TO6 ; CONVERT TO 6BIT AND CHECK - - JUMPE B,FPARSL ; IGNORE IF AREADY HAVE 6 - IDPB 0,C - SOJA B,FPARSL - -; HERE IF SPACE ENCOUNTERED - -NDFLD: MOVEI D,(E) ; COPY GOODIE - PUSHJ P,FLSSP ; FLUSH REDUNDANT SPACES - JUMPE 0,PARSD ; NO CHARS LEFT - -NFL0: PUSH P,A ; SAVE SIXBIT WORD - PUSHJ P,6TOCHS ; CONVERT TO STRING - HRRZ 0,-1(TP) ; RESTORE CHAR COUNT - -NFL2: MOVEI C,(D) ; COPY REL PNTR - SKIPGE -1(P) ; SKIP IF STRINGS TO BE STORED - JRST NFL3 - ASH D,1 ; TIMES 2 - ADDI D,T.NM1(TB) - MOVEM A,(D) ; STORE - MOVEM B,1(D) -NFL3: MOVSI A,N1SET ; FLAG IT - LSH A,(C) - IORM A,-1(P) ; AND CLOBBER - MOVE D,T.SPDL+1(TB) ; GET P BASE - POP P,@SIXTBL(C) ; AND STORE SIXBIT OF IT - - POP TP,-2(TP) ; MAKE NEW STRING POINTER - POP TP,-2(TP) - JUMPE 0,.+3 ; SKIP IF NO MORE CHARS - AOBJN E,FPARS ; MORE TO PARSE? -CPOPJ: POPJ P, ; RETURN, ALL DONE - - SUB TP,[2,,2] ; FLUSH OLD STRING - ADD E,[1,,1] - ADD AB,[2,,2] ; BUMP ARG - JUMPL AB,RPARGL ; AND GO ON -CPOPJ1: AOS A,(P) ; PREPARE TO WIN - HLRZS A - POPJ P, - - - -; HERE IF STRING HAS ENDED - -PARSD: PUSH P,A ; SAVE 6 BIT - MOVE A,-3(TP) ; CAN USE ARG STRING - MOVE B,-2(TP) - MOVEI D,(E) - JRST NFL2 ; AND CONTINUE - -; HERE IF JUST READ DEV - -GOTDEV: MOVEI D,2 ; CODE FOR DEVICE - JRST GOTFLD ; GOT A FIELD - -; HERE IF JUST READ SNAME - -GOTSNM: MOVEI D,3 -GOTFLD: PUSHJ P,FLSSP - SOJA E,NFL0 - - -; HERE FOR NON STRING ARG ENCOUNTERED - -ARGCLB: SKIPGE (P) ; IF NOT STORING, CONSIDER THIS THE END - - POPJ P, - MOVE C,T.SPDL+1(TB) ; GET P-BASE - HLRZ A,S.DEV(C) ; GET DEVICE - CAIE A,(SIXBIT /INT/) ; IS IT THE INTERNAL DEVICE - JRST TRYNET ; NO, COUD BE NET - MOVE A,0 ; OFFNEDING TYPE TO A - PUSHJ P,APLQ ; IS IT APPLICABLE - JRST NAPT ; NO, LOSE - PMOVEM (AB),T.XT(TB) - ADD AB,[2,,2] ; MUST BE LAST ARG - JUMPL AB,TMA - JRST CPOPJ1 ; ELSE SUCCESSFUL RETURN -TRYNET: CAIE 0,TFIX ; FOR NET DEV, ARGS MUST BE FIX - JRST WRONGT ; TREAT AS WRONG TYPE - MOVSI A,MSTNET ; BETTER BE NET EVENTUALLY - IORM A,(P) ; STORE FLAGS - MOVSI A,TFIX - MOVE B,1(AB) ; GET NUMBER - MOVEI 0,(E) ; MAKE SURE NOT DEVICE - CAIN 0,2 - JRST WRONGT - PUSH P,B ; SAVE NUMBER - MOVEI D,(E) ; SET FOR TABLE OFFSETS - MOVEI 0,0 - ADD TP,[4,,4] - JRST NFL2 ; GO CLOBBER IT AWAY -] - - -; ROUTINE TO FLUSH LEADING SPACES FROM A FIELD - -FLSSP: HRRZ 0,-1(TP) ; GET CHR COUNNT - JUMPE 0,CPOPJ ; FINISHED STRING -FLSS1: MOVE B,(TP) ; GET BYTR - ILDB C,B ; GETCHAR - CAILE C,40 - JRST FLSS2 - MOVEM B,(TP) ; UPDATE BYTE POINTER - SOJN 0,FLSS1 - -FLSS2: HRRM 0,-1(TP) ; UPDATE STRING - POPJ P, - -IFN ITS,[ -;TABLE FOR STFUFFING SIXBITS AWAY - -SIXTBL: S.NM1(D) - S.NM2(D) - S.DEV(D) - S.SNM(D) - S.X1(D) -] - -RDTBL: RDEVIC(B) - RNAME1(B) - RNAME2(B) - RSNAME(B) - - - -IFE ITS,[ - -; TENEX VERSION OF FILE NAME PARSER (ONLY ACCEPT ARGS IN SINGLE STRING) - -RGPRS: MOVEI 0,NOSTOR - -RGPARS: HRLM 0,(P) ; SAVE FOR STORE CHECKING - CAMGE AB,[-7,,] ; MULTI-STRING CASE POSSIBLE? - JRST TN.MLT ; YES, GO PROCESS -RGPRSS: GETYP 0,(AB) ; CHECK ARG TYPE - CAIE 0,TCHSTR - JRST WRONGT ; FOR NOW ONLY STRING ARGS WIN - PUSH TP,(AB) - PUSH TP,1(AB) - PUSHJ P,FLSSP ; FLUSH LEADING SPACES - PUSHJ P,RGPRS1 - ADD AB,[2,,2] -CHKLST: JUMPGE AB,CPOPJ1 - SKIPGE (P) ; IF FROM OPEN, ALLOW ONE MORE - POPJ P, - PMOVEM (AB),T.XT(TB) - ADD AB,[2,,2] - JUMPL AB,TMA -CPOPJ1: AOS (P) - POPJ P, - -RGPRS1: PUSH P,[0] ; ALLOW A DEVICE SPEC -TN.SNM: MOVE A,(TP) - HRRZ 0,-1(TP) - JUMPE 0,RPDONE - ILDB A,A - CAIE A,"< ; START "DIRECTORY" ? - JRST TN.N1 ; NO LOOK FOR NAME1 - SETOM (P) ; DEV NOT ALLOWED - IBP (TP) ; SKIP CHAR - SOS -1(TP) - PUSHJ P,TN.CNT ; COUNT CHARS TO ">" - JUMPE B,ILLNAM ; RAN OUT - CAIE A,"> ; SKIP IF WINS - JRST ILLNAM - PUSHJ P,TN.CPS ; COPY TO NEW STRING - MOVEM A,T.SNM(TB) - MOVEM B,T.SNM+1(TB) - -TN.N1: PUSHJ P,TN.CNT - JUMPE B,RPDONE - CAIE A,": ; GOT A DEVICE - JRST TN.N11 - SKIPE (P) - JRST ILLNAM - SETOM (P) - PUSHJ P,TN.CPS - MOVEM A,T.DEV(TB) - MOVEM B,T.DEV+1(TB) - JRST TN.SNM ; NOW LOOK FOR SNAME - -TN.N11: CAIE A,"> - CAIN A,"< - JRST ILLNAM - MOVEM A,(P) ; SAVE END CHAR - PUSHJ P,TN.CPS ; GEN STRING - MOVEM A,T.NM1(TB) - MOVEM B,T.NM1+1(TB) - -TN.N2: SKIPN A,(P) ; GET CHAR BACK - JRST RPDONE - CAIN A,"; ; START VERSION? - JRST .+3 - CAIE A,". ; START NAME2? - JRST ILLNAM ; I GIVE UP!!! - HRRZ B,-1(TP) ; GET RMAINS OF STRING - PUSHJ P,TN.CPS ; AND COPY IT - MOVEM A,T.NM2(TB) - MOVEM B,T.NM2+1(TB) -RPDONE: SUB P,[1,,1] ; FLUSH TEMP - SUB TP,[2,,2] -CPOPJ: POPJ P, - -TN.CNT: HRRZ 0,-1(TP) ; CHAR COUNT - MOVE C,(TP) ; BPTR - MOVEI B,0 ; INIT COUNT TO 0 - -TN.CN1: MOVEI A,0 ; IN CASE RUN OUT - SOJL 0,CPOPJ ; RUN OUT? - ILDB A,C ; TRY ONE - CAIE A," ; TNEX FILE QUOTE? - JRST TN.CN2 - SOJL 0,CPOPJ - IBP C ; SKIP QUOTED CHAT - ADDI B,2 - JRST TN.CN1 - -TN.CN2: CAIE A,"< - CAIN A,"> - POPJ P, - - CAIE A,". - CAIN A,"; - POPJ P, - CAIN A,": - POPJ P, - AOJA B,TN.CN1 - -TN.CPS: PUSH P,B ; # OF CHARS - MOVEI A,4(B) ; ADD 4 TO B IN A - IDIVI A,5 - PUSHJ P,IBLOCK ; GET BLOCK OF WORDS FOR STRING - - POP P,C ; CHAR COUNT BACK - HRLI B,440700 - MOVSI A,TCHSTR - HRRI A,(C) ; CHAR STRING - MOVE D,B ; COPY BYTER - - JUMPE C,CPOPJ - ILDB 0,(TP) ; GET CHAR - IDPB 0,D ; AND STROE - SOJG C,.-2 - - MOVNI C,(A) ; - LENGTH TO C - ADDB C,-1(TP) ; DECREMENT WORDS COUNT - TRNN C,-1 ; SKIP IF EMPTY - POPJ P, - IBP (TP) - SOS -1(TP) ; ELSE FLUSH TERMINATOR - POPJ P, - -ILLNAM: PUSH TP,$TATOM - PUSH TP,EQUOTE ILLEGAL-TENEX-FILE-NAME - JRST CALER1 - -TN.MLT: MOVEI A,(AB) - HRLI A,-10 - -TN.ML1: GETYP 0,(A) - CAIE 0,TFIX - CAIN 0,TCHSTR - JRST .+2 - JRST RGPRSS ; ASSUME SINGLE STRING - ADD A,[2,,2] - JUMPL A,TN.ML1 - - MOVEI A,T.NM1(TB) - HRLI A,(AB) - BLT A,T.SNM+1(TB) ; BLT 'EM IN - ADD AB,[10,,10] ; SKIP THESE GUYS - JRST CHKLST - -] - - -; ROUTINE TO OPEN A CHANNEL FOR ANY DEVICE. NAMES ARE ASSUMED TO ALREADY -; BE ON BOTH TP STACK AND P STACK - -OPNCH: MOVE C,T.SPDL+1(TB) ; GET PDL BASE - HRRZ A,S.DIR(C) - ANDI A,1 ; JUST WANT I AND O - HRLM A,S.DEV(C) -; .TRANS S.DEV(C) ; UNDO ANY TRANSLATIONS -; JRST TRLOST ; COMPLAIN - - HRRZ A,S.DEV(C) ; GET SIXBIT DEVICE CODE - MOVEI E,(A) ; COPY TO E - ANDI E,777700 ; WITHOUT LAST - MOVEI D,(E) ; AND D - ANDI D,770000 ; WITH JUST LETTER - MOVSI B,-NDEVS ; AOBJN COUNTER - -DEVLP: HRRZ 0,DEVS(B) ; GET ONE - CAIN 0,(A) ; FULL DEV? - JRST DISPA - CAIN 0,(D) ; ONE LETTER - JRST CH2DIG - CAIN 0,(E) ; 2 LTTERS - JRST CH1DIG -NXTDEV: AOBJN B,DEVLP ; LOOP THRU - -IFN ITS,[ -OUSR: HRRZ A,S.DIR(C) ; BLOCK OR UNIT? - TRNE A,2 ; SKIP IF UNIT - JRST ODSK - PUSHJ P,OPEN1 ; OPEN IT - PUSHJ P,FIXREA ; AND READCHST IT - MOVE B,T.CHAN+1(TB) ; RESTORE CHANNEL - MOVE 0,[PUSHJ P,DOIOT] ; GET AN IOINS - MOVEM 0,IOINS(B) - MOVE C,T.SPDL+1(TB) - HRRZ A,S.DIR(C) - TRNN A,1 - JRST EOFMAK - MOVEI 0,80. - MOVEM 0,LINLN(B) - JRST OPNWIN - -OSTY: HLRZ A,S.DEV(C) - IORI A,10 ; THE DONT LOSE BIT (DONT HANG ON INPUT DO ON OUTPUT) - HRLM A,S.DEV(C) - JRST OUSR -] -IFE ITS,[ - PUSH TP,$TATOM - PUSH TP,EQUOTE NO-SUCH-DEVICE? - JRST CALER1 -] - -; MAKE SURE DIGITS EXIST - -CH2DIG: LDB 0,[60600,,A] - CAIG 0,'9 ; CHECK DIGITNESS - CAIGE 0,'0 - JRST NXTDEV ; LOSER - -CH1DIG: LDB 0,[600,,A] ; LAST CHAR - CAIG 0,'9 - CAIGE 0,'0 - JRST NXTDEV - -; HERE TO DISPATCH IF SUCCESSFUL - -DISPA: HLRZ B,DEVS(B) -IFN ITS,[ - HRRZ A,S.DIR(C) ; GET DIR OF OPEN - CAIN A,5 ; IS IT DISPLAY - CAIN B,ODIS ; BETTER BE OPENING DISPLAY - JRST (B) ; GO TO HANDLER - JRST WRONGD -] -IFE ITS, JRST (B) - - -IFN ITS,[ - -; DISK DEVICE OPNER COME HERE - -ODSK: MOVE A,S.SNM(C) ; GET SNAME - .SUSET [.SSNAM,,A] ; CLOBBER IT - PUSHJ P,OPEN0 ; DO REAL LIVE OPEN -] -IFE ITS,[ - -; TENEX DISK FILE OPENER - -ODSK: MOVE B,T.CHAN+1(TB) ; GET CHANNEL - PUSHJ P,STSTK ; EXPAND STRING ONTO STACK (E POINTS TO OLD P) - MOVE A,DIRECT-1(B) - MOVE B,DIRECT(B) - PUSHJ P,STRTO6 ; GET DIR NAME - POP P,C - MOVE D,T.SPDL+1(TB) - HRRZ D,S.DIR(D) - CAMN C,[SIXBIT /PRINTO/] - IORI D,100 ; TURN ON BIT TO SAY USE OLD FILE - MOVSI A,101 ; START SETTING UP BITS EXTRA BIT FOR MSB - TRNE D,1 ; SKIP IF INPUT - TRNE D,100 ; WITE OVER? - TLOA A,100000 ; FORCE NEW VERSION - TLO A,400000 ; FORCE OLD - HRROI B,1(E) ; POIT TO STRING - GTJFN - TDZA 0,0 ; SAVE FACT OF NO SKIP - MOVEI 0,1 ; INDICATE SKIPPED - MOVE P,E ; RESTORE PSTACK - JUMPE 0,GTJLOS ; FIND OUT WHAT HAPPENED - - MOVE B,T.CHAN+1(TB) ; GET CHANNEL - HRRZM A,CHANNO(B) ; SAVE IT - ANDI A,-1 ; READ Y TO DO OPEN - MOVSI B,440000 ; USE 36. BIT BYES - HRRI B,200000 ; ASSUME READ - TRNE D,1 ; SKIP IF READ - HRRI B,300000 ; WRITE BIT - HRRZ 0,FSAV(TB) ; SEE IF REF DATE HACK - CAIN 0,NFOPEN - TRO B,400 ; SET DON'T MUNG REF DATE BIT - OPENF - JRST OPFLOS - MOVEI 0,C.OPN+C.READ - TRNE D,1 ; SKIP FOR READ - MOVEI 0,C.OPN+C.PRIN - MOVE B,T.CHAN+1(TB) - HRRM 0,-4(B) ; MUNG THOSE BITS - ASH A,1 ; POINT TO SLOT - ADDI A,CHNL0(TVP) ; TO REAL SLOT - MOVEM B,1(A) ; SAVE CHANNEL - PUSHJ P,TMTNXS ; GET STRING FROM TENEX - MOVE B,CHANNO(B) ; JFN TO A - HRROI A,1(E) ; BASE OF STRING - MOVE C,[111111,,140001] ; WEIRD CONTROL BITS - JFNS ; GET STRING - MOVEI B,1(E) ; POINT TO START OF STRING - SUBM P,E ; RELATIVIZE E - PUSHJ P,TNXSTR ; MAKE INTO A STRING - SUB P,E ; BACK TO NORMAL - PUSH TP,A - PUSH TP,B - PUSHJ P,RGPRS1 ; PARSE INTO FIELDS - MOVE B,T.CHAN+1(TB) - MOVEI C,RNAME1-1(B) - HRLI C,T.NM1(TB) - BLT C,RSNAME(B) - JRST OPBASC -OPFLOS: MOVEI C,(A) ; SAVE ERROR CODE - MOVE B,T.CHAN+1(TB) - HRRZ A,CHANNO(B) ; JFN BACK TO A - RLJFN ; TRY TO RELEASE IT - JFCL - MOVEI A,(C) ; ERROR CODE BACK TO A - -GTJLOS: PUSHJ P,TGFALS ; GET A FALSE WITH REASON - JRST OPNRET - -STSTK: PUSH TP,$TCHAN - PUSH TP,B - MOVEI A,4+5 ; COUNT CHARS NEEDED (NEED LAST 0 BYTE) - MOVE B,(TP) - ADD A,RDEVIC-1(B) - ADD A,RNAME1-1(B) - ADD A,RNAME2-1(B) - ADD A,RSNAME-1(B) - ANDI A,-1 ; TO 18 BITS - IDIVI A,5 ; TO WORDS NEEDED - POP P,C ; SAVE RET ADDR - MOVE E,P ; SAVE POINTER - PUSH P,[0] ; ALOCATE SLOTS - SOJG A,.-1 - PUSH P,C ; RET ADDR BACK - INTGO ; IN CASE OVERFLEW - MOVE B,(TP) ; IN CASE GC'D - MOVE D,[440700,,1(E)] ; BYTE POINTER TO IT - MOVEI A,RDEVIC-1(B) - PUSHJ P,MOVSTR ; FLUSH IT ON - MOVEI A,": - IDPB A,D - HRRZ A,RSNAME-1(B) ; ANY SNAME AT ALL? - JUMPE A,ST.NM1 ; NOPE, CANT HACK WITH IT - MOVEI A,"< - IDPB A,D - MOVEI A,RSNAME-1(B) - PUSHJ P,MOVSTR ; SNAME UP - MOVEI A,"> - IDPB A,D - MOVEI A,RNAME1-1(B) - PUSHJ P,MOVSTR - MOVEI A,". - IDPB A,D -ST.NM1: MOVEI A,RNAME2-1(B) - PUSHJ P,MOVSTR - SUB TP,[2,,2] - POPJ P, - -MOVSTR: HRRZ 0,(A) ; CHAR COUNT - MOVE A,1(A) ; BYTE POINTER - SOJL 0,CPOPJ - ILDB C,A ; GET CHAR - IDPB C,D ; MUNG IT UP - JRST .-3 - -; MAKE A TENEX ERROR MESSAGE STRING - -TGFALS: PUSH P,A ; SAVE ERROR CODE - PUSHJ P,TMTNXS ; STRING ON STACK - HRROI A,1(E) ; POINT TO SPACE - MOVE B,(E) ; ERROR CODE - HRLI B,400000 ; FOR ME - MOVSI C,-100. ; MAX CHARS - ERSTR ; GET TENEX STRING - JRST TGFLS1 - JRST TGFLS1 - - MOVEI B,1(E) ; A AND B BOUND STRING - SUBM P,E ; RELATIVIZE E - PUSHJ P,TNXSTR ; BUILD STRING - SUB P,E ; P BACK TO NORMAL -TGFLS2: SUB P,[1,,1] ; FLUSH ERROR CODE SLOT - MOVE C,A - MOVE D,B - PUSHJ P,INCONS ; BUILD LIST - MOVSI A,TFALSE ; MAKE IT FALSE - POPJ P, - -TGFLS1: MOVE P,E ; RESET STACK - MOVE A,$TCHSTR - MOVE B,CHQUOTE UNKNOWN PROBLEM IN I/O - JRST TGFLS2 - -] -; OTHER BUFFERED DEVICES JOIN HERE - -OPDSK1: -IFN ITS,[ - PUSHJ P,FIXREA ; STORE THE "REAL" NAMES INTO THE CHANNEL -] -OPBASC: MOVE C,T.SPDL+1(TB) ; C WAS CLOBBERED, GET IT BACK - HRRZ A,S.DIR(C) ; FIND OUT IF OPEN IS ASCII OR WORD - TRZN A,2 ; SKIP IF BINARY - PUSHJ P,OPASCI ; DO IT FOR ASCII - -; NOW SET UP IO INSTRUCTION FOR CHANNEL - -MAKION: MOVE B,T.CHAN+1(TB) - MOVEI C,GETCHR - JUMPE A,MAKIO1 ; JUMP IF INPUT - MOVEI C,PUTCHR ; ELSE GET INPUT - MOVEI 0,80. ; DEFAULT LINE LNTH - MOVEM 0,LINLN(B) - MOVSI 0,TFIX - MOVEM 0,LINLN-1(B) -MAKIO1: - HRLI C,(PUSHJ P,) - MOVEM C,IOINS(B) ; STORE IT - JUMPN A,OPNWIN ; GET AN EOF FORM FOR INPUT CHANNEL - -; HERE TO CONS UP - -EOFMAK: MOVSI C,TATOM - MOVE D,EQUOTE END-OF-FILE - PUSHJ P,INCONS - MOVEI E,(B) - MOVSI C,TATOM - MOVE D,IMQUOTE ERROR - PUSHJ P,ICONS - MOVE D,T.CHAN+1(TB) ; RESTORE CHANNEL - MOVSI 0,TFORM - MOVEM 0,EOFCND-1(D) - MOVEM B,EOFCND(D) - -OPNWIN: MOVEI 0,10. ; SET UP RADIX - MOVSI A,TCHAN ; OPEN SUCCEEDED, RET CHANNEL - MOVE B,T.CHAN+1(TB) - MOVEM 0,RADX(B) - -OPNRET: MOVE C,(P) ; RET ADDR - SUB P,[S.X3+2,,S.X3+2] - SUB TP,[T.CHAN+2,,T.CHAN+2] - JRST (C) - - -; HERE TO CREATE CHARACTER BUFFERS FOR ASCII I/O - -OPASCI: PUSH P,A ; CONTAINS MODE, SAVE IT - MOVEI A,BUFLNT ; GET SIZE OF BUFFER - PUSHJ P,IBLOCK ; GET STORAGE - MOVSI 0,TWORD+.VECT. ; SET UTYPE - MOVEM 0,BUFLNT(B) ; AND STORE - MOVSI A,TCHSTR - SKIPE (P) ; SKIP IF INPUT - JRST OPASCO - MOVEI D,BUFLNT(B) ; REST BYTE POINTER -OPASCA: HRLI D,440700 - MOVE B,T.CHAN+1(TB) ; GET CHANNEL BACK - MOVEI 0,C.BUF - IORM 0,-4(B) ; TURN ON BUFFER BIT - MOVEM A,BUFSTR-1(B) - MOVEM D,BUFSTR(B) ; CLOBBER - POP P,A - POPJ P, - -OPASCO: HRROI C,777776 - MOVEM C,(B) ; -1 THE BUFFER (LEAVE OFF LOW BIT) - MOVSI C,(B) - HRRI C,1(B) ; BUILD BLT POINTER - BLT C,BUFLNT-1(B) ; ZAP - MOVEI D,(B) ; START MAKING STRING POINTER - HRRI A,BUFLNT*5 ; SET UP CHAR COUNT - JRST OPASCA - - -; OPEN NON FILE ORIENTED DEVICES (NUL, PTR, PTP ETC.) - -ONUL: -OPTP: -OPTR: PUSHJ P,OPEN0 ; SET UP MODE AND OPEN - SETZM S.NM1(C) ; CLOBBER UNINTERESTING FIELDS - SETZM S.NM2(C) - SETZM S.SNM(C) - JRST OPDSK1 - -; OPEN DEVICES THAT IGNORE SNAME - -OUTN: PUSHJ P,OPEN0 - SETZM S.SNM(C) - JRST OPDSK1 - -; OPEN THE DISPLAY DEVICE - -ODIS: MOVEI B,T.DIR(TB) ; GET CHANNEL - PUSHJ P,CHRWRD ; TO ASCII - JFCL - MOVE E,B ; DIR TO E - MOVE B,T.CHAN+1(TB) ; CHANNEL - MOVE 0,[PUSHJ P,DCHAR] ; IOINS - CAIN A,1 - MOVEM 0,IOINS(B) - PUSHJ P,DISOPN - JRST DISLOS ; LOSER - - MOVE D,T.CHAN+1(TB) ; GET CHANNEL - MOVEI 0,C.OPN+C.PRIN - HRRM 0,-4(D) - MOVEM A,DISINF-1(D) ; AND STORE - MOVEM B,DISINF(D) - SETZM CHANNO(D) ; NO REAL CHANNEL - MOVEI 0,DISLNL - MOVEM 0,LINLN(D) - MOVEI 0,DISPGL - MOVEM 0,PAGLN(D) - MOVEI 0,10. ; SET RADIX - MOVEM 0,RADX(D) - JRST SAVCHN ; ADD TO CHANNEL LIST - - -; INTERNAL CHANNEL OPENER - -OINT: HRRZ A,S.DIR(C) ; CHECK DIR - CAIL A,2 ; READ/PRINT? - JRST WRONGD ; NO, LOSE - - MOVE 0,INTINS(A) ; GET INS - MOVE D,T.CHAN+1(TB) ; AND CHANNEL - MOVEM 0,IOINS(D) ; AND CLOBBER - MOVEI 0,C.OPN+C.READ - TRNE A,1 - MOVEI 0,C.OPN+C.PRIN - HRRM 0,-4(D) - SETOM STATUS(D) ; MAKE SURE NOT AA TTY - PMOVEM T.XT(TB),INTFCN-1(D) - -; HERE TO SAVE PSEUDO CHANNELS - -SAVCHN: HRRZ E,CHNL0+1(TVP) ; POINT TO CURRENT LIST - MOVSI C,TCHAN - PUSHJ P,ICONS ; CONS IT ON - HRRZM B,CHNL0+1(TVP) - JRST OPNWIN - -; INT DEVICE I/O INS - -INTINS: PUSHJ P,GTINTC - PUSHJ P,PTINTC - - -; HERE TO OPEN THE NET DEVICE (I.E. THE ARPA NET) - -IFN ITS,[ -ONET: HRRZ A,S.DIR(C) ; DIRECTION CODE - CAILE A,1 ; ASCII ? - IORI A,4 ; TURN ON IMAGE BIT - SKIPGE S.NM1(C) ; NAME1 I.E. LOCAL HOST GIVEN - IORI A,10 ; NO, WE WILL LET ITS GIVE US ONE - SKIPGE S.NM2(C) ; NORMAL OR "LISTEN" - IORI A,20 ; TURN ON LISTEN BIT - MOVEI 0,7 ; DEFAULT BYTE SIZE - TRNE A,2 ; UNLESS - MOVEI 0,36. ; IMAGE WHICH IS 36 - SKIPN T.XT(TB) ; BYTE SIZE GIVEN? - MOVEM 0,S.X1(C) ; NO, STORE DEFAULT - SKIPG D,S.X1(C) ; BYTE SIZE REASONABLE? - JRST RBYTSZ ; NO <0, COMPLAIN - TRNE A,2 ; SKIP TO CHECK ASCII - JRST ONET2 ; CHECK IMAGE - CAIN D,7 ; 7-BIT WINS - JRST ONET1 - CAIE D,44 ; 36-BIT INDICATES BLOCK ASCII MODE - JRST .+3 - IORI A,2 ; SET BLOCK FLAG - JRST ONET1 - IORI A,40 ; USE 8-BIT MODE - CAIN D,10 ; IS IT RIGHT - JRST ONET1 ; YES -] - -RBYTSZ: PUSH TP,$TATOM ; CALL ERROR - PUSH TP,EQUOTE BYTE-SIZE-BAD - JRST CALER1 - -IFN ITS,[ -ONET2: CAILE D,36. ; IMAGE SIZE REASONABLE? - JRST RBYTSZ ; NO - CAIN D,36. ; NORMAL - JRST ONET1 ; YES, DONT SET FIELD - - ASH D,9. ; POSITION FOR FIELD - IORI A,40(D) ; SET IT AND ITS BIT - -ONET1: HRLM A,S.DEV(C) ; CLOBBER OPEN BLOCK - MOVE E,A ; SAVE BLOCK MODE INFO - PUSHJ P,OPEN1 ; DO THE OPEN - PUSH P,E - -; CLOBBER REAL SLOTS FOR THE OPEN - - MOVEI A,3 ; GET STATE VECTOR - PUSHJ P,IBLOCK - MOVSI A,TUVEC - MOVE D,T.CHAN+1(TB) - MOVEM A,BUFRIN-1(D) - MOVEM B,BUFRIN(D) - MOVSI A,TFIX+.VECT. ; SET U TYPE - MOVEM A,3(B) - MOVE C,T.SPDL+1(TB) - MOVE B,T.CHAN+1(TB) - - PUSHJ P,INETST ; GET STATE - - POP P,A ; IS THIS BLOCK MODE - MOVEI 0,80. ; POSSIBLE LINE LENGTH - TRNE A,1 ; SKIP IF INPUT - MOVEM 0,LINLN(B) - TRNN A,2 ; BLOCK MODE? - JRST .+3 - TRNN A,4 ; ASCII MODE? - JRST OPBASC ; GO SETUP BLOCK ASCII - MOVE 0,[PUSHJ P,DOIOT] - MOVEM 0,IOINS(B) - - JRST OPNWIN - -; INTERNAL ROUTINE TO GET THE CURRENT STATE OF THE NETWROK CHANNEL - -INETST: MOVE A,S.NM1(C) - MOVEM A,RNAME1(B) - MOVE A,S.NM2(C) - MOVEM A,RNAME2(B) - LDB A,[1100,,S.SNM(C)] - MOVEM A,RSNAME(B) - - MOVE E,BUFRIN(B) ; GET STATE BLOCK -INTST1: HRRE 0,S.X1(C) - MOVEM 0,(E) - ADDI C,1 - AOBJN E,INTST1 - - POPJ P, - - -; ACCEPT A CONNECTION - -MFUNCTION NETACC,SUBR - - PUSHJ P,ARGNET ; CHECK THAT ARG IS AN OPEN NET CHANNEL - MOVE A,CHANNO(B) ; GET CHANNEL - LSH A,23. ; TO AC FIELD - IOR A,[.NETACC] - XCT A - JRST IFALSE ; RETURN FALSE -NETRET: MOVE A,(AB) - MOVE B,1(AB) - JRST FINIS - -; FORCE SYSTEM NETWORK BUFFERS TO BE SENT - -MFUNCTION NETS,SUBR - - PUSHJ P,ARGNET - CAME A,MODES+1 - CAMN A,MODES+3 - SKIPA A,CHANNO(B) ; GET CHANNEL - JRST WRONGD - LSH A,23. - IOR A,[.NETS] - XCT A - JRST NETRET - -; SUBR TO RETURN UPDATED NET STATE - -MFUNCTION NETSTATE,SUBR - - PUSHJ P,ARGNET ; IS IT A NET CHANNEL - PUSHJ P,INSTAT - JRST FINIS - -; INTERNAL NETSTATE ROUTINE - -INSTAT: MOVE C,P ; GET PDL BASE - MOVEI 0,S.X3 ; # OF SLOTS NEEDED - PUSH P,[0] - SOJN 0,.-1 - - MOVEI D,S.DEV(C) ; SETUP FOR .RCHST - HRL D,CHANNO(B) - .RCHST D, ; GET THE GOODS - - PUSHJ P,INETST ; INTO VECTOR - SUB P,[S.X3,,S.X3] - MOVE B,BUFRIN(B) - MOVSI A,TUVEC - POPJ P, -] -; INTERNAL ROUTINE TO CHECK FOR CORRECT CHANNEL TYPE - -ARGNET: ENTRY 1 - GETYP 0,(AB) - CAIE 0,TCHAN - JRST WTYP1 - MOVE B,1(AB) ; GET CHANNEL - SKIPN CHANNO(B) ; OPEN? - JRST CHNCLS - MOVE A,RDEVIC-1(B) ; GET DEV NAME - MOVE B,RDEVIC(B) - PUSHJ P,STRTO6 - POP P,A - CAME A,[SIXBIT /NET /] - JRST NOTNET - MOVE B,1(AB) - MOVE A,DIRECT-1(B) ; CHECK FOR A READ SOCKET - MOVE B,DIRECT(B) - PUSHJ P,STRTO6 - MOVE B,1(AB) ; RESTORE CHANNEL - POP P,A - POPJ P, - -IFE ITS,[ - -; TENEX NETWRK OPENING CODE - -ONET: MOVE B,T.CHAN+1(TB) ; GET CHANNEL - MOVSI C,100700 - HRRI C,1(P) - MOVE E,P - PUSH P,[ASCII /NET:/] ; FOR STRINGS - GETYP 0,RNAME1-1(B) ; CHECK TYPE - CAIE 0,TFIX ; SKIP IF # SUPPLIED - JRST ONET1 - MOVE 0,RNAME1(B) ; GET IT - PUSHJ P,FIXSTK - JFCL - JRST ONET2 -ONET1: CAIE 0,TCHSTR - JRST WRONGT - HRRZ 0,RNAME1-1(B) - MOVE B,RNAME1(B) - JUMPE 0,ONET2 - ILDB A,B - JSP D,ONETCH - SOJA 0,.-3 -ONET2: MOVEI A,". - JSP D,ONETCH - MOVE B,T.CHAN+1(TB) - GETYP 0,RNAME2-1(B) - CAIE 0,TFIX - JRST ONET3 - GETYP 0,RSNAME-1(B) - CAIE 0,TFIX - JRST WRONGT - MOVE 0,RSNAME(B) - PUSHJ P,FIXSTK - JRST ONET4 - MOVE B,T.CHAN+1(TB) - MOVEI A,"- - JSP D,ONETCH - MOVE 0,RNAME2(B) - PUSHJ P,FIXSTK - JRST WRONGT - JRST ONET4 -ONET3: CAIE 0,TCHSTR - JRST WRONGT - HRRZ 0,RNAME2-1(B) - MOVE B,RNAME2(B) - JUMPE 0,ONET4 - ILDB A,B - JSP D,ONETCH - SOJA 0,.-3 - -ONET4: -ONET5: MOVE B,T.CHAN+1(TB) - GETYP 0,RNAME2-1(B) - CAIN 0,TCHSTR - JRST ONET6 - MOVEI A,"; - JSP D,ONETCH - MOVEI A,"T - JSP D,ONETCH -ONET6: MOVSI A,1 - HRROI B,1(E) ; STRING POINTER - GTJFN ; GET THE G.D JFN - TDZA 0,0 ; REMEMBER FAILURE - MOVEI 0,1 - MOVE P,E ; RESTORE P - JUMPE 0,GTJLOS ; CONS UP ERROR STRING - - MOVE B,T.CHAN+1(TB) - HRRZM A,CHANNO(B) ; SAVE THE JFN - - MOVE C,T.SPDL+1(TB) - MOVE D,S.DIR(C) - MOVEI B,10 - TRNE D,2 - MOVEI B,36. - SKIPE T.XT(TB) - MOVE B,T.XT+1(TB) - JUMPL B,RBYTSZ - CAILE B,36. - JRST RBYTSZ - ROT B,-6 - TLO B,3400 - HRRI B,200000 - TRNE D,1 ; SKIP FOR INPUT - HRRI B,100000 - ANDI A,-1 ; ISOLATE JFCN - OPENF - JRST OPFLOS ; REPORT ERROR - MOVE B,T.CHAN+1(TB) - ASH A,1 ; POINT TO SLOT - ADDI A,CHNL0(TVP) ; TO REAL SLOT - MOVEM B,1(A) ; SAVE CHANNEL - MOVE A,CHANNO(B) - CVSKT ; GET ABS SOCKET # - FATAL NETWORK BITES THE BAG! - MOVE D,B - MOVE B,T.CHAN+1(TB) - MOVEM D,RNAME1(B) - MOVSI 0,TFIX - MOVEM 0,RNAME1-1(B) - - MOVSI 0,TFIX - MOVEM 0,RNAME2-1(B) - MOVEM 0,RSNAME-1(B) - MOVE C,T.SPDL+1(TB) - MOVE C,S.DIR(C) - MOVE 0,[PUSHJ P,DONETO] - TRNN C,1 ; SKIP FOR OUTPUT - MOVE 0,[PUSHJ P,DONETI] - MOVEM 0,IOINS(B) - MOVEI 0,80. ; LINELENGTH - TRNE C,1 ; SKIP FOR INPUT - MOVEM 0,LINLN(B) - MOVEI A,3 ; GET STATE UVECTOR - PUSHJ P,IBLOCK - MOVSI 0,TFIX+.VECT. - MOVEM 0,3(B) - MOVE C,B - MOVE B,T.CHAN+1(TB) - MOVEM C,BUFRIN(B) - MOVSI 0,TUVEC - MOVEM 0,BUFRIN-1(B) - MOVE A,CHANNO(B) ; GET JFN - GDSTS ; GET STATE - MOVE E,T.CHAN+1(TB) - MOVEM D,RNAME2(E) - MOVEM C,RSNAME(E) - MOVE C,BUFRIN(E) - MOVEM B,(C) ; INITIAL STATE STORED - MOVE B,E - JRST OPNWIN - -; DOIOT FOR TENEX NETWRK - -DONETO: PUSH P,0 - MOVE 0,[BOUT] - JRST .+3 - -DONETI: PUSH P,0 - MOVE 0,[BIN] - PUSH P,0 - PUSH TP,$TCHAN - PUSH TP,B - MOVEI 0,(A) ; POSSIBLE OUTPUT CHAR TO 0 - MOVE A,CHANNO(B) - MOVE B,0 - ENABLE - XCT (P) - DISABLE - MOVEI A,(B) ; RET CHAR IN A - MOVE B,(TP) - MOVE 0,-1(P) - SUB P,[2,,2] - SUB TP,[2,,2] - POPJ P, - -NETPRS: MOVEI D,0 - HRRZ 0,(C) - MOVE C,1(C) - -ONETL: ILDB A,C - CAIN A,"# - POPJ P, - SUBI A,60 - ASH D,3 - IORI D,(A) - SOJG 0,ONETL - AOS (P) - POPJ P, - -FIXSTK: CAMN 0,[-1] - POPJ P, - JFFO 0,FIXS3 ; PUT OCTAL DIGITS INTO STIRNG - MOVEI A,"0 - POP P,D - AOJA D,ONETCH -FIXS3: IDIVI A,3 - MOVEI B,12. - SUBI B,(A) - HRLM B,(P) - IMULI A,3 - LSH 0,(A) - POP P,B -FIXS2: MOVEI A,0 - ROTC 0,3 ; NEXT DIGIT - ADDI A,60 - JSP D,ONETCH - SUB B,[1,,0] - TLNN B,-1 - JRST 1(B) - JRST FIXS2 - -ONETCH: IDPB A,C - TLNE C,760000 ; SKIP IF NEW WORD - JRST (D) - PUSH P,[0] - JRST (D) - -INSTAT: MOVE E,B - MOVE A,CHANNO(E) - GDSTS - LSH B,-32. - MOVEM D,RNAME2(E) ; UPDATE FOREIGN SOCHKET - MOVEM C,RSNAME(E) ; AND HOST - MOVE C,BUFRIN(E) - XCT ITSTRN(B) ; XLATE TO LOOK MORE LIKE ITS - MOVEM B,(C) ; STORE STATE - MOVE B,E - POPJ P, - -ITSTRN: MOVEI B,0 - JRST NLOSS - JRST NLOSS - MOVEI B,1 - MOVEI B,2 - JRST NLOSS - MOVEI B,4 - PUSHJ P,NOPND - MOVEI B,0 - JRST NLOSS - JRST NLOSS - PUSHJ P,NCLSD - MOVEI B,0 - JRST NLOSS - MOVEI B,0 - -NLOSS: FATAL ILLEGAL NETWORK STATE - -NOPND: MOVE B,DIRECT(E) ; SEE IF READ OR PRINT - ILDB B,B ; GET 1ST CHAR - CAIE B,"R ; SKIP FOR READ - JRST NOPNDW - SIBE ; SEE IF INPUT EXISTS - JRST .+3 - MOVEI B,5 - POPJ P, - MOVEM B,2(C) ; STORE BYTES IN STATE VECTOR - MOVEI B,11 ; RETURN DATA PRESENT STATE - POPJ P, - -NOPNDW: SOBE ; SEE IF OUTPUT PRESENT - JRST .+3 - MOVEI B,5 - POPJ P, - - MOVEI B,6 - POPJ P, - -NCLSD: MOVE B,DIRECT(E) - ILDB B,B - CAIE B,"R - JRST RET0 - SIBE - JRST .+2 - JRST RET0 - MOVEI B,10 - POPJ P, - -RET0: MOVEI B,0 - POPJ P, - - -MFUNCTION NETSTATE,SUBR - - PUSHJ P,ARGNET - PUSHJ P,INSTAT - MOVE B,BUFRIN(B) - MOVSI A,TUVEC - JRST FINIS - -MFUNCTION NETS,SUBR - - PUSHJ P,ARGNET - CAME A,MODES+1 ; PRINT OR PRINTB? - CAMN A,MODES+3 - SKIPA A,CHANNO(B) - JRST WRONGD - MOVEI B,21 - MTOPR -NETRET: MOVE B,1(AB) - MOVSI A,TCHAN - JRST FINIS - -MFUNCTION NETACC,SUBR - - PUSHJ P,ARGNET - MOVE A,CHANNO(B) - MOVEI B,20 - MTOPR - JRST NETRET - -] - -; HERE TO OPEN TELETYPE DEVICES - -OTTY: HRRZ A,S.DIR(C) ; GET DIR CODE - TRNE A,2 ; SKIP IF NOT READB/PRINTB - JRST WRONGD ; CANT DO THAT - -IFN ITS,[ - MOVE A,S.NM1(C) ; CHECK FOR A DIR - MOVE 0,S.NM2(C) - CAMN A,[SIXBIT /.FILE./] - CAME 0,[SIXBIT /(DIR)/] - SKIPA E,[-15.*2,,] - JRST OUTN ; DO IT THAT WAY - - HRRZ A,S.DIR(C) ; CHECK DIR - TRNE A,1 - JRST TTYLP2 - HRRI E,CHNL1(TVP) - PUSH P,S.DEV(C) ; SAVE THE SIXBIT DEV NAME - HRLZS (P) ; POSTITION DEVICE NAME - -TTYLP: SKIPN D,1(E) ; CHANNEL OPEN? - JRST TTYLP1 ; NO, GO TO NEXT - MOVE A,RDEVIC-1(D) ; GET DEV NAME - MOVE B,RDEVIC(D) - PUSHJ P,STRTO6 ; TO 6 BIT - POP P,A ; GET RESULT - CAMN A,(P) ; SAME? - JRST SAMTYQ ; COULD BE THE SAME -TTYLP1: ADD E,[2,,2] - JUMPL E,TTYLP - SUB P,[1,,1] ; THIS ONE MUST BE UNIQUE -TTYLP2: MOVE C,T.SPDL+1(TB) ; POINT TO P BASE - HRRZ A,S.DIR(C) ; GET DIR OF OPEN - SKIPE A ; IF OUTPUT, - IORI A,20 ; THEN USE DISPLAY MODE - HRLM A,S.DEV(C) ; STORE IN OPEN BLOCK - PUSHJ P,OPEN2 ; OPEN THE TTY - HRLZ A,S.DEV(C) ; GET DEVICE NAME - PUSHJ P,6TOCHS ; TO A STRING - MOVE D,T.CHAN+1(TB) ; POINT TO CHANNEL - MOVEM A,RDEVIC-1(D) - MOVEM B,RDEVIC(D) - MOVE C,T.SPDL+1(TB) ; RESTORE PDL BASE - MOVE B,D ; CHANNEL TO B - HRRZ 0,S.DIR(C) ; AND DIR - JUMPE 0,TTYSPC -TTY1: DOTCAL TTYGET,[CHANNO(B),[2000,,0],[2000,,A],[2000,,D]] - FATAL .CALL FAILURE - DOTCAL TTYSET,[CHANNO(B),MODE1,MODE2,D] - FATAL .CALL FAILURE - MOVE A,[PUSHJ P,GMTYO] - MOVEM A,IOINS(B) - DOTCAL RSSIZE,[CHANNO(B),[2000,,A],[2000,,D]] - FATAL .CALL FAILURE - MOVEM D,LINLN(B) - MOVEM A,PAGLN(B) - JRST OPNWIN - -; MAKE AN IOT - -IOTMAK: HRLZ A,CHANNO(B) ; GET CHANNEL - ROT A,5 - IOR A,[.IOT A] ; BUILD IOT - MOVEM A,IOINS(B) ; AND STORE IT - POPJ P, - - -; HERE IF POSSIBLY OPENING AN ALREADY OPEN TTY - -SAMTYQ: MOVE D,1(E) ; RESTORE CURRENT CHANNEL - MOVE A,DIRECT-1(D) ; GET DIR - MOVE B,DIRECT(D) - PUSHJ P,STRTO6 - POP P,A ; GET SIXBIT - MOVE C,T.SPDL+1(TB) - HRRZ C,S.DIR(C) - CAME A,MODES(C) ; SKIP IF DIFFERENT DIRECTION - JRST TTYLP1 - -; HERE IF A RE-OPEN ON A TTY - - HRRZ 0,FSAV(TB) ; IS IT FROM A FOPEN - CAIN 0,FOPEN - JRST RETOLD ; RET OLD CHANNEL - - PUSH TP,$TCHAN - PUSH TP,1(E) ; PUSH OLD CHANNEL - PUSH TP,$TFIX - PUSH TP,T.CHAN+1(TB) - MOVE A,[PUSHJ P,CHNFIX] - PUSHJ P,GCHACK - SUB TP,[4,,4] - -RETOLD: MOVE B,1(E) ; GET CHANNEL - AOS CHANNO-1(B) ; AOS REF COUNT - MOVSI A,TCHAN - SUB P,[1,,1] ; CLEAN UP STACK - JRST OPNRET ; AND LEAVE - - -; ROUTINE TO PASS TO GCHACK TO FIX UP CHANNEL POINTER - -CHNFIX: CAIN C,TCHAN - CAME D,(TP) - POPJ P, - MOVE D,-2(TP) ; GET REPLACEMENT - SKIPE B - MOVEM D,1(B) ; CLOBBER IT AWAY - POPJ P, -] - -IFE ITS,[ - MOVE C,T.SPDL+1(TB) ; POINT TO P BASE - HRRZ 0,S.DIR(C) ; 0/ 0 FOR READ 0/ 1 FOR PRINT - MOVE A,[PUSHJ P,MTYO] - MOVE B,T.CHAN+1(TB) - MOVEM A,IOINS(B) - MOVEI A,100 ; PRIM INPUT JFN - JUMPN 0,TNXTY1 - MOVEI E,C.OPN+C.READ - HRRM E,-4(B) - MOVEM B,CHNL0+2*100+1(TVP) - JRST TNXTY2 -TNXTY1: MOVEM B,CHNL0+2*101+1(TVP) - MOVEI A,101 ; PRIM OUTPUT JFN - MOVEI E,C.OPN+C.PRIN - HRRM E,-4(B) -TNXTY2: MOVEM A,CHANNO(B) - JUMPN 0,OPNWIN -] -; SETUP FUNNY BUFFER FOR TTY INPUT DEVICES - -TTYSPC: MOVEI A,EXTBFR ; GET EXTRA BUFFER - PUSHJ P,IBLOCK ; GET BLOCK - MOVE D,T.CHAN+1(TB) ;RESTORE CHANNEL POINTER -IFN ITS,[ - MOVE A,CHANNO(D) - LSH A,23. - IOR A,[.IOT A] - MOVEM A,IOIN2(B) -] -IFE ITS,[ - MOVE A,[PBIN] - MOVEM A,IOIN2(B) -] - MOVSI A,TLIST - MOVEM A,EXBUFR-1(D) ; FOR WAITING TTY BUFFERS - SETZM EXBUFR(D) ; NIL LIST - MOVEM B,BUFRIN(D) ;STORE IN CHANNEL - MOVSI A,TUVEC ;MAKE SURE TYPE IS UNIFORM VECTOR - MOVEM A,BUFRIN-1(D) -IFN ITS, MOVEI A,177 ;SET ERASER TO RUBOUT -IFE ITS, MOVEI A,1 ; TRY ^A FOR TENEX - MOVEM A,ERASCH(B) - SETZM KILLCH(B) ;NO KILL CHARACTER NEEDED - MOVEI A,33 ;BREAKCHR TO C.R. - MOVEM A,BRKCH(B) - MOVEI A,"\ ;ESCAPER TO \ - MOVEM A,ESCAP(B) - MOVE A,[010700,,BYTPTR(E)] ;RELATIVE BYTE POINTER - MOVEM A,BYTPTR(B) - MOVEI A,14 ;BARF BACK CHARACTER FF - MOVEM A,BRFCHR(B) - MOVEI A,^D - MOVEM A,BRFCH2(B) - -; SETUP DEFAULT TTY INTERRUPT HANDLER - - PUSH TP,$TATOM - PUSH TP,MQUOTE CHAR,CHAR,INTRUP - PUSH TP,$TFIX - PUSH TP,[10] ; PRIORITY OF CHAR INT - PUSH TP,$TCHAN - PUSH TP,D - MCALL 3,EVENT ; 1ST MAKE AN EVENT EXIST - PUSH TP,A - PUSH TP,B - PUSH TP,$TSUBR - PUSH TP,[QUITTER] ; DEFAULT HANDLER IS QUITTER - MCALL 2,HANDLER - -; BUILD A NULL STRING - - MOVEI A,0 - PUSHJ P,IBLOCK ; USE A BLOCK - MOVE D,T.CHAN+1(TB) - MOVEI 0,C.BUF - IORM 0,-4(D) - HRLI B,440700 - MOVSI A,TCHSTR - MOVEM A,BUFSTR-1(D) - MOVEM B,BUFSTR(D) - MOVEI A,0 - MOVE B,D ; CHANNEL TO B - JRST MAKION - - -; ROUTINE TO OPEN ITS CHANNEL WITHOUT .RCHST - -OPEN2: MOVEI A,S.DEV(C) ; POINT TO OPEN BLOCK - PUSHJ P,MOPEN ; OPEN THE FILE - JRST OPNLOS - MOVE B,T.CHAN+1(TB) ; GET CHANNEL BACK - MOVEM A,CHANNO(B) ; SAVE THE CHANNEL - JRST OPEN3 - -; FIX UP MODE AND FALL INTO OPEN - -OPEN0: HRRZ A,S.DIR(C) ; GET DIR - TRNE A,2 ; SKIP IF NOT BLOCK - IORI A,4 ; TURN ON IMAGE - IORI A,2 ; AND BLOCK - - PUSH P,A - PUSH TP,$TPDL - PUSH TP,C ; SAVE CRUFT TO CHECK FOR PRINTO, HA HA - MOVE B,T.CHAN+1(TB) - MOVE A,DIRECT-1(B) - MOVE B,DIRECT(B) ; THIS KLUDGE THE MESS OF NDR - PUSHJ P,STRTO6 - MOVE C,(TP) - POP P,D ; THE SIXBIT FOR KLUDGE - POP P,A ; GET BACK THE RANDOM BITS - SUB TP,[2,,2] - CAME D,[SIXBIT /PRINTO/] - JRST OPEN9 ; WELL NOT THIS TIME - IORI A,100000 ; WRITEOVER BIT - - HRRZ 0,FSAV(TB) - CAIN 0,NFOPEN - IOR A,4 ; DON'T CHANGE REF DATE -OPEN9: HRLM A,S.DEV(C) ; AND STORE IT - -; ROUTINE TO ATTEMPT TO OPEN A REAL ITS CHANNEL - -OPEN1: MOVEI A,S.DEV(C) ; POINT TO OPEN BLOCK - PUSHJ P,MOPEN - JRST OPNLOS - MOVE B,T.CHAN+1(TB) ; GET CHANNEL BACK - MOVEM A,CHANNO(B) ; CLOBBER INTO CHANNEL - MOVSI A,(A) ; SET UP READ CHAN STATUS - HRRI A,S.DEV(C) - .RCHST A, ; GET THE GOODS - -; NOW CLOBBER THE TVP SLOT FOR THIS CHANNEL - -OPEN3: MOVE A,S.DIR(C) - MOVEI 0,C.OPN+C.READ - TRNE A,1 - MOVEI 0,C.OPN+C.PRIN - TRNE A,2 - TRO 0,C.BIN - HRRM 0,-4(B) - MOVE A,CHANNO(B) ; GET CHANNEL # - ASH A,1 - ADDI A,CHNL0(TVP) ; POINT TO SLOT - MOVEM B,1(A) ; NOT: TYPE ALREADY SETUP - -; NOW GET STATUS WORD - -DOSTAT: HRLZ A,CHANNO(B) ; NOW GET STATUS WORD - ROT A,5 - IOR A,[.STATUS STATUS(B)] ; GET INS - XCT A ; AND DO IT - POPJ P, - - -; HERE IF OPEN FAILS (CHANNEL IS IN A) - -OPNLOS: JUMPL A,NOCHAN ; ALL CHANNELS ARE IN USE - LSH A,23. ; DO A .STATUS - IOR A,[.STATUS A] - XCT A ; STATUS TO A - PUSHJ P,GFALS ; GET A FALSE WITH A MESSAGE - SUB P,[1,,1] ; EXTRA RET ADDR FLUSHED - JRST OPNRET ; AND RETURN - -; ROUTINE TO CONS UP FALSE WITH REASON - -GFALS: PUSH P,[SIXBIT / ERR/] ; SET UP OPEN TO ERR DEV - PUSH P,[3] ; SAY ITS FOR CHANNEL - PUSH P,A - .OPEN 0,-2(P) ; USE CHANNEL 0 FOR THIS - FATAL CAN'T OPEN ERROR DEVICE - SUB P,[3,,3] ; DONT WANT OPEN BLOCK NOW - MOVEI A,0 ; PREPARE TO BUILD STRING ON STACK -EL1: PUSH P,[0] ; WHERE IT WILL GO - MOVSI B,(<440700,,(P)>) ; BYTE POINTER TO TOP OF STACK -EL2: .IOT 0,0 ; GET A CHAR - JUMPL 0,EL3 ; JUMP ON -1,,3 - CAIN 0,3 ; EOF? - JRST EL3 ; YES, MAKE STRING - CAIN 0,14 ; IGNORE FORM FEEDS - JRST EL2 ; IGNORE FF - CAIE 0,15 ; IGNORE CR & LF - CAIN 0,12 - JRST EL2 - IDPB 0,B ; STUFF IT - TLNE B,760000 ; SIP IF WORD FULL - AOJA A,EL2 - AOJA A,EL1 ; COUNT WORD AND GO - -EL3: SKIPN (P) ; ANY CHARS AT END? - SUB P,[1,,1] ; FLUSH XTRA - PUSH P,A ; PUT UP COUNT - .CLOSE 0, ; CLOSE THE ERR DEVICE - PUSHJ P,CHMAK ; MAKE STRING - MOVE C,A - MOVE D,B ; COPY STRING - PUSHJ P,INCONS ; CONS TO NIL - MOVSI A,TFALSE ; MAKEIT A FALSE - POPJ P, - - -; ROUTINE TO FILL IN THE "REAL" SLOTS FOR THE CHANNEL - -FIXREA: HRLZS S.DEV(C) ; KILL MODE BITS - MOVE D,[-4,,S.DEV] - -FIXRE1: MOVEI A,(D) ; COPY REL POINTER - ADD A,T.SPDL+1(TB) ; POINT TO SLOT - SKIPN A,(A) ; SKIP IF GOODIE THERE - JRST FIXRE2 - PUSHJ P,6TOCHS ; MAKE INOT A STRING - MOVE C,RDTBL-S.DEV(D); GET OFFSET - ADD C,T.CHAN+1(TB) - MOVEM A,-1(C) - MOVEM B,(C) -FIXRE2: AOBJN D,FIXRE1 - POPJ P, - -DOOPN: PUSH P,A - HRLZ A,CHANNO(B) ; GET CHANNEL - ASH A,5 - HRR A,(P) ; POINT - TLO A,(.OPEN) - XCT A - SKIPA - AOS -1(P) - POP P,A - POPJ P, - -;THIS ROUTINE CONVERTS MUDDLE CHARACTER STRINGS TO SIXBIT FILE NAMES -STRTO6: PUSH TP,A - PUSH TP,B - PUSH P,E ;SAVE USEFUL FROB - MOVEI E,(A) ; CHAR COUNT TO E - GETYP A,A - CAIE A,TCHSTR ; IS IT ONE WORD? - JRST WRONGT ;NO -CHREAD: MOVEI A,0 ;INITIALIZE OUTPUT WORD - MOVE D,[440600,,A] ;AND BYTE POINTER TO IT -NEXCHR: SOJL E,SIXDON - ILDB 0,B ; GET NEXT CHAR - JUMPE 0,SIXDON ;IF NULL, WE ARE FINISHED - PUSHJ P,A0TO6 ; CONVERT TO SIXBIT - IDPB 0,D ;DEPOSIT INTO SIX BIT - TRNN A,77 ;IS OUTPUT FULL - JRST NEXCHR ; NO, GET NEXT -SIXDON: SUB TP,[2,,2] ;FIX UP TP - POP P,E - EXCH A,(P) ;LEAVE RESULT ON P-STACK - JRST (A) ;NOW RETURN - - -;SUBROUTINE TO CONVERT SIXBIT TO ATOM - -6TOCHS: PUSH P,E - PUSH P,D - MOVEI B,0 ;MAX NUMBER OF CHARACTERS - PUSH P,[0] ;STRING WILL GO ON P SATCK - JUMPE A,GETATM ; EMPTY, LEAVE - MOVEI E,-1(P) ;WILL BE BYTE POINTER - HRLI E,10700 ;SET IT UP - PUSH P,[0] ;SECOND POSSIBLE WORD - MOVE D,[440600,,A] ;INPUT BYTE POINTER -6LOOP: ILDB 0,D ;START CHAR GOBBLING - ADDI 0,40 ;CHANGET TOASCII - IDPB 0,E ;AND STORE IT - TLNN D,770000 ; SKIP IF NOT DONE - JRST 6LOOP1 - TDNN A,MSKS(B) ; CHECK IF JUST SPACES LEFT - AOJA B,GETATM ; YES, DONE - AOJA B,6LOOP ;KEEP LOOKING -6LOOP1: PUSH P,[6] ;IF ARRIVE HERE, STRING IS 2 WORDS - JRST .+2 -GETATM: MOVEM B,(P) ;SET STRING LENGTH=1 - PUSHJ P,CHMAK ;MAKE A MUDDLE STRING - POP P,D - POP P,E - POPJ P, - -MSKS: 7777,,-1 - 77,,-1 - ,,-1 - 7777 - 77 - - -; CONVERT ONE CHAR - -A0TO6: CAIL 0,141 ;IF IT IS GREATER OR EQUAL TO LOWER A - CAILE 0,172 ;BUT LESS THAN OR EQUAL TO LOWER Z - JRST .+2 ;THEN - SUBI 0,40 ;CONVERT TO UPPER CASE - SUBI 0,40 ;NOW TO SIX BIT - JUMPL 0,BAD6 ;CHECK FOR A WINNER - CAILE 0,77 - JRST BAD6 - POPJ P, - -; SUBR TO DELETE AND RENAME FILES - -MFUNCTION RENAME,SUBR - - ENTRY - - JUMPGE AB,TFA - PUSH TP,$TPDL - PUSH TP,P ; SAVE P-STACK BASE - GETYP 0,(AB) ; GET 1ST ARG TYPE -IFN ITS,[ - CAIN 0,TCHAN ; CHANNEL? - JRST CHNRNM ; MUST BE RENAME WHILE OPEN FOR WRITING -] -IFE ITS,[ - PUSH P,[100000,,0] - PUSH P,[377777,,377777] -] - MOVSI E,-4 ; 4 THINGS TO PUSH -RNMALP: MOVE B,@RNMTBL(E) - PUSH P,E - PUSHJ P,IDVAL1 - POP P,E - GETYP 0,A - CAIE 0,TCHSTR ; SKIP IF WINS - JRST RNMLP1 - -IFN ITS, PUSHJ P,STRTO6 ; CONVERT TO SIXBIT -IFE ITS, PUSH P,B ; PUSH BYTE POINTER - JRST .+2 - -RNMLP1: PUSH P,RNSTBL(E) ; USE DEFAULT - AOBJN E,RNMALP - -IFN ITS,[ - PUSHJ P,RGPRS ; PARSE THE ARGS - JRST RNM1 ; COULD BE A RENAME - -; HERE TO DELETE A FILE - -DELFIL: MOVEI A,0 ; SETUP FDELE - EXCH A,(P) ; AND GET SNAME - .SUSET [.SSNAM,,A] - HLRZS -3(P) ; FIXUP DEVICE - .FDELE -3(P) ; DO IT TO IT - JRST FDLST ; ANALYSE ERROR - -FDLWON: MOVSI A,TATOM - MOVE B,MQUOTE T - JRST FINIS -] -IFE ITS,[ - MOVE A,(TP) ; GET BASE OF PDL - MOVEI A,1(A) ; POINT TO CRAP - MOVE B,1(AB) ; STRING POINTER - PUSH P,[0] - PUSH P,[0] - PUSH P,[0] - GTJFN ; GET A JFN - JRST TDLLOS ; LOST - ADD AB,[2,,2] ; PAST ARG - JUMPL AB,RNM1 ; GO TRY FOR RENAME - MOVE P,(TP) ; RESTORE P STACK - MOVEI C,(A) ; FOR RELEASE - DELF ; ATTEMPT DELETE - JRST DELLOS ; LOSER - RLJFN ; MAKE SURE FLUSHED - JFCL - -FDLWON: MOVSI A,TATOM - MOVE B,MQUOTE T - JRST FINIS - -RNMLOS: PUSH P,A - MOVEI A,(B) - RLJFN - JFCL -DELLO1: MOVEI A,(C) - RLJFN - JFCL - POP P,A ; ERR NUMBER BACK -TDLLOS: PUSHJ P,TGFALS ; GET FALSE WITH REASON - JRST FINIS - -DELLOS: PUSH P,A ; SAVE ERROR - JRST DELLO1 -] - -;TABLE OF REANMAE DEFAULTS -IFN ITS,[ -RNMTBL: IMQUOTE DEV - IMQUOTE NM1 - IMQUOTE NM2 - IMQUOTE SNM - -RNSTBL: SIXBIT /DSK _MUDS_> / -] -IFE ITS,[ -RNMTBL: IMQUOTE DEV - IMQUOTE SNM - IMQUOTE NM1 - IMQUOTE NM2 - -RNSTBL: -1,,[ASCIZ /DSK/] - 0 - -1,,[ASCIZ /_MUDS_/] - -1,,[ASCIZ /MUD/] -] -; HERE TO DO A RENAME - -RNM1: JUMPGE AB,TMA ; IF ARGS EXHAUSTED, MUST BE TOO MUCH STRING - GETYP 0,(AB) - MOVE C,1(AB) ; GET ARG - CAIN 0,TATOM ; IS IT "TO" - CAME C,MQUOTE TO - JRST WRONGT ; NO, LOSE - ADD AB,[2,,2] ; BUMP PAST "TO" - JUMPGE AB,TFA -IFN ITS,[ - MOVEM P,T.SPDL+1(TB) ; SAVE NEW P-BASE - - MOVEI 0,4 ; FOUR DEFAULTS - PUSH P,-3(P) ; DEFAULT DEVICE IS CURRENT - SOJN 0,.-1 - - PUSHJ P,RGPRS ; PARSE THE NEXT STRING - JRST TMA - - HLRZS A,-7(P) ; FIX AND GET DEV1 - HLRZS B,-3(P) ; SAME FOR DEV2 - CAIE A,(B) ; SAME? - JRST DEVDIF - - POP P,A ; GET SNAME 2 - CAME A,(P)-3 ; SNAME 1 - JRST DEVDIF - .SUSET [.SSNAM,,A] - POP P,-2(P) ; MOVE NAMES DOWN - POP P,-2(P) - .FDELE -4(P) ; TRY THE RENAME - JRST FDLST - JRST FDLWON - -; HERE FOR RENAME WHILE OPEN FOR WRITING - -CHNRNM: ADD AB,[2,,2] ; NEXT ARG - JUMPGE AB,TFA - MOVE B,-1(AB) ; GET CHANNEL - SKIPN CHANNO(B) ; SKIP IF OPEN - JRST BADCHN - MOVE A,DIRECT-1(B) ; CHECK DIRECTION - MOVE B,DIRECT(B) - PUSHJ P,STRTO6 ; TO 6 BIT - POP P,A - CAME A,[SIXBIT /PRINT/] - CAMN A,[SIXBIT /PRINTB/] - JRST CHNRN1 - CAME A,[SIXBIT /PRINTO/] - JRST WRONGD - -; SET UP .FDELE BLOCK - -CHNRN1: PUSH P,[0] - PUSH P,[0] - MOVEM P,T.SPDL+1(TB) - PUSH P,[0] - PUSH P,[SIXBIT /_MUDL_/] - PUSH P,[SIXBIT />/] - PUSH P,[0] - - PUSHJ P,RGPRS ; PARSE THESE - JRST TMA - - SUB P,[1,,1] ; SNAME/DEV IGNORED - MOVE AB,ABSAV(TB) ; GET ORIG ARG POINTER - MOVE B,1(AB) - MOVE A,CHANNO(B) ; ITS CHANNEL # - MOVEM A,-2(P) - .FDELE -4(P) - JRST FDLST - MOVEI A,-4(P) ; SET UP FOR RDCHST - HRL A,CHANNO(B) - .RCHST A, - MOVE A,-3(P) ; UPDATE CHANNEL - PUSHJ P,6TOCHS ; GET A STRING - MOVE C,1(AB) - MOVEM A,RNAME1-1(C) - MOVEM B,RNAME1(C) - MOVE A,-2(P) - PUSHJ P,6TOCHS - MOVE C,1(AB) - MOVEM A,RNAME2-1(C) - MOVEM B,RNAME2(C) - MOVE B,1(AB) - MOVSI A,TCHAN - JRST FINIS -] -IFE ITS,[ - PUSH P,A - MOVE A,(TP) ; PBASE BACK - PUSH A,[400000,,0] - MOVEI A,(A) - MOVE B,1(AB) - GTJFN - JRST TDLLOS - POP P,B - EXCH A,B - MOVEI C,(A) ; FOR RELEASE ATTEMPT - RNAMF - JRST RNMLOS - MOVEI A,(B) - RLJFN ; FLUSH JFN - JFCL - MOVEI A,(C) ; MAKE SURR OTHER IS FLUSHED - RLJFN - JFCL - JRST FDLWON -] -; HERE FOR LOSING .FDELE - -FDLST: .STATUS 0,A ; GET STATUS - PUSHJ P,GFALS ; ANALYZE IT - JRST FINIS - -; SOME .FDELE ERRORS - -DEVDIF: PUSH TP,$TATOM - PUSH TP,EQUOTE DEVICE-OR-SNAME-DIFFERS - JRST CALER1 - - ; HERE TO RESET A READ CHANNEL - -MFUNCTION FRESET,SUBR,RESET - - ENTRY 1 - GETYP A,(AB) - CAIE A,TCHAN - JRST WTYP1 - MOVE B,1(AB) ;GET CHANNEL - SKIPN IOINS(B) ; OPEN? - JRST REOPE1 ; NO, IGNORE CHECKS -IFN ITS,[ - MOVE A,STATUS(B) ;GET STATUS - ANDI A,77 - JUMPE A,REOPE1 ;IF IT CLOSED, JUST REOPEN IT, MAYBE? - CAILE A,2 ;SKIPS IF TTY FLAVOR - JRST REOPEN -] -IFE ITS,[ - MOVE A,CHANNO(B) - CAIE A,100 ; TTY-IN - CAIN A,101 ; TTY-OUT - JRST .+2 - JRST REOPEN -] - CAME B,TTICHN+1(TVP) - CAMN B,TTOCHN+1(TVP) - JRST REATTY -REATT1: MOVEI B,DIRECT-1(B) ;POINT TO DIRECTION - PUSHJ P,CHRWRD ;CONVERT TO A WORD - JFCL - CAME B,[ASCII /READ/] - JRST TTYOPN - MOVE B,1(AB) ;RESTORE CHANNEL - PUSHJ P,RRESET" ;DO REAL RESET - JRST TTYOPN - -REOPEN: PUSH TP,(AB) ;FIRST CLOSE IT - PUSH TP,(AB)+1 - MCALL 1,FCLOSE - MOVE B,1(AB) ;RESTORE CHANNEL - -; SET UP TEMPS FOR OPNCH - -REOPE1: PUSH P,[0] ; WILL HOLD DIR CODE - PUSH TP,$TPDL - PUSH TP,P - IRP A,,[DIRECT,RNAME1,RNAME2,RDEVIC,RSNAME,ACCESS] - PUSH TP,A-1(B) - PUSH TP,A(B) - TERMIN - - PUSH TP,$TCHAN - PUSH TP,1(AB) - - MOVE A,T.DIR(TB) - MOVE B,T.DIR+1(TB) ; GET DIRECTION - PUSHJ P,CHMOD ; CHECK THE MODE - MOVEM A,(P) ; AND STORE IT - -; NOW SET UP OPEN BLOCK IN SIXBIT -IFN ITS,[ - MOVSI E,-4 ; AOBN PNTR -FRESE2: MOVE B,T.CHAN+1(TB) - MOVEI A,@RDTBL(E) ; GET ITEM POINTER - GETYP 0,-1(A) ; GET ITS TYPE - CAIE 0,TCHSTR - JRST FRESE1 - MOVE B,(A) ; GET STRING - MOVE A,-1(A) - PUSHJ P,STRTO6 -FRESE3: AOBJN E,FRESE2 - HLRZS -3(P) ; FIX DEVICE SPEC -] -IFE ITS,[ - MOVE B,T.CHAN+1(TB) - MOVE A,RDEVIC-1(B) - MOVE B,RDEVIC(B) - PUSHJ P,STRTO6 ; RESULT ON STACK - HLRZS (P) -] - - PUSH P,[0] ; PUSH UP SOME DUMMIES - PUSH P,[0] - PUSH P,[0] - PUSHJ P,OPNCH ; ATTEMPT TO DO THEOPEN - GETYP 0,A - CAIE 0,TCHAN - JRST FINIS ; LEAVE IF FALSE OR WHATEVER - -DRESET: MOVE A,(AB) - MOVE B,1(AB) - SETZM CHRPOS(B) ;INITIALIZE THESE PARAMETERS - SETZM LINPOS(B) - SETZM ACCESS(B) - JRST FINIS - -TTYOPN: MOVE B,1(AB) - CAME B,TTOCHN+1(TVP) - CAMN B,TTICHN+1(TVP) - PUSHJ P,TTYOP2 - PUSHJ P,DOSTAT - DOTCAL RSSIZE,[CHANNO(B),[2000,,C],[2000,,D]] - FATAL .CALL FAILURE - MOVEM C,PAGLN(B) - MOVEM D,LINLN(B) - JRST DRESET - -IFN ITS,[ -FRESE1: CAIE 0,TFIX - JRST BADCHN - PUSH P,(A) - JRST FRESE3 -] - -; INTERFACE TO REOPEN CLOSED CHANNELS - -OPNCHN: PUSH TP,$TCHAN - PUSH TP,B - MCALL 1,FRESET - POPJ P, - -REATTY: PUSHJ P,TTYOP2 - SKIPE NOTTY - JRST DRESET - MOVE B,1(AB) - JRST REATT1 - -; FUNCTION TO LIST ALL CHANNELS - -MFUNCTION CHANLIST,SUBR - - ENTRY 0 - - MOVEI A,N.CHNS-1 ;MAX # OF REAL CHANNELS - MOVEI C,0 - MOVEI B,CHNL1(TVP) ;POINT TO FIRST REAL CHANNEL - -CHNLP: SKIPN 1(B) ;OPEN? - JRST NXTCHN ;NO, SKIP - HRRZ E,(B) ; ABOUT TO FLUSH? - JUMPN E,NXTCHN ; YES, FORGET IT - MOVE D,1(B) ; GET CHANNEL - HRRZ E,CHANNO-1(D) ; GET REF COUNT - PUSH TP,(B) - PUSH TP,1(B) - ADDI C,1 ;COUNT WINNERS - SOJGE E,.-3 ; COUNT THEM -NXTCHN: ADDI B,2 - SOJN A,CHNLP - - SKIPN B,CHNL0(TVP)+1 ;NOW HACK LIST OF PSUEDO CHANNELS - JRST MAKLST -CHNLS: PUSH TP,(B) - PUSH TP,(B)+1 - ADDI C,1 - HRRZ B,(B) - JUMPN B,CHNLS - -MAKLST: ACALL C,LIST - JRST FINIS - - ; ROUTINE TO RESTORE A CLOSED CHANNEL TO ITS PREVIOUS STATE - - -REOPN: PUSH TP,$TCHAN - PUSH TP,B - SKIPN CHANNO(B) ; ONLY REAL CHANNELS - JRST PSUEDO - -IFN ITS,[ - MOVSI E,-4 ; SET UP POINTER FOR NAMES - -GETOPB: MOVE B,(TP) ; GET CHANNEL - MOVEI A,@RDTBL(E) ; GET POINTER - MOVE B,(A) ; NOW STRING - MOVE A,-1(A) - PUSHJ P,STRTO6 ; LEAVES SIXBIT ON STACK - AOBJN E,GETOPB -] -IFE ITS,[ - MOVE A,RDEVIC-1(B) - MOVE B,RDEVIC(B) - PUSHJ P,STRTO6 ; GET DEV NAME IN SIXBIT -] - MOVE B,(TP) ; RESTORE CHANNEL - MOVE A,DIRECT-1(B) - MOVE B,DIRECT(B) - PUSHJ P,CHMOD ; CHECK FOR A VALID MODE - -IFN ITS, HLRZS E,-3(P) ; GET DEVICE IN PROPER PLACE -IFE ITS, HLRZS E,(P) - MOVE B,(TP) ; RESTORE CHANNEL - CAIN E,(SIXBIT /DSK/) - JRST DISKH ; DISK WINS IMMEIDATELY - CAIN E,(SIXBIT /TTY/) ; NO NEED TO RE-OPEN THE TTY - JRST REOPD1 -IFN ITS,[ - ANDI E,777700 ; COULD BE "UTn" - MOVE D,CHANNO(B) ; GET CHANNEL - ASH D,1 - ADDI D,CHNL0(TVP) ; DON'T SEEM TO BE OPEN - SETZM 1(D) - SETZM CHANNO(B) - CAIN E,(SIXBIT /UT /) - JRST REOPD ; CURRENTLY, CANT RESTORE UTAPE CHANNLES - CAIN E,(SIXBIT /AI /) - JRST REOPD ; CURRENTLY CANT RESTORE AI CHANNELS - CAIN E,(SIXBIT /ML /) - JRST REOPD ; CURRENTLY CANT RESTORE ML CHANNELS - CAIN E,(SIXBIT /DM /) - JRST REOPD ; CURRENTLY CANT RESTORE DM CHANNELS -] - PUSH TP,$TCHAN ; TRY TO RESET IT - PUSH TP,B - MCALL 1,FRESET - -IFN ITS,[ -REOPD1: AOS -4(P) -REOPD: SUB P,[4,,4] -] -IFE ITS,[ -REOPD1: AOS -1(P) -REOPD: SUB P,[1,,1] -] -REOPD0: SUB TP,[2,,2] - POPJ P, - -IFN ITS,[ -DISKH: MOVE C,(P) ; SNAME - .SUSET [.SSNAM,,C] -] -IFE ITS,[ -DISKH: MOVEM A,(P) ; SAVE MODE WORD - PUSHJ P,STSTK ; STRING TO STACK - MOVE A,(E) ; RESTORE MODE WORD - PUSH TP,$TPDL - PUSH TP,E ; SAVE PDL BASE - MOVE B,-2(TP) ; CHANNEL BACK TO B -] - MOVE C,ACCESS(B) ; GET CHANNELS ACCESS - TRNN A,2 ; SKIP IF NOT ASCII CHANNEL - JRST DISKH1 - HRRZ D,ACCESS-1(B) ; IF PARTIAL WORD OUT - IMULI C,5 ; TO CHAR ACCESS - JUMPE D,DISKH1 ; NO SWEAT - ADDI C,(D) - SUBI C,5 -DISKH1: HRRZ D,BUFSTR-1(B) ; ANY CHARS IN MUDDLE BUFFER - JUMPE D,DISKH2 - PUSH P,A - PUSH P,C - MOVEI C,BUFSTR-1(B) - PUSHJ P,BYTDOP ; FIND LENGTH OF WHOLE BUFFER - HLRZ D,(A) ; LENGTH + 2 TO D - SUBI D,2 - IMULI D,5 ; TO CHARS - POP P,C - POP P,A -DISKH2: SUBI C,(D) ; UPDATE CHAR ACCESS - IDIVI C,5 ; BACK TO WORD ACCESS - IORI A,6 ; BLOCK IMAGE -IFN ITS,[ - TRNE A,1 - IORI A,100000 ; WRITE OVER BIT - HRLM A,-3(P) - MOVEI A,-3(P) - PUSHJ P,DOOPN - JRST REOPD - MOVE A,C ; ACCESS TO A - PUSHJ P,GETFLN ; CHECK LENGTH - CAIGE 0,(A) ; CHECK BOUNDS - JRST .+3 ; COMPLAIN - PUSHJ P,DOACCS ; AND ACESS - JRST REOPD1 ; SUCCESS - - MOVE A,CHANNO(B) ; CLOSE THE G.D. CHANNEL - PUSHJ P,MCLOSE - JRST REOPD - -DOACCS: PUSH P,A - HRLZ A,CHANNO(B) - ASH A,5 - IOR A,[.ACCESS (P)] - XCT A - POP P,A - POPJ P, - -DOIOTO: -DOIOTI: -DOIOT: - PUSH P,0 - MOVSI 0,TCHAN - MOVEM 0,BSTO(PVP) ; IN CASE OF INTERRUPT - ENABLE - HRLZ 0,CHANNO(B) - ASH 0,5 - IOR 0,[.IOT A] - XCT 0 - DISABLE - SETZM BSTO(PVP) - POP P,0 - POPJ P, - -GETFLN: MOVE 0,CHANNO(B) ; GET CHANNEL - .CALL FILBLK ; READ LNTH - .VALUE - POPJ P, - -FILBLK: SETZ - SIXBIT /FILLEN/ - 0 - 402000,,0 ; STUFF RESULT IN 0 -] -IFE ITS,[ - - HRROI B,1(E) ; TENEX STRING POINTER - MOVEI A,1(P) ; A POINT TO BLOCK OF INFO - PUSH P,[100400,,0] ; FORCE JFN REUSE AND ONLY ACCEPT EXISTING FILE - PUSH P,[377777,,377777] ; NO I/O FOR CORRECTIONS ETC. - REPEAT 6,PUSH P,[0] ; OTHER SLOTS - MOVE D,-2(TP) ; CHANNEL BACK - PUSH P,CHANNO(D) ; AND DESIRED JFN - GTJFN ; GO GET IT - JRST RGTJL ; COMPLAIN - MOVE P,(TP) ; RESTORE P - MOVE A,(P) ; MODE WORD BACK - MOVE B,[440000,,200000] ; FLAG BITS - TRNE A,1 ; SKIP FOR INPUT - TRC B,300000 ; CHANGE TO WRITE - MOVE A,CHANNO(D) ; GET JFN - OPENF - JRST ROPFLS - MOVE E,C ; LENGTH TO E - SIZEF ; GET CURRENT LENGTH - JRST ROPFLS - CAMGE B,E ; STILL A WINNER - JRST ROPFLS - MOVE A,-2(TP) ; CHANNEL - MOVE A,CHANNO(A) ; JFN - MOVE B,C - SFPTR - JRST ROPFLS - SUB TP,[2,,2] ; FLUSH PDL POINTER - JRST REOPD1 - -ROPFLS: MOVE A,-2(TP) - MOVE A,CHANNO(A) - CLOSF ; ATTEMPT TO CLOSE - JFCL ; IGNORE FAILURE - SKIPA - -RGTJL: MOVE P,(TP) - SUB TP,[2,,2] - JRST REOPD - -DOACCS: PUSH P,B - EXCH A,B - MOVE A,CHANNO(A) - SFPTR - JRST ACCFAI - POP P,B - POPJ P, -] -PSUEDO: AOS (P) ; ASSUME SUCCESS FOR NOW - MOVEI B,RDEVIC-1(B) ; SEE WHAT DEVICE IS - PUSHJ P,CHRWRD - JFCL - CAME B,[ASCII /E&S/] ; DISPLAY ? - CAMN B,[ASCII /DIS/] - SKIPA B,(TP) ; YES, REGOBBLE CHANNEL AND CONTINUE - JRST REOPD0 ; NO, RETURN HAPPY - PUSHJ P,DISROP - SOS (P) ; DISPLAY DID NOT REOPEN, UNDO ASSUMPTION OF SUCCESS - JRST REOPD0 - - ;THIS PROGRAM CLOSES THE SPECIFIED CHANNEL - -MFUNCTION FCLOSE,SUBR,[CLOSE] - - ENTRY 1 ;ONLY ONE ARG - GETYP A,(AB) ;CHECK ARGS - CAIE A,TCHAN ;IS IT A CHANNEL - JRST WTYP1 - MOVE B,1(AB) ;PICK UP THE CHANNEL - HRRZ A,CHANNO-1(B) ; GET REF COUNT - SOJGE A,CFIN5 ; NOT READY TO REALLY CLOSE - CAME B,TTICHN+1(TVP) ; CHECK FOR TTY - CAMN B,TTOCHN+1(TVP) - JRST CLSTTY - MOVE A,[JRST CHNCLS] - MOVEM A,IOINS(B) ;CLOBBER THE IO INS - MOVE A,RDEVIC-1(B) ;GET THE NAME OF THE DEVICE - MOVE B,RDEVIC(B) - PUSHJ P,STRTO6 - HLRZS A,(P) - MOVE B,1(AB) ; RESTORE CHANNEL - CAIE A,(SIXBIT /E&S/) - CAIN A,(SIXBIT /DIS/) - PUSHJ P,DISCLS - MOVE B,1(AB) ; IN CASE CLOBBERED BY DISCLS - SKIPN A,CHANNO(B) ;ANY REAL CHANNEL? - JRST REMOV ; NO, EITHER CLOSED OR PSEUDO CHANNEL - - MOVE A,DIRECT-1(B) ; POINT TO DIRECTION - MOVE B,DIRECT(B) - PUSHJ P,STRTO6 ; CONVERT TO WORD - POP P,A - LDB E,[140600,,(P)] ; FIRST CHAR OD DEV NAME - CAIE E,'T ; SKIP IF TTY - JRST CFIN4 - CAME A,[SIXBIT /READ/] ; SKIP IF WINNER - JRST CFIN1 -IFN ITS,[ - MOVE B,1(AB) ; IN ITS CHECK STATUS - LDB A,[600,,STATUS(B)] - CAILE A,2 - JRST CFIN1 -] - PUSH TP,$TCHSTR - PUSH TP,CHQUOTE CHAR - PUSH TP,(AB) - PUSH TP,1(AB) - MCALL 2,OFF ; TURN OFF INTERRUPT -CFIN1: MOVE B,1(AB) - MOVE A,CHANNO(B) -IFN ITS,[ - PUSHJ P,MCLOSE -] -IFE ITS,[ - TLZ A,400000 ; FOR JFN RELEASE - CLOSF ; CLOSE THE FILE AND RELEASE THE JFN - JFCL - MOVE A,CHANNO(B) -] -CFIN: LSH A,1 - ADDI A,CHNL0+1(TVP) ;POINT TO THIS CHANNELS LSOT - SETZM CHANNO(B) - SETZM (A) ;AND CLOBBER IT - HLLZS BUFSTR-1(B) - SETZM BUFSTR(B) - HLLZS ACCESS-1(B) -CFIN2: HLLZS -4(B) - MOVSI A,TCHAN ;RETURN THE CHANNEL - JRST FINIS - -CLSTTY: PUSH TP,$TATOM - PUSH TP,EQUOTE ATTEMPT-TO-CLOSE-TTY-CHANNEL - JRST CALER1 - - -REMOV: MOVEI D,CHNL0(TVP)+1 ;ATTEMPT TO REMOVE FROM PSUEDO CHANNEL LIST -REMOV0: SKIPN C,D ;FOUND ON LIST ? - JRST CFIN2 ;NO, JUST IGNORE THIS CLOSED CHANNEL - HRRZ D,(C) ;GET POINTER TO NEXT - CAME B,(D)+1 ;FOUND ? - JRST REMOV0 - HRRZ D,(D) ;YES, SPLICE IT OUT - HRRM D,(C) - JRST CFIN2 - - -; CLOSE UP ANY LEFTOVER BUFFERS - -CFIN4: CAME A,[SIXBIT /PRINTO/] - CAMN A,[SIXBIT /PRINTB/] - JRST .+3 - CAME A,[SIXBIT /PRINT/] - JRST CFIN1 - MOVE B,1(AB) ; GET CHANNEL - GETYP 0,BUFSTR-1(B) ; IS THERE AN OUTPUT BUFFER - SKIPN BUFSTR(B) - JRST CFIN1 - CAIE 0,TCHSTR - JRST CFINX1 -IFE ITS, PUSH P,A ; SAVE MODE - PUSHJ P,BFCLOS -IFE ITS,[ - POP P,A ; RESTORE MODE - MOVE 0,RDEVIC(B) - ILDB 0,0 - CAIN 0,"D - CAME A,[SIXBIT /PRINT/] - JRST CFINX1 - MOVE A,CHANNO(B) ; GET JFN - TLO A,400000 ; BIT MEANS DONT RELEASE JFN - CLOSF ; CLOSE THE FILE - FATAL CLOSF LOST? - MOVE E,B ; SAVE CHANNEL - MOVE A,CHANNO(B) - HRLI A,11 - MOVSI B,7700 ; MASK - MOVSI C,700 ; MAKE NEW SIZE 7 - CHFDB - HRLI A,12 - SETOM B - MOVE C,ACCESS(E) ; LENGTH IN CHARS - CHFDB -] - HLLZS BUFSTR-1(B) - SETZM BUFSTR(B) -CFINX1: HLLZS ACCESS-1(B) - JRST CFIN1 - -CFIN5: HRRM A,CHANNO-1(B) - JRST CFIN2 - ;SUBR TO DO .ACCESS ON A READ CHANNEL -;FORM: -;POSITIONS CHANNEL AT CHARACTER POSN FIX-NUMBER -;H. BRODIE 7/26/72 - -MFUNCTION MACCESS,SUBR,[ACCESS] - ENTRY 2 ;ARGS: CHANNEL AND FIX-NUMBER - -;CHECK ARGUMENT TYPES - GETYP A,(AB) - CAIE A,TCHAN ;FIRST ARG SHOULD BE CHANNEL - JRST WTYP1 - GETYP A,2(AB) ;TYPE OF SECOND - CAIE A,TFIX ;SHOULD BE FIX - JRST WTYP2 - -;CHECK DIRECTION OF CHANNEL - MOVE B,1(AB) ;B GETS PNTR TO CHANNEL - MOVEI B,DIRECT-1(B) ;GET DIRECTION OF CHANNEL - PUSHJ P,CHRWRD ;GRAB THE CHAR STRNG - JFCL - CAME B,[+1] - JRST MACCA - PUSH P,[2] ;ACCESS ON PRINTB CHANNEL - MOVE B,1(AB) - SKIPE BUFSTR(B) ;SEE IF WE MUST FLUSH PART BUFFER - PUSHJ P,BFCLS1 - JRST MACC -MACCA: PUSH P,[0] ; READ RATHER THAN READB INDICATOR - CAMN B,[ASCIZ /READ/] - JRST .+4 - CAME B,[ASCIZ /READB/] ; READB CHANNEL? - JRST WRONGD - AOS (P) ; SET INDICATOR FOR BINARY MODE - -;CHECK THAT THE CHANNEL IS OPEN -MACC: MOVE B,1(AB) ;GET BACK PTR TO CHANNEL - SKIPN CHANNO(B) ;CLOSED CHANNELS HAVE CHANNO ZEROED OUT - JRST CHNCLS ;IF CHNL CLOSED => ERROR - -;COMPUTE ACCESS PNTR TO ACCESS WORD CHAR IS IN -;REMAINDER IS NUMBER OF TIMES TO INCR BYTE POINTER -ADEVOK: SKIPGE C,3(AB) ;GET CHAR POSN...ALL NEGS = -5 - MOVNI C,-5 -;BUT .ACCESS -1 ISN'T IMPLEMENTED ON ITS YET, SO TELL HIM - JUMPGE C,MACC1 - PUSH TP,$TATOM - PUSH TP,EQUOTE NEGATIVE-ACCESS-NOT-ON-ITS - JRST CALER1 -MACC1: SKIPN (P) - IDIVI C,5 - -;SETUP THE .ACCESS - MOVE B,1(AB) ;GET BACK PTR TO CHANNEL - MOVE A,CHANNO(B) ;A GETS REAL CHANNEL NUMBER -IFN ITS,[ - ROT A,23. ;SET UP IN AC FIELD - IOR A,[.ACCESS 0,C] ;C CONTAINS PLACE TO ACCESS TO - -;DO IT TO IT! - XCT A -] -IFE ITS,[ - MOVE B,C - SFPTR ; DO IT IN TENEX - JRST ACCFAI - MOVE B,1(AB) ; RESTORE CHANNEL -] - POP P,E ; CHECK FOR READB MODE - CAIN E,2 - JRST DONADV ; PRINTB CHANNEL - SKIPE BUFSTR(B) ; IS THERE A READ BUFFER TO FLUSH - JRST .+3 - SETZM LSTCH(B) ; CLEAR OUT POSSIBLE EOF INDICATOR - JRST DONADV - -;NOW FORCE GETCHR TO DO A .IOT FIRST THING - MOVEI C,BUFSTR-1(B) ; FIND END OF STRING - PUSHJ P,BYTDOP" - SUBI A,2 ; LAST REAL WORD - HRLI A,010700 - MOVEM A,BUFSTR(B) - HLLZS BUFSTR-1(B) ; CLOBBER CHAR COUNT - MOVEM A,BUFSTR(B) - SETZM LSTCH(B) ;CLOBBER READ'S HIDDEN CHARACTER - -;NOW DO THE APPROPRIATE NUM OF BYTE ADVANCEMENTS - JUMPLE D,DONADV -ADVPTR: PUSHJ P,GETCHR - MOVE B,1(AB) ;RESTORE IN CASE CLOBBERED - SOJG D,ADVPTR - -DONADV: MOVE C,3(AB) ;FIXUP ACCESS SLOT IN CHNL - MOVEM C,ACCESS(B) - MOVE A,$TCHAN ;TYPE OF RESULT = "CHANNEL" - JRST FINIS ;DONE...B CONTAINS CHANNEL - -IFE ITS,[ -ACCFAI: PUSH TP,$TATOM - PUSH TP,EQUOTE ACCESS-FAILURE - JRST CALER1 -] - - -;WRONG TYPE OF DEVICE ERROR -WRDEV: PUSH TP,$TATOM - PUSH TP,EQUOTE NON-DSK-DEVICE - JRST CALER1 - -; BINARY READ AND PRINT ROUTINES - -MFUNCTION PRINTB,SUBR - - ENTRY 2 - -PBFL: PUSH P,. ; PUSH NON-ZERONESS - JRST BINI1 - -MFUNCTION READB,SUBR - - ENTRY - - PUSH P,[0] - HLRZ 0,AB - CAIG 0,-3 - CAIG 0,-7 - JRST WNA - -BINI1: GETYP 0,(AB) ; SHOULD BE UVEC OR STORE - CAIN 0,TUVEC - JRST BINI2 - CAIE 0,TSTORAGE - JRST WTYP1 ; ELSE LOSE -BINI2: MOVE B,1(AB) ; GET IT - HLRE C,B - SUBI B,(C) ; POINT TO DOPE - GETYP A,(B) - PUSHJ P,SAT" ; GET ITS ST.ALOC.TYPE - CAIE A,S1WORD - JRST WTYP1 - GETYP 0,2(AB) - CAIE 0,TCHAN ; BETTER BE A CHANNEL - JRST WTYP2 - MOVE B,3(AB) ; GET IT - MOVEI B,DIRECT-1(B) ; GET DIRECTION OF - PUSHJ P,CHRWRD ; INTO 1 WORD - JFCL - MOVNI E,1 - CAMN B,[ASCII /READB/] - MOVEI E,0 - CAMN B,[+1] - MOVE E,PBFL - JUMPL E,WRONGD ; LOSER - CAME E,(P) ; CHECK WINNGE - JRST WRONGD - MOVE B,3(AB) ; GET CHANNEL BACK - SKIPN A,IOINS(B) ; OPEN? - PUSHJ P,OPENIT ; LOSE - CAMN A,[JRST CHNCLS] - JRST CHNCLS ; LOSE, CLOSED - JUMPN E,BUFOU1 ; JUMP FOR OUTPUT - CAML AB,[-5,,] ; SKIP IF EOF GIVEN - JRST BINI5 - MOVE 0,4(AB) - MOVEM 0,EOFCND-1(B) - MOVE 0,5(AB) - MOVEM 0,EOFCND(B) -BINI5: SKIPE LSTCH(B) ; INDICATES IF EOF HIT - JRST BINEOF - MOVE A,1(AB) ; GET VECTOR - PUSHJ P,PGBIOI ; READ IT - HLRE C,A ; GET COUNT DONE - HLRE D,1(AB) ; AND FULL COUNT - SUB C,D ; C=> TOTAL READ - ADDM C,ACCESS(B) - JUMPGE A,BINIOK ; NOT EOF YET - SETOM LSTCH(B) -BINIOK: MOVE B,C - MOVSI A,TFIX ; RETURN AMOUNT ACTUALLY READ - JRST FINIS - -BUFOU1: SKIPE BUFSTR(B) ; ANY BUFFERS AROUND? - PUSHJ P,BFCLS1 ; GET RID OF SAME - MOVE A,1(AB) - PUSHJ P,PGBIOO - HLRE C,1(AB) - MOVNS C - addm c,ACCESS(B) - MOVE A,(AB) ; RET VECTOR ETC. - MOVE B,1(AB) - JRST FINIS - - -BINEOF: PUSH TP,EOFCND-1(B) - PUSH TP,EOFCND(B) - PUSH TP,$TCHAN - PUSH TP,B - MCALL 1,FCLOSE ; CLOSE THE LOSER - MCALL 1,EVAL - JRST FINIS - -OPENIT: PUSH P,E - PUSHJ P,OPNCHN ;TRY TO OPEN THE LOSER - JUMPE B,CHNCLS ;FAIL - POP P,E - POPJ P, - ; THESE SUBROUTINES BY NDR 9/16/73 TO FACILITATE THE -; TYPES OF IO NECESSARY TO MAKE MORE EFFICIENT USE OF -; THE NETWORK AND DO RELATED FILE TRANSFER TYPE OF JOBS. - -R1CHAR: SKIPN A,LSTCH(B) ; CHAR READING ROUTINE FOR FCOPY - PUSHJ P,RXCT - MOVEM A,LSTCH(B) - JUMPL A,.+2 ; IN CASE OF -1 ON STY - TRZN A,400000 ; EXCL HACKER - JRST .+4 - MOVEM A,LSTCH(B) ; SAVE DE-EXCLED CHAR - MOVEI A,"! - JRST .+2 - SETZM LSTCH(B) - PUSH P,C - HRRZ C,DIRECT-1(B) - CAIE C,5 ; IF DIRECTION IS 5 LONG THEN READB - JRST R1CH1 - AOS C,ACCESS-1(B) - CAMN C,[TFIX,,1] - AOS ACCESS(B) ; EVERY FIFTY INCREMENT - CAMN C,[TFIX,,5] - HLLZS ACCESS-1(B) - JRST .+2 -R1CH1: AOS ACCESS(B) - POP P,C - POPJ P, - -W1CHAR: CAIE A,15 ; CHAR WRITING ROUTINE, TEST FOR CR - JRST .+3 - SETOM CHRPOS(B) - AOSA LINPOS(B) - CAIE A,12 ; TEST FOR LF - AOS CHRPOS(B) ; IF NOT LF AOS CHARACTE5R POSITION - CAIE A,14 ; TEST FOR FORM FEED - JRST .+3 - SETZM CHRPOS(B) ; IF FORM FEED ZERO CHARACTER POSITION - SETZM LINPOS(B) ; AND LINE POSITION - CAIE A,11 ; IS THIS A TAB? - JRST .+6 - MOVE C,CHRPOS(B) - ADDI C,7 - IDIVI C,8. - IMULI C,8. ; FIX UP CHAR POS FOR TAB - MOVEM C,CHRPOS(B) ; AND SAVE - PUSH P,C - HRRZ C,DIRECT-1(B) - CAIE C,6 ; SIX LONG MUST BE PRINTB - JRST W1CH1 - AOS C,ACCESS-1(B) - CAMN C,[TFIX,,1] - AOS ACCESS(B) - CAMN C,[TFIX,,5] - HLLZS ACCESS-1(B) - JRST .+2 -W1CH1: AOS ACCESS(B) - PUSHJ P,WXCT - POP P,C - POPJ P, - -R1C: SUBM M,(P) ;LITTLE ENTRY FOR COMPILED STUFF - PUSH TP,$TCHAN ;SAVE THE CHANNEL TO BLESS IT - PUSH TP,B - MOVEI B,DIRECT-1(B) - PUSHJ P,CHRWRD - JFCL - CAME B,[ASCIZ /READ/] - CAMN B,[ASCII /READB/] - JRST .+2 - JRST BADCHN - POP TP,B - POP TP,(TP) - SKIPN IOINS(B) ; IS THE CHANNEL OPEN - PUSHJ P,OPENIT ; NO, GO DO IT - PUSHJ P,GRB ; MAKE SURE WE HAVE A READ BUFFER - PUSHJ P,R1CHAR ; AND GET HIM A CHARACTER - JRST MPOPJ ; THATS ALL FOLKS - -W1C: SUBM M,(P) - PUSHJ P,W1CI - JRST MPOPJ - -W1CI: PUSH TP,$TCHAN - PUSH TP,B - PUSH P,A ; ASSEMBLER ENTRY TO OUTPUT 1 CHAR - MOVEI B,DIRECT-1(B) - PUSHJ P,CHRWRD ; INTERNAL CALL TO W1CHAR - JFCL - CAME B,[ASCII /PRINT/] - CAMN B,[+1] - JRST .+2 - JRST BADCHN - POP TP,B - POP TP,(TP) - SKIPN IOINS(B) ; MAKE SURE THAT IT IS OPEN - PUSHJ P,OPENIT - PUSHJ P,GWB - POP P,A ; GET THE CHAR TO DO - JRST W1CHAR - -; ROUTINES TO REPLACE XCT IOINS(B) FOR INPUT AND OUTPUT -; THEY DO THE XCT THEN CHECK OUT POSSIBLE SCRIPTAGE--BLECH. - - -WXCT: PUSH P,A ; SAVE THE CHAR TO WRITE - PUSH TP,$TCHAN ; AND SAVE THE CHANNEL TOO - PUSH TP,B - XCT IOINS(B) ; DO THE REAL ONE - JRST DOSCPT ; AND CHECK OUT SCRIPTAGE - -RXCT: PUSH TP,$TCHAN - PUSH TP,B ; DO IT FOR READS, SAVE THE CHAN - XCT IOINS(B) ; READ IT - PUSH P,A ; AND SAVE THE CHAR AROUND - JRST DOSCPT ; AND CHECK OUT SCRIPTAGE - -DOSCPT: MOVE B,(TP) ;CHECK FOR SCRIPTAGE - SKIPN SCRPTO(B) ; IF ZERO FORGET IT - JRST SCPTDN ; THATS ALL THERE IS TO IT - PUSH P,C ; SAVE AN ACCUMULATOR FOR CLEANLINESS - GETYP C,SCRPTO-1(B) ; IS IT A LIST - CAIE C,TLIST - JRST BADCHN - PUSH TP,$TLIST - PUSH TP,[0] ; SAVE A SLOT FOR THE LIST - MOVE C,SCRPTO(B) ; GET THE LIST OF SCRIPT CHANNELS -SCPT1: GETYP B,(C) ; GET THE TYPE OF THIS SCRIPT CHAN - CAIE B,TCHAN - JRST BADCHN ; IF IT ISN'T A CHANNEL, COMPLAIN - HRRZ B,(C) ; GET THE REST OF THE LIST IN B - MOVEM B,(TP) ; AND STORE ON STACK - MOVE B,1(C) ; GET THE CHANNEL IN B - MOVE A,-1(P) ; AND THE CHARACTER IN A - PUSHJ P,W1CI ; GO TO INTERNAL W1C, IT BLESSES GOODIES - SKIPE C,(TP) ; GET THE REST OF LIST OF CHANS - JRST SCPT1 ; AND CYCLE THROUGH - SUB TP,[2,,2] ; CLEAN OFF THE LIST OF CHANS - POP P,C ; AND RESTORE ACCUMULATOR C -SCPTDN: POP P,A ; RESTORE THE CHARACTER - POP TP,B ; AND THE ORIGINAL CHANNEL - POP TP,(TP) - POPJ P, ; AND THATS ALL - - -; SUBROUTINE TO COPY FROM INCHAN TO OUTCHAN UNTIL EOF HIT -; ON THE INPUT CHANNEL -; CALL IS WHERE DEFAULTS ARE INCHAN AND OUTCHAN - - MFUNCTION FCOPY,SUBR,[FILECOPY] - - ENTRY - HLRE 0,AB - CAMGE 0,[-4] - JRST WNA ; TAKES FROM 0 TO 2 ARGS - - JUMPE 0,.+4 ; NO FIRST ARG? - PUSH TP,(AB) - PUSH TP,1(AB) ; SAVE IN CHAN - JRST .+6 - MOVE A,$TATOM - MOVE B,IMQUOTE INCHAN - PUSHJ P,IDVAL - PUSH TP,A - PUSH TP,B - HLRE 0,AB ; CHECK FOR SECOND ARG - CAML 0,[-2] ; WAS THERE MORE THAN ONE ARG? - JRST .+4 - PUSH TP,2(AB) ; SAVE SECOND ARG - PUSH TP,3(AB) - JRST .+6 - MOVE A,$TATOM ; LOOK UP OUTCHAN AS DEFAULT - MOVE B,IMQUOTE OUTCHAN - PUSHJ P,IDVAL - PUSH TP,A - PUSH TP,B ; AND SAVE IT - - MOVE A,-3(TP) - MOVE B,-2(TP) ; INPUT CHANNEL - MOVEI 0,0 ; INDICATE INPUT - PUSHJ P,CHKCHN ; CHECK FOR GOOD CHANNEL - MOVE A,-1(TP) - MOVE B,(TP) ; GET OUT CHAN - MOVEI 0,1 ; INDICATE OUT CHAN - PUSHJ P,CHKCHN ; CHECK FOR GOOD OUT CHAN - - PUSH P,[0] ; COUNT OF CHARS OUTPUT - - MOVE B,-2(TP) - PUSHJ P,GRB ; MAKE SURE WE HAVE READ BUFF - MOVE B,(TP) - PUSHJ P,GWB ; MAKE SURE WE HAVE WRITE BUFF - -FCLOOP: MOVE B,-2(TP) - PUSHJ P,R1CHAR ; GET A CHAR - JUMPL A,FCDON ; IF A NEG NUMBER WE GOT EOF - MOVE B,(TP) ; GET OUT CHAN - PUSHJ P,W1CHAR ; SPIT IT OUT - AOS (P) ; INCREMENT COUNT - JRST FCLOOP - -FCDON: SUB TP,[2,,2] ; POP OFF OUTCHAN - MCALL 1,FCLOSE ; CLOSE INCHAN - MOVE A,$TFIX - POP P,B ; GET CHAR COUNT TO RETURN - JRST FINIS - -CHKCHN: PUSH P,0 ; CHECK FOR GOOD TASTING CHANNEL - PUSH TP,A - PUSH TP,B - GETYP C,A - CAIE C,TCHAN - JRST CHKBDC ; GO COMPLAIN IN RIGHT WAY - MOVEI B,DIRECT-1(B) - PUSHJ P,CHRWRD - JRST CHKBDC - MOVE C,(P) ; GET CHAN DIRECT - CAMN B,CHKT(C) - JRST .+4 - ADDI C,2 ; TEST FOR READB OR PRINTB ALSO - CAME B,CHKT(C) ; TEST FOR CORRECT DIRECT - JRST CHKBDC - MOVE B,(TP) - SKIPN IOINS(B) ; MAKE SURE IT IS OPEN - PUSHJ P,OPENIT ; IF ZERO IOINS GO OPEN IT - SUB TP,[2,,2] - POP P, ; CLEAN UP STACKS - POPJ P, - -CHKT: ASCIZ /READ/ - ASCII /PRINT/ - ASCII /READB/ - +1 - -CHKBDC: POP P,E - MOVNI D,2 - IMULI D,1(E) - HLRE 0,AB - CAMLE 0,D ; SEE IF THIS WAS HIS ARG OF DEFAULT - JRST BADCHN - JUMPE E,WTYP1 - JRST WTYP2 - - ; FUNCTIONS READSTRING AND PRINTSTRING WORK LIKE READB AND PRINTB, -; THAT IS THEY READ INTO AND OUT OF STRINGS. IN ADDITION BOTH ACCEPT -; AN ADDITIONAL ARGUMENT WHICH IS THE NUMBER OF CHARS TO READ OR PRINT, IF -; IT IS DESIRED FOR THIS TO BE DIFFERENT THAN THE LENGTH OF THE STRING. - -; FORMAT IS -; AND BOTH SUBRS RETURN THE NUMBER OF CHARS READ OR WRITTEN - -; FORMAT FOR PRINTSTRING IS - -; THESE WERE CODED 9/16/73 BY NEAL D. RYAN - - MFUNCTION RSTRNG,SUBR,READSTRING - - ENTRY - PUSH P,[0] ; FLAG TO INDICATE READING - HLRE 0,AB - CAMG 0,[-1] - CAMG 0,[-9] - JRST WNA ; CHECK THAT IT HAS FROM 1 TO 4 ARGS - JRST STRIO1 - - MFUNCTION PSTRNG,SUBR,PRINTSTRING - - ENTRY - PUSH P,[1] ; FLAG TO INDICATE WRITING - HLRE 0,AB - CAMG 0,[-1] - CAMG 0,[-7] - JRST WNA ; CHECK THAT IT HAS FROM 1 TO 3 ARGS - -STRIO1: PUSH TP,[0] ; SAVE SLOT ON STACK - PUSH TP,[0] - GETYP 0,(AB) - CAIE 0,TCHSTR ; MAKE SURE WE GOT STRING - JRST WTYP1 - HRRZ 0,(AB) ; CHECK FOR EMPTY STRING - SKIPN (P) - JUMPE 0,MTSTRN - HLRE 0,AB - CAML 0,[-2] ; WAS A CHANNEL GIVEN - JRST STRIO2 - GETYP 0,2(AB) - CAIE 0,TCHAN - JRST WTYP2 ; SECOND ARG NOT CHANNEL - MOVE B,3(AB) - MOVEI B,DIRECT-1(B) - PUSHJ P,CHRWRD - JFCL - MOVNI E,1 ; CHECKING FOR GOOD DIRECTION - CAMN B,[ASCII /READ/] - MOVEI E,0 - CAMN B,[ASCII /PRINT/] - MOVEI E,1 - CAMN B,[+1] - MOVEI E,1 - CAMN B,[ASCII /READB/] - MOVEI E,0 - CAME E,(P) - JRST WRONGD ; MAKE SURE CHANNEL IS OPEN IN RIGHT MODE - PUSH TP,2(AB) - PUSH TP,3(AB) ; PUSH ON CHANNEL - JRST STRIO3 -STRIO2: MOVE B,IMQUOTE INCHAN - MOVSI A,TCHAN - SKIPE (P) - MOVE B,IMQUOTE OUTCHAN - PUSHJ P,IDVAL - TLZ A,TYPMSK#777777 - CAME A,$TCHAN - JRST BADCHN ; MAKE SURE WE GOT A GOOD DEFAULT CHANNEL - PUSH TP,A - PUSH TP,B -STRIO3: MOVE B,(TP) ; GET CHANNEL - SKIPN E,IOINS(B) ; MAKE SURE HE IS OPEN - PUSHJ P,OPENIT ; IF NOT GO OPEN - CAMN E,[JRST CHNCLS] - JRST CHNCLS ; CHECK TO SEE THAT CHANNEL ISNT ALREADY CLOSED -STRIO4: HLRE 0,AB - CAML 0,[-4] - JRST STRIO5 ; NO COUNT TO WORRY ABOUT - GETYP 0,4(AB) - MOVE E,4(AB) - MOVE C,5(AB) - CAIE 0,TCHSTR - CAIN 0,TFIX ; BETTER BE A FIXED NUMBER - JRST .+2 - JRST WTYP3 - HRRZ D,(AB) ; GET ACTUAL STRING LENGTH - CAIN 0,TFIX - JRST .+7 - SKIPE (P) ; TEST FOR WRITING - JRST .-7 ; IF WRITING WE GOT TROUBLE - PUSH P,D ; ACTUAL STRING LENGTH - MOVEM E,(TB) ; STUFF HIS FUNNY DELIM STRING - MOVEM C,1(TB) - JRST STRIO7 - CAML D,C ; MAKE SURE THE STRING IS LONG ENOUGH - JRST .+4 ; WIN - PUSH TP,$TATOM ; LOSAGE, COUNT TOO GREAT - PUSH TP,EQUOTE COUNT-GREATER-THAN-STRING-SIZE - JRST CALER1 - PUSH P,C ; PUSH ON MAX COUNT - JRST STRIO7 -STRIO5: -STRIO6: HRRZ C,(AB) ; GET CHAR COUNT - PUSH P,C ; AND PUSH IT ON STACK AS NO MAX COUNT GIVEN -STRIO7: HLRE 0,AB - CAML 0,[-6] - JRST .+6 - MOVE B,(TP) ; GET THE CHANNEL - MOVE 0,6(AB) - MOVEM 0,EOFCND-1(B) ; STUFF IN SLOT IN CHAN - MOVE 0,7(AB) - MOVEM 0,EOFCND(B) - PUSH TP,(AB) ; PUSH ON STRING - PUSH TP,1(AB) - PUSH P,[0] ; PUSH ON CURRENT COUNT OF CHARS DONE - MOVE 0,-2(P) ; GET READ OR WRITE FLAG - JUMPN 0,OUTLOP ; GO WRITE STUFF - - MOVE B,-2(TP) ; GET CHANNEL - PUSHJ P,GRB ; MAKE SURE WE HAVE BUFF - SKIPGE A,LSTCH(B) ; CHECK FOR EOF ALREADY READ PREVIOUSLY - JRST SRDOEF ; GO DOES HIS EOF HACKING -INLOP: INTGO - MOVE B,-2(TP) ; GET CHANNEL - MOVE C,-1(P) ; MAX COUNT - CAMG C,(P) ; COMPARE WITH COUNT DONE - JRST STREOF ; WE HAVE FINISHED - PUSHJ P,R1CHAR ; GET A CHAR - JUMPL A,INEOF ; EOF HIT - MOVE C,1(TB) - HRRZ E,(TB) ; DO WE HAVE A STRING TO WORRY US? - SOJL E,INLNT ; GO FINISH STUFFING - ILDB D,C - CAME D,A - JRST .-3 - JRST INEOF -INLNT: IDPB A,(TP) ; STUFF IN STRING - SOS -1(TP) ; DECREMENT STRING COUNT - AOS (P) ; INCREMENT CHAR COUNT - JRST INLOP - -INEOF: SKIPE C,LSTCH(B) ; IS THIS AN ! AND IS THERE A CHAR THERE - JRST .+3 ; YES - MOVEM A,LSTCH(B) ; NO SAVE THE CHAR - JRST .+3 - ADDI C,400000 - MOVEM C,LSTCH(B) - HRRZ C,DIRECT-1(B) ; GET THE TYPE OF CHAN - CAIN C,5 ; IS IT READB? - JRST .+3 - SOS ACCESS(B) ; FIX UP ACCESS FOR READ CHANNEL - JRST STREOF ; AND THATS IT - HRRZ C,ACCESS-1(B) ; FOR A READB ITS WORSE - MOVEI D,5 - SKIPG C - HRRM D,ACCESS-1(B) ; CHANGE A 0 TO A FIVE - SOS C,ACCESS-1(B) - CAMN C,[TFIX,,0] - SOS ACCESS(B) ; AND SOS THE WORD COUNT MAYBE - JRST STREOF - -SRDOEF: SETZM LSTCH(B) ; IN CASE OF -1, FLUSH IT - AOJE A,INLOP ; SKIP OVER -1 ON PTY'S - SUB TP,[6,,6] - SUB P,[3,,3] ; POP JUNK OFF STACKS - PUSH TP,EOFCND-1(B) - PUSH TP,EOFCND(B) ; WHAT WE NEED TO EVAL - PUSH TP,$TCHAN - PUSH TP,B - MCALL 1,FCLOSE ; CLOSE THE LOOSING CHANNEL - MCALL 1,EVAL ; EVAL HIS EOF JUNK - JRST FINIS - -OUTLOP: MOVE B,-2(TP) - PUSHJ P,GWB ; MAKE SURE WE HAVE BUFF -OUTLP1: INTGO - MOVE B,-2(TP) - MOVE C,-1(P) ; MAX COUNT TO DO - CAMG C,(P) ; HAVE WE DONE ENOUGH - JRST STREOF - ILDB A,(TP) ; GET THE CHAR - SOS -1(TP) ; SUBTRACT FROM STRING LENGTH - AOS (P) ; INC COUNT OF CHARS DONE - PUSHJ P,W1CHAR ; GO STUFF CHAR - JRST OUTLP1 - -STREOF: MOVE A,$TFIX - POP P,B ; RETURN THE LOOSER A COUNT OF WHAT WAS DONE - SUB P,[2,,2] - SUB TP,[6,,6] - JRST FINIS - - -GWB: SKIPE BUFSTR(B) - POPJ P, - PUSH TP,$TCHAN - PUSH TP,B ; GET US A WRITE BUFFER ON PRINTB CHAN - MOVEI A,BUFLNT - PUSHJ P,IBLOCK - MOVSI A,TWORD+.VECT. - MOVEM A,BUFLNT(B) - SETOM (B) - MOVEI C,1(B) - HRLI C,(B) - BLT C,BUFLNT-1(B) - MOVE C,B - HRLI C,440700 - MOVE B,(TP) - MOVEI 0,C.BUF - IORM 0,-4(B) - MOVEM C,BUFSTR(B) - MOVE C,[TCHSTR,,BUFLNT*5] - MOVEM C,BUFSTR-1(B) - SUB TP,[2,,2] - POPJ P, - - -GRB: SKIPE BUFSTR(B) - POPJ P, - PUSH TP,$TCHAN - PUSH TP,B ; GET US A READ BUFFER - MOVEI A,BUFLNT - PUSHJ P,IBLOCK - MOVEI C,BUFLNT(B) - POP TP,B - MOVEI 0,C.BUF - IORM 0,-4(B) - HRLI C,440700 - MOVEM C,BUFSTR(B) - MOVSI C,TCHSTR - MOVEM C,BUFSTR-1(B) - SUB TP,[1,,1] - POPJ P, - -MTSTRN: PUSH TP,$TATOM - PUSH TP,EQUOTE EMPTY-STRING - JRST CALER1 - - ; INPUT UNBUFFERING ROUTINE. THIS DOES THE CHARACTER UNBUFFERING -; FOR INPUT. THE OPEN ROUTINE SETUPS A PUSHJ P, TO -; THIS ROUTINE AS THE IOINS FOR A CHANNEL OPEN TO A NON-TTY DEVICE. - -; H. BRODIE 7/19/72 - -; CALLING SEQ: -; PUSHJ P,GETCHR -; B/ AOBJN PNTR TO CHANNEL VECTOR -; RETURNS NEXT CHARACTER IN AC A. -; ON ENCOUNTERING EITHER ^C OR NUL(^@) IT ASSUMES EOF AND -; TRANSMITS ONLY ^C ON SUCCESSIVE CALLS - - -GETCHR: -; FIRST GRAB THE BUFFER - GETYP A,BUFSTR-1(B) ; GET TYPE WORD - CAIN A,TCHSTR ; SKIPS IF NOT CHSTR (I.E. IF BAD BUFFER) - JRST GTGBUF ; IS GOOD BUFFER...SKIP ERROR RETURN -BDCHAN: PUSH TP,$TATOM ; ERROR RETURN - PUSH TP,EQUOTE BAD-INPUT-BUFFER - JRST CALER1 - -; BUFFER WAS GOOD -GTGBUF: HRRZ A,BUFSTR-1(B) ; GET LENGTH OF STRING - SOJGE A,GTGCHR ; JUMP IF STILL MORE - -; HERE IF THE BUFFER WAS EXHAUSTED (BYTE PNTR POINTS INTO DOPE WDS) -; GENERATE AN .IOT POINTER -;FIRST SAVE C AND D AS I WILL CLOBBER THEM -NEWBUF: PUSH P,C - PUSH P,D -IFN ITS,[ - LDB C,[600,,STATUS(B)] ; GET TYPE - CAIG C,2 ; SKIP IF NOT TTY -] -IFE ITS,[ - SKIPE BUFRIN(B) -] - JRST GETTTY ; GET A TTY BUFFER - - PUSHJ P,PGBUFI ; RE-FILL BUFFER - - JUMPGE A,BUFGOO ;SKIPS IF IOT COMPLETED...FIX UP CHANNEL - MOVEI C,1 ; MAKE SURE LAST EOF REALLY ENDS IT - ANDCAM C,-1(A) - MOVSI C,014000 ; GET A ^C - MOVEM C,(A) ;FAKE AN EOF - -; RESET THE BYTE POINTER IN THE CHANNEL. -; BUILD ONE USING THE PTR TO BEG OF BUFFER SAVED IN D -BUFGOO: HRLI D,440700 ; GENERATE VIRGIN LH - - MOVEM D,BUFSTR(B) ; STASH IN THE BUFFER BYTE PNTR SLOT - MOVEI A,BUFLNT*5-1 -BUFROK: POP P,D ;RESTORE D - POP P,C ;RESTORE C - - -; HERE IF THERE ARE CHARS IN BUFFER -GTGCHR: HRRM A,BUFSTR-1(B) - ILDB A,BUFSTR(B) ; GET A CHAR FROM BUFFER -IFE ITS,[ - CAIN A,32 ; TENEX EOF? - JRST .+3 -] - CAIE A,3 ; EOF? - POPJ P, ; AND RETURN -IFN ITS,[ - LDB A,[600,,STATUS(B)] ; CHECK FOR TTY - CAILE A,2 ; SKIP IF TTY -] -IFE ITS, SKIPN BUFRIN(B) - - JRST .+3 -RETEO1: HRRI A,3 - POPJ P, - - HRRZ A,@BUFSTR(B) ; SEE IF RSUBR START BIT IS ON - TRNN A,1 - MOVSI A,-1 - JRST RETEO1 - -IFN ITS,[ -PGBUFO: -PGBUFI: -] -IFE ITS,[ -PGBUFO: SKIPA D,[SOUT] -PGBUFI: MOVE D,[SIN] -] - SKIPGE A,BUFSTR(B) ; POINT TO CURRENT BUFFER POSIT - SUBI A,1 ; FOR 440700 AND 010700 START - SUBI A,BUFLNT-1 ; CALCULATE PNTR TO BEG OF BUFFER - HRLI A,-BUFLNT ; IOT (AOBJN) PNTR IN A -IFN ITS,[ -PGBIOO: -PGBIOI: MOVE D,A ; COPY FOR LATER - MOVSI C,TUVEC ; PREPARE TO HANDDLE INTS - MOVEM C,DSTO(PVP) - MOVEM C,ASTO(PVP) - MOVSI C,TCHAN - MOVEM C,BSTO(PVP) - -; BUILD .IOT INSTR - MOVE C,CHANNO(B) ; CHANNEL NUMBER IN C - ROT C,23. ; MOVE INTO AC FIELD - IOR C,[.IOT 0,A] ; IOR IN SKELETON .IOT - -; DO THE .IOT - ENABLE ; ALLOW INTS - XCT C ; EXECUTE THE .IOT INSTR - DISABLE - SETZM BSTO(PVP) - SETZM ASTO(PVP) - SETZM DSTO(PVP) - POPJ P, -] - -IFE ITS,[ -PGBIOT: PUSH P,D - PUSH TP,$TCHAN - PUSH TP,B - MOVEI C,(A) ; POINT TO BUFFER - HRLI C,444400 - MOVE D,A ; XTRA POINTER - MOVE A,CHANNO(B) ; FILE JFN - MOVE B,C - HLRE C,D ; - COUNT TO C - XCT (P) ; DO IT TO IT - MOVEI A,1(B) - MOVE B,(TP) - SUB TP,[2,,2] - SUB P,[1,,1] - JUMPGE C,CPOPJ ; NO EOF YET - HRLI A,(C) ; LOOK LIKE AN AOBJN PNTR - POPJ P, - -PGBIOO: SKIPA D,[SOUT] -PGBIOI: MOVE D,[SIN] - JRST PGBIOT -DOIOTO: PUSH P,D - PUSH P,C - PUSHJ P,PGBIOO -DOIOTE: POP P,C - POP P,D - POPJ P, -DOIOTI: PUSH P,D - PUSH P,C - PUSHJ P,PGBIOI - JRST DOIOTE -] - -; OUTPUT BUFFERING ROUTINES SIMILAR TO INPUT BUFFERING ROUTINES OF PREV PAGE - -PUTCHR: PUSH P,A - GETYP A,BUFSTR-1(B) ; CHECK TYPE OF ARG - CAIE A,TCHSTR ; MUST BE STRING - JRST BDCHAN - - HRRZ A,BUFSTR-1(B) ; GET CHAR COUNT - JUMPE A,REBUFF ; PREV RESET BUFF, UNDO SAME - -PUTCH1: POP P,A ; RESTORE CHAR - CAMN A,[-1] ; SPECIAL HACK? - JRST PUTCH2 ; YES GO HANDLE - IDPB A,BUFSTR(B) ; STUFF IT -PUTCH3: SOS A,BUFSTR-1(B) ; COUNT DOWN STRING - TRNE A,-1 ; SKIP IF FULL - POPJ P, - -; HERE TO FLUSH OUT A BUFFER - - PUSH P,C - PUSH P,D - PUSHJ P,PGBUFO ; SETUP AND DO IOT - HRLI D,440700 ; POINT INTO BUFFER - MOVEM D,BUFSTR(B) ; STORE IT - MOVEI A,BUFLNT*5 ; RESET COUNT - HRRM A,BUFSTR-1(B) - POP P,D - POP P,C - POPJ P, - -;HERE TO DA ^C AND TURN ON MAGIC BIT - -PUTCH2: MOVEI A,3 - IDPB A,BUFSTR(B) ; ZAP OUT THE ^C - MOVEI A,1 ; GET BIT - IORM A,@BUFSTR(B) ; ON GOES THE BIT - JRST PUTCH3 - -; RESET A FUNNY BUF - -REBUFF: MOVEI A,BUFLNT*5 ; 1ST COUNT - HRRM A,BUFSTR-1(B) - HRRZ A,BUFSTR(B) ; NOW POINTER - SUBI A,BUFLNT - HRLI A,440700 - MOVEM A,BUFSTR(B) ; STORE BACK - JRST PUTCH1 - - -; HERE TO FLUSH FINAL BUFFER - -BFCLOS: HLLZS ACCESS-1(B) ; CLEAR OUT KLUDGE PRINTB PART ACCESS COUNT - MOVE C,B ; THIS BUFFER FLUSHER THE WORK OF NDR - MOVEI B,RDEVIC-1(B) ; FIND OUT IF THIS IS NET - PUSHJ P,CHRWRD - JFCL - TRZ B,77777 ; LEAVE ONLY HIGH 3 CHARS - MOVEI A,0 ; FLAG 0=NET 1=DSK - CAME B,[ASCIZ /NET/] ; IS THIS NET? - AOS A - PUSH P,A ; SAVE THE RESULT OF OUR TEST - MOVE B,C ; RESTORE CHANNEL IN B - JUMPN A,BFCLNN ; DONT HAVE TO CHECK NET STATE - PUSH TP,$TCHAN - PUSH TP,B ; SAVE CHANNEL - PUSHJ P,INSTAT ; GET CURRENT NETWORK STATE - MOVE A,(B) ; GET FIRST ELEMENT OF STATE UVECTOR WHICH IS CUR STATE - POP TP,B ; RESTORE B - POP TP, - CAIE A,5 ; IS NET IN OPEN STATE? - CAIN A,6 ; OR ELSE IS IT IN RFNM WAIT STATE - JRST BFCLNN ; IF SO TO THE IOT - POP P, ; ELSE FLUSH CRUFT AND DONT IOT - POPJ P, ; RETURN DOING NO IOT -BFCLNN: MOVEI C,BUFLNT*5 ; NEW BUFFER FLUSHER BY NDR - HRRZ D,BUFSTR-1(B) ; SO THAT NET ALSO WORKS RIGHT - SUBI C,(D) ; GET NUMBER OF CHARS - IDIVI C,5 ; NUMBER OF FULL WORDS AND REST - PUSH P,D ; SAVE NUMBER OF ODD CHARS - SKIPGE A,BUFSTR(B) ; GET CURRENT BUF POSITION - SUBI A,1 ; FIX FOR 440700 BYTE POINTER - PUSH P,(A) ; SAVE THE ODD WORD OF BUFFER - MOVEI D,BUFLNT - SUBI D,(C) - SKIPE -1(P) - SUBI A,1 - ADDI D,1(A) ; FIX UP FOR POSSIBLE ODD CHARS - PUSH TP,$TUVEC - PUSH TP,D ; PUSH THE DOPE VECTOR ONTO THE STACK - JUMPE C,BFCLSR ; IN CASE THERE ARE NO FULL WORDS TO DO - HRL A,C - MOVE E,[A,,BUFLNT] - SUBI E,(C) ; FIX UP FOR BACKWARDS BLT - POP A,@E ; AMAZING GRACE - TLNE A,-1 - JRST .-2 - HRRO A,D ; SET UP AOBJN POINTER - SUBI A,(C) - TLC A,-1(C) - PUSHJ P,PGBIOO ; DO THE IOT OF ALL THE FULL WORDS -BFCLSR: HRRO A,(TP) ; GET IOT PTR FOR REST OF JUNK - SUBI A,1 ; POINT TO WORD BEFORE DOPE WORDS - POP P,0 ; GET BACK ODD WORD - POP P,C ; GET BACK ODD CHAR COUNT - POP P,D ; FLAG FOR NET OR DSK - JUMPE C,BFCLSD ; IF NO ODD CHARS FINISH UP - JUMPN D,BFCDSK ; GO FINISH OFF DSK - MOVEI D,7 - IMULI D,(C) ; FIND NO OF BITS TO SHIFT - LSH 0,-43(D) ; SHIFT BITS TO RIGHT PLACE - MOVEM 0,(A) ; STORE IN STRING - SUBI C,5 ; HOW MANY CHAR POSITIONS TO SKIP - MOVNI C,(C) ; MAKE C POSITIVE - LSH C,17 - TLC A,(C) ; MUNG THE AOBJN POINTER TO KLUDGE - PUSHJ P,PGBIOO ; DO IOT OF ODD CHARS -BFCLSD: HRRZ A,(TP) ; GET PTR TO DOPE WORD - SUBI A,BUFLNT - HRLI A,440700 ; AOBJN POINTER TO FIRST OF BUFFER - MOVEM A,BUFSTR(B) - MOVEI A,BUFLNT*5 - HRRM A,BUFSTR-1(B) - SUB TP,[2,,2] - POPJ P, - -BFCDSK: MOVE C,A ; FOR FUNNY AOBJN PTR - HLL C,BUFSTR(B) ; POINT INTO WORD AFTER LAST CHAR - TRZ 0,1 - MOVEM 0,(A) -IFN ITS, MOVEI 0,3 ; CONTROL C -IFE ITS, MOVEI 0,32 ; CNTL Z - IDPB 0,C - PUSHJ P,PGBIOO - JRST BFCLSD - -BFCLS1: HRRZ C,DIRECT-1(B) - MOVSI 0,(JFCL) - CAIE C,6 - MOVE 0,[AOS ACCESS(B)] - PUSH P,0 - HRRZ C,BUFSTR-1(B) - IDIVI C,5 - JUMPE D,BCLS11 - MOVEI A,40 ; PAD WITH SPACES - PUSHJ P,PUTCHR - XCT (P) ; AOS ACCESS IF NECESSARY - SOJG D,.-3 ; TO END OF WORD -BCLS11: POP P,0 - HLLZS ACCESS-1(B) - HRRZ C,BUFSTR-1(B) - CAIE C,BUFLNT*5 - PUSHJ P,BFCLOS - POPJ P, - - -; HERE TO GET A TTY BUFFER - -GETTTY: SKIPN C,EXBUFR(B) ; SKIP IF BUFFERS BACKED UP - JRST TTYWAI - HRRZ D,(C) ; CDR THE LIST - GETYP A,(C) ; CHECK TYPE - CAIE A,TDEFER ; MUST BE DEFERRED - JRST BDCHAN - MOVE C,1(C) ; GET DEFERRED GOODIE - GETYP A,(C) ; BETTER BE CHSTR - CAIE A,TCHSTR - JRST BDCHAN - MOVE A,(C) ; GET FULL TYPE WORD - MOVE C,1(C) - MOVEM D,EXBUFR(B) ; STORE CDR'D LIST - MOVEM A,BUFSTR-1(B) ; MAKE CURRENT BUFFER - MOVEM C,BUFSTR(B) - SOJA A,BUFROK - -TTYWAI: PUSHJ P,TTYBLK ; BLOCKED FOR TTY I/O - JRST GETTTY ; SHOULD ONLY RETURN HAPPILY - - ;INTERNAL DEVICE READ ROUTINE. - -;FOR INTERNAL DEVICES THIS ROUTINE APPLIES THE GIVEN OBJECT, -;CHECKS THAT THE RETURNED VALUE IS OF TYPE CHARACTER, -;AND RETURNS THAT AS THE NEXT CHARACTER IN THE "FILE" - -;H. BRODIE 8/31/72 - -GTINTC: PUSH TP,$TCHAN ;SAVE THE CHANNEL...WE'LL CLOBBER B - PUSH TP,B - PUSH P,C ;AND SAVE THE OTHER ACS - PUSH P,D - PUSH P,E - PUSH P,0 - PUSH TP,INTFCN-1(B) - PUSH TP,INTFCN(B) - MCALL 1,APPLY - GETYP A,A - CAIE A,TCHRS - JRST BADRET - MOVE A,B -INTRET: POP P,0 ;RESTORE THE ACS - POP P,E - POP P,D - POP P,C - POP TP,B ;RESTORE THE CHANNEL - SUB TP,[1,,1] ;FLUSH $TCHAN...WE DON'T NEED IT - POPJ P, - - -BADRET: PUSH TP,$TATOM - PUSH TP,EQUOTE INT-DEVICE-WRONG-TYPE-EVALUATION-RESULT - JRST CALER1 - -;INTERNAL DEVICE PRINT ROUTINE. - -;FOR INTERNAL DEVICES THIS ROUTINE APPLIES THE GIVEN OBJECT,(FUNCTION, SUBR, OR RSUBR) -;TO THE CURRENT CHARACTER BEING "PRINTED". - -PTINTC: PUSH TP,$TCHAN ;SAVE THE CHANNEL...WE'LL CLOBBER B - PUSH TP,B - PUSH P,C ;AND SAVE THE OTHER ACS - PUSH P,D - PUSH P,E - PUSH P,0 - PUSH TP,INTFCN-1(B) ;PUSH TYPE OF GIVEN OBJ - PUSH TP,INTFCN(B) ;PUSH THE SUPPLIED FUNCTION (OR SUBR ETC.) - PUSH TP,$TCHRS ;PUSH THE TYPE "CHARACTER" - PUSH TP,A ;PUSH THE CHAR - MCALL 2,APPLY ;APPLY THE FUNCTION TO THE CHAR - JRST INTRET - - - -; ROUTINE TO FLUSH OUT A PRINT BUFFER - -MFUNCTION BUFOUT,SUBR - - ENTRY 1 - - GETYP 0,(AB) - CAIE 0,TCHAN - JRST WTYP1 - - MOVE B,1(AB) - MOVEI B,DIRECT-1(B) - PUSHJ P,CHRWRD ; GET DIR NAME - JFCL - CAMN B,[ASCII /PRINT/] - JRST .+3 - CAME B,[+1] - JRST WRONGD - TRNE B,1 ; SKIP IF PRINT - PUSH P,[JFCL] - TRNN B,1 ; SKIP IF PRINTB - PUSH P,[AOS ACCESS(B)] - MOVE B,1(AB) - GETYP 0,BUFSTR-1(B) - CAIN 0,TCHSTR - SKIPN C,BUFSTR(B) ; BYTE POINTER? - JRST BFIN1 - HRRZ C,BUFSTR-1(B) ; CHARS LEFT - IDIVI C,5 ; MULTIPLE OF 5? - JUMPE D,BFIN2 ; YUP NO EXTRAS - - MOVEI A,40 ; PAD WITH SPACES - PUSHJ P,PUTCHR ; OUT IT GOES - XCT (P) ; MAYBE BUMP ACCESS - SOJG D,.-3 ; FILL - -BFIN2: PUSHJ P,BFCLOS ; WRITE OUT BUFFER -BFIN1: MOVSI A,TCHAN - JRST FINIS - - - -; FUNCTION TO GET THE FILE LENGTH OF A READ CHANNEL - -MFUNCTION FILLNT,SUBR,[FILE-LENGTH] - ENTRY 1 - - GETYP 0,(AB) - CAIE 0,TCHAN - JRST WTYP1 - MOVE B,1(AB) - MOVEI B,DIRECT-1(B) ; GET CHANNEL TYPE - PUSHJ P,CHRWRD - JFCL - CAME B,[ASCIZ /READ/] - JRST .+3 - PUSH P,[5] ; MULTIPLICATIVE FACTOR FOR READ - JRST .+4 - CAME B,[ASCII /READB/] - JRST WRONGD - PUSH P,[1] ; MULTIPLICATIVE FACTOR FOR READ - MOVE C,1(AB) -IFN ITS,[ - .CALL FILL1 - JRST FILLOS ; GIVE HIM A NICE FALSE -] -IFE ITS,[ - MOVE A,CHANNO(C) - SIZEF - JRST FILLOS -] - POP P,C - IMUL B,C - MOVE A,$TFIX - JRST FINIS - -IFN ITS,[ -FILL1: SETZ ; BLOCK FOR .CALL TO FILLEN - SIXBIT /FILLEN/ - CHANNO (C) - SETZM B - -FILLOS: MOVE A,CHANNO(C) - PUSHJ P,GFALS - JRST FINIS -] -IFE ITS,[ -FILLOS: PUSHJ P,TGFALS - JRST FINIS -] - - - ;THREE GENERALLY USEFUL ERROR ROUTINES FOR I/O - -NOTNET: -BADCHN: PUSH TP,$TATOM - PUSH TP,EQUOTE BAD-CHANNEL - JRST CALER1 - -WRONGD: PUSH TP,$TATOM - PUSH TP,EQUOTE WRONG-DIRECTION-CHANNEL - JRST CALER1 - -CHNCLS: PUSH TP,$TATOM - PUSH TP,EQUOTE CHANNEL-CLOSED - JRST CALER1 - -BAD6: PUSH TP,$TATOM - PUSH TP,EQUOTE NON-6-BIT-CHARACTER-IN-FILE-NAME - JRST CALER1 - -DISLOS: MOVE C,$TCHSTR - MOVE D,CHQUOTE [DISPLAY NOT AVAILABLE] - PUSHJ P,INCONS - MOVSI A,TFALSE - JRST OPNRET - -NOCHAN: PUSH TP,$TATOM - PUSH TP,EQUOTE ITS-CHANNELS-EXHAUSTED - JRST CALER1 - -MODE1: 232020,,202020 -MODE2: 232023,,332320 - -END - - -TITLE GCHACK - -RELOCATABLE - -.INSRT MUDDLE > - -.GLOBAL FRMUNG,PARBOT,TYPVEC,GCHACK,REHASH,IMPURI,NWORDT -.GLOBAL TD.LNT,TD.GET,TD.PUT - -; THIS IS AN INTERNAL MUDDLE SUBROUTINE TO RUN AROUND GC SPACE DOING -; SOMETHING ARBITRARY TO EVERY ENTITY THEREIN - -; CALL -- -; A/ INSTRUCTION TO BE EXECUTED -; PUSHJ P,GCHACK - -GCHACK: HRRZ E,TYPVEC+1(TVP) ; SET UP TYPE POINTER - HRLI E,C ; WILL HAVE TYPE CODE IN C - MOVE B,PARBOT ; START AT PARBOT - SETOM 1(TP) ; FENCE POST PDL - PUSH P,A - MOVEI A,(TB) - PUSHJ P,FRMUNG ; MUNG CURRENT FRAME - POP P,A - -; FIRST HACK PAIR SPACE - -PHACK: CAML B,PARTOP ; SKIP IF MORE PAIRS - JRST VHACK ; DONE, NOW HACK VECTORS - GETYP C,(B) ; TYPE OF CURRENT PAIR - MOVE D,1(B) ; AND ITS DATUM - XCT A ; APPLY INS - ADDI B,2 - JRST PHACK - -; NOW DO THE SAME THING TO VECTOR SPACE - -VHACK: MOVE B,VECTOP ; START AT TOP, MOVE DOWN - SUBI B,1 ; POINT TO TOPMOST VECTOR -VHACK2: CAMG B,VECBOT ; SKIP IF MORE TO DO - JRST REHASQ ; SEE IF MUST REHASH - - HLRE D,-1(B) ; GET TYPE FROM D.W. - HLRZ C,(B) ; AND TOTAL LENGTH - SUBI B,(C)-1 ; POINT TO START OF VECTOR - PUSH P,B - SUBI C,2 ; CHECK WINNAGE - JUMPL C,BADV ; FATAL LOSSAGE - PUSH P,C ; SAVE COUNT - JUMPE C,VHACK1 ; EMPTY VECTOR, FINISHED - -; DECIDE BASED ON TYPE WHETHER GENERAL,UNIFORM OR SPECIAL - - JUMPGE D,UHACK ; UNIFORM - TRNE D,377777 ; SKIP IF GENERAL - JRST SHACK ; SPECIAL - -; FALL THROUGH TO GENERAL - -GHACK1: GETYP C,(B) ; LOOK A T 1ST ELEMENT - CAIE C,TCBLK - CAIN C,TENTRY ; FRAME ON STACK - SOJA B,EHACK - CAIE C,TUBIND - CAIN C,TBIND ; BINDING BLOCK - JRST BHACK - CAIN C,TGATOM ; ATOM WITH GDECL? - JRST GDHACK - MOVE D,1(B) ; GET DATUM - XCT A ; USER INS - ADDI B,2 ; NEXT ELEMENT - SOS (P) - SOSLE (P) ; COUNT ELEMENTS - SKIPGE (B) ; OR FENCE POST HIT - JRST VHACK1 - JRST GHACK1 - -; HERE TO GO OVER UVECTORS - -UHACK: CAMN A,[PUSHJ P,SBSTIS] - JRST VHACK1 ; IF THIS SUBSTITUTE, DONT DO UVEC - MOVEI C,(D) ; COPY UNIFORM TYPE - SUBI B,1 ; BACK OFF - -UHACK1: MOVE D,1(B) ; DATUM - XCT A - SOSLE (P) ; COUNT DOEN - AOJA B,UHACK1 - JRST VHACK1 - -; HERE TO HACK VARIOUS FLAVORS OF SPECIAL GOODIES - -SHACK: ANDI D,377777 ; KILL EXTRA CRUFT - CAIN D,SATOM - JRST ATHACK - CAIE D,STPSTK ; STACK OR - CAIN D,SPVP ; PROCESS - JRST GHACK1 ; TREAT LIKE GENERAL - CAIN D,SASOC ; ASSOCATION - JRST ASHACK - CAIG D,NUMSAT ; TEMPLATE MAYBE? - JRST BADV ; NO CHANCE - ADDI C,(B) ; POINT TO DOPE WORDS - SUBI D,NUMSAT+1 - HRLI D,(D) - ADD D,TD.LNT+1(TVP) - JUMPGE D,BADV ; JUMP IF INVALID TEMPLATE HACKER - - CAMN A,[PUSHJ P,SBSTIS] - JRST VHACK1 - -TD.UPD: PUSH P,A ; INS TO EXECUTE - XCT (D) - HLRZ E,B ; POSSIBLE BASIC LENGTH - PUSH P,[0] - PUSH P,E - MOVEI B,(B) ; ISOLATE LENGTH - PUSH P,C ; SAVE POINTER TO OBJECT - - PUSH P,[0] ; HOME FOR VALUES - PUSH P,[0] ; SLOT FOR TEMP - PUSH P,B ; SAVE - SUB D,TD.LNT+1(TVP) - PUSH P,D ; SAVE FOR FINDING OTHER TABLES - JUMPE E,TD.UP2 ; NO REPEATING SEQ - ADD D,TD.GET+1(TVP) ; COMP LNTH OF REPEATING SEQ - HLRE D,(D) ; D ==> - LNTH OF TEMPLATE - ADDI D,(E) ; D ==> -LENGTH OF REP SEQ - MOVNS D - HRLM D,-5(P) ; SAVE IT AND BASIC - -TD.UP2: SKIPG D,-1(P) ; ANY LEFT? - JRST TD.UP1 - - MOVE E,TD.GET+1(TVP) - ADD E,(P) - MOVE E,(E) ; POINTER TO VECTOR IN E - MOVEM D,-6(P) ; SAVE ELMENT # - SKIPN B,-5(P) ; SKIP IF "RESTS" EXIST - SOJA D,TD.UP3 - - MOVEI 0,(B) ; BASIC LNT TO 0 - SUBI 0,(D) ; SEE IF PAST BASIC - JUMPGE 0,.-3 ; JUMP IF O.K. - MOVSS B ; REP LNT TO RH, BASIC TO LH - IDIVI 0,(B) ; A==> -WHICH REPEATER - MOVNS A - ADD A,-5(P) ; PLUS BASIC - ADDI A,1 ; AND FUDGE - MOVEM A,-6(P) ; SAVE FOR PUTTER - ADDI E,-1(A) ; POINT - SOJA D,.+2 - -TD.UP3: ADDI E,(D) ; POINT TO SLOT - XCT (E) ; GET THIS ELEMENT INTO A AND B - MOVEM A,-3(P) ; SAVE TYPE FOR LATER PUT - MOVEM B,-2(P) - GETYP C,A ; TYPE TO C - MOVE D,B ; DATUME - MOVEI B,-3(P) ; POINTER TO HOME - MOVE A,-7(P) ; GET INS - XCT A ; AND DO IT - MOVE C,-4(P) ; GET POINTER FOR UPDATE OF ELEMENT - MOVE E,TD.PUT+1(TVP) - SOS D,-1(P) ; RESTORE COUNT - ADD E,(P) - MOVE E,(E) ; POINTER TO VECTOR IN E - MOVE B,-6(P) ; SAVED OFFSET - ADDI E,(B)-1 ; POINT TO SLOT - MOVE A,-3(P) ; RESTORE TYPE WORD - MOVE B,-2(P) - XCT (E) ; SMASH IT BACK - FATAL TEMPLATE LOSSAGE - MOVE C,-4(P) - JRST TD.UP2 - -TD.UP1: MOVE A,-7(P) ; RESTORE INS - SUB P,[10,,10] - MOVSI D,400000 ; RESTORE MARK/UNMARK BIT - JRST VHACK1 - -; FATAL LOSSAGE ARRIVES HERE - -BADV: FATAL GC SPACE IN A BAD STATE - -; HERE TO HACK SPECIAL CRUFT IN GENERAL VECTORS (STACKS) - -EHACK: MOVSI D,-FRAMLN ; SET UP AOBJN PNTR - -EHACK1: HRRZ C,ETB(D) ; GET 1ST TYPE - PUSH P,D ; SAVE AOBJN - MOVE D,1(B) ; GET ITEM - CAME A,[PUSHJ P,SBSTIS] ; DONT IF SUBSTITUTE DIFFERENT - XCT A ; USER GOODIE - POP P,D ; RESTORE AOBJN - ADDI B,1 ; MOVE ON - SOSLE (P) ; ALSO COUNT IN TOTAL VECTOR - AOBJN D,EHACK1 - AOJA B,GHACK1 ; AND GO ON - -; TABLE OF ENTRY BLOCK TYPES - -ETB: TSUBR - TTB - TAB - TSP - TPDL - TTP - TWORD - -; HERE TO GROVEL OVER BINDING BLOCKS - -BHACK: MOVEI C,TATOM ; ALSO TREEAT AS ATOM - MOVE D,1(B) - CAME A,[PUSHJ P,SBSTIS] ; DONT IF SUBSTITUTE DIFFERENT - XCT A - PUSHJ P,NXTGDY ; NEXT GOODIE - PUSHJ P,NXTGDY ; AND NEXT - MOVEI C,TSP ; TYPE THE BACK LOCATIVE - PUSHJ P,NXTGD1 ; AND NEXT - PUSH P,B - HLRZ D,-2(B) ; DECL POINTER - MOVEI B,0 ; MAKE SURE NO CLOBBER - MOVEI C,TDECL - XCT A ; DO THE THING BEING DONE - POP P,B - HRLM D,-2(B) ; FIX UP IN CASE CHANGED - JRST GHACK1 - -; HERE TO HACK ATOMS WITH GDECLS - -GDHACK: CAMN A,[PUSHJ P,SBSTIS] - JRST VHACK1 - - MOVEI C,TATOM ; TREAT LIKE ATOM - MOVE D,1(B) - XCT A - HRRZ D,(B) ; GET DECL - JUMPE D,VHACK1 - CAIN D,-1 ; WATCH OUT FOR MAINFEST - JRST VHACK1 - PUSH P,B ; SAVE POINTER - MOVEI B,0 - MOVEI C,TLIST - XCT A - POP P,B - HRRM D,(B) ; RESET - JRST VHACK1 - -; HERE TO HACK ATOMS - -ATHACK: ADDI B,1 ; POINT PRIOR TO OBL SLOT - MOVEI C,TOBLS ; GET TYPE - MOVE D,1(B) ; AND DATUM - CAME A,[PUSHJ P,SBSTIS] ; DONT IF SUBSTITUTE DIFFERENT - XCT A - JRST VHACK1 - -; HERE TO HACK ASSOCIATION BLOCKS - -ASHACK: MOVEI D,3 ; COUNT GOODIES TO MARK - -ASHAK1: PUSH P,D - MOVE D,1(B) - GETYP C,(B) - PUSH P,D ; SAVE POINTER - XCT A - POP P,D ; GET OLD BACK - CAME D,1(B) ; CHANGED? - TLO E,400000 ; SET NON-VIRGIN FLAG - POP P,D - PUSHJ P,BMP ; TO NEXT - SOJG D,ASHAK1 - -; HERE TO GOT TO NEXT VECTOR - -VHACK1: MOVE B,-1(P) ; GET POINTER - SUB P,[2,,2] ; FLUSH CRUFT - SOJA B,VHACK2 ; FIXUP POINTER AND GO ON - -; ROUTINE TO GET A GOODIE - -NXTGDY: GETYP C,(B) -NXTGD1: MOVE D,1(B) - XCT A ; DO IT TO IT -BMP: SOS -1(P) - SOSG -1(P) - JRST BMP1 - ADDI B,2 - POPJ P, -BMP1: SUB P,[1,,1] - JRST VHACK1 - -REHASQ: JUMPL E,REHASH ; HASH TABLE RAPED, FIX IT - POPJ P, - - -MFUNCTION SUBSTI,SUBR,[SUBSTITUTE] - -;THIS FUNCTION CODED BY NDR IS AN INCREDIBLE WAY TO -;KILL YOURSELF, EVEN IF YOU THINK YOU REALLY KNOW WHAT -;YOU ARE DOING. -;IT DOES A MINI-GC CHANGING EACH REFERENCE OF THE -;SECOND ITEM TO A REFERENCE OF THE FIRST ITEM, HA HA HA. -;BOTH ITEMS MUST BE OF THE SAME TYPE OR -;IF NOT, NEITHER CAN BE A TYPE REQUIRING TWO WORDS -; OF STORAGE, AND SUBSTITUTION CANT BE DONE IN -; UVECTORS WHEN THEY ARE DIFFERENT, AS WELL AS IN -; A FEW OTHER YUCKY PLACES. -;RETURNS ITEM TWO--THE ONLY WAY TO GET YOUR HANDS BACK ON IT - - ENTRY 2 - - -SBSTI1: GETYP A,2(AB) - CAIE A,TATOM - JRST SBSTI2 - MOVE B,3(AB) ; IMPURIFY HASH BUCKET MAYBE? - PUSHJ P,IMPURI - -SBSTI2: GETYP A,2(AB) ; GET TYPE OF SECOND ARG - MOVE D,A - PUSHJ P,NWORDT ; AND STORAGE ALLOCATION - MOVE E,A - GETYP A,(AB) ; GET TYPE OF FIRST ARG - MOVE B,A - PUSHJ P,NWORDT - CAMN B,D ; IF TYPES SAME, DONT CHECK FOR ALLOCATION - JRST SBSTI3 - CAIN E,1 - CAIE A,1 - JRST SBSTIL ; LOOSE, NOT BOTH ONE WORD GOODIES - -SBSTI3: MOVEI C,0 - CAIN D,0 ; IF GOODIE IS OF TYPE ZERO - MOVEI C,1 ; USE TYPE 1 TO KEEP INFO FROM CLOBBERAGE - PUSH TP,C - SUBI E,1 - PUSH TP,E ; 1=DEFERRED TYPE ITEM, 0=ELSE - PUSH TP,C - PUSH TP,D ; TYPE OF GOODIE - PUSH TP,C - PUSH TP,[0] - CAIN D,TLIST - AOS (TP) ; 1=TYPE LIST, 0=ELSE - PUSH TP,C - PUSH TP,2(AB) ; TYPE-WORD - PUSH TP,C - PUSH TP,3(AB) ; VALUE-WORD - PUSH TP,(AB) - PUSH TP,1(AB) ; TYPE-VALUE OF THINGS TO CHANGE INTO - MOVE A,[PUSHJ P,SBSTIR] - CAME B,D ; IF NOT SAME TYPE, USE DIFF MUNGER - MOVE A,[PUSHJ P,SBSTIS] - PUSHJ P,GCHACK ; DO-IT - MOVE A,-4(TP) - MOVE B,-2(TP) - JRST FINIS ; GIVE THE LOOSER A HANDLE ON HIS GOODIE - -SBSTIR: CAME D,-2(TP) - JRST LSUB ; THIS IS IT - CAME C,-10(TP) - JRST LSUB ; IF ITEM CANT BE SAME CHECK FOR LISTAGE - JUMPE B,LSUB+1 ; WE GOT HOLD OF A FUNNY GOODIE, JUST IGNORE IT - MOVE 0,(TP) - MOVEM 0,1(B) ; SMASH IT - MOVE 0,-1(TP) ; GET TYPE WORD - SKIPE -12(TP) ; IF THIS IS A DEFFERABLE ITEM THEN WE MUST - MOVEM 0,(B) ; ALSO SMASH THE TYPE WORD SLOT - -LSUB: SKIPN -6(TP) ; IF WE ARE LOOKING FOR LISTS, LOOK ON - POPJ P, ; ELSE THATS ALL - CAMG B,PARTOP - CAMGE B,PARBOT ; IS IT IN LIST SPACE? - POPJ P, ; WELL NO LIST SMASHING THIS TIME - HRRZ 0,(B) ; GET ITS LIST POINTER - CAME 0,-2(TP) - POPJ P, ; THIS ONE DIDNT MATCH - MOVE 0,(TP) ; GET THE NEW REST OF THE LIST - HRRM 0,(B) ; AND SMASH INTO THE REST OF THE LIST - POPJ P, - -SBSTIS: CAMN D,-2(TP) - CAME C,-10(TP) - POPJ P, - SKIPN B ; SEE IF THIS IS A FUNNY GOODIE WE NO TOUCHIE - POPJ P, - MOVE 0,(TP) - MOVEM 0,1(B) ; KLOBBER VALUE CELL - MOVE 0,-1(TP) - HLLM 0,(B) ; KLOBBER TYPE CELL, WHICH WE KNOW IS THERE - POPJ P, - -SBSTIL: PUSH TP,$TATOM ; LOSSAGE ON DIFFERENT TYPES, ONE DOUBLE WORD - PUSH TP,EQUOTE CANT-SUBSTITUTE-WITH-STRING-OR-TUPLE-AND-OTHER - JRST CALER1 - -END - - TITLE INITIALIZATION FOR MUDDLE - -RELOCATABLE - -LAST==1 ;POSSIBLE CHECKS DONE LATER - -.INSRT MUDDLE > - -SYSQ - -IFE ITS,[ -FATINS==.FATAL" -SEVEC==104000,,204 -] - -IMPURE - -OBSIZE==151. ;DEFAULT OBLIST SIZE - -.LIFG -.LOP .VALUE -.ELDC - - -.GLOBAL SETUP,TPBAS,GCPDL,GCPVP,PVBASE,PVLNT,PARNEW,AAGC,ICR,SWAP,OBLNT,MSGTYP -.GLOBAL ICLOS,OCLOS,GLOBASE,GLOBSP,PARBOT,PARTOP,CODTOP,START,BEGIN,VECBOT,VECTOP,TPBASE -.GLOBAL LISTEN,ROOT,INITIAL,TBINIT,TOPLEV,INTOBL,ERROBL,MUDOBL,TTYOPE,RESFUN,QUITTER -.GLOBAL IOINS,BUFRIN,IOIN2,ECHO,MTYI,MTYO,MUDSTR,P.TOP,TTICHN,TTOCHN,TYPVEC -.GLOBAL PDLBUF,PHIBOT,%UNAM,PURVEC,STOSTR,ISTOST,TD.LNT,TD.PUT,TD.GET,CAFRE1 -; INIITAL AMOUNT OF AFREE SPACE - -STOSTR: BLOCK 400 ; A RANDOM AMOUNT -ISTOST: 401,,0 - -SETUP: -IFN ITS, .SUSET [.RUNAM,,%UNAM] ; FOR AGC'S BENFIT - MOVE P,GCPDL ;GET A PUSH DOWN STACK -IFN ITS, .SUSET [.SMASK,,[200000]] ; ENABLE PDL OVFL - MOVE TVP,[-TVLNT,,TVBASE] ;GET INITIAL TRANSFER VECTOR - PUSHJ P,TTYOPE ;OPEN THE TTY - AOS A,20 ; TOP OF LOW SEGG - HRRZM A,P.TOP - SOSN A ; IF NOTHING YET -IFN ITS, .SUSET [.RMEMT,,P.TOP] -IFE ITS, JRST 4, - HRRE A,P.TOP ; CHECK TOP - TRNE A,377777 ; SKIP IF ALL LOW SEG - JUMPL A,PAGLOS ; COMPLAIN - MOVE A,HITOP ; FIND HI SEG TOP - ADDI A,1777 - ANDCMI A,1777 - MOVEM A,RHITOP ; SAVE IT - MOVEI A,200 - SUBI A,PHIBOT - JUMPE A,HIBOK - MOVSI A,(A) - HRRI A,200 -IFN ITS,[ - .CALL GIVCOR - .VALUE -] -HIBOK: MOVEI B,[ASCIZ /MUDDLE INITIALIZATION. -/] - PUSHJ P,MSGTYP ;PRINT IT - MOVE A,CODTOP ;CHECK FOR A WINNING LOAD - CAML A,VECBOT ;IT BETTER BE LESS - JRST DEATH1 ;LOSE COMPLETELY - MOVE B,PARBOT ;CHECK FOR ANY PAIRS - CAME B,PARTOP ;ANY LOAD/ASSEMBLE TIME PAIRS? - JRST PAIRCH ;YES CHECK THEM - ADDI A,2000 ;BUMP UP - ANDCMI A,1777 - MOVEM A,PARBOT ;UPDATE PARBOT AND TOP - MOVEM A,PARTOP -SETTV: MOVE PVP,[-PVLNT*2,,GCPVP] ;AND A PROCESS VECTOR - MOVEI A,(PVP) ;SET UP A BLT - HRLI A,PVBASE ;FROM PROTOTYPE - BLT A,PVLNT*2-1(PVP) ;INITIALIZE - MOVE TP,[-ITPLNT,,TPBAS] ;GET A STACK FOR THIS PROCCESS - MOVEI TB,(TP) ;AND A BASE - HRLI TB,1 - SUB TP,[1,,1] ;POP ONCE - -; ALLOCATE SOME OBLISTS FOR INITIAL ATOMS - - PUSH P,[5] ;COUNT INITIAL OBLISTS - - PUSH P,OBLNT ;SAVE CURRENT OBLIST DEFAULT SIZE - -MAKEOB: SOS A,-1(P) - MOVE A,OBSZ(A) - MOVEM A,OBLNT - MCALL 0,MOBLIST ;GOBBLE AN OBLIST - PUSH TP,$TOBLS ;AND SAVE THEM - PUSH TP,B - MOVE A,(P)-1 ;COUNT DOWN - MOVEM B,@OBTBL(A) ;STORE - JUMPN A,MAKEOB - - POP P,OBLNT ;RESTORE DEFAULT OBLIST SIZE - - MOVE C,TVP ;MAKE 2 COPIES OF XFER VECTOR POINTER - MOVE D,TVP - -;MAIN INITIALIZE LOOP - SCAN XFER VECTOR FOR ATOMS, UPDATE -;OFFSETS IN CODE, UNIQUIFY ATOMS AND COMPACT XFER VECTOR - -ILOOP: HLRZ A,(C) ;FIRST TYPE - JUMPE A,TVEXAU ;USEFUL STUFF EXHAUSTED - CAIN A,TCHSTR ;CHARACTER STRING? - JRST CHACK ;YES, GO HACK IT - CAIN A,TATOM ;ATOM? - JRST ATOMHK ;YES, CHECK IT OUT - MOVE A,(C) ;MOVE TO NEW HOME (MAY BE SAME) - MOVEM A,(D) - MOVE A,1(C) - MOVEM A,1(D) -SETLP: AOS (P) ;COUNT NUMBER OF PAIRS IN XFER VECTOR - ADD D,[2,,2] ;OUT COUNTER -SETLP1: ADD C,[2,,2] ;AND IN COUNTER - JUMPL C,ILOOP ;JUMP IF MORE TO DO - ;NEW XFER VECTOR FINISHED, NOW GIVE AWAY THE REST - -TVEXAU: HLRE B,C ;GET -LENGTH - SUBI C,(B) ;POIT TO DOPE WORD - ANDI C,-1 ;NO LH - HLRZ A,1(C) ;INTIAL LENGTH TO A - MOVEI E,(C) ;COPY OF POINTER TO DOPW WD - SUBI E,(D) ;AMOUNT LEFT OVER TO E - HRLZM E,1(C) ;CLOBBER INTO DOPE WORD FOR GARBAGE - MOVSI E,(E) ;PREPARE TO UPDATE TVP - ADD TVP,E ;NOW POINTS TO THE RIGHT AMOUNT - HLRE B,D ;-AMOUNT LEFT TO B - ADD B,A ;AMOUNT OF GOOD STUFF - HRLZM B,1(D) ;STORE IT IN GODD DOPE WORD - MOVSI E,400000 ;CLOBBER TO GENERAL IN BOTH CASES - MOVEM E,(C) - MOVEM E,(D) - - -; FIX UP TYPE VECTOR - - MOVE A,TYPVEC+1(TVP) ;GET POINTER - MOVEI 0,0 ;FOR POSSIBLE NULL SLOTS - MOVSI B,TATOM ;SET TYPE TO ATOM - -TYPLP: HLLM B,(A) ;CHANGE TYPE TO ATOM - MOVE C,@1(A) ;GET ATOM - MOVEM C,1(A) - ADD A,[2,,2] ;BUMP - JUMPL A,TYPLP - ; CLOSE TTY CHANNELS -IFN ITS,[ - - .CLOSE 1, - .CLOSE 2, -] - -;GENERAT THE LOGICAL TTY IN AND OUT CHANNELS - -;SETUP CALL TO OPEN OUTPUT TTY CHANNNEL - - IRP A,,[[PRINT,TCHSTR],[TTY:,TCHSTR]] - IRP B,C,[A] - PUSH TP,$!C - PUSH TP,CHQUOTE B - .ISTOP - TERMIN - TERMIN - - MCALL 2,FOPEN ;OPEN THE OUT PUT CHANNEL - MOVEM B,TTOCHN+1(TVP) ;SAVE IT - -;ASSIGN AS GLOBAL VALUE - - PUSH TP,$TATOM - PUSH TP,IMQUOTE OUTCHAN - PUSH TP,A - PUSH TP,B - MOVE A,[PUSHJ P,MTYO] ;MORE WINNING INS - MOVEM A,IOINS(B) ;CLOBBER - MCALL 2,SETG - -;SETUP A CALL TO OPEN THE TTY CHANNEL - - IRP A,,[[READ,TCHSTR],[TTY:,TCHSTR]] - IRP B,C,[A] - PUSH TP,$!C - PUSH TP,CHQUOTE B - .ISTOP - TERMIN - TERMIN - - MCALL 2,FOPEN ;OPEN INPUTCHANNEL - MOVEM B,TTICHN+1(TVP) ;SAVE IT - PUSH TP,$TATOM ;ASSIGN AS A GLOBAL VALUE - PUSH TP,IMQUOTE INCHAN - PUSH TP,A - PUSH TP,B - MOVE C,BUFRIN(B) ;GET AUX BUFFER PTR - MOVE A,[PUSHJ P,MTYI] - MOVEM A,IOIN2(C) ;MORE OF A WINNER - MOVE A,[PUSHJ P,MTYO] - MOVEM A,ECHO(C) ;ECHO INS - MCALL 2,SETG - -;GENERATE AN INITIAL PROCESS AND SWAP IT IN - - PUSHJ P,ICR ;CREATE IT - MOVEI 0,RUNING - MOVEM 0,PSTAT"+1(B) - MOVE D,B ;SET UP TO CALL SWAP - JSP C,SWAP ;AND SWAP IN - MOVEM PVP,MAINPR" ;SAVE AS THE MAIN PROCESS - PUSH TP,[TENTRY,,TOPLEV] ;BUILD DUMMY FRAME - PUSH TP,[1,,0] - MOVEI A,-1(TP) - PUSH TP,A - PUSH TP,SP - PUSH TP,P - MOVE C,TP ;COPY TP - ADD C,[3,,3] ;FUDGE - PUSH TP,C ;TPSAV PUSHED - PUSH TP,[TOPLEV] - HRRI TB,(TP) ;SETUP TB - HRLI TB,2 - ADD TB,[1,,1] - MOVEM TB,TBINIT+1(PVP) - MOVSI A,TSUBR - MOVEM A,RESFUN(PVP) - MOVEI A,LISTEN" - MOVEM A,RESFUN+1(PVP) - PUSH TP,$TATOM - PUSH TP,IMQUOTE THIS-PROCESS - PUSH TP,$TPVP - PUSH TP,PVP - MCALL 2,SETG - -; FIND TVP OFFSET FOR THE ATOM 'T' FOR TEMPLATE - - MOVEI A,MQUOTE T - SUBI A,(TVP) -TVTOFF==0 - ADDSQU TVTOFF - - MOVEM A,SQULOC-1 - - PUSH TP,$TATOM - PUSH TP,IMQUOTE TVTOFF,,MUDDLE - PUSH TP,$TFIX - PUSH TP,A - MCALL 2,SETG - -; HERE TO SETUP SQUOZE TABLE IN PURE CORE - - PUSHJ P,SQSETU ; GO TO ROUTINE - - MOVEI A,400000 ; FENCE POST PURE SR VECTOR - HRRM A,PURVEC(TVP) - MOVE A,TP - HLRE B,A - SUBI A,-PDLBUF(B) ;POINT TO DOPE WORDS - MOVEI B,12 ;GROWTH SPEC - IORM B,(A) - MOVEI 0,ISTOST - MOVEM 0,CODTOP - PUSHJ P,AAGC ;DO IT - AOJL A,.-1 - MOVE A,TPBASE+1(PVP) - SUB A,[640.,,640.] - MOVEM A,TPBASE+1(PVP) - -; CREATE LIST OF ROOT AND NEW OBLIST - - MOVEI A,5 - PUSH P,A - -NAMOBL: PUSH TP,$TATOM - PUSH TP,@OBNAM-1(A) ; NAME - PUSH TP,$TATOM - PUSH TP,IMQUOTE OBLIST - PUSH TP,$TOBLS - PUSH TP,@OBTBL-1(A) - MCALL 3,PUT ; NAME IT - SOS A,(P) - PUSH TP,$TOBLS - PUSH TP,@OBTBL(A) - PUSH TP,$TATOM - PUSH TP,IMQUOTE OBLIST - PUSH TP,$TATOM - PUSH TP,@OBNAM(A) - MCALL 3,PUT - SKIPE A,(P) - JRST NAMOBL - SUB P,[1,,1] - -;Define MUDDLE version number - MOVEI A,5 - MOVEI B,0 ;Initialize result - MOVE C,[440700,,MUDSTR+2] -VERLP: ILDB D,C ;Get next charcter digit - CAIG D,"9 ;Non-digit ? - CAIGE D,"0 - JRST VERDEF - SUBI D,"0 ;Convert to number - IMULI B,10. - ADD B,D ;Include number into result - SOJG A,VERLP ;Finished ? -VERDEF: - PUSH TP,$TATOM - PUSH TP,MQUOTE MUDDLE - PUSH TP,$TFIX - PUSH TP,B - MCALL 2,SETG ;Make definition -OPIPC: -IFN ITS,[ - PUSH TP,$TCHSTR - PUSH TP,CHQUOTE IPC - PUSH TP,$TATOM - PUSH TP,MQUOTE IPC-HANDLER - MCALL 1,GVAL - PUSH TP,A - PUSH TP,B - PUSH TP,$TFIX - PUSH TP,[1] - MCALL 3,ON - MCALL 0,IPCON -] - -; Allocate inital template tables - - MOVEI A,10 - PUSHJ P,CAFRE1 - ADD B,[10,,10] ; REST IT OFF - MOVEM B,TD.LNT+1(TVP) - MOVEI A,10 - PUSHJ P,CAFRE1 - MOVEI 0,TUVEC ; SETUP UTYPE - HRLM 0,10(B) - MOVEM B,TD.GET+1(TVP) - MOVEI A,10 - PUSHJ P,CAFRE1 - MOVEI 0,TUVEC ; SETUP UTYPE - HRLM 0,10(B) - MOVEM B,TD.PUT+1(TVP) - -PTSTRT: MOVEI A,SETUP - ADDI A,1 - SUB A,PARBOT ;FIND WHERE PAIRS SHOULD GO - MOVEM A,PARNEW -IFE ITS,[ - MOVEI A,400000 - MOVE B,[1,,START] - SEVEC -] - PUSH P,[14.,,14.] ;PUSH A SMALL PRGRM ONTO P - MOVEI A,1(P) ;POINT TO ITS START - PUSH P,[JRST AAGC] ;GO TO AGC - PUSH P,[MOVE B,PSTO+1(PVP)] ;GET SAVED P - PUSH P,[SUB B,-13.(P)] ;FUDGE TO POP OFF PROGRAM - PUSH P,[MOVEM B,PSAV(TB)] ;INTO FRAME - PUSH P,[MOVE B,TPSTO+1(PVP)] ;GET TP - PUSH P,[MOVEM B,TPSAV(TB)] ;STORE IT - PUSH P,[MOVE B,SPSTO+1(PVP)] ;SP - PUSH P,[MOVEM B,SPSAV(TB)] - PUSH P,[MOVEI B,TOPLEV] ;WHERE TO GO - PUSH P,[MOVEM B,PCSAV(TB)] -IFN ITS, PUSH P,[MOVSI B,(.VALUE )] -IFE ITS, PUSH P,[MOVSI B,(JRST 4,)] - PUSH P,[HRRI B,C] - PUSH P,[JRST B] ;GO DO VALRET - PUSH P,[B] - PUSH P,A ; PUSH START ADDR - MOVE B,[JRST -11.(P)] - MOVE 0,[JUMPA START] - MOVE C,[ASCII \0/9\] - MOVE D,[ASCII \B/1Q\] - MOVE E,[ASCIZ \ -* -\] ;TERMINATE - POPJ P, ; GO - -; CHECK PAIR SPACE - -PAIRCH: CAMG A,B - JRST SETTV ;O.K. - -DEATH1: MOVEI B,[ASCIZ /LOSSAGE--CODE AND DATA OVERLAP -/] - PUSHJ P,MSGTYP - .VALUE - -;CHARACTER STRING HACKER - -CHACK: MOVE A,(C) ;GET TYPE - HLLZM A,(D) ;STORE IN NEW HOME - MOVE B,1(C) ;GET POINTER - HLRZ E,B ;-LENGHT - HRRM E,(D) - PUSH P,E+1 ; IDIVI WILL CLOBBER - ADDI E,4+5*2 ; ROUND AND ACCOUNT FOR DOPE WORDS - IDIVI E,5 ; E/ WORDS LONG - PUSHJ P,EBPUR ; MAKE A PURIFIED COPY - POP P,E+1 - HRLI B,440700 ;MAKE POINT BYTER - MOVEM B,1(D) ;AND STORE IT - ANDI A,-1 ;CLEAR LH OF A - JUMPE A,SETLP ;JUMP IF NO REF - MOVE E,(P) ;GET OFFSET - LSH E,1 - HRRZ B,-1(A) ;SEE IF PREVIOUS INSTRUCTION REFERS TO $TCHSTR - CAIE B,$TCHSTR ;SKIP IF IT DOES - JRST CHACK1 ;NO, JUST DO CHQUOTE PART - HRRM E,-1(A) ;CLOBBER - MOVEI B,TVP - DPB B,[220400,,-1(A)] ;CLOBBER INDEX FIELD -CHACK1: ADDI E,1 - HRRM E,(A) ;STORE INTO REFERENCE - JRST SETLP - -; SUBROUTINE TO COPY A HUNK OF STRUCTURE TO THE HIGH SEGMENT - -EBPUR: PUSH P,E - PUSH P,A - ADD E,HITOP ; GET NEW TOP - CAMG E,RHITOP ; SKIP IF TOO BIG - JRST EBPUR1 - -; CODE TO GROW HI SEG - - MOVEI A,2000 - ADDB A,RHITOP ; NEW TOP -IFN ITS,[ - ASH A,-10. ; NUM OF BLOCKS - SUBI A,1 ; BLOCK TO GET - .CALL HIGET - .VALUE -] - -EBPUR1: MOVEI A,-1(E) ; NEEDED TO TERMINATE BLT - EXCH E,HITOP - HRLI E,(B) - MOVEI B,(E) - BLT E,(A) - POP P,A - POP P,E - POPJ P, - -GIVCOR: SETZ - SIXBIT /CORBLK/ - 1000,,0 - 1000,,-1 - SETZ A - -HIGET: SETZ - SIXBIT /CORBLK/ - 1000,,100000 - 1000,,-1 - A - 401000,,400001 - - -; PROCESS AN ATOM AND ADD IT TO AN APPROPRIATE OBLIST IF IT ISN'T -; ALREADY THERE - -ATOMHK: PUSH TP,$TOBLS ; SAVE OBLIST - PUSH TP,[0] ; FILLED IN LATER - PUSH TP,$TVEC ;SAVE TV POINTERS - PUSH TP,C - PUSH TP,$TVEC - PUSH TP,D - MOVE B,1(C) ;GET THE ATOM - PUSH TP,$TATOM ;AND SAVE - PUSH TP,B - HRRZ A,(B) ;GET OBLIST SPEC FROM ATOM - LSH A,1 - ADDI A,1(TB) ;POINT TO ITS HOME - PUSH TP,$TOBLS - PUSH TP,(A) ;AND SAV IT - MOVE A,(A) - MOVEM A,-10(TP) ; CLOBBER - HLRE E,A - MOVNS E - - ADD B,[3,,3] ;POINT TO ATOM'S PNAME - MOVEI A,0 ;FOR HASHING - XOR A,(B) - AOBJN B,.-1 - TLZ A,400000 ;FORCE POSITIVE RESULT - IDIV A,E - HRLS B ;REMAINDER IN B IS BUCKET - ADDB B,(TP) ;UPDATE POINTER - - SKIPN C,(B) ;GOBBLE BUCKET CONTENTS - JRST USEATM ;NONE, LEAVE AND USE THIS ATOM -OBLOO3: MOVE E,-2(TP) ;RE-GOBBLE ATOM - ADD E,[3,,3] ;POINT TO PNAME - SKIPN D,1(C) ;CHECK LIST ELEMNT - JRST NXTBCK ;0, CHECK NEXT IN THIS BUCKET - ADD D,[3,,3] ;POINT TO PNAME -OBLOO2: MOVE A,(D) ;GET A WORD - CAME A,(E) ;COMPARE - JRST NXTBCK ;THEY DIFFER, TRY NEX -OBLOOP: AOBJP E,CHCKD ;COULD BE A MATCH, GO CHECK - AOBJN D,OBLOO2 ;HAVEN'T LOST YET - -NXTBCK: HRRZ C,(C) ;CDR THE LIST - JUMPN C,OBLOO3 ;IF NOT NIL, KEEP TRYING - -;HERE IF THIS ATOM MUST BE PUT ON OBLIST - -USEATM: MOVE B,-2(TP) ; GET ATOM - HLRZ 0,(B) ; SEE IF PURE OR NOT - TRNN 0,400000 ; SKIP IF IMPURE - JRST PURATM - MOVE B,(TP) ;POINTER TO BUCKET - HRRZ C,(B) ;POINTER TO LIST IN THIS BUCKET - PUSH TP,$TATOM ;GENERATE CALL TO CONS - PUSH TP,-3(TP) - PUSH TP,$TLIST - PUSH TP,C - MCALL 2,CONS ;CONS IT UP - MOVE C,(TP) ;REGOBBLE BUCKET POINTER - HRRZM B,(C) ;CLOBBER - MOVE B,-2(TP) ;POINT TO ATOM - MOVE C,-10(TP) ; GET OBLIST - MOVEM C,2(B) ; INTO ATOM - PUSHJ P,VALMAK ;MAKE A GLOBAL VALUE FOR THIS LOSER -PURAT2: MOVE C,-6(TP) ;RESET POINTERS - MOVE D,-4(TP) - SUB TP,[12,,12] - MOVE B,(C) ;MOVE THE ENTRY - HLLZM B,(D) ;DON'T WANT REF POINTER STORED - MOVE A,1(C) ;AND MOVE ATOM - MOVEM A,1(D) - MOVE A,(P) ;GET CURRENT OFFSET - LSH A,1 - ADDI A,1 - ANDI B,-1 ;CHECK FOR REAL REF - JUMPE B,SETLP1 ;DON'T SAVE THIS ATOM ON TVP - HRRM A,(B) ;CLOBBER CODE - JRST SETLP - - -; HERE TO MAKE A PURE ATOM - -PURATM: HRRZ B,-2(TP) ; POINT TO IT - HLRE E,-2(TP) ; - LNTH - MOVNS E - ADDI E,2 - PUSHJ P,EBPUR ; PURE COPY - HRRM B,-2(TP) ; AND STORE BACK - HRRO B,(TP) ; GET BUCKET BACK -PURAT1: HRRZ C,(B) ; GET CONTENTS - JUMPE C,HICONS ; AT END, OK - CAIL C,HIBOT ; SKIP IF IMPURE - JRST HICONS ; CONS IT ON - MOVEI B,(C) - JRST PURAT1 - -HICONS: HRLI C,TATOM - PUSH P,C - PUSH P,-2(TP) - PUSH P,B - MOVEI B,-2(P) - MOVEI E,2 - PUSHJ P,EBPUR ; MAKE PURE LIST CELL - - MOVE C,(P) - SUB P,[3,,3] - HRRM B,(C) ; STORE IT - MOVE B,1(B) ; ATOM BACK - MOVE C,-6(TP) ; GET TVP SLOT - HRRM B,1(C) ; AND STORE - HLRZ 0,(B) ; TYPE OF VAL - MOVE C,B - CAIN 0,TUNBOU ; NOT UNBOUND? - JRST PURAT3 ; UNBOUND, NO VAL - MOVEI E,2 ; COUNT AGAIN - PUSHJ P,EBPUR ; VALUE CELL - MOVE C,-2(TP) ; ATOM BACK - HLLZS (B) ; CLEAR LH - MOVSI 0,TLOCI - HLLM 0,(C) - MOVEM B,1(C) -PURAT3: HRRZ A,(C) ; GET OBLIST CODE - MOVE A,OBTBL2(A) - MOVEM A,2(C) ; STORE OBLIST SLOT - HLLZS (C) - JRST PURAT2 - -; A POSSIBLE MATCH ARRIVES HERE - -CHCKD: AOBJN D,NXTBCK ;SIZES DIFFER, JUMP - MOVE D,1(C) ;THEY MATCH!, GET EXISTING ATOM - MOVEI A,(D) ;GET TYPE OF IT - MOVE B,-2(TP) ;GET NEW ATOM - HLRZ 0,(B) - TRZ A,377777 ; SAVE ONLY 400000 BIT - TRZ 0,377777 - CAIN 0,(A) ; SKIP IF WIN - JRST IM.PUR - MOVSI 0,400000 - ANDCAM 0,(B) - ANDCAM 0,(D) - HLRZ A,(D) - CAIE A,TUNBOU ;UNBOUND? - JRST A1VAL ;YES, CONTINUE - MOVE A,(B) ;MOVE VALUE - MOVEM A,(D) - MOVE A,1(B) - MOVEM A,1(D) - MOVE B,D ;EXISTING ATOM TO B - MOVEI 0,(B) - CAIL 0,HIBOT - JRST .+3 - PUSHJ P,VALMAK ;MAKE A VALUE - JRST .+2 - PUSHJ P,PVALM - -;NOW FIND ATOMS OCCURENCE IN XFER VECTOR - -OFFIND: MOVE D,-4(TP) ;GET CURRENT POINTER INTO TP - MOVE C,TVP ;AND A COPY OF TVP - MOVEI A,0 ;INITIALIZE COUNTER -ALOOP: CAMN B,1(C) ;IS THIS IT? - JRST AFOUND - ADD C,[2,,2] ;BUMP COUNTER - CAMGE C,D ;HAVE WE HIT END - AOJA A,ALOOP ;NO, KEEP LOOKING - - MOVEI B,[ASCIZ /LOSSAGE--ATOM DISAPPEARED -/] -TYPIT: PUSHJ P,MSGTYP - .VALUE - -AFOUND: LSH A,1 ;FOUND ATOM, GET REAL OFFSET - ADDI A,1 - MOVE C,-6(TP) ;GET TV POINTER TO NEW ATOM - HRRZ B,(C) ;POINT TO REFERENCE - SKIPE B ;ANY THERE? - HRRM A,(B) ;YES, CLOBBER AWAY - SUB TP,[12,,12] - JRST SETLP1 ;AND GO ON - -A1VAL: HLRZ C,(B) ;GET VALUE'S TYPE - MOVE B,D ;NOW PUT EXISTING ATOM IN B - CAIN C,TUNBOU ;UNBOUND? - JRST OFFIND ;YES, WINNER - - MOVEI B,[ASCIZ /LOSSAGE--ATOM TRIES TO HAVE 2 VALUES -/] - JRST TYPIT - - -IM.PUR: MOVEI B,[ASCIZ /LOSSAG--ATOM TRIES TO BE BOTH PURE AND IMPURE -/] - JRST TYPIT - -PAGLOS: MOVEI B,[ASCIZ /LOSSAGE--IMPURE CORE EXTENDS INTO HIGH SEGMENT -/] - JRST TYPIT - -;MAKE A VALUE IN SLOT ON GLOBAL SP - -VALMAK: HLRZ A,(B) ;TYPE OF VALUE - CAIE A,400000+TUNBOU - CAIN A,TUNBOU ;VALUE? - POPJ P, ;NO, ALL DONE - MOVE A,GLOBSP+1(TVP) ;GET POINTER TO GLOBAL SP - SUB A,[4,,4] ;ALLOCATE SPACE - CAMG A,GLOBAS+1(TVP) ;CHECK FOR OVERFLOW - JRST SPOVFL - MOVEM A,GLOBSP+1(TVP) ;STORE IT BACK - MOVE C,(B) ;GET TYPE CELL - TLZ C,400000 - HLLZM C,2(A) ;INTO TYPE CELL - MOVE C,1(B) ;GET VALUE - MOVEM C,3(A) ;INTO VALUE SLOT - MOVSI C,TGATOM ;GET TATOM,,0 - MOVEM C,(A) - MOVEM B,1(A) ;AND POINTER TO ATOM - MOVSI C,TLOCI ;NOW CLOBBER THE ATOM - MOVEM C,(B) ;INTO TYPE CELL - ADD A,[2,,2] ;POINT TO VALUE - MOVEM A,1(B) - POPJ P, - -SPOVFL: MOVEI B,[ASCIZ /LOSSAGE--GLOBAL SP OVERFLOW -/] - JRST TYPIT - - -PVALM: HLRZ 0,(B) - CAIE 0,400000+TUNBOU - CAIN 0,TUNBOU - POPJ P, - MOVEI E,2 - PUSH P,B - PUSHJ P,EBPUR - POP P,C - MOVEM B,1(C) - MOVSI 0,TLOCI - MOVEM 0,(C) - MOVE B,C - POPJ P, - ;SET UP LIST OF INTERNAL NAMES AND ADDRESS NEEDED BY COMPILER - -VECTGO DUMMY1 - -IRP A,,[FINIS,SPECBIND,MESTBL,WNA,WRONGT,$TLOSE,CALER1 -ILOC,IGLOC,IDVAL,ILVAL,IGVAL,INTFLG,LCKINT,TYPLOO,TDEFER -IFALSE,UNAS,UNBOU,RCALL,SEGMNT,SEGLST,NUMPRI,DISXTR,SSPEC1,COMPERR -MAKACT,MAKENV,BFRAME,TTP,TTB,$TTP,$TTB,MAKTUP,TPALOC,IBIND,SSPECS -CILVAL,CISET,CIGVAL,CSETG,IBLOK1,IBLOCK,CLLOC,CGLOC,CASSQ,CGASSQ -CILNT,CILNQ,CILEGQ,CEMPTY,CIEQUA,CIREST,CINTH,CIAT,CSETLO,CIN -CIPUT,CIGET,CIGETL,CIMON,CISTRU,CIMEMQ,CIMEMB,CITOP,CIBACK,TYPSEG -CICONS,CIUVEC,CIVEC,IIFORM,IILIST,CISTNG,HITOP,INCR1,TYPG,VALG,TESTR -OTBSAV,CITYPE,CFRAME,CARGS,CFUNCT,CUTYPE,CPTYPE,CTYPEP,CTYPEQ,CCHUTY -CIREMA,RTFALS,CIGETP,CIGTPR,MPOPJ,TAB,$TAB,ICONS,CSTO,DSTO,NTPALO -CPLUS,CTIMES,CTIME,CDIVID,CMINUS,CLQ,CLEQ,CGQ,CGEQ,CLOG,CSIN,CCOS,CATAN,CSQRT -CFIX,CFLOAT,CEXP,CRAND,CINEQU,SPECBND,PGGIVE,PGFIND,MTYO,CMIN,CMAX,RCL,R1C,W1C -CALLTY,CTYPEC,CTYPEW,NOTTY,CHKAB,CTMPLT,IUNWIN,UNWIN2,NOSHUF,ROOT,ERROBL,INTOBL -CINSER,CIRMV,CLOOKU,CATOM,CIPNAM,ISTRCM,CITERP,CIPRIN,CIPRN1,CIPRNC -CPATM,CP1ATM,CPCATM,CPSTR,CP1STR,CPCSTR,CPCH,CREADC,CNXTCH,CREDC1,CNXTC1 -CGBOUN,IIGLOC,MAKTU2,CIFLTZ,CIUPRS] - .GLOBAL A - ADDSQU A - MAKAT [A]TFIX,A,MUDDLE,0 -TERMIN - -VECRET - -; ROUTINE TO SORT AND PURIFY SQUOZE TABLE - -SQSETU: MOVE A,[SQUTBL-SQULOC+2,,SQUTBL] - MOVEI 0,1 -SQ2: MOVE B,(A) - CAMG B,2(A) - JRST SQ1 - MOVEI 0,0 - EXCH B,2(A) - MOVEM B,(A) - MOVE B,1(A) - EXCH B,3(A) - MOVEM B,1(A) -SQ1: ADD A,[2,,2] - JUMPL A,SQ2 - JUMPE 0,SQSETU - MOVEI E,SQULOC-SQUTBL - MOVEI B,SQUTBL - PUSHJ P,EBPUR ; TO THE PURE WORLD - HRLI B,SQUTBL-SQULOC - MOVEM B,SQUPNT" - POPJ P, - -RHITOP: 0 - -OBSZ: 151. - 151. - 151. - 151. - 317. - -OBTBL2: ROOT+1 - ERROBL+1 - INTOBL+1 - MUDOBL+1 - INITIAL+1 - -OBTBL: INITIAL+1(TVP) - MUDOBL+1(TVP) - INTOBL+1(TVP) - ERROBL+1(TVP) - ROOT+1(TVP) -OBNAM: MQUOTE INITIAL - MQUOTE MUDDLE - MQUOTE INTERRUPTS - MQUOTE ERRORS - MQUOTE ROOT - -END SETUP - - - -TITLE INTERRUPT HANDLER FOR MUDDLE - -RELOCATABLE - -;C. REEVE APRIL 1971 - -.INSRT MUDDLE > - -SYSQ - -IF1,[ -IFE ITS,.INSRT MUDSYS;STENEX > -] - -PDLGRO==10000 ;AMOUNT TO GROW A PDL THAT LOSES -NINT==72. ;MAXIMUM NUMBER OF INTERRUPTS POSSIBLE - -IFN ITS,[ -;SET UP LOCATION 42 TO POINT TO TSINT - -RMT [ - -ZZZ==$. ;SAVE CURRENT LOCATION - -LOC 42 - - JSR MTSINT ;GO TO HANDLER - -LOC ZZZ -] -] - -; GLOBALS NEEDED BY INTERRUPT HANDLER - -.GLOBAL ONINT ; FUDGE INS EXECUTED IF NON ZERO AT START OF INTERRUPT -.GLOBA GCFLG ;TELLS WHETHER OR NOT GARBAGE COLLECTOR IS RUNNING -.GLOBAL GCFLCH ; FLUSH CHARS IMMEDIATE SO GC CAN SEE THEM -.GLOBAL CORTOP ; TOP OF CORE -.GLOBA GCINT ;TELLS GARBAGE COLLECTOR TO SIMULATE AN INTERRUPT -.GLOBAL INTNUM,INTVEC ;TV ENTRIES CONCERNING INTERRUPTS -.GLOBAL AGC ;CALL THE GARBAGE COLLECTOR -.GLOBAL VECNEW,PARNEW,GETNUM ;GC PSEUDO ARGS -.GLOBAL GCPDL ;GARBAGE COLLECTORS PDL -.GLOBAL VECTOP,VECBOT ;DELIMIT VECTOR SPACE -.GLOBAL PURTOP -.GLOBAL PDLBUF ;AMOUNT OF PDL GROWTH -.GLOBAL PGROW ;POINTS TO DOPE WORD OF NEXT PDL TO GROW -.GLOBAL TPGROW ;POINTS TO NEXT MUDDLE PDL TO GROW -.GLOBAL TOPLEV,ERROR%,N.CHNS,CHNL1 -.GLOBAL BUFRIN,CHNL0,SYSCHR ;CHANNEL GLOBALS -.GLOBAL IFALSE,TPOVFL,1STEPR,INTOBL,INCHAR,CURPRI,RDEVIC,RDIREC,GFALS,STATUS -.GLOBAL PSTAT,NOTRES,IOIN2,INAME,INTFCN,CHNCNT,CHANNO,GIBLOK,ICONS,INCONS -.GLOBAL IEVECT,INSRTX,ILOOKC,IPUT,IREMAS,IGET,CSTAK,EMERGE -.GLOBAL MTSINT ;BEGINNING OF INTERRUPT HANDLER -.GLOBAL INTINT ;CALLED BY INITIALIZER TO TAKE CARE OF INT PCS -.GLOBAL FRMSTK,APPLY,CHUNW -.GLOBAL IPCGOT,DIRQ ;HANDLE BRANCHING OFF TO IPC KLUDGERY - -; GLOBALS FOR GC -.GLOBAL GCTIM,GCCAUS,GCCALL - -; GLOBALS FOR MONITOR ROUTINES - -.GLOBAL MONCH,MONCH0,RMONCH,RMONC0,LOCQ,SMON,BAPT,APLQ,MAKACT,NAPT -.GLOBAL PURERR,BUFRIN,INSTAT - -MONITOR - -.GLOBAL MSGTYP,MTYI,UPLO,IFLUSH,OCLOS,ERRET,MASK1,MASK2 ;SUBROUTINES USED -.GLOBAL ERROR,LISTEN,ECHO,RRESET,MTYO,GCHAPN,P.CORE,P.TOP,QUEUES,NOTTY,TTYOP2,TTICHN -.GLOBAL INTHLD,BNDV,SPECBE -;BEGINNING OF ACTUAL INTERRUPT HANDLER (MUST BE IMPURE) - - -;***** TEMP FUDGE ******* - -QUEUES==INTVEC - - -; DECLARATIONS ASSOCIATED WITH INTERRUPT HANDERS AND HEADERS - -; SPECIAL TABLES - -SPECIN: IRP A,,[CHAR,CLOCK,MPV,ILOPR,WRITE,READ,IOC,PURE,SYSDOWN,INFERIOR,RUNT,REALT -PARITY] - MQUOTE A,[A]INTRUP - TERMIN -SPECLN==.-SPECIN - -; TABLE OF SPECIAL FINDING ROUTINES - -FNDTBL: IRP A,,[GETCHN,0,0,0,LOCGET,LOCGET,0,0,0,0,0,0,0] - A - TERMIN - -; TABLE OF SPECIAL SETUP ROUTINES - -INTBL: IRP A,,[S.CHAR,S.CLOK,S.MPV,S.ILOP,S.WMON,S.RMON,S.IOC,S.PURE,S.DOWN,S.INF -S.RUNT,S.REAL,S.PAR] - A - S!A==.IRPCNT - TERMIN - -IFN ITS,[ - -; EXTERNAL INTERRUPT TABLE - -EXTINT: REPEAT NINT-36.,0 - REPEAT 16.,HCHAR - 0 - 0 - REPEAT 8.,HINF - REPEAT NINT-62.,0 -EXTEND: - -IRP A,,[[HCLOCK,13.],[HMPV,14.],[HILOPR,6],[HIOC,9],[HPURE,26.],[HDOWN,7],[HREAL,35.] -[HRUNT,34.],[HPAR,28.]] - IRP B,C,[A] - LOC EXTINT+C - B - .ISTOP - TERMIN -TERMIN - - -LOC EXTEND -] - -IFE ITS,[ - -; TABLES FOR TENEX INTERRUPT SYSTEM - -LEVTAB: P1 ; POINTS TO INT PC HOLDERS FOR LEVS 1,2 AND 3 - P2 - P3 - -CHNMSK==0 ; WILL BE MASK WORD FOR INT SET UP -MFORK==400000 -NNETS==10. ; ALLOW 10 NETWRK INTERRUPTS -NETCHN==36.-NNETS - -CHNTAB: ; LOCATION OF INT ROUTINES FOR VARIOUS "CHANNELS" - BLOCK 36.-NNETS ; THERE AR 36. TENEX INT CHANNELS - -REPEAT NNETS, 1,,INTNET+3*.RPCNT - -IRP A,,[[0,CNTLG],[1,CNTLS],[9.,TNXPDL]] - IRP B,C,[A] - LOC CHNTAB+B - 1,,C - CHNMSK==CHNMSK+<1_<35.-B>> - .ISTOP - TERMIN -TERMIN -LOC CHNTAB+36. - -EXTINT: BLOCK NINT-NNETS - -REPEAT NNETS,HNET - -IRP A,,[[HCNTLG,36.],[HCNTLS,37.]] - IRP B,C,[A] - LOC EXTINT+C - B - .ISTOP - TERMIN -TERMIN -LOC EXTINT+NINT -] - - -; HANDLER/HEADER PARAMETERS - -; HEADER BLOCKS - -IHDRLN==4 ; LENGTH OF HEADER BLOCK - -INAME==0 ; NAME OF INTERRUPT -ISTATE==2 ; CURRENT STATE -IHNDLR==4 ; POINTS TO LIST OF HANDLERS -INTPRI==6 ; CONTAINS PRIORITY OF INTERRUPT - -IHANDL==4 ; LENGTH OF A HANDLER BLOCK - -INXT==0 ; POINTS TO NEXTIN CHAIN -IPREV==2 ; POINTS TO PREV IN CHAIN -INTFCN==4 ; FUNCTION ASSOCIATED WITH THIS HANDLER -INTPRO==6 ; PROCESS TO RUN INT IN - -IFN ITS,[ -RMT [ -IMPURE -TSINT: -MTSINT: 0 ;INTERRUPT BITS GET STORED HERE -TSINTR: 0 ;INTERRUPT PC WORD STORED HERE - JRST TSINTP ;GO TO PURE CODE - -; SOFTWARE INTERNAL INTERRUPTS JSR TO HERE - -LCKINT: 0 - JRST DOINT - -PURE -] -] -IFE ITS,[ -RMT [ -; JSR HERE FOR SOFTWARE INTERNAL INTERRUPTS - -LCKINT: 0 - JRST DOINT -] -] - - -IFN ITS,[ - -;THE REST OF THIS CODE IS PURE - -TSINTP: SOSGE INTFLG ; SKIP IF ENABLED - SETOM INTFLG ;DONT GET LESS THAN -1 - - MOVEM A,TSAVA ;SAVE TWO ACS - MOVEM B,TSAVB - MOVE A,TSINT ;PICK UP INT BIT PATTERN - JUMPL A,2NDWORD ;DONT CHECK FOR PDL OVERFLOW ETC. IF SIGN BIT ON - - TRZE A,200000 ;IS THIS A PDL OVERFLOW? - JRST IPDLOV ;YES, GO HANDLE IT FIRST - -IMPCH: MOVEI B,0 - TRNE A,20000 ;IS IT A MEMORY PROTECTION VIOLATION? - MOVEI B,1 ; FLAG SAME - - TRNE A,40 ;ILLEGAL OP CODE? - MOVEI B,2 ; ALSO FLAG - TRNN A,400 ; IOC? - JRST .+3 - SOS TSINTR - MOVEI B,3 - TLNE A,200 ; PURE? - MOVEI B,4 - SOJGE B,DO.NOW ; CANT WAIT AROUND - -;DECODE THE REST OF THE INTERRUPTS USING A TABLE - -2NDWORD: - JUMPL A,GC2 ;2ND WORD? - IORM A,PIRQ ;NO, INTO WORD 1 - JRST GCQUIT ;AND DISMISS INT - -GC2: TLZ A,400000 ;TURN OFF SIGN BIT - IORM A,PIRQ2 - TRNE A,177777 ;CHECK FOR CHANNELS - JRST CHNACT ;GO IF CHANNEL ACTIVITY -] -GCQUIT: SKIPGE INTFLG ;SKIP IF INTERRUPTS ENABLED - JRST INTDON ;NO, DEFER REAL HANDLING UNTIL LATER - - MOVE A,TSINTR ;PICKUP RETURN WORD -IFE ITS,[ - TLON A,10000 ; EXEC PC? - SUBI A,1 ; YES FIXUP PC -] - MOVEM A,LCKINT ;STORE ELSEWHERE - MOVEI A,DOINTE ;CAUSE DISMISS TO HANDLER - HRRM A,TSINTR ;STORE IN INT RETURN - PUSH P,INTFLG ;SAVE INT FLAG - SETOM INTFLG ;AND DISABLE - - -INTDON: MOVE A,TSAVA ;RESTORE ACS - MOVE B,TSAVB -IFN ITS, .DISMISS TSINTR ;AND DISMISS THE INTERRUPT -IFE ITS, DEBRK - - -DO.NOW: SKIPE GCFLG - JRST DLOSER ; HANDLE FATAL GC ERRORS - MOVSI B,1 - SKIPGE INTFLG ; IF NOT ENABLED - MOVEM B,INTFLG ; PRETEND IT IS - JRST 2NDWORD - -IFE ITS,[ - -; HERE FOR TENEX PDL OVER FLOW INTERRUPT - -TNXPDL: SOSGE INTFLG - SETOM INTFLG - MOVEM A,TSAVA - MOVEM B,TSAVB - JRST IPDLOV ; GO TO COMMON HANDLER - -; HERE FOR TENEX ^G AND ^S INTERRUPTS - -CNTLG: MOVEM A,TSAVA - MOVEI A,1 - JRST CNTSG - -CNTLS: MOVEM A,TSAVA - MOVEI A,2 - -CNTSG: MOVEM B,TSAVB - IORM A,PIRQ2 ; SAY FOR MUDDLE LEVEL - SOSGE INTFLG - SETOM INTFLG - JRST GCQUIT -INTNET: -REPEAT NNETS,[ - MOVEM A,TSAVA - MOVE A,[1_<.RPCNT+NETCHN>] - JRST CNTSG -] -] - -; HERE TO PROCESS INTERRUPTS - -DOINT: SKIPE INTHLD ; GLOBAL LOCK ON INTS - JRST @LCKINT - SETOM INTHLD ; DONT LET IT HAPPEN AGAIN - PUSH P,INTFLG -DOINTE: SKIPE ONINT ; ANY FUDGE? - XCT ONINT ; YEAH, TRY ONE - EXCH 0,LCKINT ; RELATIVIZE PC IF FROM RSUBR - PUSH P,0 ; AND SAVE - ANDI 0,-1 - CAMG 0,PURTOP - CAMGE 0,VECBOT - JRST DONREL - SUBI 0,(M) ; M IS BASE REG - HLL 0,(P) ; GET FLAGS - TLO 0,M ; INDEX IT OFF M - EXCH 0,(P) ; AND RESTORE TO STACK -DONREL: EXCH 0,LCKINT ; GET BACK SAVED 0 - SETZM INTFLG ;DISABLE - AOS -1(P) ;INCR SAVED FLAG - -;NOW SAVE WORKING ACS - - PUSHJ P,SAVACS - HLRZ A,-1(P) ; HACK FUNNYNESS FOR MPV/ILOPR - SKIPE A - SETZM -1(P) ; REALLY DISABLED - -DIRQ: MOVE A,PIRQ ;NOW SATRT PROCESSING - JFFO A,FIRQ ;COUNT BITS AND GO - MOVE A,PIRQ2 ;1ST DONE, LOOK AT 2ND - JFFO A,FIRQ2 - -INTDN1: SKIPN GCHAPN ; SKIP IF MUST DO GC INT - JRST .+3 - SETZM GCHAPN - PUSHJ P,INTOGC ; AND INTERRUPT - - PUSHJ P,RESTAC - -IFN ITS,[ - .SUSET [.SPICLR,,[0]] ; DISABLE INTS -] - POP P,LCKINT - POP P,INTFLG - SETZM INTHLD ; RE-ENABLE THE WORLD -IFN ITS,[ - EXCH 0,LCKINT - HRRI 0,@0 ; EFFECTIVIZE THE ADDRESS - TLZ 0,37 ; KILL IND AND INDEX - EXCH 0,LCKINT - .DISMIS LCKINT -] -IFE ITS, JRST @LCKINT -FIRQ: PUSHJ P,GETBIT ;SET UP THE BIT TO CLOBBER IN PIRQ - ANDCAM A,PIRQ ;CLOBBER IT - ADDI B,36. ;OFSET INTO TABLE - JRST XIRQ ;GO EXECUTE - -FIRQ2: PUSHJ P,GETBIT ;PREPARE TO CLOBBER BIT - ANDCAM A,PIRQ2 ;CLOBBER IT - ADDI B,71. ;AGAIN OFFSET INTO TABLE -XIRQ: - CAIE B,21 ;PDL OVERFLOW? - JRST FHAND ;YES, HACK APPROPRIATELY - -PDL2: SKIPN A,PGROW - SKIPE A,TPGROW - JRST .+2 - JRST DIRQ ; NOTHING GROWING, FALSE ALARM - MOVEI B,PDLGRO_-6 ;GET GROWTH SPEC - DPB B,[111100,,-1(A)] ;STORE GROWTH SPEC -REAGC: MOVE C,[10.,,1] ; INDICATOR FOR AGC - SKIPE PGROW ; P IS GROWING - ADDI C,6 - SKIPE TPGROW ; TP IS GROWING - ADDI C,1 - PUSHJ P,AGC ;COLLECT GARBAGE - SETZM PGROW - SETZM TPGROW - AOJL A,REAGC ; IF NO CORE, RETRY - JRST DIRQ - -SAVACS: -IRP A,,[0,A,B,C,D,E] - PUSH TP,A!STO(PVP) - SETZM A!STO(PVP) ;NOW ZERO TYPE - PUSH TP,A - TERMIN - POPJ P, - -RESTAC: -IRP A,,[E,D,C,B,A,0] - POP TP,A - POP TP,A!STO(PVP) - TERMIN - POPJ P, - -; HERE TO DO GC INTERRUPT AND CLOSE ANY DEAD CHANNELS - -INTOGC: PUSH P,[N.CHNS-1] - MOVE A,TVP - ADD A,[CHNL1,,CHNL1] - PUSH TP,$TVEC - PUSH TP,A - -INTGC1: MOVE A,(TP) ; GET POINTER - SKIPN B,1(A) ; ANY CHANNEL? - JRST INTGC2 - HRRE 0,(A) ; INDICATOR - JUMPGE 0,INTGC2 - PUSH TP,$TCHAN - PUSH TP,B - MCALL 1,FCLOSE - - MOVE A,(TP) - -INTGC2: HLLZS (A) - ADD A,[2,,2] - MOVEM A,(TP) - SOSE (P) - JRST INTGC1 - - SUB P,[1,,1] - SUB TP,[2,,2] - PUSH TP,$TCHSTR - PUSH TP,CHQUOTE GC - PUSH TP,$TFLOAT ; PUSH ON TIME ARGUMENT - PUSH TP,GCTIM - PUSH TP,$TFIX ; PUSH ON THE CAUSE ARGUMENT - PUSH TP,GCCAUS - PUSH TP,$TATOM ; PUSH ON THE CALL ARGUMENT - MOVE A,GCCALL - PUSH TP,@GCALLR(A) - MCALL 4,INTERR - POPJ P, - - -GCALLR: 0 - MQUOTE BLOAT - MQUOTE GROW - MQUOTE LIST - MQUOTE VECTOR - MQUOTE SET - MQUOTE SETG - MQUOTE FREEZE - MQUOTE PURE-PAGE-LOADER - MQUOTE GC - MQUOTE INTERRUPT-HANDLER - MQUOTE NEWTYPE - - ; OLD "ON" SETS UP EVENT AND HANDLER - -MFUNCTION ON,SUBR - - ENTRY - - HLRE 0,AB ; 0=> -2*NUM OF ARGS - ASH 0,-1 ; TO -NUM - CAME 0,[-5] - JRST .+3 - MOVEI B,10(AB) ; LAST MUST BE CHAN OR LOC - PUSHJ P,CHNORL - ADDI 0,3 - JUMPG 0,TFA ; AT LEAST 3 - MOVEI A,0 ; SET UP IN CASE NO PROC - AOJG 0,ONPROC ; JUMP IF NONE - GETYP C,6(AB) ; CHECK IT - CAIE C,TPVP - JRST TRYFIX - MOVE A,7(AB) ; GET IT -ONPROC: PUSH P,A ; SAVE AS A FLAG - GETYP A,(AB) ; CHECK PREV EXISTANCE - PUSH P,0 - CAIN A,TATOM - JRST .+3 - CAIE A,TCHSTR - JRST WTYP1 - MOVEI B,(AB) ; FIND IT - PUSHJ P,FNDINT - POP P,0 ; REST NUM OF ARGS - JUMPN B,ON3 ; ALREADY THERE - SKIPE C ; SKIP IF NOTHING TO FLUSH - SUB TP,[2,,2] - PUSH TP,(AB) ; GET NAME - PUSH TP,1(AB) - PUSH TP,4(AB) - PUSH TP,5(AB) - MOVEI A,2 ; # OF ARGS TO EVENT - AOJG 0,ON1 ; JUMP IF NO LAST ARG - PUSH TP,10(AB) - PUSH TP,11(AB) - ADDI A,1 -ON1: ACALL A,EVENT - -ON3: PUSH TP,A - PUSH TP,B - PUSH TP,2(AB) ; NOW FCN - PUSH TP,3(AB) - MOVEI A,3 ; NUM OF ARGS - SKIPN (P) - SOJA A,ON2 ; NO PROC - PUSH TP,$TPVP - PUSH TP,7(AB) -ON2: ACALL A,HANDLER - JRST FINIS - - -TRYFIX: SKIPN A,7(AB) - CAIE C,TFIX - JRST WRONGT - JRST ONPROC - -; ROUTINE TO BUILD AN EVENT - -MFUNCTION EVENT,SUBR - - ENTRY - - HLRZ 0,AB - CAIN 0,-2 ; IF JUST 1 - JRST RE.EVN ; COULD BE EVENT - CAIL 0,-3 ; MUST BE AT LEAST 2 ARGS - JRST TFA - GETYP A,2(AB) ; 2ND ARG MUST BE FIXED POINT PRIORITY - CAIE A,TFIX - JRST WTYP2 - GETYP A,(AB) ; FIRST ARG SHOULD BE CHSTR - CAIN A,TATOM ; ALLOW ACTUAL ATOM - JRST .+3 - CAIE A,TCHSTR - JRST WTYP1 - CAIL 0,-5 - JRST GOTRGS - CAIG 0,-7 - JRST TMA - MOVEI B,4(AB) - PUSHJ P,CHNORL ; CHANNEL OR LOCATIVE (PUT ON STACK) - -GOTRGS: MOVEI B,(AB) ; NOW TRY TO FIND HEADER FOR THIS INTERRUPT - PUSHJ P,FNDINT ; CALL INTERNAL HACKER - JUMPN B,FINIS ; ALREADY ONE OF THIS NAME - PUSH P,C - JUMPE C,.+3 ; GET IT OFF STACK - POP TP,B - POP TP,A - PUSHJ P,MAKINT ; MAKE ONE FOR ME - MOVSI 0,TFIX - MOVEM 0,INTPRI(B) ; SET UP PRIORITY - MOVE 0,3(AB) - MOVEM 0,INTPRI+1(B) -CH.SPC: POP P,C ; GET CODE BACK - SKIPGE C - PUSHJ P,DO.SPC ; DO ANY SPECIAL HACKS - JRST FINIS - -RE.EVN: GETYP 0,(AB) - CAIE 0,TINTH - JRST TFA ; ELSE SAY NOT ENOUGH - MOVE B,1(AB) ; GET IT - SETZM ISTATE+1(B) ; MAKE SURE ENABLED - SETZB D,C - GETYP A,INAME(B) ; CHECK FOR CHANNEL - CAIN A,TCHAN ; SKIP IF NOT - HRROI C,SS.CHA ; SET UP CHANNEL HACK - HRLZ E,INTPRI(B) ; GET POSSIBLE READ/WRITE BITS - TLNE E,.WRMON+.RDMON ; SKIP IF NOT MONITORS - PUSHJ P,GETNM1 - JUMPL C,RE.EV1 - MOVE B,INAME+1(B) ; CHECK FOR SPEC - PUSHJ P,SPEC1 - MOVE B,1(AB) ; RESTORE IHEADER -RE.EV1: PUSH TP,INAME(B) - PUSH TP,INAME+1(B) - PUSH P,C - MOVSI C,TATOM - PUSH TP,$TATOM - SKIPN D - MOVE D,MQUOTE INTERRUPT - PUSH TP,D - MOVE A,INAME(B) - MOVE B,INAME+1(B) ; GET IT - PUSHJ P,IGET ; LOOK FOR IT - JUMPN B,FINIS ; RETURN IT - MOVE A,(TB) - MOVE B,1(TB) - POP TP,D - POP TP,C - PUSH TP,(AB) - PUSH TP,1(AB) - PUSHJ P,IPUT ; REESTABLISH IT - MOVE A,(AB) - MOVE B,1(AB) - JRST CH.SPC - - -; FUNCTION TO GENERATE A HANDLER FOR A GIVEN INTERRUPT - -MFUNCTION HANDLER,SUBR - - ENTRY - - HLRZ 0,AB - CAIL 0,-2 ; MUST BE 2 OR MORE ARGS - JRST TFA - GETYP A,(AB) - CAIE A,TINTH ; EVENT? - JRST WTYP1 - GETYP A,2(AB) - CAIN 0,-4 ; IF EXACTLY 2 - CAIE A,THAND ; COULD BE HANDLER - JRST CHEVNT - - MOVE B,3(AB) ; GET IT - SKIPN IPREV+1(B) ; SKIP IF ALREADY IN USE - JRST HNDOK - MOVE D,1(AB) ; GET EVENT - SKIPN D,IHNDLR+1(D) ; GET FIRST HANDLER - JRST BADHND - CAMN D,B ; IS THIS IT? - JRST HFINIS ; YES, ALREADY "HANDLED" - MOVE D,INXT+1(D) ; GO TO NEXT HANDLER - JUMPN D,.-3 -BADHND: PUSH TP,$TATOM - PUSH TP,EQUOTE HANDLER-ALREADY-IN-USE - JRST CALER1 - -CHEVNT: CAIG 0,-7 ; SKIP IF LESS THAN 4 - JRST TMA - PUSH TP,$TPVP ; SLOT FOR PROCESS - PUSH TP,[0] - CAIE 0,-6 ; IF 3, LOOK FOR PROC - JRST NOPROC - GETYP 0,4(AB) - CAIE 0,TPVP - JRST WTYP3 - MOVE 0,5(AB) - MOVEM 0,(TP) - -NOPROC: PUSHJ P,APLQ - JRST NAPT - PUSHJ P,MHAND ; MAKE THE HANDLER - MOVE 0,1(TB) ; GET PROCESS - MOVEM 0,INTPRO+1(B) ; AND PUT IT INTO HANDLER - MOVSI 0,TPVP ; SET UP TYPE - MOVEM 0,INTPRO(B) - MOVE 0,2(AB) ; SET UP FUNCTION - MOVEM 0,INTFCN(B) - MOVE 0,3(AB) - MOVEM 0,INTFCN+1(B) - -HNDOK: MOVE D,1(AB) ; PICK UP EVEENT - MOVE E,IHNDLR+1(D) ; GET POINTER TO HANDLERS - MOVEM B,IHNDLR+1(D) ; PUT NEW ONE IN - MOVSI 0,TINTH ; GET INT HDR TYPE - MOVEM 0,IPREV(B) ; INTO BACK POINTER - MOVEM D,IPREV+1(B) ; AND POINTER ITSELF - MOVEM E,INXT+1(B) ; NOW NEXT POINTER - MOVSI 0,THAND ; NOW HANDLER TYPE - MOVEM 0,IHNDLR(D) ; SET TYPE IN HEADER - MOVEM 0,INXT(B) - JUMPE E,HFINIS ; JUMP IF HEADER WAS EMPTY - MOVEM 0,IPREV(E) ; FIX UP ITS PREV - MOVEM B,IPREV+1(E) -HFINIS: MOVSI A,THAND - JRST FINIS - - - -; FUNCTIONS TO SET TIME LIMITS FOR REALTIME AND RUNTIME INTS - -MFUNCTION RUNTIMER,SUBR - - ENTRY 1 - - GETYP 0,(AB) - JFCL 10,.+1 - MOVE A,1(AB) - CAIE 0,TFIX - JRST RUNT1 - IMUL A,[245761.] - JRST RUNT2 - -RUNT1: CAIE 0,TFLOAT - JRST WTYP1 - FMPR A,[245760.62] - MULI A,400 ; FIX IT - TSC A,A - ASH B,(A)-243 - MOVE A,B -RUNT2: JUMPL A,OUTRNG ; NOT FOR NEG # - JFCL 10,OUTRNG - .SUSET [.SRTMR,,A] - MOVE A,(AB) - MOVE B,1(AB) - JRST FINIS - -MFUNCTION REALTIMER,SUBR - - ENTRY 1 - - JFCL 10,.+1 - GETYP 0,(AB) - MOVE A,1(AB) - CAIE 0,TFIX - JRST REALT1 - IMULI A,60. ; TO 60THS OF SEC - JRST REALT2 - -REALT1: CAIE 0,TFLOAT - JRST WTYP1 - FMPRI A,(60.0) - MULI A,400 - TSC A,A - ASH B,(A)-243 - MOVE A,B - -REALT2: JUMPL A,OUTRNG - JFCL 10,OUTRNG - MOVE B,[200000,,A] - .REALT B, - JFCL - MOVE A,(AB) - MOVE B,1(AB) - JRST FINIS - -; FUNCTIONS TO ENABLE AND DISABLE INTERRUPTS - -MFUNCTION %ENABL,SUBR,ENABLE - - PUSHJ P,GTEVNT - SETZM ISTATE+1(B) - JRST FINIS - -MFUNCTION %DISABL,SUBR,DISABLE - - - PUSHJ P,GTEVNT - SETOM ISTATE+1(B) - JRST FINIS - -GTEVNT: ENTRY 1 - GETYP 0,(AB) - CAIE 0,TINTH - JRST WTYP1 - MOVE A,(AB) - MOVE B,1(AB) - POPJ P, - -DO.SPC: HRRZ C,INTBL(C) ; POINT TO SPECIAL CODE - HLRZ 0,AB ; - TWO TIMES NUM ARGS - PUSHJ P,(C) ; CALL ROUTINE - JUMPE E,CPOPJ ; NO BITS TO ENABLE, LEAVE -IFE ITS,[ - PUSH TP,A - PUSH TP,B - MOVE B,1(TB) ; CHANNEL - MOVE 0,CHANNO(B) - MOVEM 0,(E) ; SAVE IN TABLE - MOVEI E,(E) - SUBI E,NETJFN-NETCHN - MOVE A,0 ; SETUP FOR MTOPR - MOVEI B,24 - MOVSI C,(E) - TLO C,770000 ; DONT SETUP INR/INS - MTOPR - MOVEI 0,1 - MOVNS E - LSH 0,35.(E) - IORM 0,MASK1 - MOVE B,MASK1 - MOVEI A,MFORK - AIC - - POP TP,B - POP TP,A - POPJ P, ; ***** TEMP ****** -] -IFN ITS,[ - CAILE E,35. ; SKIP IF 1ST WORD BIT - JRST SETW2 - LSH 0,-1(E) - - IORM 0,MASK1 ; STORE IN PROTOTYPE MASK - .SUSET [.SMASK,,MASK1] - POPJ P, - -SETW2: LSH 0,-36.(E) - IORM 0,MASK2 ; SET UP PROTO MASK2 - .SUSET [.SMSK2,,MASK2] - POPJ P, -] - -; ROUTINE TO CHECK FOR CHANNEL OR LOCATIVE - -CHNORL: GETYP A,(B) ; GET TYPE - CAIN A,TCHAN ; IF CHANNEL - JRST CHNWIN - PUSH P,0 - PUSHJ P,LOCQ ; ELSE LOOCATIVE - JRST WRONGT - POP P,0 -CHNWIN: PUSH TP,(B) - PUSH TP,1(B) - POPJ P, - -; SUBROUTINE TO FIND A HANDLER OF A GIVEN NAME - -FNDINT: PUSHJ P,FNDNM - JUMPE B,CPOPJ - PUSHJ P,SPEC1 ; COULD BE FUNNY - -INTASO: PUSH P,C ; C<0 IF SPECIAL - PUSH TP,A - PUSH TP,B - MOVSI C,TATOM - SKIPN D ; COULD BE CHANGED FOR MONITOR - MOVE D,MQUOTE INTERRUPT - PUSH TP,C - PUSH TP,D - PUSHJ P,IGET - MOVE D,(TP) - SUB TP,[2,,2] - POP P,C ; AND RESTOR SPECIAL INDICATOR - SKIPE B ; IF FOUND - SUB TP,[2,,2] ; REMOVE CRUFT -CPOPJ: POPJ P, ; AND RETURN - -; CHECK FOR SPECIAL INTERNAL INTERRUPT HACK - -SPEC1: MOVSI C,-SPECLN ; BUILD AOBJN PNTR -SPCLOP: CAME B,@SPECIN(C) ; SKIP IF SPECIAL - AOBJN C,.-1 ; UNTIL EXHAUSTED - JUMPGE C,.+3 - SKIPE E,FNDTBL(C) - JRST (E) - MOVEI 0,-1(TB) ; SEE IF OK - CAIE 0,(TP) - JRST TMA - POPJ P, - -; ROUTINE TO CREATE A NEW INTERRUPT (INTERNAL ONLY--NOT ITS FLAVOR) - -MAKINT: JUMPN C,GOTATM ; ALREADY HAVE NAME, GET THING - MOVEI B,(AB) ; POINT TO STRING - PUSHJ P,CSTAK ; CHARS TO STAKC - MOVE B,INTOBL+1(TVP) - PUSHJ P,INSRTX - MOVE D,MQUOTE INTERRUPT -GOTATM: PUSH TP,$TINTH ; MAKE SLOT FOR HEADER BLOCK - PUSH TP,[0] - PUSH TP,A - PUSH TP,B ; SAVE ATOM - PUSH TP,$TATOM - PUSH TP,D - MOVEI A,IHDRLN*2 - PUSHJ P,GIBLOK - MOVE A,-3(TP) ; GET NAME AND STORE SAME - MOVEM A,INAME(B) - MOVE A,-2(TP) - MOVEM A,INAME+1(B) - SETZM ISTATE+1(B) - MOVEM B,-4(TP) ; STASH HEADER - POP TP,D - POP TP,C - EXCH B,(TP) - MOVSI A,TINTH - EXCH A,-1(TP) ; INTERNAL PUT CALL - PUSHJ P,IPUT - POP TP,B - POP TP,A - POPJ P, - -; FIND NAME OF INTERRUPT - -FNDNM: GETYP A,(B) ; TYPE - CAIE A,TCHSTR ; IF STRING - JRST FNDATM ; DONT HAVE ATOM, OTHERWISE DO - PUSHJ P,IILOOK - JRST .+2 -FNDATM: MOVE B,1(B) - SETZB C,D ; PREVENT LOSSAGE LATER - MOVSI A,TATOM - -; THE NEXT 2 INSTRUCTIONS ARE A KLUDGE TO GET THE RIGHT ERROR ATOM - - CAMN B,IMQUOTE ERROR - MOVE B,MQUOTE ERROR,ERROR,INTRUP - POPJ P, - -IILOOK: PUSHJ P,CSTAK ; PUT CHRS ON STACK - MOVE B,INTOBL+1(TVP) - JRST ILOOKC ; LOOK IT UP - -; ROUTINE TO MAKE A HANDLER BLOCK - -MHAND: MOVEI A,IHANDL*2 - JRST GIBLOK ; GET BLOCK - -; HERE TO GET CHANNEL FOR "CHAR" INTERRUPT - -GETCHN: GETYP 0,(TB) ; GET TYPE - CAIE 0,TCHAN ; CHANNL IS WINNER - JRST WRONGT - MOVE A,(TB) ; USE THE CHANNEL TO NAME THE INTERRUPT - MOVE B,1(TB) - SKIPN CHANNO(B) ; SKIP IF WINNING CHANNEL - JRST CBDCHN ; LOSER - POPJ P, - -LOCGET: GETYP 0,(TB) ; TYPE - CAIN 0,TCHAN ; SKIP IF LOCATIVE - JRST WRONGT - MOVE D,B - MOVE A,(TB) - MOVE B,1(TB) ; GET LOCATIVE - POPJ P, - -; FINAL MONITOR SETUP ROUTINES - -S.RMON: SKIPA E,[.RDMON,,] -S.WMON: MOVSI E,.WRMON - PUSH TP,A - PUSH TP,B - HLRM E,INTPRI(B) ; SAVE BITS - MOVEI B,(TB) ; POINT TO LOCATIVE - HRRZ A,FSAV(TB) - CAIN A,OFF - MOVSI D,(ANDCAM E,) ; KILL INST - CAIN A,EVENT - MOVSI D,(IORM E,) - PUSHJ P,SMON ; GO DO IT - POP TP,B - POP TP,A - MOVEI E,0 - POPJ P, - - -; SPECIAL SETUP ROUTINES FOR INITIAL INTERRUPTS - -IFN ITS,[ -S.CHAR: MOVE E,1(TB) ; GET CHANNEL - MOVE E,CHANNO(E) - ADDI E,36. ; GET CORRECT MASK BIT -ONEBIT: MOVEI 0,1 ; BIT FOR INT TO RET - POPJ P, -] -IFE ITS,[ -S.CHAR: MOVE E,1(TB) - MOVE 0,RDEVIC(E) - ILDB 0,0 ; 1ST CHAR - PUSH P,A - CAIE 0,"N ; NET ? - JRST S.CHA1 - - MOVEI A,0 - HRRZ 0,CHANNO(E) - MOVE E,[-NNETS,,NETJFN] - CAMN 0,(E) - JRST S.CHA2 - SKIPN (E) - MOVE A,E ; REMEMBER WHERE - AOBJN E,.-5 - TLNN A,-1 - FATAL NO MORE NETWORK - MOVE E,A -S.CHA1: MOVEI E,0 -S.CHA2: POP P,A - POPJ P, -] - - -; SPECIAL FOR CLOCK - -S.DOWN: SKIPA E,[7] -S.CLOK: MOVEI E,13. ; FOR NOW JUST GET BIT # - JRST ONEBIT - -S.PAR: MOVEI E,28. - JRST ONEBIT - -; RUNTIME AND REALTIME INTERRUPTS - -S.RUNT: SKIPA E,[34.] -S.REAL: MOVEI E,35. - JRST ONEBIT - -S.IOC: SKIPA E,[9.] ; IO CHANNEL ERROR -S.PURE: MOVEI E,26. - JRST ONEBIT - -; MPV AND ILOPR - -S.MPV: SKIPA E,[14.] ; BIT POS -S.ILOP: MOVEI E,6 - JRST ONEBIT - -; HERE TO TURN ALL INFERIOR INTS - -S.INF: MOVEI E,36.+16.+2 ; START OF BITS - MOVEI 0,37 ; 8 BITS WORTH - POPJ P, - - -; HERE TO HANDLE ITS INTERRUPTS - -FHAND: SKIPN D,EXTINT(B) ; SKIP IF HANDLERS ARE POSSIBLE - JRST DIRQ - JRST (D) - -IFN ITS,[ -; SPECIAL CHARACTER HANDLERS - -HCHAR: MOVEI D,CHNL0+1(TVP) - ADDI D,(B) ; POINT TO CHANNEL SLOT - ADDI D,(B) - SKIPN D,-72.(D) ; PICK UP CHANNEL - JRST IPCGOT ;WELL, IT GOTTA BEE THE THE IPC THEN - PUSH TP,$TCHAN - PUSH TP,D - LDB 0,[600,,STATUS(D)] ; GET DEVICE CODE - CAILE 0,2 ; SKIP IF A TTY - JRST HNET ; MAYBE NETWORK CHANNEL - CAMN D,TTICHN+1(TVP) - SKIPN NOTTY - JRST HCHR11 - MOVE B,D ; CHAN TO B - PUSHJ P,TTYOP2 ; RE-GOBBLE TTY - MOVE D,(TP) -HCHR11: MOVE D,CHANNO(D) ; GET ITS CHANNEL - PUSH P,D ; AND SAVE IT - .CALL HOWMNY ; GET # OF CHARS - MOVEI B,0 ; IF TTY GONE, NO CHARS -RECHR: ADDI B,1 ; BUMP BY ONE FOR SOSG - MOVEM B,CHNCNT(D) ; AND SAVE - IORM A,PIRQ2 ; LEAVE THE INT ON - -CHRLOO: MOVE D,(P) ; GET CHNNAEL NO. - SOSG CHNCNT(D) ; GET COUNT - JRST CHRDON - - MOVE B,(TP) - MOVE D,BUFRIN(B) ; GET EXTRA BUFFER - XCT IOIN2(D) ; READ CHAR - PUSH TP,$TCHSTR - PUSH TP,CHQUOTE CHAR - PUSH TP,$TCHRS ; SAVE CHAR FOR CALL - PUSH TP,A - PUSH TP,$TCHAN ; SAVE CHANNEL - PUSH TP,B - PUSHJ P,INCHAR ; PUT CHAR IN USERS BUFFER - MCALL 3,INTERRUPT ; RUN THE HANDLERS - JRST CHRLOO ; AND LOOP - -CHRDON: .CALL HOWMNY - MOVEI B,0 - MOVEI A,1 ; SET FOR PI WORD CLOBBER - LSH A,(D) - JUMPG B,RECHR ; ANY MORE? - ANDCAM A,PIRQ2 - SUB P,[1,,1] - SUB TP,[2,,2] - JRST DIRQ - - - -; HERE FOR NET CHANNEL INTERRUPT - -HNET: CAIE 0,26 ; NETWORK? - JRST HSTYET ; HANDLE PSEUDO TTY ETC. - PUSH TP,$TATOM - PUSH TP,MQUOTE CHAR,CHAR,INTRUP - PUSH TP,$TUVEC - PUSH TP,BUFRIN(D) - PUSH TP,$TCHAN - PUSH TP,D - MOVE B,D ; CHAN TO B - PUSHJ P,INSTAT ; UPDATE THE NETWRK STATE - MCALL 3,INTERRUPT - SUB TP,[2,,2] - JRST DIRQ - -HSTYET: PUSH TP,$TATOM - PUSH TP,MQUOTE CHAR,CHAR,INTRUP - PUSH TP,$TCHAN - PUSH TP,D - MCALL 2,INTERRUPT - SUB TP,[2,,2] - JRST DIRQ - -] -CBDCHN: PUSH TP,$TATOM - PUSH TP,EQUOTE BAD-CHANNEL - JRST CALER1 - -IFN ITS,[ - -HCLOCK: PUSH TP,$TCHSTR - PUSH TP,CHQUOTE CLOCK - MCALL 1,INTERRUPT - JRST DIRQ - -HRUNT: PUSH TP,$TATOM - PUSH TP,MQUOTE RUNT,RUNT,INTRUP - MCALL 1,INTERRUPT - JRST DIRQ - -HREAL: PUSH TP,$TATOM - PUSH TP,MQUOTE REALT,REALT,INTRUP - MCALL 1,INTERRUPT - JRST DIRQ - -HPAR: MOVE A,MQUOTE PARITY,PARITY,INTRUP - JRST HMPV1 - -HMPV: MOVE A,MQUOTE MPV,MPV,INTRUP - JRST HMPV1 - -HILOPR: MOVE A,MQUOTE ILOPR,ILOPR,INTRUP - JRST HMPV1 - -HPURE: MOVE A,MQUOTE PURE,PURE,INTRUP -HMPV1: PUSH TP,$TATOM - PUSH TP,A - PUSH P,LCKINT ; SAVE LOCN - PUSH TP,$TATOM - PUSH TP,A - PUSH TP,$TWORD - PUSH TP,LCKINT - MCALL 2,EMERGENCY - POP P,A - MOVE C,(TP) - SUB TP,[2,,2] - JUMPN B,DIRQ - - PUSH TP,$TATOM - PUSH TP,EQUOTE DANGEROUS-INTERRUPT-NOT-HANDLED - PUSH TP,$TATOM - PUSH TP,C - PUSH TP,$TWORD - PUSH TP,A - MCALL 3,ERROR - JRST DIRQ - - - -; HERE TO HANDLE SYS DOWN INTERRUPT - -HDOWN: PUSH TP,$TATOM - PUSH TP,MQUOTE SYSDOWN,SYSDOWN,INTRUP - .DIETI A, ; HOW LONG? - PUSH TP,$TFIX - PUSH TP,A - PUSH P,A ; FOR MESSAGE - MCALL 2,INTERRUPT - POP P,A - JUMPN B,DIRQ - .SUSET [.RTTY,,B] ; DO WE NOW HAVE A TTY AT ALL? - JUMPL B,DIRQ ; DONT HANG AROUND - PUSH P,A - MOVEI B,[ASCIZ / -Excuse me, SYSTEM going down in /] - SKIPG (P) ; SKIP IF REALLY GOING DOWN - MOVEI B,[ASCIZ / -Excuse me, SYSTEM has been REVIVED! -/] - PUSHJ P,MSGTYP - POP P,B - JUMPE B,DIRQ - IDIVI B,30. ; TO SECONDS - IDIVI B,60. ; A/ SECONDS B/ MINUTES - JUMPE B,NOMIN - PUSH P,C - PUSHJ P,DECOUT - MOVEI B,[ASCIZ / minutes /] - PUSHJ P,MSGTYP - POP P,B - JRST .+2 -NOMIN: MOVEI B,(C) - PUSHJ P,DECOUT - MOVEI B,[ASCIZ / seconds. -/] - PUSHJ P,MSGTYP - JRST DIRQ - -; TWO DIGIT DEC OUT FROM B/ - -DECOUT: IDIVI B,10. - JUMPE B,DECOU1 ; NO TEN - MOVEI A,60(B) - PUSHJ P,MTYO -DECOU1: MOVEI A,60(C) - JRST MTYO - -; HERE TO HANDLE I/O CHANNEL ERRORS - -HIOC: .SUSET [.RAPRC,,A] ; CONTAINS CHANNEL OF MOST RECENT LOSSAGE - LDB A,[330400,,A] ; GET CHAN # - MOVEI C,(A) ; COPY - PUSH TP,$TATOM ; PUSH ERROR - PUSH TP,EQUOTE FILE-SYSTEM-ERROR - - PUSH TP,$TCHAN - ASH C,1 ; GET CHANNEL - ADDI C,CHNL0+1(TVP) ; GET CHANNEL VECTOR - PUSH TP,(C) - LSH A,23. ; DO A .STATUS - IOR A,[.STATUS A] - XCT A - PUSHJ P,GFALS ; GEN NAMED FALSE - PUSH TP,A - PUSH TP,B - PUSH TP,$TATOM - PUSH TP,MQUOTE IOC,IOC,INTRUP - - PUSH TP,A - PUSH TP,B - PUSH TP,-7(TP) - PUSH TP,-7(TP) - MCALL 3,EMERGENCY - JUMPN B,DIRQ1 ; JUMP IF HANDLED - MCALL 3,ERROR - JRST DIRQ - -DIRQ1: SUB TP,[6,,6] - JRST DIRQ - -; HANDLE INFERIOR KNOCKING AT THE DOOR - -HINF: SUBI B,36.+16.+2 ; CONVERT TO INF # - PUSH TP,$TATOM - PUSH TP,MQUOTE INFERIOR,INFERIOR,INTRUP - PUSH TP,$TFIX - PUSH TP,B - MCALL 2,INTERRUPT - JRST DIRQ -] -IFE ITS,[ - -; HERE FOR TENEX INTS (FIRST CUT) - -HCNTLG: MOVEI A,7 - JRST HCNGS - -HCNTLS: MOVEI A,23 - -HCNGS: PUSH TP,$TATOM - PUSH TP,MQUOTE CHAR,CHAR,INTRUP - PUSH TP,$TCHRS - PUSH TP,A - PUSH TP,$TCHAN - PUSH TP,TTICHN+1(TVP) - MCALL 3,INTERRUPT - JRST DIRQ - -HNET: MOVE A,NETJFN-NINT+NNETS(B) - JUMPE A,DIRQ - ASH A,1 - ADDI A,CHNL0+1(TVP) - MOVE B,(A) - PUSH TP,$TATOM - PUSH TP,MQUOTE CHAR,CHAR,INTRUP - PUSH TP,$TUVEC - PUSH TP,BUFRIN(B) - PUSH TP,$TCHAN - PUSH TP,B - PUSHJ P,INSTAT - MCALL 3,INTERRUPT - JRST DIRQ -] - - -MFUNCTION OFF,SUBR - ENTRY - - JUMPGE AB,TFA - HLRZ 0,AB - GETYP A,(AB) ; ARG TYPE - MOVE B,1(AB) ; AND VALUE - CAIN A,TINTH ; HEADER, GO HACK - JRST OFFHD ; QUEEN OF HEARTS - CAIN A,TATOM - JRST .+3 - CAIE A,TCHSTR - JRST TRYHAN ; MAYBE INDIVIDUAL HANDLER - CAIN 0,-2 ; MORE THAN 1 ARG? - JRST OFFAC1 ; NO, GO ON - CAIG 0,-5 ; CANT BE MORE THAN 2 - JRST TMA - MOVEI B,2(AB) ; POINT TO 2D - PUSHJ P,CHNORL -OFFAC1: MOVEI B,(AB) - PUSHJ P,FNDINT - JUMPGE B,NOHAN1 ; NOT HANDLED - -OFFH1: PUSH P,C ; SAVE C FOR BIT CLOBBER - MOVSI C,TATOM - SKIPN D - MOVE D,MQUOTE INTERRUPT - MOVE A,INAME(B) - MOVE B,INAME+1(B) - PUSHJ P,IREMAS - SKIPE B ; IF NO ASSOC, DONT SMASH - SETOM ISTATE+1(B) ; DISABLE IN CASE QUEUED - POP P,C ; SPECIAL? - JUMPGE C,FINIS ; NO, DONE - - HRRZ C,INTBL(C) ; POINT TO SPECIAL CODE - PUSHJ P,(C) ; GO TO SAME - JUMPE E,OFINIS ; DONE -IFN ITS,[ - CAILE E,35. ; SKIP IF 1ST WORD - JRST CLRW2 ; CLOBBER 2D WORD BIT - LSH 0,-1(E) ; POSITION BIT - ANDCAM 0,MASK1 ; KILL BIT - .SUSET [.SMASK,,MASK1] -] -IFE ITS,[ - MOVE D,B - SETZM (E) - MOVEI E,(E) - SUBI E,NETJFN-NETCHN - MOVEI 0,1 - MOVNS E - LSH 0,35.(E) - ANDCAM 0,MASK1 - MOVEI A,MFORK - SETCM B,MASK1 - DIC - ANDCAM 0,PIRQ ; JUST IN CASE - MOVE B,D -] -OFINIS: MOVSI A,TINTH - JRST FINIS - -IFN ITS,[ -CLRW2: LSH 0,-36.(E) ; POS BIT FOR 2D WORD - ANDCAM 0,MASK2 - .SUSET [.SMSK2,,MASK2] - JRST OFINIS -] - -TRYHAN: CAIE A,THAND ; HANDLER? - JRST WTYP1 - CAIE 0,-2 - JRST TMA - GETYP 0,IPREV(B) ; GET TYPE OF PREV - MOVE A,INXT+1(B) - MOVE C,IPREV+1(B) - MOVE D,IPREV(B) - CAIE 0,THAND - JRST DOHEAD ; PREV HUST BE HDR - MOVEM A,INXT+1(C) - JRST .+2 -DOHEAD: MOVEM A,IHNDLR+1(C) ; INTO HDR - JUMPE A,OFFINI - MOVEM D,IPREV(A) - MOVEM C,IPREV+1(A) -OFFINI: SETZM IPREV+1(B) - SETZM INXT+1(B) - MOVSI A,THAND - JRST FINIS - -OFFHD: CAIE 0,-2 - JRST TMA - PUSHJ P,GETNMS ; GET INFOR ABOUT INT - JUMPE C,OFFH1 - PUSH TP,INAME(B) - PUSH TP,INAME+1(B) - JRST OFFH1 - -GETNMS: GETYP A,INAME(B) ; CHECK FOR SPECIAL - SETZB C,D - CAIN A,TCHAN - HRROI C,SS.CHA - PUSHJ P,LOCQ ; LOCATIVE? - JRST CHGTNM - - MOVEI B,INAME(B) ; POINT TO LOCATIVE - MOVSI D,(MOVE E,) - PUSHJ P,SMON ; GET MONITOR - MOVE B,1(AB) -GETNM1: HRROI C,SS.WMO ; ASSUME WRITE - TLNN E,.WRMON - HRROI C,SS.RMO - MOVE D,MQUOTE WRITE,WRITE,INTRUP - TLNN E,.WRMON - MOVE D,MQUOTE READ,READ,INTRUP - POPJ P, - -CHGTNM: JUMPL C,CPOPJ - MOVE B,INAME+1(B) - PUSHJ P,SPEC1 - MOVE B,1(AB) ; RESTORE IHEADER - POPJ P, - -; EMERGENCY, CANT DEFER ME!! - -MQUOTE INTERRUPT - -EMERGENCY: - PUSH P,. - JRST INTERR+1 - -MFUNCTION INTERRUPT,SUBR - - PUSH P,[0] - - ENTRY - - SETZM INTHLD ; RE-ENABLE THE WORLD - JUMPGE AB,TFA - MOVE B,1(AB) ; GET HANDLER/NAME - GETYP A,(AB) ; CAN BE HEADER OR NAME - CAIN A,TINTH ; SKIP IF NOT HEADER - JRST GTHEAD - CAIN A,TATOM - JRST .+3 - CAIE A,TCHSTR ; SKIP IF CHAR STRING - JRST WTYP1 - MOVEI B,(AB) ; LOOK UP NAME - PUSHJ P,FNDNM ; GET NAME - JUMPE B,IFALSE - MOVEI D,0 - CAMN B,MQUOTE CHAR,CHAR,INTRUP - PUSHJ P,CHNGT1 - CAME B,MQUOTE READ,READ,INTRUP - CAMN B,MQUOTE WRITE,WRITE,INTRUP - PUSHJ P,GTLOC1 - PUSHJ P,INTASO - JUMPE B,IFALSE - -GTHEAD: SKIPE ISTATE+1(B) ; ENABLED? - JRST IFALSE ; IGNORE COMPLETELY - MOVE A,INTPRI+1(B) ; GET PRIORITY OF INTERRUPT - CAMLE A,CURPRI ; SEE IF MUST QUEU - JRST SETPRI ; MAY RUN NOW - SKIPE (P) ; SKIP IF DEFER OK - JRST DEFERR - MOVEM A,(P) - PUSH TP,$TINTH ; SAVE HEADER - PUSH TP,B - MOVEI A,1 ; SAVE OTHER ARGS -PSHARG: ADD AB,[2,,2] - JUMPGE AB,QUEU1 ; GO MAKE QUEU ENTRY - PUSH TP,(AB) - PUSH TP,1(AB) - AOJA A,PSHARG -QUEU1: PUSHJ P,IEVECT ; GET VECTOR - PUSH TP,$TVEC - PUSH TP,[0] ; WILL HOLD QUEUE HEADER - PUSH TP,A - PUSH TP,B - - POP P,A ; RESTORE PRIORITY - - MOVE B,QUEUES+1(TVP) ; GET INTERRUPT QUEUES - MOVEI D,0 - JUMPGE B,GQUEU ; MAKE A QUEUE HDR - -NXTQU: CAMN A,1(B) ; GOT PRIORITY? - JRST ADDQU ; YES, ADD TO THE QUEU - CAMG A,1(B) ; SKIP IF SPOT NOT FOUND - JRST GQUEU - MOVE D,B - MOVE B,3(B) ; GO TO NXT QUEUE - JUMPL B,NXTQU - -GQUEU: PUSH TP,$TVEC ; SAVE NEXT POINTER - PUSH TP,D - PUSH TP,$TFIX - PUSH TP,A ; SAVE PRIORITY - PUSH TP,$TVEC - PUSH TP,B - PUSH TP,$TLIST - PUSH TP,[0] - PUSH TP,$TLIST - PUSH TP,[0] - MOVEI A,4 - PUSHJ P,IEVECT - MOVE D,(TP) ; NOW SPLICE - SUB TP,[2,,2] - JUMPN D,GQUEU1 - MOVEM B,QUEUES+1(TVP) - JRST .+2 -GQUEU1: MOVEM B,3(D) - -ADDQU: MOVEM B,-2(TP) ; SAVE QUEU HDR - POP TP,D - POP TP,C - PUSHJ P,INCONS ; CONS IT - MOVE C,(TP) ;GET QUEUE HEADER - SKIPE D,7(C) ; IF END EXISTS - HRRM B,(D) ; SPLICE - MOVEM B,7(C) - SKIPN 5(C) ; SKIP IF START EXISTS - MOVEM B,5(C) - -IFINI: MOVSI A,TATOM - MOVE B,MQUOTE T - JRST FINIS - -SETPRI: EXCH A,CURPRI - MOVEM A,(P) - - PUSH TP,$TAB ; PASS AB TO HANDLERS - PUSH TP,AB - - PUSHJ P,RUNINT ; RUN THE HANDLERS - POP P,A ; UNQUEU ANY WAITERS - PUSHJ P,UNQUEU - - JRST IFINI - -; HERE TO UNQUEUE WAITING INTERRUPTS - -UNQUEU: PUSH P,A ; SAVE NEW LEVEL - -UNQUE1: MOVE A,(P) ; TARGET LEVEL - CAMLE A,CURPRI ; CHECK RUG NOT PULLED OUT - JRST UNDONE - SKIPE B,QUEUES+1(TVP) - CAML A,1(B) ; RIGHT LEVEL? - JRST UNDONE ; FINISHED - - SKIPN C,5(B) ; ON QUEUEU? - JRST UNXQ - HRRZ D,(C) ; CDR THE LIST - MOVEM D,5(B) - SKIPN D ; SKIP IF NOT LAST - SETZM 7(B) ; CLOBBER END POINTER - MOVE A,1(B) ; GET THIS PRIORITY LEVEL - MOVEM A,CURPRI ; MAKE IT THE CURRENT ONE - MOVE D,1(C) ; GET SAVED VECTOR OF INF - - MOVE B,1(D) ; INT HEADER - PUSH TP,$TVEC - PUSH TP,D ; AND ARGS - - PUSHJ P,RUNINT ; RUN THEM - JRST UNQUE1 - -UNDONE: POP P,CURPRI ; SET CURRENT LEVEL - MOVE A,CURPRI - POPJ P, - -UNXQ: MOVE B,3(B) ; GO TO NEXT QUEUE - MOVEM B,QUEUES+1(TVP) - JRST UNQUE1 - - - -; SUBR TO CHANGE INTERRUPT LEVEL - -MFUNCTION INTLEV,SUBR,[INT-LEVEL] - ENTRY - JUMPGE AB,RETLEV ; JUST RETURN CURRENT - GETYP A,(AB) - CAIE A,TFIX - JRST WTYP1 ; LEVEL IS FIXED - SKIPGE A,1(AB) - JRST OUTRNG" - CAMN A,CURPRI ; DIFFERENT? - JRST RETLEV ; NO RETURN - PUSH P,CURPRI - CAMG A,CURPRI ; SKIP IF NO UNQUEUE NEEDED - PUSHJ P,UNQUEU - MOVEM A,CURPRI ; SAVE - POP P,A - SKIPA B,A -RETLEV: MOVE B,CURPRI - MOVSI A,TFIX - JRST FINIS - -RUNINT: PUSH TP,$THAND ; SAVE HANDLERS LIST - PUSH TP,IHNDLR+1(B) - - SKIPN ISTATE+1(B) ; SKIP IF DISABLED - SKIPN B,(TP) - JRST SUBTP4 -NXHND: MOVEM B,(TP) ; SAVE CURRENT HDR - MOVE A,-2(TP) ; SAVE ARG POINTER - PUSHJ P,CHSWAP ; SEE IF MUST SWAP - PUSH TP,[0] - PUSH TP,[0] - MOVEI C,1 ; COUNT ARGS - PUSH TP,$TSP - PUSH TP,SP - MOVE D,PVP - ADD D,[1STEPR,,1STEPR] - PUSH TP,BNDV - PUSH TP,D - PUSH TP,$TPVP - PUSH TP,[0] - MOVE E,TP - PUSH TP,INTFCN(B) - PUSH TP,INTFCN+1(B) - ADD A,[2,,2] - JUMPGE A,DO.HND - PUSH TP,(A) - PUSH TP,1(A) - AOJA C,.-4 -DO.HND: PUSH P,C - PUSHJ P,SPECBE ; BIND 1 STEP FLAG - POP P,C - ACALL C,INTAPL - MOVE SP,-4(TP) - MOVE C,(TP) ; RESET 1 STEP - MOVEM C,1STEPR+1(PVP) - SUB TP,[6,,6] - PUSHJ P,CHUNSW - CAMN E,PVP - SUB TP,[4,,4] ; NO PROCESS CHANGE, POP JUNK - CAMN E,PVP - JRST .+4 - MOVE D,TPSTO+1(E) - SUB D,[4,,4] - MOVEM D,TPSTO+1(E) ; FIXUP HIS STACK -DO.H1: GETYP A,A ; CHECK FOR A DISMISS - CAIN A,TDISMI - JRST SUBTP4 - MOVE B,(TP) ; TRY FOR NEXT HANDLER - SKIPE B,INXT+1(B) - JRST NXHND -SUBTP4: SUB TP,[4,,4] - POPJ P, - -MFUNCTION INTAPL,SUBR,[RUNINT] - JRST APPLY - - -NOHAND: JUMPE C,NOHAN1 - PUSH TP,$TATOM - PUSH TP,EQUOTE INTERNAL-INTERRUPT -NOHAN1: PUSH TP,(AB) - PUSH TP,1(AB) - PUSH TP,$TATOM - PUSH TP,EQUOTE NOT-HANDLED - SKIPE A,C - MOVEI A,1 - ADDI A,2 - JRST CALER - -DEFERR: PUSH TP,$TATOM - PUSH TP,EQUOTE ATTEMPT-TO-DEFER-UNDEFERABLE-INTERRUPT - PUSH TP,$TINTH - PUSH TP,B - PUSH TP,$TATOM - PUSH TP,MQUOTE INTERRUPT - MCALL 3,RERR ; FORCE REAL ERROR - JRST FINIS - -; FUNCTION TO DISMISS AN INTERRUPT TO AN ARBITRARY ACTIVATION - -MFUNCTION DISMISS,SUBR - - HLRZ 0,AB - JUMPGE AB,TFA - CAIGE 0,-6 - JRST TMA - MOVNI D,1 - CAIE 0,-6 - JRST DISMI3 - GETYP 0,4(AB) - CAIE 0,TFIX - JRST WTYP - SKIPGE D,5(AB) - JRST OUTRNG - -DISMI3: MOVEI A,(TB) - -DISMI0: HRRZ B,FSAV(A) - HRRZ C,PCSAV(A) - CAIE B,INTAPL - JRST DISMI1 - - MOVE E,OTBSAV(A) - MOVEI 0,(A) ; SAVE FRAME - MOVEI A,DISMI2 - HRRM A,PCSAV(E) ; GET IT BACK HERE - MOVE A,(AB) - MOVE B,1(AB) - MOVE C,TPSAV(E) - MOVEM A,-7(C) - MOVEM B,-6(C) - MOVEI C,0 - CAMGE AB,[-3,,] - MOVEI C,2(AB) - MOVE B,0 ; DEST FRAME - JUMPL D,.+3 - MOVE A,PSAV(E) ; NOW MUNG SAVED INT LEVEL - MOVEM D,-1(A) ; ZAP YOUR MUNGED - PUSHJ P,CHUNW ; CHECK ON UNWINDERS - JRST FINIS ; FALL DOWN - -DISMI1: MOVEI E,(A) - HRRZ A,OTBSAV(A) - JUMPN A,DISMI0 - - MOVE A,(AB) - MOVE B,1(AB) - - PUSH TP,A - PUSH TP,B - SKIPGE A,D - JRST .+4 - CAMG A,CURPRI - PUSHJ P,UNQUEU - MOVEM A,CURPRI - CAML AB,[-3,,] - JRST .+5 - PUSH TP,2(AB) - PUSH TP,3(AB) - MCALL 2,ERRET - JRST FINIS - - POP TP,B - POP TP,A - JRST FINIS - -DISMI2: MOVE C,(TP) - MOVEM C,1STEPR+1(PVP) - MOVE SP,-4(TP) - SUB TP,[6,,6] - PUSHJ P,CHUNSW ; UNDO ANY PROCESS HACKING - MOVE C,TP - CAME E,PVP ; SWAPED? - MOVE C,TPSTO+1(E) - MOVE D,-1(C) - MOVE 0,(C) - SUB TP,[4,,4] - SUB C,[4,,4] ; MAYBE FIXUP OTHER STACK - CAME E,PVP - MOVEM C,TPSTO+1(E) - PUSH TP,D - PUSH TP,0 - PUSH TP,A - PUSH TP,B - MOVE A,-1(P) ; SAVED PRIORITY - CAMG A,CURPRI - PUSHJ P,UNQUEU - MOVEM A,CURPRI - SKIPN -1(TP) - JRST .+3 - MCALL 2,ERRET - JRST FINIS - - SUB TP,[4,,4] - MOVSI A,TDISMI - MOVE B,MQUOTE T - JRST DO.H1 - -CHNGT1: HLRE B,AB - SUBM AB,B - GETYP 0,-2(B) - CAIE 0,TCHAN - JRST WTYP3 - MOVE B,-1(B) - MOVSI A,TCHAN - POPJ P, - -GTLOC1: GETYP A,2(AB) - PUSHJ P,LOCQ - JRST WTYP2 - MOVE D,B ; RET ATOM FOR ASSOC - MOVE A,2(AB) - MOVE B,3(AB) - POPJ P, - ; MONITOR CHECKERS - -MONCH0: HLLZ 0,(B) ; POTENTIAL MONITORS -MONCH: TLZ 0,TYPMSK ; KILL TYPE - IOR C,0 ; IN NEW TYPE - PUSH P,0 - MOVEI 0,(B) - CAIL 0,HIBOT - JRST PURERR - POP P,0 - TLNN 0,.WRMON ; SKIP IF WRITE MONIT - POPJ P, - -; MONITOR IS ON, INVOKE HANDLER - - PUSH TP,A ; SAVE OBJ - PUSH TP,B - PUSH TP,C - PUSH TP,D ; SAVE DATUM - MOVSI C,TATOM ; PREPARE TO FIND IT - MOVE D,MQUOTE WRITE,WRITE,INTRUP - PUSHJ P,IGET - JUMPE B,MONCH1 ; NOT FOUND IGNORE FOR NOW - PUSH TP,A ; START SETTING UP CALL - PUSH TP,B - PUSH TP,-5(TP) - PUSH TP,-5(TP) - PUSH TP,-5(TP) - PUSH TP,-5(TP) - PUSHJ P,FRMSTK ; PUT FRAME ON STAKC - MCALL 4,EMERGE ; DO IT -MONCH1: POP TP,D - POP TP,C - POP TP,B - POP TP,A - HLLZ 0,(B) ; UPDATE MONITORS - TLZ 0,TYPMSK - IOR C,0 - POPJ P, - -; NOW FOR READ MONITORS - -RMONC0: HLLZ 0,(B) -RMONCH: TLNN 0,.RDMON - POPJ P, - PUSH TP,A - PUSH TP,B - MOVSI C,TATOM - MOVE D,MQUOTE READ,READ,INTRUP - PUSHJ P,IGET - JUMPE B,RMONC1 - PUSH TP,A - PUSH TP,B - PUSH TP,-3(TP) - PUSH TP,-3(TP) - PUSHJ P,FRMSTK ; PUT FRAME ON STACK - MCALL 3,EMERGE -RMONC1: POP TP,B - POP TP,A - POPJ P, - -; PUT THE CURRENT FRAME ON THE STACK - -FRMSTK: PUSHJ P,MAKACT - HRLI A,TFRAME - PUSH TP,A - PUSH TP,B - POPJ P, - -; HERE TO COMPLAIN ABOUT ATTEMPTS TO MUNG PURE CODE - -PURERR: PUSH TP,$TATOM - PUSH TP,EQUOTE ATTEMPT-TO-MUNG-PURE-STRUCTURE - PUSH TP,A - PUSH TP,B - MOVEI A,2 - JRST CALER - -; PROCESS SWAPPING CODE - -CHSWAP: MOVE E,PVP ; GET CURRENT - POP P,0 - SKIPE D,INTPRO+1(B) ; SKIP IF NO PROCESS GIVEN - CAMN D,PVP ; SKIP IF DIFFERENT - JRST PSHPRO - - PUSHJ P,SWAPIT ; DO SWAP - -PSHPRO: PUSH TP,$TPVP - PUSH TP,E - JRST @0 - -CHUNSW: MOVE E,PVP ; RET OLD PROC - MOVE D,-2(TP) ; GET SAVED PROC - CAMN D,PVP ; SWAPPED? - POPJ P, - -SWAPIT: PUSH P,0 - MOVE 0,PSTAT+1(D) ; CHECK STATE - CAIE 0,RESMBL - JRST NOTRES - MOVEM 0,PSTAT+1(PVP) - MOVEI 0,RUNING - MOVEM 0,PSTAT+1(D) ; SAVE NEW STATE - POP P,0 - POP P,C - JRST SWAP" - - -;SUBROUTINE TO GET BIT FOR CLOBBERAGE - -GETBIT: MOVNS B ;NEGATE - MOVSI A,400000 ;GET THE BIT - LSH A,(B) ;SHIFT TO POSITION - POPJ P, ;AND RETURN - -;HERE TO HANDLE PDL OVERFLOW. ASK FOR A GC - -IPDLOV: -IFN ITS,[ - MOVEM A,TSINT ;SAVE INT WORD -] - - SKIPE GCFLG ;IS GC RUNNING? - JRST GCPLOV ;YES, COMPLAIN GROSSLY - - MOVEI A,200000 ;GET BIT TO CLOBBER - IORM A,PIRQ ;LEAVE A MESSAGE FOR HIGHER LEVEL - - EXCH P,GCPDL ;GET A WINNING PDL - HRRZ B,TSINTR ;GET POINTER TO LOSING INSTRUCTION - SKIPG GCPDL ; SKIP IF NOT P - LDB B,[270400,,-1(B)] ;GET AC FIELD - SKIPL GCPDL ; SKIP IF P - MOVEI B,P - MOVEI A,(B) ;COPY IT - LSH A,1 ;TIMES 2 - ADDI A,0STO(PVP) ;POINT TO THIS ACS CURRENT TYPE - HLRZ A,(A) ;GET THAT TYPE INTO A - CAIN B,P ;IS IT P - MOVEI B,GCPDL ;POINT TO SAVED P - - CAIN B,B ;OR IS IT B ITSELF - MOVEI B,TSAVB - CAIN B,A ;OR A - MOVEI B,TSAVA - - CAIN B,C ;OR C - MOVEI B,1(P) ;C WILL BE ON THE STACK - - PUSH P,C - PUSH P,A - - MOVE A,(B) ;GET THE LOSING POINTER - MOVEI C,(A) ;AND ISOLATE RH - - CAMG C,VECTOP ;CHECK IF IN GC SPACE - CAMG C,VECBOT - JRST NOGROW ;NO, COMPLAIN - -; FALL THROUGH - - - HLRZ C,A ;GET -LENGTH - SUBI A,-1(C) ;POINT TO A DOPE WORD - POP P,C ;RESTORE TYPE INTO C - PUSH P,D ; SAVE FOR GROWTH HACKER - MOVEI D,0 - CAIN C,TPDL ; POIN TD TO APPROPRIATE DOPE WORD - MOVEI D,PGROW - CAIN C,TTP - MOVEI D,TPGROW - JUMPE D,BADPDL ; IF D STILL 0, THIS PDL IS WEIRD - MOVEI A,PDLBUF(A) ; POINT TO ALLEGED REAL DOPE WORD - SKIPN (D) ; SKIP IF PREVIOUSLY BLOWN - MOVEM A,(D) ; CLOBBER IN - CAME A,(D) ; MAKE SURE IT IS THE SAME - JRST PDLOSS - POP P,D ; RESTORE D - - -PNTRHK: MOVE C,(B) ;RESTORE PDL POINTER - SUB C,[PDLBUF,,0] ;FUDGE THE POINTER - MOVEM C,(B) ;AND STORE IT - - POP P,C ;RESTORE THE WORLD - EXCH P,GCPDL ;GET BACK ORIG PDL -IFN ITS,[ - MOVE A,TSINT ;RESTORE INT WORD - - JRST IMPCH ;LOOK FOR MORE INTERRUPTS -] -IFE ITS, JRST GCQUIT - -TPOVFL: SETOM INTFLG ;SIMULATE PDL OVFL - PUSH P,A - MOVEI A,200000 ;TURN ON THE BIT - IORM A,PIRQ - SUB TP,[PDLBUF,,0] ;HACK STACK POINTER - HLRE A,TP ;FIND DOPEW - SUBM TP,A ;POINT TO DOPE WORD - MOVEI A,1(A) ; ZERO LH AND POINT TO DOPEWD - SKIPN TPGROW - HRRZM A,TPGROW - CAME A,TPGROW ; MAKE SURE WINNAGE - JRST PDLOSS - POP P,A - POPJ P, - - -; GROW CORE IF PDL OVERFLOW DURING GC - -GCPLOV: MOVE A,P.TOP ; GET TOP OF IMPURE - ASH A,-10. ; TO BLOCKS - EXCH P,GCPDL ; NEED A PDL TO CALL P.CORE - ADDI A,1 ; GO TO NEXT BLOCK -GRECOR: PUSHJ P,P.CORE ; GET CORE - JRST SLPCOR ; HANG GETTING THE CORE - EXCH P,GCPDL ; BPDLS BACK - ADD P,[-2000,,0] -IFE ITS, JRST GCQUIT -IFN ITS,[ - MOVE A,TSINT - JRST IMPCH - - -SLPCOR: MOVEI B,1 - .SLEEP B, - JRST GRECOR - -] - -IFN ITS,[ - -;HERE TO HANDLE LOW-LEVEL CHANNELS - - -CHNACT: SKIPN GCFLG ;GET A WINNING PDL - EXCH P,GCPDL - ANDI A,177777 ;ISOLATE CHANNEL BITS - PUSH P,0 ;SAVE - -CHNA1: MOVEI B,0 ;BIT COUNTER - JFFO A,.+2 ;COUNT - JRST CHNA2 - SUBI B,35. ;NOW HAVE CHANNEL - MOVMS B ;PLUS IT - MOVEI 0,1 - LSH 0,(B) - ANDCM A,0 - MOVEI 0,(B) ; COPY TO 0 - LSH 0,23. ;POSITION FOR A .STATUS - IOR 0,[.STATUS 0] - XCT 0 ;DO IT - ANDI 0,77 ;ISOLATE DEVICE - CAILE 0,2 - JRST CHNA1 - -PMIN4: MOVE 0,B ; CHAN TO 0 - .ITYIC 0, ; INTO 0 - JRST .+2 ; DONE, GO ON - JRST PMIN4 - SETZM GCFLCH ; LEAVE GC MODE - JRST CHNA1 - -CHNA2: POP P,0 - SKIPN GCFLG - EXCH P,GCPDL - JRST GCQUIT - -HOWMNY: SETZ - SIXBIT /LISTEN/ - D - 402000,,B -] - -MFUNCTION GASCII,SUBR,ASCII - ENTRY 1 - - GETYP A,(AB) - CAIE A,TCHRS - JRST TRYNUM - - MOVE B,1(AB) - MOVSI A,TFIX - JRST FINIS - -TRYNUM: CAIE A,TFIX - JRST WTYP1 - SKIPGE B,1(AB) ;GET NUMBER - JRST TOOBIG - CAILE B,177 ;CHECK RANGE - JRST TOOBIG - MOVSI A,TCHRS - JRST FINIS - -TOOBIG: PUSH TP,$TATOM - PUSH TP,EQUOTE ARGUMENT-OUT-OF-RANGE - JRST CALER1 - - -;HERE IF PDL OVERFLOW DURING GARBAGE COLLECTION - -BADPDL: FATAL NON PDL OVERFLOW - -NOGROW: FATAL PDL OVERFLOW ON NON EXPANDABLE PDL - -PDLOSS: FATAL PDL OVEFLOW BUFFER EXHAUSTED - -DLOSER: PUSH P,LOSRS(B) - MOVE A,TSAVA - MOVE B,TSAVB - POPJ P, - -LOSRS: IMPV - ILOPR - IOC - IPURE - - -;MEMORY PROTECTION INTERRUPT - -IOC: FATAL IO CHANNEL ERROR IN GARBAGE COLLECTOR -IMPV: FATAL MPV IN GARBAGE COLLECTOR - -IPURE: FATAL PURE WRITE IN GARBAGE COLLECTOR -ILOPR: FATAL ILLEGAL OPEREATION IN GARBAGE COLLECTOR - -IFN ITS,[ - -;SUBROUTINE TO BE CALLED AT INITIALIZE TIME TO SETUP INTS - -INTINT: SETZM CHNCNT - MOVE A,[CHNCNT,,CHNCNT+1] - BLT A,CHNCNT+16. - SETZM INTFLG - .SUSET [.SPICLR,,[-1]] - MOVE A,MASK1 ;SET MASKS - MOVE B,MASK2 - .SETM2 A, ;SET BOTH MASKS - MOVSI A,TVEC - MOVEM A,QUEUES(TVP) - SETZM QUEUES+1(TVP) ;UNQUEUE ANY OLD INTERRUPTS - SETZM CURPRI - POPJ P, -] -IFE ITS,[ - -; INITIALIZE TENEX INTERRUPT SYSTEM - -INTINT: CIS ; CLEAR THE INT WORLD - SETZM INTFLG ; IN CASE RESTART - MOVSI A,TVEC ; FIXUP QUEUES - MOVEM A,QUEUES(TVP) - SETZM QUEUES+1(TVP) - SETZM CURPRI ; AND PRIORITY LEVEL - MOVEI A,MFORK ; TURN ON MY INTERRUPTS - MOVE B,[LEVTAB,,CHNTAB] ; POINT TO TABLES - SIR ; TELL SYSTEM ABOUT THEM - MOVE B,MASK1 ; SET UP FOR INT BITS - AIC ; TURN THEM ON - MOVSI A,7 ; CNTL G AND CHANNEL 0 - ATI ; ACTIVATE IT - MOVE A,[23,,1] ; CNTL S AND CHANNEL 1 - ATI ; ACTIVATE IT - MOVEI A,MFORK ; DO THE ENABLE - EIR - POPJ P, -] - - -; CNTL-G HANDLER - -MFUNCTION QUITTER,SUBR - - ENTRY 2 - GETYP A,(AB) - CAIE A,TCHRS - JRST WTYP1 - GETYP A,2(AB) - CAIE A,TCHAN - JRST WTYP2 - MOVE B,1(AB) - MOVE A,(AB) - CAIN B,^S ; HANDLE CNTL-S - JRST RETLIS - CAIE B,7 - JRST FINIS - - PUSHJ P,CLEAN ; CLEAN UP I/O CHANNELS - PUSH TP,$TATOM - PUSH TP,EQUOTE CONTROL-G? - MCALL 1,ERROR - JRST FINIS - -RETLIS: MOVEI D,(TB) ; FIND A LISTEN OR ERROR TO RET TO - -RETLI1: HRRZ A,OTBSAV(D) - HRRZ C,FSAV(A) ; CHECK FUNCTION - CAIE C,LISTEN - CAIN C,ERROR ; FOUND? - JRST FNDHIM ; YES, GO TO SAME - CAIN C,ERROR% ; FUNNY ERROR - JRST FNDHIM - CAIN C,TOPLEV ; NO ERROR/LISTEN - JRST FINIS - MOVEI D,(A) - JRST RETLI1 - -FNDHIM: PUSH TP,$TTB - PUSH TP,D - PUSHJ P,CLEAN - MOVE B,(TP) ; NEW FRAME - SUB TP,[2,,2] - MOVEI C,0 - PUSHJ P,CHUNW ; UNWIND? - MOVSI A,TATOM - MOVE B,MQUOTE T - JRST FINIS - -CLEAN: MOVE B,3(AB) ; GET IN CHAN - PUSHJ P,RRESET - MOVE B,3(AB) ; CHANNEL BAKC - MOVE C,BUFRIN(B) - SKIPN C,ECHO(C) ; GET ECHO - JRST CLUNQ -IFN ITS,[ - MOVEI A,2 - CAMN C,[PUSHJ P,MTYO] - JRST TYONUM - LDB A,[270400,,C] -TYONUM: LSH A,23. - IOR A,[.RESET] - XCT A -] -IFE ITS,[ - MOVEI A,101 ; OUTPUT JFN - CFOBF -] - -CLUNQ: SETZB A,CURPRI - JRST UNQUEU - - -IMPURE -ONINT: 0 ; INT FUDGER -IFN ITS,[ -;RANDOM IMPURE CRUFT NEEDED -CHNCNT: BLOCK 16. ; # OF CHARS IN EACH CHANNEL - -TSAVA: 0 -TSAVB: 0 -PIRQ: 0 ;HOLDS REQUEST BITS FOR 1ST WORD -PIRQ2: 0 ;SAME FOR WORD 2 -PCOFF: 0 -MASK1: 1200,,220540 ;FIRST MASK -MASK2: 0 ;SECOND THEREOF -CURPRI: 0 ; CURRENT PRIORITY -] -IFE ITS,[ -NETJFN: BLOCK NNETS -MASK1: CHNMSK -TSINTR: -P1: 0 ; PC INT LEVEL 1 -P2: 0 ; PC INT LEVEL 2 -P3: 0 ; PC INT LEVEL 3 -CURPRI: 0 -TSAVA: 0 -TSAVB: 0 -PIRQ: 0 -PIRQ2: 0 -] -PURE - -END - TITLE MAIN LOOP AND GLOBALLY REFERENCED SUBROUTINES - -RELOCA - -.GLOBAL PATCH,TBINIT,PIDSTO,PROCID,PTIME,GCPDL,PBASE,TYPTOP,RERR,FRMSTK,EMERGE -.GLOBAL PAT,PDLBUF,INTINT,START,SWAP,ICR,SPBASE,TPBASE,TPBAS,SAT,CURPRI,CHFINI -.GLOBAL TOPLEVEL,INTOBL,INITIA,ERROBL,MAINPR,RESFUN,STATUS,TYPVEC,ROOT,TTICHN,TTOCHN -.GLOBAL TTYOPE,MOPEN,MCLOSE,MIOT,ILVAL,MESS,ERROR,CHFRM,IGVAL,TYPBOT,ASOVEC -.GLOBAL PRINT,PRIN1,PRINC,MUDSTR,VECBOT,CSTACK,IFALSE,TYPLOO,RCALL,SWAPIN,CTMPLT -.GLOBAL IDPROC,CHFSWP,ILOC,MAKACT,BNDV,SPECSTORE,BINDID,IGLOC,MTYO,MSGTYP,CAFRE1 -.GLOBAL EVATYP,EVTYPE,APLTYP,APTYPE,PRNTYP,PRTYPE,AGC,SGSNAM,NAPT,APLQ,STRTO6 -.GLOBAL 6TOCHS,TYPFND,STBL,CHNL0,N.CHNS,CLOSAL,%LOGOUT,%SSNAM,%RSNAM,%KILLM -.GLOBAL MAKINF,%VALRET,COMPERR,IPUT,IGET,TMATCH,INITIZ,IPCINI,%UNAM,%JNAM,%RUNAM,%RJNAM -.GLOBAL NOTTY,PATEND,CFRAME,CARGS,CFUNCT,CITYPE,CTYPEQ,CPTYPE,CTYPEP,CUTYPE,CCHUTY -.GLOBAL RTFALS,PGINT,PURCLN,CTYPEC,CTYPEW,IDVAL1,CALLTY,MESSAG,INITFL,WHOAMI -.GLOBAL %SLEEP,%HANG,%TOPLQ,ONINT,CHUNW,CURFCN,BUFRIN,TD.LNT,TD.GET,TD.PUT,MPOPJ -.GLOBAL PURVEC,PLOAD,SSPECS,OUTRNG -.GLOBAL TYPIC -.INSRT MUDDLE > - -MONITS==1 ; SET TO 1 IF PC DEMON WANTED -.VECT.==1 ; BIT TO INDICATE VECTORS FOR GCHACK - -;MAIN LOOP AND STARTUP - -START: MOVEI 0,0 ; SET NO HACKS - MOVEM 0,WHOAMI ; HACK FOR TS FOO linked to TS MUDDLE - MOVE PVP,MAINPR ; MAKE SURE WE START IN THE MAIN PROCESS - JUMPE 0,INITIZ ; MIGHT BE RESTART - MOVE P,PSTO+1(PVP) ; SET UP FOR BOOTSTRAP HACK - MOVE TP,TPSTO+1(PVP) -INITIZ: SKIPN P ; IF NO CURRENT P - MOVE P,PSTO+1(PVP) ; PDL TO GET OFF THE GROUND - SKIPN TP ; SAME FOR TP - MOVE TP,TPSTO+1(PVP) ; GET A TP TO WORK WITH - MOVE TVP,TVPSTO+1(PVP) ; GET A TVP - SETZB R,M ; RESET RSUBR AC'S - PUSHJ P,%RUNAM - PUSHJ P,%RJNAM - PUSHJ P,TTYOPE ;OPEN THE TTY - MOVEI B,MUDSTR - SKIPE WHOAMI ; SKIP IF THIS IS MUDDLE - JRST .+3 ; ELSE NO MESSAGE - SKIPN NOTTY ; IF NO TTY, IGNORE - PUSHJ P,MSGTYP ;TYPE OUT TO USER - - XCT MESSAG ;MAYBE PRINT A MESSAGE - PUSHJ P,INTINT ;INITIALIZE INTERRUPT HANDLER - XCT IPCINI - PUSHJ P,PURCLN ; CLEAN UP PURE SHARED AREA -RESTART: ;RESTART A PROCESS -STP: MOVEI C,0 - MOVE B,TBINIT+1(PVP) ;POINT INTO STACK AT START - PUSHJ P,CHUNW ; LEAVE WHILE DOING UNWIND CHECK - MOVEI E,TOPLEV - MOVEI A,TFALSE ; IN CASE FALLS OFF PROCESS - MOVEI B,0 - MOVEM E,-1(TB) - JRST CONTIN - - MQUOTE TOPLEVEL -TOPLEVEL: - MCALL 0,LISTEN - JRST TOPLEVEL - - -MFUNCTION LISTEN,SUBR - - ENTRY - PUSH P,[0] ;FLAG: DON'T PRINT ERROR MSG - JRST ER1 - -; USER SUPPLIED ERROR HANDLER, TEMPORARY KLUDGE - IMQUOTE ERROR - -ERROR: MOVE B,IMQUOTE ERROR - PUSHJ P,IGVAL ; GET VALUE - GETYP C,A - CAIN C,TSUBR ; CHECK FOR NO CHANGE - CAIE B,RERR1 ; SKIP IF NOT CHANGED - JRST .+2 - JRST RERR1 ; GO TO THE DEFAULT - PUSH TP,A ; SAVE VALUE - PUSH TP,B - MOVE C,AB ; SAVE AB - MOVEI D,1 ; AND COUNTER -USER1: PUSH TP,(C) ; PUSH THEM - PUSH TP,1(C) - ADD C,[2,,2] ; BUMP - ADDI D,1 - JUMPL C,USER1 - ACALL D,APPLY ; EVAL USERS ERROR - JRST FINIS - - -TPSUBR==TSUBR+400000 - -MFUNCTION ERROR%,PSUBR,ERROR - -RMT [EXPUNGE TPSUBR -] -RERR1: ENTRY - PUSH TP,$TATOM - PUSH TP,MQUOTE ERROR,ERROR,INTRUP - PUSHJ P,FRMSTK ; PUT ERROR'S FRAME ON STACK - MOVEI D,2 - MOVE C,AB -RERR2: JUMPGE C,RERR22 - PUSH TP,(C) - PUSH TP,1(C) - ADD C,[2,,2] - AOJA D,RERR2 -RERR22: ACALL D,EMERGENCY - JRST RERR - -IMQUOTE ERROR -RERR: ENTRY - PUSH P,[-1] ;PRINT ERROR FLAG - -ER1: MOVE B,IMQUOTE INCHAN - PUSHJ P,ILVAL ; CHECK INPUT CHANNEL IS SOME KIND OF TTY - GETYP A,A - CAIE A,TCHAN ; SKIP IF IT IS A CHANNEL - JRST ER2 ; NO, MUST REBIND - CAMN B,TTICHN+1(TVP) - JRST NOTINC -ER2: MOVE B,IMQUOTE INCHAN - MOVEI C,TTICHN(TVP) ; POINT TO VALU - PUSHJ P,PUSH6 ; PUSH THE BINDING - MOVE B,TTICHN+1(TVP) ; GET IN CHAN -NOTINC: SKIPE NOTTY - JRST NOECHO - PUSH TP,$TCHAN - PUSH TP,B - PUSH TP,$TATOM - PUSH TP,MQUOTE T - MCALL 2,TTYECH ; ECHO INPUT -NOECHO: MOVE B,IMQUOTE OUTCHAN - PUSHJ P,ILVAL ; GET THE VALUE - GETYP A,A - CAIE A,TCHAN ; SKIP IF OK CHANNEL - JRST ER3 ; NOT CHANNEL, MUST REBIND - CAMN B,TTOCHN+1(TVP) - JRST NOTOUT -ER3: MOVE B,IMQUOTE OUTCHAN - MOVEI C,TTOCHN(TVP) - PUSHJ P,PUSH6 ; PUSH THE BINDINGS -NOTOUT: MOVE B,IMQUOTE OBLIST - PUSHJ P,ILVAL ; GET THE VALUE OF OBLIST - PUSHJ P,OBCHK ; IS IT A WINNER ? - SKIPA A,$TATOM ; NO, SKIP AND CONTINUE - JRST NOTOBL ; YES, DO NOT DO REBINDING - MOVE B,IMQUOTE OBLIST - PUSHJ P,IGLOC - GETYP 0,A - CAIN 0,TUNBOU - JRST MAKOB ; NO GLOBAL OBLIST, MAKE ONE - MOVEI C,(B) ; COPY ADDRESS - MOVE A,(C) ; GET THE GVAL - MOVE B,(C)+1 - PUSHJ P,OBCHK ; IS IT A WINNER ? - JRST MAKOB ; NO, GO MAKE A NEW ONE - MOVE B,IMQUOTE OBLIST - PUSHJ P,PUSH6 - -NOTOBL: PUSH TP,[TATOM,,-1] ;FOR BINDING - PUSH TP,IMQUOTE LER,[LERR ]INTRUP - PUSHJ P,MAKACT - HRLI A,TFRAME ; CORRCT TYPE - PUSH TP,A - PUSH TP,B - PUSH TP,[0] - PUSH TP,[0] - MOVE A,PVP ; GET PROCESS - ADD A,[PROCID,,PROCID] ; POINT TO ID (ALSO LEVEL) - PUSH TP,BNDV - PUSH TP,A - MOVE A,PROCID(PVP) - ADDI A,1 ; BUMP ERROR LEVEL - PUSH TP,A - PUSH TP,PROCID+1(PVP) - PUSH P,A - - MOVE B,IMQUOTE READ-TABLE - PUSHJ P,IGVAL - PUSH TP,[TATOM,,-1] - PUSH TP,IMQUOTE READ-TABLE - GETYP C,A ; TO GVAL OF READ-TABLE ON ERROR AND - CAIE C,TVEC ; TOP ERRET'S - JRST .+4 - PUSH TP,A - PUSH TP,B - JRST .+3 - PUSH TP,$TUNBOUND - PUSH TP,[-1] - PUSH TP,[0] - PUSH TP,[0] - - PUSHJ P,SPECBIND ;BIND THE CRETANS - MOVE A,-1(P) ;RESTORE SWITHC - JUMPE A,NOERR ;IF 0, DONT PRINT ERROR MESS - PUSH TP,$TATOM - PUSH TP,EQUOTE *ERROR* - MCALL 0,TERPRI - MCALL 1,PRINC ;PRINT THE MESSAGE -NOERR: MOVE C,AB ;GET A COPY OF AB - -ERRLP: JUMPGE C,LEVPRT ;IF NONE, RE-ENTER READ-EVAL-PRINT LOOP - PUSH TP,$TAB - PUSH TP,C - MOVEI B,PRIN1 - GETYP A,(C) ; GET ARGS TYPE - CAIE A,TATOM - JRST ERROK - MOVE A,1(C) ; GET ATOM - MOVE A,2(A) - CAIE A,ERROBL+1 - CAMN A,ERROBL+1(TVP) ; DONT SKIP IF IN ERROR OBLIST - MOVEI B,PRINC ; DONT PRINT TRAILER -ERROK: PUSH P,B ; SAVE ROUTINE POINTER - PUSH TP,(C) - PUSH TP,1(C) - MCALL 0,TERPRI ; CRLF - POP P,B ; GET ROUTINE BACK - .MCALL 1,(B) - POP TP,C - SUB TP,[1,,1] - ADD C,[2,,2] ;BUMP SAVED AB - JRST ERRLP ;AND CONTINUE - - -LEVPRT: XCT INITFL ;LOAD MUDDLE INIT FILE IF FIRST TIME - MCALL 0,TERPRI - PUSH TP,$TATOM - PUSH TP,EQUOTE [LISTENING-AT-LEVEL ] - MCALL 1,PRINC ;PRINT LEVEL - PUSH TP,$TFIX ;READY TO PRINT LEVEL - HRRZ A,(P) ;GET LEVEL - SUB P,[2,,2] ;AND POP STACK - PUSH TP,A - MCALL 1,PRIN1 ;PRINT WITHOUT SPACES ETC. - PUSH TP,$TATOM ;NOW PROCESS - PUSH TP,EQUOTE [ PROCESS ] - MCALL 1,PRINC ;DONT SLASHIFY SPACES - PUSH TP,PROCID(PVP) ;NOW ID - PUSH TP,PROCID+1(PVP) - MCALL 1,PRIN1 - SKIPN C,CURPRI - JRST MAINLP - PUSH TP,$TFIX - PUSH TP,C - PUSH TP,$TATOM - PUSH TP,EQUOTE [ INT-LEVEL ] - MCALL 1,PRINC - MCALL 1,PRIN1 - JRST MAINLP ; FALL INTO MAIN LOOP - - ;ROUTINES FOR ERROR-LISTEN - -OBCHK: GETYP 0,A - CAIN 0,TOBLS - JRST CPOPJ1 ; WIN FOR SINGLE OBLIST - CAIE 0,TLIST ; IF LIST, MAKE SURE EACH IS AN OBLIST - JRST CPOPJ ; ELSE, LOSE - - JUMPE B,CPOPJ ; NIL ,LOSE - PUSH TP,A - PUSH TP,B - PUSH P,[0] ;FLAG FOR DEFAULT CHECKING - MOVEI 0,1000 ; VERY BIG NUMBER FOR CIRCULARITY TEST - -OBCHK0: INTGO - SOJE 0,OBLOSE ; CIRCULARITY TEST - HRRZ B,(TP) ; GET LIST POINTER - GETYP A,(B) - CAIE A,TOBLS ; SKIP IF WINNER - JRST DEFCHK ; CHECK FOR SPECIAL ATOM DEFAULT - HRRZ B,(B) - MOVEM B,(TP) - JUMPN B,OBCHK0 -OBWIN: AOS (P)-1 -OBLOSE: SUB TP,[2,,2] - SUB P,[1,,1] - POPJ P, - -DEFCHK: SKIPN (P) ; BEEN HERE BEFORE ? - CAIE A,TATOM ; OR, NOT AN ATOM ? - JRST OBLOSE ; YES, LOSE - MOVE A,(B)+1 - CAME A,MQUOTE DEFAULT - JRST OBLOSE ; LOSE - SETOM (P) ; SET FLAG - HRRZ B,(B) ; CHECK FOR END OF LIST - MOVEM B,(TP) - JUMPN B,OBCHK0 ; NOT THE END, CONTINUE LOOKING - JRST OBLOSE ; LOSE FOR DEFAULT AT THE END - - - -PUSH6: PUSH TP,[TATOM,,-1] - PUSH TP,B - PUSH TP,(C) - PUSH TP,1(C) - PUSH TP,[0] - PUSH TP,[0] - POPJ P, - - -MAKOB: PUSH TP,INITIAL(TVP) - PUSH TP,INITIAL+1(TVP) - PUSH TP,ROOT(TVP) - PUSH TP,ROOT+1(TVP) - MCALL 2,LIST - PUSH TP,$TATOM - PUSH TP,IMQUOTE OBLIST - PUSH TP,A - PUSH TP,B - MCALL 2,SETG - PUSH TP,[TATOM,,-1] - PUSH TP,IMQUOTE OBLIST - PUSH TP,A - PUSH TP,B - PUSH TP,[0] - PUSH TP,[0] - JRST NOTOBL - - -;THIS IS IT FOLKS...THE MAIN LOOP. READ, EVAL, PRINT - -MAINLP: MOVE A,$TATOM ;KLUDGE BY NDR LIKE ERROR TO LET LOOSER REDEFINE - MOVE B,MQUOTE REP - PUSHJ P,ILVAL ;GET ITS LVAL TO SEE IF REDEFINED - GETYP C,A - CAIE C,TUNBOUND - JRST REPCHK - MOVE A,$TATOM ;SEE IF IT HAS GVAL SINCE NO LVAL - MOVE B,MQUOTE REP - PUSHJ P,IGVAL - GETYP C,A - CAIN C,TUNBOUN - JRST IREPER -REPCHK: CAIN C,TSUBR - CAIE B,REPER - JRST .+2 - JRST IREPER -REREPE: PUSH TP,A - PUSH TP,B - GETYP A,-1(TP) - PUSHJ P,APLQ - JRST ERRREP - MCALL 1,APPLY ;LOOSER HAS REDEFINED SO CALL HIS - JRST MAINLP -IREPER: PUSH P,[0] ;INDICATE FALL THROUGH - JRST REPERF - -ERRREP: PUSH TP,[TATOM,,-1] - PUSH TP,MQUOTE REP - PUSH TP,$TSUBR - PUSH TP,[REPER] - PUSH TP,[0] - PUSH TP,[0] - PUSHJ P,SPECBIN - PUSH TP,$TATOM - PUSH TP,EQUOTE NON-APPLICABLE-REP - PUSH TP,-11(TP) - PUSH TP,-11(TP) - MCALL 2,ERROR - SUB TP,[6,,6] - PUSHJ P,SSPECS - JRST REREPE - - -MFUNCTION REPER,SUBR,REP -REPER: ENTRY 0 - PUSH P,[1] ;INDICATE DIRECT CALL -REPERF: MCALL 0,TERPRI - MCALL 0,READ - PUSH TP,A - PUSH TP,B - MCALL 0,TERPRI - MCALL 1,EVAL - PUSH TP,$TATOM - PUSH TP,IMQUOTE LAST-OUT - PUSH TP,A - PUSH TP,B - MCALL 2,SET - PUSH TP,A - PUSH TP,B - MCALL 1,PRIN1 - POP P,C ;FLAG FOR FALL THROUGH OR CALL - JUMPN C,FINIS ;IN CASE LOOSER CALLED REP - JRST MAINLP - - -;FUNCTION TO RETRY A PREVIOUS FUNCTION CALL - -MFUNCTION RETRY,SUBR - - ENTRY - JUMPGE AB,RETRY1 ; USE MOST RECENT - CAMGE AB,[-2,,0] - JRST TMA - GETYP A,(AB) ; CHECK TYPE - CAIE A,TFRAME - JRST WTYP1 - MOVEI B,(AB) ; POINT TO ARG - JRST RETRY2 -RETRY1: MOVE B,IMQUOTE LER,[LERR ]INTRUP - PUSHJ P,ILOC ; LOCATIVE TO FRAME -RETRY2: PUSHJ P,CHFSWP ; CHECK VALIDITY AND SWAP IF NECESSARY - HRRZ 0,OTBSAV(B) ; CHECK FOR TOP - JUMPE 0,RESTAR ; YES RE-ENTER TOP LEVEL - PUSH TP,$TTB - PUSH TP,B ; SAVE FRAME - MOVE B,OTBSAV(B) ; GET PRVIOUS FOR UNBIND HACK - MOVEI C,-1(TP) - PUSHJ P,CHUNW ; CHECK ANY UNWINDING - CAME SP,SPSAV(TB) ; UNBINDING NEEDED? - PUSHJ P,SPECSTORE - MOVE P,PSAV(TB) ; GET OTHER STUFF - MOVE AB,ABSAV(B) - HLRE A,AB ; COMPUTE # OF ARGS - MOVNI A,-FRAMLN(A) ; MAKE TP POINT PAST FRAME - HRLI A,(A) - MOVE C,TPSAV(TB) ; COMPUTE TP - ADD C,A - MOVE TP,C - MOVE TB,B ; FIX UP TB - HRRZ C,FSAV(TB) ; GET FUNCTION - CAMGE C,VECTOP ; CHECK FOR RSUBR - CAMG C,VECBOT - JRST (C) ; GO - GETYP 0,(C) ; RSUBR OR ENTRY? - CAIE 0,TATOM - CAIN 0,TRSUBR - JRST RETRNT - MOVS R,(C) ; SET UP R - HRRI R,(C) - MOVEI C,0 - JRST RETRN3 - -RETRNT: CAIE 0,TRSUBR - JRST RETRN1 - MOVE R,1(C) -RETRN4: HRRZ C,2(C) ; OFFSET -RETRN3: SKIPL M,1(R) - JRST RETRN5 -RETRN7: ADDI C,(M) - JRST (C) - -RETRN5: MOVEI D,(M) ; TOTAL OFFSET - MOVSS M - ADD M,PURVEC+1(TVP) - SKIPL M,1(M) - JRST RETRN6 - ADDI M,(D) - JRST RETRN7 -RETRN6: HLRZ A,1(R) - PUSH P,D - PUSH P,C - PUSHJ P,PLOAD - JRST RETRER ; LOSER - POP P,C - POP P,D - MOVE M,B - JRST RETRN7 - -RETRN1: MOVE B,1(C) - PUSH TP,$TVEC - PUSH TP,C - PUSHJ P,IGVAL - GETYP 0,A - MOVE C,(TP) - SUB TP,[2,,2] - CAIE 0,TRSUBR - JRST RETRN2 - MOVE R,B - JRST RETRN3 - -RETRN2: PUSH TP,$TATOM - PUSH TP,EQUOTE CANT-RETRY-ENTRY-GONE - JRST CALER1 - -RETRER: PUSH TP,$TATOM - PUSH TP,EQUOTE PURE-LOAD-FAILURE - JRST CALER1 - - -;FUNCTION TO DO ERROR RETURN - -MFUNCTION ERRET,SUBR - - ENTRY - HLRE A,AB ; -2*# OF ARGS - JUMPGE A,STP ; RESTART PROCESS - ASH A,-1 ; -# OF ARGS - AOJE A,ERRET2 ; NO FRAME SUPPLIED - AOJL A,TMA - ADD AB,[2,,2] - PUSHJ P,OKFRT - JRST WTYP2 - SUB AB,[2,,2] - PUSHJ P,CHPROC ; POINT TO FRAME SLOT - JRST ERRET3 -ERRET2: MOVE B,IMQUOTE LER,[LERR ]INTRUP - PUSHJ P,ILVAL ; GET ITS VALUE -ERRET3: PUSH TP,A - PUSH TP,B - MOVEI B,-1(TP) - PUSHJ P,CHFSWP ; CHECK VALIDITY AND SWAP IF NECESSARY - HRRZ 0,OTBSAV(B) ; TOP LEVEL? - JUMPE 0,TOPLOS - PUSHJ P,CHUNW ; ANY UNWINDING - JRST CHFINIS - - -; FUNCTION TO RETURN LAST ERROR FRAME OR PREVIOUS FRAME - -MFUNCTION FRAME,SUBR - ENTRY - SETZB A,B - JUMPGE AB,FRM1 ; DEFAULT CASE - CAMG AB,[-3,,0] ; SKIP IF OK ARGS - JRST TMA - PUSHJ P,OKFRT ; A FRAME OR SIMILAR THING? - JRST WTYP1 - -FRM1: PUSHJ P,CFRAME ; GO TO INTERNAL - JRST FINIS - -CFRAME: JUMPN A,FRM2 ; ARG SUPPLIED? - MOVE B,IMQUOTE LER,[LERR ]INTRUP - PUSHJ P,ILVAL - JRST FRM3 -FRM2: PUSHJ P,CHPROC ; CHECK FOR PROCESS - PUSH TP,A - PUSH TP,B - MOVEI B,-1(TP) ; POINT TO SLOT - PUSHJ P,CHFRM ; CHECK IT - MOVE C,(TP) ; GET FRAME BACK - MOVE B,OTBSAV(C) ;GET PREVIOUS FRAME - SUB TP,[2,,2] - TRNN B,-1 ; SKIP IF OK - JRST TOPLOSE - -FRM3: JUMPN B,FRM4 ; JUMP IF WINNER - MOVE B,IMQUOTE THIS-PROCESS - PUSHJ P,ILVAL ; GET PROCESS OF INTEREST - GETYP A,A ; CHECK IT - CAIN A,TUNBOU - MOVE B,PVP ; USE CURRENT - MOVEI A,PVLNT*2+1(B) ; POINT TO DOPE WORDS - MOVE B,TBINIT+1(B) ; AND BASE FRAME -FRM4: HLL B,OTBSAV(B) ;TIME - HRLI A,TFRAME - POPJ P, - -OKFRT: AOS (P) ;ASSUME WINNAGE - GETYP 0,(AB) - MOVE A,(AB) - MOVE B,1(AB) - CAIE 0,TFRAME - CAIN 0,TENV - POPJ P, - CAIE 0,TPVP - CAIN 0,TACT - POPJ P, - SOS (P) - POPJ P, - -CHPROC: GETYP 0,A ; TYPE - CAIE 0,TPVP - POPJ P, ; OK - MOVEI A,PVLNT*2+1(B) - CAMN B,PVP ; THIS PROCESS? - JRST CHPRO1 - MOVE B,TBSTO+1(B) - JRST FRM4 - -CHPRO1: MOVE B,OTBSAV(TB) - JRST FRM4 - -; FUNCTION TO RETURN ARGS TUPLE FOR A FRAME - -MFUNCTION ARGS,SUBR - ENTRY 1 - PUSHJ P,OKFRT ; CHECK FRAME TYPE - JRST WTYP1 - PUSHJ P,CARGS - JRST FINIS - -CARGS: PUSHJ P,CHPROC - PUSH TP,A - PUSH TP,B - MOVEI B,-1(TP) ; POINT TO FRAME SLOT - PUSHJ P,CHFRM ; AND CHECK FOR VALIDITY - MOVE C,(TP) ; FRAME BACK - MOVSI A,TARGS -CARGS1: GETYP 0,FSAV(C) ; IS THIS A FUNNY ONE - CAIE 0,TCBLK ; SKIP IF FUNNY - JRST .+3 ; NO NORMAL - MOVE C,OTBSAV(C) ; ASSOCIATE WITH PREVIOUS FRAME - JRST CARGS1 - HLR A,OTBSAV(C) ; TIME IT AND - MOVE B,ABSAV(C) ; GET POINTER - SUB TP,[2,,2] ; FLUSH CRAP - POPJ P, - -; FUNCTION TO RETURN FUNCTION ASSOCIATED WITH A FRAME - -MFUNCTION FUNCT,SUBR ;RETURNS FUNCTION NAME OF - ENTRY 1 ; FRAME ARGUMENT - PUSHJ P,OKFRT ; CHECK TYPE - JRST WTYP1 - PUSHJ P,CFUNCT - JRST FINIS - -CFUNCT: PUSHJ P,CHPROC - PUSH TP,A - PUSH TP,B - MOVEI B,-1(TP) - PUSHJ P,CHFRM ; CHECK IT - MOVE C,(TP) ; RESTORE FRAME - HRRZ A,FSAV(C) ;FUNCTION POINTER - CAMG A,VECTOP ;IS THIS AN RSUBR ? - CAMGE A,VECBOT - SKIPA B,@-1(A) ;NO, GET SUBR'S NAME POINTER - MOVE B,(A)+3 ;YES, GET RSUBR'S NAME ENTRY - MOVSI A,TATOM - SUB TP,[2,,2] - POPJ P, - -BADFRAME: - PUSH TP,$TATOM - PUSH TP,EQUOTE FRAME-NO-LONGER-EXISTS - JRST CALER1 - - -TOPLOSE: - PUSH TP,$TATOM - PUSH TP,EQUOTE TOP-LEVEL-FRAME - JRST CALER1 - - - - -; ROUTINE TO HANG INDEFINITELY WITH INTERRUPTS ENABLED - -MFUNCTION HANG,SUBR - - ENTRY - - JUMPGE AB,HANG1 ; NO PREDICATE - CAMGE AB,[-3,,] - JRST TMA -REHANG: MOVE A,[PUSHJ P,CHKPRH] - MOVEM A,ONINT ; CHECK PREDICATE AFTER ANY INTERRUPT - PUSH TP,(AB) - PUSH TP,1(AB) -HANG1: ENABLE ;LET OURSELVES BE INTERRUPTED OUT - PUSHJ P,%HANG - DISABLE ;PREVENT INTERRUPTS AT RANDOM TIMES - SETZM ONINT - MOVE A,$TATOM - MOVE B,MQUOTE T - JRST FINIS - - -; ROUTINE TO SLEEP FOR POSITIVE NUMBER OF SECONDS WITH INTERRUPTS ENABLED -; ARGUMENT SHOULD BE OF TYPE FIX OR FLOAT AND NON-NEGATIVE - -MFUNCTION SLEEP,SUBR - - ENTRY - - JUMPGE AB,TFA - CAML AB,[-3,,] - JRST SLEEP1 - CAMGE AB,[-5,,] - JRST TMA - PUSH TP,2(AB) - PUSH TP,3(AB) -SLEEP1: GETYP 0,(AB) - CAIE 0,TFIX - JRST .+5 - MOVE B,1(AB) - JUMPL B,OUTRNG ;ARG SHOULDNT BE NEGATIVE - IMULI B,30. ;CONVERT TO # OF THIRTIETHS OF A SECOND - JRST SLEEPR ;GO SLEEP - CAIE 0,TFLOAT ;IF IT WASNT FIX MAKE SURE IT IS FLOAT - JRST WTYP1 ;WRONG TYPE ARG - MOVE B,1(AB) - FMPR B,[30.0] ;CONVERT TO FLOATING # OF THIRTIETHS OF A SECOND - MULI B,400 ;KLUDGE TO FIX IT - TSC B,B - ASH C,(B)-243 - MOVE B,C ;MOVE THE FIXED NUMBER INTO B - JUMPL B,OUTRNG ;CHECK TO SEE THAT WE HAVE POSITIVE NUMBER -SLEEPR: MOVE A,B -RESLEE: MOVE B,[PUSHJ P,CHKPRS] - CAMGE AB,[-3,,] - MOVEM B,ONINT - ENABLE - PUSHJ P,%SLEEP - DISABLE - SETZM ONINT - MOVE A,$TATOM - MOVE B,MQUOTE T - JRST FINIS - -CHKPRH: PUSH P,B - MOVEI B,HANGP - JRST .+3 - -CHKPRS: PUSH P,B - MOVEI B,SLEEPP - HRRM B,LCKINT - SETZM ONINT ; TURN OFF FEATURE FOR NOW - POP P,B - POPJ P, - -HANGP: SKIPA B,[REHANG] -SLEEPP: MOVEI B,RESLEE - PUSH P,B - PUSH P,A - DISABLE - PUSH TP,(TB) - PUSH TP,1(TB) - MCALL 1,EVAL - GETYP 0,A - CAIE 0,TFALSE - JRST FINIS - POP P,A - POPJ P, - -MFUNCTION VALRET,SUBR -; SUBR TO VALRET A STRING TO SUPERIOR ITS PROCESS - - ENTRY 1 - GETYP A,(AB) ; GET TYPE OF ARGUMENT - CAIE A,TCHSTR ; IS IT A CHR STRING? - JRST WTYP1 ; NO...ERROR WRONG TYPE - PUSHJ P,CSTACK ; COPY THE CHR STRING TO THE STACK - ; CSTACK IS IN ATOMHK - MOVEI B,0 ; ASCIZ TERMINATOR - EXCH B,(P) ; STORE AND RETRIEVE COUNT - -; CALCULATE THE BEGINNING ADDR OF THE STRING - MOVEI A,-1(P) ; GET ADDR OF TOP OF STACK - SUBI A,-1(B) ; GET STARTING ADDR - PUSHJ P,%VALRE ; PASS UP TO MONITOR - JRST IFALSE ; IF HE RETURNS, RETURN FALSE - - -MFUNCTION LOGOUT,SUBR - -; SUBR TO DO A .LOGOUT (VALID ONLY AT TOP LEVEL) - ENTRY 0 - PUSHJ P,%TOPLQ ; SKIP IF AT TOP LEVEL - JRST IFALSE - PUSHJ P,CLOSAL - PUSHJ P,%LOGOUT ; TRY TO FLUSH - JRST IFALSE ; COULDN'T DO IT...RETURN FALSE - -; FUNCTS TO GET UNAME AND JNAME - -MFUNCTION UNAME,SUBR - - ENTRY 0 - - PUSHJ P,%RUNAM - JRST RSUJNM - -MFUNCTION JNAME,SUBR - - ENTRY 0 - - PUSHJ P,%RJNAM - JRST RSUJNM - -; FUNCTION TO SET AND READ GLOBAL SNAME - -MFUNCTION SNAME,SUBR - - ENTRY - - JUMPGE AB,SNAME1 - CAMG AB,[-3,,] - JRST TMA - GETYP A,(AB) ; ARG MUST BE STRING - CAIE A,TCHSTR - JRST WTYP1 - PUSH TP,$TATOM - PUSH TP,IMQUOTE SNM - PUSH TP,(AB) - PUSH TP,1(AB) - MCALL 2,SETG - JRST FINIS - -SNAME1: MOVE B,IMQUOTE SNM - PUSHJ P,IDVAL1 - GETYP 0,A - CAIN 0,TCHSTR - JRST FINIS - MOVE A,$TCHSTR - MOVE B,CHQUOTE - JRST FINIS - -RSUJNM: PUSHJ P,6TOCHS ; CONVERT IT - JRST FINIS - - -SGSNAM: MOVE B,IMQUOTE SNM - PUSHJ P,IDVAL1 - GETYP 0,A - CAIE 0,TCHSTR - JRST SGSN1 - - PUSH TP,A - PUSH TP,B - PUSHJ P,STRTO6 - POP P,A - SUB TP,[2,,2] - JRST .+2 - -SGSN1: MOVEI A,0 - PUSHJ P,%SSNAM ; SET SNAME IN SYSTEM - POPJ P, - - - -;THIS SUBROUTINE ALLOCATES A NEW PROCESS TAKES NO ARGS AND -;IS CALLED BY PUSHJ P,. RETURNS IN A AND B A NEW PROCESS. - -ICR: MOVEI A,PVLNT ;SETUP CALL TO VECTOR FOR PVP - PUSHJ P,IVECT ;GOBBLE A VECTOR - HRLI C,PVBASE ;SETUP A BLT POINTER - HRRI C,(B) ;GET INTO ADDRESS - BLT C,PVLNT*2-1(B) ;COPY A PROTOTYPE INTO NEW PVP - MOVSI C,400000+SPVP+.VECT. ;SET SPECIAL TYPE - MOVEM C,PVLNT*2(B) ;CLOBBER IT IN - PUSH TP,A ;SAVE THE RESULTS OF VECTOR - PUSH TP,B - - PUSH TP,$TFIX ;GET A UNIFORM VECTOR - PUSH TP,[PLNT] - MCALL 1,UVECTOR - ADD B,[PDLBUF-2,,-1] ;FUDGE WITH BUFFER - MOVE C,(TP) ;REGOBBLE PROCESS POINTER - MOVEM B,PSTO+1(C) ;STORE IN ALL HOMES - MOVEM B,PBASE+1(C) - - - MOVEI A,TPLNT ;PREPARE TO CREATE A TEMPORARY PDL - PUSHJ P,IVECT ;GET THE TEMP PDL - ADD B,[PDLBUF,,0] ;PDL GROWTH HACK - MOVE C,(TP) ;RE-GOBBLE NEW PVP - SUB B,[1,,1] ;FIX FOR STACK - MOVEM B,TPBASE+1(C) - -;SETUP INITIAL BINDING - - PUSH B,$TBIND - MOVEM B,SPBASE+1(C) ;SAVE AS BASE OF SP - MOVEM B,SPSTO+1(C) ;AND CURRENT THEREOF - MOVEM B,CURFCN+1(C) ; AND AS CURRENT FCN FOR SPEC/UNSPEC LOGIC - PUSH B,IMQUOTE THIS-PROCESS - PUSH B,$TPVP ;GIVE IT PROCESS AS VALUE - PUSH B,C - ADD B,[2,,2] ;FINISH FRAME - MOVEM B,TPSTO+1(C) ;MAKE THIS THE CURRENT STACK POINTER - MOVEM C,PVPSTO+1(C) ;SAVE THE NEW PVP ITSELF - MOVEM TVP,TVPSTO+1(C) ;AND THE GOOD OLD TRANSFER VECTOR - AOS A,IDPROC ;GOBBLE A UNIQUE PROCESS I.D. - MOVEM A,PROCID+1(C) ;SAVE THAT ALSO - AOS A,PTIME ; GET A UNIQUE BINDING ID - MOVEM A,BINDID+1(C) - - MOVSI A,TPVP ;CLOBBER THE TYPE - MOVE B,(TP) ;AND POINTER TO PROCESS - SUB TP,[2,,2] - POPJ P, - -;MINI ROUTINE TO CALL VECTOR WITH COUNT IN A - -IVECT: PUSH TP,$TFIX - PUSH TP,A - MCALL 1,VECTOR ;GOBBLE THE VECTOR - POPJ P, - - -;SUBROUTINE TO SWAP A PROCESS IN -;CALLED WITH JSP A,SWAP AND NEW PVP IN B - -SWAP: ;FIRST STORE ALL THE ACS - - IRP A,,[PVP,TVP,AB,TB,TP,SP,P,M,R] - MOVEM A,A!STO+1(PVP) - TERMIN - - SETOM 1(TP) ; FENCE POST MAIN STACK - MOVEM TP,TPSAV(TB) ; CORRECT FRAME - SETZM PSAV(TB) ; CLEAN UP CURRENT FRAME - SETZM SPSAV(TB) - SETZM PCSAV(TB) - - MOVE E,PVP ;RETURN OLD PROCESS IN E - MOVE PVP,D ;AND MAKE NEW ONE BE D - -SWAPIN: - ;NOW RESTORE NEW PROCESSES AC'S - - IRP A,,[PVP,TVP,AB,TB,TP,SP,P,M,R] - MOVE A,A!STO+1(PVP) - TERMIN - - JRST (C) ;AND RETURN - - - - -;SUBRS ASSOCIATED WITH TYPES - -;INTERNAL FUNCTION TO GET STRAGE ALLOCATION TYPE -;GETS THE TYPE CODE IN A AND RETURNS SAT IN A. - -SAT: LSH A,1 ;TIMES 2 TO REF VECTOR - HRLS A ;TO BOTH HALVES TO HACK AOBJN POINTER - ADD A,TYPVEC+1(TVP) ;ACCESS THE VECTOR - HRR A,(A) ;GET PROBABLE SAT - JUMPL A,.+2 ;DID WE REALLY HAVE A VALID TYPE - MOVEI A,0 ;NO RETURN 0 - ANDI A,SATMSK - POPJ P, ;AND RETURN - -;TYPE (ITYPE) ARE FUNCTIONS TO RETURN THE ATOMIC NAME OF THE -;TYPE OF A GOODIE. TYPE TAKES ITS ARGS ON AP AND RETURNS IN A AND B. -;ITYPE TAKES ITS ARGS IN A AND B AND RETURNS IN SAME (B=0) FOR INVALID -;TYPECODE. -MFUNCTION TYPE,SUBR - - ENTRY 1 - GETYP A,(AB) ;TYPE INTO A -TYPE1: PUSHJ P,ITYPE ;GO TO INTERNAL - JUMPN B,FINIS ;GOOD RETURN -TYPERR: PUSH TP,$TATOM ;SETUP ERROR CALL - PUSH TP,EQUOTE TYPE-UNDEFINED - JRST CALER1" ;STANDARD ERROR HACKER - -CITYPE: GETYP A,A ; GET TYPE FOR COMPILER CALL -ITYPE: LSH A,1 ;TIMES 2 - HRLS A ;TO BOTH SIDES - ADD A,TYPVEC+1(TVP) ;GET ACTUAL LOCATION - JUMPGE A,TYPERR ;LOST, TYPE OUT OF BOUNDS - MOVE B,1(A) ;PICKUP TYPE - HLLZ A,(A) - POPJ P, - -; PREDICATE -- IS OBJECT OF TYPE SPECIFIED - -MFUNCTION %TYPEQ,SUBR,[TYPE?] - - ENTRY - - MOVE D,AB ; GET ARGS - ADD D,[2,,2] - JUMPGE D,TFA - MOVE A,(AB) - HLRE C,D - MOVMS C - ASH C,-1 ; FUDGE - PUSHJ P,ITYPQ ; GO INTERNAL - JFCL - JRST FINIS - -ITYPQ: GETYP A,A ; OBJECT - PUSHJ P,ITYPE -TYPEQ0: SOJL C,CIFALS - GETYP 0,(D) - CAIE 0,TATOM ; Type name must be an atom - JRST WRONGT - CAMN B,1(D) ; Same as the OBJECT? - JRST CPOPJ1 ; Yes, return type name - ADD D,[2,,2] - JRST TYPEQ0 ; No, continue comparing - -CIFALS: MOVEI B,0 - MOVSI A,TFALSE - POPJ P, - -CTYPEQ: SOJE A,CIFALS ; TREAT NO ARGS AS FALSE - MOVEI D,1(A) ; FIND BASE OF ARGS - ASH D,1 - HRLI D,(D) - SUBM TP,D ; D POINTS TO BASE - MOVE E,D ; SAVE FOR TP RESTORE - ADD D,[3,,3] ; FUDGE - MOVEI C,(A) ; NUMBER OF TYPES - MOVE A,-2(D) - PUSHJ P,ITYPQ - JFCL ; IGNORE SKIP FOR NOW - MOVE TP,E ; SET TP BACK - JUMPL B,CPOPJ1 ; SKIP - POPJ P, - -; Entries to get type codes for types for fixing up RSUBRs and assembling - -MFUNCTION %TYPEC,SUBR,[TYPE-C] - - ENTRY - - JUMPGE AB,TFA - GETYP 0,(AB) - CAIE 0,TATOM - JRST WTYP1 - MOVE B,1(AB) - CAMGE AB,[-3,,0] ; skip if only type name given - JRST GTPTYP - MOVE C,MQUOTE ANY - -TYPEC1: PUSHJ P,CTYPEC ; go to internal - JRST FINIS - -GTPTYP: CAMGE AB,[-5,,0] - JRST TMA - GETYP 0,2(AB) - CAIE 0,TATOM - JRST WTYP2 - MOVE C,3(AB) - JRST TYPEC1 - -CTYPEC: PUSH P,C ; save primtype checker - PUSHJ P,TYPLOO ; search type vector - POP P,B - CAMN B,MQUOTE ANY - JRST CTPEC1 - PUSH P,D - HRRZ A,(A) - ANDI A,SATMSK - PUSH P,A - PUSHJ P,TYPLOO - HRRZ 0,(A) - ANDI 0,SATMSK - CAME 0,(P) - JRST TYPDIF - MOVE D,-1(P) - SUB P,[2,,2] -CTPEC1: MOVEI B,(D) - MOVSI A,TTYPEC - POPJ P, - -MFUNCTION %TYPEW,SUBR,[TYPE-W] - - ENTRY - - JUMPGE AB,TFA - GETYP 0,(AB) - CAIE 0,TATOM - JRST WTYP1 - MOVEI D,0 - MOVE C,MQUOTE ANY - MOVE B,1(AB) - CAMGE AB,[-3,,0] - JRST CTYPW1 - -CTYPW3: PUSHJ P,CTYPEW - JRST FINIS - -CTYPW1: GETYP 0,2(AB) - CAIE 0,TATOM - JRST WTYP2 - CAMGE AB,[-5,,0] ; JUMP IF RH IS GIVEN - JRST CTYPW2 - MOVE C,3(AB) - JRST CTYPW3 - -CTYPW2: CAMGE AB,[-7,,0] - JRST TMA - GETYP 0,4(AB) - CAIE 0,TFIX - JRST WRONGT - MOVE D,5(AB) - JRST CTYPW3 - -CTYPEW: PUSH P,D - PUSHJ P,CTYPEC ; GET CODE IN B - POP P,B - HRLI B,(D) - MOVSI A,TTYPEW - POPJ P, - -;PRIMTTYPE RETURNS THE TYPE ATOM OF A PRIMITIVE TYPE IN A CLASS - -STBL: REPEAT NUMSAT,MQUOTE INTERNAL-TYPE - -LOC STBL - -IRP A,,[[1WORD,WORD],[2WORD,LIST],[NWORD,UVECTOR],[2NWORD,VECTOR],[STORE,STORAGE] -[ARGS,TUPLE],[FRAME,FRAME],[ATOM,ATOM],[LOCID,LOCD],[CHSTR,STRING] -[PVP,PROCESS],[ASOC,ASOC],[LOCA,LOCA],[LOCS,LOCS],[LOCU,LOCU],[LOCV,LOCV] -[LOCL,LOCL],[LOCN,LOCAS],[LOCT,LOCT]] -IRP B,C,[A] -LOC STBL+S!B -MQUOTE C - -.ISTOP - -TERMIN -TERMIN - -LOC STBL+NUMSAT+1 - - -MFUNCTION TYPEPRIM,SUBR - - ENTRY 1 - GETYP A,(AB) - CAIE A,TATOM - JRST NOTATOM - MOVE B,1(AB) - PUSHJ P,CTYPEP - JRST FINIS - -CTYPEP: PUSHJ P,TYPLOO ; CONVERT ATOM TO CODE - HRRZ A,(A) ; SAT TO A - ANDI A,SATMSK - JRST PTYP1 - -MFUNCTION PRIMTYPE,SUBR - - ENTRY 1 - - MOVE A,(AB) ;GET TYPE - PUSHJ P,CPTYPE - JRST FINIS - -CPTYPE: GETYP A,A - PUSHJ P,SAT ;GET SAT -PTYP1: JUMPE A,TYPERR - MOVE B,MQUOTE TEMPLATE - CAIG A,NUMSAT ; IF BIG SAT, THEN TEMPLATE - MOVE B,@STBL(A) - MOVSI A,TATOM - POPJ P, - - -; RSUBR MAKES A VECTOR INTO AN OBJECT OF TYPE RSUBR, ALSO SLIGHTLY MUNGING IT - -MFUNCTION RSUBR,SUBR - ENTRY 1 - - GETYP A,(AB) - CAIE A,TVEC ; MUST BE VECTOR - JRST WTYP1 - MOVE B,1(AB) ; GET IT - GETYP A,(B) ; CHECK 1ST ELEMENTS TYPE - CAIN A,TPCODE ; PURE CODE - JRST .+3 - CAIE A,TCODE - JRST NRSUBR - HLRM B,(B) ; CLOBEER SPECIAL COUNT FIELD - MOVSI A,TRSUBR - JRST FINIS - -NRSUBR: PUSH TP,$TATOM - PUSH TP,EQUOTE FIRST-ELEMENT-OF-VECTOR-NOT-CODE - JRST CALER1 - -; ROUTINE TO GENERATE ENTRYY OTHER THAN FIRST TO RSUBRR - -MFUNCTION MENTRY,SUBR,[RSUBR-ENTRY] - - ENTRY 2 - - GETYP 0,(AB) ; TYPE OF ARG - CAIE 0,TVEC ; BETTER BE VECTOR - JRST WTYP1 - GETYP 0,2(AB) - CAIE 0,TFIX - JRST WTYP2 - MOVE B,1(AB) ; GET VECTOR - CAML B,[-3,,0] - JRST BENTRY - GETYP 0,(B) ; FIRST ELEMENT - CAIE 0,TRSUBR - JRST MENTR1 -MENTR2: GETYP 0,2(B) - CAIE 0,TATOM - JRST BENTRY - MOVE C,3(AB) - HRRM C,2(B) ; OFFSET INTO VECTOR - HLRM B,(B) - MOVSI A,TENTER - JRST FINIS - -MENTR1: CAIE 0,TATOM - JRST BENTRY - MOVE B,1(B) ; GET ATOM - PUSHJ P,IGVAL ; GET VAL - GETYP 0,A - CAIE 0,TRSUBR - JRST BENTRY - MOVE B,1(AB) ; RESTORE B - JRST MENTR2 - -BENTRY: PUSH TP,$TATOM - PUSH TP,EQUOTE BAD-VECTOR - JRST CALER1 - -; SUBR TO GET ENTRIES OFFSET - -MFUNCTION LENTRY,SUBR,[ENTRY-LOC] - - ENTRY 1 - - GETYP 0,(AB) - CAIE 0,TENTER - JRST WTYP1 - MOVE B,1(AB) - HRRZ B,2(B) - MOVSI A,TFIX - JRST FINIS - -; RETURN FALSE - -RTFALS: MOVSI A,TFALSE - MOVEI B,0 - POPJ P, - -;SUBROUTINE CALL FOR RSUBRs -RCALL: SUBM M,(P) ;CALCULATE PC's OFFSET IN THE RSUBR - PUSHJ P,@0 ;GO TO THE PROPER SUBROUTINE - SUBM M,(P) ;RECONSTITUTE THE RSUBR's PC - POPJ P, - - -; ERRORS IN COMPILED CODE MAY END UP HERE - -COMPERR: - PUSH TP,$TATOM - PUSH TP,EQUOTE ERROR-IN-COMPILED-CODE - JRST CALER1 - - -;CHTYPE TAKES TWO ARGUMENTS. ANY GOODIE AND A AN ATOMIC TYPE NAME -;IT CHECKS THE STORAGE ALLOCATION TYPES OF THE TWO ARE THE SAME AND -;IF THEY ARE CHANGES THE TYPE OF THE FIRST TO THAT NAME D IN THE SECOND - -MFUNCTION CHTYPE,SUBR - - ENTRY 2 - GETYP A,2(AB) ;FIRST CHECK THAT ARG 2 IS AN ATOM - CAIE A,TATOM - JRST NOTATOM - MOVE B,3(AB) ;AND TYPE NAME - PUSHJ P,TYPLOO ;GO LOOKUP TYPE -TFOUND: HRRZ B,(A) ;GOBBLE THE SAT - TRNE B,CHBIT ; SKIP IF CHTYPABLE - JRST CANTCH - TRNE B,TMPLBT ; TEMPLAT - HRLI B,-1 - AND B,[-1,,SATMSK] - GETYP A,(AB) ;NOW GET TYPE TO HACK - PUSHJ P,SAT ;FIND OUT ITS SAT - JUMPE A,TYPERR ;COMPLAIN - CAILE A,NUMSAT - JRST CHTMPL ; JUMP IF TEMPLATE DATA - CAIE A,(B) ;DO THEY AGREE? - JRST TYPDIF ;NO, COMPLAIN -CHTMP1: MOVSI A,(D) ;GET NEW TYPE - HRR A,(AB) ; FOR DEFERRED GOODIES - JUMPL B,CHMATC ; CHECK IT - MOVE B,1(AB) ;AND VALUE - JRST FINIS - -CHTMPL: MOVE E,1(AB) ; GET ARG - HLRZ A,(E) - ANDI A,SATMSK - MOVE 0,3(AB) ; SEE IF TO "TEMPLATE" - CAME 0,MQUOTE TEMPLATE - CAIN A,(B) - JRST CHTMP1 - JRST TYPDIF - -CHMATC: PUSH TP,A - PUSH TP,1(AB) ; SAVE GOODIE - MOVSI A,TATOM - MOVE B,3(AB) - MOVSI C,TATOM - MOVE D,MQUOTE DECL - PUSHJ P,IGET ; FIND THE DECL - MOVE C,(AB) - MOVE D,1(AB) ; NOW GGO TO MATCH - PUSHJ P,TMATCH - JRST TMPLVIO - POP TP,B - POP TP,A - JRST FINIS - -TYPLOO: PUSHJ P,TYPFND - JRST .+2 - POPJ P, - PUSH TP,$TATOM ;LOST, GENERATE ERROR - PUSH TP,EQUOTE BAD-TYPE-NAME - JRST CALER1 - -TYPFND: MOVE A,TYPVEC+1(TVP) ;GOBBLE DOWN TYPE VECTOR - MOVEI D,0 ;INITIALIZE TYPE COUNTER -TLOOK: CAMN B,1(A) ;CHECK THIS ONE - JRST CPOPJ1 - ADDI D,1 ;BUMP COUNTER - AOBJP A,.+2 ;COUTN DOWN ON VECTOR - AOBJN A,TLOOK - POPJ P, -CPOPJ1: AOS (P) - POPJ P, - -TYPDIF: PUSH TP,$TATOM ;MAKE ERROR MESSAGE - PUSH TP,EQUOTE STORAGE-TYPES-DIFFER - JRST CALER1 - - -TMPLVI: PUSH TP,$TATOM - PUSH TP,EQUOTE DECL-VIOLATION - JRST CALER1 - - -; FUNCTION TO ADD A NEW TYPE TO THE WORLD WITH GIVEN PRIMITIVE TYPE - -MFUNCTION NEWTYPE,SUBR - - ENTRY - - HLRZ 0,AB ; CHEC # OF ARGS - CAILE 0,-4 ; AT LEAST 2 - JRST TFA - CAIGE 0,-6 - JRST TMA ; NOT MORE THAN 3 - GETYP A,(AB) ; GET 1ST ARGS TYPE (SHOULD BE ATOM) - GETYP C,2(AB) ; SAME WITH SECOND - CAIN A,TATOM ; CHECK - CAIE C,TATOM - JRST NOTATOM - - MOVE B,3(AB) ; GET PRIM TYPE NAME - PUSHJ P,TYPLOO ; LOOK IT UP - HRRZ A,(A) ; GOBBLE SAT - HRLI A,TATOM ; MAKE NEW TYPE - PUSH P,A ; AND SAVE - MOVE B,1(AB) ; SEE IF PREV EXISTED - PUSHJ P,TYPFND - JRST NEWTOK ; DID NOT EXIST BEFORE - MOVEI B,2(A) ; FOR POSSIBLE TMPLAT BIT - HRRZ A,(A) ; GET SAT - HRRZ 0,(P) ; AND PROPOSED - ANDI 0,SATMSK - ANDI A,SATMSK - CAIN 0,(A) ; SKIP IF LOSER - JRST NEWTFN ; O.K. - - PUSH TP,$TATOM - PUSH TP,EQUOTE TYPE-ALREADY-EXISTS - JRST CALER1 - -NEWTOK: POP P,A - MOVE B,1(AB) ; NEWTYPE NAME - PUSHJ P,INSNT ; MUNG IN NEW TYPE - -NEWTFN: CAML AB,[-5,,] ; SKIP IF TEMPLAT SUPPLIED - JRST NEWTF1 - MOVEI 0,TMPLBT ; GET THE BIT - IORM 0,-2(B) ; INTO WORD - MOVE A,(AB) ; GET TYPE NAME - MOVE B,1(AB) - MOVSI C,TATOM - MOVE D,MQUOTE DECL - PUSH TP,4(AB) ; GET TEMLAT - PUSH TP,5(AB) - PUSHJ P,IPUT -NEWTF1: MOVE A,(AB) - MOVE B,1(AB) ; RETURN NAME - JRST FINIS - -; SET UP GROWTH FIELDS - -IGROWT: SKIPA A,[111100,,(C)] -IGROWB: MOVE A,[001100,,(C)] - HLRE B,C - SUB C,B ; POINT TO DOPE WORD - MOVE B,TYPIC ; INDICATED GROW BLOCK - DPB B,A - POPJ P, - -INSNT: PUSH TP,A - PUSH TP,B ; SAVE NAME OF NEWTYPE - MOVE C,TYPBOT+1(TVP) ; CHECK GROWTH NEED - CAMGE C,TYPVEC+1(TVP) - JRST ADDIT ; STILL ROOM -GAGN: PUSHJ P,IGROWB ; SETUP BOTTOM GROWTH - SKIPE C,EVATYP+1(TVP) - PUSHJ P,IGROWT ; SET UP TOP GROWTH - SKIPE C,APLTYP+1(TVP) - PUSHJ P,IGROWT - MOVE C,[11.,,5] ; SET UP INDICATOR FOR AGC - PUSHJ P,AGC ; GROW THE WORLD - AOJL A,GAGN ; BAD AGC LOSSAGE - MOVE 0,[-101,,-100] - ADDM 0,TYPBOT+1(TVP) ; FIX UP POINTER - -ADDIT: MOVE C,TYPVEC+1(TVP) - SUB C,[2,,2] ; ALLOCATE ROOM - MOVEM C,TYPVEC+1(TVP) - HLRE B,C ; PREPARE TO BLT - SUBM C,B ; C POINTS DOPE WORD END - HRLI C,2(C) ; GET BLT AC READY - BLT C,-3(B) - POP TP,-1(B) ; CLOBBER IT IN - POP TP,-2(B) - POPJ P, - - -; Interface to interpreter for setting up tables associated with -; template data structures. -; A/ <-name of type>- -; B/ <-length ins>- -; C/ <-uvector of length code or 0> -; D/ <-uvector of GETTERs>- -; E/ <-uvector of PUTTERs>- - -CTMPLT: SUBM M,(P) ; could possibly gc during this stuff - SKIPE C ; for now dont handle vector of length ins - FATAL TEMPLATE DATA WITH COMPUTED LENGTH - PUSH TP,$TATOM ; save name of type - PUSH TP,A - PUSH P,B ; save length instr - HLRE A,TD.LNT+1(TVP) ; check for template slots left? - HRRZ B,TD.LNT+1(TVP) - SUB B,A ; point to dope words - HLRZ B,1(B) ; get real length - ADDM B,A ; any room? - JUMPG A,GOODRM ; jump if ok - - PUSH TP,$TUVEC ; save getters and putters - PUSH TP,D - PUSH TP,$TUVEC - PUSH TP,E - MOVEI A,6(B) ; grow it 10 by copying - PUSH P,A ; save new length - PUSHJ P,CAFRE1 ; get frozen uvector - ADD B,[10,,10] ; rest it down some - HRL C,TD.LNT+1(TVP) ; prepare to BLT in - MOVEM B,TD.LNT+1(TVP) ; and save as new length vector - HRRI C,(B) ; destination - ADD B,(P) ; final destination address - BLT C,-13(B) - MOVE A,(P) ; length for new getters - PUSHJ P,CAFRE1 - MOVE C,TD.GET+1(TVP) ; get old for copy - MOVEM B,TD.GET+1(TVP) - HRRI C,(B) - ADD B,(P) - BLT C,-13(B) ; zap those guys in - MOVE A,(P) ; finally putters - PUSHJ P,CAFRE1 - MOVE C,TD.PUT+1(TVP) - MOVEM B,TD.PUT+1(TVP) - HRRI C,(B) ; BLT pointer - ADD B,(P) - BLT C,-13(B) - SUB P,[1,,1] ; flush stack craft - MOVE E,(TP) - MOVE D,-2(TP) - SUB TP,[4,,4] - -GOODRM: MOVE B,TD.LNT+1(TVP) ; move down to fit new guy - SUB B,[1,,1] ; will always win due to prev checks - MOVEM B,TD.LNT+1(TVP) - HRLI B,1(B) - HLRE A,TD.LNT+1(TVP) - MOVNS A - ADDI A,-1(B) ; A/ final destination - BLT B,-1(A) - POP P,(A) ; new length ins munged in - HLRE A,TD.LNT+1(TVP) - MOVNS A ; A/ offset for other guys - PUSH P,A ; save it - ADD A,TD.GET+1(TVP) ; point for storing uvs of ins - MOVEM D,-1(A) - MOVE A,(P) - ADD A,TD.PUT+1(TVP) - MOVEM E,-1(A) ; store putter also - POP P,A ; compute primtype - ADDI A,NUMSAT - HRLI A,TATOM - MOVE B,(TP) ; ready to mung type vector - SUB TP,[2,,2] - PUSHJ P,INSNT ; insert into vector - JRST MPOPJ - - -; FUNCTIONS TO SET UP EVALUATION AND APPLICATION RULES FOR DATA TYPES - -MFUNCTION EVALTYPE,SUBR - - ENTRY 2 - - PUSHJ P,CHKARG ; VERIFY WINNAGE IN ARGS - MOVEI A,EVATYP ; POINT TO TABLE - MOVEI E,EVTYPE ; POINT TO PURE VERSION -TBLCAL: PUSHJ P,TBLSET ; SETUP TABLE ENTRY - JRST FINIS - -MFUNCTION APPLYTYPE,SUBR - - ENTRY 2 - - PUSHJ P,CHKARG - MOVEI A,APLTYP ; POINT TO APPLY TABLE - MOVEI E,APTYPE ; PURE TABLE - JRST TBLCAL - - -MFUNCTION PRINTTYPE,SUBR - - ENTRY 2 - - PUSHJ P,CHKARG - MOVEI A,PRNTYP ; POINT TO APPLY TABLE - MOVEI E,PRTYPE ; PURE TABLE - JRST TBLCAL - -; CHECK ARGS AND SETUP FOR TABLE HACKER - -CHKARG: GETYP A,(AB) ; 1ST MUST BE TYPE NAME - CAIE A,TATOM - JRST WTYP1 - MOVE B,1(AB) ; GET ATOM - PUSHJ P,TYPLOO ; VERIFY THAT IT IS A TYPE - PUSH P,D ; SAVE TYPE NO. - HRRZ A,(A) ; GET SAT - ANDI A,SATMSK - PUSH P,A - GETYP A,2(AB) ; GET 2D TYPE - CAIE A,TATOM ; EITHER TYPE OR APPLICABLE - JRST TRYAPL ; TRY APPLICABLE - MOVE B,3(AB) ; VERIFY IT IS A TYPE - PUSHJ P,TYPLOO - HRRZ A,(A) ; GET SAT - ANDI A,SATMSK - POP P,C ; RESTORE SAVED SAT - CAIE A,(C) ; SKIP IF A WINNER - JRST TYPDIF ; REPORT ERROR - POP P,C ; GET SAVED TYPE - MOVEI B,0 ; TELL THAT WE ARE A TYPE - POPJ P, - -TRYAPL: PUSHJ P,APLQ ; IS THIS APPLICABLE - JRST NAPT - SUB P,[1,,1] - MOVE B,2(AB) ; RETURN SAME - MOVE D,3(AB) - POP P,C - POPJ P, - - -; HERE TO PUT ENTRY IN APPROPRIATE TABLE - -TBLSET: HRLI A,(A) ; FOR TVP HACKING - ADD A,TVP ; POINT TO TVP SLOT - PUSH TP,B - PUSH TP,D ; SAVE VALUE - PUSH TP,$TVEC - PUSH TP,A - PUSH P,C ; SAVE TYPE BEING HACKED - PUSH P,E - SKIPE B,1(A) ; SKIP IF VECTOR DOESN'T EXIST YET - JRST TBL.OK - HLRE A,TYPBOT+1(TVP) ; GET CURRENT TABLE LNTH - MOVNS A - ASH A,-1 - PUSHJ P,IVECT ; GET VECTOR - MOVE C,(TP) ; POINT TO RETURN POINT - MOVEM B,1(C) ; SAVE VECTOR - -TBL.OK: POP P,E - POP P,C ; RESTORE TYPE - SUB TP,[2,,2] - POP TP,D - POP TP,A - JUMPN A,TBLOK1 ; JUMP IF FUNCTION ETC. SUPPLIED - CAILE D,NUMPRI ; SKIP IF ORIGINAL TYPE - MOVNI E,(D) ; CAUSE E TO ENDUP 0 - ADDI E,(D) ; POINT TO PURE SLOT -TBLOK1: ADDI C,(C) ; POINT TO VECTOR SLOT - ADDI C,(B) - JUMPN A,OK.SET ; OK TO CLOBBER - ADDI B,(D) ; POINT TO TARGET TYPE'S SLOT - ADDI B,(D) ; POINT TO TARGET TYPE'S SLOT - SKIPN A,(B) ; SKIP IF WINNER - SKIPE 1(B) ; SKIP IF LOSER - SKIPA D,1(B) ; SETUP D - JRST CH.PTB ; CHECK PURE TABLE - -OK.SET: MOVEM A,(C) ; STORE - MOVEM D,1(C) - MOVE A,(AB) ; RET TYPE - MOVE B,1(AB) - JRST FINIS - -CH.PTB: MOVEI A,0 - MOVE D,[SETZ NAPT] - JUMPE E,OK.SET - MOVE D,(E) - JRST OK.SET - -CALLTY: MOVE A,TYPVEC(TVP) - MOVE B,TYPVEC+1(TVP) - POPJ P, - -MFUNCTION ALLTYPES,SUBR - - ENTRY 0 - - MOVE A,TYPVEC(TVP) - MOVE B,TYPVEC+1(TVP) - JRST FINIS - -; - -;FUNCTION TO RETURN TYPE OF ELEMENTS IN A UVECTOR - -MFUNCTION UTYPE,SUBR - - ENTRY 1 - - GETYP A,(AB) ;GET U VECTOR - PUSHJ P,SAT - CAIE A,SNWORD - JRST WTYP1 - MOVE B,1(AB) ; GET UVECTOR - PUSHJ P,CUTYPE - JRST FINIS - -CUTYPE: HLRE A,B ;GET -LENGTH - HRRZS B - SUB B,A ;POINT TO TYPE WORD - GETYP A,(B) - JRST ITYPE ; GET NAME OF TYPE - -; FUNCTION TO CHANGE UNIFORM TYPE OF A VECTOR - -MFUNCTION CHUTYPE,SUBR - - ENTRY 2 - - GETYP A,2(AB) ;GET 2D TYPE - CAIE A,TATOM - JRST NOTATO - GETYP A,(AB) ; CALL WITH UVECTOR? - PUSHJ P,SAT - CAIE A,SNWORD - JRST WTYP1 - MOVE A,1(AB) ; GET UV POINTER - MOVE B,3(AB) ;GET ATOM - PUSHJ P,CCHUTY - MOVE A,(AB) ; RETURN UVECTOR - MOVE B,1(AB) - JRST FINIS - -CCHUTY: PUSH TP,$TUVEC - PUSH TP,A - PUSHJ P,TYPLOO ;LOOK IT UP - HRRZ B,(A) ;GET SAT - TRNE B,CHBIT - JRST CANTCH - ANDI B,SATMSK - HLRE C,(TP) ;-LENGTH - HRRZ E,(TP) - SUB E,C ;POINT TO TYPE - GETYP A,(E) ;GET TYPE - JUMPE A,WIN0 ;ALLOW TYPE "LOSE" TO CHANGE TO ANYTHING - PUSHJ P,SAT ;GET SAT - JUMPE A,TYPERR - CAIE A,(B) ;COMPARE - JRST TYPDIF -WIN0: HRLM D,(E) ;CLOBBER NEW ONE - POP TP,B - POP TP,A - POPJ P, - -CANTCH: PUSH TP,$TATOM - PUSH TP,EQUOTE CANT-CHTYPE-INTO - PUSH TP,2(AB) - PUSH TP,3(AB) - MOVEI A,2 - JRST CALER - -NOTATOM: - PUSH TP,$TATOM - PUSH TP,EQUOTE NON-ATOMIC-ARGUMENT - PUSH TP,(AB) - PUSH TP,1(AB) - MOVEI A,2 - JRST CALER - - - -; SUBROUTINE TO LEAVE MUDDLE CLOSING ALL CHANNELS ON THE WAY - -MFUNCTION QUIT,SUBR - - ENTRY 0 - - - PUSHJ P,CLOSAL ; DO THE CLOSES - PUSHJ P,%KILLM - JRST IFALSE ; JUST IN CASE - -CLOSAL: MOVE B,TVP ; POINT TO XFER VECCTOR - ADD B,[CHNL0+2,,CHNL0+2] ; POINT TO 1ST (NOT INCLUDING TTY I/O) - PUSH TP,$TVEC - PUSH TP,B - PUSH P,[N.CHNS-1] ; MAX NO. OF CHANS - -CLOSA1: MOVE B,(TP) - ADD B,[2,,2] - MOVEM B,(TP) - SKIPN C,-1(B) ; THIS ONE OPEN? - JRST CLOSA4 ; NO - CAME C,TTICHN+1(TVP) - CAMN C,TTOCHN+1(TVP) - JRST CLOSA4 - PUSH TP,-2(B) ; PUSH IT - PUSH TP,-1(B) - MCALL 1,FCLOSE ; CLOSE IT -CLOSA4: SOSLE (P) ; COUNT DOWN - JRST CLOSA1 - - - SUB TP,[2,,2] - SUB P,[1,,1] - -CLOSA3: SKIPN B,CHNL0+1(TVP) - POPJ P, - PUSH TP,(B) - HLLZS (TP) - PUSH TP,1(B) - HRRZ B,(B) - MOVEM B,CHNL0+1(TVP) - MCALL 1,FCLOSE - JRST CLOSA3 - -; LITTLE ROUTINES USED ALL OVER THE PLACE - -CRLF: MOVEI A,15 - PUSHJ P,MTYO - MOVEI A,12 - JRST MTYO -MSGTYP: HRLI B,440700 ;MAKE BYTE POINTER -MSGTY1: ILDB A,B ;GET NEXT CHARACTER - JUMPE A,CPOPJ ;NULL ENDS STRING - CAIE A,177 ; DONT PRINT RUBOUTS - PUSHJ P,MTYO" - JRST MSGTY1 ;AND GET NEXT CHARACTER -CPOPJ: POPJ P, - -IMPURE - -WHOAMI: 0 ; SYAYS WHETHER I AM REALLY A MUDDLE OR SOME HACK - - -;GARBAGE COLLECTORS PDLS - - -GCPDL: -GCPLNT,,GCPDL - - BLOCK GCPLNT - - -PURE - -MUDSTR: ASCII /MUDDLE / -STRNG: -1 - -1 - -1 - ASCIZ / IN OPERATION./ - -;MARKED PDLS FOR GC PROCESS - -VECTGO -; DUMMY FRAME FOR INITIALIZER CALLS - - TENTRY,,LISTEN - 0 - .-3 - 0 - 0 - -ITPLNT,,TPBAS-1 - 0 - -TPBAS: BLOCK ITPLNT+PDLBUF - GENERAL - ITPLNT+2+PDLBUF+7,,0 - - -VECRET - - - - -$TMATO: TATOM,,-1 - - -PATCH: -PAT: BLOCK 100 -PATEND: 0 - -END - -TITLE PURE-PAGE LOADER - -RELOCATABLE - -MAPCH==0 ; channel for MAPing -ELN==3 ; Length of table entry - -.GLOBAL PURVEC,PURTOP,PURBOT,P.TOP,MUDSTR,STRTO6,PLOAD,AGC,GCDOWN -.GLOBAL SQUTOA,IGVAL,IBLOCK,PURCLN,MOVPUR,GETPAG,GCFLG,NOSHUF - -.INSRT MUDDLE > - -SYSQ - -IFE ITS,[ -IF1, .INSRT STENEX > -] - -IFN ITS,[ -PURDIR==SIXBIT /MUD50/ ; directory containing pure pages -OPURDI==SIXBIT /MHILIB/ -OFIXDI==SIXBIT /MHILIB/ -FIXDIR==SIXBIT /MUD50/ -ARC==1 ; flag saying fixups on archive -] -IFN ITS,[ -PGMSK==1777 -PGSHFT==10. -] -IFE ITS,[ -PGMSK==777 -PGSHFT==9. -] - -; This routine taskes a slot offset in register A and -; maps in the associated file. It clobbers all ACs -; It skip returns if it wins. - -PLOAD: PUSH P,A ; save slot offset - ADD A,PURVEC+1(TVP) ; point into pure vector - MOVE B,(A) ; get sixbit of name -IFN ITS,[ - MOVE C,MUDSTR+2 ; get version number - PUSHJ P,CSIXBT ; vers # to six bit - HRRI C,(SIXBIT /SAV/) - MOVSS C - .SUSET [.RSNAM,,0] ; GET CURRENT SNAME TO 0 - .SUSET [.SSNAM,,[PURDIR]] ; get sname for it - MOVE A,[SIXBIT / &DSK/] ; build open block - .OPEN MAPCH,A ; try to open file - JRST FIXITU ; no current version, fix one up - PUSH P,0 ; for compat wit tenex and save old sname - DOTCAL FILLEN,[[1000,,MAPCH],[2000,,A]] - JRST MAPLOS - ADDI A,PGMSK ; in case not even # of pages - ASH A,-PGSHFT ; to pages - PUSH P,A ; save the length -] -IFE ITS,[ - MOVE E,P ; save pdl base - PUSH P,[0] ; slots for building strings - PUSH P,[0] - MOVE A,[440700,,1(E)] - MOVE C,[440600,,B] - MOVEI D,6 - ILDB 0,C - JUMPE 0,.+4 ; violate cardinal ".+ rule" - ADDI 0,40 ; to ASCII - IDPB 0,A - SOJG D,.-4 - - PUSH P,[ASCII / SAV/] - MOVE C,MUDSTR+2 ; get ascii of vers no. - IORI C,1 ; hair to change r.o. to space - MOVE 0,C - ADDI C,1 - ANDCM C,0 ; C has 1st 1 - JFFO C,.+3 - MOVEI 0,0 ; use zer name - JRST ZER... - MOVEI C,(D) - IDIVI C,7 - AND 0,MSKS(C) ; get rid of r.o.s -ZER...: PUSH P,0 - MOVEI B,-1(P) ; point to it - HRLI B,260700 - HRROI D,1(E) ; point to name - MOVEI A,1(P) - - PUSH P,[100000,,] - PUSH P,[377777,,377777] - PUSH P,[-1,,[ASCIZ /DSK/]] - PUSH P,[-1,,[ASCIZ /MUDLIB/]] - PUSH P,D - PUSH P,B - PUSH P,[0] - PUSH P,[0] - PUSH P,[0] - MOVEI B,0 - MOVE D,4(E) ; save final version string - GTJFN - JRST FIXITU - - MOVE B,[440000,,240000] - OPENF - JRST FIXITU - MOVE P,E ; flush crap - PUSH P,A - SIZEF ; get length - JRST MAPLOS - PUSH P,C ; save # of pages - MOVEI A,(C) -] - PUSHJ P,ALOPAG ; get the necessary pages - JRST MAPLS1 - PUSH P,B ; save page number -IFN ITS,[ - MOVN A,-1(P) ; get neg count - MOVSI A,(A) ; build aobjn pointer - HRR A,(P) ; get page to start - MOVE B,A ; save for later - HLLZ 0,A ; page pointer for file - DOTCAL CORBLK,[[1000,,200000],[1000,,-1],A,[1000,,MAPCH],0] - JRST MAPLS3 ; total wipe out - .CLOSE MAPCH, ; no need to have file open anymore -] -IFE ITS,[ - MOVE D,-1(P) ; # of pages to D - HRLI B,400000 ; specify this fork - HRROI E,(B) ; build page aobjn for later - TLC E,-1(D) ; sexy way of doing lh - HRLZ A,-2(P) ; JFN to lh of A - MOVSI C,120000 ; bits for read/execute - - PMAP - ADDI A,1 - ADDI B,1 - SOJG D,.-3 ; map 'em all - MOVE A,-2(P) - CLOSF ; try to close file - JFCL ; ignore failure - MOVE B,E -] - -; now try to smash slot in PURVEC - -PLOAD1: MOVE A,PURVEC+1(TVP) ; get pointer to it - ASH B,PGSHFT ; convert to aobjn pointer to words - MOVE C,-3(P) ; get slot offset - ADDI C,(A) ; point to slot - MOVEM B,1(C) ; clobber it in - ANDI B,-1 ; isolate address of page - HRRZ D,PURVEC(TVP) ; get offset into vector for start of chain - TRNE D,400000 ; skip if not end marker - JRST SCHAIN - HRLI D,A ; set up indexed pointer - ADDI D,1 - HRRZ 0,@D ; get its address - JUMPE 0,SCHAIN ; no chain exists, start one - CAILE 0,(B) ; skip if new one should be first - AOJA D,INLOOP ; jump into the loop - - SUBI D,1 ; undo ADDI -FCLOB: MOVE E,-3(P) ; get offset for this guy - HRRM D,2(C) ; link up - HRRM E,PURVEC(TVP) ; store him away - JRST PLOADD - -SCHAIN: MOVEI D,400000 ; get end of chain indicator - JRST FCLOB ; and clobber it in - -INLOOP: MOVE E,D ; save in case of later link up - HRR D,@D ; point to next table entry - TRNE D,400000 ; 400000 is the end of chain bit - JRST SLFOUN ; found a slot, leave loop - ADDI D,1 ; point to address of progs - HRRZ 0,@D ; get address of block - CAILE 0,(B) ; skip if still haven't fit it in - AOJA D,INLOOP ; back to loop start and point to chain link - SUBI D,1 ; point back to start of slot - -SLFOUN: MOVE 0,-3(P) ; get offset into vector of this guy - HRRM 0,@E ; make previous point to us - HRRM D,2(C) ; link it in - - -PLOADD: AOS -4(P) ; skip return - -MAPLS3: SUB P,[1,,1] ; flush stack crap -MAPLS1: SUB P,[1,,1] -MAPLOS: -IFN ITS,[ - MOVE 0,(P) - .SUSET [.SSNAM,,0] ; restore SNAME -] - SUB P,[2,,2] - POPJ P, - -; Here if no current version exists - -FIXITU: PUSH TP,$TFIX - PUSH TP,0 ; maybe save sname - -IFN ITS,[ - PUSH P,C ; save final name - MOVE C,[SIXBIT /FIXUP/] ; name of fixup file -IFN ,.SUSET [.SSNAM,,[OFIXDI]] -IFN ARC, HRRI A,(SIXBIT /ARC/) - .OPEN MAPCH,A -IFE ARC, JRST MAPLOS -IFN ARC, PUSHJ P,ARCLOS - MOVE 0,[-2,,A] ; prepare to read version and length - PUSH P,B ; save program name - .IOT MAPCH,0 - SKIPGE 0 - FATAL BAD FIXUP FILE - PUSH P,B ; save version number of fixup file - MOVEI A,-2(A) ; length -2 (for vers and length) - PUSHJ P,IBLOCK ; get a UVECTOR for the fixups - PUSH TP,$TUVEC ; and save - PUSH TP,B - MOVE A,B - MOVSI 0,TUVEC - MOVEM 0,ASTO(PVP) ; prepare for moby iot (interruptable) - ENABLE - .IOT MAPCH,A ; get fixups - DISABLE - .CLOSE MAPCH, - SETZM ASTO(PVP) - POP P,A ; restore version number - IDIVI A,100. ; get 100s digit in a rest in B - ADDI A,20 ; convert to sixbit - IDIVI B,10. ; B tens digit C 1s digit - ADDI B,20 - ADDI C,20 - MOVE 0,[220600,,D] - MOVSI D,(SIXBIT /SAV/) - CAIE A,20 - IDPB A,0 - CAIE B,20 - IDPB B,0 - IDPB C,0 - MOVE B,[SIXBIT / &DSK/] - MOVE C,(P) ; program name -IFN ,.SUSET [.SSNAM,,[OPURDI]] - .OPEN MAPCH,B ; try for this one - JRST MAPLS1 - DOTCAL FILLEN,[[1000,,MAPCH],[2000,,A]] - JRST MAPLS1 - ADDI A,PGMSK ; in case not exact pages - ASH A,-PGSHFT ; to pages - PUSH P,A ; save - PUSHJ P,ALOPAG ; find some pages - JRST MAPLS4 - MOVN A,(P) ; build aobjn pointer - MOVSI A,(A) - HRRI A,(B) - MOVE B,A - HLLZ 0,B - DOTCAL CORBLK,[[1000,,104000],[1000,,-1],A,[1000,,MAPCH],0] - JRST MAPLS4 - SUB P,[1,,1] - .CLOSE MAPCH, -] -IFE ITS,[ - PUSH TP,$TPDL ; save stack pointer - PUSH TP,E - PUSH P,D ; save vers string - HRROI A,[ASCIZ /FIXUP/] - MOVEM A,10.(E) ; into name slot - MOVEI A,5(E) ; point to arg block - SETZB B,C - GTJFN - JRST MAPLS4 - MOVEI C,(A) ; save JFN in case OPNEF loses - MOVE B,[440000,,200000] - OPENF - JRST MAPLS4 - BIN ; length of fixups to B - PUSH P,A ; save JFN - MOVEI A,-2(B) ; length of uvextor to get - PUSHJ P,IBLOCK - PUSH TP,$TUVEC - PUSH TP,B ; sav it - POP P,A ; restore JFN - BIN ; read in vers # - MOVE D,B ; save vers # - MOVE B,(TP) - HLRE C,B - HRLI B,444400 - SIN ; read in entire fixups - CLOSF ; and close file of same - JFCL ; ignore cailure to close - HRROI C,1(E) ; point to name - MOVEM C,9.(E) - MOVEI C,3(E) - HRLI C,260700 - MOVEM C,10.(E) - MOVE 0,[ASCII / /] - MOVEM 0,4(E) ; all spaces - MOVEI A,(D) - IDIVI A,100. ; to ascii - ADDI A,60 - IDIVI B,10. - ADDI B,60 - ADDI C,60 - MOVE 0,[440700,,4(E)] - CAIE A,60 - IDPB A,0 - CAIE B,60 - IDPB B,0 - IDPB C,0 - SETZB C,B - MOVEI A,5(E) ; ready for 'nother GTJFN - GTJFN - JRST MAPLS5 - MOVEI C,(A) ; save JFN in case OPENF loses - MOVE B,[440000,,240000] - OPENF - JRST MAPLS5 - SIZEF - JRST MAPLS5 - PUSH P,A - PUSH P,C - MOVEI A,(C) - PUSHJ P,ALOPAG ; get the pages - JRST MAPLS5 - MOVEI D,(B) ; save pointer - MOVN A,(P) ; build page aobjn pntr - HRLI D,(A) - EXCH D,(P) ; get length - HRLI B,400000 - - HRLZ A,-1(P) ; JFN for PMAP - MOVSI C,120400 ; bits for read/execute/copy-on-write - - PMAP - ADDI A,1 - ADDI B,1 - SOJG D,.-3 - - HLRZS A - CLOSF - JFCL - POP P,B ; restore page # - SUB P,[1,,1] -] -; now to do fixups - - MOVE A,(TP) ; pointer to them - ASH B,PGSHFT ; aobjn to program - -FIX1: SKIPL E,(A) ; read one hopefully squoze - FATAL ATTEMPT TO TYPE FIX PURE - TLZ E,740000 - PUSHJ P,SQUTOA ; look it up - FATAL BAD FIXUPS - - AOBJP A,FIX2 - HLRZ D,(A) ; get old value - SUBM E,D ; D is diff between old and new - HRLM E,(A) ; fixup the fixups - MOVEI 0,0 ; flag for which half -FIX4: JUMPE 0,FIXRH ; jump if getting rh - MOVEI 0,0 ; next time will get rh - AOBJP A,FIX2 ; done? - HLRZ C,(A) ; get lh - JUMPE C,FIX3 ; 0 terminates -FIX5: ADDI C,(B) ; access the code - ADDM D,-1(C) ; and fix it up - JRST FIX4 - -FIXRH: MOVEI 0,1 ; change flag - HRRZ C,(A) ; get it and - JUMPN C,FIX5 - -FIX3: AOBJN A,FIX1 ; do next one - -FIX2: -IFN ITS,[ -IFN .SUSET [.SSNAM,,[PURDIR]] - .OPEN MAPCH,[SIXBIT / 'DSK_PURE_>/] - JRST MAPLS1 - MOVE E,B ; save pointer - ASH E,-PGSHFT ; to page AOBJN - .IOT MAPCH,B ; write out the goodie - SETZB 0,A - MOVEI B,MAPCH - MOVE C,(P) - MOVE D,-1(P) - .FDELE 0 ; attempt to rename to right thing - JRST MAPLS1 - .CLOSE MAPCH, - MOVE B,[SIXBIT / &DSK/] - .OPEN MAPCH,B - FATAL WHERE DID THE FILE GO? - HLLZ 0,E ; pointer to file pages - PUSH P,E ; SAVE FOR END - DOTCAL CORBLK,[[1000,,200000],[1000,,-1],E,[1000,,MAPCH],0] - FATAL LOSSAGE LOSSAGE PAGES LOST - .CLOSE MAPCH, - - SKIPGE MUDSTR+2 ; skip if not experimental - JRST NOFIXO - PUSHJ P,GENVN ; get version number as a number - MOVE E,(TP) -IFN ,.SUSET [.SSNAM,,[FIXDIR]] -IFE ARC, .OPEN MAPCH,[SIXBIT / 'DSK_FIXU_>/] -IFN ARC, .OPEN MAPCH,[SIXBIT / 'ARC_FIXU_>/] -IFE ARC, FATAL CANT WRITE FIXUPS -IFN ARC, PUSHJ P,ARCFAT - HLRE A,E ; get length - MOVNS A - ADDI A,2 ; account for these 2 words - MOVE 0,[-2,,A] ; write version and length - .IOT MAPCH,0 - .IOT MAPCH,E ; out go the fixups - SETZB 0,A - MOVEI B,MAPCH - MOVE C,-1(P) - MOVE D,[SIXBIT /FIXUP/] - .FDELE 0 - FATAL FIXUP WRITE OUT FAILED - .CLOSE MAPCH, -NOFIXO: -] -IFE ITS,[ - MOVE E,-2(TP) ; restore P-stack base - MOVEI 0,600000 ; fixup args to GTJFN - HRLM 0,5(E) - MOVE D,B ; save page number - POP P,4(E) ; current version name in - MOVEI A,5(E) ; pointer ro arg block - MOVEI B,0 - GTJFN - FATAL MAP FIXUP LOSSAGE - MOVE B,[440000,,100000] - OPENF - FATAL MAP FIXUP LOSSAGE - MOVEI B,(D) ; ready to write it out - HRLI B,444400 - HLRE C,D - SOUT ; zap it out - TLO A,400000 ; dont recycle the JFN - CLOSF - JFCL - ANDI A,-1 ; kill sign bit - MOVE B,[440000,,240000] - OPENF - FATAL MAP FIXUP LOSSAGE - MOVE B,D - ASH B,-PGSHFT ; aobjn to pages - PUSH P,B - HLRE D,B ; -count - HRLI B,400000 - MOVSI A,(A) - MOVSI C,120000 - - PMAP - ADDI A,1 - ADDI B,1 - AOJL D,.-3 - - HLRZS A - CLOSF - JFCL - - HRROI 0,[ASCIZ /FIXUP/] ; now write out new fixup file - MOVEM 0,10.(E) - MOVEI A,5(E) - MOVEI B,0 - - SKIPGE MUDSTR+2 - JRST NOFIXO ; exp vers, dont write out - - PUSHJ P,GENVN - MOVEI D,(B) ; save vers in D - GTJFN - FATAL MAP FIXUP LOSSAGE - MOVE B,[440000,,100000] - OPENF - FATAL MAP FIXUP LOSSAGE - HLRE B,(TP) ; length of fixup vector - MOVNS B - ADDI B,2 ; for length and version words - BOUT - MOVE B,D ; and vers # - BOUT - MOVSI B,444400 ; byte pointer to fixups - HRR B,(TP) - HLRE C,(TP) - SOUT - CLOSF - JFCL -NOFIXO: MOVE A,(P) ; save aobjn to pages - MOVE P,-2(TP) - SUB TP,[2,,2] - PUSH P,A -] - HRRZ A,(P) ; get page # - HLRE C,(P) ; and # of same - MOVE B,(P) ; set B up for return - MOVNS C -IFN ITS,[ - SUB P,[2,,2] - MOVE 0,-2(TP) ; saved sname - MOVEM 0,(P) -] - PUSH P,C - PUSH P,A - SUB TP,[4,,4] - JRST PLOAD1 - -IFN ITS,[ -MAPLS4: .CLOSE MAPCH, - SUB P,[1,,1] - JRST MAPLS1 -] -IFE ITS,[ -MAPLS4: SKIPA A,[4,,4] -MAPLS5: MOVE A,[6,,6] - MOVE P,E - SUB TP,A - SKIPE A,C - CLOSF - JFCL - JRST MAPLOS -] - -IFN ITS,[ -IFN ARC,[ -ARCLOS: PUSHJ P,CKLOCK - JRST MAPLS1 - -ARCRTR: SOS (P) - SOS (P) - POPJ P, - -ARCFAT: PUSHJ P,CKLOCK - FATAL CANT WRITE FIXUP FILE - JRST ARCRTR - -CKLOCK: PUSH P,0 - .STATUS MAPCH,0 - LDB 0,[220600,,0] - CAIN 0,23 ; file locked? - JRST WAIT ; wait and retry - POP P,0 - POPJ P, - -WAIT: MOVEI 0,1 - .SLEEP 0, - POP P,0 - AOS (P) - POPJ P, -] -] - -; Here to try to get a free page block for new thing -; A/ # of pages to get - -ALOPAG: PUSHJ P,GETPAG ; try to get enough pages - POPJ P, - AOS (P) ; won skip return - MOVEI 0,(B) ; update PURBOT/PURTOP to reflect current state - ASH 0,PGSHFT - MOVEM 0,PURBOT - POPJ P, - -GETPAG: MOVE C,P.TOP ; top of GC space - ASH C,-PGSHFT ; to page number - MOVE B,PURBOT ; current bottom of pure space - ASH B,-PGSHFT ; also to pages - SUBM B,C ; pages available ==> C - CAIGE C,(A) ; skip if have enough already - JRST GETPG1 ; no, try to shuffle around - SUBI B,(A) ; B/ first new page - AOS (P) - POPJ P, ; return with new free page in B - -; Here if shuffle must occur or gc must be done to make room - -GETPG1: MOVEI 0,0 - SKIPE NOSHUF ; if can't shuffle, then ask gc - JRST ASKAGC - MOVE 0,PURTOP ; get top of mapped pure area - SUB 0,P.TOP ; total free words to 0 - ASH 0,-PGSHFT ; to pages - CAIGE 0,(A) ; skip if winnage possible - JRST ASKAGC ; please AGC give me some room!! - SUBM A,C ; C/ amount we must flush to make room - -; Here to find pages for flush using LRU algorithm - -GL1: MOVE B,PURVEC+1(TVP) ; get pointer to pure sr vector - MOVEI 0,-1 ; get very large age - -GL2: SKIPN 1(B) ; skip if not already flushed - JRST GL3 - HLRZ D,2(B) ; get this ones age - CAMLE D,0 ; skip if this is a candidate - JRST GL3 - MOVE E,B ; point to table entry with E - MOVEI 0,(D) ; and use as current best -GL3: ADD B,[ELN,,ELN] ; look at next - JUMPL B,GL2 - - HLRE B,1(E) ; get length of flushee - ASH B,-PGSHFT ; to negative # of pages - ADD C,B ; update amount needed - SETZM 1(E) ; indicate it will be gone - JUMPG C,GL1 ; jump if more to get - -; Now compact pure space - - PUSH P,A ; need all acs - SETZB E,A - HRRZ D,PURVEC(TVP) ; point to first in core addr order - HRRZ C,PURTOP ; get destination page - ASH C,-PGSHFT ; to page number - -CL1: ADD D,PURVEC+1(TVP) ; to real pointer - SKIPE 1(D) ; skip if this one is a flushee - JRST CL2 - - HRRZ D,2(D) ; point to next one in chain - JUMPN E,CL3 ; jump if not first one - HRRM D,PURVEC(TVP) ; and use its next as first - JRST CL4 - -CL3: HRRM D,2(E) ; link up - JRST CL4 - -; Found a stayer, move it if necessary - -CL2: MOVEI E,(D) ; another pointer to slot - HLRE B,1(D) ; - length of block - HRRZ D,1(D) ; pointer to block - SUB D,B ; point to top of block - ASH D,-PGSHFT ; to page number - CAIN D,(C) ; if not moving, jump - JRST CL6 - - ASH B,-PGSHFT ; to pages -IFN ITS,[ -CL5: SUBI C,1 ; move to pointer and from pointer - SUBI D,1 - DOTCAL CORBLK,[[1000,,200000],[1000,,-1],C,[1000,,-1],D] - FATAL PURE SHUFFLE LOSSAGE - AOJL B,CL5 ; count down -] -IFE ITS,[ - PUSH P,B ; save # of pages - MOVEI A,-1(D) ; copy from pointer - HRLI A,400000 ; get this fork code - RMAP ; get a JFN (hopefully) - EXCH D,(P) ; D # of pages (save from) - ADDM D,(P) ; update from - MOVEI B,-1(C) ; to pointer in B - HRLI B,400000 - MOVSI C,120000 ; read/execute modes - - PMAP ; move a page - SUBI A,1 - SUBI B,1 - AOJL D,.-3 ; move them all - - MOVEI C,1(B) - POP P,D - ADDI D,1 -] -; Update the table address for this loser - - SUBM C,D ; compute offset (in pages) - ASH D,PGSHFT ; to words - ADDM D,1(E) ; update it -CL7: HRRZ D,2(E) ; chain on -CL4: TRNN D,400000 ; skip if end of chain - JRST CL1 - - ASH C,PGSHFT ; to words - MOVEM C,PURBOT ; reset pur bottom - POP P,A - JRST GETPAG - -CL6: HRRZ C,1(E) ; get new top of world - ASH C,-PGSHFT ; to page # - JRST CL7 - -; SUBR to create an entry in the vector for one of these guys - -MFUNCTION PCODE,SUBR - - ENTRY 2 - - GETYP 0,(AB) ; check 1st arg is string - CAIE 0,TCHSTR - JRST WTYP1 - GETYP 0,2(AB) ; second must be fix - CAIE 0,TFIX - JRST WTYP2 - - MOVE A,(AB) ; convert name of program to sixbit - MOVE B,1(AB) - PUSHJ P,STRTO6 -PCODE4: MOVE C,(P) ; get name in sixbit - -; Now look for either this one or an empty slot - - MOVEI E,0 - MOVE B,PURVEC+1(TVP) - -PCODE2: CAMN C,(B) ; skip if this is not it - JRST PCODE1 ; found it, drop out of loop - JUMPN E,.+3 ; dont record another empty if have one - SKIPN (B) ; skip if slot filled - MOVE E,B ; remember pointer - ADD B,[ELN,,ELN] - JUMPL B,PCODE2 ; jump if more to look at - - JUMPE E,PCODE3 ; if E=0, error no room - MOVEM C,(E) ; else stash away name and zero rest - SETZM 1(E) - SETZM 2(E) - JRST .+2 - -PCODE1: MOVE E,B ; build ,, - MOVEI 0,0 ; flag whether new slot - SKIPE 1(E) ; skip if mapped already - MOVEI 0,1 - MOVE B,3(AB) - HLRE D,E - HLRE E,PURVEC+1(TVP) - SUB D,E - HRLI B,(D) - MOVSI A,TPCODE - SKIPN NOSHUF ; skip if not shuffling - JRST FINIS - JUMPN 0,FINIS ; jump if winner - PUSH TP,A - PUSH TP,B - HLRZ A,B - PUSHJ P,PLOAD - JRST PCOERR - POP TP,B - POP TP,A - JRST FINIS - -PCOERR: PUSH TP,$TATOM - PUSH TP,EQUOTE PURE-LOAD-FAILURE - JRST CALER1 - - -PCODE3: HLRE A,PURVEC+1(TVP) ; get current length - MOVNS A - ADDI A,10*ELN ; add 10(8) more entry slots - PUSHJ P,IBLOCK - EXCH B,PURVEC+1(TVP) ; store new one and get old - HLRE A,B ; -old length to A - MOVSI B,(B) ; start making BLT pointer - HRR B,PURVEC+1(TVP) - SUBM B,A ; final dest to A - BLT B,-1(A) - JRST PCODE4 - -; Here if must try to GC for some more core - -ASKAGC: SKIPE GCFLG ; if already in GC, lose - POPJ P, - SUBM A,0 ; amount required to 0 - ASH 0,PGSHFT ; TO WORDS - MOVEM 0,GCDOWN ; pass as funny arg to AGC - EXCH A,C ; save A from gc's destruction -IFN ITS, .IOPUSH MAPCH, ; gc uses same channel - PUSH P,C - MOVE C,[8,,9.] ; SET UP INDICATORS FOR GC - PUSHJ P,AGC - POP P,C -IFN ITS, .IOPOP MAPCH, - EXCH C,A - JUMPGE C,GETPAG - PUSH TP,$TATOM - PUSH TP,EQUOTE NO-MORE-PAGES - AOJA TB,CALER1 - -; Here to clean up pure space by flushing all shared stuff - -PURCLN: SKIPE NOSHUF - POPJ P, - MOVEI B,400000 - HRRM B,PURVEC(TVP) ; flush chain pointer - MOVE B,PURVEC+1(TVP) ; get pointer to table - SETZM 1(B) ; zero pointer entry - SETZM 2(B) ; zero link and age slots - ADD B,[ELN,,ELN] ; go to next slot - JUMPL B,.-3 ; do til exhausted - MOVE B,PURBOT ; now return pages - SUB B,PURTOP ; compute page AOBJN pointer - JUMPE B,CPOPJ ; no pure pages? - MOVSI B,(B) - HRR B,PURBOT - ASH B,-PGSHFT -IFN ITS,[ - DOTCAL CORBLK,[[1000,,0],[1000,,-1],B] - FATAL SYSTEM WONT TAKE CORE BACK? -] -IFE ITS,[ - HLRE D,B ; - # of pges to flush - HRLI B,400000 ; specify hacking hom fork - MOVNI A,1 - - PMAP - ADDI B,1 - AOJL D,.-2 -] - MOVE B,PURTOP ; now fix up pointers - MOVEM B,PURBOT ; to indicate no pure -CPOPJ: POPJ P, - -; Here to move the entire pure space. -; A/ # and direction of pages to move (+ ==> up) - -MOVPUR: SKIPE NOSHUF - FATAL CANT MOVE PURE SPACE AROUND - IFE ITS [ASH A,1] - SKIPN B,A ; zero movement, ignore call - POPJ P, - - ASH B,PGSHFT ; convert to words for pointer update - MOVE C,PURVEC+1(TVP) ; loop through updating non-zero entries - SKIPE 1(C) - ADDM B,1(C) - ADD C,[ELN,,ELN] - JUMPL C,.-3 - - MOVE C,PURTOP ; found pages at top and bottom of pure - ASH C,-PGSHFT - MOVE D,PURBOT - ASH D,-PGSHFT - ADDM B,PURTOP ; update to new boundaries - ADDM B,PURBOT - CAIN C,(D) ; differ? - POPJ P, - JUMPG A,PUP ; if moving up, go do separate CORBLKs - -IFN ITS,[ - SUBM D,C ; -size of area to C (in pages) - MOVEI E,(D) ; build pointer to bottom of destination - ADD E,A - HRLI E,(C) - HRLI D,(C) - DOTCAL CORBLK,[[1000,,200000],[1000,,-1],E,[1000,,-1],D] - FATAL CANT MOVE PURE - POPJ P, - -PUP: SUBM C,D ; pages to move to D - ADDI A,(C) ; point to new top - -PUPL: SUBI C,1 - SUBI A,1 - DOTCAL CORBLK,[[1000,,200000],[1000,,-1],A,[1000,,-1],C] - FATAL CANT MOVE PURE - SOJG D,PUPL - POPJ P, -] -IFE ITS,[ - SUBM D,C ; pages to move to D - MOVSI E,(C) ; build aobjn pointer - HRRI E,(D) ; point to lowest - ADD D,A ; D==> new lowest page -PURCL1: MOVSI A,400000 ; specify here - HRRI A,(E) ; get a page - RMAP ; get a real handle on it - MOVE B,D ; where to go - HRLI B,400000 - MOVSI C,120000 - PMAP - ADDI D,1 - AOBJN E,PURCL1 - POPJ P, - -PUP: SUB D,C ; - count to D - MOVSI E,(D) ; start building AOBJN - HRRI E,(C) ; aobjn to top - ADD C,A ; C==> new top - MOVE D,C - -PUPL: MOVSI A,400000 - HRRI A,(E) - RMAP ; get real handle - MOVE B,D - HRLI B,400000 - MOVSI C,120000 - PMAP - SUBI E,2 - SUBI D,1 - AOBJN E,PUPL - - POPJ P, -] -IFN ITS,[ -CSIXBT: MOVEI 0,5 - PUSH P,[440700,,C] - PUSH P,[440600,,D] - MOVEI D,0 -CSXB2: ILDB E,-1(P) - CAIN E,177 - JRST CSXB1 - SUBI E,40 - IDPB E,(P) - SOJG 0,CSXB2 -CSXB1: SUB P,[2,,2] - MOVE C,D - POPJ P, -] -GENVN: MOVE C,[440700,,MUDSTR+2] - MOVEI D,5 - MOVEI B,0 -VNGEN: ILDB 0,C - CAIN 0,177 - POPJ P, - IMULI B,10. - SUBI 0,60 - ADD B,0 - SOJG D,VNGEN - POPJ P, - -IFE ITS,[ -MSKS: 774000,,0 - 777760,,0 - 777777,,700000 - 777777,,777400 - 777777,,777776 -] -END - -TITLE MAPS -- MAP FUNCTIONS FOR MUDDLE - -RELOCATABLE - -.INSRT MUDDLE > - -.GLOBAL TYPSEG,NXTLM,NAPT,APLQ,INCR1,SPECBI,FRMSTK,MAPPLY -.GLOBAL CHFSWP,SSPEC1,ILVAL,CHUNW - -; PSTACK OFFSETS - -INCNT==0 ; INNER LOOP COUNT -LISTNO==-1 ; ARG NUMBER BEING HACKED -ARGCNT==-2 ; FINAL ARG COUNTER -NARGS==-3 ; NUMBER OF STRUCTURES -NTHRST==-4 ; 0=> MAP REST, OTHERWISE MAP FIRST - -; MAP THE "CAR" OF EACH LIST - -MFUNCTION MAPF,SUBR - - PUSH P,. ; PUSH NON-ZERO - JRST MAP1 - -; MAP THE "CDR" OF EACH LIST - -MFUNCTION MAPR,SUBR - - PUSH P,[0] - -MAP1: ENTRY - HLRE C,AB ; HOW MANY ARGS - ASH C,-1 ; TO # OF PAIRS - ADDI C,3 ; AT LEAST 3 - JUMPG C,TFA ; NOT ENOUGH - GETYP A,(AB) ; TYPE OF CONSTRUCTOR - CAIN A,TFALSE ; ANY CONSING NEEDE? - JRST MAP2 ; NO, SKIP CHECK - PUSHJ P,APLQ ; CHECK IF APPLICABLE - JRST NAPT ; NO, ERROR -MAP2: MOVNS C ; POS NO. OF ARGS (-3) - ADDI C,1 ; C/ NOW # OF LISTS... - PUSH P,C ; SAVE IT - PUSH TP,[TATOM,,-1] ; ALL **GFP** INSTRUCTIONS ARE TO DO WITH MAPRET - PUSH TP,MQUOTE LMAP,[LMAP ]INTRUP - PUSHJ P,FRMSTK ; **GFP** - PUSH TP,[0] ; **GFP** - PUSH TP,[0] ; **GFP** - PUSHJ P,SPECBIND ; **GFP** - MOVE C,(P) ; RESTORE COUNT OF ARGS - MOVE A,AB ; COPY ARG POINTER - MOVSI 0,TAB ; CLOBBER A'S TYPE - MOVEM 0,ASTO(PVP) - -ARGLP: INTGO ; STACK MAY OVERFLOW - PUSH TP,4(A) ; SKIP FCNS - PUSH TP,5(A) - ADD A,[2,,2] - SOJG C,ARGLP ; ALL UP ON STACK - -; ALL STRUCTURES ARE ON THE STACK, NOW PUSH THE CONSTRUCTOR - - PUSH TP,(AB) ; CONSTRUCTOR - PUSH TP,1(AB) - SETZM ASTO(PVP) - PUSH P,[-1] ; FUNNY TEMPS - PUSH P,[0] - PUSH P,[0] - -; OUTER LOOP CDRING EACH STRUCTURE - -OUTRLP: SETZM LISTNO(P) ; START AT 0TH LIST - MOVE 0,NARGS(P) ; TOTAL # OF STRUCS - MOVEM 0,INCNT(P) ; AS COUNTER IN INNER LOOP - PUSH TP,2(AB) ; PUSH THE APPLIER - PUSH TP,3(AB) - -; INNER LOOP, CONS UP EACH APPLICATION - -INRLP: INTGO - MOVEI E,2 ; READY TO BUMP LISTNO - ADDB E,LISTNO(P) ; CURRENT STORED AND IN C - ADDI E,(TB)4 ; POINT TO A STRUCTURE - MOVE A,(E) ; PICK IT UP - MOVE B,1(E) ; AND VAL - PUSHJ P,TYPSEG ; SETUP TO REST IT ETC. - SKIPL ARGCNT(P) ; DONT INCR THE 1ST TIME - XCT INCR1(C) ; INCREMENT THE LOSER - MOVE 0,DSTO(PVP) ; UPDATE THE LIST - MOVEM 0,(E) - MOVEM D,1(E) ; CLOBBER AWAY - PUSH TP,DSTO(PVP) ; FOR REST CASE - PUSH TP,D - PUSHJ P,NXTLM ; SKIP IF GOT ONE, ELSE DONT - JRST DONEIT ; FINISHED - SETZM DSTO(PVP) - SKIPN NTHRST(P) ; SKIP IF MAP REST - JRST INRLP1 - MOVEM A,-1(TP) ; IUSE AS ARG - MOVEM B,(TP) -INRLP1: SOSE INCNT(P) ; COUNT ARGS - JRST INRLP ; MORE, GO DO THEM - - -; ALL ARGS PUSHED, APPLY USER FCN - - SKIPGE ARGCNT(P) ; UN NEGATE ARGCNT - SETZM ARGCNT(P) - MOVE A,NARGS(P) ; GET # OF ARGS - ADDI A,1 - ACALL A,MAPPLY ; APPLY THE BAG BITER - - GETYP 0,(AB) ; GET TYPE OF CONSTRUCTOR - CAIN 0,TFALSE ; SKIP IF ONE IS THERE - JRST OUTRL1 - PUSH TP,A - PUSH TP,B - AOS ARGCNT(P) - JRST OUTRLP - -OUTRL1: MOVEM A,-1(TP) ; SAVE PARTIAL VALUE - MOVEM B,(TP) - JRST OUTRLP - -; HERE IF ALL FINISHED - -DONEIT: HRLS C,LISTNO(P) ; HOW MANY DONE - SUB TP,[2,,2] ; FLUSH SAVED VAL - SUB TP,C ; FLUSH TUPLE OF CRUFT -DONEI1: SKIPGE ARGCNT(P) - SETZM ARGCNT(P) ; IN CASE STILL NEGATIVE - SETZM DSTO(PVP) ; UNSCREW - GETYP 0,(AB) ; ANY CONSTRUCTOR - CAIN 0,TFALSE - JRST MFINIS ; NO, LEAVE - AOS D,ARGCNT(P) ; IF NO ARGS - ACALL D,APPLY ; APPLY IT - - JRST FINIS - -; HERE TO FINISH IF CONSTRUCTOR WAS #FALSE () - -MFINIS: POP TP,B - POP TP,A - JRST FINIS - -; **GFP** FROM HERE TO THE END - -MFUNCTION MAPLEAVE,SUBR - - ENTRY - - CAMGE AB,[-3,,0] - JRST TMA - MOVE B,MQUOTE LMAP,[LMAP ]INTRUP - PUSHJ P,ILVAL - GETYP 0,A - CAIE 0,TFRAME ; MAKE SURE WINNER - JRST NOTM - PUSH TP,A - PUSH TP,B - MOVEI B,-1(TP) ; POINT TO FRAME POINTER - PUSHJ P,CHFSWP - PUSHJ P,CHUNW - JUMPL C,MAPL1 ; RET VAL SUPPLIED - MOVSI A,TATOM - MOVE B,MQUOTE T - JRST FINIS - -MAPL1: MOVE A,(C) - MOVE B,1(C) - JRST FINIS - -MFUNCTION MAPSTOP,SUBR - - ENTRY - - PUSH P,[1] - JRST MAPREC - -MFUNCTION MAPRET,SUBR - - ENTRY - - PUSH P,[0] -MAPREC: MOVE B,MQUOTE LMAP,[LMAP ]INTRUP - PUSHJ P,ILVAL ; GET VALUE - GETYP 0,A ; FRAME? - CAIE 0,TFRAME - JRST NOTM - PUSH TP,A - PUSH TP,B - MOVEI B,-1(TP) - POP P,0 ; RET/STOP SWITCH - JUMPN 0,MAPRC1 ; JUMP IF STOP - PUSHJ P,CHFSWP ; CHECK IT OUT (AND MAYBE SWAP) - PUSH P,[NLOCR] - JRST MAPRC2 -MAPRC1: PUSHJ P,CHFSWP - PUSH P,[NLOCR1] -MAPRC2: HRRZ E,SPSAV(B) ; UNBIND BEFORE RETURN - PUSH TP,$TAB - PUSH TP,C - ADDI E,1 ; FUDGE FOR UNBINDER - PUSHJ P,SSPEC1 ; UNBINDER - HLRE D,(TP) ; FIND NUMBER - JUMPE D,MAPRE1 ; SKIP IF NONE TO MOVE - MOVNS E,D ; AND PLUS IT - HRLI E,(E) ; COMPUTE NEW TP - ADD E,TPSAV(B) ; NEW TP - HRRZ C,TPSAV(B) ; GET OLD TOP - MOVEM E,TPSAV(B) - HRL C,(TP) ; AND NEW BOT - ADDI C,1 - BLT C,(E) ; BRING IT ALL DOWN -MAPRE1: ASH D,-1 ; NO OF ARGS - HRRI TB,(B) ; PREPARE TO FINIS - MOVSI A,TFIX - MOVEI B,(D) - POP P,0 ; GET PC TO GO TO - MOVEM 0,PCSAV(TB) - JRST CONTIN ; BACK TO MAPPER - -NLOCR1: TDZA A,A ; ZER SW -NLOCR: MOVEI A,1 - GETYP 0,(AB) ; CHECK IF BUILDING - CAIN 0,TFALSE - JRST FLUSHM ; REMOVE GOODIES - ADDM B,ARGCNT(P) ; BUMP ARG COUNTER -NLOCR2: JUMPE A,DONEI1 - JRST OUTRLP - -FLUSHM: ASH B,1 ; FLUSH GOODIES DROPPED - HRLI B,(B) - SUB TP,B - JRST NLOCR2 - -NOTM: PUSH TP,$TATOM - PUSH TP,EQUOTE NOT-IN-MAP-FUNCTION - JRST CALER1 - -END - ; THE FOLLOWING INFORMATION IS MEANT AS GUIDE TO THE CARE AND FEEDING -; OF MUDDLE. IT ATTEMPTS TO SPECIFY PROGRAMMING CONVENTIONS AND -; SUPPLY SYMBOLS AND MACROS NEEDED BY ALL MODULES IN A MUDDLE. - -; FOR EFFICIENCY THE STANDARD MODE OF RUNNING IS UNINTERRUPTABLE. -; WITH EXPLICIT CHECKS FOR PENDING INTERRUPTS. THE INTGO MACRO -; PERFORMS THE APPROPRIATE CHECK - -; FOR INTERRUPTS TO WORK IN INTERRUPTABLE CODE, IT MUST -; BE ABSOLUTELY PURE. BETWEEN ANY TWO INSTRUCTIONS OF -; INTERRUPTABLE CODE THERE MAY BE AN INTERUPT IN WHICH -; A COMPACTING GARBAGE COLLECTION MAY OCCUR. -; NOTE: A SCRATCH AC MAY CONTAIN POINTERS TO GC SPACE IN -; INTERRUPTABLE CODE OR DURING AN INTGO IF THE TYPE CODE FOR THAT AC'S -; SLOT IN THE PROCESS VECTOR IS SET TO REFLECT ITS CONTENTS. - -; ALL ATOM POINTERS WILL BE REFERRED TO IN ASSEMBLED CODE BY -; MQUOTE -- FOR NORMAL ATOMS -; EQUOTE -- FOR ERROR COMMENT ATOMS - -; FUNCTION CALLS TO INITIAL FUNCTIONS WILL BE CALLED USING THE FOLLOWING: - -; MCALL N, ;SEE MCALL MACRO -; ACALL AC, ; SEE ACALL MACRO - -; UNLESS PNAME IS NOT A VALID MIDAS SYMBOL, IN WHICH CASE ANOTHER INTERNAL -; NAME WILL BE USED - -; WHEN CALLING A SUBR THROUGH AN INDEX OR INDIRECT, THE UUOS GENERATED -; BY THE MACROS SHOULLD BE USED. -; THESE ARE .MCALL AND .ACALL -- EXAMPLE: -; .ACALL A,@(B) - - - - - - ; ORGANIZATION OF CORE STORAGE IN THE MUDDLE SYSTEM (ENVIRONMENT) - -; 20: SPECIAL CODE FOR UUO AND INTERUPTS - -;CODBOT: WORD CONTAINING LOCATION OF BOTTOMMOST WORD OF IMPURE CODE - -; --IMPURE CODE-- - -;CODTOP: WORD CONTAINING LOCATION OFWORD AFTER LAST WORD OF CODE - -;PARBOT: WORD CONTAINING LOCATION OFBOTTOMMOST LIST - -; --PAIRSS-- - -;PARTOP: WORD CONTAINING LOCATION OFWORD AFTER LAST PAIR WORD - -;VECBOT: WORD CONTAINING LOCATION OFFIRST WORD OF VECTORS - -; --VECTORS-- - -;VECTOP: WORD CONTAINING LOCATION OFWORD AFTER TOPMOST VECTOR -; THE WORD BEFORE VECTOP IS THE DOPE FOR THE LAST VECTOR - -; --GC MARK PDL (SOMETIMES NOT THERE)-- - -;CORTOP: TOP OF LOW-SEGMENT/IMPURE CORE - -;600000: START OF PURE CODE (SHARED ALSO) - -; --PURE CODE-- - -; - - - ; BASIC DATA TYPES PRE-DEFINED IN MUDDLE - -; PRIMITIVE DATA TYPES -; IF T IS A DATA TYPE THEN $T=[T,,0] - -; DATA TYPES ARE ASSIGNED BY THE TYPMAK MACRO IN SOME ARBITRARY ORDER - - -;TLOSE ;ILLEGAL TYPE (USED PRIMARILY FOR ERRORS) -;TFIX ;FIXED POINT -;TFLOAT ;FLOATING POINT -;TCHRS ;WORD OF UP TO 5 ASCII CHARACTERS -;TENTRY ; MARKS BEGINNING OF A FRAME ON TP STACK -;TSUBR ;BUILT IN FUNCTION WITH EVALUATED ARGS -;TFSUBR ;BUILT IN FUNCTION WITH UN-EVALUATED ARGS -;TUNBOU ;TYPE GIVEN TO UNBOUND OR UNASSIGNED ATOM -;TBIND ;MARKS BEGINNING OF BINDING BLOCK ON TP STACK -;TILLEG ;POINTER PREVIOUSLY HERE NOW ILLEGAL -;TTIME ;UNIQUE NUMBER (SEE FLOAD) -;TLIST ;POINTER TO LIST ELEMENT -;TFORM ;POINTER TO LIST ELEMENT BUT USED AS AN EXPRESSION -;TSEG ;SAME AS FORM BUT VALUE IS MUST BE STRUCTURED AND IS USED -; ;AS A SEGMENT -;TEXPR ;POINTER TO LIST ELEMENT BUT USED AS AN INTERPRETIVE FUNCTION -;TFUNAR ;LIKE TEXPR BUT HAS PARTIALLY EVALUATED ARGS -;TLOCL ;LOCATIVE TO LIST ELEMENT (SEE AT,IN AND SETLOC) -;TFALSE ;NOT TRUTH -;TDEFER ;POINTER TO REAL VALUE (ONLY APPEARS AS CAR OF LIST) -;TUVEC ;AOBJN POINTER TO UNIFORM VECTOR -;TOBLS ;AOBJN TO UVEC OF LISTS OF ATOMS. USED AS SYMBOL TABLE -;TVEC ;VECTOR (AOBJN POINTER TO GENERALIZED VECTOR) -;TCHAN ;VECTOR OF INFO DESCRIBING AN I/O CHANNEL -;TLOCV ;LOCATIVE TO GENERAL VECTOR (SEE AT,IN AND SETLOC) -;TTVP ;POINTER TO TRANSFER VECTOR -;TBVL ;BEGINS A VECTOR BINDING ON THE TP STACK -;TTAG ;VECTOR OF INFO SPECIFYING A GENERALIZED TAG -;TPVP ;POINTER TO PROCESS VECTOR -;TLOCI ;POINTER TO ATOM VALUE ON STACK (INTERNAL NOT SEEN BY USER) -;TTP ;POINTER TO MAIN MARKED STACK -;TSP ;POINTER TO CURRENT BINDINGS ON STACK -;TLOCS ;LOCATIVE TO STACK (NOT CURRENTLY USED) -;TPP ;POINTER TO PLANNER PDL (NOT CURRENTLY USED) -;TPLD ;POINTER TO P-STACK (UNMARKED) -;TARGS ;POINTER TO AN ARG BLOCK (HAIRY KLUDGE) -;TAB ;SAVED AB (NOT GIVEN TO USER) -;TTB ;SAVED TB (NOT GIVEN TO USER) -;TFRAME ;USER POINTER TO STACK FRAME -;TCHSTR ;BYTE POINTER TO STRING OF CHARS (COUNT ALSO INCLUDED) -;TATOM ;POINTER TO ATOM -;TLOCD ;USER LOCATIVE TO ATOM VALUE -;TBYTE :POINTER TO ARBITRARY BYTE STRING (NOT CURRENTLY USED) -;TENV ;USER POINTER TO FRAME USED AS AN ENVIRONMENT -;TACT ;USER POINTER TO FRAME FOR A NAMED ACTIVATION -;TASOC ;ASSOCIATION TRIPLE -;TLOCU ;LOCATIVE TO UVECTOR ELEMENT (SEE AT,IN AND SETLOC) -;TLOCS ;LOCATIVE TO A BYTE IN A CHAR STRING (SEE AT,IN AND SETLOC) -;TLOCA ;LOCATIVE TO ELEMENT IN ARG BLOCK -;TENTS ;NOT USED -;TBS ; "" -;TPLDS ; "" -;TPC ; "" -;TINFO ;POINTER TO LIST ELEMENT USED WITH ARG POINTERS -;TNBS ;NOT USED -;TBVLS ;NOT USED -;TCSUBR ;CARE SUBR (USED ONLY WITH CUDDLE SEE -- WJL) -;TWORD ;36-BIT WORD -;TRSUBR ;COMPILED PROGRAM (ACTUALLY A VECTOR POINTER) -;TCODE ;UNIFORM VECTOR OF INSTRUCTIONS -;TCLIST ;NOT USED -;TBITS ;GENERAL BYTE POINTER -;TSTORA ;POINTER TO NON GC IMPURE STUFF -;TPICTU ;E&S CODE IN NON GC SPACE -;TSKIP ;ENVIRONMENT SPLICE -;TLINK ;LEXICAL LINK -;TINTH ;INTERRUPT HEADER -;THAND ;INTERRUPT HANDLER -;TLOCN ;LOCATIVE TO ASSOCIATION -;TDECL ;POINTER TO LIST OF ATOMS AND TYPE DECLARATIONS -;TDISMI ;TYPE MEANING DONT RUN REST OF HANDLERS -;TDCLI ; INTERNAL TYPE FOR SAVED FUNCTION BODY -;TMENT ; POINTER TO MAIN ENTRY OF WHICH THIS IS PART -;TENTER ; NON-MAIN ENTRY TO AN RSUBR -;TSPLICE ; RETURN FROM READ MACRO MEANS SPLICE SUBELEMENTS IN -;TPCODE ; PURE CODE POINTER IN FUNNY FORMAT -;TTYPEW : TYPE WORD -;TTYPEC ; TYPE CODE -;TGATOM ; ATOM WITH GVALUE -;TREADA ; READ ACTIVATION HACK -;TUNWIN ; INTERNAL FOR UNWIND SPEC ON STACK -;TUBIND ; BINDING OF UNSPECIAL ATOM -;TMACRO ; EVAL MACRO - -; STORGE ALLOCATION TYPES. ALLOCATED BY AN "IRP" LATER IN THIS FILE - - -;S1WORD ;UNMARKED STUFF OF NO INTEREST TO AGC -;S2WORD ;POINTERS TO ELEMENTS IN PAIR SPACE (LIST, FORM, EXPR ETC.) -;S2DEFR ;DEFERRED LIST VALUES -;SNWORD ;POINTERS TO UNIFORM VECTORS -;S2NWOR ;POINTERS TO GENERAL VECTORS -;STPSTK ;STACK POINTERS -;SPSTK ;UNMARKED STACK POINTERS -;SARGS ;POINTERS TO ARG BLOCKS (USER) -;SABASE ;POINTER TO ARG BLOCK (INTERNAL) -;STBASE ;POINTER TO FRAME (INTERNAL) -;SFRAME ;POINTER TO FRAME (USER) -;SBYTE ;GENERAL BYTE POINTER -;SATOM ;POINTER TO ATOM -;SLOCID ;POINTER TO VALUE CELL OF ATOM -;SPVP ;PROCESS VECTORS -;SCHSTR ;ASCII BYTE POINTER -;SASOC ;POINTER TO ASSOCIATION BLOCK -;SINFO ;LIST CELL CONTAINING EXTRA ARGBLOCK INFO -;SSTORE ;NON GC STORGAGE POINTER -;SLOCA ;ARG BLOCK LOCATIVE -;SLOCD ;USER VALUE CELL LOCATIVE -;SLOCS ;LOCATIVE TO STRING -;SLOCU ;LOCATIVE TO UVECTOR -;SLOCV ;LOCATIVE TO GENERAL VECTOR -;SLOCL ;LOCATIVE TO LIST ELEENT -;SLOCN ;LOCATIVE TO ASSOCIATION -;SGATOM ;REALLY ATOM BUT SPECIAL GC HACK - -;NOTE: TO FIND OUT IF A GIVEN STORAGE ALLOCATION TYPE NEEDS TO BE DEFERRED, REFER TO -;LOCATION "MKTBS:" OFFSET BY THE STORAGE TYPE. IF IT IS <0, THAT SAT NEEDS TO BE DEFERRED. -; -;ONE WAY TO DO THIS IS TO PUT A REAL TYPE CODE IN AC A AND PUHSJ P,NWORDT -; A WILL CONTAIN 1 IF NO DEFERRED NEEDED OR 2 IF DEFER IS NEEDED - - ; SOME MUDDLE DATA FORMATS - -; FORMAT OF LIST ELEMENT - -; WORD 1: SIGN BIT, RESERVED FOR GARBAGE COLLECTOR -; BITS 1-17 TYPE OF FIRST ELEMENT OF LIST -; BITS 18-35 POINTS TO REST OF LIST (ALWAYS ANOTHER LIST OR 0) -; -; WORD 2: DATUM OF FIRST ELEMENT OF LIST OF TYPE SPECIFIED -; -; IF DATUM REQUIRES 54 BITS TO SPECIFY, TYPE WILL BE "TDEFER" AND -; VALUE WILL BE AN 18 BIT POINTER TO FULL 2 WORD PAIR - - - -;FORMAT OF GENERAL VECTOR (OF N ELEMENTS) -;POINTED INTO BY AOBJN POINTER -;A GENERAL VECTOR HAS FEWER THAN 2^16 ELEMENTS - - -; TYPE<1> TYPE OF FIRST OBJECT (THE RIGHT HALF OF THE TYPE WORD MIGHT BE NONZERO) -; OBJ<1> OBJECT OF SPECIFIED TYPE -; TYPE<2> -; OBJ<2> -; . -; . -; . -; TYPE -; OBJ -; VD(1)-VECTOR DOPE--SIGN-NOT UNIFORM, BITS 1-17 TYPE,,18-35 GROWTH/SHRINKAGE -; VD(2)-VECTOR DOPE--SIGN-G.C.; BITS 1-17 ARE 2*N+1,,18-35 G.C. RELOCATION EITHER UP OR DOWN - - - ;SPECIAL VECTORS IN THE INITIAL SYSTEM - -;THE SYSTEM KEEPS RELEVANT INFORMATION CONCERNING ALL TYPES -;IN A TYPE VECTOR, TYPVEC, WHICH MAY BE INDEXED BY THE TYPE NUMBER -;FOUND IN THE TYPE FIELD OF ANY GOODIE. TABLES APLTYP AND EVLTYP ALSO EXIST -;THEY SPECIFY HOW DIFFERENT TYPES EVAL AND APPLY. - -;TYPE IN AC A, PUSHJ P,SAT RETURNS STORAGE TYPE IN A - -;TYPE TO NAME OF TYPE TRANSLATION TABLE - -; TATOM,,+CHBIT+TMPLBT - -; ATOMIC NAME - -; CHBIT ON MEANS YOU CANT RANDOMLY CHTYPE INTO THIS TYPE -; TMPLBT ON MEANS A TEMPLATE EXISTS DESCRIBING THIS - -;AN ATOM IS A BLOCK IN VECTOR SPACE WITH THE FOLLOWING FORMAT - -; ,,<0 OR BINDID> ; TLOCI MEANS VAL EXISTS. - ; 0 MEANS GLOBAL -; ; BINDID SPECS ENV IN - ; WHICH LOCAL VAL EXISTS -; -; -; -; <400000+SATOM,,0> -; ,,0 (SIGN BIT FOR G.C. RH FOR G.C. RELOCATION) - -;POINTERS TO INITIAL STRUCTURES AND ATOMS NEEDED BY COMPILED CODE -;WILL BE POINTED TO BY THE TRANSFER VECTOR -;A POINTER TO THIS VECTOR ALWAYS EXISTS IN AC TVP -;THE FORMAT OF THIS VECTOR IS: - -; TYPE,,0 -; VALUE -; . -; . -; . -; TV DOPE WORDS - - -;INFORMATION CONCERNING EACH PROCESS IS KEPT IN THE PROCESS VECTOR -;A POINTER TO THE CURRENT PROCESS ALWAYS EXISTS IN AC PVP -;THE FORMAT OF A PROCESS VECTOR IS: - -; TFIX,,0 -; PROCID ;UNIQUE ID OF THIS PROCESS - -; 20 ELEMENTS (I.E. 40 WORDS) CONTAINIG SAVED ACS -; CAN BE REFERENCED SYMBOLICALLY USING SYMBOLS -; OF THE FORM AC!STO(PVP) - -; OTHER PROCESS LOCAL INFO LIKE LEXICAL STATE, PROCESS STATE,LAST RESUMER -; . -; . -; . -; PV DOPE WORDS - - - - -;FORMAT OF PUSH DOWN STACKS USED AND CONVENTIONS - - IF1 [ -PRINTC /MUDDLE - INSERT FILE FOR ALL PROGRAMS -/ -] - -IF2 [PRINTC /MUDDLE -/ -] -;AC ASSIGNMNETS - -P"=17 ;THE UNMARKED PDL POINTER (USED BY THE OUTSIDE WORLD AND MUDDLE) -R"=16 ;REFERENCE BASE FOR RSUBRS -M"=15 ;CODE BASE FOR RSUBRS -SP"=14 ;SPECIAL PDL (USED BY MUDDLE FOR VARIABLE BINDINGS)(SPECIAL PDL IS PART OF TP) -TP"=13 ;MARKED PDL (USED BY MUDDLE FOR ARGS TO FUNCTIONS - ;AND MARKED TEMPORARIES) -TB"=12 ;MARKED PDL BASE POINTER AND CURRENT FRAME POINTER -AB"=11 ;ARGUMENT PDL BASE (MARKED) - ;AB IS AN AOBJN POINTER TO THE ARGUMENTS -TVP"=7 ;TRANSFER VECTOR POINTER -PVP"=6 ;PROCESS VECTOR POINTER - -;THE FOLLOWING ACS ARE 'SCRATCH' FOR MUDDLE - -A"=1 ; A AND B CONTAIN TYPE AND VALUE UPON FUNCTION RETURNS -B"=2 -C"=3 -D"=4 -E"=5 - -NIL"=0 ;END OF LIST MARKER - -;MACRO TO DEFINE MAIN IF NOT DEFINED - -IF1 [ -DEFINE SYSQ - ITS==1 - IFE <<<.AFNM1>_-24.>->,ITS==0 - IFN ITS,[PRINTC /ITS VERSION -/] - IFE ITS,[PRINTC /TENEX VERSION -/] - - TERMIN - -DEFINE DEFMAI ARG,\D - D==.TYPE ARG - IFE ,ARG==0 - EXPUNGE D - TERMIN -] - -DEFMAI MAIN -DEFMAI READER - -IF2,EXPUNGE DEFMAI - - ;DEFINE TYPES AND $TYPES AND IF MAIN NOT 0, MAKE THE $TYPE WORDS - - -IFN MAIN,NUMPRI==-1 - -IF1 [ -NUMPRI==-1 ;NUMBER OF PRIMITIVE TYPES - -DEFINE TYPMAK SAT,LIST -IRP A,,[LIST] -NUMPRI==NUMPRI+1 -IRP B,,[A] -T!B==NUMPRI -.GLOBAL $!T!B -IFN MAIN,[$!T!B=[T!B,,0] -] -.ISTOP -TERMIN -IFN MAIN,[ -RMT [ADDTYP SAT,A -]] -TERMIN -TERMIN - -;MACRO TO ADD STUFF TO TYPE VECTOR - -IFN MAIN,[ -DEFINE ADDTYP SAT,TYPE,NAME,CHF,\CH - IFSE [CHF],CH==0 - IFSN [CHF],CH==CHBIT - IFSE [NAME]IN,CH==CHBIT - IFSN [CHF]-1,[ - TATOM,,CH+SAT - IFSN [NAME],[IFSE [NAME]IN,MQUOTE INTERNAL - IFSN [NAME]IN,MQUOTE [NAME] - ] - IFSE [NAME],MQUOTE TYPE - ] - IFSE [CHF]-1,[ - TATOM,,CH+SAT - IMQUOTE [NAME] - ] - TERMIN -] -] -IF2 [IFE MAIN,[DEFINE TYPMAK SAT,LIST - RMT [EXPUN [LIST] -] - TERMIN -] -] - -;DEFINE THE STORAGE ALLOCATION TYPES IN THE WORLD - - -NUMSAT==0 -GENERAL==400000,,0 ;FLAG FOR BEING A GENERAL VECTOR - -IF1 [ -DEFINE PRMACR HACKER - -IRP A,,[1WORD,2WORD,2DEFRD,NWORD,2NWORD,TPSTK,PSTK,ARGS -ABASE,TBASE,FRAME,BYTE,ATOM,LOCID,PVP,CHSTR,ASOC,INFO,STORE -LOCA,LOCD,LOCS,LOCU,LOCV,LOCL,LOCN,GATOM,LOCT] - -HACKER A - -TERMIN -TERMIN - - - -DEFINE DEFINR B - NUMSAT==NUMSAT+1 - S!B==NUMSAT - TERMIN -] - -PRMACR DEFINR - -STMPLT==NUMSAT+1 - -;MACRO FOR SAVING STUFF TO DO LATER - -.GSSET 4 - -DEFINE HERE G00002,G00003 -G00002!G00003!TERMIN - -IF1 [ -DEFINE RMT A -HERE [DEFINE HERE G00002,G00003 -G00002!][A!G00003!TERMIN] -TERMIN -] - - -RMT [EXPUNGE GENERAL,NUMSTA -] - -DEFINE XPUNGR A - EXPUNGE S!A - TERMIN - -IFE MAIN,[ -RMT [PRMACR XPUNGR -] -] - -C.BUF==1 -C.PRIN==2 -C.BIN==4 -C.OPN==10 -C.READ==40 - -; FLAG INDICATING VECTOR FOR GCHACK - -.VECT.==40000 - -; DEFINE SYMBLOS FOR VARIOUS OBLISTS - -SYSTEM==0 ;MAIN SYSTEM OBLIST -ERRORS==1 ;ERROR COMMENT OBLIST -INTRUP==2 ;INERRUPT OBLIST -MUDDLE==3 ;MUDDLE GLOBAL SYMBOLS (ADDRESSES) - -RMT [EXPUNGE SYSTEM,ERRORS,INTRUP -] -; DEFINE SYMBOLS FOR PROCESS STATES - -RUNABL==1 -RESMBL==2 -RUNING==3 -DEAD==4 -BLOCKED==5 - -IFE MAIN,[RMT [EXPUNGE RESMBL,RUNABL,RUNING,DEAD,BLOCKED -] -] ;BUILD THE TYPE CODES AND ADD STUFF TO TYPVEC AND DEFINE $!TYPE) - -IFN MAIN,[RMT [SAVE==. - LOC TYPVLC - ] - ] - - -TYPMAK S1WORD,[[LOSE],FIX,FLOAT,[CHRS,CHARACTER],[ENTRY,IN],[SUBR,,1],[FSUBR,,1]] -TYPMAK S1WORD,[[UNBOUND,,1],[BIND,IN],[ILLEGAL,,1],TIME] -TYPMAK S2WORD,[LIST,FORM,[SEG,SEGMENT],[EXPR,FUNCTION],[FUNARG,CLOSURE]] -TYPMAK SLOCL,[LOCL] -TYPMAK S2WORD,[FALSE] -TYPMAK S2DEFRD,[[DEFER,IN]] -TYPMAK SNWORD,[[UVEC,UVECTOR],[OBLS,OBLIST,-1]] -TYPMAK S2NWORD,[[VEC,VECTOR],[CHAN,CHANNEL,1]] -TYPMAK SLOCV,[LOCV] -TYPMAK S2NWORD,[[TVP,IN],[BVL,IN],[TAG,,1]] -TYPMAK SPVP,[[PVP,PROCESS]] -TYPMAK STPSTK,[[LOCI,IN],[TP,IN],[SP,IN],[LOCS,IN]] -TYPMAK S2WORD,[[MACRO]] -TYPMAK SPSTK,[[PDL,IN]] -TYPMAK SARGS,[[ARGS,TUPLE]] -TYPMAK SABASE,[[AB,IN]] -TYPMAK STBASE,[[TB,IN]] -TYPMAK SFRAME,[FRAME] -TYPMAK SCHSTR,[[CHSTR,STRING]] -TYPMAK SATOM,[ATOM] -TYPMAK SLOCID,[LOCD] -TYPMAK SBYTE,[BYTE] -TYPMAK SFRAME,[[ENV,ENVIRONMENT],[ACT,ACTIVATION,1]] -TYPMAK SASOC,[ASOC] -TYPMAK SLOCU,[LOCU] -TYPMAK SLOCS,[LOCS] -TYPMAK SLOCA,[LOCA] -TYPMAK S1WORD,[[CBLK,IN]] -TYPMAK STMPLT,[[TMPLT,TEMPLATE]] -TYPMAK SLOCT,[LOCT] - ;THE FOLLOWING TYPES (THROUGH CSUBR) CAN PROBABLY BE RECYCLED -TYPMAK S1WORD,[[PC,IN]] -TYPMAK SINFO,[[INFO,IN]] -TYPMAK SATOM,[[BNDS,IN]] -TYPMAK S2NWORD,[[BVLS,IN]] -TYPMAK S1WORD,[[CSUBR,,1]] - -TYPMAK S1WORD,[[WORD]] -TYPMAK S2NWORD,[[RSUBR,,1]] -TYPMAK SNWORD,[CODE] - ;TYPE CLIST CAN PROBABLY BE RECYCLED -TYPMAK S2WORD,[[CLIST,IN]] -TYPMAK S1WORD,[[BITS]] -TYPMAK SSTORE,[STORAGE,PICTURE] -TYPMAK STPSTK,[[SKIP,IN]] -TYPMAK SATOM,[[LINK,,1]] -TYPMAK S2NWORD,[[INTH,IHEADER,1],[HAND,HANDLER,1]] -TYPMAK SLOCN,[[LOCN,LOCAS]] -TYPMAK S2WORD,[DECL] -TYPMAK SATOM,[DISMISS] -TYPMAK S2WORD,[[DCLI,IN]] -TYPMAK S2NWORD,[[ENTER,RSUBR-ENTRY,1]] -TYPMAK S2WORD,[SPLICE] -TYPMAK S1WORD,[[PCODE,PCODE,1],[TYPEW,TYPE-W,1],[TYPEC,TYPE-C,1]] -TYPMAK SGATOM,[[GATOM,IN]] -TYPMAK SFRAME,[[READA,,1]] -TYPMAK STBASE,[[UNWIN,IN]] -TYPMAK S1WORD,[[UBIND,IN]] -IFN MAIN,[RMT [LOC SAVE - ] - ] -IF2,EXPUNGE TYPMAK,DOTYPS - -RMT [EQUALS XP EXPUNGE -IF2,XP STMPLT -] -IF1 [ - -DEFINE EXPUN LIST - IRP A,,[LIST] - IRP B,,[A] - EXPUNGE T!B - .ISTOP - TERMIN - TERMIN - TERMIN -] - - -TYPMSK==17777 -MONMSK==TYPMSK#777777 -SATMSK==777 -CHBIT==1000 -TMPLBT==2000 - -IF1 [ -DEFINE GETYP AC,ADR - LDB AC,[221500,,ADR] - TERMIN - -DEFINE GETYPF AC,ADR - LDB AC,[003700,,ADR] - TERMIN - -DEFINE MONITO - .WRMON==200000 - .RDMON==100000 - .EXMON== 40000 - .GLOBAL .MONWR,.MONRD,.MONEX - RMT [IF2 IFE MAIN, XP .WRMON,.RDMON,.EXMON -] - TERMIN -] - -IFN MAIN,MONITO - -IFE MAIN,[RMT [XP SATMSK,TYPMSK,MONMSK,CHBIT -] -] - ;MUDDLE WIDE GLOBALS - -;DEFINE ENTRIES IN PROCESS VECTOR AS BEING GLOBAL - -IF1 [ -IRP A,,[0,A,B,C,D,E,PVP,TVP,TP,TB,AB,P,PB,SP,M,R] -.GLOBAL A!STO -TERMIN - -.GLOBAL CALER1,FINIS,VECTOP,VECBOT,INTFLG - -;GLOBALS FOR MACROS IN VECTOR AND PAIR SPACE - -.GLOBAL VECLOC,PARLOC,TVBASE,TVLOC,PVLOC,PVBASE,SQUTBL,SQULOC -.GLOBAL PARTOP,CODTOP,HITOP,HIBOT,SPECBIND,LCKINT -.GLOBAL GETWNA,WNA,TFA,TMA,WRONGT,WTYP,WTYP1,WTYP2,WTYP3,CALER,CALER1 -] - - -;STORAGE ALLOCATIN SPECIFICATION GLOBALS - -NSUBRS==600. ; ESTIMATE OF # OF SUBRS IN WOLD -TPLNT"==2000 ;TEMP PDL LENGTHH -GSPLNT==2000 ;INITIAL GLOBAL SP -GCPLNT"==100. ;GARBAGE COLLECTOR'S PDL LENGTH -PVLNT"==100 ;LENGTH OF INITIAL PROCESS VECTOR -TVLNT"==6000 ;MAX TRANSFER VECTOR -ITPLNT"==100 ;TP FOR GC -PLNT"==1000 ;PDL FOR USER PROCESS - -;LOCATIONS OF VARIOUS STORAGE AREAS - -PARBASE"==32000 ;START OF PAIR SPACE -VECBASE"==44000 ;START OF VECTOR SPACE -IFN MAIN,[PARLOC"==PARBASE -VECLOC"==VECBASE -] - -;INITIAL MACROS - -;SYMBLOS ASSOCIATED WITH STACK FRAMES -;TB POINTS TO CURRENT FRAME, THE SYMBOLS BELOW ARE OFFSETS ON TB - -FRAMLN==7 ;LENGTH OF A FRAME -FSAV==-7 ;POINT TO CALLED FUNCTION -OTBSAV==-6 ;POINT TO PREVIOUS FRAME AND CONTAINS TIME -ABSAV==-5 ;ARGUMENT POINTER -SPSAV==-4 ;BINDING POINTER -PSAV==-3 ;SAVED P-STACK -TPSAV==-2 ;TOP OF STACK POINTER -PCSAV==-1 ;PCWORD - -RMT [EXPUNGE FRAMLN -] -IFE MAIN,[RMT [EXPUNGE PCSAV TPSAV SPSAV PSAV ABSAV FSAV OTBSAV -] -] - -;CALL MACRO -; ARGS ARE PUSHED ON THE STACK AS TYPE VALUE PAIRS - -.GLOBAL .MCALL,.ACALL,FINIS,CONTIN,.ECALL,FATINS - -; CALL WITH AN ASSEMBLE TIME KNOWN NUMBER OF ARGUMENTS - -IF1 [ -DEFINE MCALL N,F - .GLOBAL F - IFGE <17-N>,.MCALL N,F - IFL <17-N>,[PRINTC /LOSSAGE AT MCALL - TOO MANY ARGS -/ - .MCALL F - ] - TERMIN - -; CALL WITH RUN TIME KNOWN NUMBER OF ARGS IN AC SPECIFIED BY N - -DEFINE ACALL N,F - .GLOBAL F - .ACALL N,F - TERMIN - -; STANDARD SUBROUTINE RETURN - -; JRST FINIS - -; ARGUMENTS WILL NO LONGER BE ON THE STACK WHEN RETURN HAS HAPPENED -; VALUE SHOULD BE IN A AND B - -;CHECK THAT THE ENTRY POINT WAS CALLED WITH N ARGUMENTS - -DEFINE ENTRY N - IFSN N,,[ - HLRZ A,AB - CAIE A,-2*N - JSP E,GETWNA] -TERMIN - - -; MACROS ASSOCIATED WIT INTERRUPT PROCESSING -;INTERRUPT IF THERE IS A WAITING INTERRUPT - -DEFINE INTGO - SKIPGE INTFLG - JSR LCKINT -TERMIN - -;TO BECOME INTERRUPTABLE - -DEFINE ENABLE - AOSN INTFLG - JSR LCKINT -TERMIN - -;TO BECOME UNITERRUPTABLE - -DEFINE DISABLE - SETZM INTFLG -TERMIN -] - IF1 [ -;MACRO TO BUILD TYPE DISPATCH TABLES EASILY - -DEFINE TBLDIS NAME,DEFAULT,LIST,LNTH - -NAME: - REPEAT LNTH+1,DEFAULT - IRP A,,[LIST] - IRP TYPE,LOCN,[A] - LOC NAME+TYPE - LOCN - .ISTOP - TERMIN - TERMIN - LOC NAME+LNTH+1 -TERMIN - -; DISPATCH FOR NUMPRI GOODIES - -DEFINE DISTBL NAME,DEFAULT,LIST - TBLDIS NAME,DEFAULT,[LIST]NUMPRI - TERMIN - -DEFINE DISTBS NAME,DEFAULT,LIST - TBLDIS NAME,DEFAULT,[LIST]NUMSAT - TERMIN - -] - - -VECFLG==0 -PARFLG==0 - -;MACROS FOR INITIIAL MUDDLE LIST STRUCTURE - -;CHAR STRING MAKER, RETURNS POINTER AND TYPE - -IF1 [ -DEFINE MACHAR NAME,TYPE,VAL,\LNT,WHERE,LAST - TYPE==TCHSTR - VECTGO WHERE - LNT==.LENGTH \NAME!\ - ASCII \NAME!\ - LAST==$." - TCHRS,,0 - $."-WHERE+1,,0 - VAL==LNT,,WHERE - VECRET - -TERMIN -;MACRO TO DEFINE ATOMS - -DEFINE MAKAT NAME,TYAT,VALU,OBLIS,REFER,LOCN,\TVENT,FIRST - FIRST==. - TYAT,,OBLIS - VALU - 0 - ASCII \NAME!\ - 400000+SATOM,,0 - .-FIRST+1,,0 - TVENT==FIRST-.+2,,FIRST - IFSN [LOCN],LOCN==TVENT - ADDTV TATOM,TVENT,REFER - TERMIN - - - - ;MACROS TO SWITCH BACK AND FORTH INTO AND OUT OF VECTOR AND PAIR SPACE -;GENERAL SWITCHER - -DEFINE LOCSET LOCN,RETNAM,NEWLOC,OTHLOC,F1,F2,TOPWRD,\SAVE,SAVEF1,SAVEF2,NEW - - IFE F1,[SAVE==. - LOC NEWLOC - SAVEF2==F2 - IFN F2,OTHLOC==SAVE - F2==0 - DEFINE RETNAM - F1==F1-1 - IFE F1,[NEWLOC==. - F2==SAVEF2 - LOC TOPWRD - NEWLOC - LOC SAVE - ] - TERMIN - ] - - IFN F1,[F1==F1+1 - ] - - IFSN LOCN,,LOCN==. - IFE F1,F1==1 - -TERMIN - - -DEFINE VECTGO LOCN - LOCSET LOCN,VECRET,VECLOC,PARLOC,VECFLG,PARFLG,VECTOP - TERMIN - -DEFINE PARGO LOCN - LOCSET LOCN,PARRET,PARLOC,VECLOC,PARFLG,VECFLG,PARTOP - TERMIN - -DEFINE ADDSQU NAME,\SAVE - SAVE==. - LOC SQULOC - SQUOZE 0,NAME - NAME - SQULOC==. - LOC SAVE - TERMIN - -DEFINE ADDTV TYPE,GOODIE,REFER,\SAVE - SAVE==. - LOC TVLOC - TVOFF==.-TVBASE+1 - TYPE,,REFER - GOODIE - TVLOC==. - LOC SAVE - TERMIN - -;MACRO TO ADD TO PROCESS VECTOR - -DEFINE ADDPV TYPE,GOODIE,OFFS,\SAVE - SAVE==. - LOC PVLOC - PVOFF==.-PVBASE - IFSN OFFS,,OFFS==PVOFF - TYPE,,0 - GOODIE - PVLOC==. - LOC SAVE - TERMIN - - - - - -;MACRO TO DEFINE A FUNCTION ATOM - -DEFINE MFUNCTION NAME,TYPE,PNAME - (TVP) -NAME": - VECTGO DUMMY1 - ADDSQU NAME - IFSE [PNAME],MAKAT NAME,T!TYPE,NAME,SYSTEM, - IFSN [PNAME],MAKAT [PNAME]T!TYPE,NAME,SYSTEM, - VECRET - TERMIN - -; VERSION OF MQUOTE WITH IMPURE BIT ON - -DEFINE IMQUOTE ARG,PNAME,OBLIS,\LOCN - (TVP) - - LOCN==.-1 - VECTGO DUMMY1 - IFSE [PNAME],MAKAT [ARG]<400000+TUNBOU>,0,OBLIS,LOCN - - IFSN [PNAME],MAKAT [PNAME]<400000+TUNBOU>,0,OBLIS,LOCN - VECRET - TERMIN - -;MACRO TO DEFINE QUOTED GOODIE - -DEFINE MQUOTE ARG,PNAME,OBLIS,\LOCN - (TVP) - - LOCN==.-1 - VECTGO DUMMY1 - IFSE [PNAME],MAKAT [ARG]TUNBOU,0,OBLIS,LOCN - IFSN [PNAME],MAKAT [PNAME]TUNBOU,0,OBLIS,LOCN - VECRET - TERMIN - - - - -DEFINE CHQUOTE NAME,\LOCN,TYP,VAL - (TVP) - LOCN==.-1 - MACHAR [NAME]TYP,VAL - ADDTV TYP,VAL,LOCN - - TERMIN - - -; SPECIAL ERROR MQUOTE - -DEFINE EQUOTE ARG,PNAME - MQUOTE ARG,[PNAME]ERRORS TERMIN - - -; MACRO DO .CALL UUOS - -DEFINE DOTCAL NM,LIST,\LOCN - .CALL LOCN - RMT [LOCN==. - SETZ - SIXBIT /NM/ - IRP Q,R,[LIST] - IFSN [R][][Q - ] - - IFSE [R][][\ - ] - TERMIN - ] -TERMIN - -; MACRO TO HANDLE FATAL ERRORS - -DEFINE FATAL MSG/ - FATINS [ASCIZ /: FATAL ERROR MSG  -/] - TERMIN -] - -CHRWD==5 - -IFN READER,[ -NCHARS==177 -;CHARACTER TABLE GENERATING MACROS - -DEFINE SETSYM WRDL,BYTL,COD - WRD!WRDL==& - WRD!WRDL==\<_<<4-BYTL>*7+1>> - TERMIN - -DEFINE INIWRD N,INIT - WRD!N==INIT - TERMIN - -DEFINE OUTWRD N - WRD!N - TERMIN - -;MACRO TO KILL THESE SYMBOLS LATER - -DEFINE KILLWD N - EXPUNGE WRD!N - TERMIN -DEFINE SETMSK N - MSK!N==<177_<<4-N>*7+1>>#<-1> - TERMIN - -;MACRO TO KILL MASKS LATER - -DEFINE KILMSK N - EXPUNGE MSK!N - TERMIN - -NWRDS==/CHRWD - -REPEAT CHRWD,SETMSK \.RPCNT - -REPEAT NWRDS,INIWRD \.RPCNT,004020100402 - -DEFINE OUTTBL - REPEAT NWRDS,OUTWRD \.RPCNT - TERMIN - - -;MACRO TO GENERATE THE DUMMIES EASLILIER - -DEFINE INITCH \DUM1,DUM2,DUM3 - - -DEFINE SETCOD COD,LIST - IRP CHAR,,[LIST] - DUM1==CHAR/5 - DUM2==CHAR-DUM1*5 - SETSYM \DUM1,\DUM2,COD - TERMIN - TERMIN - -DEFINE SETCHR COD,LIST - IRPC CHAR,,[LIST] - DUM3=="CHAR - DUM1==DUM3/5 - DUM2==DUM3-DUM1*5 - SETSYM \DUM1,\DUM2,COD - TERMIN - TERMIN - -DEFINE INCRCO OCOD,LIST - IRP CHAR,,[LIST] - DUM1==CHAR/5 - DUM2==CHAR-DUM1*5 - SETSYM \DUM1,\DUM2,\ - TERMIN - TERMIN - -DEFINE INCRCH OCOD,LIST - IRPC CHAR,,[LIST] - DUM3=="CHAR - DUM1==DUM3/5 - DUM2==DUM3-DUM1*5 - SETSYM \DUM1,\DUM2,\ - TERMIN - TERMIN - RMT [EXPUNGE DUM1,DUM2,DUM3 - REPEAT NWRDS,KILLWD \.RPCNT - REPEAT CHRWD,KILMSK \.RPCNT -] - -TERMIN - -INITCH -] - -;REDEFINE END DO ALL THE REMOTES (ON LAST PASS ONLY) - -EQUALS E.END END - -DEFINE END ARG - EQUALS END E.END - CONSTANTS - - IMPURE - VARIABLES - PURE - HERE - .LNKOT - IF2 GEXPUN - CONSTANTS - IMPURE - VARIABLES - CODEND==. - LOC CODTOP - CODEND - LOC CODEND - PURE - CODEND==. - LOC HITOP - CODEND - LOC CODEND - IF2 EXPUNGE PARFLG,VECFLG,CHRWD,NN,NUMPRI,PURITY,EAD,ACD,PUSHED - IF2 EXPUNGE INSTNT,DUMMY1,PRIM,PPLNT,GSPLNT,MEDIAT - END ARG - TERMIN - - -;MACROS TO PRINT VERSIONS OF PROGRAMS DURING ASSEMBLY - -IF1 [ -DEFINE NUMGEN SYM,\REST,N - NN==NN-1 - N==&77 - REST== - IFN N,IFGE <31-N>,IFGE ,TOTAL==TOTAL*10.+ - IFN NN,NUMGEN REST - EXPUNGE N,REST - TERMIN - -DEFINE VERSIO N - PRINTC /VERSION = N -/ - TERMIN -] - -TOTAL==0 -NN==7 - -NUMGEN .FNAM2 - -IF1 [ -RADIX 10. - -VERSIO \TOTAL - -RADIX 8 -PROGVN==TOTAL - - -DEFINE VATOM SYM,\LOCN,TV,A,B - VECTGO - LOCN==. - TFIX,,MUDDLE - PROGVN - 0 - A==<<<&77>+40>_29.> - B==<&77> - IFN B,A==A+<_22.> - B==<&77> - IFN B,A==A+<_15.> - B==<&77> - IFN B,A==A+<_8.> - B==<&77> - IFN B,A==A+<_1.> - A - IFN ,<+40>_29. - 400000+SATOM,, - .-LOCN+1,,0 - TV==LOCN-.+2,,LOCN - ADDTV TATOM,TV,0 - VECRET - TERMIN - -;VATOM .FNAM1 ;"HACK REMOVED FOR EFFICIENCY" - - -;MACRO TO REMMVE SYMBOLS OF THE FORM "GXXXXX" - -DEFINE GEXPUN \SYM - NN==7 - TOTAL==0 - NUMGEN \ - RADIX 10. - .GSSET 0 - REPEAT TOTAL,XXP - RADIX 8 -TERMIN - -DEFINE XXP \A - EXPUNGE A - TERMIN - - -DEFINE ..LOC NEW,OLD - .LIFS .LPUR"+.LIMPU" - OLD!"==$." - LOC NEW!" - .ELDC - .LIFS -.LPUR" - LOC $." - .ELDC - .LIFS -.LIMPU - LOC $." - .ELDC - TERMIN - - -; PURE - MACRO TO SWITCH LOADING TO PURE CORE. - -DEFINE PURE - IFE PURITY-1, ..LOC .LPUR,.LIMPU - PURITY==0 - TERMIN - -; IMPURE - MACRO TO SWITCH LOADING TO IMPURE CORE. - -DEFINE IMPURE - IFE PURITY, ..LOC .LIMPU,.LPUR - PURITY==1 - TERMIN -] -PURITY==0 - -TITLE MUDEX -- TENEX DEPENDANT MUDDLE CODE - -RELOCATABLE - -.INSRT MUDDLE > -.INSRT STENEX > - -MFORK==400000 - -MONITS==1 - -.GLOBAL %SSNAM,%RSNAM,%KILLM,%LOGOU,%SLEEP,%VALRE,NOTTY,MSGTYP,TTYOP2 -.GLOBAL %UNAM,%JNAM,%RUNAM,%RJNAM,%GCJOB,%SHWND,%SHFNT,%GETIP,%INFMP -.GLOBAL GCHN,WNDP,FRNP,MESSAG,INITFL,6TOCHS,SGSNAM,MTYO,PGINT,WHOAMI -.GLOBAL %TOPLQ,IBLOCK,TMTNXS,TNXSTR,%HANG,ILLUUO,UUOH,IPCINI,CTIME,BFLOAT -.GLOBAL GCRSET - -GCHN==0 -WRTP==1000,,100000 -GCHI==1000,,GCHN -CRJB==1000,,400001 -FME==1000,,-1 -FLS==1000,, - -CTIME: JOBTM ; get run time in milli secs - MOVE B,A - JSP A,BFLOAT ; Convert to floating - FDVRI B,(1000.0) ; Change to units of seconds - MOVSI A,TFLOAT - POPJ P, - -; SET THE SNAME GLOBALLY - -%SSNAM: POPJ P, - -; READ THE GLOBAL SNAME - -%RSNAM: POPJ P, - -; KILL THE CURRENT JOB - -%KILLM: HALTF - POPJ P, - -; PASS STRING TO SUPERIOR (MONITOR?) - -%VALRE: HALTF - POPJ P, - -; LOGOUT OF SYSTEM (MUST BE "TOP LEVEL") - -%LOGOU: LGOUT - POPJ P, - -; GO TO SLEEP A WHILE - -%SLEEP: IMULI A,33. ; TO MILLI SECS - DISMS - POPJ P, - -; HANG FOR EVER - -%HANG: WAIT - -; READ JNAME - -%RJNAM: POPJ P, - -; READ UNAME - -%RUNAM: POPJ P, - -; HERE TO SEE IF WE ARE A TOP LEVEL JOB - -%TOPLQ: GJINF - SKIPGE D - AOS (P) - POPJ P, - -; GET AN INFERIOR FOR THE GARBAGE COLLECTOR - -%GCJOB: PUSH P,A - MOVEI A,200000 ; GET BITS FOR FORK - CFORK ; MAKE AN IFERIOR FORK - FATAL CANT GET GC FORK - MOVEM A,GCFRK ; SAVE HANDLE - POP P,A ; RESTORE PAGE - PUSHJ P,%GETIP ; GET IT THERE - PUSHJ P,%SHWND - JRST %SHFNT ; AND FRONTIER - -; HERE TO GET A PAGE FOR THE INFERIOR - -%GETIP: POPJ P, - -; HERE TO SHARE WINDOW - -%SHWND: TDZA 0,0 ; FLAG SAYING WINDOW - -; HERE TO SHARE FRONTIER - -%SHFNT: MOVEI 0,1 - PUSH P,A - PUSH P,B - PUSH P,C - MOVEI B,2*FRNP ; FRONTIER (REMEMBER TENEX PAGE SIZE) - SKIPN 0 - MOVEI B,2*WNDP ; NO,WINDOW - HRLI B,MFORK - ASH A,1 ; TIMES 2 - HRL A,GCFRK - MOVSI C,140000 ; READ AND WRITE ACCESS - - PMAP - ADDI A,1 - ADDI B,1 - PMAP - ASH B,9. ; POINT TO PAGE - MOVES (B) ; CLOBBER TOP - MOVES -1(B) ; AND UNDER - POP P,C - POP P,B - POP P,A - POPJ P, - -; HERE TO MAP INFERIOR BACK AND KILL SAME - -%INFMP: PUSH P,C - PUSH P,D - PUSH P,E - ASH A,1 - ASH B,1 - MOVE D,A ; POINT TO PAGES - MOVE E,B ; FOR COPYING - PUSH P,A ; SAVE FOR TOUCHING - MOVS A,GCFRK - MOVSI B,MFORK - MOVSI C,120400 ; READ AND WRITE COPY - -LP1: HRRI A,(E) - HRRI B,(D) - PMAP - ADDI E,1 - AOBJN D,LP1 - -; HERE TO TOUCH PAGES TO INSURE KEEPING THEM (KLUDGE) - - POP P,E ; RESTORE MY FIRST PAGE # - MOVEI A,(E) ; COPY FOR LOOP - ASH A,9. ; TO WORD ADDR - MOVES (A) ; WRITE IT - AOBJN E,.-3 ; FOR ALL PAGES - - MOVE A,GCFRK - KFORK - POP P,E - POP P,D - POP P,C - POPJ P, - -; HACK TO PRINT MESSAGE OF INTEREST TO USER - -MESOUT: MOVSI A,(JFCL) - MOVEM A,MESSAG ; DO ONLY ONCE - MOVEI A,400000 - MOVE B,[1,,ILLUUO] - MOVE C,[40,,UUOH] - SCVEC - SETZ SP, ; HACK TO AVOID LOSSAGE WITH GARBAGE IN SP FIRST TIME - PUSHJ P,GCRSET - PUSHJ P,PGINT ; INITIALIZE PAGE MAP - RESET - PUSHJ P,TTYOP2 - SKIPE NOTTY ; HAVE A TTY? - JRST RESNM ; NO, SKIP THIS STUFF - - MOVEI A,MESBLK - MOVEI B,0 - GTJFN - JRST RESNM - MOVE B,[70000,,200000] - OPENF - JRST RESNM - -MSLP: BIN - MOVE D,B ; SAVE BYTE - GTSTS - TLNE B,1000 - JRST RESNM - EXCH D,A - CAIN A,14 - PBOUT - MOVE A,D - JRST MSLP - -RESNM2: CLOSF - JFCL - -RESNM: -RESNM1: POPJ P, - -MESBLK: 100000,, - 377777,,377777 - -1,,[ASCIZ /DSK/] - -1,,[ASCIZ /VEZZA/] - -1,,[ASCIZ /MUDDLE/] - -1,,[ASCIZ /MESSAG/] - 0 - 0 - 0 - -MUDINT: MOVSI 0,(JFCL) ; CLOBBER MUDDLE INIT SWITCH - MOVEM 0,INITFL - - GJINF ; GET INFO NEEDED - PUSHJ P,TMTNXS ; MAKE A TEMP STRING FOR TENEX INFO (POINTER LEFT IN E) - HRROI A,1(E) ; TNX STRING POINTER - DIRST - FATAL ATTACHED DIR DOES NOT EXIST - MOVEI B,1(E) ; NOW HAVE BOUNDS OF STRING - SUBM P,E ; RELATIVIZE E - PUSHJ P,TNXSTR ; MAKE THE STRING - SUB P,E - PUSH TP,$TATOM - PUSH TP,IMQUOTE SNM - PUSH TP,A - PUSH TP,B - MCALL 2,SETG - PUSH TP,$TCHSTR - PUSH TP,CHQUOTE READ - PUSH TP,$TCHSTR - PUSH TP,CHQUOTE MUDDLE.INIT - MCALL 2,FOPEN - GETYP A,A - CAIE A,TCHAN - POPJ P, - PUSH TP,$TCHAN - PUSH TP,B - MOVEI B,INITSTR ; TELL USER WHAT'S HAPPENING - SKIPE WHOAMI - JRST .+3 - SKIPN NOTTY - PUSHJ P,MSGTYP - MCALL 1,MLOAD - POPJ P, - -TMTNXS: POP P,D ; SAVE RET ADDR - MOVE E,P ; BUILD A STRING SPACE ON PSTACK - MOVEI 0,20. ; USE 20 WORDS (=100 CHARS) - PUSH P,[0] - SOJG 0,.-1 - - JRST (D) - - -TNXSTR: SUBI B,(P) - PUSH P,B - ADDI B,-1(P) - SUBI B,(A) ; WORDS TO B - IMULI B,5 ; TO CHARS - LDB 0,[360600,,A] ; GET BYTE POSITION - IDIVI 0,7 ; TO A REAL BYTE POSITION - MOVNS 0 - ADDI 0,5 - SUBM 0,B ; FINAL LENGTH IN BYTES TO B - PUSH P,B ; SAVE IT - MOVEI A,4(B) ; TO WORDS - IDIVI A,5 - PUSHJ P,IBLOCK ; GET STRING - POP P,A - POP P,C - ADDI C,(P) - MOVE D,B ; COPY POINTER - MOVE 0,(C) ; GET A WORD - MOVEM 0,(D) - ADDI C,1 - AOBJN D,.-3 - - HRLI A,TCHSTR - HRLI B,440700 ; MAKE INTO BYTER - POPJ P, - -IPCINI: JFCL -IFN MONITS,[ - -DEMS: SETZ - SIXBIT /DEMSIG/ - SETZ [SIXBIT /MUDSTA/] -] -INITSTR: ASCIZ /MUDDLE INIT/ - -IMPURE - -GCFRK: 0 - -IFN MONITS,[ -MESSDM: 30,,(SIXBIT /IPC/) - .+1 - SIXBIT /MUDDLESTATIS/ - 1 - 1 -] - -MESSAG: PUSHJ P,MESOUT ; MESSAGE SWITCH - -INITFL: PUSHJ P,MUDINT ; MUDDLE INIT SWITCH - -PURE - -END - -TITLE SQUOZE TABLE HANDLER FOR MUDDLE - -RELOCATABLE - -.INSRT MUDDLE > - -.GLOBAL SQUPNT,ATOSQ,SQUTOA - -; POINTER TO TABLE FILLED IN BY INITM - -SQUPNT: 0 - -; GIVEN LOCN OF SUBR RET SQUO NAME ARG AND VAL IN E - -ATOSQ: PUSH P,B - PUSH P,A - MOVE A,SQUPNT ; GET TABLE POINTER - MOVE B,[2,,2] - CAMN E,1(A) - JRST ATOSQ1 - ADD A,B - JUMPL A,.-3 -POPABJ: POP P,B - POP P,A - POPJ P, - -ATOSQ1: MOVE E,(A) - AOS -2(P) - JRST POPABJ - -; BINARY SEARCH FOR SQUOZE SYMBOL ARG IN E - -SQUTOA: PUSH P,A - PUSH P,B - PUSH P,C - - MOVE A,SQUPNT ; POINTER TO TABLE - HLRE B,SQUPNT - MOVNS B - HRLI B,(B) ; B IS CURRENT OFFSET - -UP: ASH B,-1 ; HALVE TABLE - AND B,[-2,,-2] ; FORCE DIVIS BY 2 - MOVE C,A ; COPY POINTER - JUMPLE B,LSTHLV ; CANT GET SMALLER - ADD C,B - CAMLE E,(C) ; SKIP IF EITHER FOUND OR IN TOP - MOVE A,C ; POINT TO SECOND HALF - CAMN E,(C) ; SKIP IF NOT FOUND - JRST WON - CAML E,(C) ; SKIP IF IN TOP HALF - JRST UP - HLLZS C ; FIX UP OINTER - SUB A,C - JRST UP - -WON: MOVE E,1(C) ; RET VAL IN E - AOS -3(P) ; SKIP RET -WON1: POP P,C - POP P,B - POP P,A - POPJ P, - -LSTHLV: CAMN E,(C) ; LINEAR SERCH REST - JRST WON - ADD C,[2,,2] - JUMPL C,.-3 - JRST WON1 ; ALL GONE, LOSE - -END - -TITLE MODIFIED AFREE FOR MUDDLE - -RELOCATABLE - -.INSRT MUDDLE > - -.GLOBAL CAFREE,CAFRET,PARNEW,AGC,PARBOT,CODTOP,CAFRE1 -.GLOBAL STOGC,STOSTR,CAFRE,ISTOST,STOLST,SAT,ICONS,BYTDOP -.GLOBAL FLIST,STORIC -MFUNCTION FREEZE,SUBR - - ENTRY 1 - - GETYP A,(AB) ; get type of it - PUSH TP,(AB) ; save a copy - PUSH TP,1(AB) - PUSH P,[0] ; flag for tupel freeze - PUSHJ P,SAT ; to SAT - MOVEI B,0 ; final type - CAIN A,SNWORD ; check valid types - MOVSI B,TUVEC ; use UVECTOR - CAIN A,S2NWOR - MOVSI B,TVEC - CAIN A,SARGS - MOVSI B,TVEC - CAIN A,SCHSTR - MOVSI B,TCHSTR - JUMPE B,WTYP1 - PUSH P,B ; save final type - CAME B,$TCHSTR ; special chars hack - JRST OK.FR - HRR B,(AB) ; fixup count - MOVEM B,(P) - - MOVEI C,(TB) ; point to it - PUSHJ P,BYTDOP ; A==> points to dope word - HRRO B,1(TB) - SUBI A,1(B) ; A==> length of block - TLC B,-1(A) - MOVEM B,1(TB) ; and save - MOVSI 0,TUVEC - MOVEM 0,(TB) - -OK.FR: HLRE A,1(TB) ; get length - MOVNS A - PUSH P,A - ADDI A,2 - PUSHJ P,CAFREE ; get storage - HRLZ B,1(TB) ; set up to BLT - HRRI B,(A) - POP P,C - ADDI C,(A) ; compute end - BLT B,(C) - MOVEI B,(A) - HLL B,1(AB) - POP P,A - JRST FINIS - - -CAFRE: PUSH P,A - HRRZ E,STOLST+1(TVP) - SETZB C,D - PUSHJ P,ICONS ; get list element - PUSH TP,$TLIST ; and save - PUSH TP,B - MOVE A,(P) ; restore length - ADDI A,2 ; 2 more for dope words - PUSHJ P,CAFREE ; get the core and dope words - POP P,B ; restore count - MOVNS B ; build AOBJN pointer - MOVSI B,(B) - HRRI B,(A) - MOVE C,(TP) - MOVEM B,1(C) ; save on list - MOVSI 0,TSTORA ; and type - HLLM 0,(C) - HRRZM C,STOLST+1(TVP) ; and save as new list - SUB TP,[2,,2] - POPJ P, - -CAFRE1: PUSH P,A - ADDI A,2 - PUSHJ P,CAFREE - HRROI B,(A) ; pointer to B - POP P,A ; length back - TLC B,-1(A) - POPJ P, - -CAFREE: IRP AC,,[B,C,D,E] - PUSH P,AC - TERMIN - SKIPG A ; make sure arg is a winner - FATAL BAD CALL TO CAFREE - MOVSI A,(A) ; count to left half for search - MOVEI B,FLIST ; get first pointer - HRRZ C,(B) ; c points to next block -CLOOP: CAMG A,(C) ; skip if not big enough - JRST CONLIS ; found one - MOVEI D,(B) ; save in case fall out - MOVEI B,(C) ; point to new previous - HRRZ C,(C) ; next block - JUMPN C,CLOOP ; go on through loop - HLRZ E,A ; count to E - CAMGE E,STORIC ; skip if a area or more - MOVE E,STORIC ; else use a whole area - MOVE C,PARBOT ; foun out if any funny space - SUB C,CODTOP ; amount around to C - CAMLE C,E ; skip if must GC - JRST CHAVIT ; already have it - SUBI E,-1(C) ; get needed from agc - MOVEM E,PARNEW ; funny arg to AGC - PUSH P,A - MOVE C,[7,,6] ; SET UP AGC INDICATORS - PUSHJ P,AGC ; collect that garbage - SETZM PARNEW ; dont do it again - AOJL A,GCLOS ; couldn't get core - POP P,A - -; Make sure pointers still good after GC - - MOVEI D,FLIST - HRRZ B,(D) - - HRRZ E,(B) ; next pointer - JUMPE E,.+4 ; end of list ok - MOVEI D,(B) - MOVEI B,(E) - JRST .-4 ; look at next - -CHAVIT: MOVE E,PARBOT ; find amount obtained - SUBI E,1 ; dont use a real pair - MOVEI C,(E) ; for reset of CODTOP - SUB E,CODTOP - EXCH C,CODTOP ; store it back - CAIE B,(C) ; did we simply grow the last block? - JRST CSPLIC ; no, splice it in - HLRZ C,(B) ; length of old guy - ADDI C,(E) ; total length - ADDI B,(E) ; point to new last dope word - HRLZM C,(B) ; clobber final length in - HRRM B,(D) ; and splice into free list - MOVEI C,(B) ; reset acs for reentry into loop - MOVEI B,(D) - JRST CLOOP - -; Here to splice new core onto end of list. - -CSPLIC: MOVE C,CODTOP ; point to end of new block - HRLZM E,(C) ; store length of new block in dope words - HRRM C,(D) ; D is old previous, link it up - MOVEI B,(D) ; and reset B for reentry into loop - JRST CLOOP - -; here if an appropriate block is on the list - -CONLIS: HLRZS A ; count back to a rh - HLRZ D,(C) ; length of proposed block to D - CAIN A,(D) ; skip if they are different - JRST CEASY ; just splice it out - MOVEI B,(C) ; point to block to be chopped up - SUBI B,-1(D) ; point to beginning of same - SUBI D,(A) ; amount of block to be left to D - HRLM D,(C) ; and fix up dope words - ADDI B,-1(A) ; point to end of same - HRLZM A,(B) - HRRM B,(B) ; for GC benefit - -CFREET: CAIE A,1 ; if more than 1 - SETZM -1(B) ; make tasteful dope worda - SUBI B,-1(A) - MOVEI A,(B) - IRP AC,,[E,D,C,B] - POP P,AC - TERMIN - POPJ P, - -CEASY: MOVEI D,(C) ; point to block to return - HRRZ C,(C) ; point to next of same - HRRM C,(B) ; smash its previous - MOVEI B,(D) ; point to block with B - HRRM B,(B) ; for GC benefit - JRST CFREET - -GCLOS: PUSH TP,$TATOM - PUSH TP,EQUOTE NO-MORE-STORAGE - JRST CALER1 - -CAFRET: HRROI B,(B) ; prepare to search list - TLC B,-1(A) ; by making an AOBJN pointer - HRRZ C,STOLST+1(TVP) ; start of list - MOVEI D,STOLST+1(TVP) - -CAFRTL: JUMPE C,CPOPJ ; not founc - CAME B,1(C) ; this it? - JRST CAFRT1 - HRRZ C,(C) ; yes splice it out - HRRM C,(D) ; smash it -CPOPJ: POPJ P, ; dont do anything now - -CAFRT1: MOVEI D,(C) - HRRZ C,(C) - JRST CAFRTL - -; Here from GC to collect all unused blocks into free list - -STOGC: SETZB C,E ; zero current length and pointer - MOVE A,CODTOP ; get high end of free space - -STOGCL: CAIG A,STOSTR ; end? - JRST STOGCE ; yes, cleanup and leave - - HLRZ 0,(A) ; get length - ANDI 0,377777 - SKIPGE (A) ; skip if a not used block - JRST STOGC1 ; jump if marked - - JUMPE C,STOGC3 ; jump if no block under construction - ADD C,0 ; else add this length to current - JRST STOGC4 - -STOGC3: MOVEI B,(A) ; save pointer - MOVE C,0 ; init length - -STOGC4: SUB A,0 ; point to next block - JRST STOGCL - -STOGC1: ANDCAM D,(A) ; kill mark bit - JUMPE C,STOGC4 ; if no block under cons, dont fix - HRLM C,(B) ; store total block length - HRRM E,(B) ; next pointer hooked in - MOVEI E,(B) ; new next pointer - MOVEI C,0 - JRST STOGC4 - -STOGCE: JUMPE C,STGCE1 ; jump if no current block - HRLM C,(B) ; smash in count - HRRM E,(B) ; smash in next pointer - MOVEI E,(B) ; and setup E - -STGCE1: HRRZM E,FLIST+1 ; final link up - POPJ P, - -IMPURE - -FLIST: .+1 - ISTOST - -PURE - -END - -TITLE FLOATB--CONVERT FLOATING NUMBER TO ASCII STRING - -RELOCA - -.GLOBAL FLOATB - -ACNUM==1 - -IRP A,,[A,B,C,D,E,F,G,H,I,J] -A==ACNUM -ACNUM==ACNUM+1 -TERMIN - -P==17 - -TEM1==I - -EXPUNGE ACNUM - -FLOATB: PUSH P,B - PUSH P,C - PUSH P,D - PUSH P,F - PUSH P,G - PUSH P,H - PUSH P,I - PUSH P,0 - PUSH P,J - MOVSI 0,440700 ; BUILD BYTEPNTR - HLRZ J,A ; POINT TO BUFFER - HRRI 0,1(J) - MOVE A,(A) ; GET NUMBER - MOVE D,A - SETZM (J) ; Clear counter - PUSHJ P,NFLOT - POP P,J - POP P,0 - POP P,I - POP P,H - POP P,G - POP P,F - POP P,D - POP P,C - POP P,B - POPJ P, - -; at this point we enter code abstracted from DDT. -NFLOT: JUMPG A,TFL1 - JUMPE A,FP1A - MOVNS A - PUSH P,A - MOVEI A,"- - PUSHJ P,CHRO - POP P,A - TLZE A,400000 - JRST FP1A - -TFL1: MOVEI B,0 -TFLX: CAMGE A,FT01 - JRST FP4 - CAML A,FT8 - AOJA B,FP4 -FP1A: -FP3: SETZB C,TEM1 ; CLEAR DIGIT CNTR, C TO RECEIVE FRACTION - MULI A,400 - ASHC B,-243(A) - MOVE A,B - PUSHJ P,FP7 - PUSH P,A - MOVEI A,". - PUSHJ P,CHRO - POP P,A - MOVNI A,10 - ADD A,TEM1 - MOVE E,C -FP3A: MOVE D,E - MULI D,12 - PUSHJ P,FP7B - SKIPE E - AOJL A,FP3A - POPJ P, ; ONE return from OFLT here - -FP4: MOVNI C,6 - MOVEI F,0 -FP4A: ADDI F,1(F) - XCT FCP(B) - SOSA F - FMPR A,@FCP+1(B) - AOJN C,FP4A - PUSH P,EXPSGN(B) - PUSHJ P,FP3 - PUSH P,A - MOVEI A,"E - PUSHJ P,CHRO - POP P,A - POP P,D - PUSHJ P,FDIGIT - MOVE A,F - -FP7: SKIPE A ; AVOID AOSING TEM1, NOT SIGNIFICANT DIGIT - AOS TEM1 - IDIVI A,12 - HRLM B,(P) - JUMPE A,FP7A1 - PUSHJ P,FP7 - -FP7A1: HLRZ D,(P) -FP7B: ADDI D,"0 - -; type digit -FDIGIT: PUSH P,A - MOVE A,D - PUSHJ P,CHRO - POP P,A - POPJ P, - -CHRO: AOS (J) ; COUNT CHAR - IDPB A,0 ; STUFF CHAR - POPJ P, - -; constants - 1.0^32. - 1.0^16. -FT8: 1.0^8 - 1.0^4 - 1.0^2 - 1.0^1 -FT: 1.0^0 - 1.0^-32. - 1.0^-16. - 1.0^-8 - 1.0^-4 - 1.0^-2 -FT01: 1.0^-1 -FT0=FT01+1 - -; instructions -FCP: CAMLE A, FT0(C) - CAMGE A, FT(C) - 0, FT0(C) - -EXPSGN: "- - "+ - - -EXPUNGE A,B,C,D,E,F,G,H,I,J,TEM1,P - -END - TITLE PRIMITIVE FUNCTIONS FOR THE MUDDLE SYSTEM - -RELOCATABLE - -.INSRT MUDDLE > - -.GLOBAL TMA,TFA,CELL,IBLOCK,IBLOK1,ICELL2,VECTOP -.GLOBAL NWORDT,CHARGS,CHFRM,CHLOCI,IFALSE,IPUTP,IGETP,BYTDOP -.GLOBAL OUTRNG,IGETLO,CHFRAM,ISTRUC,TYPVEC,SAT,CHKAB,VAL,CELL2,MONCH,MONCH0 -.GLOBAL RMONCH,RMONC0,LOCQ,LOCQQ,SMON,PURERR,APLQ,NAPT,TYPSEG,NXTLM -.GLOBAL MAKACT,ILLCHO,COMPER,CEMPTY,CIAT,CIEQUA,CILEGQ,CILNQ,CILNT,CIN,CINTH,CIREST -.GLOBAL CISTRU,CSETLO,CIPUT,CIGET,CIGETL,CIMEMQ,CIMEMB,CIMON,CITOP,CIBACK -.GLOBAL IGET,IGETL,IPUT,CIGETP,CIGTPR,CINEQU,IEQUAL,TD.LNT,TD.GET,TD.PUT,TD.PTY -.GLOBAL TMPLNT,ISTRCM - -; BUILD DISPATCH TABLE FOR PRIMITIVE FUNCTIONS USAGE - -PRMTYP: - -REPEAT NUMSAT,[0] ;INITIALIZE TABLE TO ZEROES - -IRP A,,[2WORD,2NWORD,NWORD,ARGS,CHSTR,BYTE] - -LOC PRMTYP+S!A -P!A==.IRPCN+1 -P!A - -TERMIN - -PTMPLT==PBYTE+1 - -; FUDGE FOR STRUCTURE LOCATIVES - -IRP A,,[[LOCL,2WORD],[LOCV,2NWORD],[LOCU,NWORD],[LOCS,CHSTR],[LOCA,ARGS] -[LOCT,TMPLT]] - IRP B,C,[A] - LOC PRMTYP+S!B - P!B==P!C,,0 - P!B - .ISTOP - TERMIN -TERMIN - -LOC PRMTYP+SSTORE ;SPECIAL HACK FOR AFREE STORAGE -PNWORD - -LOC PRMTYP+NUMSAT+1 - -PNUM==PTMPLT+1 - -; MACRO TO BUILD PRIMITIVE DISPATCH TABLES - -DEFINE PRDISP NAME,DEFAULT,LIST - TBLDIS NAME,DEFAULT,[LIST]PNUM - TERMIN - - -; SUBROUTINE TO RETURN PRIMITIVE TYPE AND PRINT ERROR IF ILLEGAL - -PTYPE: GETYP A,(B) ;CALLE D WITH B POINTING TO PAIR - CAIN A,TILLEG ;LOSE IF ILLEGAL - JRST ILLCHOS - - PUSHJ P,SAT ;GET STORAGE ALLOC TYPE - CAIE A,SLOCA - CAIN A,SARGS ;SPECIAL HAIR FOR ARGS - PUSHJ P,CHARGS - CAIN A,SFRAME - PUSHJ P,CHFRM - CAIN A,SLOCID - PUSHJ P,CHLOCI -PTYP1: MOVEI 0,(A) ; ALSO RETURN PRIMTYPE - CAILE A,NUMSAT ; SKIP IF NOT TEMPLATE - SKIPA A,[PTMPLT] - MOVE A,PRMTYP(A) ;GET PRIM TYPE, - POPJ P, - -; COMPILERS CALL TO ABOVE (LESS CHECKING) - -CPTYPE: PUSHJ P,SAT - MOVEI 0,(A) - CAILE A,NUMSAT - SKIPA A,[PTMPLT] - MOVE A,PRMTYP(A) - POPJ P, - - -MFUNCTION SUBSTRUC,SUBR - - ENTRY - JUMPGE AB,TFA ;need at least one arg - CAMGE AB,[-10,,0] ;NO MORE THEN 4 - JRST TMA - MOVE B,AB - PUSHJ P,PTYPE ;get primtype in A - PUSH P,A - JRST @TYTBL(A) - -RESSUB: CAMLE AB,[-2,,0] ;if only one arg skip rest - JRST @COPYTB(A) - HLRZ B,(AB)2 ;GET TYPE - CAIE B,TFIX ;IF FIX OK - JRST WRONGT - MOVE B,(AB)1 ;ptr to object of resting - MOVE C,(AB)3 ;# of times to rest - MOVEI E,(A) - MOVE A,(AB) - PUSHJ P,@MRSTBL(E) - PUSH TP,A ;type - PUSH TP,B ;put rested sturc on stack - JRST ALOCOK - -PRDISP TYTBL,IWTYP1,[[P2WORD,RESSUB],[P2NWORD,RESSUB] -[PNWORD,RESSUB],[PCHSTR,RESSUB]] - -PRDISP MRSTBL,IWTYP1,[[P2WORD,LREST],[P2NWORD,VREST] -[PNWORD,UREST],[PCHSTR,SREST]] - -PRDISP COPYTB,IWTYP1,[[P2WORD,CPYLST],[P2NWORD,CPYVEC] -[PNWORD,CPYUVC],[PCHSTR,CPYSTR]] - -PRDISP ALOCTB,IWTYP1,[[P2WORD,ALLIST],[P2NWORD,ALVEC] -[PNWORD,ALUVEC],[PCHSTR,ALSTR]] - -ALOCFX: MOVE B,(TP) ;missing 3rd arg aloc for "rest" of struc - MOVE C,-1(TP) - MOVE A,(P) - PUSH P,[377777,,-1] - PUSHJ P,@LENTBL(A) ;get length of rested struc - SUB P,[1,,1] - POP P,C - MOVE A,B ;# of elements needed - JRST @ALOCTB(C) - -ALOCOK: CAML AB,[-4,,0] ;exactly 3 args - JRST ALOCFX - HLRZ C,(AB)4 - CAIE C,TFIX ;OK IF TYPE FIX - JRST WRONGT - POP P,C ;C HAS PRIMTYYPE - MOVE A,(AB)5 ;# of elements needed - JRST @ALOCTB(C) ;DO ALLOCATION - - -CPYVEC: HLRE A,(AB)1 ;USE WHEN ONLY ONE ARG - MOVNS A - ASH A,-1 ;# OF ELEMENTS FOR ALLOCATION - PUSH TP,(AB) - PUSH TP,(AB)1 - -ALVEC: PUSH P,A - ASH A,1 - HRLI A,(A) - ADD A,(TP) - CAIL A,-1 ;CHK FOR OUT OF RANGE - JRST OUTRNG - CAMGE AB,[-6,,] ; SKIP IF WE GET VECTOR - JRST ALVEC2 ; USER SUPPLIED VECTOR - MOVE A,(P) - PUSHJ P,IBLOK1 -ALVEC1: MOVE A,(P) ;# OF WORDS TO ALLOCATE - MOVE C,B ; SAVE VECTOR POINTER - ASH A,1 ;TIMES 2 - HRLI A,(A) - ADD A,B ;PTING TO FIRST DOPE WORD -ALLOCATED - CAIL A,-1 - JRST OUTRNG - SUBI A,1 ;ptr to last element of the block - HRL B,(TP) ;bleft-ptr to source , b right -ptr to allocated space - BLT B,(A) - MOVE B,C - POP P,A - SUB TP,[2,,2] - MOVSI A,TVEC - JRST FINIS - -ALVEC2: GETYP 0,6(AB) ; CHECK IT IS A VECTOR - CAIE 0,TVEC - JRST WTYP - HLRE A,7(AB) ; CHECK SIZE - MOVNS A - ASH A,-1 ; # OF ELEMENTS - CAMGE A,(P) ; SKIP IF BIG ENOUGH - JRST OUTRNG - MOVE B,7(AB) ; WINNER, JOIN COMMON CODE - JRST ALVEC1 - -CPYUVC: HLRE A,(AB)1 ;# OF ELEMENTS FOR ALLOCATION - MOVNS A - PUSH TP,(AB) - PUSH TP,1(AB) - -ALUVEC: PUSH P,A - HRLI A,(A) - ADD A,(TP) ;PTING TO DOPE WORD OF ORIG VEC - CAIL A,-1 - JRST OUTRNG - CAMGE AB,[-6,,] ; SKIP IF WE SUPPLY UVECTOR - JRST ALUVE2 - MOVE A,(P) - PUSHJ P,IBLOCK -ALUVE1: MOVE A,(P) ;# of owrds to allocate - HRLI A,(A) - ADD A,B ;LOCATION O FIRST ALLOCATED DOPE WORD - HLR D,(AB)1 ;# OF ELEMENTS IN UVECTOR - MOVNS D - ADD D,(AB)1 ;LOCATION OF FIRST DOPE WORD FOR SOURCE - GETYP E,(D) ;GET UTYPE - CAML AB,[-6,,] ; SKIP IF USER SUPPLIED OUTPUT UVECTOR - HRLM E,(A) ;DUMP UTYPE INTO DOPE WORD OF ALLOC UVEC - CAMGE AB,[-6,,] - CAIN 0,(E) ; 0 HAS USER UVEC UTYPE - JRST .+2 - JRST WRNGUT - CAIL A,-1 - JRST OUTRNG - MOVE C,B ; SAVE POINTER TO FINAL GUY - HRL C,(TP) ;Bleft- ptr to source, Bright-ptr to allocated space - BLT C,-1(A) - POP P,A - MOVSI A,TUVEC - JRST FINIS - -ALUVE2: GETYP 0,6(AB) ; CHECK IT IS A VECTOR - CAIE 0,TUVEC - JRST WTYP - HLRE A,7(AB) ; CHECK SIZE - MOVNS A - CAMGE A,(P) ; SKIP IF BIG ENOUGH - JRST OUTRNG - MOVE B,7(AB) ; WINNER, JOIN COMMON CODE - HLRE A,B - SUBM B,A - GETYP 0,(A) ; GET UTYPE OF USER UVECTOR - JRST ALUVE1 - -CPYSTR: HRR A,(AB) ;#OF CHAR TO COPY - PUSH TP,(AB) ;ALSTR EXPECTS STRING IN TP - PUSH TP,1(AB) - -ALSTR: PUSH P,A - HRRZ 0,-1(TP) ;0 IS LENGTH OFF VECTOR - CAIGE 0,(A) - JRST OUTRNG - CAMGE AB,[-6,,] ; SKIP IF WE SUPPLY STRING - JRST ALSTR2 - ADDI A,4 - IDIVI A,5 - PUSHJ P,IBLOCK ;ALLOCATE SPACE - HRLI B,440700 - MOVE A,(P) ; # OF CHARS TO A -ALSTR1: PUSH P,B ;BYTE PTR TO ALOC SPACE - POP TP,C ;PTR TO ORIGINAL STR - POP TP,D ;USELESS -COPYST: ILDB D,C ;GET NEW CHAR - IDPB D,B ;DEPOSIT CHAR - SOJG A,COPYST ;FINISH TRANSFER? - -CLOSTR: POP P,B ;BYTE PTR TO COPY - POP P,A ;# FO ELEMENTS - HRLI A,TCHSTR - JRST FINIS - -ALSTR2: GETYP 0,6(AB) ; CHECK IT IS A VECTOR - CAIE 0,TCHSTR - JRST WTYP - HRRZ A,6(AB) - CAMGE A,(P) ; SKIP IF BIG ENOUGH - JRST OUTRNG - EXCH A,(P) - MOVE B,7(AB) ; WINNER, JOIN COMMON CODE - JRST ALSTR1 - -CPYLST: SKIPN 1(AB) - JRST ZEROLT - PUSHJ P,CELL2 - POP P,C - HRLI C,TLIST ;TP JUNK FOR GAR. COLLECTOR - PUSH TP,C ;TYPE - PUSH TP,B ;VALUE -PTR TO NEW LIST - PUSH TP,C ;TYPE - MOVE C,1(AB) ;PTR TO FIRST ELEMENT OF ORIG. LIST -REPLST: MOVE D,(C) - MOVE E,1(C) ;GET LIST ELEMENT INTO ALOC SPACE - HLLM D,(B) - MOVEM E,1(B) ;PUT INTO ALLOCATED SPACE - HRRZ C,(C) ;UPDATE PTR - JUMPE C,CLOSWL ;END OF LIST? - PUSH TP,B - PUSHJ P,CELL2 - POP TP,D - HRRM B,(D) ;LINK ALLOCATED LIST CELLS - JRST REPLST - -CLOSWL: POP TP,B ;USELESS - POP TP,B ;PTR TO NEW LIST - POP TP,A ;TYPE - JRST FINIS - - - -ALLIST: CAMGE AB,[-6,,] ; SKIP IF WE BUILD THE LIST - JRST CPYLS2 - JUMPE A,ZEROLT - PUSH P,A - PUSHJ P,CELL - POP P,A ;# OF ELEMENTS - PUSH P,B ;ptr to allocated list - POP TP,C ;ptr to orig list - JRST ENTCOP - -COPYL: ADDI B,2 - HRRM B,-2(B) ;LINK ALOCATED LIST CELLS -ENTCOP: JUMPE C,OUTRNG - MOVE D,(C) - MOVE E,1(C) ;get list element into D+E - HLLM D,(B) - MOVEM E,1(B) ;put into allocated space - HRRZ C,(C) ;update ptrs - SOJG A,COPYL ;finish transfer? - -CLOSEL: POP P,B ;PTR TO NEW LIST - POP TP,A ;type - JRST FINIS - -ZEROLT: SUB TP,[1,,1] ;IF RESTED ALL OF LIST - SUB TP,[1,,1] - MOVSI A,TLIST - MOVEI B,0 - JRST FINIS - -CPYLS2: GETYP 0,6(AB) - CAIE 0,TLIST - JRST WTYP - MOVE B,7(AB) ; GET DEST LIST - MOVE C,(TP) - - JUMPE A,CPYLS3 -CPYLS4: JUMPE B,OUTRNG - JUMPE C,OUTRNG - MOVE D,1(C) - MOVEM D,1(B) - GETYP 0,(C) - HRLM 0,(B) - HRRZ B,(B) - HRRZ C,(C) - SOJG A,CPYLS4 - -CPYLS3: MOVE B,7(AB) - MOVSI A,TLIST - JRST FINIS - - -; PROCESS TYPE ILLEGAL - -ILLCHO: HRRZ B,1(B) ;GET CLOBBERED TYPE - CAIN B,TARGS ;WAS IT ARGS? - JRST ILLAR1 - CAIN B,TFRAME ;A FRAME? - JRST ILFRAM - CAIN B,TLOCD ;A LOCATIVE TO AN ID - JRST ILLOC1 - - LSH B,1 ;NONE OF ABOVE LOOK IN TABLE - ADDI B,TYPVEC+1(TVP) - PUSH TP,$TATOM - PUSH TP,EQUOTE ILLEGAL - PUSH TP,$TATOM - PUSH TP,(B) ;PUSH ATOMIC NAME - MOVEI A,2 - JRST CALER ;GO TO ERROR REPORTER - -; CHECK AN ARGS POINTER - -CHARGS: PUSHJ P,ICHARG ; INTERNAL CHECK - JUMPN B,CPOPJ - -ILLAR1: PUSH TP,$TATOM - PUSH TP,EQUOTE ILLEGAL-ARGUMENT-BLOCK - JRST CALER1 - -ICHARG: PUSH P,A ;SAVE SOME ACS - PUSH P,B - PUSH P,C - SKIPN C,1(B) ;GET POINTER - JRST ILLARG ; ZERO POINTER IS ILLEGAL - HLRE A,C ;FIND ASSOCIATED FRAME - SUBI C,(A) ;C POINTS TO FRAME OR FRAME POINTER - GETYP A,(C) ;GET TYPE OF NEXT GOODIE - CAIN A,TCBLK - JRST CHARG1 - CAIE A,TENTRY ;MUST BE EITHER ENTRY OR TINFO - CAIN A,TINFO - JRST CHARG1 ;WINNER - JRST ILLARG - -CHARG1: CAIN A,TINFO ;POINTER TO FRAME? - ADD C,1(C) ;YES, GET IT - CAIE A,TINFO ;POINTS TO ENTRT? - MOVEI C,FRAMLN(C) ;YES POINT TO END OF FRAME - HLRZ C,OTBSAV(C) ;GET TIME FROM FRAME - HRRZ B,(B) ;AND ARGS TIME - CAIE B,(C) ;SAME? -ILLARG: SETZM -1(P) ; RETURN ZEROED B -POPBCJ: POP P,C - POP P,B - POP P,A - POPJ P, ;GO GET PRIM TYPE - - - -; CHECK A FRAME POINTER - -CHFRM: PUSHJ P,CHFRAM - JUMPN B,CPOPJ - -ILFRAM: PUSH TP,$TATOM - PUSH TP,EQUOTE ILLEGAL-FRAME - JRST CALER1 - -CHFRAM: PUSH P,A ;SAVE SOME REGISTERS - PUSH P,B - PUSH P,C - HRRZ A,(B) ; GE PVP POINTER - HLRZ C,(A) ; GET LNTH - SUBI A,-1(C) ; POINT TO TOP - CAIN A,(PVP) ; SKIP IF NOT THIS PROCESS - MOVEM TP,TPSTO+1(A) ; MAKE CURRENT BE STORED - HRRZ A,TPSTO+1(A) ; GET TP FOR THIS PROC - HRRZ C,1(B) ;GET POINTER PART - CAILE C,1(A) ;STILL WITHIN STACK - JRST BDFR - HLRZ A,FSAV(C) ;CHECK STILL AN ENTRY BLOCK - CAIN A,TCBLK - JRST .+3 - CAIE A,TENTRY - JRST BDFR - HLRZ A,1(B) ;GET TIME FROM POINTER - HLRZ C,OTBSAV(C) ;AND FROM FRAME - CAIE A,(C) ;SAME? -BDFR: SETZM -1(P) ; RETURN 0 IN B - JRST POPBCJ ;YES, WIN - -; CHECK A LOCATIVE TO AN IDENTIFIER - -CHLOCI: PUSHJ P,ICHLOC - JUMPN B,CPOPJ - -ILLOC1: PUSH TP,$TATOM - PUSH TP,EQUOTE ILLEGAL-LOCATIVE - JRST CALER1 - -ICHLOC: PUSH P,A - PUSH P,B - PUSH P,C - - HRRZ A,(B) ;GET TIME FROM POINTER - JUMPE A,POPBCJ ;ZERO, GLOBAL VARIABLE NO TIME - HRRZ C,1(B) ;POINT TO STACK - CAMLE C,VECTOP - JRST ILLOC ;NO - HRRZ C,2(C) ; SHOULD BE DECL,,TIME - CAIE A,(C) -ILLOC: SETZM -1(P) ; RET 0 IN B - JRST POPBCJ - - - - -; PREDICATE TO SEE IF AN OBJECT IS STRUCTURED - -MFUNCTION %STRUC,SUBR,[STRUCTURED?] - - ENTRY 1 - - GETYP A,(AB) ; GET TYPE - PUSHJ P,ISTRUC ; INTERNAL - JRST IFALSE - JRST ITRUTH - - -; PREDICATE TO CHECK THE LEGALITY OF A FRAME/ARGS TUPLE/IDENTIFIER LOCATIVE - -MFUNCTION %LEGAL,SUBR,[LEGAL?] - - ENTRY 1 - - MOVEI B,(AB) ; POINT TO ARG - PUSHJ P,ILEGQ - JRST IFALSE - JRST ITRUTH - -ILEGQ: GETYP A,(B) - CAIN A,TILLEG - POPJ P, - PUSHJ P,SAT ; GET STORG TYPE - CAIN A,SFRAME ; FRAME? - PUSHJ P,CHFRAM - CAIN A,SARGS ; ARG TUPLE - PUSHJ P,ICHARG - CAIN A,SLOCID ; ID LOCATIVE - PUSHJ P,ICHLOC - JUMPE B,CPOPJ - JRST CPOPJ1 - - -; COMPILERS CALL - -CILEGQ: PUSH TP,A - PUSH TP,B - MOVEI B,-1(TP) - PUSHJ P,ILEGQ - TDZA 0,0 - MOVEI 0,1 - SUB TP,[2,,2] - JUMPE 0,NO - -YES: MOVSI A,TATOM - MOVE B,MQUOTE T - JRST CPOPJ1 - -NOM: SUBM M,(P) -NO: MOVSI A,TFALSE - MOVEI B,0 - POPJ P, - -YESM: SUBM M,(P) - JRST YES - ;SUBRS TO DEFINE, GET, AND PUT BIT FIELDS - -MFUNCTION BITS,SUBR - ENTRY - JUMPGE AB,TFA ;AT LEAST ONE ARG ? - GETYP A,(AB) - CAIE A,TFIX - JRST WTYP1 - SKIPLE C,(AB)+1 ;GET FIRST AND CHECK TO SEE IF POSITIVE - CAILE C,44 ;CHECK IF FIELD NOT GREATER THAN WORD SIZE - JRST OUTRNG - MOVEI B,0 - CAML AB,[-2,,0] ;ONLY ONE ARG ? - JRST ONEF ;YES - CAMGE AB,[-4,,0] ;MORE THAN TWO ARGS ? - JRST TMA ;YES, LOSE - GETYP A,(AB)+2 - CAIE A,TFIX - JRST WTYP2 - SKIPGE B,(AB)+3 ;GET SECOND ARG AND CHECK TO SEE IF NON-NEGATIVE - JRST OUTRNG - ADD C,(AB)+3 ;CALCULATE LEFTMOST EXTENT OF THE FIELD - CAILE C,44 ;SHOULD BE LESS THAN WORD SIZE - JRST OUTRNG - LSH B,6 -ONEF: ADD B,(AB)+1 - LSH B,30 ;FORM BYTE POINTER'S LEFT HALF - MOVSI A,TBITS - JRST FINIS - - - -MFUNCTION GETBITS,SUBR - ENTRY 2 - GETYP A,(AB) - PUSHJ P,SAT - CAIN A,SSTORE - JRST .+3 - CAIE A,S1WORD - JRST WTYP1 - GETYP A,(AB)+2 - CAIE A,TBITS - JRST WTYP2 - MOVEI A,(AB)+1 ;GET ADDRESS OF THE WORD - HLL A,(AB)+3 ;GET LEFT HALF OF BYTE POINTER - LDB B,A - MOVSI A,TWORD ; ALWAYS RETURN WORD____ - JRST FINIS - - -MFUNCTION PUTBITS,SUBR - ENTRY - CAML AB,[-2,,0] ;AT LEAST TWO ARGS ? - JRST TFA ;NO, LOSE - GETYP A,(AB) - PUSHJ P,SAT - CAIE A,S1WORD - JRST WTYP1 - GETYP A,(AB)+2 - CAIE A,TBITS - JRST WTYP2 - MOVEI B,0 ;EMPTY THIRD ARG DEFAULT - CAML AB,[-4,,0] ;ONLY TWO ARGS ? - JRST TWOF - CAMGE AB,[-6,,0] ;MORE THAN THREE ARGS ? - JRST TMA ;YES, LOSE - GETYP A,(AB)+4 - PUSHJ P,SAT - CAIE A,S1WORD - JRST WTYP3 - MOVE B,(AB)+5 -TWOF: MOVEI A,(AB)+1 ;ADDRESS OF THE TARGET WORD - HLL A,(AB)+3 ;GET THE LEFT HALF OF THE BYTE POINTER - DPB B,A - MOVE B,(AB)+1 - MOVE A,(AB) ;SAME TYPE AS FIRST ARG'S - JRST FINIS - - -; FUNCTION TO GET THE LENGTH OF LISTS,VECTORS AND CHAR STRINGS - -MFUNCTION LNTHQ,SUBR,[LENGTH?] - - ENTRY 2 - GETYP A,(AB)2 - CAIE A,TFIX - JRST WTYP2 - PUSH P,(AB)3 - JRST LNTHER - - -MFUNCTION LENGTH,SUBR - - ENTRY 1 - PUSH P,[377777777777] -LNTHER: MOVE B,AB ;POINT TO ARGS - PUSHJ P,PTYPE ;GET ITS PRIM TYPE - MOVE B,1(AB) - MOVE C,(AB) - PUSHJ P,@LENTBL(A) ; CALL RIGTH ONE - JRST LFINIS ;OTHERWISE USE 0 - -PRDISP LENTBL,IWTYP1,[[P2WORD,LNLST],[P2NWORD,LNVEC],[PNWORD,LNUVEC] -[PARGS,LNVEC],[PCHSTR,LNCHAR],[PTMPLT,LNTMPL]] - -LNLST: SKIPN C,B ; EMPTY? - JRST LNLST2 ; YUP, LEAVE - MOVEI B,1 ; INIT COUNTER - MOVSI A,TLIST ;WILL BECOME INTERRUPTABLE - HLLM A,CSTO(PVP) ;AND C WILL BE A LIST POINTER -LNLST1: INTGO ;IN CASE CIRCULAR LIST - CAMLE B,(P)-1 - JRST LNLST2 - HRRZ C,(C) ;STEP - JUMPE C,.+2 ;DONE, RETRUN LENGTH - AOJA B,LNLST1 ;COUNT AND GO -LNLST2: SETZM CSTO(PVP) - POPJ P, - -LFINIS: POP P,C - CAMLE B,C - JRST IFALSE - MOVSI A,TFIX ;LENGTH IS AN INTEGER - JRST FINIS - -LNVEC: ASH B,-1 ;GENERAL VECTOR DIVIDE BY 2 -LNUVEC: HLRES B ;GET LENGTH - MOVMS B ;MAKE POS - POPJ P, - -LNCHAR: HRRZ B,C ; GET COUNT - POPJ P, - -LNTMPL: GETYP A,(B) ; GET REAL SAT - SUBI A,NUMSAT+1 - HRLS A ; READY TO HIT TABLE - ADD A,TD.LNT+1(TVP) - JUMPGE A,BADTPL - MOVE C,B ; DATUM TO C - XCT (A) ; GET LENGTH - HLRZS C ; REST COUNTER - SUBI B,(C) ; FLUSH IT OFF - MOVEI B,(B) ; IN CASE FUNNY STUFF - MOVSI A,TFIX - POPJ P, - -; COMPILERS ENTRIES - -CILNT: SUBM M,(P) - PUSH P,[377777,,-1] - MOVE C,A - GETYP A,A - PUSHJ P,CPTYPE ; GET PRIMTYPE - JUMPE A,COMPERR - PUSHJ P,@LENTBL(A) ; DISPATCH - MOVSI A,TFIX - SUB P,[1,,1] -MPOPJ: SUBM M,(P) - POPJ P, - -CILNQ: SUBM M,(P) - PUSH P,C - MOVE C,A - GETYP A,A - PUSHJ P,CPTYPE - JUMPE A,COMPERR - PUSHJ P,@LENTBL(A) - POP P,C - SUBM M,(P) - MOVSI A,TFIX - CAMG B,C - JRST CPOPJ1 - MOVSI A,TFALSE - MOVEI B,0 - POPJ P, - - - -IDNT1: MOVE A,(AB) ;RETURN THE FIRST ARG - MOVE B,1(AB) - JRST FINIS - -MFUNCTION QUOTE,FSUBR - - ENTRY 1 - - GETYP A,(AB) - CAIE A,TLIST ;ARG MUST BE A LIST - JRST WTYP1 - SKIPN B,1(AB) ;SHOULD HAVE A BODY - JRST TFA - - HLLZ A,(B) ; GET IT - MOVE B,1(B) - JSP E,CHKAB - JRST FINIS - -MFUNCTION NEQ,SUBR,[N==?] - - MOVEI D,1 - JRST EQR - -MFUNCTION EQ,SUBR,[==?] - - MOVEI D,0 -EQR: ENTRY 2 - - GETYP A,(AB) ;GET 1ST TYPE - GETYP C,2(AB) ;AND 2D TYPE - MOVE B,1(AB) - CAIN A,(C) ;CHECK IT - CAME B,3(AB) - JRST @TABLE2(D) - JRST @TABLE1(D) - -ITRUTH: MOVSI A,TATOM ;RETURN TRUTH - MOVE B,MQUOTE T - JRST FINIS - -IFALSE: MOVSI A,TFALSE ;RETURN FALSE - MOVEI B,0 - JRST FINIS - -TABLE1: ITRUTH -TABLE2: IFALSE - ITRUTH - - - - -MFUNCTION EMPTY,SUBR,EMPTY? - - ENTRY 1 - - MOVE B,AB - PUSHJ P,PTYPE ;GET PRIMITIVE TYPE - - MOVEI A,(A) - JUMPE A,WTYP1 - SKIPN B,1(AB) ;GET THE ARG - JRST ITRUTH - - CAIN A,PTMPLT ; TEMPLATE? - JRST EMPTPL - CAIE A,P2WORD ;A LIST? - JRST EMPT1 ;NO VECTOR OR CHSTR - JUMPE B,ITRUTH ;0 POINTER MEANS EMPTY LIST - JRST IFALSE - - -EMPT1: CAIE A,PCHSTR ;CHAR STRING? - JRST EMPT2 ;NO, VECTOR - HRRZ B,(AB) ; GET COUNT - JUMPE B,ITRUTH ;0 STRING WINS - JRST IFALSE - -EMPT2: JUMPGE B,ITRUTH - JRST IFALSE - -EMPTPL: PUSHJ P,LNTMPL ; GET LENGTH - JUMPE B,ITRUTH - JRST IFALSE - -; COMPILER'S ENTRY TO EMPTY - -CEMPTY: PUSH P,A - GETYP A,A - PUSHJ P,CPTYPE - POP P,0 - JUMPE A,COMPERR - JUMPE B,YES ; ALWAYS EMPTY - CAIN A,PTMPLT - JRST CEMPTP - CAIN A,P2WORD - JRST NO - CAIN A,PCHSTR - JRST .+3 - JUMPGE B,YES - JRST NO - TRNE 0,-1 ; STRING, SKIP ON ZERO LENGTH FIELD - JRST NO - JRST YES - -CEMPTP: PUSHJ P,LNTMPL - JUMPE B,YES - JRST NO - -MFUNCTION NEQUAL,SUBR,[N=?] - PUSH P,[1] - JRST EQUALR - -MFUNCTION EQUAL,SUBR,[=?] - PUSH P,[0] -EQUALR: ENTRY 2 - - MOVE C,AB ;SET UP TO CALL INTERNAL - MOVE D,AB - ADD D,[2,,2] ;C POINTS TO FIRS, D TO SECOND - PUSHJ P,IEQUAL ;CALL INTERNAL - JRST EQFALS ;NO SKIP MEANS LOSE - JRST EQTRUE -EQFALS: POP P,C - JRST @TABLE2(C) -EQTRUE: POP P,C - JRST @TABLE1(C) - - -; COMPILER'S ENTRY TO =? AND N=? - -CINEQU: PUSH P,[0] - JRST .+2 - -CIEQUA: PUSH P,[1] - PUSH TP,A - PUSH TP,B - PUSH TP,C - PUSH TP,D - MOVEI C,-3(TP) - MOVEI D,-1(TP) - SUBM M,-1(P) ; MAY BECOME INTERRUPTABLE - PUSHJ P,IEQUAL - JRST NOE - POP P,C - SUB TP,[4,,4] ; FLUSH TEMPS - JRST @CTAB1(C) - -NOE: POP P,C - SUB TP,[4,,4] - JRST @CTAB2(C) - -CTAB1: NOM -CTAB2: YESM - NOM - -; INTERNAL EQUAL SUBROUTINE - -IEQUAL: MOVE B,C ;NOW CHECK THE ARGS - PUSHJ P,PTYPE - MOVE B,D - PUSHJ P,PTYPE - GETYP 0,(C) ;NOW CHECK FOR EQ - GETYP B,(D) - MOVE E,1(C) - CAIN 0,(B) ;DONT SKIP IF POSSIBLE WINNER - CAME E,1(D) ;DEFINITE WINNER, SKIP - JRST IEQ1 -CPOPJ1: AOS (P) ;EQ, SKIP RETURN - POPJ P, - - -IEQ1: CAIE 0,(B) ;SKIP IF POSSIBLE MATCH -CPOPJ: POPJ P, ;NOT POSSIBLE WINNERS - JRST @EQTBL(A) ;DISPATCH - -PRDISP EQTBL,CPOPJ,[[P2WORD,EQLIST],[P2NWORD,EQVEC],[PNWORD,EQUVEC] -[PARGS,EQVEC],[PCHSTR,EQCHST],[PTMPLT,EQTMPL]] - - -EQLIST: PUSHJ P,PUSHCD ;PUT ARGS ON STACK - -EQLST1: INTGO ;IN CASE OF CIRCULAR - HRRZ C,-2(TP) ;GET FIRST - HRRZ D,(TP) ;AND 2D - CAIN C,(D) ;EQUAL? - JRST EQLST2 ;YES, LEAVE - JUMPE C,EQLST3 ;NIL LOSES - JUMPE D,EQLST3 - GETYP 0,(C) ;CHECK DEFERMENT - CAIN 0,TDEFER - HRRZ C,1(C) ;PICK UP POINTED TO CROCK - GETYP 0,(D) - CAIN 0,TDEFER - HRRZ D,1(D) ;POINT TO REAL GOODIE - PUSHJ P,IEQUAL ;CHECK THE CARS - JRST EQLST3 ;LOSE - HRRZ C,@-2(TP) ;CDR THE LISTS - HRRZ D,@(TP - HRRZM C,-2(TP) ;AND STORE - HRRZM D,(TP) - JRST EQLST1 - -EQLST2: AOS (P) ;SKIP RETRUN -EQLST3: SUB TP,[4,,4] ;REMOVE CRUFT - POPJ P, - -; HERE FOR HACKING TEMPLATE STRUCTURES - -EQTMPL: PUSHJ P,PUSHCD ; SAVE GOODIES - PUSHJ P,PUSHCD - MOVE C,1(C) ; CHECK REAL SATS - GETYP C,(C) - MOVE D,1(D) - GETYP 0,(D) - CAIE 0,(C) ; SKIP IF WINNERS - JRST EQTMP4 - PUSH P,0 ; SAVE MAGIC OFFSET - MOVE B,-2(TP) - PUSHJ P,TM.LN1 ; RET LENGTH IN B - MOVEI B,-1(B) ; FLUSH FUNNY - HLRZ C,-2(TP) - SUBI B,(C) - PUSH P,B - MOVE C,(TP) ; POINTER TO OTHER GUY - ADD A,TD.LNT+1(TVP) - XCT (A) ; OTHER LENGTH TO B - HLRZ 0,B ; REST OFFSETTER - PUSH P,0 - MOVEI B,-1(B) - HLRZ C,(TP) - SUBI B,(C) - CAME B,-1(P) - JRST EQTMP1 - -EQTMP2: AOS C,(P) - SOSGE -1(P) - JRST EQTMP3 ; WIN!! - - MOVE B,-6(TP) ; POINTER - MOVE 0,-2(P) ; GET MAGIC OFFSET - PUSHJ P,TM.TOE ; GET OFFSET TO TEMPLATE - ADD A,TD.GET+1(TVP) - MOVE A,(A) - ADDI E,(A) - XCT (E) ; VAL TO A AND B - MOVEM A,-3(TP) - MOVEM B,-2(TP) - MOVE C,(P) - MOVE B,-4(TP) ; OTHER GUY - MOVE 0,-2(P) - PUSHJ P,TM.TOE - ADD A,TD.GET+1(TVP) - MOVE A,(A) - ADDI E,(A) - XCT (E) ; GET OTHER VALUE - MOVEM A,-1(TP) - MOVEM B,(TP) - MOVEI C,-3(TP) - MOVEI D,-1(TP) - PUSHJ P,IEQUAL ; RECURSE - JRST EQTMP1 ; LOSER - JRST EQTMP2 ; WINNER - -EQTMP3: AOS -3(P) ; WIN RETURN -EQTMP1: SUB P,[3,,3] ; FLUSH JUNK -EQTMP4: SUB TP,[10,,10] - POPJ P, - - - -EQVEC: HLRE A,1(C) ;GET LENGTHS - HLRZ B,1(D) - CAIE B,(A) ;SKIP IF EQUAL LENGTHS - POPJ P, ;LOSE - JUMPGE A,CPOPJ1 ;SKIP RETRUN WIN - PUSHJ P,PUSHCD ;SAVE ARGS - -EQVEC1: INTGO ;IN CASE LONG VECTOR - MOVE C,(TP) - MOVE D,-2(TP) ;ARGS TO C AND D - PUSHJ P,IEQUAL - JRST EQLST3 - MOVE C,[2,,2] ;GET BUMPER - ADDM C,(TP) - ADDB C,-2(TP) ;BUMP BOTH POINTERS - JUMPL C,EQVEC1 - JRST EQLST2 - -EQUVEC: HLRE A,1(C) ;GET LENGTHS - HLRZ B,1(D) - CAIE B,(A) ;SKIP IF EQUAL - POPJ P, - - HRRZ B,1(C) ;START COMPUTING DOPE WORD LOCN - SUB B,A ;B POINTS TO DOPE WORD - GETYP 0,(B) ;GET UNIFORM TYPE - HRRZ B,1(D) ;NOW FIND OTHER DOPE WORD - SUB B,A - HLRZ B,(B) ;OTHER UNIFORM TYPE - CAIE 0,(B) ;TYPES THE SAME? - POPJ P, ;NO, LOSE - - JUMPGE A,CPOPJ1 ;IF ZERO LENGTH ALREADY WON - - HRLZI B,(B) ;TYPE TO LH - PUSH P,B ;AND SAVED - PUSHJ P,PUSHCD ;SAVE ARGS - -EQUV1: MOVEI C,1(TP) ;POINT TO WHERE WILL GO - PUSH TP,(P) - MOVE A,-3(TP) ;PUSH ONE OF THE VECTORS - PUSH TP,(A) ; PUSH ELEMENT - MOVEI D,1(TP) ;POINT TO 2D ARG - PUSH TP,(P) - MOVE A,-3(TP) ;AND PUSH ITS POINTER - PUSH TP,(A) - PUSHJ P,IEQUAL - JRST UNEQUV - - SUB TP,[4,,4] ;POP TP - MOVE A,[1,,1] - ADDM A,(TP) ;BUMP POINTERS - ADDB A,-2(TP) - JUMPL A,EQUV1 ;JUMP IF STILL MORE STUFF - SUB P,[1,,1] ;POP OFF TYPE - JRST EQLST2 - -UNEQUV: SUB P,[1,,1] - SUB TP,[10,,10] - POPJ P, - - - -EQCHST: HRRZ B,(C) ; GET LENGTHS - HRRZ A,(D) - CAIE A,(B) ;SAME - JRST EQCHS3 ;NO, LOSE - MOVE C,1(C) - MOVE D,1(D) - JUMPE A,EQCHS4 ;BOTH 0 LENGTH, WINS - -EQCHS2: - ILDB 0,C ;GET NEXT CHARS - ILDB E,D - CAIE 0,(E) ; SKIP IF STILL WINNING - JRST EQCHS3 ; NOT = - SOJG A,EQCHS2 - -EQCHS4: AOS (P) -EQCHS3: POPJ P, - -PUSHCD: PUSH TP,(C) - PUSH TP,1(C) - PUSH TP,(D) - PUSH TP,1(D) - POPJ P, - - -; REST/NTH/AT/PUT/GET - -; ARG CHECKER - -ARGS1: MOVE E,[JRST WTYP2] ; ERROR CONDITION FOR 2D ARG NOT FIXED -ARGS2: HLRE 0,AB ; CHECK NO. OF ARGS - ASH 0,-1 ; TO - NO. OF ARGS - AOJG 0,TFA ; 0--TOO FEW - AOJL 0,TMA ; MORE THAT 2-- TOO MANY - MOVEI C,1 ; DEFAULT ARG2 - JUMPN 0,ARGS4 ; GET STRUCTURED ARG -ARGS3: GETYP A,2(AB) - CAIE A,TFIX ; SHOULD BE FIXED NUMBER - XCT E ; DO ERROR THING - SKIPGE C,3(AB) ; BETTER BE NON-NEGATIVE - JRST OUTRNG -ARGS4: MOVEI B,(AB) ; POINT TO STRUCTURED POINTER - PUSHJ P,PTYPE ; GET PRIM TYPE - MOVEI E,(A) ; DISPATCH CODE TO E - MOVE A,(AB) ; GET ARG 1 - MOVE B,1(AB) - POPJ P, - -; REST - -MFUNCTION REST,SUBR - - ENTRY - PUSHJ P,ARGS1 ; GET AND CHECK ARGS - PUSHJ P,@RESTBL(E) ; DO IT BASED ON TYPE - MOVE C,A ; THE FOLLOWING IS TO MAKE STORAGE WORK - GETYP A,(AB) - PUSHJ P,SAT - CAIN A,SSTORE ; SKIP IF NOT STORAGE - MOVSI C,TSTORA ; USE ITS PRIMTYPE - MOVE A,C - JRST FINIS - -PRDISP RESTBL,IWTYP1,[[P2WORD,LREST],[PNWORD,UREST],[P2NWOR,VREST],[PARGS,AREST] -[PCHSTR,SREST],[PTMPLT,TMPRST]] - -; AT - -MFUNCTION AT,SUBR - - ENTRY - PUSHJ P,ARGS1 - SOJL C,OUTRNG - PUSHJ P,@ATTBL(E) - JRST FINIS - -PRDISP ATTBL,IWTYP1,[[P2WORD,LAT],[PNWORD,UAT],[P2NWORD,VAT],[PARGS,AAT] -[PCHSTR,STAT],[PTMPLT,TAT]] - - -; NTH - -MFUNCTION NTH,SUBR - - ENTRY - - PUSHJ P,ARGS1 - SOJL C,OUTRNG - PUSHJ P,@NTHTBL(E) - JRST FINIS - -PRDISP NTHTBL,IWTYP1,[[P2WORD,LNTH],[PNWORD,UNTH],[P2NWOR,VNTH],[PARGS,ANTH] -[PCHSTR,SNTH],[PTMPLT,TMPLNT]] - -; GET - -MFUNCTION GET,SUBR - - ENTRY - MOVE E,IIGETP ; MAKE ARG CHECKER FAIL INTO GETPROP - PUSHJ P,ARGS5 ; CHECK ARGS - SOJL C,OUTRNG - SKIPN E,IGETBL(E) ; GET DISPATCH ADR - JRST IGETP ; REALLY PUTPROP - JUMPE 0,TMA - PUSHJ P,(E) ; DISPATCH - JRST FINIS - -PRDISP IGETBL,0,[[P2WORD,LNTH],[PNWORD,UNTH],[P2NWORD,VNTH],[PARGS,ANTH] -[PCHSTR,SNTH],[PTMPLT,TMPLNT]] - -; GETL - -MFUNCTION GETL,SUBR - - ENTRY - MOVE E,IIGETL ; ERROR HACK - PUSHJ P,ARGS5 - SOJL C,OUTRNG ; LOSER - SKIPN E,IGTLTB(E) - JRST IGETLO ; REALLY GETPL - JUMPE 0,TMA - PUSHJ P,(E) ; DISPATCH - JRST FINIS - -IIGETL: JRST IGETLO - -PRDISP IGTLTB,0,[[P2WORD,LAT],[PNWORD,UAT],[P2NWORD,VAT],[PARGS,AAT] -[PCHSTR,STAT]] - - -; ARG CHECKER FOR PUT/GET/GETL - -ARGS5: HLRE 0,AB ; -# OF ARGS - ASH 0,-1 - ADDI 0,2 ; 0 OR -1 WIN - JUMPG 0,TFA - AOJL 0,TMA ; MORE THAN 3 - JRST ARGS3 ; GET ARGS - -; PUT - -MFUNCTION PUT,SUBR - - ENTRY - MOVE E,IIPUTP - PUSHJ P,ARGS5 ; GET ARGS - SKIPN E,IPUTBL(E) - JRST IPUTP - CAML AB,[-5,,] ; SKIP IF GOOD ARRGS - JRST TFA - SOJL C,OUTRNG - PUSH TP,4(AB) - PUSH TP,5(AB) - PUSHJ P,(E) - MOVE A,(AB) ; RET STRUCTURE - MOVE B,1(AB) - JRST FINIS - -PRDISP IPUTBL,0,[[P2WORD,LPUT],[PNWORD,UPUT],[P2NWORD,VPUT],[PARGS,APUT] -[PCHSTR,SPUT],[PTMPLT,TMPPUT]] - -; IN - -MFUNCTION IN,SUBR - - ENTRY 1 - - MOVEI B,(AB) ; POINT TO ARG - PUSHJ P,PTYPE - MOVS E,A ; REAL DISPATCH TO E - MOVE B,1(AB) - MOVE A,(AB) - GETYP C,A ; IN CASE NEEDED - PUSHJ P,@INTBL(E) - JRST FINIS - -PRDISP INTBL,OTHIN,[[P2WORD,LNTH1],[PNWORD,UIN],[P2NWORD,VIN],[PARGS,AIN] -[PCHSTR,SIN],[PTMPLT,TIN]] - -OTHIN: CAIE C,TLOCN ; ASSOCIATION LOCATIVE - JRST OTHIN1 ; MAYBE LOCD - HLLZ 0,VAL(B) - PUSHJ P,RMONCH - MOVE A,VAL(B) - MOVE B,VAL+1(B) - POPJ P, - -OTHIN1: CAIE C,TLOCD - JRST WTYP1 - JRST VIN - - -; SETLOC - -MFUNCTION SETLOC,SUBR - - ENTRY 2 - - MOVEI B,(AB) ; POINT TO ARG - PUSHJ P,PTYPE ; DO TYPE - MOVS E,A ; REAL TYPE - MOVE B,1(AB) - MOVE C,2(AB) ; PASS ARG - MOVE D,3(AB) - MOVE A,(AB) ; IN CASE - GETYP 0,A - PUSHJ P,@SETTBL(E) - MOVE A,2(AB) - MOVE B,3(AB) - JRST FINIS - -PRDISP SETTBL,OTHSET,[[P2WORD,LSTUF],[PNWORD,USTUF],[P2NWORD,VSTUF],[PARGS,ASTUF] -[PCHSTR,SSTUF],[PTMPLT,TSTUF]] - -OTHSET: CAIE 0,TLOCN ; ASSOC? - JRST OTHSE1 - HLLZ 0,VAL(B) ; GET MONITORS - PUSHJ P,MONCH - MOVEM C,VAL(B) - MOVEM D,VAL+1(B) - POPJ P, - -OTHSE1: CAIE 0,TLOCD - JRST WTYP1 - JRST VSTUF - -; LREST -- REST A LIST IN B BY AMOUNT IN C - -LREST: MOVSI A,TLIST - JUMPE C,CPOPJ - MOVEM A,BSTO(PVP) - -LREST2: INTGO ;CHECK INTERRUPTS - JUMPE B,OUTRNG ; CANT CDR NIL - HRRZ B,(B) ;CDR THE LIST - SOJG C,LREST2 ;COUNT DOWN - SETZM BSTO(PVP) ;RESET BSTO - POPJ P, - - -; VREST -- REST A VECTOR, AREST -- REST AN ARG BLOCK - -VREST: SKIPA A,$TVEC ; FINAL TYPE -AREST: HRLI A,TARGS - ASH C,1 ; TIMES 2 - JRST UREST1 - -; UREST -- REST A UVECTOR - -STORST: SKIPA A,$TSTORA -UREST: MOVSI A,TUVEC -UREST1: JUMPE C,CPOPJ - HRLI C,(C) - JUMPL C,OUTRNG - ADD B,C ; REST IT - CAILE B,-1 ; OUT OF RANGE ? - JRST OUTRNG - POPJ P, - - -; SREST -- REST A STRING - -SREST: JUMPE C,SREST1 - PUSH P,A ; SAVE TYPE WORD - PUSH P,C ; SAVE AMOUNT - MOVEI D,(A) ; GET LENGTH - CAILE C,(D) ; SKIP IF OK - JRST OUTRNG - LDB D,[366000,,B] ;POSITION FIELD OF BYTE POINTER - LDB A,[300600,,B] ;SIZE FIELD - PUSH P,A ;SAVE SIZE - IDIVI D,(A) ;COMPUT BYTES IN 1ST WORD - MOVEI 0,36. ;NOW COMPUTE BYTES PER WORD - IDIVI 0,(A) ;BYTES PER WORD IN 0 - MOVE E,0 ;COPY OF BYTES PER WORD TO E - SUBI 0,(D) ;0 # OF UNSUED BYTES IN 1ST WORD - ADDB C,0 ;C AND 0 NO.OF CHARS FROM WORD BOUNDARY - IDIVI C,(E) ;C/ REL WORD D/ CHAR IN LAST - ADDI C,(B) ;POINTO WORD WITH C - POP P,A ;RESTORE BITS PER BYTE - IMULI A,(D) ;A/ BITS USED IN LAST WORD - MOVEI 0,36. - SUBI 0,(A) ;0 HAS NEW POSITION FIELD - DPB 0,[360600,,B] ;INTO BYTE POINTER - HRRI B,(C) ;POINT TO RIGHT WORD - POP P,C ; RESTORE AMOUNT - POP P,A - SUBI A,(C) ; NEW LENGTH -SREST1: HRLI A,TCHSTR - POPJ P, - -; TMPRST -- REST A TEMPLATE DATA STRUCTURE - -TMPRST: PUSHJ P,TM.TOE ; CHECK ALL BOUNDS ETC. - MOVSI D,(D) - HLL C,D - MOVE B,C ; RET IN B - MOVSI A,TTMPLT - POPJ P, - -; LAT -- GET A LOCATIVE TO A LIST - -LAT: PUSHJ P,LREST ; GET POINTER - JUMPE B,OUTRNG ; YOU LOSE! - MOVSI A,TLOCL ; NEW TYPE - POPJ P, - - -; UAT -- GET A LOCATIVE TO A UVECTOR - -UAT: PUSHJ P,UREST - MOVSI A,TLOCU - JRST POPJL - -; VAT -- GET A LOCATIVE TO A VECTOR - -VAT: PUSHJ P,VREST ; REST IT AND TYPE IT - MOVSI A,TLOCV - JRST POPJL - -; AAT -- GET A LOCATIVE TO AN ARGS BLOCK - -AAT: PUSHJ P,AREST - HRLI A,TLOCA -POPJL: JUMPGE B,OUTRNG ; LOST - POPJ P, - -; STAT -- LOCATIVE TO A STRING - -STAT: PUSHJ P,SREST - TRNN A,-1 ; SKIP IF ANY LEFT - JRST OUTRNG - HRLI A,TLOCS ; LOCATIVE - POPJ P, - -; TAT -- LOCATIVE TO A TEMPLATE - -TAT: PUSHJ P,TMPRST - PUSH TP,A - PUSH TP,B - GETYP A,(B) ; GET REAL SAT - SUBI A,NUMSAT+1 - HRLS A ; READY TO HIT TABLE - ADD A,TD.LNT+1(TVP) - JUMPGE A,BADTPL - MOVE C,B ; DATUM TO C - XCT (A) ; GET LENGTH - HLRZS C ; REST COUNTER - SUBI B,(C) ; FLUSH IT OFF - JUMPE B,OUTRNG - MOVE B,(TP) - SUB TP,[2,,2] - MOVSI A,TLOCT - POPJ P, - - -; LNTH -- NTH OF LIST - -LNTH: PUSHJ P,LAT -LNTH1: PUSHJ P,RMONC0 ; CHECK READ MONITORS - HLLZ A,(B) ; GET GOODIE - MOVE B,1(B) - JSP E,CHKAB ; HACK DEFER - POPJ P, - -; VNTH -- NTH A VECTOR, ANTH -- NTH AN ARGS BLOCK - -ANTH: PUSHJ P,AAT - JRST .+2 - -VNTH: PUSHJ P,VAT -AIN: -VIN: PUSHJ P,RMONC0 - MOVE A,(B) - MOVE B,1(B) - POPJ P, - -; UNTH -- NTH OF UVECTOR - -UNTH: PUSHJ P,UAT -UIN: HLRE C,B ; FIND DW - SUBM B,C - HLLZ 0,(C) ; GET MONITORS - MOVE D,0 - TLZ D,TYPMSK#<-1> - PUSH P,D - PUSHJ P,RMONCH ; CHECK EM - POP P,A - MOVE B,(B) ; AND VALUE - POPJ P, - - -; SNTH -- NTH A STRING - -SNTH: PUSHJ P,STAT -SIN: PUSH TP,A - PUSH TP,B ; SAVE POINT BYTER - MOVEI C,-1(TP) ; FIND DOPE WORD - PUSHJ P,BYTDOP - HLLZ 0,-1(A) ; GET - POP TP,B - POP TP,A - PUSHJ P,RMONCH - ILDB B,B ; GET CHAR - MOVSI A,TCHRS - POPJ P, - -; TIN -- IN OF A TEMPLATE - -TIN: MOVEI C,0 - -; TMPLNT -- NTH A TEMPLATE DATA STRUCTURE - -TMPLNT: ADDI C,1 - PUSHJ P,TM.TOE ; GET POINTER TO INS IN E - ADD A,TD.GET+1(TVP) ; POINT TO GETTER - MOVE A,(A) ; GET VECTOR OF INS - ADDI E,-1(A) ; POINT TO INS - SUBI D,1 - XCT (E) ; DO IT - POPJ P, ; RETURN - -; LPUT -- PUT ON A LIST - -LPUT: PUSHJ P,LAT ; POSITION - POP TP,D - POP TP,C - -; LSTUF -- HERE TO STUFF A LIST ELEMENT - -LSTUF: PUSHJ P,MONCH0 ; CHECK OUT MONITOR BITS - GETYP A,C ; ISOLATE TYPE - PUSHJ P,NWORDT ; NEED TO DEFER? - SOJN A,DEFSTU - HLLM C,(B) - MOVEM D,1(B) ; AND VAL - POPJ P, - -DEFSTU: PUSH TP,$TLIST - PUSH TP,B - PUSH TP,C - PUSH TP,D - PUSHJ P,CELL2 ; GET WORDS - POP TP,1(B) - POP TP,(B) - MOVE E,(TP) - SUB TP,[2,,2] - MOVEM B,1(E) - HLLZ 0,(E) ; GET OLD MONITORS - TLZ 0,TYPMSK ; KILL TYPES - TLO 0,TDEFER ; MAKE DEFERRED - HLLM 0,(E) - POPJ P, - -; VPUT -- PUT ON A VECTOR , APUT -- PUT ON AN RG BLOCK - -APUT: PUSHJ P,AAT - JRST .+2 - -VPUT: PUSHJ P,VAT ; TREAT LIKE VECTOR - POP TP,D ; GET GOODIE BACK - POP TP,C - -; AVSTUF -- CLOBBER ARGS AND VECTORS - -ASTUF: -VSTUF: PUSHJ P,MONCH0 - MOVEM C,(B) - MOVEM D,1(B) - POPJ P, - - - - -; UPUT -- CLOBBER A UVECTOR - -UPUT: PUSHJ P,UAT ; GET IT RESTED - POP TP,D - POP TP,C - -; USTUF -- HERE TO CLOBBER A UVECTOR - -USTUF: HLRE E,B - SUBM B,E ; C POINTS TO DOPE - GETYP A,(E) ; GET UTYPE - GETYP 0,C - CAIE 0,(A) ; CHECK SAMENESS - JRST WRNGUT - HLLZ 0,(E) ; MONITOR BITS IN DOPE WORD - MOVSI A,TUVEC - PUSHJ P,MONCH - MOVEM D,(B) ; SMASH - POPJ P, - -; SPUT -- HERE TO PUT A STRING - -SPUT: PUSHJ P,STAT ; REST IT - POP TP,D - POP TP,C - -; SSTUF -- STUFF A STRING - -SSTUF: GETYP 0,C ; BETTER BE CHAR - CAIE 0,TCHRS - JRST WTYP3 - PUSH TP,A - PUSH TP,B - MOVEI C,-1(TP) ; FIND D.W. - PUSHJ P,BYTDOP - HLLZ 0,(A)-1 ; GET MONITORS - POP TP,B - POP TP,A - MOVSI C,TCHRS - PUSHJ P,MONCH - IDPB D,B ; STASH - POPJ P, - -; TSTUF -- SETLOC A TEMPLATE - -TSTUF: PUSH TP,C - PUSH TP,D - MOVEI C,0 - -; PUTTMP -- TEMPLATE PUTTER - -TMPPUT: ADDI C,1 - PUSHJ P,TM.TOE ; GET E POINTING TO SLOT # - ADD A,TD.PUT+1(TVP) ; POINT TO INS - MOVE A,(A) ; GET VECTOR OF INS - ADDI E,-1(A) - POP TP,B ; NEW VAL TO A AND B - POP TP,A - SUBI D,1 - XCT (E) ; DO IT - JRST BADPUT - POPJ P, - -TM.LN1: SUBI 0,NUMSAT+1 - HRRZ A,0 ; RET FIXED OFFSET - HRLS 0 - ADD 0,TD.LNT+1(TVP) ; USE LENGTHERS FOR TEST - JUMPGE 0,BADTPL - PUSH P,C - MOVE C,B - HRRZS 0 ; POINT TO TABLE ENTRY - PUSH P,A - XCT @0 ; DO IT - POP P,A - POP P,C - POPJ P, - -TM.TBL: MOVEI E,(D) ; TENTATIVE WINNER IN E - TLNN B,-1 ; SKIP IF REST HAIR EXISTS - POPJ P, ; NO, WIN - - PUSH P,A ; SAVE OFFSET - HRLS A ; A IS REL OFFSET TO INS TABLE - ADD A,TD.GET+1(TVP) ; GET ONEOF THE TABLES - MOVE A,(A) ; TABLE POINTER TO A - MOVSI 0,-1(D) ; START SEEING IF PAST TEMP SPEC - ADD 0,A - JUMPL 0,CPOPJA ; JUMP IF E STILL VALID - HLRZ E,B ; BASIC LENGTH TO E - HLRE 0,A ; LENGTH OF TEMPLATE TO 0 - ADDI 0,(E) ; 0 ==> # ELEMENTS IN REPEATING SEQUENCE - MOVNS 0 - SUBM D,E ; E ==> # PAST BASIC WANTED - EXCH 0,E - IDIVI 0,(E) ; A ==> REL REST GUY WANTED - HLRZ E,B - ADDI E,1(A) -CPOPJA: POP P,A - POPJ P, - -; TM.TOE -- GET RIGHT TEMPLATE # IN E -; C/ OBJECT #, B/ OBJECT POINTER - -TM.TOE: GETYP 0,(B) ; GET REAL SAT - MOVEI D,(C) ; OBJ # TO D - HLRZ C,B ; REST COUNT - ADDI D,(C) ; FUDGE FOR REST COUNTER - MOVE C,B ; POINTER TO C - PUSHJ P,TM.LN1 ; GET LENGTH IN B (WATCH LH!) - CAILE D,(B) ; CHECK RANGE - JRST OUTRNG ; LOSER, QUIT - JRST TM.TBL ; GO COMPUTE TABLE OFFSET - - ; ROUTINE FOR COMPILER CALLS RETS CODE IN E GOODIE IN A AND B -; FIXES (P) - -CPTYEE: MOVE E,A - GETYP A,A - PUSHJ P,CPTYPE - JUMPE A,COMPERR - SUBM M,-1(P) - EXCH E,A - POPJ P, - -; COMPILER CALLS TO MANY OF THESE GUYS - -CIREST: PUSHJ P,CPTYEE ; TYPE OF DISP TO E - JUMPL C,OUTRNG - CAIN 0,SSTORE - JRST CIRST1 - PUSHJ P,@RESTBL(E) - JRST MPOPJ - -CIRST1: PUSHJ P,STORST - JRST MPOPJ - -CINTH: PUSHJ P,CPTYEE - SOJL C,OUTRNG ; CHECK BOUNDS - PUSHJ P,@NTHTBL(E) - JRST MPOPJ - -CIAT: PUSHJ P,CPTYEE - SOJL C,OUTRNG - PUSHJ P,@ATTBL(E) - JRST MPOPJ - -CSETLO: PUSHJ P,CTYLOC - MOVSS E ; REAL DISPATCH - GETYP 0,A ; INCASE LOCAS OR LOCD - PUSH TP,C - PUSH TP,D - PUSHJ P,@SETTBL(E) - POP TP,B - POP TP,A - JRST MPOPJ - -CIN: PUSHJ P,CTYLOC - MOVSS E ; REAL DISPATCH - GETYP C,A - PUSHJ P,@INTBL(E) - JRST MPOPJ - -CTYLOC: MOVE E,A - GETYP A,A - PUSHJ P,CPTYPE - SUBM M,-1(P) - EXCH A,E - POPJ P, - -; COMPILER'S PUT,GET AND GETL - -CIGET: PUSH P,[0] - JRST .+2 - -CIGETL: PUSH P,[1] - MOVE E,A - GETYP A,A - PUSHJ P,CPTYPE - EXCH A,E - JUMPE E,CIGET1 ; REAL GET, NOT NTH - GETYP 0,C ; INDIC FIX? - CAIE 0,TFIX - JRST CIGET1 - POP P,E ; GET FLAG - AOS (P) ; ALWAYS SKIP - MOVE C,D ; # TO AN AC - JRST @.+1(E) - CINTH - CIAT - -CIGET1: POP P,E ; GET FLAG - JRST @GETTR(E) ; DO A REAL GET - -GETTR: CIGTPR - CIGETP - -CIPUT: SUBM M,(P) - MOVE E,A - GETYP A,A - PUSHJ P,CPTYPE - EXCH A,E - PUSH TP,-1(TP) ; PAIN AND SUFFERING - PUSH TP,-1(TP) - MOVEM A,-3(TP) - MOVEM B,-2(TP) - JUMPE E,CIPUT1 - GETYP 0,C - CAIE 0,TFIX ; YES DO STRUCT - JRST CIPUT1 - MOVE C,D - SOJL C,OUTRNG ; CHECK BOUNDS - PUSHJ P,@IPUTBL(E) -PMPOPJ: POP TP,B - POP TP,A - JRST MPOPJ - -CIPUT1: PUSHJ P,IPUT - JRST PMPOPJ - -; SMON -- SET MONITOR BITS -; B/ -; D/ OR -; E/ BITS - -SMON: GETYP A,(B) - PUSHJ P,PTYPE ; TO PRIM TYPE - HLRZS A - SKIPE A,SMONTB(A) ; DISPATCH? - JRST (A) - -; COULD STILL BE LOCN OR LOCD - - GETYP A,(B) ; TYPE BACK - CAIE A,TLOCN - JRST SMON2 ; COULD BE LOCD - MOVE C,1(B) ; POINT - HRRI D,VAL(C) ; MAKE INST POINT - JRST SMON3 - -SMON2: CAIE A,TLOCD - JRST WRONGT - - -; SET LIST/TUPLE/ID LOCATIVE - -SMON4: HRR D,1(B) ; POINT TO TYPE WORD -SMON3: XCT D - POPJ P, - -; SET UVEC LOC - -SMON5: HRRZ C,1(B) ; POINT TO TOP OF UV - HLRE 0,1(B) - SUB C,0 ; POINT TO DOPE - HRRI D,(C) ; POINT IN INST - JRST SMON3 - -; SET CHSTR LOC - -SMON6: MOVEI C,(B) ; FOR BYTDOP - PUSHJ P,BYTDOP ; POINT TO DOPE - HRRI D,(A)-1 - JRST SMON3 - -PRDISP SMONTB,0,[[P2WORD,SMON4],[P2NWOR,SMON4],[PARGS,SMON4] -[PNWORD,SMON5],[PCHSTR,SMON6]] - - -; COMPILER'S MONAD? - -CIMON: PUSH P,A - GETYP A,A - PUSHJ P,CPTYPE - JUMPE A,CIMON1 - POP P,A - JRST CEMPTY - -CIMON1: POP P,A - JRST YES - -; FUNCTION TO DECIDE IF FURTHER DECOMPOSITION POSSIBLE - -MFUNCTION MONAD,SUBR,MONAD? - - ENTRY 1 - - MOVE B,AB ; CHECK PRIM TYPE - PUSHJ P,PTYPE - JUMPE A,ITRUTH ;RETURN ARGUMENT - SKIPE B,1(AB) - JRST @MONTBL(A) ;DISPATCH ON PTYPE - JRST ITRUTH - -PRDISP MONTBL,IFALSE,[[P2NWORD,MON1],[PNWORD,MON1],[PARGS,MON1] -[PCHSTR,CHMON],[PTMPLT,TMPMON]] - -MON1: JUMPGE B,ITRUTH ;EMPTY VECTOR - JRST IFALSE - -CHMON: HRRZ B,(AB) - JUMPE B,ITRUTH - JRST IFALSE - -TMPMON: PUSHJ P,LNTMPL - JUMPE B,ITRUTH - JRST IFALSE - -CISTRU: GETYP A,A ; COMPILER CALL - PUSHJ P,ISTRUC - JRST NO - JRST YES - -ISTRUC: PUSHJ P,SAT ; STORAGE TYPE - SKIPE A,PRMTYP(A) - AOS (P) ; SKIP IF WINS - POPJ P, - -; SUBR TO CHECK FOR LOCATIVE - -MFUNCTION %LOCA,SUBR,[LOCATIVE?] - - ENTRY 1 - GETYP A,(AB) - PUSHJ P,LOCQQ - JRST IFALSE - JRST ITRUTH - -; SKIPS IF TYPE IN A IS A LOCATIVE - -LOCQ: GETYP A,(B) ; GET TYPE -LOCQQ: PUSH P,A ; SAVE FOR LOCN/LOCD - PUSHJ P,SAT - MOVE A,PRMTYP(A) - JUMPE A,LOCQ1 - SUB P,[1,,1] - TRNN A,-1 -LOCQ2: AOS (P) - POPJ P, - -LOCQ1: POP P,A ; RESTORE TYPE - CAIE A,TLOCN - CAIN A,TLOCD - JRST LOCQ2 - POPJ P, - - -; MUDDLE SORT ROUTINE - -; P-STACK OFFSETS MUDDLE SORT ROUTINE - -; P-STACK OFFSETS FOR THIS PROGRAM - -XCHNG==0 ; FLAG SAYING AN EXCHANGE HAS HAPPENED -PLACE==-1 ; WHERE WE ARE NOW -UTYP==-2 ; TYPE OF UNIFORM VECTOR -DELT==-3 ; DIST BETWEEN COMPARERS - -MFUNCTION SORT,SUBR - - ENTRY - - HLRZ 0,AB ; CHECK FOR ENOUGH ARGS - CAILE 0,-4 - JRST TFA - GETYP A,(AB) ; 1ST MUST EITHER BE FALSE OR APPLICABLE - CAIN A,TFALSE - JRST SORT1 ; FALSE, OK - PUSHJ P,APLQ ; IS IT APPLICABLE - JRST NAPT ; NO, LOSER - -SORT1: MOVE B,AB - ADD B,[2,,2] ; BUMP TO POINT TO MAIN ARRAY - SETZB D,E ; 0 # OF STUCS AND LNTH - -SORT2: GETYP A,(B) ; GET ITS TYPE - PUSHJ P,PTYPE ; IS IT STRUCTURED? - MOVEI C,1 ; CHECK TYPE OF STRUC - CAIN A,PNWORD ; UVEC? - MOVEI C,0 ; YUP - CAIE A,PARGS - CAIN A,P2NWORD ; VECTOR - MOVNI C,1 - JUMPG C,WTYP - PUSH TP,(B) ; PUSH IT - PUSH TP,1(B) - ADD B,[2,,2] ; GO ON - MOVEI A,1 ; DEFAULT REC SIZE - PUSHJ P,NXFIX ; SIZE OF RECORD? - HLRZ 0,-2(TP) ; -LNTH OF STUC - HRRZ A,(TP) ; LENGTH OF REC - IDIVI 0,(A) ; DIV TO GET - # OF RECS - SKIPN D ; PREV LENGTH EXIST? - MOVE D,0 ; NO USE THIS - CAME 0,D - JRST SLOSE0 - MOVEI A,0 ; DEF REC SIZE - PUSHJ P,NXFIX ; AND OFFSET OF KEY - SUBI E,1 - JUMPL B,SORT2 ; GO ON - HRRM E,4(TB) ; SAVE THAT IN APPROPRIATE PLACE - - MOVE 0,3(TB) - CAMG 0,5(TB) ; CHECK FOR BAD OFFSET - JRST SLOSE3 - -; NOW CHECK WHATEVER STUCTURE THIS IS IS UNIFORM AND HAS GOOD ELEMENTS - - HLRE B,1(TB) ; COMP LENGTH - MOVNS B - HRRZ C,2(TB) ; GET VEC/UVEC FLAG - MOVEI D,(B) - ASH B,(C) ; FUDGE - JUMPE C,.+3 ; SKIP FOR UVEC - MOVE 0,[1,,1] ; ELSE FUDGE KEY OFFSET - ADDM 0,5(TB) - HRRZ 0,3(TB) ; GET REC LENGTH - IDIV D,0 ; # OF RECS - JUMPN E,SLOSE4 - CAIG D,1 ; MORE THAN 1? - JRST SORTD ; NO, DONE ALREADY - GETYP 0,(AB) ; TYPE OF COMPARER - CAIE 0,TFALSE ; IF FALSE, STRUCT MUST CONTAIN FIX,FLOAT,ATOM OR STRING - JRST SORT3 ; USER SUPPLIED COMPARER, LET HIM WORRY - -; NOW CHECK OUT ELEMENT TYPES - - JUMPN C,SORT5 ; JUMP IF GENERAL - MOVEI D,1(B) ; FIND END OF VECTOR - ADD D,1(TB) ; D POINTS TO END - PUSHJ P,TYPCH1 ; GET TYPE AND CHECK IT - JRST SORT6 - -SORT5: MOVE D,1(TB) ; POINT TO VEC - ADD D,5(TB) ; INTO REC TO KEY - PUSHJ P,TYPCH1 - -SAMELP: GETYP C,-1(D) ; GET TYPE - CAIE 0,(C) ; COMPARE TYPE - JRST SLOSE2 - ADD D,3(TB) ; TO NEXT RECORD - JUMPL D,SAMELP - -SORT6: CAIE A,S1WORD ; 1 WORDS? - JRST SORT7 - MOVEI E,INTSRT - MOVSI A,400000 ; SET UP MASK -SORT9: PUSHJ P,ISORT - MOVE A,2(AB) - MOVE B,3(AB) - JRST FINIS - -SORT7: CAIE A,SATOM ; ATOMS? - JRST SORT8 - MOVE E,[-3,,ATMSRT] ; SET UP FOR ATOMS - MOVE A,[430140,,3(D)] ; BIT POINTER FOR ATOMS - JRST SORT9 - -SORT8: MOVE E,[1,,STRSRT] ; MUST BE STRING SORT - MOVE A,[430140,,(D)] ; BYTE POINTER FOR STRINGER - JRST SORT9 - -; TABLES FOR RADIX SORT CHECKERS - -INTSRT==0 -ATMSRT==1 -STRSRT==2 - -TST1: PUSHJ P,I.TST1 - PUSHJ P,A.TST1 - PUSHJ P,S.TST1 - -TST2: PUSHJ P,I.TST2 - PUSHJ P,A.TST2 - PUSHJ P,S.TST2 - -NXBIT: ROT A,-1 - PUSHJ P,A.NXBI - PUSHJ P,S.NXBI - -PREBIT: ROT A,1 - PUSHJ P,A.PREB - PUSHJ P,S.PREB - -ENDTST: SKIPGE A - TLOE A,40 - TLOE A,40 - -; INTEGER SORT SPECIFIC ROUTINES - -I.TST1: JUMPL A,I.TST3 -I.TST4: TDNE A,(D) - AOS (P) - POPJ P, - -I.TST2: JUMPL A,I.TST4 -I.TST3: TDNN A,(D) - AOS (P) - POPJ P, - -; ATOM SORT SPECIFIC ROUTINES - -A.TST1: MOVE D,(D) ; GET AN ATOM - CAMG E,D ; SKIP IF NOT EXHAUSTED - POPJ P, - TLZ A,40 ; TELL A BIT HAS HAPPENED - LDB D,A ; GET THE BIT - SKIPE D - AOS (P) ; SKIP IF ON - POPJ P, - -A.TST2: PUSHJ P,A.TST1 ; USE OTHER ROUTINE - AOS (P) - POPJ P, - -A.NXBI: TLNN A,770000 ; CHECK FOR WORD CHANGE - SUB E,[1,,0] ; FIX WORD CHECKER - IBP A - POPJ P, - -A.PREB: ADD A,[10000,,] ; AH FOR A DECR BYTE POINTER - SKIPG A - CAMG A,[437777,,-1] ; SKIP IF BACKED OVER WORD - POPJ P, - TLZ A,770000 ; CLOBBER POSIT FIELD - SUBI A,1 ; DECR WORD POS FIELD - ADD E,[1,,0] ; AND FIX WORD HACKER - POPJ P, - -; STRING SPECIFIC SORT ROUTINES - -S.TST1: HRLZ 0,-1(D) ; LENGTH OF STRING - IMULI 0,7 ; IN BITS - HRRI 0,-1 ; MAKE SURE BIGGER RH - CAMG 0,E ; SKIP IF MORE BITS LEFT - POPJ P, ; DON TSKIP - TLZ A,40 ; BIT FOUND - HLRZ 0,(D) ; CHECK FOR SIMPLE CASE - HRRZ D,(D) ; POINT TO STRING - CAIN 0,440700 ; SKIP IF HAIRY - JRST S.TST3 - - PUSH P,A ; SAVE BYTER - MOVEI A,440700 ; COMPUTE BITS NOT USED 1ST WORD - SUBI A,@0 - HLRZ 0,(P) ; GET BIT POINTER - SUBI 0,(A) ; UPDATE POS FIELD - JUMPGE 0,.+2 ; NO NEED FOR NEXT WORD - ADD 0,[1,,440000] - MOVSS 0 - HRRZ A,(P) ; REBUILD BYTE POINTER - ADDI 0,(A) - LDB 0,0 ; GET THE DAMN BYTE - POP P,A - JRST .+2 - -S.TST3: LDB 0,A ; GET BYTE FOR EASY CASE - SKIPE 0 - AOS (P) - POPJ P, - -S.TST2: PUSHJ P,S.TST1 - AOS (P) - POPJ P, - -S.NXBI: IBP A ; BUMP BYTER - TLNN A,770000 ; SKIP IF NOT END BIT - IBP A ; SKIP END BIT (NOT USED IN ASCII STRINGS) - ADD E,[1,,0] ; COUNT BIT - POPJ P, - -S.PREB: SUB E,[1,,0] ; DECR CHAR COUNT - ADD A,[10000,,0] ; PLEASE GIVE ME A DECRBYTEPNTR - SKIPG A - CAMG A,[437777,,-1] - POPJ P, - TLC A,450000 ; POINT TO LAST USED BIT IN WORD - SUBI A,1 - POPJ P, - -; SIMPLE RADIX EXCHANGE - -ISORT: MOVE B,1(TB) ; START OF VECTOR - HLRE D,B ; COMPUTE POINTER TO END OF IT - SUBM B,D ; FIND END - MOVEI C,(D) - -ISORT1: PUSH TP,(TB) - PUSH TP,C - MOVE 0,C ; SEE IF HAVE MET AT MIDDLE - SUB 0,3(TB) - ANDI 0,-1 - CAIGE 0,(B) - JRST ISORT7 ; HAVE MET, LEAVE - PUSH TP,(TB) ; SAVE OTHER POINTER - PUSH TP,B - - INTGO - MOVE B,(TP) ; IN CASE MOVED - MOVE C,-2(TP) - -ISORT3: HRRZ D,5(TB) ; OFFSET TO KEY - ADDI D,(B) ; POINT TO KEY - XCT TST1(E) ; CHECK FOR LOSER - JRST ISORT4 - SUB C,3(TB) ; IS THERE ONE TO EXCHANGE WITH - HRRZ D,5(TB) - ADDI D,(C) - XCT TST2(E) ; SKIP IF A POSSIBLE EXCHANGE - JRST ISORT2 ; NO EXCH, KEEP LOOKING - - PUSHJ P,EXCHM ; DO THE EXCHANGE - -ISORT4: ADD B,3(TB) ; HAVE EXCHANGED, MOVE ON -ISORT2: CAME B,C ; MET? - JRST ISORT3 ; MORE TO CHECK - XCT NXBIT(E) ; NEXT BIT - MOVE B,(TP) ; RESTORE TOP POINTER - SUB TP,[2,,2] ; FLUSH IT - XCT ENDTST(E) - JRST ISORT6 - PUSHJ P,ISORT1 ; SORT SUB AREA - MOVE C,(TP) ; AND OTHER SUB AREA - PUSHJ P,ISORT1 -ISORT6: XCT PREBIT(E) -ISORT7: MOVE B,(TP) - SUB TP,[2,,2] - POPJ P, - -; SCHELL SORT FOR USER SUPPLIED COMPARER - -SORT3: ADDI D,1 - ASH D,-1 ; COMPUTE INITIAL D - PUSH P,D ; AND SAVE IT - PUSH P,[0] ; MAY HOLD UTYPE OF VECTOR - HRRZ 0,(TB) ; 0 NON ZERO MEANS GEN VECT - JUMPN 0,SSORT1 ; DONT COMPUTE UTYPE - HLRE C,1(TB) - HRRZ D,1(TB) ; FIND TYPE - SUBI D,(C) - GETYP D,(D) - MOVSM D,(P) ; AND SAVE -SSORT1: PUSH P,[0] ; CURRENT PLACE IN VECTOR - PUSH P,[0] ; EXCHANGE FLAG - PUSH TP,[0] - PUSH TP,[0] - -; OUTER LOOP STARTS HERE - -OUTRLP: SETZM XCHNG(P) ; NO EXHCANGE YET - SETZM PLACE(P) - -INRLP: PUSH TP,(AB) ; PUSH USER COMPARE FCN - PUSH TP,1(AB) - MOVE C,PLACE(P) ; GET CURRENT PLACE - ADD C,1(TB) ; ADD POINTER TO VEC IN - ADD C,5(TB) ; OFFSET TO KEY - PUSHJ P,GETELM - MOVE D,3(TB) - IMUL D,DELT(P) ; TIMES WORDS PER REC - ADD C,D - PUSHJ P,GETELM - MCALL 3,APPLY ; APPLY IT - GETYP 0,A ; TYPE OF RETURN - CAIN 0,TFALSE ; SKIP IF MUST CHANGE - JRST INRLP1 - - MOVE C,1(TB) ; POINT TO START - ADD C,PLACE(P) - MOVE B,3(TB) - IMUL B,DELT(P) - ADD B,C - PUSHJ P,EXCHM ; EXCHANGE THEM - SETOM XCHNG(P) ; SAY AN EXCHANGE TOOK PLACE - -INRLP1: MOVE C,3(TB) ; GET OFFSET - ADDB C,PLACE(P) - MOVE D,3(TB) - IMUL D,DELT(P) - ADD C,D ; CHECK FOR OVERFLOW - ADD C,1(TB) - JUMPL C,INRLP - SKIPE XCHNG(P) ; ANY EXCHANGES? - JRST OUTRLP ; YES, RESET PLACE AND GO - SOSG D,DELT(P) ; SKIP IF DIST WAS 1 - JRST SORTD - ADDI D,2 ; COMPUTE NEW DIST - ASH D,-1 - MOVEM D,DELT(P) - JRST OUTRLP - -SORTD: MOVE A,2(AB) ; DONE, RET 1ST STRUC - MOVE B,3(AB) - JRST FINIS - -; ROUTINE TO GET NEXT ARG IF ITS FIX - -NXFIX: JUMPGE B,NXFIX1 ; NONE LEFT, USE DEFAULT - GETYP 0,(B) ; TYPE - CAIE 0,TFIX ; FIXED? - JRST NXFIX1 ; NO, USE DEFAULT - MOVE A,1(B) ; GET THE NUMBER - ADD B,[2,,2] ; BUMP TO NEXT ARG -NXFIX1: HRLI C,TFIX - TRNE C,-1 ; SKIP IF UV - ASH A,1 ; FUDGE FOR VEC/UVEC - HRLI A,(A) - PUSH TP,C - PUSH TP,A - POPJ P, - -GETELM: SKIPN A,UTYP-1(P) ; SKIP IF UVECT - MOVE A,-1(C) ; GGET GEN TYPE - PUSH TP,A - PUSH TP,(C) - POPJ P, - -TYPCH1: GETYP A,-1(D) ; GET TYPE - MOVEI 0,(A) ; SAVE IN 0 - PUSHJ P,SAT ; AND SAT - CAIE A,SCHSTR ; STRING - CAIN A,SATOM - POPJ P, - CAIN A,S1WORD ; 1-WORD GOODIE - POPJ P, - JRST SLOSE1 - -; HERE TO DO EXCHANGE - -EXCHM: PUSH P,E - PUSH P,A ; SAVE VITAL ACS - PUSH P,B - PUSH P,C - SUB B,1(TB) ; COMPUTE RECORD # - HLRZS B ; TO RH - HRRZ 0,3(TB) ; GET REC LENGTH - IDIV B,0 ; DIV BY REC LENGTH - MOVE C,(P) - SUB C,1(TB) ; SAME FOR C - HLRZS C - IDIV C,0 ; NOW HAVE OTHER RECORD - - HRRE D,4(TB) ; - # OF STUCS - MOVSI D,(D) ; MAKE AN AOBJN POINTER - HRRI D,(TB) ; TO TEMPPS - -RECLP: HRRZ 0,3(D) ; GET REC LENGTH - MOVN E,3(D) ; NOW AOBJN TO REC - MOVSI E,(E) - HRR E,1(D) - MOVEI A,(C) ; COMP START OF REC - IMUL A,0 ; TIMES REC LENGTH - ADDI E,(A) - MOVEI A,(B) - IMUL A,0 - ADD A,1(D) ; POINT TO OTHER RECORD - -EXCHLP: EXCH 0,(A) - EXCH 0,(E) - EXCH 0,(A) - ADDI A,1 - AOBJN E,EXCHLP - - ADD D,[1,,6] ; TO NEXT STRUC - JUMPL D,RECLP ; IF MORE - - POP P,C - POP P,B - POP P,A - POP P,E - POPJ P, - -; FUNCTION TO DETERMINE MEMBERSHIP IN LISTS AND VECTORS - -MFUNCTION MEMBER,SUBR - - MOVE E,[PUSHJ P,EQLTST] ;TEST ROUTINE IN E - JRST MEMB - -MFUNCTION MEMQ,SUBR - - MOVE E,[PUSHJ P,EQTST] ;EQ TESTER - -MEMB: ENTRY 2 - MOVE B,AB ;POINT TO FIRST ARG - PUSHJ P,PTYPE ;CHECK PRIM TYPE - ADD B,[2,,2] ;POINT TO 2ND ARG - PUSHJ P,PTYPE - JUMPE A,WTYP2 ;2ND WRONG TYPE - PUSH TP,(AB) - PUSH TP,1(AB) - MOVE C,2(AB) ; FOR TUPLE CASE - SKIPE B,3(AB) ;GOBBLE LIST VECTOR ETC. POINTER - PUSHJ P,@MEMTBL(A) ;DISPATCH - JRST IFALSE ;OR REPORT LOSSAGE - JRST FINIS - -PRDISP MEMTBL,IWTYP2,[[P2WORD,MEMLST],[PNWORD,MUVEC],[P2NWORD,MEMVEC] -[PARGS,MEMTUP],[PCHSTR,MEMCH],[PTMPLT,MEMTMP]] - - - -MEMLST: MOVSI 0,TLIST ;SET B'S TYPE TO LIST - MOVEM 0,BSTO(PVP) - JUMPE B,MEMLS6 ; EMPTY LIST LOSE IMMEDIATE - -MEMLS1: INTGO ;CHECK INTERRUPTS - MOVEI C,(B) ;COPY POINTER - GETYP D,(C) ;GET TYPE - MOVSI A,(D) ;COPY - CAIE D,TDEFER ;DEFERRED? - JRST MEMLS2 - MOVE C,1(C) ;GET DEFERRED DATUM - GETYPF A,(C) ;GET FULL TYPE WORD -MEMLS2: MOVE C,1(C) ;GET DATUM - XCT E ;DO THE COMPARISON - JRST MEMLS3 ;NO MATCH - MOVSI A,TLIST -MEMLS5: AOS (P) -MEMLS6: SETZM BSTO(PVP) ;RESET B'S TYPE - POPJ P, - -MEMLS3: HRRZ B,(B) ;STEP THROGH - JUMPN B,MEMLS1 ;STILL MORE TO DO -MEMLS4: MOVSI A,TFALSE ;RETURN FALSE - JRST MEMLS6 ;RETURN 0 - -MEMTUP: HRRZ A,C - TLOA A,TARGS -MEMVEC: MOVSI A,TVEC ;CLOBBER B'S TYPE TO VECTOR - JUMPGE B,MEMLS4 ;EMPTY VECTOR - MOVEM A,BSTO(PVP) - -MEMV1: INTGO ;CHECK FOR INTS - GETYPF A,(B) ;GET FULL TYPE - MOVE C,1(B) ;AND DATA - XCT E ;DO COMPARISON INS - JRST MEMV2 ;NOT EQUAL - MOVE A,BSTO(PVP) - JRST MEMLS5 ;RETURN WITH POINTER - -MEMV2: ADD B,[2,,2] ;INCREMENT AND GO - JUMPL B,MEMV1 ;STILL WINNING -MEMV3: MOVEI B,0 - JRST MEMLS4 ;AND RETURN FALSE - -MUVEC: JUMPGE B,MEMLS4 - GETYP A,-1(TP) ;GET TYPE OF GODIE - HLRE C,B ;LOOK FOR UNIFORM TYPE - SUBM B,C ;DOPE POINTER TO C - GETYP C,(C) ;GET THE TYPE - CAIE A,(C) ;ARE THEY THE SAME? - JRST MEMLS4 ;NO, LOSE - MOVSI A,TUVEC - CAIN 0,SSTORE - MOVSI A,TSTORA - PUSH P,A - MOVEM A,BSTO(PVP) - MOVSI A,(C) ;TYPE TO LH - PUSH P,A ; SAVE FOR EACH TEST - -MUVEC1: INTGO ;CHECK OUT INTS - MOVE C,(B) ;GET DATUM - MOVE A,(P) ; GET TYPE - XCT E ;COMPARE - AOBJN B,MUVEC1 ;LOOP TO WINNAGE - SUB P,[1,,1] - POP P,A - JUMPGE B,MEMV3 ;LOSE RETURN - -MUVEC2: JRST MEMLS5 - - -MEMCH: GETYP A,-1(TP) ;IS ARG A SINGLE CHAR - CAIE A,TCHRS ;SKIP IF POSSIBLE WINNER - JRST MEMSTR - MOVEI 0,(C) - MOVE D,(TP) ; AND CHAR - -MEMCH1: SOJL 0,MEMV3 - MOVE E,B - ILDB A,B - CAIE A,(D) ;CHECK IT - SOJA C,MEMCH1 - -MEMCH2: MOVE B,E - MOVE A,C - JRST MEMLS5 - -MEMSTR: CAME E,[PUSHJ P,EQLTST] - JRST MEMV3 - HLRZ A,C - CAIE A, TCHSTR ; A SHOULD HAVE TCHSTR IN RIGHT HALF - JRST MEMV3 - MOVEI 0,(C) ; GET # OF CHAR INTO 0 - ILDB D,(TP) - PUSH P,D ; PUTS 1ST CHAR OF 1ST ARG ONTO STACK - -MEMST1: SOJL 0,MEMLS ; HUNTS FOR FIRST MATCHING CHAR - MOVE E,B - ILDB A,B - CAME A,(P) - SOJA C,MEMST1 ; MATCH FAILS TRY NEXT - - PUSH P,B - PUSH P,E - PUSH P,C - PUSH P,0 - MOVE E,(TP) ; MATCH WINS SAVE OLD VALUES FOR FAILING LOOP - HRRZ C,-1(TP) ; LENGTH OF 1ARG -MEMST2: SOJE C,MEMWN ; WON -RAN OUT OF 1ARG FIRST- - SOJL MEMLSR ; LOST -RAN OUT OF 2ARG- - ILDB A,B - ILDB D,E - CAIN A,(D) ; SKP IF POSSIBLY LOST -BACK TO MEMST1- - JRST MEMST2 - - POP P,0 - POP P,C - POP P,E - POP P,B - SOJA C,MEMST1 - -MEMWN: MOVE B,-2(P) ; SETS UP ARGS LIKE MEMCH2 - HAVE WON - MOVE A,-1(P) - SUB P,[5,,5] - JRST MEMLS5 - -MEMLSR: SUB P,[5,,5] - JRST MEMV3 - -MEMLS: SUB P,[1,,1] - JRST MEMV3 - -; MEMBERSHIP FOR TEMPLATE HACKER - -MEMTMP: GETYP 0,(B) ; GET REAL SAT - PUSH P,E - PUSH P,0 - PUSH TP,A - PUSH TP,B ; SAVE GOOEIE - PUSHJ P,TM.LN1 ; GET LENGTH - MOVEI B,(B) - HLRZ A,(TP) ; FUDGE FOR REST - SUBI B,(A) - PUSH P,B ; SAVE LENGTH - PUSH P,[-1] - POP TP,B - POP TP,A - MOVEM A,BSTO+1(PVP) - -MEMTM1: SETZM BSTO(PVP) - AOS C,(P) - SOSGE -1(P) - JRST MEMTM2 - MOVE 0,-2(P) - PUSHJ P,TMPLNT ; GET ITEM - EXCH C,B ; VALUE TO C, POINTER BACK TO B - MOVE E,-3(P) - MOVSI 0,TTMPLT - MOVEM 0,BSTO(PVP) - XCT E - JRST MEMTM1 - - HRL B,(P) ; DO APPROPRIATE REST - AOS -4(P) -MEMTM2: SUB P,[4,,4] - MOVSI A,TTMPLT - SETZM BSTO(PVP) - POPJ P, - -EQTST: GETYP A,A - GETYP 0,-1(TP) - CAMN C,(TP) ;CHECK VALUE - CAIE 0,(A) ;AND TYPE - POPJ P, - JRST CPOPJ1 - -EQLTST: PUSH TP,BSTO(PVP) - PUSH TP,B - PUSH TP,A - PUSH TP,C - SETZM BSTO(PVP) - PUSH P,E ;SAVE INS - MOVEI C,-5(TP) ;SET UP CALL TO IEQUAL - MOVEI D,-1(TP) - AOS -1(P) ;ASSUME SKIP - PUSHJ P,IEQUAL ;GO INO EQUAL - SOS -1(P) ;UNDO SKIP - SUB TP,[2,,2] ;AND POOP OF CRAP - POP TP,B - POP TP,BSTO(PVP) - POP P,E - POPJ P, - -; COMPILER MEMQ AND MEMBER - -CIMEMB: SKIPA E,[PUSHJ P,EQLTST] - -CIMEMQ: MOVE E,[PUSHJ P,EQTST] - SUBM M,(P) - PUSH TP,A - PUSH TP,B - GETYP A,C - PUSHJ P,CPTYPE - JUMPE A,COMPERR - MOVE B,D ; STRUCT TO B - PUSHJ P,@MEMTBL(A) - TDZA 0,0 ; FLAG NO SKIP - MOVEI 0,1 ; FLAG SKIP - SUB TP,[2,,2] - JUMPE 0,NOM - SOS (P) ; SKIP RETURN - JRST MPOPJ - - -; FUNCTION TO RETURN THE TOP OF A VECTOR , CSTRING OR UNIFORM VECTOR - -MFUNCTION TOP,SUBR - - ENTRY 1 - - MOVE B,AB ;CHECK ARG - PUSHJ P,PTYPE - MOVEI E,(A) - MOVE A,(AB) - MOVE B,1(AB) - PUSHJ P,@TOPTBL(E) ;DISPATCH - JRST FINIS - -PRDISP TOPTBL,IWTYP1,[[PNWORD,UVTOP],[P2NWORD,VTOP],[PCHSTR,CHTOP],[PARGS,ATOP] -[PTMPLT,BCKTOP]] - -BCKTOP: MOVEI B,(B) ; FIX UP POINTER - MOVSI A,TTMPLT - POPJ P, - -UVTOP: SKIPA A,$TUVEC -VTOP: MOVSI A,TVEC - CAIN 0,SSTORE - MOVSI A,TSTORA - HLRE C,B ;AND -LENGTH - HRRZS B - SUB B,C ;POINT TO DOPE WORD - HLRZ D,1(B) ;TOTAL LENGTH - SUBI B,-2(D) ;POINT TO TOP - MOVNI D,-2(D) ;-LENGTH - HRLI B,(D) ;B NOW POINTS TO TOP - POPJ P, - -CHTOP: PUSH TP,A - PUSH TP,B - LDB 0,[360600,,(TP)] ; POSITION FIELD - LDB E,[300600,,(TP)] ; AND SIZE FILED - IDIVI 0,(E) ; 0/ BYTES IN 1ST WORD - MOVEI C,36. ; BITS PER WORD - IDIVI C,(E) ; BYTES PER WORD - PUSH P,C - SUBM C,0 ; UNUSED BYTES I 1ST WORD - ADD 0,-1(TP) ; LENGTH OF WORD BOUNDARIED STRING - MOVEI C,-1(TP) ; GET DOPE WORD - PUSHJ P,BYTDOP - HLRZ C,(A) ; GET LENGTH - SUBI A,-1(C) ; START +1 - MOVEI B,(A) ; SETUP BYTER - HRLI B,440000 - SUB A,(TP) ; WORDS DIFFERENT - IMUL A,(P) ; CHARS EXTRA - SUBM 0,A ; FINAL TOTAL TO A - HRLI A,TCHSTR - POP P,C - DPB E,[300600,,B] - SUB TP,[2,,2] - POPJ P, - - - -ATOP: - -GETATO: HLRE C,B ;GET -LENGTH - HRROS B - SUB B,C ;POINT PAST - GETYP 0,(B) ;GET NEXT TYPE (ASSURED OF BEING EITHER TINFO OR TENTRY) - CAIN 0,TENTRY ;IF ENTRY - JRST EASYTP ;WANT UNEVALUATED ARGS - HRRE C,(B) ;ELSE-- GET NO. OF ARGS (*-2) - SUBI B,(C) ;GO TO TOP - TLCA B,-1(C) ;STORE NUMBER IN TOP POINTER -EASYTP: MOVE B,FRAMLN+ABSAV(B) ;GET ARG POINTER - HRLI A,TARGS - POPJ P, - -; COMPILERS ENTRY TO TOP - -CITOP: PUSHJ P,CPTYEE - CAIN E,P2WORD ; LIST? - JRST COMPERR - PUSHJ P,@TOPTBL(E) - JRST MPOPJ - -; FUNCTION TO CLOBBER THE CDR OF A LIST - -MFUNCTION PUTREST,SUBR,[PUTREST] - ENTRY 2 - - MOVE B,AB ;COPY ARG POINTER - PUSHJ P,PTYPE ;CHECK IT - CAIE A,P2WORD ;LIST? - JRST WTYP1 ;NO, LOSE - ADD B,[2,,2] ;AND NEXT ONE - PUSHJ P,PTYPE - CAIE A,P2WORD - JRST WTYP2 ;NOT LIST, LOSE - HRRZ B,1(AB) ;GET FIRST - MOVE D,3(AB) ;AND 2D LIST - CAIL B,HIBOT - JRST PURERR - HRRM D,(B) ;CLOBBER - MOVE A,(AB) ;RETURN CALLED TYPE - JRST FINIS - - - -; FUNCTION TO BACK UP A VECTOR, UVECTOR OR CHAR STRING - -MFUNCTION BACK,SUBR - - ENTRY - - MOVEI C,1 ;ASSUME BACKING UP ONE - JUMPGE AB,TFA ;NO ARGS IS TOO FEW - CAML AB,[-2,,0] ;SKIP IF MORE THAN 2 ARGS - JRST BACK1 ;ONLY ONE ARG - GETYP A,2(AB) ;GET TYPE - CAIE A,TFIX ;MUST BE FIXED - JRST WTYP2 - SKIPGE C,3(AB) ;GET NUMBER - JRST OUTRNG - CAMGE AB,[-4,,0] ;SKIP IF WINNING NUMBER OF ARGS - JRST TMA -BACK1: MOVE B,AB ;SET UP TO FIND TYPE - PUSHJ P,PTYPE ;GET PRIM TYPE - MOVEI E,(A) - MOVE A,(AB) - MOVE B,1(AB) ;GET DATUM - PUSHJ P,@BCKTBL(E) - JRST FINIS - -PRDISP BCKTBL,IWTYP2,[[PNWORD,BACKU],[P2NWORD,BACKV],[PCHSTR,BACKC],[PARGS,BACKA] -[PTMPLT,BCKTMP]] - -BACKV: LSH C,1 ;GENERAL, DOUBLE AMOUNT - SKIPA A,$TVEC -BACKU: MOVSI A,TUVEC - CAIN 0,SSTORE - MOVSI A,TSTORA - HRLI C,(C) ;TO BOTH HALVES - SUB B,C ;BACK UP VECTOR POINTER - HLRE C,B ;FIND OUT IF OVERFLOW - SUBM B,C ;DOPE POINTER TO C - HLRZ D,1(C) ;GET LENGTH - SUBI C,-2(D) ;POINT TO TOP - ANDI C,-1 - CAILE C,(B) ;SKIP IF A WINNER - JRST OUTRNG ;COMPLAIN -BACKUV: POPJ P, - -BCKTMP: MOVSI C,(C) - SUB B,C ; FIX UP POINTER - JUMPL B,OUTRNG - MOVSI A,TTMPLT - POPJ P, - -BACKC: PUSH TP,A - PUSH TP,B - ADDI A,(C) ; NEW LENGTH - HRLI A,TCHSTR - PUSH P,A ; SAVE COUNT - LDB E,[300600,,B] ;BYTE SIZE - MOVEI 0,36. ;BITS PER WORD - IDIVI 0,(E) ;DIVIDE TO FIND BYTES/WORD - IDIV C,0 ;C/ WORDS BACK, D/BYTES BACK - SUBI B,(C) ;BACK WORDS UP - JUMPE D,CHBOUN ;CHECK BOUNDS - - IMULI 0,(E) ;0/ BITS OCCUPIED BY FULL WORD - LDB A,[360600,,B] ;GET POSITION FILED -BACKC2: ADDI A,(E) ;BUMP - CAIGE A,36. - JRST BACKC1 ;O.K. - SUB A,0 - SUBI B,1 ;DECREMENT POINTER PART -BACKC1: SOJG D,BACKC2 ;DO FOR ALL BYTES - - - - DPB A,[360600,,B] ;FIX UP POINT BYTER -CHBOUN: MOVEI C,-1(TP) - PUSHJ P,BYTDOP ; FIND DOPE WORD - HLRZ C,(A) - SUBI A,-1(C) ; POINT TO TOP - MOVE C,B ; COPY BYTER - IBP C - CAILE A,(C) ; SKIP IF OK - JRST OUTRNG - POP P,A ; RESTORE COUNT - SUB TP,[2,,2] - POPJ P, - - -BACKA: LSH C,1 ;NUMBER TIMES 2 - HRLI C,(C) ;TO BOTH HALVES - SUB B,C ;FIX POINTER - MOVE E,B ;AND SAVE - PUSHJ P,GETATO ;LOOK A T TOP - CAMLE B,E ;COMPARE - JRST OUTRNG - MOVE B,E - POPJ P, - -; COMPILER'S BACK - -CIBACK: PUSHJ P,CPTYEE - JUMPL C,OUTRNG - CAIN E,P2WORD - JRST COMPERR - PUSHJ P,@BCKTBL(E) - JRST MPOPJ - -MFUNCTION STRCOMP,SUBR - - ENTRY 2 - - MOVE A,(AB) - MOVE B,1(AB) - MOVE C,2(AB) - MOVE D,3(AB) - PUSHJ P,ISTRCM - JRST FINIS - -ISTRCM: GETYP 0,A - CAIE 0,TCHSTR - JRST ATMCMP ; MAYBE ATOMS - - GETYP 0,C - CAIE 0,TCHSTR - JRST WTYP2 - - MOVEI A,(A) ; ISOLATR LENGHTS - MOVEI C,(C) - -STRCO2: SOJL A,CHOTHE ; ONE STRING EXHAUSTED, CHECK OTHER - SOJL C,1BIG ; 1ST IS BIGGER - ILDB 0,B - ILDB E,D - CAIN 0,(E) ; SKIP IF DIFFERENT - JRST STRCO2 - CAIL 0,(E) ; SKIP IF 2D BIGGER THAN 1ST - JRST 1BIG -2BIG: MOVNI B,1 - JRST RETFIX - -CHOTHE: JUMPN C,2BIG ; 2 IS BIGGER -SM.CMP: TDZA B,B ; RETURN 0 -1BIG: MOVEI B,1 -RETFIX: MOVSI A,TFIX - POPJ P, - -ATMCMP: CAIE 0,TATOM ; COULD BE ATOM - JRST WTYP1 ; NO, QUIT - GETYP 0,C - CAIE 0,TATOM - JRST WTYP2 - - CAMN B,D ; SAME ATOM? - JRST SM.CMP - ADD B,[3,,3] ; SKIP VAL CELL ETC. - ADD D,[3,,3] - -ATMCM1: MOVE 0,(B) ; GET A WORD OF CHARS - CAME 0,(D) ; SAME? - JRST ATMCM3 ; NO, GET DIF - AOBJP B,ATMCM2 - AOBJN D,ATMCM1 ; MORE TO COMPARE - JRST 1BIG ; 1ST IS BIGGER - - -ATMCM2: AOBJP D,SM.CMP ; EQUAL - JRST 2BIG - -ATMCM3: LSH 0,-1 ; AVOID SIGN LOSSAGE - MOVE C,(D) - LSH C,-1 - CAMG 0,C - JRST 2BIG - JRST 1BIG - - ;ERROR COMMENTS FOR SOME PRIMITIVES - -OUTRNG: PUSH TP,$TATOM - PUSH TP,EQUOTE OUT-OF-BOUNDS - JRST CALER1 - -WRNGUT: PUSH TP,$TATOM - PUSH TP,EQUOTE UNIFORM-VECTORS-TYPE-DIFFERS - JRST CALER1 - -SLOSE0: PUSH TP,$TATOM - PUSH TP,EQUOTE VECTOR-LENGTHS-DIFFER - JRST CALER1 - -SLOSE1: PUSH TP,$TATOM - PUSH TP,EQUOTE KEYS-WRONG-TYPE - JRST CALER1 - -SLOSE2: PUSH TP,$TATOM - PUSH TP,EQUOTE KEY-TYPES-DIFFER - JRST CALER1 - -SLOSE3: PUSH TP,$TATOM - PUSH TP,EQUOTE KEY-OFFSET-OUTSIDE-RECORD - JRST CALER1 - -SLOSE4: PUSH TP,$TATOM - PUSH TP,EQUOTE NON-INTEGER-NO.-OF-RECORDS - JRST CALER1 - -IIGETP: JRST IGETP ;FUDGE FOR MIDAS/STINK LOSSAGE -IIPUTP: JRST IPUTP - - ;SUPER USEFUL ERROR MESSAGES (USED BY WHOLE WORLD) - -WNA: PUSH TP,$TATOM - PUSH TP,EQUOTE WRONG-NUMBER-OF-ARGUMENTS - JRST CALER1 - -TFA: PUSH TP,$TATOM - PUSH TP,EQUOTE TOO-FEW-ARGUMENTS-SUPPLIED - JRST CALER1 - -TMA: PUSH TP,$TATOM - PUSH TP,EQUOTE TOO-MANY-ARGUMENTS-SUPPLIED - JRST CALER1 - -WRONGT: -WTYP: PUSH TP,$TATOM - PUSH TP,EQUOTE ARG-WRONG-TYPE - JRST CALER1 - -IWTYP1: -WTYP1: PUSH TP,$TATOM - PUSH TP,EQUOTE FIRST-ARG-WRONG-TYPE - JRST CALER1 - -IWTYP2: -WTYP2: PUSH TP,$TATOM - PUSH TP,EQUOTE SECOND-ARG-WRONG-TYPE - JRST CALER1 - -BADTPL: PUSH TP,$TATOM - PUSH TP,EQUOTE BAD-TEMPLATE-DATA - JRST CALER1 - -BADPUT: PUSH TP,$TATOM - PUSH TP,EQUOTE TEMPLATE-TYPE-VIOLATION - JRST CALER1 - -WTYP3: PUSH TP,$TATOM - PUSH TP,EQUOTE THIRD-ARG-WRONG-TYPE - JRST CALER1 - -CALER1: MOVEI A,1 -CALER: HRRZ C,FSAV(TB) - PUSH TP,$TATOM - CAMGE C,VECTOP - CAMGE C,VECBOT - SKIPA C,@-1(C) ; SUBRS AND FSUBRS - MOVE C,3(C) ; FOR RSUBRS - PUSH TP,C - ADDI A,1 - ACALL A,ERROR - JRST FINIS - - -GETWNA: HLRZ B,(E)-2 ;GET LOSING COMPARE INSTRUCTION - CAIE B,(CAIE A,) ;AS EXPECTED ? - JRST WNA ;NO, - HRRE B,(E)-2 ;GET DESIRED NUMBER OF ARGS - HLRE A,AB ;GET ACTUAL NUMBER OF ARGS - CAMG B,A - JRST TFA - JRST TMA - -END - TITLE PRINTER ROUTINE FOR MUDDLE - -RELOCATABLE - -.INSRT DSK:MUDDLE > - -.GLOBAL IPNAME,MTYO,FLOATB,RLOOKU,RADX,INAME,INTFCN,LINLN,DOIOTO,BFCLS1,ATOSQ,IGVAL -.GLOBAL BYTPNT,OPNCHN,CHRWRD,IDVAL,CHARGS,CHFRM,CHLOCI,PRNTYP,PRTYPE,IBLOCK,WXCT -.GLOBAL VECBOT,VAL,ITEM,INDIC,IOINS,DIRECT,TYPVEC,CHRPOS,LINPOS,ACCESS,PAGLN,ROOT,PROCID -.GLOBAL BADCHN,WRONGD,CHNCLS,IGET,FNFFL,ILLCHO,BUFSTR,BYTDOP,6TOCHS,PURVEC,STBL,RXCT -.GLOBAL TMPLNT,TD.LNT,MPOPJ,SSPEC1 -.GLOBAL CIPRIN,CIPRNC,CIPRN1,CPATM,CP1ATM,CPCATM,CPSTR,CP1STR,CPCSTR -.GLOBAL CIFLTZ,CITERP,CIUPRS,CPCH - -BUFLNT==100 ; BUFFER LENGTH IN WORDS - -FLAGS==0 ;REGISTER USED TO STORE FLAGS -CARRET==15 ;CARRIAGE RETURN CHARACTER -ESCHAR=="\ ;ESCAPE CHARACTER -SPACE==40 ;SPACE CHARACTER -ATMBIT==200000 ;BIT SWITCH FOR ATOM-NAME PRINT -NOQBIT==020000 ;SWITCH FOR NO ESCAPING OF OUTPUT (PRINC) -SEGBIT==010000 ;SWITCH TO INDICATE PRINTING A SEGMENT -SPCBIT==004000 ;SWITCH TO INDICATE "PRINT" CALL (PUT A SPACE AFTER) -FLTBIT==002000 ;SWITCH TO INDICATE "FLATSIZE" CALL -HSHBIT==001000 ;SWITCH TO INDICATE "PHASH" CALL -TERBIT==000400 ;SWITCH TO INDICATE "TERPRI" CALL -UNPRSE==000200 ;SWITCH TO INDICATE "UNPARSE" CALL -ASCBIT==000100 ;SWITCH TO INDICATE USING A "PRINT" CHANNEL -BINBIT==000040 ;SWITCH TO INDICATE USING A "PRINTB" CHANNEL -PJBIT==400000 -C.BUF==1 -C.PRIN==2 -C.BIN==4 -C.OPN==10 -C.READ==40 - - - MFUNCTION FLATSIZE,SUBR - DEFINE FLTMAX - 4(B) TERMIN - DEFINE FLTSIZ - 2(B)TERMIN -;FLATSIZE TAKES TWO OR THREE ARGUMENTS: THE FIRST IS AN OBJECT THE SECOND -;IS THE MAXIMUM SIZE BEFORE IT GIVES UP AN RETURNS FALSE -;THE THIRD (OPTIONAL) ARGUMENT IS A RADIX - ENTRY - CAMG AB,[-2,,0] ;CHECK NUMBER OF ARGS - CAMG AB,[-6,,0] - JRST WNA - PUSH P,3(AB) - - GETYP A,2(AB) - CAIE A,TFIX - JRST WTYP2 ;SECOND ARG NOT FIX THEN LOSE - - CAMG AB,[-4,,0] ;SEE IF THERE IS A RADIX ARGUMENT - JRST .+3 ; RADIX SUPPLIED - PUSHJ P,GTRADX ; GET THE RADIX FROM OUTCHAN - JRST FLTGO - GETYP A,4(AB) ;CHECK TO SEE THAT RADIX IS FIX - CAIE A,TFIX - JRST WTYP ;ERROR THIRD ARGUMENT WRONG TYPE - MOVE C,5(AB) - PUSHJ P,GETARG ; GET ARGS INTO A AND B -FLTGO: POP P,D ; RESTORE FLATSIZE MAXIMUM - PUSHJ P,CIFLTZ - JFCL - JRST FINIS - - - -MFUNCTION UNPARSE,SUBR - DEFINE UPB - 0(B) TERMIN - - ENTRY - - JUMPGE AB,TFA - MOVE E,TP ;SAVE TP POINTER - - - -;TURN ON FLTBIT TO AVOID PRINTING LOSSAGE -;TURN ON UNPRSE TO CAUSE CHARS TO BE STASHED - CAMG AB,[-2,,0] ;SKIP IF RADIX SUPPLIED - JRST .+3 - PUSHJ P,GTRADX ;GET THE RADIX FROM OUTCHAN - JRST UNPRGO - CAMGE AB,[-5,,0] ;CHECK FOR TOO MANY - JRST TMA - GETYP 0,2(AB) - CAIE 0,TFIX ;SEE IF RADIX IS FIXED - JRST WTYP2 - MOVE C,3(AB) ;GET RADIX - PUSHJ P,GETARG ;GET ARGS INTO A AND B -UNPRGO: PUSHJ P,CIUPRS - JRST FINIS - JRST FINIS - - -GTRADX: MOVE B,IMQUOTE OUTCHAN - PUSH P,0 ;SAVE FLAGS - PUSHJ P,IDVAL ;GET VALUE FOR OUTCHAN - POP P,0 - GETYP A,A ;CHECK TYPE OF CHANNEL - CAIE A,TCHAN - JRST FUNCH1-1 ;IT IS A TP-POINTER - MOVE C,RADX(B) ;GET RADIX FROM OUTCHAN - JRST FUNCH1 - MOVE C,(B)+6 ;GET RADIX FROM STACK - -FUNCH1: CAIG C,1 ;CHECK FOR STRANGE RADIX - MOVEI C,10. ;DEFAULT IF THIS IS THE CASE -GETARG: MOVE A,(AB) - MOVE B,1(AB) - POPJ P, - - -MFUNCTION PRINT,SUBR - ENTRY - PUSHJ P,AGET ; GET ARGS - PUSHJ P,CIPRIN - JRST FINIS - -MFUNCTION PRINC,SUBR - ENTRY - PUSHJ P,AGET ; GET ARGS - PUSHJ P,CIPRNC - JRST FINIS - -MFUNCTION PRIN1,SUBR - ENTRY - PUSHJ P,AGET - PUSHJ P,CIPRN1 - JRST FINIS - JRST PRIN01 ;CALL IPRINT AFTER SAVING STUFF - - -MFUNCTION TERPRI,SUBR - ENTRY - PUSHJ P,AGET1 - PUSHJ P,CITERP - JRST FINIS - - -CITERP: SUBM M,(P) - MOVSI 0,TERBIT+SPCBIT ; SET UP FLAGS - PUSHJ P,TESTR ; TEST FOR GOOD CHANNEL - MOVEI A,CARRET ; MOVE IN CARRIAGE-RETURN - PUSHJ P,PITYO ; PRINT IT OUT - MOVEI A,12 ; LINE-FEED - PUSHJ P,PITYO - MOVSI A,TFALSE ; RETURN A FALSE - MOVEI B,0 - JRST MPOPJ ; RETURN - - -TESTR: GETYP E,A - CAIN E,TCHAN ; CHANNEL? - JRST TESTR1 ; OK? - CAIE E,TTP - JRST BADCHN - HLRZS 0 - IOR 0,A ; RESTORE FLAGS - HRLZS 0 - POPJ P, -TESTR1: HRRZ E,-4(B) ; GET IN FLAGS FROM CHANNEL - TRC E,C.PRIN+C.OPN ; CHECK TO SEE THAT CHANNEL IS GOOD - TRNE E,C.PRIN+C.OPN - JRST BADCHN ; ITS A LOSER - TRNE E,C.BIN - JRST PSHNDL ; DON'T HANDLE BINARY - TLO ASCBIT ; ITS ASCII - POPJ P, ; ITS A WINNER - -PSHNDL: PUSH TP,C ; SAVE ARGS - PUSH TP,D - PUSH TP,A ; PUSH CHANNEL ONTO STACK - PUSH TP,B - PUSHJ P,BPRINT ; CHECK BUFFER - POP TP,B - POP TP,A - POP TP,D - POP TP,C - POPJ P, - - - ;CIUPRS NEEDS A RADIX IN C AND A TYPE-OBJECT PAIR IN A,B - -CIUPRS: SUBM M,(P) ; MODIFY M-POINTER - MOVE E,TP ; SAVE TP-POINTER - PUSH TP,[0] ; SLOT FOR FIRST STRING COPY - PUSH TP,[0] - PUSH TP,[0] ; AND SECOND STRING - PUSH TP,[0] - PUSH TP,A ; SAVE OBJECTS - PUSH TP,B - PUSH TP,$TTP ; SAVE TP POINTER - PUSH TP,E - PUSH P,C - MOVE D,[377777,,-1] ; MOVE IN MAXIMUM NUMBER FOR FLATSIZE - PUSHJ P,CIFLTZ ; FIND LENGTH OF STRING - FATAL UNPARSE BLEW IT - PUSH TP,$TFIX ; MOVE IN ARGUMENT FOR ISTRING - PUSH TP,B - MCALL 1,ISTRING - POP TP,E ; RESTORE TP-POINTER - SUB TP,[1,,1] ;GET RID OF TYPE WORD - MOVEM A,1(E) ; SAVE RESULTS - MOVEM A,3(E) - MOVEM B,2(E) - MOVEM B,4(E) - POP TP,B ; RESTORE THE WORLD - POP TP,A - POP P,C - MOVSI 0,FLTBIT+UNPRSE ; SET UP FLAGS - PUSHJ P,CUSET - JRST MPOPJ ; RETURN - - - -; FOR CIFLTZ C CONTAINS THE RADIX, D THE MAXIMUM NUMBER OF CHARACTERS, -; A,B THE TYPE-OBJECT PAIR - -CIFLTZ: SUBM M,(P) - MOVE E,TP ; SAVE POINTER - PUSH TP,$TFIX ; PUSH ON FLATSIZE COUNT - PUSH TP,[0] - PUSH TP,$TFIX ; PUSH ON FLATSIZE MAXIMUM - PUSH TP,D - MOVSI 0,FLTBIT ; MOVE ON FLATSIZE FLAG - PUSHJ P,CUSET ; CONTINUE - JRST MPOPJ - SOS (P) ; SKIP RETURN - JRST MPOPJ ; RETURN - -; CUSET IS THE ROUTINE USED BY FLATSIZE AND UNPARSE TO DO THE PUSHING,POPING AND CALLING -; NEEDED TO GET A RESULT. - -CUSET: PUSH TP,$TFIX ; PUSH ON RADIX - PUSH TP,C - PUSH TP,$TPDL - PUSH TP,P ; PUSH ON RETURN POINTER IN CASE FLATSIZE GETS A FALSE - PUSH TP,A ; SAVE OBJECTS - PUSH TP,B - MOVSI C,TTP ; CONSTRUCT TP-POINTER - HLR C,FLAGS ; SAVE FLAGS IN TP-POINTER - MOVE D,E - PUSH TP,C ; PUSH ON CHANNEL - PUSH TP,D - PUSHJ P,IPRINT ; GO TO INTERNAL PRINTER - POP TP,B ; GET IN TP POINTER - MOVE TP,B ; RESTORE POINTER - TLNN FLAGS,UNPRSE ; SEE IF UNPARSE CALL - JRST FLTGEN ; ITS A FLATSIZE - MOVE A,UPB+3 ; RETURN STRING - MOVE B,UPB+4 - POPJ P, ; DONE -FLTGEN: MOVE A,FLTSIZ-1 ; GET IN COUNT - MOVE B,FLTSIZ - AOS (P) - POPJ P, ; EXIT - - -; CIPRIN,CIPRNC,CIPRN1,CPATM,CP1ATM,CPCATM,CPSTR,CP1STR,CPCSTR ALL ASSUME -; THAT C,D CONTAIN THE OBJECT AND A AND B CONTAIN THE CHANNEL - -CIPRIN: SUBM M,(P) - MOVSI 0,SPCBIT ; SET UP FLAGS - PUSHJ P,TPRT ; PRINT INITIALIZATION - PUSHJ P,IPRINT - JRST TPRTE ; EXIT - -CIPRN1: SUBM M,(P) - MOVEI FLAGS,0 ; SET UP FLAGS - PUSHJ P,TPR1 ; INITIALIZATION - PUSHJ P,IPRINT ; PRINT IT OUT - JRST TPR1E ; EXIT - -CIPRNC: SUBM M,(P) - MOVSI FLAGS,NOQBIT ; SET UP FLAGS - PUSHJ P,TPR1 ; INITIALIZATION - PUSHJ P,IPRINT - JRST TPR1E ; EXIT - -; INITIALIZATION FOR PRINT ROUTINES - -TPRT: PUSHJ P,TESTR ; SEE IF CHANNEL IS OK - PUSH TP,C ; SAVE ARGUMENTS - PUSH TP,D - PUSH TP,A ; SAVE CHANNEL - PUSH TP,B - MOVEI A,CARRET ; PRINT CARRIAGE RETURN - PUSHJ P,PITYO - MOVEI A,12 ; AND LF - PUSHJ P,PITYO - MOVE A,-3(TP) ; MOVE IN ARGS - MOVE B,-2(TP) - POPJ P, - -; EXIT FOR PRINT ROUTINES - -TPRTE: POP TP,B ; RESTORE CHANNEL - MOVEI A,SPACE ; PRINT TRAILING SPACE - PUSHJ P,PITYO - SUB TP,[1,,1] ; GET RID OF CHANNEL TYPE-WORD - POP TP,B ; RETURN WHAT WAS PASSED - POP TP,A - JRST MPOPJ ; EXIT - -; INITIALIZATION FOR PRIN1 AND PRINC ROUTINES - -TPR1: PUSHJ P,TESTR ; SEE IF CHANNEL IS OK - PUSH TP,C ; SAVE ARGS - PUSH TP,D - PUSH TP,A ; SAVE CHANNEL - PUSH TP,B - MOVE A,-3(TP) ; GET ARGS - MOVE B,-2(TP) - POPJ P, - -; EXIT FOR PRIN1 AND PRINC ROUTINES - -TPR1E: SUB TP,[2,,2] ; REMOVE CHANNEL - POP TP,B ; RETURN ARGUMENTS THAT WERE GIVEN - POP TP,A - JRST MPOPJ ; EXIT - - - -CPATM: SUBM M,(P) - MOVSI C,TATOM ; GET TYPE FOR BINARY - MOVE 0,$SPCBIT ; SET UP FLAGS - PUSHJ P,TPRT ; PRINT INITIALIZATION - PUSHJ P,CPATOM ; PRINT IT OUT - JRST TPRTE ; EXIT - -CP1ATM: SUBM M,(P) - MOVE C,$TATOM - MOVEI FLAGS,0 ; SET UP FLAGS - PUSHJ P,TPR1 ; INITIALIZATION - PUSHJ P,CPATOM ; PRINT IT OUT - JRST TPR1E ; EXIT - -CPCATM: SUBM M,(P) - MOVE C,$TATOM - MOVSI FLAGS,NOQBIT ; SET UP FLAGS - PUSHJ P,TPR1 ; INITIALIZATION - PUSHJ P,CPATOM ; PRINT IT OUT - JRST TPR1E ; EXIT - - -; THIS ROUTINE IS USD TO PRINT ONE CHARACTER. THE CHANNEL IS IN A AND B THE -; CHARACTER IS IN C. -CPCH: SUBM M,(P) - MOVSI FLAGS,NOQBIT - MOVE C,$TCHRS - PUSHJ P,TESTR ; SEE IF CHANNEL IS GOOD - PUSH P,D - MOVE A,D ; MOVE IN CHARACTER FOR PITYO - PUSHJ P,PITYO - MOVE A,$TCHRST ; RETURN THE CHARACTER - POP P,B - JRST MPOPJ - - - - -CPSTR: SUBM M,(P) - HRLI C,TCHSTR - MOVSI 0,SPCBIT ; SET UP FLAGS - PUSHJ P,TPRT ; PRINT INITIALIZATION - PUSHJ P,CPCHST ; PRINT IT OUT - JRST TPRTE ; EXIT - -CP1STR: SUBM M,(P) - HRLI C,TCHSTR - MOVEI FLAGS,0 ; SET UP FLAGS - PUSHJ P,TPR1 ; INITIALIZATION - PUSHJ P,CPCHST ; PRINT IT OUT - JRST TPR1E ; EXIT - -CPCSTR: SUBM M,(P) - HRLI C,TCHSTR - MOVSI FLAGS,NOQBIT ; SET UP FLAGS - PUSHJ P,TPR1 ; INITIALIZATION - PUSHJ P,CPCHST ; PRINT IT OUT - JRST TPR1E ; EXIT - - -CPATOM: PUSH TP,A ; COPY ARGS FOR INTERNAL SAKE - PUSH TP,B - PUSH P,0 ; ATOM CALLER ROUTINE - PUSH P,C - JRST PATOM - -CPCHST: PUSH TP,A ; COPY ARGS FOR INTERNAL SAKE - PUSH TP,B - PUSH P,0 ; STRING CALLER ROUTINE - PUSH P,C - JRST PCHSTR - - - -AGET: MOVEI FLAGS,0 - SKIPL E,AB ; COPY ARG POINTER - JRST TFA ;NO ARGS IS AN ERROR - ADD E,[2,,2] ;POINT AT POSSIBLE CHANNEL - JRST COMPT -AGET1: MOVE E,AB ; GET COPY OF AB - MOVSI FLAGS,TERBIT - -COMPT: PUSH TP,$TFIX ;LEAVE ROOM ON STACK FOR ONE CHANNEL - PUSH TP,[0] - JUMPGE E,DEFCHN ;IF NO CHANNEL ARGUMENT, USE CURRENT BINDING - CAMG E,[-2,,0] ;IF MORE ARGS THEN ERROR - JRST TMA - MOVE A,(E) ;GET CHANNEL - MOVE B,(E)+1 - JRST NEWCHN - -DEFCHN: MOVE B,IMQUOTE OUTCHAN - MOVSI A,TATOM - PUSH P,FLAGS ;SAVE FLAGS - PUSHJ P,IDVAL ;GET VALUE OF OUTCHAN - POP P,0 - -NEWCHN: TLNE FLAGS,TERBIT ; SEE IF TERPRI - POPJ P, - MOVE C,(AB) ; GET ARGS - MOVE D,1(AB) - POPJ P, - -; HERE IF USING A PRINTB CHANNEL - -BPRINT: TLO FLAGS,BINBIT - SKIPE BUFSTR(B) ; ANY OUTPUT BUFFER? - POPJ P, - -; HERE TO GENERATE A STRING BUFFER - - PUSH P,FLAGS - MOVEI A,BUFLNT ; GET BUFFER LENGTH - PUSHJ P,IBLOCK ; MAKE A BUFFER - MOVSI 0,TWORD+.VECT. ; CLOBBER U TYPE - MOVEM 0,BUFLNT(B) - SETOM (B)) ; -1 THE BUFFER - MOVEI C,1(B) - HRLI C,(B) - BLT C,BUFLNT-1(B) - HRLI B,440700 - MOVE C,(TP) - MOVEM B,BUFSTR(C) ; STOR BYTE POINTER - MOVE 0,[TCHSTR,,BUFLNT*5] - MOVEM 0,BUFSTR-1(C) - POP P,FLAGS - - MOVE B,(TP) - POPJ P, - - -IPRINT: PUSH P,C ; SAVE C - PUSH P,FLAGS ;SAVE PREVIOUS FLAGS - PUSH TP,A ;SAVE ARGUMENT ON TP-STACK - PUSH TP,B - - INTGO ;ALLOW INTERRUPTS HERE - - GETYP A,-1(TP) ;GET THE TYPE CODE OF THE ITEM - SKIPE C,PRNTYP+1(TVP) ; USER TYPE TABLE? - JRST PRDISP -NORMAL: CAIG A,NUMPRI ;PRIMITIVE? - JRST @PRTYPE(A) ;YES-DISPATCH - JRST PUNK ;JUMP TO ERROR ROUTINE IF CODE TOO GREAT - -; HERE FOR USER PRINT DISPATCH - -PRDISP: ADDI C,(A) ; POINT TO SLOT - ADDI C,(A) - SKIPE (C) ; SKIP EITHER A LOSER OR JRST DISP - JRST PRDIS1 ; APPLY EVALUATOR - SKIPN C,1(C) ; GET ADDR OR GO TO PURE DISP - JRST NORMAL - JRST (C) - -PRDIS1: PUSH P,C ; SAVE C - PUSH TP,[TATOM,,-1] ; PUSH ON OUTCHAN FOR SPECBIND - PUSH TP,IMQUOTE OUTCHAN - PUSH TP,-5(TP) - PUSH TP,-5(TP) - PUSH TP,[0] - PUSH TP,[0] - PUSHJ P,SPECBIND - POP P,C ; RESTORE C - PUSH TP,(C) ; PUSH ARGS FOR APPLY - PUSH TP,1(C) - PUSH TP,-9(TP) - PUSH TP,-9(TP) - MCALL 2,APPLY ; APPLY HACKER TO OBJECT - MOVEI E,-8(TP) - PUSHJ P,SSPEC1 ;UNBIND OUTCHAN - SUB TP,[6,,6] ; POP OFF STACK - JRST PNEXT - -; PRINT DISPATCH TABLE - -DISTBL PRTYPE,PUNK,[[TATOM,PATOM],[TFORM,PFORM],[TSEG,PSEG],[TFIX,PFIX] -[TFLOAT,PFLOAT],[TLIST,PLIST],[TVEC,PVEC],[TCHRS,PCHRS],[TCHSTR,PCHSTR] -[TARGS,PARGS],[TUVEC,PUVEC],[TDEFER,PDEFER],[TINTH,PINTH],[THAND,PHAND] -[TILLEG,ILLCH],[TRSUBR,PRSUBR],[TENTER,PENTRY],[TPCODE,PPCODE],[TTYPEW,PTYPEW] -[TTYPEC,PTYPEC],[TTMPLT,TMPRNT],[TLOCD,LOCPT1]] - -PUNK: MOVE C,TYPVEC+1(TVP) ; GET AOBJN-POINTER TO VECTOR OF TYPE ATOMS - GETYP B,-1(TP) ; GET THE TYPE CODE INTO REG B - LSH B,1 ; MULTIPLY BY TWO - HRL B,B ; DUPLICATE IT IN THE LEFT HALF - ADD C,B ; INCREMENT THE AOBJN-POINTER - JUMPGE C,PRERR ; IF POSITIVE, INDEX > VECTOR SIZE - - MOVE B,-2(TP) ; MOVE IN CHANNEL - PUSHJ P,RETIF1 ; START NEW LINE IF NO ROOM - MOVEI A,"# ; INDICATE TYPE-NAME FOLLOWS - PUSHJ P,PITYO - MOVE A,(C) ; GET TYPE-ATOM - MOVE B,1(C) - PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT - PUSH TP,-3(TP) - PUSHJ P,IPRINT ; PRINT ATOM-NAME - SUB TP,[2,,2] ; POP STACK - MOVE B,-2(TP) ; MOVE IN CHANNEL - PUSHJ P,SPACEQ ; MAYBE SPACE - MOVE B,(B) ; RESET THE REAL ARGUMENT POINTER - HRRZ A,(C) ; GET THE STORAGE-TYPE - ANDI A,SATMSK - CAIG A,NUMSAT ; SKIP IF TEMPLATE - JRST @UKTBL(A) ; USE DISPATCH TABLE ON STORAGE TYPE - JRST TMPRNT ; PRINT TEMPLATED DATA STRUCTURE - -DISTBS UKTBL,POCTAL,[[S2WORD,PLIST],[S2NWORD,PVEC],[SNWORD,PUVEC],[SATOM,PATOM] -[SCHSTR,PCHSTR],[SFRAME,PFRAME],[SARGS,PARGS],[SPVP,PPVP],[SLOCID,LOCPT],[SLOCA,LOCP] -[SLOCV,LOCP],[SLOCU,LOCP],[SLOCS,LOCP],[SLOCL,LOCP],[SLOCN,LOCP],[SASOC,ASSPNT] -[SLOCT,LOCP]] - - ; SELECK AN ILLEGAL - -ILLCH: MOVEI B,-1(TP) - JRST ILLCHO - - ; PRINT INTERRUPT HANDLER - -PHAND: MOVE B,-2(TP) ; MOVE CHANNEL INTO B - PUSHJ P,RETIF1 - MOVEI A,"# - PUSHJ P,PITYO ; SAY "FUNNY TYPE" - MOVSI A,TATOM - MOVE B,MQUOTE HANDLER - PUSH TP,-3(TP) ; PUSH CHANNEL ON FOR IPRINT - PUSH TP,-3(TP) - PUSHJ P,IPRINT ; PRINT THE TYPE NAME - SUB TP,[2,,2] ; POP CHANNEL OFF STACK - MOVE B,-2(TP) ; GET CHANNEL - PUSHJ P,SPACEQ ; SPACE MAYBE - SKIPN B,(TP) ; GET ARG BACK - JRST PNEXT - MOVE A,INTFCN(B) ; PRINT FUNCTION FOR NOW - MOVE B,INTFCN+1(B) - PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT - PUSH TP,-3(TP) - PUSHJ P,IPRINT ; PRINT THE INT FUNCTION - SUB TP,[2,,2] ; POP CHANNEL OFF - JRST PNEXT - -; PRINT INT HEADER - -PINTH: MOVE B,-2(TP) ; GET CHANNEL INTO B - PUSHJ P,RETIF1 - MOVEI A,"# - PUSHJ P,PITYO - MOVSI A,TATOM ; AND NAME - MOVE B,MQUOTE IHEADER - PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT - PUSH TP,-3(TP) - PUSHJ P,IPRINT - MOVE B,-4(TP) ; GET CHANNEL INTO B - PUSHJ P,SPACEQ ; MAYBE SPACE - SKIPN B,-2(TP) ; INT HEADER BACK - JRST PNEXT - MOVE A,INAME(B) ; GET NAME - MOVE B,INAME+1(B) - PUSHJ P,IPRINT - SUB TP,[2,,2] ; CLEAN OFF STACK - JRST PNEXT - - -; PRINT ASSOCIATION BLOCK - -ASSPNT: MOVEI A,"( ; MAKE IT BE (ITEN INDIC VAL) - MOVE B,-2(TP) ; GET CHANNEL INTO B - PUSHJ P,PRETIF ; MAKE ROOM AND PRINT - SKIPA C,[-3,,0] ; # OF FIELDS -ASSLP: PUSHJ P,SPACEQ - MOVE D,(TP) ; RESTORE GOODIE - ADD D,ASSOFF(C) ; POINT TO FIELD - MOVE A,(D) ; GET IT - MOVE B,1(D) - PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT - PUSH TP,-3(TP) - PUSHJ P,IPRINT ; AND PRINT IT - SUB TP,[2,,2] ; POP OFF CHANNEL - AOBJN C,ASSLP - - MOVEI A,") - MOVE B,-2(TP) ; GET CHANNEL INTO B - PUSHJ P,PRETIF ; CLOSE IT - JRST PNEXT - -ASSOFF: ITEM - INDIC - VAL - ; PRINT TYPE-C AND TYPE-W - -PTYPEW: HRRZ A,(TP) ; POSSIBLE RH - HLRZ B,(TP) - MOVE C,MQUOTE TYPE-W - JRST PTYPEX - -PTYPEC: HRRZ B,(TP) - MOVEI A,0 - MOVE C,MQUOTE TYPE-C - -PTYPEX: PUSH P,B - PUSH P,A - PUSH TP,$TATOM - PUSH TP,C - MOVEI A,2 - MOVE B,-4(TP) ; GET CHANNEL INTO B - PUSHJ P,RETIF ; ROOM TO START? - MOVEI A,"% - PUSHJ P,PITYO - MOVEI A,"< - PUSHJ P,PITYO - POP TP,B ; GET NAME - POP TP,A - PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT - PUSH TP,-3(TP) - PUSHJ P,IPRINT ; AND PRINT IT AS 1ST ELEMENT - SUB TP,[2,,2] ; POP OFF CHANNEL - MOVE B,-2(TP) ; GET CHANNEL INTO B - PUSHJ P,SPACEQ ; MAYBE SPACE - MOVE A,-1(P) ; TYPE CODE - ASH A,1 - HRLI A,(A) ; MAKE SURE WINS - ADD A,TYPVEC+1(TVP) - JUMPL A,PTYPX1 ; JUMP FOR A WINNER - PUSH TP,$TATOM - PUSH TP,EQUOTE BAD-TYPE-CODE - JRST CALER1 - -PTYPX1: MOVE B,1(A) ; GET TYPE NAME - HRRZ A,(A) ; AND SAT - ANDI A,SATMSK - MOVEM A,-1(P) ; AND SAVE IT - MOVSI A,TATOM - PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT - PUSH TP,-3(TP) - PUSHJ P,IPRINT ; OUT IT GOES - SUB TP,[2,,2] ; POP OFF CHANNEL - MOVE B,-2(TP) ; GET CHANNEL INTO B - PUSHJ P,SPACEQ ; MAYBE SPACE - MOVE A,-1(P) ; GET SAT BACK - MOVE B,@STBL(A) - MOVSI A,TATOM ; AND PRINT IT - PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT - PUSH TP,-3(TP) - PUSHJ P,IPRINT - SUB TP,[2,,2] ; POP OFF STACK - SKIPN B,(P) ; ANY EXTRA CRAP? - JRST PTYPX2 - - MOVE B,-2(TP) ; GET CHANNEL INTO B - PUSHJ P,SPACEQ - MOVE B,(P) - MOVSI A,TFIX - PUSH TP,-3(TP) ; PUSH CHANNELS FOR IPRINT - PUSH TP,-3(TP) - PUSHJ P,IPRINT ; PRINT EXTRA - SUB TP,[2,,2] ; POP OFF CHANNEL - -PTYPX2: MOVEI A,"> - MOVE B,-2(TP) ; GET CHANNEL INTO B - PUSHJ P,PRETIF - SUB P,[2,,2] ; FLUSH CRUFT - JRST PNEXT - - ; PRINT PURE CODE POINTER - -PPCODE: MOVEI A,2 - MOVE B,-2(TP) ; GET CHANNEL INTO B - PUSHJ P,RETIF - MOVEI A,"% - PUSHJ P,PITYO - MOVEI A,"< - PUSHJ P,PITYO - MOVSI A,TATOM ; PRINT SUBR CALL - MOVE B,MQUOTE PCODE - PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT - PUSH TP,-3(TP) - PUSHJ P,IPRINT - MOVE B,-4(TP) ; GET CHANNEL INTO B - PUSHJ P,SPACEQ ; MAYBE SPACE? - HLRZ A,-2(TP) ; OFFSET TO VECTOR - ADD A,PURVEC+1(TVP) ; SLOT TO A - MOVE A,(A) ; SIXBIT NAME - PUSH P,FLAGS - PUSHJ P,6TOCHS ; TO A STRING - POP P,FLAGS - PUSHJ P,IPRINT - MOVE B,-4(TP) ; GET CHANNEL INTO B - PUSHJ P,SPACEQ - HRRZ B,-2(TP) ; GET OFFSET - MOVSI A,TFIX - PUSHJ P,IPRINT - SUB TP,[2,,2] ; POP CHANNEL OFF STACK - MOVEI A,"> - MOVE B,-2(TP) ; GET CHANNEL INTO B - PUSHJ P,PRETIF ; CLOSE THE FORM - JRST PNEXT - - - ; PRINT SUB-ENTRY TO RSUBR - -PENTRY: MOVE B,(TP) ; GET BLOCK - GETYP A,(B) ; TYPE OF 1ST ELEMENT - CAIE A,TRSUBR ; RSUBR, OK - JRST PENT1 - MOVSI A,TATOM ; UNLINK - HLLM A,(B) - MOVE A,1(B) - MOVE A,3(A) - MOVEM A,1(B) -PENT2: MOVEI A,2 ; CHECK ROOM - MOVE B,-2(TP) ; GET CHANNEL INTO B - PUSHJ P,RETIF - MOVEI A,"% ; SETUP READ TIME MACRO - PUSHJ P,PITYO - MOVEI A,"< - PUSHJ P,PITYO - MOVSI A,TATOM - MOVE B,MQUOTE RSUBR-ENTRY - PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT - PUSH TP,-3(TP) - PUSHJ P,IPRINT - MOVE B,-4(TP) - PUSHJ P,SPACEQ ; MAYBE SPACE - MOVEI A,"' ; QUOTE TO AVOID EVALING IT - PUSHJ P,PRETIF - MOVSI A,TVEC - MOVE B,-2(TP) - PUSHJ P,IPRINT - MOVE B,-4(TP) ; GET CHANNEL INTO B - PUSHJ P,SPACEQ - MOVE B,-2(TP) - HRRZ B,2(B) - MOVSI A,TFIX - PUSHJ P,IPRINT - MOVEI A,"> - SUB TP,[2,,2] ; POP CHANNEL OFF STACK - MOVE B,-2(TP) ; GET CHANNEL INTO B - PUSHJ P,PRETIF - JRST PNEXT - -PENT1: CAIN A,TATOM - JRST PENT2 - PUSH TP,$TATOM - PUSH TP,EQUOTE BAD-ENTRY-BLOCK - JRST CALER1 - - ; HERE TO PRINT TEMPLATED DATA STRUCTURE - -TMPRNT: PUSH P,FLAGS ; SAVE FLAGS - MOVE A,(TP) ; GET POINTER - GETYP A,(A) ; GET SAT - PUSH P,A ; AND SAVE IT - MOVEI A,"{ ; OPEN SQUIGGLE - MOVE B,-2(TP) ; GET CHANNEL INTO B - PUSHJ P,PRETIF ; PRINT WITH CHECKING - HLRZ A,(TP) ; GET AMOUNT RESTED OFF - SUBI A,1 - PUSH P,A ; AND SAVE IT - MOVE A,-1(P) ; GET SAT - SUBI A,NUMSAT+1 ; FIXIT UP - HRLI A,(A) - ADD A,TD.LNT+1(TVP) ; CHECK FOR WINNAGE - JUMPGE A,BADTPL ; COMPLAIN - HRRZS C,(TP) ; GET LENGTH - XCT (A) ; INTO B - SUB B,(P) ; FUDGE FOR RESTS - MOVEI B,-1(B) ; FUDGE IT - PUSH P,B ; AND SAVE IT - -TMPRN1: AOS C,-1(P) ; GET ELEMENT OF INTEREST - SOSGE (P) ; CHECK FOR ANY LEFT - JRST TMPRN2 ; ALL DONE - - MOVE B,(TP) ; POINTER - HRRZ 0,-2(P) ; SAT - PUSHJ P,TMPLNT ; GET THE ITEM - MOVE FLAGS,-3(P) ; RESTORE FLAGS - PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT - PUSH TP,-3(TP) - PUSHJ P,IPRINT ; PRINT THIS ELEMENT - SUB TP,[2,,2] ; POP CHANNEL OFF STACK - MOVE B,-2(TP) ; GET CHANNEL INTO B - SKIPE (P) ; IF NOT LAST ONE THEN - PUSHJ P,SPACEQ ; SEPARATE WITH A SPACE - JRST TMPRN1 - -TMPRN2: SUB P,[4,,4] - MOVE B,-2(TP) - MOVEI A,"} ; CLOSE THIS GUY - PUSHJ P,PRETIF - JRST PNEXT - - - ; RSUBR PRINTING ROUTINES. ON PRINTB CHANNELS, WRITES OUT -; COMPACT BINARY. ON PRINT CHANNELS ALL IS ASCII - -PRSUBR: MOVE A,(TP) ; GET RSUBR IN QUESTION - GETYP A,(A) ; CHECK FOR PURE RSUBR - CAIN A,TPCODE - JRST PRSBRP ; PRINT IT SPECIAL WAY - - TLNN FLAGS,BINBIT ; SKIP IF BINARY OUTPUT - JRST ARSUBR - - PUSH P,FLAGS - MOVSI A,TRSUBR ; FIND FIXUPS - MOVE B,(TP) - HLRE D,1(B) ; -LENGTH OF CODE VEC - PUSH P,D ; SAVE SAME - MOVSI C,TATOM - MOVE D,MQUOTE RSUBR - PUSHJ P,IGET ; GO GET THEM - JUMPE B,RCANT ; NO FIXUPS, BINARY LOSES - PUSH TP,A ; SAVE FIXUP LIST - PUSH TP,B - - MOVNI A,1 ; USE ^C AS MARKER FOR RSUBR - MOVE FLAGS,-1(P) ; RESTORE FLAGS - MOVE B,-4(TP) ; GET CHANNEL FOR PITYO - PUSHJ P,PITYO ; OUT IT GOES - -PRSBR1: MOVE B,-4(TP) - PUSHJ P,BFCLS1 ; FLUSH OUT CURRENT BUFFER - - MOVE B,-4(TP) ; CHANNEL BACK - MOVN E,(P) ; LENGTH OF CODE - PUSH P,E - HRROI A,(P) ; POINT TO SAME - PUSHJ P,DOIOTO ; OUT GOES COUNT - MOVSI C,TCODE - MOVEM C,ASTO(PVP) ; FOR IOT INTERRUPTS - MOVE A,-2(TP) ; GET POINTER TO CODE - MOVE A,1(A) - PUSHJ P,DOIOTO ; IOT IT OUT - POP P,E - ADDI E,1 ; UPDATE ACCESS - ADDM E,ACCESS(B) - SETZM ASTO(PVP) ; UNSCREW A - -; NOW PRINT OUT NORMAL RSUBR VECTOR - - MOVE FLAGS,-1(P) ; RESTORE FLAGS - SUB P,[1,,1] - MOVE B,-2(TP) ; GET RSUBR VECTOR - PUSHJ P,PRBODY ; PRINT ITS BODY - -; HERE TO PRINT BINARY FIXUPS - - MOVEI E,0 ; 1ST COMPUTE LENGTH OF FIXUPS - SKIPN A,(TP) ; LIST TO A - JRST PRSBR5 ; EMPTY, DONE - JUMPL A,UFIXES ; JUMP IF FIXUPS IN UVECTOR FORM - ADDI E,1 ; FOR VERS - -PRSBR6: HRRZ A,(A) ; NEXT? - JUMPE A,PRSBR5 - GETYP B,(A) - CAIE B,TDEFER ; POSSIBLE STRING - JRST PRSBR7 ; COULD BE ATOM - MOVE B,1(A) ; POSSIBLE STRINGER - GETYP C,(B) - CAIE C,TCHSTR ; YES!!! - JRST BADFXU ; LOSING FIXUPS - HRRZ C,(B) ; # OF CHARS TO C - ADDI C,5+5 ; ROUND AND ADD FOR COUNT - IDIVI C,5 ; TO WORDS - ADDI E,(C) - JRST FIXLST ; COUNT FOR USE LIST ETC. - -PRSBR7: GETYP B,(A) ; GET TYPE - CAIE B,TATOM - JRST BADFXU - ADDI E,1 - -FIXLST: HRRZ A,(A) ; REST IT TO OLD VAL - JUMPE A,BADFXU - GETYP B,(A) ; FIX? - CAIE B,TFIX - JRST BADFXU - MOVEI D,1 - HRRZ A,(A) ; TO USE LIST - JUMPE A,BADFXU - GETYP B,(A) - CAIE B,TLIST - JRST BADFXU ; LOSER - MOVE C,1(A) ; GET LIST - -PRSBR8: JUMPE C,PRSBR9 - GETYP B,(C) ; TYPE OK? - CAIE B,TFIX - JRST BADFXU - HRRZ C,(C) - AOJA D,PRSBR8 ; LOOP - -PRSBR9: ADDI D,2 ; ROUND UP - ASH D,-1 ; DIV BY 2 FOR TWO GOODIES PER HWORD - ADDI E,(D) - JRST PRSBR6 - -PRSBR5: PUSH P,E ; SAVE LENGTH OF FIXUPS - PUSH TP,$TUVEC ; SLOT FOR BUFFER POINTER - PUSH TP,[0] - -PFIXU1: MOVE B,-6(TP) ; START LOOPING THROUGH CHANNELS - PUSHJ P,BFCLS1 ; FLUSH BUFFER - MOVE B,-6(TP) ; CHANNEL BACK - MOVEI C,BUFSTR-1(B) ; SETUP BUFFER - PUSHJ P,BYTDOP ; FIND D.W. - SUBI A,BUFLNT+1 - HRLI A,-BUFLNT - MOVEM A,(TP) - MOVE E,(P) ; LENGTH OF FIXUPS - SETZB C,D ; FOR EOUT - PUSHJ P,EOUT - MOVE C,-2(TP) ; FIXUP LIST - MOVE E,1(C) ; HAVE VERS - PUSHJ P,EOUT ; OUT IT GOES - -PFIXU2: HRRZ C,(C) ; FIRST THING - JUMPE C,PFIXU3 ; DONE? - GETYP A,(C) ; STRING OR ATOM - CAIN A,TATOM ; MUST BE STRING - JRST PFIXU4 - MOVE A,1(C) ; POINT TO POINTER - HRRZ D,(A) ; LENGTH - IDIVI D,5 - PUSH P,E ; SAVE REMAINDER - MOVEI E,1(D) - MOVNI D,(D) - MOVSI D,(D) - PUSH P,D - PUSHJ P,EOUT - MOVEI D,0 -PFXU1A: MOVE A,1(C) ; RESTORE POINTER - HRRZ A,1(A) ; BYTE POINTER - ADD A,(P) - MOVE E,(A) - PUSHJ P,EOUT - MOVE A,[1,,1] - ADDB A,(P) - JUMPL A,PFXU1A - MOVE D,-1(P) ; LAST WORD - MOVE A,1(C) - HRRZ A,1(A) - ADD A,(P) - SKIPE E,D - MOVE E,(A) ; LAST WORD OF CHARS - IOR E,PADS(D) - PUSHJ P,EOUT ; OUT - SUB P,[1,,1] - JRST PFIXU5 - -PADS: ASCII /#####/ - ASCII /####/ - ASCII /###/ - ASCII /##/ - ASCII /#/ - -PFIXU4: HRRZ E,(C) ; GET CURRENT VAL - MOVE E,1(E) - PUSHJ P,ATOSQ ; GET SQUOZE - JRST BADFXU - TLO E,400000 ; USE TO DIFFERENTIATE BETWEEN STRING - PUSHJ P,EOUT - -; HERE TO WRITE OUT LISTS - -PFIXU5: HRRZ C,(C) ; POINT TO CURRENT VALUE - HRLZ E,1(C) - HRRZ C,(C) ; POINT TO USES LIST - HRRZ D,1(C) ; GET IT - -PFIXU6: TLCE D,400000 ; SKIP FOR RH - HRLZ E,1(D) ; SETUP LH - JUMPG D,.+3 - HRR E,1(D) - PUSHJ P,EOUT ; WRITE IT OUT - HRR D,(D) - TRNE D,-1 ; SKIP IF DONE - JRST PFIXU6 - - TRNE E,-1 ; SKIP IF ZERO BYTE EXISTS - MOVEI E,0 - PUSHJ P,EOUT - JRST PFIXU2 ; DO NEXT - -PFIXU3: HLRE C,(TP) ; -AMNT LEFT IN BUFFER - MOVN D,C ; PLUS SAME - ADDI C,BUFLNT ; WORDS USED TO C - JUMPE C,PFIXU7 ; NONE USED, LEAVE - MOVSS C ; START SETTING UP BTB - MOVN A,C ; ALSO FINAL IOT POINTER - HRR C,(TP) ; PDL POINTER PART OF BTB - SUBI C,1 - HRLI D,C ; CONTINUE SETTING UP BTB - POP C,@D ; MOVE 'EM DOWN - TLNE C,-1 - JRST .-2 - HRRI A,@D ; OUTPUT POINTER - ADDI A,1 - MOVSI B,TUVEC - MOVEM B,ASTO(PVP) - MOVE B,-6(TP) - PUSHJ P,DOIOTO ; WRITE IT OUT - SETZM ASTO(PVP) - -PFIXU7: SUB TP,[4,,4] - SUB P,[2,,2] - JRST PNEXT - -; ROUTINE TO OUTPUT CONTENTS OF E - -EOUT: MOVE B,-6(TP) ; CHANNEL - AOS ACCESS(B) - MOVE A,(TP) ; BUFFER POINTER - MOVEM E,(A) - AOBJP A,.+3 ; COUNT AND GO - MOVEM A,(TP) - POPJ P, - - SUBI A,BUFLNT ; SET UP IOT POINTER - HRLI A,-BUFLNT - MOVEM A,(TP) ; RESET SAVED POINTER - MOVSI 0,TUVEC - MOVEM 0,ASTO(PVP) - MOVSI 0,TLIST - MOVEM 0,DSTO(PVP) - MOVEM 0,CSTO(PVP) - PUSHJ P,DOIOTO ; OUT IT GOES - SETZM ASTO(PVP) - SETZM CSTO(PVP) - SETZM DSTO(PVP) - POPJ P, - -; HERE IF UVECOR FORM OF FIXUPS - -UFIXES: PUSH TP,$TUVEC - PUSH TP,A ; SAVE IT - -UFIX1: MOVE B,-6(TP) ; GET SAME - PUSHJ P,BFCLS1 ; FLUSH OUT BUFFER - HLRE C,(TP) ; GET LENGTH - MOVMS C - PUSH P,C - HRROI A,(P) ; READY TO ZAP IT OUT - PUSHJ P,DOIOTO ; ZAP! - SUB P,[1,,1] - HLRE C,(TP) ; LENGTH BACK - MOVMS C - ADDI C,1 - ADDM C,ACCESS(B) ; UPDATE ACCESS - MOVE A,(TP) ; NOW THE UVECTOR - MOVSI C,TUVEC - MOVEM C,ASTO(PVP) - PUSHJ P,DOIOTO ; GO - SETZM ASTO(PVP) - SUB P,[1,,1] - SUB TP,[4,,4] - JRST PNEXT - -RCANT: PUSH TP,$TATOM - PUSH TP,EQUOTE RSUBR-LACKS-FIXUPS - JRST CALER1 - - -BADFXU: PUSH TP,$TATOM - PUSH TP,EQUOTE BAD-FIXUPS - JRST CALER1 - -PRBODY: TDZA C,C ; FLAG SAYING FLUSH CODE -PRBOD1: MOVEI C,1 ; PRINT CODE ALSO - PUSH P,FLAGS - PUSH TP,$TRSUBR - PUSH TP,B - PUSH P,C - MOVEI A,"[ ; START VECTOR TEXT - MOVE B,-6(TP) ; GET CHANNEL FOR PITYO - PUSHJ P,PITYO - POP P,C - MOVE B,(TP) ; RSUBR BACK - JUMPN C,PRSON ; GO START PRINTING - MOVEI A,"0 ; PLACE SAVER FOR CODE VEC - MOVE B,-6(TP) ; GET CHANNEL FOR PITYO - PUSHJ P,PITYO - -PRSBR2: MOVE B,[2,,2] ; BUMP VECTOR - ADDB B,(TP) - JUMPGE B,PRSBR3 ; NO SPACE IF LAST - MOVE B,-6(TP) ; GET CHANNEL FOR SPACEQ - PUSHJ P,SPACEQ - SKIPA B,(TP) ; GET BACK POINTER -PRSON: JUMPGE B,PRSBR3 - GETYP 0,(B) ; SEE IF RSUBR POINTED TO - CAIN 0,TENTER - JRST .+3 ; JUMP IF RSUBR ENTRY - CAIE 0,TRSUBR ; YES! - JRST PRSB10 ; COULD BE SUBR/FSUBR - MOVE C,1(B) ; GET RSUBR - PUSH P,0 ; SAVE TYPE FOUND - GETYP 0,2(C) ; SEE IF ATOM - CAIE 0,TATOM - JRST PRSBR4 - MOVE B,3(C) ; GET ATOM NAME - PUSHJ P,IGVAL ; GO LOOK - MOVE C,(TP) ; ORIG RSUBR BACK - GETYP A,A - POP P,0 ; DESIRED TYPE - CAIE 0,(A) ; SAME TYPE - JRST PRSBR4 - MOVE D,1(C) - MOVE 0,3(D) ; NAME OF RSUBR IN QUESTION - CAME 0,3(B) ; WIN? - JRST PRSBR4 - MOVEM 0,1(C) - MOVSI A,TATOM - MOVEM A,(C) ; UNLINK - -PRSBR4: MOVE FLAGS,(P) ; RESTORE FLAGS - MOVE B,(TP) - MOVE A,(B) - MOVE B,1(B) ; PRINT IT - PUSH TP,-7(TP) ; PUSH CHANNEL FOR IPRINT - PUSH TP,-7(TP) - PUSHJ P,IPRINT - SUB TP,[2,,2] ; POP OFF CHANNEL - JRST PRSBR2 - -PRSB10: CAIE 0,TSUBR ; SUBR? - CAIN 0,TFSUBR - JRST .+2 - JRST PRSBR4 - MOVE C,1(B) ; GET LOCN OF SUBR OR FSUBR - MOVE C,@-1(C) ; NAME OF IT - MOVEM C,1(B) ; SMASH - MOVSI C,TATOM ; AND TYPE - MOVEM C,(B) - JRST PRSBR4 - -PRSBR3: MOVEI A,"] - MOVE B,-6(TP) - PUSHJ P,PRETIF ; CLOSE IT UP - SUB TP,[2,,2] ; FLUSH CRAP - POP P,FLAGS - POPJ P, - - - ; HERE TO PRINT PURE RSUBRS - -PRSBRP: MOVEI A,2 ; WILL "%<" FIT? - MOVE B,-2(TP) ; GET CHANNEL FOR RETIF - PUSHJ P,RETIF - MOVEI A,"% - PUSHJ P,PITYO - MOVEI A,"< - PUSHJ P,PITYO - MOVSI A,TATOM - MOVE B,MQUOTE RSUBR - PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT - PUSH TP,-3(TP) - PUSHJ P,IPRINT ; PRINT IT OUT - SUB TP,[2,,2] ; POP OFF CHANNEL - MOVE B,-2(TP) - PUSHJ P,SPACEQ ; MAYBE SPACE - MOVEI A,"' ; QUOTE THE VECCTOR - PUSHJ P,PRETIF - MOVE B,(TP) ; GET RSUBR BODY BACK - PUSH TP,$TFIX ; STUFF THE STACK - PUSH TP,[0] - PUSHJ P,PRBOD1 ; PRINT AND UNLINK - SUB TP,[2,,2] ; GET JUNK OFF STACK - MOVE B,-2(TP) ; GET CHANNEL FOR RETIF - MOVEI A,"> - PUSHJ P,PRETIF - JRST PNEXT - -; HERE TO PRINT ASCII RSUBRS - -ARSUBR: PUSH P,FLAGS ; SAVE FROM GET - MOVSI A,TRSUBR - MOVE B,(TP) - MOVSI C,TATOM - MOVE D,MQUOTE RSUBR - PUSHJ P,IGET ; TRY TO GET FIXUPS - POP P,FLAGS - JUMPE B,PUNK ; NO FIXUPS LOSE - GETYP A,A - CAIE A,TLIST ; ARE FIXUPS A LIST? - JRST PUNK ; NO, AGAIN LOSE - PUSH TP,$TLIST - PUSH TP,B ; SAVE FIXUPS - MOVEI A,17. - - MOVE B,-4(TP) - PUSHJ P,RETIF - PUSH P,[440700,,[ASCIZ /% - PUSHJ P,PRETIF - JRST PNEXT - - ; HERE TO DO LOCATIVES (PRINT CONTENTS THEREOF) - -LOCP: PUSH TP,-1(TP) - PUSH TP,-1(TP) - PUSH P,0 - MCALL 1,IN ; GET ITS CONTENTS FROM "IN" - POP P,0 - PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT - PUSH TP,-3(TP) - PUSHJ P,IPRINT ; PRINT IT - SUB TP,[2,,2] ; POP CHANNEL OFF STACK - JRST PNEXT - ;INTERNAL SUBROUTINE TO HANDLE CHARACTER OUTPUT -;B CONTAINS CHANNEL -;PRINTER ITYO USED FOR FLATSIZE FAKE OUT -PITYO: TLNN FLAGS,FLTBIT - JRST ITYO -PITYO1: PUSH TP,[TTP,,0] ; PUSH ON TP POINTER - PUSH TP,B - TLNE FLAGS,UNPRSE ;SKIPS UNPRSE NOT SET - JRST ITYO+2 - AOS FLTSIZ ;FLATSIZE DOESN'T PRINT - ;INSTEAD IT COUNTS THE CHARACTERS THAT WOULD BE OUTPUT - SOSGE FLTMAX ;UNLESS THE MAXIMUM IS EXCEEDED - JRST .+4 - POP TP,B ; GET CHANNEL BACK - SUB TP,[1,,1] - POPJ P, - MOVEI E,(B) ; GET POINTER FOR UNBINDING - PUSHJ P,SSPEC1 - MOVE P,UPB+8 ; RESTORE P - POP TP,B ; GET BACK TP POINTER - PUSH P,0 ; SAVE FLAGS - MOVE TP,B ; RESTORE TP -PITYO3: MOVEI C,(TB) - CAILE C,1(TP) - JRST PITYO2 - POP P,0 ; RESTORE FLAGS - MOVSI A,TFALSE ;IN WHICH CASE IT IMMEDIATELY GIVES UP AND RETURNS FALSE - MOVEI B,0 - POPJ P, - -PITYO2: HRR TB,OTBSAV(TB) ; RESTORE TB - JRST PITYO3 - - - ;THE REAL THING -;NOTE THAT THE FOLLOWING CODE HAS BUGS IF IT IS PRINTING OUT LONG -;CHARACTER STRINGS -; (NOTE THAT THE ABOVE COMMENT, IF TRUE, SHOULD NOT BE ADMITTED.) -ITYO: PUSH TP,$TCHAN - PUSH TP,B - PUSH P,FLAGS ;SAVE STUFF - PUSH P,C -ITYOCH: PUSH P,A ;SAVE OUTPUT CHARACTER - - -ITYO1: TLNE FLAGS,UNPRSE ;SKIPS UNPRSE NOT SET - JRST UNPROUT ;IF FROM UNPRSE, STASH IN STRING - CAIE A,^L ;SKIP IF THIS IS A FORM-FEED - JRST NOTFF - SETZM LINPOS(B) ;ZERO THE LINE NUMBER - JRST ITYXT - -NOTFF: CAIE A,15 ;SKIP IF IT IS A CR - JRST NOTCR - SETZM CHRPOS(B) ;ZERO THE CHARACTER POSITION - PUSHJ P,WXCT ;OUTPUT THE C-R - PUSHJ P,AOSACC ; BUMP COUNT - AOS C,LINPOS(B) ;ADD ONE TO THE LINE NUMBER - CAMG C,PAGLN(B) ;SKIP IF THIS TAKES US PAST PAGE END - JRST ITYXT1 - - SETZM LINPOS(B) ;ZERO THE LINE POSITION -; PUSHJ P,WXCT ; REMOVED FOR NOW -; PUSHJ P,AOSACC -; MOVEI A,^L ; DITTO - JRST ITYXT1 - -NOTCR: CAIN A,^I ;SKIP IF NOT TAB - JRST TABCNT - CAIE A,10 ; BACK SPACE - JRST .+3 - SOS CHRPOS(B) ; BACK UP ONE - JRST ITYXT - CAIE A,^J ;SKIP IF LINE FEED - AOS CHRPOS(B) ;ADD TO CHARACTER NUMBER - -ITYXT: PUSHJ P,AOSACC ; BUMP ACCESS -ITYXTA: PUSHJ P,WXCT ;OUTPUT THE CHARACTER -ITYXT1: POP P,A ;RESTORE THE ORIGINAL CHARACTER - -ITYRET: POP P,C ;RESTORE REGS & RETURN - POP P,FLAGS - POP TP,B ; GET CHANNEL BACK - SUB TP,[1,,1] - POPJ P, - -TABCNT: PUSH P,D - MOVE C,CHRPOS(B) - ADDI C,8. ;INCREMENT COUNT BY EIGHT (MOD EIGHT) - IDIVI C,8. - IMULI C,8. - MOVEM C,CHRPOS(B) ;REPLACE COUNT - POP P,D - JRST ITYXT - -UNPROUT: POP P,A ;GET BACK THE ORIG CHAR - IDPB A,UPB+2 ;DEPOSIT USING BYTE POINTER I PUSHED LONG AGO - SOS UPB+1 - JRST ITYRET ;RETURN - -AOSACC: TLNN FLAGS,BINBIT - JRST NRMACC - AOS C,ACCESS-1(B) ; COUNT CHARS IN WORD - CAMN C,[TFIX,,1] - AOS ACCESS(B) - CAMN C,[TFIX,,5] - HLLZS ACCESS-1(B) - POPJ P, - -NRMACC: AOS ACCESS(B) - POPJ P, - -SPACEQ: MOVEI A,40 - TLNE FLAGS,FLTBIT+BINBIT - JRST PITYO ; JUST OUTPUT THE SPACE - PUSH P,[1] ; PRINT SPACE IF NOT END OF LINE - MOVEI A,1 - JRST RETIF2 - -RETIF1: MOVEI A,1 - -RETIF: PUSH P,[0] - TLNE FLAGS,FLTBIT+BINBIT - JRST SPOPJ ; IF WE ARE IN FLATSIZE THEN ESCAPE -RETIF2: PUSH P,FLAGS -RETCH: PUSH P,A - -RETCH1: ADD A,CHRPOS(B) ;ADD THE CHARACTER POSITION - SKIPN CHRPOS(B) ; IF JUST RESET, DONT DO IT AGAIN - JRST RETXT - CAMG A,LINLN(B) ;SKIP IF GREATER THAN LINE LENGTH - JRST RETXT1 - - MOVEI A,^M ;FORCE A CARRIAGE RETURN - SETZM CHRPOS(B) - PUSHJ P,WXCT - PUSHJ P,AOSACC ; BUMP CHAR COUNT - MOVEI A,^J ;AND FORCE A LINE FEED - PUSHJ P,WXCT - PUSHJ P,AOSACC ; BUMP CHAR COUNT - AOS A,LINPOS(B) - CAMG A,PAGLN(B) ;AT THE END OF THE PAGE ? - JRST RETXT -; MOVEI A,^L ;IF SO FORCE A FORM FEED -; PUSHJ P,WXCT -; PUSHJ P,AOSACC ; BUMP CHAR COUNT - SETZM LINPOS(B) - -RETXT: POP P,A - - POP P,FLAGS -SPOPJ: SUB P,[1,,1] - POPJ P, ;RETURN - -PRETIF: PUSH P,A ;SAVE CHAR - PUSHJ P,RETIF1 - POP P,A - JRST PITYO - -RETIF3: TLNE FLAGS,FLTBIT ; NOTHING ON FLATSIZE - POPJ P, - PUSH P,[0] - PUSH P,FLAGS - HRRI FLAGS,2 ; PRETEND ONLY 1 CHANNEL - PUSH P,A - JRST RETCH1 - -RETXT1: SKIPN -2(P) ; SKIP IF SPACE HACK - JRST RETXT - MOVEI A,40 - PUSHJ P,WXCT - AOS CHRPOS(B) - PUSH P,C - PUSHJ P,AOSACC - POP P,C - JRST RETXT - - ;THIS IS CODE TO HANDLE UNKNOWN DATA TYPES. -;IT PRINTS "*XXXXXX*XXXXXXXXXXXX*", WHERE THE FIRST NUMBER IS THE -;TYPE CODE IN OCTAL, THE SECOND IS THE VALUE FIELD IN OCTAL. -PRERR: MOVEI A,21. ;CHECK FOR 21. SPACES LEFT ON PRINT LINE - MOVE B,-2(TP) ; GET CHANNEL INTO B - PUSHJ P,RETIF ;INSERT CARRIAGE RETURN IF NOT ENOUGH - MOVEI A,"* ;JUNK TO INDICATE ERROR PRINTOUT IN OCTAL - PUSHJ P,PITYO ;TYPE IT - - MOVE E,[000300,,-2(TP)] ;GET POINTER INDEXED OFF TP SO THAT - ;TYPE CODE MAY BE OBTAINED FOR PRINTING. - MOVEI D,6 ;# OF OCTAL DIGITS IN HALF WORD -OCTLP1: ILDB A,E ;GET NEXT 3-BIT BYTE OF TYPE CODE - IORI A,60 ;OR-IN 60 FOR ASCII DIGIT - PUSHJ P,PITYO ;PRINT IT - SOJG D,OCTLP1 ;REPEAT FOR SIX CHARACTERS - -PRE01: MOVEI A,"* ;DELIMIT TYPE CODE FROM VALUE FIELD - PUSHJ P,PITYO - - HRLZI E,(410300,,(TP)) ;BYTE POINTER TO SECOND WORD - ;INDEXED OFF TP - MOVEI D,12. ;# OF OCTAL DIGITS IN A WORD -OCTLP2: LDB A,E ;GET 3 BITS - IORI A,60 ;CONVERT TO ASCII - PUSHJ P,PITYO ;PRINT IT - IBP E ;INCREMENT POINTER TO NEXT BYTE - SOJG D,OCTLP2 ;REPEAT FOR 12. CHARS - - MOVEI A,"* ;DELIMIT END OF ERROR TYPEOUT - PUSHJ P,PITYO ;REPRINT IT - - JRST PNEXT ;RESTORE REGS & POP UP ONE LEVEL TO CALLER - -POCTAL: MOVEI A,14. ;RETURN TO NEW LINE IF 14. SPACES NOT LEFT - MOVE B,-2(TP) ; GET CHANNEL INTO B - PUSHJ P,RETIF - JRST PRE01 ;PRINT VALUE AS "*XXXXXXXXXXXX*" - - ;PRINT BINARY INTEGERS IN DECIMAL. -; -PFIX: MOVM E,(TP) ; GET # (MAFNITUDE) - JUMPL E,POCTAL ; IF ABS VAL IS NEG, MUST BE SETZ - PUSH P,FLAGS - -PFIX1: MOVE B,-2(TP) ; GET CHANNEL INTO B -PFIX2: MOVE D,UPB+6 ; IF UNPARSE, THIS IS RADIX - TLNE FLAGS,UNPRSE+FLTBIT ;SKIPS IF NOT FROM UNPARSE OR FLATSIZE - JRST PFIXU - MOVE D,RADX(B) ; GET OUTPUT RADIX -PFIXU: CAIG D,1 ; DONT ALLOW FUNNY RADIX - MOVEI D,10. ; IF IN DOUBT USE 10. - PUSH P,D - MOVEI A,1 ; START A COUNTER - SKIPGE B,(TP) ; CHECK SIGN - MOVEI A,2 ; NEG, NEED CHAR FOR SIGN - - IDIV B,D ; START COUNTING - JUMPE B,.+2 - AOJA A,.-2 - - MOVE B,-2(TP) ; CHANNEL TO B - TLNN FLAGS,FLTBIT+BINBIT - PUSHJ P,RETIF3 ; CHECK FOR C.R. - MOVE B,-2(TP) ; RESTORE CHANNEL - MOVEI A,"- ; GET SIGN - SKIPGE (TP) ; SKIP IF NOT NEEDED - PUSHJ P,PITYO - MOVM C,(TP) ; GET MAGNITUDE OF # - MOVE B,-2(TP) ; RESTORE CHANNEL - POP P,E ; RESTORE RADIX - PUSHJ P,FIXTYO ; WRITE OUT THE # - MOVE FLAGS,-1(P) - SUB P,[1,,1] ; FLUSH P STUFF - JRST PNEXT - -FIXTYO: IDIV C,E - HRLM D,(P) ; SAVE REMAINDER - SKIPE C - PUSHJ P,FIXTYO - HLRZ A,(P) ; START GETTING #'S BACK - ADDI A,60 - MOVE B,-2(TP) ; CHANNEL BACK - JRST PITYO - - ;PRINT SINGLE-PRECISION FLOATING POINT NUMBERS IN DECIMAL. -; -PFLOAT: SKIPN A,(TP) ; SKIP IF NUMBER IS NON-ZERO (SPECIAL HACK FOR ZERO) - JRST PFLT0 ; HACK THAT ZERO - MOVM E,A ; CHECK FOR NORMALIZED - TLNN E,400 ; NORMALIZED - JRST PUNK - MOVEI E,FLOATB ;ADDRESS OF FLOATING POINT CONVERSION ROUTINE - MOVE D,[6,,6] ;# WORDS TO GET FROM STACK - -PNUMB: HRLI A,1(P) ;LH(A) TO CONTAIN ADDRESS OF RETURN AREA ON STACK - HRR A,TP ;RH(A) TO CONTAIN ADDRESS OF DATA ITEM - HLRZ B,A ;SAVE RETURN AREA ADDRESS IN REG B - ADD P,D ;ADD # WORDS OF RETURN AREA TO BOTH HALVES OF SP - JUMPGE P,PDLERR ;PLUS OR ZERO STACK POINTER IS OVERFLOW -PDLWIN: PUSHJ P,(E) ;CALL ROUTINE WHOSE ADDRESS IS IN REG E - - MOVE C,(B) ;GET COUNT 0F # CHARS RETURNED - MOVE A,C ;MAKE SURE THAT # WILL FIT ON PRINT LINE -PFLT1: PUSH P,B ; SAVE B - MOVE B,-2(TP) ; GET CHANNEL INTO B - PUSHJ P,RETIF ;START NEW LINE IF IT WON'T - POP P,B ; RESTORE B - - HRLI B,000700 ;MAKE REG B INTO BYTE POINTER TO FIRST CHAR LESS ONE -PNUM01: ILDB A,B ;GET NEXT BYTE - PUSH P,B ;SAVE B - MOVE B,-2(TP) ; GET CHANNEL INTO B - PUSHJ P,PITYO ;PRINT IT - - P,B ; RESTORE B - SOJG C,PNUM01 ;DECREMENT CHAR COUNT: LOOP IF NON-ZERO - - SUB P,D ;SUBTRACT # WORDS USED ON STACK FOR RETURN - JRST PNEXT ;STORE REGS & POP UP ONE LEVEL TO CALLER - - -PFLT0: MOVEI A,9. ; WIDTH OF 0.0000000 - MOVEI C,9. ; SEE ABOVE - MOVEI D,0 ; WE'RE GONNA TEST D SOON...SO WILL DO RIGHT THING - MOVEI B,[ASCII /0.0000000/] - SOJA B,PFLT1 ; PT TO 1 BELOW CONST, THEN REJOIN CODE - - - - -PDLERR: SUB P,D ;REST STACK POINTER -REPEAT 6,PUSH P,[0] - JRST PDLWIN - ;PRINT SHORT (ONE WORD) CHARACTER STRINGS -; -PCHRS: MOVEI A,3 ;MAX # CHARS PLUS 2 (LESS ESCAPES) - MOVE B,-2(TP) ; GET CHANNEL INTO B - TLNE FLAGS,NOQBIT ;SKIP IF QUOTES WILL BE USED - MOVEI A,1 ;ELSE, JUST ONE CHARACTER POSSIBLE - PUSHJ P,RETIF ;NEW LINE IF INSUFFICIENT SPACE - TLNE FLAGS,NOQBIT ;DON'T QUOTE IF IN PRINC MODE - JRST PCASIS - MOVEI A,"! ;TYPE A EXCL - PUSHJ P,PITYO - MOVEI A,"" ;AND A DOUBLE QUOTE - PUSHJ P,PITYO - -PCASIS: MOVE A,(TP) ;GET NEXT BYTE FROM WORD - TLNE FLAGS,NOQBIT ;SKIP IF WE ARE NOT IN PRINC MODE (NOQBIT=0) - JRST PCPRNT ;IF BIT IS ON, PRINT WITHOUT ESCAPING - CAIE A,ESCHAR ;SKIP IF NOT THE ESCAPE CHARACTER - JRST PCPRNT ;ESCAPE THE ESCAPE CHARACTER - -ESCPRT: MOVEI A,ESCHAR ;TYPE THE ESCAPE CHARACTER - PUSHJ P,PITYO - -PCPRNT: MOVE A,(TP) ;GET THE CHARACTER AGAIN - PUSHJ P,PITYO ;PRINT IT - JRST PNEXT - - - ;PRINT DEFERED (INVISIBLE) ITEMS. (PRINTED AS THE THING POINTED TO) -; -PDEFER: MOVE A,(B) ;GET FIRST WORD OF ITEM - MOVE B,1(B) ;GET SECOND - PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT - PUSH TP,-3(TP) - PUSHJ P,IPRINT ;PRINT IT - SUB TP,[2,,2] ; POP OFF CHANNEL - JRST PNEXT ;GO EXIT - - -; Print an ATOM. TRAILERS are added if the atom is not in the current -; lexical path. Also escaping of charactets is performed to allow READ -; to win. - -PATOM: PUSH P,[440700,,D] ; PUSH BYE POINTER TO FINAL STRING - SETZB D,E ; SET CHARCOUNT AD DESTINATION TO 0 - HLLZS -1(TP) ; RH OF TATOM,, WILL COUNT ATOMS IN PATH - -PATOM0: PUSH TP,$TPDL ; SAVE CURRENT STAKC FOR \ LOGIC - PUSH TP,P - LDB A,[301400,,(P)] ; GET BYTE PTR POSITION - DPB A,[301400,,E] ; SAVE IN E - MOVE C,-2(TP) ; GET ATOM POINTER - ADD C,[3,,3] ; POINT TO PNAME - HLRE A,C ; -# WORDS TO A - PUSH P,A ; PUSH THAT FOR "AOSE" - MOVEI A,177 ; PUT RUBOUT WHERE \ MIGHT GO - JSP B,DOIDPB - HRLI C,440700 ; BUILD BYET POINTER - -PATOM1: ILDB A,C ; GET A CHAR - JUMPE A,PATDON ; END OF PNAME? - TLNN C,760000 ; SKIP IF NOT WORD BOUNDARY - AOS (P) ; COUNT WORD - JRST PENTCH ; ENTER THE CHAR INTO OUTPUT - -PATDON: LDB A,[220600,,E] ; GET "STATE" - LDB A,STABYT+6 ; SIMULATE "END" CHARACTER - DPB A,[220600,,E] ; AND STORE - MOVE B,E ; SETUP BYTE POINTER TO 1ST CHAR - TLZ B,77 - HRR B,(TP) ; POINT - SUB TP,[2,,2] ; FLUSH SAVED PDL - MOVE C,-1(P) ; GET BYE POINTER - SUB P,[2,,2] ; FLUSH - PUSH P,D - MOVEI A,0 - IDPB A,B - AOS -1(TP) ; COUNT ATOMS - TLNE FLAGS,NOQBIT ; SKIP IF NOT "PRINC" - JRST NOLEX4 ; NEEDS NO LEXICAL TRAILERS - MOVEI A,"\ ; GET QUOTER - TLNN E,2 ; SKIP IF NEEDED - JRST PATDO1 - SOS -1(TP) ; DONT COUNT BECAUSE OF SLASH - DPB A,B ; CLOBBER -PATDO1: MOVEI E,(E) ; CLEAR LH(E) - PUSH P,C ; SAVE BYTER - PUSH P,E ; ALSO CHAR COUNT - - MOVE B,IMQUOTE OBLIST - PUSH P,FLAGS - PUSHJ P,IDVAL ; GET LOCAL/GLOBAL VALUE - POP P,FLAGS ; AND RESTORES FLAGS - MOVE C,(TP) ; GET ATOM BACK - SKIPN C,2(C) ; GET ITS OBLIST - AOJA A,NOOBL1 ; NONE, USE FALSE - JUMPL C,.+3 ; JUMP IF REAL OBLIST - ADDI C,(TVP) ; ELSE MUST BE OFFSET - MOVE C,(C) - CAME A,$TLIST ; SKIP IF A LIST - CAMN A,$TOBLS ; SKIP IF UNREASONABLE VALUE - JRST CHOBL ; WINS, NOW LOCATE IT - -CHROOT: CAME C,ROOT+1(TVP) ; IS THIS ROOT? - JRST FNDOBL ; MUST FIND THE PATH NAME - POP P,E ; RESTORE CHAR COUNT - MOVE D,(P) ; AND PARTIAL WORD - EXCH D,-1(P) ; STORE BYTE POINTER AND GET PARTIAL WORD - MOVEI A,"! ; PUT OUT MAGIC - JSP B,DOIDPB ; INTO BUFFER - MOVEI A,"- - JSP B,DOIDPB - MOVEI A,40 - JSP B,DOIDPB - -NOLEX0: SUB P,[2,,2] ; REMOVE COUNTER AND BYTE POINTER - PUSH P,D ; PUSH NEXT WORD IF ANY - JRST NOLEX4 - -NOLEX: MOVE E,(P) ; GET COUNT - SUB P,[2,,2] -NOLEX4: MOVEI E,(E) ; CLOBBER LH(E) - MOVE A,E ; COUNT TO A - SKIPN (P) ; FLUSH 0 WORD - SUB P,[1,,1] - HRRZ C,-1(TP) ; GET # OF ATOMS - SUBI A,(C) ; FIX COUNT - MOVE B,-2(TP) ; GET CHANNEL INTO B - PUSHJ P,RETIF ; MAY NEED C.R. - MOVEI C,-1(E) ; COMPUTE WORDS-1 - IDIVI C,5 ; WORDS-1 TO C - HRLI C,(C) - MOVE D,P - SUB D,C ; POINTS TO 1ST WORD OF CHARS - MOVSI C,440700+D ; BYTEPOINTER TO STRING - PUSH TP,$TPDL ; SAVE FROM GC - PUSH TP,D - -PATOUT: ILDB A,C ; READ A CHAR - SKIPE A ; IGNORE NULS - PUSHJ P,PITYO ; PRINT IT - MOVE D,(TP) ; RESTORE POINTER - SOJG E,PATOUT - -NOLEXD: SUB TP,[2,,2] ; FLUSH TP JUNK - MOVE P,D ; RESTORE P - SUB P,[1,,1] - JRST PNEXT - - -PENTCH: TLNE FLAGS,NOQBIT ; "PRINC"? - JRST PENTC1 ; YES, AVOID SLASHING - IDIVI A,CHRWD ; GET CHARS TYPE - LDB B,BYTPNT(B) - CAIL B,6 ; SKIP IF NOT SPECIAL - JRST PENTC2 ; SLASH IMMEDIATE - LDB A,[220600,,E] ; GET "STATE" - LDB A,STABYT-1(B) ; GET NEW STATE - DPB A,[220600,,E] ; AND SAVE IT -PENTC3: LDB A,C ; RESTORE CHARACTER -PENTC1: JSP B,DOIDPB - SKIPGE (P) ; SKIP IF DONE - JRST PATOM1 ; CONTINUE - JRST PATDON - -PENTC2: MOVEI A,"\ ; GET CHAR QUOTER - JSP B,DOIDPB ; NEEDED, DO IT - MOVEI A,4 ; PATCH FOR ATOMS ALREADY BACKSLASHED - JRST PENTC3-1 - -; ROUTINE TO PUT ONE CHAR ON STACK BUFFER - -DOIDPB: IDPB A,-1(P) ; DEPOSIT - TRNN D,377 ; SKIP IF D FULL - AOJA E,(B) - PUSH P,(P) ; MOVE TOP OF STACK UP - MOVEM D,-2(P) ; SAVE WORDS - MOVE D,[440700,,D] - MOVEM D,-1(P) - MOVEI D,0 - AOJA E,(B) - -; CHECK FOR UNIQUENESS LOOKING INTO PATH - -CHOBL: CAME A,$TOBLS ; SINGLE OBLIST? - JRST LSTOBL ; NO, AL LIST THEREOF - CAME B,C ; THE RIGTH ONE? - JRST CHROOT ; NO, CHECK ROOT - JRST NOLEX ; WINNER, NO TRAILERS! - -LSTOBL: PUSH TP,A ; SCAN A LIST OF OBLISTS - PUSH TP,B - PUSH TP,A - PUSH TP,B - PUSH TP,$TOBLS - PUSH TP,C - -NXTOB2: INTGO ; LIST LOOP, PREVENT LOSSAGE - SKIPN C,-2(TP) ; SKIP IF NOT DONE - JRST CHROO1 ; EMPTY, CHECK ROOT - MOVE B,1(C) ; GET ONE - CAME B,(TP) ; WINNER? - JRST NXTOBL ; NO KEEP LOOKING - CAMN C,-4(TP) ; SKIP IF NOT FIRST ON LIST - JRST NOLEX1 - MOVE A,-6(TP) ; GET ATOM BACK - MOVEI D,0 - ADD A,[3,,3] ; POINT TO PNAME - PUSH P,0 ; SAVE FROM RLOOKU - PUSH P,(A) - ADDI D,5 - AOBJN A,.-2 ; PUSH THE PNAME - PUSH P,D ; AND CHAR COUNT - MOVSI A,TLIST ; TELL RLOOKU WE WIN - MOVE B,-4(TP) ; GET BACK OBLIST LIST - SUB TP,[6,,6] ; FLUSH CRAP - PUSHJ P,RLOOKU ; FIND IT - POP P,0 - CAMN B,(TP) ; SKIP IF NON UNIQUE - JRST NOLEX ; UNIQUE , NO TRAILER!! - JRST CHROO2 ; CHECK ROOT - -NXTOBL: HRRZ B,@-2(TP) ; STEP THE LIST - MOVEM B,-2(TP) - JRST NXTOB2 - - -FNDOBL: MOVE C,(TP) ; GET ATOM - MOVSI A,TOBLS - MOVE B,2(C) - JUMPL B,.+3 - ADDI B,(TVP) - MOVE B,(B) - MOVSI C,TATOM - MOVE D,IMQUOTE OBLIST - PUSH P,0 - PUSHJ P,IGET - POP P,0 -NOOBL1: POP P,E ; RESTORE CHAR COUNT - MOVE D,(P) ; GET PARTIAL WORD - EXCH D,-1(P) ; AND BYTE POINTER - CAME A,$TATOM ; IF NOT ATOM, USE FALSE - JRST NOOBL - MOVEM B,(TP) ; STORE IN ATOM SLOT - MOVEI A,"! - JSP B,DOIDPB ; WRITE IT OUT - MOVEI A,"- - JSP B,DOIDPB - SUB P,[1,,1] - JRST PATOM0 ; AND LOOP - -NOOBL: MOVE C,[440700,,[ASCIZ /!-#FALSE ()/]] - ILDB A,C - JUMPE A,NOLEX0 - JSP B,DOIDPB - JRST .-3 - - -NOLEX1: SUB TP,[6,,6] ; FLUSH STUFF - JRST NOLEX - -CHROO1: SUB TP,[6,,6] -CHROO2: MOVE C,(TP) ; GET ATOM - SKIPGE C,2(C) ; AND ITS OBLIST - JRST CHROOT - ADDI C,(TVP) - MOVE C,(C) - JRST CHROOT - - - ; STATE TABLES FOR \ OF FIRST CHAR - -RADIX 16. - -STATS: 431244000 - 434444400 - 222224200 - 434564200 - 444444400 - 454564200 - 487444200 - 484444400 - 484444200 - -RADIX 8. - -STABYT: 400400,,STATS(A) - 340400,,STATS(A) - 300400,,STATS(A) - 240400,,STATS(A) - 200400,,STATS(A) - 140400,,STATS(A) - 100400,,STATS(A) - - ;PRINT LONG CHARACTER STRINGS. -; -PCHSTR: MOVE B,(TP) - TLZ FLAGS,ATMBIT ;WE ARE NOT USING ATOM-NAME TYPE ESCAPING - PUSH P,-1(TP) ; PUSH CHAR COUNT - MOVE D,[AOS E] ;GET INSTRUCTION TO COUNT CHARACTERS - SETZM E ;ZERO COUNT - PUSHJ P,PCHRST ;GO THROUGH STRING, ESCAPING, ETC. AND COUNTING - MOVE A,E ;PUT COUNT RETURNED IN REG A - TLNN FLAGS,NOQBIT ;SKIP (NO QUOTES) IF IN PRINC (BIT ON) - ADDI A,2 ;PLUS TWO FOR QUOTES - PUSH P,B ; SAVE B - MOVE B,-2(TP) ; GET CHANNEL INTO B - PUSHJ P,RETIF ;START NEW LINE IF NO SPACE - POP P,B ; RESTORE B - TLNE FLAGS,NOQBIT ;SKIP (PRINT ") IF BIT IS OFF (NOT PRINC) - JRST PCHS01 ;OTHERWISE, DON'T QUOTE - MOVEI A,"" ;PRINT A DOUBLE QUOTE - PUSH P,B ; SAVE B - MOVE B,-2(TP) - PUSHJ P,PITYO - POP P,B ; RESTORE B - -PCHS01: MOVE D,[PUSHJ P,PITYO] ;OUTPUT INSTRUCTION - MOVEM B,(TP) ;RESET BYTE POINTER - POP P,-1(TP) ; RESET CHAR COUNT - PUSHJ P,PCHRST ;TYPE STRING - - TLNE FLAGS,NOQBIT ;AGAIN, SKIP IF DOUBLE-QUOTING TO BE DONE - JRST PNEXT ;RESTORE REGS & POP UP ONE LEVEL TO CALLER - MOVEI A,"" ;PRINT A DOUBLE QUOTE - MOVE B,-2(TP) ; GET CHANNEL INTO B - PUSH P,B ; SAVE B - MOVE B,-2(TP) ; GET CHANNEL - PUSHJ P,PITYO - POP P,B ;RESTORE B - JRST PNEXT - - -;INTERNAL ROUTINE USED TO COUNT OR OUTPUT CHARACTER STRINGS. -; -;THE APPROPRIATE ESCAPING CONVENTIONS ARE USED AS DETERMINED BY THE FLAG BITS. -; -PCHRST: PUSH P,A ;SAVE REGS - PUSH P,B - PUSH P,C - PUSH P,D - -PCHR02: INTGO ; IN CASE VERY LONG STRING - HRRZ C,-1(TP) ;GET COUNT - SOJL C,PCSOUT ; DONE? - HRRM C,-1(TP) - ILDB A,(TP) ; GET CHAR - - TLNE FLAGS,NOQBIT ;SKIP IF WE ARE NOT IN PRINC MODE (NOQBIT=0) - JRST PCSPRT ;IF BIT IS ON, PRINT WITHOUT ESCAPING - CAIN A,ESCHAR ;SKIP IF NOT THE ESCAPE CHARACTER - JRST ESCPRN ;ESCAPE THE ESCAPE CHARACTER - CAIN A,"" ;SKIP IF NOT A DOUBLE QUOTE - JRST ESCPRN ;OTHERWISE, ESCAPE THE """ - IDIVI A,CHRWD ;CODE HERE FINDS CHARACTER TYPE - LDB B,BYTPNT(B) ; " - CAIGE B,6 ;SKIP IF NOT A NUMBER/LETTER - JRST PCSPRT ;OTHERWISE, PRINT IT - TLNN FLAGS,ATMBIT ;SKIP IF PRINTING AN ATOM-NAME (UNQUOTED) - JRST PCSPRT ;OTHERWISE, NO OTHER CHARS TO ESCAPE - -ESCPRN: MOVEI A,ESCHAR ;TYPE THE ESCAPE CHARACTER - PUSH P,B ; SAVE B - MOVE B,-2(TP) ; GET CHANNEL INTO B - XCT (P)-1 - POP P,B ; RESTORE B - -PCSPRT: LDB A,(TP) ;GET THE CHARACTER AGAIN - PUSH P,B ; SAVE B - MOVE B,-2(TP) ; GET CHANNEL INTO B - XCT (P)-1 ;PRINT IT - POP P,B ; RESTORE B - JRST PCHR02 ;LOOP THROUGH STRING - -PCSOUT: POP P,D - POP P,C ;RESTORE REGS & RETURN - POP P,B - POP P,A - POPJ P, - - - ;PRINT AN ARGUMENT LIST -;CHECK FOR TIME ERRORS - -PARGS: MOVEI B,-1(TP) ;POINT TO ARGS POINTER - PUSHJ P,CHARGS ;AND CHECK THEM - JRST PVEC ; CHEAT TEMPORARILY - - - -;PRINT A FRAME -PFRAME: MOVEI B,-1(TP) ;POINT TO FRAME POINTER - PUSHJ P,CHFRM - HRRZ B,(TP) ;POINT TO FRAME ITSELF - HRRZ B,FSAV(B) ;GET POINTER TO SUBROUTINE - CAMGE B,VECTOP - CAMGE B,VECBOT - SKIPA B,@-1(B) ; SUBRS AND FSUBRS - MOVE B,3(B) ; FOR RSUBRS - MOVSI A,TATOM - PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT - PUSH TP,-3(TP) - PUSHJ P,IPRINT ;PRINT FUNCTION NAME - SUB TP,[2,,2] ; POP CHANNEL OFF STACK - JRST PNEXT - -PPVP: MOVE B,(TP) ; PROCESS TO B - MOVSI A,TFIX - JUMPE B,.+3 - MOVE A,PROCID(B) - MOVE B,PROCID+1(B) ;GET ID - PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT - PUSH TP,-3(TP) - PUSHJ P,IPRINT - SUB TP,[2,,2] ; POP CHANNEL OFF STACK - JRST PNEXT - -; HERE TO PRINT LOCATIVES - -LOCPT1: HRRZ A,-1(TP) - JUMPN A,PUNK -LOCPT: MOVEI B,-1(TP) ; VALIDITY CHECK - PUSHJ P,CHLOCI - HRRZ A,-1(TP) - JUMPE A,GLOCPT - MOVE B,(TP) - MOVE A,(B) - MOVE B,1(B) - PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT - PUSH TP,-3(TP) - PUSHJ P,IPRINT - SUB TP,[2,,2] ; POP CHANNEL OFF STACK - JRST PNEXT - -GLOCPT: MOVEI A,2 - MOVE B,-2(TP) ; GET CHANNEL - PUSHJ P,RETIF - MOVEI A,"% - PUSHJ P,PITYO - MOVEI A,"< - PUSHJ P,PITYO - MOVSI A,TATOM - MOVE B,MQUOTE GLOC - PUSH TP,-3(TP) - PUSH TP,-3(TP) - PUSHJ P,IPRINT - SUB TP,[2,,2] - PUSHJ P,SPACEQ - MOVE B,(TP) - MOVSI A,TATOM - MOVE B,-1(B) - PUSH TP,-3(TP) - PUSH TP,-3(TP) - PUSHJ P,IPRINT - SUB TP,[2,,2] - PUSHJ P,SPACEQ - MOVSI A,TATOM - MOVE B,MQUOTE T - PUSH TP,-3(TP) - PUSH TP,-3(TP) - PUSHJ P,IPRINT - SUB TP,[2,,2] - MOVEI A,"> - PUSHJ P,PRETIF - JRST PNEXT - - ;PRINT UNIFORM VECTORS. -; -PUVEC: MOVE B,-2(TP) ; GET CHANNEL INTO B - MOVEI A,2 ; ROOM FOR ! AND SQ BRACK? - PUSHJ P,RETIF - MOVEI A,"! ;TYPE AN ! AND OPEN SQUARE BRACKET - PUSHJ P,PITYO - MOVEI A,"[ - PUSHJ P,PITYO - - MOVE C,(TP) ;GET AOBJN POINTER TO VECTOR - TLNN C,777777 ;SKIP ONLY IF COUNT IS NOT ZERO - JRST NULVEC ;ELSE, VECTOR IS EMPTY - - HLRE A,C ;GET NEG COUNT - MOVEI D,(C) ;COPY POINTER - SUB D,A ;POINT TO DOPE WORD - HLLZ A,(D) ;GET TYPE - PUSH P,A ;AND SAVE IT - -PUVE02: MOVE A,(P) ;PUT TYPE CODE IN REG A - MOVE B,(C) ;PUT DATUM INTO REG B - PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT - PUSH TP,-3(TP) - PUSHJ P,IPRINT ;TYPE IT - SUB TP,[2,,2] ; POP CHANNEL OF STACK - MOVE C,(TP) ;GET AOBJN POINTER - AOBJP C,NULVE1 ;JUMP IF COUNT IS ZERO - MOVEM C,(TP) ;PUT POINTER BACK ONTO STACK - - MOVE B,-2(TP) ; GET CHANNEL INTO B - PUSHJ P,SPACEQ - JRST PUVE02 ;LOOP THROUGH VECTOR - -NULVE1: SUB P,[1,,1] ;REMOVE STACK CRAP -NULVEC: MOVE B,-2(TP) ; GET CHANNEL INTO B - MOVEI A,"! ;TYPE CLOSE BRACKET - PUSHJ P,PRETIF - MOVEI A,"] - PUSHJ P,PRETIF - JRST PNEXT - - ;PRINT A GENERALIZED VECTOR -; -PVEC: MOVE B,-2(TP) ; GET CHANNEL INTO B - PUSHJ P,RETIF1 ;NEW LINE IF NO ROOM FOR [ - MOVEI A,"[ ;PRINT A LEFT-BRACKET - PUSHJ P,PITYO - - MOVE C,(TP) ;GET AOBJN POINTER TO VECTOR - TLNN C,777777 ;SKIP IF POINTER-COUNT IS NON-ZERO - JRST PVCEND ;ELSE, FINISHED WITH VECTOR -PVCR01: MOVE A,(C) ;PUT FIRST WORD OF NEXT ELEMENT INTO REG A - MOVE B,1(C) ;SECOND WORD OF LIST INTO REG B - PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT - PUSH TP,-3(TP) - PUSHJ P,IPRINT ;PRINT THAT ELEMENT - SUB TP,[2,,2] ; POP CHANNEL OFF STACK - - MOVE C,(TP) ;GET AOBJN POINTER FROM TP-STACK - AOBJP C,PVCEND ;POSITIVE HERE SERIOUS ERROR! (THOUGH NOT PDL) - AOBJN C,.+2 ;SKIP AND CONTINUE LOOP IF COUNT NOT ZERO - JRST PVCEND ;ELSE, FINISHED WITH VECTOR - MOVEM C,(TP) ;PUT INCREMENTED POINTER BACK ON TP-STACK - - MOVE B,-2(TP) ; GET CHANNEL INTO B - PUSHJ P,SPACEQ - JRST PVCR01 ;CONTINUE LOOPING THROUGH OBJECTS ON VECTOR - -PVCEND: MOVE B,-2(TP) ; GET CHANNEL INTO B - PUSHJ P,RETIF1 ;NEW LINE IF NO ROOM FOR ] - MOVEI A,"] ;PRINT A RIGHT-BRACKET - PUSHJ P,PITYO - JRST PNEXT - - ;PRINT A LIST. -; -PLIST: MOVE B,-2(TP) ; GET CHANNEL INTO B - PUSHJ P,RETIF1 ;NEW LINE IF NO SPACE LEFT FOR "(" - MOVEI A,"( ;TYPE AN OPEN PAREN - PUSHJ P,PITYO - PUSHJ P,LSTPRT ;PRINT THE INSIDES - MOVE B,-2(TP) ; RESTORE CHANNEL TO B - PUSHJ P,RETIF1 ;NEW LINE IF NO ROOM FOR THE CLOSE PAREN - MOVEI A,") ;TYPE A CLOSE PAREN - PUSHJ P,PITYO - JRST PNEXT - -PSEG: TLOA FLAGS,SEGBIT ;PRINT A SEGMENT (& SKIP) - -PFORM: TLZ FLAGS,SEGBIT ;PRINT AN ELEMENT - -PLMNT3: MOVE C,(TP) - JUMPE C,PLMNT1 ;IF THE CALL IS EMPTY GO AWAY - MOVE B,1(C) - MOVEI D,0 - CAMN B,MQUOTE LVAL - MOVEI D,". - CAMN B,MQUOTE GVAL - MOVEI D,", - CAMN B,MQUOTE QUOTE - MOVEI D,"' - JUMPE D,PLMNT1 ;NEITHER, LEAVE - -;ITS A SPECIAL HACK - HRRZ C,(C) - JUMPE C,PLMNT1 ;NIL BODY? - -;ITS VALUE OF AN ATOM - HLLZ A,(C) - MOVE B,1(C) - HRRZ C,(C) - JUMPN C,PLMNT1 ;IF TERE ARE EXTRA ARGS GO AWAY - - PUSH P,D ;PUSH THE CHAR - PUSH TP,A - PUSH TP,B - TLNN FLAGS,SEGBIT ;SKIP (CONTINUE) IF THIS IS A SEGMENT - JRST PLMNT4 ;ELSE DON'T PRINT THE "." - -;ITS A SEGMENT CALL - MOVE B,-4(TP) ; GET CHANNEL INTO B - MOVEI A,2 ; ROOM FOR ! AND . OR , - PUSHJ P,RETIF - MOVEI A,"! - PUSHJ P,PITYO - -PLMNT4: MOVE B,-4(TP) ; GET CHANNEL INTO B - PUSHJ P,RETIF1 - POP P,A ;RESTORE CHAR - PUSHJ P,PITYO - POP TP,B - POP TP,A - PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT - PUSH TP,-3(TP) - PUSHJ P,IPRINT - SUB TP,[2,,2] ; POP CHANNEL OFF STACK - JRST PNEXT - - -PLMNT1: TLNN FLAGS,SEGBIT ;SKIP IF THIS IS A SEGMENT - JRST PLMNT5 ;ELSE DON'T TYPE THE "!" - -;ITS A SEGMENT CALL - MOVE B,-2(TP) ; GET CHANNEL INTO B - MOVEI A,2 ; ROOM FOR ! AND < - PUSHJ P,RETIF - MOVEI A,"! - PUSHJ P,PITYO - -PLMNT5: MOVE B,-2(TP) ; GET CHANNEL FOR B - PUSHJ P,RETIF1 - MOVEI A,"< - PUSHJ P,PITYO - PUSHJ P,LSTPRT - MOVEI A,"! - MOVE B,-2(TP) ; GET CHANNEL INTO B - TLNE FLAGS,SEGBIT ;SKIP IF NOT SEGEMNT - PUSHJ P,PRETIF - MOVEI A,"> - PUSHJ P,PRETIF - JRST PNEXT - - - -LSTPRT: SKIPN C,(TP) - POPJ P, - HLLZ A,(C) ;GET NEXT ELEMENT - MOVE B,1(C) - HRRZ C,(C) ;CHOP THE LIST - JUMPN C,PLIST1 - PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT - PUSH TP,-3(TP) - PUSHJ P,IPRINT ;PRINT THE LAST ELEMENT - SUB TP,[2,,2] ; POP CHANNEL OFF STACK - POPJ P, - -PLIST1: MOVEM C,(TP) - PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT - PUSH TP,-3(TP) - PUSHJ P, IPRINT ;PRINT THE NEXT ELEMENT - SUB TP,[2,,2] ; POP CHANNEL OFF STACK - MOVE B,-2(TP) ; GET CHANNEL INTO B - PUSHJ P,SPACEQ - JRST LSTPRT ;REPEAT - -PNEXT: POP P,FLAGS ;RESTORE PREVIOUS FLAG BITS - SUB TP,[2,,2] ;REMOVE INPUT ELEMENT FROM TP-STACK - POP P,C ;RESTORE REG C - POPJ P, - -OPENIT: PUSH P,E - PUSH P,FLAGS - PUSHJ P,OPNCHN - POP P,FLAGS - POP P,E - JUMPGE B,FNFFL ;ERROR IF IT CANNOT BE OPENED - POPJ P, - - -END - -TITLE GETPUT ASSOCIATION FUNCTIONS FOR MUDDLE - -RELOCATABLE - -.INSRT MUDDLE > - -; COMPONENTS IN AN ASSOCIATION BLOCK - -ITEM==0 ;ITEM TO WHICH INDUCATOR APPLIES -VAL==2 ;VALUE -INDIC==4 ;INDICATOR -NODPNT==6 ;IF NON ZERO POINTS TO CHAIN -PNTRS==7 ;POINTERS NEXT (RH) AND PREV (LH) - -ASOLNT==8 ;NUMBER OF WORDS IN AN ASSOCIATION BLOCK - -.GLOBAL ASOVEC ;POINTER TO HASH VECTOR IN TV -.GLOBAL ASOLNT,ITEM,INDIC,VAL,NODPNT,NODES,IPUTP,IGETP,PUT,IFALSE -.GLOBAL DUMNOD,IGETLO,IBLOCK,MONCH,RMONCH,IPUT,IGETL,IREMAS,IGET -.GLOBAL NWORDT,CIGETP,CIGTPR,CIPUTP,CIREMA,MPOPJ - -MFUNCTION GETP,SUBR,[GETPROP] - - ENTRY - -IGETP: PUSHJ P,GETLI - JRST FINIS ; NO SKIP, LOSE - MOVSI A,TLOCN - HLLZ 0,VAL(B) - PUSHJ P,RMONCH ; CHECK MONITOR - MOVE A,VAL(B) ;ELSE RETURN VALUE - MOVE B,VAL+1(B) -CFINIS: JRST FINIS - -; FUNCTION TO RETURN LOCATIVE TO ASSOC - -MFUNCTION GETPL,SUBR - - ENTRY - -IGETLO: PUSHJ P,GETLI - JRST FINIS - MOVSI A,TLOCN - JRST FINIS - -GETLI: PUSHJ P,2OR3 ; GET ARGS - PUSHJ P,IGETL ;SEE IF ASSOCIATION EXISTS - SKIPE B - AOS (P) ; WIN RETURN - CAMGE AB,[-4,,0] ; ANY ERROR THING - JUMPE B,CHFIN ;IF 0, NONE EXISTS - POPJ P, - -CHFIN: PUSH TP,4(AB) - PUSH TP,5(AB) - MCALL 1,EVAL - POPJ P, - -; COMPILER CALLS TO SOME OF THESE - -CIGETP: SUBM M,(P) ; FIX RET ADDR - PUSHJ P,IGETL ; GO TO INTERNAL - JUMPE B,MPOPJ - MOVSI A,TLOCN -MPOPJ1: SOS (P) ; WINNER (SOS BECAUSE OF SUBM M,(P)) -MPOPJ: SUBM M,(P) - POPJ P, - -CIGTPR: SUBM M,(P) - PUSHJ P,IGETL - JUMPE B,MPOPJ - MOVE A,VAL(B) ; GET VAL TYPE - MOVE B,VAL+1(B) - JRST MPOPJ1 - -CIPUTP: SUBM M,(P) - PUSH TP,-1(TP) ; SAVE VAL - PUSH TP,-1(TP) - PUSHJ P,IPUT ; DO IT - POP TP,B - POP TP,A - JRST MPOPJ - -CIREMA: SUBM M,(P) - PUSHJ P,IREMAS ; FLUSH IT - JRST MPOPJ - -; CHECK PUT/GET PUTPROP AND GETPROP ARGS - -2OR3: HLRE 0,AB - ASH 0,-1 ; TO -# OF ARGS - ADDI 0,2 ; AT LEAST 2 - JUMPG 0,TFA ; 1 OR LESS, LOSE - AOJL 0,TMA ; 4 OR MORE, LOSE - MOVE A,(AB) ; GET ARGS INTO ACS - MOVE B,1(AB) - MOVE C,2(AB) - MOVE D,3(AB) - POPJ P, - -; INTERNAL GET - -IGET: PUSHJ P,IGETL ; GET LOCATIVE - JUMPE B,CPOPJ - MOVE A,VAL(B) - MOVE B,VAL+1(B) - POPJ P, - -; FUNCTION TO MAKE AN ASSOCIATION - -MFUNCTION PUTP,SUBR,[PUTPROP] - - ENTRY - -IPUTP: PUSHJ P,2OR3 ; GET ARGS - JUMPN 0,REMAS ; REMOVE AN ASSOCIATION - PUSH TP,4(AB) ; SAVE NEW VAL - PUSH TP,5(AB) - PUSHJ P,IPUT ; DO IT - MOVE A,(AB) ; RETURN NEW VAL - MOVE B,1(AB) - JRST FINIS - -REMAS: PUSHJ P,IREMAS - JRST FINIS - -IPUT: SKIPN DUMNOD+1(TVP) ; NEW DUMMY NEDDED? - PUSHJ P,DUMMAK ; YES, GO MAKE ONE -IPUT1: PUSHJ P,IGETI ;SEE IF THIS ONE EXISTS - - JUMPE B,NEWASO ;JUMP IF NEED NEW ASSOCIATION BLOCK -CLOBV: MOVE C,-5(TP) ; RET NEW VAL - MOVE D,-4(TP) - SUB TP,[6,,6] - HLLZ 0,VAL(B) - MOVSI A,TLOCN - PUSHJ P,MONCH ; MONITOR CHECK - MOVEM C,VAL(B) ;STORE IT - MOVEM D,VAL+1(B) -CPOPJ: POPJ P, - -; HERE TO CREATE A NEW ASSOCIATION - -NEWASO: MOVE B,DUMNOD+1(TVP) ; GET BALNK ASSOCIATION - SETZM DUMNOD+1(TVP) ; CAUSE NEW ONE NEXT TIME - - -;NOW SPLICE IN CHAIN - - JUMPE D,PUT1 ;NO OTHERS EXISTED IN THIS BUCKET - HRLZM C,PNTRS(B) ;CLOBBER PREV POINTER - HRRM B,PNTRS(C) ;AND NEXT POINTER - JRST .+2 - -PUT1: HRRZM B,(C) ;STORE INTO VECTOR - HRRZ C,NODES+1(TVP) - HRLM C,NODPNT(B) - MOVE D,NODPNT(C) - HRRZM B,NODPNT(C) - HRRM D,NODPNT(B) - HRLM B,NODPNT(D) - MOVEI C,-3(TP) ;COPY ARG POINTER - MOVSI A,-4 ;AND COPY POINTER - -PUT2: MOVE D,(C) ;START COPYING - MOVEM D,@CLOBTB(A) - ADDI C,1 - AOBJN A,PUT2 ;NOTE *** DEPENDS ON ORDER IN VECTOR *** - - JRST CLOBV - -;HERE TO REMOVE AN ASSOCIATION - -IREMAS: PUSHJ P,IGETL ;LOOK IT UP - JUMPE B,CPOPJ ;NEVER EXISTED, IGNORE - HRRZ A,PNTRS(B) ;NEXT POINTER - HLRZ E,PNTRS(B) ;PREV POINTER - SKIPE A ;DOES A NEXT EXIST? - HRLM E,PNTRS(A) ;YES CLOBBER ITS PREV POINTER - SKIPN D ;SKIP IF NOT FIRST IN BUCKET - MOVEM A,(C) ;FIRST STORE NEW ONE - SKIPE D ;OTHERWISE - HRRM A,PNTRS(E) ;PATCH NEXT POINTER IN PREVIOUS - HRRZ A,NODPNT(B) ;SEE IF MUST UNSPLICE NODE - HLRZ E,NODPNT(B) - SKIPE A - HRLM E,NODPNT(A) ;SPLICE - JUMPE E,PUT4 ;FLUSH IF NO PREV POINTER - HRRZ C,NODPNT(E) ;GET PREV'S NEXT POINTER - CAIE C,(B) ;DOES IT POINT TO THIS NODE - .VALUE [ASCIZ /:FATAL PUT LOSSAGE/] - HRRM A,NODPNT(E) ;YES, SPLICE -PUT4: MOVE A,VAL(B) ;RETURN VALUE - SETZM PNTRS(B) - MOVE B,VAL+1(B) - POPJ P, - - -;INTERNAL GET FUNCTION CALLED BY PUT AND GET -; A AND B ARE THE ITEM -;C AND D ARE THE INDICATOR - -IGETL: PUSHJ P,IGETI - SUB TP,[4,,4] ; FLUSH CRUFT LEFT BY IGETI - POPJ P, - -IGETI: PUSHJ P,LHCLR - EXCH A,C - PUSHJ P,LHCLR - EXCH C,A - PUSH TP,A - PUSH TP,B - PUSH TP,C ;SAVE C AND D - PUSH TP,D - XOR A,B ; BUILD HASH - XOR A,C - XOR A,D - TLZ A,400000 ; FORCE POS A - HLRZ B,ASOVEC+1(TVP) ;GET LENGTH OF HASH VECTOR - MOVNS B - IDIVI A,(B) ;RELATIVE BUCKET NOW IN B - HRLI B,(B) ;IN CASE GC OCCURS - ADD B,ASOVEC+1(TVP) ;POINT TO BUCKET - MOVEI D,0 ;SET FIRST SWITCH - SKIPN A,(B) ;GET CONTENTS OF BUCKET (DONT SKIP IF EMPTY) - JRST GFALSE - - MOVSI 0,TASOC ;FOR INTGOS, MAKE A TASOC - HLLZM 0,ASTO(PVP) - -IGET1: GETYPF 0,ITEM(A) ;GET ITEMS TYPE - - MOVE E,ITEM+1(A) - CAMN 0,-3(TP) ;COMPARE TYPES - CAME E,-2(TP) ;AND VALUES - JRST NXTASO ;LOSER - GETYPF 0,INDIC(A) ;MOW TRY INDICATORS - MOVE E,INDIC+1(A) - CAMN 0,-1(TP) - CAME E,(TP) - JRST NXTASO - - SKIPN D ;IF 1ST THEN - MOVE C,B ;RETURN POINTER IN C - MOVE B,A ;FOUND, RETURN ASSOCIATION - MOVSI A,TASOC -IGRET: SETZM ASTO(PVP) - POPJ P, - -NXTASO: MOVEI D,1 ;SET SWITCH - MOVE C,A ;CYCLE - HRRZ A,PNTRS(A) ;STEP - JUMPN A,IGET1 - - MOVSI A,TFALSE - MOVEI B,0 - JRST IGRET - -GFALSE: MOVE C,B ;PRESERVE VECTOR POINTER - MOVSI A,TFALSE - SETZB B,D - JRST IGRET - -; FUNCTION TO DO A PUT AND ALSO ADD TO THE NODE FOR THIS GOODIE - -REPEAT 0,[ -MFUNCTION PUTN,SUBR - - ENTRY - - CAML AB,[-4,,0] ;WAS THIS A REMOVAL - JRST PUT - - PUSHJ P,IPUT ;DO THE PUT - SKIPE NODPNT(C) ;NODE CHAIN EXISTS? - JRST FINIS - - PUSH TP,$TASOC ;NO, START TO BUILD - PUSH TP,C - SKIPN DUMNOD+1(TVP) ; FIX UP DUMMY? - PUSHJ P,DUMMAK -CHPT: MOVE C,$TCHSTR - MOVE D,CHQUOTE NODE - PUSHJ P,IGETL - JUMPE B,MAKNOD ;NOT FOUND, LOSE -NODSPL: MOVE C,(TP) ;HERE TO SPLICE IN NEW NODE - MOVE D,VAL+1(B) ;GET POINTER TO NODE STRING - HRRM D,NODPNT(C) ;CLOBBER - HRLM B,NODPNT(C) - SKIPE D ;SPLICE ONLY IF THERE IS SOMETHING THERE - HRLM C,NODPNT(D) - MOVEM C,VAL+1(B) ;COMPLETE NODE CHAIN - MOVE A,2(AB) ;RETURN VALUE - MOVE B,3(AB) - JRST FINIS - -MAKNOD: PUSHJ P,NEWASO ;GENERATE THE NEW ASSOCIATION - MOVE A,@CHPT ;GET UNIQUE STRING - MOVEM A,INDIC(C) ;CLOBBER IN INDIC - MOVE A,@CHPT+1 - MOVEM A,INDIC+1(C) - MOVE B,C ;POINTER TO B - HRRZ C,NODES+1(TVP) ;GET POINTER TO CHAIN OF NODES - HRRZ D,VAL+1(C) ;SKIP DUMMY NODE - HRRM B,VAL+1(C) ;CLOBBER INTO CHAIN - HRRM D,NODPNT(B) - SKIPE D ;SPLICE IF ONLY SOMETHING THERE - HRLM B,NODPNT(D) - HRLM C,NODPNT(B) - MOVSI A,TASOC ;SET TYPE OF VAL TO ASSOCIATION - MOVEM A,VAL(B) - SETZM VAL+1(B) - JRST NODSPL ;GO SPLICE ITEM ONTO NODE -] - -DUMMAK: PUSH TP,A - PUSH TP,B - PUSH TP,C - PUSH TP,D - MOVEI A,ASOLNT - PUSHJ P,IBLOCK - MOVSI A,400000+SASOC+.VECT. - MOVEM A,ASOLNT(B) ;SET SPECIAL TYPE - MOVEM B,DUMNOD+1(TVP) - POP TP,D - POP TP,C - POP TP,B - POP TP,A - POPJ P, - -CLOBTB: ITEM(B) - ITEM+1(B) - INDIC(B) - INDIC+1(B) - VAL(B) - VAL+1(B) - -MFUNCTION ASSOCIATIONS,SUBR - - ENTRY 0 - MOVE B,NODES+1(TVP) -ASSOC1: MOVSI A,TASOC ; SET TYPE - HRRZ B,NODPNT(B) ; POINT TO 1ST REAL NODE - JUMPE B,IFALSE - JRST FINIS - -; RETURN NEXT ASSOCIATION IN CHAIN OR FALSE - -MFUNCTION NEXT,SUBR - - ENTRY 1 - - GETYP 0,(AB) ; BETTER BE ASSOC - CAIE 0,TASOC - JRST WTYP1 ; LOSE - MOVE B,1(AB) ; GET ARG - JRST ASSOC1 - -; GET ITEM/INDICATOR/VALUE CELLS - -MFUNCTION %ITEM,SUBR,ITEM - - MOVEI B,ITEM ; OFFSET - JRST GETIT - -MFUNCTION INDICATOR,SUBR - - MOVEI B,INDIC - JRST GETIT - -MFUNCTION AVALUE,SUBR - - MOVEI B,VAL -GETIT: ENTRY 1 - GETYP 0,(AB) ; BETTER BE ASSOC - CAIE 0,TASOC - JRST WTYP1 - ADD B,1(AB) ; GET ARG - MOVE A,(B) - MOVE B,1(B) - JRST FINIS - -LHCLR: PUSH P,A - GETYP A,A - PUSHJ P,NWORDT ; DEFERRED ? - SOJE A,LHCLR2 - POP P,A -LHCLR1: TLZ A,TYPMSK#<-1> - POPJ P, -LHCLR2: POP P,A - HLLZS A - JRST LHCLR1 - -END - -TITLE READC TELETYPE DEVICE HANDLER FOR MUDDLE - -RELOCATABLE - -.INSRT MUDDLE > - -SYSQ - -IF1,[ -IFE ITS,.INSRT MUDSYS;STENEX > -] - -.GLOBAL BUFRIN,CHRCNT,SYSCHR,ECHO,BYTPTR,ERASCH,KILLCH,BRKCH,AGC,CHRWRD,W1CHAR,GWB -.GLOBAL IOIN2,READC,WRONGC,BRFCHR,ESCAP,TTYOPE,MTYI,MTYO,NOTTY,TTYOP2,IBLOCK -.GLOBAL RRESET,TTICHN,TTOCHN,CHANNO,STATUS,BRFCH2,TTYBLK,TTYUNB,WAITNS -.GLOBAL EXBUFR,INCHAR,BYTDOP,BUFSTR,LSTCH,CHNCNT,DIRECT,IOINS,IBLOCK,INCONS -.GLOBAL BADCHN,WRONGD,CHNLOS,MODE1,MODE2,GMTYO,IDVAL,GETCHR,PAGLN,LINLN -.GLOBAL RDEVIC -TTYOUT==1 -TTYIN==2 - -; FLAGS CONCERNING TTY CHANNEL STATE - -N.ECHO==1 ; NO INPUT ECHO -N.CNTL==2 ; NO RUBOUT ^L ^D ECHO -N.IMED==4 ; ALL CHARS WAKE UP -N.IME1==10 ; SOON WILL BE N.IMED - - -; OPEN BLOCK MODE BITS -OUT==1 -IMAGEM==4 -ASCIIM==0 -UNIT==0 - - -; READC IS CALLED BY PUSHJ P,READC -; B POINTS TO A TTY FLAVOR CHANNEL -; ONE CHARACTER IS RETURNED IN A -; BECOMES INTERRUPTABLE IF NO CHARACTERS EXISTS - -; HERE TO ASK SYSTEM FOR SOME CHARACTERS - -INCHAR: IRP A,,[0,C,D,E] ;SAVE ACS - PUSH P,A - TERMIN - MOVE E,BUFRIN(B) ; GET AUX BUFFER - MOVE D,BYTPTR(E) - HLRE 0,E ;FIND END OF BUFFER - SUBM E,0 - ANDI 0,-1 ;ISOLATE RH - MOVE C,SYSCHR(E) ; GET FLAGS - -INCHR1: TRNE C,N.IMED+N.CNTL ; SKIP IF NOT IMMEDIATE - JRST DONE - TLZE D,40 ; SKIP IF NOT ESCAPED - JRST INCHR2 ; ESCAPED - CAMN A,ESCAP(E) ; IF ESCAPE - TLO D,40 ; REMEMBER - CAMN A,BRFCH2(E) - JRST BRF - CAMN A,BRFCHR(E) ;BUFFER PRINT CHAR - JRST CLEARQ ;MAYBE CLEAR SCREEN - CAMN A,BRKCH(E) ;IS THIS A BREAK? - JRST DONE ;YES, DONE - CAMN A,ERASCH(E) ;ARE IS IT ERASE? - JRST ERASE ;YES, GO PROCESS - CAMN A,KILLCH(E) ;OR KILL - JRST KILL - -INCHR2: PUSHJ P,PUTCHR ;PUT ACHAR IN BUFFER -INCHR3: MOVEM D,BYTPTR(E) - JRST DONE1 - -DONE: SKIPL A ; IF JUST BUFFER FORCE, SKIP - PUSHJ P,PUTCHR ; STORE CHAR - MOVEI A,N.IMED ; TURN OFF IMEDIACY - ANDCAM A,SYSCHR(E) - MOVEM D,BYTPTR(E) - PUSH TP,$TCHAN ; SAVE CHANNEL - PUSH TP,B - MOVE A,CHRCNT(E) ; GET # OF CHARS - SETZM CHRCNT(E) - PUSH P,A - ADDI A,4 ; ROUND UP - IDIVI A,5 ; AND DOWN - PUSHJ P,IBLOCK ; GET CORE - HLRE A,B ; FIND D.W. - SUBM B,A - MOVSI 0,TCHRS+.VECT. ; GET TYPE - MOVEM 0,(A) ; AND STORE - MOVEI D,(B) ; COPY PNTR - POP P,C ; CHAR COUNT - HRLI D,440700 - HRLI C,TCHSTR - PUSH TP,C - PUSH TP,D - PUSHJ P,INCONS ; CONS IT ON - MOVE C,-2(TP) ; GET CHAN BACK - MOVEI D,EXBUFR(C) ; POINT TO BUFFER LIST - HRRZ 0,(D) ; LAST? - JUMPE 0,.+3 - MOVE D,0 - JRST .-3 ; GO UNTIL END - HRRM B,(D) ; SPLICE - -; HERE TO BLT IN BUFFER - - MOVE D,BUFRIN(C) ; POINT TO COMPLETED BUFFER - HRRZ C,(TP) ; START OF NEW STRING - HRLI C,BYTPTR+1(D) ; 1ST WORD OF CHARS - MOVE E,[010700,,BYTPTR(E)] - EXCH E,BYTPTR(D) ; END OF STRING - MOVEI E,-BYTPTR(E) - ADD E,(TP) ; ADD TO START - BLT C,-1(E) - MOVE B,-2(TP) ; CHANNEL BACK - SUB TP,[4,,4] ; FLUSH JUNK - PUSHJ P,TTYUNB ; UNBLOCK THIS TTY -DONE1: IRP A,,[E,D,C,0] - POP P,A - TERMIN - POPJ P, - - -ERASE: SKIPN CHRCNT(E) ;ANYTHING IN BUFFER? - JRST BARFCR ;NO, MAYBE TYPE CR - - SOS CHRCNT(E) ;DELETE FROM COUNT - LDB A,D ;RE-GOBBLE LAST CHAR -IFN ITS,[ - LDB C,[600,,STATUS(B)] ; CHECK FOR IMLAC - CAIE C,2 ; SKIP IF IT IS -] - JRST TYPCHR - SKIPN ECHO(E) ; SKIP IF ECHOABLE - JRST NECHO - PUSHJ P,CHRTYP ; FOUND OUT IMALC BEHAVIOR - SKIPGE C,FIXIM2(C) - JRST (C) -NOTFUN: PUSHJ P,DELCHR - SOJG C,.-1 - -NECHO: ADD D,[70000,,0] ;DECREMENT BYTE POINTER - JUMPGE D,INCHR3 ;AND GO ON, UNLESS BYTE POINTER LOST - SUB D,[430000,,1] ;FIX UP BYTE POINTER - JRST INCHR3 - -LFKILL: PUSHJ P,LNSTRV - JRST NECHO - -BSKILL: PUSHJ P,GETPOS ; CURRENT POSITION TO A - PUSHJ P,SETPOS ; POSITION IMLAC CURSOR - MOVEI A,20 ; ^P - XCT ECHO(E) - MOVEI A,"L ; L , DELETE TO END OF LINE - XCT ECHO(E) - JRST NECHO - -TBKILL: PUSHJ P,GETPOS - ANDI A,7 - SUBI A,10 ; A -NUMBER OF DELS TO DO - PUSH P,A - PUSHJ P,DELCHR - AOSE (P) - JRST .-2 - - SUB P,[1,,1] - JRST NECHO -TYPCHR: -IFE ITS,[ - PUSH P,A ; USE TENEX SLASH RUBOUT - MOVEI A,"\ - SKIPE C,ECHO(E) - XCT C - POP P,A -] - SKIPE C,ECHO(E) - XCT C - JRST NECHO - -; ROUTINE TO DEL CHAR ON IMLAC - -DELCHR: MOVEI A,20 - XCT ECHO(E) - MOVEI A,"X - XCT ECHO(E) - POPJ P, - -; HERE FOR SPECIAL IMLAC HACKS - -FOURQ: PUSH P,CNOTFU -FOURQ2: MOVEI C,2 ; FOR ^Z AND ^_ - CAMN B,TTICHN+1(TVP) ; SKIP IF NOT CONSOLE TTY - MOVEI C,4 -CNOTFU: POPJ P,NOTFUN - -CNECHO: JRST NECHO - -LNSTRV: MOVEI A,20 ; ^P - XCT ECHO(E) - MOVEI A,"U - XCT ECHO(E) - POPJ P, - -; HERE IF KILLING A C.R., RE-POSITION CURSOR - -CRKILL: PUSHJ P,GETPOS ; COMPUTE LINE POS - PUSHJ P,SETPOS - JRST NECHO - -SETPOS: PUSH P,A ; SAVE POS - MOVEI A,20 - XCT ECHO(E) - MOVEI A,"H - XCT ECHO(E) - POP P,A - XCT ECHO(E) ; HORIZ POSIT AT END OF LINE - POPJ P,0 - -GETPOS: PUSH P,0 - MOVEI 0,10 ; MINIMUM CURSOR POS - PUSH P,[010700,,BYTPTR(E)] ; POINT TO BUFFER - PUSH P,CHRCNT(E) ; NUMBER THEREOF - -GETPO1: SOSGE (P) ; COUNT DOWN - JRST GETPO2 - ILDB A,-1(P) ; CHAR FROM BUFFER - CAIN A,15 ; SKIP IF NOT CR - MOVEI 0,10 ; C.R., RESET COUNT - PUSHJ P,CHRTYP ; GET TYPE - XCT FIXIM3(C) ; GET FIXED COUNT - ADD 0,C - JRST GETPO1 - -GETPO2: MOVE A,0 ; RET COUNT - MOVE 0,-2(P) ; RESTORE AC 0 - SUB P,[3,,3] - POPJ P, - -CHRTYP: MOVEI C,0 ; NUMBER OF FLUSHEES - CAILE A,37 ; SKIP IF CONTROL CHAR - POPJ P, - PUSH TP,$TCHAN - PUSH TP,B ; SAVE CHAN - IDIVI A,12. ; FIND SPECIAL HACKS - MOVE A,FIXIML(A) ; GET CONT WORD - IMULI B,3 - ROTC A,3(B) ; GET CODE IN B - ANDI B,7 - MOVEI C,(B) - MOVE B,(TP) ; RESTORE CHAN - SUB TP,[2,,2] - POPJ P, - -FIXIM2: 1 - 2 - SETZ FOURQ - SETZ CRKILL - SETZ LFKILL - SETZ BSKILL - SETZ TBKILL - -FIXIM3: MOVEI C,1 - MOVEI C,2 - PUSHJ P,FOURQ2 - MOVEI C,0 - MOVEI C,0 - MOVNI C,1 - PUSHJ P,CNTTAB - -CNTTAB: ANDCMI 0,7 ; GET COUNT INCUDING TAB HACK - ADDI 0,10 - MOVEI C,0 - POPJ P, - -FIXIML: 111111,,115641 ; CNTL @ABCDE,,FGHIJK - 131111,,111111 ; LMNOPQ,,RSTUVW - 112011,,120000 ; XYZ LBRAK \ RBRAK,,^ _ - -; HERE TO KILL THE WHOLE BUFFER - -KILL: CLEARM CHRCNT(E) ;NONE LEFT NOW - MOVE D,[010700,,BYTPTR(E)] ;RESET POINTER - -BARFCR: -IFN ITS,[ - MOVE A,ERASCH(E) ;GET THE ERASE CHAR - CAIN A,177 ;IS IT RUBOUT? -] - PUSHJ P,CRLF1 ; PRINT CR-LF - JRST INCHR3 - -CLEARQ: -IFN ITS,[ - MOVE A,STATUS(B) ;CHECK CONSOLE KIND - ANDI A,77 - CAIN A,2 ;DATAPOINT? - PUSHJ P,CLR ;YES, CLEAR SCREEN -] - -BRF: MOVE C,[010700,,BYTPTR(E)] ;POINT TO START OF BUFFER - SKIPN ECHO(E) ;ANY ECHO INS? - JRST NECHO - - PUSHJ P,CRLF2 - PUSH P,CHRCNT(E) - - SOSGE (P) - JRST DECHO - ILDB A,C ;GOBBLE CHAR - XCT ECHO(E) ;ECHO IT - JRST .-4 ;DO FOR ENTIRE BUFFER - -DECHO: SUB P,[1,,1] - JRST INCHR3 - -CLR: SKIPN C,ECHO(E) ;ONLY IF INS EXISTS - POPJ P, - MOVEI A,20 ;ERASE SCREEN - XCT C - MOVEI A,103 - XCT C - POPJ P, - -PUTCHR: AOS CHRCNT(E) ;COUNT THIS CHARACTER - IBP D ;BUMP BYTE POINTER - CAIG 0,@D ;DONT SKIP IF BUFFER FULL - PUSHJ P,BUFULL ;GROW BUFFER -IFE ITS,[ - CAIN A,37 ; CHANGE EOL TO CRLF - MOVEI A,15 -] - DPB A,D ;CLOBBER BYTE POINTER IN - MOVE C,SYSCHR(E) ; FLAGS - TRNN C,N.IMED+N.CNTL - CAIE A,15 ; IF CR INPUT, FOLLOW WITH LF - POPJ P, - MOVEI A,12 ; GET LF - JRST PUTCHR - -; BUFFER FULL, GROW THE BUFFER - -BUFULL: PUSH TP,$TCHAN ;SAVE B - PUSH TP,B - PUSH P,A ; SAVE CURRENT CHAR - HLRE A,BUFRIN(B) - MOVNS A - ADDI A,100 ; MAKE ONE LONGER - PUSHJ P,IBLOCK ; GET IT - MOVE A,(TP) ;RESTORE CHANNEL POINTER - SUB TP,[2,,2] ;AND REMOVE CRUFT - MOVE E,BUFRIN(A) ;GET AUX BUFFER POINTER - MOVEM B,BUFRIN(A) - HLRE 0,E ;RECOMPUTE 0 - MOVSI E,(E) - HRRI E,(B) ; POINT TO DEST - SUB B,0 - BLT E,(B) - MOVEI 0,100-2(B) - MOVE B,A - POP P,A - POPJ P, - -; ROUTINE TO CRLF ON ANY TTY - -CRLF1: SKIPN ECHO(E) - POPJ P, ; NO ECHO INS -CRLF2: MOVEI A,15 - XCT ECHO(E) - MOVEI A,12 - XCT ECHO(E) - POPJ P, - -; SUBROUTINE TO FLUSH BUFFER - -RRESET: SETZM LSTCH(B) ; CLOBBER RE-USE CHAR - MOVE E,BUFRIN(B) ;GET AUX BUFFER - SETZM CHRCNT(E) - MOVEI D,N.IMED+N.IME1 - ANDCAM D,SYSCHR(E) - MOVE D,[010700,,BYTPTR(E)] ;RESET BYTE POINTER - MOVEM D,BYTPTR(E) - MOVE D,CHANNO(B) ;GOBBLE CHANNEL - SETZM CHNCNT(D) ; FLUSH COUNTERS -IFN ITS,[ - LSH D,23. ;POSITION - IOR D,[.RESET 0] - XCT D ;RESET ITS CHANNEL -] -IFE ITS,[ - MOVEI A,100 ; TTY IN JFN - CFIBF -] - SETZM EXBUFR(B) ; CLOBBER STAKED BUFFS - MOVEI C,BUFSTR-1(B) ; FIND D.W. - PUSHJ P,BYTDOP - SUBI A,2 - HRLI A,010700 - MOVEM A,BUFSTR(B) - HLLZS BUFSTR-1(B) - POPJ P, - -; SUBROUTINE TO ESTABLISH ECHO IOINS - -MFUNCTION ECHOPAIR,SUBR - - ENTRY 2 - - GETYP A,(AB) ;CHECK ARG TYPES - GETYP C,2(AB) - CAIN A,TCHAN ;IS A CHANNEL - CAIE C,TCHAN ;IS C ALSO - JRST WRONGT ;NO, ONE OF THEM LOSES - - MOVE A,1(AB) ;GET CHANNEL - PUSHJ P,TCHANC ; VERIFY TTY IN - MOVE D,3(AB) ;GET OTHER CHANNEL - MOVEI B,DIRECT-1(D) ;AND ITS DIRECTION - PUSHJ P,CHRWRD - JFCL - CAME B,[ASCII /PRINT/] - JRST WRONGD - - MOVE B,BUFRIN(A) ;GET A'S AUX BUFFER - HRLZ C,CHANNO(D) ; GET CHANNEL - LSH C,5 - IOR C,[.IOT A] ; BUILD AN IOT - MOVEM C,ECHO(B) ;CLOBBER -CHANRT: MOVE A,(AB) - MOVE B,1(AB) ;RETURN 1ST ARG - JRST FINIS - -TCHANC: MOVEI B,DIRECT-1(A) ;GET DIRECTION - PUSHJ P,CHRWRD ; CONVERT - JFCL - CAME B,[ASCII /READ/] - JRST WRONGD - LDB C,[600,,STATUS(A)] ;GET A CODE - CAILE C,2 ;MAKE SURE A TTY FLAVOR DEVICE - JRST WRONGC - POPJ P, -IFE ITS,[ -TTYOPEN: -TTYOP2: MOVEI A,-1 ; TENEX JFN FOR TERMINAL - MOVEI 2,145100 ; MAGIC BITS (SEE TENEX MANUAL) - SFMOD ; ZAP - RFMOD ; LETS FIND SCREEN SIZE - LDB A,[220700,,B] ; GET PAGE WIDTH - LDB B,[310700,,B] ; AND LENGTH - MOVE C,TTOCHN+1(TVP) - MOVEM A,LINLN(C) - MOVEM B,PAGLN(C) - MOVEI A,-1 ; NOW HACK CNTL CHAR STUFF - RFCOC ; GET CURRENT - AND B,[036377,,-1] ; CHANGE FOR ^@, ^A AND ^D (FOR NOW) - SFCOC ; AND RESUSE IT - - POPJ P, -] - -IFN ITS,[ -TTYOP2: .SUSET [.RTTY,,C] - SETZM NOTTY - JUMPL C,TTYNO ; DONT HAVE TTY - -TTYOPEN: - SKIPE NOTTY - POPJ P, - .OPEN TTYIN,[SIXBIT / TTY/] - JRST TTYNO - .OPEN TTYOUT,[21,,(SIXBIT /TTY/)] ;AND OUTPUT - FATAL CANT OPEN TTY - DOTCAL TTYGET,[[1000,,TTYOUT],[2000,,0],[2000,,A],[2000,,B]] - FATAL .CALL FAILURE - DOTCAL TTYSET,[[1000,,TTYOUT],MODE1,MODE2,B] - FATAL .CALL FAILURE - -SETCHN: MOVE B,TTICHN+1(TVP) ;GET CHANNEL - MOVEI C,TTYIN ;GET ITS CHAN # - MOVEM C,CHANNO(B) - .STATUS TTYIN,STATUS(B) ;CLOBBER STATUS - - MOVE B,TTOCHN+1(TVP) ;GET OUT CHAN - MOVEI C,TTYOUT - MOVEM C,CHANNO(B) - .STATUS TTYOUT,STATUS(B) - SETZM IMAGFL ;RESET IMAGE MODE FLAG - HLLZS IOINS-1(B) - DOTCAL RSSIZE,[[1000,,TTYOUT],[2000,,C],[2000,,D]] - FATAL .CALL RSSIZE LOSSAGE - MOVEM C,PAGLN(B) - MOVEM D,LINLN(B) - POPJ P, - -; HERE IF TTY WONT OPEN - -TTYNO: SETOM NOTTY - POPJ P, -] - -MTYI: SKIPE NOTTY ; SKIP IF HAVE TTY - FATAL TRIED TO USE NON-EXISTANT TTY -IFN ITS, .IOT TTYIN,A -IFE ITS, PBIN - POPJ P, - -MTYO: SKIPE NOTTY - POPJ P, ; IGNORE, DONT HAVE TTY - SKIPE IMAGFL ;SKIP RE-OPENING IF ALREADY IN ASCII - PUSHJ P,MTYO1 ;WAS IN IMAGE...RE-OPEN - CAIE A,177 ;DONT OUTPUT A DELETE -IFN ITS, .IOT TTYOUT,A -IFE ITS, PBOUT - POPJ P, - -MTYO1: MOVE B,TTOCHN+1(TVP) - PUSH P,0 - PUSHJ P,REASCI - POP P,0 - POPJ P, - -; HERE FOR TYO TO ANY TTY FLAVOR DEVICE - -GMTYO: PUSH P,0 - HRRZ 0,IOINS-1(B) ; GET FLAG - SKIPE 0 - PUSHJ P,REASCI ; RE-OPEN TTY - HRLZ 0,CHANNO(B) - ASH 0,5 - IOR 0,[.IOT A] - CAIE A,177 ; DONE OUTPUT A DELETE - XCT 0 - POP P,0 - POPJ P, - -REASCI: PUSH P,A - PUSH P,C - PUSHJ P,DEVTOC - HRLI C,21 ; ASCII GRAPHIC BIT - MOVE A,CHANNO(B) ; GET CHANNEL - ASH A,23. ; TO AC FIELD - IOR A,[.OPEN 0,C] - XCT A - FATAL TTY OPEN LOSSAGE - POP P,C - POP P,A - HLLZS IOINS-1(B) - CAMN B,TTOCHN+1(TVP) - SETZM IMAGFL - POPJ P, - - - -WRONGC: PUSH TP,$TATOM - PUSH TP,EQUOTE NOT-A-TTY-TYPE-CHANNEL - JRST CALER1 - - - -; HERE TO HANDLE TTY BLOCKING AND UNBLOCKING - -TTYBLK: PUSH TP,$TCHAN - PUSH TP,B - PUSH P,0 - PUSH P,E ; SAVE SOME ACS -IFN ITS,[ - MOVE A,CHANNO(B) ; GET CHANNEL NUMBER - SOSG CHNCNT(A) ; ANY PENDING CHARS - JRST TTYBL1 - SETZM CHNCNT(A) - MOVEI 0,1 - LSH 0,(A) - .SUSET [.SIFPI,,0] ; SLAM AN INT ON -] -TTYBL1: MOVE C,BUFRIN(B) - MOVE A,SYSCHR(C) ; GET FLAGS - TRZ A,N.IMED - TRZE A,N.IME1 ; IF WILL BE - TRO A,N.IMED ; THE MAKE IT - MOVEM A,SYSCHR(C) -IFN ITS,[ - MOVE A,[.CALL TTYIOT]; NON-BUSY WAIT - SKIPE NOTTY - MOVE A,[.SLEEP A,] -] -IFE ITS,[ - MOVE A,[PUSHJ P,TNXIN] -] - MOVEM A,WAITNS(B) - PUSH TP,$TCHSTR - PUSH TP,CHQUOTE BLOCKED - PUSH TP,$TPVP - PUSH TP,PVP - MCALL 2,INTERRUPT - MOVSI A,TCHAN - MOVEM A,BSTO(PVP) - MOVE B,(TP) - ENABLE -REBLK: MOVEI A,-1 ; IN CASE SLEEPING - XCT WAITNS(B) ; NOW WAIT - JFCL -IFE ITS, JRST .-3 -IFN ITS, JRST CHRSNR ; SNARF CHAR -REBLK1: DISABLE ; FALL THROUG=> UNBLOCKED - SETZM BSTO(PVP) - POP P,E - POP P,0 - MOVE B,(TP) - SUB TP,[2,,2] - POPJ P, - -CHRSNR: SKIPE NOTTY ; TTY? - JRST REBLK ; NO, JUST RESET AND BLOCK - .SUSET [.SIFPI,,[1_]] - JRST REBLK ; AND GO BACK - -TTYIOT: SETZ - SIXBIT /IOT/ - 1000,,TTYIN - 0 - 405000,,20000 - -; HERE TO UNBLOCK TTY - -TTYUNB: MOVE A,WAITNS(B) ; GET INS - CAMN A,[JRST REBLK1] - JRST TTYUN1 - MOVE A,[JRST REBLK1] ; LEAVE THE SLEEP - MOVEM A,WAITNS(B) - PUSH TP,$TCHAN - PUSH TP,B - PUSH TP,$TCHSTR - PUSH TP,CHQUOTE UNBLOCKED - PUSH TP,$TCHAN - PUSH TP,B - MCALL 2,INTERRUPT - MOVE B,(TP) ; RESTORE CHANNEL - SUB TP,[2,,2] -TTYUN1: POPJ P, - -IFE ITS,[ -; TENEX BASIC TTY I/O ROUTINE - -TNXIN: PUSHJ P,MTYI - PUSHJ P,INCHAR - POPJ P, -] -MFUNCTION TTYECHO,SUBR - - ENTRY 2 - - GETYP 0,(AB) - CAIE 0,TCHAN - JRST WTYP1 - MOVE A,1(AB) ; GET CHANNEL - PUSHJ P,TCHANC ; MAKE SURE IT IS TTY INPUT - MOVE E,BUFRIN(A) ; EXTRA INFO BUFFER -IFN ITS,[ - DOTCAL TTYGET,[CHANNO(A),[2000,,B],[2000,,C],[2000,,0]] - FATAL .CALL FAILURE -] -IFE ITS,[ - MOVEI A,100 ; TTY JFN - RFMOD ; MODE IN B - TRZ B,6000 ; TURN OFF ECHO -] - GETYP D,2(AB) ; ARG 2 - CAIE D,TFALSE ; SKIP IF WANT ECHO OFF - JRST ECHOON - -IFN ITS,[ - ANDCM B,[606060,,606060] - ANDCM C,[606060,,606060] - - DOTCAL TTYSET,[CHANNO(A),B,C,0] - FATAL .CALL FAILURE -] -IFE ITS,[ - SFMOD -] - - MOVEI B,N.ECHO+N.CNTL ; SET FLAGS - IORM B,SYSCHR(E) - - JRST CHANRT - -ECHOON: -IFN ITS,[ - IOR B,[202020,,202020] - IOR C,[202020,,202020] - DOTCAL TTYSET,[CHANNO(A),B,C,0] - FATAL .CALL FAILURE -] -IFE ITS,[ - TRO B,4000 - SFMOD -] - MOVEI A,N.ECHO+N.CNTL - ANDCAM A,SYSCHR(E) - JRST CHANRT - - - -; USER SUBR FOR INSTANT CHARACTER SNARFING - -MFUNCTION UTYI,SUBR,TYI - - ENTRY - CAMGE AB,[-3,,] - JRST TMA - MOVE A,(AB) - MOVE B,1(AB) - JUMPL AB,.+3 - MOVE B,IMQUOTE INCHAN - PUSHJ P,IDVAL ; USE INCHAN - GETYP 0,A ; GET TYPE - CAIE 0,TCHAN - JRST WTYP1 - LDB 0,[600,,STATUS(B)] - CAILE 0,2 - JRST WTYP1 - SKIPN A,LSTCH(B) ; ANY READ AHEAD CHAR - JRST UTYI1 ; NO, SKIP - SETZM LSTCH(B) - TLZN A,400000 ; ! HACK? - JRST UTYI2 ; NO, OK - MOVEM A,LSTCH(B) ; YES SAVE - MOVEI A,"! ; RET AN ! - JRST UTYI2 - -UTYI1: MOVE 0,IOINS(B) - CAME 0,[PUSHJ P,GETCHR] - JRST WTYP1 - PUSH TP,$TCHAN - PUSH TP,B - MOVE C,BUFRIN(B) - MOVEI D,N.IME1+N.IMED - IORM D,SYSCHR(C) ; CLOBBER IT IN - DOTCAL TTYGET,[CHANNO(B),[2000,,A],[2000,,D],[2000,,0]] - FATAL .CALL FAILURE - PUSH P,A - PUSH P,0 - PUSH P,D ; SAVE THEM - IOR D,[030303,,030303] - IOR A,[030303,,030303] - DOTCAL TTYSET,[CHANNO(B),A,D,0] - FATAL .CALL FAILURE - MOVNI A,1 - SKIPE CHRCNT(C) ; ALREADY SOME? - PUSHJ P,INCHAR - MOVE C,BUFRIN(B) ; GET BUFFER BACK - MOVEI D,N.IME1 - IORM D,SYSCHR(C) - PUSHJ P,GETCHR - MOVE B,1(TB) - MOVE C,BUFRIN(B) - MOVEI D,N.IME1+N.IMED - ANDCAM D,SYSCHR(C) - POP P,D - POP P,0 - POP P,C - DOTCAL TTYSET,[CHANNO(B),C,D,0] - FATAL .CALL FAILURE -UTYI2: MOVEI B,(A) - MOVSI A,TCHRS - JRST FINIS - -MFUNCTION IMAGE,SUBR - ENTRY - JUMPGE AB,TFA ; 1 OR 2 ARGS NEEDED - GETYP A,(AB) ;GET THE TYPE OF THE ARG - CAIE A,TFIX ;CHECK IT FOR CORRECT TYPE - JRST WTYP1 ;WAS WRONG...ERROR EXIT - HLRZ 0,AB - CAIL 0,-2 - JRST USEOTC - CAIE 0,-4 - JRST TMA - GETYP 0,2(AB) - CAIE 0,TCHAN - JRST WTYP2 - MOVE B,3(AB) ; GET CHANNEL -IMAGE1: LDB 0,[600,,STATUS(B)] - CAILE 0,2 ; MUST BE TTY - JRST IMAGFO - MOVE 0,IOINS(B) - CAMN 0,[PUSHJ P,MTYO] - JRST .+3 - CAME 0,[PUSHJ P,GMTYO] - JRST WRONGD - HRRZ 0,IOINS-1(B) - JUMPE 0,OPNIMG -IMGIOT: MOVE A,1(AB) ;GET VALUE - HRLZ 0,CHANNO(B) - ASH 0,5 - IOR 0,[.IOT A] - XCT 0 -IMGEXT: MOVE A,(AB) ;RETURN THE ORIGINAL ARG - MOVE B,1(AB) - JRST FINIS ;EXIT - - -IMAGFO: PUSH TP,$TCHAN ;IMAGE OUTPUT FOR NON TTY - PUSH TP,B - MOVEI B,DIRECT-1(B) - PUSHJ P,CHRWRD - JFCL - CAME B,[ASCII /PRINT/] - CAMN B,[+1] - JRST .+2 - JRST BADCHN ; CHANNEL COULDNT BE BLESSED - MOVE B,(TP) - PUSHJ P,GWB ; MAKE SURE CHANNEL HAS BUFFER - MOVE A,1(AB) ; GET THE CHARACTER TO DO - PUSHJ P,W1CHAR - MOVE A,(AB) - MOVE B,1(AB) ;RETURN THE FIX - JRST FINIS - - -USEOTC: MOVSI A,TATOM - MOVE B,IMQUOTE OUTCHAN - PUSHJ P,IDVAL - GETYP 0,A - CAIE 0,TCHAN - MOVE B,TTICHN+1(TVP) - JRST IMAGE1 - -OPNIMG: HLLOS IOINS-1(B) - CAMN B,TTOCHN+1(TVP) - SETOM IMAGFL - PUSHJ P,DEVTOC - HRLI C,41 ; SUPER IMAGE BIT - MOVE A,CHANNO(B) - ASH A,23. - IOR A,[.OPEN 0,C] - XCT A - FATAL TTY OPEN LOSSAGE - JRST IMGIOT - -DEVTOC: PUSH P,D - PUSH P,E - PUSH P,0 - PUSH P,A - MOVE D,RDEVIC(B) - MOVE E,[220600,,C] - MOVEI A,3 - MOVEI C,0 - ILDB 0,D - SUBI 0,40 - IDPB 0,E - SOJG A,.-3 - POP P,A - POP P,0 - POP P,E - POP P,D - POPJ P, - -IMGBLK: OUT+IMAGEM+UNIT,,(SIXBIT /TTY/) - 0 - 0 - - - -IMPURE -IMAGFL: 0 -PURE - - -END - -TITLE READER FOR MUDDLE - -;C. REEVE DEC. 1970 - -RELOCA - -READER==1 ;TELL MUDDLE > TO USE SOME SPECIAL HACKS -FRMSIN==1 ;FLAG SAYING WHETHER OR "." AND "'" HACKS EXIST - -.INSRT MUDDLE > - -.GLOBAL CONS,VECTOR,NXTCHR,RLOOKU,CRADIX,SPTIME,QUOTE,TENTAB,CHMAK,FLUSCH,ITENTB -.GLOBAL SETDEV,OPNCHN,ILVAL,RADX,IDVAL,LSTCH,EVECTOR,EUVECTOR,CHUNW -.GLOBAL CHRWRD,EOFCND,DIRECT,ACCESS,IOINS,ROOT,DIRECT,DOIOTI,DOACCS,IGVAL,BYTDOP -.GLOBAL ICONS,INCONS,IEVECT,IEUVEC,BUFSTR,TYPFND,SQUTOA,IBLOCK,GRB -.GLOBAL BADCHN,WRONGD,CHNCLS,FNFFL,IPUT,IGET,ILOC,RXCT,WXCT,IUNWIN,UNWIN2 -.GLOBAL CNXTCH,CREADC,MPOPJ,CREDC1,CNXTC1,IREMAS - -BUFLNT==100 - -FF=0 ;FALG REGISTER DURING NUMBER CONVERSION - -;FLAGS USED (RIGHT HALF) - -NOTNUM==1 ;NOT A NUMBER -NFIRST==2 ;NOT FIRST CHARACTER BEING READ -DECFRC==4 ;FORCE DECIMAL CONVERSION -NEGF==10 ;NEGATE THIS THING -NUMWIN==20 ;DIGIT(S) SEEN -INSTRN==40 ;IN QUOTED CHARACTER STRING -FLONUM==100 ;NUMBER IS FLOOATING POINT -DOTSEN==200 ;. SEEN IN IMPUT STREAM -EFLG==400 ;E SEEN FOR EXPONENT -IFN FRMSIN,[ - FRSDOT==1000 ;. CAME FIRST - USEAGN==2000 ;SPECIAL DOT HACK -] -OCTWIN==4000 -OCTSTR==10000 - -;TEMPORARY OFFSETS - -VCNT==0 ;NUMBER OF ELEMENTS IN CURRENT VECTOR -ONUM==1 ;CURRENT NUMBER IN OCTAL -DNUM==3 ;CURRENT NUMBER IN DECIMAL -FNUM==5 ;CURRENTLY UNUSED -CNUM==7 ;IN CURRENT RADIX -NDIGS==11 ;NUMBER OF DIGITS -ENUM==13 ;EXPONENT - - - ; TEXT FILE LOADING PROGRAM - -MFUNCTION MLOAD,SUBR,[LOAD] - - ENTRY - - HLRZ A,AB ;GET NO. OF ARGS - CAIE A,-4 ;IS IT 2 - JRST TRY2 ;NO, TRY ANOTHER - GETYP A,2(AB) ;GET TYPE - CAIE A,TOBLS ;IS IT OBLIST - CAIN A,TLIST ; OR LIST THEREOF? - JRST CHECK1 - JRST WTYP2 - -TRY2: CAIE A,-2 ;IS ONE SUPPLIED - JRST WNA - -CHECK1: GETYP A,(AB) ;GET TYPE - CAIE A,TCHAN ;IS IT A CHANNEL - JRST WTYP1 - -LOAD1: HLRZ A,TB ;GET CURRENT TIME - PUSH TP,$TTIME ;AND SAVE IT - PUSH TP,A - - MOVEI C,CLSNGO ; LOCATION OF FUNNY CLOSER - PUSHJ P,IUNWIN ; SET UP AS UNWINDER - -LOAD2: PUSH TP,(AB) ;USE SUPPLIED CHANNEL - PUSH TP,1(AB) - PUSH TP,(TB) ;USE TIME AS EOF ARG - PUSH TP,1(TB) - CAML AB,[-2,,0] ;CHECK FOR 2ND ARG - JRST LOAD3 ;NONE - PUSH TP,2(AB) ;PUSH ON 2ND ARG - PUSH TP,3(AB) - MCALL 3,READ - JRST CHKRET ;CHECK FOR EOF RET - -LOAD3: MCALL 2,READ -CHKRET: CAMN A,(TB) ;IS TYPE EOF HACK - CAME B,1(TB) ;AND IS VALUE - JRST EVALIT ;NO, GO EVAL RESULT - PUSH TP,(AB) - PUSH TP,1(AB) - MCALL 1,FCLOSE - MOVE A,$TCHSTR - MOVE B,CHQUOTE DONE - JRST FINIS - -CLSNGO: PUSH TP,$TCHAN - PUSH TP,1(AB) - MCALL 1,FCLOSE - JRST UNWIN2 ; CONTINUE UNWINDING - -EVALIT: PUSH TP,A - PUSH TP,B - MCALL 1,EVAL - JRST LOAD2 - - - -; OTHER FILE LOADING PROGRAM - - - -MFUNCTION FLOAD,SUBR - - ENTRY - - MOVEI C,1 ;INITIALIZE OPEN'S ARG COUNT - PUSH TP,$TAB ;SLOT FOR SAVED AB - PUSH TP,[0] ;EMPTY FOR NOW - PUSH TP,$TCHSTR ;PUT IN FIRST ARG - PUSH TP,CHQUOTE READ - MOVE A,AB ;COPY OF ARGUMENT POINTER - -FARGS: JUMPGE A,CALOPN ;DONE? IF SO CALL OPEN - GETYP B,(A) ;NO, CHECK TYPE OF THIS ARG - CAIE B,TOBLS ;OBLIST? - CAIN B,TLIST ; OR LIST THEREOF - JRST OBLSV ;YES, GO SAVE IT - - PUSH TP,(A) ;SAVE THESE ARGS - PUSH TP,1(A) - ADD A,[2,,2] ;BUMP A - AOJA C,FARGS ;COUNT AND GO - -OBLSV: MOVEM A,1(TB) ;SAVE THE AB - -CALOPN: ACALL C,FOPEN ;OPEN THE FILE - - JUMPGE B,FNFFL ;FILE MUST NO EXIST - EXCH A,(TB) ;PLACE CHANNEL ON STACK - EXCH B,1(TB) ;OBTAINING POSSIBLE OBLIST - JUMPN B,2ARGS ;OBLIST SUOPPLIED? - - MCALL 1,MLOAD ;NO, JUST CALL - JRST FINIS - - -2ARGS: PUSH TP,(B) ;PUSH THE OBLIST - PUSH TP,1(B) - MCALL 2,MLOAD - JRST FINIS - - -FNFFL: PUSH TP,$TATOM - PUSH TP,EQUOTE FILE-SYSTEM-ERROR - JUMPE B,CALER1 - PUSH TP,A - PUSH TP,B - MOVEI A,2 - JRST CALER - - MFUNCTION READ,SUBR - - ENTRY - - PUSH P,[IREAD1] ;WHERE TO GO AFTER BINDING -READ0: PUSH TP,$TTP ;SLOT FOR LAST THING READ (TYPE IS UNREADABLE) - PUSH TP,[0] - PUSH TP,$TFIX ;SLOT FOR RADIX - PUSH TP,[0] - PUSH TP,$TCHAN ;AND SLOT FOR CHANNEL - PUSH TP,[0] - PUSH TP,[0] ; USER DISP SLOT - PUSH TP,[0] - PUSH TP,$TSPLICE - PUSH TP,[0] ;SEGMENT FOR SPLICING MACROS - JUMPGE AB,READ1 ;NO ARGS, NO BINDING - GETYP C,(AB) ;ISOLATE TYPE - CAIN C,TUNBOU - JRST WTYP1 - PUSH TP,[TATOM,,-1] ;PUSH THE ATOMS - PUSH TP,IMQUOTE INCHAN - PUSH TP,(AB) ;PUSH ARGS - PUSH TP,1(AB) - PUSH TP,[0] ;DUMMY - PUSH TP,[0] - MOVE B,1(AB) ;GET CHANNEL POINTER - ADD AB,[2,,2] ;AND ARG POINTER - JUMPGE AB,BINDEM ;MORE? - PUSH TP,[TVEC,,-1] - ADD B,[EOFCND-1,,EOFCND-1] - PUSH TP,B - PUSH TP,(AB) - PUSH TP,1(AB) - ADD AB,[2,,2] - JUMPGE AB,BINDEM ;IF ANY MORE ARGS GO PROCESS AND BIND THEM - GETYP C,(AB) ;ISOLATE TYPE - CAIE C,TLIST - CAIN C,TOBLS - SKIPA - JRST WTYP3 - PUSH TP,[TATOM,,-1] ;PUSH THE ATOMS - PUSH TP,IMQUOTE OBLIST - PUSH TP,(AB) ;PUSH ARGS - PUSH TP,1(AB) - PUSH TP,[0] ;DUMMY - PUSH TP,[0] - ADD AB,[2,,2] ;AND ARG POINTER - JUMPGE AB,BINDEM ; ALL DONE, BIND ATOMS - GETYP 0,(AB) ; GET TYPE OF TABLE - CAIE 0,TVEC ; SKIP IF BAD TYPE - JRST WTYP ; ELSE COMPLAIN - PUSH TP,[TATOM,,-1] - PUSH TP,IMQUOTE READ-TABLE - PUSH TP,(AB) - PUSH TP,1(AB) - PUSH TP,[0] - PUSH TP,[0] - ADD AB,[2,,2] ; BUMP TO NEXT ARG - JUMPL AB,TMA ;MORE ?, ERROR -BINDEM: PUSHJ P,SPECBIND - JRST READ1 - -MFUNCTION RREADC,SUBR,READCHR - - ENTRY - PUSH P,[IREADC] - JRST READC0 ;GO BIND VARIABLES - -MFUNCTION NXTRDC,SUBR,NEXTCHR - - ENTRY - - PUSH P,[INXTRD] -READC0: CAMGE AB,[-5,,] - JRST TMA - PUSH TP,(AB) - PUSH TP,1(AB) - JUMPL AB,READC1 - MOVE B,IMQUOTE INCHAN - PUSHJ P,IDVAL - GETYP A,A - CAIE A,TCHAN - JRST BADCHN - MOVEM A,-1(TP) - MOVEM B,(TP) -READC1: PUSHJ P,@(P) - JRST .+2 - JRST FINIS - - PUSH TP,-1(TP) - PUSH TP,-1(TP) - MCALL 1,FCLOSE - MOVE A,EOFCND-1(B) - MOVE B,EOFCND(B) - CAML AB,[-3,,] - JRST .+3 - MOVE A,2(AB) - MOVE B,3(AB) - PUSH TP,A - PUSH TP,B - MCALL 1,EVAL - JRST FINIS - - -MFUNCTION PARSE,SUBR - - ENTRY - - PUSHJ P,GAPRS ;GET ARGS FOR PARSES - PUSHJ P,GPT ;GET THE PARSE TABLE - PUSHJ P,NXTCH ; GET A CHAR TO TEST FOR ! ALT - SKIPN 11.(TB) ; EOF HIT, COMPLAIN TO LOOSER - JRST NOPRS - MOVEI A,33 ; CHANGE IT TO AN ALT, SNEAKY HUH? - CAIN B,MANYT ; TYPE OF MULTIPLE CLOSE, I.E. ! ALT - MOVEM A,5(TB) - PUSHJ P,IREAD1 ;GO DO THE READING - JRST .+2 - JRST LPSRET ;PROPER EXIT -NOPRS: PUSH TP,$TATOM - PUSH TP,EQUOTE CAN'T-PARSE - JRST CALER1 - -MFUNCTION LPARSE,SUBR - - ENTRY - - PUSHJ P,GAPRS ;GET THE ARGS TO THE PARSE - JRST LPRS1 - -GAPRS: PUSH TP,$TTP - PUSH TP,[0] - PUSH TP,$TFIX - PUSH TP,[10.] - PUSH TP,$TFIX - PUSH TP,[0] ; LETTER SAVE - PUSH TP,[0] - PUSH TP,[0] ; PARSE TABLE MAYBE? - PUSH TP,$TSPLICE - PUSH TP,[0] ;SEGMENT FOR SPLICING MACROS - PUSH TP,[0] ;SLOT FOR LOCATIVE TO STRING - PUSH TP,[0] - JUMPGE AB,USPSTR - PUSH TP,[TATOM,,-1] - PUSH TP,IMQUOTE PARSE-STRING - PUSH TP,(AB) - PUSH TP,1(AB) ; BIND OLD PARSE-STRING - PUSH TP,[0] - PUSH TP,[0] - PUSHJ P,SPECBIND - ADD AB,[2,,2] - JUMPGE AB,USPSTR - GETYP 0,(AB) - CAIE 0,TFIX - JRST WTYP2 - MOVE 0,1(AB) - MOVEM 0,3(TB) - ADD AB,[2,,2] - JUMPGE AB,USPSTR - GETYP 0,(AB) - CAIE 0,TLIST - CAIN 0,TOBLS - SKIPA - JRST WTYP3 - PUSH TP,[TATOM,,-1] - PUSH TP,IMQUOTE OBLIST - PUSH TP,(AB) - PUSH TP,1(AB) ; HE WANTS HIS OWN OBLIST - PUSH TP,[0] - PUSH TP,[0] - PUSHJ P,SPECBIND - ADD AB,[2,,2] - JUMPGE AB,USPSTR - GETYP 0,(AB) - CAIE 0,TVEC - JRST WTYP - PUSH TP,[TATOM,,-1] - PUSH TP,IMQUOTE PARSE-TABLE - PUSH TP,(AB) - PUSH TP,1(AB) - PUSH TP,[0] - PUSH TP,[0] - PUSHJ P,SPECBIND - ADD AB,[2,,2] - JUMPGE AB,USPSTR - GETYP 0,(AB) - CAIE 0,TCHRS - JRST WTYP - MOVE 0,1(AB) - MOVEM 0,5(TB) ; STUFF IN A LOOK-AHEAD CHARACTER IF HE WANTS - ADD AB,[2,,2] - JUMPL AB,TMA -USPSTR: MOVE B,IMQUOTE PARSE-STRING - PUSHJ P,ILOC ; GET A LOCATIVE TO THE STRING, WHEREVER - GETYP 0,A - CAIN 0,TUNBOUND ; NONEXISTANT - JRST BDPSTR - GETYP 0,(B) ; IT IS POINTING TO A STRING - CAIE 0,TCHSTR - JRST BDPSTR - MOVEM A,10.(TB) - MOVEM B,11.(TB) - POPJ P, - -LPRS1: PUSHJ P,GPT ; GET THE VALUE OF PARSE-TABLE IN SLOT - PUSH TP,$TLIST - PUSH TP,[0] ; HERE WE ARE MAKE PLACE TO SAVE GOODIES - PUSH TP,$TLIST - PUSH TP,[0] -LPRS2: PUSHJ P,IREAD1 - JRST LPRSDN ; IF WE ARE DONE, WE ARE THROUGH - MOVE C,A - MOVE D,B - PUSHJ P,INCONS - SKIPN -2(TP) - MOVEM B,-2(TP) ; SAVE THE BEGINNING ON FIRST - SKIPE C,(TP) - HRRM B,(C) ; PUTREST INTO IT - MOVEM B,(TP) - JRST LPRS2 -LPRSDN: MOVSI A,TLIST - MOVE B,-2(TP) -LPSRET: SKIPLE C,5(TB) ; EXIT FOR PARSE AND LPARSE - CAIN C,400033 ; SEE IF NO PEEK AHEAD OR IF ! ALTMODE - JRST FINIS ; IF SO NO NEED TO BACK STRING ONE - SKIPN C,11.(TB) - JRST FINIS ; IF ATE WHOLE STRING, DONT GIVE BACK ANY -BUPRS: MOVEI D,1 - ADDM D,(C) ; AOS THE COUNT OF STRING LENGTH - SKIPG D,1(C) ; SEXIER THAN CLR'S CODE FOR DECREMENTING - SUB D,[430000,,1] ; A BYTE POINTER - ADD D,[70000,,0] - MOVEM D,1(C) - HRRZ E,2(TB) - JUMPE E,FINIS ; SEE IF WE NEED TO BACK UP TWO - HLLZS 2(TB) ; CLEAR OUT DOUBLE CHR LOOKY FLAG - JRST BUPRS ; AND BACK UP PARSE STRING A LITTLE MORE - - ; ARGUMENTS ARE BOUND, NOW GET THE VALUES OF THINGS - - -GRT: MOVE B,IMQUOTE READ-TABLE - SKIPA ; HERE TO GET TABLE FOR READ -GPT: MOVE B,IMQUOTE PARSE-TABLE - MOVSI A,TATOM ; TO FILL SLOT WITH PARSE TABLE - PUSHJ P,ILVAL - GETYP 0,A - CAIN 0,TUNBOUND - POPJ P, - CAIE 0,TVEC - JRST BADPTB - MOVEM A,6(TB) - MOVEM B,7(TB) - POPJ P, - -READ1: PUSHJ P,GRT - MOVE B,IMQUOTE INCHAN - MOVSI A,TATOM - PUSHJ P,IDVAL ;NOW GOBBLE THE REAL CHANNEL - TLZ A,TYPMSK#777777 - HLLZS A ; INCASE OF FUNNY BUG - CAME A,$TCHAN ;IS IT A CHANNEL - JRST BADCHN - MOVEM A,4(TB) ; STORE CHANNEL - MOVEM B,5(TB) - HRRZ A,-4(B) - TRC A,C.OPN+C.READ - TRNE A,C.OPN+C.READ - JRST WRONGD - HLLOS 4(TB) - TRNE A,C.BIN ; SKIP IF NOT BIN - JRST BREAD ; CHECK FOR BUFFER - HLLZS 4(TB) -GETIOA: MOVE B,5(TB) -GETIO: MOVE A,IOINS(B) ;GOBBLE THE I/O INSTRUCTION - JUMPE A,OPNFIL ;GO REALLY OPEN THE CROCK - MOVE A,RADX(B) ;GET RADIX - MOVEM A,3(TB) - MOVEM B,5(TB) ;SAVE CHANNEL -REREAD: MOVE D,LSTCH(B) ;ANY CHARS AROUND? - MOVEI 0,33 - CAIN D,400033 ;FLUSH THE TERMINATOR HACK - MOVEM 0,LSTCH(B) ; MAKE ! ALT INTO JUST ALT IF IT IS STILL AROUND - - PUSHJ P,@(P) ;CALL INTERNAL READER - JRST BADTRM ;LOST -RFINIS: SUB P,[1,,1] ;POP OFF LOSER - PUSH TP,A - PUSH TP,B - JUMPE C,FLSCOM ; FLUSH TOP LEVEL COMMENT - PUSH TP,C - PUSH TP,D - MOVE A,4(TB) - MOVE B,5(TB) ; GET CHANNEL - MOVSI C,TATOM - MOVE D,MQUOTE COMMENT - PUSHJ P,IPUT -RFINI1: POP TP,B - POP TP,A - JRST FINIS - -FLSCOM: MOVE A,4(TB) - MOVE B,5(TB) - MOVSI C,TATOM - MOVE D,MQUOTE COMMENT - PUSHJ P,IREMAS - JRST RFINI1 - -BADTRM: MOVE C,5(TB) ; GET CHANNEL - JUMPGE B,CHLSTC ;NO, MUST BE UNMATCHED PARENS - SETZM LSTCH(C) ; DONT REUSE EOF CHR - PUSH TP,4(TB) ;CLOSE THE CHANNEL - PUSH TP,5(TB) - MCALL 1,FCLOSE - PUSH TP,EOFCND-1(B) - PUSH TP,EOFCND(B) - MCALL 1,EVAL ;AND EVAL IT - SETZB C,D - GETYP 0,A ; CHECK FOR FUNNY ACT - CAIE 0,TREADA - JRST RFINIS ; AND RETURN - - PUSHJ P,CHUNW ; UNWIND TO POINT - MOVSI A,TREADA ; SEND MESSAGE BACK - JRST CONTIN - -;HERE TO ATTEMPT TO OPEN A CLOSED CHANNEL - -OPNFIL: PUSHJ P,OPNCHN ;GO DO THE OPEN - JUMPGE B,FNFFL ;LOSE IC B IS 0 - JRST GETIO - - -CHLSTC: MOVE B,5(TB) ;GET CHANNEL BACK - JRST REREAD - - -BREAD: MOVE B,5(TB) ; GET CHANNEL - SKIPE BUFSTR(B) - JRST GETIO - MOVEI A,BUFLNT ; GET A BUFFER - PUSHJ P,IBLOCK - MOVEI C,BUFLNT(B) ; POINT TO END - HRLI C,440700 - MOVE B,5(TB) ; CHANNEL BACK - MOVEI 0,C.BUF - IORM 0,-4(B) - MOVEM C,BUFSTR(B) - MOVSI C,TCHSTR+.VECT. - MOVEM C,BUFSTR-1(B) - JRST GETIO - ;MAIN ENTRY TO READER - -NIREAD: PUSHJ P,LSTCHR -NIREA1: PUSH P,[-1] ; DONT GOBBLE COMMENTS - JRST IREAD2 - -IREAD: - PUSHJ P,LSTCHR ;DON'T REREAD LAST CHARACTER -IREAD1: PUSH P,[0] ; FLAG SAYING SNARF COMMENTS -IREAD2: INTGO -BDLP: SKIPE C,9.(TB) ;HAVE WE GOT A SPLICING MACRO LEFT - JRST SPLMAC ;IF SO GIVE HIM SOME OF IT - PUSHJ P,NXTCH ;GOBBLE CHAR IN A AND TYPE IN D - MOVMS B ; FOR SPECIAL NEG HACK OF MACRO TABLES - CAIG B,ENTYPE - JUMPN B,@DTBL-1(B) ;ERROR ON ZERO TYPE OR FUNNY TYPE - JRST BADCHR - - -SPLMAC: HRRZ D,(C) ;GET THE REST OF THE SEGMENT - MOVEM D,9.(TB) ;AND PUT BACK IN PLACE - GETYP D,(C) ;SEE IF DEFERMENT NEEDED - CAIN D,TDEFER - MOVE C,1(C) ;IF SO, DO DEFEREMENT - MOVE A,(C) - MOVE B,1(C) ;GET THE GOODIE - AOS -1(P) ;ALWAYS A SKIP RETURN - POP P,(P) ;DONT WORRY ABOUT COMMENT SEARCHAGE - SETZB C,D ;MAKE SURE HE DOESNT THINK WE GOT COMMENT - POPJ P, ;GIVE HIM WHAT HE DESERVES - -DTBL: NUMLET ;HERE IF NUMBER OR LETTER - NUMLET ;NUMBER -NUMCOD==.-DTBL - NUMLET ;+- -PLUMIN==.-DTBL - NUMLET ;. -DOTTYP==.-DTBL - NUMLET ;E -NONSPC==.-DTBL ;NUMBER OF NON-SPECIAL CHARACTERS - SPACE ;SPACING CHAR CR,LF,SP,TAB ETC. -SPATYP==.-DTBL ;TYPE FOR SPACE CHARS - - -;THE FOLLOWING ENTRIES ARE VARIOUS PUNCTUATION CROCKS - - LPAREN ;( - BEGIN LIST - RPAREN ;) - END CURRENT LEVEL OF INPUT - LBRACK ;[ -BEGIN ARRAY -LBRTYP==.-DTBL - RBRACK ;] - END OF ARRAY - QUOTIT ;' - QUOTE THE FOLLOWING GOODIE -QUOTYP==.-DTBL - - MACCAL ;% - INVOKE A READ TIME MACRO -MACTYP==.-DTBL - CSTRING ;" - CHARACTER STRING -CSTYP==.-DTBL - NUMLET ;\ - ESCAPE,BEGIN ATOM - -ESCTYP==.-DTBL ;TYPE OF ESCAPE CHARACTER - - SPECTY ;# - SPECIAL TYPE TO BE READ -SPCTYP==.-DTBL - OPNANG ;< - BEGIN ELEMENT CALL - -SLMNT==.-DTBL ;TYPE OF START OF SEGMENT - - CLSANG ;> - END ELEMENT CALL - - - EOFCHR ;^C - END OF FILE - - COMNT ;; - BEGIN COMMENT -COMTYP==.-DTBL ;TYPE OF START OF COMMENT - - GLOVAL ;, - GET GLOBAL VALUE -GLMNT==.-DTBL - ILLSQG ;{ - START TEMPLATE STRUCTURE -TMPTYP==.-DTBL - CLSBRA ;} - END TEMPLATE STRUCTURE - -NTYPES==.-DTBL - - - -; EXTENDED TABLE FOR ! HACKS - - NUMLET ; !! FAKE OUT - SEGDOT ;!. - CALL TO LVAL (SEG) -DOTEXT==.-DTBL - UVECIN ;![ - INPUT UNIFORM VECTOR ] -LBREXT==.-DTBL - QUOSEG ;!' - SEG CALL TO QUOTE -QUOEXT==.-DTBL - SINCHR ;!" - INPUT ONE CHARACTER -CSEXT==.-DTBL - SEGIN ;!< - SEG CALL -SLMEXT==.-DTBL - GLOSEG ;!, - SEG CALL TO GVAL -GLMEXT==.-DTBL - LOSPATH ;!- - PATH NAME SEPARATOR -PATHTY==.-DTBL - TERM ;!$ - (EXCAL-ALT MODE) PUT ALL CLOSES -MANYT==.-DTBL - USRDS1 ; DISPATCH FOR USER TABLE (NO !) -USTYP1==.-DTBL - USRDS2 ; " " " " (WITH !) -USTYP2==.-DTBL -ENTYPE==.-DTBL - - - -SPACE: PUSHJ P,LSTCHR ;DONT REREAD SPACER - JRST BDLP - -USRDS1: SKIPA B,A ; GET CHAR IN B -USRDS2: MOVEI B,200(A) ; ! CHAR, DISP 200 FURTHER - ASH B,1 - ADD B,7(TB) ; POINT TO TABLE ENTRY - GETYP 0,(B) - CAIN 0,TLIST - MOVE B,1(B) ; IF LIST, USE FIRST ITEM-SPECIAL NO BREAK HACK - SKIPL C,5(TB) ; GET CHANNEL POINTER (IF ANY) - JRST USRDS3 - ADD C,[EOFCND-1,,EOFCND-1] - PUSH TP,$TBVL - HRRM SP,(TP) ; BUILD A TBVL - MOVE SP,TP - PUSH TP,C - PUSH TP,(C) - PUSH TP,1(C) - MOVEI D,PVLNT*2+1(PVP) - HRLI D,TREADA - MOVEM D,(C) - MOVEI D,(TB) - HLL D,OTBSAV(TB) - MOVEM D,1(C) -USRDS3: PUSH TP,(B) ; APPLIER - PUSH TP,1(B) - PUSH TP,$TCHRS ; APPLY TO CHARACTER - PUSH TP,A - PUSHJ P,LSTCHR ; FLUSH CHAR - MCALL 2,APPLY ; GO TO USER GOODIE - HRRZ SP,(SP) ; UNBIND MANUALLY - MOVEI D,(TP) - SUBI D,(SP) - MOVSI D,(D) - HLL SP,TP - SUB SP,D - SUB TP,[4,,4] ; FLUSH TP CRAP - GETYP 0,A ; CHECK FOR DISMISS? - CAIN 0,TSPLICE - JRST GOTSPL ; RETURN OF SEGMENT INDICATES SPLICAGE - CAIN 0,TREADA ; FUNNY? - JRST DOEOF - CAIE 0,TDISMI - JRST RET ; NO, RETURN FROM IREAD - JRST BDLP ; YES, IGNORE RETURN - -GOTSPL: MOVEM B,9.(TB) ; STICK IN THE SPLICAGE SLOT SO IREADS WILL GET HIM - JRST BDLP ; GO BACK AND READ FROM OUR SPLICE, OK? - - -;HERE ON NUMBER OR LETTER, START ATOM - -NUMLET: PUSHJ P,GOBBLE ;READ IN THE ATOM AND PUT PNTR ON ARG PDL - JRST RET ;NO SKIP RETURN I.E. NON NIL - -;HERE TO START BUILDING A CHARACTER STRING GOODIE - -CSTRING: PUSHJ P,GOBBL1 ;READ IN STRING - JRST RET - -;ARRIVE HERE TO INVOKE A READ TIME MACRO FUNCTION - -MACCAL: PUSHJ P,NXTCH1 ;READ ONE MORE CHARACTER - CAIE B,MACTYP ;IS IT ANOTHER MACRO CHAR - - JRST MACAL2 ;NO, CALL MACRO AND USE VALUE - PUSHJ P,LSTCHR ;DONT REREAD % - PUSHJ P,MACAL1 ;OTHERWISE, USE SIDE EFFECCT, BUT NOT VALUE - JRST IREAD2 - -MACAL2: PUSH P,CRET -MACAL1: PUSHJ P,IREAD1 ;READ FUNCTION NAME - JRST RETERR - PUSH TP,C - PUSH TP,D ; SAVE COMMENT IF ANY - PUSH TP,A ;SAVE THE RESULT - PUSH TP,B ;AND USE IT AS AN ARGUMENT - MCALL 1,EVAL - POP TP,D - POP TP,C ; RESTORE COMMENT IF ANY... -CRET: POPJ P,RET12 - -;CALL GOBBLE TO FIND THE TYPE AND THEN IREAD TO READ IT - -SPECTY: PUSHJ P,NIREAD ; READ THE TYPES NAME (SHOULD BE AN ATOM) - JRST RETERR - PUSH TP,A - PUSH TP,B - PUSHJ P,NXTCH ; GET NEXT CHAR - CAIN B,TMPTYP ; SKIP IF NOT TEMPLATE START - JRST RDTMPL - SETZB A,B - EXCH A,-1(TP) - EXCH B,(TP) - PUSH TP,A ;BEGIN SETTING UP CHTYPE CALL - PUSH TP,B - PUSHJ P,IREAD1 ;NOW READ STRUCTURE - JRST RETER1 - MOVEM C,-3(TP) ; SAVE COMMENT - MOVEM D,-2(TP) - EXCH A,-1(TP) ;USE AS FIRST ARG - EXCH B,(TP) - PUSH TP,A ;USE OTHER AS 2D ARG - PUSH TP,B - MCALL 2,CHTYPE ;ATTEMPT TO MUNG -RET13: POP TP,D - POP TP,C ; RESTORE COMMENT -RET12: SETOM (P) ; DONT LOOOK FOR MORE! - JRST RET - -RDTMPL: PUSH P,["}] ; SET UP TERMINATE TEST - MOVE B,(TP) - PUSHJ P,IGVAL - MOVEM A,-1(TP) - MOVEM B,(TP) - PUSH P,[BLDTMP] ; FLAG FOR VECTOR READING CODE - JRST LBRAK2 - -BLDTMP: ADDI A,1 ; 1 MORE ARGUMENT - ACALL A,APPLY ; DO IT TO IT - POPJ P, - -RETER1: SUB TP,[2,,2] -RETERR: SKIPL A,5(TB) - MOVEI A,5(TB)-LSTCH ;NO CHANNEL, USE SLOT - MOVEM B,LSTCH(A) ; RESTORE LAST CHAR - PUSHJ P,ERRPAR - JRST RET1 - -;THIS CODE CALLS IREAD RECURSIVELY TO READ THAT WHICH IS -;BETWEEN (), ARRIVED AT WHEN ( IS READ - -SEGIN: PUSH TP,$TSEG - JRST OPNAN1 - -OPNANG: PUSH TP,$TFORM ;SAVE TYPE -OPNAN1: PUSH P,[">] - JRST LPARN1 - -LPAREN: PUSH P,[")] - PUSH TP,$TLIST ;START BY ASSUMING NIL -LPARN1: PUSH TP,[0] - PUSHJ P,LSTCHR ;DON'T REREAD PARENS -LLPLOP: PUSHJ P,IREAD1 ;READ IT - JRST LDONE ;HIT TERMINATOR - -;HERE WHEN MUST ADD CAR TO CURRENT WINNER - -GENCAR: PUSH TP,C ; SAVE COMMENT - PUSH TP,D - MOVE C,A ; SET UP CALL - MOVE D,B - PUSHJ P,INCONS ; CONS ON TO NIL - POP TP,D - POP TP,C - POP TP,E ;GET CDR - JUMPN E,CDRIN ;IF STACKED GOODIE NOT NIL SKIP - PUSH TP,B ;AND USE AS TOTAL VALUE - PUSH TP,$TLIST ;SAVE THIS AS FIRSST THING ON LIST - MOVE A,-2(TP) ; GET REAL TYPE - JRST .+2 ;SKIP CDR SETTING -CDRIN: HRRM B,(E) - PUSH TP,B ;CLOBBER IN NEW PARTIAL GOODIE - JUMPE C,LLPLOP ; JUMP IF NO COMMENT - PUSH TP,C - PUSH TP,D - MOVSI C,TATOM - MOVE D,MQUOTE COMMENT - PUSHJ P,IPUT - JRST LLPLOP ;AND CONTINUE - -; HERE TO RAP UP LIST - -LDONE: CAME B,(P) ;CHECK VALIDITY OF CHARACTER - PUSHJ P,MISMAT ;REPORT MISMATCH - SUB P, [1,,1] - POP TP,B ;GET VALUE OF PARTIAL RESULT - POP TP,A ;AND TYPE OF SAME - JUMPE B,RET ;VALUE IS NIL, DON'T POP AGAIN - POP TP,B ;POP FIRST LIST ELEMENT - POP TP,A ;AND TYPE - JRST RET - -;THIS CODE IS SIMILAR TO LIST GENERATING CODE BUT IS FOR VECTORS -OPNBRA: PUSH P,["}] ; SAVE TERMINATOR -UVECIN: PUSH P,[135] ; CLOSE SQUARE BRACKET - PUSH P,[IEUVECTOR] ;PUSH NAME OF U VECT HACKER - JRST LBRAK2 ;AND GO - -LBRACK: PUSH P,[135] ; SAVE TERMINATE - PUSH P,[IEVECTOR] ;PUSH GEN VECTOR HACKER -LBRAK2: PUSHJ P,LSTCHR ;FORCE READING NEW CHAR - PUSH P,[0] ; COUNT ELEMENTS - PUSH TP,$TLIST ; AND SLOT FOR GOODIES - PUSH TP,[0] - -LBRAK1: PUSHJ P,IREAD1 ;RECURSIVELY READ ELEMENTS OF ARRAY - JRST LBDONE ;RAP UP ON TERMINATOR - -STAKIT: EXCH A,-1(TP) ; STORE RESULT AND GET CURRENT LIST - EXCH B,(TP) - AOS (P) ; COUNT ELEMENTS - JUMPE C,LBRAK3 ; IF NO COMMENT, GO ON - MOVEI E,(B) ; GET CDR - PUSHJ P,ICONS ; CONS IT ON - MOVEI E,(B) ; SAVE RS - MOVSI C,TFIX ; AND GET FIXED NUM - MOVE D,(P) - PUSHJ P,ICONS -LBRAK3: PUSH TP,A ; SAVE CURRENT COMMENT LIST - PUSH TP,B - JRST LBRAK1 - -; HERE TO RAP UP VECTOR - -LBDONE: CAME B,-2(P) ; FINISHED RETURN (WAS THE RIGHT STOP USED?) - PUSHJ P,MISMAB ; WARN USER - POP TP,1(TB) ; REMOVE COMMENT LIST - POP TP,(TB) - MOVE A,(P) ; COUNT TO A - PUSHJ P,-1@(P) ; MAKE THE VECTOR - SUB P,[3,,3] - -; PUT COMMENTS ON VECTOR (OR UVECTOR) - - MOVNI C,1 ; INDICATE TEMPLATE HACK - CAMN A,$TVEC - MOVEI C,1 - CAMN A,$TUVEC ; SKIP IF UVECTOR - MOVEI C,0 - PUSH P,C ; SAVE - PUSH TP,A ; SAVE VECTOR/UVECTOR - PUSH TP,B - -VECCOM: SKIPN C,1(TB) ; ANY LEFT? - JRST RETVEC ; NO, LEAVE - MOVE A,1(C) ; ASSUME WINNING TYPES - SUBI A,1 - HRRZ C,(C) ; CDR THE LIST - HRRZ E,(C) ; AGAIN - MOVEM E,1(TB) ; SAVE CDR - GETYP E,(C) ; CHECK DEFFERED - MOVSI D,(E) - CAIN E,TDEFER ; SKIP IF NOT DEFERRED - MOVE C,1(C) - CAIN E,TDEFER - GETYPF D,(C) ; GET REAL TYPE - MOVE B,(TP) ; GET VECTOR POINTER - SKIPGE (P) ; SKIP IF NOT TEMPLATE - JRST TMPCOM - HRLI A,(A) ; COUNTER - LSH A,@(P) ; MAYBE SHIFT IT - ADD B,A - MOVE A,-1(TP) ; TYPE -TMPCO1: PUSH TP,D - PUSH TP,1(C) ; PUSH THE COMMENT - MOVSI C,TATOM - MOVE D,MQUOTE COMMENT - PUSHJ P,IPUT - JRST VECCOM - -TMPCOM: MOVSI A,(A) - ADD B,A - MOVSI A,TTMPLT - JRST TMPCO1 - -RETVEC: SUB P,[1,,1] - POP TP,B - POP TP,A - JRST RET - -; BUILD A SINGLE CHARACTER ITEM - -SINCHR: PUSHJ P,NXTC1 ;FORCE READ NEXT - CAIN B,ESCTYP ;ESCAPE? - PUSHJ P,NXTC1 ;RETRY - MOVEI B,(A) - MOVSI A,TCHRS - JRST RETCL - - -; HERE ON RIGHT PAREN, BRACKET, ANGLE BRACKET OR CTL C - -CLSBRA: -CLSANG: ;CLOSE ANGLE BRACKETS -RBRACK: ;COMMON RETURN FOR END OF ARRAY ALSO -RPAREN: PUSHJ P,LSTCHR ;DON'T REREAD -EOFCH1: MOVE B,A ;GETCHAR IN B - MOVSI A,TCHRS ;AND TYPE IN A -RET1: SUB P,[1,,1] - POPJ P, - -EOFCHR: SETZB C,D - JUMPL A,EOFCH1 ; JUMP ON REAL EOF - JRST RRSUBR ; MAYBE A BINARY RSUBR - -DOEOF: MOVE A,[-1,,3] - SETZB C,D - JRST EOFCH1 - - -; NORMAL RETURN FROM IREAD/IREAD1 - -RETCL: PUSHJ P,LSTCHR ;DONT REREAD -RET: AOS -1(P) ;SKIP - POP P,E ; POP FLAG -RETC: JUMPL E,RET2 ; DONT LOOK FOR COMMENTS - PUSH TP,A ; SAVE ITEM - PUSH TP,B -CHCOMN: PUSHJ P,NXTCH ; READ A CHARACTER - CAIE B,COMTYP ; SKIP IF COMMENT - JRST CHSPA - PUSHJ P,IREAD ; READ THE COMMENT - JRST POPAJ - MOVE C,A - MOVE D,B - JRST .+2 -POPAJ: SETZB C,D - POP TP,B - POP TP,A -RET2: POPJ P, - -CHSPA: CAIN B,SPATYP - PUSHJ P,SPACEQ ; IS IT A REAL SPACE - JRST POPAJ - PUSHJ P,LSTCHR ; FLUSH THE SPACE - JRST CHCOMN - -;RANDOM MINI-SUBROUTINES USED BY THE READER - -;READ A CHAR INTO A AND TYPE CODE INTO D - -NXTC1: SKIPL B,5(TB) ;GET CHANNEL - JRST NXTPR1 ;NO CHANNEL, GO READ STRING - SKIPE LSTCH(B) - PUSHJ P,CNTACC ; COUNT ON ACCESS POINTER - JRST NXTC2 -NXTC: SKIPL B,5(TB) ;GET CHANNEL - JRST NXTPRS ;NO CHANNEL, GO READ STRING - SKIPE A,LSTCH(B) ;CHAR IN A IF REUSE - JRST PRSRET -NXTC2: PUSHJ P,RXCT ;GET CHAR FROM INPUT - HLLZS 2(TB) ;FLAG INDICATING ONE CHAR LOOK AHEAD - MOVEM A,LSTCH(B) ;SAVE THE CHARACTER -PRSRET: TRZE A,400000 ;DONT SKIP IF SPECIAL - JRST RETYPE ;GO HACK SPECIALLY -GETCTP: CAILE A,177 ; CHECK RANGE - JRST BADCHR - PUSH P,A ;AND SAVE FROM DIVISION - ANDI A,177 - IDIVI A,CHRWD ;YIELDS WORD AND CHAR NUMBER - LDB B,BYTPNT(B) ;GOBBLE TYPE CODE - POP P,A - POPJ P, - -NXTPRS: SKIPE A,5(TB) ;GET OLD CHARACTER IF ONE EXISTS - JRST PRSRET -NXTPR1: MOVEI A,400033 - PUSH P,C - MOVE C,11.(TB) - HRRZ B,(C) ;GET THE STRING - SOJL B,NXTPR3 - HRRM B,(C) - ILDB A,1(C) ;GET THE CHARACTER FROM THE STRING -NXTPR2: MOVEM A,5(TB) ;SAVE IT - POP P,C - JRST PRSRET ;CONTINUE -NXTPR3: SETZM 8.(TB) - SETZM 9.(TB) ;CLEAR OUT LOCATIVE, AT END OF STRING - JRST NXTPR2 - -; NXTCH AND NXTCH1 ARE SAME AS NXTC AND NXTC1 EXCEPT THEY CHECK ! -; HACKS - -NXTCH1: PUSHJ P,NXTC1 ;READ CHAR - JRST .+2 -NXTCH: PUSHJ P,NXTC ;READ CHAR - CAIGE B,NTYPES+1 ;IF 1 > THAN MAX, MUST BE SPECIAL - JRST CHKUS1 ; CHECK FOR USER DISPATCH - - CAIN B,NTYPES+1 ;FOR OBSCURE BUG FOUND BY MSG - PUSHJ P,NXTC1 ;READ NEXT ONE - HLLOS 2(TB) ;FLAG FOR TWO CHAR LOOK AHEAD - -RETYP1: CAIN A,". ;!. - MOVEI B,DOTEXT ;YES, GET EXTENDED TYPE - CAIN A,"[ - MOVEI B,LBREXT - CAIN A,"' - MOVEI B,QUOEXT - CAIN A,"" - MOVEI B,CSEXT - CAIN A,"- - MOVEI B,PATHTY - CAIN A,"< - MOVEI B,SLMEXT - CAIN A,", - MOVEI B,GLMEXT - CAIN A,33 - MOVEI B,MANYT ;! ALTMODE - -CRMLST: ADDI A,400000 ;CLOBBER LASTCHR - PUSH P,B - SKIPL B,5(TB) ;POINT TO CHANNEL - MOVEI B,5(TB)-LSTCH ;NO CHANNEL, POINT AT SLOT - MOVEM A,LSTCH(B) - SUBI A,400000 ;DECREASE CHAR - POP P,B - -CHKUS2: SKIPN 7(TB) ; SKIP IF USER TABLE - JRST UPLO - PUSH P,A - ADDI A,200 - ASH A,1 ; POINT TO SLOT - HRLS A - ADD A,7(TB) - SKIPL A ;IS THERE VECTOR ENOUGH? - JRST CHKUS4 - SKIPN 1(A) ; NON-ZERO==>USER FCN EXISTS - JRST CHKUS4 ; HOPE HE APPRECIATES THIS - MOVEI B,USTYP2 -CHKRDO: PUSH P,0 ; CHECK FOR REDOING IF CHAR IN TABLE - GETYP 0,(A) - CAIE 0,TCHRS - JRST CHKUS5 - POP P,0 ;WE ARE TRANSMOGRIFYING - POP P,(P) ;FLUSH OLD CHAR - MOVE A,1(A) ;GET NEW CHARACTER - PUSH P,7(TB) - PUSH P,2(TB) ; FLAGS FOR NUM OF CHRS IN LOOK AHEAD - PUSH P,5(TB) ; TO AVOID SMASHING LSTCHR - SETZM 5(TB) ; CLEAR OUT CHANNEL - SETZM 7(TB) ;CLEAR OUT TABLE - TRZE A,200 ; ! HACK - TRO A,400000 ; TURN ON PROPER BIT - PUSHJ P,PRSRET - POP P,5(TB) ; GET BACK CHANNEL - POP P,2(TB) - POP P,7(TB) ;GET BACK OLD PARSE TABLE - POPJ P, - -CHKUS5: CAIE 0,TLIST - JRST .+4 ; SPECIAL NON-BREAK TYPE HACK - MOVNS -1(P) ; INDICATE BY NEGATIVE - MOVE A,1(A) ; GET <1 LIST> - GETYP 0,(A) ; AND GET THE TYPE OF THAT - CAIE 0,TFIX ; SEE IF HE WANTS SAME CHAR WITH DIFF TYPE - JRST CHKUS6 ; JUST A VANILLA HACK - MOVE A,1(A) ; PRETEND IT IS SAME TYPE AS NEW CHAR - PUSH P,7(TB) ; CLEAR OUT TRANSLATE TABLE - PUSH P,2(TB) ; FLAGS FOR # OF CHRS IN LOOK AHEAD - SETZM 7(TB) - TRZE A,200 - TRO A,400000 ; TURN ON PROPER BIT IF ! HACK - PUSHJ P,PRSRET ; REGET TYPE - POP P,2(TB) - POP P,7(TB) ; PUT TRANSLATE TABLE BACK -CHKUS6: SKIPGE -1(P) ; SEE IF A SPECIAL NON-BREAK - MOVNS B ; SEXY, HUH? - POP P,0 - POP P,A - MOVMS A ; FIX UP A POSITIVE CHARACTER - POPJ P, - -CHKUS4: POP P,A - JRST UPLO - -CHKUS1: SKIPN 7(TB) ; USER CHECK FOR NOT ! CASE - POPJ P, - PUSH P,A - ASH A,1 - HRLS A - ADD A,7(TB) - SKIPL A - JRST CHKUS3 - SKIPN 1(A) - JRST CHKUS3 - MOVEI B,USTYP1 - JRST CHKRDO ; TRANSMOGRIFY CHARACTER? - -CHKUS3: POP P,A - POPJ P, - -UPLO: POPJ P, ; LETS NOT AND SAY WE USED TO - ; AVOID STRANGE ! BLECHAGE - -RETYPE: PUSHJ P,GETCTP ;GET TYPE OF CHAR - JRST RETYP1 - -NXTCS: PUSHJ P,NXTC - PUSH P,A ; HACK TO NOT TRANSLATE CHAR - PUSHJ P,CHKUS1 ; BUT DO TRANSLATION OF TYPE IF HE WANTS - POP P,A ; USED TO BUILD UP STRINGS - POPJ P, - -CHKALT: CAIN A,33 ;ALT? - MOVEI B,MANYT - JRST CRMLST - - -TERM: MOVEI B,0 ;RETURN A 0 - JRST RET1 - ;AND RETURN - -CHKMIN: CAIN A,"- ; IF CHAR IS -, WINNER - MOVEI B,PATHTY - JRST CRMLST - -LOSPAT: PUSHJ P,LSTCHR ; FIX RECURSIVE LOSAGE - PUSH TP,$TATOM - PUSH TP,EQUOTE UNATTACHED-PATH-NAME-SEPARATOR - JRST CALER1 - - -; HERE TO SEE IF READING RSUBR - -RRSUBR: PUSHJ P,LSTCHR ; FLUSH JUST READ CHAR - SKIPL B,5(TB) ; SKIP IF A CHANNEL EXISTS - JRST SPACE ; ELSE LIKE A SPACE - MOVE C,@BUFSTR(B) ; SEE IF FLAG SAYS START OF RSUBR - TRNN C,1 ; SKIP IF REAL RSUBR - JRST SPACE ; NO, IGNORE FOR NOW - -; REALLY ARE READING AN RSUBR - - HRRZ 0,4(TB) ; GET READ/READB INDICATOR - MOVE C,ACCESS(B) ; GET CURRENT ACCESS - JUMPN 0,.+3 ; ALREADY WORDS, NO NEED TO DIVIDE - ADDI C,4 ; ROUND UP - IDIVI C,5 - PUSH P,C ; SAVE WORD ACCESS - MOVEI A,(C) ; COPY IT FOR CALL - JUMPN 0,.+3 - IMULI C,5 - MOVEM C,ACCESS(B) ; FIXUP ACCESS - HLLZS ACCESS-1(B) ; FOR READB LOSER - PUSHJ P,DOACCS ; AND GO THERE - PUSH P,[0] ; FOR READ IN - HRROI A,(P) ; PREPARE TO READ LENGTH - PUSHJ P,DOIOTI ; READ IT - POP P,C ; GET READ GOODIE - MOVEI A,(C) ; COPY FOR GETTING BLOCK - ADDI C,1 ; COUNT COUNT WORD - ADDM C,(P) - PUSH TP,$TUVEC ; WILL HOLD UVECTOR OF FIXUPS IF THEY STAY - PUSH TP,[0] - PUSHJ P,IBLOCK ; GET A BLOCK - PUSH TP,$TUVEC - PUSH TP,B ; AND SAVE - MOVE A,B ; READY TO IOT IT IN - MOVE B,5(TB) ; GET CHANNEL BACK - MOVSI 0,TUVEC ; SETUP A'S TYPE - MOVEM 0,ASTO(PVP) - PUSHJ P,DOIOTI ; IN COMES THE WHOLE BLOCK - SETZM ASTO(PVP) ; A NO LONGER SPECIAL - MOVEI C,BUFSTR-1(B) ; NO RESET BUFFER - PUSHJ P,BYTDOP ; A POINTS TO DOPW WORD - SUBI A,2 - HRLI A,010700 ; SETUP BYTE POINTER TO END - HLLZS BUFSTR-1(B) ; ZERO CHAR COUNNT - MOVEM A,BUFSTR(B) - HRRZ A,4(TB) ; READ/READB FLG - MOVE C,(P) ; ACCESS IN WORDS - SKIPN A ; SKIP FOR ASCII - IMULI C,5 ; BUMP - MOVEM C,ACCESS(B) ; UPDATE ACCESS - PUSHJ P,NIREAD ; READ RSUBR VECTOR - JRST BRSUBR ; LOSER - GETYP A,A ; VERIFY A LITTLE - CAIE A,TVEC ; DONT SKIP IF BAD - JRST BRSUBR ; NOT A GOOD FILE - PUSHJ P,LSTCHR ; FLUSH REREAD CHAR - MOVE C,(TP) ; CODE VECTOR BACK - MOVSI A,TCODE - HLR A,B ; FUNNY COUNT - MOVEM A,(B) ; CLOBBER - MOVEM C,1(B) - PUSH TP,$TRSUBR ; MAKE RSUBR - PUSH TP,B - -; NOW LOOK OVER FIXUPS - - MOVE B,5(TB) ; GET CHANNEL - MOVE C,ACCESS(B) - HLLZS ACCESS-1(B) ; FOR READB LOSER - HRRZ 0,4(TB) ; READ/READB FLG - JUMPN 0,RSUB1 - ADDI C,4 ; ROUND UP - IDIVI C,5 ; TO WORDS - MOVEI D,(C) ; FIXUP ACCESS - IMULI D,5 - MOVEM D,ACCESS(B) ; AND STORE -RSUB1: ADDI C,1 ; ACCOUNT FOR EXTRA COUNTERS - MOVEM C,(P) ; SAVE FOR LATER - MOVEI A,-1(C) ; FOR DOACS - MOVEI C,2 ; UPDATE REAL ACCESS - SKIPN 0 ; SKIP FOR READB CASE - MOVEI C,10. - ADDM C,ACCESS(B) - PUSHJ P,DOACCS ; DO THE ACCESS - PUSH TP,$TUVEC ; SLOT FOR FIXUP BUFFER - PUSH TP,[0] - -; FOUND OUT IF FIXUPS STAY - - MOVE B,MQUOTE KEEP-FIXUPS - PUSHJ P,ILVAL ; GET VALUE - GETYP 0,A - MOVE B,5(TB) ; CHANNEL BACK TO B - CAIE 0,TUNBOU - CAIN 0,TFALSE - JRST RSUB4 ; NO, NOT KEEPING FIXUPS - PUSH P,[0] ; SLOT TO READ INTO - HRROI A,(P) ; GET LENGTH OF SAME - PUSHJ P,DOIOTI - POP P,C - MOVEI A,(C) ; GET UVECTOR FOR KEEPING - ADDM C,(P) ; ACCESS TO END - PUSH P,C ; SAVE LENGTH OF FIXUPS - PUSHJ P,IBLOCK - MOVEM B,-6(TP) ; AND SAVE - MOVE A,B ; FOR IOTING THEM IN - ADD B,[1,,1] ; POINT PAST VERS # - MOVEM B,(TP) - MOVSI C,TUVEC - MOVEM C,ASTO(PVP) - MOVE B,5(TB) ; AND CHANNEL - PUSHJ P,DOIOTI ; GET THEM - SETZM ASTO(PVP) - MOVE A,(TP) ; GET VERS - PUSH P,-1(A) ; AND PUSH IT - JRST RSUB5 - -RSUB4: PUSH P,[0] - PUSH P,[0] ; 2 SLOTS FOR READING - MOVEI A,-1(P) - HRLI A,-2 - PUSHJ P,DOIOTI - MOVE C,-1(P) - MOVE D,(P) - ADDM C,-2(P) ; NOW -2(P) IS ACCESS TO END OF FIXUPS -RSUB5: MOVEI C,BUFSTR-1(B) ; FIXUP BUFFER - PUSHJ P,BYTDOP - SUBI A,2 ; POINT BEFORE D.W. - HRLI A,10700 - MOVEM A,BUFSTR(B) - HLLZS BUFSTR-1(B) - SKIPE -6(TP) - JRST RSUB2A - SUBI A,BUFLNT-1 ; ALSO MAKE AN IOT FLAVOR BUFFER - HRLI A,-BUFLNT - MOVEM A,(TP) - MOVSI C,TUVEC - MOVEM C,ASTO(PVP) - PUSHJ P,DOIOTI - SETZM ASTO(PVP) -RSUB2A: PUSH P,-1(P) ; ANOTHER COPY OF LENGTH OF FIXUPS - -; LOOP FIXING UP NEW TYPES - -RSUB2: PUSHJ P,WRDIN ; SEE WHAT NEXT THING IS - JRST RSUB3 ; NO MORE, DONE - JUMPL E,STSQ ; MUST BE FIRST SQUOZE - MOVNI 0,(E) ; TO UPDATE AMNT OF FIXUPS - ADDB 0,(P) - HRLI E,(E) ; IS LENGTH OF STRING IN WORDS - ADD E,(TP) ; FIXUP BUFFER POINTER - JUMPL E,.+3 - SUB E,[BUFLNT,,BUFLNT] - JUMPGE E,.-1 ; STILL NOT RIGHT - EXCH E,(TP) ; FIX UP SLOT - HLRE C,E ; FIX BYTE POINTER ALSO - IMUL C,[-5] ; + CHARS LEFT - MOVE B,5(TB) ; CHANNEL - PUSH TP,BUFSTR-1(B) - PUSH TP,BUFSTR(B) - HRRM C,BUFSTR-1(B) - HRLI E,440700 ; AND BYTE POINTER - MOVEM E,BUFSTR(B) - PUSHJ P,NIREAD ; READ ATOM NAME OF TYPE - TDZA 0,0 ; FLAG LOSSAGE - MOVEI 0,1 ; WINNAGE - MOVE C,5(TB) ; RESET BUFFER - POP TP,BUFSTR(C) - POP TP,BUFSTR-1(C) - JUMPE 0,BRSUBR ; BAD READ OF RSUBR - GETYP A,A ; A LITTLE CHECKING - CAIE A,TATOM - JRST BRSUBR - PUSHJ P,LSTCHR ; FLUSH REREAD CHAR - HRRZ 0,4(TB) ; FIXUP ACCESS PNTR - MOVE C,5(TB) - MOVE D,ACCESS(C) - HLLZS ACCESS-1(C) ; FOR READB HACKER - ADDI D,4 - IDIVI D,5 - IMULI D,5 - SKIPN 0 - MOVEM D,ACCESS(C) ; RESET -TYFIXE: PUSHJ P,TYPFND ; SEE IF A LEGAL TYPE NAME - JRST TYPFIX ; GO SEE USER ABOUT THIS - PUSHJ P,FIXCOD ; GO FIX UP THE CODE - JRST RSUB2 - -; NOW FIX UP SUBRS ETC. IF NECESSARY - -STSQ: MOVE B,MQUOTE MUDDLE - PUSHJ P,IGVAL ; GET CURRENT VERS - CAME B,-1(P) ; SKIP IF NO FIXUPS NEEDED - JRST DOFIX0 ; MUST DO THEM - -; ALL DONE, ACCESS PAST FIXUPS AND RETURN - -RSUB3: MOVE A,-3(P) - MOVE B,5(TB) - MOVEI C,(A) ; UPDATE CHANNEL ACCESS IN CASE SKIPPING - HRRZ 0,4(TB) ; READ/READB FLAG - SKIPN 0 - IMULI C,5 - MOVEM C,ACCESS(B) ; INTO ACCESS SLOT - HLLZS ACCESS-1(B) - PUSHJ P,DOACCS ; ACCESSED - MOVEI C,BUFSTR-1(B) ; FIX UP BUFFER - PUSHJ P,BYTDOP - SUBI A,2 - HRLI A,10700 - MOVEM A,BUFSTR(B) - HLLZS BUFSTR-1(B) - SKIPN A,-6(TP) ; SKIP IF KEEPING FIXUPS - JRST RSUB6 - PUSH TP,$TUVEC - PUSH TP,A - MOVSI A,TRSUBR - MOVE B,-4(TP) - MOVSI C,TATOM - MOVE D,MQUOTE RSUBR - PUSHJ P,IPUT ; DO THE ASSOCIATION - -RSUB6: MOVE B,-2(TP) ; GET RSUBR - MOVSI A,TRSUBR - SUB P,[4,,4] ; FLUSH P CRUFT - SUB TP,[10,,10] - JRST RET - -; FIXUP SUBRS ETC. - -DOFIX0: SKIPN C,-6(TP) ; GET BUFFER IF KEEPING - JRST DOFIXE - MOVEM B,(C) ; CLOBBER - JRST DOFIXE - -FIXUPL: PUSHJ P,WRDIN - JRST RSUB3 -DOFIXE: JUMPGE E,BRSUBR - TLZ E,740000 ; KILL BITS - PUSHJ P,SQUTOA ; LOOK IT UP - JRST BRSUBR - MOVEI D,(E) ; FOR FIXCOD - PUSHJ P,FIXCOD ; FIX 'EM UP - JRST FIXUPL - -; ROUTINE TO FIXUP ACTUAL CODE - -FIXCOD: MOVEI E,0 ; FOR HWRDIN - PUSH P,D ; NEW VALUE - PUSHJ P,HWRDIN ; GET HW NEEDED - MOVE D,(P) ; GET NEW VAL - MOVE A,(TP) ; AND BUFFER POINTER - SKIPE -6(TP) ; SAVING? - HRLM D,-1(A) ; YES, CLOBBER - SUB C,(P) ; DIFFERENCE - MOVN D,C - -FIXLP: PUSHJ P,HWRDIN ; GET AN OFFSET - JUMPE C,FIXED - HRRES C ; MAKE NEG IF NEC - JUMPL C,LHFXUP - ADD C,-4(TP) ; POINT INTO CODE - ADDM D,-1(C) - JRST FIXLP - -LHFXUP: MOVMS C - ADD C,-4(TP) - MOVSI 0,(D) - ADDM 0,-1(C) - JRST FIXLP - -FIXED: SUB P,[1,,1] - POPJ P, - -; ROUTINE TO READ A WORD FROM BUFFER - -WRDIN: PUSH P,A - PUSH P,B - SOSG -3(P) ; COUNT IT DOWN - JRST WRDIN1 - AOS -2(P) ; SKIP RETURN - MOVE B,5(TB) ; CHANNEL - HRRZ A,4(TB) ; READ/READB SW - MOVEI E,5 - SKIPE A - MOVEI E,1 - ADDM E,ACCESS(B) - MOVE A,(TP) ; BUFFER - MOVE E,(A) - AOBJP A,WRDIN2 ; NEED NEW BUFFER - MOVEM A,(TP) -WRDIN1: POP P,B - POP P,A - POPJ P, - -WRDIN2: MOVE B,-3(P) ; IS THIS LAST WORD? - SOJLE B,WRDIN1 ; YES, DONT RE-IOT - SUB A,[BUFLNT,,BUFLNT] - MOVEM A,(TP) - MOVSI B,TUVEC - MOVEM B,ASTO(PVP) - MOVE B,5(TB) - PUSHJ P,DOIOTI - SETZM ASTO(PVP) - JRST WRDIN1 - -; READ IN NEXT HALF WORD - -HWRDIN: JUMPN E,NOIOT ; USE EXISTING WORD - PUSH P,-3(P) ; FAKE OUT WRDIN IF NEC. - PUSHJ P,WRDIN - JRST BRSUBR - POP P,-4(P) ; RESET COUNTER - HLRZ C,E ; RET LH - POPJ P, - -NOIOT: HRRZ C,E - MOVEI E,0 - POPJ P, - -TYPFIX: PUSH TP,$TATOM - PUSH TP,EQUOTE BAD-TYPE-NAME - PUSH TP,$TATOM - PUSH TP,B - PUSH TP,$TATOM - PUSH TP,EQUOTE ERRET-TYPE-NAME-DESIRED - MCALL 3,ERROR - JRST TYFIXE - -BRSUBR: PUSH TP,$TATOM - PUSH TP,EQUOTE RSUBR-IN-BAD-FORMAT - JRST CALER1 - - - -;TABLE OF BYTE POINTERS FOR GETTING CHARS - -BYTPNT": 350700,,CHTBL(A) - 260700,,CHTBL(A) - 170700,,CHTBL(A) - 100700,,CHTBL(A) - 010700,,CHTBL(A) - -;HERE ARE THE TABLES OF CHXRACTERS (NOTE EVERYTHING NOT SPECIFIED IS -;IN THE NUMBER LETTER CATAGORY) - -SETCHR 2,[0123456789] - -SETCHR 3,[+-] - -SETCHR 4,[.] - -SETCHR 5,[Ee] - -SETCOD 6,[15,12,11,14,40,33] ;ALL ARE TYPE 2 (SPACING - FF,TAB,SPACE,ALT-MODE) - -INCRCH 7,[()[]'%"\#<>] ;GIVE THESE INCREASRNG CODES FROM 3 - -SETCOD 22,[3] ;^C - EOF CHARACTER - -INCRCH 23,[;,{}!] ;COMMENT AND GLOBAL VALUE AND SPECIAL - -CHTBL: - OUTTBL ;OUTPUT THE TABLE RIGHT HERE - - - ; THIS CODE FLUSHES WANDERING COMMENTS - -COMNT: PUSHJ P,IREAD - JRST COMNT2 - JRST BDLP - -COMNT2: SKIPL A,5(TB) ; RESTORE CHANNEL - MOVEI A,5(TB)-LSTCH ;NO CHANNEL, POINT AT SLOT - MOVEM B,LSTCH(A) ; CLOBBER IN CHAR - PUSHJ P,ERRPAR - JRST BDLP - -;SUBROUTINE TO READ CHARS ONTO STACK - -GOBBL1: MOVEI FF,0 ;KILL ALL FLAGS - PUSHJ P,LSTCHR ;DON'T REREAD " - TROA FF,NOTNUM+INSTRN ;SURPRESS NUMBER CONVERSION -GOBBLE: MOVEI FF,0 ;FLAGS CONCERRNING CURRENT GOODIE IN HERE - MOVE A,TP ;GOBBLE CURRENT TP TO BE PUSHED - MOVEI C,6 ;NOW PUSH 6 0'S ON TO STACK - PUSH TP,$TFIX ;TYPE IS FIXED - PUSH TP,FF ;AND VALUE IS 0 - SOJG C,.-2 ;FOUR OF THEM - PUSH TP,$TTP ;NOW SAVE OLD TP - ADD A,[1,,1] ;MAKE IT LOOK LIKE A TB - PUSH TP,A - MOVEI D,0 ;ZERO OUT CHARACTER COUNT -GOB1: MOVSI C,(<440700,,(P)>) ;SET UP FIRST WORD OF CHARS - PUSH P,[0] ;BYTE POINTER -GOB2: PUSH P,FF ;SAVE FLAG REGISTER - INTGO ; IN CASE P OVERFLOWS - MOVEI A,NXTCH - TRNE FF,INSTRN - MOVEI A,NXTCS ; HACK TO GET MAYBE NEW TYPE WITHOUT CHANGE - PUSHJ P,(A) - POP P,FF ;AND RESTORE FLAG REGISTER - CAIN B,ESCTYP ;IS IT A CHARACTER TO BE ESCAPED - JRST ESCHK ;GOBBLE THE ESCAPED CHARACTER - TRNE FF,INSTRN ;ARE WE BUILDING A CHAR STRING - JRST ADSTRN ;YES, GO READ IN - CAILE B,NONSPC ;IS IT SPECIAL - JRST DONEG ;YES, RAP THIS UP - - TRNE FF,NOTNUM ;IS NUMERIC STILL WINNING - JRST SYMB2 ;NO, ONLY DO CHARACTER HACKING - CAIL A,60 ;CHECK FOR DIGIT - CAILE A,71 - JRST SYMB1 ;NOT A DIGIT - JRST CNV ;GO CONVERT TO NUMBER - CNV: - -;ARRIVE HERE IF STILL BUILDING A NUMBER -CNV: MOVE B,(TP) ;GOBBLE POINTER TO TEMPS - TRO FF,NUMWIN ;SAY DIGITSSEEN - SUBI A,60 ;CONVERT TO A NUMBER - TRNE FF,EFLG ;HAS E BEEN SEEN - JRST ECNV ;YES, CONVERT EXPONENT - TRNE FF,DOTSEN ;HAS A DOT BEEN SEEN - - JRST DECNV ;YES, THIS IS A FLOATING NUMBER - - MOVE E,ONUM(B) ; OCTAL CONVERT - LSH E,3 - ADDI E,(A) - MOVEM E,ONUM(B) - TRNE FF,OCTSTR ; SKIP OTHER CONVERSIONS IF OCTAL FORCE - JRST CNV1 - - JFCL 17,.+1 ;KILL ALL FLAGS - MOVE E,CNUM(B) ;COMPUTE CURRENT RADIX - IMUL E,3(TB) - ADD E,A ;ADD IN CURRENT DIGIT - JFCL 10,.+2 - MOVEM E,CNUM(B) ;AND SAVE IT - - - -;INSERT OCTAL AND CRADIX CROCK HERE IF NECESSSARY - JRST DECNV1 ;CONVERT TO DECIMAL(FIXED) - - -DECNV: TRO FF,FLONUM ;SET FLOATING FLAG -DECNV1: JFCL 17,.+1 ;CLEAR ALL FLAGS - MOVE E,DNUM(B) ;GET DECIMAL NUMBER - IMULI E,10. - JFCL 10,CNV2 ;JUMP IF OVERFLOW - ADD E,A ;ADD IN DIGIT - MOVEM E,DNUM(B) - TRNE FF,FLONUM ;IS THIS FRACTION? - SOS NDIGS(B) ;YES, DECREASE EXPONENT BY ONE - -CNV1: PUSHJ P,NXTCH ;RE-GOBBLE CHARACTER - JRST SYMB2 ;ALSO DEPOSIT INTO SYMBOL BEING MADE -CNV2: ;OVERFLOW IN DECIMAL NUMBER - TRNE FF,DOTSEN ;IS THIS FRACTION PART? - JRST CNV1 ;YES,IGNORE DIGIT - AOS NDIGS(B) ;NO, INCREASE IMPLICIT EXPONENT BY ONE - TRO FF,FLONUM ;SET FLOATING FLAG BUT - JRST CNV1 ;DO NOT FORCE DECIMAL(DECFRC) - -ECNV: ;CONVERT A DECIMAL EXPONENT - HRRZ E,ENUM(B) ;GET EXPONENT - IMULI E,10. - ADD E,A ;ADD IN DIGIT - TLNN E,777777 ;IF OVERFLOW INTO LEFT HALF - HRRM E,ENUM(B) ;DO NOT STORE(CATCH ERROR LATER) - JRST CNV1 - JRST SYMB2 ;ALSO DEPOSIT INTO SYMBOL BEING MADE - - -;HERE TO PUT INTO IDENTIFIER BEING BUILT - -ESCHK: PUSHJ P,NXTC1 ;GOBBLE NEXT CHAR -SYMB: MOVE B,(TP) ;GET BACK TEM POINTER - TRNE FF,EFLG ;IF E FLAG SET - HLRZ FF,ENUM(B) ;RESTORE SAVED FLAGS - TRO FF,NOTNUM ;SET NOT NUMBER FLAG -SYMB2: TRO FF,NFIRST ;NOT FIRST IN WORLD -SYMB3: IDPB A,C ;INSERT IT - PUSHJ P,LSTCHR ;READ NEW CHARACTER - TLNE C,760000 ;WORD FULL? - AOJA D,GOB2 ;NO, KEEP TRYING - AOJA D,GOB1 ;COUNT WORD AND GO - -;HERE TO CHECK FOR +,-,. IN NUMBER - -SYMB1: TRNE FF,NFIRST ;IS THIS THE FIRST CHARACTER - JRST CHECK. ;NO, ONLY LOOK AT DOT - CAIE A,"- ;IS IT MINUS - JRST .+3 ;NO CHECK PLUS - TRO FF,NEGF ;YES, NEGATE AT THE END - JRST SYMB2 - CAIN A,"+ ;IS IT + - JRST SYMB2 ;ESSENTIALLY IGNORE IT - CAIE A,"* ; FUNNY OCTAL CROCK? - JRST CHECK. - - TRO FF,OCTSTR - JRST SYMB2 - -;COULD BE . - -CHECK.: PUSHJ P,LSTCHR ;FLUSH LAST CHARACTER - MOVEI E,0 - TRNN FF,DOTSEN+EFLG ;IF ONE ALREADY SEEN - CAIE A,". - JRST CHECKE ;GO LOOK FOR E - -IFN FRMSIN,[ - TRNN FF,NFIRST ;IS IT THE FIRST - JRST DOT1 ;YES, COULD MEAN EVALUATE A VARIABLE -] - -CHCK.1: TRO FF,DECFRC+DOTSEN ;FORCE DECIMAL -IFN FRMSIN, TRNN FF,FRSDOT ;IF NOT FIRST ., PUT IN CHAR STRING - JRST SYMB2 ;ENTER INTO SYMBOL -IFN FRMSIN, JRST GOB2 ;IGNORE THE "." - - - -IFN FRMSIN,[ - -;HERE TO SET UP FOR .FOO ..FOO OR. - -DOT1: PUSH P,FF ;SAVE FLAGS - PUSHJ P,NXTCH1 ;GOBBLE A NEW CHARACTER - POP P,FF ;RESTORE FLAGS - TRO FF,FRSDOT ;SET FLAG IN CASE - CAIN B,NUMCOD ;SKIP IF NOT NUMERIC - JRST CHCK.1 ;NUMERIC, COULD BE FLONUM - -; CODE TO HANDLE ALL IMPLICIT CALLS I.E. QUOTE, LVAL, GVAL - - MOVSI B,TFORM ;LVAL - MOVE A,MQUOTE LVAL - SUB P,[2,,2] ;POP OFF BYTE POINTER AND GOBBLE CALL - POP TP,TP - SUB TP,[1,,1] ;REMOVE TP JUNK - JRST IMPCA1 - -GLOSEG: SKIPA B,$TSEG ;SEG CALL TO GVAL -GLOVAL: MOVSI B,TFORM ;FORM CALL TO SAME - MOVE A,MQUOTE GVAL - JRST IMPCAL - -QUOSEG: SKIPA B,$TSEG ;SEG CALL TO QUOTE -QUOTIT: MOVSI B,TFORM - MOVE A,MQUOTE QUOTE - JRST IMPCAL - -SEGDOT: MOVSI B,TSEG ;SEG CALL TO LVAL - MOVE A,MQUOTE LVAL -IMPCAL: PUSHJ P,LSTCHR ;FLUSH LAST CHAR EXCEPT -IMPCA1: PUSH TP,$TATOM ;FOR .FOO FLAVOR - PUSH TP,A ;PUSH ARGS - PUSH P,B ;SAVE TYPE - PUSHJ P,IREAD1 ;READ - JRST USENIL ; IF NO ARG, USE NIL -IMPCA2: PUSH TP,C - PUSH TP,D - MOVE C,A ; GET READ THING - MOVE D,B - PUSHJ P,INCONS ; CONS TO NIL - MOVEI E,(B) ; PREPARE TON CONS ON -POPARE: POP TP,D ; GET ATOM BACK - POP TP,C - EXCH C,-1(TP) ; SAVE THAT COMMENT - EXCH D,(TP) - PUSHJ P,ICONS - POP P,A ;GET FINAL TYPE - JRST RET13 ;AND RETURN - - -USENIL: PUSH TP,C - PUSH TP,D - SKIPL A,5(TB) ; RESTOR LAST CHR - MOVEI A,5(TB)-LSTCH ;NO CHANNEL, POINT AT SLOT - MOVEM B,LSTCH(A) - MOVEI E,0 - JRST POPARE - -;HERE AFTER READING ATOM TO CALL VALUE - -.SET: SUB P,[1,,1] ;FLUSH GOBBLE CALL - PUSH P,$TFORM ;GET WINNING TYPE - MOVE E,(P) - PUSHJ P,RETC ; CHECK FOR POSSIBLE COMMENT - PUSH TP,$TATOM - PUSH TP,MQUOTE LVAL - JRST IMPCA2 ;GO CONS LIST - -] - -;HERE TO CHECK FOR "E" FLAVOR OF EXPONENT - -CHECKE: CAIN A,"* ; CHECK FOR FINAL * - JRST SYMB4 - TRNN FF,EFLG ;HAS ONE BEEN SEEN - CAIE B,NONSPC ;IF NOT, IS THIS ONE - JRST SYMB ;NO, ENTER AS SYMBOL KILL NUMERIC WIN - - TRNN FF,NUMWIN ;HAVE DIGITS BEEN SEEN? - JRST SYMB ;NO, NOT A NUMBER - MOVE B,(TP) ;GET POINTER TO TEMPS - HRLM FF,ENUM(B) ;SAVE FLAGS - HRRI FF,DECFRC+DOTSEN+EFLG ;SET NEW FLAGS - JRST SYMB3 ;ENTER SYMBOL - - -SYMB4: TRZN FF,OCTSTR - JRST SYMB - TRZN FF,OCTWIN ; ALREADY WON? - TROA FF,OCTWIN ; IF NOT DO IT NOW - JRST SYMB - JRST SYMB2 - -;HERE ON READING CHARACTER STRING - -ADSTRN: SKIPL A ; EOF? - CAIN B,MANYT ;TERMINATE? - JRST DONEG ;YES - CAIE B,CSTYP - JRST SYMB2 ;NO JUST INSERT IT -ADSTN1: PUSHJ P,LSTCHR ;DON'T REREAD """ - - -;HERE TO FINISH THIS CROCK - -DONEG: TRNN FF,OCTSTR ; IF START OCTAL BUT NOT FINISH.. - TRNN FF,NUMWIN ;HAVE DIGITS BEEN SEEN? - TRO FF,NOTNUM ;NO,SET NOT NUMBER FLAG - SKIPGE C ; SKIP IF STUFF IN TOP WORD - SUB P,[1,,1] - PUSH P,D - TRNN FF,NOTNUM ;NUMERIC? - JRST NUMHAK ;IS NUMERIC, GO TO IT - -IFN FRMSIN,[ - MOVE A,(TP) ;GET POINTER TO TEMPS - MOVEM FF,NDIGS(A) ;USE TO HOLD FLAGS -] - TRNE FF,INSTRN ;ARE WE BUILDING A STRING - JRST MAKSTR ;YES, GO COMPLETE SAME -LOOPAT: PUSHJ P,NXTCH ; CHECK FOR TRAILER - CAIN B,PATHTY ; PATH BEGINNER - JRST PATH0 ; YES, GO PROCESS - CAIN B,SPATYP ; SPACER? - PUSHJ P,SPACEQ ; CHECK FOR REAL SPACE - JRST PATH2 - PUSHJ P,LSTCHR ; FLUSH IT AND RETRY - JRST LOOPAT -PATH0: PUSHJ P,NXTCH1 ; READ FORCED NEXT - CAIE B,SPCTYP ; DO #FALSE () HACK - CAIN B,ESCTYP - JRST PATH4 - CAIL B,SPATYP ; SPACER? - JRST PATH3 ; YES, USE THE ROOT OBLIST -PATH4: PUSHJ P,NIREA1 ; READ NEXT ITEM - PUSHJ P,ERRPAR ; LOSER - CAME A,$TATOM ; ONLY ALLOW ATOMS - JRST BADPAT - - PUSH TP,A - PUSH TP,B - PUSH TP,A - PUSH TP,B - PUSH TP,$TATOM - PUSH TP,IMQUOTE OBLIST - MCALL 2,GET ; GET THE OBLIST - CAMN A,$TOBLS ; IF NOT OBLIST, MAKE ONE - JRST PATH6 - MCALL 1,MOBLIS ; MAKE ONE - JRST PATH1 - -PATH6: SUB TP,[2,,2] - JRST PATH1 - - -PATH3: MOVE B,ROOT+1(TVP) ; GET ROOT OBLIST - MOVSI A,TOBLS -PATH1: PUSHJ P,RLOOKU ; AND LOOK IT UP - -IFN FRMSIN,[ - MOVE C,(TP) ;SET TO REGOBBLE FLAGS - MOVE FF,NDIGS(C) -] - JRST FINID - - -SPACEQ: ANDI A,-1 - CAIE A,33 - CAIN A,400033 - POPJ P, - CAIE A,3 - AOS (P) - POPJ P, - -;HERE TO RAP UP CHAR STRING ITEM - -MAKSTR: MOVE C,D ;SETUP TO CALL CHMAK - PUSHJ P,CHMAK ;GO MAKE SAME - JRST FINID - - -NUMHAK: MOVE C,(TP) ;REGOBBLETEMP POINTER - POP P,D ;POP OFF STACK TOP - ADDI D,4 - IDIVI D,5 - HRLI D,(D) ;TOO BOTH HALVES - SUB P,D ;REMOVE CHAR STRING - TRNE FF,FLONUM+EFLG ;IS IT A FLOATING POINT NUMBER - JRST FLOATIT ;YES, GO MAKE IT WIN - MOVE B,CNUM(C) - TRNE FF,DECFRC - MOVE B,DNUM(C) ;GRAB FIXED GOODIE - TRNE FF,OCTWIN ; SKIP IF NOT OCTAL - MOVE B,ONUM(C) ; USE OCTAL VALUE - -FINID2: MOVSI A,TFIX ;SAY FIXED POINT -FINID1: TRNE FF,NEGF ;NEGATE - MOVNS B ;YES -FINID: POP TP,TP ;RESTORE OLD TP - SUB TP,[1,,1] ;FINISH HACK -IFN FRMSIN,[ - TRNE FF,FRSDOT ;DID . START IT - JRST .SET ;YES, GO HACK -] - POPJ P, ;AND RETURN - - - - -PATH2: MOVE B,IMQUOTE OBLIST - PUSHJ P,IDVAL - JRST PATH1 - -BADPAT: PUSH TP,$TATOM - PUSH TP,EQUOTE NON-ATOMIC-OBLIST-NAME - JRST CALER1 - - -FLOATIT: - JFCL 17,.+1 ;CLEAR ALL ARITHMETIC FLAGS - - TRNE FF,EFLG ;"E" SEEN? - JRST EXPDO ;YES, DO EXPONENT - MOVE D,NDIGS(C) ;GET IMPLICIT EXPONENT - -FLOATE: MOVE A,DNUM(C) ;GET DECIMAL NUMBER - IDIVI A,400000 ;SPLIT - FSC A,254 ;CONVERT MOST SIGNIFICANT - FSC B,233 ; AND LEAST SIGNIFICANT - FADR B,A ;COMBINE - - MOVM A,D ;GET MAGNITUDE OF EXPONENT - CAILE A,37. ;HOW BIG? - JRST FOOR ;TOO BIG-FLOATING OUT OF RANGE - JUMPGE D,FLOAT1 ;JUMP IF EXPONENT POSITIVE - FDVR B,TENTAB(A) ;DIVIDE BY TEN TO THE EXPONENT - JRST SETFLO - -FLOAT1: FMPR B,TENTAB(A) ;SCALE UP - -SETFLO: JFCL 10,FOOR ;FLOATING OUT OF RANGE ON OVERFLOW - MOVSI A,TFLOAT -IFN FRMSIN, TRZ FF,FRSDOT ;FLOATING NUMBER NOT VALUE - JRST FINID1 - -EXPDO: - HRRZ D,ENUM(C) ;GET EXPONENT - TRNE FF,NEGF ;IS EXPONENT NEGATIVE? - MOVNS D ;YES - ADD D,NDIGS(C) ;ADD IMPLICIT EXPONENT - HLR FF,ENUM(C) ;RESTORE FLAGS - JUMPL D,FLOATE ;FLOATING IF EXPONENT NEGATIVE - CAIG D,10. ;OR IF EXPONENT TOO LARGE - TRNE FF,FLONUM ;OR IF FLAG SET - JRST FLOATE - MOVE B,DNUM(C) ; - IMUL B,ITENTB(D) - JFCL 10,FLOATE ;IF OVERFLOW, MAKE FLOATING - JRST FINID2 ;GO MAKE FIXED NUMBER - -; HERE TO READ ONE CHARACTER FOR USER. - -CREDC1: SUBM M,(P) - PUSH TP,A - PUSH TP,B - PUSHJ P,IREADC - JFCL - JRST MPOPJ - -CNXTC1: SUBM M,(P) - PUSH TP,A - PUSH TP,B - PUSHJ P,INXTRD - JFCL - JRST MPOPJ - -CREADC: SUBM M,(P) - PUSH TP,A - PUSH TP,B - PUSHJ P,IREADC - JRST RMPOPJ - SOS (P) - JRST RMPOPJ - -CNXTCH: SUBM M,(P) - PUSH TP,A - PUSH TP,B - PUSHJ P,INXTRD - JRST RMPOPJ - SOS (P) -RMPOPJ: SUB TP,[2,,2] - JRST MPOPJ - -INXTRD: TDZA E,E -IREADC: MOVEI E,1 - MOVE B,(TP) ; CHANNEL - HRRZ A,-4(B) ; GET BLESS BITS - TRNE A,C.BIN - TRNE A,C.BUF - JRST .+3 - PUSHJ P,GRB - HRRZ A,-4(B) - TRC A,C.OPN+C.READ - TRNE A,C.OPN+C.READ - JRST BADCHN - SKIPN A,LSTCH(B) - PUSHJ P,RXCT - MOVEM A,LSTCH(B) ; SAVE CHAR - CAMN A,[-1] ; SPECIAL PSEUDO TTY HACK? - JRST PSEUDO ; YES, RET AS FIX - TRZN A,400000 ; UNDO ! HACK - JRST NOEXCL - SKIPE E - MOVEM A,LSTCH(B) - MOVEI A,"! ; RETURN AN ! -NOEXC1: SKIPGE B,A ; CHECK EOF - SOS (P) ; DO EOF RETURN - MOVE B,A ; CHAR TO B - MOVSI A,TCHRS -PSEUD1: AOS (P) - POPJ P, - -PSEUDO: SKIPE E - PUSHJ P,LSTCH2 - MOVE B,A - MOVSI A,TFIX - JRST PSEUD1 - -NOEXCL: SKIPE E - PUSHJ P,LSTCH2 - JRST NOEXC1 - -; READER ERRORS COME HERE - -ERRPAR: PUSH TP,$TCHRS ;DO THE OFFENDER - PUSH TP,B - PUSH TP,$TCHRS - PUSH TP,[40] ;SPACE - PUSH TP,$TCHSTR - PUSH TP,CHQUOT UNEXPECTED - JRST MISMA1 - -;COMPLAIN ABOUT MISMATCHED CLOSINGS - -MISMAB: SKIPA A,["]] -MISMAT: MOVE A,-1(P) ;GOBBLE THE DESIRED CHARACTER - JUMPE B,CPOPJ ;IGNORE UNIVERSAL CLOSE - PUSH TP,$TCHRS - PUSH TP,B - PUSH TP,$TCHSTR - PUSH TP,CHQUOT [ INSTEAD-OF ] - PUSH TP,$TCHRS - PUSH TP,A -MISMA1: MCALL 3,STRING - PUSH TP,$TATOM - PUSH TP,EQUOTE READER-SYNTAX-ERROR-ERRET-ANYTHING-TO-GO-ON - PUSH TP,A - PUSH TP,B - PUSH TP,$TATOM - PUSH TP,MQUOTE READ - MCALL 3,ERROR -CPOPJ: POPJ P, - -; HERE ON BAD INPUT CHARACTER - -BADCHR: PUSH TP,$TATOM - PUSH TP,EQUOTE BAD-ASCII-CHARACTER - JRST CALER1 - -; HERE ON YUCKY PARSE TABLE - -BADPTB: PUSH TP,$TATOM - PUSH TP,EQUOTE BAD-MACRO-TABLE - JRST CALER1 - -BDPSTR: PUSH TP,$TATOM - PUSH TP,EQUOTE BAD-PARSE-STRING - JRST CALER1 - -ILLSQG: PUSHJ P,LSTCHR ; DON'T MESS WITH IT AGAIN - PUSH TP,$TATOM - PUSH TP,EQUOTE BAD-USE-OF-SQUIGGLY-BRACKETS - JRST CALER1 - - -;FLOATING POINT NUMBER TOO LARGE OR SMALL -FOOR: PUSH TP,$TATOM - PUSH TP,EQUOTE NUMBER-OUT-OF-RANGE - JRST CALER1 - - -NILSXP: 0,,0 - -LSTCHR: PUSH P,B - SKIPL B,5(TB) ;GET CHANNEL - JRST LSTCH1 ;NO CHANNEL, POINT AT SLOT - PUSHJ P,LSTCH2 - POP P,B - POPJ P, - -LSTCH2: SKIPE LSTCH(B) ;ARE WE REALLY FLUSHING A REUSE CHARACTER ? - PUSHJ P,CNTACC - SETZM LSTCH(B) - POPJ P, - -LSTCH1: SETZM 5(TB) ;ZERO THE LETTER AND RETURN - POP P,B - POPJ P, - -CNTACC: PUSH P,A - HRRZ A,-4(B) ; GET BITS - TRNE A,C.BIN - JRST CNTBIN - AOS ACCESS(B) -CNTDON: POP P,A - POPJ P, - -CNTBIN: AOS A,ACCESS-1(B) - CAMN A,[TFIX,,1] - AOS ACCESS(B) - CAMN A,[TFIX,,5] - HLLZS ACCESS-1(B) - JRST CNTDON - - -;TABLE OF NAMES OF ARGS AND ALLOWED TYPES - -ARGS: - IRP A,,[[[CAIN C,TUNBOU]],[[CAIE C,TCHAN],INCHAN],[[PUSHJ P,CHOBL],OBLIST]] - IRP B,C,[A] - B - IFSN [C],IMQUOTE C - .ISTOP - TERMIN - TERMIN - -CHOBL: CAIE C,TLIST ;A LIST OR AN OBLIST - CAIN C,TOBLS - AOS (P) - POPJ P, - -END - - TITLE SAVE AND RESTORE STATE OF A MUDDLE - -RELOCATABLE - -.INSRT DSK:MUDDLE > - -SYSQ - -IFE ITS,[ -IF1,[ -.INSRT STENEX > -EXPUNGE SAVE -] -] - -.GLOBAL MOPEN,MIOT,MCLOSE,MUDSTR,SWAP,STRTO6,GCPDL,RGPRS -.GLOBAL CHNL0,CHNL1,REOPN,AGC,SWAPIN,MASK1,MASK2,IPCBLS -.GLOBAL P.CORE,P.TOP,SGSNAM,%RUNAM,%RJNAM,INTINT,CLOSAL,TTYOPE -.GLOBAL NOTTY,PURCLN,6TOCHS,DISXTR,IDVAL1,N.CHNS - -MFUNCTION FSAVE,SUBR - - ENTRY - - PUSH P,. ; SAY WE ARE FAST SAVER - JRST SAVE1 - -MFUNCTION SAVE,SUBR - - ENTRY - - PUSH P,[0] ; SAY WE ARE OLD SLOW SAVE -SAVE1: SKIPG MUDSTR+2 ; DON'T SAVE FROM EXPERIMENTAL MUDDLE - JRST EXPVRS - PUSH P,[0] ; GC OR NOT? -IFE ITS,[ - MOVE B,[400600,,] - MOVE C,[440000,,100000] -] - PUSHJ P,GTFNM ; GET THE FILE NAME ONTO P - JRST .+2 - JRST SAVEON - JUMPGE AB,TMA ; TOO MUCH STRING - GETYP 0,(AB) ; WHAT IS ARG - CAMGE AB,[-3,,0] ; NOT TOO MANY - JRST TMA - CAIN 0,TFALSE -IFN ITS, SETOM -4(P) ; GC FLAG -IFE ITS, SETOM (P) -SAVEON: -IFN ITS,[ - MOVSI A,7 ; IMAGE BLOCK OUT - HRR A,-2(P) ; DEVICE - PUSH P,A - PUSH P,[SIXBIT /_MUDS_/] - PUSH P,[SIXBIT />/] - MOVEI A,-2(P) ; POINT TO BLOCK - PUSHJ P,MOPEN ; ATTEMPT TO OPEN - JRST CANTOP - SUB P,[3,,3] ; FLUSH OPEN BLOCK - PUSH P,-4(P) ; GC FLAG TO TOP OF STACK -] - EXCH A,(P) ; CHAN TO STACK GC TO A - JUMPL A,.+2 - MCALL 0,GC - -; NOW GET VERSION OF MUDDLE FOR COMPARISON - - MOVE A,MUDSTR+2 ; GET # - MOVEI B,177 ; CHANGE ALL RUBOUT CHARACTERS - MOVEI C,40 ; ----- TO SPACES - PUSHJ P,HACKV - - PUSHJ P,WRDOUT - MOVEI A,0 ; WRITE ZERO IF FAST -IFN ITS, SKIPE -6(P) -IFE ITS, SKIPE -1(P) - PUSHJ P,WRDOUT - MOVE A,VECTOP ; CORE REQUIREMENTS FOR THIS SAVED MUDDLE - PUSHJ P,WRDOUT - -IFN ITS,[ - SETZB A,B ; FIRST, ALL INTS OFF - .SETM2 A, - SKIPE DISXTR ; IF HAVE DISPLAY, CLOSE IT - .DSTOP ; STOP THE E&S IF RUNNING - -; IF FAST SAVE JUMP OFF HERE - - SKIPE -6(P) - JRST FSAVE1 - -; NOW DUMP OUT GC SPACE - MOVEI A,E+1 ; ADDRESS OF FIRST NON-SCRATCH WORD - POP P,0 ; CHAN TO 0 - LSH 0,23. ; POSITION - IOR 0,[.IOT A] -] - -IFE ITS,[ - MOVEI A,400000 ; FOR THIS PROCESS - DIR ; TURN OFF INT SYSTEM - -; IF FAST, LEAVE HERE - - SKIPE -1(P) - JRST FSAVE1 - -; NOW DUMP OUT GC SPACE - POP P,0 ; RESTORE JFN - MOVE A,[-,,E] ; NUMBER OF ACS TO GO - PUSH P,(A) - AOBJN A,.-1 - MOVE A,0 - MOVE B,P - BOUT - MOVEI A,20 ; START AT LOCN 20 -] -DMPLP1: MOVEI B,(A) ; POINT TO START OF STUFF - SUB B,VECTOP ; GET BLOCK LENGTH - MOVSI B,(B) - HRRI B,(A) ; HAVE IOT POINTER - SKIPL B ; SKIP IF OK AOBJN POINTER - HRLI B,400000 ; OTHER WISE AS MUCH AS POSSIBLE - -; MAIN NON-ZERO DUMPING LOOP - -DMPLP: SKIPN C,(B) ; FIND FIRST NON-ZERO - AOBJN B,.-1 - JUMPGE B,DMPDON ; NO MORE TO SCAN - -DMP4: MOVEI E,(B) ; FOUND ONE, SAVE POINTER TO IT -DMP3: MOVSI D,-5 ; DUPLICATE COUNTER SETUP - -DMP1: CAMN C,(B) ; IS NEXT SAME AS THIS? - JRST CNTDUP ; COUNT DUPS - MOVSI D,-5 ; RESET COUNTER - SKIPE C,(B) ; SEARCH FOR ZERO -DMP5: AOBJN B,DMP1 ; COUNT AND GO - JUMPGE B,DMP2 ; JUMP IF BLOCK FINISHED - - AOBJP B,DMP2 ; CHECK FOR LONE ZERO - SKIPE C,(B) - JRST DMP1 ; LONE ZERO, DONT END BLOCK - -DMP2: MOVEI D,(E) ; START COMPUTING OUTPUT IOT - SUBI D,(B) ; D=> -LNTH OF BLOCK - HRLI E,(D) ; E=> AOBJN PNTR TO OUTPUT -IFN ITS,[ - HRROI A,E ; MAKE AN IOT POINTER TO IT - XCT 0 ; WRITE IT - MOVE A,E ; NOW FOR THE BLOCK - XCT 0 ; ZAP!, OUT IT GOES -] -IFE ITS,[ - EXCH E,B ; AOBJN TO B - MOVE A,0 ; JFN TO A - BOUT ; WRITE IT - MOVE D,B ; SAVE POINTER - HRLI B,444400 ; BYTPE POINTER - HLRE C,D ; # OF BYTES - SOUT -] -; NOW COMPUTE A CKS - -IFN ITS,[ - MOVE D,E ; FIRST WORD OF CKS - ROT E,1 - ADD E,(D) - AOBJN D,.-2 ; COMP CKS - HRROI A,E - XCT 0 ; WRITE OUT THE CKS -] -IFE ITS,[ - MOVE B,D - ROT B,1 - ADD B,(D) - AOBJN D,.-2 - BOUT - MOVE B,E ; MAIN POINTER BACK -] - -DMP7: JUMPL B,DMPLP ; MORE TO DO? -DMPDON: SUB B,VECTOP ; DONE? - JUMPGE B,DMPDN1 ; YES, LEAVE -IFN ITS, MOVEI A,400000+PVP ; POINT TO NEXT WORD TO GO -IFE ITS, MOVEI A,400020 - JRST DMPLP1 -IFN ITS,[ -DMPDN1: HRROI A,[-1] - XCT 0 ; EOF -DMPDN2: SETZB A,B ; SET UP RENAME WHILE OPEN ETC. - MOVE E,(P) - MOVE D,-1(P) - LDB C,[270400,,0] ; GET CHANNEL - .FDELE A ; RENAME IT - FATAL SAVE RENAME FAILED - XOR 0,[<.IOT A>#<.CLOSE>] ; CHANGE TO A CLOSE - XCT 0 - - MOVE A,MASK1 ; TURN INTS BACK ON - MOVE B,MASK2 - .SETM2 A, - SKIPE DISXTR ; SKIP IF NO E&S - .DCONTINUE ; RESTART THE E&S IF WE HAVE IT -] - -IFE ITS,[ -DMPDN1: MOVNI B,1 - MOVE A,0 ; WRITE EOF - BOUT -DMPDN2: MOVE A,0 - CLOSF - FATAL CANT CLOSE SAVE FILE - CIS ; CLEAR IT SYSTEM - MOVEI A,400000 - EIR ; AND RE-ENABLE -] - -SDONE: MOVE A,$TCHSTR - MOVE B,CHQUOTE SAVED - JRST FINIS - -; SCAN FOR MANY OCCURENCES OF THE SAME THING - -CNTDUP: AOBJN D,DMP5 ; 4 IN A ROW YET - CAIN E,-4(B) ; ANY PARTIAL BLOCK? - JRST DMP6 ; NO, DUMP THESE - SUB B,[4,,4] ; BACK UP POINTER - JRST DMP2 -DMP6: CAMN C,(B) ; FIND ALL CONTIG - AOBJN B,.-1 - MOVEI D,(B) ; COMPUTE COUNT - SUBI D,(E) - MOVSI D,(D) - HRRI D,(E) ; HEADER -IFN ITS,[ - HRROI A,D - XCT 0 - HRROI A,C ; WRITE THE WORD - XCT 0 -] -IFE ITS,[ - MOVE A,0 - EXCH D,B - BOUT - MOVE B,C - BOUT - MOVE B,D -] JRST DMP7 - -; HERE TO WRITE OUT FAST SAVE FILE - -FSAVE1: MOVE A,PARTOP ; DONT WRITE OUT "HOLE" - ADDI A,1777 - ANDCMI A,1777 - MOVEI E,(A) - PUSHJ P,WRDOUT - MOVE A,VECBOT - ANDCMI A,1777 - HRLI E,(A) - PUSHJ P,WRDOUT - POP P,0 ; CHANNEL TO 0 -IFN ITS,[ - ASH 0,23. ; TO AC FIELS - IOR 0,[.IOT A] - MOVEI A,5 ; START AT WORD 5 -] -IFE ITS,[ - MOVE A,[-,,E] - PUSH P,(A) - AOBJN A,.-1 - MOVE A,0 - MOVE B,P ; WRITE OUT P FOR WIINAGE - BOUT - MOVE B,[444400,,20] - MOVNI C,20-6 - SOUT ; MAKE PAGE BOUNDARIES WIN - MOVEI A,20 ; START AT 20 -] - MOVEI B,(E) ; PARTOP TO B - PUSHJ P,FOUT ; WRITE OUT UP TO PAIR TOP - HLRZ A,E ; VECBOT TO A - MOVE B,VECTOP ; AND THE REST - PUSHJ P,FOUT - JRST DMPDN2 - -IFN ITS,[ -FOUT: MOVEI D,(A) ; SAVE START - SUB A,B ; COMPUTE LH OF IOT PNTR - MOVSI A,(A) - SKIPL A ; IF + MEANS GROSS CORE SIZE - MOVSI A,400000 ; USE BIGGEST - HRRI A,(D) - XCT 0 ; ZAP, OUT IT GOES - CAMGE A,B ; SKIP IF ALL WENT - JRST FOUT ; DO THE REST - POPJ P, ; GO CLOSE FILE -] -IFE ITS,[ -FOUT: MOVEI C,(A) - SUBI C,(B) ; # OF BYTES TP C - MOVEI B,(A) ; START TO B - HRLI B,444400 - MOVE A,0 - SOUT ; WRITE IT OUT - POPJ P, -] - - -; HERE TO ATTEMPT TO RESTORE A SAVED STATE - -MFUNCTION RESTORE,SUBR - - ENTRY - SKIPG MUDSTR+2 ; DON'T RESTORE FROM EXPERIMENTAL MUDDLE - JRST EXPVRS -IFE ITS,[ - MOVE B,[100600,,] - MOVE C,[440000,,240000] -] - PUSHJ P,GTFNM - JRST TMA -IFN ITS,[ - MOVEI A,6 ; READ/IMAGE/BLOCK - HRLM A,-2(P) - MOVEI A,-2(P) - PUSHJ P,MOPEN ; OPEN THE LOSER - JRST FNF - SUB P,[4,,4] ; REMOVE OPEN BLOCK - - PUSH P,A ; SAVE CHANNEL - PUSHJ P,SGSNAM ; SAVE SNAME IN SYSTEM -] -IFE ITS, PUSH P,A ; SAVE JFN - PUSHJ P,WRDIN ; READ MUDDLE VERSION - MOVEI B,40 ; CHANGE ALL SPACES - MOVEI C,177 ; ----- TO RUBOUT CHARACTERS - PUSHJ P,HACKV - CAME A,MUDSTR+2 ; AGREE ? - JRST BADVRS - -IFN ITS, MCALL 0,IPCOFF ; CLOSE ALL IPC CHANS - PUSHJ P,CLOSAL ; CLOSE CHANNELS -IFN ITS,[ - SETZB A,B ; KILL ALL POSSIBLE INTERRUPTION - .SETM2 A, -] -IFE ITS,[ - MOVEI A,400000 ; DISABLE INTS - DIR ; INTS OFF -] - PUSHJ P,PURCLN ; DONT KEEP PURE SHAREDNESS - POP P,A ; RETRIEVE CHANNEL - MOVE P,GCPDL - PUSH P,A ; AND SAVE IT ON A GOOD PDL - PUSHJ P,WRDIN ; READ A WORD (VECTOP) OR 0==>FAST I.E. MAP RESTORE - JUMPE A,FASTR - MOVEM A,VECTOP ; SAVE FOR LATER - ASH A,-10. ; TO BLOCKS - MOVE C,A ; SAVE A COPY - ADDI A,1 ; ROOM FOR GC PDL - PUSHJ P,P.CORE - PUSHJ P,NOCORE ; LOSE,LOSE, LOSE - -; NOW READY TO READ IN GC SPACE - POP P,0 ; GET CHAN - MOVEI E+1,0 - MOVE B,[E+1,,E+2] ; BLT SETUP TO ZERO CORE - MOVE E,NOTTY - MOVE A,VECTOP - BLT B,-1+2000(A) ; THE WHOLE THING? -IFN ITS,[ - LSH 0,23. - IOR 0,[.IOT A] ; BUILD IOT -] -IFE ITS,[ - MOVE A,0 - BIN ; READ IN NEW "P" - MOVE P,B -] -LDLP: -IFN ITS,[ - HRROI A,B ; READ A HDR - XCT 0 - JUMPL A,LD1 ; DONE -] -IFE ITS,[ - MOVE A,0 - BIN ; HDR TO B -] - CAMN B,[-1] - JRST LD1 - - JUMPGE B,LDDUPS ; JUMP IF LOADING DUPS -IFN ITS,[ - MOVE A,B ; TO IOTER - XCT 0 - - MOVE C,B ; COMP CKS - ROT C,1 - ADD C,(B) - AOBJN B,.-2 ; COMP AWAY - - HRROI A,D ; GET FILES CKS - XCT 0 - CAME D,C ; CHECK - FATAL RESTORE CHECKSUM ERROR - JRST LDLP ; LOAD MORE -] -IFE ITS,[ - MOVE D,B ; SAVE - HLRE C,B - HRLI B,444400 - MOVE A,0 - SIN ; READ IN A BUNCH - - MOVE B,D - ROT D,1 - ADD D,(B) - AOBJN B,.-2 - - BIN ; READ STORED CKS - CAME D,B - FATAL RESTORE CHECKSUM ERROR - JRST LDLP -] - -LDDUPS: -IFN ITS,[ - HRROI A,(B) ; READ 1ST IN PLACE - XCT 0 -] -IFE ITS,[ - MOVE D,B ; SAVE HDR - BIN ; READ WORD OF INTEREST - MOVEM B,(D) - MOVE B,D -] - HLRZ A,B ; # TO A - HRLI B,(B) ; BUILD A BLT PONTER - ADDI B,1 - ADDI A,-2(B) - BLT B,(A) - JRST LDLP - -LD1: -IFN ITS,[ - XOR 0,[<.IOT A>#<.CLOSE>] ; CHANGE TO CLOSE - XCT 0 ; AND DO IT -] -IFE ITS,[ - MOVE A,0 - CLOSF - JFCL -FASTR1: MOVEI A,P-1 - MOVEI B,P-1-E - POP P,(A) - SUBI A,1 - SOJG B,.-2 -] - -IFN ITS,[ -FASTR1: -] - MOVE A,VECTOP ; REAL CORE TOP - ADDI A,2000 ; ROOM FOR GC PDL - MOVEM A,P.TOP - MOVEM E,NOTTY ; SAVE TTY FLAG - PUSHJ P,PURCLN ; IN CASE RESTORED THING HAD PURE STUFF - PUSHJ P,INTINT ; USE NEW INTRRRUPTS - -; NOW CYCLE THROUGH CHANNELS - MOVE C,TVP - ADD C,[CHNL1+2,,CHNL1+2] ; POINT TO REAL CHANNELS SLOTS - PUSH TP,$TVEC - PUSH TP,C - PUSH P,[N.CHNS] - -CHNLP: SKIPN B,-1(C) ; GET CHANNEL - JRST NXTCHN - PUSHJ P,REOPN - PUSHJ P,CHNLOS - MOVE C,(TP) ; GET POINTER -NXTCHN: ADD C,[2,,2] ; AND BUMP - MOVEM C,(TP) - SOSE (P) - JRST CHNLP - - SKIPN C,CHNL0(TVP)+1 ; ANY PSUEDO CHANNELS - JRST RDONE ; NO, JUST GO AWAY - MOVSI A,TLIST ; YES, REOPEN THEM - MOVEM A,(TP)-1 -CHNLP1: MOVEM C,(TP) ; SAVE POINTER - SKIPE B,(C)+1 ; GET CHANNEL - PUSHJ P,REOPN - PUSHJ P,CHNLO1 - MOVE C,(TP) ; GOBBLE POINTER - HRRZ C,(C) ; REST LIST OF PSUEDO CHANNELS - JUMPN C,CHNLP1 - -RDONE: SUB TP,[2,,2] - SUB P,[1,,1] - PUSHJ P,TTYOPE -IFN ITS,[ - PUSHJ P,IPCBLS ;BLESS ALL THE IPC CHANNELS - PUSHJ P,SGSNAM ; GET SNAME - SKIPN A - .SUSET [.RSNAM,,A] - PUSHJ P,6TOCHS ; TO STRING - PUSH TP,A - PUSH TP,B - MCALL 1,SNAME -] - PUSHJ P,%RUNAM - PUSHJ P,%RJNAM - MOVE A,$TCHSTR - MOVE B,CHQUOTE RESTORED - JRST FINIS - -FASTR: -IFN ITS,[ - PUSHJ P,WRDIN ; GET CORE TOP - ASH A,-10. ; TO PAGES - MOVEI B,(A) ; SAVE - ADDI A,1 ; ROOM FOR GC PDL - PUSHJ P,P.CORE ; GET ALL CORE - PUSHJ P,NOCORE ; LOSE RETURN - PUSHJ P,WRDIN ; GET PARTOP - ASH A,-10. ; TO PAGES - MOVEI E,(A) - PUSHJ P,WRDIN ; NOW GET VECBOT - ASH A,-10. ; TO PAGES - EXCH A,E ; AND SAVE IN E - MOVNS A - MOVSI A,(A) ; TO PAGE AOBJN - MOVE C,A ; COPY OF POINTER - MOVE 0,NOTTY ; SAVE NOTTY FLAG AROUND - MOVE D,(P) ; CHANNEL - DOTCAL CORBLK,[[1000,,104000],[1000,,-1],A,D,C] - FATAL CORBLK ON RESTORE LOSSAGE - SUBM E,B ; AOBJN LH TO E - HRLI E,(B) ; AOBJN TO CORE - HRLI C,(B) ; AND TO DISK - DOTCAL CORBLK,[[1000,,104000],[1000,,-1],E,D,C] - FATAL CORBLK ON RESTORE LOSSAGE - MOVSI A,(D) ; CHANNEL BACK - ASH A,5 - MOVEI B,E ; WHERE TO STRAT IN FILE - IOR A,[.ACCESS B] - XCT A ; ACCESS TO RIGHT ACS - XOR A,[<.IOT B>#<.ACCESS B>] - MOVE B,[D-P-1,,E] - XCT A ; GET ACS - MOVE E,0 ; NO TTY FLAG BACK - XOR A,[<.IOT B>#<.CLOSE>] - XCT A -] -IFE ITS,[ -FASTR: POP P,A ; JFN TO A - BIN ; CORE TOP TO B - MOVE E,B ; SAVE - BIN ; PARTOP - MOVE D,B - BIN ; VECBOT - MOVE C,B - BIN ; SAVED P - MOVE P,B - MOVE 0,NOTTY ; SAVE NOTTY FLAG AROUND - HRL E,C ; SAVE VECTOP - MOVSI A,(A) ; JFN TO LH - MOVSI B,400000 ; FOR ME - MOVSI C,120400 ; FLAGS - ASH D,-9. ; PAGES TO D - PMAP - ADDI A,1 - ADDI B,1 - SOJG D,.-3 - - ASH E,-9. ; E==> CORTOP PAGE,,VECBOT PAGE - HLR B,E ; B NOW READY - MOVEI D,(E) - SUBI D,(B) - PMAP - ADDI A,1 - ADDI B,1 - SOJG D,.-3 - - HLRZS A - CLOSF - FATAL CANT CLOSE RESTORE FILE - MOVE E,0 ; NOTTY TO E -] - MOVE A,PARTOP ; ZERO OUT NEW FREE - HRLI A,(A) - MOVE B,VECBOT - SETZM (A) - ADDI A,1 - BLT A,-1(B) ; ZAP...YOU'RE ZERO - JRST FASTR1 - - -; HERE TO GROCK FILE NAME FROM ARGS - -GTFNM: -IFN ITS,[ - PUSH TP,$TPDL - PUSH TP,P - - IRP A,,[DSK,MUDDLE,SAVE] - PUSH P,[SIXBIT /A/] - TERMIN - PUSHJ P,SGSNAM ; GET SNAME - PUSH P,A ; SAVE SNAME - - JUMPGE AB,GTFNM1 - PUSHJ P,RGPRS ; PARSE THESE ARGS - JRST .+2 -GTFNM1: AOS -4(P) ; SKIP RETURN - - POP P,A ; GET SNAME - .SUSET [.SSNAM,,A] - MOVE A,-3(P) ; GET RET ADDR - HLRZS -2(P) ; FIXUP DEVICE SPEC - SUB TP,[2,,2] - JRST (A) - -; HERE TOO OUT 1 WORD - -WRDOUT: PUSH P,B - PUSH P,A - HRROI B,(P) ; POINT AT C(A) - MOVE A,-3(P) ; CHANNEL - PUSHJ P,MIOT ;WRITE IT -POPJB: POP P,A - POP P,B - POPJ P, - -; HERE TO READ 1 WORD -WRDIN==WRDOUT -] -IFE ITS,[ - PUSH P,C - PUSH P,B - MOVE B,IMQUOTE SNM - PUSHJ P,IDVAL1 - GETYP 0,A - CAIN 0,TUNBOU - MOVEI B,0 - MOVEI A,(P) - PUSH P,[377777,,377777] - PUSH P,[-1,,[ASCIZ /DSK/]] - PUSH P,B - PUSH P,[-1,,[ASCIZ /MUDDLE/]] - PUSH P,[-1,,[ASCIZ /SAVE/]] - PUSH P,[0] - PUSH P,[0] - PUSH P,[77] ; USE AN OBSCURE JFN IF POSSIBLE - MOVE B,1(AB) - GTJFN - JRST FNF - SUB P,[9.,,9.] - POP P,B - OPENF - JRST FNF - ADD AB,[2,,2] - SKIPL AB - AOS (P) - POPJ P, - -WRDIN: PUSH P,B - MOVE A,-2(P) ; JFN TO A - BIN - MOVE A,B - POP P,B - POPJ P, - -WRDOUT: PUSH P,B - MOVE B,-2(P) - EXCH A,B - BOUT - EXCH A,B - POP P,B - POPJ P, -] - - -;REPLACE ALL OCCURANCES OF CHARACTER (B) TO CHARACTER (C) IN A -HACKV: PUSH P,D - PUSH P,E - MOVE D,[440700,,A] - MOVEI E,5 -HACKV1: ILDB 0,D - CAIN 0,(B) ; MATCH ? - DPB C,D ; YES, CLOBBER - SOJG E,HACKV1 - POP P,E - POP P,D - POPJ P, - - -CANTOP: PUSH TP,$TATOM - PUSH TP,EQUOTE CANT-OPEN-OUTPUT-FILE - JRST CALER1 - -FNF: PUSH TP,$TATOM - PUSH TP,EQUOTE FILE-NOT-FOUND - JRST CALER1 - -BADVRS: PUSH TP,$TATOM - PUSH TP,EQUOTE MUDDLE-VERSIONS-DIFFER - JRST CALER1 - -EXPVRS: PUSH TP,$TATOM - PUSH TP,EQUOTE EXPERIMENTAL-MUDDLE-VERSION - JRST CALER1 - -CHNLO1: MOVE C,(TP) - SETZM 1(C) - JRST CHNLO2 - -CHNLOS: MOVE C,(TP) - SETZM (C)-1 -CHNLO2: MOVEI B,[ASCIZ / -CHANNEL-NOT-RESTORED -/] - JRST MSGTYP" - - -NOCORE: PUSH P,A - PUSH P,B - MOVEI B,[ASCIZ / -WAIT, CORE NOT YET HERE -/] - PUSHJ P,MSGTYP" - MOVE A,(P) ; RESTORE BLOCKS NEEDED - MOVEI B,1 - .SLEEP B, - PUSHJ P,P.CORE - JRST .-4 - MOVEI B,[ASCIZ / -CORE ARRIVED -/] - PUSHJ P,MSGTYP - POP P,B - POP P,A - POPJ P, -END - TITLE SPECS FOR MUDDLE - -RELOCA - -MAIN==1 -.GLOBAL TYPVLC,PBASE,TYPBOT,MAINPR,PTIME,IDPROC,ROOT,TTICHN,TTOCHN,TYPVEC -.GLOBAL %UNAM,%JNAM,NOTTY,GCHAPN,INTHLD,PURBOT,PURTOP,N.CHNS,SPCCHK,CURFCN -.GLOBAL TD.GET,TD.PUT,TD.LNT,NOSHUF - - -.INSRT MUDDLE > - -SYSQ - -CONSTANTS - -IFN ITS,[ - N.CHNS==16. - FATINS==.VALUE -] -IFE ITS,[ - N.CHNS==102 -] - -IMPURE - -CRADIX: 10. -%UNAM: 0 ; HOLDS UNAME -%JNAM: 0 ; HOLDS JNAME -IDPROC: 0 ; ENVIRONMENT NUMBER GENERATOR -PTIME: 0 ; UNIQUE NUMBER FOR PROCID AND ENVIRONMENTS -OBLNT": 13. ; LENGTH OF DEFAULT OBLISTS (SMALL) -VECTOP": VECLOC ; TOP OF CURRENT GARBAGE COLLECTED SPACE -VECBOT": VECBASE ; BOTTOM OF GARBAGE COLLECTED SPACE -CODBOT: 0 ; ABSOLUTE BOTTOM OF CODE -CODTOP": PARBASE ; TOP OF IMPURE CODE (INCLUDING "STORAGE") -HITOP: 0 ; TOP OF INTERPRETER PURE CORE -PARNEW": 0 -PARBOT": PARBASE -PARTOP": PARLOC -VECNEW": 0 ; LOCATION FOR OFFSET BETWWEN OLD GCSTOP AND NEW GCSTOP -INTFLG: 0 ; INTERRUPT PENDING FLAG -MAINPR: 0 ; HOLDS POINTER TO THE MAIN PROCESS -NOTTY: 0 ; NON-ZERO==> THIS MUDDLE HAS NO TTY -GCHAPN: 0 ; NON-ZERO A GC HAS HAPPENED RECENTLY -INTHLD: 0 ; NON-ZERO INTERRUPTS CANT HAPPEN -PURBOT: HIBOT ; BOTTOM OF DYNAMICALLY ALLOCATED PURE -PURTOP: HIBOT ; TOP OF DYNAMICALLY ALLOCATED PURE -SPCCHK: SETZ ; SPECIAL/UNSPECIAL CHECKING? -NOSHUF: 0 ; FLAG TO BUILD A NON MOVING HI SEG - -;PAGE MAP USAGE TABLE FOR MUDDLE -;EACH PAGE IS REPRESENTED BY ONE BIT IN THE TABLE -;IF BIT = 0 THEN PAGE IS FREE OTHERWISE BUSY -;FOR PAGE n USE BIT (n MOD 32.) IN WORD PMAP+n/32. -PMAP": -1 ;SECTION 0 -- BELONGS TO AGC - -1 ;SECTION 1 -- BELONGS TO AGC - -1 ;SECTION 2 -- BELONGS TO AGC - -1 ;SECTION 3 -- BELONGS TO AGC - -1 ;SECTION 4 -- BELONGS TO AGC - -1 ;SECTION 5 -- BELONGS TO AGC (DEPENDS ON HIBOT) - -1 ;SECTION 6 -- START OF PURE CORE (FILLED IN BY INITM) - -1 ;SECTION 7 -- LAST TWO PAGES BELONG TO AGC'S PAGE MAPPER - - -NINT==72. ; NUMBER OF POSSIBLE ITS INTERRUPTS -NASOCS==159. ; LENGTH OF ASSOCIATION VECTOR -PDLBUF==100 ; EXTRA INSURENCE PDL -ASOLNT==10 ; LENGTH OF ASSOCIATION BLOCKS - - -.GLOBAL PATCH,TBINIT,LERR,LPROG,PIDSTO,PROCID,PTIME,GCPDL,INTFLG,WTYP1,WTYP2 -.GLOBAL PAT,PDLBUF,INTINT,PARNEW,GCPVP,START,SWAP,ICR,SPBASE,TPBASE,GLOBAS,GLOBSP,TPBAS -.GLOBAL TOPLEVEL,INTNUM,INTVEC,INTOBL,ASOVEC,ERROBL,MAINPR,RESFUN,.BLOCK,ASOLNT,NODES -.GLOBAL WRONGT,TTYOPE,OPEN,CLOSE,IOT,ILVAL,MESS,FACTI,REFVEC,MUDOBL,INITIA -.GLOBAL LSTRES,BINDID,DUMNOD,PSTAT,1STEPR,IDPROC,EVATYP,APLTYP,PRNTYP,PURVEC,STOLST - - -VECTGO -TVBASE": BLOCK TVLNT - GENERAL - TVLNT+2,,0 -TVLOC==TVBASE - - - -;INITIAL TYPE TABLE - -TYPVLC": - BLOCK 2*NUMPRI+2 - GENERAL - 2*NUMPRI+2+2,,0 - -TYPTP==.-2 ; POINT TO TOP OF TYPES - -; INITIAL SYMBOL TABEL FOR RSUBRS - -SQULOC==. -SQUTBL: BLOCK 2*NSUBRS - TWORD,,0 - 2*NSUBRS+2,,0 - -INTVCL: BLOCK 2*NINT - TLIST,,0 - 2*NINT+2,,0 - -NODLST: TTP,,0 - 0 - TASOC,,0 - BLOCK ASOLNT-3 - GENERAL+ - ASOLNT+2,,0 - -NODDUM: BLOCK ASOLNT - GENERAL+ - ASOLNT+2,,0 - - - -ASOVCL: BLOCK NASOCS - TASOC,,0 - NASOCS+2,,0 - - - -;THESE ENTRIES MUST NOT MOVE DURING INITILAIZATION - -ADDTV TVEC,[-2*NUMPRI-2,,TYPVLC] -TYPVEC==TVOFF-1 - -ADDTV TVEC,[-2*NUMPRI-2,,TYPVLC] -TYPBOT==TVOFF-1 ; POINT TO CURRENT TOP OF TYPE VECTORS - -;ENTRY FOR ROOT,TTICHN,TTOCHN - -ADDTV TCHAN,0 -TTICHN==TVOFF-1 - -ADDTV TCHAN,0 -TTOCHN==TVOFF-1 - -ADDTV TOBLS,0 -ROOT==TVOFF-1 -ADDTV TOBLS,0 -INITIA==TVOFF-1 -ADDTV TOBLS,0 -INTOBL==TVOFF-1 -ADDTV TOBLS,0 -ERROBL==TVOFF-1 -ADDTV TOBLS,0 -MUDOBL==TVOFF-1 -ADDTV TVEC,0 -GRAPHS==TVOFF-1 -ADDTV TFIX,0 -INTNUM==TVOFF-1 -ADDTV TVEC,[-2*NINT,,INTVCL] -INTVEC==TVOFF-1 -ADDTV TUVEC,[-NASOCS,,ASOVCL] -ASOVEC==TVOFF-1 - -ADDTV TLIST,0 -CHNL0"==TVOFF-1 ;LIST FOR CURRENTLY OPEN PSUEDO CHANNELS - -IFN ITS,[ -DEFINE ADDCHN N - ADDTV TCHAN,0 - CHNL!N==TVOFF-1 - .GLOBAL CHNL!N - TERMIN - -REPEAT 15.,ADDCHN \.RPCNT+1 - -DEFINE ADDIPC N - ADDTV TLIST,0 - IPCS!N==TVOFF-1 - .GLOBAL IPCS!N - TERMIN - -REPEAT 15.,ADDIPC \.RPCNT+1 -] - -IFE ITS,[ -ADDTV TCHAN,0 -CHNL1==TVOFF-1 -.GLOBAL CHNL1 -REPEAT N.CHNS-1,[ADDTV TCHAN,0 -] -] - -ADDTV TASOC,[-ASOLNT,,NODLST] -NODES==TVOFF-1 - -ADDTV TASOC,[-ASOLNT,,NODDUM] -DUMNOD==TVOFF-1 - -ADDTV TVEC,0 -EVATYP==TVOFF-1 - -ADDTV TVEC,0 -APLTYP==TVOFF-1 - -ADDTV TVEC,0 -PRNTYP==TVOFF-1 - -; SLOTS ASSOCIATED WITH TEMPLATE DATA STRUCTURES - -ADDTV TUVEC,0 -TD.GET==TVOFF-1 - -ADDTV TUVEC,0 -TD.PUT==TVOFF-1 - -ADDTV TUVEC,0 -TD.LNT==TVOFF-1 - -ADDTV TUVEC,0 -TD.PTY==TVOFF-1 - - - -;GLOBAL SPECIAL PDL - -GSP: BLOCK GSPLNT - GENERAL - GSPLNT+2,,0 - -ADDTV TVEC,[-GSPLNT,,GSP] -GLOBASE==TVOFF-1 -GLOB==.-2 -ADDTV TVEC,GLOB -GLOBSP==TVOFF-1 ;ENTRY FOR CURRENT POINTER TO GLOBAL SP - -; POINTER VECTOR TO PURE SHARED RSUBRS - -PURV: BLOCK 3*20. ; ENOUGH FOR 20 SUCH (INITIALLY) - 0 - 3*20.+2,,0 - -ADDTV TUVEC,[-3*20.,,PURV] -PURVEC==TVOFF-1 - -ADDTV TLIST,0 -STOLST==TVOFF-1 - -;PROCESS VECTOR FOR GARBAGE COLLECTOR PROCESS - -GCPVP: BLOCK PVLNT*2 - GENERAL - PVLNT*2+2,,0 - - -VECRET - -PURE - -;INITIAL PROCESS VECTOR - -PVBASE": BLOCK PVLNT*2 - GENERAL - PVLNT*2+2,,0 -PVLOC==PVBASE - - -;ENTRY FOR PROCESS I.D. - - ADDPV TFIX,1,PROCID -;THE FOLLOWING IRP MAKES SPACE FO9 SAVED ACS - -ZZZ==. - -IRP A,,[0,A,B,C,D,E,PVP,TVP,AB,TB,TP,SP,M,R,P]B,,[0 -0,0,0,0,0,TPVP,TTVP,TAB,TTB,TTP,TSP,TCODE,TRSUBR,TPDL] - -LOC PVLOC+2*A -A!STO==.-PVBASE -B,,0 -0 -TERMIN - -PVLOC==PVLOC+16.*2 -LOC ZZZ - - -ADDPV TTB,0,TBINIT -ADDPV TTP,0,TPBASE -ADDPV TSP,0,SPBASE -ADDPV TPDL,0,PBASE -ADDPV 0,0,RESFUN -ADDPV TLIST,0,.BLOCK -ADDPV TLIST,0,MESS -ADDPV TACT,0,FACTI -ADDPV TPVP,0,LSTRES -ADDPV TFIX,0,BINDID -ADDPV TFIX,1,PSTAT -ADDPV TPVP,0,1STEPR -ADDPV TSP,0,CURFCN - - -IMPURE - -END - ;"TENEX VERSION" - - - - ;"wakeup on all but alpha, no echo" -MUDDLE-MOD ;"gunnasigned initially" - - - - -<PSEUDO <SET SFMOD #OPCODE *104000000110*>> ;"JSYS 110" -<PSEUDO <SET RFMOD #OPCODE *104000000107*>> ;"JSYS 107" -<DECLARE ("VALUE" WORD)> -<HRRZI A* -1> ;"controlling tty file desig" -<RFMOD> -<MOVSI A* TWORD> -<JRST FINIS> - -<TITLE TTY-SET> -<DECLARE ("VALUE" WORD <PRIMTYPE WORD>)> -<HRRZI A* -1> -<MOVE B* 1 (AB)> -<SFMOD> -<MOVE A* (AB)> -<MOVE B* 1 (AB)> -<JRST FINIS> - -<END> - -<DEFINE TTY-OFF () -<COND (<NOT <GASSIGNED? MUDDLE-MOD>> - <SETG MUDDLE-MOD <TTY-GET>>)> - <TTY-SET ,CALICO-MOD>> - -<DEFINE TTY-ON () -<COND (<NOT <GASSIGNED? MUDDLE-MOD>> - <SETG MUDDLE-MOD <TTY-GET>>) - (<TTY-SET ,MUDDLE-MOD>)>> - - -<ENDPACKAGE> - TITLE UUO HANDLER FOR MUDDLE AND HYDRA -RELOCATABLE -.INSRT MUDDLE > - -;GLOBALS FOR THIS PROGRAM - -.GLOBAL BACKTR,PRINT,PDLBUF,TPGROW,SPECSTO,TIMOUT,AGC,VECBOT,VECTOP -.GLOBAL BCKTRK,TPOVFL,.MONWR,.MONRD,.MONEX,MAKACT,IGVAL,ILVAL,BFRAME -.GLOBAL PURTOP,PURBOT,PLOAD,PURVEC,STOSTR,MSGTYP,UUOH,ILLUUO - -;SETUP UUO DISPATCH TABLE HERE - -UUOTBL: ILLUUO - -IRP UUOS,,[[DP,DODP],[.MCALL,DMCALL],[.ACALL,DACALL],[.ECALL,DECALL],[.FATAL,DFATAL]] -UUFOO==.IRPCNT+1 -IRP UUO,DISP,[UUOS] -.GLOBAL UUO -UUO=UUFOO_33 -DISP -.ISTOP -TERMIN -TERMIN - -REPEAT 100-UUFOO,[ILLUUO -] - - -RMT [ -IMPURE - -UUOH: -LOC 41 - JSR UUOH -LOC UUOH - 0 - JRST UUOPUR ;GO TO PURE CODE FOR THIS - -SAVEC: 0 ; USED TO SAVE WORKING AC -NOLINK: 0 - -PURE -] - -;SEPARATION OF PURE FROM IMPURE CODE HERE - -UUOPUR: MOVEM C,SAVEC ; SAVE AC - LDB C,[330900,,40] - JRST @UUOTBL(C) ;DISPATCH BASED ON THE UUO - - - -ILLUUO: FATAL ILLEGAL UUO - ;CALL HANDLER - -MQUOTE CALLER -CALLER: - -DMCALL": - MOVEI D,0 ; FLAG NOT ENTRY CALL - LDB C,[270400,,40] ; GET AC FIELD OF UUO -COMCAL: LSH C,1 ; TIMES 2 - MOVN AB,C ; GET NEGATED # OF ARGS - HRLI C,(C) ; TO BOTH SIDES - SUBM TP,C ; NOW HAVE TP TO SAVE - MOVEM C,TPSAV(TB) ; SAVE IT - MOVSI AB,(AB) ; BUILD THE AB POINTER - HRRI AB,1(C) ; POINT TO ARGS - HRRZ C,UUOH ; GET PC OF CALL - CAMG C,PURTOP ; SKIP IF NOT IN GC SPACE - CAIGE C,STOSTR ; SKIP IF IN GC SPACE - JRST .+3 - SUBI C,(M) ; RELATIVIZE THE PC - HRLI C,M ; FOR RETURNER TO WIN - MOVEM C,PCSAV(TB) - MOVEM SP,SPSAV(TB) ; SAVE BINDING GOODIE - MOVSI C,TENTRY ; SET UP ENTRY WORD - HRR C,40 ; POINT TO CALLED SR - ADD TP,[FRAMLN,,FRAMLN] ; ALLOCATE NEW FRAME - JUMPGE TP,TPLOSE -CALDON: MOVEM C,FSAV+1(TP) ; CLOBBER THE FRAME - MOVEM TB,OTBSAV+1(TP) - MOVEM AB,ABSAV+1(TP) ; FRAME BUILT - MOVEM P,PSAV(TB) - HRRI TB,(TP) ; SETUP NEW TB - MOVEI C,(C) - MOVEI M,0 ; UNSETUP M FOR GC WINNAGE - CAMG C,VECTOP ; SKIP IF NOT RSUBR - CAMGE C,VECBOT ; SKIP IF RSUBR - JRST CALLS - GETYP A,(C) ; GET CONTENTS OF SLOT - JUMPN D,EVCALL ; EVAL CALLING ENTRY ? - CAIE A,TRSUBR ; RSUBR CALLING RSUBR ? - JRST RCHECK ; NO - MOVE R,(C)+1 ; YES, SETUP R -CALLR0: HRRM R,FSAV+1(TB) ; FIXUP THE PROPER FSAV -CALLR1: AOS E,2(R) ; COUNT THE CALLS - TRNN E,-1 ; SKIP IF OK - JRST COUNT1 - - SKIPL M,(R)+1 ; SETUP M - JRST SETUPM ; JUMP IF A PURE RSUBR IN QUESTION - AOBJP TB,.+1 ; GO TO CALLED RSUBR - INTGO ; CHECK FOR INTERRUPTS - JRST (M) - -COUNT1: SOS 2(R) ; UNDO OVERFLOW - HLLZS 2(R) - JRST CALLR1 - -CALLS: AOBJP TB,.+1 ; GO TO CALLED SUBR - INTGO ; CHECK FOR INTERRUPTS - JRST @C - -; HERE TO HANDLE A PURE RSUBR (LOAD IF PUNTED OR OTHERWISE FLUSHED) - -SETUPM: MOVEI C,0 ; OFFSET (FOR MAIN ENTRIES) -STUPM1: MOVEI D,(M) ; GET OFFSET INTO CODE - HLRS M ; GET VECTOR OFFSET IN BOTH HALVES - ADD M,PURVEC+1(TVP) ; GET IT - SKIPL M - FATAL LOSING PURE RSUBR POINTER - HLLM TB,2(M) ; MARK FOR LRU ALGORITHM - SKIPN M,1(M) ; POINT TO CORE IF LOADED - AOJA TB,STUPM2 ; GO LOAD IT -STUPM3: ADDI M,(D) ; POINT TO REAL THING - HRLI C,M ; POINT TO START PC - AOBJP TB,.+1 - INTGO - JRST @C ; GO TO IT - -STUPM2: HLRZ A,1(R) ; SET UP TO CALL LOADER - PUSH P,D - PUSH P,C - PUSHJ P,PLOAD ; LOAD IT - JRST PCANT1 - POP P,C - POP P,D - MOVE M,B ; GET LOCATION - SOJA TB,STUPM3 - -RCHECK: CAIN A,TPCODE ; PURE RSUBR? - JRST .+3 - CAIE A,TCODE ; EVALUATOR CALLING RSUBR ? - JRST SCHECK ; NO - MOVS R,(C) ; YES, SETUP R - HRRI R,(C) - JRST CALLR1 ; GO FINISH THE RSUBR CALL - - -SCHECK: CAIE A,TSUBR ; RSUBR CALLING SUBR AS REFERENCE ? - CAIN A,TFSUBR - SKIPA C,(C)+1 ; SKIP AND GET ROUTINE'S ADDRESS - JRST ECHECK - HRRM C,FSAV+1(TB) ; FIXUP THE PROPER FSAV - JRST CALLS ; GO FINISH THE SUBR CALL - -ECHECK: CAIE A,TENTER ; SKIP IF SUB ENTRY OF RSUBR - JRST ACHECK ; COULD BE EVAL CALLING ONE - MOVE C,1(C) ; POINT TO SUB ENTRY BLOCK -ECHCK3: GETYP A,(C) ; SEE IF LINKED TO ITS MAIN ENTRY - MOVE B,1(C) - CAIN A,TRSUBR - JRST ECHCK2 - -; CHECK IF CAN LINK ATOM - - CAIE A,TATOM - JRST BENTRY ; LOSER , COMPLAIN -ECHCK4: MOVE B,1(C) ; GET ATOM - PUSH TP,$TVEC - PUSH TP,C - PUSHJ P,IGVAL ; TRY GLOBAL VALUE - MOVE C,(TP) - SUB TP,[2,,2] - CAMN A,$TUNBOU - JRST BADVAL - CAME A,$TRSUBR ; IS IT A WINNER - JRST BENTRY - SKIPE NOLINK - JRST ECHCK2 - HLLM A,(C) ; FIXUP LINKAGE - MOVEM B,1(C) - JRST ECHCK2 - -EVCALL: CAIN A,TATOM ; EVAL CALLING ENTRY? - JRST ECHCK4 ; COULD BE MUST FIXUP - CAIE A,TRSUBR ; YES THIS IS ONE - JRST BENTRY - MOVE B,1(C) -ECHCK2: MOVE R,B ; SET UP R - HRRM C,FSAV+1(TB) ; SET POINTER INTO FRAME - HRRZ C,2(C) ; FIND OFFSET INTO SAME - SKIPL M,1(R) ; POINT TO START OF RSUBR - JRST STUPM1 ; JUMP IF A LOSER - HRLI C,M - JRST CALLS ; GO TO SR - -ACHECK: CAIE A,TATOM ; RSUBR CALLING THROUGH REFERENCE ATOM ? - JRST DOAPP3 ; TRY APPLYING IT - MOVE A,(C) - MOVE B,(C)+1 - PUSHJ P,IGVAL - HRRZ C,40 ; REGOBBLE POINTER TO SLOT - GETYP 0,A ; GET TYPE - CAIN 0,TUNBOUND - JRST TRYLCL -SAVEIT: CAIE 0,TRSUBR - CAIN 0,TENTER - JRST SAVEI1 ; WINNER - CAIE 0,TSUBR - CAIN 0,TFSUBR - JRST SUBRIT - JRST BADVAL ; SOMETHING STRANGE -SAVEI1: SKIPE NOLINK - JRST .+3 - MOVEM A,(C) ; CLOBBER NEW VALUE - MOVEM B,(C)+1 - CAIN 0,TENTER - JRST ENTRIT ; HACK ENTRY TO SUB RSUBR - MOVE R,B ; SETUP R - JRST CALLR0 ; GO FINISH THE RSUBR CALL - -ENTRIT: MOVE C,B - JRST ECHCK3 - -SUBRIT: SKIPE NOLINK - JRST .+3 - MOVEM A,(C) - MOVEM B,1(C) - HRRM B,FSAV+1(TB) ; FIXUP THE PROPER FSAV - MOVEI C,(B) - JRST CALLS ; GO FINISH THE SUBR CALL - -TRYLCL: MOVE A,(C) - MOVE B,(C)+1 - PUSHJ P,ILVAL - GETYP 0,A - CAIE 0,TUNBOUND - JRST SAVEIT - SKIPA D,EQUOTE UNBOUND-VARIABLE -BADVAL: MOVEI D,0 -ERCAL: AOBJP TB,.+1 ; MAKE TB A LIGIT FRAME PNTR - MOVEI E,CALLER - HRRM E,FSAV(TB) ; SET A WINNING FSAV - HRRZ C,40 ; REGOBBLE POINTER TO SLOT - JUMPE D,DOAPPL - SUBI C,(R) ; CALCULATE OFFSET - HRLS C - ADD C,R ; MAKE INTO REAL RSUBR POINTER - PUSH TP,$TRSUBR ; SAVE - PUSH TP,C - HRRZ C,40 ; REGOBBLE POINTER TO SLOT - PUSH TP,$TATOM - PUSH TP,D - PUSH TP,(C) - PUSH TP,(C)+1 - PUSH TP,$TATOM - PUSH TP,MQUOTE CALLER - MCALL 3,ERROR - MOVE C,(TP) ; GET SAVED RSUBR POINTER - SUB TP,[2,,2] ; POP STACK - GETYP 0,A - HRRM C,40 - SOJA TB,SAVEIT - -BENTRY: MOVE D,EQUOTE BAD-ENTRY-BLOCK - JRST ERCAL - -;HANDLER FOR CALL WHERE SPECIFIES NUMBER OF ARGS - -DACALL": - LDB C,[270400,,40] ; GOBBLE THE AC LOCN INTO C - EXCH C,SAVEC ; C TO SAVE LOC RESTORE C - MOVE C,@SAVEC ; C NOW HAS NUMBER OF ARGS - MOVEI D,0 ; FLAG NOT E CALL - JRST COMCAL ; JOIN MCALL - -; CALL TO ENTRY FROM EVAL (LIKE ACALL) - -DECALL: LDB C,[270400,,40] ; GET NAME OF AC - EXCH C,SAVEC ; STORE NAME - MOVE C,@SAVEC ; C NOW HAS NUM OF ARGS - MOVEI D,1 ; FLAG THIS - JRST COMCAL - -;HANDLE OVERFLOW IN THE TP - -TPLOSE: PUSHJ P,TPOVFL - JRST CALDON - -; RSUBR HAS POSSIBLY BEEN REPLACED BY A FUNCTION OR WHATEVER, DO AN APPLY - -DOAPPL: PUSH TP,A ; PUSH THE THING TO APPLY - PUSH TP,B - MOVEI A,1 -DOAPP2: JUMPGE AB,DOAPP1 ; ARGS DONE - - PUSH TP,(AB) - PUSH TP,1(AB) - ADD AB,[2,,2] - AOJA A,DOAPP2 - -DOAPP1: ACALL A,APPLY ; APPLY THE LOSER - JRST FINIS - -DOAPP3: MOVE A,(C) ; GET VAL - MOVE B,1(C) - JRST BADVAL ; GET SETUP FOR APPLY CALL - -; ENTRY TO BUILD A FRAME (USED BY SOME COMPILED PROG/REPEAT) - -BFRAME: HRLI A,M ; RELATIVIZE PC - MOVEM A,PCSAV(TB) ; CLOBBER PC IN - MOVEM TP,TPSAV(TB) ; SAVE STATE - MOVEM SP,SPSAV(TB) - ADD TP,[FRAMLN,,FRAMLN] - SKIPL TP - PUSHJ TPOVFL ; HACK BLOWN PDL - MOVSI A,TCBLK ; FUNNY FRAME - HRRI A,(R) - MOVEM A,FSAV+1(TP) ; CLOBBER - MOVEM TB,OTBSAV+1(TP) - MOVEM AB,ABSAV+1(TP) - POP P,A ; RET ADDR TO A - MOVEM P,PSAV(TB) - HRRI TB,(TP) - AOBJN TB,.+1 - JRST (A) - ;SUBROUTINE TERMINATION CODE (NOT A UUO BUT HERE FOR COMPLETENENSS) - -FINIS: -CNTIN1: HRRZS C,OTBSAV(TB) ; RESTORE BASE - HRRI TB,(C) -CONTIN: MOVE TP,TPSAV(TB) ; START HERE FOR FUNNY RESTART - MOVE P,PSAV(TB) - CAME SP,SPSAV(TB) ; ANY RESTORATION NEEDED - PUSHJ P,SPECSTO ; YES, GO UNRAVEL THE WORLDS BINDINGS - MOVE AB,ABSAV(TB) ; AND GET OLD ARG POINTER - HRRZ C,FSAV(TB) ; CHECK FOR RSUBR - MOVEI M,0 ; UNSETUP M FOR GC WINNAGE - CAMG C,VECTOP - CAMGE C,VECBOT - JRST @PCSAV(TB) ; AND RETURN - GETYP 0,(C) ; RETURN TO MAIN OR SUB ENTRY? - CAIN 0,TCODE - JRST .+3 - CAIE 0,TPCODE - JRST FINIS1 - MOVS R,(C) - HRRI R,(C) ; RESET R - SKIPGE M,1(R) ; GET LOC OF REAL SUBR - JRST @PCSAV(TB) - JRST FINIS2 - -FINIS1: CAIE 0,TRSUBR - JRST FINISA ; MAY HAVE BEEN PUT BACK TO ATOM - MOVE R,1(C) - SKIPGE M,1(R) - JRST @PCSAV(TB) - -FINIS2: MOVEI C,(M) ; COMPUTE REAL M FOR PURE RSUBR - HLRS M - ADD M,PURVEC+1(TVP) - SKIPN M,1(M) ; SKIP IF LOADED - JRST FINIS3 - ADDI M,(C) ; POINT TO SUB PART - JRST @PCSAV(TB) - -FINIS3: PUSH TP,A - PUSH TP,B - HLRZ A,1(R) ; RELOAD IT - PUSHJ P,PLOAD - JRST PCANT - POP TP,B - POP TP,A - MOVE M,1(R) - JRST FINIS2 - -FINISA: CAIE 0,TATOM - JRST BADENT - PUSH TP,A - PUSH TP,B - PUSH TP,$TENTER - HRL C,(C) - PUSH TP,C - MOVE B,1(C) ; GET ATOM - PUSHJ P,IGVAL ; GET VAL - GETYP 0,A - CAIE 0,TRSUBR - JRST BADENT - MOVE C,(TP) - HLLM A,(C) - MOVEM B,1(C) - MOVE A,-3(TP) - MOVE B,-2(TP) - SUB TP,[4,,4] - JRST FINIS1 - -BADENT: PUSH TP,$TATOM - PUSH TP,EQUOTE RSUBR-ENTRY-UNLINKED - JRST CALER1 - -PCANT1: ADD TB,[1,,] -PCANT: PUSH TP,$TATOM - PUSH TP,EQUOTE PURE-LOAD-FAILURE - JRST CALER1 - -REPEAT 0,[ -BCKTR1: PUSH TP,A ; SAVE VALUE TO BE RETURNED - PUSH TP,B ; SAVE FRAME ON PP - PUSHJ P,BCKTRK - POP TP,B - POP TP,A - JRST CNTIN1 -] - -; SUBR TO ENABLE AND DISABLE LINKING OF RSUBRS AT RUN TIME - -MFUNCTION %RLINK,SUBR,[RSUBR-LINK] - - ENTRY 1 - - GETYP 0,(AB) - SETZM NOLINK - CAIN 0,TFALSE - SETOM NOLINK - MOVE A,(AB) - MOVE B,1(AB) - JRST FINIS - -;HANDLER FOR DEBUGGING CALL TO PRINT - -DODP": - PUSH TP, @40 - AOS 40 - PUSH TP,@40 - PUSH P,0 - PUSH P,1 - PUSH P,2 - PUSH P,SAVEC - PUSH P,4 - PUSH P,5 - PUSH P,40 - PUSH P,UUOH - MCALL 1,PRINT - POP P,UUOH - POP P,40 - POP P,5 - POP P,4 - POP P,3 - POP P,2 - POP P,1 - POP P,0 - JRST 2,@UUOH - - -DFATAL: MOVEM A,20 - MOVEM B,21 - MOVE B,40 - HRLI B,440700 - PUSHJ P,MSGTYP - JRST 4,. -END -  \ No newline at end of file diff --git a/sumex/muddle.mcr291 b/sumex/muddle.mcr291 new file mode 100644 index 0000000..29bd011 --- /dev/null +++ b/sumex/muddle.mcr291 @@ -0,0 +1,1182 @@ +; THE FOLLOWING INFORMATION IS MEANT AS GUIDE TO THE CARE AND FEEDING +; OF MUDDLE. IT ATTEMPTS TO SPECIFY PROGRAMMING CONVENTIONS AND +; SUPPLY SYMBOLS AND MACROS NEEDED BY ALL MODULES IN A MUDDLE. + +; FOR EFFICIENCY THE STANDARD MODE OF RUNNING IS UNINTERRUPTABLE. +; WITH EXPLICIT CHECKS FOR PENDING INTERRUPTS. THE INTGO MACRO +; PERFORMS THE APPROPRIATE CHECK + +; FOR INTERRUPTS TO WORK IN INTERRUPTABLE CODE, IT MUST +; BE ABSOLUTELY PURE. BETWEEN ANY TWO INSTRUCTIONS OF +; INTERRUPTABLE CODE THERE MAY BE AN INTERUPT IN WHICH +; A COMPACTING GARBAGE COLLECTION MAY OCCUR. +; NOTE: A SCRATCH AC MAY CONTAIN POINTERS TO GC SPACE IN +; INTERRUPTABLE CODE OR DURING AN INTGO IF THE TYPE CODE FOR THAT AC'S +; SLOT IN THE PROCESS VECTOR IS SET TO REFLECT ITS CONTENTS. + +; ALL ATOM POINTERS WILL BE REFERRED TO IN ASSEMBLED CODE BY +; MQUOTE <PNAME> -- FOR NORMAL ATOMS +; EQUOTE <PNAME> -- FOR ERROR COMMENT ATOMS + +; FUNCTION CALLS TO INITIAL FUNCTIONS WILL BE CALLED USING THE FOLLOWING: + +; MCALL N,<PNAME> ;SEE MCALL MACRO +; ACALL AC,<PNAME> ; SEE ACALL MACRO + +; UNLESS PNAME IS NOT A VALID MIDAS SYMBOL, IN WHICH CASE ANOTHER INTERNAL +; NAME WILL BE USED + +; WHEN CALLING A SUBR THROUGH AN INDEX OR INDIRECT, THE UUOS GENERATED +; BY THE MACROS SHOULLD BE USED. +; THESE ARE .MCALL AND .ACALL -- EXAMPLE: +; .ACALL A,@(B) + + + + + + ; ORGANIZATION OF CORE STORAGE IN THE MUDDLE SYSTEM (ENVIRONMENT) + +; 20: SPECIAL CODE FOR UUO AND INTERUPTS + +;CODBOT: WORD CONTAINING LOCATION OF BOTTOMMOST WORD OF IMPURE CODE + +; --IMPURE CODE-- + +;CODTOP: WORD CONTAINING LOCATION OFWORD AFTER LAST WORD OF CODE + +;PARBOT: WORD CONTAINING LOCATION OFBOTTOMMOST LIST + +; --PAIRSS-- + +;PARTOP: WORD CONTAINING LOCATION OFWORD AFTER LAST PAIR WORD + +;VECBOT: WORD CONTAINING LOCATION OFFIRST WORD OF VECTORS + +; --VECTORS-- + +;VECTOP: WORD CONTAINING LOCATION OFWORD AFTER TOPMOST VECTOR +; THE WORD BEFORE VECTOP IS THE DOPE FOR THE LAST VECTOR + +; --GC MARK PDL (SOMETIMES NOT THERE)-- + +;CORTOP: TOP OF LOW-SEGMENT/IMPURE CORE + +;600000: START OF PURE CODE (SHARED ALSO) + +; --PURE CODE-- + +; + + + ; BASIC DATA TYPES PRE-DEFINED IN MUDDLE + +; PRIMITIVE DATA TYPES +; IF T IS A DATA TYPE THEN $T=[T,,0] + +; DATA TYPES ARE ASSIGNED BY THE TYPMAK MACRO IN SOME ARBITRARY ORDER + + +;TLOSE ;ILLEGAL TYPE (USED PRIMARILY FOR ERRORS) +;TFIX ;FIXED POINT +;TFLOAT ;FLOATING POINT +;TCHRS ;WORD OF UP TO 5 ASCII CHARACTERS +;TENTRY ; MARKS BEGINNING OF A FRAME ON TP STACK +;TSUBR ;BUILT IN FUNCTION WITH EVALUATED ARGS +;TFSUBR ;BUILT IN FUNCTION WITH UN-EVALUATED ARGS +;TUNBOU ;TYPE GIVEN TO UNBOUND OR UNASSIGNED ATOM +;TBIND ;MARKS BEGINNING OF BINDING BLOCK ON TP STACK +;TILLEG ;POINTER PREVIOUSLY HERE NOW ILLEGAL +;TTIME ;UNIQUE NUMBER (SEE FLOAD) +;TLIST ;POINTER TO LIST ELEMENT +;TFORM ;POINTER TO LIST ELEMENT BUT USED AS AN EXPRESSION +;TSEG ;SAME AS FORM BUT VALUE IS MUST BE STRUCTURED AND IS USED +; ;AS A SEGMENT +;TEXPR ;POINTER TO LIST ELEMENT BUT USED AS AN INTERPRETIVE FUNCTION +;TFUNAR ;LIKE TEXPR BUT HAS PARTIALLY EVALUATED ARGS +;TLOCL ;LOCATIVE TO LIST ELEMENT (SEE AT,IN AND SETLOC) +;TFALSE ;NOT TRUTH +;TDEFER ;POINTER TO REAL VALUE (ONLY APPEARS AS CAR OF LIST) +;TUVEC ;AOBJN POINTER TO UNIFORM VECTOR +;TOBLS ;AOBJN TO UVEC OF LISTS OF ATOMS. USED AS SYMBOL TABLE +;TVEC ;VECTOR (AOBJN POINTER TO GENERALIZED VECTOR) +;TCHAN ;VECTOR OF INFO DESCRIBING AN I/O CHANNEL +;TLOCV ;LOCATIVE TO GENERAL VECTOR (SEE AT,IN AND SETLOC) +;TTVP ;POINTER TO TRANSFER VECTOR +;TBVL ;BEGINS A VECTOR BINDING ON THE TP STACK +;TTAG ;VECTOR OF INFO SPECIFYING A GENERALIZED TAG +;TPVP ;POINTER TO PROCESS VECTOR +;TLOCI ;POINTER TO ATOM VALUE ON STACK (INTERNAL NOT SEEN BY USER) +;TTP ;POINTER TO MAIN MARKED STACK +;TSP ;POINTER TO CURRENT BINDINGS ON STACK +;TLOCS ;LOCATIVE TO STACK (NOT CURRENTLY USED) +;TPP ;POINTER TO PLANNER PDL (NOT CURRENTLY USED) +;TPLD ;POINTER TO P-STACK (UNMARKED) +;TARGS ;POINTER TO AN ARG BLOCK (HAIRY KLUDGE) +;TAB ;SAVED AB (NOT GIVEN TO USER) +;TTB ;SAVED TB (NOT GIVEN TO USER) +;TFRAME ;USER POINTER TO STACK FRAME +;TCHSTR ;BYTE POINTER TO STRING OF CHARS (COUNT ALSO INCLUDED) +;TATOM ;POINTER TO ATOM +;TLOCD ;USER LOCATIVE TO ATOM VALUE +;TBYTE :POINTER TO ARBITRARY BYTE STRING (NOT CURRENTLY USED) +;TENV ;USER POINTER TO FRAME USED AS AN ENVIRONMENT +;TACT ;USER POINTER TO FRAME FOR A NAMED ACTIVATION +;TASOC ;ASSOCIATION TRIPLE +;TLOCU ;LOCATIVE TO UVECTOR ELEMENT (SEE AT,IN AND SETLOC) +;TLOCS ;LOCATIVE TO A BYTE IN A CHAR STRING (SEE AT,IN AND SETLOC) +;TLOCA ;LOCATIVE TO ELEMENT IN ARG BLOCK +;TENTS ;NOT USED +;TBS ; "" +;TPLDS ; "" +;TPC ; "" +;TINFO ;POINTER TO LIST ELEMENT USED WITH ARG POINTERS +;TNBS ;NOT USED +;TBVLS ;NOT USED +;TCSUBR ;CARE SUBR (USED ONLY WITH CUDDLE SEE -- WJL) +;TWORD ;36-BIT WORD +;TRSUBR ;COMPILED PROGRAM (ACTUALLY A VECTOR POINTER) +;TCODE ;UNIFORM VECTOR OF INSTRUCTIONS +;TCLIST ;NOT USED +;TBITS ;GENERAL BYTE POINTER +;TSTORA ;POINTER TO NON GC IMPURE STUFF +;TPICTU ;E&S CODE IN NON GC SPACE +;TSKIP ;ENVIRONMENT SPLICE +;TLINK ;LEXICAL LINK +;TINTH ;INTERRUPT HEADER +;THAND ;INTERRUPT HANDLER +;TLOCN ;LOCATIVE TO ASSOCIATION +;TDECL ;POINTER TO LIST OF ATOMS AND TYPE DECLARATIONS +;TDISMI ;TYPE MEANING DONT RUN REST OF HANDLERS +;TDCLI ; INTERNAL TYPE FOR SAVED FUNCTION BODY +;TMENT ; POINTER TO MAIN ENTRY OF WHICH THIS IS PART +;TENTER ; NON-MAIN ENTRY TO AN RSUBR +;TSPLICE ; RETURN FROM READ MACRO MEANS SPLICE SUBELEMENTS IN +;TPCODE ; PURE CODE POINTER IN FUNNY FORMAT +;TTYPEW : TYPE WORD +;TTYPEC ; TYPE CODE +;TGATOM ; ATOM WITH GVALUE +;TREADA ; READ ACTIVATION HACK +;TUNWIN ; INTERNAL FOR UNWIND SPEC ON STACK +;TUBIND ; BINDING OF UNSPECIAL ATOM +;TMACRO ; EVAL MACRO + +; STORGE ALLOCATION TYPES. ALLOCATED BY AN "IRP" LATER IN THIS FILE + + +;S1WORD ;UNMARKED STUFF OF NO INTEREST TO AGC +;S2WORD ;POINTERS TO ELEMENTS IN PAIR SPACE (LIST, FORM, EXPR ETC.) +;S2DEFR ;DEFERRED LIST VALUES +;SNWORD ;POINTERS TO UNIFORM VECTORS +;S2NWOR ;POINTERS TO GENERAL VECTORS +;STPSTK ;STACK POINTERS +;SPSTK ;UNMARKED STACK POINTERS +;SARGS ;POINTERS TO ARG BLOCKS (USER) +;SABASE ;POINTER TO ARG BLOCK (INTERNAL) +;STBASE ;POINTER TO FRAME (INTERNAL) +;SFRAME ;POINTER TO FRAME (USER) +;SBYTE ;GENERAL BYTE POINTER +;SATOM ;POINTER TO ATOM +;SLOCID ;POINTER TO VALUE CELL OF ATOM +;SPVP ;PROCESS VECTORS +;SCHSTR ;ASCII BYTE POINTER +;SASOC ;POINTER TO ASSOCIATION BLOCK +;SINFO ;LIST CELL CONTAINING EXTRA ARGBLOCK INFO +;SSTORE ;NON GC STORGAGE POINTER +;SLOCA ;ARG BLOCK LOCATIVE +;SLOCD ;USER VALUE CELL LOCATIVE +;SLOCS ;LOCATIVE TO STRING +;SLOCU ;LOCATIVE TO UVECTOR +;SLOCV ;LOCATIVE TO GENERAL VECTOR +;SLOCL ;LOCATIVE TO LIST ELEENT +;SLOCN ;LOCATIVE TO ASSOCIATION +;SGATOM ;REALLY ATOM BUT SPECIAL GC HACK + +;NOTE: TO FIND OUT IF A GIVEN STORAGE ALLOCATION TYPE NEEDS TO BE DEFERRED, REFER TO +;LOCATION "MKTBS:" OFFSET BY THE STORAGE TYPE. IF IT IS <0, THAT SAT NEEDS TO BE DEFERRED. +; +;ONE WAY TO DO THIS IS TO PUT A REAL TYPE CODE IN AC A AND PUHSJ P,NWORDT +; A WILL CONTAIN 1 IF NO DEFERRED NEEDED OR 2 IF DEFER IS NEEDED + + ; SOME MUDDLE DATA FORMATS + +; FORMAT OF LIST ELEMENT + +; WORD 1: SIGN BIT, RESERVED FOR GARBAGE COLLECTOR +; BITS 1-17 TYPE OF FIRST ELEMENT OF LIST +; BITS 18-35 POINTS TO REST OF LIST (ALWAYS ANOTHER LIST OR 0) +; +; WORD 2: DATUM OF FIRST ELEMENT OF LIST OF TYPE SPECIFIED +; +; IF DATUM REQUIRES 54 BITS TO SPECIFY, TYPE WILL BE "TDEFER" AND +; VALUE WILL BE AN 18 BIT POINTER TO FULL 2 WORD PAIR + + + +;FORMAT OF GENERAL VECTOR (OF N ELEMENTS) +;POINTED INTO BY AOBJN POINTER +;A GENERAL VECTOR HAS FEWER THAN 2^16 ELEMENTS + + +; TYPE<1> TYPE OF FIRST OBJECT (THE RIGHT HALF OF THE TYPE WORD MIGHT BE NONZERO) +; OBJ<1> OBJECT OF SPECIFIED TYPE +; TYPE<2> +; OBJ<2> +; . +; . +; . +; TYPE<N> +; OBJ<N> +; VD(1)-VECTOR DOPE--SIGN-NOT UNIFORM, BITS 1-17 TYPE,,18-35 GROWTH/SHRINKAGE +; VD(2)-VECTOR DOPE--SIGN-G.C.; BITS 1-17 ARE 2*N+1,,18-35 G.C. RELOCATION EITHER UP OR DOWN + + + ;SPECIAL VECTORS IN THE INITIAL SYSTEM + +;THE SYSTEM KEEPS RELEVANT INFORMATION CONCERNING ALL TYPES +;IN A TYPE VECTOR, TYPVEC, WHICH MAY BE INDEXED BY THE TYPE NUMBER +;FOUND IN THE TYPE FIELD OF ANY GOODIE. TABLES APLTYP AND EVLTYP ALSO EXIST +;THEY SPECIFY HOW DIFFERENT TYPES EVAL AND APPLY. + +;TYPE IN AC A, PUSHJ P,SAT RETURNS STORAGE TYPE IN A + +;TYPE TO NAME OF TYPE TRANSLATION TABLE + +; TATOM,,<STORAGE ALLOCATION TYPE>+CHBIT+TMPLBT + +; ATOMIC NAME + +; CHBIT ON MEANS YOU CANT RANDOMLY CHTYPE INTO THIS TYPE +; TMPLBT ON MEANS A TEMPLATE EXISTS DESCRIBING THIS + +;AN ATOM IS A BLOCK IN VECTOR SPACE WITH THE FOLLOWING FORMAT + +; <TUNBOU OR TLOCI>,,<0 OR BINDID> ; TLOCI MEANS VAL EXISTS. + ; 0 MEANS GLOBAL +; ; BINDID SPECS ENV IN + ; WHICH LOCAL VAL EXISTS +; <LOCATIVE TO VALUE OR 0> +; <POINTER TO OBLIST OR 0> +; <ASCII /PNAME/> +; <400000+SATOM,,0> +; <LNTH>,,0 (SIGN BIT FOR G.C. RH FOR G.C. RELOCATION) + +;POINTERS TO INITIAL STRUCTURES AND ATOMS NEEDED BY COMPILED CODE +;WILL BE POINTED TO BY THE TRANSFER VECTOR +;A POINTER TO THIS VECTOR ALWAYS EXISTS IN AC TVP +;THE FORMAT OF THIS VECTOR IS: + +; TYPE,,0 +; VALUE +; . +; . +; . +; TV DOPE WORDS + + +;INFORMATION CONCERNING EACH PROCESS IS KEPT IN THE PROCESS VECTOR +;A POINTER TO THE CURRENT PROCESS ALWAYS EXISTS IN AC PVP +;THE FORMAT OF A PROCESS VECTOR IS: + +; TFIX,,0 +; PROCID ;UNIQUE ID OF THIS PROCESS + +; 20 ELEMENTS (I.E. 40 WORDS) CONTAINIG SAVED ACS +; CAN BE REFERENCED SYMBOLICALLY USING SYMBOLS +; OF THE FORM AC!STO(PVP) + +; OTHER PROCESS LOCAL INFO LIKE LEXICAL STATE, PROCESS STATE,LAST RESUMER +; . +; . +; . +; PV DOPE WORDS + + + + +;FORMAT OF PUSH DOWN STACKS USED AND CONVENTIONS + + IF1 [ +PRINTC /MUDDLE - INSERT FILE FOR ALL PROGRAMS +/ +] + +IF2 [PRINTC /MUDDLE +/ +] +;AC ASSIGNMNETS + +P"=17 ;THE UNMARKED PDL POINTER (USED BY THE OUTSIDE WORLD AND MUDDLE) +R"=16 ;REFERENCE BASE FOR RSUBRS +M"=15 ;CODE BASE FOR RSUBRS +SP"=14 ;SPECIAL PDL (USED BY MUDDLE FOR VARIABLE BINDINGS)(SPECIAL PDL IS PART OF TP) +TP"=13 ;MARKED PDL (USED BY MUDDLE FOR ARGS TO FUNCTIONS + ;AND MARKED TEMPORARIES) +TB"=12 ;MARKED PDL BASE POINTER AND CURRENT FRAME POINTER +AB"=11 ;ARGUMENT PDL BASE (MARKED) + ;AB IS AN AOBJN POINTER TO THE ARGUMENTS +TVP"=7 ;TRANSFER VECTOR POINTER +PVP"=6 ;PROCESS VECTOR POINTER + +;THE FOLLOWING ACS ARE 'SCRATCH' FOR MUDDLE + +A"=1 ; A AND B CONTAIN TYPE AND VALUE UPON FUNCTION RETURNS +B"=2 +C"=3 +D"=4 +E"=5 + +NIL"=0 ;END OF LIST MARKER + +;MACRO TO DEFINE MAIN IF NOT DEFINED + +IF1 [ +DEFINE SYSQ + ITS==1 + IFE <<<.AFNM1>_-24.>-<SIXBIT / T./>>,ITS==0 + IFN ITS,[PRINTC /ITS VERSION +/] + IFE ITS,[PRINTC /TENEX VERSION +/] + + TERMIN + +DEFINE DEFMAI ARG,\D + D==.TYPE ARG + IFE <D-17>,ARG==0 + EXPUNGE D + TERMIN +] + +DEFMAI MAIN +DEFMAI READER + +IF2,EXPUNGE DEFMAI + + ;DEFINE TYPES AND $TYPES AND IF MAIN NOT 0, MAKE THE $TYPE WORDS + + +IFN MAIN,NUMPRI==-1 + +IF1 [ +NUMPRI==-1 ;NUMBER OF PRIMITIVE TYPES + +DEFINE TYPMAK SAT,LIST +IRP A,,[LIST] +NUMPRI==NUMPRI+1 +IRP B,,[A] +T!B==NUMPRI +.GLOBAL $!T!B +IFN MAIN,[$!T!B=[T!B,,0] +] +.ISTOP +TERMIN +IFN MAIN,[ +RMT [ADDTYP SAT,A +]] +TERMIN +TERMIN + +;MACRO TO ADD STUFF TO TYPE VECTOR + +IFN MAIN,[ +DEFINE ADDTYP SAT,TYPE,NAME,CHF,\CH + IFSE [CHF],CH==0 + IFSN [CHF],CH==CHBIT + IFSE [NAME]IN,CH==CHBIT + IFSN [CHF]-1,[ + TATOM,,CH+SAT + IFSN [NAME],[IFSE [NAME]IN,MQUOTE INTERNAL + IFSN [NAME]IN,MQUOTE [NAME] + ] + IFSE [NAME],MQUOTE TYPE + ] + IFSE [CHF]-1,[ + TATOM,,CH+SAT + IMQUOTE [NAME] + ] + TERMIN +] +] +IF2 [IFE MAIN,[DEFINE TYPMAK SAT,LIST + RMT [EXPUN [LIST] +] + TERMIN +] +] + +;DEFINE THE STORAGE ALLOCATION TYPES IN THE WORLD + + +NUMSAT==0 +GENERAL==400000,,0 ;FLAG FOR BEING A GENERAL VECTOR + +IF1 [ +DEFINE PRMACR HACKER + +IRP A,,[1WORD,2WORD,2DEFRD,NWORD,2NWORD,TPSTK,PSTK,ARGS +ABASE,TBASE,FRAME,BYTE,ATOM,LOCID,PVP,CHSTR,ASOC,INFO,STORE +LOCA,LOCD,LOCS,LOCU,LOCV,LOCL,LOCN,GATOM,LOCT] + +HACKER A + +TERMIN +TERMIN + + + +DEFINE DEFINR B + NUMSAT==NUMSAT+1 + S!B==NUMSAT + TERMIN +] + +PRMACR DEFINR + +STMPLT==NUMSAT+1 + +;MACRO FOR SAVING STUFF TO DO LATER + +.GSSET 4 + +DEFINE HERE G00002,G00003 +G00002!G00003!TERMIN + +IF1 [ +DEFINE RMT A +HERE [DEFINE HERE G00002,G00003 +G00002!][A!G00003!TERMIN] +TERMIN +] + + +RMT [EXPUNGE GENERAL,NUMSTA +] + +DEFINE XPUNGR A + EXPUNGE S!A + TERMIN + +IFE MAIN,[ +RMT [PRMACR XPUNGR +] +] + +C.BUF==1 +C.PRIN==2 +C.BIN==4 +C.OPN==10 +C.READ==40 + +; FLAG INDICATING VECTOR FOR GCHACK + +.VECT.==40000 + +; DEFINE SYMBLOS FOR VARIOUS OBLISTS + +SYSTEM==0 ;MAIN SYSTEM OBLIST +ERRORS==1 ;ERROR COMMENT OBLIST +INTRUP==2 ;INERRUPT OBLIST +MUDDLE==3 ;MUDDLE GLOBAL SYMBOLS (ADDRESSES) + +RMT [EXPUNGE SYSTEM,ERRORS,INTRUP +] +; DEFINE SYMBOLS FOR PROCESS STATES + +RUNABL==1 +RESMBL==2 +RUNING==3 +DEAD==4 +BLOCKED==5 + +IFE MAIN,[RMT [EXPUNGE RESMBL,RUNABL,RUNING,DEAD,BLOCKED +] +] ;BUILD THE TYPE CODES AND ADD STUFF TO TYPVEC AND DEFINE $!TYPE) + +IFN MAIN,[RMT [SAVE==. + LOC TYPVLC + ] + ] + + +TYPMAK S1WORD,[[LOSE],FIX,FLOAT,[CHRS,CHARACTER],[ENTRY,IN],[SUBR,,1],[FSUBR,,1]] +TYPMAK S1WORD,[[UNBOUND,,1],[BIND,IN],[ILLEGAL,,1],TIME] +TYPMAK S2WORD,[LIST,FORM,[SEG,SEGMENT],[EXPR,FUNCTION],[FUNARG,CLOSURE]] +TYPMAK SLOCL,[LOCL] +TYPMAK S2WORD,[FALSE] +TYPMAK S2DEFRD,[[DEFER,IN]] +TYPMAK SNWORD,[[UVEC,UVECTOR],[OBLS,OBLIST,-1]] +TYPMAK S2NWORD,[[VEC,VECTOR],[CHAN,CHANNEL,1]] +TYPMAK SLOCV,[LOCV] +TYPMAK S2NWORD,[[TVP,IN],[BVL,IN],[TAG,,1]] +TYPMAK SPVP,[[PVP,PROCESS]] +TYPMAK STPSTK,[[LOCI,IN],[TP,IN],[SP,IN],[LOCS,IN]] +TYPMAK S2WORD,[[MACRO]] +TYPMAK SPSTK,[[PDL,IN]] +TYPMAK SARGS,[[ARGS,TUPLE]] +TYPMAK SABASE,[[AB,IN]] +TYPMAK STBASE,[[TB,IN]] +TYPMAK SFRAME,[FRAME] +TYPMAK SCHSTR,[[CHSTR,STRING]] +TYPMAK SATOM,[ATOM] +TYPMAK SLOCID,[LOCD] +TYPMAK SBYTE,[BYTE] +TYPMAK SFRAME,[[ENV,ENVIRONMENT],[ACT,ACTIVATION,1]] +TYPMAK SASOC,[ASOC] +TYPMAK SLOCU,[LOCU] +TYPMAK SLOCS,[LOCS] +TYPMAK SLOCA,[LOCA] +TYPMAK S1WORD,[[CBLK,IN]] +TYPMAK STMPLT,[[TMPLT,TEMPLATE]] +TYPMAK SLOCT,[LOCT] + ;THE FOLLOWING TYPES (THROUGH CSUBR) CAN PROBABLY BE RECYCLED +TYPMAK S1WORD,[[PC,IN]] +TYPMAK SINFO,[[INFO,IN]] +TYPMAK SATOM,[[BNDS,IN]] +TYPMAK S2NWORD,[[BVLS,IN]] +TYPMAK S1WORD,[[CSUBR,,1]] + +TYPMAK S1WORD,[[WORD]] +TYPMAK S2NWORD,[[RSUBR,,1]] +TYPMAK SNWORD,[CODE] + ;TYPE CLIST CAN PROBABLY BE RECYCLED +TYPMAK S2WORD,[[CLIST,IN]] +TYPMAK S1WORD,[[BITS]] +TYPMAK SSTORE,[STORAGE,PICTURE] +TYPMAK STPSTK,[[SKIP,IN]] +TYPMAK SATOM,[[LINK,,1]] +TYPMAK S2NWORD,[[INTH,IHEADER,1],[HAND,HANDLER,1]] +TYPMAK SLOCN,[[LOCN,LOCAS]] +TYPMAK S2WORD,[DECL] +TYPMAK SATOM,[DISMISS] +TYPMAK S2WORD,[[DCLI,IN]] +TYPMAK S2NWORD,[[ENTER,RSUBR-ENTRY,1]] +TYPMAK S2WORD,[SPLICE] +TYPMAK S1WORD,[[PCODE,PCODE,1],[TYPEW,TYPE-W,1],[TYPEC,TYPE-C,1]] +TYPMAK SGATOM,[[GATOM,IN]] +TYPMAK SFRAME,[[READA,,1]] +TYPMAK STBASE,[[UNWIN,IN]] +TYPMAK S1WORD,[[UBIND,IN]] +IFN MAIN,[RMT [LOC SAVE + ] + ] +IF2,EXPUNGE TYPMAK,DOTYPS + +RMT [EQUALS XP EXPUNGE +IF2,XP STMPLT +] +IF1 [ + +DEFINE EXPUN LIST + IRP A,,[LIST] + IRP B,,[A] + EXPUNGE T!B + .ISTOP + TERMIN + TERMIN + TERMIN +] + + +TYPMSK==17777 +MONMSK==TYPMSK#777777 +SATMSK==777 +CHBIT==1000 +TMPLBT==2000 + +IF1 [ +DEFINE GETYP AC,ADR + LDB AC,[221500,,ADR] + TERMIN + +DEFINE GETYPF AC,ADR + LDB AC,[003700,,ADR] + TERMIN + +DEFINE MONITO + .WRMON==200000 + .RDMON==100000 + .EXMON== 40000 + .GLOBAL .MONWR,.MONRD,.MONEX + RMT [IF2 IFE MAIN, XP .WRMON,.RDMON,.EXMON +] + TERMIN +] + +IFN MAIN,MONITO + +IFE MAIN,[RMT [XP SATMSK,TYPMSK,MONMSK,CHBIT +] +] + ;MUDDLE WIDE GLOBALS + +;DEFINE ENTRIES IN PROCESS VECTOR AS BEING GLOBAL + +IF1 [ +IRP A,,[0,A,B,C,D,E,PVP,TVP,TP,TB,AB,P,PB,SP,M,R] +.GLOBAL A!STO +TERMIN + +.GLOBAL CALER1,FINIS,VECTOP,VECBOT,INTFLG + +;GLOBALS FOR MACROS IN VECTOR AND PAIR SPACE + +.GLOBAL VECLOC,PARLOC,TVBASE,TVLOC,PVLOC,PVBASE,SQUTBL,SQULOC +.GLOBAL PARTOP,CODTOP,HITOP,HIBOT,SPECBIND,LCKINT +.GLOBAL GETWNA,WNA,TFA,TMA,WRONGT,WTYP,WTYP1,WTYP2,WTYP3,CALER,CALER1 +] + + +;STORAGE ALLOCATIN SPECIFICATION GLOBALS + +NSUBRS==600. ; ESTIMATE OF # OF SUBRS IN WOLD +TPLNT"==2000 ;TEMP PDL LENGTHH +GSPLNT==2000 ;INITIAL GLOBAL SP +GCPLNT"==100. ;GARBAGE COLLECTOR'S PDL LENGTH +PVLNT"==100 ;LENGTH OF INITIAL PROCESS VECTOR +TVLNT"==6000 ;MAX TRANSFER VECTOR +ITPLNT"==100 ;TP FOR GC +PLNT"==1000 ;PDL FOR USER PROCESS + +;LOCATIONS OF VARIOUS STORAGE AREAS + +PARBASE"==32000 ;START OF PAIR SPACE +VECBASE"==44000 ;START OF VECTOR SPACE +IFN MAIN,[PARLOC"==PARBASE +VECLOC"==VECBASE +] + +;INITIAL MACROS + +;SYMBLOS ASSOCIATED WITH STACK FRAMES +;TB POINTS TO CURRENT FRAME, THE SYMBOLS BELOW ARE OFFSETS ON TB + +FRAMLN==7 ;LENGTH OF A FRAME +FSAV==-7 ;POINT TO CALLED FUNCTION +OTBSAV==-6 ;POINT TO PREVIOUS FRAME AND CONTAINS TIME +ABSAV==-5 ;ARGUMENT POINTER +SPSAV==-4 ;BINDING POINTER +PSAV==-3 ;SAVED P-STACK +TPSAV==-2 ;TOP OF STACK POINTER +PCSAV==-1 ;PCWORD + +RMT [EXPUNGE FRAMLN +] +IFE MAIN,[RMT [EXPUNGE PCSAV TPSAV SPSAV PSAV ABSAV FSAV OTBSAV +] +] + +;CALL MACRO +; ARGS ARE PUSHED ON THE STACK AS TYPE VALUE PAIRS + +.GLOBAL .MCALL,.ACALL,FINIS,CONTIN,.ECALL,FATINS + +; CALL WITH AN ASSEMBLE TIME KNOWN NUMBER OF ARGUMENTS + +IF1 [ +DEFINE MCALL N,F + .GLOBAL F + IFGE <17-N>,.MCALL N,F + IFL <17-N>,[PRINTC /LOSSAGE AT MCALL - TOO MANY ARGS +/ + .MCALL F + ] + TERMIN + +; CALL WITH RUN TIME KNOWN NUMBER OF ARGS IN AC SPECIFIED BY N + +DEFINE ACALL N,F + .GLOBAL F + .ACALL N,F + TERMIN + +; STANDARD SUBROUTINE RETURN + +; JRST FINIS + +; ARGUMENTS WILL NO LONGER BE ON THE STACK WHEN RETURN HAS HAPPENED +; VALUE SHOULD BE IN A AND B + +;CHECK THAT THE ENTRY POINT WAS CALLED WITH N ARGUMENTS + +DEFINE ENTRY N + IFSN N,,[ + HLRZ A,AB + CAIE A,-2*N + JSP E,GETWNA] +TERMIN + + +; MACROS ASSOCIATED WIT INTERRUPT PROCESSING +;INTERRUPT IF THERE IS A WAITING INTERRUPT + +DEFINE INTGO + SKIPGE INTFLG + JSR LCKINT +TERMIN + +;TO BECOME INTERRUPTABLE + +DEFINE ENABLE + AOSN INTFLG + JSR LCKINT +TERMIN + +;TO BECOME UNITERRUPTABLE + +DEFINE DISABLE + SETZM INTFLG +TERMIN +] + IF1 [ +;MACRO TO BUILD TYPE DISPATCH TABLES EASILY + +DEFINE TBLDIS NAME,DEFAULT,LIST,LNTH + +NAME: + REPEAT LNTH+1,DEFAULT + IRP A,,[LIST] + IRP TYPE,LOCN,[A] + LOC NAME+TYPE + LOCN + .ISTOP + TERMIN + TERMIN + LOC NAME+LNTH+1 +TERMIN + +; DISPATCH FOR NUMPRI GOODIES + +DEFINE DISTBL NAME,DEFAULT,LIST + TBLDIS NAME,DEFAULT,[LIST]NUMPRI + TERMIN + +DEFINE DISTBS NAME,DEFAULT,LIST + TBLDIS NAME,DEFAULT,[LIST]NUMSAT + TERMIN + +] + + +VECFLG==0 +PARFLG==0 + +;MACROS FOR INITIIAL MUDDLE LIST STRUCTURE + +;CHAR STRING MAKER, RETURNS POINTER AND TYPE + +IF1 [ +DEFINE MACHAR NAME,TYPE,VAL,\LNT,WHERE,LAST + TYPE==TCHSTR + VECTGO WHERE + LNT==.LENGTH \NAME!\ + ASCII \NAME!\ + LAST==$." + TCHRS,,0 + $."-WHERE+1,,0 + VAL==LNT,,WHERE + VECRET + +TERMIN +;MACRO TO DEFINE ATOMS + +DEFINE MAKAT NAME,TYAT,VALU,OBLIS,REFER,LOCN,\TVENT,FIRST + FIRST==. + TYAT,,OBLIS + VALU + 0 + ASCII \NAME!\ + 400000+SATOM,,0 + .-FIRST+1,,0 + TVENT==FIRST-.+2,,FIRST + IFSN [LOCN],LOCN==TVENT + ADDTV TATOM,TVENT,REFER + TERMIN + + + + ;MACROS TO SWITCH BACK AND FORTH INTO AND OUT OF VECTOR AND PAIR SPACE +;GENERAL SWITCHER + +DEFINE LOCSET LOCN,RETNAM,NEWLOC,OTHLOC,F1,F2,TOPWRD,\SAVE,SAVEF1,SAVEF2,NEW + + IFE F1,[SAVE==. + LOC NEWLOC + SAVEF2==F2 + IFN F2,OTHLOC==SAVE + F2==0 + DEFINE RETNAM + F1==F1-1 + IFE F1,[NEWLOC==. + F2==SAVEF2 + LOC TOPWRD + NEWLOC + LOC SAVE + ] + TERMIN + ] + + IFN F1,[F1==F1+1 + ] + + IFSN LOCN,,LOCN==. + IFE F1,F1==1 + +TERMIN + + +DEFINE VECTGO LOCN + LOCSET LOCN,VECRET,VECLOC,PARLOC,VECFLG,PARFLG,VECTOP + TERMIN + +DEFINE PARGO LOCN + LOCSET LOCN,PARRET,PARLOC,VECLOC,PARFLG,VECFLG,PARTOP + TERMIN + +DEFINE ADDSQU NAME,\SAVE + SAVE==. + LOC SQULOC + SQUOZE 0,NAME + NAME + SQULOC==. + LOC SAVE + TERMIN + +DEFINE ADDTV TYPE,GOODIE,REFER,\SAVE + SAVE==. + LOC TVLOC + TVOFF==.-TVBASE+1 + TYPE,,REFER + GOODIE + TVLOC==. + LOC SAVE + TERMIN + +;MACRO TO ADD TO PROCESS VECTOR + +DEFINE ADDPV TYPE,GOODIE,OFFS,\SAVE + SAVE==. + LOC PVLOC + PVOFF==.-PVBASE + IFSN OFFS,,OFFS==PVOFF + TYPE,,0 + GOODIE + PVLOC==. + LOC SAVE + TERMIN + + + + + +;MACRO TO DEFINE A FUNCTION ATOM + +DEFINE MFUNCTION NAME,TYPE,PNAME + (TVP) +NAME": + VECTGO DUMMY1 + ADDSQU NAME + IFSE [PNAME],MAKAT NAME,T!TYPE,NAME,SYSTEM,<NAME-1> + IFSN [PNAME],MAKAT [PNAME]T!TYPE,NAME,SYSTEM,<NAME-1> + VECRET + TERMIN + +; VERSION OF MQUOTE WITH IMPURE BIT ON + +DEFINE IMQUOTE ARG,PNAME,OBLIS,\LOCN + (TVP) + + LOCN==.-1 + VECTGO DUMMY1 + IFSE [PNAME],MAKAT [ARG]<400000+TUNBOU>,0,OBLIS,LOCN + + IFSN [PNAME],MAKAT [PNAME]<400000+TUNBOU>,0,OBLIS,LOCN + VECRET + TERMIN + +;MACRO TO DEFINE QUOTED GOODIE + +DEFINE MQUOTE ARG,PNAME,OBLIS,\LOCN + (TVP) + + LOCN==.-1 + VECTGO DUMMY1 + IFSE [PNAME],MAKAT [ARG]TUNBOU,0,OBLIS,LOCN + IFSN [PNAME],MAKAT [PNAME]TUNBOU,0,OBLIS,LOCN + VECRET + TERMIN + + + + +DEFINE CHQUOTE NAME,\LOCN,TYP,VAL + (TVP) + LOCN==.-1 + MACHAR [NAME]TYP,VAL + ADDTV TYP,VAL,LOCN + + TERMIN + + +; SPECIAL ERROR MQUOTE + +DEFINE EQUOTE ARG,PNAME + MQUOTE ARG,[PNAME]ERRORS TERMIN + + +; MACRO DO .CALL UUOS + +DEFINE DOTCAL NM,LIST,\LOCN + .CALL LOCN + RMT [LOCN==. + SETZ + SIXBIT /NM/ + IRP Q,R,[LIST] + IFSN [R][][Q + ] + + IFSE [R][][<SETZ>\<Q> + ] + TERMIN + ] +TERMIN + +; MACRO TO HANDLE FATAL ERRORS + +DEFINE FATAL MSG/ + FATINS [ASCIZ /: FATAL ERROR MSG  +/] + TERMIN +] + +CHRWD==5 + +IFN READER,[ +NCHARS==177 +;CHARACTER TABLE GENERATING MACROS + +DEFINE SETSYM WRDL,BYTL,COD + WRD!WRDL==<WRD!WRDL>&<MSK!BYTL> + WRD!WRDL==<WRD!WRDL>\<<COD&177>_<<4-BYTL>*7+1>> + TERMIN + +DEFINE INIWRD N,INIT + WRD!N==INIT + TERMIN + +DEFINE OUTWRD N + WRD!N + TERMIN + +;MACRO TO KILL THESE SYMBOLS LATER + +DEFINE KILLWD N + EXPUNGE WRD!N + TERMIN +DEFINE SETMSK N + MSK!N==<177_<<4-N>*7+1>>#<-1> + TERMIN + +;MACRO TO KILL MASKS LATER + +DEFINE KILMSK N + EXPUNGE MSK!N + TERMIN + +NWRDS==<NCHARS+CHRWD-1>/CHRWD + +REPEAT CHRWD,SETMSK \.RPCNT + +REPEAT NWRDS,INIWRD \.RPCNT,004020100402 + +DEFINE OUTTBL + REPEAT NWRDS,OUTWRD \.RPCNT + TERMIN + + +;MACRO TO GENERATE THE DUMMIES EASLILIER + +DEFINE INITCH \DUM1,DUM2,DUM3 + + +DEFINE SETCOD COD,LIST + IRP CHAR,,[LIST] + DUM1==CHAR/5 + DUM2==CHAR-DUM1*5 + SETSYM \DUM1,\DUM2,COD + TERMIN + TERMIN + +DEFINE SETCHR COD,LIST + IRPC CHAR,,[LIST] + DUM3=="CHAR + DUM1==DUM3/5 + DUM2==DUM3-DUM1*5 + SETSYM \DUM1,\DUM2,COD + TERMIN + TERMIN + +DEFINE INCRCO OCOD,LIST + IRP CHAR,,[LIST] + DUM1==CHAR/5 + DUM2==CHAR-DUM1*5 + SETSYM \DUM1,\DUM2,\<OCOD+.IRPCN> + TERMIN + TERMIN + +DEFINE INCRCH OCOD,LIST + IRPC CHAR,,[LIST] + DUM3=="CHAR + DUM1==DUM3/5 + DUM2==DUM3-DUM1*5 + SETSYM \DUM1,\DUM2,\<OCOD+.IRPCN> + TERMIN + TERMIN + RMT [EXPUNGE DUM1,DUM2,DUM3 + REPEAT NWRDS,KILLWD \.RPCNT + REPEAT CHRWD,KILMSK \.RPCNT +] + +TERMIN + +INITCH +] + +;REDEFINE END DO ALL THE REMOTES (ON LAST PASS ONLY) + +EQUALS E.END END + +DEFINE END ARG + EQUALS END E.END + CONSTANTS + + IMPURE + VARIABLES + PURE + HERE + .LNKOT + IF2 GEXPUN + CONSTANTS + IMPURE + VARIABLES + CODEND==. + LOC CODTOP + CODEND + LOC CODEND + PURE + CODEND==. + LOC HITOP + CODEND + LOC CODEND + IF2 EXPUNGE PARFLG,VECFLG,CHRWD,NN,NUMPRI,PURITY,EAD,ACD,PUSHED + IF2 EXPUNGE INSTNT,DUMMY1,PRIM,PPLNT,GSPLNT,MEDIAT + END ARG + TERMIN + + +;MACROS TO PRINT VERSIONS OF PROGRAMS DURING ASSEMBLY + +IF1 [ +DEFINE NUMGEN SYM,\REST,N + NN==NN-1 + N==<SYM_-30.>&77 + REST==<SYM_6> + IFN N,IFGE <31-N>,IFGE <N-20>,TOTAL==TOTAL*10.+<N-20> + IFN NN,NUMGEN REST + EXPUNGE N,REST + TERMIN + +DEFINE VERSIO N + PRINTC /VERSION = N +/ + TERMIN +] + +TOTAL==0 +NN==7 + +NUMGEN .FNAM2 + +IF1 [ +RADIX 10. + +VERSIO \TOTAL + +RADIX 8 +PROGVN==TOTAL + + +DEFINE VATOM SYM,\LOCN,TV,A,B + VECTGO + LOCN==. + TFIX,,MUDDLE + PROGVN + 0 + A==<<<<SYM_-30.>&77>+40>_29.> + B==<<SYM_-24.>&77> + IFN B,A==A+<<B+40>_22.> + B==<<SYM_-18.>&77> + IFN B,A==A+<<B+40>_15.> + B==<<SYM_-12.>&77> + IFN B,A==A+<<B+40>_8.> + B==<<SYM_-6.>&77> + IFN B,A==A+<<B+40>_1.> + A + IFN <SYM&77>,<<SYM&77>+40>_29. + 400000+SATOM,, + .-LOCN+1,,0 + TV==LOCN-.+2,,LOCN + ADDTV TATOM,TV,0 + VECRET + TERMIN + +;VATOM .FNAM1 ;"HACK REMOVED FOR EFFICIENCY" + + +;MACRO TO REMMVE SYMBOLS OF THE FORM "GXXXXX" + +DEFINE GEXPUN \SYM + NN==7 + TOTAL==0 + NUMGEN \<SIXBIT /SYM!/> + RADIX 10. + .GSSET 0 + REPEAT TOTAL,XXP + RADIX 8 +TERMIN + +DEFINE XXP \A + EXPUNGE A + TERMIN + + +DEFINE ..LOC NEW,OLD + .LIFS .LPUR"+.LIMPU" + OLD!"==$." + LOC NEW!" + .ELDC + .LIFS -.LPUR" + LOC $." + .ELDC + .LIFS -.LIMPU + LOC $." + .ELDC + TERMIN + + +; PURE - MACRO TO SWITCH LOADING TO PURE CORE. + +DEFINE PURE + IFE PURITY-1, ..LOC .LPUR,.LIMPU + PURITY==0 + TERMIN + +; IMPURE - MACRO TO SWITCH LOADING TO IMPURE CORE. + +DEFINE IMPURE + IFE PURITY, ..LOC .LIMPU,.LPUR + PURITY==1 + TERMIN +] +PURITY==0 + diff --git a/sumex/mudex.mcr030 b/sumex/mudex.mcr030 new file mode 100644 index 0000000..5d0f7b9 --- /dev/null +++ b/sumex/mudex.mcr030 @@ -0,0 +1,311 @@ +TITLE MUDEX -- TENEX DEPENDANT MUDDLE CODE + +RELOCATABLE + +.INSRT MUDDLE > +.INSRT STENEX > + +MFORK==400000 + +MONITS==1 + +.GLOBAL %SSNAM,%RSNAM,%KILLM,%LOGOU,%SLEEP,%VALRE,NOTTY,MSGTYP,TTYOP2 +.GLOBAL %UNAM,%JNAM,%RUNAM,%RJNAM,%GCJOB,%SHWND,%SHFNT,%GETIP,%INFMP +.GLOBAL GCHN,WNDP,FRNP,MESSAG,INITFL,6TOCHS,SGSNAM,MTYO,PGINT,WHOAMI +.GLOBAL %TOPLQ,IBLOCK,TMTNXS,TNXSTR,%HANG,ILLUUO,UUOH,IPCINI,CTIME,BFLOAT +.GLOBAL GCRSET + +GCHN==0 +WRTP==1000,,100000 +GCHI==1000,,GCHN +CRJB==1000,,400001 +FME==1000,,-1 +FLS==1000,, + +CTIME: JOBTM ; get run time in milli secs + MOVE B,A + JSP A,BFLOAT ; Convert to floating + FDVRI B,(1000.0) ; Change to units of seconds + MOVSI A,TFLOAT + POPJ P, + +; SET THE SNAME GLOBALLY + +%SSNAM: POPJ P, + +; READ THE GLOBAL SNAME + +%RSNAM: POPJ P, + +; KILL THE CURRENT JOB + +%KILLM: HALTF + POPJ P, + +; PASS STRING TO SUPERIOR (MONITOR?) + +%VALRE: HALTF + POPJ P, + +; LOGOUT OF SYSTEM (MUST BE "TOP LEVEL") + +%LOGOU: LGOUT + POPJ P, + +; GO TO SLEEP A WHILE + +%SLEEP: IMULI A,33. ; TO MILLI SECS + DISMS + POPJ P, + +; HANG FOR EVER + +%HANG: WAIT + +; READ JNAME + +%RJNAM: POPJ P, + +; READ UNAME + +%RUNAM: POPJ P, + +; HERE TO SEE IF WE ARE A TOP LEVEL JOB + +%TOPLQ: GJINF + SKIPGE D + AOS (P) + POPJ P, + +; GET AN INFERIOR FOR THE GARBAGE COLLECTOR + +%GCJOB: PUSH P,A + MOVEI A,200000 ; GET BITS FOR FORK + CFORK ; MAKE AN IFERIOR FORK + FATAL CANT GET GC FORK + MOVEM A,GCFRK ; SAVE HANDLE + POP P,A ; RESTORE PAGE + PUSHJ P,%GETIP ; GET IT THERE + PUSHJ P,%SHWND + JRST %SHFNT ; AND FRONTIER + +; HERE TO GET A PAGE FOR THE INFERIOR + +%GETIP: POPJ P, + +; HERE TO SHARE WINDOW + +%SHWND: TDZA 0,0 ; FLAG SAYING WINDOW + +; HERE TO SHARE FRONTIER + +%SHFNT: MOVEI 0,1 + PUSH P,A + PUSH P,B + PUSH P,C + MOVEI B,2*FRNP ; FRONTIER (REMEMBER TENEX PAGE SIZE) + SKIPN 0 + MOVEI B,2*WNDP ; NO,WINDOW + HRLI B,MFORK + ASH A,1 ; TIMES 2 + HRL A,GCFRK + MOVSI C,140000 ; READ AND WRITE ACCESS + + PMAP + ADDI A,1 + ADDI B,1 + PMAP + ASH B,9. ; POINT TO PAGE + MOVES (B) ; CLOBBER TOP + MOVES -1(B) ; AND UNDER + POP P,C + POP P,B + POP P,A + POPJ P, + +; HERE TO MAP INFERIOR BACK AND KILL SAME + +%INFMP: PUSH P,C + PUSH P,D + PUSH P,E + ASH A,1 + ASH B,1 + MOVE D,A ; POINT TO PAGES + MOVE E,B ; FOR COPYING + PUSH P,A ; SAVE FOR TOUCHING + MOVS A,GCFRK + MOVSI B,MFORK + MOVSI C,120400 ; READ AND WRITE COPY + +LP1: HRRI A,(E) + HRRI B,(D) + PMAP + ADDI E,1 + AOBJN D,LP1 + +; HERE TO TOUCH PAGES TO INSURE KEEPING THEM (KLUDGE) + + POP P,E ; RESTORE MY FIRST PAGE # + MOVEI A,(E) ; COPY FOR LOOP + ASH A,9. ; TO WORD ADDR + MOVES (A) ; WRITE IT + AOBJN E,.-3 ; FOR ALL PAGES + + MOVE A,GCFRK + KFORK + POP P,E + POP P,D + POP P,C + POPJ P, + +; HACK TO PRINT MESSAGE OF INTEREST TO USER + +MESOUT: MOVSI A,(JFCL) + MOVEM A,MESSAG ; DO ONLY ONCE + MOVEI A,400000 + MOVE B,[1,,ILLUUO] + MOVE C,[40,,UUOH] + SCVEC + SETZ SP, ; HACK TO AVOID LOSSAGE WITH GARBAGE IN SP FIRST TIME + PUSHJ P,GCRSET + PUSHJ P,PGINT ; INITIALIZE PAGE MAP + RESET + PUSHJ P,TTYOP2 + SKIPE NOTTY ; HAVE A TTY? + JRST RESNM ; NO, SKIP THIS STUFF + + MOVEI A,MESBLK + MOVEI B,0 + GTJFN + JRST RESNM + MOVE B,[70000,,200000] + OPENF + JRST RESNM + +MSLP: BIN + MOVE D,B ; SAVE BYTE + GTSTS + TLNE B,1000 + JRST RESNM + EXCH D,A + CAIN A,14 + PBOUT + MOVE A,D + JRST MSLP + +RESNM2: CLOSF + JFCL + +RESNM: +RESNM1: POPJ P, + +MESBLK: 100000,, + 377777,,377777 + -1,,[ASCIZ /DSK/] + -1,,[ASCIZ /VEZZA/] + -1,,[ASCIZ /MUDDLE/] + -1,,[ASCIZ /MESSAG/] + 0 + 0 + 0 + +MUDINT: MOVSI 0,(JFCL) ; CLOBBER MUDDLE INIT SWITCH + MOVEM 0,INITFL + + GJINF ; GET INFO NEEDED + PUSHJ P,TMTNXS ; MAKE A TEMP STRING FOR TENEX INFO (POINTER LEFT IN E) + HRROI A,1(E) ; TNX STRING POINTER + DIRST + FATAL ATTACHED DIR DOES NOT EXIST + MOVEI B,1(E) ; NOW HAVE BOUNDS OF STRING + SUBM P,E ; RELATIVIZE E + PUSHJ P,TNXSTR ; MAKE THE STRING + SUB P,E + PUSH TP,$TATOM + PUSH TP,IMQUOTE SNM + PUSH TP,A + PUSH TP,B + MCALL 2,SETG + PUSH TP,$TCHSTR + PUSH TP,CHQUOTE READ + PUSH TP,$TCHSTR + PUSH TP,CHQUOTE MUDDLE.INIT + MCALL 2,FOPEN + GETYP A,A + CAIE A,TCHAN + POPJ P, + PUSH TP,$TCHAN + PUSH TP,B + MOVEI B,INITSTR ; TELL USER WHAT'S HAPPENING + SKIPE WHOAMI + JRST .+3 + SKIPN NOTTY + PUSHJ P,MSGTYP + MCALL 1,MLOAD + POPJ P, + +TMTNXS: POP P,D ; SAVE RET ADDR + MOVE E,P ; BUILD A STRING SPACE ON PSTACK + MOVEI 0,20. ; USE 20 WORDS (=100 CHARS) + PUSH P,[0] + SOJG 0,.-1 + + JRST (D) + + +TNXSTR: SUBI B,(P) + PUSH P,B + ADDI B,-1(P) + SUBI B,(A) ; WORDS TO B + IMULI B,5 ; TO CHARS + LDB 0,[360600,,A] ; GET BYTE POSITION + IDIVI 0,7 ; TO A REAL BYTE POSITION + MOVNS 0 + ADDI 0,5 + SUBM 0,B ; FINAL LENGTH IN BYTES TO B + PUSH P,B ; SAVE IT + MOVEI A,4(B) ; TO WORDS + IDIVI A,5 + PUSHJ P,IBLOCK ; GET STRING + POP P,A + POP P,C + ADDI C,(P) + MOVE D,B ; COPY POINTER + MOVE 0,(C) ; GET A WORD + MOVEM 0,(D) + ADDI C,1 + AOBJN D,.-3 + + HRLI A,TCHSTR + HRLI B,440700 ; MAKE INTO BYTER + POPJ P, + +IPCINI: JFCL +IFN MONITS,[ + +DEMS: SETZ + SIXBIT /DEMSIG/ + SETZ [SIXBIT /MUDSTA/] +] +INITSTR: ASCIZ /MUDDLE INIT/ + +IMPURE + +GCFRK: 0 + +IFN MONITS,[ +MESSDM: 30,,(SIXBIT /IPC/) + .+1 + SIXBIT /MUDDLESTATIS/ + 1 + 1 +] + +MESSAG: PUSHJ P,MESOUT ; MESSAGE SWITCH + +INITFL: PUSHJ P,MUDINT ; MUDDLE INIT SWITCH + +PURE + +END + diff --git a/sumex/mudsqu.mcr004 b/sumex/mudsqu.mcr004 new file mode 100644 index 0000000..93a8569 --- /dev/null +++ b/sumex/mudsqu.mcr004 @@ -0,0 +1,71 @@ +TITLE SQUOZE TABLE HANDLER FOR MUDDLE + +RELOCATABLE + +.INSRT MUDDLE > + +.GLOBAL SQUPNT,ATOSQ,SQUTOA + +; POINTER TO TABLE FILLED IN BY INITM + +SQUPNT: 0 + +; GIVEN LOCN OF SUBR RET SQUO NAME ARG AND VAL IN E + +ATOSQ: PUSH P,B + PUSH P,A + MOVE A,SQUPNT ; GET TABLE POINTER + MOVE B,[2,,2] + CAMN E,1(A) + JRST ATOSQ1 + ADD A,B + JUMPL A,.-3 +POPABJ: POP P,B + POP P,A + POPJ P, + +ATOSQ1: MOVE E,(A) + AOS -2(P) + JRST POPABJ + +; BINARY SEARCH FOR SQUOZE SYMBOL ARG IN E + +SQUTOA: PUSH P,A + PUSH P,B + PUSH P,C + + MOVE A,SQUPNT ; POINTER TO TABLE + HLRE B,SQUPNT + MOVNS B + HRLI B,(B) ; B IS CURRENT OFFSET + +UP: ASH B,-1 ; HALVE TABLE + AND B,[-2,,-2] ; FORCE DIVIS BY 2 + MOVE C,A ; COPY POINTER + JUMPLE B,LSTHLV ; CANT GET SMALLER + ADD C,B + CAMLE E,(C) ; SKIP IF EITHER FOUND OR IN TOP + MOVE A,C ; POINT TO SECOND HALF + CAMN E,(C) ; SKIP IF NOT FOUND + JRST WON + CAML E,(C) ; SKIP IF IN TOP HALF + JRST UP + HLLZS C ; FIX UP OINTER + SUB A,C + JRST UP + +WON: MOVE E,1(C) ; RET VAL IN E + AOS -3(P) ; SKIP RET +WON1: POP P,C + POP P,B + POP P,A + POPJ P, + +LSTHLV: CAMN E,(C) ; LINEAR SERCH REST + JRST WON + ADD C,[2,,2] + JUMPL C,.-3 + JRST WON1 ; ALL GONE, LOSE + +END + diff --git a/sumex/nfree.mcr032 b/sumex/nfree.mcr032 new file mode 100644 index 0000000..0dad0f6 --- /dev/null +++ b/sumex/nfree.mcr032 @@ -0,0 +1,251 @@ +TITLE MODIFIED AFREE FOR MUDDLE + +RELOCATABLE + +.INSRT MUDDLE > + +.GLOBAL CAFREE,CAFRET,PARNEW,AGC,PARBOT,CODTOP,CAFRE1 +.GLOBAL STOGC,STOSTR,CAFRE,ISTOST,STOLST,SAT,ICONS,BYTDOP +.GLOBAL FLIST,STORIC +MFUNCTION FREEZE,SUBR + + ENTRY 1 + + GETYP A,(AB) ; get type of it + PUSH TP,(AB) ; save a copy + PUSH TP,1(AB) + PUSH P,[0] ; flag for tupel freeze + PUSHJ P,SAT ; to SAT + MOVEI B,0 ; final type + CAIN A,SNWORD ; check valid types + MOVSI B,TUVEC ; use UVECTOR + CAIN A,S2NWOR + MOVSI B,TVEC + CAIN A,SARGS + MOVSI B,TVEC + CAIN A,SCHSTR + MOVSI B,TCHSTR + JUMPE B,WTYP1 + PUSH P,B ; save final type + CAME B,$TCHSTR ; special chars hack + JRST OK.FR + HRR B,(AB) ; fixup count + MOVEM B,(P) + + MOVEI C,(TB) ; point to it + PUSHJ P,BYTDOP ; A==> points to dope word + HRRO B,1(TB) + SUBI A,1(B) ; A==> length of block + TLC B,-1(A) + MOVEM B,1(TB) ; and save + MOVSI 0,TUVEC + MOVEM 0,(TB) + +OK.FR: HLRE A,1(TB) ; get length + MOVNS A + PUSH P,A + ADDI A,2 + PUSHJ P,CAFREE ; get storage + HRLZ B,1(TB) ; set up to BLT + HRRI B,(A) + POP P,C + ADDI C,(A) ; compute end + BLT B,(C) + MOVEI B,(A) + HLL B,1(AB) + POP P,A + JRST FINIS + + +CAFRE: PUSH P,A + HRRZ E,STOLST+1(TVP) + SETZB C,D + PUSHJ P,ICONS ; get list element + PUSH TP,$TLIST ; and save + PUSH TP,B + MOVE A,(P) ; restore length + ADDI A,2 ; 2 more for dope words + PUSHJ P,CAFREE ; get the core and dope words + POP P,B ; restore count + MOVNS B ; build AOBJN pointer + MOVSI B,(B) + HRRI B,(A) + MOVE C,(TP) + MOVEM B,1(C) ; save on list + MOVSI 0,TSTORA ; and type + HLLM 0,(C) + HRRZM C,STOLST+1(TVP) ; and save as new list + SUB TP,[2,,2] + POPJ P, + +CAFRE1: PUSH P,A + ADDI A,2 + PUSHJ P,CAFREE + HRROI B,(A) ; pointer to B + POP P,A ; length back + TLC B,-1(A) + POPJ P, + +CAFREE: IRP AC,,[B,C,D,E] + PUSH P,AC + TERMIN + SKIPG A ; make sure arg is a winner + FATAL BAD CALL TO CAFREE + MOVSI A,(A) ; count to left half for search + MOVEI B,FLIST ; get first pointer + HRRZ C,(B) ; c points to next block +CLOOP: CAMG A,(C) ; skip if not big enough + JRST CONLIS ; found one + MOVEI D,(B) ; save in case fall out + MOVEI B,(C) ; point to new previous + HRRZ C,(C) ; next block + JUMPN C,CLOOP ; go on through loop + HLRZ E,A ; count to E + CAMGE E,STORIC ; skip if a area or more + MOVE E,STORIC ; else use a whole area + MOVE C,PARBOT ; foun out if any funny space + SUB C,CODTOP ; amount around to C + CAMLE C,E ; skip if must GC + JRST CHAVIT ; already have it + SUBI E,-1(C) ; get needed from agc + MOVEM E,PARNEW ; funny arg to AGC + PUSH P,A + MOVE C,[7,,6] ; SET UP AGC INDICATORS + PUSHJ P,AGC ; collect that garbage + SETZM PARNEW ; dont do it again + AOJL A,GCLOS ; couldn't get core + POP P,A + +; Make sure pointers still good after GC + + MOVEI D,FLIST + HRRZ B,(D) + + HRRZ E,(B) ; next pointer + JUMPE E,.+4 ; end of list ok + MOVEI D,(B) + MOVEI B,(E) + JRST .-4 ; look at next + +CHAVIT: MOVE E,PARBOT ; find amount obtained + SUBI E,1 ; dont use a real pair + MOVEI C,(E) ; for reset of CODTOP + SUB E,CODTOP + EXCH C,CODTOP ; store it back + CAIE B,(C) ; did we simply grow the last block? + JRST CSPLIC ; no, splice it in + HLRZ C,(B) ; length of old guy + ADDI C,(E) ; total length + ADDI B,(E) ; point to new last dope word + HRLZM C,(B) ; clobber final length in + HRRM B,(D) ; and splice into free list + MOVEI C,(B) ; reset acs for reentry into loop + MOVEI B,(D) + JRST CLOOP + +; Here to splice new core onto end of list. + +CSPLIC: MOVE C,CODTOP ; point to end of new block + HRLZM E,(C) ; store length of new block in dope words + HRRM C,(D) ; D is old previous, link it up + MOVEI B,(D) ; and reset B for reentry into loop + JRST CLOOP + +; here if an appropriate block is on the list + +CONLIS: HLRZS A ; count back to a rh + HLRZ D,(C) ; length of proposed block to D + CAIN A,(D) ; skip if they are different + JRST CEASY ; just splice it out + MOVEI B,(C) ; point to block to be chopped up + SUBI B,-1(D) ; point to beginning of same + SUBI D,(A) ; amount of block to be left to D + HRLM D,(C) ; and fix up dope words + ADDI B,-1(A) ; point to end of same + HRLZM A,(B) + HRRM B,(B) ; for GC benefit + +CFREET: CAIE A,1 ; if more than 1 + SETZM -1(B) ; make tasteful dope worda + SUBI B,-1(A) + MOVEI A,(B) + IRP AC,,[E,D,C,B] + POP P,AC + TERMIN + POPJ P, + +CEASY: MOVEI D,(C) ; point to block to return + HRRZ C,(C) ; point to next of same + HRRM C,(B) ; smash its previous + MOVEI B,(D) ; point to block with B + HRRM B,(B) ; for GC benefit + JRST CFREET + +GCLOS: PUSH TP,$TATOM + PUSH TP,EQUOTE NO-MORE-STORAGE + JRST CALER1 + +CAFRET: HRROI B,(B) ; prepare to search list + TLC B,-1(A) ; by making an AOBJN pointer + HRRZ C,STOLST+1(TVP) ; start of list + MOVEI D,STOLST+1(TVP) + +CAFRTL: JUMPE C,CPOPJ ; not founc + CAME B,1(C) ; this it? + JRST CAFRT1 + HRRZ C,(C) ; yes splice it out + HRRM C,(D) ; smash it +CPOPJ: POPJ P, ; dont do anything now + +CAFRT1: MOVEI D,(C) + HRRZ C,(C) + JRST CAFRTL + +; Here from GC to collect all unused blocks into free list + +STOGC: SETZB C,E ; zero current length and pointer + MOVE A,CODTOP ; get high end of free space + +STOGCL: CAIG A,STOSTR ; end? + JRST STOGCE ; yes, cleanup and leave + + HLRZ 0,(A) ; get length + ANDI 0,377777 + SKIPGE (A) ; skip if a not used block + JRST STOGC1 ; jump if marked + + JUMPE C,STOGC3 ; jump if no block under construction + ADD C,0 ; else add this length to current + JRST STOGC4 + +STOGC3: MOVEI B,(A) ; save pointer + MOVE C,0 ; init length + +STOGC4: SUB A,0 ; point to next block + JRST STOGCL + +STOGC1: ANDCAM D,(A) ; kill mark bit + JUMPE C,STOGC4 ; if no block under cons, dont fix + HRLM C,(B) ; store total block length + HRRM E,(B) ; next pointer hooked in + MOVEI E,(B) ; new next pointer + MOVEI C,0 + JRST STOGC4 + +STOGCE: JUMPE C,STGCE1 ; jump if no current block + HRLM C,(B) ; smash in count + HRRM E,(B) ; smash in next pointer + MOVEI E,(B) ; and setup E + +STGCE1: HRRZM E,FLIST+1 ; final link up + POPJ P, + +IMPURE + +FLIST: .+1 + ISTOST + +PURE + +END + diff --git a/sumex/pfloat.mcr003 b/sumex/pfloat.mcr003 new file mode 100644 index 0000000..e5f8f47 --- /dev/null +++ b/sumex/pfloat.mcr003 @@ -0,0 +1,149 @@ +TITLE FLOATB--CONVERT FLOATING NUMBER TO ASCII STRING + +RELOCA + +.GLOBAL FLOATB + +ACNUM==1 + +IRP A,,[A,B,C,D,E,F,G,H,I,J] +A==ACNUM +ACNUM==ACNUM+1 +TERMIN + +P==17 + +TEM1==I + +EXPUNGE ACNUM + +FLOATB: PUSH P,B + PUSH P,C + PUSH P,D + PUSH P,F + PUSH P,G + PUSH P,H + PUSH P,I + PUSH P,0 + PUSH P,J + MOVSI 0,440700 ; BUILD BYTEPNTR + HLRZ J,A ; POINT TO BUFFER + HRRI 0,1(J) + MOVE A,(A) ; GET NUMBER + MOVE D,A + SETZM (J) ; Clear counter + PUSHJ P,NFLOT + POP P,J + POP P,0 + POP P,I + POP P,H + POP P,G + POP P,F + POP P,D + POP P,C + POP P,B + POPJ P, + +; at this point we enter code abstracted from DDT. +NFLOT: JUMPG A,TFL1 + JUMPE A,FP1A + MOVNS A + PUSH P,A + MOVEI A,"- + PUSHJ P,CHRO + POP P,A + TLZE A,400000 + JRST FP1A + +TFL1: MOVEI B,0 +TFLX: CAMGE A,FT01 + JRST FP4 + CAML A,FT8 + AOJA B,FP4 +FP1A: +FP3: SETZB C,TEM1 ; CLEAR DIGIT CNTR, C TO RECEIVE FRACTION + MULI A,400 + ASHC B,-243(A) + MOVE A,B + PUSHJ P,FP7 + PUSH P,A + MOVEI A,". + PUSHJ P,CHRO + POP P,A + MOVNI A,10 + ADD A,TEM1 + MOVE E,C +FP3A: MOVE D,E + MULI D,12 + PUSHJ P,FP7B + SKIPE E + AOJL A,FP3A + POPJ P, ; ONE return from OFLT here + +FP4: MOVNI C,6 + MOVEI F,0 +FP4A: ADDI F,1(F) + XCT FCP(B) + SOSA F + FMPR A,@FCP+1(B) + AOJN C,FP4A + PUSH P,EXPSGN(B) + PUSHJ P,FP3 + PUSH P,A + MOVEI A,"E + PUSHJ P,CHRO + POP P,A + POP P,D + PUSHJ P,FDIGIT + MOVE A,F + +FP7: SKIPE A ; AVOID AOSING TEM1, NOT SIGNIFICANT DIGIT + AOS TEM1 + IDIVI A,12 + HRLM B,(P) + JUMPE A,FP7A1 + PUSHJ P,FP7 + +FP7A1: HLRZ D,(P) +FP7B: ADDI D,"0 + +; type digit +FDIGIT: PUSH P,A + MOVE A,D + PUSHJ P,CHRO + POP P,A + POPJ P, + +CHRO: AOS (J) ; COUNT CHAR + IDPB A,0 ; STUFF CHAR + POPJ P, + +; constants + 1.0^32. + 1.0^16. +FT8: 1.0^8 + 1.0^4 + 1.0^2 + 1.0^1 +FT: 1.0^0 + 1.0^-32. + 1.0^-16. + 1.0^-8 + 1.0^-4 + 1.0^-2 +FT01: 1.0^-1 +FT0=FT01+1 + +; instructions +FCP: CAMLE A, FT0(C) + CAMGE A, FT(C) + 0, FT0(C) + +EXPSGN: "- + "+ + + +EXPUNGE A,B,C,D,E,F,G,H,I,J,TEM1,P + +END + \ No newline at end of file diff --git a/sumex/primit.mcr169 b/sumex/primit.mcr169 new file mode 100644 index 0000000..d336a23 --- /dev/null +++ b/sumex/primit.mcr169 @@ -0,0 +1,2909 @@ +TITLE PRIMITIVE FUNCTIONS FOR THE MUDDLE SYSTEM + +RELOCATABLE + +.INSRT MUDDLE > + +.GLOBAL TMA,TFA,CELL,IBLOCK,IBLOK1,ICELL2,VECTOP +.GLOBAL NWORDT,CHARGS,CHFRM,CHLOCI,IFALSE,IPUTP,IGETP,BYTDOP +.GLOBAL OUTRNG,IGETLO,CHFRAM,ISTRUC,TYPVEC,SAT,CHKAB,VAL,CELL2,MONCH,MONCH0 +.GLOBAL RMONCH,RMONC0,LOCQ,LOCQQ,SMON,PURERR,APLQ,NAPT,TYPSEG,NXTLM +.GLOBAL MAKACT,ILLCHO,COMPER,CEMPTY,CIAT,CIEQUA,CILEGQ,CILNQ,CILNT,CIN,CINTH,CIREST +.GLOBAL CISTRU,CSETLO,CIPUT,CIGET,CIGETL,CIMEMQ,CIMEMB,CIMON,CITOP,CIBACK +.GLOBAL IGET,IGETL,IPUT,CIGETP,CIGTPR,CINEQU,IEQUAL,TD.LNT,TD.GET,TD.PUT,TD.PTY +.GLOBAL TMPLNT,ISTRCM + +; BUILD DISPATCH TABLE FOR PRIMITIVE FUNCTIONS USAGE + +PRMTYP: + +REPEAT NUMSAT,[0] ;INITIALIZE TABLE TO ZEROES + +IRP A,,[2WORD,2NWORD,NWORD,ARGS,CHSTR,BYTE] + +LOC PRMTYP+S!A +P!A==.IRPCN+1 +P!A + +TERMIN + +PTMPLT==PBYTE+1 + +; FUDGE FOR STRUCTURE LOCATIVES + +IRP A,,[[LOCL,2WORD],[LOCV,2NWORD],[LOCU,NWORD],[LOCS,CHSTR],[LOCA,ARGS] +[LOCT,TMPLT]] + IRP B,C,[A] + LOC PRMTYP+S!B + P!B==P!C,,0 + P!B + .ISTOP + TERMIN +TERMIN + +LOC PRMTYP+SSTORE ;SPECIAL HACK FOR AFREE STORAGE +PNWORD + +LOC PRMTYP+NUMSAT+1 + +PNUM==PTMPLT+1 + +; MACRO TO BUILD PRIMITIVE DISPATCH TABLES + +DEFINE PRDISP NAME,DEFAULT,LIST + TBLDIS NAME,DEFAULT,[LIST]PNUM + TERMIN + + +; SUBROUTINE TO RETURN PRIMITIVE TYPE AND PRINT ERROR IF ILLEGAL + +PTYPE: GETYP A,(B) ;CALLE D WITH B POINTING TO PAIR + CAIN A,TILLEG ;LOSE IF ILLEGAL + JRST ILLCHOS + + PUSHJ P,SAT ;GET STORAGE ALLOC TYPE + CAIE A,SLOCA + CAIN A,SARGS ;SPECIAL HAIR FOR ARGS + PUSHJ P,CHARGS + CAIN A,SFRAME + PUSHJ P,CHFRM + CAIN A,SLOCID + PUSHJ P,CHLOCI +PTYP1: MOVEI 0,(A) ; ALSO RETURN PRIMTYPE + CAILE A,NUMSAT ; SKIP IF NOT TEMPLATE + SKIPA A,[PTMPLT] + MOVE A,PRMTYP(A) ;GET PRIM TYPE, + POPJ P, + +; COMPILERS CALL TO ABOVE (LESS CHECKING) + +CPTYPE: PUSHJ P,SAT + MOVEI 0,(A) + CAILE A,NUMSAT + SKIPA A,[PTMPLT] + MOVE A,PRMTYP(A) + POPJ P, + + +MFUNCTION SUBSTRUC,SUBR + + ENTRY + JUMPGE AB,TFA ;need at least one arg + CAMGE AB,[-10,,0] ;NO MORE THEN 4 + JRST TMA + MOVE B,AB + PUSHJ P,PTYPE ;get primtype in A + PUSH P,A + JRST @TYTBL(A) + +RESSUB: CAMLE AB,[-2,,0] ;if only one arg skip rest + JRST @COPYTB(A) + HLRZ B,(AB)2 ;GET TYPE + CAIE B,TFIX ;IF FIX OK + JRST WRONGT + MOVE B,(AB)1 ;ptr to object of resting + MOVE C,(AB)3 ;# of times to rest + MOVEI E,(A) + MOVE A,(AB) + PUSHJ P,@MRSTBL(E) + PUSH TP,A ;type + PUSH TP,B ;put rested sturc on stack + JRST ALOCOK + +PRDISP TYTBL,IWTYP1,[[P2WORD,RESSUB],[P2NWORD,RESSUB] +[PNWORD,RESSUB],[PCHSTR,RESSUB]] + +PRDISP MRSTBL,IWTYP1,[[P2WORD,LREST],[P2NWORD,VREST] +[PNWORD,UREST],[PCHSTR,SREST]] + +PRDISP COPYTB,IWTYP1,[[P2WORD,CPYLST],[P2NWORD,CPYVEC] +[PNWORD,CPYUVC],[PCHSTR,CPYSTR]] + +PRDISP ALOCTB,IWTYP1,[[P2WORD,ALLIST],[P2NWORD,ALVEC] +[PNWORD,ALUVEC],[PCHSTR,ALSTR]] + +ALOCFX: MOVE B,(TP) ;missing 3rd arg aloc for "rest" of struc + MOVE C,-1(TP) + MOVE A,(P) + PUSH P,[377777,,-1] + PUSHJ P,@LENTBL(A) ;get length of rested struc + SUB P,[1,,1] + POP P,C + MOVE A,B ;# of elements needed + JRST @ALOCTB(C) + +ALOCOK: CAML AB,[-4,,0] ;exactly 3 args + JRST ALOCFX + HLRZ C,(AB)4 + CAIE C,TFIX ;OK IF TYPE FIX + JRST WRONGT + POP P,C ;C HAS PRIMTYYPE + MOVE A,(AB)5 ;# of elements needed + JRST @ALOCTB(C) ;DO ALLOCATION + + +CPYVEC: HLRE A,(AB)1 ;USE WHEN ONLY ONE ARG + MOVNS A + ASH A,-1 ;# OF ELEMENTS FOR ALLOCATION + PUSH TP,(AB) + PUSH TP,(AB)1 + +ALVEC: PUSH P,A + ASH A,1 + HRLI A,(A) + ADD A,(TP) + CAIL A,-1 ;CHK FOR OUT OF RANGE + JRST OUTRNG + CAMGE AB,[-6,,] ; SKIP IF WE GET VECTOR + JRST ALVEC2 ; USER SUPPLIED VECTOR + MOVE A,(P) + PUSHJ P,IBLOK1 +ALVEC1: MOVE A,(P) ;# OF WORDS TO ALLOCATE + MOVE C,B ; SAVE VECTOR POINTER + ASH A,1 ;TIMES 2 + HRLI A,(A) + ADD A,B ;PTING TO FIRST DOPE WORD -ALLOCATED + CAIL A,-1 + JRST OUTRNG + SUBI A,1 ;ptr to last element of the block + HRL B,(TP) ;bleft-ptr to source , b right -ptr to allocated space + BLT B,(A) + MOVE B,C + POP P,A + SUB TP,[2,,2] + MOVSI A,TVEC + JRST FINIS + +ALVEC2: GETYP 0,6(AB) ; CHECK IT IS A VECTOR + CAIE 0,TVEC + JRST WTYP + HLRE A,7(AB) ; CHECK SIZE + MOVNS A + ASH A,-1 ; # OF ELEMENTS + CAMGE A,(P) ; SKIP IF BIG ENOUGH + JRST OUTRNG + MOVE B,7(AB) ; WINNER, JOIN COMMON CODE + JRST ALVEC1 + +CPYUVC: HLRE A,(AB)1 ;# OF ELEMENTS FOR ALLOCATION + MOVNS A + PUSH TP,(AB) + PUSH TP,1(AB) + +ALUVEC: PUSH P,A + HRLI A,(A) + ADD A,(TP) ;PTING TO DOPE WORD OF ORIG VEC + CAIL A,-1 + JRST OUTRNG + CAMGE AB,[-6,,] ; SKIP IF WE SUPPLY UVECTOR + JRST ALUVE2 + MOVE A,(P) + PUSHJ P,IBLOCK +ALUVE1: MOVE A,(P) ;# of owrds to allocate + HRLI A,(A) + ADD A,B ;LOCATION O FIRST ALLOCATED DOPE WORD + HLR D,(AB)1 ;# OF ELEMENTS IN UVECTOR + MOVNS D + ADD D,(AB)1 ;LOCATION OF FIRST DOPE WORD FOR SOURCE + GETYP E,(D) ;GET UTYPE + CAML AB,[-6,,] ; SKIP IF USER SUPPLIED OUTPUT UVECTOR + HRLM E,(A) ;DUMP UTYPE INTO DOPE WORD OF ALLOC UVEC + CAMGE AB,[-6,,] + CAIN 0,(E) ; 0 HAS USER UVEC UTYPE + JRST .+2 + JRST WRNGUT + CAIL A,-1 + JRST OUTRNG + MOVE C,B ; SAVE POINTER TO FINAL GUY + HRL C,(TP) ;Bleft- ptr to source, Bright-ptr to allocated space + BLT C,-1(A) + POP P,A + MOVSI A,TUVEC + JRST FINIS + +ALUVE2: GETYP 0,6(AB) ; CHECK IT IS A VECTOR + CAIE 0,TUVEC + JRST WTYP + HLRE A,7(AB) ; CHECK SIZE + MOVNS A + CAMGE A,(P) ; SKIP IF BIG ENOUGH + JRST OUTRNG + MOVE B,7(AB) ; WINNER, JOIN COMMON CODE + HLRE A,B + SUBM B,A + GETYP 0,(A) ; GET UTYPE OF USER UVECTOR + JRST ALUVE1 + +CPYSTR: HRR A,(AB) ;#OF CHAR TO COPY + PUSH TP,(AB) ;ALSTR EXPECTS STRING IN TP + PUSH TP,1(AB) + +ALSTR: PUSH P,A + HRRZ 0,-1(TP) ;0 IS LENGTH OFF VECTOR + CAIGE 0,(A) + JRST OUTRNG + CAMGE AB,[-6,,] ; SKIP IF WE SUPPLY STRING + JRST ALSTR2 + ADDI A,4 + IDIVI A,5 + PUSHJ P,IBLOCK ;ALLOCATE SPACE + HRLI B,440700 + MOVE A,(P) ; # OF CHARS TO A +ALSTR1: PUSH P,B ;BYTE PTR TO ALOC SPACE + POP TP,C ;PTR TO ORIGINAL STR + POP TP,D ;USELESS +COPYST: ILDB D,C ;GET NEW CHAR + IDPB D,B ;DEPOSIT CHAR + SOJG A,COPYST ;FINISH TRANSFER? + +CLOSTR: POP P,B ;BYTE PTR TO COPY + POP P,A ;# FO ELEMENTS + HRLI A,TCHSTR + JRST FINIS + +ALSTR2: GETYP 0,6(AB) ; CHECK IT IS A VECTOR + CAIE 0,TCHSTR + JRST WTYP + HRRZ A,6(AB) + CAMGE A,(P) ; SKIP IF BIG ENOUGH + JRST OUTRNG + EXCH A,(P) + MOVE B,7(AB) ; WINNER, JOIN COMMON CODE + JRST ALSTR1 + +CPYLST: SKIPN 1(AB) + JRST ZEROLT + PUSHJ P,CELL2 + POP P,C + HRLI C,TLIST ;TP JUNK FOR GAR. COLLECTOR + PUSH TP,C ;TYPE + PUSH TP,B ;VALUE -PTR TO NEW LIST + PUSH TP,C ;TYPE + MOVE C,1(AB) ;PTR TO FIRST ELEMENT OF ORIG. LIST +REPLST: MOVE D,(C) + MOVE E,1(C) ;GET LIST ELEMENT INTO ALOC SPACE + HLLM D,(B) + MOVEM E,1(B) ;PUT INTO ALLOCATED SPACE + HRRZ C,(C) ;UPDATE PTR + JUMPE C,CLOSWL ;END OF LIST? + PUSH TP,B + PUSHJ P,CELL2 + POP TP,D + HRRM B,(D) ;LINK ALLOCATED LIST CELLS + JRST REPLST + +CLOSWL: POP TP,B ;USELESS + POP TP,B ;PTR TO NEW LIST + POP TP,A ;TYPE + JRST FINIS + + + +ALLIST: CAMGE AB,[-6,,] ; SKIP IF WE BUILD THE LIST + JRST CPYLS2 + JUMPE A,ZEROLT + PUSH P,A + PUSHJ P,CELL + POP P,A ;# OF ELEMENTS + PUSH P,B ;ptr to allocated list + POP TP,C ;ptr to orig list + JRST ENTCOP + +COPYL: ADDI B,2 + HRRM B,-2(B) ;LINK ALOCATED LIST CELLS +ENTCOP: JUMPE C,OUTRNG + MOVE D,(C) + MOVE E,1(C) ;get list element into D+E + HLLM D,(B) + MOVEM E,1(B) ;put into allocated space + HRRZ C,(C) ;update ptrs + SOJG A,COPYL ;finish transfer? + +CLOSEL: POP P,B ;PTR TO NEW LIST + POP TP,A ;type + JRST FINIS + +ZEROLT: SUB TP,[1,,1] ;IF RESTED ALL OF LIST + SUB TP,[1,,1] + MOVSI A,TLIST + MOVEI B,0 + JRST FINIS + +CPYLS2: GETYP 0,6(AB) + CAIE 0,TLIST + JRST WTYP + MOVE B,7(AB) ; GET DEST LIST + MOVE C,(TP) + + JUMPE A,CPYLS3 +CPYLS4: JUMPE B,OUTRNG + JUMPE C,OUTRNG + MOVE D,1(C) + MOVEM D,1(B) + GETYP 0,(C) + HRLM 0,(B) + HRRZ B,(B) + HRRZ C,(C) + SOJG A,CPYLS4 + +CPYLS3: MOVE B,7(AB) + MOVSI A,TLIST + JRST FINIS + + +; PROCESS TYPE ILLEGAL + +ILLCHO: HRRZ B,1(B) ;GET CLOBBERED TYPE + CAIN B,TARGS ;WAS IT ARGS? + JRST ILLAR1 + CAIN B,TFRAME ;A FRAME? + JRST ILFRAM + CAIN B,TLOCD ;A LOCATIVE TO AN ID + JRST ILLOC1 + + LSH B,1 ;NONE OF ABOVE LOOK IN TABLE + ADDI B,TYPVEC+1(TVP) + PUSH TP,$TATOM + PUSH TP,EQUOTE ILLEGAL + PUSH TP,$TATOM + PUSH TP,(B) ;PUSH ATOMIC NAME + MOVEI A,2 + JRST CALER ;GO TO ERROR REPORTER + +; CHECK AN ARGS POINTER + +CHARGS: PUSHJ P,ICHARG ; INTERNAL CHECK + JUMPN B,CPOPJ + +ILLAR1: PUSH TP,$TATOM + PUSH TP,EQUOTE ILLEGAL-ARGUMENT-BLOCK + JRST CALER1 + +ICHARG: PUSH P,A ;SAVE SOME ACS + PUSH P,B + PUSH P,C + SKIPN C,1(B) ;GET POINTER + JRST ILLARG ; ZERO POINTER IS ILLEGAL + HLRE A,C ;FIND ASSOCIATED FRAME + SUBI C,(A) ;C POINTS TO FRAME OR FRAME POINTER + GETYP A,(C) ;GET TYPE OF NEXT GOODIE + CAIN A,TCBLK + JRST CHARG1 + CAIE A,TENTRY ;MUST BE EITHER ENTRY OR TINFO + CAIN A,TINFO + JRST CHARG1 ;WINNER + JRST ILLARG + +CHARG1: CAIN A,TINFO ;POINTER TO FRAME? + ADD C,1(C) ;YES, GET IT + CAIE A,TINFO ;POINTS TO ENTRT? + MOVEI C,FRAMLN(C) ;YES POINT TO END OF FRAME + HLRZ C,OTBSAV(C) ;GET TIME FROM FRAME + HRRZ B,(B) ;AND ARGS TIME + CAIE B,(C) ;SAME? +ILLARG: SETZM -1(P) ; RETURN ZEROED B +POPBCJ: POP P,C + POP P,B + POP P,A + POPJ P, ;GO GET PRIM TYPE + + + +; CHECK A FRAME POINTER + +CHFRM: PUSHJ P,CHFRAM + JUMPN B,CPOPJ + +ILFRAM: PUSH TP,$TATOM + PUSH TP,EQUOTE ILLEGAL-FRAME + JRST CALER1 + +CHFRAM: PUSH P,A ;SAVE SOME REGISTERS + PUSH P,B + PUSH P,C + HRRZ A,(B) ; GE PVP POINTER + HLRZ C,(A) ; GET LNTH + SUBI A,-1(C) ; POINT TO TOP + CAIN A,(PVP) ; SKIP IF NOT THIS PROCESS + MOVEM TP,TPSTO+1(A) ; MAKE CURRENT BE STORED + HRRZ A,TPSTO+1(A) ; GET TP FOR THIS PROC + HRRZ C,1(B) ;GET POINTER PART + CAILE C,1(A) ;STILL WITHIN STACK + JRST BDFR + HLRZ A,FSAV(C) ;CHECK STILL AN ENTRY BLOCK + CAIN A,TCBLK + JRST .+3 + CAIE A,TENTRY + JRST BDFR + HLRZ A,1(B) ;GET TIME FROM POINTER + HLRZ C,OTBSAV(C) ;AND FROM FRAME + CAIE A,(C) ;SAME? +BDFR: SETZM -1(P) ; RETURN 0 IN B + JRST POPBCJ ;YES, WIN + +; CHECK A LOCATIVE TO AN IDENTIFIER + +CHLOCI: PUSHJ P,ICHLOC + JUMPN B,CPOPJ + +ILLOC1: PUSH TP,$TATOM + PUSH TP,EQUOTE ILLEGAL-LOCATIVE + JRST CALER1 + +ICHLOC: PUSH P,A + PUSH P,B + PUSH P,C + + HRRZ A,(B) ;GET TIME FROM POINTER + JUMPE A,POPBCJ ;ZERO, GLOBAL VARIABLE NO TIME + HRRZ C,1(B) ;POINT TO STACK + CAMLE C,VECTOP + JRST ILLOC ;NO + HRRZ C,2(C) ; SHOULD BE DECL,,TIME + CAIE A,(C) +ILLOC: SETZM -1(P) ; RET 0 IN B + JRST POPBCJ + + + + +; PREDICATE TO SEE IF AN OBJECT IS STRUCTURED + +MFUNCTION %STRUC,SUBR,[STRUCTURED?] + + ENTRY 1 + + GETYP A,(AB) ; GET TYPE + PUSHJ P,ISTRUC ; INTERNAL + JRST IFALSE + JRST ITRUTH + + +; PREDICATE TO CHECK THE LEGALITY OF A FRAME/ARGS TUPLE/IDENTIFIER LOCATIVE + +MFUNCTION %LEGAL,SUBR,[LEGAL?] + + ENTRY 1 + + MOVEI B,(AB) ; POINT TO ARG + PUSHJ P,ILEGQ + JRST IFALSE + JRST ITRUTH + +ILEGQ: GETYP A,(B) + CAIN A,TILLEG + POPJ P, + PUSHJ P,SAT ; GET STORG TYPE + CAIN A,SFRAME ; FRAME? + PUSHJ P,CHFRAM + CAIN A,SARGS ; ARG TUPLE + PUSHJ P,ICHARG + CAIN A,SLOCID ; ID LOCATIVE + PUSHJ P,ICHLOC + JUMPE B,CPOPJ + JRST CPOPJ1 + + +; COMPILERS CALL + +CILEGQ: PUSH TP,A + PUSH TP,B + MOVEI B,-1(TP) + PUSHJ P,ILEGQ + TDZA 0,0 + MOVEI 0,1 + SUB TP,[2,,2] + JUMPE 0,NO + +YES: MOVSI A,TATOM + MOVE B,MQUOTE T + JRST CPOPJ1 + +NOM: SUBM M,(P) +NO: MOVSI A,TFALSE + MOVEI B,0 + POPJ P, + +YESM: SUBM M,(P) + JRST YES + ;SUBRS TO DEFINE, GET, AND PUT BIT FIELDS + +MFUNCTION BITS,SUBR + ENTRY + JUMPGE AB,TFA ;AT LEAST ONE ARG ? + GETYP A,(AB) + CAIE A,TFIX + JRST WTYP1 + SKIPLE C,(AB)+1 ;GET FIRST AND CHECK TO SEE IF POSITIVE + CAILE C,44 ;CHECK IF FIELD NOT GREATER THAN WORD SIZE + JRST OUTRNG + MOVEI B,0 + CAML AB,[-2,,0] ;ONLY ONE ARG ? + JRST ONEF ;YES + CAMGE AB,[-4,,0] ;MORE THAN TWO ARGS ? + JRST TMA ;YES, LOSE + GETYP A,(AB)+2 + CAIE A,TFIX + JRST WTYP2 + SKIPGE B,(AB)+3 ;GET SECOND ARG AND CHECK TO SEE IF NON-NEGATIVE + JRST OUTRNG + ADD C,(AB)+3 ;CALCULATE LEFTMOST EXTENT OF THE FIELD + CAILE C,44 ;SHOULD BE LESS THAN WORD SIZE + JRST OUTRNG + LSH B,6 +ONEF: ADD B,(AB)+1 + LSH B,30 ;FORM BYTE POINTER'S LEFT HALF + MOVSI A,TBITS + JRST FINIS + + + +MFUNCTION GETBITS,SUBR + ENTRY 2 + GETYP A,(AB) + PUSHJ P,SAT + CAIN A,SSTORE + JRST .+3 + CAIE A,S1WORD + JRST WTYP1 + GETYP A,(AB)+2 + CAIE A,TBITS + JRST WTYP2 + MOVEI A,(AB)+1 ;GET ADDRESS OF THE WORD + HLL A,(AB)+3 ;GET LEFT HALF OF BYTE POINTER + LDB B,A + MOVSI A,TWORD ; ALWAYS RETURN WORD____ + JRST FINIS + + +MFUNCTION PUTBITS,SUBR + ENTRY + CAML AB,[-2,,0] ;AT LEAST TWO ARGS ? + JRST TFA ;NO, LOSE + GETYP A,(AB) + PUSHJ P,SAT + CAIE A,S1WORD + JRST WTYP1 + GETYP A,(AB)+2 + CAIE A,TBITS + JRST WTYP2 + MOVEI B,0 ;EMPTY THIRD ARG DEFAULT + CAML AB,[-4,,0] ;ONLY TWO ARGS ? + JRST TWOF + CAMGE AB,[-6,,0] ;MORE THAN THREE ARGS ? + JRST TMA ;YES, LOSE + GETYP A,(AB)+4 + PUSHJ P,SAT + CAIE A,S1WORD + JRST WTYP3 + MOVE B,(AB)+5 +TWOF: MOVEI A,(AB)+1 ;ADDRESS OF THE TARGET WORD + HLL A,(AB)+3 ;GET THE LEFT HALF OF THE BYTE POINTER + DPB B,A + MOVE B,(AB)+1 + MOVE A,(AB) ;SAME TYPE AS FIRST ARG'S + JRST FINIS + + +; FUNCTION TO GET THE LENGTH OF LISTS,VECTORS AND CHAR STRINGS + +MFUNCTION LNTHQ,SUBR,[LENGTH?] + + ENTRY 2 + GETYP A,(AB)2 + CAIE A,TFIX + JRST WTYP2 + PUSH P,(AB)3 + JRST LNTHER + + +MFUNCTION LENGTH,SUBR + + ENTRY 1 + PUSH P,[377777777777] +LNTHER: MOVE B,AB ;POINT TO ARGS + PUSHJ P,PTYPE ;GET ITS PRIM TYPE + MOVE B,1(AB) + MOVE C,(AB) + PUSHJ P,@LENTBL(A) ; CALL RIGTH ONE + JRST LFINIS ;OTHERWISE USE 0 + +PRDISP LENTBL,IWTYP1,[[P2WORD,LNLST],[P2NWORD,LNVEC],[PNWORD,LNUVEC] +[PARGS,LNVEC],[PCHSTR,LNCHAR],[PTMPLT,LNTMPL]] + +LNLST: SKIPN C,B ; EMPTY? + JRST LNLST2 ; YUP, LEAVE + MOVEI B,1 ; INIT COUNTER + MOVSI A,TLIST ;WILL BECOME INTERRUPTABLE + HLLM A,CSTO(PVP) ;AND C WILL BE A LIST POINTER +LNLST1: INTGO ;IN CASE CIRCULAR LIST + CAMLE B,(P)-1 + JRST LNLST2 + HRRZ C,(C) ;STEP + JUMPE C,.+2 ;DONE, RETRUN LENGTH + AOJA B,LNLST1 ;COUNT AND GO +LNLST2: SETZM CSTO(PVP) + POPJ P, + +LFINIS: POP P,C + CAMLE B,C + JRST IFALSE + MOVSI A,TFIX ;LENGTH IS AN INTEGER + JRST FINIS + +LNVEC: ASH B,-1 ;GENERAL VECTOR DIVIDE BY 2 +LNUVEC: HLRES B ;GET LENGTH + MOVMS B ;MAKE POS + POPJ P, + +LNCHAR: HRRZ B,C ; GET COUNT + POPJ P, + +LNTMPL: GETYP A,(B) ; GET REAL SAT + SUBI A,NUMSAT+1 + HRLS A ; READY TO HIT TABLE + ADD A,TD.LNT+1(TVP) + JUMPGE A,BADTPL + MOVE C,B ; DATUM TO C + XCT (A) ; GET LENGTH + HLRZS C ; REST COUNTER + SUBI B,(C) ; FLUSH IT OFF + MOVEI B,(B) ; IN CASE FUNNY STUFF + MOVSI A,TFIX + POPJ P, + +; COMPILERS ENTRIES + +CILNT: SUBM M,(P) + PUSH P,[377777,,-1] + MOVE C,A + GETYP A,A + PUSHJ P,CPTYPE ; GET PRIMTYPE + JUMPE A,COMPERR + PUSHJ P,@LENTBL(A) ; DISPATCH + MOVSI A,TFIX + SUB P,[1,,1] +MPOPJ: SUBM M,(P) + POPJ P, + +CILNQ: SUBM M,(P) + PUSH P,C + MOVE C,A + GETYP A,A + PUSHJ P,CPTYPE + JUMPE A,COMPERR + PUSHJ P,@LENTBL(A) + POP P,C + SUBM M,(P) + MOVSI A,TFIX + CAMG B,C + JRST CPOPJ1 + MOVSI A,TFALSE + MOVEI B,0 + POPJ P, + + + +IDNT1: MOVE A,(AB) ;RETURN THE FIRST ARG + MOVE B,1(AB) + JRST FINIS + +MFUNCTION QUOTE,FSUBR + + ENTRY 1 + + GETYP A,(AB) + CAIE A,TLIST ;ARG MUST BE A LIST + JRST WTYP1 + SKIPN B,1(AB) ;SHOULD HAVE A BODY + JRST TFA + + HLLZ A,(B) ; GET IT + MOVE B,1(B) + JSP E,CHKAB + JRST FINIS + +MFUNCTION NEQ,SUBR,[N==?] + + MOVEI D,1 + JRST EQR + +MFUNCTION EQ,SUBR,[==?] + + MOVEI D,0 +EQR: ENTRY 2 + + GETYP A,(AB) ;GET 1ST TYPE + GETYP C,2(AB) ;AND 2D TYPE + MOVE B,1(AB) + CAIN A,(C) ;CHECK IT + CAME B,3(AB) + JRST @TABLE2(D) + JRST @TABLE1(D) + +ITRUTH: MOVSI A,TATOM ;RETURN TRUTH + MOVE B,MQUOTE T + JRST FINIS + +IFALSE: MOVSI A,TFALSE ;RETURN FALSE + MOVEI B,0 + JRST FINIS + +TABLE1: ITRUTH +TABLE2: IFALSE + ITRUTH + + + + +MFUNCTION EMPTY,SUBR,EMPTY? + + ENTRY 1 + + MOVE B,AB + PUSHJ P,PTYPE ;GET PRIMITIVE TYPE + + MOVEI A,(A) + JUMPE A,WTYP1 + SKIPN B,1(AB) ;GET THE ARG + JRST ITRUTH + + CAIN A,PTMPLT ; TEMPLATE? + JRST EMPTPL + CAIE A,P2WORD ;A LIST? + JRST EMPT1 ;NO VECTOR OR CHSTR + JUMPE B,ITRUTH ;0 POINTER MEANS EMPTY LIST + JRST IFALSE + + +EMPT1: CAIE A,PCHSTR ;CHAR STRING? + JRST EMPT2 ;NO, VECTOR + HRRZ B,(AB) ; GET COUNT + JUMPE B,ITRUTH ;0 STRING WINS + JRST IFALSE + +EMPT2: JUMPGE B,ITRUTH + JRST IFALSE + +EMPTPL: PUSHJ P,LNTMPL ; GET LENGTH + JUMPE B,ITRUTH + JRST IFALSE + +; COMPILER'S ENTRY TO EMPTY + +CEMPTY: PUSH P,A + GETYP A,A + PUSHJ P,CPTYPE + POP P,0 + JUMPE A,COMPERR + JUMPE B,YES ; ALWAYS EMPTY + CAIN A,PTMPLT + JRST CEMPTP + CAIN A,P2WORD + JRST NO + CAIN A,PCHSTR + JRST .+3 + JUMPGE B,YES + JRST NO + TRNE 0,-1 ; STRING, SKIP ON ZERO LENGTH FIELD + JRST NO + JRST YES + +CEMPTP: PUSHJ P,LNTMPL + JUMPE B,YES + JRST NO + +MFUNCTION NEQUAL,SUBR,[N=?] + PUSH P,[1] + JRST EQUALR + +MFUNCTION EQUAL,SUBR,[=?] + PUSH P,[0] +EQUALR: ENTRY 2 + + MOVE C,AB ;SET UP TO CALL INTERNAL + MOVE D,AB + ADD D,[2,,2] ;C POINTS TO FIRS, D TO SECOND + PUSHJ P,IEQUAL ;CALL INTERNAL + JRST EQFALS ;NO SKIP MEANS LOSE + JRST EQTRUE +EQFALS: POP P,C + JRST @TABLE2(C) +EQTRUE: POP P,C + JRST @TABLE1(C) + + +; COMPILER'S ENTRY TO =? AND N=? + +CINEQU: PUSH P,[0] + JRST .+2 + +CIEQUA: PUSH P,[1] + PUSH TP,A + PUSH TP,B + PUSH TP,C + PUSH TP,D + MOVEI C,-3(TP) + MOVEI D,-1(TP) + SUBM M,-1(P) ; MAY BECOME INTERRUPTABLE + PUSHJ P,IEQUAL + JRST NOE + POP P,C + SUB TP,[4,,4] ; FLUSH TEMPS + JRST @CTAB1(C) + +NOE: POP P,C + SUB TP,[4,,4] + JRST @CTAB2(C) + +CTAB1: NOM +CTAB2: YESM + NOM + +; INTERNAL EQUAL SUBROUTINE + +IEQUAL: MOVE B,C ;NOW CHECK THE ARGS + PUSHJ P,PTYPE + MOVE B,D + PUSHJ P,PTYPE + GETYP 0,(C) ;NOW CHECK FOR EQ + GETYP B,(D) + MOVE E,1(C) + CAIN 0,(B) ;DONT SKIP IF POSSIBLE WINNER + CAME E,1(D) ;DEFINITE WINNER, SKIP + JRST IEQ1 +CPOPJ1: AOS (P) ;EQ, SKIP RETURN + POPJ P, + + +IEQ1: CAIE 0,(B) ;SKIP IF POSSIBLE MATCH +CPOPJ: POPJ P, ;NOT POSSIBLE WINNERS + JRST @EQTBL(A) ;DISPATCH + +PRDISP EQTBL,CPOPJ,[[P2WORD,EQLIST],[P2NWORD,EQVEC],[PNWORD,EQUVEC] +[PARGS,EQVEC],[PCHSTR,EQCHST],[PTMPLT,EQTMPL]] + + +EQLIST: PUSHJ P,PUSHCD ;PUT ARGS ON STACK + +EQLST1: INTGO ;IN CASE OF CIRCULAR + HRRZ C,-2(TP) ;GET FIRST + HRRZ D,(TP) ;AND 2D + CAIN C,(D) ;EQUAL? + JRST EQLST2 ;YES, LEAVE + JUMPE C,EQLST3 ;NIL LOSES + JUMPE D,EQLST3 + GETYP 0,(C) ;CHECK DEFERMENT + CAIN 0,TDEFER + HRRZ C,1(C) ;PICK UP POINTED TO CROCK + GETYP 0,(D) + CAIN 0,TDEFER + HRRZ D,1(D) ;POINT TO REAL GOODIE + PUSHJ P,IEQUAL ;CHECK THE CARS + JRST EQLST3 ;LOSE + HRRZ C,@-2(TP) ;CDR THE LISTS + HRRZ D,@(TP + HRRZM C,-2(TP) ;AND STORE + HRRZM D,(TP) + JRST EQLST1 + +EQLST2: AOS (P) ;SKIP RETRUN +EQLST3: SUB TP,[4,,4] ;REMOVE CRUFT + POPJ P, + +; HERE FOR HACKING TEMPLATE STRUCTURES + +EQTMPL: PUSHJ P,PUSHCD ; SAVE GOODIES + PUSHJ P,PUSHCD + MOVE C,1(C) ; CHECK REAL SATS + GETYP C,(C) + MOVE D,1(D) + GETYP 0,(D) + CAIE 0,(C) ; SKIP IF WINNERS + JRST EQTMP4 + PUSH P,0 ; SAVE MAGIC OFFSET + MOVE B,-2(TP) + PUSHJ P,TM.LN1 ; RET LENGTH IN B + MOVEI B,-1(B) ; FLUSH FUNNY + HLRZ C,-2(TP) + SUBI B,(C) + PUSH P,B + MOVE C,(TP) ; POINTER TO OTHER GUY + ADD A,TD.LNT+1(TVP) + XCT (A) ; OTHER LENGTH TO B + HLRZ 0,B ; REST OFFSETTER + PUSH P,0 + MOVEI B,-1(B) + HLRZ C,(TP) + SUBI B,(C) + CAME B,-1(P) + JRST EQTMP1 + +EQTMP2: AOS C,(P) + SOSGE -1(P) + JRST EQTMP3 ; WIN!! + + MOVE B,-6(TP) ; POINTER + MOVE 0,-2(P) ; GET MAGIC OFFSET + PUSHJ P,TM.TOE ; GET OFFSET TO TEMPLATE + ADD A,TD.GET+1(TVP) + MOVE A,(A) + ADDI E,(A) + XCT (E) ; VAL TO A AND B + MOVEM A,-3(TP) + MOVEM B,-2(TP) + MOVE C,(P) + MOVE B,-4(TP) ; OTHER GUY + MOVE 0,-2(P) + PUSHJ P,TM.TOE + ADD A,TD.GET+1(TVP) + MOVE A,(A) + ADDI E,(A) + XCT (E) ; GET OTHER VALUE + MOVEM A,-1(TP) + MOVEM B,(TP) + MOVEI C,-3(TP) + MOVEI D,-1(TP) + PUSHJ P,IEQUAL ; RECURSE + JRST EQTMP1 ; LOSER + JRST EQTMP2 ; WINNER + +EQTMP3: AOS -3(P) ; WIN RETURN +EQTMP1: SUB P,[3,,3] ; FLUSH JUNK +EQTMP4: SUB TP,[10,,10] + POPJ P, + + + +EQVEC: HLRE A,1(C) ;GET LENGTHS + HLRZ B,1(D) + CAIE B,(A) ;SKIP IF EQUAL LENGTHS + POPJ P, ;LOSE + JUMPGE A,CPOPJ1 ;SKIP RETRUN WIN + PUSHJ P,PUSHCD ;SAVE ARGS + +EQVEC1: INTGO ;IN CASE LONG VECTOR + MOVE C,(TP) + MOVE D,-2(TP) ;ARGS TO C AND D + PUSHJ P,IEQUAL + JRST EQLST3 + MOVE C,[2,,2] ;GET BUMPER + ADDM C,(TP) + ADDB C,-2(TP) ;BUMP BOTH POINTERS + JUMPL C,EQVEC1 + JRST EQLST2 + +EQUVEC: HLRE A,1(C) ;GET LENGTHS + HLRZ B,1(D) + CAIE B,(A) ;SKIP IF EQUAL + POPJ P, + + HRRZ B,1(C) ;START COMPUTING DOPE WORD LOCN + SUB B,A ;B POINTS TO DOPE WORD + GETYP 0,(B) ;GET UNIFORM TYPE + HRRZ B,1(D) ;NOW FIND OTHER DOPE WORD + SUB B,A + HLRZ B,(B) ;OTHER UNIFORM TYPE + CAIE 0,(B) ;TYPES THE SAME? + POPJ P, ;NO, LOSE + + JUMPGE A,CPOPJ1 ;IF ZERO LENGTH ALREADY WON + + HRLZI B,(B) ;TYPE TO LH + PUSH P,B ;AND SAVED + PUSHJ P,PUSHCD ;SAVE ARGS + +EQUV1: MOVEI C,1(TP) ;POINT TO WHERE WILL GO + PUSH TP,(P) + MOVE A,-3(TP) ;PUSH ONE OF THE VECTORS + PUSH TP,(A) ; PUSH ELEMENT + MOVEI D,1(TP) ;POINT TO 2D ARG + PUSH TP,(P) + MOVE A,-3(TP) ;AND PUSH ITS POINTER + PUSH TP,(A) + PUSHJ P,IEQUAL + JRST UNEQUV + + SUB TP,[4,,4] ;POP TP + MOVE A,[1,,1] + ADDM A,(TP) ;BUMP POINTERS + ADDB A,-2(TP) + JUMPL A,EQUV1 ;JUMP IF STILL MORE STUFF + SUB P,[1,,1] ;POP OFF TYPE + JRST EQLST2 + +UNEQUV: SUB P,[1,,1] + SUB TP,[10,,10] + POPJ P, + + + +EQCHST: HRRZ B,(C) ; GET LENGTHS + HRRZ A,(D) + CAIE A,(B) ;SAME + JRST EQCHS3 ;NO, LOSE + MOVE C,1(C) + MOVE D,1(D) + JUMPE A,EQCHS4 ;BOTH 0 LENGTH, WINS + +EQCHS2: + ILDB 0,C ;GET NEXT CHARS + ILDB E,D + CAIE 0,(E) ; SKIP IF STILL WINNING + JRST EQCHS3 ; NOT = + SOJG A,EQCHS2 + +EQCHS4: AOS (P) +EQCHS3: POPJ P, + +PUSHCD: PUSH TP,(C) + PUSH TP,1(C) + PUSH TP,(D) + PUSH TP,1(D) + POPJ P, + + +; REST/NTH/AT/PUT/GET + +; ARG CHECKER + +ARGS1: MOVE E,[JRST WTYP2] ; ERROR CONDITION FOR 2D ARG NOT FIXED +ARGS2: HLRE 0,AB ; CHECK NO. OF ARGS + ASH 0,-1 ; TO - NO. OF ARGS + AOJG 0,TFA ; 0--TOO FEW + AOJL 0,TMA ; MORE THAT 2-- TOO MANY + MOVEI C,1 ; DEFAULT ARG2 + JUMPN 0,ARGS4 ; GET STRUCTURED ARG +ARGS3: GETYP A,2(AB) + CAIE A,TFIX ; SHOULD BE FIXED NUMBER + XCT E ; DO ERROR THING + SKIPGE C,3(AB) ; BETTER BE NON-NEGATIVE + JRST OUTRNG +ARGS4: MOVEI B,(AB) ; POINT TO STRUCTURED POINTER + PUSHJ P,PTYPE ; GET PRIM TYPE + MOVEI E,(A) ; DISPATCH CODE TO E + MOVE A,(AB) ; GET ARG 1 + MOVE B,1(AB) + POPJ P, + +; REST + +MFUNCTION REST,SUBR + + ENTRY + PUSHJ P,ARGS1 ; GET AND CHECK ARGS + PUSHJ P,@RESTBL(E) ; DO IT BASED ON TYPE + MOVE C,A ; THE FOLLOWING IS TO MAKE STORAGE WORK + GETYP A,(AB) + PUSHJ P,SAT + CAIN A,SSTORE ; SKIP IF NOT STORAGE + MOVSI C,TSTORA ; USE ITS PRIMTYPE + MOVE A,C + JRST FINIS + +PRDISP RESTBL,IWTYP1,[[P2WORD,LREST],[PNWORD,UREST],[P2NWOR,VREST],[PARGS,AREST] +[PCHSTR,SREST],[PTMPLT,TMPRST]] + +; AT + +MFUNCTION AT,SUBR + + ENTRY + PUSHJ P,ARGS1 + SOJL C,OUTRNG + PUSHJ P,@ATTBL(E) + JRST FINIS + +PRDISP ATTBL,IWTYP1,[[P2WORD,LAT],[PNWORD,UAT],[P2NWORD,VAT],[PARGS,AAT] +[PCHSTR,STAT],[PTMPLT,TAT]] + + +; NTH + +MFUNCTION NTH,SUBR + + ENTRY + + PUSHJ P,ARGS1 + SOJL C,OUTRNG + PUSHJ P,@NTHTBL(E) + JRST FINIS + +PRDISP NTHTBL,IWTYP1,[[P2WORD,LNTH],[PNWORD,UNTH],[P2NWOR,VNTH],[PARGS,ANTH] +[PCHSTR,SNTH],[PTMPLT,TMPLNT]] + +; GET + +MFUNCTION GET,SUBR + + ENTRY + MOVE E,IIGETP ; MAKE ARG CHECKER FAIL INTO GETPROP + PUSHJ P,ARGS5 ; CHECK ARGS + SOJL C,OUTRNG + SKIPN E,IGETBL(E) ; GET DISPATCH ADR + JRST IGETP ; REALLY PUTPROP + JUMPE 0,TMA + PUSHJ P,(E) ; DISPATCH + JRST FINIS + +PRDISP IGETBL,0,[[P2WORD,LNTH],[PNWORD,UNTH],[P2NWORD,VNTH],[PARGS,ANTH] +[PCHSTR,SNTH],[PTMPLT,TMPLNT]] + +; GETL + +MFUNCTION GETL,SUBR + + ENTRY + MOVE E,IIGETL ; ERROR HACK + PUSHJ P,ARGS5 + SOJL C,OUTRNG ; LOSER + SKIPN E,IGTLTB(E) + JRST IGETLO ; REALLY GETPL + JUMPE 0,TMA + PUSHJ P,(E) ; DISPATCH + JRST FINIS + +IIGETL: JRST IGETLO + +PRDISP IGTLTB,0,[[P2WORD,LAT],[PNWORD,UAT],[P2NWORD,VAT],[PARGS,AAT] +[PCHSTR,STAT]] + + +; ARG CHECKER FOR PUT/GET/GETL + +ARGS5: HLRE 0,AB ; -# OF ARGS + ASH 0,-1 + ADDI 0,2 ; 0 OR -1 WIN + JUMPG 0,TFA + AOJL 0,TMA ; MORE THAN 3 + JRST ARGS3 ; GET ARGS + +; PUT + +MFUNCTION PUT,SUBR + + ENTRY + MOVE E,IIPUTP + PUSHJ P,ARGS5 ; GET ARGS + SKIPN E,IPUTBL(E) + JRST IPUTP + CAML AB,[-5,,] ; SKIP IF GOOD ARRGS + JRST TFA + SOJL C,OUTRNG + PUSH TP,4(AB) + PUSH TP,5(AB) + PUSHJ P,(E) + MOVE A,(AB) ; RET STRUCTURE + MOVE B,1(AB) + JRST FINIS + +PRDISP IPUTBL,0,[[P2WORD,LPUT],[PNWORD,UPUT],[P2NWORD,VPUT],[PARGS,APUT] +[PCHSTR,SPUT],[PTMPLT,TMPPUT]] + +; IN + +MFUNCTION IN,SUBR + + ENTRY 1 + + MOVEI B,(AB) ; POINT TO ARG + PUSHJ P,PTYPE + MOVS E,A ; REAL DISPATCH TO E + MOVE B,1(AB) + MOVE A,(AB) + GETYP C,A ; IN CASE NEEDED + PUSHJ P,@INTBL(E) + JRST FINIS + +PRDISP INTBL,OTHIN,[[P2WORD,LNTH1],[PNWORD,UIN],[P2NWORD,VIN],[PARGS,AIN] +[PCHSTR,SIN],[PTMPLT,TIN]] + +OTHIN: CAIE C,TLOCN ; ASSOCIATION LOCATIVE + JRST OTHIN1 ; MAYBE LOCD + HLLZ 0,VAL(B) + PUSHJ P,RMONCH + MOVE A,VAL(B) + MOVE B,VAL+1(B) + POPJ P, + +OTHIN1: CAIE C,TLOCD + JRST WTYP1 + JRST VIN + + +; SETLOC + +MFUNCTION SETLOC,SUBR + + ENTRY 2 + + MOVEI B,(AB) ; POINT TO ARG + PUSHJ P,PTYPE ; DO TYPE + MOVS E,A ; REAL TYPE + MOVE B,1(AB) + MOVE C,2(AB) ; PASS ARG + MOVE D,3(AB) + MOVE A,(AB) ; IN CASE + GETYP 0,A + PUSHJ P,@SETTBL(E) + MOVE A,2(AB) + MOVE B,3(AB) + JRST FINIS + +PRDISP SETTBL,OTHSET,[[P2WORD,LSTUF],[PNWORD,USTUF],[P2NWORD,VSTUF],[PARGS,ASTUF] +[PCHSTR,SSTUF],[PTMPLT,TSTUF]] + +OTHSET: CAIE 0,TLOCN ; ASSOC? + JRST OTHSE1 + HLLZ 0,VAL(B) ; GET MONITORS + PUSHJ P,MONCH + MOVEM C,VAL(B) + MOVEM D,VAL+1(B) + POPJ P, + +OTHSE1: CAIE 0,TLOCD + JRST WTYP1 + JRST VSTUF + +; LREST -- REST A LIST IN B BY AMOUNT IN C + +LREST: MOVSI A,TLIST + JUMPE C,CPOPJ + MOVEM A,BSTO(PVP) + +LREST2: INTGO ;CHECK INTERRUPTS + JUMPE B,OUTRNG ; CANT CDR NIL + HRRZ B,(B) ;CDR THE LIST + SOJG C,LREST2 ;COUNT DOWN + SETZM BSTO(PVP) ;RESET BSTO + POPJ P, + + +; VREST -- REST A VECTOR, AREST -- REST AN ARG BLOCK + +VREST: SKIPA A,$TVEC ; FINAL TYPE +AREST: HRLI A,TARGS + ASH C,1 ; TIMES 2 + JRST UREST1 + +; UREST -- REST A UVECTOR + +STORST: SKIPA A,$TSTORA +UREST: MOVSI A,TUVEC +UREST1: JUMPE C,CPOPJ + HRLI C,(C) + JUMPL C,OUTRNG + ADD B,C ; REST IT + CAILE B,-1 ; OUT OF RANGE ? + JRST OUTRNG + POPJ P, + + +; SREST -- REST A STRING + +SREST: JUMPE C,SREST1 + PUSH P,A ; SAVE TYPE WORD + PUSH P,C ; SAVE AMOUNT + MOVEI D,(A) ; GET LENGTH + CAILE C,(D) ; SKIP IF OK + JRST OUTRNG + LDB D,[366000,,B] ;POSITION FIELD OF BYTE POINTER + LDB A,[300600,,B] ;SIZE FIELD + PUSH P,A ;SAVE SIZE + IDIVI D,(A) ;COMPUT BYTES IN 1ST WORD + MOVEI 0,36. ;NOW COMPUTE BYTES PER WORD + IDIVI 0,(A) ;BYTES PER WORD IN 0 + MOVE E,0 ;COPY OF BYTES PER WORD TO E + SUBI 0,(D) ;0 # OF UNSUED BYTES IN 1ST WORD + ADDB C,0 ;C AND 0 NO.OF CHARS FROM WORD BOUNDARY + IDIVI C,(E) ;C/ REL WORD D/ CHAR IN LAST + ADDI C,(B) ;POINTO WORD WITH C + POP P,A ;RESTORE BITS PER BYTE + IMULI A,(D) ;A/ BITS USED IN LAST WORD + MOVEI 0,36. + SUBI 0,(A) ;0 HAS NEW POSITION FIELD + DPB 0,[360600,,B] ;INTO BYTE POINTER + HRRI B,(C) ;POINT TO RIGHT WORD + POP P,C ; RESTORE AMOUNT + POP P,A + SUBI A,(C) ; NEW LENGTH +SREST1: HRLI A,TCHSTR + POPJ P, + +; TMPRST -- REST A TEMPLATE DATA STRUCTURE + +TMPRST: PUSHJ P,TM.TOE ; CHECK ALL BOUNDS ETC. + MOVSI D,(D) + HLL C,D + MOVE B,C ; RET IN B + MOVSI A,TTMPLT + POPJ P, + +; LAT -- GET A LOCATIVE TO A LIST + +LAT: PUSHJ P,LREST ; GET POINTER + JUMPE B,OUTRNG ; YOU LOSE! + MOVSI A,TLOCL ; NEW TYPE + POPJ P, + + +; UAT -- GET A LOCATIVE TO A UVECTOR + +UAT: PUSHJ P,UREST + MOVSI A,TLOCU + JRST POPJL + +; VAT -- GET A LOCATIVE TO A VECTOR + +VAT: PUSHJ P,VREST ; REST IT AND TYPE IT + MOVSI A,TLOCV + JRST POPJL + +; AAT -- GET A LOCATIVE TO AN ARGS BLOCK + +AAT: PUSHJ P,AREST + HRLI A,TLOCA +POPJL: JUMPGE B,OUTRNG ; LOST + POPJ P, + +; STAT -- LOCATIVE TO A STRING + +STAT: PUSHJ P,SREST + TRNN A,-1 ; SKIP IF ANY LEFT + JRST OUTRNG + HRLI A,TLOCS ; LOCATIVE + POPJ P, + +; TAT -- LOCATIVE TO A TEMPLATE + +TAT: PUSHJ P,TMPRST + PUSH TP,A + PUSH TP,B + GETYP A,(B) ; GET REAL SAT + SUBI A,NUMSAT+1 + HRLS A ; READY TO HIT TABLE + ADD A,TD.LNT+1(TVP) + JUMPGE A,BADTPL + MOVE C,B ; DATUM TO C + XCT (A) ; GET LENGTH + HLRZS C ; REST COUNTER + SUBI B,(C) ; FLUSH IT OFF + JUMPE B,OUTRNG + MOVE B,(TP) + SUB TP,[2,,2] + MOVSI A,TLOCT + POPJ P, + + +; LNTH -- NTH OF LIST + +LNTH: PUSHJ P,LAT +LNTH1: PUSHJ P,RMONC0 ; CHECK READ MONITORS + HLLZ A,(B) ; GET GOODIE + MOVE B,1(B) + JSP E,CHKAB ; HACK DEFER + POPJ P, + +; VNTH -- NTH A VECTOR, ANTH -- NTH AN ARGS BLOCK + +ANTH: PUSHJ P,AAT + JRST .+2 + +VNTH: PUSHJ P,VAT +AIN: +VIN: PUSHJ P,RMONC0 + MOVE A,(B) + MOVE B,1(B) + POPJ P, + +; UNTH -- NTH OF UVECTOR + +UNTH: PUSHJ P,UAT +UIN: HLRE C,B ; FIND DW + SUBM B,C + HLLZ 0,(C) ; GET MONITORS + MOVE D,0 + TLZ D,TYPMSK#<-1> + PUSH P,D + PUSHJ P,RMONCH ; CHECK EM + POP P,A + MOVE B,(B) ; AND VALUE + POPJ P, + + +; SNTH -- NTH A STRING + +SNTH: PUSHJ P,STAT +SIN: PUSH TP,A + PUSH TP,B ; SAVE POINT BYTER + MOVEI C,-1(TP) ; FIND DOPE WORD + PUSHJ P,BYTDOP + HLLZ 0,-1(A) ; GET + POP TP,B + POP TP,A + PUSHJ P,RMONCH + ILDB B,B ; GET CHAR + MOVSI A,TCHRS + POPJ P, + +; TIN -- IN OF A TEMPLATE + +TIN: MOVEI C,0 + +; TMPLNT -- NTH A TEMPLATE DATA STRUCTURE + +TMPLNT: ADDI C,1 + PUSHJ P,TM.TOE ; GET POINTER TO INS IN E + ADD A,TD.GET+1(TVP) ; POINT TO GETTER + MOVE A,(A) ; GET VECTOR OF INS + ADDI E,-1(A) ; POINT TO INS + SUBI D,1 + XCT (E) ; DO IT + POPJ P, ; RETURN + +; LPUT -- PUT ON A LIST + +LPUT: PUSHJ P,LAT ; POSITION + POP TP,D + POP TP,C + +; LSTUF -- HERE TO STUFF A LIST ELEMENT + +LSTUF: PUSHJ P,MONCH0 ; CHECK OUT MONITOR BITS + GETYP A,C ; ISOLATE TYPE + PUSHJ P,NWORDT ; NEED TO DEFER? + SOJN A,DEFSTU + HLLM C,(B) + MOVEM D,1(B) ; AND VAL + POPJ P, + +DEFSTU: PUSH TP,$TLIST + PUSH TP,B + PUSH TP,C + PUSH TP,D + PUSHJ P,CELL2 ; GET WORDS + POP TP,1(B) + POP TP,(B) + MOVE E,(TP) + SUB TP,[2,,2] + MOVEM B,1(E) + HLLZ 0,(E) ; GET OLD MONITORS + TLZ 0,TYPMSK ; KILL TYPES + TLO 0,TDEFER ; MAKE DEFERRED + HLLM 0,(E) + POPJ P, + +; VPUT -- PUT ON A VECTOR , APUT -- PUT ON AN RG BLOCK + +APUT: PUSHJ P,AAT + JRST .+2 + +VPUT: PUSHJ P,VAT ; TREAT LIKE VECTOR + POP TP,D ; GET GOODIE BACK + POP TP,C + +; AVSTUF -- CLOBBER ARGS AND VECTORS + +ASTUF: +VSTUF: PUSHJ P,MONCH0 + MOVEM C,(B) + MOVEM D,1(B) + POPJ P, + + + + +; UPUT -- CLOBBER A UVECTOR + +UPUT: PUSHJ P,UAT ; GET IT RESTED + POP TP,D + POP TP,C + +; USTUF -- HERE TO CLOBBER A UVECTOR + +USTUF: HLRE E,B + SUBM B,E ; C POINTS TO DOPE + GETYP A,(E) ; GET UTYPE + GETYP 0,C + CAIE 0,(A) ; CHECK SAMENESS + JRST WRNGUT + HLLZ 0,(E) ; MONITOR BITS IN DOPE WORD + MOVSI A,TUVEC + PUSHJ P,MONCH + MOVEM D,(B) ; SMASH + POPJ P, + +; SPUT -- HERE TO PUT A STRING + +SPUT: PUSHJ P,STAT ; REST IT + POP TP,D + POP TP,C + +; SSTUF -- STUFF A STRING + +SSTUF: GETYP 0,C ; BETTER BE CHAR + CAIE 0,TCHRS + JRST WTYP3 + PUSH TP,A + PUSH TP,B + MOVEI C,-1(TP) ; FIND D.W. + PUSHJ P,BYTDOP + HLLZ 0,(A)-1 ; GET MONITORS + POP TP,B + POP TP,A + MOVSI C,TCHRS + PUSHJ P,MONCH + IDPB D,B ; STASH + POPJ P, + +; TSTUF -- SETLOC A TEMPLATE + +TSTUF: PUSH TP,C + PUSH TP,D + MOVEI C,0 + +; PUTTMP -- TEMPLATE PUTTER + +TMPPUT: ADDI C,1 + PUSHJ P,TM.TOE ; GET E POINTING TO SLOT # + ADD A,TD.PUT+1(TVP) ; POINT TO INS + MOVE A,(A) ; GET VECTOR OF INS + ADDI E,-1(A) + POP TP,B ; NEW VAL TO A AND B + POP TP,A + SUBI D,1 + XCT (E) ; DO IT + JRST BADPUT + POPJ P, + +TM.LN1: SUBI 0,NUMSAT+1 + HRRZ A,0 ; RET FIXED OFFSET + HRLS 0 + ADD 0,TD.LNT+1(TVP) ; USE LENGTHERS FOR TEST + JUMPGE 0,BADTPL + PUSH P,C + MOVE C,B + HRRZS 0 ; POINT TO TABLE ENTRY + PUSH P,A + XCT @0 ; DO IT + POP P,A + POP P,C + POPJ P, + +TM.TBL: MOVEI E,(D) ; TENTATIVE WINNER IN E + TLNN B,-1 ; SKIP IF REST HAIR EXISTS + POPJ P, ; NO, WIN + + PUSH P,A ; SAVE OFFSET + HRLS A ; A IS REL OFFSET TO INS TABLE + ADD A,TD.GET+1(TVP) ; GET ONEOF THE TABLES + MOVE A,(A) ; TABLE POINTER TO A + MOVSI 0,-1(D) ; START SEEING IF PAST TEMP SPEC + ADD 0,A + JUMPL 0,CPOPJA ; JUMP IF E STILL VALID + HLRZ E,B ; BASIC LENGTH TO E + HLRE 0,A ; LENGTH OF TEMPLATE TO 0 + ADDI 0,(E) ; 0 ==> # ELEMENTS IN REPEATING SEQUENCE + MOVNS 0 + SUBM D,E ; E ==> # PAST BASIC WANTED + EXCH 0,E + IDIVI 0,(E) ; A ==> REL REST GUY WANTED + HLRZ E,B + ADDI E,1(A) +CPOPJA: POP P,A + POPJ P, + +; TM.TOE -- GET RIGHT TEMPLATE # IN E +; C/ OBJECT #, B/ OBJECT POINTER + +TM.TOE: GETYP 0,(B) ; GET REAL SAT + MOVEI D,(C) ; OBJ # TO D + HLRZ C,B ; REST COUNT + ADDI D,(C) ; FUDGE FOR REST COUNTER + MOVE C,B ; POINTER TO C + PUSHJ P,TM.LN1 ; GET LENGTH IN B (WATCH LH!) + CAILE D,(B) ; CHECK RANGE + JRST OUTRNG ; LOSER, QUIT + JRST TM.TBL ; GO COMPUTE TABLE OFFSET + + ; ROUTINE FOR COMPILER CALLS RETS CODE IN E GOODIE IN A AND B +; FIXES (P) + +CPTYEE: MOVE E,A + GETYP A,A + PUSHJ P,CPTYPE + JUMPE A,COMPERR + SUBM M,-1(P) + EXCH E,A + POPJ P, + +; COMPILER CALLS TO MANY OF THESE GUYS + +CIREST: PUSHJ P,CPTYEE ; TYPE OF DISP TO E + JUMPL C,OUTRNG + CAIN 0,SSTORE + JRST CIRST1 + PUSHJ P,@RESTBL(E) + JRST MPOPJ + +CIRST1: PUSHJ P,STORST + JRST MPOPJ + +CINTH: PUSHJ P,CPTYEE + SOJL C,OUTRNG ; CHECK BOUNDS + PUSHJ P,@NTHTBL(E) + JRST MPOPJ + +CIAT: PUSHJ P,CPTYEE + SOJL C,OUTRNG + PUSHJ P,@ATTBL(E) + JRST MPOPJ + +CSETLO: PUSHJ P,CTYLOC + MOVSS E ; REAL DISPATCH + GETYP 0,A ; INCASE LOCAS OR LOCD + PUSH TP,C + PUSH TP,D + PUSHJ P,@SETTBL(E) + POP TP,B + POP TP,A + JRST MPOPJ + +CIN: PUSHJ P,CTYLOC + MOVSS E ; REAL DISPATCH + GETYP C,A + PUSHJ P,@INTBL(E) + JRST MPOPJ + +CTYLOC: MOVE E,A + GETYP A,A + PUSHJ P,CPTYPE + SUBM M,-1(P) + EXCH A,E + POPJ P, + +; COMPILER'S PUT,GET AND GETL + +CIGET: PUSH P,[0] + JRST .+2 + +CIGETL: PUSH P,[1] + MOVE E,A + GETYP A,A + PUSHJ P,CPTYPE + EXCH A,E + JUMPE E,CIGET1 ; REAL GET, NOT NTH + GETYP 0,C ; INDIC FIX? + CAIE 0,TFIX + JRST CIGET1 + POP P,E ; GET FLAG + AOS (P) ; ALWAYS SKIP + MOVE C,D ; # TO AN AC + JRST @.+1(E) + CINTH + CIAT + +CIGET1: POP P,E ; GET FLAG + JRST @GETTR(E) ; DO A REAL GET + +GETTR: CIGTPR + CIGETP + +CIPUT: SUBM M,(P) + MOVE E,A + GETYP A,A + PUSHJ P,CPTYPE + EXCH A,E + PUSH TP,-1(TP) ; PAIN AND SUFFERING + PUSH TP,-1(TP) + MOVEM A,-3(TP) + MOVEM B,-2(TP) + JUMPE E,CIPUT1 + GETYP 0,C + CAIE 0,TFIX ; YES DO STRUCT + JRST CIPUT1 + MOVE C,D + SOJL C,OUTRNG ; CHECK BOUNDS + PUSHJ P,@IPUTBL(E) +PMPOPJ: POP TP,B + POP TP,A + JRST MPOPJ + +CIPUT1: PUSHJ P,IPUT + JRST PMPOPJ + +; SMON -- SET MONITOR BITS +; B/ <POINTER TO LOCATIVE> +; D/ <IORM> OR <ANDCAM> +; E/ BITS + +SMON: GETYP A,(B) + PUSHJ P,PTYPE ; TO PRIM TYPE + HLRZS A + SKIPE A,SMONTB(A) ; DISPATCH? + JRST (A) + +; COULD STILL BE LOCN OR LOCD + + GETYP A,(B) ; TYPE BACK + CAIE A,TLOCN + JRST SMON2 ; COULD BE LOCD + MOVE C,1(B) ; POINT + HRRI D,VAL(C) ; MAKE INST POINT + JRST SMON3 + +SMON2: CAIE A,TLOCD + JRST WRONGT + + +; SET LIST/TUPLE/ID LOCATIVE + +SMON4: HRR D,1(B) ; POINT TO TYPE WORD +SMON3: XCT D + POPJ P, + +; SET UVEC LOC + +SMON5: HRRZ C,1(B) ; POINT TO TOP OF UV + HLRE 0,1(B) + SUB C,0 ; POINT TO DOPE + HRRI D,(C) ; POINT IN INST + JRST SMON3 + +; SET CHSTR LOC + +SMON6: MOVEI C,(B) ; FOR BYTDOP + PUSHJ P,BYTDOP ; POINT TO DOPE + HRRI D,(A)-1 + JRST SMON3 + +PRDISP SMONTB,0,[[P2WORD,SMON4],[P2NWOR,SMON4],[PARGS,SMON4] +[PNWORD,SMON5],[PCHSTR,SMON6]] + + +; COMPILER'S MONAD? + +CIMON: PUSH P,A + GETYP A,A + PUSHJ P,CPTYPE + JUMPE A,CIMON1 + POP P,A + JRST CEMPTY + +CIMON1: POP P,A + JRST YES + +; FUNCTION TO DECIDE IF FURTHER DECOMPOSITION POSSIBLE + +MFUNCTION MONAD,SUBR,MONAD? + + ENTRY 1 + + MOVE B,AB ; CHECK PRIM TYPE + PUSHJ P,PTYPE + JUMPE A,ITRUTH ;RETURN ARGUMENT + SKIPE B,1(AB) + JRST @MONTBL(A) ;DISPATCH ON PTYPE + JRST ITRUTH + +PRDISP MONTBL,IFALSE,[[P2NWORD,MON1],[PNWORD,MON1],[PARGS,MON1] +[PCHSTR,CHMON],[PTMPLT,TMPMON]] + +MON1: JUMPGE B,ITRUTH ;EMPTY VECTOR + JRST IFALSE + +CHMON: HRRZ B,(AB) + JUMPE B,ITRUTH + JRST IFALSE + +TMPMON: PUSHJ P,LNTMPL + JUMPE B,ITRUTH + JRST IFALSE + +CISTRU: GETYP A,A ; COMPILER CALL + PUSHJ P,ISTRUC + JRST NO + JRST YES + +ISTRUC: PUSHJ P,SAT ; STORAGE TYPE + SKIPE A,PRMTYP(A) + AOS (P) ; SKIP IF WINS + POPJ P, + +; SUBR TO CHECK FOR LOCATIVE + +MFUNCTION %LOCA,SUBR,[LOCATIVE?] + + ENTRY 1 + GETYP A,(AB) + PUSHJ P,LOCQQ + JRST IFALSE + JRST ITRUTH + +; SKIPS IF TYPE IN A IS A LOCATIVE + +LOCQ: GETYP A,(B) ; GET TYPE +LOCQQ: PUSH P,A ; SAVE FOR LOCN/LOCD + PUSHJ P,SAT + MOVE A,PRMTYP(A) + JUMPE A,LOCQ1 + SUB P,[1,,1] + TRNN A,-1 +LOCQ2: AOS (P) + POPJ P, + +LOCQ1: POP P,A ; RESTORE TYPE + CAIE A,TLOCN + CAIN A,TLOCD + JRST LOCQ2 + POPJ P, + + +; MUDDLE SORT ROUTINE + +; P-STACK OFFSETS MUDDLE SORT ROUTINE + +; P-STACK OFFSETS FOR THIS PROGRAM + +XCHNG==0 ; FLAG SAYING AN EXCHANGE HAS HAPPENED +PLACE==-1 ; WHERE WE ARE NOW +UTYP==-2 ; TYPE OF UNIFORM VECTOR +DELT==-3 ; DIST BETWEEN COMPARERS + +MFUNCTION SORT,SUBR + + ENTRY + + HLRZ 0,AB ; CHECK FOR ENOUGH ARGS + CAILE 0,-4 + JRST TFA + GETYP A,(AB) ; 1ST MUST EITHER BE FALSE OR APPLICABLE + CAIN A,TFALSE + JRST SORT1 ; FALSE, OK + PUSHJ P,APLQ ; IS IT APPLICABLE + JRST NAPT ; NO, LOSER + +SORT1: MOVE B,AB + ADD B,[2,,2] ; BUMP TO POINT TO MAIN ARRAY + SETZB D,E ; 0 # OF STUCS AND LNTH + +SORT2: GETYP A,(B) ; GET ITS TYPE + PUSHJ P,PTYPE ; IS IT STRUCTURED? + MOVEI C,1 ; CHECK TYPE OF STRUC + CAIN A,PNWORD ; UVEC? + MOVEI C,0 ; YUP + CAIE A,PARGS + CAIN A,P2NWORD ; VECTOR + MOVNI C,1 + JUMPG C,WTYP + PUSH TP,(B) ; PUSH IT + PUSH TP,1(B) + ADD B,[2,,2] ; GO ON + MOVEI A,1 ; DEFAULT REC SIZE + PUSHJ P,NXFIX ; SIZE OF RECORD? + HLRZ 0,-2(TP) ; -LNTH OF STUC + HRRZ A,(TP) ; LENGTH OF REC + IDIVI 0,(A) ; DIV TO GET - # OF RECS + SKIPN D ; PREV LENGTH EXIST? + MOVE D,0 ; NO USE THIS + CAME 0,D + JRST SLOSE0 + MOVEI A,0 ; DEF REC SIZE + PUSHJ P,NXFIX ; AND OFFSET OF KEY + SUBI E,1 + JUMPL B,SORT2 ; GO ON + HRRM E,4(TB) ; SAVE THAT IN APPROPRIATE PLACE + + MOVE 0,3(TB) + CAMG 0,5(TB) ; CHECK FOR BAD OFFSET + JRST SLOSE3 + +; NOW CHECK WHATEVER STUCTURE THIS IS IS UNIFORM AND HAS GOOD ELEMENTS + + HLRE B,1(TB) ; COMP LENGTH + MOVNS B + HRRZ C,2(TB) ; GET VEC/UVEC FLAG + MOVEI D,(B) + ASH B,(C) ; FUDGE + JUMPE C,.+3 ; SKIP FOR UVEC + MOVE 0,[1,,1] ; ELSE FUDGE KEY OFFSET + ADDM 0,5(TB) + HRRZ 0,3(TB) ; GET REC LENGTH + IDIV D,0 ; # OF RECS + JUMPN E,SLOSE4 + CAIG D,1 ; MORE THAN 1? + JRST SORTD ; NO, DONE ALREADY + GETYP 0,(AB) ; TYPE OF COMPARER + CAIE 0,TFALSE ; IF FALSE, STRUCT MUST CONTAIN FIX,FLOAT,ATOM OR STRING + JRST SORT3 ; USER SUPPLIED COMPARER, LET HIM WORRY + +; NOW CHECK OUT ELEMENT TYPES + + JUMPN C,SORT5 ; JUMP IF GENERAL + MOVEI D,1(B) ; FIND END OF VECTOR + ADD D,1(TB) ; D POINTS TO END + PUSHJ P,TYPCH1 ; GET TYPE AND CHECK IT + JRST SORT6 + +SORT5: MOVE D,1(TB) ; POINT TO VEC + ADD D,5(TB) ; INTO REC TO KEY + PUSHJ P,TYPCH1 + +SAMELP: GETYP C,-1(D) ; GET TYPE + CAIE 0,(C) ; COMPARE TYPE + JRST SLOSE2 + ADD D,3(TB) ; TO NEXT RECORD + JUMPL D,SAMELP + +SORT6: CAIE A,S1WORD ; 1 WORDS? + JRST SORT7 + MOVEI E,INTSRT + MOVSI A,400000 ; SET UP MASK +SORT9: PUSHJ P,ISORT + MOVE A,2(AB) + MOVE B,3(AB) + JRST FINIS + +SORT7: CAIE A,SATOM ; ATOMS? + JRST SORT8 + MOVE E,[-3,,ATMSRT] ; SET UP FOR ATOMS + MOVE A,[430140,,3(D)] ; BIT POINTER FOR ATOMS + JRST SORT9 + +SORT8: MOVE E,[1,,STRSRT] ; MUST BE STRING SORT + MOVE A,[430140,,(D)] ; BYTE POINTER FOR STRINGER + JRST SORT9 + +; TABLES FOR RADIX SORT CHECKERS + +INTSRT==0 +ATMSRT==1 +STRSRT==2 + +TST1: PUSHJ P,I.TST1 + PUSHJ P,A.TST1 + PUSHJ P,S.TST1 + +TST2: PUSHJ P,I.TST2 + PUSHJ P,A.TST2 + PUSHJ P,S.TST2 + +NXBIT: ROT A,-1 + PUSHJ P,A.NXBI + PUSHJ P,S.NXBI + +PREBIT: ROT A,1 + PUSHJ P,A.PREB + PUSHJ P,S.PREB + +ENDTST: SKIPGE A + TLOE A,40 + TLOE A,40 + +; INTEGER SORT SPECIFIC ROUTINES + +I.TST1: JUMPL A,I.TST3 +I.TST4: TDNE A,(D) + AOS (P) + POPJ P, + +I.TST2: JUMPL A,I.TST4 +I.TST3: TDNN A,(D) + AOS (P) + POPJ P, + +; ATOM SORT SPECIFIC ROUTINES + +A.TST1: MOVE D,(D) ; GET AN ATOM + CAMG E,D ; SKIP IF NOT EXHAUSTED + POPJ P, + TLZ A,40 ; TELL A BIT HAS HAPPENED + LDB D,A ; GET THE BIT + SKIPE D + AOS (P) ; SKIP IF ON + POPJ P, + +A.TST2: PUSHJ P,A.TST1 ; USE OTHER ROUTINE + AOS (P) + POPJ P, + +A.NXBI: TLNN A,770000 ; CHECK FOR WORD CHANGE + SUB E,[1,,0] ; FIX WORD CHECKER + IBP A + POPJ P, + +A.PREB: ADD A,[10000,,] ; AH FOR A DECR BYTE POINTER + SKIPG A + CAMG A,[437777,,-1] ; SKIP IF BACKED OVER WORD + POPJ P, + TLZ A,770000 ; CLOBBER POSIT FIELD + SUBI A,1 ; DECR WORD POS FIELD + ADD E,[1,,0] ; AND FIX WORD HACKER + POPJ P, + +; STRING SPECIFIC SORT ROUTINES + +S.TST1: HRLZ 0,-1(D) ; LENGTH OF STRING + IMULI 0,7 ; IN BITS + HRRI 0,-1 ; MAKE SURE BIGGER RH + CAMG 0,E ; SKIP IF MORE BITS LEFT + POPJ P, ; DON TSKIP + TLZ A,40 ; BIT FOUND + HLRZ 0,(D) ; CHECK FOR SIMPLE CASE + HRRZ D,(D) ; POINT TO STRING + CAIN 0,440700 ; SKIP IF HAIRY + JRST S.TST3 + + PUSH P,A ; SAVE BYTER + MOVEI A,440700 ; COMPUTE BITS NOT USED 1ST WORD + SUBI A,@0 + HLRZ 0,(P) ; GET BIT POINTER + SUBI 0,(A) ; UPDATE POS FIELD + JUMPGE 0,.+2 ; NO NEED FOR NEXT WORD + ADD 0,[1,,440000] + MOVSS 0 + HRRZ A,(P) ; REBUILD BYTE POINTER + ADDI 0,(A) + LDB 0,0 ; GET THE DAMN BYTE + POP P,A + JRST .+2 + +S.TST3: LDB 0,A ; GET BYTE FOR EASY CASE + SKIPE 0 + AOS (P) + POPJ P, + +S.TST2: PUSHJ P,S.TST1 + AOS (P) + POPJ P, + +S.NXBI: IBP A ; BUMP BYTER + TLNN A,770000 ; SKIP IF NOT END BIT + IBP A ; SKIP END BIT (NOT USED IN ASCII STRINGS) + ADD E,[1,,0] ; COUNT BIT + POPJ P, + +S.PREB: SUB E,[1,,0] ; DECR CHAR COUNT + ADD A,[10000,,0] ; PLEASE GIVE ME A DECRBYTEPNTR + SKIPG A + CAMG A,[437777,,-1] + POPJ P, + TLC A,450000 ; POINT TO LAST USED BIT IN WORD + SUBI A,1 + POPJ P, + +; SIMPLE RADIX EXCHANGE + +ISORT: MOVE B,1(TB) ; START OF VECTOR + HLRE D,B ; COMPUTE POINTER TO END OF IT + SUBM B,D ; FIND END + MOVEI C,(D) + +ISORT1: PUSH TP,(TB) + PUSH TP,C + MOVE 0,C ; SEE IF HAVE MET AT MIDDLE + SUB 0,3(TB) + ANDI 0,-1 + CAIGE 0,(B) + JRST ISORT7 ; HAVE MET, LEAVE + PUSH TP,(TB) ; SAVE OTHER POINTER + PUSH TP,B + + INTGO + MOVE B,(TP) ; IN CASE MOVED + MOVE C,-2(TP) + +ISORT3: HRRZ D,5(TB) ; OFFSET TO KEY + ADDI D,(B) ; POINT TO KEY + XCT TST1(E) ; CHECK FOR LOSER + JRST ISORT4 + SUB C,3(TB) ; IS THERE ONE TO EXCHANGE WITH + HRRZ D,5(TB) + ADDI D,(C) + XCT TST2(E) ; SKIP IF A POSSIBLE EXCHANGE + JRST ISORT2 ; NO EXCH, KEEP LOOKING + + PUSHJ P,EXCHM ; DO THE EXCHANGE + +ISORT4: ADD B,3(TB) ; HAVE EXCHANGED, MOVE ON +ISORT2: CAME B,C ; MET? + JRST ISORT3 ; MORE TO CHECK + XCT NXBIT(E) ; NEXT BIT + MOVE B,(TP) ; RESTORE TOP POINTER + SUB TP,[2,,2] ; FLUSH IT + XCT ENDTST(E) + JRST ISORT6 + PUSHJ P,ISORT1 ; SORT SUB AREA + MOVE C,(TP) ; AND OTHER SUB AREA + PUSHJ P,ISORT1 +ISORT6: XCT PREBIT(E) +ISORT7: MOVE B,(TP) + SUB TP,[2,,2] + POPJ P, + +; SCHELL SORT FOR USER SUPPLIED COMPARER + +SORT3: ADDI D,1 + ASH D,-1 ; COMPUTE INITIAL D + PUSH P,D ; AND SAVE IT + PUSH P,[0] ; MAY HOLD UTYPE OF VECTOR + HRRZ 0,(TB) ; 0 NON ZERO MEANS GEN VECT + JUMPN 0,SSORT1 ; DONT COMPUTE UTYPE + HLRE C,1(TB) + HRRZ D,1(TB) ; FIND TYPE + SUBI D,(C) + GETYP D,(D) + MOVSM D,(P) ; AND SAVE +SSORT1: PUSH P,[0] ; CURRENT PLACE IN VECTOR + PUSH P,[0] ; EXCHANGE FLAG + PUSH TP,[0] + PUSH TP,[0] + +; OUTER LOOP STARTS HERE + +OUTRLP: SETZM XCHNG(P) ; NO EXHCANGE YET + SETZM PLACE(P) + +INRLP: PUSH TP,(AB) ; PUSH USER COMPARE FCN + PUSH TP,1(AB) + MOVE C,PLACE(P) ; GET CURRENT PLACE + ADD C,1(TB) ; ADD POINTER TO VEC IN + ADD C,5(TB) ; OFFSET TO KEY + PUSHJ P,GETELM + MOVE D,3(TB) + IMUL D,DELT(P) ; TIMES WORDS PER REC + ADD C,D + PUSHJ P,GETELM + MCALL 3,APPLY ; APPLY IT + GETYP 0,A ; TYPE OF RETURN + CAIN 0,TFALSE ; SKIP IF MUST CHANGE + JRST INRLP1 + + MOVE C,1(TB) ; POINT TO START + ADD C,PLACE(P) + MOVE B,3(TB) + IMUL B,DELT(P) + ADD B,C + PUSHJ P,EXCHM ; EXCHANGE THEM + SETOM XCHNG(P) ; SAY AN EXCHANGE TOOK PLACE + +INRLP1: MOVE C,3(TB) ; GET OFFSET + ADDB C,PLACE(P) + MOVE D,3(TB) + IMUL D,DELT(P) + ADD C,D ; CHECK FOR OVERFLOW + ADD C,1(TB) + JUMPL C,INRLP + SKIPE XCHNG(P) ; ANY EXCHANGES? + JRST OUTRLP ; YES, RESET PLACE AND GO + SOSG D,DELT(P) ; SKIP IF DIST WAS 1 + JRST SORTD + ADDI D,2 ; COMPUTE NEW DIST + ASH D,-1 + MOVEM D,DELT(P) + JRST OUTRLP + +SORTD: MOVE A,2(AB) ; DONE, RET 1ST STRUC + MOVE B,3(AB) + JRST FINIS + +; ROUTINE TO GET NEXT ARG IF ITS FIX + +NXFIX: JUMPGE B,NXFIX1 ; NONE LEFT, USE DEFAULT + GETYP 0,(B) ; TYPE + CAIE 0,TFIX ; FIXED? + JRST NXFIX1 ; NO, USE DEFAULT + MOVE A,1(B) ; GET THE NUMBER + ADD B,[2,,2] ; BUMP TO NEXT ARG +NXFIX1: HRLI C,TFIX + TRNE C,-1 ; SKIP IF UV + ASH A,1 ; FUDGE FOR VEC/UVEC + HRLI A,(A) + PUSH TP,C + PUSH TP,A + POPJ P, + +GETELM: SKIPN A,UTYP-1(P) ; SKIP IF UVECT + MOVE A,-1(C) ; GGET GEN TYPE + PUSH TP,A + PUSH TP,(C) + POPJ P, + +TYPCH1: GETYP A,-1(D) ; GET TYPE + MOVEI 0,(A) ; SAVE IN 0 + PUSHJ P,SAT ; AND SAT + CAIE A,SCHSTR ; STRING + CAIN A,SATOM + POPJ P, + CAIN A,S1WORD ; 1-WORD GOODIE + POPJ P, + JRST SLOSE1 + +; HERE TO DO EXCHANGE + +EXCHM: PUSH P,E + PUSH P,A ; SAVE VITAL ACS + PUSH P,B + PUSH P,C + SUB B,1(TB) ; COMPUTE RECORD # + HLRZS B ; TO RH + HRRZ 0,3(TB) ; GET REC LENGTH + IDIV B,0 ; DIV BY REC LENGTH + MOVE C,(P) + SUB C,1(TB) ; SAME FOR C + HLRZS C + IDIV C,0 ; NOW HAVE OTHER RECORD + + HRRE D,4(TB) ; - # OF STUCS + MOVSI D,(D) ; MAKE AN AOBJN POINTER + HRRI D,(TB) ; TO TEMPPS + +RECLP: HRRZ 0,3(D) ; GET REC LENGTH + MOVN E,3(D) ; NOW AOBJN TO REC + MOVSI E,(E) + HRR E,1(D) + MOVEI A,(C) ; COMP START OF REC + IMUL A,0 ; TIMES REC LENGTH + ADDI E,(A) + MOVEI A,(B) + IMUL A,0 + ADD A,1(D) ; POINT TO OTHER RECORD + +EXCHLP: EXCH 0,(A) + EXCH 0,(E) + EXCH 0,(A) + ADDI A,1 + AOBJN E,EXCHLP + + ADD D,[1,,6] ; TO NEXT STRUC + JUMPL D,RECLP ; IF MORE + + POP P,C + POP P,B + POP P,A + POP P,E + POPJ P, + +; FUNCTION TO DETERMINE MEMBERSHIP IN LISTS AND VECTORS + +MFUNCTION MEMBER,SUBR + + MOVE E,[PUSHJ P,EQLTST] ;TEST ROUTINE IN E + JRST MEMB + +MFUNCTION MEMQ,SUBR + + MOVE E,[PUSHJ P,EQTST] ;EQ TESTER + +MEMB: ENTRY 2 + MOVE B,AB ;POINT TO FIRST ARG + PUSHJ P,PTYPE ;CHECK PRIM TYPE + ADD B,[2,,2] ;POINT TO 2ND ARG + PUSHJ P,PTYPE + JUMPE A,WTYP2 ;2ND WRONG TYPE + PUSH TP,(AB) + PUSH TP,1(AB) + MOVE C,2(AB) ; FOR TUPLE CASE + SKIPE B,3(AB) ;GOBBLE LIST VECTOR ETC. POINTER + PUSHJ P,@MEMTBL(A) ;DISPATCH + JRST IFALSE ;OR REPORT LOSSAGE + JRST FINIS + +PRDISP MEMTBL,IWTYP2,[[P2WORD,MEMLST],[PNWORD,MUVEC],[P2NWORD,MEMVEC] +[PARGS,MEMTUP],[PCHSTR,MEMCH],[PTMPLT,MEMTMP]] + + + +MEMLST: MOVSI 0,TLIST ;SET B'S TYPE TO LIST + MOVEM 0,BSTO(PVP) + JUMPE B,MEMLS6 ; EMPTY LIST LOSE IMMEDIATE + +MEMLS1: INTGO ;CHECK INTERRUPTS + MOVEI C,(B) ;COPY POINTER + GETYP D,(C) ;GET TYPE + MOVSI A,(D) ;COPY + CAIE D,TDEFER ;DEFERRED? + JRST MEMLS2 + MOVE C,1(C) ;GET DEFERRED DATUM + GETYPF A,(C) ;GET FULL TYPE WORD +MEMLS2: MOVE C,1(C) ;GET DATUM + XCT E ;DO THE COMPARISON + JRST MEMLS3 ;NO MATCH + MOVSI A,TLIST +MEMLS5: AOS (P) +MEMLS6: SETZM BSTO(PVP) ;RESET B'S TYPE + POPJ P, + +MEMLS3: HRRZ B,(B) ;STEP THROGH + JUMPN B,MEMLS1 ;STILL MORE TO DO +MEMLS4: MOVSI A,TFALSE ;RETURN FALSE + JRST MEMLS6 ;RETURN 0 + +MEMTUP: HRRZ A,C + TLOA A,TARGS +MEMVEC: MOVSI A,TVEC ;CLOBBER B'S TYPE TO VECTOR + JUMPGE B,MEMLS4 ;EMPTY VECTOR + MOVEM A,BSTO(PVP) + +MEMV1: INTGO ;CHECK FOR INTS + GETYPF A,(B) ;GET FULL TYPE + MOVE C,1(B) ;AND DATA + XCT E ;DO COMPARISON INS + JRST MEMV2 ;NOT EQUAL + MOVE A,BSTO(PVP) + JRST MEMLS5 ;RETURN WITH POINTER + +MEMV2: ADD B,[2,,2] ;INCREMENT AND GO + JUMPL B,MEMV1 ;STILL WINNING +MEMV3: MOVEI B,0 + JRST MEMLS4 ;AND RETURN FALSE + +MUVEC: JUMPGE B,MEMLS4 + GETYP A,-1(TP) ;GET TYPE OF GODIE + HLRE C,B ;LOOK FOR UNIFORM TYPE + SUBM B,C ;DOPE POINTER TO C + GETYP C,(C) ;GET THE TYPE + CAIE A,(C) ;ARE THEY THE SAME? + JRST MEMLS4 ;NO, LOSE + MOVSI A,TUVEC + CAIN 0,SSTORE + MOVSI A,TSTORA + PUSH P,A + MOVEM A,BSTO(PVP) + MOVSI A,(C) ;TYPE TO LH + PUSH P,A ; SAVE FOR EACH TEST + +MUVEC1: INTGO ;CHECK OUT INTS + MOVE C,(B) ;GET DATUM + MOVE A,(P) ; GET TYPE + XCT E ;COMPARE + AOBJN B,MUVEC1 ;LOOP TO WINNAGE + SUB P,[1,,1] + POP P,A + JUMPGE B,MEMV3 ;LOSE RETURN + +MUVEC2: JRST MEMLS5 + + +MEMCH: GETYP A,-1(TP) ;IS ARG A SINGLE CHAR + CAIE A,TCHRS ;SKIP IF POSSIBLE WINNER + JRST MEMSTR + MOVEI 0,(C) + MOVE D,(TP) ; AND CHAR + +MEMCH1: SOJL 0,MEMV3 + MOVE E,B + ILDB A,B + CAIE A,(D) ;CHECK IT + SOJA C,MEMCH1 + +MEMCH2: MOVE B,E + MOVE A,C + JRST MEMLS5 + +MEMSTR: CAME E,[PUSHJ P,EQLTST] + JRST MEMV3 + HLRZ A,C + CAIE A, TCHSTR ; A SHOULD HAVE TCHSTR IN RIGHT HALF + JRST MEMV3 + MOVEI 0,(C) ; GET # OF CHAR INTO 0 + ILDB D,(TP) + PUSH P,D ; PUTS 1ST CHAR OF 1ST ARG ONTO STACK + +MEMST1: SOJL 0,MEMLS ; HUNTS FOR FIRST MATCHING CHAR + MOVE E,B + ILDB A,B + CAME A,(P) + SOJA C,MEMST1 ; MATCH FAILS TRY NEXT + + PUSH P,B + PUSH P,E + PUSH P,C + PUSH P,0 + MOVE E,(TP) ; MATCH WINS SAVE OLD VALUES FOR FAILING LOOP + HRRZ C,-1(TP) ; LENGTH OF 1ARG +MEMST2: SOJE C,MEMWN ; WON -RAN OUT OF 1ARG FIRST- + SOJL MEMLSR ; LOST -RAN OUT OF 2ARG- + ILDB A,B + ILDB D,E + CAIN A,(D) ; SKP IF POSSIBLY LOST -BACK TO MEMST1- + JRST MEMST2 + + POP P,0 + POP P,C + POP P,E + POP P,B + SOJA C,MEMST1 + +MEMWN: MOVE B,-2(P) ; SETS UP ARGS LIKE MEMCH2 - HAVE WON + MOVE A,-1(P) + SUB P,[5,,5] + JRST MEMLS5 + +MEMLSR: SUB P,[5,,5] + JRST MEMV3 + +MEMLS: SUB P,[1,,1] + JRST MEMV3 + +; MEMBERSHIP FOR TEMPLATE HACKER + +MEMTMP: GETYP 0,(B) ; GET REAL SAT + PUSH P,E + PUSH P,0 + PUSH TP,A + PUSH TP,B ; SAVE GOOEIE + PUSHJ P,TM.LN1 ; GET LENGTH + MOVEI B,(B) + HLRZ A,(TP) ; FUDGE FOR REST + SUBI B,(A) + PUSH P,B ; SAVE LENGTH + PUSH P,[-1] + POP TP,B + POP TP,A + MOVEM A,BSTO+1(PVP) + +MEMTM1: SETZM BSTO(PVP) + AOS C,(P) + SOSGE -1(P) + JRST MEMTM2 + MOVE 0,-2(P) + PUSHJ P,TMPLNT ; GET ITEM + EXCH C,B ; VALUE TO C, POINTER BACK TO B + MOVE E,-3(P) + MOVSI 0,TTMPLT + MOVEM 0,BSTO(PVP) + XCT E + JRST MEMTM1 + + HRL B,(P) ; DO APPROPRIATE REST + AOS -4(P) +MEMTM2: SUB P,[4,,4] + MOVSI A,TTMPLT + SETZM BSTO(PVP) + POPJ P, + +EQTST: GETYP A,A + GETYP 0,-1(TP) + CAMN C,(TP) ;CHECK VALUE + CAIE 0,(A) ;AND TYPE + POPJ P, + JRST CPOPJ1 + +EQLTST: PUSH TP,BSTO(PVP) + PUSH TP,B + PUSH TP,A + PUSH TP,C + SETZM BSTO(PVP) + PUSH P,E ;SAVE INS + MOVEI C,-5(TP) ;SET UP CALL TO IEQUAL + MOVEI D,-1(TP) + AOS -1(P) ;ASSUME SKIP + PUSHJ P,IEQUAL ;GO INO EQUAL + SOS -1(P) ;UNDO SKIP + SUB TP,[2,,2] ;AND POOP OF CRAP + POP TP,B + POP TP,BSTO(PVP) + POP P,E + POPJ P, + +; COMPILER MEMQ AND MEMBER + +CIMEMB: SKIPA E,[PUSHJ P,EQLTST] + +CIMEMQ: MOVE E,[PUSHJ P,EQTST] + SUBM M,(P) + PUSH TP,A + PUSH TP,B + GETYP A,C + PUSHJ P,CPTYPE + JUMPE A,COMPERR + MOVE B,D ; STRUCT TO B + PUSHJ P,@MEMTBL(A) + TDZA 0,0 ; FLAG NO SKIP + MOVEI 0,1 ; FLAG SKIP + SUB TP,[2,,2] + JUMPE 0,NOM + SOS (P) ; SKIP RETURN + JRST MPOPJ + + +; FUNCTION TO RETURN THE TOP OF A VECTOR , CSTRING OR UNIFORM VECTOR + +MFUNCTION TOP,SUBR + + ENTRY 1 + + MOVE B,AB ;CHECK ARG + PUSHJ P,PTYPE + MOVEI E,(A) + MOVE A,(AB) + MOVE B,1(AB) + PUSHJ P,@TOPTBL(E) ;DISPATCH + JRST FINIS + +PRDISP TOPTBL,IWTYP1,[[PNWORD,UVTOP],[P2NWORD,VTOP],[PCHSTR,CHTOP],[PARGS,ATOP] +[PTMPLT,BCKTOP]] + +BCKTOP: MOVEI B,(B) ; FIX UP POINTER + MOVSI A,TTMPLT + POPJ P, + +UVTOP: SKIPA A,$TUVEC +VTOP: MOVSI A,TVEC + CAIN 0,SSTORE + MOVSI A,TSTORA + HLRE C,B ;AND -LENGTH + HRRZS B + SUB B,C ;POINT TO DOPE WORD + HLRZ D,1(B) ;TOTAL LENGTH + SUBI B,-2(D) ;POINT TO TOP + MOVNI D,-2(D) ;-LENGTH + HRLI B,(D) ;B NOW POINTS TO TOP + POPJ P, + +CHTOP: PUSH TP,A + PUSH TP,B + LDB 0,[360600,,(TP)] ; POSITION FIELD + LDB E,[300600,,(TP)] ; AND SIZE FILED + IDIVI 0,(E) ; 0/ BYTES IN 1ST WORD + MOVEI C,36. ; BITS PER WORD + IDIVI C,(E) ; BYTES PER WORD + PUSH P,C + SUBM C,0 ; UNUSED BYTES I 1ST WORD + ADD 0,-1(TP) ; LENGTH OF WORD BOUNDARIED STRING + MOVEI C,-1(TP) ; GET DOPE WORD + PUSHJ P,BYTDOP + HLRZ C,(A) ; GET LENGTH + SUBI A,-1(C) ; START +1 + MOVEI B,(A) ; SETUP BYTER + HRLI B,440000 + SUB A,(TP) ; WORDS DIFFERENT + IMUL A,(P) ; CHARS EXTRA + SUBM 0,A ; FINAL TOTAL TO A + HRLI A,TCHSTR + POP P,C + DPB E,[300600,,B] + SUB TP,[2,,2] + POPJ P, + + + +ATOP: + +GETATO: HLRE C,B ;GET -LENGTH + HRROS B + SUB B,C ;POINT PAST + GETYP 0,(B) ;GET NEXT TYPE (ASSURED OF BEING EITHER TINFO OR TENTRY) + CAIN 0,TENTRY ;IF ENTRY + JRST EASYTP ;WANT UNEVALUATED ARGS + HRRE C,(B) ;ELSE-- GET NO. OF ARGS (*-2) + SUBI B,(C) ;GO TO TOP + TLCA B,-1(C) ;STORE NUMBER IN TOP POINTER +EASYTP: MOVE B,FRAMLN+ABSAV(B) ;GET ARG POINTER + HRLI A,TARGS + POPJ P, + +; COMPILERS ENTRY TO TOP + +CITOP: PUSHJ P,CPTYEE + CAIN E,P2WORD ; LIST? + JRST COMPERR + PUSHJ P,@TOPTBL(E) + JRST MPOPJ + +; FUNCTION TO CLOBBER THE CDR OF A LIST + +MFUNCTION PUTREST,SUBR,[PUTREST] + ENTRY 2 + + MOVE B,AB ;COPY ARG POINTER + PUSHJ P,PTYPE ;CHECK IT + CAIE A,P2WORD ;LIST? + JRST WTYP1 ;NO, LOSE + ADD B,[2,,2] ;AND NEXT ONE + PUSHJ P,PTYPE + CAIE A,P2WORD + JRST WTYP2 ;NOT LIST, LOSE + HRRZ B,1(AB) ;GET FIRST + MOVE D,3(AB) ;AND 2D LIST + CAIL B,HIBOT + JRST PURERR + HRRM D,(B) ;CLOBBER + MOVE A,(AB) ;RETURN CALLED TYPE + JRST FINIS + + + +; FUNCTION TO BACK UP A VECTOR, UVECTOR OR CHAR STRING + +MFUNCTION BACK,SUBR + + ENTRY + + MOVEI C,1 ;ASSUME BACKING UP ONE + JUMPGE AB,TFA ;NO ARGS IS TOO FEW + CAML AB,[-2,,0] ;SKIP IF MORE THAN 2 ARGS + JRST BACK1 ;ONLY ONE ARG + GETYP A,2(AB) ;GET TYPE + CAIE A,TFIX ;MUST BE FIXED + JRST WTYP2 + SKIPGE C,3(AB) ;GET NUMBER + JRST OUTRNG + CAMGE AB,[-4,,0] ;SKIP IF WINNING NUMBER OF ARGS + JRST TMA +BACK1: MOVE B,AB ;SET UP TO FIND TYPE + PUSHJ P,PTYPE ;GET PRIM TYPE + MOVEI E,(A) + MOVE A,(AB) + MOVE B,1(AB) ;GET DATUM + PUSHJ P,@BCKTBL(E) + JRST FINIS + +PRDISP BCKTBL,IWTYP2,[[PNWORD,BACKU],[P2NWORD,BACKV],[PCHSTR,BACKC],[PARGS,BACKA] +[PTMPLT,BCKTMP]] + +BACKV: LSH C,1 ;GENERAL, DOUBLE AMOUNT + SKIPA A,$TVEC +BACKU: MOVSI A,TUVEC + CAIN 0,SSTORE + MOVSI A,TSTORA + HRLI C,(C) ;TO BOTH HALVES + SUB B,C ;BACK UP VECTOR POINTER + HLRE C,B ;FIND OUT IF OVERFLOW + SUBM B,C ;DOPE POINTER TO C + HLRZ D,1(C) ;GET LENGTH + SUBI C,-2(D) ;POINT TO TOP + ANDI C,-1 + CAILE C,(B) ;SKIP IF A WINNER + JRST OUTRNG ;COMPLAIN +BACKUV: POPJ P, + +BCKTMP: MOVSI C,(C) + SUB B,C ; FIX UP POINTER + JUMPL B,OUTRNG + MOVSI A,TTMPLT + POPJ P, + +BACKC: PUSH TP,A + PUSH TP,B + ADDI A,(C) ; NEW LENGTH + HRLI A,TCHSTR + PUSH P,A ; SAVE COUNT + LDB E,[300600,,B] ;BYTE SIZE + MOVEI 0,36. ;BITS PER WORD + IDIVI 0,(E) ;DIVIDE TO FIND BYTES/WORD + IDIV C,0 ;C/ WORDS BACK, D/BYTES BACK + SUBI B,(C) ;BACK WORDS UP + JUMPE D,CHBOUN ;CHECK BOUNDS + + IMULI 0,(E) ;0/ BITS OCCUPIED BY FULL WORD + LDB A,[360600,,B] ;GET POSITION FILED +BACKC2: ADDI A,(E) ;BUMP + CAIGE A,36. + JRST BACKC1 ;O.K. + SUB A,0 + SUBI B,1 ;DECREMENT POINTER PART +BACKC1: SOJG D,BACKC2 ;DO FOR ALL BYTES + + + + DPB A,[360600,,B] ;FIX UP POINT BYTER +CHBOUN: MOVEI C,-1(TP) + PUSHJ P,BYTDOP ; FIND DOPE WORD + HLRZ C,(A) + SUBI A,-1(C) ; POINT TO TOP + MOVE C,B ; COPY BYTER + IBP C + CAILE A,(C) ; SKIP IF OK + JRST OUTRNG + POP P,A ; RESTORE COUNT + SUB TP,[2,,2] + POPJ P, + + +BACKA: LSH C,1 ;NUMBER TIMES 2 + HRLI C,(C) ;TO BOTH HALVES + SUB B,C ;FIX POINTER + MOVE E,B ;AND SAVE + PUSHJ P,GETATO ;LOOK A T TOP + CAMLE B,E ;COMPARE + JRST OUTRNG + MOVE B,E + POPJ P, + +; COMPILER'S BACK + +CIBACK: PUSHJ P,CPTYEE + JUMPL C,OUTRNG + CAIN E,P2WORD + JRST COMPERR + PUSHJ P,@BCKTBL(E) + JRST MPOPJ + +MFUNCTION STRCOMP,SUBR + + ENTRY 2 + + MOVE A,(AB) + MOVE B,1(AB) + MOVE C,2(AB) + MOVE D,3(AB) + PUSHJ P,ISTRCM + JRST FINIS + +ISTRCM: GETYP 0,A + CAIE 0,TCHSTR + JRST ATMCMP ; MAYBE ATOMS + + GETYP 0,C + CAIE 0,TCHSTR + JRST WTYP2 + + MOVEI A,(A) ; ISOLATR LENGHTS + MOVEI C,(C) + +STRCO2: SOJL A,CHOTHE ; ONE STRING EXHAUSTED, CHECK OTHER + SOJL C,1BIG ; 1ST IS BIGGER + ILDB 0,B + ILDB E,D + CAIN 0,(E) ; SKIP IF DIFFERENT + JRST STRCO2 + CAIL 0,(E) ; SKIP IF 2D BIGGER THAN 1ST + JRST 1BIG +2BIG: MOVNI B,1 + JRST RETFIX + +CHOTHE: JUMPN C,2BIG ; 2 IS BIGGER +SM.CMP: TDZA B,B ; RETURN 0 +1BIG: MOVEI B,1 +RETFIX: MOVSI A,TFIX + POPJ P, + +ATMCMP: CAIE 0,TATOM ; COULD BE ATOM + JRST WTYP1 ; NO, QUIT + GETYP 0,C + CAIE 0,TATOM + JRST WTYP2 + + CAMN B,D ; SAME ATOM? + JRST SM.CMP + ADD B,[3,,3] ; SKIP VAL CELL ETC. + ADD D,[3,,3] + +ATMCM1: MOVE 0,(B) ; GET A WORD OF CHARS + CAME 0,(D) ; SAME? + JRST ATMCM3 ; NO, GET DIF + AOBJP B,ATMCM2 + AOBJN D,ATMCM1 ; MORE TO COMPARE + JRST 1BIG ; 1ST IS BIGGER + + +ATMCM2: AOBJP D,SM.CMP ; EQUAL + JRST 2BIG + +ATMCM3: LSH 0,-1 ; AVOID SIGN LOSSAGE + MOVE C,(D) + LSH C,-1 + CAMG 0,C + JRST 2BIG + JRST 1BIG + + ;ERROR COMMENTS FOR SOME PRIMITIVES + +OUTRNG: PUSH TP,$TATOM + PUSH TP,EQUOTE OUT-OF-BOUNDS + JRST CALER1 + +WRNGUT: PUSH TP,$TATOM + PUSH TP,EQUOTE UNIFORM-VECTORS-TYPE-DIFFERS + JRST CALER1 + +SLOSE0: PUSH TP,$TATOM + PUSH TP,EQUOTE VECTOR-LENGTHS-DIFFER + JRST CALER1 + +SLOSE1: PUSH TP,$TATOM + PUSH TP,EQUOTE KEYS-WRONG-TYPE + JRST CALER1 + +SLOSE2: PUSH TP,$TATOM + PUSH TP,EQUOTE KEY-TYPES-DIFFER + JRST CALER1 + +SLOSE3: PUSH TP,$TATOM + PUSH TP,EQUOTE KEY-OFFSET-OUTSIDE-RECORD + JRST CALER1 + +SLOSE4: PUSH TP,$TATOM + PUSH TP,EQUOTE NON-INTEGER-NO.-OF-RECORDS + JRST CALER1 + +IIGETP: JRST IGETP ;FUDGE FOR MIDAS/STINK LOSSAGE +IIPUTP: JRST IPUTP + + ;SUPER USEFUL ERROR MESSAGES (USED BY WHOLE WORLD) + +WNA: PUSH TP,$TATOM + PUSH TP,EQUOTE WRONG-NUMBER-OF-ARGUMENTS + JRST CALER1 + +TFA: PUSH TP,$TATOM + PUSH TP,EQUOTE TOO-FEW-ARGUMENTS-SUPPLIED + JRST CALER1 + +TMA: PUSH TP,$TATOM + PUSH TP,EQUOTE TOO-MANY-ARGUMENTS-SUPPLIED + JRST CALER1 + +WRONGT: +WTYP: PUSH TP,$TATOM + PUSH TP,EQUOTE ARG-WRONG-TYPE + JRST CALER1 + +IWTYP1: +WTYP1: PUSH TP,$TATOM + PUSH TP,EQUOTE FIRST-ARG-WRONG-TYPE + JRST CALER1 + +IWTYP2: +WTYP2: PUSH TP,$TATOM + PUSH TP,EQUOTE SECOND-ARG-WRONG-TYPE + JRST CALER1 + +BADTPL: PUSH TP,$TATOM + PUSH TP,EQUOTE BAD-TEMPLATE-DATA + JRST CALER1 + +BADPUT: PUSH TP,$TATOM + PUSH TP,EQUOTE TEMPLATE-TYPE-VIOLATION + JRST CALER1 + +WTYP3: PUSH TP,$TATOM + PUSH TP,EQUOTE THIRD-ARG-WRONG-TYPE + JRST CALER1 + +CALER1: MOVEI A,1 +CALER: HRRZ C,FSAV(TB) + PUSH TP,$TATOM + CAMGE C,VECTOP + CAMGE C,VECBOT + SKIPA C,@-1(C) ; SUBRS AND FSUBRS + MOVE C,3(C) ; FOR RSUBRS + PUSH TP,C + ADDI A,1 + ACALL A,ERROR + JRST FINIS + + +GETWNA: HLRZ B,(E)-2 ;GET LOSING COMPARE INSTRUCTION + CAIE B,(CAIE A,) ;AS EXPECTED ? + JRST WNA ;NO, + HRRE B,(E)-2 ;GET DESIRED NUMBER OF ARGS + HLRE A,AB ;GET ACTUAL NUMBER OF ARGS + CAMG B,A + JRST TFA + JRST TMA + +END + \ No newline at end of file diff --git a/sumex/print.mcr246 b/sumex/print.mcr246 new file mode 100644 index 0000000..62a4fbd --- /dev/null +++ b/sumex/print.mcr246 @@ -0,0 +1,2246 @@ +TITLE PRINTER ROUTINE FOR MUDDLE + +RELOCATABLE + +.INSRT DSK:MUDDLE > + +.GLOBAL IPNAME,MTYO,FLOATB,RLOOKU,RADX,INAME,INTFCN,LINLN,DOIOTO,BFCLS1,ATOSQ,IGVAL +.GLOBAL BYTPNT,OPNCHN,CHRWRD,IDVAL,CHARGS,CHFRM,CHLOCI,PRNTYP,PRTYPE,IBLOCK,WXCT +.GLOBAL VECBOT,VAL,ITEM,INDIC,IOINS,DIRECT,TYPVEC,CHRPOS,LINPOS,ACCESS,PAGLN,ROOT,PROCID +.GLOBAL BADCHN,WRONGD,CHNCLS,IGET,FNFFL,ILLCHO,BUFSTR,BYTDOP,6TOCHS,PURVEC,STBL,RXCT +.GLOBAL TMPLNT,TD.LNT,MPOPJ,SSPEC1 +.GLOBAL CIPRIN,CIPRNC,CIPRN1,CPATM,CP1ATM,CPCATM,CPSTR,CP1STR,CPCSTR +.GLOBAL CIFLTZ,CITERP,CIUPRS,CPCH + +BUFLNT==100 ; BUFFER LENGTH IN WORDS + +FLAGS==0 ;REGISTER USED TO STORE FLAGS +CARRET==15 ;CARRIAGE RETURN CHARACTER +ESCHAR=="\ ;ESCAPE CHARACTER +SPACE==40 ;SPACE CHARACTER +ATMBIT==200000 ;BIT SWITCH FOR ATOM-NAME PRINT +NOQBIT==020000 ;SWITCH FOR NO ESCAPING OF OUTPUT (PRINC) +SEGBIT==010000 ;SWITCH TO INDICATE PRINTING A SEGMENT +SPCBIT==004000 ;SWITCH TO INDICATE "PRINT" CALL (PUT A SPACE AFTER) +FLTBIT==002000 ;SWITCH TO INDICATE "FLATSIZE" CALL +HSHBIT==001000 ;SWITCH TO INDICATE "PHASH" CALL +TERBIT==000400 ;SWITCH TO INDICATE "TERPRI" CALL +UNPRSE==000200 ;SWITCH TO INDICATE "UNPARSE" CALL +ASCBIT==000100 ;SWITCH TO INDICATE USING A "PRINT" CHANNEL +BINBIT==000040 ;SWITCH TO INDICATE USING A "PRINTB" CHANNEL +PJBIT==400000 +C.BUF==1 +C.PRIN==2 +C.BIN==4 +C.OPN==10 +C.READ==40 + + + MFUNCTION FLATSIZE,SUBR + DEFINE FLTMAX + 4(B) TERMIN + DEFINE FLTSIZ + 2(B)TERMIN +;FLATSIZE TAKES TWO OR THREE ARGUMENTS: THE FIRST IS AN OBJECT THE SECOND +;IS THE MAXIMUM SIZE BEFORE IT GIVES UP AN RETURNS FALSE +;THE THIRD (OPTIONAL) ARGUMENT IS A RADIX + ENTRY + CAMG AB,[-2,,0] ;CHECK NUMBER OF ARGS + CAMG AB,[-6,,0] + JRST WNA + PUSH P,3(AB) + + GETYP A,2(AB) + CAIE A,TFIX + JRST WTYP2 ;SECOND ARG NOT FIX THEN LOSE + + CAMG AB,[-4,,0] ;SEE IF THERE IS A RADIX ARGUMENT + JRST .+3 ; RADIX SUPPLIED + PUSHJ P,GTRADX ; GET THE RADIX FROM OUTCHAN + JRST FLTGO + GETYP A,4(AB) ;CHECK TO SEE THAT RADIX IS FIX + CAIE A,TFIX + JRST WTYP ;ERROR THIRD ARGUMENT WRONG TYPE + MOVE C,5(AB) + PUSHJ P,GETARG ; GET ARGS INTO A AND B +FLTGO: POP P,D ; RESTORE FLATSIZE MAXIMUM + PUSHJ P,CIFLTZ + JFCL + JRST FINIS + + + +MFUNCTION UNPARSE,SUBR + DEFINE UPB + 0(B) TERMIN + + ENTRY + + JUMPGE AB,TFA + MOVE E,TP ;SAVE TP POINTER + + + +;TURN ON FLTBIT TO AVOID PRINTING LOSSAGE +;TURN ON UNPRSE TO CAUSE CHARS TO BE STASHED + CAMG AB,[-2,,0] ;SKIP IF RADIX SUPPLIED + JRST .+3 + PUSHJ P,GTRADX ;GET THE RADIX FROM OUTCHAN + JRST UNPRGO + CAMGE AB,[-5,,0] ;CHECK FOR TOO MANY + JRST TMA + GETYP 0,2(AB) + CAIE 0,TFIX ;SEE IF RADIX IS FIXED + JRST WTYP2 + MOVE C,3(AB) ;GET RADIX + PUSHJ P,GETARG ;GET ARGS INTO A AND B +UNPRGO: PUSHJ P,CIUPRS + JRST FINIS + JRST FINIS + + +GTRADX: MOVE B,IMQUOTE OUTCHAN + PUSH P,0 ;SAVE FLAGS + PUSHJ P,IDVAL ;GET VALUE FOR OUTCHAN + POP P,0 + GETYP A,A ;CHECK TYPE OF CHANNEL + CAIE A,TCHAN + JRST FUNCH1-1 ;IT IS A TP-POINTER + MOVE C,RADX(B) ;GET RADIX FROM OUTCHAN + JRST FUNCH1 + MOVE C,(B)+6 ;GET RADIX FROM STACK + +FUNCH1: CAIG C,1 ;CHECK FOR STRANGE RADIX + MOVEI C,10. ;DEFAULT IF THIS IS THE CASE +GETARG: MOVE A,(AB) + MOVE B,1(AB) + POPJ P, + + +MFUNCTION PRINT,SUBR + ENTRY + PUSHJ P,AGET ; GET ARGS + PUSHJ P,CIPRIN + JRST FINIS + +MFUNCTION PRINC,SUBR + ENTRY + PUSHJ P,AGET ; GET ARGS + PUSHJ P,CIPRNC + JRST FINIS + +MFUNCTION PRIN1,SUBR + ENTRY + PUSHJ P,AGET + PUSHJ P,CIPRN1 + JRST FINIS + JRST PRIN01 ;CALL IPRINT AFTER SAVING STUFF + + +MFUNCTION TERPRI,SUBR + ENTRY + PUSHJ P,AGET1 + PUSHJ P,CITERP + JRST FINIS + + +CITERP: SUBM M,(P) + MOVSI 0,TERBIT+SPCBIT ; SET UP FLAGS + PUSHJ P,TESTR ; TEST FOR GOOD CHANNEL + MOVEI A,CARRET ; MOVE IN CARRIAGE-RETURN + PUSHJ P,PITYO ; PRINT IT OUT + MOVEI A,12 ; LINE-FEED + PUSHJ P,PITYO + MOVSI A,TFALSE ; RETURN A FALSE + MOVEI B,0 + JRST MPOPJ ; RETURN + + +TESTR: GETYP E,A + CAIN E,TCHAN ; CHANNEL? + JRST TESTR1 ; OK? + CAIE E,TTP + JRST BADCHN + HLRZS 0 + IOR 0,A ; RESTORE FLAGS + HRLZS 0 + POPJ P, +TESTR1: HRRZ E,-4(B) ; GET IN FLAGS FROM CHANNEL + TRC E,C.PRIN+C.OPN ; CHECK TO SEE THAT CHANNEL IS GOOD + TRNE E,C.PRIN+C.OPN + JRST BADCHN ; ITS A LOSER + TRNE E,C.BIN + JRST PSHNDL ; DON'T HANDLE BINARY + TLO ASCBIT ; ITS ASCII + POPJ P, ; ITS A WINNER + +PSHNDL: PUSH TP,C ; SAVE ARGS + PUSH TP,D + PUSH TP,A ; PUSH CHANNEL ONTO STACK + PUSH TP,B + PUSHJ P,BPRINT ; CHECK BUFFER + POP TP,B + POP TP,A + POP TP,D + POP TP,C + POPJ P, + + + ;CIUPRS NEEDS A RADIX IN C AND A TYPE-OBJECT PAIR IN A,B + +CIUPRS: SUBM M,(P) ; MODIFY M-POINTER + MOVE E,TP ; SAVE TP-POINTER + PUSH TP,[0] ; SLOT FOR FIRST STRING COPY + PUSH TP,[0] + PUSH TP,[0] ; AND SECOND STRING + PUSH TP,[0] + PUSH TP,A ; SAVE OBJECTS + PUSH TP,B + PUSH TP,$TTP ; SAVE TP POINTER + PUSH TP,E + PUSH P,C + MOVE D,[377777,,-1] ; MOVE IN MAXIMUM NUMBER FOR FLATSIZE + PUSHJ P,CIFLTZ ; FIND LENGTH OF STRING + FATAL UNPARSE BLEW IT + PUSH TP,$TFIX ; MOVE IN ARGUMENT FOR ISTRING + PUSH TP,B + MCALL 1,ISTRING + POP TP,E ; RESTORE TP-POINTER + SUB TP,[1,,1] ;GET RID OF TYPE WORD + MOVEM A,1(E) ; SAVE RESULTS + MOVEM A,3(E) + MOVEM B,2(E) + MOVEM B,4(E) + POP TP,B ; RESTORE THE WORLD + POP TP,A + POP P,C + MOVSI 0,FLTBIT+UNPRSE ; SET UP FLAGS + PUSHJ P,CUSET + JRST MPOPJ ; RETURN + + + +; FOR CIFLTZ C CONTAINS THE RADIX, D THE MAXIMUM NUMBER OF CHARACTERS, +; A,B THE TYPE-OBJECT PAIR + +CIFLTZ: SUBM M,(P) + MOVE E,TP ; SAVE POINTER + PUSH TP,$TFIX ; PUSH ON FLATSIZE COUNT + PUSH TP,[0] + PUSH TP,$TFIX ; PUSH ON FLATSIZE MAXIMUM + PUSH TP,D + MOVSI 0,FLTBIT ; MOVE ON FLATSIZE FLAG + PUSHJ P,CUSET ; CONTINUE + JRST MPOPJ + SOS (P) ; SKIP RETURN + JRST MPOPJ ; RETURN + +; CUSET IS THE ROUTINE USED BY FLATSIZE AND UNPARSE TO DO THE PUSHING,POPING AND CALLING +; NEEDED TO GET A RESULT. + +CUSET: PUSH TP,$TFIX ; PUSH ON RADIX + PUSH TP,C + PUSH TP,$TPDL + PUSH TP,P ; PUSH ON RETURN POINTER IN CASE FLATSIZE GETS A FALSE + PUSH TP,A ; SAVE OBJECTS + PUSH TP,B + MOVSI C,TTP ; CONSTRUCT TP-POINTER + HLR C,FLAGS ; SAVE FLAGS IN TP-POINTER + MOVE D,E + PUSH TP,C ; PUSH ON CHANNEL + PUSH TP,D + PUSHJ P,IPRINT ; GO TO INTERNAL PRINTER + POP TP,B ; GET IN TP POINTER + MOVE TP,B ; RESTORE POINTER + TLNN FLAGS,UNPRSE ; SEE IF UNPARSE CALL + JRST FLTGEN ; ITS A FLATSIZE + MOVE A,UPB+3 ; RETURN STRING + MOVE B,UPB+4 + POPJ P, ; DONE +FLTGEN: MOVE A,FLTSIZ-1 ; GET IN COUNT + MOVE B,FLTSIZ + AOS (P) + POPJ P, ; EXIT + + +; CIPRIN,CIPRNC,CIPRN1,CPATM,CP1ATM,CPCATM,CPSTR,CP1STR,CPCSTR ALL ASSUME +; THAT C,D CONTAIN THE OBJECT AND A AND B CONTAIN THE CHANNEL + +CIPRIN: SUBM M,(P) + MOVSI 0,SPCBIT ; SET UP FLAGS + PUSHJ P,TPRT ; PRINT INITIALIZATION + PUSHJ P,IPRINT + JRST TPRTE ; EXIT + +CIPRN1: SUBM M,(P) + MOVEI FLAGS,0 ; SET UP FLAGS + PUSHJ P,TPR1 ; INITIALIZATION + PUSHJ P,IPRINT ; PRINT IT OUT + JRST TPR1E ; EXIT + +CIPRNC: SUBM M,(P) + MOVSI FLAGS,NOQBIT ; SET UP FLAGS + PUSHJ P,TPR1 ; INITIALIZATION + PUSHJ P,IPRINT + JRST TPR1E ; EXIT + +; INITIALIZATION FOR PRINT ROUTINES + +TPRT: PUSHJ P,TESTR ; SEE IF CHANNEL IS OK + PUSH TP,C ; SAVE ARGUMENTS + PUSH TP,D + PUSH TP,A ; SAVE CHANNEL + PUSH TP,B + MOVEI A,CARRET ; PRINT CARRIAGE RETURN + PUSHJ P,PITYO + MOVEI A,12 ; AND LF + PUSHJ P,PITYO + MOVE A,-3(TP) ; MOVE IN ARGS + MOVE B,-2(TP) + POPJ P, + +; EXIT FOR PRINT ROUTINES + +TPRTE: POP TP,B ; RESTORE CHANNEL + MOVEI A,SPACE ; PRINT TRAILING SPACE + PUSHJ P,PITYO + SUB TP,[1,,1] ; GET RID OF CHANNEL TYPE-WORD + POP TP,B ; RETURN WHAT WAS PASSED + POP TP,A + JRST MPOPJ ; EXIT + +; INITIALIZATION FOR PRIN1 AND PRINC ROUTINES + +TPR1: PUSHJ P,TESTR ; SEE IF CHANNEL IS OK + PUSH TP,C ; SAVE ARGS + PUSH TP,D + PUSH TP,A ; SAVE CHANNEL + PUSH TP,B + MOVE A,-3(TP) ; GET ARGS + MOVE B,-2(TP) + POPJ P, + +; EXIT FOR PRIN1 AND PRINC ROUTINES + +TPR1E: SUB TP,[2,,2] ; REMOVE CHANNEL + POP TP,B ; RETURN ARGUMENTS THAT WERE GIVEN + POP TP,A + JRST MPOPJ ; EXIT + + + +CPATM: SUBM M,(P) + MOVSI C,TATOM ; GET TYPE FOR BINARY + MOVE 0,$SPCBIT ; SET UP FLAGS + PUSHJ P,TPRT ; PRINT INITIALIZATION + PUSHJ P,CPATOM ; PRINT IT OUT + JRST TPRTE ; EXIT + +CP1ATM: SUBM M,(P) + MOVE C,$TATOM + MOVEI FLAGS,0 ; SET UP FLAGS + PUSHJ P,TPR1 ; INITIALIZATION + PUSHJ P,CPATOM ; PRINT IT OUT + JRST TPR1E ; EXIT + +CPCATM: SUBM M,(P) + MOVE C,$TATOM + MOVSI FLAGS,NOQBIT ; SET UP FLAGS + PUSHJ P,TPR1 ; INITIALIZATION + PUSHJ P,CPATOM ; PRINT IT OUT + JRST TPR1E ; EXIT + + +; THIS ROUTINE IS USD TO PRINT ONE CHARACTER. THE CHANNEL IS IN A AND B THE +; CHARACTER IS IN C. +CPCH: SUBM M,(P) + MOVSI FLAGS,NOQBIT + MOVE C,$TCHRS + PUSHJ P,TESTR ; SEE IF CHANNEL IS GOOD + PUSH P,D + MOVE A,D ; MOVE IN CHARACTER FOR PITYO + PUSHJ P,PITYO + MOVE A,$TCHRST ; RETURN THE CHARACTER + POP P,B + JRST MPOPJ + + + + +CPSTR: SUBM M,(P) + HRLI C,TCHSTR + MOVSI 0,SPCBIT ; SET UP FLAGS + PUSHJ P,TPRT ; PRINT INITIALIZATION + PUSHJ P,CPCHST ; PRINT IT OUT + JRST TPRTE ; EXIT + +CP1STR: SUBM M,(P) + HRLI C,TCHSTR + MOVEI FLAGS,0 ; SET UP FLAGS + PUSHJ P,TPR1 ; INITIALIZATION + PUSHJ P,CPCHST ; PRINT IT OUT + JRST TPR1E ; EXIT + +CPCSTR: SUBM M,(P) + HRLI C,TCHSTR + MOVSI FLAGS,NOQBIT ; SET UP FLAGS + PUSHJ P,TPR1 ; INITIALIZATION + PUSHJ P,CPCHST ; PRINT IT OUT + JRST TPR1E ; EXIT + + +CPATOM: PUSH TP,A ; COPY ARGS FOR INTERNAL SAKE + PUSH TP,B + PUSH P,0 ; ATOM CALLER ROUTINE + PUSH P,C + JRST PATOM + +CPCHST: PUSH TP,A ; COPY ARGS FOR INTERNAL SAKE + PUSH TP,B + PUSH P,0 ; STRING CALLER ROUTINE + PUSH P,C + JRST PCHSTR + + + +AGET: MOVEI FLAGS,0 + SKIPL E,AB ; COPY ARG POINTER + JRST TFA ;NO ARGS IS AN ERROR + ADD E,[2,,2] ;POINT AT POSSIBLE CHANNEL + JRST COMPT +AGET1: MOVE E,AB ; GET COPY OF AB + MOVSI FLAGS,TERBIT + +COMPT: PUSH TP,$TFIX ;LEAVE ROOM ON STACK FOR ONE CHANNEL + PUSH TP,[0] + JUMPGE E,DEFCHN ;IF NO CHANNEL ARGUMENT, USE CURRENT BINDING + CAMG E,[-2,,0] ;IF MORE ARGS THEN ERROR + JRST TMA + MOVE A,(E) ;GET CHANNEL + MOVE B,(E)+1 + JRST NEWCHN + +DEFCHN: MOVE B,IMQUOTE OUTCHAN + MOVSI A,TATOM + PUSH P,FLAGS ;SAVE FLAGS + PUSHJ P,IDVAL ;GET VALUE OF OUTCHAN + POP P,0 + +NEWCHN: TLNE FLAGS,TERBIT ; SEE IF TERPRI + POPJ P, + MOVE C,(AB) ; GET ARGS + MOVE D,1(AB) + POPJ P, + +; HERE IF USING A PRINTB CHANNEL + +BPRINT: TLO FLAGS,BINBIT + SKIPE BUFSTR(B) ; ANY OUTPUT BUFFER? + POPJ P, + +; HERE TO GENERATE A STRING BUFFER + + PUSH P,FLAGS + MOVEI A,BUFLNT ; GET BUFFER LENGTH + PUSHJ P,IBLOCK ; MAKE A BUFFER + MOVSI 0,TWORD+.VECT. ; CLOBBER U TYPE + MOVEM 0,BUFLNT(B) + SETOM (B)) ; -1 THE BUFFER + MOVEI C,1(B) + HRLI C,(B) + BLT C,BUFLNT-1(B) + HRLI B,440700 + MOVE C,(TP) + MOVEM B,BUFSTR(C) ; STOR BYTE POINTER + MOVE 0,[TCHSTR,,BUFLNT*5] + MOVEM 0,BUFSTR-1(C) + POP P,FLAGS + + MOVE B,(TP) + POPJ P, + + +IPRINT: PUSH P,C ; SAVE C + PUSH P,FLAGS ;SAVE PREVIOUS FLAGS + PUSH TP,A ;SAVE ARGUMENT ON TP-STACK + PUSH TP,B + + INTGO ;ALLOW INTERRUPTS HERE + + GETYP A,-1(TP) ;GET THE TYPE CODE OF THE ITEM + SKIPE C,PRNTYP+1(TVP) ; USER TYPE TABLE? + JRST PRDISP +NORMAL: CAIG A,NUMPRI ;PRIMITIVE? + JRST @PRTYPE(A) ;YES-DISPATCH + JRST PUNK ;JUMP TO ERROR ROUTINE IF CODE TOO GREAT + +; HERE FOR USER PRINT DISPATCH + +PRDISP: ADDI C,(A) ; POINT TO SLOT + ADDI C,(A) + SKIPE (C) ; SKIP EITHER A LOSER OR JRST DISP + JRST PRDIS1 ; APPLY EVALUATOR + SKIPN C,1(C) ; GET ADDR OR GO TO PURE DISP + JRST NORMAL + JRST (C) + +PRDIS1: PUSH P,C ; SAVE C + PUSH TP,[TATOM,,-1] ; PUSH ON OUTCHAN FOR SPECBIND + PUSH TP,IMQUOTE OUTCHAN + PUSH TP,-5(TP) + PUSH TP,-5(TP) + PUSH TP,[0] + PUSH TP,[0] + PUSHJ P,SPECBIND + POP P,C ; RESTORE C + PUSH TP,(C) ; PUSH ARGS FOR APPLY + PUSH TP,1(C) + PUSH TP,-9(TP) + PUSH TP,-9(TP) + MCALL 2,APPLY ; APPLY HACKER TO OBJECT + MOVEI E,-8(TP) + PUSHJ P,SSPEC1 ;UNBIND OUTCHAN + SUB TP,[6,,6] ; POP OFF STACK + JRST PNEXT + +; PRINT DISPATCH TABLE + +DISTBL PRTYPE,PUNK,[[TATOM,PATOM],[TFORM,PFORM],[TSEG,PSEG],[TFIX,PFIX] +[TFLOAT,PFLOAT],[TLIST,PLIST],[TVEC,PVEC],[TCHRS,PCHRS],[TCHSTR,PCHSTR] +[TARGS,PARGS],[TUVEC,PUVEC],[TDEFER,PDEFER],[TINTH,PINTH],[THAND,PHAND] +[TILLEG,ILLCH],[TRSUBR,PRSUBR],[TENTER,PENTRY],[TPCODE,PPCODE],[TTYPEW,PTYPEW] +[TTYPEC,PTYPEC],[TTMPLT,TMPRNT],[TLOCD,LOCPT1]] + +PUNK: MOVE C,TYPVEC+1(TVP) ; GET AOBJN-POINTER TO VECTOR OF TYPE ATOMS + GETYP B,-1(TP) ; GET THE TYPE CODE INTO REG B + LSH B,1 ; MULTIPLY BY TWO + HRL B,B ; DUPLICATE IT IN THE LEFT HALF + ADD C,B ; INCREMENT THE AOBJN-POINTER + JUMPGE C,PRERR ; IF POSITIVE, INDEX > VECTOR SIZE + + MOVE B,-2(TP) ; MOVE IN CHANNEL + PUSHJ P,RETIF1 ; START NEW LINE IF NO ROOM + MOVEI A,"# ; INDICATE TYPE-NAME FOLLOWS + PUSHJ P,PITYO + MOVE A,(C) ; GET TYPE-ATOM + MOVE B,1(C) + PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT + PUSH TP,-3(TP) + PUSHJ P,IPRINT ; PRINT ATOM-NAME + SUB TP,[2,,2] ; POP STACK + MOVE B,-2(TP) ; MOVE IN CHANNEL + PUSHJ P,SPACEQ ; MAYBE SPACE + MOVE B,(B) ; RESET THE REAL ARGUMENT POINTER + HRRZ A,(C) ; GET THE STORAGE-TYPE + ANDI A,SATMSK + CAIG A,NUMSAT ; SKIP IF TEMPLATE + JRST @UKTBL(A) ; USE DISPATCH TABLE ON STORAGE TYPE + JRST TMPRNT ; PRINT TEMPLATED DATA STRUCTURE + +DISTBS UKTBL,POCTAL,[[S2WORD,PLIST],[S2NWORD,PVEC],[SNWORD,PUVEC],[SATOM,PATOM] +[SCHSTR,PCHSTR],[SFRAME,PFRAME],[SARGS,PARGS],[SPVP,PPVP],[SLOCID,LOCPT],[SLOCA,LOCP] +[SLOCV,LOCP],[SLOCU,LOCP],[SLOCS,LOCP],[SLOCL,LOCP],[SLOCN,LOCP],[SASOC,ASSPNT] +[SLOCT,LOCP]] + + ; SELECK AN ILLEGAL + +ILLCH: MOVEI B,-1(TP) + JRST ILLCHO + + ; PRINT INTERRUPT HANDLER + +PHAND: MOVE B,-2(TP) ; MOVE CHANNEL INTO B + PUSHJ P,RETIF1 + MOVEI A,"# + PUSHJ P,PITYO ; SAY "FUNNY TYPE" + MOVSI A,TATOM + MOVE B,MQUOTE HANDLER + PUSH TP,-3(TP) ; PUSH CHANNEL ON FOR IPRINT + PUSH TP,-3(TP) + PUSHJ P,IPRINT ; PRINT THE TYPE NAME + SUB TP,[2,,2] ; POP CHANNEL OFF STACK + MOVE B,-2(TP) ; GET CHANNEL + PUSHJ P,SPACEQ ; SPACE MAYBE + SKIPN B,(TP) ; GET ARG BACK + JRST PNEXT + MOVE A,INTFCN(B) ; PRINT FUNCTION FOR NOW + MOVE B,INTFCN+1(B) + PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT + PUSH TP,-3(TP) + PUSHJ P,IPRINT ; PRINT THE INT FUNCTION + SUB TP,[2,,2] ; POP CHANNEL OFF + JRST PNEXT + +; PRINT INT HEADER + +PINTH: MOVE B,-2(TP) ; GET CHANNEL INTO B + PUSHJ P,RETIF1 + MOVEI A,"# + PUSHJ P,PITYO + MOVSI A,TATOM ; AND NAME + MOVE B,MQUOTE IHEADER + PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT + PUSH TP,-3(TP) + PUSHJ P,IPRINT + MOVE B,-4(TP) ; GET CHANNEL INTO B + PUSHJ P,SPACEQ ; MAYBE SPACE + SKIPN B,-2(TP) ; INT HEADER BACK + JRST PNEXT + MOVE A,INAME(B) ; GET NAME + MOVE B,INAME+1(B) + PUSHJ P,IPRINT + SUB TP,[2,,2] ; CLEAN OFF STACK + JRST PNEXT + + +; PRINT ASSOCIATION BLOCK + +ASSPNT: MOVEI A,"( ; MAKE IT BE (ITEN INDIC VAL) + MOVE B,-2(TP) ; GET CHANNEL INTO B + PUSHJ P,PRETIF ; MAKE ROOM AND PRINT + SKIPA C,[-3,,0] ; # OF FIELDS +ASSLP: PUSHJ P,SPACEQ + MOVE D,(TP) ; RESTORE GOODIE + ADD D,ASSOFF(C) ; POINT TO FIELD + MOVE A,(D) ; GET IT + MOVE B,1(D) + PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT + PUSH TP,-3(TP) + PUSHJ P,IPRINT ; AND PRINT IT + SUB TP,[2,,2] ; POP OFF CHANNEL + AOBJN C,ASSLP + + MOVEI A,") + MOVE B,-2(TP) ; GET CHANNEL INTO B + PUSHJ P,PRETIF ; CLOSE IT + JRST PNEXT + +ASSOFF: ITEM + INDIC + VAL + ; PRINT TYPE-C AND TYPE-W + +PTYPEW: HRRZ A,(TP) ; POSSIBLE RH + HLRZ B,(TP) + MOVE C,MQUOTE TYPE-W + JRST PTYPEX + +PTYPEC: HRRZ B,(TP) + MOVEI A,0 + MOVE C,MQUOTE TYPE-C + +PTYPEX: PUSH P,B + PUSH P,A + PUSH TP,$TATOM + PUSH TP,C + MOVEI A,2 + MOVE B,-4(TP) ; GET CHANNEL INTO B + PUSHJ P,RETIF ; ROOM TO START? + MOVEI A,"% + PUSHJ P,PITYO + MOVEI A,"< + PUSHJ P,PITYO + POP TP,B ; GET NAME + POP TP,A + PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT + PUSH TP,-3(TP) + PUSHJ P,IPRINT ; AND PRINT IT AS 1ST ELEMENT + SUB TP,[2,,2] ; POP OFF CHANNEL + MOVE B,-2(TP) ; GET CHANNEL INTO B + PUSHJ P,SPACEQ ; MAYBE SPACE + MOVE A,-1(P) ; TYPE CODE + ASH A,1 + HRLI A,(A) ; MAKE SURE WINS + ADD A,TYPVEC+1(TVP) + JUMPL A,PTYPX1 ; JUMP FOR A WINNER + PUSH TP,$TATOM + PUSH TP,EQUOTE BAD-TYPE-CODE + JRST CALER1 + +PTYPX1: MOVE B,1(A) ; GET TYPE NAME + HRRZ A,(A) ; AND SAT + ANDI A,SATMSK + MOVEM A,-1(P) ; AND SAVE IT + MOVSI A,TATOM + PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT + PUSH TP,-3(TP) + PUSHJ P,IPRINT ; OUT IT GOES + SUB TP,[2,,2] ; POP OFF CHANNEL + MOVE B,-2(TP) ; GET CHANNEL INTO B + PUSHJ P,SPACEQ ; MAYBE SPACE + MOVE A,-1(P) ; GET SAT BACK + MOVE B,@STBL(A) + MOVSI A,TATOM ; AND PRINT IT + PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT + PUSH TP,-3(TP) + PUSHJ P,IPRINT + SUB TP,[2,,2] ; POP OFF STACK + SKIPN B,(P) ; ANY EXTRA CRAP? + JRST PTYPX2 + + MOVE B,-2(TP) ; GET CHANNEL INTO B + PUSHJ P,SPACEQ + MOVE B,(P) + MOVSI A,TFIX + PUSH TP,-3(TP) ; PUSH CHANNELS FOR IPRINT + PUSH TP,-3(TP) + PUSHJ P,IPRINT ; PRINT EXTRA + SUB TP,[2,,2] ; POP OFF CHANNEL + +PTYPX2: MOVEI A,"> + MOVE B,-2(TP) ; GET CHANNEL INTO B + PUSHJ P,PRETIF + SUB P,[2,,2] ; FLUSH CRUFT + JRST PNEXT + + ; PRINT PURE CODE POINTER + +PPCODE: MOVEI A,2 + MOVE B,-2(TP) ; GET CHANNEL INTO B + PUSHJ P,RETIF + MOVEI A,"% + PUSHJ P,PITYO + MOVEI A,"< + PUSHJ P,PITYO + MOVSI A,TATOM ; PRINT SUBR CALL + MOVE B,MQUOTE PCODE + PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT + PUSH TP,-3(TP) + PUSHJ P,IPRINT + MOVE B,-4(TP) ; GET CHANNEL INTO B + PUSHJ P,SPACEQ ; MAYBE SPACE? + HLRZ A,-2(TP) ; OFFSET TO VECTOR + ADD A,PURVEC+1(TVP) ; SLOT TO A + MOVE A,(A) ; SIXBIT NAME + PUSH P,FLAGS + PUSHJ P,6TOCHS ; TO A STRING + POP P,FLAGS + PUSHJ P,IPRINT + MOVE B,-4(TP) ; GET CHANNEL INTO B + PUSHJ P,SPACEQ + HRRZ B,-2(TP) ; GET OFFSET + MOVSI A,TFIX + PUSHJ P,IPRINT + SUB TP,[2,,2] ; POP CHANNEL OFF STACK + MOVEI A,"> + MOVE B,-2(TP) ; GET CHANNEL INTO B + PUSHJ P,PRETIF ; CLOSE THE FORM + JRST PNEXT + + + ; PRINT SUB-ENTRY TO RSUBR + +PENTRY: MOVE B,(TP) ; GET BLOCK + GETYP A,(B) ; TYPE OF 1ST ELEMENT + CAIE A,TRSUBR ; RSUBR, OK + JRST PENT1 + MOVSI A,TATOM ; UNLINK + HLLM A,(B) + MOVE A,1(B) + MOVE A,3(A) + MOVEM A,1(B) +PENT2: MOVEI A,2 ; CHECK ROOM + MOVE B,-2(TP) ; GET CHANNEL INTO B + PUSHJ P,RETIF + MOVEI A,"% ; SETUP READ TIME MACRO + PUSHJ P,PITYO + MOVEI A,"< + PUSHJ P,PITYO + MOVSI A,TATOM + MOVE B,MQUOTE RSUBR-ENTRY + PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT + PUSH TP,-3(TP) + PUSHJ P,IPRINT + MOVE B,-4(TP) + PUSHJ P,SPACEQ ; MAYBE SPACE + MOVEI A,"' ; QUOTE TO AVOID EVALING IT + PUSHJ P,PRETIF + MOVSI A,TVEC + MOVE B,-2(TP) + PUSHJ P,IPRINT + MOVE B,-4(TP) ; GET CHANNEL INTO B + PUSHJ P,SPACEQ + MOVE B,-2(TP) + HRRZ B,2(B) + MOVSI A,TFIX + PUSHJ P,IPRINT + MOVEI A,"> + SUB TP,[2,,2] ; POP CHANNEL OFF STACK + MOVE B,-2(TP) ; GET CHANNEL INTO B + PUSHJ P,PRETIF + JRST PNEXT + +PENT1: CAIN A,TATOM + JRST PENT2 + PUSH TP,$TATOM + PUSH TP,EQUOTE BAD-ENTRY-BLOCK + JRST CALER1 + + ; HERE TO PRINT TEMPLATED DATA STRUCTURE + +TMPRNT: PUSH P,FLAGS ; SAVE FLAGS + MOVE A,(TP) ; GET POINTER + GETYP A,(A) ; GET SAT + PUSH P,A ; AND SAVE IT + MOVEI A,"{ ; OPEN SQUIGGLE + MOVE B,-2(TP) ; GET CHANNEL INTO B + PUSHJ P,PRETIF ; PRINT WITH CHECKING + HLRZ A,(TP) ; GET AMOUNT RESTED OFF + SUBI A,1 + PUSH P,A ; AND SAVE IT + MOVE A,-1(P) ; GET SAT + SUBI A,NUMSAT+1 ; FIXIT UP + HRLI A,(A) + ADD A,TD.LNT+1(TVP) ; CHECK FOR WINNAGE + JUMPGE A,BADTPL ; COMPLAIN + HRRZS C,(TP) ; GET LENGTH + XCT (A) ; INTO B + SUB B,(P) ; FUDGE FOR RESTS + MOVEI B,-1(B) ; FUDGE IT + PUSH P,B ; AND SAVE IT + +TMPRN1: AOS C,-1(P) ; GET ELEMENT OF INTEREST + SOSGE (P) ; CHECK FOR ANY LEFT + JRST TMPRN2 ; ALL DONE + + MOVE B,(TP) ; POINTER + HRRZ 0,-2(P) ; SAT + PUSHJ P,TMPLNT ; GET THE ITEM + MOVE FLAGS,-3(P) ; RESTORE FLAGS + PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT + PUSH TP,-3(TP) + PUSHJ P,IPRINT ; PRINT THIS ELEMENT + SUB TP,[2,,2] ; POP CHANNEL OFF STACK + MOVE B,-2(TP) ; GET CHANNEL INTO B + SKIPE (P) ; IF NOT LAST ONE THEN + PUSHJ P,SPACEQ ; SEPARATE WITH A SPACE + JRST TMPRN1 + +TMPRN2: SUB P,[4,,4] + MOVE B,-2(TP) + MOVEI A,"} ; CLOSE THIS GUY + PUSHJ P,PRETIF + JRST PNEXT + + + ; RSUBR PRINTING ROUTINES. ON PRINTB CHANNELS, WRITES OUT +; COMPACT BINARY. ON PRINT CHANNELS ALL IS ASCII + +PRSUBR: MOVE A,(TP) ; GET RSUBR IN QUESTION + GETYP A,(A) ; CHECK FOR PURE RSUBR + CAIN A,TPCODE + JRST PRSBRP ; PRINT IT SPECIAL WAY + + TLNN FLAGS,BINBIT ; SKIP IF BINARY OUTPUT + JRST ARSUBR + + PUSH P,FLAGS + MOVSI A,TRSUBR ; FIND FIXUPS + MOVE B,(TP) + HLRE D,1(B) ; -LENGTH OF CODE VEC + PUSH P,D ; SAVE SAME + MOVSI C,TATOM + MOVE D,MQUOTE RSUBR + PUSHJ P,IGET ; GO GET THEM + JUMPE B,RCANT ; NO FIXUPS, BINARY LOSES + PUSH TP,A ; SAVE FIXUP LIST + PUSH TP,B + + MOVNI A,1 ; USE ^C AS MARKER FOR RSUBR + MOVE FLAGS,-1(P) ; RESTORE FLAGS + MOVE B,-4(TP) ; GET CHANNEL FOR PITYO + PUSHJ P,PITYO ; OUT IT GOES + +PRSBR1: MOVE B,-4(TP) + PUSHJ P,BFCLS1 ; FLUSH OUT CURRENT BUFFER + + MOVE B,-4(TP) ; CHANNEL BACK + MOVN E,(P) ; LENGTH OF CODE + PUSH P,E + HRROI A,(P) ; POINT TO SAME + PUSHJ P,DOIOTO ; OUT GOES COUNT + MOVSI C,TCODE + MOVEM C,ASTO(PVP) ; FOR IOT INTERRUPTS + MOVE A,-2(TP) ; GET POINTER TO CODE + MOVE A,1(A) + PUSHJ P,DOIOTO ; IOT IT OUT + POP P,E + ADDI E,1 ; UPDATE ACCESS + ADDM E,ACCESS(B) + SETZM ASTO(PVP) ; UNSCREW A + +; NOW PRINT OUT NORMAL RSUBR VECTOR + + MOVE FLAGS,-1(P) ; RESTORE FLAGS + SUB P,[1,,1] + MOVE B,-2(TP) ; GET RSUBR VECTOR + PUSHJ P,PRBODY ; PRINT ITS BODY + +; HERE TO PRINT BINARY FIXUPS + + MOVEI E,0 ; 1ST COMPUTE LENGTH OF FIXUPS + SKIPN A,(TP) ; LIST TO A + JRST PRSBR5 ; EMPTY, DONE + JUMPL A,UFIXES ; JUMP IF FIXUPS IN UVECTOR FORM + ADDI E,1 ; FOR VERS + +PRSBR6: HRRZ A,(A) ; NEXT? + JUMPE A,PRSBR5 + GETYP B,(A) + CAIE B,TDEFER ; POSSIBLE STRING + JRST PRSBR7 ; COULD BE ATOM + MOVE B,1(A) ; POSSIBLE STRINGER + GETYP C,(B) + CAIE C,TCHSTR ; YES!!! + JRST BADFXU ; LOSING FIXUPS + HRRZ C,(B) ; # OF CHARS TO C + ADDI C,5+5 ; ROUND AND ADD FOR COUNT + IDIVI C,5 ; TO WORDS + ADDI E,(C) + JRST FIXLST ; COUNT FOR USE LIST ETC. + +PRSBR7: GETYP B,(A) ; GET TYPE + CAIE B,TATOM + JRST BADFXU + ADDI E,1 + +FIXLST: HRRZ A,(A) ; REST IT TO OLD VAL + JUMPE A,BADFXU + GETYP B,(A) ; FIX? + CAIE B,TFIX + JRST BADFXU + MOVEI D,1 + HRRZ A,(A) ; TO USE LIST + JUMPE A,BADFXU + GETYP B,(A) + CAIE B,TLIST + JRST BADFXU ; LOSER + MOVE C,1(A) ; GET LIST + +PRSBR8: JUMPE C,PRSBR9 + GETYP B,(C) ; TYPE OK? + CAIE B,TFIX + JRST BADFXU + HRRZ C,(C) + AOJA D,PRSBR8 ; LOOP + +PRSBR9: ADDI D,2 ; ROUND UP + ASH D,-1 ; DIV BY 2 FOR TWO GOODIES PER HWORD + ADDI E,(D) + JRST PRSBR6 + +PRSBR5: PUSH P,E ; SAVE LENGTH OF FIXUPS + PUSH TP,$TUVEC ; SLOT FOR BUFFER POINTER + PUSH TP,[0] + +PFIXU1: MOVE B,-6(TP) ; START LOOPING THROUGH CHANNELS + PUSHJ P,BFCLS1 ; FLUSH BUFFER + MOVE B,-6(TP) ; CHANNEL BACK + MOVEI C,BUFSTR-1(B) ; SETUP BUFFER + PUSHJ P,BYTDOP ; FIND D.W. + SUBI A,BUFLNT+1 + HRLI A,-BUFLNT + MOVEM A,(TP) + MOVE E,(P) ; LENGTH OF FIXUPS + SETZB C,D ; FOR EOUT + PUSHJ P,EOUT + MOVE C,-2(TP) ; FIXUP LIST + MOVE E,1(C) ; HAVE VERS + PUSHJ P,EOUT ; OUT IT GOES + +PFIXU2: HRRZ C,(C) ; FIRST THING + JUMPE C,PFIXU3 ; DONE? + GETYP A,(C) ; STRING OR ATOM + CAIN A,TATOM ; MUST BE STRING + JRST PFIXU4 + MOVE A,1(C) ; POINT TO POINTER + HRRZ D,(A) ; LENGTH + IDIVI D,5 + PUSH P,E ; SAVE REMAINDER + MOVEI E,1(D) + MOVNI D,(D) + MOVSI D,(D) + PUSH P,D + PUSHJ P,EOUT + MOVEI D,0 +PFXU1A: MOVE A,1(C) ; RESTORE POINTER + HRRZ A,1(A) ; BYTE POINTER + ADD A,(P) + MOVE E,(A) + PUSHJ P,EOUT + MOVE A,[1,,1] + ADDB A,(P) + JUMPL A,PFXU1A + MOVE D,-1(P) ; LAST WORD + MOVE A,1(C) + HRRZ A,1(A) + ADD A,(P) + SKIPE E,D + MOVE E,(A) ; LAST WORD OF CHARS + IOR E,PADS(D) + PUSHJ P,EOUT ; OUT + SUB P,[1,,1] + JRST PFIXU5 + +PADS: ASCII /#####/ + ASCII /####/ + ASCII /###/ + ASCII /##/ + ASCII /#/ + +PFIXU4: HRRZ E,(C) ; GET CURRENT VAL + MOVE E,1(E) + PUSHJ P,ATOSQ ; GET SQUOZE + JRST BADFXU + TLO E,400000 ; USE TO DIFFERENTIATE BETWEEN STRING + PUSHJ P,EOUT + +; HERE TO WRITE OUT LISTS + +PFIXU5: HRRZ C,(C) ; POINT TO CURRENT VALUE + HRLZ E,1(C) + HRRZ C,(C) ; POINT TO USES LIST + HRRZ D,1(C) ; GET IT + +PFIXU6: TLCE D,400000 ; SKIP FOR RH + HRLZ E,1(D) ; SETUP LH + JUMPG D,.+3 + HRR E,1(D) + PUSHJ P,EOUT ; WRITE IT OUT + HRR D,(D) + TRNE D,-1 ; SKIP IF DONE + JRST PFIXU6 + + TRNE E,-1 ; SKIP IF ZERO BYTE EXISTS + MOVEI E,0 + PUSHJ P,EOUT + JRST PFIXU2 ; DO NEXT + +PFIXU3: HLRE C,(TP) ; -AMNT LEFT IN BUFFER + MOVN D,C ; PLUS SAME + ADDI C,BUFLNT ; WORDS USED TO C + JUMPE C,PFIXU7 ; NONE USED, LEAVE + MOVSS C ; START SETTING UP BTB + MOVN A,C ; ALSO FINAL IOT POINTER + HRR C,(TP) ; PDL POINTER PART OF BTB + SUBI C,1 + HRLI D,C ; CONTINUE SETTING UP BTB + POP C,@D ; MOVE 'EM DOWN + TLNE C,-1 + JRST .-2 + HRRI A,@D ; OUTPUT POINTER + ADDI A,1 + MOVSI B,TUVEC + MOVEM B,ASTO(PVP) + MOVE B,-6(TP) + PUSHJ P,DOIOTO ; WRITE IT OUT + SETZM ASTO(PVP) + +PFIXU7: SUB TP,[4,,4] + SUB P,[2,,2] + JRST PNEXT + +; ROUTINE TO OUTPUT CONTENTS OF E + +EOUT: MOVE B,-6(TP) ; CHANNEL + AOS ACCESS(B) + MOVE A,(TP) ; BUFFER POINTER + MOVEM E,(A) + AOBJP A,.+3 ; COUNT AND GO + MOVEM A,(TP) + POPJ P, + + SUBI A,BUFLNT ; SET UP IOT POINTER + HRLI A,-BUFLNT + MOVEM A,(TP) ; RESET SAVED POINTER + MOVSI 0,TUVEC + MOVEM 0,ASTO(PVP) + MOVSI 0,TLIST + MOVEM 0,DSTO(PVP) + MOVEM 0,CSTO(PVP) + PUSHJ P,DOIOTO ; OUT IT GOES + SETZM ASTO(PVP) + SETZM CSTO(PVP) + SETZM DSTO(PVP) + POPJ P, + +; HERE IF UVECOR FORM OF FIXUPS + +UFIXES: PUSH TP,$TUVEC + PUSH TP,A ; SAVE IT + +UFIX1: MOVE B,-6(TP) ; GET SAME + PUSHJ P,BFCLS1 ; FLUSH OUT BUFFER + HLRE C,(TP) ; GET LENGTH + MOVMS C + PUSH P,C + HRROI A,(P) ; READY TO ZAP IT OUT + PUSHJ P,DOIOTO ; ZAP! + SUB P,[1,,1] + HLRE C,(TP) ; LENGTH BACK + MOVMS C + ADDI C,1 + ADDM C,ACCESS(B) ; UPDATE ACCESS + MOVE A,(TP) ; NOW THE UVECTOR + MOVSI C,TUVEC + MOVEM C,ASTO(PVP) + PUSHJ P,DOIOTO ; GO + SETZM ASTO(PVP) + SUB P,[1,,1] + SUB TP,[4,,4] + JRST PNEXT + +RCANT: PUSH TP,$TATOM + PUSH TP,EQUOTE RSUBR-LACKS-FIXUPS + JRST CALER1 + + +BADFXU: PUSH TP,$TATOM + PUSH TP,EQUOTE BAD-FIXUPS + JRST CALER1 + +PRBODY: TDZA C,C ; FLAG SAYING FLUSH CODE +PRBOD1: MOVEI C,1 ; PRINT CODE ALSO + PUSH P,FLAGS + PUSH TP,$TRSUBR + PUSH TP,B + PUSH P,C + MOVEI A,"[ ; START VECTOR TEXT + MOVE B,-6(TP) ; GET CHANNEL FOR PITYO + PUSHJ P,PITYO + POP P,C + MOVE B,(TP) ; RSUBR BACK + JUMPN C,PRSON ; GO START PRINTING + MOVEI A,"0 ; PLACE SAVER FOR CODE VEC + MOVE B,-6(TP) ; GET CHANNEL FOR PITYO + PUSHJ P,PITYO + +PRSBR2: MOVE B,[2,,2] ; BUMP VECTOR + ADDB B,(TP) + JUMPGE B,PRSBR3 ; NO SPACE IF LAST + MOVE B,-6(TP) ; GET CHANNEL FOR SPACEQ + PUSHJ P,SPACEQ + SKIPA B,(TP) ; GET BACK POINTER +PRSON: JUMPGE B,PRSBR3 + GETYP 0,(B) ; SEE IF RSUBR POINTED TO + CAIN 0,TENTER + JRST .+3 ; JUMP IF RSUBR ENTRY + CAIE 0,TRSUBR ; YES! + JRST PRSB10 ; COULD BE SUBR/FSUBR + MOVE C,1(B) ; GET RSUBR + PUSH P,0 ; SAVE TYPE FOUND + GETYP 0,2(C) ; SEE IF ATOM + CAIE 0,TATOM + JRST PRSBR4 + MOVE B,3(C) ; GET ATOM NAME + PUSHJ P,IGVAL ; GO LOOK + MOVE C,(TP) ; ORIG RSUBR BACK + GETYP A,A + POP P,0 ; DESIRED TYPE + CAIE 0,(A) ; SAME TYPE + JRST PRSBR4 + MOVE D,1(C) + MOVE 0,3(D) ; NAME OF RSUBR IN QUESTION + CAME 0,3(B) ; WIN? + JRST PRSBR4 + MOVEM 0,1(C) + MOVSI A,TATOM + MOVEM A,(C) ; UNLINK + +PRSBR4: MOVE FLAGS,(P) ; RESTORE FLAGS + MOVE B,(TP) + MOVE A,(B) + MOVE B,1(B) ; PRINT IT + PUSH TP,-7(TP) ; PUSH CHANNEL FOR IPRINT + PUSH TP,-7(TP) + PUSHJ P,IPRINT + SUB TP,[2,,2] ; POP OFF CHANNEL + JRST PRSBR2 + +PRSB10: CAIE 0,TSUBR ; SUBR? + CAIN 0,TFSUBR + JRST .+2 + JRST PRSBR4 + MOVE C,1(B) ; GET LOCN OF SUBR OR FSUBR + MOVE C,@-1(C) ; NAME OF IT + MOVEM C,1(B) ; SMASH + MOVSI C,TATOM ; AND TYPE + MOVEM C,(B) + JRST PRSBR4 + +PRSBR3: MOVEI A,"] + MOVE B,-6(TP) + PUSHJ P,PRETIF ; CLOSE IT UP + SUB TP,[2,,2] ; FLUSH CRAP + POP P,FLAGS + POPJ P, + + + ; HERE TO PRINT PURE RSUBRS + +PRSBRP: MOVEI A,2 ; WILL "%<" FIT? + MOVE B,-2(TP) ; GET CHANNEL FOR RETIF + PUSHJ P,RETIF + MOVEI A,"% + PUSHJ P,PITYO + MOVEI A,"< + PUSHJ P,PITYO + MOVSI A,TATOM + MOVE B,MQUOTE RSUBR + PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT + PUSH TP,-3(TP) + PUSHJ P,IPRINT ; PRINT IT OUT + SUB TP,[2,,2] ; POP OFF CHANNEL + MOVE B,-2(TP) + PUSHJ P,SPACEQ ; MAYBE SPACE + MOVEI A,"' ; QUOTE THE VECCTOR + PUSHJ P,PRETIF + MOVE B,(TP) ; GET RSUBR BODY BACK + PUSH TP,$TFIX ; STUFF THE STACK + PUSH TP,[0] + PUSHJ P,PRBOD1 ; PRINT AND UNLINK + SUB TP,[2,,2] ; GET JUNK OFF STACK + MOVE B,-2(TP) ; GET CHANNEL FOR RETIF + MOVEI A,"> + PUSHJ P,PRETIF + JRST PNEXT + +; HERE TO PRINT ASCII RSUBRS + +ARSUBR: PUSH P,FLAGS ; SAVE FROM GET + MOVSI A,TRSUBR + MOVE B,(TP) + MOVSI C,TATOM + MOVE D,MQUOTE RSUBR + PUSHJ P,IGET ; TRY TO GET FIXUPS + POP P,FLAGS + JUMPE B,PUNK ; NO FIXUPS LOSE + GETYP A,A + CAIE A,TLIST ; ARE FIXUPS A LIST? + JRST PUNK ; NO, AGAIN LOSE + PUSH TP,$TLIST + PUSH TP,B ; SAVE FIXUPS + MOVEI A,17. + + MOVE B,-4(TP) + PUSHJ P,RETIF + PUSH P,[440700,,[ASCIZ /%<FIXUP!-RSUBRS!-/]] + +AL1: ILDB A,(P) ; GET CHAR + JUMPE A,.+3 + PUSHJ P,PITYO + JRST AL1 + + SUB P,[1,,1] + PUSHJ P,SPACEQ + + MOVEI A,"' + PUSHJ P,PRETIF ; QUOTE TO AVOID ADDITIONAL EVAL + MOVE B,-2(TP) ; PRINT ACTUAL KLUDGE + PUSHJ P,PRBOD1 + MOVE B,-4(TP) ; GET CHANNEL FOR SPACEQ + PUSHJ P,SPACEQ + MOVEI A,"' ; DONT EVAL FIXUPS EITHER + PUSHJ P,PRETIF + POP TP,B + POP TP,A + PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT + PUSH TP,-3(TP) + PUSHJ P,IPRINT + SUB TP,[2,,2] ; POP CHANNEL OFF STACK + MOVE B,-2(TP) ; GET CHANNEL INTO B + MOVEI A,"> + PUSHJ P,PRETIF + JRST PNEXT + + ; HERE TO DO LOCATIVES (PRINT CONTENTS THEREOF) + +LOCP: PUSH TP,-1(TP) + PUSH TP,-1(TP) + PUSH P,0 + MCALL 1,IN ; GET ITS CONTENTS FROM "IN" + POP P,0 + PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT + PUSH TP,-3(TP) + PUSHJ P,IPRINT ; PRINT IT + SUB TP,[2,,2] ; POP CHANNEL OFF STACK + JRST PNEXT + ;INTERNAL SUBROUTINE TO HANDLE CHARACTER OUTPUT +;B CONTAINS CHANNEL +;PRINTER ITYO USED FOR FLATSIZE FAKE OUT +PITYO: TLNN FLAGS,FLTBIT + JRST ITYO +PITYO1: PUSH TP,[TTP,,0] ; PUSH ON TP POINTER + PUSH TP,B + TLNE FLAGS,UNPRSE ;SKIPS UNPRSE NOT SET + JRST ITYO+2 + AOS FLTSIZ ;FLATSIZE DOESN'T PRINT + ;INSTEAD IT COUNTS THE CHARACTERS THAT WOULD BE OUTPUT + SOSGE FLTMAX ;UNLESS THE MAXIMUM IS EXCEEDED + JRST .+4 + POP TP,B ; GET CHANNEL BACK + SUB TP,[1,,1] + POPJ P, + MOVEI E,(B) ; GET POINTER FOR UNBINDING + PUSHJ P,SSPEC1 + MOVE P,UPB+8 ; RESTORE P + POP TP,B ; GET BACK TP POINTER + PUSH P,0 ; SAVE FLAGS + MOVE TP,B ; RESTORE TP +PITYO3: MOVEI C,(TB) + CAILE C,1(TP) + JRST PITYO2 + POP P,0 ; RESTORE FLAGS + MOVSI A,TFALSE ;IN WHICH CASE IT IMMEDIATELY GIVES UP AND RETURNS FALSE + MOVEI B,0 + POPJ P, + +PITYO2: HRR TB,OTBSAV(TB) ; RESTORE TB + JRST PITYO3 + + + ;THE REAL THING +;NOTE THAT THE FOLLOWING CODE HAS BUGS IF IT IS PRINTING OUT LONG +;CHARACTER STRINGS +; (NOTE THAT THE ABOVE COMMENT, IF TRUE, SHOULD NOT BE ADMITTED.) +ITYO: PUSH TP,$TCHAN + PUSH TP,B + PUSH P,FLAGS ;SAVE STUFF + PUSH P,C +ITYOCH: PUSH P,A ;SAVE OUTPUT CHARACTER + + +ITYO1: TLNE FLAGS,UNPRSE ;SKIPS UNPRSE NOT SET + JRST UNPROUT ;IF FROM UNPRSE, STASH IN STRING + CAIE A,^L ;SKIP IF THIS IS A FORM-FEED + JRST NOTFF + SETZM LINPOS(B) ;ZERO THE LINE NUMBER + JRST ITYXT + +NOTFF: CAIE A,15 ;SKIP IF IT IS A CR + JRST NOTCR + SETZM CHRPOS(B) ;ZERO THE CHARACTER POSITION + PUSHJ P,WXCT ;OUTPUT THE C-R + PUSHJ P,AOSACC ; BUMP COUNT + AOS C,LINPOS(B) ;ADD ONE TO THE LINE NUMBER + CAMG C,PAGLN(B) ;SKIP IF THIS TAKES US PAST PAGE END + JRST ITYXT1 + + SETZM LINPOS(B) ;ZERO THE LINE POSITION +; PUSHJ P,WXCT ; REMOVED FOR NOW +; PUSHJ P,AOSACC +; MOVEI A,^L ; DITTO + JRST ITYXT1 + +NOTCR: CAIN A,^I ;SKIP IF NOT TAB + JRST TABCNT + CAIE A,10 ; BACK SPACE + JRST .+3 + SOS CHRPOS(B) ; BACK UP ONE + JRST ITYXT + CAIE A,^J ;SKIP IF LINE FEED + AOS CHRPOS(B) ;ADD TO CHARACTER NUMBER + +ITYXT: PUSHJ P,AOSACC ; BUMP ACCESS +ITYXTA: PUSHJ P,WXCT ;OUTPUT THE CHARACTER +ITYXT1: POP P,A ;RESTORE THE ORIGINAL CHARACTER + +ITYRET: POP P,C ;RESTORE REGS & RETURN + POP P,FLAGS + POP TP,B ; GET CHANNEL BACK + SUB TP,[1,,1] + POPJ P, + +TABCNT: PUSH P,D + MOVE C,CHRPOS(B) + ADDI C,8. ;INCREMENT COUNT BY EIGHT (MOD EIGHT) + IDIVI C,8. + IMULI C,8. + MOVEM C,CHRPOS(B) ;REPLACE COUNT + POP P,D + JRST ITYXT + +UNPROUT: POP P,A ;GET BACK THE ORIG CHAR + IDPB A,UPB+2 ;DEPOSIT USING BYTE POINTER I PUSHED LONG AGO + SOS UPB+1 + JRST ITYRET ;RETURN + +AOSACC: TLNN FLAGS,BINBIT + JRST NRMACC + AOS C,ACCESS-1(B) ; COUNT CHARS IN WORD + CAMN C,[TFIX,,1] + AOS ACCESS(B) + CAMN C,[TFIX,,5] + HLLZS ACCESS-1(B) + POPJ P, + +NRMACC: AOS ACCESS(B) + POPJ P, + +SPACEQ: MOVEI A,40 + TLNE FLAGS,FLTBIT+BINBIT + JRST PITYO ; JUST OUTPUT THE SPACE + PUSH P,[1] ; PRINT SPACE IF NOT END OF LINE + MOVEI A,1 + JRST RETIF2 + +RETIF1: MOVEI A,1 + +RETIF: PUSH P,[0] + TLNE FLAGS,FLTBIT+BINBIT + JRST SPOPJ ; IF WE ARE IN FLATSIZE THEN ESCAPE +RETIF2: PUSH P,FLAGS +RETCH: PUSH P,A + +RETCH1: ADD A,CHRPOS(B) ;ADD THE CHARACTER POSITION + SKIPN CHRPOS(B) ; IF JUST RESET, DONT DO IT AGAIN + JRST RETXT + CAMG A,LINLN(B) ;SKIP IF GREATER THAN LINE LENGTH + JRST RETXT1 + + MOVEI A,^M ;FORCE A CARRIAGE RETURN + SETZM CHRPOS(B) + PUSHJ P,WXCT + PUSHJ P,AOSACC ; BUMP CHAR COUNT + MOVEI A,^J ;AND FORCE A LINE FEED + PUSHJ P,WXCT + PUSHJ P,AOSACC ; BUMP CHAR COUNT + AOS A,LINPOS(B) + CAMG A,PAGLN(B) ;AT THE END OF THE PAGE ? + JRST RETXT +; MOVEI A,^L ;IF SO FORCE A FORM FEED +; PUSHJ P,WXCT +; PUSHJ P,AOSACC ; BUMP CHAR COUNT + SETZM LINPOS(B) + +RETXT: POP P,A + + POP P,FLAGS +SPOPJ: SUB P,[1,,1] + POPJ P, ;RETURN + +PRETIF: PUSH P,A ;SAVE CHAR + PUSHJ P,RETIF1 + POP P,A + JRST PITYO + +RETIF3: TLNE FLAGS,FLTBIT ; NOTHING ON FLATSIZE + POPJ P, + PUSH P,[0] + PUSH P,FLAGS + HRRI FLAGS,2 ; PRETEND ONLY 1 CHANNEL + PUSH P,A + JRST RETCH1 + +RETXT1: SKIPN -2(P) ; SKIP IF SPACE HACK + JRST RETXT + MOVEI A,40 + PUSHJ P,WXCT + AOS CHRPOS(B) + PUSH P,C + PUSHJ P,AOSACC + POP P,C + JRST RETXT + + ;THIS IS CODE TO HANDLE UNKNOWN DATA TYPES. +;IT PRINTS "*XXXXXX*XXXXXXXXXXXX*", WHERE THE FIRST NUMBER IS THE +;TYPE CODE IN OCTAL, THE SECOND IS THE VALUE FIELD IN OCTAL. +PRERR: MOVEI A,21. ;CHECK FOR 21. SPACES LEFT ON PRINT LINE + MOVE B,-2(TP) ; GET CHANNEL INTO B + PUSHJ P,RETIF ;INSERT CARRIAGE RETURN IF NOT ENOUGH + MOVEI A,"* ;JUNK TO INDICATE ERROR PRINTOUT IN OCTAL + PUSHJ P,PITYO ;TYPE IT + + MOVE E,[000300,,-2(TP)] ;GET POINTER INDEXED OFF TP SO THAT + ;TYPE CODE MAY BE OBTAINED FOR PRINTING. + MOVEI D,6 ;# OF OCTAL DIGITS IN HALF WORD +OCTLP1: ILDB A,E ;GET NEXT 3-BIT BYTE OF TYPE CODE + IORI A,60 ;OR-IN 60 FOR ASCII DIGIT + PUSHJ P,PITYO ;PRINT IT + SOJG D,OCTLP1 ;REPEAT FOR SIX CHARACTERS + +PRE01: MOVEI A,"* ;DELIMIT TYPE CODE FROM VALUE FIELD + PUSHJ P,PITYO + + HRLZI E,(410300,,(TP)) ;BYTE POINTER TO SECOND WORD + ;INDEXED OFF TP + MOVEI D,12. ;# OF OCTAL DIGITS IN A WORD +OCTLP2: LDB A,E ;GET 3 BITS + IORI A,60 ;CONVERT TO ASCII + PUSHJ P,PITYO ;PRINT IT + IBP E ;INCREMENT POINTER TO NEXT BYTE + SOJG D,OCTLP2 ;REPEAT FOR 12. CHARS + + MOVEI A,"* ;DELIMIT END OF ERROR TYPEOUT + PUSHJ P,PITYO ;REPRINT IT + + JRST PNEXT ;RESTORE REGS & POP UP ONE LEVEL TO CALLER + +POCTAL: MOVEI A,14. ;RETURN TO NEW LINE IF 14. SPACES NOT LEFT + MOVE B,-2(TP) ; GET CHANNEL INTO B + PUSHJ P,RETIF + JRST PRE01 ;PRINT VALUE AS "*XXXXXXXXXXXX*" + + ;PRINT BINARY INTEGERS IN DECIMAL. +; +PFIX: MOVM E,(TP) ; GET # (MAFNITUDE) + JUMPL E,POCTAL ; IF ABS VAL IS NEG, MUST BE SETZ + PUSH P,FLAGS + +PFIX1: MOVE B,-2(TP) ; GET CHANNEL INTO B +PFIX2: MOVE D,UPB+6 ; IF UNPARSE, THIS IS RADIX + TLNE FLAGS,UNPRSE+FLTBIT ;SKIPS IF NOT FROM UNPARSE OR FLATSIZE + JRST PFIXU + MOVE D,RADX(B) ; GET OUTPUT RADIX +PFIXU: CAIG D,1 ; DONT ALLOW FUNNY RADIX + MOVEI D,10. ; IF IN DOUBT USE 10. + PUSH P,D + MOVEI A,1 ; START A COUNTER + SKIPGE B,(TP) ; CHECK SIGN + MOVEI A,2 ; NEG, NEED CHAR FOR SIGN + + IDIV B,D ; START COUNTING + JUMPE B,.+2 + AOJA A,.-2 + + MOVE B,-2(TP) ; CHANNEL TO B + TLNN FLAGS,FLTBIT+BINBIT + PUSHJ P,RETIF3 ; CHECK FOR C.R. + MOVE B,-2(TP) ; RESTORE CHANNEL + MOVEI A,"- ; GET SIGN + SKIPGE (TP) ; SKIP IF NOT NEEDED + PUSHJ P,PITYO + MOVM C,(TP) ; GET MAGNITUDE OF # + MOVE B,-2(TP) ; RESTORE CHANNEL + POP P,E ; RESTORE RADIX + PUSHJ P,FIXTYO ; WRITE OUT THE # + MOVE FLAGS,-1(P) + SUB P,[1,,1] ; FLUSH P STUFF + JRST PNEXT + +FIXTYO: IDIV C,E + HRLM D,(P) ; SAVE REMAINDER + SKIPE C + PUSHJ P,FIXTYO + HLRZ A,(P) ; START GETTING #'S BACK + ADDI A,60 + MOVE B,-2(TP) ; CHANNEL BACK + JRST PITYO + + ;PRINT SINGLE-PRECISION FLOATING POINT NUMBERS IN DECIMAL. +; +PFLOAT: SKIPN A,(TP) ; SKIP IF NUMBER IS NON-ZERO (SPECIAL HACK FOR ZERO) + JRST PFLT0 ; HACK THAT ZERO + MOVM E,A ; CHECK FOR NORMALIZED + TLNN E,400 ; NORMALIZED + JRST PUNK + MOVEI E,FLOATB ;ADDRESS OF FLOATING POINT CONVERSION ROUTINE + MOVE D,[6,,6] ;# WORDS TO GET FROM STACK + +PNUMB: HRLI A,1(P) ;LH(A) TO CONTAIN ADDRESS OF RETURN AREA ON STACK + HRR A,TP ;RH(A) TO CONTAIN ADDRESS OF DATA ITEM + HLRZ B,A ;SAVE RETURN AREA ADDRESS IN REG B + ADD P,D ;ADD # WORDS OF RETURN AREA TO BOTH HALVES OF SP + JUMPGE P,PDLERR ;PLUS OR ZERO STACK POINTER IS OVERFLOW +PDLWIN: PUSHJ P,(E) ;CALL ROUTINE WHOSE ADDRESS IS IN REG E + + MOVE C,(B) ;GET COUNT 0F # CHARS RETURNED + MOVE A,C ;MAKE SURE THAT # WILL FIT ON PRINT LINE +PFLT1: PUSH P,B ; SAVE B + MOVE B,-2(TP) ; GET CHANNEL INTO B + PUSHJ P,RETIF ;START NEW LINE IF IT WON'T + POP P,B ; RESTORE B + + HRLI B,000700 ;MAKE REG B INTO BYTE POINTER TO FIRST CHAR LESS ONE +PNUM01: ILDB A,B ;GET NEXT BYTE + PUSH P,B ;SAVE B + MOVE B,-2(TP) ; GET CHANNEL INTO B + PUSHJ P,PITYO ;PRINT IT + + P,B ; RESTORE B + SOJG C,PNUM01 ;DECREMENT CHAR COUNT: LOOP IF NON-ZERO + + SUB P,D ;SUBTRACT # WORDS USED ON STACK FOR RETURN + JRST PNEXT ;STORE REGS & POP UP ONE LEVEL TO CALLER + + +PFLT0: MOVEI A,9. ; WIDTH OF 0.0000000 + MOVEI C,9. ; SEE ABOVE + MOVEI D,0 ; WE'RE GONNA TEST D SOON...SO WILL DO RIGHT THING + MOVEI B,[ASCII /0.0000000/] + SOJA B,PFLT1 ; PT TO 1 BELOW CONST, THEN REJOIN CODE + + + + +PDLERR: SUB P,D ;REST STACK POINTER +REPEAT 6,PUSH P,[0] + JRST PDLWIN + ;PRINT SHORT (ONE WORD) CHARACTER STRINGS +; +PCHRS: MOVEI A,3 ;MAX # CHARS PLUS 2 (LESS ESCAPES) + MOVE B,-2(TP) ; GET CHANNEL INTO B + TLNE FLAGS,NOQBIT ;SKIP IF QUOTES WILL BE USED + MOVEI A,1 ;ELSE, JUST ONE CHARACTER POSSIBLE + PUSHJ P,RETIF ;NEW LINE IF INSUFFICIENT SPACE + TLNE FLAGS,NOQBIT ;DON'T QUOTE IF IN PRINC MODE + JRST PCASIS + MOVEI A,"! ;TYPE A EXCL + PUSHJ P,PITYO + MOVEI A,"" ;AND A DOUBLE QUOTE + PUSHJ P,PITYO + +PCASIS: MOVE A,(TP) ;GET NEXT BYTE FROM WORD + TLNE FLAGS,NOQBIT ;SKIP IF WE ARE NOT IN PRINC MODE (NOQBIT=0) + JRST PCPRNT ;IF BIT IS ON, PRINT WITHOUT ESCAPING + CAIE A,ESCHAR ;SKIP IF NOT THE ESCAPE CHARACTER + JRST PCPRNT ;ESCAPE THE ESCAPE CHARACTER + +ESCPRT: MOVEI A,ESCHAR ;TYPE THE ESCAPE CHARACTER + PUSHJ P,PITYO + +PCPRNT: MOVE A,(TP) ;GET THE CHARACTER AGAIN + PUSHJ P,PITYO ;PRINT IT + JRST PNEXT + + + ;PRINT DEFERED (INVISIBLE) ITEMS. (PRINTED AS THE THING POINTED TO) +; +PDEFER: MOVE A,(B) ;GET FIRST WORD OF ITEM + MOVE B,1(B) ;GET SECOND + PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT + PUSH TP,-3(TP) + PUSHJ P,IPRINT ;PRINT IT + SUB TP,[2,,2] ; POP OFF CHANNEL + JRST PNEXT ;GO EXIT + + +; Print an ATOM. TRAILERS are added if the atom is not in the current +; lexical path. Also escaping of charactets is performed to allow READ +; to win. + +PATOM: PUSH P,[440700,,D] ; PUSH BYE POINTER TO FINAL STRING + SETZB D,E ; SET CHARCOUNT AD DESTINATION TO 0 + HLLZS -1(TP) ; RH OF TATOM,, WILL COUNT ATOMS IN PATH + +PATOM0: PUSH TP,$TPDL ; SAVE CURRENT STAKC FOR \ LOGIC + PUSH TP,P + LDB A,[301400,,(P)] ; GET BYTE PTR POSITION + DPB A,[301400,,E] ; SAVE IN E + MOVE C,-2(TP) ; GET ATOM POINTER + ADD C,[3,,3] ; POINT TO PNAME + HLRE A,C ; -# WORDS TO A + PUSH P,A ; PUSH THAT FOR "AOSE" + MOVEI A,177 ; PUT RUBOUT WHERE \ MIGHT GO + JSP B,DOIDPB + HRLI C,440700 ; BUILD BYET POINTER + +PATOM1: ILDB A,C ; GET A CHAR + JUMPE A,PATDON ; END OF PNAME? + TLNN C,760000 ; SKIP IF NOT WORD BOUNDARY + AOS (P) ; COUNT WORD + JRST PENTCH ; ENTER THE CHAR INTO OUTPUT + +PATDON: LDB A,[220600,,E] ; GET "STATE" + LDB A,STABYT+6 ; SIMULATE "END" CHARACTER + DPB A,[220600,,E] ; AND STORE + MOVE B,E ; SETUP BYTE POINTER TO 1ST CHAR + TLZ B,77 + HRR B,(TP) ; POINT + SUB TP,[2,,2] ; FLUSH SAVED PDL + MOVE C,-1(P) ; GET BYE POINTER + SUB P,[2,,2] ; FLUSH + PUSH P,D + MOVEI A,0 + IDPB A,B + AOS -1(TP) ; COUNT ATOMS + TLNE FLAGS,NOQBIT ; SKIP IF NOT "PRINC" + JRST NOLEX4 ; NEEDS NO LEXICAL TRAILERS + MOVEI A,"\ ; GET QUOTER + TLNN E,2 ; SKIP IF NEEDED + JRST PATDO1 + SOS -1(TP) ; DONT COUNT BECAUSE OF SLASH + DPB A,B ; CLOBBER +PATDO1: MOVEI E,(E) ; CLEAR LH(E) + PUSH P,C ; SAVE BYTER + PUSH P,E ; ALSO CHAR COUNT + + MOVE B,IMQUOTE OBLIST + PUSH P,FLAGS + PUSHJ P,IDVAL ; GET LOCAL/GLOBAL VALUE + POP P,FLAGS ; AND RESTORES FLAGS + MOVE C,(TP) ; GET ATOM BACK + SKIPN C,2(C) ; GET ITS OBLIST + AOJA A,NOOBL1 ; NONE, USE FALSE + JUMPL C,.+3 ; JUMP IF REAL OBLIST + ADDI C,(TVP) ; ELSE MUST BE OFFSET + MOVE C,(C) + CAME A,$TLIST ; SKIP IF A LIST + CAMN A,$TOBLS ; SKIP IF UNREASONABLE VALUE + JRST CHOBL ; WINS, NOW LOCATE IT + +CHROOT: CAME C,ROOT+1(TVP) ; IS THIS ROOT? + JRST FNDOBL ; MUST FIND THE PATH NAME + POP P,E ; RESTORE CHAR COUNT + MOVE D,(P) ; AND PARTIAL WORD + EXCH D,-1(P) ; STORE BYTE POINTER AND GET PARTIAL WORD + MOVEI A,"! ; PUT OUT MAGIC + JSP B,DOIDPB ; INTO BUFFER + MOVEI A,"- + JSP B,DOIDPB + MOVEI A,40 + JSP B,DOIDPB + +NOLEX0: SUB P,[2,,2] ; REMOVE COUNTER AND BYTE POINTER + PUSH P,D ; PUSH NEXT WORD IF ANY + JRST NOLEX4 + +NOLEX: MOVE E,(P) ; GET COUNT + SUB P,[2,,2] +NOLEX4: MOVEI E,(E) ; CLOBBER LH(E) + MOVE A,E ; COUNT TO A + SKIPN (P) ; FLUSH 0 WORD + SUB P,[1,,1] + HRRZ C,-1(TP) ; GET # OF ATOMS + SUBI A,(C) ; FIX COUNT + MOVE B,-2(TP) ; GET CHANNEL INTO B + PUSHJ P,RETIF ; MAY NEED C.R. + MOVEI C,-1(E) ; COMPUTE WORDS-1 + IDIVI C,5 ; WORDS-1 TO C + HRLI C,(C) + MOVE D,P + SUB D,C ; POINTS TO 1ST WORD OF CHARS + MOVSI C,440700+D ; BYTEPOINTER TO STRING + PUSH TP,$TPDL ; SAVE FROM GC + PUSH TP,D + +PATOUT: ILDB A,C ; READ A CHAR + SKIPE A ; IGNORE NULS + PUSHJ P,PITYO ; PRINT IT + MOVE D,(TP) ; RESTORE POINTER + SOJG E,PATOUT + +NOLEXD: SUB TP,[2,,2] ; FLUSH TP JUNK + MOVE P,D ; RESTORE P + SUB P,[1,,1] + JRST PNEXT + + +PENTCH: TLNE FLAGS,NOQBIT ; "PRINC"? + JRST PENTC1 ; YES, AVOID SLASHING + IDIVI A,CHRWD ; GET CHARS TYPE + LDB B,BYTPNT(B) + CAIL B,6 ; SKIP IF NOT SPECIAL + JRST PENTC2 ; SLASH IMMEDIATE + LDB A,[220600,,E] ; GET "STATE" + LDB A,STABYT-1(B) ; GET NEW STATE + DPB A,[220600,,E] ; AND SAVE IT +PENTC3: LDB A,C ; RESTORE CHARACTER +PENTC1: JSP B,DOIDPB + SKIPGE (P) ; SKIP IF DONE + JRST PATOM1 ; CONTINUE + JRST PATDON + +PENTC2: MOVEI A,"\ ; GET CHAR QUOTER + JSP B,DOIDPB ; NEEDED, DO IT + MOVEI A,4 ; PATCH FOR ATOMS ALREADY BACKSLASHED + JRST PENTC3-1 + +; ROUTINE TO PUT ONE CHAR ON STACK BUFFER + +DOIDPB: IDPB A,-1(P) ; DEPOSIT + TRNN D,377 ; SKIP IF D FULL + AOJA E,(B) + PUSH P,(P) ; MOVE TOP OF STACK UP + MOVEM D,-2(P) ; SAVE WORDS + MOVE D,[440700,,D] + MOVEM D,-1(P) + MOVEI D,0 + AOJA E,(B) + +; CHECK FOR UNIQUENESS LOOKING INTO PATH + +CHOBL: CAME A,$TOBLS ; SINGLE OBLIST? + JRST LSTOBL ; NO, AL LIST THEREOF + CAME B,C ; THE RIGTH ONE? + JRST CHROOT ; NO, CHECK ROOT + JRST NOLEX ; WINNER, NO TRAILERS! + +LSTOBL: PUSH TP,A ; SCAN A LIST OF OBLISTS + PUSH TP,B + PUSH TP,A + PUSH TP,B + PUSH TP,$TOBLS + PUSH TP,C + +NXTOB2: INTGO ; LIST LOOP, PREVENT LOSSAGE + SKIPN C,-2(TP) ; SKIP IF NOT DONE + JRST CHROO1 ; EMPTY, CHECK ROOT + MOVE B,1(C) ; GET ONE + CAME B,(TP) ; WINNER? + JRST NXTOBL ; NO KEEP LOOKING + CAMN C,-4(TP) ; SKIP IF NOT FIRST ON LIST + JRST NOLEX1 + MOVE A,-6(TP) ; GET ATOM BACK + MOVEI D,0 + ADD A,[3,,3] ; POINT TO PNAME + PUSH P,0 ; SAVE FROM RLOOKU + PUSH P,(A) + ADDI D,5 + AOBJN A,.-2 ; PUSH THE PNAME + PUSH P,D ; AND CHAR COUNT + MOVSI A,TLIST ; TELL RLOOKU WE WIN + MOVE B,-4(TP) ; GET BACK OBLIST LIST + SUB TP,[6,,6] ; FLUSH CRAP + PUSHJ P,RLOOKU ; FIND IT + POP P,0 + CAMN B,(TP) ; SKIP IF NON UNIQUE + JRST NOLEX ; UNIQUE , NO TRAILER!! + JRST CHROO2 ; CHECK ROOT + +NXTOBL: HRRZ B,@-2(TP) ; STEP THE LIST + MOVEM B,-2(TP) + JRST NXTOB2 + + +FNDOBL: MOVE C,(TP) ; GET ATOM + MOVSI A,TOBLS + MOVE B,2(C) + JUMPL B,.+3 + ADDI B,(TVP) + MOVE B,(B) + MOVSI C,TATOM + MOVE D,IMQUOTE OBLIST + PUSH P,0 + PUSHJ P,IGET + POP P,0 +NOOBL1: POP P,E ; RESTORE CHAR COUNT + MOVE D,(P) ; GET PARTIAL WORD + EXCH D,-1(P) ; AND BYTE POINTER + CAME A,$TATOM ; IF NOT ATOM, USE FALSE + JRST NOOBL + MOVEM B,(TP) ; STORE IN ATOM SLOT + MOVEI A,"! + JSP B,DOIDPB ; WRITE IT OUT + MOVEI A,"- + JSP B,DOIDPB + SUB P,[1,,1] + JRST PATOM0 ; AND LOOP + +NOOBL: MOVE C,[440700,,[ASCIZ /!-#FALSE ()/]] + ILDB A,C + JUMPE A,NOLEX0 + JSP B,DOIDPB + JRST .-3 + + +NOLEX1: SUB TP,[6,,6] ; FLUSH STUFF + JRST NOLEX + +CHROO1: SUB TP,[6,,6] +CHROO2: MOVE C,(TP) ; GET ATOM + SKIPGE C,2(C) ; AND ITS OBLIST + JRST CHROOT + ADDI C,(TVP) + MOVE C,(C) + JRST CHROOT + + + ; STATE TABLES FOR \ OF FIRST CHAR + +RADIX 16. + +STATS: 431244000 + 434444400 + 222224200 + 434564200 + 444444400 + 454564200 + 487444200 + 484444400 + 484444200 + +RADIX 8. + +STABYT: 400400,,STATS(A) + 340400,,STATS(A) + 300400,,STATS(A) + 240400,,STATS(A) + 200400,,STATS(A) + 140400,,STATS(A) + 100400,,STATS(A) + + ;PRINT LONG CHARACTER STRINGS. +; +PCHSTR: MOVE B,(TP) + TLZ FLAGS,ATMBIT ;WE ARE NOT USING ATOM-NAME TYPE ESCAPING + PUSH P,-1(TP) ; PUSH CHAR COUNT + MOVE D,[AOS E] ;GET INSTRUCTION TO COUNT CHARACTERS + SETZM E ;ZERO COUNT + PUSHJ P,PCHRST ;GO THROUGH STRING, ESCAPING, ETC. AND COUNTING + MOVE A,E ;PUT COUNT RETURNED IN REG A + TLNN FLAGS,NOQBIT ;SKIP (NO QUOTES) IF IN PRINC (BIT ON) + ADDI A,2 ;PLUS TWO FOR QUOTES + PUSH P,B ; SAVE B + MOVE B,-2(TP) ; GET CHANNEL INTO B + PUSHJ P,RETIF ;START NEW LINE IF NO SPACE + POP P,B ; RESTORE B + TLNE FLAGS,NOQBIT ;SKIP (PRINT ") IF BIT IS OFF (NOT PRINC) + JRST PCHS01 ;OTHERWISE, DON'T QUOTE + MOVEI A,"" ;PRINT A DOUBLE QUOTE + PUSH P,B ; SAVE B + MOVE B,-2(TP) + PUSHJ P,PITYO + POP P,B ; RESTORE B + +PCHS01: MOVE D,[PUSHJ P,PITYO] ;OUTPUT INSTRUCTION + MOVEM B,(TP) ;RESET BYTE POINTER + POP P,-1(TP) ; RESET CHAR COUNT + PUSHJ P,PCHRST ;TYPE STRING + + TLNE FLAGS,NOQBIT ;AGAIN, SKIP IF DOUBLE-QUOTING TO BE DONE + JRST PNEXT ;RESTORE REGS & POP UP ONE LEVEL TO CALLER + MOVEI A,"" ;PRINT A DOUBLE QUOTE + MOVE B,-2(TP) ; GET CHANNEL INTO B + PUSH P,B ; SAVE B + MOVE B,-2(TP) ; GET CHANNEL + PUSHJ P,PITYO + POP P,B ;RESTORE B + JRST PNEXT + + +;INTERNAL ROUTINE USED TO COUNT OR OUTPUT CHARACTER STRINGS. +; +;THE APPROPRIATE ESCAPING CONVENTIONS ARE USED AS DETERMINED BY THE FLAG BITS. +; +PCHRST: PUSH P,A ;SAVE REGS + PUSH P,B + PUSH P,C + PUSH P,D + +PCHR02: INTGO ; IN CASE VERY LONG STRING + HRRZ C,-1(TP) ;GET COUNT + SOJL C,PCSOUT ; DONE? + HRRM C,-1(TP) + ILDB A,(TP) ; GET CHAR + + TLNE FLAGS,NOQBIT ;SKIP IF WE ARE NOT IN PRINC MODE (NOQBIT=0) + JRST PCSPRT ;IF BIT IS ON, PRINT WITHOUT ESCAPING + CAIN A,ESCHAR ;SKIP IF NOT THE ESCAPE CHARACTER + JRST ESCPRN ;ESCAPE THE ESCAPE CHARACTER + CAIN A,"" ;SKIP IF NOT A DOUBLE QUOTE + JRST ESCPRN ;OTHERWISE, ESCAPE THE """ + IDIVI A,CHRWD ;CODE HERE FINDS CHARACTER TYPE + LDB B,BYTPNT(B) ; " + CAIGE B,6 ;SKIP IF NOT A NUMBER/LETTER + JRST PCSPRT ;OTHERWISE, PRINT IT + TLNN FLAGS,ATMBIT ;SKIP IF PRINTING AN ATOM-NAME (UNQUOTED) + JRST PCSPRT ;OTHERWISE, NO OTHER CHARS TO ESCAPE + +ESCPRN: MOVEI A,ESCHAR ;TYPE THE ESCAPE CHARACTER + PUSH P,B ; SAVE B + MOVE B,-2(TP) ; GET CHANNEL INTO B + XCT (P)-1 + POP P,B ; RESTORE B + +PCSPRT: LDB A,(TP) ;GET THE CHARACTER AGAIN + PUSH P,B ; SAVE B + MOVE B,-2(TP) ; GET CHANNEL INTO B + XCT (P)-1 ;PRINT IT + POP P,B ; RESTORE B + JRST PCHR02 ;LOOP THROUGH STRING + +PCSOUT: POP P,D + POP P,C ;RESTORE REGS & RETURN + POP P,B + POP P,A + POPJ P, + + + ;PRINT AN ARGUMENT LIST +;CHECK FOR TIME ERRORS + +PARGS: MOVEI B,-1(TP) ;POINT TO ARGS POINTER + PUSHJ P,CHARGS ;AND CHECK THEM + JRST PVEC ; CHEAT TEMPORARILY + + + +;PRINT A FRAME +PFRAME: MOVEI B,-1(TP) ;POINT TO FRAME POINTER + PUSHJ P,CHFRM + HRRZ B,(TP) ;POINT TO FRAME ITSELF + HRRZ B,FSAV(B) ;GET POINTER TO SUBROUTINE + CAMGE B,VECTOP + CAMGE B,VECBOT + SKIPA B,@-1(B) ; SUBRS AND FSUBRS + MOVE B,3(B) ; FOR RSUBRS + MOVSI A,TATOM + PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT + PUSH TP,-3(TP) + PUSHJ P,IPRINT ;PRINT FUNCTION NAME + SUB TP,[2,,2] ; POP CHANNEL OFF STACK + JRST PNEXT + +PPVP: MOVE B,(TP) ; PROCESS TO B + MOVSI A,TFIX + JUMPE B,.+3 + MOVE A,PROCID(B) + MOVE B,PROCID+1(B) ;GET ID + PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT + PUSH TP,-3(TP) + PUSHJ P,IPRINT + SUB TP,[2,,2] ; POP CHANNEL OFF STACK + JRST PNEXT + +; HERE TO PRINT LOCATIVES + +LOCPT1: HRRZ A,-1(TP) + JUMPN A,PUNK +LOCPT: MOVEI B,-1(TP) ; VALIDITY CHECK + PUSHJ P,CHLOCI + HRRZ A,-1(TP) + JUMPE A,GLOCPT + MOVE B,(TP) + MOVE A,(B) + MOVE B,1(B) + PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT + PUSH TP,-3(TP) + PUSHJ P,IPRINT + SUB TP,[2,,2] ; POP CHANNEL OFF STACK + JRST PNEXT + +GLOCPT: MOVEI A,2 + MOVE B,-2(TP) ; GET CHANNEL + PUSHJ P,RETIF + MOVEI A,"% + PUSHJ P,PITYO + MOVEI A,"< + PUSHJ P,PITYO + MOVSI A,TATOM + MOVE B,MQUOTE GLOC + PUSH TP,-3(TP) + PUSH TP,-3(TP) + PUSHJ P,IPRINT + SUB TP,[2,,2] + PUSHJ P,SPACEQ + MOVE B,(TP) + MOVSI A,TATOM + MOVE B,-1(B) + PUSH TP,-3(TP) + PUSH TP,-3(TP) + PUSHJ P,IPRINT + SUB TP,[2,,2] + PUSHJ P,SPACEQ + MOVSI A,TATOM + MOVE B,MQUOTE T + PUSH TP,-3(TP) + PUSH TP,-3(TP) + PUSHJ P,IPRINT + SUB TP,[2,,2] + MOVEI A,"> + PUSHJ P,PRETIF + JRST PNEXT + + ;PRINT UNIFORM VECTORS. +; +PUVEC: MOVE B,-2(TP) ; GET CHANNEL INTO B + MOVEI A,2 ; ROOM FOR ! AND SQ BRACK? + PUSHJ P,RETIF + MOVEI A,"! ;TYPE AN ! AND OPEN SQUARE BRACKET + PUSHJ P,PITYO + MOVEI A,"[ + PUSHJ P,PITYO + + MOVE C,(TP) ;GET AOBJN POINTER TO VECTOR + TLNN C,777777 ;SKIP ONLY IF COUNT IS NOT ZERO + JRST NULVEC ;ELSE, VECTOR IS EMPTY + + HLRE A,C ;GET NEG COUNT + MOVEI D,(C) ;COPY POINTER + SUB D,A ;POINT TO DOPE WORD + HLLZ A,(D) ;GET TYPE + PUSH P,A ;AND SAVE IT + +PUVE02: MOVE A,(P) ;PUT TYPE CODE IN REG A + MOVE B,(C) ;PUT DATUM INTO REG B + PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT + PUSH TP,-3(TP) + PUSHJ P,IPRINT ;TYPE IT + SUB TP,[2,,2] ; POP CHANNEL OF STACK + MOVE C,(TP) ;GET AOBJN POINTER + AOBJP C,NULVE1 ;JUMP IF COUNT IS ZERO + MOVEM C,(TP) ;PUT POINTER BACK ONTO STACK + + MOVE B,-2(TP) ; GET CHANNEL INTO B + PUSHJ P,SPACEQ + JRST PUVE02 ;LOOP THROUGH VECTOR + +NULVE1: SUB P,[1,,1] ;REMOVE STACK CRAP +NULVEC: MOVE B,-2(TP) ; GET CHANNEL INTO B + MOVEI A,"! ;TYPE CLOSE BRACKET + PUSHJ P,PRETIF + MOVEI A,"] + PUSHJ P,PRETIF + JRST PNEXT + + ;PRINT A GENERALIZED VECTOR +; +PVEC: MOVE B,-2(TP) ; GET CHANNEL INTO B + PUSHJ P,RETIF1 ;NEW LINE IF NO ROOM FOR [ + MOVEI A,"[ ;PRINT A LEFT-BRACKET + PUSHJ P,PITYO + + MOVE C,(TP) ;GET AOBJN POINTER TO VECTOR + TLNN C,777777 ;SKIP IF POINTER-COUNT IS NON-ZERO + JRST PVCEND ;ELSE, FINISHED WITH VECTOR +PVCR01: MOVE A,(C) ;PUT FIRST WORD OF NEXT ELEMENT INTO REG A + MOVE B,1(C) ;SECOND WORD OF LIST INTO REG B + PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT + PUSH TP,-3(TP) + PUSHJ P,IPRINT ;PRINT THAT ELEMENT + SUB TP,[2,,2] ; POP CHANNEL OFF STACK + + MOVE C,(TP) ;GET AOBJN POINTER FROM TP-STACK + AOBJP C,PVCEND ;POSITIVE HERE SERIOUS ERROR! (THOUGH NOT PDL) + AOBJN C,.+2 ;SKIP AND CONTINUE LOOP IF COUNT NOT ZERO + JRST PVCEND ;ELSE, FINISHED WITH VECTOR + MOVEM C,(TP) ;PUT INCREMENTED POINTER BACK ON TP-STACK + + MOVE B,-2(TP) ; GET CHANNEL INTO B + PUSHJ P,SPACEQ + JRST PVCR01 ;CONTINUE LOOPING THROUGH OBJECTS ON VECTOR + +PVCEND: MOVE B,-2(TP) ; GET CHANNEL INTO B + PUSHJ P,RETIF1 ;NEW LINE IF NO ROOM FOR ] + MOVEI A,"] ;PRINT A RIGHT-BRACKET + PUSHJ P,PITYO + JRST PNEXT + + ;PRINT A LIST. +; +PLIST: MOVE B,-2(TP) ; GET CHANNEL INTO B + PUSHJ P,RETIF1 ;NEW LINE IF NO SPACE LEFT FOR "(" + MOVEI A,"( ;TYPE AN OPEN PAREN + PUSHJ P,PITYO + PUSHJ P,LSTPRT ;PRINT THE INSIDES + MOVE B,-2(TP) ; RESTORE CHANNEL TO B + PUSHJ P,RETIF1 ;NEW LINE IF NO ROOM FOR THE CLOSE PAREN + MOVEI A,") ;TYPE A CLOSE PAREN + PUSHJ P,PITYO + JRST PNEXT + +PSEG: TLOA FLAGS,SEGBIT ;PRINT A SEGMENT (& SKIP) + +PFORM: TLZ FLAGS,SEGBIT ;PRINT AN ELEMENT + +PLMNT3: MOVE C,(TP) + JUMPE C,PLMNT1 ;IF THE CALL IS EMPTY GO AWAY + MOVE B,1(C) + MOVEI D,0 + CAMN B,MQUOTE LVAL + MOVEI D,". + CAMN B,MQUOTE GVAL + MOVEI D,", + CAMN B,MQUOTE QUOTE + MOVEI D,"' + JUMPE D,PLMNT1 ;NEITHER, LEAVE + +;ITS A SPECIAL HACK + HRRZ C,(C) + JUMPE C,PLMNT1 ;NIL BODY? + +;ITS VALUE OF AN ATOM + HLLZ A,(C) + MOVE B,1(C) + HRRZ C,(C) + JUMPN C,PLMNT1 ;IF TERE ARE EXTRA ARGS GO AWAY + + PUSH P,D ;PUSH THE CHAR + PUSH TP,A + PUSH TP,B + TLNN FLAGS,SEGBIT ;SKIP (CONTINUE) IF THIS IS A SEGMENT + JRST PLMNT4 ;ELSE DON'T PRINT THE "." + +;ITS A SEGMENT CALL + MOVE B,-4(TP) ; GET CHANNEL INTO B + MOVEI A,2 ; ROOM FOR ! AND . OR , + PUSHJ P,RETIF + MOVEI A,"! + PUSHJ P,PITYO + +PLMNT4: MOVE B,-4(TP) ; GET CHANNEL INTO B + PUSHJ P,RETIF1 + POP P,A ;RESTORE CHAR + PUSHJ P,PITYO + POP TP,B + POP TP,A + PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT + PUSH TP,-3(TP) + PUSHJ P,IPRINT + SUB TP,[2,,2] ; POP CHANNEL OFF STACK + JRST PNEXT + + +PLMNT1: TLNN FLAGS,SEGBIT ;SKIP IF THIS IS A SEGMENT + JRST PLMNT5 ;ELSE DON'T TYPE THE "!" + +;ITS A SEGMENT CALL + MOVE B,-2(TP) ; GET CHANNEL INTO B + MOVEI A,2 ; ROOM FOR ! AND < + PUSHJ P,RETIF + MOVEI A,"! + PUSHJ P,PITYO + +PLMNT5: MOVE B,-2(TP) ; GET CHANNEL FOR B + PUSHJ P,RETIF1 + MOVEI A,"< + PUSHJ P,PITYO + PUSHJ P,LSTPRT + MOVEI A,"! + MOVE B,-2(TP) ; GET CHANNEL INTO B + TLNE FLAGS,SEGBIT ;SKIP IF NOT SEGEMNT + PUSHJ P,PRETIF + MOVEI A,"> + PUSHJ P,PRETIF + JRST PNEXT + + + +LSTPRT: SKIPN C,(TP) + POPJ P, + HLLZ A,(C) ;GET NEXT ELEMENT + MOVE B,1(C) + HRRZ C,(C) ;CHOP THE LIST + JUMPN C,PLIST1 + PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT + PUSH TP,-3(TP) + PUSHJ P,IPRINT ;PRINT THE LAST ELEMENT + SUB TP,[2,,2] ; POP CHANNEL OFF STACK + POPJ P, + +PLIST1: MOVEM C,(TP) + PUSH TP,-3(TP) ; GET CHANNEL FOR IPRINT + PUSH TP,-3(TP) + PUSHJ P, IPRINT ;PRINT THE NEXT ELEMENT + SUB TP,[2,,2] ; POP CHANNEL OFF STACK + MOVE B,-2(TP) ; GET CHANNEL INTO B + PUSHJ P,SPACEQ + JRST LSTPRT ;REPEAT + +PNEXT: POP P,FLAGS ;RESTORE PREVIOUS FLAG BITS + SUB TP,[2,,2] ;REMOVE INPUT ELEMENT FROM TP-STACK + POP P,C ;RESTORE REG C + POPJ P, + +OPENIT: PUSH P,E + PUSH P,FLAGS + PUSHJ P,OPNCHN + POP P,FLAGS + POP P,E + JUMPGE B,FNFFL ;ERROR IF IT CANNOT BE OPENED + POPJ P, + + +END + diff --git a/sumex/putget.mcr047 b/sumex/putget.mcr047 new file mode 100644 index 0000000..53f08c9 --- /dev/null +++ b/sumex/putget.mcr047 @@ -0,0 +1,395 @@ +TITLE GETPUT ASSOCIATION FUNCTIONS FOR MUDDLE + +RELOCATABLE + +.INSRT MUDDLE > + +; COMPONENTS IN AN ASSOCIATION BLOCK + +ITEM==0 ;ITEM TO WHICH INDUCATOR APPLIES +VAL==2 ;VALUE +INDIC==4 ;INDICATOR +NODPNT==6 ;IF NON ZERO POINTS TO CHAIN +PNTRS==7 ;POINTERS NEXT (RH) AND PREV (LH) + +ASOLNT==8 ;NUMBER OF WORDS IN AN ASSOCIATION BLOCK + +.GLOBAL ASOVEC ;POINTER TO HASH VECTOR IN TV +.GLOBAL ASOLNT,ITEM,INDIC,VAL,NODPNT,NODES,IPUTP,IGETP,PUT,IFALSE +.GLOBAL DUMNOD,IGETLO,IBLOCK,MONCH,RMONCH,IPUT,IGETL,IREMAS,IGET +.GLOBAL NWORDT,CIGETP,CIGTPR,CIPUTP,CIREMA,MPOPJ + +MFUNCTION GETP,SUBR,[GETPROP] + + ENTRY + +IGETP: PUSHJ P,GETLI + JRST FINIS ; NO SKIP, LOSE + MOVSI A,TLOCN + HLLZ 0,VAL(B) + PUSHJ P,RMONCH ; CHECK MONITOR + MOVE A,VAL(B) ;ELSE RETURN VALUE + MOVE B,VAL+1(B) +CFINIS: JRST FINIS + +; FUNCTION TO RETURN LOCATIVE TO ASSOC + +MFUNCTION GETPL,SUBR + + ENTRY + +IGETLO: PUSHJ P,GETLI + JRST FINIS + MOVSI A,TLOCN + JRST FINIS + +GETLI: PUSHJ P,2OR3 ; GET ARGS + PUSHJ P,IGETL ;SEE IF ASSOCIATION EXISTS + SKIPE B + AOS (P) ; WIN RETURN + CAMGE AB,[-4,,0] ; ANY ERROR THING + JUMPE B,CHFIN ;IF 0, NONE EXISTS + POPJ P, + +CHFIN: PUSH TP,4(AB) + PUSH TP,5(AB) + MCALL 1,EVAL + POPJ P, + +; COMPILER CALLS TO SOME OF THESE + +CIGETP: SUBM M,(P) ; FIX RET ADDR + PUSHJ P,IGETL ; GO TO INTERNAL + JUMPE B,MPOPJ + MOVSI A,TLOCN +MPOPJ1: SOS (P) ; WINNER (SOS BECAUSE OF SUBM M,(P)) +MPOPJ: SUBM M,(P) + POPJ P, + +CIGTPR: SUBM M,(P) + PUSHJ P,IGETL + JUMPE B,MPOPJ + MOVE A,VAL(B) ; GET VAL TYPE + MOVE B,VAL+1(B) + JRST MPOPJ1 + +CIPUTP: SUBM M,(P) + PUSH TP,-1(TP) ; SAVE VAL + PUSH TP,-1(TP) + PUSHJ P,IPUT ; DO IT + POP TP,B + POP TP,A + JRST MPOPJ + +CIREMA: SUBM M,(P) + PUSHJ P,IREMAS ; FLUSH IT + JRST MPOPJ + +; CHECK PUT/GET PUTPROP AND GETPROP ARGS + +2OR3: HLRE 0,AB + ASH 0,-1 ; TO -# OF ARGS + ADDI 0,2 ; AT LEAST 2 + JUMPG 0,TFA ; 1 OR LESS, LOSE + AOJL 0,TMA ; 4 OR MORE, LOSE + MOVE A,(AB) ; GET ARGS INTO ACS + MOVE B,1(AB) + MOVE C,2(AB) + MOVE D,3(AB) + POPJ P, + +; INTERNAL GET + +IGET: PUSHJ P,IGETL ; GET LOCATIVE + JUMPE B,CPOPJ + MOVE A,VAL(B) + MOVE B,VAL+1(B) + POPJ P, + +; FUNCTION TO MAKE AN ASSOCIATION + +MFUNCTION PUTP,SUBR,[PUTPROP] + + ENTRY + +IPUTP: PUSHJ P,2OR3 ; GET ARGS + JUMPN 0,REMAS ; REMOVE AN ASSOCIATION + PUSH TP,4(AB) ; SAVE NEW VAL + PUSH TP,5(AB) + PUSHJ P,IPUT ; DO IT + MOVE A,(AB) ; RETURN NEW VAL + MOVE B,1(AB) + JRST FINIS + +REMAS: PUSHJ P,IREMAS + JRST FINIS + +IPUT: SKIPN DUMNOD+1(TVP) ; NEW DUMMY NEDDED? + PUSHJ P,DUMMAK ; YES, GO MAKE ONE +IPUT1: PUSHJ P,IGETI ;SEE IF THIS ONE EXISTS + + JUMPE B,NEWASO ;JUMP IF NEED NEW ASSOCIATION BLOCK +CLOBV: MOVE C,-5(TP) ; RET NEW VAL + MOVE D,-4(TP) + SUB TP,[6,,6] + HLLZ 0,VAL(B) + MOVSI A,TLOCN + PUSHJ P,MONCH ; MONITOR CHECK + MOVEM C,VAL(B) ;STORE IT + MOVEM D,VAL+1(B) +CPOPJ: POPJ P, + +; HERE TO CREATE A NEW ASSOCIATION + +NEWASO: MOVE B,DUMNOD+1(TVP) ; GET BALNK ASSOCIATION + SETZM DUMNOD+1(TVP) ; CAUSE NEW ONE NEXT TIME + + +;NOW SPLICE IN CHAIN + + JUMPE D,PUT1 ;NO OTHERS EXISTED IN THIS BUCKET + HRLZM C,PNTRS(B) ;CLOBBER PREV POINTER + HRRM B,PNTRS(C) ;AND NEXT POINTER + JRST .+2 + +PUT1: HRRZM B,(C) ;STORE INTO VECTOR + HRRZ C,NODES+1(TVP) + HRLM C,NODPNT(B) + MOVE D,NODPNT(C) + HRRZM B,NODPNT(C) + HRRM D,NODPNT(B) + HRLM B,NODPNT(D) + MOVEI C,-3(TP) ;COPY ARG POINTER + MOVSI A,-4 ;AND COPY POINTER + +PUT2: MOVE D,(C) ;START COPYING + MOVEM D,@CLOBTB(A) + ADDI C,1 + AOBJN A,PUT2 ;NOTE *** DEPENDS ON ORDER IN VECTOR *** + + JRST CLOBV + +;HERE TO REMOVE AN ASSOCIATION + +IREMAS: PUSHJ P,IGETL ;LOOK IT UP + JUMPE B,CPOPJ ;NEVER EXISTED, IGNORE + HRRZ A,PNTRS(B) ;NEXT POINTER + HLRZ E,PNTRS(B) ;PREV POINTER + SKIPE A ;DOES A NEXT EXIST? + HRLM E,PNTRS(A) ;YES CLOBBER ITS PREV POINTER + SKIPN D ;SKIP IF NOT FIRST IN BUCKET + MOVEM A,(C) ;FIRST STORE NEW ONE + SKIPE D ;OTHERWISE + HRRM A,PNTRS(E) ;PATCH NEXT POINTER IN PREVIOUS + HRRZ A,NODPNT(B) ;SEE IF MUST UNSPLICE NODE + HLRZ E,NODPNT(B) + SKIPE A + HRLM E,NODPNT(A) ;SPLICE + JUMPE E,PUT4 ;FLUSH IF NO PREV POINTER + HRRZ C,NODPNT(E) ;GET PREV'S NEXT POINTER + CAIE C,(B) ;DOES IT POINT TO THIS NODE + .VALUE [ASCIZ /:FATAL PUT LOSSAGE/] + HRRM A,NODPNT(E) ;YES, SPLICE +PUT4: MOVE A,VAL(B) ;RETURN VALUE + SETZM PNTRS(B) + MOVE B,VAL+1(B) + POPJ P, + + +;INTERNAL GET FUNCTION CALLED BY PUT AND GET +; A AND B ARE THE ITEM +;C AND D ARE THE INDICATOR + +IGETL: PUSHJ P,IGETI + SUB TP,[4,,4] ; FLUSH CRUFT LEFT BY IGETI + POPJ P, + +IGETI: PUSHJ P,LHCLR + EXCH A,C + PUSHJ P,LHCLR + EXCH C,A + PUSH TP,A + PUSH TP,B + PUSH TP,C ;SAVE C AND D + PUSH TP,D + XOR A,B ; BUILD HASH + XOR A,C + XOR A,D + TLZ A,400000 ; FORCE POS A + HLRZ B,ASOVEC+1(TVP) ;GET LENGTH OF HASH VECTOR + MOVNS B + IDIVI A,(B) ;RELATIVE BUCKET NOW IN B + HRLI B,(B) ;IN CASE GC OCCURS + ADD B,ASOVEC+1(TVP) ;POINT TO BUCKET + MOVEI D,0 ;SET FIRST SWITCH + SKIPN A,(B) ;GET CONTENTS OF BUCKET (DONT SKIP IF EMPTY) + JRST GFALSE + + MOVSI 0,TASOC ;FOR INTGOS, MAKE A TASOC + HLLZM 0,ASTO(PVP) + +IGET1: GETYPF 0,ITEM(A) ;GET ITEMS TYPE + + MOVE E,ITEM+1(A) + CAMN 0,-3(TP) ;COMPARE TYPES + CAME E,-2(TP) ;AND VALUES + JRST NXTASO ;LOSER + GETYPF 0,INDIC(A) ;MOW TRY INDICATORS + MOVE E,INDIC+1(A) + CAMN 0,-1(TP) + CAME E,(TP) + JRST NXTASO + + SKIPN D ;IF 1ST THEN + MOVE C,B ;RETURN POINTER IN C + MOVE B,A ;FOUND, RETURN ASSOCIATION + MOVSI A,TASOC +IGRET: SETZM ASTO(PVP) + POPJ P, + +NXTASO: MOVEI D,1 ;SET SWITCH + MOVE C,A ;CYCLE + HRRZ A,PNTRS(A) ;STEP + JUMPN A,IGET1 + + MOVSI A,TFALSE + MOVEI B,0 + JRST IGRET + +GFALSE: MOVE C,B ;PRESERVE VECTOR POINTER + MOVSI A,TFALSE + SETZB B,D + JRST IGRET + +; FUNCTION TO DO A PUT AND ALSO ADD TO THE NODE FOR THIS GOODIE + +REPEAT 0,[ +MFUNCTION PUTN,SUBR + + ENTRY + + CAML AB,[-4,,0] ;WAS THIS A REMOVAL + JRST PUT + + PUSHJ P,IPUT ;DO THE PUT + SKIPE NODPNT(C) ;NODE CHAIN EXISTS? + JRST FINIS + + PUSH TP,$TASOC ;NO, START TO BUILD + PUSH TP,C + SKIPN DUMNOD+1(TVP) ; FIX UP DUMMY? + PUSHJ P,DUMMAK +CHPT: MOVE C,$TCHSTR + MOVE D,CHQUOTE NODE + PUSHJ P,IGETL + JUMPE B,MAKNOD ;NOT FOUND, LOSE +NODSPL: MOVE C,(TP) ;HERE TO SPLICE IN NEW NODE + MOVE D,VAL+1(B) ;GET POINTER TO NODE STRING + HRRM D,NODPNT(C) ;CLOBBER + HRLM B,NODPNT(C) + SKIPE D ;SPLICE ONLY IF THERE IS SOMETHING THERE + HRLM C,NODPNT(D) + MOVEM C,VAL+1(B) ;COMPLETE NODE CHAIN + MOVE A,2(AB) ;RETURN VALUE + MOVE B,3(AB) + JRST FINIS + +MAKNOD: PUSHJ P,NEWASO ;GENERATE THE NEW ASSOCIATION + MOVE A,@CHPT ;GET UNIQUE STRING + MOVEM A,INDIC(C) ;CLOBBER IN INDIC + MOVE A,@CHPT+1 + MOVEM A,INDIC+1(C) + MOVE B,C ;POINTER TO B + HRRZ C,NODES+1(TVP) ;GET POINTER TO CHAIN OF NODES + HRRZ D,VAL+1(C) ;SKIP DUMMY NODE + HRRM B,VAL+1(C) ;CLOBBER INTO CHAIN + HRRM D,NODPNT(B) + SKIPE D ;SPLICE IF ONLY SOMETHING THERE + HRLM B,NODPNT(D) + HRLM C,NODPNT(B) + MOVSI A,TASOC ;SET TYPE OF VAL TO ASSOCIATION + MOVEM A,VAL(B) + SETZM VAL+1(B) + JRST NODSPL ;GO SPLICE ITEM ONTO NODE +] + +DUMMAK: PUSH TP,A + PUSH TP,B + PUSH TP,C + PUSH TP,D + MOVEI A,ASOLNT + PUSHJ P,IBLOCK + MOVSI A,400000+SASOC+.VECT. + MOVEM A,ASOLNT(B) ;SET SPECIAL TYPE + MOVEM B,DUMNOD+1(TVP) + POP TP,D + POP TP,C + POP TP,B + POP TP,A + POPJ P, + +CLOBTB: ITEM(B) + ITEM+1(B) + INDIC(B) + INDIC+1(B) + VAL(B) + VAL+1(B) + +MFUNCTION ASSOCIATIONS,SUBR + + ENTRY 0 + MOVE B,NODES+1(TVP) +ASSOC1: MOVSI A,TASOC ; SET TYPE + HRRZ B,NODPNT(B) ; POINT TO 1ST REAL NODE + JUMPE B,IFALSE + JRST FINIS + +; RETURN NEXT ASSOCIATION IN CHAIN OR FALSE + +MFUNCTION NEXT,SUBR + + ENTRY 1 + + GETYP 0,(AB) ; BETTER BE ASSOC + CAIE 0,TASOC + JRST WTYP1 ; LOSE + MOVE B,1(AB) ; GET ARG + JRST ASSOC1 + +; GET ITEM/INDICATOR/VALUE CELLS + +MFUNCTION %ITEM,SUBR,ITEM + + MOVEI B,ITEM ; OFFSET + JRST GETIT + +MFUNCTION INDICATOR,SUBR + + MOVEI B,INDIC + JRST GETIT + +MFUNCTION AVALUE,SUBR + + MOVEI B,VAL +GETIT: ENTRY 1 + GETYP 0,(AB) ; BETTER BE ASSOC + CAIE 0,TASOC + JRST WTYP1 + ADD B,1(AB) ; GET ARG + MOVE A,(B) + MOVE B,1(B) + JRST FINIS + +LHCLR: PUSH P,A + GETYP A,A + PUSHJ P,NWORDT ; DEFERRED ? + SOJE A,LHCLR2 + POP P,A +LHCLR1: TLZ A,TYPMSK#<-1> + POPJ P, +LHCLR2: POP P,A + HLLZS A + JRST LHCLR1 + +END + diff --git a/sumex/readch.mcr116 b/sumex/readch.mcr116 new file mode 100644 index 0000000..bec13f5 --- /dev/null +++ b/sumex/readch.mcr116 @@ -0,0 +1,872 @@ +TITLE READC TELETYPE DEVICE HANDLER FOR MUDDLE + +RELOCATABLE + +.INSRT MUDDLE > + +SYSQ + +IF1,[ +IFE ITS,.INSRT MUDSYS;STENEX > +] + +.GLOBAL BUFRIN,CHRCNT,SYSCHR,ECHO,BYTPTR,ERASCH,KILLCH,BRKCH,AGC,CHRWRD,W1CHAR,GWB +.GLOBAL IOIN2,READC,WRONGC,BRFCHR,ESCAP,TTYOPE,MTYI,MTYO,NOTTY,TTYOP2,IBLOCK +.GLOBAL RRESET,TTICHN,TTOCHN,CHANNO,STATUS,BRFCH2,TTYBLK,TTYUNB,WAITNS +.GLOBAL EXBUFR,INCHAR,BYTDOP,BUFSTR,LSTCH,CHNCNT,DIRECT,IOINS,IBLOCK,INCONS +.GLOBAL BADCHN,WRONGD,CHNLOS,MODE1,MODE2,GMTYO,IDVAL,GETCHR,PAGLN,LINLN +.GLOBAL RDEVIC +TTYOUT==1 +TTYIN==2 + +; FLAGS CONCERNING TTY CHANNEL STATE + +N.ECHO==1 ; NO INPUT ECHO +N.CNTL==2 ; NO RUBOUT ^L ^D ECHO +N.IMED==4 ; ALL CHARS WAKE UP +N.IME1==10 ; SOON WILL BE N.IMED + + +; OPEN BLOCK MODE BITS +OUT==1 +IMAGEM==4 +ASCIIM==0 +UNIT==0 + + +; READC IS CALLED BY PUSHJ P,READC +; B POINTS TO A TTY FLAVOR CHANNEL +; ONE CHARACTER IS RETURNED IN A +; BECOMES INTERRUPTABLE IF NO CHARACTERS EXISTS + +; HERE TO ASK SYSTEM FOR SOME CHARACTERS + +INCHAR: IRP A,,[0,C,D,E] ;SAVE ACS + PUSH P,A + TERMIN + MOVE E,BUFRIN(B) ; GET AUX BUFFER + MOVE D,BYTPTR(E) + HLRE 0,E ;FIND END OF BUFFER + SUBM E,0 + ANDI 0,-1 ;ISOLATE RH + MOVE C,SYSCHR(E) ; GET FLAGS + +INCHR1: TRNE C,N.IMED+N.CNTL ; SKIP IF NOT IMMEDIATE + JRST DONE + TLZE D,40 ; SKIP IF NOT ESCAPED + JRST INCHR2 ; ESCAPED + CAMN A,ESCAP(E) ; IF ESCAPE + TLO D,40 ; REMEMBER + CAMN A,BRFCH2(E) + JRST BRF + CAMN A,BRFCHR(E) ;BUFFER PRINT CHAR + JRST CLEARQ ;MAYBE CLEAR SCREEN + CAMN A,BRKCH(E) ;IS THIS A BREAK? + JRST DONE ;YES, DONE + CAMN A,ERASCH(E) ;ARE IS IT ERASE? + JRST ERASE ;YES, GO PROCESS + CAMN A,KILLCH(E) ;OR KILL + JRST KILL + +INCHR2: PUSHJ P,PUTCHR ;PUT ACHAR IN BUFFER +INCHR3: MOVEM D,BYTPTR(E) + JRST DONE1 + +DONE: SKIPL A ; IF JUST BUFFER FORCE, SKIP + PUSHJ P,PUTCHR ; STORE CHAR + MOVEI A,N.IMED ; TURN OFF IMEDIACY + ANDCAM A,SYSCHR(E) + MOVEM D,BYTPTR(E) + PUSH TP,$TCHAN ; SAVE CHANNEL + PUSH TP,B + MOVE A,CHRCNT(E) ; GET # OF CHARS + SETZM CHRCNT(E) + PUSH P,A + ADDI A,4 ; ROUND UP + IDIVI A,5 ; AND DOWN + PUSHJ P,IBLOCK ; GET CORE + HLRE A,B ; FIND D.W. + SUBM B,A + MOVSI 0,TCHRS+.VECT. ; GET TYPE + MOVEM 0,(A) ; AND STORE + MOVEI D,(B) ; COPY PNTR + POP P,C ; CHAR COUNT + HRLI D,440700 + HRLI C,TCHSTR + PUSH TP,C + PUSH TP,D + PUSHJ P,INCONS ; CONS IT ON + MOVE C,-2(TP) ; GET CHAN BACK + MOVEI D,EXBUFR(C) ; POINT TO BUFFER LIST + HRRZ 0,(D) ; LAST? + JUMPE 0,.+3 + MOVE D,0 + JRST .-3 ; GO UNTIL END + HRRM B,(D) ; SPLICE + +; HERE TO BLT IN BUFFER + + MOVE D,BUFRIN(C) ; POINT TO COMPLETED BUFFER + HRRZ C,(TP) ; START OF NEW STRING + HRLI C,BYTPTR+1(D) ; 1ST WORD OF CHARS + MOVE E,[010700,,BYTPTR(E)] + EXCH E,BYTPTR(D) ; END OF STRING + MOVEI E,-BYTPTR(E) + ADD E,(TP) ; ADD TO START + BLT C,-1(E) + MOVE B,-2(TP) ; CHANNEL BACK + SUB TP,[4,,4] ; FLUSH JUNK + PUSHJ P,TTYUNB ; UNBLOCK THIS TTY +DONE1: IRP A,,[E,D,C,0] + POP P,A + TERMIN + POPJ P, + + +ERASE: SKIPN CHRCNT(E) ;ANYTHING IN BUFFER? + JRST BARFCR ;NO, MAYBE TYPE CR + + SOS CHRCNT(E) ;DELETE FROM COUNT + LDB A,D ;RE-GOBBLE LAST CHAR +IFN ITS,[ + LDB C,[600,,STATUS(B)] ; CHECK FOR IMLAC + CAIE C,2 ; SKIP IF IT IS +] + JRST TYPCHR + SKIPN ECHO(E) ; SKIP IF ECHOABLE + JRST NECHO + PUSHJ P,CHRTYP ; FOUND OUT IMALC BEHAVIOR + SKIPGE C,FIXIM2(C) + JRST (C) +NOTFUN: PUSHJ P,DELCHR + SOJG C,.-1 + +NECHO: ADD D,[70000,,0] ;DECREMENT BYTE POINTER + JUMPGE D,INCHR3 ;AND GO ON, UNLESS BYTE POINTER LOST + SUB D,[430000,,1] ;FIX UP BYTE POINTER + JRST INCHR3 + +LFKILL: PUSHJ P,LNSTRV + JRST NECHO + +BSKILL: PUSHJ P,GETPOS ; CURRENT POSITION TO A + PUSHJ P,SETPOS ; POSITION IMLAC CURSOR + MOVEI A,20 ; ^P + XCT ECHO(E) + MOVEI A,"L ; L , DELETE TO END OF LINE + XCT ECHO(E) + JRST NECHO + +TBKILL: PUSHJ P,GETPOS + ANDI A,7 + SUBI A,10 ; A -NUMBER OF DELS TO DO + PUSH P,A + PUSHJ P,DELCHR + AOSE (P) + JRST .-2 + + SUB P,[1,,1] + JRST NECHO +TYPCHR: +IFE ITS,[ + PUSH P,A ; USE TENEX SLASH RUBOUT + MOVEI A,"\ + SKIPE C,ECHO(E) + XCT C + POP P,A +] + SKIPE C,ECHO(E) + XCT C + JRST NECHO + +; ROUTINE TO DEL CHAR ON IMLAC + +DELCHR: MOVEI A,20 + XCT ECHO(E) + MOVEI A,"X + XCT ECHO(E) + POPJ P, + +; HERE FOR SPECIAL IMLAC HACKS + +FOURQ: PUSH P,CNOTFU +FOURQ2: MOVEI C,2 ; FOR ^Z AND ^_ + CAMN B,TTICHN+1(TVP) ; SKIP IF NOT CONSOLE TTY + MOVEI C,4 +CNOTFU: POPJ P,NOTFUN + +CNECHO: JRST NECHO + +LNSTRV: MOVEI A,20 ; ^P + XCT ECHO(E) + MOVEI A,"U + XCT ECHO(E) + POPJ P, + +; HERE IF KILLING A C.R., RE-POSITION CURSOR + +CRKILL: PUSHJ P,GETPOS ; COMPUTE LINE POS + PUSHJ P,SETPOS + JRST NECHO + +SETPOS: PUSH P,A ; SAVE POS + MOVEI A,20 + XCT ECHO(E) + MOVEI A,"H + XCT ECHO(E) + POP P,A + XCT ECHO(E) ; HORIZ POSIT AT END OF LINE + POPJ P,0 + +GETPOS: PUSH P,0 + MOVEI 0,10 ; MINIMUM CURSOR POS + PUSH P,[010700,,BYTPTR(E)] ; POINT TO BUFFER + PUSH P,CHRCNT(E) ; NUMBER THEREOF + +GETPO1: SOSGE (P) ; COUNT DOWN + JRST GETPO2 + ILDB A,-1(P) ; CHAR FROM BUFFER + CAIN A,15 ; SKIP IF NOT CR + MOVEI 0,10 ; C.R., RESET COUNT + PUSHJ P,CHRTYP ; GET TYPE + XCT FIXIM3(C) ; GET FIXED COUNT + ADD 0,C + JRST GETPO1 + +GETPO2: MOVE A,0 ; RET COUNT + MOVE 0,-2(P) ; RESTORE AC 0 + SUB P,[3,,3] + POPJ P, + +CHRTYP: MOVEI C,0 ; NUMBER OF FLUSHEES + CAILE A,37 ; SKIP IF CONTROL CHAR + POPJ P, + PUSH TP,$TCHAN + PUSH TP,B ; SAVE CHAN + IDIVI A,12. ; FIND SPECIAL HACKS + MOVE A,FIXIML(A) ; GET CONT WORD + IMULI B,3 + ROTC A,3(B) ; GET CODE IN B + ANDI B,7 + MOVEI C,(B) + MOVE B,(TP) ; RESTORE CHAN + SUB TP,[2,,2] + POPJ P, + +FIXIM2: 1 + 2 + SETZ FOURQ + SETZ CRKILL + SETZ LFKILL + SETZ BSKILL + SETZ TBKILL + +FIXIM3: MOVEI C,1 + MOVEI C,2 + PUSHJ P,FOURQ2 + MOVEI C,0 + MOVEI C,0 + MOVNI C,1 + PUSHJ P,CNTTAB + +CNTTAB: ANDCMI 0,7 ; GET COUNT INCUDING TAB HACK + ADDI 0,10 + MOVEI C,0 + POPJ P, + +FIXIML: 111111,,115641 ; CNTL @ABCDE,,FGHIJK + 131111,,111111 ; LMNOPQ,,RSTUVW + 112011,,120000 ; XYZ LBRAK \ RBRAK,,^ _ + +; HERE TO KILL THE WHOLE BUFFER + +KILL: CLEARM CHRCNT(E) ;NONE LEFT NOW + MOVE D,[010700,,BYTPTR(E)] ;RESET POINTER + +BARFCR: +IFN ITS,[ + MOVE A,ERASCH(E) ;GET THE ERASE CHAR + CAIN A,177 ;IS IT RUBOUT? +] + PUSHJ P,CRLF1 ; PRINT CR-LF + JRST INCHR3 + +CLEARQ: +IFN ITS,[ + MOVE A,STATUS(B) ;CHECK CONSOLE KIND + ANDI A,77 + CAIN A,2 ;DATAPOINT? + PUSHJ P,CLR ;YES, CLEAR SCREEN +] + +BRF: MOVE C,[010700,,BYTPTR(E)] ;POINT TO START OF BUFFER + SKIPN ECHO(E) ;ANY ECHO INS? + JRST NECHO + + PUSHJ P,CRLF2 + PUSH P,CHRCNT(E) + + SOSGE (P) + JRST DECHO + ILDB A,C ;GOBBLE CHAR + XCT ECHO(E) ;ECHO IT + JRST .-4 ;DO FOR ENTIRE BUFFER + +DECHO: SUB P,[1,,1] + JRST INCHR3 + +CLR: SKIPN C,ECHO(E) ;ONLY IF INS EXISTS + POPJ P, + MOVEI A,20 ;ERASE SCREEN + XCT C + MOVEI A,103 + XCT C + POPJ P, + +PUTCHR: AOS CHRCNT(E) ;COUNT THIS CHARACTER + IBP D ;BUMP BYTE POINTER + CAIG 0,@D ;DONT SKIP IF BUFFER FULL + PUSHJ P,BUFULL ;GROW BUFFER +IFE ITS,[ + CAIN A,37 ; CHANGE EOL TO CRLF + MOVEI A,15 +] + DPB A,D ;CLOBBER BYTE POINTER IN + MOVE C,SYSCHR(E) ; FLAGS + TRNN C,N.IMED+N.CNTL + CAIE A,15 ; IF CR INPUT, FOLLOW WITH LF + POPJ P, + MOVEI A,12 ; GET LF + JRST PUTCHR + +; BUFFER FULL, GROW THE BUFFER + +BUFULL: PUSH TP,$TCHAN ;SAVE B + PUSH TP,B + PUSH P,A ; SAVE CURRENT CHAR + HLRE A,BUFRIN(B) + MOVNS A + ADDI A,100 ; MAKE ONE LONGER + PUSHJ P,IBLOCK ; GET IT + MOVE A,(TP) ;RESTORE CHANNEL POINTER + SUB TP,[2,,2] ;AND REMOVE CRUFT + MOVE E,BUFRIN(A) ;GET AUX BUFFER POINTER + MOVEM B,BUFRIN(A) + HLRE 0,E ;RECOMPUTE 0 + MOVSI E,(E) + HRRI E,(B) ; POINT TO DEST + SUB B,0 + BLT E,(B) + MOVEI 0,100-2(B) + MOVE B,A + POP P,A + POPJ P, + +; ROUTINE TO CRLF ON ANY TTY + +CRLF1: SKIPN ECHO(E) + POPJ P, ; NO ECHO INS +CRLF2: MOVEI A,15 + XCT ECHO(E) + MOVEI A,12 + XCT ECHO(E) + POPJ P, + +; SUBROUTINE TO FLUSH BUFFER + +RRESET: SETZM LSTCH(B) ; CLOBBER RE-USE CHAR + MOVE E,BUFRIN(B) ;GET AUX BUFFER + SETZM CHRCNT(E) + MOVEI D,N.IMED+N.IME1 + ANDCAM D,SYSCHR(E) + MOVE D,[010700,,BYTPTR(E)] ;RESET BYTE POINTER + MOVEM D,BYTPTR(E) + MOVE D,CHANNO(B) ;GOBBLE CHANNEL + SETZM CHNCNT(D) ; FLUSH COUNTERS +IFN ITS,[ + LSH D,23. ;POSITION + IOR D,[.RESET 0] + XCT D ;RESET ITS CHANNEL +] +IFE ITS,[ + MOVEI A,100 ; TTY IN JFN + CFIBF +] + SETZM EXBUFR(B) ; CLOBBER STAKED BUFFS + MOVEI C,BUFSTR-1(B) ; FIND D.W. + PUSHJ P,BYTDOP + SUBI A,2 + HRLI A,010700 + MOVEM A,BUFSTR(B) + HLLZS BUFSTR-1(B) + POPJ P, + +; SUBROUTINE TO ESTABLISH ECHO IOINS + +MFUNCTION ECHOPAIR,SUBR + + ENTRY 2 + + GETYP A,(AB) ;CHECK ARG TYPES + GETYP C,2(AB) + CAIN A,TCHAN ;IS A CHANNEL + CAIE C,TCHAN ;IS C ALSO + JRST WRONGT ;NO, ONE OF THEM LOSES + + MOVE A,1(AB) ;GET CHANNEL + PUSHJ P,TCHANC ; VERIFY TTY IN + MOVE D,3(AB) ;GET OTHER CHANNEL + MOVEI B,DIRECT-1(D) ;AND ITS DIRECTION + PUSHJ P,CHRWRD + JFCL + CAME B,[ASCII /PRINT/] + JRST WRONGD + + MOVE B,BUFRIN(A) ;GET A'S AUX BUFFER + HRLZ C,CHANNO(D) ; GET CHANNEL + LSH C,5 + IOR C,[.IOT A] ; BUILD AN IOT + MOVEM C,ECHO(B) ;CLOBBER +CHANRT: MOVE A,(AB) + MOVE B,1(AB) ;RETURN 1ST ARG + JRST FINIS + +TCHANC: MOVEI B,DIRECT-1(A) ;GET DIRECTION + PUSHJ P,CHRWRD ; CONVERT + JFCL + CAME B,[ASCII /READ/] + JRST WRONGD + LDB C,[600,,STATUS(A)] ;GET A CODE + CAILE C,2 ;MAKE SURE A TTY FLAVOR DEVICE + JRST WRONGC + POPJ P, +IFE ITS,[ +TTYOPEN: +TTYOP2: MOVEI A,-1 ; TENEX JFN FOR TERMINAL + MOVEI 2,145100 ; MAGIC BITS (SEE TENEX MANUAL) + SFMOD ; ZAP + RFMOD ; LETS FIND SCREEN SIZE + LDB A,[220700,,B] ; GET PAGE WIDTH + LDB B,[310700,,B] ; AND LENGTH + MOVE C,TTOCHN+1(TVP) + MOVEM A,LINLN(C) + MOVEM B,PAGLN(C) + MOVEI A,-1 ; NOW HACK CNTL CHAR STUFF + RFCOC ; GET CURRENT + AND B,[036377,,-1] ; CHANGE FOR ^@, ^A AND ^D (FOR NOW) + SFCOC ; AND RESUSE IT + + POPJ P, +] + +IFN ITS,[ +TTYOP2: .SUSET [.RTTY,,C] + SETZM NOTTY + JUMPL C,TTYNO ; DONT HAVE TTY + +TTYOPEN: + SKIPE NOTTY + POPJ P, + .OPEN TTYIN,[SIXBIT / TTY/] + JRST TTYNO + .OPEN TTYOUT,[21,,(SIXBIT /TTY/)] ;AND OUTPUT + FATAL CANT OPEN TTY + DOTCAL TTYGET,[[1000,,TTYOUT],[2000,,0],[2000,,A],[2000,,B]] + FATAL .CALL FAILURE + DOTCAL TTYSET,[[1000,,TTYOUT],MODE1,MODE2,B] + FATAL .CALL FAILURE + +SETCHN: MOVE B,TTICHN+1(TVP) ;GET CHANNEL + MOVEI C,TTYIN ;GET ITS CHAN # + MOVEM C,CHANNO(B) + .STATUS TTYIN,STATUS(B) ;CLOBBER STATUS + + MOVE B,TTOCHN+1(TVP) ;GET OUT CHAN + MOVEI C,TTYOUT + MOVEM C,CHANNO(B) + .STATUS TTYOUT,STATUS(B) + SETZM IMAGFL ;RESET IMAGE MODE FLAG + HLLZS IOINS-1(B) + DOTCAL RSSIZE,[[1000,,TTYOUT],[2000,,C],[2000,,D]] + FATAL .CALL RSSIZE LOSSAGE + MOVEM C,PAGLN(B) + MOVEM D,LINLN(B) + POPJ P, + +; HERE IF TTY WONT OPEN + +TTYNO: SETOM NOTTY + POPJ P, +] + +MTYI: SKIPE NOTTY ; SKIP IF HAVE TTY + FATAL TRIED TO USE NON-EXISTANT TTY +IFN ITS, .IOT TTYIN,A +IFE ITS, PBIN + POPJ P, + +MTYO: SKIPE NOTTY + POPJ P, ; IGNORE, DONT HAVE TTY + SKIPE IMAGFL ;SKIP RE-OPENING IF ALREADY IN ASCII + PUSHJ P,MTYO1 ;WAS IN IMAGE...RE-OPEN + CAIE A,177 ;DONT OUTPUT A DELETE +IFN ITS, .IOT TTYOUT,A +IFE ITS, PBOUT + POPJ P, + +MTYO1: MOVE B,TTOCHN+1(TVP) + PUSH P,0 + PUSHJ P,REASCI + POP P,0 + POPJ P, + +; HERE FOR TYO TO ANY TTY FLAVOR DEVICE + +GMTYO: PUSH P,0 + HRRZ 0,IOINS-1(B) ; GET FLAG + SKIPE 0 + PUSHJ P,REASCI ; RE-OPEN TTY + HRLZ 0,CHANNO(B) + ASH 0,5 + IOR 0,[.IOT A] + CAIE A,177 ; DONE OUTPUT A DELETE + XCT 0 + POP P,0 + POPJ P, + +REASCI: PUSH P,A + PUSH P,C + PUSHJ P,DEVTOC + HRLI C,21 ; ASCII GRAPHIC BIT + MOVE A,CHANNO(B) ; GET CHANNEL + ASH A,23. ; TO AC FIELD + IOR A,[.OPEN 0,C] + XCT A + FATAL TTY OPEN LOSSAGE + POP P,C + POP P,A + HLLZS IOINS-1(B) + CAMN B,TTOCHN+1(TVP) + SETZM IMAGFL + POPJ P, + + + +WRONGC: PUSH TP,$TATOM + PUSH TP,EQUOTE NOT-A-TTY-TYPE-CHANNEL + JRST CALER1 + + + +; HERE TO HANDLE TTY BLOCKING AND UNBLOCKING + +TTYBLK: PUSH TP,$TCHAN + PUSH TP,B + PUSH P,0 + PUSH P,E ; SAVE SOME ACS +IFN ITS,[ + MOVE A,CHANNO(B) ; GET CHANNEL NUMBER + SOSG CHNCNT(A) ; ANY PENDING CHARS + JRST TTYBL1 + SETZM CHNCNT(A) + MOVEI 0,1 + LSH 0,(A) + .SUSET [.SIFPI,,0] ; SLAM AN INT ON +] +TTYBL1: MOVE C,BUFRIN(B) + MOVE A,SYSCHR(C) ; GET FLAGS + TRZ A,N.IMED + TRZE A,N.IME1 ; IF WILL BE + TRO A,N.IMED ; THE MAKE IT + MOVEM A,SYSCHR(C) +IFN ITS,[ + MOVE A,[.CALL TTYIOT]; NON-BUSY WAIT + SKIPE NOTTY + MOVE A,[.SLEEP A,] +] +IFE ITS,[ + MOVE A,[PUSHJ P,TNXIN] +] + MOVEM A,WAITNS(B) + PUSH TP,$TCHSTR + PUSH TP,CHQUOTE BLOCKED + PUSH TP,$TPVP + PUSH TP,PVP + MCALL 2,INTERRUPT + MOVSI A,TCHAN + MOVEM A,BSTO(PVP) + MOVE B,(TP) + ENABLE +REBLK: MOVEI A,-1 ; IN CASE SLEEPING + XCT WAITNS(B) ; NOW WAIT + JFCL +IFE ITS, JRST .-3 +IFN ITS, JRST CHRSNR ; SNARF CHAR +REBLK1: DISABLE ; FALL THROUG=> UNBLOCKED + SETZM BSTO(PVP) + POP P,E + POP P,0 + MOVE B,(TP) + SUB TP,[2,,2] + POPJ P, + +CHRSNR: SKIPE NOTTY ; TTY? + JRST REBLK ; NO, JUST RESET AND BLOCK + .SUSET [.SIFPI,,[1_<TTYIN>]] + JRST REBLK ; AND GO BACK + +TTYIOT: SETZ + SIXBIT /IOT/ + 1000,,TTYIN + 0 + 405000,,20000 + +; HERE TO UNBLOCK TTY + +TTYUNB: MOVE A,WAITNS(B) ; GET INS + CAMN A,[JRST REBLK1] + JRST TTYUN1 + MOVE A,[JRST REBLK1] ; LEAVE THE SLEEP + MOVEM A,WAITNS(B) + PUSH TP,$TCHAN + PUSH TP,B + PUSH TP,$TCHSTR + PUSH TP,CHQUOTE UNBLOCKED + PUSH TP,$TCHAN + PUSH TP,B + MCALL 2,INTERRUPT + MOVE B,(TP) ; RESTORE CHANNEL + SUB TP,[2,,2] +TTYUN1: POPJ P, + +IFE ITS,[ +; TENEX BASIC TTY I/O ROUTINE + +TNXIN: PUSHJ P,MTYI + PUSHJ P,INCHAR + POPJ P, +] +MFUNCTION TTYECHO,SUBR + + ENTRY 2 + + GETYP 0,(AB) + CAIE 0,TCHAN + JRST WTYP1 + MOVE A,1(AB) ; GET CHANNEL + PUSHJ P,TCHANC ; MAKE SURE IT IS TTY INPUT + MOVE E,BUFRIN(A) ; EXTRA INFO BUFFER +IFN ITS,[ + DOTCAL TTYGET,[CHANNO(A),[2000,,B],[2000,,C],[2000,,0]] + FATAL .CALL FAILURE +] +IFE ITS,[ + MOVEI A,100 ; TTY JFN + RFMOD ; MODE IN B + TRZ B,6000 ; TURN OFF ECHO +] + GETYP D,2(AB) ; ARG 2 + CAIE D,TFALSE ; SKIP IF WANT ECHO OFF + JRST ECHOON + +IFN ITS,[ + ANDCM B,[606060,,606060] + ANDCM C,[606060,,606060] + + DOTCAL TTYSET,[CHANNO(A),B,C,0] + FATAL .CALL FAILURE +] +IFE ITS,[ + SFMOD +] + + MOVEI B,N.ECHO+N.CNTL ; SET FLAGS + IORM B,SYSCHR(E) + + JRST CHANRT + +ECHOON: +IFN ITS,[ + IOR B,[202020,,202020] + IOR C,[202020,,202020] + DOTCAL TTYSET,[CHANNO(A),B,C,0] + FATAL .CALL FAILURE +] +IFE ITS,[ + TRO B,4000 + SFMOD +] + MOVEI A,N.ECHO+N.CNTL + ANDCAM A,SYSCHR(E) + JRST CHANRT + + + +; USER SUBR FOR INSTANT CHARACTER SNARFING + +MFUNCTION UTYI,SUBR,TYI + + ENTRY + CAMGE AB,[-3,,] + JRST TMA + MOVE A,(AB) + MOVE B,1(AB) + JUMPL AB,.+3 + MOVE B,IMQUOTE INCHAN + PUSHJ P,IDVAL ; USE INCHAN + GETYP 0,A ; GET TYPE + CAIE 0,TCHAN + JRST WTYP1 + LDB 0,[600,,STATUS(B)] + CAILE 0,2 + JRST WTYP1 + SKIPN A,LSTCH(B) ; ANY READ AHEAD CHAR + JRST UTYI1 ; NO, SKIP + SETZM LSTCH(B) + TLZN A,400000 ; ! HACK? + JRST UTYI2 ; NO, OK + MOVEM A,LSTCH(B) ; YES SAVE + MOVEI A,"! ; RET AN ! + JRST UTYI2 + +UTYI1: MOVE 0,IOINS(B) + CAME 0,[PUSHJ P,GETCHR] + JRST WTYP1 + PUSH TP,$TCHAN + PUSH TP,B + MOVE C,BUFRIN(B) + MOVEI D,N.IME1+N.IMED + IORM D,SYSCHR(C) ; CLOBBER IT IN + DOTCAL TTYGET,[CHANNO(B),[2000,,A],[2000,,D],[2000,,0]] + FATAL .CALL FAILURE + PUSH P,A + PUSH P,0 + PUSH P,D ; SAVE THEM + IOR D,[030303,,030303] + IOR A,[030303,,030303] + DOTCAL TTYSET,[CHANNO(B),A,D,0] + FATAL .CALL FAILURE + MOVNI A,1 + SKIPE CHRCNT(C) ; ALREADY SOME? + PUSHJ P,INCHAR + MOVE C,BUFRIN(B) ; GET BUFFER BACK + MOVEI D,N.IME1 + IORM D,SYSCHR(C) + PUSHJ P,GETCHR + MOVE B,1(TB) + MOVE C,BUFRIN(B) + MOVEI D,N.IME1+N.IMED + ANDCAM D,SYSCHR(C) + POP P,D + POP P,0 + POP P,C + DOTCAL TTYSET,[CHANNO(B),C,D,0] + FATAL .CALL FAILURE +UTYI2: MOVEI B,(A) + MOVSI A,TCHRS + JRST FINIS + +MFUNCTION IMAGE,SUBR + ENTRY + JUMPGE AB,TFA ; 1 OR 2 ARGS NEEDED + GETYP A,(AB) ;GET THE TYPE OF THE ARG + CAIE A,TFIX ;CHECK IT FOR CORRECT TYPE + JRST WTYP1 ;WAS WRONG...ERROR EXIT + HLRZ 0,AB + CAIL 0,-2 + JRST USEOTC + CAIE 0,-4 + JRST TMA + GETYP 0,2(AB) + CAIE 0,TCHAN + JRST WTYP2 + MOVE B,3(AB) ; GET CHANNEL +IMAGE1: LDB 0,[600,,STATUS(B)] + CAILE 0,2 ; MUST BE TTY + JRST IMAGFO + MOVE 0,IOINS(B) + CAMN 0,[PUSHJ P,MTYO] + JRST .+3 + CAME 0,[PUSHJ P,GMTYO] + JRST WRONGD + HRRZ 0,IOINS-1(B) + JUMPE 0,OPNIMG +IMGIOT: MOVE A,1(AB) ;GET VALUE + HRLZ 0,CHANNO(B) + ASH 0,5 + IOR 0,[.IOT A] + XCT 0 +IMGEXT: MOVE A,(AB) ;RETURN THE ORIGINAL ARG + MOVE B,1(AB) + JRST FINIS ;EXIT + + +IMAGFO: PUSH TP,$TCHAN ;IMAGE OUTPUT FOR NON TTY + PUSH TP,B + MOVEI B,DIRECT-1(B) + PUSHJ P,CHRWRD + JFCL + CAME B,[ASCII /PRINT/] + CAMN B,[<ASCII /PRINT/>+1] + JRST .+2 + JRST BADCHN ; CHANNEL COULDNT BE BLESSED + MOVE B,(TP) + PUSHJ P,GWB ; MAKE SURE CHANNEL HAS BUFFER + MOVE A,1(AB) ; GET THE CHARACTER TO DO + PUSHJ P,W1CHAR + MOVE A,(AB) + MOVE B,1(AB) ;RETURN THE FIX + JRST FINIS + + +USEOTC: MOVSI A,TATOM + MOVE B,IMQUOTE OUTCHAN + PUSHJ P,IDVAL + GETYP 0,A + CAIE 0,TCHAN + MOVE B,TTICHN+1(TVP) + JRST IMAGE1 + +OPNIMG: HLLOS IOINS-1(B) + CAMN B,TTOCHN+1(TVP) + SETOM IMAGFL + PUSHJ P,DEVTOC + HRLI C,41 ; SUPER IMAGE BIT + MOVE A,CHANNO(B) + ASH A,23. + IOR A,[.OPEN 0,C] + XCT A + FATAL TTY OPEN LOSSAGE + JRST IMGIOT + +DEVTOC: PUSH P,D + PUSH P,E + PUSH P,0 + PUSH P,A + MOVE D,RDEVIC(B) + MOVE E,[220600,,C] + MOVEI A,3 + MOVEI C,0 + ILDB 0,D + SUBI 0,40 + IDPB 0,E + SOJG A,.-3 + POP P,A + POP P,0 + POP P,E + POP P,D + POPJ P, + +IMGBLK: OUT+IMAGEM+UNIT,,(SIXBIT /TTY/) + 0 + 0 + + + +IMPURE +IMAGFL: 0 +PURE + + +END + diff --git a/sumex/reader.mcr264 b/sumex/reader.mcr264 new file mode 100644 index 0000000..5468f07 --- /dev/null +++ b/sumex/reader.mcr264 @@ -0,0 +1,2121 @@ +TITLE READER FOR MUDDLE + +;C. REEVE DEC. 1970 + +RELOCA + +READER==1 ;TELL MUDDLE > TO USE SOME SPECIAL HACKS +FRMSIN==1 ;FLAG SAYING WHETHER OR "." AND "'" HACKS EXIST + +.INSRT MUDDLE > + +.GLOBAL CONS,VECTOR,NXTCHR,RLOOKU,CRADIX,SPTIME,QUOTE,TENTAB,CHMAK,FLUSCH,ITENTB +.GLOBAL SETDEV,OPNCHN,ILVAL,RADX,IDVAL,LSTCH,EVECTOR,EUVECTOR,CHUNW +.GLOBAL CHRWRD,EOFCND,DIRECT,ACCESS,IOINS,ROOT,DIRECT,DOIOTI,DOACCS,IGVAL,BYTDOP +.GLOBAL ICONS,INCONS,IEVECT,IEUVEC,BUFSTR,TYPFND,SQUTOA,IBLOCK,GRB +.GLOBAL BADCHN,WRONGD,CHNCLS,FNFFL,IPUT,IGET,ILOC,RXCT,WXCT,IUNWIN,UNWIN2 +.GLOBAL CNXTCH,CREADC,MPOPJ,CREDC1,CNXTC1,IREMAS + +BUFLNT==100 + +FF=0 ;FALG REGISTER DURING NUMBER CONVERSION + +;FLAGS USED (RIGHT HALF) + +NOTNUM==1 ;NOT A NUMBER +NFIRST==2 ;NOT FIRST CHARACTER BEING READ +DECFRC==4 ;FORCE DECIMAL CONVERSION +NEGF==10 ;NEGATE THIS THING +NUMWIN==20 ;DIGIT(S) SEEN +INSTRN==40 ;IN QUOTED CHARACTER STRING +FLONUM==100 ;NUMBER IS FLOOATING POINT +DOTSEN==200 ;. SEEN IN IMPUT STREAM +EFLG==400 ;E SEEN FOR EXPONENT +IFN FRMSIN,[ + FRSDOT==1000 ;. CAME FIRST + USEAGN==2000 ;SPECIAL DOT HACK +] +OCTWIN==4000 +OCTSTR==10000 + +;TEMPORARY OFFSETS + +VCNT==0 ;NUMBER OF ELEMENTS IN CURRENT VECTOR +ONUM==1 ;CURRENT NUMBER IN OCTAL +DNUM==3 ;CURRENT NUMBER IN DECIMAL +FNUM==5 ;CURRENTLY UNUSED +CNUM==7 ;IN CURRENT RADIX +NDIGS==11 ;NUMBER OF DIGITS +ENUM==13 ;EXPONENT + + + ; TEXT FILE LOADING PROGRAM + +MFUNCTION MLOAD,SUBR,[LOAD] + + ENTRY + + HLRZ A,AB ;GET NO. OF ARGS + CAIE A,-4 ;IS IT 2 + JRST TRY2 ;NO, TRY ANOTHER + GETYP A,2(AB) ;GET TYPE + CAIE A,TOBLS ;IS IT OBLIST + CAIN A,TLIST ; OR LIST THEREOF? + JRST CHECK1 + JRST WTYP2 + +TRY2: CAIE A,-2 ;IS ONE SUPPLIED + JRST WNA + +CHECK1: GETYP A,(AB) ;GET TYPE + CAIE A,TCHAN ;IS IT A CHANNEL + JRST WTYP1 + +LOAD1: HLRZ A,TB ;GET CURRENT TIME + PUSH TP,$TTIME ;AND SAVE IT + PUSH TP,A + + MOVEI C,CLSNGO ; LOCATION OF FUNNY CLOSER + PUSHJ P,IUNWIN ; SET UP AS UNWINDER + +LOAD2: PUSH TP,(AB) ;USE SUPPLIED CHANNEL + PUSH TP,1(AB) + PUSH TP,(TB) ;USE TIME AS EOF ARG + PUSH TP,1(TB) + CAML AB,[-2,,0] ;CHECK FOR 2ND ARG + JRST LOAD3 ;NONE + PUSH TP,2(AB) ;PUSH ON 2ND ARG + PUSH TP,3(AB) + MCALL 3,READ + JRST CHKRET ;CHECK FOR EOF RET + +LOAD3: MCALL 2,READ +CHKRET: CAMN A,(TB) ;IS TYPE EOF HACK + CAME B,1(TB) ;AND IS VALUE + JRST EVALIT ;NO, GO EVAL RESULT + PUSH TP,(AB) + PUSH TP,1(AB) + MCALL 1,FCLOSE + MOVE A,$TCHSTR + MOVE B,CHQUOTE DONE + JRST FINIS + +CLSNGO: PUSH TP,$TCHAN + PUSH TP,1(AB) + MCALL 1,FCLOSE + JRST UNWIN2 ; CONTINUE UNWINDING + +EVALIT: PUSH TP,A + PUSH TP,B + MCALL 1,EVAL + JRST LOAD2 + + + +; OTHER FILE LOADING PROGRAM + + + +MFUNCTION FLOAD,SUBR + + ENTRY + + MOVEI C,1 ;INITIALIZE OPEN'S ARG COUNT + PUSH TP,$TAB ;SLOT FOR SAVED AB + PUSH TP,[0] ;EMPTY FOR NOW + PUSH TP,$TCHSTR ;PUT IN FIRST ARG + PUSH TP,CHQUOTE READ + MOVE A,AB ;COPY OF ARGUMENT POINTER + +FARGS: JUMPGE A,CALOPN ;DONE? IF SO CALL OPEN + GETYP B,(A) ;NO, CHECK TYPE OF THIS ARG + CAIE B,TOBLS ;OBLIST? + CAIN B,TLIST ; OR LIST THEREOF + JRST OBLSV ;YES, GO SAVE IT + + PUSH TP,(A) ;SAVE THESE ARGS + PUSH TP,1(A) + ADD A,[2,,2] ;BUMP A + AOJA C,FARGS ;COUNT AND GO + +OBLSV: MOVEM A,1(TB) ;SAVE THE AB + +CALOPN: ACALL C,FOPEN ;OPEN THE FILE + + JUMPGE B,FNFFL ;FILE MUST NO EXIST + EXCH A,(TB) ;PLACE CHANNEL ON STACK + EXCH B,1(TB) ;OBTAINING POSSIBLE OBLIST + JUMPN B,2ARGS ;OBLIST SUOPPLIED? + + MCALL 1,MLOAD ;NO, JUST CALL + JRST FINIS + + +2ARGS: PUSH TP,(B) ;PUSH THE OBLIST + PUSH TP,1(B) + MCALL 2,MLOAD + JRST FINIS + + +FNFFL: PUSH TP,$TATOM + PUSH TP,EQUOTE FILE-SYSTEM-ERROR + JUMPE B,CALER1 + PUSH TP,A + PUSH TP,B + MOVEI A,2 + JRST CALER + + MFUNCTION READ,SUBR + + ENTRY + + PUSH P,[IREAD1] ;WHERE TO GO AFTER BINDING +READ0: PUSH TP,$TTP ;SLOT FOR LAST THING READ (TYPE IS UNREADABLE) + PUSH TP,[0] + PUSH TP,$TFIX ;SLOT FOR RADIX + PUSH TP,[0] + PUSH TP,$TCHAN ;AND SLOT FOR CHANNEL + PUSH TP,[0] + PUSH TP,[0] ; USER DISP SLOT + PUSH TP,[0] + PUSH TP,$TSPLICE + PUSH TP,[0] ;SEGMENT FOR SPLICING MACROS + JUMPGE AB,READ1 ;NO ARGS, NO BINDING + GETYP C,(AB) ;ISOLATE TYPE + CAIN C,TUNBOU + JRST WTYP1 + PUSH TP,[TATOM,,-1] ;PUSH THE ATOMS + PUSH TP,IMQUOTE INCHAN + PUSH TP,(AB) ;PUSH ARGS + PUSH TP,1(AB) + PUSH TP,[0] ;DUMMY + PUSH TP,[0] + MOVE B,1(AB) ;GET CHANNEL POINTER + ADD AB,[2,,2] ;AND ARG POINTER + JUMPGE AB,BINDEM ;MORE? + PUSH TP,[TVEC,,-1] + ADD B,[EOFCND-1,,EOFCND-1] + PUSH TP,B + PUSH TP,(AB) + PUSH TP,1(AB) + ADD AB,[2,,2] + JUMPGE AB,BINDEM ;IF ANY MORE ARGS GO PROCESS AND BIND THEM + GETYP C,(AB) ;ISOLATE TYPE + CAIE C,TLIST + CAIN C,TOBLS + SKIPA + JRST WTYP3 + PUSH TP,[TATOM,,-1] ;PUSH THE ATOMS + PUSH TP,IMQUOTE OBLIST + PUSH TP,(AB) ;PUSH ARGS + PUSH TP,1(AB) + PUSH TP,[0] ;DUMMY + PUSH TP,[0] + ADD AB,[2,,2] ;AND ARG POINTER + JUMPGE AB,BINDEM ; ALL DONE, BIND ATOMS + GETYP 0,(AB) ; GET TYPE OF TABLE + CAIE 0,TVEC ; SKIP IF BAD TYPE + JRST WTYP ; ELSE COMPLAIN + PUSH TP,[TATOM,,-1] + PUSH TP,IMQUOTE READ-TABLE + PUSH TP,(AB) + PUSH TP,1(AB) + PUSH TP,[0] + PUSH TP,[0] + ADD AB,[2,,2] ; BUMP TO NEXT ARG + JUMPL AB,TMA ;MORE ?, ERROR +BINDEM: PUSHJ P,SPECBIND + JRST READ1 + +MFUNCTION RREADC,SUBR,READCHR + + ENTRY + PUSH P,[IREADC] + JRST READC0 ;GO BIND VARIABLES + +MFUNCTION NXTRDC,SUBR,NEXTCHR + + ENTRY + + PUSH P,[INXTRD] +READC0: CAMGE AB,[-5,,] + JRST TMA + PUSH TP,(AB) + PUSH TP,1(AB) + JUMPL AB,READC1 + MOVE B,IMQUOTE INCHAN + PUSHJ P,IDVAL + GETYP A,A + CAIE A,TCHAN + JRST BADCHN + MOVEM A,-1(TP) + MOVEM B,(TP) +READC1: PUSHJ P,@(P) + JRST .+2 + JRST FINIS + + PUSH TP,-1(TP) + PUSH TP,-1(TP) + MCALL 1,FCLOSE + MOVE A,EOFCND-1(B) + MOVE B,EOFCND(B) + CAML AB,[-3,,] + JRST .+3 + MOVE A,2(AB) + MOVE B,3(AB) + PUSH TP,A + PUSH TP,B + MCALL 1,EVAL + JRST FINIS + + +MFUNCTION PARSE,SUBR + + ENTRY + + PUSHJ P,GAPRS ;GET ARGS FOR PARSES + PUSHJ P,GPT ;GET THE PARSE TABLE + PUSHJ P,NXTCH ; GET A CHAR TO TEST FOR ! ALT + SKIPN 11.(TB) ; EOF HIT, COMPLAIN TO LOOSER + JRST NOPRS + MOVEI A,33 ; CHANGE IT TO AN ALT, SNEAKY HUH? + CAIN B,MANYT ; TYPE OF MULTIPLE CLOSE, I.E. ! ALT + MOVEM A,5(TB) + PUSHJ P,IREAD1 ;GO DO THE READING + JRST .+2 + JRST LPSRET ;PROPER EXIT +NOPRS: PUSH TP,$TATOM + PUSH TP,EQUOTE CAN'T-PARSE + JRST CALER1 + +MFUNCTION LPARSE,SUBR + + ENTRY + + PUSHJ P,GAPRS ;GET THE ARGS TO THE PARSE + JRST LPRS1 + +GAPRS: PUSH TP,$TTP + PUSH TP,[0] + PUSH TP,$TFIX + PUSH TP,[10.] + PUSH TP,$TFIX + PUSH TP,[0] ; LETTER SAVE + PUSH TP,[0] + PUSH TP,[0] ; PARSE TABLE MAYBE? + PUSH TP,$TSPLICE + PUSH TP,[0] ;SEGMENT FOR SPLICING MACROS + PUSH TP,[0] ;SLOT FOR LOCATIVE TO STRING + PUSH TP,[0] + JUMPGE AB,USPSTR + PUSH TP,[TATOM,,-1] + PUSH TP,IMQUOTE PARSE-STRING + PUSH TP,(AB) + PUSH TP,1(AB) ; BIND OLD PARSE-STRING + PUSH TP,[0] + PUSH TP,[0] + PUSHJ P,SPECBIND + ADD AB,[2,,2] + JUMPGE AB,USPSTR + GETYP 0,(AB) + CAIE 0,TFIX + JRST WTYP2 + MOVE 0,1(AB) + MOVEM 0,3(TB) + ADD AB,[2,,2] + JUMPGE AB,USPSTR + GETYP 0,(AB) + CAIE 0,TLIST + CAIN 0,TOBLS + SKIPA + JRST WTYP3 + PUSH TP,[TATOM,,-1] + PUSH TP,IMQUOTE OBLIST + PUSH TP,(AB) + PUSH TP,1(AB) ; HE WANTS HIS OWN OBLIST + PUSH TP,[0] + PUSH TP,[0] + PUSHJ P,SPECBIND + ADD AB,[2,,2] + JUMPGE AB,USPSTR + GETYP 0,(AB) + CAIE 0,TVEC + JRST WTYP + PUSH TP,[TATOM,,-1] + PUSH TP,IMQUOTE PARSE-TABLE + PUSH TP,(AB) + PUSH TP,1(AB) + PUSH TP,[0] + PUSH TP,[0] + PUSHJ P,SPECBIND + ADD AB,[2,,2] + JUMPGE AB,USPSTR + GETYP 0,(AB) + CAIE 0,TCHRS + JRST WTYP + MOVE 0,1(AB) + MOVEM 0,5(TB) ; STUFF IN A LOOK-AHEAD CHARACTER IF HE WANTS + ADD AB,[2,,2] + JUMPL AB,TMA +USPSTR: MOVE B,IMQUOTE PARSE-STRING + PUSHJ P,ILOC ; GET A LOCATIVE TO THE STRING, WHEREVER + GETYP 0,A + CAIN 0,TUNBOUND ; NONEXISTANT + JRST BDPSTR + GETYP 0,(B) ; IT IS POINTING TO A STRING + CAIE 0,TCHSTR + JRST BDPSTR + MOVEM A,10.(TB) + MOVEM B,11.(TB) + POPJ P, + +LPRS1: PUSHJ P,GPT ; GET THE VALUE OF PARSE-TABLE IN SLOT + PUSH TP,$TLIST + PUSH TP,[0] ; HERE WE ARE MAKE PLACE TO SAVE GOODIES + PUSH TP,$TLIST + PUSH TP,[0] +LPRS2: PUSHJ P,IREAD1 + JRST LPRSDN ; IF WE ARE DONE, WE ARE THROUGH + MOVE C,A + MOVE D,B + PUSHJ P,INCONS + SKIPN -2(TP) + MOVEM B,-2(TP) ; SAVE THE BEGINNING ON FIRST + SKIPE C,(TP) + HRRM B,(C) ; PUTREST INTO IT + MOVEM B,(TP) + JRST LPRS2 +LPRSDN: MOVSI A,TLIST + MOVE B,-2(TP) +LPSRET: SKIPLE C,5(TB) ; EXIT FOR PARSE AND LPARSE + CAIN C,400033 ; SEE IF NO PEEK AHEAD OR IF ! ALTMODE + JRST FINIS ; IF SO NO NEED TO BACK STRING ONE + SKIPN C,11.(TB) + JRST FINIS ; IF ATE WHOLE STRING, DONT GIVE BACK ANY +BUPRS: MOVEI D,1 + ADDM D,(C) ; AOS THE COUNT OF STRING LENGTH + SKIPG D,1(C) ; SEXIER THAN CLR'S CODE FOR DECREMENTING + SUB D,[430000,,1] ; A BYTE POINTER + ADD D,[70000,,0] + MOVEM D,1(C) + HRRZ E,2(TB) + JUMPE E,FINIS ; SEE IF WE NEED TO BACK UP TWO + HLLZS 2(TB) ; CLEAR OUT DOUBLE CHR LOOKY FLAG + JRST BUPRS ; AND BACK UP PARSE STRING A LITTLE MORE + + ; ARGUMENTS ARE BOUND, NOW GET THE VALUES OF THINGS + + +GRT: MOVE B,IMQUOTE READ-TABLE + SKIPA ; HERE TO GET TABLE FOR READ +GPT: MOVE B,IMQUOTE PARSE-TABLE + MOVSI A,TATOM ; TO FILL SLOT WITH PARSE TABLE + PUSHJ P,ILVAL + GETYP 0,A + CAIN 0,TUNBOUND + POPJ P, + CAIE 0,TVEC + JRST BADPTB + MOVEM A,6(TB) + MOVEM B,7(TB) + POPJ P, + +READ1: PUSHJ P,GRT + MOVE B,IMQUOTE INCHAN + MOVSI A,TATOM + PUSHJ P,IDVAL ;NOW GOBBLE THE REAL CHANNEL + TLZ A,TYPMSK#777777 + HLLZS A ; INCASE OF FUNNY BUG + CAME A,$TCHAN ;IS IT A CHANNEL + JRST BADCHN + MOVEM A,4(TB) ; STORE CHANNEL + MOVEM B,5(TB) + HRRZ A,-4(B) + TRC A,C.OPN+C.READ + TRNE A,C.OPN+C.READ + JRST WRONGD + HLLOS 4(TB) + TRNE A,C.BIN ; SKIP IF NOT BIN + JRST BREAD ; CHECK FOR BUFFER + HLLZS 4(TB) +GETIOA: MOVE B,5(TB) +GETIO: MOVE A,IOINS(B) ;GOBBLE THE I/O INSTRUCTION + JUMPE A,OPNFIL ;GO REALLY OPEN THE CROCK + MOVE A,RADX(B) ;GET RADIX + MOVEM A,3(TB) + MOVEM B,5(TB) ;SAVE CHANNEL +REREAD: MOVE D,LSTCH(B) ;ANY CHARS AROUND? + MOVEI 0,33 + CAIN D,400033 ;FLUSH THE TERMINATOR HACK + MOVEM 0,LSTCH(B) ; MAKE ! ALT INTO JUST ALT IF IT IS STILL AROUND + + PUSHJ P,@(P) ;CALL INTERNAL READER + JRST BADTRM ;LOST +RFINIS: SUB P,[1,,1] ;POP OFF LOSER + PUSH TP,A + PUSH TP,B + JUMPE C,FLSCOM ; FLUSH TOP LEVEL COMMENT + PUSH TP,C + PUSH TP,D + MOVE A,4(TB) + MOVE B,5(TB) ; GET CHANNEL + MOVSI C,TATOM + MOVE D,MQUOTE COMMENT + PUSHJ P,IPUT +RFINI1: POP TP,B + POP TP,A + JRST FINIS + +FLSCOM: MOVE A,4(TB) + MOVE B,5(TB) + MOVSI C,TATOM + MOVE D,MQUOTE COMMENT + PUSHJ P,IREMAS + JRST RFINI1 + +BADTRM: MOVE C,5(TB) ; GET CHANNEL + JUMPGE B,CHLSTC ;NO, MUST BE UNMATCHED PARENS + SETZM LSTCH(C) ; DONT REUSE EOF CHR + PUSH TP,4(TB) ;CLOSE THE CHANNEL + PUSH TP,5(TB) + MCALL 1,FCLOSE + PUSH TP,EOFCND-1(B) + PUSH TP,EOFCND(B) + MCALL 1,EVAL ;AND EVAL IT + SETZB C,D + GETYP 0,A ; CHECK FOR FUNNY ACT + CAIE 0,TREADA + JRST RFINIS ; AND RETURN + + PUSHJ P,CHUNW ; UNWIND TO POINT + MOVSI A,TREADA ; SEND MESSAGE BACK + JRST CONTIN + +;HERE TO ATTEMPT TO OPEN A CLOSED CHANNEL + +OPNFIL: PUSHJ P,OPNCHN ;GO DO THE OPEN + JUMPGE B,FNFFL ;LOSE IC B IS 0 + JRST GETIO + + +CHLSTC: MOVE B,5(TB) ;GET CHANNEL BACK + JRST REREAD + + +BREAD: MOVE B,5(TB) ; GET CHANNEL + SKIPE BUFSTR(B) + JRST GETIO + MOVEI A,BUFLNT ; GET A BUFFER + PUSHJ P,IBLOCK + MOVEI C,BUFLNT(B) ; POINT TO END + HRLI C,440700 + MOVE B,5(TB) ; CHANNEL BACK + MOVEI 0,C.BUF + IORM 0,-4(B) + MOVEM C,BUFSTR(B) + MOVSI C,TCHSTR+.VECT. + MOVEM C,BUFSTR-1(B) + JRST GETIO + ;MAIN ENTRY TO READER + +NIREAD: PUSHJ P,LSTCHR +NIREA1: PUSH P,[-1] ; DONT GOBBLE COMMENTS + JRST IREAD2 + +IREAD: + PUSHJ P,LSTCHR ;DON'T REREAD LAST CHARACTER +IREAD1: PUSH P,[0] ; FLAG SAYING SNARF COMMENTS +IREAD2: INTGO +BDLP: SKIPE C,9.(TB) ;HAVE WE GOT A SPLICING MACRO LEFT + JRST SPLMAC ;IF SO GIVE HIM SOME OF IT + PUSHJ P,NXTCH ;GOBBLE CHAR IN A AND TYPE IN D + MOVMS B ; FOR SPECIAL NEG HACK OF MACRO TABLES + CAIG B,ENTYPE + JUMPN B,@DTBL-1(B) ;ERROR ON ZERO TYPE OR FUNNY TYPE + JRST BADCHR + + +SPLMAC: HRRZ D,(C) ;GET THE REST OF THE SEGMENT + MOVEM D,9.(TB) ;AND PUT BACK IN PLACE + GETYP D,(C) ;SEE IF DEFERMENT NEEDED + CAIN D,TDEFER + MOVE C,1(C) ;IF SO, DO DEFEREMENT + MOVE A,(C) + MOVE B,1(C) ;GET THE GOODIE + AOS -1(P) ;ALWAYS A SKIP RETURN + POP P,(P) ;DONT WORRY ABOUT COMMENT SEARCHAGE + SETZB C,D ;MAKE SURE HE DOESNT THINK WE GOT COMMENT + POPJ P, ;GIVE HIM WHAT HE DESERVES + +DTBL: NUMLET ;HERE IF NUMBER OR LETTER + NUMLET ;NUMBER +NUMCOD==.-DTBL + NUMLET ;+- +PLUMIN==.-DTBL + NUMLET ;. +DOTTYP==.-DTBL + NUMLET ;E +NONSPC==.-DTBL ;NUMBER OF NON-SPECIAL CHARACTERS + SPACE ;SPACING CHAR CR,LF,SP,TAB ETC. +SPATYP==.-DTBL ;TYPE FOR SPACE CHARS + + +;THE FOLLOWING ENTRIES ARE VARIOUS PUNCTUATION CROCKS + + LPAREN ;( - BEGIN LIST + RPAREN ;) - END CURRENT LEVEL OF INPUT + LBRACK ;[ -BEGIN ARRAY +LBRTYP==.-DTBL + RBRACK ;] - END OF ARRAY + QUOTIT ;' - QUOTE THE FOLLOWING GOODIE +QUOTYP==.-DTBL + + MACCAL ;% - INVOKE A READ TIME MACRO +MACTYP==.-DTBL + CSTRING ;" - CHARACTER STRING +CSTYP==.-DTBL + NUMLET ;\ - ESCAPE,BEGIN ATOM + +ESCTYP==.-DTBL ;TYPE OF ESCAPE CHARACTER + + SPECTY ;# - SPECIAL TYPE TO BE READ +SPCTYP==.-DTBL + OPNANG ;< - BEGIN ELEMENT CALL + +SLMNT==.-DTBL ;TYPE OF START OF SEGMENT + + CLSANG ;> - END ELEMENT CALL + + + EOFCHR ;^C - END OF FILE + + COMNT ;; - BEGIN COMMENT +COMTYP==.-DTBL ;TYPE OF START OF COMMENT + + GLOVAL ;, - GET GLOBAL VALUE +GLMNT==.-DTBL + ILLSQG ;{ - START TEMPLATE STRUCTURE +TMPTYP==.-DTBL + CLSBRA ;} - END TEMPLATE STRUCTURE + +NTYPES==.-DTBL + + + +; EXTENDED TABLE FOR ! HACKS + + NUMLET ; !! FAKE OUT + SEGDOT ;!. - CALL TO LVAL (SEG) +DOTEXT==.-DTBL + UVECIN ;![ - INPUT UNIFORM VECTOR ] +LBREXT==.-DTBL + QUOSEG ;!' - SEG CALL TO QUOTE +QUOEXT==.-DTBL + SINCHR ;!" - INPUT ONE CHARACTER +CSEXT==.-DTBL + SEGIN ;!< - SEG CALL +SLMEXT==.-DTBL + GLOSEG ;!, - SEG CALL TO GVAL +GLMEXT==.-DTBL + LOSPATH ;!- - PATH NAME SEPARATOR +PATHTY==.-DTBL + TERM ;!$ - (EXCAL-ALT MODE) PUT ALL CLOSES +MANYT==.-DTBL + USRDS1 ; DISPATCH FOR USER TABLE (NO !) +USTYP1==.-DTBL + USRDS2 ; " " " " (WITH !) +USTYP2==.-DTBL +ENTYPE==.-DTBL + + + +SPACE: PUSHJ P,LSTCHR ;DONT REREAD SPACER + JRST BDLP + +USRDS1: SKIPA B,A ; GET CHAR IN B +USRDS2: MOVEI B,200(A) ; ! CHAR, DISP 200 FURTHER + ASH B,1 + ADD B,7(TB) ; POINT TO TABLE ENTRY + GETYP 0,(B) + CAIN 0,TLIST + MOVE B,1(B) ; IF LIST, USE FIRST ITEM-SPECIAL NO BREAK HACK + SKIPL C,5(TB) ; GET CHANNEL POINTER (IF ANY) + JRST USRDS3 + ADD C,[EOFCND-1,,EOFCND-1] + PUSH TP,$TBVL + HRRM SP,(TP) ; BUILD A TBVL + MOVE SP,TP + PUSH TP,C + PUSH TP,(C) + PUSH TP,1(C) + MOVEI D,PVLNT*2+1(PVP) + HRLI D,TREADA + MOVEM D,(C) + MOVEI D,(TB) + HLL D,OTBSAV(TB) + MOVEM D,1(C) +USRDS3: PUSH TP,(B) ; APPLIER + PUSH TP,1(B) + PUSH TP,$TCHRS ; APPLY TO CHARACTER + PUSH TP,A + PUSHJ P,LSTCHR ; FLUSH CHAR + MCALL 2,APPLY ; GO TO USER GOODIE + HRRZ SP,(SP) ; UNBIND MANUALLY + MOVEI D,(TP) + SUBI D,(SP) + MOVSI D,(D) + HLL SP,TP + SUB SP,D + SUB TP,[4,,4] ; FLUSH TP CRAP + GETYP 0,A ; CHECK FOR DISMISS? + CAIN 0,TSPLICE + JRST GOTSPL ; RETURN OF SEGMENT INDICATES SPLICAGE + CAIN 0,TREADA ; FUNNY? + JRST DOEOF + CAIE 0,TDISMI + JRST RET ; NO, RETURN FROM IREAD + JRST BDLP ; YES, IGNORE RETURN + +GOTSPL: MOVEM B,9.(TB) ; STICK IN THE SPLICAGE SLOT SO IREADS WILL GET HIM + JRST BDLP ; GO BACK AND READ FROM OUR SPLICE, OK? + + +;HERE ON NUMBER OR LETTER, START ATOM + +NUMLET: PUSHJ P,GOBBLE ;READ IN THE ATOM AND PUT PNTR ON ARG PDL + JRST RET ;NO SKIP RETURN I.E. NON NIL + +;HERE TO START BUILDING A CHARACTER STRING GOODIE + +CSTRING: PUSHJ P,GOBBL1 ;READ IN STRING + JRST RET + +;ARRIVE HERE TO INVOKE A READ TIME MACRO FUNCTION + +MACCAL: PUSHJ P,NXTCH1 ;READ ONE MORE CHARACTER + CAIE B,MACTYP ;IS IT ANOTHER MACRO CHAR + + JRST MACAL2 ;NO, CALL MACRO AND USE VALUE + PUSHJ P,LSTCHR ;DONT REREAD % + PUSHJ P,MACAL1 ;OTHERWISE, USE SIDE EFFECCT, BUT NOT VALUE + JRST IREAD2 + +MACAL2: PUSH P,CRET +MACAL1: PUSHJ P,IREAD1 ;READ FUNCTION NAME + JRST RETERR + PUSH TP,C + PUSH TP,D ; SAVE COMMENT IF ANY + PUSH TP,A ;SAVE THE RESULT + PUSH TP,B ;AND USE IT AS AN ARGUMENT + MCALL 1,EVAL + POP TP,D + POP TP,C ; RESTORE COMMENT IF ANY... +CRET: POPJ P,RET12 + +;CALL GOBBLE TO FIND THE TYPE AND THEN IREAD TO READ IT + +SPECTY: PUSHJ P,NIREAD ; READ THE TYPES NAME (SHOULD BE AN ATOM) + JRST RETERR + PUSH TP,A + PUSH TP,B + PUSHJ P,NXTCH ; GET NEXT CHAR + CAIN B,TMPTYP ; SKIP IF NOT TEMPLATE START + JRST RDTMPL + SETZB A,B + EXCH A,-1(TP) + EXCH B,(TP) + PUSH TP,A ;BEGIN SETTING UP CHTYPE CALL + PUSH TP,B + PUSHJ P,IREAD1 ;NOW READ STRUCTURE + JRST RETER1 + MOVEM C,-3(TP) ; SAVE COMMENT + MOVEM D,-2(TP) + EXCH A,-1(TP) ;USE AS FIRST ARG + EXCH B,(TP) + PUSH TP,A ;USE OTHER AS 2D ARG + PUSH TP,B + MCALL 2,CHTYPE ;ATTEMPT TO MUNG +RET13: POP TP,D + POP TP,C ; RESTORE COMMENT +RET12: SETOM (P) ; DONT LOOOK FOR MORE! + JRST RET + +RDTMPL: PUSH P,["}] ; SET UP TERMINATE TEST + MOVE B,(TP) + PUSHJ P,IGVAL + MOVEM A,-1(TP) + MOVEM B,(TP) + PUSH P,[BLDTMP] ; FLAG FOR VECTOR READING CODE + JRST LBRAK2 + +BLDTMP: ADDI A,1 ; 1 MORE ARGUMENT + ACALL A,APPLY ; DO IT TO IT + POPJ P, + +RETER1: SUB TP,[2,,2] +RETERR: SKIPL A,5(TB) + MOVEI A,5(TB)-LSTCH ;NO CHANNEL, USE SLOT + MOVEM B,LSTCH(A) ; RESTORE LAST CHAR + PUSHJ P,ERRPAR + JRST RET1 + +;THIS CODE CALLS IREAD RECURSIVELY TO READ THAT WHICH IS +;BETWEEN (), ARRIVED AT WHEN ( IS READ + +SEGIN: PUSH TP,$TSEG + JRST OPNAN1 + +OPNANG: PUSH TP,$TFORM ;SAVE TYPE +OPNAN1: PUSH P,[">] + JRST LPARN1 + +LPAREN: PUSH P,[")] + PUSH TP,$TLIST ;START BY ASSUMING NIL +LPARN1: PUSH TP,[0] + PUSHJ P,LSTCHR ;DON'T REREAD PARENS +LLPLOP: PUSHJ P,IREAD1 ;READ IT + JRST LDONE ;HIT TERMINATOR + +;HERE WHEN MUST ADD CAR TO CURRENT WINNER + +GENCAR: PUSH TP,C ; SAVE COMMENT + PUSH TP,D + MOVE C,A ; SET UP CALL + MOVE D,B + PUSHJ P,INCONS ; CONS ON TO NIL + POP TP,D + POP TP,C + POP TP,E ;GET CDR + JUMPN E,CDRIN ;IF STACKED GOODIE NOT NIL SKIP + PUSH TP,B ;AND USE AS TOTAL VALUE + PUSH TP,$TLIST ;SAVE THIS AS FIRSST THING ON LIST + MOVE A,-2(TP) ; GET REAL TYPE + JRST .+2 ;SKIP CDR SETTING +CDRIN: HRRM B,(E) + PUSH TP,B ;CLOBBER IN NEW PARTIAL GOODIE + JUMPE C,LLPLOP ; JUMP IF NO COMMENT + PUSH TP,C + PUSH TP,D + MOVSI C,TATOM + MOVE D,MQUOTE COMMENT + PUSHJ P,IPUT + JRST LLPLOP ;AND CONTINUE + +; HERE TO RAP UP LIST + +LDONE: CAME B,(P) ;CHECK VALIDITY OF CHARACTER + PUSHJ P,MISMAT ;REPORT MISMATCH + SUB P, [1,,1] + POP TP,B ;GET VALUE OF PARTIAL RESULT + POP TP,A ;AND TYPE OF SAME + JUMPE B,RET ;VALUE IS NIL, DON'T POP AGAIN + POP TP,B ;POP FIRST LIST ELEMENT + POP TP,A ;AND TYPE + JRST RET + +;THIS CODE IS SIMILAR TO LIST GENERATING CODE BUT IS FOR VECTORS +OPNBRA: PUSH P,["}] ; SAVE TERMINATOR +UVECIN: PUSH P,[135] ; CLOSE SQUARE BRACKET + PUSH P,[IEUVECTOR] ;PUSH NAME OF U VECT HACKER + JRST LBRAK2 ;AND GO + +LBRACK: PUSH P,[135] ; SAVE TERMINATE + PUSH P,[IEVECTOR] ;PUSH GEN VECTOR HACKER +LBRAK2: PUSHJ P,LSTCHR ;FORCE READING NEW CHAR + PUSH P,[0] ; COUNT ELEMENTS + PUSH TP,$TLIST ; AND SLOT FOR GOODIES + PUSH TP,[0] + +LBRAK1: PUSHJ P,IREAD1 ;RECURSIVELY READ ELEMENTS OF ARRAY + JRST LBDONE ;RAP UP ON TERMINATOR + +STAKIT: EXCH A,-1(TP) ; STORE RESULT AND GET CURRENT LIST + EXCH B,(TP) + AOS (P) ; COUNT ELEMENTS + JUMPE C,LBRAK3 ; IF NO COMMENT, GO ON + MOVEI E,(B) ; GET CDR + PUSHJ P,ICONS ; CONS IT ON + MOVEI E,(B) ; SAVE RS + MOVSI C,TFIX ; AND GET FIXED NUM + MOVE D,(P) + PUSHJ P,ICONS +LBRAK3: PUSH TP,A ; SAVE CURRENT COMMENT LIST + PUSH TP,B + JRST LBRAK1 + +; HERE TO RAP UP VECTOR + +LBDONE: CAME B,-2(P) ; FINISHED RETURN (WAS THE RIGHT STOP USED?) + PUSHJ P,MISMAB ; WARN USER + POP TP,1(TB) ; REMOVE COMMENT LIST + POP TP,(TB) + MOVE A,(P) ; COUNT TO A + PUSHJ P,-1@(P) ; MAKE THE VECTOR + SUB P,[3,,3] + +; PUT COMMENTS ON VECTOR (OR UVECTOR) + + MOVNI C,1 ; INDICATE TEMPLATE HACK + CAMN A,$TVEC + MOVEI C,1 + CAMN A,$TUVEC ; SKIP IF UVECTOR + MOVEI C,0 + PUSH P,C ; SAVE + PUSH TP,A ; SAVE VECTOR/UVECTOR + PUSH TP,B + +VECCOM: SKIPN C,1(TB) ; ANY LEFT? + JRST RETVEC ; NO, LEAVE + MOVE A,1(C) ; ASSUME WINNING TYPES + SUBI A,1 + HRRZ C,(C) ; CDR THE LIST + HRRZ E,(C) ; AGAIN + MOVEM E,1(TB) ; SAVE CDR + GETYP E,(C) ; CHECK DEFFERED + MOVSI D,(E) + CAIN E,TDEFER ; SKIP IF NOT DEFERRED + MOVE C,1(C) + CAIN E,TDEFER + GETYPF D,(C) ; GET REAL TYPE + MOVE B,(TP) ; GET VECTOR POINTER + SKIPGE (P) ; SKIP IF NOT TEMPLATE + JRST TMPCOM + HRLI A,(A) ; COUNTER + LSH A,@(P) ; MAYBE SHIFT IT + ADD B,A + MOVE A,-1(TP) ; TYPE +TMPCO1: PUSH TP,D + PUSH TP,1(C) ; PUSH THE COMMENT + MOVSI C,TATOM + MOVE D,MQUOTE COMMENT + PUSHJ P,IPUT + JRST VECCOM + +TMPCOM: MOVSI A,(A) + ADD B,A + MOVSI A,TTMPLT + JRST TMPCO1 + +RETVEC: SUB P,[1,,1] + POP TP,B + POP TP,A + JRST RET + +; BUILD A SINGLE CHARACTER ITEM + +SINCHR: PUSHJ P,NXTC1 ;FORCE READ NEXT + CAIN B,ESCTYP ;ESCAPE? + PUSHJ P,NXTC1 ;RETRY + MOVEI B,(A) + MOVSI A,TCHRS + JRST RETCL + + +; HERE ON RIGHT PAREN, BRACKET, ANGLE BRACKET OR CTL C + +CLSBRA: +CLSANG: ;CLOSE ANGLE BRACKETS +RBRACK: ;COMMON RETURN FOR END OF ARRAY ALSO +RPAREN: PUSHJ P,LSTCHR ;DON'T REREAD +EOFCH1: MOVE B,A ;GETCHAR IN B + MOVSI A,TCHRS ;AND TYPE IN A +RET1: SUB P,[1,,1] + POPJ P, + +EOFCHR: SETZB C,D + JUMPL A,EOFCH1 ; JUMP ON REAL EOF + JRST RRSUBR ; MAYBE A BINARY RSUBR + +DOEOF: MOVE A,[-1,,3] + SETZB C,D + JRST EOFCH1 + + +; NORMAL RETURN FROM IREAD/IREAD1 + +RETCL: PUSHJ P,LSTCHR ;DONT REREAD +RET: AOS -1(P) ;SKIP + POP P,E ; POP FLAG +RETC: JUMPL E,RET2 ; DONT LOOK FOR COMMENTS + PUSH TP,A ; SAVE ITEM + PUSH TP,B +CHCOMN: PUSHJ P,NXTCH ; READ A CHARACTER + CAIE B,COMTYP ; SKIP IF COMMENT + JRST CHSPA + PUSHJ P,IREAD ; READ THE COMMENT + JRST POPAJ + MOVE C,A + MOVE D,B + JRST .+2 +POPAJ: SETZB C,D + POP TP,B + POP TP,A +RET2: POPJ P, + +CHSPA: CAIN B,SPATYP + PUSHJ P,SPACEQ ; IS IT A REAL SPACE + JRST POPAJ + PUSHJ P,LSTCHR ; FLUSH THE SPACE + JRST CHCOMN + +;RANDOM MINI-SUBROUTINES USED BY THE READER + +;READ A CHAR INTO A AND TYPE CODE INTO D + +NXTC1: SKIPL B,5(TB) ;GET CHANNEL + JRST NXTPR1 ;NO CHANNEL, GO READ STRING + SKIPE LSTCH(B) + PUSHJ P,CNTACC ; COUNT ON ACCESS POINTER + JRST NXTC2 +NXTC: SKIPL B,5(TB) ;GET CHANNEL + JRST NXTPRS ;NO CHANNEL, GO READ STRING + SKIPE A,LSTCH(B) ;CHAR IN A IF REUSE + JRST PRSRET +NXTC2: PUSHJ P,RXCT ;GET CHAR FROM INPUT + HLLZS 2(TB) ;FLAG INDICATING ONE CHAR LOOK AHEAD + MOVEM A,LSTCH(B) ;SAVE THE CHARACTER +PRSRET: TRZE A,400000 ;DONT SKIP IF SPECIAL + JRST RETYPE ;GO HACK SPECIALLY +GETCTP: CAILE A,177 ; CHECK RANGE + JRST BADCHR + PUSH P,A ;AND SAVE FROM DIVISION + ANDI A,177 + IDIVI A,CHRWD ;YIELDS WORD AND CHAR NUMBER + LDB B,BYTPNT(B) ;GOBBLE TYPE CODE + POP P,A + POPJ P, + +NXTPRS: SKIPE A,5(TB) ;GET OLD CHARACTER IF ONE EXISTS + JRST PRSRET +NXTPR1: MOVEI A,400033 + PUSH P,C + MOVE C,11.(TB) + HRRZ B,(C) ;GET THE STRING + SOJL B,NXTPR3 + HRRM B,(C) + ILDB A,1(C) ;GET THE CHARACTER FROM THE STRING +NXTPR2: MOVEM A,5(TB) ;SAVE IT + POP P,C + JRST PRSRET ;CONTINUE +NXTPR3: SETZM 8.(TB) + SETZM 9.(TB) ;CLEAR OUT LOCATIVE, AT END OF STRING + JRST NXTPR2 + +; NXTCH AND NXTCH1 ARE SAME AS NXTC AND NXTC1 EXCEPT THEY CHECK ! +; HACKS + +NXTCH1: PUSHJ P,NXTC1 ;READ CHAR + JRST .+2 +NXTCH: PUSHJ P,NXTC ;READ CHAR + CAIGE B,NTYPES+1 ;IF 1 > THAN MAX, MUST BE SPECIAL + JRST CHKUS1 ; CHECK FOR USER DISPATCH + + CAIN B,NTYPES+1 ;FOR OBSCURE BUG FOUND BY MSG + PUSHJ P,NXTC1 ;READ NEXT ONE + HLLOS 2(TB) ;FLAG FOR TWO CHAR LOOK AHEAD + +RETYP1: CAIN A,". ;!. + MOVEI B,DOTEXT ;YES, GET EXTENDED TYPE + CAIN A,"[ + MOVEI B,LBREXT + CAIN A,"' + MOVEI B,QUOEXT + CAIN A,"" + MOVEI B,CSEXT + CAIN A,"- + MOVEI B,PATHTY + CAIN A,"< + MOVEI B,SLMEXT + CAIN A,", + MOVEI B,GLMEXT + CAIN A,33 + MOVEI B,MANYT ;! ALTMODE + +CRMLST: ADDI A,400000 ;CLOBBER LASTCHR + PUSH P,B + SKIPL B,5(TB) ;POINT TO CHANNEL + MOVEI B,5(TB)-LSTCH ;NO CHANNEL, POINT AT SLOT + MOVEM A,LSTCH(B) + SUBI A,400000 ;DECREASE CHAR + POP P,B + +CHKUS2: SKIPN 7(TB) ; SKIP IF USER TABLE + JRST UPLO + PUSH P,A + ADDI A,200 + ASH A,1 ; POINT TO SLOT + HRLS A + ADD A,7(TB) + SKIPL A ;IS THERE VECTOR ENOUGH? + JRST CHKUS4 + SKIPN 1(A) ; NON-ZERO==>USER FCN EXISTS + JRST CHKUS4 ; HOPE HE APPRECIATES THIS + MOVEI B,USTYP2 +CHKRDO: PUSH P,0 ; CHECK FOR REDOING IF CHAR IN TABLE + GETYP 0,(A) + CAIE 0,TCHRS + JRST CHKUS5 + POP P,0 ;WE ARE TRANSMOGRIFYING + POP P,(P) ;FLUSH OLD CHAR + MOVE A,1(A) ;GET NEW CHARACTER + PUSH P,7(TB) + PUSH P,2(TB) ; FLAGS FOR NUM OF CHRS IN LOOK AHEAD + PUSH P,5(TB) ; TO AVOID SMASHING LSTCHR + SETZM 5(TB) ; CLEAR OUT CHANNEL + SETZM 7(TB) ;CLEAR OUT TABLE + TRZE A,200 ; ! HACK + TRO A,400000 ; TURN ON PROPER BIT + PUSHJ P,PRSRET + POP P,5(TB) ; GET BACK CHANNEL + POP P,2(TB) + POP P,7(TB) ;GET BACK OLD PARSE TABLE + POPJ P, + +CHKUS5: CAIE 0,TLIST + JRST .+4 ; SPECIAL NON-BREAK TYPE HACK + MOVNS -1(P) ; INDICATE BY NEGATIVE + MOVE A,1(A) ; GET <1 LIST> + GETYP 0,(A) ; AND GET THE TYPE OF THAT + CAIE 0,TFIX ; SEE IF HE WANTS SAME CHAR WITH DIFF TYPE + JRST CHKUS6 ; JUST A VANILLA HACK + MOVE A,1(A) ; PRETEND IT IS SAME TYPE AS NEW CHAR + PUSH P,7(TB) ; CLEAR OUT TRANSLATE TABLE + PUSH P,2(TB) ; FLAGS FOR # OF CHRS IN LOOK AHEAD + SETZM 7(TB) + TRZE A,200 + TRO A,400000 ; TURN ON PROPER BIT IF ! HACK + PUSHJ P,PRSRET ; REGET TYPE + POP P,2(TB) + POP P,7(TB) ; PUT TRANSLATE TABLE BACK +CHKUS6: SKIPGE -1(P) ; SEE IF A SPECIAL NON-BREAK + MOVNS B ; SEXY, HUH? + POP P,0 + POP P,A + MOVMS A ; FIX UP A POSITIVE CHARACTER + POPJ P, + +CHKUS4: POP P,A + JRST UPLO + +CHKUS1: SKIPN 7(TB) ; USER CHECK FOR NOT ! CASE + POPJ P, + PUSH P,A + ASH A,1 + HRLS A + ADD A,7(TB) + SKIPL A + JRST CHKUS3 + SKIPN 1(A) + JRST CHKUS3 + MOVEI B,USTYP1 + JRST CHKRDO ; TRANSMOGRIFY CHARACTER? + +CHKUS3: POP P,A + POPJ P, + +UPLO: POPJ P, ; LETS NOT AND SAY WE USED TO + ; AVOID STRANGE ! BLECHAGE + +RETYPE: PUSHJ P,GETCTP ;GET TYPE OF CHAR + JRST RETYP1 + +NXTCS: PUSHJ P,NXTC + PUSH P,A ; HACK TO NOT TRANSLATE CHAR + PUSHJ P,CHKUS1 ; BUT DO TRANSLATION OF TYPE IF HE WANTS + POP P,A ; USED TO BUILD UP STRINGS + POPJ P, + +CHKALT: CAIN A,33 ;ALT? + MOVEI B,MANYT + JRST CRMLST + + +TERM: MOVEI B,0 ;RETURN A 0 + JRST RET1 + ;AND RETURN + +CHKMIN: CAIN A,"- ; IF CHAR IS -, WINNER + MOVEI B,PATHTY + JRST CRMLST + +LOSPAT: PUSHJ P,LSTCHR ; FIX RECURSIVE LOSAGE + PUSH TP,$TATOM + PUSH TP,EQUOTE UNATTACHED-PATH-NAME-SEPARATOR + JRST CALER1 + + +; HERE TO SEE IF READING RSUBR + +RRSUBR: PUSHJ P,LSTCHR ; FLUSH JUST READ CHAR + SKIPL B,5(TB) ; SKIP IF A CHANNEL EXISTS + JRST SPACE ; ELSE LIKE A SPACE + MOVE C,@BUFSTR(B) ; SEE IF FLAG SAYS START OF RSUBR + TRNN C,1 ; SKIP IF REAL RSUBR + JRST SPACE ; NO, IGNORE FOR NOW + +; REALLY ARE READING AN RSUBR + + HRRZ 0,4(TB) ; GET READ/READB INDICATOR + MOVE C,ACCESS(B) ; GET CURRENT ACCESS + JUMPN 0,.+3 ; ALREADY WORDS, NO NEED TO DIVIDE + ADDI C,4 ; ROUND UP + IDIVI C,5 + PUSH P,C ; SAVE WORD ACCESS + MOVEI A,(C) ; COPY IT FOR CALL + JUMPN 0,.+3 + IMULI C,5 + MOVEM C,ACCESS(B) ; FIXUP ACCESS + HLLZS ACCESS-1(B) ; FOR READB LOSER + PUSHJ P,DOACCS ; AND GO THERE + PUSH P,[0] ; FOR READ IN + HRROI A,(P) ; PREPARE TO READ LENGTH + PUSHJ P,DOIOTI ; READ IT + POP P,C ; GET READ GOODIE + MOVEI A,(C) ; COPY FOR GETTING BLOCK + ADDI C,1 ; COUNT COUNT WORD + ADDM C,(P) + PUSH TP,$TUVEC ; WILL HOLD UVECTOR OF FIXUPS IF THEY STAY + PUSH TP,[0] + PUSHJ P,IBLOCK ; GET A BLOCK + PUSH TP,$TUVEC + PUSH TP,B ; AND SAVE + MOVE A,B ; READY TO IOT IT IN + MOVE B,5(TB) ; GET CHANNEL BACK + MOVSI 0,TUVEC ; SETUP A'S TYPE + MOVEM 0,ASTO(PVP) + PUSHJ P,DOIOTI ; IN COMES THE WHOLE BLOCK + SETZM ASTO(PVP) ; A NO LONGER SPECIAL + MOVEI C,BUFSTR-1(B) ; NO RESET BUFFER + PUSHJ P,BYTDOP ; A POINTS TO DOPW WORD + SUBI A,2 + HRLI A,010700 ; SETUP BYTE POINTER TO END + HLLZS BUFSTR-1(B) ; ZERO CHAR COUNNT + MOVEM A,BUFSTR(B) + HRRZ A,4(TB) ; READ/READB FLG + MOVE C,(P) ; ACCESS IN WORDS + SKIPN A ; SKIP FOR ASCII + IMULI C,5 ; BUMP + MOVEM C,ACCESS(B) ; UPDATE ACCESS + PUSHJ P,NIREAD ; READ RSUBR VECTOR + JRST BRSUBR ; LOSER + GETYP A,A ; VERIFY A LITTLE + CAIE A,TVEC ; DONT SKIP IF BAD + JRST BRSUBR ; NOT A GOOD FILE + PUSHJ P,LSTCHR ; FLUSH REREAD CHAR + MOVE C,(TP) ; CODE VECTOR BACK + MOVSI A,TCODE + HLR A,B ; FUNNY COUNT + MOVEM A,(B) ; CLOBBER + MOVEM C,1(B) + PUSH TP,$TRSUBR ; MAKE RSUBR + PUSH TP,B + +; NOW LOOK OVER FIXUPS + + MOVE B,5(TB) ; GET CHANNEL + MOVE C,ACCESS(B) + HLLZS ACCESS-1(B) ; FOR READB LOSER + HRRZ 0,4(TB) ; READ/READB FLG + JUMPN 0,RSUB1 + ADDI C,4 ; ROUND UP + IDIVI C,5 ; TO WORDS + MOVEI D,(C) ; FIXUP ACCESS + IMULI D,5 + MOVEM D,ACCESS(B) ; AND STORE +RSUB1: ADDI C,1 ; ACCOUNT FOR EXTRA COUNTERS + MOVEM C,(P) ; SAVE FOR LATER + MOVEI A,-1(C) ; FOR DOACS + MOVEI C,2 ; UPDATE REAL ACCESS + SKIPN 0 ; SKIP FOR READB CASE + MOVEI C,10. + ADDM C,ACCESS(B) + PUSHJ P,DOACCS ; DO THE ACCESS + PUSH TP,$TUVEC ; SLOT FOR FIXUP BUFFER + PUSH TP,[0] + +; FOUND OUT IF FIXUPS STAY + + MOVE B,MQUOTE KEEP-FIXUPS + PUSHJ P,ILVAL ; GET VALUE + GETYP 0,A + MOVE B,5(TB) ; CHANNEL BACK TO B + CAIE 0,TUNBOU + CAIN 0,TFALSE + JRST RSUB4 ; NO, NOT KEEPING FIXUPS + PUSH P,[0] ; SLOT TO READ INTO + HRROI A,(P) ; GET LENGTH OF SAME + PUSHJ P,DOIOTI + POP P,C + MOVEI A,(C) ; GET UVECTOR FOR KEEPING + ADDM C,(P) ; ACCESS TO END + PUSH P,C ; SAVE LENGTH OF FIXUPS + PUSHJ P,IBLOCK + MOVEM B,-6(TP) ; AND SAVE + MOVE A,B ; FOR IOTING THEM IN + ADD B,[1,,1] ; POINT PAST VERS # + MOVEM B,(TP) + MOVSI C,TUVEC + MOVEM C,ASTO(PVP) + MOVE B,5(TB) ; AND CHANNEL + PUSHJ P,DOIOTI ; GET THEM + SETZM ASTO(PVP) + MOVE A,(TP) ; GET VERS + PUSH P,-1(A) ; AND PUSH IT + JRST RSUB5 + +RSUB4: PUSH P,[0] + PUSH P,[0] ; 2 SLOTS FOR READING + MOVEI A,-1(P) + HRLI A,-2 + PUSHJ P,DOIOTI + MOVE C,-1(P) + MOVE D,(P) + ADDM C,-2(P) ; NOW -2(P) IS ACCESS TO END OF FIXUPS +RSUB5: MOVEI C,BUFSTR-1(B) ; FIXUP BUFFER + PUSHJ P,BYTDOP + SUBI A,2 ; POINT BEFORE D.W. + HRLI A,10700 + MOVEM A,BUFSTR(B) + HLLZS BUFSTR-1(B) + SKIPE -6(TP) + JRST RSUB2A + SUBI A,BUFLNT-1 ; ALSO MAKE AN IOT FLAVOR BUFFER + HRLI A,-BUFLNT + MOVEM A,(TP) + MOVSI C,TUVEC + MOVEM C,ASTO(PVP) + PUSHJ P,DOIOTI + SETZM ASTO(PVP) +RSUB2A: PUSH P,-1(P) ; ANOTHER COPY OF LENGTH OF FIXUPS + +; LOOP FIXING UP NEW TYPES + +RSUB2: PUSHJ P,WRDIN ; SEE WHAT NEXT THING IS + JRST RSUB3 ; NO MORE, DONE + JUMPL E,STSQ ; MUST BE FIRST SQUOZE + MOVNI 0,(E) ; TO UPDATE AMNT OF FIXUPS + ADDB 0,(P) + HRLI E,(E) ; IS LENGTH OF STRING IN WORDS + ADD E,(TP) ; FIXUP BUFFER POINTER + JUMPL E,.+3 + SUB E,[BUFLNT,,BUFLNT] + JUMPGE E,.-1 ; STILL NOT RIGHT + EXCH E,(TP) ; FIX UP SLOT + HLRE C,E ; FIX BYTE POINTER ALSO + IMUL C,[-5] ; + CHARS LEFT + MOVE B,5(TB) ; CHANNEL + PUSH TP,BUFSTR-1(B) + PUSH TP,BUFSTR(B) + HRRM C,BUFSTR-1(B) + HRLI E,440700 ; AND BYTE POINTER + MOVEM E,BUFSTR(B) + PUSHJ P,NIREAD ; READ ATOM NAME OF TYPE + TDZA 0,0 ; FLAG LOSSAGE + MOVEI 0,1 ; WINNAGE + MOVE C,5(TB) ; RESET BUFFER + POP TP,BUFSTR(C) + POP TP,BUFSTR-1(C) + JUMPE 0,BRSUBR ; BAD READ OF RSUBR + GETYP A,A ; A LITTLE CHECKING + CAIE A,TATOM + JRST BRSUBR + PUSHJ P,LSTCHR ; FLUSH REREAD CHAR + HRRZ 0,4(TB) ; FIXUP ACCESS PNTR + MOVE C,5(TB) + MOVE D,ACCESS(C) + HLLZS ACCESS-1(C) ; FOR READB HACKER + ADDI D,4 + IDIVI D,5 + IMULI D,5 + SKIPN 0 + MOVEM D,ACCESS(C) ; RESET +TYFIXE: PUSHJ P,TYPFND ; SEE IF A LEGAL TYPE NAME + JRST TYPFIX ; GO SEE USER ABOUT THIS + PUSHJ P,FIXCOD ; GO FIX UP THE CODE + JRST RSUB2 + +; NOW FIX UP SUBRS ETC. IF NECESSARY + +STSQ: MOVE B,MQUOTE MUDDLE + PUSHJ P,IGVAL ; GET CURRENT VERS + CAME B,-1(P) ; SKIP IF NO FIXUPS NEEDED + JRST DOFIX0 ; MUST DO THEM + +; ALL DONE, ACCESS PAST FIXUPS AND RETURN + +RSUB3: MOVE A,-3(P) + MOVE B,5(TB) + MOVEI C,(A) ; UPDATE CHANNEL ACCESS IN CASE SKIPPING + HRRZ 0,4(TB) ; READ/READB FLAG + SKIPN 0 + IMULI C,5 + MOVEM C,ACCESS(B) ; INTO ACCESS SLOT + HLLZS ACCESS-1(B) + PUSHJ P,DOACCS ; ACCESSED + MOVEI C,BUFSTR-1(B) ; FIX UP BUFFER + PUSHJ P,BYTDOP + SUBI A,2 + HRLI A,10700 + MOVEM A,BUFSTR(B) + HLLZS BUFSTR-1(B) + SKIPN A,-6(TP) ; SKIP IF KEEPING FIXUPS + JRST RSUB6 + PUSH TP,$TUVEC + PUSH TP,A + MOVSI A,TRSUBR + MOVE B,-4(TP) + MOVSI C,TATOM + MOVE D,MQUOTE RSUBR + PUSHJ P,IPUT ; DO THE ASSOCIATION + +RSUB6: MOVE B,-2(TP) ; GET RSUBR + MOVSI A,TRSUBR + SUB P,[4,,4] ; FLUSH P CRUFT + SUB TP,[10,,10] + JRST RET + +; FIXUP SUBRS ETC. + +DOFIX0: SKIPN C,-6(TP) ; GET BUFFER IF KEEPING + JRST DOFIXE + MOVEM B,(C) ; CLOBBER + JRST DOFIXE + +FIXUPL: PUSHJ P,WRDIN + JRST RSUB3 +DOFIXE: JUMPGE E,BRSUBR + TLZ E,740000 ; KILL BITS + PUSHJ P,SQUTOA ; LOOK IT UP + JRST BRSUBR + MOVEI D,(E) ; FOR FIXCOD + PUSHJ P,FIXCOD ; FIX 'EM UP + JRST FIXUPL + +; ROUTINE TO FIXUP ACTUAL CODE + +FIXCOD: MOVEI E,0 ; FOR HWRDIN + PUSH P,D ; NEW VALUE + PUSHJ P,HWRDIN ; GET HW NEEDED + MOVE D,(P) ; GET NEW VAL + MOVE A,(TP) ; AND BUFFER POINTER + SKIPE -6(TP) ; SAVING? + HRLM D,-1(A) ; YES, CLOBBER + SUB C,(P) ; DIFFERENCE + MOVN D,C + +FIXLP: PUSHJ P,HWRDIN ; GET AN OFFSET + JUMPE C,FIXED + HRRES C ; MAKE NEG IF NEC + JUMPL C,LHFXUP + ADD C,-4(TP) ; POINT INTO CODE + ADDM D,-1(C) + JRST FIXLP + +LHFXUP: MOVMS C + ADD C,-4(TP) + MOVSI 0,(D) + ADDM 0,-1(C) + JRST FIXLP + +FIXED: SUB P,[1,,1] + POPJ P, + +; ROUTINE TO READ A WORD FROM BUFFER + +WRDIN: PUSH P,A + PUSH P,B + SOSG -3(P) ; COUNT IT DOWN + JRST WRDIN1 + AOS -2(P) ; SKIP RETURN + MOVE B,5(TB) ; CHANNEL + HRRZ A,4(TB) ; READ/READB SW + MOVEI E,5 + SKIPE A + MOVEI E,1 + ADDM E,ACCESS(B) + MOVE A,(TP) ; BUFFER + MOVE E,(A) + AOBJP A,WRDIN2 ; NEED NEW BUFFER + MOVEM A,(TP) +WRDIN1: POP P,B + POP P,A + POPJ P, + +WRDIN2: MOVE B,-3(P) ; IS THIS LAST WORD? + SOJLE B,WRDIN1 ; YES, DONT RE-IOT + SUB A,[BUFLNT,,BUFLNT] + MOVEM A,(TP) + MOVSI B,TUVEC + MOVEM B,ASTO(PVP) + MOVE B,5(TB) + PUSHJ P,DOIOTI + SETZM ASTO(PVP) + JRST WRDIN1 + +; READ IN NEXT HALF WORD + +HWRDIN: JUMPN E,NOIOT ; USE EXISTING WORD + PUSH P,-3(P) ; FAKE OUT WRDIN IF NEC. + PUSHJ P,WRDIN + JRST BRSUBR + POP P,-4(P) ; RESET COUNTER + HLRZ C,E ; RET LH + POPJ P, + +NOIOT: HRRZ C,E + MOVEI E,0 + POPJ P, + +TYPFIX: PUSH TP,$TATOM + PUSH TP,EQUOTE BAD-TYPE-NAME + PUSH TP,$TATOM + PUSH TP,B + PUSH TP,$TATOM + PUSH TP,EQUOTE ERRET-TYPE-NAME-DESIRED + MCALL 3,ERROR + JRST TYFIXE + +BRSUBR: PUSH TP,$TATOM + PUSH TP,EQUOTE RSUBR-IN-BAD-FORMAT + JRST CALER1 + + + +;TABLE OF BYTE POINTERS FOR GETTING CHARS + +BYTPNT": 350700,,CHTBL(A) + 260700,,CHTBL(A) + 170700,,CHTBL(A) + 100700,,CHTBL(A) + 010700,,CHTBL(A) + +;HERE ARE THE TABLES OF CHXRACTERS (NOTE EVERYTHING NOT SPECIFIED IS +;IN THE NUMBER LETTER CATAGORY) + +SETCHR 2,[0123456789] + +SETCHR 3,[+-] + +SETCHR 4,[.] + +SETCHR 5,[Ee] + +SETCOD 6,[15,12,11,14,40,33] ;ALL ARE TYPE 2 (SPACING - FF,TAB,SPACE,ALT-MODE) + +INCRCH 7,[()[]'%"\#<>] ;GIVE THESE INCREASRNG CODES FROM 3 + +SETCOD 22,[3] ;^C - EOF CHARACTER + +INCRCH 23,[;,{}!] ;COMMENT AND GLOBAL VALUE AND SPECIAL + +CHTBL: + OUTTBL ;OUTPUT THE TABLE RIGHT HERE + + + ; THIS CODE FLUSHES WANDERING COMMENTS + +COMNT: PUSHJ P,IREAD + JRST COMNT2 + JRST BDLP + +COMNT2: SKIPL A,5(TB) ; RESTORE CHANNEL + MOVEI A,5(TB)-LSTCH ;NO CHANNEL, POINT AT SLOT + MOVEM B,LSTCH(A) ; CLOBBER IN CHAR + PUSHJ P,ERRPAR + JRST BDLP + +;SUBROUTINE TO READ CHARS ONTO STACK + +GOBBL1: MOVEI FF,0 ;KILL ALL FLAGS + PUSHJ P,LSTCHR ;DON'T REREAD " + TROA FF,NOTNUM+INSTRN ;SURPRESS NUMBER CONVERSION +GOBBLE: MOVEI FF,0 ;FLAGS CONCERRNING CURRENT GOODIE IN HERE + MOVE A,TP ;GOBBLE CURRENT TP TO BE PUSHED + MOVEI C,6 ;NOW PUSH 6 0'S ON TO STACK + PUSH TP,$TFIX ;TYPE IS FIXED + PUSH TP,FF ;AND VALUE IS 0 + SOJG C,.-2 ;FOUR OF THEM + PUSH TP,$TTP ;NOW SAVE OLD TP + ADD A,[1,,1] ;MAKE IT LOOK LIKE A TB + PUSH TP,A + MOVEI D,0 ;ZERO OUT CHARACTER COUNT +GOB1: MOVSI C,(<440700,,(P)>) ;SET UP FIRST WORD OF CHARS + PUSH P,[0] ;BYTE POINTER +GOB2: PUSH P,FF ;SAVE FLAG REGISTER + INTGO ; IN CASE P OVERFLOWS + MOVEI A,NXTCH + TRNE FF,INSTRN + MOVEI A,NXTCS ; HACK TO GET MAYBE NEW TYPE WITHOUT CHANGE + PUSHJ P,(A) + POP P,FF ;AND RESTORE FLAG REGISTER + CAIN B,ESCTYP ;IS IT A CHARACTER TO BE ESCAPED + JRST ESCHK ;GOBBLE THE ESCAPED CHARACTER + TRNE FF,INSTRN ;ARE WE BUILDING A CHAR STRING + JRST ADSTRN ;YES, GO READ IN + CAILE B,NONSPC ;IS IT SPECIAL + JRST DONEG ;YES, RAP THIS UP + + TRNE FF,NOTNUM ;IS NUMERIC STILL WINNING + JRST SYMB2 ;NO, ONLY DO CHARACTER HACKING + CAIL A,60 ;CHECK FOR DIGIT + CAILE A,71 + JRST SYMB1 ;NOT A DIGIT + JRST CNV ;GO CONVERT TO NUMBER + CNV: + +;ARRIVE HERE IF STILL BUILDING A NUMBER +CNV: MOVE B,(TP) ;GOBBLE POINTER TO TEMPS + TRO FF,NUMWIN ;SAY DIGITSSEEN + SUBI A,60 ;CONVERT TO A NUMBER + TRNE FF,EFLG ;HAS E BEEN SEEN + JRST ECNV ;YES, CONVERT EXPONENT + TRNE FF,DOTSEN ;HAS A DOT BEEN SEEN + + JRST DECNV ;YES, THIS IS A FLOATING NUMBER + + MOVE E,ONUM(B) ; OCTAL CONVERT + LSH E,3 + ADDI E,(A) + MOVEM E,ONUM(B) + TRNE FF,OCTSTR ; SKIP OTHER CONVERSIONS IF OCTAL FORCE + JRST CNV1 + + JFCL 17,.+1 ;KILL ALL FLAGS + MOVE E,CNUM(B) ;COMPUTE CURRENT RADIX + IMUL E,3(TB) + ADD E,A ;ADD IN CURRENT DIGIT + JFCL 10,.+2 + MOVEM E,CNUM(B) ;AND SAVE IT + + + +;INSERT OCTAL AND CRADIX CROCK HERE IF NECESSSARY + JRST DECNV1 ;CONVERT TO DECIMAL(FIXED) + + +DECNV: TRO FF,FLONUM ;SET FLOATING FLAG +DECNV1: JFCL 17,.+1 ;CLEAR ALL FLAGS + MOVE E,DNUM(B) ;GET DECIMAL NUMBER + IMULI E,10. + JFCL 10,CNV2 ;JUMP IF OVERFLOW + ADD E,A ;ADD IN DIGIT + MOVEM E,DNUM(B) + TRNE FF,FLONUM ;IS THIS FRACTION? + SOS NDIGS(B) ;YES, DECREASE EXPONENT BY ONE + +CNV1: PUSHJ P,NXTCH ;RE-GOBBLE CHARACTER + JRST SYMB2 ;ALSO DEPOSIT INTO SYMBOL BEING MADE +CNV2: ;OVERFLOW IN DECIMAL NUMBER + TRNE FF,DOTSEN ;IS THIS FRACTION PART? + JRST CNV1 ;YES,IGNORE DIGIT + AOS NDIGS(B) ;NO, INCREASE IMPLICIT EXPONENT BY ONE + TRO FF,FLONUM ;SET FLOATING FLAG BUT + JRST CNV1 ;DO NOT FORCE DECIMAL(DECFRC) + +ECNV: ;CONVERT A DECIMAL EXPONENT + HRRZ E,ENUM(B) ;GET EXPONENT + IMULI E,10. + ADD E,A ;ADD IN DIGIT + TLNN E,777777 ;IF OVERFLOW INTO LEFT HALF + HRRM E,ENUM(B) ;DO NOT STORE(CATCH ERROR LATER) + JRST CNV1 + JRST SYMB2 ;ALSO DEPOSIT INTO SYMBOL BEING MADE + + +;HERE TO PUT INTO IDENTIFIER BEING BUILT + +ESCHK: PUSHJ P,NXTC1 ;GOBBLE NEXT CHAR +SYMB: MOVE B,(TP) ;GET BACK TEM POINTER + TRNE FF,EFLG ;IF E FLAG SET + HLRZ FF,ENUM(B) ;RESTORE SAVED FLAGS + TRO FF,NOTNUM ;SET NOT NUMBER FLAG +SYMB2: TRO FF,NFIRST ;NOT FIRST IN WORLD +SYMB3: IDPB A,C ;INSERT IT + PUSHJ P,LSTCHR ;READ NEW CHARACTER + TLNE C,760000 ;WORD FULL? + AOJA D,GOB2 ;NO, KEEP TRYING + AOJA D,GOB1 ;COUNT WORD AND GO + +;HERE TO CHECK FOR +,-,. IN NUMBER + +SYMB1: TRNE FF,NFIRST ;IS THIS THE FIRST CHARACTER + JRST CHECK. ;NO, ONLY LOOK AT DOT + CAIE A,"- ;IS IT MINUS + JRST .+3 ;NO CHECK PLUS + TRO FF,NEGF ;YES, NEGATE AT THE END + JRST SYMB2 + CAIN A,"+ ;IS IT + + JRST SYMB2 ;ESSENTIALLY IGNORE IT + CAIE A,"* ; FUNNY OCTAL CROCK? + JRST CHECK. + + TRO FF,OCTSTR + JRST SYMB2 + +;COULD BE . + +CHECK.: PUSHJ P,LSTCHR ;FLUSH LAST CHARACTER + MOVEI E,0 + TRNN FF,DOTSEN+EFLG ;IF ONE ALREADY SEEN + CAIE A,". + JRST CHECKE ;GO LOOK FOR E + +IFN FRMSIN,[ + TRNN FF,NFIRST ;IS IT THE FIRST + JRST DOT1 ;YES, COULD MEAN EVALUATE A VARIABLE +] + +CHCK.1: TRO FF,DECFRC+DOTSEN ;FORCE DECIMAL +IFN FRMSIN, TRNN FF,FRSDOT ;IF NOT FIRST ., PUT IN CHAR STRING + JRST SYMB2 ;ENTER INTO SYMBOL +IFN FRMSIN, JRST GOB2 ;IGNORE THE "." + + + +IFN FRMSIN,[ + +;HERE TO SET UP FOR .FOO ..FOO OR.<ABC> + +DOT1: PUSH P,FF ;SAVE FLAGS + PUSHJ P,NXTCH1 ;GOBBLE A NEW CHARACTER + POP P,FF ;RESTORE FLAGS + TRO FF,FRSDOT ;SET FLAG IN CASE + CAIN B,NUMCOD ;SKIP IF NOT NUMERIC + JRST CHCK.1 ;NUMERIC, COULD BE FLONUM + +; CODE TO HANDLE ALL IMPLICIT CALLS I.E. QUOTE, LVAL, GVAL + + MOVSI B,TFORM ;LVAL + MOVE A,MQUOTE LVAL + SUB P,[2,,2] ;POP OFF BYTE POINTER AND GOBBLE CALL + POP TP,TP + SUB TP,[1,,1] ;REMOVE TP JUNK + JRST IMPCA1 + +GLOSEG: SKIPA B,$TSEG ;SEG CALL TO GVAL +GLOVAL: MOVSI B,TFORM ;FORM CALL TO SAME + MOVE A,MQUOTE GVAL + JRST IMPCAL + +QUOSEG: SKIPA B,$TSEG ;SEG CALL TO QUOTE +QUOTIT: MOVSI B,TFORM + MOVE A,MQUOTE QUOTE + JRST IMPCAL + +SEGDOT: MOVSI B,TSEG ;SEG CALL TO LVAL + MOVE A,MQUOTE LVAL +IMPCAL: PUSHJ P,LSTCHR ;FLUSH LAST CHAR EXCEPT +IMPCA1: PUSH TP,$TATOM ;FOR .FOO FLAVOR + PUSH TP,A ;PUSH ARGS + PUSH P,B ;SAVE TYPE + PUSHJ P,IREAD1 ;READ + JRST USENIL ; IF NO ARG, USE NIL +IMPCA2: PUSH TP,C + PUSH TP,D + MOVE C,A ; GET READ THING + MOVE D,B + PUSHJ P,INCONS ; CONS TO NIL + MOVEI E,(B) ; PREPARE TON CONS ON +POPARE: POP TP,D ; GET ATOM BACK + POP TP,C + EXCH C,-1(TP) ; SAVE THAT COMMENT + EXCH D,(TP) + PUSHJ P,ICONS + POP P,A ;GET FINAL TYPE + JRST RET13 ;AND RETURN + + +USENIL: PUSH TP,C + PUSH TP,D + SKIPL A,5(TB) ; RESTOR LAST CHR + MOVEI A,5(TB)-LSTCH ;NO CHANNEL, POINT AT SLOT + MOVEM B,LSTCH(A) + MOVEI E,0 + JRST POPARE + +;HERE AFTER READING ATOM TO CALL VALUE + +.SET: SUB P,[1,,1] ;FLUSH GOBBLE CALL + PUSH P,$TFORM ;GET WINNING TYPE + MOVE E,(P) + PUSHJ P,RETC ; CHECK FOR POSSIBLE COMMENT + PUSH TP,$TATOM + PUSH TP,MQUOTE LVAL + JRST IMPCA2 ;GO CONS LIST + +] + +;HERE TO CHECK FOR "E" FLAVOR OF EXPONENT + +CHECKE: CAIN A,"* ; CHECK FOR FINAL * + JRST SYMB4 + TRNN FF,EFLG ;HAS ONE BEEN SEEN + CAIE B,NONSPC ;IF NOT, IS THIS ONE + JRST SYMB ;NO, ENTER AS SYMBOL KILL NUMERIC WIN + + TRNN FF,NUMWIN ;HAVE DIGITS BEEN SEEN? + JRST SYMB ;NO, NOT A NUMBER + MOVE B,(TP) ;GET POINTER TO TEMPS + HRLM FF,ENUM(B) ;SAVE FLAGS + HRRI FF,DECFRC+DOTSEN+EFLG ;SET NEW FLAGS + JRST SYMB3 ;ENTER SYMBOL + + +SYMB4: TRZN FF,OCTSTR + JRST SYMB + TRZN FF,OCTWIN ; ALREADY WON? + TROA FF,OCTWIN ; IF NOT DO IT NOW + JRST SYMB + JRST SYMB2 + +;HERE ON READING CHARACTER STRING + +ADSTRN: SKIPL A ; EOF? + CAIN B,MANYT ;TERMINATE? + JRST DONEG ;YES + CAIE B,CSTYP + JRST SYMB2 ;NO JUST INSERT IT +ADSTN1: PUSHJ P,LSTCHR ;DON'T REREAD """ + + +;HERE TO FINISH THIS CROCK + +DONEG: TRNN FF,OCTSTR ; IF START OCTAL BUT NOT FINISH.. + TRNN FF,NUMWIN ;HAVE DIGITS BEEN SEEN? + TRO FF,NOTNUM ;NO,SET NOT NUMBER FLAG + SKIPGE C ; SKIP IF STUFF IN TOP WORD + SUB P,[1,,1] + PUSH P,D + TRNN FF,NOTNUM ;NUMERIC? + JRST NUMHAK ;IS NUMERIC, GO TO IT + +IFN FRMSIN,[ + MOVE A,(TP) ;GET POINTER TO TEMPS + MOVEM FF,NDIGS(A) ;USE TO HOLD FLAGS +] + TRNE FF,INSTRN ;ARE WE BUILDING A STRING + JRST MAKSTR ;YES, GO COMPLETE SAME +LOOPAT: PUSHJ P,NXTCH ; CHECK FOR TRAILER + CAIN B,PATHTY ; PATH BEGINNER + JRST PATH0 ; YES, GO PROCESS + CAIN B,SPATYP ; SPACER? + PUSHJ P,SPACEQ ; CHECK FOR REAL SPACE + JRST PATH2 + PUSHJ P,LSTCHR ; FLUSH IT AND RETRY + JRST LOOPAT +PATH0: PUSHJ P,NXTCH1 ; READ FORCED NEXT + CAIE B,SPCTYP ; DO #FALSE () HACK + CAIN B,ESCTYP + JRST PATH4 + CAIL B,SPATYP ; SPACER? + JRST PATH3 ; YES, USE THE ROOT OBLIST +PATH4: PUSHJ P,NIREA1 ; READ NEXT ITEM + PUSHJ P,ERRPAR ; LOSER + CAME A,$TATOM ; ONLY ALLOW ATOMS + JRST BADPAT + + PUSH TP,A + PUSH TP,B + PUSH TP,A + PUSH TP,B + PUSH TP,$TATOM + PUSH TP,IMQUOTE OBLIST + MCALL 2,GET ; GET THE OBLIST + CAMN A,$TOBLS ; IF NOT OBLIST, MAKE ONE + JRST PATH6 + MCALL 1,MOBLIS ; MAKE ONE + JRST PATH1 + +PATH6: SUB TP,[2,,2] + JRST PATH1 + + +PATH3: MOVE B,ROOT+1(TVP) ; GET ROOT OBLIST + MOVSI A,TOBLS +PATH1: PUSHJ P,RLOOKU ; AND LOOK IT UP + +IFN FRMSIN,[ + MOVE C,(TP) ;SET TO REGOBBLE FLAGS + MOVE FF,NDIGS(C) +] + JRST FINID + + +SPACEQ: ANDI A,-1 + CAIE A,33 + CAIN A,400033 + POPJ P, + CAIE A,3 + AOS (P) + POPJ P, + +;HERE TO RAP UP CHAR STRING ITEM + +MAKSTR: MOVE C,D ;SETUP TO CALL CHMAK + PUSHJ P,CHMAK ;GO MAKE SAME + JRST FINID + + +NUMHAK: MOVE C,(TP) ;REGOBBLETEMP POINTER + POP P,D ;POP OFF STACK TOP + ADDI D,4 + IDIVI D,5 + HRLI D,(D) ;TOO BOTH HALVES + SUB P,D ;REMOVE CHAR STRING + TRNE FF,FLONUM+EFLG ;IS IT A FLOATING POINT NUMBER + JRST FLOATIT ;YES, GO MAKE IT WIN + MOVE B,CNUM(C) + TRNE FF,DECFRC + MOVE B,DNUM(C) ;GRAB FIXED GOODIE + TRNE FF,OCTWIN ; SKIP IF NOT OCTAL + MOVE B,ONUM(C) ; USE OCTAL VALUE + +FINID2: MOVSI A,TFIX ;SAY FIXED POINT +FINID1: TRNE FF,NEGF ;NEGATE + MOVNS B ;YES +FINID: POP TP,TP ;RESTORE OLD TP + SUB TP,[1,,1] ;FINISH HACK +IFN FRMSIN,[ + TRNE FF,FRSDOT ;DID . START IT + JRST .SET ;YES, GO HACK +] + POPJ P, ;AND RETURN + + + + +PATH2: MOVE B,IMQUOTE OBLIST + PUSHJ P,IDVAL + JRST PATH1 + +BADPAT: PUSH TP,$TATOM + PUSH TP,EQUOTE NON-ATOMIC-OBLIST-NAME + JRST CALER1 + + +FLOATIT: + JFCL 17,.+1 ;CLEAR ALL ARITHMETIC FLAGS + + TRNE FF,EFLG ;"E" SEEN? + JRST EXPDO ;YES, DO EXPONENT + MOVE D,NDIGS(C) ;GET IMPLICIT EXPONENT + +FLOATE: MOVE A,DNUM(C) ;GET DECIMAL NUMBER + IDIVI A,400000 ;SPLIT + FSC A,254 ;CONVERT MOST SIGNIFICANT + FSC B,233 ; AND LEAST SIGNIFICANT + FADR B,A ;COMBINE + + MOVM A,D ;GET MAGNITUDE OF EXPONENT + CAILE A,37. ;HOW BIG? + JRST FOOR ;TOO BIG-FLOATING OUT OF RANGE + JUMPGE D,FLOAT1 ;JUMP IF EXPONENT POSITIVE + FDVR B,TENTAB(A) ;DIVIDE BY TEN TO THE EXPONENT + JRST SETFLO + +FLOAT1: FMPR B,TENTAB(A) ;SCALE UP + +SETFLO: JFCL 10,FOOR ;FLOATING OUT OF RANGE ON OVERFLOW + MOVSI A,TFLOAT +IFN FRMSIN, TRZ FF,FRSDOT ;FLOATING NUMBER NOT VALUE + JRST FINID1 + +EXPDO: + HRRZ D,ENUM(C) ;GET EXPONENT + TRNE FF,NEGF ;IS EXPONENT NEGATIVE? + MOVNS D ;YES + ADD D,NDIGS(C) ;ADD IMPLICIT EXPONENT + HLR FF,ENUM(C) ;RESTORE FLAGS + JUMPL D,FLOATE ;FLOATING IF EXPONENT NEGATIVE + CAIG D,10. ;OR IF EXPONENT TOO LARGE + TRNE FF,FLONUM ;OR IF FLAG SET + JRST FLOATE + MOVE B,DNUM(C) ; + IMUL B,ITENTB(D) + JFCL 10,FLOATE ;IF OVERFLOW, MAKE FLOATING + JRST FINID2 ;GO MAKE FIXED NUMBER + +; HERE TO READ ONE CHARACTER FOR USER. + +CREDC1: SUBM M,(P) + PUSH TP,A + PUSH TP,B + PUSHJ P,IREADC + JFCL + JRST MPOPJ + +CNXTC1: SUBM M,(P) + PUSH TP,A + PUSH TP,B + PUSHJ P,INXTRD + JFCL + JRST MPOPJ + +CREADC: SUBM M,(P) + PUSH TP,A + PUSH TP,B + PUSHJ P,IREADC + JRST RMPOPJ + SOS (P) + JRST RMPOPJ + +CNXTCH: SUBM M,(P) + PUSH TP,A + PUSH TP,B + PUSHJ P,INXTRD + JRST RMPOPJ + SOS (P) +RMPOPJ: SUB TP,[2,,2] + JRST MPOPJ + +INXTRD: TDZA E,E +IREADC: MOVEI E,1 + MOVE B,(TP) ; CHANNEL + HRRZ A,-4(B) ; GET BLESS BITS + TRNE A,C.BIN + TRNE A,C.BUF + JRST .+3 + PUSHJ P,GRB + HRRZ A,-4(B) + TRC A,C.OPN+C.READ + TRNE A,C.OPN+C.READ + JRST BADCHN + SKIPN A,LSTCH(B) + PUSHJ P,RXCT + MOVEM A,LSTCH(B) ; SAVE CHAR + CAMN A,[-1] ; SPECIAL PSEUDO TTY HACK? + JRST PSEUDO ; YES, RET AS FIX + TRZN A,400000 ; UNDO ! HACK + JRST NOEXCL + SKIPE E + MOVEM A,LSTCH(B) + MOVEI A,"! ; RETURN AN ! +NOEXC1: SKIPGE B,A ; CHECK EOF + SOS (P) ; DO EOF RETURN + MOVE B,A ; CHAR TO B + MOVSI A,TCHRS +PSEUD1: AOS (P) + POPJ P, + +PSEUDO: SKIPE E + PUSHJ P,LSTCH2 + MOVE B,A + MOVSI A,TFIX + JRST PSEUD1 + +NOEXCL: SKIPE E + PUSHJ P,LSTCH2 + JRST NOEXC1 + +; READER ERRORS COME HERE + +ERRPAR: PUSH TP,$TCHRS ;DO THE OFFENDER + PUSH TP,B + PUSH TP,$TCHRS + PUSH TP,[40] ;SPACE + PUSH TP,$TCHSTR + PUSH TP,CHQUOT UNEXPECTED + JRST MISMA1 + +;COMPLAIN ABOUT MISMATCHED CLOSINGS + +MISMAB: SKIPA A,["]] +MISMAT: MOVE A,-1(P) ;GOBBLE THE DESIRED CHARACTER + JUMPE B,CPOPJ ;IGNORE UNIVERSAL CLOSE + PUSH TP,$TCHRS + PUSH TP,B + PUSH TP,$TCHSTR + PUSH TP,CHQUOT [ INSTEAD-OF ] + PUSH TP,$TCHRS + PUSH TP,A +MISMA1: MCALL 3,STRING + PUSH TP,$TATOM + PUSH TP,EQUOTE READER-SYNTAX-ERROR-ERRET-ANYTHING-TO-GO-ON + PUSH TP,A + PUSH TP,B + PUSH TP,$TATOM + PUSH TP,MQUOTE READ + MCALL 3,ERROR +CPOPJ: POPJ P, + +; HERE ON BAD INPUT CHARACTER + +BADCHR: PUSH TP,$TATOM + PUSH TP,EQUOTE BAD-ASCII-CHARACTER + JRST CALER1 + +; HERE ON YUCKY PARSE TABLE + +BADPTB: PUSH TP,$TATOM + PUSH TP,EQUOTE BAD-MACRO-TABLE + JRST CALER1 + +BDPSTR: PUSH TP,$TATOM + PUSH TP,EQUOTE BAD-PARSE-STRING + JRST CALER1 + +ILLSQG: PUSHJ P,LSTCHR ; DON'T MESS WITH IT AGAIN + PUSH TP,$TATOM + PUSH TP,EQUOTE BAD-USE-OF-SQUIGGLY-BRACKETS + JRST CALER1 + + +;FLOATING POINT NUMBER TOO LARGE OR SMALL +FOOR: PUSH TP,$TATOM + PUSH TP,EQUOTE NUMBER-OUT-OF-RANGE + JRST CALER1 + + +NILSXP: 0,,0 + +LSTCHR: PUSH P,B + SKIPL B,5(TB) ;GET CHANNEL + JRST LSTCH1 ;NO CHANNEL, POINT AT SLOT + PUSHJ P,LSTCH2 + POP P,B + POPJ P, + +LSTCH2: SKIPE LSTCH(B) ;ARE WE REALLY FLUSHING A REUSE CHARACTER ? + PUSHJ P,CNTACC + SETZM LSTCH(B) + POPJ P, + +LSTCH1: SETZM 5(TB) ;ZERO THE LETTER AND RETURN + POP P,B + POPJ P, + +CNTACC: PUSH P,A + HRRZ A,-4(B) ; GET BITS + TRNE A,C.BIN + JRST CNTBIN + AOS ACCESS(B) +CNTDON: POP P,A + POPJ P, + +CNTBIN: AOS A,ACCESS-1(B) + CAMN A,[TFIX,,1] + AOS ACCESS(B) + CAMN A,[TFIX,,5] + HLLZS ACCESS-1(B) + JRST CNTDON + + +;TABLE OF NAMES OF ARGS AND ALLOWED TYPES + +ARGS: + IRP A,,[[[CAIN C,TUNBOU]],[[CAIE C,TCHAN],INCHAN],[[PUSHJ P,CHOBL],OBLIST]] + IRP B,C,[A] + B + IFSN [C],IMQUOTE C + .ISTOP + TERMIN + TERMIN + +CHOBL: CAIE C,TLIST ;A LIST OR AN OBLIST + CAIN C,TOBLS + AOS (P) + POPJ P, + +END + + \ No newline at end of file diff --git a/sumex/save.mcr083 b/sumex/save.mcr083 new file mode 100644 index 0000000..4808df7 --- /dev/null +++ b/sumex/save.mcr083 @@ -0,0 +1,749 @@ +TITLE SAVE AND RESTORE STATE OF A MUDDLE + +RELOCATABLE + +.INSRT DSK:MUDDLE > + +SYSQ + +IFE ITS,[ +IF1,[ +.INSRT STENEX > +EXPUNGE SAVE +] +] + +.GLOBAL MOPEN,MIOT,MCLOSE,MUDSTR,SWAP,STRTO6,GCPDL,RGPRS +.GLOBAL CHNL0,CHNL1,REOPN,AGC,SWAPIN,MASK1,MASK2,IPCBLS +.GLOBAL P.CORE,P.TOP,SGSNAM,%RUNAM,%RJNAM,INTINT,CLOSAL,TTYOPE +.GLOBAL NOTTY,PURCLN,6TOCHS,DISXTR,IDVAL1,N.CHNS + +MFUNCTION FSAVE,SUBR + + ENTRY + + PUSH P,. ; SAY WE ARE FAST SAVER + JRST SAVE1 + +MFUNCTION SAVE,SUBR + + ENTRY + + PUSH P,[0] ; SAY WE ARE OLD SLOW SAVE +SAVE1: SKIPG MUDSTR+2 ; DON'T SAVE FROM EXPERIMENTAL MUDDLE + JRST EXPVRS + PUSH P,[0] ; GC OR NOT? +IFE ITS,[ + MOVE B,[400600,,] + MOVE C,[440000,,100000] +] + PUSHJ P,GTFNM ; GET THE FILE NAME ONTO P + JRST .+2 + JRST SAVEON + JUMPGE AB,TMA ; TOO MUCH STRING + GETYP 0,(AB) ; WHAT IS ARG + CAMGE AB,[-3,,0] ; NOT TOO MANY + JRST TMA + CAIN 0,TFALSE +IFN ITS, SETOM -4(P) ; GC FLAG +IFE ITS, SETOM (P) +SAVEON: +IFN ITS,[ + MOVSI A,7 ; IMAGE BLOCK OUT + HRR A,-2(P) ; DEVICE + PUSH P,A + PUSH P,[SIXBIT /_MUDS_/] + PUSH P,[SIXBIT />/] + MOVEI A,-2(P) ; POINT TO BLOCK + PUSHJ P,MOPEN ; ATTEMPT TO OPEN + JRST CANTOP + SUB P,[3,,3] ; FLUSH OPEN BLOCK + PUSH P,-4(P) ; GC FLAG TO TOP OF STACK +] + EXCH A,(P) ; CHAN TO STACK GC TO A + JUMPL A,.+2 + MCALL 0,GC + +; NOW GET VERSION OF MUDDLE FOR COMPARISON + + MOVE A,MUDSTR+2 ; GET # + MOVEI B,177 ; CHANGE ALL RUBOUT CHARACTERS + MOVEI C,40 ; ----- TO SPACES + PUSHJ P,HACKV + + PUSHJ P,WRDOUT + MOVEI A,0 ; WRITE ZERO IF FAST +IFN ITS, SKIPE -6(P) +IFE ITS, SKIPE -1(P) + PUSHJ P,WRDOUT + MOVE A,VECTOP ; CORE REQUIREMENTS FOR THIS SAVED MUDDLE + PUSHJ P,WRDOUT + +IFN ITS,[ + SETZB A,B ; FIRST, ALL INTS OFF + .SETM2 A, + SKIPE DISXTR ; IF HAVE DISPLAY, CLOSE IT + .DSTOP ; STOP THE E&S IF RUNNING + +; IF FAST SAVE JUMP OFF HERE + + SKIPE -6(P) + JRST FSAVE1 + +; NOW DUMP OUT GC SPACE + MOVEI A,E+1 ; ADDRESS OF FIRST NON-SCRATCH WORD + POP P,0 ; CHAN TO 0 + LSH 0,23. ; POSITION + IOR 0,[.IOT A] +] + +IFE ITS,[ + MOVEI A,400000 ; FOR THIS PROCESS + DIR ; TURN OFF INT SYSTEM + +; IF FAST, LEAVE HERE + + SKIPE -1(P) + JRST FSAVE1 + +; NOW DUMP OUT GC SPACE + POP P,0 ; RESTORE JFN + MOVE A,[-<P-E>,,E] ; NUMBER OF ACS TO GO + PUSH P,(A) + AOBJN A,.-1 + MOVE A,0 + MOVE B,P + BOUT + MOVEI A,20 ; START AT LOCN 20 +] +DMPLP1: MOVEI B,(A) ; POINT TO START OF STUFF + SUB B,VECTOP ; GET BLOCK LENGTH + MOVSI B,(B) + HRRI B,(A) ; HAVE IOT POINTER + SKIPL B ; SKIP IF OK AOBJN POINTER + HRLI B,400000 ; OTHER WISE AS MUCH AS POSSIBLE + +; MAIN NON-ZERO DUMPING LOOP + +DMPLP: SKIPN C,(B) ; FIND FIRST NON-ZERO + AOBJN B,.-1 + JUMPGE B,DMPDON ; NO MORE TO SCAN + +DMP4: MOVEI E,(B) ; FOUND ONE, SAVE POINTER TO IT +DMP3: MOVSI D,-5 ; DUPLICATE COUNTER SETUP + +DMP1: CAMN C,(B) ; IS NEXT SAME AS THIS? + JRST CNTDUP ; COUNT DUPS + MOVSI D,-5 ; RESET COUNTER + SKIPE C,(B) ; SEARCH FOR ZERO +DMP5: AOBJN B,DMP1 ; COUNT AND GO + JUMPGE B,DMP2 ; JUMP IF BLOCK FINISHED + + AOBJP B,DMP2 ; CHECK FOR LONE ZERO + SKIPE C,(B) + JRST DMP1 ; LONE ZERO, DONT END BLOCK + +DMP2: MOVEI D,(E) ; START COMPUTING OUTPUT IOT + SUBI D,(B) ; D=> -LNTH OF BLOCK + HRLI E,(D) ; E=> AOBJN PNTR TO OUTPUT +IFN ITS,[ + HRROI A,E ; MAKE AN IOT POINTER TO IT + XCT 0 ; WRITE IT + MOVE A,E ; NOW FOR THE BLOCK + XCT 0 ; ZAP!, OUT IT GOES +] +IFE ITS,[ + EXCH E,B ; AOBJN TO B + MOVE A,0 ; JFN TO A + BOUT ; WRITE IT + MOVE D,B ; SAVE POINTER + HRLI B,444400 ; BYTPE POINTER + HLRE C,D ; # OF BYTES + SOUT +] +; NOW COMPUTE A CKS + +IFN ITS,[ + MOVE D,E ; FIRST WORD OF CKS + ROT E,1 + ADD E,(D) + AOBJN D,.-2 ; COMP CKS + HRROI A,E + XCT 0 ; WRITE OUT THE CKS +] +IFE ITS,[ + MOVE B,D + ROT B,1 + ADD B,(D) + AOBJN D,.-2 + BOUT + MOVE B,E ; MAIN POINTER BACK +] + +DMP7: JUMPL B,DMPLP ; MORE TO DO? +DMPDON: SUB B,VECTOP ; DONE? + JUMPGE B,DMPDN1 ; YES, LEAVE +IFN ITS, MOVEI A,400000+PVP ; POINT TO NEXT WORD TO GO +IFE ITS, MOVEI A,400020 + JRST DMPLP1 +IFN ITS,[ +DMPDN1: HRROI A,[-1] + XCT 0 ; EOF +DMPDN2: SETZB A,B ; SET UP RENAME WHILE OPEN ETC. + MOVE E,(P) + MOVE D,-1(P) + LDB C,[270400,,0] ; GET CHANNEL + .FDELE A ; RENAME IT + FATAL SAVE RENAME FAILED + XOR 0,[<.IOT A>#<.CLOSE>] ; CHANGE TO A CLOSE + XCT 0 + + MOVE A,MASK1 ; TURN INTS BACK ON + MOVE B,MASK2 + .SETM2 A, + SKIPE DISXTR ; SKIP IF NO E&S + .DCONTINUE ; RESTART THE E&S IF WE HAVE IT +] + +IFE ITS,[ +DMPDN1: MOVNI B,1 + MOVE A,0 ; WRITE EOF + BOUT +DMPDN2: MOVE A,0 + CLOSF + FATAL CANT CLOSE SAVE FILE + CIS ; CLEAR IT SYSTEM + MOVEI A,400000 + EIR ; AND RE-ENABLE +] + +SDONE: MOVE A,$TCHSTR + MOVE B,CHQUOTE SAVED + JRST FINIS + +; SCAN FOR MANY OCCURENCES OF THE SAME THING + +CNTDUP: AOBJN D,DMP5 ; 4 IN A ROW YET + CAIN E,-4(B) ; ANY PARTIAL BLOCK? + JRST DMP6 ; NO, DUMP THESE + SUB B,[4,,4] ; BACK UP POINTER + JRST DMP2 +DMP6: CAMN C,(B) ; FIND ALL CONTIG + AOBJN B,.-1 + MOVEI D,(B) ; COMPUTE COUNT + SUBI D,(E) + MOVSI D,(D) + HRRI D,(E) ; HEADER +IFN ITS,[ + HRROI A,D + XCT 0 + HRROI A,C ; WRITE THE WORD + XCT 0 +] +IFE ITS,[ + MOVE A,0 + EXCH D,B + BOUT + MOVE B,C + BOUT + MOVE B,D +] JRST DMP7 + +; HERE TO WRITE OUT FAST SAVE FILE + +FSAVE1: MOVE A,PARTOP ; DONT WRITE OUT "HOLE" + ADDI A,1777 + ANDCMI A,1777 + MOVEI E,(A) + PUSHJ P,WRDOUT + MOVE A,VECBOT + ANDCMI A,1777 + HRLI E,(A) + PUSHJ P,WRDOUT + POP P,0 ; CHANNEL TO 0 +IFN ITS,[ + ASH 0,23. ; TO AC FIELS + IOR 0,[.IOT A] + MOVEI A,5 ; START AT WORD 5 +] +IFE ITS,[ + MOVE A,[-<P-E>,,E] + PUSH P,(A) + AOBJN A,.-1 + MOVE A,0 + MOVE B,P ; WRITE OUT P FOR WIINAGE + BOUT + MOVE B,[444400,,20] + MOVNI C,20-6 + SOUT ; MAKE PAGE BOUNDARIES WIN + MOVEI A,20 ; START AT 20 +] + MOVEI B,(E) ; PARTOP TO B + PUSHJ P,FOUT ; WRITE OUT UP TO PAIR TOP + HLRZ A,E ; VECBOT TO A + MOVE B,VECTOP ; AND THE REST + PUSHJ P,FOUT + JRST DMPDN2 + +IFN ITS,[ +FOUT: MOVEI D,(A) ; SAVE START + SUB A,B ; COMPUTE LH OF IOT PNTR + MOVSI A,(A) + SKIPL A ; IF + MEANS GROSS CORE SIZE + MOVSI A,400000 ; USE BIGGEST + HRRI A,(D) + XCT 0 ; ZAP, OUT IT GOES + CAMGE A,B ; SKIP IF ALL WENT + JRST FOUT ; DO THE REST + POPJ P, ; GO CLOSE FILE +] +IFE ITS,[ +FOUT: MOVEI C,(A) + SUBI C,(B) ; # OF BYTES TP C + MOVEI B,(A) ; START TO B + HRLI B,444400 + MOVE A,0 + SOUT ; WRITE IT OUT + POPJ P, +] + + +; HERE TO ATTEMPT TO RESTORE A SAVED STATE + +MFUNCTION RESTORE,SUBR + + ENTRY + SKIPG MUDSTR+2 ; DON'T RESTORE FROM EXPERIMENTAL MUDDLE + JRST EXPVRS +IFE ITS,[ + MOVE B,[100600,,] + MOVE C,[440000,,240000] +] + PUSHJ P,GTFNM + JRST TMA +IFN ITS,[ + MOVEI A,6 ; READ/IMAGE/BLOCK + HRLM A,-2(P) + MOVEI A,-2(P) + PUSHJ P,MOPEN ; OPEN THE LOSER + JRST FNF + SUB P,[4,,4] ; REMOVE OPEN BLOCK + + PUSH P,A ; SAVE CHANNEL + PUSHJ P,SGSNAM ; SAVE SNAME IN SYSTEM +] +IFE ITS, PUSH P,A ; SAVE JFN + PUSHJ P,WRDIN ; READ MUDDLE VERSION + MOVEI B,40 ; CHANGE ALL SPACES + MOVEI C,177 ; ----- TO RUBOUT CHARACTERS + PUSHJ P,HACKV + CAME A,MUDSTR+2 ; AGREE ? + JRST BADVRS + +IFN ITS, MCALL 0,IPCOFF ; CLOSE ALL IPC CHANS + PUSHJ P,CLOSAL ; CLOSE CHANNELS +IFN ITS,[ + SETZB A,B ; KILL ALL POSSIBLE INTERRUPTION + .SETM2 A, +] +IFE ITS,[ + MOVEI A,400000 ; DISABLE INTS + DIR ; INTS OFF +] + PUSHJ P,PURCLN ; DONT KEEP PURE SHAREDNESS + POP P,A ; RETRIEVE CHANNEL + MOVE P,GCPDL + PUSH P,A ; AND SAVE IT ON A GOOD PDL + PUSHJ P,WRDIN ; READ A WORD (VECTOP) OR 0==>FAST I.E. MAP RESTORE + JUMPE A,FASTR + MOVEM A,VECTOP ; SAVE FOR LATER + ASH A,-10. ; TO BLOCKS + MOVE C,A ; SAVE A COPY + ADDI A,1 ; ROOM FOR GC PDL + PUSHJ P,P.CORE + PUSHJ P,NOCORE ; LOSE,LOSE, LOSE + +; NOW READY TO READ IN GC SPACE + POP P,0 ; GET CHAN + MOVEI E+1,0 + MOVE B,[E+1,,E+2] ; BLT SETUP TO ZERO CORE + MOVE E,NOTTY + MOVE A,VECTOP + BLT B,-1+2000(A) ; THE WHOLE THING? +IFN ITS,[ + LSH 0,23. + IOR 0,[.IOT A] ; BUILD IOT +] +IFE ITS,[ + MOVE A,0 + BIN ; READ IN NEW "P" + MOVE P,B +] +LDLP: +IFN ITS,[ + HRROI A,B ; READ A HDR + XCT 0 + JUMPL A,LD1 ; DONE +] +IFE ITS,[ + MOVE A,0 + BIN ; HDR TO B +] + CAMN B,[-1] + JRST LD1 + + JUMPGE B,LDDUPS ; JUMP IF LOADING DUPS +IFN ITS,[ + MOVE A,B ; TO IOTER + XCT 0 + + MOVE C,B ; COMP CKS + ROT C,1 + ADD C,(B) + AOBJN B,.-2 ; COMP AWAY + + HRROI A,D ; GET FILES CKS + XCT 0 + CAME D,C ; CHECK + FATAL RESTORE CHECKSUM ERROR + JRST LDLP ; LOAD MORE +] +IFE ITS,[ + MOVE D,B ; SAVE + HLRE C,B + HRLI B,444400 + MOVE A,0 + SIN ; READ IN A BUNCH + + MOVE B,D + ROT D,1 + ADD D,(B) + AOBJN B,.-2 + + BIN ; READ STORED CKS + CAME D,B + FATAL RESTORE CHECKSUM ERROR + JRST LDLP +] + +LDDUPS: +IFN ITS,[ + HRROI A,(B) ; READ 1ST IN PLACE + XCT 0 +] +IFE ITS,[ + MOVE D,B ; SAVE HDR + BIN ; READ WORD OF INTEREST + MOVEM B,(D) + MOVE B,D +] + HLRZ A,B ; # TO A + HRLI B,(B) ; BUILD A BLT PONTER + ADDI B,1 + ADDI A,-2(B) + BLT B,(A) + JRST LDLP + +LD1: +IFN ITS,[ + XOR 0,[<.IOT A>#<.CLOSE>] ; CHANGE TO CLOSE + XCT 0 ; AND DO IT +] +IFE ITS,[ + MOVE A,0 + CLOSF + JFCL +FASTR1: MOVEI A,P-1 + MOVEI B,P-1-E + POP P,(A) + SUBI A,1 + SOJG B,.-2 +] + +IFN ITS,[ +FASTR1: +] + MOVE A,VECTOP ; REAL CORE TOP + ADDI A,2000 ; ROOM FOR GC PDL + MOVEM A,P.TOP + MOVEM E,NOTTY ; SAVE TTY FLAG + PUSHJ P,PURCLN ; IN CASE RESTORED THING HAD PURE STUFF + PUSHJ P,INTINT ; USE NEW INTRRRUPTS + +; NOW CYCLE THROUGH CHANNELS + MOVE C,TVP + ADD C,[CHNL1+2,,CHNL1+2] ; POINT TO REAL CHANNELS SLOTS + PUSH TP,$TVEC + PUSH TP,C + PUSH P,[N.CHNS] + +CHNLP: SKIPN B,-1(C) ; GET CHANNEL + JRST NXTCHN + PUSHJ P,REOPN + PUSHJ P,CHNLOS + MOVE C,(TP) ; GET POINTER +NXTCHN: ADD C,[2,,2] ; AND BUMP + MOVEM C,(TP) + SOSE (P) + JRST CHNLP + + SKIPN C,CHNL0(TVP)+1 ; ANY PSUEDO CHANNELS + JRST RDONE ; NO, JUST GO AWAY + MOVSI A,TLIST ; YES, REOPEN THEM + MOVEM A,(TP)-1 +CHNLP1: MOVEM C,(TP) ; SAVE POINTER + SKIPE B,(C)+1 ; GET CHANNEL + PUSHJ P,REOPN + PUSHJ P,CHNLO1 + MOVE C,(TP) ; GOBBLE POINTER + HRRZ C,(C) ; REST LIST OF PSUEDO CHANNELS + JUMPN C,CHNLP1 + +RDONE: SUB TP,[2,,2] + SUB P,[1,,1] + PUSHJ P,TTYOPE +IFN ITS,[ + PUSHJ P,IPCBLS ;BLESS ALL THE IPC CHANNELS + PUSHJ P,SGSNAM ; GET SNAME + SKIPN A + .SUSET [.RSNAM,,A] + PUSHJ P,6TOCHS ; TO STRING + PUSH TP,A + PUSH TP,B + MCALL 1,SNAME +] + PUSHJ P,%RUNAM + PUSHJ P,%RJNAM + MOVE A,$TCHSTR + MOVE B,CHQUOTE RESTORED + JRST FINIS + +FASTR: +IFN ITS,[ + PUSHJ P,WRDIN ; GET CORE TOP + ASH A,-10. ; TO PAGES + MOVEI B,(A) ; SAVE + ADDI A,1 ; ROOM FOR GC PDL + PUSHJ P,P.CORE ; GET ALL CORE + PUSHJ P,NOCORE ; LOSE RETURN + PUSHJ P,WRDIN ; GET PARTOP + ASH A,-10. ; TO PAGES + MOVEI E,(A) + PUSHJ P,WRDIN ; NOW GET VECBOT + ASH A,-10. ; TO PAGES + EXCH A,E ; AND SAVE IN E + MOVNS A + MOVSI A,(A) ; TO PAGE AOBJN + MOVE C,A ; COPY OF POINTER + MOVE 0,NOTTY ; SAVE NOTTY FLAG AROUND + MOVE D,(P) ; CHANNEL + DOTCAL CORBLK,[[1000,,104000],[1000,,-1],A,D,C] + FATAL CORBLK ON RESTORE LOSSAGE + SUBM E,B ; AOBJN LH TO E + HRLI E,(B) ; AOBJN TO CORE + HRLI C,(B) ; AND TO DISK + DOTCAL CORBLK,[[1000,,104000],[1000,,-1],E,D,C] + FATAL CORBLK ON RESTORE LOSSAGE + MOVSI A,(D) ; CHANNEL BACK + ASH A,5 + MOVEI B,E ; WHERE TO STRAT IN FILE + IOR A,[.ACCESS B] + XCT A ; ACCESS TO RIGHT ACS + XOR A,[<.IOT B>#<.ACCESS B>] + MOVE B,[D-P-1,,E] + XCT A ; GET ACS + MOVE E,0 ; NO TTY FLAG BACK + XOR A,[<.IOT B>#<.CLOSE>] + XCT A +] +IFE ITS,[ +FASTR: POP P,A ; JFN TO A + BIN ; CORE TOP TO B + MOVE E,B ; SAVE + BIN ; PARTOP + MOVE D,B + BIN ; VECBOT + MOVE C,B + BIN ; SAVED P + MOVE P,B + MOVE 0,NOTTY ; SAVE NOTTY FLAG AROUND + HRL E,C ; SAVE VECTOP + MOVSI A,(A) ; JFN TO LH + MOVSI B,400000 ; FOR ME + MOVSI C,120400 ; FLAGS + ASH D,-9. ; PAGES TO D + PMAP + ADDI A,1 + ADDI B,1 + SOJG D,.-3 + + ASH E,-9. ; E==> CORTOP PAGE,,VECBOT PAGE + HLR B,E ; B NOW READY + MOVEI D,(E) + SUBI D,(B) + PMAP + ADDI A,1 + ADDI B,1 + SOJG D,.-3 + + HLRZS A + CLOSF + FATAL CANT CLOSE RESTORE FILE + MOVE E,0 ; NOTTY TO E +] + MOVE A,PARTOP ; ZERO OUT NEW FREE + HRLI A,(A) + MOVE B,VECBOT + SETZM (A) + ADDI A,1 + BLT A,-1(B) ; ZAP...YOU'RE ZERO + JRST FASTR1 + + +; HERE TO GROCK FILE NAME FROM ARGS + +GTFNM: +IFN ITS,[ + PUSH TP,$TPDL + PUSH TP,P + + IRP A,,[DSK,MUDDLE,SAVE] + PUSH P,[SIXBIT /A/] + TERMIN + PUSHJ P,SGSNAM ; GET SNAME + PUSH P,A ; SAVE SNAME + + JUMPGE AB,GTFNM1 + PUSHJ P,RGPRS ; PARSE THESE ARGS + JRST .+2 +GTFNM1: AOS -4(P) ; SKIP RETURN + + POP P,A ; GET SNAME + .SUSET [.SSNAM,,A] + MOVE A,-3(P) ; GET RET ADDR + HLRZS -2(P) ; FIXUP DEVICE SPEC + SUB TP,[2,,2] + JRST (A) + +; HERE TOO OUT 1 WORD + +WRDOUT: PUSH P,B + PUSH P,A + HRROI B,(P) ; POINT AT C(A) + MOVE A,-3(P) ; CHANNEL + PUSHJ P,MIOT ;WRITE IT +POPJB: POP P,A + POP P,B + POPJ P, + +; HERE TO READ 1 WORD +WRDIN==WRDOUT +] +IFE ITS,[ + PUSH P,C + PUSH P,B + MOVE B,IMQUOTE SNM + PUSHJ P,IDVAL1 + GETYP 0,A + CAIN 0,TUNBOU + MOVEI B,0 + MOVEI A,(P) + PUSH P,[377777,,377777] + PUSH P,[-1,,[ASCIZ /DSK/]] + PUSH P,B + PUSH P,[-1,,[ASCIZ /MUDDLE/]] + PUSH P,[-1,,[ASCIZ /SAVE/]] + PUSH P,[0] + PUSH P,[0] + PUSH P,[77] ; USE AN OBSCURE JFN IF POSSIBLE + MOVE B,1(AB) + GTJFN + JRST FNF + SUB P,[9.,,9.] + POP P,B + OPENF + JRST FNF + ADD AB,[2,,2] + SKIPL AB + AOS (P) + POPJ P, + +WRDIN: PUSH P,B + MOVE A,-2(P) ; JFN TO A + BIN + MOVE A,B + POP P,B + POPJ P, + +WRDOUT: PUSH P,B + MOVE B,-2(P) + EXCH A,B + BOUT + EXCH A,B + POP P,B + POPJ P, +] + + +;REPLACE ALL OCCURANCES OF CHARACTER (B) TO CHARACTER (C) IN A +HACKV: PUSH P,D + PUSH P,E + MOVE D,[440700,,A] + MOVEI E,5 +HACKV1: ILDB 0,D + CAIN 0,(B) ; MATCH ? + DPB C,D ; YES, CLOBBER + SOJG E,HACKV1 + POP P,E + POP P,D + POPJ P, + + +CANTOP: PUSH TP,$TATOM + PUSH TP,EQUOTE CANT-OPEN-OUTPUT-FILE + JRST CALER1 + +FNF: PUSH TP,$TATOM + PUSH TP,EQUOTE FILE-NOT-FOUND + JRST CALER1 + +BADVRS: PUSH TP,$TATOM + PUSH TP,EQUOTE MUDDLE-VERSIONS-DIFFER + JRST CALER1 + +EXPVRS: PUSH TP,$TATOM + PUSH TP,EQUOTE EXPERIMENTAL-MUDDLE-VERSION + JRST CALER1 + +CHNLO1: MOVE C,(TP) + SETZM 1(C) + JRST CHNLO2 + +CHNLOS: MOVE C,(TP) + SETZM (C)-1 +CHNLO2: MOVEI B,[ASCIZ / +CHANNEL-NOT-RESTORED +/] + JRST MSGTYP" + + +NOCORE: PUSH P,A + PUSH P,B + MOVEI B,[ASCIZ / +WAIT, CORE NOT YET HERE +/] + PUSHJ P,MSGTYP" + MOVE A,(P) ; RESTORE BLOCKS NEEDED + MOVEI B,1 + .SLEEP B, + PUSHJ P,P.CORE + JRST .-4 + MOVEI B,[ASCIZ / +CORE ARRIVED +/] + PUSHJ P,MSGTYP + POP P,B + POP P,A + POPJ P, +END + \ No newline at end of file diff --git a/sumex/specs.mcr062 b/sumex/specs.mcr062 new file mode 100644 index 0000000..f0c7401 --- /dev/null +++ b/sumex/specs.mcr062 @@ -0,0 +1,302 @@ +TITLE SPECS FOR MUDDLE + +RELOCA + +MAIN==1 +.GLOBAL TYPVLC,PBASE,TYPBOT,MAINPR,PTIME,IDPROC,ROOT,TTICHN,TTOCHN,TYPVEC +.GLOBAL %UNAM,%JNAM,NOTTY,GCHAPN,INTHLD,PURBOT,PURTOP,N.CHNS,SPCCHK,CURFCN +.GLOBAL TD.GET,TD.PUT,TD.LNT,NOSHUF + + +.INSRT MUDDLE > + +SYSQ + +CONSTANTS + +IFN ITS,[ + N.CHNS==16. + FATINS==.VALUE +] +IFE ITS,[ + N.CHNS==102 +] + +IMPURE + +CRADIX: 10. +%UNAM: 0 ; HOLDS UNAME +%JNAM: 0 ; HOLDS JNAME +IDPROC: 0 ; ENVIRONMENT NUMBER GENERATOR +PTIME: 0 ; UNIQUE NUMBER FOR PROCID AND ENVIRONMENTS +OBLNT": 13. ; LENGTH OF DEFAULT OBLISTS (SMALL) +VECTOP": VECLOC ; TOP OF CURRENT GARBAGE COLLECTED SPACE +VECBOT": VECBASE ; BOTTOM OF GARBAGE COLLECTED SPACE +CODBOT: 0 ; ABSOLUTE BOTTOM OF CODE +CODTOP": PARBASE ; TOP OF IMPURE CODE (INCLUDING "STORAGE") +HITOP: 0 ; TOP OF INTERPRETER PURE CORE +PARNEW": 0 +PARBOT": PARBASE +PARTOP": PARLOC +VECNEW": 0 ; LOCATION FOR OFFSET BETWWEN OLD GCSTOP AND NEW GCSTOP +INTFLG: 0 ; INTERRUPT PENDING FLAG +MAINPR: 0 ; HOLDS POINTER TO THE MAIN PROCESS +NOTTY: 0 ; NON-ZERO==> THIS MUDDLE HAS NO TTY +GCHAPN: 0 ; NON-ZERO A GC HAS HAPPENED RECENTLY +INTHLD: 0 ; NON-ZERO INTERRUPTS CANT HAPPEN +PURBOT: HIBOT ; BOTTOM OF DYNAMICALLY ALLOCATED PURE +PURTOP: HIBOT ; TOP OF DYNAMICALLY ALLOCATED PURE +SPCCHK: SETZ ; SPECIAL/UNSPECIAL CHECKING? +NOSHUF: 0 ; FLAG TO BUILD A NON MOVING HI SEG + +;PAGE MAP USAGE TABLE FOR MUDDLE +;EACH PAGE IS REPRESENTED BY ONE BIT IN THE TABLE +;IF BIT = 0 THEN PAGE IS FREE OTHERWISE BUSY +;FOR PAGE n USE BIT (n MOD 32.) IN WORD PMAP+n/32. +PMAP": -1 ;SECTION 0 -- BELONGS TO AGC + -1 ;SECTION 1 -- BELONGS TO AGC + -1 ;SECTION 2 -- BELONGS TO AGC + -1 ;SECTION 3 -- BELONGS TO AGC + -1 ;SECTION 4 -- BELONGS TO AGC + -1 ;SECTION 5 -- BELONGS TO AGC (DEPENDS ON HIBOT) + -1 ;SECTION 6 -- START OF PURE CORE (FILLED IN BY INITM) + -1 ;SECTION 7 -- LAST TWO PAGES BELONG TO AGC'S PAGE MAPPER + + +NINT==72. ; NUMBER OF POSSIBLE ITS INTERRUPTS +NASOCS==159. ; LENGTH OF ASSOCIATION VECTOR +PDLBUF==100 ; EXTRA INSURENCE PDL +ASOLNT==10 ; LENGTH OF ASSOCIATION BLOCKS + + +.GLOBAL PATCH,TBINIT,LERR,LPROG,PIDSTO,PROCID,PTIME,GCPDL,INTFLG,WTYP1,WTYP2 +.GLOBAL PAT,PDLBUF,INTINT,PARNEW,GCPVP,START,SWAP,ICR,SPBASE,TPBASE,GLOBAS,GLOBSP,TPBAS +.GLOBAL TOPLEVEL,INTNUM,INTVEC,INTOBL,ASOVEC,ERROBL,MAINPR,RESFUN,.BLOCK,ASOLNT,NODES +.GLOBAL WRONGT,TTYOPE,OPEN,CLOSE,IOT,ILVAL,MESS,FACTI,REFVEC,MUDOBL,INITIA +.GLOBAL LSTRES,BINDID,DUMNOD,PSTAT,1STEPR,IDPROC,EVATYP,APLTYP,PRNTYP,PURVEC,STOLST + + +VECTGO +TVBASE": BLOCK TVLNT + GENERAL + TVLNT+2,,0 +TVLOC==TVBASE + + + +;INITIAL TYPE TABLE + +TYPVLC": + BLOCK 2*NUMPRI+2 + GENERAL + 2*NUMPRI+2+2,,0 + +TYPTP==.-2 ; POINT TO TOP OF TYPES + +; INITIAL SYMBOL TABEL FOR RSUBRS + +SQULOC==. +SQUTBL: BLOCK 2*NSUBRS + TWORD,,0 + 2*NSUBRS+2,,0 + +INTVCL: BLOCK 2*NINT + TLIST,,0 + 2*NINT+2,,0 + +NODLST: TTP,,0 + 0 + TASOC,,0 + BLOCK ASOLNT-3 + GENERAL+<SASOC,,0> + ASOLNT+2,,0 + +NODDUM: BLOCK ASOLNT + GENERAL+<SASOC,,0> + ASOLNT+2,,0 + + + +ASOVCL: BLOCK NASOCS + TASOC,,0 + NASOCS+2,,0 + + + +;THESE ENTRIES MUST NOT MOVE DURING INITILAIZATION + +ADDTV TVEC,[-2*NUMPRI-2,,TYPVLC] +TYPVEC==TVOFF-1 + +ADDTV TVEC,[-2*NUMPRI-2,,TYPVLC] +TYPBOT==TVOFF-1 ; POINT TO CURRENT TOP OF TYPE VECTORS + +;ENTRY FOR ROOT,TTICHN,TTOCHN + +ADDTV TCHAN,0 +TTICHN==TVOFF-1 + +ADDTV TCHAN,0 +TTOCHN==TVOFF-1 + +ADDTV TOBLS,0 +ROOT==TVOFF-1 +ADDTV TOBLS,0 +INITIA==TVOFF-1 +ADDTV TOBLS,0 +INTOBL==TVOFF-1 +ADDTV TOBLS,0 +ERROBL==TVOFF-1 +ADDTV TOBLS,0 +MUDOBL==TVOFF-1 +ADDTV TVEC,0 +GRAPHS==TVOFF-1 +ADDTV TFIX,0 +INTNUM==TVOFF-1 +ADDTV TVEC,[-2*NINT,,INTVCL] +INTVEC==TVOFF-1 +ADDTV TUVEC,[-NASOCS,,ASOVCL] +ASOVEC==TVOFF-1 + +ADDTV TLIST,0 +CHNL0"==TVOFF-1 ;LIST FOR CURRENTLY OPEN PSUEDO CHANNELS + +IFN ITS,[ +DEFINE ADDCHN N + ADDTV TCHAN,0 + CHNL!N==TVOFF-1 + .GLOBAL CHNL!N + TERMIN + +REPEAT 15.,ADDCHN \.RPCNT+1 + +DEFINE ADDIPC N + ADDTV TLIST,0 + IPCS!N==TVOFF-1 + .GLOBAL IPCS!N + TERMIN + +REPEAT 15.,ADDIPC \.RPCNT+1 +] + +IFE ITS,[ +ADDTV TCHAN,0 +CHNL1==TVOFF-1 +.GLOBAL CHNL1 +REPEAT N.CHNS-1,[ADDTV TCHAN,0 +] +] + +ADDTV TASOC,[-ASOLNT,,NODLST] +NODES==TVOFF-1 + +ADDTV TASOC,[-ASOLNT,,NODDUM] +DUMNOD==TVOFF-1 + +ADDTV TVEC,0 +EVATYP==TVOFF-1 + +ADDTV TVEC,0 +APLTYP==TVOFF-1 + +ADDTV TVEC,0 +PRNTYP==TVOFF-1 + +; SLOTS ASSOCIATED WITH TEMPLATE DATA STRUCTURES + +ADDTV TUVEC,0 +TD.GET==TVOFF-1 + +ADDTV TUVEC,0 +TD.PUT==TVOFF-1 + +ADDTV TUVEC,0 +TD.LNT==TVOFF-1 + +ADDTV TUVEC,0 +TD.PTY==TVOFF-1 + + + +;GLOBAL SPECIAL PDL + +GSP: BLOCK GSPLNT + GENERAL + GSPLNT+2,,0 + +ADDTV TVEC,[-GSPLNT,,GSP] +GLOBASE==TVOFF-1 +GLOB==.-2 +ADDTV TVEC,GLOB +GLOBSP==TVOFF-1 ;ENTRY FOR CURRENT POINTER TO GLOBAL SP + +; POINTER VECTOR TO PURE SHARED RSUBRS + +PURV: BLOCK 3*20. ; ENOUGH FOR 20 SUCH (INITIALLY) + 0 + 3*20.+2,,0 + +ADDTV TUVEC,[-3*20.,,PURV] +PURVEC==TVOFF-1 + +ADDTV TLIST,0 +STOLST==TVOFF-1 + +;PROCESS VECTOR FOR GARBAGE COLLECTOR PROCESS + +GCPVP: BLOCK PVLNT*2 + GENERAL + PVLNT*2+2,,0 + + +VECRET + +PURE + +;INITIAL PROCESS VECTOR + +PVBASE": BLOCK PVLNT*2 + GENERAL + PVLNT*2+2,,0 +PVLOC==PVBASE + + +;ENTRY FOR PROCESS I.D. + + ADDPV TFIX,1,PROCID +;THE FOLLOWING IRP MAKES SPACE FO9 SAVED ACS + +ZZZ==. + +IRP A,,[0,A,B,C,D,E,PVP,TVP,AB,TB,TP,SP,M,R,P]B,,[0 +0,0,0,0,0,TPVP,TTVP,TAB,TTB,TTP,TSP,TCODE,TRSUBR,TPDL] + +LOC PVLOC+2*A +A!STO==.-PVBASE +B,,0 +0 +TERMIN + +PVLOC==PVLOC+16.*2 +LOC ZZZ + + +ADDPV TTB,0,TBINIT +ADDPV TTP,0,TPBASE +ADDPV TSP,0,SPBASE +ADDPV TPDL,0,PBASE +ADDPV 0,0,RESFUN +ADDPV TLIST,0,.BLOCK +ADDPV TLIST,0,MESS +ADDPV TACT,0,FACTI +ADDPV TPVP,0,LSTRES +ADDPV TFIX,0,BINDID +ADDPV TFIX,1,PSTAT +ADDPV TPVP,0,1STEPR +ADDPV TSP,0,CURFCN + + +IMPURE + +END + \ No newline at end of file diff --git a/sumex/tty.muddle b/sumex/tty.muddle new file mode 100644 index 0000000..dceb10a --- /dev/null +++ b/sumex/tty.muddle @@ -0,0 +1,42 @@ +<PACKAGE "TTY"> ;"TENEX VERSION" + +<ENTRY TTY-SET TTY-GET TTY-ON TTY-OFF> + +<SETG CALICO-MOD #WORD *700000*> ;"wakeup on all but alpha, no echo" +MUDDLE-MOD ;"gunnasigned initially" + +<GDECL (CALICO-MOD MUDDLE-MOD) WORD> + +<TITLE TTY-GET> +<PSEUDO <SET SFMOD #OPCODE *104000000110*>> ;"JSYS 110" +<PSEUDO <SET RFMOD #OPCODE *104000000107*>> ;"JSYS 107" +<DECLARE ("VALUE" WORD)> +<HRRZI A* -1> ;"controlling tty file desig" +<RFMOD> +<MOVSI A* TWORD> +<JRST FINIS> + +<TITLE TTY-SET> +<DECLARE ("VALUE" WORD <PRIMTYPE WORD>)> +<HRRZI A* -1> +<MOVE B* 1 (AB)> +<SFMOD> +<MOVE A* (AB)> +<MOVE B* 1 (AB)> +<JRST FINIS> + +<END> + +<DEFINE TTY-OFF () +<COND (<NOT <GASSIGNED? MUDDLE-MOD>> + <SETG MUDDLE-MOD <TTY-GET>>)> + <TTY-SET ,CALICO-MOD>> + +<DEFINE TTY-ON () +<COND (<NOT <GASSIGNED? MUDDLE-MOD>> + <SETG MUDDLE-MOD <TTY-GET>>) + (<TTY-SET ,MUDDLE-MOD>)>> + + +<ENDPACKAGE> + \ No newline at end of file diff --git a/sumex/uuoh.mcr0072 b/sumex/uuoh.mcr0072 new file mode 100644 index 0000000..c5a097f --- /dev/null +++ b/sumex/uuoh.mcr0072 @@ -0,0 +1,465 @@ +TITLE UUO HANDLER FOR MUDDLE AND HYDRA +RELOCATABLE +.INSRT MUDDLE > + +;GLOBALS FOR THIS PROGRAM + +.GLOBAL BACKTR,PRINT,PDLBUF,TPGROW,SPECSTO,TIMOUT,AGC,VECBOT,VECTOP +.GLOBAL BCKTRK,TPOVFL,.MONWR,.MONRD,.MONEX,MAKACT,IGVAL,ILVAL,BFRAME +.GLOBAL PURTOP,PURBOT,PLOAD,PURVEC,STOSTR,MSGTYP,UUOH,ILLUUO + +;SETUP UUO DISPATCH TABLE HERE + +UUOTBL: ILLUUO + +IRP UUOS,,[[DP,DODP],[.MCALL,DMCALL],[.ACALL,DACALL],[.ECALL,DECALL],[.FATAL,DFATAL]] +UUFOO==.IRPCNT+1 +IRP UUO,DISP,[UUOS] +.GLOBAL UUO +UUO=UUFOO_33 +DISP +.ISTOP +TERMIN +TERMIN + +REPEAT 100-UUFOO,[ILLUUO +] + + +RMT [ +IMPURE + +UUOH: +LOC 41 + JSR UUOH +LOC UUOH + 0 + JRST UUOPUR ;GO TO PURE CODE FOR THIS + +SAVEC: 0 ; USED TO SAVE WORKING AC +NOLINK: 0 + +PURE +] + +;SEPARATION OF PURE FROM IMPURE CODE HERE + +UUOPUR: MOVEM C,SAVEC ; SAVE AC + LDB C,[330900,,40] + JRST @UUOTBL(C) ;DISPATCH BASED ON THE UUO + + + +ILLUUO: FATAL ILLEGAL UUO + ;CALL HANDLER + +MQUOTE CALLER +CALLER: + +DMCALL": + MOVEI D,0 ; FLAG NOT ENTRY CALL + LDB C,[270400,,40] ; GET AC FIELD OF UUO +COMCAL: LSH C,1 ; TIMES 2 + MOVN AB,C ; GET NEGATED # OF ARGS + HRLI C,(C) ; TO BOTH SIDES + SUBM TP,C ; NOW HAVE TP TO SAVE + MOVEM C,TPSAV(TB) ; SAVE IT + MOVSI AB,(AB) ; BUILD THE AB POINTER + HRRI AB,1(C) ; POINT TO ARGS + HRRZ C,UUOH ; GET PC OF CALL + CAMG C,PURTOP ; SKIP IF NOT IN GC SPACE + CAIGE C,STOSTR ; SKIP IF IN GC SPACE + JRST .+3 + SUBI C,(M) ; RELATIVIZE THE PC + HRLI C,M ; FOR RETURNER TO WIN + MOVEM C,PCSAV(TB) + MOVEM SP,SPSAV(TB) ; SAVE BINDING GOODIE + MOVSI C,TENTRY ; SET UP ENTRY WORD + HRR C,40 ; POINT TO CALLED SR + ADD TP,[FRAMLN,,FRAMLN] ; ALLOCATE NEW FRAME + JUMPGE TP,TPLOSE +CALDON: MOVEM C,FSAV+1(TP) ; CLOBBER THE FRAME + MOVEM TB,OTBSAV+1(TP) + MOVEM AB,ABSAV+1(TP) ; FRAME BUILT + MOVEM P,PSAV(TB) + HRRI TB,(TP) ; SETUP NEW TB + MOVEI C,(C) + MOVEI M,0 ; UNSETUP M FOR GC WINNAGE + CAMG C,VECTOP ; SKIP IF NOT RSUBR + CAMGE C,VECBOT ; SKIP IF RSUBR + JRST CALLS + GETYP A,(C) ; GET CONTENTS OF SLOT + JUMPN D,EVCALL ; EVAL CALLING ENTRY ? + CAIE A,TRSUBR ; RSUBR CALLING RSUBR ? + JRST RCHECK ; NO + MOVE R,(C)+1 ; YES, SETUP R +CALLR0: HRRM R,FSAV+1(TB) ; FIXUP THE PROPER FSAV +CALLR1: AOS E,2(R) ; COUNT THE CALLS + TRNN E,-1 ; SKIP IF OK + JRST COUNT1 + + SKIPL M,(R)+1 ; SETUP M + JRST SETUPM ; JUMP IF A PURE RSUBR IN QUESTION + AOBJP TB,.+1 ; GO TO CALLED RSUBR + INTGO ; CHECK FOR INTERRUPTS + JRST (M) + +COUNT1: SOS 2(R) ; UNDO OVERFLOW + HLLZS 2(R) + JRST CALLR1 + +CALLS: AOBJP TB,.+1 ; GO TO CALLED SUBR + INTGO ; CHECK FOR INTERRUPTS + JRST @C + +; HERE TO HANDLE A PURE RSUBR (LOAD IF PUNTED OR OTHERWISE FLUSHED) + +SETUPM: MOVEI C,0 ; OFFSET (FOR MAIN ENTRIES) +STUPM1: MOVEI D,(M) ; GET OFFSET INTO CODE + HLRS M ; GET VECTOR OFFSET IN BOTH HALVES + ADD M,PURVEC+1(TVP) ; GET IT + SKIPL M + FATAL LOSING PURE RSUBR POINTER + HLLM TB,2(M) ; MARK FOR LRU ALGORITHM + SKIPN M,1(M) ; POINT TO CORE IF LOADED + AOJA TB,STUPM2 ; GO LOAD IT +STUPM3: ADDI M,(D) ; POINT TO REAL THING + HRLI C,M ; POINT TO START PC + AOBJP TB,.+1 + INTGO + JRST @C ; GO TO IT + +STUPM2: HLRZ A,1(R) ; SET UP TO CALL LOADER + PUSH P,D + PUSH P,C + PUSHJ P,PLOAD ; LOAD IT + JRST PCANT1 + POP P,C + POP P,D + MOVE M,B ; GET LOCATION + SOJA TB,STUPM3 + +RCHECK: CAIN A,TPCODE ; PURE RSUBR? + JRST .+3 + CAIE A,TCODE ; EVALUATOR CALLING RSUBR ? + JRST SCHECK ; NO + MOVS R,(C) ; YES, SETUP R + HRRI R,(C) + JRST CALLR1 ; GO FINISH THE RSUBR CALL + + +SCHECK: CAIE A,TSUBR ; RSUBR CALLING SUBR AS REFERENCE ? + CAIN A,TFSUBR + SKIPA C,(C)+1 ; SKIP AND GET ROUTINE'S ADDRESS + JRST ECHECK + HRRM C,FSAV+1(TB) ; FIXUP THE PROPER FSAV + JRST CALLS ; GO FINISH THE SUBR CALL + +ECHECK: CAIE A,TENTER ; SKIP IF SUB ENTRY OF RSUBR + JRST ACHECK ; COULD BE EVAL CALLING ONE + MOVE C,1(C) ; POINT TO SUB ENTRY BLOCK +ECHCK3: GETYP A,(C) ; SEE IF LINKED TO ITS MAIN ENTRY + MOVE B,1(C) + CAIN A,TRSUBR + JRST ECHCK2 + +; CHECK IF CAN LINK ATOM + + CAIE A,TATOM + JRST BENTRY ; LOSER , COMPLAIN +ECHCK4: MOVE B,1(C) ; GET ATOM + PUSH TP,$TVEC + PUSH TP,C + PUSHJ P,IGVAL ; TRY GLOBAL VALUE + MOVE C,(TP) + SUB TP,[2,,2] + CAMN A,$TUNBOU + JRST BADVAL + CAME A,$TRSUBR ; IS IT A WINNER + JRST BENTRY + SKIPE NOLINK + JRST ECHCK2 + HLLM A,(C) ; FIXUP LINKAGE + MOVEM B,1(C) + JRST ECHCK2 + +EVCALL: CAIN A,TATOM ; EVAL CALLING ENTRY? + JRST ECHCK4 ; COULD BE MUST FIXUP + CAIE A,TRSUBR ; YES THIS IS ONE + JRST BENTRY + MOVE B,1(C) +ECHCK2: MOVE R,B ; SET UP R + HRRM C,FSAV+1(TB) ; SET POINTER INTO FRAME + HRRZ C,2(C) ; FIND OFFSET INTO SAME + SKIPL M,1(R) ; POINT TO START OF RSUBR + JRST STUPM1 ; JUMP IF A LOSER + HRLI C,M + JRST CALLS ; GO TO SR + +ACHECK: CAIE A,TATOM ; RSUBR CALLING THROUGH REFERENCE ATOM ? + JRST DOAPP3 ; TRY APPLYING IT + MOVE A,(C) + MOVE B,(C)+1 + PUSHJ P,IGVAL + HRRZ C,40 ; REGOBBLE POINTER TO SLOT + GETYP 0,A ; GET TYPE + CAIN 0,TUNBOUND + JRST TRYLCL +SAVEIT: CAIE 0,TRSUBR + CAIN 0,TENTER + JRST SAVEI1 ; WINNER + CAIE 0,TSUBR + CAIN 0,TFSUBR + JRST SUBRIT + JRST BADVAL ; SOMETHING STRANGE +SAVEI1: SKIPE NOLINK + JRST .+3 + MOVEM A,(C) ; CLOBBER NEW VALUE + MOVEM B,(C)+1 + CAIN 0,TENTER + JRST ENTRIT ; HACK ENTRY TO SUB RSUBR + MOVE R,B ; SETUP R + JRST CALLR0 ; GO FINISH THE RSUBR CALL + +ENTRIT: MOVE C,B + JRST ECHCK3 + +SUBRIT: SKIPE NOLINK + JRST .+3 + MOVEM A,(C) + MOVEM B,1(C) + HRRM B,FSAV+1(TB) ; FIXUP THE PROPER FSAV + MOVEI C,(B) + JRST CALLS ; GO FINISH THE SUBR CALL + +TRYLCL: MOVE A,(C) + MOVE B,(C)+1 + PUSHJ P,ILVAL + GETYP 0,A + CAIE 0,TUNBOUND + JRST SAVEIT + SKIPA D,EQUOTE UNBOUND-VARIABLE +BADVAL: MOVEI D,0 +ERCAL: AOBJP TB,.+1 ; MAKE TB A LIGIT FRAME PNTR + MOVEI E,CALLER + HRRM E,FSAV(TB) ; SET A WINNING FSAV + HRRZ C,40 ; REGOBBLE POINTER TO SLOT + JUMPE D,DOAPPL + SUBI C,(R) ; CALCULATE OFFSET + HRLS C + ADD C,R ; MAKE INTO REAL RSUBR POINTER + PUSH TP,$TRSUBR ; SAVE + PUSH TP,C + HRRZ C,40 ; REGOBBLE POINTER TO SLOT + PUSH TP,$TATOM + PUSH TP,D + PUSH TP,(C) + PUSH TP,(C)+1 + PUSH TP,$TATOM + PUSH TP,MQUOTE CALLER + MCALL 3,ERROR + MOVE C,(TP) ; GET SAVED RSUBR POINTER + SUB TP,[2,,2] ; POP STACK + GETYP 0,A + HRRM C,40 + SOJA TB,SAVEIT + +BENTRY: MOVE D,EQUOTE BAD-ENTRY-BLOCK + JRST ERCAL + +;HANDLER FOR CALL WHERE SPECIFIES NUMBER OF ARGS + +DACALL": + LDB C,[270400,,40] ; GOBBLE THE AC LOCN INTO C + EXCH C,SAVEC ; C TO SAVE LOC RESTORE C + MOVE C,@SAVEC ; C NOW HAS NUMBER OF ARGS + MOVEI D,0 ; FLAG NOT E CALL + JRST COMCAL ; JOIN MCALL + +; CALL TO ENTRY FROM EVAL (LIKE ACALL) + +DECALL: LDB C,[270400,,40] ; GET NAME OF AC + EXCH C,SAVEC ; STORE NAME + MOVE C,@SAVEC ; C NOW HAS NUM OF ARGS + MOVEI D,1 ; FLAG THIS + JRST COMCAL + +;HANDLE OVERFLOW IN THE TP + +TPLOSE: PUSHJ P,TPOVFL + JRST CALDON + +; RSUBR HAS POSSIBLY BEEN REPLACED BY A FUNCTION OR WHATEVER, DO AN APPLY + +DOAPPL: PUSH TP,A ; PUSH THE THING TO APPLY + PUSH TP,B + MOVEI A,1 +DOAPP2: JUMPGE AB,DOAPP1 ; ARGS DONE + + PUSH TP,(AB) + PUSH TP,1(AB) + ADD AB,[2,,2] + AOJA A,DOAPP2 + +DOAPP1: ACALL A,APPLY ; APPLY THE LOSER + JRST FINIS + +DOAPP3: MOVE A,(C) ; GET VAL + MOVE B,1(C) + JRST BADVAL ; GET SETUP FOR APPLY CALL + +; ENTRY TO BUILD A FRAME (USED BY SOME COMPILED PROG/REPEAT) + +BFRAME: HRLI A,M ; RELATIVIZE PC + MOVEM A,PCSAV(TB) ; CLOBBER PC IN + MOVEM TP,TPSAV(TB) ; SAVE STATE + MOVEM SP,SPSAV(TB) + ADD TP,[FRAMLN,,FRAMLN] + SKIPL TP + PUSHJ TPOVFL ; HACK BLOWN PDL + MOVSI A,TCBLK ; FUNNY FRAME + HRRI A,(R) + MOVEM A,FSAV+1(TP) ; CLOBBER + MOVEM TB,OTBSAV+1(TP) + MOVEM AB,ABSAV+1(TP) + POP P,A ; RET ADDR TO A + MOVEM P,PSAV(TB) + HRRI TB,(TP) + AOBJN TB,.+1 + JRST (A) + ;SUBROUTINE TERMINATION CODE (NOT A UUO BUT HERE FOR COMPLETENENSS) + +FINIS: +CNTIN1: HRRZS C,OTBSAV(TB) ; RESTORE BASE + HRRI TB,(C) +CONTIN: MOVE TP,TPSAV(TB) ; START HERE FOR FUNNY RESTART + MOVE P,PSAV(TB) + CAME SP,SPSAV(TB) ; ANY RESTORATION NEEDED + PUSHJ P,SPECSTO ; YES, GO UNRAVEL THE WORLDS BINDINGS + MOVE AB,ABSAV(TB) ; AND GET OLD ARG POINTER + HRRZ C,FSAV(TB) ; CHECK FOR RSUBR + MOVEI M,0 ; UNSETUP M FOR GC WINNAGE + CAMG C,VECTOP + CAMGE C,VECBOT + JRST @PCSAV(TB) ; AND RETURN + GETYP 0,(C) ; RETURN TO MAIN OR SUB ENTRY? + CAIN 0,TCODE + JRST .+3 + CAIE 0,TPCODE + JRST FINIS1 + MOVS R,(C) + HRRI R,(C) ; RESET R + SKIPGE M,1(R) ; GET LOC OF REAL SUBR + JRST @PCSAV(TB) + JRST FINIS2 + +FINIS1: CAIE 0,TRSUBR + JRST FINISA ; MAY HAVE BEEN PUT BACK TO ATOM + MOVE R,1(C) + SKIPGE M,1(R) + JRST @PCSAV(TB) + +FINIS2: MOVEI C,(M) ; COMPUTE REAL M FOR PURE RSUBR + HLRS M + ADD M,PURVEC+1(TVP) + SKIPN M,1(M) ; SKIP IF LOADED + JRST FINIS3 + ADDI M,(C) ; POINT TO SUB PART + JRST @PCSAV(TB) + +FINIS3: PUSH TP,A + PUSH TP,B + HLRZ A,1(R) ; RELOAD IT + PUSHJ P,PLOAD + JRST PCANT + POP TP,B + POP TP,A + MOVE M,1(R) + JRST FINIS2 + +FINISA: CAIE 0,TATOM + JRST BADENT + PUSH TP,A + PUSH TP,B + PUSH TP,$TENTER + HRL C,(C) + PUSH TP,C + MOVE B,1(C) ; GET ATOM + PUSHJ P,IGVAL ; GET VAL + GETYP 0,A + CAIE 0,TRSUBR + JRST BADENT + MOVE C,(TP) + HLLM A,(C) + MOVEM B,1(C) + MOVE A,-3(TP) + MOVE B,-2(TP) + SUB TP,[4,,4] + JRST FINIS1 + +BADENT: PUSH TP,$TATOM + PUSH TP,EQUOTE RSUBR-ENTRY-UNLINKED + JRST CALER1 + +PCANT1: ADD TB,[1,,] +PCANT: PUSH TP,$TATOM + PUSH TP,EQUOTE PURE-LOAD-FAILURE + JRST CALER1 + +REPEAT 0,[ +BCKTR1: PUSH TP,A ; SAVE VALUE TO BE RETURNED + PUSH TP,B ; SAVE FRAME ON PP + PUSHJ P,BCKTRK + POP TP,B + POP TP,A + JRST CNTIN1 +] + +; SUBR TO ENABLE AND DISABLE LINKING OF RSUBRS AT RUN TIME + +MFUNCTION %RLINK,SUBR,[RSUBR-LINK] + + ENTRY 1 + + GETYP 0,(AB) + SETZM NOLINK + CAIN 0,TFALSE + SETOM NOLINK + MOVE A,(AB) + MOVE B,1(AB) + JRST FINIS + +;HANDLER FOR DEBUGGING CALL TO PRINT + +DODP": + PUSH TP, @40 + AOS 40 + PUSH TP,@40 + PUSH P,0 + PUSH P,1 + PUSH P,2 + PUSH P,SAVEC + PUSH P,4 + PUSH P,5 + PUSH P,40 + PUSH P,UUOH + MCALL 1,PRINT + POP P,UUOH + POP P,40 + POP P,5 + POP P,4 + POP P,3 + POP P,2 + POP P,1 + POP P,0 + JRST 2,@UUOH + + +DFATAL: MOVEM A,20 + MOVEM B,21 + MOVE B,40 + HRLI B,440700 + PUSHJ P,MSGTYP + JRST 4,. +END +  \ No newline at end of file