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

[Andre Vehreschild <vehre at gmx dot de>]

Dear all,

sorry for the bad patch yesterday. Here is an update to that one. It fixes the
pr60289 is GNU-style checked, bootstraps and regtests ok on x86_64-linux-gnu.

Comments welcome.

Regards,
	Andre

On Sat, 20 Dec 2014 16:38:23 +0100
Andre Vehreschild <vehre@gmx.de> wrote:

> Dear all,
> 
> please find attached a patch fixing the PR60289 with my recent patch on
> PR60255. Please understand, that for this patch to work correctly you need to
> have my previous patch from
> 
> https://gcc.gnu.org/ml/fortran/2014-12/msg00092.html
> 
> applied already to your gfortran sources.
> 
> I am still collecting comments on the 60255 patch and applying them. Therefore
> both patches are on "request for comment" now. So feel free to comment.
> 
> Bootstrapping and regtesting is running currently.
> 
> - Andre
> 
> On Mon, 18 Aug 2014 10:36:44 +0200
> Paul Richard Thomas <paul.richard.thomas@gmail.com> wrote:
> 
> > Dear All,
> > 
> > There are known issues with unlimited polymorphic variables
> > representing characters : see
> > https://groups.google.com/forum/#!topic/comp.lang.fortran/aRz3HMpblTs
> > and https://gcc.gnu.org/bugzilla/show_bug.cgi?id=55901
> > 
> > One way or another, the variable itself needs to carry the string
> > length and the kind.  With fixed length and kind=1, the vtable 'size'
> > does the job.
> > 
> > Tobias has suggested more than once that we use the new array
> > descriptor as the class container as well. We either do this or add
> > fields to the class container.
> > 
> > Cheers
> > 
> > Paul
> > 
> > On 17 August 2014 18:39, Dominique Dhumieres <dominiq@lps.ens.fr> wrote:
> > >> Here is a failing testcase.
> > >
> > > I was about to post the same test. The test fails with two counts:
> > > (1) len(P) == 80,
> > > (2) deallocate(P) fails with
> > >
> > > a.out(882,0x7fff75e1d310) malloc: *** error for object 0x7fc801c04978:
> > > incorrect checksum for freed object - object was probably modified after
> > > being freed. ...
> > >
> > > Dominique
> > 
> > 
> > 
> 
> 


-- 
Andre Vehreschild * Kreuzherrenstr. 8 * 52062 Aachen
Tel.: +49 241 9291018 * Email: vehre@gmx.de 

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 9d7d3c2..214b64d 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -6877,7 +6877,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 0db668d..7c5ebe0 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -5126,8 +5126,15 @@ 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;
+	      /* Store the string length.  Get the backend_decl of the _len
+		 component for that.  */
+	      if ((expr->symtree->n.sym->ts.type == BT_CLASS
+		  || expr->symtree->n.sym->ts.type == BT_DERIVED)
+		  && expr->symtree->n.sym->ts.u.derived->attr.unlimited_polymorphic)
+		tmp = gfc_class_len_get (gfc_get_symbol_decl (
+					   expr->symtree->n.sym));
+	      else
+		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));
diff --git a/gcc/testsuite/gfortran.dg/unlimited_polymorphic_21.f90 b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_21.f90
new file mode 100644
index 0000000..18a66b0
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_21.f90
@@ -0,0 +1,57 @@
+! { dg-do run }
+! Testing fix for PR fortran/60289
+! Contributed by: Andre Vehreschild <vehre@gmx.de>
+!
+program test
+    implicit none
+
+    class(*), pointer :: P
+    integer :: string_len = 10 *2
+
+    allocate(character(string_len)::P)
+
+    select type(P)
+        type is (character(*))
+            P ="some test string"
+            if (P .ne. "some test string") then
+                call abort ()
+            end if
+            if (len(P) .ne. 20) then
+                call abort ()
+            end if
+            if (len(P) .eq. len("some test string")) then
+                call abort ()
+            end if
+        class default
+            call abort ()
+    end select
+
+    deallocate(P)
+
+    ! Now for kind=4 chars.
+
+    allocate(character(len=20,kind=4)::P)
+
+    select type(P)
+        type is (character(len=*,kind=4))
+            P ="some test string"
+            if (P .ne. 4_"some test string") then
+                call abort ()
+            end if
+            if (len(P) .ne. 20) then
+                call abort ()
+            end if
+            if (len(P) .eq. len("some test string")) then
+                call abort ()
+            end if
+        type is (character(len=*,kind=1))
+            call abort ()
+        class default
+            call abort ()
+    end select
+
+    deallocate(P)
+
+
+end program test
+