+2016-12-09 Paul Thomas <pault@gcc.gnu.org>
+
+ 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 <kargl@gcc.gnu.org>
PR fortran/65173
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
{
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)
}
+/* 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
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);
}
p->common_block = NULL;
p->f2k_derived = NULL;
p->assoc = NULL;
+ p->fn_result_spec = 0;
return p;
}
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);
+ }
}
}
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. */
/* 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
/* 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)
/* 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);
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. */
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;
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);
+2016-12-09 Paul Thomas <pault@gcc.gnu.org>
+
+ PR fortran/44265
+ * gfortran.dg/char_result_14.f90: New test.
+ * gfortran.dg/char_result_15.f90: New test.
+
2016-12-09 Martin Liska <mliska@suse.cz>
* gcc.dg/tree-ssa/dump-3.c: New test.
--- /dev/null
+! { 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_harvey@bigpond.com>
+! 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
--- /dev/null
+! { 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 <pault@gcc.gnu.org>
+!
+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
projects / gcc.git / commitdiff