diff --git a/rtl/i386/rttip.inc b/rtl/i386/rttip.inc index 5a881e29c0..0189d0afcb 100644 --- a/rtl/i386/rttip.inc +++ b/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 diff --git a/rtl/inc/objpas.inc b/rtl/inc/objpas.inc index 94207c9289..d9890db205 100644 --- a/rtl/inc/objpas.inc +++ b/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 -} +} \ No newline at end of file diff --git a/rtl/inc/objpash.inc b/rtl/inc/objpash.inc index 11a573b1d2..ed7cb9abd7 100644 --- a/rtl/inc/objpash.inc +++ b/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 - -} + +} \ No newline at end of file