int ranks_must_agree, int is_elemental, locus *where)
{
gfc_ref *ref;
- bool rank_check;
+ bool rank_check, is_pointer;
/* 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
return 1;
/* At this point, we are considering a scalar passed to an array. This
- is valid (cf. F95 12.4.1.1; F2003 12.4.1.2),
+ is valid (cf. F95 12.4.1.1, F2003 12.4.1.2, and F2008 12.5.2.4),
- if the actual argument is (a substring of) an element of a
- non-assumed-shape/non-pointer array;
- - (F2003) if the actual argument is of type character. */
+ non-assumed-shape/non-pointer/non-polymorphic array; or
+ - (F2003) if the actual argument is of type character of default/c_char
+ kind. */
+
+ is_pointer = actual->expr_type == EXPR_VARIABLE
+ ? actual->symtree->n.sym->attr.pointer : false;
for (ref = actual->ref; ref; ref = ref->next)
- if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT
- && ref->u.ar.dimen > 0)
- break;
+ {
+ if (ref->type == REF_COMPONENT)
+ is_pointer = ref->u.c.component->attr.pointer;
+ else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT
+ && ref->u.ar.dimen > 0
+ && (!ref->next
+ || (ref->next->type == REF_SUBSTRING && !ref->next->next)))
+ break;
+ }
+
+ if (actual->ts.type == BT_CLASS && actual->expr_type != EXPR_NULL)
+ {
+ if (where)
+ gfc_error ("Polymorphic scalar passed to array dummy argument '%s' "
+ "at %L", formal->name, &actual->where);
+ return 0;
+ }
- /* Not an array element. */
- if (formal->ts.type == BT_CHARACTER
- && (ref == NULL
- || (actual->expr_type == EXPR_VARIABLE
- && (actual->symtree->n.sym->as->type == AS_ASSUMED_SHAPE
- || actual->symtree->n.sym->attr.pointer))))
+ if (actual->expr_type != EXPR_NULL && ref && actual->ts.type != BT_CHARACTER
+ && (is_pointer || ref->u.ar.as->type == AS_ASSUMED_SHAPE))
{
+ if (where)
+ gfc_error ("Element of assumed-shaped or pointer "
+ "array passed to array dummy argument '%s' at %L",
+ formal->name, &actual->where);
+ return 0;
+ }
+
+ if (actual->ts.type == BT_CHARACTER && actual->expr_type != EXPR_NULL
+ && (!ref || is_pointer || ref->u.ar.as->type == AS_ASSUMED_SHAPE))
+ {
+ if (formal->ts.kind != 1 && (gfc_option.allow_std & GFC_STD_GNU) == 0)
+ {
+ if (where)
+ gfc_error ("Extension: Scalar non-default-kind, non-C_CHAR-kind "
+ "CHARACTER actual argument with array dummy argument "
+ "'%s' at %L", formal->name, &actual->where);
+ return 0;
+ }
+
if (where && (gfc_option.allow_std & GFC_STD_F2003) == 0)
{
gfc_error ("Fortran 2003: Scalar CHARACTER actual argument with "
else
return 1;
}
- else if (ref == NULL && actual->expr_type != EXPR_NULL)
+
+ if (ref == NULL && actual->expr_type != EXPR_NULL)
{
if (where)
argument_rank_mismatch (formal->name, &actual->where,
return 0;
}
- if (actual->expr_type == EXPR_VARIABLE
- && actual->symtree->n.sym->as
- && (actual->symtree->n.sym->as->type == AS_ASSUMED_SHAPE
- || actual->symtree->n.sym->attr.pointer))
- {
- if (where)
- gfc_error ("Element of assumed-shaped array passed to dummy "
- "argument '%s' at %L", formal->name, &actual->where);
- return 0;
- }
-
return 1;
}
real, allocatable :: deferred(:,:,:)
real, pointer :: ptr(:,:,:)
call rlv1(deferred(1,1,1)) ! valid since contiguous
-call rlv1(ptr(1,1,1)) ! { dg-error "Element of assumed-shaped array" }
-call rlv1(assumed_sh_dummy(1,1,1)) ! { dg-error "Element of assumed-shaped array" }
-call rlv1(pointer_dummy(1,1,1)) ! { dg-error "Element of assumed-shaped array" }
+call rlv1(ptr(1,1,1)) ! { dg-error "Element of assumed-shaped or pointer array" }
+call rlv1(assumed_sh_dummy(1,1,1)) ! { dg-error "Element of assumed-shaped or pointer array" }
+call rlv1(pointer_dummy(1,1,1)) ! { dg-error "Element of assumed-shaped or pointer array" }
end
subroutine test2(assumed_sh_dummy, pointer_dummy)