From e3a7c6cf721d52efe1a80b83149edd8c66568841 Mon Sep 17 00:00:00 2001 From: Andre Vehreschild Date: Fri, 6 Feb 2015 12:22:54 +0100 Subject: re PR fortran/60289 (allocating class(*) pointer as character gives type-spec requires the same character-length parameter) 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 --- gcc/fortran/ChangeLog | 14 ++++++ gcc/fortran/resolve.c | 4 +- gcc/fortran/trans-stmt.c | 11 ++++- .../gfortran.dg/unlimited_polymorphic_22.f90 | 56 ++++++++++++++++++++++ 4 files changed, 83 insertions(+), 2 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/unlimited_polymorphic_22.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index ae912cb..63198c8 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,17 @@ + +2015-01-29 Andre Vehreschild , Janus Weil + + 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 + + * gfortran.dg/unlimited_polymorphic_22.f90: New test. + 2015-02-05 Tobias Burnus PR fortran/64943 diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 0b188da..b1111cc 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 96e5abd..7e0e856 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 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 +! +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 -- cgit v1.1