OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

re PR fortran/41850 (Wrong-code with optional allocatable arrays) 

2009-11-01  Tobias Burnus  <burnus@net-b.de>

        PR fortran/41850
        * trans-expr.c (gfc_conv_procedure_call): Deallocate intent-out
        variables only when present. Remove unneccessary present check.

2009-11-01  Tobias Burnus  <burnus@net-b.de>

        PR fortran/41850
        * gfortran.dg/intent_out_6.f90: New testcase.

From-SVN: r153793
This commit is contained in:
Tobias Burnus 2009-11-01 13:43:42 +01:00 committed by Tobias Burnus
parent 164247b0e2
commit 745ff31ff7
4 changed files with 79 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
gcc/fortran/ChangeLog
View File

@ -1,3 +1,9 @@
2009-11-01 Tobias Burnus <burnus@net-b.de>
PR fortran/41850
* trans-expr.c (gfc_conv_procedure_call): Deallocate intent-out
variables only when present. Remove unneccessary present check.
2009-10-29 Tobias Burnus <burnus@net-b.de>
PR fortran/41777

42
gcc/fortran/trans-expr.c
View File

@ -2935,17 +2935,22 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
gfc_conv_array_parameter (&parmse, e, argss, f, fsym,
sym->name, NULL);
/* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
allocated on entry, it must be deallocated. */
if (fsym && fsym->attr.allocatable
&& fsym->attr.intent == INTENT_OUT)
{
tmp = build_fold_indirect_ref_loc (input_location,
parmse.expr);
tmp = gfc_trans_dealloc_allocated (tmp);
gfc_add_expr_to_block (&se->pre, tmp);
}
/* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
allocated on entry, it must be deallocated. */
if (fsym && fsym->attr.allocatable
&& fsym->attr.intent == INTENT_OUT)
{
tmp = build_fold_indirect_ref_loc (input_location,
parmse.expr);
tmp = gfc_trans_dealloc_allocated (tmp);
if (fsym->attr.optional
&& e->expr_type == EXPR_VARIABLE
&& e->symtree->n.sym->attr.optional)
tmp = fold_build3 (COND_EXPR, void_type_node,
gfc_conv_expr_present (e->symtree->n.sym),
tmp, build_empty_stmt (input_location));
gfc_add_expr_to_block (&se->pre, tmp);
}
}
}
@ -2957,9 +2962,20 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
if (e && (fsym == NULL || fsym->attr.optional))
{
/* If an optional argument is itself an optional dummy argument,
check its presence and substitute a null if absent. */
check its presence and substitute a null if absent. This is
only needed when passing an array to an elemental procedure
as then array elements are accessed - or no NULL pointer is
allowed and a "1" or "0" should be passed if not present.
When passing a deferred array to a non-deferred array dummy,
the array needs to be packed and a check needs thus to be
inserted. */
if (e->expr_type == EXPR_VARIABLE
&& e->symtree->n.sym->attr.optional)
&& e->symtree->n.sym->attr.optional
&& ((e->rank > 0 && sym->attr.elemental)
|| e->representation.length || e->ts.type == BT_CHARACTER
|| (e->rank > 0 && (fsym == NULL
|| (fsym->as->type != AS_ASSUMED_SHAPE
&& fsym->as->type != AS_DEFERRED)))))
gfc_conv_missing_dummy (&parmse, e, fsym ? fsym->ts : e->ts,
e->representation.length);
}

5
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,8 @@
2009-11-01 Tobias Burnus <burnus@net-b.de>
PR fortran/41850
* gfortran.dg/intent_out_6.f90: New testcase.
2009-10-31 Richard Guenther <rguenther@suse.de>
* g++.dg/tree-ssa/restrict1.C: New.

39
gcc/testsuite/gfortran.dg/intent_out_6.f90 Normal file
View File

@ -0,0 +1,39 @@
! { dg-do run }
!
! PR fortran/41850
!
module test_module
implicit none
contains
subroutine sub2(a)
implicit none
real,allocatable,intent(out),optional :: a(:)
if(present(a)) then
if(allocated(a)) call abort()
allocate(a(1))
a(1) = 5
end if
end subroutine sub2
subroutine sub1(a)
implicit none
real,allocatable,intent(out),optional :: a(:)
! print *,'in sub1'
call sub2(a)
if(present(a)) then
if(a(1) /= 5) call abort()
end if
end subroutine sub1
end module test_module
program test
use test_module
implicit none
real, allocatable :: x(:)
allocate(x(1))
call sub1()
x = 8
call sub1(x)
if(x(1) /= 5) call abort()
end program
! { dg-final { cleanup-modules "test_module" } }