General background: Private module variables and module procedures can
be marked as TREE_PUBLIC()= 0, unless they are used in the specification
expression of the dummy argument or result variable of public module
procedures (or private module procedures in public generic interfaces).
That gives a lot of optimization possibilities. However, it is not
trivial to get it right. The current version has resolve_function:
3128 if (sym && specification_expr && sym->attr.function
3129 && gfc_current_ns->proc_name
3130 && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
3131 sym->attr.public_used = 1;
That fails if one does not operate on a result variable but on a dummy
argument, which might be not at ns->proc_name but at ns->parent->proc_name.
The attached patch tried to fix the 4.8 regression without breaking the
existing test cases.
Build and regtested on x86-64-gnu-linux.
OK for the trunk?
Tobias
PS: I start to understand why other compilers don't do it.
2012-12-21 Tobias Burnus <bur...@net-b.de>
PR fortran/54884
* resolve.c (spec_expr_mod_proc): New static variable.
(resolve_formal_arglist, resolve_function, resolve_variable,
resolve_charlen, resolve_fl_variable, resolve_symbol): Use
it to decide when to mark a symbol as public_use.
2012-12-21 Tobias Burnus <bur...@net-b.de>
PR fortran/54884
* gfortran.dg/public_private_module_8.f90: New.
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index fce6f73..95cc4de 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -83,6 +83,10 @@ static int formal_arg_flag = 0;
/* True if we are resolving a specification expression. */
static bool specification_expr = false;
+/* True if we are resolving the specification expression of a module
+ procedure's result or dummy variable; used for the public_use setting. */
+static bool spec_expr_mod_proc = false;
+
/* The id of the last entry seen. */
static int current_entry_id;
@@ -278,7 +282,7 @@ resolve_formal_arglist (gfc_symbol *proc)
{
gfc_formal_arglist *f;
gfc_symbol *sym;
- bool saved_specification_expr;
+ bool saved_specification_expr, saved_spec_expr_mod_proc;
int i;
if (proc->result != NULL)
@@ -339,8 +343,19 @@ resolve_formal_arglist (gfc_symbol *proc)
saved_specification_expr = specification_expr;
specification_expr = true;
+ saved_spec_expr_mod_proc = spec_expr_mod_proc;
+ if ((sym->attr.dummy || sym->attr.result || sym->attr.function)
+ && ((sym == sym->result && sym->ns->proc_name
+ && sym->ns->proc_name->attr.flavor == FL_MODULE)
+ || (sym != sym->result && sym->ns->parent
+ && sym->ns->parent->proc_name
+ && sym->ns->parent->proc_name->attr.flavor == FL_MODULE)))
+ spec_expr_mod_proc = true;
+
gfc_resolve_array_spec (as, 0);
+
specification_expr = saved_specification_expr;
+ spec_expr_mod_proc = saved_spec_expr_mod_proc;
/* We can't tell if an array with dimension (:) is assumed or deferred
shape until we know if it has the pointer or allocatable attributes.
@@ -3129,12 +3144,13 @@ resolve_function (gfc_expr *expr)
return FAILURE;
}
- if (sym && specification_expr && sym->attr.function
- && gfc_current_ns->proc_name
- && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
+ if (sym && spec_expr_mod_proc && sym->attr.function
+ && ((gfc_current_ns->proc_name
+ && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
+ || (gfc_current_ns->parent && gfc_current_ns->parent->proc_name
+ && gfc_current_ns->parent->proc_name->attr.flavor == FL_MODULE)))
sym->attr.public_used = 1;
-
/* Switch off assumed size checking and do this again for certain kinds
of procedure, once the procedure itself is resolved. */
need_full_assumed_size++;
@@ -5363,14 +5379,15 @@ resolve_variable (gfc_expr *e)
/* If a PRIVATE variable is used in the specification expression of the
result variable, it might be accessed from outside the module and can
thus not be TREE_PUBLIC() = 0.
- TODO: sym->attr.public_used only has to be set for the result variable's
- type-parameter expression and not for dummies or automatic variables.
- Additionally, it only has to be set if the function is either PUBLIC or
- used in a generic interface or TBP; unfortunately,
+ TODO: sym->attr.public_used only has to be set if the function is
+ either PUBLIC or used in a generic interface or TBP; unfortunately,
proc_name->attr.public_used can get set at a later stage. */
- if (specification_expr && sym->attr.access == ACCESS_PRIVATE
+ if (spec_expr_mod_proc
&& !sym->attr.function && !sym->attr.use_assoc
- && gfc_current_ns->proc_name && gfc_current_ns->proc_name->attr.function)
+ && ((gfc_current_ns->proc_name
+ && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
+ || (gfc_current_ns->parent && gfc_current_ns->parent->proc_name
+ && gfc_current_ns->parent->proc_name->attr.flavor == FL_MODULE)))
sym->attr.public_used = 1;
/* Deal with forward references to entries during resolve_code, to
@@ -5384,7 +5401,7 @@ resolve_variable (gfc_expr *e)
gfc_entry_list *entry;
gfc_formal_arglist *formal;
int n;
- bool seen, saved_specification_expr;
+ bool seen, saved_specification_expr, saved_spec_expr_mod_proc;
/* If the symbol is a dummy... */
if (sym->attr.dummy && sym->ns == gfc_current_ns)
@@ -5419,6 +5436,15 @@ resolve_variable (gfc_expr *e)
/* Now do the same check on the specification expressions. */
saved_specification_expr = specification_expr;
specification_expr = true;
+ saved_spec_expr_mod_proc = spec_expr_mod_proc;
+ if ((sym->attr.dummy || sym->attr.result || sym->attr.function)
+ && ((sym == sym->result && sym->ns->proc_name
+ && sym->ns->proc_name->attr.flavor == FL_MODULE)
+ || (sym != sym->result && sym->ns->parent
+ && sym->ns->parent->proc_name
+ && sym->ns->parent->proc_name->attr.flavor == FL_MODULE)))
+ spec_expr_mod_proc = true;
+
if (sym->ts.type == BT_CHARACTER
&& gfc_resolve_expr (sym->ts.u.cl->length) == FAILURE)
t = FAILURE;
@@ -5432,6 +5458,7 @@ resolve_variable (gfc_expr *e)
t = FAILURE;
}
specification_expr = saved_specification_expr;
+ spec_expr_mod_proc = saved_spec_expr_mod_proc;
if (t == SUCCESS)
/* Update the symbol's entry level. */
@@ -10674,7 +10701,7 @@ static gfc_try
resolve_charlen (gfc_charlen *cl)
{
int i, k;
- bool saved_specification_expr;
+ bool saved_specification_expr, saved_spec_expr_mod_proc;
if (cl->resolved)
return SUCCESS;
@@ -10682,18 +10709,26 @@ resolve_charlen (gfc_charlen *cl)
cl->resolved = 1;
saved_specification_expr = specification_expr;
specification_expr = true;
+ saved_spec_expr_mod_proc = spec_expr_mod_proc;
+ if ((gfc_current_ns->proc_name
+ && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
+ || (gfc_current_ns->parent && gfc_current_ns->parent->proc_name
+ && gfc_current_ns->parent->proc_name->attr.flavor == FL_MODULE))
+ spec_expr_mod_proc = true;
if (cl->length_from_typespec)
{
if (gfc_resolve_expr (cl->length) == FAILURE)
{
specification_expr = saved_specification_expr;
+ spec_expr_mod_proc = saved_spec_expr_mod_proc;
return FAILURE;
}
if (gfc_simplify_expr (cl->length, 0) == FAILURE)
{
specification_expr = saved_specification_expr;
+ spec_expr_mod_proc = saved_spec_expr_mod_proc;
return FAILURE;
}
}
@@ -10703,6 +10738,7 @@ resolve_charlen (gfc_charlen *cl)
if (resolve_index_expr (cl->length) == FAILURE)
{
specification_expr = saved_specification_expr;
+ spec_expr_mod_proc = saved_spec_expr_mod_proc;
return FAILURE;
}
}
@@ -10727,10 +10763,12 @@ resolve_charlen (gfc_charlen *cl)
{
gfc_error ("String length at %L is too large", &cl->length->where);
specification_expr = saved_specification_expr;
+ spec_expr_mod_proc = saved_spec_expr_mod_proc;
return FAILURE;
}
specification_expr = saved_specification_expr;
+ spec_expr_mod_proc = saved_spec_expr_mod_proc;
return SUCCESS;
}
@@ -11192,7 +11230,7 @@ resolve_fl_variable (gfc_symbol *sym, int mp_flag)
int no_init_flag, automatic_flag;
gfc_expr *e;
const char *auto_save_msg;
- bool saved_specification_expr;
+ bool saved_specification_expr, saved_spec_expr_mod_proc;
auto_save_msg = "Automatic object '%s' at %L cannot have the "
"SAVE attribute";
@@ -11205,6 +11243,13 @@ resolve_fl_variable (gfc_symbol *sym, int mp_flag)
is_non_constant_shape_array. */
saved_specification_expr = specification_expr;
specification_expr = true;
+ saved_spec_expr_mod_proc = spec_expr_mod_proc;
+ if ((sym->attr.dummy || sym->attr.result || sym->attr.function)
+ && ((gfc_current_ns->proc_name
+ && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
+ || (gfc_current_ns->parent && gfc_current_ns->parent->proc_name
+ && gfc_current_ns->parent->proc_name->attr.flavor == FL_MODULE)))
+ spec_expr_mod_proc = true;
if (sym->ns->proc_name
&& (sym->ns->proc_name->attr.flavor == FL_MODULE
@@ -11219,6 +11264,7 @@ resolve_fl_variable (gfc_symbol *sym, int mp_flag)
gfc_error ("The module or main program array '%s' at %L must "
"have constant shape", sym->name, &sym->declared_at);
specification_expr = saved_specification_expr;
+ spec_expr_mod_proc = saved_spec_expr_mod_proc;
return FAILURE;
}
@@ -11229,6 +11275,7 @@ resolve_fl_variable (gfc_symbol *sym, int mp_flag)
"requires either the pointer or allocatable attribute",
sym->name, &sym->declared_at);
specification_expr = saved_specification_expr;
+ spec_expr_mod_proc = saved_spec_expr_mod_proc;
return FAILURE;
}
@@ -11243,6 +11290,7 @@ resolve_fl_variable (gfc_symbol *sym, int mp_flag)
gfc_error ("Entity with assumed character length at %L must be a "
"dummy argument or a PARAMETER", &sym->declared_at);
specification_expr = saved_specification_expr;
+ spec_expr_mod_proc = saved_spec_expr_mod_proc;
return FAILURE;
}
@@ -11250,6 +11298,7 @@ resolve_fl_variable (gfc_symbol *sym, int mp_flag)
{
gfc_error (auto_save_msg, sym->name, &sym->declared_at);
specification_expr = saved_specification_expr;
+ spec_expr_mod_proc = saved_spec_expr_mod_proc;
return FAILURE;
}
@@ -11264,6 +11313,7 @@ resolve_fl_variable (gfc_symbol *sym, int mp_flag)
gfc_error ("'%s' at %L must have constant character length "
"in this context", sym->name, &sym->declared_at);
specification_expr = saved_specification_expr;
+ spec_expr_mod_proc = saved_spec_expr_mod_proc;
return FAILURE;
}
if (sym->attr.in_common)
@@ -11271,6 +11321,7 @@ resolve_fl_variable (gfc_symbol *sym, int mp_flag)
gfc_error ("COMMON variable '%s' at %L must have constant "
"character length", sym->name, &sym->declared_at);
specification_expr = saved_specification_expr;
+ spec_expr_mod_proc = saved_spec_expr_mod_proc;
return FAILURE;
}
}
@@ -11302,6 +11353,7 @@ resolve_fl_variable (gfc_symbol *sym, int mp_flag)
{
gfc_error (auto_save_msg, sym->name, &sym->declared_at);
specification_expr = saved_specification_expr;
+ spec_expr_mod_proc = saved_spec_expr_mod_proc;
return FAILURE;
}
}
@@ -11336,6 +11388,7 @@ resolve_fl_variable (gfc_symbol *sym, int mp_flag)
else
goto no_init_error;
specification_expr = saved_specification_expr;
+ spec_expr_mod_proc = saved_spec_expr_mod_proc;
return FAILURE;
}
@@ -11344,10 +11397,12 @@ no_init_error:
{
gfc_try res = resolve_fl_variable_derived (sym, no_init_flag);
specification_expr = saved_specification_expr;
+ spec_expr_mod_proc = saved_spec_expr_mod_proc;
return res;
}
specification_expr = saved_specification_expr;
+ spec_expr_mod_proc = saved_spec_expr_mod_proc;
return SUCCESS;
}
@@ -13151,7 +13206,7 @@ resolve_symbol (gfc_symbol *sym)
gfc_component *c;
symbol_attribute class_attr;
gfc_array_spec *as;
- bool saved_specification_expr;
+ bool saved_specification_expr, saved_spec_expr_mod_proc;
if (sym->attr.artificial)
return;
@@ -13699,8 +13754,19 @@ resolve_symbol (gfc_symbol *sym)
saved_specification_expr = specification_expr;
specification_expr = true;
+ saved_spec_expr_mod_proc = spec_expr_mod_proc;
+ if ((sym->attr.dummy || sym->attr.result || sym->attr.function)
+ && ((sym == sym->result && sym->ns->proc_name
+ && sym->ns->proc_name->attr.flavor == FL_MODULE)
+ || (sym != sym->result && sym->ns->parent
+ && sym->ns->parent->proc_name
+ && sym->ns->parent->proc_name->attr.flavor == FL_MODULE)))
+ spec_expr_mod_proc = true;
+
gfc_resolve_array_spec (sym->as, check_constant);
+
specification_expr = saved_specification_expr;
+ spec_expr_mod_proc = saved_spec_expr_mod_proc;
formal_arg_flag = 0;
diff --git a/gcc/testsuite/gfortran.dg/public_private_module_8.f90 b/gcc/testsuite/gfortran.dg/public_private_module_8.f90
new file mode 100644
index 0000000..8543320
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/public_private_module_8.f90
@@ -0,0 +1,52 @@
+! { dg-do compile }
+! { dg-options "-O2" }
+!
+! PR fortran/54884
+!
+! Check that get_key_len is not optimized away as it
+! is used in a publicly visible specification expression.
+!
+
+module m
+ private
+ public :: foo
+ interface foo
+ module procedure bar
+ end interface foo
+contains
+ pure function mylen()
+ integer :: mylen
+ mylen = 42
+ end function mylen
+ pure function myotherlen()
+ integer :: myotherlen
+ myotherlen = 99
+ end function myotherlen
+ subroutine bar(x)
+ character(len=mylen()) :: x
+ character :: z2(myotherlen())
+ call internal(x)
+ block
+ character(len=myotherlen()) :: z
+ z = "abc"
+ x(1:5) = z
+ end block
+! x(6:10) = intern_func()
+ contains
+! The following currently fails as character lengths are
+! resolved separately; additionally intern_func's
+! sym->ns->proc_name is "bar".
+! function intern_func()
+! character(len=myotherlen()) :: intern_func
+! intern_func = "zuzu"
+! end function intern_func
+ subroutine internal(y)
+ character(len=myotherlen()) :: y
+ y = "abc"
+ end subroutine internal
+ end subroutine bar
+end module m
+
+! { dg-final { scan-assembler-not "__m_MOD_myotherlen" } }
+! { dg-final { scan-assembler "__m_MOD_bar" } }
+! { dg-final { scan-assembler "__m_MOD_mylen" } }
