From c7f587bd0f7eb3e94e31a8b597abc05492e3d074 Mon Sep 17 00:00:00 2001 From: Paul Thomas Date: Sat, 5 Nov 2016 14:25:25 +0000 Subject: [PATCH] check.c (gfc_check_move_alloc): Introduce error to prevent aliasing between to and from arguments. 2016-11-05 Paul Thomas * check.c (gfc_check_move_alloc): Introduce error to prevent aliasing between to and from arguments. 2016-11-05 Paul Thomas * gfortran.dg/move_alloc_17.f03: New test. From-SVN: r241872 --- gcc/fortran/ChangeLog | 5 ++ gcc/fortran/check.c | 88 ++++++++++++--------- gcc/testsuite/ChangeLog | 4 + gcc/testsuite/gfortran.dg/move_alloc_17.f90 | 21 +++++ 4 files changed, 79 insertions(+), 39 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/move_alloc_17.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 10aaff86c64..41225b55650 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,8 @@ +2016-11-05 Paul Thomas + + * check.c (gfc_check_move_alloc): Introduce error to prevent + aliasing between to and from arguments. + 2016-11-05 Janus Weil Manuel Lopez-Ibanez diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index 5057d4999fd..142cdac2e38 100644 --- 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 % nor % argument at %L", + " neither % nor % 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 2283fd7538e..69af2ef7025 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,7 @@ +2016-11-05 Paul Thomas + + * gfortran.dg/move_alloc_17.f03: New test. + 2016-11-05 Richard Biener 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 index 00000000000..acede0f901b --- /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 -- 2.30.2