backport: re PR fortran/78659 ([F03] Spurious "requires DTIO" reported against namelist statement)
2017-05-17 Jerry DeLisle <jvdelisle@gcc.gnu.org> Backport from trunk 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: r248166
This commit is contained in:
Jerry DeLisle
parent
2c85805fa9
commit
d96f3d3658
|
|
@ -1,3 +1,14 @@
|
|||
2017-05-17 Jerry DeLisle <jvdelisle@gcc.gnu.org>
|
||||
|
||||
Backport from trunk
|
||||
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-15 Steven G. Kargl <kargl@gcc.gnu.org>
|
||||
|
||||
Backport from trunk
|
||||
|
|
|
|||
|
|
@ -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 (!t)
|
||||
if (k == M_READ)
|
||||
{
|
||||
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;
|
||||
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 (n->sym->ts.type == BT_CLASS && !t)
|
||||
{
|
||||
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;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
|
|
|||
|
|
@ -13849,31 +13849,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)
|
||||
{
|
||||
|
|
@ -13907,27 +13887,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. */
|
||||
|
|
@ -13945,10 +13904,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
|
||||
|
|
|
|||
|
|
@ -1,3 +1,12 @@
|
|||
2017-05-17 Jerry DeLisle <jvdelisle@gcc.gnu.org>
|
||||
|
||||
Backport from trunk
|
||||
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-15 Steven G. Kargl <kargl@gcc.gnu.org>
|
||||
|
||||
PR fortran/80752
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
Loading…
Reference in New Issue