-- 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
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 --
--------------------------
-- 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
-- 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
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;
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 --
---------------------
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 --
----------------------
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;
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 --
---------------------------
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 --
-----------------------------------
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 --
----------------------------
-- 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;
-- 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);
-- 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
-- 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.
projects / thirdparty / gcc.git / commitdiff
