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. ja...@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 +