Re: [Patch, Fortran, OOP] PR 47978: Invalid INTENT in overriding TBP not detected

[Janus Weil <janus at gcc dot gnu dot org>]

Update: Here is an extended version of the patch, which adds a few
additional checks:
 * a simple check for the array shape (not complete yet, but fixing at
least comment #0 of PR 35831)
 * a check for the string length, as recently implemented for
character results (PR49638)
 * furthermore it checks more of the attributes listed in 12.3.2 (I
did not add test cases for those, and I would argue that we don't
really need a test case for every single attribute)

The patch still regtests cleanly. Ok for trunk? Or should I rather
commit the simple version first?

Cheers,
Janus


2011-09-11  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/35831
	PR fortran/47978
	* interface.c (check_dummy_characteristics): New function to check the
	characteristics of dummy arguments.
	(gfc_compare_interfaces,gfc_check_typebound_override): Call it here.


2011-09-11  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/35831
	PR fortran/47978
	* gfortran.dg/dynamic_dispatch_5.f03: Fix invalid test case.
	* gfortran.dg/typebound_proc_6.f03: Changed wording in error message.
	* gfortran.dg/proc_decl_26.f90: New.
	* gfortran.dg/typebound_override_2.f90: New.



2011/9/9 Janus Weil <janus@gcc.gnu.org>:
> Hi all,
>
> here is another small patch for an accepts-invalid OOP problem: When
> overriding a type-bound procedure, we need to check that the intents
> of the formal args agree (or more general: their 'characteristics', as
> defined in chapter 12.3.2 of the F08 standard). For now I'm only
> checking type+rank as well as the INTENT and OPTIONAL attributes, but
> I added a FIXME for more comprehensive checking (which could be added
> in a follow-up patch).
>
> On the technical side of things, I'm adding a new function
> 'check_dummy_characteristics', which is called in two places:
> ?* gfc_compare_interfaces and
> ?* gfc_check_typebound_override.
>
> A slight subtlety is given by the fact that for the PASS argument, the
> type of the argument does not have to agree when overriding.
>
> The improved checking also caught an invalid test case in the
> testsuite (dynamic_dispatch_5), for another one the error message
> changed slightly (typebound_proc_6).
>
> Regtested on x86_64-unknown-linux-gnu. Ok for trunk?
>
> Cheers,
> Janus
>
>
> 2011-09-09 ?Janus Weil ?<janus@gcc.gnu.org>
>
> ? ? ? ?PR fortran/47978
> ? ? ? ?* interface.c (check_dummy_characteristics): New function to check the
> ? ? ? ?characteristics of dummy arguments.
> ? ? ? ?(gfc_compare_interfaces,gfc_check_typebound_override): Call it here.
>
>
> 2011-09-09 ?Janus Weil ?<janus@gcc.gnu.org>
>
> ? ? ? ?PR fortran/47978
> ? ? ? ?* gfortran.dg/dynamic_dispatch_5.f03: Fix invalid test case.
> ? ? ? ?* gfortran.dg/typebound_proc_6.f03: Changed wording in error message.
> ? ? ? ?* gfortran.dg/typebound_override_1.f90: New.
>

Index: gcc/testsuite/gfortran.dg/dynamic_dispatch_5.f03
===================================================================
--- gcc/testsuite/gfortran.dg/dynamic_dispatch_5.f03	(revision 178757)
+++ gcc/testsuite/gfortran.dg/dynamic_dispatch_5.f03	(working copy)
@@ -56,7 +56,7 @@ module s_base_mat_mod
 contains 
   subroutine s_scals(d,a,info) 
     implicit none 
-    class(s_base_sparse_mat), intent(in) :: a
+    class(s_base_sparse_mat), intent(inout) :: a
     real(spk_), intent(in)      :: d
     integer, intent(out)            :: info
 
@@ -73,7 +73,7 @@ contains
 
   subroutine s_scal(d,a,info) 
     implicit none 
-    class(s_base_sparse_mat), intent(in) :: a
+    class(s_base_sparse_mat), intent(inout) :: a
     real(spk_), intent(in)      :: d(:)
     integer, intent(out)            :: info
 
Index: gcc/testsuite/gfortran.dg/typebound_proc_6.f03
===================================================================
--- gcc/testsuite/gfortran.dg/typebound_proc_6.f03	(revision 178757)
+++ gcc/testsuite/gfortran.dg/typebound_proc_6.f03	(working copy)
@@ -89,7 +89,7 @@ MODULE testmod
     ! For corresponding dummy arguments.
     PROCEDURE, PASS :: corresp1 => proc_tmeint ! Ok.
     PROCEDURE, PASS :: corresp2 => proc_tmeintx ! { dg-error "should be named 'a'" }
-    PROCEDURE, PASS :: corresp3 => proc_tmereal ! { dg-error "Types mismatch for dummy argument 'a'" }
+    PROCEDURE, PASS :: corresp3 => proc_tmereal ! { dg-error "Type/rank mismatch in argument 'a'" }
 
   END TYPE t
 
Index: gcc/fortran/interface.c
===================================================================
--- gcc/fortran/interface.c	(revision 178757)
+++ gcc/fortran/interface.c	(working copy)
@@ -977,6 +977,113 @@ generic_correspondence (gfc_formal_arglist *f1, gf
 }
 
 
+/* Check if the characteristics of two dummy arguments match,
+   cf. F08:12.3.2.  */
+
+static gfc_try
+check_dummy_characteristics (gfc_symbol *s1, gfc_symbol *s2,
+			     bool type_must_agree, char *errmsg, int err_len)
+{
+  /* Check type and rank.  */
+  if (type_must_agree && !compare_type_rank (s2, s1))
+    {
+      if (errmsg != NULL)
+	snprintf (errmsg, err_len, "Type/rank mismatch in argument '%s'",
+		  s1->name);
+      return FAILURE;
+    }
+
+  /* Check INTENT.  */
+  if (s1->attr.intent != s2->attr.intent)
+    {
+      snprintf (errmsg, err_len, "INTENT mismatch in argument '%s'",
+		s1->name);
+      return FAILURE;
+    }
+
+  /* Check OPTIONAL attribute.  */
+  if (s1->attr.optional != s2->attr.optional)
+    {
+      snprintf (errmsg, err_len, "OPTIONAL mismatch in argument '%s'",
+		s1->name);
+      return FAILURE;
+    }
+
+  /* Check ALLOCATABLE attribute.  */
+  if (s1->attr.allocatable != s2->attr.allocatable)
+    {
+      snprintf (errmsg, err_len, "ALLOCATABLE mismatch in argument '%s'",
+		s1->name);
+      return FAILURE;
+    }
+
+  /* Check POINTER attribute.  */
+  if (s1->attr.pointer != s2->attr.pointer)
+    {
+      snprintf (errmsg, err_len, "POINTER mismatch in argument '%s'",
+		s1->name);
+      return FAILURE;
+    }
+
+  /* Check TARGET attribute.  */
+  if (s1->attr.target != s2->attr.target)
+    {
+      snprintf (errmsg, err_len, "TARGET mismatch in argument '%s'",
+		s1->name);
+      return FAILURE;
+    }
+
+  /* FIXME: Do more comprehensive testing of attributes, like e.g.
+	    ASYNCHRONOUS, CONTIGUOUS, VALUE, VOLATILE, etc.  */
+
+  /* Check string length.  */
+  if (s1->ts.type == BT_CHARACTER
+      && s1->ts.u.cl && s1->ts.u.cl->length
+      && s2->ts.u.cl && s2->ts.u.cl->length)
+    {
+      int compval = gfc_dep_compare_expr (s1->ts.u.cl->length,
+					  s2->ts.u.cl->length);
+      switch (compval)
+      {
+	case -1:
+	case  1:
+	case -3:
+	  snprintf (errmsg, err_len, "Character length mismatch "
+		    "in argument '%s'", s1->name);
+	  return FAILURE;
+
+	case -2:
+	  /* FIXME: Implement a warning for this case.
+	  gfc_warning ("Possible character length mismatch in argument '%s'",
+		       s1->name);*/
+	  break;
+
+	case 0:
+	  break;
+
+	default:
+	  gfc_internal_error ("check_dummy_characteristics: Unexpected result "
+			      "%i of gfc_dep_compare_expr", compval);
+	  break;
+      }
+    }
+
+  /* Check array shape.  */
+  if (s1->as && s2->as)
+    {
+      if (s1->as->type != s2->as->type)
+	{
+	  snprintf (errmsg, err_len, "Shape mismatch in argument '%s'",
+		    s1->name);
+	  return FAILURE;
+	}
+      /* FIXME: Check exact shape.  */
+    }
+    
+  return SUCCESS;
+}
+
+
 /* 'Compare' two formal interfaces associated with a pair of symbols.
    We return nonzero if there exists an actual argument list that
    would be ambiguous between the two interfaces, zero otherwise.
@@ -1059,31 +1166,22 @@ gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol
 	    return 0;
 	  }
 
-	/* Check type and rank.  */
-	if (!compare_type_rank (f2->sym, f1->sym))
+	if (intent_flag)
 	  {
+	    /* Check all characteristics.  */
+	    if (check_dummy_characteristics (f1->sym, f2->sym,
+					     true, errmsg, err_len) == FAILURE)
+	      return 0;
+	  }
+	else if (!compare_type_rank (f2->sym, f1->sym))
+	  {
+	    /* Only check type and rank.  */
 	    if (errmsg != NULL)
 	      snprintf (errmsg, err_len, "Type/rank mismatch in argument '%s'",
 			f1->sym->name);
 	    return 0;
 	  }
 
-	/* Check INTENT.  */
-	if (intent_flag && (f1->sym->attr.intent != f2->sym->attr.intent))
-	  {
-	    snprintf (errmsg, err_len, "INTENT mismatch in argument '%s'",
-		      f1->sym->name);
-	    return 0;
-	  }
-
-	/* Check OPTIONAL.  */
-	if (intent_flag && (f1->sym->attr.optional != f2->sym->attr.optional))
-	  {
-	    snprintf (errmsg, err_len, "OPTIONAL mismatch in argument '%s'",
-		      f1->sym->name);
-	    return 0;
-	  }
-
 	f1 = f1->next;
 	f2 = f2->next;
       }
@@ -3468,18 +3566,18 @@ gfc_free_formal_arglist (gfc_formal_arglist *p)
 }
 
 
-/* Check that it is ok for the typebound procedure proc to override the
-   procedure old.  */
+/* Check that it is ok for the type-bound procedure 'proc' to override the
+   procedure 'old', cf. F08:4.5.7.3.  */
 
 gfc_try
 gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
 {
   locus where;
-  const gfc_symbol* proc_target;
-  const gfc_symbol* old_target;
+  const gfc_symbol *proc_target, *old_target;
   unsigned proc_pass_arg, old_pass_arg, argpos;
-  gfc_formal_arglist* proc_formal;
-  gfc_formal_arglist* old_formal;
+  gfc_formal_arglist *proc_formal, *old_formal;
+  bool check_type;
+  char err[200];
 
   /* This procedure should only be called for non-GENERIC proc.  */
   gcc_assert (!proc->n.tb->is_generic);
@@ -3637,15 +3735,12 @@ gfc_check_typebound_override (gfc_symtree* proc, g
 	  return FAILURE;
 	}
 
-      /* Check that the types correspond if neither is the passed-object
-	 argument.  */
-      /* FIXME:  Do more comprehensive testing here.  */
-      if (proc_pass_arg != argpos && old_pass_arg != argpos
-	  && !gfc_compare_types (&proc_formal->sym->ts, &old_formal->sym->ts))
+      check_type = proc_pass_arg != argpos && old_pass_arg != argpos;
+      if (check_dummy_characteristics (proc_formal->sym, old_formal->sym,
+				       check_type, err, sizeof(err)) == FAILURE)
 	{
-	  gfc_error ("Types mismatch for dummy argument '%s' of '%s' %L "
-		     "in respect to the overridden procedure",
-		     proc_formal->sym->name, proc->name, &where);
+	  gfc_error (strcat (err, " of '%s' at %L with respect to the "
+			     "overridden procedure"), proc->name, &where);
 	  return FAILURE;
 	}
 

! { dg-do compile }
!
! PR 35831: [F95] Shape mismatch check missing for dummy procedure argument
!
! Contributed by Tobias Burnus <burnus@gcc.gnu.org>

program test

  implicit none

  interface
    subroutine one(a)
      integer a(:)
    end subroutine
    subroutine two(a)
      integer a(2)
    end subroutine
  end interface

  call foo(two)  ! { dg-error "Shape mismatch in argument" }
  call bar(two)  ! { dg-error "Shape mismatch in argument" }

contains

  subroutine foo(f1)
    procedure(one) :: f1
  end subroutine foo

  subroutine bar(f2)
    interface
      subroutine f2(a)
        integer a(:)
      end subroutine
    end interface
  end subroutine bar

end program 

! { dg-do compile }

module foo_mod
  type foo
  contains
    procedure, pass(f) :: bar => base_bar
  end type foo
contains 
  subroutine base_bar(f,j)
    class(foo), intent(inout) :: f
    integer, intent(in)    :: j
  end subroutine base_bar
end module foo_mod

module extfoo_mod
  use foo_mod
  type, extends(foo) :: extfoo
  contains
    procedure, pass(f) :: bar => ext_bar  ! { dg-error "INTENT mismatch in argument" }
  end type extfoo
contains 
  subroutine ext_bar(f,j)
    class(extfoo), intent(inout) :: f
    integer, intent(inout) :: j
  end subroutine ext_bar
end module extfoo_mod 

! { dg-final { cleanup-modules "foo_mod extfoo_mod" } }