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