+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
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 */
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;
+}
GFC_ISYM_DOT_PRODUCT,
GFC_ISYM_DPROD,
GFC_ISYM_EOSHIFT,
+ GFC_ISYM_ETIME,
GFC_ISYM_EXP,
GFC_ISYM_EXPONENT,
GFC_ISYM_FLOOR,
GFC_ISYM_INDEX,
GFC_ISYM_INT,
GFC_ISYM_IOR,
+ GFC_ISYM_IRAND,
GFC_ISYM_ISHFT,
GFC_ISYM_ISHFTC,
GFC_ISYM_LBOUND,
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,
}
+/* 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 *),
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);
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);
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);
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);
bck, BT_LOGICAL, dl, 1);
make_generic ("verify", GFC_ISYM_VERIFY);
+
+
}
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);
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,
/* 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.
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 *);
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 *);
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 *);
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 *);
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 *);
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 *);
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);
}
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
-
void
gfc_iresolve_init_1 (void)
{
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;
+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>
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 \
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 =
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 \
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
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
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;
+}
--- /dev/null
+/* 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
+}
--- /dev/null
+/* 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;
+}
--- /dev/null
+/* 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;
+}
projects / gcc.git / commitdiff