diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 71d5c670e55..b556e7598a0 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -2075,7 +2075,8 @@ get_proc_pointer_decl (gfc_symbol *sym) /* Get a basic decl for an external function. */ tree -gfc_get_extern_function_decl (gfc_symbol * sym, gfc_actual_arglist *actual_args) +gfc_get_extern_function_decl (gfc_symbol * sym, gfc_actual_arglist *actual_args, + const char *fnspec) { tree type; tree fndecl; @@ -2287,7 +2288,8 @@ module_sym: mangled_name = gfc_sym_mangled_function_id (sym); } - type = gfc_get_function_type (sym, actual_args); + type = gfc_get_function_type (sym, actual_args, fnspec); + fndecl = build_decl (input_location, FUNCTION_DECL, name, type); diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index d17b623924c..bcc13ce79c6 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -40,6 +40,8 @@ along with GCC; see the file COPYING3. If not see #include "trans-types.h" #include "trans-array.h" #include "dependency.h" /* For CAF array alias analysis. */ +#include "attribs.h" + /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */ /* This maps Fortran intrinsic math functions to external library or GCC @@ -4257,10 +4259,69 @@ remove_empty_actual_arguments (gfc_actual_arglist **ap) } } +#define MAX_SPEC_ARG 12 + +/* Make up an fn spec that's right for intrinsic functions that we + want to call. */ + +static char * +intrinsic_fnspec (gfc_expr *expr) +{ + static char fnspec_buf[MAX_SPEC_ARG*2+1]; + char *fp; + int i; + int num_char_args; + +#define ADD_CHAR(c) do { *fp++ = c; *fp++ = ' '; } while(0) + + /* Set the fndecl. */ + fp = fnspec_buf; + /* Function return value. FIXME: Check if the second letter could + be something other than a space, for further optimization. */ + ADD_CHAR ('.'); + if (expr->rank == 0) + { + if (expr->ts.type == BT_CHARACTER) + { + ADD_CHAR ('w'); /* Address of character. */ + ADD_CHAR ('.'); /* Length of character. */ + } + } + else + ADD_CHAR ('w'); /* Return value is a descriptor. */ + + num_char_args = 0; + for (gfc_actual_arglist *a = expr->value.function.actual; a; a = a->next) + { + if (a->expr == NULL) + continue; + + if (a->name && strcmp (a->name,"%VAL") == 0) + ADD_CHAR ('.'); + else + { + if (a->expr->rank > 0) + ADD_CHAR ('r'); + else + ADD_CHAR ('R'); + } + num_char_args += a->expr->ts.type == BT_CHARACTER; + gcc_assert (fp - fnspec_buf + num_char_args <= MAX_SPEC_ARG*2); + } + + for (i = 0; i < num_char_args; i++) + ADD_CHAR ('.'); + + *fp = '\0'; + return fnspec_buf; +} + +#undef MAX_SPEC_ARG +#undef ADD_CHAR + /* 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). */ + arguments should be removed. */ gfc_symbol * specific_intrinsic_symbol (gfc_expr *expr) @@ -4278,14 +4339,19 @@ specific_intrinsic_symbol (gfc_expr *expr) 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); + = gfc_get_extern_function_decl (sym, expr->value.function.actual, + intrinsic_fnspec (expr)); } + remove_empty_actual_arguments (&(expr->value.function.actual)); return sym; } -/* Generate a call to an external intrinsic function. */ +/* Generate a call to an external intrinsic function. FIXME: So far, + this only works for functions which are called with well-defined + types; CSHIFT and friends will come later. */ + static void gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr) { @@ -4302,11 +4368,16 @@ gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr) switch (expr->value.function.isym->id) { + case GFC_ISYM_ANY: + case GFC_ISYM_ALL: case GFC_ISYM_FINDLOC: case GFC_ISYM_MAXLOC: case GFC_ISYM_MINLOC: case GFC_ISYM_MAXVAL: case GFC_ISYM_MINVAL: + case GFC_ISYM_NORM2: + case GFC_ISYM_PRODUCT: + case GFC_ISYM_SUM: specific_symbol = true; break; default: diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index b7129dcbe6d..281cc7d34ab 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -3009,7 +3009,8 @@ create_fn_spec (gfc_symbol *sym, tree fntype) } tree -gfc_get_function_type (gfc_symbol * sym, gfc_actual_arglist *actual_args) +gfc_get_function_type (gfc_symbol * sym, gfc_actual_arglist *actual_args, + const char *fnspec) { tree type; vec *typelist = NULL; @@ -3193,7 +3194,19 @@ arg_type_list_done: type = build_varargs_function_type_vec (type, typelist); else type = build_function_type_vec (type, typelist); - type = create_fn_spec (sym, type); + + /* If we were passed an fn spec, add it here, otherwise determine it from + the formal arguments. */ + if (fnspec) + { + tree tmp; + int spec_len = strlen (fnspec); + tmp = build_tree_list (NULL_TREE, build_string (spec_len, fnspec)); + tmp = tree_cons (get_identifier ("fn spec"), tmp, TYPE_ATTRIBUTES (type)); + type = build_type_attribute_variant (type, tmp); + } + else + type = create_fn_spec (sym, type); return type; } diff --git a/gcc/fortran/trans-types.h b/gcc/fortran/trans-types.h index 56074f1b83b..1b59287996b 100644 --- a/gcc/fortran/trans-types.h +++ b/gcc/fortran/trans-types.h @@ -88,7 +88,8 @@ tree gfc_sym_type (gfc_symbol *); tree gfc_typenode_for_spec (gfc_typespec *, int c = 0); int gfc_copy_dt_decls_ifequal (gfc_symbol *, gfc_symbol *, bool); -tree gfc_get_function_type (gfc_symbol *, gfc_actual_arglist *args = NULL); +tree gfc_get_function_type (gfc_symbol *, gfc_actual_arglist *args = NULL, + const char *fnspec = NULL); tree gfc_type_for_size (unsigned, int); tree gfc_type_for_mode (machine_mode, int); diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 16b4215605e..6e417c43e8c 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -608,7 +608,8 @@ tree gfc_get_label_decl (gfc_st_label *); /* Return the decl for an external function. */ tree gfc_get_extern_function_decl (gfc_symbol *, - gfc_actual_arglist *args = NULL); + gfc_actual_arglist *args = NULL, + const char *fnspec = NULL); /* Return the decl for a function. */ tree gfc_get_function_decl (gfc_symbol *);