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
This commit is contained in:
parent
7d54ef80fe
commit
08857b6111
|
@ -1,3 +1,12 @@
|
||||||
|
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>
|
2010-08-15 Tobias Burnus <burnus@net-b.de>
|
||||||
|
|
||||||
* interface.c (compare_pointer, ): Allow passing TARGETs to pointers
|
* interface.c (compare_pointer, ): Allow passing TARGETs to pointers
|
||||||
|
|
|
@ -1589,7 +1589,8 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
|
||||||
if (rank_check || ranks_must_agree
|
if (rank_check || ranks_must_agree
|
||||||
|| (formal->attr.pointer && actual->expr_type != EXPR_NULL)
|
|| (formal->attr.pointer && actual->expr_type != EXPR_NULL)
|
||||||
|| (actual->rank != 0 && !(is_elemental || formal->attr.dimension))
|
|| (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
|
|| (actual->rank == 0 && formal->attr.dimension
|
||||||
&& gfc_is_coindexed (actual)))
|
&& gfc_is_coindexed (actual)))
|
||||||
{
|
{
|
||||||
|
@ -2004,6 +2005,20 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
|
||||||
"call at %L", where);
|
"call at %L", where);
|
||||||
return 0;
|
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,
|
if (!compare_parameter (f->sym, a->expr, ranks_must_agree,
|
||||||
is_elemental, where))
|
is_elemental, where))
|
||||||
|
|
|
@ -123,7 +123,7 @@ gfc_make_safe_expr (gfc_se * se)
|
||||||
tree
|
tree
|
||||||
gfc_conv_expr_present (gfc_symbol * sym)
|
gfc_conv_expr_present (gfc_symbol * sym)
|
||||||
{
|
{
|
||||||
tree decl;
|
tree decl, cond;
|
||||||
|
|
||||||
gcc_assert (sym->attr.dummy);
|
gcc_assert (sym->attr.dummy);
|
||||||
|
|
||||||
|
@ -136,8 +136,26 @@ gfc_conv_expr_present (gfc_symbol * sym)
|
||||||
|| GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
|
|| GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
|
||||||
decl = GFC_DECL_SAVED_DESCRIPTOR (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));
|
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);
|
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
|
else if (fsym && fsym->ts.type == BT_CLASS
|
||||||
&& e->ts.type == BT_DERIVED)
|
&& e->ts.type == BT_DERIVED)
|
||||||
{
|
{
|
||||||
|
|
|
@ -1,3 +1,8 @@
|
||||||
|
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>
|
2010-08-15 Tobias Burnus <burnus@net-b.de>
|
||||||
|
|
||||||
* gfortran.dg/pointer_target_1.f90: New.
|
* gfortran.dg/pointer_target_1.f90: New.
|
||||||
|
|
|
@ -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
|
|
@ -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
|
Loading…
Reference in New Issue