Routine Build_Constrained_Itype was created as an exact duplicate
Build_Subtype with a comment suggesting that their code should be
exported from Sem_Util and reused. Unfortunately, since then both
routines diverged and now are subtly different, so reusing is not
straightforward. However, it is still better to have them both exported
to prevent further duplication.
Tested on x86_64-pc-linux-gnu, committed on trunk
2020-06-11 Piotr Trojanek <troja...@adacore.com>
gcc/ada/
* sem_aggr.adb (Build_Constrained_Itype): Move to Sem_Util.
* sem_ch3.adb (Build_Subtype, Inherit_Predicate_Flags): Move...
* sem_util.adb (Build_Subtype): Here. Add parameters for
references to objects previously declared in enclosing scopes.
(Inherit_Predicate_Flags): And here, because it is called by
Build_Subtype.
* sem_util.ads (Build_Overriding_Spec): Reorder alphabetically.
(Build_Subtype): Moved from Sem_Ch3; comments updated.
(Build_Constrained_Itype): Moved from Sem_Aggr; comments
updated.--- gcc/ada/sem_aggr.adb
+++ gcc/ada/sem_aggr.adb
@@ -3313,29 +3313,6 @@ package body Sem_Aggr is
-- part of the enclosing aggregate. Assoc_List provides the discriminant
-- associations of the current type or of some enclosing record.
- procedure Build_Constrained_Itype
- (N : Node_Id;
- Typ : Entity_Id;
- New_Assoc_List : List_Id);
- -- Build a constrained itype for the newly created record aggregate N
- -- and set it as a type of N. The itype will have Typ as its base type
- -- and will be constrained by the values of discriminants from the
- -- component association list New_Assoc_List.
-
- -- ??? This code used to be pretty much a copy of Sem_Ch3.Build_Subtype,
- -- but now those two routines behave differently for types with unknown
- -- discriminants. They should really be exported in sem_util or some
- -- such and used in sem_ch3 and here rather than have a copy of the
- -- code which is a maintenance nightmare.
-
- -- ??? Performance WARNING. The current implementation creates a new
- -- itype for all aggregates whose base type is discriminated. This means
- -- that for record aggregates nested inside an array aggregate we will
- -- create a new itype for each record aggregate if the array component
- -- type has discriminants. For large aggregates this may be a problem.
- -- What should be done in this case is to reuse itypes as much as
- -- possible.
-
function Discriminant_Present (Input_Discr : Entity_Id) return Boolean;
-- If aggregate N is a regular aggregate this routine will return True.
-- Otherwise, if N is an extension aggregate, then Input_Discr denotes
@@ -3495,78 +3472,6 @@ package body Sem_Aggr is
end loop;
end Add_Discriminant_Values;
- -----------------------------
- -- Build_Constrained_Itype --
- -----------------------------
-
- procedure Build_Constrained_Itype
- (N : Node_Id;
- Typ : Entity_Id;
- New_Assoc_List : List_Id)
- is
- Constrs : constant List_Id := New_List;
- Loc : constant Source_Ptr := Sloc (N);
- Def_Id : Entity_Id;
- Indic : Node_Id;
- New_Assoc : Node_Id;
- Subtyp_Decl : Node_Id;
-
- begin
- New_Assoc := First (New_Assoc_List);
- while Present (New_Assoc) loop
-
- -- There is exactly one choice in the component association (and
- -- it is either a discriminant, a component or the others clause).
- pragma Assert (List_Length (Choices (New_Assoc)) = 1);
-
- -- Duplicate expression for the discriminant and put it on the
- -- list of constraints for the itype declaration.
-
- if Is_Entity_Name (First (Choices (New_Assoc)))
- and then
- Ekind (Entity (First (Choices (New_Assoc)))) = E_Discriminant
- then
- Append_To (Constrs, Duplicate_Subexpr (Expression (New_Assoc)));
- end if;
-
- Next (New_Assoc);
- end loop;
-
- if Has_Unknown_Discriminants (Typ)
- and then Present (Underlying_Record_View (Typ))
- then
- Indic :=
- Make_Subtype_Indication (Loc,
- Subtype_Mark =>
- New_Occurrence_Of (Underlying_Record_View (Typ), Loc),
- Constraint =>
- Make_Index_Or_Discriminant_Constraint (Loc,
- Constraints => Constrs));
- else
- Indic :=
- Make_Subtype_Indication (Loc,
- Subtype_Mark =>
- New_Occurrence_Of (Base_Type (Typ), Loc),
- Constraint =>
- Make_Index_Or_Discriminant_Constraint (Loc,
- Constraints => Constrs));
- end if;
-
- Def_Id := Create_Itype (Ekind (Typ), N);
-
- Subtyp_Decl :=
- Make_Subtype_Declaration (Loc,
- Defining_Identifier => Def_Id,
- Subtype_Indication => Indic);
- Set_Parent (Subtyp_Decl, Parent (N));
-
- -- Itypes must be analyzed with checks off (see itypes.ads)
-
- Analyze (Subtyp_Decl, Suppress => All_Checks);
-
- Set_Etype (N, Def_Id);
- end Build_Constrained_Itype;
-
--------------------------
-- Discriminant_Present --
--------------------------
--- gcc/ada/sem_ch3.adb
+++ gcc/ada/sem_ch3.adb
@@ -563,10 +563,6 @@ package body Sem_Ch3 is
-- copying the record declaration for the derived base. In the tagged case
-- the value returned is irrelevant.
- procedure Inherit_Predicate_Flags (Subt, Par : Entity_Id);
- -- Propagate static and dynamic predicate flags from a parent to the
- -- subtype in a subtype declaration with and without constraints.
-
function Is_EVF_Procedure (Subp : Entity_Id) return Boolean;
-- Subsidiary to Check_Abstract_Overriding and Derive_Subprogram.
-- Determine whether subprogram Subp is a procedure subject to pragma
@@ -13078,10 +13074,6 @@ package body Sem_Ch3 is
-- Ditto for access types. Makes use of previous two functions, to
-- constrain designated type.
- function Build_Subtype (T : Entity_Id; C : List_Id) return Entity_Id;
- -- T is an array or discriminated type, C is a list of constraints
- -- that apply to T. This routine builds the constrained subtype.
-
function Is_Discriminant (Expr : Node_Id) return Boolean;
-- Returns True if Expr is a discriminant
@@ -13229,7 +13221,7 @@ package body Sem_Ch3 is
Next_Index (Old_Index);
end loop;
- return Build_Subtype (Old_Type, Constr_List);
+ return Build_Subtype (Related_Node, Loc, Old_Type, Constr_List);
else
return Old_Type;
@@ -13294,81 +13286,13 @@ package body Sem_Ch3 is
Next_Elmt (Old_Constraint);
end loop;
- return Build_Subtype (Old_Type, Constr_List);
+ return Build_Subtype (Related_Node, Loc, Old_Type, Constr_List);
else
return Old_Type;
end if;
end Build_Constrained_Discriminated_Type;
- -------------------
- -- Build_Subtype --
- -------------------
-
- function Build_Subtype (T : Entity_Id; C : List_Id) return Entity_Id is
- Indic : Node_Id;
- Subtyp_Decl : Node_Id;
- Def_Id : Entity_Id;
- Btyp : Entity_Id := Base_Type (T);
-
- begin
- -- The Related_Node better be here or else we won't be able to
- -- attach new itypes to a node in the tree.
-
- pragma Assert (Present (Related_Node));
-
- -- If the view of the component's type is incomplete or private
- -- with unknown discriminants, then the constraint must be applied
- -- to the full type.
-
- if Has_Unknown_Discriminants (Btyp)
- and then Present (Underlying_Type (Btyp))
- then
- Btyp := Underlying_Type (Btyp);
- end if;
-
- Indic :=
- Make_Subtype_Indication (Loc,
- Subtype_Mark => New_Occurrence_Of (Btyp, Loc),
- Constraint => Make_Index_Or_Discriminant_Constraint (Loc, C));
-
- Def_Id := Create_Itype (Ekind (T), Related_Node);
-
- Subtyp_Decl :=
- Make_Subtype_Declaration (Loc,
- Defining_Identifier => Def_Id,
- Subtype_Indication => Indic);
-
- Set_Parent (Subtyp_Decl, Parent (Related_Node));
-
- -- Itypes must be analyzed with checks off (see package Itypes)
-
- Analyze (Subtyp_Decl, Suppress => All_Checks);
-
- if Is_Itype (Def_Id) and then Has_Predicates (T) then
- Inherit_Predicate_Flags (Def_Id, T);
-
- -- Indicate where the predicate function may be found
-
- if Is_Itype (T) then
- if Present (Predicate_Function (Def_Id)) then
- null;
-
- elsif Present (Predicate_Function (T)) then
- Set_Predicate_Function (Def_Id, Predicate_Function (T));
-
- else
- Set_Predicated_Parent (Def_Id, Predicated_Parent (T));
- end if;
-
- elsif No (Predicate_Function (Def_Id)) then
- Set_Predicated_Parent (Def_Id, T);
- end if;
- end if;
-
- return Def_Id;
- end Build_Subtype;
-
---------------------
-- Get_Discr_Value --
---------------------
@@ -18483,38 +18407,6 @@ package body Sem_Ch3 is
return Assoc_List;
end Inherit_Components;
- -----------------------------
- -- Inherit_Predicate_Flags --
- -----------------------------
-
- procedure Inherit_Predicate_Flags (Subt, Par : Entity_Id) is
- begin
- if Present (Predicate_Function (Subt)) then
- return;
- end if;
-
- Set_Has_Predicates (Subt, Has_Predicates (Par));
- Set_Has_Static_Predicate_Aspect
- (Subt, Has_Static_Predicate_Aspect (Par));
- Set_Has_Dynamic_Predicate_Aspect
- (Subt, Has_Dynamic_Predicate_Aspect (Par));
-
- -- A named subtype does not inherit the predicate function of its
- -- parent but an itype declared for a loop index needs the discrete
- -- predicate information of its parent to execute the loop properly.
- -- A non-discrete type may has a static predicate (for example True)
- -- but has no static_discrete_predicate.
-
- if Is_Itype (Subt) and then Present (Predicate_Function (Par)) then
- Set_Subprograms_For_Type (Subt, Subprograms_For_Type (Par));
-
- if Has_Static_Predicate (Par) and then Is_Discrete_Type (Par) then
- Set_Static_Discrete_Predicate
- (Subt, Static_Discrete_Predicate (Par));
- end if;
- end if;
- end Inherit_Predicate_Flags;
-
----------------------
-- Is_EVF_Procedure --
----------------------
--- gcc/ada/sem_util.adb
+++ gcc/ada/sem_util.adb
@@ -36,6 +36,7 @@ with Exp_Ch11; use Exp_Ch11;
with Exp_Util; use Exp_Util;
with Fname; use Fname;
with Freeze; use Freeze;
+with Itypes; use Itypes;
with Lib; use Lib;
with Lib.Xref; use Lib.Xref;
with Namet.Sp; use Namet.Sp;
@@ -1683,6 +1684,78 @@ package body Sem_Util is
return Decl;
end Build_Component_Subtype;
+ -----------------------------
+ -- Build_Constrained_Itype --
+ -----------------------------
+
+ procedure Build_Constrained_Itype
+ (N : Node_Id;
+ Typ : Entity_Id;
+ New_Assoc_List : List_Id)
+ is
+ Constrs : constant List_Id := New_List;
+ Loc : constant Source_Ptr := Sloc (N);
+ Def_Id : Entity_Id;
+ Indic : Node_Id;
+ New_Assoc : Node_Id;
+ Subtyp_Decl : Node_Id;
+
+ begin
+ New_Assoc := First (New_Assoc_List);
+ while Present (New_Assoc) loop
+
+ -- There is exactly one choice in the component association (and
+ -- it is either a discriminant, a component or the others clause).
+ pragma Assert (List_Length (Choices (New_Assoc)) = 1);
+
+ -- Duplicate expression for the discriminant and put it on the
+ -- list of constraints for the itype declaration.
+
+ if Is_Entity_Name (First (Choices (New_Assoc)))
+ and then
+ Ekind (Entity (First (Choices (New_Assoc)))) = E_Discriminant
+ then
+ Append_To (Constrs, Duplicate_Subexpr (Expression (New_Assoc)));
+ end if;
+
+ Next (New_Assoc);
+ end loop;
+
+ if Has_Unknown_Discriminants (Typ)
+ and then Present (Underlying_Record_View (Typ))
+ then
+ Indic :=
+ Make_Subtype_Indication (Loc,
+ Subtype_Mark =>
+ New_Occurrence_Of (Underlying_Record_View (Typ), Loc),
+ Constraint =>
+ Make_Index_Or_Discriminant_Constraint (Loc,
+ Constraints => Constrs));
+ else
+ Indic :=
+ Make_Subtype_Indication (Loc,
+ Subtype_Mark =>
+ New_Occurrence_Of (Base_Type (Typ), Loc),
+ Constraint =>
+ Make_Index_Or_Discriminant_Constraint (Loc,
+ Constraints => Constrs));
+ end if;
+
+ Def_Id := Create_Itype (Ekind (Typ), N);
+
+ Subtyp_Decl :=
+ Make_Subtype_Declaration (Loc,
+ Defining_Identifier => Def_Id,
+ Subtype_Indication => Indic);
+ Set_Parent (Subtyp_Decl, Parent (N));
+
+ -- Itypes must be analyzed with checks off (see itypes.ads)
+
+ Analyze (Subtyp_Decl, Suppress => All_Checks);
+
+ Set_Etype (N, Def_Id);
+ end Build_Constrained_Itype;
+
---------------------------
-- Build_Default_Subtype --
---------------------------
@@ -2120,6 +2193,81 @@ package body Sem_Util is
return New_Spec;
end Build_Overriding_Spec;
+ -------------------
+ -- Build_Subtype --
+ -------------------
+
+ function Build_Subtype
+ (Related_Node : Node_Id;
+ Loc : Source_Ptr;
+ Typ : Entity_Id;
+ Constraints : List_Id)
+ return Entity_Id
+ is
+ Indic : Node_Id;
+ Subtyp_Decl : Node_Id;
+ Def_Id : Entity_Id;
+ Btyp : Entity_Id := Base_Type (Typ);
+
+ begin
+ -- The Related_Node better be here or else we won't be able to
+ -- attach new itypes to a node in the tree.
+
+ pragma Assert (Present (Related_Node));
+
+ -- If the view of the component's type is incomplete or private
+ -- with unknown discriminants, then the constraint must be applied
+ -- to the full type.
+
+ if Has_Unknown_Discriminants (Btyp)
+ and then Present (Underlying_Type (Btyp))
+ then
+ Btyp := Underlying_Type (Btyp);
+ end if;
+
+ Indic :=
+ Make_Subtype_Indication (Loc,
+ Subtype_Mark => New_Occurrence_Of (Btyp, Loc),
+ Constraint =>
+ Make_Index_Or_Discriminant_Constraint (Loc, Constraints));
+
+ Def_Id := Create_Itype (Ekind (Typ), Related_Node);
+
+ Subtyp_Decl :=
+ Make_Subtype_Declaration (Loc,
+ Defining_Identifier => Def_Id,
+ Subtype_Indication => Indic);
+
+ Set_Parent (Subtyp_Decl, Parent (Related_Node));
+
+ -- Itypes must be analyzed with checks off (see package Itypes)
+
+ Analyze (Subtyp_Decl, Suppress => All_Checks);
+
+ if Is_Itype (Def_Id) and then Has_Predicates (Typ) then
+ Inherit_Predicate_Flags (Def_Id, Typ);
+
+ -- Indicate where the predicate function may be found
+
+ if Is_Itype (Typ) then
+ if Present (Predicate_Function (Def_Id)) then
+ null;
+
+ elsif Present (Predicate_Function (Typ)) then
+ Set_Predicate_Function (Def_Id, Predicate_Function (Typ));
+
+ else
+ Set_Predicated_Parent (Def_Id, Predicated_Parent (Typ));
+ end if;
+
+ elsif No (Predicate_Function (Def_Id)) then
+ Set_Predicated_Parent (Def_Id, Typ);
+ end if;
+ end if;
+
+ return Def_Id;
+ end Build_Subtype;
+
-----------------------------------
-- Cannot_Raise_Constraint_Error --
-----------------------------------
@@ -13236,6 +13384,38 @@ package body Sem_Util is
return Off * (Expr_Value (Exp) - Expr_Value (Low_Bound ((Ind))));
end Indexed_Component_Bit_Offset;
+ -----------------------------
+ -- Inherit_Predicate_Flags --
+ -----------------------------
+
+ procedure Inherit_Predicate_Flags (Subt, Par : Entity_Id) is
+ begin
+ if Present (Predicate_Function (Subt)) then
+ return;
+ end if;
+
+ Set_Has_Predicates (Subt, Has_Predicates (Par));
+ Set_Has_Static_Predicate_Aspect
+ (Subt, Has_Static_Predicate_Aspect (Par));
+ Set_Has_Dynamic_Predicate_Aspect
+ (Subt, Has_Dynamic_Predicate_Aspect (Par));
+
+ -- A named subtype does not inherit the predicate function of its
+ -- parent but an itype declared for a loop index needs the discrete
+ -- predicate information of its parent to execute the loop properly.
+ -- A non-discrete type may has a static predicate (for example True)
+ -- but has no static_discrete_predicate.
+
+ if Is_Itype (Subt) and then Present (Predicate_Function (Par)) then
+ Set_Subprograms_For_Type (Subt, Subprograms_For_Type (Par));
+
+ if Has_Static_Predicate (Par) and then Is_Discrete_Type (Par) then
+ Set_Static_Discrete_Predicate
+ (Subt, Static_Discrete_Predicate (Par));
+ end if;
+ end if;
+ end Inherit_Predicate_Flags;
+
----------------------------
-- Inherit_Rep_Item_Chain --
----------------------------
--- gcc/ada/sem_util.ads
+++ gcc/ada/sem_util.ads
@@ -273,6 +273,27 @@ package Sem_Util is
-- through a type-specific wrapper for all inherited subprograms that
-- may have a modified condition.
+ procedure Build_Constrained_Itype
+ (N : Node_Id;
+ Typ : Entity_Id;
+ New_Assoc_List : List_Id);
+ -- Build a constrained itype for the newly created record aggregate N and
+ -- set it as a type of N. The itype will have Typ as its base type and
+ -- will be constrained by the values of discriminants from the component
+ -- association list New_Assoc_List.
+
+ -- ??? This code used to be pretty much a copy of Build_Subtype, but now
+ -- those two routines behave differently for types with unknown
+ -- discriminants. They are both exported in from this package in the hope
+ -- to eventually unify them (a not duplicate them even more until then).
+
+ -- ??? Performance WARNING. The current implementation creates a new itype
+ -- for all aggregates whose base type is discriminated. This means that
+ -- for record aggregates nested inside an array aggregate we will create
+ -- a new itype for each record aggregate if the array component type has
+ -- discriminants. For large aggregates this may be a problem. What should
+ -- be done in this case is to reuse itypes as much as possible.
+
function Build_Default_Subtype
(T : Entity_Id;
N : Node_Id) return Entity_Id;
@@ -291,14 +312,6 @@ package Sem_Util is
-- the compilation unit, and install it in the Elaboration_Entity field
-- of Spec_Id, the entity for the compilation unit.
- function Build_Overriding_Spec
- (Op : Node_Id;
- Typ : Entity_Id) return Node_Id;
- -- Build a subprogram specification for the wrapper of an inherited
- -- operation with a modified pre- or postcondition (See AI12-0113).
- -- Op is the parent operation, and Typ is the descendant type that
- -- inherits the operation.
-
procedure Build_Explicit_Dereference
(Expr : Node_Id;
Disc : Entity_Id);
@@ -308,6 +321,30 @@ package Sem_Util is
-- loaded with both interpretations, and the dereference interpretation
-- carries the name of the reference discriminant.
+ function Build_Overriding_Spec
+ (Op : Node_Id;
+ Typ : Entity_Id) return Node_Id;
+ -- Build a subprogram specification for the wrapper of an inherited
+ -- operation with a modified pre- or postcondition (See AI12-0113).
+ -- Op is the parent operation, and Typ is the descendant type that
+ -- inherits the operation.
+
+ function Build_Subtype
+ (Related_Node : Node_Id;
+ Loc : Source_Ptr;
+ Typ : Entity_Id;
+ Constraints : List_Id)
+ return Entity_Id;
+ -- Typ is an array or discriminated type, Constraints is a list of
+ -- constraints that apply to Typ. This routine builds the constrained
+ -- subtype using Loc as the source location and attached this subtype
+ -- declaration to Related_Node. The returned subtype inherits predicates
+ -- from Typ.
+
+ -- ??? The routine is mostly a duplicate of Build_Constrained_Itype, so be
+ -- careful which of the two better suits your needs (and certainly do not
+ -- duplicate their code).
+
function Cannot_Raise_Constraint_Error (Expr : Node_Id) return Boolean;
-- Returns True if the expression cannot possibly raise Constraint_Error.
-- The response is conservative in the sense that a result of False does
@@ -1485,6 +1522,10 @@ package Sem_Util is
-- either the value is not yet known before back-end processing or it is
-- not known at compile time after back-end processing.
+ procedure Inherit_Predicate_Flags (Subt, Par : Entity_Id);
+ -- Propagate static and dynamic predicate flags from a parent to the
+ -- subtype in a subtype declaration with and without constraints.
+
procedure Inherit_Rep_Item_Chain (Typ : Entity_Id; From_Typ : Entity_Id);
-- Inherit the rep item chain of type From_Typ without clobbering any
-- existing rep items on Typ's chain. Typ is the destination type.
