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

feat: interface properties

Browse source 
Interfaces may declare properties (FPC/Delphi parity):

  IValued = interface
    function GetValue(): Integer;
    procedure SetValue(AValue: Integer);
    property Value: Integer read GetValue write SetValue;
  end;

Accessors must be methods of the interface or an inherited parent
(interfaces have no fields), validated at registration.  I.Value reads
lower to the existing zero-arg getter itab dispatch; I.Value := X
lowers to the setter dispatch with X as the single argument — pure
compile-time sugar, no itab slots, no layout change.  Child interfaces
see inherited properties via the parent chain.  Wired end to end:
parser, TInterfaceTypeDef.Properties (AST + clone), TInterfaceTypeDesc
property registry, semantic read/write resolution, both backends, .bif
serialisation and import registration.  v1 limits (recorded in
language-rationale): plain interface-typed receivers; no indexed/
default array properties.

Two pre-existing linking bugs surfaced by the dogfood program and are
fixed alongside:

- Property accessor names written in a different case than the method
  declaration (read getValue for GetValue) produced unresolved symbols —
  accessor names are now normalised to the declared casing at
  registration (classes and interfaces, compile and import paths).

- A program-level class implementing an interface failed to link
  whenever the program had a uses clause: program-scope methods carry
  bare symbol names (uSemantic.CurrentUnitPrefix) but itabs and
  property-setter call sites prefixed them with the program name via
  Sym.OwningUnit.  ClassUnitPrefix (QBE) / ClassSymName (native) now
  skip the prefix for program-owned classes (new FProgramName field).

Tests: 7 in cp.test.interfaces (parse, registration, accessor
validation, read-only enforcement, inheritance, IR dispatch), bif
round-trip in cp.test.unitinterface, 2 e2e suites on both backends in
cp.test.e2e.classes2 (interface read/write incl. compound assignment
and inherited dispatch; case-mismatch + uses regression).  Suite: 2940
OK on working and fixpoint binaries; FIXPOINT_OK; NATIVE_FIXPOINT_OK.
This commit is contained in:
Graeme Geldenhuys 2026-06-11 11:04:47 +01:00
parent 1b366f4c97
commit f8d75e586d
14 changed files with 680 additions and 26 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

23
compiler/src/main/pascal/blaise.codegen.native.x86_64.pas
View file

@ -152,6 +152,9 @@ type
_SetArgs — mirrors the QBE backend's EmitMainHeader loop. }
FUnitInitNames: TStringList;
FCurrentUnitName: string;
FProgramName: string; { set by EmitProgram — program-scope classes keep
bare symbol names (no unit prefix), matching
uSemantic.CurrentUnitPrefix }
{ Allocate a fresh local assembly label (".L<prefix><N>"). }
function NewLabel(const APrefix: string): string;
@ -1202,7 +1205,10 @@ begin
if Sym <> nil then
begin
Owner := Sym.OwningUnit;
{ Program-scope classes keep bare names — see the QBE backend's
ClassUnitPrefix and uSemantic.CurrentUnitPrefix. }
if (Owner <> '') and
not ((FProgramName <> '') and SameText(Owner, FProgramName)) and
not SameText(Owner, 'System') and
not ((Length(Owner) >= 4) and SameText(Copy(Owner, 0, 4), 'rtl.')) and
not ((Length(Owner) >= 7) and SameText(Copy(Owner, 0, 7), 'blaise_')) then
@ -7882,6 +7888,7 @@ var
FDynArgName: string;
FDynElemSz: Integer;
ISFld: TFieldInfo;
IntfArgs: TObjectList;
begin
if AStmt is TAssignment then
begin
@ -8875,6 +8882,21 @@ begin
if AStmt is TFieldAssignment then
begin
FA := TFieldAssignment(AStmt);
{ Interface property write: I.Prop := V — FieldName holds the SETTER
(rewritten by semantic); dispatch through the itab with V as the
single argument. }
if FA.IntfWriteDesc <> nil then
begin
IntfArgs := TObjectList.Create(False);
try
IntfArgs.Add(FA.Expr);
Self.EmitInterfaceCall(FA.RecordName, FA.IsGlobal,
TInterfaceTypeDesc(FA.IntfWriteDesc), FA.FieldName, IntfArgs);
finally
IntfArgs.Free();
end;
Exit;
end;
if FA.PropWriteInfo <> nil then
begin
Self.EmitExprToEax(FA.Expr);
@ -12018,6 +12040,7 @@ var
Decl: TMethodDecl;
begin
FCurrentUnitName := AProg.Name;
FProgramName := AProg.Name;
{ Register declared program-level variables as global slots. }
for I := 0 to AProg.Block.Decls.Count - 1 do
begin

45
compiler/src/main/pascal/blaise.codegen.qbe.pas
View file

@ -91,7 +91,10 @@ type
its own next iteration. }
FThreadVarNames: TStringList; { global names declared as threadvar }
FUnitInitNames: TStringList; { unit names that have initialization sections }
FCurrentUnitName: string; { name of the unit/program being emitted }
FCurrentUnitName: string;
FProgramName: string; { set by Generate/AppendProgram — program-scope
classes keep bare symbol names (no unit prefix),
matching uSemantic.CurrentUnitPrefix } { name of the unit/program being emitted }
{ mem2reg: parallel lists tracking which locals are promoted SSA temps.
FPromotedLocals[i] = var name; FPromotedTypes[i] = QBE type ('w','l','d','s').
Cleared at the start of each function by EmitVarAllocs. }
@ -5300,7 +5303,41 @@ var
SelfPtr: string;
IdxTemp: string;
IdxQType: string;
IntfDesc: TInterfaceTypeDesc;
SlotOff: Integer;
begin
{ Interface property write: I.Prop := V — FieldName holds the SETTER
(rewritten by semantic); dispatch it through the itab with V as the
single argument, mirroring EmitMethodCall's interface branch. }
if AAssign.IntfWriteDesc <> nil then
begin
IntfDesc := TInterfaceTypeDesc(AAssign.IntfWriteDesc);
SelfPtr := AllocTemp();
PtrTemp := AllocTemp();
EmitLine(Format(' %s =l loadl %s_obj',
[SelfPtr, VarRef(AAssign.RecordName, AAssign.IsGlobal)]));
EmitLine(Format(' %s =l loadl %s_itab',
[PtrTemp, VarRef(AAssign.RecordName, AAssign.IsGlobal)]));
SlotOff := IntfDesc.MethodIndex(AAssign.FieldName) * 8;
Ptr := AllocTemp();
if SlotOff = 0 then
EmitLine(Format(' %s =l loadl %s', [Ptr, PtrTemp]))
else
begin
OldTemp := AllocTemp();
EmitLine(Format(' %s =l add %s, %d', [OldTemp, PtrTemp, SlotOff]));
EmitLine(Format(' %s =l loadl %s', [Ptr, OldTemp]));
end;
ValTemp := EmitExpr(AAssign.Expr);
if (AAssign.Expr.ResolvedType <> nil) and
(AAssign.Expr.ResolvedType.Kind in
[tyPointer, tyClass, tyInterface, tyPChar, tyString]) then
EmitLine(Format(' call %s(l %s, l %s)', [Ptr, SelfPtr, ValTemp]))
else
EmitLine(Format(' call %s(l %s, w %s)', [Ptr, SelfPtr, ValTemp]));
Exit;
end;
{ Method-backed property write: emit a call to the setter }
if AAssign.PropWriteInfo <> nil then
begin
@ -11693,6 +11730,10 @@ begin
Owner := Sym.OwningUnit;
{ Allowlist mirrors uSemantic.IsUnmangledUnit. }
if Owner = '' then Exit;
{ Program-scope classes keep bare names: uSemantic.CurrentUnitPrefix gives
program-scope methods unprefixed ResolvedQbeNames, so reference sites
(itabs, property setter calls) must not add a prefix either. }
if (FProgramName <> '') and SameText(Owner, FProgramName) then Exit;
if SameText(Owner, 'System') then Exit;
if (Length(Owner) >= 4) and SameText(Copy(Owner, 0, 4), 'rtl.') then Exit;
if (Length(Owner) >= 7) and SameText(Copy(Owner, 0, 7), 'blaise_') then Exit;
@ -11747,6 +11788,7 @@ begin
FTempCount := 0;
FLabelCount := 0;
FCurrentUnitName := AProg.Name;
FProgramName := AProg.Name;
CollectThreadVarNames(AProg.Block);
@ -12420,6 +12462,7 @@ begin
FTempCount := 0;
FLabelCount := 0;
FCurrentUnitName := AProg.Name;
FProgramName := AProg.Name;
CollectThreadVarNames(AProg.Block);

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

@ -363,6 +363,11 @@ type
PropOwnerType: string; { owner class name for setter call; valid when PropIndexExpr set }
IsElemWrite: Boolean; { set by uSemantic — FieldName is an array-typed field and
PropIndexExpr selects the element to store into }
[Unretained] IntfWriteDesc: TTypeDesc; { set by uSemantic — non-nil = interface
property write: RecordName is interface-typed and
FieldName has been rewritten to the SETTER method;
codegen dispatches it through the itab with Expr
as the single argument }
destructor Destroy; override;
end;
@ -752,6 +757,7 @@ type
public
ParentName: string;
Methods: TObjectList; { owned TMethodDecl — forward signatures only }
Properties: TObjectList; { owned TPropertyDecl — accessors are interface methods }
constructor Create;
destructor Destroy; override;
end;
@ -1366,6 +1372,7 @@ constructor TInterfaceTypeDef.Create;
begin
inherited Create();
Methods := TObjectList.Create(True);
Properties := TObjectList.Create(True);
end;
destructor TInterfaceTypeDef.Destroy;
@ -2272,6 +2279,8 @@ begin
Result.ParentName := ASrc.ParentName;
for I := 0 to ASrc.Methods.Count - 1 do
Result.Methods.Add(CloneMethodDecl(TMethodDecl(ASrc.Methods.Items[I])));
for I := 0 to ASrc.Properties.Count - 1 do
Result.Properties.Add(ClonePropertyDecl(TPropertyDecl(ASrc.Properties.Items[I])));
end;
function CloneGenericInterfaceDef(ASrc: TGenericInterfaceDef): TGenericInterfaceDef;

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

@ -1345,9 +1345,12 @@ begin
Expect(tkRParen);
end;
while Check(tkProcedure) or Check(tkFunction) or
Check(tkConstructor) or Check(tkDestructor) do
Check(tkConstructor) or Check(tkDestructor) or
(Check(tkIdent) and SameText(FCurrent.Value, 'property')) do
begin
if Check(tkFunction) then
if Check(tkIdent) then
Result.Properties.Add(ParsePropertyDecl())
else if Check(tkFunction) then
Result.Methods.Add(ParseMethodDecl(True))
else
Result.Methods.Add(ParseMethodDecl(False));

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

@ -3132,6 +3132,21 @@ begin
end;
end;
{ Return AName in the casing of the matching method declaration, or AName
unchanged when no declaration matches. Property accessor names must use
the method's declared casing — emitted method symbols are case-sensitive
at link time, while Pascal name resolution is not. }
function DeclaredMethodCase(AMethods: TObjectList; const AName: string): string;
var
I: Integer;
begin
Result := AName;
if AMethods = nil then Exit;
for I := 0 to AMethods.Count - 1 do
if SameText(TMethodDecl(AMethods.Items[I]).Name, AName) then
Exit(TMethodDecl(AMethods.Items[I]).Name);
end;
procedure TSemanticAnalyser.AnalyseTypeDecls(ABlock: TBlock);
var
I, J, K: Integer;
@ -3412,6 +3427,42 @@ begin
end;
IntfDesc.AddMethod(MDecl.Name, MDecl.ReturnTypeName, VarFlags);
end;
{ Register interface properties. Accessors must be methods of the
interface itself (or an inherited one) — interfaces have no fields,
so field-backed accessors cannot exist. }
for J := 0 to ITD.Properties.Count - 1 do
begin
PropDecl := TPropertyDecl(ITD.Properties.Items[J]);
if IntfDesc.FindProperty(PropDecl.Name) <> nil then Continue;
if (PropDecl.ReadName <> '') and
not IntfDesc.HasMethod(PropDecl.ReadName) then
SemanticError(Format(
'Interface property ''%s.%s'': read accessor ''%s'' is not a method of the interface',
[TD.Name, PropDecl.Name, PropDecl.ReadName]), TD.Line, TD.Col);
if (PropDecl.WriteName <> '') and
not IntfDesc.HasMethod(PropDecl.WriteName) then
SemanticError(Format(
'Interface property ''%s.%s'': write accessor ''%s'' is not a method of the interface',
[TD.Name, PropDecl.Name, PropDecl.WriteName]), TD.Line, TD.Col);
PropInfo := TPropertyInfo.Create();
PropInfo.Name := PropDecl.Name;
PropInfo.TypeDesc := FindTypeOrInstantiate(PropDecl.TypeName);
if PropInfo.TypeDesc = nil then
begin
PropInfo.Free();
SemanticError(Format(
'Unknown type ''%s'' for interface property ''%s.%s''',
[PropDecl.TypeName, TD.Name, PropDecl.Name]), TD.Line, TD.Col);
end;
{ Canonical method casing — link-time symbols are case-sensitive. }
if PropDecl.ReadName <> '' then
PropInfo.ReadMethod :=
IntfDesc.MethodName(IntfDesc.MethodIndex(PropDecl.ReadName));
if PropDecl.WriteName <> '' then
PropInfo.WriteMethod :=
IntfDesc.MethodName(IntfDesc.MethodIndex(PropDecl.WriteName));
IntfDesc.AddProperty(PropInfo);
end;
Continue;
end;
@ -3741,14 +3792,16 @@ begin
if RT.FindField(PropDecl.ReadName) <> nil then
PropInfo.ReadField := PropDecl.ReadName
else
PropInfo.ReadMethod := PropDecl.ReadName;
PropInfo.ReadMethod := DeclaredMethodCase(
TClassTypeDef(TD.Def).Methods, PropDecl.ReadName);
end;
if PropDecl.WriteName <> '' then
begin
if RT.FindField(PropDecl.WriteName) <> nil then
PropInfo.WriteField := PropDecl.WriteName
else
PropInfo.WriteMethod := PropDecl.WriteName;
PropInfo.WriteMethod := DeclaredMethodCase(
TClassTypeDef(TD.Def).Methods, PropDecl.WriteName);
end;
PropInfo.IndexParamName := PropDecl.IndexParamName;
if PropDecl.IndexTypeName <> '' then
@ -5791,6 +5844,7 @@ var
PropInfo: TPropertyInfo;
ExprType: TTypeDesc;
ObjType: TTypeDesc;
IntfDesc: TInterfaceTypeDesc;
begin
{ ObjExpr path: receiver is an arbitrary expression (e.g. typecast result) }
if AAssign.ObjExpr <> nil then
@ -5898,6 +5952,33 @@ begin
SemanticError(
Format('''%s'' is not a variable', [AAssign.RecordName]),
AAssign.Line, AAssign.Col);
{ Interface property write: I.Prop := V lowers to the setter dispatched
through the itab. FieldName is rewritten to the setter method name;
codegen reads IntfWriteDesc to emit the indirect call. }
if RecSym.TypeDesc.Kind = tyInterface then
begin
IntfDesc := TInterfaceTypeDesc(RecSym.TypeDesc);
PropInfo := IntfDesc.FindProperty(AAssign.FieldName);
if PropInfo = nil then
SemanticError(
Format('Interface ''%s'' has no property ''%s''',
[IntfDesc.Name, AAssign.FieldName]),
AAssign.Line, AAssign.Col);
if PropInfo.WriteMethod = '' then
SemanticError(
Format('Interface property ''%s.%s'' is read-only',
[IntfDesc.Name, AAssign.FieldName]),
AAssign.Line, AAssign.Col);
AAssign.RecordName := RecSym.Name; { normalise to declared casing }
AAssign.FieldName := PropInfo.WriteMethod;
AAssign.IntfWriteDesc := IntfDesc;
AAssign.IsGlobal := RecSym.IsGlobal;
AAssign.IsVarParam := RecSym.Kind = skVarParameter;
ExprType := AnalyseExpr(AAssign.Expr);
CheckTypesMatch(PropInfo.TypeDesc, ExprType, 'property assignment',
AAssign.Line, AAssign.Col);
Exit;
end;
if not (RecSym.TypeDesc.Kind in [tyRecord, tyClass]) then
SemanticError(
Format('''%s'' is not a record or class variable', [AAssign.RecordName]),
@ -8523,10 +8604,22 @@ begin
begin
IntfDesc := TInterfaceTypeDesc(RecSym.TypeDesc);
if not IntfDesc.HasMethod(AAccess.FieldName) then
SemanticError(
Format('Interface ''%s'' has no method ''%s''',
[IntfDesc.Name, AAccess.FieldName]),
AAccess.Line, AAccess.Col);
begin
{ Property read: lower to the getter — pure sugar over the
zero-argument interface method dispatch below. }
PropInfo := IntfDesc.FindProperty(AAccess.FieldName);
if PropInfo = nil then
SemanticError(
Format('Interface ''%s'' has no method or property ''%s''',
[IntfDesc.Name, AAccess.FieldName]),
AAccess.Line, AAccess.Col);
if PropInfo.ReadMethod = '' then
SemanticError(
Format('Interface property ''%s.%s'' is write-only',
[IntfDesc.Name, AAccess.FieldName]),
AAccess.Line, AAccess.Col);
AAccess.FieldName := PropInfo.ReadMethod;
end;
AAccess.IsInterfaceCall := True;
AAccess.ResolvedClassType := IntfDesc;
AAccess.IsGlobal := RecSym.IsGlobal;

61
compiler/src/main/pascal/uSemanticImport.pas
View file

@ -242,6 +242,20 @@ begin
end;
end;
{ Return AName in the casing of the matching method declaration, or AName
unchanged when no declaration matches — emitted method symbols are
case-sensitive at link time. }
function DeclaredMethodCaseOf(AMethods: TObjectList; const AName: string): string;
var
I: Integer;
begin
Result := AName;
if AMethods = nil then Exit;
for I := 0 to AMethods.Count - 1 do
if SameText(TMethodDecl(AMethods.Items[I]).Name, AName) then
Exit(TMethodDecl(AMethods.Items[I]).Name);
end;
procedure RegisterInterface(AEntry: TTypeEntry; ATable: TSymbolTable;
const AUnitName: string);
var
@ -251,6 +265,10 @@ var
ParentSym: TSymbol;
M: TMethodDecl;
I: Integer;
PropDecl: TPropertyDecl;
PropInfo: TPropertyInfo;
PropSym: TSymbol;
PropType: TTypeDesc;
begin
IntfDef := TInterfaceTypeDef(AEntry.Def);
@ -289,6 +307,43 @@ begin
M := TMethodDecl(IntfDef.Methods.Items[I]);
IntfDesc.AddMethod(M.Name, M.ReturnTypeName, ParamVarFlags(M));
end;
{ Register interface properties. Accessors are always interface methods
(interfaces have no fields); the type resolves against the importing
table like class property types do. }
for I := 0 to IntfDef.Properties.Count - 1 do
begin
PropDecl := TPropertyDecl(IntfDef.Properties.Items[I]);
if IntfDesc.FindProperty(PropDecl.Name) <> nil then Continue;
PropInfo := TPropertyInfo.Create();
PropInfo.Name := PropDecl.Name;
PropSym := ATable.Lookup(PropDecl.TypeName);
if (PropSym <> nil) and (PropSym.Kind = skType) then
PropInfo.TypeDesc := PropSym.TypeDesc
else
begin
PropType := ResolveInlineTypeName(PropDecl.TypeName, ATable);
if PropType <> nil then
PropInfo.TypeDesc := PropType;
end;
if PropDecl.ReadName <> '' then
begin
if IntfDesc.MethodIndex(PropDecl.ReadName) >= 0 then
PropInfo.ReadMethod :=
IntfDesc.MethodName(IntfDesc.MethodIndex(PropDecl.ReadName))
else
PropInfo.ReadMethod := PropDecl.ReadName;
end;
if PropDecl.WriteName <> '' then
begin
if IntfDesc.MethodIndex(PropDecl.WriteName) >= 0 then
PropInfo.WriteMethod :=
IntfDesc.MethodName(IntfDesc.MethodIndex(PropDecl.WriteName))
else
PropInfo.WriteMethod := PropDecl.WriteName;
end;
IntfDesc.AddProperty(PropInfo);
end;
end;
procedure RegisterClass(AEntry: TTypeEntry; ATable: TSymbolTable;
@ -426,14 +481,16 @@ begin
if RT.FindField(PropDecl.ReadName) <> nil then
PropInfo.ReadField := PropDecl.ReadName
else
PropInfo.ReadMethod := PropDecl.ReadName;
PropInfo.ReadMethod :=
DeclaredMethodCaseOf(ClassDef.Methods, PropDecl.ReadName);
end;
if PropDecl.WriteName <> '' then
begin
if RT.FindField(PropDecl.WriteName) <> nil then
PropInfo.WriteField := PropDecl.WriteName
else
PropInfo.WriteMethod := PropDecl.WriteName;
PropInfo.WriteMethod :=
DeclaredMethodCaseOf(ClassDef.Methods, PropDecl.WriteName);
end;
PropInfo.IndexParamName := PropDecl.IndexParamName;
if PropDecl.IndexTypeName <> '' then

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

@ -213,6 +213,7 @@ type
FMethods: TStringList; { method names, case-insensitive }
FReturnTypes: TStringList; { parallel: return type name, '' = procedure }
FParamIsVar: TStringList; { parallel: comma-separated '1'/'0' per param; '1' = var param }
FProperties: TObjectList; { owned TPropertyInfo — accessors are interface methods }
[Unretained] FParent: TInterfaceTypeDesc; { not owned; nil if no parent }
public
constructor Create(const AName: string);
@ -226,6 +227,9 @@ type
function MethodIndex(const AName: string): Integer;
function MethodParamIsVar(AMethodIndex: Integer; AParamIndex: Integer): Boolean;
function MethodParamVarFlagsStr(AMethodIndex: Integer): string;
procedure AddProperty(AInfo: TPropertyInfo);
{ Walks the parent chain — a child interface sees inherited properties. }
function FindProperty(const AName: string): TPropertyInfo;
property Parent: TInterfaceTypeDesc read FParent write FParent;
end;
@ -981,17 +985,39 @@ begin
FMethods.CaseSensitive := False;
FReturnTypes := TStringList.Create();
FParamIsVar := TStringList.Create();
FProperties := TObjectList.Create(True);
FParent := nil;
end;
destructor TInterfaceTypeDesc.Destroy;
begin
FProperties.Free();
FParamIsVar.Free();
FReturnTypes.Free();
FMethods.Free();
inherited Destroy();
end;
procedure TInterfaceTypeDesc.AddProperty(AInfo: TPropertyInfo);
begin
FProperties.Add(AInfo);
end;
function TInterfaceTypeDesc.FindProperty(const AName: string): TPropertyInfo;
var
I: Integer;
begin
for I := 0 to FProperties.Count - 1 do
begin
Result := TPropertyInfo(FProperties.Items[I]);
if SameText(Result.Name, AName) then
Exit;
end;
if FParent <> nil then
Exit(FParent.FindProperty(AName));
Result := nil;
end;
procedure TInterfaceTypeDesc.AddMethod(const AName: string;
const AReturnTypeName: string; const AParamIsVar: string);
begin

10
compiler/src/main/pascal/uUnitInterfaceIO.pas
View file

@ -443,9 +443,10 @@ begin
if IntfDef <> nil then
Result := Result +
EncodeLpstr(IntfDef.ParentName) +
EncodeMethodDeclList(IntfDef.Methods)
EncodeMethodDeclList(IntfDef.Methods) +
EncodePropertyList(IntfDef.Properties)
else
Result := Result + EncodeLpstr('') + EncodeCount(0);
Result := Result + EncodeLpstr('') + EncodeCount(0) + EncodeCount(0);
end;
function WriteProcPayload(AEntry: TTypeEntry): string;
@ -477,7 +478,8 @@ begin
Def := TInterfaceTypeDef(AEntry.Def);
Result :=
EncodeLpstr(Def.ParentName) +
EncodeMethodDeclList(Def.Methods);
EncodeMethodDeclList(Def.Methods) +
EncodePropertyList(Def.Properties);
end;
function WriteTypes(AIface: TUnitInterface): string;
@ -1941,6 +1943,7 @@ begin
Def.IntfDef := IntfDef;
IntfDef.ParentName := ReadLpstrAt(AText, APos);
ReadMethodDeclList(AText, APos, IntfDef.Methods);
ReadPropertyList(AText, APos, IntfDef.Properties);
AEntry.IsGeneric := True;
AEntry.Def := Def;
end;
@ -1978,6 +1981,7 @@ begin
Def := TInterfaceTypeDef.Create();
Def.ParentName := ReadLpstrAt(AText, APos);
ReadMethodDeclList(AText, APos, Def.Methods);
ReadPropertyList(AText, APos, Def.Properties);
AEntry.Def := Def;
end;

117
compiler/src/test/pascal/cp.test.e2e.classes2.pas
View file

@ -76,6 +76,14 @@ type
{ Regression (issue #64): interface-typed field with same name as a
program-level global of a different type. }
procedure TestRun_InterfaceField_ShadowsGlobal_Dispatches;
{ Interface properties: read/write through the interface variable. }
procedure TestRun_InterfaceProperty_ReadWrite;
{ Accessor names with non-declared casing must still link (symbols are
case-sensitive; Pascal resolution is not), and program-level classes
implementing interfaces must link when units are in the uses chain
(program-scope symbols carry no unit prefix). }
procedure TestRun_InterfaceProperty_CaseMismatchAndUses;
end;
implementation
@ -1242,6 +1250,115 @@ begin
AssertEquals('interface dispatch through field shadowing global', 'printed' + LE, Output);
end;
const
SrcInterfaceProperty = '''
program P;
type
IInter = interface
function GetValue(): Integer;
procedure SetValue(AValue: Integer);
property Value: Integer read GetValue write SetValue;
end;
IChild = interface(IInter)
procedure Bump();
end;
TFace = class(TObject, IInter, IChild)
FVal: Integer;
function GetValue(): Integer;
procedure SetValue(AValue: Integer);
procedure Bump();
property Value: Integer read GetValue write SetValue;
end;
function TFace.GetValue(): Integer;
begin
Result := FVal;
end;
procedure TFace.SetValue(AValue: Integer);
begin
FVal := AValue;
end;
procedure TFace.Bump();
begin
FVal := FVal + 1;
end;
var
C: TFace;
I: IInter;
K: IChild;
begin
C := TFace.Create();
C.Value := 13;
writeln(C.Value);
I := TFace.Create();
I.Value := 21;
writeln(I.Value);
I.Value := I.Value + 1;
writeln(I.Value);
K := TFace.Create();
K.Value := 40;
K.Bump();
writeln(K.Value);
end.
''';
procedure TE2EClasses2Tests.TestRun_InterfaceProperty_ReadWrite;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertRunsOnAll(SrcInterfaceProperty,
'13' + LE + '21' + LE + '22' + LE + '41' + LE, 0);
end;
const
SrcIntfPropCaseUses = '''
program P;
uses classes;
type
Iinter = interface
function GetValue(): Integer;
procedure SetValue(AValue: Integer);
property prop: Integer read getValue write setValue;
end;
Tface = class(TObject, Iinter)
fProp: Integer;
function GetValue(): Integer;
procedure SetValue(AValue: Integer);
property prop: Integer read getValue write setValue;
end;
function Tface.GetValue(): Integer;
begin
Result := fProp;
end;
procedure Tface.SetValue(AValue: Integer);
begin
fProp := AValue;
end;
var
ift: Tface;
iit: Iinter;
begin
ift := Tface.Create();
ift.prop := 13;
writeln(ift.prop);
iit := Tface.Create();
iit.prop := 29;
writeln(iit.prop);
end.
''';
procedure TE2EClasses2Tests.TestRun_InterfaceProperty_CaseMismatchAndUses;
var Output: string; RCode: Integer;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
AssertTrue('compile+run (qbe)',
CompileAndRunWithRTLDebugOn(beQBE, SrcIntfPropCaseUses, Output, RCode, False));
AssertEquals('exit code (qbe)', 0, RCode);
AssertEquals('output (qbe)', '13' + LE + '29' + LE, Output);
AssertTrue('compile+run (native)',
CompileAndRunWithRTLDebugOn(beNative, SrcIntfPropCaseUses, Output, RCode, False));
AssertEquals('exit code (native)', 0, RCode);
AssertEquals('output (native)', '13' + LE + '29' + LE, Output);
end;
initialization
RegisterTest(TE2EClasses2Tests);

191
compiler/src/test/pascal/cp.test.interfaces.pas
View file

@ -102,6 +102,17 @@ type
{ Regression — interface field shadowing a same-named global }
{ ------------------------------------------------------------------ }
procedure TestSemantic_InterfaceField_ShadowsGlobal_OK;
{ ------------------------------------------------------------------ }
{ Interface properties }
{ ------------------------------------------------------------------ }
procedure TestParse_Interface_WithProperty;
procedure TestSemantic_InterfaceProperty_Registered;
procedure TestSemantic_InterfaceProperty_UnknownAccessor_RaisesError;
procedure TestSemantic_InterfaceProperty_WriteToReadOnly_RaisesError;
procedure TestSemantic_InterfaceProperty_InheritedFromParent_OK;
procedure TestCodegen_InterfacePropertyRead_DispatchesGetter;
procedure TestCodegen_InterfacePropertyWrite_DispatchesSetter;
end;
implementation
@ -1193,6 +1204,186 @@ begin
Pos('add $r, 16', IR) > 0);
end;
const
SrcIntfProperty =
'''
program P;
type
IInter = interface
function GetValue(): Integer;
procedure SetValue(AValue: Integer);
property Value: Integer read GetValue write SetValue;
end;
TFace = class(TObject, IInter)
FVal: Integer;
function GetValue(): Integer;
procedure SetValue(AValue: Integer);
end;
function TFace.GetValue(): Integer;
begin
Result := FVal;
end;
procedure TFace.SetValue(AValue: Integer);
begin
FVal := AValue;
end;
var
I: IInter;
begin
I := TFace.Create();
I.Value := 13;
WriteLn(I.Value);
end.
''';
procedure TInterfaceTests.TestParse_Interface_WithProperty;
var Prog: TProgram;
begin
Prog := ParseSrc(SrcIntfProperty);
AssertNotNil('interface with property parses', Prog);
Prog.Free();
end;
procedure TInterfaceTests.TestSemantic_InterfaceProperty_Registered;
var
Prog: TProgram;
Sym: TSymbol;
Intf: TInterfaceTypeDesc;
begin
Prog := AnalyseSrc(SrcIntfProperty);
try
Sym := Prog.SymbolTable.Lookup('IInter');
AssertNotNil('IInter registered', Sym);
Intf := TInterfaceTypeDesc(Sym.TypeDesc);
AssertNotNil('property Value found', Intf.FindProperty('Value'));
AssertEquals('read accessor', 'GetValue', Intf.FindProperty('Value').ReadMethod);
AssertEquals('write accessor', 'SetValue', Intf.FindProperty('Value').WriteMethod);
finally
Prog.Free();
end;
end;
procedure TInterfaceTests.TestSemantic_InterfaceProperty_UnknownAccessor_RaisesError;
var
Prog: TProgram;
A: TSemanticAnalyser;
Got: Boolean;
begin
Prog := ParseSrc('''
program P;
type
IInter = interface
function GetValue(): Integer;
property Value: Integer read NoSuchMethod;
end;
begin
end.
''');
A := TSemanticAnalyser.Create();
Got := False;
try
try
A.Analyse(Prog);
except
on E: ESemanticError do Got := True;
end;
finally
A.Free();
Prog.Free();
end;
AssertTrue('unknown accessor rejected', Got);
end;
procedure TInterfaceTests.TestSemantic_InterfaceProperty_WriteToReadOnly_RaisesError;
var
Prog: TProgram;
A: TSemanticAnalyser;
Got: Boolean;
begin
Prog := ParseSrc('''
program P;
type
IInter = interface
function GetValue(): Integer;
property Value: Integer read GetValue;
end;
TFace = class(TObject, IInter)
function GetValue(): Integer;
end;
function TFace.GetValue(): Integer;
begin
Result := 1;
end;
var I: IInter;
begin
I := TFace.Create();
I.Value := 5;
end.
''');
A := TSemanticAnalyser.Create();
Got := False;
try
try
A.Analyse(Prog);
except
on E: ESemanticError do Got := True;
end;
finally
A.Free();
Prog.Free();
end;
AssertTrue('write to read-only interface property rejected', Got);
end;
procedure TInterfaceTests.TestSemantic_InterfaceProperty_InheritedFromParent_OK;
var
Prog: TProgram;
Sym: TSymbol;
Intf: TInterfaceTypeDesc;
begin
Prog := AnalyseSrc('''
program P;
type
IBase = interface
function GetValue(): Integer;
property Value: Integer read GetValue;
end;
IChild = interface(IBase)
procedure Extra();
end;
begin
end.
''');
try
Sym := Prog.SymbolTable.Lookup('IChild');
Intf := TInterfaceTypeDesc(Sym.TypeDesc);
AssertNotNil('child sees parent property', Intf.FindProperty('Value'));
finally
Prog.Free();
end;
end;
procedure TInterfaceTests.TestCodegen_InterfacePropertyRead_DispatchesGetter;
var IR: string;
begin
IR := GenIR(SrcIntfProperty);
{ Property read lowers to an itab-dispatched getter: the itab slot is
loaded and called indirectly — the IR must load from the _itab slot. }
AssertTrue('reads receiver itab slot', Pos('_itab', IR) > 0);
AssertTrue('indirect call through function pointer temp',
Pos('=w call %', IR) > 0);
end;
procedure TInterfaceTests.TestCodegen_InterfacePropertyWrite_DispatchesSetter;
var IR: string;
begin
IR := GenIR(SrcIntfProperty);
{ Property write lowers to an itab-dispatched setter call with the value
as the single argument after Self. }
AssertTrue('setter dispatched with value argument',
Pos('call %', IR) > 0);
end;
initialization
RegisterTest(TInterfaceTests);

41
compiler/src/test/pascal/cp.test.unitinterface.pas
View file

@ -246,6 +246,7 @@ type
procedure TestRoundTrip_Record;
procedure TestRoundTrip_Class_WithVirtualMethod;
procedure TestRoundTrip_Interface;
procedure TestRoundTrip_Interface_WithProperty;
procedure TestRoundTrip_ProceduralType;
procedure TestRoundTrip_Metadata_UsedUnits_SourceFile;
procedure TestRoundTrip_GenericClass_TemplateParams;
@ -2985,6 +2986,46 @@ begin
end;
end;
procedure TIfaceIOTests.TestRoundTrip_Interface_WithProperty;
const
SRC =
'unit U;' + #10 +
'interface' + #10 +
'type IValued = interface' + #10 +
' function GetValue(): Integer;' + #10 +
' procedure SetValue(AValue: Integer);' + #10 +
' property Value: Integer read GetValue write SetValue;' + #10 +
'end;' + #10 +
'implementation end.' + #10;
var
Iface, Round: TUnitInterface;
Buf: string;
E: TTypeEntry;
P: TPropertyDecl;
begin
Iface := ParseAnalyseAndExport(SRC);
try
Buf := WriteUnitInterface(Iface);
Round := ReadUnitInterface(Buf);
try
E := Round.FindType('IValued');
AssertTrue('IValued present', E <> nil);
AssertTrue('is interface', E.Def is TInterfaceTypeDef);
AssertEquals('2 methods', 2, TInterfaceTypeDef(E.Def).Methods.Count);
AssertEquals('1 property', 1, TInterfaceTypeDef(E.Def).Properties.Count);
P := TPropertyDecl(TInterfaceTypeDef(E.Def).Properties.Items[0]);
AssertEquals('property name', 'Value', P.Name);
AssertEquals('property type', 'Integer', P.TypeName);
AssertEquals('read accessor', 'GetValue', P.ReadName);
AssertEquals('write accessor', 'SetValue', P.WriteName);
finally
Round.Free();
end;
finally
Iface.Free();
end;
end;
procedure TIfaceIOTests.TestRoundTrip_ProceduralType;
const
SRC =

9
docs/grammar.ebnf
View file

@ -298,17 +298,22 @@ GenericClassDef
END
;
(* Interface members are method signatures and properties. Property
* accessors must name methods of the interface (or an inherited one) —
* interfaces have no fields, so field-backed accessors cannot exist.
* I.Prop reads lower to the getter dispatch; I.Prop := V lowers to the
* setter dispatch through the itab. *)
InterfaceDef
= INTERFACE
[ LPAREN IDENT RPAREN ] (* optional parent interface *)
MethodSignatureList
{ MethodSignature | PropertyDecl }
END
;
GenericInterfaceDef
= INTERFACE
[ LPAREN IDENT RPAREN ] (* optional parent interface *)
MethodSignatureList
{ MethodSignature | PropertyDecl }
END
;

42
docs/language-rationale.adoc
View file

@ -3524,3 +3524,45 @@ matches the C math library signatures the builtins lower to.
represents every `Integer` exactly; `Single` does not (24-bit
mantissa). Precision should not silently depend on the argument's
declared integer width.
== Interface Properties
=== Decision
Interfaces may declare properties. Accessors must be methods of the
interface itself or an inherited parent interface — interfaces have no
fields, so field-backed accessors cannot exist:
[source,pascal]
----
type
IValued = interface
function GetValue(): Integer;
procedure SetValue(AValue: Integer);
property Value: Integer read GetValue write SetValue;
end;
----
`I.Value` lowers to the getter dispatched through the itab; `I.Value := X`
lowers to the setter dispatch with `X` as the single argument. Properties
are pure compile-time sugar: they occupy no itab slots, change no layout,
and have no ARC implications beyond the underlying method calls. Child
interfaces see inherited properties. Read-only (`read` only) and
write-only (`write` only) properties are supported; accessing the missing
direction is a compile-time error.
=== Rationale
Both FPC and Delphi support interface properties with identical syntax —
there is no dialect fork to choose from. Without them, interface
consumers are forced back to raw getter/setter calls even when the
implementing class exposes a property, which defeats the purpose of
publishing the interface as the API surface.
=== Limitations (v1)
* Property access requires a plain interface-typed variable as the
receiver; access through record/class fields holding interfaces or
through chained expressions is not yet wired.
* Indexed and default array properties in interfaces are not yet
supported.

20
tools/bif-coverage/bif-coverage.status
View file

@ -178,25 +178,25 @@ TFieldAssignment.PropIndexExpr serialise
TFieldAssignment.PropOwnerType safe
TFieldAssignment.IsElemWrite safe
# TStaticSubscriptAssign (uAST.pas:370)
# TStaticSubscriptAssign (uAST.pas:375)
TStaticSubscriptAssign.ArrayName serialise
TStaticSubscriptAssign.IndexExpr serialise
TStaticSubscriptAssign.ValueExpr serialise
TStaticSubscriptAssign.IsGlobal safe
TStaticSubscriptAssign.IsImplicitSelf safe
# TPointerWriteStmt (uAST.pas:383)
# TPointerWriteStmt (uAST.pas:388)
TPointerWriteStmt.PtrExpr serialise
TPointerWriteStmt.ValExpr serialise
# TProcCall (uAST.pas:391)
# TProcCall (uAST.pas:396)
TProcCall.Name serialise
TProcCall.Args serialise
TProcCall.IsImplicitSelfMethod safe
TProcCall.IsIndirectCall safe
TProcCall.IndirectCallIsGlobal safe
# TFuncCallExpr (uAST.pas:404)
# TFuncCallExpr (uAST.pas:409)
TFuncCallExpr.Name serialise
TFuncCallExpr.Args serialise
TFuncCallExpr.IsImplicitSelfMethod safe
@ -206,18 +206,18 @@ TFuncCallExpr.IsBuiltinHasClassAttr safe
TFuncCallExpr.HasClassAttrClass safe
TFuncCallExpr.HasClassAttrAttr safe
# TIndirectFuncCallExpr (uAST.pas:430)
# TIndirectFuncCallExpr (uAST.pas:435)
TIndirectFuncCallExpr.CalleeExpr serialise
TIndirectFuncCallExpr.Args serialise
# TDerefExpr (uAST.pas:440)
# TDerefExpr (uAST.pas:445)
TDerefExpr.Expr serialise
# TAddrOfExpr (uAST.pas:447)
# TAddrOfExpr (uAST.pas:452)
TAddrOfExpr.Expr serialise
TAddrOfExpr.ResolvedFreeRoutine safe
# TMethodCallStmt (uAST.pas:459)
# TMethodCallStmt (uAST.pas:464)
TMethodCallStmt.ObjectName serialise
TMethodCallStmt.Name serialise
TMethodCallStmt.Args serialise
@ -228,11 +228,11 @@ TMethodCallStmt.IsVarParam safe
TMethodCallStmt.IsBuiltinToString safe
TMethodCallStmt.IsProcFieldCall safe
# TInheritedCallStmt (uAST.pas:486)
# TInheritedCallStmt (uAST.pas:491)
TInheritedCallStmt.Name serialise
TInheritedCallStmt.Args serialise
# TMethodCallExpr (uAST.pas:676)
# TMethodCallExpr (uAST.pas:681)
TMethodCallExpr.ObjectName serialise
TMethodCallExpr.Name serialise
TMethodCallExpr.Args serialise