PR fortran/95544 - Fix ICE in NULL() argument to intrinsics

Fortran 2018: An argument to an intrinsic procedure other than ASSOCIATED,
NULL, or PRESENT shall be a data object.  An EXPR_NULL is not a data
object.  Add checks for intrinsics.

2020-06-11  Steven G. Kargl  <kargl@gcc.gnu.org>
	    Harald Anlauf  <anlauf@gmx.de>

gcc/fortran/
	PR fortran/95544
	* check.c (invalid_null_arg): Rename to gfc_invalid_null_arg.
	(gfc_check_associated, gfc_check_kind, gfc_check_merge)
	(gfc_check_shape, gfc_check_size, gfc_check_spread)
	(gfc_check_transfer): Adjust.
	(gfc_check_len_lentrim, gfc_check_trim): Check for NULL() argument.
	* gfortran.h: Declare gfc_invalid_null_arg ().
	* intrinsic.c (check_arglist): Check for NULL() argument.

diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index 0afb96c..148a326 100644 (file)
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -1431,8 +1431,8 @@ gfc_check_x_yd (gfc_expr *x, gfc_expr *y)
   return true;
 }
 
-static bool
-invalid_null_arg (gfc_expr *x)
+bool
+gfc_invalid_null_arg (gfc_expr *x)
 {
   if (x->expr_type == EXPR_NULL)
     {
@@ -1451,7 +1451,7 @@ gfc_check_associated (gfc_expr *pointer, gfc_expr *target)
   int i;
   bool t;
 
-  if (invalid_null_arg (pointer))
+  if (gfc_invalid_null_arg (pointer))
     return false;
 
   attr1 = gfc_expr_attr (pointer);
@@ -1477,7 +1477,7 @@ gfc_check_associated (gfc_expr *pointer, gfc_expr *target)
   if (target == NULL)
     return true;
 
-  if (invalid_null_arg (target))
+  if (gfc_invalid_null_arg (target))
     return false;
 
   if (target->expr_type == EXPR_VARIABLE || target->expr_type == EXPR_FUNCTION)
@@ -3374,7 +3374,7 @@ 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))
+  if (gfc_invalid_null_arg (x))
     return false;
 
   if (gfc_bt_struct (x->ts.type) || x->ts.type == BT_CLASS)
@@ -3453,6 +3453,9 @@ gfc_check_len_lentrim (gfc_expr *s, gfc_expr *kind)
   if (!type_check (s, 0, BT_CHARACTER))
     return false;
 
+  if (gfc_invalid_null_arg (s))
+    return false;
+
   if (!kind_check (kind, 1, BT_INTEGER))
     return false;
   if (kind && !gfc_notify_std (GFC_STD_F2003, "%qs intrinsic "
@@ -4138,10 +4141,10 @@ 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))
+  if (gfc_invalid_null_arg (tsource))
     return false;
 
-  if (invalid_null_arg (fsource))
+  if (gfc_invalid_null_arg (fsource))
     return false;
 
   if (!same_type_check (tsource, 0, fsource, 1))
@@ -5061,7 +5064,7 @@ gfc_check_shape (gfc_expr *source, gfc_expr *kind)
 {
   gfc_array_ref *ar;
 
-  if (invalid_null_arg (source))
+  if (gfc_invalid_null_arg (source))
     return false;
 
   if (source->rank == 0 || source->expr_type != EXPR_VARIABLE)
@@ -5146,7 +5149,7 @@ gfc_check_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
 bool
 gfc_check_sizeof (gfc_expr *arg)
 {
-  if (invalid_null_arg (arg))
+  if (gfc_invalid_null_arg (arg))
     return false;
 
   if (arg->ts.type == BT_PROCEDURE)
@@ -5634,7 +5637,7 @@ gfc_check_sngl (gfc_expr *a)
 bool
 gfc_check_spread (gfc_expr *source, gfc_expr *dim, gfc_expr *ncopies)
 {
-  if (invalid_null_arg (source))
+  if (gfc_invalid_null_arg (source))
     return false;
 
   if (source->rank >= GFC_MAX_DIMENSIONS)
@@ -6167,7 +6170,7 @@ 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))
+  if (gfc_invalid_null_arg (source))
     return false;
 
   /* SOURCE shall be a scalar or array of any type.  */
@@ -6186,7 +6189,7 @@ 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))
+  if (gfc_invalid_null_arg (mold))
     return false;
 
   /* MOLD shall be a scalar or array of any type.  */
@@ -6412,6 +6415,9 @@ gfc_check_trim (gfc_expr *x)
   if (!type_check (x, 0, BT_CHARACTER))
     return false;
 
+  if (gfc_invalid_null_arg (x))
+    return false;
+
   if (!scalar_check (x, 0))
     return false;
 

diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 0ef7b1b..6d76efb 100644 (file)
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -3553,6 +3553,7 @@ bool gfc_calculate_transfer_sizes (gfc_expr*, gfc_expr*, gfc_expr*,
 bool gfc_boz2int (gfc_expr *, int);
 bool gfc_boz2real (gfc_expr *, int);
 bool gfc_invalid_boz (const char *, locus *);
+bool gfc_invalid_null_arg (gfc_expr *);
 
 
 /* class.c */

diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c
index 17f5efc..60d91f6 100644 (file)
--- a/gcc/fortran/intrinsic.c
+++ b/gcc/fortran/intrinsic.c
@@ -4442,6 +4442,18 @@ check_arglist (gfc_actual_arglist **ap, gfc_intrinsic_sym *sym,
          return false;
        }
 
+      /* F2018, p. 328: An argument to an intrinsic procedure other than
+        ASSOCIATED, NULL, or PRESENT shall be a data object.  An EXPR_NULL
+        is not a data object.  */
+      if (actual->expr->expr_type == EXPR_NULL
+         && (!(sym->id == GFC_ISYM_ASSOCIATED
+               || sym->id == GFC_ISYM_NULL
+               || sym->id == GFC_ISYM_PRESENT)))
+       {
+         gfc_invalid_null_arg (actual->expr);
+         return false;
+       }
+
       /* If the formal argument is INTENT([IN]OUT), check for definability.  */
       if (formal->intent == INTENT_INOUT || formal->intent == INTENT_OUT)
        {

diff --git a/gcc/testsuite/gfortran.dg/pr95544.f90 b/gcc/testsuite/gfortran.dg/pr95544.f90
new file mode 100644 (file)
index 0000000..01b9fc5
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr95544.f90
@@ -0,0 +1,15 @@
+! { dg-do compile }
+! PR fortran/95544 - ICE in gfc_can_put_var_on_stack, at fortran/trans-decl.c:494
+
+program test
+   character(:), allocatable :: z
+   character(:), pointer     :: p
+   character(1), pointer     :: c
+   print *, adjustl (null(z)) ! { dg-error "is not permitted as actual argument" }
+   print *, adjustr (null(z)) ! { dg-error "is not permitted as actual argument" }
+   print *, len     (null(p)) ! { dg-error "is not permitted as actual argument" }
+   print *, len     (null(z)) ! { dg-error "is not permitted as actual argument" }
+   print *, len_trim(null(c)) ! { dg-error "is not permitted as actual argument" }
+   print *, len_trim(null(z)) ! { dg-error "is not permitted as actual argument" }
+   print *, trim    (null(z)) ! { dg-error "is not permitted as actual argument" }
+end