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

7 files changed, 256 insertions, 2 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index a823c8a..e1cf74e 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -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
diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index 007f8d9..cbf3d9d 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 c82483e..a533b1c 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 95e208f..7247d89 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 b2c0e78..ab26143 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 f1da732..2d8fffd 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 96eb306..e2c1b7e 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;