[Patch, Fortran] F2008: Null pointer/non-allocated as absent dummy

[Tobias Burnus <burnus at net-b dot de>]

 And yet another rather trivial F2008 change... (hours later) ... well, 
maybe it is not as trivial as I thought, but here it is.

The rules for absent actual arguments to optional dummies was changed 
from Fortran 2003 (12.4.1.6 Restrictions on dummy arguments not present) 
to Fortran 2008 (12.5.2.12 Argument presence and restrictions on 
arguments not present) by adding the following:

A dummy argument [...] is not present if the dummy argument [...]
does not have the ALLOCATABLE or POINTER attribute, and corresponds to 
an actual argument that
* has the ALLOCATABLE attribute and is not allocated, or
* has the POINTER attribute and is disassociated."

That mostly matches the current "present()" checks, except for 
descriptors (where the data element is NULL) and for directly passing 
EXPR_NULL. (At least I read it such that passing NULL() is allowed.) 
Thus, removing some checks - and changes for EXPR_NULL and assumed-shape 
arrays was all what was needed.

I also added a check that NULL() is not used for allocatable or 
non-optional dummies.

Build and regtested on x86-64-linux. OK for the trunk?

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

Index: gcc/fortran/trans-expr.c
===================================================================
--- gcc/fortran/trans-expr.c	(Revision 163252)
+++ gcc/fortran/trans-expr.c	(Arbeitskopie)
@@ -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, gf
 		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)
 	{
Index: gcc/fortran/interface.c
===================================================================
--- gcc/fortran/interface.c	(Revision 163252)
+++ gcc/fortran/interface.c	(Arbeitskopie)
@@ -1584,7 +1589,8 @@ compare_parameter (gfc_symbol *formal, g
   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)))
     {
@@ -1999,6 +2005,20 @@ compare_actual_formal (gfc_actual_arglis
 		       "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))
Index: gcc/testsuite/gfortran.dg/optional_absent_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/optional_absent_1.f90	(Revision 0)
+++ gcc/testsuite/gfortran.dg/optional_absent_1.f90	(Revision 0)
@@ -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
Index: gcc/testsuite/gfortran.dg/null_actual.f90
===================================================================
--- gcc/testsuite/gfortran.dg/null_actual.f90	(Revision 0)
+++ gcc/testsuite/gfortran.dg/null_actual.f90	(Revision 0)
@@ -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