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.
===================================================================
@@ -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)
{
===================================================================
@@ -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))
===================================================================
@@ -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
===================================================================
@@ -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