@@ -1664,6 +1664,9 @@ typedef struct gfc_symbol
/* Set if the dummy argument of a procedure could be an array despite
being called with a scalar actual argument. */
unsigned maybe_array:1;
+ /* Set if this should be passed by value, but is not a VALUE argument
+ according to the Fortran standard. */
+ unsigned pass_as_value:1;
int refs;
struct gfc_namespace *ns; /* namespace containing this symbol */
@@ -3239,7 +3242,7 @@ bool gfc_type_is_extension_of (gfc_symbol *, gfc_symbol *);
bool gfc_type_compatible (gfc_typespec *, gfc_typespec *);
void gfc_copy_formal_args_intr (gfc_symbol *, gfc_intrinsic_sym *,
- gfc_actual_arglist *);
+ gfc_actual_arglist *, bool copy_type = false);
void gfc_free_finalizer (gfc_finalizer *el); /* Needed in resolve.c, too */
@@ -3264,6 +3267,8 @@ void gfc_intrinsic_done_1 (void);
char gfc_type_letter (bt, bool logical_equals_int = false);
gfc_symbol * gfc_get_intrinsic_sub_symbol (const char *);
+gfc_symbol *gfc_get_intrinsic_function_symbol (gfc_expr *);
+gfc_symbol *gfc_find_intrinsic_symbol (gfc_expr *);
bool gfc_convert_type (gfc_expr *, gfc_typespec *, int);
bool gfc_convert_type_warn (gfc_expr *, gfc_typespec *, int, int,
bool array = false);
@@ -122,6 +122,43 @@ gfc_get_intrinsic_sub_symbol (const char *name)
return sym;
}
+/* Get a symbol for a resolved function, with its special name. The
+ actual argument list needs to be set by the caller. */
+
+gfc_symbol *
+gfc_get_intrinsic_function_symbol (gfc_expr *expr)
+{
+ gfc_symbol *sym;
+
+ gfc_get_symbol (expr->value.function.name, gfc_intrinsic_namespace, &sym);
+ sym->attr.external = 1;
+ sym->attr.function = 1;
+ sym->attr.always_explicit = 1;
+ sym->attr.proc = PROC_INTRINSIC;
+ sym->attr.flavor = FL_PROCEDURE;
+ sym->result = sym;
+ if (expr->rank > 0)
+ {
+ sym->attr.dimension = 1;
+ sym->as = gfc_get_array_spec ();
+ sym->as->type = AS_ASSUMED_SHAPE;
+ sym->as->rank = expr->rank;
+ }
+ return sym;
+}
+
+/* Find a symbol for a resolved intrinsic procedure, return NULL if
+ not found. */
+
+gfc_symbol *
+gfc_find_intrinsic_symbol (gfc_expr *expr)
+{
+ gfc_symbol *sym;
+ gfc_find_symbol (expr->value.function.name, gfc_intrinsic_namespace,
+ 0, &sym);
+ return sym;
+}
+
/* Return a pointer to the name of a conversion function given two
typespecs. */
@@ -4645,12 +4645,13 @@ add_proc_interface (gfc_symbol *sym, ifsrc source, gfc_formal_arglist *formal)
declaration statement (see match_proc_decl()) to create the formal
args based on the args of a given named interface.
- When an actual argument list is provided, skip the absent arguments.
+ When an actual argument list is provided, skip the absent arguments
+ unless copy_type is true.
To be used together with gfc_se->ignore_optional. */
void
gfc_copy_formal_args_intr (gfc_symbol *dest, gfc_intrinsic_sym *src,
- gfc_actual_arglist *actual)
+ gfc_actual_arglist *actual, bool copy_type)
{
gfc_formal_arglist *head = NULL;
gfc_formal_arglist *tail = NULL;
@@ -4677,13 +4678,27 @@ gfc_copy_formal_args_intr (gfc_symbol *dest, gfc_intrinsic_sym *src,
act_arg = act_arg->next;
continue;
}
- act_arg = act_arg->next;
}
formal_arg = gfc_get_formal_arglist ();
gfc_get_symbol (curr_arg->name, gfc_current_ns, &(formal_arg->sym));
/* May need to copy more info for the symbol. */
- formal_arg->sym->ts = curr_arg->ts;
+ if (copy_type && act_arg->expr != NULL)
+ {
+ formal_arg->sym->ts = act_arg->expr->ts;
+ if (act_arg->expr->rank > 0)
+ {
+ formal_arg->sym->attr.dimension = 1;
+ formal_arg->sym->as = gfc_get_array_spec();
+ formal_arg->sym->as->rank = -1;
+ formal_arg->sym->as->type = AS_ASSUMED_RANK;
+ }
+ if (act_arg->name && strcmp (act_arg->name, "%VAL") == 0)
+ formal_arg->sym->pass_as_value = 1;
+ }
+ else
+ formal_arg->sym->ts = curr_arg->ts;
+
formal_arg->sym->attr.optional = curr_arg->optional;
formal_arg->sym->attr.value = curr_arg->value;
formal_arg->sym->attr.intent = curr_arg->intent;
@@ -4708,6 +4723,8 @@ gfc_copy_formal_args_intr (gfc_symbol *dest, gfc_intrinsic_sym *src,
/* Validate changes. */
gfc_commit_symbol (formal_arg->sym);
+ if (actual)
+ act_arg = act_arg->next;
}
/* Add the interface to the symbol. */
@@ -4238,12 +4238,60 @@ gfc_get_symbol_for_expr (gfc_expr * expr, bool ignore_optional)
return sym;
}
+/* Remove empty actual arguments. */
+
+static void
+remove_empty_actual_arguments (gfc_actual_arglist **ap)
+{
+ while (*ap)
+ {
+ if ((*ap)->expr == NULL)
+ {
+ gfc_actual_arglist *r = *ap;
+ *ap = r->next;
+ r->next = NULL;
+ gfc_free_actual_arglist (r);
+ }
+ else
+ ap = &((*ap)->next);
+ }
+}
+
+/* Generate the right symbol for the specific intrinsic function and
+ modify the expr accordingly. This assumes that absent optional
+ arguments should be removed. FIXME: This should be extended for
+ procedures which do not ignore optional arguments (PR 97454). */
+
+gfc_symbol *
+specific_intrinsic_symbol (gfc_expr *expr)
+{
+ gfc_symbol *sym;
+
+ sym = gfc_find_intrinsic_symbol (expr);
+ if (sym == NULL)
+ {
+ sym = gfc_get_intrinsic_function_symbol (expr);
+ sym->ts = expr->ts;
+ if (sym->ts.type == BT_CHARACTER && sym->ts.u.cl)
+ sym->ts.u.cl = gfc_new_charlen (sym->ns, NULL);
+
+ gfc_copy_formal_args_intr (sym, expr->value.function.isym,
+ expr->value.function.actual, true);
+ sym->backend_decl
+ = gfc_get_extern_function_decl (sym, expr->value.function.actual);
+ }
+ remove_empty_actual_arguments (&(expr->value.function.actual));
+
+ return sym;
+}
+
/* Generate a call to an external intrinsic function. */
static void
gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr)
{
gfc_symbol *sym;
vec<tree, va_gc> *append_args;
+ bool specific_symbol;
gcc_assert (!se->ss || se->ss->info->expr == expr);
@@ -4252,7 +4300,28 @@ gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr)
else
gcc_assert (expr->rank == 0);
- sym = gfc_get_symbol_for_expr (expr, se->ignore_optional);
+ switch (expr->value.function.isym->id)
+ {
+ case GFC_ISYM_FINDLOC:
+ case GFC_ISYM_MAXLOC:
+ case GFC_ISYM_MINLOC:
+ case GFC_ISYM_MAXVAL:
+ case GFC_ISYM_MINVAL:
+ specific_symbol = true;
+ break;
+ default:
+ specific_symbol = false;
+ }
+
+ if (specific_symbol)
+ {
+ /* Need to copy here because specific_intrinsic_symbol modifies
+ expr to omit the absent optional arguments. */
+ expr = gfc_copy_expr (expr);
+ sym = specific_intrinsic_symbol (expr);
+ }
+ else
+ sym = gfc_get_symbol_for_expr (expr, se->ignore_optional);
/* Calls to libgfortran_matmul need to be appended special arguments,
to be able to call the BLAS ?gemm functions if required and possible. */
@@ -4302,7 +4371,11 @@ gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr)
gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
append_args);
- gfc_free_symbol (sym);
+
+ if (specific_symbol)
+ gfc_free_expr (expr);
+ else
+ gfc_free_symbol (sym);
}
/* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
@@ -5081,12 +5154,10 @@ strip_kind_from_actual (gfc_actual_arglist * actual)
{
for (gfc_actual_arglist *a = actual; a; a = a->next)
{
- gfc_actual_arglist *b = a->next;
- if (b && b->name && strcmp (b->name, "kind") == 0)
+ if (a && a->name && strcmp (a->name, "kind") == 0)
{
- a->next = b->next;
- b->next = NULL;
- gfc_free_actual_arglist (b);
+ gfc_free_expr (a->expr);
+ a->expr = NULL;
}
}
}
@@ -5224,20 +5295,17 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op)
if (arrayexpr->ts.type == BT_CHARACTER)
{
- gfc_actual_arglist *a, *b;
+ gfc_actual_arglist *a;
a = actual;
strip_kind_from_actual (a);
- while (a->next)
+ while (a)
{
- b = a->next;
- if (b->expr == NULL || strcmp (b->name, "dim") == 0)
+ if (a->name && strcmp (a->name, "dim") == 0)
{
- a->next = b->next;
- b->next = NULL;
- gfc_free_actual_arglist (b);
+ gfc_free_expr (a->expr);
+ a->expr = NULL;
}
- else
- a = b;
+ a = a->next;
}
gfc_conv_intrinsic_funcall (se, expr);
return;
@@ -5996,29 +6064,16 @@ gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op)
if (arrayexpr->ts.type == BT_CHARACTER)
{
- gfc_actual_arglist *a2, *a3;
- a2 = actual->next; /* dim */
- a3 = a2->next; /* mask */
- if (a2->expr == NULL || expr->rank == 0)
+ gfc_actual_arglist *dim = actual->next;
+ if (expr->rank == 0 && dim->expr != 0)
{
- if (a3->expr == NULL)
- actual->next = NULL;
- else
- {
- actual->next = a3;
- a2->next = NULL;
- }
- gfc_free_actual_arglist (a2);
+ gfc_free_expr (dim->expr);
+ dim->expr = NULL;
}
- else
- if (a3->expr == NULL)
- {
- a2->next = NULL;
- gfc_free_actual_arglist (a3);
- }
gfc_conv_intrinsic_funcall (se, expr);
return;
}
+
type = gfc_typenode_for_spec (&expr->ts);
/* Initialize the result. */
limit = gfc_create_var (type, "limit");
@@ -2246,7 +2246,8 @@ gfc_sym_type (gfc_symbol * sym)
else
type = gfc_typenode_for_spec (&sym->ts, sym->attr.codimension);
- if (sym->attr.dummy && !sym->attr.function && !sym->attr.value)
+ if (sym->attr.dummy && !sym->attr.function && !sym->attr.value
+ && !sym->pass_as_value)
byref = 1;
else
byref = 0;