From patchwork Fri May 19 00:16:45 2017 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Jerry DeLisle X-Patchwork-Id: 764220 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by ozlabs.org (Postfix) with ESMTPS id 3wTTBr2sspz9s5j for ; Fri, 19 May 2017 10:17:06 +1000 (AEST) Authentication-Results: ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.b="dg2vX01q"; dkim-atps=neutral DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:to :from:subject:message-id:date:mime-version:content-type; q=dns; s=default; b=KQcSLjgmk74Uf3nUSHURsoeCYVliKFEsinLVUDv7RgrS9coI9n l23MvZxepgC0Twn37LVGmtJkaITQhSrkkqY2Y56UPEm4ERkA3zmSi7xeUQt62+ew Ub9SE6KENoeMl16s1Fjm6JTmJY1Rd7vSaYLamWz+7JR3Qf2mYsIusxdXE= DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:to :from:subject:message-id:date:mime-version:content-type; s= default; bh=KCxHlbJ5Q2xPprDox/O2VnObVw8=; b=dg2vX01qyR9dcxx0drKa k5MS73TVfC0CjYgtj3/wNaY7XSWXkq6QOrOKX7Ua+ZeDjTsfuyoORYBMRQ3hybQR j4aeffpcRtzFY2kT9PVCQboVpn7odYE+Zce7q+3o9H57GfLkBVLxXzmSoaIIXK8x lXsY/Husd9vdoVg5k7kEynQ= Received: (qmail 61345 invoked by alias); 19 May 2017 00:16:54 -0000 Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org Received: (qmail 61292 invoked by uid 89); 19 May 2017 00:16:48 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=-25.2 required=5.0 tests=AWL, BAYES_00, GIT_PATCH_0, GIT_PATCH_1, GIT_PATCH_2, GIT_PATCH_3, RCVD_IN_DNSWL_LOW, RP_MATCHES_RCVD, SPF_PASS autolearn=ham version=3.3.2 spammy=jr, pz, H*r:sk:2017051, H*Ad:D*charter.net X-Spam-User: qpsmtpd, 2 recipients X-HELO: mtaout004-public.msg.strl.va.charter.net Received: from mtaout004-public.msg.strl.va.charter.net (HELO mtaout004-public.msg.strl.va.charter.net) (68.114.190.29) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with ESMTP; Fri, 19 May 2017 00:16:46 +0000 Received: from impout006 ([68.114.189.21]) by mtaout004.msg.strl.va.charter.net (InterMail vM.9.00.023.01 201-2473-194) with ESMTP id <20170519001648.YSQH3685.mtaout004.msg.strl.va.charter.net@impout006>; Thu, 18 May 2017 19:16:48 -0500 Received: from amda8.localdomain ([96.41.215.23]) by impout006 with charter.net id N0Gl1v00D0Wrkg0010GmVg; Thu, 18 May 2017 19:16:48 -0500 X-Authority-Analysis: v=2.2 cv=TffmjVYh c=1 sm=1 tr=0 a=salB9WdMPIDduBH7JsZfrA==:117 a=salB9WdMPIDduBH7JsZfrA==:17 a=r77TgQKjGQsHNAKrUKIA:9 a=mDV3o1hIAAAA:8 a=GS34fij1tkcS1JaGDgsA:9 a=QEXdDO2ut3YA:10 a=pmEDWeGMPc7izIy4LXEA:9 a=hquHOILUSkIA:10 a=gtWb-NexE5EgCN50xO8A:9 a=voGCI5DAS3EA:10 a=_FVE-zBwftR9WsbkzFJk:22 X-Auth-id: anZkZWxpc2xlQGNoYXJ0ZXIubmV0 To: "fortran@gcc.gnu.org" , GCC Patches From: Jerry DeLisle Subject: [patch, fortran] PR80333 Namelist dtio write of array of class does not traverse the array Message-ID: <8dc9b364-13c5-f568-9000-345f736c3ad5@charter.net> Date: Thu, 18 May 2017 17:16:45 -0700 User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:52.0) Gecko/20100101 Thunderbird/52.1.0 MIME-Version: 1.0 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 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 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. ! { 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/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;