diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 275823173e2..16b6a580c2e 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,17 @@ +2016-04-20 Hristian Kirtchev + + * 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 + + * 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 * sem_ch12.adb (Qualify_Universal_Operands): New routine. diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index bd757cd1040..c7a9a97e8e8 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -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; diff --git a/gcc/ada/sem_attr.ads b/gcc/ada/sem_attr.ads index a8fa47139ec..b3c30183883 100644 --- a/gcc/ada/sem_attr.ads +++ b/gcc/ada/sem_attr.ads @@ -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 -- ----------------- diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 4989409d67e..5f2722d06df 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -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