Fix ICE on warning with new interface check.

In the test case, there was a warning about INTENT where an EXTERNAL
masked an interface in an outer scope, when the location of the
symbol was not set, leading to an ICE.

Two problems, two-part solution: It makes no sense to warn about
INTENT for artificially generated formal argument lists, and the
location should be set.

gcc/fortran/ChangeLog:

	PR fortran/96073
	* frontend-passes.c (check_externals_procedure):  Add locus
	information for new_sym.
	* interface.c (gfc_check_dummy_characteristics): Do not warn
	about INTENT for artificially generated variables.

gcc/testsuite/ChangeLog:

	PR fortran/96073
	* gfortran.dg/interface_48.f90: New test.

diff --git a/gcc/fortran/frontend-passes.c b/gcc/fortran/frontend-passes.c
index 69f9ca6..7768fdc 100644 (file)
--- a/gcc/fortran/frontend-passes.c
+++ b/gcc/fortran/frontend-passes.c
@@ -5441,6 +5441,7 @@ check_externals_procedure (gfc_symbol *sym, locus *loc,
   gfc_current_ns = gsym->ns;
 
   gfc_get_formal_from_actual_arglist (new_sym, actual);
+  new_sym->declared_at = *loc;
   gfc_current_ns = save_ns;
 
   return 0;

diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 0cc504f..e518209 100644 (file)
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -1343,7 +1343,8 @@ gfc_check_dummy_characteristics (gfc_symbol *s1, gfc_symbol *s2,
     }
 
   /* Check INTENT.  */
-  if (s1->attr.intent != s2->attr.intent)
+  if (s1->attr.intent != s2->attr.intent && !s1->attr.artificial
+      && !s2->attr.artificial)
     {
       snprintf (errmsg, err_len, "INTENT mismatch in argument '%s'",
                s1->name);

diff --git a/gcc/testsuite/gfortran.dg/interface_48.f90 b/gcc/testsuite/gfortran.dg/interface_48.f90
new file mode 100644 (file)
index 0000000..f751332
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/interface_48.f90
@@ -0,0 +1,31 @@
+! { dg-do compile }
+! PR 96073 - this used to cause an ICE.
+! Test case by Jürgen Reuter.
+
+module m
+  implicit none
+  private
+
+  interface
+     subroutine GetXminM (set, xmin)
+       integer, intent(in) :: set
+       real, intent(out) :: xmin
+     end subroutine GetXminM
+  end interface
+  interface 
+     subroutine foo(a)  ! { dg-warning "Type mismatch" }
+       integer, intent(in) :: a 
+     end subroutine foo
+  end interface
+
+contains
+
+  subroutine s ()
+    real :: xmin
+    integer :: set
+    external :: GetXminM, foo
+    call GetXminM (set, xmin)
+    call foo(1.0) ! { dg-warning "Type mismatch" }
+  end subroutine s
+
+end module m