check.c (gfc_check_move_alloc): Introduce error to prevent aliasing between to and...

2016-11-05  Paul Thomas  <pault@gcc.gnu.org>

	* check.c (gfc_check_move_alloc): Introduce error to prevent
	aliasing between to and from arguments.

2016-11-05  Paul Thomas  <pault@gcc.gnu.org>

	* gfortran.dg/move_alloc_17.f03: New test.

From-SVN: r241872

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 10aaff86c64bedcb89641f637f1fb230e9e3748f..41225b55650364a425f9053964f71a29f70628a3 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,8 @@
+2016-11-05  Paul Thomas  <pault@gcc.gnu.org>
+
+       * check.c (gfc_check_move_alloc): Introduce error to prevent
+       aliasing between to and from arguments.
+
 2016-11-05  Janus Weil  <janus@gcc.gnu.org>
            Manuel Lopez-Ibanez  <manu@gcc.gnu.org>
 

diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index 5057d4999fd7e35bf9cdbfa3959911f742ed10e6..142cdac2e38e9dcaa0acae18a90bcde898aac1a5 100644 (file)
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -880,7 +880,7 @@ gfc_check_a_p (gfc_expr *a, gfc_expr *p)
 
   if (a->ts.kind != p->ts.kind)
     {
-      if (!gfc_notify_std (GFC_STD_GNU, "Different type kinds at %L", 
+      if (!gfc_notify_std (GFC_STD_GNU, "Different type kinds at %L",
                           &p->where))
        return false;
     }
@@ -1797,7 +1797,7 @@ gfc_check_count (gfc_expr *mask, gfc_expr *dim, gfc_expr *kind)
   if (!kind_check (kind, 2, BT_INTEGER))
     return false;
   if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
-                              "with KIND argument at %L", 
+                              "with KIND argument at %L",
                               gfc_current_intrinsic, &kind->where))
     return false;
 
@@ -2127,11 +2127,11 @@ gfc_check_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary,
        }
       else if (boundary->rank == array->rank - 1)
        {
-         if (!gfc_check_conformance (shift, boundary, 
+         if (!gfc_check_conformance (shift, boundary,
                                      "arguments '%s' and '%s' for "
-                                     "intrinsic %s", 
-                                     gfc_current_intrinsic_arg[1]->name, 
-                                     gfc_current_intrinsic_arg[2]->name, 
+                                     "intrinsic %s",
+                                     gfc_current_intrinsic_arg[1]->name,
+                                     gfc_current_intrinsic_arg[2]->name,
                                      gfc_current_intrinsic))
            return false;
        }
@@ -2156,7 +2156,7 @@ gfc_check_float (gfc_expr *a)
 
   if ((a->ts.kind != gfc_default_integer_kind)
       && !gfc_notify_std (GFC_STD_GNU, "non-default INTEGER "
-                         "kind argument to %s intrinsic at %L", 
+                         "kind argument to %s intrinsic at %L",
                          gfc_current_intrinsic, &a->where))
     return false;
 
@@ -2283,7 +2283,7 @@ gfc_check_iand (gfc_expr *i, gfc_expr *j)
 
   if (i->ts.kind != j->ts.kind)
     {
-      if (!gfc_notify_std (GFC_STD_GNU, "Different type kinds at %L", 
+      if (!gfc_notify_std (GFC_STD_GNU, "Different type kinds at %L",
                           &i->where))
        return false;
     }
@@ -2329,7 +2329,7 @@ gfc_check_ichar_iachar (gfc_expr *c, gfc_expr *kind)
     return false;
 
   if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
-                              "with KIND argument at %L", 
+                              "with KIND argument at %L",
                               gfc_current_intrinsic, &kind->where))
     return false;
 
@@ -2409,7 +2409,7 @@ gfc_check_ieor (gfc_expr *i, gfc_expr *j)
 
   if (i->ts.kind != j->ts.kind)
     {
-      if (!gfc_notify_std (GFC_STD_GNU, "Different type kinds at %L", 
+      if (!gfc_notify_std (GFC_STD_GNU, "Different type kinds at %L",
                           &i->where))
        return false;
     }
@@ -2432,7 +2432,7 @@ gfc_check_index (gfc_expr *string, gfc_expr *substring, gfc_expr *back,
   if (!kind_check (kind, 3, BT_INTEGER))
     return false;
   if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
-                              "with KIND argument at %L", 
+                              "with KIND argument at %L",
                               gfc_current_intrinsic, &kind->where))
     return false;
 
@@ -2483,7 +2483,7 @@ gfc_check_ior (gfc_expr *i, gfc_expr *j)
 
   if (i->ts.kind != j->ts.kind)
     {
-      if (!gfc_notify_std (GFC_STD_GNU, "Different type kinds at %L", 
+      if (!gfc_notify_std (GFC_STD_GNU, "Different type kinds at %L",
                           &i->where))
        return false;
     }
@@ -2633,7 +2633,7 @@ gfc_check_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
   if (!kind_check (kind, 2, BT_INTEGER))
     return false;
   if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
-                              "with KIND argument at %L", 
+                              "with KIND argument at %L",
                               gfc_current_intrinsic, &kind->where))
     return false;
 
@@ -2678,7 +2678,7 @@ gfc_check_len_lentrim (gfc_expr *s, gfc_expr *kind)
   if (!kind_check (kind, 1, BT_INTEGER))
     return false;
   if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
-                              "with KIND argument at %L", 
+                              "with KIND argument at %L",
                               gfc_current_intrinsic, &kind->where))
     return false;
 
@@ -2948,7 +2948,7 @@ gfc_check_min_max (gfc_actual_arglist *arg)
   if (x->ts.type == BT_CHARACTER)
     {
       if (!gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
-                          "with CHARACTER argument at %L", 
+                          "with CHARACTER argument at %L",
                           gfc_current_intrinsic, &x->where))
        return false;
     }
@@ -3118,10 +3118,10 @@ gfc_check_minloc_maxloc (gfc_actual_arglist *ap)
     return false;
 
   if (m != NULL
-      && !gfc_check_conformance (a, m, 
-                                "arguments '%s' and '%s' for intrinsic %s", 
-                                gfc_current_intrinsic_arg[0]->name, 
-                                gfc_current_intrinsic_arg[2]->name, 
+      && !gfc_check_conformance (a, m,
+                                "arguments '%s' and '%s' for intrinsic %s",
+                                gfc_current_intrinsic_arg[0]->name,
+                                gfc_current_intrinsic_arg[2]->name,
                                 gfc_current_intrinsic))
     return false;
 
@@ -3172,10 +3172,10 @@ check_reduction (gfc_actual_arglist *ap)
     return false;
 
   if (m != NULL
-      && !gfc_check_conformance (a, m, 
-                                "arguments '%s' and '%s' for intrinsic %s", 
-                                gfc_current_intrinsic_arg[0]->name, 
-                                gfc_current_intrinsic_arg[2]->name, 
+      && !gfc_check_conformance (a, m,
+                                "arguments '%s' and '%s' for intrinsic %s",
+                                gfc_current_intrinsic_arg[0]->name,
+                                gfc_current_intrinsic_arg[2]->name,
                                 gfc_current_intrinsic))
     return false;
 
@@ -3342,6 +3342,16 @@ gfc_check_move_alloc (gfc_expr *from, gfc_expr *to)
       return false;
     }
 
+  /*  F2003 12.4.1.7  */
+  if (to->expr_type == EXPR_VARIABLE && from->expr_type ==EXPR_VARIABLE
+      && !strcmp (to->symtree->n.sym->name, from->symtree->n.sym->name))
+    {
+      gfc_error ("The FROM and TO arguments at %L are either the same object "
+                "or subobjects thereof and so violate aliasing restrictions "
+                "(F2003 12.4.1.7)", &to->where);
+      return false;
+    }
+
   /* CLASS arguments: Make sure the vtab of from is present.  */
   if (to->ts.type == BT_CLASS && !UNLIMITED_POLY (from))
     gfc_find_vtab (&from->ts);
@@ -3447,10 +3457,10 @@ gfc_check_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector)
   if (!type_check (mask, 1, BT_LOGICAL))
     return false;
 
-  if (!gfc_check_conformance (array, mask, 
-                             "arguments '%s' and '%s' for intrinsic '%s'", 
-                             gfc_current_intrinsic_arg[0]->name, 
-                             gfc_current_intrinsic_arg[1]->name, 
+  if (!gfc_check_conformance (array, mask,
+                             "arguments '%s' and '%s' for intrinsic '%s'",
+                             gfc_current_intrinsic_arg[0]->name,
+                             gfc_current_intrinsic_arg[1]->name,
                              gfc_current_intrinsic))
     return false;
 
@@ -3989,7 +3999,7 @@ gfc_check_scan (gfc_expr *x, gfc_expr *y, gfc_expr *z, gfc_expr *kind)
   if (!kind_check (kind, 3, BT_INTEGER))
     return false;
   if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
-                              "with KIND argument at %L", 
+                              "with KIND argument at %L",
                               gfc_current_intrinsic, &kind->where))
     return false;
 
@@ -4050,7 +4060,7 @@ gfc_check_selected_real_kind (gfc_expr *p, gfc_expr *r, gfc_expr *radix)
 {
   if (p == NULL && r == NULL
       && !gfc_notify_std (GFC_STD_F2008, "SELECTED_REAL_KIND with"
-                         " neither %<P%> nor %<R%> argument at %L", 
+                         " neither %<P%> nor %<R%> argument at %L",
                          gfc_current_intrinsic_where))
     return false;
 
@@ -4081,7 +4091,7 @@ gfc_check_selected_real_kind (gfc_expr *p, gfc_expr *r, gfc_expr *radix)
        return false;
 
       if (!gfc_notify_std (GFC_STD_F2008, "%qs intrinsic with "
-                          "RADIX argument at %L", gfc_current_intrinsic, 
+                          "RADIX argument at %L", gfc_current_intrinsic,
                           &radix->where))
        return false;
     }
@@ -4123,7 +4133,7 @@ gfc_check_shape (gfc_expr *source, gfc_expr *kind)
   if (!kind_check (kind, 1, BT_INTEGER))
     return false;
   if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
-                              "with KIND argument at %L", 
+                              "with KIND argument at %L",
                               gfc_current_intrinsic, &kind->where))
     return false;
 
@@ -4178,7 +4188,7 @@ gfc_check_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
   if (!kind_check (kind, 2, BT_INTEGER))
     return false;
   if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
-                              "with KIND argument at %L", 
+                              "with KIND argument at %L",
                               gfc_current_intrinsic, &kind->where))
     return false;
 
@@ -4621,9 +4631,9 @@ gfc_check_c_loc (gfc_expr *x)
                     &x->where);
          return false;
        }
-     
+
       if (x->rank
-         && !gfc_notify_std (GFC_STD_F2008_TS, 
+         && !gfc_notify_std (GFC_STD_F2008_TS,
                              "Noninteroperable array at %L as"
                              " argument to C_LOC: %s", &x->where, msg))
          return false;
@@ -4634,7 +4644,7 @@ gfc_check_c_loc (gfc_expr *x)
 
       if (ar->as->type != AS_EXPLICIT && ar->as->type != AS_ASSUMED_SIZE
          && !attr.allocatable
-         && !gfc_notify_std (GFC_STD_F2008, 
+         && !gfc_notify_std (GFC_STD_F2008,
                              "Array of interoperable type at %L "
                              "to C_LOC which is nonallocatable and neither "
                              "assumed size nor explicit size", &x->where))
@@ -4669,7 +4679,7 @@ gfc_check_sngl (gfc_expr *a)
 
   if ((a->ts.kind != gfc_default_double_kind)
       && !gfc_notify_std (GFC_STD_GNU, "non double precision "
-                         "REAL argument to %s intrinsic at %L", 
+                         "REAL argument to %s intrinsic at %L",
                          gfc_current_intrinsic, &a->where))
     return false;
 
@@ -5182,7 +5192,7 @@ gfc_check_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
   /* If we can't calculate the sizes, we cannot check any more.
      Return true for that case.  */
 
-  if (!gfc_calculate_transfer_sizes (source, mold, size, &source_size, 
+  if (!gfc_calculate_transfer_sizes (source, mold, size, &source_size,
                                     &result_size, NULL))
     return true;
 
@@ -5221,7 +5231,7 @@ gfc_check_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
   if (!kind_check (kind, 2, BT_INTEGER))
     return false;
   if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
-                              "with KIND argument at %L", 
+                              "with KIND argument at %L",
                               gfc_current_intrinsic, &kind->where))
     return false;
 
@@ -5350,7 +5360,7 @@ gfc_check_verify (gfc_expr *x, gfc_expr *y, gfc_expr *z, gfc_expr *kind)
   if (!kind_check (kind, 3, BT_INTEGER))
     return false;
   if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
-                              "with KIND argument at %L", 
+                              "with KIND argument at %L",
                               gfc_current_intrinsic, &kind->where))
     return false;
 

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 2283fd7538e4166294f10f43dc0c9b737069b714..69af2ef70253352ccee33640ff280b4b2d25931b 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,7 @@
+2016-11-05  Paul Thomas  <pault@gcc.gnu.org>
+
+       * gfortran.dg/move_alloc_17.f03: New test.
+
 2016-11-05  Richard Biener  <rguenther@suse.de>
 
        PR bootstrap/78188

diff --git a/gcc/testsuite/gfortran.dg/move_alloc_17.f90 b/gcc/testsuite/gfortran.dg/move_alloc_17.f90
new file mode 100644 (file)
index 0000000..acede0f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/move_alloc_17.f90
@@ -0,0 +1,21 @@
+! { dg-do compile }
+!
+! The call to MOVE_ALLOC below caused a seg fault in runtime.
+! This was discussed in:
+! https://groups.google.com/forum/#!topic/comp.lang.fortran/ZVLqXFYDZ0M
+! Richard Maine proposed that the code violated the restrictions on
+! actual arguments in F2003 12.4.1.7 and so the fix asserts that the
+! TO and FROM arguments cannot be the same object or subobjects thereof.
+!
+!
+program test_move_alloc
+  type :: linked_list
+     type(linked_list), allocatable :: link
+     integer :: value
+  end type linked_list
+  type(linked_list) :: test
+
+  allocate(test % link)
+  allocate(test % link % link)
+  call move_alloc(test % link, test % link % link) ! { dg-error "aliasing restrictions" }
+end program test_move_alloc