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

Fix PR 119928, formal arguments used to wrongly inferred for CLASS.

Browse Source 
The problem was indeed that generating a formal from an actual
arglist is a bad idea when classes are involved.  Fixed in the
attached patch.  I think it still makes sense to remove the checks
when the other attributes are present (or PR96073 may come back
in different guise, even if I have to test case at present).
I have also converted the test to a run-time check.

gcc/fortran/ChangeLog:

	PR fortran/119928
	* interface.cc (gfc_check_dummy_characteristics): Do not issue
	error if one dummy symbol has been generated from an actual
	argument and the other one has OPTIONAL, INTENT, ALLOCATABLE,
	POINTER, TARGET, VALUE, ASYNCHRONOUS or CONTIGUOUS.
	(gfc_get_formal_from_actual_arglist): Do nothing if symbol
	is a class.

gcc/testsuite/ChangeLog:

	PR fortran/119928
	* gfortran.dg/interface_60.f90: New test.
This commit is contained in:
Thomas Koenig
2025-05-06 18:05:41 +02:00
parent 76c882e341
commit e7a2b8b76a
2 changed files with 143 additions and 62 deletions
Download Patch File Download Diff File Expand all files Collapse all files

135
gcc/fortran/interface.cc
View File

@@ -1403,77 +1403,82 @@ gfc_check_dummy_characteristics (gfc_symbol *s1, gfc_symbol *s2,
}
}
/* Check 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);
return false;
}
/* A lot of information is missing for artificially generated
formal arguments, let's not look into that. */
/* Check OPTIONAL attribute. */
if (s1->attr.optional != s2->attr.optional)
if (!s1->attr.artificial && !s2->attr.artificial)
{
snprintf (errmsg, err_len, "OPTIONAL mismatch in argument '%s'",
s1->name);
return false;
}
/* Check INTENT. */
if (s1->attr.intent != s2->attr.intent)
{
snprintf (errmsg, err_len, "INTENT mismatch in argument '%s'",
s1->name);
return false;
}
/* Check ALLOCATABLE attribute. */
if (s1->attr.allocatable != s2->attr.allocatable)
{
snprintf (errmsg, err_len, "ALLOCATABLE mismatch in argument '%s'",
s1->name);
return false;
}
/* Check OPTIONAL attribute. */
if (s1->attr.optional != s2->attr.optional)
{
snprintf (errmsg, err_len, "OPTIONAL mismatch in argument '%s'",
s1->name);
return false;
}
/* Check POINTER attribute. */
if (s1->attr.pointer != s2->attr.pointer)
{
snprintf (errmsg, err_len, "POINTER mismatch in argument '%s'",
s1->name);
return false;
}
/* Check ALLOCATABLE attribute. */
if (s1->attr.allocatable != s2->attr.allocatable)
{
snprintf (errmsg, err_len, "ALLOCATABLE mismatch in argument '%s'",
s1->name);
return false;
}
/* Check TARGET attribute. */
if (s1->attr.target != s2->attr.target)
{
snprintf (errmsg, err_len, "TARGET mismatch in argument '%s'",
s1->name);
return false;
}
/* Check POINTER attribute. */
if (s1->attr.pointer != s2->attr.pointer)
{
snprintf (errmsg, err_len, "POINTER mismatch in argument '%s'",
s1->name);
return false;
}
/* Check ASYNCHRONOUS attribute. */
if (s1->attr.asynchronous != s2->attr.asynchronous)
{
snprintf (errmsg, err_len, "ASYNCHRONOUS mismatch in argument '%s'",
s1->name);
return false;
}
/* Check TARGET attribute. */
if (s1->attr.target != s2->attr.target)
{
snprintf (errmsg, err_len, "TARGET mismatch in argument '%s'",
s1->name);
return false;
}
/* Check CONTIGUOUS attribute. */
if (s1->attr.contiguous != s2->attr.contiguous)
{
snprintf (errmsg, err_len, "CONTIGUOUS mismatch in argument '%s'",
s1->name);
return false;
}
/* Check ASYNCHRONOUS attribute. */
if (s1->attr.asynchronous != s2->attr.asynchronous)
{
snprintf (errmsg, err_len, "ASYNCHRONOUS mismatch in argument '%s'",
s1->name);
return false;
}
/* Check VALUE attribute. */
if (s1->attr.value != s2->attr.value)
{
snprintf (errmsg, err_len, "VALUE mismatch in argument '%s'",
s1->name);
return false;
}
/* Check CONTIGUOUS attribute. */
if (s1->attr.contiguous != s2->attr.contiguous)
{
snprintf (errmsg, err_len, "CONTIGUOUS mismatch in argument '%s'",
s1->name);
return false;
}
/* Check VOLATILE attribute. */
if (s1->attr.volatile_ != s2->attr.volatile_)
{
snprintf (errmsg, err_len, "VOLATILE mismatch in argument '%s'",
s1->name);
return false;
/* Check VALUE attribute. */
if (s1->attr.value != s2->attr.value)
{
snprintf (errmsg, err_len, "VALUE mismatch in argument '%s'",
s1->name);
return false;
}
/* Check VOLATILE attribute. */
if (s1->attr.volatile_ != s2->attr.volatile_)
{
snprintf (errmsg, err_len, "VOLATILE mismatch in argument '%s'",
s1->name);
return false;
}
}
/* Check interface of dummy procedures. */
@@ -5849,6 +5854,12 @@ gfc_get_formal_from_actual_arglist (gfc_symbol *sym,
char name[GFC_MAX_SYMBOL_LEN + 1];
static int var_num;
/* Do not infer the formal from actual arguments if we are dealing with
classes. */
if (sym->ts.type == BT_CLASS)
return;
f = &sym->formal;
for (a = actual_args; a != NULL; a = a->next)
{

70
gcc/testsuite/gfortran.dg/interface_60.f90 Normal file
View File

@@ -0,0 +1,70 @@
! { dg-do run }
! { dg-options "-Wexternal-argument-mismatch" }
! Originally proc_ptr_52.f90, this gave an error with the warning above.
module cs
implicit none
integer, target :: integer_target
abstract interface
function classStar_map_ifc(x) result(y)
class(*), pointer :: y
class(*), target, intent(in) :: x
end function classStar_map_ifc
end interface
contains
function fun(x) result(y)
class(*), pointer :: y
class(*), target, intent(in) :: x
select type (x)
type is (integer)
integer_target = x ! Deals with dangling target.
y => integer_target
class default
y => null()
end select
end function fun
function apply(fap, x) result(y)
procedure(classStar_map_ifc) :: fap
integer, intent(in) :: x
integer :: y
class(*), pointer :: p
y = 0 ! Get rid of 'y' undefined warning
p => fap (x)
select type (p)
type is (integer)
y = p
end select
end function apply
function selector() result(fsel)
procedure(classStar_map_ifc), pointer :: fsel
fsel => fun
end function selector
end module cs
program classStar_map
use cs
implicit none
integer :: x, y
procedure(classStar_map_ifc), pointer :: fm
x = 123654
fm => selector () ! Fixed by second chunk in patch
y = apply (fm, x) ! Fixed by first chunk in patch
if (x .ne. y) stop 1
x = 2 * x
y = apply (fun, x) ! PR93925; fixed as above
if (x .ne. y) stop 2
end program classStar_map