diff options
| -rw-r--r-- | gcc/fortran/ChangeLog | 14 | ||||
| -rw-r--r-- | gcc/fortran/resolve.c | 4 | ||||
| -rw-r--r-- | gcc/fortran/trans-stmt.c | 11 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/unlimited_polymorphic_22.f90 | 56 |
4 files changed, 83 insertions, 2 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index ae912cbe03f..63198c89b7d 100644 --- 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 0b188dad05b..b1111cc4cf5 100644 --- 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 96e5abd6bed..7e0e856b0d0 100644 --- 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 index 00000000000..0753fe048a8 --- /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 |