re PR fortran/85138 (ICE with generic function)

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

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

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

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

From-SVN: r261362

gcc/fortran/ChangeLog

 2018-06-09  Steven G. Kargl  <kargl@gcc.gnu.org>
 
+	PR fortran/85138
+	PR fortran/85996
+	PR fortran/86051
+	* decl.c (gfc_match_char_spec): Use private namespace in attempt to
+	reduce a charlen to a constant.
+
+2018-06-09  Steven G. Kargl  <kargl@gcc.gnu.org>
+
 	PR fortran/78278
 	* data.c (gfc_assign_data_value): Re-arrange code to allow for
 	an error for double initialization of CHARACTER entities.

gcc/fortran/decl.c

@@ -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;

gcc/testsuite/ChangeLog

 2018-06-09  Steven G. Kargl  <kargl@gcc.gnu.org>
 
+	PR fortran/85138
+	PR fortran/85996
+	PR fortran/86051
+	* gfortran.dg/pr85138_1.f90: New test.
+	* gfortran.dg/pr85138_2.f90: Ditto.
+	* gfortran.dg/pr85996.f90: Ditto.
+
+2018-06-09  Steven G. Kargl  <kargl@gcc.gnu.org>
+
 	PR fortran/78278
 	* gfortran.dg/data_bounds_1.f90: Add -std=gnu option.
 	* gfortran.dg/data_char_1.f90: Ditto.

gcc/testsuite/gfortran.dg/pr85138_1.f90

+! { 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

gcc/testsuite/gfortran.dg/pr85138_2.f90

+! { 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

gcc/testsuite/gfortran.dg/pr85996.f90

+! { 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