TeamHeptaMirrors/gcc
1
0
Fork 1
mirror of https://github.com/gcc-mirror/gcc.git synced 2026-05-06 14:59:39 +02:00
Code Issues Packages Projects Releases Wiki Activity

Fortran: diagnostic for argument w/type parameters for assumed-type dummy

Browse Source 
2021-09-22  Sandra Loosemore  <sandra@codesourcery.com>

	PR fortran/101319

gcc/fortran/
	* interface.c (gfc_compare_actual_formal): Extend existing
	assumed-type diagnostic to also check for argument with type
	parameters.

gcc/testsuite/
	* gfortran.dg/c-interop/assumed-type-dummy.f90: Remove xfail.
This commit is contained in:
Sandra Loosemore
2021-09-22 07:49:17 -07:00
parent 7a40f2e748
commit 5098e7077b
2 changed files with 11 additions and 11 deletions
Download Patch File Download Diff File Expand all files Collapse all files

20
gcc/fortran/interface.c
View File

@@ -3183,21 +3183,21 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
is_elemental, where))
return false;
/* TS 29113, 6.3p2. */
/* TS 29113, 6.3p2; F2018 15.5.2.4. */
if (f->sym->ts.type == BT_ASSUMED
&& (a->expr->ts.type == BT_DERIVED
|| (a->expr->ts.type == BT_CLASS && CLASS_DATA (a->expr))))
{
gfc_namespace *f2k_derived;
f2k_derived = a->expr->ts.type == BT_DERIVED
? a->expr->ts.u.derived->f2k_derived
: CLASS_DATA (a->expr)->ts.u.derived->f2k_derived;
if (f2k_derived
&& (f2k_derived->finalizers || f2k_derived->tb_sym_root))
gfc_symbol *derived = (a->expr->ts.type == BT_DERIVED
? a->expr->ts.u.derived
: CLASS_DATA (a->expr)->ts.u.derived);
gfc_namespace *f2k_derived = derived->f2k_derived;
if (derived->attr.pdt_type
|| (f2k_derived
&& (f2k_derived->finalizers || f2k_derived->tb_sym_root)))
{
gfc_error ("Actual argument at %L to assumed-type dummy is of "
gfc_error ("Actual argument at %L to assumed-type dummy "
"has type parameters or is of "
"derived type with type-bound or FINAL procedures",
&a->expr->where);
return false;

2
gcc/testsuite/gfortran.dg/c-interop/assumed-type-dummy.f90
View File

@@ -73,7 +73,7 @@ contains
type(t4) :: a4
call s1 (a1) ! OK
call s1 (a2) ! { dg-error "assumed-type dummy" "pr101319" { xfail *-*-* } }
call s1 (a2) ! { dg-error "assumed-type dummy" }
call s1 (a3) ! { dg-error "assumed-type dummy" }
call s1 (a4) ! { dg-error "assumed-type dummy" }
end subroutine