+ interfaces support

rtl/i386/rttip.inc

@@ -164,26 +164,18 @@ asm
         jmp     .LExitFinalize
         // Interfaces
 .LDoInterfaceFinal:
+        pushl   Data
+        call    FPC_INTF_DECR_REF
         jmp     .LExitFinalize
         // Variants
 .LDoVariantFinal:
         jmp     .LExitFinalize
         // dynamic Array
 .LDoDynArrayFinal:
-// load count
-        movl    Data,%edx
-        orl     %edx,%edx
-        jz      .LExitFinalize
-        movl    -4(%edx),%edx
-        incl    %ebx
-        movzbl  (%ebx),%eax
-        incl    %eax
-        addl    %eax,%ebx
-// %ebx points to size. Put size in ecx
-        movl    (%ebx),%ecx
-// %ebx points to type. Put into ebx.
-        addl    $4, %ebx
-        jmp     .LMyArrayFinalLoop
+        pushl   TypeInfo
+        pushl   Data
+        call    DYNARRAY_DECR_REF
+        jmp     .LExitFinalize
 .LDoClassFinal:
 .LDoObjectFinal:
 .LDoRecordFinal:
@@ -286,6 +278,8 @@ asm
         jmp     .LExitAddRef
         // Interfaces
 .LDoInterfaceAddRef:
+        pushl   Data
+        call    FPC_INTF_INCR_REF
         jmp     .LExitAddRef
         // Variants
 .LDoVariantAddRef:
@@ -293,10 +287,10 @@ asm
         // Dynamic Arrays
 .LDoDynArrayAddRef:
         movl    Data,%eax
-        testl   %eax,%eax
-        je      .LExitAddRef
+        orl     %eax,%eax
+        jz      .LExitAddRef
         lock
-        incl    -4(%eax)
+        incl    -8(%eax)
         jmp     .LExitAddRef
 .LDoClassAddRef:
 .LDoObjectAddRef:
@@ -398,12 +392,17 @@ asm
         jmp     .LExitDecRef
         // Interfaces
 .LDoInterfaceDecRef:
+        pushl   Data
+        call    FPC_INTF_DECR_REF
         jmp     .LExitDecRef
         // Variants
 .LDoVariantDecRef:
         jmp     .LExitDecRef
         // Dynamic Arrays
 .LDoDynArrayDecRef:
+        pushl   TypeInfo
+        pushl   Data
+        call    DYNARRAY_DECR_REF
         jmp     .LExitDecRef
 .LDoClassDecRef:
 .LDoObjectDecRef:
@@ -473,7 +472,10 @@ end;
 
 {
   $Log$
-  Revision 1.3  2000-10-21 18:20:17  florian
+  Revision 1.4  2000-11-04 16:30:35  florian
+    + interfaces support
+
+  Revision 1.3  2000/10/21 18:20:17  florian
     * a lot of small changes:
        - setlength is internal
        - win32 graph unit extended

rtl/inc/objpas.inc

@@ -32,6 +32,45 @@
            handleerror(219);
       end;
 
+{$ifndef ver1_0}
+    { interface helpers }
+    procedure int_do_intf_decr_ref(var i: pointer);[public,alias: 'FPC_INTF_DECR_REF'];
+      begin
+        if assigned(i) then
+          IUnknown(i)._Release;
+        i:=nil;
+      end;
+
+    procedure int_do_intf_incr_ref(const i: pointer);[public,alias: 'FPC_INTF_INCR_REF'];
+      begin
+         if assigned(i) then
+           IUnknown(i)._AddRef;
+      end;
+
+    procedure int_do_intf_assign(var D: pointer; const S: pointer);[public,alias: 'FPC_INTF_ASSIGN'];
+      begin
+         if assigned(S) then IUnknown(S)._AddRef;
+         if assigned(D) then IUnknown(D)._Release;
+         D:=S;
+      end;
+
+    procedure int_do_intf_as(var D: pointer; const S: pointer; const iid: TGUID);[public,alias: 'FPC_INTF_AS'];
+      const
+        S_OK = 0;
+      var
+        tmpi: pointer; // _AddRef before _Release
+      begin
+        if assigned(S) then
+          begin
+             if IUnknown(S).QueryInterface(iid,tmpi)<>S_OK then
+               handleerror(219);
+             if assigned(D) then IUnknown(D)._Release;
+             D:=tmpi;
+          end
+        else
+          int_do_intf_decr_ref(D);
+      end;
+{$endif ver1_0}
 
 {****************************************************************************
                                TOBJECT
@@ -151,7 +190,7 @@
                          end;
                   end;
                 c:=c.ClassParent;
-             end;                                                                                                                                                                                                                                              
+             end;
            MethodAddress:=nil;
         end;
 
@@ -342,7 +381,7 @@
                           tmessagehandlerrec(msghandler).obj:=self;
                           msghandler(message);
                           { we don't need any longer the assembler
-                            solution                              
+                            solution
                           asm
                              pushl message
                              pushl %esi
@@ -394,7 +433,7 @@
                           tmessagehandlerrec(msghandler).obj:=self;
                           msghandler(message);
                           { we don't need any longer the assembler
-                            solution                              
+                            solution
                           asm
                              pushl message
                              pushl %esi
@@ -445,6 +484,96 @@
         begin
         end;
 
+{$ifndef ver1_0}
+      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 TObject.getinterface(const iid : tguid;out obj) : boolean;
+        var
+          IEntry: pinterfaceentry;
+        begin
+          IEntry:=getinterfaceentry(iid);
+          if Assigned(IEntry) then begin
+            PDWORD(@obj)^:=DWORD(PDWORD(Self))+IEntry^.IOffset;
+            int_do_intf_incr_ref(pointer(obj)); { it must be an com interface }
+            getinterface:=True;
+          end
+          else begin
+            PDWORD(@Obj)^:=0;
+            getinterface:=False;
+          end;
+        end;
+
+      function TObject.getinterfacebystr(const iidstr : string;out obj) : boolean;
+        var
+          IEntry: pinterfaceentry;
+        begin
+          IEntry:=getinterfaceentrybystr(iidstr);
+          if Assigned(IEntry) then begin
+            PDWORD(@obj)^:=DWORD(PDWORD(Self))+IEntry^.IOffset;
+            if Assigned(IEntry^.iid) then { for Com interfaces }
+              int_do_intf_incr_ref(pointer(obj));
+            getinterfacebystr:=True;
+          end
+          else begin
+            PDWORD(@Obj)^:=0;
+            getinterfacebystr:=False;
+          end;
+        end;
+
+      class function TObject.getinterfaceentry(const iid : tguid) : pinterfaceentry;
+        var
+          i: integer;
+          intftable: pinterfacetable;
+          Res: pinterfaceentry;
+        begin
+          getinterfaceentry:=nil;
+          intftable:=getinterfacetable;
+          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;
+        end;
+
+      class function TObject.getinterfaceentrybystr(const iidstr : string) : pinterfaceentry;
+        var
+          i: integer;
+          intftable: pinterfacetable;
+          Res: pinterfaceentry;
+        begin
+          getinterfaceentrybystr:=nil;
+          intftable:=getinterfacetable;
+          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;
+        end;
+
+      class function TObject.getinterfacetable : pinterfacetable;
+        begin
+          getinterfacetable:=pinterfacetable((pointer(Self)+vmtIntfTable)^);
+        end;
+{$endif ver1_0}
+
 {****************************************************************************
                              Exception Support
 ****************************************************************************}
@@ -457,9 +586,12 @@
 
 {
   $Log$
-  Revision 1.3  2000-07-22 14:52:01  sg
+  Revision 1.4  2000-11-04 16:29:54  florian
+    + interfaces support
+
+  Revision 1.3  2000/07/22 14:52:01  sg
   * Resolved CVS conflicts for TObject.MethodAddress patch
 
   Revision 1.1.2.1  2000/07/22 14:46:57  sg
   * Made TObject.MethodAddress case independent
-}
+}

rtl/inc/objpash.inc

@@ -76,6 +76,28 @@
 
        pstringmessagetable = ^tstringmessagetable;
 
+       pguid = ^tguid;
+       tguid = packed record
+         D1: LongWord;
+         D2: Word;
+         D3: Word;
+         D4: array[0..7] of Byte;
+       end;
+
+       pinterfaceentry = ^tinterfaceentry;
+       tinterfaceentry = packed record
+         IID: pguid; { if assigned(IID) then Com else Corba}
+         VTable: Pointer;
+         IOffset: LongInt;
+         IIDStr: pshortstring; { never nil. Com: upper(GuidToString(IID^)) }
+       end;
+
+       pinterfacetable = ^tinterfacetable;
+       tinterfacetable = packed record
+         EntryCount: Word;
+         Entries: array[0..0] of tinterfaceentry;
+       end;
+
        tobject = class
        public
           { please don't change the order of virtual methods, because      }
@@ -116,14 +138,38 @@
           { new for gtk, default handler for text based messages }
           procedure DefaultHandlerStr(var message);virtual;
 
-          { interface functions, I don't know if we need this }
-          {
-          function getinterface(const iid : tguid;out obj) : boolean;
+{$ifndef ver1_0}
+          { interface functions }
+          function getinterface(const iid : tguid; out obj) : boolean;
+          function getinterfacebystr(const iidstr : string; out obj) : boolean;
           class function getinterfaceentry(const iid : tguid) : pinterfaceentry;
+          class function getinterfaceentrybystr(const iidstr : string) : pinterfaceentry;
           class function getinterfacetable : pinterfacetable;
-          }
+{$endif ver1_0}
        end;
 
+{$ifndef ver1_0}
+       IUnknown = interface
+         ['{00000000-0000-0000-C000-000000000046}']
+         function QueryInterface(const iid: tguid; var {out} obj): LongInt; stdcall;
+         function _AddRef: LongInt; stdcall;
+         function _Release: LongInt; stdcall;
+       end;
+
+       { for native dispinterface support }
+       IDispatch = interface(IUnknown)
+         ['{00020400-0000-0000-C000-000000000046}']
+         function GetTypeInfoCount({out}var count: LongInt): LongInt; stdcall;
+         function GetTypeInfo(Index, LocaleID: LongInt;
+           var {out} TypeInfo): LongInt; stdcall;
+         function GetIDsOfNames(const iid: TGUID; names: Pointer;
+           NameCount, LocaleID: LongInt; DispIDs: Pointer): LongInt; stdcall;
+         function Invoke(DispID: LongInt; const iid: TGUID;
+           LocaleID: LongInt; Flags: Word; var params;
+           VarResult, ExcepInfo, ArgErr: Pointer): Integer; stdcall;
+       end;
+{$endif ver1_0}
+
        TExceptProc = Procedure (Obj : TObject; Addr,Frame: Pointer);
 
        { Exception object stack }
@@ -205,14 +251,17 @@
            vtAnsiString : (VAnsiString: Pointer);
 //           vtCurrency   : (VCurrency: PCurrency);
 //           vtVariant    : (VVariant: PVariant);
-//           vtInterface  : (VInterface: Pointer);
+           vtInterface  : (VInterface: Pointer);
            vtWideString : (VWideString: Pointer);
            vtInt64      : (VInt64: PInt64);
            vtQWord      : (VQWord: PQWord);
        end;
 {
   $Log$
-  Revision 1.4  2000-09-30 07:38:07  sg
+  Revision 1.5  2000-11-04 16:28:55  florian
+    + interfaces support
+
+  Revision 1.4  2000/09/30 07:38:07  sg
   * Added 'RaiseProc': A user-definable callback procedure which gets
     called whenever an exception is being raised
 
@@ -221,5 +270,5 @@
 
   Revision 1.2  2000/07/13 11:33:45  michael
   + removed logs
- 
-}
+
+}