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