summaryrefslogtreecommitdiff
path: root/gcc
diff options
context:
space:
mode:
authorjanus <janus@138bc75d-0d04-0410-961f-82ee72b054a4>2013-05-31 08:09:09 +0000
committerjanus <janus@138bc75d-0d04-0410-961f-82ee72b054a4>2013-05-31 08:09:09 +0000
commitee73dd7b1cfffac2a2b70ca66496f8382cc7b0e8 (patch)
tree47677cddfe498b18259a39ec527d93408dae351e /gcc
parent789a3e1c0c343c55c193906b019b9bbdccc4b2a3 (diff)
downloadgcc-ee73dd7b1cfffac2a2b70ca66496f8382cc7b0e8.tar.gz
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. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@199475 138bc75d-0d04-0410-961f-82ee72b054a4
Diffstat (limited to 'gcc')
-rw-r--r--gcc/fortran/ChangeLog14
-rw-r--r--gcc/fortran/error.c17
-rw-r--r--gcc/fortran/gfortran.h1
-rw-r--r--gcc/fortran/interface.c106
-rw-r--r--gcc/fortran/misc.c9
-rw-r--r--gcc/testsuite/ChangeLog19
-rw-r--r--gcc/testsuite/gfortran.dg/assumed_type_7.f9023
-rw-r--r--gcc/testsuite/gfortran.dg/dummy_procedure_5.f902
-rw-r--r--gcc/testsuite/gfortran.dg/interface_26.f904
-rw-r--r--gcc/testsuite/gfortran.dg/proc_ptr_11.f906
-rw-r--r--gcc/testsuite/gfortran.dg/proc_ptr_15.f909
-rw-r--r--gcc/testsuite/gfortran.dg/proc_ptr_comp_20.f908
-rw-r--r--gcc/testsuite/gfortran.dg/proc_ptr_comp_33.f904
-rw-r--r--gcc/testsuite/gfortran.dg/proc_ptr_result_5.f902
-rw-r--r--gcc/testsuite/gfortran.dg/typebound_override_1.f902
-rw-r--r--gcc/testsuite/gfortran.dg/typebound_override_4.f902
-rw-r--r--gcc/testsuite/gfortran.dg/typebound_override_5.f9040
-rw-r--r--gcc/testsuite/gfortran.dg/typebound_override_6.f9039
-rw-r--r--gcc/testsuite/gfortran.dg/typebound_override_7.f9039
-rw-r--r--gcc/testsuite/gfortran.dg/typebound_proc_6.f034
20 files changed, 284 insertions, 66 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index af467b6b2a4..db8d1d09202 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,17 @@
+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
diff --git a/gcc/fortran/error.c b/gcc/fortran/error.c
index 60b209354c5..ee0dea0c1c7 100644
--- a/gcc/fortran/error.c
+++ b/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;
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 27662f7ca40..14da0aff36f 100644
--- a/gcc/fortran/gfortran.h
+++ b/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);
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index adc4e63845f..f06ecfe3ec4 100644
--- a/gcc/fortran/interface.c
+++ b/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. */
diff --git a/gcc/fortran/misc.c b/gcc/fortran/misc.c
index cce599b3cbc..9b8f31f68fc 100644
--- a/gcc/fortran/misc.c
+++ b/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
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 27bf13439d0..a46912e5a9b 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,22 @@
+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
diff --git a/gcc/testsuite/gfortran.dg/assumed_type_7.f90 b/gcc/testsuite/gfortran.dg/assumed_type_7.f90
new file mode 100644
index 00000000000..48cb43e7f8d
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/assumed_type_7.f90
@@ -0,0 +1,23 @@
+! { 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
diff --git a/gcc/testsuite/gfortran.dg/dummy_procedure_5.f90 b/gcc/testsuite/gfortran.dg/dummy_procedure_5.f90
index 5ab4e7cec8e..cb0e7c04d0e 100644
--- a/gcc/testsuite/gfortran.dg/dummy_procedure_5.f90
+++ b/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
diff --git a/gcc/testsuite/gfortran.dg/interface_26.f90 b/gcc/testsuite/gfortran.dg/interface_26.f90
index 330c434d2a3..6f8325faf32 100644
--- a/gcc/testsuite/gfortran.dg/interface_26.f90
+++ b/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 )
diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_11.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_11.f90
index e00594ab7a4..bee73f45213 100644
--- a/gcc/testsuite/gfortran.dg/proc_ptr_11.f90
+++ b/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
diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_15.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_15.f90
index f1d3d184c96..b4f1b2f6ee8 100644
--- a/gcc/testsuite/gfortran.dg/proc_ptr_15.f90
+++ b/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
-
diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_comp_20.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_comp_20.f90
index 3cad7dfa66b..29a2ef9f0d4 100644
--- a/gcc/testsuite/gfortran.dg/proc_ptr_comp_20.f90
+++ b/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
diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_comp_33.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_comp_33.f90
index b6a31fe3a0b..55a768017fa 100644
--- a/gcc/testsuite/gfortran.dg/proc_ptr_comp_33.f90
+++ b/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
diff --git a/gcc/testsuite/gfortran.dg/proc_ptr_result_5.f90 b/gcc/testsuite/gfortran.dg/proc_ptr_result_5.f90
index b021ca7c76e..121fd4d87f9 100644
--- a/gcc/testsuite/gfortran.dg/proc_ptr_result_5.f90
+++ b/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
diff --git a/gcc/testsuite/gfortran.dg/typebound_override_1.f90 b/gcc/testsuite/gfortran.dg/typebound_override_1.f90
index 96f90256342..7eb685615f4 100644
--- a/gcc/testsuite/gfortran.dg/typebound_override_1.f90
+++ b/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" }
diff --git a/gcc/testsuite/gfortran.dg/typebound_override_4.f90 b/gcc/testsuite/gfortran.dg/typebound_override_4.f90
index 2b747a87b6e..95131dea3b8 100644
--- a/gcc/testsuite/gfortran.dg/typebound_override_4.f90
+++ b/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)
diff --git a/gcc/testsuite/gfortran.dg/typebound_override_5.f90 b/gcc/testsuite/gfortran.dg/typebound_override_5.f90
new file mode 100644
index 00000000000..565dd48d4fd
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/typebound_override_5.f90
@@ -0,0 +1,40 @@
+! { 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" } }
diff --git a/gcc/testsuite/gfortran.dg/typebound_override_6.f90 b/gcc/testsuite/gfortran.dg/typebound_override_6.f90
new file mode 100644
index 00000000000..45720fd610f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/typebound_override_6.f90
@@ -0,0 +1,39 @@
+! { 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" } }
diff --git a/gcc/testsuite/gfortran.dg/typebound_override_7.f90 b/gcc/testsuite/gfortran.dg/typebound_override_7.f90
new file mode 100644
index 00000000000..0c7c48ad566
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/typebound_override_7.f90
@@ -0,0 +1,39 @@
+! { 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" } }
diff --git a/gcc/testsuite/gfortran.dg/typebound_proc_6.f03 b/gcc/testsuite/gfortran.dg/typebound_proc_6.f03
index 3a32cbc96a2..1e1d871c39f 100644
--- a/gcc/testsuite/gfortran.dg/typebound_proc_6.f03
+++ b/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