OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

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

Browse Source 
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
This commit is contained in:
Paul Thomas 2016-11-05 14:25:25 +00:00
parent 92657eb0f6
commit c7f587bd0f
4 changed files with 79 additions and 39 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
gcc/fortran/ChangeLog
View File

@ -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>

88
gcc/fortran/check.c
View File

@ -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;

4
gcc/testsuite/ChangeLog
View File

@ -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

21
gcc/testsuite/gfortran.dg/move_alloc_17.f90 Normal file
View File

@ -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