sumex/nfree.mcr032

   1 TITLE MODIFIED AFREE FOR MUDDLE\r
   2 \r
   3 RELOCATABLE\r
   4 \r
   5 .INSRT MUDDLE >\r
   6 \r
   7 .GLOBAL CAFREE,CAFRET,PARNEW,AGC,PARBOT,CODTOP,CAFRE1\r
   8 .GLOBAL STOGC,STOSTR,CAFRE,ISTOST,STOLST,SAT,ICONS,BYTDOP\r
   9 .GLOBAL FLIST,STORIC\r
  10 MFUNCTION FREEZE,SUBR\r
  11 \r
  12         ENTRY   1\r
  13 \r
  14         GETYP   A,(AB)          ; get type of it\r
  15         PUSH    TP,(AB)         ; save a copy\r
  16         PUSH    TP,1(AB)\r
  17         PUSH    P,[0]           ; flag for tupel freeze\r
  18         PUSHJ   P,SAT           ; to SAT\r
  19         MOVEI   B,0             ; final type\r
  20         CAIN    A,SNWORD        ; check valid types\r
  21         MOVSI   B,TUVEC         ; use UVECTOR\r
  22         CAIN    A,S2NWOR\r
  23         MOVSI   B,TVEC\r
  24         CAIN    A,SARGS\r
  25         MOVSI   B,TVEC\r
  26         CAIN    A,SCHSTR\r
  27         MOVSI   B,TCHSTR\r
  28         JUMPE   B,WTYP1\r
  29         PUSH    P,B             ; save final type\r
  30         CAME    B,$TCHSTR       ; special chars hack\r
  31         JRST    OK.FR\r
  32         HRR     B,(AB)          ; fixup count\r
  33         MOVEM   B,(P)\r
  34 \r
  35         MOVEI   C,(TB)          ; point to it\r
  36         PUSHJ   P,BYTDOP        ; A==> points to dope word\r
  37         HRRO    B,1(TB)\r
  38         SUBI    A,1(B)          ; A==> length of block\r
  39         TLC     B,-1(A)\r
  40         MOVEM   B,1(TB)         ; and save\r
  41         MOVSI   0,TUVEC\r
  42         MOVEM   0,(TB)\r
  43 \r
  44 OK.FR:  HLRE    A,1(TB)         ; get length\r
  45         MOVNS   A\r
  46         PUSH    P,A\r
  47         ADDI    A,2\r
  48         PUSHJ   P,CAFREE        ; get storage\r
  49         HRLZ    B,1(TB)         ; set up to BLT\r
  50         HRRI    B,(A)\r
  51         POP     P,C\r
  52         ADDI    C,(A)           ; compute end\r
  53         BLT     B,(C)\r
  54         MOVEI   B,(A)\r
  55         HLL     B,1(AB)\r
  56         POP     P,A\r
  57         JRST    FINIS\r
  58 \r
  59                 \r
  60 CAFRE:  PUSH    P,A\r
  61         HRRZ    E,STOLST+1(TVP)\r
  62         SETZB   C,D\r
  63         PUSHJ   P,ICONS         ; get list element\r
  64         PUSH    TP,$TLIST       ; and save\r
  65         PUSH    TP,B\r
  66         MOVE    A,(P)           ; restore length\r
  67         ADDI    A,2             ; 2 more for dope words\r
  68         PUSHJ   P,CAFREE        ; get the core and dope words\r
  69         POP     P,B             ; restore count\r
  70         MOVNS   B               ; build AOBJN pointer\r
  71         MOVSI   B,(B)\r
  72         HRRI    B,(A)\r
  73         MOVE    C,(TP)\r
  74         MOVEM   B,1(C)          ; save on list\r
  75         MOVSI   0,TSTORA        ; and type\r
  76         HLLM    0,(C)\r
  77         HRRZM   C,STOLST+1(TVP) ; and save as new list\r
  78         SUB     TP,[2,,2]\r
  79         POPJ    P,\r
  80         \r
  81 CAFRE1: PUSH    P,A\r
  82         ADDI    A,2\r
  83         PUSHJ   P,CAFREE\r
  84         HRROI   B,(A)           ; pointer to B\r
  85         POP     P,A             ; length back\r
  86         TLC     B,-1(A)\r
  87         POPJ    P,\r
  88 \r
  89 CAFREE: IRP     AC,,[B,C,D,E]\r
  90         PUSH    P,AC\r
  91         TERMIN\r
  92         SKIPG   A               ; make sure arg is a winner\r
  93         FATAL BAD CALL TO CAFREE\r
  94         MOVSI   A,(A)           ; count to left half for search\r
  95         MOVEI   B,FLIST         ; get first pointer\r
  96         HRRZ    C,(B)           ; c points to next block\r
  97 CLOOP:  CAMG    A,(C)           ; skip if not big enough\r
  98         JRST    CONLIS          ; found one\r
  99         MOVEI   D,(B)           ; save in case fall out\r
 100         MOVEI   B,(C)           ; point to new previous\r
 101         HRRZ    C,(C)           ; next block\r
 102         JUMPN   C,CLOOP         ; go on through loop\r
 103         HLRZ    E,A             ; count to E\r
 104         CAMGE   E,STORIC        ; skip if a area or more\r
 105         MOVE    E,STORIC        ; else use a whole area\r
 106         MOVE    C,PARBOT        ; foun out if any funny space\r
 107         SUB     C,CODTOP        ; amount around to C\r
 108         CAMLE   C,E             ; skip if must GC\r
 109         JRST    CHAVIT          ; already have it\r
 110         SUBI    E,-1(C)         ; get needed from agc\r
 111         MOVEM   E,PARNEW        ; funny arg to AGC\r
 112         PUSH    P,A\r
 113         MOVE    C,[7,,6]        ; SET UP AGC INDICATORS\r
 114         PUSHJ   P,AGC           ; collect that garbage\r
 115         SETZM   PARNEW          ; dont do it again\r
 116         AOJL    A,GCLOS         ; couldn't get core\r
 117         POP     P,A\r
 118 \r
 119 ; Make sure pointers still good after GC\r
 120 \r
 121         MOVEI   D,FLIST\r
 122         HRRZ    B,(D)\r
 123 \r
 124         HRRZ    E,(B)           ; next pointer\r
 125         JUMPE   E,.+4           ; end of list ok\r
 126         MOVEI   D,(B)\r
 127         MOVEI   B,(E)\r
 128         JRST    .-4             ; look at next\r
 129 \r
 130 CHAVIT: MOVE    E,PARBOT        ; find amount obtained\r
 131         SUBI    E,1             ; dont use a real pair\r
 132         MOVEI   C,(E)           ; for reset of CODTOP\r
 133         SUB     E,CODTOP\r
 134         EXCH    C,CODTOP        ; store it back\r
 135         CAIE    B,(C)           ; did we simply grow the last block?\r
 136         JRST    CSPLIC          ; no, splice it in\r
 137         HLRZ    C,(B)           ; length of old guy\r
 138         ADDI    C,(E)           ; total length\r
 139         ADDI    B,(E)           ; point to new last dope word\r
 140         HRLZM   C,(B)           ; clobber final length in\r
 141         HRRM    B,(D)           ; and splice into free list\r
 142         MOVEI   C,(B)           ; reset acs for reentry into loop\r
 143         MOVEI   B,(D)\r
 144         JRST    CLOOP\r
 145 \r
 146 ; Here to splice new core onto end of list.\r
 147 \r
 148 CSPLIC: MOVE    C,CODTOP        ; point to end of new block\r
 149         HRLZM   E,(C)           ; store length of new block in dope words\r
 150         HRRM    C,(D)           ; D is old previous, link it up\r
 151         MOVEI   B,(D)           ; and reset B for reentry into loop\r
 152         JRST    CLOOP\r
 153 \r
 154 ; here if an appropriate block is on the list\r
 155 \r
 156 CONLIS: HLRZS   A               ; count back to a rh\r
 157         HLRZ    D,(C)           ; length of proposed block to D\r
 158         CAIN    A,(D)           ; skip if they are different\r
 159         JRST    CEASY           ; just splice it out\r
 160         MOVEI   B,(C)           ; point to block to be chopped up\r
 161         SUBI    B,-1(D)         ; point to beginning of same\r
 162         SUBI    D,(A)           ; amount of block to be left to D\r
 163         HRLM    D,(C)           ; and fix up dope words\r
 164         ADDI    B,-1(A)         ; point to end of same\r
 165         HRLZM   A,(B)\r
 166         HRRM    B,(B)           ; for GC benefit\r
 167 \r
 168 CFREET: CAIE    A,1             ; if more than 1\r
 169         SETZM   -1(B)           ; make tasteful dope worda\r
 170         SUBI    B,-1(A)\r
 171         MOVEI   A,(B)\r
 172         IRP     AC,,[E,D,C,B]\r
 173         POP     P,AC\r
 174         TERMIN\r
 175         POPJ    P,\r
 176 \r
 177 CEASY:  MOVEI   D,(C)           ; point to block to return\r
 178         HRRZ    C,(C)           ; point to next of same\r
 179         HRRM    C,(B)           ; smash its previous\r
 180         MOVEI   B,(D)           ; point to block with B\r
 181         HRRM    B,(B)           ; for GC benefit\r
 182         JRST    CFREET\r
 183 \r
 184 GCLOS:  PUSH    TP,$TATOM\r
 185         PUSH    TP,EQUOTE NO-MORE-STORAGE\r
 186         JRST    CALER1\r
 187 \r
 188 CAFRET: HRROI   B,(B)           ; prepare to search list\r
 189         TLC     B,-1(A)         ; by making an AOBJN pointer\r
 190         HRRZ    C,STOLST+1(TVP) ; start of list\r
 191         MOVEI   D,STOLST+1(TVP)\r
 192 \r
 193 CAFRTL: JUMPE   C,CPOPJ         ; not founc\r
 194         CAME    B,1(C)          ; this it?\r
 195         JRST    CAFRT1\r
 196         HRRZ    C,(C)           ; yes splice it out\r
 197         HRRM    C,(D)           ; smash it\r
 198 CPOPJ:  POPJ    P,              ; dont do anything now\r
 199 \r
 200 CAFRT1: MOVEI   D,(C)\r
 201         HRRZ    C,(C)\r
 202         JRST    CAFRTL\r
 203 \r
 204 ; Here from GC to collect all unused blocks into free list\r
 205 \r
 206 STOGC:  SETZB   C,E             ; zero current length and pointer\r
 207         MOVE    A,CODTOP        ; get high end of free space\r
 208 \r
 209 STOGCL: CAIG    A,STOSTR        ; end?\r
 210         JRST    STOGCE          ; yes, cleanup and leave\r
 211 \r
 212         HLRZ    0,(A)           ; get length\r
 213         ANDI    0,377777\r
 214         SKIPGE  (A)             ; skip if a not used block\r
 215         JRST    STOGC1          ; jump if marked\r
 216 \r
 217         JUMPE   C,STOGC3        ; jump if no block under construction\r
 218         ADD     C,0             ; else add this length to current\r
 219         JRST    STOGC4\r
 220 \r
 221 STOGC3: MOVEI   B,(A)           ; save pointer\r
 222         MOVE    C,0             ; init length\r
 223 \r
 224 STOGC4: SUB     A,0             ; point to next block\r
 225         JRST    STOGCL\r
 226 \r
 227 STOGC1: ANDCAM  D,(A)           ; kill mark bit\r
 228         JUMPE   C,STOGC4        ; if no block under cons, dont fix\r
 229         HRLM    C,(B)           ; store total block length\r
 230         HRRM    E,(B)           ; next pointer hooked in\r
 231         MOVEI   E,(B)           ; new next pointer\r
 232         MOVEI   C,0\r
 233         JRST    STOGC4\r
 234 \r
 235 STOGCE: JUMPE   C,STGCE1        ; jump if no current block\r
 236         HRLM    C,(B)           ; smash in count\r
 237         HRRM    E,(B)           ; smash in next pointer\r
 238         MOVEI   E,(B)           ; and setup E\r
 239 \r
 240 STGCE1: HRRZM   E,FLIST+1       ; final link up\r
 241         POPJ    P,\r
 242 \r
 243 IMPURE\r
 244 \r
 245 FLIST:  .+1\r
 246         ISTOST\r
 247 \r
 248 PURE\r
 249 \r
 250 END\r
 251 \f\r