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
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 ();
}
! { 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 <COPYRIGHT HOLDER> ``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 <COPYRIGHT
HOLDER> 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//'<in>'
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)//'<out>'
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" } }