diff mbox series

PR fortran/95544 - ICE in gfc_can_put_var_on_stack, at fortran/trans-decl.c:494

Message ID trinity-2ac4c8b7-4c7f-46c6-8959-439b6009573c-1591886342706@3c-app-gmx-bap74
State New
Headers show
Series PR fortran/95544 - ICE in gfc_can_put_var_on_stack, at fortran/trans-decl.c:494 | expand

Commit Message

Harald Anlauf June 11, 2020, 2:39 p.m. UTC 
> Gesendet: Montag, 08. Juni 2020 um 22:25 Uhr
> Von: "Harald Anlauf" <anlauf@gmx.de>
> An: "fortran" <fortran@gcc.gnu.org>, "gcc-patches" <gcc-patches@gcc.gnu.org>
> Betreff: [PATCH] PR fortran/95544 - ICE in gfc_can_put_var_on_stack, at fortran/trans-decl.c:494

OK, now with a brown bag over my head, here comes the patch instead of
just the testcase.

Thanks to Thomas for pointing that out in private.

Harald

Comments

Thomas Koenig June 11, 2020, 4:26 p.m. UTC | #1 
Hi Harald,

one remark: Instead of

+	  && !(strcmp(gfc_current_intrinsic, "associated") == 0
+		|| strcmp(gfc_current_intrinsic, "null") == 0
+		|| strcmp(gfc_current_intrinsic, "present") == 0))

could you maybe test sym->id ?

OK with that change.

Best regards, and thanks for the patch

	Thomas
Harald Anlauf June 11, 2020, 6:36 p.m. UTC | #2 
Hi Thomas,

> one remark: Instead of
>
> +	  && !(strcmp(gfc_current_intrinsic, "associated") == 0
> +		|| strcmp(gfc_current_intrinsic, "null") == 0
> +		|| strcmp(gfc_current_intrinsic, "present") == 0))
>
> could you maybe test sym->id ?
>
> OK with that change.

done.  See attached for the actual commit.

Thanks for the hint and the swift review!

Harald
diff mbox series

Patch

diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index 0afb96c0414..148a3269815 100644
--- 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 0ef7b1b0eff..6d76efb5298 100644
--- 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 17f5efc6566..95150c8b6ce 100644
--- 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
+	  && !(strcmp(gfc_current_intrinsic, "associated") == 0
+		|| strcmp(gfc_current_intrinsic, "null") == 0
+		|| strcmp(gfc_current_intrinsic, "present") == 0))
+	{
+	  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
index 00000000000..01b9fc5cc9f
--- /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