{
    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.

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

var
  Converter: array of array of TCustomConverterProc;
  
procedure ReadField(pfield: pointer; Tind: integer); inline;
begin
//addlog('  -- readfield %0 %1',[tind, B_namespace[TNames[tind]]]);
  if Assigned(Types[DH.B_ToGtind[Tind]].Proc)
    then Types[DH.B_ToGtind[Tind]].Proc(pfield, fio_Load, Tind)
    else CpsStream.Read(pfield^, Types[DH.B_ToGtind[Tind]].Size);
         //ReadBin(pfield, Types[Tind].Size div 4);
end;

  (* 0.8.2 --> 0.8.90, 7 July 2008
    The new strategy is to use *LOCAL* tinds when loading.
    So all converter procedures were updated accordingly.
  
  *)

  (*  0.8.1 --> 0.8.2,  15 Feb. 2008
       A fatal blunder detected.
         Who said the standard dynamic array
         memory manager allocates exactly the
         same amount of bytes as the array length?
         it could be rounded up to anything.

       My application started crashing with all the signs of
         trashed heap after I tried to used chepersy
         in combination with array of byte.
         
   P.S. Just as I thought, the dynamic arrays
     use *different* allocator than the GetMem() procedure. Go tell.


Procedure NewDynArray(parray: pointer; Len, BaseTypeInd: integer);
var
  p: pointer;
begin
  if Len = 0 then pointer(parray^):=nil
  else begin
    GetMem(p, 8 + Len * Types[BaseTypeInd].Size);
    dword(parray^):=dword(p) + 8;
    dword(p^):=1; //reference count
    dword(pointer(cardinal(p) + 4)^)
      :=Len {$ifdef fpc} - 1{$endif}; //high value in FreePascal, length  in Delphi
  end;
end;

*)

//type TArrayOfByte = array of byte;
Procedure NewDynArray(parray: pointer; Len, BaseTypeInd: integer);
var
  p: pointer;
begin
  pointer(parray^):= nil;
  SetLength(TArrayOfByte(parray^), Len * Types[BaseTypeInd].Size);
  if Len > 0 then  //high value in FreePascal, length  in Delphi
  {$ifdef fpc}
    dword((pointer(parray^) - 4)^):= Len - 1;
  {$else}
    dword(pointer(cardinal(parray^) - 4)^):= Len;
  {$endif}
end;



procedure CP_AnyDynamicArray (PField: pointer; Tind1, Tind2: integer); register; forward;
procedure CP_AnyClass (PField: pointer; Tind1, Tind2: integer); register; forward;

function GetConverterProc(Tind1, Tind2: integer): TCustomConverterProc;
begin
  if (Tind1 <= high(Converter)) and (Tind2 <= high (Converter[Tind1]))
    then Result:= Converter[Tind1][Tind2]
    else Result:=nil;

  if not assigned(Result) then begin
    if   (Types[Tind1].Kind = fk_dynamic_array)
      and (Types[Tind2].Kind = fk_dynamic_array)
      and (Types[Tind1].DynArrayLevel = Types[Tind2].DynArrayLevel)
      and Assigned(GetConverterProc(Types[Tind1].DynArrayBaseInd, Types[Tind2].DynArrayBaseInd))
    then Result:=@CP_AnyDynamicArray;

    if (Types[Tind1].Kind = fk_Class) and (Types[Tind2].Kind = fk_Class)
    then Result:=@CP_AnyClass;
  end;
end;

procedure SetConverterProc(Tind1, Tind2: integer; p: TCustomConverterProc);
var i, j: integer;
begin
  if Tind1 > high(Converter) then SetLength(Converter, Tind1 + 1);
  i:= high(Converter[Tind1]);
  if Tind2 > i then begin
    SetLength(Converter[Tind1], Tind2 + 1);
    For j:= i + 1 to Tind2 -1 do Converter[Tind1][j]:=nil;
  end;
  Converter[Tind1][Tind2]:=p;
end;

Procedure RegTypeConverter(types1, types2: array of const; p: TCustomConverterProc);
var
  type1, type2: PTypeInfo;
  Tind1, Tind2, i, j: integer;
  list1, list2: string;
begin
  list1:='';
  For i:=0 to high(types1) do begin
    if types1[i].vtype <> vtPointer then Die(MI_ERROR_PROGRAMMER_NO_BAKA,
      [RuEn('','The entry ') + inttostr(i) + RuEn(
        '-й элемент первого параметра, переданного в RegTypeConverter() - не PTypeInfo!'
       ,' in the first parameter passed to RegTypeConverter() is not a PTypeInfo!')]);
    if list1 <> '' then list1:=list1 + ',';
    list1:=list1 + PTypeInfo(types1[i].vpointer)^.Name;
  end;
  list2:='';
  For i:=0 to high(types2) do begin
    if types2[i].vtype <> vtPointer then Die(MI_ERROR_PROGRAMMER_NO_BAKA,
      [RuEn('','The entry ') + inttostr(i) + RuEn(
        '-й элемент второго параметра, переданного в RegTypeConverter() - не PTypeInfo!'
       ,' in the second parameter passed to RegTypeConverter() is not a PTypeInfo!')]);
    if list2 <> '' then list2:=list2 + ',';
    list2:=list2 + PTypeInfo(types2[i].vpointer)^.Name;
  end;
  if MotherState^.VerboseLog then AddLog(RuEn(
     '  Конвертер типов'
    ,'  Type converter') +' %0 -> %1: %2', [UpperCase(list1), UpperCase(list2), @p]);

  For i:=0 to high(types1) do begin
    type1:=types1[i].vpointer;
    Tind1:=TypeNameSpace.Ind(type1^.Name, 0);
    if Tind1 < 0 then Die(MI_ERROR_PROGRAMMER_NO_BAKA,
       [RuEn('Неизвестный тип "','Unknown type "')
        + UpperCase(type1^.Name)
        + RuEn('", отсутствует в реестре!', '", not present in the registry!')]);
    For j:=0 to high(types2) do begin
      type2:=types2[j].vpointer;
      Tind2:=TypeNameSpace.Ind(type2^.Name, 0);
      if Tind2 < 0 then Die(MI_ERROR_PROGRAMMER_NO_BAKA,
       [RuEn('Неизвестный тип "','Unknown type "')
         + UpperCase(type2^.Name)
         + RuEn('", отсутствует в реестре!', '", not present in the registry!')]);
      if (Types[Tind1].Kind = fk_dynamic_array)
        and (Types[Tind2].Kind = fk_dynamic_array)
        and (Types[Tind1].DynArrayLevel = Types[Tind2].DynArrayLevel)
        then Die(MI_ERROR_PROGRAMMER_NO_BAKA, [RuEn(
          'Нет нужды писать конвертеры для динамических массивов одинаковой мерности, ибо таковые конвертируются автоматически!'
         ,'There is no need to write converters for the dynamic array types with the same number of dimensions, the conversion is performed automatically!')]);
      SetConverterProc(Tind1, Tind2, p);
    end;
  end;
end;

procedure ConvertSingleDimArray(parray: pointer; Tind1, Tind2: integer);
var
  l, s, i, t1, t2: integer;
  p: TCustomConverterProc;
begin
  t2:= Types[Tind2].BaseTypeInd;
  l:=ReadInt();
  NewDynArray(parray, l, t2);
  if l = 0 then Exit; //nothing more to do
  s:=Types[t2].size;
  t1:= DH.B_TBaseInds[Tind1];
  p:=GetConverterProc(DH.B_ToGtind[t1], t2);
  For i:=0 to l - 1 do
    p(pointer(cardinal(parray^) + i*s), t1, t2);
end;

procedure ConvMultiDimArray(a: PArrayOfPointer; Tind1, Tind2: integer);
var
  s, i, t1, t2: integer;
begin
  t1:= DH.B_TBaseInds[Tind1];
  t2:= Types[Tind2].BaseTypeInd;
{addlog('  convmultidimarray %0 %1 | %2 %3', [B_NameSpace[TNames[tind1]], B_NameSpace[TNames[t1]],
TypeNameSpace[tind2], TypeNameSpace[t2]]);
}
  if TFieldKind(DH.TKinds[t1]) <> fk_dynamic_array then ConvertSingleDimArray(a, Tind1, Tind2)//[Tind1]].DynArrayLevel = 1
  else begin
    s:=ReadInt();
//addlog('    %0', [s]);

    SetLength(a^, s);
    For i:=0 to s - 1 do
      ConvMultiDimArray(@a^[i], t1, t2);
  end;
end;

procedure CP_AnyDynamicArray (PField: pointer; Tind1, Tind2: integer); register;
begin
  ConvMultiDimArray(pfield, Tind1, Tind2);
end;

procedure CP_AnyClass (PField: pointer; Tind1, Tind2: integer); register;
begin
  //stub!  ----------------------------------------------------------------------------------------------------------------------------
  Types[DH.B_ToGtind[Tind1]].Proc(pfield, fio_Load, Tind1);
end;

procedure CP_IntToInt (PField: pointer; Tind1, Tind2: integer); register;
var
  i1: shortint;
  i2: smallint;
  i4: longint;
  i8: Int64;
begin
  case Types[DH.B_ToGtind[Tind1]].size of
    1: begin
       ReadField(@i1, Tind1);
       i8:=i1;
     end;
    2: begin
       ReadField(@i2, Tind1);
       i8:=i2;
     end;
    4: begin
       ReadField(@i4, Tind1);
       i8:=i4;
     end;
    8: ReadField(@i8, Tind1);
  end;
  Move(i8, PField^, Types[Tind2].Size);
end;

procedure CP_UIntToInt (PField: pointer; Tind1, Tind2: integer); register;
var
  i1: byte;
  i2: word;
  i4: dword;
 {$ifdef fpc}
  i8: qword;
 {$else}
  i8: int64;
 {$endif}
begin
  case Types[DH.B_ToGtind[Tind1]].size of
    1: begin
       ReadField(@i1, Tind1);
       i8:=i1;
     end;
    2: begin
       ReadField(@i2, Tind1);
       i8:=i2;
     end;
    4: begin
       ReadField(@i4, Tind1);
       i8:=i4;
     end;
   {$ifdef fpc}
    8: ReadField(@i8, Tind1);
   {$endif}
  end;
  Move(i8, PField^, Types[Tind2].Size);
end;


procedure CP_SingleToInt (PField: pointer; Tind1, Tind2: integer); register;
var
  s: Single;
  tb: Int64;
begin
  ReadField(@s, Tind1);
  tb:=round(s);
//addlog(' cp_singletoint %0', [s]);
  Move(tb, PField^, Types[Tind2].Size);
end;

procedure CP_DoubleToInt (PField: pointer; Tind1, Tind2: integer); register;
var
  d: Double;
  tb: Int64;
begin
  ReadField(@d, Tind1);
  tb:=round(d);
  Move(tb, PField^, Types[Tind2].Size);
end;

procedure CP_ExtendedToInt (PField: pointer; Tind1, Tind2: integer); register;
var
  e: Extended;
  tb: Int64;
begin
  ReadField(@e, Tind1);
  tb:=round(e);
  Move(tb, PField^, Types[Tind2].Size);
end;


procedure CP_IntToSingle (PField: pointer; Tind1, Tind2: integer); register;
var
  i1: shortint;
  i2: smallint;
  i4: longint;
  i8: Int64;
begin
  case Types[DH.B_ToGtind[Tind1]].size of
    1: begin
      ReadField(@i1, Tind1);
      single(pfield^):=i1;
    end;
    2: begin
      ReadField(@i2, Tind1);
      single(pfield^):=i2;
    end;
    4: begin
      ReadField(@i4, Tind1);
      single(pfield^):=i4;
    end;
    8: begin
      ReadField(@i8, Tind1);
      single(pfield^):=i8;
    end;
  end;
end;

procedure CP_UIntToSingle (PField: pointer; Tind1, Tind2: integer); register;
var
  i1: byte;
  i2: word;
  i4: dword;
 {$ifdef fpc}
  i8: qword;
 {$endif}
begin
  case Types[DH.B_ToGtind[Tind1]].size of
    1: begin
      ReadField(@i1, Tind1);
      single(pfield^):=i1;
    end;
    2: begin
      ReadField(@i2, Tind1);
      single(pfield^):=i2;
    end;
    4: begin
      ReadField(@i4, Tind1);
      single(pfield^):=i4;
    end;
   {$ifdef fpc}
    8: begin
      ReadField(@i8, Tind1);
      single(pfield^):=i8;
    end;
   {$endif}
  end;
end;

procedure CP_IntToDouble (PField: pointer; Tind1, Tind2: integer); register;
var
  i1: shortint;
  i2: smallint;
  i4: longint;
  i8: Int64;
begin
  case Types[DH.B_ToGtind[Tind1]].size of
    1: begin
      ReadField(@i1, Tind1);
      Double(pfield^):=i1;
    end;
    2: begin
      ReadField(@i2, Tind1);
      Double(pfield^):=i2;
    end;
    4: begin
      ReadField(@i4, Tind1);
      Double(pfield^):=i4;
    end;
    8: begin
      ReadField(@i8, Tind1);
      Double(pfield^):=i8;
    end;
  end;
end;

procedure CP_UIntToDouble (PField: pointer; Tind1, Tind2: integer); register;
var
  i1: byte;
  i2: word;
  i4: dword;
 {$ifdef fpc}
  i8: qword;
 {$endif}
begin
  case Types[DH.B_ToGtind[Tind1]].size of
    1: begin
      ReadField(@i1, Tind1);
      Double(pfield^):=i1;
    end;
    2: begin
      ReadField(@i2, Tind1);
      Double(pfield^):=i2;
    end;
    4: begin
      ReadField(@i4, Tind1);
      Double(pfield^):=i4;
    end;
   {$ifdef fpc}
    8: begin
      ReadField(@i8, Tind1);
      Double(pfield^):=i8;
    end;
   {$endif}
  end;
end;

procedure CP_IntToExtended (PField: pointer; Tind1, Tind2: integer); register;
var
  i1: shortint;
  i2: smallint;
  i4: longint;
  i8: Int64;
begin
  case Types[DH.B_ToGtind[Tind1]].size of
    1: begin
      ReadField(@i1, Tind1);
      Extended(pfield^):=i1;
    end;
    2: begin
      ReadField(@i2, Tind1);
      Extended(pfield^):=i2;
    end;
    4: begin
      ReadField(@i4, Tind1);
      Extended(pfield^):=i4;
    end;
    8: begin
      ReadField(@i8, Tind1);
      Extended(pfield^):=i8;
    end;
  end;
end;

procedure CP_UIntToExtended (PField: pointer; Tind1, Tind2: integer); register;
var
  i1: byte;
  i2: word;
  i4: dword;
 {$ifdef fpc}
  i8: qword;
 {$endif}
begin
  case Types[DH.B_ToGtind[Tind1]].size of
    1: begin
      ReadField(@i1, Tind1);
      Extended(pfield^):=i1;
    end;
    2: begin
      ReadField(@i2, Tind1);
      Extended(pfield^):=i2;
    end;
    4: begin
      ReadField(@i4, Tind1);
      Extended(pfield^):=i4;
    end;
   {$ifdef fpc}
    8: begin
      ReadField(@i8, Tind1);
      Extended(pfield^):=i8;
    end;
   {$endif}
  end;
end;

procedure CP_DoubleToSingle (PField: pointer; Tind1, Tind2: integer); register;
var
  v: Double;
begin
  ReadField(@v, Tind1);
  single(PField^):=v;
end;

procedure CP_DoubleToExtended (PField: pointer; Tind1, Tind2: integer); register;
var
  v: Double;
begin
  ReadField(@v, Tind1);
  extended(PField^):=v;
end;

procedure CP_SingleToExtended (PField: pointer; Tind1, Tind2: integer); register;
var
  v: Single;
begin
  ReadField(@v, Tind1);
  extended(PField^):=v;
end;

procedure CP_SingleToDouble (PField: pointer; Tind1, Tind2: integer); register;
var
  v: Single;
begin
  ReadField(@v, Tind1);
  double(PField^):=v;
end;

procedure CP_ExtendedToDouble (PField: pointer; Tind1, Tind2: integer); register;
var
  v: Extended;
begin
  ReadField(@v, Tind1);
  double(PField^):=v;
end;

procedure CP_ExtendedToSingle (PField: pointer; Tind1, Tind2: integer); register;
var
  v: Extended;
begin
  ReadField(@v, Tind1);
  single(PField^):=v;
end;

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


procedure RegisterBuiltInConverters;
begin
  RegTypeConverter(
    [typeinfo(shortint), typeinfo(smallint), typeinfo(longint), typeinfo(int64)],
    [typeinfo(byte), typeinfo(shortint), typeinfo(smallint),  typeinfo(word),
     typeinfo(longint), typeinfo(dword), typeinfo(int64) {$ifdef fpc}, typeinfo(qword) {$endif}],
    @CP_IntToInt
  );
  
  RegTypeConverter(
    [typeinfo(byte), typeinfo(word), typeinfo(dword) {$ifdef fpc}, typeinfo(qword) {$endif}],
    [typeinfo(byte), typeinfo(shortint), typeinfo(smallint),  typeinfo(word),
     typeinfo(longint), typeinfo(dword), typeinfo(int64) {$ifdef fpc}, typeinfo(qword) {$endif}],
    @CP_UintToInt
  );


  RegTypeConverter(
    [typeinfo(single)],
    [typeinfo(byte), typeinfo(shortint), typeinfo(smallint),  typeinfo(word),
     typeinfo(longint), typeinfo(dword), typeinfo(int64) {$ifdef fpc}, typeinfo(qword) {$endif}],
    @CP_SingleToInt
  );
    
  RegTypeConverter(
    [typeinfo(shortint), typeinfo(smallint), typeinfo(longint), typeinfo(int64)],
    [typeinfo(single)],
    @CP_IntToSingle
  );
  
  RegTypeConverter(
    [typeinfo(byte), typeinfo(word), typeinfo(dword) {$ifdef fpc}, typeinfo(qword) {$endif}],
    [typeinfo(single)],
    @CP_UIntToSingle
  );

  RegTypeConverter(
    [typeinfo(double)],
    [typeinfo(byte), typeinfo(shortint), typeinfo(smallint),  typeinfo(word),
     typeinfo(longint), typeinfo(dword), typeinfo(int64) {$ifdef fpc}, typeinfo(qword) {$endif}],
    @CP_DoubleToInt
  );
  
  RegTypeConverter(
    [typeinfo(shortint), typeinfo(smallint), typeinfo(longint), typeinfo(int64)],
    [typeinfo(double)],
    @CP_IntToDouble
  );

  RegTypeConverter(
    [typeinfo(byte), typeinfo(word), typeinfo(dword) {$ifdef fpc}, typeinfo(qword) {$endif}],
    [typeinfo(double)],
    @CP_UIntToDouble
  );

  RegTypeConverter(
    [typeinfo(extended)],
    [typeinfo(byte), typeinfo(shortint), typeinfo(smallint),  typeinfo(word),
     typeinfo(longint), typeinfo(dword), typeinfo(int64) {$ifdef fpc}, typeinfo(qword) {$endif}],
    @CP_ExtendedToInt
  );

  RegTypeConverter(
    [typeinfo(shortint), typeinfo(smallint), typeinfo(longint), typeinfo(int64)],
    [typeinfo(extended)],
    @CP_IntToExtended
  );

  RegTypeConverter(
    [typeinfo(byte), typeinfo(word), typeinfo(dword) {$ifdef fpc}, typeinfo(qword) {$endif}],
    [typeinfo(extended)],
    @CP_UIntToExtended
  );
  
  RegTypeConverter([typeinfo(single)], [typeinfo(double)], @CP_SingleToDouble);
  RegTypeConverter([typeinfo(single)], [typeinfo(extended)], @CP_SingleToExtended);
  RegTypeConverter([typeinfo(double)], [typeinfo(single)], @CP_DoubleToSingle);
  RegTypeConverter([typeinfo(double)], [typeinfo(extended)], @CP_DoubleToExtended);
  RegTypeConverter([typeinfo(extended)], [typeinfo(single)], @CP_ExtendedToSingle);
  RegTypeConverter([typeinfo(extended)], [typeinfo(double)], @CP_ExtendedToDouble);

  {$ifdef cge}
    RegTypeConverter([typeinfo(single)],[typeinfo(fixed32)], @CP_SingleToFixed32);
    RegTypeConverter([typeinfo(double)],[typeinfo(fixed32)], @CP_DoubleToFixed32);
    RegTypeConverter([typeinfo(fixed32)],[typeinfo(single)], @CP_Fixed32ToSingle);
    RegTypeConverter([typeinfo(fixed32)],[typeinfo(double)], @CP_Fixed32ToDouble);
    RegTypeConverter([typeinfo(fixed32)],[typeinfo(shortint), typeinfo(smallint), typeinfo(longint), typeinfo(int64)], @CP_Fixed32ToInt);
    RegTypeConverter([typeinfo(fixed32)],[typeinfo(byte), typeinfo(word), typeinfo(dword), typeinfo(qword) ], @CP_Fixed32ToUInt);
    RegTypeConverter([typeinfo(shortint), typeinfo(smallint), typeinfo(longint), typeinfo(int64)],[typeinfo(fixed32)], @CP_IntToFixed32);
    RegTypeConverter([typeinfo(byte), typeinfo(word), typeinfo(dword), typeinfo(qword)],[typeinfo(fixed32)], @CP_UIntToFixed32);
  {$endif}
end;

procedure DieCIncompat(sru, sen: WideString);
begin
  Die(MI_ERROR_PROGRAMMER_NO_BAKA, [
    RuEn(
      'К сожалению, Chepersy несовместима с используемой вами версией '
     ,'Sorry, but Chepersy is not compatible with the current version of ') +
   {$ifdef fpc}
    'Free Pascal'
   {$else}
    'Delphi'
   {$endif}
  + RuEn(
     ', поскольку базируется на нескольких предположениях о том, как компилятор располагает данные в памяти. (Не совпадает ' + sru + ')'
    ,' you use, because it relies on some assumptions on how the compiler arranges the data structures in memory. (' + sen +' mismatch)')]);
end;


Type
  ZRecord = record
    zza: byte;
  end;
  ZSEnum = 0..1;
  ZBEnum = 0..32;
  ZSSet = set of ZSEnum;
  ZBSet = set of ZBEnum;

procedure CheckCompilerCompatibility;
var a: array of word;
begin
  if SizeOf(ZRecord) <> {$ifdef fpc}1{$else}1{$endif} then DieCIncompat('размер записей','record size');
  if SizeOf(ZSSet) <> {$ifdef fpc}4{$else}1{$endif} then DieCIncompat('размер малых множеств','small set size');
  if SizeOf(ZBSet) <> {$ifdef fpc}32{$else}5{$endif} then DieCIncompat('размер больших множеств','big set size');
  SetLength(a, 7);
  if dword(pointer(cardinal(a) - 4)^) <> {$ifdef fpc}6{$else}7{$endif} then DieCIncompat('размер дин. массивов в -4', 'dynamic array length at -4');
  if dword(pointer(cardinal(a) - 8)^) <> 1 then DieCIncompat('счётчик ссылок дин. массивов в -8', 'dynamic array reference count at -8');
end;


