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 55f8299..9dbed15 100644 --- a/compiler/src/main/pascal/blaise.codegen.native.x86_64.pas +++ b/compiler/src/main/pascal/blaise.codegen.native.x86_64.pas @@ -6155,6 +6155,17 @@ begin { Open-array element read: A[I] where A is an open-array parameter. The data pointer lives in the _var_A slot (not _var_A_high). } + { Indexed/default property read: Obj.Items[I] or Obj[I] (default property) — + semantic has folded the index into StrExpr (a TFieldAccessExpr with PropRead + + PropIndexExpr), leaving AExpr.IndexExpr nil. Delegate to the StrExpr. } + if (AExpr is TStringSubscriptExpr) and + (TStringSubscriptExpr(AExpr).StrExpr is TFieldAccessExpr) and + (TFieldAccessExpr(TStringSubscriptExpr(AExpr).StrExpr).PropRead <> nil) then + begin + Self.EmitExprToEax(TStringSubscriptExpr(AExpr).StrExpr); + Exit; + end; + if (AExpr is TStringSubscriptExpr) and (TStringSubscriptExpr(AExpr).StrExpr is TIdentExpr) and (TStringSubscriptExpr(AExpr).StrExpr.ResolvedType <> nil) and @@ -10967,6 +10978,28 @@ begin if AStmt is TStaticSubscriptAssign then begin SSA := TStaticSubscriptAssign(AStmt); + { Default array property write: Obj[I] := V lowered to a setter call. + Args: receiver %rdi, index %rsi, value %rdx (System V). Evaluate value + and index first (they clobber registers), stash on the stack, then load + the receiver and reload the args. } + if SSA.PropWriteInfo <> nil then + begin + Self.EmitExprToEax(SSA.ValueExpr); { value } + Self.Emit(#9'pushq %rax'); + Self.EmitExprToEax(SSA.IndexExpr); { index } + Self.Emit(#9'pushq %rax'); + if Self.IsLocal(SSA.ArrayName) then + Self.Emit(Format(#9'movq %s, %%rdi', [Self.VarOperand(SSA.ArrayName)])) + else + Self.Emit(Format(#9'movq %s(%%rip), %%rdi', [SSA.ArrayName])); + if SSA.IsVarParam then + Self.Emit(#9'movq (%rdi), %rdi'); { var-param: slot -> instance } + Self.Emit(#9'popq %rsi'); { index } + Self.Emit(#9'popq %rdx'); { value } + Self.EmitPropAccessorCallNative(SSA.PropOwnerType, + TPropertyInfo(SSA.PropWriteInfo).WriteMethod, SSA.PropAccessorVSlot); + Exit; + end; if (SSA.ResolvedArrayType <> nil) and (SSA.ResolvedArrayType.Kind = tyPChar) then begin diff --git a/compiler/src/main/pascal/blaise.codegen.qbe.pas b/compiler/src/main/pascal/blaise.codegen.qbe.pas index 557ca32..735844f 100644 --- a/compiler/src/main/pascal/blaise.codegen.qbe.pas +++ b/compiler/src/main/pascal/blaise.codegen.qbe.pas @@ -13976,7 +13976,38 @@ var ItabTemp: string; { interface RHS itab slot or itab name literal } ItabPtr: string; { ElemPtr + 8, target of itab store } IntfDesc: TInterfaceTypeDesc; + DefProp: TPropertyInfo; + RecvTemp: string; + IdxQType: string; + ValQType: string; + PropTgt: string; begin + { Default array property write: Obj[I] := V lowered to a setter call. + Semantic set PropWriteInfo; ArrayName is the receiver, IndexExpr/ValueExpr + are the setter args. Dispatch through the vtable when the setter is + virtual (PropAccessorVSlot >= 0), else a static call. } + if AStmt.PropWriteInfo <> nil then + begin + DefProp := TPropertyInfo(AStmt.PropWriteInfo); + RecvTemp := AllocTemp(); + EmitLine(Format(' %s =l loadl %s', + [RecvTemp, VarRef(AStmt.ArrayName, AStmt.IsGlobal)])); + if AStmt.IsVarParam then + begin + ElemPtr := AllocTemp(); + EmitLine(Format(' %s =l loadl %s', [ElemPtr, RecvTemp])); + RecvTemp := ElemPtr; + end; + IdxW := EmitExpr(AStmt.IndexExpr); + IdxQType := QbeTypeOf(DefProp.IndexTypeDesc); + ElemVal := EmitExpr(AStmt.ValueExpr); + ValQType := QbeTypeOf(DefProp.TypeDesc); + PropTgt := PropAccessorTarget(AStmt.PropOwnerType, DefProp.WriteMethod, + AStmt.PropAccessorVSlot, RecvTemp); + EmitLine(Format(' call %s(l %s, %s %s, %s %s)', + [PropTgt, RecvTemp, IdxQType, IdxW, ValQType, ElemVal])); + Exit; + end; { PChar subscript write: P[I] := Integer — storeb at ptr + I. EmitByteRhs short-circuits Chr(N) so we store N directly instead of truncating the low byte of a _Chr-allocated string pointer. } diff --git a/compiler/src/main/pascal/uAST.pas b/compiler/src/main/pascal/uAST.pas index 42328bb..d85b0a1 100644 --- a/compiler/src/main/pascal/uAST.pas +++ b/compiler/src/main/pascal/uAST.pas @@ -430,6 +430,13 @@ type [Unretained] ResolvedArrayType: TTypeDesc; { set by uSemantic; not owned } IsImplicitSelf: Boolean; { set by uSemantic — ArrayName is an array-typed field of Self } [Unretained] ImplicitFieldInfo: TFieldInfo; { non-owned — the Self field; set with IsImplicitSelf } + { Default array property write: Obj[I] := V where Obj's class has a + `default` indexed property — lowered to a setter call. When + PropWriteInfo is non-nil, ArrayName is the receiver variable, IndexExpr + is the index arg, ValueExpr is the value arg. } + [Unretained] PropWriteInfo: TObject; { TPropertyInfo — non-owned; nil = plain array write } + PropOwnerType: string; { declaring class of the setter } + PropAccessorVSlot: Integer; { setter vtable slot, -1 = static call } destructor Destroy; override; end; @@ -846,6 +853,7 @@ type WriteName: string; { backing field or setter method; '' = read-only } IndexParamName: string; { '' = non-indexed property } IndexTypeName: string; { type name of the index parameter; '' when non-indexed } + IsDefault: Boolean; { declared with the `default` directive (Obj[I] sugar) } end; TClassTypeDef = class(TASTTypeDef) diff --git a/compiler/src/main/pascal/uParser.pas b/compiler/src/main/pascal/uParser.pas index ff4d028..0b32aaf 100644 --- a/compiler/src/main/pascal/uParser.pas +++ b/compiler/src/main/pascal/uParser.pas @@ -1992,6 +1992,16 @@ begin Advance(); end; Expect(tkSemicolon); + { Optional `default` directive on an indexed property — marks it as the + class's default array property, enabling Obj[I] sugar. It appears as a + separate directive after the property's own semicolon: + property Items[I: Integer]: T read Get write Put; default; } + if Check(tkIdent) and SameText(FCurrent.Value, 'default') then + begin + Result.IsDefault := True; + Advance(); + Expect(tkSemicolon); + end; except Result.Free(); raise; diff --git a/compiler/src/main/pascal/uSemantic.pas b/compiler/src/main/pascal/uSemantic.pas index ef3fc6a..0194305 100644 --- a/compiler/src/main/pascal/uSemantic.pas +++ b/compiler/src/main/pascal/uSemantic.pas @@ -2537,6 +2537,7 @@ begin PropInfo.IndexParamName := NewPDecl.IndexParamName; if NewPDecl.IndexTypeName <> '' then PropInfo.IndexTypeDesc := FindTypeOrInstantiate(NewPDecl.IndexTypeName); + PropInfo.IsDefault := NewPDecl.IsDefault; RT.AddProperty(PropInfo); end; @@ -4264,6 +4265,7 @@ begin PropInfo.IndexParamName := PropDecl.IndexParamName; if PropDecl.IndexTypeName <> '' then PropInfo.IndexTypeDesc := FTable.FindType(PropDecl.IndexTypeName); + PropInfo.IsDefault := PropDecl.IsDefault; RT.AddProperty(PropInfo); end; @@ -10165,6 +10167,8 @@ function TSemanticAnalyser.AnalyseStringSubscriptExpr(AExpr: TStringSubscriptExp var StrType, IdxType: TTypeDesc; FldAccess: TFieldAccessExpr; + DefProp: TPropertyInfo; + DefFA: TFieldAccessExpr; begin StrType := AnalyseExpr(AExpr.StrExpr); { Indexed property read: Obj.Prop[I] where Prop is a method-backed indexed property } @@ -10229,6 +10233,31 @@ begin AExpr.ResolvedType := Result; Exit; end; + { Default array property: Obj[I] on a class/record with a `default` indexed + property is sugar for Obj.[I]. Synthesise the field-access for + the default property's getter, analyse it (which sets PropRead / owner / + vtable slot), and reuse the indexed-property-read path above. } + if (StrType.Kind in [tyClass, tyRecord]) then + begin + DefProp := TRecordTypeDesc(StrType).FindDefaultProperty(); + if (DefProp <> nil) and (DefProp.ReadMethod <> '') then + begin + DefFA := TFieldAccessExpr.Create(); + DefFA.Line := AExpr.Line; + DefFA.Col := AExpr.Col; + DefFA.Base := AExpr.StrExpr; { transfer ownership of the receiver expr } + DefFA.FieldName := DefProp.Name; + { Attach the index BEFORE analysis — the indexed-property field-access + path expects PropIndexExpr to be present. } + DefFA.PropIndexExpr := AExpr.IndexExpr; + AExpr.IndexExpr := nil; + AExpr.StrExpr := DefFA; { StrExpr now owns DefFA } + AnalyseExpr(DefFA); { sets DefFA.PropRead / PropOwnerType / VSlot } + Result := DefProp.TypeDesc; + AExpr.ResolvedType := Result; + Exit; + end; + end; if not StrType.IsString() then SemanticError( Format('String subscript ''[]'' requires a string expression, got ''%s''', @@ -10335,6 +10364,7 @@ var ValType: TTypeDesc; BaseInfo: TFieldInfo; ElemT: TTypeDesc; + DefProp: TPropertyInfo; begin { Chained / multi-dimensional element write: BaseExpr yields the inner array (A[I][J] := V, lowered from A[I, J] := V or written directly). @@ -10393,6 +10423,30 @@ begin AStmt.Line, AStmt.Col); end; AStmt.ArrayName := Sym.Name; { normalise to declared casing } + { Default array property write: Obj[I] := V where Obj's class/record has a + `default` indexed property with a setter — lower to a setter call. } + if Sym.TypeDesc.Kind in [tyClass, tyRecord] then + begin + DefProp := TRecordTypeDesc(Sym.TypeDesc).FindDefaultProperty(); + if (DefProp <> nil) and (DefProp.WriteMethod <> '') then + begin + AStmt.IsGlobal := Sym.IsGlobal; + AStmt.IsVarParam := Sym.Kind = skVarParameter; + AStmt.PropWriteInfo := DefProp; + AStmt.PropOwnerType := + PropAccessorOwner(TRecordTypeDesc(Sym.TypeDesc).Name, DefProp.WriteMethod); + AStmt.PropAccessorVSlot := + PropAccessorVSlot(TRecordTypeDesc(Sym.TypeDesc).Name, DefProp.WriteMethod); + IdxType := AnalyseExpr(AStmt.IndexExpr); + if (DefProp.IndexTypeDesc <> nil) then + CheckTypesMatch(DefProp.IndexTypeDesc, IdxType, 'default property index', + AStmt.Line, AStmt.Col); + ValType := AnalyseExpr(AStmt.ValueExpr); + CheckTypesMatch(DefProp.TypeDesc, ValType, 'default property assignment', + AStmt.Line, AStmt.Col); + Exit; + end; + end; { PChar subscript write: P[I] := Integer — storeb at ptr + I } if Sym.TypeDesc.Kind = tyPChar then begin diff --git a/compiler/src/main/pascal/uSymbolTable.pas b/compiler/src/main/pascal/uSymbolTable.pas index d33809d..04ed431 100644 --- a/compiler/src/main/pascal/uSymbolTable.pas +++ b/compiler/src/main/pascal/uSymbolTable.pas @@ -218,6 +218,7 @@ type WriteMethod: string; { '' if field-backed write or read-only } IndexParamName: string; { '' = non-indexed property } [Unretained] IndexTypeDesc: TTypeDesc; { not owned; non-nil when IndexParamName <> '' } + IsDefault: Boolean; { declared with the `default` directive (Obj[I] sugar) } end; { Type descriptor for zero-GUID interface types (Phase 3). } @@ -294,6 +295,7 @@ type procedure AddProperty(AProp: TPropertyInfo); function FindProperty(const AName: string): TPropertyInfo; function FindIndexedProperty: TPropertyInfo; + function FindDefaultProperty: TPropertyInfo; { Custom attribute tracking } procedure AddClassAttribute(const AName: string); @@ -1007,6 +1009,27 @@ begin Result := nil; end; +function TRecordTypeDesc.FindDefaultProperty: TPropertyInfo; +{ Returns the property marked `default` (Obj[I] sugar), walking the inheritance + chain; nil if the class has no default property. } +var + I: Integer; + P: TPropertyInfo; + Walk: TRecordTypeDesc; +begin + Walk := Self; + while Walk <> nil do + begin + for I := 0 to Walk.FProperties.Count - 1 do + begin + P := TPropertyInfo(Walk.FProperties.Items[I]); + if P.IsDefault then Exit(P); + end; + Walk := Walk.Parent; + end; + Result := nil; +end; + procedure TRecordTypeDesc.AddClassAttribute(const AName: string); begin FClassAttributes.Add(AName); diff --git a/compiler/src/main/pascal/uUnitInterfaceIO.pas b/compiler/src/main/pascal/uUnitInterfaceIO.pas index f983d42..5660b73 100644 --- a/compiler/src/main/pascal/uUnitInterfaceIO.pas +++ b/compiler/src/main/pascal/uUnitInterfaceIO.pas @@ -311,7 +311,8 @@ begin EncodeLpstr(P.ReadName) + EncodeLpstr(P.WriteName) + EncodeLpstr(P.IndexParamName) + - EncodeLpstr(P.IndexTypeName); + EncodeLpstr(P.IndexTypeName) + + EncodeBool(P.IsDefault); end; end; @@ -1807,6 +1808,7 @@ begin P.WriteName := ReadLpstrAt(AText, APos); P.IndexParamName := ReadLpstrAt(AText, APos); P.IndexTypeName := ReadLpstrAt(AText, APos); + P.IsDefault := DecodeBool(AText, APos); ATarget.Add(P); end; end; diff --git a/compiler/src/test/pascal/cp.test.e2e.properties.pas b/compiler/src/test/pascal/cp.test.e2e.properties.pas index 2ba5c83..1c579e9 100644 --- a/compiler/src/test/pascal/cp.test.e2e.properties.pas +++ b/compiler/src/test/pascal/cp.test.e2e.properties.pas @@ -30,6 +30,11 @@ type procedure TestRun_DefaultValueIsZero; procedure TestRun_InheritedProperty; procedure TestRun_IndexedProperty; + { Default array property: Obj[I] sugar (read + write), string element, and + inheritance of the default property from a base class. } + procedure TestRun_DefaultProperty_ReadWrite; + procedure TestRun_DefaultProperty_StringElement; + procedure TestRun_DefaultProperty_Inherited; { Static-array field accessed from inside a method (implicit Self). } procedure TestRun_StaticArrayField_ReadInMethod; procedure TestRun_StaticArrayField_WriteInMethod; @@ -215,6 +220,80 @@ begin AssertRunsOnAll(SrcArrOfRecord, '77' + LE, 0); end; +const + SrcDefaultRW = ''' + program P; + type + TVec = class + FData: array[0..4] of Integer; + function Get(i: Integer): Integer; begin Result := FData[i] end; + procedure Put(i: Integer; v: Integer); begin FData[i] := v end; + property Items[i: Integer]: Integer read Get write Put; default; + end; + var v: TVec; + begin + v := TVec.Create; + v[0] := 10; v[1] := 20; + WriteLn(v[0] + v[1]); + v := nil + end. + '''; + + SrcDefaultStr = ''' + program P; + type + TBag = class + FData: array[0..2] of string; + function Get(i: Integer): string; begin Result := FData[i] end; + procedure Put(i: Integer; v: string); begin FData[i] := v end; + property Items[i: Integer]: string read Get write Put; default; + end; + var b: TBag; + begin + b := TBag.Create; + b[0] := 'foo'; b[1] := 'bar'; + WriteLn(b[0] + b[1]); + b := nil + end. + '''; + + SrcDefaultInherited = ''' + program P; + type + TBase = class + FData: array[0..2] of Integer; + function Get(i: Integer): Integer; begin Result := FData[i] end; + procedure Put(i: Integer; v: Integer); begin FData[i] := v end; + property Items[i: Integer]: Integer read Get write Put; default; + end; + TDerived = class(TBase) end; + var d: TDerived; + begin + d := TDerived.Create; + d[0] := 5; d[1] := 7; + WriteLn(d[0] + d[1]); + d := nil + end. + '''; + +procedure TE2EPropertyTests.TestRun_DefaultProperty_ReadWrite; +begin + if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end; + AssertRunsOnAll(SrcDefaultRW, '30' + LE, 0); +end; + +procedure TE2EPropertyTests.TestRun_DefaultProperty_StringElement; +begin + if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end; + AssertRunsOnAll(SrcDefaultStr, 'foobar' + LE, 0); +end; + +procedure TE2EPropertyTests.TestRun_DefaultProperty_Inherited; +begin + if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end; + AssertRunsOnAll(SrcDefaultInherited, '12' + LE, 0); +end; + initialization RegisterTest(TE2EPropertyTests); diff --git a/compiler/src/test/pascal/cp.test.properties.pas b/compiler/src/test/pascal/cp.test.properties.pas index acd7d2b..c678b54 100644 --- a/compiler/src/test/pascal/cp.test.properties.pas +++ b/compiler/src/test/pascal/cp.test.properties.pas @@ -70,6 +70,10 @@ type procedure TestCodegen_IndexedProperty_Read_EmitsGetterWithIndex; procedure TestCodegen_IndexedProperty_Write_EmitsSetterWithIndex; + { Default array property: Obj[I] lowers to the getter/setter call. } + procedure TestCodegen_DefaultProperty_Read_EmitsGetter; + procedure TestCodegen_DefaultProperty_Write_EmitsSetter; + { Regression: 'Outer.Inner.Indexed[Variable]' — chained base + indexed property read with a variable index. Previously crashed the codegen because the analyser skipped AnalyseExpr on PropIndexExpr in the @@ -588,6 +592,50 @@ begin AssertTrue('indexed write emits setter call', Pos('call $TList_Put', IR) > 0); end; +procedure TPropertyTests.TestCodegen_DefaultProperty_Read_EmitsGetter; +var + IR: string; +begin + IR := GenIR( + ''' + program P; + type + TVec = class + FD: array[0..3] of Integer; + function Get(i: Integer): Integer; begin Result := FD[i] end; + procedure Put(i: Integer; v: Integer); begin FD[i] := v end; + property Items[i: Integer]: Integer read Get write Put; default; + end; + var v: TVec; x: Integer; + begin v := TVec.Create(); x := v[2]; WriteLn(x) end. + ''' + ); + AssertTrue('default-property read emits getter call', + Pos('call $TVec_Get', IR) > 0); +end; + +procedure TPropertyTests.TestCodegen_DefaultProperty_Write_EmitsSetter; +var + IR: string; +begin + IR := GenIR( + ''' + program P; + type + TVec = class + FD: array[0..3] of Integer; + function Get(i: Integer): Integer; begin Result := FD[i] end; + procedure Put(i: Integer; v: Integer); begin FD[i] := v end; + property Items[i: Integer]: Integer read Get write Put; default; + end; + var v: TVec; + begin v := TVec.Create(); v[2] := 9 end. + ''' + ); + AssertTrue('default-property write emits setter call', + Pos('call $TVec_Put', IR) > 0); +end; + procedure TPropertyTests.TestCodegen_IndexedProperty_ChainedBase_VarIndex_Compiles; const Src = diff --git a/docs/grammar.ebnf b/docs/grammar.ebnf index c162d8d..cb1377a 100644 --- a/docs/grammar.ebnf +++ b/docs/grammar.ebnf @@ -405,6 +405,7 @@ PropertyDecl [ "read" IDENT ] [ "write" IDENT ] SEMICOLON + [ "default" SEMICOLON ] (* default array property *) ; (* If the index parameter is present, the property is indexed: @@ -412,7 +413,12 @@ PropertyDecl * Indexed reads emit a getter call with one extra argument (the index). * Indexed writes emit a setter call with two extra arguments (index, value). * Only a single index parameter is supported; multiple-index properties - * (as in Delphi) are not. *) + * (as in Delphi) are not. + * + * The optional "default" directive (only meaningful on an indexed property) + * marks it as the class's default array property, enabling the Obj[I] sugar: + * property Items[I: Integer]: T read Get write Put; default; + * Obj[I] then lowers to Obj.Items[I] (getter on read, setter on write). *) (* "property", "read", "write" are contextual soft keywords; they may be used * as identifiers outside a class body. *) diff --git a/docs/language-rationale.adoc b/docs/language-rationale.adoc index a1d027e..260fd16 100644 --- a/docs/language-rationale.adoc +++ b/docs/language-rationale.adoc @@ -755,6 +755,29 @@ the idiomatic subscript syntax the compiler source already uses. names in the declaration are more transparent and consistent with the existing non-indexed property design. +==== Default array property + +An indexed property may carry the `default` directive, marking it as the +class's default array property: + +---- +property Items[I: Integer]: T read Get write Put; default; +---- + +A subscript applied directly to an object of that class — `Obj[I]` — is then +sugar for `Obj.Items[I]`: it lowers to the getter on read and the setter on +write, exactly as the named form does. This is the mechanism behind the +familiar `List[i]` syntax. Resolution walks the inheritance chain, so a +default property declared on a base class is usable through a derived class. +The `default` flag is carried across units in the `.bif` interface so a +default property declared in one unit keeps its subscript sugar when the unit +is used elsewhere. + +Only one default property per class is meaningful (the first one found wins); +the directive is only valid on an indexed property. The accessor dispatch +honours `virtual`/`override` on the getter/setter, the same as a named indexed +property access. + --- === Constructor and Destructor Keywords diff --git a/tools/bif-coverage/bif-coverage.status b/tools/bif-coverage/bif-coverage.status index 1d6d030..da86317 100644 --- a/tools/bif-coverage/bif-coverage.status +++ b/tools/bif-coverage/bif-coverage.status @@ -194,6 +194,8 @@ TStaticSubscriptAssign.BaseExpr serialise TStaticSubscriptAssign.IsGlobal safe TStaticSubscriptAssign.IsVarParam safe TStaticSubscriptAssign.IsImplicitSelf safe +TStaticSubscriptAssign.PropOwnerType safe +TStaticSubscriptAssign.PropAccessorVSlot safe # TPointerWriteStmt (uAST.pas:420) TPointerWriteStmt.PtrExpr serialise