@@ -116,6 +116,7 @@ package Aspects is
Aspect_Max_Entry_Queue_Length,
Aspect_Max_Queue_Length, -- GNAT
Aspect_No_Caching, -- GNAT
+ Aspect_No_Controlled_Parts,
Aspect_Object_Size, -- GNAT
Aspect_Obsolescent, -- GNAT
Aspect_Output,
@@ -403,6 +404,7 @@ package Aspects is
Aspect_Max_Entry_Queue_Length => Expression,
Aspect_Max_Queue_Length => Expression,
Aspect_No_Caching => Optional_Expression,
+ Aspect_No_Controlled_Parts => Optional_Expression,
Aspect_Object_Size => Expression,
Aspect_Obsolescent => Optional_Expression,
Aspect_Output => Name,
@@ -505,6 +507,7 @@ package Aspects is
Aspect_Max_Entry_Queue_Length => False,
Aspect_Max_Queue_Length => False,
Aspect_No_Caching => False,
+ Aspect_No_Controlled_Parts => False,
Aspect_Object_Size => True,
Aspect_Obsolescent => False,
Aspect_Output => False,
@@ -666,6 +669,7 @@ package Aspects is
Aspect_Max_Entry_Queue_Length => Name_Max_Entry_Queue_Length,
Aspect_Max_Queue_Length => Name_Max_Queue_Length,
Aspect_No_Caching => Name_No_Caching,
+ Aspect_No_Controlled_Parts => Name_No_Controlled_Parts,
Aspect_No_Elaboration_Code_All => Name_No_Elaboration_Code_All,
Aspect_No_Inline => Name_No_Inline,
Aspect_No_Return => Name_No_Return,
@@ -960,6 +964,7 @@ package Aspects is
Aspect_Max_Entry_Queue_Length => Never_Delay,
Aspect_Max_Queue_Length => Never_Delay,
Aspect_No_Caching => Never_Delay,
+ Aspect_No_Controlled_Parts => Never_Delay,
Aspect_No_Elaboration_Code_All => Never_Delay,
Aspect_No_Tagged_Streams => Never_Delay,
Aspect_Obsolescent => Never_Delay,
@@ -2192,6 +2192,11 @@ package body Freeze is
-- which is the current instance type can only be applied when the type
-- is limited.
+ procedure Check_No_Controlled_Parts_Violations (Typ : Entity_Id);
+ -- Check that Typ does not violate the semantics of aspect
+ -- No_Controlled_Parts when it is specified on Typ or one of its
+ -- ancestors.
+
procedure Check_Suspicious_Convention (Rec_Type : Entity_Id);
-- Give a warning for pragma Convention with language C or C++ applied
-- to a discriminated record type. This is suppressed for the unchecked
@@ -2412,6 +2417,361 @@ package body Freeze is
end if;
end Check_Current_Instance;
+ ------------------------------------------
+ -- Check_No_Controlled_Parts_Violations --
+ ------------------------------------------
+
+ procedure Check_No_Controlled_Parts_Violations (Typ : Entity_Id) is
+
+ function Find_Aspect_No_Controlled_Parts
+ (Typ : Entity_Id) return Node_Id;
+ -- Search for aspect No_Controlled_Parts on a given type. When
+ -- the aspect is not explicity specified Empty is returned.
+
+ function Get_Aspect_No_Controlled_Parts_Value
+ (Typ : Entity_Id) return Entity_Id;
+ -- Obtain the value for the No_Controlled_Parts aspect on a given
+ -- type. When the aspect is not explicitly specified Empty is
+ -- returned.
+
+ function Has_Aspect_No_Controlled_Parts
+ (Typ : Entity_Id) return Boolean;
+ -- Predicate function which identifies whether No_Controlled_Parts
+ -- is explicitly specified on a given type.
+
+ -------------------------------------
+ -- Find_Aspect_No_Controlled_Parts --
+ -------------------------------------
+
+ function Find_Aspect_No_Controlled_Parts
+ (Typ : Entity_Id) return Node_Id
+ is
+ Partial_View : constant Entity_Id :=
+ Incomplete_Or_Partial_View (Typ);
+
+ Aspect_Spec : Entity_Id :=
+ Find_Aspect (Typ, Aspect_No_Controlled_Parts);
+ Curr_Aspect_Spec : Entity_Id;
+ begin
+
+ -- Examine Typ's associated node, when present, since aspect
+ -- specifications do not get transferred when nodes get rewritten.
+
+ -- For example, this can happen in the expansion of array types
+
+ if No (Aspect_Spec)
+ and then Present (Associated_Node_For_Itype (Typ))
+ and then Nkind (Associated_Node_For_Itype (Typ))
+ = N_Full_Type_Declaration
+ then
+ Aspect_Spec :=
+ Find_Aspect
+ (Id => Defining_Identifier
+ (Associated_Node_For_Itype (Typ)),
+ A => Aspect_No_Controlled_Parts);
+ end if;
+
+ -- Examine aspects specifications on private type declarations
+
+ -- Should Find_Aspect be improved to handle this case ???
+
+ if No (Aspect_Spec)
+ and then Present (Partial_View)
+ and then Present
+ (Aspect_Specifications
+ (Declaration_Node
+ (Partial_View)))
+ then
+ Curr_Aspect_Spec :=
+ First
+ (Aspect_Specifications
+ (Declaration_Node
+ (Partial_View)));
+
+ -- Search through aspects present on the private type
+
+ while Present (Curr_Aspect_Spec) loop
+ if Get_Aspect_Id (Curr_Aspect_Spec)
+ = Aspect_No_Controlled_Parts
+ then
+ Aspect_Spec := Curr_Aspect_Spec;
+ exit;
+ end if;
+
+ Next (Curr_Aspect_Spec);
+ end loop;
+
+ end if;
+
+ -- When errors are posted on the aspect return Empty
+
+ if Error_Posted (Aspect_Spec) then
+ return Empty;
+ end if;
+
+ return Aspect_Spec;
+ end Find_Aspect_No_Controlled_Parts;
+
+ ------------------------------------------
+ -- Get_Aspect_No_Controlled_Parts_Value --
+ ------------------------------------------
+
+ function Get_Aspect_No_Controlled_Parts_Value
+ (Typ : Entity_Id) return Entity_Id
+ is
+ Aspect_Spec : constant Entity_Id :=
+ Find_Aspect_No_Controlled_Parts (Typ);
+ begin
+
+ -- Return the value of the aspect when present
+
+ if Present (Aspect_Spec) then
+
+ -- No expression is the same as True
+
+ if No (Expression (Aspect_Spec)) then
+ return Standard_True;
+ end if;
+
+ -- Assume its expression has already been constant folded into
+ -- a Boolean value and return its value.
+
+ return Entity (Expression (Aspect_Spec));
+ end if;
+
+ -- Otherwise, the aspect is not specified - so return Empty
+
+ return Empty;
+ end Get_Aspect_No_Controlled_Parts_Value;
+
+ ------------------------------------
+ -- Has_Aspect_No_Controlled_Parts --
+ ------------------------------------
+
+ function Has_Aspect_No_Controlled_Parts
+ (Typ : Entity_Id) return Boolean
+ is (Present (Find_Aspect_No_Controlled_Parts (Typ)));
+
+ -- Generic instances
+
+ -------------------------------------------
+ -- Get_Generic_Formal_Types_In_Hierarchy --
+ -------------------------------------------
+
+ function Get_Generic_Formal_Types_In_Hierarchy
+ is new Collect_Types_In_Hierarchy (Predicate => Is_Generic_Formal);
+ -- Return a list of all types within a given type's hierarchy which
+ -- are generic formals.
+
+ ----------------------------------------
+ -- Get_Types_With_Aspect_In_Hierarchy --
+ ----------------------------------------
+
+ function Get_Types_With_Aspect_In_Hierarchy
+ is new Collect_Types_In_Hierarchy
+ (Predicate => Has_Aspect_No_Controlled_Parts);
+ -- Returns a list of all types within a given type's hierarchy which
+ -- have the aspect No_Controlled_Parts specified.
+
+ -- Local declarations
+
+ Types_With_Aspect : Elist_Id :=
+ Get_Types_With_Aspect_In_Hierarchy (Typ);
+
+ Aspect_Value : Entity_Id;
+ Curr_Value : Entity_Id;
+ Curr_Typ_Elmt : Elmt_Id;
+ Curr_Body_Elmt : Elmt_Id;
+ Curr_Formal_Elmt : Elmt_Id;
+ Gen_Bodies : Elist_Id;
+ Gen_Formals : Elist_Id;
+ Scop : Entity_Id;
+
+ -- Start of processing for Check_No_Controlled_Parts_Violations
+
+ begin
+ -- There are no types with No_Controlled_Parts specified, so there
+ -- is nothing to check.
+
+ if Is_Empty_Elmt_List (Types_With_Aspect)
+ or else not Comes_From_Source (Typ)
+ then
+ return;
+ end if;
+
+ -- Obtain the aspect value for No_Controlled_Parts for comparison
+
+ Aspect_Value :=
+ Get_Aspect_No_Controlled_Parts_Value
+ (Node (First_Elmt (Types_With_Aspect)));
+
+ -- When the value is True and there are controlled parts or the type
+ -- itself is controlled, trigger the appropriate error.
+
+ if Aspect_Value = Standard_True
+ and then (Is_Controlled (Typ)
+ or else Has_Controlled_Component (Typ))
+ then
+ Error_Msg_N
+ ("aspect No_Controlled_Parts applied to controlled type &", Typ);
+ end if;
+
+ -- Move through Types_With_Aspect - checking that the value specified
+ -- for their corresponding No_Controlled_Parts aspects do not
+ -- override each other.
+
+ Curr_Typ_Elmt := First_Elmt (Types_With_Aspect);
+ while Present (Curr_Typ_Elmt) loop
+ Curr_Value :=
+ Get_Aspect_No_Controlled_Parts_Value (Node (Curr_Typ_Elmt));
+
+ -- Compare the aspect value against the current type
+
+ if Curr_Value /= Aspect_Value then
+ Error_Msg_NE
+ ("cannot override aspect No_Controlled_Parts of "
+ & "ancestor type &", Typ, Node (Curr_Typ_Elmt));
+ return;
+ end if;
+
+ Next_Elmt (Curr_Typ_Elmt);
+ end loop;
+
+ -- Issue an error if the aspect applies to a type declared inside a
+ -- generic body and if said type derives from or has a component of
+ -- a generic formal type - since those are considered to be both
+ -- controlled and have aspect No_Controlled_Parts specified as False
+ -- by default (RM H.4.1(4/5)).
+
+ -- We do not check tagged types since deriving from a formal type
+ -- within an enclosing generic unit is already illegal
+ -- (RM 3.9.1 (4/2)).
+
+ if Aspect_Value = Standard_True
+ and then In_Generic_Body (Typ)
+ and then not Is_Tagged_Type (Typ)
+ then
+ Gen_Bodies := New_Elmt_List;
+ Gen_Formals :=
+ Get_Generic_Formal_Types_In_Hierarchy
+ (Typ => Typ,
+ Examine_Components => True);
+
+ -- Climb scopes collecting generic bodies
+
+ Scop := Scope (Typ);
+ while Present (Scop) and then Scop /= Standard_Standard loop
+
+ -- Generic package body
+
+ if Ekind (Scop) = E_Generic_Package
+ and then In_Package_Body (Scop)
+ then
+ Append_Elmt (Scop, Gen_Bodies);
+
+ -- Generic subprogram body
+
+ elsif Is_Generic_Subprogram (Scop) then
+ Append_Elmt (Scop, Gen_Bodies);
+ end if;
+
+ Scop := Scope (Scop);
+ end loop;
+
+ -- Warn about the improper use of No_Controlled_Parts on a type
+ -- declaration deriving from or that has a component of a generic
+ -- formal type within the formal type's corresponding generic
+ -- body by moving through all formal types in Typ's hierarchy and
+ -- checking if they are formals in any of the enclosing generic
+ -- bodies.
+
+ -- However, a special exception gets made for formal types which
+ -- derive from a type which has No_Controlled_Parts True.
+
+ -- For example:
+
+ -- generic
+ -- type Form is private;
+ -- package G is
+ -- type Type_A is new Form with No_Controlled_Parts; -- OK
+ -- end;
+ --
+ -- package body G is
+ -- type Type_B is new Form with No_Controlled_Parts; -- ERROR
+ -- end;
+
+ -- generic
+ -- type Form is private;
+ -- package G is
+ -- type Type_A is record C : Form; end record
+ -- with No_Controlled_Parts; -- OK
+ -- end;
+ --
+ -- package body G is
+ -- type Type_B is record C : Form; end record
+ -- with No_Controlled_Parts; -- ERROR
+ -- end;
+
+ -- type Root is tagged null record with No_Controlled_Parts;
+ --
+ -- generic
+ -- type Form is new Root with private;
+ -- package G is
+ -- type Type_A is record C : Form; end record
+ -- with No_Controlled_Parts; -- OK
+ -- end;
+ --
+ -- package body G is
+ -- type Type_B is record C : Form; end record
+ -- with No_Controlled_Parts; -- OK
+ -- end;
+
+ Curr_Formal_Elmt := First_Elmt (Gen_Formals);
+ while Present (Curr_Formal_Elmt) loop
+
+ Curr_Body_Elmt := First_Elmt (Gen_Bodies);
+ while Present (Curr_Body_Elmt) loop
+
+ -- Obtain types in the formal type's hierarchy which have
+ -- the aspect specified.
+
+ Types_With_Aspect :=
+ Get_Types_With_Aspect_In_Hierarchy
+ (Node (Curr_Formal_Elmt));
+
+ -- We found a type declaration in a generic body where both
+ -- No_Controlled_Parts is true and one of its ancestors is a
+ -- generic formal type.
+
+ if Scope (Node (Curr_Formal_Elmt)) =
+ Node (Curr_Body_Elmt)
+
+ -- Check that no ancestors of the formal type have
+ -- No_Controlled_Parts True before issuing the error.
+
+ and then (Is_Empty_Elmt_List (Types_With_Aspect)
+ or else
+ Get_Aspect_No_Controlled_Parts_Value
+ (Node (First_Elmt (Types_With_Aspect)))
+ = Standard_False)
+ then
+ Error_Msg_Node_1 := Typ;
+ Error_Msg_Node_2 := Node (Curr_Formal_Elmt);
+ Error_Msg
+ ("aspect No_Controlled_Parts cannot be applied to "
+ & "type & which has an ancestor or component of "
+ & "formal type & within the formal type's "
+ & "corresponding generic body", Sloc (Typ));
+ end if;
+
+ Next_Elmt (Curr_Body_Elmt);
+ end loop;
+
+ Next_Elmt (Curr_Formal_Elmt);
+ end loop;
+ end if;
+ end Check_No_Controlled_Parts_Violations;
+
---------------------------------
-- Check_Suspicious_Convention --
---------------------------------
@@ -6801,6 +7161,16 @@ package body Freeze is
end;
end if;
+ -- Verify at this point that No_Controlled_Parts, when specified on
+ -- the current type or one of its ancestors, has not been overridden
+ -- and that no violation of the aspect has occurred.
+
+ -- It is important that we perform the checks here after the type has
+ -- been processed because if said type depended on a private type it
+ -- will not have been marked controlled.
+
+ Check_No_Controlled_Parts_Violations (E);
+
-- End of freeze processing for type entities
end if;
@@ -1816,6 +1816,13 @@ package body Sem_Ch13 is
Aspect := First (L);
Aspect_Loop : while Present (Aspect) loop
Analyze_One_Aspect : declare
+
+ Aspect_Exit : exception;
+ -- This exception is used to exit aspect processing completely. It
+ -- is used when an error is detected, and no further processing is
+ -- required. It is also used if an earlier error has left the tree
+ -- in a state where the aspect should not be processed.
+
Expr : constant Node_Id := Expression (Aspect);
Id : constant Node_Id := Identifier (Aspect);
Loc : constant Source_Ptr := Sloc (Aspect);
@@ -1854,6 +1861,17 @@ package body Sem_Ch13 is
procedure Analyze_Aspect_Static;
-- Ada 202x (AI12-0075): Perform analysis of aspect Static
+ procedure Check_Expr_Is_OK_Static_Expression
+ (Expr : Node_Id;
+ Typ : Entity_Id := Empty);
+ -- Check the specified expression Expr to make sure that it is a
+ -- static expression of the given type (i.e. it will be analyzed
+ -- and resolved using this type, which can be any valid argument
+ -- to Resolve, e.g. Any_Integer is OK). If not, give an error
+ -- and raise Aspect_Exit. If Typ is left Empty, then any static
+ -- expression is allowed. Includes checking that the expression
+ -- does not raise Constraint_Error.
+
function Make_Aitem_Pragma
(Pragma_Argument_Associations : List_Id;
Pragma_Name : Name_Id) return Node_Id;
@@ -2711,6 +2729,42 @@ package body Sem_Ch13 is
end if;
end Analyze_Aspect_Yield;
+ ----------------------------------------
+ -- Check_Expr_Is_OK_Static_Expression --
+ ----------------------------------------
+
+ procedure Check_Expr_Is_OK_Static_Expression
+ (Expr : Node_Id;
+ Typ : Entity_Id := Empty)
+ is
+ begin
+ if Present (Typ) then
+ Analyze_And_Resolve (Expr, Typ);
+ else
+ Analyze_And_Resolve (Expr);
+ end if;
+
+ -- An expression cannot be considered static if its resolution
+ -- failed or if it's erroneous. Stop the analysis of the
+ -- related aspect.
+
+ if Etype (Expr) = Any_Type or else Error_Posted (Expr) then
+ raise Aspect_Exit;
+
+ elsif Is_OK_Static_Expression (Expr) then
+ return;
+
+ -- Finally, we have a real error
+
+ else
+ Error_Msg_Name_1 := Nam;
+ Flag_Non_Static_Expr
+ ("entity for aspect% must be a static expression",
+ Expr);
+ raise Aspect_Exit;
+ end if;
+ end Check_Expr_Is_OK_Static_Expression;
+
-----------------------
-- Make_Aitem_Pragma --
-----------------------
@@ -2874,7 +2928,10 @@ package body Sem_Ch13 is
-- versions of the language. Allowed for them only for
-- shared variable control aspects.
- if Nkind (N) = N_Formal_Type_Declaration then
+ -- Original node is used in case expansion rewrote the node -
+ -- as is the case with generic derived types.
+
+ if Nkind (Original_Node (N)) = N_Formal_Type_Declaration then
if Ada_Version < Ada_2020 then
Error_Msg_N
("aspect % not allowed for formal type declaration",
@@ -3883,6 +3940,32 @@ package body Sem_Ch13 is
Insert_Pragma (Aitem);
goto Continue;
+ -- No_Controlled_Parts
+
+ when Aspect_No_Controlled_Parts =>
+
+ -- Check appropriate type argument
+
+ if not Is_Type (E) then
+ Error_Msg_N
+ ("aspect % can only be applied to types", E);
+ end if;
+
+ -- Disallow subtypes
+
+ if Nkind (Declaration_Node (E)) = N_Subtype_Declaration then
+ Error_Msg_N
+ ("aspect % cannot be applied to subtypes", E);
+ end if;
+
+ -- Resolve the expression to a boolean
+
+ if Present (Expr) then
+ Check_Expr_Is_OK_Static_Expression (Expr, Any_Boolean);
+ end if;
+
+ goto Continue;
+
-- Obsolescent
when Aspect_Obsolescent => declare
@@ -4860,6 +4943,8 @@ package body Sem_Ch13 is
end if;
end;
end if;
+ exception
+ when Aspect_Exit => null;
end Analyze_One_Aspect;
Next (Aspect);
@@ -10996,6 +11081,7 @@ package body Sem_Ch13 is
| Aspect_Max_Entry_Queue_Length
| Aspect_Max_Queue_Length
| Aspect_No_Caching
+ | Aspect_No_Controlled_Parts
| Aspect_Obsolescent
| Aspect_Part_Of
| Aspect_Post
@@ -6654,6 +6654,99 @@ package body Sem_Util is
return N;
end Compile_Time_Constraint_Error;
+ --------------------------------
+ -- Collect_Types_In_Hierarchy --
+ --------------------------------
+
+ function Collect_Types_In_Hierarchy
+ (Typ : Entity_Id;
+ Examine_Components : Boolean := False) return Elist_Id
+ is
+ Results : Elist_Id;
+
+ procedure Process_Type (Typ : Entity_Id);
+ -- Collect type Typ if it satisfies function Predicate. Do so for its
+ -- parent type, base type, progenitor types, and any component types.
+
+ ------------------
+ -- Process_Type --
+ ------------------
+
+ procedure Process_Type (Typ : Entity_Id) is
+ Comp : Entity_Id;
+ Iface_Elmt : Elmt_Id;
+
+ begin
+ if not Is_Type (Typ) or else Error_Posted (Typ) then
+ return;
+ end if;
+
+ -- Collect the current type if it satisfies the predicate
+
+ if Predicate (Typ) then
+ Append_Elmt (Typ, Results);
+ end if;
+
+ -- Process component types
+
+ if Examine_Components then
+
+ -- Examine components and discriminants
+
+ if Is_Concurrent_Type (Typ)
+ or else Is_Incomplete_Or_Private_Type (Typ)
+ or else Is_Record_Type (Typ)
+ or else Has_Discriminants (Typ)
+ then
+ Comp := First_Component_Or_Discriminant (Typ);
+
+ while Present (Comp) loop
+ Process_Type (Etype (Comp));
+
+ Next_Component_Or_Discriminant (Comp);
+ end loop;
+
+ -- Examine array components
+
+ elsif Ekind (Typ) = E_Array_Type then
+ Process_Type (Component_Type (Typ));
+ end if;
+ end if;
+
+ -- Examine parent type
+
+ if Etype (Typ) /= Typ then
+ Process_Type (Etype (Typ));
+ end if;
+
+ -- Examine base type
+
+ if Base_Type (Typ) /= Typ then
+ Process_Type (Base_Type (Typ));
+ end if;
+
+ -- Examine interfaces
+
+ if Is_Record_Type (Typ)
+ and then Present (Interfaces (Typ))
+ then
+ Iface_Elmt := First_Elmt (Interfaces (Typ));
+ while Present (Iface_Elmt) loop
+ Process_Type (Node (Iface_Elmt));
+
+ Next_Elmt (Iface_Elmt);
+ end loop;
+ end if;
+ end Process_Type;
+
+ -- Start of processing for Collect_Types_In_Hierarchy
+
+ begin
+ Results := New_Elmt_List;
+ Process_Type (Typ);
+ return Results;
+ end Collect_Types_In_Hierarchy;
+
-----------------------
-- Conditional_Delay --
-----------------------
@@ -581,6 +581,18 @@ package Sem_Util is
-- emitted immediately after the main message (and before output of any
-- message indicating that Constraint_Error will be raised).
+ generic
+ with function Predicate (Typ : Entity_Id) return Boolean;
+ function Collect_Types_In_Hierarchy
+ (Typ : Entity_Id;
+ Examine_Components : Boolean := False) return Elist_Id;
+ -- Inspect the ancestor and progenitor types of Typ and Typ itself -
+ -- collecting those for which function Predicate is True. The resulting
+ -- list is ordered in a type-to-ultimate-ancestor fashion.
+
+ -- When Examine_Components is True, components types in the hierarchy also
+ -- get collected.
+
procedure Conditional_Delay (New_Ent, Old_Ent : Entity_Id);
-- Sets the Has_Delayed_Freeze flag of New_Ent if the Delayed_Freeze flag
-- of Old_Ent is set and Old_Ent has not yet been Frozen (i.e. Is_Frozen is
@@ -145,6 +145,7 @@ package Snames is
Name_Exclusive_Functions : constant Name_Id := N + $;
Name_Full_Access_Only : constant Name_Id := N + $;
Name_Integer_Literal : constant Name_Id := N + $;
+ Name_No_Controlled_Parts : constant Name_Id := N + $;
Name_Real_Literal : constant Name_Id := N + $;
Name_Relaxed_Initialization : constant Name_Id := N + $;
Name_Stable_Properties : constant Name_Id := N + $;