paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-04-26 14:13:46 +02:00
Code Issues Packages Projects Releases Wiki Activity

JitClasses: Fix property parsing / Allow "class" access via type in library

Browse Source
This commit is contained in:
Martin 2021-09-22 21:55:59 +02:00
parent 5ad938c07a
commit d948ad6717
4 changed files with 104 additions and 10 deletions

51
components/jitclasses/jitclass.pas
View File

@ -221,7 +221,9 @@ type
FJitPVmt: PVmt;
FRefCountedJitPVmt: TRefCountedJitClassReference;
FAncestorClass: TClass;
FAncestorClassName: String;
FAncestorJitClass: TJitClassCreator;
FAncestorJitType: TJitTypeClassBase;
FClassName: String;
FTypeLibrary: TJitTypeLibrary;
@ -234,7 +236,6 @@ type
procedure DoTypeLibFreed(Sender: TObject);
procedure DoAnchesterJitClassFreed(Sender: TObject);
function GetJitClass: TClass;
procedure SetClassName(AValue: String);
procedure SetClassUnit(AValue: String);
procedure SetTypeLibrary(AValue: TJitTypeLibrary);
@ -244,6 +245,7 @@ type
class procedure FreeJitClass(AJitPVmt: PVmt);
function GetLockReferenceObj: TRefCountedJitReference; override;
function GetTypeInfo: PTypeInfo; override;
function GetJitClass: TClass; override;
procedure CreateJitClass;
procedure CreateJitClassPreCheck;
@ -257,8 +259,10 @@ type
procedure CreateJitPropsPrepare;
procedure CreateJitPropsFinish;
public
constructor Create(AnAncestorClass: TClass; AClassName: String; AClassUnit: String);
constructor Create(AnAncestorJitClass: TJitClassCreator; AClassName: String; AClassUnit: String);
constructor Create(AnAncestorClass: TClass; AClassName: String; AClassUnit: String; ATypeLibrary: TJitTypeLibrary = nil);
constructor Create(AnAncestorClassName, AClassName: String; AClassUnit: String; ATypeLibrary: TJitTypeLibrary = nil);
constructor Create(AnAncestorJitClass: TJitClassCreator; AClassName: String; AClassUnit: String; ATypeLibrary: TJitTypeLibrary = nil);
constructor Create(AnAncestorJitType: TJitType; AClassName: String; AClassUnit: String; ATypeLibrary: TJitTypeLibrary = nil);
destructor Destroy; override;
(* UpdateJitClass
@ -862,7 +866,7 @@ begin
NewDefault:= '';
NewNoDefault := False;
NewIsStored := True;
tk := Parser.CurrentKind;
tk := Parser.Next;
if tk = ptIdent then begin // stopped at read or write
while tk in [ptIdent, ptDot] do begin
if (tk = ptIdent) then begin
@ -1125,7 +1129,23 @@ end;
procedure TJitClassCreator.CreateJitClass;
var
HasJitAnchestor: Boolean;
at: TJitType;
begin
if (FAncestorClass = nil) and (FAncestorJitClass = nil) then begin
if (FAncestorJitType = nil) and (FAncestorClassName <> '') and (FTypeLibrary <> nil) then begin
at := FTypeLibrary.FindType(FAncestorClassName, FClassUnit);
if not (at is TJitTypeClassBase) then
raise Exception.Create('Incorrect type for anchestor');
FAncestorJitType := TJitTypeJitClass(at);
end;
if FAncestorJitType <> nil then begin;
if (FAncestorJitType is TJitTypeJitClass) then
FAncestorJitClass := TJitClassCreator(TJitTypeJitClass(FAncestorJitType).JitClassCreator)
else
FAncestorClass := FAncestorJitType.JitClass;
end;
end;
CreateJitClassPreCheck;
FFlags := FFlags - [ccfModifiedMethods, ccfModifiedProps, ccfModifiedClassName];
@ -1460,7 +1480,7 @@ begin
end;
constructor TJitClassCreator.Create(AnAncestorClass: TClass;
AClassName: String; AClassUnit: String);
AClassName: String; AClassUnit: String; ATypeLibrary: TJitTypeLibrary);
begin
FJitPVmt := nil;
FJitMethods := TJitMethodList.Create(Self);
@ -1471,17 +1491,34 @@ begin
FAncestorClass := AnAncestorClass;
FClassName := AClassName;
FClassUnit := AClassUnit;
TypeLibrary := ATypeLibrary;
end;
constructor TJitClassCreator.Create(AnAncestorClassName, AClassName: String;
AClassUnit: String; ATypeLibrary: TJitTypeLibrary);
begin
Create(TClass(nil), AClassName, AClassUnit, ATypeLibrary);
FAncestorClassName := AnAncestorClassName;
end;
constructor TJitClassCreator.Create(AnAncestorJitClass: TJitClassCreator;
AClassName: String; AClassUnit: String);
AClassName: String; AClassUnit: String; ATypeLibrary: TJitTypeLibrary);
begin
Create(TClass(nil), AClassName, AClassUnit);
Create(TClass(nil), AClassName, AClassUnit, ATypeLibrary);
FAncestorJitClass := AnAncestorJitClass;
if FAncestorJitClass <> nil then
FAncestorJitClass.AddFreeNotification(@DoAnchesterJitClassFreed);
end;
constructor TJitClassCreator.Create(AnAncestorJitType: TJitType;
AClassName: String; AClassUnit: String; ATypeLibrary: TJitTypeLibrary);
begin
if not (AnAncestorJitType is TJitTypeClassBase) then
raise Exception.Create('Incorrect type for anchestor');
Create(TClass(nil), AClassName, AClassUnit, ATypeLibrary);
FAncestorJitType := TJitTypeClassBase(AnAncestorJitType);
end;
destructor TJitClassCreator.Destroy;
begin
inherited Destroy;

29
components/jitclasses/jittypes.pas
View File

@ -163,6 +163,7 @@ type
protected
FClassUnit: String;
function GetTypeInfo: PTypeInfo; virtual; abstract;
function GetJitClass: TClass; virtual; abstract;
public
property TypeInfo: PTypeInfo read GetTypeInfo;
property ClassUnit: String read FClassUnit; // write SetClassUnit;
@ -304,21 +305,29 @@ type
end;
TJitTypeClassBase = class abstract (TJitType)
protected
function GetJitClass: TClass; virtual; abstract;
public
property JitClass: TClass read GetJitClass;
end;
{ TJitTypeClass }
TJitTypeClass = class(TJitType)
TJitTypeClass = class(TJitTypeClassBase)
private
FClass: TClass;
protected
function GetTypeInfo: PTypeInfo; override;
function GetJitClass: TClass; override;
public
constructor Create(ATypeName: String; AClass: TClass; ATypeLibrary: TJitTypeLibrary = nil);
end;
{ TJitTypeJitClass }
TJitTypeJitClass = class(TJitType)
TJitTypeJitClass = class(TJitTypeClassBase)
private
FJitClassCreator: TJitClassCreatorBase;
FOwnJitCreator: Boolean;
@ -326,6 +335,7 @@ type
protected
function GetTypeInfo: PTypeInfo; override;
function GetJitClass: TClass; override;
function GetLockReferenceInc: TRefCountedJitReference; override;
function IsConstTypeInfo: Boolean; override;
public
@ -333,6 +343,7 @@ type
ATypeLibrary: TJitTypeLibrary = nil; ATakeOwnerShip: Boolean = False);
destructor Destroy; override;
property JitClassCreator: TJitClassCreatorBase read FJitClassCreator;
property OwnJitCreator: Boolean read FOwnJitCreator write FOwnJitCreator;
end;
@ -457,6 +468,7 @@ end;
constructor JitTypeParserException.Create(APos: Integer; const AToken,
msg: string);
begin
inherited Create(msg);
FErrorPos := APos;
FErrorToken := AToken;
end;
@ -2182,6 +2194,11 @@ begin
Result := FClass.ClassInfo;
end;
function TJitTypeClass.GetJitClass: TClass;
begin
Result := FClass;
end;
constructor TJitTypeClass.Create(ATypeName: String; AClass: TClass;
ATypeLibrary: TJitTypeLibrary);
begin
@ -2204,6 +2221,14 @@ begin
Result := nil;
end;
function TJitTypeJitClass.GetJitClass: TClass;
begin
if FJitClassCreator <> nil then
Result := FJitClassCreator.GetJitClass
else
Result := nil;
end;
function TJitTypeJitClass.GetLockReferenceInc: TRefCountedJitReference;
begin
if FJitClassCreator <> nil then

1
components/jitclasses/test/JitClassesTest.lpi
View File

@ -8,7 +8,6 @@
<Title Value="JitClassesTest"/>
<ResourceType Value="res"/>
<UseXPManifest Value="True"/>
<Icon Value="0"/>
</General>
<BuildModes>
<Item Name="Default (no checks, O-)" Default="True"/>

33
components/jitclasses/test/testjitclass.pas
View File

@ -709,6 +709,7 @@ end;
procedure TJitClassTest.TestJitParseClass;
var
JitCreator: TJitClassCreator;
JitTypeLib: TJitTypeLibrary;
begin
JitCreator := TJitClassCreator.Create(TMyClass, 'TJitTestClass', 'foo');
JitCreator.JitProperties.ParseFromClassDeclaration(
@ -728,6 +729,38 @@ begin
AssertTrue(JitCreator.JitProperties.IndexOf('TestFoo') < 0);
JitCreator.Free;
JitCreator := TJitClassCreator.Create(TMyClass, 'TJitTestClass', 'foo');
JitCreator.JitProperties.ParseFromClassDeclaration(
' property TestProp1: int64 read foo write foo;' +
' property TestProp2: int64 read foo;' +
'a: word;' +
'function foo: boolean;' +
' property TestProp3: int64 read foo;'
);
AssertTrue(JitCreator.JitProperties.IndexOf('TestProp1') >= 0);
AssertTrue(JitCreator.JitProperties.IndexOf('TestProp2') >= 0);
AssertTrue(JitCreator.JitProperties.IndexOf('TestProp3') >= 0);
JitCreator.Free;
JitTypeLib := TJitTypeLibrary.Create;
JitTypeLib.AddAlias('string', 'ansistring');
JitCreator := TJitClassCreator.Create(TMyClass, 'TJitTestClass', 'foo', JitTypeLib);
JitCreator.JitProperties.ParseFromClassDeclaration(
' property TestProp1: string read foo write foo;' +
' property TestProp2: ansistring read foo;'
);
AssertTrue(JitCreator.JitProperties.IndexOf('TestProp1') >= 0);
AssertTrue(JitCreator.JitProperties.IndexOf('TestProp2') >= 0);
JitCreator.Free;
JitTypeLib.Free;
end;
procedure TJitClassTest.TestJitPropCircularClassDef;