diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 63a3927c58e..4bddcb43aaa 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,12 @@ +2010-08-15 Tobias Burnus + + * 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 * interface.c (compare_pointer, ): Allow passing TARGETs to pointers diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index fa32c5c6999..e9d310a2444 100644 --- 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 53df2ae894f..82f67fb9c27 100644 --- 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 3cdef810b02..1065b33757f 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2010-08-15 Tobias Burnus + + * gfortran.dg/optional_absent_1.f90: New. + * gfortran.dg/null_actual.f90: New. + 2010-08-15 Tobias Burnus * gfortran.dg/pointer_target_1.f90: New. diff --git a/gcc/testsuite/gfortran.dg/null_actual.f90 b/gcc/testsuite/gfortran.dg/null_actual.f90 new file mode 100644 index 00000000000..b29e89d4898 --- /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 index 00000000000..690c30fa214 --- /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