OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

re PR fortran/37159 (RANDOM_SEED: GET= check array size at compile time and respect -fdefault-integer-*)

Browse Source 
2008-11-01  Dennis Wassel  <dennis.wassel@gmail.com>

	PR fortran/37159
	* fortran/check.c (gfc_check_random_seed): Check PUT size
	at compile time.

2008-11-01  Dennis Wassel  <dennis.wassel@gmail.com>

	PR fortran/37159
	* intrinsics/random.c: Added comment to adapt check.c, should
	kiss_size change.
	Few cosmetic changes to existing comments.

2008-11-01  Dennis Wassel  <dennis.wassel@gmail.com>

	PR fortran/37159
	* gfortran.dg/random_seed_1.f90: New testcase.

From-SVN: r141511
This commit is contained in:
Dennis Wassel 2008-11-01 10:24:15 +00:00 committed by Thomas Koenig
parent f9fd1e7778
commit 1b867ae782
6 changed files with 57 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
gcc/fortran/ChangeLog
View File

@ -1,3 +1,9 @@
2008-11-01 Dennis Wassel <dennis.wassel@gmail.com>
PR fortran/37159
* fortran/check.c (gfc_check_random_seed): Check PUT size
at compile time.
2008-10-31 Mikael Morin <mikael.morin@tele2.fr>
PR fortran/35840

15
gcc/fortran/check.c
View File

@ -3120,9 +3120,16 @@ gfc_check_random_number (gfc_expr *harvest)
gfc_try
gfc_check_random_seed (gfc_expr *size, gfc_expr *put, gfc_expr *get)
{
unsigned int nargs = 0;
unsigned int nargs = 0, kiss_size;
locus *where = NULL;
mpz_t put_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;
if (size != NULL)
{
if (size->expr_type != EXPR_VARIABLE
@ -3162,6 +3169,12 @@ gfc_check_random_seed (gfc_expr *size, gfc_expr *put, gfc_expr *get)
if (kind_value_check (put, 1, gfc_default_integer_kind) == FAILURE)
return FAILURE;
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);
}
if (get != NULL)

5
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,8 @@
2008-11-01 Dennis Wassel <dennis.wassel@gmail.com>
PR fortran/37159
* gfortran.dg/random_seed_1.f90: New testcase.
2008-10-31 Manuel López-Ibáñez <manu@gcc.gnu.org>
* gcc.dg/cpp/Wsignprom.c: Add column numbers.

14
gcc/testsuite/gfortran.dg/random_seed_1.f90 Normal file
View File

@ -0,0 +1,14 @@
! { dg-do compile }
! Emit a diagnostic for too small PUT array at compile time
! See PR fortran/37159
! Possible improvement:
! Provide a separate testcase for systems that support REAL(16),
! to test the minimum size of 12 (instead of 8).
PROGRAM random_seed_1
IMPLICIT NONE
INTEGER :: small(7)
CALL RANDOM_SEED(PUT=small) ! { dg-error "is too small" }
END PROGRAM random_seed_1

7
libgfortran/ChangeLog
View File

@ -1,3 +1,10 @@
2008-11-01 Dennis Wassel <dennis.wassel@gmail.com>
PR fortran/37159
* intrinsics/random.c: Added comment to adapt check.c, should
kiss_size change.
Few cosmetic changes to existing comments.
2008-10-22 Jerry DeLisle <jvdelisle@gcc.gnu.org>
PR libfortran/37707

21
libgfortran/intrinsics/random.c
View File

@ -75,8 +75,7 @@ static __gthread_mutex_t random_lock;
GFC_REAL_* types in the range of [0,1). If GFC_REAL_*_RADIX are 2
or 16, respectively, we mask off the bits that don't fit into the
correct GFC_REAL_*, convert to the real type, then multiply by the
correct offset.
*/
correct offset. */
static inline void
@ -214,8 +213,7 @@ KISS algorithm. */
We do this by using three generators with different seeds, the
first one always for the most significant bits, the second one
for bits 33..64 (if present in the REAL kind), and the third one
(called twice) for REAL(16).
*/
(called twice) for REAL(16). */
#define GFC_SL(k, n) ((k)^((k)<<(n)))
#define GFC_SR(k, n) ((k)^((k)>>(n)))
@ -229,8 +227,11 @@ KISS algorithm. */
with 0<=x<2^32, 0<y<2^32, 0<=z<2^32, 0<=c<698769069
except that the two pairs
z=0,c=0 and z=2^32-1,c=698769068
should be avoided.
*/
should be avoided. */
/* Any modifications to the seeds that change kiss_size below need to be
reflected in check.c (gfc_check_random_seed) to enable correct
compile-time checking of PUT size for the RANDOM_SEED intrinsic. */
#define KISS_DEFAULT_SEED_1 123456789, 362436069, 521288629, 316191069
#define KISS_DEFAULT_SEED_2 987654321, 458629013, 582859209, 438195021
@ -390,7 +391,7 @@ arandom_r4 (gfc_array_r4 *x)
while (dest)
{
/* random_r4 (dest); */
/* random_r4 (dest); */
kiss = kiss_random_kernel (kiss_seed_1);
rnumber_4 (dest, kiss);
@ -457,7 +458,7 @@ arandom_r8 (gfc_array_r8 *x)
while (dest)
{
/* random_r8 (dest); */
/* random_r8 (dest); */
kiss = ((GFC_UINTEGER_8) kiss_random_kernel (kiss_seed_1)) << 32;
kiss += kiss_random_kernel (kiss_seed_2);
rnumber_8 (dest, kiss);
@ -527,7 +528,7 @@ arandom_r10 (gfc_array_r10 *x)
while (dest)
{
/* random_r10 (dest); */
/* random_r10 (dest); */
kiss = ((GFC_UINTEGER_8) kiss_random_kernel (kiss_seed_1)) << 32;
kiss += kiss_random_kernel (kiss_seed_2);
rnumber_10 (dest, kiss);
@ -599,7 +600,7 @@ arandom_r16 (gfc_array_r16 *x)
while (dest)
{
/* random_r16 (dest); */
/* random_r16 (dest); */
kiss1 = ((GFC_UINTEGER_8) kiss_random_kernel (kiss_seed_1)) << 32;
kiss1 += kiss_random_kernel (kiss_seed_2);