heapunit.pas

Delphi direct support for GIF files

unit heapunit;
{
Exports various routines that can be used to use and monitor dynamic
memory (the heap).
The most important exported procedures are GetBigMem and FreeBigMem;
these are equivalent to GetMem and FreeMem, only the amount of claimed
(freed) memory is now virtually unlimited.
Also important is the Move procedure that overrides (but uses) system's
Move procedure.

In the past, there were problems (with GetBigMem) when GlobalAllocPtr was
frequently called. To avoid this problem, the simple GetMem procedure,
also available in protected mode, is used whenever possible.
An additional advantage of this is that GetMem works considerably faster
than GlobalAllocPtr.
However, WHY there is a problem when GlobalAllocPtr is called often,
is not completely understood.

C.A. van Beest, R.P. Sterkenburg, PML-TNO Rijswijk, The Netherlands.
}
{
Revision history:
19 oct 92: - created as a unit
22 oct 92: - procedure BigFillChar added
13 nov 92: - bug in getbigmem.find_block eliminated
 1 feb 93: - now runs under Borland Pascal 7.0, with use of extended memory
             if target is 'protected mode application'
 4 mar 93: - uses 'strfunc' instead of 'strings' or 'mystrings'
 1 apr 93: - added procedure Move, that overrides system's Move procedure;
             this corrects a bug that occurs when a segment limit is crossed
           - HexAdrStr is renamed to SegOfsStr (in unit strfunc)
 6 mar 94: - added compiler directives for use with windows targets
 9 mar 94: - corrected compiler directives: dpmi memory routines (move,
             AddToAddress, GlobalAllocPtr and GlobalFreePtr) now used
             both for dpmi and windows targets
23 may 94: - added procedure BigMove
24 may 94: - renamed freebigmem to BigFreeMem
           - renamed getbigmem to BigGetMem
30 aug 94: - added procedures BigBlockwrite and BigBlockread
 7 sep 94: - changed the type of 'number' to Longint
25 oct 94: - msdos in stead of real (compiler directive)
           - changed GetBigMem: uses GetMem for small blocks
           - changed layout of compiler directive-dependent pieces
26 oct 94: - tested with RAPSCEN, RAPCAS and TESTBGAR.copy
           - Procedures for testing moved to program TESTHEAP.
27 Oct 94: - undone a few (undocumented) mistakes made at 25 Oct
28 oct 94: - Procedure BigFreemem for both protected and real mode changed
 2 Apr 95: - added startmem and usedmem, conditionally declared and used,
             for debugging purposes
 4 Apr 95: - changed result type for BigBlockWrite and -read to Longint;
             it's now also calculated correctly
           - made separate versions of BigBlockWrite and -Read for DPMI
             and real mode
           - moved mempos to 'real mode declarations'
 5 Apr 95: - tested BigMove, and it seems to work correctly, also
             in Protected mode, although it was expected to fail for
             the same reasons as BigBlockWrite etc.
 7 Apr 95: - made compilation (and good functioning) under
             Delphi possible
23 May 95: - updated USES comments for Delphi
27 Feb 96: - corrected bugs in BigBlockRead and BigBlockWrite that occurred
             when reading blocks with size being a power of 2
12 Nov 96: - All keywords to lower case
26 Mar 97: - renamed ErStop to FatalError
}

(*************************)   interface    (*************************)

const
   blocksize = 64000;
{ Since the maximum length of a contiguous piece of memory (allocated
with GetMem, deallocated with FreeMem c.q. copied by Move) is 65520,
one must use these procedures with blocks smaller than that size.
The chosen size is rather arbitrary, but easy when debugging. }

{$ifdef debug}
var startmem, usedmem: Longint;
{$endif}


procedure AddToAddress(var P: Pointer; Increment: Longint);
{ Increments the address of P with 'increment' }

procedure BigBlockWrite(var f: file; var buffer;
                            number: Longint; var Result: Longint);
{ Same as BlockWrite (Turbo Pascal) but permits writing of blocks
greater than the BP block size of at most 65535 }

procedure BigBlockRead(var F: file; var buffer;
                           number: Longint; var Result: Longint);
{ Same as BlockRead (Turbo Pascal) but permits reading of blocks
greater than the BP block size of at most 65535 }

procedure BigFillChar(address : pointer; size : longint; ch : char);
{ Same as FillChar (Turbo Pascal), but size larger than 65520 bytes
is allowed. }

procedure BigFreeMem(address: Pointer; size: Longint);
{ Same as FreeMem (see Turbo Pascal help about that procedure),
but 'size' larger than 65520 bytes is allowed }

procedure BigGetMem(var address: Pointer; size: Longint);
{ Same as GetMem (see Turbo Pascal help about that procedure),
but 'size' larger than 65520 bytes is allowed.
'Address' returns the starting address of the allocated piece of memory;
returns nil if no block of the specified size could be found }

procedure BigMove(var Source, Dest; Count: Longint);
{ Same as Move (see declaration hereunder),
but 'Count' larger than 65520 bytes is allowed }

procedure Move(var Source, Dest; Count: Longint);
{ This procedure overrides system's Move procedure, because that lead
in certain cases to errors; here it is (hopefully in all cases) solved. }

{$ifdef MSDOS}
function mempos(ptr: pointer): longint;
{ Returns the number of bytes between the mempos in 'ptr' and the
bottom of memory. }
{$endif MSDOS}

(*************************)  implementation  (***********************)

{$ifdef MSDOS}
uses
   exitunit;    { Imports FatalError }
{$endif}
{$ifdef DPMI}
uses
   winapi;      { Imports GlobalAllocPtr }
{$endif}
{$ifdef Windows}
{$ifndef ver80}
uses
   winapi;      { Imports GlobalAllocPtr }
{$else}
uses
   WinProcs,    { Imports GlobalAllocPtr }
   WinTypes;    { Imports gmem_movable }
{$endif ver80}
{$endif Windows}

{ Procedures for REAL mode }

{$ifdef MSDOS}
procedure AddToAddress(var P: Pointer; Increment: Longint);
{ Increments the address of P with 'increment' }
var Address, AddrSeg, AddrOfs: Longint;
begin { AddToAddress }
   Address := 16*Longint(Seg(P^)) + Longint(Ofs(P^)) + Increment;
   AddrSeg := Address div 16;
   AddrOfs := Address mod 16;
   P := Ptr(AddrSeg, AddrOfs)
end;  { AddToAddress }

procedure BigBlockRead(var F: file; var buffer;
                           number: Longint; var Result: Longint);
{ Same as BlockRead (Turbo Pascal) but permits reading of blocks
greater than the BP block size of at most 65535 }
var
   p: pointer;
   j, nblock, tempresult: word;
   offset: Longint;
begin { BigBlockRead }
   result := 0;
   p := addr(buffer);
   nblock := number div blocksize;
   for j := 1 to nblock
   do begin
      BlockRead( f, p^, blocksize, tempresult);
      result := result + tempresult;
      addtoaddress(p, blocksize);
   end;
   BlockRead( f, p^, number mod blocksize, tempresult);
   result := result + tempresult;
end; { BigBlockRead }

procedure BigBlockWrite(var f: file; var buffer;
                            number: Longint; var Result: Longint);
{ Same as BlockWrite (Turbo Pascal) but permits writing of blocks
greater than the BP block size of at most 65535 }
var
   p: pointer;
   blocknr, nblock, tempresult: word;
begin { BigBlockWrite }
   result := 0;
   nblock := number div blocksize;
   p := addr(buffer);
   for blocknr := 1 to nblock
   do begin
      BlockWrite( f, p^, blocksize, tempresult);
      result := result + tempresult;
      addtoaddress(p, blocksize);
   end;
   BlockWrite( f, p^, number mod blocksize, tempresult);
   result := result + tempresult;
end; { BigBlockWrite }

procedure BigFreeMem( address: Pointer; size: Longint);
{ Same as FreeMem, but blocks larger than 65520 bytes are allowed }
var
   block, NumberOfBlocks: word;
begin { BigFreeMem }
   NumberOfBlocks := Size div BlockSize;
   for Block := 1 to NumberOfBlocks do begin
      FreeMem(Address, BlockSize);
      AddToAddress(Address, BlockSize);
   end;
   FreeMem(Address, Size mod BlockSize);
   {$ifdef debug}
   usedmem := startmem - memavail;
   {$endif}
end;  { BigFreeMem }

procedure BigGetMem(var address: Pointer; size: Longint);
{ Same as GetMem, but blocks larger than 65520 bytes are allowed.
'Address' returns the starting address of the allocated piece of memory;
returns nil if no block of the specified size could be found }

   type
      pfree = ^freerec;
      freerec = record
         next: pfree;
         lo, hi: Word;
      end; { freerec }
   { This record structure corresponds to that used in the heap to
   administrate free blocks. For the meaning of lo and hi see the
   Borland Pascal programmer's guide. }

   function freeblocksize(freeblockpointer: Pfree): longint;
   { Returns the size of the free block that belongs to 'freeblockpointer' }
   begin { freeblocksize }
      with freeblockpointer^
      do if freeblockpointer = heapptr
         then freeblocksize := mempos(heapend) - mempos(freeblockpointer)
         else freeblocksize := longint(hi) * 16 + lo;
   end;  { freeblocksize }

   function next_pfree(p: pfree): pfree;
   { Returns the pointer to the next record of the freelist, or heapend if
   'p' points to 'heapptr' (the latter is the last record in the list,
   whose 'next' field contains garbage). }
   var tempptr: pfree;
   begin { next_pfree }
      if p = heapptr
      then next_pfree := heapend
      else next_pfree := p^.next;
   end;  { next_pfree }

   function prev_pfree(p: pfree): pfree;
   { returns the pointer to the record who's 'next' field points to 'p'.
   p can not be equal to freelist when called from getbigmem }
   var tempptr: pfree;
   begin { prev_pfree }
      if p = freelist
      then FatalError('Error in subroutine prev_pfree: p=freelist')
      else begin
         tempptr := freelist;
         while tempptr^.next <> p
         do tempptr := tempptr^.next;
         prev_pfree := tempptr;
      end;
   end;  { prev_pfree }