{
    This file is part of chepersy
    Copyright (c) 2004-2008 by Anton Rzheshevski (chebmaster@mail.ru),

    See the file COPYING.CPS, 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.

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

//       "NO USER SERVICEABLE PARTS BELOW THIS POINT"

var
  DH: TChepersyDatabaseHeader;



const
  ArrayLikeTypes: set of TFieldKind = [
    fk_string, fk_8bit_string, fk_dynamic_array]; //types that have pointer^.ReferenceCount layout
  StdTindPointer = 0;
  StdTindTManagedObject = 2;// 1;
  StdTindDword = 1;//2;
  StdTindArrayOfDword = 3;
  StdTind2dArrayOfDword = 4;
  StdTindUnknownSet = 5;
  StdTindQword = 6;
  StdTindArrayOfQword = 7;
  StdTindArrayOfTManagedObject = 8;
  StdTindArrayOfUnknownSet = 9;
  StdTind2dArrayOfUnknownSet = 10;
  StdTind2dArrayOfTManagedObject = 11;
  StdTind2dArrayOfQWord = 12;
  StdTindUnknownRecord = 13;
  StdTindArrayOfUnknownRecord = 14;
  StdTind2dArrayOfUnknownRecord = 15;
  StdTindMetaclass = 16;
  //Beginning with 2.4.0, the wide string type has changed for non-Windows platforms:
  WstringType = {$ifdef windows}tkWstring {$else}tkUstring{$endif};





  // *********** FIELD SAVING / LOADING ROUTINES **********************
// ! AS OF 0.9.x most of these are scraped, replaced with
//   the direct calls to the stream via the B_Stream global variable.


{   These can be used in the custom processing procedures}
//  Function SizeToBufferIndex(s: integer): integer; {$ifdef fpc}inline;{$endif} forward;
//  procedure WriteInt(i: integer); {$ifdef fpc}inline;{$endif} forward;
//  function ReadInt: integer; {$ifdef fpc}inline;{$endif} forward;

//These are the same as ***Bin, but use bytes instead.
// When writing to the stream they round up to dwords.
//  procedure ReadUnaligned(p: pointer; NumBytes: integer); {$ifdef fpc}inline;{$endif} forward;
//  procedure SkipUnaligned(NumBytes: integer); {$ifdef fpc}inline;{$endif} forward;
//  procedure WriteAnsiString(v: AnsiString); {$ifdef fpc}inline;{$endif} forward;
//  procedure WriteWideString(v: WideString); {$ifdef fpc}inline;{$endif} forward;
//  procedure SkipAnsiString; {$ifdef fpc}inline;{$endif} forward;
//  procedure SkipWideString; {$ifdef fpc}inline;{$endif} forward;
//  function ReadWideString(): WideString; {$ifdef fpc}inline;{$endif} forward;
//  function ReadAnsiString(): AnsiString; {$ifdef fpc}inline;{$endif} forward;

//  procedure WriteNil; {$ifdef fpc}inline;{$endif} forward;

  procedure ReadPersistent(var o: TManagedObject); register; forward;
  procedure WritePersistent(o: TManagedObject); forward;



  procedure LogWarnings(); forward;
//  private
  procedure DieInvalidContainer(nng: string); forward;
  procedure DieIncompatible(M: TMessageId; Param: array of Const); forward;

  procedure LoadEnum(tyi: integer; p: pointer); forward;
   //making it "inline"
   // causes a complete пиздец. Sorry for my French.
   // Note to self: report as a FreePascal bug.

  function NumObjects: integer;  forward;//_readonum(): integer;//property NumObjects: integer read _readOnum;
//  end;


type
  TCpsStub1 = (cps_st1_1, cps_st1_2);
  Chepersy_UnknownSet = set of TCpsStub1;
  Chepersy_arrayofUnknownSet = array of Chepersy_UnknownSet;
  Chepersy_2darrayofUnknownSet = array of array of Chepersy_UnknownSet;


{$ifdef oldhacky}
  var
    vmtMyClassIndex,
    vmtMyScenarioIndex,
    vmtMyFieldsList,
    vmtMyLocalFieldsList,
    vmtMyLocalClassIndex: integer;
   procedure InitializeVmtxxxConsts; forward;
{$else}
  var
    aClassInd,
    aScenarioInd: array of integer;
    aFieldsList: array of TFieldsList;
    aOffset: cardinal = 0;
   procedure InitializeIndexArrays; forward;
{$endif}
var
  BottleNeckCounter1, BottleNeckCounter2: int64;
  procedure CpsValidate(n: string); overload; forward;
  procedure CpsValidate(i: PTypeInfo); overload; forward;

//  procedure OpenCGEFileForWrite (Target: TStream); overload; forward;

  procedure PrepareToSave(Target: TStream); overload; forward;
  procedure PrepareToLoad(Source: TStream); overload; forward;

  procedure DoneSaving(FreeTheStream: boolean); forward;
  procedure DoneLoading(FreeTheStream: boolean; var OutputList: TArrayOfManagedObjects); forward;

  function GetConverterProc(Tind1, Tind2: integer): TCustomConverterProc; forward;


  function GetClassIndex(C: TClass): integer; forward;
  procedure SetClassIndex(C: TClass; index: integer); forward;


  procedure CpsFindLoadingScenario(Cind, B_LocalClassInd: integer); forward;
  procedure CpsBuildsavingScenario(Cind: integer); forward;
  procedure CpsBuildCloningScenario(Cind: integer); forward;

  procedure LoadRecord(base: pointer; op: TFieldOperation; B_ClassIndex: integer); forward;
  procedure SaveRecord(base: pointer; Cind: integer); forward;
  procedure WalkRecord(base: pointer; Cind: integer); forward;

{$ifndef cge}
  function RuEn(ru, en: WideString): WideString; forward;

  Procedure Die(YellID :TMessageID; Param: array of const); overload; forward;
  Procedure Die(YellID :TMessageID); overload;  forward;
  Procedure Die(u: WideString; Param: array of const);  overload;  forward;
  Procedure Die(u: WideString);  overload;  forward;

  Procedure AddLog(U: WideString); overload;  forward;
  Procedure AddLog(mID: TMessageID); overload;  forward;
  Procedure AddLog(mID: TMessageID; Param: array of const); overload;  forward;
  Procedure AddLog(U: WideString; Param: array of const); overload; forward;

  {$include mo_cps_stubs_public.inc}
   //simplified replacements for parts of the Cheb's Game Engine
   
{$endif}


var
  //new in 0.8.90: the old buffer allocation system finally scraped for good.
//  CpsStream: TStream; //0.8.95 replaced with CpsStream
  
  //new in 0.9
  CpsWalkMarkVal: integer = -1;

  //new in 0.9
  mXorMask, mAndMask: dword;
  CurrentWalkProc: TcustomWalkProc;



procedure BasketWarningsAdd(w: WideString); forward;
  {$include mo_cps_cfile_func.inc}

procedure DieTypeFailed(T: TTypeRecord; reason: string); forward;

procedure _RegEnum(T: TTypeRecord); forward;

//  procedure _RegisterField(name: string; Pf: pointer; PI: PTypeInfo; SkipIt: boolean);
  procedure RegBegin(C: TObject);  forward;
  procedure RegEnd;  forward;
  function ClassIndex(C: TClass): integer; forward;

procedure _RegTypeBin(Info: PTypeInfo; Size: Integer); forward;
procedure _RegTypeComplexWZK(Info: PTypeInfo; Proc: TCustomTypeProcessingProc;
                             S: integer; K: TFieldKind); forward;
Procedure NewDynArray(parray: pointer; Len, BaseTypeInd: integer); forward;

function _ListRecordFields(packd, addrrequired: boolean; base: pointer; startoffset: longint; v: array of const): TFieldDesc; forward;

procedure RegTypeClass(C: CManagedObject); forward;
procedure RegTypeComplex(Info: PTypeInfo; Proc: TCustomTypeProcessingProc); forward;
procedure RegTypeDynArrayNd(Dimensions: integer; ArrayInfo, BaseType: PTypeInfo); forward;
procedure RegTypeEnum(Info: PTypeInfo); forward;
procedure RegTypeDynArray1d(ArrayInfo, BaseType: PTypeInfo); forward;

 {$ifdef delphiworkaround}
  procedure DumbDelphiSetMyFieldsList(C: TClass; F: TObject); forward;
 {$endif}
 
  //registers procedure that converts between the known types
  //  (e.g. shortint / longint), so you can change field types
  //  and the class could still be loaded.
  //Converters for all known numeric types are already registered.
  procedure RegTypeConverter(types1, types2: array of const; p: TCustomConverterProc); forward;


const
  tind_pointer = 0;
  tind_dword = 1;
  tind_arrayofdword = 3;
  tind_2darrayofdword = 4;
  tind_unknown_set = 5;
  tind_unknown_record = 13;

var
  Scenario,
  CloningScenario: array of dword;

{$ifdef oldhacky}
  InvalidClassIndex: integer;
{$endif}
//  LocalTI: integer;

  //Global variables, formerly fields of classes TRegistrator and TBasket:
  Fields, SaveableFields: TFieldInfos;
  Records: TAOI; //type indices. Formerly for classes, since v0.9 also for records
  ClassAncestors: T2DAOI;
  NameSpace,
  TypeNameSpace,
  ClassNameSpace: TNameSpace;
  Types: TTypeRegistry;
  TypeToRecInd: array of integer;
  Enums: T2DAOI;
  tScenarioIndex, clScenarioIndex: array of integer;
  
  CurrentObject: TAOMO;//TManagedObject;
  CurrentObjectInd: TAOI;
  prevOffset, prevSize, prevname, prevtype: integer;




//  B_ScenarioIndex: array of Integer;
  ContName: string;
  CurrentInd: integer;
  Obj: TAOMO;

  procedure RP_Dyna (PField: pointer; OP: TFieldOperation; Tind: integer); register; forward;

type
  TDwordArray = array[0..$0FFFFFFF] of Dword;
  PDwordArray = ^TDwordArray;
  PArrayOfPointer = ^ArrayOfPointer;
  ArrayOfPointer = array of pointer;

var
  NowSaving, NowLoading: boolean; //additional check for out-of-scope calls

  operator = (a, b: TMd5Digest) z: system.boolean;
  var i: integer;
  begin
    for i:=0 to High(a) do if a[i] <> b[i] then begin z:= False; Exit end;
    z:= True;
  end;

  procedure ValidateChepersyState(s: string);
  begin
    if not CpsFinalized then ClassesRegistrationEnd;
    if not CpsValid then raise Exception.Create(
      'Call to ' + s + ' when Chepersy is not initialized yet!');
  end;

  procedure BasketwarningsAdd(w: WideString);
  begin
    CpsParserWarnings.Add({$ifdef fpc} Utf8Encode(w) {$else} w {$endif} );
  end;

  function min(a, b: integer): integer; inline;
  begin
    if a < b then Result:=a else Result:=b;
  end;

  Function SizeToBufferIndex(s: integer): integer; inline;
  begin
    if s > 0 then Result:= 1 + ((s - 1) div SizeOf(dword)) //compiler should optimize it into shr 2
             else Result:= 0;
  end;
  
{$ifndef oldhacky}
  const hShift = {$ifdef fpc}5{$else}7{$endif};

  function CHash(C: TClass): cardinal; register; inline;
  begin
    Result:=(cardinal(C) shr hShift) - aOffset;
  end;
  
  function cFitsIndexArrays(C: TClass): boolean; register; inline;
  begin
    Result:=(CHash(C) <= high(aClassInd));
  end;

  procedure MakeSureClassFitsIndexArrays(C: TClass);
  var
    n: int64;
    i, j: integer;
  begin
    if cFitsIndexArrays(C) then Exit;
    n:=int64(cardinal(C) shr hShift) - int64(aOffset);
//addlog(' -----------------  %0  %1  %2  %3', [cardinal(C) shr hShift, aoffset, high(aClassInd), n] );
    if n < 0 then begin
      if MotherState^.VerboseLog then AddLog(RuEn('  Индексные массивы расширяются на %1 чтобы вместить %0','  Expanding index arrays by %1 to fit %0.'), [string(C.ClassName), n]);
      i:=length(aClassInd);
      SetLength(aClassInd, i - n);
      SetLength(aScenarioInd, i - n);
      SetLength(aFieldsList, i - n);
      For j:=high(aClassInd) downto - n do begin
        aClassInd[j]:=aClassInd[j + n];
        aScenarioInd[j]:=aScenarioInd[j + n];
        pointer(aFieldsList[j]):=pointer(aFieldsList[j + n]);
      end;
      For j:=0 to -n - 1 do begin
        aClassInd[j]:=0;
        aScenarioInd[j]:=0;
        pointer(aFieldsList[j]):=nil;
      end;
      aOffset:=0;
      aOffset:=CHash(C);
    end
    else begin
      i:=Length(aClassInd);
      if MotherState^.VerboseLog then AddLog(RuEn('  Индексные массивы расширяются на %1 чтобы вместить %0','  Expanding index arrays by %1 to fit %0.'), [string(C.ClassName), n - i + 1]);
      SetLength(aClassInd, n + 1);
      SetLength(aScenarioInd, n + 1);
      SetLength(aFieldsList, n + 1);
      For j:=i to high(aClassInd) do begin
        aClassInd[j]:=0;
        aScenarioInd[j]:=0;
        pointer(aFieldsList[j]):=nil;
      end;
    end;
    
  end;

  procedure InitializeIndexArrays;
  var
    C: TClass;
    O: TObject;
  begin
    {$ifdef fpc}
      C:=TObject.ClassType;
    {$else}
      O:=TObject.Create;
      C:=O.ClassType;
      O.Free;
    {$endif}
    aOffset:=CHash(C);
  end;
  
{$endif}

  function LocalClassNameStr(i: integer): AnsiString;
  begin
    Result:=DH.B_NameSpace[DH.CNames[i]];
  end;

  procedure WriteInt(i: integer); {$ifdef fpc}inline;{$endif}
  begin
    {$ifdef fpc}
    CpsStream.WriteDWord(dword(i));
    {$else}
    CpsStream.WriteBuffer(i, 4);
    {$endif}
  end;

  function ReadInt: integer; {$ifdef fpc}inline;{$endif}
  begin
    {$ifdef fpc}
    Result:= integer(CpsStream.ReadDWord());
    {$else}
    CpsStream.ReadBuffer(Result, 4);
    {$endif}
  end;

  {$ifndef fpc}
 procedure WriteDword(i: dword);
  begin
    CpsStream.WriteBuffer(i, 4);
  end;

  function ReadDword: dword;
  begin
    CpsStream.ReadBuffer(Result, 4);
  end;
  {$endif}

  procedure ReadUnaligned(p: pointer; NumBytes: integer);
  {$ifdef support08x}
  var w, i: dword;
  {$endif}
  begin
    CpsStream.Read(p^, NumBytes);
    {$ifdef support08x}
     if DH.StreamVersion = 0 then begin
       i:= (4 - (NumBytes and 3)) and 3;
       if i > 0 then CpsStream.Read(w, i);
     end;
    {$endif}
  end;
  
(*  procedure WriteUnaligned(p: pointer; NumBytes: integer);
  begin
    CpsStream.Write(p^, NumBytes);
    CpsStream.Position:= CpsStream.Position + (4 - (NumBytes and 3)) and 3;
  end;
*)

  procedure SkipUnaligned(NumBytes: integer);
  var a: array of byte;
  begin
   {$ifdef support08x}
    if DH.StreamVersion = 0 then
      SetLength(a, AlignGranularity * SizeToBufferIndex(NumBytes))
    else
   {$endif}
      SetLength(a, NumBytes);
    CpsStream.Read(a[0], Length(a));
  end;

    function AlignedSize(s: integer): integer; {$ifdef fpc}inline;{$endif}
    begin
      Result:=SizeToBufferIndex(s) * SizeOf(integer);
    end;

    function AlignedWideStringSize(s: integer): integer; {$ifdef fpc}inline;{$endif}
    const
      IdW = (SizeOf(integer) div SizeOf(WideChar));
    begin
      Result:=IdW * (1 + ((s - 1) div IdW));
    end;

  procedure SkipWideString; {$ifdef fpc}inline;{$endif}
  begin
    {$ifdef fpc}
    SkipUnaligned(4 * AlignedSize(CpsStream.ReadDword * SizeOf(WideChar)));
    {$else}
    SkipUnaligned(4 * AlignedSize(ReadInt() * SizeOf(WideChar)));
    {$endif}
  end;

  procedure SkipAnsiString; {$ifdef fpc}inline;{$endif}
  begin
    {$ifdef fpc}
    SkipUnaligned(CpsStream.ReadDword());
    {$else}
    SkipUnaligned(ReadInt);
    {$endif}
  end;

  procedure WriteAnsiString(v: AnsiString); {$ifdef fpc}inline;{$endif}
  begin
    {$ifdef fpc}
    CpsStream.WriteDword(Length(v));
    if Length(v) > 0
      then CpsStream.Write(v[1], Length(v))
    {$else}
    WriteInt(Length(v));
    if Length(v) > 0
      then CpsStream.WriteBuffer(v[1], Length(v))
    {$endif}
  end;

  procedure WriteWideString(v: WideString); {$ifdef fpc}inline;{$endif}
  begin
    {$ifdef fpc}
    CpsStream.WriteDword(Length(v));
    if Length(v) > 0 then
      CpsStream.Write(v[1], 4 * SizeToBufferIndex(Length(v) * SizeOf(WideChar)));
    {$else}
    WriteInt(Length(v));
    if Length(v) > 0 then
      CpsStream.WriteBuffer(v[1], 4 * SizeToBufferIndex(Length(v) * SizeOf(WideChar)));
    {$endif}
  end;

  function ReadWideString(): WideString; {$ifdef fpc}inline;{$endif}
  begin
    {$ifdef fpc}
    SetLength(Result, CpsStream.ReadDword());
    if Length(Result) > 0 then
      CpsStream.Read(Result[1], 4 * SizeToBufferIndex(Length(Result) * SizeOf(WideChar)));
    {$else}
    SetLength(Result, ReadInt());
    if Length(Result) > 0 then
      CpsStream.ReadBuffer(Result[1], 4 * SizeToBufferIndex(Length(Result) * SizeOf(WideChar)));
    {$endif}
  end;

  function ReadAnsiString(): AnsiString; {$ifdef fpc}inline;{$endif}
  begin
    {$ifdef fpc}
    SetLength(Result, CpsStream.ReadDWord);
    if length(Result) > 0 then ReadUnaligned(@Result[1], length(Result));
    {$else}
    SetLength(Result, ReadInt());
    if length(Result) > 0 then ReadUnaligned(@Result[1], length(Result));
    {$endif}
  end;

  procedure WriteNil; {$ifdef fpc}inline;{$endif}
  begin
    {$ifdef fpc}
    CpsStream.WriteDword(-1);
    {$else}
    WriteInt(-1);
    {$endif}
  end;

const
  FKName : array[TFieldKind] of WideString = (
   'неподдерживаемый','бинарный','целый','вещественный','строковой (utf-16)','множество',
   'перечислимый','класс','особый','строковой (ANSI)','неперзистентный класс','устаревш. статический массив',
   'перечислимый массив','запись', 'динамический массив', 'запись (упакованная)', 'статический массив',
   'ERRORпользовательский класс', 'метакласс');

  FKNameEnglish : array[TFieldKind] of string = (
   'unsupported','binary','integer','floating-point','string(utf-16)','set',
   'enumerated','class','custom','string(ANSI)','non-persistent class','obsolete static array',
   'enumerated array','record','dynamic array', 'packed record', 'static array',
   'ERRORcustom class', 'metaclass');

function FieldKindToStr(k: TFieldKind): WideString;
  begin
    Result:=RuEn(FKName[k], FKNameEnglish[k]);
  end;
const _ctt: array[0..23] of WideString = (
'нН','бБ','цЦ','вВ','сС','мМ','пП','кК','оО','уУ','зЗ','дД',
'uU','bB','iI','fF','sS','eE','cC','nN','oO','rR','dD','pP');
function FieldKindToCapStr(k: TFieldKind): WideString;
  var j: integer;
  begin
    Result:=RuEn(FKName[k], FKNameEnglish[k]);
    for j:=0 to High(_ctt) do
      if Result[1] = _ctt[j][1]
        then Result[1]:= _ctt[j][2];
  end;

  procedure WalkPersistent(o: TManagedObject); forward;

{$ifdef cge}
  {$include mo_fixedpoint.inc}
{$endif}

{$include mo_cps_dyna.inc}

{$include mo_cps_basket.inc}

{$include mo_cps_typeprocs.inc}

{$include mo_cps_convert.inc}

{$include mo_cps_registrator.inc}

{$include mo_cps_trulypersistent.inc}

{$include mo_cps_walker.inc}

{$include mo_cps_garbagecollector.inc}



{ TNameSpace }

function TNameSpace.Ind(i_s: string; AssumedInd: integer): integer;
var
  i: integer;
begin
  i_s:=UpperCase(i_s);
  Result:=-1;
  if (AssumedInd >=0) and (AssumedInd <= High) and (Self[AssumedInd] = i_s)
  then begin
    if Alias[AssumedInd] >= 0 then Result:=Alias[AssumedInd]
                              else Result:=AssumedInd;
  end
  else
    For i:=0 to High do
      if Self[i] = i_s then begin
        if Alias[i] >= 0 then Result:=Alias[i]
                         else Result:=i;
        Break;
      end;
end;

function TNameSpace.Translate(RegNS: TNameSpace): TAOI;
var
  o: TAOI;
  i: integer;
begin
  o:=TAOI.Create;
  o.Length:=Length;
  For i:=0 to High do begin
    o[i]:=RegNS.Ind(Self[i], i); //to speed up translation of identic name spaces
//if MotherState^.VerboseLog then AddLog('---NS tran: %0 %1 %2',[i, Self[i], o[i]]);
  end;
  Result:=o;
end;

function TNameSpace.Add(a_s: string): integer;
var
  i: integer;
begin
  a_s:=UpperCase(a_s);
  i:=Ind(a_s, -1);
  if i >=0 then Result:=Ind(a_s, -1)
  else begin
    Result:=inherited Add(a_s);
    SetLength(Alias, Self.Length);
    Alias[Result]:= -1;
  end;
end;

function TNameSpace.Add(s1, s2: string): integer;
var
  i: integer;
begin
  s2:=UpperCase(s2);
  i:=Ind(s1, -1);
  if i >=0 then Result:=Ind(s1, -1)
  else begin
    Add(s2);
    Result:=inherited Add(s1);
    SetLength(Alias, Self.Length);
    Alias[Result]:= Ind(s2, -1);
  end;
end;

//added in 0.8.2
  function ExportChepersyClassList(): TStringList; //class names per index
    var i: integer;
  begin
    Result:=TStringList.Create;
    For i:=0 to Records.High do
      if Types[Records[i]].Kind in [fk_Class]
        then Result.AddObject(TypeNameSpace[Records[i]], TObject(Types[Records[i]]._class));
  end;


  function CpsStore(o: TManagedObject; {$ifdef cge}m: TMessageId;{$endif} Target: TStream;
              XorMask: dword = $ffffffff; AndMask: dword = $ffffffff; Headerless: longbool = false): longbool;
  var
    ContName: string;
  begin
    {$ifdef cge}
      AddLog(MI_SAVING, [MsgRaw(m)]);
    {$endif}
    ValidateChepersyState('CpsStore()');
    Result:= false;
    CpsCriticalSection.Enter;
    {$ifndef cge}
    CpsError.Clear;
    {$endif}
    mXorMask:= XorMask;
    mAndMask:= AndMask;
    try
      try
        PrepareToSave(Target); //assigns CpsStream

        DH:= CpsDatabaseHeaders[0];
        if not Headerless then begin
          DH.WriteSignatureToStream;
          DH.WriteHeader;
        end;
    //     {$include un_bottleneck_start.inc}
         WritePersistent(o);
    //     {$include un_bottleneck_stop.inc}
         DoneSaving(No);
         Result:= true;
      except
        if Target is TFileStream
          then ContName:=(Target as TFileStream).FileName
          else Contname:=Target.ClassName;
        Try EmergencyCloseCgeFile Except End;
       {$ifdef cge}
        Die(MI_ERROR_SAVING, [MsgRaw(m), ContName]);
       {$else}
        try Die(MI_ERROR_SAVING, [ContName]); except end;
      {$endif}
      end;
    finally
      CpsCriticalSection.Leave;
    end;
    AddLogOk;
  end;


  function CpsLoad(
    {$ifdef cge}m: TMessageId;{$endif}
    Source: TStream;
    var OutputList: TArrayOfManagedObjects;
    DatabaseHeader: TChepersyDatabaseHeader = nil //if set, treats the stream as headerless!
  ): TManagedObject;
  var
//    t: integer;
    ContName: string;
  begin
   {$ifdef cge}
    AddLog(MI_LOADING, [MsgRaw(m)]);
   {$endif}
    ValidateChepersyState('CpsLoad()');
    Result:= nil;
    CpsCriticalSection.Enter;
    {$ifndef cge}
    CpsError.Clear;
    {$endif}
    try
      try
  //t:=tick();
         //{$include un_bottleneck_start.inc}
         PrepareToLoad(Source);

         if not Assigned(DatabaseHeader)
           then databaseHeader:= TChepersyDatabaseHeader.GetInstance() {
             loads/skips header from stream as needed
             Sets DH:= Self in the process!
         }
           else DH:= DatabaseHeader;

         ReadPersistent(Result);
  //       n:=NumObjects;
  //if VerboseLog then AddLog('Loading %0 objects from the file took %1 ms (%3 ns per object).'#10#13'FileFormat is %2',[n, Tick()-t, 'CGE' + VersionOfLoadedFile, int(1000000.0*((Tick()-t)/n))]);

         DoneLoading(No, OutputList);
//AddLog('CpsLoad(): high(OutputList) = %0', [high(OutputList)]);
        //{$include un_bottleneck_stop.inc}
      except
        if Source is TFileStream
          then ContName:=(Source as TFileStream).FileName
          else Contname:=Source.ClassName;
        Try EmergencyCloseCgeFile Except End;
        {$ifdef cge}
          Die(MI_ERROR_LOADING, [MsgRaw(m), ContName]);
        {$else}
          try Die(MI_ERROR_LOADING, [ContName]); except end;
          result:= nil;
        {$endif}
      end;
    finally
      CpsCriticalSection.Leave;
    end;
    AddLogOk;
  end;


