From 2bd749490845f2edc7de74dca4b29fd7d7698dff Mon Sep 17 00:00:00 2001 From: "Steven G. Kargl" Date: Sat, 12 Jun 2004 17:34:47 +0000 Subject: [PATCH] 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 --- gcc/fortran/ChangeLog | 13 ++ gcc/fortran/check.c | 113 ++++++++++ gcc/fortran/gfortran.h | 4 + gcc/fortran/intrinsic.c | 76 +++++++ gcc/fortran/intrinsic.h | 11 +- gcc/fortran/iresolve.c | 37 +++- gcc/fortran/trans-intrinsic.c | 4 + libgfortran/ChangeLog | 9 + libgfortran/Makefile.am | 2 + libgfortran/Makefile.in | 24 ++- libgfortran/intrinsics/cpu_time.c | 13 ++ libgfortran/intrinsics/date_and_time.c | 280 +++++++++++++++++++++++++ libgfortran/intrinsics/etime.c | 81 +++++++ libgfortran/intrinsics/rand.c | 93 ++++++++ 14 files changed, 756 insertions(+), 4 deletions(-) create mode 100644 libgfortran/intrinsics/date_and_time.c create mode 100644 libgfortran/intrinsics/etime.c create mode 100644 libgfortran/intrinsics/rand.c diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index a823c8a2a59..e1cf74e9518 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,16 @@ +2004-06-12 Steven G. Kargl + + * 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 PR fortran/14957 diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index 007f8d975e4..cbf3d9dba7a 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -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; +} diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index c82483e9851..a533b1c348e 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -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, diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c index 95e208f25dc..7247d892ebe 100644 --- a/gcc/fortran/intrinsic.c +++ b/gcc/fortran/intrinsic.c @@ -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, diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h index b2c0e780f4e..ab261431f06 100644 --- a/gcc/fortran/intrinsic.h +++ b/gcc/fortran/intrinsic.h @@ -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 *); diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c index f1da7329c48..2d8fffd4558 100644 --- a/gcc/fortran/iresolve.c +++ b/gcc/fortran/iresolve.c @@ -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) { diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index 96eb306adc1..e2c1b7e1529 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -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; diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog index 8cf4131eae1..2865a4342b2 100644 --- a/libgfortran/ChangeLog +++ b/libgfortran/ChangeLog @@ -1,3 +1,12 @@ +2004-06-12 Steven G. Kargl + + * 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 Steven Bosscher diff --git a/libgfortran/Makefile.am b/libgfortran/Makefile.am index 63bf6b5afe6..a395cdddf7b 100644 --- a/libgfortran/Makefile.am +++ b/libgfortran/Makefile.am @@ -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 \ diff --git a/libgfortran/Makefile.in b/libgfortran/Makefile.in index f30ae3077c6..01399c917b7 100644 --- a/libgfortran/Makefile.in +++ b/libgfortran/Makefile.in @@ -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 diff --git a/libgfortran/intrinsics/cpu_time.c b/libgfortran/intrinsics/cpu_time.c index 9fd954b9a71..887debc3e53 100644 --- a/libgfortran/intrinsics/cpu_time.c +++ b/libgfortran/intrinsics/cpu_time.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; +} diff --git a/libgfortran/intrinsics/date_and_time.c b/libgfortran/intrinsics/date_and_time.c new file mode 100644 index 00000000000..6a09b2aeba2 --- /dev/null +++ b/libgfortran/intrinsics/date_and_time.c @@ -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 +#include +#include +#include "libgfortran.h" + +#include +#include + +#undef HAVE_NO_DATE_TIME +#if TIME_WITH_SYS_TIME +# include +# include +#else +# if HAVE_SYS_TIME_H +# include +# else +# ifdef HAVE_TIME_H +# include +# 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 +} diff --git a/libgfortran/intrinsics/etime.c b/libgfortran/intrinsics/etime.c new file mode 100644 index 00000000000..89ee539f064 --- /dev/null +++ b/libgfortran/intrinsics/etime.c @@ -0,0 +1,81 @@ +/* Implementation of the ETIME intrinsic. + Copyright (C) 2004 Free Software Foundation, Inc. + Contributed by Steven G. Kargl . + +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 +#include "libgfortran.h" + +#include + +#if defined (HAVE_SYS_TIME_H) && defined (HAVE_SYS_RESOURCE_H) +#include +#include +#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; +} diff --git a/libgfortran/intrinsics/rand.c b/libgfortran/intrinsics/rand.c new file mode 100644 index 00000000000..c4782fcdf61 --- /dev/null +++ b/libgfortran/intrinsics/rand.c @@ -0,0 +1,93 @@ +/* Implementation of the IRAND, RAND, and SRAND intrinsics. + Copyright (C) 2004 Free Software Foundation, Inc. + Contributed by Steven G. Kargl . + +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; +} -- 2.30.2