aboutsummaryrefslogtreecommitdiff
path: root/gcc
diff options
context:
space:
mode:
Diffstat (limited to 'gcc')
-rw-r--r--gcc/fortran/ChangeLog9
-rw-r--r--gcc/fortran/interface.c17
-rw-r--r--gcc/fortran/trans-expr.c31
-rw-r--r--gcc/testsuite/ChangeLog5
-rw-r--r--gcc/testsuite/gfortran.dg/null_actual.f9020
-rw-r--r--gcc/testsuite/gfortran.dg/optional_absent_1.f9048
6 files changed, 127 insertions, 3 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 63a3927..4bddcb4 100644
--- 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
--- 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
--- 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
--- 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
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
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
generated by cgit v1.1 at 2024-11-04 22:29:24 +0000