OSDN Git Service

2009-03-30 Paul Thomas <pault@gcc.gnu.org>
authorpault <pault@138bc75d-0d04-0410-961f-82ee72b054a4>
Mon, 30 Mar 2009 19:35:14 +0000 (19:35 +0000)
committerpault <pault@138bc75d-0d04-0410-961f-82ee72b054a4>
Mon, 30 Mar 2009 19:35:14 +0000 (19:35 +0000)
PR fortran/22571
PR fortran/26227
PR fortran/24886
* symbol.c : Add gfc_global_ns_list.
* decl.c (add_global_entry): Set the namespace ('ns') field.
* gfortran.h : Add the resolved field to gfc_namespace. Add the
namespace ('ns') field to gfc_gsymbol.  Add flag_whole_file to
gfc_option_t.  Add the prototype for gfc_free_dt_list.
* lang.opt : Add the whole-file option.
* invoke.texi : Document the whole-file option.
* resolve.c (resolve_global_procedure): If the fwhole-file
option is set, reorder gsymbols to ensure that translation is
in the right order.  Resolve the gsymbol's namespace if that
has not occurred and then check interfaces.
(resolve_function): Move call to resolve_global_procedure.
(resolve_call): The same.
(resolve_codes): Store the current labels_obstack.
(gfc_resolve) : Return if the namespace is already resolved.
trans-decl.c (gfc_get_extern_function_decl): If the whole_file
option is selected, use the backend_decl of a gsymbol, if it is
available.
parse.c (add_global_procedure, add_global_program): If the flag
whole-file is set, add the namespace to the gsymbol.
(gfc_parse_file): On -fwhole-file, put procedure namespaces on
the global namespace list.  Rearrange to do resolution of all
the procedures in a file, followed by their translation.
* options.c (gfc_init_options): Add -fwhole-file.
(gfc_handle_option): The same.

2009-03-30  Paul Thomas  <pault@gcc.gnu.org>

PR fortran/22571
* gfortran.dg/whole_file_1.f90: New test.
PR fortran/26227
* gfortran.dg/whole_file_2.f90: New test.
* gfortran.dg/whole_file_3.f90: New test.
PR fortran/24886
* gfortran.dg/whole_file_4.f90: New test.

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

16 files changed:
gcc/fortran/ChangeLog
gcc/fortran/decl.c
gcc/fortran/gfortran.h
gcc/fortran/invoke.texi
gcc/fortran/lang.opt
gcc/fortran/options.c
gcc/fortran/parse.c
gcc/fortran/resolve.c
gcc/fortran/symbol.c
gcc/fortran/trans-array.c
gcc/fortran/trans-decl.c
gcc/testsuite/ChangeLog
gcc/testsuite/gfortran.dg/whole_file_1.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/whole_file_2.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/whole_file_3.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/whole_file_4.f90 [new file with mode: 0644]

index 51f82c5..28764ec 100644 (file)
@@ -1,3 +1,34 @@
+2009-03-30  Paul Thomas  <pault@gcc.gnu.org>
+
+       PR fortran/22571
+       PR fortran/26227
+       PR fortran/24886
+       * symbol.c : Add gfc_global_ns_list.
+       * decl.c (add_global_entry): Set the namespace ('ns') field.
+       * gfortran.h : Add the resolved field to gfc_namespace. Add the
+       namespace ('ns') field to gfc_gsymbol.  Add flag_whole_file to
+       gfc_option_t.  Add the prototype for gfc_free_dt_list.
+       * lang.opt : Add the whole-file option.
+       * invoke.texi : Document the whole-file option.
+       * resolve.c (resolve_global_procedure): If the fwhole-file
+       option is set, reorder gsymbols to ensure that translation is
+       in the right order.  Resolve the gsymbol's namespace if that
+       has not occurred and then check interfaces.
+       (resolve_function): Move call to resolve_global_procedure.
+       (resolve_call): The same.
+       (resolve_codes): Store the current labels_obstack.
+       (gfc_resolve) : Return if the namespace is already resolved.
+       trans-decl.c (gfc_get_extern_function_decl): If the whole_file
+       option is selected, use the backend_decl of a gsymbol, if it is
+       available.
+       parse.c (add_global_procedure, add_global_program): If the flag
+       whole-file is set, add the namespace to the gsymbol.
+       (gfc_parse_file): On -fwhole-file, put procedure namespaces on
+       the global namespace list.  Rearrange to do resolution of all
+       the procedures in a file, followed by their translation.
+       * options.c (gfc_init_options): Add -fwhole-file.
+       (gfc_handle_option): The same.
+
 2009-03-30  Ulrich Weigand  <Ulrich.Weigand@de.ibm.com>
 
        * f95-lang.c (gfc_init_builtin_functions): Define BUILT_IN_HUGE_VAL
index 54a32f1..1e83d21 100644 (file)
@@ -4530,6 +4530,7 @@ add_global_entry (const char *name, int sub)
       s->type = type;
       s->where = gfc_current_locus;
       s->defined = 1;
+      s->ns = gfc_current_ns;
       return true;
     }
   return false;
index 3a7f98a..7ea9aa7 100644 (file)
@@ -1306,10 +1306,14 @@ typedef struct gfc_namespace
 
   /* Set to 1 if namespace is an interface body with "IMPORT" used.  */
   int has_import_set;
+
+  /* Set to 1 if resolved has been called for this namespace.  */
+  int resolved;
 }
 gfc_namespace;
 
 extern gfc_namespace *gfc_current_ns;
+extern gfc_namespace *gfc_global_ns_list;
 
 /* Global symbols are symbols of global scope. Currently we only use
    this to detect collisions already when parsing.
@@ -1328,6 +1332,7 @@ typedef struct gfc_gsymbol
 
   int defined, used;
   locus where;
+  gfc_namespace *ns;
 }
 gfc_gsymbol;
 
@@ -2027,6 +2032,7 @@ typedef struct
   int flag_init_character;
   char flag_init_character_value;
   int flag_align_commons;
+  int flag_whole_file;
 
   int fpe;
   int rtcheck;
@@ -2354,6 +2360,8 @@ void gfc_traverse_user_op (gfc_namespace *, void (*)(gfc_user_op *));
 void gfc_save_all (gfc_namespace *);
 
 void gfc_symbol_state (void);
+void gfc_free_dt_list (void);
+
 
 gfc_gsymbol *gfc_get_gsymbol (const char *);
 gfc_gsymbol *gfc_find_gsymbol (gfc_gsymbol *, const char *);
index a263a15..e49297d 100644 (file)
@@ -164,7 +164,7 @@ and warnings}.
 @item Code Generation Options
 @xref{Code Gen Options,,Options for code generation conventions}.
 @gccoptlist{-fno-automatic  -ff2c  -fno-underscoring @gol
--fsecond-underscore @gol
+-fwhole-file -fsecond-underscore @gol
 -fbounds-check -fcheck-array-temporaries  -fmax-array-constructor =@var{n} @gol
 -fcheck=@var{<all|bounds|array-temps>}
 -fmax-stack-var-size=@var{n} @gol
@@ -1158,6 +1158,19 @@ in the source, even if the names as seen by the linker are mangled to
 prevent accidental linking between procedures with incompatible
 interfaces.
 
+@item -fwhole-file
+@opindex @code{fwhole-file}
+By default, GNU Fortran parses, resolves and translates each procedure
+in a file separately.  Using this option modifies this such that the
+whole file is parsed and placed in a single front-end tree.  During
+resolution, in addition to all the usual checks and fixups, references
+to external procedures that are in the same file effect resolution of
+that procedure, if not already done, and a check of the interfaces. The
+dependences are resolved by changing the order in which the file is
+translated into the backend tree.  Thus, a procedure that is referenced
+is translated before the reference and the duplication of backend tree
+declarations eliminated.
+
 @item -fsecond-underscore
 @opindex @code{fsecond-underscore}
 @cindex underscore
index 193604a..9da290c 100644 (file)
@@ -360,6 +360,10 @@ funderscoring
 Fortran
 Append underscores to externally visible names
 
+fwhole-file
+Fortran
+Compile all program units at once and check all interfaces
+
 fworking-directory
 Fortran
 ; Documented in C
index 17c577d..b45696d 100644 (file)
@@ -93,6 +93,7 @@ gfc_init_options (unsigned int argc, const char **argv)
   gfc_option.flag_default_real = 0;
   gfc_option.flag_dollar_ok = 0;
   gfc_option.flag_underscoring = 1;
+  gfc_option.flag_whole_file = 0;
   gfc_option.flag_f2c = 0;
   gfc_option.flag_second_underscore = -1;
   gfc_option.flag_implicit_none = 0;
@@ -673,6 +674,10 @@ gfc_handle_option (size_t scode, const char *arg, int value)
       gfc_option.flag_underscoring = value;
       break;
 
+    case OPT_fwhole_file:
+      gfc_option.flag_whole_file = 1;
+      break;
+
     case OPT_fsecond_underscore:
       gfc_option.flag_second_underscore = value;
       break;
index 0800fc1..1925198 100644 (file)
@@ -3715,6 +3715,7 @@ add_global_procedure (int sub)
       s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
       s->where = gfc_current_locus;
       s->defined = 1;
+      s->ns = gfc_current_ns;
     }
 }
 
@@ -3737,6 +3738,7 @@ add_global_program (void)
       s->type = GSYM_PROGRAM;
       s->where = gfc_current_locus;
       s->defined = 1;
+      s->ns = gfc_current_ns;
     }
 }
 
@@ -3750,6 +3752,7 @@ gfc_parse_file (void)
   gfc_state_data top, s;
   gfc_statement st;
   locus prog_locus;
+  gfc_namespace *next;
 
   gfc_start_source_files ();
 
@@ -3768,6 +3771,10 @@ gfc_parse_file (void)
   if (setjmp (eof_buf))
     return FAILURE;    /* Come here on unexpected EOF */
 
+  /* Prepare the global namespace that will contain the
+     program units.  */
+  gfc_global_ns_list = next = NULL;
+
   seen_program = 0;
 
   /* Exit early for empty files.  */
@@ -3794,6 +3801,8 @@ loop:
       accept_statement (st);
       add_global_program ();
       parse_progunit (ST_NONE);
+      if (gfc_option.flag_whole_file)
+       goto prog_units;
       break;
 
     case ST_SUBROUTINE:
@@ -3801,6 +3810,8 @@ loop:
       push_state (&s, COMP_SUBROUTINE, gfc_new_block);
       accept_statement (st);
       parse_progunit (ST_NONE);
+      if (gfc_option.flag_whole_file)
+       goto prog_units;
       break;
 
     case ST_FUNCTION:
@@ -3808,6 +3819,8 @@ loop:
       push_state (&s, COMP_FUNCTION, gfc_new_block);
       accept_statement (st);
       parse_progunit (ST_NONE);
+      if (gfc_option.flag_whole_file)
+       goto prog_units;
       break;
 
     case ST_BLOCK_DATA:
@@ -3834,9 +3847,12 @@ loop:
       push_state (&s, COMP_PROGRAM, gfc_new_block);
       main_program_symbol (gfc_current_ns, "MAIN__");
       parse_progunit (st);
+      if (gfc_option.flag_whole_file)
+       goto prog_units;
       break;
     }
 
+  /* Handle the non-program units.  */
   gfc_current_ns->code = s.head;
 
   gfc_resolve (gfc_current_ns);
@@ -3862,7 +3878,56 @@ loop:
   gfc_done_2 ();
   goto loop;
 
-done:
+prog_units:
+  /* The main program and non-contained procedures are put
+     in the global namespace list, so that they can be processed
+     later and all their interfaces resolved.  */
+  gfc_current_ns->code = s.head;
+  if (next)
+    next->sibling = gfc_current_ns;
+  else
+    gfc_global_ns_list = gfc_current_ns;
+
+  next = gfc_current_ns;
+
+  pop_state ();
+  goto loop;
+
+  done:
+
+  if (!gfc_option.flag_whole_file)
+    goto termination;
+
+  /* Do the resolution.  */ 
+  gfc_current_ns = gfc_global_ns_list;
+  for (; gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
+    {
+      gfc_current_locus = gfc_current_ns->proc_name->declared_at;
+      gfc_resolve (gfc_current_ns);
+    }
+
+  /* Do the parse tree dump.  */ 
+  gfc_current_ns = gfc_option.dump_parse_tree ? gfc_global_ns_list : NULL;
+  for (; gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
+    {
+      gfc_dump_parse_tree (gfc_current_ns, stdout);
+      fputs ("-----------------------------------------\n\n", stdout);
+    }
+
+  gfc_current_ns = gfc_global_ns_list;
+  gfc_get_errors (NULL, &errors);
+
+  /* Do the translation.  This could be in a different order to
+     resolution if there are forward references in the file.  */
+  for (; !errors && gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
+    {
+      gfc_current_locus = gfc_current_ns->proc_name->declared_at;
+      gfc_generate_code (gfc_current_ns);
+    }
+
+termination:
+  gfc_free_dt_list ();
+
   gfc_end_source_files ();
   return SUCCESS;
 
index b79e485..81d5ed8 100644 (file)
@@ -1582,12 +1582,19 @@ find_noncopying_intrinsics (gfc_symbol *fnsym, gfc_actual_arglist *actual)
    reference being resolved must correspond to the type of gsymbol.
    Otherwise, the new symbol is equipped with the attributes of the
    reference.  The corresponding code that is called in creating
-   global entities is parse.c.  */
+   global entities is parse.c.
+
+   In addition, for all but -std=legacy, the gsymbols are used to
+   check the interfaces of external procedures from the same file.
+   The namespace of the gsymbol is resolved and then, once this is
+   done the interface is checked.  */
 
 static void
-resolve_global_procedure (gfc_symbol *sym, locus *where, int sub)
+resolve_global_procedure (gfc_symbol *sym, locus *where,
+                         gfc_actual_arglist **actual, int sub)
 {
   gfc_gsymbol * gsym;
+  gfc_namespace *ns;
   unsigned int type;
 
   type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
@@ -1597,6 +1604,32 @@ resolve_global_procedure (gfc_symbol *sym, locus *where, int sub)
   if ((gsym->type != GSYM_UNKNOWN && gsym->type != type))
     gfc_global_used (gsym, where);
 
+  if (gfc_option.flag_whole_file
+       && gsym->type != GSYM_UNKNOWN
+       && gsym->ns
+       && gsym->ns->proc_name
+       && gsym->ns->proc_name->formal)
+    {
+      /* Make sure that translation for the gsymbol occurs before
+        the procedure currently being resolved.  */
+      ns = gsym->ns->resolved ? NULL : gfc_global_ns_list;
+      for (; ns && ns != gsym->ns; ns = ns->sibling)
+       {
+         if (ns->sibling == gsym->ns)
+           {
+             ns->sibling = gsym->ns->sibling;
+             gsym->ns->sibling = gfc_global_ns_list;
+             gfc_global_ns_list = gsym->ns;
+             break;
+           }
+       }
+
+      if (!gsym->ns->resolved)
+       gfc_resolve (gsym->ns);
+
+      gfc_procedure_use (gsym->ns->proc_name, actual, where);
+    }
+
   if (gsym->type == GSYM_UNKNOWN)
     {
       gsym->type = type;
@@ -2310,10 +2343,6 @@ resolve_function (gfc_expr *expr)
       return FAILURE;
     }
 
-  /* If the procedure is external, check for usage.  */
-  if (sym && is_external_proc (sym))
-    resolve_global_procedure (sym, &expr->where, 0);
-
   /* Switch off assumed size checking and do this again for certain kinds
      of procedure, once the procedure itself is resolved.  */
   need_full_assumed_size++;
@@ -2342,6 +2371,11 @@ resolve_function (gfc_expr *expr)
   /* Resume assumed_size checking.  */
   need_full_assumed_size--;
 
+  /* If the procedure is external, check for usage.  */
+  if (sym && is_external_proc (sym))
+    resolve_global_procedure (sym, &expr->where,
+                             &expr->value.function.actual, 0);
+
   if (sym && sym->ts.type == BT_CHARACTER
       && sym->ts.cl
       && sym->ts.cl->length == NULL
@@ -2931,10 +2965,6 @@ resolve_call (gfc_code *c)
        }
     }
 
-  /* If external, check for usage.  */
-  if (csym && is_external_proc (csym))
-    resolve_global_procedure (csym, &c->loc, 1);
-
   /* Subroutines without the RECURSIVE attribution are not allowed to
    * call themselves.  */
   if (csym && is_illegal_recursion (csym, gfc_current_ns))
@@ -2965,6 +2995,10 @@ resolve_call (gfc_code *c)
   /* Resume assumed_size checking.  */
   need_full_assumed_size--;
 
+  /* If external, check for usage.  */
+  if (csym && is_external_proc (csym))
+    resolve_global_procedure (csym, &c->loc, &c->ext.actual, 1);
+
   t = SUCCESS;
   if (c->resolved_sym == NULL)
     {
@@ -10559,6 +10593,7 @@ static void
 resolve_codes (gfc_namespace *ns)
 {
   gfc_namespace *n;
+  bitmap_obstack old_obstack;
 
   for (n = ns->contained; n; n = n->sibling)
     resolve_codes (n);
@@ -10568,9 +10603,13 @@ resolve_codes (gfc_namespace *ns)
   /* Set to an out of range value.  */
   current_entry_id = -1;
 
+  old_obstack = labels_obstack;
   bitmap_obstack_initialize (&labels_obstack);
+
   resolve_code (ns->code, ns);
+
   bitmap_obstack_release (&labels_obstack);
+  labels_obstack = old_obstack;
 }
 
 
@@ -10585,10 +10624,14 @@ gfc_resolve (gfc_namespace *ns)
 {
   gfc_namespace *old_ns;
 
+  if (ns->resolved)
+    return;
+
   old_ns = gfc_current_ns;
 
   resolve_types (ns);
   resolve_codes (ns);
 
   gfc_current_ns = old_ns;
+  ns->resolved = 1;
 }
index ca9d0a3..7888235 100644 (file)
@@ -93,6 +93,7 @@ static int next_dummy_order = 1;
 
 
 gfc_namespace *gfc_current_ns;
+gfc_namespace *gfc_global_ns_list;
 
 gfc_gsymbol *gfc_gsym_root = NULL;
 
@@ -2938,7 +2939,7 @@ free_sym_tree (gfc_symtree *sym_tree)
 
 /* Free the derived type list.  */
 
-static void
+void
 gfc_free_dt_list (void)
 {
   gfc_dt_list *dt, *n;
index e7b5232..2442fd2 100644 (file)
@@ -4741,6 +4741,8 @@ get_array_charlen (gfc_expr *expr, gfc_se *se)
        {
          get_array_charlen (expr->value.op.op2, se);
 
+         gcc_assert (expr->value.op.op == INTRINSIC_CONCAT);
+
          /* Add the string lengths and assign them to the expression
             string length backend declaration.  */
          gfc_add_modify (&se->pre, expr->ts.cl->backend_decl,
index 6cfc86a..774f420 100644 (file)
@@ -1221,6 +1221,7 @@ gfc_get_extern_function_decl (gfc_symbol * sym)
   char s[GFC_MAX_SYMBOL_LEN + 23]; /* "_gfortran_f2c_specific" and '\0'.  */
   tree name;
   tree mangled_name;
+  gfc_gsymbol *gsym;
 
   if (sym->backend_decl)
     return sym->backend_decl;
@@ -1233,6 +1234,41 @@ gfc_get_extern_function_decl (gfc_symbol * sym)
   if (sym->attr.proc_pointer)
     return get_proc_pointer_decl (sym);
 
+  /* See if this is an external procedure from the same file.  If so,
+     return the backend_decl.  */
+  gsym =  gfc_find_gsymbol (gfc_gsym_root, sym->name);
+
+  if (gfc_option.flag_whole_file
+       && !sym->backend_decl
+       && gsym && gsym->ns
+       && ((gsym->type == GSYM_SUBROUTINE) || (gsym->type == GSYM_FUNCTION))
+       && gsym->ns->proc_name->backend_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.  */
+      if (gsym->ns->entries)
+       {
+         gfc_entry_list *entry = gsym->ns->entries;
+
+         for (; entry; entry = entry->next)
+           {
+             if (strcmp (gsym->name, entry->sym->name) == 0)
+               {
+                 sym->backend_decl = entry->sym->backend_decl;
+                 break;
+               }
+           }
+       }
+      else
+       {
+         sym->backend_decl = gsym->ns->proc_name->backend_decl;
+       }
+
+      if (sym->backend_decl)
+       return sym->backend_decl;
+    }
+
   if (sym->attr.intrinsic)
     {
       /* Call the resolution function to get the actual name.  This is
index cf19d16..daa4544 100644 (file)
@@ -1,3 +1,13 @@
+2009-03-30  Paul Thomas  <pault@gcc.gnu.org>
+
+       PR fortran/22571
+       * gfortran.dg/whole_file_1.f90: New test.
+       PR fortran/26227
+       * gfortran.dg/whole_file_2.f90: New test.
+       * gfortran.dg/whole_file_3.f90: New test.
+       PR fortran/24886
+       * gfortran.dg/whole_file_4.f90: New test.
+
 2009-03-30  Jakub Jelinek  <jakub@redhat.com>
 
        * gfortran.dg/bind_c_usage_19.f90: New test.
diff --git a/gcc/testsuite/gfortran.dg/whole_file_1.f90 b/gcc/testsuite/gfortran.dg/whole_file_1.f90
new file mode 100644 (file)
index 0000000..d7137ee
--- /dev/null
@@ -0,0 +1,60 @@
+! { dg-do compile }
+! { dg-options "-fwhole-file" }
+! Tests the fix for PR22571 in which the derived types in a, b
+! c and d were not detected to be different.  In e and f, they
+! are the same because they are sequence types.
+!
+! Contributed by Joost VandeVondele <jv244@cam.ac.uk>
+!
+subroutine a(p)
+  type t
+    integer :: t1
+  end type
+  type(t) :: p
+  p%t1 = 42
+end subroutine
+
+subroutine b
+  type u
+    integer :: u1
+  end type
+  type (u) :: q
+  call a(q)  ! { dg-error "Type mismatch" }
+  print *, q%u1
+end subroutine
+
+subroutine c(p)
+  type u
+    integer :: u1
+  end type
+  type(u) :: p
+  p%u1 = 42
+end subroutine
+
+subroutine d
+  type u
+    integer :: u1
+  end type
+  type (u) :: q
+  call c(q)  ! { dg-error "Type mismatch" }
+  print *, q%u1
+end subroutine
+
+subroutine e(p)
+  type u
+    sequence
+    integer :: u1
+  end type
+  type(u) :: p
+  p%u1 = 42
+end subroutine
+
+subroutine f
+  type u
+    sequence
+    integer :: u1
+  end type
+  type (u) :: q
+  call e(q)  ! This is OK because the types are sequence.
+  print *, q%u1
+end subroutine
diff --git a/gcc/testsuite/gfortran.dg/whole_file_2.f90 b/gcc/testsuite/gfortran.dg/whole_file_2.f90
new file mode 100644 (file)
index 0000000..7f40352
--- /dev/null
@@ -0,0 +1,25 @@
+! { dg-do compile }
+! { dg-options "-fwhole-file" }
+! Tests the fix for PR26227 in which the interface mismatches
+! below were not detected.
+!
+! Contributed by Andrew Pinski <pinskia@gcc.gnu.org>
+!
+function a(b)
+REAL ::b
+b = 2.0
+a = 1.0
+end function
+
+program gg
+real :: h
+character (5) :: chr = 'hello'
+h = a(); ! { dg-error "Missing actual argument" }
+call test ([chr]) ! { dg-error "Rank mismatch" }
+end program gg
+
+subroutine test (a)
+  character (5) :: a
+  if (a .ne. 'hello') call abort
+end subroutine test
+
diff --git a/gcc/testsuite/gfortran.dg/whole_file_3.f90 b/gcc/testsuite/gfortran.dg/whole_file_3.f90
new file mode 100644 (file)
index 0000000..7ad762c
--- /dev/null
@@ -0,0 +1,21 @@
+! { dg-do compile }
+! { dg-options "-fwhole-file" }
+! Tests the fix for PR26227 in which the interface mismatches
+! below were not detected.
+!
+! Contributed by Andrew Pinski <pinskia@gcc.gnu.org>
+!
+      SUBROUTINE PHLOAD (READER,*)
+      IMPLICIT NONE
+      EXTERNAL         READER
+      CALL READER (*1)
+ 1    RETURN 1
+      END SUBROUTINE
+
+      program test
+      EXTERNAL R
+      call PHLOAD (R, 1) ! { dg-error "Missing alternate return spec" }
+      CALL PHLOAD (R, 2) ! { dg-error "Missing alternate return spec" }
+      CALL PHLOAD (R, *999) ! This one is OK
+ 999  continue
+      END program test
diff --git a/gcc/testsuite/gfortran.dg/whole_file_4.f90 b/gcc/testsuite/gfortran.dg/whole_file_4.f90
new file mode 100644 (file)
index 0000000..671bc2d
--- /dev/null
@@ -0,0 +1,19 @@
+! { dg-do compile }
+! { dg-options "-fwhole-file -std=legacy" }
+! Tests the fix for PR24886 in which the mismatch between the
+! character lengths of the actual and formal arguments of
+! 'foo' was not detected.
+!
+! Contributed by Uttam Pawar <uttamp@us.ibm.com>
+!
+        subroutine foo(y)
+           character(len=20) :: y
+           y = 'hello world'
+        end
+
+        program test
+           character(len=10) :: x
+           call foo(x) ! { dg-warning "actual argument shorter" }
+           write(*,*) 'X=',x
+           pause
+        end