Merged revisions 422-423 via svnmerge from

/trunk

git-svn-id: branches/fixes_2_0@477 -

.gitattributes

@@ -5932,6 +5932,7 @@ tests/webtbs/tw4043.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

compiler/symconst.pas

@@ -112,7 +112,11 @@ const
   paranr_syscall_legacy   = high(word)-2;
   paranr_result_leftright = high(word)-1;
 
+
 type
+  { keep this in sync with TIntfFlag in rtl/objpas/typinfo.pp }
+  TCompilerIntfFlag = (ifHasGuid,ifDispInterface,ifDispatch,ifHasStrGUID);
+
   { Deref entry options }
   tdereftype = (deref_nil,
     deref_sym,

compiler/symdef.pas

@@ -5879,6 +5879,8 @@ implementation
 
 
     procedure tobjectdef.write_rtti_data(rt:trttitype);
+      var
+        i : longint;
       begin
          case objecttype of
             odt_class:
@@ -5914,27 +5916,55 @@ implementation
              end;
            fullrtti :
              begin
-               if (oo_has_vmt in objectoptions) and
-                  not(objecttype in [odt_interfacecom,odt_interfacecorba]) then
-                 rttiList.concat(Tai_const.Createname(vmt_mangledname,AT_DATA,0))
-               else
-                 rttiList.concat(Tai_const.create_sym(nil));
+               if not(objecttype in [odt_interfacecom,odt_interfacecorba]) then
+                 begin
+                   if (oo_has_vmt in objectoptions) then
+                     rttiList.concat(Tai_const.Createname(vmt_mangledname,AT_DATA,0))
+                   else
+                     rttiList.concat(Tai_const.create_sym(nil));
+                 end;
 
-               { write owner typeinfo }
-               if assigned(childof) and (oo_can_have_published in childof.objectoptions) then
+               { write parent typeinfo }
+               if assigned(childof) and ((oo_can_have_published in childof.objectoptions) or
+                 (objecttype in [odt_interfacecom,odt_interfacecorba])) then
                  rttiList.concat(Tai_const.Create_sym(childof.get_rtti_label(fullrtti)))
                else
                  rttiList.concat(Tai_const.create_sym(nil));
 
-               { count total number of properties }
-               if assigned(childof) and (oo_can_have_published in childof.objectoptions) then
-                 count:=childof.next_free_name_index
-               else
-                 count:=0;
+               if objecttype in [odt_object,odt_class] then
+                 begin
+                   { count total number of properties }
+                   if assigned(childof) and (oo_can_have_published in childof.objectoptions) then
+                     count:=childof.next_free_name_index
+                   else
+                     count:=0;
 
-               { write it }
-               symtable.foreach(@count_published_properties,nil);
-               rttiList.concat(Tai_const.Create_16bit(count));
+                   { write it }
+                   symtable.foreach(@count_published_properties,nil);
+                   rttiList.concat(Tai_const.Create_16bit(count));
+                 end
+               else
+                 { interface: write flags, iid and iidstr }
+                 begin
+                   rttiList.concat(Tai_const.Create_32bit(
+                     { ugly, but working }
+                     longint([
+                       TCompilerIntfFlag(ord(ifHasGuid)*ord(assigned(iidguid))),
+                       TCompilerIntfFlag(ord(ifHasStrGUID)*ord(assigned(iidstr)))
+                     ])
+                     {
+                     ifDispInterface,
+                     ifDispatch, }
+                     ));
+{$ifdef cpurequiresproperalignment}
+                   rttilist.concat(Tai_align.Create(sizeof(TConstPtrUInt)));
+{$endif cpurequiresproperalignment}
+                   rttilist.concat(Tai_const.Create_32bit(longint(iidguid^.D1)));
+                   rttilist.concat(Tai_const.Create_16bit(iidguid^.D2));
+                   rttilist.concat(Tai_const.Create_16bit(iidguid^.D3));
+                   for i:=Low(iidguid^.D4) to High(iidguid^.D4) do
+                     rttilist.concat(Tai_const.Create_8bit(iidguid^.D4[i]));
+                 end;
 
                { write unit name }
                rttiList.concat(Tai_const.Create_8bit(length(current_module.realmodulename^)));
@@ -5944,14 +5974,32 @@ implementation
                rttilist.concat(Tai_align.Create(sizeof(TConstPtrUInt)));
 {$endif cpurequiresproperalignment}
 
-               { write published properties count }
-               count:=0;
-               symtable.foreach(@count_published_properties,nil);
-               rttiList.concat(Tai_const.Create_16bit(count));
+               { write iidstr }
+               if objecttype in [odt_interfacecom,odt_interfacecorba] then
+                 begin
+                   if assigned(iidstr) then
+                     begin
+                       rttiList.concat(Tai_const.Create_8bit(length(iidstr^)));
+                       rttiList.concat(Tai_string.Create(iidstr^));
+                     end
+                   else
+                     rttiList.concat(Tai_const.Create_8bit(0));
+{$ifdef cpurequiresproperalignment}
+                   rttilist.concat(Tai_align.Create(sizeof(TConstPtrUInt)));
+{$endif cpurequiresproperalignment}
+                 end;
+
+               if objecttype in [odt_object,odt_class] then
+                 begin
+                   { write published properties count }
+                   count:=0;
+                   symtable.foreach(@count_published_properties,nil);
+                   rttiList.concat(Tai_const.Create_16bit(count));
 
 {$ifdef cpurequiresproperalignment}
-               rttilist.concat(Tai_align.Create(sizeof(TConstPtrUInt)));
+                   rttilist.concat(Tai_align.Create(sizeof(TConstPtrUInt)));
 {$endif cpurequiresproperalignment}
+                 end;
 
                { count is used to write nameindex   }
 

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,14 +124,21 @@ unit typinfo;
               (MinInt64Value, MaxInt64Value: Int64);
             tkQWord:
               (MinQWordValue, MaxQWordValue: QWord);
-            tkInterface,
-            tkInterfaceRaw:
+            tkInterface:
               (
-               IntfParent: PPTypeInfo;
-               IID: PGUID;
-               IIDStr: ShortString;
+               IntfParent: PTypeInfo;
+               IntfFlags : TIntfFlagsBase;
+               GUID: TGUID;
                IntfUnit: ShortString;
               );
+            tkInterfaceRaw:
+              (
+               RawIntfParent: PTypeInfo;
+               RawIntfFlags : TIntfFlagsBase;
+               IID: TGUID;
+               RawIntfUnit: ShortString;
+               IIDStr: ShortString;               
+              );
       end;
 
       // unsed, just for completeness

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.