-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2018, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
with Sem_Dim; use Sem_Dim;
with Sem_Disp; use Sem_Disp;
with Sem_Dist; use Sem_Dist;
+with Sem_Elab; use Sem_Elab;
with Sem_Elim; use Sem_Elim;
with Sem_Eval; use Sem_Eval;
with Sem_Mech; use Sem_Mech;
-- Create a new ordinary fixed point type, and apply the constraint to
-- obtain subtype of it.
+ procedure Preanalyze_Default_Expression (N : Node_Id; T : Entity_Id);
+ -- Wrapper on Preanalyze_Spec_Expression for default expressions, so that
+ -- In_Default_Expr can be properly adjusted.
+
procedure Prepare_Private_Subtype_Completion
(Id : Entity_Id;
Related_Nod : Node_Id);
Set_Ekind (T_Name, E_Access_Subprogram_Type);
end if;
- Set_Can_Use_Internal_Rep (T_Name, not Always_Compatible_Rep_On_Target);
-
+ Set_Can_Use_Internal_Rep (T_Name,
+ not Always_Compatible_Rep_On_Target);
Set_Etype (T_Name, T_Name);
Init_Size_Align (T_Name);
Set_Directly_Designated_Type (T_Name, Desig_Type);
+ -- If the access_to_subprogram is not declared at the library level,
+ -- it can only point to subprograms that are at the same or deeper
+ -- accessibility level. The corresponding subprogram type might
+ -- require an activation record when compiling for C.
+
+ Set_Needs_Activation_Record (Desig_Type,
+ not Is_Library_Level_Entity (T_Name));
+
Generate_Reference_To_Formals (T_Name);
-- Ada 2005 (AI-231): Propagate the null-excluding attribute
-- nonconforming preconditions in both an ancestor and
-- a progenitor operation.
+ -- If the operation is a primitive wrapper it is an explicit
+ -- (overriding) operqtion and all is fine.
+
if Present (Anc)
and then Has_Non_Trivial_Precondition (Anc)
and then Has_Non_Trivial_Precondition (Iface_Prim)
and then Nkind (Parent (Prim)) =
N_Procedure_Specification
and then Null_Present (Parent (Prim)))
+ or else Is_Primitive_Wrapper (Prim)
then
null;
- -- The inherited operation must be overridden
+ -- The operation is inherited and must be overridden
elsif not Comes_From_Source (Prim) then
Error_Msg_NE
if Is_Limited_Record (Typ) then
return True;
- -- If the root type is limited (and not a limited interface)
- -- so is the current type
+ -- If the root type is limited (and not a limited interface) so is
+ -- the current type.
elsif Is_Limited_Record (R)
and then (not Is_Interface (R) or else not Is_Limited_Interface (R))
return True;
-- Else the type may have a limited interface progenitor, but a
- -- limited record parent.
+ -- limited record parent that is not an interface.
- elsif R /= P and then Is_Limited_Record (P) then
+ elsif R /= P
+ and then Is_Limited_Record (P)
+ and then not Is_Interface (P)
+ then
return True;
else
-- Context denotes the owner of the declarative list.
procedure Check_Entry_Contracts;
- -- Perform a pre-analysis of the pre- and postconditions of an entry
+ -- Perform a preanalysis of the pre- and postconditions of an entry
-- declaration. This must be done before full resolution and creation
-- of the parameter block, etc. to catch illegal uses within the
-- contract expression. Full analysis of the expression is done when
-- the contract is processed.
+ function Contains_Lib_Incomplete_Type (Pkg : Entity_Id) return Boolean;
+ -- Check if a nested package has entities within it that rely on library
+ -- level private types where the full view has not been completed for
+ -- the purposes of checking if it is acceptable to freeze an expression
+ -- function at the point of declaration.
+
procedure Handle_Late_Controlled_Primitive (Body_Decl : Node_Id);
-- Determine whether Body_Decl denotes the body of a late controlled
-- primitive (either Initialize, Adjust or Finalize). If this is the
procedure Resolve_Aspects;
-- Utility to resolve the expressions of aspects at the end of a list of
- -- declarations.
-
- function Uses_Unseen_Lib_Unit_Priv (Pkg : Entity_Id) return Boolean;
- -- Check if an inner package has entities within it that rely on library
- -- level private types where the full view has not been seen.
+ -- declarations, or before a declaration that freezes previous entities,
+ -- such as in a subprogram body.
-----------------
-- Adjust_Decl --
end loop;
end Check_Entry_Contracts;
+ ----------------------------------
+ -- Contains_Lib_Incomplete_Type --
+ ----------------------------------
+
+ function Contains_Lib_Incomplete_Type (Pkg : Entity_Id) return Boolean is
+ Curr : Entity_Id;
+
+ begin
+ -- Avoid looking through scopes that do not meet the precondition of
+ -- Pkg not being within a library unit spec.
+
+ if not Is_Compilation_Unit (Pkg)
+ and then not Is_Generic_Instance (Pkg)
+ and then not In_Package_Body (Enclosing_Lib_Unit_Entity (Pkg))
+ then
+ -- Loop through all entities in the current scope to identify
+ -- an entity that depends on a private type.
+
+ Curr := First_Entity (Pkg);
+ loop
+ if Nkind (Curr) in N_Entity
+ and then Depends_On_Private (Curr)
+ then
+ return True;
+ end if;
+
+ exit when Last_Entity (Current_Scope) = Curr;
+ Curr := Next_Entity (Curr);
+ end loop;
+ end if;
+
+ return False;
+ end Contains_Lib_Incomplete_Type;
+
--------------------------------------
-- Handle_Late_Controlled_Primitive --
--------------------------------------
end loop;
end Resolve_Aspects;
- -------------------------------
- -- Uses_Unseen_Lib_Unit_Priv --
- -------------------------------
-
- function Uses_Unseen_Lib_Unit_Priv (Pkg : Entity_Id) return Boolean is
- Curr : Entity_Id;
-
- begin
- -- Avoid looking through scopes that do not meet the precondition of
- -- Pkg not being within a library unit spec.
-
- if not Is_Compilation_Unit (Pkg)
- and then not Is_Generic_Instance (Pkg)
- and then not In_Package_Body (Enclosing_Lib_Unit_Entity (Pkg))
- then
- -- Loop through all entities in the current scope to identify
- -- an entity that depends on a private type.
-
- Curr := First_Entity (Pkg);
- loop
- if Nkind (Curr) in N_Entity
- and then Depends_On_Private (Curr)
- then
- return True;
- end if;
-
- exit when Last_Entity (Current_Scope) = Curr;
- Curr := Next_Entity (Curr);
- end loop;
- end if;
-
- return False;
- end Uses_Unseen_Lib_Unit_Priv;
-
-- Local variables
Context : Node_Id := Empty;
-- in order to perform visibility checks on delayed aspects.
Adjust_Decl;
- Freeze_All (First_Entity (Current_Scope), Decl);
- Freeze_From := Last_Entity (Current_Scope);
+
+ -- If the current scope is a generic subprogram body. Skip the
+ -- generic formal parameters that are not frozen here.
+
+ if Is_Subprogram (Current_Scope)
+ and then Nkind (Unit_Declaration_Node (Current_Scope)) =
+ N_Generic_Subprogram_Declaration
+ and then Present (First_Entity (Current_Scope))
+ then
+ while Is_Generic_Formal (Freeze_From) loop
+ Freeze_From := Next_Entity (Freeze_From);
+ end loop;
+
+ Freeze_All (Freeze_From, Decl);
+ Freeze_From := Last_Entity (Current_Scope);
+
+ else
+ -- For declarations in a subprogram body there is no issue
+ -- with name resolution in aspect specifications, but in
+ -- ASIS mode we need to preanalyze aspect specifications
+ -- that may otherwise only be analyzed during expansion
+ -- (e.g. during generation of a related subprogram).
+
+ if ASIS_Mode then
+ Resolve_Aspects;
+ end if;
+
+ Freeze_All (First_Entity (Current_Scope), Decl);
+ Freeze_From := Last_Entity (Current_Scope);
+ end if;
-- Current scope is a package specification
and then not Is_Child_Unit (Current_Scope)
and then No (Generic_Parent (Parent (L)))
then
- -- This is needed in all cases to catch visibility errors in
- -- aspect expressions, but several large user tests are now
- -- rejected. Pending notification we restrict this call to
- -- ASIS mode.
+ -- ARM rule 13.1.1(11/3): usage names in aspect definitions are
+ -- resolved at the end of the immediately enclosing declaration
+ -- list (AI05-0183-1).
- if ASIS_Mode then
- Resolve_Aspects;
- end if;
+ Resolve_Aspects;
elsif L /= Visible_Declarations (Parent (L))
or else No (Private_Declarations (Parent (L)))
-- not cause unwanted freezing at that point.
-- It is also necessary to check for a case where both an expression
- -- function is used and the current scope depends on an unseen
+ -- function is used and the current scope depends on an incomplete
-- private type from a library unit, otherwise premature freezing of
-- the private type will occur.
elsif not Analyzed (Next_Decl) and then Is_Body (Next_Decl)
and then ((Nkind (Next_Decl) /= N_Subprogram_Body
- or else not Was_Expression_Function (Next_Decl))
- or else not Uses_Unseen_Lib_Unit_Priv (Current_Scope))
+ or else not Was_Expression_Function (Next_Decl))
+ or else (not Is_Ignored_Ghost_Entity (Current_Scope)
+ and then not Contains_Lib_Incomplete_Type
+ (Current_Scope)))
then
-- When a controlled type is frozen, the expander generates stream
-- and controlled-type support routines. If the freeze is caused
if Nkind (Next_Decl) = N_Subprogram_Body then
Handle_Late_Controlled_Primitive (Next_Decl);
end if;
+
+ else
+ -- In ASIS mode, if the next declaration is a body, complete
+ -- the analysis of declarations so far.
+
+ Resolve_Aspects;
end if;
Adjust_Decl;
if Present (L) then
Context := Parent (L);
- -- Analyze the contracts of packages and their bodies
-
- if Nkind (Context) = N_Package_Specification then
-
- -- When a package has private declarations, its contract must be
- -- analyzed at the end of the said declarations. This way both the
- -- analysis and freeze actions are properly synchronized in case
- -- of private type use within the contract.
+ -- Certain contract annocations have forward visibility semantics and
+ -- must be analyzed after all declarative items have been processed.
+ -- This timing ensures that entities referenced by such contracts are
+ -- visible.
- if L = Private_Declarations (Context) then
- Analyze_Package_Contract (Defining_Entity (Context));
+ -- Analyze the contract of an immediately enclosing package spec or
+ -- body first because other contracts may depend on its information.
- -- Otherwise the contract is analyzed at the end of the visible
- -- declarations.
-
- elsif L = Visible_Declarations (Context)
- and then No (Private_Declarations (Context))
- then
- Analyze_Package_Contract (Defining_Entity (Context));
- end if;
-
- elsif Nkind (Context) = N_Package_Body then
+ if Nkind (Context) = N_Package_Body then
Analyze_Package_Body_Contract (Defining_Entity (Context));
+
+ elsif Nkind (Context) = N_Package_Specification then
+ Analyze_Package_Contract (Defining_Entity (Context));
end if;
- -- Analyze the contracts of various constructs now due to the delayed
- -- visibility needs of their aspects and pragmas.
+ -- Analyze the contracts of various constructs in the declarative
+ -- list.
Analyze_Contracts (L);
Remove_Visible_Refinements (Corresponding_Spec (Context));
Remove_Partial_Visible_Refinements (Corresponding_Spec (Context));
- elsif Nkind (Context) = N_Package_Declaration then
+ elsif Nkind (Context) = N_Package_Specification then
-- Partial state refinements are visible up to the end of the
-- package spec declarations. Hide the partial state refinements
-- from visibility to restore the original state conditions.
- Remove_Partial_Visible_Refinements (Corresponding_Spec (Context));
+ Remove_Partial_Visible_Refinements (Defining_Entity (Context));
end if;
-- Verify that all abstract states found in any package declared in
if not Analyzed (T) then
Set_Analyzed (T);
+ -- Set the SPARK mode from the current context
+
+ Set_SPARK_Pragma (T, SPARK_Mode_Pragma);
+ Set_SPARK_Pragma_Inherited (T);
+
case Nkind (Def) is
when N_Access_To_Subprogram_Definition =>
Access_Subprogram_Declaration (T, Def);
Set_Has_Predicates (Def_Id);
end if;
+ -- Save the scenario for examination by the ABE Processing
+ -- phase.
+
+ Record_Elaboration_Scenario (N);
+
when N_Enumeration_Type_Definition =>
Enumeration_Type_Declaration (T, Def);
T := Find_Type_Name (N);
- Set_Ekind (T, E_Incomplete_Type);
- Init_Size_Align (T);
- Set_Is_First_Subtype (T, True);
- Set_Etype (T, T);
+ Set_Ekind (T, E_Incomplete_Type);
+ Set_Etype (T, T);
+ Set_Is_First_Subtype (T);
+ Init_Size_Align (T);
+
+ -- Set the SPARK mode from the current context
+
+ Set_SPARK_Pragma (T, SPARK_Mode_Pragma);
+ Set_SPARK_Pragma_Inherited (T);
-- Ada 2005 (AI-326): Minimum decoration to give support to tagged
-- incomplete types.
Prev_Entity : Entity_Id := Empty;
procedure Check_Dynamic_Object (Typ : Entity_Id);
- -- A library-level object with non-static discriminant constraints may
+ -- A library-level object with nonstatic discriminant constraints may
-- require dynamic allocation. The declaration is illegal if the
-- profile includes the restriction No_Implicit_Heap_Allocations.
-- This function is called when a non-generic library level object of a
-- task type is declared. Its function is to count the static number of
-- tasks declared within the type (it is only called if Has_Task is set
- -- for T). As a side effect, if an array of tasks with non-static bounds
+ -- for T). As a side effect, if an array of tasks with nonstatic bounds
-- or a variant record type is encountered, Check_Restriction is called
-- indicating the count is unknown.
function Delayed_Aspect_Present return Boolean;
-- If the declaration has an expression that is an aggregate, and it
-- has aspects that require delayed analysis, the resolution of the
- -- aggregate must be deferred to the freeze point of the objet. This
+ -- aggregate must be deferred to the freeze point of the object. This
-- special processing was created for address clauses, but it must
-- also apply to Alignment. This must be done before the aspect
-- specifications are analyzed because we must handle the aggregate
-- Local variables
- Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
- -- Save the Ghost mode to restore on exit
+ Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
+ Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
+ -- Save the Ghost-related attributes to restore on exit
Related_Id : Entity_Id;
and then Nkind (E) = N_Aggregate
and then
((Present (Following_Address_Clause (N))
- and then not Ignore_Rep_Clauses)
+ and then not Ignore_Rep_Clauses)
or else Delayed_Aspect_Present)
then
Set_Etype (E, T);
+ -- If the aggregate is limited it will be built in place, and its
+ -- expansion is deferred until the object declaration is expanded.
+
+ if Is_Limited_Type (T) then
+ Set_Expansion_Delayed (E);
+ end if;
+
else
+ -- If the expression is a formal that is a "subprogram pointer"
+ -- this is illegal in accessibility terms (see RM 3.10.2 (13.1/2)
+ -- and AARM 3.10.2 (13.b/2)). Add an explicit conversion to force
+ -- the corresponding check, as is done for assignments.
+
+ if Is_Entity_Name (E)
+ and then Present (Entity (E))
+ and then Is_Formal (Entity (E))
+ and then
+ Ekind (Etype (Entity (E))) = E_Anonymous_Access_Subprogram_Type
+ and then Ekind (T) /= E_Anonymous_Access_Subprogram_Type
+ then
+ Rewrite (E, Convert_To (T, Relocate_Node (E)));
+ end if;
+
Resolve (E, T);
end if;
elsif Is_Scalar_Type (T) and then Is_OK_Static_Expression (E) then
Set_Is_Known_Valid (Id);
+
+ -- If it is a constant initialized with a valid nonstatic entity,
+ -- the constant is known valid as well, and can inherit the subtype
+ -- of the entity if it is a subtype of the given type. This info
+ -- is preserved on the actual subtype of the constant.
+
+ elsif Is_Scalar_Type (T)
+ and then Is_Entity_Name (E)
+ and then Is_Known_Valid (Entity (E))
+ and then In_Subrange_Of (Etype (Entity (E)), T)
+ then
+ Set_Is_Known_Valid (Id);
+ Set_Ekind (Id, E_Constant);
+ Set_Actual_Subtype (Id, Etype (Entity (E)));
end if;
-- Deal with setting of null flags
end if;
end if;
+ -- Set the SPARK mode from the current context (may be overwritten later
+ -- with explicit pragma).
+
+ Set_SPARK_Pragma (Id, SPARK_Mode_Pragma);
+ Set_SPARK_Pragma_Inherited (Id);
+
+ -- Preserve relevant elaboration-related attributes of the context which
+ -- are no longer available or very expensive to recompute once analysis,
+ -- resolution, and expansion are over.
+
+ Mark_Elaboration_Attributes
+ (N_Id => Id,
+ Checks => True,
+ Warnings => True);
+
-- Initialize alignment and size and capture alignment setting
Init_Alignment (Id);
and then not Is_Constrained (Underlying_Type (T))
and then not Is_Aliased (Id)
and then not Is_Class_Wide_Type (T)
- and then not Is_Controlled_Active (T)
+ and then not Is_Controlled (T)
and then not Has_Controlled_Component (Base_Type (T))
and then Expander_Active
then
Check_No_Hidden_State (Id);
end if;
- Restore_Ghost_Mode (Saved_GM);
+ Restore_Ghost_Region (Saved_GM, Saved_IGR);
end Analyze_Object_Declaration;
---------------------------
Set_Is_First_Subtype (T);
Make_Class_Wide_Type (T);
+ -- Set the SPARK mode from the current context
+
+ Set_SPARK_Pragma (T, SPARK_Mode_Pragma);
+ Set_SPARK_Pragma_Inherited (T);
+
if Unknown_Discriminants_Present (N) then
Set_Discriminant_Constraint (T, No_Elist);
end if;
-- Finally this happens in some complex cases when validity checks are
-- enabled, where the same subtype declaration may be analyzed twice.
- -- This can happen if the subtype is created by the pre-analysis of
+ -- This can happen if the subtype is created by the preanalysis of
-- an attribute tht gives the range of a loop statement, and the loop
-- itself appears within an if_statement that will be rewritten during
-- expansion.
if not Comes_From_Source (N) then
Set_Ekind (Id, Ekind (T));
- if Present (Predicate_Function (T)) then
+ if Present (Predicate_Function (Id)) then
+ null;
+
+ elsif Present (Predicate_Function (T)) then
Set_Predicate_Function (Id, Predicate_Function (T));
elsif Present (Ancestor_Subtype (T))
- and then Has_Predicates (Ancestor_Subtype (T))
and then Present (Predicate_Function (Ancestor_Subtype (T)))
then
Set_Predicate_Function (Id,
("subtype mark required", One_Cstr);
-- String subtype must have a lower bound of 1 in SPARK.
- -- Note that we do not need to test for the non-static case
+ -- Note that we do not need to test for the nonstatic case
-- here, since that was already taken care of in
-- Process_Range_Expr_In_Decl.
Set_Is_Constrained (Id, Is_Constrained (T));
Set_Is_Known_Valid (Id, Is_Known_Valid (T));
Set_RM_Size (Id, RM_Size (T));
- Inherit_Predicate_Flags (Id, T);
when Ordinary_Fixed_Point_Kind =>
Set_Ekind (Id, E_Ordinary_Fixed_Point_Subtype);
Set_Is_Constrained (Id, Is_Constrained (T));
Set_Is_Known_Valid (Id, Is_Known_Valid (T));
Set_RM_Size (Id, RM_Size (T));
- Inherit_Predicate_Flags (Id, T);
when Modular_Integer_Kind =>
Set_Ekind (Id, E_Modular_Integer_Subtype);
Set_Is_Constrained (Id, Is_Constrained (T));
Set_Is_Known_Valid (Id, Is_Known_Valid (T));
Set_RM_Size (Id, RM_Size (T));
- Inherit_Predicate_Flags (Id, T);
when Class_Wide_Kind =>
Set_Ekind (Id, E_Class_Wide_Subtype);
when others =>
raise Program_Error;
end case;
+
+ -- If there is no constraint in the subtype indication, the
+ -- declared entity inherits predicates from the parent.
+
+ Inherit_Predicate_Flags (Id, T);
end if;
if Etype (Id) = Any_Type then
Conditional_Delay (Id, T);
end if;
+ -- If we have a subtype of an incomplete type whose full type is a
+ -- derived numeric type, we need to have a freeze node for the subtype.
+ -- Otherwise gigi will complain while computing the (static) bounds of
+ -- the subtype.
+
+ if Is_Itype (T)
+ and then Is_Elementary_Type (Id)
+ and then Etype (Id) /= Id
+ then
+ declare
+ Partial : constant Entity_Id :=
+ Incomplete_Or_Partial_View (First_Subtype (Id));
+ begin
+ if Present (Partial)
+ and then Ekind (Partial) = E_Incomplete_Type
+ then
+ Set_Has_Delayed_Freeze (Id);
+ end if;
+ end;
+ end if;
+
-- Check that Constraint_Error is raised for a scalar subtype indication
-- when the lower or upper bound of a non-null range lies outside the
-- range of the type mark.
Analyze (Decl);
Set_Etype (Index, New_E);
- -- If the index is a range the Entity attribute is not
- -- available. Example:
+ -- If the index is a range or a subtype indication it carries
+ -- no entity. Example:
-- package Pkg is
-- type T is private;
-- Table : array (T(1) .. T(10)) of Boolean;
-- end Pkg;
- if Nkind (Index) /= N_Range then
+ -- Otherwise the type of the reference is its entity.
+
+ if Is_Entity_Name (Index) then
Set_Entity (Index, New_E);
end if;
end;
Set_Has_Controlled_Component
(Implicit_Base,
Has_Controlled_Component (Element_Type)
- or else Is_Controlled_Active (Element_Type));
+ or else Is_Controlled (Element_Type));
Set_Packed_Array_Impl_Type
(Implicit_Base, Empty);
Set_Has_Controlled_Component (T, Has_Controlled_Component
(Element_Type)
or else
- Is_Controlled_Active (Element_Type));
+ Is_Controlled (Element_Type));
Set_Finalize_Storage_Only (T, Finalize_Storage_Only
(Element_Type));
Set_Default_SSO (T);
Create_Itype (Ekind (Pbase), N, Derived_Type, 'B');
Svg_Chars : constant Name_Id := Chars (Ibase);
Svg_Next_E : constant Entity_Id := Next_Entity (Ibase);
+ Svg_Prev_E : constant Entity_Id := Prev_Entity (Ibase);
begin
Copy_Node (Pbase, Ibase);
Set_Associated_Node_For_Itype (Ibase, N);
Set_Chars (Ibase, Svg_Chars);
+ Set_Prev_Entity (Ibase, Svg_Prev_E);
Set_Next_Entity (Ibase, Svg_Next_E);
Set_Sloc (Ibase, Sloc (Derived_Type));
Set_Scope (Ibase, Scope (Derived_Type));
Tdef : constant Node_Id := Type_Definition (N);
Indic : constant Node_Id := Subtype_Indication (Tdef);
Parent_Base : constant Entity_Id := Base_Type (Parent_Type);
- Implicit_Base : Entity_Id;
+ Implicit_Base : Entity_Id := Empty;
New_Indic : Node_Id;
procedure Make_Implicit_Base;
N_Subtype_Indication;
D_Constraint : Node_Id;
- New_Constraint : Elist_Id;
+ New_Constraint : Elist_Id := No_Elist;
Old_Disc : Entity_Id;
New_Disc : Entity_Id;
New_N : Node_Id;
if No (Next_Entity (Old_Disc))
or else Ekind (Next_Entity (Old_Disc)) /= E_Discriminant
then
- Set_Next_Entity
+ Link_Entities
(Last_Entity (Derived_Type), Next_Entity (Old_Disc));
exit;
end if;
-- Build the full derivation if this is not the anonymous derived
-- base type created by Build_Derived_Record_Type in the constrained
-- case (see point 5. of its head comment) since we build it for the
- -- derived subtype. And skip it for protected types altogether, as
+ -- derived subtype. And skip it for synchronized types altogether, as
-- gigi does not use these types directly.
if Present (Full_View (Parent_Type))
and then not Is_Itype (Derived_Type)
- and then not (Ekind (Full_View (Parent_Type)) in Protected_Kind)
+ and then not Is_Concurrent_Type (Full_View (Parent_Type))
then
declare
Der_Base : constant Entity_Id := Base_Type (Derived_Type);
Error_Msg_N ("cannot add discriminants to untagged type", N);
end if;
- Set_Stored_Constraint (Derived_Type, No_Elist);
- Set_Is_Constrained (Derived_Type, Is_Constrained (Parent_Type));
- Set_Is_Controlled (Derived_Type, Is_Controlled (Parent_Type));
- Set_Disable_Controlled (Derived_Type, Disable_Controlled
- (Parent_Type));
+ Set_Stored_Constraint (Derived_Type, No_Elist);
+ Set_Is_Constrained (Derived_Type, Is_Constrained (Parent_Type));
+
+ Set_Is_Controlled_Active
+ (Derived_Type, Is_Controlled_Active (Parent_Type));
+
+ Set_Disable_Controlled
+ (Derived_Type, Disable_Controlled (Parent_Type));
+
Set_Has_Controlled_Component
- (Derived_Type, Has_Controlled_Component
- (Parent_Type));
+ (Derived_Type, Has_Controlled_Component (Parent_Type));
-- Direct controlled types do not inherit Finalize_Storage_Only flag
- if not Is_Controlled_Active (Parent_Type) then
+ if not Is_Controlled (Parent_Type) then
Set_Finalize_Storage_Only
(Base_Type (Derived_Type), Finalize_Storage_Only (Parent_Type));
end if;
Parent_Base := Base_Type (Parent_Type);
end if;
- -- AI05-0115 : if this is a derivation from a private type in some
+ -- AI05-0115: if this is a derivation from a private type in some
-- other scope that may lead to invisible components for the derived
-- type, mark it accordingly.
if Is_Private_Type (Parent_Type) then
- if Scope (Parent_Type) = Scope (Derived_Type) then
+ if Scope (Parent_Base) = Scope (Derived_Type) then
null;
- elsif In_Open_Scopes (Scope (Parent_Type))
- and then In_Private_Part (Scope (Parent_Type))
+ elsif In_Open_Scopes (Scope (Parent_Base))
+ and then In_Private_Part (Scope (Parent_Base))
then
null;
elsif Has_Unknown_Discriminants (Parent_Type)
and then
(not Has_Discriminants (Parent_Type)
- or else not In_Open_Scopes (Scope (Parent_Type)))
+ or else not In_Open_Scopes (Scope (Parent_Base)))
then
Set_Has_Unknown_Discriminants (Derived_Type);
end if;
and then Chars (Scope (Scope (Derived_Type))) = Name_Ada
and then Scope (Scope (Scope (Derived_Type))) = Standard_Standard
then
- Set_Is_Controlled (Derived_Type);
+ Set_Is_Controlled_Active (Derived_Type);
else
- Set_Is_Controlled (Derived_Type, Is_Controlled (Parent_Base));
+ Set_Is_Controlled_Active
+ (Derived_Type, Is_Controlled_Active (Parent_Base));
end if;
-- Minor optimization: there is no need to generate the class-wide
New_Decl :=
New_Copy_Tree
(Parent (Parent_Base), Map => Assoc_List, New_Sloc => Loc);
+ Copy_Dimensions_Of_Components (Derived_Type);
-- Restore the fields saved prior to the New_Copy_Tree call
-- and compute the stored constraint.
- Set_Etype (Derived_Type, Save_Etype);
- Set_Next_Entity (Derived_Type, Save_Next_Entity);
+ Set_Etype (Derived_Type, Save_Etype);
+ Link_Entities (Derived_Type, Save_Next_Entity);
if Has_Discriminants (Derived_Type) then
Set_Discriminant_Constraint
(Derived_Type, Save_Discr_Constr);
Set_Stored_Constraint
(Derived_Type, Expand_To_Stored_Constraint (Parent_Type, Discs));
+
Replace_Components (Derived_Type, New_Decl);
end if;
begin
-- Set common attributes
- Set_Scope (Derived_Type, Current_Scope);
-
+ Set_Scope (Derived_Type, Current_Scope);
Set_Etype (Derived_Type, Parent_Base);
Set_Ekind (Derived_Type, Ekind (Parent_Base));
Propagate_Concurrent_Flags (Derived_Type, Parent_Base);
- Set_Size_Info (Derived_Type, Parent_Type);
- Set_RM_Size (Derived_Type, RM_Size (Parent_Type));
- Set_Is_Controlled (Derived_Type, Is_Controlled (Parent_Type));
- Set_Disable_Controlled (Derived_Type, Disable_Controlled (Parent_Type));
+ Set_Size_Info (Derived_Type, Parent_Type);
+ Set_RM_Size (Derived_Type, RM_Size (Parent_Type));
- Set_Is_Tagged_Type (Derived_Type, Is_Tagged_Type (Parent_Type));
- Set_Is_Volatile (Derived_Type, Is_Volatile (Parent_Type));
+ Set_Is_Controlled_Active
+ (Derived_Type, Is_Controlled_Active (Parent_Type));
+
+ Set_Disable_Controlled (Derived_Type, Disable_Controlled (Parent_Type));
+ Set_Is_Tagged_Type (Derived_Type, Is_Tagged_Type (Parent_Type));
+ Set_Is_Volatile (Derived_Type, Is_Volatile (Parent_Type));
if Is_Tagged_Type (Derived_Type) then
Set_No_Tagged_Streams_Pragma
Set_Has_Predicates (Derived_Type);
end if;
- -- The derived type inherits the representation clauses of the parent
+ -- The derived type inherits representation clauses from the parent
+ -- type, and from any interfaces.
Inherit_Rep_Item_Chain (Derived_Type, Parent_Type);
+ declare
+ Iface : Node_Id := First (Abstract_Interface_List (Derived_Type));
+ begin
+ while Present (Iface) loop
+ Inherit_Rep_Item_Chain (Derived_Type, Entity (Iface));
+ Next (Iface);
+ end loop;
+ end;
+
-- If the parent type has delayed rep aspects, then mark the derived
-- type as possibly inheriting a delayed rep aspect.
("a range is not a valid discriminant constraint", Constr);
Discr_Expr (D) := Error;
+ elsif Nkind (Constr) = N_Subtype_Indication then
+ Error_Msg_N
+ ("a subtype indication is not a valid discriminant constraint",
+ Constr);
+ Discr_Expr (D) := Error;
+
else
Process_Discriminant_Expression (Constr, Discr);
Discr_Expr (D) := Constr;
Set_Is_Limited_Record (Def_Id, Is_Limited_Record (T));
if Has_Discrs
- and then not Is_Empty_Elmt_List (Elist)
- and then not For_Access
+ and then not Is_Empty_Elmt_List (Elist)
+ and then not For_Access
then
Create_Constrained_Components (Def_Id, Related_Nod, T, Elist);
+
elsif not For_Access then
Set_Cloned_Subtype (Def_Id, T);
end if;
return;
else
Set_Itype (IR, Ityp);
- Insert_After (Nod, IR);
+
+ -- If Nod is a library unit entity, then Insert_After won't work,
+ -- because Nod is not a member of any list. Therefore, we use
+ -- Add_Global_Declaration in this case. This can happen if we have a
+ -- build-in-place library function, child unit or not.
+
+ if (Nkind (Nod) in N_Entity and then Is_Compilation_Unit (Nod))
+ or else
+ (Nkind_In (Nod,
+ N_Defining_Program_Unit_Name, N_Subprogram_Declaration)
+ and then Is_Compilation_Unit (Defining_Entity (Nod)))
+ then
+ Add_Global_Declaration (IR);
+ else
+ Insert_After (Nod, IR);
+ end if;
end if;
end Build_Itype_Reference;
if Nkind (Exp) = N_Type_Conversion
and then Nkind (Expression (Exp)) = N_Function_Call
then
- Error_Msg_N
- ("illegal context for call"
- & " to function with limited result", Exp);
+ -- No error for internally-generated object declarations,
+ -- which can come from build-in-place assignment statements.
+
+ if Nkind (Parent (Exp)) = N_Object_Declaration
+ and then not Comes_From_Source
+ (Defining_Identifier (Parent (Exp)))
+ then
+ null;
+
+ else
+ Error_Msg_N
+ ("illegal context for call to function with limited "
+ & "result", Exp);
+ end if;
else
Error_Msg_N
- ("initialization of limited object requires aggregate "
- & "or function call", Exp);
+ ("initialization of limited object requires aggregate or "
+ & "function call", Exp);
end if;
end if;
end if;
-- or protected interfaces.
elsif Nkind (N) = N_Full_Type_Declaration
- and then Protected_Present (Type_Def)
+ and then Protected_Present (Type_Def)
then
if Limited_Present (Iface_Def)
or else Synchronized_Present (Iface_Def)
-- Note that the type of the full view is the same entity as the type
-- of the partial view. In this fashion, the subtype has access to the
-- correct view of the parent.
+ -- The list below included access types, but this leads to several
+ -- regressions. How should the base type of the full view be
+ -- set consistently for subtypes completed by access types?
Save_Next_Entity := Next_Entity (Full);
Save_Homonym := Homonym (Priv);
Set_Sloc (Full, Sloc (Priv));
end case;
- Set_Next_Entity (Full, Save_Next_Entity);
+ Link_Entities (Full, Save_Next_Entity);
Set_Homonym (Full, Save_Homonym);
Set_Associated_Node_For_Itype (Full, Related_Nod);
Set_RM_Size (Full, RM_Size (Full_Base));
Set_Is_Itype (Full);
+ -- For the unusual case of a type with unknown discriminants whose
+ -- completion is an array, use the proper full base.
+
+ if Is_Array_Type (Full_Base)
+ and then Has_Unknown_Discriminants (Priv)
+ then
+ Set_Etype (Full, Full_Base);
+ end if;
+
-- A subtype of a private-type-without-discriminants, whose full-view
-- has discriminants with default expressions, is not constrained.
end if;
-- It is unsafe to share the bounds of a scalar type, because the Itype
- -- is elaborated on demand, and if a bound is non-static then different
+ -- is elaborated on demand, and if a bound is nonstatic, then different
-- orders of elaboration in different units will lead to different
-- external symbols.
end if;
-- A deferred constant is a visible entity. If type has invariants,
- -- verify that the initial value satisfies them.
+ -- verify that the initial value satisfies them. This is not done in
+ -- GNATprove mode, as GNATprove handles invariant checks itself.
- if Has_Invariants (T) and then Present (Invariant_Procedure (T)) then
+ if Has_Invariants (T)
+ and then Present (Invariant_Procedure (T))
+ and then not GNATprove_Mode
+ then
Insert_After (N,
Make_Invariant_Call (New_Occurrence_Of (Prev, Sloc (N))));
end if;
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;
end if;
Constrain_Discriminated_Type (Def_Id, SI, Related_Nod);
+ Set_First_Private_Entity (Def_Id, First_Private_Entity (T_Ent));
Set_Depends_On_Private (Def_Id, Has_Private_Component (Def_Id));
Set_Corresponding_Record_Type (Def_Id,
Related_Nod : Node_Id) return Entity_Id
is
T_Sub : constant Entity_Id :=
- Create_Itype (E_Record_Subtype, Related_Nod, Corr_Rec, 'C');
+ Create_Itype
+ (Ekind => E_Record_Subtype,
+ Related_Nod => Related_Nod,
+ Related_Id => Corr_Rec,
+ Suffix => 'C',
+ Suffix_Index => -1);
begin
Set_Etype (T_Sub, Corr_Rec);
Set_Is_Volatile (Full, Is_Volatile (Priv));
Set_Treat_As_Volatile (Full, Treat_As_Volatile (Priv));
Set_Scope (Full, Scope (Priv));
+ Set_Prev_Entity (Full, Prev_Entity (Priv));
Set_Next_Entity (Full, Next_Entity (Priv));
Set_First_Entity (Full, First_Entity (Priv));
Set_Last_Entity (Full, Last_Entity (Priv));
Set_Parent (New_Compon, Parent (Old_Compon));
- -- If the old component's Esize was already determined and is a
- -- static value, then the new component simply inherits it. Otherwise
- -- the old component's size may require run-time determination, but
- -- the new component's size still might be statically determinable
- -- (if, for example it has a static constraint). In that case we want
- -- Layout_Type to recompute the component's size, so we reset its
- -- size and positional fields.
-
- if Frontend_Layout_On_Target
- and then not Known_Static_Esize (Old_Compon)
- then
- Set_Esize (New_Compon, Uint_0);
- Init_Normalized_First_Bit (New_Compon);
- Init_Normalized_Position (New_Compon);
- Init_Normalized_Position_Max (New_Compon);
- end if;
-
-- We do not want this node marked as Comes_From_Source, since
-- otherwise it would get first class status and a separate cross-
-- reference line would be generated. Illegitimate children do not
Set_Comes_From_Source (New_Compon, False);
-- But it is a real entity, and a birth certificate must be properly
- -- registered by entering it into the entity list.
+ -- registered by entering it into the entity list, and setting its
+ -- scope to the given subtype. This turns out to be useful for the
+ -- LLVM code generator, but that scope is not used otherwise.
Enter_Name (New_Compon);
+ Set_Scope (New_Compon, Subt);
return New_Compon;
end Create_Component;
(Parent_Type : Entity_Id;
Tagged_Type : Entity_Id)
is
- E : Entity_Id;
- Elmt : Elmt_Id;
- Iface : Entity_Id;
- Iface_Elmt : Elmt_Id;
- Iface_Subp : Entity_Id;
- New_Subp : Entity_Id := Empty;
- Prim_Elmt : Elmt_Id;
- Subp : Entity_Id;
- Typ : Entity_Id;
+ E : Entity_Id;
+ Elmt : Elmt_Id;
+ Iface : Entity_Id;
+ Iface_Alias : Entity_Id;
+ Iface_Elmt : Elmt_Id;
+ Iface_Subp : Entity_Id;
+ New_Subp : Entity_Id := Empty;
+ Prim_Elmt : Elmt_Id;
+ Subp : Entity_Id;
+ Typ : Entity_Id;
begin
pragma Assert (Ada_Version >= Ada_2005
Prim_Elmt := First_Elmt (Primitive_Operations (Iface));
while Present (Prim_Elmt) loop
- Iface_Subp := Node (Prim_Elmt);
+ Iface_Subp := Node (Prim_Elmt);
+ Iface_Alias := Ultimate_Alias (Iface_Subp);
-- Exclude derivation of predefined primitives except those
-- that come from source, or are inherited from one that comes
-- function "=" (Left, Right : Iface) return Boolean;
if not Is_Predefined_Dispatching_Operation (Iface_Subp)
- or else Comes_From_Source (Ultimate_Alias (Iface_Subp))
+ or else Comes_From_Source (Iface_Alias)
then
- E := Find_Primitive_Covering_Interface
- (Tagged_Type => Tagged_Type,
- Iface_Prim => Iface_Subp);
+ E :=
+ Find_Primitive_Covering_Interface
+ (Tagged_Type => Tagged_Type,
+ Iface_Prim => Iface_Subp);
-- If not found we derive a new primitive leaving its alias
-- attribute referencing the interface primitive.
-- Because the implicit base is used in the conversion of the bounds, we
-- have to freeze it now. This is similar to what is done for numeric
- -- types, and it equally suspicious, but otherwise a non-static bound
+ -- types, and it equally suspicious, but otherwise a nonstatic bound
-- will have a reference to an unfrozen type, which is rejected by Gigi
-- (???). This requires specific care for definition of stream
-- attributes. For details, see comments at the end of
begin
Parent_Type := Find_Type_Of_Subtype_Indic (Indic);
+ if SPARK_Mode = On
+ and then Is_Tagged_Type (Parent_Type)
+ then
+ declare
+ Partial_View : constant Entity_Id :=
+ Incomplete_Or_Partial_View (Parent_Type);
+
+ begin
+ -- If the partial view was not found then the parent type is not
+ -- a private type. Otherwise check if the partial view is a tagged
+ -- private type.
+
+ if Present (Partial_View)
+ and then Is_Private_Type (Partial_View)
+ and then not Is_Tagged_Type (Partial_View)
+ then
+ Error_Msg_NE
+ ("cannot derive from & declared as untagged private "
+ & "(SPARK RM 3.4(1))", N, Partial_View);
+ end if;
+ end;
+ end if;
+
-- Ada 2005 (AI-251): In case of interface derivation check that the
-- parent is also an interface.
begin
-- Look for the associated private type declaration
- Partial_View := First_Entity (Current_Scope);
- loop
- exit when No (Partial_View)
- or else (Has_Private_Declaration (Partial_View)
- and then Full_View (Partial_View) = T);
-
- Next_Entity (Partial_View);
- end loop;
+ Partial_View := Incomplete_Or_Partial_View (T);
-- If the partial view was not found then the source code has
-- errors and the transformation is not needed.
Error_Msg_N
("elementary or array type cannot have discriminants",
Defining_Identifier (First (Discriminant_Specifications (N))));
- Set_Has_Discriminants (T, False);
+
+ -- Unset Has_Discriminants flag to prevent cascaded errors, but
+ -- only if we are not already processing a malformed syntax tree.
+
+ if Is_Type (T) then
+ Set_Has_Discriminants (T, False);
+ end if;
-- The type is allowed to have discriminants
procedure Diagnose_Interface (N : Node_Id; E : Entity_Id) is
begin
- if not Is_Interface (E) and then E /= Any_Type then
+ if not Is_Interface (E) and then E /= Any_Type then
Error_Msg_NE ("(Ada 2005) & must be an interface", N, E);
end if;
end Diagnose_Interface;
then
Result :=
Search_Derivation_Levels (Ti, Stored_Constraint (Ti), True);
+
else
declare
- Td : constant Entity_Id := Etype (Ti);
+ Td : Entity_Id := Etype (Ti);
begin
+ -- If the parent type is private, the full view may include
+ -- renamed discriminants, and it is those stored values that
+ -- may be needed (the partial view never has more information
+ -- than the full view).
+
+ if Is_Private_Type (Td) and then Present (Full_View (Td)) then
+ Td := Full_View (Td);
+ end if;
+
if Td = Ti then
Result := Discriminant;
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;
----------------------
-- This test only concerns tagged types
if not Is_Tagged_Type (Original_Type) then
- return True;
+
+ -- Check if this is a renamed discriminant (hidden either by the
+ -- derived type or by some ancestor), unless we are analyzing code
+ -- generated by the expander since it may reference such components
+ -- (for example see the expansion of Deep_Adjust).
+
+ if Ekind (C) = E_Discriminant and then Present (N) then
+ return
+ not Comes_From_Source (N)
+ or else not Is_Completely_Hidden (C);
+ else
+ return True;
+ end if;
-- If it is _Parent or _Tag, there is no visibility issue
CW_Type : Entity_Id;
CW_Name : Name_Id;
Next_E : Entity_Id;
+ Prev_E : Entity_Id;
begin
if Present (Class_Wide_Type (T)) then
CW_Name := Chars (CW_Type);
Next_E := Next_Entity (CW_Type);
+ Prev_E := Prev_Entity (CW_Type);
Copy_Node (T, CW_Type);
Set_Comes_From_Source (CW_Type, False);
Set_Chars (CW_Type, CW_Name);
Set_Parent (CW_Type, Parent (T));
+ Set_Prev_Entity (CW_Type, Prev_E);
Set_Next_Entity (CW_Type, Next_E);
-- Ensure we have a new freeze node for the class-wide type. The partial
end if;
-- In the subtype indication case, if the immediate parent of the
- -- new subtype is non-static, then the subtype we create is non-
- -- static, even if its bounds are static.
+ -- new subtype is nonstatic, then the subtype we create is nonstatic,
+ -- even if its bounds are static.
if Nkind (N) = N_Subtype_Indication
and then not Is_OK_Static_Subtype (Entity (Subtype_Mark (N)))
-----------------------------------
procedure Preanalyze_Default_Expression (N : Node_Id; T : Entity_Id) is
- Save_In_Default_Expr : constant Boolean := In_Default_Expr;
+ Save_In_Default_Expr : constant Boolean := In_Default_Expr;
+ Save_In_Spec_Expression : constant Boolean := In_Spec_Expression;
+
begin
- In_Default_Expr := True;
- Preanalyze_Spec_Expression (N, T);
- In_Default_Expr := Save_In_Default_Expr;
+ In_Default_Expr := True;
+ In_Spec_Expression := True;
+
+ Preanalyze_With_Freezing_And_Resolve (N, T);
+
+ In_Default_Expr := Save_In_Default_Expr;
+ In_Spec_Expression := Save_In_Spec_Expression;
end Preanalyze_Default_Expression;
--------------------------------
end if;
end if;
- -- A discriminant cannot be effectively volatile (SPARK RM 7.1.3(6)).
+ -- A discriminant cannot be effectively volatile (SPARK RM 7.1.3(4)).
-- This check is relevant only when SPARK_Mode is on as it is not a
-- standard Ada legality rule.
-- Local variables
- Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
+ Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
+ Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
+ -- Save the Ghost-related attributes to restore on exit
Full_Indic : Node_Id;
Full_Parent : Entity_Id;
else
Full_List := Primitive_Operations (Full_T);
-
while Present (Prim_Elmt) loop
Prim := Node (Prim_Elmt);
then
Check_Controlling_Formals (Full_T, Prim);
- if not Is_Dispatching_Operation (Prim) then
+ if Is_Suitable_Primitive (Prim)
+ and then not Is_Dispatching_Operation (Prim)
+ then
Append_Elmt (Prim, Full_List);
- Set_Is_Dispatching_Operation (Prim, True);
+ Set_Is_Dispatching_Operation (Prim);
Set_DT_Position_Value (Prim, No_Uint);
end if;
elsif Is_Dispatching_Operation (Prim)
and then Disp_Typ /= Full_T
then
-
-- Verify that it is not otherwise controlled by a
-- formal or a return value of type T.
end if;
<<Leave>>
- Restore_Ghost_Mode (Saved_GM);
+ Restore_Ghost_Region (Saved_GM, Saved_IGR);
end Process_Full_View;
-----------------------------------
if Nkind (S) /= N_Subtype_Indication then
Find_Type (S);
+
+ -- No way to proceed if the subtype indication is malformed. This
+ -- will happen for example when the subtype indication in an object
+ -- declaration is missing altogether and the expression is analyzed
+ -- as if it were that indication.
+
+ if not Is_Entity_Name (S) then
+ return Any_Type;
+ end if;
+
Check_Incomplete (S);
P := Parent (S);
Constrain_Access (Def_Id, S, Related_Nod);
if Expander_Active
- and then Is_Itype (Designated_Type (Def_Id))
+ and then Is_Itype (Designated_Type (Def_Id))
and then Nkind (Related_Nod) = N_Subtype_Declaration
and then not Is_Incomplete_Type (Designated_Type (Def_Id))
then
when Enumeration_Kind =>
Constrain_Enumeration (Def_Id, S);
- Inherit_Predicate_Flags (Def_Id, Subtype_Mark_Id);
when Ordinary_Fixed_Point_Kind =>
Constrain_Ordinary_Fixed (Def_Id, S);
when Integer_Kind =>
Constrain_Integer (Def_Id, S);
- Inherit_Predicate_Flags (Def_Id, Subtype_Mark_Id);
when Class_Wide_Kind
| E_Incomplete_Type
end if;
when Private_Kind =>
- Constrain_Discriminated_Type (Def_Id, S, Related_Nod);
+
+ -- A private type with unknown discriminants may be completed
+ -- by an unconstrained array type.
+
+ if Has_Unknown_Discriminants (Subtype_Mark_Id)
+ and then Present (Full_View (Subtype_Mark_Id))
+ and then Is_Array_Type (Full_View (Subtype_Mark_Id))
+ then
+ Constrain_Array (Def_Id, S, Related_Nod, Related_Id, Suffix);
+
+ -- ... but more commonly is completed by a discriminated record
+ -- type.
+
+ else
+ Constrain_Discriminated_Type (Def_Id, S, Related_Nod);
+ end if;
-- The base type may be private but Def_Id may be a full view
-- in an instance.
Error_Msg_N ("invalid subtype mark in subtype indication", S);
end case;
- -- Size and Convention are always inherited from the base type
+ -- Size, Alignment, Representation aspects and Convention are always
+ -- inherited from the base type.
Set_Size_Info (Def_Id, (Subtype_Mark_Id));
+ Set_Rep_Info (Def_Id, (Subtype_Mark_Id));
Set_Convention (Def_Id, Convention (Subtype_Mark_Id));
+ -- The anonymous subtype created for the subtype indication
+ -- inherits the predicates of the parent.
+
+ if Has_Predicates (Subtype_Mark_Id) then
+ Inherit_Predicate_Flags (Def_Id, Subtype_Mark_Id);
+
+ -- Indicate where the predicate function may be found
+
+ if No (Predicate_Function (Def_Id)) and then Is_Itype (Def_Id) then
+ Set_Predicated_Parent (Def_Id, Subtype_Mark_Id);
+ end if;
+ end if;
+
return Def_Id;
end if;
end Process_Subtype;
end;
end if;
- Final_Storage_Only := not Is_Controlled_Active (T);
+ Final_Storage_Only := not Is_Controlled (T);
-- Ada 2005: Check whether an explicit Limited is present in a derived
-- type declaration.
elsif not Is_Class_Wide_Equivalent_Type (T)
and then (Has_Controlled_Component (Etype (Component))
or else (Chars (Component) /= Name_uParent
- and then Is_Controlled_Active
- (Etype (Component))))
+ and then Is_Controlled (Etype (Component))))
then
Set_Has_Controlled_Component (T, True);
Final_Storage_Only :=
Next_Discriminant (Comp);
end loop;
+ elsif Nkind (N) = N_Variant_Part then
+ Comp := First_Discriminant (Typ);
+ while Present (Comp) loop
+ if Chars (Comp) = Chars (Name (N)) then
+ Set_Entity (Name (N), Comp);
+ exit;
+ end if;
+
+ Next_Discriminant (Comp);
+ end loop;
+
elsif Nkind (N) = N_Component_Declaration then
Comp := First_Component (Typ);
while Present (Comp) loop
projects / gcc.git / blobdiff