From 90cdc1b6fe945bbb0f5524b04fbaa336f2e6e27e Mon Sep 17 00:00:00 2001
From: florian <florian@freepascal.org>
Date: Wed, 15 Jun 2005 21:27:51 +0000
Subject: [PATCH] * fixed interface rtti, fixes bug #4089
git-svn-id: trunk@422 -
---
.gitattributes | 1 +
rtl/objpas/typinfo.pp | 19 +++++++++++++------
tests/webtbs/tw4089.pp | 36 ++++++++++++++++++++++++++++++++++++
3 files changed, 50 insertions(+), 6 deletions(-)
create mode 100644 tests/webtbs/tw4089.pp
diff --git a/.gitattributes b/.gitattributes
index a1794da2c5..a834dcd1ec 100644
--- a/.gitattributes
+++ b/.gitattributes
@@ -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
diff --git a/rtl/objpas/typinfo.pp b/rtl/objpas/typinfo.pp
index c3a22da28b..71a8032b48 100644
--- a/rtl/objpas/typinfo.pp
+++ b/rtl/objpas/typinfo.pp
@@ -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;
diff --git a/tests/webtbs/tw4089.pp b/tests/webtbs/tw4089.pp
new file mode 100644
index 0000000000..4764700386
--- /dev/null
+++ b/tests/webtbs/tw4089.pp
@@ -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.
\ No newline at end of file