re PR ada/58264 (incorrect bounds of string when assigned from dereference of functio...

	PR ada/58264
	* gcc-interface/trans.c (Attribute_to_gnu): Define GNAT_PREFIX local
	variable and use it throughout.
	<Attr_Length>: Note whether the prefix is the dereference of a pointer
	to unconstrained array and, in this case, capture the result for both
	Attr_First and Attr_Last.

From-SVN: r202694

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 686f62cc863701b3b8c0e75070cb2f9be6acb71b..6b0ba092134fc62c1221beb9b8009218d042579e 100644 (file)
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,12 @@
+2013-09-18  Eric Botcazou  <ebotcazou@adacore.com>
+
+       PR ada/58264
+       * gcc-interface/trans.c (Attribute_to_gnu): Define GNAT_PREFIX local
+       variable and use it throughout.
+       <Attr_Length>: Note whether the prefix is the dereference of a pointer
+       to unconstrained array and, in this case, capture the result for both
+       Attr_First and Attr_Last.
+
 2013-09-18  Eric Botcazou  <ebotcazou@adacore.com>
 
        * gcc-interface/decl.c (gnat_to_gnu_entity) <E_Abstract_State>: New.

diff --git a/gcc/ada/gcc-interface/trans.c b/gcc/ada/gcc-interface/trans.c
index 6fc22bbad426aa6069f1bf47674c73fb18bfb55e..7e56f22c3f042ccae4632b5520ea512006a0ded4 100644 (file)
--- a/gcc/ada/gcc-interface/trans.c
+++ b/gcc/ada/gcc-interface/trans.c
@@ -1391,6 +1391,7 @@ Pragma_to_gnu (Node_Id gnat_node)
 static tree
 Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute)
 {
+  const Node_Id gnat_prefix = Prefix (gnat_node);
   tree gnu_prefix, gnu_type, gnu_expr;
   tree gnu_result_type, gnu_result = error_mark_node;
   bool prefix_unused = false;
@@ -1400,13 +1401,13 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute)
      parameter types might be incomplete types coming from a limited with.  */
   if (Ekind (Etype (gnat_node)) == E_Access_Subprogram_Type
       && Is_Dispatch_Table_Entity (Etype (gnat_node))
-      && Nkind (Prefix (gnat_node)) == N_Identifier
-      && Is_Subprogram (Entity (Prefix (gnat_node)))
-      && Is_Public (Entity (Prefix (gnat_node)))
-      && !present_gnu_tree (Entity (Prefix (gnat_node))))
-    gnu_prefix = get_minimal_subprog_decl (Entity (Prefix (gnat_node)));
+      && Nkind (gnat_prefix) == N_Identifier
+      && Is_Subprogram (Entity (gnat_prefix))
+      && Is_Public (Entity (gnat_prefix))
+      && !present_gnu_tree (Entity (gnat_prefix)))
+    gnu_prefix = get_minimal_subprog_decl (Entity (gnat_prefix));
   else
-    gnu_prefix = gnat_to_gnu (Prefix (gnat_node));
+    gnu_prefix = gnat_to_gnu (gnat_prefix);
   gnu_type = TREE_TYPE (gnu_prefix);
 
   /* If the input is a NULL_EXPR, make a new one.  */
@@ -1549,8 +1550,8 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute)
         since it can use a special calling convention on some platforms,
         which cannot be propagated to the access type.  */
       else if (attribute == Attr_Access
-              && Nkind (Prefix (gnat_node)) == N_Identifier
-              && is_cplusplus_method (Entity (Prefix (gnat_node))))
+              && Nkind (gnat_prefix) == N_Identifier
+              && is_cplusplus_method (Entity (gnat_prefix)))
        post_error ("access to C++ constructor or member function not allowed",
                    gnat_node);
 
@@ -1661,13 +1662,12 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute)
          /* If this is a dereference and we have a special dynamic constrained
             subtype on the prefix, use it to compute the size; otherwise, use
             the designated subtype.  */
-         if (Nkind (Prefix (gnat_node)) == N_Explicit_Dereference)
+         if (Nkind (gnat_prefix) == N_Explicit_Dereference)
            {
-             Node_Id gnat_deref = Prefix (gnat_node);
              Node_Id gnat_actual_subtype
-               = Actual_Designated_Subtype (gnat_deref);
+               = Actual_Designated_Subtype (gnat_prefix);
              tree gnu_ptr_type
-               = TREE_TYPE (gnat_to_gnu (Prefix (gnat_deref)));
+               = TREE_TYPE (gnat_to_gnu (Prefix (gnat_prefix)));
 
              if (TYPE_IS_FAT_OR_THIN_POINTER_P (gnu_ptr_type)
                  && Present (gnat_actual_subtype))
@@ -1728,7 +1728,6 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute)
          align = DECL_ALIGN (TREE_OPERAND (gnu_prefix, 1)) / BITS_PER_UNIT;
        else
          {
-           Node_Id gnat_prefix = Prefix (gnat_node);
            Entity_Id gnat_type = Etype (gnat_prefix);
            unsigned int double_align;
            bool is_capped_double, align_clause;
@@ -1800,28 +1799,38 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute)
                         : 1), i;
        struct parm_attr_d *pa = NULL;
        Entity_Id gnat_param = Empty;
+       bool unconstrained_ptr_deref = false;
 
        /* Make sure any implicit dereference gets done.  */
        gnu_prefix = maybe_implicit_deref (gnu_prefix);
        gnu_prefix = maybe_unconstrained_array (gnu_prefix);
 
-       /* We treat unconstrained array In parameters specially.  */
-       if (!Is_Constrained (Etype (Prefix (gnat_node))))
-         {
-           Node_Id gnat_prefix = Prefix (gnat_node);
-
-           /* This is the direct case.  */
-           if (Nkind (gnat_prefix) == N_Identifier
-               && Ekind (Entity (gnat_prefix)) == E_In_Parameter)
-             gnat_param = Entity (gnat_prefix);
-
-           /* This is the indirect case.  Note that we need to be sure that
-              the access value cannot be null as we'll hoist the load.  */
-           if (Nkind (gnat_prefix) == N_Explicit_Dereference
-               && Nkind (Prefix (gnat_prefix)) == N_Identifier
-               && Ekind (Entity (Prefix (gnat_prefix))) == E_In_Parameter
-               && Can_Never_Be_Null (Entity (Prefix (gnat_prefix))))
-             gnat_param = Entity (Prefix (gnat_prefix));
+       /* We treat unconstrained array In parameters specially.  We also note
+          whether we are dereferencing a pointer to unconstrained array.  */
+       if (!Is_Constrained (Etype (gnat_prefix)))
+         switch (Nkind (gnat_prefix))
+           {
+           case N_Identifier:
+             /* This is the direct case.  */
+             if (Ekind (Entity (gnat_prefix)) == E_In_Parameter)
+               gnat_param = Entity (gnat_prefix);
+             break;
+
+           case N_Explicit_Dereference:
+             /* This is the indirect case.  Note that we need to be sure that
+                the access value cannot be null as we'll hoist the load.  */
+             if (Nkind (Prefix (gnat_prefix)) == N_Identifier
+                 && Ekind (Entity (Prefix (gnat_prefix))) == E_In_Parameter)
+               {
+                 if (Can_Never_Be_Null (Entity (Prefix (gnat_prefix))))
+                   gnat_param = Entity (Prefix (gnat_prefix));
+               }
+             else
+               unconstrained_ptr_deref = true;
+             break;
+
+           default:
+             break;
          }
 
        /* If the prefix is the view conversion of a constrained array to an
@@ -1956,22 +1965,54 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute)
          {
            gnu_result
              = build1 (SAVE_EXPR, TREE_TYPE (gnu_result), gnu_result);
-           if (attribute == Attr_First)
-             pa->first = gnu_result;
-           else if (attribute == Attr_Last)
-             pa->last = gnu_result;
-           else
-             pa->length = gnu_result;
+           switch (attribute)
+             {
+             case Attr_First:
+               pa->first = gnu_result;
+               break;
+
+             case Attr_Last:
+               pa->last = gnu_result;
+               break;
+
+             case Attr_Length:
+             case Attr_Range_Length:
+               pa->length = gnu_result;
+               break;
+
+             default:
+               gcc_unreachable ();
+             }
          }
 
-       /* Set the source location onto the predicate of the condition in the
-          'Length case but do not do it if the expression is cached to avoid
-          messing up the debug info.  */
-       else if ((attribute == Attr_Range_Length || attribute == Attr_Length)
-                && TREE_CODE (gnu_result) == COND_EXPR
-                && EXPR_P (TREE_OPERAND (gnu_result, 0)))
-         set_expr_location_from_node (TREE_OPERAND (gnu_result, 0),
-                                      gnat_node);
+       /* Otherwise, evaluate it each time it is referenced.  */
+       else
+         switch (attribute)
+           {
+           case Attr_First:
+           case Attr_Last:
+             /* If we are dereferencing a pointer to unconstrained array, we
+                need to capture the value because the pointed-to bounds may
+                subsequently be released.  */
+             if (unconstrained_ptr_deref)
+               gnu_result
+                 = build1 (SAVE_EXPR, TREE_TYPE (gnu_result), gnu_result);
+             break;
+
+           case Attr_Length:
+           case Attr_Range_Length:
+             /* Set the source location onto the predicate of the condition
+                but not if the expression is cached to avoid messing up the
+                debug info.  */
+             if (TREE_CODE (gnu_result) == COND_EXPR
+                 && EXPR_P (TREE_OPERAND (gnu_result, 0)))
+               set_expr_location_from_node (TREE_OPERAND (gnu_result, 0),
+                                            gnat_node);
+             break;
+
+           default:
+             gcc_unreachable ();
+           }
 
        break;
       }
@@ -2144,8 +2185,8 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute)
 
     case Attr_Mechanism_Code:
       {
+       Entity_Id gnat_obj = Entity (gnat_prefix);
        int code;
-       Entity_Id gnat_obj = Entity (Prefix (gnat_node));
 
        prefix_unused = true;
        gnu_result_type = get_unpadded_type (Etype (gnat_node));
@@ -2180,10 +2221,11 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute)
      it has a side-effect.  But don't do it if the prefix is just an entity
      name.  However, if an access check is needed, we must do it.  See second
      example in AARM 11.6(5.e).  */
-  if (prefix_unused && TREE_SIDE_EFFECTS (gnu_prefix)
-      && !Is_Entity_Name (Prefix (gnat_node)))
-    gnu_result = build_compound_expr  (TREE_TYPE (gnu_result), gnu_prefix,
-                                      gnu_result);
+  if (prefix_unused
+      && TREE_SIDE_EFFECTS (gnu_prefix)
+      && !Is_Entity_Name (gnat_prefix))
+    gnu_result
+      = build_compound_expr  (TREE_TYPE (gnu_result), gnu_prefix, gnu_result);
 
   *gnu_result_type_p = gnu_result_type;
   return gnu_result;

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 6da9c74408397217a77eb133286930873a731c79..1e9450548cbd196d7280691790877d9c9374a564 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,7 @@
+2013-09-18  Eric Botcazou  <ebotcazou@adacore.com>
+
+       *  gnat.dg/array_bounds_test2.adb: New test.
+
 2013-09-18  Kyrylo Tkachov  <kyrylo.tkachov@arm.com>
 
        * g++.dg/debug/dwarf2/omp-fesdr.C: Check for fopenmp effective target.

diff --git a/gcc/testsuite/gnat.dg/array_bounds_test2.adb b/gcc/testsuite/gnat.dg/array_bounds_test2.adb
new file mode 100644 (file)
index 0000000..43e1ed3
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/array_bounds_test2.adb
@@ -0,0 +1,25 @@
+--  { dg-do run }
+
+with Ada.Unchecked_Deallocation;
+
+procedure Array_Bounds_Test2 is
+
+  type String_Ptr_T is access String;
+  procedure Free is new Ada.Unchecked_Deallocation (String, String_Ptr_T);
+  String_Data : String_Ptr_T := new String'("Hello World");
+
+  function Peek return String_Ptr_T is
+  begin
+    return String_Data;
+  end Peek;
+
+begin
+  declare
+    Corrupted_String : String := Peek.all;
+  begin
+    Free(String_Data);
+    if Corrupted_String'First /= 1 then
+      raise Program_Error;
+    end if;
+  end;
+end;