paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-11-04 01:19:38 +01:00
Code Issues Packages Projects Releases Wiki Activity

* fixed interface rtti, fixes bug #4089

Browse Source 
git-svn-id: trunk@422 -
This commit is contained in:
florian 2005-06-15 21:27:51 +00:00
parent aa1650fcdc
commit 90cdc1b6fe
3 changed files with 50 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitattributes vendored
View File

@ -5933,6 +5933,7 @@ tests/webtbs/tw4038.pp svneol=native#text/plain
tests/webtbs/tw4055.pp svneol=native#text/plain
tests/webtbs/tw4058.pp svneol=native#text/plain
tests/webtbs/tw4078.pp svneol=native#text/plain
tests/webtbs/tw4089.pp svneol=native#text/plain
tests/webtbs/ub1873.pp svneol=native#text/plain
tests/webtbs/ub1883.pp svneol=native#text/plain
tests/webtbs/uw0555.pp svneol=native#text/plain

19
rtl/objpas/typinfo.pp
View File

@ -45,7 +45,7 @@ unit typinfo;
TMethodKind = (mkProcedure,mkFunction,mkConstructor,mkDestructor,
mkClassProcedure, mkClassFunction);
TParamFlags = set of (pfVar,pfConst,pfArray,pfAddress,pfReference,pfOut);
TIntfFlag = (ifHasGuid,ifDispInterface,ifDispatch);
TIntfFlag = (ifHasGuid,ifDispInterface,ifDispatch,ifHasStrGUID);
TIntfFlags = set of TIntfFlag;
TIntfFlagsBase = set of TIntfFlag;
@ -124,13 +124,20 @@ unit typinfo;
(MinInt64Value, MaxInt64Value: Int64);
tkQWord:
(MinQWordValue, MaxQWordValue: QWord);
tkInterface,
tkInterface:
(
IntfParent: PTypeInfo;
IntfFlags : TIntfFlagsBase;
GUID: TGUID;
IntfUnit: ShortString;
);
tkInterfaceRaw:
(
IntfParent: PPTypeInfo;
IID: PGUID;
IIDStr: ShortString;
IntfUnit: ShortString;
RawIntfParent: PTypeInfo;
RawIntfFlags : TIntfFlagsBase;
IID: TGUID;
RawIntfUnit: ShortString;
IIDStr: ShortString;
);
end;

36
tests/webtbs/tw4089.pp Normal file
View File

@ -0,0 +1,36 @@
{ Source provided for Free Pascal Bug Report 4089 }
{ Submitted by "Martin Schreiber" on 2005-06-14 }
{ e-mail: }
program project1;
{$ifdef FPC}
{$mode objfpc}{$H+}
{$else}
{$apptype console}
{$endif}
uses
Classes, SysUtils, typinfo;
type
itest1 = interface
procedure test1;
end;
itest2 = interface(itest1)['{1A50A4E4-5B46-4C7C-A992-51EFEA1202B8}']
procedure test2;
end;
var
po1: ptypeinfo;
po2: ptypedata;
begin
po1:= typeinfo(itest2);
writeln('Kind: ',getenumname(typeinfo(ttypekind),ord(po1^.kind)));
writeln('Name: "',po1^.name,'"');
po2:= gettypedata(po1);
writeln('IntfParent: ',integer(po2^.intfparent));
writeln('Guid: ',po2^.guid.d1);
writeln('IntfUnit: "',po2^.IntfUnit,'"');
end.