}
+/* Do the checks of the actual argument list that are specific to elemental
+ procedures. If called with c == NULL, we have a function, otherwise if
+ expr == NULL, we have a subroutine. */
+static try
+resolve_elemental_actual (gfc_expr *expr, gfc_code *c)
+{
+ gfc_actual_arglist *arg0;
+ gfc_actual_arglist *arg;
+ gfc_symbol *esym = NULL;
+ gfc_intrinsic_sym *isym = NULL;
+ gfc_expr *e = NULL;
+ gfc_intrinsic_arg *iformal = NULL;
+ gfc_formal_arglist *eformal = NULL;
+ bool formal_optional = false;
+ bool set_by_optional = false;
+ int i;
+ int rank = 0;
+
+ /* Is this an elemental procedure? */
+ if (expr && expr->value.function.actual != NULL)
+ {
+ if (expr->value.function.esym != NULL
+ && expr->value.function.esym->attr.elemental)
+ {
+ arg0 = expr->value.function.actual;
+ esym = expr->value.function.esym;
+ }
+ else if (expr->value.function.isym != NULL
+ && expr->value.function.isym->elemental)
+ {
+ arg0 = expr->value.function.actual;
+ isym = expr->value.function.isym;
+ }
+ else
+ return SUCCESS;
+ }
+ else if (c && c->ext.actual != NULL
+ && c->symtree->n.sym->attr.elemental)
+ {
+ arg0 = c->ext.actual;
+ esym = c->symtree->n.sym;
+ }
+ else
+ return SUCCESS;
+
+ /* The rank of an elemental is the rank of its array argument(s). */
+ for (arg = arg0; arg; arg = arg->next)
+ {
+ if (arg->expr != NULL && arg->expr->rank > 0)
+ {
+ rank = arg->expr->rank;
+ if (arg->expr->expr_type == EXPR_VARIABLE
+ && arg->expr->symtree->n.sym->attr.optional)
+ set_by_optional = true;
+
+ /* Function specific; set the result rank and shape. */
+ if (expr)
+ {
+ expr->rank = rank;
+ if (!expr->shape && arg->expr->shape)
+ {
+ expr->shape = gfc_get_shape (rank);
+ for (i = 0; i < rank; i++)
+ mpz_init_set (expr->shape[i], arg->expr->shape[i]);
+ }
+ }
+ break;
+ }
+ }
+
+ /* If it is an array, it shall not be supplied as an actual argument
+ to an elemental procedure unless an array of the same rank is supplied
+ as an actual argument corresponding to a nonoptional dummy argument of
+ that elemental procedure(12.4.1.5). */
+ formal_optional = false;
+ if (isym)
+ iformal = isym->formal;
+ else
+ eformal = esym->formal;
+
+ for (arg = arg0; arg; arg = arg->next)
+ {
+ if (eformal)
+ {
+ if (eformal->sym && eformal->sym->attr.optional)
+ formal_optional = true;
+ eformal = eformal->next;
+ }
+ else if (isym && iformal)
+ {
+ if (iformal->optional)
+ formal_optional = true;
+ iformal = iformal->next;
+ }
+ else if (isym)
+ formal_optional = true;
+
+ if (arg->expr != NULL
+ && arg->expr->expr_type == EXPR_VARIABLE
+ && arg->expr->symtree->n.sym->attr.optional
+ && formal_optional
+ && arg->expr->rank
+ && (set_by_optional || arg->expr->rank != rank))
+ {
+ gfc_error ("'%s' at %L is an array and OPTIONAL; it cannot "
+ "therefore be an actual argument of an ELEMENTAL "
+ "procedure unless there is a non-optional argument "
+ "with the same rank (12.4.1.5)",
+ arg->expr->symtree->n.sym->name, &arg->expr->where);
+ return FAILURE;
+ }
+ }
+
+ for (arg = arg0; arg; arg = arg->next)
+ {
+ if (arg->expr == NULL || arg->expr->rank == 0)
+ continue;
+
+ /* Being elemental, the last upper bound of an assumed size array
+ argument must be present. */
+ if (resolve_assumed_size_actual (arg->expr))
+ return FAILURE;
+
+ if (expr)
+ continue;
+
+ /* Elemental subroutine array actual arguments must conform. */
+ if (e != NULL)
+ {
+ if (gfc_check_conformance ("elemental subroutine", arg->expr, e)
+ == FAILURE)
+ return FAILURE;
+ }
+ else
+ e = arg->expr;
+ }
+
+ return SUCCESS;
+}
+
+
/* Go through each actual argument in ACTUAL and see if it can be
implemented as an inlined, non-copying intrinsic. FNSYM is the
function being called, or NULL if not known. */
const char *name;
try t;
int temp;
- int i;
sym = NULL;
if (expr->symtree)
temp = need_full_assumed_size;
need_full_assumed_size = 0;
- if (expr->value.function.actual != NULL
- && ((expr->value.function.esym != NULL
- && expr->value.function.esym->attr.elemental)
- || (expr->value.function.isym != NULL
- && expr->value.function.isym->elemental)))
- {
- /* The rank of an elemental is the rank of its array argument(s). */
- for (arg = expr->value.function.actual; arg; arg = arg->next)
- {
- if (arg->expr != NULL && arg->expr->rank > 0)
- {
- expr->rank = arg->expr->rank;
- if (!expr->shape && arg->expr->shape)
- {
- expr->shape = gfc_get_shape (expr->rank);
- for (i = 0; i < expr->rank; i++)
- mpz_init_set (expr->shape[i], arg->expr->shape[i]);
- }
- break;
- }
- }
+ if (resolve_elemental_actual (expr, NULL) == FAILURE)
+ return FAILURE;
- /* Being elemental, the last upper bound of an assumed size array
- argument must be present. */
- for (arg = expr->value.function.actual; arg; arg = arg->next)
- {
- if (arg->expr != NULL
- && arg->expr->rank > 0
- && resolve_assumed_size_actual (arg->expr))
- return FAILURE;
- }
- }
if (omp_workshare_flag
&& expr->value.function.esym
&& ! gfc_elemental (expr->value.function.esym))
if (m == MATCH_ERROR)
return FAILURE;
- if (sym->ns->parent != NULL)
+ if (sym->ns->parent != NULL && !sym->attr.use_assoc)
{
gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
if (sym != NULL)
gfc_internal_error ("resolve_subroutine(): bad function type");
}
- /* Some checks of elemental subroutines. */
- if (c->ext.actual != NULL
- && c->symtree->n.sym->attr.elemental)
- {
- gfc_actual_arglist * a;
- gfc_expr * e;
- e = NULL;
-
- for (a = c->ext.actual; a; a = a->next)
- {
- if (a->expr == NULL || a->expr->rank == 0)
- continue;
-
- /* The last upper bound of an assumed size array argument must
- be present. */
- if (resolve_assumed_size_actual (a->expr))
- return FAILURE;
-
- /* Array actual arguments must conform. */
- if (e != NULL)
- {
- if (gfc_check_conformance ("elemental subroutine", a->expr, e)
- == FAILURE)
- return FAILURE;
- }
- else
- e = a->expr;
- }
- }
+ /* Some checks of elemental subroutine actual arguments. */
+ if (resolve_elemental_actual (NULL, c) == FAILURE)
+ return FAILURE;
if (t == SUCCESS)
find_noncopying_intrinsics (c->resolved_sym, c->ext.actual);
--- /dev/null
+! { dg-do compile }
+! Check the fix for PR20893, in which actual arguments could violate:
+! "(5) If it is an array, it shall not be supplied as an actual argument to
+! an elemental procedure unless an array of the same rank is supplied as an
+! actual argument corresponding to a nonoptional dummy argument of that
+! elemental procedure." (12.4.1.5)
+!
+! Contributed by Joost VandeVondele <jv244@cam.ac.uk>
+!
+ CALL T1(1,2)
+CONTAINS
+ SUBROUTINE T1(A1,A2,A3)
+ INTEGER :: A1,A2, A4(2)
+ INTEGER, OPTIONAL :: A3(2)
+ interface
+ elemental function efoo (B1,B2,B3) result(bar)
+ INTEGER, intent(in) :: B1, B2
+ integer :: bar
+ INTEGER, OPTIONAL, intent(in) :: B3
+ end function efoo
+ end interface
+
+! check an intrinsic function
+ write(6,*) MAX(A1,A2,A3) ! { dg-error "array and OPTIONAL" }
+ write(6,*) MAX(A1,A3,A2)
+ write(6,*) MAX(A1,A4,A3)
+! check an internal elemental function
+ write(6,*) foo(A1,A2,A3) ! { dg-error "array and OPTIONAL" }
+ write(6,*) foo(A1,A3,A2)
+ write(6,*) foo(A1,A4,A3)
+! check an external elemental function
+ write(6,*) efoo(A1,A2,A3) ! { dg-error "array and OPTIONAL" }
+ write(6,*) efoo(A1,A3,A2)
+ write(6,*) efoo(A1,A4,A3)
+! check an elemental subroutine
+ call foobar (A1,A2,A3) ! { dg-error "array and OPTIONAL" }
+ call foobar (A1,A2,A4)
+ call foobar (A1,A4,A4)
+ END SUBROUTINE
+ elemental function foo (B1,B2,B3) result(bar)
+ INTEGER, intent(in) :: B1, B2
+ integer :: bar
+ INTEGER, OPTIONAL, intent(in) :: B3
+ bar = 1
+ end function foo
+ elemental subroutine foobar (B1,B2,B3)
+ INTEGER, intent(OUT) :: B1
+ INTEGER, optional, intent(in) :: B2, B3
+ B1 = 1
+ end subroutine foobar
+
+END
\ No newline at end of file
projects / platform / upstream / linaro-gcc.git / commitdiff