[multiple changes]
2017-05-19 Paul Thomas <pault@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-19 Paul Thomas <pault@gcc.gnu.org> Jerry DeLisle <jvdelisle@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. 2017-05-19 Jerry DeLisle <jvdelisle@gcc.gnu.org> PR libgfortran/80333 * gfortran.dg/dtio_30.f03: New test. From-SVN: r248293
This commit is contained in:
Jerry DeLisle
parent
33f8c0a14d
commit
51cd6b78ee
|
|
@ -1,3 +1,11 @@
|
|||
2017-05-19 Paul Thomas <pault@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-19 David Malcolm <dmalcolm@redhat.com>
|
||||
|
||||
PR fortran/79852
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
}
|
||||
|
|
|
|||
|
|
@ -1,3 +1,8 @@
|
|||
2017-05-19 Jerry DeLisle <jvdelisle@gcc.gnu.org>
|
||||
|
||||
PR libgfortran/80333
|
||||
* gfortran.dg/dtio_30.f03: New test.
|
||||
|
||||
2017-05-19 Marek Polacek <polacek@redhat.com>
|
||||
|
||||
PR sanitizer/80800
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -1,3 +1,11 @@
|
|||
2017-05-19 Paul Thomas <pault@gcc.gnu.org>
|
||||
Jerry DeLisle <jvdelisle@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.
|
||||
|
||||
2017-05-17 Jerry DeLisle <jvdelisle@gcc.gnu.org>
|
||||
|
||||
PR libgfortran/80741
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue