From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: from esa4.mentor.iphmx.com (esa4.mentor.iphmx.com [68.232.137.252]) by sourceware.org (Postfix) with ESMTPS id 1C5C1385F02A; Thu, 2 Apr 2020 09:34:29 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.3.2 sourceware.org 1C5C1385F02A Authentication-Results: sourceware.org; dmarc=none (p=none dis=none) header.from=codesourcery.com Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=Tobias_Burnus@mentor.com IronPort-SDR: r0FOF+i6RIT6+fxmkaQJFseaNbaSJuL15VLLgN1DIHsyUHW1/BrfZFRDHee1Aa/E/clGZirSU5 MkJshiQNtEHjyBg/nr0EDkUubwJbPA4VTJAraFlkDeD9o+Lok5KoRVQaXjDzXd4MoORmW8IoqV MHPzLT8acz1mj+4xgKaUawxV7WO9QSXywZpljjB2546FVuOVBU/eLP1vIfykf0Cc13sdzYpu7L uXIRamrTs2D7Pr7LGmuvtDONHYFCxuTfsDuMicHSYFVX0DFq64/1S5as74be126hjf+HluxiBY JiU= X-IronPort-AV: E=Sophos;i="5.72,335,1580803200"; d="diff'?scan'208";a="47415701" Received: from orw-gwy-02-in.mentorg.com ([192.94.38.167]) by esa4.mentor.iphmx.com with ESMTP; 02 Apr 2020 01:34:27 -0800 IronPort-SDR: LiWqhoqxsv2xoPxhRHivuwz1kYDekmR/QrDFjEqtLUQnbWd8J7xCIPbYNUp5gfo1C8FcSegB6c n1eH9gguTQy234rou6lHTlcImUGhmfYVaCiegLuBdyDFQAH4mb68+9Ea9MqKkAHJfpz0YqJJLE +ZFmhShE9yCEEUU5o1BEt1+gD7gJSeRo6nOun9gjBZHwFX4+DsQBseW3WmhZrrF/5kHMwjgz+k AO+7pA6LXSaZjwRrZObzZsi+rS5IGO+OCssREg9deEwKWwdl8CKVS8XmAWKgQTFJC1klGs5qih ZD0= Subject: [Patch][Fortran] Resolve formal args before checking DTIO (was: Re: [PATCH] deferred-shape vs assumed-shape) To: , , References: <20200401200443.GA55208@troutmask.apl.washington.edu> From: Tobias Burnus Message-ID: Date: Thu, 2 Apr 2020 11:34:16 +0200 User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:68.0) Gecko/20100101 Thunderbird/68.6.0 MIME-Version: 1.0 In-Reply-To: <20200401200443.GA55208@troutmask.apl.washington.edu> Content-Type: multipart/mixed; boundary="------------25659A09E3C2A9E68E2BF45C" Content-Language: en-US X-Originating-IP: [137.202.0.90] X-ClientProxiedBy: SVR-IES-MBX-03.mgc.mentorg.com (139.181.222.3) To SVR-IES-MBX-03.mgc.mentorg.com (139.181.222.3) X-Spam-Status: No, score=-25.9 required=5.0 tests=BAYES_00, GIT_PATCH_0, GIT_PATCH_1, GIT_PATCH_2, GIT_PATCH_3, HEADER_FROM_DIFFERENT_DOMAINS, KAM_DMARC_STATUS, SPF_HELO_NONE, SPF_PASS, TXREP autolearn=ham autolearn_force=no version=3.4.2 X-Spam-Checker-Version: SpamAssassin 3.4.2 (2018-09-13) on server2.sourceware.org X-BeenThere: gcc-patches@gcc.gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , X-List-Received-Date: Thu, 02 Apr 2020 09:34:31 -0000 --------------25659A09E3C2A9E68E2BF45C Content-Type: text/plain; charset="utf-8"; format=flowed Content-Transfer-Encoding: quoted-printable 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). =E2=80=94 Additionally, I added the testcase. Side effect of my variant is that gfc_check_dtio_interfaces will be called again a bit later again. =E2=80=94 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-followi= ng-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 > =3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D= =3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D= =3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D > --- 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 !=3D BT_CLASS) && fsym->attr.dimension))) > gfc_error ("DTIO dummy argument at %L must be a scalar", > &fsym->declared_at); > - else if (rank =3D=3D 1 > - && (fsym->as =3D=3D NULL || fsym->as->type !=3D AS_ASSUMED_SHAPE= )) > - gfc_error ("DTIO dummy argument at %L must be an " > - "ASSUMED SHAPE ARRAY", &fsym->declared_at); > + else if (rank =3D=3D 1) > + { > + if (fsym->as =3D=3D NULL > + || !(fsym->as->type =3D=3D AS_ASSUMED_SHAPE > + || (fsym->as->type =3D=3D 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 =3D=3D BT_CHARACTER && fsym->ts.u.cl->length !=3D NULL) > gfc_error ("DTIO character argument at %L must have assumed length"= , > ----------------- Mentor Graphics (Deutschland) GmbH, Arnulfstra=C3=9Fe 201, 80634 M=C3=BCnch= en / Germany Registergericht M=C3=BCnchen HRB 106955, Gesch=C3=A4ftsf=C3=BChrer: Thomas = Heurung, Alexander Walter --------------25659A09E3C2A9E68E2BF45C Content-Type: text/x-patch; charset="UTF-8"; name="dtio.diff" Content-Transfer-Encoding: 7bit Content-Disposition: attachment; filename="dtio.diff" [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 --------------25659A09E3C2A9E68E2BF45C--