+
+ /* F2003, 12.5.2.5. */
+ if (formal->ts.type == BT_CLASS
+ && (CLASS_DATA (formal)->attr.class_pointer
+ || CLASS_DATA (formal)->attr.allocatable))
+ {
+ if (actual->ts.type != BT_CLASS)
+ {
+ if (where)
+ gfc_error ("Actual argument to '%s' at %L must be polymorphic",
+ formal->name, &actual->where);
+ return 0;
+ }
+ if (CLASS_DATA (actual)->ts.u.derived
+ != CLASS_DATA (formal)->ts.u.derived)
+ {
+ if (where)
+ gfc_error ("Actual argument to '%s' at %L must have the same "
+ "declared type", formal->name, &actual->where);
+ return 0;
+ }
+ }
+
+ if (formal->attr.codimension)
+ {
+ gfc_ref *last = NULL;
+
+ if (actual->expr_type != EXPR_VARIABLE
+ || !gfc_expr_attr (actual).codimension)
+ {
+ if (where)
+ gfc_error ("Actual argument to '%s' at %L must be a coarray",
+ formal->name, &actual->where);
+ return 0;
+ }
+
+ if (gfc_is_coindexed (actual))
+ {
+ if (where)
+ gfc_error ("Actual argument to '%s' at %L must be a coarray "
+ "and not coindexed", formal->name, &actual->where);
+ return 0;
+ }
+
+ for (ref = actual->ref; ref; ref = ref->next)
+ {
+ if (ref->type == REF_ARRAY && ref->u.ar.as->corank
+ && ref->u.ar.type != AR_FULL && ref->u.ar.dimen != 0)
+ {
+ if (where)
+ gfc_error ("Actual argument to '%s' at %L must be a coarray "
+ "and thus shall not have an array designator",
+ formal->name, &ref->u.ar.where);
+ return 0;
+ }
+ if (ref->type == REF_COMPONENT)
+ last = ref;
+ }
+
+ /* F2008, 12.5.2.6. */
+ if (formal->attr.allocatable &&
+ ((last && last->u.c.component->as->corank != formal->as->corank)
+ || (!last
+ && actual->symtree->n.sym->as->corank != formal->as->corank)))
+ {
+ if (where)
+ gfc_error ("Corank mismatch in argument '%s' at %L (%d and %d)",
+ formal->name, &actual->where, formal->as->corank,
+ last ? last->u.c.component->as->corank
+ : actual->symtree->n.sym->as->corank);
+ return 0;
+ }
+
+ /* F2008, 12.5.2.8. */
+ if (formal->attr.dimension
+ && (formal->attr.contiguous || formal->as->type != AS_ASSUMED_SHAPE)
+ && !gfc_is_simply_contiguous (actual, true))
+ {
+ if (where)
+ gfc_error ("Actual argument to '%s' at %L must be simply "
+ "contiguous", formal->name, &actual->where);
+ return 0;
+ }
+ }
+
+ /* F2008, C1239/C1240. */
+ if (actual->expr_type == EXPR_VARIABLE
+ && (actual->symtree->n.sym->attr.asynchronous
+ || actual->symtree->n.sym->attr.volatile_)
+ && (formal->attr.asynchronous || formal->attr.volatile_)
+ && actual->rank && !gfc_is_simply_contiguous (actual, true)
+ && ((formal->as->type != AS_ASSUMED_SHAPE && !formal->attr.pointer)
+ || formal->attr.contiguous))
+ {
+ if (where)
+ gfc_error ("Dummy argument '%s' has to be a pointer or assumed-shape "
+ "array without CONTIGUOUS attribute - as actual argument at"
+ " %L is not simply contiguous and both are ASYNCHRONOUS "
+ "or VOLATILE", formal->name, &actual->where);
+ return 0;
+ }