X-Git-Url: http://git.sourceforge.jp/view?a=blobdiff_plain;f=gcc%2Ffortran%2Ftrans-intrinsic.c;h=1113b5cd3cc734d472a7c915bd8d79be70fdb4b1;hb=a7a4626828090600459358ca745c4482cf9551a1;hp=77bad73d51de40f8f5b1182048b480bc09d498aa;hpb=34e106da3844e0ca1d66a310d558371e952f0423;p=pf3gnuchains%2Fgcc-fork.git diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index 77bad73d51d..1113b5cd3cc 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -1,5 +1,5 @@ /* Intrinsic translation - Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008 + Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. Contributed by Paul Brook and Steven Bosscher @@ -25,12 +25,10 @@ along with GCC; see the file COPYING3. If not see #include "config.h" #include "system.h" #include "coretypes.h" -#include "tm.h" +#include "tm.h" /* For UNITS_PER_WORD. */ #include "tree.h" #include "ggc.h" #include "toplev.h" -#include "real.h" -#include "tree-gimple.h" #include "flags.h" #include "gfortran.h" #include "arith.h" @@ -45,8 +43,7 @@ along with GCC; see the file COPYING3. If not see /* This maps fortran intrinsic math functions to external library or GCC builtin functions. */ -typedef struct gfc_intrinsic_map_t GTY(()) -{ +typedef struct GTY(()) gfc_intrinsic_map_t { /* The explicit enum is required to work around inadequacies in the garbage collection/gengtype parsing mechanism. */ enum gfc_isym_id id; @@ -93,9 +90,11 @@ gfc_intrinsic_map_t; except for atan2. */ #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE) \ { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \ - BUILT_IN_ ## ID ## L, BUILT_IN_ ## ID ## L, 0, 0, 0, 0, true, \ - false, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \ - NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE}, + BUILT_IN_ ## ID ## L, BUILT_IN_ ## ID ## L, (enum built_in_function) 0, \ + (enum built_in_function) 0, (enum built_in_function) 0, \ + (enum built_in_function) 0, true, false, true, NAME, NULL_TREE, \ + NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \ + NULL_TREE}, #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE) \ { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \ @@ -104,17 +103,25 @@ gfc_intrinsic_map_t; true, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \ NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE}, +#define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX) \ + { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, END_BUILTINS, \ + END_BUILTINS, END_BUILTINS, END_BUILTINS, END_BUILTINS, \ + false, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \ + NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE } + static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map[] = { /* Functions built into gcc itself. */ #include "mathbuiltins.def" + /* Functions in libgfortran. */ + LIB_FUNCTION (ERFC_SCALED, "erfc_scaled", false), + /* End the list. */ - { GFC_ISYM_NONE, END_BUILTINS, END_BUILTINS, END_BUILTINS, END_BUILTINS, - END_BUILTINS, END_BUILTINS, END_BUILTINS, END_BUILTINS, - true, false, true, NULL, NULL_TREE, NULL_TREE, NULL_TREE, - NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE } + LIB_FUNCTION (NONE, NULL, false) + }; +#undef LIB_FUNCTION #undef DEFINE_MATH_BUILTIN #undef DEFINE_MATH_BUILTIN_C @@ -233,7 +240,7 @@ gfc_conv_intrinsic_conversion (gfc_se * se, gfc_expr * expr) int nargs; nargs = gfc_intrinsic_argument_list_length (expr); - args = alloca (sizeof (tree) * nargs); + args = (tree *) alloca (sizeof (tree) * nargs); /* Evaluate all the arguments passed. Whilst we're only interested in the first one here, there are other parts of the front-end that assume this @@ -242,6 +249,42 @@ gfc_conv_intrinsic_conversion (gfc_se * se, gfc_expr * expr) gcc_assert (expr->value.function.actual->expr); gfc_conv_intrinsic_function_args (se, expr, args, nargs); + /* Conversion between character kinds involves a call to a library + function. */ + if (expr->ts.type == BT_CHARACTER) + { + tree fndecl, var, addr, tmp; + + if (expr->ts.kind == 1 + && expr->value.function.actual->expr->ts.kind == 4) + fndecl = gfor_fndecl_convert_char4_to_char1; + else if (expr->ts.kind == 4 + && expr->value.function.actual->expr->ts.kind == 1) + fndecl = gfor_fndecl_convert_char1_to_char4; + else + gcc_unreachable (); + + /* Create the variable storing the converted value. */ + type = gfc_get_pchar_type (expr->ts.kind); + var = gfc_create_var (type, "str"); + addr = gfc_build_addr_expr (build_pointer_type (type), var); + + /* Call the library function that will perform the conversion. */ + gcc_assert (nargs >= 2); + tmp = build_call_expr_loc (input_location, + fndecl, 3, addr, args[0], args[1]); + gfc_add_expr_to_block (&se->pre, tmp); + + /* Free the temporary afterwards. */ + tmp = gfc_call_free (var); + gfc_add_expr_to_block (&se->post, tmp); + + se->expr = var; + se->string_length = args[0]; + + return; + } + /* Conversion from complex to non-complex involves taking the real component of the value. */ if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE @@ -319,7 +362,8 @@ build_round_expr (tree arg, tree restype) else gcc_unreachable (); - return fold_convert (restype, build_call_expr (fn, 1, arg)); + return fold_convert (restype, build_call_expr_loc (input_location, + fn, 1, arg)); } @@ -431,7 +475,8 @@ gfc_conv_intrinsic_aint (gfc_se * se, gfc_expr * expr, enum rounding_mode op) if (n != END_BUILTINS) { tmp = built_in_decls[n]; - se->expr = build_call_expr (tmp, 1, arg[0]); + se->expr = build_call_expr_loc (input_location, + tmp, 1, arg[0]); return; } @@ -445,11 +490,11 @@ gfc_conv_intrinsic_aint (gfc_se * se, gfc_expr * expr, enum rounding_mode op) mpfr_init (huge); n = gfc_validate_kind (BT_INTEGER, kind, false); mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE); - tmp = gfc_conv_mpfr_to_tree (huge, kind); + tmp = gfc_conv_mpfr_to_tree (huge, kind, 0); cond = fold_build2 (LT_EXPR, boolean_type_node, arg[0], tmp); mpfr_neg (huge, huge, GFC_RND_MODE); - tmp = gfc_conv_mpfr_to_tree (huge, kind); + tmp = gfc_conv_mpfr_to_tree (huge, kind, 0); tmp = fold_build2 (GT_EXPR, boolean_type_node, arg[0], tmp); cond = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, cond, tmp); itype = gfc_get_int_type (kind); @@ -471,7 +516,7 @@ gfc_conv_intrinsic_int (gfc_se * se, gfc_expr * expr, enum rounding_mode op) int nargs; nargs = gfc_intrinsic_argument_list_length (expr); - args = alloca (sizeof (tree) * nargs); + args = (tree *) alloca (sizeof (tree) * nargs); /* Evaluate the argument, we process all arguments even though we only use the first one for code generation purposes. */ @@ -649,7 +694,8 @@ gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t * m, gfc_expr * expr) } argtypes = gfc_chainon_list (argtypes, void_type_node); type = build_function_type (gfc_typenode_for_spec (ts), argtypes); - fndecl = build_decl (FUNCTION_DECL, get_identifier (name), type); + fndecl = build_decl (input_location, + FUNCTION_DECL, get_identifier (name), type); /* Mark the decl as external. */ DECL_EXTERNAL (fndecl) = 1; @@ -693,16 +739,45 @@ gfc_conv_intrinsic_lib_function (gfc_se * se, gfc_expr * expr) /* Get the decl and generate the call. */ num_args = gfc_intrinsic_argument_list_length (expr); - args = alloca (sizeof (tree) * num_args); + args = (tree *) alloca (sizeof (tree) * num_args); gfc_conv_intrinsic_function_args (se, expr, args, num_args); fndecl = gfc_get_intrinsic_lib_fndecl (m, expr); rettype = TREE_TYPE (TREE_TYPE (fndecl)); fndecl = build_addr (fndecl, current_function_decl); - se->expr = build_call_array (rettype, fndecl, num_args, args); + se->expr = build_call_array_loc (input_location, rettype, fndecl, num_args, args); +} + + +/* If bounds-checking is enabled, create code to verify at runtime that the + string lengths for both expressions are the same (needed for e.g. MERGE). + If bounds-checking is not enabled, does nothing. */ + +void +gfc_trans_same_strlen_check (const char* intr_name, locus* where, + tree a, tree b, stmtblock_t* target) +{ + tree cond; + tree name; + + /* If bounds-checking is disabled, do nothing. */ + if (!(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)) + return; + + /* Compare the two string lengths. */ + cond = fold_build2 (NE_EXPR, boolean_type_node, a, b); + + /* Output the runtime-check. */ + name = gfc_build_cstring_const (intr_name); + name = gfc_build_addr_expr (pchar_type_node, name); + gfc_trans_runtime_check (true, false, cond, target, where, + "Unequal character lengths (%ld/%ld) in %s", + fold_convert (long_integer_type_node, a), + fold_convert (long_integer_type_node, b), name); } + /* The EXPONENT(s) intrinsic function is translated into int ret; frexp (s, &ret); @@ -734,8 +809,9 @@ gfc_conv_intrinsic_exponent (gfc_se *se, gfc_expr *expr) gfc_conv_intrinsic_function_args (se, expr, &arg, 1); res = gfc_create_var (integer_type_node, NULL); - tmp = build_call_expr (built_in_decls[frexp], 2, arg, - build_fold_addr_expr (res)); + tmp = build_call_expr_loc (input_location, + built_in_decls[frexp], 2, arg, + gfc_build_addr_expr (NULL_TREE, res)); gfc_add_expr_to_block (&se->pre, tmp); type = gfc_typenode_for_spec (&expr->ts); @@ -754,13 +830,12 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper) tree type; tree bound; tree tmp; - tree cond, cond1, cond2, cond3, cond4, size; + tree cond, cond1, cond3, cond4, size; tree ubound; tree lbound; gfc_se argse; gfc_ss *ss; gfc_array_spec * as; - gfc_ref *ref; arg = expr->value.function.actual; arg2 = arg->next; @@ -813,7 +888,7 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper) } else { - if (flag_bounds_check) + if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) { bound = gfc_evaluate_now (bound, &se->pre); cond = fold_build2 (LT_EXPR, boolean_type_node, @@ -821,48 +896,15 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper) tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))]; tmp = fold_build2 (GE_EXPR, boolean_type_node, bound, tmp); cond = fold_build2 (TRUTH_ORIF_EXPR, boolean_type_node, cond, tmp); - gfc_trans_runtime_check (cond, &se->pre, &expr->where, gfc_msg_fault); + gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where, + gfc_msg_fault); } } - ubound = gfc_conv_descriptor_ubound (desc, bound); - lbound = gfc_conv_descriptor_lbound (desc, bound); + ubound = gfc_conv_descriptor_ubound_get (desc, bound); + lbound = gfc_conv_descriptor_lbound_get (desc, bound); - /* Follow any component references. */ - if (arg->expr->expr_type == EXPR_VARIABLE - || arg->expr->expr_type == EXPR_CONSTANT) - { - as = arg->expr->symtree->n.sym->as; - for (ref = arg->expr->ref; ref; ref = ref->next) - { - switch (ref->type) - { - case REF_COMPONENT: - as = ref->u.c.component->as; - continue; - - case REF_SUBSTRING: - continue; - - case REF_ARRAY: - { - switch (ref->u.ar.type) - { - case AR_ELEMENT: - case AR_SECTION: - case AR_UNKNOWN: - as = NULL; - continue; - - case AR_FULL: - break; - } - } - } - } - } - else - as = NULL; + as = gfc_get_full_arrayspec_from_expr (arg->expr); /* 13.14.53: Result value for LBOUND @@ -887,10 +929,9 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper) if (as) { - tree stride = gfc_conv_descriptor_stride (desc, bound); + tree stride = gfc_conv_descriptor_stride_get (desc, bound); cond1 = fold_build2 (GE_EXPR, boolean_type_node, ubound, lbound); - cond2 = fold_build2 (LE_EXPR, boolean_type_node, ubound, lbound); cond3 = fold_build2 (GE_EXPR, boolean_type_node, stride, gfc_index_zero_node); @@ -898,12 +939,17 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper) cond4 = fold_build2 (LT_EXPR, boolean_type_node, stride, gfc_index_zero_node); - cond4 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, cond4, cond2); if (upper) { + tree cond5; cond = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond3, cond4); + cond5 = fold_build2 (EQ_EXPR, boolean_type_node, gfc_index_one_node, lbound); + cond5 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, cond4, cond5); + + cond = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond, cond5); + se->expr = fold_build3 (COND_EXPR, gfc_array_index_type, cond, ubound, gfc_index_zero_node); } @@ -930,6 +976,8 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper) size = fold_build2 (MINUS_EXPR, gfc_array_index_type, ubound, lbound); se->expr = fold_build2 (PLUS_EXPR, gfc_array_index_type, size, gfc_index_one_node); + se->expr = fold_build2 (MAX_EXPR, gfc_array_index_type, se->expr, + gfc_index_zero_node); } else se->expr = gfc_index_one_node; @@ -971,7 +1019,8 @@ gfc_conv_intrinsic_abs (gfc_se * se, gfc_expr * expr) default: gcc_unreachable (); } - se->expr = build_call_expr (built_in_decls[n], 1, arg); + se->expr = build_call_expr_loc (input_location, + built_in_decls[n], 1, arg); break; default: @@ -992,7 +1041,7 @@ gfc_conv_intrinsic_cmplx (gfc_se * se, gfc_expr * expr, int both) unsigned int num_args; num_args = gfc_intrinsic_argument_list_length (expr); - args = alloca (sizeof (tree) * num_args); + args = (tree *) alloca (sizeof (tree) * num_args); type = gfc_typenode_for_spec (&expr->ts); gfc_conv_intrinsic_function_args (se, expr, args, num_args); @@ -1067,7 +1116,8 @@ gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo) if (n != END_BUILTINS) { tmp = build_addr (built_in_decls[n], current_function_decl); - se->expr = build_call_array (TREE_TYPE (TREE_TYPE (built_in_decls[n])), + se->expr = build_call_array_loc (input_location, + TREE_TYPE (TREE_TYPE (built_in_decls[n])), tmp, 2, args); if (modulo == 0) return; @@ -1116,11 +1166,11 @@ gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo) ikind = gfc_max_integer_kind; } mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE); - test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind); + test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind, 0); test2 = fold_build2 (LT_EXPR, boolean_type_node, tmp, test); mpfr_neg (huge, huge, GFC_RND_MODE); - test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind); + test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind, 0); test = fold_build2 (GT_EXPR, boolean_type_node, tmp, test); test2 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, test, test2); @@ -1180,22 +1230,42 @@ gfc_conv_intrinsic_sign (gfc_se * se, gfc_expr * expr) gfc_conv_intrinsic_function_args (se, expr, args, 2); if (expr->ts.type == BT_REAL) { + tree abs; + switch (expr->ts.kind) { case 4: tmp = built_in_decls[BUILT_IN_COPYSIGNF]; + abs = built_in_decls[BUILT_IN_FABSF]; break; case 8: tmp = built_in_decls[BUILT_IN_COPYSIGN]; + abs = built_in_decls[BUILT_IN_FABS]; break; case 10: case 16: tmp = built_in_decls[BUILT_IN_COPYSIGNL]; + abs = built_in_decls[BUILT_IN_FABSL]; break; default: gcc_unreachable (); } - se->expr = build_call_expr (tmp, 2, args[0], args[1]); + + /* We explicitly have to ignore the minus sign. We do so by using + result = (arg1 == 0) ? abs(arg0) : copysign(arg0, arg1). */ + if (!gfc_option.flag_sign_zero + && MODE_HAS_SIGNED_ZEROS (TYPE_MODE (TREE_TYPE (args[1])))) + { + tree cond, zero; + zero = build_real_from_int_cst (TREE_TYPE (args[1]), integer_zero_node); + cond = fold_build2 (EQ_EXPR, boolean_type_node, args[1], zero); + se->expr = fold_build3 (COND_EXPR, TREE_TYPE (args[0]), cond, + build_call_expr (abs, 1, args[0]), + build_call_expr (tmp, 2, args[0], args[1])); + } + else + se->expr = build_call_expr_loc (input_location, + tmp, 2, args[0], args[1]); return; } @@ -1258,19 +1328,19 @@ gfc_conv_intrinsic_dprod (gfc_se * se, gfc_expr * expr) static void gfc_conv_intrinsic_char (gfc_se * se, gfc_expr * expr) { - tree arg; + tree arg[2]; tree var; tree type; + unsigned int num_args; - gfc_conv_intrinsic_function_args (se, expr, &arg, 1); + num_args = gfc_intrinsic_argument_list_length (expr); + gfc_conv_intrinsic_function_args (se, expr, arg, num_args); - /* We currently don't support character types != 1. */ - gcc_assert (expr->ts.kind == 1); - type = gfc_character1_type_node; + type = gfc_get_char_type (expr->ts.kind); var = gfc_create_var (type, "char"); - arg = convert (type, arg); - gfc_add_modify_expr (&se->pre, var, arg); + arg[0] = fold_build1 (NOP_EXPR, type, arg[0]); + gfc_add_modify (&se->pre, var, arg[0]); se->expr = gfc_build_addr_expr (build_pointer_type (type), var); se->string_length = integer_one_node; } @@ -1282,26 +1352,24 @@ gfc_conv_intrinsic_ctime (gfc_se * se, gfc_expr * expr) tree var; tree len; tree tmp; - tree type; tree cond; - tree gfc_int8_type_node = gfc_get_int_type (8); tree fndecl; tree *args; unsigned int num_args; num_args = gfc_intrinsic_argument_list_length (expr) + 2; - args = alloca (sizeof (tree) * num_args); + args = (tree *) alloca (sizeof (tree) * num_args); - type = build_pointer_type (gfc_character1_type_node); - var = gfc_create_var (type, "pstr"); - len = gfc_create_var (gfc_int8_type_node, "len"); + var = gfc_create_var (pchar_type_node, "pstr"); + len = gfc_create_var (gfc_get_int_type (8), "len"); gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2); - args[0] = build_fold_addr_expr (var); - args[1] = build_fold_addr_expr (len); + args[0] = gfc_build_addr_expr (NULL_TREE, var); + args[1] = gfc_build_addr_expr (NULL_TREE, len); fndecl = build_addr (gfor_fndecl_ctime, current_function_decl); - tmp = build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_ctime)), + tmp = build_call_array_loc (input_location, + TREE_TYPE (TREE_TYPE (gfor_fndecl_ctime)), fndecl, num_args, args); gfc_add_expr_to_block (&se->pre, tmp); @@ -1309,7 +1377,7 @@ gfc_conv_intrinsic_ctime (gfc_se * se, gfc_expr * expr) cond = fold_build2 (GT_EXPR, boolean_type_node, len, build_int_cst (TREE_TYPE (len), 0)); tmp = gfc_call_free (var); - tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ()); + tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location)); gfc_add_expr_to_block (&se->post, tmp); se->expr = var; @@ -1323,26 +1391,24 @@ gfc_conv_intrinsic_fdate (gfc_se * se, gfc_expr * expr) tree var; tree len; tree tmp; - tree type; tree cond; - tree gfc_int4_type_node = gfc_get_int_type (4); tree fndecl; tree *args; unsigned int num_args; num_args = gfc_intrinsic_argument_list_length (expr) + 2; - args = alloca (sizeof (tree) * num_args); + args = (tree *) alloca (sizeof (tree) * num_args); - type = build_pointer_type (gfc_character1_type_node); - var = gfc_create_var (type, "pstr"); - len = gfc_create_var (gfc_int4_type_node, "len"); + var = gfc_create_var (pchar_type_node, "pstr"); + len = gfc_create_var (gfc_get_int_type (4), "len"); gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2); - args[0] = build_fold_addr_expr (var); - args[1] = build_fold_addr_expr (len); + args[0] = gfc_build_addr_expr (NULL_TREE, var); + args[1] = gfc_build_addr_expr (NULL_TREE, len); fndecl = build_addr (gfor_fndecl_fdate, current_function_decl); - tmp = build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_fdate)), + tmp = build_call_array_loc (input_location, + TREE_TYPE (TREE_TYPE (gfor_fndecl_fdate)), fndecl, num_args, args); gfc_add_expr_to_block (&se->pre, tmp); @@ -1350,7 +1416,7 @@ gfc_conv_intrinsic_fdate (gfc_se * se, gfc_expr * expr) cond = fold_build2 (GT_EXPR, boolean_type_node, len, build_int_cst (TREE_TYPE (len), 0)); tmp = gfc_call_free (var); - tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ()); + tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location)); gfc_add_expr_to_block (&se->post, tmp); se->expr = var; @@ -1366,26 +1432,24 @@ gfc_conv_intrinsic_ttynam (gfc_se * se, gfc_expr * expr) tree var; tree len; tree tmp; - tree type; tree cond; tree fndecl; - tree gfc_int4_type_node = gfc_get_int_type (4); tree *args; unsigned int num_args; num_args = gfc_intrinsic_argument_list_length (expr) + 2; - args = alloca (sizeof (tree) * num_args); + args = (tree *) alloca (sizeof (tree) * num_args); - type = build_pointer_type (gfc_character1_type_node); - var = gfc_create_var (type, "pstr"); - len = gfc_create_var (gfc_int4_type_node, "len"); + var = gfc_create_var (pchar_type_node, "pstr"); + len = gfc_create_var (gfc_get_int_type (4), "len"); gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2); - args[0] = build_fold_addr_expr (var); - args[1] = build_fold_addr_expr (len); + args[0] = gfc_build_addr_expr (NULL_TREE, var); + args[1] = gfc_build_addr_expr (NULL_TREE, len); fndecl = build_addr (gfor_fndecl_ttynam, current_function_decl); - tmp = build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_ttynam)), + tmp = build_call_array_loc (input_location, + TREE_TYPE (TREE_TYPE (gfor_fndecl_ttynam)), fndecl, num_args, args); gfc_add_expr_to_block (&se->pre, tmp); @@ -1393,7 +1457,7 @@ gfc_conv_intrinsic_ttynam (gfc_se * se, gfc_expr * expr) cond = fold_build2 (GT_EXPR, boolean_type_node, len, build_int_cst (TREE_TYPE (len), 0)); tmp = gfc_call_free (var); - tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ()); + tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location)); gfc_add_expr_to_block (&se->post, tmp); se->expr = var; @@ -1417,7 +1481,7 @@ gfc_conv_intrinsic_ttynam (gfc_se * se, gfc_expr * expr) /* TODO: Mismatching types can occur when specific names are used. These should be handled during resolution. */ static void -gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, int op) +gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, enum tree_code op) { tree tmp; tree mvar; @@ -1429,7 +1493,7 @@ gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, int op) unsigned int i, nargs; nargs = gfc_intrinsic_argument_list_length (expr); - args = alloca (sizeof (tree) * nargs); + args = (tree *) alloca (sizeof (tree) * nargs); gfc_conv_intrinsic_function_args (se, expr, args, nargs); type = gfc_typenode_for_spec (&expr->ts); @@ -1442,7 +1506,7 @@ gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, int op) args[0] = gfc_evaluate_now (args[0], &se->pre); mvar = gfc_create_var (type, "M"); - gfc_add_modify_expr (&se->pre, mvar, args[0]); + gfc_add_modify (&se->pre, mvar, args[0]); for (i = 1, argexpr = argexpr->next; i < nargs; i++) { tree cond, isnan; @@ -1453,9 +1517,10 @@ gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, int op) if (argexpr->expr->expr_type == EXPR_VARIABLE && argexpr->expr->symtree->n.sym->attr.optional && TREE_CODE (val) == INDIRECT_REF) - cond = fold_build2 - (NE_EXPR, boolean_type_node, TREE_OPERAND (val, 0), - build_int_cst (TREE_TYPE (TREE_OPERAND (val, 0)), 0)); + cond = fold_build2_loc (input_location, + NE_EXPR, boolean_type_node, + TREE_OPERAND (val, 0), + build_int_cst (TREE_TYPE (TREE_OPERAND (val, 0)), 0)); else { cond = NULL_TREE; @@ -1474,14 +1539,17 @@ gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, int op) to help performance of programs that don't rely on IEEE semantics. */ if (FLOAT_TYPE_P (TREE_TYPE (mvar))) { - isnan = build_call_expr (built_in_decls[BUILT_IN_ISNAN], 1, mvar); + isnan = build_call_expr_loc (input_location, + built_in_decls[BUILT_IN_ISNAN], 1, mvar); tmp = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, tmp, fold_convert (boolean_type_node, isnan)); } - tmp = build3_v (COND_EXPR, tmp, thencase, build_empty_stmt ()); + tmp = build3_v (COND_EXPR, tmp, thencase, + build_empty_stmt (input_location)); if (cond != NULL_TREE) - tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ()); + tmp = build3_v (COND_EXPR, cond, tmp, + build_empty_stmt (input_location)); gfc_add_expr_to_block (&se->pre, tmp); argexpr = argexpr->next; @@ -1496,32 +1564,40 @@ static void gfc_conv_intrinsic_minmax_char (gfc_se * se, gfc_expr * expr, int op) { tree *args; - tree var, len, fndecl, tmp, cond; + tree var, len, fndecl, tmp, cond, function; unsigned int nargs; nargs = gfc_intrinsic_argument_list_length (expr); - args = alloca (sizeof (tree) * (nargs + 4)); + args = (tree *) alloca (sizeof (tree) * (nargs + 4)); gfc_conv_intrinsic_function_args (se, expr, &args[4], nargs); /* Create the result variables. */ len = gfc_create_var (gfc_charlen_type_node, "len"); - args[0] = build_fold_addr_expr (len); - var = gfc_create_var (build_pointer_type (gfc_character1_type_node), "pstr"); + args[0] = gfc_build_addr_expr (NULL_TREE, len); + var = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), "pstr"); args[1] = gfc_build_addr_expr (ppvoid_type_node, var); args[2] = build_int_cst (NULL_TREE, op); args[3] = build_int_cst (NULL_TREE, nargs / 2); + if (expr->ts.kind == 1) + function = gfor_fndecl_string_minmax; + else if (expr->ts.kind == 4) + function = gfor_fndecl_string_minmax_char4; + else + gcc_unreachable (); + /* Make the function call. */ - fndecl = build_addr (gfor_fndecl_string_minmax, current_function_decl); - tmp = build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_string_minmax)), - fndecl, nargs + 4, args); + fndecl = build_addr (function, current_function_decl); + tmp = build_call_array_loc (input_location, + TREE_TYPE (TREE_TYPE (function)), fndecl, + nargs + 4, args); gfc_add_expr_to_block (&se->pre, tmp); /* Free the temporary afterwards, if necessary. */ cond = fold_build2 (GT_EXPR, boolean_type_node, len, build_int_cst (TREE_TYPE (len), 0)); tmp = gfc_call_free (var); - tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ()); + tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location)); gfc_add_expr_to_block (&se->post, tmp); se->expr = var; @@ -1622,7 +1698,8 @@ gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr) } } - gfc_conv_function_call (se, sym, expr->value.function.actual, append_args); + gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr, + append_args); gfc_free (sym); } @@ -1646,7 +1723,7 @@ gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr) } */ static void -gfc_conv_intrinsic_anyall (gfc_se * se, gfc_expr * expr, int op) +gfc_conv_intrinsic_anyall (gfc_se * se, gfc_expr * expr, enum tree_code op) { tree resvar; stmtblock_t block; @@ -1674,7 +1751,7 @@ gfc_conv_intrinsic_anyall (gfc_se * se, gfc_expr * expr, int op) tmp = convert (type, boolean_true_node); else tmp = convert (type, boolean_false_node); - gfc_add_modify_expr (&se->pre, resvar, tmp); + gfc_add_modify (&se->pre, resvar, tmp); /* Walk the arguments. */ arrayss = gfc_walk_expr (actual->expr); @@ -1688,7 +1765,7 @@ gfc_conv_intrinsic_anyall (gfc_se * se, gfc_expr * expr, int op) /* Initialize the loop. */ gfc_conv_ss_startstride (&loop); - gfc_conv_loop_setup (&loop); + gfc_conv_loop_setup (&loop, &expr->where); gfc_mark_ss_chain_used (arrayss, 1); /* Generate the loop body. */ @@ -1700,7 +1777,7 @@ gfc_conv_intrinsic_anyall (gfc_se * se, gfc_expr * expr, int op) tmp = convert (type, boolean_false_node); else tmp = convert (type, boolean_true_node); - gfc_add_modify_expr (&block, resvar, tmp); + gfc_add_modify (&block, resvar, tmp); /* And break out of the loop. */ tmp = build1_v (GOTO_EXPR, exit_label); @@ -1717,7 +1794,7 @@ gfc_conv_intrinsic_anyall (gfc_se * se, gfc_expr * expr, int op) gfc_add_block_to_block (&body, &arrayse.pre); tmp = fold_build2 (op, boolean_type_node, arrayse.expr, build_int_cst (TREE_TYPE (arrayse.expr), 0)); - tmp = build3_v (COND_EXPR, tmp, found, build_empty_stmt ()); + tmp = build3_v (COND_EXPR, tmp, found, build_empty_stmt (input_location)); gfc_add_expr_to_block (&body, tmp); gfc_add_block_to_block (&body, &arrayse.post); @@ -1758,7 +1835,7 @@ gfc_conv_intrinsic_count (gfc_se * se, gfc_expr * expr) type = gfc_typenode_for_spec (&expr->ts); /* Initialize the result. */ resvar = gfc_create_var (type, "count"); - gfc_add_modify_expr (&se->pre, resvar, build_int_cst (type, 0)); + gfc_add_modify (&se->pre, resvar, build_int_cst (type, 0)); /* Walk the arguments. */ arrayss = gfc_walk_expr (actual->expr); @@ -1770,7 +1847,7 @@ gfc_conv_intrinsic_count (gfc_se * se, gfc_expr * expr) /* Initialize the loop. */ gfc_conv_ss_startstride (&loop); - gfc_conv_loop_setup (&loop); + gfc_conv_loop_setup (&loop, &expr->where); gfc_mark_ss_chain_used (arrayss, 1); /* Generate the loop body. */ @@ -1784,7 +1861,8 @@ gfc_conv_intrinsic_count (gfc_se * se, gfc_expr * expr) gfc_copy_loopinfo_to_se (&arrayse, &loop); arrayse.ss = arrayss; gfc_conv_expr_val (&arrayse, actual->expr); - tmp = build3_v (COND_EXPR, arrayse.expr, tmp, build_empty_stmt ()); + tmp = build3_v (COND_EXPR, arrayse.expr, tmp, + build_empty_stmt (input_location)); gfc_add_block_to_block (&body, &arrayse.pre); gfc_add_expr_to_block (&body, tmp); @@ -1801,7 +1879,7 @@ gfc_conv_intrinsic_count (gfc_se * se, gfc_expr * expr) /* Inline implementation of the sum and product intrinsics. */ static void -gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, int op) +gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, enum tree_code op) { tree resvar; tree type; @@ -1831,7 +1909,7 @@ gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, int op) else tmp = gfc_build_const (type, integer_one_node); - gfc_add_modify_expr (&se->pre, resvar, tmp); + gfc_add_modify (&se->pre, resvar, tmp); /* Walk the arguments. */ actual = expr->value.function.actual; @@ -1858,7 +1936,7 @@ gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, int op) /* Initialize the loop. */ gfc_conv_ss_startstride (&loop); - gfc_conv_loop_setup (&loop); + gfc_conv_loop_setup (&loop, &expr->where); gfc_mark_ss_chain_used (arrayss, 1); if (maskss) @@ -1888,7 +1966,7 @@ gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, int op) gfc_add_block_to_block (&block, &arrayse.pre); tmp = fold_build2 (op, type, resvar, arrayse.expr); - gfc_add_modify_expr (&block, resvar, tmp); + gfc_add_modify (&block, resvar, tmp); gfc_add_block_to_block (&block, &arrayse.post); if (maskss) @@ -1896,7 +1974,8 @@ gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, int op) /* We enclose the above in if (mask) {...} . */ tmp = gfc_finish_block (&block); - tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ()); + tmp = build3_v (COND_EXPR, maskse.expr, tmp, + build_empty_stmt (input_location)); } else tmp = gfc_finish_block (&block); @@ -1914,7 +1993,8 @@ gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, int op) gfc_add_block_to_block (&block, &loop.post); tmp = gfc_finish_block (&block); - tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ()); + tmp = build3_v (COND_EXPR, maskse.expr, tmp, + build_empty_stmt (input_location)); gfc_add_expr_to_block (&block, tmp); gfc_add_block_to_block (&se->pre, &block); } @@ -1955,7 +2035,7 @@ gfc_conv_intrinsic_dot_product (gfc_se * se, gfc_expr * expr) else tmp = gfc_build_const (type, integer_zero_node); - gfc_add_modify_expr (&se->pre, resvar, tmp); + gfc_add_modify (&se->pre, resvar, tmp); /* Walk argument #1. */ actual = expr->value.function.actual; @@ -1976,7 +2056,7 @@ gfc_conv_intrinsic_dot_product (gfc_se * se, gfc_expr * expr) /* Initialize the loop. */ gfc_conv_ss_startstride (&loop); - gfc_conv_loop_setup (&loop); + gfc_conv_loop_setup (&loop, &expr->where); gfc_mark_ss_chain_used (arrayss1, 1); gfc_mark_ss_chain_used (arrayss2, 1); @@ -2012,7 +2092,7 @@ gfc_conv_intrinsic_dot_product (gfc_se * se, gfc_expr * expr) tmp = fold_build2 (MULT_EXPR, type, arrayse1.expr, arrayse2.expr); tmp = fold_build2 (PLUS_EXPR, type, resvar, tmp); } - gfc_add_modify_expr (&block, resvar, tmp); + gfc_add_modify (&block, resvar, tmp); /* Finish up the loop block and the loop. */ tmp = gfc_finish_block (&block); @@ -2027,8 +2107,74 @@ gfc_conv_intrinsic_dot_product (gfc_se * se, gfc_expr * expr) } +/* Emit code for minloc or maxloc intrinsic. There are many different cases + we need to handle. For performance reasons we sometimes create two + loops instead of one, where the second one is much simpler. + Examples for minloc intrinsic: + 1) Result is an array, a call is generated + 2) Array mask is used and NaNs need to be supported: + limit = Infinity; + pos = 0; + S = from; + while (S <= to) { + if (mask[S]) { + if (pos == 0) pos = S + (1 - from); + if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; } + } + S++; + } + goto lab2; + lab1:; + while (S <= to) { + if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); } + S++; + } + lab2:; + 3) NaNs need to be supported, but it is known at compile time or cheaply + at runtime whether array is nonempty or not: + limit = Infinity; + pos = 0; + S = from; + while (S <= to) { + if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; } + S++; + } + if (from <= to) pos = 1; + goto lab2; + lab1:; + while (S <= to) { + if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); } + S++; + } + lab2:; + 4) NaNs aren't supported, array mask is used: + limit = infinities_supported ? Infinity : huge (limit); + pos = 0; + S = from; + while (S <= to) { + if (mask[S]) { limit = a[S]; pos = S + (1 - from); goto lab1; } + S++; + } + goto lab2; + lab1:; + while (S <= to) { + if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); } + S++; + } + lab2:; + 5) Same without array mask: + limit = infinities_supported ? Infinity : huge (limit); + pos = (from <= to) ? 1 : 0; + S = from; + while (S <= to) { + if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); } + S++; + } + For 3) and 5), if mask is scalar, this all goes into a conditional, + setting pos = 0; in the else branch. */ + static void -gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, int op) +gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) { stmtblock_t body; stmtblock_t block; @@ -2037,9 +2183,12 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, int op) tree limit; tree type; tree tmp; + tree cond; tree elsetmp; tree ifbody; tree offset; + tree nonempty; + tree lab1, lab2; gfc_loopinfo loop; gfc_actual_arglist *actual; gfc_ss *arrayss; @@ -2071,20 +2220,39 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, int op) actual = actual->next->next; gcc_assert (actual); maskexpr = actual->expr; + nonempty = NULL; if (maskexpr && maskexpr->rank != 0) { maskss = gfc_walk_expr (maskexpr); gcc_assert (maskss != gfc_ss_terminator); } else - maskss = NULL; + { + mpz_t asize; + if (gfc_array_size (arrayexpr, &asize) == SUCCESS) + { + nonempty = gfc_conv_mpz_to_tree (asize, gfc_index_integer_kind); + mpz_clear (asize); + nonempty = fold_build2 (GT_EXPR, boolean_type_node, nonempty, + gfc_index_zero_node); + } + maskss = NULL; + } limit = gfc_create_var (gfc_typenode_for_spec (&arrayexpr->ts), "limit"); n = gfc_validate_kind (arrayexpr->ts.type, arrayexpr->ts.kind, false); switch (arrayexpr->ts.type) { case BT_REAL: - tmp = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge, arrayexpr->ts.kind); + if (HONOR_INFINITIES (DECL_MODE (limit))) + { + REAL_VALUE_TYPE real; + real_inf (&real); + tmp = build_real (TREE_TYPE (limit), real); + } + else + tmp = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge, + arrayexpr->ts.kind, 0); break; case BT_INTEGER: @@ -2102,12 +2270,12 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, int op) possible value is HUGE in both cases. */ if (op == GT_EXPR) tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp); - gfc_add_modify_expr (&se->pre, limit, tmp); - if (op == GT_EXPR && expr->ts.type == BT_INTEGER) tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (tmp), tmp, build_int_cst (type, 1)); + gfc_add_modify (&se->pre, limit, tmp); + /* Initialize the scalarizer. */ gfc_init_loopinfo (&loop); gfc_add_ss_to_loop (&loop, arrayss); @@ -2116,14 +2284,33 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, int op) /* Initialize the loop. */ gfc_conv_ss_startstride (&loop); - gfc_conv_loop_setup (&loop); + gfc_conv_loop_setup (&loop, &expr->where); gcc_assert (loop.dimen == 1); + if (nonempty == NULL && maskss == NULL && loop.from[0] && loop.to[0]) + nonempty = fold_build2 (LE_EXPR, boolean_type_node, loop.from[0], + loop.to[0]); + lab1 = NULL; + lab2 = NULL; /* Initialize the position to zero, following Fortran 2003. We are free to do this because Fortran 95 allows the result of an entirely false - mask to be processor dependent. */ - gfc_add_modify_expr (&loop.pre, pos, gfc_index_zero_node); + mask to be processor dependent. If we know at compile time the array + is non-empty and no MASK is used, we can initialize to 1 to simplify + the inner loop. */ + if (nonempty != NULL && !HONOR_NANS (DECL_MODE (limit))) + gfc_add_modify (&loop.pre, pos, + fold_build3 (COND_EXPR, gfc_array_index_type, + nonempty, gfc_index_one_node, + gfc_index_zero_node)); + else + { + gfc_add_modify (&loop.pre, pos, gfc_index_zero_node); + lab1 = gfc_build_label_decl (NULL_TREE); + TREE_USED (lab1) = 1; + lab2 = gfc_build_label_decl (NULL_TREE); + TREE_USED (lab2) = 1; + } gfc_mark_ss_chain_used (arrayss, 1); if (maskss) @@ -2156,49 +2343,158 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, int op) gfc_start_block (&ifblock); /* Assign the value to the limit... */ - gfc_add_modify_expr (&ifblock, limit, arrayse.expr); + gfc_add_modify (&ifblock, limit, arrayse.expr); /* Remember where we are. An offset must be added to the loop counter to obtain the required position. */ - if (loop.temp_dim) - tmp = build_int_cst (gfc_array_index_type, 1); + if (loop.from[0]) + tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, + gfc_index_one_node, loop.from[0]); else - tmp =fold_build2 (MINUS_EXPR, gfc_array_index_type, - gfc_index_one_node, loop.from[0]); - gfc_add_modify_expr (&block, offset, tmp); + tmp = gfc_index_one_node; + + gfc_add_modify (&block, offset, tmp); + + if (nonempty == NULL && HONOR_NANS (DECL_MODE (limit))) + { + stmtblock_t ifblock2; + tree ifbody2; + + gfc_start_block (&ifblock2); + tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (pos), + loop.loopvar[0], offset); + gfc_add_modify (&ifblock2, pos, tmp); + ifbody2 = gfc_finish_block (&ifblock2); + cond = fold_build2 (EQ_EXPR, boolean_type_node, pos, + gfc_index_zero_node); + tmp = build3_v (COND_EXPR, cond, ifbody2, + build_empty_stmt (input_location)); + gfc_add_expr_to_block (&block, tmp); + } tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (pos), loop.loopvar[0], offset); - gfc_add_modify_expr (&ifblock, pos, tmp); + gfc_add_modify (&ifblock, pos, tmp); + + if (lab1) + gfc_add_expr_to_block (&ifblock, build1_v (GOTO_EXPR, lab1)); ifbody = gfc_finish_block (&ifblock); - /* If it is a more extreme value or pos is still zero and the value - equal to the limit. */ - tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, - fold_build2 (EQ_EXPR, boolean_type_node, - pos, gfc_index_zero_node), - fold_build2 (EQ_EXPR, boolean_type_node, - arrayse.expr, limit)); - tmp = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, - fold_build2 (op, boolean_type_node, - arrayse.expr, limit), tmp); - tmp = build3_v (COND_EXPR, tmp, ifbody, build_empty_stmt ()); - gfc_add_expr_to_block (&block, tmp); + if (!lab1 || HONOR_NANS (DECL_MODE (limit))) + { + if (lab1) + cond = fold_build2 (op == GT_EXPR ? GE_EXPR : LE_EXPR, + boolean_type_node, arrayse.expr, limit); + else + cond = fold_build2 (op, boolean_type_node, arrayse.expr, limit); + + ifbody = build3_v (COND_EXPR, cond, ifbody, + build_empty_stmt (input_location)); + } + gfc_add_expr_to_block (&block, ifbody); if (maskss) { /* We enclose the above in if (mask) {...}. */ tmp = gfc_finish_block (&block); - tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ()); + tmp = build3_v (COND_EXPR, maskse.expr, tmp, + build_empty_stmt (input_location)); } else tmp = gfc_finish_block (&block); gfc_add_expr_to_block (&body, tmp); + if (lab1) + { + gfc_trans_scalarized_loop_end (&loop, 0, &body); + + if (HONOR_NANS (DECL_MODE (limit))) + { + if (nonempty != NULL) + { + ifbody = build2_v (MODIFY_EXPR, pos, gfc_index_one_node); + tmp = build3_v (COND_EXPR, nonempty, ifbody, + build_empty_stmt (input_location)); + gfc_add_expr_to_block (&loop.code[0], tmp); + } + } + + gfc_add_expr_to_block (&loop.code[0], build1_v (GOTO_EXPR, lab2)); + gfc_add_expr_to_block (&loop.code[0], build1_v (LABEL_EXPR, lab1)); + gfc_start_block (&body); + + /* If we have a mask, only check this element if the mask is set. */ + if (maskss) + { + gfc_init_se (&maskse, NULL); + gfc_copy_loopinfo_to_se (&maskse, &loop); + maskse.ss = maskss; + gfc_conv_expr_val (&maskse, maskexpr); + gfc_add_block_to_block (&body, &maskse.pre); + + gfc_start_block (&block); + } + else + gfc_init_block (&block); + + /* Compare with the current limit. */ + gfc_init_se (&arrayse, NULL); + gfc_copy_loopinfo_to_se (&arrayse, &loop); + arrayse.ss = arrayss; + gfc_conv_expr_val (&arrayse, arrayexpr); + gfc_add_block_to_block (&block, &arrayse.pre); + + /* We do the following if this is a more extreme value. */ + gfc_start_block (&ifblock); + + /* Assign the value to the limit... */ + gfc_add_modify (&ifblock, limit, arrayse.expr); + + /* Remember where we are. An offset must be added to the loop + counter to obtain the required position. */ + if (loop.from[0]) + tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, + gfc_index_one_node, loop.from[0]); + else + tmp = gfc_index_one_node; + + gfc_add_modify (&block, offset, tmp); + + tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (pos), + loop.loopvar[0], offset); + gfc_add_modify (&ifblock, pos, tmp); + + ifbody = gfc_finish_block (&ifblock); + + cond = fold_build2 (op, boolean_type_node, arrayse.expr, limit); + + tmp = build3_v (COND_EXPR, cond, ifbody, + build_empty_stmt (input_location)); + gfc_add_expr_to_block (&block, tmp); + + if (maskss) + { + /* We enclose the above in if (mask) {...}. */ + tmp = gfc_finish_block (&block); + + tmp = build3_v (COND_EXPR, maskse.expr, tmp, + build_empty_stmt (input_location)); + } + else + tmp = gfc_finish_block (&block); + gfc_add_expr_to_block (&body, tmp); + /* Avoid initializing loopvar[0] again, it should be left where + it finished by the first loop. */ + loop.from[0] = loop.loopvar[0]; + } + gfc_trans_scalarizing_loops (&loop, &body); + if (lab2) + gfc_add_expr_to_block (&loop.pre, build1_v (LABEL_EXPR, lab2)); + /* For a scalar mask, enclose the loop in an if statement. */ if (maskexpr && maskss == NULL) { @@ -2213,7 +2509,7 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, int op) the pos variable the same way as above. */ gfc_init_block (&elseblock); - gfc_add_modify_expr (&elseblock, pos, gfc_index_zero_node); + gfc_add_modify (&elseblock, pos, gfc_index_zero_node); elsetmp = gfc_finish_block (&elseblock); tmp = build3_v (COND_EXPR, maskse.expr, tmp, elsetmp); @@ -2230,15 +2526,113 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, int op) se->expr = convert (type, pos); } +/* Emit code for minval or maxval intrinsic. There are many different cases + we need to handle. For performance reasons we sometimes create two + loops instead of one, where the second one is much simpler. + Examples for minval intrinsic: + 1) Result is an array, a call is generated + 2) Array mask is used and NaNs need to be supported, rank 1: + limit = Infinity; + nonempty = false; + S = from; + while (S <= to) { + if (mask[S]) { nonempty = true; if (a[S] <= limit) goto lab; } + S++; + } + limit = nonempty ? NaN : huge (limit); + lab: + while (S <= to) { if(mask[S]) limit = min (a[S], limit); S++; } + 3) NaNs need to be supported, but it is known at compile time or cheaply + at runtime whether array is nonempty or not, rank 1: + limit = Infinity; + S = from; + while (S <= to) { if (a[S] <= limit) goto lab; S++; } + limit = (from <= to) ? NaN : huge (limit); + lab: + while (S <= to) { limit = min (a[S], limit); S++; } + 4) Array mask is used and NaNs need to be supported, rank > 1: + limit = Infinity; + nonempty = false; + fast = false; + S1 = from1; + while (S1 <= to1) { + S2 = from2; + while (S2 <= to2) { + if (mask[S1][S2]) { + if (fast) limit = min (a[S1][S2], limit); + else { + nonempty = true; + if (a[S1][S2] <= limit) { + limit = a[S1][S2]; + fast = true; + } + } + } + S2++; + } + S1++; + } + if (!fast) + limit = nonempty ? NaN : huge (limit); + 5) NaNs need to be supported, but it is known at compile time or cheaply + at runtime whether array is nonempty or not, rank > 1: + limit = Infinity; + fast = false; + S1 = from1; + while (S1 <= to1) { + S2 = from2; + while (S2 <= to2) { + if (fast) limit = min (a[S1][S2], limit); + else { + if (a[S1][S2] <= limit) { + limit = a[S1][S2]; + fast = true; + } + } + S2++; + } + S1++; + } + if (!fast) + limit = (nonempty_array) ? NaN : huge (limit); + 6) NaNs aren't supported, but infinities are. Array mask is used: + limit = Infinity; + nonempty = false; + S = from; + while (S <= to) { + if (mask[S]) { nonempty = true; limit = min (a[S], limit); } + S++; + } + limit = nonempty ? limit : huge (limit); + 7) Same without array mask: + limit = Infinity; + S = from; + while (S <= to) { limit = min (a[S], limit); S++; } + limit = (from <= to) ? limit : huge (limit); + 8) Neither NaNs nor infinities are supported (-ffast-math or BT_INTEGER): + limit = huge (limit); + S = from; + while (S <= to) { limit = min (a[S], limit); S++); } + (or + while (S <= to) { if (mask[S]) limit = min (a[S], limit); S++; } + with array mask instead). + For 3), 5), 7) and 8), if mask is scalar, this all goes into a conditional, + setting limit = huge (limit); in the else branch. */ + static void -gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, int op) +gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op) { tree limit; tree type; tree tmp; tree ifbody; + tree nonempty; + tree nonempty_var; + tree lab; + tree fast; + tree huge_cst = NULL, nan_cst = NULL; stmtblock_t body; - stmtblock_t block; + stmtblock_t block, block2; gfc_loopinfo loop; gfc_actual_arglist *actual; gfc_ss *arrayss; @@ -2262,7 +2656,22 @@ gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, int op) switch (expr->ts.type) { case BT_REAL: - tmp = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge, expr->ts.kind); + huge_cst = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge, + expr->ts.kind, 0); + if (HONOR_INFINITIES (DECL_MODE (limit))) + { + REAL_VALUE_TYPE real; + real_inf (&real); + tmp = build_real (type, real); + } + else + tmp = huge_cst; + if (HONOR_NANS (DECL_MODE (limit))) + { + REAL_VALUE_TYPE real; + real_nan (&real, "", 1, DECL_MODE (limit)); + nan_cst = build_real (type, real); + } break; case BT_INTEGER: @@ -2278,13 +2687,17 @@ gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, int op) -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive possible value is HUGE in both cases. */ if (op == GT_EXPR) - tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp); + { + tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp); + if (huge_cst) + huge_cst = fold_build1 (NEGATE_EXPR, TREE_TYPE (huge_cst), huge_cst); + } if (op == GT_EXPR && expr->ts.type == BT_INTEGER) tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (tmp), tmp, build_int_cst (type, 1)); - gfc_add_modify_expr (&se->pre, limit, tmp); + gfc_add_modify (&se->pre, limit, tmp); /* Walk the arguments. */ actual = expr->value.function.actual; @@ -2295,13 +2708,24 @@ gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, int op) actual = actual->next->next; gcc_assert (actual); maskexpr = actual->expr; + nonempty = NULL; if (maskexpr && maskexpr->rank != 0) { maskss = gfc_walk_expr (maskexpr); gcc_assert (maskss != gfc_ss_terminator); } else - maskss = NULL; + { + mpz_t asize; + if (gfc_array_size (arrayexpr, &asize) == SUCCESS) + { + nonempty = gfc_conv_mpz_to_tree (asize, gfc_index_integer_kind); + mpz_clear (asize); + nonempty = fold_build2 (GT_EXPR, boolean_type_node, nonempty, + gfc_index_zero_node); + } + maskss = NULL; + } /* Initialize the scalarizer. */ gfc_init_loopinfo (&loop); @@ -2311,7 +2735,36 @@ gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, int op) /* Initialize the loop. */ gfc_conv_ss_startstride (&loop); - gfc_conv_loop_setup (&loop); + gfc_conv_loop_setup (&loop, &expr->where); + + if (nonempty == NULL && maskss == NULL + && loop.dimen == 1 && loop.from[0] && loop.to[0]) + nonempty = fold_build2 (LE_EXPR, boolean_type_node, loop.from[0], + loop.to[0]); + nonempty_var = NULL; + if (nonempty == NULL + && (HONOR_INFINITIES (DECL_MODE (limit)) + || HONOR_NANS (DECL_MODE (limit)))) + { + nonempty_var = gfc_create_var (boolean_type_node, "nonempty"); + gfc_add_modify (&se->pre, nonempty_var, boolean_false_node); + nonempty = nonempty_var; + } + lab = NULL; + fast = NULL; + if (HONOR_NANS (DECL_MODE (limit))) + { + if (loop.dimen == 1) + { + lab = gfc_build_label_decl (NULL_TREE); + TREE_USED (lab) = 1; + } + else + { + fast = gfc_create_var (boolean_type_node, "fast"); + gfc_add_modify (&se->pre, fast, boolean_false_node); + } + } gfc_mark_ss_chain_used (arrayss, 1); if (maskss) @@ -2340,26 +2793,167 @@ gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, int op) gfc_conv_expr_val (&arrayse, arrayexpr); gfc_add_block_to_block (&block, &arrayse.pre); - /* Assign the value to the limit... */ - ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr); + gfc_init_block (&block2); + + if (nonempty_var) + gfc_add_modify (&block2, nonempty_var, boolean_true_node); + + if (HONOR_NANS (DECL_MODE (limit))) + { + tmp = fold_build2 (op == GT_EXPR ? GE_EXPR : LE_EXPR, + boolean_type_node, arrayse.expr, limit); + if (lab) + ifbody = build1_v (GOTO_EXPR, lab); + else + { + stmtblock_t ifblock; + + gfc_init_block (&ifblock); + gfc_add_modify (&ifblock, limit, arrayse.expr); + gfc_add_modify (&ifblock, fast, boolean_true_node); + ifbody = gfc_finish_block (&ifblock); + } + tmp = build3_v (COND_EXPR, tmp, ifbody, + build_empty_stmt (input_location)); + gfc_add_expr_to_block (&block2, tmp); + } + else + { + /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or + signed zeros. */ + if (HONOR_SIGNED_ZEROS (DECL_MODE (limit))) + { + tmp = fold_build2 (op, boolean_type_node, arrayse.expr, limit); + ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr); + tmp = build3_v (COND_EXPR, tmp, ifbody, + build_empty_stmt (input_location)); + gfc_add_expr_to_block (&block2, tmp); + } + else + { + tmp = fold_build2 (op == GT_EXPR ? MAX_EXPR : MIN_EXPR, + type, arrayse.expr, limit); + gfc_add_modify (&block2, limit, tmp); + } + } + + if (fast) + { + tree elsebody = gfc_finish_block (&block2); + + /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or + signed zeros. */ + if (HONOR_NANS (DECL_MODE (limit)) + || HONOR_SIGNED_ZEROS (DECL_MODE (limit))) + { + tmp = fold_build2 (op, boolean_type_node, arrayse.expr, limit); + ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr); + ifbody = build3_v (COND_EXPR, tmp, ifbody, + build_empty_stmt (input_location)); + } + else + { + tmp = fold_build2 (op == GT_EXPR ? MAX_EXPR : MIN_EXPR, + type, arrayse.expr, limit); + ifbody = build2_v (MODIFY_EXPR, limit, tmp); + } + tmp = build3_v (COND_EXPR, fast, ifbody, elsebody); + gfc_add_expr_to_block (&block, tmp); + } + else + gfc_add_block_to_block (&block, &block2); - /* If it is a more extreme value. */ - tmp = fold_build2 (op, boolean_type_node, arrayse.expr, limit); - tmp = build3_v (COND_EXPR, tmp, ifbody, build_empty_stmt ()); - gfc_add_expr_to_block (&block, tmp); gfc_add_block_to_block (&block, &arrayse.post); tmp = gfc_finish_block (&block); if (maskss) /* We enclose the above in if (mask) {...}. */ - tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ()); + tmp = build3_v (COND_EXPR, maskse.expr, tmp, + build_empty_stmt (input_location)); gfc_add_expr_to_block (&body, tmp); + if (lab) + { + gfc_trans_scalarized_loop_end (&loop, 0, &body); + + tmp = fold_build3 (COND_EXPR, type, nonempty, nan_cst, huge_cst); + gfc_add_modify (&loop.code[0], limit, tmp); + gfc_add_expr_to_block (&loop.code[0], build1_v (LABEL_EXPR, lab)); + + gfc_start_block (&body); + + /* If we have a mask, only add this element if the mask is set. */ + if (maskss) + { + gfc_init_se (&maskse, NULL); + gfc_copy_loopinfo_to_se (&maskse, &loop); + maskse.ss = maskss; + gfc_conv_expr_val (&maskse, maskexpr); + gfc_add_block_to_block (&body, &maskse.pre); + + gfc_start_block (&block); + } + else + gfc_init_block (&block); + + /* Compare with the current limit. */ + gfc_init_se (&arrayse, NULL); + gfc_copy_loopinfo_to_se (&arrayse, &loop); + arrayse.ss = arrayss; + gfc_conv_expr_val (&arrayse, arrayexpr); + gfc_add_block_to_block (&block, &arrayse.pre); + + /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or + signed zeros. */ + if (HONOR_NANS (DECL_MODE (limit)) + || HONOR_SIGNED_ZEROS (DECL_MODE (limit))) + { + tmp = fold_build2 (op, boolean_type_node, arrayse.expr, limit); + ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr); + tmp = build3_v (COND_EXPR, tmp, ifbody, + build_empty_stmt (input_location)); + gfc_add_expr_to_block (&block, tmp); + } + else + { + tmp = fold_build2 (op == GT_EXPR ? MAX_EXPR : MIN_EXPR, + type, arrayse.expr, limit); + gfc_add_modify (&block, limit, tmp); + } + + gfc_add_block_to_block (&block, &arrayse.post); + + tmp = gfc_finish_block (&block); + if (maskss) + /* We enclose the above in if (mask) {...}. */ + tmp = build3_v (COND_EXPR, maskse.expr, tmp, + build_empty_stmt (input_location)); + gfc_add_expr_to_block (&body, tmp); + /* Avoid initializing loopvar[0] again, it should be left where + it finished by the first loop. */ + loop.from[0] = loop.loopvar[0]; + } gfc_trans_scalarizing_loops (&loop, &body); + if (fast) + { + tmp = fold_build3 (COND_EXPR, type, nonempty, nan_cst, huge_cst); + ifbody = build2_v (MODIFY_EXPR, limit, tmp); + tmp = build3_v (COND_EXPR, fast, build_empty_stmt (input_location), + ifbody); + gfc_add_expr_to_block (&loop.pre, tmp); + } + else if (HONOR_INFINITIES (DECL_MODE (limit)) && !lab) + { + tmp = fold_build3 (COND_EXPR, type, nonempty, limit, huge_cst); + gfc_add_modify (&loop.pre, limit, tmp); + } + /* For a scalar mask, enclose the loop in an if statement. */ if (maskexpr && maskss == NULL) { + tree else_stmt; + gfc_init_se (&maskse, NULL); gfc_conv_expr_val (&maskse, maskexpr); gfc_init_block (&block); @@ -2367,7 +2961,11 @@ gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, int op) gfc_add_block_to_block (&block, &loop.post); tmp = gfc_finish_block (&block); - tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ()); + if (HONOR_INFINITIES (DECL_MODE (limit))) + else_stmt = build2_v (MODIFY_EXPR, limit, huge_cst); + else + else_stmt = build_empty_stmt (input_location); + tmp = build3_v (COND_EXPR, maskse.expr, tmp, else_stmt); gfc_add_expr_to_block (&block, tmp); gfc_add_block_to_block (&se->pre, &block); } @@ -2403,7 +3001,7 @@ gfc_conv_intrinsic_btest (gfc_se * se, gfc_expr * expr) /* Generate code to perform the specified operation. */ static void -gfc_conv_intrinsic_bitop (gfc_se * se, gfc_expr * expr, int op) +gfc_conv_intrinsic_bitop (gfc_se * se, gfc_expr * expr, enum tree_code op) { tree args[2]; @@ -2428,7 +3026,7 @@ gfc_conv_intrinsic_singlebitop (gfc_se * se, gfc_expr * expr, int set) tree args[2]; tree type; tree tmp; - int op; + enum tree_code op; gfc_conv_intrinsic_function_args (se, expr, args, 2); type = TREE_TYPE (args[0]); @@ -2542,7 +3140,7 @@ gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr) unsigned int num_args; num_args = gfc_intrinsic_argument_list_length (expr); - args = alloca (sizeof (tree) * num_args); + args = (tree *) alloca (sizeof (tree) * num_args); gfc_conv_intrinsic_function_args (se, expr, args, num_args); @@ -2581,7 +3179,8 @@ gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr) default: gcc_unreachable (); } - se->expr = build_call_expr (tmp, 3, args[0], args[1], args[2]); + se->expr = build_call_expr_loc (input_location, + tmp, 3, args[0], args[1], args[2]); /* Convert the result back to the original type, if we extended the first argument's width above. */ if (expr->ts.kind < 4) @@ -2607,6 +3206,197 @@ gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr) se->expr = fold_build3 (COND_EXPR, type, tmp, args[0], rrot); } +/* LEADZ (i) = (i == 0) ? BIT_SIZE (i) + : __builtin_clz(i) - (BIT_SIZE('int') - BIT_SIZE(i)) + + The conditional expression is necessary because the result of LEADZ(0) + is defined, but the result of __builtin_clz(0) is undefined for most + targets. + + For INTEGER kinds smaller than the C 'int' type, we have to subtract the + difference in bit size between the argument of LEADZ and the C int. */ + +static void +gfc_conv_intrinsic_leadz (gfc_se * se, gfc_expr * expr) +{ + tree arg; + tree arg_type; + tree cond; + tree result_type; + tree leadz; + tree bit_size; + tree tmp; + tree func; + int s, argsize; + + gfc_conv_intrinsic_function_args (se, expr, &arg, 1); + argsize = TYPE_PRECISION (TREE_TYPE (arg)); + + /* Which variant of __builtin_clz* should we call? */ + if (argsize <= INT_TYPE_SIZE) + { + arg_type = unsigned_type_node; + func = built_in_decls[BUILT_IN_CLZ]; + } + else if (argsize <= LONG_TYPE_SIZE) + { + arg_type = long_unsigned_type_node; + func = built_in_decls[BUILT_IN_CLZL]; + } + else if (argsize <= LONG_LONG_TYPE_SIZE) + { + arg_type = long_long_unsigned_type_node; + func = built_in_decls[BUILT_IN_CLZLL]; + } + else + { + gcc_assert (argsize == 128); + arg_type = gfc_build_uint_type (argsize); + func = gfor_fndecl_clz128; + } + + /* Convert the actual argument twice: first, to the unsigned type of the + same size; then, to the proper argument type for the built-in + function. But the return type is of the default INTEGER kind. */ + arg = fold_convert (gfc_build_uint_type (argsize), arg); + arg = fold_convert (arg_type, arg); + result_type = gfc_get_int_type (gfc_default_integer_kind); + + /* Compute LEADZ for the case i .ne. 0. */ + s = TYPE_PRECISION (arg_type) - argsize; + tmp = fold_convert (result_type, build_call_expr (func, 1, arg)); + leadz = fold_build2 (MINUS_EXPR, result_type, + tmp, build_int_cst (result_type, s)); + + /* Build BIT_SIZE. */ + bit_size = build_int_cst (result_type, argsize); + + cond = fold_build2 (EQ_EXPR, boolean_type_node, + arg, build_int_cst (arg_type, 0)); + se->expr = fold_build3 (COND_EXPR, result_type, cond, bit_size, leadz); +} + +/* TRAILZ(i) = (i == 0) ? BIT_SIZE (i) : __builtin_ctz(i) + + The conditional expression is necessary because the result of TRAILZ(0) + is defined, but the result of __builtin_ctz(0) is undefined for most + targets. */ + +static void +gfc_conv_intrinsic_trailz (gfc_se * se, gfc_expr *expr) +{ + tree arg; + tree arg_type; + tree cond; + tree result_type; + tree trailz; + tree bit_size; + tree func; + int argsize; + + gfc_conv_intrinsic_function_args (se, expr, &arg, 1); + argsize = TYPE_PRECISION (TREE_TYPE (arg)); + + /* Which variant of __builtin_ctz* should we call? */ + if (argsize <= INT_TYPE_SIZE) + { + arg_type = unsigned_type_node; + func = built_in_decls[BUILT_IN_CTZ]; + } + else if (argsize <= LONG_TYPE_SIZE) + { + arg_type = long_unsigned_type_node; + func = built_in_decls[BUILT_IN_CTZL]; + } + else if (argsize <= LONG_LONG_TYPE_SIZE) + { + arg_type = long_long_unsigned_type_node; + func = built_in_decls[BUILT_IN_CTZLL]; + } + else + { + gcc_assert (argsize == 128); + arg_type = gfc_build_uint_type (argsize); + func = gfor_fndecl_ctz128; + } + + /* Convert the actual argument twice: first, to the unsigned type of the + same size; then, to the proper argument type for the built-in + function. But the return type is of the default INTEGER kind. */ + arg = fold_convert (gfc_build_uint_type (argsize), arg); + arg = fold_convert (arg_type, arg); + result_type = gfc_get_int_type (gfc_default_integer_kind); + + /* Compute TRAILZ for the case i .ne. 0. */ + trailz = fold_convert (result_type, build_call_expr_loc (input_location, + func, 1, arg)); + + /* Build BIT_SIZE. */ + bit_size = build_int_cst (result_type, argsize); + + cond = fold_build2 (EQ_EXPR, boolean_type_node, + arg, build_int_cst (arg_type, 0)); + se->expr = fold_build3 (COND_EXPR, result_type, cond, bit_size, trailz); +} + +/* Process an intrinsic with unspecified argument-types that has an optional + argument (which could be of type character), e.g. EOSHIFT. For those, we + need to append the string length of the optional argument if it is not + present and the type is really character. + primary specifies the position (starting at 1) of the non-optional argument + specifying the type and optional gives the position of the optional + argument in the arglist. */ + +static void +conv_generic_with_optional_char_arg (gfc_se* se, gfc_expr* expr, + unsigned primary, unsigned optional) +{ + gfc_actual_arglist* prim_arg; + gfc_actual_arglist* opt_arg; + unsigned cur_pos; + gfc_actual_arglist* arg; + gfc_symbol* sym; + tree append_args; + + /* Find the two arguments given as position. */ + cur_pos = 0; + prim_arg = NULL; + opt_arg = NULL; + for (arg = expr->value.function.actual; arg; arg = arg->next) + { + ++cur_pos; + + if (cur_pos == primary) + prim_arg = arg; + if (cur_pos == optional) + opt_arg = arg; + + if (cur_pos >= primary && cur_pos >= optional) + break; + } + gcc_assert (prim_arg); + gcc_assert (prim_arg->expr); + gcc_assert (opt_arg); + + /* If we do have type CHARACTER and the optional argument is really absent, + append a dummy 0 as string length. */ + append_args = NULL_TREE; + if (prim_arg->expr->ts.type == BT_CHARACTER && !opt_arg->expr) + { + tree dummy; + + dummy = build_int_cst (gfc_charlen_type_node, 0); + append_args = gfc_chainon_list (append_args, dummy); + } + + /* Build the call itself. */ + sym = gfc_get_symbol_for_expr (expr); + gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr, + append_args); + gfc_free (sym); +} + + /* The length of a character string. */ static void gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr) @@ -2650,7 +3440,7 @@ gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr) && (sym->result == sym)) decl = gfc_get_fake_result_decl (sym, 0); - len = sym->ts.cl->backend_decl; + len = sym->ts.u.cl->backend_decl; gcc_assert (len); break; } @@ -2677,12 +3467,21 @@ gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr) static void gfc_conv_intrinsic_len_trim (gfc_se * se, gfc_expr * expr) { - tree args[2]; - tree type; + int kind = expr->value.function.actual->expr->ts.kind; + tree args[2], type, fndecl; gfc_conv_intrinsic_function_args (se, expr, args, 2); type = gfc_typenode_for_spec (&expr->ts); - se->expr = build_call_expr (gfor_fndecl_string_len_trim, 2, args[0], args[1]); + + if (kind == 1) + fndecl = gfor_fndecl_string_len_trim; + else if (kind == 4) + fndecl = gfor_fndecl_string_len_trim_char4; + else + gcc_unreachable (); + + se->expr = build_call_expr_loc (input_location, + fndecl, 2, args[0], args[1]); se->expr = convert (type, se->expr); } @@ -2699,11 +3498,17 @@ gfc_conv_intrinsic_index_scan_verify (gfc_se * se, gfc_expr * expr, tree *args; unsigned int num_args; - num_args = gfc_intrinsic_argument_list_length (expr); - args = alloca (sizeof (tree) * 5); + args = (tree *) alloca (sizeof (tree) * 5); + + /* Get number of arguments; characters count double due to the + string length argument. Kind= is not passed to the library + and thus ignored. */ + if (expr->value.function.actual->next->next->expr == NULL) + num_args = 4; + else + num_args = 5; - gfc_conv_intrinsic_function_args (se, expr, args, - num_args >= 5 ? 5 : num_args); + gfc_conv_intrinsic_function_args (se, expr, args, num_args); type = gfc_typenode_for_spec (&expr->ts); if (num_args == 4) @@ -2712,7 +3517,8 @@ gfc_conv_intrinsic_index_scan_verify (gfc_se * se, gfc_expr * expr, args[4] = convert (logical4_type_node, args[4]); fndecl = build_addr (function, current_function_decl); - se->expr = build_call_array (TREE_TYPE (TREE_TYPE (function)), fndecl, + se->expr = build_call_array_loc (input_location, + TREE_TYPE (TREE_TYPE (function)), fndecl, 5, args); se->expr = convert (type, se->expr); @@ -2722,15 +3528,16 @@ gfc_conv_intrinsic_index_scan_verify (gfc_se * se, gfc_expr * expr, static void gfc_conv_intrinsic_ichar (gfc_se * se, gfc_expr * expr) { - tree args[2]; - tree type; + tree args[2], type, pchartype; gfc_conv_intrinsic_function_args (se, expr, args, 2); gcc_assert (POINTER_TYPE_P (TREE_TYPE (args[1]))); - args[1] = fold_build1 (NOP_EXPR, pchar_type_node, args[1]); + pchartype = gfc_get_pchar_type (expr->value.function.actual->expr->ts.kind); + args[1] = fold_build1 (NOP_EXPR, pchartype, args[1]); type = gfc_typenode_for_spec (&expr->ts); - se->expr = build_fold_indirect_ref (args[1]); + se->expr = build_fold_indirect_ref_loc (input_location, + args[1]); se->expr = convert (type, se->expr); } @@ -2743,7 +3550,8 @@ gfc_conv_intrinsic_isnan (gfc_se * se, gfc_expr * expr) tree arg; gfc_conv_intrinsic_function_args (se, expr, &arg, 1); - se->expr = build_call_expr (built_in_decls[BUILT_IN_ISNAN], 1, arg); + se->expr = build_call_expr_loc (input_location, + built_in_decls[BUILT_IN_ISNAN], 1, arg); STRIP_TYPE_NOPS (se->expr); se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr); } @@ -2773,12 +3581,12 @@ gfc_conv_intrinsic_merge (gfc_se * se, gfc_expr * expr) tree fsource; tree mask; tree type; - tree len; + tree len, len2; tree *args; unsigned int num_args; num_args = gfc_intrinsic_argument_list_length (expr); - args = alloca (sizeof (tree) * num_args); + args = (tree *) alloca (sizeof (tree) * num_args); gfc_conv_intrinsic_function_args (se, expr, args, num_args); if (expr->ts.type != BT_CHARACTER) @@ -2794,13 +3602,17 @@ gfc_conv_intrinsic_merge (gfc_se * se, gfc_expr * expr) also have to set the string length for the result. */ len = args[0]; tsource = args[1]; + len2 = args[2]; fsource = args[3]; mask = args[4]; + gfc_trans_same_strlen_check ("MERGE intrinsic", &expr->where, len, len2, + &se->pre); se->string_length = len; } type = TREE_TYPE (tsource); - se->expr = fold_build3 (COND_EXPR, type, mask, tsource, fsource); + se->expr = fold_build3 (COND_EXPR, type, mask, tsource, + fold_convert (type, fsource)); } @@ -2830,40 +3642,41 @@ gfc_conv_intrinsic_fraction (gfc_se * se, gfc_expr * expr) type = gfc_typenode_for_spec (&expr->ts); gfc_conv_intrinsic_function_args (se, expr, &arg, 1); tmp = gfc_create_var (integer_type_node, NULL); - se->expr = build_call_expr (built_in_decls[frexp], 2, + se->expr = build_call_expr_loc (input_location, + built_in_decls[frexp], 2, fold_convert (type, arg), - build_fold_addr_expr (tmp)); + gfc_build_addr_expr (NULL_TREE, tmp)); se->expr = fold_convert (type, se->expr); } /* NEAREST (s, dir) is translated into - tmp = copysign (INF, dir); + tmp = copysign (HUGE_VAL, dir); return nextafter (s, tmp); */ static void gfc_conv_intrinsic_nearest (gfc_se * se, gfc_expr * expr) { tree args[2], type, tmp; - int nextafter, copysign, inf; + int nextafter, copysign, huge_val; switch (expr->ts.kind) { case 4: nextafter = BUILT_IN_NEXTAFTERF; copysign = BUILT_IN_COPYSIGNF; - inf = BUILT_IN_INFF; + huge_val = BUILT_IN_HUGE_VALF; break; case 8: nextafter = BUILT_IN_NEXTAFTER; copysign = BUILT_IN_COPYSIGN; - inf = BUILT_IN_INF; + huge_val = BUILT_IN_HUGE_VAL; break; case 10: case 16: nextafter = BUILT_IN_NEXTAFTERL; copysign = BUILT_IN_COPYSIGNL; - inf = BUILT_IN_INFL; + huge_val = BUILT_IN_HUGE_VALL; break; default: gcc_unreachable (); @@ -2871,10 +3684,13 @@ gfc_conv_intrinsic_nearest (gfc_se * se, gfc_expr * expr) type = gfc_typenode_for_spec (&expr->ts); gfc_conv_intrinsic_function_args (se, expr, args, 2); - tmp = build_call_expr (built_in_decls[copysign], 2, - build_call_expr (built_in_decls[inf], 0), + tmp = build_call_expr_loc (input_location, + built_in_decls[copysign], 2, + build_call_expr_loc (input_location, + built_in_decls[huge_val], 0), fold_convert (type, args[1])); - se->expr = build_call_expr (built_in_decls[nextafter], 2, + se->expr = build_call_expr_loc (input_location, + built_in_decls[nextafter], 2, fold_convert (type, args[0]), tmp); se->expr = fold_convert (type, se->expr); } @@ -2908,7 +3724,7 @@ gfc_conv_intrinsic_spacing (gfc_se * se, gfc_expr * expr) k = gfc_validate_kind (BT_REAL, expr->ts.kind, false); prec = build_int_cst (NULL_TREE, gfc_real_kinds[k].digits); emin = build_int_cst (NULL_TREE, gfc_real_kinds[k].min_exponent - 1); - tiny = gfc_conv_mpfr_to_tree (gfc_real_kinds[k].tiny, expr->ts.kind); + tiny = gfc_conv_mpfr_to_tree (gfc_real_kinds[k].tiny, expr->ts.kind, 0); switch (expr->ts.kind) { @@ -2939,17 +3755,19 @@ gfc_conv_intrinsic_spacing (gfc_se * se, gfc_expr * expr) /* Build the block for s /= 0. */ gfc_start_block (&block); - tmp = build_call_expr (built_in_decls[frexp], 2, arg, - build_fold_addr_expr (e)); + tmp = build_call_expr_loc (input_location, + built_in_decls[frexp], 2, arg, + gfc_build_addr_expr (NULL_TREE, e)); gfc_add_expr_to_block (&block, tmp); tmp = fold_build2 (MINUS_EXPR, integer_type_node, e, prec); - gfc_add_modify_expr (&block, e, fold_build2 (MAX_EXPR, integer_type_node, - tmp, emin)); + gfc_add_modify (&block, e, fold_build2 (MAX_EXPR, integer_type_node, + tmp, emin)); - tmp = build_call_expr (built_in_decls[scalbn], 2, + tmp = build_call_expr_loc (input_location, + built_in_decls[scalbn], 2, build_real_from_int_cst (type, integer_one_node), e); - gfc_add_modify_expr (&block, res, tmp); + gfc_add_modify (&block, res, tmp); /* Finish by building the IF statement. */ cond = fold_build2 (EQ_EXPR, boolean_type_node, arg, @@ -3012,24 +3830,27 @@ gfc_conv_intrinsic_rrspacing (gfc_se * se, gfc_expr * expr) e = gfc_create_var (integer_type_node, NULL); x = gfc_create_var (type, NULL); - gfc_add_modify_expr (&se->pre, x, - build_call_expr (built_in_decls[fabs], 1, arg)); + gfc_add_modify (&se->pre, x, + build_call_expr_loc (input_location, + built_in_decls[fabs], 1, arg)); gfc_start_block (&block); - tmp = build_call_expr (built_in_decls[frexp], 2, arg, - build_fold_addr_expr (e)); + tmp = build_call_expr_loc (input_location, + built_in_decls[frexp], 2, arg, + gfc_build_addr_expr (NULL_TREE, e)); gfc_add_expr_to_block (&block, tmp); tmp = fold_build2 (MINUS_EXPR, integer_type_node, build_int_cst (NULL_TREE, prec), e); - tmp = build_call_expr (built_in_decls[scalbn], 2, x, tmp); - gfc_add_modify_expr (&block, x, tmp); + tmp = build_call_expr_loc (input_location, + built_in_decls[scalbn], 2, x, tmp); + gfc_add_modify (&block, x, tmp); stmt = gfc_finish_block (&block); cond = fold_build2 (NE_EXPR, boolean_type_node, x, build_real_from_int_cst (type, integer_zero_node)); - tmp = build3_v (COND_EXPR, cond, stmt, build_empty_stmt ()); + tmp = build3_v (COND_EXPR, cond, stmt, build_empty_stmt (input_location)); gfc_add_expr_to_block (&se->pre, tmp); se->expr = fold_convert (type, x); @@ -3061,7 +3882,8 @@ gfc_conv_intrinsic_scale (gfc_se * se, gfc_expr * expr) type = gfc_typenode_for_spec (&expr->ts); gfc_conv_intrinsic_function_args (se, expr, args, 2); - se->expr = build_call_expr (built_in_decls[scalbn], 2, + se->expr = build_call_expr_loc (input_location, + built_in_decls[scalbn], 2, fold_convert (type, args[0]), fold_convert (integer_type_node, args[1])); se->expr = fold_convert (type, se->expr); @@ -3099,10 +3921,12 @@ gfc_conv_intrinsic_set_exponent (gfc_se * se, gfc_expr * expr) gfc_conv_intrinsic_function_args (se, expr, args, 2); tmp = gfc_create_var (integer_type_node, NULL); - tmp = build_call_expr (built_in_decls[frexp], 2, + tmp = build_call_expr_loc (input_location, + built_in_decls[frexp], 2, fold_convert (type, args[0]), - build_fold_addr_expr (tmp)); - se->expr = build_call_expr (built_in_decls[scalbn], 2, tmp, + gfc_build_addr_expr (NULL_TREE, tmp)); + se->expr = build_call_expr_loc (input_location, + built_in_decls[scalbn], 2, tmp, fold_convert (integer_type_node, args[1])); se->expr = fold_convert (type, se->expr); } @@ -3132,7 +3956,8 @@ gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr) arg1 = gfc_evaluate_now (argse.expr, &se->pre); /* Build the call to size0. */ - fncall0 = build_call_expr (gfor_fndecl_size0, 1, arg1); + fncall0 = build_call_expr_loc (input_location, + gfor_fndecl_size0, 1, arg1); actual = actual->next; @@ -3143,10 +3968,6 @@ gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr) gfc_array_index_type); gfc_add_block_to_block (&se->pre, &argse.pre); - /* Build the call to size1. */ - fncall1 = build_call_expr (gfor_fndecl_size1, 2, - arg1, argse.expr); - /* Unusually, for an intrinsic, size does not exclude an optional arg2, so we must test for it. */ if (actual->expr->expr_type == EXPR_VARIABLE @@ -3154,6 +3975,11 @@ gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr) && actual->expr->symtree->n.sym->attr.optional) { tree tmp; + /* Build the call to size1. */ + fncall1 = build_call_expr_loc (input_location, + gfor_fndecl_size1, 2, + arg1, argse.expr); + gfc_init_se (&argse, NULL); argse.want_pointer = 1; argse.data_not_needed = 1; @@ -3166,29 +3992,70 @@ gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr) tmp, fncall1, fncall0); } else - se->expr = fncall1; + { + se->expr = NULL_TREE; + argse.expr = fold_build2 (MINUS_EXPR, gfc_array_index_type, + argse.expr, gfc_index_one_node); + } + } + else if (expr->value.function.actual->expr->rank == 1) + { + argse.expr = gfc_index_zero_node; + se->expr = NULL_TREE; } else se->expr = fncall0; + if (se->expr == NULL_TREE) + { + tree ubound, lbound; + + arg1 = build_fold_indirect_ref_loc (input_location, + arg1); + ubound = gfc_conv_descriptor_ubound_get (arg1, argse.expr); + lbound = gfc_conv_descriptor_lbound_get (arg1, argse.expr); + se->expr = fold_build2 (MINUS_EXPR, gfc_array_index_type, + ubound, lbound); + se->expr = fold_build2 (PLUS_EXPR, gfc_array_index_type, se->expr, + gfc_index_one_node); + se->expr = fold_build2 (MAX_EXPR, gfc_array_index_type, se->expr, + gfc_index_zero_node); + } + type = gfc_typenode_for_spec (&expr->ts); se->expr = convert (type, se->expr); } +/* Helper function to compute the size of a character variable, + excluding the terminating null characters. The result has + gfc_array_index_type type. */ + +static tree +size_of_string_in_bytes (int kind, tree string_length) +{ + tree bytesize; + int i = gfc_validate_kind (BT_CHARACTER, kind, false); + + bytesize = build_int_cst (gfc_array_index_type, + gfc_character_kinds[i].bit_size / 8); + + return fold_build2 (MULT_EXPR, gfc_array_index_type, bytesize, + fold_convert (gfc_array_index_type, string_length)); +} + + static void gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr) { gfc_expr *arg; gfc_ss *ss; gfc_se argse; - tree source; tree source_bytes; tree type; tree tmp; tree lower; tree upper; - /*tree stride;*/ int n; arg = expr->value.function.actual->expr; @@ -3196,70 +4063,69 @@ gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr) gfc_init_se (&argse, NULL); ss = gfc_walk_expr (arg); - source_bytes = gfc_create_var (gfc_array_index_type, "bytes"); - if (ss == gfc_ss_terminator) { gfc_conv_expr_reference (&argse, arg); - source = argse.expr; - type = TREE_TYPE (build_fold_indirect_ref (argse.expr)); + type = TREE_TYPE (build_fold_indirect_ref_loc (input_location, + argse.expr)); /* Obtain the source word length. */ if (arg->ts.type == BT_CHARACTER) - source_bytes = fold_convert (gfc_array_index_type, - argse.string_length); + se->expr = size_of_string_in_bytes (arg->ts.kind, + argse.string_length); else - source_bytes = fold_convert (gfc_array_index_type, - size_in_bytes (type)); + se->expr = fold_convert (gfc_array_index_type, size_in_bytes (type)); } else { + source_bytes = gfc_create_var (gfc_array_index_type, "bytes"); argse.want_pointer = 0; gfc_conv_expr_descriptor (&argse, arg, ss); - source = gfc_conv_descriptor_data_get (argse.expr); type = gfc_get_element_type (TREE_TYPE (argse.expr)); /* Obtain the argument's word length. */ if (arg->ts.type == BT_CHARACTER) - tmp = fold_convert (gfc_array_index_type, argse.string_length); + tmp = size_of_string_in_bytes (arg->ts.kind, argse.string_length); else tmp = fold_convert (gfc_array_index_type, size_in_bytes (type)); - gfc_add_modify_expr (&argse.pre, source_bytes, tmp); + gfc_add_modify (&argse.pre, source_bytes, tmp); /* Obtain the size of the array in bytes. */ for (n = 0; n < arg->rank; n++) { tree idx; idx = gfc_rank_cst[n]; - lower = gfc_conv_descriptor_lbound (argse.expr, idx); - upper = gfc_conv_descriptor_ubound (argse.expr, idx); + lower = gfc_conv_descriptor_lbound_get (argse.expr, idx); + upper = gfc_conv_descriptor_ubound_get (argse.expr, idx); tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, upper, lower); tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp, gfc_index_one_node); tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, tmp, source_bytes); - gfc_add_modify_expr (&argse.pre, source_bytes, tmp); + gfc_add_modify (&argse.pre, source_bytes, tmp); } + se->expr = source_bytes; } gfc_add_block_to_block (&se->pre, &argse.pre); - se->expr = source_bytes; } /* Intrinsic string comparison functions. */ static void -gfc_conv_intrinsic_strcmp (gfc_se * se, gfc_expr * expr, int op) +gfc_conv_intrinsic_strcmp (gfc_se * se, gfc_expr * expr, enum tree_code op) { tree args[4]; gfc_conv_intrinsic_function_args (se, expr, args, 4); - se->expr = gfc_build_compare_string (args[0], args[1], args[2], args[3]); + se->expr + = gfc_build_compare_string (args[0], args[1], args[2], args[3], + expr->value.function.actual->expr->ts.kind); se->expr = fold_build2 (op, gfc_typenode_for_spec (&expr->ts), se->expr, build_int_cst (TREE_TYPE (se->expr), 0)); } @@ -3281,25 +4147,35 @@ gfc_conv_intrinsic_adjust (gfc_se * se, gfc_expr * expr, tree fndecl) var = gfc_conv_string_tmp (se, type, len); args[0] = var; - tmp = build_call_expr (fndecl, 3, args[0], args[1], args[2]); + tmp = build_call_expr_loc (input_location, + fndecl, 3, args[0], args[1], args[2]); gfc_add_expr_to_block (&se->pre, tmp); se->expr = var; se->string_length = len; } -/* Array transfer statement. - DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE]) - where: - typeof = typeof - and: - N = min (sizeof (SOURCE(:)), sizeof (DEST(:)), +/* Generate code for the TRANSFER intrinsic: + For scalar results: + DEST = TRANSFER (SOURCE, MOLD) + where: + typeof = typeof + and: + MOLD is scalar. + + For array results: + DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE]) + where: + typeof = typeof + and: + N = min (sizeof (SOURCE(:)), sizeof (DEST(:)), sizeof (DEST(0) * SIZE). */ - static void -gfc_conv_intrinsic_array_transfer (gfc_se * se, gfc_expr * expr) +gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr) { tree tmp; + tree tmpdecl; + tree ptr; tree extent; tree source; tree source_type; @@ -3310,7 +4186,6 @@ gfc_conv_intrinsic_array_transfer (gfc_se * se, gfc_expr * expr) tree size_bytes; tree upper; tree lower; - tree stride; tree stmt; gfc_actual_arglist *arg; gfc_se argse; @@ -3318,14 +4193,27 @@ gfc_conv_intrinsic_array_transfer (gfc_se * se, gfc_expr * expr) gfc_ss_info *info; stmtblock_t block; int n; + bool scalar_mold; - gcc_assert (se->loop); - info = &se->ss->data.info; + info = NULL; + if (se->loop) + info = &se->ss->data.info; /* Convert SOURCE. The output from this stage is:- source_bytes = length of the source in bytes source = pointer to the source data. */ arg = expr->value.function.actual; + + /* Ensure double transfer through LOGICAL preserves all + the needed bits. */ + if (arg->expr->expr_type == EXPR_FUNCTION + && arg->expr->value.function.esym == NULL + && arg->expr->value.function.isym != NULL + && arg->expr->value.function.isym->id == GFC_ISYM_TRANSFER + && arg->expr->ts.type == BT_LOGICAL + && expr->ts.type != arg->expr->ts.type) + arg->expr->value.function.name = "__transfer_in_transfer"; + gfc_init_se (&argse, NULL); ss = gfc_walk_expr (arg->expr); @@ -3337,11 +4225,13 @@ gfc_conv_intrinsic_array_transfer (gfc_se * se, gfc_expr * expr) gfc_conv_expr_reference (&argse, arg->expr); source = argse.expr; - source_type = TREE_TYPE (build_fold_indirect_ref (argse.expr)); + source_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location, + argse.expr)); /* Obtain the source word length. */ if (arg->expr->ts.type == BT_CHARACTER) - tmp = fold_convert (gfc_array_index_type, argse.string_length); + tmp = size_of_string_in_bytes (arg->expr->ts.kind, + argse.string_length); else tmp = fold_convert (gfc_array_index_type, size_in_bytes (source_type)); @@ -3354,11 +4244,16 @@ gfc_conv_intrinsic_array_transfer (gfc_se * se, gfc_expr * expr) source_type = gfc_get_element_type (TREE_TYPE (argse.expr)); /* Repack the source if not a full variable array. */ - if (!(arg->expr->expr_type == EXPR_VARIABLE - && arg->expr->ref->u.ar.type == AR_FULL)) + if (arg->expr->expr_type == EXPR_VARIABLE + && arg->expr->ref->u.ar.type != AR_FULL) { - tmp = build_fold_addr_expr (argse.expr); - source = build_call_expr (gfor_fndecl_in_pack, 1, tmp); + tmp = gfc_build_addr_expr (NULL_TREE, argse.expr); + + if (gfc_option.warn_array_temp) + gfc_warning ("Creating array temporary at %L", &expr->where); + + source = build_call_expr_loc (input_location, + gfor_fndecl_in_pack, 1, tmp); source = gfc_evaluate_now (source, &argse.pre); /* Free the temporary. */ @@ -3371,7 +4266,8 @@ gfc_conv_intrinsic_array_transfer (gfc_se * se, gfc_expr * expr) gfc_init_block (&block); tmp = gfc_conv_array_data (argse.expr); tmp = fold_build2 (NE_EXPR, boolean_type_node, source, tmp); - tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ()); + tmp = build3_v (COND_EXPR, tmp, stmt, + build_empty_stmt (input_location)); gfc_add_expr_to_block (&block, tmp); gfc_add_block_to_block (&block, &se->post); gfc_init_block (&se->post); @@ -3380,7 +4276,8 @@ gfc_conv_intrinsic_array_transfer (gfc_se * se, gfc_expr * expr) /* Obtain the source word length. */ if (arg->expr->ts.type == BT_CHARACTER) - tmp = fold_convert (gfc_array_index_type, argse.string_length); + tmp = size_of_string_in_bytes (arg->expr->ts.kind, + argse.string_length); else tmp = fold_convert (gfc_array_index_type, size_in_bytes (source_type)); @@ -3391,13 +4288,12 @@ gfc_conv_intrinsic_array_transfer (gfc_se * se, gfc_expr * expr) { tree idx; idx = gfc_rank_cst[n]; - gfc_add_modify_expr (&argse.pre, source_bytes, tmp); - stride = gfc_conv_descriptor_stride (argse.expr, idx); - lower = gfc_conv_descriptor_lbound (argse.expr, idx); - upper = gfc_conv_descriptor_ubound (argse.expr, idx); + gfc_add_modify (&argse.pre, source_bytes, tmp); + lower = gfc_conv_descriptor_lbound_get (argse.expr, idx); + upper = gfc_conv_descriptor_ubound_get (argse.expr, idx); tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, upper, lower); - gfc_add_modify_expr (&argse.pre, extent, tmp); + gfc_add_modify (&argse.pre, extent, tmp); tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, extent, gfc_index_one_node); tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, @@ -3405,7 +4301,7 @@ gfc_conv_intrinsic_array_transfer (gfc_se * se, gfc_expr * expr) } } - gfc_add_modify_expr (&argse.pre, source_bytes, tmp); + gfc_add_modify (&argse.pre, source_bytes, tmp); gfc_add_block_to_block (&se->pre, &argse.pre); gfc_add_block_to_block (&se->post, &argse.post); @@ -3417,10 +4313,13 @@ gfc_conv_intrinsic_array_transfer (gfc_se * se, gfc_expr * expr) gfc_init_se (&argse, NULL); ss = gfc_walk_expr (arg->expr); + scalar_mold = arg->expr->rank == 0; + if (ss == gfc_ss_terminator) { gfc_conv_expr_reference (&argse, arg->expr); - mold_type = TREE_TYPE (build_fold_indirect_ref (argse.expr)); + mold_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location, + argse.expr)); } else { @@ -3430,9 +4329,20 @@ gfc_conv_intrinsic_array_transfer (gfc_se * se, gfc_expr * expr) mold_type = gfc_get_element_type (TREE_TYPE (argse.expr)); } + gfc_add_block_to_block (&se->pre, &argse.pre); + gfc_add_block_to_block (&se->post, &argse.post); + + if (strcmp (expr->value.function.name, "__transfer_in_transfer") == 0) + { + /* If this TRANSFER is nested in another TRANSFER, use a type + that preserves all bits. */ + if (arg->expr->ts.type == BT_LOGICAL) + mold_type = gfc_get_int_type (arg->expr->ts.kind); + } + if (arg->expr->ts.type == BT_CHARACTER) { - tmp = fold_convert (gfc_array_index_type, argse.string_length); + tmp = size_of_string_in_bytes (arg->expr->ts.kind, argse.string_length); mold_type = gfc_get_character_type_len (arg->expr->ts.kind, tmp); } else @@ -3440,7 +4350,7 @@ gfc_conv_intrinsic_array_transfer (gfc_se * se, gfc_expr * expr) size_in_bytes (mold_type)); dest_word_len = gfc_create_var (gfc_array_index_type, NULL); - gfc_add_modify_expr (&se->pre, dest_word_len, tmp); + gfc_add_modify (&se->pre, dest_word_len, tmp); /* Finally convert SIZE, if it is present. */ arg = arg->next; @@ -3451,26 +4361,27 @@ gfc_conv_intrinsic_array_transfer (gfc_se * se, gfc_expr * expr) gfc_init_se (&argse, NULL); gfc_conv_expr_reference (&argse, arg->expr); tmp = convert (gfc_array_index_type, - build_fold_indirect_ref (argse.expr)); + build_fold_indirect_ref_loc (input_location, + argse.expr)); gfc_add_block_to_block (&se->pre, &argse.pre); gfc_add_block_to_block (&se->post, &argse.post); } else tmp = NULL_TREE; + /* Separate array and scalar results. */ + if (scalar_mold && tmp == NULL_TREE) + goto scalar_transfer; + size_bytes = gfc_create_var (gfc_array_index_type, NULL); if (tmp != NULL_TREE) - { - tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, - tmp, dest_word_len); - tmp = fold_build2 (MIN_EXPR, gfc_array_index_type, - tmp, source_bytes); - } + tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, + tmp, dest_word_len); else tmp = source_bytes; - gfc_add_modify_expr (&se->pre, size_bytes, tmp); - gfc_add_modify_expr (&se->pre, size_words, + gfc_add_modify (&se->pre, size_bytes, tmp); + gfc_add_modify (&se->pre, size_words, fold_build2 (CEIL_DIV_EXPR, gfc_array_index_type, size_bytes, dest_word_len)); @@ -3487,8 +4398,8 @@ gfc_conv_intrinsic_array_transfer (gfc_se * se, gfc_expr * expr) tmp, gfc_index_one_node); tmp = fold_build2 (MIN_EXPR, gfc_array_index_type, tmp, size_words); - gfc_add_modify_expr (&se->pre, size_words, tmp); - gfc_add_modify_expr (&se->pre, size_bytes, + gfc_add_modify (&se->pre, size_words, tmp); + gfc_add_modify (&se->pre, size_bytes, fold_build2 (MULT_EXPR, gfc_array_index_type, size_words, dest_word_len)); upper = fold_build2 (PLUS_EXPR, gfc_array_index_type, @@ -3506,80 +4417,90 @@ gfc_conv_intrinsic_array_transfer (gfc_se * se, gfc_expr * expr) se->loop->to[n] = upper; /* Build a destination descriptor, using the pointer, source, as the - data field. This is already allocated so set callee_alloc. - FIXME callee_alloc is not set! */ - + data field. */ gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, - info, mold_type, false, true, false); + info, mold_type, NULL_TREE, false, true, false, + &expr->where); /* Cast the pointer to the result. */ tmp = gfc_conv_descriptor_data_get (info->descriptor); tmp = fold_convert (pvoid_type_node, tmp); /* Use memcpy to do the transfer. */ - tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], + tmp = build_call_expr_loc (input_location, + built_in_decls[BUILT_IN_MEMCPY], 3, tmp, fold_convert (pvoid_type_node, source), - size_bytes); + fold_build2 (MIN_EXPR, gfc_array_index_type, + size_bytes, source_bytes)); gfc_add_expr_to_block (&se->pre, tmp); se->expr = info->descriptor; if (expr->ts.type == BT_CHARACTER) se->string_length = dest_word_len; -} + return; -/* Scalar transfer statement. - TRANSFER (source, mold) = memcpy(&tmpdecl, &source, size), tmpdecl. */ +/* Deal with scalar results. */ +scalar_transfer: + extent = fold_build2 (MIN_EXPR, gfc_array_index_type, + dest_word_len, source_bytes); + extent = fold_build2 (MAX_EXPR, gfc_array_index_type, + extent, gfc_index_zero_node); -static void -gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr) -{ - gfc_actual_arglist *arg; - gfc_se argse; - tree type; - tree ptr; - gfc_ss *ss; - tree tmpdecl, tmp; + if (expr->ts.type == BT_CHARACTER) + { + tree direct; + tree indirect; - /* Get a pointer to the source. */ - arg = expr->value.function.actual; - ss = gfc_walk_expr (arg->expr); - gfc_init_se (&argse, NULL); - if (ss == gfc_ss_terminator) - gfc_conv_expr_reference (&argse, arg->expr); - else - gfc_conv_array_parameter (&argse, arg->expr, ss, 1); - gfc_add_block_to_block (&se->pre, &argse.pre); - gfc_add_block_to_block (&se->post, &argse.post); - ptr = argse.expr; + ptr = convert (gfc_get_pchar_type (expr->ts.kind), source); + tmpdecl = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), + "transfer"); - arg = arg->next; - type = gfc_typenode_for_spec (&expr->ts); + /* If source is longer than the destination, use a pointer to + the source directly. */ + gfc_init_block (&block); + gfc_add_modify (&block, tmpdecl, ptr); + direct = gfc_finish_block (&block); - if (expr->ts.type == BT_CHARACTER) - { - ptr = convert (build_pointer_type (type), ptr); - gfc_init_se (&argse, NULL); - gfc_conv_expr (&argse, arg->expr); - gfc_add_block_to_block (&se->pre, &argse.pre); - gfc_add_block_to_block (&se->post, &argse.post); - se->expr = ptr; - se->string_length = argse.string_length; + /* Otherwise, allocate a string with the length of the destination + and copy the source into it. */ + gfc_init_block (&block); + tmp = gfc_get_pchar_type (expr->ts.kind); + tmp = gfc_call_malloc (&block, tmp, dest_word_len); + gfc_add_modify (&block, tmpdecl, + fold_convert (TREE_TYPE (ptr), tmp)); + tmp = build_call_expr_loc (input_location, + built_in_decls[BUILT_IN_MEMCPY], 3, + fold_convert (pvoid_type_node, tmpdecl), + fold_convert (pvoid_type_node, ptr), + extent); + gfc_add_expr_to_block (&block, tmp); + indirect = gfc_finish_block (&block); + + /* Wrap it up with the condition. */ + tmp = fold_build2 (LE_EXPR, boolean_type_node, + dest_word_len, source_bytes); + tmp = build3_v (COND_EXPR, tmp, direct, indirect); + gfc_add_expr_to_block (&se->pre, tmp); + + se->expr = tmpdecl; + se->string_length = dest_word_len; } else { - tree moldsize; - tmpdecl = gfc_create_var (type, "transfer"); - moldsize = size_in_bytes (type); + tmpdecl = gfc_create_var (mold_type, "transfer"); + + ptr = convert (build_pointer_type (mold_type), source); /* Use memcpy to do the transfer. */ - tmp = fold_build1 (ADDR_EXPR, build_pointer_type (type), tmpdecl); - tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3, + tmp = gfc_build_addr_expr (NULL_TREE, tmpdecl); + tmp = build_call_expr_loc (input_location, + built_in_decls[BUILT_IN_MEMCPY], 3, fold_convert (pvoid_type_node, tmp), fold_convert (pvoid_type_node, ptr), - moldsize); + extent); gfc_add_expr_to_block (&se->pre, tmp); se->expr = tmpdecl; @@ -3601,10 +4522,24 @@ gfc_conv_allocated (gfc_se *se, gfc_expr *expr) gfc_init_se (&arg1se, NULL); arg1 = expr->value.function.actual; ss1 = gfc_walk_expr (arg1->expr); - arg1se.descriptor_only = 1; - gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1); - tmp = gfc_conv_descriptor_data_get (arg1se.expr); + if (ss1 == gfc_ss_terminator) + { + /* Allocatable scalar. */ + arg1se.want_pointer = 1; + if (arg1->expr->ts.type == BT_CLASS) + gfc_add_component_ref (arg1->expr, "$data"); + gfc_conv_expr (&arg1se, arg1->expr); + tmp = arg1se.expr; + } + else + { + /* Allocatable array. */ + arg1se.descriptor_only = 1; + gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1); + tmp = gfc_conv_descriptor_data_get (arg1se.expr); + } + tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp, fold_convert (TREE_TYPE (tmp), null_pointer_node)); se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp); @@ -3633,6 +4568,8 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr) gfc_init_se (&arg1se, NULL); gfc_init_se (&arg2se, NULL); arg1 = expr->value.function.actual; + if (arg1->expr->ts.type == BT_CLASS) + gfc_add_component_ref (arg1->expr, "$data"); arg2 = arg1->next; ss1 = gfc_walk_expr (arg1->expr); @@ -3666,7 +4603,7 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr) nonzero_charlen = NULL_TREE; if (arg1->expr->ts.type == BT_CHARACTER) nonzero_charlen = fold_build2 (NE_EXPR, boolean_type_node, - arg1->expr->ts.cl->backend_decl, + arg1->expr->ts.u.cl->backend_decl, integer_zero_node); if (ss1 == gfc_ss_terminator) @@ -3692,7 +4629,7 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr) present. */ arg1se.descriptor_only = 1; gfc_conv_expr_lhs (&arg1se, arg1->expr); - tmp = gfc_conv_descriptor_stride (arg1se.expr, + tmp = gfc_conv_descriptor_stride_get (arg1se.expr, gfc_rank_cst[arg1->expr->rank - 1]); nonzero_arraylen = fold_build2 (NE_EXPR, boolean_type_node, tmp, build_int_cst (TREE_TYPE (tmp), 0)); @@ -3706,7 +4643,8 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr) gfc_conv_expr_descriptor (&arg2se, arg2->expr, ss2); gfc_add_block_to_block (&se->pre, &arg2se.pre); gfc_add_block_to_block (&se->post, &arg2se.post); - se->expr = build_call_expr (gfor_fndecl_associated, 2, + se->expr = build_call_expr_loc (input_location, + gfor_fndecl_associated, 2, arg1se.expr, arg2se.expr); se->expr = convert (boolean_type_node, se->expr); se->expr = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, @@ -3724,6 +4662,63 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr) } +/* Generate code for the SAME_TYPE_AS intrinsic. + Generate inline code that directly checks the vindices. */ + +static void +gfc_conv_same_type_as (gfc_se *se, gfc_expr *expr) +{ + gfc_expr *a, *b; + gfc_se se1, se2; + tree tmp; + + gfc_init_se (&se1, NULL); + gfc_init_se (&se2, NULL); + + a = expr->value.function.actual->expr; + b = expr->value.function.actual->next->expr; + + if (a->ts.type == BT_CLASS) + { + gfc_add_component_ref (a, "$vptr"); + gfc_add_component_ref (a, "$hash"); + } + else if (a->ts.type == BT_DERIVED) + a = gfc_get_int_expr (gfc_default_integer_kind, NULL, + a->ts.u.derived->hash_value); + + if (b->ts.type == BT_CLASS) + { + gfc_add_component_ref (b, "$vptr"); + gfc_add_component_ref (b, "$hash"); + } + else if (b->ts.type == BT_DERIVED) + b = gfc_get_int_expr (gfc_default_integer_kind, NULL, + b->ts.u.derived->hash_value); + + gfc_conv_expr (&se1, a); + gfc_conv_expr (&se2, b); + + tmp = fold_build2 (EQ_EXPR, boolean_type_node, + se1.expr, fold_convert (TREE_TYPE (se1.expr), se2.expr)); + se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp); +} + + +/* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function. */ + +static void +gfc_conv_intrinsic_sc_kind (gfc_se *se, gfc_expr *expr) +{ + tree args[2]; + + gfc_conv_intrinsic_function_args (se, expr, args, 2); + se->expr = build_call_expr_loc (input_location, + gfor_fndecl_sc_kind, 2, args[0], args[1]); + se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr); +} + + /* Generate code for SELECTED_INT_KIND (R) intrinsic function. */ static void @@ -3735,11 +4730,12 @@ gfc_conv_intrinsic_si_kind (gfc_se *se, gfc_expr *expr) /* The argument to SELECTED_INT_KIND is INTEGER(4). */ type = gfc_get_int_type (4); - arg = build_fold_addr_expr (fold_convert (type, arg)); + arg = gfc_build_addr_expr (NULL_TREE, fold_convert (type, arg)); /* Convert it to the required type. */ type = gfc_typenode_for_spec (&expr->ts); - se->expr = build_call_expr (gfor_fndecl_si_kind, 1, arg); + se->expr = build_call_expr_loc (input_location, + gfor_fndecl_si_kind, 1, arg); se->expr = fold_convert (type, se->expr); } @@ -3764,6 +4760,8 @@ gfc_conv_intrinsic_sr_kind (gfc_se *se, gfc_expr *expr) else { gfc_typespec ts; + gfc_clear_ts (&ts); + if (actual->expr->ts.kind != gfc_c_int_kind) { /* The arguments to SELECTED_REAL_KIND are INTEGER(4). */ @@ -3781,7 +4779,8 @@ gfc_conv_intrinsic_sr_kind (gfc_se *se, gfc_expr *expr) /* Convert it to the required type. */ type = gfc_typenode_for_spec (&expr->ts); - se->expr = build_function_call_expr (gfor_fndecl_sr_kind, args); + se->expr = build_function_call_expr (input_location, + gfor_fndecl_sr_kind, args); se->expr = fold_convert (type, se->expr); } @@ -3791,39 +4790,45 @@ gfc_conv_intrinsic_sr_kind (gfc_se *se, gfc_expr *expr) static void gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr) { - tree gfc_int4_type_node = gfc_get_int_type (4); tree var; tree len; tree addr; tree tmp; - tree type; tree cond; tree fndecl; + tree function; tree *args; unsigned int num_args; num_args = gfc_intrinsic_argument_list_length (expr) + 2; - args = alloca (sizeof (tree) * num_args); + args = (tree *) alloca (sizeof (tree) * num_args); - type = build_pointer_type (gfc_character1_type_node); - var = gfc_create_var (type, "pstr"); + var = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), "pstr"); addr = gfc_build_addr_expr (ppvoid_type_node, var); - len = gfc_create_var (gfc_int4_type_node, "len"); + len = gfc_create_var (gfc_get_int_type (4), "len"); gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2); - args[0] = build_fold_addr_expr (len); + args[0] = gfc_build_addr_expr (NULL_TREE, len); args[1] = addr; - fndecl = build_addr (gfor_fndecl_string_trim, current_function_decl); - tmp = build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_string_trim)), - fndecl, num_args, args); + if (expr->ts.kind == 1) + function = gfor_fndecl_string_trim; + else if (expr->ts.kind == 4) + function = gfor_fndecl_string_trim_char4; + else + gcc_unreachable (); + + fndecl = build_addr (function, current_function_decl); + tmp = build_call_array_loc (input_location, + TREE_TYPE (TREE_TYPE (function)), fndecl, + num_args, args); gfc_add_expr_to_block (&se->pre, tmp); /* Free the temporary afterwards, if necessary. */ cond = fold_build2 (GT_EXPR, boolean_type_node, len, build_int_cst (TREE_TYPE (len), 0)); tmp = gfc_call_free (var); - tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ()); + tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location)); gfc_add_expr_to_block (&se->post, tmp); se->expr = var; @@ -3838,9 +4843,14 @@ gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr) { tree args[3], ncopies, dest, dlen, src, slen, ncopies_type; tree type, cond, tmp, count, exit_label, n, max, largest; + tree size; stmtblock_t block, body; int i; + /* We store in charsize the size of a character. */ + i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false); + size = build_int_cst (size_type_node, gfc_character_kinds[i].bit_size / 8); + /* Get the arguments. */ gfc_conv_intrinsic_function_args (se, expr, args, 3); slen = fold_convert (size_type_node, gfc_evaluate_now (args[0], &se->pre)); @@ -3851,7 +4861,7 @@ gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr) /* Check that NCOPIES is not negative. */ cond = fold_build2 (LT_EXPR, boolean_type_node, ncopies, build_int_cst (ncopies_type, 0)); - gfc_trans_runtime_check (cond, &se->pre, &expr->where, + gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where, "Argument NCOPIES of REPEAT intrinsic is negative " "(its value is %lld)", fold_convert (long_integer_type_node, ncopies)); @@ -3863,7 +4873,7 @@ gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr) build_int_cst (size_type_node, 0)); tmp = fold_build3 (COND_EXPR, ncopies_type, cond, build_int_cst (ncopies_type, 0), ncopies); - gfc_add_modify_expr (&se->pre, n, tmp); + gfc_add_modify (&se->pre, n, tmp); ncopies = n; /* Check that ncopies is not too large: ncopies should be less than @@ -3883,23 +4893,22 @@ gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr) build_int_cst (size_type_node, 0)); cond = fold_build3 (COND_EXPR, boolean_type_node, tmp, boolean_false_node, cond); - gfc_trans_runtime_check (cond, &se->pre, &expr->where, + gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where, "Argument NCOPIES of REPEAT intrinsic is too large"); - /* Compute the destination length. */ dlen = fold_build2 (MULT_EXPR, gfc_charlen_type_node, fold_convert (gfc_charlen_type_node, slen), fold_convert (gfc_charlen_type_node, ncopies)); - type = gfc_get_character_type (expr->ts.kind, expr->ts.cl); + type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl); dest = gfc_conv_string_tmp (se, build_pointer_type (type), dlen); /* Generate the code to do the repeat operation: for (i = 0; i < ncopies; i++) - memmove (dest + (i * slen), src, slen); */ + memmove (dest + (i * slen * size), src, slen*size); */ gfc_start_block (&block); count = gfc_create_var (ncopies_type, "count"); - gfc_add_modify_expr (&block, count, build_int_cst (ncopies_type, 0)); + gfc_add_modify (&block, count, build_int_cst (ncopies_type, 0)); exit_label = gfc_build_label_decl (NULL_TREE); /* Start the loop body. */ @@ -3910,24 +4919,28 @@ gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr) tmp = build1_v (GOTO_EXPR, exit_label); TREE_USED (exit_label) = 1; tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp, - build_empty_stmt ()); + build_empty_stmt (input_location)); gfc_add_expr_to_block (&body, tmp); - /* Call memmove (dest + (i*slen), src, slen). */ + /* Call memmove (dest + (i*slen*size), src, slen*size). */ tmp = fold_build2 (MULT_EXPR, gfc_charlen_type_node, fold_convert (gfc_charlen_type_node, slen), fold_convert (gfc_charlen_type_node, count)); - tmp = fold_build2 (POINTER_PLUS_EXPR, pchar_type_node, - fold_convert (pchar_type_node, dest), + tmp = fold_build2 (MULT_EXPR, gfc_charlen_type_node, + tmp, fold_convert (gfc_charlen_type_node, size)); + tmp = fold_build2 (POINTER_PLUS_EXPR, pvoid_type_node, + fold_convert (pvoid_type_node, dest), fold_convert (sizetype, tmp)); - tmp = build_call_expr (built_in_decls[BUILT_IN_MEMMOVE], 3, - tmp, src, slen); + tmp = build_call_expr_loc (input_location, + built_in_decls[BUILT_IN_MEMMOVE], 3, tmp, src, + fold_build2 (MULT_EXPR, size_type_node, slen, + fold_convert (size_type_node, size))); gfc_add_expr_to_block (&body, tmp); /* Increment count. */ tmp = fold_build2 (PLUS_EXPR, ncopies_type, count, build_int_cst (TREE_TYPE (count), 1)); - gfc_add_modify_expr (&body, count, tmp); + gfc_add_modify (&body, count, tmp); /* Build the loop. */ tmp = build1_v (LOOP_EXPR, gfc_finish_block (&body)); @@ -3958,7 +4971,8 @@ gfc_conv_intrinsic_iargc (gfc_se * se, gfc_expr * expr) /* Call the library function. This always returns an INTEGER(4). */ fndecl = gfor_fndecl_iargc; - tmp = build_call_expr (fndecl, 0); + tmp = build_call_expr_loc (input_location, + fndecl, 0); /* Convert it to the required type. */ type = gfc_typenode_for_spec (&expr->ts); @@ -3985,13 +4999,13 @@ gfc_conv_intrinsic_loc (gfc_se * se, gfc_expr * expr) if (ss == gfc_ss_terminator) gfc_conv_expr_reference (se, arg_expr); else - gfc_conv_array_parameter (se, arg_expr, ss, 1); + gfc_conv_array_parameter (se, arg_expr, ss, true, NULL, NULL, NULL); se->expr= convert (gfc_get_int_type (gfc_index_integer_kind), se->expr); /* Create a temporary variable for loc return value. Without this, we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1). */ temp_var = gfc_create_var (gfc_get_int_type (gfc_index_integer_kind), NULL); - gfc_add_modify_expr (&se->pre, temp_var, se->expr); + gfc_add_modify (&se->pre, temp_var, se->expr); se->expr = temp_var; } @@ -4002,11 +5016,9 @@ gfc_conv_intrinsic_loc (gfc_se * se, gfc_expr * expr) void gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) { - gfc_intrinsic_sym *isym; const char *name; - int lib; - - isym = expr->value.function.isym; + int lib, kind; + tree fndecl; name = &expr->value.function.name[2]; @@ -4017,7 +5029,22 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) { if (lib == 1) se->ignore_optional = 1; - gfc_conv_intrinsic_funcall (se, expr); + + switch (expr->value.function.isym->id) + { + case GFC_ISYM_EOSHIFT: + case GFC_ISYM_PACK: + case GFC_ISYM_RESHAPE: + /* For all of those the first argument specifies the type and the + third is optional. */ + conv_generic_with_optional_char_arg (se, expr, 1, 3); + break; + + default: + gfc_conv_intrinsic_funcall (se, expr); + break; + } + return; } } @@ -4035,6 +5062,10 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) gfc_conv_intrinsic_trim (se, expr); break; + case GFC_ISYM_SC_KIND: + gfc_conv_intrinsic_sc_kind (se, expr); + break; + case GFC_ISYM_SI_KIND: gfc_conv_intrinsic_si_kind (se, expr); break; @@ -4048,11 +5079,27 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) break; case GFC_ISYM_SCAN: - gfc_conv_intrinsic_index_scan_verify (se, expr, gfor_fndecl_string_scan); + kind = expr->value.function.actual->expr->ts.kind; + if (kind == 1) + fndecl = gfor_fndecl_string_scan; + else if (kind == 4) + fndecl = gfor_fndecl_string_scan_char4; + else + gcc_unreachable (); + + gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl); break; case GFC_ISYM_VERIFY: - gfc_conv_intrinsic_index_scan_verify (se, expr, gfor_fndecl_string_verify); + kind = expr->value.function.actual->expr->ts.kind; + if (kind == 1) + fndecl = gfor_fndecl_string_verify; + else if (kind == 4) + fndecl = gfor_fndecl_string_verify_char4; + else + gcc_unreachable (); + + gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl); break; case GFC_ISYM_ALLOCATED: @@ -4063,16 +5110,34 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) gfc_conv_associated(se, expr); break; + case GFC_ISYM_SAME_TYPE_AS: + gfc_conv_same_type_as (se, expr); + break; + case GFC_ISYM_ABS: gfc_conv_intrinsic_abs (se, expr); break; case GFC_ISYM_ADJUSTL: - gfc_conv_intrinsic_adjust (se, expr, gfor_fndecl_adjustl); + if (expr->ts.kind == 1) + fndecl = gfor_fndecl_adjustl; + else if (expr->ts.kind == 4) + fndecl = gfor_fndecl_adjustl_char4; + else + gcc_unreachable (); + + gfc_conv_intrinsic_adjust (se, expr, fndecl); break; case GFC_ISYM_ADJUSTR: - gfc_conv_intrinsic_adjust (se, expr, gfor_fndecl_adjustr); + if (expr->ts.kind == 1) + fndecl = gfor_fndecl_adjustr; + else if (expr->ts.kind == 4) + fndecl = gfor_fndecl_adjustr_char4; + else + gcc_unreachable (); + + gfc_conv_intrinsic_adjust (se, expr, fndecl); break; case GFC_ISYM_AIMAG: @@ -4219,7 +5284,15 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) break; case GFC_ISYM_INDEX: - gfc_conv_intrinsic_index_scan_verify (se, expr, gfor_fndecl_string_index); + kind = expr->value.function.actual->expr->ts.kind; + if (kind == 1) + fndecl = gfor_fndecl_string_index; + else if (kind == 4) + fndecl = gfor_fndecl_string_index_char4; + else + gcc_unreachable (); + + gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl); break; case GFC_ISYM_IOR: @@ -4254,6 +5327,14 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) gfc_conv_intrinsic_ishftc (se, expr); break; + case GFC_ISYM_LEADZ: + gfc_conv_intrinsic_leadz (se, expr); + break; + + case GFC_ISYM_TRAILZ: + gfc_conv_intrinsic_trailz (se, expr); + break; + case GFC_ISYM_LBOUND: gfc_conv_intrinsic_bound (se, expr, 0); break; @@ -4379,17 +5460,11 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) break; case GFC_ISYM_TRANSFER: - if (se->ss) + if (se->ss && se->ss->useflags) { - if (se->ss->useflags) - { - /* Access the previously obtained result. */ - gfc_conv_tmp_array_ref (se); - gfc_advance_se_ss_chain (se); - break; - } - else - gfc_conv_intrinsic_array_transfer (se, expr); + /* Access the previously obtained result. */ + gfc_conv_tmp_array_ref (se); + gfc_advance_se_ss_chain (se); } else gfc_conv_intrinsic_transfer (se, expr); @@ -4416,6 +5491,7 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) case GFC_ISYM_CHMOD: case GFC_ISYM_DTIME: case GFC_ISYM_ETIME: + case GFC_ISYM_EXTENDS_TYPE_OF: case GFC_ISYM_FGET: case GFC_ISYM_FGETC: case GFC_ISYM_FNUM: @@ -4453,6 +5529,14 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) gfc_conv_intrinsic_funcall (se, expr); break; + case GFC_ISYM_EOSHIFT: + case GFC_ISYM_PACK: + case GFC_ISYM_RESHAPE: + /* For those, expr->rank should always be >0 and thus the if above the + switch should have matched. */ + gcc_unreachable (); + break; + default: gfc_conv_intrinsic_lib_function (se, expr); break; @@ -4519,7 +5603,7 @@ gfc_walk_intrinsic_libfunc (gfc_ss * ss, gfc_expr * expr) } -/* Returns nonzero if the specified intrinsic function call maps directly to a +/* Returns nonzero if the specified intrinsic function call maps directly to an external library call. Should only be used for functions that return arrays. */