re PR fortran/87689 (PowerPC64 ELFv2 function parameter passing violation)

2019-02-18  Thomas Koenig  <tkoenig@gcc.gnu.org>

    PR fortran/87689
    * trans-decl.c (gfc_get_extern_function_decl): Add argument
    actual_args and pass it through to gfc_get_function_type.
    * trans-expr.c (conv_function_val): Add argument actual_args
    and pass it on to gfc_get_extern_function_decl.
    (conv_procedure_call): Pass actual arguments to conv_function_val.
    * trans-types.c (get_formal_from_actual_arglist): New function.
    (gfc_get_function_type): Add argument actual_args.  Generate
    formal args from actual args if necessary.
    * trans-types.h (gfc_get_function_type): Add optional argument.
    * trans.h (gfc_get_extern_function_decl): Add optional argument.

2019-02-18  Thomas Koenig  <tkoenig@gcc.gnu.org>

    PR fortran/87689
    * gfortran.dg/lto/20091028-1_0.f90: Add -Wno-lto-type-mismatch to
    options.
    * gfortran.dg/lto/20091028-2_0.f90: Likewise.
    * gfortran.dg/lto/pr87689_0.f: New file.
    * gfortran.dg/lto/pr87689_1.f: New file.

From-SVN: r268992

gcc/fortran/ChangeLog

+2019-02-18  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/87689
+	* trans-decl.c (gfc_get_extern_function_decl): Add argument
+	actual_args and pass it through to gfc_get_function_type.
+	* trans-expr.c (conv_function_val): Add argument actual_args
+	and pass it on to gfc_get_extern_function_decl.
+	(conv_procedure_call): Pass actual arguments to conv_function_val.
+	* trans-types.c (get_formal_from_actual_arglist): New function.
+	(gfc_get_function_type): Add argument actual_args.  Generate
+	formal args from actual args if necessary.
+	* trans-types.h (gfc_get_function_type): Add optional argument.
+	* trans.h (gfc_get_extern_function_decl): Add optional argument.
+
 2019-02-18  Martin Liska  <mliska@suse.cz>
 
 	* decl.c (gfc_match_gcc_builtin): Add support for filtering

gcc/fortran/trans-decl.c

@@ -1962,7 +1962,7 @@ 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_get_extern_function_decl (gfc_symbol * sym, gfc_actual_arglist *actual_args)
 {
   tree type;
   tree fndecl;
@@ -2135,7 +2135,7 @@ module_sym:
       mangled_name = gfc_sym_mangled_function_id (sym);
     }
 
-  type = gfc_get_function_type (sym);
+  type = gfc_get_function_type (sym, actual_args);
   fndecl = build_decl (input_location,
 		       FUNCTION_DECL, name, type);
 

gcc/fortran/trans-expr.c

@@ -3895,7 +3895,8 @@ conv_base_obj_fcn_val (gfc_se * se, tree base_object, gfc_expr * expr)
 
 
 static void
-conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr)
+conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr,
+		   gfc_actual_arglist *actual_args)
 {
   tree tmp;
 
@@ -3913,7 +3914,7 @@ conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr)
   else
     {
       if (!sym->backend_decl)
-	sym->backend_decl = gfc_get_extern_function_decl (sym);
+	sym->backend_decl = gfc_get_extern_function_decl (sym, actual_args);
 
       TREE_USED (sym->backend_decl) = 1;
 
@@ -6580,7 +6581,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 
   /* Generate the actual call.  */
   if (base_object == NULL_TREE)
-    conv_function_val (se, sym, expr);
+    conv_function_val (se, sym, expr, args);
   else
     conv_base_obj_fcn_val (se, base_object, expr);
 

gcc/fortran/trans-types.c

@@ -2970,9 +2970,54 @@ create_fn_spec (gfc_symbol *sym, tree fntype)
   return build_type_attribute_variant (fntype, tmp);
 }
 
+/* Helper function - if we do not find an interface for a procedure,
+   construct it from the actual arglist.  Luckily, this can only
+   happen for call by reference, so the information we actually need
+   to provide (and which would be impossible to guess from the call
+   itself) is not actually needed.  */
+
+static void
+get_formal_from_actual_arglist (gfc_symbol *sym, gfc_actual_arglist *actual_args)
+{
+  gfc_actual_arglist *a;
+  gfc_formal_arglist **f;
+  gfc_symbol *s;
+  char name[GFC_MAX_SYMBOL_LEN + 1];
+  static int var_num;
+
+  f = &sym->formal;
+  for (a = actual_args; a != NULL; a = a->next)
+    {
+      if (a->expr)
+	{
+	  (*f) = gfc_get_formal_arglist ();
+	  snprintf (name, GFC_MAX_SYMBOL_LEN, "_formal_%d", var_num ++);
+	  gfc_get_symbol (name, NULL, &s);
+	  if (a->expr->ts.type == BT_PROCEDURE)
+	    {
+	      s->attr.flavor = FL_PROCEDURE;
+	    }
+	  else
+	    {
+	      s->ts = a->expr->ts;
+	      s->attr.flavor = FL_VARIABLE;
+	      if (a->expr->rank > 0)
+		{
+		  s->attr.dimension = 1;
+		  s->as = gfc_get_array_spec ();
+		  s->as->type = AS_ASSUMED_SIZE;
+		}
+	    }
+	  s->attr.dummy = 1;
+	  s->attr.intent = INTENT_UNKNOWN;
+	  (*f)->sym = s;
+	}
+      f = &((*f)->next);
+    }
+}
 
 tree
-gfc_get_function_type (gfc_symbol * sym)
+gfc_get_function_type (gfc_symbol * sym, gfc_actual_arglist *actual_args)
 {
   tree type;
   vec<tree, va_gc> *typelist = NULL;
@@ -3030,6 +3075,10 @@ gfc_get_function_type (gfc_symbol * sym)
 	    vec_safe_push (typelist, build_pointer_type(gfc_charlen_type_node));
 	}
     }
+  if (sym->backend_decl == error_mark_node && actual_args != NULL
+      && sym->formal == NULL && (sym->attr.proc == PROC_EXTERNAL
+				 || sym->attr.proc == PROC_UNKNOWN))
+    get_formal_from_actual_arglist (sym, actual_args);
 
   /* Build the argument types for the function.  */
   for (f = gfc_sym_get_dummy_args (sym); f; f = f->next)

gcc/fortran/trans-types.h

@@ -88,7 +88,7 @@ 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 *);
+tree gfc_get_function_type (gfc_symbol *, gfc_actual_arglist *args = NULL);
 
 tree gfc_type_for_size (unsigned, int);
 tree gfc_type_for_mode (machine_mode, int);

gcc/fortran/trans.h

@@ -580,7 +580,8 @@ void gfc_merge_block_scope (stmtblock_t * block);
 tree gfc_get_label_decl (gfc_st_label *);
 
 /* Return the decl for an external function.  */
-tree gfc_get_extern_function_decl (gfc_symbol *);
+tree gfc_get_extern_function_decl (gfc_symbol *,
+				   gfc_actual_arglist *args = NULL);
 
 /* Return the decl for a function.  */
 tree gfc_get_function_decl (gfc_symbol *);

gcc/testsuite/ChangeLog

+2019-02-18  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/87689
+	* gfortran.dg/lto/20091028-1_0.f90: Add -Wno-lto-type-mismatch to
+	options.
+	* gfortran.dg/lto/20091028-2_0.f90: Likewise.
+	* gfortran.dg/lto/pr87689_0.f: New file.
+	* gfortran.dg/lto/pr87689_1.f: New file.
+
 2019-02-18  Wilco Dijkstra  <wdijkstr@arm.com>
 
 	* g++.dg/wrappers/pr88680.C: Add -fno-short-enums.

gcc/testsuite/gfortran.dg/lto/20091028-1_0.f90

 ! { dg-lto-do link }
-! { dg-extra-ld-options "-r -nostdlib -finline-functions -flinker-output=nolto-rel" }
+! { dg-extra-ld-options "-r -nostdlib -finline-functions -flinker-output=nolto-rel -Wno-lto-type-mismatch" }
 
 SUBROUTINE int_gen_ti_header_char( hdrbuf, hdrbufsize, itypesize, &
                               DataHandle, Element, VarName, Data, code )

gcc/testsuite/gfortran.dg/lto/20091028-2_0.f90

 ! { dg-lto-do link }
-! { dg-extra-ld-options "-r -nostdlib -finline-functions -flinker-output=nolto-rel" }
+! { dg-extra-ld-options "-r -nostdlib -finline-functions -flinker-output=nolto-rel -Wno-lto-type-mismatch" }
 
 SUBROUTINE int_gen_ti_header_char( hdrbuf, hdrbufsize, itypesize, &
                               DataHandle, Element, VarName, Data, code )

gcc/testsuite/gfortran.dg/lto/pr87689_0.f

+! { dg-lto-run }
+! PR 87689 - this used to fail for POWER, plus it used to
+! give warnings about mismatches with LTO.
+! Original test case by Judicaël Grasset.
+      program main
+        implicit none
+        character :: c
+        character(len=20) :: res, doesntwork_p8
+        external doesntwork_p8
+        c = 'o'
+        res = doesntwork_p8(c,1,2,3,4,5,6)
+        if (res /= 'foo') stop 3
+      end program main

gcc/testsuite/gfortran.dg/lto/pr87689_1.f

+      function doesntwork_p8(c,a1,a2,a3,a4,a5,a6)
+        implicit none
+        character(len=20) :: doesntwork_p8
+        character :: c
+        integer :: a1,a2,a3,a4,a5,a6
+        if (a1 /= 1 .or. a2 /= 2 .or. a3 /= 3 .or. a4 /= 4 .or. a5 /= 5
+     &       .or. a6 /= 6) stop 1
+       if (c /= 'o ') stop 2
+       doesntwork_p8 = 'foo'
+       return
+       end