Re: [patch, fortran] Correct fndecls for some library functions

[Thomas Koenig <tkoenig@netcologne.de>]

[-- Attachment #1: Type: text/plain, Size: 848 bytes --]

Am 27.11.20 um 16:46 schrieb Tobias Burnus:
> Hi Thomas,
> 
> On 25.11.20 12:58, Tobias Burnus wrote:
>> On 15.11.20 18:52, Thomas Koenig via Fortran wrote:
>>> +#define ADD_CHAR(c) do { *fp++ = c; *fp++ = ' '; } while(0)
>>> ...
>>> +  ADD_CHAR ('.');  /* Function return.  */
>> Shouldn't this be ".c" instead of ". " as neither global memory is
>> read nor written to?

I tried this, but it led to regressions.  Rather than try to find out
why exactly, I added a FIXME for later.

>>> +  if (expr->rank == 0)
>>> ...
>>> +  else
>>> +    ADD_CHAR ('w');  /* Return value is a descriptor.  */
>> shouldn't this be "o"?
> Scratch that - as it is an array descriptor, "w" is correct – the bounds
> etc. are not reset.
>> Otherwise, it looks good to me.

Committed as in the attached patch. Thanks for the review!

Best regards

	Thomas

[-- Attachment #2: fnspec-2.txt --]
[-- Type: text/plain, Size: 6736 bytes --]

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<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 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 *);