Generate correct fn specs for some Fortran library functions.

This patch works by generating the correct fn spec from the
actual arguments in specific_intrinsic_symbol, and by passing this
down via gfc_get_extern_function_decl to gfc_get_function_type.
CSHIFT remains to be done.

gcc/fortran/ChangeLog:

	PR fortran/97454
	* trans-decl.c (gfc_get_extern_function_decl): Add argument
	fnspec.
	* trans-intrinsic.c (MAX_SPEC_ARG): Define.
	(intrinsic_fnspec): New function.
	(ADD_CHAR): Define.
	(specific_intrinsic_symbol): Adjust comment. Pass
	fn spec to gfc_get_extern_function_decl.
	(gfc_conv_intrinsic_funcall): Add ANY, ALL, NORM2, PRODUCT
	and SUM intrnisic. Add FIXME for cshift et al.
	* trans-types.c	(gfc_get_function_type): Add fnspec argument,
	handle it.
	* trans-types.h (gfc_get_function_type): Add optinal fnspec
	argument.
	* trans.h (gfc_get_extern_function_decl): Likewise.

diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index 71d5c670e55d4941f20bd7816cae7c2f490d8a8d..b556e7598a0a97696435d3c859492369e26d7953 100644 (file)
--- 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 d17b623924c63cb3c04f6b86f65799cc3089e6df..bcc13ce79c625fed9d2ff91ee0969fdb3535b443 100644 (file)
--- 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 b7129dcbe6db8cf2e85203ca573a07725fe20ad7..281cc7d34ab4fded5579571e6f0338a60fd3c46c 100644 (file)
--- 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<tree, va_gc> *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 56074f1b83b26e2423826e7bb5db5da8d9bc6216..1b59287996b1953095fa9665e4446efc9e429f41 100644 (file)
--- 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 16b4215605e8810fa4f88e3ccdfa72415c5d7a74..6e417c43e8c11c0d97f9cef3b08c4943b46a54be 100644 (file)
--- 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 *);