From 688974a346b1f73cbf94ebe0ca95f4690a7f922b Mon Sep 17 00:00:00 2001
From: Janus Weil <janus@gcc.gnu.org>
Date: Tue, 10 Dec 2013 22:41:43 +0100
Subject: [PATCH] re PR fortran/35831 ([F95] Shape mismatch check missing for
dummy procedure argument)
2013-12-10 Janus Weil <janus@gcc.gnu.org>
PR fortran/35831
* interface.c (check_dummy_characteristics): Add checks for several
attributes.
2013-12-10 Janus Weil <janus@gcc.gnu.org>
PR fortran/35831
* gfortran.dg/c_by_val_5.f90: Modified.
* gfortran.dg/dummy_procedure_10.f90: New.
From-SVN: r205873
---
gcc/fortran/ChangeLog | 6 ++
gcc/fortran/interface.c | 33 ++++++++++-
gcc/testsuite/ChangeLog | 6 ++
gcc/testsuite/gfortran.dg/c_by_val_5.f90 | 2 +-
.../gfortran.dg/dummy_procedure_10.f90 | 56 +++++++++++++++++++
5 files changed, 100 insertions(+), 3 deletions(-)
create mode 100644 gcc/testsuite/gfortran.dg/dummy_procedure_10.f90
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index eff0a0fa88b1..cb87dd05c1ad 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,9 @@
+2013-12-10 Janus Weil <janus@gcc.gnu.org>
+
+ PR fortran/35831
+ * interface.c (check_dummy_characteristics): Add checks for several
+ attributes.
+
2013-12-10 Janus Weil <janus@gcc.gnu.org>
* gfortran.texi: Add possible kind values (and default) for
diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index da3db7e096c3..1cd1c2b0e3a6 100644
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -1114,8 +1114,37 @@ check_dummy_characteristics (gfc_symbol *s1, gfc_symbol *s2,
return false;
}
- /* FIXME: Do more comprehensive testing of attributes, like e.g.
- ASYNCHRONOUS, CONTIGUOUS, VALUE, VOLATILE, etc. */
+ /* Check ASYNCHRONOUS attribute. */
+ if (s1->attr.asynchronous != s2->attr.asynchronous)
+ {
+ snprintf (errmsg, err_len, "ASYNCHRONOUS mismatch in argument '%s'",
+ s1->name);
+ return false;
+ }
+
+ /* Check CONTIGUOUS attribute. */
+ if (s1->attr.contiguous != s2->attr.contiguous)
+ {
+ snprintf (errmsg, err_len, "CONTIGUOUS mismatch in argument '%s'",
+ s1->name);
+ return false;
+ }
+
+ /* Check VALUE attribute. */
+ if (s1->attr.value != s2->attr.value)
+ {
+ snprintf (errmsg, err_len, "VALUE mismatch in argument '%s'",
+ s1->name);
+ return false;
+ }
+
+ /* Check VOLATILE attribute. */
+ if (s1->attr.volatile_ != s2->attr.volatile_)
+ {
+ snprintf (errmsg, err_len, "VOLATILE mismatch in argument '%s'",
+ s1->name);
+ return false;
+ }
/* Check interface of dummy procedures. */
if (s1->attr.flavor == FL_PROCEDURE)
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 7c7409dbe3e6..5477f3f178db 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,9 @@
+2013-12-10 Janus Weil <janus@gcc.gnu.org>
+
+ PR fortran/35831
+ * gfortran.dg/c_by_val_5.f90: Modified.
+ * gfortran.dg/dummy_procedure_10.f90: New.
+
2013-12-10 Yury Gribov <y.gribov@samsung.com>
* gcc-dg/tsan/tsan.exp: Added missing call to torture-finish.
diff --git a/gcc/testsuite/gfortran.dg/c_by_val_5.f90 b/gcc/testsuite/gfortran.dg/c_by_val_5.f90
index 069d81711756..3a8bc3bf750c 100644
--- a/gcc/testsuite/gfortran.dg/c_by_val_5.f90
+++ b/gcc/testsuite/gfortran.dg/c_by_val_5.f90
@@ -23,7 +23,7 @@ module x
! "external" only.
interface
subroutine bmp_write(nx)
- integer :: nx
+ integer, value :: nx
end subroutine bmp_write
end interface
contains
diff --git a/gcc/testsuite/gfortran.dg/dummy_procedure_10.f90 b/gcc/testsuite/gfortran.dg/dummy_procedure_10.f90
new file mode 100644
index 000000000000..2720b8f2eb66
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/dummy_procedure_10.f90
@@ -0,0 +1,56 @@
+! { dg-do compile }
+!
+! PR 35831: [F95] Shape mismatch check missing for dummy procedure argument
+!
+! Contributed by Janus Weil <janus@gcc.gnu.org>
+
+program test_attributes
+
+ call tester1 (a1) ! { dg-error "ASYNCHRONOUS mismatch in argument" }
+ call tester2 (a2) ! { dg-error "CONTIGUOUS mismatch in argument" }
+ call tester3 (a1) ! { dg-error "VALUE mismatch in argument" }
+ call tester4 (a1) ! { dg-error "VOLATILE mismatch in argument" }
+
+contains
+
+ subroutine a1(aa)
+ real :: aa
+ end subroutine
+
+ subroutine a2(bb)
+ real :: bb(:)
+ end subroutine
+
+ subroutine tester1 (f1)
+ interface
+ subroutine f1 (a)
+ real, asynchronous :: a
+ end subroutine
+ end interface
+ end subroutine
+
+ subroutine tester2 (f2)
+ interface
+ subroutine f2 (b)
+ real, contiguous :: b(:)
+ end subroutine
+ end interface
+ end subroutine
+
+ subroutine tester3 (f3)
+ interface
+ subroutine f3 (c)
+ real, value :: c
+ end subroutine
+ end interface
+ end subroutine
+
+ subroutine tester4 (f4)
+ interface
+ subroutine f4 (d)
+ real, volatile :: d
+ end subroutine
+ end interface
+ end subroutine
+
+end
--
GitLab