<mdl.int>/nfree.mcr052.1

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