Fix internal error on problematic renaming
authorEric Botcazou <ebotcazou@gcc.gnu.org>
Mon, 25 May 2020 08:42:28 +0000 (10:42 +0200)
committerEric Botcazou <ebotcazou@gcc.gnu.org>
Mon, 25 May 2020 08:44:00 +0000 (10:44 +0200)
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.
<E_Variable>: 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.
<E_Procedure>: Use Alias accessor function consistently.

gcc/testsuite/ChangeLog
* gnat.dg/renaming16.adb: New test.
* gnat.dg/renaming16_pkg.ads: New helper.

gcc/ada/ChangeLog
gcc/ada/gcc-interface/decl.c
gcc/testsuite/ChangeLog
gcc/testsuite/gnat.dg/renaming16.adb [new file with mode: 0644]
gcc/testsuite/gnat.dg/renaming16_pkg.ads [new file with mode: 0644]

index d2020b8894c0e6021d443a58056440771b84a34c..09f81ba2486b94dd8ec9b446846b41f9513b3fd3 100644 (file)
@@ -1,3 +1,12 @@
+2020-05-25  Eric Botcazou  <ebotcazou@adacore.com>
+
+       * gcc-interface/decl.c (gnat_to_gnu_entity): Add new local variable
+       and use it throughout the function.
+       <E_Variable>: 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.
+       <E_Procedure>: Use Alias accessor function consistently.
+
 2020-05-25  Eric Botcazou  <ebotcazou@adacore.com>
 
        * gcc-interface/misc.c (get_array_bit_stride): Get to the debug type,
index bd69c3ab3062451a8a6d038ee29169c3bb8e4eef..94ea05de14fb95978e54df5c0de30f66f11f9337 100644 (file)
@@ -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);
index 6e839c1262e926cbe79e719a1fb26fde9cbccc35..99cdfd0929e71db010b1fdb640dabe81cf47f4ee 100644 (file)
@@ -1,3 +1,8 @@
+2020-05-25  Eric Botcazou  <ebotcazou@adacore.com>
+
+       * gnat.dg/renaming16.adb: New test.
+       * gnat.dg/renaming16_pkg.ads: New helper.
+
 2020-05-25  Eric Botcazou  <ebotcazou@adacore.com>
 
        * gnat.dg/array40.adb: New test.
diff --git a/gcc/testsuite/gnat.dg/renaming16.adb b/gcc/testsuite/gnat.dg/renaming16.adb
new file mode 100644 (file)
index 0000000..1c30e4d
--- /dev/null
@@ -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 (file)
index 0000000..0d978c3
--- /dev/null
@@ -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;