administrator/blaise
1
0
Fork 0
Code Issues Pull requests Actions Packages Projects Releases Wiki Activity

Implement Pascal property declarations with field- and method-backed access

Browse source 
Adds full property support to class types: field-backed reads/writes redirect
at semantic analysis time; method-backed reads emit a getter call in QBE IR.
Read-only enforcement raises ESemanticError on write attempts. Soft-keyword
detection keeps 'property' out of TTokenKind. 14 new tests, 527 total.
This commit is contained in:
Graeme Geldenhuys 2026-04-21 23:15:15 +01:00
parent b34bfc574d
commit 80c2b21d6c
7 changed files with 636 additions and 19 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

20
compiler/src/main/pascal/uAST.pas
View file

@ -47,9 +47,11 @@ type
public
RecordName: string;
FieldName: string;
FieldInfo: TFieldInfo; { set by uSemantic — nil for constructor calls }
IsConstructorCall: Boolean; { set by uSemantic — TypeName.Create }
IsClassAccess: Boolean; { set by uSemantic — pointer deref needed }
FieldInfo: TFieldInfo; { set by uSemantic — nil for constructor calls }
IsConstructorCall: Boolean; { set by uSemantic — TypeName.Create }
IsClassAccess: Boolean; { set by uSemantic — pointer deref needed }
PropRead: TPropertyInfo; { non-nil if this is a method-backed property read }
PropOwnerType: string; { class type name for method-backed property calls }
end;
TIsExpr = class(TASTExpr)
@ -257,12 +259,22 @@ type
destructor Destroy; override;
end;
{ One property declaration inside a class body. }
TPropertyDecl = class(TASTNode)
public
Name: string; { property name }
TypeName: string; { declared type }
ReadName: string; { backing field or getter method; '' = no read accessor }
WriteName: string; { backing field or setter method; '' = read-only }
end;
TClassTypeDef = class(TASTTypeDef)
public
ParentName: string;
ImplementsNames: TStringList; { owned — names of implemented interfaces }
Fields: TObjectList; { owned TFieldDecl }
Methods: TObjectList; { owned TMethodDecl }
Properties: TObjectList; { owned TPropertyDecl }
constructor Create;
destructor Destroy; override;
end;
@ -597,10 +609,12 @@ begin
ImplementsNames := TStringList.Create;
Fields := TObjectList.Create(True);
Methods := TObjectList.Create(True);
Properties := TObjectList.Create(True);
end;
destructor TClassTypeDef.Destroy;
begin
Properties.Free;
Methods.Free;
Fields.Free;
ImplementsNames.Free;

14
compiler/src/main/pascal/uCodeGenQBE.pas
View file

@ -1407,7 +1407,19 @@ begin
{ Store vtable pointer at offset 0 if this class has virtual methods }
if TRecordTypeDesc(FldAccess.ResolvedType).HasVTable then
EmitLine(Format(' storel $vtable_%s, %s',
[FldAccess.ResolvedType.Name, T]));
[QBEMangle(FldAccess.ResolvedType.Name), T]));
Result := T;
end
else if FldAccess.PropRead <> nil then
begin
{ Method-backed property read: load Self pointer and call getter }
L := AllocTemp;
EmitLine(Format(' %s =l loadl %%_var_%s', [L, FldAccess.RecordName]));
T := AllocTemp;
QType := QbeTypeOf(FldAccess.PropRead.TypeDesc);
EmitLine(Format(' %s =%s call $%s_%s(l %s)',
[T, QType, QBEMangle(FldAccess.PropOwnerType),
FldAccess.PropRead.ReadMethod, L]));
Result := T;
end
else if FldAccess.IsClassAccess then

60
compiler/src/main/pascal/uParser.pas
View file

@ -59,6 +59,7 @@ type
function ParseClassDef: TClassTypeDef;
function ParseInterfaceDef: TInterfaceTypeDef;
procedure ParseFieldDecl(AFields: TObjectList);
function ParsePropertyDecl: TPropertyDecl;
function ParseMethodDecl(IsFunction: Boolean): TMethodDecl;
procedure ParseParamList(AParams: TObjectList);
procedure ParseStandaloneDecl(ABlock: TBlock);
@ -377,15 +378,19 @@ begin
end;
Expect(tkRParen);
end;
while Check(tkIdent) do
ParseFieldDecl(Result.Fields);
while Check(tkProcedure) or Check(tkFunction) do
begin
if Check(tkFunction) then
{ Class body: fields, properties, and methods in any order }
repeat
if Check(tkIdent) and SameText(FCurrent.Value, 'property') then
Result.Properties.Add(ParsePropertyDecl)
else if Check(tkIdent) then
ParseFieldDecl(Result.Fields)
else if Check(tkFunction) then
Result.Methods.Add(ParseMethodDecl(True))
else if Check(tkProcedure) then
Result.Methods.Add(ParseMethodDecl(False))
else
Result.Methods.Add(ParseMethodDecl(False));
end;
Break;
until False;
Expect(tkEnd);
except
Result.Free;
@ -545,6 +550,47 @@ begin
ABlock.ProcDecls.Add(MD);
end;
function TParser.ParsePropertyDecl: TPropertyDecl;
begin
Result := TPropertyDecl.Create;
try
Result.Line := FCurrent.Line;
Result.Col := FCurrent.Col;
Advance; { consume 'property' identifier }
if not Check(tkIdent) then
raise EParseError.CreateFmt('Expected property name at line %d col %d',
[FCurrent.Line, FCurrent.Col]);
Result.Name := FCurrent.Value;
Advance;
Expect(tkColon);
Result.TypeName := ParseTypeName;
{ Optional: read Accessor }
if Check(tkIdent) and SameText(FCurrent.Value, 'read') then
begin
Advance;
if not Check(tkIdent) then
raise EParseError.CreateFmt('Expected read accessor name at line %d col %d',
[FCurrent.Line, FCurrent.Col]);
Result.ReadName := FCurrent.Value;
Advance;
end;
{ Optional: write Accessor }
if Check(tkIdent) and SameText(FCurrent.Value, 'write') then
begin
Advance;
if not Check(tkIdent) then
raise EParseError.CreateFmt('Expected write accessor name at line %d col %d',
[FCurrent.Line, FCurrent.Col]);
Result.WriteName := FCurrent.Value;
Advance;
end;
Expect(tkSemicolon);
except
Result.Free;
raise;
end;
end;
procedure TParser.ParseFieldDecl(AFields: TObjectList);
var
Fld: TFieldDecl;

98
compiler/src/main/pascal/uSemantic.pas
View file

@ -580,6 +580,9 @@ var
IntfName: string;
IntfSym: TSymbol;
ITD: TInterfaceTypeDef;
PropDecl: TPropertyDecl;
PropInfo: TPropertyInfo;
PropType: TTypeDesc;
begin
{ Pass 1 — register all type symbols with empty descriptors.
This allows self-referential field types to resolve in pass 2. }
@ -761,6 +764,37 @@ begin
end;
end;
{ Resolve property declarations }
if TD.Def is TClassTypeDef then
for J := 0 to TClassTypeDef(TD.Def).Properties.Count - 1 do
begin
PropDecl := TPropertyDecl(TClassTypeDef(TD.Def).Properties[J]);
PropType := FTable.FindType(PropDecl.TypeName);
if PropType = nil then
SemanticError(
Format('Unknown type ''%s'' for property ''%s''',
[PropDecl.TypeName, PropDecl.Name]),
PropDecl.Line, PropDecl.Col);
PropInfo := TPropertyInfo.Create;
PropInfo.Name := PropDecl.Name;
PropInfo.TypeDesc := PropType;
if PropDecl.ReadName <> '' then
begin
if RT.FindField(PropDecl.ReadName) <> nil then
PropInfo.ReadField := PropDecl.ReadName
else
PropInfo.ReadMethod := PropDecl.ReadName;
end;
if PropDecl.WriteName <> '' then
begin
if RT.FindField(PropDecl.WriteName) <> nil then
PropInfo.WriteField := PropDecl.WriteName
else
PropInfo.WriteMethod := PropDecl.WriteName;
end;
RT.AddProperty(PropInfo);
end;
{ Verify class implements all methods of each declared interface }
if TD.Def is TClassTypeDef then
for L := 0 to TClassTypeDef(TD.Def).ImplementsNames.Count - 1 do
@ -1273,6 +1307,7 @@ var
RecSym: TSymbol;
RT: TRecordTypeDesc;
FldInfo: TFieldInfo;
PropInfo: TPropertyInfo;
ExprType: TTypeDesc;
begin
RecSym := FTable.Lookup(AAssign.RecordName);
@ -1294,10 +1329,33 @@ begin
RT := TRecordTypeDesc(RecSym.TypeDesc);
FldInfo := RT.FindField(AAssign.FieldName);
if FldInfo = nil then
SemanticError(
Format('Type ''%s'' has no field ''%s''',
[AAssign.RecordName, AAssign.FieldName]),
AAssign.Line, AAssign.Col);
begin
{ Check if this is a property write }
PropInfo := RT.FindProperty(AAssign.FieldName);
if PropInfo <> nil then
begin
if PropInfo.WriteField <> '' then
begin
{ Field-backed write: redirect to the backing field }
AAssign.FieldName := PropInfo.WriteField;
FldInfo := RT.FindField(PropInfo.WriteField);
end
else if PropInfo.WriteMethod <> '' then
SemanticError(
Format('Method-backed property write not yet supported for ''%s''',
[AAssign.FieldName]),
AAssign.Line, AAssign.Col)
else
SemanticError(
Format('Property ''%s'' is read-only', [AAssign.FieldName]),
AAssign.Line, AAssign.Col);
end
else
SemanticError(
Format('Type ''%s'' has no field ''%s''',
[AAssign.RecordName, AAssign.FieldName]),
AAssign.Line, AAssign.Col);
end;
AAssign.FieldInfo := FldInfo;
ExprType := AnalyseExpr(AAssign.Expr);
@ -1509,9 +1567,10 @@ end;
function TSemanticAnalyser.AnalyseFieldAccess(AAccess: TFieldAccessExpr): TTypeDesc;
var
RecSym: TSymbol;
RT: TRecordTypeDesc;
FldInfo: TFieldInfo;
RecSym: TSymbol;
RT: TRecordTypeDesc;
FldInfo: TFieldInfo;
PropInfo: TPropertyInfo;
begin
RecSym := FTable.Lookup(AAccess.RecordName);
if RecSym = nil then
@ -1553,10 +1612,35 @@ begin
RT := TRecordTypeDesc(RecSym.TypeDesc);
FldInfo := RT.FindField(AAccess.FieldName);
if FldInfo = nil then
begin
{ Check if this is a property access }
PropInfo := RT.FindProperty(AAccess.FieldName);
if PropInfo <> nil then
begin
if PropInfo.ReadField <> '' then
begin
{ Field-backed read: redirect to the backing field }
AAccess.FieldName := PropInfo.ReadField;
AAccess.FieldInfo := RT.FindField(PropInfo.ReadField);
Result := PropInfo.TypeDesc;
AAccess.ResolvedType := Result;
Exit;
end
else if PropInfo.ReadMethod <> '' then
begin
{ Method-backed read: mark for method call in codegen }
AAccess.PropRead := PropInfo;
AAccess.PropOwnerType := RT.Name;
Result := PropInfo.TypeDesc;
AAccess.ResolvedType := Result;
Exit;
end;
end;
SemanticError(
Format('Type ''%s'' has no field ''%s''',
[AAccess.RecordName, AAccess.FieldName]),
AAccess.Line, AAccess.Col);
end;
AAccess.FieldInfo := FldInfo;
Result := FldInfo.TypeDesc;

36
compiler/src/main/pascal/uSymbolTable.pas
View file

@ -58,6 +58,17 @@ type
TInterfaceTypeDesc = class; { forward }
{ Property descriptor — one per declared property on a class. }
TPropertyInfo = class
public
Name: string;
TypeDesc: TTypeDesc; { not owned — resolved by semantic analysis }
ReadField: string; { '' if method-backed read }
ReadMethod: string; { '' if field-backed read }
WriteField: string; { '' if method-backed write or read-only }
WriteMethod: string; { '' if field-backed write or read-only }
end;
{ Extended type descriptor for record types. }
TRecordTypeDesc = class(TTypeDesc)
private
@ -66,6 +77,7 @@ type
FParent: TRecordTypeDesc; { not owned; nil for root classes }
FVTable: TObjectList; { owned TVTableEntry; nil if no virtual methods }
FImplements: TObjectList; { not owned — TInterfaceTypeDesc references }
FProperties: TObjectList; { owned TPropertyInfo }
public
constructor Create(const AName: string; AKind: TTypeKind = tyRecord);
destructor Destroy; override;
@ -88,6 +100,10 @@ type
function ImplementsCount: Integer;
function ImplementsIntfAt(AIndex: Integer): TInterfaceTypeDesc;
{ Property tracking }
procedure AddProperty(AProp: TPropertyInfo);
function FindProperty(const AName: string): TPropertyInfo;
property Fields: TObjectList read FFields;
property Parent: TRecordTypeDesc read FParent write FParent;
end;
@ -294,10 +310,12 @@ begin
FKeys.Duplicates := dupIgnore;
FVTable := nil; { allocated on first use }
FImplements := TObjectList.Create(False); { not owned }
FProperties := TObjectList.Create(True); { owned TPropertyInfo }
end;
destructor TRecordTypeDesc.Destroy;
begin
FProperties.Free;
FImplements.Free;
FKeys.Free;
FFields.Free;
@ -454,6 +472,24 @@ end;
{ TInterfaceTypeDesc }
{ ------------------------------------------------------------------ }
procedure TRecordTypeDesc.AddProperty(AProp: TPropertyInfo);
begin
FProperties.Add(AProp);
end;
function TRecordTypeDesc.FindProperty(const AName: string): TPropertyInfo;
var
I: Integer;
begin
for I := 0 to FProperties.Count - 1 do
if SameText(TPropertyInfo(FProperties[I]).Name, AName) then
begin
Result := TPropertyInfo(FProperties[I]);
Exit;
end;
Result := nil;
end;
constructor TInterfaceTypeDesc.Create(const AName: string);
begin
inherited Create;

3
compiler/src/test/pascal/TestRunner.pas
View file

@ -30,7 +30,8 @@ uses
cp.test.vtable,
cp.test.typetests,
cp.test.interfaces,
cp.test.generics;
cp.test.generics,
cp.test.properties;
var
Application: TTestRunner;

424
compiler/src/test/pascal/cp.test.properties.pas Normal file
View file

@ -0,0 +1,424 @@
unit cp.test.properties;
{$mode objfpc}{$H+}
{ Tests for Pascal property declarations — field-backed and method-backed.
Properties are transparent syntactic sugar: reads and writes redirect to
a backing field or method accessor. }
interface
uses
Classes, SysUtils, StrUtils, fpcunit, testregistry,
uLexer, uParser, uAST, uSymbolTable, uSemantic, uCodeGenQBE;
type
TPropertyTests = class(TTestCase)
private
function ParseSrc(const ASrc: string): TProgram;
function AnalyseSrc(const ASrc: string): TProgram;
function GenIR(const ASrc: string): string;
procedure AnalyseExpectError(const ASrc: string);
published
{ ------------------------------------------------------------------ }
{ Parser }
{ ------------------------------------------------------------------ }
procedure TestParse_Property_FieldBackedReadOnly;
procedure TestParse_Property_FieldBackedReadWrite;
procedure TestParse_Property_MethodBackedRead;
procedure TestParse_Property_MethodBackedReadWrite;
procedure TestParse_Property_CountInClassDef;
{ ------------------------------------------------------------------ }
{ Semantic — field-backed }
{ ------------------------------------------------------------------ }
procedure TestSemantic_Property_FieldBacked_OK;
procedure TestSemantic_Property_FieldBacked_TypeResolved;
procedure TestSemantic_Property_ReadOnly_WriteRaisesError;
procedure TestSemantic_Property_ReadWrite_OK;
{ ------------------------------------------------------------------ }
{ Semantic — method-backed }
{ ------------------------------------------------------------------ }
procedure TestSemantic_Property_MethodBacked_OK;
procedure TestSemantic_Property_MethodBacked_TypeResolved;
{ ------------------------------------------------------------------ }
{ Codegen — field-backed }
{ ------------------------------------------------------------------ }
procedure TestCodegen_Property_FieldBacked_Read_EmitsLoad;
procedure TestCodegen_Property_FieldBacked_Write_EmitsStore;
{ ------------------------------------------------------------------ }
{ Codegen — method-backed }
{ ------------------------------------------------------------------ }
procedure TestCodegen_Property_MethodBacked_Read_EmitsCall;
end;
implementation
{ ------------------------------------------------------------------ }
{ Source constants }
{ ------------------------------------------------------------------ }
const
SrcFieldBackedReadOnly =
'program P;' + LineEnding +
'type' + LineEnding +
' TBox = class' + LineEnding +
' FCount: Integer;' + LineEnding +
' property Count: Integer read FCount;' + LineEnding +
' end;' + LineEnding +
'begin' + LineEnding +
'end.';
SrcFieldBackedReadWrite =
'program P;' + LineEnding +
'type' + LineEnding +
' TBox = class' + LineEnding +
' FValue: Integer;' + LineEnding +
' property Value: Integer read FValue write FValue;' + LineEnding +
' end;' + LineEnding +
'begin' + LineEnding +
'end.';
SrcMethodBackedRead =
'program P;' + LineEnding +
'type' + LineEnding +
' TBox = class' + LineEnding +
' FCount: Integer;' + LineEnding +
' function GetCount: Integer;' + LineEnding +
' begin' + LineEnding +
' Result := Self.FCount' + LineEnding +
' end;' + LineEnding +
' property Count: Integer read GetCount;' + LineEnding +
' end;' + LineEnding +
'begin' + LineEnding +
'end.';
SrcMethodBackedReadWrite =
'program P;' + LineEnding +
'type' + LineEnding +
' TBox = class' + LineEnding +
' FValue: Integer;' + LineEnding +
' function GetValue: Integer;' + LineEnding +
' begin' + LineEnding +
' Result := Self.FValue' + LineEnding +
' end;' + LineEnding +
' procedure SetValue(AVal: Integer);' + LineEnding +
' begin' + LineEnding +
' Self.FValue := AVal' + LineEnding +
' end;' + LineEnding +
' property Value: Integer read GetValue write SetValue;' + LineEnding +
' end;' + LineEnding +
'begin' + LineEnding +
'end.';
SrcFieldBackedUsage =
'program P;' + LineEnding +
'type' + LineEnding +
' TBox = class' + LineEnding +
' FValue: Integer;' + LineEnding +
' property Value: Integer read FValue write FValue;' + LineEnding +
' end;' + LineEnding +
'var B: TBox;' + LineEnding +
'begin' + LineEnding +
' B := TBox.Create;' + LineEnding +
' B.Value := 42;' + LineEnding +
' WriteLn(B.Value)' + LineEnding +
'end.';
SrcMethodBackedReadUsage =
'program P;' + LineEnding +
'type' + LineEnding +
' TBox = class' + LineEnding +
' FCount: Integer;' + LineEnding +
' function GetCount: Integer;' + LineEnding +
' begin' + LineEnding +
' Result := Self.FCount' + LineEnding +
' end;' + LineEnding +
' property Count: Integer read GetCount;' + LineEnding +
' end;' + LineEnding +
'var B: TBox;' + LineEnding +
'begin' + LineEnding +
' B := TBox.Create;' + LineEnding +
' WriteLn(B.Count)' + LineEnding +
'end.';
{ ------------------------------------------------------------------ }
{ Helpers }
{ ------------------------------------------------------------------ }
function TPropertyTests.ParseSrc(const ASrc: string): TProgram;
var
L: TLexer;
P: TParser;
begin
L := TLexer.Create(ASrc);
P := TParser.Create(L);
try
Result := P.Parse;
finally
P.Free;
L.Free;
end;
end;
function TPropertyTests.AnalyseSrc(const ASrc: string): TProgram;
var
SA: TSemanticAnalyser;
begin
Result := ParseSrc(ASrc);
SA := TSemanticAnalyser.Create;
try
SA.Analyse(Result);
finally
SA.Free;
end;
end;
function TPropertyTests.GenIR(const ASrc: string): string;
var
CG: TCodeGenQBE;
Prog: TProgram;
begin
Prog := AnalyseSrc(ASrc);
CG := TCodeGenQBE.Create;
try
CG.Generate(Prog);
Result := CG.GetOutput;
finally
CG.Free;
Prog.Free;
end;
end;
procedure TPropertyTests.AnalyseExpectError(const ASrc: string);
var
Prog: TProgram;
SA: TSemanticAnalyser;
begin
Prog := ParseSrc(ASrc);
SA := TSemanticAnalyser.Create;
try
try
SA.Analyse(Prog);
Fail('Expected ESemanticError but none was raised');
except
on E: ESemanticError do { expected };
end;
finally
SA.Free;
Prog.Free;
end;
end;
{ ------------------------------------------------------------------ }
{ Parser tests }
{ ------------------------------------------------------------------ }
procedure TPropertyTests.TestParse_Property_FieldBackedReadOnly;
var
Prog: TProgram;
CD: TClassTypeDef;
PD: TPropertyDecl;
begin
Prog := ParseSrc(SrcFieldBackedReadOnly);
try
CD := TClassTypeDef(TTypeDecl(Prog.Block.TypeDecls[0]).Def);
AssertEquals('one property', 1, CD.Properties.Count);
PD := TPropertyDecl(CD.Properties[0]);
AssertEquals('property name', 'Count', PD.Name);
AssertEquals('type name', 'Integer', PD.TypeName);
AssertEquals('read name', 'FCount', PD.ReadName);
AssertEquals('write name empty', '', PD.WriteName);
finally
Prog.Free;
end;
end;
procedure TPropertyTests.TestParse_Property_FieldBackedReadWrite;
var
Prog: TProgram;
CD: TClassTypeDef;
PD: TPropertyDecl;
begin
Prog := ParseSrc(SrcFieldBackedReadWrite);
try
CD := TClassTypeDef(TTypeDecl(Prog.Block.TypeDecls[0]).Def);
PD := TPropertyDecl(CD.Properties[0]);
AssertEquals('property name', 'Value', PD.Name);
AssertEquals('read name', 'FValue', PD.ReadName);
AssertEquals('write name', 'FValue', PD.WriteName);
finally
Prog.Free;
end;
end;
procedure TPropertyTests.TestParse_Property_MethodBackedRead;
var
Prog: TProgram;
CD: TClassTypeDef;
PD: TPropertyDecl;
begin
Prog := ParseSrc(SrcMethodBackedRead);
try
CD := TClassTypeDef(TTypeDecl(Prog.Block.TypeDecls[0]).Def);
AssertEquals('one property', 1, CD.Properties.Count);
PD := TPropertyDecl(CD.Properties[0]);
AssertEquals('property name', 'Count', PD.Name);
AssertEquals('read name', 'GetCount', PD.ReadName);
AssertEquals('write name empty', '', PD.WriteName);
finally
Prog.Free;
end;
end;
procedure TPropertyTests.TestParse_Property_MethodBackedReadWrite;
var
Prog: TProgram;
CD: TClassTypeDef;
PD: TPropertyDecl;
begin
Prog := ParseSrc(SrcMethodBackedReadWrite);
try
CD := TClassTypeDef(TTypeDecl(Prog.Block.TypeDecls[0]).Def);
PD := TPropertyDecl(CD.Properties[0]);
AssertEquals('read name', 'GetValue', PD.ReadName);
AssertEquals('write name', 'SetValue', PD.WriteName);
finally
Prog.Free;
end;
end;
procedure TPropertyTests.TestParse_Property_CountInClassDef;
var
Prog: TProgram;
CD: TClassTypeDef;
begin
Prog := ParseSrc(SrcMethodBackedReadWrite);
try
CD := TClassTypeDef(TTypeDecl(Prog.Block.TypeDecls[0]).Def);
AssertEquals('one field', 1, CD.Fields.Count);
AssertEquals('two methods', 2, CD.Methods.Count);
AssertEquals('one property', 1, CD.Properties.Count);
finally
Prog.Free;
end;
end;
{ ------------------------------------------------------------------ }
{ Semantic — field-backed }
{ ------------------------------------------------------------------ }
procedure TPropertyTests.TestSemantic_Property_FieldBacked_OK;
begin
AnalyseSrc(SrcFieldBackedReadWrite).Free;
end;
procedure TPropertyTests.TestSemantic_Property_FieldBacked_TypeResolved;
var
Prog: TProgram;
RT: TRecordTypeDesc;
PI: TPropertyInfo;
begin
Prog := AnalyseSrc(SrcFieldBackedReadWrite);
try
RT := TRecordTypeDesc(Prog.SymbolTable.FindType('TBox'));
AssertNotNull('TBox found', RT);
PI := RT.FindProperty('Value');
AssertNotNull('Value property found', PI);
AssertEquals('type is tyInteger', Ord(tyInteger), Ord(PI.TypeDesc.Kind));
AssertEquals('read field is FValue', 'FValue', PI.ReadField);
AssertEquals('write field is FValue', 'FValue', PI.WriteField);
finally
Prog.Free;
end;
end;
procedure TPropertyTests.TestSemantic_Property_ReadOnly_WriteRaisesError;
begin
AnalyseExpectError(
'program P;' + LineEnding +
'type TBox = class' + LineEnding +
' FCount: Integer;' + LineEnding +
' property Count: Integer read FCount;' + LineEnding +
'end;' + LineEnding +
'var B: TBox;' + LineEnding +
'begin B := TBox.Create; B.Count := 5 end.'
);
end;
procedure TPropertyTests.TestSemantic_Property_ReadWrite_OK;
begin
AnalyseSrc(SrcFieldBackedUsage).Free;
end;
{ ------------------------------------------------------------------ }
{ Semantic — method-backed }
{ ------------------------------------------------------------------ }
procedure TPropertyTests.TestSemantic_Property_MethodBacked_OK;
begin
AnalyseSrc(SrcMethodBackedReadUsage).Free;
end;
procedure TPropertyTests.TestSemantic_Property_MethodBacked_TypeResolved;
var
Prog: TProgram;
RT: TRecordTypeDesc;
PI: TPropertyInfo;
begin
Prog := AnalyseSrc(SrcMethodBackedRead);
try
RT := TRecordTypeDesc(Prog.SymbolTable.FindType('TBox'));
PI := RT.FindProperty('Count');
AssertNotNull('Count property found', PI);
AssertEquals('type is tyInteger', Ord(tyInteger), Ord(PI.TypeDesc.Kind));
AssertEquals('read field empty', '', PI.ReadField);
AssertEquals('read method is GetCount', 'GetCount', PI.ReadMethod);
finally
Prog.Free;
end;
end;
{ ------------------------------------------------------------------ }
{ Codegen — field-backed }
{ ------------------------------------------------------------------ }
procedure TPropertyTests.TestCodegen_Property_FieldBacked_Read_EmitsLoad;
var
IR: string;
begin
IR := GenIR(SrcFieldBackedUsage);
{ B.Value read → loads FValue field (offset=8, after vptr) }
AssertTrue('IR emitted for field-backed read', Pos('loadw', IR) > 0);
end;
procedure TPropertyTests.TestCodegen_Property_FieldBacked_Write_EmitsStore;
var
IR: string;
begin
IR := GenIR(SrcFieldBackedUsage);
{ B.Value := 42 → stores to FValue field }
AssertTrue('IR emitted for field-backed write', Pos('storew', IR) > 0);
end;
{ ------------------------------------------------------------------ }
{ Codegen — method-backed }
{ ------------------------------------------------------------------ }
procedure TPropertyTests.TestCodegen_Property_MethodBacked_Read_EmitsCall;
var
IR: string;
begin
IR := GenIR(SrcMethodBackedReadUsage);
{ B.Count → calls $TBox_GetCount }
AssertTrue('method-backed read emits call to GetCount',
Pos('TBox_GetCount', IR) > 0);
end;
initialization
RegisterTest(TPropertyTests);
end.