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

2012-08-06  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/35831
	* interface.c (check_result_characteristics): New function, which checks
	the characteristics of function results.
	(gfc_compare_interfaces,gfc_check_typebound_override): Call it.

2012-08-06  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/35831
	* gfortran.dg/dummy_procedure_5.f90: Modified.
	* gfortran.dg/dummy_procedure_8.f90: New.
	* gfortran.dg/interface_26.f90: Modified.
	* gfortran.dg/proc_ptr_11.f90: Modified.
	* gfortran.dg/proc_ptr_15.f90: Modified.
	* gfortran.dg/proc_ptr_result_5.f90: Modified.
	* gfortran.dg/typebound_override_1.f90: Modified.
	* gfortran.dg/typebound_proc_6.f03: Modified.

From-SVN: r190187

gcc/fortran/ChangeLog

@@ -1,3 +1,10 @@
+2012-08-06  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/35831
+	* interface.c (check_result_characteristics): New function, which checks
+	the characteristics of function results.
+	(gfc_compare_interfaces,gfc_check_typebound_override): Call it.
+
 2012-08-02  Thomas König  <tkoenig@gcc.gnu.org>
 
 	 PR fortran/54033

gcc/fortran/interface.c

@@ -1006,9 +1006,8 @@ check_dummy_characteristics (gfc_symbol *s1, gfc_symbol *s2,
   /* 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'",
-	snprintf (errmsg, err_len, "Type/rank mismatch in argument '%s'",
+		s1->name);
-		  s1->name);
       return FAILURE;
     }
 
@@ -1141,6 +1140,152 @@ check_dummy_characteristics (gfc_symbol *s1, gfc_symbol *s2,
 }
 
 
+/* Check if the characteristics of two function results match,
+   cf. F08:12.3.3.  */
+
+static gfc_try
+check_result_characteristics (gfc_symbol *s1, gfc_symbol *s2,
+			      char *errmsg, int err_len)
+{
+  gfc_symbol *r1, *r2;
+
+  r1 = s1->result ? s1->result : s1;
+  r2 = s2->result ? s2->result : s2;
+
+  if (r1->ts.type == BT_UNKNOWN)
+    return SUCCESS;
+
+  /* Check type and rank.  */
+  if (!compare_type_rank (r1, r2))
+    {
+      snprintf (errmsg, err_len, "Type/rank mismatch in function result");
+      return FAILURE;
+    }
+
+  /* Check ALLOCATABLE attribute.  */
+  if (r1->attr.allocatable != r2->attr.allocatable)
+    {
+      snprintf (errmsg, err_len, "ALLOCATABLE attribute mismatch in "
+		"function result");
+      return FAILURE;
+    }
+
+  /* Check POINTER attribute.  */
+  if (r1->attr.pointer != r2->attr.pointer)
+    {
+      snprintf (errmsg, err_len, "POINTER attribute mismatch in "
+		"function result");
+      return FAILURE;
+    }
+
+  /* Check CONTIGUOUS attribute.  */
+  if (r1->attr.contiguous != r2->attr.contiguous)
+    {
+      snprintf (errmsg, err_len, "CONTIGUOUS attribute mismatch in "
+		"function result");
+      return FAILURE;
+    }
+
+  /* Check PROCEDURE POINTER attribute.  */
+  if (r1 != s1 && r1->attr.proc_pointer != r2->attr.proc_pointer)
+    {
+      snprintf (errmsg, err_len, "PROCEDURE POINTER mismatch in "
+		"function result");
+      return FAILURE;
+    }
+
+  /* Check string length.  */
+  if (r1->ts.type == BT_CHARACTER && r1->ts.u.cl && r2->ts.u.cl)
+    {
+      if (r1->ts.deferred != r2->ts.deferred)
+	{
+	  snprintf (errmsg, err_len, "Character length mismatch "
+		    "in function result");
+	  return FAILURE;
+	}
+
+      if (r1->ts.u.cl->length)
+	{
+	  int compval = gfc_dep_compare_expr (r1->ts.u.cl->length,
+					      r2->ts.u.cl->length);
+	  switch (compval)
+	  {
+	    case -1:
+	    case  1:
+	    case -3:
+	      snprintf (errmsg, err_len, "Character length mismatch "
+			"in function result");
+	      return FAILURE;
+
+	    case -2:
+	      /* FIXME: Implement a warning for this case.
+	      snprintf (errmsg, err_len, "Possible character length mismatch "
+			"in function result");*/
+	      break;
+
+	    case 0:
+	      break;
+
+	    default:
+	      gfc_internal_error ("check_result_characteristics (1): Unexpected "
+				  "result %i of gfc_dep_compare_expr", compval);
+	      break;
+	  }
+	}
+    }
+
+  /* Check array shape.  */
+  if (!r1->attr.allocatable && !r1->attr.pointer && r1->as && r2->as)
+    {
+      int i, compval;
+      gfc_expr *shape1, *shape2;
+
+      if (r1->as->type != r2->as->type)
+	{
+	  snprintf (errmsg, err_len, "Shape mismatch in function result");
+	  return FAILURE;
+	}
+
+      if (r1->as->type == AS_EXPLICIT)
+	for (i = 0; i < r1->as->rank + r1->as->corank; i++)
+	  {
+	    shape1 = gfc_subtract (gfc_copy_expr (r1->as->upper[i]),
+				   gfc_copy_expr (r1->as->lower[i]));
+	    shape2 = gfc_subtract (gfc_copy_expr (r2->as->upper[i]),
+				   gfc_copy_expr (r2->as->lower[i]));
+	    compval = gfc_dep_compare_expr (shape1, shape2);
+	    gfc_free_expr (shape1);
+	    gfc_free_expr (shape2);
+	    switch (compval)
+	    {
+	      case -1:
+	      case  1:
+	      case -3:
+		snprintf (errmsg, err_len, "Shape mismatch in dimension %i of "
+			  "function result", i + 1);
+		return FAILURE;
+
+	      case -2:
+		/* FIXME: Implement a warning for this case.
+		gfc_warning ("Possible shape mismatch in return value");*/
+		break;
+
+	      case 0:
+		break;
+
+	      default:
+		gfc_internal_error ("check_result_characteristics (2): "
+				    "Unexpected result %i of "
+				    "gfc_dep_compare_expr", compval);
+		break;
+	    }
+	  }
+    }
+
+  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.
@@ -1180,18 +1325,10 @@ gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, const char *name2,
     {
       if (s1->attr.function && s2->attr.function)
 	{
-	  /* If both are functions, check result type.  */
+	  /* If both are functions, check result characteristics.  */
-	  if (s1->ts.type == BT_UNKNOWN)
+	  if (check_result_characteristics (s1, s2, errmsg, err_len)
-	    return 1;
+	      == FAILURE)
-	  if (!compare_type_rank (s1,s2))
+	    return 0;
-	    {
-	      if (errmsg != NULL)
-		snprintf (errmsg, err_len, "Type/rank mismatch in return value "
-			  "of '%s'", name2);
-	      return 0;
-	    }
-
-	  /* FIXME: Check array bounds and string length of result.  */
 	}
 
       if (s1->attr.pure && !s2->attr.pure)
@@ -3793,7 +3930,7 @@ gfc_try
 gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
 {
   locus where;
-  const gfc_symbol *proc_target, *old_target;
+  gfc_symbol *proc_target, *old_target;
   unsigned proc_pass_arg, old_pass_arg, argpos;
   gfc_formal_arglist *proc_formal, *old_formal;
   bool check_type;
@@ -3872,45 +4009,13 @@ gfc_check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
 		     " FUNCTION", proc->name, &where);
 	  return FAILURE;
 	}
-
-      /* FIXME:  Do more comprehensive checking (including, for instance, the
-	 array-shape).  */
-      gcc_assert (proc_target->result && old_target->result);
-      if (!compare_type_rank (proc_target->result, old_target->result))
-	{
-	  gfc_error ("'%s' at %L and the overridden FUNCTION should have"
-		     " matching result types and ranks", proc->name, &where);
-	  return FAILURE;
-	}
 	
-      /* Check string length.  */
+      if (check_result_characteristics (proc_target, old_target,
-      if (proc_target->result->ts.type == BT_CHARACTER
+					err, sizeof(err)) == FAILURE)
-	  && proc_target->result->ts.u.cl && old_target->result->ts.u.cl)
 	{
-	  int compval = gfc_dep_compare_expr (proc_target->result->ts.u.cl->length,
+	  gfc_error ("Result mismatch for the overriding procedure "
-					      old_target->result->ts.u.cl->length);
+		     "'%s' at %L: %s", proc->name, &where, err);
-	  switch (compval)
+	  return FAILURE;
-	  {
-	    case -1:
-	    case  1:
-	    case -3:
-	      gfc_error ("Character length mismatch between '%s' at '%L' and "
-			 "overridden FUNCTION", proc->name, &where);
-	      return FAILURE;
-
-	    case -2:
-	      gfc_warning ("Possible character length mismatch between '%s' at"
-			   " '%L' and overridden FUNCTION", proc->name, &where);
-	      break;
-
-	    case 0:
-	      break;
-
-	    default:
-	      gfc_internal_error ("gfc_check_typebound_override: Unexpected "
-				  "result %i of gfc_dep_compare_expr", compval);
-	      break;
-	  }
 	}
     }
 

gcc/testsuite/ChangeLog

@@ -1,3 +1,15 @@
+2012-08-06  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/35831
+	* gfortran.dg/dummy_procedure_5.f90: Modified.
+	* gfortran.dg/dummy_procedure_8.f90: New.
+	* gfortran.dg/interface_26.f90: Modified.
+	* gfortran.dg/proc_ptr_11.f90: Modified.
+	* gfortran.dg/proc_ptr_15.f90: Modified.
+	* gfortran.dg/proc_ptr_result_5.f90: Modified.
+	* gfortran.dg/typebound_override_1.f90: Modified.
+	* gfortran.dg/typebound_proc_6.f03: Modified.
+
 2012-08-06  Marc Glisse  <marc.glisse@inria.fr>
 
 	PR tree-optimization/51938

gcc/testsuite/gfortran.dg/dummy_procedure_5.f90

@@ -15,7 +15,7 @@ program main
   end type
 
   type(u), external :: ufunc
-  call sub(ufunc)            ! { dg-error "Type/rank mismatch in return value" }
+  call sub(ufunc)            ! { dg-error "Type/rank mismatch in function result" }
 
 contains
 

gcc/testsuite/gfortran.dg/dummy_procedure_8.f90

@@ -0,0 +1,88 @@
+! { dg-do compile }
+!
+! PR 35831: [F95] Shape mismatch check missing for dummy procedure argument
+!
+! Contributed by Janus Weil <janus@gcc.gnu.org>
+
+implicit none
+
+call call_a(a1)  ! { dg-error "Character length mismatch in function result" }
+call call_a(a2)  ! { dg-error "Character length mismatch in function result" }
+call call_b(b1)  ! { dg-error "Shape mismatch" }
+call call_c(c1)  ! { dg-error "POINTER attribute mismatch in function result" }
+call call_d(c1)  ! { dg-error "ALLOCATABLE attribute mismatch in function result" }
+call call_e(e1)  ! { dg-error "CONTIGUOUS attribute mismatch in function result" }
+call call_f(c1)  ! { dg-error "PROCEDURE POINTER mismatch in function result" }
+
+contains
+
+  character(1) function a1()
+  end function
+
+  character(:) function a2()
+  end function
+
+  subroutine call_a(a3)
+    interface
+      character(2) function a3()
+      end function
+    end interface
+  end subroutine
+
+
+  function b1()
+    integer, dimension(1:3) :: b1
+  end function
+
+  subroutine call_b(b2)
+    interface
+      function b2()
+        integer, dimension(0:4) :: b2
+      end function
+    end interface
+  end subroutine
+
+
+  integer function c1()
+  end function
+
+  subroutine call_c(c2)
+    interface
+      function c2()
+        integer, pointer :: c2
+      end function
+    end interface
+  end subroutine
+
+
+  subroutine call_d(d2)
+    interface
+      function d2()
+        integer, allocatable :: d2
+      end function
+    end interface
+  end subroutine
+
+
+  function e1()
+    integer, dimension(:), pointer :: e1
+  end function
+
+  subroutine call_e(e2)
+    interface
+      function e2()
+        integer, dimension(:), pointer, contiguous :: e2
+      end function
+    end interface
+  end subroutine
+
+
+  subroutine call_f(f2)
+    interface
+      function f2()
+        procedure(integer), pointer :: f2
+      end function
+    end interface
+  end subroutine
+
+end

gcc/testsuite/gfortran.dg/interface_26.f90

@@ -37,7 +37,7 @@ CONTAINS
     END INTERFACE
     INTEGER, EXTERNAL :: UserOp 
 
-    res = UserFunction( a,b, UserOp ) ! { dg-error "Type/rank mismatch in return value" }
+    res = UserFunction( a,b, UserOp ) ! { dg-error "Type/rank mismatch in function result" }
 
     if( res .lt. 10 ) then
        res = recSum( a, res, UserFunction, UserOp ) 

gcc/testsuite/gfortran.dg/proc_ptr_11.f90

@@ -40,11 +40,11 @@ program bsp
   p2 => p1
   p1 => p2
 
-  p1 => abs   ! { dg-error "Type/rank mismatch in return value" }
+  p1 => abs   ! { dg-error "Type/rank mismatch in function result" }
-  p2 => abs   ! { dg-error "Type/rank mismatch in return value" }
+  p2 => abs   ! { dg-error "Type/rank mismatch in function result" }
 
   p3 => dsin
-  p3 => sin   ! { dg-error "Type/rank mismatch in return value" }
+  p3 => sin   ! { dg-error "Type/rank mismatch in function result" }
 
   contains
 

gcc/testsuite/gfortran.dg/proc_ptr_15.f90

@@ -19,10 +19,10 @@ p4 => p3
 p6 => p1
 
 ! invalid
-p1 => iabs   ! { dg-error "Type/rank mismatch in return value" }
+p1 => iabs   ! { dg-error "Type/rank mismatch in function result" }
-p1 => p2     ! { dg-error "Type/rank mismatch in return value" }
+p1 => p2     ! { dg-error "Type/rank mismatch in function result" }
-p1 => p5     ! { dg-error "Type/rank mismatch in return value" }
+p1 => p5     ! { dg-error "Type/rank mismatch in function result" }
-p6 => iabs   ! { dg-error "Type/rank mismatch in return value" }
+p6 => iabs   ! { dg-error "Type/rank mismatch in function result" }
 p4 => p2     ! { dg-error "is not a subroutine" }
 
 contains

gcc/testsuite/gfortran.dg/proc_ptr_result_5.f90

@@ -6,7 +6,7 @@
 
 program test
   procedure(real), pointer :: p
-  p => f()  ! { dg-error "Type/rank mismatch in return value" }
+  p => f()  ! { dg-error "Type/rank mismatch in function result" }
 contains
  function f()
    pointer :: f
@@ -17,4 +17,3 @@ contains
    f = .true._1
  end function f
 end program test
-

gcc/testsuite/gfortran.dg/typebound_override_1.f90

@@ -19,11 +19,11 @@ module m
 
   type, extends(t1) :: t2
    contains
-     procedure, nopass :: a => a2  ! { dg-error "Character length mismatch" }
+     procedure, nopass :: a => a2  ! { dg-error "Character length mismatch in function result" }
-     procedure, nopass :: b => b2  ! { dg-error "should have matching result types and ranks" }
+     procedure, nopass :: b => b2  ! { dg-error "Type/rank mismatch in function result" }
-     procedure, nopass :: c => c2  ! { dg-warning "Possible character length mismatch" }
+     procedure, nopass :: c => c2  ! FIXME: dg-warning "Possible character length mismatch" 
      procedure, nopass :: d => d2  ! valid, check for commutativity (+,*)
-     procedure, nopass :: e => e2  ! { dg-error "Character length mismatch" }
+     procedure, nopass :: e => e2  ! { dg-error "Character length mismatch in function result" }
   end type
 
 contains
@@ -110,7 +110,7 @@ module w2
 
  type, extends(tt1) :: tt2
  contains
-   procedure, nopass :: aa => aa2  ! { dg-warning "Possible character length mismatch" }
+   procedure, nopass :: aa => aa2  ! FIXME: dg-warning "Possible character length mismatch"
  end type
 
 contains

gcc/testsuite/gfortran.dg/typebound_proc_6.f03

@@ -72,7 +72,7 @@ MODULE testmod
     PROCEDURE, NOPASS :: subroutine2 => proc_intfunc ! { dg-error "must also be a SUBROUTINE" }
     PROCEDURE, NOPASS :: intfunction1 => proc_intfunc ! Ok, matching functions.
     PROCEDURE, NOPASS :: intfunction2 => proc_sub ! { dg-error "must also be a FUNCTION" }
-    PROCEDURE, NOPASS :: intfunction3 => proc_realfunc ! { dg-error "matching result types" }
+    PROCEDURE, NOPASS :: intfunction3 => proc_realfunc ! { dg-error "Type/rank mismatch in function result" }
 
     ! For access-based checks.
     PROCEDURE, NOPASS, PUBLIC :: priv => proc_sub ! Ok, increases visibility.