compiler, rtl, tests: write Delphi compatible (more or less) type information for Class Reference and Pointer types (mantis #0024367)

git-svn-id: trunk@24421 -

.gitattributes

@@ -11689,6 +11689,7 @@ tests/test/trtti2.pp svneol=native#text/plain
 tests/test/trtti3.pp svneol=native#text/plain
 tests/test/trtti4.pp svneol=native#text/plain
 tests/test/trtti5.pp svneol=native#text/plain
+tests/test/trtti6.pp svneol=native#text/pascal
 tests/test/tsafecall1.pp svneol=native#text/plain
 tests/test/tsafecall2.pp svneol=native#text/pascal
 tests/test/tsafecall3.pp svneol=native#text/pascal

compiler/ncgrtti.pas

@@ -616,6 +616,20 @@ implementation
              end;
         end;
 
+        procedure classrefdef_rtti(def:tclassrefdef);
+        begin
+          write_header(def,tkClassRef);
+          maybe_write_align;
+          current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_sym(ref_rtti(def.pointeddef,rt)));
+        end;
+
+        procedure pointerdef_rtti(def:tpointerdef);
+        begin
+          write_header(def,tkPointer);
+          maybe_write_align;
+          current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_sym(ref_rtti(def.pointeddef,rt)));
+        end;
+
         procedure recorddef_rtti(def:trecorddef);
         begin
            write_header(def,tkRecord);
@@ -938,6 +952,10 @@ implementation
             end;
           objectdef :
             objectdef_rtti(tobjectdef(def));
+          classrefdef :
+            classrefdef_rtti(tclassrefdef(def));
+          pointerdef :
+            pointerdef_rtti(tpointerdef(def));
           else
             unknown_rtti(tstoreddef(def));
         end;

compiler/symconst.pas

@@ -66,6 +66,8 @@ const
   tkUChar    = 25;
   tkHelper   = 26;
   tkFile     = 27;
+  tkClassRef = 28;
+  tkPointer  = 29;
 
   otSByte     = 0;
   otUByte     = 1;

rtl/inc/system.inc

@@ -18,33 +18,36 @@
 Const
    // please update tkManagedTypes below if you add new
    // values
-   tkUnknown       = 0;
-   tkInteger       = 1;
-   tkChar          = 2;
-   tkEnumeration   = 3;
-   tkFloat         = 4;
-   tkSet           = 5;
-   tkMethod        = 6;
-   tkSString       = 7;
-   tkString        = tkSString;
-   tkLString       = 8;
-   tkAString       = 9;
-   tkWString       = 10;
-   tkVariant       = 11;
-   tkArray         = 12;
-   tkRecord        = 13;
-   tkInterface     = 14;
-   tkClass         = 15;
-   tkObject        = 16;
-   tkWChar         = 17;
-   tkBool          = 18;
-   tkInt64         = 19;
-   tkQWord         = 20;
-   tkDynArray      = 21;
+   tkUnknown        = 0;
+   tkInteger        = 1;
+   tkChar           = 2;
+   tkEnumeration    = 3;
+   tkFloat          = 4;
+   tkSet            = 5;
+   tkMethod         = 6;
+   tkSString        = 7;
+   tkString         = tkSString;
+   tkLString        = 8;
+   tkAString        = 9;
+   tkWString        = 10;
+   tkVariant        = 11;
+   tkArray          = 12;
+   tkRecord         = 13;
+   tkInterface      = 14;
+   tkClass          = 15;
+   tkObject         = 16;
+   tkWChar          = 17;
+   tkBool           = 18;
+   tkInt64          = 19;
+   tkQWord          = 20;
+   tkDynArray       = 21;
    tkInterfaceCorba = 22;
-   tkProcVar       = 23;
-   tkUString       = 24;
-   tkHelper        = 26;
+   tkProcVar        = 23;
+   tkUString        = 24;
+   tkHelper         = 26;
+   tkFile           = 27;
+   tkClassRef       = 28;
+   tkPointer        = 29;
 
   // all potentially managed types
   tkManagedTypes   = [tkAstring,tkWstring,tkUstring,tkArray,

rtl/java/jsystem.inc

@@ -18,33 +18,36 @@
 Const
    // please update tkManagedTypes below if you add new
    // values
-   tkUnknown       = 0;
-   tkInteger       = 1;
-   tkChar          = 2;
-   tkEnumeration   = 3;
-   tkFloat         = 4;
-   tkSet           = 5;
-   tkMethod        = 6;
-   tkSString       = 7;
-   tkString        = tkSString;
-   tkLString       = 8;
-   tkAString       = 9;
-   tkWString       = 10;
-   tkVariant       = 11;
-   tkArray         = 12;
-   tkRecord        = 13;
-   tkInterface     = 14;
-   tkClass         = 15;
-   tkObject        = 16;
-   tkWChar         = 17;
-   tkBool          = 18;
-   tkInt64         = 19;
-   tkQWord         = 20;
-   tkDynArray      = 21;
+   tkUnknown        = 0;
+   tkInteger        = 1;
+   tkChar           = 2;
+   tkEnumeration    = 3;
+   tkFloat          = 4;
+   tkSet            = 5;
+   tkMethod         = 6;
+   tkSString        = 7;
+   tkString         = tkSString;
+   tkLString        = 8;
+   tkAString        = 9;
+   tkWString        = 10;
+   tkVariant        = 11;
+   tkArray          = 12;
+   tkRecord         = 13;
+   tkInterface      = 14;
+   tkClass          = 15;
+   tkObject         = 16;
+   tkWChar          = 17;
+   tkBool           = 18;
+   tkInt64          = 19;
+   tkQWord          = 20;
+   tkDynArray       = 21;
    tkInterfaceCorba = 22;
-   tkProcVar       = 23;
-   tkUString       = 24;
-   tkHelper        = 26;
+   tkProcVar        = 23;
+   tkUString        = 24;
+   tkHelper         = 26;
+   tkFile           = 27;
+   tkClassRef       = 28;
+   tkPointer        = 29;
 
   // all potentially managed types
   tkManagedTypes   = [tkAstring,tkWstring,tkUstring,tkArray,

rtl/objpas/typinfo.pp

@@ -43,7 +43,7 @@ unit typinfo;
                    tkWString,tkVariant,tkArray,tkRecord,tkInterface,
                    tkClass,tkObject,tkWChar,tkBool,tkInt64,tkQWord,
                    tkDynArray,tkInterfaceRaw,tkProcVar,tkUString,tkUChar,
-                   tkHelper);
+                   tkHelper,tkFile,tkClassRef,tkPointer);
 
        TOrdType  = (otSByte,otUByte,otSWord,otUWord,otSLong,otULong);
 
@@ -202,6 +202,14 @@ unit typinfo;
               elType     : PPTypeInfo;
               DynUnitName: ShortStringBase
               );
+            tkClassRef:
+              (
+              InstanceType: PTypeInfo;
+              );
+            tkPointer:
+              (
+              RefType: PTypeInfo;
+              );
       end;
 
       // unsed, just for completeness

tests/test/trtti1.pp

@@ -6,13 +6,13 @@ Program trtti1;
 Uses
   Typinfo;
 
-Const TypeNames : Array [TTYpeKind] of string[15] =
+Const TypeNames : Array [TTypeKind] of string[15] =
                     ('Unknown','Integer','Char','Enumeration',
                      'Float','Set','Method','ShortString','LongString',
                      'AnsiString','WideString','Variant','Array','Record',
                      'Interface','Class','Object','WideChar','Bool','Int64','QWord',
                      'DynamicArray','RawInterface','ProcVar','UnicodeString','UnicodeChar',
-					 'Helper');
+                     'Helper','File','ClassRef','Pointer');
 
 Const OrdinalTypes = [tkInteger,tkChar,tkENumeration,tkbool];
 

tests/test/trtti6.pp

@@ -0,0 +1,46 @@
+program ptr_classref_test;
+
+{$mode objfpc}{$H+}
+
+uses
+  typinfo;
+
+type
+  {$M+}
+  TReferredClass = class
+  end;
+  {$M-}
+
+  TClassRef = class of TReferredClass;
+
+  {$M+}
+  TClass = class
+  private
+    FRef: TClassRef;
+  published
+    property Ref: TClassRef read FRef;
+  end;
+  {$M-}
+
+  TPtr = ^UnicodeString;
+
+var
+  Info: PTypeInfo;
+  Data: PTypeData;
+begin
+  // first check TClass.Ref property
+  Info := GetPropInfo(PTypeInfo(TClass.ClassInfo), 'Ref')^.PropType;
+  if Info^.Kind <> tkClassRef then
+    halt(1);
+  Data := GetTypeData(Info);
+  if Data^.RefType <> TReferredClass.ClassInfo then
+    halt(2);
+  // next check TRefferedClass.P method
+  Info := TypeInfo(TPtr);
+  if Info^.Kind <> tkPointer then
+    halt(3);
+  Data := GetTypeData(Info);
+  if Data^.RefType <> TypeInfo(UnicodeString) then
+    halt(4);
+end.
+