From b55c4f04b3ede3f0b299553e6de822e7d63d2ea5 Mon Sep 17 00:00:00 2001 From: Daniel Franke 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 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 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 a6622a05e6a..8252bd4b18f 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,9 @@ +2009-01-05 Daniel Franke + + 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 PR fortran/38672 diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index 228ccb2ef0f..5b6a2ebc302 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 0d2c47c25f6..fbb35296bda 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2009-01-05 Daniel Franke + + PR fortran/37159 + * gfortran.dg/random_seed_1.f90: Updated. + 2009-01-05 Mikael Morin PR fortran/38669 diff --git a/gcc/testsuite/gfortran.dg/random_seed_1.f90 b/gcc/testsuite/gfortran.dg/random_seed_1.f90 index 510badf7d68..45627ff5287 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 -- 2.30.2