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.

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index f245cb4d7c05c9576b957809aa538626080015b2..beeabfa28398eadd41641ff17afe954f11d54102 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -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

diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index cdabbf5e12a7462998f1e9e6b15978a7b22fbd00..0afb96c041482a9f80daf6fd2160d67b96bb1b46 100644 (file)
--- 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/ChangeLog b/gcc/testsuite/ChangeLog
index eeb502b3c2db58e25728d7548161929a90969508..b36f8748689a710299576880533291e215aaa4a6 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -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.

diff --git a/gcc/testsuite/gfortran.dg/pr93366.f90 b/gcc/testsuite/gfortran.dg/pr93366.f90
new file mode 100644 (file)
index 0000000..3cb6d1d
--- /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