From d90445e5ee1b846b92a0ed8f50075022237de90c Mon Sep 17 00:00:00 2001 From: paul Date: Sat, 4 May 2013 12:47:05 +0000 Subject: [PATCH] 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 | 1 + compiler/ncgrtti.pas | 18 ++++++++++++++ compiler/symconst.pas | 2 ++ rtl/inc/system.inc | 55 +++++++++++++++++++++++-------------------- rtl/java/jsystem.inc | 55 +++++++++++++++++++++++-------------------- rtl/objpas/typinfo.pp | 10 +++++++- tests/test/trtti1.pp | 4 ++-- tests/test/trtti6.pp | 46 ++++++++++++++++++++++++++++++++++++ 8 files changed, 136 insertions(+), 55 deletions(-) create mode 100644 tests/test/trtti6.pp diff --git a/.gitattributes b/.gitattributes index 1a0ebaff7a..ee5425f010 100644 --- a/.gitattributes +++ b/.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 diff --git a/compiler/ncgrtti.pas b/compiler/ncgrtti.pas index e5a67c3a84..f4ed1c5d19 100644 --- a/compiler/ncgrtti.pas +++ b/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; diff --git a/compiler/symconst.pas b/compiler/symconst.pas index 72f942ada4..f7995fb64e 100644 --- a/compiler/symconst.pas +++ b/compiler/symconst.pas @@ -66,6 +66,8 @@ const tkUChar = 25; tkHelper = 26; tkFile = 27; + tkClassRef = 28; + tkPointer = 29; otSByte = 0; otUByte = 1; diff --git a/rtl/inc/system.inc b/rtl/inc/system.inc index 1a94d4cf08..f10b72eae0 100644 --- a/rtl/inc/system.inc +++ b/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, diff --git a/rtl/java/jsystem.inc b/rtl/java/jsystem.inc index 97c8019a41..b8c2adca36 100644 --- a/rtl/java/jsystem.inc +++ b/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, diff --git a/rtl/objpas/typinfo.pp b/rtl/objpas/typinfo.pp index f9f311ec65..3a26b9f942 100644 --- a/rtl/objpas/typinfo.pp +++ b/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 diff --git a/tests/test/trtti1.pp b/tests/test/trtti1.pp index c8ef202cb0..106129c608 100644 --- a/tests/test/trtti1.pp +++ b/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]; diff --git a/tests/test/trtti6.pp b/tests/test/trtti6.pp new file mode 100644 index 0000000000..221fb368d2 --- /dev/null +++ b/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. +