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 + corresponding to an 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 % without % 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 % without % 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)