This patch fixes an error in an assignmen statement to an entity of a mutable
type (variable or in-out parameter) when the righ-hand side of the assignment
is a conditioal expression, some of whose alternatives are aggregates. Prior
to this patch, not all components of the mutable object were properly
assigned the corresponding values of the aggregate.
Executing:
gnatmake -q bug
./bug
must yield:
local var 72
local var 42
in_out parameter 72
in_out parameter 42
---
with Ada.Text_IO;
procedure Bug is
type Yoyo (Exists : Boolean := False) is record
case Exists is
when False =>
null;
when True =>
Value : Integer := 5;
end case;
end record;
Var1 : Yoyo;
Var2 : Yoyo;
procedure Test (Condition : in Boolean;
Value : in Integer;
Yo : in out Yoyo) is
Var3 : Yoyo;
begin
Yo := (if Condition then
(Exists => True,
Value => Value)
else
(Exists => False));
Var3 := (case condition is
when True => (Exists => True, Value => Value),
when False => (Exists => False));
if Condition and then
Yo.Value /= Value then
Ada.Text_IO.Put_Line ("Compiler bug exposed");
end if;
if Condition then
Ada.Text_IO.Put_Line ("local var " & Integer'Image (Var3.Value));
end if;
end;
begin
Test (True, 72, Var1);
Test (True, 42, Var2);
Ada.Text_IO.Put_Line ("in_out parameter " & Var1.Value'Img);
Ada.Text_IO.Put_Line ("in_out parameter " & Var2.Value'Img);
Test (False, 1000, Var1);
end Bug;
Tested on x86_64-pc-linux-gnu, committed on trunk
2017-09-06 Ed Schonberg <[email protected]>
* sem_ch5.adb (Analyze_Assigment): If the left-hand side is an
entity of a mutable type and the right-hand side is a conditional
expression, resolve the alternatives of the conditional using
the base type of the target entity, because the alternatives
may have distinct subtypes. This is particularly relevant if
the alternatives are aggregates.
Index: sem_ch5.adb
===================================================================
--- sem_ch5.adb (revision 251789)
+++ sem_ch5.adb (working copy)
@@ -580,8 +580,27 @@
Set_Assignment_Type (Lhs, T1);
- Resolve (Rhs, T1);
+ -- If the target of the assignment is an entity of a mutable type
+ -- and the expression is a conditional expression, its alternatives
+ -- can be of different subtypes of the nominal type of the LHS, so
+ -- they must be resolved with the base type, given that their subtype
+ -- may differ frok that of the target mutable object.
+ if Is_Entity_Name (Lhs)
+ and then Ekind_In (Entity (Lhs),
+ E_Variable,
+ E_Out_Parameter,
+ E_In_Out_Parameter)
+ and then Is_Composite_Type (T1)
+ and then not Is_Constrained (Etype (Entity (Lhs)))
+ and then Nkind_In (Rhs, N_If_Expression, N_Case_Expression)
+ then
+ Resolve (Rhs, Base_Type (T1));
+
+ else
+ Resolve (Rhs, T1);
+ end if;
+
-- This is the point at which we check for an unset reference
Check_Unset_Reference (Rhs);
