diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 928e5bbe5d74..76418d94948b 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,11 @@ +2017-05-19 Paul Thomas + + 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-19 David Malcolm PR fortran/79852 diff --git a/gcc/fortran/trans-io.c b/gcc/fortran/trans-io.c index c557c1140d82..c3c56f296238 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 @@ -1670,8 +1674,12 @@ 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; + ts = sym ? &sym->ts : &c->ts; + + 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); @@ -1680,9 +1688,12 @@ transfer_namelist_element (stmtblock_t * block, const char * var_name, if (rank) { - decl = (sym) ? sym->backend_decl : c->backend_decl; + 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/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index dafa0343d1ab..fb4b1bd2db07 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2017-05-19 Jerry DeLisle + + PR libgfortran/80333 + * gfortran.dg/dtio_30.f03: New test. + 2017-05-19 Marek Polacek PR sanitizer/80800 diff --git a/gcc/testsuite/gfortran.dg/dtio_30.f03 b/gcc/testsuite/gfortran.dg/dtio_30.f03 new file mode 100644 index 000000000000..9edc8f3878d8 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dtio_30.f03 @@ -0,0 +1,60 @@ +! { 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 diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog index 7fe527dda3e3..4ada8b8074a5 100644 --- a/libgfortran/ChangeLog +++ b/libgfortran/ChangeLog @@ -1,3 +1,11 @@ +2017-05-19 Paul Thomas + Jerry DeLisle + + 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. + 2017-05-17 Jerry DeLisle PR libgfortran/80741 diff --git a/libgfortran/io/list_read.c b/libgfortran/io/list_read.c index 9175a6bb677f..6c00d11bf053 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;