From: Francois-Xavier Coudert Date: Sun, 15 Jun 2014 16:58:53 +0000 (+0000) Subject: re PR fortran/28484 ([F03] system_clock with real-type count_rate does not compile) X-Git-Tag: upstream/12.2.0~62569 X-Git-Url: http://review.tizen.org/git/?a=commitdiff_plain;h=a416c4c766df05b1e85dcee2fe7857e9a6e87b88;p=platform%2Fupstream%2Fgcc.git 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 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 53aabd8..308a7bc 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,18 @@ +2014-06-15 Francois-Xavier Coudert + + 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 * gfortran.h (gfc_copy_formal_args_intr): Update prototype. diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index 20af75f..caf3b6c 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 5c66aab..ed4ecaa 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 d029f720..f9a69fe 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 863e596..1940622 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 2ac39f6..613beef 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 7e8d08c..d1c778f 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 a9b14dd..1f530dc 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,10 @@ +2014-06-15 Francois-Xavier Coudert + + 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 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 0000000..41027de --- /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 0000000..f7399af --- /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