2010-08-15 Tobias Burnus <burnus@net-b.de>

        * trans-expr.c (gfc_conv_expr_present): Regard nullified
        pointer arrays as absent.
        (gfc_conv_procedure_call): Handle EXPR_NULL for non-pointer
        dummys as absent argument.
        * interface.c (compare_actual_formal,compare_parameter):
        Ditto.

2010-08-15  Tobias Burnus  <burnus@net-b.de>

        * gfortran.dg/optional_absent_1.f90: New.
        * gfortran.dg/null_actual.f90: New.

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

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 63a3927..4bddcb4 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,5 +1,14 @@
 2010-08-15  Tobias Burnus  <burnus@net-b.de>
 
+       * trans-expr.c (gfc_conv_expr_present): Regard nullified
+       pointer arrays as absent.
+       (gfc_conv_procedure_call): Handle EXPR_NULL for non-pointer
+       dummys as absent argument.
+       * interface.c (compare_actual_formal,compare_parameter):
+       Ditto.
+
+2010-08-15  Tobias Burnus  <burnus@net-b.de>
+
        * interface.c (compare_pointer, ): Allow passing TARGETs to pointers
        dummies with intent(in).
 

diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index fa32c5c..e9d310a 100644 (file)
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -1589,7 +1589,8 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
   if (rank_check || ranks_must_agree
       || (formal->attr.pointer && actual->expr_type != EXPR_NULL)
       || (actual->rank != 0 && !(is_elemental || formal->attr.dimension))
-      || (actual->rank == 0 && formal->as->type == AS_ASSUMED_SHAPE)
+      || (actual->rank == 0 && formal->as->type == AS_ASSUMED_SHAPE
+         && actual->expr_type != EXPR_NULL)
       || (actual->rank == 0 && formal->attr.dimension
          && gfc_is_coindexed (actual)))
     {
@@ -2004,6 +2005,20 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
                       "call at %L", where);
          return 0;
        }
+
+      if (a->expr->expr_type == EXPR_NULL && !f->sym->attr.pointer
+         && (f->sym->attr.allocatable || !f->sym->attr.optional
+             || (gfc_option.allow_std & GFC_STD_F2008) == 0))
+       {
+         if (where && (f->sym->attr.allocatable || !f->sym->attr.optional))
+           gfc_error ("Unexpected NULL() intrinsic at %L to dummy '%s'",
+                      where, f->sym->name);
+         else if (where)
+           gfc_error ("Fortran 2008: Null pointer at %L to non-pointer "
+                      "dummy '%s'", where, f->sym->name);
+
+         return 0;
+       }
       
       if (!compare_parameter (f->sym, a->expr, ranks_must_agree,
                              is_elemental, where))

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 53df2ae..82f67fb 100644 (file)
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -123,7 +123,7 @@ gfc_make_safe_expr (gfc_se * se)
 tree
 gfc_conv_expr_present (gfc_symbol * sym)
 {
-  tree decl;
+  tree decl, cond;
 
   gcc_assert (sym->attr.dummy);
 
@@ -136,8 +136,26 @@ gfc_conv_expr_present (gfc_symbol * sym)
              || GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
       decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
     }
-  return fold_build2 (NE_EXPR, boolean_type_node, decl,
+
+  cond = fold_build2 (NE_EXPR, boolean_type_node, decl,
                      fold_convert (TREE_TYPE (decl), null_pointer_node));
+
+  /* Fortran 2008 allows to pass null pointers and non-associated pointers
+     as actual argument to denote absent dummies. For array descriptors,
+     we thus also need to check the array descriptor.  */
+  if (!sym->attr.pointer && !sym->attr.allocatable
+      && sym->as && sym->as->type == AS_ASSUMED_SHAPE
+      && (gfc_option.allow_std & GFC_STD_F2008) != 0)
+    {
+      tree tmp;
+      tmp = build_fold_indirect_ref_loc (input_location, decl);
+      tmp = gfc_conv_array_data (tmp);
+      tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp,
+                        fold_convert (TREE_TYPE (tmp), null_pointer_node));
+      cond = fold_build2 (TRUTH_ANDIF_EXPR, boolean_type_node, cond, tmp);
+    }
+
+  return cond;
 }
 
 
@@ -2850,6 +2868,15 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
                parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
            }
        }
+      else if (arg->expr->expr_type == EXPR_NULL && fsym && !fsym->attr.pointer)
+       {
+         /* Pass a NULL pointer to denote an absent arg.  */
+         gcc_assert (fsym->attr.optional && !fsym->attr.allocatable);
+         gfc_init_se (&parmse, NULL);
+         parmse.expr = null_pointer_node;
+         if (arg->missing_arg_type == BT_CHARACTER)
+           parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
+       }
       else if (fsym && fsym->ts.type == BT_CLASS
                 && e->ts.type == BT_DERIVED)
        {

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 3cdef81..1065b33 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,5 +1,10 @@
 2010-08-15  Tobias Burnus  <burnus@net-b.de>
 
+       * gfortran.dg/optional_absent_1.f90: New.
+       * gfortran.dg/null_actual.f90: New.
+
+2010-08-15  Tobias Burnus  <burnus@net-b.de>
+
        * gfortran.dg/pointer_target_1.f90: New.
        * gfortran.dg/pointer_target_2.f90: New.
        * gfortran.dg/pointer_target_3.f90: New.

diff --git a/gcc/testsuite/gfortran.dg/null_actual.f90 b/gcc/testsuite/gfortran.dg/null_actual.f90
new file mode 100644 (file)
index 0000000..b29e89d
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/null_actual.f90
@@ -0,0 +1,20 @@
+! { dg-do compile }
+! { dg-options "-std=f2003" }
+!
+! NULL() actual argument to non-pointer dummies
+!
+
+call f(null()) ! { dg-error "Fortran 2008: Null pointer at .1. to non-pointer dummy" }
+call g(null()) ! { dg-error "Unexpected NULL.. intrinsic at .1. to dummy" }
+call h(null()) ! { dg-error "Unexpected NULL.. intrinsic at .1. to dummy" }
+contains
+subroutine f(x)
+  integer, optional  :: x
+end subroutine f
+subroutine g(x)
+  integer, optional, allocatable  :: x
+end subroutine g
+subroutine h(x)
+  integer :: x
+end subroutine h
+end

diff --git a/gcc/testsuite/gfortran.dg/optional_absent_1.f90 b/gcc/testsuite/gfortran.dg/optional_absent_1.f90
new file mode 100644 (file)
index 0000000..690c30f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/optional_absent_1.f90
@@ -0,0 +1,48 @@
+! { dg-do run }
+! { dg-options "-std=f2008 -fall-intrinsics" }
+!
+! Passing a null pointer or deallocated variable to an
+! optional, non-pointer, non-allocatable dummy.
+!
+program test
+  implicit none
+  integer, pointer :: ps => NULL(), pa(:) => NULL()
+  integer, allocatable :: as, aa(:)
+
+  call scalar(ps) 
+  call scalar(as) 
+  call scalar() 
+  call scalar(NULL())
+
+  call assumed_size(pa) 
+  call assumed_size(aa) 
+  call assumed_size() 
+  call assumed_size(NULL(pa))
+
+  call assumed_shape(pa)
+  call assumed_shape(aa)
+  call assumed_shape()
+  call assumed_shape(NULL())
+
+  call ptr_func(.true., ps)
+  call ptr_func(.true., null())
+  call ptr_func(.false.)
+contains
+  subroutine scalar(a)
+    integer, optional :: a
+    if (present(a)) call abort()
+  end subroutine scalar
+  subroutine assumed_size(a)
+    integer, optional :: a(*)
+    if (present(a)) call abort()
+  end subroutine assumed_size
+  subroutine assumed_shape(a)
+    integer, optional :: a(:)
+    if (present(a)) call abort()
+  end subroutine assumed_shape
+  subroutine ptr_func(is_psnt, a)
+    integer, optional, pointer :: a
+    logical :: is_psnt
+    if (is_psnt .neqv. present(a)) call abort()
+  end subroutine ptr_func
+end program test