fpc/rtl/m68k/heap.inc

{
    $Id$
    This file is part of the Free Pascal run time library.
    Copyright (c) 1993,97 by the Free Pascal development team.

    See the file COPYING.FPC, included in this distribution,
    for details about the copyright.

    This program 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.

 **********************************************************************}

{****************************************************************************
               functions for heap management in the data segment
 ****************************************************************************}
{**** 10/06/97 added checkings and corrected some bugs in getmem/freemem ****}
{**** Pierre Muller *********************************************************}

{ three conditionnals here }

{ TEMPHEAP to  allow to split the heap in two parts for easier release}
{ started for the compiler }
{ USEBLOCKS if you want special allocation for small blocks }
{ CHECKHEAP if you want to test the heap integrity }

{$IfDef CHECKHEAP}
    { 4 levels of tracing }
    const tracesize = 4;
    type   pheap_mem_info = ^heap_mem_info;
           heap_mem_info = record
           next,previous : pheap_mem_info;
           size : longint;
           sig : longint; {dummy number for test }
           calls : array [1..tracesize] of longint;
           end;
           { size 8*4 = 32 }
    { help variables for debugging with GDB }
    const check : boolean = false;
    const last_assigned : pheap_mem_info = nil;
    const growheapstop : boolean = false;

    const free_nothing : boolean = false;
    const trace : boolean = true;
    const getmem_nb : longint = 0;
    const freemem_nb : longint = 0;
{$EndIf CHECKHEAP}

    const
       heap_split : boolean = false;
       max_size = 256;
       maxblock = max_size div 8;
       freerecord_list_length : longint = 0;

    var
       _memavail : longint;
       _internal_heapsize : longint;

    type
{$ifdef UseBlocks}
       tblocks   = array[1..maxblock] of pointer;
       pblocks   = ^tblocks;
       tnblocks  = array[1..maxblock] of longint;
       pnblocks  = ^tnblocks;
{$endif UseBlocks}
       pheapinfo = ^theapinfo;
       theapinfo = record
         heaporg,heapptr,heapend,freelist : pointer;
         memavail,heapsize : longint;
{$ifdef UseBlocks}
         block : pblocks;
         nblock : pnblocks;
{$endif UseBlocks}
{$IfDef CHECKHEAP}
        last_mem : pheap_mem_info;
        nb_get,nb_free : longint;
{$EndIf CHECKHEAP}
         end;
    type
       pfreerecord = ^tfreerecord;

       tfreerecord = record
          next : pfreerecord;
          size : longint;
       end;

    var
       baseheap : theapinfo;
       curheap : pheapinfo;
{$ifdef TEMPHEAP}
       tempheap : theapinfo;
       otherheap : pheapinfo;
{$endif TEMPHEAP}

{$ifdef UseBlocks}
       baseblocks : tblocks;
       basenblocks : tnblocks;
{$endif UseBlocks}

{ this is not supported by FPK <v093
    const
       blocks : pblocks = @baseblocks;
       nblocks : pnblocks = @basenblocks; }
      type
         ppointer = ^pointer;

{$ifdef UseBlocks}
    var blocks : pblocks;
        nblocks : pnblocks;
{$endif UseBlocks}



    { Get start address of HEAP, this works well }
    { with AMIGA, ATARI, but for the MAC, the    }
    { HEAP is a pointer!!!                       }
{$IFNDEF MACOS}
    function getheapstart : pointer; assembler;
    asm
       lea.l HEAP,a0
       move.l a0,d0
    end;
{$ELSE}
    function getheapstart : pointer; assembler;
    asm
       move.l HEAP,d0
    end;

{$ENDIF MACOS}

    function getheapsize : longint; assembler;
    asm
       move.l HEAP_SIZE,d0
    end ['d0'];


    function heapsize : longint;

	  begin
		 heapsize:=_internal_heapsize;
      end;

{$IfDef CHECKHEAP}
    procedure call_stack(p : pointer);
      var i : longint;
          pp : pheap_mem_info;
      begin

        if trace then
          begin
             pp:=pheap_mem_info(p-sizeof(heap_mem_info));
             writeln('Call trace of 0x',hexstr(longint(p),8));
             writeln('of size ',pp^.size);
             for i:=1 to tracesize do
               begin
                 writeln(i,' 0x',hexstr(pp^.calls[i],8));
               end;
          end
        else
          writeln('tracing not enabled, sorry !!');
      end;

    procedure dump_heap(mark : boolean);
      var pp : pheap_mem_info;
      begin
         pp:=last_assigned;
         while pp<>nil do
           begin
              call_stack(pp+sizeof(heap_mem_info));
              if mark then
                pp^.sig:=$AAAAAAAA;
              pp:=pp^.previous;
           end;
      end;

    procedure dump_free(p : pheap_mem_info);
      var bp : longint;
      begin
         Writeln('Marked memory at ',HexStr(longint(p),8),' released');
         call_stack(p+sizeof(heap_mem_info));
         asm
            move.l (a6),a0
            move.l (a0),d0
            move.l d0,bp
         end;
         dump_stack(bp);
      end;

    function is_in_getmem_list (p : pointer) : boolean;
        var pp : pheap_mem_info;
            i : longint;
      begin
        is_in_getmem_list:=false;
        pp:=last_assigned;
        i:=0;
        while pp<>nil do
          begin
             if (pp^.sig<>$DEADBEEF) and (pp^.sig <> $AAAAAAAA) then
               begin
                  writeln('error in linked list of heap_mem_info');
                  runerror(204);
               end;

             if pp=p then
               begin
                  is_in_getmem_list:=true;
               end;
             pp:=pp^.previous;
             inc(i);
             if i > getmem_nb - freemem_nb then
               writeln('error in linked list of heap_mem_info');
          end;
      end;

    function is_in_free(p : pointer) : boolean;

      var
         hp : pfreerecord;

      begin
         if p>heapptr then
           begin
              is_in_free:=true;
              exit;
           end
         else
           begin
              hp:=freelist;
              while assigned(hp) do
                begin
                   if (p>=hp) and (p<hp+hp^.size) then
                     begin
                        is_in_free:=true;
                        exit;
                     end;
                   hp:=hp^.next;
                end;
              is_in_free:=false;
           end;
      end;
{$EndIf CHECKHEAP}

    function cal_memavail : longint;

      var
         hp : pfreerecord;
         i,ma : longint;

      begin
         ma:=heapend-heapptr;
{$ifdef UseBlocks}
         for i:=1 to maxblock do
           ma:=ma+i*8*nblocks^[i];
{$endif UseBlocks}
         hp:=freelist;
         while assigned(hp) do
           begin
              ma:=ma+hp^.size;
{$IfDef CHECKHEAP}
              if (longint(hp^.next)=0) then
                begin
                   if ((longint(hp)+hp^.size)>longint(heapptr)) then
                     writeln('freerecordlist bad at end ')
                end
              else
		          if ((longint(hp^.next)<=(longint(hp)+hp^.size)) or
		             ((hp^.size mod 8) <> 0)) then
                  writeln('error in freerecord list ');
{$EndIf CHECKHEAP}
              hp:=hp^.next;
           end;
         cal_memavail:=ma;
      end;

{$ifdef TEMPHEAP}
    procedure split_heap;
      var i :longint;
    begin
    if not heap_split then
      begin
      baseheap.heaporg:=heaporg;
      baseheap.heapptr:=heapptr;
      baseheap.freelist:=freelist;
      baseheap.block:=blocks;
      baseheap.nblock:=nblocks;
      longint(baseheap.heapend):=((longint(heapend)+longint(heapptr)) div 16)*8;
      tempheap.heaporg:=baseheap.heapend;
      tempheap.freelist:=nil;
      tempheap.heapptr:=tempheap.heaporg;
{$IfDef CHECKHEAP}
      tempheap.last_mem:=nil;
      tempheap.nb_get:=0;
      tempheap.nb_free:=0;
{$EndIf CHECKHEAP}
      tempheap.heapend:=heapend;
      tempheap.memavail:=longint(tempheap.heapend) - longint(tempheap.heaporg);
      tempheap.heapsize:=tempheap.memavail;
      getmem(tempheap.block,sizeof(tblocks));
      getmem(tempheap.nblock,sizeof(tnblocks));
      for i:=1 to maxblock do
        begin
        tempheap.block^[i]:=nil;
        tempheap.nblock^[i]:=0;
        end;
      heapend:=baseheap.heapend;
      _memavail:=cal_memavail;
      baseheap.memavail:=_memavail;
      baseheap.heapsize:=longint(baseheap.heapend)-longint(baseheap.heaporg);
      curheap:=@baseheap;
      otherheap:=@tempheap;
      heap_split:=true;
      end;
    end;

    procedure switch_to_temp_heap;
    begin
    if curheap = @baseheap then
      begin
      baseheap.heaporg:=heaporg;
      baseheap.heapend:=heapend;
      baseheap.heapptr:=heapptr;
      baseheap.freelist:=freelist;
      baseheap.memavail:=_memavail;
      baseheap.block:=blocks;
      baseheap.nblock:=nblocks;
{$IfDef CHECKHEAP}
      baseheap.last_mem:=last_assigned;
      last_assigned:=tempheap.last_mem;
      baseheap.nb_get:=getmem_nb;
      baseheap.nb_free:=freemem_nb;
      getmem_nb:=tempheap.nb_get;
      freemem_nb:=tempheap.nb_free;
{$EndIf CHECKHEAP}
      heaporg:=tempheap.heaporg;
      heapptr:=tempheap.heapptr;
      freelist:=tempheap.freelist;
      heapend:=tempheap.heapend;
      blocks:=tempheap.block;
      nblocks:=tempheap.nblock;
      _memavail:=cal_memavail;
      curheap:=@tempheap;
      otherheap:=@baseheap;
      end;
    end;

    procedure switch_to_base_heap;
    begin
    if curheap = @tempheap then
      begin
      tempheap.heaporg:=heaporg;
      tempheap.heapend:=heapend;
      tempheap.heapptr:=heapptr;
      tempheap.freelist:=freelist;
      tempheap.memavail:=_memavail;
{$IfDef CHECKHEAP}
      tempheap.last_mem:=last_assigned;
      last_assigned:=baseheap.last_mem;
      tempheap.nb_get:=getmem_nb;
      tempheap.nb_free:=freemem_nb;
      getmem_nb:=baseheap.nb_get;
      freemem_nb:=baseheap.nb_free;
{$EndIf CHECKHEAP}
      heaporg:=baseheap.heaporg;
      heapptr:=baseheap.heapptr;
      freelist:=baseheap.freelist;
      heapend:=baseheap.heapend;
      blocks:=baseheap.block;
      nblocks:=baseheap.nblock;
      _memavail:=cal_memavail;
      curheap:=@baseheap;
      otherheap:=@tempheap;
      end;
    end;

    procedure switch_heap;
    begin
    if not heap_split then split_heap;
    if curheap = @tempheap then
      switch_to_base_heap
      else
      switch_to_temp_heap;
    end;

    procedure gettempmem(var p : pointer;size : longint);

    begin
       split_heap;
       switch_to_temp_heap;
       allow_special:=true;
       getmem(p,size);
       allow_special:=false;
    end;
{$endif TEMPHEAP}

    function memavail : longint;

      begin
         memavail:=_memavail;
      end;

{$ifdef TEMPHEAP}
    procedure unsplit_heap;
    var hp,hp2,thp : pfreerecord;
    begin
    {heapend can be modified by HeapError }
    if not heap_split then exit;
    if baseheap.heapend = tempheap.heaporg then
      begin
      switch_to_base_heap;
      hp:=pfreerecord(freelist);
      if assigned(hp) then
        while assigned(hp^.next) do hp:=hp^.next;
      if tempheap.heapptr<>tempheap.heaporg then
        begin
           if hp<>nil then
             hp^.next:=heapptr;
           hp:=pfreerecord(heapptr);
           hp^.size:=heapend-heapptr;
           hp^.next:=tempheap.freelist;
           heapptr:=tempheap.heapptr;
        end;
      heapend:=tempheap.heapend;
      _memavail:=cal_memavail;
      heap_split:=false;
      end else
      begin
      hp:=pfreerecord(baseheap.freelist);
      hp2:=pfreerecord(tempheap.freelist);
      while assigned(hp) and assigned(hp2) do
        begin
        if hp=hp2 then break;
        if hp>hp2 then
          begin
          thp:=hp2;
          hp2:=hp;
          hp:=thp;
          end;
        while assigned(hp^.next) and (hp^.next<hp2) do
            hp:=hp^.next;
        if assigned(hp^.next) then
            begin
            thp:=hp^.next;
            hp^.next:=hp2;
            hp:=thp;
            end else
            begin
            hp^.next:=hp2;
            hp:=nil;
            end;
          end ;
      if heapend < tempheap.heapend then
        heapend:=tempheap.heapend;
      if heapptr < tempheap.heapptr then
        heapptr:=tempheap.heapptr;
      freemem(tempheap.block,sizeof(tblocks));
      freemem(tempheap.nblock,sizeof(tnblocks));
      _memavail:=cal_memavail;
      heap_split:=false;
      end;
    end;

    procedure releasetempheap;
    begin
    switch_to_temp_heap;
{$ifdef CHECKHEAP}
    if heapptr<>heaporg then
      writeln('Warning in releasetempheap : ',longint(tempheap.heapsize)-longint(tempheap.memavail),' bytes used !');
    dump_heap(true);
{    release(heaporg);
    fillchar(heaporg^,longint(heapend)-longint(heaporg),#0);}
{$endif CHECKHEAP }
    unsplit_heap;
    split_heap;
    end;
{$endif TEMPHEAP}

    function maxavail : longint;

      var
         hp : pfreerecord;

      begin
         maxavail:=heapend-heapptr;
         hp:=freelist;
         while assigned(hp) do
           begin
              if hp^.size>maxavail then
                maxavail:=hp^.size;
              hp:=hp^.next;
           end;
      end;

{$ifdef CHECKHEAP}
     procedure test_memavail;

       begin
          if check and (_memavail<>cal_memavail) then
            begin
               writeln('Memavail error in getmem/freemem');
            end;
       end;
{$endif CHECKHEAP}

    procedure getmem(var p : pointer;size : longint);[public,alias: 'GETMEM'];

{$IfDef CHECKHEAP}
      var i,bp,orsize : longint;
      label check_new;
{$endif CHECKHEAP}

      { changed to removed the OS conditionnals }
      function call_heaperror(addr : pointer; size : longint) : integer;
        begin
           asm
              move.l  size,-(sp)
              move.l  addr,a0
              jsr     (a0)
              move.w  d0,@Result
           end;
        end;

      var
         last,hp : pfreerecord;
         nochmal : boolean;
         s : longint;

      begin
{$ifdef CHECKHEAP}
         if trace then
           begin
              orsize:=size;
              size:=size+sizeof(heap_mem_info);
           end;
{$endif CHECKHEAP}
         if size=0 then
           begin
              p:=heapend;
{$ifdef CHECKHEAP}
              goto check_new;
{$else CHECKHEAP}
              exit;
{$endif CHECKHEAP}
           end;
{$ifdef TEMPHEAP}
         if heap_split and not allow_special then
           begin
           if (@p < otherheap^.heapend) and
              (@p > otherheap^.heaporg) then
              { useful line for the debugger }
             writeln('warning : p and @p are in different heaps !');
           end;
{$endif TEMPHEAP}
         { calc to multiply of 8 }
         if (size mod 8)<>0 then
           size:=size+(8-(size mod 8));
         dec(_memavail,size);
{$ifdef UseBlocks}
         { search cache }
         if size<=max_size then
           begin
              s:=size div 8;
              if assigned(blocks^[s]) then
                begin
                   p:=blocks^[s];
                   blocks^[s]:=pointer(blocks^[s]^);
                   dec(nblocks^[s]);
{$ifdef CHECKHEAP}
                   goto check_new;
{$else CHECKHEAP}
                   exit;
{$endif CHECKHEAP}
                end;
           end;
{$endif UseBlocks}
         repeat
           nochmal:=false;
           { search the freelist }
           if assigned(freelist) then
             begin
                last:=nil;
                hp:=freelist;
                while assigned(hp) do
                  begin
                     { take the first fitting block }
                     if hp^.size>=size then
                       begin
                          p:=hp;
                          { need we the whole block ? }
                          if hp^.size>size then
                            begin
{$ifdef UseBlocks}
                               { we must check if we are still below the limit !! }
                               if hp^.size-size<=max_size then
                                 begin
                                    { adjust the list }
                                    if assigned(last) then
                                      last^.next:=hp^.next
                                    else
                                      freelist:=hp^.next;
                                    { insert in chain }
                                    s:=(hp^.size-size) div 8;
                                    ppointer(hp+size)^:=blocks^[s];
                                    blocks^[s]:=hp+size;
                                    inc(nblocks^[s]);
                                 end
                               else
{$endif UseBlocks}
                               begin
                                  (hp+size)^.size:=hp^.size-size;
                                  (hp+size)^.next:=hp^.next;
                                  if assigned(last) then
                                    last^.next:=hp+size
                                  else
                                    freelist:=hp+size;
                               end;
                            end
                          else
                            begin
{$IfDef CHECKHEAP}
                               dec(freerecord_list_length);
{$endif CHECKHEAP}
                               if assigned(last) then
                                 last^.next:=hp^.next
                               else
                                 {this was wrong !!}
                                 {freelist:=nil;}
                                 freelist:=hp^.next;
                            end;
{$ifdef CHECKHEAP}
                            goto check_new;
{$else CHECKHEAP}
                            exit;
{$endif CHECKHEAP}
                       end;
                     last:=hp;
                     hp:=hp^.next;
                  end;
             end;
           { Latly, the top of the heap is checked, to see if there is }
           { still memory available.                                   }
           if heapend-heapptr<size then
             begin
                if assigned(heaperror) then
                  begin
                     case call_heaperror(heaperror,size) of
                        0 : runerror(203);
                        1 : p:=nil;
                        2 : nochmal:=true;
                     end;
                  end
                else
                  runerror(203);
             end
           else
             begin
                p:=heapptr;
                heapptr:=heapptr+size;
             end;
         until not nochmal;
{$ifdef CHECKHEAP}
check_new:
     inc(getmem_nb);
     test_memavail;
     if trace then
       begin
           asm
              move.l (a6),d0
              move.l d0,bp
           end;
          pheap_mem_info(p)^.sig:=$DEADBEEF;
          pheap_mem_info(p)^.previous:=last_assigned;
          if last_assigned<>nil then
            last_assigned^.next:=pheap_mem_info(p);
          last_assigned:=p;
          pheap_mem_info(p)^.next:=nil;
          pheap_mem_info(p)^.size:=orsize;
          for i:=1 to tracesize do
            begin
               pheap_mem_info(p)^.calls[i]:=get_addr(bp);
               bp:=get_next_frame(bp);
            end;
          p:=p+sizeof(heap_mem_info);
       end;
{$endif CHECKHEAP}
      end;

    procedure freemem(var p : pointer;size : longint);[public,alias: 'FREEMEM'];

      var
         hp : pfreerecord;
{$ifdef TEMPHEAP}
         heap_switched : boolean;
{$endif TEMPHEAP}
         s : longint;

      label freemem_exit;

      begin
{$ifdef CHECKHEAP}
         if free_nothing then
           begin
              p:=nil;
              exit;
           end;
     if trace then
       begin
          size:=size+sizeof(heap_mem_info);
          p:=p-sizeof(heap_mem_info);
          { made after heap_switch
          if not (is_in_getmem_list(p)) then
            runerror(204); }
       end;
{$endif CHECKHEAP}
         if size=0 then
           begin
              p:=nil;
              exit;
           end;
         if p=nil then RunError (204);
{$ifdef TEMPHEAP}
         heap_switched:=false;
         if heap_split and not allow_special then
           begin
              if (p <= heapptr) and
                 ( p >= heaporg) and
                 (@p <= otherheap^.heapend) and
                 (@p >= otherheap^.heaporg) then
                begin
                   writeln('warning : p and @p are in different heaps !');
                end;
           end;
         if (p<heaporg) or (p>heapptr) then
           begin
              if heap_split and (p<otherheap^.heapend) and
                 (p>otherheap^.heaporg) then
                begin
                   if (@p >= heaporg) and
                      (@p <= heapptr) and
                      not allow_special then
                      writeln('warning : p and @p are in different heaps !');
                   switch_heap;
                   heap_switched:=true;
                end
              else
                begin
                   writeln('pointer ',hexstr(longint(@p),8),' at ',
                     hexstr(longint(p),8),' doesn''t points to the heap');
                   runerror(204);
                end;
           end;
{$endif TEMPHEAP}
{$ifdef CHECKHEAP}
     if trace then
       begin
          if not (is_in_getmem_list(p)) then
            runerror(204);
          if pheap_mem_info(p)^.sig=$AAAAAAAA then
            dump_free(p);
          if pheap_mem_info(p)^.next<>nil then
            pheap_mem_info(p)^.next^.previous:=pheap_mem_info(p)^.previous;
          if pheap_mem_info(p)^.previous<>nil then
            pheap_mem_info(p)^.previous^.next:=pheap_mem_info(p)^.next;
          if pheap_mem_info(p)=last_assigned then
            last_assigned:=last_assigned^.previous;
       end;
{$endif CHECKHEAP}
         { calc to multiple of 8 }
       	size:=(size+7) and not 7;
         _memavail:=_memavail+size;
         if p+size>=heapptr then
           heapptr:=p
{$ifdef UseBlocks}
         { insert into cache }
         else if size<=max_size then
           begin
              s:=size div 8;
              ppointer(p)^:=blocks^[s];
              blocks^[s]:=p;
              inc(nblocks^[s]);
           end
{$endif UseBlocks}
         else
           begin
              { size can be allways set }
              pfreerecord(p)^.size:=size;

              { if there is no free list }
              if not assigned(freelist) then
                begin
                   { then generate one }
                   freelist:=p;
                   pfreerecord(p)^.next:=nil;
{$ifdef CHECKHEAP}
                   inc(freerecord_list_length);
{$endif CHECKHEAP}
                   goto freemem_exit;
                end;
              if p+size<freelist then
                begin
                pfreerecord(p)^.next:=freelist;
                freelist:=p;
{$ifdef CHECKHEAP}
                inc(freerecord_list_length);
{$endif CHECKHEAP}
                goto freemem_exit;
                end
              else
              if p+size=freelist then
                begin
                inc(pfreerecord(p)^.size,pfreerecord(freelist)^.size);
                pfreerecord(p)^.next:=pfreerecord(freelist)^.next;
                freelist:=p;
                { but now it can also connect the next block !!}
                if p+pfreerecord(p)^.size=pfreerecord(p)^.next then
                  begin
                     inc(pfreerecord(p)^.size,pfreerecord(p)^.next^.size);
{$ifdef CHECKHEAP}
                     dec(freerecord_list_length);
{$endif CHECKHEAP}
                     pfreerecord(p)^.next:=pfreerecord(freelist)^.next^.next;
                  end;
                goto freemem_exit;
                end;
              { search the insert position }
              hp:=freelist;
              while assigned(hp) do
                begin
                   if p<hp+hp^.size then
                      begin
                      writeln('pointer to dispose at ',hexstr(longint(p),8),
                        ' has already been disposed');
                      runerror(204);
                      end;
                   { connecting two blocks ? }
                   if hp+hp^.size=p then
                      begin
                         inc(hp^.size,size);
                         { connecting also to next block ? }
                         if hp+hp^.size=hp^.next then
                           begin
                              inc(hp^.size,hp^.next^.size);
{$ifdef CHECKHEAP}
                              dec(freerecord_list_length);
{$endif CHECKHEAP}
                              hp^.next:=hp^.next^.next;
                           end
                         else
                         if (hp^.next<>nil) and (hp+hp^.size>hp^.next) then
                           begin
                              writeln('pointer to dispose at ',hexstr(longint(p),8),
                                ' is too big !!');
                              runerror(204);
                            end;
                         break;
                      end
                   { if the end is reached, then concat }
                   else if hp^.next=nil then
                     begin
                        hp^.next:=p;
{$ifdef CHECKHEAP}
                        inc(freerecord_list_length);
{$endif CHECKHEAP}
                        pfreerecord(p)^.next:=nil;
                        break;
                     end
                   { falls der n„chste Zeiger gr”áer ist, dann }
                   { Einh„ngen                                 }
                   else if hp^.next>p then
                     begin
                        { connect to blocks }
                        if p+size=hp^.next then
                          begin
                             pfreerecord(p)^.next:=hp^.next^.next;
                             inc(pfreerecord(p)^.size,hp^.next^.size);
                             { we have to reset the right position }
                             hp^.next:=pfreerecord(p);
                          end
                        else
                          begin
                             pfreerecord(p)^.next:=hp^.next;
                             hp^.next:=p;
{$ifdef CHECKHEAP}
                             inc(freerecord_list_length);
{$endif CHECKHEAP}
                          end;
                        break;
                     end;
                   hp:=hp^.next;
                end;
           end;
         freemem_exit:
{$ifdef CHECKHEAP}
         inc(freemem_nb);
         test_memavail;
{$endif CHECKHEAP}
         p:=nil;
{$ifdef TEMPHEAP}
         if heap_switched then switch_heap;
{$endif TEMPHEAP}
      end;

    procedure release(var p : pointer);

      begin
         heapptr:=p;
         freelist:=nil;
         _memavail:=cal_memavail;
      end;

    procedure mark(var p : pointer);

      begin
         p:=heapptr;
      end;

    procedure markheap(var oldfreelist,oldheapptr : pointer);

      begin
         oldheapptr:=heapptr;
         oldfreelist:=freelist;
         freelist:=nil;
         _memavail:=cal_memavail;
      end;

    procedure releaseheap(oldfreelist,oldheapptr : pointer);

      begin
         heapptr:=oldheapptr;
         if longint(freelist) < longint(heapptr) then
           begin
           {here we should reget the freed blocks}
           end;
         freelist:=oldfreelist;
         _memavail:=cal_memavail;
      end;

{ the sbrk  function is moved to the system.pp }
{ as it is system dependent !!                 }
function growheap(size :longint) : integer;

  var NewPos,wantedsize : longint;
         hp : pfreerecord;
    Newlimit : longint;

begin
   wantedsize:=size;
   size:=size+$ffff;
   size:=size and $ffff0000;
   { Allocate by 64K size }
   { first try 1Meg }
   if Size<$100000 then
     begin
        NewPos:=Sbrk($100000);
        if NewPos > 0 then
          Size:=$100000;
     end
   else
     NewPos:=Sbrk(size);
   if NewPos=-1 then
     NewPos:=Sbrk(size);
   if (NewPos = -1) then
     begin
        GrowHeap:=0;
        {$IfDef CHECKHEAP}
        writeln('Call to GrowHeap failed');
        readln;
        {$EndIf CHECKHEAP}
        Exit;
     end
   else
     begin
     { make the room clean }
{$ifdef CHECKHEAP}
        Fillword(pointer(NewPos)^,size div 2,$ABCD);
        Newlimit:= (newpos+size) or $3fff;
{$else }
        Fillchar(pointer(NewPos)^,size,#0);
{$endif }
        hp:=pfreerecord(freelist);
        if not assigned(hp) then
          begin
          if pointer(newpos) = heapend then
            heapend:=pointer(newpos+size)
          else
            begin
               if heapend - heapptr > 0 then
                 begin
                    freelist:=heapptr;
                    hp:=pfreerecord(freelist);
                    hp^.size:=heapend-heapptr;
                    hp^.next:=nil;
                 end;
               heapptr:=pointer(newpos);
               heapend:=pointer(newpos+size);
            end;
          end
        else
          begin
             if pointer(newpos) = heapend then
               heapend:=pointer(newpos+size)
             else
               begin
                  while assigned(hp^.next) and (longint(hp^.next) < longint(NewPos)) do
                    hp:=hp^.next;
                  if hp^.next = nil then
                    begin
                       hp^.next:=pfreerecord(heapptr);
                       hp:=pfreerecord(heapptr);
                       hp^.size:=heapend-heapptr;
                       hp^.next:=nil;
                       heapptr:=pointer(NewPos);
                       heapend:=pointer(NewPos+Size);
                    end
                  else
	            begin
                       pfreerecord(NewPos)^.Size:=Size;
                       pfreerecord(NewPos)^.Next:=hp^.next;
                       hp^.next:=pfreerecord(NewPos);
                    end;
               end;
          end;
        { the wanted size has to be substracted
          why it will be substracted in the second try
          to get the memory PM }
		  _memavail:=cal_memavail;
        { set the total new heap size }
        asm
          move.l Size,d0
          move.l HEAP_SIZE,d1
          add.l  d0,d1
          move.l d1,HEAP_SIZE
        end;
        GrowHeap:=2;{ try again }
        _internal_heapsize:=size+_internal_heapsize;
{$IfDef CHECKHEAP}
        writeln('Call to GrowHeap succedeed : HeapSize = ',_internal_heapsize,' MemAvail = ',memavail);
        writeln('New heap part begins at ',Newpos,' with size ',size);
        if growheapstop then
          readln;
{$EndIf CHECKHEAP}
        exit;
     end;
end;


{ This function will initialize the Heap manager and need to be called from
  the initialization of the system unit }
procedure InitHeap;
{$ifdef UseBlocks}
var
  i : longint;
{$endif UseBlocks}  
begin
{$ifdef UseBlocks}
  Blocks:=@baseblocks;
  Nblocks:=@basenblocks;
  for i:=1 to maxblock do
   begin
     Blocks^[i]:=nil;
     Nblocks^[i]:=0;
   end;
{$endif UseBlocks}
  Curheap := @baseheap;
{$ifdef TEMPHEAP}
  Otherheap := @tempheap;
{$endif TEMPHEAP}
  HeapOrg := GetHeapStart;
  HeapPtr := HeapOrg;
  _memavail := GetHeapSize;
  HeapEnd := HeapOrg + _memavail;
  HeapError := @GrowHeap;
  _internal_heapsize:=longint(heapend)-longint(heaporg);
  Freelist := nil;
end;

{
  $Log$
  Revision 1.8  1998-09-04 17:27:09  pierre
    * small modifications

  Revision 1.7  1998/08/25 14:15:53  pierre
    * corrected a bug introduced by my last change
      (allocating 1Mb but only using a small part !!)

  Revision 1.6  1998/08/24 14:44:05  pierre
    * bug allocation of more than 1 MB failed corrected

  Revision 1.5  1998/08/17 12:27:17  carl
    * bugfix of heaperror, was pushing wrong parameter

  Revision 1.4  1998/07/08 11:54:40  carl
    + reinstated hepasize function
    * renamed HEAPSIZE global var to HEAP_SIZE to remove conflicts

  Revision 1.3  1998/07/02 14:24:08  michael
  Undid carls changes, but renamed _heapsize to _internal_heapsize. Make cycle now works

  Revision 1.2  1998/07/02 12:22:38  carl
    - removed heapsize function, would cause conflicts with HEAPSIZE var
    * GetHeapstart was misplaced

  Revision 1.1.1.1  1998/03/25 11:18:44  root
  * Restored version

  Revision 1.3  1998/01/26 12:01:52  michael
  + Added log at the end


  
  Working file: rtl/m68k/heap.inc
  description:
  ----------------------------
  revision 1.2
  date: 1998/01/05 16:51:24;  author: michael;  state: Exp;  lines: +31 -1
  + Moved init of heap to heap.inc: INITheap() (From Peter Vreman)
  ----------------------------
  revision 1.1
  date: 1998/01/05 00:32:44;  author: carl;  state: Exp;
  + First Version of m68k heap handler (handles amiga/macos/atari)
  =============================================================================
}