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

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

    PR fortran/87689
    Backport from trunk
    * 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-03-03  Thomas Koenig  <tkoenig@gcc.gnu.org>

    PR fortran/87689
    Backport from trunk
    * 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.
    * gfortran.dg/altreturn_9_0.f90: New file.
    * gfortran.dg/altreturn_9_1.f90: New file.

From-SVN: r269350

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 0aef9299f7c744507c88cf55a5316bfc264e22a1..b30685de60bc162228dd78ebc418fd40e02c0b26 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,18 @@
+2019-03-03  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+       PR fortran/87689
+       Backport from trunk
+       * 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-23  Paul Thomas  <pault@gcc.gnu.org>
 
        Backport from trunk

diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index c43f8e46dc5146c22413e4fe067a41982c4ddacf..f524363694c23aa4a5132d9541855ee505f012f7 100644 (file)
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -1936,7 +1936,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;
@@ -2109,7 +2109,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);
 

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 8b42bbccd455c9d7d5040b234c33fb98d656b5b1..1bcc43c5546d8d872dd4689ed030034359985240 100644 (file)
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -3799,7 +3799,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;
 
@@ -3817,7 +3818,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;
 
@@ -6238,7 +6239,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);
 

diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c
index 9a96ae7b69d25c37a366d8f243962cb6c45be3db..6f8bcfdaaca12235976b0ca4281e45984b61aad2 100644 (file)
--- a/gcc/fortran/trans-types.c
+++ b/gcc/fortran/trans-types.c
@@ -2897,9 +2897,57 @@ 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)
+    {
+      (*f) = gfc_get_formal_arglist ();
+      if (a->expr)
+       {
+         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;
+       }
+      else  /* If a->expr is NULL, this is an alternate rerturn.  */
+       (*f)->sym = NULL;
+
+      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;
@@ -2957,6 +3005,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)

diff --git a/gcc/fortran/trans-types.h b/gcc/fortran/trans-types.h
index 6dba78e36715a02548dba0d75ac09bb2e6d71f22..3df9d540c15179a539ac0ee65d331d0dc40d2456 100644 (file)
--- a/gcc/fortran/trans-types.h
+++ b/gcc/fortran/trans-types.h
@@ -87,7 +87,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);

diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 4fcc389a53b850d41bf6665cbb709c2bad91955b..f3e5b94874310ddcc26a24d6576acfd56fde71fe 100644 (file)
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -578,7 +578,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 *);

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 42803d36e1e72b3c059d30eb35347cb28e86f8c8..1ea2c1fe2191fe0fb1c3934a2a07fbc20c11b20b 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,15 @@
+2019-03-03  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+       PR fortran/87689
+       Backport from trunk
+       * 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.
+       * gfortran.dg/altreturn_9_0.f90: New file.
+       * gfortran.dg/altreturn_9_1.f90: New file.
+
 2019-02-23  Paul Thomas  <pault@gcc.gnu.org>
 
        Backport from trunk

diff --git a/gcc/testsuite/gfortran.dg/altreturn_9_0.f90 b/gcc/testsuite/gfortran.dg/altreturn_9_0.f90
new file mode 100644 (file)
index 0000000..58715c7
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/altreturn_9_0.f90
@@ -0,0 +1,10 @@
+! { dg-do  run }
+! { dg-options -std=gnu }
+! { dg-additional-sources altreturn_9_1.f90 }
+! PR 89496 - wrong type for alternate return was generated
+
+program main
+  call sub(10, *10, 20)
+  stop 1
+10 continue
+end program main

diff --git a/gcc/testsuite/gfortran.dg/altreturn_9_1.f90 b/gcc/testsuite/gfortran.dg/altreturn_9_1.f90
new file mode 100644 (file)
index 0000000..9549869
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/altreturn_9_1.f90
@@ -0,0 +1,7 @@
+! { dg-do compile }
+! { dg-options "-std=gnu" }
+! See altreturn_9_0.f90
+subroutine sub(i, *, j)
+  if (i == 10 .and. j == 20) return 1
+  return
+end subroutine sub

diff --git a/gcc/testsuite/gfortran.dg/lto/20091028-1_0.f90 b/gcc/testsuite/gfortran.dg/lto/20091028-1_0.f90
index 57c1b1f60287285ad04a5471159d38034b4d25ed..f33f6c8b94674a239942aa2a5adfa0a58fe24b98 100644 (file)
--- a/gcc/testsuite/gfortran.dg/lto/20091028-1_0.f90
+++ b/gcc/testsuite/gfortran.dg/lto/20091028-1_0.f90
@@ -1,5 +1,5 @@
 ! { dg-lto-do link }
-! { dg-extra-ld-options "-r -nostdlib -finline-functions" }
+! { dg-extra-ld-options "-r -nostdlib -finline-functions -Wno-lto-type-mismatch" }
 
 SUBROUTINE int_gen_ti_header_char( hdrbuf, hdrbufsize, itypesize, &
                               DataHandle, Element, VarName, Data, code )

diff --git a/gcc/testsuite/gfortran.dg/lto/20091028-2_0.f90 b/gcc/testsuite/gfortran.dg/lto/20091028-2_0.f90
index 57c1b1f60287285ad04a5471159d38034b4d25ed..f33f6c8b94674a239942aa2a5adfa0a58fe24b98 100644 (file)
--- a/gcc/testsuite/gfortran.dg/lto/20091028-2_0.f90
+++ b/gcc/testsuite/gfortran.dg/lto/20091028-2_0.f90
@@ -1,5 +1,5 @@
 ! { dg-lto-do link }
-! { dg-extra-ld-options "-r -nostdlib -finline-functions" }
+! { dg-extra-ld-options "-r -nostdlib -finline-functions -Wno-lto-type-mismatch" }
 
 SUBROUTINE int_gen_ti_header_char( hdrbuf, hdrbufsize, itypesize, &
                               DataHandle, Element, VarName, Data, code )

diff --git a/gcc/testsuite/gfortran.dg/lto/pr87689_0.f b/gcc/testsuite/gfortran.dg/lto/pr87689_0.f
new file mode 100644 (file)
index 0000000..5beee93
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/lto/pr87689_0.f
@@ -0,0 +1,13 @@
+! { 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

diff --git a/gcc/testsuite/gfortran.dg/lto/pr87689_1.f b/gcc/testsuite/gfortran.dg/lto/pr87689_1.f
new file mode 100644 (file)
index 0000000..f293a00
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/lto/pr87689_1.f
@@ -0,0 +1,11 @@
+      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