{
Copyright (C) 1991-99 Free Software Foundation, Inc.

Authors: Jukka Virtanen <jtv@hut.fi>
         Frank Heckenbach <frank@pascal.gnu.de>

Heap management routines

This file is part of GNU Pascal Library. The GNU Pascal Library is free
software; you can redistribute it and/or modify it under the terms of
the GNU Library General Public License as published by the Free Software
Foundation; either version 2 of the License, or (at your option) any
later version.

The GNU Pascal Library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
Library General Public License for more details.

You should have received a copy of the GNU Library General Public
License along with the GNU Pascal Library; see the file COPYING.LIB.  If
not, write to the Free Software Foundation, Inc., 675 Mass Ave,
Cambridge, MA 02139, USA.
}

unit Heap;

interface

uses GPC;

type
  GetMemType  = ^function (Size : SizeType) : Pointer;
  FreeMemType = ^procedure (aPointer : Pointer);

var
  GetMemPtr  : asmname '_p_getmem_ptr'  GetMemType;
  GetMemPtr  : GetMemType = @Default_GetMem;
  FreeMemPtr : asmname '_p_freemem_ptr' FreeMemType;
  FreeMemPtr : FreeMemType = @Default_FreeMem;

function  GPC_GetMem  (Size : SizeType) : Pointer;     asmname '_p_malloc';
procedure GPC_FreeMem (aPointer : Pointer);            asmname '_p_free';
procedure GPC_Mark    (var aPointer : Pointer);        asmname '_p_mark';
function  ReleaseFunc (aPointer : Pointer) : Integer;  asmname '_p_release';
function  GPC_New     (Size : SizeType) : Pointer;     asmname '_p_new';
procedure GPC_Dispose (aPointer : Pointer);            asmname '_p_dispose';
procedure HeapInit;                                    asmname '_p_heap_init';

implementation

type
  PMarkList = ^TMarkList;
  TMarkList = record
    Next         : PMarkList;
    PointersUsed : Integer;
    Pointers     : array [0 .. 255] of Pointer
  end;

var
  CurrentMarkList : PMarkList = nil;
  HeapBegin : Pointer = nil;
  HeapEnd   : Pointer = nil; { HeapEnd points to the LAST byte of the last object }

function GPC_GetMem (Size : SizeType) : Pointer;
begin
  GPC_GetMem := GetMemPtr^(Size)
end;

procedure GPC_FreeMem (aPointer : Pointer);
begin
  FreeMemPtr^(aPointer)
end;

procedure GPC_Mark (var aPointer : Pointer);
var Temp : PMarkList;
begin
  Temp := GPC_GetMem (SizeOf (Temp^)); { don't use `New' here }
  Temp^.Next := CurrentMarkList;
  Temp^.PointersUsed := 0;
  CurrentMarkList := Temp;
  if @aPointer <> nil then aPointer := Temp { GPC_New calls GPC_Mark (null) }
end;

function ReleaseFunc (aPointer : Pointer) = Count : Integer;
var
  Temp : PMarkList;
  i : Integer;
begin
  Count := 0;
  Temp := CurrentMarkList;
  while (Temp <> nil) and (Temp <> aPointer) do Temp := Temp^.Next;
  if Temp = nil then
    RuntimeErrorInteger (852, PtrCard (aPointer)); { cannot release object at address $%lx }
  repeat
    for i := CurrentMarkList^.PointersUsed - 1 downto 0 do
      if CurrentMarkList^.Pointers [i] <> nil then
        begin
          Inc (Count);
          GPC_FreeMem (CurrentMarkList^.Pointers [i])
        end;
    Temp := CurrentMarkList;
    CurrentMarkList := CurrentMarkList^.Next;
    GPC_FreeMem (Temp)
  until Temp = aPointer
end;

function GPC_New (Size : SizeType) = p : Pointer;
type
  PBytes = ^TBytes;
  TBytes = array [0 .. MaxVarSize div SizeOf (Byte) - 1] of Byte;
var pEnd : Pointer;
begin
  p := GPC_GetMem (Size);
  pEnd := @PBytes (p)^[Size - 1];
  if PtrCard (pEnd) > PtrCard (HeapEnd) then HeapEnd := pEnd;
  if CurrentMarkList <> nil then
    begin
      if CurrentMarkList^.PointersUsed > High (CurrentMarkList^.PointersUsed) then
        GPC_Mark (null); { this creates a new TMarkList item }
      CurrentMarkList^.Pointers [CurrentMarkList^.PointersUsed] := p;
      Inc (CurrentMarkList^.PointersUsed)
    end
end;

procedure GPC_Dispose (aPointer : Pointer);
var
  p : PMarkList;
  Found : Boolean;
  i : Integer;
begin
  if aPointer = nil then Exit;
  Found := False;
  p := CurrentMarkList;
  while (p <> nil) and not Found do
    begin
      for i := p^.PointersUsed - 1 downto 0 do
        if p^.Pointers [i] = aPointer then
          begin
            p^.Pointers [i] := nil;
            Found := True;
            Break
          end;
      p := p^.Next
    end;
  GPC_FreeMem (aPointer)
end;

procedure HeapInit;
var p : Pointer;
begin
  p := GPC_GetMem (1);
  HeapBegin := p;
  HeapEnd := p
end;

end.
