OSDN Git Service

2013-06-01 Janus Weil <janus@gcc.gnu.org>
authorjanus <janus@138bc75d-0d04-0410-961f-82ee72b054a4>
Sat, 1 Jun 2013 21:36:33 +0000 (21:36 +0000)
committerjanus <janus@138bc75d-0d04-0410-961f-82ee72b054a4>
Sat, 1 Jun 2013 21:36:33 +0000 (21:36 +0000)
    Tobias Burnus  <burnus@net-b.de>

PR fortran/57217
* interface.c (check_dummy_characteristics): Symmetrize type check.

2013-06-01  Janus Weil  <janus@gcc.gnu.org>
    Tobias Burnus  <burnus@net-b.de>

PR fortran/57217
* gfortran.dg/typebound_override_4.f90: New.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/branches/gcc-4_7-branch@199586 138bc75d-0d04-0410-961f-82ee72b054a4

gcc/fortran/ChangeLog
gcc/fortran/interface.c
gcc/testsuite/ChangeLog
gcc/testsuite/gfortran.dg/typebound_override_4.f90 [new file with mode: 0644]

index 97893b9..7f6fa7a 100644 (file)
@@ -1,3 +1,9 @@
+2013-06-01  Janus Weil  <janus@gcc.gnu.org>
+           Tobias Burnus  <burnus@net-b.de>
+
+       PR fortran/57217
+       * interface.c (check_dummy_characteristics): Symmetrize type check.
+
 2013-05-22  Janne Blomqvist  <jb@gcc.gnu.org>
 
        * intrinsic.texi (RANDOM_SEED): Improve example.
index e1f0cb6..0278995 100644 (file)
@@ -987,7 +987,8 @@ 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 (type_must_agree &&
+      (!compare_type_rank (s1, s2) || !compare_type_rank (s2, s1)))
     {
       if (errmsg != NULL)
        snprintf (errmsg, err_len, "Type/rank mismatch in argument '%s'",
index e8b54e4..d156c63 100644 (file)
@@ -1,3 +1,9 @@
+2013-06-01  Janus Weil  <janus@gcc.gnu.org>
+           Tobias Burnus  <burnus@net-b.de>
+
+       PR fortran/57217
+       * gfortran.dg/typebound_override_4.f90: New.
+
 2013-05-26  Eric Botcazou  <ebotcazou@adacore.com>
 
        * gnat.dg/specs/last_bit.ads: New test.
diff --git a/gcc/testsuite/gfortran.dg/typebound_override_4.f90 b/gcc/testsuite/gfortran.dg/typebound_override_4.f90
new file mode 100644 (file)
index 0000000..2b747a8
--- /dev/null
@@ -0,0 +1,34 @@
+! { dg-do compile }
+!
+! PR 57217: [4.7/4.8/4.9 Regression][OOP] Accepts invalid TBP overriding - lacking arguments check
+!
+! Contributed by Salvatore Filippone <filippone.salvatore@gmail.com>
+
+module base_mod
+  implicit none
+  type base_type
+  contains
+    procedure, pass(map)  :: clone    => base_clone
+  end type
+contains
+  subroutine  base_clone(map,mapout)
+    class(base_type) :: map
+    class(base_type) :: mapout
+  end subroutine
+end module
+
+module r_mod
+  use base_mod
+  implicit none
+  type, extends(base_type) :: r_type
+  contains
+    procedure, pass(map)  :: clone    => r_clone   ! { dg-error "Type/rank mismatch in argument" }
+  end type
+contains
+  subroutine  r_clone(map,mapout)
+    class(r_type) :: map
+    class(r_type) :: mapout
+  end subroutine
+end module
+
+! { dg-final { cleanup-modules "base_mod r_mod" } }