From af62ba41a4ed1e760e0056ba142798e8d6266e4d Mon Sep 17 00:00:00 2001 From: Eric Botcazou Date: Mon, 25 May 2020 10:42:28 +0200 Subject: [PATCH] Fix internal error on problematic renaming This is an internal renaming generated for a generalized loop iteration made on a tagged record type with predicate, and gigi cannot use the most efficient way of implementing renamings because the renamed object is an expression with a non-empty Actions list. gcc/ada/ChangeLog * gcc-interface/decl.c (gnat_to_gnu_entity): Add new local variable and use it throughout the function. : Rename local variable and adjust accordingly. In the case of a renaming, materialize the entity if the renamed object is an N_Expression_With_Actions node. : Use Alias accessor function consistently. gcc/testsuite/ChangeLog * gnat.dg/renaming16.adb: New test. * gnat.dg/renaming16_pkg.ads: New helper. --- gcc/ada/ChangeLog | 9 +++ gcc/ada/gcc-interface/decl.c | 101 +++++++++++++++++-------------- gcc/testsuite/ChangeLog | 5 ++ gcc/testsuite/gnat.dg/renaming16.adb | 11 ++++ gcc/testsuite/gnat.dg/renaming16_pkg.ads | 34 +++++++++++ 5 files changed, 114 insertions(+), 46 deletions(-) create mode 100644 gcc/testsuite/gnat.dg/renaming16.adb create mode 100644 gcc/testsuite/gnat.dg/renaming16_pkg.ads diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index d2020b8..09f81ba 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,5 +1,14 @@ 2020-05-25 Eric Botcazou + * gcc-interface/decl.c (gnat_to_gnu_entity): Add new local variable + and use it throughout the function. + : Rename local variable and adjust accordingly. In the + case of a renaming, materialize the entity if the renamed object is + an N_Expression_With_Actions node. + : Use Alias accessor function consistently. + +2020-05-25 Eric Botcazou + * gcc-interface/misc.c (get_array_bit_stride): Get to the debug type, if any, before calling gnat_get_array_descr_info. diff --git a/gcc/ada/gcc-interface/decl.c b/gcc/ada/gcc-interface/decl.c index bd69c3a..94ea05d 100644 --- a/gcc/ada/gcc-interface/decl.c +++ b/gcc/ada/gcc-interface/decl.c @@ -280,6 +280,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) { /* The construct that declared the entity. */ const Node_Id gnat_decl = Declaration_Node (gnat_entity); + /* The object that the entity renames, if any. */ + const Entity_Id gnat_renamed_obj = Renamed_Object (gnat_entity); /* The kind of the entity. */ const Entity_Kind kind = Ekind (gnat_entity); /* True if this is a type. */ @@ -327,7 +329,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) /* Contains the list of attributes directly attached to the entity. */ struct attrib *attr_list = NULL; - /* Since a use of an Itype is a definition, process it as such if it is in + /* Since a use of an itype is a definition, process it as such if it is in the main unit, except for E_Access_Subtype because it's actually a use of its base type, see below. */ if (!definition @@ -375,7 +377,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) } } - /* This abort means the Itype has an incorrect scope, i.e. that its + /* This abort means the itype has an incorrect scope, i.e. that its scope does not correspond to the subprogram it is first used in. */ gcc_unreachable (); } @@ -448,6 +450,14 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) If we are not defining it, it must be a type or an entity that is defined elsewhere or externally, otherwise we should have defined it already. + In other words, the failure of this assertion typically arises when a + reference to an entity (type or object) is made before its declaration, + either directly or by means of a freeze node which is incorrectly placed. + This can also happen for an entity referenced out of context, for example + a parameter outside of the subprogram where it is declared. GNAT_ENTITY + is the N_Defining_Identifier of the entity, the problematic N_Identifier + being the argument passed to Identifier_to_gnu in the parent frame. + One exception is for an entity, typically an inherited operation, which is a local alias for the parent's operation. It is neither defined, since it is an inherited operation, nor public, since it is declared in the current @@ -636,7 +646,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) && !gnu_expr && No (Address_Clause (gnat_entity)) && !No_Initialization (gnat_decl) - && No (Renamed_Object (gnat_entity))) + && No (gnat_renamed_obj)) { gnu_decl = error_mark_node; saved = true; @@ -692,7 +702,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) && !Treat_As_Volatile (gnat_entity) && (((Nkind (gnat_decl) == N_Object_Declaration) && Present (Expression (gnat_decl))) - || Present (Renamed_Object (gnat_entity)) + || Present (gnat_renamed_obj) || imported_p)); bool inner_const_flag = const_flag; bool static_flag = Is_Statically_Allocated (gnat_entity); @@ -704,20 +714,20 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) bool mutable_p = false; bool used_by_ref = false; tree gnu_ext_name = NULL_TREE; - tree renamed_obj = NULL_TREE; + tree gnu_renamed_obj = NULL_TREE; tree gnu_ada_size = NULL_TREE; /* We need to translate the renamed object even though we are only referencing the renaming. But it may contain a call for which we'll generate a temporary to hold the return value and which is part of the definition of the renaming, so discard it. */ - if (Present (Renamed_Object (gnat_entity)) && !definition) + if (Present (gnat_renamed_obj) && !definition) { if (kind == E_Exception) gnu_expr = gnat_to_gnu_entity (Renamed_Entity (gnat_entity), NULL_TREE, false); else - gnu_expr = gnat_to_gnu_external (Renamed_Object (gnat_entity)); + gnu_expr = gnat_to_gnu_external (gnat_renamed_obj); } /* Get the type after elaborating the renamed object. */ @@ -764,7 +774,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) /* Reject non-renamed objects whose type is an unconstrained array or any object whose type is a dummy type or void. */ if ((TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE - && No (Renamed_Object (gnat_entity))) + && No (gnat_renamed_obj)) || TYPE_IS_DUMMY_P (gnu_type) || TREE_CODE (gnu_type) == VOID_TYPE) { @@ -806,7 +816,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) initializing expression, in which case we can get the size from that. Note that the resulting size may still be a variable, so this may end up with an indirect allocation. */ - if (No (Renamed_Object (gnat_entity)) + if (No (gnat_renamed_obj) && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type))) { if (gnu_expr && kind == E_Constant) @@ -882,7 +892,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) && integer_zerop (TYPE_SIZE (gnu_type)) && !TREE_OVERFLOW (TYPE_SIZE (gnu_type)))) && !Is_Constr_Subt_For_UN_Aliased (gnat_type) - && No (Renamed_Object (gnat_entity)) + && No (gnat_renamed_obj) && No (Address_Clause (gnat_entity))) gnu_size = bitsize_unit_node; @@ -901,7 +911,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) && !Is_Constr_Subt_For_UN_Aliased (gnat_type) && !Is_Exported (gnat_entity) && !imported_p - && No (Renamed_Object (gnat_entity)) + && No (gnat_renamed_obj) && No (Address_Clause (gnat_entity)))) && TREE_CODE (TYPE_SIZE (gnu_type)) == INTEGER_CST) align = promote_object_alignment (gnu_type, gnat_entity); @@ -945,7 +955,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) because we don't support dynamic alignment. */ if (align == 0 && Ekind (gnat_type) == E_Class_Wide_Subtype - && No (Renamed_Object (gnat_entity)) + && No (gnat_renamed_obj) && No (Address_Clause (gnat_entity))) align = get_target_system_allocator_alignment () * BITS_PER_UNIT; @@ -961,7 +971,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) if (align == 0 && MINIMUM_ATOMIC_ALIGNMENT > TYPE_ALIGN (gnu_type) && !FLOAT_TYPE_P (gnu_type) - && !const_flag && No (Renamed_Object (gnat_entity)) + && !const_flag && No (gnat_renamed_obj) && !imported_p && No (Address_Clause (gnat_entity)) && kind != E_Out_Parameter && (gnu_size ? TREE_CODE (gnu_size) == INTEGER_CST @@ -1013,7 +1023,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) renaming can be applied to objects that are not names in Ada. This processing needs to be applied to the raw expression so as to make it more likely to rename the underlying object. */ - if (Present (Renamed_Object (gnat_entity))) + if (Present (gnat_renamed_obj)) { /* If the renamed object had padding, strip off the reference to the inner object and reset our type. */ @@ -1083,8 +1093,11 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) the elaborated renamed expression for the renaming. But this means that the caller is responsible for evaluating the address of the renaming in the correct place for the definition case to - instantiate the SAVE_EXPRs. */ - else if (!Materialize_Entity (gnat_entity)) + instantiate the SAVE_EXPRs. But we cannot use this mechanism if + the renamed object is an N_Expression_With_Actions because this + would fail the assertion below. */ + else if (!Materialize_Entity (gnat_entity) + && Nkind (gnat_renamed_obj) != N_Expression_With_Actions) { tree init = NULL_TREE; @@ -1140,7 +1153,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) inner_const_flag = TREE_READONLY (gnu_expr); gnu_size = NULL_TREE; - renamed_obj + gnu_renamed_obj = elaborate_reference (gnu_expr, gnat_entity, definition, &init); @@ -1148,15 +1161,15 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) likely be shared, even for a definition since the ADDR_EXPR built below can cause the first few nodes to be folded. */ if (global_bindings_p ()) - MARK_VISITED (renamed_obj); + MARK_VISITED (gnu_renamed_obj); if (type_annotate_only - && TREE_CODE (renamed_obj) == ERROR_MARK) + && TREE_CODE (gnu_renamed_obj) == ERROR_MARK) gnu_expr = NULL_TREE; else { gnu_expr - = build_unary_op (ADDR_EXPR, gnu_type, renamed_obj); + = build_unary_op (ADDR_EXPR, gnu_type, gnu_renamed_obj); if (init) gnu_expr = build_compound_expr (TREE_TYPE (gnu_expr), init, @@ -1525,7 +1538,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) imported_p || !definition, static_flag, volatile_flag, artificial_p, debug_info_p && definition, attr_list, - gnat_entity, !renamed_obj); + gnat_entity, !gnu_renamed_obj); DECL_BY_REF_P (gnu_decl) = used_by_ref; DECL_POINTS_TO_READONLY_P (gnu_decl) = used_by_ref && inner_const_flag; DECL_CAN_NEVER_BE_NULL_P (gnu_decl) = Can_Never_Be_Null (gnat_entity); @@ -1554,8 +1567,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) DECL_LOOP_PARM_P (gnu_decl) = 1; /* If this is a renaming pointer, attach the renamed object to it. */ - if (renamed_obj) - SET_DECL_RENAMED_OBJECT (gnu_decl, renamed_obj); + if (gnu_renamed_obj) + SET_DECL_RENAMED_OBJECT (gnu_decl, gnu_renamed_obj); /* If this is a constant and we are defining it or it generates a real symbol at the object level and we are referencing it, we may want @@ -3396,7 +3409,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) /* If there are entities in the chain corresponding to components that we did not elaborate, ensure we elaborate their types if - they are Itypes. */ + they are itypes. */ for (gnat_temp = First_Entity (gnat_entity); Present (gnat_temp); gnat_temp = Next_Entity (gnat_temp)) @@ -3482,7 +3495,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) /* When the subtype has discriminants and these discriminants affect the initial shape it has inherited, factor them in. But for an - Unchecked_Union (it must be an Itype), just return the type. */ + Unchecked_Union (it must be an itype), just return the type. */ if (Has_Discriminants (gnat_entity) && Stored_Constraint (gnat_entity) != No_Elist && Is_Record_Type (gnat_base_type) @@ -3970,16 +3983,14 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) of its type, so we must elaborate that type now. */ if (Present (Alias (gnat_entity))) { - const Entity_Id gnat_renamed = Renamed_Object (gnat_entity); + const Entity_Id gnat_alias = Alias (gnat_entity); - if (Ekind (Alias (gnat_entity)) == E_Enumeration_Literal) - gnat_to_gnu_entity (Etype (Alias (gnat_entity)), NULL_TREE, - false); + if (Ekind (gnat_alias) == E_Enumeration_Literal) + gnat_to_gnu_entity (Etype (gnat_alias), NULL_TREE, false); - gnu_decl - = gnat_to_gnu_entity (Alias (gnat_entity), gnu_expr, false); + gnu_decl = gnat_to_gnu_entity (gnat_alias, gnu_expr, false); - /* Elaborate any Itypes in the parameters of this entity. */ + /* Elaborate any itypes in the parameters of this entity. */ for (gnat_temp = First_Formal_With_Extras (gnat_entity); Present (gnat_temp); gnat_temp = Next_Formal_With_Extras (gnat_temp)) @@ -3987,24 +3998,22 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, false); /* Materialize renamed subprograms in the debugging information - when the renamed object is compile time known. We can consider + when the renamed object is known at compile time; we consider such renamings as imported declarations. - Because the parameters in generics instantiation are generally - materialized as renamings, we ofter end up having both the + Because the parameters in generic instantiations are generally + materialized as renamings, we often end up having both the renamed subprogram and the renaming in the same context and with - the same name: in this case, renaming is both useless debug-wise + the same name; in this case, renaming is both useless debug-wise and potentially harmful as name resolution in the debugger could return twice the same entity! So avoid this case. */ - if (debug_info_p && !artificial_p + if (debug_info_p + && !artificial_p + && (Ekind (gnat_alias) == E_Function + || Ekind (gnat_alias) == E_Procedure) && !(get_debug_scope (gnat_entity, NULL) - == get_debug_scope (gnat_renamed, NULL) - && Name_Equals (Chars (gnat_entity), - Chars (gnat_renamed))) - && Present (gnat_renamed) - && (Ekind (gnat_renamed) == E_Function - || Ekind (gnat_renamed) == E_Procedure) - && gnu_decl + == get_debug_scope (gnat_alias, NULL) + && Name_Equals (Chars (gnat_entity), Chars (gnat_alias))) && TREE_CODE (gnu_decl) == FUNCTION_DECL) { tree decl = build_decl (input_location, IMPORTED_DECL, @@ -4847,7 +4856,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) force_global--; /* If this is a packed array type whose original array type is itself - an Itype without freeze node, make sure the latter is processed. */ + an itype without freeze node, make sure the latter is processed. */ if (Is_Packed_Array_Impl_Type (gnat_entity) && Is_Itype (Original_Array_Type (gnat_entity)) && No (Freeze_Node (Original_Array_Type (gnat_entity))) @@ -10083,7 +10092,7 @@ copy_and_substitute_in_layout (Entity_Id gnat_new_type, finish_record_type (gnu_new_type, nreverse (gnu_field_list), is_subtype ? 2 : 1, debug_info_p); - /* Now go through the entities again looking for Itypes that we have not yet + /* Now go through the entities again looking for itypes that we have not yet elaborated (e.g. Etypes of fields that have Original_Components). */ for (Entity_Id gnat_field = First_Entity (gnat_new_type); Present (gnat_field); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 6e839c1..99cdfd0 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,5 +1,10 @@ 2020-05-25 Eric Botcazou + * gnat.dg/renaming16.adb: New test. + * gnat.dg/renaming16_pkg.ads: New helper. + +2020-05-25 Eric Botcazou + * gnat.dg/array40.adb: New test. * gnat.dg/array40_pkg.ads: New helper. diff --git a/gcc/testsuite/gnat.dg/renaming16.adb b/gcc/testsuite/gnat.dg/renaming16.adb new file mode 100644 index 0000000..1c30e4d --- /dev/null +++ b/gcc/testsuite/gnat.dg/renaming16.adb @@ -0,0 +1,11 @@ +-- { dg-do compile } + +with Renaming16_Pkg; use Renaming16_Pkg; + +procedure Renaming16 is + Results : Bindings_Query_Results_Type; +begin + for I in Create_Bindings_Iterator (Results) loop + null; + end loop; +end; diff --git a/gcc/testsuite/gnat.dg/renaming16_pkg.ads b/gcc/testsuite/gnat.dg/renaming16_pkg.ads new file mode 100644 index 0000000..0d978c3 --- /dev/null +++ b/gcc/testsuite/gnat.dg/renaming16_pkg.ads @@ -0,0 +1,34 @@ +with Ada.Iterator_Interfaces; + +package Renaming16_Pkg is + + type Results_Type is tagged null record; + + type Cursor is access constant Results_Type'Class; + + not overriding + function Has_Element (Position : Cursor) return Boolean; + + package Base_Iterators is + new Ada.Iterator_Interfaces (Cursor, Has_Element); + + -- Can be with null record + type Bindings_Iterator is + new Base_Iterators.Forward_Iterator with + record + Ref: Cursor; + end record; + + not overriding + function Create_Bindings_Iterator + (Results : in out Results_Type'Class) + return Bindings_Iterator; + + overriding function First (Object: Bindings_Iterator) return Cursor; + overriding function Next (Object: Bindings_Iterator; Position: Cursor) return Cursor; + + function Whatever return Boolean; + subtype Bindings_Query_Results_Type is Results_Type + with Dynamic_Predicate => Whatever; + +end Renaming16_Pkg; -- 2.7.4