TITLE STRBUILD MUDDLE STRUCTURE BUILDER .GLOBAL RCL,VECTOP,GCSTOP,GCSBOT,FRETOP,GCSNEW,VECBOT,PARTOP,PARBOT,HITOP,HIBOT,GETPAG .GLOBAL PDLBUF,PDLEX,PDLEXP,GCFLG,GCPDL,GETNUM,PARNEW,MOVPUR,RCLV,RCLVEC .GLOBAL PGROW,TPGROW,MAINPR,%SLEEP,MSGTYP,PURTOP,PURBOT,STOSTR,RBLDM,CPOPJ,CPOPJ1,STBL .GLOBAL MTYI,UPLO,FRMUNG,BYTDOP,GLOBSP,FREDIF,FREMIN,GCHAPN,INTFLG,PINIT,CKPUR,GCSET .GLOBAL SAT,TTOCHN,TYPVEC,ICONS,INCONS,IBLOCK,IEUVEC,IEVECTI,CELL2,MKTBS,CPOPJ1,.LIST. .GLOBAL GIBLOK,REHASH,IBLOK1,IILIST,IIFORM,CIVEC,CIUVEC,CICONS,SLEEPR,GCHK10,FPAG .GLOBAL SPBASE,OUTRNG,CISTNG,CBYTES,%RUNAM,PURVEC,GCDOWN,N.CHNS,CHNL1,PLODR,C1CONS .GLOBAL CAFRE,CAFRET,STOGC,GCHN,WNDP,FRNP,FRONT,%GCJOB,%SHWND,%INFMP,%GETIP .GLOBAL TD.PUT,TD.GET,TD.LNT,GLOTOP,UBIT,FLGSET,PURMNG,RPURBT,%IFMP2,CHKPGI,PURCLN .GLOBAL CTIME,MTYO,ILOC,NODES,GPURFL,GCDANG,GCHACK,LPUR,HITOP,BADCHN,IMPURX .GLOBAL NOWLVL,CURPLN,PVSTOR,SPSTOR,MPOPJ,NGCS,RNUMSP,NUMSWP,SAGC,INQAGC .GLOBAL GCTIM,GCCAUS,GCCALL,AAGC,LVLINC,STORIC,GVLINC,TYPIC,GCRSET,ACCESS,NOSHUF,SQUPNT ; GLOBALS ASSOCIATE WITH THE ASSOCIATION VECTOR .GLOBAL ASOVEC,ASOLNT,ITEM,INDIC,VAL,NWORDT,NODPNT,PNTRS .GLOBAL CELL,BINDID,GCFLCH,TYPBOT,GLOBAS,TPBASE .GLOBAL TPBINC,GBLINC,TYPINC,CONADJ,OGCSTP,ABOTN .GLOBAL AGC,ROOT,CIGTPR,IIGLOC .GLOBAL P.TOP,P.CORE,PMAPB .GLOBAL %MPINT,%GBINT,%CLSMP,%CLSM1 .GLOBAL GCKNUM,CORTOP,GCHPN,INTAGC,WNDP,WNDBOT,BUFGC,WIND,GCDFLG,SAVM ; SHARED SYMBOLS WITH GC MODULE .GLOBAL GCNO,BSTGC,BSTAT,NOWFRE,CURFRE,MAXFRE,USEFRE,NOWTP,CURTP,CTPMX,NOWLFL .GLOBAL CURLVL,NOWGVL,CURGVL,NOWTYP,CURTYP,NOWSTO,CURSTO,CURMAX,NOWP,CURP,CPMX .GLOBAL GCCAUS,GCCALL,LVLINC,GVLINC,TYPIC,STORIC,RCL,RCLV,GCDANG,GETNUM,RPTOP,CORTOP .GLOBAL TPGROW,PPGROW,PGROW,PMAIN,PGOOD,PMAX,TPGOOD,TPMIN,TPMAX,RFRETP,TYPTAB .GLOBAL NNPRI,NNSAT,TYPSAV,BUFGC,GCTIM,GPURFL,GCDFLG,DUMFLG,PMIN,PURMIN .GLOBAL GLBINC,GCHAIR,GCMONF,SQKIL,INBLOT .GLOBAL C%11,C%22,C%33,C%44,C%55,C%66,C%0,C%1,C%2,C%3,C%M1,C%M2,C%M10 .GLOBAL C%M20,C%M30,C%M40,C%M60 NOPAGS==1 ; NUMBER OF WINDOWS EOFBIT==1000 PDLBUF=100 .ATOM.==200000 ; FLAG SAYING ATOMS MARKED (FOR VAL FLUSH LOGIC) GCHN==0 ; CHANNEL FOR FUNNNY INFERIOR STATNO==19. ; # OF STATISTICS FOR BLOAT-STAT STATGC==8. ; # OF GC-STATISTICS FOR BLOAT-STAT RELOCATABLE .INSRT MUDDLE > SYSQ IFE ITS,[ .INSRT STENEX > ] IFN ITS, PGSZ==10. IFE ITS, PGSZ==9. ; GC-READ TAKES ONE ARGUMENT WHICH MUST BE A "READB" CHANNEL .GLOBAL CLOOKU,CINSER,MOBLIST,CATOM,EOFCND,IGLOC MFUNCTION GCREAD,SUBR,[GC-READ] ENTRY CAML AB,C%M2 ; CHECK # OF ARGS JRST TFA CAMGE AB,C%M40 JRST TMA GETYP A,(AB) ; MAKE SURE ARG IS A CHANNEL CAIE A,TCHAN JRST WTYP2 ; IT ISN'T COMPLAIN MOVE B,1(AB) ; GET PTR TO CHANNEL HRRZ C,-2(B) ; LOOK AT BITS IN CHANNEL TRC C,C.OPN+C.READ+C.BIN TRNE C,C.OPN+C.READ+C.BIN JRST BADCHN PUSH P,1(B) ; SAVE ITS CHANNEL # IFN ITS,[ MOVE B,[-2,,C] ; SET UP AOBJN PTR TO READ IN DELIMITING ; CONSTANTS MOVE A,(P) ; GET CHANNEL # DOTCAL IOT,[A,B] FATAL GCREAD-- IOT FAILED JUMPL B,EOFGC ; IF BLOCK DIDN'T FINISH THEN EOF ] IFE ITS,[ MOVE A,(P) ; GET CHANNEL BIN MOVE C,B ; TO C BIN MOVE D,B ; TO D GTSTS ; SEE IF EOF TLNE B,EOFBIT JRST EOFGC ] PUSH P,C ; SAVE AC'S PUSH P,D IFN ITS,[ MOVE B,[-3,,C] ; NEXT GROUP OF WORDS DOTCAL IOT,[A,B] FATAL GCREAD--GC IOT FAILED ] IFE ITS,[ MOVE A,-2(P) ; GET CHANNEL BIN MOVE C,B BIN MOVE D,B BIN MOVE E,B ] MOVEI 0,0 ; DO PRELIMINARY TESTS IOR 0,A ; IOR ALL WORDS IN IOR 0,B IOR 0,C IOR 0,(P) IOR 0,-1(P) TLNE 0,-1 ; SKIP IF NO BITS IN LEFT HALF JRST ERDGC MOVEM D,NNPRI MOVEM E,NNSAT MOVE D,C ; GET START OF NEWTYPE TABLE SUB D,-1(P) ; CREATE AOBJN POINTER HRLZS D ADDI D,(C) MOVEM D,TYPTAB ; SAVE IT MOVE A,(P) ; GET LENGTH OF WORD SUBI A,CONADJ ; SUBTRACT FOR CONSTANTS ADD A,GCSTOP CAMG A,FRETOP ; SEE IF GC IS NESESSARY JRST RDGC1 MOVE C,(P) ADDM C,GETNUM ; MOVE IN REQUEST MOVE C,[0,,1] ; ARGS TO GC PUSHJ P,INQAGC ; GC RDGC1: MOVE C,GCSTOP ; GET CURRENT TOP OF THE WORLD MOVEM C,OGCSTP ; SAVE IT ADD C,(P) ; CALCULATE NEW GCSTOP ADDI C,2 ; SUBTRACT FOR CONSTANTS MOVEM C,GCSTOP SUB C,OGCSTP SUBI C,2 ; SUBSTRACT TO GET RID OF D.W'S MOVNS C ; SET UP AOBJN PTR FOR READIN IFN ITS,[ HRLZS C MOVE A,-2(P) ; GET CHANNEL # ADD C,OGCSTP DOTCAL IOT,[A,C] FATAL GCREAD-- IOT FAILED ] IFE ITS,[ MOVE A,-2(P) ; CHANNEL TO A MOVE B,OGCSTP ; SET UP BYTE POINTER HRLI B,444400 SIN ; IN IT COMES ] MOVE C,(P) ; GET LENGHT OF OBJECT ADDI A,5 MOVE B,1(AB) ; GET CHANNEL ADDM C,ACCESS(B) MOVE D,GCSTOP ; SET UP TO LOOK LIKE UVECTOR OF LOSES ADDI C,2 ; ADD 2 FOR DOPE WORDS HRLM C,-1(D) MOVSI A,.VECT. SETZM -2(D) IORM A,-2(D) ; MARK VECTOR BIT PUSH TP,$TRDTB ; HOLD ON IN CASE OF GC MOVEI A,-2(D) MOVN C,(P) ADD A,C HRL A,C PUSH TP,A MOVE D,-1(P) ; SET UP BOTTOM OF ATOM TABLE SUBI D,1 MOVEM D,ABOTN MOVE C,GCSTOP ; START AT TOP OF WORLD SUBI C,3 ; POINT TO FIRST ATOM ; LOOP TO FIX UP THE ATOMS AFXLP: HRRZ 0,1(TB) ADD 0,ABOTN CAMG C,0 ; SEE IF WE ARE DONE JRST SWEEIN HRRZ 0,1(TB) SUB C,0 PUSHJ P,ATFXU ; FIX IT UP HLRZ A,(C) ; GET LENGTH TRZ A,400000 ; TURN OFF MARK BIT SUBI C,(A) ; POINT TO PRECEDING ATOM HRRZS C ; CLEAR OFF NEGATIVE JRST AFXLP ; FIXUP ROUTINE FOR ATOMS (C==> D.W.) ATFXU: PUSH P,C ; SAVE PTR TO D.W. ADD C,1(TB) MOVE A,C HLRZ B,(A) ; GET LENGTH AND MARKING TRZE B,400000 ; TURN OF MARK BIT AND SKIP IF WAS ALREADY MARKED JRST ATFXU1 MOVEI D,-3(B) ; FULL WORDS OF STRING IN PNAME IMULI D,5 ; CALCULATE # OF CHARACTERS MOVE 0,-2(A) ; GET LAST WORD OF STRING SUBI A,-1(B) ; LET A POINT TO OBLIST SLOAT MOVE B,A ; GET COPY OF A MOVE A,0 SUBI A,1 ANDCM 0,A JFFO 0,.+1 HRREI 0,-34.(A) IDIVI 0,7 ; # OF CHARS IN LAST WORD ADD D,0 ADD D,$TCHSTR ; MAKE IT LOOK LIKE A STRINGS TYPE-WORD PUSH P,D ; SAVE IT MOVE C,(B) ; GET OBLIST SLOT PTR ATFXU9: HRRZS B ; RELATAVIZE POINTER HRRZ 0,1(TB) SUB B,0 PUSH P,B JUMPE C,ATFXU6 ; NO OBLIST. CREATE ATOM CAMN C,C%M1 ; SEE IF ROOT ATOM JRST RTFX ADD C,ABOTN ; POINT TO ATOM PUSHJ P,ATFXU PUSH TP,$TATOM PUSH TP,B MOVE A,$TATOM ; SET UP TO SEE IF OBLIST EXITS MOVE C,$TATOM MOVE D,IMQUOTE OBLIST PUSHJ P,CIGTPR JRST ATFXU8 ; NO OBLIST. CREATE ONE SUB TP,C%22 ; GET RID OF SAVED ATOM RTCON: PUSH TP,$TOBLS PUSH TP,B MOVE C,B ; SET UP FOR LOOKUP MOVE A,-1(P) ; SET UP PTR TO PNAME MOVE B,(P) ADD B,[440700,,1] ; ADJUST TO MAKE IT LOOK LIKE A BYTE-POINTER HRRZ 0,1(TB) ADD B,0 PUSHJ P,CLOOKU JRST ATFXU4 ; NOT ON IT SO INSERT ATFXU3: SUB P,C%22 ; DONE SUB TP,C%22 ; POP OFF OBLIST ATFXU7: MOVE C,(P) ; RESTORE PTR TO D.W. ADD C,1(TB) MOVEM B,-1(C) ; MOVE IN RELATAVIZE ADDRESS MOVSI D,400000 IORM D,(C) ; TURN OFF MARK BIT MOVE 0,3(B) ; SEE IF MUST BE LOCR TRNE 0,1 ; SKIP IF MUST MAKE IT IMPURE PUSHJ P,IIGLOC POP P,C ADD C,1(TB) POPJ P, ; EXIT ATFXU1: POP P,C ; RESTORE PTR TO D.W. ADD C,1(TB) MOVE B,-1(C) ; GET ATOM POPJ P, ; ROUTINE TO INSERT AN ATOM ATFXU4: MOVE C,(TP) ; GET OBLIST PTR MOVE B,(P) ; SET UP STRING PTR TO PNAME ADD B,[440700,,1] HRRZ 0,1(TB) ADD B,0 MOVE A,-1(P) ; GET TYPE WORD PUSHJ P,CINSER ; INSERT IT JRST ATFXU3 ; THIS ROUTINE CREATS THE ATOM SO THAT ITS NOT ON ANY OBLIST ATFXU6: MOVE B,(P) ; POINT TO PNAME ADD B,[440700,,1] ; MAKE IT LOOK LIKE A BYTE POINTER HRRZ 0,1(TB) ADD B,0 MOVE A,-1(P) PUSHJ P,CATOM SUB P,C%22 ; CLEAN OFF STACK JRST ATFXU7 ; THIS ROUTINE CREATES AND OBLIST ATFXU8: MCALL 1,MOBLIST PUSH TP,$TOBLS PUSH TP,B ; SAVE OBLIST PTR JRST ATFXU4 ; JUMP TO INSERT THE OBLIST ; HERE TO INSERT AN ATOM INTO THE ROOT OBLIST RTFX: MOVE B,ROOT+1 ; GET ROOT OBLIST JRST RTCON ; THIS ROUTINE SWEEPS THRU THE NEW CORE IMAGE AND UPDATES ALL THE POINTERS. SWEEIN: ; ROUTINE TO FIX UP TYPE-TABLE FOR GC-READ. THIS ROUTINE FIXES UP THE TYPE TABLE SO THAT ; THE TYPES ATOM I.D. IS REPLACED BY ITS TYPE-NUMBER IN THE NEW MUDDLE AND IF ITS A ; TEMPLATE, THE SLOT FOR THE PRIMTYPE-ATOM IS REPLACED BY THE SAT OF THE TEMPLATE HRRZ E,1(TB) ; SET UP TYPE TABLE ADD E,TYPTAB JUMPGE E,VUP ; SKIP OVER IF DONE TYPUP1: PUSH P,C%0 ; PUSH SLOT FOR POSSIBLE TEMPLATE ATOM HLRZ A,1(E) ; GET POSSIBLE ATOM SLOT JUMPE A,TYPUP2 ; JUMP IF NOT A TEMPLATE ADD A,ABOTN ; GET ATOM ADD A,1(TB) MOVE A,-1(A) MOVE B,TYPVEC+1 ; GET TYPE VECTOR SLOT FOR LOOP TO SEE IF ITS THERE TYPUP3: CAMN A,1(B) ; SKIP IF NOT EQUAL JRST TYPUP4 ; FOUND ONE ADD B,C%22 ; TO NEXT JUMPL B,TYPUP3 JRST ERTYP1 ; ERROR NONE EXISTS TYPUP4: HRRZ C,(B) ; GET SAT SLOT CAIG C,NUMSAT ; MAKE SURE TYPE IS A TEMPLATE JRST ERTYP2 ; IF NOT COMPLAIN HRLM C,1(E) ; SMASH IN NEW SAT MOVE B,1(B) ; GET ATOM OF PRIMTYPE MOVEM B,(P) ; PUSH ONTO STACK TYPUP2: MOVEI D,0 ; INITIALIZE TYPE COUNT FOR LOOKUP LOOP MOVE B,TYPVEC+1 ; GET PTR FOR LOOP HRRZ A,1(E) ; GET TYPE'S ATOM ID ADD A,ABOTN ; GET ATOM ADD A,1(TB) MOVE A,-1(A) TYPUP5: CAMN A,1(B) ; SKIP IF NOT EQUAL JRST TYPUP6 ; FOUND ONE ADDI D,1 ; INCREMENT TYPE-COUNT ADD B,C%22 ; POINT TO NEXT JUMPL B,TYPUP5 HRRM D,1(E) ; CLOBBER IN TYPE-NUMBER PUSH TP,$TATOM ; PUSH ARGS FOR NEWTYPE PUSH TP,A PUSH TP,$TATOM POP P,B ; GET BACK POSSIBLE PRIMTYPE ATOM JUMPE B,TYPUP7 ; JUMP IF NOT A TEMPLATE PUSH TP,B ; PUSH ON PRIMTYPE TYPUP9: SUB E,1(TB) PUSH P,E ; SAVE RELATAVIZED PTR TO TYPE-TABLE MCALL 2,NEWTYPE POP P,E ; RESTORE RELATAVIZED PTR ADD E,1(TB) ; FIX IT UP TYPUP0: ADD E,C%22 ; INCREMENT E JUMPL E,TYPUP1 JRST VUP TYPUP7: HRRZ B,(E) ; FIND PRIMTYPE FROM SAT MOVE A,@STBL(B) PUSH TP,A JRST TYPUP9 TYPUP6: HRRM D,1(E) ; CLOBBER IN TYPE # JRST TYPUP0 ERTYP1: ERRUUO EQUOTE CANT-FIND-TEMPLATE ERTYP2: ERRUUO EQUOTE TEMPLATE-TYPE-NAME-NOT-OF-TYPE-TEMPLATE VUP: HRRZ E,1(TB) ; FIX UP SOME POINTERS MOVEM E,OGCSTP ADDM E,ABOTN ADDM E,TYPTAB ; ROUTINE TO SWEEP THRU THE READ-IN IMAGE LOOKING FOR UVECTORS AND TEMPLATES. ; WHILE SWEEPING IT FIXES UP THE DOPE WORDS APPROPRIATELY. HRRZ A,TYPTAB ; GET TO TOP OF WORLD SUBI A,2 ; GET TO FIRST TYPE WORD OR DOPE-WORD OF FIRST OBJECT VUP1: CAMG A,OGCSTP ; SKIP IF NOT DONE JRST VUP3 HLRZ B,(A) ; GET TYPE SLOT TRNE B,.VECT. ; SKIP IF NOT A VECTOR JRST VUP2 SUBI A,2 ; SKIP OVER PAIR JRST VUP1 VUP2: TRNE B,400000 ; SKIP IF UVECTOR JRST VUP4 ANDI B,TYPMSK ; GET RID OF MONITORS CAMG B,NNPRI ; SKIP IF NEWTYPE JRST VUP5 PUSHJ P,GETNTP ; GET THE NEW TYPE # PUTYP B,(A) ; SMASH IT IT VUP5: HLRZ B,1(A) ; SKIP OVER VECTOR TRZ B,400000 ; GET RID OF POSSIBLE MARK BIT SUBI A,(B) JRST VUP1 ; LOOP VUP4: ANDI B,TYPMSK ; FLUSH MONITORS CAMG B,NNSAT ; SKIP IF TEMPLATE JRST VUP5 PUSHJ P,GETSAT ; CONVERT TO NEW SAT ADDI B,.VECT. ; MAJIC TO TURN ON BIT PUTYP B,(A) JRST VUP5 VUP3: PUSH P,GCSBOT ; SAVE CURRENT GCSBOT MOVE A,OGCSTP ; SET UP NEW GCSBOT MOVEM A,GCSBOT PUSH P,GCSTOP HRRZ A,TYPTAB ; SET UP NEW GCSTOP MOVEM A,GCSTOP SETOM GCDFLG MOVE A,[PUSHJ P,RDFIX] ; INS FOR GCHACK MOVEI PVP,0 ; SAY MIGHT BE NON-ATOMS PUSHJ P,GCHK10 SETZM GCDFLG POP P,GCSTOP ; RESTORE GCSTOP MOVE A,1(TB) ; GET A POINTER TO RETURNING VALUES MOVE B,A HLRE C,B SUB B,C SETZM (B) SETZM 1(B) POP P,GCSBOT ; RESTORE GCSBOT MOVE B,1(A) ; GET PTR TO OBJECTS MOVE A,(A) JRST FINIS ; EXIT ; ERROR FOR INCORRECT GCREAD FILE ERDGC: ERRUUO EQUOTE BAD-GC-READ-FILE ; ROUTINE CALLED BY GCHACK TO UPDATE PTRS IN THE NEW CORE IMAGE RDFIX: PUSH P,C ; SAVE C PUSH P,B ; SAVE PTR EXCH B,C TLNE C,UBIT ; SKIP IF NOT UVECTOR JRST ELEFX ; DON'T HACK TYPES IN UVECTOR CAIN B,TTYPEC JRST TYPCFX CAIN B,TTYPEW JRST TYPWFX CAML B,NNPRI JRST TYPGFX ELEFX: EXCH B,A ; EXCHANGE FOR SAT PUSHJ P,SAT EXCH B,A ; REFIX CAIE B,SLOCR ; REL GLOC'S ARE STORED AS ATOMS CAIN B,SATOM JRST ATFX CAIN B,SCHSTR JRST STFX CAIN B,S1WORD ; SEE IF PRIMTYPE WOR JRST RDLSTF ; LEAVE IF IS STFXX: MOVE 0,GCSBOT ; ADJUSTMENT SUBI 0,FPAG+5 SKIPE 1(C) ; DON'T CHANGE A PTR TO NIL ADDM 0,1(C) ; FIX UP RDLSTF: TLNN C,.LIST. ; SEE IF PAIR JRST RDL1 ; EXIT MOVE 0,GCSBOT ; FIX UP SUBI 0,FPAG+5 HRRZ B,(C) ; SEE IF POINTS TO NIL SKIPN B JRST RDL1 MOVE B,C ; GET ARG FOR RLISTQ PUSHJ P,RLISTQ JRST RDL1 ADDM 0,(C) RDL1: POP P,B ; RESTORE B POP P,C POPJ P, ; ROUTINE TO FIX UP PNAMES STFX: TLZN D,STATM JRST STFXX HLLM D,1(C) ; PUT BACK WITH BIT OFF ADD D,ABOTN ANDI D,-1 HLRE 0,-1(D) ; LENGTH OF ATOM MOVNS 0 SUBI 0,3 ; VAL & OBLIST IMULI 0,5 ; TO CHARS (SORT OF) HRRZ D,-1(D) ADDI D,2 PUSH P,A PUSH P,B LDB A,[360600,,1(C)] ; GET BYTE POS IDIVI A,7 ; TO CHAR POS SKIPE A SUBI A,5 HRRZ B,(C) ; STRING LENGTH SUB B,A ; TO WORD BOUNDARY STRING SUBI 0,(B) IDIVI 0,5 ADD D,0 POP P,B POP P,A HRRM D,1(C) JRST RDLSTF ; ROUTINE TO FIX UP POINTERS TO ATOMS ATFX: SKIPGE D JRST RDLSTF ADD D,ABOTN MOVE 0,-1(D) ; GET PTR TO ATOM CAIE B,SLOCR ; IF REL LOCATIVE, MORE HAIR JRST ATFXAT MOVE B,0 PUSH P,E PUSH P,D PUSH P,C PUSH P,B PUSH P,A PUSHJ P,IGLOC SUB B,GLOTOP+1 MOVE 0,B POP P,A POP P,B POP P,C POP P,D POP P,E ATFXAT: MOVEM 0,1(C) ; SMASH IT IN JRST RDLSTF ; EXIT TYPCFX: HRRZ B,1(C) ; GET TYPE PUSHJ P,GETNEW ; GET TYPE IN THIS CORE IMAGE HRRM B,1(C) ; CLOBBER IT IN JRST RDLSTF ; CONTINUE FIXUP TYPWFX: HLRZ B,1(C) ; GET TYPE PUSHJ P,GETNEW ; GET TYPE IN THIS CORE IMAGE HRLM B,1(C) ; SMASH IT IN JRST ELEFX TYPGFX: PUSH P,D PUSHJ P,GETNTP ; GET TYPE IN THIS CORE IMAGE POP P,D PUTYP B,(C) JRST ELEFX ; HERE TO HANDLE AN EOF IN GC-READ. IT USES OPTIONAL SECOND ARG IF SUPPLIED AS ; EOF HANDLER ELSE USES CHANNELS. EOFGC: MOVE B,1(AB) ; GET CHANNEL INTO B CAML AB,C%M20 ; [-2,,0] ; SKIP IF EOF ROUTINE IS SUPPLIED JRST MYCLOS ; USE CHANNELS PUSH TP,2(AB) PUSH TP,3(AB) JRST CLOSIT MYCLOS: PUSH TP,EOFCND-1(B) PUSH TP,EOFCND(B) CLOSIT: PUSH TP,$TCHAN PUSH TP,B MCALL 1,FCLOSE ; CLOSE CHANNEL MCALL 1,EVAL ; EVAL HIS EOF HANDLER JRST FINIS ; ROUTINE TO SUPPLY THE TYPE NUMBER FOR A NEWTYPE GETNEW: CAMG B,NNPRI ;NEWTYPE POPJ P, GETNTP: MOVE D,TYPTAB ; GET AOBJN POINTER TO TYPE-TABLE GETNT1: HLRZ E,(D) ; GET TYPE # CAIN E,(B) ; SKIP IF NOT EQUAL TO GOAL JRST GOTTYP ; FOUND IT ADD D,C%22 ; POINT TO NEXT JUMPL D,GETNT1 SKIPA ; KEEP TYPE SAME GOTTYP: HRRZ B,1(D) ; GET NEW TYPE # POPJ P, ; ROUTINE TO SUPPLY THE SAT TO A TEMPLATE HACKER GETSAT: MOVE D,TYPTAB ; GET AOBJN PTR TO TYPE TABLE GETSA1: HRRZ E,(D) ; GET OBJECT CAIN E,(B) ; SKIP IF NOT EQUAL TO GOAL JRST GOTSAT ; FOUND IT ADD D,C%22 JUMPL D,GETSA1 FATAL GC-DUMP -- TYPE FIXUP FAILURE GOTSAT: HLRZ B,1(D) ; GET NEW SAT POPJ P, ; A ROUTINE TO DISTINGUISH BETWEEN A DEFERRED AND A LIST POINTER RLISTQ: PUSH P,A GETYP A,(B) ; GET TYPE PUSHJ P,SAT ; GET SAT CAIG A,NUMSAT ; NOT DEFERRED IF TEMPLATE SKIPL MKTBS(A) AOS -1(P) ; SKIP IF NOT DEFFERED POP P,A POPJ P, ; EXIT .GLOBAL FLIST MFUNCTION BLOATSTAT,SUBR,[BLOAT-STAT] ENTRY JUMPGE AB,GETUVC ; SEE IF THERE IS AN ARGUMENT GETYP A,(AB) CAIE A,TUVEC ; SEE IF THE ARGUMENT IS A UVECTOR JRST WTYP1 ; IF NOT COMPLAIN HLRE 0,1(AB) MOVNS 0 CAIE 0,STATNO+STATGC ; SEE IF UVECTOR IS RIGHT LENGTH JRST WTYP1 CAMGE AB,C%M20 ; [-2,,0] ; SEE IF THERE ARE TOO MANY ARGUMENTS JRST TMA MOVE A,(AB) ; GET THE UVECTOR MOVE B,1(AB) JRST SETUV ; CONTINUE GETUVC: MOVEI A,STATNO+STATGC ; CREATE A UVECTOR PUSHJ P,IBLOCK SETUV: PUSH P,A ; SAVE UVECTOR PUSH P,B MOVE 0,NOWFRE ; COMPUTE FREE STORAGE USED SINCE LAST BLOAT-STAT SUB 0,RFRETP ADD 0,GCSTOP MOVEM 0,CURFRE PUSHJ P,GCSET ; FIX UP BLOAT-STAT PARAMETERS HLRE 0,TP ; COMPUTE STACK SPACE USED UP ADD 0,NOWTP SUBI 0,PDLBUF MOVEM 0,CURTP MOVE B,IMQUOTE THIS-PROCESS PUSHJ P,ILOC HRRZS B MOVE PVP,PVSTOR+1 HRRZ C,TPBASE+1(PVP) ; CALCULATE # OF ATOM SLOTS MOVE 0,B HRRZ D,SPBASE+1(PVP) ; COMPUTE CURRENT # OF BINDINGS SUB 0,D IDIVI 0,6 MOVEM 0,CURLVL SUB B,C ; TOTAL WORDS ATOM STORAGE IDIVI B,6 ; COMPUTE # OF SLOTS MOVEM B,NOWLVL HRRZ A,GLOBASE+1 ; COMPUTE TOTAL # OF GLOBAL SLOTS HLRE 0,GLOBASE+1 SUB A,0 ; POINT TO DOPE WORD HLRZ B,1(A) ASH B,-2 ; # OF GVAL SLOTS MOVEM B,NOWGVL HRRZ A,GLOTOP+1 ; COMPUTE # OF GVAL SLOTS IN USE HRRZ 0,GLOBSP+1 SUB A,0 ASH A,-2 ; NEGATIVE # OF SLOTS USED MOVEM A,CURGVL HRRZ A,TYPBOT+1 ; GET LENGTH OF TYPE VECTOR HLRE 0,TYPBOT+1 SUB A,0 HLRZ B,1(A) ; # OF WORDS IN TYPE-VECTOR IDIVI B,2 ; CONVERT TO # OF TYPES MOVEM B,NOWTYP HLRE 0,TYPVEC+1 ; LENGTH OF VISABLE TYPE-VECTOR MOVNS 0 IDIVI 0,2 ; GET # OF TYPES MOVEM 0,CURTYP MOVE 0,CODTOP ; GET LENGTH OF STATIONARY IMPURE STORAGE MOVEM 0,NOWSTO SETZB B,D ; ZERO OUT MAXIMUM HRRZ C,FLIST LOOPC: HLRZ 0,(C) ; GET BLK LENGTH ADD D,0 ; ADD # OF WORDS IN BLOCK CAMGE B,0 ; SEE IF NEW MAXIMUM MOVE B,0 HRRZ C,(C) ; POINT TO NEXT BLOCK JUMPN C,LOOPC ; REPEAT MOVEM D,CURSTO MOVEM B,CURMAX HLRE 0,P ; GET AMOUNT OF ROOM LEFT ON P ADD 0,NOWP SUBI 0,PDLBUF MOVEM 0,CURP MOVSI C,BSTGC ; SET UP BLT FOR GC FIGURES HRRZ B,(P) ; RESTORE B HRR C,B BLT C,(B)STATGC-1 HRLI C,BSTAT ; MODIFY BLT FOR STATS HRRI C,STATGC(B) BLT C,(B)STATGC+STATNO-1 MOVEI 0,TFIX+.VECT. HRLM 0,(B)STATNO+STATGC ; MOVE IN UTYPE POP P,B POP P,A ; RESTORE TYPE-WORD JRST FINIS GCRSET: SETZM GCNO ; CALL FROM INIT, ZAP ALL 1ST MOVE 0,[GCNO,,GCNO+1] BLT 0,GCCALL JRST GCSET .GLOBAL PGFIND,PGGIVE,PGTAKE,PGINT ; USER GARBAGE COLLECTOR INTERFACE .GLOBAL ILVAL MFUNCTION GC,SUBR ENTRY JUMPGE AB,GC1 CAMGE AB,C%M60 ; [-6,,0] JRST TMA PUSHJ P,GETFIX ; GET FREEE MIN IF GIVEN SKIPE A ; SKIP FOR 0 ARGUMENT MOVEM A,FREMIN GC1: PUSHJ P,COMPRM ; GET CURRENT USED CORE PUSH P,A CAML AB,C%M40 ; [-4,,0] ; SEE IF 3RD ARG JRST GC5 GETYP A,4(AB) ; MAKE SURE A FIX CAIE A,TFIX JRST WTYP ; ARG WRONG TYPE MOVE A,5(AB) MOVEM A,RNUMSP MOVEM A,NUMSWP GC5: CAML AB,C%M20 ; [-2,,0] ; SEE IF SECOND ARG JRST GC3 GETYP A,2(AB) ; SEE IF NONFALSE CAIE A,TFALSE ; SKIP IF FALSE JRST HAIRGC ; CAUSE A HAIRY GC GC3: MOVSI A,TATOM ; CHECK TO SEE IF INTERRUPT FLAG IS ON MOVE B,IMQUOTE AGC-FLAG PUSHJ P,ILVAL CAMN A,$TUNBOUND ; SKIP IF NOT UNBOUND JRST GC2 SKIPE GCHPN ; SKIP IF GCHAPPEN IS 0 JRST FALRTN ; JUMP TO RETURN FALSE GC2: MOVE C,[9.,,0] PUSHJ P,AGC ; COLLECT THAT TRASH PUSHJ P,COMPRM ; HOW MUCH ROOM NOW? POP P,B ; RETURN AMOUNT SUB B,A MOVSI A,TFIX JRST FINIS HAIRGC: MOVE B,3(AB) CAIN A,TFIX ; IF FIX THEN CLOBBER NGCS MOVEM B,NGCS MOVEI A,1 ; FORCE VALUE FLUSHING PHASE TO OCCUR MOVEM A,GCHAIR JRST GC2 ; HAIRY GC OCCORS NO MATTER WHAT FALRTN: MOVE A,$TFALSE MOVEI B,0 ; RETURN A FALSE-- FOR GC WHICH DIDN'T OCCOR JRST FINIS COMPRM: MOVE A,GCSTOP ; USED SPACE SUB A,GCSBOT POPJ P, MFUNCTION GCDMON,SUBR,[GC-MON] ENTRY MOVEI E,GCMONF FLGSET: MOVE C,(E) ; GET CURRENT VALUE JUMPGE AB,RETFLG ; RET CURRENT CAMGE AB,C%M20 ; [-3,,] JRST TMA GETYP 0,(AB) SETZM (E) CAIN 0,TFALSE SETOM (E) SKIPL E SETCMM (E) RETFLG: SKIPL E SETCMM C JUMPL C,NOFLG MOVSI A,TATOM MOVE B,IMQUOTE T JRST FINIS NOFLG: MOVEI B,0 MOVSI A,TFALSE JRST FINIS .GLOBAL EVATYP,APLTYP,PRNTYP MFUNCTION BLOAT,SUBR ENTRY PUSHJ P,SQKIL MOVEI C,0 ; FLAG TO SAY WHETHER NEED A GC MOVSI E,-NBLO ; AOBJN TO BLOATER TABLE BLOAT2: JUMPGE AB,BLOAT1 ; ALL DONE? PUSHJ P,NXTFIX ; GET NEXT BLOAT PARAM SKIPE A PUSHJ P,@BLOATER(E) ; DISPATCH AOBJN E,BLOAT2 ; COUNT PARAMS SET JUMPL AB,TMA ; ANY LEFT...ERROR BLOAT1: JUMPE C,BLOATD ; DONE, NO GC NEEDED MOVE C,E ; MOVE IN INDICATOR HRLI C,1 ; INDICATE THAT IT COMES FROM BLOAT SETOM INBLOT PUSHJ P,AGC ; DO ONE SKIPE A,TPBINC ; SMASH POINNTERS MOVE PVP,PVSTOR+1 ADDM A,TPBASE+1(PVP) SKIPE A,GLBINC ; GLOBAL SP ADDM A,GLOBASE+1 SKIPE A,TYPINC ADDM A,TYPBOT+1 SETZM TPBINC ; RESET PARAMS SETZM GLBINC SETZM TYPINC BLOATD: SKIPN A,GETNUM ; SKIP IF FREE STORAGE REQUEST IN EFFECT JRST BLTFN ADD A,FRETOP ; ADD FRETOP ADDI A,1777 ; ONE BLOCK FOR MARK PDL AND ROUND ANDCMI A,1777 ; TO PAGE BOUNDRY CAML A,PURBOT ; SKIP IF POSSIBLE TO WIN JRST BLFAGC ASH A,-10. ; TO PAGES PUSHJ P,P.CORE ; GRET THE CORE JRST BLFAGC ; LOSE LOSE LOSE MOVE A,FRETOP ; CALCULATE NEW PARAMETERS MOVEM A,RFRETP MOVEM A,CORTOP MOVE B,GCSTOP SETZM 1(B) HRLI B,1(B) HRRI B,2(B) BLT B,-1(A) ; ZERO CORE BLTFN: SETZM GETNUM MOVE B,FRETOP SUB B,GCSTOP MOVSI A,TFIX ; RETURN CORE FOUND JRST FINIS BLFAGC: MOVN A,FREMIN ADDM A,GETNUM ; FIX UP SO BLOATS CORRECTLY MOVE C,C%11 ; INDICATOR FOR AGC PUSHJ P,AGC ; GARBAGE COLLECT JRST BLTFN ; EXIT ; TABLE OF BLOAT ROUTINES BLOATER: MAINB TPBLO LOBLO GLBLO TYBLO STBLO PBLO SFREM SLVL SGVL STYP SSTO PUMIN PMUNG TPMUNG NBLO==.-BLOATER ; BLOAT MAIN STORAGE AREA MAINB: SETZM GETNUM MOVE D,FRETOP ; COMPUTE CURRENT ROOM SUB D,PARTOP CAMGE A,D ; NEED MORE? POPJ P, ; NO, LEAVE SUB A,D MOVEM A,GETNUM ; SAVE POPJ P, ; BLOAT TP STACK (AT TOP) TPBLO: HLRE D,TP ; GET -SIZE MOVNS B,D ADDI D,1(TP) ; POINT TO DOPE (ALMOST) CAME D,TPGROW ; BLOWN? ADDI D,PDLBUF ; POINT TO REAL DOPE WORD SUB A,B ; SKIP IF GROWTH NEEDED JUMPLE A,CPOPJ ADDI A,63. ASH A,-6 ; CONVERT TO 64 WD BLOCKS CAILE A,377 JRST OUTRNG DPB A,[111100,,-1(D)] ; SMASH SPECS IN AOJA C,CPOPJ ; BLOAT TOP LEVEL LOCALS LOBLO: HLRE D,TP ; GET -SIZE MOVNS B,D ADDI D,1(TP) ; POINT TO DOPE (ALMOST) CAME D,TPGROW ; BLOWN? ADDI D,PDLBUF ; POINT TO REAL DOPE WORD CAMG A,B ; SKIP IF GROWTH NEEDED IMULI A,6 ; 6 WORDS PER BINDING MOVE PVP,PVSTOR+1 HRRZ 0,TPBASE+1(PVP) HRRZ B,SPBASE+1(PVP) ; ROOM AVAIL TO E SUB B,0 SUBI A,(B) ; HOW MUCH MORE? JUMPLE A,CPOPJ ; NONE NEEDED MOVEI B,TPBINC PUSHJ P,NUMADJ DPB A,[1100,,-1(D)] ; SMASH AOJA C,CPOPJ ; GLOBAL SLOT GROWER GLBLO: ASH A,2 ; 4 WORDS PER VAR MOVE D,GLOBASE+1 ; CURRENT LIMITS HRRZ B,GLOBSP+1 SUBI B,(D) SUBI A,(B) ; NEW AMOUNT NEEDED JUMPLE A,CPOPJ MOVEI B,GLBINC ; WHERE TO KEEP UPDATE PUSHJ P,NUMADJ ; FIX NUMBER HLRE 0,D SUB D,0 ; POINT TO DOPE DPB A,[1100,,(D)] ; AND SMASH AOJA C,CPOPJ ; HERE TO GROW TYPE VECTOR (AND FRIENDS) TYBLO: ASH A,1 ; TWO WORD PER TYPE HRRZ B,TYPVEC+1 ; FIND CURRENT ROOM MOVE D,TYPBOT+1 SUBI B,(D) SUBI A,(B) ; EXTRA NEEDED TO A JUMPLE A,CPOPJ ; NONE NEEDED, LEAVE MOVEI B,TYPINC ; WHERE TO STASH SPEC PUSHJ P,NUMADJ ; FIX NUMBER HLRE 0,D ; POINT TO DOPE SUB D,0 DPB A,[1100,,(D)] SKIPE D,EVATYP+1 ; GROW AUX TYPE VECS IF NEEDED PUSHJ P,SGROW1 SKIPE D,APLTYP+1 PUSHJ P,SGROW1 SKIPE D,PRNTYP+1 PUSHJ P,SGROW1 AOJA C,CPOPJ ; HERE TO CREATE STORAGE SPACE STBLO: MOVE D,GCSBOT ; HOW MUCH NOW HERE SUB D,CODTOP SUBI A,(D) ; MORE NEEDED? JUMPLE A,CPOPJ MOVEM A,PARNEW ; FORCE PAIR SPACE TO MOVE ON OUT AOJA C,CPOPJ ; BLOAT P STACK PBLO: HLRE D,P MOVNS B,D SUBI D,5 ; FUDGE FOR THIS CALL SUBI A,(D) JUMPLE A,CPOPJ ADDI B,1(P) ; POINT TO DOPE CAME B,PGROW ; BLOWN? ADDI B,PDLBUF ; NOPE, POIN TO REAL D.W. ADDI A,63. ASH A,-6 ; TO 64 WRD BLOCKS CAILE A,377 ; IN RANGE? JRST OUTRNG DPB A,[111100,,-1(B)] AOJA C,CPOPJ ; SET FREMIN SFREM: SKIPE A ; DON'T ZERO EMPTY PARAMETER MOVEM A,FREMIN POPJ P, ; SET LVAL INCREMENT SLVL: IMULI A,6 ; CALCULATE AMOUNT TO GROW B MOVEI B,LVLINC PUSHJ P,NUMADJ MOVEM A,LVLINC POPJ P, ; SET GVAL INCREMENT SGVL: IMULI A,4. ; # OF SLOTS MOVEI B,GVLINC PUSHJ P,NUMADJ MOVEM A,GVLINC POPJ P, ; SET TYPE INCREMENT STYP: IMULI A,2 ; CALCULATE NUMBER OF GROW BLOCKS NEEDED MOVEI B,TYPIC PUSHJ P,NUMADJ MOVEM A,TYPIC POPJ P, ; SET STORAGE INCREMENT SSTO: IDIVI A,2000 ; # OF BLOCKS CAIE B,0 ; REMAINDER? ADDI A,1 IMULI A,2000 ; CONVERT BACK TO WORDS MOVEM A,STORIC POPJ P, ; HERE FOR MINIMUM PURE SPACE PUMIN: ADDI A,1777 ANDCMI A,1777 ; TO PAGE BOUNDRY MOVEM A,PURMIN POPJ P, ; HERE TO ADJUST PSTACK PARAMETERS IN GC PMUNG: ADDI A,777 ; TO NEAREST 1000 WORD BOUNDRY ANDCMI A,777 MOVEM A,PGOOD ; PGOOD ASH A,2 ; PMAX IS 4*PGOOD MOVEM A,PMAX ASH A,-4 ; PMIN IS .25*PGOOD MOVEM A,PMIN ; HERE TO ADJUST GC TPSTACK PARAMS TPMUNG: ADDI A,777 ANDCMI A,777 ; TO NEAREST 1000 WORD BOUNDRY MOVEM A,TPGOOD ASH A,2 ; TPMAX= 4*TPGOOD MOVEM A,TPMAX ASH A,-4 ; TPMIN= .25*TPGOOD MOVEM A,TPMIN ; GET NEXT (FIX) ARG NXTFIX: PUSHJ P,GETFIX ADD AB,C%22 POPJ P, ; ROUTINE TO GET POS FIXED ARG GETFIX: GETYP A,(AB) CAIE A,TFIX JRST WRONGT SKIPGE A,1(AB) JRST BADNUM POPJ P, ; GET NUMBERS FIXED UP FOR GROWTH FIELDS NUMADJ: ADDI A,77 ; ROUND UP ANDCMI A,77 ; KILL CRAP MOVE 0,A MOVNS A ; COMPUTE ADD FACTOR FOR SPEC. POINTER UPDATE HRLI A,-1(A) MOVEM A,(B) ; AND STASH IT MOVE A,0 ASH A,-6 ; TO 64 WD BLOCKS CAILE A,377 ; CHECK FIT JRST OUTRNG POPJ P, ; DO SYMPATHETIC GROWTHS SGROW1: HLRE 0,D SUB D,0 DPB A,[111100,,(D)] POPJ P, ;FUNCTION TO CONSTRUCT A LIST MFUNCTION CONS,SUBR ENTRY 2 GETYP A,2(AB) ;GET TYPE OF 2ND ARG CAIE A,TLIST ;LIST? JRST WTYP2 ;NO , COMPLAIN MOVE C,(AB) ; GET THING TO CONS IN MOVE D,1(AB) HRRZ E,3(AB) ; AND LIST PUSHJ P,ICONS ; INTERNAL CONS JRST FINIS ; COMPILER CALL TO CONS C1CONS: PUSHJ P,ICELL2 JRST ICONS2 ICONS4: HRRI C,(E) ICONS3: MOVEM C,(B) ; AND STORE MOVEM D,1(B) TLPOPJ: MOVSI A,TLIST POPJ P, ; INTERNAL CONS--ICONS; C,D VALUE, E CDR ; RELATIVIZE RETURN ADDRESS HERE--MUST BE DIFFERENT FROM ICONS, SINCE ; ICONS IS CALLED FROM INTERPRETER ENTRIES WHICH ARE THEMSELVES PUSHJ'ED ; TO: DOING SUBM M,(P) ANYWHERE IN ICONS IS FATAL IF A GC OCCURS. CICONS: SUBM M,(P) PUSHJ P,ICONS JRST MPOPJ ; INTERNAL CONS TO NIL--INCONS INCONS: MOVEI E,0 ICONS: GETYP A,C ; CHECK TYPE OF VAL PUSHJ P,NWORDT ; # OF WORDS SOJN A,ICONS1 ; JUMP IF DEFERMENT NEEDED PUSHJ P,ICELL2 ; NO DEFER, GET 2 WORDS FROM PAIR SPACE JRST ICNS2A ; NO CORE, GO GC (SPECIAL PLACE, NOTICE) JRST ICONS4 ; HERE IF CONSING DEFERRED ICONS1: MOVEI A,4 ; NEED 4 WORDS PUSHJ P,ICELL ; GO GET 'EM JRST ICNS2A ; NOT THERE, GC (SAME PLACE AS FOR ICONS) HRLI E,TDEFER ; CDR AND DEFER MOVEM E,(B) ; STORE MOVEI E,2(B) ; POINT E TO VAL CELL HRRZM E,1(B) MOVEM C,(E) ; STORE VALUE MOVEM D,1(E) JRST TLPOPJ ; HERE TO GC ON A CONS ; HERE FROM C1CONS ICONS2: SUBM M,(P) PUSHJ P,ICONSG SUBM M,(P) JRST C1CONS ; HERE FROM ICONS (THUS CICONS, INDIRECTLY), ICONS1 ICNS2A: PUSHJ P,ICONSG JRST ICONS ; REALLY DO GC ICONSG: PUSH TP,C ; SAVE VAL PUSH TP,D PUSH TP,$TLIST PUSH TP,E ; SAVE VITAL STUFF ADDM A,GETNUM ; AMOUNT NEEDED MOVE C,[3,,1] ; INDICATOR FOR AGC PUSHJ P,INQAGC ; ATTEMPT TO WIN MOVE D,-2(TP) ; RESTORE VOLATILE STUFF MOVE C,-3(TP) MOVE E,(TP) SUB TP,C%44 ; [4,,4] POPJ P, ; BACK TO DRAWING BOARD ; SUBROUTINE TO ALLOCATE WORDS IN PAIR SPACE. CALLS AGC IF NEEDED CELL2: MOVEI A,2 ; USUAL CASE CELL: PUSHJ P,ICELL ; INTERNAL JRST .+2 ; LOSER POPJ P, ADDM A,GETNUM ; AMOUNT REQUIRED PUSH P,A ; PREVENT AGC DESTRUCTION MOVE C,[3,,1] ; INDICATOR FOR AGC PUSHJ P,INQAGC POP P,A JRST CELL ; AND TRY AGAIN ; INTERNAL CELL GETTER, SKIPS IF ROO EXISTS, ELSE DOESN'T ICELL2: MOVEI A,2 ; MOST LIKELY CAE ICELL: SKIPE B,RCL JRST ICELRC ;SEE IF WE CAN RE-USE A RECYCLE CELL MOVE B,PARTOP ; GET TOP OF PAIRS ADDI B,(A) ; BUMP CAMLE B,FRETOP ; SKIP IF OK. JRST VECTRY ; LOSE EXCH B,PARTOP ; SETUP NEW PARTOP AND RETURN POINTER ADDM A,USEFRE JRST CPOPJ1 ; SKIP RETURN ; TRY RECYCLING USING A VECTOR FROM RCLV VECTRY: SKIPN B,RCLV ; SKIP IF VECTOR EXISTS POPJ P, PUSH P,C PUSH P,A MOVEI C,RCLV VECTR1: HLRZ A,(B) ; GET LENGTH SUB A,(P) JUMPL A,NXTVEC ; DOESN'T SATISFY TRY AGAIN CAIN A,1 ; MAKE SURE NOT LEFT WITH A SINGLE SLOT JRST NXTVEC JUMPN A,SOML ; SOME ARE LEFT HRRZ A,(B) HRRM A,(C) HLRZ A,(B) SETZM (B) SETZM -1(B) ; CLEAR DOPE WORDS SUBI B,-1(A) POP P,A ; CLEAR STACK POP P,C JRST CPOPJ1 SOML: HRLM A,(B) ; SMASH AMOUNT LEFT SUBI B,-1(A) ; GET TO BEGINNING SUB B,(P) POP P,A POP P,C JRST CPOPJ1 NXTVEC: MOVEI C,(B) HRRZ B,(B) ; GET NEXT JUMPN B,VECTR1 POP P,A POP P,C POPJ P, ICELRC: CAIE A,2 JRST ICELL+2 ;IF HE DOESNT WANT TWO, USE OLD METHOD PUSH P,A MOVE A,(B) HRRZM A,RCL POP P,A SETZM (B) ;GIVE HIM A CLEAN RECYCLED CELL SETZM 1(B) JRST CPOPJ1 ;THAT IT ;FUNCTION TO BUILD A LIST OF MANY ELEMENTS IMFUNCTION LIST,SUBR ENTRY PUSH P,$TLIST LIST12: HLRE A,AB ;GET -NUM OF ARGS PUSH TP,$TAB PUSH TP,AB MOVNS A ;MAKE IT + JUMPE A,LISTN ;JUMP IF 0 SKIPE RCL ;SEE IF WE WANT TO DO ONE AT A TIME JRST LST12R ;TO GET RECYCLED CELLS PUSHJ P,CELL ;GET NUMBER OF CELLS PUSH TP,(P) ;SAVE IT PUSH TP,B SUB P,C%11 LSH A,-1 ;NUMBER OF REAL LIST ELEMENTS CHAINL: ADDI B,2 ;LOOP TO CHAIN ELEMENTS HRRZM B,-2(B) ;CHAIN LAST ONE TO NEXT ONE SOJG A,.-2 ;LOOP TIL ALL DONE CLEARM B,-2(B) ;SET THE LAST CDR TO NIL ; NOW LOBEER THE DATA IN TO THE LIST MOVE D,AB ; COPY OF ARG POINTER MOVE B,(TP) ;RESTORE LIS POINTER LISTLP: GETYP A,(D) ;GET TYPE PUSHJ P,NWORDT ;GET NUMBER OF WORDS SOJN A,LDEFER ;NEED TO DEFER POINTER GETYP A,(D) ;NOW CLOBBER ELEMENTS HRLM A,(B) MOVE A,1(D) ;AND VALUE.. MOVEM A,1(B) LISTL2: HRRZ B,(B) ;REST B ADD D,C%22 ;STEP ARGS JUMPL D,LISTLP POP TP,B POP TP,A SUB TP,C%22 ; CLEANUP STACK JRST FINIS LST12R: ASH A,-1 ;ONE AT A TIME TO GET RECYCLED CELLS JUMPE A,LISTN PUSH P,A ;SAVE COUNT ON STACK SETZM E SETZB C,D PUSHJ P,ICONS MOVE E,B ;LOOP AND CHAIN TOGETHER SOSLE (P) JRST .-4 PUSH TP,-1(P) ;PUSH ON THE TYPE WE WANT PUSH TP,B SUB P,C%22 ;CLEAN UP AFTER OURSELVES JRST LISTLP-2 ;AND REJOIN MAIN STREAM ; MAKE A DEFERRED POINTER LDEFER: PUSH TP,$TLIST ;SAVE CURRENT POINTER PUSH TP,B MOVEM D,1(TB) ; SAVE ARG HACKER PUSHJ P,CELL2 MOVE D,1(TB) GETYPF A,(D) ;GET FULL DATA MOVE C,1(D) MOVEM A,(B) MOVEM C,1(B) MOVE C,(TP) ;RESTORE LIST POINTER MOVEM B,1(C) ;AND MAKE THIS BE THE VALUE MOVSI A,TDEFER HLLM A,(C) ;AND STORE IT MOVE B,C SUB TP,C%22 JRST LISTL2 LISTN: MOVEI B,0 POP P,A JRST FINIS ; BUILD A FORM IMFUNCTION FORM,SUBR ENTRY PUSH P,$TFORM JRST LIST12 ; COMPILERS CALLS TO FORM AND LIST A/ COUNT ELEMENTS ON STACK IILIST: SUBM M,(P) PUSHJ P,IILST MOVSI A,TLIST JRST MPOPJ IIFORM: SUBM M,(P) PUSHJ P,IILST MOVSI A,TFORM JRST MPOPJ IILST: JUMPE A,IILST0 ; NIL WHATSIT PUSH P,A MOVEI E,0 IILST1: POP TP,D POP TP,C PUSHJ P,ICONS ; CONS 'EM UP MOVEI E,(B) SOSE (P) ; COUNT JRST IILST1 SUB P,C%11 POPJ P, IILST0: MOVEI B,0 POPJ P, ;FUNCTION TO BUILD AN IMPLICIT LIST MFUNCTION ILIST,SUBR ENTRY PUSH P,$TLIST ILIST2: JUMPGE AB,TFA ;NEED AT LEAST ONE ARG CAMGE AB,C%M40 ; [-4,,0] ; NO MORE THAN TWO ARGS JRST TMA PUSHJ P,GETFIX ; GET POS FIX # JUMPE A,LISTN ;EMPTY LIST ? CAML AB,C%M20 ; [-2,,0] ;ONLY ONE ARG? JRST LOSEL ;YES PUSH P,A ;SAVE THE CURRENT VALUE OF LENGTH FOR LOOP ITERATION ILIST0: PUSH TP,2(AB) PUSH TP,(AB)3 MCALL 1,EVAL PUSH TP,A PUSH TP,B SOSLE (P) JRST ILIST0 POP P,C ILIST1: MOVE C,(AB)+1 ;REGOBBLE LENGTH ACALL C,LIST ILIST3: POP P,A ; GET FINAL TYPE JRST FINIS LOSEL: PUSH P,A ; SAVE COUNT MOVEI E,0 LOSEL1: SETZB C,D ; TLOSE,,0 PUSHJ P,ICONS MOVEI E,(B) SOSLE (P) JRST LOSEL1 SUB P,C%11 JRST ILIST3 ; IMPLICIT FORM MFUNCTION IFORM,SUBR ENTRY PUSH P,$TFORM JRST ILIST2 ; IVECTOR AND IUVECTOR--GET VECTOR AND UVECTOR OF COMPUTED VALUES MFUNCTION VECTOR,SUBR,[IVECTOR] MOVEI C,1 JRST VECTO3 MFUNCTION UVECTOR,SUBR,[IUVECTOR] MOVEI C,0 VECTO3: ENTRY JUMPGE AB,TFA ; AT LEAST ONE ARG CAMGE AB,C%M40 ; [-4,,0] ; NOT MORE THAN 2 JRST TMA PUSHJ P,GETFIX ; GET A POS FIXED NUMBER LSH A,(C) ; A-> NUMBER OF WORDS PUSH P,C ; SAVE FOR LATER PUSHJ P,IBLOCK ; GET BLOCK (TURN ON BIT APPROPRIATELY) POP P,C HLRE A,B ; START TO SUBM B,A ; FIND DOPE WORD MOVSI D,.VECT. ; FOR GCHACK IORM D,(A) JUMPE C,VECTO4 MOVSI D,400000 ; GET NOT UNIFORM BIT IORM D,(A) ; INTO DOPE WORD SKIPA A,$TVEC ; GET TYPE VECTO4: MOVSI A,TUVEC CAML AB,C%M20 ; [-2,,0] ; SKIP IF ARGS NEED TO BE HACKED JRST FINIS JUMPGE B,FINIS ; DON'T EVAL FOR EMPTY CASE PUSH TP,A ; SAVE THE VECTOR PUSH TP,B PUSH TP,A PUSH TP,B JUMPE C,UINIT JUMPGE B,FINIS ; EMPTY VECTOR, LEAVE INLP: PUSHJ P,IEVAL ; EVAL EXPR MOVEM A,(C) MOVEM B,1(C) ADD C,C%22 ; BUMP VECTOR MOVEM C,(TP) JUMPL C,INLP ; IF MORE DO IT GETVEC: MOVE A,-3(TP) MOVE B,-2(TP) SUB TP,C%44 ; [4,,4] JRST FINIS ; HERE TO FILL UP A UVECTOR UINIT: PUSHJ P,IEVAL ; HACK THE 1ST VALUE GETYP A,A ; GET TYPE PUSH P,A ; SAVE TYPE PUSHJ P,NWORDT ; SEE IF IT CAN BE UNIFORMED SOJN A,CANTUN ; COMPLAIN STJOIN: MOVE C,(TP) ; RESTORE POINTER ADD C,1(AB) ; POINT TO DOPE WORD MOVE A,(P) ; GET TYPE HRLZM A,(C) ; STORE IN D.W. MOVSI D,.VECT. ; FOR GCHACK IORM D,(C) MOVE C,(TP) ; GET BACK VECTOR SKIPE 1(AB) JRST UINLP1 ; START FILLING UV JRST GETVE1 UINLP: MOVEM C,(TP) ; SAVE PNTR PUSHJ P,IEVAL ; EVAL THE EXPR GETYP A,A ; GET EVALED TYPE CAIE A,@(P) ; WINNER? JRST WRNGSU ; SERVICE ERROR FOR UVECTOR,STORAGE UINLP1: MOVEM B,(C) ; STORE AOBJN C,UINLP GETVE1: SUB P,C%11 JRST GETVEC ; AND RETURN VECTOR IEVAL: PUSH TP,2(AB) PUSH TP,3(AB) MCALL 1,EVAL MOVE C,(TP) POPJ P, ; ISTORAGE -- GET STORAGE OF COMPUTED VALUES MFUNCTION ISTORAGE,SUBR ENTRY JUMPGE AB,TFA CAMGE AB,C%M40 ; [-4,,0] ; AT LEAST ONE ARG JRST TMA PUSHJ P,GETFIX ; POSITIVE COUNT FIRST ARG PUSHJ P,CAFRE ; GET CORE MOVN B,1(AB) ; -COUNT HRL A,B ; PUT IN LHW (A) MOVM B,B ; +COUNT HRLI B,2(B) ; LENGTH + 2 ADDI B,(A) ; MAKE POINTER TO DOPE WORDS HLLZM B,1(B) ; PUT TOTAL LENGTH IN 2ND DOPE HRRM A,1(B) ; PUT ADDRESS IN RHW (STORE DOES THIS TOO). MOVE B,A MOVSI A,TSTORAGE CAML AB,C%M20 ; [-2,,0] ; SECOND ARG TO EVAL? JRST FINIS ; IF NOT, RETURN EMPTY PUSH TP,A PUSH TP,B PUSH TP,A PUSH TP,B PUSHJ P,IEVAL ; EVALUATE FOR FIRST VALUE GETYP A,A PUSH P,A ; FOR COMPARISON LATER PUSHJ P,SAT CAIN A,S1WORD JRST STJOIN ;TREAT LIKE A UVECTOR ; IF NOT 1-WORD TYPES, CANNOT STORE, SO COMPLAIN PUSHJ P,FREESV ; FREE STORAGE VECTOR ERRUUO EQUOTE DATA-CANT-GO-IN-STORAGE ; FOR STORAGE, MUST FREE THE CORE ELSE IT IS LOST (NO GC) FREESV: MOVE A,1(AB) ; GET COUNT ADDI A,2 ; FOR DOPE HRRZ B,(TP) ; GET ADDRESS PUSHJ P,CAFRET ; FREE THE CORE POPJ P, ; INTERNAL VECTOR ALLOCATOR. A/SIZE OF VECTOR (NOT INCLUDING DOPE WORDS) IBLOK1: ASH A,1 ; TIMES 2 GIBLOK: TLOA A,400000 ; FUNNY BIT IBLOCK: TLZ A,400000 ; NO BIT ON TLO A,.VECT. ; TURN ON BIT FOR GCHACK ADDI A,2 ; COMPENSATE FOR DOPE WORDS IBLOK2: SKIPE B,RCLV ; ANY TO RECYCLE? JRST RCLVEC NORCL: MOVE B,GCSTOP ; POINT TO BOTTOM OF SPACE PUSH P,B ; SAVE TO BUILD PTR ADDI B,(A) ; ADD NEEDED AMOUNT CAML B,FRETOP ; SKIP IF NO GC NEEDED JRST IVECT1 MOVEM B,GCSTOP ; WIN, GET POINTER TO BLOCK AND UPDATE VECBOT ADDM A,USEFRE HRRZS USEFRE HRLZM A,-1(B) ; STORE LENGTH IN DOPE WORD HLLZM A,-2(B) ; AND BIT HRRM B,-1(B) ; SMASH IN RELOCATION SOS -1(B) POP P,B ; RESTORE PTR TO BOTTOM OF VECTOR HRROS B ; POINT TO START OF VECTOR TLC B,-3(A) ; SETUP COUNT HRRI A,TVEC SKIPL A HRRI A,TUVEC MOVSI A,(A) POPJ P, ; HERE TO DO A GC ON A VECTOR ALLOCATION IVECT1: PUSH P,0 PUSH P,A ; SAVE DESIRED LENGTH HRRZ 0,A ADDM 0,GETNUM ; AND STORE AS DESIRED AMOUNT MOVE C,[4,,1] ; GET INDICATOR FOR AGC PUSHJ P,INQAGC POP P,A POP P,0 POP P,B JRST IBLOK2 ; INTERNAL EVECTOR (CALLED FROM READ) A/ #OF THINGS ; ITEMS ON TOP OF STACK IEVECT: ASH A,1 ; TO NUMBER OF WORDS PUSH P,A PUSHJ P,IBLOCK ; GET VECTOR HLRE D,B ; FIND DW SUBM B,D ; A POINTS TO DW MOVSI 0,400000+.VECT. MOVEM 0,(D) ; CLOBBER NON UNIF BIT POP P,A ; RESTORE COUNT JUMPE A,IVEC1 ; 0 LNTH, DONE MOVEI C,(TP) ; BUILD BLT SUBI C,(A)-1 ; C POINTS TO 1ST ITEM ON STACK MOVSI C,(C) HRRI C,(B) ; B/ SOURCE,,DEST BLT C,-1(D) ; XFER THE DATA HRLI A,(A) SUB TP,A ; FLUSH STACKAGE IVEC1: MOVSI A,TVEC POPJ P, ; COMPILERS CALL CIVEC: SUBM M,(P) PUSHJ P,IEVECT JRST MPOPJ ; INTERNAL CALL TO EUVECTOR IEUVEC: PUSH P,A ; SAVE LENGTH PUSHJ P,IBLOCK MOVE A,(P) JUMPE A,IEUVE1 ; EMPTY, LEAVE ASH A,1 ; NOW FIND STACK POSITION MOVEI C,(TP) ; POINT TO TOP MOVE D,B ; COPY VEC POINTER SUBI C,-1(A) ; POINT TO 1ST DATUM GETYP A,(C) ; CHECK IT PUSHJ P,NWORDT SOJN A,CANTUN ; WONT FIT GETYP E,(C) IEUVE2: GETYP 0,(C) ; TYPE OF EL CAIE 0,(E) ; MATCH? JRST WRNGUT MOVE 0,1(C) MOVEM 0,(D) ; CLOBBER ADDI C,2 AOBJN D,IEUVE2 ; LOOP TRO E,.VECT. HRLZM E,(D) ; STORE UTYPE IEUVE1: POP P,A ; GET COUNY ASH A,1 ; MUST FLUSH 2 TIMES # OF ELEMENTS HRLI A,(A) SUB TP,A ; CLEAN UP STACK MOVSI A,TUVEC POPJ P, ; COMPILER'S CALL CIUVEC: SUBM M,(P) PUSHJ P,IEUVEC JRST MPOPJ IMFUNCTION EVECTOR,SUBR,[VECTOR] ENTRY HLRE A,AB MOVNS A PUSH P,A ;SAVE NUMBER OF WORDS PUSHJ P,IBLOCK ; GET WORDS MOVEI D,-1(B) ; SETUP FOR BLT AND DOPE CLOBBER JUMPGE B,FINISV ;DONT COPY A ZERO LENGTH VECTOR HRLI C,(AB) ;START BUILDING BLT POINTER HRRI C,(B) ;TO ADDRESS ADDI D,@(P) ;SET D TO FINAL ADDRESS BLT C,(D) FINISV: MOVSI 0,400000+.VECT. MOVEM 0,1(D) ; MARK AS GENERAL SUB P,C%11 MOVSI A,TVEC JRST FINIS ;EXPLICIT VECTORS FOR THE UNIFORM CSE IMFUNCTION EUVECTOR,SUBR,[UVECTOR] ENTRY HLRE A,AB ;-NUM OF ARGS MOVNS A ASH A,-1 ;NEED HALF AS MANY WORDS PUSH P,A JUMPGE AB,EUV1 ; DONT CHECK FOR EMPTY GETYP A,(AB) ;GET FIRST ARG PUSHJ P,NWORDT ;SEE IF NEEDS EXTRA WORDS SOJN A,CANTUN EUV1: POP P,A PUSHJ P,IBLOCK ; GET VECT JUMPGE B,FINISU GETYP C,(AB) ;GET THE FIRST TYPE MOVE D,AB ;COPY THE ARG POINTER MOVE E,B ;COPY OF RESULT EUVLP: GETYP 0,(D) ;GET A TYPE CAIE 0,(C) ;SAME? JRST WRNGUT ;NO , LOSE MOVE 0,1(D) ;GET GOODIE MOVEM 0,(E) ;CLOBBER ADD D,C%22 ;BUMP ARGS POINTER AOBJN E,EUVLP TRO C,.VECT. HRLM C,(E) ;CLOBBER UNIFORM TYPE IN FINISU: MOVSI A,TUVEC JRST FINIS WRNGSU: GETYP A,-1(TP) CAIE A,TSTORAGE JRST WRNGUT ;IF UVECTOR PUSHJ P,FREESV ;FREE STORAGE VECTOR ERRUUO EQUOTE TYPES-DIFFER-IN-STORAGE-OBJECT WRNGUT: ERRUUO EQUOTE TYPES-DIFFER-IN-UNIFORM-VECTOR CANTUN: ERRUUO EQUOTE DATA-CANT-GO-IN-UNIFORM-VECTOR BADNUM: ERRUUO EQUOTE NEGATIVE-ARGUMENT ; FUNCTION TO GROW A VECTOR REPEAT 0,[ MFUNCTION GROW,SUBR ENTRY 3 MOVEI D,0 ;STACK HACKING FLAG GETYP A,(AB) ;FIRST TYPE PUSHJ P,SAT ;GET STORAGE TYPE GETYP B,2(AB) ;2ND ARG CAIE A,STPSTK ;IS IT ASTACK CAIN A,SPSTK AOJA D,GRSTCK ;YES, WIN CAIE A,SNWORD ;UNIFORM VECTOR CAIN A,S2NWORD ;OR GENERAL GRSTCK: CAIE B,TFIX ;IS 2ND FIXED JRST WTYP2 ;COMPLAIN GETYP B,4(AB) CAIE B,TFIX ;3RD ARG JRST WTYP3 ;LOSE MOVEI E,1 ;UNIFORM/GENERAL FLAG CAIE A,SNWORD ;SKIP IF UNIFORM CAIN A,SPSTK ;DONT SKIP IF UNIFORM PDL MOVEI E,0 HRRZ B,1(AB) ;POINT TO START HLRE A,1(AB) ;GET -LENGTH SUB B,A ;POINT TO DOPE WORD SKIPE D ;SKIP IF NOT STACK ADDI B,PDLBUF ;FUDGE FOR PDL HLLZS (B) ;ZERO OUT GROWTH SPECS SKIPN A,3(AB) ;ANY TOP GROWTH? JRST GROW1 ;NO, LOOK FOR BOTTOM GROWTH ASH A,(E) ;MULT BY 2 IF GENERAL ADDI A,77 ;ROUND TO NEAREST BLOCK ANDCMI A,77 ;CLEAR LOW ORDER BITS ASH A,9-6 ;DIVIDE BY 100 AND SHIFT TO POSTION TRZE A,400000 ;CONVERT TO SIGN MAGNITUDE MOVNS A TLNE A,-1 ;SKIP IF NOT TOO BIG JRST GTOBIG ;ERROR GROW1: SKIPN C,5(AB) ;CHECK LOW GROWTH JRST GROW4 ;NONE, SKIP ASH C,(E) ;GENRAL FUDGE ADDI C,77 ;ROUND ANDCMI C,77 ;FUDGE FOR VALUE RETURN PUSH P,C ;AND SAVE ASH C,-6 ;DIVIDE BY 100 TRZE C,400 ;CONVERT TO SIGN MAGNITUDE MOVNS C TDNE C,[-1,,777000] ;CHECK FOR OVERFLOW JRST GTOBIG GROW2: HLRZ E,1(B) ;GET TOTAL LENGTH OF VECTOR MOVNI E,-1(E) HRLI E,(E) ;TO BOTH HALVES ADDI E,1(B) ;POINTS TO TOP SKIPE D ;STACK? ADD E,[PDLBUF,,0] ;YES, FUDGE LENGTH SKIPL D,(P) ;SHRINKAGE? JRST GROW3 ;NO, CONTINUE MOVNS D ;PLUSIFY HRLI D,(D) ;TO BOTH HALVES ADD E,D ;POINT TO NEW LOW ADDR GROW3: IORI A,(C) ;OR TOGETHER HRRM A,(B) ;DEPOSIT INTO DOPEWORD PUSH TP,(AB) ;PUSH TYPE PUSH TP,E ;AND VALUE SKIPE A ;DON'T GC FOR NOTHING MOVE C,[2,,0] ; GET INDICATOR FOR AGC PUSHJ P,AGC JUMPL A,GROFUL POP P,C ;RESTORE GROWTH HRLI C,(C) POP TP,B ;GET VECTOR POINTER SUB B,C ;POINT TO NEW TOP POP TP,A JRST FINIS GROFUL: SUB P,C%11 ; CLEAN UP STACK SUB TP,C%22 PUSHJ P,FULLOS JRST GROW GTOBIG: ERRUUO EQUOTE ATTEMPT-TO-GROW-VECTOR-TOO-MUCH GROW4: PUSH P,[0] ;0 BOTTOM GROWTH JRST GROW2 ] FULLOS: ERRUUO EQUOTE NO-STORAGE ; SUBROUTINE TO BUILD CHARACTER STRING GOODIES MFUNCTION BYTES,SUBR ENTRY MOVEI D,1 JUMPGE AB,TFA GETYP 0,(AB) CAIE 0,TFIX JRST WTYP1 MOVE E,1(AB) ADD AB,C%22 JRST STRNG1 IMFUNCTION STRING,SUBR ENTRY MOVEI D,0 MOVEI E,7 STRNG1: MOVE B,AB ;COPY ARG POINTER MOVEI C,0 ;INITIALIZE COUNTER PUSH TP,$TAB ;SAVE A COPY PUSH TP,B HLRE A,B ; GET # OF ARGS MOVNS A ASH A,-1 ; 1/2 FOR # OF ARGS PUSHJ P,IISTRN JRST FINIS IISTRN: PUSH P,E JUMPL E,OUTRNG CAILE E,36. JRST OUTRNG SKIPN E,A ; SKIP IF ARGS EXIST JRST MAKSTR ; ALL DONE STRIN2: GETYP 0,(B) ;GET TYPE CODE CAMN 0,SING(D) ; SINGLE CHARACTER OR FIX? AOJA C,STRIN1 CAME 0,MULTI(D) ; OR STRING OR BYTE-STRING JRST WRONGT ;NEITHER HRRZ 0,(B) ; GET CHAR COUNT ADD C,0 ; AND BUMP STRIN1: ADD B,C%22 SOJG A,STRIN2 ; NOW GET THE NECESSARY VECTOR MAKSTR: HRL C,MULTI(D) ; FINAL TYPE,, CHAR COUNT PUSH P,C ; SAVE CHAR COUNT PUSH P,E ; SAVE ARG COUNT MOVEI D,36. IDIV D,-2(P) ; A==> BYTES PER WORD MOVEI A,(C) ; LNTH+4 TO A ADDI A,-1(D) IDIVI A,(D) LSH E,12. MOVE D,-2(P) DPB D,[060600,,E] HRLM E,-2(P) ; SAVE REMAINDER PUSHJ P,IBLOCK POP P,A JUMPGE B,DONEC ; 0 LENGTH, NO STRING HRLI B,440000 ;CONVERT B TO A BYTE POINTER HRRZ 0,-1(P) ; BYTE SIZE DPB 0,[300600,,B] MOVE C,(TP) ; POINT TO ARGS AGAIN NXTRG1: GETYP D,(C) ;GET AN ARG CAIN D,TFIX JRST .+3 CAIE D,TCHRS JRST TRYSTR MOVE D,1(C) ; GET IT IDPB D,B ;AND DEPOSIT IT JRST NXTARG TRYSTR: MOVE E,1(C) ;GET BYTER HRRZ 0,(C) ;AND COUNT NXTCHR: SOJL 0,NXTARG ; IF RUNOUT, GET NEXT ARG ILDB D,E ;AND GET NEXT IDPB D,B ; AND DEPOSIT SAME JRST NXTCHR NXTARG: ADD C,C%22 ;BUMP ARG POINTER SOJG A,NXTRG1 ADDI B,1 DONEC: MOVSI C,TCHRS+.VECT. TLO B,400000 HLLM C,(B) ;AND CLOBBER AWAY HLRZ C,1(B) ;GET LENGTH BACK POP P,A SUBI B,-1(C) HLL B,(P) ;MAKE A BYTE POINTER SUB P,C%11 POPJ P, SING: TCHRS TFIX MULTI: TCHSTR TBYTE ; COMPILER'S CALL TO MAKE A STRING CISTNG: TDZA D,D ; COMPILERS CALL TO MAKE A BYTE STRING CBYTES: MOVEI D,1 SUBM M,(P) MOVEI C,0 ; INIT CHAR COUNTER MOVEI B,(A) ; SET UP STACK POINTER ASH B,1 ; * 2 FOR NO. OF SLOTS HRLI B,(B) SUBM TP,B ; B POINTS TO ARGS PUSH P,D MOVEI E,7 JUMPE D,CBYST GETYP 0,1(B) ; CHECK BYTE SIZE CAIE 0,TFIX JRST WRONGT MOVE E,2(B) ADD B,C%22 SUBI A,1 CBYST: ADD B,C%11 PUSH TP,$TTP PUSH TP,B PUSHJ P,IISTRN ; MAKE IT HAPPEN MOVE TP,(TP) ; FLUSH ARGS SUB TP,C%11 POP P,D JUMPE D,MPOPJ SUB TP,C%22 JRST MPOPJ ;BUILD IMPLICT STRING MFUNCTION IBYTES,SUBR ENTRY CAML AB,C%M20 ; [-3,,] ; AT LEAST 2 JRST TFA CAMGE AB,C%M60 ; [-7,,] ; NO MORE THAN 3 JRST TMA PUSHJ P,GETFIX ; GET BYTE SIZE JUMPL A,OUTRNG CAILE A,36. JRST OUTRNG PUSH P,[TFIX] PUSH P,A PUSH P,$TBYTE ADD AB,C%22 MOVEM AB,ABSAV(TB) JRST ISTR1 MFUNCTION ISTRING,SUBR ENTRY JUMPGE AB,TFA ; TOO FEW ARGS CAMGE AB,C%M40 ; [-4,,0] ; VERIFY NOT TOO MANY ARGS JRST TMA PUSH P,[TCHRS] PUSH P,[7] PUSH P,$TCHSTR ISTR1: PUSHJ P,GETFIX MOVEI C,36. IDIV C,-1(P) ADDI A,-1(C) IDIVI A,(C) ; # OF WORDS NEEDED TO A ASH D,12. MOVE C,-1(P) ; GET BYTE SIZE DPB C,[060600,,D] PUSH P,D PUSHJ P,IBLOCK HLRE C,B ; -LENGTH TO C SUBM B,C ; LOCN OF DOPE WORD TO C HRLI D,TCHRS+.VECT. ; CLOBBER ITS TYPE HLLM D,(C) MOVE A,-1(P) HRR A,1(AB) ; SETUP TYPE'S RH SUBI B,1 HRL B,(P) ; AND BYTE POINTER SUB P,C%33 SKIPE (AB)+1 ; SKIP IF NO CHARACTERS TO DEPOSIT CAML AB,C%M20 ; [-2,,0] ; SKIP IF 2 ARGS GIVEN JRST FINIS PUSH TP,A ;SAVE OUR STRING PUSH TP,B PUSH TP,A ;SAVE A TEMPORARY CLOBBER POINTER PUSH TP,B PUSH P,(AB)1 ;SAVE COUNT PUSH TP,(AB)+2 PUSH TP,(AB)+3 CLOBST: PUSH TP,-1(TP) PUSH TP,-1(TP) MCALL 1,EVAL GETYP C,A ; CHECK IT CAME C,-1(P) ; MUST BE A CHARACTER JRST WTYP2 IDPB B,-2(TP) ;CLOBBER SOSLE (P) ;FINISHED? JRST CLOBST ;NO SUB P,C%22 SUB TP,C%66 MOVE A,(TP)+1 MOVE B,(TP)+2 JRST FINIS ; HERE TO CHECK TO SEE WHETHER PURE RSUBR'S ARE MAPPED BELOW FRETOP AND ; PUNT SOME IF THERE ARE. INQAGC: PUSH P,C PUSH P,B PUSH P,A PUSH P,E PUSHJ P,SQKIL JSP E,CKPUR ; CHECK FOR PURE RSUBR POP P,E MOVE A,PURTOP SUB A,CURPLN MOVE B,RFRETP ; GET REAL FRETOP CAIL B,(A) MOVE B,A ; TOP OF WORLD MOVE A,GCSTOP ADD A,GETNUM ADDI A,1777 ; PAGE BOUNDARY ANDCMI A,1777 CAIL A,(B) ; SEE WHETHER THERE IS ROOM JRST GOTOGC PUSHJ P,CLEANT POP P,A POP P,B POP P,C POPJ P, GOTOGC: POP P,A POP P,B POP P,C ; RESTORE CAUSE INDICATOR MOVE A,P.TOP PUSHJ P,CLEANT ; CLEAN UP SKIPL PLODR ; IF IN PLOAD DON'T INTERRUPT JRST INTAGC ; GO CAUSE GARBAGE COLLECT JRST SAGC CLEANT: PUSH P,C PUSH P,A SUB A,P.TOP ASH A,-PGSZ JUMPE A,CLNT1 PUSHJ P,GETPAG ; GET THOSE PAGES FATAL CAN'T GET PAGES NEEDED MOVE A,(P) ASH A,-10. ; TO PAGES PUSHJ P,P.CORE PUSHJ P,SLEEPR CLNT1: PUSHJ P,RBLDM POP P,A POP P,C POPJ P, ; RCLVEC DISTASTEFUL VECTOR RECYCLER ; Arrive here with B pointing to first recycler, A desired length RCLVEC: PUSH P,D ; Save registers PUSH P,C PUSH P,E MOVEI D,RCLV ; Point to previous recycle for splice RCLV1: HLRZ C,(B) ; Get size of this block CAIL C,(A) ; Skip if too small JRST FOUND1 RCLV2: MOVEI D,(B) ; Save previous pointer HRRZ B,(B) ; Point to next block JUMPN B,RCLV1 ; Jump if more blocks POP P,E POP P,C POP P,D JRST NORCL ; Go to normal allocator FOUND1: CAIN C,1(A) ; Exactly 1 greater? JRST RCLV2 ; Cant use this guy HRLM A,(B) ; Smash in new count TLO A,.VECT. ; make vector bit be on HLLM A,-1(B) CAIE C,(A) ; Exactly right length? JRST FOUND2 ; No, do hair HRRZ C,(B) ; Point to next block HRRM C,(D) ; Smash previous pointer HRRM B,(B) SUBI B,-1(A) ; Point to top of block JRST FOUND3 FOUND2: SUBI C,(A) ; Amount of left over to C HRRZ E,(B) ; Point to next block HRRM B,(B) SUBI B,(A) ; Point to dope words of guy to put back MOVSM C,(B) ; Smash in count MOVSI C,.VECT. ; Get vector bit MOVEM C,-1(B) ; Make sure it is a vector HRRM B,(D) ; Splice him in HRRM E,(B) ; And the next guy also ADDI B,1 ; Point to start of vector FOUND3: HRROI B,(B) ; Make an AOBJN pointer TLC B,-3(A) HRRI A,TVEC SKIPGE A HRRI A,TUVEC MOVSI A,(A) POP P,E POP P,C POP P,D POPJ P, END