re PR fortran/35831 ([F95] Shape mismatch check missing for dummy procedure argument)

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/proc_decl_26.f90: New.
	* gfortran.dg/typebound_override_2.f90: New.
	* gfortran.dg/typebound_proc_6.f03: Changed wording in error message.

From-SVN: r178767

gcc/fortran/ChangeLog

@@ -1,3 +1,11 @@
+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-08  Mikael Morin  <mikael.morin@sfr.fr>
 
 	* trans-array.c (gfc_trans_constant_array_constructor): Remove

gcc/fortran/interface.c

@@ -977,6 +977,113 @@ generic_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2)
 }
 
 
+/* 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 *s2, const char *name2,
 	    return 0;
 	  }
 
-	/* Check type and rank.  */
+	if (intent_flag)
-	if (!compare_type_rank (f2->sym, f1->sym))
 	  {
+	    /* 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
+/* Check that it is ok for the type-bound procedure 'proc' to override the
-   procedure old.  */
+   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 *proc_target, *old_target;
-  const gfc_symbol* old_target;
   unsigned proc_pass_arg, old_pass_arg, argpos;
-  gfc_formal_arglist* proc_formal;
+  gfc_formal_arglist *proc_formal, *old_formal;
-  gfc_formal_arglist* 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, gfc_symtree* old)
 	  return FAILURE;
 	}
 
-      /* Check that the types correspond if neither is the passed-object
+      check_type = proc_pass_arg != argpos && old_pass_arg != argpos;
-	 argument.  */
+      if (check_dummy_characteristics (proc_formal->sym, old_formal->sym,
-      /* FIXME:  Do more comprehensive testing here.  */
+				       check_type, err, sizeof(err)) == FAILURE)
-      if (proc_pass_arg != argpos && old_pass_arg != argpos
-	  && !gfc_compare_types (&proc_formal->sym->ts, &old_formal->sym->ts))
 	{
-	  gfc_error ("Types mismatch for dummy argument '%s' of '%s' %L "
+	  gfc_error ("Argument mismatch for the overriding procedure "
-		     "in respect to the overridden procedure",
+		     "'%s' at %L: %s", proc->name, &where, err);
-		     proc_formal->sym->name, proc->name, &where);
 	  return FAILURE;
 	}
 

gcc/testsuite/ChangeLog

@@ -1,3 +1,12 @@
+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/proc_decl_26.f90: New.
+	* gfortran.dg/typebound_override_2.f90: New.
+	* gfortran.dg/typebound_proc_6.f03: Changed wording in error message.
+
 2011-09-11  Eric Botcazou  <ebotcazou@adacore.com>
 
 	* gnat.dg/cond_expr2.ad[sb]: New test.

gcc/testsuite/gfortran.dg/dynamic_dispatch_5.f03

@@ -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
 

gcc/testsuite/gfortran.dg/proc_decl_26.f90

@@ -0,0 +1,37 @@
+! { 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 

gcc/testsuite/gfortran.dg/typebound_override_2.f90

@@ -0,0 +1,32 @@
+! { dg-do compile }
+!
+! PR 47978: [OOP] Invalid INTENT in overriding TBP not detected
+!
+! Contributed by Salvatore Filippone <sfilippone@uniroma2.it>
+
+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" } }

gcc/testsuite/gfortran.dg/typebound_proc_6.f03

@@ -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