From ea539bf1d3e019d36b72a0ab9c8d07d0df02d6fb Mon Sep 17 00:00:00 2001 From: Mike Date: Sun, 6 Sep 2026 15:14:21 +0300 Subject: [PATCH 1/2] parser: accept constant expressions for constref parameters (fixes upstream#41766) A formal constref parameter, like an ordinary const, may bind to a constant expression, but the assignment check rejected it with "Can't assign values to const variable", and codegen materialized a non-reference actual only for const formals. Add valid_const to the check and materialize the actual for constref formals the same way as for const ones: both promise the callee an address. FPC issue: https://gitlab.com/freepascal.org/fpc/source/-/issues/41766 Co-Authored-By: Claude Fable 5.1 --- compiler/htypechk.pas | 2 +- compiler/ncgcal.pas | 6 ++++-- tests/webtbs/tw41766.pp | 27 +++++++++++++++++++++++++++ 3 files changed, 32 insertions(+), 3 deletions(-) create mode 100644 tests/webtbs/tw41766.pp diff --git a/compiler/htypechk.pas b/compiler/htypechk.pas index 2b7da5ab4fb..0592d03873b 100644 --- a/compiler/htypechk.pas +++ b/compiler/htypechk.pas @@ -2257,7 +2257,7 @@ (hp.resultdef.typ=classrefdef) then function valid_for_formal_constref(p : tnode; report_errors: boolean) : boolean; begin valid_for_formal_constref:=(p.resultdef.typ=formaldef) or - valid_for_assign(p,[valid_void,valid_range],report_errors); + valid_for_assign(p,[valid_void,valid_const,valid_range],report_errors); end; diff --git a/compiler/ncgcal.pas b/compiler/ncgcal.pas index 0716e4efb29..7e95b12a3d2 100644 --- a/compiler/ncgcal.pas +++ b/compiler/ncgcal.pas @@ -310,8 +310,10 @@ implementation begin if maybe_push_unused_para then exit; - { allow passing of a constant to a const formaldef } - if (parasym.varspez=vs_const) and + { allow passing of a constant to a const or constref formaldef: both + promise the callee an address, so a non-reference actual (a call + result, a folded constant) is materialized once for the call } + if (parasym.varspez in [vs_const,vs_constref]) and not(left.location.loc in [LOC_CREFERENCE,LOC_REFERENCE]) then hlcg.location_force_mem(current_asmdata.CurrAsmList,left.location,left.resultdef); push_addr_para; diff --git a/tests/webtbs/tw41766.pp b/tests/webtbs/tw41766.pp new file mode 100644 index 00000000000..1e8d66b8649 --- /dev/null +++ b/tests/webtbs/tw41766.pp @@ -0,0 +1,27 @@ +{$mode objfpc} + +function FirstDWord(constref Value): UInt32; +var + DWordValue: UInt32 absolute Value; +begin + Result := DWordValue; +end; + +function FirstByteAsDWord(constref Values): UInt32; +var + Bytes: array[Byte] of Byte absolute Values; +begin + Result := FirstDWord(Bytes[0]); +end; + +var + Data: array[Byte] of Byte; + +begin + Data[0] := $78; + Data[1] := $56; + Data[2] := $34; + Data[3] := $12; + if FirstByteAsDWord(Data) <> $12345678 then + Halt(1); +end. From b9e019f2e679ee89aa57c8ed7527a89607563cff Mon Sep 17 00:00:00 2001 From: Mike Date: Mon, 7 Sep 2026 12:34:14 +0300 Subject: [PATCH 2/2] Test constref storage, temporaries and rejection boundaries Make the original forwarding oracle endian-independent. Cover storage identity, register and managed results, forwarding and simultaneous temporaries; keep readonly-to-writable and scalar-literal rejection controls. Clarify valid_const scope without changing compiler behavior. --- compiler/ncgcal.pas | 6 +- tests/webtbs/tw41766.pp | 10 +-- tests/webtbs/tw41766a.pp | 136 +++++++++++++++++++++++++++++++++++++++ tests/webtbs/tw41766b.pp | 11 ++++ tests/webtbs/tw41766c.pp | 20 ++++++ 5 files changed, 175 insertions(+), 8 deletions(-) create mode 100644 tests/webtbs/tw41766a.pp create mode 100644 tests/webtbs/tw41766b.pp create mode 100644 tests/webtbs/tw41766c.pp diff --git a/compiler/ncgcal.pas b/compiler/ncgcal.pas index 7e95b12a3d2..d8c26ecd0d2 100644 --- a/compiler/ncgcal.pas +++ b/compiler/ncgcal.pas @@ -310,9 +310,9 @@ implementation begin if maybe_push_unused_para then exit; - { allow passing of a constant to a const or constref formaldef: both - promise the callee an address, so a non-reference actual (a call - result, a folded constant) is materialized once for the call } + { Both const and constref formaldefs promise the callee an address. + Materialize an accepted non-reference actual, such as a function + result, once for the call. Existing references keep their identity. } if (parasym.varspez in [vs_const,vs_constref]) and not(left.location.loc in [LOC_CREFERENCE,LOC_REFERENCE]) then hlcg.location_force_mem(current_asmdata.CurrAsmList,left.location,left.resultdef); diff --git a/tests/webtbs/tw41766.pp b/tests/webtbs/tw41766.pp index 1e8d66b8649..d881fbe4f23 100644 --- a/tests/webtbs/tw41766.pp +++ b/tests/webtbs/tw41766.pp @@ -16,12 +16,12 @@ function FirstByteAsDWord(constref Values): UInt32; var Data: array[Byte] of Byte; + Expected: UInt32; begin - Data[0] := $78; - Data[1] := $56; - Data[2] := $34; - Data[3] := $12; - if FirstByteAsDWord(Data) <> $12345678 then + Expected := $12345678; + Move(Expected, Data, SizeOf(Expected)); + if FirstByteAsDWord(Data) <> Expected then Halt(1); + writeln('ok'); end. diff --git a/tests/webtbs/tw41766a.pp b/tests/webtbs/tw41766a.pp new file mode 100644 index 00000000000..9258b6feac4 --- /dev/null +++ b/tests/webtbs/tw41766a.pp @@ -0,0 +1,136 @@ +{ %OPT=-O2 } +{$mode objfpc} + +{ Untyped constref: storage identity, materialization and forwarding are + different paths. Check the cross-product of value origin and consumer, + including types returned in integer/FP registers and managed temporaries. } + +var + Calls: LongInt; + +function Read32(constref Value): UInt32; +var + V: UInt32 absolute Value; +begin + Result := V; +end; + +function Forward32(constref Value): UInt32; +begin + Result := Read32(Value); +end; + +function TypedForward32(constref Value: UInt32): UInt32; +begin + Result := Forward32(Value); +end; + +function AddressOf(constref Value): Pointer; +begin + Result := @Value; +end; + +function ForwardAddress(constref Value): Pointer; +begin + Result := AddressOf(Value); +end; + +function Make32(Value: UInt32): UInt32; +begin + Inc(Calls); + Result := Value; +end; + +function CheckPair(constref A, B; ExpectedA, ExpectedB: UInt32): Boolean; +begin + Result := (Read32(A) = ExpectedA) and (Read32(B) = ExpectedB) and (@A <> @B); +end; + +function Read64(constref Value): Int64; +var + V: Int64 absolute Value; +begin + Result := V; +end; + +function Make64(Value: Int64): Int64; +begin + Inc(Calls); + Result := Value; +end; + +function ReadFloat(constref Value): Double; +var + V: Double absolute Value; +begin + Result := V; +end; + +function MakeFloat(Value: Double): Double; +begin + Inc(Calls); + Result := Value; +end; + +function ReadString(constref Value): AnsiString; +var + V: AnsiString absolute Value; +begin + Result := V; +end; + +function MakeString: AnsiString; +begin + Inc(Calls); + SetLength(Result, 3); + Result[1] := 'a'; + Result[2] := 'b'; + Result[3] := 'c'; +end; + +const + Value32: UInt32 = $87654321; +var + I: LongInt; + Local: UInt32; + Values: array of UInt32; + Rec: record + Value: UInt32; + end; +begin + Local := Value32; + Rec.Value := Value32; + SetLength(Values, 2); + Values[1] := Value32; + + { A real lvalue must not turn into a copy, even after forwarding. } + if AddressOf(Local) <> @Local then Halt(1); + if ForwardAddress(Rec.Value) <> @Rec.Value then Halt(2); + if ForwardAddress(Values[1]) <> @Values[1] then Halt(3); + if Forward32(Value32) <> Value32 then Halt(4); + if TypedForward32(Local) <> Value32 then Halt(5); + + for I := 0 to 7 do + begin + Calls := 0; + if Read32(Make32(Value32 + UInt32(I))) <> Value32 + UInt32(I) then Halt(6); + if Calls <> 1 then Halt(7); + Calls := 0; + if Forward32(Make32(UInt32(I) + UInt32(10))) <> UInt32(I + 10) then Halt(8); + if Calls <> 1 then Halt(9); + Calls := 0; + if TypedForward32(Make32(UInt32(I))) <> UInt32(I) then Halt(10); + if Calls <> 1 then Halt(11); + Calls := 0; + if not CheckPair(Make32(UInt32(I)), Make32(UInt32(I + 1)), I, I + 1) then Halt(16); + if Calls <> 2 then Halt(17); + end; + + { A typed const already has storage; a call result may need a temporary. } + Calls := 0; + if Read64(Make64(-$123456789AB)) <> -$123456789AB then Halt(12); + if ReadFloat(MakeFloat(1.25)) <> 1.25 then Halt(13); + if ReadString(MakeString) <> 'abc' then Halt(14); + if Calls <> 3 then Halt(15); + writeln('ok'); +end. diff --git a/tests/webtbs/tw41766b.pp b/tests/webtbs/tw41766b.pp new file mode 100644 index 00000000000..8b55e154c24 --- /dev/null +++ b/tests/webtbs/tw41766b.pp @@ -0,0 +1,11 @@ +{ %fail } +{$mode objfpc} + +{ Allowing readonly storage does not make scalar literals addressable. } +procedure Consume(constref Value); +begin +end; + +begin + Consume(UInt32(123)); +end. diff --git a/tests/webtbs/tw41766c.pp b/tests/webtbs/tw41766c.pp new file mode 100644 index 00000000000..cccd3c824b0 --- /dev/null +++ b/tests/webtbs/tw41766c.pp @@ -0,0 +1,20 @@ +{ %fail } +{$mode objfpc} + +{ Readonly storage can be forwarded as constref, never as writable var/out. } +procedure Mutate(var Value); +begin +end; + +procedure Clear(out Value); +begin +end; + +procedure Forward(constref Value: UInt32); +begin + Mutate(Value); + Clear(Value); +end; + +begin +end.