diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 931b908a16e..73b6ffd870c 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -1673,6 +1673,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 */ @@ -3248,7 +3251,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 */ @@ -3273,6 +3276,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); diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c index f4dfcf77e0b..07b953abfc8 100644 --- a/gcc/fortran/intrinsic.c +++ b/gcc/fortran/intrinsic.c @@ -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. */ diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index df1e8965daa..a112c813124 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -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. */ diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index 8729bc12152..e0afc10d105 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -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 *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"); diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index 17f3ccc1d4e..b15ea667411 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -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;