mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-03-29 07:10:24 +08:00
Code Issues Packages Projects Releases Wiki Activity

re PR fortran/44265 (Link error with reference to parameter array in specification expression)

Browse Source 
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-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.

From-SVN: r243478
This commit is contained in:
Paul Thomas 2016-12-09 11:55:27 +00:00
parent cdecc83f3e
commit 345bd7ebbb
9 changed files with 303 additions and 12 deletions

22
gcc/fortran/ChangeLog

@ -1,3 +1,25 @@
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

2
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

59
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);
}

1
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;
}

54
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. */

24
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);

6
gcc/testsuite/ChangeLog

@ -1,3 +1,9 @@
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.

103
gcc/testsuite/gfortran.dg/char_result_14.f90 Normal file

@ -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_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

44
gcc/testsuite/gfortran.dg/char_result_15.f90 Normal file

@ -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 <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