yggdrasil/gcc
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

PR fortran/93366 - ICE on invalid, reject invalid use of NULL() as argument

Browse Source 
gcc/fortran/ChangeLog:

2020-05-05  Steve Kargl  <kargl@gcc.gnu.org>
	Harald Anlauf  <anlauf@gmx.de>

	PR fortran/93366
	* check.c (gfc_check_associated, invalid_null_arg): Factorize
	check for presence of invalid NULL() argument.
	(gfc_check_kind, gfc_check_merge, gfc_check_shape)
	(gfc_check_sizeof, gfc_check_spread, gfc_check_transfer): Use this
	check for presence of invalid NULL() arguments.

gcc/testsuite/ChangeLog:

2020-05-05  Harald Anlauf  <anlauf@gmx.de>

	PR fortran/93366
	* gfortran.dg/pr93366.f90: New test.
This commit is contained in:
Harald Anlauf
2020-05-05 22:16:50 +02:00
parent 1136ba01e1
commit 5a26ea7e0f
4 changed files with 73 additions and 15 deletions
Download Patch File Download Diff File Expand all files Collapse all files
gcc/fortran/ChangeLog
+10
View File
@@ -1,3 +1,13 @@
2020-05-05 Steve Kargl <kargl@gcc.gnu.org>
Harald Anlauf <anlauf@gmx.de>
PR fortran/93366
* check.c (gfc_check_associated, invalid_null_arg): Factorize
check for presence of invalid NULL() argument.
(gfc_check_kind, gfc_check_merge, gfc_check_shape)
(gfc_check_sizeof, gfc_check_spread, gfc_check_transfer): Use this
check for presence of invalid NULL() arguments.
2020-04-29 Stefan Schulze Frielinghaus <stefansf@linux.ibm.com>
PR fortran/94769
gcc/fortran/check.c
+40 -15
View File
@@ -1431,6 +1431,18 @@ gfc_check_x_yd (gfc_expr *x, gfc_expr *y)
return true;
}
static bool
invalid_null_arg (gfc_expr *x)
{
if (x->expr_type == EXPR_NULL)
{
gfc_error ("NULL at %L is not permitted as actual argument "
"to %qs intrinsic function", &x->where,
gfc_current_intrinsic);
return true;
}
return false;
}
bool
gfc_check_associated (gfc_expr *pointer, gfc_expr *target)
@@ -1438,12 +1450,9 @@ gfc_check_associated (gfc_expr *pointer, gfc_expr *target)
symbol_attribute attr1, attr2;
int i;
bool t;
locus *where;
where = &pointer->where;
if (pointer->expr_type == EXPR_NULL)
goto null_arg;
if (invalid_null_arg (pointer))
return false;
attr1 = gfc_expr_attr (pointer);
@@ -1468,9 +1477,8 @@ gfc_check_associated (gfc_expr *pointer, gfc_expr *target)
if (target == NULL)
return true;
where = &target->where;
if (target->expr_type == EXPR_NULL)
goto null_arg;
if (invalid_null_arg (target))
return false;
if (target->expr_type == EXPR_VARIABLE || target->expr_type == EXPR_FUNCTION)
attr2 = gfc_expr_attr (target);
@@ -1518,13 +1526,6 @@ gfc_check_associated (gfc_expr *pointer, gfc_expr *target)
}
}
return t;
null_arg:
gfc_error ("NULL pointer at %L is not permitted as actual argument "
"of %qs intrinsic function", where, gfc_current_intrinsic);
return false;
}
@@ -3373,6 +3374,9 @@ gfc_check_kill_sub (gfc_expr *pid, gfc_expr *sig, gfc_expr *status)
bool
gfc_check_kind (gfc_expr *x)
{
if (invalid_null_arg (x))
return false;
if (gfc_bt_struct (x->ts.type) || x->ts.type == BT_CLASS)
{
gfc_error ("%qs argument of %qs intrinsic at %L must be of "
@@ -4134,6 +4138,12 @@ gfc_check_transf_bit_intrins (gfc_actual_arglist *ap)
bool
gfc_check_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask)
{
if (invalid_null_arg (tsource))
return false;
if (invalid_null_arg (fsource))
return false;
if (!same_type_check (tsource, 0, fsource, 1))
return false;
@@ -5051,6 +5061,9 @@ gfc_check_shape (gfc_expr *source, gfc_expr *kind)
{
gfc_array_ref *ar;
if (invalid_null_arg (source))
return false;
if (source->rank == 0 || source->expr_type != EXPR_VARIABLE)
return true;
@@ -5133,6 +5146,9 @@ gfc_check_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
bool
gfc_check_sizeof (gfc_expr *arg)
{
if (invalid_null_arg (arg))
return false;
if (arg->ts.type == BT_PROCEDURE)
{
gfc_error ("%qs argument of %qs intrinsic at %L shall not be a procedure",
@@ -5618,6 +5634,9 @@ gfc_check_sngl (gfc_expr *a)
bool
gfc_check_spread (gfc_expr *source, gfc_expr *dim, gfc_expr *ncopies)
{
if (invalid_null_arg (source))
return false;
if (source->rank >= GFC_MAX_DIMENSIONS)
{
gfc_error ("%qs argument of %qs intrinsic at %L must be less "
@@ -6148,6 +6167,9 @@ gfc_check_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
size_t source_size;
size_t result_size;
if (invalid_null_arg (source))
return false;
/* SOURCE shall be a scalar or array of any type. */
if (source->ts.type == BT_PROCEDURE
&& source->symtree->n.sym->attr.subroutine == 1)
@@ -6164,6 +6186,9 @@ gfc_check_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
if (mold->ts.type == BT_BOZ && illegal_boz_arg (mold))
return false;
if (invalid_null_arg (mold))
return false;
/* MOLD shall be a scalar or array of any type. */
if (mold->ts.type == BT_PROCEDURE
&& mold->symtree->n.sym->attr.subroutine == 1)
gcc/testsuite/ChangeLog
+5
View File
@@ -1,3 +1,8 @@
2020-05-05 Harald Anlauf <anlauf@gmx.de>
PR fortran/93366
* gfortran.dg/pr93366.f90: New test.
2020-05-05 Michael Meissner <meissner@linux.ibm.com>
* gcc.dg/nextafter-2.c: Delete changes meant for a private branch.
gcc/testsuite/gfortran.dg/pr93366.f90
+18
View File
@@ -0,0 +1,18 @@
! { dg-do compile }
!
! PR fortran/93366 - ICE on invalid, reject invalid use of NULL() as argument
program p
print *, kind (null()) ! { dg-error "NULL at" }
print *, [ merge(null(), [1] ,.true.) ] ! { dg-error "NULL at" }
print *, [ merge([1] , null(),.true.) ] ! { dg-error "NULL at" }
print *, [ merge(null(), null(),.true.) ] ! { dg-error "NULL at" }
print *, shape (null()) ! { dg-error "NULL at" }
print *, sizeof (null()) ! { dg-error "NULL at" }
print *, spread (null(),1,1) ! { dg-error "NULL at" }
print *, transfer ( 1 , null()) ! { dg-error "NULL at" }
print *, transfer ([1], null()) ! { dg-error "NULL at" }
print *, transfer (null(), 1) ! { dg-error "NULL at" }
print *, transfer (null(), [1]) ! { dg-error "NULL at" }
print *, transfer (null(), null()) ! { dg-error "NULL at" }
end