From b55c4f04b3ede3f0b299553e6de822e7d63d2ea5 Mon Sep 17 00:00:00 2001
From: Daniel Franke <franke.daniel@gmail.com>
Date: Mon, 5 Jan 2009 14:34:02 -0500
Subject: [PATCH] re PR fortran/37159 (RANDOM_SEED: GET= check array size at
compile time and respect -fdefault-integer-*)
gcc/fortran:
2009-01-05 Daniel Franke <franke.daniel@gmail.com>
PR fortran/37159
* check.c (gfc_check_random_seed): Added size check for GET
dummy argument, reworded error messages to follow common pattern.
gcc/testsuite:
2009-01-05 Daniel Franke <franke.daniel@gmail.com>
PR fortran/37159
* gfortran.dg/random_seed_1.f90: Updated.
From-SVN: r143089
---
gcc/fortran/ChangeLog | 6 +++++
gcc/fortran/check.c | 23 +++++++++++-----
gcc/testsuite/ChangeLog | 5 ++++
gcc/testsuite/gfortran.dg/random_seed_1.f90 | 30 +++++++++++++++++++--
4 files changed, 55 insertions(+), 9 deletions(-)
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index a6622a05e6a3..8252bd4b18f8 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,9 @@
+2009-01-05 Daniel Franke <franke.daniel@gmail.com>
+
+ PR fortran/37159
+ * check.c (gfc_check_random_seed): Added size check for GET
+ dummy argument, reworded error messages to follow common pattern.
+
2009-01-05 Thomas Koenig <tkoenig@gcc.gnu.org>
PR fortran/38672
diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index 228ccb2ef0f7..5b6a2ebc3025 100644
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -3136,14 +3136,15 @@ gfc_check_random_seed (gfc_expr *size, gfc_expr *put, gfc_expr *get)
{
unsigned int nargs = 0, kiss_size;
locus *where = NULL;
- mpz_t put_size;
+ mpz_t put_size, get_size;
bool have_gfc_real_16; /* Try and mimic HAVE_GFC_REAL_16 in libgfortran. */
have_gfc_real_16 = gfc_validate_kind (BT_REAL, 16, true) != -1;
- /* Keep these values in sync with kiss_size in libgfortran/random.c. */
- kiss_size = have_gfc_real_16 ? 12 : 8;
-
+ /* Keep the number of bytes in sync with kiss_size in
+ libgfortran/intrinsics/random.c. */
+ kiss_size = (have_gfc_real_16 ? 48 : 32) / gfc_default_integer_kind;
+
if (size != NULL)
{
if (size->expr_type != EXPR_VARIABLE
@@ -3186,9 +3187,10 @@ gfc_check_random_seed (gfc_expr *size, gfc_expr *put, gfc_expr *get)
if (gfc_array_size (put, &put_size) == SUCCESS
&& mpz_get_ui (put_size) < kiss_size)
- gfc_error ("Array PUT of intrinsic %s is too small (%i/%i) at %L",
- gfc_current_intrinsic, (int) mpz_get_ui (put_size),
- kiss_size, where);
+ gfc_error ("Size of '%s' argument of '%s' intrinsic at %L "
+ "too small (%i/%i)",
+ gfc_current_intrinsic_arg[1], gfc_current_intrinsic, where,
+ (int) mpz_get_ui (put_size), kiss_size);
}
if (get != NULL)
@@ -3214,6 +3216,13 @@ gfc_check_random_seed (gfc_expr *size, gfc_expr *put, gfc_expr *get)
if (kind_value_check (get, 2, gfc_default_integer_kind) == FAILURE)
return FAILURE;
+
+ if (gfc_array_size (get, &get_size) == SUCCESS
+ && mpz_get_ui (get_size) < kiss_size)
+ gfc_error ("Size of '%s' argument of '%s' intrinsic at %L "
+ "too small (%i/%i)",
+ gfc_current_intrinsic_arg[2], gfc_current_intrinsic, where,
+ (int) mpz_get_ui (get_size), kiss_size);
}
/* RANDOM_SEED may not have more than one non-optional argument. */
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 0d2c47c25f6c..fbb35296bda1 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2009-01-05 Daniel Franke <franke.daniel@gmail.com>
+
+ PR fortran/37159
+ * gfortran.dg/random_seed_1.f90: Updated.
+
2009-01-05 Mikael Morin <mikael.morin@tele2.fr>
PR fortran/38669
diff --git a/gcc/testsuite/gfortran.dg/random_seed_1.f90 b/gcc/testsuite/gfortran.dg/random_seed_1.f90
index 510badf7d68b..45627ff52873 100644
--- a/gcc/testsuite/gfortran.dg/random_seed_1.f90
+++ b/gcc/testsuite/gfortran.dg/random_seed_1.f90
@@ -6,9 +6,35 @@
! Possible improvement:
! Provide a separate testcase for systems that support REAL(16),
! to test the minimum size of 12 (instead of 8).
+!
+! Updated to check for arrays of unexpected size,
+! this also works for -fdefault-integer-8.
+!
PROGRAM random_seed_1
IMPLICIT NONE
- INTEGER :: small(7)
- CALL RANDOM_SEED(PUT=small) ! { dg-error "is too small" }
+ INTEGER, PARAMETER :: k = selected_real_kind (precision (0.0_8) + 1)
+ INTEGER, PARAMETER :: nbytes = MERGE(48, 32, k == 16)
+
+ ! '+1' to avoid out-of-bounds warnings
+ INTEGER, PARAMETER :: n = nbytes / KIND(n) + 1
+ INTEGER, DIMENSION(n) :: seed
+
+ ! Get seed, array too small
+ CALL RANDOM_SEED(GET=seed(1:(n-2))) ! { dg-error "too small" }
+
+ ! Get seed, array bigger than necessary
+ CALL RANDOM_SEED(GET=seed(1:n))
+
+ ! Get seed, proper size
+ CALL RANDOM_SEED(GET=seed(1:(n-1)))
+
+ ! Put too few bytes
+ CALL RANDOM_SEED(PUT=seed(1:(n-2))) ! { dg-error "too small" }
+
+ ! Put too many bytes
+ CALL RANDOM_SEED(PUT=seed(1:n))
+
+ ! Put the right amount of bytes
+ CALL RANDOM_SEED(PUT=seed(1:(n-1)))
END PROGRAM random_seed_1
--
GitLab