git
/
gcc
mirror of git://gcc.gnu.org/git/gcc.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

Fortran: improve checking of procedures passed as actual argument [PR50377] 

Procedures passed as actual argument require either an explicit interface
or must be declared EXTERNAL.  Add a check and generate an error (default)
or a warning when -std=legacy is specified.

	PR fortran/50377

gcc/fortran/ChangeLog:

	* resolve.cc (resolve_actual_arglist): Check procedure actual
	arguments.

gcc/testsuite/ChangeLog:

	* gfortran.dg/pr41011.f: Fix invalid testcase.
	* gfortran.dg/actual_procedure_2.f: New test.
This commit is contained in:
Harald Anlauf 2025-10-10 22:02:51 +02:00
parent 6a77bf08e5
commit 52ee235811
3 changed files with 48 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
gcc/fortran/resolve.cc
View File

@ -2295,6 +2295,30 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
goto cleanup; goto cleanup;
} }
if (e->expr_type == EXPR_VARIABLE
&& e->ts.type == BT_PROCEDURE
&& no_formal_args
&& sym->attr.flavor == FL_PROCEDURE
&& sym->attr.if_source == IFSRC_UNKNOWN
&& !sym->attr.external
&& !sym->attr.intrinsic
&& !sym->attr.artificial
&& !sym->ts.interface)
{
/* Emit a warning for -std=legacy and an error otherwise. */
if (gfc_option.warn_std == 0)
gfc_warning (0, "Procedure %qs at %L used as actual argument but "
"does neither have an explicit interface nor the "
"EXTERNAL attribute", sym->name, &e->where);
else
{
gfc_error ("Procedure %qs at %L used as actual argument but "
"does neither have an explicit interface nor the "
"EXTERNAL attribute", sym->name, &e->where);
goto cleanup;
}
}
first_actual_arg = false; first_actual_arg = false;
} }

22
gcc/testsuite/gfortran.dg/actual_procedure_2.f Normal file
View File

@ -0,0 +1,22 @@
! { dg-do compile }
! PR fortran/50377
!
! Reject procedures passed as actual argument if there is no explicit
! interface and they are not declared EXTERNAL
!
! Contributed by Vittorio Zecca
! external sub ! Required for valid code
! external fun ! Required for valid code
call sub(sub) ! { dg-error "used as actual argument" }
z = fun(fun) ! { dg-error "used as actual argument" }
end
subroutine sub(y)
external y
end
real function fun(z)
external z
f = 1.
end

2
gcc/testsuite/gfortran.dg/pr41011.f
View File

@ -1,5 +1,7 @@
! { dg-do compile } ! { dg-do compile }
! { dg-options "-O3 -std=legacy" } ! { dg-options "-O3 -std=legacy" }
SUBROUTINE PR41011 (DCDX)
DIMENSION DCDX(*)
CALL UVSET(NX,NY,NZ,HVAR,ZET,NP,DZ,DKM,UM,VM,UG,VG,TM,DCDX, ! { dg-warning "Rank mismatch|Invalid procedure argument" } CALL UVSET(NX,NY,NZ,HVAR,ZET,NP,DZ,DKM,UM,VM,UG,VG,TM,DCDX, ! { dg-warning "Rank mismatch|Invalid procedure argument" }
*ITY,ISH,NSMT,F) *ITY,ISH,NSMT,F)
CALL DCTDX(NX,NY,NX1,NFILT,C(MLAG),DCDX(MLAG),HELP,HELPA, CALL DCTDX(NX,NY,NX1,NFILT,C(MLAG),DCDX(MLAG),HELP,HELPA,