+ memorymanager like delphi

rtl/inc/heap.inc

@@ -24,12 +24,21 @@
 
 }
 
+{ Memory manager }
+const
+  MemoryManager: TMemoryManager = (
+    GetMem: SysGetMem;
+    FreeMem: SysFreeMem
+  );
+
+{ Default Heap }
 const
   max_size = 256;
   maxblock = max_size div 8;
-  freerecord_list_length : longint = 0;
 
 type
+  ppointer = ^pointer;
+
   pfreerecord = ^tfreerecord;
   tfreerecord = record
     next : pfreerecord;
@@ -41,26 +50,23 @@ type
   tnblocks  = array[1..maxblock] of longint;
   pnblocks  = ^tnblocks;
 
-
-  ppointer = ^pointer;
-
-
 var
   internal_memavail  : longint;
   internal_heapsize  : longint;
   baseblocks         : tblocks;
   basenblocks        : tnblocks;
 
-
 const
   blocks  : pblocks  = @baseblocks;
   nblocks : pnblocks = @basenblocks;
 
 
+{ Check Heap }
 {$IfDef CHECKHEAP}
     { 4 levels of tracing }
     const
        tracesize = 4;
+       freerecord_list_length : longint = 0;
     type
        pheap_mem_info = ^heap_mem_info;
        heap_mem_info = record
@@ -85,6 +91,7 @@ const
 {$EndIf CHECKHEAP}
 
 
+{ Temp Heap }
 {$ifdef TEMPHEAP}
     const
        heap_split : boolean = false;
@@ -109,6 +116,40 @@ const
        otherheap : pheapinfo;
 {$endif TEMPHEAP}
 
+{*****************************************************************************
+                             Memory Manager
+*****************************************************************************}
+
+procedure GetMemoryManager(var MemMgr:TMemoryManager);
+begin
+  MemMgr:=MemoryManager;
+end;
+
+
+procedure SetMemoryManager(const MemMgr:TMemoryManager);
+begin
+  MemoryManager:=MemMgr;
+end;
+
+
+function IsMemoryManagerSet:Boolean;
+begin
+  IsMemoryManagerSet:=(MemoryManager.GetMem<>@SysGetMem) or
+                      (MemoryManager.FreeMem<>@SysFreeMem);
+end;
+
+
+procedure GetMem(Var p:pointer;Size:Longint);[public,alias:{$ifdef FPCNAMES}'FPC_'+{$endif}'GETMEM'];
+begin
+  MemoryManager.GetMem(p,Size);
+end;
+
+
+procedure FreeMem(Var p:pointer;Size:Longint);[public,alias:{$ifdef FPCNAMES}'FPC_'+{$endif}'FREEMEM'];
+begin
+  MemoryManager.FreeMem(p,Size);
+end;
+
 
 {*****************************************************************************
                        Heapsize,Memavail,MaxAvail
@@ -149,12 +190,10 @@ var
 begin
   ma:=heapend-heapptr;
 { count blocks }
-
   if heapblocks then
    for i:=1 to maxblock do
     inc(ma,i*8*nblocks^[i]);
 { walk freelist }
-
   hp:=freelist;
   while assigned(hp) do
    begin
@@ -485,10 +524,10 @@ end;
 
 
 {*****************************************************************************
-                                GetMem
+                                 SysGetMem
 *****************************************************************************}
 
-procedure getmem(var p : pointer;size : longint);[public,alias: {$ifdef FPCNAMES}'FPC_'+{$endif}'GETMEM'];
+procedure SysGetMem(var p : pointer;size : longint);
 type
   heaperrorproc=function(size:longint):integer;
 var
@@ -660,10 +699,10 @@ end;
 
 
 {*****************************************************************************
-                                FreeMem
+                               SysFreeMem
 *****************************************************************************}
 
-procedure freemem(var p : pointer;size : longint);[public,alias: {$ifdef FPCNAMES}'FPC_'+{$endif}'FREEMEM'];
+procedure SysFreeMem(var p : pointer;size : longint);
 var
   hp : pfreerecord;
 {$ifdef TEMPHEAP}
@@ -929,11 +968,11 @@ begin
    { Allocate by 64K size }
    size:=(size+$fffff) and $ffff0000;
    { first try 1Meg }
-   if size<$100000 then
+   if size<GrowHeapSize then
     begin
-      NewPos:=Sbrk($100000);
+      NewPos:=Sbrk(GrowHeapSize);
       if NewPos>0 then
-       size:=$100000;
+       size:=GrowHeapSize;
     end
    else
     NewPos:=SBrk(size);
@@ -1041,7 +1080,10 @@ end;
 
 {
   $Log$
-  Revision 1.1  1998-09-14 10:48:17  peter
+  Revision 1.2  1998-10-01 14:55:17  peter
+    + memorymanager like delphi
+
+  Revision 1.1  1998/09/14 10:48:17  peter
     * FPC_ names
     * Heap manager is now system independent
 

rtl/inc/heaph.inc

@@ -14,8 +14,24 @@
 
  **********************************************************************}
 
+{ Memorymanager }
+type
+  PMemoryManager = ^TMemoryManager;
+  TMemoryManager = record
+    Getmem  : procedure(Var p:pointer;Size:Longint);
+    Freemem : procedure(Var p:pointer;Size:Longint);
+  end;
+procedure GetMemoryManager(var MemMgr: TMemoryManager);
+procedure SetMemoryManager(const MemMgr: TMemoryManager);
+function  IsMemoryManagerSet: Boolean;
+
+Procedure SysGetmem(Var p:pointer;Size:Longint);
+Procedure SysFreemem(Var p:pointer;Size:Longint);
+
+{ Variables }
 const
-  heapblocks : boolean=false;
+  heapblocks   : boolean=true;
+  growheapsize : longint=$100000;
 var
   heaporg,heapptr,heapend,heaperror,freelist : pointer;
 
@@ -47,7 +63,10 @@ Procedure releaseheap(oldfreelist,oldheapptr : pointer);
 
 {
   $Log$
-  Revision 1.6  1998-09-08 15:03:27  peter
+  Revision 1.7  1998-10-01 14:55:18  peter
+    + memorymanager like delphi
+
+  Revision 1.6  1998/09/08 15:03:27  peter
     * moved getmem/freemem/memavail/maxavail to heaph.inc
 
   Revision 1.5  1998/07/02 14:11:30  michael