From a6db99a61a86814241b66a17a65633338d86cc17 Mon Sep 17 00:00:00 2001 From: Steve Baird Date: Fri, 27 Mar 2020 11:56:40 -0700 Subject: [PATCH] [Ada] Fix anonymous-to-named access type implicit conversion legality checking 2020-06-12 Steve Baird gcc/ada/ * sem_res.adb (Valid_Conversion): The simpler cases of violations of the aforementioned 8.6 rule are already handled correctly. These include cases where the operand of the type conversion is an access parameter or a stand-alone object of an anonymous access type. Add code to detect violations where the operand of the type conversion is an access discriminant whose accessibility level is tied to one of the other simpler cases. This is implemented in a new function, Valid_Conversion.Is_Discrim_Of_Bad_Access_Conversion_Argument, which is called in place of the previous test. --- gcc/ada/sem_res.adb | 89 ++++++++++++++++++++++++++++++++++++++++++--- 1 file changed, 83 insertions(+), 6 deletions(-) diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index ee64248231a..0290c53d413 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -12482,6 +12482,18 @@ package body Sem_Res is -- are not rechecked because type visbility may lead to spurious errors, -- but conversions in an actual for a formal object must be checked. + function Is_Discrim_Of_Bad_Access_Conversion_Argument + (Expr : Node_Id) return Boolean; + -- Implicit anonymous-to-named access type conversions are not allowed + -- if the "statically deeper than" relationship does not apply to the + -- type of the conversion operand. See RM 8.6(28.1) and AARM 8.6(28.d). + -- We deal with most such cases elsewhere so that we can emit more + -- specific error messages (e.g., if the operand is an access parameter + -- or a saooaaat (stand-alone object of an anonymous access type)), but + -- here is where we catch the case where the operand is an access + -- discriminant selected from a dereference of another such "bad" + -- conversion argument. + function Valid_Tagged_Conversion (Target_Type : Entity_Id; Opnd_Type : Entity_Id) return Boolean; @@ -12584,6 +12596,74 @@ package body Sem_Res is end if; end In_Instance_Code; + -------------------------------------------------- + -- Is_Discrim_Of_Bad_Access_Conversion_Argument -- + -------------------------------------------------- + + function Is_Discrim_Of_Bad_Access_Conversion_Argument + (Expr : Node_Id) return Boolean + is + Exp_Type : Entity_Id := Base_Type (Etype (Expr)); + pragma Assert (Is_Access_Type (Exp_Type)); + + Associated_Node : Node_Id; + Deref_Prefix : Node_Id; + begin + if not Is_Anonymous_Access_Type (Exp_Type) then + return False; + end if; + + pragma Assert (Is_Itype (Exp_Type)); + Associated_Node := Associated_Node_For_Itype (Exp_Type); + + if Nkind (Associated_Node) /= N_Discriminant_Specification then + return False; -- not the type of an access discriminant + end if; + + -- return False if Expr not of form .all.Some_Component + + if (Nkind (Expr) /= N_Selected_Component) + or else (Nkind (Prefix (Expr)) /= N_Explicit_Dereference) + then + -- conditional expressions, declare expressions ??? + return False; + end if; + + Deref_Prefix := Prefix (Prefix (Expr)); + Exp_Type := Base_Type (Etype (Deref_Prefix)); + + -- The "statically deeper relationship" does not apply + -- to generic formal access types, so a prefix of such + -- a type is a "bad" prefix. + + if Is_Generic_Formal (Exp_Type) then + return True; + + -- The "statically deeper relationship" does apply to + -- any other named access type. + + elsif not Is_Anonymous_Access_Type (Exp_Type) then + return False; + end if; + + pragma Assert (Is_Itype (Exp_Type)); + Associated_Node := Associated_Node_For_Itype (Exp_Type); + + -- The "statically deeper relationship" applies to some + -- anonymous access types and not to others. Return + -- True for the cases where it does not apply. Also check + -- recursively for the + -- .all.Access_Discrim.all.Access_Discrim case, + -- where the correct result depends on . + + return Nkind_In (Associated_Node, + N_Procedure_Specification, -- access parameter + N_Function_Specification, -- access parameter + N_Object_Declaration -- saooaaat + ) + or else Is_Discrim_Of_Bad_Access_Conversion_Argument (Deref_Prefix); + end Is_Discrim_Of_Bad_Access_Conversion_Argument; + ---------------------------- -- Valid_Array_Conversion -- ---------------------------- @@ -13133,13 +13213,10 @@ package body Sem_Res is & "not allowed", Operand); return False; - -- This is a case where there's an enclosing object whose - -- to which the "statically deeper than" relationship does - -- not apply (such as an access discriminant selected from - -- a dereference of an access parameter). + -- Detect access discriminant values that are illegal + -- implicit anonymous-to-named access conversion operands. - elsif Object_Access_Level (Operand) - = Scope_Depth (Standard_Standard) + elsif Is_Discrim_Of_Bad_Access_Conversion_Argument (Operand) then Conversion_Error_N ("implicit conversion of anonymous access value " -- 2.30.2