summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--gcc/fortran/ChangeLog15
-rw-r--r--gcc/fortran/check.c47
-rw-r--r--gcc/fortran/intrinsic.texi21
-rw-r--r--gcc/fortran/iresolve.c15
-rw-r--r--gcc/fortran/trans-decl.c14
-rw-r--r--gcc/fortran/trans-intrinsic.c94
-rw-r--r--gcc/fortran/trans.h2
-rw-r--r--gcc/testsuite/ChangeLog7
-rw-r--r--gcc/testsuite/gfortran.dg/system_clock_1.f9035
-rw-r--r--gcc/testsuite/gfortran.dg/system_clock_2.f9018
10 files changed, 236 insertions, 32 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 53aabd8faa0..308a7bc22bf 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,18 @@
+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.
diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index 20af75feb44..caf3b6cbb4e 100644
--- a/gcc/fortran/check.c
+++ b/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;
}
diff --git a/gcc/fortran/intrinsic.texi b/gcc/fortran/intrinsic.texi
index 5c66aab4b8a..ed4ecaa8838 100644
--- a/gcc/fortran/intrinsic.texi
+++ b/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
diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c
index d029f720a8d..f9a69feaeef 100644
--- a/gcc/fortran/iresolve.c
+++ b/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;
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index 863e596c639..1940622d9da 100644
--- a/gcc/fortran/trans-decl.c
+++ b/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;
diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index 2ac39f67bf2..613beef4331 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/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;
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 7e8d08cda85..d1c778f7b5a 100644
--- a/gcc/fortran/trans.h
+++ b/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. */
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index a9b14ddf888..1f530dc5850 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,10 @@
+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
diff --git a/gcc/testsuite/gfortran.dg/system_clock_1.f90 b/gcc/testsuite/gfortran.dg/system_clock_1.f90
new file mode 100644
index 00000000000..41027deb28f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/system_clock_1.f90
@@ -0,0 +1,35 @@
+! { 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
diff --git a/gcc/testsuite/gfortran.dg/system_clock_2.f90 b/gcc/testsuite/gfortran.dg/system_clock_2.f90
new file mode 100644
index 00000000000..f7399afe2d1
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/system_clock_2.f90
@@ -0,0 +1,18 @@
+! { 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
View Lorry Controller Status