Hello world,
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, like this:
10 | CALL bar (test2) ! { dg-error "Interface mismatch in dummy
procedure" }
| 1
......
16 | CALL bar (test) ! { dg-error "Interface mismatch in dummy
procedure" }
| 2
Fehler: Interface mismatch in dummy procedure at (1) conflichts with
(2): 'test2' is not a subroutine
Regression-tested. OK for trunk?
Best regards
Thomas
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 fdde84db80d..edec907d33a 100644
--- 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
index 00000000000..4d619241c27
--- /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
index 00000000000..99a2b959463
--- /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 ece42ca2312..da45762f9b1 100644
--- 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 9414f587b90..732d7bc627d 100644
--- 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 4de0925647f..923ab9ebfed 100644
--- 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
