diff options
author | janus <janus@138bc75d-0d04-0410-961f-82ee72b054a4> | 2013-05-31 08:09:09 +0000 |
---|---|---|
committer | janus <janus@138bc75d-0d04-0410-961f-82ee72b054a4> | 2013-05-31 08:09:09 +0000 |
commit | ee73dd7b1cfffac2a2b70ca66496f8382cc7b0e8 (patch) | |
tree | 47677cddfe498b18259a39ec527d93408dae351e /gcc | |
parent | 789a3e1c0c343c55c193906b019b9bbdccc4b2a3 (diff) | |
download | gcc-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')
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 |