From: Eric Botcazou <[email protected]>
The problem is that the relevant part of the RM 4.8(5.3) rule is implemented
in the expander (the other part being implemented in the analyzer), so this
merges the former with the latter and streamlines the result in the process.
This also tweaks the Accessibility_Level function to make it more robust in
the presence of errors, as well as adjusts the new error message given by
the Check_Return_Construct_Accessibility procedure, which was a mouthful
and not really in keeping with other error messages about accessibility.
gcc/ada/ChangeLog:
* accessibility.adb (Accessibility_Level): Also deal with SAOOAAATs
without extra accessibility object alongside formal parameters.
(Check_Return_Construct_Accessibility): Streamline the error message
and adjust it to expression functions.
* exp_ch4.adb (Expand_Allocator_Expression): Do not perform a static
accessibility check here.
* sem_res.adb (Resolve_Allocator): Streamline the implementation of
the static accessibility check of RM 4.8(5.3), use a more consistent
error message, adjust it to instantiation bodies, and specifically
deal with formal parameters.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/accessibility.adb | 33 +++++-----
gcc/ada/exp_ch4.adb | 32 ----------
gcc/ada/sem_res.adb | 124 ++++++++++++++++++++++----------------
3 files changed, 92 insertions(+), 97 deletions(-)
diff --git a/gcc/ada/accessibility.adb b/gcc/ada/accessibility.adb
index a32691669e4..fcd30dde28f 100644
--- a/gcc/ada/accessibility.adb
+++ b/gcc/ada/accessibility.adb
@@ -668,23 +668,12 @@ package body Accessibility is
then
return Make_Level_Literal (Scope_Depth (Standard_Standard));
- -- Return the library level for formal parameters of an anonymous
- -- access type without extra accessiblity formal. This may happen
- -- for subprograms with foreign convention or when expansion is
- -- disabled, see Sem_Ch6.Create_Extra_Formals.
-
- elsif Is_Formal (E)
- and then Ekind (Etype (E)) = E_Anonymous_Access_Type
- and then No (Get_Dynamic_Accessibility (E))
- then
- return Make_Level_Literal (Scope_Depth (Standard_Standard));
-
-- Formal parameters with an extra accessibility formal, as well
-- as stand-alone objects of an anonymous access type (SAOOAAAT).
elsif (Is_Formal (E) or else Ekind (E) in E_Constant | E_Variable)
and then Present (Get_Dynamic_Accessibility (E))
- and then (Level in Dynamic_Level | Zero_On_Dynamic_Level)
+ and then Level in Dynamic_Level | Zero_On_Dynamic_Level
then
if Level = Zero_On_Dynamic_Level then
return Make_Level_Literal (Scope_Depth (Standard_Standard));
@@ -718,6 +707,19 @@ package body Accessibility is
return New_Occurrence_Of (Get_Dynamic_Accessibility (E), Loc);
+ -- Return the library level for formal parameters or stand-alone
+ -- objects of an anonymous access type without extra accessibility
+ -- object. This may happen for subprograms with foreign convention
+ -- or when expansion is disabled, see Sem_Ch6.Create_Extra_Formals
+ -- and Exp_Ch3.Expand_N_Object_Declaration.
+
+ elsif (Is_Formal (E) or else Ekind (E) in E_Constant | E_Variable)
+ and then Is_Anonymous_Access_Type (Etype (E))
+ and then not Is_Local_Anonymous_Access (Etype (E))
+ and then Level in Dynamic_Level | Zero_On_Dynamic_Level
+ then
+ return Make_Level_Literal (Scope_Depth (Standard_Standard));
+
-- Initialization procedures have a special extra accessibility
-- parameter associated with the level at which the object
-- being initialized exists
@@ -1708,9 +1710,12 @@ package body Accessibility is
-------------------------
procedure Accessibility_Error is
+ Suffix : constant String :=
+ (if Is_Expression_Function_Or_Completion (Scope_Id)
+ then "in expression function"
+ else "in return");
Message : constant String :=
- "level of type of access discriminant value is statically too deep"
- & " in return (RM 6.5(5.9))";
+ "level of type of access discriminant is too deep " & Suffix;
begin
-- In an instance, this is a runtime check, but one we know will fail
diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb
index 1148fc21ad1..9b36c1cc06d 100644
--- a/gcc/ada/exp_ch4.adb
+++ b/gcc/ada/exp_ch4.adb
@@ -832,38 +832,6 @@ package body Exp_Ch4 is
return;
end if;
- -- Check that any anonymous access discriminants are suitable
- -- for use in an allocator.
-
- -- Note: This check is performed here instead of during analysis
- -- so that we can check against the fully resolved Etype of Exp.
-
- if Is_Entity_Name (Exp)
- and then Has_Anonymous_Access_Discriminant (Etype (Exp))
- and then Static_Accessibility_Level (Exp, Zero_On_Dynamic_Level)
- > Static_Accessibility_Level (N, Object_Decl_Level)
- then
- -- A dynamic check and a warning are generated when we are within
- -- an instance.
-
- if In_Instance then
- Insert_Action (N,
- Make_Raise_Program_Error (Loc,
- Reason => PE_Accessibility_Check_Failed));
-
- Error_Msg_Warn := SPARK_Mode /= On;
- Error_Msg_N ("anonymous access discriminant is too deep for use"
- & " in allocator<<", N);
- Error_Msg_N ("\Program_Error [<<", N);
-
- -- Otherwise, make the error static
-
- else
- Error_Msg_N ("anonymous access discriminant is too deep for use"
- & " in allocator", N);
- end if;
- end if;
-
Aggr_In_Place := Is_Delayed_Aggregate (Exp);
Delayed_Cond_Expr := Is_Delayed_Conditional_Expression (Exp);
diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index 43b6500ca61..1fd511c47d9 100644
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -5333,19 +5333,20 @@ package body Sem_Res is
Subtyp : Entity_Id;
Discrim : Entity_Id;
Constr : Node_Id;
- Aggr : Node_Id;
+ Exp : Node_Id;
Assoc : Node_Id := Empty;
Disc_Exp : Node_Id;
+ procedure Accessibility_Error (Exp : Node_Id);
+ -- Give an error about the accessibility level of the allocator
+
procedure Check_Allocator_Discrim_Accessibility
(Disc_Exp : Node_Id;
Alloc_Typ : Entity_Id);
-- Check that accessibility level associated with an access discriminant
-- initialized in an allocator by the expression Disc_Exp is not deeper
-- than the level of the allocator type Alloc_Typ. An error message is
- -- issued if this condition is violated. Specialized checks are done for
- -- the cases of a constraint expression which is an access attribute or
- -- an access discriminant.
+ -- issued if this condition is violated.
procedure Check_Allocator_Discrim_Accessibility_Exprs
(Curr_Exp : Node_Id;
@@ -5357,6 +5358,38 @@ package body Sem_Res is
-- If the allocator is an actual in a call, it is allowed to be class-
-- wide when the context is not because it is a controlling actual.
+ -------------------------
+ -- Accessibility_Error --
+ -------------------------
+
+ procedure Accessibility_Error (Exp : Node_Id) is
+ Prefix : constant String :=
+ (if Nkind (Exp) = N_Attribute_Reference
+ then "prefix of attribute"
+ else "type of access discriminant");
+ Message : constant String :=
+ Prefix & " has deeper level than allocator type";
+
+ begin
+ -- In an instance, this is a runtime check, but one we know will fail
+ -- so generate an appropriate warning. As usual, this kind of warning
+ -- is an error in SPARK mode or if No_Dynamic_Accessibility_Checks.
+
+ if In_Instance_Body then
+ Error_Msg_Warn := SPARK_Mode /= On
+ and then not
+ No_Dynamic_Accessibility_Checks_Enabled (N);
+ Error_Msg_N (Message & "<<", Exp);
+ Error_Msg_F ("\Program_Error [<<", Exp);
+ Insert_Action (N,
+ Make_Raise_Program_Error (Sloc (N),
+ Reason => PE_Accessibility_Check_Failed));
+
+ else
+ Error_Msg_N (Message, Exp);
+ end if;
+ end Accessibility_Error;
+
-------------------------------------------
-- Check_Allocator_Discrim_Accessibility --
-------------------------------------------
@@ -5366,43 +5399,21 @@ package body Sem_Res is
Alloc_Typ : Entity_Id)
is
begin
- if Type_Access_Level (Etype (Disc_Exp)) >
- Deepest_Type_Access_Level (Alloc_Typ)
+ -- The accessibility level of a function call whose result type is
+ -- an anonymous access type used to define the discriminant of an
+ -- object is the level of the object (RM 3.10.2(10.3, 14.1)), and
+ -- this level is that of the access type for an allocator.
+
+ if Nkind (Disc_Exp) = N_Function_Call
+ and then Ekind (Etype (Disc_Exp)) = E_Anonymous_Access_Type
then
- Error_Msg_N
- ("operand type has deeper level than allocator type", Disc_Exp);
+ return;
+ end if;
- -- When the expression is an Access attribute the level of the prefix
- -- object must not be deeper than that of the allocator's type.
-
- elsif Nkind (Disc_Exp) = N_Attribute_Reference
- and then Get_Attribute_Id (Attribute_Name (Disc_Exp)) =
- Attribute_Access
- and then Static_Accessibility_Level
- (Disc_Exp, Zero_On_Dynamic_Level)
- > Deepest_Type_Access_Level (Alloc_Typ)
+ if Static_Accessibility_Level (Disc_Exp, Zero_On_Dynamic_Level)
+ > Deepest_Type_Access_Level (Alloc_Typ)
then
- Error_Msg_N
- ("prefix of attribute has deeper level than allocator type",
- Disc_Exp);
-
- -- When the expression is an access discriminant the check is against
- -- the level of the prefix object.
-
- elsif Ekind (Etype (Disc_Exp)) = E_Anonymous_Access_Type
- and then Nkind (Disc_Exp) = N_Selected_Component
- and then Static_Accessibility_Level
- (Disc_Exp, Zero_On_Dynamic_Level)
- > Deepest_Type_Access_Level (Alloc_Typ)
- then
- Error_Msg_N
- ("access discriminant has deeper level than allocator type",
- Disc_Exp);
-
- -- All other cases are legal
-
- else
- null;
+ Accessibility_Error (Disc_Exp);
end if;
end Check_Allocator_Discrim_Accessibility;
@@ -5564,29 +5575,29 @@ package body Sem_Res is
-- deeper than the type of the allocator (in contrast to access
-- parameters, where the level of the actual can be arbitrary).
- -- We can't use Valid_Conversion to perform this check because in
- -- general the type of the allocator is unrelated to the type of
- -- the access discriminant.
+ -- We cannot use Valid_Conversion to perform this check because
+ -- in general the type of the allocator is unrelated to the type
+ -- of the access discriminant.
if Ekind (Typ) /= E_Anonymous_Access_Type
or else Is_Local_Anonymous_Access (Typ)
then
Subtyp := Entity (Subtype_Mark (E));
- Aggr := Original_Node (Expression (E));
+ Exp := Original_Node (Expression (E));
- if Has_Discriminants (Subtyp)
- and then Nkind (Aggr) in N_Aggregate | N_Extension_Aggregate
+ if Has_Anonymous_Access_Discriminant (Subtyp)
+ and then Nkind (Exp) in N_Aggregate | N_Extension_Aggregate
then
Discrim := First_Discriminant (Base_Type (Subtyp));
-- Get the first component expression of the aggregate
- if Present (Expressions (Aggr)) then
- Disc_Exp := First (Expressions (Aggr));
+ if Present (Expressions (Exp)) then
+ Disc_Exp := First (Expressions (Exp));
- elsif Present (Component_Associations (Aggr)) then
- Assoc := First (Component_Associations (Aggr));
+ elsif Present (Component_Associations (Exp)) then
+ Assoc := First (Component_Associations (Exp));
if Present (Assoc) then
Disc_Exp := Expression (Assoc);
@@ -5615,7 +5626,7 @@ package body Sem_Res is
Next (Disc_Exp);
else
- Assoc := First (Component_Associations (Aggr));
+ Assoc := First (Component_Associations (Exp));
if Present (Assoc) then
Disc_Exp := Expression (Assoc);
@@ -5625,6 +5636,16 @@ package body Sem_Res is
end if;
end if;
end loop;
+
+ -- Apply the RM 3.10.2(12.4) rule to formal parameters
+
+ elsif Has_Anonymous_Access_Discriminant (Subtyp)
+ and then Is_Entity_Name (Exp)
+ and then Is_Formal (Entity (Exp))
+ and then Static_Accessibility_Level (Exp, Zero_On_Dynamic_Level)
+ > Deepest_Type_Access_Level (Typ)
+ then
+ Accessibility_Error (Exp);
end if;
end if;
@@ -5643,7 +5664,8 @@ package body Sem_Res is
-- expression used to constrain an access discriminant cannot be
-- deeper than the type of the allocator (in contrast to access
-- parameters, where the level of the actual can be arbitrary).
- -- We can't use Valid_Conversion to perform this check because
+
+ -- We cannot use Valid_Conversion to perform this check because
-- in general the type of the allocator is unrelated to the type
-- of the access discriminant.
@@ -5653,7 +5675,7 @@ package body Sem_Res is
then
Subtyp := Entity (Subtype_Mark (Original_Node (E)));
- if Has_Discriminants (Subtyp) then
+ if Has_Anonymous_Access_Discriminant (Subtyp) then
Discrim := First_Discriminant (Base_Type (Subtyp));
Constr := First (Constraints (Constraint (Original_Node (E))));
while Present (Discrim) and then Present (Constr) loop
--
2.53.0
