Hi Mikael, Steve,
On 11/21/23 12:33, Mikael Morin wrote:
Harald, you mentioned the lack of GFC_STD_F2023_DEL feature group in
your first message, but I don't quite understand why you didn't add one.
It seems to me the most natural way to do this.
thanks for insisting on this variant.
In my first attack at this problem, I overlooked one place in
libgfortran.h, which I now was able to find and adjust.
Now everything falls into place.
I suggest we emit a warning by default, error with -std=f2023 (I agree
with Steve that we should push towards strict f2023 conformance), and no
diagnostic with -std=gnu or -std=f2018 or lower.
As the majority agrees on this, I accept it. The attached patch
now does this and fixes the testcases accordingly.
It seems that the solution is to fix the code in the testsuite.
Agreed, these seem to explicitly test mismatching kinds, so add an
option to prevent error.
Done.
I also fixed a few issues in the documentation in gfortran.texi .
As I currently cannot build a full compiler (see PR112643),
patch V3 is not properly regtested yet, but appears to give
results as discussed.
Comments?
Mikael
Thanks,
Harald
diff --git a/gcc/fortran/check.cc b/gcc/fortran/check.cc
index 6c45e6542f0..e5cf6a495b5 100644
--- a/gcc/fortran/check.cc
+++ b/gcc/fortran/check.cc
@@ -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;
diff --git a/gcc/fortran/interface.cc b/gcc/fortran/interface.cc
index fc4fe662eab..641edf9d059 100644
--- a/gcc/fortran/interface.cc
+++ b/gcc/fortran/interface.cc
@@ -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))
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 50c4604a025..30b941356b6 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -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)
