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)

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)

gcc/testsuite/gfortran.dg/pr93366.f90

+! { 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