OSDN Git Service

2010-07-26 Tobias Burnus <burnus@net-b.de>
authorburnus <burnus@138bc75d-0d04-0410-961f-82ee72b054a4>
Tue, 27 Jul 2010 08:44:22 +0000 (08:44 +0000)
committerburnus <burnus@138bc75d-0d04-0410-961f-82ee72b054a4>
Tue, 27 Jul 2010 08:44:22 +0000 (08:44 +0000)
        PR fortran/40873
        * trans-decl.c (gfc_get_extern_function_decl): Fix generation
        for functions which are later in the same file.
        (gfc_create_function_decl, build_function_decl,
        build_entry_thunks): Add global argument.
        * trans.c (gfc_generate_module_code): Update
        gfc_create_function_decl call.
        * trans.h (gfc_create_function_decl): Update prototype.
        * resolve.c (resolve_global_procedure): Also resolve for
        IFSRC_IFBODY.

2010-07-26  Tobias Burnus  <burnus@net-b.de>

        PR fortran/40873
        * gfortran.dg/whole_file_22.f90: New test.
        * gfortran.dg/whole_file_23.f90: New test.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@162557 138bc75d-0d04-0410-961f-82ee72b054a4

gcc/fortran/ChangeLog
gcc/fortran/resolve.c
gcc/fortran/trans-decl.c
gcc/fortran/trans.c
gcc/fortran/trans.h
gcc/testsuite/ChangeLog
gcc/testsuite/gfortran.dg/whole_file_22.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/whole_file_23.f90 [new file with mode: 0644]

index cd8e6e4..7700e0b 100644 (file)
@@ -1,3 +1,16 @@
+2010-07-26  Tobias Burnus  <burnus@net-b.de>
+
+       PR fortran/40873
+       * trans-decl.c (gfc_get_extern_function_decl): Fix generation
+       for functions which are later in the same file.
+       (gfc_create_function_decl, build_function_decl,
+       build_entry_thunks): Add global argument.
+       * trans.c (gfc_generate_module_code): Update
+       gfc_create_function_decl call.
+       * trans.h (gfc_create_function_decl): Update prototype.
+       * resolve.c (resolve_global_procedure): Also resolve for
+       IFSRC_IFBODY.
+
 2010-07-26  Richard Henderson  <rth@redhat.com>
 
        PR target/44132
index fb9aadc..dab533d 100644 (file)
@@ -1816,7 +1816,8 @@ resolve_global_procedure (gfc_symbol *sym, locus *where,
     gfc_global_used (gsym, where);
 
   if (gfc_option.flag_whole_file
-       && sym->attr.if_source == IFSRC_UNKNOWN
+       && (sym->attr.if_source == IFSRC_UNKNOWN
+           || sym->attr.if_source == IFSRC_IFBODY)
        && gsym->type != GSYM_UNKNOWN
        && gsym->ns
        && gsym->ns->resolved != -1
@@ -1902,7 +1903,7 @@ resolve_global_procedure (gfc_symbol *sym, locus *where,
                   sym->name, &sym->declared_at, gfc_typename (&sym->ts),
                   gfc_typename (&def_sym->ts));
 
-      if (def_sym->formal)
+      if (def_sym->formal && sym->attr.if_source != IFSRC_IFBODY)
        {
          gfc_formal_arglist *arg = def_sym->formal;
          for ( ; arg; arg = arg->next)
@@ -1969,14 +1970,19 @@ resolve_global_procedure (gfc_symbol *sym, locus *where,
                       where);
 
          /* F2003, 12.3.1.1 (3b); F2008, 12.4.2.2 (3b) */
-         if (def_sym->result->attr.pointer
-             || def_sym->result->attr.allocatable)
+         if ((def_sym->result->attr.pointer
+              || def_sym->result->attr.allocatable)
+              && (sym->attr.if_source != IFSRC_IFBODY
+                  || def_sym->result->attr.pointer
+                       != sym->result->attr.pointer
+                  || def_sym->result->attr.allocatable
+                       != sym->result->attr.allocatable))
            gfc_error ("Function '%s' at %L with a POINTER or ALLOCATABLE "
                       "result must have an explicit interface", sym->name,
                       where);
 
          /* F2003, 12.3.1.1 (3c); F2008, 12.4.2.2 (3c)  */
-         if (sym->ts.type == BT_CHARACTER
+         if (sym->ts.type == BT_CHARACTER && sym->attr.if_source != IFSRC_IFBODY
              && def_sym->ts.u.cl->length != NULL)
            {
              gfc_charlen *cl = sym->ts.u.cl;
@@ -1992,14 +1998,14 @@ resolve_global_procedure (gfc_symbol *sym, locus *where,
        }
 
       /* F2003, 12.3.1.1 (4); F2008, 12.4.2.2 (4) */
-      if (def_sym->attr.elemental)
+      if (def_sym->attr.elemental && !sym->attr.elemental)
        {
          gfc_error ("ELEMENTAL procedure '%s' at %L must have an explicit "
                     "interface", sym->name, &sym->declared_at);
        }
 
       /* F2003, 12.3.1.1 (5); F2008, 12.4.2.2 (5) */
-      if (def_sym->attr.is_bind_c)
+      if (def_sym->attr.is_bind_c && !sym->attr.is_bind_c)
        {
          gfc_error ("Procedure '%s' at %L with BIND(C) attribute must have "
                     "an explicit interface", sym->name, &sym->declared_at);
@@ -2010,7 +2016,8 @@ resolve_global_procedure (gfc_symbol *sym, locus *where,
              && !(gfc_option.warn_std & GFC_STD_GNU)))
        gfc_errors_to_warnings (1);
 
-      gfc_procedure_use (def_sym, actual, where);
+      if (sym->attr.if_source != IFSRC_IFBODY)  
+       gfc_procedure_use (def_sym, actual, where);
 
       gfc_errors_to_warnings (0);
     }
index 4a3fcd8..5d6ea02 100644 (file)
@@ -1413,8 +1413,26 @@ gfc_get_extern_function_decl (gfc_symbol * sym)
        && !sym->backend_decl
        && gsym && gsym->ns
        && ((gsym->type == GSYM_SUBROUTINE) || (gsym->type == GSYM_FUNCTION))
-       && gsym->ns->proc_name->backend_decl)
+       && (gsym->ns->proc_name->backend_decl || !sym->attr.intrinsic))
     {
+      if (!gsym->ns->proc_name->backend_decl)
+       {
+         /* By construction, the external function cannot be
+            a contained procedure.  */
+         locus old_loc;
+         tree save_fn_decl = current_function_decl;
+
+         current_function_decl = NULL_TREE;
+         gfc_get_backend_locus (&old_loc);
+         push_cfun (cfun);
+
+         gfc_create_function_decl (gsym->ns, true);
+
+         pop_cfun ();
+         gfc_set_backend_locus (&old_loc);
+         current_function_decl = save_fn_decl;
+       }
+
       /* If the namespace has entries, the proc_name is the
         entry master.  Find the entry and use its backend_decl.
         otherwise, use the proc_name backend_decl.  */
@@ -1574,7 +1592,7 @@ gfc_get_extern_function_decl (gfc_symbol * sym)
    a master function with alternate entry points.  */
 
 static void
-build_function_decl (gfc_symbol * sym)
+build_function_decl (gfc_symbol * sym, bool global)
 {
   tree fndecl, type, attributes;
   symbol_attribute attr;
@@ -1682,7 +1700,11 @@ build_function_decl (gfc_symbol * sym)
 
   /* Layout the function declaration and put it in the binding level
      of the current function.  */
-  pushdecl (fndecl);
+
+  if (global)
+    pushdecl_top_level (fndecl);
+  else
+    pushdecl (fndecl);
 
   sym->backend_decl = fndecl;
 }
@@ -1955,7 +1977,7 @@ trans_function_start (gfc_symbol * sym)
 /* Create thunks for alternate entry points.  */
 
 static void
-build_entry_thunks (gfc_namespace * ns)
+build_entry_thunks (gfc_namespace * ns, bool global)
 {
   gfc_formal_arglist *formal;
   gfc_formal_arglist *thunk_formal;
@@ -1977,7 +1999,7 @@ build_entry_thunks (gfc_namespace * ns)
 
       thunk_sym = el->sym;
       
-      build_function_decl (thunk_sym);
+      build_function_decl (thunk_sym, global);
       create_function_arglist (thunk_sym);
 
       trans_function_start (thunk_sym);
@@ -2137,17 +2159,18 @@ build_entry_thunks (gfc_namespace * ns)
 
 
 /* Create a decl for a function, and create any thunks for alternate entry
-   points.  */
+   points. If global is true, generate the function in the global binding
+   level, otherwise in the current binding level (which can be global).  */
 
 void
-gfc_create_function_decl (gfc_namespace * ns)
+gfc_create_function_decl (gfc_namespace * ns, bool global)
 {
   /* Create a declaration for the master function.  */
-  build_function_decl (ns->proc_name);
+  build_function_decl (ns->proc_name, global);
 
   /* Compile the entry thunks.  */
   if (ns->entries)
-    build_entry_thunks (ns);
+    build_entry_thunks (ns, global);
 
   /* Now create the read argument list.  */
   create_function_arglist (ns->proc_name);
@@ -3728,7 +3751,7 @@ gfc_generate_contained_functions (gfc_namespace * parent)
       if (ns->parent != parent)
        continue;
 
-      gfc_create_function_decl (ns);
+      gfc_create_function_decl (ns, false);
     }
 
   for (ns = parent->contained; ns; ns = ns->sibling)
@@ -4364,7 +4387,7 @@ gfc_generate_function_code (gfc_namespace * ns)
 
   /* Create the declaration for functions with global scope.  */
   if (!sym->backend_decl)
-    gfc_create_function_decl (ns);
+    gfc_create_function_decl (ns, false);
 
   fndecl = sym->backend_decl;
   old_context = current_function_decl;
index 003f609..4bd4f3b 100644 (file)
@@ -1388,7 +1388,7 @@ gfc_generate_module_code (gfc_namespace * ns)
       if (!n->proc_name)
         continue;
 
-      gfc_create_function_decl (n);
+      gfc_create_function_decl (n, false);
       gcc_assert (DECL_CONTEXT (n->proc_name->backend_decl) == NULL_TREE);
       DECL_CONTEXT (n->proc_name->backend_decl) = ns->proc_name->backend_decl;
       gfc_module_add_decl (entry, n->proc_name->backend_decl);
index 9872e83..99f0dc0 100644 (file)
@@ -449,7 +449,7 @@ void gfc_allocate_lang_decl (tree);
 tree gfc_advance_chain (tree, int);
 
 /* Create a decl for a function.  */
-void gfc_create_function_decl (gfc_namespace *);
+void gfc_create_function_decl (gfc_namespace *, bool);
 /* Generate the code for a function.  */
 void gfc_generate_function_code (gfc_namespace *);
 /* Output a BLOCK DATA program unit.  */
@@ -537,7 +537,7 @@ void gfc_process_block_locals (gfc_namespace*);
 /* Output initialization/clean-up code that was deferred.  */
 void gfc_trans_deferred_vars (gfc_symbol*, gfc_wrapped_block *);
 
-/* somewhere! */
+/* In f95-lang.c.  */
 tree pushdecl (tree);
 tree pushdecl_top_level (tree);
 void pushlevel (int);
@@ -545,6 +545,8 @@ tree poplevel (int, int, int);
 tree getdecls (void);
 tree gfc_truthvalue_conversion (tree);
 tree gfc_builtin_function (tree);
+
+/* In trans-types.c.  */
 struct array_descr_info;
 bool gfc_get_array_descr_info (const_tree, struct array_descr_info *);
 
index de8eb35..9ce3878 100644 (file)
@@ -1,4 +1,10 @@
-2010-07-19  Iain Sandoe  <iains@gcc.gnu.org>
+2010-07-26  Tobias Burnus  <burnus@net-b.de>
+
+       PR fortran/40873
+       * gfortran.dg/whole_file_22.f90: New test.
+       * gfortran.dg/whole_file_23.f90: New test.
+
+2010-07-26  Iain Sandoe  <iains@gcc.gnu.org>
            Jack Howarth  <howarth@bromo.med.uc.edu>
            Richard Henderson  <rth@redhat.com>
 
diff --git a/gcc/testsuite/gfortran.dg/whole_file_22.f90 b/gcc/testsuite/gfortran.dg/whole_file_22.f90
new file mode 100644 (file)
index 0000000..4e22920
--- /dev/null
@@ -0,0 +1,38 @@
+! { dg-do link }
+! { dg-options "-fwhole-program -O3 -g" }
+!
+! PR fortran/40873
+!
+      program prog
+        call one()
+        call two()
+        call test()
+      end program prog
+      subroutine one()
+        call three()
+      end subroutine one
+      subroutine two()
+        call three()
+      end subroutine two
+      subroutine three()
+      end subroutine three
+
+SUBROUTINE c()
+ CALL a()
+END SUBROUTINE c
+
+SUBROUTINE a()
+END SUBROUTINE a
+
+MODULE M
+CONTAINS
+ SUBROUTINE b()
+   CALL c()
+ END SUBROUTINE
+END MODULE
+
+subroutine test()
+USE M
+CALL b()
+END
+
diff --git a/gcc/testsuite/gfortran.dg/whole_file_23.f90 b/gcc/testsuite/gfortran.dg/whole_file_23.f90
new file mode 100644 (file)
index 0000000..c8f66e6
--- /dev/null
@@ -0,0 +1,49 @@
+! { dg-do compile }
+! 
+! PR fortran/40873
+!
+! Failed to compile (segfault) with -fwhole-file.
+! Cf. PR 40873 comment 24; test case taken from
+! PR fortran/31867 comment 6.
+!
+
+pure integer function lensum (words, sep)
+  character (len=*), intent(in)        :: words(:), sep
+  lensum = (size (words)-1) * len (sep) + sum (len_trim (words))
+end function
+
+module util_mod
+  implicit none
+  interface
+    pure integer function lensum (words, sep)
+      character (len=*), intent(in)        :: words(:), sep
+    end function
+  end interface
+  contains
+  function join (words, sep) result(str)
+! trim and concatenate a vector of character variables, 
+! inserting sep between them
+    character (len=*), intent(in)        :: words(:), sep
+    character (len=lensum (words, sep))  :: str
+    integer                              :: i, nw
+    nw  = size (words)
+    str = ""
+    if (nw < 1) then
+      return
+    else
+      str = words(1)
+    end if
+    do i=2,nw
+      str = trim (str) // sep // words(i)
+    end do
+  end function join
+end module util_mod
+!
+program xjoin
+  use util_mod, only: join
+  implicit none
+  character (len=5) :: words(2) = (/"two  ","three"/) 
+  write (*,"(1x,'words = ',a)") "'"//join (words, "&")//"'"
+end program xjoin
+
+! { dg-final { cleanup-modules "util_mod" } }