From patchwork Fri Dec 21 17:30:28 2012 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit Subject: [Fortran] PR 54884 - Fix TREE_PUBLIC() issue with PRIVATE module procedures Date: Fri, 21 Dec 2012 07:30:28 -0000 From: Tobias Burnus X-Patchwork-Id: 207863 Message-Id: <50D49CB4.6090306@net-b.de> To: gcc patches , gfortran 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 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 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" } }