From 80c2b21d6c2fa54f5258b29aa2f4da5f0dc79bb7 Mon Sep 17 00:00:00 2001 From: Graeme Geldenhuys Date: Tue, 21 Apr 2026 23:15:15 +0100 Subject: [PATCH] Implement Pascal property declarations with field- and method-backed access 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. --- compiler/src/main/pascal/uAST.pas | 20 +- compiler/src/main/pascal/uCodeGenQBE.pas | 14 +- compiler/src/main/pascal/uParser.pas | 60 ++- compiler/src/main/pascal/uSemantic.pas | 98 +++- compiler/src/main/pascal/uSymbolTable.pas | 36 ++ compiler/src/test/pascal/TestRunner.pas | 3 +- .../src/test/pascal/cp.test.properties.pas | 424 ++++++++++++++++++ 7 files changed, 636 insertions(+), 19 deletions(-) create mode 100644 compiler/src/test/pascal/cp.test.properties.pas diff --git a/compiler/src/main/pascal/uAST.pas b/compiler/src/main/pascal/uAST.pas index 1506dc5..040c603 100644 --- a/compiler/src/main/pascal/uAST.pas +++ b/compiler/src/main/pascal/uAST.pas @@ -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; diff --git a/compiler/src/main/pascal/uCodeGenQBE.pas b/compiler/src/main/pascal/uCodeGenQBE.pas index daebe9d..5c47530 100644 --- a/compiler/src/main/pascal/uCodeGenQBE.pas +++ b/compiler/src/main/pascal/uCodeGenQBE.pas @@ -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 diff --git a/compiler/src/main/pascal/uParser.pas b/compiler/src/main/pascal/uParser.pas index 31d1ee8..7318489 100644 --- a/compiler/src/main/pascal/uParser.pas +++ b/compiler/src/main/pascal/uParser.pas @@ -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; diff --git a/compiler/src/main/pascal/uSemantic.pas b/compiler/src/main/pascal/uSemantic.pas index 4e248b0..a4dd397 100644 --- a/compiler/src/main/pascal/uSemantic.pas +++ b/compiler/src/main/pascal/uSemantic.pas @@ -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; diff --git a/compiler/src/main/pascal/uSymbolTable.pas b/compiler/src/main/pascal/uSymbolTable.pas index 4622275..4c5670c 100644 --- a/compiler/src/main/pascal/uSymbolTable.pas +++ b/compiler/src/main/pascal/uSymbolTable.pas @@ -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; diff --git a/compiler/src/test/pascal/TestRunner.pas b/compiler/src/test/pascal/TestRunner.pas index 92974aa..f84e271 100644 --- a/compiler/src/test/pascal/TestRunner.pas +++ b/compiler/src/test/pascal/TestRunner.pas @@ -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; diff --git a/compiler/src/test/pascal/cp.test.properties.pas b/compiler/src/test/pascal/cp.test.properties.pas new file mode 100644 index 0000000..be3a624 --- /dev/null +++ b/compiler/src/test/pascal/cp.test.properties.pas @@ -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.