diff options
Diffstat (limited to 'libgfortran')
| -rw-r--r-- | libgfortran/ChangeLog | 12 | ||||
| -rw-r--r-- | libgfortran/gfortran.map | 3 | ||||
| -rw-r--r-- | libgfortran/intrinsics/random.c | 81 | ||||
| -rw-r--r-- | libgfortran/libgfortran.h | 9 | ||||
| -rw-r--r-- | libgfortran/runtime/main.c | 2 |
5 files changed, 91 insertions, 16 deletions
diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog index 13c6f283939..1d4055b02e1 100644 --- a/libgfortran/ChangeLog +++ b/libgfortran/ChangeLog @@ -1,3 +1,15 @@ +2007-08-12 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> + + PR fortran/30964 + PR fortran/33054 + * intrinsics/random.c (random_seed): Rename into random_seed_i4. + (random_seed_i8): New function. + * gfortran.map (GFORTRAN_1.0): Remove _gfortran_random_seed, + add _gfortran_random_seed_i4 and _gfortran_random_seed_i8. + * libgfortran.h (iexport_proto): Replace random_seed by + random_seed_i4 and random_seed_i8. + * runtime/main.c (init): Call the new random_seed_i4. + 2007-08-11 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> Tobias Burnus <burnus@gcc.gnu.org> diff --git a/libgfortran/gfortran.map b/libgfortran/gfortran.map index 8cfc23670b7..31ca41e9f88 100644 --- a/libgfortran/gfortran.map +++ b/libgfortran/gfortran.map @@ -553,7 +553,8 @@ GFORTRAN_1.0 { _gfortran_random_r16; _gfortran_random_r4; _gfortran_random_r8; - _gfortran_random_seed; + _gfortran_random_seed_i4; + _gfortran_random_seed_i8; _gfortran_rename_i4; _gfortran_rename_i4_sub; _gfortran_rename_i8; diff --git a/libgfortran/intrinsics/random.c b/libgfortran/intrinsics/random.c index 9a31a0e2995..f64f21c5b80 100644 --- a/libgfortran/intrinsics/random.c +++ b/libgfortran/intrinsics/random.c @@ -1,5 +1,5 @@ /* Implementation of the RANDOM intrinsics - Copyright 2002, 2004, 2005, 2006 Free Software Foundation, Inc. + Copyright 2002, 2004, 2005, 2006, 2007 Free Software Foundation, Inc. Contributed by Lars Segerlund <seger@linuxmail.org> and Steve Kargl. @@ -32,6 +32,7 @@ Boston, MA 02110-1301, USA. */ #include "config.h" #include "libgfortran.h" #include <gthr.h> +#include <string.h> extern void random_r4 (GFC_REAL_4 *); iexport_proto(random_r4); @@ -644,22 +645,22 @@ arandom_r16 (gfc_array_r16 *x) must be called with no argument or exactly one argument. */ void -random_seed (GFC_INTEGER_4 *size, gfc_array_i4 *put, gfc_array_i4 *get) +random_seed_i4 (GFC_INTEGER_4 *size, gfc_array_i4 *put, gfc_array_i4 *get) { int i; __gthread_mutex_lock (&random_lock); - if (size == NULL && put == NULL && get == NULL) - { - /* From the standard: "If no argument is present, the processor assigns - a processor-dependent value to the seed." */ + /* Check that we only have one argument present. */ + if ((size ? 1 : 0) + (put ? 1 : 0) + (get ? 1 : 0) > 1) + runtime_error ("RANDOM_SEED should have at most one argument present."); - for (i=0; i<kiss_size; i++) + /* From the standard: "If no argument is present, the processor assigns + a processor-dependent value to the seed." */ + if (size == NULL && put == NULL && get == NULL) + for (i = 0; i < kiss_size; i++) kiss_seed[i] = kiss_default_seed[i]; - } - if (size != NULL) *size = kiss_size; @@ -675,7 +676,7 @@ random_seed (GFC_INTEGER_4 *size, gfc_array_i4 *put, gfc_array_i4 *get) /* This code now should do correct strides. */ for (i = 0; i < kiss_size; i++) - kiss_seed[i] =(GFC_UINTEGER_4) put->data[i * put->dim[0].stride]; + kiss_seed[i] = (GFC_UINTEGER_4) put->data[i * put->dim[0].stride]; } /* Return the seed to GET data. */ @@ -696,7 +697,65 @@ random_seed (GFC_INTEGER_4 *size, gfc_array_i4 *put, gfc_array_i4 *get) __gthread_mutex_unlock (&random_lock); } -iexport(random_seed); +iexport(random_seed_i4); + + +void +random_seed_i8 (GFC_INTEGER_8 *size, gfc_array_i8 *put, gfc_array_i8 *get) +{ + int i; + + __gthread_mutex_lock (&random_lock); + + /* Check that we only have one argument present. */ + if ((size ? 1 : 0) + (put ? 1 : 0) + (get ? 1 : 0) > 1) + runtime_error ("RANDOM_SEED should have at most one argument present."); + + /* From the standard: "If no argument is present, the processor assigns + a processor-dependent value to the seed." */ + if (size == NULL && put == NULL && get == NULL) + for (i = 0; i < kiss_size; i++) + kiss_seed[i] = kiss_default_seed[i]; + + if (size != NULL) + *size = kiss_size / 2; + + if (put != NULL) + { + /* If the rank of the array is not 1, abort. */ + if (GFC_DESCRIPTOR_RANK (put) != 1) + runtime_error ("Array rank of PUT is not 1."); + + /* If the array is too small, abort. */ + if (((put->dim[0].ubound + 1 - put->dim[0].lbound)) < kiss_size / 2) + runtime_error ("Array size of PUT is too small."); + + /* This code now should do correct strides. */ + for (i = 0; i < kiss_size; i += 2) + memcpy (&kiss_seed[i], &(put->data[i * put->dim[0].stride]), + sizeof (GFC_UINTEGER_8)); + } + + /* Return the seed to GET data. */ + if (get != NULL) + { + /* If the rank of the array is not 1, abort. */ + if (GFC_DESCRIPTOR_RANK (get) != 1) + runtime_error ("Array rank of GET is not 1."); + + /* If the array is too small, abort. */ + if (((get->dim[0].ubound + 1 - get->dim[0].lbound)) < kiss_size / 2) + runtime_error ("Array size of GET is too small."); + + /* This code now should do correct strides. */ + for (i = 0; i < kiss_size; i += 2) + memcpy (&(get->data[i * get->dim[0].stride]), &kiss_seed[i], + sizeof (GFC_UINTEGER_8)); + } + + __gthread_mutex_unlock (&random_lock); +} +iexport(random_seed_i8); #ifndef __GTHREAD_MUTEX_INIT diff --git a/libgfortran/libgfortran.h b/libgfortran/libgfortran.h index 06718013cc8..ce6d28e9f95 100644 --- a/libgfortran/libgfortran.h +++ b/libgfortran/libgfortran.h @@ -768,9 +768,12 @@ iexport_proto(compare_string); /* random.c */ -extern void random_seed (GFC_INTEGER_4 * size, gfc_array_i4 * put, - gfc_array_i4 * get); -iexport_proto(random_seed); +extern void random_seed_i4 (GFC_INTEGER_4 * size, gfc_array_i4 * put, + gfc_array_i4 * get); +iexport_proto(random_seed_i4); +extern void random_seed_i8 (GFC_INTEGER_8 * size, gfc_array_i8 * put, + gfc_array_i8 * get); +iexport_proto(random_seed_i8); /* size.c */ diff --git a/libgfortran/runtime/main.c b/libgfortran/runtime/main.c index 570e9591213..87adcd228ce 100644 --- a/libgfortran/runtime/main.c +++ b/libgfortran/runtime/main.c @@ -162,7 +162,7 @@ init (void) /* if (argc > 1 && strcmp(argv[1], "--resume") == 0) resume(); */ #endif - random_seed(NULL,NULL,NULL); + random_seed_i4 (NULL, NULL, NULL); } |