Skip to content

R
riscv-gcc-1
Commit 71129dde by Arnaud Charlet
Options

[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
parent 5c63aafa
Showing with 139 additions and 68 deletions
gcc/ada/ChangeLog
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.
(Save_References_In_Operator): Add explicit qualifications in
the generic template for all operands of universal type.
......
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;
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));
Init_Visible_Discriminants;
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;
......
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 --
-----------------
......
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
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment