* check.c (gfc_check_system_clock): New function.

	* intrinsic.c (add_sym_3s): New function.
	(add_subroutines): Use it.
	* intrinsic.h (gfc_check_system_clock, gfc_resolve_system_clock):
	Add prototypes.
	* iresolve.c (gfc_resolve_system_clock): New function.
libgfortran/
	* intrinsics/system_clock: New file.
	* Makefile.am: Add intrinsics/system_clock.c.
	* Makefile.in: Regenerate.


git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@82131 138bc75d-0d04-0410-961f-82ee72b054a4

5 files changed, 120 insertions, 2 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 7b24d047200..f2c23546bbc 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,5 +1,14 @@
 2004-05-22  Steven G. Kargl  <kargls@comcast.net>
 
+	* check.c (gfc_check_system_clock): New function.
+	* intrinsic.c (add_sym_3s): New function.
+	(add_subroutines): Use it.
+	* intrinsic.h (gfc_check_system_clock, gfc_resolve_system_clock):
+	Add prototypes.
+	* iresolve.c (gfc_resolve_system_clock): New function.
+
+2004-05-22  Steven G. Kargl  <kargls@comcast.net>
+
 	* invoke.texi: Document -Wunderflow and spell check.
 	* lang.opt: Add Wunderflow.
 	* gfortran.h (gfc_option_t): Add warn_underflow option.
diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index 703002f0fec..dadb1166ea9 100644
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -1864,3 +1864,62 @@ gfc_check_random_seed (gfc_expr * size, gfc_expr * put, gfc_expr * get)
 
   return SUCCESS;
 }
+
+/* The arguments of SYSTEM_CLOCK are scalar, integer variables.  Note,
+   count, count_rate, and count_max are all optional arguments */
+
+try
+gfc_check_system_clock (gfc_expr * count, gfc_expr * count_rate,
+                        gfc_expr * count_max)
+{
+
+  if (count != NULL)
+    {
+      if (scalar_check (count, 0) == FAILURE)
+        return FAILURE;
+
+      if (type_check (count, 0, BT_INTEGER) == FAILURE)
+        return FAILURE;
+
+      if (variable_check (count, 0) == FAILURE)
+        return FAILURE;
+    }
+
+  if (count_rate != NULL)
+    {
+      if (scalar_check (count_rate, 1) == FAILURE)
+        return FAILURE;
+
+      if (type_check (count_rate, 1, BT_INTEGER) == FAILURE)
+        return FAILURE;
+
+      if (variable_check (count_rate, 1) == FAILURE)
+        return FAILURE;
+
+      if (count != NULL && same_type_check(count, 0, count_rate, 1) == FAILURE)
+        return FAILURE;
+
+    }
+
+  if (count_max != NULL)
+    {
+      if (scalar_check (count_max, 2) == FAILURE)
+        return FAILURE;
+
+      if (type_check (count_max, 2, BT_INTEGER) == FAILURE)
+        return FAILURE;
+
+      if (variable_check (count_max, 2) == FAILURE)
+        return FAILURE;
+
+      if (count != NULL && same_type_check(count, 0, count_max, 2) == FAILURE)
+        return FAILURE;
+
+      if (count_rate != NULL
+          && same_type_check(count_rate, 1, count_max, 2) == FAILURE)
+        return FAILURE;
+
+   }
+
+    return SUCCESS;
+}
diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c
index c787e227a4e..7b77fdb6eed 100644
--- a/gcc/fortran/intrinsic.c
+++ b/gcc/fortran/intrinsic.c
@@ -453,6 +453,33 @@ static void add_sym_3 (const char *name, int elemental, int actual_ok, bt type,
 	   (void*)0);
 }
 
+/* Add the name of an intrinsic subroutine with three arguments to the list
+   of intrinsic names. */
+
+static void add_sym_3s (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,
+		       const char* a3, bt type3, int kind3, int optional3
+		       ) {
+  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,
+	   a3, type3, kind3, optional3,
+	   (void*)0);
+}
+
 
 static void add_sym_4 (const char *name, int elemental, int actual_ok, bt type,
 		       int kind,
@@ -1632,8 +1659,8 @@ add_subroutines (void)
 	     sz, BT_INTEGER, di, 1, pt, BT_INTEGER, di, 1,
 	     gt, BT_INTEGER, di, 1);
 
-  add_sym_3 ("system_clock", 0, 1, BT_UNKNOWN, 0,
-	     NULL, NULL, NULL,
+  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,
 	     cm, BT_INTEGER, di, 1);
 }
diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h
index fa39a3e4234..b2c0e780f4e 100644
--- a/gcc/fortran/intrinsic.h
+++ b/gcc/fortran/intrinsic.h
@@ -99,6 +99,7 @@ try gfc_check_x (gfc_expr *);
 
 /* Intrinsic subroutines.  */
 try gfc_check_cpu_time (gfc_expr *);
+try gfc_check_system_clock (gfc_expr *, gfc_expr *, gfc_expr *);
 try gfc_check_date_and_time (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
 try gfc_check_mvbits (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *,
 		      gfc_expr *);
@@ -303,6 +304,7 @@ void gfc_resolve_verify (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
 
 /* Intrinsic subroutine resolution.  */
 void gfc_resolve_cpu_time (gfc_code *);
+void gfc_resolve_system_clock(gfc_code *);
 void gfc_resolve_random_number (gfc_code *);
 
 
diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c
index e873f03f0dc..46e38037f60 100644
--- a/gcc/fortran/iresolve.c
+++ b/gcc/fortran/iresolve.c
@@ -1369,6 +1369,27 @@ gfc_resolve_random_number (gfc_code * c ATTRIBUTE_UNUSED)
   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
 }
 
+/* Determine if the arguments to SYSTEM_CLOCK are INTEGER(4) or INTEGER(8) */
+
+void
+gfc_resolve_system_clock (gfc_code * c)
+{
+  const char *name;
+  int kind;
+
+  if (c->ext.actual->expr != NULL)
+    kind = c->ext.actual->expr->ts.kind;
+  else if (c->ext.actual->next->expr != NULL)
+      kind = c->ext.actual->next->expr->ts.kind;
+  else if (c->ext.actual->next->next->expr != NULL)
+      kind = c->ext.actual->next->next->expr->ts.kind;
+  else
+    kind = gfc_default_integer_kind ();
+
+  name = gfc_get_string (PREFIX("system_clock_%d"), kind);
+  c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+}
+
 
 void
 gfc_iresolve_init_1 (void)