re PR fortran/54190 (TYPE(*)/assumed-rank: Type/rank check too relaxed for dummy procedure)

2013-05-31  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/54190
	PR fortran/57217
	* gfortran.h (gfc_terminal_width): Remove prototype.
	* error.c (get_terminal_width): Moved here from misc.c. Renamed.
	Try to determine terminal width from environment variable.
	* interface.c (compare_type, compare_rank): New functions. Fix assumed
	type/rank handling.
	(compare_type_rank, check_dummy_characteristics,
	check_result_characteristics, gfc_compare_interfaces): Use them.
	(symbol_rank): Slightly modified and moved.
	* misc.c (gfc_terminal_width): Moved to error.c.


2013-05-31  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/54190
	PR fortran/57217
	* gfortran.dg/dummy_procedure_5.f90: Modified error message.
	* gfortran.dg/interface_26.f90: Ditto.
	* gfortran.dg/proc_ptr_11.f90: Ditto.
	* gfortran.dg/proc_ptr_15.f90: Ditto.
	* gfortran.dg/proc_ptr_comp_20.f90: Ditto.
	* gfortran.dg/proc_ptr_comp_33.f90: Ditto.
	* gfortran.dg/proc_ptr_result_5.f90: Ditto.
	* gfortran.dg/typebound_override_1.f90: Ditto.
	* gfortran.dg/typebound_override_4.f90: Ditto.
	* gfortran.dg/typebound_proc_6.f03: Ditto.
	* gfortran.dg/assumed_type_7.f90: New test.
	* gfortran.dg/typebound_override_5.f90: New test.
	* gfortran.dg/typebound_override_6.f90: New test.
	* gfortran.dg/typebound_override_7.f90: New test.

From-SVN: r199475

gcc/fortran/ChangeLog

+2013-05-31  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/54190
+	PR fortran/57217
+	* gfortran.h (gfc_terminal_width): Remove prototype.
+	* error.c (get_terminal_width): Moved here from misc.c. Renamed.
+	Try to determine terminal width from environment variable.
+	* interface.c (compare_type, compare_rank): New functions. Fix assumed
+	type/rank handling.
+	(compare_type_rank, check_dummy_characteristics,
+	check_result_characteristics, gfc_compare_interfaces): Use them.
+	(symbol_rank): Slightly modified and moved.
+	* misc.c (gfc_terminal_width): Moved to error.c.
+
 2013-05-30  Janus Weil  <janus@gcc.gnu.org>
 
 	PR fortran/54189

gcc/fortran/error.c

@@ -59,12 +59,27 @@ gfc_pop_suppress_errors (void)
 }
 
 
+static int
+get_terminal_width (void)
+{
+  const char *p = getenv ("COLUMNS");
+  if (p)
+    {
+      int value = atoi (p);
+      if (value > 0)
+	return value;
+    }
+  /* Use a reasonable default.  */
+  return 80;
+}
+
+
 /* Per-file error initialization.  */
 
 void
 gfc_error_init_1 (void)
 {
-  terminal_width = gfc_terminal_width ();
+  terminal_width = get_terminal_width ();
   errors = 0;
   warnings = 0;
   buffer_flag = 0;

gcc/fortran/gfortran.h

@@ -2436,7 +2436,6 @@ void gfc_start_source_files (void);
 void gfc_end_source_files (void);
 
 /* misc.c */
-int gfc_terminal_width (void);
 void gfc_clear_ts (gfc_typespec *);
 FILE *gfc_open_file (const char *);
 const char *gfc_basic_typename (bt);

gcc/fortran/interface.c

@@ -508,18 +508,23 @@ gfc_compare_types (gfc_typespec *ts1, gfc_typespec *ts2)
 }
 
 
-/* Given two symbols that are formal arguments, compare their ranks
-   and types.  Returns nonzero if they have the same rank and type,
-   zero otherwise.  */
+static int
+compare_type (gfc_symbol *s1, gfc_symbol *s2)
+{
+  if (s2->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK))
+    return 1;
+
+  return gfc_compare_types (&s1->ts, &s2->ts) || s2->ts.type == BT_ASSUMED;
+}
+
 
 static int
-compare_type_rank (gfc_symbol *s1, gfc_symbol *s2)
+compare_rank (gfc_symbol *s1, gfc_symbol *s2)
 {
   gfc_array_spec *as1, *as2;
   int r1, r2;
 
-  if (s1->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK)
-      || s2->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK))
+  if (s2->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK))
     return 1;
 
   as1 = (s1->ts.type == BT_CLASS) ? CLASS_DATA (s1)->as : s1->as;
@@ -528,13 +533,21 @@ compare_type_rank (gfc_symbol *s1, gfc_symbol *s2)
   r1 = as1 ? as1->rank : 0;
   r2 = as2 ? as2->rank : 0;
 
-  if (r1 != r2
-      && (!as1 || as1->type != AS_ASSUMED_RANK)
-      && (!as2 || as2->type != AS_ASSUMED_RANK))
+  if (r1 != r2 && (!as2 || as2->type != AS_ASSUMED_RANK))
     return 0;			/* Ranks differ.  */
 
-  return gfc_compare_types (&s1->ts, &s2->ts)
-	 || s1->ts.type == BT_ASSUMED || s2->ts.type == BT_ASSUMED;
+  return 1;
+}
+
+
+/* Given two symbols that are formal arguments, compare their ranks
+   and types.  Returns nonzero if they have the same rank and type,
+   zero otherwise.  */
+
+static int
+compare_type_rank (gfc_symbol *s1, gfc_symbol *s2)
+{
+  return compare_type (s1, s2) && compare_rank (s1, s2);
 }
 
 
@@ -1019,6 +1032,15 @@ generic_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2,
 }
 
 
+static int
+symbol_rank (gfc_symbol *sym)
+{
+  gfc_array_spec *as;
+  as = (sym->ts.type == BT_CLASS) ? CLASS_DATA (sym)->as : sym->as;
+  return as ? as->rank : 0;
+}
+
+
 /* Check if the characteristics of two dummy arguments match,
    cf. F08:12.3.2.  */
 
@@ -1030,12 +1052,20 @@ check_dummy_characteristics (gfc_symbol *s1, gfc_symbol *s2,
     return s1 == s2 ? true : false;
 
   /* Check type and rank.  */
-  if (type_must_agree &&
-      (!compare_type_rank (s1, s2) || !compare_type_rank (s2, s1)))
+  if (type_must_agree)
     {
-      snprintf (errmsg, err_len, "Type/rank mismatch in argument '%s'",
-		s1->name);
-      return false;
+      if (!compare_type (s1, s2) || !compare_type (s2, s1))
+	{
+	  snprintf (errmsg, err_len, "Type mismatch in argument '%s' (%s/%s)",
+		    s1->name, gfc_typename (&s1->ts), gfc_typename (&s2->ts));
+	  return false;
+	}
+      if (!compare_rank (s1, s2))
+	{
+	  snprintf (errmsg, err_len, "Rank mismatch in argument '%s' (%i/%i)",
+		    s1->name, symbol_rank (s1), symbol_rank (s2));
+	  return false;
+	}
     }
 
   /* Check INTENT.  */
@@ -1203,9 +1233,16 @@ check_result_characteristics (gfc_symbol *s1, gfc_symbol *s2,
     return true;
 
   /* Check type and rank.  */
-  if (!compare_type_rank (r1, r2))
+  if (!compare_type (r1, r2))
+    {
+      snprintf (errmsg, err_len, "Type mismatch in function result (%s/%s)",
+		gfc_typename (&r1->ts), gfc_typename (&r2->ts));
+      return false;
+    }
+  if (!compare_rank (r1, r2))
     {
-      snprintf (errmsg, err_len, "Type/rank mismatch in function result");
+      snprintf (errmsg, err_len, "Rank mismatch in function result (%i/%i)",
+		symbol_rank (r1), symbol_rank (r2));
       return false;
     }
 
@@ -1437,13 +1474,26 @@ gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, const char *name2,
 					      errmsg, err_len))
 	      return 0;
 	  }
-	else if (!compare_type_rank (f2->sym, f1->sym))
+	else
 	  {
 	    /* Only check type and rank.  */
-	    if (errmsg != NULL)
-	      snprintf (errmsg, err_len, "Type/rank mismatch in argument '%s'",
-			f1->sym->name);
-	    return 0;
+	    if (!compare_type (f2->sym, f1->sym))
+	      {
+		if (errmsg != NULL)
+		  snprintf (errmsg, err_len, "Type mismatch in argument '%s' "
+			    "(%s/%s)", f1->sym->name,
+			    gfc_typename (&f1->sym->ts),
+			    gfc_typename (&f2->sym->ts));
+		return 0;
+	      }
+	    if (!compare_rank (f2->sym, f1->sym))
+	      {
+		if (errmsg != NULL)
+		  snprintf (errmsg, err_len, "Rank mismatch in argument '%s' "
+			    "(%i/%i)", f1->sym->name, symbol_rank (f1->sym),
+			    symbol_rank (f2->sym));
+		return 0;
+	      }
 	  }
 next:
 	f1 = f1->next;
@@ -1746,16 +1796,6 @@ done:
 }
 
 
-static int
-symbol_rank (gfc_symbol *sym)
-{
-  if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as)
-    return CLASS_DATA (sym)->as->rank;
-
-  return (sym->as == NULL) ? 0 : sym->as->rank;
-}
-
-
 /* Given a symbol of a formal argument list and an expression, if the
    formal argument is allocatable, check that the actual argument is
    allocatable. Returns nonzero if compatible, zero if not compatible.  */

gcc/fortran/misc.c

@@ -24,15 +24,6 @@ along with GCC; see the file COPYING3.  If not see
 #include "gfortran.h"
 
 
-/* Get terminal width.  */
-
-int
-gfc_terminal_width (void)
-{
-  return 80;
-}
-
-
 /* Initialize a typespec to unknown.  */
 
 void

gcc/testsuite/ChangeLog

+2013-05-31  Janus Weil  <janus@gcc.gnu.org>
+
+	PR fortran/54190
+	PR fortran/57217
+	* gfortran.dg/dummy_procedure_5.f90: Modified error message.
+	* gfortran.dg/interface_26.f90: Ditto.
+	* gfortran.dg/proc_ptr_11.f90: Ditto.
+	* gfortran.dg/proc_ptr_15.f90: Ditto.
+	* gfortran.dg/proc_ptr_comp_20.f90: Ditto.
+	* gfortran.dg/proc_ptr_comp_33.f90: Ditto.
+	* gfortran.dg/proc_ptr_result_5.f90: Ditto.
+	* gfortran.dg/typebound_override_1.f90: Ditto.
+	* gfortran.dg/typebound_override_4.f90: Ditto.
+	* gfortran.dg/typebound_proc_6.f03: Ditto.
+	* gfortran.dg/assumed_type_7.f90: New test.
+	* gfortran.dg/typebound_override_5.f90: New test.
+	* gfortran.dg/typebound_override_6.f90: New test.
+	* gfortran.dg/typebound_override_7.f90: New test.
+
 2013-05-30  Tobias Burnus  <burnus@net-b.de>
 
 	PR middle-end/57073

gcc/testsuite/gfortran.dg/assumed_type_7.f90

+! { dg-do compile }
+!
+! PR 54190: TYPE(*)/assumed-rank: Type/rank check too relaxed for dummy procedure
+!
+! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
+
+implicit none
+call sub(f)    ! { dg-error "Type mismatch in argument" }
+contains
+
+  subroutine f(x)
+    type(*) :: x
+  end subroutine
+
+  subroutine sub(g)
+    interface
+      subroutine g(x)
+        integer :: x
+      end subroutine
+    end interface
+  end subroutine
+
+end 

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 function result" }
+  call sub(ufunc)            ! { dg-error "Type mismatch in function result" }
 
 contains
 

gcc/testsuite/gfortran.dg/interface_26.f90

@@ -23,7 +23,7 @@ PROGRAM test
   USE funcs 
   INTEGER :: rs
   INTEGER, PARAMETER :: a = 2, b = 1
-  rs = recSum( a, b, test1, sumInts ) ! { dg-error "Type/rank mismatch in argument" }
+  rs = recSum( a, b, test1, sumInts ) ! { dg-error "Type mismatch in argument" }
   write(*,*) "Results", rs
 CONTAINS
   RECURSIVE INTEGER FUNCTION recSum( a,b,UserFunction,UserOp ) RESULT( res )
@@ -37,7 +37,7 @@ CONTAINS
     END INTERFACE
     INTEGER, EXTERNAL :: UserOp 
 
-    res = UserFunction( a,b, UserOp ) ! { dg-error "Type/rank mismatch in function result" }
+    res = UserFunction( a,b, UserOp ) ! { dg-error "Type 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 function result" }
-  p2 => abs   ! { dg-error "Type/rank mismatch in function result" }
+  p1 => abs   ! { dg-error "Type mismatch in function result" }
+  p2 => abs   ! { dg-error "Type mismatch in function result" }
 
   p3 => dsin
-  p3 => sin   ! { dg-error "Type/rank mismatch in function result" }
+  p3 => sin   ! { dg-error "Type 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 function result" }
-p1 => p2     ! { dg-error "Type/rank mismatch in function result" }
-p1 => p5     ! { dg-error "Type/rank mismatch in function result" }
-p6 => iabs   ! { dg-error "Type/rank mismatch in function result" }
+p1 => iabs   ! { dg-error "Type mismatch in function result" }
+p1 => p2     ! { dg-error "Type mismatch in function result" }
+p1 => p5     ! { dg-error "Type mismatch in function result" }
+p6 => iabs   ! { dg-error "Type mismatch in function result" }
 p4 => p2     ! { dg-error "is not a subroutine" }
 
 contains
@@ -32,4 +32,3 @@ contains
   end subroutine
 
 end
-

gcc/testsuite/gfortran.dg/proc_ptr_comp_20.f90

@@ -27,11 +27,11 @@ type(t2) :: o2
 procedure(logical),pointer :: pp1
 procedure(complex),pointer :: pp2
 
-pp1 => pp2        ! { dg-error "Type/rank mismatch" }
-pp2 => o2%ppc     ! { dg-error "Type/rank mismatch" }
+pp1 => pp2        ! { dg-error "Type mismatch in function result" }
+pp2 => o2%ppc     ! { dg-error "Type mismatch in function result" }
 
-o1%ppc => pp1     ! { dg-error "Type/rank mismatch" }
-o1%ppc => o2%ppc  ! { dg-error "Type/rank mismatch" }
+o1%ppc => pp1     ! { dg-error "Type mismatch in function result" }
+o1%ppc => o2%ppc  ! { dg-error "Type mismatch in function result" }
 
 contains
 

gcc/testsuite/gfortran.dg/proc_ptr_comp_33.f90

@@ -11,7 +11,7 @@ module m
 
   type :: rectangle
     real :: width, height
-    procedure(get_area_ai), pointer :: get_area => get_my_area  ! { dg-error "Type/rank mismatch" }
+    procedure(get_area_ai), pointer :: get_area => get_my_area  ! { dg-error "Type mismatch in argument" }
   end type rectangle
 
   abstract interface
@@ -51,7 +51,7 @@ program p
   type(rectangle) :: rect
 
   rect  = rectangle (1.0, 2.0, get1)
-  rect  = rectangle (3.0, 4.0, get2)  ! { dg-error "Type/rank mismatch" }
+  rect  = rectangle (3.0, 4.0, get2)  ! { dg-error "Type mismatch in argument" }
 
 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 function result" }
+  p => f()  ! { dg-error "Type mismatch in function result" }
 contains
  function f()
    pointer :: f

gcc/testsuite/gfortran.dg/typebound_override_1.f90

@@ -20,7 +20,7 @@ module m
   type, extends(t1) :: t2
    contains
      procedure, nopass :: a => a2  ! { dg-error "Character length mismatch in function result" }
-     procedure, nopass :: b => b2  ! { dg-error "Type/rank mismatch in function result" }
+     procedure, nopass :: b => b2  ! { dg-error "Rank mismatch in function result" }
      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 in function result" }

gcc/testsuite/gfortran.dg/typebound_override_4.f90

@@ -22,7 +22,7 @@ module r_mod
   implicit none
   type, extends(base_type) :: r_type
   contains
-    procedure, pass(map)  :: clone    => r_clone   ! { dg-error "Type/rank mismatch in argument" }
+    procedure, pass(map)  :: clone    => r_clone   ! { dg-error "Type mismatch in argument" }
   end type
 contains
   subroutine  r_clone(map,mapout)

gcc/testsuite/gfortran.dg/typebound_override_5.f90

+! { dg-do compile }
+!
+! PR 54190: TYPE(*)/assumed-rank: Type/rank check too relaxed for dummy procedure
+! PR 57217: [4.7/4.8/4.9 Regression][OOP] Accepts invalid TBP overriding - lacking arguments check
+!
+! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
+
+module base_mod
+  implicit none
+  type base_type
+    integer :: kind
+  contains
+    procedure, pass(map)  :: clone    => base_clone
+  end type
+contains
+  subroutine  base_clone(map,mapout,info)
+    class(base_type), intent(inout) :: map
+    class(base_type), intent(inout) :: mapout
+    integer     :: info
+  end subroutine
+end module
+
+module r_mod
+  use base_mod
+  implicit none
+  type, extends(base_type) :: r_type
+    real  :: dat
+  contains
+    procedure, pass(map)  :: clone    => r_clone   ! { dg-error "Type mismatch in argument" }
+  end type
+contains
+  subroutine  r_clone(map,mapout,info)
+    class(r_type), intent(inout) :: map
+!gcc$ attributes no_arg_check :: mapout
+    integer, intent(inout) :: mapout
+    integer     :: info
+  end subroutine
+end module
+
+! { dg-final { cleanup-modules "base_mod r_mod" } }

gcc/testsuite/gfortran.dg/typebound_override_6.f90

+! { dg-do compile }
+!
+! PR 54190: TYPE(*)/assumed-rank: Type/rank check too relaxed for dummy procedure
+! PR 57217: [4.7/4.8/4.9 Regression][OOP] Accepts invalid TBP overriding - lacking arguments check
+!
+! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
+
+module base_mod
+  implicit none
+  type base_type
+    integer :: kind
+  contains
+    procedure, pass(map)  :: clone    => base_clone
+  end type
+contains
+  subroutine  base_clone(map,mapout,info)
+    class(base_type), intent(inout) :: map
+    class(base_type), intent(inout) :: mapout
+    integer     :: info
+  end subroutine
+end module
+
+module r_mod
+  use base_mod
+  implicit none
+  type, extends(base_type) :: r_type
+    real  :: dat
+  contains
+    procedure, pass(map)  :: clone    => r_clone   ! { dg-error "Rank mismatch in argument" }
+  end type
+contains
+  subroutine  r_clone(map,mapout,info)
+    class(r_type), intent(inout) :: map
+    class(base_type), intent(inout) :: mapout(..)
+    integer     :: info
+  end subroutine
+end module
+
+! { dg-final { cleanup-modules "base_mod r_mod" } }

gcc/testsuite/gfortran.dg/typebound_override_7.f90

+! { dg-do compile }
+!
+! PR 54190: TYPE(*)/assumed-rank: Type/rank check too relaxed for dummy procedure
+! PR 57217: [4.7/4.8/4.9 Regression][OOP] Accepts invalid TBP overriding - lacking arguments check
+!
+! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
+
+module base_mod
+  implicit none
+  type base_type
+    integer :: kind
+  contains
+    procedure, pass(map)  :: clone    => base_clone
+  end type
+contains
+  subroutine  base_clone(map,mapout,info)
+    class(base_type), intent(inout) :: map
+    class(base_type), intent(inout) :: mapout
+    integer     :: info
+  end subroutine
+end module
+
+module r_mod
+  use base_mod
+  implicit none
+  type, extends(base_type) :: r_type
+    real  :: dat
+  contains
+    procedure, pass(map)  :: clone    => r_clone   ! { dg-error "Type mismatch in argument" }
+  end type
+contains
+  subroutine  r_clone(map,mapout,info)
+    class(r_type), intent(inout) :: map
+    type(*), intent(inout) :: mapout
+    integer     :: info
+  end subroutine
+end module
+
+! { dg-final { cleanup-modules "base_mod r_mod" } }

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 "Type/rank mismatch in function result" }
+    PROCEDURE, NOPASS :: intfunction3 => proc_realfunc ! { dg-error "Type mismatch in function result" }
 
     ! For access-based checks.
     PROCEDURE, NOPASS, PUBLIC :: priv => proc_sub ! Ok, increases visibility.
@@ -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 "Type/rank mismatch in argument 'a'" }
+    PROCEDURE, PASS :: corresp3 => proc_tmereal ! { dg-error "Type mismatch in argument 'a'" }
 
   END TYPE t