When an object declaration as an indefinite type, the actual subtype of the
object is constructed from the expression itself. If the type is an unchecked
union such a subtype cannot be constructed because discriminants cannot be
retrieved from the expression. In this case, rewrite declaration as a renaming
declaration, where the back-end does not require a definite subtype.
Compiling and executing foo.adb must yield::
TRUE
FALSE
TRUE
'A'
11
100
---
with Text_IO; use Text_IO;
procedure Foo is
type Rec_Type (I : Integer ) is record
B : Boolean;
case I is
when 0 =>
null;
when 1 .. 10 =>
C : Character;
when others =>
N : Natural;
end case;
end record;
pragma Unchecked_Union (Rec_Type);
function Get (I : Integer) return Rec_Type is
begin
case I is
when 0 => return (I => 0, B => True);
when 1 .. 10 => return (I => 1, B => False, C => 'A');
when others => return (I => 11, B => True, N => abs I);
end case;
end Get;
procedure Nop (R : Rec_Type) is
begin
Put_Line (Boolean'Image (R.B));
end Nop;
R0 : constant Rec_Type := Get (0);
R1 : constant Rec_Type := Get (1);
R11 : constant Rec_Type := Get (11);
R100 : Rec_Type := Get (100);
begin
Nop (R0);
Nop (R1);
Nop (R11);
Put_Line (Character'Image (R1.C));
Put_Line (Integer'Image (R11.N));
Put_Line (Integer'Image (R100.N));
end Foo;
Tested on x86_64-pc-linux-gnu, committed on trunk
2014-10-20 Ed Schonberg <schonb...@adacore.com>
* sem_ch3.adb (Analyze_Object_Declaration): If the type is
an unconstrained unchecked_union type, rewrite declaration
as a renaming to prevent attempt to retrieve non- existent
discriminants from expression.
Index: sem_ch3.adb
===================================================================
--- sem_ch3.adb (revision 216476)
+++ sem_ch3.adb (working copy)
@@ -3839,6 +3839,32 @@
elsif GNATprove_Mode then
null;
+ -- If the type is an unchecked union, no subtype can be built from
+ -- the expression. Rewrite declaration as a renaming, which the
+ -- back-end can handle properly. This is a rather unusual case,
+ -- because most unchecked_union declarations have default values
+ -- for discriminants and are thus unconstrained.
+
+ elsif Is_Unchecked_Union (T) then
+ if Constant_Present (N)
+ or else Nkind (E) = N_Function_Call
+ then
+ Set_Ekind (Id, E_Constant);
+ else
+ Set_Ekind (Id, E_Variable);
+ end if;
+
+ Rewrite (N,
+ Make_Object_Renaming_Declaration (Loc,
+ Defining_Identifier => Id,
+ Subtype_Mark => New_Occurrence_Of (T, Loc),
+ Name => E));
+
+ Set_Renamed_Object (Id, E);
+ Freeze_Before (N, T);
+ Set_Is_Frozen (Id);
+ return;
+
else
Expand_Subtype_From_Expr (N, T, Object_Definition (N), E);
Act_T := Find_Type_Of_Object (Object_Definition (N), N);
