[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 c4ca48f6183d1b97a8b7d0921b3faa350a27f24a..8c4ace7cdfabd8b5ff244ccc3297490cb8d1d5a9 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,11 @@
+2020-04-02  Tobias Burnus  <tobias@codesourcery.com>
+
+       * 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  <tobias@codesourcery.com>
 
        PR fortran/93522

diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 96037629f5f07ecc6334304c2981e71c188cfebb..88e4d9236f3c2430d6adbfe1ab9d6453e0e6f6d9 100644 (file)
--- 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 14d03c27759d2b86858d23f4d41859b5b8a9a48d..75a50c999b7d76a813110cdba8e4d81a18e2f4cc 100644 (file)
--- 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 79b0d72456514fbae8eea332becad262c2c879a0..97de6ddce84450afdc194e3f2f4e03ea0439a9fd 100644 (file)
--- 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 c3803b69bdb3459722694b99ac93ec8a0e6769c1..c28b0018c37bc79f8a19d2e30f7f30cc1a2ccd27 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,7 @@
+2020-04-02  Tobias Burnus  <tobias@codesourcery.com>
+
+       * gfortran.dg/dtio_35.f90: New.
+
 2020-04-02  Richard Biener  <rguenther@suse.de>
 
        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 (file)
index 0000000..d7211df
--- /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