trans-expr.c (gfc_conv_expr_present): Regard nullified pointer arrays as absent.

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.

From-SVN: r163263

gcc/fortran/ChangeLog

 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).
 

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))

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)
 	{

gcc/testsuite/ChangeLog

 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.

gcc/testsuite/gfortran.dg/null_actual.f90

+! { 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

gcc/testsuite/gfortran.dg/optional_absent_1.f90

+! { 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