Fix LAPACK build error due to global symbol checking.

This was an interesting regression.  It came from my recent
patch, where an assert was triggered because a procedure artificial
dummy argument generated for a global symbol did not have the
information if if was a function or a subroutine.  Fixed by
adding the information in gfc_get_formal_from_actual_arglist.

This information then uncovered some new errors, also in the
testsuite, which needed fixing.  Finally, the error is made to
look a bit nicer, so the user gets a pointer to where the
original interface comes from.

gcc/fortran/ChangeLog:

	PR fortran/118845
	* interface.cc (compare_parameter): If the formal attribute has been
	generated from an actual argument list, also output an pointer to
	there in case of an error.
	(gfc_get_formal_from_actual_arglist): Set function and subroutine
	attributes and (if it is a function) the typespec from the actual
	argument.

gcc/testsuite/ChangeLog:

	PR fortran/118845
	* gfortran.dg/recursive_check_4.f03: Adjust call so types matche.
	* gfortran.dg/recursive_check_6.f03: Likewise.
	* gfortran.dg/specifics_2.f90: Adjust calls so types match.
	* gfortran.dg/interface_52.f90: New test.
	* gfortran.dg/interface_53.f90: New test.

diff --git a/gcc/fortran/interface.cc b/gcc/fortran/interface.cc
index fdde84db80d0b33e8e5df5924dc9fcc1aef16a04..edec907d33a3356399f4bcdf5243893aa3450544 100644 (file)
--- a/gcc/fortran/interface.cc
+++ b/gcc/fortran/interface.cc
@@ -2474,8 +2474,16 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
                                           sizeof(err),NULL, NULL))
        {
          if (where)
-           gfc_error_opt (0, "Interface mismatch in dummy procedure %qs at %L:"
-                          " %s", formal->name, &actual->where, err);
+           {
+             /* Artificially generated symbol names would only confuse.  */
+             if (formal->attr.artificial)
+               gfc_error_opt (0, "Interface mismatch in dummy procedure "
+                              "at %L conflicts with %L: %s", &actual->where,
+                              &formal->declared_at, err);
+             else
+               gfc_error_opt (0, "Interface mismatch in dummy procedure %qs "
+                              "at %L: %s", formal->name, &actual->where, err);
+           }
          return false;
        }
 
@@ -2483,8 +2491,16 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
                                   sizeof(err), NULL, NULL))
        {
          if (where)
-           gfc_error_opt (0, "Interface mismatch in dummy procedure %qs at %L:"
-                          " %s", formal->name, &actual->where, err);
+           {
+             if (formal->attr.artificial)
+               gfc_error_opt (0, "Interface mismatch in dummy procedure "
+                              "at %L conflichts with %L: %s", &actual->where,
+                              &formal->declared_at, err);
+             else
+               gfc_error_opt (0, "Interface mismatch in dummy procedure %qs at "
+                              "%L: %s", formal->name, &actual->where, err);
+
+           }
          return false;
        }
 
@@ -5822,7 +5838,14 @@ gfc_get_formal_from_actual_arglist (gfc_symbol *sym,
          gfc_get_symbol (name, gfc_current_ns, &s);
          if (a->expr->ts.type == BT_PROCEDURE)
            {
+             gfc_symbol *asym = a->expr->symtree->n.sym;
              s->attr.flavor = FL_PROCEDURE;
+             if (asym->attr.function)
+               {
+                 s->attr.function = 1;
+                 s->ts = asym->ts;
+               }
+             s->attr.subroutine = asym->attr.subroutine;
            }
          else
            {

diff --git a/gcc/testsuite/gfortran.dg/interface_52.f90 b/gcc/testsuite/gfortran.dg/interface_52.f90
new file mode 100644 (file)
index 0000000..4d61924
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/interface_52.f90
@@ -0,0 +1,20 @@
+  ! { dg-do compile }
+MODULE m
+  IMPLICIT NONE
+
+CONTAINS
+
+  SUBROUTINE test ()
+    IMPLICIT NONE
+
+    CALL bar (test2) ! { dg-error "Interface mismatch in dummy procedure" }
+  END SUBROUTINE test
+
+  INTEGER FUNCTION test2 () RESULT (x)
+    IMPLICIT NONE
+
+    CALL bar (test) ! { dg-error "Interface mismatch in dummy procedure" }
+  END FUNCTION test2
+
+END MODULE m
+

diff --git a/gcc/testsuite/gfortran.dg/interface_53.f90 b/gcc/testsuite/gfortran.dg/interface_53.f90
new file mode 100644 (file)
index 0000000..99a2b95
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/interface_53.f90
@@ -0,0 +1,8 @@
+! { dg-do compile }
+! PR 118845 - reduced from a segfault in Lapack.
+SUBROUTINE SDRVES(  RESULT )
+  external SSLECT
+  CALL SGEES( SSLECT )
+  CALL SGEES( SSLECT )
+  RESULT = SSLECT( 1, 2 )
+END

diff --git a/gcc/testsuite/gfortran.dg/recursive_check_4.f03 b/gcc/testsuite/gfortran.dg/recursive_check_4.f03
index ece42ca2312faa8327d30895ba4318bf471fd5ca..da45762f9b1e86d94a24ebd41afaa59cf4296b89 100644 (file)
--- a/gcc/testsuite/gfortran.dg/recursive_check_4.f03
+++ b/gcc/testsuite/gfortran.dg/recursive_check_4.f03
@@ -20,7 +20,7 @@ CONTAINS
     IMPLICIT NONE
     PROCEDURE(test2), POINTER :: procptr
 
-    CALL bar (test2) ! { dg-warning "Non-RECURSIVE" }
+    CALL bar2 (test2) ! { dg-warning "Non-RECURSIVE" }
     procptr => test2 ! { dg-warning "Non-RECURSIVE" }
 
     x = 1812

diff --git a/gcc/testsuite/gfortran.dg/recursive_check_6.f03 b/gcc/testsuite/gfortran.dg/recursive_check_6.f03
index 9414f587b9018039f6f9020d9b7155ea2d9dfafb..732d7bc627d47709389c0e72ca1d43d81a2fbde3 100644 (file)
--- a/gcc/testsuite/gfortran.dg/recursive_check_6.f03
+++ b/gcc/testsuite/gfortran.dg/recursive_check_6.f03
@@ -31,7 +31,7 @@ CONTAINS
 
       bar = test_func () ! { dg-error "not RECURSIVE" }
       procptr => test_func ! { dg-warning "Non-RECURSIVE" }
-      CALL foobar (test_func) ! { dg-warning "Non-RECURSIVE" }
+      CALL foobar2 (test_func) ! { dg-warning "Non-RECURSIVE" }
     END FUNCTION bar
   END FUNCTION test_func
 

diff --git a/gcc/testsuite/gfortran.dg/specifics_2.f90 b/gcc/testsuite/gfortran.dg/specifics_2.f90
index 4de0925647f643c96b5597ba247549de4bb7349c..923ab9ebfed825c4cc5f066067237d28defb3580 100644 (file)
--- a/gcc/testsuite/gfortran.dg/specifics_2.f90
+++ b/gcc/testsuite/gfortran.dg/specifics_2.f90
@@ -1,5 +1,6 @@
 ! { dg-do compile }
-! This is the list of intrinsics allowed as actual arguments
+  ! This is the list of intrinsics allowed as actual arguments
+  implicit none
  intrinsic abs,acos,acosh,aimag,aint,alog,alog10,amod,anint,asin,asinh,atan,&
  atan2,atanh,cabs,ccos,cexp,clog,conjg,cos,cosh,csin,csqrt,dabs,dacos,&
  dacosh,dasin,dasinh,datan,datan2,datanh,dconjg,dcos,dcosh,ddim,dexp,dim,&
@@ -7,75 +8,75 @@
  exp,iabs,idim,idnint,index,isign,len,mod,nint,sign,sin,sinh,sqrt,tan,&
  tanh,zabs,zcos,zexp,zlog,zsin,zsqrt
  
-  call foo(abs)
-  call foo(acos)
-  call foo(acosh)
-  call foo(aimag)
-  call foo(aint)
-  call foo(alog)
-  call foo(alog10)
-  call foo(amod)
-  call foo(anint)
-  call foo(asin)
-  call foo(asinh)
-  call foo(atan)
-  call foo(atan2)
-  call foo(atanh)
-  call foo(cabs)
-  call foo(ccos)
-  call foo(cexp)
-  call foo(clog)
-  call foo(conjg)
-  call foo(cos)
-  call foo(cosh)
-  call foo(csin)
-  call foo(csqrt)
-  call foo(dabs)
-  call foo(dacos)
-  call foo(dacosh)
-  call foo(dasin)
-  call foo(dasinh)
-  call foo(datan)
-  call foo(datan2)
-  call foo(datanh)
-  call foo(dconjg)
-  call foo(dcos)
-  call foo(dcosh)
-  call foo(ddim)
-  call foo(dexp)
-  call foo(dim)
-  call foo(dimag)
-  call foo(dint)
-  call foo(dlog)
-  call foo(dlog10)
-  call foo(dmod)
-  call foo(dnint)
-  call foo(dprod)
-  call foo(dsign)
-  call foo(dsin)
-  call foo(dsinh)
-  call foo(dsqrt)
-  call foo(dtan)
-  call foo(dtanh)
-  call foo(exp)
-  call foo(iabs)
-  call foo(idim)
-  call foo(idnint)
-  call foo(index)
-  call foo(isign)
-  call foo(len)
-  call foo(mod)
-  call foo(nint)
-  call foo(sign)
-  call foo(sin)
-  call foo(sinh)
-  call foo(sqrt)
-  call foo(tan)
-  call foo(tanh)
-  call foo(zabs)
-  call foo(zcos)
-  call foo(zexp)
-  call foo(zlog)
-  call foo(zsin)
-  call foo(zsqrt)
+  call foo_r4(abs)
+  call foo_r4(acos)
+  call foo_r4(acosh)
+  call foo_r4(aimag)
+  call foo_r4(aint)
+  call foo_r4(alog)
+  call foo_r4(alog10)
+  call foo_r4(amod)
+  call foo_r4(anint)
+  call foo_r4(asin)
+  call foo_r4(asinh)
+  call foo_r4(atan)
+  call foo_r4(atan2)
+  call foo_r4(atanh)
+  call foo_r4(cabs)
+  call foo_c4(ccos)
+  call foo_c4(cexp)
+  call foo_c4(clog)
+  call foo_c4(conjg)
+  call foo_r4(cos)
+  call foo_r4(cosh)
+  call foo_c4(csin)
+  call foo_c4(csqrt)
+  call foo_r8(dabs)
+  call foo_r8(dacos)
+  call foo_r8(dacosh)
+  call foo_r8(dasin)
+  call foo_r8(dasinh)
+  call foo_r8(datan)
+  call foo_r8(datan2)
+  call foo_r8(datanh)
+  call foo_c8(dconjg)
+  call foo_r8(dcos)
+  call foo_r8(dcosh)
+  call foo_r8(ddim)
+  call foo_r8(dexp)
+  call foo_r8(ddim)
+  call foo_r8(dimag)
+  call foo_r8(dint)
+  call foo_r8(dlog)
+  call foo_r8(dlog10)
+  call foo_r8(dmod)
+  call foo_r8(dnint)
+  call foo_r8(dprod)
+  call foo_r8(dsign)
+  call foo_r8(dsin)
+  call foo_r8(dsinh)
+  call foo_r8(dsqrt)
+  call foo_r8(dtan)
+  call foo_r8(dtanh)
+  call foo_r5(exp)
+  call foo_i4(iabs)
+  call foo_i4(idim)
+  call foo_i4(idnint)
+  call foo_i4(index)
+  call foo_i4(isign)
+  call foo_i4(len)
+  call foo_i4(mod)
+  call foo_i4(nint)
+  call foo_r4(sign)
+  call foo_r4(sin)
+  call foo_r4(sinh)
+  call foo_r4(sqrt)
+  call foo_r4(tan)
+  call foo_r4(tanh)
+  call foo_r8(zabs)
+  call foo_c8(zcos)
+  call foo_c8(zexp)
+  call foo_c8(zlog)
+  call foo_c8(zsin)
+  call foo_c8(zsqrt)
   end