diff --git a/compiler/src/main/pascal/blaise.codegen.native.x86_64.pas b/compiler/src/main/pascal/blaise.codegen.native.x86_64.pas index c69d78e..f5e0068 100644 --- a/compiler/src/main/pascal/blaise.codegen.native.x86_64.pas +++ b/compiler/src/main/pascal/blaise.codegen.native.x86_64.pas @@ -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"). } 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 diff --git a/compiler/src/main/pascal/blaise.codegen.qbe.pas b/compiler/src/main/pascal/blaise.codegen.qbe.pas index 5835bd2..75508ed 100644 --- a/compiler/src/main/pascal/blaise.codegen.qbe.pas +++ b/compiler/src/main/pascal/blaise.codegen.qbe.pas @@ -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); diff --git a/compiler/src/main/pascal/uAST.pas b/compiler/src/main/pascal/uAST.pas index a6c59f1..aab3b91 100644 --- a/compiler/src/main/pascal/uAST.pas +++ b/compiler/src/main/pascal/uAST.pas @@ -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; diff --git a/compiler/src/main/pascal/uParser.pas b/compiler/src/main/pascal/uParser.pas index 783881b..0f932a9 100644 --- a/compiler/src/main/pascal/uParser.pas +++ b/compiler/src/main/pascal/uParser.pas @@ -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)); diff --git a/compiler/src/main/pascal/uSemantic.pas b/compiler/src/main/pascal/uSemantic.pas index 981fe3c..16726e3 100644 --- a/compiler/src/main/pascal/uSemantic.pas +++ b/compiler/src/main/pascal/uSemantic.pas @@ -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; diff --git a/compiler/src/main/pascal/uSemanticImport.pas b/compiler/src/main/pascal/uSemanticImport.pas index 04b2084..5fa892d 100644 --- a/compiler/src/main/pascal/uSemanticImport.pas +++ b/compiler/src/main/pascal/uSemanticImport.pas @@ -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 diff --git a/compiler/src/main/pascal/uSymbolTable.pas b/compiler/src/main/pascal/uSymbolTable.pas index 99dc083..203f73a 100644 --- a/compiler/src/main/pascal/uSymbolTable.pas +++ b/compiler/src/main/pascal/uSymbolTable.pas @@ -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 diff --git a/compiler/src/main/pascal/uUnitInterfaceIO.pas b/compiler/src/main/pascal/uUnitInterfaceIO.pas index 8afe666..2cfe5d0 100644 --- a/compiler/src/main/pascal/uUnitInterfaceIO.pas +++ b/compiler/src/main/pascal/uUnitInterfaceIO.pas @@ -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; diff --git a/compiler/src/test/pascal/cp.test.e2e.classes2.pas b/compiler/src/test/pascal/cp.test.e2e.classes2.pas index bf2bd8a..8a9ece4 100644 --- a/compiler/src/test/pascal/cp.test.e2e.classes2.pas +++ b/compiler/src/test/pascal/cp.test.e2e.classes2.pas @@ -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); diff --git a/compiler/src/test/pascal/cp.test.interfaces.pas b/compiler/src/test/pascal/cp.test.interfaces.pas index bcc8de4..7c6cf9e 100644 --- a/compiler/src/test/pascal/cp.test.interfaces.pas +++ b/compiler/src/test/pascal/cp.test.interfaces.pas @@ -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); diff --git a/compiler/src/test/pascal/cp.test.unitinterface.pas b/compiler/src/test/pascal/cp.test.unitinterface.pas index 9e235a5..ac3393f 100644 --- a/compiler/src/test/pascal/cp.test.unitinterface.pas +++ b/compiler/src/test/pascal/cp.test.unitinterface.pas @@ -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 = diff --git a/docs/grammar.ebnf b/docs/grammar.ebnf index 31abf38..6fc5aa1 100644 --- a/docs/grammar.ebnf +++ b/docs/grammar.ebnf @@ -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 ; diff --git a/docs/language-rationale.adoc b/docs/language-rationale.adoc index 674907a..4dd387f 100644 --- a/docs/language-rationale.adoc +++ b/docs/language-rationale.adoc @@ -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. diff --git a/tools/bif-coverage/bif-coverage.status b/tools/bif-coverage/bif-coverage.status index 236f247..561e15d 100644 --- a/tools/bif-coverage/bif-coverage.status +++ b/tools/bif-coverage/bif-coverage.status @@ -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