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

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.

diff --git a/gcc/fortran/interface.cc b/gcc/fortran/interface.cc
index 1e552a3df861091e641b644f30b4034c037450c7..753f589ff6779acc155d1b02ed0856ba4ab35e6a 100644 (file)
--- a/gcc/fortran/interface.cc
+++ b/gcc/fortran/interface.cc
@@ -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)
     {

diff --git a/gcc/testsuite/gfortran.dg/interface_60.f90 b/gcc/testsuite/gfortran.dg/interface_60.f90
new file mode 100644 (file)
index 0000000..a7701f6
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/interface_60.f90
@@ -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