diff options
author | pault <pault@138bc75d-0d04-0410-961f-82ee72b054a4> | 2017-10-04 10:43:45 +0000 |
---|---|---|
committer | pault <pault@138bc75d-0d04-0410-961f-82ee72b054a4> | 2017-10-04 10:43:45 +0000 |
commit | bb2fe503bb136db039c159c2f2af46f0ace64298 (patch) | |
tree | 766b6c1e28ec2bb871c6783225573d614c75b16a /gcc/fortran | |
parent | f94f4183640e5292c3a91df8e0b03cc6bb4d4675 (diff) | |
download | gcc-bb2fe503bb136db039c159c2f2af46f0ace64298.tar.gz |
2017-10-04 Paul Thomas <pault@gcc.gnu.org>
PR fortran/60458
PR fortran/77296
* resolve.c (resolve_assoc_var): Deferred character type
associate names must not receive an integer conatant length.
* symbol.c (gfc_is_associate_pointer): Deferred character
length functions also require an associate pointer.
* trans-decl.c (gfc_get_symbol_decl): Deferred character
length functions or derived type components require the assoc
name to have variable string length.
* trans-stmt.c (trans_associate_var): Set the string length of
deferred string length associate names. The address expression
is not needed for allocatable, pointer or dummy targets. Change
the comment about defered string length targets.
2017-10-04 Paul Thomas <pault@gcc.gnu.org>
PR fortran/77296
* gfortran.dg/associate_32.f03 : New test.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@253400 138bc75d-0d04-0410-961f-82ee72b054a4
Diffstat (limited to 'gcc/fortran')
-rw-r--r-- | gcc/fortran/ChangeLog | 16 | ||||
-rw-r--r-- | gcc/fortran/resolve.c | 2 | ||||
-rw-r--r-- | gcc/fortran/symbol.c | 6 | ||||
-rw-r--r-- | gcc/fortran/trans-decl.c | 8 | ||||
-rw-r--r-- | gcc/fortran/trans-stmt.c | 45 |
5 files changed, 73 insertions, 4 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 6f904b1e735..c38b34b944e 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,19 @@ +2017-10-04 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/60458 + PR fortran/77296 + * resolve.c (resolve_assoc_var): Deferred character type + associate names must not receive an integer conatant length. + * symbol.c (gfc_is_associate_pointer): Deferred character + length functions also require an associate pointer. + * trans-decl.c (gfc_get_symbol_decl): Deferred character + length functions or derived type components require the assoc + name to have variable string length. + * trans-stmt.c (trans_associate_var): Set the string length of + deferred string length associate names. The address expression + is not needed for allocatable, pointer or dummy targets. Change + the comment about defered string length targets. + 2017-10-03 Thomas Koenig <tkoenig@gcc.gnu.org> * io.c (match_wait_element): Correctly match END and EOR tags. diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 698cf6de2fd..e6f95d513d3 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -8530,7 +8530,7 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target) if (!sym->ts.u.cl) sym->ts.u.cl = target->ts.u.cl; - if (!sym->ts.u.cl->length) + if (!sym->ts.u.cl->length && !sym->ts.deferred) sym->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind, NULL, target->value.character.length); diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index 68a76c4e4cf..4c109fdfbad 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -5054,6 +5054,12 @@ gfc_is_associate_pointer (gfc_symbol* sym) if (sym->ts.type == BT_CLASS) return true; + if (sym->ts.type == BT_CHARACTER + && sym->ts.deferred + && sym->assoc->target + && sym->assoc->target->expr_type == EXPR_FUNCTION) + return true; + if (!sym->assoc->variable) return false; diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index d227d519c63..b4f515f21d9 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -1695,6 +1695,14 @@ gfc_get_symbol_decl (gfc_symbol * sym) if (sym->ts.type == BT_CHARACTER) { if (sym->attr.associate_var + && sym->ts.deferred + && sym->assoc && sym->assoc->target + && ((sym->assoc->target->expr_type == EXPR_VARIABLE + && sym->assoc->target->symtree->n.sym->ts.type != BT_CHARACTER) + || sym->assoc->target->expr_type == EXPR_FUNCTION)) + sym->ts.u.cl->backend_decl = NULL_TREE; + + if (sym->attr.associate_var && sym->ts.u.cl->backend_decl && VAR_P (sym->ts.u.cl->backend_decl)) length = gfc_index_zero_node; diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 925ea636258..7a76b8ead31 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -1533,6 +1533,7 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block) bool need_len_assign; bool whole_array = true; gfc_ref *ref; + symbol_attribute attr; gcc_assert (sym->assoc); e = sym->assoc->target; @@ -1592,6 +1593,17 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block) gfc_conv_expr_descriptor (&se, e); + if (sym->ts.type == BT_CHARACTER + && sym->ts.deferred + && !sym->attr.select_type_temporary + && VAR_P (sym->ts.u.cl->backend_decl) + && se.string_length != sym->ts.u.cl->backend_decl) + { + gfc_add_modify (&se.pre, sym->ts.u.cl->backend_decl, + fold_convert (gfc_charlen_type_node, + se.string_length)); + } + /* If we didn't already do the pointer assignment, set associate-name descriptor to the one generated for the temporary. */ if ((!sym->assoc->variable && !cst_array_ctor) @@ -1758,8 +1770,35 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block) need_len_assign = need_len_assign && sym->ts.type == BT_CHARACTER; } - tmp = TREE_TYPE (sym->backend_decl); - tmp = gfc_build_addr_expr (tmp, se.expr); + if (sym->ts.type == BT_CHARACTER + && sym->ts.deferred + && !sym->attr.select_type_temporary + && VAR_P (sym->ts.u.cl->backend_decl) + && se.string_length != sym->ts.u.cl->backend_decl) + { + gfc_add_modify (&se.pre, sym->ts.u.cl->backend_decl, + fold_convert (gfc_charlen_type_node, + se.string_length)); + if (e->expr_type == EXPR_FUNCTION) + { + tmp = gfc_call_free (sym->backend_decl); + gfc_add_expr_to_block (&se.post, tmp); + } + } + + attr = gfc_expr_attr (e); + if (sym->ts.type == BT_CHARACTER && e->ts.type == BT_CHARACTER + && (attr.allocatable || attr.pointer || attr.dummy)) + { + /* These are pointer types already. */ + tmp = fold_convert (TREE_TYPE (sym->backend_decl), se.expr); + } + else + { + tmp = TREE_TYPE (sym->backend_decl); + tmp = gfc_build_addr_expr (tmp, se.expr); + } + gfc_add_modify (&se.pre, sym->backend_decl, tmp); gfc_add_init_cleanup (block, gfc_finish_block( &se.pre), @@ -1784,7 +1823,7 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block) gfc_init_se (&se, NULL); if (e->symtree->n.sym->ts.type == BT_CHARACTER) { - /* What about deferred strings? */ + /* Deferred strings are dealt with in the preceeding. */ gcc_assert (!e->symtree->n.sym->ts.deferred); tmp = e->symtree->n.sym->ts.u.cl->backend_decl; } |