From: Jerry DeLisle Date: Thu, 11 May 2017 20:40:49 +0000 (+0000) Subject: re PR fortran/78659 ([F03] Spurious "requires DTIO" reported against namelist statement) X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=628c06d6bc47c3a1487ecd41eb12d13a968d4480;p=gcc.git re PR fortran/78659 ([F03] Spurious "requires DTIO" reported against namelist statement) 2017-05-11 Jerry DeLisle PR fortran/78659 * io.c (dtio_procs_present): Add new function to check for DTIO procedures relative to I/O statement READ or WRITE. (gfc_resolve_dt): Add namelist checks using the new function. * resolve.c (dtio_procs_present): Remove function and related namelist checks. (resolve_fl_namelist): Add check specific to Fortran 95 restriction on namelist objects. * gfortran.dg/namelist_91.f90: New test. * gfortran.dg/namelist_92.f90: New test. * gfortran.dg/namelist_93.f90: New test. * gfortran.dg/namelist_94.f90: New test. From-SVN: r247930 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index eda814e74a4..e56a9b9b0d0 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,13 @@ +2017-05-11 Jerry DeLisle + + PR fortran/78659 + * io.c (dtio_procs_present): Add new function to check for DTIO + procedures relative to I/O statement READ or WRITE. + (gfc_resolve_dt): Add namelist checks using the new function. + * resolve.c (dtio_procs_present): Remove function and related + namelist checks. (resolve_fl_namelist): Add check specific to + Fortran 95 restriction on namelist objects. + 2017-05-11 Nathan Sidwell * trans-decl.c: Include dumpfile.h not tree-dump.h, diff --git a/gcc/fortran/io.c b/gcc/fortran/io.c index 7ab897daa44..b2fa741d03f 100644 --- a/gcc/fortran/io.c +++ b/gcc/fortran/io.c @@ -2966,6 +2966,30 @@ conflict: return MATCH_ERROR; } +/* Check for formatted read and write DTIO procedures. */ + +static bool +dtio_procs_present (gfc_symbol *sym, io_kind k) +{ + gfc_symbol *derived; + + if (sym && sym->ts.u.derived) + { + if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)) + derived = CLASS_DATA (sym)->ts.u.derived; + else if (sym->ts.type == BT_DERIVED) + derived = sym->ts.u.derived; + else + return false; + if ((k == M_WRITE || k == M_PRINT) && + (gfc_find_specific_dtio_proc (derived, true, true) != NULL)) + return true; + if ((k == M_READ) && + (gfc_find_specific_dtio_proc (derived, false, true) != NULL)) + return true; + } + return false; +} /* Traverse a namelist that is part of a READ statement to make sure that none of the variables in the namelist are INTENT(IN). Returns @@ -3244,7 +3268,7 @@ gfc_resolve_dt (gfc_dt *dt, locus *loc) /* If we are reading and have a namelist, check that all namelist symbols can appear in a variable definition context. */ - if (k == M_READ && dt->namelist) + if (dt->namelist) { gfc_namelist* n; for (n = dt->namelist->namelist; n; n = n->next) @@ -3252,17 +3276,50 @@ gfc_resolve_dt (gfc_dt *dt, locus *loc) gfc_expr* e; bool t; - e = gfc_get_variable_expr (gfc_find_sym_in_symtree (n->sym)); - t = gfc_check_vardef_context (e, false, false, false, NULL); - gfc_free_expr (e); + if (k == M_READ) + { + e = gfc_get_variable_expr (gfc_find_sym_in_symtree (n->sym)); + t = gfc_check_vardef_context (e, false, false, false, NULL); + gfc_free_expr (e); + + if (!t) + { + gfc_error ("NAMELIST %qs in READ statement at %L contains" + " the symbol %qs which may not appear in a" + " variable definition context", + dt->namelist->name, loc, n->sym->name); + return false; + } + } + + t = dtio_procs_present (n->sym, k); - if (!t) + if (n->sym->ts.type == BT_CLASS && !t) { - gfc_error ("NAMELIST %qs in READ statement at %L contains" - " the symbol %qs which may not appear in a" - " variable definition context", - dt->namelist->name, loc, n->sym->name); - return false; + gfc_error ("NAMELIST object %qs in namelist %qs at %L is " + "polymorphic and requires a defined input/output " + "procedure", n->sym->name, dt->namelist->name, loc); + return 1; + } + + if ((n->sym->ts.type == BT_DERIVED) + && (n->sym->ts.u.derived->attr.alloc_comp + || n->sym->ts.u.derived->attr.pointer_comp)) + { + if (!gfc_notify_std (GFC_STD_F2003, "NAMELIST object %qs in " + "namelist %qs at %L with ALLOCATABLE " + "or POINTER components", n->sym->name, + dt->namelist->name, loc)) + return 1; + + if (!t) + { + gfc_error ("NAMELIST object %qs in namelist %qs at %L has " + "ALLOCATABLE or POINTER components and thus requires " + "a defined input/output procedure", n->sym->name, + dt->namelist->name, loc); + return 1; + } } } } diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index df32a8a8539..d50ffdb826a 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -13846,31 +13846,11 @@ resolve_fl_derived (gfc_symbol *sym) } -/* Check for formatted read and write DTIO procedures. */ - -static bool -dtio_procs_present (gfc_symbol *sym) -{ - gfc_symbol *derived; - - if (sym->ts.type == BT_CLASS) - derived = CLASS_DATA (sym)->ts.u.derived; - else if (sym->ts.type == BT_DERIVED) - derived = sym->ts.u.derived; - else - return false; - - return gfc_find_specific_dtio_proc (derived, true, true) != NULL - && gfc_find_specific_dtio_proc (derived, false, true) != NULL; -} - - static bool resolve_fl_namelist (gfc_symbol *sym) { gfc_namelist *nl; gfc_symbol *nlsym; - bool dtio; for (nl = sym->namelist; nl; nl = nl->next) { @@ -13904,27 +13884,6 @@ resolve_fl_namelist (gfc_symbol *sym) sym->name, &sym->declared_at)) return false; - dtio = dtio_procs_present (nl->sym); - - if (nl->sym->ts.type == BT_CLASS && !dtio) - { - gfc_error ("NAMELIST object %qs in namelist %qs at %L is " - "polymorphic and requires a defined input/output " - "procedure", nl->sym->name, sym->name, &sym->declared_at); - return false; - } - - if (nl->sym->ts.type == BT_DERIVED - && (nl->sym->ts.u.derived->attr.alloc_comp - || nl->sym->ts.u.derived->attr.pointer_comp)) - { - if (!gfc_notify_std (GFC_STD_F2003, "NAMELIST object %qs in " - "namelist %qs at %L with ALLOCATABLE " - "or POINTER components", nl->sym->name, - sym->name, &sym->declared_at)) - return false; - return true; - } } /* Reject PRIVATE objects in a PUBLIC namelist. */ @@ -13942,10 +13901,17 @@ resolve_fl_namelist (gfc_symbol *sym) return false; } - /* If the derived type has specific DTIO procedures for both read and - write then namelist objects with private components are OK. */ - if (dtio_procs_present (nl->sym)) - continue; + if (nl->sym->ts.type == BT_DERIVED + && (nl->sym->ts.u.derived->attr.alloc_comp + || nl->sym->ts.u.derived->attr.pointer_comp)) + { + if (!gfc_notify_std (GFC_STD_F2003, "NAMELIST object %qs in " + "namelist %qs at %L with ALLOCATABLE " + "or POINTER components", nl->sym->name, + sym->name, &sym->declared_at)) + return false; + return true; + } /* Types with private components that came here by USE-association. */ if (nl->sym->ts.type == BT_DERIVED diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 7fbf899d65e..1d522ba8677 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,11 @@ +2017-05-11 Jerry DeLisle + + PR fortran/78659 + * gfortran.dg/namelist_91.f90: New test. + * gfortran.dg/namelist_92.f90: New test. + * gfortran.dg/namelist_93.f90: New test. + * gfortran.dg/namelist_94.f90: New test. + 2017-05-11 Bill Schmidt PR target/80695 diff --git a/gcc/testsuite/gfortran.dg/namelist_91.f90 b/gcc/testsuite/gfortran.dg/namelist_91.f90 new file mode 100644 index 00000000000..672e3f61d6e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/namelist_91.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } +! PR78659 Spurious "requires DTIO" reported against namelist statement +program p + type t + integer :: k + end type + class(t), allocatable :: x + namelist /nml/ x +end diff --git a/gcc/testsuite/gfortran.dg/namelist_92.f90 b/gcc/testsuite/gfortran.dg/namelist_92.f90 new file mode 100644 index 00000000000..fc678caacb7 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/namelist_92.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! PR78659 Spurious "requires DTIO" reported against namelist statement +MODULE ma + IMPLICIT NONE + TYPE :: ta + INTEGER, allocatable :: array(:) + END TYPE ta +END MODULE ma + +PROGRAM p + USE ma + type(ta):: x + NAMELIST /nml/ x + WRITE (*, nml) ! { dg-error "has ALLOCATABLE or POINTER components and thus requires a defined input/output" } + READ (*, nml) ! { dg-error "has ALLOCATABLE or POINTER components and thus requires a defined input/output" } +END PROGRAM p diff --git a/gcc/testsuite/gfortran.dg/namelist_93.f90 b/gcc/testsuite/gfortran.dg/namelist_93.f90 new file mode 100644 index 00000000000..f4e26bc8af3 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/namelist_93.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! PR78659 Spurious "requires DTIO" reported against namelist statement +MODULE ma + IMPLICIT NONE + TYPE :: ta + INTEGER, allocatable :: array(:) + END TYPE ta +END MODULE ma + +PROGRAM p + USE ma + class(ta), allocatable :: x + NAMELIST /nml/ x + WRITE (*, nml)! { dg-error "is polymorphic and requires a defined input/output procedure" } + READ (*, nml) ! { dg-error "is polymorphic and requires a defined input/output procedure" } +END PROGRAM p diff --git a/gcc/testsuite/gfortran.dg/namelist_94.f90 b/gcc/testsuite/gfortran.dg/namelist_94.f90 new file mode 100644 index 00000000000..d0344f76d4d --- /dev/null +++ b/gcc/testsuite/gfortran.dg/namelist_94.f90 @@ -0,0 +1,32 @@ +! { dg-do compile } +! PR78659 Spurious "requires DTIO" reported against namelist statement +MODULE m + IMPLICIT NONE + TYPE :: t + CHARACTER :: c + CONTAINS + PROCEDURE :: write_formatted + GENERIC :: WRITE(FORMATTED) => write_formatted + END TYPE +CONTAINS + SUBROUTINE write_formatted(dtv, unit, iotype, v_list, iostat, iomsg) + CLASS(t), INTENT(IN) :: dtv + INTEGER, INTENT(IN) :: unit + CHARACTER(*), INTENT(IN) :: iotype + INTEGER, INTENT(IN) :: v_list(:) + INTEGER, INTENT(OUT) :: iostat + CHARACTER(*), INTENT(INOUT) :: iomsg + WRITE (unit, "(A)", IOSTAT=iostat, IOMSG=iomsg) dtv%c + print *, "what" + END SUBROUTINE +END MODULE + +PROGRAM p + USE m + IMPLICIT NONE + class(t), allocatable :: x + NAMELIST /nml/ x + x = t('a') + WRITE (*, nml) + READ (*, nml) ! { dg-error "is polymorphic and requires a defined input/output procedure" } +END