From 345bd7ebbb38f0e1d5acf33ab3f680111cfa7871 Mon Sep 17 00:00:00 2001 From: Paul Thomas Date: Fri, 9 Dec 2016 11:55:27 +0000 Subject: [PATCH] re PR fortran/44265 (Link error with reference to parameter array in specification expression) 2016-12-09 Paul Thomas PR fortran/44265 * gfortran.h : Add fn_result_spec bitfield to gfc_symbol. * resolve.c (flag_fn_result_spec): New function. (resolve_fntype): Call it for character result lengths. * symbol.c (gfc_new_symbol): Set fn_result_spec to zero. * trans-decl.c (gfc_sym_mangled_identifier): Include the procedure name in the mangled name for symbols with the fn_result_spec bit set. (gfc_finish_var_decl): Mark the decls of these symbols appropriately for the case where the function is external. (gfc_get_symbol_decl): Mangle the name of these symbols. (gfc_create_module_variable): Allow them through the assert. (gfc_generate_function_code): Remove the assert before the initialization of sym->tlink because the frontend no longer uses this field. * trans-expr.c (gfc_map_intrinsic_function): Add a case to treat the LEN_TRIM intrinsic. (gfc_trans_string_copy): Deal with Wstringop-overflow warning that can occur with constant source lengths at -O3. 2016-12-09 Paul Thomas PR fortran/44265 * gfortran.dg/char_result_14.f90: New test. * gfortran.dg/char_result_15.f90: New test. From-SVN: r243478 --- gcc/fortran/ChangeLog | 22 ++++ gcc/fortran/gfortran.h | 2 + gcc/fortran/resolve.c | 59 +++++++++++ gcc/fortran/symbol.c | 1 + gcc/fortran/trans-decl.c | 54 ++++++++-- gcc/fortran/trans-expr.c | 24 ++++- gcc/testsuite/ChangeLog | 6 ++ gcc/testsuite/gfortran.dg/char_result_14.f90 | 103 +++++++++++++++++++ gcc/testsuite/gfortran.dg/char_result_15.f90 | 44 ++++++++ 9 files changed, 303 insertions(+), 12 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/char_result_14.f90 create mode 100644 gcc/testsuite/gfortran.dg/char_result_15.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index eb5e987128c..b27c1e36787 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,25 @@ +2016-12-09 Paul Thomas + + PR fortran/44265 + * gfortran.h : Add fn_result_spec bitfield to gfc_symbol. + * resolve.c (flag_fn_result_spec): New function. + (resolve_fntype): Call it for character result lengths. + * symbol.c (gfc_new_symbol): Set fn_result_spec to zero. + * trans-decl.c (gfc_sym_mangled_identifier): Include the + procedure name in the mangled name for symbols with the + fn_result_spec bit set. + (gfc_finish_var_decl): Mark the decls of these symbols + appropriately for the case where the function is external. + (gfc_get_symbol_decl): Mangle the name of these symbols. + (gfc_create_module_variable): Allow them through the assert. + (gfc_generate_function_code): Remove the assert before the + initialization of sym->tlink because the frontend no longer + uses this field. + * trans-expr.c (gfc_map_intrinsic_function): Add a case to + treat the LEN_TRIM intrinsic. + (gfc_trans_string_copy): Deal with Wstringop-overflow warning + that can occur with constant source lengths at -O3. + 2016-12-08 Steven G. Kargl PR fortran/65173 diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index fcd3a3fabc3..670c13afa64 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -1545,6 +1545,8 @@ typedef struct gfc_symbol unsigned equiv_built:1; /* Set if this variable is used as an index name in a FORALL. */ unsigned forall_index:1; + /* Set if the symbol is used in a function result specification . */ + unsigned fn_result_spec:1; /* Used to avoid multiple resolutions of a single symbol. */ unsigned resolved:1; /* Set if this is a module function or subroutine with the diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index e4ea10f27bc..2093de91c20 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -566,6 +566,14 @@ resolve_contained_fntype (gfc_symbol *sym, gfc_namespace *ns) { bool t; + if (sym && sym->attr.flavor == FL_PROCEDURE + && sym->ns->parent + && sym->ns->parent->proc_name + && sym->ns->parent->proc_name->attr.flavor == FL_PROCEDURE + && !strcmp (sym->name, sym->ns->parent->proc_name->name)) + gfc_error ("Contained procedure %qs at %L has the same name as its " + "encompassing procedure", sym->name, &sym->declared_at); + /* If this namespace is not a function or an entry master function, ignore it. */ if (! sym || !(sym->attr.function || sym->attr.flavor == FL_VARIABLE) @@ -15747,6 +15755,54 @@ resolve_equivalence (gfc_equiv *eq) } +/* Function called by resolve_fntype to flag other symbol used in the + length type parameter specification of function resuls. */ + +static bool +flag_fn_result_spec (gfc_expr *expr, + gfc_symbol *sym ATTRIBUTE_UNUSED, + int *f ATTRIBUTE_UNUSED) +{ + gfc_namespace *ns; + gfc_symbol *s; + + if (expr->expr_type == EXPR_VARIABLE) + { + s = expr->symtree->n.sym; + for (ns = s->ns; ns; ns = ns->parent) + if (!ns->parent) + break; + + if (!s->fn_result_spec + && s->attr.flavor == FL_PARAMETER) + { + /* Function contained in a module.... */ + if (ns->proc_name && ns->proc_name->attr.flavor == FL_MODULE) + { + gfc_symtree *st; + s->fn_result_spec = 1; + /* Make sure that this symbol is translated as a module + variable. */ + st = gfc_get_unique_symtree (ns); + st->n.sym = s; + s->refs++; + } + /* ... which is use associated and called. */ + else if (s->attr.use_assoc || s->attr.used_in_submodule + || + /* External function matched with an interface. */ + (s->ns->proc_name + && ((s->ns == ns + && s->ns->proc_name->attr.if_source == IFSRC_DECL) + || s->ns->proc_name->attr.if_source == IFSRC_IFBODY) + && s->ns->proc_name->attr.function)) + s->fn_result_spec = 1; + } + } + return false; +} + + /* Resolve function and ENTRY types, issue diagnostics if needed. */ static void @@ -15797,6 +15853,9 @@ resolve_fntype (gfc_namespace *ns) el->sym->attr.untyped = 1; } } + + if (sym->ts.type == BT_CHARACTER) + gfc_traverse_expr (sym->ts.u.cl->length, NULL, flag_fn_result_spec, 0); } diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index 882be92efaf..f16e6262b2e 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -2965,6 +2965,7 @@ gfc_new_symbol (const char *name, gfc_namespace *ns) p->common_block = NULL; p->f2k_derived = NULL; p->assoc = NULL; + p->fn_result_spec = 0; return p; } diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 2e6ef2a2bfc..f659a486ec9 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -356,12 +356,36 @@ gfc_sym_mangled_identifier (gfc_symbol * sym) if (sym->attr.is_bind_c == 1 && sym->binding_label) return get_identifier (sym->binding_label); - if (sym->module == NULL) - return gfc_sym_identifier (sym); + if (!sym->fn_result_spec) + { + if (sym->module == NULL) + return gfc_sym_identifier (sym); + else + { + snprintf (name, sizeof name, "__%s_MOD_%s", sym->module, sym->name); + return get_identifier (name); + } + } else { - snprintf (name, sizeof name, "__%s_MOD_%s", sym->module, sym->name); - return get_identifier (name); + /* This is an entity that is actually local to a module procedure + that appears in the result specification expression. Since + sym->module will be a zero length string, we use ns->proc_name + instead. */ + if (sym->ns->proc_name && sym->ns->proc_name->module) + { + snprintf (name, sizeof name, "__%s_MOD__%s_PROC_%s", + sym->ns->proc_name->module, + sym->ns->proc_name->name, + sym->name); + return get_identifier (name); + } + else + { + snprintf (name, sizeof name, "__%s_PROC_%s", + sym->ns->proc_name->name, sym->name); + return get_identifier (name); + } } } @@ -615,6 +639,16 @@ gfc_finish_var_decl (tree decl, gfc_symbol * sym) DECL_EXTERNAL (decl) = 1; TREE_PUBLIC (decl) = 1; } + else if (sym->fn_result_spec && !sym->ns->proc_name->module) + { + + if (sym->ns->proc_name->attr.if_source != IFSRC_DECL) + DECL_EXTERNAL (decl) = 1; + else + TREE_STATIC (decl) = 1; + + TREE_PUBLIC (decl) = 1; + } else if (sym->module && !sym->attr.result && !sym->attr.dummy) { /* TODO: Don't set sym->module for result or dummy variables. */ @@ -1632,7 +1666,7 @@ gfc_get_symbol_decl (gfc_symbol * sym) /* Create string length decl first so that they can be used in the type declaration. For associate names, the target character length is used. Set 'length' to a constant so that if the - string lenght is a variable, it is not finished a second time. */ + string length is a variable, it is not finished a second time. */ if (sym->ts.type == BT_CHARACTER) { if (sym->attr.associate_var @@ -1654,7 +1688,7 @@ gfc_get_symbol_decl (gfc_symbol * sym) /* Symbols from modules should have their assembler names mangled. This is done here rather than in gfc_finish_var_decl because it is different for string length variables. */ - if (sym->module) + if (sym->module || sym->fn_result_spec) { gfc_set_decl_assembler_name (decl, gfc_sym_mangled_identifier (sym)); if (sym->attr.use_assoc && !intrinsic_array_parameter) @@ -4766,7 +4800,9 @@ gfc_create_module_variable (gfc_symbol * sym) /* Create the variable. */ pushdecl (decl); - gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE); + gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE + || (sym->ns->parent->proc_name->attr.flavor == FL_MODULE + && sym->fn_result_spec)); DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl; rest_of_decl_compilation (decl, 1, 0); gfc_module_add_decl (cur_module, decl); @@ -6153,8 +6189,8 @@ gfc_generate_function_code (gfc_namespace * ns) previous_procedure_symbol = current_procedure_symbol; current_procedure_symbol = sym; - /* Check that the frontend isn't still using this. */ - gcc_assert (sym->tlink == NULL); + /* Initialize sym->tlink so that gfc_trans_deferred_vars does not get + lost or worse. */ sym->tlink = sym; /* Create the declaration for functions with global scope. */ diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 78bff87cd1c..8cb0f1c7129 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -4116,6 +4116,16 @@ gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping) new_expr = gfc_copy_expr (arg1->ts.u.cl->length); break; + case GFC_ISYM_LEN_TRIM: + new_expr = gfc_copy_expr (arg1); + gfc_apply_interface_mapping_to_expr (mapping, new_expr); + + if (!new_expr) + return false; + + gfc_replace_expr (arg1, new_expr); + return true; + case GFC_ISYM_SIZE: if (!sym->as || sym->as->rank == 0) return false; @@ -6484,10 +6494,18 @@ gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest, builtin_decl_explicit (BUILT_IN_MEMMOVE), 3, dest, src, slen); + /* Wstringop-overflow appears at -O3 even though this warning is not + explicitly available in fortran nor can it be switched off. If the + source length is a constant, its negative appears as a very large + postive number and triggers the warning in BUILTIN_MEMSET. Fixing + the result of the MINUS_EXPR suppresses this spurious warning. */ + tmp = fold_build2_loc (input_location, MINUS_EXPR, + TREE_TYPE(dlen), dlen, slen); + if (slength && TREE_CONSTANT (slength)) + tmp = gfc_evaluate_now (tmp, block); + tmp4 = fold_build_pointer_plus_loc (input_location, dest, slen); - tmp4 = fill_with_spaces (tmp4, chartype, - fold_build2_loc (input_location, MINUS_EXPR, - TREE_TYPE(dlen), dlen, slen)); + tmp4 = fill_with_spaces (tmp4, chartype, tmp); gfc_init_block (&tempblock); gfc_add_expr_to_block (&tempblock, tmp3); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 12a3c4b8901..843ee9f928d 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,9 @@ +2016-12-09 Paul Thomas + + PR fortran/44265 + * gfortran.dg/char_result_14.f90: New test. + * gfortran.dg/char_result_15.f90: New test. + 2016-12-09 Martin Liska * gcc.dg/tree-ssa/dump-3.c: New test. diff --git a/gcc/testsuite/gfortran.dg/char_result_14.f90 b/gcc/testsuite/gfortran.dg/char_result_14.f90 new file mode 100644 index 00000000000..3083ecce4c5 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/char_result_14.f90 @@ -0,0 +1,103 @@ +! { dg-do run } +! +! Tests the fix for PR44265. This is the original test with the addition +! of the check of the issue found in comment #1 of the PR. +! +! Contributed by Ian Harvey +! Ian also contributed the first version of the fix. +! +! The original version of the bug +MODULE Fruits0 + IMPLICIT NONE + PRIVATE + PUBLIC :: Get0 +CONTAINS + FUNCTION Get0(i) RESULT(s) + CHARACTER(*), PARAMETER :: names(3) = [ & + 'Apple ', & + 'Orange ', & + 'Mango ' ]; + INTEGER, INTENT(IN) :: i + CHARACTER(LEN_TRIM(names(i))) :: s + !**** + s = names(i) + END FUNCTION Get0 +END MODULE Fruits0 +! +! Version that came about from sorting other issues. +MODULE Fruits + IMPLICIT NONE + PRIVATE + character (20) :: buffer + CHARACTER(*), PARAMETER :: names(4) = [ & + 'Apple ', & + 'Orange ', & + 'Mango ', & + 'Pear ' ]; + PUBLIC :: Get, SGet, fruity2, fruity3, buffer +CONTAINS +! This worked previously + subroutine fruity3 + write (buffer, '(i2,a)') len (Get (4)), Get (4) + end +! Original function in the PR + FUNCTION Get(i) RESULT(s) + INTEGER, INTENT(IN) :: i + CHARACTER(LEN_trim(names(i))) :: s + !**** + s = names(i) + END FUNCTION Get +! Check that dummy is OK + Subroutine Sget(i, s) + CHARACTER(*), PARAMETER :: names(4) = [ & + 'Apple ', & + 'Orange ', & + 'Mango ', & + 'Pear ' ]; + INTEGER, INTENT(IN) :: i + CHARACTER(LEN_trim(names(i))), intent(out) :: s + !**** + s = names(i) + write (buffer, '(i2,a)') len (s), s + END subroutine SGet +! This would fail with undefined references to mangled 'names' during linking + subroutine fruity2 + write (buffer, '(i2,a)') len (Get (3)), Get (3) + end +END MODULE Fruits + +PROGRAM WheresThatbLinkingConstantGone + use Fruits0 + USE Fruits + IMPLICIT NONE + character(7) :: arg = "" + integer :: i + +! Test the fix for the original bug + if (len (Get0(1)) .ne. 5) call abort + if (Get0(2) .ne. "Orange") call abort + +! Test the fix for the subsequent issues + call fruity + if (trim (buffer) .ne. " 6Orange") call abort + call fruity2 + if (trim (buffer) .ne. " 5Mango") call abort + call fruity3 + if (trim (buffer) .ne. " 4Pear") call abort + do i = 3, 4 + call Sget (i, arg) + if (i == 3) then + if (trim (buffer) .ne. " 5Mango") call abort + if (trim (arg) .ne. "Mango") call abort + else + if (trim (buffer) .ne. " 4Pear") call abort +! Since arg is fixed length in this scope, it gets over-written +! by s, which in this case is length 4. Thus, the 'o' remains. + if (trim (arg) .ne. "Pearo") call abort + end if + enddo +contains + subroutine fruity + write (buffer, '(i2,a)') len (Get (2)), Get (2) + end +END PROGRAM WheresThatbLinkingConstantGone diff --git a/gcc/testsuite/gfortran.dg/char_result_15.f90 b/gcc/testsuite/gfortran.dg/char_result_15.f90 new file mode 100644 index 00000000000..3c9a879d359 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/char_result_15.f90 @@ -0,0 +1,44 @@ +! { dg-do run } +! +! Tests the fix for PR44265. This test arose because of an issue found +! during the development of the fix; namely the clash between the normal +! module parameter and that found in the specification expression for +! 'Get'. +! +! Contributed by Paul Thomas +! +MODULE Fruits + IMPLICIT NONE + PRIVATE + character (20) :: buffer + PUBLIC :: Get, names, fruity, buffer + CHARACTER(len=7), PARAMETER :: names(3) = [ & + 'Pomme ', & + 'Orange ', & + 'Mangue ' ]; +CONTAINS + FUNCTION Get(i) RESULT(s) + CHARACTER(len=7), PARAMETER :: names(3) = [ & + 'Apple ', & + 'Orange ', & + 'Mango ' ]; + INTEGER, INTENT(IN) :: i + CHARACTER(LEN_TRIM(names(i))) :: s + s = names(i) + END FUNCTION Get + subroutine fruity (i) + integer :: i + write (buffer, '(i2,a)') len (Get (i)), Get (i) + end subroutine +END MODULE Fruits + +PROGRAM WheresThatbLinkingConstantGone + USE Fruits + IMPLICIT NONE + integer :: i + write (buffer, '(i2,a)') len (Get (1)), Get (1) + if (trim (buffer) .ne. " 5Apple") call abort + call fruity(3) + if (trim (buffer) .ne. " 5Mango") call abort + if (trim (names(3)) .ne. "Mangue") Call abort +END PROGRAM WheresThatbLinkingConstantGone -- 2.30.2