===================================================================
@@ -1701,23 +1701,54 @@ transfer_namelist_element (stmtblock_t * block, co
/* 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);
+ }
+ }
}
if (ts->type == BT_CHARACTER)
===================================================================
@@ -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
-
===================================================================
@@ -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
===================================================================
@@ -2075,7 +2075,7 @@ nml_write_obj (st_parameter_dt *dtp, namelist_info
/* 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
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
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
/* 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;