Hello,
With some important help from Paul regarding how to access the class data and
array specs, we have the attached patch.
This fixes both READ and WRITE of arrays of class/type objects. The namelist
routines are updated to set the array specifications correctly in the frontend
so that the call to set the namelist dimensions is completed.
Likewise in the NAMELIST READ arena, we have to then take the given loop
specification information and compute the index into the class/type data and set
pointers to the right place on the array. The existing namelist code already
sequences through the loop and needed to be initialized correctly.
Regression tested on x86_64. New test case attached. The test case is little
interesting. You will see use of the unlimited repeat specifier '*' on the DT
format specifier. One can see how useful that is when you have allocated arrays
that could change during program execution. (Just a little side note)
OK for trunk? and then to 7 in about a week?
Regards,
Jerry
2017-05-18 Paul Thomas <pa...@gcc.gnu.org>
PR fortran/80333
* trans-io.c (nml_get_addr_expr): If we are dealing with class
type data set tmp tree to get that address.
(transfer_namelist_element): Set the array spec to point to the
the class data.
2017-05-18 Paul Thomas <pa...@gcc.gnu.org>
Jerry DeLisle <jvdeli...@gcc.gnu.org>
PR fortran/80333
* list_read.c (nml_read_obj): Compute pointer into class/type
arrays from the nl->dim information. Update it for each iteration
of the loop for the given object.
diff --git a/gcc/fortran/trans-io.c b/gcc/fortran/trans-io.c
index c557c114..a81a0c16 100644
--- a/gcc/fortran/trans-io.c
+++ b/gcc/fortran/trans-io.c
@@ -1613,6 +1613,10 @@ nml_get_addr_expr (gfc_symbol * sym, gfc_component * c,
tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
base_addr, tmp, NULL_TREE);
+ if (GFC_CLASS_TYPE_P (TREE_TYPE (tmp))
+ && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_class_data_get (tmp))))
+ tmp = gfc_class_data_get (tmp);
+
if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
tmp = gfc_conv_array_data (tmp);
else
@@ -1671,7 +1675,11 @@ transfer_namelist_element (stmtblock_t * block, const char * var_name,
/* Build ts, as and data address using symbol or component. */
ts = (sym) ? &sym->ts : &c->ts;
- as = (sym) ? sym->as : c->as;
+
+ if (ts->type != BT_CLASS)
+ as = (sym) ? sym->as : c->as;
+ else
+ as = (sym) ? CLASS_DATA (sym)->as : CLASS_DATA (c)->as;
addr_expr = nml_get_addr_expr (sym, c, base_addr);
@@ -1683,6 +1691,9 @@ transfer_namelist_element (stmtblock_t * block, const char * var_name,
decl = (sym) ? sym->backend_decl : c->backend_decl;
if (sym && sym->attr.dummy)
decl = build_fold_indirect_ref_loc (input_location, decl);
+
+ if (ts->type == BT_CLASS)
+ decl = gfc_class_data_get (decl);
dt = TREE_TYPE (decl);
dtype = gfc_get_dtype (dt);
}
diff --git a/libgfortran/io/list_read.c b/libgfortran/io/list_read.c
index 9175a6bb..d8d06823 100644
--- a/libgfortran/io/list_read.c
+++ b/libgfortran/io/list_read.c
@@ -2871,6 +2871,7 @@ nml_read_obj (st_parameter_dt *dtp, namelist_info *nl, index_type offset,
index_type m;
size_t obj_name_len;
void *pdata;
+ gfc_class list_obj;
/* If we have encountered a previous read error or this object has not been
touched in name parsing, just return. */
@@ -2909,11 +2910,28 @@ nml_read_obj (st_parameter_dt *dtp, namelist_info *nl, index_type offset,
{
/* Update the pointer to the data, using the current index vector */
- pdata = (void*)(nl->mem_pos + offset);
- for (dim = 0; dim < nl->var_rank; dim++)
- pdata = (void*)(pdata + (nl->ls[dim].idx
- - GFC_DESCRIPTOR_LBOUND(nl,dim))
- * GFC_DESCRIPTOR_STRIDE(nl,dim) * nl->size);
+ if ((nl->type == BT_DERIVED || nl->type == BT_CLASS)
+ && nl->dtio_sub != NULL)
+ {
+ pdata = NULL; /* Not used under these conidtions. */
+ if (nl->type == BT_CLASS)
+ list_obj.data = ((gfc_class*)nl->mem_pos)->data;
+ else
+ list_obj.data = (void *)nl->mem_pos;
+
+ for (dim = 0; dim < nl->var_rank; dim++)
+ list_obj.data = list_obj.data + (nl->ls[dim].idx
+ - GFC_DESCRIPTOR_LBOUND(nl,dim))
+ * GFC_DESCRIPTOR_STRIDE(nl,dim) * nl->size;
+ }
+ else
+ {
+ pdata = (void*)(nl->mem_pos + offset);
+ for (dim = 0; dim < nl->var_rank; dim++)
+ pdata = (void*)(pdata + (nl->ls[dim].idx
+ - GFC_DESCRIPTOR_LBOUND(nl,dim))
+ * GFC_DESCRIPTOR_STRIDE(nl,dim) * nl->size);
+ }
/* If we are finished with the repeat count, try to read next value. */
@@ -2958,6 +2976,7 @@ nml_read_obj (st_parameter_dt *dtp, namelist_info *nl, index_type offset,
break;
case BT_DERIVED:
+ case BT_CLASS:
/* If this object has a User Defined procedure, call it. */
if (nl->dtio_sub != NULL)
{
@@ -2970,13 +2989,11 @@ nml_read_obj (st_parameter_dt *dtp, namelist_info *nl, index_type offset,
int noiostat;
int *child_iostat = NULL;
gfc_array_i4 vlist;
- gfc_class list_obj;
formatted_dtio dtio_ptr = (formatted_dtio)nl->dtio_sub;
GFC_DESCRIPTOR_DATA(&vlist) = NULL;
GFC_DIMENSION_SET(vlist.dim[0],1, 0, 0);
-
- list_obj.data = (void *)nl->mem_pos;
+
list_obj.vptr = nl->vtable;
list_obj.len = 0;
! { dg-do run }
! PR80333 Namelist dtio write of array of class does not traverse the array
! This test checks both NAMELIST WRITE and READ of an array of class
module m
implicit none
type :: t
character :: c
character :: d
contains
procedure :: read_formatted
generic :: read(formatted) => read_formatted
procedure :: write_formatted
generic :: write(formatted) => write_formatted
end type t
contains
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
integer :: i
read(unit,'(a1,a1)', iostat=iostat, iomsg=iomsg) dtv%c, dtv%d
end subroutine read_formatted
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,'(a1,a1)', iostat=iostat, iomsg=iomsg) dtv%c, dtv%d
end subroutine write_formatted
end module m
program p
use m
implicit none
class(t), dimension(:,:), allocatable :: w
namelist /nml/ w
integer :: unit, iostatus
character(256) :: str = ""
open(10, status='scratch')
allocate(w(10,3))
w = t('j','r')
w(5:7,2)%c='k'
write(10, nml)
rewind(10)
w = t('p','z')
read(10, nml)
write(str,*) w
if (str.ne." jr jr jr jr jr jr jr jr jr jr jr jr jr jr kr kr kr jr jr jr jr
jr jr jr jr jr jr jr jr jr") &
& call abort
str = ""
write(str,"(*(DT))") w
if (str.ne."jrjrjrjrjrjrjrjrjrjrjrjrjrjrkrkrkrjrjrjrjrjrjrjrjrjrjrjrjrjr")
call abort
end program p
