/rtl/inc/objects.pp

Large files files are truncated, but you can click here to view the full file

{
    This file is part of the Free Pascal run time library.
    Copyright (c) 1999-2000 by the Free Pascal development team.

    Objects.pas clone for Free Pascal

    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.

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

{************[ SOURCE FILE OF FREE VISION ]****************}
{                                                          }
{    System independent clone of objects.pas               }
{                                                          }
{    Interface Copyright (c) 1992 Borland International    }
{                                                          }
{    Parts Copyright (c) 1999-2000 by Florian Klaempfl     }
{    fnklaemp@cip.ft.uni-erlangen.de                       }
{                                                          }
{    Parts Copyright (c) 1999-2000 by Frank ZAGO           }
{    zago@ecoledoc.ipc.fr                                  }
{                                                          }
{    Parts Copyright (c) 1999-2000 by MH Spiegel           }
{                                                          }
{    Parts Copyright (c) 1996, 1999-2000 by Leon de Boer   }
{    ldeboer@ibm.net                                       }
{                                                          }
{    Free Vision project coordinator Balazs Scheidler      }
{    bazsi@tas.vein.hu                                     }
{                                                          }
UNIT Objects;

{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
                                  INTERFACE
{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}

{==== Select assembler ==============================================}
{$IFDEF CPU86}
  {$ASMMODE ATT}
{$ENDIF}


{==== Compiler directives ===========================================}
{$H-} { No ansistrings }
{$X+} { Extended syntax is ok }
{$R-} { Disable range checking }
{$ifndef Unix}
  {$S-} { Disable Stack Checking }
{$endif}
{$I-} { Disable IO Checking }
{$Q-} { Disable Overflow Checking }
{$V-} { Turn off strict VAR strings }
{$INLINE ON} {Turn on inlining.}
{====================================================================}

{$ifdef win32}
  uses
    Windows;
{$endif}

{***************************************************************************}
{                             PUBLIC CONSTANTS                              }
{***************************************************************************}

{---------------------------------------------------------------------------}
{                          STREAM ERROR STATE MASKS                         }
{---------------------------------------------------------------------------}
CONST
   stOk         =  0;                                 { No stream error }
   stError      = -1;                                 { Access error }
   stInitError  = -2;                                 { Initialize error }
   stReadError  = -3;                                 { Stream read error }
   stWriteError = -4;                                 { Stream write error }
   stGetError   = -5;                                 { Get object error }
   stPutError   = -6;                                 { Put object error }
   stSeekError  = -7;                                 { Seek error in stream }
   stOpenError  = -8;                                 { Error opening stream }

{---------------------------------------------------------------------------}
{                        STREAM ACCESS MODE CONSTANTS                       }
{---------------------------------------------------------------------------}
CONST
   stCreate    = $3C00;                               { Create new file }
   stOpenRead  = $3D00;                               { Read access only }
   stOpenWrite = $3D01;                               { Write access only }
   stOpen      = $3D02;                               { Read/write access }

{---------------------------------------------------------------------------}
{                          TCollection ERROR CODES                          }
{---------------------------------------------------------------------------}
CONST
   coIndexError = -1;                                 { Index out of range }
   coOverflow   = -2;                                 { Overflow }

{---------------------------------------------------------------------------}
{         VMT HEADER CONSTANT - HOPEFULLY WE CAN DROP THIS LATER            }
{---------------------------------------------------------------------------}
CONST
   vmtHeaderSize = 8;                                 { VMT header size }

CONST
{---------------------------------------------------------------------------}
{                            MAXIUM DATA SIZES                              }
{---------------------------------------------------------------------------}
{$IFDEF FPC}
   MaxBytes = 128*1024*128;                               { Maximum data size }
{$ELSE}
   MaxBytes = 16384;
{$ENDIF}
   MaxWords = MaxBytes DIV SizeOf(Word);              { Max word data size }
   MaxPtrs = MaxBytes DIV SizeOf(Pointer);            { Max ptr data size }
   MaxCollectionSize = MaxBytes DIV SizeOf(Pointer);  { Max collection size }
   MaxTPCompatibleCollectionSize = 65520 div 4;

{***************************************************************************}
{                          PUBLIC TYPE DEFINITIONS                          }
{***************************************************************************}

{---------------------------------------------------------------------------}
{                               CHARACTER SET                               }
{---------------------------------------------------------------------------}
TYPE
   TCharSet = SET Of Char;                            { Character set }
   PCharSet = ^TCharSet;                              { Character set ptr }

{---------------------------------------------------------------------------}
{                               GENERAL ARRAYS                              }
{---------------------------------------------------------------------------}
TYPE
   TByteArray = ARRAY [0..MaxBytes-1] Of Byte;        { Byte array }
   PByteArray = ^TByteArray;                          { Byte array pointer }

   TWordArray = ARRAY [0..MaxWords-1] Of Word;        { Word array }
   PWordArray = ^TWordArray;                          { Word array pointer }

   TPointerArray = Array [0..MaxPtrs-1] Of Pointer;   { Pointer array }
   PPointerArray = ^TPointerArray;                    { Pointer array ptr }

{---------------------------------------------------------------------------}
{                             POINTER TO STRING                             }
{---------------------------------------------------------------------------}
TYPE
   PString = PShortString;                            { String pointer }

{---------------------------------------------------------------------------}
{                    OS dependent File type / consts                        }
{---------------------------------------------------------------------------}
type
   FNameStr = String;
const
   MaxReadBytes = $7fffffff;

var
   invalidhandle : THandle;


{---------------------------------------------------------------------------}
{                            DOS ASCIIZ FILENAME                            }
{---------------------------------------------------------------------------}
TYPE
   AsciiZ = Array [0..255] Of Char;                   { Filename array }

{---------------------------------------------------------------------------}
{                        BIT SWITCHED TYPE CONSTANTS                        }
{---------------------------------------------------------------------------}
TYPE
   Sw_Word    = Cardinal;                             { Long Word now }
   Sw_Integer = LongInt;                              { Long integer now }

{***************************************************************************}
{                        PUBLIC RECORD DEFINITIONS                          }
{***************************************************************************}

{---------------------------------------------------------------------------}
{                          TYPE CONVERSION RECORDS                          }
{---------------------------------------------------------------------------}
TYPE
   WordRec = packed RECORD
{$ifdef ENDIAN_LITTLE}
     Lo, Hi: Byte;                                    { Word to bytes }
{$else}
     Hi,Lo: Byte;
{$endif}
   END;

   LongRec = packed RECORD
{$ifdef ENDIAN_LITTLE}
     Lo, Hi: Word;                                    { LongInt to words }
{$else}
     Hi,Lo: Word;                                    { LongInt to words }
{$endif}
   END;

   PtrRec = packed RECORD
     Ofs, Seg: Word;                                  { Pointer to words }
   END;

{---------------------------------------------------------------------------}
{                  TStreamRec RECORD - STREAM OBJECT RECORD                 }
{---------------------------------------------------------------------------}
TYPE
   PStreamRec = ^TStreamRec;                          { Stream record ptr }
   TStreamRec = Packed RECORD
      ObjType: Sw_Word;                               { Object type id }
      VmtLink: pointer;                               { VMT link }
      Load : Pointer;                                 { Object load code }
      Store: Pointer;                                 { Object store code }
      Next : PStreamRec;                              { Next stream record }
   END;

{***************************************************************************}
{                        PUBLIC OBJECT DEFINITIONS                          }
{***************************************************************************}

{---------------------------------------------------------------------------}
{                        TPoint OBJECT - POINT OBJECT                       }
{---------------------------------------------------------------------------}
TYPE
   PPoint = ^TPoint;
   TPoint = OBJECT
      X, Y: Sw_Integer;
   END;

{---------------------------------------------------------------------------}
{                      TRect OBJECT - RECTANGLE OBJECT                      }
{---------------------------------------------------------------------------}
   PRect = ^TRect;
   TRect = OBJECT
      A, B: TPoint;                                { Corner points }
      FUNCTION Empty: Boolean;
      FUNCTION Equals (R: TRect): Boolean;
      FUNCTION Contains (P: TPoint): Boolean;
      PROCEDURE Copy (R: TRect);
      PROCEDURE Union (R: TRect);
      PROCEDURE Intersect (R: TRect);
      PROCEDURE Move (ADX, ADY: Sw_Integer);
      PROCEDURE Grow (ADX, ADY: Sw_Integer);
      PROCEDURE Assign (XA, YA, XB, YB: Sw_Integer);
   END;

{---------------------------------------------------------------------------}
{                  TObject OBJECT - BASE ANCESTOR OBJECT                    }
{---------------------------------------------------------------------------}
TYPE
   TObject = OBJECT
      CONSTRUCTOR Init;
      PROCEDURE Free;
      FUNCTION Is_Object(P:Pointer):Boolean;
      DESTRUCTOR Done;                                               Virtual;
   END;
   PObject = ^TObject;

{ ******************************* REMARK ****************************** }
{  Two new virtual methods have been added to the object in the form of }
{  Close and Open. The main use here is in the Disk Based Descendants   }
{  the calls open and close the given file so these objects can be      }
{  used like standard files. Two new fields have also been added to     }
{  speed up seeks on descendants. All existing code will compile and    }
{  work completely normally oblivious to these new methods and fields.  }
{ ****************************** END REMARK *** Leon de Boer, 15May96 * }

{---------------------------------------------------------------------------}
{                 TStream OBJECT - STREAM ANCESTOR OBJECT                   }
{---------------------------------------------------------------------------}
TYPE
   TStream = OBJECT (TObject)
         Status    : Integer;                         { Stream status }
         ErrorInfo : Integer;                         { Stream error info }
         StreamSize: LongInt;                         { Stream current size }
         Position  : LongInt;                         { Current position }
         TPCompatible : Boolean;
      CONSTRUCTOR Init;
      FUNCTION Get: PObject;
      FUNCTION StrRead: PChar;
      FUNCTION GetPos: Longint;                                      Virtual;
      FUNCTION GetSize: Longint;                                     Virtual;
      FUNCTION ReadStr: PString;
      PROCEDURE Open (OpenMode: Word);                               Virtual;
      PROCEDURE Close;                                               Virtual;
      PROCEDURE Reset;
      PROCEDURE Flush;                                               Virtual;
      PROCEDURE Truncate;                                            Virtual;
      PROCEDURE Put (P: PObject);
      PROCEDURE StrWrite (P: PChar);
      PROCEDURE WriteStr (P: PString);
      PROCEDURE Seek (Pos: LongInt);                                 Virtual;
      PROCEDURE Error (Code, Info: Integer);                         Virtual;
      PROCEDURE Read (Var Buf; Count: LongInt);                      Virtual;
      PROCEDURE Write (Var Buf; Count: LongInt);                     Virtual;
      PROCEDURE CopyFrom (Var S: TStream; Count: Longint);
   END;
   PStream = ^TStream;

{ ******************************* REMARK ****************************** }
{   A few minor changes to this object and an extra field added called  }
{  FName which holds an AsciiZ array of the filename this allows the    }
{  streams file to be opened and closed like a normal text file. All    }
{  existing code should work without any changes.                       }
{ ****************************** END REMARK *** Leon de Boer, 19May96 * }

{---------------------------------------------------------------------------}
{                TDosStream OBJECT - DOS FILE STREAM OBJECT                 }
{---------------------------------------------------------------------------}
TYPE
   TDosStream = OBJECT (TStream)
         Handle: THandle;                             { DOS file handle }
         FName : AsciiZ;                              { AsciiZ filename }
      CONSTRUCTOR Init (FileName: FNameStr; Mode: Word);
      DESTRUCTOR Done;                                               Virtual;
      PROCEDURE Close;                                               Virtual;
      PROCEDURE Truncate;                                            Virtual;
      PROCEDURE Seek (Pos: LongInt);                                 Virtual;
      PROCEDURE Open (OpenMode: Word);                               Virtual;
      PROCEDURE Read (Var Buf; Count: Longint);                      Virtual;
      PROCEDURE Write (Var Buf; Count: Longint);                     Virtual;
   private
      FileInfo : File;
   END;
   PDosStream = ^TDosStream;

{ ******************************* REMARK ****************************** }
{   A few minor changes to this object and an extra field added called  }
{  lastmode which holds the read or write condition last using the      }
{  speed up buffer which helps speed up the flush, position and size    }
{  functions. All existing code should work without any changes.        }
{ ****************************** END REMARK *** Leon de Boer, 19May96 * }

{---------------------------------------------------------------------------}
{                TBufStream OBJECT - BUFFERED DOS FILE STREAM               }
{---------------------------------------------------------------------------}
TYPE
   TBufStream = OBJECT (TDosStream)
         LastMode: Byte;                              { Last buffer mode }
         BufSize : Longint;                           { Buffer size }
         BufPtr  : Longint;                           { Buffer start }
         BufEnd  : Longint;                           { Buffer end }
         Buffer  : PByteArray;                        { Buffer allocated }
      CONSTRUCTOR Init (FileName: FNameStr; Mode, Size: Word);
      DESTRUCTOR Done;                                               Virtual;
      PROCEDURE Close;                                               Virtual;
      PROCEDURE Flush;                                               Virtual;
      PROCEDURE Truncate;                                            Virtual;
      PROCEDURE Seek (Pos: LongInt);                                 Virtual;
      PROCEDURE Open (OpenMode: Word);                               Virtual;
      PROCEDURE Read (Var Buf; Count: Longint);                      Virtual;
      PROCEDURE Write (Var Buf; Count: Longint);                     Virtual;
   END;
   PBufStream = ^TBufStream;

{ ******************************* REMARK ****************************** }
{  All the changes here should be completely transparent to existing    }
{  code. Basically the memory blocks do not have to be base segments    }
{  but this means our list becomes memory blocks rather than segments.  }
{  The stream will also expand like the other standard streams!!        }
{ ****************************** END REMARK *** Leon de Boer, 19May96 * }

{---------------------------------------------------------------------------}
{               TMemoryStream OBJECT - MEMORY STREAM OBJECT                 }
{---------------------------------------------------------------------------}
TYPE
   TMemoryStream = OBJECT (TStream)
         BlkCount: Longint;                           { Number of segments }
         BlkSize : Word;                              { Memory block size }
         MemSize : LongInt;                           { Memory alloc size }
         BlkList : PPointerArray;                     { Memory block list }
      CONSTRUCTOR Init (ALimit: Longint; ABlockSize: Word);
      DESTRUCTOR Done;                                               Virtual;
      PROCEDURE Truncate;                                            Virtual;
      PROCEDURE Read (Var Buf; Count: Longint);                      Virtual;
      PROCEDURE Write (Var Buf; Count: Longint);                     Virtual;
      PRIVATE
      FUNCTION ChangeListSize (ALimit: Longint): Boolean;
   END;
   PMemoryStream = ^TMemoryStream;


TYPE
  TItemList = Array [0..MaxCollectionSize - 1] Of Pointer;
  PItemList = ^TItemList;

{ ******************************* REMARK ****************************** }
{    The changes here look worse than they are. The Sw_Integer simply   }
{  switches between Integers and LongInts if switched between 16 and 32 }
{  bit code. All existing code will compile without any changes.        }
{ ****************************** END REMARK *** Leon de Boer, 10May96 * }

{---------------------------------------------------------------------------}
{              TCollection OBJECT - COLLECTION ANCESTOR OBJECT              }
{---------------------------------------------------------------------------}
   TCollection = OBJECT (TObject)
         Items: PItemList;                            { Item list pointer }
         Count: Sw_Integer;                           { Item count }
         Limit: Sw_Integer;                           { Item limit count }
         Delta: Sw_Integer;                           { Inc delta size }
      CONSTRUCTOR Init (ALimit, ADelta: Sw_Integer);
      CONSTRUCTOR Load (Var S: TStream);
      DESTRUCTOR Done;                                               Virtual;
      FUNCTION At (Index: Sw_Integer): Pointer;
      FUNCTION IndexOf (Item: Pointer): Sw_Integer;                  Virtual;
      FUNCTION GetItem (Var S: TStream): Pointer;                    Virtual;
      FUNCTION LastThat (Test: Pointer): Pointer;
      FUNCTION FirstThat (Test: Pointer): Pointer;
      PROCEDURE Pack;
      PROCEDURE FreeAll;
      PROCEDURE DeleteAll;
      PROCEDURE Free (Item: Pointer);
      PROCEDURE Insert (Item: Pointer);                              Virtual;
      PROCEDURE Delete (Item: Pointer);
      PROCEDURE AtFree (Index: Sw_Integer);
      PROCEDURE FreeItem (Item: Pointer);                            Virtual;
      PROCEDURE AtDelete (Index: Sw_Integer);
      PROCEDURE ForEach (Action: Pointer);
      PROCEDURE SetLimit (ALimit: Sw_Integer);                       Virtual;
      PROCEDURE Error (Code, Info: Integer);                         Virtual;
      PROCEDURE AtPut (Index: Sw_Integer; Item: Pointer);
      PROCEDURE AtInsert (Index: Sw_Integer; Item: Pointer);
      PROCEDURE Store (Var S: TStream);
      PROCEDURE PutItem (Var S: TStream; Item: Pointer);             Virtual;
   END;
   PCollection = ^TCollection;

{---------------------------------------------------------------------------}
{          TSortedCollection OBJECT - SORTED COLLECTION ANCESTOR            }
{---------------------------------------------------------------------------}
TYPE
   TSortedCollection = OBJECT (TCollection)
         Duplicates: Boolean;                         { Duplicates flag }
      CONSTRUCTOR Init (ALimit, ADelta: Sw_Integer);
      CONSTRUCTOR Load (Var S: TStream);
      FUNCTION KeyOf (Item: Pointer): Pointer;                       Virtual;
      FUNCTION IndexOf (Item: Pointer): Sw_Integer;                  Virtual;
      FUNCTION Compare (Key1, Key2: Pointer): Sw_Integer;            Virtual;
      FUNCTION Search (Key: Pointer; Var Index: Sw_Integer): Boolean;Virtual;
      PROCEDURE Insert (Item: Pointer);                              Virtual;
      PROCEDURE Store (Var S: TStream);
   END;
   PSortedCollection = ^TSortedCollection;

{---------------------------------------------------------------------------}
{           TStringCollection OBJECT - STRING COLLECTION OBJECT             }
{---------------------------------------------------------------------------}
TYPE
   TStringCollection = OBJECT (TSortedCollection)
      FUNCTION GetItem (Var S: TStream): Pointer;                    Virtual;
      FUNCTION Compare (Key1, Key2: Pointer): Sw_Integer;            Virtual;
      PROCEDURE FreeItem (Item: Pointer);                            Virtual;
      PROCEDURE PutItem (Var S: TStream; Item: Pointer);             Virtual;
   END;
   PStringCollection = ^TStringCollection;

{---------------------------------------------------------------------------}
{             TStrCollection OBJECT - STRING COLLECTION OBJECT              }
{---------------------------------------------------------------------------}
TYPE
   TStrCollection = OBJECT (TSortedCollection)
      FUNCTION Compare (Key1, Key2: Pointer): Sw_Integer;            Virtual;
      FUNCTION GetItem (Var S: TStream): Pointer;                    Virtual;
      PROCEDURE FreeItem (Item: Pointer);                            Virtual;
      PROCEDURE PutItem (Var S: TStream; Item: Pointer);             Virtual;
   END;
   PStrCollection = ^TStrCollection;

{ ******************************* REMARK ****************************** }
{    This is a completely >> NEW << object which holds a collection of  }
{  strings but does not alphabetically sort them. It is a very useful   }
{  object for insert ordered list boxes!                                }
{ ****************************** END REMARK *** Leon de Boer, 15May96 * }

{---------------------------------------------------------------------------}
{        TUnSortedStrCollection - UNSORTED STRING COLLECTION OBJECT         }
{---------------------------------------------------------------------------}
TYPE
   TUnSortedStrCollection = OBJECT (TStringCollection)
      PROCEDURE Insert (Item: Pointer);                              Virtual;
   END;
   PUnSortedStrCollection = ^TUnSortedStrCollection;

{---------------------------------------------------------------------------}
{         TResourceCollection OBJECT - RESOURCE COLLECTION OBJECT           }
{---------------------------------------------------------------------------}
TYPE
   TResourceCollection = OBJECT (TStringCollection)
      FUNCTION KeyOf (Item: Pointer): Pointer;                       Virtual;
      FUNCTION GetItem (Var S: TStream): Pointer;                    Virtual;
      PROCEDURE FreeItem (Item: Pointer);                            Virtual;
      PROCEDURE PutItem (Var S: TStream; Item: Pointer);             Virtual;
   END;
   PResourceCollection = ^TResourceCollection;

{---------------------------------------------------------------------------}
{                 TResourceFile OBJECT - RESOURCE FILE OBJECT               }
{---------------------------------------------------------------------------}
TYPE
   TResourceFile = OBJECT (TObject)
         Stream  : PStream;                           { File as a stream }
         Modified: Boolean;                           { Modified flag }
      CONSTRUCTOR Init (AStream: PStream);
      DESTRUCTOR Done;                                               Virtual;
      FUNCTION Count: Sw_Integer;
      FUNCTION KeyAt (I: Sw_Integer): String;
      FUNCTION Get (Key: String): PObject;
      FUNCTION SwitchTo (AStream: PStream; Pack: Boolean): PStream;
      PROCEDURE Flush;
      PROCEDURE Delete (Key: String);
      PROCEDURE Put (Item: PObject; Key: String);
      PRIVATE
         BasePos: LongInt;                            { Base position }
         IndexPos: LongInt;                           { Index position }
         Index: TResourceCollection;                  { Index collection }
   END;
   PResourceFile = ^TResourceFile;

TYPE
   TStrIndexRec = Packed RECORD
      Key : Sw_word;
      Count, Offset: Word;
   END;

   TStrIndex = Array [0..9999] Of TStrIndexRec;
   PStrIndex = ^TStrIndex;

{---------------------------------------------------------------------------}
{                 TStringList OBJECT - STRING LIST OBJECT                   }
{---------------------------------------------------------------------------}
   TStringList = OBJECT (TObject)
      CONSTRUCTOR Load (Var S: TStream);
      DESTRUCTOR Done;                                               Virtual;
      FUNCTION Get (Key: Sw_Word): String;
      PRIVATE
         Stream   : PStream;
         BasePos  : Longint;
         IndexSize: Longint;
         Index    : PStrIndex;
      PROCEDURE ReadStr (Var S: String; Offset, Skip: Longint);
   END;
   PStringList = ^TStringList;

{---------------------------------------------------------------------------}
{                 TStrListMaker OBJECT - RESOURCE FILE OBJECT               }
{---------------------------------------------------------------------------}
TYPE
   TStrListMaker = OBJECT (TObject)
      CONSTRUCTOR Init (AStrSize, AIndexSize: Sw_Word);
      DESTRUCTOR Done;                                               Virtual;
      PROCEDURE Put (Key: Sw_Word; S: String);
      PROCEDURE Store (Var S: TStream);
      PRIVATE
         StrPos   : Sw_Word;
         StrSize  : Sw_Word;
         Strings  : PByteArray;
         IndexPos : Sw_Word;
         IndexSize: Sw_Word;
         Index    : PStrIndex;
         Cur      : TStrIndexRec;
      PROCEDURE CloseCurrent;
   END;
   PStrListMaker = ^TStrListMaker;

{***************************************************************************}
{                            INTERFACE ROUTINES                             }
{***************************************************************************}

{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{                      CALL HELPERS INTERFACE ROUTINES                      }
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}

{ Constructor calls.

  Ctor     Pointer to the constructor.
  Obj      Pointer to the instance. NIL if new instance to be allocated.
  VMT      Pointer to the VMT (obtained by TypeOf()).
  returns  Pointer to the instance.
}
function CallVoidConstructor(Ctor: pointer; Obj: pointer; VMT: pointer): pointer;inline;
function CallPointerConstructor(Ctor: pointer; Obj: pointer; VMT: pointer; Param1: pointer): pointer;inline;

{ Method calls.

  Method   Pointer to the method.
  Obj      Pointer to the instance. NIL if new instance to be allocated.
  returns  Pointer to the instance.
}
function CallVoidMethod(Method: pointer; Obj: pointer): pointer;inline;
function CallPointerMethod(Method: pointer; Obj: pointer; Param1: pointer): pointer;inline;

{ Local-function/procedure calls.

  Func     Pointer to the local function (which must be far-coded).
  Frame    Frame pointer of the wrapping function.
}

function CallVoidLocal(Func: pointer; Frame: Pointer): pointer;inline;
function CallPointerLocal(Func: pointer; Frame: Pointer; Param1: pointer): pointer;inline;

{ Calls of functions/procedures local to methods.

  Func     Pointer to the local function (which must be far-coded).
  Frame    Frame pointer of the wrapping method.
  Obj      Pointer to the object that the method belongs to.
}
function CallVoidMethodLocal(Func: pointer; Frame: Pointer; Obj: pointer): pointer;inline;
function CallPointerMethodLocal(Func: pointer; Frame: Pointer; Obj: pointer; Param1: pointer): pointer;inline;


{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{                    DYNAMIC STRING INTERFACE ROUTINES                      }
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}

{-NewStr-------------------------------------------------------------
Allocates a dynamic string into memory. If S is nil, NewStr returns
a nil pointer, otherwise NewStr allocates Length(S)+1 bytes of memory
containing a copy of S, and returns a pointer to the string.
12Jun96 LdB
---------------------------------------------------------------------}
FUNCTION NewStr (Const S: String): PString;

{-DisposeStr---------------------------------------------------------
Disposes of a PString allocated by the function NewStr.
12Jun96 LdB
---------------------------------------------------------------------}
PROCEDURE DisposeStr (P: PString);

PROCEDURE SetStr(VAR p:pString; CONST s:STRING);


{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{                        STREAM INTERFACE ROUTINES                          }
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}

{-Abstract-----------------------------------------------------------
Terminates program with a run-time error 211. When implementing
an abstract object type, call Abstract in those virtual methods that
must be overridden in descendant types. This ensures that any
attempt to use instances of the abstract object type will fail.
12Jun96 LdB
---------------------------------------------------------------------}
PROCEDURE Abstract;

{-RegisterObjects----------------------------------------------------
Registers the three standard objects TCollection, TStringCollection
and TStrCollection.
02Sep97 LdB
---------------------------------------------------------------------}
PROCEDURE RegisterObjects;

{-RegisterType-------------------------------------------------------
Registers the given object type with Free Vision's streams, creating
a list of known objects. Streams can only store and return these known
object types. Each registered object needs a unique stream registration
record, of type TStreamRec.
02Sep97 LdB
---------------------------------------------------------------------}
PROCEDURE RegisterType (Var S: TStreamRec);

{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{                    GENERAL FUNCTION INTERFACE ROUTINES                    }
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}

{-LongMul------------------------------------------------------------
Returns the long integer value of X * Y integer values.
04Sep97 LdB
---------------------------------------------------------------------}
FUNCTION LongMul (X, Y: Integer): LongInt;

{-LongDiv------------------------------------------------------------
Returns the integer value of long integer X divided by integer Y.
04Sep97 LdB
---------------------------------------------------------------------}
FUNCTION LongDiv (X: Longint; Y: Integer): Integer;


{***************************************************************************}
{                         PUBLIC INITIALIZED VARIABLES                      }
{***************************************************************************}


CONST
{---------------------------------------------------------------------------}
{              INITIALIZED DOS/DPMI/WIN/OS2 PUBLIC VARIABLES                }
{---------------------------------------------------------------------------}
   StreamError: Pointer = Nil;                        { Stream error ptr }
   DefaultTPCompatible: Boolean = false;

{---------------------------------------------------------------------------}
{                        STREAM REGISTRATION RECORDS                        }
{---------------------------------------------------------------------------}

CONST
   RCollection: TStreamRec = (
     ObjType: 50;
     VmtLink: Ofs(TypeOf(TCollection)^);
     Load: @TCollection.Load;
     Store: @TCollection.Store;
     Next: Nil);

   RStringCollection: TStreamRec = (
     ObjType: 51;
     VmtLink: Ofs(TypeOf(TStringCollection)^);
     Load: @TStringCollection.Load;
     Store: @TStringCollection.Store;
     Next: Nil);

   RStrCollection: TStreamRec = (
     ObjType: 69;
     VmtLink: Ofs(TypeOf(TStrCollection)^);
     Load:    @TStrCollection.Load;
     Store:   @TStrCollection.Store;
     Next: Nil);

   RStringList: TStreamRec = (
     ObjType: 52;
     VmtLink: Ofs(TypeOf(TStringList)^);
     Load: @TStringList.Load;
     Store: Nil;
     Next: Nil);

   RStrListMaker: TStreamRec = (
     ObjType: 52;
     VmtLink: Ofs(TypeOf(TStrListMaker)^);
     Load: Nil;
     Store: @TStrListMaker.Store;
     Next: Nil);

{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}
                                IMPLEMENTATION
{<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>}

Uses dos;

{***************************************************************************}
{                      HELPER ROUTINES FOR CALLING                          }
{***************************************************************************}

type
  VoidLocal = function(_EBP: Pointer): pointer;
  PointerLocal = function(_EBP: Pointer; Param1: pointer): pointer;
  VoidMethodLocal = function(_EBP: Pointer): pointer;
  PointerMethodLocal = function(_EBP: Pointer; Param1: pointer): pointer;
  VoidConstructor = function(VMT: pointer; Obj: pointer): pointer;
  PointerConstructor = function(VMT: pointer; Obj: pointer; Param1: pointer): pointer;
  VoidMethod = function(Obj: pointer): pointer;
  PointerMethod = function(Obj: pointer; Param1: pointer): pointer;


function CallVoidConstructor(Ctor: pointer; Obj: pointer; VMT: pointer): pointer;inline;
begin
  CallVoidConstructor := VoidConstructor(Ctor)(Obj, VMT);
end;


function CallPointerConstructor(Ctor: pointer; Obj: pointer; VMT: pointer; Param1: pointer): pointer;inline;
{$undef FPC_CallPointerConstructor_Implemented}
begin
  {$define FPC_CallPointerConstructor_Implemented}
  CallPointerConstructor := PointerConstructor(Ctor)(Obj, VMT, Param1)
end;
{$ifndef FPC_CallPointerConstructor_Implemented}
{$error CallPointerConstructor function not implemented}
{$endif not FPC_CallPointerConstructor_Implemented}


function CallVoidMethod(Method: pointer; Obj: pointer): pointer;inline;
begin
  CallVoidMethod := VoidMethod(Method)(Obj)
end;


function CallPointerMethod(Method: pointer; Obj: pointer; Param1: pointer): pointer;inline;
{$undef FPC_CallPointerMethod_Implemented}
begin
{$define FPC_CallPointerMethod_Implemented}
  CallPointerMethod := PointerMethod(Method)(Obj, Param1)
end;
{$ifndef FPC_CallPointerMethod_Implemented}
{$error CallPointerMethod function not implemented}
{$endif not FPC_CallPointerMethod_Implemented}


function CallVoidLocal(Func: pointer; Frame: Pointer): pointer;inline;
begin
  CallVoidLocal := VoidLocal(Func)(Frame)
end;


function CallPointerLocal(Func: pointer; Frame: Pointer; Param1: pointer): pointer;inline;
begin
  CallPointerLocal := PointerLocal(Func)(Frame, Param1)
end;


function CallVoidMethodLocal(Func: pointer; Frame: Pointer; Obj: pointer): pointer;inline;
begin
  CallVoidMethodLocal := VoidMethodLocal(Func)(Frame)
end;


function CallPointerMethodLocal(Func: pointer; Frame: Pointer; Obj: pointer; Param1: pointer): pointer;inline;
begin
  CallPointerMethodLocal := PointerMethodLocal(Func)(Frame, Param1)
end;




{***************************************************************************}
{                      PRIVATE INITIALIZED VARIABLES                        }
{***************************************************************************}

{---------------------------------------------------------------------------}
{               INITIALIZED DOS/DPMI/WIN/OS2 PRIVATE VARIABLES              }
{---------------------------------------------------------------------------}
CONST
   StreamTypes: PStreamRec = Nil;                     { Stream types reg }

{***************************************************************************}
{                          PRIVATE INTERNAL ROUTINES                        }
{***************************************************************************}
{---------------------------------------------------------------------------}
{  RegisterError -> Platforms DOS/DPMI/WINDOWS/OS2 - Checked 12Jun96 LdB    }
{---------------------------------------------------------------------------}
PROCEDURE RegisterError;
BEGIN
   RunError(212);                                     { Register error }
END;


{***************************************************************************}
{                               OBJECT METHODS                              }
{***************************************************************************}

{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{                           TRect OBJECT METHODS                            }
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
PROCEDURE CheckEmpty (Var Rect: TRect);
BEGIN
   With Rect Do Begin
     If (A.X >= B.X) OR (A.Y >= B.Y) Then Begin       { Zero or reversed }
       A.X := 0;                                      { Clear a.x }
       A.Y := 0;                                      { Clear a.y }
       B.X := 0;                                      { Clear b.x }
       B.Y := 0;                                      { Clear b.y }
     End;
   End;
END;

{--TRect--------------------------------------------------------------------}
{  Empty -> Platforms DOS/DPMI/WIN/OS2 - Checked 10May96 LdB                }
{---------------------------------------------------------------------------}
FUNCTION TRect.Empty: Boolean;
BEGIN
   Empty := (A.X >= B.X) OR (A.Y >= B.Y);             { Empty result }
END;

{--TRect--------------------------------------------------------------------}
{  Equals -> Platforms DOS/DPMI/WIN/OS2 - Checked 10May96 LdB               }
{---------------------------------------------------------------------------}
FUNCTION TRect.Equals (R: TRect): Boolean;
BEGIN
   Equals := (A.X = R.A.X) AND (A.Y = R.A.Y) AND
   (B.X = R.B.X) AND (B.Y = R.B.Y);                   { Equals result }
END;

{--TRect--------------------------------------------------------------------}
{  Contains -> Platforms DOS/DPMI/WIN/OS2 - Checked 10May96 LdB             }
{---------------------------------------------------------------------------}
FUNCTION TRect.Contains (P: TPoint): Boolean;
BEGIN
   Contains := (P.X >= A.X) AND (P.X < B.X) AND
     (P.Y >= A.Y) AND (P.Y < B.Y);                    { Contains result }
END;

{--TRect--------------------------------------------------------------------}
{  Copy -> Platforms DOS/DPMI/WIN/OS2 - Checked 10May96 LdB                 }
{---------------------------------------------------------------------------}
PROCEDURE TRect.Copy (R: TRect);
BEGIN
   A := R.A;                                          { Copy point a }
   B := R.B;                                          { Copy point b }
END;

{--TRect--------------------------------------------------------------------}
{  Union -> Platforms DOS/DPMI/WIN/OS2 - Checked 10May96 LdB                }
{---------------------------------------------------------------------------}
PROCEDURE TRect.Union (R: TRect);
BEGIN
   If (R.A.X < A.X) Then A.X := R.A.X;                { Take if smaller }
   If (R.A.Y < A.Y) Then A.Y := R.A.Y;                { Take if smaller }
   If (R.B.X > B.X) Then B.X := R.B.X;                { Take if larger }
   If (R.B.Y > B.Y) Then B.Y := R.B.Y;                { Take if larger }
END;

{--TRect--------------------------------------------------------------------}
{  Intersect -> Platforms DOS/DPMI/WIN/OS2 - Checked 10May96 LdB            }
{---------------------------------------------------------------------------}
PROCEDURE TRect.Intersect (R: TRect);
BEGIN
   If (R.A.X > A.X) Then A.X := R.A.X;                { Take if larger }
   If (R.A.Y > A.Y) Then A.Y := R.A.Y;                { Take if larger }
   If (R.B.X < B.X) Then B.X := R.B.X;                { Take if smaller }
   If (R.B.Y < B.Y) Then B.Y := R.B.Y;                { Take if smaller }
   CheckEmpty(Self);                                  { Check if empty }
END;

{--TRect--------------------------------------------------------------------}
{  Move -> Platforms DOS/DPMI/WIN/OS2 - Checked 10May96 LdB                 }
{---------------------------------------------------------------------------}
PROCEDURE TRect.Move (ADX, ADY: Sw_Integer);
BEGIN
   Inc(A.X, ADX);                                     { Adjust A.X }
   Inc(A.Y, ADY);                                     { Adjust A.Y }
   Inc(B.X, ADX);                                     { Adjust B.X }
   Inc(B.Y, ADY);                                     { Adjust B.Y }
END;

{--TRect--------------------------------------------------------------------}
{  Grow -> Platforms DOS/DPMI/WIN/OS2 - Checked 10May96 LdB                 }
{---------------------------------------------------------------------------}
PROCEDURE TRect.Grow (ADX, ADY: Sw_Integer);
BEGIN
   Dec(A.X, ADX);                                     { Adjust A.X }
   Dec(A.Y, ADY);                                     { Adjust A.Y }
   Inc(B.X, ADX);                                     { Adjust B.X }
   Inc(B.Y, ADY);                                     { Adjust B.Y }
   CheckEmpty(Self);                                  { Check if empty }
END;

{--TRect--------------------------------------------------------------------}
{  Assign -> Platforms DOS/DPMI/WIN/OS2 - Checked 10May96 LdB               }
{---------------------------------------------------------------------------}
PROCEDURE TRect.Assign (XA, YA, XB, YB: Sw_Integer);
BEGIN
   A.X := XA;                                         { Hold A.X value }
   A.Y := YA;                                         { Hold A.Y value }
   B.X := XB;                                         { Hold B.X value }
   B.Y := YB;                                         { Hold B.Y value }
END;

{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{                           TObject OBJECT METHODS                          }
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}

TYPE
   DummyObject = OBJECT (TObject)                     { Internal object }
     Data: RECORD END;                                { Helps size VMT link }
   END;

{ ******************************* REMARK ****************************** }
{ I Prefer this code because it self sizes VMT link rather than using a }
{ fixed record structure thus it should work on all compilers without a }
{ specific record to match each compiler.                               }
{ ****************************** END REMARK *** Leon de Boer, 10May96 * }

{--TObject------------------------------------------------------------------}
{  Init -> Platforms DOS/DPMI/WIN/OS2 - Checked 10May96 LdB                 }
{---------------------------------------------------------------------------}
CONSTRUCTOR TObject.Init;
VAR LinkSize: LongInt; Dummy: DummyObject;
BEGIN
   LinkSize := Pbyte(@Dummy.Data)-Pbyte(@Dummy);  { Calc VMT link size }
   FillChar((Pbyte(@Self)+LinkSize)^,
     SizeOf(Self)-LinkSize, #0);                      { Clear data fields }
END;

{--TObject------------------------------------------------------------------}
{  Free -> Platforms DOS/DPMI/WIN/OS2 - Checked 10May96 LdB                 }
{---------------------------------------------------------------------------}
PROCEDURE TObject.Free;
BEGIN
   Dispose(PObject(@Self), Done);                     { Dispose of self }
END;

{--TObject------------------------------------------------------------------}
{  Is_Object -> Platforms DOS/DPMI/WIN/OS2 - Checked 5Mar00 DM              }
{---------------------------------------------------------------------------}
FUNCTION TObject.Is_Object(P:Pointer):Boolean;
TYPE
   PVMT=^VMT;
   PPVMT=^PVMT;
   VMT=RECORD
     Size,NegSize:Longint;
     ParentLink:PVMT;
   END;
VAR SP:PPVMT; Q:PVMT;
BEGIN
   SP:=PPVMT(@SELF);
   Q:=SP^;
   Is_Object:=False;
   While Q<>Nil Do Begin
     IF Q=P THEN Begin
       Is_Object:=True;
       Break;
     End;
     Q:=Q^.Parentlink;
   End;
END;

{--TObject------------------------------------------------------------------}
{  Done -> Platforms DOS/DPMI/WIN/OS2 - Checked 10May96 LdB                 }
{---------------------------------------------------------------------------}
DESTRUCTOR TObject.Done;
BEGIN                                                 { Abstract method }
END;

{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{                           TStream OBJECT METHODS                          }
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}

CONSTRUCTOR TStream.Init;
BEGIN
  Status := StOK;
  ErrorInfo := 0;
  StreamSize := 0;
  Position := 0;
  TPCompatible := DefaultTPCompatible;
END;

{--TStream------------------------------------------------------------------}
{  Get -> Platforms DOS/DPMI/WIN/OS2 - Checked 02Sep97 LdB                  }
{---------------------------------------------------------------------------}
FUNCTION TStream.Get: PObject;
VAR ObjType: Sw_Word; P: PStreamRec; ObjTypeWord: Word;
BEGIN
   If TPCompatible Then Begin
     { Read 16-bit word for TP compatibility. }
     Read(ObjTypeWord, SizeOf(ObjTypeWord));
     ObjType := ObjTypeWord
   End
   else
     Read(ObjType, SizeOf(ObjType));                  { Read object type }
   If (ObjType<>0) Then Begin                         { Object registered }
     P := StreamTypes;                                { Current reg list }
     While (P <> Nil) AND (P^.ObjType <> ObjType)     { Find object type OR }
       Do P := P^.Next;                               { Find end of chain }
     If (P=Nil) Then Begin                            { Not registered }
       Error(stGetError, ObjType);                    { Obj not registered }
       Get := Nil;                                    { Return nil pointer }
     End Else
       Get :=PObject(
         CallPointerConstructor(P^.Load,Nil,P^.VMTLink, @Self))  { Call constructor }
   End Else Get := Nil;                               { Return nil pointer }
END;

{--TStream------------------------------------------------------------------}
{  StrRead -> Platforms DOS/DPMI/WIN/OS2 - Checked 10May96 LdB              }
{---------------------------------------------------------------------------}
FUNCTION TStream.StrRead: PChar;
VAR L: Word; P: PChar;
BEGIN
   Read(L, SizeOf(L));                                { Read length }
   If (L = 0) Then StrRead := Nil Else Begin          { Check for empty }
     GetMem(P, L + 1);                                { Allocate memory }
     If (P <> Nil) Then Begin                         { Check allocate okay }
       Read(P[0], L);                                 { Read the data }
       P[L] := #0;                                    { Terminate with #0 }
     End;
     StrRead := P;                                    { Return PChar }
   End;
END;

{--TStream------------------------------------------------------------------}
{  ReadStr -> Platforms DOS/DPMI/WIN/OS2 - Checked 10May96 LdB              }
{---------------------------------------------------------------------------}
FUNCTION TStream.ReadStr: PString;
VAR L: Byte; P: PString;
BEGIN
   Read(L, 1);                                        { Read string length }
   If (L > 0) Then Begin
     GetMem(P, L + 1);                                { Allocate memory }
     If (P <> Nil) Then Begin                         { Check allocate okay }
       P^[0] := Char(L);                              { Hold length }
       Read(P^[1], L);                                { Read string data }
     End;
     ReadStr := P;                                    { Return string ptr }
   End Else ReadStr := Nil;
END;

{--TStream------------------------------------------------------------------}
{  GetPos -> Platforms DOS/DPMI/WIN/OS2 - Checked 10May96 LdB               }
{---------------------------------------------------------------------------}
FUNCTION TStream.GetPos: LongInt;
BEGIN
   If (Stat…