Hi Dominique.
....snip....
> I have a last glitch (which can be deferred if needed):
....snip....
Fixed by the new patch, which is attached. Bootstraps and regtests OK.
OK for trunk?
Paul
2016-11-10 Paul Thomas <pa...@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_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.
2016-11-10 Paul Thomas <pa...@gcc.gnu.org>
PR fortran/44265
* gfortran.dg/char_result_14.f90: New test.
* gfortran.dg/char_result_15.f90: New test.
* gfortran.dg/char_result_16.f90: New test.
--
The difference between genius and stupidity is; genius has its limits.
Albert Einstein
Index: gcc/fortran/gfortran.h
===================================================================
*** gcc/fortran/gfortran.h (revision 241994)
--- gcc/fortran/gfortran.h (working copy)
*************** typedef struct gfc_symbol
*** 1498,1503 ****
--- 1498,1505 ----
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
Index: gcc/fortran/resolve.c
===================================================================
*** gcc/fortran/resolve.c (revision 241994)
--- gcc/fortran/resolve.c (working copy)
*************** resolve_equivalence (gfc_equiv *eq)
*** 15732,15737 ****
--- 15732,15785 ----
}
+ /* 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
*************** resolve_fntype (gfc_namespace *ns)
*** 15782,15787 ****
--- 15830,15838 ----
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);
}
Index: gcc/fortran/symbol.c
===================================================================
*** gcc/fortran/symbol.c (revision 241994)
--- gcc/fortran/symbol.c (working copy)
*************** gfc_new_symbol (const char *name, gfc_na
*** 2933,2938 ****
--- 2933,2939 ----
p->common_block = NULL;
p->f2k_derived = NULL;
p->assoc = NULL;
+ p->fn_result_spec = 0;
return p;
}
Index: gcc/fortran/trans-decl.c
===================================================================
*** gcc/fortran/trans-decl.c (revision 241994)
--- gcc/fortran/trans-decl.c (working copy)
*************** gfc_sym_mangled_identifier (gfc_symbol *
*** 355,362 ****
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);
else
{
snprintf (name, sizeof name, "__%s_MOD_%s", sym->module, sym->name);
--- 355,381 ----
if (sym->attr.is_bind_c == 1 && sym->binding_label)
return get_identifier (sym->binding_label);
! if (sym->fn_result_spec && sym->module)
! {
! /* 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. */
! 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 if (sym->module == NULL)
! if (!sym->fn_result_spec)
! return gfc_sym_identifier (sym);
! else
! {
! snprintf (name, sizeof name, "__%s_PROC_%s",
! sym->ns->proc_name->name, sym->name);
! return get_identifier (name);
! }
else
{
snprintf (name, sizeof name, "__%s_MOD_%s", sym->module, sym->name);
*************** gfc_get_symbol_decl (gfc_symbol * sym)
*** 1628,1634 ****
/* 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. */
if (sym->ts.type == BT_CHARACTER)
{
if (sym->attr.associate_var
--- 1647,1653 ----
/* 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 length is a variable, it is not finished a second time. */
if (sym->ts.type == BT_CHARACTER)
{
if (sym->attr.associate_var
*************** gfc_get_symbol_decl (gfc_symbol * sym)
*** 1650,1656 ****
/* 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)
{
gfc_set_decl_assembler_name (decl, gfc_sym_mangled_identifier (sym));
if (sym->attr.use_assoc && !intrinsic_array_parameter)
--- 1669,1675 ----
/* 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 || sym->fn_result_spec)
{
gfc_set_decl_assembler_name (decl, gfc_sym_mangled_identifier (sym));
if (sym->attr.use_assoc && !intrinsic_array_parameter)
*************** gfc_create_module_variable (gfc_symbol *
*** 4753,4759 ****
/* Create the variable. */
pushdecl (decl);
! gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
rest_of_decl_compilation (decl, 1, 0);
gfc_module_add_decl (cur_module, decl);
--- 4772,4780 ----
/* Create the variable. */
pushdecl (decl);
! 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);
*************** gfc_generate_function_code (gfc_namespac
*** 6140,6147 ****
previous_procedure_symbol = current_procedure_symbol;
current_procedure_symbol = sym;
! /* Check that the frontend isn't still using this. */
! gcc_assert (sym->tlink == NULL);
sym->tlink = sym;
/* Create the declaration for functions with global scope. */
--- 6161,6168 ----
previous_procedure_symbol = current_procedure_symbol;
current_procedure_symbol = sym;
! /* 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. */
Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c (revision 241994)
--- gcc/fortran/trans-expr.c (working copy)
*************** gfc_map_intrinsic_function (gfc_expr *ex
*** 4116,4121 ****
--- 4116,4131 ----
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;
Index: gcc/testsuite/gfortran.dg/char_result_14.f90
===================================================================
*** gcc/testsuite/gfortran.dg/char_result_14.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/char_result_14.f90 (working copy)
***************
*** 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_har...@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
Index: gcc/testsuite/gfortran.dg/char_result_15.f90
===================================================================
*** gcc/testsuite/gfortran.dg/char_result_15.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/char_result_15.f90 (working copy)
***************
*** 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 <pa...@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
Index: gcc/testsuite/gfortran.dg/char_result_16.f90
===================================================================
*** gcc/testsuite/gfortran.dg/char_result_16.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/char_result_16.f90 (working copy)
***************
*** 0 ****
--- 1,34 ----
+ ! { dg-do run }
+ !
+ ! Tests the fix for PR44265. This test arose during review.
+ !
+ ! Contributed by Dominique d'Humeieres <domi...@lps.ens.fr>
+ !
+ FUNCTION Get(i) RESULT(s)
+ CHARACTER(*), PARAMETER :: names(3) = [ &
+ 'Apple ', &
+ 'Orange ', &
+ 'Mango ' ];
+ INTEGER, INTENT(IN) :: i
+ CHARACTER(LEN_TRIM(names(i))) :: s
+ !****
+ s = names(i)
+ print *, len(s)
+ END FUNCTION Get
+
+ PROGRAM WheresThatbLinkingConstantGone
+ IMPLICIT NONE
+ interface
+ FUNCTION Get(i) RESULT(s)
+ CHARACTER(*), PARAMETER :: names(3) = [ &
+ 'Apple ', &
+ 'Orange ', &
+ 'Mango ' ];
+ INTEGER, INTENT(IN) :: i
+ CHARACTER(LEN_TRIM(names(i))) :: s
+ END FUNCTION Get
+ end interface
+
+ if (len(Get(1)) .ne. 5) call abort
+ if (len(Get(2)) .ne. 6) call abort
+ END PROGRAM WheresThatbLinkingConstantGone
