(* ***** BEGIN LICENSE BLOCK *****
 * Version: MPL 1.1
 *
 * The contents of this file are subject to the Mozilla Public License Version
 * 1.1 (the "License"); you may not use this file except in compliance with
 * the License. You may obtain a copy of the License at
 * http://www.mozilla.org/MPL/
 *
 * Software distributed under the License is distributed on an "AS IS" basis,
 * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
 * for the specific language governing rights and limitations under the
 * License.
 *
 * The Original Code is TurboPower Abbrevia
 *
 * The Initial Developer of the Original Code is
 * TurboPower Software
 *
 * Portions created by the Initial Developer are Copyright (C) 1997-2002
 * the Initial Developer. All Rights Reserved.
 *
 * Contributor(s):
 *
 * ***** END LICENSE BLOCK ***** *)

{*********************************************************}
{* ABBREVIA: AbDfBase.pas                                *}
{*********************************************************}
{* Deflate base unit                                     *}
{*********************************************************}

unit AbDfBase;

{$I AbDefine.inc}

interface

uses
  SysUtils,
  Classes;

type
  PAbDfLongintList = ^TAbDfLongintList;
  TAbDfLongintList =
               array [0..pred(MaxInt div sizeof(longint))] of longint;

const
  dfc_CodeLenCodeLength = 7;
  dfc_LitDistCodeLength = 15;
  dfc_MaxCodeLength     = 15;

const
  dfc_MaxMatchLen = 258;         {lengths are 3..258 for deflate}
  dfc_MaxMatchLen64 = 64 * 1024; {lengths are 3..65536  for deflate64}

const
  dfc_LitExtraOffset = 257;
  dfc_LitExtraBits : array [0..30] of byte =
    (0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 2, 2, 2, 2, 3, 3, 3, 3,
     4, 4, 4, 4, 5, 5, 5, 5, 16, 99, 99);
     { note: the last two are required to avoid going beyond the end}
     {       of the array when generating static trees}

  dfc_DistExtraOffset = 0;
  dfc_DistExtraBits : array [0..31] of byte =
    (0, 0, 0, 0, 1, 1, 2, 2, 3, 3, 4, 4, 5, 5, 6, 6, 7, 7, 8, 8, 9, 9,
     10, 10, 11, 11, 12, 12, 13, 13, 14, 14);
     { note: the last two are only use for deflate64}

  dfc_LengthBase : array [0..28] of word =
    (3, 4, 5, 6, 7, 8, 9, 10, 11, 13, 15, 17, 19, 23, 27, 31, 35, 43,
     51, 59, 67, 83, 99, 115, 131, 163, 195, 227, 3);
     { note: the final 3 is correct for deflate64; for symbol 285,}
     {       lengths are stored as (length - 3)}
     {       for deflate it's very wrong, but there's special code in}
     {       the (de)compression code to cater for this}

  dfc_DistanceBase : array [0..31] of word =
    (1, 2, 3, 4, 5, 7, 9, 13, 17, 25, 33, 49, 65, 97, 129, 193, 257,
     385, 513, 769, 1025, 1537, 2049, 3073, 4097, 6145, 8193, 12289,
     16385, 24577, 32769, 49153);

  dfc_CodeLengthIndex : array [0..18] of byte =
    (16, 17, 18, 0, 8, 7, 9, 6, 10, 5, 11, 4, 12, 3, 13, 2, 14, 1, 15);

const
  dfc_CanUseStored  = $01;
  dfc_CanUseStatic  = $02;
  dfc_CanUseDynamic = $04;
  dfc_UseLazyMatch  = $08;
  dfc_UseDeflate64  = $10;
  dfc_UseAdler32    = $20;
  dfc_CanUseHuffman = dfc_CanUseStatic or dfc_CanUseDynamic;
  dfc_TestOnly      = $40000000;

type
  TAbProgressStep = procedure (aPercentDone : integer) of object;
    {-progress metering of deflate/inflate; abort with AbortProgress}

  TAbDeflateHelper = class
    private
      FAmpleLength    : longint;
      FChainLength    : longint;
      FLogFile        : string;
      FMaxLazy        : longint;
      FOnProgressStep : TAbProgressStep;
      FOptions        : longint;
      FPartSize       : Int64;
      FSizeCompressed : Int64;
      FSizeNormal     : Int64;
      FStreamSize     : Int64;
      FWindowSize     : longint;
      FZipOption      : AnsiChar;
    protected
      procedure dhSetAmpleLength(aValue : longint);
      procedure dhSetChainLength(aValue : longint);
      procedure dhSetLogFile(const aValue : string);
      procedure dhSetMaxLazy(aValue : longint);
      procedure dhSetOnProgressStep(aValue : TAbProgressStep);
      procedure dhSetOptions(aValue : longint);
      procedure dhSetWindowSize(aValue : longint);
      procedure dhSetZipOption(aValue : AnsiChar);
    public
      constructor Create;

      procedure Assign(aHelper : TAbDeflateHelper);

      property AmpleLength : longint
                  read FAmpleLength write dhSetAmpleLength;
      property ChainLength : longint
                  read FChainLength write dhSetChainLength;
      property LogFile : string
                  read FLogFile write dhSetLogFile;
      property MaxLazyLength : longint
                  read FMaxLazy write dhSetMaxLazy;
      property Options : longint
                  read FOptions write dhSetOptions;
      property PartialSize : Int64
                  read FPartSize write FPartSize;
      property PKZipOption : AnsiChar
                  read FZipOption write dhSetZipOption;
      property StreamSize : Int64
                  read FStreamSize write FStreamSize;
      property WindowSize : longint
                  read FWindowSize write dhSetWindowSize;

      property CompressedSize : Int64
                  read FSizeCompressed write FSizeCompressed;
      property NormalSize : Int64
                  read FSizeNormal write FSizeNormal;

      property OnProgressStep : TAbProgressStep
                  read FOnProgressStep write dhSetOnProgressStep;
  end;

type
  TAbLineDelimiter = (ldCRLF, ldLF);

  TAbLogger = class(TStream)
    private
      FBuffer    : PAnsiChar;
      FCurPos    : PAnsiChar;
      FLineDelim : TAbLineDelimiter;
      FStream    : TFileStream;
    protected
      function logWriteBuffer : boolean;
    public
      constructor Create(const aLogName : string);
      destructor Destroy; override;

      function Read(var Buffer; Count : longint) : longint; override;
      function Seek(const Offset : Int64; Origin : TSeekOrigin) : Int64; override;
      function Write(const Buffer; Count : longint) : longint; override;
      procedure WriteLine(const S : string);
      procedure WriteStr(const S : string);

      property LineDelimiter : TAbLineDelimiter
                  read FLineDelim write FLineDelim;
  end;

type
  TAbNodeManager = class
    private
      FFreeList     : pointer;
      FNodeSize     : cardinal;
      FNodesPerPage : cardinal;
      FPageHead     : pointer;
      FPageSize     : cardinal;
    protected
      function nmAllocNewPage : pointer;
    public
      constructor Create(aNodeSize : cardinal);
      destructor Destroy; override;

      function AllocNode : pointer;
      function AllocNodeClear : pointer;
      procedure FreeNode(aNode : pointer);
  end;

{---exception classes---}
type
  EAbAbortProgress = class(Exception);
  EAbPartSizedInflate = class(Exception);
  EAbInflatePasswordError = class(Exception);
  EAbInternalInflateError = class(Exception);
  EAbInflateError = class(Exception)
    public
      constructor Create(const aMsg : string);
      constructor CreateUnknown(const aMsg : string;
                                const aErrorMsg : string);
  end;
  EAbInternalDeflateError = class(Exception);
  EAbDeflateError = class(Exception)
    public
      constructor Create(const aMsg : string);
      constructor CreateUnknown(const aMsg : string;
                                const aErrorMsg : string);
  end;

{---aborting a process---}
procedure AbortProgress;

{---calculation of checksums---}
procedure AbUpdateAdlerBuffer(var aAdler : longint;
                              var aBuffer; aCount : integer);
procedure AbUpdateCRCBuffer(var aCRC : longint;
                            var aBuffer; aCount : integer);


implementation

uses
  AbUtils;

{===TAbDeflateHelper=================================================}
constructor TAbDeflateHelper.Create;
begin
  inherited Create;
  FAmpleLength := 8;
  FChainLength := 32;
  {FLogFile := '';}
  FMaxLazy := 16;
  {FOnProgressStep := nil;}
  FOptions := $F;
  {FStreamSize := 0;}
  FWindowSize := 32 * 1024;
  FZipOption := 'n';
end;
{--------}
procedure TAbDeflateHelper.Assign(aHelper : TAbDeflateHelper);
begin
  FAmpleLength := aHelper.FAmpleLength;
  FChainLength := aHelper.FChainLength;
  FLogFile := aHelper.FLogFile;
  FMaxLazy := aHelper.FMaxLazy;
  FOnProgressStep := aHelper.FOnProgressStep;
  FOptions := aHelper.FOptions;
  FPartSize := aHelper.FPartSize;
  FStreamSize := aHelper.FStreamSize;
  FWindowSize := aHelper.FWindowSize;
  FZipOption := aHelper.FZipOption;
end;
{--------}
procedure TAbDeflateHelper.dhSetAmpleLength(aValue : longint);
begin
  if (aValue <> AmpleLength) then begin
    if (aValue <> -1) and (aValue < 4) then
      aValue := 4;
    FAmpleLength := aValue;
    FZipOption := '?';
  end;
end;
{--------}
procedure TAbDeflateHelper.dhSetChainLength(aValue : longint);
begin
  if (aValue <> ChainLength) then begin
    if (aValue <> -1) and (aValue < 4) then
      aValue := 4;
    FChainLength := aValue;
    FZipOption := '?';
  end;
end;
{--------}
procedure TAbDeflateHelper.dhSetLogFile(const aValue : string);
begin
  FLogFile := aValue;
end;
{--------}
procedure TAbDeflateHelper.dhSetMaxLazy(aValue : longint);
begin
  if (aValue <> MaxLazyLength) then begin
    if (aValue <> -1) and (aValue < 4) then
      aValue := 4;
    FMaxLazy := aValue;
    FZipOption := '?';
  end;
end;
{--------}
procedure TAbDeflateHelper.dhSetOnProgressStep(aValue : TAbProgressStep);
begin
  FOnProgressStep := aValue;
end;
{--------}
procedure TAbDeflateHelper.dhSetOptions(aValue : longint);
begin
  if (aValue <> Options) then begin
    FOptions := aValue;
    FZipOption := '?';
  end;
end;
{--------}
procedure TAbDeflateHelper.dhSetWindowSize(aValue : longint);
var
  NewValue : longint;
begin
  if (aValue <> WindowSize) then begin
    {calculate the window size rounded to nearest 1024 bytes}
    NewValue := ((aValue + 1023) div 1024) * 1024;
    {if the new window size is greater than 32KB...}
    if (NewValue > 32 * 1024) then
      {if the Deflate64 option is set, force to 64KB}
      if ((Options and dfc_UseDeflate64) <> 0) then
        NewValue := 64 * 1024
      {otherwise, force to 32KB}
      else
        NewValue := 32 * 1024;
    {set the new window size}
    FWindowSize := NewValue;
  end;
end;
{--------}
procedure TAbDeflateHelper.dhSetZipOption(aValue : AnsiChar);
begin
  {notes:
     The original Abbrevia code used the following table for
     setting the equivalent values:
            Good  Lazy  Chain  UseLazy  Option
               4     4      4     N       s        ^
               4     5      8     N                |
               4     6     32     N       f      faster
               4     4     16     Y              slower
               8    16     32     Y       n        |
               8    16    128     Y                |
               8    32    256     Y                |
              32   128   1024     Y                |
              32   258   4096     Y       x        V
     The new Abbrevia 3 code follows these values to a certain extent.
  }

  {force to lower case}
  if ('A' <= aValue) and (aValue <= 'Z') then
    aValue := AnsiChar(ord(aValue) + ord('a') - ord('A'));

  {if the value has changed...}
  if (aValue <> PKZipOption) then begin

    {switch on the new value...}
    case aValue of
      '0' : {no compression}
        begin
          FZipOption := aValue;
          FOptions := (FOptions and (not $0F)) or dfc_CanUseStored;
          FAmpleLength := 8;  { not actually needed}
          FChainLength := 32; { not actually needed}
          FMaxLazy := 16;     { not actually needed}
        end;
      '2' : {hidden option: Abbrevia 2 compatibility}
        begin
          FZipOption := aValue;
          FOptions := FOptions or $0F;
          FAmpleLength := 8;
          FChainLength := 32;
          FMaxLazy := 16;
        end;
      'f' : {fast compression}
        begin
          FZipOption := aValue;
          FOptions := FOptions or $07; { no lazy matching}
          FAmpleLength := 4;
          FChainLength := 32;
          FMaxLazy := 6;
        end;
      'n' : {normal compression}
        begin
          FZipOption := aValue;
          FOptions := FOptions or $0F;
          FAmpleLength := 16;
          FChainLength := 32;
          FMaxLazy := 24;
        end;
      's' : {super fast compression}
        begin
          FZipOption := aValue;
          FOptions := FOptions or $07; { no lazy matching}
          FAmpleLength := 4;
          FChainLength := 4;
          FMaxLazy := 4;
        end;
      'x' : {maximum compression}
        begin
          FZipOption := aValue;
          FOptions := FOptions or $0F;
          FAmpleLength := 64;{32;}
          FChainLength := 4096;
          FMaxLazy := 258;
        end;
    end;
  end;
end;
{====================================================================}


{===TAbLogger========================================================}
const
  LogBufferSize = 4096;
{--------}
constructor TAbLogger.Create(const aLogName : string);
begin
  Assert(aLogName <> '',
         'TAbLogger.Create: a filename must be provided for the logger');

  {create the ancestor}
  inherited Create;

  {set the default line terminator}
  {$IFDEF MSWINDOWS}
  FLineDelim := ldCRLF;
  {$ENDIF}
  {$IFDEF UNIX}
  FLineDelim := ldLF;
  {$ENDIF}

  {create and initialize the buffer}
  GetMem(FBuffer, LogBufferSize);
  FCurPos := FBuffer;

  {create the log file}
  FStream := TFileStream.Create(aLogName, fmCreate);
end;
{--------}
destructor TAbLogger.Destroy;
begin
  {if there is a buffer ensure that it is flushed before freeing it}
  if (FBuffer <> nil) then begin
    if (FCurPos <> FBuffer) then
      logWriteBuffer;
    FreeMem(FBuffer, LogBufferSize);
  end;

  {free the stream}
  FStream.Free;

  {destroy the ancestor}
  inherited Destroy;
end;
{--------}
function TAbLogger.logWriteBuffer : boolean;
var
  BytesToWrite : longint;
  BytesWritten : longint;
begin
  BytesToWrite := FCurPos - FBuffer;
  BytesWritten := FStream.Write(FBuffer^, BytesToWrite);
  if (BytesWritten = BytesToWrite) then begin
    Result := true;
    FCurPos := FBuffer;
  end
  else begin
    Result := false;
    if (BytesWritten <> 0) then begin
      Move(FBuffer[BytesWritten], FBuffer^, BytesToWrite - BytesWritten);
      FCurPos := FBuffer + (BytesToWrite - BytesWritten);
    end;
  end;
end;
{--------}
function TAbLogger.Read(var Buffer; Count : longint) : longint;
begin
  Assert(false, 'TAbLogger.Read: loggers are write-only, no reading allowed');
  Result := 0;
end;
{--------}
function TAbLogger.Seek(const Offset : Int64; Origin : TSeekOrigin) : Int64;
begin
  case Origin of
    soBeginning :
      begin
      end;
    soCurrent :
      if (Offset = 0) then begin
        Result := FStream.Position + (FCurPos - FBuffer);
        Exit;
      end;
    soEnd :
      if (Offset = 0) then begin
        Result := FStream.Position + (FCurPos - FBuffer);
        Exit;
      end;
  end;

  Assert(false, 'TAbLogger.Seek: loggers are write-only, no seeking allowed');
  Result := 0;
end;
{--------}
function TAbLogger.Write(const Buffer; Count : longint) : longint;
var
  UserBuf      : PAnsiChar;
  BytesToGo    : longint;
  BytesToWrite : longint;
begin
  {reference the user's buffer as a PChar}
  UserBuf := @Buffer;

  {start the counter for the number of bytes written}
  Result := 0;

  {if needed, empty the internal buffer into the underlying stream}
  if (LogBufferSize = FCurPos - FBuffer) then
    if not logWriteBuffer then
      Exit;

  {calculate the number of bytes to copy this time from the user's
   buffer to the internal buffer}
  BytesToGo := Count;
  BytesToWrite := LogBufferSize - (FCurPos - FBuffer);
  if (BytesToWrite > BytesToGo) then
    BytesToWrite := BytesToGo;

  {copy the bytes}
  Move(UserBuf^, FCurPos^, BytesToWrite);

  {adjust the counters}
  inc(FCurPos, BytesToWrite);
  dec(BytesToGo, BytesToWrite);
  inc(Result, BytesToWrite);

  {while there are still more bytes to copy, do so}
  while (BytesToGo <> 0) do begin
    {advance the user's buffer}
    inc(UserBuf, BytesToWrite);

    {empty the internal buffer into the underlying stream}
    if not logWriteBuffer then
      Exit;

    {calculate the number of bytes to copy this time from the user's
     buffer to the internal buffer}
    BytesToWrite := LogBufferSize;
    if (BytesToWrite > BytesToGo) then
      BytesToWrite := BytesToGo;

    {copy the bytes}
    Move(UserBuf^, FCurPos^, BytesToWrite);

    {adjust the counters}
    inc(FCurPos, BytesToWrite);
    dec(BytesToGo, BytesToWrite);
    inc(Result, BytesToWrite);
  end;
end;
{--------}
procedure TAbLogger.WriteLine(const S : string);
const
  cLF : AnsiChar = ^J;
  cCRLF : array [0..1] of AnsiChar = ^M^J;
begin
  if (length(S) > 0) then
    Write(S[1], length(S));
  case FLineDelim of
    ldLF   : Write(cLF, sizeof(cLF));
    ldCRLF : Write(cCRLF, sizeof(cCRLF));
  end;
end;
{--------}
procedure TAbLogger.WriteStr(const S : string);
begin
  if (length(S) > 0) then
    Write(S[1], length(S));
end;
{====================================================================}


{===Calculate checksums==============================================}
procedure AbUpdateAdlerBuffer(var aAdler : longint;
                              var aBuffer; aCount : integer);
var
  S1 : LongWord;
  S2 : LongWord;
  i  : integer;
  Buffer     : PAnsiChar;
  BytesToUse : integer;
begin
  {Note: this algorithm will *only* work if the buffer is 4KB or less,
         which is why we go to such lengths to chop up the user buffer
         into usable chunks of 4KB.

         However, for Delphi 3 there is no proper 32-bit longword.
         Although the additions pose no problems in this situation,
         the mod operations below (especially for S2) will be signed
         integer divisions, producing an (invalid) signed result. In
         this case, the buffer is chopped up into 2KB chunks to avoid
         any signed problems.}

  {split the current Adler checksum into its halves}
  S1 := LongWord(aAdler) and $FFFF;
  S2 := LongWord(aAdler) shr 16;

  {reference the user buffer as a PChar: it makes it easier}
  Buffer := @aBuffer;

  {while there's still data to checksum...}
  while (aCount <> 0) do begin

    {calculate the number of bytes to checksum this time}
    {$IFDEF HasLongWord}
    BytesToUse := 4096;
    {$ELSE}
    BytesToUse := 2048;
    {$ENDIF}
    if (BytesToUse > aCount) then
      BytesToUse := aCount;

    {checksum the bytes}
    for i := 0 to pred(BytesToUse) do begin
      inc(S1, ord(Buffer^));
      inc(S2, S1);
      inc(Buffer);
    end;

    {recalibrate the Adler checksum halves}
    S1 := S1 mod 65521;
    S2 := S2 mod 65521;

    {calculate the number of bytes still to go}
    dec(aCount, BytesToUse);
  end;

  {join the halves to produce the complete Adler checksum}
  aAdler := longint((S2 shl 16) or S1);
end;
{--------}
procedure AbUpdateCRCBuffer(var aCRC : longint;
                            var aBuffer; aCount : integer);
var
  i      : integer;
  CRC    : LongWord;
  Buffer : PAnsiChar;
begin
{$R-}{$Q-}
  {reference the user buffer as a PChar: it makes it easier}
  Buffer := @aBuffer;

  {get the current CRC as a local variable, it's faster}
  CRC := aCRC;

  {checksum the bytes in the buffer}
  for i := 0 to pred(aCount) do begin
    CRC := AbCrc32Table[byte(CRC) xor byte(Buffer^)] xor (CRC shr 8);
    inc(Buffer);
  end;

  {return the new CRC}
  aCRC := CRC;
{$R+}{$Q+}
end;
{====================================================================}


{===EAbInflateError==================================================}
constructor EAbInflateError.Create(const aMsg : string);
begin
  inherited Create(
     'Abbrevia inflate error, possibly a corrupted compressed stream. ' +
     '(Internal cause: ' + aMsg + ')');
end;
{--------}
constructor EAbInflateError.CreateUnknown(const aMsg : string;
                                          const aErrorMsg : string);
begin
  inherited Create(aMsg + ': ' + aErrorMsg);
end;
{====================================================================}


{===EAbDeflateError==================================================}
constructor EAbDeflateError.Create(const aMsg : string);
begin
  inherited Create(
     'Abbrevia deflate error. ' +
     '(Internal cause: ' + aMsg + ')');
end;
{--------}
constructor EAbDeflateError.CreateUnknown(const aMsg : string;
                                          const aErrorMsg : string);
begin
  inherited Create(aMsg + ': ' + aErrorMsg);
end;
{====================================================================}


{===Node manager=====================================================}
const
  PageSize = 8 * 1024;
type
  PGenericNode = ^TGenericNode;
  TGenericNode = packed record
    gnNext : PGenericNode;
    gnData : record end;
  end;
{--------}
constructor TAbNodeManager.Create(aNodeSize : cardinal);
const
  Gran = sizeof(pointer);
  Mask = not (Gran - 1);
begin
  {create the ancestor}
  inherited Create;

  {save the node size rounded to nearest 4 bytes}
  if (aNodeSize <= sizeof(pointer)) then
    aNodeSize := sizeof(pointer)
  else
    aNodeSize := (aNodeSize + Gran - 1) and Mask;
  FNodeSize := aNodeSize;

  {calculate the page size (default 1024 bytes) and the number of
   nodes per page; if the default page size is not large enough for
   two or more nodes, force a single node per page}
  FNodesPerPage := (PageSize - sizeof(pointer)) div aNodeSize;
  if (FNodesPerPage > 1) then
    FPageSize := PageSize
  else begin
    FNodesPerPage := 1;
    FPagesize := aNodeSize + sizeof(pointer);
  end;
end;
{--------}
destructor TAbNodeManager.Destroy;
var
  Temp : pointer;
begin
  {dispose of all the pages, if there are any}
  while (FPageHead <> nil) do begin
    Temp := PGenericNode(FPageHead)^.gnNext;
    FreeMem(FPageHead, FPageSize);
    FPageHead := Temp;
  end;

  {destroy the ancestor}
  inherited Destroy;
end;
{--------}
function TAbNodeManager.AllocNode : pointer;
begin
  Result := FFreeList;
  if (Result = nil) then
    Result := nmAllocNewPage
  else
    FFreeList := PGenericNode(Result)^.gnNext;
end;
{--------}
function TAbNodeManager.AllocNodeClear : pointer;
begin
  Result := FFreeList;
  if (Result = nil) then
    Result := nmAllocNewPage
  else
    FFreeList := PGenericNode(Result)^.gnNext;
  FillChar(Result^, FNodeSize, 0);
end;
{--------}
procedure TAbNodeManager.FreeNode(aNode : pointer);
begin
  {add the node (if non-nil) to the top of the free list}
  if (aNode <> nil) then begin
    PGenericNode(aNode)^.gnNext := FFreeList;
    FFreeList := aNode;
  end;
end;
{--------}
function TAbNodeManager.nmAllocNewPage : pointer;
var
  NewPage  : PAnsiChar;
  i        : integer;
  FreeList : pointer;
  NodeSize : integer;
begin
  {allocate a new page and add it to the front of the page list}
  GetMem(NewPage, FPageSize);
  PGenericNode(NewPage)^.gnNext := FPageHead;
  FPageHead := NewPage;

  {now split up the new page into nodes and push them all onto the
   free list; note that the first 4 bytes of the page is a pointer to
   the next page, so remember to skip over it}
  inc(NewPage, sizeof(pointer));
  FreeList := FFreeList;
  NodeSize := FNodeSize;
  for i := 0 to pred(FNodesPerPage) do begin
    PGenericNode(NewPage)^.gnNext := FreeList;
    FreeList := NewPage;
    inc(NewPage, NodeSize);
  end;

  {return the top of the list}
  Result := FreeList;
  FFreeList := PGenericNode(Result)^.gnNext;
end;
{====================================================================}


{====================================================================}
procedure AbortProgress;
begin
  raise EAbAbortProgress.Create('Abort');
end;
{====================================================================}

end.