@@ -4357,6 +4357,9 @@ gfc_check_null (gfc_expr *mold)
if (mold == NULL)
return true;
+ if (mold->expr_type == EXPR_NULL)
+ return true;
+
if (!variable_check (mold, 0, true))
return false;
@@ -5189,7 +5192,7 @@ is_c_interoperable (gfc_expr *expr, const char **msg, bool c_loc, bool c_f_ptr)
{
*msg = NULL;
- if (expr->expr_type == EXPR_NULL)
+ if (expr->expr_type == EXPR_NULL && expr->ts.type == BT_UNKNOWN)
{
*msg = "NULL() is not interoperable";
return false;
@@ -2387,6 +2387,8 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
gfc_component *ppc;
bool codimension = false;
gfc_array_spec *formal_as;
+ bool pointer_arg, allocatable_arg;
+ bool pre2018 = ((gfc_option.allow_std & GFC_STD_F2018) == 0);
/* If the formal arg has type BT_VOID, it's to one of the iso_c_binding
procs c_f_pointer or c_f_procpointer, and we need to accept most
@@ -2564,13 +2566,20 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
}
}
+ pointer_arg = gfc_expr_attr (actual).pointer;
+ allocatable_arg = gfc_expr_attr (actual).allocatable;
+
/* F08: 12.5.2.5 Allocatable and pointer dummy variables. However, this
is necessary also for F03, so retain error for both.
+ F2018:15.5.2.5 relaxes this constraint to same attributes.
NOTE: Other type/kind errors pre-empt this error. Since they are F03
compatible, no attempt has been made to channel to this one. */
if (UNLIMITED_POLY (formal) && !UNLIMITED_POLY (actual)
&& (CLASS_DATA (formal)->attr.allocatable
- ||CLASS_DATA (formal)->attr.class_pointer))
+ || CLASS_DATA (formal)->attr.class_pointer)
+ && (pre2018
+ || (allocatable_arg && CLASS_DATA (formal)->attr.allocatable)
+ || (pointer_arg && CLASS_DATA (formal)->attr.class_pointer)))
{
if (where)
gfc_error ("Actual argument to %qs at %L must be unlimited "
@@ -2710,7 +2719,8 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
rank_check = where != NULL && !is_elemental && formal_as
&& (formal_as->type == AS_ASSUMED_SHAPE
|| formal_as->type == AS_DEFERRED)
- && actual->expr_type != EXPR_NULL;
+ && !(actual->expr_type == EXPR_NULL
+ && actual->ts.type == BT_UNKNOWN);
/* Skip rank checks for NO_ARG_CHECK. */
if (formal->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK))
@@ -3184,8 +3194,10 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
gfc_array_ref *actual_arr_ref;
gfc_array_spec *fas, *aas;
bool pointer_dummy, pointer_arg, allocatable_arg;
+ bool procptr_dummy, optional_dummy, allocatable_dummy;
bool ok = true;
+ bool pre2018 = ((gfc_option.allow_std & GFC_STD_F2018) == 0);
actual = *ap;
@@ -3296,15 +3308,66 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
&& a->expr->ts.type != BT_ASSUMED)
gfc_find_vtab (&a->expr->ts);
+ /* Checks for NULL() actual arguments without MOLD. */
+ if (a->expr->expr_type == EXPR_NULL && a->expr->ts.type == BT_UNKNOWN)
+ {
+ /* Interp J3/22-146:
+ "If the context of the reference to NULL is an <actual argument>
+ corresponding to an <assumed-rank> dummy argument, MOLD shall be
+ present." */
+ fas = (f->sym->ts.type == BT_CLASS && CLASS_DATA (f->sym)
+ ? CLASS_DATA (f->sym)->as
+ : f->sym->as);
+ if (fas && fas->type == AS_ASSUMED_RANK)
+ {
+ gfc_error ("Intrinsic %<NULL()%> without %<MOLD%> argument "
+ "at %L passed to assumed-rank dummy %qs",
+ &a->expr->where, f->sym->name);
+ ok = false;
+ goto match;
+ }
+
+ /* Asummed-length dummy argument. */
+ if (f->sym->ts.type == BT_CHARACTER
+ && !f->sym->ts.deferred
+ && f->sym->ts.u.cl
+ && f->sym->ts.u.cl->length == NULL)
+ {
+ gfc_error ("Intrinsic %<NULL()%> without %<MOLD%> argument "
+ "at %L passed to assumed-length dummy %qs",
+ &a->expr->where, f->sym->name);
+ ok = false;
+ goto match;
+ }
+ }
+
+ /* Allow passing of NULL() as disassociated pointer, procedure
+ pointer, or unallocated allocatable (F2008+) to a respective dummy
+ argument. */
+ pointer_dummy = ((f->sym->ts.type != BT_CLASS
+ && f->sym->attr.pointer)
+ || (f->sym->ts.type == BT_CLASS
+ && CLASS_DATA (f->sym)->attr.class_pointer));
+
+ procptr_dummy = ((f->sym->ts.type != BT_CLASS
+ && f->sym->attr.proc_pointer)
+ || (f->sym->ts.type == BT_CLASS
+ && CLASS_DATA (f->sym)->attr.proc_pointer));
+
+ optional_dummy = f->sym->attr.optional;
+
+ allocatable_dummy = ((f->sym->ts.type != BT_CLASS
+ && f->sym->attr.allocatable)
+ || (f->sym->ts.type == BT_CLASS
+ && CLASS_DATA (f->sym)->attr.allocatable));
+
if (a->expr->expr_type == EXPR_NULL
- && ((f->sym->ts.type != BT_CLASS && !f->sym->attr.pointer
- && (f->sym->attr.allocatable || !f->sym->attr.optional
- || (gfc_option.allow_std & GFC_STD_F2008) == 0))
- || (f->sym->ts.type == BT_CLASS
- && !CLASS_DATA (f->sym)->attr.class_pointer
- && (CLASS_DATA (f->sym)->attr.allocatable
- || !f->sym->attr.optional
- || (gfc_option.allow_std & GFC_STD_F2008) == 0))))
+ && !pointer_dummy
+ && !procptr_dummy
+ && !(optional_dummy
+ && (gfc_option.allow_std & GFC_STD_F2008) != 0)
+ && !(allocatable_dummy
+ && (gfc_option.allow_std & GFC_STD_F2008) != 0))
{
if (where
&& (!f->sym->attr.optional
@@ -3409,6 +3472,9 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
if (f->sym->ts.type == BT_CLASS)
goto skip_size_check;
+ if (a->expr->expr_type == EXPR_NULL)
+ goto skip_size_check;
+
actual_size = get_expr_storage_size (a->expr);
formal_size = get_sym_storage_size (f->sym);
if (actual_size != 0 && actual_size < formal_size
@@ -3606,6 +3672,71 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
}
}
+ /* Check conditions on allocatable and pointer dummy variables:
+
+ "The actual argument shall be polymorphic if and only if the
+ associated dummy argument is polymorphic, and either both the
+ actual and dummy arguments shall be unlimited polymorphic, or the
+ declared type of the actual argument shall be the same as the
+ declared type of the dummy argument."
+
+ with a minor difference from F2008:15.5.2.5 to F2018:15.5.2.5,
+ where the latter applies only to same (ALLOCATABLE or POINTER)
+ attributes. Note that checks related to unlimited polymorphism
+ are also done in compare_parameter(). */
+ if ((pointer_dummy || allocatable_dummy)
+ && (pointer_arg || allocatable_arg)
+ && (pre2018
+ || (pointer_dummy && pointer_arg)
+ || (allocatable_dummy && allocatable_arg))
+ && (f->sym->ts.type == BT_CLASS
+ || a->expr->ts.type == BT_CLASS))
+ {
+ if (f->sym->ts.type == BT_CLASS && a->expr->ts.type != BT_CLASS
+ && pointer_dummy)
+ {
+ if (where)
+ gfc_error ("Actual argument to %qs at %L must be a "
+ "CLASS POINTER",
+ f->sym->name, &a->expr->where);
+ ok = false;
+ goto match;
+ }
+
+ if (f->sym->ts.type != BT_CLASS && a->expr->ts.type == BT_CLASS
+ && pointer_arg)
+ {
+ if (where)
+ gfc_error ("Actual argument to %qs at %L cannot be a "
+ "CLASS POINTER",
+ f->sym->name, &a->expr->where);
+ ok = false;
+ goto match;
+ }
+
+ if (f->sym->ts.type == BT_CLASS && a->expr->ts.type != BT_CLASS
+ && allocatable_dummy)
+ {
+ if (where)
+ gfc_error ("Actual argument to %qs at %L must be a "
+ "CLASS ALLOCATABLE",
+ f->sym->name, &a->expr->where);
+ ok = false;
+ goto match;
+ }
+
+ if (f->sym->ts.type != BT_CLASS && a->expr->ts.type == BT_CLASS
+ && allocatable_arg)
+ {
+ if (where)
+ gfc_error ("Actual argument to %qs at %L cannot be a "
+ "CLASS ALLOCATABLE",
+ f->sym->name, &a->expr->where);
+ ok = false;
+ goto match;
+ }
+ }
+
/* Fortran 2008, C1242. */
if (f->sym->attr.pointer && gfc_is_coindexed (a->expr))
@@ -6288,16 +6288,37 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
&& (fsym->ts.type != BT_CLASS
|| !CLASS_DATA (fsym)->attr.class_pointer))
{
- /* Pass a NULL pointer to denote an absent arg. */
- gcc_assert (fsym->attr.optional && !fsym->attr.allocatable
- && (fsym->ts.type != BT_CLASS
- || !CLASS_DATA (fsym)->attr.allocatable));
- gfc_init_se (&parmse, NULL);
- parmse.expr = null_pointer_node;
- if (arg->associated_dummy
- && gfc_dummy_arg_get_typespec (*arg->associated_dummy).type
- == BT_CHARACTER)
- parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
+ if ((fsym->ts.type != BT_CLASS
+ && fsym->attr.allocatable)
+ || (fsym->ts.type == BT_CLASS
+ && CLASS_DATA (fsym)->attr.allocatable))
+ {
+ /* Pass descriptor equivalent to an unallocated allocatable
+ actual argument. */
+ if (e->rank != 0)
+ gfc_internal_error ("gfc_conv_procedure_call() TODO: "
+ "NULL(allocatable(rank != 0))");
+ /* Scalar version below. */
+ gfc_init_se (&parmse, NULL);
+ gfc_conv_expr_reference (&parmse, e);
+ tmp = parmse.expr;
+ if (TREE_CODE (tmp) == ADDR_EXPR)
+ tmp = TREE_OPERAND (tmp, 0);
+ parmse.expr = gfc_conv_scalar_to_descriptor (&parmse, tmp,
+ fsym->attr);
+ parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr);
+ }
+ else
+ {
+ /* Pass a NULL pointer to denote an absent optional arg. */
+ gcc_assert (fsym->attr.optional);
+ gfc_init_se (&parmse, NULL);
+ parmse.expr = null_pointer_node;
+ if (arg->associated_dummy
+ && gfc_dummy_arg_get_typespec (*arg->associated_dummy).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)
@@ -6852,7 +6873,9 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
we can assign it to the data field. */
if (fsym && fsym->as && fsym->as->type == AS_ASSUMED_RANK
- && fsym->ts.type != BT_CLASS && e->expr_type != EXPR_NULL)
+ && fsym->ts.type != BT_CLASS
+ && !(e->expr_type == EXPR_NULL
+ && e->ts.type == BT_UNKNOWN))
{
tmp = parmse.expr;
if (TREE_CODE (tmp) == ADDR_EXPR)