FreeChainXenon/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

re PR fortran/78661 ([OOP] Namelist output missing object designator under DTIO)

Browse source 
2017-03-28  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/78661
	* trans-io.c (transfer_namelist_element): Perform a polymorphic call
	to a DTIO procedure if necessary.

2017-03-28  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/78661
	* gfortran.dg/dtio_25.f90: Modified test case.
	* gfortran.dg/dtio_27.f90: New test case.

2017-03-28  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/78661
	* io/write.c (nml_write_obj): Build a class container only if necessary.

From-SVN: r246546
This commit is contained in:
Janus Weil 2017-03-28 19:01:05 +02:00
parent 189d9d3a8f
commit cf47453061
7 changed files with 164 additions and 27 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

6
gcc/fortran/ChangeLog
View file

@ -1,3 +1,9 @@
2017-03-28 Janus Weil <janus@gcc.gnu.org>
PR fortran/78661
* trans-io.c (transfer_namelist_element): Perform a polymorphic call
to a DTIO procedure if necessary.
2017-03-25 Paul Thomas <pault@gcc.gnu.org>
PR fortran/80156

59
gcc/fortran/trans-io.c
View file

@ -1701,22 +1701,53 @@ transfer_namelist_element (stmtblock_t * block, const char * var_name,
/* Check if the derived type has a specific DTIO for the mode.
Note that although namelist io is forbidden to have a format
list, the specific subroutine is of the formatted kind. */
if (ts->type == BT_DERIVED)
if (ts->type == BT_DERIVED || ts->type == BT_CLASS)
{
gfc_symbol *dtio_sub = NULL;
gfc_symbol *vtab;
dtio_sub = gfc_find_specific_dtio_proc (ts->u.derived,
last_dt == WRITE,
true);
if (dtio_sub != NULL)
gfc_symbol *derived;
if (ts->type==BT_CLASS)
derived = ts->u.derived->components->ts.u.derived;
else
derived = ts->u.derived;
gfc_symtree *tb_io_st = gfc_find_typebound_dtio_proc (derived,
last_dt == WRITE, true);
if (ts->type == BT_CLASS && tb_io_st)
{
dtio_proc = gfc_get_symbol_decl (dtio_sub);
dtio_proc = gfc_build_addr_expr (NULL, dtio_proc);
vtab = gfc_find_derived_vtab (ts->u.derived);
vtable = vtab->backend_decl;
if (vtable == NULL_TREE)
vtable = gfc_get_symbol_decl (vtab);
vtable = gfc_build_addr_expr (pvoid_type_node, vtable);
// polymorphic DTIO call (based on the dynamic type)
gfc_se se;
gfc_symtree *st = gfc_find_symtree (sym->ns->sym_root, sym->name);
// build vtable expr
gfc_expr *expr = gfc_get_variable_expr (st);
gfc_add_vptr_component (expr);
gfc_init_se (&se, NULL);
se.want_pointer = 1;
gfc_conv_expr (&se, expr);
vtable = se.expr;
// build dtio expr
gfc_add_component_ref (expr,
tb_io_st->n.tb->u.generic->specific_st->name);
gfc_init_se (&se, NULL);
se.want_pointer = 1;
gfc_conv_expr (&se, expr);
gfc_free_expr (expr);
dtio_proc = se.expr;
}
else
{
// non-polymorphic DTIO call (based on the declared type)
gfc_symbol *dtio_sub = gfc_find_specific_dtio_proc (derived,
last_dt == WRITE, true);
if (dtio_sub != NULL)
{
dtio_proc = gfc_get_symbol_decl (dtio_sub);
dtio_proc = gfc_build_addr_expr (NULL, dtio_proc);
gfc_symbol *vtab = gfc_find_derived_vtab (derived);
vtable = vtab->backend_decl;
if (vtable == NULL_TREE)
vtable = gfc_get_symbol_decl (vtab);
vtable = gfc_build_addr_expr (pvoid_type_node, vtable);
}
}
}

6
gcc/testsuite/ChangeLog
View file

@ -1,3 +1,9 @@
2017-03-28 Janus Weil <janus@gcc.gnu.org>
PR fortran/78661
* gfortran.dg/dtio_25.f90: Modified test case.
* gfortran.dg/dtio_27.f90: New test case.
2017-03-28 Uros Bizjak <ubizjak@gmail.com>
PR target/53383

22
gcc/testsuite/gfortran.dg/dtio_25.f90
View file

@ -8,6 +8,8 @@ module m
contains
procedure :: write_formatted
generic :: write(formatted) => write_formatted
procedure :: read_formatted
generic :: read(formatted) => read_formatted
end type
contains
subroutine write_formatted(dtv, unit, iotype, v_list, iostat, iomsg)
@ -18,11 +20,26 @@ contains
integer, intent(out) :: iostat
character(*), intent(inout) :: iomsg
if (iotype.eq."NAMELIST") then
write (unit, '(a,a,a,a,i5)') 'x%c="',dtv%c,'",','x%k=', dtv%k
write (unit, '(a3,a1,i3)') dtv%c,',', dtv%k
else
write (unit,*) dtv%c, dtv%k
end if
end subroutine
subroutine read_formatted(dtv, unit, iotype, v_list, iostat, iomsg)
class(t), intent(inout) :: dtv
integer, intent(in) :: unit
character(*), intent(in) :: iotype
integer, intent(in) :: v_list(:)
integer, intent(out) :: iostat
character(*), intent(inout) :: iomsg
character :: comma
if (iotype.eq."NAMELIST") then
read (unit, '(a4,a1,i3)') dtv%c, comma, dtv%k ! FIXME: need a4 here, with a3 above
else
read (unit,*) dtv%c, comma, dtv%k
end if
if (comma /= ',') call abort()
end subroutine
end module
program p
@ -33,9 +50,8 @@ program p
namelist /nml/ x
x = t('a', 5)
write (buffer, nml)
if (buffer.ne.'&NML x%c="a",x%k= 5 /') call abort
if (buffer.ne.'&NML X= a, 5 /') call abort
x = t('x', 0)
read (buffer, nml)
if (x%c.ne.'a'.or. x%k.ne.5) call abort
end

65
gcc/testsuite/gfortran.dg/dtio_27.f90 Normal file
View file

@ -0,0 +1,65 @@
! { dg-do run }
!
! PR 78661: [OOP] Namelist output missing object designator under DTIO
!
! Contributed by Ian Harvey <ian_harvey@bigpond.com>
MODULE m
IMPLICIT NONE
TYPE :: t
CHARACTER :: c
CONTAINS
PROCEDURE :: write_formatted
GENERIC :: WRITE(FORMATTED) => write_formatted
PROCEDURE :: read_formatted
GENERIC :: READ(FORMATTED) => read_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
END SUBROUTINE
SUBROUTINE read_formatted(dtv, unit, iotype, v_list, iostat, iomsg)
CLASS(t), INTENT(INOUT) :: dtv
INTEGER, INTENT(IN) :: unit
CHARACTER(*), INTENT(IN) :: iotype
INTEGER, INTENT(IN) :: v_list(:)
INTEGER, INTENT(OUT) :: iostat
CHARACTER(*), INTENT(INOUT) :: iomsg
READ (unit, "(A)", IOSTAT=iostat, IOMSG=iomsg) dtv%c
END SUBROUTINE
END MODULE
PROGRAM p
USE m
IMPLICIT NONE
character(len=4), dimension(3) :: buffer
call test_type
call test_class
contains
subroutine test_type
type(t) :: x
namelist /n1/ x
x = t('a')
write (buffer, n1)
if (buffer(2) /= " X=a") call abort()
end subroutine
subroutine test_class
class(t), allocatable :: y
namelist /n2/ y
y = t('b')
write (buffer, n2)
if (buffer(2) /= " Y=b") call abort()
end subroutine
END

5
libgfortran/ChangeLog
View file

@ -1,3 +1,8 @@
2017-03-28 Janus Weil <janus@gcc.gnu.org>
PR fortran/78661
* io/write.c (nml_write_obj): Build a class container only if necessary.
2017-03-27 Dominique d'Humieres <dominiq@lps.ens.fr>
* io/list_read.c: Insert /* Fall through. */ in the macro

28
libgfortran/io/write.c
View file

@ -2075,7 +2075,7 @@ nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset,
/* Write namelist variable names in upper case. If a derived type,
nothing is output. If a component, base and base_name are set. */
if (obj->type != BT_DERIVED)
if (obj->type != BT_DERIVED || obj->dtio_sub != NULL)
{
namelist_write_newline (dtp);
write_character (dtp, " ", 1, 1, NODELIM);
@ -2227,15 +2227,10 @@ nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset,
int noiostat;
int *child_iostat = NULL;
gfc_array_i4 vlist;
gfc_class list_obj;
formatted_dtio dtio_ptr = (formatted_dtio)obj->dtio_sub;
GFC_DIMENSION_SET(vlist.dim[0],1, 0, 0);
list_obj.data = p;
list_obj.vptr = obj->vtable;
list_obj.len = 0;
/* Set iostat, intent(out). */
noiostat = 0;
child_iostat = (dtp->common.flags & IOPARM_HAS_IOSTAT) ?
@ -2252,7 +2247,6 @@ nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset,
child_iomsg = tmp_iomsg;
child_iomsg_len = IOMSG_LEN;
}
namelist_write_newline (dtp);
/* If writing to an internal unit, stash it to allow
the child procedure to access it. */
@ -2261,9 +2255,23 @@ nml_write_obj (st_parameter_dt *dtp, namelist_info * obj, index_type offset,
/* Call the user defined formatted WRITE procedure. */
dtp->u.p.current_unit->child_dtio++;
dtio_ptr ((void *)&list_obj, &unit, iotype, &vlist,
child_iostat, child_iomsg,
iotype_len, child_iomsg_len);
if (obj->type == BT_DERIVED)
{
// build a class container
gfc_class list_obj;
list_obj.data = p;
list_obj.vptr = obj->vtable;
list_obj.len = 0;
dtio_ptr ((void *)&list_obj, &unit, iotype, &vlist,
child_iostat, child_iomsg,
iotype_len, child_iomsg_len);
}
else
{
dtio_ptr (p, &unit, iotype, &vlist,
child_iostat, child_iomsg,
iotype_len, child_iomsg_len);
}
dtp->u.p.current_unit->child_dtio--;
goto obj_loop;