[Fortran] Resolve formal args before checking DTIO (was: Re: [PATCH] deferred-shape vs assumed-shape)

Message ID ec568677-ee4b-2170-c082-0638fb19ec84@codesourcery.com
State New
Headers show
Series
  • [Fortran] Resolve formal args before checking DTIO (was: Re: [PATCH] deferred-shape vs assumed-shape)
Related show

Commit Message

Tobias Burnus April 2, 2020, 9:34 a.m.
Hi Steve,

I think your patch is fine - however, I think calling the normal
resolve_formal_arglist looks a bit cleaner to me (as done in the
attached patch). — Additionally, I added the testcase.

Side effect of my variant is that gfc_check_dtio_interfaces will
be called again a bit later again. — In this sense, Steve's patch,
which replicates a chunk of resolve_formal_arglist, is better.

Thoughts by anyone?

OK?

Tobias

PS: I was thinking of calling resolve_symbol instead
but this one does not resolve the formal arguments
(via "gfc_resolve (sym->formal_ns)") as sym->attr.contained.

On 4/1/20 10:04 PM, Steve Kargl via Fortran wrote:

> See

> https://stackoverflow.com/questions/60972134/whats-wrong-with-the-following-fortran-code-gfortran-dtio-dummy-argument-at

>

> Is A(:) a deferred-shape array or an assumed-shape array?  The

> answer of course depends on context.

>

> This patch fixes the issue found at the above URL.

>

> Index: gcc/fortran/interface.c

> ===================================================================

> --- gcc/fortran/interface.c   (revision 280157)

> +++ gcc/fortran/interface.c   (working copy)

> @@ -4916,10 +4916,15 @@ check_dtio_arg_TKR_intent (gfc_symbol *fsym, bool type

>         || ((type != BT_CLASS) && fsym->attr.dimension)))

>       gfc_error ("DTIO dummy argument at %L must be a scalar",

>              &fsym->declared_at);

> -  else if (rank == 1

> -        && (fsym->as == NULL || fsym->as->type != AS_ASSUMED_SHAPE))

> -    gfc_error ("DTIO dummy argument at %L must be an "

> -            "ASSUMED SHAPE ARRAY", &fsym->declared_at);

> +  else if (rank == 1)

> +    {

> +      if (fsym->as == NULL

> +       || !(fsym->as->type == AS_ASSUMED_SHAPE

> +             || (fsym->as->type == AS_DEFERRED && fsym->attr.dummy

> +                 && !fsym->attr.allocatable && !fsym->attr.pointer)))

> +     gfc_error ("DTIO dummy argument at %L must be an "

> +                "ASSUMED-SHAPE ARRAY", &fsym->declared_at);

> +    }

>

>     if (type == BT_CHARACTER && fsym->ts.u.cl->length != NULL)

>       gfc_error ("DTIO character argument at %L must have assumed length",

>

-----------------
Mentor Graphics (Deutschland) GmbH, Arnulfstraße 201, 80634 München / Germany
Registergericht München HRB 106955, Geschäftsführer: Thomas Heurung, Alexander Walter

Comments

Christophe Lyon via Gcc-patches April 2, 2020, 3:05 p.m. | #1
This one is a little bit wierd for me.  It seems AS_DEFERRED
is overloaded and things get fixed up later.  In array.c
one finds match_array_element_spec(), which set AS_DEFERRED
if the matchers sees (:) regardless of how the array is used.
Then in gfc_set_array_spec(), the array spec is attached to
the symbol in this block

  if (sym->as == NULL)
    {
      sym->as = as;
      return true;
    }

We can check sym->attr to determine if this is a nonallocatable
nonpointer dummy argument and reset the type to AS_ASSUMED_SHAPE;
or at least I though tI could.  This leads to a very, very, long
list of regressions.  So, I went with the direct hammer.

Your patch is fine with me as it likely resolves (fixes up?)
the symbol for future references.

-- 
steve

On Thu, Apr 02, 2020 at 11:34:16AM +0200, Tobias Burnus wrote:
> Hi Steve,

> 

> I think your patch is fine - however, I think calling the normal

> resolve_formal_arglist looks a bit cleaner to me (as done in the

> attached patch). — Additionally, I added the testcase.

> 

> Side effect of my variant is that gfc_check_dtio_interfaces will

> be called again a bit later again. — In this sense, Steve's patch,

> which replicates a chunk of resolve_formal_arglist, is better.

> 

> Thoughts by anyone?

> 

> OK?

> 

> Tobias

> 

> PS: I was thinking of calling resolve_symbol instead

> but this one does not resolve the formal arguments

> (via "gfc_resolve (sym->formal_ns)") as sym->attr.contained.

> 

> On 4/1/20 10:04 PM, Steve Kargl via Fortran wrote:

> 

> > See

> > https://stackoverflow.com/questions/60972134/whats-wrong-with-the-following-fortran-code-gfortran-dtio-dummy-argument-at

> > 

> > Is A(:) a deferred-shape array or an assumed-shape array?  The

> > answer of course depends on context.

> > 

> > This patch fixes the issue found at the above URL.

> > 

> > Index: gcc/fortran/interface.c

> > ===================================================================

> > --- gcc/fortran/interface.c   (revision 280157)

> > +++ gcc/fortran/interface.c   (working copy)

> > @@ -4916,10 +4916,15 @@ check_dtio_arg_TKR_intent (gfc_symbol *fsym, bool type

> >         || ((type != BT_CLASS) && fsym->attr.dimension)))

> >       gfc_error ("DTIO dummy argument at %L must be a scalar",

> >              &fsym->declared_at);

> > -  else if (rank == 1

> > -        && (fsym->as == NULL || fsym->as->type != AS_ASSUMED_SHAPE))

> > -    gfc_error ("DTIO dummy argument at %L must be an "

> > -            "ASSUMED SHAPE ARRAY", &fsym->declared_at);

> > +  else if (rank == 1)

> > +    {

> > +      if (fsym->as == NULL

> > +       || !(fsym->as->type == AS_ASSUMED_SHAPE

> > +             || (fsym->as->type == AS_DEFERRED && fsym->attr.dummy

> > +                 && !fsym->attr.allocatable && !fsym->attr.pointer)))

> > +     gfc_error ("DTIO dummy argument at %L must be an "

> > +                "ASSUMED-SHAPE ARRAY", &fsym->declared_at);

> > +    }

> > 

> >     if (type == BT_CHARACTER && fsym->ts.u.cl->length != NULL)

> >       gfc_error ("DTIO character argument at %L must have assumed length",

> > 

> -----------------

> Mentor Graphics (Deutschland) GmbH, Arnulfstraße 201, 80634 München / Germany

> Registergericht München HRB 106955, Geschäftsführer: Thomas Heurung, Alexander Walter


> [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.

> 

>  gcc/fortran/gfortran.h                |  1 +

>  gcc/fortran/interface.c               |  4 ++-

>  gcc/fortran/resolve.c                 | 10 +++----

>  gcc/testsuite/gfortran.dg/dtio_35.f90 | 50 +++++++++++++++++++++++++++++++++++

>  4 files changed, 59 insertions(+), 6 deletions(-)

> 

> 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/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



-- 
Steve
20170425 https://www.youtube.com/watch?v=VWUpyCsUKR4
20161221 https://www.youtube.com/watch?v=IbCHE-hONow

Patch

[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.

 gcc/fortran/gfortran.h                |  1 +
 gcc/fortran/interface.c               |  4 ++-
 gcc/fortran/resolve.c                 | 10 +++----
 gcc/testsuite/gfortran.dg/dtio_35.f90 | 50 +++++++++++++++++++++++++++++++++++
 4 files changed, 59 insertions(+), 6 deletions(-)

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/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