paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-08 08:28:09 +02:00
Code Issues Packages Projects Releases Wiki Activity

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

Browse Source 
git-svn-id: trunk@24421 -
This commit is contained in:
paul 2013-05-04 12:47:05 +00:00
parent 930b76e8fb
commit d90445e5ee
8 changed files with 136 additions and 55 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitattributes vendored
View File

@ -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

18
compiler/ncgrtti.pas
View File

@ -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;

2
compiler/symconst.pas
View File

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

55
rtl/inc/system.inc
View File

@ -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,

55
rtl/java/jsystem.inc
View File

@ -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,

10
rtl/objpas/typinfo.pp
View File

@ -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

4
tests/test/trtti1.pp
View File

@ -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];

46
tests/test/trtti6.pp Normal file
View File

@ -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.