+2017-05-11 Jerry DeLisle <jvdelisle@gcc.gnu.org>
+
+ 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 <nathan@acm.org>
* trans-decl.c: Include dumpfile.h not tree-dump.h,
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
/* 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)
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;
+ }
}
}
}
}
-/* 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)
{
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. */
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
+2017-05-11 Jerry DeLisle <jvdelisle@gcc.gnu.org>
+
+ 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 <wschmidt@linux.vnet.ibm.com>
PR target/80695
--- /dev/null
+! { 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
--- /dev/null
+! { 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
--- /dev/null
+! { 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
--- /dev/null
+! { 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
projects / gcc.git / commitdiff