[gcc r10-8301] PR fortran/93366 - ICE on invalid, reject invalid use of NULL() as argument
Harald Anlauf
anlauf@gcc.gnu.org
Sun Jun 14 12:58:31 GMT 2020
https://gcc.gnu.org/g:294105192c9f6bdcebce81752fc1e64e2b7adebb
commit r10-8301-g294105192c9f6bdcebce81752fc1e64e2b7adebb
Author: Harald Anlauf <anlauf@gmx.de>
Date: Tue May 5 22:16:50 2020 +0200
PR fortran/93366 - ICE on invalid, reject invalid use of NULL() as argument
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.
(cherry picked from commit 5a26ea7e0f8b9a00a2eb0a5e8f70efa04056f167)
Diff:
---
gcc/fortran/check.c | 55 +++++++++++++++++++++++++----------
gcc/testsuite/gfortran.dg/pr93366.f90 | 18 ++++++++++++
2 files changed, 58 insertions(+), 15 deletions(-)
diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index cdabbf5e12a..0afb96c0414 100644
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -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)
diff --git a/gcc/testsuite/gfortran.dg/pr93366.f90 b/gcc/testsuite/gfortran.dg/pr93366.f90
new file mode 100644
index 00000000000..3cb6d1d16da
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr93366.f90
@@ -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
More information about the Gcc-cvs
mailing list