[Patch, fortran] PR40011 - Problems with -fwhole-file

[Paul Richard Thomas <paul dot richard dot thomas at gmail dot com>]

The attached is a first step towards putting the whole file scope
option onto a good footing.  The patch is mostly what has already been
posted up to an improvement to the modification to allow type
cheating,  This is fixed by producing warnings instead of errors for
std=legacy and -fwhole-file, without pedantic.  If pedantic is set,
errors are produced.  The testcases test the fixes for the first batch
of problems.

The next step is to grab the backend_decls for module procedures.  I
am working on this now.

The patch now allows anything that I have to hand to be compiled under
-fwhole-file.

Bootstrapped and regtested on FC9/x86_i64 - OK for trunk

Paul

2009-05-16  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/40011
	* gfortran.h : Add prototype for void gfc_errors_to_warnings.
	* error.c (gfc_error): If warnings_not_errors is set, produce a
	warning.
	(gfc_errors_to_warnings): New function.
	options.c (gfc_post_options): If pedantic and whole_file, set
	flag_whole_file to 2.
	resolve.c (not_in_recursive, not_entry_self_reference): New
	functions.
	(resolve_global_procedure): Modify conditions for resolving the
	procedures referenced and checking their interfaces.  Add error
	for missing interface or wrong rank.
	(gfc_resolve): Stack cs_base and flag partially resolved name
	spaces.
	trans-decl.c (gfc_get_extern_function_decl): Do not try to get
	backend_decls of procedures that are use associated, since they
	might have an explicit interface in the module.

2009-05-16  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/40011
	* gfortran.dg/whole_file_7.f90: New test.
	* gfortran.dg/whole_file_8.f90: New test.
	* gfortran.dg/whole_file_9.f90: New test.
	* gfortran.dg/whole_file_10.f90: New test.

Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h	(revision 147611)
+++ gcc/fortran/gfortran.h	(working copy)
@@ -2244,6 +2244,7 @@
 void gfc_free_error (gfc_error_buf *);
 
 void gfc_get_errors (int *, int *);
+void gfc_errors_to_warnings (int);
 
 /* arith.c */
 void gfc_arith_init_1 (void);
Index: gcc/fortran/error.c
===================================================================
--- gcc/fortran/error.c	(revision 147611)
+++ gcc/fortran/error.c	(working copy)
@@ -32,6 +32,8 @@
 
 static int suppress_errors = 0;
 
+static int warnings_not_errors = 0; 
+
 static int terminal_width, buffer_flag, errors, warnings;
 
 static gfc_error_buf error_buffer, warning_buffer, *cur_error_buffer;
@@ -863,6 +865,9 @@
 {
   va_list argp;
 
+  if (warnings_not_errors)
+    goto warning;
+
   if (suppress_errors)
     return;
 
@@ -878,6 +883,30 @@
 
   if (buffer_flag == 0)
     gfc_increment_error_count();
+
+  return;
+
+warning:
+
+  if (inhibit_warnings)
+    return;
+
+  warning_buffer.flag = 1;
+  warning_buffer.index = 0;
+  cur_error_buffer = &warning_buffer;
+
+  va_start (argp, nocmsgid);
+  error_print (_("Warning:"), _(nocmsgid), argp);
+  va_end (argp);
+
+  error_char ('\0');
+
+  if (buffer_flag == 0)
+  {
+    warnings++;
+    if (warnings_are_errors)
+      gfc_increment_error_count();
+  }
 }
 
 
@@ -955,6 +984,7 @@
 gfc_clear_error (void)
 {
   error_buffer.flag = 0;
+  warnings_not_errors = 0;
 }
 
 
@@ -1042,3 +1072,12 @@
   if (e != NULL)
     *e = errors;
 }
+
+
+/* Switch errors into warnings.  */
+
+void
+gfc_errors_to_warnings (int f)
+{
+  warnings_not_errors = (f == 1) ? 1 : 0;
+}
Index: gcc/fortran/options.c
===================================================================
--- gcc/fortran/options.c	(revision 147611)
+++ gcc/fortran/options.c	(working copy)
@@ -368,6 +368,9 @@
       gfc_option.warn_tabs = 0;
     }
 
+  if (pedantic && gfc_option.flag_whole_file)
+    gfc_option.flag_whole_file = 2;
+
   gfc_cpp_post_options ();
 
 /* FIXME: return gfc_cpp_preprocess_only ();
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c	(revision 147611)
+++ gcc/fortran/resolve.c	(working copy)
@@ -1645,6 +1645,47 @@
    The namespace of the gsymbol is resolved and then, once this is
    done the interface is checked.  */
 
+
+static bool
+not_in_recursive (gfc_symbol *sym, gfc_namespace *gsym_ns)
+{
+  if (!gsym_ns->proc_name->attr.recursive)
+    return true;
+
+  if (sym->ns == gsym_ns)
+    return false;
+
+  if (sym->ns->parent && sym->ns->parent == gsym_ns)
+    return false;
+
+  return true;
+}
+
+static bool
+not_entry_self_reference  (gfc_symbol *sym, gfc_namespace *gsym_ns)
+{
+  if (gsym_ns->entries)
+    {
+      gfc_entry_list *entry = gsym_ns->entries;
+
+      for (; entry; entry = entry->next)
+	{
+	  if (strcmp (sym->name, entry->sym->name) == 0)
+	    {
+	      if (strcmp (gsym_ns->proc_name->name,
+			  sym->ns->proc_name->name) == 0)
+		return false;
+
+	      if (sym->ns->parent
+		  && strcmp (gsym_ns->proc_name->name,
+			     sym->ns->parent->proc_name->name) == 0)
+		return false;
+	    }
+	}
+    }
+  return true;
+}
+
 static void
 resolve_global_procedure (gfc_symbol *sym, locus *where,
 			  gfc_actual_arglist **actual, int sub)
@@ -1663,7 +1704,10 @@
   if (gfc_option.flag_whole_file
 	&& gsym->type != GSYM_UNKNOWN
 	&& gsym->ns
-	&& gsym->ns->proc_name)
+	&& gsym->ns->resolved != -1
+	&& gsym->ns->proc_name
+	&& not_in_recursive (sym, gsym->ns)
+	&& not_entry_self_reference (sym, gsym->ns))
     {
       /* Make sure that translation for the gsymbol occurs before
 	 the procedure currently being resolved.  */
@@ -1682,7 +1726,22 @@
       if (!gsym->ns->resolved)
 	gfc_resolve (gsym->ns);
 
+      if (gsym->ns->proc_name->attr.function
+	    && gsym->ns->proc_name->as
+	    && gsym->ns->proc_name->as->rank
+	    && (!sym->as || sym->as->rank != gsym->ns->proc_name->as->rank))
+	gfc_error ("The reference to function '%s' at %L either needs an "
+		   "explicit INTERFACE or the rank is incorrect", sym->name,
+		   where);
+
+      if (gfc_option.flag_whole_file == 1
+	    || gfc_option.warn_std & GFC_STD_F77
+	    || gfc_option.warn_std & GFC_STD_LEGACY)
+	gfc_errors_to_warnings (1);
+
       gfc_procedure_use (gsym->ns->proc_name, actual, where);
+
+      gfc_errors_to_warnings (0);
     }
 
   if (gsym->type == GSYM_UNKNOWN)
@@ -10887,15 +10946,19 @@
 gfc_resolve (gfc_namespace *ns)
 {
   gfc_namespace *old_ns;
+  code_stack *old_cs_base;
 
   if (ns->resolved)
     return;
 
+  ns->resolved = -1;
   old_ns = gfc_current_ns;
+  old_cs_base = cs_base;
 
   resolve_types (ns);
   resolve_codes (ns);
 
   gfc_current_ns = old_ns;
+  cs_base = old_cs_base;
   ns->resolved = 1;
 }
Index: gcc/fortran/trans-decl.c
===================================================================
--- gcc/fortran/trans-decl.c	(revision 147611)
+++ gcc/fortran/trans-decl.c	(working copy)
@@ -1291,6 +1291,7 @@
   gsym =  gfc_find_gsymbol (gfc_gsym_root, sym->name);
 
   if (gfc_option.flag_whole_file
+	&& !sym->attr.use_assoc
 	&& !sym->backend_decl
 	&& gsym && gsym->ns
 	&& ((gsym->type == GSYM_SUBROUTINE) || (gsym->type == GSYM_FUNCTION))
Index: gcc/testsuite/gfortran.dg/whole_file_10.f90
===================================================================
--- gcc/testsuite/gfortran.dg/whole_file_10.f90	(revision 0)
+++ gcc/testsuite/gfortran.dg/whole_file_10.f90	(revision 0)
@@ -0,0 +1,33 @@
+! { dg-do compile }
+! { dg-options "-fwhole-file" }
+! Test the fix for the fifth problem in PR40011, where the
+! entries were not resolved, resulting in a segfault.
+!
+! Contributed by Dominique d'Humieres <dominiq@lps.ens.fr>
+!
+recursive function fac(i) result (res)
+  integer :: i, j, k, res
+  k = 1
+  goto 100
+entry bifac(i,j) result (res)
+  k = j
+100 continue
+  if (i < k) then
+    res = 1
+  else
+    res = i * bifac(i-k,k)
+  end if
+end function
+
+program test
+  external fac
+  external bifac
+  integer :: fac, bifac
+  print *, fac(5)
+  print *, bifac(5,2)
+  print*, fac(6)
+  print *, bifac(6,2)
+  print*, fac(0)
+  print *, bifac(1,2)
+end program test
+
Index: gcc/testsuite/gfortran.dg/whole_file_7.f90
===================================================================
--- gcc/testsuite/gfortran.dg/whole_file_7.f90	(revision 0)
+++ gcc/testsuite/gfortran.dg/whole_file_7.f90	(revision 0)
@@ -0,0 +1,34 @@
+! { dg-do compile }
+! { dg-options "-fwhole-file" }
+! Test the fixes for the first two problems in PR40011
+!
+! Contributed by Dominique d'Humieres <dominiq@lps.ens.fr>
+!
+! This function would not compile because -fwhole-file would
+! try repeatedly to resolve the function because of the self
+! reference.
+RECURSIVE FUNCTION eval_args(q)  result (r)
+  INTEGER NNODE 
+  PARAMETER (NNODE  = 10) 
+  TYPE NODE 
+    SEQUENCE 
+    INTEGER car 
+    INTEGER cdr 
+  END TYPE NODE 
+  TYPE(NODE) heap(NNODE) 
+  INTEGER r, q 
+  r = eval_args(heap(q)%cdr) 
+END FUNCTION eval_args 
+
+function test(n)
+  real, dimension(2) :: test
+  integer            :: n
+  test = n
+  return
+end function test
+
+program arr     ! The error was not picked up causing an ICE
+  real, dimension(2) :: res
+  res = test(2) ! { dg-error "needs an explicit INTERFACE" }
+  print *, res
+end program
Index: gcc/testsuite/gfortran.dg/whole_file_8.f90
===================================================================
--- gcc/testsuite/gfortran.dg/whole_file_8.f90	(revision 0)
+++ gcc/testsuite/gfortran.dg/whole_file_8.f90	(revision 0)
@@ -0,0 +1,37 @@
+! { dg-do compile }
+! { dg-options "-fwhole-file" }
+! Test the fix for the third problem in PR40011, where false
+! type/rank mismatches were found in the main program calls.
+!
+! Contributed by Dominique d'Humieres <dominiq@lps.ens.fr>
+!
+subroutine test_d(fn, val, res)
+  double precision fn
+  double precision val, res
+
+  print *, fn(val), res
+end subroutine
+
+subroutine test_c(fn, val, res)
+  complex fn
+  complex val, res
+
+  print *, fn(val), res
+end subroutine
+
+program specifics
+
+  intrinsic dcos
+  intrinsic dcosh
+  intrinsic dexp
+
+  intrinsic conjg
+
+  call test_d (dcos, 1d0, dcos(1d0))
+  call test_d (dcosh, 1d0, dcosh(1d0))
+  call test_d (dexp, 1d0, dexp(1d0))
+
+  call test_c (conjg, (1.0,1.0) , conjg((1.0,1.0)))
+
+end program
+
Index: gcc/testsuite/gfortran.dg/whole_file_9.f90
===================================================================
--- gcc/testsuite/gfortran.dg/whole_file_9.f90	(revision 0)
+++ gcc/testsuite/gfortran.dg/whole_file_9.f90	(revision 0)
@@ -0,0 +1,47 @@
+! { dg-do compile }
+! { dg-options "-fwhole-file" }
+! Test the fix for the fourth problem in PR40011, where the
+! entries were not resolved, resulting in a segfault.
+!
+! Contributed by Dominique d'Humieres <dominiq@lps.ens.fr>
+!
+program test
+interface
+  function bad_stuff(n)
+    integer :: bad_stuff (2)
+    integer :: n(2)
+  end function bad_stuff
+   recursive function rec_stuff(n) result (tmp)
+    integer :: n(2), tmp(2)
+  end function rec_stuff
+end interface
+   integer :: res(2)
+  res = bad_stuff((/-19,-30/))
+
+end program test
+
+  recursive function bad_stuff(n)
+    integer :: bad_stuff (2)
+    integer :: n(2), tmp(2), ent = 0, sent = 0
+    save ent, sent
+    ent = -1
+   entry rec_stuff(n) result (tmp)
+    if (ent == -1) then
+      sent = ent
+      ent = 0
+    end if
+    ent = ent + 1
+    tmp = 1
+    if(maxval (n) < 5) then
+      tmp = tmp + rec_stuff (n+1)
+      ent = ent - 1
+    endif
+    if (ent == 1) then
+      if (sent == -1) then
+        bad_stuff = tmp + bad_stuff (1)
+      end if
+      ent = 0
+      sent = 0
+    end if
+  end function bad_stuff
+