heapunit.pas

Delphi direct support for GIF files

   procedure find_block(size: Longint; var freeblockpointer: Pfree);
   { Returns the pointer to the record in the freelist that has a free block
   that can contain 'size' bytes or more (in other words:
   in which a data structure of 'size' bytes can be stored).
   Returns Nil if no such block is available. }
   begin { find_block }
      freeblockpointer := freelist;
      while (freeblocksize(freeblockpointer) < size) and
            (freeblockpointer <> heapptr)
      do freeblockpointer := freeblockpointer^.next;
      if freeblocksize(freeblockpointer) < size
      then freeblockpointer := Nil
   end;  { find_block }

   procedure getmemblocks(var address: Pointer; size: Longint);
   var Block, NumberOfBlocks: Word;
       BlockAddress: Pointer;
   begin { getmemblocks }
      if (Size mod BlockSize) = 0
      then address := HeapPtr
      else GetMem(address, Size mod BlockSize);
      NumberOfBlocks := Size div BlockSize;
      for Block := 1 to NumberOfBlocks
      do GetMem(BlockAddress, BlockSize);
   end;  { getmemblocks }

var freeblockpointer,
    savefreelist, previous: pfree;
begin { BigGetMem }
   if Size < 65520
   then GetMem(address, Size)
   else begin
      address := nil;
      find_block(size, freeblockpointer);
      if freeblockpointer <> Nil
      then begin
         if freeblockpointer = freelist
         then getmemblocks(address, size)
         else begin
            savefreelist := freelist;
            previous := prev_pfree(freeblockpointer);
            freelist := freeblockpointer;
            getmemblocks(address, size);
            previous^.next := freelist;
            freelist := savefreelist;
         end;
      end;
   end;
   {$ifdef debug}
   usedmem := startmem - memavail;
   {$endif}
end;  { BigGetMem }

function mempos(ptr: pointer): longint;
{ Returns the number of bytes between the mempos in 'ptr' and the
bottom of memory. }
begin  mempos := 16 * longint(seg(ptr^)) + longint(ofs(ptr^));
end; { mempos }

procedure Move(var Source, Dest; Count: Longint);
{ This procedure overrides system's Move procedure;
the real mode version is trivial, but the DPMI/Windows version isn't }
begin system.Move(Source, Dest, Count);
end;  { Move }
{$endif}


{ Procedures for PROTECTED mode }

{$ifndef MSDOS}
procedure AddToAddress(var P: Pointer; Increment: Longint);
{ Increments the address of P with 'increment' }
type Long = record Lo, Hi: Word; end;
var phi, plo, inchi, inclo: Longint;
begin { AddToAddress }
   phi := Long(P).Hi;
   plo := Long(P).Lo;
   inchi := Long(Increment).Hi;
   inclo := Long(Increment).Lo;
   if plo + inclo >= 65536      { this is necessary    }
   then begin                   { to prevent a range   }
      inclo := inclo-65536;     { check error at the   }
      Inc(inchi);               { P = Ptr(...)         }
   end;                         { assignment statement }
   P := Ptr(phi + inchi*SelectorInc, plo + inclo);
end;  { AddToAddress }

procedure BigBlockRead(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 }
const blocksize = 32768;
var
   p: pointer;
   offset, rest: Longint;
   tempresult, nblock, blocknr: word;
begin { BigBlockRead }
   result := 0;
   p := addr(buffer);
   offset := Longint(Ofs(P^));
   if offset + number <= 65535
   then begin
      BlockRead( f, p^, number, tempresult);
      result := result + tempresult;
   end
   else begin
      rest := 65536 - offset;
      if rest <= 65535
      then begin
         BlockRead( f, p^, rest, tempresult);
         addtoaddress(p, rest);
         result := result + tempresult;
         number := number - rest;
      end;
      nblock := number div blocksize;
      for blocknr := 1 to nblock
      do begin
         BlockRead( f, p^, blocksize, tempresult);
         result := result + tempresult;
         addtoaddress(p, blocksize);
      end;
      rest := number - result;
      if rest = 0
      then tempresult := 0
      else BlockRead( f, p^, rest, tempresult);
      result := result + tempresult;
   end;
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 }
const blocksize = 32768;
var
   p: pointer;
   offset, rest: Longint;
   tempresult, nblock, blocknr: word;
begin { BigBlockWrite }
   result := 0;
   p := addr(buffer);
   offset := Longint(Ofs(P^));
   if offset + number <= 65535
   then begin
      BlockWrite( f, p^, number, tempresult);
      result := result + tempresult;
   end
   else begin
      rest := 65536 - offset;
      if rest <= 65535
      then begin
         BlockWrite( f, p^, rest, tempresult);
         addtoaddress(p, rest);
         result := result + tempresult;
         number := number - rest;
      end;
      nblock := number div blocksize;
      for blocknr := 1 to nblock
      do begin
         BlockWrite( f, p^, blocksize, tempresult);
         result := result + tempresult;
         addtoaddress(p, blocksize);
      end;
      rest := number - result;
      if rest = 0
      then tempresult := 0
      else BlockWrite( f, p^, rest, tempresult);
      result := result + tempresult;
   end;
end; { BigBlockWrite }

procedure BigGetMem( var address: Pointer; size: Longint);
{ Same as GetMem, but blocks larger than 65520 bytes are allowed }
begin { BigGetMem }
   if size < 65520
   then GetMem(address, size)
   else address := GlobalAllocPtr(gmem_moveable, size);
   {$ifdef debug}
   usedmem := startmem - memavail;
   {$endif}
end;  { BigGetMem }

procedure BigFreeMem(address: Pointer; size: Longint);
{ Same as FreeMem, but blocks larger than 65520 bytes are allowed }
var H: THandle;
begin { BigFreeMem }
   if size < 65520
   then FreeMem(address, size)
   else H := GlobalFreePtr(address);
   {$ifdef debug}
   usedmem := startmem - memavail;
   {$endif}
end;  { BigFreeMem }

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. }
type bytearr = array[1..6] of Byte;
     valpointer=^bytearr;
var firstpart: word;
    SourcePtr, DestPtr: Pointer;
    valptr: valpointer;
begin { Move }
   if (Longint(Ofs(Dest))+Count > 65536) or
      (Longint(Ofs(Source))+Count > 65536)
   then begin
      SourcePtr := @Source;
      DestPtr := @Dest;
      if Longint(Ofs(Dest))+Count > 65536
      then firstpart := 65536 - Ofs(Dest)
      else firstpart := 65536 - Ofs(Source);
      system.Move(Source, Dest, firstpart);
      AddToAddress(SourcePtr, firstpart);
      AddToAddress(DestPtr, firstpart);
      system.Move(SourcePtr^, DestPtr^, Count-firstpart);
   end
   else system.Move(Source, Dest, Count);
end;  { Move }
{$endif}


{ Procedures for both REAL and PROTECTED mode }

procedure BigFillChar(address: pointer; size: longint; ch: char);
{ Same as FillChar (TurboPascal), but size larger than 65520 bytes
is allowed. }
var p: pointer;
    j, nblock: word;
begin { BigFillChar }
   nblock := size div blocksize;
   p := address;
   for j := 1 to nblock
   do begin
      fillchar(p^, blocksize, ch);
      addtoaddress(p, blocksize);
   end;
   FillChar(p^, size mod blocksize, ch);
end;  { BigFillChar }

procedure BigMove(var Source, Dest; Count: Longint);
var BlockNr, NumberOfBlocks: Word;
    SourceAddress, TargetAddress: Pointer;
begin { BigMove }
   NumberOfBlocks := Count div BlockSize;
   SourceAddress := Pointer(Source);
   TargetAddress := Pointer(Dest);
   for BlockNr := 1 to NumberOfBlocks
   do begin
      Move(SourceAddress^, TargetAddress^, BlockSize);
      AddToAddress(SourceAddress, BlockSize);
      AddToAddress(TargetAddress, BlockSize)
   end;
   Move(SourceAddress^, TargetAddress^, Count mod BlockSize);
end;  { BigMove }

{$ifdef debug}
begin
   startmem := memavail;
   usedmem := 0;
{$endif}
end.  { UNIT heapunit }