From: Tobias Burnus Date: Thu, 2 Apr 2020 16:27:09 +0000 (+0200) Subject: [Fortran] Resolve formal args before checking DTIO X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=3ab216a4d2f14be1f37350260142c91fabce834a;p=gcc.git [Fortran] Resolve formal args before checking DTIO * gfortran.h (gfc_resolve_formal_arglist): Add prototype. * interface.c (check_dtio_interface1): Call it. * resolve.c (gfc_resolve_formal_arglist): Renamed from resolve_formal_arglist, removed static. (find_arglists, resolve_types): Update calls. * gfortran.dg/dtio_35.f90: New. --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index c4ca48f6183..8c4ace7cdfa 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,11 @@ +2020-04-02 Tobias Burnus + + * gfortran.h (gfc_resolve_formal_arglist): Add prototype. + * interface.c (check_dtio_interface1): Call it. + * resolve.c (gfc_resolve_formal_arglist): Renamed from + resolve_formal_arglist, removed static. + (find_arglists, resolve_types): Update calls. + 2020-04-02 Tobias Burnus PR fortran/93522 diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 96037629f5f..88e4d9236f3 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -3369,6 +3369,7 @@ bool gfc_resolve_expr (gfc_expr *); void gfc_resolve (gfc_namespace *); void gfc_resolve_code (gfc_code *, gfc_namespace *); void gfc_resolve_blocks (gfc_code *, gfc_namespace *); +void gfc_resolve_formal_arglist (gfc_symbol *); int gfc_impure_variable (gfc_symbol *); int gfc_pure (gfc_symbol *); int gfc_implicit_pure (gfc_symbol *); diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index 14d03c27759..75a50c999b7 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -5007,6 +5007,9 @@ check_dtio_interface1 (gfc_symbol *derived, gfc_symtree *tb_io_st, gfc_error ("DTIO procedure %qs at %L must be a subroutine", dtio_sub->name, &dtio_sub->declared_at); + if (!dtio_sub->resolved) + gfc_resolve_formal_arglist (dtio_sub); + arg_num = 0; for (formal = dtio_sub->formal; formal; formal = formal->next) arg_num++; @@ -5025,7 +5028,6 @@ check_dtio_interface1 (gfc_symbol *derived, gfc_symtree *tb_io_st, return; } - /* Now go through the formal arglist. */ arg_num = 1; for (formal = dtio_sub->formal; formal; formal = formal->next, arg_num++) diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 79b0d724565..97de6ddce84 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -264,8 +264,8 @@ resolve_procedure_interface (gfc_symbol *sym) Since a dummy argument cannot be a non-dummy procedure, the only resort left for untyped names are the IMPLICIT types. */ -static void -resolve_formal_arglist (gfc_symbol *proc) +void +gfc_resolve_formal_arglist (gfc_symbol *proc) { gfc_formal_arglist *f; gfc_symbol *sym; @@ -319,7 +319,7 @@ resolve_formal_arglist (gfc_symbol *proc) } if (sym->attr.if_source != IFSRC_UNKNOWN) - resolve_formal_arglist (sym); + gfc_resolve_formal_arglist (sym); if (sym->attr.subroutine || sym->attr.external) { @@ -547,7 +547,7 @@ find_arglists (gfc_symbol *sym) || gfc_fl_struct (sym->attr.flavor) || sym->attr.intrinsic) return; - resolve_formal_arglist (sym); + gfc_resolve_formal_arglist (sym); } @@ -17159,7 +17159,7 @@ resolve_types (gfc_namespace *ns) if (ns->proc_name && ns->proc_name->attr.flavor == FL_PROCEDURE && ns->proc_name->attr.if_source == IFSRC_IFBODY) - resolve_formal_arglist (ns->proc_name); + gfc_resolve_formal_arglist (ns->proc_name); gfc_traverse_ns (ns, resolve_bind_c_derived_types); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index c3803b69bdb..c28b0018c37 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,7 @@ +2020-04-02 Tobias Burnus + + * gfortran.dg/dtio_35.f90: New. + 2020-04-02 Richard Biener PR c/94392 diff --git a/gcc/testsuite/gfortran.dg/dtio_35.f90 b/gcc/testsuite/gfortran.dg/dtio_35.f90 new file mode 100644 index 00000000000..d7211df87ac --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dtio_35.f90 @@ -0,0 +1,50 @@ +! { dg-compile } +! +! Reported by Vladimir Nikishkin +! at https://stackoverflow.com/questions/60972134/whats-wrong-with-the-following-fortran-code-gfortran-dtio-dummy-argument-at# +! + +module scheme + + type, abstract :: scheme_object + contains + procedure, pass :: generic_scheme_print => print_scheme_object + generic, public :: write (formatted) => generic_scheme_print + end type scheme_object + + abstract interface + subroutine packageable_procedure( ) + import scheme_object + end subroutine packageable_procedure + end interface +contains + + subroutine print_scheme_object(this, unit, iotype, v_list, iostat, iomsg) + class(scheme_object), intent(in) :: this + integer, intent(in) :: unit + character(*), intent(in) :: iotype + integer, intent(in) :: v_list (:) + integer, intent(out) :: iostat + character(*), intent(inout) :: iomsg + iostat = 1 + end subroutine print_scheme_object + + subroutine packaged_cons( ) + end subroutine packaged_cons + + function make_primitive_procedure_object( proc1 ) result( retval ) + class(scheme_object), pointer :: retval + procedure(packageable_procedure), pointer :: proc1 + end function make_primitive_procedure_object + + subroutine ll_setup_global_environment() + procedure(packageable_procedure), pointer :: proc1 + class(scheme_object), pointer :: proc_obj_to_pack + proc1 => packaged_cons + proc_obj_to_pack => make_primitive_procedure_object( proc1 ) + end subroutine ll_setup_global_environment + +end module scheme + +program main +end program main