From: Eric Botcazou <[email protected]>
For type conversions in instance bodies. It's barely maintainable and the
raise statements are directly inserted for these checks in other contexts.
gcc/ada/ChangeLog:
* exp_ch4.adb (Expand_N_Type_Conversion): Do not apply again static
accessibility checks in instance bodies.
* sem_res.adb (Valid_Conversion): Insert the raise statements for
the failure of static accessibility checks in instance bodies.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/exp_ch4.adb | 85 ---------------------------------------------
gcc/ada/sem_res.adb | 17 ++++++---
2 files changed, 12 insertions(+), 90 deletions(-)
diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb
index 9b36c1cc06d..52826388282 100644
--- a/gcc/ada/exp_ch4.adb
+++ b/gcc/ada/exp_ch4.adb
@@ -11501,21 +11501,9 @@ package body Exp_Ch4 is
-- assignment to temporary. If there is no change of representation,
-- then the conversion node is unchanged.
- procedure Raise_Accessibility_Error;
- -- Called when we know that an accessibility check will fail. Rewrites
- -- node N to an appropriate raise statement and outputs warning msgs.
- -- The Etype of the raise node is set to Target_Type. Note that in this
- -- case the rest of the processing should be skipped (i.e. the call to
- -- this procedure will be followed by "goto Done").
-
procedure Real_Range_Check;
-- Handles generation of range check for real target value
- function Statically_Deeper_Relation_Applies (Targ_Typ : Entity_Id)
- return Boolean;
- -- Given a target type for a conversion, determine whether the
- -- statically deeper accessibility rules apply to it.
-
--------------------------
-- Discrete_Range_Check --
--------------------------
@@ -11755,22 +11743,6 @@ package body Exp_Ch4 is
end if;
end Handle_Changed_Representation;
- -------------------------------
- -- Raise_Accessibility_Error --
- -------------------------------
-
- procedure Raise_Accessibility_Error is
- begin
- Error_Msg_Warn := SPARK_Mode /= On;
- Rewrite (N,
- Make_Raise_Program_Error (Sloc (N),
- Reason => PE_Accessibility_Check_Failed));
- Set_Etype (N, Target_Type);
-
- Error_Msg_N ("accessibility check failure<<", N);
- Error_Msg_N ("\Program_Error [<<", N);
- end Raise_Accessibility_Error;
-
----------------------
-- Real_Range_Check --
----------------------
@@ -12023,25 +11995,6 @@ package body Exp_Ch4 is
Rewrite (Expr, New_Occurrence_Of (Tnn, Loc));
end Real_Range_Check;
- ----------------------------------------
- -- Statically_Deeper_Relation_Applies --
- ----------------------------------------
-
- function Statically_Deeper_Relation_Applies (Targ_Typ : Entity_Id)
- return Boolean
- is
- begin
- -- The case where the target type is an anonymous access type is
- -- ignored since they have different semantics and get covered by
- -- various runtime checks depending on context.
-
- -- Note, the current implementation of this predicate is incomplete
- -- and doesn't fully reflect the rules given in RM 3.10.2 (19) and
- -- (19.1) ???
-
- return Ekind (Targ_Typ) /= E_Anonymous_Access_Type;
- end Statically_Deeper_Relation_Applies;
-
-- Start of processing for Expand_N_Type_Conversion
begin
@@ -12321,44 +12274,6 @@ package body Exp_Ch4 is
Apply_Accessibility_Check_For_Conversion
(Operand, Target_Type, Insert_Node => Operand);
end if;
-
- -- If the level of the operand type is statically deeper than the
- -- level of the target type, then force Program_Error. Note that this
- -- can only occur for cases where the attribute is within the body of
- -- an instantiation, otherwise the conversion will already have been
- -- rejected as illegal.
-
- -- Note: warnings are issued by the analyzer for the instance cases,
- -- and, since we are late in expansion, a check is performed to
- -- verify that neither the target type nor the operand type are
- -- internally generated - as this can lead to spurious errors when,
- -- for example, the operand type is a result of BIP expansion.
-
- elsif In_Instance_Body
- and then Statically_Deeper_Relation_Applies (Target_Type)
- and then not Is_Internal (Target_Type)
- and then not Is_Internal (Operand_Type)
- and then
- Type_Access_Level (Operand_Type) > Type_Access_Level (Target_Type)
- then
- Raise_Accessibility_Error;
- goto Done;
-
- -- When the operand is a selected access discriminant the check needs
- -- to be made against the level of the object denoted by the prefix
- -- of the selected name. Force Program_Error for this case as well
- -- (this accessibility violation can only happen if within the body
- -- of an instantiation).
-
- elsif In_Instance_Body
- and then Ekind (Operand_Type) = E_Anonymous_Access_Type
- and then Nkind (Operand) = N_Selected_Component
- and then Ekind (Entity (Selector_Name (Operand))) = E_Discriminant
- and then Static_Accessibility_Level (Operand, Zero_On_Dynamic_Level)
- > Type_Access_Level (Target_Type)
- then
- Raise_Accessibility_Error;
- goto Done;
end if;
end if;
diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index 1fd511c47d9..c91ae4e476b 100644
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -14464,8 +14464,7 @@ package body Sem_Res is
= N_Component_Declaration)
then
-- In an instance, this is a run-time check, but one we know
- -- will fail, so generate an appropriate warning. The raise
- -- will be generated by Expand_N_Type_Conversion.
+ -- will fail, so generate an appropriate warning.
if In_Instance_Body then
Error_Msg_Warn := SPARK_Mode /= On;
@@ -14473,6 +14472,11 @@ package body Sem_Res is
("cannot convert local pointer to non-local access type<<",
Operand, Report_Errs);
Report_Error_N ("\Program_Error [<<", Operand, Report_Errs);
+ Rewrite (N,
+ Make_Raise_Program_Error (Sloc (N),
+ Reason => PE_Accessibility_Check_Failed));
+ Set_Etype (N, Target_Type);
+ return False;
-- If not in an instance body, this is a real error
@@ -14484,7 +14488,6 @@ package body Sem_Res is
("cannot convert local pointer to non-local access type",
Operand, Report_Errs);
end if;
-
return False;
end if;
@@ -14505,8 +14508,7 @@ package body Sem_Res is
> Deepest_Type_Access_Level (Target_Type)
then
-- In an instance, this is a run-time check, but one we know
- -- will fail, so generate an appropriate warning. The raise
- -- will be generated by Expand_N_Type_Conversion.
+ -- will fail, so generate an appropriate warning.
if In_Instance_Body then
Error_Msg_Warn := SPARK_Mode /= On;
@@ -14515,6 +14517,11 @@ package body Sem_Res is
& "access type<<", Operand, Report_Errs);
Report_Error_N
("\Program_Error [<<", Operand, Report_Errs);
+ Rewrite (N,
+ Make_Raise_Program_Error (Sloc (N),
+ Reason => PE_Accessibility_Check_Failed));
+ Set_Etype (N, Target_Type);
+ return False;
-- If not in an instance body, this is a real error
--
2.53.0
