[Patch, fortran] PR93794 - [8/9/10/11 Regression] ICE in gfc_conv_component_ref, at fortran/trans-expr.c:2497

[Patch, fortran] PR93794 - [8/9/10/11 Regression] ICE in gfc_conv_component_ref, at fortran/trans-expr.c:2497

[Paul Richard Thomas]

[-- Attachment #1: Type: text/plain, Size: 644 bytes --]

Harald has reminded me about this patch, which emanates from the time when
I had negative competence with git. It is totally trivial but my tree is
blocked with other work today.

Regtested on FC33/x86_64 - OK for master? If desired, I will apply it to 9-
and 10-branches as well.

Paul

Fortran: Allow pointer deferred length associate selectors. [PR93794]

2021-01-05  Paul Thomas  <pault@gcc.gnu.org>

gcc/fortran
PR fortran/93794
* trans-expr.c (gfc_conv_component_ref): Remove the condition
that deferred character length components only be allocatable.

gcc/testsuite/
PR fortran/93794
* gfortran.dg/deferred_character_35.f90 : New test.

[-- Attachment #2: submit.diff --]
[-- Type: text/x-patch, Size: 4203 bytes --]

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 14361a10f68..6efb84232ed 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -2670,7 +2670,7 @@ gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
   /* Allocatable deferred char arrays are to be handled by the gfc_deferred_
      strlen () conditional below.  */
   if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer
-      && !(c->attr.allocatable && c->ts.deferred)
+      && !c->ts.deferred
       && !c->attr.pdt_string)
     {
       tmp = c->ts.u.cl->backend_decl;
diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index bcc13ce79c6..dbe15ff91b1 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -8319,17 +8319,50 @@ gfc_conv_intrinsic_storage_size (gfc_se *se, gfc_expr *expr)
   gfc_init_se (&argse, NULL);
   result_type = gfc_get_int_type (expr->ts.kind);
 
-  if (arg->rank == 0)
+  if (arg->ts.type == BT_CLASS)
     {
-      if (arg->ts.type == BT_CLASS)
+      if (arg->rank == 0)
+	gfc_conv_expr (&argse, arg);
+      else
+	gfc_conv_expr_descriptor (&argse, arg);
+
+      if (!GFC_CLASS_TYPE_P (TREE_TYPE (argse.expr)))
+	argse.expr = gfc_get_class_from_expr (argse.expr);
+
+      /* Dummy argument descriptors are fixed. Use the stored class expr..  */
+      if (argse.expr == NULL_TREE
+	  || !GFC_CLASS_TYPE_P (TREE_TYPE (argse.expr)))
 	{
-	  gfc_add_vptr_component (arg);
-	  gfc_add_size_component (arg);
-	  gfc_conv_expr (&argse, arg);
-	  tmp = fold_convert (result_type, argse.expr);
-	  goto done;
+	  tmp = arg->symtree->n.sym->backend_decl;
+	  argse.expr = GFC_DECL_SAVED_DESCRIPTOR (tmp);
 	}
 
+      /* We now have the class expression.  */
+      tmp = gfc_class_vtab_size_get (argse.expr);
+      tmp = fold_convert (result_type, tmp);
+
+      /* Multiply by the len field if it is non-zero.  */
+      if (UNLIMITED_POLY (arg))
+	{
+	  tree cond;
+	  tree product;
+	  argse.expr = gfc_class_len_get (argse.expr);
+	  argse.expr = fold_convert (result_type, argse.expr);
+	  cond = build_zero_cst (TREE_TYPE (argse.expr));
+	  cond = fold_build2_loc (input_location,
+				  GT_EXPR, logical_type_node,
+				  argse.expr, cond);
+	  product = fold_build2_loc (input_location, MULT_EXPR,
+				     result_type,
+				     tmp, argse.expr);
+	  tmp = fold_build3_loc (input_location, COND_EXPR,
+				 result_type, cond,
+				 product, tmp);
+	}
+      goto done;
+    }
+  else if (arg->rank == 0)
+    {
       gfc_conv_expr_reference (&argse, arg);
       type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
 						     argse.expr));
@@ -8338,16 +8371,6 @@ gfc_conv_intrinsic_storage_size (gfc_se *se, gfc_expr *expr)
     {
       argse.want_pointer = 0;
       gfc_conv_expr_descriptor (&argse, arg);
-      if (arg->ts.type == BT_CLASS)
-	{
-	  if (arg->rank > 0)
-	    tmp = gfc_class_vtab_size_get (
-		 GFC_DECL_SAVED_DESCRIPTOR (arg->symtree->n.sym->backend_decl));
-	  else
-	    tmp = gfc_class_vtab_size_get (TREE_OPERAND (argse.expr, 0));
-	  tmp = fold_convert (result_type, tmp);
-	  goto done;
-	}
       type = gfc_get_element_type (TREE_TYPE (argse.expr));
     }
 
@@ -8511,6 +8534,30 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
 	    tmp = gfc_class_vtab_size_get (class_ref);
 	  else
 	    tmp = gfc_class_vtab_size_get (argse.expr);
+
+	  /* Multiply by the len field if it is non-zero.  */
+	  if (UNLIMITED_POLY (arg->expr))
+	    {
+	      tree cond;
+	      tree product;
+	      tree len;
+	      if (class_ref != NULL_TREE)
+		len = gfc_class_len_get (class_ref);
+	      else
+		len = gfc_class_len_get (argse.expr);
+	      len = fold_convert (TREE_TYPE (tmp), len);
+	      cond = build_zero_cst (TREE_TYPE (len));
+	      cond = fold_build2_loc (input_location,
+				      GT_EXPR, logical_type_node,
+				      len, cond);
+	      product = fold_build2_loc (input_location, MULT_EXPR,
+					 TREE_TYPE (len),
+					 tmp, len);
+	      tmp = fold_build3_loc (input_location, COND_EXPR,
+				     TREE_TYPE (len), cond,
+				     product, tmp);
+	    }
+
 	  break;
 	default:
 	  source_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,

[-- Attachment #3: deferred_character_35.f90 --]
[-- Type: text/x-fortran, Size: 393 bytes --]

! { dg-do compile }
!
! Test the fix for PR93794, where the ASSOCIATE statement ICED on the
! deferred character length, pointer component.
!
! Contributed by Gerhard Steinmetz  <gscfq@t-online.de>
!
program p
   type t
      character(:), pointer :: a
   end type
   type(t) :: z
   character(4), target :: c = 'abcd'
   z%a => c
   associate (y => z%a)
      print *, y
   end associate
end

Re: [Patch, fortran] PR93794 - [8/9/10/11 Regression] ICE in gfc_conv_component_ref, at fortran/trans-expr.c:2497

[Thomas Koenig]

Hello Paul,

as you wrote, it is indeed quite obvious.

> Regtested on FC33/x86_64 - OK for master? If desired, I will apply it to 9-
> and 10-branches as well.

OK for all branches.

Best regards

	Thomas

Re: [Patch, fortran] PR93794 - [8/9/10/11 Regression] ICE in gfc_conv_component_ref, at fortran/trans-expr.c:2497

[Paul Richard Thomas]

Hi Thomas,

The huge chunk in trans-intrinsic.c is a prototype fix for failures of
intrinsic functions with unlimited polymorphic actual arguments. This is
PR98534. I am putting it on one side for the moment so if anybody wants to
take it over, please do. All the failures are due to the _len field of
unlimited polymorphic entities not being used. In addition, there is some
strangeness happening with reallocation on assignment due, I think, to the
_data field being of void type. Also, the _copy functions are unhappy with
this. Codes work as intended but valgrind is most unhappy about them.

Cheers

Paul


On Tue, 5 Jan 2021 at 12:55, Thomas Koenig <tkoenig@netcologne.de> wrote:

> Hello Paul,
>
> as you wrote, it is indeed quite obvious.
>
> > Regtested on FC33/x86_64 - OK for master? If desired, I will apply it to
> 9-
> > and 10-branches as well.
>
> OK for all branches.
>
> Best regards
>
>         Thomas
>


-- 
"If you can't explain it simply, you don't understand it well enough" -
Albert Einstein