fpc/rtl/inc/objpas.inc

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

    This unit makes Free Pascal as much as possible Delphi compatible

    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.

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

{$ifdef FPC_HAS_FEATURE_VARIANTS}
    procedure DoDispCallByIDError(res : Pointer; const disp : IDispatch;desc : PDispDesc; params : Pointer);
      begin
        handleerroraddrframeind(RuntimeErrorExitCodes[reVarDispatch],
          get_pc_addr,get_frame);
      end;


    procedure fpc_dispatch_by_id(Result: Pointer; const Dispatch: pointer;
      DispDesc: Pointer; Params: Pointer); compilerproc;
      type
        TDispProc = procedure(res : Pointer; const disp : IDispatch;desc : PDispDesc; params : Pointer);
      begin
        TDispProc(DispCallByIDProc)(Result,IDispatch(Dispatch),DispDesc,Params);
      end;
{$endif FPC_HAS_FEATURE_VARIANTS}


{****************************************************************************
                  Internal Routines called from the Compiler
****************************************************************************}

    { the reverse order of the parameters make code generation easier }
    function fpc_do_is(aclass : tclass;aobject : tobject) : boolean;[public,alias: 'FPC_DO_IS']; compilerproc;
      begin
         fpc_do_is:=assigned(aobject) and assigned(aclass) and
           aobject.inheritsfrom(aclass);
      end;


    { the reverse order of the parameters make code generation easier }
    function fpc_do_as(aclass : tclass;aobject : tobject): tobject;[public,alias: 'FPC_DO_AS']; compilerproc;
      begin
         if assigned(aobject) and not(aobject.inheritsfrom(aclass)) then
           handleerroraddrframeInd(219,get_pc_addr,get_frame);
         result := aobject;
      end;

    { interface helpers }
    procedure fpc_intf_decr_ref(var i: pointer);[public,alias: 'FPC_INTF_DECR_REF']; compilerproc;
      var
        iFetch: pointer;
      begin
        iFetch:=i;
        if assigned(iFetch) then
          begin
            i:=nil;
            IUnknown(iFetch)._Release;
          end;
      end;

    { local declaration for intf_decr_ref for local access }
    procedure intf_decr_ref(var i: pointer); [external name 'FPC_INTF_DECR_REF'];


    procedure fpc_intf_incr_ref(i: pointer);[public,alias: 'FPC_INTF_INCR_REF']; compilerproc;
      begin
         if assigned(i) then
           IUnknown(i)._AddRef;
      end;

    { local declaration of intf_incr_ref for local access }
    procedure intf_incr_ref(i: pointer); [external name 'FPC_INTF_INCR_REF'];

    procedure fpc_intf_assign(var D: pointer; const S: pointer);[public,alias: 'FPC_INTF_ASSIGN']; compilerproc;
      begin
         if assigned(S) then
           IUnknown(S)._AddRef;
         if assigned(D) then
           IUnknown(D)._Release;
         D:=S;
      end;

    procedure fpc_intf_assign(var D: pointer; const s: pointer); [external name 'FPC_INTF_ASSIGN'];

    {procedure fpc_intf_assign_by_iid(var D: pointer; const S: pointer; const iid: TGUID);[public,alias: 'FPC_INTF_ASSIGN2']; compilerproc;
      var
        tmp : pointer;
      begin
         if assigned(S) then
           begin
             tmp:=nil;
             if IUnknown(S).QueryInterface(iid,tmp)<>S_OK then
               handleerror(219);
             if assigned(D) then
               IUnknown(D)._Release;
             D:=tmp;
           end
         else
           begin
             if assigned(D) then
               IUnknown(D)._Release;
             D:=nil;
           end;
      end;}


    function fpc_intf_is(const S: pointer; const iid: TGUID): Boolean;[public,alias: 'FPC_INTF_IS']; compilerproc;
      var
        tmpi: pointer;
      begin
        tmpi:=nil;
        fpc_intf_is:=Assigned(S) and (IUnknown(S).QueryInterface(iid,tmpi)=S_OK);
        if Assigned(tmpi) then
          IUnknown(tmpi)._Release;
      end;


    function fpc_intf_is_class(const S: pointer; const aclass: tclass): Boolean;[public,alias: 'FPC_INTF_IS_CLASS']; compilerproc;
      var
        tmpo: tobject;
      begin
        fpc_intf_is_class:=Assigned(S) and (IUnknown(S).QueryInterface(IObjectInstance,tmpo)=S_OK)  and tmpo.InheritsFrom(aclass);
      end;


    function fpc_class_is_intf(const S: pointer; const iid: TGUID): Boolean;[public,alias: 'FPC_CLASS_IS_INTF']; compilerproc;
      var
        tmpi: pointer;
        tmpi2: pointer; // weak!
      begin
        tmpi:=nil;
        tmpi2:=nil;
        fpc_class_is_intf:=Assigned(S) and ((TObject(S).GetInterfaceWeak(IUnknown,tmpi2) and (IUnknown(tmpi2).QueryInterface(IID,tmpi)=S_OK)) or
            TObject(S).GetInterface(IID,tmpi));
        if Assigned(tmpi) then
          IUnknown(tmpi)._Release;
      end;


    function fpc_class_is_corbaintf(const S: pointer; const iid: Shortstring): Boolean;[public,alias: 'FPC_CLASS_IS_CORBAINTF']; compilerproc;
      begin
        fpc_class_is_corbaintf:=Assigned(S) and Assigned(TObject(S).GetInterfaceEntryByStr(iid));
      end;


    function fpc_intf_cast(const S: pointer; const iid: TGUID): IInterface;[public,alias: 'FPC_INTF_CAST']; compilerproc;
      var
        tmpi: pointer;
      begin
        tmpi:=nil;
        if Assigned(S) and (IUnknown(S).QueryInterface(iid,tmpi)=S_OK) then
          pointer(fpc_intf_cast):=tmpi
        else
          fpc_intf_cast:= nil;
      end;


    function fpc_intf_cast_class(const S: pointer; const aclass: tclass): pointer;[public,alias: 'FPC_INTF_CAST_CLASS']; compilerproc;
      var
        tmpo: tobject;
      begin
        if Assigned(S) and (IUnknown(S).QueryInterface(IObjectInstance,tmpo)=S_OK) and tmpo.InheritsFrom(aclass) then
          fpc_intf_cast_class:=tmpo
        else
          fpc_intf_cast_class:=nil;
      end;


    function fpc_class_cast_intf(const S: pointer; const iid: TGUID): IInterface;[public,alias: 'FPC_CLASS_CAST_INTF']; compilerproc;
      var
        tmpi: pointer;
        tmpi2: pointer; // weak!
      begin
        tmpi:=nil;
        tmpi2:=nil;
        if Assigned(S) and ((TObject(S).GetInterfaceWeak(IUnknown,tmpi2) and (IUnknown(tmpi2).QueryInterface(IID,tmpi)=S_OK)) or
            TObject(S).GetInterface(IID,tmpi)) then
          begin
            // decrease reference count
            fpc_class_cast_intf:=nil;
            pointer(fpc_class_cast_intf):=tmpi
          end
        else
          fpc_class_cast_intf:=nil;
      end;


    function fpc_class_cast_corbaintf(const S: pointer; const iid: Shortstring): Pointer;[public,alias: 'FPC_CLASS_CAST_CORBAINTF']; compilerproc;
      var
        tmpi: pointer;
      begin
        if Assigned(S) and TObject(S).GetInterface(iid,tmpi) then
          fpc_class_cast_corbaintf:=tmpi
        else
          fpc_class_cast_corbaintf:=nil;
      end;


    function fpc_intf_as(const S: pointer; const iid: TGUID): IInterface;[public,alias: 'FPC_INTF_AS']; compilerproc;
      var
        tmpi: pointer; // _AddRef before _Release
      begin
        if assigned(S) then
          begin
             tmpi:=nil;
             if IUnknown(S).QueryInterface(iid,tmpi)<>S_OK then
               handleerror(219);
             // decrease reference count
             fpc_intf_as:=nil;
             pointer(fpc_intf_as):=tmpi;
          end
        else
          fpc_intf_as:=nil;
      end;


    function fpc_intf_as_class(const S: pointer; const aclass: tclass): pointer;[public,alias: 'FPC_INTF_AS_CLASS']; compilerproc;
      var
        tmpo: tobject;
      begin
        if assigned(S) then
          begin
            if not ((IUnknown(S).QueryInterface(IObjectInstance,tmpo)=S_OK) and tmpo.inheritsfrom(aclass)) then
              handleerror(219);
            fpc_intf_as_class:=tmpo;
          end
        else
          fpc_intf_as_class:=nil;
      end;


    function fpc_class_as_intf(const S: pointer; const iid: TGUID): IInterface;[public,alias: 'FPC_CLASS_AS_INTF']; compilerproc;
      var
        tmpi: pointer; // _AddRef before _Release
        tmpi2: pointer; // weak!
      begin
        if assigned(S) then
          begin
             tmpi:=nil;
             tmpi2:=nil;
             if not ((TObject(S).GetInterfaceWeak(IUnknown,tmpi2) and (IUnknown(tmpi2).QueryInterface(IID,tmpi)=S_OK)) or TObject(S).GetInterface(IID,tmpi)) then
               handleerror(219);
             // decrease reference count
             fpc_class_as_intf:=nil;
             pointer(fpc_class_as_intf):=tmpi;
          end
        else
          fpc_class_as_intf:=nil;
      end;


    function fpc_class_as_corbaintf(const S: pointer; const iid: Shortstring): Pointer;[public,alias: 'FPC_CLASS_AS_CORBAINTF']; compilerproc;
      var
        tmpi: pointer; // _AddRef before _Release
      begin
        if assigned(S) then
          begin
             tmpi:=nil;
             if not TObject(S).GetInterface(iid,tmpi) then
               handleerror(219);
             fpc_class_as_corbaintf:=tmpi;
          end
        else
          fpc_class_as_corbaintf:=nil;
      end;

{****************************************************************************
                               TVMT
****************************************************************************}


    function TVmt.GetvParent: PVmt;
      begin
        if Assigned(vParentRef) then
          GetvParent:=vParentRef^
        else
          GetvParent:=Nil;
      end;


{****************************************************************************
                           TGUID
 ****************************************************************************}

class operator TGUID.=(const aLeft, aRight: TGUID): Boolean;

var
  P1,P2 : ^Cardinal;

begin
  P1:=PCardinal(@aLeft);
  P2:=PCardinal(@aRight);
  Result:=(P1[0]=P2[0]) and (P1[1]=P2[1]) and (P1[2]=P2[2]) and (P1[3]=P2[3]);
end;

class operator TGUID.<>(const aLeft, aRight: TGUID): Boolean;

begin
  Result:=Not (aLeft=aRight);
end;

class function TGUID.Empty: TGUID; static;

begin
  Result:=Default(TGUID);
end;


class function TGUID.Create(const aData; aBigEndian: Boolean = False): TGUID; overload; static;

begin
  Result:=Create(PByte(@aData),aBigEndian);
end;

class function TGUID.Create(const aData : PByte; aBigEndian: Boolean = False): TGUID; overload; static;

const
  SysBigendian = {$IFDEF FPC_LITTLE_ENDIAN} false {$ELSE} true {$ENDIF};

begin
  Result := PGuid(aData)^;
  if (aBigEndian=SysBigEndian) then
    exit;
  Result.D1:=SwapEndian(Result.D1);
  Result.D2:=SwapEndian(Result.D2);
  Result.D3:=SwapEndian(Result.D3);
end;


class function TGUID.Create(const aData: array of Byte; aStartIndex: Cardinal; aBigEndian: Boolean = False): TGUID; overload; static;

begin
  if ((Length(aData)-aStartIndex)<16) then
    Result:=Empty
  else
    Result:=Create(PByte(@aData[aStartIndex]),aBigEndian);
end;


function TGUID.IsEmpty: Boolean;

var
  P : ^Cardinal;

begin
  P:=PCardinal(@Self);
  Result:=(P[0]=0) and (P[1]=0) and (P[2]=0) and (P[3]=0)
end;



{****************************************************************************
                           TINTERFACEENTRY
****************************************************************************}


    function tinterfaceentry.GetIID: pguid;
      begin
        if Assigned(IIDRef) then
          GetIID:=IIDRef^
        else
          GetIID:=Nil;
      end;


    function tinterfaceentry.GetIIDStr: pshortstring;
      begin
        if Assigned(IIDStrRef) then
          GetIIDStr:=IIDStrRef^
        else
          GetIIDStr:=Nil;
      end;


{****************************************************************************
                               TOBJECT
****************************************************************************}

      constructor TObject.Create;
        begin
        end;

      destructor TObject.Destroy;
        begin
        end;

      procedure TObject.Free;

        begin
           // the call via self avoids a warning
           if self<>nil then
             self.destroy;
        end;

      class function TObject.InstanceSize : SizeInt;

        begin
           InstanceSize := PVmt(Self)^.vInstanceSize;
        end;

      procedure InitInterfacePointers(objclass: tclass;instance : pointer);

        var
          ovmt: PVmt;
          i: longint;
          intftable: pinterfacetable;
          Res: pinterfaceentry;
        begin
          ovmt := PVmt(objclass);
          while assigned(ovmt) and assigned(ovmt^.vIntfTable) do
            begin
              intftable:=ovmt^.vIntfTable;
              i:=intftable^.EntryCount;
              Res:=@intftable^.Entries[0];
              while i>0 do begin
                if Res^.IType = etStandard then
                  ppointer(@(pbyte(instance)[Res^.IOffset]))^:=
                    pointer(Res^.VTable);
                inc(Res);
                dec(i);
              end;
              ovmt:=ovmt^.vParent;
            end;
        end;

      class function TObject.InitInstance(instance : pointer) : tobject;

        var
           vmt  : PVmt;
           inittable : pointer;
{$ifdef FPC_HAS_FEATURE_RTTI}
           mopinittable : PRTTIRecordOpOffsetTable;
{$endif def FPC_HAS_FEATURE_RTTI}
           i : longint;
        begin
           I:=instancesize;
           { the size is saved at offset 0 }
           fillchar(instance^, InstanceSize, 0);
           { insert VMT pointer into the new created memory area }
           { (in class methods self contains the VMT!)           }
           {$IFNDEF SYSTEM_HAS_FEATURE_MONITOR}
             ppointer(instance)^:=pointer(self);
           {$ELSE}
             {$IFDEF VER3_2}
             // In 3.2.x Compiler (used during bootstrap) still inserts VMT at offset...
             ppointer(PByte(instance)+SizeOf(Pointer))^:=pointer(self);
             {$ELSE}
             // As of 3.3.x compiler forces insert of VMT at first pos.
             ppointer(instance)^:=pointer(self);
             {$ENDIF}
          {$ENDIF}

           if assigned(PVmt(self)^.vIntfTable) then
             InitInterfacePointers(self,instance);

{$ifdef FPC_HAS_FEATURE_RTTI}
           { for management operators like initialize call int_initialize }
           vmt := PVmt(self);
           if assigned(vmt) then
             begin
               inittable:=vmt^.vInitTable;
               if assigned(inittable) then
                 begin
                   mopinittable:=RTTIRecordMopInitTable(inittable);
                   if assigned(mopinittable) then
                     begin
                       {$push}
                       { ensure that no range check errors pop up with the [0..0] array }
                       {$R-}
                       for i:=0 to mopinittable^.Count-1 do
                         TRTTIRecVarOp(mopinittable^.Entries[i].ManagmentOperator)(PByte(Instance)+mopinittable^.Entries[i].FieldOffset);
                       {$pop}
                     end;
                 end;
             end;
{$endif def FPC_HAS_FEATURE_RTTI}

           InitInstance:=TObject(Instance);
        end;

      class function TObject.ClassParent : tclass;

        begin
           { type of self is class of tobject => it points to the vmt }
           { the parent vmt is saved at offset vmtParent              }
           classparent:=tclass(PVmt(Self)^.vParent);
        end;

      class function TObject.NewInstance : tobject;

        var
           p : pointer;

        begin
           getmem(p, InstanceSize);
           if p <> nil then
              InitInstance(p);
           NewInstance:=TObject(p);
        end;

      procedure TObject.FreeInstance;

        begin
           CleanupInstance;
           FreeMem(Pointer(Self));
        end;

      class function TObject.ClassType : TClass;

        begin
           ClassType:=TClass(Pointer(Self))
        end;

      type
         {$PUSH}
         {$PACKRECORDS NORMAL}
         tmethodnamerec =
         {$IFNDEF FPC_REQUIRES_PROPER_ALIGNMENT}
         packed
         {$ENDIF FPC_REQUIRES_PROPER_ALIGNMENT}
         record
            name : pshortstring;
            addr : codepointer;
         end;

         tmethodnametable =
         {$IFNDEF FPC_REQUIRES_PROPER_ALIGNMENT}
         packed
         {$ENDIF FPC_REQUIRES_PROPER_ALIGNMENT}
         record
           count : dword;
           entries : packed array[0..0] of tmethodnamerec;
         end;
         {$POP}

         pmethodnametable =  ^tmethodnametable;

      class function TObject.MethodAddress(const name : shortstring) : codepointer;

        var
           methodtable : pmethodnametable;
           i : longint; // in case count=0
           ovmt : PVmt;

        begin
           ovmt:=PVmt(self);
           while assigned(ovmt) do
             begin
                methodtable:=pmethodnametable(ovmt^.vMethodTable);
                if assigned(methodtable) then
                  begin
                     for i:=0 to methodtable^.count-1 do
                       if ShortCompareText(methodtable^.entries[i].name^, name)=0 then
                         begin
                            MethodAddress:=methodtable^.entries[i].addr;
                            exit;
                         end;
                  end;
                ovmt := ovmt^.vParent;
             end;
           MethodAddress:=nil;
        end;


      class function TObject.MethodName(address : codepointer) : shortstring;
        var
           methodtable : pmethodnametable;
           i : longint; // in case count=0
           ovmt : PVmt;
        begin
           ovmt:=PVmt(self);
           while assigned(ovmt) do
             begin
                methodtable:=pmethodnametable(ovmt^.vMethodTable);
                if assigned(methodtable) then
                  begin
                     for i:=0 to methodtable^.count-1 do
                       if methodtable^.entries[i].addr=address then
                         begin
                            MethodName:=methodtable^.entries[i].name^;
                            exit;
                         end;
                  end;
                ovmt := ovmt^.vParent;
             end;
           MethodName:='';
        end;


      function TObject.FieldAddress(const name : shortstring) : pointer;

         {The following is copied to the typinfo unit. If it is changed here, change it there as well ! }

        type
           {$PUSH}
           {$PACKRECORDS NORMAL}
           PFieldInfo = ^TFieldInfo;
           TFieldInfo =
{$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}
           packed
{$endif FPC_REQUIRES_PROPER_ALIGNMENT}
           record
             FieldOffset: SizeUInt;
             ClassTypeIndex: Word;
             Name: ShortString;
           end;

           PFieldTable = ^TFieldTable;
           TFieldTable =
{$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}
           packed
{$endif FPC_REQUIRES_PROPER_ALIGNMENT}
           record
             FieldCount: Word;
             ClassTable: Pointer;
             { should be array[Word] of TFieldInfo;  but
               Elements have variant size! force at least proper alignment }
             Fields: array[0..0] of TFieldInfo
           end;
           {$POP}

        var
           ovmt: PVmt;
           FieldTable: PFieldTable;
           FieldInfo: PFieldInfo;
           i: longint;

        begin
           if Length(name) > 0 then
           begin
             ovmt := PVmt(ClassType);
             while ovmt <> nil do
             begin
               FieldTable := PFieldTable(ovmt^.vFieldTable);
               if FieldTable <> nil then
               begin
                 FieldInfo := @FieldTable^.Fields[0];
                 for i := 0 to FieldTable^.FieldCount - 1 do
                 begin
                   if ShortCompareText(FieldInfo^.Name, name) = 0 then
                   begin
                     fieldaddress := Pointer(Self) + FieldInfo^.FieldOffset;
                     exit;
                   end;
                   FieldInfo := PFieldInfo(PByte(@FieldInfo^.Name) + 1 + Length(FieldInfo^.Name));
{$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
                   { align to largest field of TFieldInfo }
                   FieldInfo := Align(FieldInfo, SizeOf(PtrUInt));
{$endif FPC_REQUIRES_PROPER_ALIGNMENT}
                 end;
               end;
               { Try again with the parent class type }
               ovmt:=ovmt^.vParent;
             end;
           end;

           fieldaddress:=nil;
        end;

      function TObject.SafeCallException(exceptobject : tobject;
        exceptaddr : codepointer) : HResult;

        begin
          safecallexception:=E_UNEXPECTED;
        end;

      class function TObject.ClassInfo : pointer;

        begin
          ClassInfo := PVmt(Self)^.vTypeInfo;
        end;

      class function TObject.ClassName : ShortString;

        begin
          ClassName := PVmt(Self)^.vClassName^;
        end;

      class function TObject.ClassNameIs(const name : RTLString) : boolean;

        var
          SS : ShortString;
          
        begin
           SS:=ShortString(Name);
           ClassNameIs:=ShortCompareText(PVmt(Self)^.vClassName^, SS) = 0;
        end;

      class function TObject.InheritsFrom(aclass : TClass) : Boolean;

        var
           vmt: PVmt;

        begin
           if assigned(aclass) then
             begin
               vmt:=PVmt(self);
               while assigned(vmt) and (vmt <> PVmt(aclass)) do
                 vmt := vmt^.vParent;
               InheritsFrom := (vmt = PVmt(aclass));
             end
           else
             inheritsFrom := False;
        end;

      class function TObject.stringmessagetable : pstringmessagetable;

        begin
          stringmessagetable:=PVmt(Self)^.vMsgStrPtr;
        end;

      type
         tmessagehandler = procedure(var msg) of object;


      procedure TObject.Dispatch(var message);

        type
{$PUSH}
{$PACKRECORDS NORMAL}
           PMsgIntTable = ^TMsgIntTable;
           TMsgIntTable = record
              index : dword;
              method : codepointer;
           end;

           PMsgInt = ^TMsgInt;
           TMsgInt = record
              count : longint;
              msgs : array[0..0] of TMsgIntTable;
           end;
{$POP}
        var
           index : dword;
           count,i : longint;
           msgtable : PMsgIntTable;
           p : PMsgInt;
           ovmt : PVmt;
           msghandler : tmessagehandler;

        begin
           index:=dword(message);
           ovmt := PVmt(ClassType);
           while assigned(ovmt) do
             begin
                // See if we have messages at all in this class.
                p:=PMsgInt(ovmt^.vDynamicTable);
                If Assigned(p) then
                  begin
                     msgtable:=@p^.msgs;
                     count:=p^.count;
                  end
                else
                  Count:=0;
                { later, we can implement a binary search here }
                for i:=0 to count-1 do
                  begin
                     if index=msgtable[i].index then
                       begin
                          TMethod(msghandler).Code:=msgtable[i].method;
                          TMethod(msghandler).Data:=self;
                          msghandler(message);
                          exit;
                       end;
                  end;
                ovmt:=ovmt^.vParent;
             end;
           DefaultHandler(message);
        end;

      procedure TObject.DispatchStr(var message);

        var
           name : shortstring;
           count,i : longint;
           msgstrtable : pmsgstrtable;
           p: pstringmessagetable;
           ovmt : PVmt;
           msghandler : tmessagehandler;

        begin
           name:=pshortstring(@message)^;
           ovmt:=PVmt(ClassType);
           while assigned(ovmt) do
           begin
                p := ovmt^.vMsgStrPtr;
                if (P<>Nil) and (p^.count<>0) then
                  begin
                  count:=p^.count;
                  msgstrtable:=@p^.msgstrtable;
                  end
                else
                  Count:=0;
                { later, we can implement a binary search here }
                for i:=0 to count-1 do
                  begin
                     if name=msgstrtable[i].name^ then
                       begin
                          TMethod(msghandler).Code:=msgstrtable[i].method;
                          TMethod(msghandler).Data:=self;
                          msghandler(message);
                          exit;
                       end;
                  end;
                ovmt:=ovmt^.vParent;
           end;
           DefaultHandlerStr(message);
        end;

      procedure TObject.DefaultHandler(var message);

        begin
        end;

      procedure TObject.DefaultHandlerStr(var message);

        begin
        end;

      procedure TObject.CleanupInstance;

        var
           vmt  : PVmt;
           temp : pointer;
        begin
           vmt := PVmt(ClassType);
           while vmt<>nil do
             begin
               Temp:= vmt^.vInitTable;
{$ifdef FPC_HAS_FEATURE_RTTI}
               { The RTTI format matches one for records, except the type is tkClass.
                 Since RecordRTTI does not check the type, calling it yields the desired result. }
               if Assigned(Temp) then
                 RecordRTTI(Self,aligntoqword(Temp+2+PByte(Temp)[1]),@int_finalize);
{$endif def FPC_HAS_FEATURE_RTTI}
               vmt:= vmt^.vParent;
             end;
           {$IFDEF SYSTEM_HAS_FEATURE_MONITOR}
           if Assigned(_MonitorData) then
             TMonitor.FreeMonitorData(_MonitorData);
           {$ENDIF}
        end;

      procedure TObject.AfterConstruction;

        begin
        end;

      procedure TObject.BeforeDestruction;

        begin
        end;

      function IsGUIDEqual(const guid1, guid2: tguid): boolean;
        begin
          IsGUIDEqual:=
            (guid1.D1=guid2.D1) and
            (PDWORD(@guid1.D2)^=PDWORD(@guid2.D2)^) and
            (PDWORD(@guid1.D4[0])^=PDWORD(@guid2.D4[0])^) and
            (PDWORD(@guid1.D4[4])^=PDWORD(@guid2.D4[4])^);
        end;

      // Use of managed types should be avoided here; implicit _Addref/_Release
      // will end up in unpredictable behaviour if called on CORBA interfaces.
      type
        TInterfaceGetter = procedure(out Obj) of object;
        TClassGetter = function: TObject of object;

      function GetInterfaceByEntry(Instance: pointer; IEntry: pinterfaceentry; out obj): boolean;
        var
          Getter: TMethod;
        begin
          Pointer(Obj) := nil;
          Getter.Data := Instance;
          if Assigned(IEntry) and Assigned(Instance) then
          begin
            case IEntry^.IType of
              etStandard:
                  Pointer(Obj) := PByte(instance)+IEntry^.IOffset;
              etFieldValue, etFieldValueClass:
                  Pointer(obj) := PPointer(PByte(Instance)+IEntry^.IOffset)^;
              etVirtualMethodResult:
                begin
                  // IOffset is relative to the VMT, not to instance.
                  Getter.code := PCodePointer(PByte(PPointer(Instance)^) + IEntry^.IOffset)^;
                  TInterfaceGetter(Getter)(obj);
                end;
              etVirtualMethodClass:
                begin
                  // IOffset is relative to the VMT, not to instance.
                  Getter.code := PCodePointer(PByte(PPointer(Instance)^) + IEntry^.IOffset)^;
                  TObject(obj) := TClassGetter(Getter)();
                end;
              etStaticMethodResult:
                begin
                  Getter.code := IEntry^.IOffsetAsCodePtr;
                  TInterfaceGetter(Getter)(obj);
                end;
              etStaticMethodClass:
                begin
                  Getter.code := IEntry^.IOffsetAsCodePtr;
                  TObject(obj) := TClassGetter(Getter)();
                end;
            end;
          end;
          result := assigned(pointer(obj));
        end;

      function TObject.GetInterface(const iid : tguid;out obj) : boolean;
        var
          IEntry: PInterfaceEntry;
          Instance: TObject;
        begin
          if IsGUIDEqual(IObjectInstance,iid) then
          begin
            TObject(Obj) := Self;
            Result := True;
            Exit;
          end;

          Instance := self;
          repeat
            IEntry := Instance.GetInterfaceEntry(iid);
            result := GetInterfaceByEntry(Instance, IEntry, obj);

            if (not result) or
              (IEntry^.IType in [etStandard, etFieldValue,
               etStaticMethodResult, etVirtualMethodResult]) then
              Break;

            { if interface is implemented by a class-type property or field,
              continue search }
            Instance := TObject(obj);
          until False;

          { Getter function will normally AddRef, so adding another reference here
            will cause memleak. }
          if result and (IEntry^.IType in [etStandard, etFieldValue]) then
            IInterface(obj)._AddRef;
        end;

      function TObject.GetInterfaceWeak(const iid : tguid; out obj) : boolean;
        var
          IEntry: PInterfaceEntry;
          Instance: TObject;
        begin
          if IsGUIDEqual(IObjectInstance,iid) then
          begin
            TObject(Obj) := Self;
            Result := True;
            Exit;
          end;

          Instance := self;
          repeat
            IEntry := Instance.GetInterfaceEntry(iid);
            result := GetInterfaceByEntry(Instance, IEntry, obj);

            if (not result) or
              (IEntry^.IType in [etStandard, etFieldValue,
               etStaticMethodResult, etVirtualMethodResult]) then
              Break;

            { if interface is implemented by a class-type property or field,
              continue search }
            Instance := TObject(obj);
          until False;

          { Getter function will normally AddRef, so we have to release it,
            else the ref is not weak. }
          if result and not (IEntry^.IType in [etStandard, etFieldValue]) then
            IInterface(obj)._Release;
        end;

      function TObject.GetInterfaceByStr(const iidstr : shortstring;out obj) : boolean;
        var
          IEntry: PInterfaceEntry;
          Instance: TObject;
        begin
          Instance := self;
          repeat
            IEntry := Instance.GetInterfaceEntryByStr(iidstr);
            result := GetInterfaceByEntry(Instance, IEntry, obj);

            if (not result) or
              (IEntry^.IType in [etStandard, etFieldValue,
               etStaticMethodResult, etVirtualMethodResult]) then
              Break;

            { if interface is implemented by a class-type property or field,
              continue search }
            Instance := TObject(obj);
          until False;

          { Getter function will normally AddRef, so adding another reference here
            will cause memleak. (com interfaces only!) }
          if result and Assigned(IEntry^.IID) and (IEntry^.IType in [etStandard, etFieldValue]) then
            IInterface(obj)._AddRef;
        end;

      function TObject.GetInterface(const iidstr : shortstring;out obj) : boolean;
        begin
          Result := GetInterfaceByStr(iidstr,obj);
        end;

      class function TObject.GetInterfaceEntry(const iid : tguid) : pinterfaceentry;
        var
          i: longint;
          intftable: pinterfacetable;
          ovmt: PVmt;
        begin
          ovmt := PVmt(Self);
          while Assigned(ovmt) and Assigned(ovmt^.vIntftable) do
          begin
            intftable:=ovmt^.vIntfTable;
            for i:=0 to intftable^.EntryCount-1 do
            begin
              result:=@intftable^.Entries[i];
              if assigned(Result^.iid) and IsGUIDEqual(Result^.iid^,iid) then
                Exit;
            end;
            ovmt := ovmt^.vParent;
          end;
          result := nil;
        end;

      class function TObject.GetInterfaceEntryByStr(const iidstr : shortstring) : pinterfaceentry;
        var
          i: longint;
          intftable: pinterfacetable;
          ovmt: PVmt;
        begin
          ovmt := PVmt(Self);
          while Assigned(ovmt) and Assigned(ovmt^.vIntfTable) do
          begin
            intftable:=ovmt^.vIntfTable;
            for i:=0 to intftable^.EntryCount-1 do
            begin
              result:=@intftable^.Entries[i];
              if assigned(result^.iidstr) and (result^.iidstr^ = iidstr) then
                Exit;
            end;
            ovmt := ovmt^.vParent;
          end;
          result:=nil;
        end;

      class function TObject.GetInterfaceTable : pinterfacetable;
        begin
          getinterfacetable:=PVmt(Self)^.vIntfTable;
        end;

      class function TObject.UnitName : RTLString;
{$ifdef FPC_HAS_FEATURE_RTTI}

        type
          TClassTypeInfo = {$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}packed{$endif}record
            Attributes: Pointer;
            case TTypeKind of
              tkClass: (
                ClassType: TClass;
                ParentInfo: Pointer;
                PropCount: SmallInt;
                UnitName: ShortString;
              );
              { include for proper alignment }
              tkInt64: (
                Dummy: Int64;
              );
          end;
          PClassTypeInfo = ^TClassTypeInfo;
        var
          classtypeinfo: PClassTypeInfo;
        begin
          classtypeinfo:=ClassInfo;
          if Assigned(classtypeinfo) then
          begin
            // offset PTypeInfo by Length(Name) + 2 (ShortString length byte + SizeOf(Kind))
            inc(Pointer(classtypeinfo), PByte(Pointer(classtypeinfo)+1)^ + 2);
            {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
            classtypeinfo:=aligntoqword(classtypeinfo);
            {$endif}
            result:=classtypeinfo^.UnitName;
          end
          else
            result:='';
        end;
{$else not FPC_HAS_FEATURE_RTTI}
        begin
          result:='';
        end;
{$endif ndef FPC_HAS_FEATURE_RTTI}

      class function TObject.QualifiedClassName: RTLString;
        var
          uname: RTLString;
        begin
          uname := UnitName; //TODO: change 'UnitName' to 'UnitScope' as soon as RTL implement it
          if uname='' then
            result:=ClassName
          else
            result:=Concat(uname, '.', ClassName);
        end;

      function TObject.Equals(Obj: TObject) : boolean;
        begin
          result:=Obj=Self;
        end;

      function TObject.GetHashCode: PtrInt;
        begin
          result:=PtrInt(Self);
        end;

      function TObject.ToString: RTLString;
        begin
          result:=ClassName;
        end;
        
      procedure TObject.DisposeOf;
      begin
        Free;
      end;
      
      function TObject.GetDisposed : Boolean;
      
      begin
        Result:=False;
      end;    
      
      procedure TObject.CheckDisposed;
      
      begin
        // Do nothing since we have no reference count.
      end;

      {$IFDEF SYSTEM_HAS_FEATURE_MONITOR}

       function TObject.SetMonitorData(aData,aCheckOld : Pointer) : Pointer;
       begin
         Result:=InterlockedCompareExchange(_MonitorData,aData,aCheckOld);
       end;

       function TObject.GetMonitorData: Pointer;
       begin
         Result:=_MonitorData;
       end;
      {$ENDIF}


{****************************************************************************
                               TINTERFACEDOBJECT
****************************************************************************}

    function TInterfacedObject.QueryInterface(
      {$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} iid : tguid;out obj) : longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};

      begin
         if getinterface(iid,obj) then
           result:=S_OK
         else
           result:=longint(E_NOINTERFACE);
      end;

    function TInterfacedObject._AddRef : longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};

      begin
         _addref:=frefcount;
         if _addref<>0 then
           begin
             if _addref>0 then
               _addref:=interlockedincrement(frefcount);
             exit;
           end;
         frefcount:=1; { Work non-atomically in the common case of refcount = 0 (typical state after the complete object construction). }
         _addref:=1;
      end;

    function TInterfacedObject._Release : longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};

      begin
         _Release:=frefcount;
         if _Release<>1 then
           begin
             if _Release<=0 then { -1 means recursive call from destructor... 0 is impossible. }
               exit;
             _Release:=interlockeddecrement(frefcount);
             if _Release>0 then
               exit;
           end
         else
           _Release:=0; { Work non-atomically in the common case of refcount = 1 (typical state for the last owner... which is often the only owner). }
         frefcount:=-1; { Prevent recursive _Release from destroying twice (bug 32168). }
         self.destroy;
      end;

   destructor TInterfacedObject.Destroy;

   begin
     // We must explicitly reset. Bug ID 32353
     FRefCount:=0;
     inherited Destroy;
   end;

    procedure TInterfacedObject.AfterConstruction;

      begin
         { we need to fix the refcount we forced in newinstance }
         { further, it must be done in a thread safe way        }
         if frefcount=1 then
           frefcount:=0 { Work non-atomically in the common case of refcount = 1 (usual state before AfterConstruction). }
         else
           declocked(frefcount);
      end;

    procedure TInterfacedObject.BeforeDestruction;

      begin
         if frefcount>0 then { Legitimate values: -1 if destroying by _Release, 0 if destroying manually. }
           HandleError(204);
      end;

    class function TInterfacedObject.NewInstance : TObject;

      begin
         NewInstance:=inherited NewInstance;
         if NewInstance<>nil then
           TInterfacedObject(NewInstance).frefcount:=1;
      end;

{****************************************************************************
                               TAGGREGATEDOBJECT
****************************************************************************}

    constructor TAggregatedObject.Create(const aController: IUnknown);

      begin
        inherited Create;
        { do not keep a counted reference to the controller! }
        fcontroller := Pointer(aController);
      end;

    function TAggregatedObject.QueryInterface(
      {$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} iid : tguid;out obj) : longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};

      begin
         Result := IUnknown(fcontroller).QueryInterface(iid, obj);
      end;

    function TAggregatedObject._AddRef : longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};

      begin
         Result := IUnknown(fcontroller)._AddRef;
      end;

    function TAggregatedObject._Release : longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};

      begin
         Result := IUnknown(fcontroller)._Release;
      end;

    function TAggregatedObject.GetController : IUnknown;

      begin
         Result := IUnknown(fcontroller);
      end;

{****************************************************************************
                               TContainedOBJECT
****************************************************************************}

    function TContainedObject.QueryInterface(
            {$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} iid : tguid;out obj) : longint; {$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};

    begin
      if getinterface(iid,obj) then
        result:=S_OK
      else
        result:=longint(E_NOINTERFACE);
    end;

{****************************************************************************
                               TNoRefCountObject
****************************************************************************}

    function TNoRefCountObject.QueryInterface( {$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} iid : tguid;out obj) : longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};

      begin
         if getinterface(iid,obj) then
           result:=S_OK
         else
           result:=longint(E_NOINTERFACE);
      end;

    function TNoRefCountObject._AddRef : longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};

      begin
         Result:=-1;
      end;

    function TNoRefCountObject._Release : longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};

      begin
         Result:=-1;
      end;



{****************************************************************************
                               TCustomAttribute
****************************************************************************}


    constructor TCustomAttribute.Create;
    begin
      inherited;
    end;


{****************************************************************************
                           TUnimplementedAttribute
****************************************************************************}


    constructor TUnimplementedAttribute.Create;
    begin
      inherited;
    end;


{****************************************************************************
                               TCustomStoredAttribute
****************************************************************************}


    constructor StoredAttribute.Create;
    begin
    end;


    constructor  StoredAttribute.Create(Const aFlag : Boolean);
    begin
      FFlag:=aFlag;
    end;



    constructor StoredAttribute.Create(Const aName : shortstring);
    begin
      FName:=aName;
    end;

{****************************************************************************
                             TInterfaceThunk
****************************************************************************}

Constructor TInterfaceThunk.Create(aCallback : TThunkCallback);

begin
  FCallBack:=aCallBack;
end;

Procedure TInterfaceThunk.Thunk(aMethod: Longint; aCount : Longint; aData : PArgData);

begin
  if Assigned(FCallBack) then
    FCallBack(Self,aMethod,aCount,aData); 
end;

function TInterfaceThunk.QueryInterface({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} iid : tguid;out obj) : longint;{$IFNDEF WINDOWS}cdecl{$ELSE}stdcall{$ENDIF};

begin
  result:=longint(E_NOINTERFACE);
  if (TMethod(FCallBack).Data<>Nil) then
    // Query the object that created us, this is normally TVirtualInterface
    // Take care: do not call QueryInterface, that would create a never-ending loop !!
    if TObject(TMethod(FCallBack).Data).GetInterface(iid,obj) then
      result:=S_OK;
  if (Result<>S_OK) then
    Result:=Inherited QueryInterface(iid,obj);
end;

function TInterfaceThunk.InterfaceVMTOffset : word;

begin
  Result:=0;
end;

{****************************************************************************
                             Exception Support
****************************************************************************}

{$ifdef FPC_HAS_FEATURE_EXCEPTIONS}
  {$if defined(FPC_WASM_NATIVE_EXCEPTIONS)}
    {$I except_native.inc}
  {$elseif defined(FPC_WASM_BRANCHFUL_EXCEPTIONS)}
    {$I except_branchful.inc}
  {$else}
    {$i except.inc}
  {$endif}
{$endif FPC_HAS_FEATURE_EXCEPTIONS}

{****************************************************************************
                             Various Delphi constructs
****************************************************************************}

class operator TMethod.=(const aLeft, aRight: TMethod): Boolean; inline;
begin
  Result:=(aLeft.Data=aRight.Data) and (aLeft.Code=aRight.Code);
end;

class operator TMethod.<>(const aLeft, aRight: TMethod): Boolean; inline;
begin
  Result:=(aLeft.Data<>aRight.Data) or (aLeft.Code<>aRight.Code);
end;

class operator TMethod.>(const aLeft, aRight: TMethod): Boolean; inline;
begin
  Result:=(PtrUInt(aLeft.Data)>PtrUInt(aRight.Data)) 
            or
          ((aLeft.Data=aRight.Data) and (PtrUInt(aLeft.Code)>PtrUint(aRight.Code)));
end;

class operator TMethod.>=(const aLeft, aRight: TMethod): Boolean; inline;
begin
  Result:=(aLeft>aRight) or (aLeft=aRight);
end;

class operator TMethod.<(const aLeft, aRight: TMethod): Boolean; inline;
begin
  Result:=(PtrUInt(aLeft.Data)<PtrUInt(aRight.Data)) 
            or
          ((aLeft.Data=aRight.Data) and (PtrUInt(aLeft.Code)<PtrUint(aRight.Code)));
end;

class operator TMethod.<=(const aLeft, aRight: TMethod): Boolean; inline;
begin
  Result:=(aLeft<aRight) or (aLeft=aRight);
end;


function TPtrWrapper.ToPointer: Pointer;
begin
  Result:=FValue;
end;

class function TPtrWrapper.GetNilValue: TPtrWrapper;

begin
  Result.FValue:=Nil;
end;

constructor TPtrWrapper.Create(AValue: PtrInt);

begin
  FValue:=Pointer(aValue);
end;

constructor TPtrWrapper.Create(AValue: Pointer);

begin
  FValue:=aValue;
end;


function TPtrWrapper.ToInteger: PtrInt;
begin
  Result:=PtrInt(FValue);
end;

class operator TPtrWrapper.=(Left, Right: TPtrWrapper): Boolean;

begin
  Result:=Left.FValue=Right.FValue;
end;

constructor TMarshal.Create;
begin
  System.Error(reInvalidPtr);
end;

class function TMarshal.AllocMem(Size: SizeInt): TPtrWrapper;
begin
  Result.Value := System.AllocMem(Size);
end;

class function TMarshal.ReallocMem(OldPtr: TPtrWrapper; NewSize: SizeInt): TPtrWrapper;
var
  P: Pointer;
begin
  P := OldPtr.Value;
  Result.Value := System.ReallocMem(P, NewSize);
end;

class procedure TMarshal.FreeMem(Ptr: TPtrWrapper);
begin
  System.FreeMem(Ptr.Value);
end;

class procedure TMarshal.Move(Src, Dest: TPtrWrapper; Count: SizeInt); static;
begin
  System.Move(Src.Value^, Dest.Value^, Count);
end;


class function TMarshal.UnsafeAddrOf(var Value): TPtrWrapper;
begin
  Result.Value := @Value;
end;


class procedure TMarshal.Copy(const Src: TUint8Array; StartIndex: SizeInt; Dest: TPtrWrapper; Count: SizeInt);
begin
  System.Move(PUInt8(Src)[StartIndex], Dest.Value^, Count * SizeOf(UInt8));
end;

class procedure TMarshal.Copy(Src: TPtrWrapper; var Dest: TUint8Array; StartIndex: SizeInt; Count: SizeInt);
begin
  System.Move(Src.Value^, PUInt8(Dest)[StartIndex], Count * SizeOf(UInt8));
end;

class procedure TMarshal.Copy(const Src: TInt8Array; StartIndex: SizeInt; Dest: TPtrWrapper; Count: SizeInt);
begin
  System.Move(PInt8(Src)[StartIndex], Dest.Value^, Count * SizeOf(Int8));
end;

class procedure TMarshal.Copy(Src: TPtrWrapper; var Dest: TInt8Array ; StartIndex: SizeInt; Count: SizeInt);
begin
  System.Move(Src.Value^, PInt8(Dest)[StartIndex], Count * SizeOf(Int8));
end;

class procedure TMarshal.Copy(const Src: TUInt16Array; StartIndex: SizeInt; Dest: TPtrWrapper; Count: SizeInt);
begin
  System.Move(PUInt16(Src)[StartIndex], Dest.Value^, Count * SizeOf(UInt16));
end;

class procedure TMarshal.Copy(Src: TPtrWrapper; var Dest: TUint16Array; StartIndex: SizeInt; Count: SizeInt);
begin
  System.Move(Src.Value^, PUInt16(Dest)[StartIndex], Count * SizeOf(UInt16));
end;

class procedure TMarshal.Copy(const Src: TInt16Array; StartIndex: SizeInt; Dest: TPtrWrapper; Count: SizeInt);
begin
  System.Move(PInt16(Src)[StartIndex], Dest.Value^, Count * SizeOf(Int16));
end;

class procedure TMarshal.Copy(Src: TPtrWrapper; var Dest: TInt16Array; StartIndex: SizeInt; Count: SizeInt);
begin
  System.Move(Src.Value^, PInt16(Dest)[StartIndex], Count * SizeOf(Int16));
end;

class procedure TMarshal.Copy(const Src: TInt32Array; StartIndex: SizeInt; Dest: TPtrWrapper; Count: SizeInt);
begin
  System.Move(PInt32(Src)[StartIndex], Dest.Value^, Count * SizeOf(Int32));
end;

class procedure TMarshal.Copy(Src: TPtrWrapper; var Dest: TInt32Array; StartIndex: SizeInt; Count: SizeInt);
begin
  System.Move(Src.Value^, PInt32(Dest)[StartIndex], Count * SizeOf(Int32));
end;

class procedure TMarshal.Copy(const Src: TInt64Array; StartIndex: SizeInt; Dest: TPtrWrapper; Count: SizeInt);
begin
  System.Move(PInt64(Src)[StartIndex], Dest.Value^, Count * SizeOf(Int64));
end;

class procedure TMarshal.Copy(Src: TPtrWrapper; var Dest: TInt64Array; StartIndex: SizeInt; Count: SizeInt);
begin
  System.Move(Src.Value^, PInt64(Dest)[StartIndex], Count * SizeOf(Int64));
end;

class procedure TMarshal.Copy(const Src: TPtrWrapperArray; StartIndex: SizeInt; Dest: TPtrWrapper; Count: SizeInt);
begin
  System.Move(PPointer(Src)[StartIndex], Dest.Value^, Count * SizeOf(TPtrWrapper));
end;

class procedure TMarshal.Copy(Src: TPtrWrapper; var Dest: TPtrWrapperArray; StartIndex: SizeInt; Count: SizeInt);
begin
  System.Move(Src.Value^, PPointer(Dest)[StartIndex], Count * SizeOf(TPtrWrapper));
end;

generic class function TMarshal.FixArray<T>(const Arr: specialize TArray<T>): TPtrWrapper;
begin
  Result.Value := nil;
  specialize TArray<T>(Result) := Arr;
end;

generic class procedure TMarshal.UnfixArray<T>(ArrPtr: TPtrWrapper);
begin
  Finalize(specialize TArray<T>(ArrPtr));
end;


class function TMarshal.ReadByte(Ptr: TPtrWrapper; Ofs: SizeInt = 0): Byte;
begin
  Result := PByte(Ptr.Value + Ofs)^;
end;

class procedure TMarshal.WriteByte(Ptr: TPtrWrapper; Ofs: SizeInt; Value: Byte);
begin
  PByte(Ptr.Value + Ofs)^ := Value;
end;

class procedure TMarshal.WriteByte(Ptr: TPtrWrapper; Value: Byte);
begin
  PByte(Ptr.Value)^ := Value;
end;

class function TMarshal.ReadInt16(Ptr: TPtrWrapper; Ofs: SizeInt = 0): Int16;
begin
  Result := PInt16(Ptr.Value + Ofs)^;
end;

class procedure TMarshal.WriteInt16(Ptr: TPtrWrapper; Ofs: SizeInt; Value: Int16);
begin
  PInt16(Ptr.Value + Ofs)^ := Value;
end;

class procedure TMarshal.WriteInt16(Ptr: TPtrWrapper; Value: Int16);
begin
  PInt16(Ptr.Value)^ := Value;
end;

class function TMarshal.ReadInt32(Ptr: TPtrWrapper; Ofs: SizeInt = 0): Int32;
begin
  Result := PInt32(Ptr.Value + Ofs)^;
end;

class procedure TMarshal.WriteInt32(Ptr: TPtrWrapper; Ofs: SizeInt; Value: Int32);
begin
  PInt32(Ptr.Value + Ofs)^ := Value;
end;

class procedure TMarshal.WriteInt32(Ptr: TPtrWrapper; Value: Int32);
begin
  PInt32(Ptr.Value)^ := Value;
end;

class function TMarshal.ReadInt64(Ptr: TPtrWrapper; Ofs: SizeInt = 0): Int64;
begin
  Result := PInt64(Ptr.Value + Ofs)^;
end;

class procedure TMarshal.WriteInt64(Ptr: TPtrWrapper; Ofs: SizeInt; Value: Int64);
begin
  PInt64(Ptr.Value + Ofs)^ := Value;
end;

class procedure TMarshal.WriteInt64(Ptr: TPtrWrapper; Value: Int64);
begin
  PInt64(Ptr.Value)^ := Value;
end;

class function TMarshal.ReadPtr(Ptr: TPtrWrapper; Ofs: SizeInt = 0): TPtrWrapper;
begin
  Result.Value := PPointer(Ptr.Value + Ofs)^;
end;

class procedure TMarshal.WritePtr(Ptr: TPtrWrapper; Ofs: SizeInt; Value: TPtrWrapper);
begin
  PPointer(Ptr.Value + Ofs)^ := Value.Value;
end;

class procedure TMarshal.WritePtr(Ptr, Value: TPtrWrapper);
begin
  PPointer(Ptr.Value)^ := Value.Value;
end;

{$IFDEF FPC_HAS_FEATURE_UNICODESTRINGS}

class function TMarshal.AsAnsi(const S: UnicodeString): AnsiString;
begin
  Result := AnsiString(S);
end;

class function TMarshal.AsAnsi(S: PUnicodeChar): AnsiString;
begin
  result := AnsiString(S);
end;

class function TMarshal.InOutString(const S: UnicodeString): PUnicodeChar;
begin
  Result := PUnicodeChar(S);
end;

class function TMarshal.InString(const S: UnicodeString): PUnicodeChar;
begin
  Result := PUnicodeChar(S);
end;

class function TMarshal.OutString(const S: UnicodeString): PUnicodeChar;
begin
  Result := PUnicodeChar(S);
end;

class function TMarshal.FixString(var Str: UnicodeString): TPtrWrapper;
begin
  UniqueString(Str);
  Result := UnsafeFixString(Str);
end;

class procedure TMarshal.UnfixString(Ptr: TPtrWrapper);
begin
  if Ptr.Value <> PUnicodeChar('') then
    Finalize(UnicodeString(Ptr));
end;

class function TMarshal.UnsafeFixString(const Str: UnicodeString): TPtrWrapper;
begin
  if Length(Str) = 0 then
  begin
    Result.Value := PUnicodeChar('');
    Exit;
  end;
  Result.Value := nil;
  UnicodeString(Result) := Str;
end;

class function TMarshal.AllocStringAsAnsi(const Str: UnicodeString): TPtrWrapper;
begin
  Result := AllocStringAsAnsi(PUnicodeChar(Pointer(Str)), Length(Str), DefaultSystemCodePage);
end;

class function TMarshal.AllocStringAsAnsi(const Str: UnicodeString; CodePage: Word): TPtrWrapper;
begin
  Result := AllocStringAsAnsi(PUnicodeChar(Pointer(Str)), Length(Str), CodePage);
end;

class function TMarshal.AllocStringAsAnsi(S: PUnicodeChar): TPtrWrapper;
begin
  Result := AllocStringAsAnsi(S, Length(S), DefaultSystemCodePage);
end;

class function TMarshal.AllocStringAsAnsi(S: PUnicodeChar; CodePage: Word): TPtrWrapper;
begin
  Result := AllocStringAsAnsi(S, Length(S), CodePage);
end;

class function TMarshal.AllocStringAsUnicode(const Str: UnicodeString): TPtrWrapper;
var
  NBytes: SizeUint;
begin
  NBytes := (Length(Str) + 1) * SizeOf(UnicodeChar);
  Result.Value := System.GetMem(NBytes);
  System.Move(PUnicodeChar(Str)^, Result.Value^, NBytes);
end;

class function TMarshal.AllocStringAsUtf8(const Str: UnicodeString): TPtrWrapper;
begin
  Result := AllocStringAsAnsi(PUnicodeChar(Pointer(Str)), Length(Str), CP_UTF8);
end;

class function TMarshal.AllocStringAsUtf8(S: PUnicodeChar): TPtrWrapper;
begin
  Result := AllocStringAsAnsi(S, Length(S), CP_UTF8);
end;

class function TMarshal.AllocStringAsAnsi(S: PUnicodeChar; Len: SizeInt; CodePage: Word): TPtrWrapper;
var
  U2ARes: AnsiString;
  NBytes: SizeInt;
begin
  U2ARes := ''; { Suppress warning. }
  WideStringManager.Unicode2AnsiMoveProc(S, U2ARes, CodePage, Len);
  if Length(U2ARes) = 0 then
  begin
    Result.Value := nil;
    Exit;
  end;
  { Could instead avoid the second allocation, assuming U2ARes.RefCount = 1:
    System.Move(Pointer(U2ARes)^, (Pointer(U2ARes) - AnsiStringHeaderSize)^, (Length(U2ARes) + 1) * SizeOf(AnsiChar));
    Result.FValue := Pointer(U2ARes) - AnsiStringHeaderSize;
    Pointer(U2ARes) := nil; }
  NBytes := (Length(U2ARes) + 1) * SizeOf(AnsiChar);
  Result.Value := System.GetMem(NBytes);
  System.Move(PAnsiChar(U2ARes)^, Result.Value^, NBytes);
end;

class procedure TMarshal.Copy(const Src: TUnicodeCharArray; StartIndex: SizeInt; Dest: TPtrWrapper; Count: SizeInt);
begin
  System.Move(PUnicodeChar(Src)[StartIndex], Dest.Value^, Count * SizeOf(UnicodeChar));
end;

class procedure TMarshal.Copy(Src: TPtrWrapper; var Dest: TUnicodeCharArray; StartIndex: SizeInt; Count: SizeInt);
begin
  System.Move(Src.Value^, PUnicodeChar(Dest)[StartIndex], Count * SizeOf(UnicodeChar));
end;

class function TMarshal.ReadStringAsAnsi(Ptr: TPtrWrapper; Len: SizeInt = -1): UnicodeString;
begin
  Result := ReadStringAsAnsi(DefaultSystemCodePage, Ptr, Len);
end;

class function TMarshal.ReadStringAsAnsi(CodePage: Word; Ptr: TPtrWrapper; Len: SizeInt = -1): UnicodeString;
begin
  { Here and below, IndexByte/Word assume that, when Len >= 0, either:
    - Up to Len characters are accessible in Ptr;
    - IndexByte/Word cannot access invalid memory past the searched character
      (e.g. i386.inc and x86_64.inc IndexByte/Word versions are specifically designed not to). }
  if Len < 0 then
    Len := IndexByte(Ptr.Value^, Len, 0);
  Result := ''; { Suppress warning. }
  WideStringManager.Ansi2UnicodeMoveProc(Ptr.Value, CodePage, Result, Len);
end;

class function TMarshal.ReadStringAsAnsiUpTo(CodePage: Word; Ptr: TPtrWrapper; MaxLen: SizeInt): UnicodeString;
var
  Len: SizeInt;
begin
  Len := IndexByte(Ptr.Value^, MaxLen, 0);
  if Len < 0 then
    Len := MaxLen;
  Result := ReadStringAsAnsi(CodePage, Ptr, Len);
end;

class procedure TMarshal.WriteStringAsAnsi(Ptr: TPtrWrapper; const Value: UnicodeString; MaxCharsIncNull: SizeInt);
begin
  WriteStringAsAnsi(Ptr, 0, Value, MaxCharsIncNull, DefaultSystemCodePage);
end;

class procedure TMarshal.WriteStringAsAnsi(Ptr: TPtrWrapper; const Value: UnicodeString; MaxCharsIncNull: SizeInt; CodePage: Word);
begin
  WriteStringAsAnsi(Ptr, 0, Value, MaxCharsIncNull, CodePage);
end;

class procedure TMarshal.WriteStringAsAnsi(Ptr: TPtrWrapper; Ofs: SizeInt; const Value: UnicodeString; MaxCharsIncNull: SizeInt);
begin
  WriteStringAsAnsi(Ptr, Ofs, Value, MaxCharsIncNull, DefaultSystemCodePage);
end;

class procedure TMarshal.WriteStringAsAnsi(Ptr: TPtrWrapper; Ofs: SizeInt; const Value: UnicodeString; MaxCharsIncNull: SizeInt; CodePage: Word);
var
  U2ARes: AnsiString;
  ValueLen, U2AResLen: SizeInt;
begin
  U2ARes := ''; { Suppress warning. }
  ValueLen := Length(Value);
  { Delphi null-terminates iff MaxCharsIncNull < 0, so MaxCharsIncNull is actually just MaxChars. }
  if (MaxCharsIncNull > 0) and (MaxCharsIncNull < ValueLen) then
    ValueLen := MaxCharsIncNull; { UTF-16 → ANSI should never shrink element count, so limit the number of characters analyzed. }
  WideStringManager.Unicode2AnsiMoveProc(PUnicodeChar(Pointer(Value)), U2ARes, CodePage, ValueLen);
  U2AResLen := Length(U2ARes);
  if (MaxCharsIncNull >= 0) and (MaxCharsIncNull < U2AResLen) then
    U2AResLen := MaxCharsIncNull;
  System.Move(PAnsiChar(Pointer(U2ARes))^, (Ptr.Value + Ofs)^, U2AResLen * SizeOf(AnsiChar));
  if MaxCharsIncNull < 0 then
    PAnsiChar(Ptr.Value + Ofs)[U2AResLen] := #0;
end;

class function TMarshal.ReadStringAsUnicode(Ptr: TPtrWrapper; Len: SizeInt = -1): UnicodeString;
begin
  if Len < 0 then
    Len := Length(PUnicodeChar(Ptr.Value));
  Result := ''; { Suppress warning. }
  SetLength(Result, Len);
  System.Move(Ptr.Value^, Pointer(Result)^, Len * SizeOf(UnicodeChar));
end;

class function TMarshal.ReadStringAsUnicodeUpTo(Ptr: TPtrWrapper; MaxLen: SizeInt): UnicodeString;
var
  Len: SizeInt;
begin
  Len := IndexWord(Ptr.Value^, MaxLen, 0);
  if Len < 0 then
    Len := MaxLen;
  Result := ReadStringAsUnicode(Ptr, Len);
end;

class procedure TMarshal.WriteStringAsUnicode(Ptr: TPtrWrapper; const Value: UnicodeString; MaxCharsIncNull: SizeInt);
begin
  WriteStringAsUnicode(Ptr, 0, Value, MaxCharsIncNull);
end;

class procedure TMarshal.WriteStringAsUnicode(Ptr: TPtrWrapper; Ofs: SizeInt; const Value: UnicodeString; MaxCharsIncNull: SizeInt);
var
  Len: SizeInt;
begin
  { Again, Delphi null-terminates iff MaxCharsIncNull < 0, so MaxCharsIncNull is actually just MaxChars. }
  Len := Length(Value);
  if (MaxCharsIncNull >= 0) and (MaxCharsIncNull < Len) then
    Len := MaxCharsIncNull;
  System.Move(Pointer(Value)^, (Ptr.Value + Ofs)^, Len * SizeOf(UnicodeChar));
  if MaxCharsIncNull < 0 then
    PUnicodeChar(Ptr.Value + Ofs)[Len] := #0;
end;

class function TMarshal.ReadStringAsUtf8(Ptr: TPtrWrapper; Len: SizeInt = -1): UnicodeString;
begin
  Result := ReadStringAsAnsi(CP_UTF8, Ptr, Len);
end;

class function TMarshal.ReadStringAsUtf8UpTo(Ptr: TPtrWrapper; MaxLen: SizeInt): UnicodeString;
begin
  Result := ReadStringAsAnsiUpTo(CP_UTF8, Ptr, MaxLen);
end;

class procedure TMarshal.WriteStringAsUtf8(Ptr: TPtrWrapper; const Value: UnicodeString; MaxCharsIncNull: SizeInt);
begin
  WriteStringAsAnsi(Ptr, Value, MaxCharsIncNull, CP_UTF8);
end;

class procedure TMarshal.WriteStringAsUtf8(Ptr: TPtrWrapper; Ofs: SizeInt; const Value: UnicodeString; MaxCharsIncNull: SizeInt);
begin
  WriteStringAsAnsi(Ptr, Ofs, Value, MaxCharsIncNull, CP_UTF8);
end;

{$ENDIF}

{$IFDEF SYSTEM_HAS_FEATURE_MONITOR}
{$i monitor.inc}
{$ENDIF}