mirror of
https://gcc.gnu.org/git/gcc.git
synced 2024-11-25 11:54:01 +08:00
check.c (gfc_check_second_sub, [...]): New functions.
* check.c (gfc_check_second_sub, gfc_check_irand, gfc_check_rand gfc_check_srand, gfc_check_etime, gfc_check_etime_sub): New functions. * gfortran.h (gfc_generic_isym_id): New symbols GFC_ISYM_ETIME, GFC_ISYM_IRAND, GFC_ISYM_RAND, GFC_ISYM_SECOND. * trans-intrinsic.c: Use symbols. * intrinsic.c (add_sym_2s): New function. * intrinsic.c: Add etime, dtime, irand, rand, second, srand. * intrinsic.h: Function prototypes. * iresolve.c (gfc_resolve_etime_sub, gfc_resolve_second_sub gfc_resolve_srand): New functions. libgfortran * Makefile.am: Add rand.c and etime.c * Makefile.in: Regenerated. * aclocal.in: Regenerated. * cpu_time.c (second_sub, second): New functions. * rand.c (irand, rand, srand): New file. * etime.c (etime_sub, etime): New file. From-SVN: r83034
This commit is contained in:
Steven G. Kargl
Paul Brook
parent
b08eae9288
commit
2bd7494908
@ -1,3 +1,16 @@
|
||||
2004-06-12 Steven G. Kargl <kargls@comcast.net>
|
||||
|
||||
* check.c (gfc_check_second_sub, gfc_check_irand, gfc_check_rand
|
||||
gfc_check_srand, gfc_check_etime, gfc_check_etime_sub): New functions.
|
||||
* gfortran.h (gfc_generic_isym_id): New symbols GFC_ISYM_ETIME,
|
||||
GFC_ISYM_IRAND, GFC_ISYM_RAND, GFC_ISYM_SECOND.
|
||||
* trans-intrinsic.c: Use symbols.
|
||||
* intrinsic.c (add_sym_2s): New function.
|
||||
* intrinsic.c: Add etime, dtime, irand, rand, second, srand.
|
||||
* intrinsic.h: Function prototypes.
|
||||
* iresolve.c (gfc_resolve_etime_sub, gfc_resolve_second_sub
|
||||
gfc_resolve_srand): New functions.
|
||||
|
||||
2004-06-12 Tobias Schlueter <tobias.schlueter@physik.uni-muenchen.de>
|
||||
|
||||
PR fortran/14957
|
||||
|
||||
@ -1877,6 +1877,23 @@ gfc_check_random_seed (gfc_expr * size, gfc_expr * put, gfc_expr * get)
|
||||
return SUCCESS;
|
||||
}
|
||||
|
||||
try
|
||||
gfc_check_second_sub (gfc_expr * time)
|
||||
{
|
||||
|
||||
if (scalar_check (time, 0) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
if (type_check (time, 0, BT_REAL) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
if (kind_value_check(time, 0, 4) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
return SUCCESS;
|
||||
}
|
||||
|
||||
|
||||
/* The arguments of SYSTEM_CLOCK are scalar, integer variables. Note,
|
||||
count, count_rate, and count_max are all optional arguments */
|
||||
|
||||
@ -1935,3 +1952,99 @@ gfc_check_system_clock (gfc_expr * count, gfc_expr * count_rate,
|
||||
|
||||
return SUCCESS;
|
||||
}
|
||||
|
||||
try
|
||||
gfc_check_irand (gfc_expr * x)
|
||||
{
|
||||
if (scalar_check (x, 0) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
if (type_check (x, 0, BT_INTEGER) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
if (kind_value_check(x, 0, 4) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
return SUCCESS;
|
||||
}
|
||||
|
||||
try
|
||||
gfc_check_rand (gfc_expr * x)
|
||||
{
|
||||
if (scalar_check (x, 0) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
if (type_check (x, 0, BT_INTEGER) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
if (kind_value_check(x, 0, 4) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
return SUCCESS;
|
||||
}
|
||||
|
||||
try
|
||||
gfc_check_srand (gfc_expr * x)
|
||||
{
|
||||
if (scalar_check (x, 0) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
if (type_check (x, 0, BT_INTEGER) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
if (kind_value_check(x, 0, 4) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
return SUCCESS;
|
||||
}
|
||||
|
||||
try
|
||||
gfc_check_etime (gfc_expr * x)
|
||||
{
|
||||
if (array_check (x, 0) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
if (rank_check (x, 0, 1) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
if (variable_check (x, 0) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
if (type_check (x, 0, BT_REAL) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
if (kind_value_check(x, 0, 4) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
return SUCCESS;
|
||||
}
|
||||
|
||||
try
|
||||
gfc_check_etime_sub (gfc_expr * values, gfc_expr * time)
|
||||
{
|
||||
if (array_check (values, 0) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
if (rank_check (values, 0, 1) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
if (variable_check (values, 0) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
if (type_check (values, 0, BT_REAL) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
if (kind_value_check(values, 0, 4) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
if (scalar_check (time, 1) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
if (type_check (time, 1, BT_REAL) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
if (kind_value_check(time, 1, 4) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
return SUCCESS;
|
||||
}
|
||||
|
||||
@ -301,6 +301,7 @@ enum gfc_generic_isym_id
|
||||
GFC_ISYM_DOT_PRODUCT,
|
||||
GFC_ISYM_DPROD,
|
||||
GFC_ISYM_EOSHIFT,
|
||||
GFC_ISYM_ETIME,
|
||||
GFC_ISYM_EXP,
|
||||
GFC_ISYM_EXPONENT,
|
||||
GFC_ISYM_FLOOR,
|
||||
@ -315,6 +316,7 @@ enum gfc_generic_isym_id
|
||||
GFC_ISYM_INDEX,
|
||||
GFC_ISYM_INT,
|
||||
GFC_ISYM_IOR,
|
||||
GFC_ISYM_IRAND,
|
||||
GFC_ISYM_ISHFT,
|
||||
GFC_ISYM_ISHFTC,
|
||||
GFC_ISYM_LBOUND,
|
||||
@ -343,12 +345,14 @@ enum gfc_generic_isym_id
|
||||
GFC_ISYM_PACK,
|
||||
GFC_ISYM_PRESENT,
|
||||
GFC_ISYM_PRODUCT,
|
||||
GFC_ISYM_RAND,
|
||||
GFC_ISYM_REAL,
|
||||
GFC_ISYM_REPEAT,
|
||||
GFC_ISYM_RESHAPE,
|
||||
GFC_ISYM_RRSPACING,
|
||||
GFC_ISYM_SCALE,
|
||||
GFC_ISYM_SCAN,
|
||||
GFC_ISYM_SECOND,
|
||||
GFC_ISYM_SET_EXPONENT,
|
||||
GFC_ISYM_SHAPE,
|
||||
GFC_ISYM_SI_KIND,
|
||||
|
||||
@ -429,6 +429,32 @@ static void add_sym_2 (const char *name, int elemental, int actual_ok, bt type,
|
||||
}
|
||||
|
||||
|
||||
/* Add the name of an intrinsic subroutine with two arguments to the list
|
||||
of intrinsic names. */
|
||||
|
||||
static void add_sym_2s (const char *name, int elemental, int actual_ok, bt type,
|
||||
int kind,
|
||||
try (*check)(gfc_expr *,gfc_expr *,gfc_expr *),
|
||||
gfc_expr *(*simplify)(gfc_expr *,gfc_expr *,gfc_expr *),
|
||||
void (*resolve)(gfc_code *),
|
||||
const char* a1, bt type1, int kind1, int optional1,
|
||||
const char* a2, bt type2, int kind2, int optional2
|
||||
) {
|
||||
gfc_check_f cf;
|
||||
gfc_simplify_f sf;
|
||||
gfc_resolve_f rf;
|
||||
|
||||
cf.f3 = check;
|
||||
sf.f3 = simplify;
|
||||
rf.s1 = resolve;
|
||||
|
||||
add_sym (name, elemental, actual_ok, type, kind, cf, sf, rf,
|
||||
a1, type1, kind1, optional1,
|
||||
a2, type2, kind2, optional2,
|
||||
(void*)0);
|
||||
}
|
||||
|
||||
|
||||
static void add_sym_3 (const char *name, int elemental, int actual_ok, bt type,
|
||||
int kind,
|
||||
try (*check)(gfc_expr *,gfc_expr *,gfc_expr *),
|
||||
@ -989,6 +1015,16 @@ add_functions (void)
|
||||
|
||||
make_generic ("epsilon", GFC_ISYM_NONE);
|
||||
|
||||
/* G77 compatibility */
|
||||
add_sym_1 ("etime", 0, 1, BT_REAL, 4,
|
||||
gfc_check_etime, NULL, NULL,
|
||||
x, BT_REAL, 4, 0);
|
||||
|
||||
make_alias ("dtime");
|
||||
|
||||
make_generic ("etime", GFC_ISYM_ETIME);
|
||||
|
||||
|
||||
add_sym_1 ("exp", 1, 1, BT_REAL, dr,
|
||||
NULL, gfc_simplify_exp, gfc_resolve_exp, x, BT_REAL, dr, 0);
|
||||
|
||||
@ -1098,6 +1134,13 @@ add_functions (void)
|
||||
|
||||
make_generic ("ior", GFC_ISYM_IOR);
|
||||
|
||||
/* The following function is for G77 compatibility. */
|
||||
add_sym_1 ("irand", 0, 1, BT_INTEGER, 4,
|
||||
gfc_check_irand, NULL, NULL,
|
||||
i, BT_INTEGER, 4, 0);
|
||||
|
||||
make_generic ("irand", GFC_ISYM_IRAND);
|
||||
|
||||
add_sym_2 ("ishft", 1, 1, BT_INTEGER, di,
|
||||
gfc_check_ishft, gfc_simplify_ishft, gfc_resolve_ishft,
|
||||
i, BT_INTEGER, di, 0, sh, BT_INTEGER, di, 0);
|
||||
@ -1386,6 +1429,13 @@ add_functions (void)
|
||||
|
||||
make_generic ("radix", GFC_ISYM_NONE);
|
||||
|
||||
/* The following function is for G77 compatibility. */
|
||||
add_sym_1 ("rand", 0, 1, BT_REAL, 4,
|
||||
gfc_check_rand, NULL, NULL,
|
||||
i, BT_INTEGER, 4, 0);
|
||||
|
||||
make_generic ("rand", GFC_ISYM_RAND);
|
||||
|
||||
add_sym_1 ("range", 0, 1, BT_INTEGER, di,
|
||||
gfc_check_range, gfc_simplify_range, NULL,
|
||||
x, BT_REAL, dr, 0);
|
||||
@ -1436,6 +1486,11 @@ add_functions (void)
|
||||
|
||||
make_generic ("scan", GFC_ISYM_SCAN);
|
||||
|
||||
/* Added for G77 compatibility garbage. */
|
||||
add_sym_0 ("second", 0, 1, BT_REAL, 4, NULL, NULL, NULL);
|
||||
|
||||
make_generic ("second", GFC_ISYM_SECOND);
|
||||
|
||||
add_sym_1 ("selected_int_kind", 0, 1, BT_INTEGER, di,
|
||||
NULL, gfc_simplify_selected_int_kind, NULL,
|
||||
r, BT_INTEGER, di, 0);
|
||||
@ -1606,6 +1661,8 @@ add_functions (void)
|
||||
bck, BT_LOGICAL, dl, 1);
|
||||
|
||||
make_generic ("verify", GFC_ISYM_VERIFY);
|
||||
|
||||
|
||||
}
|
||||
|
||||
|
||||
@ -1634,11 +1691,25 @@ add_subroutines (void)
|
||||
gfc_check_cpu_time, NULL, gfc_resolve_cpu_time,
|
||||
tm, BT_REAL, dr, 0);
|
||||
|
||||
/* More G77 compatibility garbage. */
|
||||
add_sym_1s ("second", 0, 1, BT_UNKNOWN, 0,
|
||||
gfc_check_second_sub, NULL, gfc_resolve_second_sub,
|
||||
tm, BT_REAL, dr, 0);
|
||||
|
||||
add_sym_4 ("date_and_time", 0, 1, BT_UNKNOWN, 0,
|
||||
gfc_check_date_and_time, NULL, NULL,
|
||||
dt, BT_CHARACTER, dc, 1, tm, BT_CHARACTER, dc, 1,
|
||||
zn, BT_CHARACTER, dc, 1, vl, BT_INTEGER, di, 1);
|
||||
|
||||
/* More G77 compatibility garbage. */
|
||||
add_sym_2s ("etime", 0, 1, BT_UNKNOWN, 0,
|
||||
gfc_check_etime_sub, NULL, gfc_resolve_etime_sub,
|
||||
vl, BT_REAL, 4, 0, tm, BT_REAL, 4, 0);
|
||||
|
||||
add_sym_2s ("dtime", 0, 1, BT_UNKNOWN, 0,
|
||||
gfc_check_etime_sub, NULL, gfc_resolve_etime_sub,
|
||||
vl, BT_REAL, 4, 0, tm, BT_REAL, 4, 0);
|
||||
|
||||
add_sym_2 ("getarg", 0, 1, BT_UNKNOWN, 0,
|
||||
NULL, NULL, NULL,
|
||||
c, BT_INTEGER, di, 0, vl, BT_CHARACTER, dc, 0);
|
||||
@ -1659,6 +1730,11 @@ add_subroutines (void)
|
||||
sz, BT_INTEGER, di, 1, pt, BT_INTEGER, di, 1,
|
||||
gt, BT_INTEGER, di, 1);
|
||||
|
||||
/* More G77 compatibility garbage. */
|
||||
add_sym_1s ("srand", 0, 1, BT_UNKNOWN, di,
|
||||
gfc_check_srand, NULL, gfc_resolve_srand,
|
||||
c, BT_INTEGER, 4, 0);
|
||||
|
||||
add_sym_3s ("system_clock", 0, 1, BT_UNKNOWN, 0,
|
||||
gfc_check_system_clock, NULL, gfc_resolve_system_clock,
|
||||
c, BT_INTEGER, di, 1, cr, BT_INTEGER, di, 1,
|
||||
|
||||
@ -1,6 +1,6 @@
|
||||
/* Header file for intrinsics check, resolve and simplify function
|
||||
prototypes.
|
||||
Copyright (C) 2000, 2001, 2002, 2003 Free Software Foundation, Inc.
|
||||
Copyright (C) 2000, 2001, 2002, 2003, 2004 Free Software Foundation, Inc.
|
||||
Contributed by Andy Vaught & Katherine Holcomb
|
||||
|
||||
This file is part of GCC.
|
||||
@ -44,6 +44,8 @@ try gfc_check_dble (gfc_expr *);
|
||||
try gfc_check_digits (gfc_expr *);
|
||||
try gfc_check_dot_product (gfc_expr *, gfc_expr *);
|
||||
try gfc_check_eoshift (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
try gfc_check_etime (gfc_expr *);
|
||||
try gfc_check_etime_sub (gfc_expr *, gfc_expr *);
|
||||
try gfc_check_huge (gfc_expr *);
|
||||
try gfc_check_i (gfc_expr *);
|
||||
try gfc_check_iand (gfc_expr *, gfc_expr *);
|
||||
@ -55,6 +57,7 @@ try gfc_check_ieor (gfc_expr *, gfc_expr *);
|
||||
try gfc_check_index (gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
try gfc_check_int (gfc_expr *, gfc_expr *);
|
||||
try gfc_check_ior (gfc_expr *, gfc_expr *);
|
||||
try gfc_check_irand (gfc_expr *);
|
||||
try gfc_check_ishft (gfc_expr *, gfc_expr *);
|
||||
try gfc_check_ishftc (gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
try gfc_check_kind (gfc_expr *);
|
||||
@ -75,18 +78,21 @@ try gfc_check_precision (gfc_expr *);
|
||||
try gfc_check_present (gfc_expr *);
|
||||
try gfc_check_product (gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
try gfc_check_radix (gfc_expr *);
|
||||
try gfc_check_rand (gfc_expr *);
|
||||
try gfc_check_range (gfc_expr *);
|
||||
try gfc_check_real (gfc_expr *, gfc_expr *);
|
||||
try gfc_check_repeat (gfc_expr *, gfc_expr *);
|
||||
try gfc_check_reshape (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
try gfc_check_scale (gfc_expr *, gfc_expr *);
|
||||
try gfc_check_scan (gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
try gfc_check_second_sub (gfc_expr *);
|
||||
try gfc_check_selected_real_kind (gfc_expr *, gfc_expr *);
|
||||
try gfc_check_set_exponent (gfc_expr *, gfc_expr *);
|
||||
try gfc_check_shape (gfc_expr *);
|
||||
try gfc_check_size (gfc_expr *, gfc_expr *);
|
||||
try gfc_check_sign (gfc_expr *, gfc_expr *);
|
||||
try gfc_check_spread (gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
try gfc_check_srand (gfc_expr *);
|
||||
try gfc_check_sum (gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
try gfc_check_transfer (gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
try gfc_check_transpose (gfc_expr *);
|
||||
@ -240,6 +246,7 @@ void gfc_resolve_dot_product (gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
void gfc_resolve_dprod (gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
void gfc_resolve_eoshift (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *,
|
||||
gfc_expr *);
|
||||
void gfc_resolve_etime_sub (gfc_code *);
|
||||
void gfc_resolve_exp (gfc_expr *, gfc_expr *);
|
||||
void gfc_resolve_exponent (gfc_expr *, gfc_expr *);
|
||||
void gfc_resolve_floor (gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
@ -283,6 +290,7 @@ void gfc_resolve_reshape (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *,
|
||||
void gfc_resolve_rrspacing (gfc_expr *, gfc_expr *);
|
||||
void gfc_resolve_scale (gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
void gfc_resolve_scan (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
void gfc_resolve_second_sub (gfc_code *);
|
||||
void gfc_resolve_set_exponent (gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
void gfc_resolve_shape (gfc_expr *, gfc_expr *);
|
||||
void gfc_resolve_sign (gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
@ -291,6 +299,7 @@ void gfc_resolve_sinh (gfc_expr *, gfc_expr *);
|
||||
void gfc_resolve_spacing (gfc_expr *, gfc_expr *);
|
||||
void gfc_resolve_spread (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
void gfc_resolve_sqrt (gfc_expr *, gfc_expr *);
|
||||
void gfc_resolve_srand (gfc_code *);
|
||||
void gfc_resolve_sum (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
void gfc_resolve_tan (gfc_expr *, gfc_expr *);
|
||||
void gfc_resolve_tanh (gfc_expr *, gfc_expr *);
|
||||
|
||||
@ -1369,6 +1369,42 @@ gfc_resolve_random_number (gfc_code * c ATTRIBUTE_UNUSED)
|
||||
name = gfc_get_string (PREFIX("arandom_r%d"), kind);
|
||||
|
||||
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
|
||||
|
||||
}
|
||||
|
||||
|
||||
/* G77 compatibility subroutines etime() and dtime(). */
|
||||
|
||||
void
|
||||
gfc_resolve_etime_sub (gfc_code * c)
|
||||
{
|
||||
const char *name;
|
||||
|
||||
name = gfc_get_string (PREFIX("etime_sub"));
|
||||
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
|
||||
}
|
||||
|
||||
|
||||
/* G77 compatibility subroutine second(). */
|
||||
|
||||
void
|
||||
gfc_resolve_second_sub (gfc_code * c)
|
||||
{
|
||||
const char *name;
|
||||
|
||||
name = gfc_get_string (PREFIX("second_sub"));
|
||||
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
|
||||
}
|
||||
|
||||
|
||||
/* G77 compatibility function srand(). */
|
||||
|
||||
void
|
||||
gfc_resolve_srand (gfc_code * c)
|
||||
{
|
||||
const char *name;
|
||||
name = gfc_get_string (PREFIX("srand"));
|
||||
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
|
||||
}
|
||||
|
||||
|
||||
@ -1393,7 +1429,6 @@ gfc_resolve_system_clock (gfc_code * c)
|
||||
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
|
||||
}
|
||||
|
||||
|
||||
void
|
||||
gfc_iresolve_init_1 (void)
|
||||
{
|
||||
|
||||
@ -2867,6 +2867,10 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
|
||||
|
||||
case GFC_ISYM_DOT_PRODUCT:
|
||||
case GFC_ISYM_MATMUL:
|
||||
case GFC_ISYM_IRAND:
|
||||
case GFC_ISYM_RAND:
|
||||
case GFC_ISYM_ETIME:
|
||||
case GFC_ISYM_SECOND:
|
||||
gfc_conv_intrinsic_funcall (se, expr);
|
||||
break;
|
||||
|
||||
|
||||
@ -1,3 +1,12 @@
|
||||
2004-06-12 Steven G. Kargl <kargls@comcast.net>
|
||||
|
||||
* Makefile.am: Add rand.c and etime.c
|
||||
* Makefile.in: Regenerated.
|
||||
* aclocal.in: Regenerated.
|
||||
* cpu_time.c (second_sub, second): New functions.
|
||||
* rand.c (irand, rand, srand): New file.
|
||||
* etime.c (etime_sub, etime): New file.
|
||||
|
||||
2004-06-12 Tobias Schlueter <tobias.schlueter@physik.uni-muenchen.de>
|
||||
Steven Bosscher <stevenb@suse.de>
|
||||
|
||||
|
||||
@ -42,11 +42,13 @@ intrinsics/cshift0.c \
|
||||
intrinsics/date_and_time.c \
|
||||
intrinsics/eoshift0.c \
|
||||
intrinsics/eoshift2.c \
|
||||
intrinsics/etime.c \
|
||||
intrinsics/ishftc.c \
|
||||
intrinsics/pack_generic.c \
|
||||
intrinsics/size.c \
|
||||
intrinsics/spread_generic.c \
|
||||
intrinsics/string_intrinsics.c \
|
||||
intrinsics/rand.c \
|
||||
intrinsics/random.c \
|
||||
intrinsics/reshape_generic.c \
|
||||
intrinsics/reshape_packed.c \
|
||||
|
||||
@ -119,9 +119,9 @@ am__objects_32 = backspace.lo close.lo endfile.lo format.lo inquire.lo \
|
||||
list_read.lo lock.lo open.lo read.lo rewind.lo transfer.lo \
|
||||
unit.lo unix.lo write.lo
|
||||
am__objects_33 = associated.lo abort.lo args.lo cpu_time.lo cshift0.lo \
|
||||
date_and_time.lo eoshift0.lo eoshift2.lo ishftc.lo \
|
||||
date_and_time.lo eoshift0.lo eoshift2.lo etime.lo ishftc.lo \
|
||||
pack_generic.lo size.lo spread_generic.lo string_intrinsics.lo \
|
||||
random.lo reshape_generic.lo reshape_packed.lo \
|
||||
rand.lo random.lo reshape_generic.lo reshape_packed.lo \
|
||||
selected_kind.lo system_clock.lo transpose_generic.lo \
|
||||
unpack_generic.lo in_pack_generic.lo in_unpack_generic.lo
|
||||
am__objects_34 =
|
||||
@ -314,11 +314,13 @@ intrinsics/cshift0.c \
|
||||
intrinsics/date_and_time.c \
|
||||
intrinsics/eoshift0.c \
|
||||
intrinsics/eoshift2.c \
|
||||
intrinsics/etime.c \
|
||||
intrinsics/ishftc.c \
|
||||
intrinsics/pack_generic.c \
|
||||
intrinsics/size.c \
|
||||
intrinsics/spread_generic.c \
|
||||
intrinsics/string_intrinsics.c \
|
||||
intrinsics/rand.c \
|
||||
intrinsics/random.c \
|
||||
intrinsics/reshape_generic.c \
|
||||
intrinsics/reshape_packed.c \
|
||||
@ -2029,6 +2031,15 @@ eoshift2.obj: intrinsics/eoshift2.c
|
||||
eoshift2.lo: intrinsics/eoshift2.c
|
||||
$(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o eoshift2.lo `test -f 'intrinsics/eoshift2.c' || echo '$(srcdir)/'`intrinsics/eoshift2.c
|
||||
|
||||
etime.o: intrinsics/etime.c
|
||||
$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o etime.o `test -f 'intrinsics/etime.c' || echo '$(srcdir)/'`intrinsics/etime.c
|
||||
|
||||
etime.obj: intrinsics/etime.c
|
||||
$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o etime.obj `if test -f 'intrinsics/etime.c'; then $(CYGPATH_W) 'intrinsics/etime.c'; else $(CYGPATH_W) '$(srcdir)/intrinsics/etime.c'; fi`
|
||||
|
||||
etime.lo: intrinsics/etime.c
|
||||
$(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o etime.lo `test -f 'intrinsics/etime.c' || echo '$(srcdir)/'`intrinsics/etime.c
|
||||
|
||||
ishftc.o: intrinsics/ishftc.c
|
||||
$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o ishftc.o `test -f 'intrinsics/ishftc.c' || echo '$(srcdir)/'`intrinsics/ishftc.c
|
||||
|
||||
@ -2074,6 +2085,15 @@ string_intrinsics.obj: intrinsics/string_intrinsics.c
|
||||
string_intrinsics.lo: intrinsics/string_intrinsics.c
|
||||
$(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o string_intrinsics.lo `test -f 'intrinsics/string_intrinsics.c' || echo '$(srcdir)/'`intrinsics/string_intrinsics.c
|
||||
|
||||
rand.o: intrinsics/rand.c
|
||||
$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o rand.o `test -f 'intrinsics/rand.c' || echo '$(srcdir)/'`intrinsics/rand.c
|
||||
|
||||
rand.obj: intrinsics/rand.c
|
||||
$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o rand.obj `if test -f 'intrinsics/rand.c'; then $(CYGPATH_W) 'intrinsics/rand.c'; else $(CYGPATH_W) '$(srcdir)/intrinsics/rand.c'; fi`
|
||||
|
||||
rand.lo: intrinsics/rand.c
|
||||
$(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o rand.lo `test -f 'intrinsics/rand.c' || echo '$(srcdir)/'`intrinsics/rand.c
|
||||
|
||||
random.o: intrinsics/random.c
|
||||
$(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o random.o `test -f 'intrinsics/random.c' || echo '$(srcdir)/'`intrinsics/random.c
|
||||
|
||||
|
||||
@ -114,3 +114,16 @@ void prefix(cpu_time_##KIND) (GFC_REAL_##KIND *__time) \
|
||||
CPU_TIME(4)
|
||||
CPU_TIME(8)
|
||||
|
||||
void
|
||||
prefix(second_sub) (GFC_REAL_4 *s)
|
||||
{
|
||||
prefix(cpu_time_4)(s);
|
||||
}
|
||||
|
||||
GFC_REAL_4
|
||||
prefix(second) (void)
|
||||
{
|
||||
GFC_REAL_4 s;
|
||||
prefix(cpu_time_4)(&s);
|
||||
return s;
|
||||
}
|
||||
|
||||
280
libgfortran/intrinsics/date_and_time.c
Normal file
280
libgfortran/intrinsics/date_and_time.c
Normal file
@ -0,0 +1,280 @@
|
||||
/* Implementation of the DATE_AND_TIME intrinsic.
|
||||
Copyright (C) 2003, 2004 Free Software Foundation, Inc.
|
||||
Contributed by Steven Bosscher.
|
||||
|
||||
This file is part of the GNU Fortran 95 runtime library (libgfor).
|
||||
|
||||
Libgfor is free software; you can redistribute it and/or
|
||||
modify it under the terms of the GNU Lesser General Public
|
||||
License as published by the Free Software Foundation; either
|
||||
version 2.1 of the License, or (at your option) any later version.
|
||||
|
||||
Libgfor is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU Lesser General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU Lesser General Public
|
||||
License along with libgfor; see the file COPYING.LIB. If not,
|
||||
write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
||||
Boston, MA 02111-1307, USA. */
|
||||
|
||||
#include "config.h"
|
||||
#include <sys/types.h>
|
||||
#include <string.h>
|
||||
#include <assert.h>
|
||||
#include "libgfortran.h"
|
||||
|
||||
#include <stdio.h>
|
||||
#include <stdlib.h>
|
||||
|
||||
#undef HAVE_NO_DATE_TIME
|
||||
#if TIME_WITH_SYS_TIME
|
||||
# include <sys/time.h>
|
||||
# include <time.h>
|
||||
#else
|
||||
# if HAVE_SYS_TIME_H
|
||||
# include <sys/time.h>
|
||||
# else
|
||||
# ifdef HAVE_TIME_H
|
||||
# include <time.h>
|
||||
# else
|
||||
# define HAVE_NO_DATE_TIME
|
||||
# endif /* HAVE_TIME_H */
|
||||
# endif /* HAVE_SYS_TIME_H */
|
||||
#endif /* TIME_WITH_SYS_TIME */
|
||||
|
||||
#ifndef abs
|
||||
#define abs(x) ((x)>=0 ? (x) : -(x))
|
||||
#endif
|
||||
|
||||
/* DATE_AND_TIME ([DATE, TIME, ZONE, VALUES])
|
||||
|
||||
Description: Returns data on the real-time clock and date in a form
|
||||
compatible with the representations defined in ISO 8601:1988.
|
||||
|
||||
Class: Non-elemental subroutine.
|
||||
|
||||
Arguments:
|
||||
|
||||
DATE (optional) shall be scalar and of type default character, and
|
||||
shall be of length at least 8 in order to contain the complete
|
||||
value. It is an INTENT (OUT) argument. Its leftmost 8 characters
|
||||
are assigned a value of the form CCYYMMDD, where CC is the century,
|
||||
YY the year within the century, MM the month within the year, and
|
||||
DD the day within the month. If there is no date available, they
|
||||
are assigned blanks.
|
||||
|
||||
TIME (optional) shall be scalar and of type default character, and
|
||||
shall be of length at least 10 in order to contain the complete
|
||||
value. It is an INTENT (OUT) argument. Its leftmost 10 characters
|
||||
are assigned a value of the form hhmmss.sss, where hh is the hour
|
||||
of the day, mm is the minutes of the hour, and ss.sss is the
|
||||
seconds and milliseconds of the minute. If there is no clock
|
||||
available, they are assigned blanks.
|
||||
|
||||
ZONE (optional) shall be scalar and of type default character, and
|
||||
shall be of length at least 5 in order to contain the complete
|
||||
value. It is an INTENT (OUT) argument. Its leftmost 5 characters
|
||||
are assigned a value of the form ±hhmm, where hh and mm are the
|
||||
time difference with respect to Coordinated Universal Time (UTC) in
|
||||
hours and parts of an hour expressed in minutes, respectively. If
|
||||
there is no clock available, they are assigned blanks.
|
||||
|
||||
VALUES (optional) shall be of type default integer and of rank
|
||||
one. It is an INTENT (OUT) argument. Its size shall be at least
|
||||
8. The values returned in VALUES are as follows:
|
||||
|
||||
VALUES (1) the year (for example, 2003), or HUGE (0) if there is
|
||||
no date available;
|
||||
|
||||
VALUES (2) the month of the year, or HUGE (0) if there
|
||||
is no date available;
|
||||
|
||||
VALUES (3) the day of the month, or HUGE (0) if there is no date
|
||||
available;
|
||||
|
||||
VALUES (4) the time difference with respect to Coordinated
|
||||
Universal Time (UTC) in minutes, or HUGE (0) if this information
|
||||
is not available;
|
||||
|
||||
VALUES (5) the hour of the day, in the range of 0 to 23, or HUGE
|
||||
(0) if there is no clock;
|
||||
|
||||
VALUES (6) the minutes of the hour, in the range 0 to 59, or
|
||||
HUGE (0) if there is no clock;
|
||||
|
||||
VALUES (7) the seconds of the minute, in the range 0 to 60, or
|
||||
HUGE (0) if there is no clock;
|
||||
|
||||
VALUES (8) the milliseconds of the second, in the range 0 to
|
||||
999, or HUGE (0) if there is no clock.
|
||||
|
||||
NULL pointer represent missing OPTIONAL arguments. All arguments
|
||||
have INTENT(OUT). Because of the -i8 option, we must implement
|
||||
VALUES for INTEGER(kind=4) and INTEGER(kind=8).
|
||||
|
||||
Based on libU77's date_time_.c.
|
||||
|
||||
TODO :
|
||||
- Check year boundaries.
|
||||
- There is no STDC/POSIX way to get VALUES(8). A GNUish way may
|
||||
be to use ftime.
|
||||
*/
|
||||
|
||||
void
|
||||
date_and_time (char *__date,
|
||||
char *__time,
|
||||
char *__zone,
|
||||
gfc_array_i4 *__values,
|
||||
GFC_INTEGER_4 __date_len,
|
||||
GFC_INTEGER_4 __time_len,
|
||||
GFC_INTEGER_4 __zone_len)
|
||||
{
|
||||
#define DATE_LEN 8
|
||||
#define TIME_LEN 10
|
||||
#define ZONE_LEN 5
|
||||
#define VALUES_SIZE 8
|
||||
char date[DATE_LEN + 1];
|
||||
char timec[TIME_LEN + 1];
|
||||
char zone[ZONE_LEN + 1];
|
||||
GFC_INTEGER_4 values[VALUES_SIZE];
|
||||
|
||||
#ifndef HAVE_NO_DATE_TIME
|
||||
time_t lt = time (NULL);
|
||||
struct tm local_time = *localtime (<);
|
||||
struct tm UTC_time = *gmtime (<);
|
||||
|
||||
/* All arguments can be derived from VALUES. */
|
||||
values[0] = 1900 + local_time.tm_year;
|
||||
values[1] = 1 + local_time.tm_mon;
|
||||
values[2] = local_time.tm_mday;
|
||||
values[3] = (local_time.tm_min - UTC_time.tm_min +
|
||||
60 * (local_time.tm_hour - UTC_time.tm_hour +
|
||||
24 * (local_time.tm_yday - UTC_time.tm_yday)));
|
||||
values[4] = local_time.tm_hour;
|
||||
values[5] = local_time.tm_min;
|
||||
values[6] = local_time.tm_sec;
|
||||
#if HAVE_GETTIMEOFDAY
|
||||
{
|
||||
struct timeval tp;
|
||||
# if GETTIMEOFDAY_ONE_ARGUMENT
|
||||
if (!gettimeofday (&tp))
|
||||
# else
|
||||
# if HAVE_STRUCT_TIMEZONE
|
||||
struct timezone tzp;
|
||||
|
||||
/* Some systems such as HP-UX, do have struct timezone, but
|
||||
gettimeofday takes void* as the 2nd arg. However, the
|
||||
effect of passing anything other than a null pointer is
|
||||
unspecified on HPUX. Configure checks if gettimeofday
|
||||
actually fails with a non-NULL arg and pretends that
|
||||
struct timezone is missing if it does fail. */
|
||||
if (!gettimeofday (&tp, &tzp))
|
||||
# else
|
||||
if (!gettimeofday (&tp, (void *) 0))
|
||||
# endif /* HAVE_STRUCT_TIMEZONE */
|
||||
# endif /* GETTIMEOFDAY_ONE_ARGUMENT */
|
||||
values[7] = tp.tv_usec / 1000;
|
||||
}
|
||||
#else
|
||||
values[7] = GFC_INTEGER_4_HUGE;
|
||||
#endif /* HAVE_GETTIMEOFDAY */
|
||||
|
||||
if (__date)
|
||||
{
|
||||
snprintf (date, DATE_LEN + 1, "%04d%02d%02d",
|
||||
values[0], values[1], values[2]);
|
||||
}
|
||||
|
||||
if (__time)
|
||||
{
|
||||
snprintf (timec, TIME_LEN + 1, "%02d%02d%02d.%03d",
|
||||
values[4], values[5], values[6], values[7]);
|
||||
}
|
||||
|
||||
if (__zone)
|
||||
{
|
||||
snprintf (zone, ZONE_LEN + 1, "%+03d%02d",
|
||||
values[3] / 60, abs (values[3] % 60));
|
||||
}
|
||||
#else /* if defined HAVE_NO_DATE_TIME */
|
||||
/* We really have *nothing* to return, so return blanks and HUGE(0). */
|
||||
{
|
||||
int i;
|
||||
|
||||
memset (date, ' ', DATE_LEN);
|
||||
date[DATE_LEN] = '\0';
|
||||
|
||||
memset (timec, ' ', TIME_LEN);
|
||||
time[TIME_LEN] = '\0';
|
||||
|
||||
memset (zone, ' ', ZONE_LEN);
|
||||
zone[ZONE_LEN] = '\0';
|
||||
|
||||
for (i = 0; i < VALUES_SIZE; i++)
|
||||
values[i] = GFC_INTEGER_4_HUGE;
|
||||
}
|
||||
#endif /* HAVE_NO_DATE_TIME */
|
||||
|
||||
/* Copy the values into the arguments. */
|
||||
if (__values)
|
||||
{
|
||||
int i;
|
||||
size_t len, delta, elt_size;
|
||||
|
||||
elt_size = GFC_DESCRIPTOR_SIZE (__values);
|
||||
len = __values->dim[0].ubound + 1 - __values->dim[0].lbound;
|
||||
delta = __values->dim[0].stride;
|
||||
if (delta == 0)
|
||||
delta = 1;
|
||||
|
||||
assert (len >= VALUES_SIZE);
|
||||
/* Cope with different type kinds. */
|
||||
if (elt_size == 4)
|
||||
{
|
||||
GFC_INTEGER_4 *vptr4 = __values->data;
|
||||
|
||||
for (i = 0; i < VALUES_SIZE; i++, vptr4 += delta)
|
||||
{
|
||||
*vptr4 = values[i];
|
||||
}
|
||||
}
|
||||
else if (elt_size == 8)
|
||||
{
|
||||
GFC_INTEGER_8 *vptr8 = (GFC_INTEGER_8 *)__values->data;
|
||||
|
||||
for (i = 0; i < VALUES_SIZE; i++, vptr8 += delta)
|
||||
{
|
||||
if (values[i] == GFC_INTEGER_4_HUGE)
|
||||
*vptr8 = GFC_INTEGER_8_HUGE;
|
||||
else
|
||||
*vptr8 = values[i];
|
||||
}
|
||||
}
|
||||
else
|
||||
abort ();
|
||||
}
|
||||
|
||||
if (__zone)
|
||||
{
|
||||
assert (__zone_len >= ZONE_LEN);
|
||||
fstrcpy (__zone, ZONE_LEN, zone, ZONE_LEN);
|
||||
}
|
||||
|
||||
if (__time)
|
||||
{
|
||||
assert (__time_len >= TIME_LEN);
|
||||
fstrcpy (__time, TIME_LEN, timec, TIME_LEN);
|
||||
}
|
||||
|
||||
if (__date)
|
||||
{
|
||||
assert (__date_len >= DATE_LEN);
|
||||
fstrcpy (__date, DATE_LEN, date, DATE_LEN);
|
||||
}
|
||||
#undef DATE_LEN
|
||||
#undef TIME_LEN
|
||||
#undef ZONE_LEN
|
||||
#undef VALUES_SIZE
|
||||
}
|
||||
81
libgfortran/intrinsics/etime.c
Normal file
81
libgfortran/intrinsics/etime.c
Normal file
@ -0,0 +1,81 @@
|
||||
/* Implementation of the ETIME intrinsic.
|
||||
Copyright (C) 2004 Free Software Foundation, Inc.
|
||||
Contributed by Steven G. Kargl <kargls@comcast.net>.
|
||||
|
||||
This file is part of the GNU Fortran 95 runtime library (libgfortran).
|
||||
|
||||
Libgfortran is free software; you can redistribute it and/or
|
||||
modify it under the terms of the GNU Lesser General Public
|
||||
License as published by the Free Software Foundation; either
|
||||
version 2.1 of the License, or (at your option) any later version.
|
||||
|
||||
Libgfortran is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU Lesser General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU Lesser General Public
|
||||
License along with libgfor; see the file COPYING.LIB. If not,
|
||||
write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
||||
Boston, MA 02111-1307, USA. */
|
||||
|
||||
#include "config.h"
|
||||
#include <sys/types.h>
|
||||
#include "libgfortran.h"
|
||||
|
||||
#include <stdio.h>
|
||||
|
||||
#if defined (HAVE_SYS_TIME_H) && defined (HAVE_SYS_RESOURCE_H)
|
||||
#include <sys/time.h>
|
||||
#include <sys/resource.h>
|
||||
#endif
|
||||
|
||||
void
|
||||
prefix(etime_sub) (gfc_array_r4 *t, GFC_REAL_4 *result)
|
||||
{
|
||||
GFC_REAL_4 tu, ts, tt, *tp;
|
||||
index_type dim;
|
||||
|
||||
#if defined(HAVE_SYS_TIME_H) && defined(HAVE_SYS_RESOURCE_H)
|
||||
struct rusage rt;
|
||||
|
||||
if (getrusage(RUSAGE_SELF, &rt) == 0)
|
||||
{
|
||||
tu = (GFC_REAL_4)(rt.ru_utime.tv_sec + 1.e-6 * rt.ru_utime.tv_usec);
|
||||
ts = (GFC_REAL_4)(rt.ru_stime.tv_sec + 1.e-6 * rt.ru_stime.tv_usec);
|
||||
tt = tu + ts;
|
||||
}
|
||||
else
|
||||
{
|
||||
tu = -1.;
|
||||
ts = -1.;
|
||||
tt = -1.;
|
||||
}
|
||||
#else
|
||||
tu = -1.;
|
||||
ts = -1.;
|
||||
tt = -1.;
|
||||
#endif
|
||||
|
||||
dim = GFC_DESCRIPTOR_RANK (t);
|
||||
if (dim != 1)
|
||||
runtime_error ("Array rank of TARRAY is not 1.");
|
||||
|
||||
if (t->dim[0].stride == 0)
|
||||
t->dim[0].stride = 1;
|
||||
|
||||
tp = t->data;
|
||||
|
||||
*tp = tu;
|
||||
tp += t->dim[0].stride;
|
||||
*tp = ts;
|
||||
*result = tt;
|
||||
}
|
||||
|
||||
GFC_REAL_4
|
||||
prefix(etime) (gfc_array_r4 *t)
|
||||
{
|
||||
GFC_REAL_4 val;
|
||||
prefix(etime_sub) (t, &val);
|
||||
return val;
|
||||
}
|
||||
93
libgfortran/intrinsics/rand.c
Normal file
93
libgfortran/intrinsics/rand.c
Normal file
@ -0,0 +1,93 @@
|
||||
/* Implementation of the IRAND, RAND, and SRAND intrinsics.
|
||||
Copyright (C) 2004 Free Software Foundation, Inc.
|
||||
Contributed by Steven G. Kargl <kargls@comcast.net>.
|
||||
|
||||
This file is part of the GNU Fortran 95 runtime library (libgfortran).
|
||||
|
||||
Libgfortran is free software; you can redistribute it and/or
|
||||
modify it under the terms of the GNU Lesser General Public
|
||||
License as published by the Free Software Foundation; either
|
||||
version 2.1 of the License, or (at your option) any later version.
|
||||
|
||||
Libgfortran is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU Lesser General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU Lesser General Public
|
||||
License along with libgfor; see the file COPYING.LIB. If not,
|
||||
write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
||||
Boston, MA 02111-1307, USA. */
|
||||
|
||||
/* Simple multiplicative congruent algorithm.
|
||||
The period of this generator is approximately 2^31-1, which means that
|
||||
it should not be used for anything serious. The implementation here
|
||||
is based of an algorithm from S.K. Park and K.W. Miller, Comm. ACM,
|
||||
31, 1192-1201 (1988). It is also provided solely for compatibility
|
||||
with G77. */
|
||||
|
||||
#include "config.h"
|
||||
#include "libgfortran.h"
|
||||
|
||||
#define GFC_RAND_A 16807
|
||||
#define GFC_RAND_M 2147483647
|
||||
#define GFC_RAND_M1 (GFC_RAND_M - 1)
|
||||
|
||||
static GFC_UINTEGER_8 rand_seed = 1;
|
||||
|
||||
|
||||
/* Set the seed of the irand generator. Note 0 is a bad seed. */
|
||||
|
||||
void
|
||||
prefix(srand) (GFC_INTEGER_4 *i)
|
||||
{
|
||||
rand_seed = (GFC_UINTEGER_8) (*i != 0) ? *i : 123459876;
|
||||
}
|
||||
|
||||
|
||||
/* Return an INTEGER in the range [1,GFC_RAND_M-1]. */
|
||||
|
||||
GFC_INTEGER_4
|
||||
prefix(irand) (GFC_INTEGER_4 *i)
|
||||
{
|
||||
|
||||
GFC_INTEGER_4 j = *i;
|
||||
|
||||
switch (j)
|
||||
{
|
||||
/* Return the next RN. */
|
||||
case 0:
|
||||
break;
|
||||
|
||||
/* Reset the RN sequence to system-dependent sequence and return the
|
||||
first value. */
|
||||
case 1:
|
||||
j = 0;
|
||||
prefix(srand) (&j);
|
||||
break;
|
||||
|
||||
/* Seed the RN sequence with j and return the first value. */
|
||||
default:
|
||||
prefix(srand) (&j);
|
||||
}
|
||||
|
||||
rand_seed = GFC_RAND_A * rand_seed % GFC_RAND_M;
|
||||
|
||||
return (GFC_INTEGER_4) rand_seed;
|
||||
}
|
||||
|
||||
|
||||
/* Return a REAL in the range [0,1). Cast to double to use the full
|
||||
range of pseudo-random numbers returned by irand(). */
|
||||
|
||||
GFC_REAL_4
|
||||
prefix(rand) (GFC_INTEGER_4 *i)
|
||||
{
|
||||
GFC_REAL_4 val;
|
||||
|
||||
do
|
||||
val = (GFC_REAL_4)((double)(prefix(irand) (i) - 1) / (double) GFC_RAND_M1);
|
||||
while (val == 1.0);
|
||||
|
||||
return val;
|
||||
}
|
||||
Loading…
Reference in New Issue
Block a user