Club Amiga de Montreal - CAM/CAM_CD_1.iso/files/549b.lha/M2P_v1.0_sources/source.lzh/FStorage.mpp

Modula Implementation | 1991-08-10 | 5.3 KB | 204 lines

(*======================================================================*)

IMPLEMENTATION MODULE FStorage;

IMPORT SYSTEM;

@IF AMIGA THEN IMPORT Memory;
@ELSE          IMPORT Storage;
@END

@INCLUDE "MACROS"

@NoLongAddressing       (* I really trust this code :-) *)
@NoRangeChecks
@NoVChecks
@NoStackChecks
@NoNILChecks

(*----------------------------------------------------------------------*)
(*  Memory Tracking list structure                                      *)
(*----------------------------------------------------------------------*)

TYPE  TrackList = POINTER TO TrackNode;
      TrackNode = RECORD
                     Next : TrackList;
                     Size : LONGCARD;
                  END;

CONST TrackSize = SYSTEM.TSIZE(TrackNode);

VAR   Track : TrackList;

(*----------------------------------------------------------------------*)
(*  Type definition for the FreeList.                                   *)
(*----------------------------------------------------------------------*)

TYPE ListRec = RECORD
                  Free   :  TrackList;
                  HowMany:  CARDINAL;
               END;

CONST BlockSize = 4096;         (* Blocking factor (must be > MaxBlock) *)
      MaxBlock  = 512;          (* Maximum size block using freelist    *)
      Grain     = 8;            (* Allocations sizes are modulus Grain  *)

CONST NumFreeLists = MaxBlock DIV Grain;

VAR FreeList: ARRAY [1..NumFreeLists] OF ListRec;
           i: CARDINAL;

(*----------------------------------------------------------------------*)

PROCEDURE ALLOCATE(VAR addr:SYSTEM.ADDRESS; amount: LONGCARD);

VAR node : TrackList;
    i:     CARDINAL;
    siz:   SYSTEM.ADDRESS;

BEGIN
   IF amount > MaxBlock THEN
      addr:=NIL;
      INC(amount,TrackSize);
      @IF AMIGA THEN
         node:=Memory.AllocMem(amount,Memory.MemReqSet{Memory.MemPublic});
         IF SYSTEM.ADDRESS(node) # SYSTEM.ADDRESS(0) THEN
            node^.Size:=amount;
            addr:=SYSTEM.ADDRESS(node);
            INC(addr,TrackSize);
            node^.Next:=Track;
            Track:=node;
         END;
      @ELSE
         Storage.ALLOCATE(node,amount);
         IF node # NIL THEN
            node^.Size:=amount;
            addr:=SYSTEM.ADDRESS(node);
            INC(addr,TrackSize);
            node^.Next:=Track;
            Track:=node;
         END;
      @END
   ELSIF amount=0 THEN DISPOSEALL; HALT;
   ELSE
      INC(amount,Grain-1);
      i:=CARDINAL(amount) DIV Grain;
      WITH FreeList[i] DO
         IF Free = NIL THEN
            ALLOCATE(node,LONGCARD(BlockSize));
            IF node = NIL THEN
               addr:=NIL;
               RETURN;
            END;
            siz :=SYSTEM.ADDRESS(i*Grain);
            i := 0;
            WHILE i<HowMany DO
               node^.Next:=Free;
               Free:=node;
               node:=SYSTEM.ADDRESS(node)+siz;
               INC(i);
            END;
         END;
         addr:=Free;
         Free:=Free^.Next;
      END;
   END;
END ALLOCATE;

(*----------------------------------------------------------------------*)

PROCEDURE DEALLOCATE(VAR addr:SYSTEM.ADDRESS; amount: LONGCARD);

VAR node,follow: TrackList;
    i:           CARDINAL;

BEGIN
   IF addr # NIL THEN
      IF amount > MaxBlock THEN
         node:=Track;
         DEC(addr,TrackSize);
         WHILE (node # addr) AND (node # NIL) DO
            follow:=node;
            node:=follow^.Next;
         END;
         IF node # NIL THEN
            IF Track=node THEN
               Track:=node^.Next;
            ELSE
               follow^.Next:=node^.Next;
            END;
            @IF AMIGA THEN
               Memory.FreeMem(node,node^.Size);
            @ELSE
               Storage.DEALLOCATE(node,node^.Size);
            @END
         END;
      ELSIF amount # 0 THEN
         node:=addr;
         INC(amount,Grain-1);
         i:=CARDINAL(amount) DIV Grain;
         WITH FreeList[i] DO
            node^.Next:=Free;
            Free:=node;
         END;
      END;
      addr:=NIL;
   END;
END DEALLOCATE;

(*----------------------------------------------------------------------*)

@NoCopyStrings

PROCEDURE DUPLICATE(block: ARRAY OF SYSTEM.BYTE):SYSTEM.ADDRESS;

VAR newblock: SYSTEM.ADDRESS;
           i: CARDINAL;
         ptr: POINTER TO SYSTEM.BYTE;

BEGIN
   ALLOCATE(newblock,LONGCARD(HIGH(block)+1));
   ptr:=newblock;
   i:=0;
   WHILE (i<=HIGH(block)) DO
      ptr^:=block[i];
      INC(i);
      INC(ptr);
   END;
   RETURN newblock;
END DUPLICATE;

(*----------------------------------------------------------------------*)
(*  DISPOSALL   Walks the FreeList, disposing of all allocated memory.  *)
(*----------------------------------------------------------------------*)

PROCEDURE DISPOSEALL();

VAR next : TrackList;

BEGIN
   WHILE Track # NIL DO
      next:=Track^.Next;
      @IF AMIGA THEN
         Memory.FreeMem(Track,Track^.Size);
      @ELSE
         Storage.DEALLOCATE(Track,Track^.Size);
      @END
      Track:=next;
   END;
END DISPOSEALL;

(************************************************************************)
(*  MAIN INITIALIZATION CODE                                            *)
(************************************************************************)

BEGIN
   Track:=NIL;
   FOR i:= 1 TO NumFreeLists DO
      WITH FreeList[i] DO
         Free    := NIL;
         HowMany := BlockSize DIV (i*Grain);
      END;
   END;
END FStorage.