@@ -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);
@@ -5126,8 +5126,10 @@ 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. */
+ tmp = gfc_class_len_get (gfc_get_symbol_decl (
+ expr->symtree->n.sym));
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));
new file mode 100644
@@ -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
+