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.

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

    procedure DoDispCallByIDError(res : Pointer; const disp : IDispatch;desc : PDispDesc; params : Pointer);
      begin
        handleerrorframe(RuntimeErrorExitCodes[reVarDispatch],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;

{****************************************************************************
                  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
           handleerrorframe(219,get_frame);
         result := aobject;
      end;

    { interface helpers }
    procedure fpc_intf_decr_ref(var i: pointer);[public,alias: 'FPC_INTF_DECR_REF']; compilerproc;
      begin
        if assigned(i) then
          begin
            IUnknown(i)._Release;
            i:=nil;
          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_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
             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_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
             if IUnknown(S).QueryInterface(iid,tmpi)<>S_OK then
               handleerror(219);
             pointer(fpc_intf_as):=tmpi;
          end
        else
          fpc_intf_as:=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
      begin
        if assigned(S) then
          begin
             if not TObject(S).GetInterface(iid,tmpi) then
               handleerror(219);
             pointer(fpc_class_as_intf):=tmpi;
          end
        else
          fpc_class_as_intf:=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:=pSizeInt(pointer(self)+vmtInstanceSize)^;
        end;

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

        var
          i: integer;
          intftable: pinterfacetable;
          Res: pinterfaceentry;
        begin
          while assigned(objclass) do
            begin
              intftable:=pinterfacetable((pointer(objclass)+vmtIntfTable)^);
              if assigned(intftable) then
              begin
                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;
              end;
              objclass:=pclass(pointer(objclass)+vmtParent)^;
            end;
        end;

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

        begin
           { 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!)           }
           ppointer(instance)^:=pointer(self);
           InitInterfacePointers(self,instance);
           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:=pclass(pointer(self)+vmtParent)^;
        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
         tmethodnamerec = packed record
            name : pshortstring;
            addr : pointer;
         end;

         tmethodnametable = packed record
           count : dword;
           entries : packed array[0..0] of tmethodnamerec;
         end;

         pmethodnametable =  ^tmethodnametable;

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

        var
           UName : ShortString;
           methodtable : pmethodnametable;
           i : dword;
           vmt : tclass;

        begin
           UName := UpCase(name);
           vmt:=self;
           while assigned(vmt) do
             begin
                methodtable:=pmethodnametable((Pointer(vmt)+vmtMethodTable)^);
                if assigned(methodtable) then
                  begin
                     for i:=0 to methodtable^.count-1 do
                       if UpCase(methodtable^.entries[i].name^)=UName then
                         begin
                            MethodAddress:=methodtable^.entries[i].addr;
                            exit;
                         end;
                  end;
                vmt:=pclass(pointer(vmt)+vmtParent)^;
             end;
           MethodAddress:=nil;
        end;


      class function TObject.MethodName(address : pointer) : shortstring;
        var
           methodtable : pmethodnametable;
           i : dword;
           vmt : tclass;
        begin
           vmt:=self;
           while assigned(vmt) do
             begin
                methodtable:=pmethodnametable((Pointer(vmt)+vmtMethodTable)^);
                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;
                vmt:=pclass(pointer(vmt)+vmtParent)^;
             end;
           MethodName:='';
        end;


      function TObject.FieldAddress(const name : shortstring) : pointer;
        type
           PFieldInfo = ^TFieldInfo;
           TFieldInfo =
{$ifndef FPC_REQUIRES_PROPER_ALIGNMENT}
           packed
{$endif FPC_REQUIRES_PROPER_ALIGNMENT}
           record
             FieldOffset: PtrUInt;
             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;

        var
           UName: ShortString;
           CurClassType: TClass;
           FieldTable: PFieldTable;
           FieldInfo: PFieldInfo;
           i: Integer;

        begin
           if Length(name) > 0 then
           begin
             UName := UpCase(name);
             CurClassType := ClassType;
             while CurClassType <> nil do
             begin
               FieldTable := PFieldTable((Pointer(CurClassType) + vmtFieldTable)^);
               if FieldTable <> nil then
               begin
                 FieldInfo := @FieldTable^.Fields[0];
                 for i := 0 to FieldTable^.FieldCount - 1 do
                 begin
                   if UpCase(FieldInfo^.Name) = UName 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 }
               CurClassType:=pclass(pointer(CurClassType)+vmtParent)^;
             end;
           end;

           fieldaddress:=nil;
        end;

      function TObject.SafeCallException(exceptobject : tobject;
        exceptaddr : pointer) : longint;

        begin
           safecallexception:=0;
        end;

      class function TObject.ClassInfo : pointer;

        begin
           ClassInfo:=ppointer(Pointer(self)+vmtTypeInfo)^;
        end;

      class function TObject.ClassName : ShortString;

        begin
           ClassName:=PShortString((Pointer(Self)+vmtClassName)^)^;
        end;

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

        begin
           ClassNameIs:=Upcase(ClassName)=Upcase(name);
        end;

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

        var
           vmt : tclass;

        begin
           vmt:=self;
           while assigned(vmt) do
             begin
                if vmt=aclass then
                  begin
                     InheritsFrom:=true;
                     exit;
                  end;
                vmt:=pclass(pointer(vmt)+vmtParent)^;
             end;
           InheritsFrom:=false;
        end;

      class function TObject.stringmessagetable : pstringmessagetable;

        begin
           stringmessagetable:=pstringmessagetable((pointer(Self)+vmtMsgStrPtr)^);
        end;

      type
         tmessagehandler = procedure(var msg) of object;
         tmessagehandlerrec = packed record
            proc : pointer;
            obj : pointer;
         end;


      procedure TObject.Dispatch(var message);

        type
           tmsgtable = packed record
              index : dword;
              method : pointer;
           end;

           pmsgtable = ^tmsgtable;

        var
           index : dword;
           count,i : longint;
           msgtable : pmsgtable;
           p : pointer;
           vmt : tclass;
           msghandler : tmessagehandler;

        begin
           index:=dword(message);
           vmt:=ClassType;
           while assigned(vmt) do
             begin
                // See if we have messages at all in this class.
                p:=pointer(vmt)+vmtDynamicTable;
                If assigned(PPointer(p)^) then
                  begin
                     msgtable:=pmsgtable(Pointer(p^)+4);
                     count:=pdword(p^)^;
                  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
                          p:=msgtable[i].method;
                          tmessagehandlerrec(msghandler).proc:=p;
                          tmessagehandlerrec(msghandler).obj:=self;
                          msghandler(message);
                          exit;
                       end;
                  end;
                vmt:=pclass(pointer(vmt)+vmtParent)^;
             end;
           DefaultHandler(message);
        end;

      procedure TObject.DispatchStr(var message);

        type
           PSizeUInt = ^SizeUInt;

        var
           name : shortstring;
           count,i : longint;
           msgstrtable : pmsgstrtable;
           p : pointer;
           vmt : tclass;
           msghandler : tmessagehandler;

        begin
           name:=pshortstring(@message)^;
           vmt:=ClassType;
           while assigned(vmt) do
             begin
                p:=(pointer(vmt)+vmtMsgStrPtr);
                If (P<>Nil) and (PPtrInt(P)^<>0) then
                  begin
                  count:=PPtrInt(PSizeUInt(p)^)^;
                  msgstrtable:=pmsgstrtable(PSizeUInt(P)^+sizeof(ptrint));
                  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
                          p:=msgstrtable[i].method;
                          tmessagehandlerrec(msghandler).proc:=p;
                          tmessagehandlerrec(msghandler).obj:=self;
                          msghandler(message);
                          exit;
                       end;
                  end;
                vmt:=pclass(pointer(vmt)+vmtParent)^;
             end;
           DefaultHandlerStr(message);
        end;

      procedure TObject.DefaultHandler(var message);

        begin
        end;

      procedure TObject.DefaultHandlerStr(var message);

        begin
        end;

      procedure TObject.CleanupInstance;

        Type
          TRecElem = packed Record
            Info : Pointer;
            Offset : Longint;
          end;

          TRecElemArray = packed array[1..Maxint] of TRecElem;

          PRecRec = ^TRecRec;
          TRecRec = record
            Size,Count : Longint;
            Elements : TRecElemArray;
          end;

        var
           vmt  : tclass;
           temp : pbyte;
           count,
           i    : longint;
{$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
           recelem  : TRecElem;
{$endif FPC_REQUIRES_PROPER_ALIGNMENT}
        begin
           vmt:=ClassType;
           while vmt<>nil do
             begin
               { This need to be included here, because Finalize()
                 has should support for tkClass }
               Temp:=Pointer((Pointer(vmt)+vmtInitTable)^);
               if Assigned(Temp) then
                 begin
                   inc(Temp);
                   I:=Temp^;
                   inc(temp,I+1);                // skip name string;
                   temp:=aligntoptr(temp);
{$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
                   move(PRecRec(Temp)^.Count,Count,sizeof(Count));
{$else FPC_REQUIRES_PROPER_ALIGNMENT}
                   Count:=PRecRec(Temp)^.Count;  // get element Count
{$endif FPC_REQUIRES_PROPER_ALIGNMENT}
                   For I:=1 to count do
{$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
                     begin
                       move(PRecRec(Temp)^.elements[I],RecElem,sizeof(RecElem));
                       With RecElem do
                         int_Finalize (pointer(self)+Offset,Info);
                     end;
{$else FPC_REQUIRES_PROPER_ALIGNMENT}
                     With PRecRec(Temp)^.elements[I] do
                       int_Finalize (pointer(self)+Offset,Info);
{$endif FPC_REQUIRES_PROPER_ALIGNMENT}
                 end;
               vmt:=pclass(pointer(vmt)+vmtParent)^;
             end;
        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;

      function getinterfacebyentry(Instance: pointer; IEntry: pinterfaceentry; out obj): boolean;
        var
          Getter: function: IInterface of object;
        begin
          Pointer(Obj) := nil;
          if Assigned(IEntry) and Assigned(Instance) then
          begin
            case IEntry^.IType of
              etStandard:
                begin
                  //writeln('Doing etStandard cast of ', TObject(Instance).classname(), ' with self = ', ptruint(Instance), ' and offset = ', IEntry^.IOffset);
                  Pointer(Obj) := Pointer(PtrInt(Instance) + IEntry^.IOffset);
                end;
              etFieldValue:
                begin
                  //writeln('Doing etFieldValue cast of ', TObject(Instance).classname(), ' with offset = ', IEntry^.IOffset);
                  Pointer(obj) := ppointer(Pointer(Instance)+IEntry^.IOffset)^;
                end;
              etVirtualMethodResult:
                begin
                  //writeln('Doing etVirtualMethodResult cast of ', TObject(Instance).classname());
                  TMethod(Getter).data := Instance;
                  TMethod(Getter).code := ppointer(ptrint(Instance) + IEntry^.IOffset)^;
                  Pointer(obj) := Pointer(Getter());
                end;
              etStaticMethodResult:
                begin
                  //writeln('Doing etStaticMethodResult cast of ', TObject(Instance).classname());
                  TMethod(Getter).data := Instance;
                  TMethod(Getter).code := pointer(IEntry^.IOffset);
                  Pointer(obj) := Pointer(Getter());
                end;
            end;
          end;
          result := assigned(pointer(obj));
          if result then
            IInterface(obj)._AddRef;
        end;

      function TObject.getinterface(const iid : tguid;out obj) : boolean;
        begin
          Result := getinterfacebyentry(self, getinterfaceentry(iid), obj);
        end;

      function TObject.getinterfacebystr(const iidstr : string;out obj) : boolean;
        begin
          Result := getinterfacebyentry(self, getinterfaceentrybystr(iidstr), obj);
        end;

      class function TObject.getinterfaceentry(const iid : tguid) : pinterfaceentry;
        var
          i: integer;
          intftable: pinterfacetable;
          Res: pinterfaceentry;
        begin
          getinterfaceentry:=nil;
          intftable:=pinterfacetable((pointer(Self)+vmtIntfTable)^);
          if assigned(intftable) then begin
            i:=intftable^.EntryCount;
            Res:=@intftable^.Entries[0];
            while (i>0) and
               not (assigned(Res^.iid) and IsGUIDEqual(Res^.iid^,iid)) do begin
              inc(Res);
              dec(i);
            end;
            if (i>0) then
              getinterfaceentry:=Res;
          end;
          if (getinterfaceentry=nil)and not(classparent=nil) then
            getinterfaceentry:=classparent.getinterfaceentry(iid)
        end;

      class function TObject.getinterfaceentrybystr(const iidstr : string) : pinterfaceentry;
        var
          i: integer;
          intftable: pinterfacetable;
          Res: pinterfaceentry;
        begin
          getinterfaceentrybystr:=nil;
          intftable:=pinterfacetable((pointer(Self)+vmtIntfTable)^);
          if assigned(intftable) then begin
            i:=intftable^.EntryCount;
            Res:=@intftable^.Entries[0];
            while (i>0) and (Res^.iidstr^<>iidstr) do begin
              inc(Res);
              dec(i);
            end;
            if (i>0) then
              getinterfaceentrybystr:=Res;
          end;
          if (getinterfaceentrybystr=nil) and not(classparent=nil) then
            getinterfaceentrybystr:=classparent.getinterfaceentrybystr(iidstr)
        end;

      class function TObject.getinterfacetable : pinterfacetable;
        begin
          getinterfacetable:=pinterfacetable((pointer(Self)+vmtIntfTable)^);
        end;

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

    function TInterfacedObject.QueryInterface(
      const iid : tguid;out obj) : longint;stdcall;

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

    function TInterfacedObject._AddRef : longint;stdcall;

      begin
         _addref:=interlockedincrement(frefcount);
      end;

    function TInterfacedObject._Release : longint;stdcall;

      begin
         _Release:=interlockeddecrement(frefcount);
         if _Release=0 then
           self.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        }
         declocked(frefcount);
      end;

    procedure TInterfacedObject.BeforeDestruction;

      begin
         if frefcount<>0 then
           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(
      const iid : tguid;out obj) : longint;stdcall;

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

    function TAggregatedObject._AddRef : longint;stdcall;

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

    function TAggregatedObject._Release : longint;stdcall;

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

      begin
         Result := IUnknown(fcontroller);
      end;    


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

{$ifdef FPC_HAS_FEATURE_EXCEPTIONS}
{$i except.inc}
{$endif FPC_HAS_FEATURE_EXCEPTIONS}