re PR fortran/37159 (RANDOM_SEED: GET= check array size at compile time and respect...

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

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index f7f763f97671bda6ea52c7f2dfc2384e834e895c..8f0e58d15480df84d5cfdf67b11ed3d9f8fed807 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -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

diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index 1f9ce2fff6ab4c4326b51289cb85ec94f8535df2..de507676491d6449f773d831a72d72eabbf33a4d 100644 (file)
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -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)

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 9051361982e19179598e192eb3906238d8e74994..db83bac28e30bc8f8502b918a64f6575a77d174c 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -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.

diff --git a/gcc/testsuite/gfortran.dg/random_seed_1.f90 b/gcc/testsuite/gfortran.dg/random_seed_1.f90
new file mode 100644 (file)
index 0000000..510badf
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/random_seed_1.f90
@@ -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

diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog
index c4630a57f11a0007962d149a16a1cfd9dfbeec5c..2903760cb8c5b7fc7f6b048ea0f0ad884cf7e532 100644 (file)
--- a/libgfortran/ChangeLog
+++ b/libgfortran/ChangeLog
@@ -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

diff --git a/libgfortran/intrinsics/random.c b/libgfortran/intrinsics/random.c
index 360e6ec22bab622146bada2f93428cd2626d3226..24ba1058e57cf996049c6e9bfa416df54c7f96c6 100644 (file)
--- a/libgfortran/intrinsics/random.c
+++ b/libgfortran/intrinsics/random.c
@@ -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);