From b460b38698c7a2c2126250dec94f40a636635a66 Mon Sep 17 00:00:00 2001 From: burnus Date: Tue, 3 Nov 2009 16:51:52 +0000 Subject: [PATCH] 2009-11-03 Tobias Burnus PR fortran/41907 * trans-expr.c (gfc_conv_procedure_call): Fix presence check for optional arguments. 2009-11-03 Tobias Burnus PR fortran/41907 * gfortran.dg/missing_optional_dummy_6.f90: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@153854 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/ChangeLog | 6 +++ gcc/fortran/trans-expr.c | 15 +++--- gcc/testsuite/ChangeLog | 5 ++ .../gfortran.dg/missing_optional_dummy_6.f90 | 60 ++++++++++++++++++++++ 4 files changed, 80 insertions(+), 6 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/missing_optional_dummy_6.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 717ffa025cb..8fc1175b35a 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,9 @@ +2009-11-03 Tobias Burnus + + PR fortran/41907 + * trans-expr.c (gfc_conv_procedure_call): Fix presence check + for optional arguments. + 2009-11-01 Tobias Burnus PR fortran/41872 diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index d8f8303fdbd..5a45f4f6368 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -2998,16 +2998,19 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, 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. */ + When passing a non-array-descriptor full array to a + non-array-descriptor dummy, no check is needed. For + array-descriptor actual to array-descriptor dummy, see + PR 41911 for why a check has to be inserted. + fsym == NULL is checked as intrinsics required the descriptor + but do not always set fsym. */ if (e->expr_type == EXPR_VARIABLE && 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))))) + || (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); } diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 32e07ccd49a..859b5f15f7c 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2009-11-03 Tobias Burnus + + PR fortran/41907 + * gfortran.dg/missing_optional_dummy_6.f90: New test. + 2009-11-03 Nick Clifton * gcc.target/rx/builtins,c: Remove redundant tests. diff --git a/gcc/testsuite/gfortran.dg/missing_optional_dummy_6.f90 b/gcc/testsuite/gfortran.dg/missing_optional_dummy_6.f90 new file mode 100644 index 00000000000..408582289f1 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/missing_optional_dummy_6.f90 @@ -0,0 +1,60 @@ +! { dg-do run } +! { dg-options "-fdump-tree-original" } +! +! PR fortran/41907 +! +program test + implicit none + call scalar1 () + call assumed_shape1 () + call explicit_shape1 () +contains + + ! Calling functions + subroutine scalar1 (slr1) + integer, optional :: slr1 + call scalar2 (slr1) + end subroutine scalar1 + + subroutine assumed_shape1 (as1) + integer, dimension(:), optional :: as1 + call assumed_shape2 (as1) + call explicit_shape2 (as1) + end subroutine assumed_shape1 + + subroutine explicit_shape1 (es1) + integer, dimension(5), optional :: es1 + call assumed_shape2 (es1) + call explicit_shape2 (es1) + end subroutine explicit_shape1 + + + ! Called functions + subroutine assumed_shape2 (as2) + integer, dimension(:),optional :: as2 + if (present (as2)) call abort() + end subroutine assumed_shape2 + + subroutine explicit_shape2 (es2) + integer, dimension(5),optional :: es2 + if (present (es2)) call abort() + end subroutine explicit_shape2 + + subroutine scalar2 (slr2) + integer, optional :: slr2 + if (present (slr2)) call abort() + end subroutine scalar2 + +end program test + +! { dg-final { scan-tree-dump-times "scalar2 \\(slr1" 1 "original" } } + +! { dg-final { scan-tree-dump-times "= es1 != 0B" 1 "original" } } +! { dg-final { scan-tree-dump-times "assumed_shape2 \\(es1" 0 "original" } } +! { dg-final { scan-tree-dump-times "explicit_shape2 \\(es1" 1 "original" } } + +! { dg-final { scan-tree-dump-times "= as1 != 0B" 2 "original" } } +! { dg-final { scan-tree-dump-times "assumed_shape2 \\(as1" 0 "original" } } +! { dg-final { scan-tree-dump-times "explicit_shape2 \\(as1" 0 "original" } } + +! { dg-final { cleanup-tree-dump "original" } } -- 2.11.0