format.c: Removing unused code.
* io/format.c: Removing unused code. * intrinsics/random.c: Likewise. From-SVN: r108014
This commit is contained in:
Francois-Xavier Coudert
François-Xavier Coudert
parent
0954310ff3
commit
93af36c5c1
@ -1,3 +1,8 @@
|
||||
2005-12-04 Francois-Xavier Coudert <coudert@clipper.ens.fr>
|
||||
|
||||
* io/format.c: Removing unused code.
|
||||
* intrinsics/random.c: Likewise.
|
||||
|
||||
2005-12-02 Francois-Xavier Coudert <coudert@clipper.ens.fr>
|
||||
|
||||
PR libfortran/25116
|
||||
|
||||
@ -51,383 +51,30 @@ static __gthread_mutex_t random_lock = __GTHREAD_MUTEX_INIT;
|
||||
static __gthread_mutex_t random_lock;
|
||||
#endif
|
||||
|
||||
#if 0
|
||||
|
||||
/* The Mersenne Twister code is currently commented out due to
|
||||
|
||||
(1) Simple user specified seeds lead to really bad sequences for
|
||||
nearly 100000 random numbers.
|
||||
(2) open(), read(), and close() are not properly declared via header
|
||||
files.
|
||||
(3) The global index i is abused and causes unexpected behavior with
|
||||
GET and PUT.
|
||||
(4) See PR 15619.
|
||||
|
||||
The algorithm was taken from the paper :
|
||||
/* libgfortran previously had a Mersenne Twister, taken from the paper:
|
||||
|
||||
Mersenne Twister: 623-dimensionally equidistributed
|
||||
uniform pseudorandom generator.
|
||||
|
||||
by: Makoto Matsumoto
|
||||
Takuji Nishimura
|
||||
|
||||
Which appeared in the: ACM Transactions on Modelling and Computer
|
||||
by Makoto Matsumoto & Takuji Nishimura
|
||||
which appeared in the: ACM Transactions on Modelling and Computer
|
||||
Simulations: Special Issue on Uniform Random Number
|
||||
Generation. ( Early in 1998 ). */
|
||||
Generation. ( Early in 1998 ).
|
||||
|
||||
The Mersenne Twister code was replaced due to
|
||||
|
||||
(1) Simple user specified seeds lead to really bad sequences for
|
||||
nearly 100000 random numbers.
|
||||
(2) open(), read(), and close() were not properly declared via header
|
||||
files.
|
||||
(3) The global index i was abused and caused unexpected behavior with
|
||||
GET and PUT.
|
||||
(4) See PR 15619.
|
||||
|
||||
|
||||
#include <stdio.h>
|
||||
#include <stdlib.h>
|
||||
#include <sys/types.h>
|
||||
#include <sys/stat.h>
|
||||
#include <fcntl.h>
|
||||
|
||||
#ifdef HAVE_UNISTD_H
|
||||
#include <unistd.h>
|
||||
#endif
|
||||
|
||||
/*Use the 'big' generator by default ( period -> 2**19937 ). */
|
||||
|
||||
#define MT19937
|
||||
|
||||
/* Define the necessary constants for the algorithm. */
|
||||
|
||||
#ifdef MT19937
|
||||
enum constants
|
||||
{
|
||||
N = 624, M = 397, R = 19, TU = 11, TS = 7, TT = 15, TL = 17
|
||||
};
|
||||
#define M_A 0x9908B0DF
|
||||
#define T_B 0x9D2C5680
|
||||
#define T_C 0xEFC60000
|
||||
#else
|
||||
enum constants
|
||||
{
|
||||
N = 351, M = 175, R = 19, TU = 11, TS = 7, TT = 15, TL = 17
|
||||
};
|
||||
#define M_A 0xE4BD75F5
|
||||
#define T_B 0x655E5280
|
||||
#define T_C 0xFFD58000
|
||||
#endif
|
||||
|
||||
static int i = N;
|
||||
static unsigned int seed[N];
|
||||
|
||||
/* This is the routine which handles the seeding of the generator,
|
||||
and also reading and writing of the seed. */
|
||||
|
||||
void
|
||||
random_seed (GFC_INTEGER_4 *size, gfc_array_i4 *put, gfc_array_i4 *get)
|
||||
{
|
||||
__gthread_mutex_lock (&random_lock);
|
||||
|
||||
/* Initialize the seed in system dependent manner. */
|
||||
if (get == NULL && put == NULL && size == NULL)
|
||||
{
|
||||
int fd;
|
||||
fd = open ("/dev/urandom", O_RDONLY);
|
||||
if (fd < 0)
|
||||
{
|
||||
/* We dont have urandom. */
|
||||
GFC_UINTEGER_4 s = (GFC_UINTEGER_4) seed;
|
||||
for (i = 0; i < N; i++)
|
||||
{
|
||||
s = s * 29943829 - 1;
|
||||
seed[i] = s;
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
/* Using urandom, might have a length issue. */
|
||||
read (fd, &seed[0], sizeof (GFC_UINTEGER_4) * N);
|
||||
close (fd);
|
||||
i = N;
|
||||
}
|
||||
goto return_unlock;
|
||||
}
|
||||
|
||||
/* Return the size of the seed */
|
||||
if (size != NULL)
|
||||
{
|
||||
*size = N;
|
||||
goto return_unlock;
|
||||
}
|
||||
|
||||
/* if we have gotten to this pount we have a get or put
|
||||
* now we check it the array fulfills the demands in the standard .
|
||||
*/
|
||||
|
||||
/* Set the seed to PUT data */
|
||||
if (put != NULL)
|
||||
{
|
||||
/* if the rank of the array is not 1 abort */
|
||||
if (GFC_DESCRIPTOR_RANK (put) != 1)
|
||||
abort ();
|
||||
|
||||
/* if the array is too small abort */
|
||||
if (((put->dim[0].ubound + 1 - put->dim[0].lbound)) < N)
|
||||
abort ();
|
||||
|
||||
/* If this is the case the array is a temporary */
|
||||
if (put->dim[0].stride == 0)
|
||||
goto return_unlock;
|
||||
|
||||
/* This code now should do correct strides. */
|
||||
for (i = 0; i < N; i++)
|
||||
seed[i] = put->data[i * put->dim[0].stride];
|
||||
}
|
||||
|
||||
/* 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)
|
||||
abort ();
|
||||
|
||||
/* if the array is too small abort */
|
||||
if (((get->dim[0].ubound + 1 - get->dim[0].lbound)) < N)
|
||||
abort ();
|
||||
|
||||
/* If this is the case the array is a temporary */
|
||||
if (get->dim[0].stride == 0)
|
||||
goto return_unlock;
|
||||
|
||||
/* This code now should do correct strides. */
|
||||
for (i = 0; i < N; i++)
|
||||
get->data[i * get->dim[0].stride] = seed[i];
|
||||
}
|
||||
|
||||
random_unlock:
|
||||
__gthread_mutex_unlock (&random_lock);
|
||||
}
|
||||
iexport(random_seed);
|
||||
|
||||
/* Here is the internal routine which generates the random numbers
|
||||
in 'batches' based upon the need for a new batch.
|
||||
It's an integer based routine known as 'Mersenne Twister'.
|
||||
This implementation still lacks 'tempering' and a good verification,
|
||||
but gives very good metrics. */
|
||||
|
||||
static void
|
||||
random_generate (void)
|
||||
{
|
||||
/* 32 bits. */
|
||||
GFC_UINTEGER_4 y;
|
||||
|
||||
/* Generate batch of N. */
|
||||
int k, m;
|
||||
for (k = 0, m = M; k < N - 1; k++)
|
||||
{
|
||||
y = (seed[k] & (-1 << R)) | (seed[k + 1] & ((1u << R) - 1));
|
||||
seed[k] = seed[m] ^ (y >> 1) ^ (-(GFC_INTEGER_4) (y & 1) & M_A);
|
||||
if (++m >= N)
|
||||
m = 0;
|
||||
}
|
||||
|
||||
y = (seed[N - 1] & (-1 << R)) | (seed[0] & ((1u << R) - 1));
|
||||
seed[N - 1] = seed[M - 1] ^ (y >> 1) ^ (-(GFC_INTEGER_4) (y & 1) & M_A);
|
||||
i = 0;
|
||||
}
|
||||
|
||||
/* A routine to return a REAL(KIND=4). */
|
||||
|
||||
void
|
||||
random_r4 (GFC_REAL_4 * harv)
|
||||
{
|
||||
__gthread_mutex_lock (&random_lock);
|
||||
|
||||
/* Regenerate if we need to. */
|
||||
if (i >= N)
|
||||
random_generate ();
|
||||
|
||||
/* Convert uint32 to REAL(KIND=4). */
|
||||
*harv = (GFC_REAL_4) ((GFC_REAL_4) (GFC_UINTEGER_4) seed[i++] /
|
||||
(GFC_REAL_4) (~(GFC_UINTEGER_4) 0));
|
||||
__gthread_mutex_unlock (&random_lock);
|
||||
}
|
||||
iexport(random_r4);
|
||||
|
||||
/* A routine to return a REAL(KIND=8). */
|
||||
|
||||
void
|
||||
random_r8 (GFC_REAL_8 * harv)
|
||||
{
|
||||
__gthread_mutex_lock (&random_lock);
|
||||
|
||||
/* Regenerate if we need to, may waste one 32-bit value. */
|
||||
if ((i + 1) >= N)
|
||||
random_generate ();
|
||||
|
||||
/* Convert two uint32 to a REAL(KIND=8). */
|
||||
*harv = ((GFC_REAL_8) ((((GFC_UINTEGER_8) seed[i+1]) << 32) + seed[i])) /
|
||||
(GFC_REAL_8) (~(GFC_UINTEGER_8) 0);
|
||||
i += 2;
|
||||
__gthread_mutex_unlock (&random_lock);
|
||||
}
|
||||
iexport(random_r8);
|
||||
|
||||
/* Code to handle arrays will follow here. */
|
||||
|
||||
/* REAL(KIND=4) REAL array. */
|
||||
|
||||
void
|
||||
arandom_r4 (gfc_array_r4 * harv)
|
||||
{
|
||||
index_type count[GFC_MAX_DIMENSIONS];
|
||||
index_type extent[GFC_MAX_DIMENSIONS];
|
||||
index_type stride[GFC_MAX_DIMENSIONS];
|
||||
index_type stride0;
|
||||
index_type dim;
|
||||
GFC_REAL_4 *dest;
|
||||
int n;
|
||||
|
||||
dest = harv->data;
|
||||
|
||||
if (harv->dim[0].stride == 0)
|
||||
harv->dim[0].stride = 1;
|
||||
|
||||
dim = GFC_DESCRIPTOR_RANK (harv);
|
||||
|
||||
for (n = 0; n < dim; n++)
|
||||
{
|
||||
count[n] = 0;
|
||||
stride[n] = harv->dim[n].stride;
|
||||
extent[n] = harv->dim[n].ubound + 1 - harv->dim[n].lbound;
|
||||
if (extent[n] <= 0)
|
||||
return;
|
||||
}
|
||||
|
||||
stride0 = stride[0];
|
||||
|
||||
__gthread_mutex_lock (&random_lock);
|
||||
|
||||
while (dest)
|
||||
{
|
||||
/* Set the elements. */
|
||||
|
||||
/* regenerate if we need to */
|
||||
if (i >= N)
|
||||
random_generate ();
|
||||
|
||||
/* Convert uint32 to float in a hopefully g95 compiant manner */
|
||||
*dest = (GFC_REAL_4) ((GFC_REAL_4) (GFC_UINTEGER_4) seed[i++] /
|
||||
(GFC_REAL_4) (~(GFC_UINTEGER_4) 0));
|
||||
|
||||
/* Advance to the next element. */
|
||||
dest += stride0;
|
||||
count[0]++;
|
||||
/* Advance to the next source element. */
|
||||
n = 0;
|
||||
while (count[n] == extent[n])
|
||||
{
|
||||
/* When we get to the end of a dimension,
|
||||
reset it and increment
|
||||
the next dimension. */
|
||||
count[n] = 0;
|
||||
/* We could precalculate these products,
|
||||
but this is a less
|
||||
frequently used path so proabably not worth it. */
|
||||
dest -= stride[n] * extent[n];
|
||||
n++;
|
||||
if (n == dim)
|
||||
{
|
||||
dest = NULL;
|
||||
break;
|
||||
}
|
||||
else
|
||||
{
|
||||
count[n]++;
|
||||
dest += stride[n];
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
__gthread_mutex_unlock (&random_lock);
|
||||
}
|
||||
|
||||
/* REAL(KIND=8) array. */
|
||||
|
||||
void
|
||||
arandom_r8 (gfc_array_r8 * harv)
|
||||
{
|
||||
index_type count[GFC_MAX_DIMENSIONS];
|
||||
index_type extent[GFC_MAX_DIMENSIONS];
|
||||
index_type stride[GFC_MAX_DIMENSIONS];
|
||||
index_type stride0;
|
||||
index_type dim;
|
||||
GFC_REAL_8 *dest;
|
||||
int n;
|
||||
|
||||
dest = harv->data;
|
||||
|
||||
if (harv->dim[0].stride == 0)
|
||||
harv->dim[0].stride = 1;
|
||||
|
||||
dim = GFC_DESCRIPTOR_RANK (harv);
|
||||
|
||||
for (n = 0; n < dim; n++)
|
||||
{
|
||||
count[n] = 0;
|
||||
stride[n] = harv->dim[n].stride;
|
||||
extent[n] = harv->dim[n].ubound + 1 - harv->dim[n].lbound;
|
||||
if (extent[n] <= 0)
|
||||
return;
|
||||
}
|
||||
|
||||
stride0 = stride[0];
|
||||
|
||||
__gthread_mutex_lock (&random_lock);
|
||||
|
||||
while (dest)
|
||||
{
|
||||
/* Set the elements. */
|
||||
|
||||
/* regenerate if we need to, may waste one 32-bit value */
|
||||
if ((i + 1) >= N)
|
||||
random_generate ();
|
||||
|
||||
/* Convert two uint32 to a REAL(KIND=8). */
|
||||
*dest = ((GFC_REAL_8) ((((GFC_UINTEGER_8) seed[i+1]) << 32) + seed[i])) /
|
||||
(GFC_REAL_8) (~(GFC_UINTEGER_8) 0);
|
||||
i += 2;
|
||||
|
||||
/* Advance to the next element. */
|
||||
dest += stride0;
|
||||
count[0]++;
|
||||
/* Advance to the next source element. */
|
||||
n = 0;
|
||||
while (count[n] == extent[n])
|
||||
{
|
||||
/* When we get to the end of a dimension,
|
||||
reset it and increment
|
||||
the next dimension. */
|
||||
count[n] = 0;
|
||||
/* We could precalculate these products,
|
||||
but this is a less
|
||||
frequently used path so proabably not worth it. */
|
||||
dest -= stride[n] * extent[n];
|
||||
n++;
|
||||
if (n == dim)
|
||||
{
|
||||
dest = NULL;
|
||||
break;
|
||||
}
|
||||
else
|
||||
{
|
||||
count[n]++;
|
||||
dest += stride[n];
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
__gthread_mutex_unlock (&random_lock);
|
||||
}
|
||||
|
||||
#else
|
||||
|
||||
/* George Marsaglia's KISS (Keep It Simple Stupid) random number generator.
|
||||
|
||||
This PRNG combines:
|
||||
libgfortran currently uses George Marsaglia's KISS (Keep It Simple Stupid)
|
||||
random number generator. This PRNG combines:
|
||||
|
||||
(1) The congruential generator x(n)=69069*x(n-1)+1327217885 with a period
|
||||
of 2^32,
|
||||
@ -733,7 +380,6 @@ random_seed (GFC_INTEGER_4 *size, gfc_array_i4 *put, gfc_array_i4 *get)
|
||||
}
|
||||
iexport(random_seed);
|
||||
|
||||
#endif /* mersenne twister */
|
||||
|
||||
#ifndef __GTHREAD_MUTEX_INIT
|
||||
static void __attribute__((constructor))
|
||||
|
||||
@ -1117,178 +1117,3 @@ unget_format (st_parameter_dt *dtp, const fnode *f)
|
||||
dtp->u.p.fmt->saved_format = f;
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
#if 0
|
||||
|
||||
static void dump_format1 (fnode * f);
|
||||
|
||||
/* dump_format0()-- Dump a single format node */
|
||||
|
||||
void
|
||||
dump_format0 (fnode * f)
|
||||
{
|
||||
char *p;
|
||||
int i;
|
||||
|
||||
switch (f->format)
|
||||
{
|
||||
case FMT_COLON:
|
||||
st_printf (" :");
|
||||
break;
|
||||
case FMT_SLASH:
|
||||
st_printf (" %d/", f->u.r);
|
||||
break;
|
||||
case FMT_DOLLAR:
|
||||
st_printf (" $");
|
||||
break;
|
||||
case FMT_T:
|
||||
st_printf (" T%d", f->u.n);
|
||||
break;
|
||||
case FMT_TR:
|
||||
st_printf (" TR%d", f->u.n);
|
||||
break;
|
||||
case FMT_TL:
|
||||
st_printf (" TL%d", f->u.n);
|
||||
break;
|
||||
case FMT_X:
|
||||
st_printf (" %dX", f->u.n);
|
||||
break;
|
||||
case FMT_S:
|
||||
st_printf (" S");
|
||||
break;
|
||||
case FMT_SS:
|
||||
st_printf (" SS");
|
||||
break;
|
||||
case FMT_SP:
|
||||
st_printf (" SP");
|
||||
break;
|
||||
|
||||
case FMT_LPAREN:
|
||||
if (f->repeat == 1)
|
||||
st_printf (" (");
|
||||
else
|
||||
st_printf (" %d(", f->repeat);
|
||||
|
||||
dump_format1 (f->u.child);
|
||||
st_printf (" )");
|
||||
break;
|
||||
|
||||
case FMT_STRING:
|
||||
st_printf (" '");
|
||||
p = f->u.string.p;
|
||||
for (i = f->u.string.length; i > 0; i--)
|
||||
st_printf ("%c", *p++);
|
||||
|
||||
st_printf ("'");
|
||||
break;
|
||||
|
||||
case FMT_P:
|
||||
st_printf (" %dP", f->u.k);
|
||||
break;
|
||||
case FMT_I:
|
||||
st_printf (" %dI%d.%d", f->repeat, f->u.integer.w, f->u.integer.m);
|
||||
break;
|
||||
|
||||
case FMT_B:
|
||||
st_printf (" %dB%d.%d", f->repeat, f->u.integer.w, f->u.integer.m);
|
||||
break;
|
||||
|
||||
case FMT_O:
|
||||
st_printf (" %dO%d.%d", f->repeat, f->u.integer.w, f->u.integer.m);
|
||||
break;
|
||||
|
||||
case FMT_Z:
|
||||
st_printf (" %dZ%d.%d", f->repeat, f->u.integer.w, f->u.integer.m);
|
||||
break;
|
||||
|
||||
case FMT_BN:
|
||||
st_printf (" BN");
|
||||
break;
|
||||
case FMT_BZ:
|
||||
st_printf (" BZ");
|
||||
break;
|
||||
case FMT_D:
|
||||
st_printf (" %dD%d.%d", f->repeat, f->u.real.w, f->u.real.d);
|
||||
break;
|
||||
|
||||
case FMT_EN:
|
||||
st_printf (" %dEN%d.%dE%d", f->repeat, f->u.real.w, f->u.real.d,
|
||||
f->u.real.e);
|
||||
break;
|
||||
|
||||
case FMT_ES:
|
||||
st_printf (" %dES%d.%dE%d", f->repeat, f->u.real.w, f->u.real.d,
|
||||
f->u.real.e);
|
||||
break;
|
||||
|
||||
case FMT_F:
|
||||
st_printf (" %dF%d.%d", f->repeat, f->u.real.w, f->u.real.d);
|
||||
break;
|
||||
|
||||
case FMT_E:
|
||||
st_printf (" %dE%d.%dE%d", f->repeat, f->u.real.w, f->u.real.d,
|
||||
f->u.real.e);
|
||||
break;
|
||||
|
||||
case FMT_G:
|
||||
st_printf (" %dG%d.%dE%d", f->repeat, f->u.real.w, f->u.real.d,
|
||||
f->u.real.e);
|
||||
break;
|
||||
|
||||
case FMT_L:
|
||||
st_printf (" %dL%d", f->repeat, f->u.w);
|
||||
break;
|
||||
case FMT_A:
|
||||
st_printf (" %dA%d", f->repeat, f->u.w);
|
||||
break;
|
||||
|
||||
default:
|
||||
st_printf (" ???");
|
||||
break;
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
/* dump_format1()-- Dump a string of format nodes */
|
||||
|
||||
static void
|
||||
dump_format1 (fnode * f)
|
||||
{
|
||||
for (; f; f = f->next)
|
||||
dump_format1 (f);
|
||||
}
|
||||
|
||||
/* dump_format()-- Dump the whole format node tree */
|
||||
|
||||
void
|
||||
dump_format (void)
|
||||
{
|
||||
st_printf ("format = ");
|
||||
dump_format0 (&array[0]);
|
||||
st_printf ("\n");
|
||||
}
|
||||
|
||||
|
||||
void
|
||||
next_test (st_parameter_dt *dtp)
|
||||
{
|
||||
fnode *f;
|
||||
int i;
|
||||
|
||||
for (i = 0; i < 20; i++)
|
||||
{
|
||||
f = next_format (dtp);
|
||||
if (f == NULL)
|
||||
{
|
||||
st_printf ("No format!\n");
|
||||
break;
|
||||
}
|
||||
|
||||
dump_format1 (f);
|
||||
st_printf ("\n");
|
||||
}
|
||||
}
|
||||
|
||||
#endif
|
||||
|
||||
Loading…
Reference in New Issue
Block a user