From: Steven G. Kargl Date: Sat, 9 Jun 2018 15:47:40 +0000 (+0000) Subject: re PR fortran/85138 (ICE with generic function) X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=3cf89a7b992d483e80b3b5960f6f4012fae95045;p=gcc.git re PR fortran/85138 (ICE with generic function) 2018-06-09 Steven G. Kargl 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 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 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 52fdc46a887..1868780c921 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,11 @@ +2018-06-09 Steven G. Kargl + + 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 PR fortran/78278 diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index df21ce0943b..c36a16ba5ac 100644 --- a/gcc/fortran/decl.c +++ b/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; diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 8e90b1f4723..135213b0f48 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,12 @@ +2018-06-09 Steven G. Kargl + + 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 PR fortran/78278 diff --git a/gcc/testsuite/gfortran.dg/pr85138_1.f90 b/gcc/testsuite/gfortran.dg/pr85138_1.f90 new file mode 100644 index 00000000000..a64d9ce9329 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr85138_1.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/pr85138_2.f90 b/gcc/testsuite/gfortran.dg/pr85138_2.f90 new file mode 100644 index 00000000000..942cc6684d8 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr85138_2.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/pr85996.f90 b/gcc/testsuite/gfortran.dg/pr85996.f90 new file mode 100644 index 00000000000..e594d6771c8 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr85996.f90 @@ -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