re PR fortran/60289 (allocating class(*) pointer as character gives type-spec require...

	PR fortran/60289
	Initial patch by Janus Weil
	* resolve.c (resolve_allocate_expr): Add check for comp. only when
	target is not unlimited polymorphic.
	* trans-stmt.c (gfc_trans_allocate): Assign correct value to _len
	component of unlimited polymorphic entities.

	* gfortran.dg/unlimited_polymorphic_22.f90: New test.

From-SVN: r220474

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index ae912cb..63198c8 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,17 @@
+
+2015-01-29  Andre Vehreschild  <vehre@gmx.de>, Janus Weil  <janus@gcc.gnu.org>
+
+       PR fortran/60289
+       Initial patch by Janus Weil
+       * resolve.c (resolve_allocate_expr): Add check for comp. only when 
+       target is not unlimited polymorphic.
+       * trans-stmt.c (gfc_trans_allocate): Assign correct value to _len
+       component of unlimited polymorphic entities.
+
+2015-01-29  Andre Vehreschild  <vehre@gmx.de>
+
+       * gfortran.dg/unlimited_polymorphic_22.f90: New test.
+
 2015-02-05  Tobias Burnus  <burnus@net-b.de>
 
        PR fortran/64943

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 0b188da..b1111cc 100644 (file)
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -6933,7 +6933,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 96e5abd..7e0e856 100644 (file)
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -5167,7 +5167,16 @@ gfc_trans_allocate (gfc_code * code)
              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;
+             if ((expr->symtree->n.sym->ts.type == BT_CLASS
+                 || expr->symtree->n.sym->ts.type == BT_DERIVED)
+                 && expr->ts.u.derived->attr.unlimited_polymorphic)
+               /* For unlimited polymorphic entities get the backend_decl of
+                  the _len component for that.  */
+               tmp = gfc_class_len_get (gfc_get_symbol_decl (
+                                          expr->symtree->n.sym));
+             else
+               /* Else use what is stored in the charlen->backend_decl.  */
+               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_22.f90 b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_22.f90
new file mode 100644 (file)
index 0000000..0753fe0
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_22.f90
@@ -0,0 +1,56 @@
+! { 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