Skip to content

Commit

Permalink
deep refactoring of FPC RTTI access
Browse files Browse the repository at this point in the history 
- with several optimization and fixes to be in synch with Delphi's
  • Loading branch information
Arnaud Bouchez committed Feb 6, 2018
1 parent 300db3d commit d9fe9a5
Show file tree
Hide file tree
Showing 2 changed files with 115 additions and 82 deletions.
195 changes: 114 additions & 81 deletions SQLite3/mORMot.pas
View file
Expand Up @@ -2880,49 +2880,33 @@ TTypeInfo = record
TPropInfo = packed record TPropInfo = packed record
private private
{$endif} {$endif}
{$ifdef USETYPEINFO}
function RetrieveFieldSize: integer;
{$endif}
function GetOrdProp(Instance: TObject): PtrInt; function GetOrdProp(Instance: TObject): PtrInt;
{$ifdef USETYPEINFO}{$ifdef HASINLINE}inline;{$endif}{$endif} {$ifdef USETYPEINFO}{$ifdef HASINLINE}inline;{$endif}{$endif}
function GetObjProp(Instance: TObject): TObject; function GetObjProp(Instance: TObject): TObject;
{$ifdef HASINLINE}inline;{$endif}
procedure SetOrdProp(Instance: TObject; Value: PtrInt); procedure SetOrdProp(Instance: TObject; Value: PtrInt);
{$ifdef USETYPEINFO}{$ifdef HASINLINE}inline;{$endif}{$endif}
function GetInt64Prop(Instance: TObject): Int64; function GetInt64Prop(Instance: TObject): Int64;
{$ifdef USETYPEINFO}{$ifdef HASINLINE}inline;{$endif}{$endif}
procedure SetInt64Prop(Instance: TObject; const Value: Int64); procedure SetInt64Prop(Instance: TObject; const Value: Int64);
{$ifdef USETYPEINFO}{$ifdef HASINLINE}inline;{$endif}{$endif}
procedure GetLongStrProp(Instance: TObject; var Value: RawByteString); procedure GetLongStrProp(Instance: TObject; var Value: RawByteString);
{$ifdef USETYPEINFO}{$ifdef HASINLINE}inline;{$endif}{$endif}
procedure SetLongStrProp(Instance: TObject; const Value: RawByteString); procedure SetLongStrProp(Instance: TObject; const Value: RawByteString);
{$ifdef USETYPEINFO}{$ifdef HASINLINE}inline;{$endif}{$endif}
procedure CopyLongStrProp(Source,Dest: TObject); procedure CopyLongStrProp(Source,Dest: TObject);
{$ifdef USETYPEINFO}{$ifdef HASINLINE}inline;{$endif}{$endif}
procedure GetWideStrProp(Instance: TObject; var Value: WideString); procedure GetWideStrProp(Instance: TObject; var Value: WideString);
{$ifdef USETYPEINFO}{$ifdef HASINLINE}inline;{$endif}{$endif}
procedure SetWideStrProp(Instance: TObject; const Value: WideString); procedure SetWideStrProp(Instance: TObject; const Value: WideString);
{$ifdef USETYPEINFO}{$ifdef HASINLINE}inline;{$endif}{$endif}
{$ifdef HASVARUSTRING} {$ifdef HASVARUSTRING}
function GetUnicodeStrProp(Instance: TObject): UnicodeString; function GetUnicodeStrProp(Instance: TObject): UnicodeString;
{$ifdef USETYPEINFO}{$ifdef HASINLINE}inline;{$endif}{$endif}
procedure SetUnicodeStrProp(Instance: TObject; const Value: UnicodeString); procedure SetUnicodeStrProp(Instance: TObject; const Value: UnicodeString);
{$ifdef USETYPEINFO}{$ifdef HASINLINE}inline;{$endif}{$endif}
{$endif HASVARUSTRING} {$endif HASVARUSTRING}
function GetCurrencyProp(Instance: TObject): currency; function GetCurrencyProp(Instance: TObject): currency;
{$ifdef USETYPEINFO}{$ifdef HASINLINE}inline;{$endif}{$endif}
procedure SetCurrencyProp(Instance: TObject; const Value: Currency); procedure SetCurrencyProp(Instance: TObject; const Value: Currency);
{$ifdef HASINLINE}inline;{$endif}
function GetDoubleProp(Instance: TObject): double; function GetDoubleProp(Instance: TObject): double;
{$ifdef USETYPEINFO}{$ifdef HASINLINE}inline;{$endif}{$endif}
procedure SetDoubleProp(Instance: TObject; Value: Double); procedure SetDoubleProp(Instance: TObject; Value: Double);
{$ifdef HASINLINE}inline;{$endif}
function GetFloatProp(Instance: TObject): double; function GetFloatProp(Instance: TObject): double;
{$ifdef USETYPEINFO}{$ifdef HASINLINE}inline;{$endif}{$endif}
procedure SetFloatProp(Instance: TObject; Value: TSynExtended); procedure SetFloatProp(Instance: TObject; Value: TSynExtended);
{$ifdef USETYPEINFO}{$ifdef HASINLINE}inline;{$endif}{$endif}
{$ifndef NOVARIANTS} {$ifndef NOVARIANTS}
procedure GetVariantProp(Instance: TObject; var result: Variant); procedure GetVariantProp(Instance: TObject; var result: Variant);
{$ifdef USETYPEINFO}{$ifdef HASINLINE}inline;{$endif}{$endif}
procedure SetVariantProp(Instance: TObject; const Value: Variant); procedure SetVariantProp(Instance: TObject; const Value: Variant);
{$ifdef USETYPEINFO}{$ifdef HASINLINE}inline;{$endif}{$endif}
{$endif} {$endif}
public public
/// the type definition of this property /// the type definition of this property
Expand Down Expand Up @@ -29024,6 +29008,13 @@ procedure TPropInfo.SetLongStrValue(Instance: TObject; const Value: RawUTF8);
end; end;
end; end;


procedure TPropInfo.CopyLongStrProp(Source,Dest: TObject);
var tmp: RawByteString;
begin
GetLongStrProp(Source,tmp);
SetLongStrProp(Dest,tmp);
end;

{$ifndef NOVARIANTS} {$ifndef NOVARIANTS}
procedure TPropInfo.SetFromVariant(Instance: TObject; const Value: variant); procedure TPropInfo.SetFromVariant(Instance: TObject; const Value: variant);
var i: integer; var i: integer;
Expand Down Expand Up @@ -29456,30 +29447,6 @@ function TPropInfo.IsBlob: boolean;
result := (@self<>nil) and (TypeInfo=system.TypeInfo(TSQLRawBlob)); result := (@self<>nil) and (TypeInfo=system.TypeInfo(TSQLRawBlob));
end; end;


function TPropInfo.IsStored(Instance: TObject): boolean;
type // function(Instance: TObject) trick does not work with CPU64 :(
TStoredProc = function: Boolean of object;
var Call: TMethod;
begin
{$ifdef FPC} // extracted from IsStoredProp() function in typinfo.pp
result := ((PropProcs shr 4) and 3=ptconst) and LongBool(StoredProc);
{$else} // Delphi version
if (StoredProc and (not PtrInt($ff)))=0 then
result := boolean(StoredProc) else
if Instance=nil then
// field or method without Instance specified -> assume "stored true"
result := true else
if PropWrap(StoredProc).Kind=$ff then
result := PBoolean(PtrInt(Instance)+StoredProc and $00FFFFFF)^ else begin
if PropWrap(StoredProc).Kind=$fe then
Call.Code := pointer((PPtrUInt(PPtrInt(Instance)^+SmallInt(StoredProc))^)) else
Call.Code := pointer(StoredProc);
Call.Data := Instance;
result := TStoredProc(Call);
end;
{$endif}
end;

function TPropInfo.GetterIsField: boolean; function TPropInfo.GetterIsField: boolean;
begin begin
{$ifdef FPC} {$ifdef FPC}
Expand Down Expand Up @@ -29563,9 +29530,31 @@ function TPropInfo.Next: PPropInfo;


{$ifdef USETYPEINFO} {$ifdef USETYPEINFO}


function TPropInfo.GetOrdProp(Instance: TObject): PtrInt; function TPropInfo.IsStored(Instance: TObject): boolean;
begin begin
result := TypInfo.GetOrdProp(Instance,@self); result := TypInfo.IsStoredProp(Instance,@self);
end;

function TPropInfo.RetrieveFieldSize: integer;
begin
case PropType^.Kind of
tkInteger,tkEnumeration,tkSet,tkChar,tkWChar{$ifdef FPC},tkBool{$endif}:
case PropType^.OrdType of
otSByte, otUByte: result := 1;
otSWord, otUWord: result := 2;
else result := 4;
end;
tkFloat:
case PropType^.FloatType of
ftSingle: result := 4;
ftExtended: result := 10;
else result := 8;
end;
tkLString,tkWString,tkClass,tkInterface,tkDynArray: result := SizeOf(pointer);
tkInt64{$ifdef FPC},tkQWord{$endif}: result := 8;
tkVariant: result := SizeOf(variant);
else result := 0;
end;
end; end;


function TPropInfo.GetObjProp(Instance: TObject): TObject; function TPropInfo.GetObjProp(Instance: TObject): TObject;
Expand All @@ -29575,13 +29564,28 @@ function TPropInfo.GetObjProp(Instance: TObject): TObject;
result := pointer(TypInfo.GetOrdProp(Instance,@self)); result := pointer(TypInfo.GetOrdProp(Instance,@self));
end; end;


function TPropInfo.GetOrdProp(Instance: TObject): PtrInt;
begin
result := TypInfo.GetOrdProp(Instance,@self);
end;

procedure TPropInfo.SetOrdProp(Instance: TObject; Value: PtrInt); procedure TPropInfo.SetOrdProp(Instance: TObject; Value: PtrInt);
var P: pointer;
begin begin
if {$ifndef FPC}(PropType^.Kind=tkClass) and {$endif} if SetterIsField then
(SetProc=0) and GetterIsField then P := SetterAddr(Instance) else
// allow setting a class instance even if there is no "write ..." attribute if (SetProc=0) and GetterIsField then
PPtrInt(GetterAddr(Instance))^ := Value else P := GetterAddr(Instance) else begin
TypInfo.SetOrdProp(Instance,@self,Value); TypInfo.SetOrdProp(Instance,@self,Value);
exit;
end;
if PropType^.Kind=tkClass then
PPTrInt(P)^ := Value else
case PropType^.OrdType of
otUByte,otSByte: PByte(P)^ := Value;
otUWord,otSWord: PWord(P)^ := Value;
otULong,otSLong: PCardinal(P)^ := Value;
end;
end; end;


function TPropInfo.GetInt64Prop(Instance: TObject): Int64; function TPropInfo.GetInt64Prop(Instance: TObject): Int64;
Expand All @@ -29602,29 +29606,26 @@ procedure TPropInfo.SetInt64Prop(Instance: TObject; const Value: Int64);


procedure TPropInfo.GetLongStrProp(Instance: TObject; var Value: RawByteString); procedure TPropInfo.GetLongStrProp(Instance: TObject; var Value: RawByteString);
begin begin
{$ifdef UNICODE} if GetterIsField then
Value := TypInfo.GetAnsiStrProp(Instance,@self); Value := PRawByteString(GetterAddr(Instance))^ else
{$else} {$ifdef UNICODE}
Value := TypInfo.GetStrProp(Instance,@self); Value := TypInfo.GetAnsiStrProp(Instance,@self);
{$endif} {$else}
Value := TypInfo.GetStrProp(Instance,@self);
{$endif}
end; end;


procedure TPropInfo.SetLongStrProp(Instance: TObject; const Value: RawByteString); procedure TPropInfo.SetLongStrProp(Instance: TObject; const Value: RawByteString);
begin begin
{$ifdef UNICODE} if SetterIsField then
TypInfo.SetAnsiStrProp(Instance,@self,Value); PRawByteString(SetterAddr(Instance))^ := Value else
{$else} if (SetProc=0) and GetterIsField then
TypInfo.SetStrProp(Instance,@self,Value); PRawByteString(GetterAddr(Instance))^ := Value else
{$endif} {$ifdef UNICODE}
end; TypInfo.SetAnsiStrProp(Instance,@self,Value);

{$else}
procedure TPropInfo.CopyLongStrProp(Source,Dest: TObject); TypInfo.SetStrProp(Instance,@self,Value);
begin {$endif}
{$ifdef UNICODE}
TypInfo.SetAnsiStrProp(Dest,@self,TypInfo.GetAnsiStrProp(Source,@self));
{$else}
SetStrProp(Dest,@self,TypInfo.GetStrProp(Source,@self));
{$endif}
end; end;


procedure TPropInfo.GetWideStrProp(Instance: TObject; var Value: WideString); procedure TPropInfo.GetWideStrProp(Instance: TObject; var Value: WideString);
Expand All @@ -29645,7 +29646,11 @@ function TPropInfo.GetUnicodeStrProp(Instance: TObject): UnicodeString;


procedure TPropInfo.SetUnicodeStrProp(Instance: TObject; const Value: UnicodeString); procedure TPropInfo.SetUnicodeStrProp(Instance: TObject; const Value: UnicodeString);
begin begin
TypInfo.SetUnicodeStrProp(Instance,@self,Value); if SetterIsField then
PUnicodeString(SetterAddr(Instance))^ := Value else
if (SetProc=0) and GetterIsField then
PUnicodeString(GetterAddr(Instance))^ := Value else
TypInfo.SetUnicodeStrProp(Instance,@self,Value);
end; end;
{$endif HASVARUSTRING} {$endif HASVARUSTRING}


Expand Down Expand Up @@ -29687,14 +29692,29 @@ function TPropInfo.GetFloatProp(Instance: TObject): double;
end; end;


procedure TPropInfo.SetFloatProp(Instance: TObject; Value: TSynExtended); procedure TPropInfo.SetFloatProp(Instance: TObject; Value: TSynExtended);
var P: pointer;
begin begin
TypInfo.SetFloatProp(Instance,@self,value); if SetterIsField then
P := SetterAddr(Instance) else
if (SetProc=0) and GetterIsField then
P := GetterAddr(Instance) else begin
TypInfo.SetFloatProp(Instance,@self,value);
exit;
end;
case PropType^.FloatType of
ftSingle: PSingle(P)^ := Value;
ftDoub: PDouble(P)^ := Value;
ftExtended: PExtended(P)^ := Value;
ftCurr: PCurrency(P)^ := Value;
end;
end; end;


{$ifndef NOVARIANTS} {$ifndef NOVARIANTS}
procedure TPropInfo.GetVariantProp(Instance: TObject; var result: Variant); procedure TPropInfo.GetVariantProp(Instance: TObject; var result: Variant);
begin begin
result := TypInfo.GetVariantProp(Instance,@self); if GetterIsField then
SetVariantByValue(PVariant(GetterAddr(Instance))^,result) else
result := TypInfo.GetVariantProp(Instance,@self);
end; end;


procedure TPropInfo.SetVariantProp(Instance: TObject; const Value: Variant); procedure TPropInfo.SetVariantProp(Instance: TObject; const Value: Variant);
Expand All @@ -29705,7 +29725,27 @@ procedure TPropInfo.SetVariantProp(Instance: TObject; const Value: Variant);
end; end;
{$endif} {$endif}


{$else USETYPEINFO} {$else USETYPEINFO} // Delphi-only version below

function TPropInfo.IsStored(Instance: TObject): boolean;
type // function(Instance: TObject) trick does not work with CPU64 :(
TStoredProc = function: Boolean of object;
var Call: TMethod;
begin
if (StoredProc and (not PtrInt($ff)))=0 then
result := boolean(StoredProc) else
if Instance=nil then
// field or method without Instance specified -> assume "stored true"
result := true else
if PropWrap(StoredProc).Kind=$ff then
result := PBoolean(PtrInt(Instance)+StoredProc and $00FFFFFF)^ else begin
if PropWrap(StoredProc).Kind=$fe then
Call.Code := pointer((PPtrUInt(PPtrInt(Instance)^+SmallInt(StoredProc))^)) else
Call.Code := pointer(StoredProc);
Call.Data := Instance;
result := TStoredProc(Call);
end;
end;


function TPropInfo.GetOrdProp(Instance: TObject): PtrInt; function TPropInfo.GetOrdProp(Instance: TObject): PtrInt;
type // function(Instance: TObject) trick does not work with CPU64 :( type // function(Instance: TObject) trick does not work with CPU64 :(
Expand Down Expand Up @@ -29733,7 +29773,7 @@ function TPropInfo.GetOrdProp(Instance: TObject): PtrInt;
P := @value; P := @value;
end; end;
with TypeInfo^ do with TypeInfo^ do
if Kind=tkClass then if Kind in [tkClass,tkInterface,tkDynArray] then
result := PPtrInt(P)^ else result := PPtrInt(P)^ else
case TOrdType(PByte(AlignToPtr(@Name[ord(Name[0])+1]))^) of // OrdType of case TOrdType(PByte(AlignToPtr(@Name[ord(Name[0])+1]))^) of // OrdType of
otSByte: result := PShortInt(P)^; otSByte: result := PShortInt(P)^;
Expand Down Expand Up @@ -29769,7 +29809,7 @@ procedure TPropInfo.SetOrdProp(Instance: TObject; Value: PtrInt);
exit; exit;
end; end;
with PropType^^ do with PropType^^ do
if Kind=tkClass then if Kind in [tkClass,tkInterface,tkDynArray] then
PPtrInt(P)^ := Value else PPtrInt(P)^ := Value else
case TOrdType(PByte(AlignToPtr(@Name[ord(Name[0])+1]))^) of // OrdType of case TOrdType(PByte(AlignToPtr(@Name[ord(Name[0])+1]))^) of // OrdType of
otSByte: PShortInt(P)^ := Value; otSByte: PShortInt(P)^ := Value;
Expand Down Expand Up @@ -29877,13 +29917,6 @@ procedure TPropInfo.SetLongStrProp(Instance: TObject; const Value: RawByteString
end; end;
end; end;


procedure TPropInfo.CopyLongStrProp(Source,Dest: TObject);
var tmp: RawByteString;
begin
GetLongStrProp(Source,tmp);
SetLongStrProp(Dest,tmp);
end;

procedure TPropInfo.GetWideStrProp(Instance: TObject; var Value: WideString); procedure TPropInfo.GetWideStrProp(Instance: TObject; var Value: WideString);
type type
TUStringGetProc = function: WideString of object; TUStringGetProc = function: WideString of object;
Expand Down
2 changes: 1 addition & 1 deletion SynopseCommit.inc
View file
@@ -1 +1 @@
'1.18.4249' '1.18.4250'

0 comments on commit d9fe9a5

Please sign in to comment.