re PR fortran/28484 ([F03] system_clock with real-type count_rate does not compile)

	PR fortran/28484
	PR fortran/61429

	* check.c (gfc_check_system_clock): Improve checking of arguments.
	* intrinsic.texi: Update doc of SYSTEM_CLOCK.
	* iresolve.c (gfc_resolve_system_clock): Choose library function
	used depending on argument kinds.
	* trans-decl.c (gfc_build_intrinsic_function_decls): Build
	decls for system_clock_4 and system_clock_8.
	* trans-intrinsic.c (conv_intrinsic_system_clock): New function.
	(gfc_conv_intrinsic_subroutine): Call conv_intrinsic_system_clock.
	* trans.h (gfor_fndecl_system_clock4, gfor_fndecl_system_clock8):
	New variables.

	* gfortran.dg/system_clock_1.f90: New file.
	* gfortran.dg/system_clock_2.f90: New file.

From-SVN: r211686

gcc/fortran/ChangeLog

+2014-06-15  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/28484
+	PR fortran/61429
+	* check.c (gfc_check_system_clock): Improve checking of arguments.
+	* intrinsic.texi: Update doc of SYSTEM_CLOCK.
+	* iresolve.c (gfc_resolve_system_clock): Choose library function
+	used depending on argument kinds.
+	* trans-decl.c (gfc_build_intrinsic_function_decls): Build
+	decls for system_clock_4 and system_clock_8.
+	* trans-intrinsic.c (conv_intrinsic_system_clock): New function.
+	(gfc_conv_intrinsic_subroutine): Call conv_intrinsic_system_clock.
+	* trans.h (gfor_fndecl_system_clock4, gfor_fndecl_system_clock8):
+	New variables.
+
 2014-06-12  Tobias Burnus  <burnus@net-b.de>
 
 	* gfortran.h (gfc_copy_formal_args_intr): Update prototype.

gcc/fortran/check.c

@@ -5206,8 +5206,10 @@ gfc_check_second_sub (gfc_expr *time)
 }
 
 
-/* The arguments of SYSTEM_CLOCK are scalar, integer variables.  Note,
-   count, count_rate, and count_max are all optional arguments */
+/* COUNT and COUNT_MAX of SYSTEM_CLOCK are scalar, default-kind integer
+   variables in Fortran 95.  In Fortran 2003 and later, they can be of any
+   kind, and COUNT_RATE can be of type real.  Note, count, count_rate, and
+   count_max are all optional arguments */
 
 bool
 gfc_check_system_clock (gfc_expr *count, gfc_expr *count_rate,
@@ -5221,6 +5223,12 @@ gfc_check_system_clock (gfc_expr *count, gfc_expr *count_rate,
       if (!type_check (count, 0, BT_INTEGER))
 	return false;
 
+      if (count->ts.kind != gfc_default_integer_kind
+	  && !gfc_notify_std (GFC_STD_F2003, "COUNT argument to "
+			      "SYSTEM_CLOCK at %L has non-default kind",
+			      &count->where))
+	return false;
+
       if (!variable_check (count, 0, false))
 	return false;
     }
@@ -5230,15 +5238,26 @@ gfc_check_system_clock (gfc_expr *count, gfc_expr *count_rate,
       if (!scalar_check (count_rate, 1))
 	return false;
 
-      if (!type_check (count_rate, 1, BT_INTEGER))
-	return false;
-
       if (!variable_check (count_rate, 1, false))
 	return false;
 
-      if (count != NULL
-	  && !same_type_check (count, 0, count_rate, 1))
-	return false;
+      if (count_rate->ts.type == BT_REAL)
+	{
+	  if (!gfc_notify_std (GFC_STD_F2003, "Real COUNT_RATE argument to "
+			       "SYSTEM_CLOCK at %L", &count_rate->where))
+	    return false;
+	}
+      else
+	{
+	  if (!type_check (count_rate, 1, BT_INTEGER))
+	    return false;
+
+	  if (count_rate->ts.kind != gfc_default_integer_kind
+	      && !gfc_notify_std (GFC_STD_F2003, "COUNT_RATE argument to "
+				  "SYSTEM_CLOCK at %L has non-default kind",
+				  &count_rate->where))
+	    return false;
+	}
 
     }
 
@@ -5250,15 +5269,13 @@ gfc_check_system_clock (gfc_expr *count, gfc_expr *count_rate,
       if (!type_check (count_max, 2, BT_INTEGER))
 	return false;
 
-      if (!variable_check (count_max, 2, false))
-	return false;
-
-      if (count != NULL
-	  && !same_type_check (count, 0, count_max, 2))
+      if (count_max->ts.kind != gfc_default_integer_kind
+	  && !gfc_notify_std (GFC_STD_F2003, "COUNT_MAX argument to "
+			      "SYSTEM_CLOCK at %L has non-default kind",
+			      &count_max->where))
 	return false;
 
-      if (count_rate != NULL
-	  && !same_type_check (count_rate, 1, count_max, 2))
+      if (!variable_check (count_max, 2, false))
 	return false;
     }
 

gcc/fortran/intrinsic.texi

@@ -12259,15 +12259,16 @@ clock implementation, provide up to nanosecond resolution.  If a
 monotonic clock is not available, the implementation falls back to a
 realtime clock.
 
-@var{COUNT_RATE} is system dependent and can vary depending on the
-kind of the arguments. For @var{kind=4} arguments, @var{COUNT}
-represents milliseconds, while for @var{kind=8} arguments, @var{COUNT}
-typically represents micro- or nanoseconds depending on resolution of
-the underlying platform clock. @var{COUNT_MAX} usually equals
-@code{HUGE(COUNT_MAX)}. Note that the millisecond resolution of the
-@var{kind=4} version implies that the @var{COUNT} will wrap around in
-roughly 25 days. In order to avoid issues with the wrap around and for
-more precise timing, please use the @var{kind=8} version.
+@var{COUNT_RATE} is system dependent and can vary depending on the kind of
+the arguments. For @var{kind=4} arguments (and smaller integer kinds),
+@var{COUNT} represents milliseconds, while for @var{kind=8} arguments (and
+larger integer kinds), @var{COUNT} typically represents micro- or
+nanoseconds depending on resolution of the underlying platform clock.
+@var{COUNT_MAX} usually equals @code{HUGE(COUNT_MAX)}. Note that the
+millisecond resolution of the @var{kind=4} version implies that the
+@var{COUNT} will wrap around in roughly 25 days. In order to avoid issues
+with the wrap around and for more precise timing, please use the
+@var{kind=8} version.
 
 If there is no clock, or querying the clock fails, @var{COUNT} is set
 to @code{-HUGE(COUNT)}, and @var{COUNT_RATE} and @var{COUNT_MAX} are
@@ -12299,7 +12300,7 @@ Subroutine
 @item @var{COUNT}      @tab (Optional) shall be a scalar of type 
 @code{INTEGER} with @code{INTENT(OUT)}.
 @item @var{COUNT_RATE} @tab (Optional) shall be a scalar of type 
-@code{INTEGER} with @code{INTENT(OUT)}.
+@code{INTEGER} or @code{REAL}, with @code{INTENT(OUT)}.
 @item @var{COUNT_MAX}  @tab (Optional) shall be a scalar of type 
 @code{INTEGER} with @code{INTENT(OUT)}.
 @end multitable

gcc/fortran/iresolve.c

@@ -3293,13 +3293,14 @@ 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;
+  gfc_expr *count = c->ext.actual->expr;
+  gfc_expr *count_max = c->ext.actual->next->next->expr;
+
+  /* The INTEGER(8) version has higher precision, it is used if both COUNT
+     and COUNT_MAX can hold 64-bit values, or are absent.  */
+  if ((!count || count->ts.kind >= 8)
+      && (!count_max || count_max->ts.kind >= 8))
+    kind = 8;
   else
     kind = gfc_default_integer_kind;
 

gcc/fortran/trans-decl.c

@@ -116,6 +116,8 @@ tree gfor_fndecl_ttynam;
 tree gfor_fndecl_in_pack;
 tree gfor_fndecl_in_unpack;
 tree gfor_fndecl_associated;
+tree gfor_fndecl_system_clock4;
+tree gfor_fndecl_system_clock8;
 
 
 /* Coarray run-time library function decls.  */
@@ -2822,7 +2824,9 @@ static void
 gfc_build_intrinsic_function_decls (void)
 {
   tree gfc_int4_type_node = gfc_get_int_type (4);
+  tree gfc_pint4_type_node = build_pointer_type (gfc_int4_type_node);
   tree gfc_int8_type_node = gfc_get_int_type (8);
+  tree gfc_pint8_type_node = build_pointer_type (gfc_int8_type_node);
   tree gfc_int16_type_node = gfc_get_int_type (16);
   tree gfc_logical4_type_node = gfc_get_logical_type (4);
   tree pchar1_type_node = gfc_get_pchar_type (1);
@@ -3021,6 +3025,16 @@ gfc_build_intrinsic_function_decls (void)
   DECL_PURE_P (gfor_fndecl_sr_kind) = 1;
   TREE_NOTHROW (gfor_fndecl_sr_kind) = 1;
 
+  gfor_fndecl_system_clock4 = gfc_build_library_function_decl (
+	get_identifier (PREFIX("system_clock_4")),
+	void_type_node, 3, gfc_pint4_type_node, gfc_pint4_type_node,
+	gfc_pint4_type_node);
+
+  gfor_fndecl_system_clock8 = gfc_build_library_function_decl (
+	get_identifier (PREFIX("system_clock_8")),
+	void_type_node, 3, gfc_pint8_type_node, gfc_pint8_type_node,
+	gfc_pint8_type_node);
+
   /* Power functions.  */
   {
     tree ctype, rtype, itype, jtype;

gcc/fortran/trans-intrinsic.c

@@ -2183,6 +2183,96 @@ gfc_conv_intrinsic_fdate (gfc_se * se, gfc_expr * expr)
 }
 
 
+/* Call the SYSTEM_CLOCK library functions, handling the type and kind
+   conversions.  */
+
+static tree
+conv_intrinsic_system_clock (gfc_code *code)
+{
+  stmtblock_t block;
+  gfc_se count_se, count_rate_se, count_max_se;
+  tree arg1 = NULL_TREE, arg2 = NULL_TREE, arg3 = NULL_TREE;
+  tree type, tmp;
+  int kind;
+
+  gfc_expr *count = code->ext.actual->expr;
+  gfc_expr *count_rate = code->ext.actual->next->expr;
+  gfc_expr *count_max = code->ext.actual->next->next->expr;
+
+  /* The INTEGER(8) version has higher precision, it is used if both COUNT
+     and COUNT_MAX can hold 64-bit values, or are absent.  */
+  if ((!count || count->ts.kind >= 8)
+      && (!count_max || count_max->ts.kind >= 8))
+    kind = 8;
+  else
+    kind = gfc_default_integer_kind;
+  type = gfc_get_int_type (kind);
+
+  /* Evaluate our arguments.  */
+  if (count)
+    {
+      gfc_init_se (&count_se, NULL);
+      gfc_conv_expr (&count_se, count);
+    }
+
+  if (count_rate)
+    {
+      gfc_init_se (&count_rate_se, NULL);
+      gfc_conv_expr (&count_rate_se, count_rate);
+    }
+
+  if (count_max)
+    {
+      gfc_init_se (&count_max_se, NULL);
+      gfc_conv_expr (&count_max_se, count_max);
+    }
+
+  /* Prepare temporary variables if we need them.  */
+  if (count && count->ts.kind != kind)
+    arg1 = gfc_create_var (type, "count");
+  else if (count)
+    arg1 = count_se.expr;
+
+  if (count_rate && (count_rate->ts.kind != kind
+		     || count_rate->ts.type != BT_INTEGER))
+    arg2 = gfc_create_var (type, "count_rate");
+  else if (count_rate)
+    arg2 = count_rate_se.expr;
+
+  if (count_max && count_max->ts.kind != kind)
+    arg3 = gfc_create_var (type, "count_max");
+  else if (count_max)
+    arg3 = count_max_se.expr;
+
+  /* Make the function call. */
+  gfc_init_block (&block);
+  tmp = build_call_expr_loc (input_location,
+			     kind == 4 ? gfor_fndecl_system_clock4
+				       : gfor_fndecl_system_clock8,
+                             3,
+			     arg1 ? gfc_build_addr_expr (NULL_TREE, arg1)
+				  : null_pointer_node,
+			     arg2 ? gfc_build_addr_expr (NULL_TREE, arg2)
+				  : null_pointer_node,
+			     arg3 ? gfc_build_addr_expr (NULL_TREE, arg3)
+				  : null_pointer_node);
+  gfc_add_expr_to_block (&block, tmp);
+
+  /* And store values back if needed.  */
+  if (arg1 && arg1 != count_se.expr)
+    gfc_add_modify (&block, count_se.expr,
+		    fold_convert (TREE_TYPE (count_se.expr), arg1));
+  if (arg2 && arg2 != count_rate_se.expr)
+    gfc_add_modify (&block, count_rate_se.expr,
+		    fold_convert (TREE_TYPE (count_rate_se.expr), arg2));
+  if (arg3 && arg3 != count_max_se.expr)
+    gfc_add_modify (&block, count_max_se.expr,
+		    fold_convert (TREE_TYPE (count_max_se.expr), arg3));
+
+  return gfc_finish_block (&block);
+}
+
+
 /* Return a character string containing the tty name.  */
 
 static void
@@ -7968,6 +8058,10 @@ gfc_conv_intrinsic_subroutine (gfc_code *code)
       res = conv_co_minmaxsum (code);
       break;
 
+    case GFC_ISYM_SYSTEM_CLOCK:
+      res = conv_intrinsic_system_clock (code);
+      break;
+
     default:
       res = NULL_TREE;
       break;

gcc/fortran/trans.h

@@ -697,6 +697,8 @@ extern GTY(()) tree gfor_fndecl_fdate;
 extern GTY(()) tree gfor_fndecl_in_pack;
 extern GTY(()) tree gfor_fndecl_in_unpack;
 extern GTY(()) tree gfor_fndecl_associated;
+extern GTY(()) tree gfor_fndecl_system_clock4;
+extern GTY(()) tree gfor_fndecl_system_clock8;
 
 
 /* Coarray run-time library function decls.  */

gcc/testsuite/ChangeLog

+2014-06-15  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
+
+	PR fortran/28484
+	PR fortran/61429
+	* gfortran.dg/system_clock_1.f90: New file.
+	* gfortran.dg/system_clock_2.f90: New file.
+
 2014-06-14  Paolo Carlini  <paolo.carlini@oracle.com>
 
 	PR c++/33101

gcc/testsuite/gfortran.dg/system_clock_1.f90

+! { dg-do run }
+
+  integer :: i, j, k
+  integer(kind=8) :: i8, j8, k8
+  real :: x
+  double precision :: z
+
+  call system_clock(i, j, k)
+  call system_clock(i, j, k8)
+  call system_clock(i, j8, k)
+  call system_clock(i, j8, k8)
+  call system_clock(i8, j, k)
+  call system_clock(i8, j, k8)
+  call system_clock(i8, j8, k)
+  call system_clock(i8, j8, k8)
+
+  call system_clock(i, x, k)
+  call system_clock(i, x, k8)
+  call system_clock(i, x, k)
+  call system_clock(i, x, k8)
+  call system_clock(i8, x, k)
+  call system_clock(i8, x, k8)
+  call system_clock(i8, x, k)
+  call system_clock(i8, x, k8)
+
+  call system_clock(i, z, k)
+  call system_clock(i, z, k8)
+  call system_clock(i, z, k)
+  call system_clock(i, z, k8)
+  call system_clock(i8, z, k)
+  call system_clock(i8, z, k8)
+  call system_clock(i8, z, k)
+  call system_clock(i8, z, k8)
+
+  end

gcc/testsuite/gfortran.dg/system_clock_2.f90

+! { dg-do compile }
+! { dg-options "-std=f95" }
+
+  integer :: i, j, k
+  integer(kind=8) :: i8, j8, k8
+  real :: x
+  double precision :: z
+
+  call system_clock(i, j, k)
+  call system_clock(i, j, k8) ! { dg-error "has non-default kind" }
+  call system_clock(i, j8, k) ! { dg-error "has non-default kind" }
+  call system_clock(i8, j, k) ! { dg-error "has non-default kind" }
+
+  call system_clock(i, x, k) ! { dg-error "Real COUNT_RATE argument" }
+
+  call system_clock(i, z, k) ! { dg-error "Real COUNT_RATE argument" }
+
+  end