[PATCH, Fortran] PR fortran/60289 First try on: Fixing character array allocation for class(*) type variable

[Andre Vehreschild <vehre at gmx dot de>]

Hi,

I am proposing another patch, this time to resolve PR60289. The issue in the bug
reported is, that a code like:

	class(*), pointer :: P
	allocate(character(20)::P)

is rejected by trunk's gfortran compiler. janus@gcc.gnu.org proposed a first
patch in the PR, which my patch extends. 

Motivation: Previously parsing of the type association to the unlimited
polymorphic variable P was not allowed and reported the error "Error:
Allocating p at (1) with type-spec requires the same character-length parameter
as in the declaration", after the errorneous error report was fixed by
janus' patch, an ICE occured in trans-stmt.c's gfc_trans_allocate()-routine.
The ICE reported in PR60289 is something different and does not occur in trunk
anymore. The ICE reported now boils down to line 5056 in trans-stmt.c:

	tmp= al->expr->ts.u.cl->backend_decl;

The dereferencing of ts.u's cl member is valid only, when ts.type is of
BT_CHARACTER. With al->expr being an unlimited polymorphic type, the
backend_decl is not available in cl.

Although there is a backend_decl available in ts.u.derived, I was not able to
get it compatible for the fold_convert in the line following the assignment to
tmp:

	gfc_add_modify (&se.pre, tmp, fold_convert (TREE_TYPE(tmp),
						              se_sz.expr));

My current solution therefore is to execute those two statements only, when
ts.type is of BT_CHARACTER.

Can someone explain what the fold_convert is doing in that specific place? I
assume that it is checking for and ensuring some type compatibility. Is there
some documentation available, explaining this? Is something similar needed for
the unlimited polymorphic variable?

Attached patch bootstraps and regtests ok on x86_64-unknown-linux-gnu. You
may need to have my patch for 60255 incorporated, too, for testing.

Regards,
	Andre
-- 
Andre Vehreschild * Email: vehre ad gmx dot de 

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 15d8dab..15d3613 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -6878,7 +6878,9 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
       goto failure;
     }
 
-  if (code->ext.alloc.ts.type == BT_CHARACTER && !e->ts.deferred)
+  /* Check F08:C632.  */
+  if (code->ext.alloc.ts.type == BT_CHARACTER && !e->ts.deferred
+      && !UNLIMITED_POLY (e))
     {
       int cmp = gfc_dep_compare_expr (e->ts.u.cl->length,
 				      code->ext.alloc.ts.u.cl->length);
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 547e9c1..575342d 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -5046,7 +5046,7 @@ gfc_trans_allocate (gfc_code * code)
 	      if (unlimited_char)
 		tmp = TREE_TYPE (gfc_typenode_for_spec (&code->expr3->ts));
 	      else
-	      tmp = TREE_TYPE (gfc_typenode_for_spec (&al->expr->ts));
+		tmp = TREE_TYPE (gfc_typenode_for_spec (&al->expr->ts));
 	      tmp = TYPE_SIZE_UNIT (tmp);
 	      memsz = fold_build2_loc (input_location, MULT_EXPR,
 				       TREE_TYPE (tmp), tmp,
@@ -5061,10 +5061,14 @@ gfc_trans_allocate (gfc_code * code)
 	      gfc_add_block_to_block (&se.pre, &se_sz.pre);
 	      se_sz.expr = gfc_evaluate_now (se_sz.expr, &se.pre);
 	      gfc_add_block_to_block (&se.pre, &se_sz.post);
-	      /* Store the string length.  */
-	      tmp = al->expr->ts.u.cl->backend_decl;
-	      gfc_add_modify (&se.pre, tmp, fold_convert (TREE_TYPE (tmp),
-			      se_sz.expr));
+	      /* Store the string length only when variable allocated is
+	         a character array.  */
+	      if(al->expr->ts.type== BT_CHARACTER)
+		{
+		  tmp= al->expr->ts.u.cl->backend_decl;
+		  gfc_add_modify (&se.pre, tmp, fold_convert (TREE_TYPE(tmp),
+						              se_sz.expr));
+                }
               tmp = TREE_TYPE (gfc_typenode_for_spec (&code->ext.alloc.ts));
               tmp = TYPE_SIZE_UNIT (tmp);
 	      memsz = fold_build2_loc (input_location, MULT_EXPR,
diff --git a/gcc/testsuite/gfortran.dg/unlimited_polymorphic_20.f90 b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_20.f90
new file mode 100644
index 0000000..070ba89
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_20.f90
@@ -0,0 +1,24 @@
+! { dg-do run }
+! Testing fix for 
+! PR fortran/60289
+!
+program test   
+    implicit none
+  
+    class(*), pointer :: P
+   
+    allocate(character(20)::P)
+
+    select type(P)
+        type is (character(*))
+            P ="some test string"
+            if (P .ne. "some test string") then
+                call abort()
+            end if
+        class default
+            call abort()
+    end select
+
+    deallocate(P)
+end program test 
+