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.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@153793 138bc75d-0d04-0410-961f-82ee72b054a4

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 323bd43..90df7a4 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -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
 2009-10-29  Tobias Burnus  <burnus@net-b.de>
 
        PR fortran/41777

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 7eddbd4..8255bb1 100644 (file)
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -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);
 
                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,
       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
          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);
        }
            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 6e3a9d8..363e9cb 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -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.
 2009-10-31  Richard Guenther  <rguenther@suse.de>
 
        * g++.dg/tree-ssa/restrict1.C: New.

diff --git a/gcc/testsuite/gfortran.dg/intent_out_6.f90 b/gcc/testsuite/gfortran.dg/intent_out_6.f90
new file mode 100644 (file)
index 0000000..1a41107
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/intent_out_6.f90
@@ -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" } }