+/* Optimize minloc(b), where b is rank 1 array, into
+ (/ minloc(b, dim=1) /), and similarly for maxloc,
+ as the latter forms are expanded inline. */
+
+static void
+optimize_minmaxloc (gfc_expr **e)
+{
+ gfc_expr *fn = *e;
+ gfc_actual_arglist *a;
+ char *name, *p;
+
+ if (fn->rank != 1
+ || fn->value.function.actual == NULL
+ || fn->value.function.actual->expr == NULL
+ || fn->value.function.actual->expr->rank != 1)
+ return;
+
+ *e = gfc_get_array_expr (fn->ts.type, fn->ts.kind, &fn->where);
+ (*e)->shape = fn->shape;
+ fn->rank = 0;
+ fn->shape = NULL;
+ gfc_constructor_append_expr (&(*e)->value.constructor, fn, &fn->where);
+
+ name = XALLOCAVEC (char, strlen (fn->value.function.name) + 1);
+ strcpy (name, fn->value.function.name);
+ p = strstr (name, "loc0");
+ p[3] = '1';
+ fn->value.function.name = gfc_get_string (name);
+ if (fn->value.function.actual->next)
+ {
+ a = fn->value.function.actual->next;
+ gcc_assert (a->expr == NULL);
+ }
+ else
+ {
+ a = gfc_get_actual_arglist ();
+ fn->value.function.actual->next = a;
+ }
+ a->expr = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
+ &fn->where);
+ mpz_set_ui (a->expr->value.integer, 1);
+}
+
+/* Callback function for code checking that we do not pass a DO variable to an
+ INTENT(OUT) or INTENT(INOUT) dummy variable. */
+
+static int
+doloop_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
+ void *data ATTRIBUTE_UNUSED)
+{
+ gfc_code *co;
+ int i;
+ gfc_formal_arglist *f;
+ gfc_actual_arglist *a;
+ gfc_code *cl;
+
+ co = *c;
+
+ /* If the doloop_list grew, we have to truncate it here. */
+
+ if ((unsigned) doloop_level < doloop_list.length())
+ doloop_list.truncate (doloop_level);
+
+ switch (co->op)
+ {
+ case EXEC_DO:
+
+ if (co->ext.iterator && co->ext.iterator->var)
+ doloop_list.safe_push (co);
+ else
+ doloop_list.safe_push ((gfc_code *) NULL);
+ break;
+
+ case EXEC_CALL:
+
+ if (co->resolved_sym == NULL)
+ break;
+
+ f = gfc_sym_get_dummy_args (co->resolved_sym);
+
+ /* Withot a formal arglist, there is only unknown INTENT,
+ which we don't check for. */
+ if (f == NULL)
+ break;
+
+ a = co->ext.actual;
+
+ while (a && f)
+ {
+ FOR_EACH_VEC_ELT (doloop_list, i, cl)
+ {
+ gfc_symbol *do_sym;
+
+ if (cl == NULL)
+ break;
+
+ do_sym = cl->ext.iterator->var->symtree->n.sym;
+
+ if (a->expr && a->expr->symtree
+ && a->expr->symtree->n.sym == do_sym)
+ {
+ if (f->sym->attr.intent == INTENT_OUT)
+ gfc_error_now_1 ("Variable '%s' at %L set to undefined "
+ "value inside loop beginning at %L as "
+ "INTENT(OUT) argument to subroutine '%s'",
+ do_sym->name, &a->expr->where,
+ &doloop_list[i]->loc,
+ co->symtree->n.sym->name);
+ else if (f->sym->attr.intent == INTENT_INOUT)
+ gfc_error_now_1 ("Variable '%s' at %L not definable inside "
+ "loop beginning at %L as INTENT(INOUT) "
+ "argument to subroutine '%s'",
+ do_sym->name, &a->expr->where,
+ &doloop_list[i]->loc,
+ co->symtree->n.sym->name);
+ }
+ }
+ a = a->next;
+ f = f->next;
+ }
+ break;
+
+ default:
+ break;
+ }
+ return 0;
+}
+
+/* Callback function for functions checking that we do not pass a DO variable
+ to an INTENT(OUT) or INTENT(INOUT) dummy variable. */
+
+static int
+do_function (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
+ void *data ATTRIBUTE_UNUSED)
+{
+ gfc_formal_arglist *f;
+ gfc_actual_arglist *a;
+ gfc_expr *expr;
+ gfc_code *dl;
+ int i;
+
+ expr = *e;
+ if (expr->expr_type != EXPR_FUNCTION)
+ return 0;
+
+ /* Intrinsic functions don't modify their arguments. */
+
+ if (expr->value.function.isym)
+ return 0;
+
+ f = gfc_sym_get_dummy_args (expr->symtree->n.sym);
+
+ /* Without a formal arglist, there is only unknown INTENT,
+ which we don't check for. */
+ if (f == NULL)
+ return 0;
+
+ a = expr->value.function.actual;
+
+ while (a && f)
+ {
+ FOR_EACH_VEC_ELT (doloop_list, i, dl)
+ {
+ gfc_symbol *do_sym;
+
+ if (dl == NULL)
+ break;
+
+ do_sym = dl->ext.iterator->var->symtree->n.sym;
+
+ if (a->expr && a->expr->symtree
+ && a->expr->symtree->n.sym == do_sym)
+ {
+ if (f->sym->attr.intent == INTENT_OUT)
+ gfc_error_now_1 ("Variable '%s' at %L set to undefined value "
+ "inside loop beginning at %L as INTENT(OUT) "
+ "argument to function '%s'", do_sym->name,
+ &a->expr->where, &doloop_list[i]->loc,
+ expr->symtree->n.sym->name);
+ else if (f->sym->attr.intent == INTENT_INOUT)
+ gfc_error_now_1 ("Variable '%s' at %L not definable inside loop"
+ " beginning at %L as INTENT(INOUT) argument to"
+ " function '%s'", do_sym->name,
+ &a->expr->where, &doloop_list[i]->loc,
+ expr->symtree->n.sym->name);
+ }
+ }
+ a = a->next;
+ f = f->next;
+ }
+
+ return 0;
+}
+
+static void
+doloop_warn (gfc_namespace *ns)
+{
+ gfc_code_walker (&ns->code, doloop_code, do_function, NULL);
+}
+
+