[PATCH] PR fortran/85138,85996 -- Use private namespace

[Steve Kargl <sgk at troutmask dot apl dot washington dot edu>]

All,

The attach patch fixes a regression introduced by r258347.  In that
revision, an attempt is made to reduce a scalar integer expression
to a constant in a CHARACTER(LEN=...) type declaration.  If successful,
life is good.  If unsuccessful, the original scalar integer expression is
simply saved for later resolution. 

Unfortunately, this created a regression, because an attempt to reduce
the scalar integer expression mucks up the namespace.  In particular,
this occurs for user-defined generic functions with the module procedures
declared after the use of the generic name (see testcases).  Note, this
may actually be invalid Fortran, but I'm not going to try to unravel:

   A variable in a specification expression shall have its
   type and type parameters, if any, specified by a previous
   declaration in the same scoping unit, by the implicit
   typing rules in effect for the scoping unit, or by host
   or use association.

It seems to be a catch-22.  The module procedures should be available
through host association except the generic name is used before the
module procedures are parsed.

The fix is to use a private namespace.  Whether an attempt to
reduce the scalar interger expression is successful or not,
the private namespace is discarded.

Built and regression tested on x86_64-*-freebsd and i586-*-freebsd.
OK to commit?

2018-06-04  Steven G. Kargl  <kargl@gcc.gnu.org>

	PR fortran/85138
	PR fortran/85996
	* decl.c (gfc_match_char_spec): Use private namespace in attempt to
	reduce a charlen to a constant.

2018-06-04  Steven G. Kargl  <kargl@gcc.gnu.org>

	PR fortran/85138
	PR fortran/85996
	* gfortran.dg/pr85138_1.f90: New test.
	* gfortran.dg/pr85138_2.f90: Ditto.
	* gfortran.dg/pr85996.f90: Ditto.

-- 
Steve

Index: gcc/fortran/decl.c
===================================================================
--- gcc/fortran/decl.c	(revision 261145)
+++ gcc/fortran/decl.c	(working copy)
@@ -3238,12 +3238,20 @@ done:
     cl->length = gfc_get_int_expr (gfc_charlen_int_kind, NULL, 1);
   else
     {
-      /* If gfortran ends up here, then the len may be reducible to a
-	 constant.  Try to do that here.  If it does not reduce, simply
-	 assign len to the charlen.  */
+      /* If gfortran ends up here, then len may be reducible to a constant.
+	 Try to do that here.  If it does not reduce, simply assign len to
+	 charlen.  A complication occurs with user-defined generic functions,
+	 which are not resolved.  Use a private namespace to deal with
+	 generic functions.  */
+
       if (len && len->expr_type != EXPR_CONSTANT)
 	{
+	  gfc_namespace *old_ns;
 	  gfc_expr *e;
+
+	  old_ns = gfc_current_ns;
+	  gfc_current_ns = gfc_get_namespace (NULL, 0);
+
 	  e = gfc_copy_expr (len);
 	  gfc_reduce_init_expr (e);
 	  if (e->expr_type == EXPR_CONSTANT)
@@ -3254,10 +3262,12 @@ done:
 	    }
 	  else
 	    gfc_free_expr (e);
-	  cl->length = len;
+
+	  gfc_free_namespace (gfc_current_ns);
+	  gfc_current_ns = old_ns;
 	}
-      else
-	cl->length = len;
+
+      cl->length = len;
     }
 
   ts->u.cl = cl;
Index: gcc/testsuite/gfortran.dg/pr85138_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/pr85138_1.f90	(nonexistent)
+++ gcc/testsuite/gfortran.dg/pr85138_1.f90	(working copy)
@@ -0,0 +1,29 @@
+! { dg-do compile }
+module fox_m_fsys_format
+
+  interface len
+     module procedure str_real_sp_len, str_real_sp_fmt_len
+  end interface
+
+contains
+
+  pure function str_real_sp_fmt_len(x, fmt) result(n)
+    real, intent(in) :: x
+    character(len=*), intent(in) :: fmt
+    if (.not.checkFmt(fmt)) then
+    endif
+  end function str_real_sp_fmt_len
+  pure function str_real_sp_len(x) result(n)
+    real, intent(in) :: x
+    n = len(x, "")
+  end function str_real_sp_len
+  pure function str_real_dp_matrix(xa) result(s)
+    real, intent(in) :: xa
+    character(len=len(xa)) :: s
+  end function str_real_dp_matrix
+
+  pure function checkfmt(s) result(a)
+   logical a
+   character(len=*), intent(in) :: s
+  end function checkfmt
+end module fox_m_fsys_format
Index: gcc/testsuite/gfortran.dg/pr85138_2.f90
===================================================================
--- gcc/testsuite/gfortran.dg/pr85138_2.f90	(nonexistent)
+++ gcc/testsuite/gfortran.dg/pr85138_2.f90	(working copy)
@@ -0,0 +1,32 @@
+! { dg-do compile }
+module fox_m_fsys_format
+  interface len
+    module procedure str_real_dp_len, str_real_dp_fmt_len
+  end interface
+contains
+  pure function str_real_dp_fmt_len(x, fmt) result(n)
+    real, intent(in) :: x
+    character(len=*), intent(in) :: fmt
+    if (.not.checkFmt(fmt)) then
+    endif
+  end function str_real_dp_fmt_len
+  pure function str_real_dp_len(x) result(n)
+    real, intent(in) :: x
+  end function str_real_dp_len
+  pure function str_real_dp_array_len(xa) result(n)
+    real, dimension(:), intent(in) :: xa
+  end function str_real_dp_array_len
+  pure function str_real_dp_array_fmt_len(xa, fmt) result(n)
+    real, dimension(:), intent(in) :: xa
+    character(len=*), intent(in) :: fmt
+  end function str_real_dp_array_fmt_len
+  pure function str_real_dp_fmt(x, fmt) result(s)
+    real, intent(in) :: x
+    character(len=*), intent(in) :: fmt
+    character(len=len(x, fmt)) :: s
+  end function str_real_dp_fmt
+  pure function checkFmt(fmt) result(good)
+    character(len=*), intent(in) :: fmt
+    logical :: good
+  end function checkFmt
+end module fox_m_fsys_format
Index: gcc/testsuite/gfortran.dg/pr85996.f90
===================================================================
--- gcc/testsuite/gfortran.dg/pr85996.f90	(nonexistent)
+++ gcc/testsuite/gfortran.dg/pr85996.f90	(working copy)
@@ -0,0 +1,69 @@
+! { dg-do compile }
+module strings
+
+   type string
+      integer :: len = 0, size = 0
+      character, pointer :: chars(:) => null()
+   end type string
+
+   interface length
+      module procedure len_s
+   end interface
+
+   interface char
+      module procedure s_to_c, s_to_slc  
+   end interface
+
+   interface uppercase
+      module procedure uppercase_c
+   end interface
+
+   interface replace
+      module procedure replace_ccs
+   end interface
+
+   contains
+
+      elemental function len_s(s)
+         type(string), intent(in) :: s
+         integer :: len_s
+      end function len_s
+
+      pure function s_to_c(s)
+         type(string),intent(in) :: s
+         character(length(s)) :: s_to_c
+      end function s_to_c
+
+      pure function s_to_slc(s,long)
+         type(string),intent(in) :: s
+         integer, intent(in) :: long
+         character(long) :: s_to_slc
+      end function s_to_slc
+
+      pure function lr_sc_s(s,start,ss) result(l)
+         type(string), intent(in) :: s
+         character(*), intent(in) :: ss
+         integer, intent(in)  :: start
+         integer :: l
+      end function lr_sc_s
+
+      pure function lr_ccc(s,tgt,ss,action) result(l)
+         character(*), intent(in) :: s,tgt,ss,action
+         integer :: l
+         select case(uppercase(action))
+         case default
+         end select
+      end function lr_ccc
+
+      function replace_ccs(s,tgt,ss) result(r)
+         character(*), intent(in)             :: s,tgt
+         type(string), intent(in)             :: ss
+         character(lr_ccc(s,tgt,char(ss),'first'))  :: r
+      end function replace_ccs
+
+      pure function uppercase_c(c)
+         character(*), intent(in) :: c
+         character(len(c)) :: uppercase_c
+      end function uppercase_c
+
+end module strings