X-Git-Url: http://git.sourceforge.jp/view?p=pf3gnuchains%2Fgcc-fork.git;a=blobdiff_plain;f=gcc%2Ffortran%2Ftrans-intrinsic.c;h=c10e9e5732f5fa38189f6909080222cac6efbf6c;hp=37a6a05761ed9ab8d52b699729ab71dc49fcb164;hb=b805cd14f8d4d3f8671c9506f07061d675e6bd3a;hpb=260abd713cecaf15b4c8803e4b609a66c6d10656 diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index 37a6a05761e..c10e9e5732f 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -1,5 +1,5 @@ /* Intrinsic translation - Copyright (C) 2002, 2003, 2004 Free Software Foundation, Inc. + Copyright (C) 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc. Contributed by Paul Brook and Steven Bosscher @@ -17,8 +17,8 @@ for more details. You should have received a copy of the GNU General Public License along with GCC; see the file COPYING. If not, write to the Free -Software Foundation, 59 Temple Place - Suite 330, Boston, MA -02111-1307, USA. */ +Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA +02110-1301, USA. */ /* trans-intrinsic.c-- generate GENERIC trees for calls to intrinsics. */ @@ -26,16 +26,13 @@ Software Foundation, 59 Temple Place - Suite 330, Boston, MA #include "system.h" #include "coretypes.h" #include "tree.h" -#include -#include #include "ggc.h" #include "toplev.h" #include "real.h" #include "tree-gimple.h" #include "flags.h" -#include -#include #include "gfortran.h" +#include "arith.h" #include "intrinsic.h" #include "trans.h" #include "trans-const.h" @@ -55,14 +52,18 @@ typedef struct gfc_intrinsic_map_t GTY(()) /* Enum value from the "language-independent", aka C-centric, part of gcc, or END_BUILTINS of no such value set. */ - /* ??? There are now complex variants in builtins.def, though we - don't currently do anything with them. */ - enum built_in_function code4; - enum built_in_function code8; + enum built_in_function code_r4; + enum built_in_function code_r8; + enum built_in_function code_r10; + enum built_in_function code_r16; + enum built_in_function code_c4; + enum built_in_function code_c8; + enum built_in_function code_c10; + enum built_in_function code_c16; /* True if the naming pattern is to prepend "c" for complex and append "f" for kind=4. False if the naming pattern is to - prepend "_gfortran_" and append "[rc][48]". */ + prepend "_gfortran_" and append "[rc](4|8|10|16)". */ bool libm_name; /* True if a complex version of the function exists. */ @@ -77,25 +78,42 @@ typedef struct gfc_intrinsic_map_t GTY(()) /* Cache decls created for the various operand types. */ tree real4_decl; tree real8_decl; + tree real10_decl; + tree real16_decl; tree complex4_decl; tree complex8_decl; + tree complex10_decl; + tree complex16_decl; } gfc_intrinsic_map_t; /* ??? The NARGS==1 hack here is based on the fact that (c99 at least) defines complex variants of all of the entries in mathbuiltins.def except for atan2. */ -#define DEFINE_MATH_BUILTIN(ID, NAME, NARGS) \ - { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, true, \ - NARGS == 1, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE}, +#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}, + +#define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE) \ + { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \ + BUILT_IN_ ## ID ## L, BUILT_IN_ ## ID ## L, BUILT_IN_C ## ID ## F, \ + BUILT_IN_C ## ID, BUILT_IN_C ## ID ## L, BUILT_IN_C ## ID ## L, true, \ + true, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \ + NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE}, #define LIBM_FUNCTION(ID, NAME, HAVE_COMPLEX) \ - { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, true, HAVE_COMPLEX, true, \ - NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE } + { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, END_BUILTINS, \ + END_BUILTINS, END_BUILTINS, END_BUILTINS, END_BUILTINS, \ + true, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \ + NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE } #define LIBF_FUNCTION(ID, NAME, HAVE_COMPLEX) \ - { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, false, HAVE_COMPLEX, true, \ - NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE } + { 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[] = { @@ -111,12 +129,15 @@ static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map[] = /* Functions in libgfortran. */ LIBF_FUNCTION (FRACTION, "fraction", false), LIBF_FUNCTION (NEAREST, "nearest", false), + LIBF_FUNCTION (RRSPACING, "rrspacing", false), LIBF_FUNCTION (SET_EXPONENT, "set_exponent", false), + LIBF_FUNCTION (SPACING, "spacing", false), /* End the list. */ LIBF_FUNCTION (NONE, NULL, false) }; #undef DEFINE_MATH_BUILTIN +#undef DEFINE_MATH_BUILTIN_C #undef LIBM_FUNCTION #undef LIBF_FUNCTION @@ -124,14 +145,14 @@ static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map[] = elemental functions to manipulate reals. */ typedef struct { - tree arg; /* Variable tree to view convert to integer. */ + tree arg; /* Variable tree to view convert to integer. */ tree expn; /* Variable tree to save exponent. */ tree frac; /* Variable tree to save fraction. */ tree smask; /* Constant tree of sign's mask. */ tree emask; /* Constant tree of exponent's mask. */ tree fmask; /* Constant tree of fraction's mask. */ - tree edigits; /* Constant tree of bit numbers of exponent. */ - tree fdigits; /* Constant tree of bit numbers of fraction. */ + tree edigits; /* Constant tree of the number of exponent bits. */ + tree fdigits; /* Constant tree of the number of fraction bits. */ tree f1; /* Constant tree of the f1 defined in the real model. */ tree bias; /* Constant tree of the bias of exponent in the memory. */ tree type; /* Type tree of arg1. */ @@ -139,6 +160,7 @@ typedef struct } real_compnt_info; +enum rounding_mode { RND_ROUND, RND_TRUNC, RND_CEIL, RND_FLOOR }; /* Evaluate the arguments to an intrinsic function. */ @@ -146,28 +168,42 @@ static tree gfc_conv_intrinsic_function_args (gfc_se * se, gfc_expr * expr) { gfc_actual_arglist *actual; - tree args; + gfc_expr *e; + gfc_intrinsic_arg *formal; gfc_se argse; + tree args; args = NULL_TREE; - for (actual = expr->value.function.actual; actual; actual = actual->next) + formal = expr->value.function.isym->formal; + + for (actual = expr->value.function.actual; actual; actual = actual->next, + formal = formal ? formal->next : NULL) { - /* Skip ommitted optional arguments. */ - if (!actual->expr) + e = actual->expr; + /* Skip omitted optional arguments. */ + if (!e) continue; /* Evaluate the parameter. This will substitute scalarized - references automatically. */ + references automatically. */ gfc_init_se (&argse, se); - if (actual->expr->ts.type == BT_CHARACTER) + if (e->ts.type == BT_CHARACTER) { - gfc_conv_expr (&argse, actual->expr); + gfc_conv_expr (&argse, e); gfc_conv_string_parameter (&argse); args = gfc_chainon_list (args, argse.string_length); } else - gfc_conv_expr_val (&argse, actual->expr); + gfc_conv_expr_val (&argse, e); + + /* If an optional argument is itself an optional dummy argument, + check its presence and substitute a null if absent. */ + if (e->expr_type ==EXPR_VARIABLE + && e->symtree->n.sym->attr.optional + && formal + && formal->optional) + gfc_conv_missing_dummy (&argse, e, formal->ts); gfc_add_block_to_block (&se->pre, &argse.pre); gfc_add_block_to_block (&se->post, &argse.post); @@ -188,7 +224,7 @@ gfc_conv_intrinsic_conversion (gfc_se * se, gfc_expr * expr) /* Evaluate the argument. */ type = gfc_typenode_for_spec (&expr->ts); - assert (expr->value.function.actual->expr); + gcc_assert (expr->value.function.actual->expr); arg = gfc_conv_intrinsic_function_args (se, expr); arg = TREE_VALUE (arg); @@ -206,9 +242,9 @@ gfc_conv_intrinsic_conversion (gfc_se * se, gfc_expr * expr) se->expr = convert (type, arg); } - -/* This is needed because the gcc backend only implements FIX_TRUNC_EXPR - TRUNC(x) = INT(x) <= x ? INT(x) : INT(x) - 1 +/* This is needed because the gcc backend only implements + FIX_TRUNC_EXPR, which is the same as INT() in Fortran. + FLOOR(x) = INT(x) <= x ? INT(x) : INT(x) - 1 Similarly for CEILING. */ static tree @@ -226,11 +262,11 @@ build_fixbound_expr (stmtblock_t * pblock, tree arg, tree type, int up) intval = gfc_evaluate_now (intval, pblock); tmp = convert (argtype, intval); - cond = build (up ? GE_EXPR : LE_EXPR, boolean_type_node, tmp, arg); + cond = build2 (up ? GE_EXPR : LE_EXPR, boolean_type_node, tmp, arg); - tmp = build (up ? PLUS_EXPR : MINUS_EXPR, type, intval, - convert (type, integer_one_node)); - tmp = build (COND_EXPR, type, cond, intval, tmp); + tmp = build2 (up ? PLUS_EXPR : MINUS_EXPR, type, intval, + build_int_cst (type, 1)); + tmp = build3 (COND_EXPR, type, cond, intval, tmp); return tmp; } @@ -258,11 +294,11 @@ build_round_expr (stmtblock_t * pblock, tree arg, tree type) neg = build_real (argtype, r); tmp = gfc_build_const (argtype, integer_zero_node); - cond = fold (build (GT_EXPR, boolean_type_node, arg, tmp)); + cond = fold_build2 (GT_EXPR, boolean_type_node, arg, tmp); - tmp = fold (build (COND_EXPR, argtype, cond, pos, neg)); - tmp = fold (build (PLUS_EXPR, argtype, arg, tmp)); - return fold (build1 (FIX_TRUNC_EXPR, type, tmp)); + tmp = fold_build3 (COND_EXPR, argtype, cond, pos, neg); + tmp = fold_build2 (PLUS_EXPR, argtype, arg, tmp); + return fold_build1 (FIX_TRUNC_EXPR, type, tmp); } @@ -271,44 +307,47 @@ build_round_expr (stmtblock_t * pblock, tree arg, tree type) however the RTL expander only actually supports FIX_TRUNC_EXPR. */ static tree -build_fix_expr (stmtblock_t * pblock, tree arg, tree type, int op) +build_fix_expr (stmtblock_t * pblock, tree arg, tree type, + enum rounding_mode op) { switch (op) { - case FIX_FLOOR_EXPR: + case RND_FLOOR: return build_fixbound_expr (pblock, arg, type, 0); break; - case FIX_CEIL_EXPR: + case RND_CEIL: return build_fixbound_expr (pblock, arg, type, 1); break; - case FIX_ROUND_EXPR: + case RND_ROUND: return build_round_expr (pblock, arg, type); default: - return build1 (op, type, arg); + gcc_assert (op == RND_TRUNC); + return build1 (FIX_TRUNC_EXPR, type, arg); } } /* Round a real value using the specified rounding mode. We use a temporary integer of that same kind size as the result. - Values larger than can be represented by this kind are unchanged, as - will not be accurate enough to represent the rounding. + Values larger than those that can be represented by this kind are + unchanged, as they will not be accurate enough to represent the + rounding. huge = HUGE (KIND (a)) aint (a) = ((a > huge) || (a < -huge)) ? a : (real)(int)a */ static void -gfc_conv_intrinsic_aint (gfc_se * se, gfc_expr * expr, int op) +gfc_conv_intrinsic_aint (gfc_se * se, gfc_expr * expr, enum rounding_mode op) { tree type; tree itype; tree arg; tree tmp; tree cond; - mpf_t huge; + mpfr_t huge; int n; int kind; @@ -318,7 +357,7 @@ gfc_conv_intrinsic_aint (gfc_se * se, gfc_expr * expr, int op) /* We have builtin functions for some cases. */ switch (op) { - case FIX_ROUND_EXPR: + case RND_ROUND: switch (kind) { case 4: @@ -328,31 +367,45 @@ gfc_conv_intrinsic_aint (gfc_se * se, gfc_expr * expr, int op) case 8: n = BUILT_IN_ROUND; break; + + case 10: + case 16: + n = BUILT_IN_ROUNDL; + break; } break; - case FIX_FLOOR_EXPR: + case RND_TRUNC: switch (kind) { case 4: - n = BUILT_IN_FLOORF; + n = BUILT_IN_TRUNCF; break; case 8: - n = BUILT_IN_FLOOR; + n = BUILT_IN_TRUNC; + break; + + case 10: + case 16: + n = BUILT_IN_TRUNCL; break; } + break; + + default: + gcc_unreachable (); } /* Evaluate the argument. */ - assert (expr->value.function.actual->expr); + gcc_assert (expr->value.function.actual->expr); arg = gfc_conv_intrinsic_function_args (se, expr); /* Use a builtin function if one exists. */ if (n != END_BUILTINS) { tmp = built_in_decls[n]; - se->expr = gfc_build_function_call (tmp, arg); + se->expr = build_function_call_expr (tmp, arg); return; } @@ -363,35 +416,37 @@ gfc_conv_intrinsic_aint (gfc_se * se, gfc_expr * expr, int op) arg = gfc_evaluate_now (arg, &se->pre); /* Test if the value is too large to handle sensibly. */ - mpf_init (huge); - n = gfc_validate_kind (BT_INTEGER, kind); - mpf_set_z (huge, gfc_integer_kinds[n].huge); - tmp = gfc_conv_mpf_to_tree (huge, kind); - cond = build (LT_EXPR, boolean_type_node, arg, tmp); - - mpf_neg (huge, huge); - tmp = gfc_conv_mpf_to_tree (huge, kind); - tmp = build (GT_EXPR, boolean_type_node, arg, tmp); - cond = build (TRUTH_AND_EXPR, boolean_type_node, cond, tmp); + gfc_set_model_kind (kind); + 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); + cond = build2 (LT_EXPR, boolean_type_node, arg, tmp); + + mpfr_neg (huge, huge, GFC_RND_MODE); + tmp = gfc_conv_mpfr_to_tree (huge, kind); + tmp = build2 (GT_EXPR, boolean_type_node, arg, tmp); + cond = build2 (TRUTH_AND_EXPR, boolean_type_node, cond, tmp); itype = gfc_get_int_type (kind); tmp = build_fix_expr (&se->pre, arg, itype, op); tmp = convert (type, tmp); - se->expr = build (COND_EXPR, type, cond, tmp, arg); + se->expr = build3 (COND_EXPR, type, cond, tmp, arg); + mpfr_clear (huge); } /* Convert to an integer using the specified rounding mode. */ static void -gfc_conv_intrinsic_int (gfc_se * se, gfc_expr * expr, int op) +gfc_conv_intrinsic_int (gfc_se * se, gfc_expr * expr, enum rounding_mode op) { tree type; tree arg; /* Evaluate the argument. */ type = gfc_typenode_for_spec (&expr->ts); - assert (expr->value.function.actual->expr); + gcc_assert (expr->value.function.actual->expr); arg = gfc_conv_intrinsic_function_args (se, expr); arg = TREE_VALUE (arg); @@ -455,10 +510,22 @@ gfc_build_intrinsic_lib_fndecls (void) /* Add GCC builtin functions. */ for (m = gfc_intrinsic_map; m->id != GFC_ISYM_NONE; m++) { - if (m->code4 != END_BUILTINS) - m->real4_decl = built_in_decls[m->code4]; - if (m->code8 != END_BUILTINS) - m->real8_decl = built_in_decls[m->code8]; + if (m->code_r4 != END_BUILTINS) + m->real4_decl = built_in_decls[m->code_r4]; + if (m->code_r8 != END_BUILTINS) + m->real8_decl = built_in_decls[m->code_r8]; + if (m->code_r10 != END_BUILTINS) + m->real10_decl = built_in_decls[m->code_r10]; + if (m->code_r16 != END_BUILTINS) + m->real16_decl = built_in_decls[m->code_r16]; + if (m->code_c4 != END_BUILTINS) + m->complex4_decl = built_in_decls[m->code_c4]; + if (m->code_c8 != END_BUILTINS) + m->complex8_decl = built_in_decls[m->code_c8]; + if (m->code_c10 != END_BUILTINS) + m->complex10_decl = built_in_decls[m->code_c10]; + if (m->code_c16 != END_BUILTINS) + m->complex16_decl = built_in_decls[m->code_c16]; } } @@ -487,14 +554,19 @@ gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t * m, gfc_expr * expr) case 8: pdecl = &m->real8_decl; break; + case 10: + pdecl = &m->real10_decl; + break; + case 16: + pdecl = &m->real16_decl; + break; default: - abort (); + gcc_unreachable (); } } else if (ts->type == BT_COMPLEX) { - if (!m->complex_available) - abort (); + gcc_assert (m->complex_available); switch (ts->kind) { @@ -504,24 +576,36 @@ gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t * m, gfc_expr * expr) case 8: pdecl = &m->complex8_decl; break; + case 10: + pdecl = &m->complex10_decl; + break; + case 16: + pdecl = &m->complex16_decl; + break; default: - abort (); + gcc_unreachable (); } } else - abort (); + gcc_unreachable (); if (*pdecl) return *pdecl; if (m->libm_name) { - if (ts->kind != 4 && ts->kind != 8) - abort (); - snprintf (name, sizeof (name), "%s%s%s", - ts->type == BT_COMPLEX ? "c" : "", - m->name, - ts->kind == 4 ? "f" : ""); + if (ts->kind == 4) + snprintf (name, sizeof (name), "%s%s%s", + ts->type == BT_COMPLEX ? "c" : "", m->name, "f"); + else if (ts->kind == 8) + snprintf (name, sizeof (name), "%s%s", + ts->type == BT_COMPLEX ? "c" : "", m->name); + else + { + gcc_assert (ts->kind == 10 || ts->kind == 16); + snprintf (name, sizeof (name), "%s%s%s", + ts->type == BT_COMPLEX ? "c" : "", m->name, "l"); + } } else { @@ -547,7 +631,7 @@ gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t * m, gfc_expr * expr) /* Mark it __attribute__((const)), if possible. */ TREE_READONLY (fndecl) = m->is_constant; - rest_of_decl_compilation (fndecl, NULL, 1, 0); + rest_of_decl_compilation (fndecl, 1, 0); (*pdecl) = fndecl; return fndecl; @@ -581,7 +665,7 @@ gfc_conv_intrinsic_lib_function (gfc_se * se, gfc_expr * expr) /* Get the decl and generate the call. */ args = gfc_conv_intrinsic_function_args (se, expr); fndecl = gfc_get_intrinsic_lib_fndecl (m, expr); - se->expr = gfc_build_function_call (fndecl, args); + se->expr = build_function_call_expr (fndecl, args); } /* Generate code for EXPONENT(X) intrinsic function. */ @@ -603,15 +687,21 @@ gfc_conv_intrinsic_exponent (gfc_se * se, gfc_expr * expr) case 8: fndecl = gfor_fndecl_math_exponent8; break; + case 10: + fndecl = gfor_fndecl_math_exponent10; + break; + case 16: + fndecl = gfor_fndecl_math_exponent16; + break; default: - abort (); + gcc_unreachable (); } - se->expr = gfc_build_function_call (fndecl, args); + se->expr = build_function_call_expr (fndecl, args); } /* Evaluate a single upper or lower bound. */ -/* TODO: bound intrinsic generates way too much unneccessary code. */ +/* TODO: bound intrinsic generates way too much unnecessary code. */ static void gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper) @@ -622,44 +712,46 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper) tree type; tree bound; tree tmp; - tree cond; + tree cond, cond1, cond2, cond3, cond4, size; + tree ubound; + tree lbound; gfc_se argse; gfc_ss *ss; - int i; + gfc_array_spec * as; + gfc_ref *ref; - gfc_init_se (&argse, NULL); arg = expr->value.function.actual; arg2 = arg->next; if (se->ss) { /* Create an implicit second parameter from the loop variable. */ - assert (!arg2->expr); - assert (se->loop->dimen == 1); - assert (se->ss->expr == expr); + gcc_assert (!arg2->expr); + gcc_assert (se->loop->dimen == 1); + gcc_assert (se->ss->expr == expr); gfc_advance_se_ss_chain (se); bound = se->loop->loopvar[0]; - bound = fold (build (MINUS_EXPR, gfc_array_index_type, bound, - se->loop->from[0])); + bound = fold_build2 (MINUS_EXPR, gfc_array_index_type, bound, + se->loop->from[0]); } else { /* use the passed argument. */ - assert (arg->next->expr); + gcc_assert (arg->next->expr); gfc_init_se (&argse, NULL); gfc_conv_expr_type (&argse, arg->next->expr, gfc_array_index_type); gfc_add_block_to_block (&se->pre, &argse.pre); bound = argse.expr; /* Convert from one based to zero based. */ - bound = fold (build (MINUS_EXPR, gfc_array_index_type, bound, - gfc_index_one_node)); + bound = fold_build2 (MINUS_EXPR, gfc_array_index_type, bound, + gfc_index_one_node); } /* TODO: don't re-evaluate the descriptor on each iteration. */ /* Get a descriptor for the first parameter. */ ss = gfc_walk_expr (arg->expr); - assert (ss != gfc_ss_terminator); - argse.want_pointer = 0; + gcc_assert (ss != gfc_ss_terminator); + gfc_init_se (&argse, NULL); gfc_conv_expr_descriptor (&argse, arg->expr, ss); gfc_add_block_to_block (&se->pre, &argse.pre); gfc_add_block_to_block (&se->post, &argse.post); @@ -668,28 +760,138 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper) if (INTEGER_CST_P (bound)) { - assert (TREE_INT_CST_HIGH (bound) == 0); - i = TREE_INT_CST_LOW (bound); - assert (i >= 0 && i < GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))); + int hi, low; + + hi = TREE_INT_CST_HIGH (bound); + low = TREE_INT_CST_LOW (bound); + if (hi || low < 0 || low >= GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))) + gfc_error ("'dim' argument of %s intrinsic at %L is not a valid " + "dimension index", upper ? "UBOUND" : "LBOUND", + &expr->where); } else { if (flag_bounds_check) { bound = gfc_evaluate_now (bound, &se->pre); - cond = fold (build (LT_EXPR, boolean_type_node, bound, - convert (TREE_TYPE (bound), integer_zero_node))); + cond = fold_build2 (LT_EXPR, boolean_type_node, + bound, build_int_cst (TREE_TYPE (bound), 0)); tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))]; - tmp = fold (build (GE_EXPR, boolean_type_node, bound, tmp)); - cond = fold(build (TRUTH_ORIF_EXPR, boolean_type_node, cond, tmp)); - gfc_trans_runtime_check (cond, gfc_strconst_fault, &se->pre); + 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, gfc_msg_fault, &se->pre, &expr->where); } } - if (upper) - se->expr = gfc_conv_descriptor_ubound(desc, bound); + ubound = gfc_conv_descriptor_ubound (desc, bound); + lbound = gfc_conv_descriptor_lbound (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; + + /* 13.14.53: Result value for LBOUND + + Case (i): For an array section or for an array expression other than a + whole array or array structure component, LBOUND(ARRAY, DIM) + has the value 1. For a whole array or array structure + component, LBOUND(ARRAY, DIM) has the value: + (a) equal to the lower bound for subscript DIM of ARRAY if + dimension DIM of ARRAY does not have extent zero + or if ARRAY is an assumed-size array of rank DIM, + or (b) 1 otherwise. + + 13.14.113: Result value for UBOUND + + Case (i): For an array section or for an array expression other than a + whole array or array structure component, UBOUND(ARRAY, DIM) + has the value equal to the number of elements in the given + dimension; otherwise, it has a value equal to the upper bound + for subscript DIM of ARRAY if dimension DIM of ARRAY does + not have size zero and has value zero if dimension DIM has + size zero. */ + + if (as) + { + tree stride = gfc_conv_descriptor_stride (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); + cond3 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, cond3, cond1); + + 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) + { + cond = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond3, cond4); + + se->expr = fold_build3 (COND_EXPR, gfc_array_index_type, cond, + ubound, gfc_index_zero_node); + } + else + { + if (as->type == AS_ASSUMED_SIZE) + cond = fold_build2 (EQ_EXPR, boolean_type_node, bound, + build_int_cst (TREE_TYPE (bound), + arg->expr->rank - 1)); + else + cond = boolean_false_node; + + cond1 = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond3, cond4); + cond = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond, cond1); + + se->expr = fold_build3 (COND_EXPR, gfc_array_index_type, cond, + lbound, gfc_index_one_node); + } + } else - se->expr = gfc_conv_descriptor_lbound(desc, bound); + { + if (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); + } + else + se->expr = gfc_index_one_node; + } type = gfc_typenode_for_spec (&expr->ts); se->expr = convert (type, se->expr); @@ -701,10 +903,10 @@ gfc_conv_intrinsic_abs (gfc_se * se, gfc_expr * expr) { tree args; tree val; - tree fndecl; + int n; args = gfc_conv_intrinsic_function_args (se, expr); - assert (args && TREE_CHAIN (args) == NULL_TREE); + gcc_assert (args && TREE_CHAIN (args) == NULL_TREE); val = TREE_VALUE (args); switch (expr->value.function.actual->expr->ts.type) @@ -718,19 +920,23 @@ gfc_conv_intrinsic_abs (gfc_se * se, gfc_expr * expr) switch (expr->ts.kind) { case 4: - fndecl = gfor_fndecl_math_cabsf; + n = BUILT_IN_CABSF; break; case 8: - fndecl = gfor_fndecl_math_cabs; + n = BUILT_IN_CABS; + break; + case 10: + case 16: + n = BUILT_IN_CABSL; break; default: - abort (); + gcc_unreachable (); } - se->expr = gfc_build_function_call (fndecl, args); + se->expr = build_function_call_expr (built_in_decls[n], args); break; default: - abort (); + gcc_unreachable (); } } @@ -759,11 +965,11 @@ gfc_conv_intrinsic_cmplx (gfc_se * se, gfc_expr * expr, int both) else imag = build_real_from_int_cst (TREE_TYPE (type), integer_zero_node); - se->expr = fold (build (COMPLEX_EXPR, type, real, imag)); + se->expr = fold_build2 (COMPLEX_EXPR, type, real, imag); } -/* Remainder function MOD(A, P) = A - INT(A / P) * P. - MODULO(A, P) = (A==0 .or. !(A>0 .xor. P>0))? MOD(A,P):MOD(A,P)+P. */ +/* Remainder function MOD(A, P) = A - INT(A / P) * P + MODULO(A, P) = A - FLOOR (A / P) * P */ /* TODO: MOD(x, 0) */ static void @@ -774,68 +980,124 @@ gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo) tree type; tree itype; tree tmp; - tree zero; tree test; tree test2; - mpf_t huge; - int n; + mpfr_t huge; + int n, ikind; arg = gfc_conv_intrinsic_function_args (se, expr); - arg2 = TREE_VALUE (TREE_CHAIN (arg)); - arg = TREE_VALUE (arg); - type = TREE_TYPE (arg); switch (expr->ts.type) { case BT_INTEGER: /* Integer case is easy, we've got a builtin op. */ - se->expr = build (TRUNC_MOD_EXPR, type, arg, arg2); + arg2 = TREE_VALUE (TREE_CHAIN (arg)); + arg = TREE_VALUE (arg); + type = TREE_TYPE (arg); + + if (modulo) + se->expr = build2 (FLOOR_MOD_EXPR, type, arg, arg2); + else + se->expr = build2 (TRUNC_MOD_EXPR, type, arg, arg2); break; case BT_REAL: - /* Real values we have to do the hard way. */ + n = END_BUILTINS; + /* Check if we have a builtin fmod. */ + switch (expr->ts.kind) + { + case 4: + n = BUILT_IN_FMODF; + break; + + case 8: + n = BUILT_IN_FMOD; + break; + + case 10: + case 16: + n = BUILT_IN_FMODL; + break; + + default: + break; + } + + /* Use it if it exists. */ + if (n != END_BUILTINS) + { + tmp = built_in_decls[n]; + se->expr = build_function_call_expr (tmp, arg); + if (modulo == 0) + return; + } + + arg2 = TREE_VALUE (TREE_CHAIN (arg)); + arg = TREE_VALUE (arg); + type = TREE_TYPE (arg); + arg = gfc_evaluate_now (arg, &se->pre); arg2 = gfc_evaluate_now (arg2, &se->pre); - tmp = build (RDIV_EXPR, type, arg, arg2); + /* Definition: + modulo = arg - floor (arg/arg2) * arg2, so + = test ? fmod (arg, arg2) : fmod (arg, arg2) + arg2, + where + test = (fmod (arg, arg2) != 0) && ((arg < 0) xor (arg2 < 0)) + thereby avoiding another division and retaining the accuracy + of the builtin function. */ + if (n != END_BUILTINS && modulo) + { + tree zero = gfc_build_const (type, integer_zero_node); + tmp = gfc_evaluate_now (se->expr, &se->pre); + test = build2 (LT_EXPR, boolean_type_node, arg, zero); + test2 = build2 (LT_EXPR, boolean_type_node, arg2, zero); + test2 = build2 (TRUTH_XOR_EXPR, boolean_type_node, test, test2); + test = build2 (NE_EXPR, boolean_type_node, tmp, zero); + test = build2 (TRUTH_AND_EXPR, boolean_type_node, test, test2); + test = gfc_evaluate_now (test, &se->pre); + se->expr = build3 (COND_EXPR, type, test, + build2 (PLUS_EXPR, type, tmp, arg2), tmp); + return; + } + + /* If we do not have a built_in fmod, the calculation is going to + have to be done longhand. */ + tmp = build2 (RDIV_EXPR, type, arg, arg2); + /* Test if the value is too large to handle sensibly. */ - mpf_init (huge); - n = gfc_validate_kind (BT_INTEGER, expr->ts.kind); - mpf_set_z (huge, gfc_integer_kinds[n].huge); - test = gfc_conv_mpf_to_tree (huge, expr->ts.kind); - test2 = build (LT_EXPR, boolean_type_node, tmp, test); - - mpf_neg (huge, huge); - test = gfc_conv_mpf_to_tree (huge, expr->ts.kind); - test = build (GT_EXPR, boolean_type_node, tmp, test); - test2 = build (TRUTH_AND_EXPR, boolean_type_node, test, test2); - - itype = gfc_get_int_type (expr->ts.kind); - tmp = build_fix_expr (&se->pre, tmp, itype, FIX_TRUNC_EXPR); + gfc_set_model_kind (expr->ts.kind); + mpfr_init (huge); + n = gfc_validate_kind (BT_INTEGER, expr->ts.kind, true); + ikind = expr->ts.kind; + if (n < 0) + { + n = gfc_validate_kind (BT_INTEGER, gfc_max_integer_kind, false); + 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); + test2 = 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 = build2 (GT_EXPR, boolean_type_node, tmp, test); + test2 = build2 (TRUTH_AND_EXPR, boolean_type_node, test, test2); + + itype = gfc_get_int_type (ikind); + if (modulo) + tmp = build_fix_expr (&se->pre, tmp, itype, RND_FLOOR); + else + tmp = build_fix_expr (&se->pre, tmp, itype, RND_TRUNC); tmp = convert (type, tmp); - tmp = build (COND_EXPR, type, test2, tmp, arg); - tmp = build (MULT_EXPR, type, tmp, arg2); - se->expr = build (MINUS_EXPR, type, arg, tmp); + tmp = build3 (COND_EXPR, type, test2, tmp, arg); + tmp = build2 (MULT_EXPR, type, tmp, arg2); + se->expr = build2 (MINUS_EXPR, type, arg, tmp); + mpfr_clear (huge); break; default: - abort (); - } - - if (modulo) - { - zero = gfc_build_const (type, integer_zero_node); - /* Build !(A > 0 .xor. P > 0). */ - test = build (GT_EXPR, boolean_type_node, arg, zero); - test2 = build (GT_EXPR, boolean_type_node, arg2, zero); - test = build (TRUTH_XOR_EXPR, boolean_type_node, test, test2); - test = build1 (TRUTH_NOT_EXPR, boolean_type_node, test); - /* Build (A == 0) .or. !(A > 0 .xor. P > 0). */ - test2 = build (EQ_EXPR, boolean_type_node, arg, zero); - test = build (TRUTH_OR_EXPR, boolean_type_node, test, test2); - - se->expr = build (COND_EXPR, type, test, se->expr, - build (PLUS_EXPR, type, se->expr, arg2)); + gcc_unreachable (); } } @@ -856,12 +1118,12 @@ gfc_conv_intrinsic_dim (gfc_se * se, gfc_expr * expr) arg = TREE_VALUE (arg); type = TREE_TYPE (arg); - val = build (MINUS_EXPR, type, arg, arg2); + val = build2 (MINUS_EXPR, type, arg, arg2); val = gfc_evaluate_now (val, &se->pre); zero = gfc_build_const (type, integer_zero_node); - tmp = build (LE_EXPR, boolean_type_node, val, zero); - se->expr = build (COND_EXPR, type, tmp, zero, val); + tmp = build2 (LE_EXPR, boolean_type_node, val, zero); + se->expr = build3 (COND_EXPR, type, tmp, zero, val); } @@ -889,15 +1151,19 @@ gfc_conv_intrinsic_sign (gfc_se * se, gfc_expr * expr) switch (expr->ts.kind) { case 4: - tmp = gfor_fndecl_math_sign4; + tmp = built_in_decls[BUILT_IN_COPYSIGNF]; break; case 8: - tmp = gfor_fndecl_math_sign8; + tmp = built_in_decls[BUILT_IN_COPYSIGN]; + break; + case 10: + case 16: + tmp = built_in_decls[BUILT_IN_COPYSIGNL]; break; default: - abort (); + gcc_unreachable (); } - se->expr = gfc_build_function_call (tmp, arg); + se->expr = build_function_call_expr (tmp, arg); return; } @@ -906,11 +1172,11 @@ gfc_conv_intrinsic_sign (gfc_se * se, gfc_expr * expr) type = TREE_TYPE (arg); zero = gfc_build_const (type, integer_zero_node); - testa = fold (build (GE_EXPR, boolean_type_node, arg, zero)); - testb = fold (build (GE_EXPR, boolean_type_node, arg2, zero)); - tmp = fold (build (TRUTH_XOR_EXPR, boolean_type_node, testa, testb)); - se->expr = fold (build (COND_EXPR, type, tmp, - build1 (NEGATE_EXPR, type, arg), arg)); + testa = fold_build2 (GE_EXPR, boolean_type_node, arg, zero); + testb = fold_build2 (GE_EXPR, boolean_type_node, arg2, zero); + tmp = fold_build2 (TRUTH_XOR_EXPR, boolean_type_node, testa, testb); + se->expr = fold_build3 (COND_EXPR, type, tmp, + build1 (NEGATE_EXPR, type, arg), arg); } @@ -922,7 +1188,7 @@ gfc_conv_intrinsic_present (gfc_se * se, gfc_expr * expr) gfc_expr *arg; arg = expr->value.function.actual->expr; - assert (arg->expr_type == EXPR_VARIABLE); + gcc_assert (arg->expr_type == EXPR_VARIABLE); se->expr = gfc_conv_expr_present (arg->symtree->n.sym); se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr); } @@ -945,7 +1211,7 @@ gfc_conv_intrinsic_dprod (gfc_se * se, gfc_expr * expr) type = gfc_typenode_for_spec (&expr->ts); arg = convert (type, arg); arg2 = convert (type, arg2); - se->expr = build (MULT_EXPR, type, arg, arg2); + se->expr = build2 (MULT_EXPR, type, arg, arg2); } @@ -962,7 +1228,7 @@ gfc_conv_intrinsic_char (gfc_se * se, gfc_expr * expr) arg = TREE_VALUE (arg); /* We currently don't support character types != 1. */ - assert (expr->ts.kind == 1); + gcc_assert (expr->ts.kind == 1); type = gfc_character1_type_node; var = gfc_create_var (type, "char"); @@ -973,6 +1239,116 @@ gfc_conv_intrinsic_char (gfc_se * se, gfc_expr * expr) } +static void +gfc_conv_intrinsic_ctime (gfc_se * se, gfc_expr * expr) +{ + tree var; + tree len; + tree tmp; + tree arglist; + tree type; + tree cond; + tree gfc_int8_type_node = gfc_get_int_type (8); + + type = build_pointer_type (gfc_character1_type_node); + var = gfc_create_var (type, "pstr"); + len = gfc_create_var (gfc_int8_type_node, "len"); + + tmp = gfc_conv_intrinsic_function_args (se, expr); + arglist = gfc_chainon_list (NULL_TREE, build_fold_addr_expr (var)); + arglist = gfc_chainon_list (arglist, build_fold_addr_expr (len)); + arglist = chainon (arglist, tmp); + + tmp = build_function_call_expr (gfor_fndecl_ctime, arglist); + gfc_add_expr_to_block (&se->pre, tmp); + + /* Free the temporary afterwards, if necessary. */ + cond = build2 (GT_EXPR, boolean_type_node, len, + build_int_cst (TREE_TYPE (len), 0)); + arglist = gfc_chainon_list (NULL_TREE, var); + tmp = build_function_call_expr (gfor_fndecl_internal_free, arglist); + tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ()); + gfc_add_expr_to_block (&se->post, tmp); + + se->expr = var; + se->string_length = len; +} + + +static void +gfc_conv_intrinsic_fdate (gfc_se * se, gfc_expr * expr) +{ + tree var; + tree len; + tree tmp; + tree arglist; + tree type; + tree cond; + tree gfc_int4_type_node = gfc_get_int_type (4); + + type = build_pointer_type (gfc_character1_type_node); + var = gfc_create_var (type, "pstr"); + len = gfc_create_var (gfc_int4_type_node, "len"); + + tmp = gfc_conv_intrinsic_function_args (se, expr); + arglist = gfc_chainon_list (NULL_TREE, build_fold_addr_expr (var)); + arglist = gfc_chainon_list (arglist, build_fold_addr_expr (len)); + arglist = chainon (arglist, tmp); + + tmp = build_function_call_expr (gfor_fndecl_fdate, arglist); + gfc_add_expr_to_block (&se->pre, tmp); + + /* Free the temporary afterwards, if necessary. */ + cond = build2 (GT_EXPR, boolean_type_node, len, + build_int_cst (TREE_TYPE (len), 0)); + arglist = gfc_chainon_list (NULL_TREE, var); + tmp = build_function_call_expr (gfor_fndecl_internal_free, arglist); + tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ()); + gfc_add_expr_to_block (&se->post, tmp); + + se->expr = var; + se->string_length = len; +} + + +/* Return a character string containing the tty name. */ + +static void +gfc_conv_intrinsic_ttynam (gfc_se * se, gfc_expr * expr) +{ + tree var; + tree len; + tree tmp; + tree arglist; + tree type; + tree cond; + tree gfc_int4_type_node = gfc_get_int_type (4); + + type = build_pointer_type (gfc_character1_type_node); + var = gfc_create_var (type, "pstr"); + len = gfc_create_var (gfc_int4_type_node, "len"); + + tmp = gfc_conv_intrinsic_function_args (se, expr); + arglist = gfc_chainon_list (NULL_TREE, build_fold_addr_expr (var)); + arglist = gfc_chainon_list (arglist, build_fold_addr_expr (len)); + arglist = chainon (arglist, tmp); + + tmp = build_function_call_expr (gfor_fndecl_ttynam, arglist); + gfc_add_expr_to_block (&se->pre, tmp); + + /* Free the temporary afterwards, if necessary. */ + cond = build2 (GT_EXPR, boolean_type_node, len, + build_int_cst (TREE_TYPE (len), 0)); + arglist = gfc_chainon_list (NULL_TREE, var); + tmp = build_function_call_expr (gfor_fndecl_internal_free, arglist); + tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ()); + gfc_add_expr_to_block (&se->post, tmp); + + se->expr = var; + se->string_length = len; +} + + /* Get the minimum/maximum value of all the parameters. minmax (a1, a2, a3, ...) { @@ -1012,7 +1388,7 @@ gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, int op) limit = gfc_evaluate_now(limit, &se->pre); mvar = gfc_create_var (type, "M"); - elsecase = build_v (MODIFY_EXPR, mvar, limit); + elsecase = build2_v (MODIFY_EXPR, mvar, limit); for (arg = TREE_CHAIN (arg); arg != NULL_TREE; arg = TREE_CHAIN (arg)) { val = TREE_VALUE (arg); @@ -1023,10 +1399,10 @@ gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, int op) if (TREE_CODE (val) != VAR_DECL && !TREE_CONSTANT (val)) val = gfc_evaluate_now(val, &se->pre); - thencase = build_v (MODIFY_EXPR, mvar, convert (type, val)); + thencase = build2_v (MODIFY_EXPR, mvar, convert (type, val)); - tmp = build (op, boolean_type_node, val, limit); - tmp = build_v (COND_EXPR, tmp, thencase, elsecase); + tmp = build2 (op, boolean_type_node, val, limit); + tmp = build3_v (COND_EXPR, tmp, thencase, elsecase); gfc_add_expr_to_block (&se->pre, tmp); elsecase = build_empty_stmt (); limit = mvar; @@ -1035,8 +1411,8 @@ gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, int op) } -/* Create a symbol node for this intrinsic. The symbol form the frontend - is for the generic name. */ +/* Create a symbol node for this intrinsic. The symbol from the frontend + has the generic name. */ static gfc_symbol * gfc_get_symbol_for_expr (gfc_expr * expr) @@ -1044,7 +1420,7 @@ gfc_get_symbol_for_expr (gfc_expr * expr) gfc_symbol *sym; /* TODO: Add symbols for intrinsic function to the global namespace. */ - assert (strlen (expr->value.function.name) <= GFC_MAX_SYMBOL_LEN - 5); + gcc_assert (strlen (expr->value.function.name) <= GFC_MAX_SYMBOL_LEN - 5); sym = gfc_new_symbol (expr->value.function.name, NULL); sym->ts = expr->ts; @@ -1071,16 +1447,64 @@ static void gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr) { gfc_symbol *sym; + tree append_args; - assert (!se->ss || se->ss->expr == expr); + gcc_assert (!se->ss || se->ss->expr == expr); if (se->ss) - assert (expr->rank > 0); + gcc_assert (expr->rank > 0); else - assert (expr->rank == 0); + gcc_assert (expr->rank == 0); sym = gfc_get_symbol_for_expr (expr); - gfc_conv_function_call (se, sym, expr->value.function.actual); + + /* Calls to libgfortran_matmul need to be appended special arguments, + to be able to call the BLAS ?gemm functions if required and possible. */ + append_args = NULL_TREE; + if (expr->value.function.isym->generic_id == GFC_ISYM_MATMUL + && sym->ts.type != BT_LOGICAL) + { + tree cint = gfc_get_int_type (gfc_c_int_kind); + + if (gfc_option.flag_external_blas + && (sym->ts.type == BT_REAL || sym->ts.type == BT_COMPLEX) + && (sym->ts.kind == gfc_default_real_kind + || sym->ts.kind == gfc_default_double_kind)) + { + tree gemm_fndecl; + + if (sym->ts.type == BT_REAL) + { + if (sym->ts.kind == gfc_default_real_kind) + gemm_fndecl = gfor_fndecl_sgemm; + else + gemm_fndecl = gfor_fndecl_dgemm; + } + else + { + if (sym->ts.kind == gfc_default_real_kind) + gemm_fndecl = gfor_fndecl_cgemm; + else + gemm_fndecl = gfor_fndecl_zgemm; + } + + append_args = gfc_chainon_list (NULL_TREE, build_int_cst (cint, 1)); + append_args = gfc_chainon_list + (append_args, build_int_cst + (cint, gfc_option.blas_matmul_limit)); + append_args = gfc_chainon_list (append_args, + gfc_build_addr_expr (NULL_TREE, + gemm_fndecl)); + } + else + { + append_args = gfc_chainon_list (NULL_TREE, build_int_cst (cint, 0)); + append_args = gfc_chainon_list (append_args, build_int_cst (cint, 0)); + append_args = gfc_chainon_list (append_args, null_pointer_node); + } + } + + gfc_conv_function_call (se, sym, expr->value.function.actual, append_args); gfc_free (sym); } @@ -1136,7 +1560,7 @@ gfc_conv_intrinsic_anyall (gfc_se * se, gfc_expr * expr, int op) /* Walk the arguments. */ arrayss = gfc_walk_expr (actual->expr); - assert (arrayss != gfc_ss_terminator); + gcc_assert (arrayss != gfc_ss_terminator); /* Initialize the scalarizer. */ gfc_init_loopinfo (&loop); @@ -1173,10 +1597,9 @@ gfc_conv_intrinsic_anyall (gfc_se * se, gfc_expr * expr, int op) gfc_conv_expr_val (&arrayse, actual->expr); gfc_add_block_to_block (&body, &arrayse.pre); - tmp = build (op, boolean_type_node, arrayse.expr, - fold_convert (TREE_TYPE (arrayse.expr), - integer_zero_node)); - tmp = build_v (COND_EXPR, tmp, found, build_empty_stmt ()); + tmp = 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 ()); gfc_add_expr_to_block (&body, tmp); gfc_add_block_to_block (&body, &arrayse.post); @@ -1217,11 +1640,11 @@ 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, convert (type, integer_zero_node)); + gfc_add_modify_expr (&se->pre, resvar, build_int_cst (type, 0)); /* Walk the arguments. */ arrayss = gfc_walk_expr (actual->expr); - assert (arrayss != gfc_ss_terminator); + gcc_assert (arrayss != gfc_ss_terminator); /* Initialize the scalarizer. */ gfc_init_loopinfo (&loop); @@ -1235,15 +1658,15 @@ gfc_conv_intrinsic_count (gfc_se * se, gfc_expr * expr) /* Generate the loop body. */ gfc_start_scalarized_body (&loop, &body); - tmp = build (PLUS_EXPR, TREE_TYPE (resvar), resvar, - convert (TREE_TYPE (resvar), integer_one_node)); - tmp = build_v (MODIFY_EXPR, resvar, tmp); + tmp = build2 (PLUS_EXPR, TREE_TYPE (resvar), resvar, + build_int_cst (TREE_TYPE (resvar), 1)); + tmp = build2_v (MODIFY_EXPR, resvar, tmp); gfc_init_se (&arrayse, NULL); gfc_copy_loopinfo_to_se (&arrayse, &loop); arrayse.ss = arrayss; gfc_conv_expr_val (&arrayse, actual->expr); - tmp = build_v (COND_EXPR, arrayse.expr, tmp, build_empty_stmt ()); + tmp = build3_v (COND_EXPR, arrayse.expr, tmp, build_empty_stmt ()); gfc_add_block_to_block (&body, &arrayse.pre); gfc_add_expr_to_block (&body, tmp); @@ -1296,15 +1719,15 @@ gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, int op) actual = expr->value.function.actual; arrayexpr = actual->expr; arrayss = gfc_walk_expr (arrayexpr); - assert (arrayss != gfc_ss_terminator); + gcc_assert (arrayss != gfc_ss_terminator); actual = actual->next->next; - assert (actual); + gcc_assert (actual); maskexpr = actual->expr; - if (maskexpr) + if (maskexpr && maskexpr->rank != 0) { maskss = gfc_walk_expr (maskexpr); - assert (maskss != gfc_ss_terminator); + gcc_assert (maskss != gfc_ss_terminator); } else maskss = NULL; @@ -1346,7 +1769,7 @@ gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, int op) gfc_conv_expr_val (&arrayse, arrayexpr); gfc_add_block_to_block (&block, &arrayse.pre); - tmp = build (op, type, resvar, arrayse.expr); + tmp = build2 (op, type, resvar, arrayse.expr); gfc_add_modify_expr (&block, resvar, tmp); gfc_add_block_to_block (&block, &arrayse.post); @@ -1355,13 +1778,129 @@ 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 = build_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ()); + tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ()); } else tmp = gfc_finish_block (&block); gfc_add_expr_to_block (&body, tmp); gfc_trans_scalarizing_loops (&loop, &body); + + /* For a scalar mask, enclose the loop in an if statement. */ + if (maskexpr && maskss == NULL) + { + gfc_init_se (&maskse, NULL); + gfc_conv_expr_val (&maskse, maskexpr); + gfc_init_block (&block); + gfc_add_block_to_block (&block, &loop.pre); + gfc_add_block_to_block (&block, &loop.post); + tmp = gfc_finish_block (&block); + + tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ()); + gfc_add_expr_to_block (&block, tmp); + gfc_add_block_to_block (&se->pre, &block); + } + else + { + gfc_add_block_to_block (&se->pre, &loop.pre); + gfc_add_block_to_block (&se->pre, &loop.post); + } + + gfc_cleanup_loop (&loop); + + se->expr = resvar; +} + + +/* Inline implementation of the dot_product intrinsic. This function + is based on gfc_conv_intrinsic_arith (the previous function). */ +static void +gfc_conv_intrinsic_dot_product (gfc_se * se, gfc_expr * expr) +{ + tree resvar; + tree type; + stmtblock_t body; + stmtblock_t block; + tree tmp; + gfc_loopinfo loop; + gfc_actual_arglist *actual; + gfc_ss *arrayss1, *arrayss2; + gfc_se arrayse1, arrayse2; + gfc_expr *arrayexpr1, *arrayexpr2; + + type = gfc_typenode_for_spec (&expr->ts); + + /* Initialize the result. */ + resvar = gfc_create_var (type, "val"); + if (expr->ts.type == BT_LOGICAL) + tmp = convert (type, integer_zero_node); + else + tmp = gfc_build_const (type, integer_zero_node); + + gfc_add_modify_expr (&se->pre, resvar, tmp); + + /* Walk argument #1. */ + actual = expr->value.function.actual; + arrayexpr1 = actual->expr; + arrayss1 = gfc_walk_expr (arrayexpr1); + gcc_assert (arrayss1 != gfc_ss_terminator); + + /* Walk argument #2. */ + actual = actual->next; + arrayexpr2 = actual->expr; + arrayss2 = gfc_walk_expr (arrayexpr2); + gcc_assert (arrayss2 != gfc_ss_terminator); + + /* Initialize the scalarizer. */ + gfc_init_loopinfo (&loop); + gfc_add_ss_to_loop (&loop, arrayss1); + gfc_add_ss_to_loop (&loop, arrayss2); + + /* Initialize the loop. */ + gfc_conv_ss_startstride (&loop); + gfc_conv_loop_setup (&loop); + + gfc_mark_ss_chain_used (arrayss1, 1); + gfc_mark_ss_chain_used (arrayss2, 1); + + /* Generate the loop body. */ + gfc_start_scalarized_body (&loop, &body); + gfc_init_block (&block); + + /* Make the tree expression for [conjg(]array1[)]. */ + gfc_init_se (&arrayse1, NULL); + gfc_copy_loopinfo_to_se (&arrayse1, &loop); + arrayse1.ss = arrayss1; + gfc_conv_expr_val (&arrayse1, arrayexpr1); + if (expr->ts.type == BT_COMPLEX) + arrayse1.expr = build1 (CONJ_EXPR, type, arrayse1.expr); + gfc_add_block_to_block (&block, &arrayse1.pre); + + /* Make the tree expression for array2. */ + gfc_init_se (&arrayse2, NULL); + gfc_copy_loopinfo_to_se (&arrayse2, &loop); + arrayse2.ss = arrayss2; + gfc_conv_expr_val (&arrayse2, arrayexpr2); + gfc_add_block_to_block (&block, &arrayse2.pre); + + /* Do the actual product and sum. */ + if (expr->ts.type == BT_LOGICAL) + { + tmp = build2 (TRUTH_AND_EXPR, type, arrayse1.expr, arrayse2.expr); + tmp = build2 (TRUTH_OR_EXPR, type, resvar, tmp); + } + else + { + tmp = build2 (MULT_EXPR, type, arrayse1.expr, arrayse2.expr); + tmp = build2 (PLUS_EXPR, type, resvar, tmp); + } + gfc_add_modify_expr (&block, resvar, tmp); + + /* Finish up the loop block and the loop. */ + tmp = gfc_finish_block (&block); + gfc_add_expr_to_block (&body, tmp); + + gfc_trans_scalarizing_loops (&loop, &body); gfc_add_block_to_block (&se->pre, &loop.pre); gfc_add_block_to_block (&se->pre, &loop.post); gfc_cleanup_loop (&loop); @@ -1369,17 +1908,19 @@ gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, int op) se->expr = resvar; } + static void gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, int op) { stmtblock_t body; stmtblock_t block; stmtblock_t ifblock; + stmtblock_t elseblock; tree limit; tree type; tree tmp; + tree elsetmp; tree ifbody; - tree cond; gfc_loopinfo loop; gfc_actual_arglist *actual; gfc_ss *arrayss; @@ -1405,25 +1946,25 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, int op) actual = expr->value.function.actual; arrayexpr = actual->expr; arrayss = gfc_walk_expr (arrayexpr); - assert (arrayss != gfc_ss_terminator); + gcc_assert (arrayss != gfc_ss_terminator); actual = actual->next->next; - assert (actual); + gcc_assert (actual); maskexpr = actual->expr; - if (maskexpr) + if (maskexpr && maskexpr->rank != 0) { maskss = gfc_walk_expr (maskexpr); - assert (maskss != gfc_ss_terminator); + gcc_assert (maskss != gfc_ss_terminator); } else maskss = NULL; limit = gfc_create_var (gfc_typenode_for_spec (&arrayexpr->ts), "limit"); - n = gfc_validate_kind (arrayexpr->ts.type, arrayexpr->ts.kind); + n = gfc_validate_kind (arrayexpr->ts.type, arrayexpr->ts.kind, false); switch (arrayexpr->ts.type) { case BT_REAL: - tmp = gfc_conv_mpf_to_tree (gfc_real_kinds[n].huge, arrayexpr->ts.kind); + tmp = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge, arrayexpr->ts.kind); break; case BT_INTEGER: @@ -1432,12 +1973,12 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, int op) break; default: - abort (); + gcc_unreachable (); } /* Most negative(+HUGE) for maxval, most negative (-HUGE) for minval. */ if (op == GT_EXPR) - tmp = fold (build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp)); + tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp); gfc_add_modify_expr (&se->pre, limit, tmp); /* Initialize the scalarizer. */ @@ -1450,20 +1991,13 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, int op) gfc_conv_ss_startstride (&loop); gfc_conv_loop_setup (&loop); - assert (loop.dimen == 1); - - /* Initialize the position to the first element. If the array has zero - size we need to return zero. Otherwise use the first element of the - array, in case all elements are equal to the limit. - ie. pos = (ubound >= lbound) ? lbound, lbound - 1; */ - tmp = fold (build (MINUS_EXPR, gfc_array_index_type, - loop.from[0], gfc_index_one_node)); - cond = fold (build (GE_EXPR, boolean_type_node, - loop.to[0], loop.from[0])); - tmp = fold (build (COND_EXPR, gfc_array_index_type, cond, - loop.from[0], tmp)); - gfc_add_modify_expr (&loop.pre, pos, tmp); - + gcc_assert (loop.dimen == 1); + + /* 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); + gfc_mark_ss_chain_used (arrayss, 1); if (maskss) gfc_mark_ss_chain_used (maskss, 1); @@ -1502,9 +2036,11 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, int op) ifbody = gfc_finish_block (&ifblock); - /* If it is a more extreme value. */ - tmp = build (op, boolean_type_node, arrayse.expr, limit); - tmp = build_v (COND_EXPR, tmp, ifbody, build_empty_stmt ()); + /* If it is a more extreme value or pos is still zero. */ + tmp = build2 (TRUTH_OR_EXPR, boolean_type_node, + build2 (op, boolean_type_node, arrayse.expr, limit), + build2 (EQ_EXPR, boolean_type_node, pos, gfc_index_zero_node)); + tmp = build3_v (COND_EXPR, tmp, ifbody, build_empty_stmt ()); gfc_add_expr_to_block (&block, tmp); if (maskss) @@ -1512,7 +2048,7 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, int op) /* We enclose the above in if (mask) {...}. */ tmp = gfc_finish_block (&block); - tmp = build_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ()); + tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ()); } else tmp = gfc_finish_block (&block); @@ -1520,14 +2056,38 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, int op) gfc_trans_scalarizing_loops (&loop, &body); - gfc_add_block_to_block (&se->pre, &loop.pre); - gfc_add_block_to_block (&se->pre, &loop.post); + /* For a scalar mask, enclose the loop in an if statement. */ + if (maskexpr && maskss == NULL) + { + gfc_init_se (&maskse, NULL); + gfc_conv_expr_val (&maskse, maskexpr); + gfc_init_block (&block); + gfc_add_block_to_block (&block, &loop.pre); + gfc_add_block_to_block (&block, &loop.post); + tmp = gfc_finish_block (&block); + + /* For the else part of the scalar mask, just initialize + the pos variable the same way as above. */ + + gfc_init_block (&elseblock); + gfc_add_modify_expr (&elseblock, pos, gfc_index_zero_node); + elsetmp = gfc_finish_block (&elseblock); + + tmp = build3_v (COND_EXPR, maskse.expr, tmp, elsetmp); + gfc_add_expr_to_block (&block, tmp); + gfc_add_block_to_block (&se->pre, &block); + } + else + { + gfc_add_block_to_block (&se->pre, &loop.pre); + gfc_add_block_to_block (&se->pre, &loop.post); + } gfc_cleanup_loop (&loop); /* Return a value in the range 1..SIZE(array). */ - tmp = fold (build (MINUS_EXPR, gfc_array_index_type, loop.from[0], - gfc_index_one_node)); - tmp = fold (build (MINUS_EXPR, gfc_array_index_type, pos, tmp)); + tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, loop.from[0], + gfc_index_one_node); + tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, pos, tmp); /* And convert to the required type. */ se->expr = convert (type, tmp); } @@ -1560,11 +2120,11 @@ gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, int op) type = gfc_typenode_for_spec (&expr->ts); /* Initialize the result. */ limit = gfc_create_var (type, "limit"); - n = gfc_validate_kind (expr->ts.type, expr->ts.kind); + n = gfc_validate_kind (expr->ts.type, expr->ts.kind, false); switch (expr->ts.type) { case BT_REAL: - tmp = gfc_conv_mpf_to_tree (gfc_real_kinds[n].huge, expr->ts.kind); + tmp = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge, expr->ts.kind); break; case BT_INTEGER: @@ -1572,27 +2132,27 @@ gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, int op) break; default: - abort (); + gcc_unreachable (); } /* Most negative(-HUGE) for maxval, most positive (-HUGE) for minval. */ if (op == GT_EXPR) - tmp = fold (build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp)); + tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp); gfc_add_modify_expr (&se->pre, limit, tmp); /* Walk the arguments. */ actual = expr->value.function.actual; arrayexpr = actual->expr; arrayss = gfc_walk_expr (arrayexpr); - assert (arrayss != gfc_ss_terminator); + gcc_assert (arrayss != gfc_ss_terminator); actual = actual->next->next; - assert (actual); + gcc_assert (actual); maskexpr = actual->expr; - if (maskexpr) + if (maskexpr && maskexpr->rank != 0) { maskss = gfc_walk_expr (maskexpr); - assert (maskss != gfc_ss_terminator); + gcc_assert (maskss != gfc_ss_terminator); } else maskss = NULL; @@ -1635,26 +2195,42 @@ gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, int op) gfc_add_block_to_block (&block, &arrayse.pre); /* Assign the value to the limit... */ - ifbody = build_v (MODIFY_EXPR, limit, arrayse.expr); + ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr); /* If it is a more extreme value. */ - tmp = build (op, boolean_type_node, arrayse.expr, limit); - tmp = build_v (COND_EXPR, tmp, ifbody, build_empty_stmt ()); + tmp = 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 = build_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ()); - } + /* We enclose the above in if (mask) {...}. */ + tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ()); gfc_add_expr_to_block (&body, tmp); gfc_trans_scalarizing_loops (&loop, &body); - gfc_add_block_to_block (&se->pre, &loop.pre); - gfc_add_block_to_block (&se->pre, &loop.post); + /* For a scalar mask, enclose the loop in an if statement. */ + if (maskexpr && maskss == NULL) + { + gfc_init_se (&maskse, NULL); + gfc_conv_expr_val (&maskse, maskexpr); + gfc_init_block (&block); + gfc_add_block_to_block (&block, &loop.pre); + gfc_add_block_to_block (&block, &loop.post); + tmp = gfc_finish_block (&block); + + tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ()); + gfc_add_expr_to_block (&block, tmp); + gfc_add_block_to_block (&se->pre, &block); + } + else + { + gfc_add_block_to_block (&se->pre, &loop.pre); + gfc_add_block_to_block (&se->pre, &loop.post); + } + gfc_cleanup_loop (&loop); se->expr = limit; @@ -1674,10 +2250,10 @@ gfc_conv_intrinsic_btest (gfc_se * se, gfc_expr * expr) arg = TREE_VALUE (arg); type = TREE_TYPE (arg); - tmp = build (LSHIFT_EXPR, type, convert (type, integer_one_node), arg2); - tmp = build (BIT_AND_EXPR, type, arg, tmp); - tmp = fold (build (NE_EXPR, boolean_type_node, tmp, - convert (type, integer_zero_node))); + tmp = build2 (LSHIFT_EXPR, type, build_int_cst (type, 1), arg2); + tmp = build2 (BIT_AND_EXPR, type, arg, tmp); + tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp, + build_int_cst (type, 0)); type = gfc_typenode_for_spec (&expr->ts); se->expr = convert (type, tmp); } @@ -1695,7 +2271,7 @@ gfc_conv_intrinsic_bitop (gfc_se * se, gfc_expr * expr, int op) arg = TREE_VALUE (arg); type = TREE_TYPE (arg); - se->expr = fold (build (op, type, arg, arg2)); + se->expr = fold_build2 (op, type, arg, arg2); } /* Bitwise not. */ @@ -1725,16 +2301,15 @@ gfc_conv_intrinsic_singlebitop (gfc_se * se, gfc_expr * expr, int set) arg = TREE_VALUE (arg); type = TREE_TYPE (arg); - tmp = fold (build (LSHIFT_EXPR, type, - convert (type, integer_one_node), arg2)); + tmp = fold_build2 (LSHIFT_EXPR, type, build_int_cst (type, 1), arg2); if (set) op = BIT_IOR_EXPR; else { op = BIT_AND_EXPR; - tmp = fold (build1 (BIT_NOT_EXPR, type, tmp)); + tmp = fold_build1 (BIT_NOT_EXPR, type, tmp); } - se->expr = fold (build (op, type, arg, tmp)); + se->expr = fold_build2 (op, type, arg, tmp); } /* Extract a sequence of bits. @@ -1756,23 +2331,46 @@ gfc_conv_intrinsic_ibits (gfc_se * se, gfc_expr * expr) arg2 = TREE_VALUE (arg2); type = TREE_TYPE (arg); - mask = build_int_2 (-1, ~(unsigned HOST_WIDE_INT) 0); - mask = build (LSHIFT_EXPR, type, mask, arg3); + mask = build_int_cst (NULL_TREE, -1); + mask = build2 (LSHIFT_EXPR, type, mask, arg3); mask = build1 (BIT_NOT_EXPR, type, mask); - tmp = build (RSHIFT_EXPR, type, arg, arg2); + tmp = build2 (RSHIFT_EXPR, type, arg, arg2); - se->expr = fold (build (BIT_AND_EXPR, type, tmp, mask)); + se->expr = fold_build2 (BIT_AND_EXPR, type, tmp, mask); } -/* ISHFT (I, SHIFT) = (shift >= 0) ? i << shift : i >> -shift. */ +/* RSHIFT (I, SHIFT) = I >> SHIFT + LSHIFT (I, SHIFT) = I << SHIFT */ +static void +gfc_conv_intrinsic_rlshift (gfc_se * se, gfc_expr * expr, int right_shift) +{ + tree arg; + tree arg2; + + arg = gfc_conv_intrinsic_function_args (se, expr); + arg2 = TREE_VALUE (TREE_CHAIN (arg)); + arg = TREE_VALUE (arg); + + se->expr = fold_build2 (right_shift ? RSHIFT_EXPR : LSHIFT_EXPR, + TREE_TYPE (arg), arg, arg2); +} + +/* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i)) + ? 0 + : ((shift >= 0) ? i << shift : i >> -shift) + where all shifts are logical shifts. */ static void gfc_conv_intrinsic_ishft (gfc_se * se, gfc_expr * expr) { tree arg; tree arg2; tree type; + tree utype; tree tmp; + tree width; + tree num_bits; + tree cond; tree lshift; tree rshift; @@ -1780,23 +2378,33 @@ gfc_conv_intrinsic_ishft (gfc_se * se, gfc_expr * expr) arg2 = TREE_VALUE (TREE_CHAIN (arg)); arg = TREE_VALUE (arg); type = TREE_TYPE (arg); + utype = gfc_unsigned_type (type); + + width = fold_build1 (ABS_EXPR, TREE_TYPE (arg2), arg2); /* Left shift if positive. */ - lshift = build (LSHIFT_EXPR, type, arg, arg2); + lshift = fold_build2 (LSHIFT_EXPR, type, arg, width); - /* Right shift if negative. This will perform an arithmetic shift as - we are dealing with signed integers. Section 13.5.7 allows this. */ - tmp = build1 (NEGATE_EXPR, TREE_TYPE (arg2), arg2); - rshift = build (RSHIFT_EXPR, type, arg, tmp); + /* Right shift if negative. + We convert to an unsigned type because we want a logical shift. + The standard doesn't define the case of shifting negative + numbers, and we try to be compatible with other compilers, most + notably g77, here. */ + rshift = fold_convert (type, build2 (RSHIFT_EXPR, utype, + convert (utype, arg), width)); - tmp = build (GT_EXPR, boolean_type_node, arg2, - convert (TREE_TYPE (arg2), integer_zero_node)); - rshift = build (COND_EXPR, type, tmp, lshift, rshift); + tmp = fold_build2 (GE_EXPR, boolean_type_node, arg2, + build_int_cst (TREE_TYPE (arg2), 0)); + tmp = fold_build3 (COND_EXPR, type, tmp, lshift, rshift); - /* Do nothing if shift == 0. */ - tmp = build (EQ_EXPR, boolean_type_node, arg2, - convert (TREE_TYPE (arg2), integer_zero_node)); - se->expr = build (COND_EXPR, type, tmp, arg, rshift); + /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas + gcc requires a shift width < BIT_SIZE(I), so we have to catch this + special case. */ + num_bits = build_int_cst (TREE_TYPE (arg2), TYPE_PRECISION (type)); + cond = fold_build2 (GE_EXPR, boolean_type_node, width, num_bits); + + se->expr = fold_build3 (COND_EXPR, type, cond, + build_int_cst (type, 0), tmp); } /* Circular shift. AKA rotate or barrel shift. */ @@ -1810,6 +2418,7 @@ gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr) tree tmp; tree lrot; tree rrot; + tree zero; arg = gfc_conv_intrinsic_function_args (se, expr); arg2 = TREE_CHAIN (arg); @@ -1817,27 +2426,46 @@ gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr) if (arg3) { /* Use a library function for the 3 parameter version. */ + tree int4type = gfc_get_int_type (4); + type = TREE_TYPE (TREE_VALUE (arg)); - /* Convert all args to the same type otherwise we need loads of library - functions. SIZE and SHIFT cannot have values > BIT_SIZE (I) so the - conversion is safe. */ - tmp = convert (type, TREE_VALUE (arg2)); - TREE_VALUE (arg2) = tmp; - tmp = convert (type, TREE_VALUE (arg3)); - TREE_VALUE (arg3) = tmp; + /* We convert the first argument to at least 4 bytes, and + convert back afterwards. This removes the need for library + functions for all argument sizes, and function will be + aligned to at least 32 bits, so there's no loss. */ + if (expr->ts.kind < 4) + { + tmp = convert (int4type, TREE_VALUE (arg)); + TREE_VALUE (arg) = tmp; + } + /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would + need loads of library functions. They cannot have values > + BIT_SIZE (I) so the conversion is safe. */ + TREE_VALUE (arg2) = convert (int4type, TREE_VALUE (arg2)); + TREE_VALUE (arg3) = convert (int4type, TREE_VALUE (arg3)); switch (expr->ts.kind) { + case 1: + case 2: case 4: tmp = gfor_fndecl_math_ishftc4; break; case 8: tmp = gfor_fndecl_math_ishftc8; break; + case 16: + tmp = gfor_fndecl_math_ishftc16; + break; default: - abort (); + gcc_unreachable (); } - se->expr = gfc_build_function_call (tmp, arg); + se->expr = build_function_call_expr (tmp, arg); + /* Convert the result back to the original type, if we extended + the first argument's width above. */ + if (expr->ts.kind < 4) + se->expr = convert (type, se->expr); + return; } arg = TREE_VALUE (arg); @@ -1845,20 +2473,19 @@ gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr) type = TREE_TYPE (arg); /* Rotate left if positive. */ - lrot = build (LROTATE_EXPR, type, arg, arg2); + lrot = fold_build2 (LROTATE_EXPR, type, arg, arg2); /* Rotate right if negative. */ - tmp = build1 (NEGATE_EXPR, TREE_TYPE (arg2), arg2); - rrot = build (RROTATE_EXPR, type, arg, tmp); + tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (arg2), arg2); + rrot = fold_build2 (RROTATE_EXPR, type, arg, tmp); - tmp = build (GT_EXPR, boolean_type_node, arg2, - convert (TREE_TYPE (arg2), integer_zero_node)); - rrot = build (COND_EXPR, type, tmp, lrot, rrot); + zero = build_int_cst (TREE_TYPE (arg2), 0); + tmp = fold_build2 (GT_EXPR, boolean_type_node, arg2, zero); + rrot = fold_build3 (COND_EXPR, type, tmp, lrot, rrot); /* Do nothing if shift == 0. */ - tmp = build (EQ_EXPR, boolean_type_node, arg2, - convert (TREE_TYPE (arg2), integer_zero_node)); - se->expr = build (COND_EXPR, type, tmp, arg, rrot); + tmp = fold_build2 (EQ_EXPR, boolean_type_node, arg2, zero); + se->expr = fold_build3 (COND_EXPR, type, tmp, arg, rrot); } /* The length of a character string. */ @@ -1871,8 +2498,9 @@ gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr) gfc_symbol *sym; gfc_se argse; gfc_expr *arg; + gfc_ss *ss; - assert (!se->ss); + gcc_assert (!se->ss); arg = expr->value.function.actual->expr; @@ -1880,35 +2508,47 @@ gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr) switch (arg->expr_type) { case EXPR_CONSTANT: - len = build_int_2 (arg->value.character.length, 0); + len = build_int_cst (NULL_TREE, arg->value.character.length); break; - default: - if (arg->expr_type == EXPR_VARIABLE - && (arg->ref == NULL || (arg->ref->next == NULL - && arg->ref->type == REF_ARRAY))) - { - /* This doesn't catch all cases. - See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html - and the surrounding thread. */ - sym = arg->symtree->n.sym; - decl = gfc_get_symbol_decl (sym); - if (decl == current_function_decl && sym->attr.function + case EXPR_ARRAY: + /* Obtain the string length from the function used by + trans-array.c(gfc_trans_array_constructor). */ + len = NULL_TREE; + get_array_ctor_strlen (arg->value.constructor, &len); + break; + + case EXPR_VARIABLE: + if (arg->ref == NULL + || (arg->ref->next == NULL && arg->ref->type == REF_ARRAY)) + { + /* This doesn't catch all cases. + See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html + and the surrounding thread. */ + sym = arg->symtree->n.sym; + decl = gfc_get_symbol_decl (sym); + if (decl == current_function_decl && sym->attr.function && (sym->result == sym)) - decl = gfc_get_fake_result_decl (sym); - - len = sym->ts.cl->backend_decl; - assert (len); - } - else - { - /* Anybody stupid enough to do this deserves inefficient code. */ - gfc_init_se (&argse, se); - gfc_conv_expr (&argse, arg); - gfc_add_block_to_block (&se->pre, &argse.pre); - gfc_add_block_to_block (&se->post, &argse.post); - len = argse.string_length; + decl = gfc_get_fake_result_decl (sym, 0); + + len = sym->ts.cl->backend_decl; + gcc_assert (len); + break; } + + /* Otherwise fall through. */ + + default: + /* Anybody stupid enough to do this deserves inefficient code. */ + ss = gfc_walk_expr (arg); + gfc_init_se (&argse, se); + if (ss == gfc_ss_terminator) + gfc_conv_expr (&argse, arg); + else + gfc_conv_expr_descriptor (&argse, arg, ss); + gfc_add_block_to_block (&se->pre, &argse.pre); + gfc_add_block_to_block (&se->post, &argse.post); + len = argse.string_length; break; } se->expr = convert (type, len); @@ -1923,7 +2563,7 @@ gfc_conv_intrinsic_len_trim (gfc_se * se, gfc_expr * expr) args = gfc_conv_intrinsic_function_args (se, expr); type = gfc_typenode_for_spec (&expr->ts); - se->expr = gfc_build_function_call (gfor_fndecl_string_len_trim, args); + se->expr = build_function_call_expr (gfor_fndecl_string_len_trim, args); se->expr = convert (type, se->expr); } @@ -1933,6 +2573,7 @@ gfc_conv_intrinsic_len_trim (gfc_se * se, gfc_expr * expr) static void gfc_conv_intrinsic_index (gfc_se * se, gfc_expr * expr) { + tree logical4_type_node = gfc_get_logical_type (4); tree args; tree back; tree type; @@ -1943,17 +2584,17 @@ gfc_conv_intrinsic_index (gfc_se * se, gfc_expr * expr) tmp = gfc_advance_chain (args, 3); if (TREE_CHAIN (tmp) == NULL_TREE) { - back = convert (gfc_logical4_type_node, integer_one_node); - back = tree_cons (NULL_TREE, integer_zero_node, NULL_TREE); + back = tree_cons (NULL_TREE, build_int_cst (logical4_type_node, 0), + NULL_TREE); TREE_CHAIN (tmp) = back; } else { back = TREE_CHAIN (tmp); - TREE_VALUE (back) = convert (gfc_logical4_type_node, TREE_VALUE (back)); + TREE_VALUE (back) = convert (logical4_type_node, TREE_VALUE (back)); } - se->expr = gfc_build_function_call (gfor_fndecl_string_index, args); + se->expr = build_function_call_expr (gfor_fndecl_string_index, args); se->expr = convert (type, se->expr); } @@ -1966,11 +2607,11 @@ gfc_conv_intrinsic_ichar (gfc_se * se, gfc_expr * expr) arg = gfc_conv_intrinsic_function_args (se, expr); arg = TREE_VALUE (TREE_CHAIN (arg)); - assert (POINTER_TYPE_P (TREE_TYPE (arg))); + gcc_assert (POINTER_TYPE_P (TREE_TYPE (arg))); arg = build1 (NOP_EXPR, pchar_type_node, arg); type = gfc_typenode_for_spec (&expr->ts); - se->expr = gfc_build_indirect_ref (arg); + se->expr = build_fold_indirect_ref (arg); se->expr = convert (type, se->expr); } @@ -1985,16 +2626,32 @@ gfc_conv_intrinsic_merge (gfc_se * se, gfc_expr * expr) tree fsource; tree mask; tree type; + tree len; arg = gfc_conv_intrinsic_function_args (se, expr); - tsource = TREE_VALUE (arg); - arg = TREE_CHAIN (arg); - fsource = TREE_VALUE (arg); - arg = TREE_CHAIN (arg); - mask = TREE_VALUE (arg); + if (expr->ts.type != BT_CHARACTER) + { + tsource = TREE_VALUE (arg); + arg = TREE_CHAIN (arg); + fsource = TREE_VALUE (arg); + mask = TREE_VALUE (TREE_CHAIN (arg)); + } + else + { + /* We do the same as in the non-character case, but the argument + list is different because of the string length arguments. We + also have to set the string length for the result. */ + len = TREE_VALUE (arg); + arg = TREE_CHAIN (arg); + tsource = TREE_VALUE (arg); + arg = TREE_CHAIN (TREE_CHAIN (arg)); + fsource = TREE_VALUE (arg); + mask = TREE_VALUE (TREE_CHAIN (arg)); + se->string_length = len; + } type = TREE_TYPE (tsource); - se->expr = fold (build (COND_EXPR, type, mask, tsource, fsource)); + se->expr = fold_build3 (COND_EXPR, type, mask, tsource, fsource); } @@ -2012,8 +2669,9 @@ gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr) actual = expr->value.function.actual; ss = gfc_walk_expr (actual->expr); - assert (ss != gfc_ss_terminator); + gcc_assert (ss != gfc_ss_terminator); argse.want_pointer = 1; + argse.data_not_needed = 1; gfc_conv_expr_descriptor (&argse, actual->expr, ss); gfc_add_block_to_block (&se->pre, &argse.pre); gfc_add_block_to_block (&se->post, &argse.post); @@ -2031,7 +2689,7 @@ gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr) else fndecl = gfor_fndecl_size0; - se->expr = gfc_build_function_call (fndecl, args); + se->expr = build_function_call_expr (fndecl, args); type = gfc_typenode_for_spec (&expr->ts); se->expr = convert (type, se->expr); } @@ -2044,14 +2702,18 @@ gfc_conv_intrinsic_strcmp (gfc_se * se, gfc_expr * expr, int op) { tree type; tree args; + tree arg2; args = gfc_conv_intrinsic_function_args (se, expr); - /* Build a call for the comparison. */ - se->expr = gfc_build_function_call (gfor_fndecl_compare_string, args); + arg2 = TREE_CHAIN (TREE_CHAIN (args)); + + se->expr = gfc_build_compare_string (TREE_VALUE (args), + TREE_VALUE (TREE_CHAIN (args)), TREE_VALUE (arg2), + TREE_VALUE (TREE_CHAIN (arg2))); type = gfc_typenode_for_spec (&expr->ts); - se->expr = build (op, type, se->expr, - convert (TREE_TYPE (se->expr), integer_zero_node)); + se->expr = fold_build2 (op, type, se->expr, + build_int_cst (TREE_TYPE (se->expr), 0)); } /* Generate a call to the adjustl/adjustr library function. */ @@ -2071,15 +2733,263 @@ gfc_conv_intrinsic_adjust (gfc_se * se, gfc_expr * expr, tree fndecl) var = gfc_conv_string_tmp (se, type, len); args = tree_cons (NULL_TREE, var, args); - tmp = gfc_build_function_call (fndecl, args); + tmp = build_function_call_expr (fndecl, args); gfc_add_expr_to_block (&se->pre, tmp); se->expr = var; se->string_length = len; } +/* A helper function for gfc_conv_intrinsic_array_transfer to compute + the size of tree expressions in bytes. */ +static tree +gfc_size_in_bytes (gfc_se *se, gfc_expr *e) +{ + tree tmp; + + if (e->ts.type == BT_CHARACTER) + tmp = se->string_length; + else + { + if (e->rank) + { + tmp = gfc_get_element_type (TREE_TYPE (se->expr)); + tmp = size_in_bytes (tmp); + } + else + tmp = size_in_bytes (TREE_TYPE (TREE_TYPE (se->expr))); + } + + return fold_convert (gfc_array_index_type, tmp); +} + + +/* Array transfer statement. + 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) +{ + tree tmp; + tree extent; + tree source; + tree source_bytes; + tree dest_word_len; + tree size_words; + tree size_bytes; + tree upper; + tree lower; + tree stride; + tree stmt; + tree args; + gfc_actual_arglist *arg; + gfc_se argse; + gfc_ss *ss; + gfc_ss_info *info; + stmtblock_t block; + int n; + + gcc_assert (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; + gfc_init_se (&argse, NULL); + ss = gfc_walk_expr (arg->expr); + + source_bytes = gfc_create_var (gfc_array_index_type, NULL); + + /* Obtain the pointer to source and the length of source in bytes. */ + if (ss == gfc_ss_terminator) + { + gfc_conv_expr_reference (&argse, arg->expr); + source = argse.expr; + + /* Obtain the source word length. */ + tmp = gfc_size_in_bytes (&argse, arg->expr); + } + else + { + gfc_init_se (&argse, NULL); + argse.want_pointer = 0; + gfc_conv_expr_descriptor (&argse, arg->expr, ss); + source = gfc_conv_descriptor_data_get (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)) + { + tmp = build_fold_addr_expr (argse.expr); + tmp = gfc_chainon_list (NULL_TREE, tmp); + source = build_function_call_expr (gfor_fndecl_in_pack, tmp); + source = gfc_evaluate_now (source, &argse.pre); + + /* Free the temporary. */ + gfc_start_block (&block); + tmp = convert (pvoid_type_node, source); + tmp = gfc_chainon_list (NULL_TREE, tmp); + tmp = build_function_call_expr (gfor_fndecl_internal_free, tmp); + gfc_add_expr_to_block (&block, tmp); + stmt = gfc_finish_block (&block); + + /* Clean up if it was repacked. */ + gfc_init_block (&block); + tmp = gfc_conv_array_data (argse.expr); + tmp = build2 (NE_EXPR, boolean_type_node, source, tmp); + tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ()); + gfc_add_expr_to_block (&block, tmp); + gfc_add_block_to_block (&block, &se->post); + gfc_init_block (&se->post); + gfc_add_block_to_block (&se->post, &block); + } + + /* Obtain the source word length. */ + tmp = gfc_size_in_bytes (&argse, arg->expr); + + /* Obtain the size of the array in bytes. */ + extent = gfc_create_var (gfc_array_index_type, NULL); + for (n = 0; n < arg->expr->rank; n++) + { + 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); + tmp = build2 (MINUS_EXPR, gfc_array_index_type, + upper, lower); + gfc_add_modify_expr (&argse.pre, extent, tmp); + tmp = build2 (PLUS_EXPR, gfc_array_index_type, + extent, gfc_index_one_node); + tmp = build2 (MULT_EXPR, gfc_array_index_type, + tmp, source_bytes); + } + } + + gfc_add_modify_expr (&argse.pre, source_bytes, tmp); + gfc_add_block_to_block (&se->pre, &argse.pre); + gfc_add_block_to_block (&se->post, &argse.post); + + /* Now convert MOLD. The sole output is: + dest_word_len = destination word length in bytes. */ + arg = arg->next; + + gfc_init_se (&argse, NULL); + ss = gfc_walk_expr (arg->expr); + + if (ss == gfc_ss_terminator) + { + gfc_conv_expr_reference (&argse, arg->expr); + + /* Obtain the source word length. */ + tmp = gfc_size_in_bytes (&argse, arg->expr); + } + else + { + gfc_init_se (&argse, NULL); + argse.want_pointer = 0; + gfc_conv_expr_descriptor (&argse, arg->expr, ss); + + /* Obtain the source word length. */ + tmp = gfc_size_in_bytes (&argse, arg->expr); + } + + dest_word_len = gfc_create_var (gfc_array_index_type, NULL); + gfc_add_modify_expr (&se->pre, dest_word_len, tmp); + + /* Finally convert SIZE, if it is present. */ + arg = arg->next; + size_words = gfc_create_var (gfc_array_index_type, NULL); + + if (arg->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)); + gfc_add_block_to_block (&se->pre, &argse.pre); + gfc_add_block_to_block (&se->post, &argse.post); + } + else + tmp = NULL_TREE; + + size_bytes = gfc_create_var (gfc_array_index_type, NULL); + if (tmp != NULL_TREE) + { + tmp = build2 (MULT_EXPR, gfc_array_index_type, + tmp, dest_word_len); + tmp = build2 (MIN_EXPR, gfc_array_index_type, tmp, source_bytes); + } + else + tmp = source_bytes; + + gfc_add_modify_expr (&se->pre, size_bytes, tmp); + gfc_add_modify_expr (&se->pre, size_words, + build2 (CEIL_DIV_EXPR, gfc_array_index_type, + size_bytes, dest_word_len)); + + /* Evaluate the bounds of the result. If the loop range exists, we have + to check if it is too large. If so, we modify loop->to be consistent + with min(size, size(source)). Otherwise, size is made consistent with + the loop range, so that the right number of bytes is transferred.*/ + n = se->loop->order[0]; + if (se->loop->to[n] != NULL_TREE) + { + tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, + se->loop->to[n], se->loop->from[n]); + tmp = build2 (PLUS_EXPR, gfc_array_index_type, + tmp, gfc_index_one_node); + tmp = 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, + build2 (MULT_EXPR, gfc_array_index_type, + size_words, dest_word_len)); + upper = build2 (PLUS_EXPR, gfc_array_index_type, + size_words, se->loop->from[n]); + upper = build2 (MINUS_EXPR, gfc_array_index_type, + upper, gfc_index_one_node); + } + else + { + upper = build2 (MINUS_EXPR, gfc_array_index_type, + size_words, gfc_index_one_node); + se->loop->from[n] = gfc_index_zero_node; + } + + 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. */ + tmp = gfc_typenode_for_spec (&expr->ts); + gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, + info, tmp, false, true, false, false); + + /* Use memcpy to do the transfer. */ + tmp = gfc_conv_descriptor_data_get (info->descriptor); + args = gfc_chainon_list (NULL_TREE, tmp); + tmp = fold_convert (pvoid_type_node, source); + args = gfc_chainon_list (args, source); + args = gfc_chainon_list (args, size_bytes); + tmp = built_in_decls[BUILT_IN_MEMCPY]; + tmp = build_function_call_expr (tmp, args); + gfc_add_expr_to_block (&se->pre, tmp); + + se->expr = info->descriptor; + if (expr->ts.type == BT_CHARACTER) + se->string_length = dest_word_len; +} + + /* Scalar transfer statement. - TRANSFER (source, mold) = *(typeof *)&source */ + TRANSFER (source, mold) = memcpy(&tmpdecl, &source, size), tmpdecl. */ static void gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr) @@ -2089,8 +2999,7 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr) tree type; tree ptr; gfc_ss *ss; - - assert (!se->ss); + tree tmpdecl, tmp, args; /* Get a pointer to the source. */ arg = expr->value.function.actual; @@ -2106,9 +3015,10 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr) arg = arg->next; type = gfc_typenode_for_spec (&expr->ts); - ptr = convert (build_pointer_type (type), ptr); + 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); @@ -2118,7 +3028,22 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr) } else { - se->expr = gfc_build_indirect_ref (ptr); + tree moldsize; + tmpdecl = gfc_create_var (type, "transfer"); + moldsize = size_in_bytes (type); + + /* Use memcpy to do the transfer. */ + tmp = build1 (ADDR_EXPR, build_pointer_type (type), tmpdecl); + tmp = fold_convert (pvoid_type_node, tmp); + args = gfc_chainon_list (NULL_TREE, tmp); + tmp = fold_convert (pvoid_type_node, ptr); + args = gfc_chainon_list (args, tmp); + args = gfc_chainon_list (args, moldsize); + tmp = built_in_decls[BUILT_IN_MEMCPY]; + tmp = build_function_call_expr (tmp, args); + gfc_add_expr_to_block (&se->pre, tmp); + + se->expr = tmpdecl; } } @@ -2140,9 +3065,9 @@ gfc_conv_allocated (gfc_se *se, gfc_expr *expr) arg1se.descriptor_only = 1; gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1); - tmp = gfc_conv_descriptor_data (arg1se.expr); - tmp = build (NE_EXPR, boolean_type_node, tmp, - fold_convert (TREE_TYPE (tmp), null_pointer_node)); + tmp = gfc_conv_descriptor_data_get (arg1se.expr); + tmp = 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); } @@ -2163,6 +3088,8 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr) tree tmp2; tree tmp; tree args, fndecl; + tree nonzero_charlen; + tree nonzero_arraylen; gfc_ss *ss1, *ss2; gfc_init_se (&arg1se, NULL); @@ -2184,55 +3111,89 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr) else { /* A pointer to an array. */ - arg1se.descriptor_only = 1; - gfc_conv_expr_lhs (&arg1se, arg1->expr); - tmp2 = gfc_conv_descriptor_data (arg1se.expr); + gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1); + tmp2 = gfc_conv_descriptor_data_get (arg1se.expr); } - tmp = build (NE_EXPR, boolean_type_node, tmp2, - fold_convert (TREE_TYPE (tmp2), null_pointer_node)); + gfc_add_block_to_block (&se->pre, &arg1se.pre); + gfc_add_block_to_block (&se->post, &arg1se.post); + tmp = build2 (NE_EXPR, boolean_type_node, tmp2, + fold_convert (TREE_TYPE (tmp2), null_pointer_node)); se->expr = tmp; } else { /* An optional target. */ ss2 = gfc_walk_expr (arg2->expr); + + nonzero_charlen = NULL_TREE; + if (arg1->expr->ts.type == BT_CHARACTER) + nonzero_charlen = build2 (NE_EXPR, boolean_type_node, + arg1->expr->ts.cl->backend_decl, + integer_zero_node); + if (ss1 == gfc_ss_terminator) { /* A pointer to a scalar. */ - assert (ss2 == gfc_ss_terminator); + gcc_assert (ss2 == gfc_ss_terminator); arg1se.want_pointer = 1; gfc_conv_expr (&arg1se, arg1->expr); arg2se.want_pointer = 1; gfc_conv_expr (&arg2se, arg2->expr); - tmp = build (EQ_EXPR, boolean_type_node, arg1se.expr, arg2se.expr); - se->expr = tmp; + gfc_add_block_to_block (&se->pre, &arg1se.pre); + gfc_add_block_to_block (&se->post, &arg1se.post); + tmp = build2 (EQ_EXPR, boolean_type_node, arg1se.expr, arg2se.expr); + tmp2 = build2 (NE_EXPR, boolean_type_node, arg1se.expr, + null_pointer_node); + se->expr = build2 (TRUTH_AND_EXPR, boolean_type_node, tmp, tmp2); } else { + + /* An array pointer of zero length is not associated if target is + present. */ + arg1se.descriptor_only = 1; + gfc_conv_expr_lhs (&arg1se, arg1->expr); + tmp = gfc_conv_descriptor_stride (arg1se.expr, + gfc_rank_cst[arg1->expr->rank - 1]); + nonzero_arraylen = build2 (NE_EXPR, boolean_type_node, + tmp, integer_zero_node); + /* A pointer to an array, call library function _gfor_associated. */ - assert (ss2 != gfc_ss_terminator); + gcc_assert (ss2 != gfc_ss_terminator); args = NULL_TREE; arg1se.want_pointer = 1; gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1); args = gfc_chainon_list (args, arg1se.expr); + arg2se.want_pointer = 1; 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); args = gfc_chainon_list (args, arg2se.expr); fndecl = gfor_fndecl_associated; - se->expr = gfc_build_function_call (fndecl, args); + se->expr = build_function_call_expr (fndecl, args); + se->expr = build2 (TRUTH_AND_EXPR, boolean_type_node, + se->expr, nonzero_arraylen); + } - } + + /* If target is present zero character length pointers cannot + be associated. */ + if (nonzero_charlen != NULL_TREE) + se->expr = build2 (TRUTH_AND_EXPR, boolean_type_node, + se->expr, nonzero_charlen); + } + se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr); } -/* Scan a string for any one of the characters in a set of characters. */ +/* Scan a string for any one of the characters in a set of characters. */ static void gfc_conv_intrinsic_scan (gfc_se * se, gfc_expr * expr) { + tree logical4_type_node = gfc_get_logical_type (4); tree args; tree back; tree type; @@ -2243,28 +3204,29 @@ gfc_conv_intrinsic_scan (gfc_se * se, gfc_expr * expr) tmp = gfc_advance_chain (args, 3); if (TREE_CHAIN (tmp) == NULL_TREE) { - back = convert (gfc_logical4_type_node, integer_one_node); - back = tree_cons (NULL_TREE, integer_zero_node, NULL_TREE); + back = tree_cons (NULL_TREE, build_int_cst (logical4_type_node, 0), + NULL_TREE); TREE_CHAIN (tmp) = back; } else { back = TREE_CHAIN (tmp); - TREE_VALUE (back) = convert (gfc_logical4_type_node, TREE_VALUE (back)); + TREE_VALUE (back) = convert (logical4_type_node, TREE_VALUE (back)); } - se->expr = gfc_build_function_call (gfor_fndecl_string_scan, args); + se->expr = build_function_call_expr (gfor_fndecl_string_scan, args); se->expr = convert (type, se->expr); } /* Verify that a set of characters contains all the characters in a string - by indentifying the position of the first character in a string of + by identifying the position of the first character in a string of characters that does not appear in a given set of characters. */ static void gfc_conv_intrinsic_verify (gfc_se * se, gfc_expr * expr) { + tree logical4_type_node = gfc_get_logical_type (4); tree args; tree back; tree type; @@ -2275,200 +3237,20 @@ gfc_conv_intrinsic_verify (gfc_se * se, gfc_expr * expr) tmp = gfc_advance_chain (args, 3); if (TREE_CHAIN (tmp) == NULL_TREE) { - back = convert (gfc_logical4_type_node, integer_one_node); - back = tree_cons (NULL_TREE, integer_zero_node, NULL_TREE); + back = tree_cons (NULL_TREE, build_int_cst (logical4_type_node, 0), + NULL_TREE); TREE_CHAIN (tmp) = back; } else { back = TREE_CHAIN (tmp); - TREE_VALUE (back) = convert (gfc_logical4_type_node, TREE_VALUE (back)); + TREE_VALUE (back) = convert (logical4_type_node, TREE_VALUE (back)); } - se->expr = gfc_build_function_call (gfor_fndecl_string_verify, args); + se->expr = build_function_call_expr (gfor_fndecl_string_verify, args); se->expr = convert (type, se->expr); } -/* Prepare components and related information of a real number which is - the first argument of a elemental functions to manipulate reals. */ - -static -void prepare_arg_info (gfc_se * se, gfc_expr * expr, - real_compnt_info * rcs, int all) -{ - tree arg; - tree masktype; - tree tmp; - tree wbits; - tree one; - tree exponent, fraction; - int n; - gfc_expr *a1; - - if (TARGET_FLOAT_FORMAT != IEEE_FLOAT_FORMAT) - gfc_todo_error ("Non-IEEE floating format"); - - assert (expr->expr_type == EXPR_FUNCTION); - - arg = gfc_conv_intrinsic_function_args (se, expr); - arg = TREE_VALUE (arg); - rcs->type = TREE_TYPE (arg); - - /* Force arg'type to integer by unaffected convert */ - a1 = expr->value.function.actual->expr; - masktype = gfc_get_int_type (a1->ts.kind); - rcs->mtype = masktype; - tmp = build1 (VIEW_CONVERT_EXPR, masktype, arg); - arg = gfc_create_var (masktype, "arg"); - gfc_add_modify_expr(&se->pre, arg, tmp); - rcs->arg = arg; - - /* Caculate the numbers of bits of exponent, fraction and word */ - n = gfc_validate_kind (a1->ts.type, a1->ts.kind); - tmp = build_int_2 (gfc_real_kinds[n].digits - 1, 0); - rcs->fdigits = convert (masktype, tmp); - wbits = build_int_2 (TYPE_PRECISION (rcs->type) - 1, 0); - wbits = convert (masktype, wbits); - rcs->edigits = fold (build (MINUS_EXPR, masktype, wbits, tmp)); - - /* Form masks for exponent/fraction/sign */ - one = gfc_build_const (masktype, integer_one_node); - rcs->smask = fold (build (LSHIFT_EXPR, masktype, one, wbits)); - rcs->f1 = fold (build (LSHIFT_EXPR, masktype, one, rcs->fdigits)); - rcs->emask = fold (build (MINUS_EXPR, masktype, rcs->smask, rcs->f1)); - rcs->fmask = fold (build (MINUS_EXPR, masktype, rcs->f1, one)); - /* Form bias. */ - tmp = fold (build (MINUS_EXPR, masktype, rcs->edigits, one)); - tmp = fold (build (LSHIFT_EXPR, masktype, one, tmp)); - rcs->bias = fold (build (MINUS_EXPR, masktype, tmp ,one)); - - if (all) - { - /* exponent, and fraction */ - tmp = build (BIT_AND_EXPR, masktype, arg, rcs->emask); - tmp = build (RSHIFT_EXPR, masktype, tmp, rcs->fdigits); - exponent = gfc_create_var (masktype, "exponent"); - gfc_add_modify_expr(&se->pre, exponent, tmp); - rcs->expn = exponent; - - tmp = build (BIT_AND_EXPR, masktype, arg, rcs->fmask); - fraction = gfc_create_var (masktype, "fraction"); - gfc_add_modify_expr(&se->pre, fraction, tmp); - rcs->frac = fraction; - } -} - -/* Build a call to __builtin_clz. */ - -static tree -call_builtin_clz (tree result_type, tree op0) -{ - tree fn, parms, call; - enum machine_mode op0_mode = TYPE_MODE (TREE_TYPE (op0)); - - if (op0_mode == TYPE_MODE (integer_type_node)) - fn = built_in_decls[BUILT_IN_CLZ]; - else if (op0_mode == TYPE_MODE (long_integer_type_node)) - fn = built_in_decls[BUILT_IN_CLZL]; - else if (op0_mode == TYPE_MODE (long_long_integer_type_node)) - fn = built_in_decls[BUILT_IN_CLZLL]; - else - abort (); - - parms = tree_cons (NULL, op0, NULL); - call = gfc_build_function_call (fn, parms); - - return convert (result_type, call); -} - -/* Generate code for SPACING (X) intrinsic function. We generate: - - t = expn - (BITS_OF_FRACTION) - res = t << (BITS_OF_FRACTION) - if (t < 0) - res = tiny(X) -*/ - -static void -gfc_conv_intrinsic_spacing (gfc_se * se, gfc_expr * expr) -{ - tree arg; - tree masktype; - tree tmp, t1, cond; - tree tiny, zero; - tree fdigits; - real_compnt_info rcs; - - prepare_arg_info (se, expr, &rcs, 0); - arg = rcs.arg; - masktype = rcs.mtype; - fdigits = rcs.fdigits; - tiny = rcs.f1; - zero = gfc_build_const (masktype, integer_zero_node); - tmp = build (BIT_AND_EXPR, masktype, rcs.emask, arg); - tmp = build (RSHIFT_EXPR, masktype, tmp, fdigits); - tmp = build (MINUS_EXPR, masktype, tmp, fdigits); - cond = build (LE_EXPR, boolean_type_node, tmp, zero); - t1 = build (LSHIFT_EXPR, masktype, tmp, fdigits); - tmp = build (COND_EXPR, masktype, cond, tiny, t1); - tmp = build1 (VIEW_CONVERT_EXPR, rcs.type, tmp); - - se->expr = tmp; -} - -/* Generate code for RRSPACING (X) intrinsic function. We generate: - - if (expn == 0 && frac == 0) - res = 0; - else - { - sedigits = edigits + 1; - if (expn == 0) - { - t1 = leadzero (frac); - frac = frac << (t1 + sedigits); - frac = frac >> (sedigits); - } - t = bias + BITS_OF_FRACTION_OF; - res = (t << BITS_OF_FRACTION_OF) | frac; -*/ - -static void -gfc_conv_intrinsic_rrspacing (gfc_se * se, gfc_expr * expr) -{ - tree masktype; - tree tmp, t1, t2, cond, cond2; - tree one, zero; - tree fdigits, fraction; - real_compnt_info rcs; - - prepare_arg_info (se, expr, &rcs, 1); - masktype = rcs.mtype; - fdigits = rcs.fdigits; - fraction = rcs.frac; - one = gfc_build_const (masktype, integer_one_node); - zero = gfc_build_const (masktype, integer_zero_node); - t2 = build (PLUS_EXPR, masktype, rcs.edigits, one); - - t1 = call_builtin_clz (masktype, fraction); - tmp = build (PLUS_EXPR, masktype, t1, one); - tmp = build (LSHIFT_EXPR, masktype, fraction, tmp); - tmp = build (RSHIFT_EXPR, masktype, tmp, t2); - cond = build (EQ_EXPR, boolean_type_node, rcs.expn, zero); - fraction = build (COND_EXPR, masktype, cond, tmp, fraction); - - tmp = build (PLUS_EXPR, masktype, rcs.bias, fdigits); - tmp = build (LSHIFT_EXPR, masktype, tmp, fdigits); - tmp = build (BIT_IOR_EXPR, masktype, tmp, fraction); - - cond2 = build (EQ_EXPR, boolean_type_node, rcs.frac, zero); - cond = build (TRUTH_ANDIF_EXPR, boolean_type_node, cond, cond2); - tmp = build (COND_EXPR, masktype, cond, - convert (masktype, integer_zero_node), tmp); - - tmp = build1 (VIEW_CONVERT_EXPR, rcs.type, tmp); - se->expr = tmp; -} /* Generate code for SELECTED_INT_KIND (R) intrinsic function. */ @@ -2479,9 +3261,9 @@ gfc_conv_intrinsic_si_kind (gfc_se * se, gfc_expr * expr) args = gfc_conv_intrinsic_function_args (se, expr); args = TREE_VALUE (args); - args = gfc_build_addr_expr (NULL, args); + args = build_fold_addr_expr (args); args = tree_cons (NULL_TREE, args, NULL_TREE); - se->expr = gfc_build_function_call (gfor_fndecl_si_kind, args); + se->expr = build_function_call_expr (gfor_fndecl_si_kind, args); } /* Generate code for SELECTED_REAL_KIND (P, R) intrinsic function. */ @@ -2508,7 +3290,7 @@ gfc_conv_intrinsic_sr_kind (gfc_se * se, gfc_expr * expr) gfc_add_block_to_block (&se->post, &argse.post); args = gfc_chainon_list (args, argse.expr); } - se->expr = gfc_build_function_call (gfor_fndecl_sr_kind, args); + se->expr = build_function_call_expr (gfor_fndecl_sr_kind, args); } @@ -2517,6 +3299,7 @@ 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; @@ -2533,19 +3316,19 @@ gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr) len = gfc_create_var (gfc_int4_type_node, "len"); tmp = gfc_conv_intrinsic_function_args (se, expr); - arglist = gfc_chainon_list (arglist, gfc_build_addr_expr (NULL, len)); + arglist = gfc_chainon_list (arglist, build_fold_addr_expr (len)); arglist = gfc_chainon_list (arglist, addr); arglist = chainon (arglist, tmp); - - tmp = gfc_build_function_call (gfor_fndecl_string_trim, arglist); + + tmp = build_function_call_expr (gfor_fndecl_string_trim, arglist); gfc_add_expr_to_block (&se->pre, tmp); /* Free the temporary afterwards, if necessary. */ - cond = build (GT_EXPR, boolean_type_node, len, - convert (TREE_TYPE (len), integer_zero_node)); + cond = build2 (GT_EXPR, boolean_type_node, len, + build_int_cst (TREE_TYPE (len), 0)); arglist = gfc_chainon_list (NULL_TREE, var); - tmp = gfc_build_function_call (gfor_fndecl_internal_free, arglist); - tmp = build_v (COND_EXPR, cond, tmp, build_empty_stmt ()); + tmp = build_function_call_expr (gfor_fndecl_internal_free, arglist); + tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ()); gfc_add_expr_to_block (&se->post, tmp); se->expr = var; @@ -2558,6 +3341,7 @@ gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr) static void gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr) { + tree gfc_int4_type_node = gfc_get_int_type (4); tree tmp; tree len; tree args; @@ -2570,14 +3354,14 @@ gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr) len = TREE_VALUE (args); tmp = gfc_advance_chain (args, 2); ncopies = TREE_VALUE (tmp); - len = fold (build (MULT_EXPR, gfc_int4_type_node, len, ncopies)); + len = fold_build2 (MULT_EXPR, gfc_int4_type_node, len, ncopies); type = gfc_get_character_type (expr->ts.kind, expr->ts.cl); var = gfc_conv_string_tmp (se, build_pointer_type (type), len); arglist = NULL_TREE; arglist = gfc_chainon_list (arglist, var); arglist = chainon (arglist, args); - tmp = gfc_build_function_call (gfor_fndecl_string_repeat, arglist); + tmp = build_function_call_expr (gfor_fndecl_string_repeat, arglist); gfc_add_expr_to_block (&se->pre, tmp); se->expr = var; @@ -2585,6 +3369,54 @@ gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr) } +/* Generate code for the IARGC intrinsic. */ + +static void +gfc_conv_intrinsic_iargc (gfc_se * se, gfc_expr * expr) +{ + tree tmp; + tree fndecl; + tree type; + + /* Call the library function. This always returns an INTEGER(4). */ + fndecl = gfor_fndecl_iargc; + tmp = build_function_call_expr (fndecl, NULL_TREE); + + /* Convert it to the required type. */ + type = gfc_typenode_for_spec (&expr->ts); + tmp = fold_convert (type, tmp); + + se->expr = tmp; +} + + +/* The loc intrinsic returns the address of its argument as + gfc_index_integer_kind integer. */ + +static void +gfc_conv_intrinsic_loc (gfc_se * se, gfc_expr * expr) +{ + tree temp_var; + gfc_expr *arg_expr; + gfc_ss *ss; + + gcc_assert (!se->ss); + + arg_expr = expr->value.function.actual->expr; + ss = gfc_walk_expr (arg_expr); + if (ss == gfc_ss_terminator) + gfc_conv_expr_reference (se, arg_expr); + else + gfc_conv_array_parameter (se, arg_expr, ss, 1); + 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); + se->expr = temp_var; +} + /* Generate code for an intrinsic function. Some map directly to library calls, others get special handling. In some cases the name of the function used depends on the type specifiers. */ @@ -2593,14 +3425,14 @@ void gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) { gfc_intrinsic_sym *isym; - char *name; + const char *name; int lib; isym = expr->value.function.isym; name = &expr->value.function.name[2]; - if (expr->rank > 0) + if (expr->rank > 0 && !expr->inline_noncopying_intrinsic) { lib = gfc_is_intrinsic_libcall (expr); if (lib != 0) @@ -2615,7 +3447,7 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) switch (expr->value.function.isym->generic_id) { case GFC_ISYM_NONE: - abort (); + gcc_unreachable (); case GFC_ISYM_REPEAT: gfc_conv_intrinsic_repeat (se, expr); @@ -2637,14 +3469,6 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) gfc_conv_intrinsic_exponent (se, expr); break; - case GFC_ISYM_SPACING: - gfc_conv_intrinsic_spacing (se, expr); - break; - - case GFC_ISYM_RRSPACING: - gfc_conv_intrinsic_rrspacing (se, expr); - break; - case GFC_ISYM_SCAN: gfc_conv_intrinsic_scan (se, expr); break; @@ -2678,7 +3502,7 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) break; case GFC_ISYM_AINT: - gfc_conv_intrinsic_aint (se, expr, FIX_TRUNC_EXPR); + gfc_conv_intrinsic_aint (se, expr, RND_TRUNC); break; case GFC_ISYM_ALL: @@ -2686,7 +3510,11 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) break; case GFC_ISYM_ANINT: - gfc_conv_intrinsic_aint (se, expr, FIX_ROUND_EXPR); + gfc_conv_intrinsic_aint (se, expr, RND_ROUND); + break; + + case GFC_ISYM_AND: + gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR); break; case GFC_ISYM_ANY: @@ -2709,22 +3537,25 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) gfc_conv_intrinsic_conversion (se, expr); break; - /* Integer conversions are handled seperately to make sure we get the + /* Integer conversions are handled separately to make sure we get the correct rounding mode. */ case GFC_ISYM_INT: - gfc_conv_intrinsic_int (se, expr, FIX_TRUNC_EXPR); + case GFC_ISYM_INT2: + case GFC_ISYM_INT8: + case GFC_ISYM_LONG: + gfc_conv_intrinsic_int (se, expr, RND_TRUNC); break; case GFC_ISYM_NINT: - gfc_conv_intrinsic_int (se, expr, FIX_ROUND_EXPR); + gfc_conv_intrinsic_int (se, expr, RND_ROUND); break; case GFC_ISYM_CEILING: - gfc_conv_intrinsic_int (se, expr, FIX_CEIL_EXPR); + gfc_conv_intrinsic_int (se, expr, RND_CEIL); break; case GFC_ISYM_FLOOR: - gfc_conv_intrinsic_int (se, expr, FIX_FLOOR_EXPR); + gfc_conv_intrinsic_int (se, expr, RND_FLOOR); break; case GFC_ISYM_MOD: @@ -2739,6 +3570,14 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) gfc_conv_intrinsic_cmplx (se, expr, name[5] == '1'); break; + case GFC_ISYM_COMMAND_ARGUMENT_COUNT: + gfc_conv_intrinsic_iargc (se, expr); + break; + + case GFC_ISYM_COMPLEX: + gfc_conv_intrinsic_cmplx (se, expr, 1); + break; + case GFC_ISYM_CONJG: gfc_conv_intrinsic_conjg (se, expr); break; @@ -2747,14 +3586,26 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) gfc_conv_intrinsic_count (se, expr); break; + case GFC_ISYM_CTIME: + gfc_conv_intrinsic_ctime (se, expr); + break; + case GFC_ISYM_DIM: gfc_conv_intrinsic_dim (se, expr); break; + case GFC_ISYM_DOT_PRODUCT: + gfc_conv_intrinsic_dot_product (se, expr); + break; + case GFC_ISYM_DPROD: gfc_conv_intrinsic_dprod (se, expr); break; + case GFC_ISYM_FDATE: + gfc_conv_intrinsic_fdate (se, expr); + break; + case GFC_ISYM_IAND: gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR); break; @@ -2777,6 +3628,10 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) gfc_conv_intrinsic_ichar (se, expr); break; + case GFC_ISYM_IARGC: + gfc_conv_intrinsic_iargc (se, expr); + break; + case GFC_ISYM_IEOR: gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR); break; @@ -2789,6 +3644,14 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR); break; + case GFC_ISYM_LSHIFT: + gfc_conv_intrinsic_rlshift (se, expr, 0); + break; + + case GFC_ISYM_RSHIFT: + gfc_conv_intrinsic_rlshift (se, expr, 1); + break; + case GFC_ISYM_ISHFT: gfc_conv_intrinsic_ishft (se, expr); break; @@ -2801,6 +3664,16 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) gfc_conv_intrinsic_bound (se, expr, 0); break; + case GFC_ISYM_TRANSPOSE: + if (se->ss && se->ss->useflags) + { + gfc_conv_tmp_array_ref (se); + gfc_advance_se_ss_chain (se); + } + else + gfc_conv_array_transpose (se, expr->value.function.actual->expr); + break; + case GFC_ISYM_LEN: gfc_conv_intrinsic_len (se, expr); break; @@ -2857,6 +3730,10 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) gfc_conv_intrinsic_not (se, expr); break; + case GFC_ISYM_OR: + gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR); + break; + case GFC_ISYM_PRESENT: gfc_conv_intrinsic_present (se, expr); break; @@ -2878,19 +3755,76 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) break; case GFC_ISYM_TRANSFER: - gfc_conv_intrinsic_transfer (se, expr); + if (se->ss) + { + 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); + } + else + gfc_conv_intrinsic_transfer (se, expr); + break; + + case GFC_ISYM_TTYNAM: + gfc_conv_intrinsic_ttynam (se, expr); break; case GFC_ISYM_UBOUND: gfc_conv_intrinsic_bound (se, expr, 1); break; - case GFC_ISYM_DOT_PRODUCT: - case GFC_ISYM_MATMUL: + case GFC_ISYM_XOR: + gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR); + break; + + case GFC_ISYM_LOC: + gfc_conv_intrinsic_loc (se, expr); + break; + + case GFC_ISYM_ACCESS: + case GFC_ISYM_CHDIR: + case GFC_ISYM_CHMOD: + case GFC_ISYM_ETIME: + case GFC_ISYM_FGET: + case GFC_ISYM_FGETC: + case GFC_ISYM_FNUM: + case GFC_ISYM_FPUT: + case GFC_ISYM_FPUTC: + case GFC_ISYM_FSTAT: + case GFC_ISYM_FTELL: + case GFC_ISYM_GETCWD: + case GFC_ISYM_GETGID: + case GFC_ISYM_GETPID: + case GFC_ISYM_GETUID: + case GFC_ISYM_HOSTNM: + case GFC_ISYM_KILL: + case GFC_ISYM_IERRNO: case GFC_ISYM_IRAND: + case GFC_ISYM_ISATTY: + case GFC_ISYM_LINK: + case GFC_ISYM_LSTAT: + case GFC_ISYM_MALLOC: + case GFC_ISYM_MATMUL: + case GFC_ISYM_MCLOCK: + case GFC_ISYM_MCLOCK8: case GFC_ISYM_RAND: - case GFC_ISYM_ETIME: + case GFC_ISYM_RENAME: case GFC_ISYM_SECOND: + case GFC_ISYM_SECNDS: + case GFC_ISYM_SIGNAL: + case GFC_ISYM_STAT: + case GFC_ISYM_SYMLNK: + case GFC_ISYM_SYSTEM: + case GFC_ISYM_TIME: + case GFC_ISYM_TIME8: + case GFC_ISYM_UMASK: + case GFC_ISYM_UNLINK: gfc_conv_intrinsic_funcall (se, expr); break; @@ -2914,8 +3848,7 @@ gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss) break; default: - abort (); - break; + gcc_unreachable (); } } @@ -2936,6 +3869,7 @@ gfc_walk_intrinsic_bound (gfc_ss * ss, gfc_expr * expr) newss->type = GFC_SS_INTRINSIC; newss->expr = expr; newss->next = ss; + newss->data.info.dimen = 1; return newss; } @@ -2948,7 +3882,7 @@ gfc_walk_intrinsic_libfunc (gfc_ss * ss, gfc_expr * expr) { gfc_ss *newss; - assert (expr->rank > 0); + gcc_assert (expr->rank > 0); newss = gfc_get_ss (); newss->type = GFC_SS_FUNCTION; @@ -2967,8 +3901,8 @@ gfc_walk_intrinsic_libfunc (gfc_ss * ss, gfc_expr * expr) int gfc_is_intrinsic_libcall (gfc_expr * expr) { - assert (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym); - assert (expr->rank > 0); + gcc_assert (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym); + gcc_assert (expr->rank > 0); switch (expr->value.function.isym->generic_id) { @@ -3006,10 +3940,10 @@ gfc_ss * gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr, gfc_intrinsic_sym * isym) { - assert (isym); + gcc_assert (isym); if (isym->elemental) - return gfc_walk_elemental_function_args (ss, expr, GFC_SS_SCALAR); + return gfc_walk_elemental_function_args (ss, expr->value.function.actual, GFC_SS_SCALAR); if (expr->rank == 0) return ss; @@ -3024,6 +3958,9 @@ gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr, case GFC_ISYM_UBOUND: return gfc_walk_intrinsic_bound (ss, expr); + case GFC_ISYM_TRANSFER: + return gfc_walk_intrinsic_libfunc (ss, expr); + default: /* This probably meant someone forgot to add an intrinsic to the above list(s) when they implemented it, or something's gone horribly wrong.