From 28142763147a93f59e1538f16983cbe9158bf37a Mon Sep 17 00:00:00 2001
From: tkoenig <tkoenig@138bc75d-0d04-0410-961f-82ee72b054a4>
Date: Sat, 4 Feb 2006 22:11:57 +0000
Subject: [PATCH] 2006-02-04 Thomas Koenig <Thomas.Koenig@online.de>
PR fortran/25075
check.c (identical_dimen_shape): New function.
(check_dot_product): Use identical_dimen_shape() to check sizes
for dot_product.
(gfc_check_matmul): Likewise.
(gfc_check_merge): Check conformance between tsource and fsource
and between tsource and mask.
(gfc_check_pack): Check conformance between array and mask.
2006-02-04 Thomas Koenig <Thomas.Koenig@online.de>
PR fortran/25075
intrinsic_argument_conformance_1.f90: New test.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@110596 138bc75d-0d04-0410-961f-82ee72b054a4
---
gcc/fortran/ChangeLog | 11 +++
gcc/fortran/check.c | 97 ++++++++++++++++---
gcc/testsuite/ChangeLog | 5 +
.../intrinsic_argument_conformance_1.f90 | 10 ++
4 files changed, 111 insertions(+), 12 deletions(-)
create mode 100644 gcc/testsuite/gfortran.dg/intrinsic_argument_conformance_1.f90
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 5dfdb5232bdb..2ea8316293a0 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,14 @@
+2006-02-04 Thomas Koenig <Thomas.Koenig@online.de>
+
+ PR fortran/25075
+ check.c (identical_dimen_shape): New function.
+ (check_dot_product): Use identical_dimen_shape() to check sizes
+ for dot_product.
+ (gfc_check_matmul): Likewise.
+ (gfc_check_merge): Check conformance between tsource and fsource
+ and between tsource and mask.
+ (gfc_check_pack): Check conformance between array and mask.
+
2006-02-03 Steven G. Kargl <kargls@comcast>
Paul Thomas <pault@gcc.gnu.org>
diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index 8b56d520f7fc..dc6541c85980 100644
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -354,6 +354,34 @@ dim_rank_check (gfc_expr * dim, gfc_expr * array, int allow_assumed)
return SUCCESS;
}
+/* Compare the size of a along dimension ai with the size of b along
+ dimension bi, returning 0 if they are known not to be identical,
+ and 1 if they are identical, or if this cannot be determined. */
+
+static int
+identical_dimen_shape (gfc_expr *a, int ai, gfc_expr *b, int bi)
+{
+ mpz_t a_size, b_size;
+ int ret;
+
+ gcc_assert (a->rank > ai);
+ gcc_assert (b->rank > bi);
+
+ ret = 1;
+
+ if (gfc_array_dimen_size (a, ai, &a_size) == SUCCESS)
+ {
+ if (gfc_array_dimen_size (b, bi, &b_size) == SUCCESS)
+ {
+ if (mpz_cmp (a_size, b_size) != 0)
+ ret = 0;
+
+ mpz_clear (b_size);
+ }
+ mpz_clear (a_size);
+ }
+ return ret;
+}
/***** Check functions *****/
@@ -802,6 +830,16 @@ gfc_check_dot_product (gfc_expr * vector_a, gfc_expr * vector_b)
if (rank_check (vector_b, 1, 1) == FAILURE)
return FAILURE;
+ if (! identical_dimen_shape (vector_a, 0, vector_b, 0))
+ {
+ gfc_error ("different shape for arguments '%s' and '%s' "
+ "at %L for intrinsic 'dot_product'",
+ gfc_current_intrinsic_arg[0],
+ gfc_current_intrinsic_arg[1],
+ &vector_a->where);
+ return FAILURE;
+ }
+
return SUCCESS;
}
@@ -1461,13 +1499,35 @@ gfc_check_matmul (gfc_expr * matrix_a, gfc_expr * matrix_b)
case 1:
if (rank_check (matrix_b, 1, 2) == FAILURE)
return FAILURE;
+ /* Check for case matrix_a has shape(m), matrix_b has shape (m, k). */
+ if (! identical_dimen_shape (matrix_a, 0, matrix_b, 0))
+ {
+ gfc_error ("different shape on dimension 1 for arguments '%s' "
+ "and '%s' at %L for intrinsic matmul",
+ gfc_current_intrinsic_arg[0],
+ gfc_current_intrinsic_arg[1],
+ &matrix_a->where);
+ return FAILURE;
+ }
break;
case 2:
- if (matrix_b->rank == 2)
- break;
- if (rank_check (matrix_b, 1, 1) == FAILURE)
- return FAILURE;
+ if (matrix_b->rank != 2)
+ {
+ if (rank_check (matrix_b, 1, 1) == FAILURE)
+ return FAILURE;
+ }
+ /* matrix_b has rank 1 or 2 here. Common check for the cases
+ - matrix_a has shape (n,m) and matrix_b has shape (m, k)
+ - matrix_a has shape (n,m) and matrix_b has shape (m). */
+ if (! identical_dimen_shape (matrix_a, 1, matrix_b, 0))
+ {
+ gfc_error ("different shape on dimension 2 for argument '%s' and "
+ "dimension 1 for argument '%s' at %L for intrinsic "
+ "matmul", gfc_current_intrinsic_arg[0],
+ gfc_current_intrinsic_arg[1], &matrix_a->where);
+ return FAILURE;
+ }
break;
default:
@@ -1621,12 +1681,26 @@ gfc_check_product_sum (gfc_actual_arglist * ap)
try
gfc_check_merge (gfc_expr * tsource, gfc_expr * fsource, gfc_expr * mask)
{
+ char buffer[80];
+
if (same_type_check (tsource, 0, fsource, 1) == FAILURE)
return FAILURE;
if (type_check (mask, 2, BT_LOGICAL) == FAILURE)
return FAILURE;
+ snprintf(buffer, sizeof(buffer), "arguments '%s' and '%s' for intrinsic '%s'",
+ gfc_current_intrinsic_arg[0], gfc_current_intrinsic_arg[1],
+ gfc_current_intrinsic);
+ if (gfc_check_conformance (buffer, tsource, fsource) == FAILURE)
+ return FAILURE;
+
+ snprintf(buffer, sizeof(buffer), "arguments '%s' and '%s' for intrinsic '%s'",
+ gfc_current_intrinsic_arg[0], gfc_current_intrinsic_arg[2],
+ gfc_current_intrinsic);
+ if (gfc_check_conformance (buffer, tsource, mask) == FAILURE)
+ return FAILURE;
+
return SUCCESS;
}
@@ -1672,20 +1746,19 @@ gfc_check_null (gfc_expr * mold)
try
gfc_check_pack (gfc_expr * array, gfc_expr * mask, gfc_expr * vector)
{
+ char buffer[80];
+
if (array_check (array, 0) == FAILURE)
return FAILURE;
if (type_check (mask, 1, BT_LOGICAL) == FAILURE)
return FAILURE;
- if (mask->rank != 0 && mask->rank != array->rank)
- {
- gfc_error ("'%s' argument of '%s' intrinsic at %L must be conformable "
- "with '%s' argument", gfc_current_intrinsic_arg[0],
- gfc_current_intrinsic, &array->where,
- gfc_current_intrinsic_arg[1]);
- return FAILURE;
- }
+ snprintf(buffer, sizeof(buffer), "arguments '%s' and '%s' for intrinsic '%s'",
+ gfc_current_intrinsic_arg[0], gfc_current_intrinsic_arg[1],
+ gfc_current_intrinsic);
+ if (gfc_check_conformance (buffer, array, mask) == FAILURE)
+ return FAILURE;
if (vector != NULL)
{
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index f3ebef145082..d35cfa1ab105 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2006-02-04 Thomas Koenig <Thomas.Koenig@online.de>
+
+ PR fortran/25075
+ intrinsic_argument_conformance_1.f90: New test.
+
2006-02-03 Steven G. Kargl <kargls@comcast.net>
PR fortran/20845
diff --git a/gcc/testsuite/gfortran.dg/intrinsic_argument_conformance_1.f90 b/gcc/testsuite/gfortran.dg/intrinsic_argument_conformance_1.f90
new file mode 100644
index 000000000000..bfdcf429ebbe
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/intrinsic_argument_conformance_1.f90
@@ -0,0 +1,10 @@
+! { dg-do compile }
+program main
+ real :: av(2), bv(4)
+ real :: a(2,2)
+ logical :: lo(3,2)
+ print *,dot_product(av, bv) ! { dg-error "different shape" }
+ print *,pack(a, lo) ! { dg-error "different shape" }
+ print *,merge(av, bv, lo(1,:)) ! { dg-error "different shape" }
+ print *,matmul(bv,a) ! { dg-error "different shape" }
+end program main
--
GitLab