Index: check.c =================================================================== --- check.c (revision 211315) +++ check.c (working copy) @@ -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, @@ -5230,16 +5232,26 @@ gfc_check_system_clock (gfc_expr *count, 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)) + 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; - } if (count_max != NULL) @@ -5252,14 +5264,6 @@ gfc_check_system_clock (gfc_expr *count, if (!variable_check (count_max, 2, false)) return false; - - if (count != NULL - && !same_type_check (count, 0, count_max, 2)) - return false; - - if (count_rate != NULL - && !same_type_check (count_rate, 1, count_max, 2)) - return false; } return true; Index: iresolve.c =================================================================== --- iresolve.c (revision 211315) +++ iresolve.c (working copy) @@ -3293,13 +3293,14 @@ gfc_resolve_system_clock (gfc_code *c) { const char *name; int kind; + gfc_expr *count = c->ext.actual->expr; + gfc_expr *count_max = c->ext.actual->next->next->expr; - 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; + /* 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; Index: trans-decl.c =================================================================== --- trans-decl.c (revision 211315) +++ trans-decl.c (working copy) @@ -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. */ @@ -2791,7 +2793,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_int4_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); @@ -2990,6 +2994,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; Index: trans-intrinsic.c =================================================================== --- trans-intrinsic.c (revision 211315) +++ trans-intrinsic.c (working copy) @@ -2183,6 +2183,98 @@ gfc_conv_intrinsic_fdate (gfc_se * se, g } +/* Call the SYSTEM_CLOCK library functions, handling the type and kind + conversions. */ + +extern void debug_tree (tree); + +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 @@ -7965,6 +8057,10 @@ gfc_conv_intrinsic_subroutine (gfc_code res = conv_co_minmaxsum (code); break; + case GFC_ISYM_SYSTEM_CLOCK: + res = conv_intrinsic_system_clock (code); + break; + default: res = NULL_TREE; break; Index: trans.h =================================================================== --- trans.h (revision 211315) +++ trans.h (working copy) @@ -694,6 +694,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. */