+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
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)
}
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;
+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
--- /dev/null
+! { 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
--- /dev/null
+! { 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
--- /dev/null
+! { 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
projects / gcc.git / commitdiff