[multiple changes]
2016-04-20 Hristian Kirtchev <kirtchev@adacore.com> * sem_attr.ads Add new table Universal_Type_Attribute. * sem_util.adb (Yields_Universal_Type): Use a table lookup when checking attributes. 2016-04-20 Ed Schonberg <schonberg@adacore.com> * exp_aggr.adb (Init_Stored_Discriminants, Init_Visible_Discriminants): New procedures, subsidiary of Build_Record_Aggr_Code, to handle properly the construction of aggregates for a derived type that constrains some parent discriminants and renames others. From-SVN: r235255
This commit is contained in:
Arnaud Charlet
parent
5c63aafa2e
commit
71129dded1
4 changed files with 139 additions and 68 deletions
|
|
@ -1,3 +1,17 @@
|
|||
2016-04-20 Hristian Kirtchev <kirtchev@adacore.com>
|
||||
|
||||
* sem_attr.ads Add new table Universal_Type_Attribute.
|
||||
* sem_util.adb (Yields_Universal_Type): Use a table lookup when
|
||||
checking attributes.
|
||||
|
||||
2016-04-20 Ed Schonberg <schonberg@adacore.com>
|
||||
|
||||
* exp_aggr.adb (Init_Stored_Discriminants,
|
||||
Init_Visible_Discriminants): New procedures, subsidiary of
|
||||
Build_Record_Aggr_Code, to handle properly the construction
|
||||
of aggregates for a derived type that constrains some parent
|
||||
discriminants and renames others.
|
||||
|
||||
2016-04-20 Hristian Kirtchev <kirtchev@adacore.com>
|
||||
|
||||
* sem_ch12.adb (Qualify_Universal_Operands): New routine.
|
||||
|
|
|
|||
|
|
@ -1879,6 +1879,11 @@ package body Exp_Aggr is
|
|||
-- Returns the first discriminant association in the constraint
|
||||
-- associated with T, if any, otherwise returns Empty.
|
||||
|
||||
function Get_Explicit_Discriminant_Value (D : Entity_Id) return Node_Id;
|
||||
-- If the ancestor part is an unconstrained type and further ancestors
|
||||
-- do not provide discriminants for it, check aggregate components for
|
||||
-- values of the discriminants.
|
||||
|
||||
procedure Init_Hidden_Discriminants (Typ : Entity_Id; List : List_Id);
|
||||
-- If Typ is derived, and constrains discriminants of the parent type,
|
||||
-- these discriminants are not components of the aggregate, and must be
|
||||
|
|
@ -1886,10 +1891,19 @@ package body Exp_Aggr is
|
|||
-- if Typ derives fron an already constrained subtype of a discriminated
|
||||
-- parent type.
|
||||
|
||||
function Get_Explicit_Discriminant_Value (D : Entity_Id) return Node_Id;
|
||||
-- If the ancestor part is an unconstrained type and further ancestors
|
||||
-- do not provide discriminants for it, check aggregate components for
|
||||
-- values of the discriminants.
|
||||
procedure Init_Stored_Discriminants;
|
||||
-- If the type is derived and has inherited discriminants, generate
|
||||
-- explicit assignments for each, using the store constraint of the
|
||||
-- type. Note that both visible and stored discriminants must be
|
||||
-- initialized in case the derived type has some renamed and some
|
||||
-- constrained discriminants.
|
||||
|
||||
procedure Init_Visible_Discriminants;
|
||||
-- If type has discriminants, retrieve their values from aggregate,
|
||||
-- and generate explicit assignments for each. This does not include
|
||||
-- discriminants inherited from ancestor, which are handled above.
|
||||
-- The type of the aggregate is a subtype created ealier using the
|
||||
-- given values of the discriminant components of the aggregate.
|
||||
|
||||
function Is_Int_Range_Bounds (Bounds : Node_Id) return Boolean;
|
||||
-- Check whether Bounds is a range node and its lower and higher bounds
|
||||
|
|
@ -2279,6 +2293,70 @@ package body Exp_Aggr is
|
|||
end loop;
|
||||
end Init_Hidden_Discriminants;
|
||||
|
||||
--------------------------------
|
||||
-- Init_Visible_Discriminants --
|
||||
--------------------------------
|
||||
|
||||
procedure Init_Visible_Discriminants is
|
||||
Discriminant : Entity_Id;
|
||||
Discriminant_Value : Node_Id;
|
||||
|
||||
begin
|
||||
Discriminant := First_Discriminant (Typ);
|
||||
while Present (Discriminant) loop
|
||||
Comp_Expr :=
|
||||
Make_Selected_Component (Loc,
|
||||
Prefix => New_Copy_Tree (Target),
|
||||
Selector_Name => New_Occurrence_Of (Discriminant, Loc));
|
||||
|
||||
Discriminant_Value :=
|
||||
Get_Discriminant_Value
|
||||
(Discriminant, Typ, Discriminant_Constraint (N_Typ));
|
||||
|
||||
Instr :=
|
||||
Make_OK_Assignment_Statement (Loc,
|
||||
Name => Comp_Expr,
|
||||
Expression => New_Copy_Tree (Discriminant_Value));
|
||||
|
||||
Set_No_Ctrl_Actions (Instr);
|
||||
Append_To (L, Instr);
|
||||
|
||||
Next_Discriminant (Discriminant);
|
||||
end loop;
|
||||
end Init_Visible_Discriminants;
|
||||
|
||||
-------------------------------
|
||||
-- Init_Stored_Discriminants --
|
||||
-------------------------------
|
||||
|
||||
procedure Init_Stored_Discriminants is
|
||||
Discriminant : Entity_Id;
|
||||
Discriminant_Value : Node_Id;
|
||||
|
||||
begin
|
||||
Discriminant := First_Stored_Discriminant (Typ);
|
||||
while Present (Discriminant) loop
|
||||
Comp_Expr :=
|
||||
Make_Selected_Component (Loc,
|
||||
Prefix => New_Copy_Tree (Target),
|
||||
Selector_Name => New_Occurrence_Of (Discriminant, Loc));
|
||||
|
||||
Discriminant_Value :=
|
||||
Get_Discriminant_Value
|
||||
(Discriminant, N_Typ, Discriminant_Constraint (N_Typ));
|
||||
|
||||
Instr :=
|
||||
Make_OK_Assignment_Statement (Loc,
|
||||
Name => Comp_Expr,
|
||||
Expression => New_Copy_Tree (Discriminant_Value));
|
||||
|
||||
Set_No_Ctrl_Actions (Instr);
|
||||
Append_To (L, Instr);
|
||||
|
||||
Next_Stored_Discriminant (Discriminant);
|
||||
end loop;
|
||||
end Init_Stored_Discriminants;
|
||||
|
||||
-------------------------
|
||||
-- Is_Int_Range_Bounds --
|
||||
-------------------------
|
||||
|
|
@ -2681,35 +2759,11 @@ package body Exp_Aggr is
|
|||
|
||||
-- Generate discriminant init values for the visible discriminants
|
||||
|
||||
declare
|
||||
Discriminant : Entity_Id;
|
||||
Discriminant_Value : Node_Id;
|
||||
Init_Visible_Discriminants;
|
||||
|
||||
begin
|
||||
Discriminant := First_Stored_Discriminant (Typ);
|
||||
while Present (Discriminant) loop
|
||||
Comp_Expr :=
|
||||
Make_Selected_Component (Loc,
|
||||
Prefix => New_Copy_Tree (Target),
|
||||
Selector_Name => New_Occurrence_Of (Discriminant, Loc));
|
||||
|
||||
Discriminant_Value :=
|
||||
Get_Discriminant_Value
|
||||
(Discriminant,
|
||||
N_Typ,
|
||||
Discriminant_Constraint (N_Typ));
|
||||
|
||||
Instr :=
|
||||
Make_OK_Assignment_Statement (Loc,
|
||||
Name => Comp_Expr,
|
||||
Expression => New_Copy_Tree (Discriminant_Value));
|
||||
|
||||
Set_No_Ctrl_Actions (Instr);
|
||||
Append_To (L, Instr);
|
||||
|
||||
Next_Stored_Discriminant (Discriminant);
|
||||
end loop;
|
||||
end;
|
||||
if Is_Derived_Type (N_Typ) then
|
||||
Init_Stored_Discriminants;
|
||||
end if;
|
||||
end if;
|
||||
end if;
|
||||
|
||||
|
|
|
|||
|
|
@ -605,6 +605,44 @@ package Sem_Attr is
|
|||
|
||||
others => False);
|
||||
|
||||
-- The following table lists all attributes that yield a result of a
|
||||
-- universal type.
|
||||
|
||||
Universal_Type_Attribute : constant array (Attribute_Id) of Boolean :=
|
||||
(Attribute_Aft => True,
|
||||
Attribute_Alignment => True,
|
||||
Attribute_Component_Size => True,
|
||||
Attribute_Count => True,
|
||||
Attribute_Delta => True,
|
||||
Attribute_Digits => True,
|
||||
Attribute_Exponent => True,
|
||||
Attribute_First_Bit => True,
|
||||
Attribute_Fore => True,
|
||||
Attribute_Last_Bit => True,
|
||||
Attribute_Length => True,
|
||||
Attribute_Machine_Emax => True,
|
||||
Attribute_Machine_Emin => True,
|
||||
Attribute_Machine_Mantissa => True,
|
||||
Attribute_Machine_Radix => True,
|
||||
Attribute_Max_Alignment_For_Allocation => True,
|
||||
Attribute_Max_Size_In_Storage_Elements => True,
|
||||
Attribute_Model_Emin => True,
|
||||
Attribute_Model_Epsilon => True,
|
||||
Attribute_Model_Mantissa => True,
|
||||
Attribute_Model_Small => True,
|
||||
Attribute_Modulus => True,
|
||||
Attribute_Pos => True,
|
||||
Attribute_Position => True,
|
||||
Attribute_Safe_First => True,
|
||||
Attribute_Safe_Last => True,
|
||||
Attribute_Scale => True,
|
||||
Attribute_Size => True,
|
||||
Attribute_Small => True,
|
||||
Attribute_Wide_Wide_Width => True,
|
||||
Attribute_Wide_Width => True,
|
||||
Attribute_Width => True,
|
||||
others => False);
|
||||
|
||||
-----------------
|
||||
-- Subprograms --
|
||||
-----------------
|
||||
|
|
|
|||
|
|
@ -20962,8 +20962,6 @@ package body Sem_Util is
|
|||
---------------------------
|
||||
|
||||
function Yields_Universal_Type (N : Node_Id) return Boolean is
|
||||
Nam : Name_Id;
|
||||
|
||||
begin
|
||||
-- Integer and real literals are of a universal type
|
||||
|
||||
|
|
@ -20973,41 +20971,8 @@ package body Sem_Util is
|
|||
-- The values of certain attributes are of a universal type
|
||||
|
||||
elsif Nkind (N) = N_Attribute_Reference then
|
||||
Nam := Attribute_Name (N);
|
||||
|
||||
return
|
||||
Nam = Name_Aft
|
||||
or else Nam = Name_Alignment
|
||||
or else Nam = Name_Component_Size
|
||||
or else Nam = Name_Count
|
||||
or else Nam = Name_Delta
|
||||
or else Nam = Name_Digits
|
||||
or else Nam = Name_Exponent
|
||||
or else Nam = Name_First_Bit
|
||||
or else Nam = Name_Fore
|
||||
or else Nam = Name_Last_Bit
|
||||
or else Nam = Name_Length
|
||||
or else Nam = Name_Machine_Emax
|
||||
or else Nam = Name_Machine_Emin
|
||||
or else Nam = Name_Machine_Mantissa
|
||||
or else Nam = Name_Machine_Radix
|
||||
or else Nam = Name_Max_Alignment_For_Allocation
|
||||
or else Nam = Name_Max_Size_In_Storage_Elements
|
||||
or else Nam = Name_Model_Emin
|
||||
or else Nam = Name_Model_Epsilon
|
||||
or else Nam = Name_Model_Mantissa
|
||||
or else Nam = Name_Model_Small
|
||||
or else Nam = Name_Modulus
|
||||
or else Nam = Name_Pos
|
||||
or else Nam = Name_Position
|
||||
or else Nam = Name_Safe_First
|
||||
or else Nam = Name_Safe_Last
|
||||
or else Nam = Name_Scale
|
||||
or else Nam = Name_Size
|
||||
or else Nam = Name_Small
|
||||
or else Nam = Name_Wide_Wide_Width
|
||||
or else Nam = Name_Wide_Width
|
||||
or else Nam = Name_Width;
|
||||
Universal_Type_Attribute (Get_Attribute_Id (Attribute_Name (N)));
|
||||
|
||||
-- ??? There are possibly other cases to consider
|
||||
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue