From patchwork Fri Apr 29 21:46:36 2011 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Tobias Burnus X-Patchwork-Id: 93482 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]) by ozlabs.org (Postfix) with SMTP id EC5E0B6FD3 for ; Sat, 30 Apr 2011 07:47:01 +1000 (EST) Received: (qmail 32032 invoked by alias); 29 Apr 2011 21:46:57 -0000 Received: (qmail 31983 invoked by uid 22791); 29 Apr 2011 21:46:53 -0000 X-SWARE-Spam-Status: No, hits=1.5 required=5.0 tests=AWL, BAYES_50, PERCENT_RANDOM, RCVD_IN_DNSWL_NONE, SARE_RAND_1, TW_TM X-Spam-Check-By: sourceware.org Received: from mx02.qsc.de (HELO mx02.qsc.de) (213.148.130.14) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Fri, 29 Apr 2011 21:46:38 +0000 Received: from [192.168.178.22] (port-92-204-100-38.dynamic.qsc.de [92.204.100.38]) by mx02.qsc.de (Postfix) with ESMTP id C69601E3A1; Fri, 29 Apr 2011 23:46:36 +0200 (CEST) Message-ID: <4DBB31BC.5000804@net-b.de> Date: Fri, 29 Apr 2011 23:46:36 +0200 From: Tobias Burnus User-Agent: Mozilla/5.0 (X11; U; Linux x86_64; de; rv:1.9.2.13) Gecko/20101206 SUSE/3.1.7 Thunderbird/3.1.7 MIME-Version: 1.0 To: gcc patches , gfortran Subject: [Fortran] RFC patch for gfc_trans_deferred_vars (PR 48786) 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 Dear all, gfc_trans_deferred_vars is a bit of a mess; there is first a block which handles function results of the type proc_sym->result == proc_sym. Afterwards, deferred variables - local, dummys, and proc_sym->result (!= proc_sym) are handled. The problem is that for allocatable results (esp. of CLASS type) and for deferred-length strings, the same initialization has to happen as for function results. Consequence: There is code partial duplication - and some code should be duplicated, but is not; that causes the issue with the current code. Attached patch tries to fix that; it fixes Arjan's wrong-code issue and it also reduces the code size; however, I do not think that it makes the code very readable. What do you think? How can this be improved? Or should the patch be committed as is? (The patch was regtested on x86-64-linux.) Tobias ! { dg-do run } ! ! PR fortran/24141 ! ! Contributed by Arjen Markus; the trace module ! is from Simon Geard. ! ! ------------------------------------- ! Copyright 2011 Simon Geard. All rights reserved. ! ! Redistribution and use in source and binary forms, with or without modification, are ! permitted provided that the following conditions are met: ! ! 1. Redistributions of source code must retain the above copyright notice, this list of ! conditions and the following disclaimer. ! ! 2. Redistributions in binary form must reproduce the above copyright notice, this list ! of conditions and the following disclaimer in the documentation and/or other materials ! provided with the distribution. ! ! THIS SOFTWARE IS PROVIDED BY ``AS IS'' AND ANY EXPRESS OR IMPLIED ! WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND ! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL OR ! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR ! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR ! SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ! ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ! NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. module trace implicit none type tracing integer :: level = 0 character(len=3) :: indent = ' ' contains procedure, public :: in procedure, public :: out procedure, public :: message procedure, public :: get_current_indent procedure, public :: print_current_indent end type tracing type(tracing), public :: tr logical, private :: s_trace_is_on = .false. contains subroutine set_trace_on s_trace_is_on = .true. end subroutine set_trace_on subroutine set_trace_off s_trace_is_on = .false. end subroutine set_trace_off logical function trace_is_on() trace_is_on = s_trace_is_on end function trace_is_on subroutine in(this, name) implicit none class(tracing), intent(inout) :: this character(len=*), intent(in) :: name if (s_trace_is_on) then write(*,'(a)') repeat(this%indent,this%level)//name//'' end if this%level = this%level + 1 end subroutine in subroutine out(this, no_message) implicit none class(tracing), intent(inout) :: this logical, optional :: no_message ! = .true. logical :: output_mess this%level = this%level - 1 if (s_trace_is_on) then output_mess = merge(no_message, .true., present(no_message)) if (output_mess) write(*,'(a)') repeat(this%indent,this%level)//'' end if end subroutine out subroutine message(this, mess) class(tracing), intent(in) :: this character(len=*), intent(in) :: mess if (s_trace_is_on) then write(*,'(a)') repeat(this%indent,this%level)//mess end if end subroutine message subroutine print_current_indent(this) class(tracing), intent(in) :: this if (this%level > 0) then write(*,advance='no',fmt = '(a)') repeat(this%indent,this%level) end if end subroutine print_current_indent subroutine get_current_indent(this, indent, nindent) class(tracing), intent(in) :: this character(len=*), intent(out) :: indent integer, intent(out) :: nindent indent = repeat(this%indent,this%level) nindent = len(this%indent)*this%level end subroutine get_current_indent end module trace module points2d3d use trace implicit none type point2d real :: x, y contains procedure :: print => print_2d procedure :: add_vector => add_vector_2d procedure :: random => random_vector_2d procedure :: assign => assign_2d generic, public :: operator(+) => add_vector generic, public :: assignment(=) => assign end type point2d type, extends(point2d) :: point3d real :: z contains procedure :: print => print_3d procedure :: add_vector => add_vector_3d procedure :: random => random_vector_3d procedure :: assign => assign_3d !! generic, public :: operator(+) => add_vector !! generic, public :: assignment(=) => assign end type point3d contains subroutine print_2d( point ) class(point2d) :: point write(*,'(2f10.4)') point%x, point%y end subroutine print_2d subroutine print_3d( point ) class(point3d) :: point write(*,'(3f10.4)') point%x, point%y, point%z end subroutine print_3d subroutine random_vector_2d( point ) class(point2d) :: point call random_number( point%x ) call random_number( point%y ) point%x = 2.0 * point%x - 1.0 point%y = 2.0 * point%y - 1.0 end subroutine random_vector_2d ! ! This routine gets confused for the 2D variant ! - essentially the same interface? subroutine random_vector_3d( point ) class(point3d) :: point call point%point2d%random call random_number( point%z ) point%z = 2.0 * point%z - 1.0 end subroutine random_vector_3d function add_vector_2d( point, vector ) class(point2d), intent(in) :: point, vector class(point2d), allocatable :: add_vector_2d if ( allocated(add_vector_2d) ) then deallocate( add_vector_2d ) endif allocate( add_vector_2d ) add_vector_2d%x = point%x + vector%x add_vector_2d%y = point%y + vector%y end function add_vector_2d function add_vector_3d( point, vector ) class(point3d), intent(in) :: point class(point2d), intent(in) :: vector class(point3d), allocatable :: vector_3d class(point2d), allocatable :: add_vector_3d allocate( vector_3d ) select type (vector) class is (point3d) vector_3d%point2d = point%point2d + vector%point2d vector_3d%z = point%z + vector%z end select call move_alloc( vector_3d, add_vector_3d ) end function add_vector_3d subroutine assign_2d( left, right ) class(point2d), intent(inout) :: left class(point2d), intent(in) :: right left%x = right%x left%y = right%y end subroutine assign_2d subroutine assign_3d( left, right ) class(point3d), intent(inout) :: left class(point2d), intent(in) :: right select type (right) type is (point3d) left%point2d = right%point2d left%z = right%z end select end subroutine assign_3d end module points2d3d program random_walk use points2d3d ! Both 2D and 3D points available type(point2d), target :: point_2d, vector_2d type(point3d), target :: point_3d, vector_3d ! ! A variable of class point2d can point to point_2d but ! also to point_3d ! class(point2d), pointer :: point, vector integer :: nsteps = 3 ! Was 10 integer :: i integer :: trial real :: deltt = 0.1 ! Select what type of point ... do trial = 1,2 if (trial == 1) then write(*,*) 'Two-dimensional walk:' point => point_2d vector => vector_2d else ! Now let's take a 3D walk ... write(*,*) 'Three-dimensional walk:' point => point_3d vector => vector_3d end if call point%random do i = 1,nsteps call vector%random point = point + vector call point%print enddo enddo end program random_walk ! { dg-final { cleanup-modules "trace points2d3d" } } diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index f80c9db..3db38eb 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -3355,7 +3355,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) gfc_symbol *sym; gfc_formal_arglist *f; stmtblock_t tmpblock; - bool seen_trans_deferred_array = false; + bool seen_trans_deferred_array = false, processed_proc = false; tree tmp = NULL; gfc_expr *e; gfc_se se; @@ -3391,37 +3391,8 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) } else if (proc_sym->ts.type == BT_CHARACTER) { - if (proc_sym->ts.deferred) - { - tmp = NULL; - gfc_save_backend_locus (&loc); - gfc_set_backend_locus (&proc_sym->declared_at); - gfc_start_block (&init); - /* Zero the string length on entry. */ - gfc_add_modify (&init, proc_sym->ts.u.cl->backend_decl, - build_int_cst (gfc_charlen_type_node, 0)); - /* Null the pointer. */ - e = gfc_lval_expr_from_sym (proc_sym); - gfc_init_se (&se, NULL); - se.want_pointer = 1; - gfc_conv_expr (&se, e); - gfc_free_expr (e); - tmp = se.expr; - gfc_add_modify (&init, tmp, - fold_convert (TREE_TYPE (se.expr), - null_pointer_node)); - gfc_restore_backend_locus (&loc); - - /* Pass back the string length on exit. */ - tmp = proc_sym->ts.u.cl->passed_length; - tmp = build_fold_indirect_ref_loc (input_location, tmp); - tmp = fold_convert (gfc_charlen_type_node, tmp); - tmp = fold_build2_loc (input_location, MODIFY_EXPR, - gfc_charlen_type_node, tmp, - proc_sym->ts.u.cl->backend_decl); - gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp); - } - else if (TREE_CODE (proc_sym->ts.u.cl->backend_decl) == VAR_DECL) + if (TREE_CODE (proc_sym->ts.u.cl->backend_decl) == VAR_DECL + && !proc_sym->ts.deferred) gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl, block); } else @@ -3437,14 +3408,32 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) init_intent_out_dt (proc_sym, block); gfc_restore_backend_locus (&loc); - for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink) + for (sym = proc_sym->tlink; ; sym = sym->tlink) { bool sym_has_alloc_comp = (sym->ts.type == BT_DERIVED) && sym->ts.u.derived->attr.alloc_comp; if (sym->assoc) continue; - if (sym->attr.dimension) + /* Handle sym == proc_sym only once to avoid an endless loop. */ + if (sym == proc_sym) + { + if (processed_proc) + break; + processed_proc = true; + } + + /* For function results, which do not need an initialization, + end the loop. */ + if (sym == proc_sym + && (sym != proc_sym->result + || !(sym->attr.allocatable || sym->ts.deferred + || sym_has_alloc_comp + || (sym->ts.type == BT_CLASS + && CLASS_DATA (sym)->attr.allocatable)))) + break; + + if (sym->attr.dimension && sym != proc_sym) { switch (sym->as->type) { @@ -3521,7 +3510,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) if (sym_has_alloc_comp && !seen_trans_deferred_array) gfc_trans_deferred_array (sym, block); } - else if ((!sym->attr.dummy || sym->ts.deferred) + else if (! sym->attr.dimension && (!sym->attr.dummy || sym->ts.deferred) && (sym->attr.allocatable || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.allocatable))) @@ -3551,9 +3540,9 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) null_pointer_node)); } - if ((sym->attr.dummy ||sym->attr.result) - && sym->ts.type == BT_CHARACTER - && sym->ts.deferred) + if ((sym->attr.dummy || sym->attr.result || sym == proc_sym) + && sym->ts.type == BT_CHARACTER + && sym->ts.deferred) { /* Character length passed by reference. */ tmp = sym->ts.u.cl->passed_length; @@ -3582,7 +3571,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) /* Deallocate when leaving the scope. Nullifying is not needed. */ - if (!sym->attr.result && !sym->attr.dummy) + if (!sym->attr.result && sym != proc_sym && !sym->attr.dummy) tmp = gfc_deallocate_scalar_with_status (se.expr, NULL, true, NULL, sym->ts); @@ -3638,9 +3627,9 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) } else if (sym->ts.deferred) gfc_fatal_error ("Deferred type parameter not yet supported"); - else if (sym_has_alloc_comp) + else if (sym_has_alloc_comp && proc_sym != sym) gfc_trans_deferred_array (sym, block); - else if (sym->ts.type == BT_CHARACTER) + else if (sym->ts.type == BT_CHARACTER && sym != proc_sym) { gfc_save_backend_locus (&loc); gfc_set_backend_locus (&sym->declared_at); @@ -3667,7 +3656,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), NULL_TREE); } - else + else if (proc_sym != sym) gcc_unreachable (); }