re PR fortran/54884 (Externally used PRIVATE module procedure wrongly marked as TREE_PUBLIC()=0)

2012-10-18  Tobias Burnus  <burnus@net-b.de>

        PR fortran/54884
        * resolve.c (specification_expr): Change to bool.
        (resolve_formal_arglist, resolve_symbol): Set
        specification_expr to true before resolving the array spec.
        (resolve_variable, resolve_charlen, resolve_fl_variable):
        Properly reset specification_expr.
        (resolve_function): Set public_use when used in
        a specification expr.

2012-10-18  Tobias Burnus  <burnus@net-b.de>

        PR fortran/54884
        * gfortran.dg/public_private_module_7.f90: New.

From-SVN: r192571

gcc/fortran/ChangeLog

+2012-10-18  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/54884
+	* resolve.c (specification_expr): Change to bool.
+	(resolve_formal_arglist, resolve_symbol): Set
+	specification_expr to true before resolving the array spec.
+	(resolve_variable, resolve_charlen, resolve_fl_variable):
+	Properly reset specification_expr.
+	(resolve_function): Set public_use when used in
+	a specification expr.
+
 2012-10-16  Tobias Burnus  <burnus@net-b.de>
 
 	PR fortran/50981

gcc/fortran/resolve.c

@@ -81,7 +81,7 @@ static int omp_workshare_flag;
 static int formal_arg_flag = 0;
 
 /* True if we are resolving a specification expression.  */
-static int specification_expr = 0;
+static bool specification_expr = false;
 
 /* The id of the last entry seen.  */
 static int current_entry_id;
@@ -278,6 +278,7 @@ resolve_formal_arglist (gfc_symbol *proc)
 {
   gfc_formal_arglist *f;
   gfc_symbol *sym;
+  bool saved_specification_expr;
   int i;
 
   if (proc->result != NULL)
@@ -336,7 +337,10 @@ resolve_formal_arglist (gfc_symbol *proc)
       as = sym->ts.type == BT_CLASS && sym->attr.class_ok
 	   ? CLASS_DATA (sym)->as : sym->as;
 
+      saved_specification_expr = specification_expr;
+      specification_expr = true;
       gfc_resolve_array_spec (as, 0);
+      specification_expr = saved_specification_expr;
 
       /* 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.
@@ -3119,6 +3123,12 @@ 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)
+    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++;
@@ -5368,7 +5378,7 @@ resolve_variable (gfc_expr *e)
       gfc_entry_list *entry;
       gfc_formal_arglist *formal;
       int n;
-      bool seen;
+      bool seen, saved_specification_expr;
 
       /* If the symbol is a dummy...  */
       if (sym->attr.dummy && sym->ns == gfc_current_ns)
@@ -5401,7 +5411,8 @@ resolve_variable (gfc_expr *e)
 	}
 
       /* Now do the same check on the specification expressions.  */
-      specification_expr = 1;
+      saved_specification_expr = specification_expr;
+      specification_expr = true;
       if (sym->ts.type == BT_CHARACTER
 	  && gfc_resolve_expr (sym->ts.u.cl->length) == FAILURE)
 	t = FAILURE;
@@ -5409,14 +5420,12 @@ resolve_variable (gfc_expr *e)
       if (sym->as)
 	for (n = 0; n < sym->as->rank; n++)
 	  {
-	     specification_expr = 1;
 	     if (gfc_resolve_expr (sym->as->lower[n]) == FAILURE)
 	       t = FAILURE;
-	     specification_expr = 1;
 	     if (gfc_resolve_expr (sym->as->upper[n]) == FAILURE)
 	       t = FAILURE;
 	  }
-      specification_expr = 0;
+      specification_expr = saved_specification_expr;
 
       if (t == SUCCESS)
 	/* Update the symbol's entry level.  */
@@ -10175,28 +10184,35 @@ static gfc_try
 resolve_charlen (gfc_charlen *cl)
 {
   int i, k;
+  bool saved_specification_expr;
 
   if (cl->resolved)
     return SUCCESS;
 
   cl->resolved = 1;
-
+  saved_specification_expr = specification_expr;
+  specification_expr = true;
 
   if (cl->length_from_typespec)
     {
       if (gfc_resolve_expr (cl->length) == FAILURE)
-	return FAILURE;
+	{
+	  specification_expr = saved_specification_expr;
+	  return FAILURE;
+	}
 
       if (gfc_simplify_expr (cl->length, 0) == FAILURE)
-	return FAILURE;
+	{
+	  specification_expr = saved_specification_expr;
+	  return FAILURE;
+	}
     }
   else
     {
-      specification_expr = 1;
 
       if (resolve_index_expr (cl->length) == FAILURE)
 	{
-	  specification_expr = 0;
+	  specification_expr = saved_specification_expr;
 	  return FAILURE;
 	}
     }
@@ -10220,9 +10236,11 @@ resolve_charlen (gfc_charlen *cl)
       && mpz_cmp (cl->length->value.integer, gfc_integer_kinds[k].huge) > 0)
     {
       gfc_error ("String length at %L is too large", &cl->length->where);
+      specification_expr = saved_specification_expr;
       return FAILURE;
     }
 
+  specification_expr = saved_specification_expr;
   return SUCCESS;
 }
 
@@ -10682,6 +10700,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;
 
   auto_save_msg = "Automatic object '%s' at %L cannot have the "
 		  "SAVE attribute";
@@ -10692,7 +10711,8 @@ resolve_fl_variable (gfc_symbol *sym, int mp_flag)
   /* Set this flag to check that variables are parameters of all entries.
      This check is effected by the call to gfc_resolve_expr through
      is_non_constant_shape_array.  */
-  specification_expr = 1;
+  saved_specification_expr = specification_expr;
+  specification_expr = true;
 
   if (sym->ns->proc_name
       && (sym->ns->proc_name->attr.flavor == FL_MODULE
@@ -10706,7 +10726,7 @@ resolve_fl_variable (gfc_symbol *sym, int mp_flag)
 	 constant.  */
       gfc_error ("The module or main program array '%s' at %L must "
 		 "have constant shape", sym->name, &sym->declared_at);
-      specification_expr = 0;
+      specification_expr = saved_specification_expr;
       return FAILURE;
     }
 
@@ -10716,6 +10736,7 @@ resolve_fl_variable (gfc_symbol *sym, int mp_flag)
       gfc_error ("Entity '%s' at %L has a deferred type parameter and "
 		 "requires either the pointer or allocatable attribute",
 		     sym->name, &sym->declared_at);
+      specification_expr = saved_specification_expr;
       return FAILURE;
     }
 
@@ -10729,12 +10750,14 @@ 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;
 	  return FAILURE;
 	}
 
       if (e && sym->attr.save == SAVE_EXPLICIT && !gfc_is_constant_expr (e))
 	{
 	  gfc_error (auto_save_msg, sym->name, &sym->declared_at);
+	  specification_expr = saved_specification_expr;
 	  return FAILURE;
 	}
 
@@ -10748,12 +10771,14 @@ 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;
 	      return FAILURE;
 	    }
 	  if (sym->attr.in_common)
 	    {
 	      gfc_error ("COMMON variable '%s' at %L must have constant "
 			 "character length", sym->name, &sym->declared_at);
+	      specification_expr = saved_specification_expr;
 	      return FAILURE;
 	    }
 	}
@@ -10784,6 +10809,7 @@ resolve_fl_variable (gfc_symbol *sym, int mp_flag)
       if (automatic_flag && sym->attr.save == SAVE_EXPLICIT)
 	{
 	  gfc_error (auto_save_msg, sym->name, &sym->declared_at);
+	  specification_expr = saved_specification_expr;
 	  return FAILURE;
 	}
     }
@@ -10817,13 +10843,19 @@ resolve_fl_variable (gfc_symbol *sym, int mp_flag)
 		   sym->name, &sym->declared_at);
       else
 	goto no_init_error;
+      specification_expr = saved_specification_expr;
       return FAILURE;
     }
 
 no_init_error:
   if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
-    return resolve_fl_variable_derived (sym, no_init_flag);
+    {
+      gfc_try res = resolve_fl_variable_derived (sym, no_init_flag);
+      specification_expr = saved_specification_expr;
+      return res;
+    }
 
+  specification_expr = saved_specification_expr;
   return SUCCESS;
 }
 
@@ -12569,6 +12601,7 @@ resolve_symbol (gfc_symbol *sym)
   gfc_component *c;
   symbol_attribute class_attr;
   gfc_array_spec *as;
+  bool saved_specification_expr;
 
   if (sym->attr.artificial)
     return;
@@ -12689,7 +12722,12 @@ resolve_symbol (gfc_symbol *sym)
 	}
     }
   else if (mp_flag && sym->attr.flavor == FL_PROCEDURE && sym->attr.function)
-    gfc_resolve_array_spec (sym->result->as, false);
+    {
+      bool saved_specification_expr = specification_expr;
+      specification_expr = true;
+      gfc_resolve_array_spec (sym->result->as, false);
+      specification_expr = saved_specification_expr;
+    }
 
   if (sym->ts.type == BT_CLASS && sym->attr.class_ok)
     {
@@ -13105,7 +13143,10 @@ resolve_symbol (gfc_symbol *sym)
   if (sym->attr.function && sym->as)
     formal_arg_flag = 1;
 
+  saved_specification_expr = specification_expr;
+  specification_expr = true;
   gfc_resolve_array_spec (sym->as, check_constant);
+  specification_expr = saved_specification_expr;
 
   formal_arg_flag = 0;
 

gcc/testsuite/ChangeLog

+2012-10-18  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/54884
+	* gfortran.dg/public_private_module_7.f90: New.
+
 2012-10-18  Paolo Carlini  <paolo.carlini@oracle.com>
 
 	PR c++/29633
@@ -10,21 +15,21 @@
 
 2012-10-18  Matthew Gretton-Dann  <matthew.gretton-dann@arm.com>
 
-        * gcc.target/arm/neon/vfmaQf32.c: New testcase.
-        * gcc.target/arm/neon/vfmaf32.c: Likewise.
-        * gcc.target/arm/neon/vfmsQf32.c: Likewise.
-        * gcc.target/arm/neon/vfmsf32.c: Likewise.
+	* gcc.target/arm/neon/vfmaQf32.c: New testcase.
+	* gcc.target/arm/neon/vfmaf32.c: Likewise.
+	* gcc.target/arm/neon/vfmsQf32.c: Likewise.
+	* gcc.target/arm/neon/vfmsf32.c: Likewise.
 
 2012-10-18  Matthew Gretton-Dann  <matthew.gretton-dann@arm.com>
 
-        * gcc.target/arm/ftest-armv8a-arm.c: New testcase.
-        * gcc.target/arm/ftest-armv8a-thumb.c: Likewise.
-        * gcc.target/arm/ftest-support-arm.h (feature_matrix): Add
-        ARMv8-A row.
-        * gcc.target/arm/ftest-support-thumb.h (feature_matrix):
-        Likewise.
-        * gcc.target/arm/ftest-support.h (architecture): Add ARMv8-A.
-        * lib/target-supports.exp: Add ARMv8-A architecture expectation.
+	* gcc.target/arm/ftest-armv8a-arm.c: New testcase.
+	* gcc.target/arm/ftest-armv8a-thumb.c: Likewise.
+	* gcc.target/arm/ftest-support-arm.h (feature_matrix): Add
+	ARMv8-A row.
+	* gcc.target/arm/ftest-support-thumb.h (feature_matrix):
+	Likewise.
+	* gcc.target/arm/ftest-support.h (architecture): Add ARMv8-A.
+	* lib/target-supports.exp: Add ARMv8-A architecture expectation.
 
 2012-10-16  Jan Hubicka  <jh@suse.cz>
 

gcc/testsuite/gfortran.dg/public_private_module_7.f90

+! { 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_common_attrs
+  private
+  !...
+  public :: get_key
+contains
+  pure function get_key_len() result(n)
+    n = 5
+  end function get_key_len
+  pure function other() result(n)
+    n = 5
+  end function other
+  ! ...
+  function get_key() result(key)
+    ! ...
+    character(len=get_key_len()) :: key
+    key = ''
+  end function get_key
+end module m_common_attrs
+
+! { dg-final { scan-assembler-not "__m_common_attrs_MOD_other" } }
+! { dg-final { scan-assembler "__m_common_attrs_MOD_get_key_len" } }