parser: allow readonly storage and results for untyped constref

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;
 
 

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
+        { 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);
         push_addr_para;

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;
+  Expected: UInt32;
+
+begin
+  Expected := $12345678;
+  Move(Expected, Data, SizeOf(Expected));
+  if FirstByteAsDWord(Data) <> Expected then
+    Halt(1);
+  writeln('ok');
+end.

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.

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.

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.