X-Git-Url: http://git.sourceforge.jp/view?a=blobdiff_plain;f=gcc%2Ffortran%2Ftrans-intrinsic.c;h=ae60eb1c7700633fc89cd5640398bab42dac5817;hb=08803898f86ac4e22632737f1bd52668dbb4e663;hp=21694e41b36fb71dc428b7a2db44f08b0832b849;hpb=e60a6f7b6c12183ca32dfe2876f09f4b4f4f69c1;p=pf3gnuchains%2Fgcc-fork.git diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index 21694e41b36..ae60eb1c770 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -273,7 +273,8 @@ gfc_conv_intrinsic_conversion (gfc_se * se, gfc_expr * expr) /* Call the library function that will perform the conversion. */ gcc_assert (nargs >= 2); - tmp = build_call_expr (fndecl, 3, addr, args[0], args[1]); + tmp = build_call_expr_loc (input_location, + fndecl, 3, addr, args[0], args[1]); gfc_add_expr_to_block (&se->pre, tmp); /* Free the temporary afterwards. */ @@ -363,7 +364,8 @@ build_round_expr (tree arg, tree restype) else gcc_unreachable (); - return fold_convert (restype, build_call_expr (fn, 1, arg)); + return fold_convert (restype, build_call_expr_loc (input_location, + fn, 1, arg)); } @@ -475,7 +477,8 @@ gfc_conv_intrinsic_aint (gfc_se * se, gfc_expr * expr, enum rounding_mode op) if (n != END_BUILTINS) { tmp = built_in_decls[n]; - se->expr = build_call_expr (tmp, 1, arg[0]); + se->expr = build_call_expr_loc (input_location, + tmp, 1, arg[0]); return; } @@ -745,7 +748,7 @@ gfc_conv_intrinsic_lib_function (gfc_se * se, gfc_expr * expr) rettype = TREE_TYPE (TREE_TYPE (fndecl)); fndecl = build_addr (fndecl, current_function_decl); - se->expr = build_call_array (rettype, fndecl, num_args, args); + se->expr = build_call_array_loc (input_location, rettype, fndecl, num_args, args); } @@ -808,7 +811,8 @@ gfc_conv_intrinsic_exponent (gfc_se *se, gfc_expr *expr) gfc_conv_intrinsic_function_args (se, expr, &arg, 1); res = gfc_create_var (integer_type_node, NULL); - tmp = build_call_expr (built_in_decls[frexp], 2, arg, + tmp = build_call_expr_loc (input_location, + built_in_decls[frexp], 2, arg, gfc_build_addr_expr (NULL_TREE, res)); gfc_add_expr_to_block (&se->pre, tmp); @@ -828,13 +832,12 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper) tree type; tree bound; tree tmp; - tree cond, cond1, cond2, cond3, cond4, size; + tree cond, cond1, cond3, cond4, size; tree ubound; tree lbound; gfc_se argse; gfc_ss *ss; gfc_array_spec * as; - gfc_ref *ref; arg = expr->value.function.actual; arg2 = arg->next; @@ -903,42 +906,7 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper) ubound = gfc_conv_descriptor_ubound_get (desc, bound); lbound = gfc_conv_descriptor_lbound_get (desc, bound); - /* Follow any component references. */ - if (arg->expr->expr_type == EXPR_VARIABLE - || arg->expr->expr_type == EXPR_CONSTANT) - { - as = arg->expr->symtree->n.sym->as; - for (ref = arg->expr->ref; ref; ref = ref->next) - { - switch (ref->type) - { - case REF_COMPONENT: - as = ref->u.c.component->as; - continue; - - case REF_SUBSTRING: - continue; - - case REF_ARRAY: - { - switch (ref->u.ar.type) - { - case AR_ELEMENT: - case AR_SECTION: - case AR_UNKNOWN: - as = NULL; - continue; - - case AR_FULL: - break; - } - break; - } - } - } - } - else - as = NULL; + as = gfc_get_full_arrayspec_from_expr (arg->expr); /* 13.14.53: Result value for LBOUND @@ -966,7 +934,6 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper) tree stride = gfc_conv_descriptor_stride_get (desc, bound); cond1 = fold_build2 (GE_EXPR, boolean_type_node, ubound, lbound); - cond2 = fold_build2 (LE_EXPR, boolean_type_node, ubound, lbound); cond3 = fold_build2 (GE_EXPR, boolean_type_node, stride, gfc_index_zero_node); @@ -1054,7 +1021,8 @@ gfc_conv_intrinsic_abs (gfc_se * se, gfc_expr * expr) default: gcc_unreachable (); } - se->expr = build_call_expr (built_in_decls[n], 1, arg); + se->expr = build_call_expr_loc (input_location, + built_in_decls[n], 1, arg); break; default: @@ -1150,7 +1118,8 @@ gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo) if (n != END_BUILTINS) { tmp = build_addr (built_in_decls[n], current_function_decl); - se->expr = build_call_array (TREE_TYPE (TREE_TYPE (built_in_decls[n])), + se->expr = build_call_array_loc (input_location, + TREE_TYPE (TREE_TYPE (built_in_decls[n])), tmp, 2, args); if (modulo == 0) return; @@ -1263,22 +1232,42 @@ gfc_conv_intrinsic_sign (gfc_se * se, gfc_expr * expr) gfc_conv_intrinsic_function_args (se, expr, args, 2); if (expr->ts.type == BT_REAL) { + tree abs; + switch (expr->ts.kind) { case 4: tmp = built_in_decls[BUILT_IN_COPYSIGNF]; + abs = built_in_decls[BUILT_IN_FABSF]; break; case 8: tmp = built_in_decls[BUILT_IN_COPYSIGN]; + abs = built_in_decls[BUILT_IN_FABS]; break; case 10: case 16: tmp = built_in_decls[BUILT_IN_COPYSIGNL]; + abs = built_in_decls[BUILT_IN_FABSL]; break; default: gcc_unreachable (); } - se->expr = build_call_expr (tmp, 2, args[0], args[1]); + + /* We explicitly have to ignore the minus sign. We do so by using + result = (arg1 == 0) ? abs(arg0) : copysign(arg0, arg1). */ + if (!gfc_option.flag_sign_zero + && MODE_HAS_SIGNED_ZEROS (TYPE_MODE (TREE_TYPE (args[1])))) + { + tree cond, zero; + zero = build_real_from_int_cst (TREE_TYPE (args[1]), integer_zero_node); + cond = fold_build2 (EQ_EXPR, boolean_type_node, args[1], zero); + se->expr = fold_build3 (COND_EXPR, TREE_TYPE (args[0]), cond, + build_call_expr (abs, 1, args[0]), + build_call_expr (tmp, 2, args[0], args[1])); + } + else + se->expr = build_call_expr_loc (input_location, + tmp, 2, args[0], args[1]); return; } @@ -1381,7 +1370,8 @@ gfc_conv_intrinsic_ctime (gfc_se * se, gfc_expr * expr) args[1] = gfc_build_addr_expr (NULL_TREE, len); fndecl = build_addr (gfor_fndecl_ctime, current_function_decl); - tmp = build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_ctime)), + tmp = build_call_array_loc (input_location, + TREE_TYPE (TREE_TYPE (gfor_fndecl_ctime)), fndecl, num_args, args); gfc_add_expr_to_block (&se->pre, tmp); @@ -1419,7 +1409,8 @@ gfc_conv_intrinsic_fdate (gfc_se * se, gfc_expr * expr) args[1] = gfc_build_addr_expr (NULL_TREE, len); fndecl = build_addr (gfor_fndecl_fdate, current_function_decl); - tmp = build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_fdate)), + tmp = build_call_array_loc (input_location, + TREE_TYPE (TREE_TYPE (gfor_fndecl_fdate)), fndecl, num_args, args); gfc_add_expr_to_block (&se->pre, tmp); @@ -1459,7 +1450,8 @@ gfc_conv_intrinsic_ttynam (gfc_se * se, gfc_expr * expr) args[1] = gfc_build_addr_expr (NULL_TREE, len); fndecl = build_addr (gfor_fndecl_ttynam, current_function_decl); - tmp = build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_ttynam)), + tmp = build_call_array_loc (input_location, + TREE_TYPE (TREE_TYPE (gfor_fndecl_ttynam)), fndecl, num_args, args); gfc_add_expr_to_block (&se->pre, tmp); @@ -1527,9 +1519,10 @@ gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, enum tree_code op) if (argexpr->expr->expr_type == EXPR_VARIABLE && argexpr->expr->symtree->n.sym->attr.optional && TREE_CODE (val) == INDIRECT_REF) - cond = fold_build2 - (NE_EXPR, boolean_type_node, TREE_OPERAND (val, 0), - build_int_cst (TREE_TYPE (TREE_OPERAND (val, 0)), 0)); + cond = fold_build2_loc (input_location, + NE_EXPR, boolean_type_node, + TREE_OPERAND (val, 0), + build_int_cst (TREE_TYPE (TREE_OPERAND (val, 0)), 0)); else { cond = NULL_TREE; @@ -1548,7 +1541,8 @@ gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, enum tree_code op) to help performance of programs that don't rely on IEEE semantics. */ if (FLOAT_TYPE_P (TREE_TYPE (mvar))) { - isnan = build_call_expr (built_in_decls[BUILT_IN_ISNAN], 1, mvar); + isnan = build_call_expr_loc (input_location, + built_in_decls[BUILT_IN_ISNAN], 1, mvar); tmp = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, tmp, fold_convert (boolean_type_node, isnan)); } @@ -1596,7 +1590,8 @@ gfc_conv_intrinsic_minmax_char (gfc_se * se, gfc_expr * expr, int op) /* Make the function call. */ fndecl = build_addr (function, current_function_decl); - tmp = build_call_array (TREE_TYPE (TREE_TYPE (function)), fndecl, + tmp = build_call_array_loc (input_location, + TREE_TYPE (TREE_TYPE (function)), fndecl, nargs + 4, args); gfc_add_expr_to_block (&se->pre, tmp); @@ -2114,6 +2109,72 @@ gfc_conv_intrinsic_dot_product (gfc_se * se, gfc_expr * expr) } +/* Emit code for minloc or maxloc intrinsic. There are many different cases + we need to handle. For performance reasons we sometimes create two + loops instead of one, where the second one is much simpler. + Examples for minloc intrinsic: + 1) Result is an array, a call is generated + 2) Array mask is used and NaNs need to be supported: + limit = Infinity; + pos = 0; + S = from; + while (S <= to) { + if (mask[S]) { + if (pos == 0) pos = S + (1 - from); + if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; } + } + S++; + } + goto lab2; + lab1:; + while (S <= to) { + if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); } + S++; + } + lab2:; + 3) NaNs need to be supported, but it is known at compile time or cheaply + at runtime whether array is nonempty or not: + limit = Infinity; + pos = 0; + S = from; + while (S <= to) { + if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; } + S++; + } + if (from <= to) pos = 1; + goto lab2; + lab1:; + while (S <= to) { + if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); } + S++; + } + lab2:; + 4) NaNs aren't supported, array mask is used: + limit = infinities_supported ? Infinity : huge (limit); + pos = 0; + S = from; + while (S <= to) { + if (mask[S]) { limit = a[S]; pos = S + (1 - from); goto lab1; } + S++; + } + goto lab2; + lab1:; + while (S <= to) { + if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); } + S++; + } + lab2:; + 5) Same without array mask: + limit = infinities_supported ? Infinity : huge (limit); + pos = (from <= to) ? 1 : 0; + S = from; + while (S <= to) { + if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); } + S++; + } + For 3) and 5), if mask is scalar, this all goes into a conditional, + setting pos = 0; in the else branch. */ + static void gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) { @@ -2124,9 +2185,12 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) tree limit; tree type; tree tmp; + tree cond; tree elsetmp; tree ifbody; tree offset; + tree nonempty; + tree lab1, lab2; gfc_loopinfo loop; gfc_actual_arglist *actual; gfc_ss *arrayss; @@ -2158,21 +2222,39 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) actual = actual->next->next; gcc_assert (actual); maskexpr = actual->expr; + nonempty = NULL; if (maskexpr && maskexpr->rank != 0) { maskss = gfc_walk_expr (maskexpr); gcc_assert (maskss != gfc_ss_terminator); } else - maskss = NULL; + { + mpz_t asize; + if (gfc_array_size (arrayexpr, &asize) == SUCCESS) + { + nonempty = gfc_conv_mpz_to_tree (asize, gfc_index_integer_kind); + mpz_clear (asize); + nonempty = fold_build2 (GT_EXPR, boolean_type_node, nonempty, + gfc_index_zero_node); + } + maskss = NULL; + } limit = gfc_create_var (gfc_typenode_for_spec (&arrayexpr->ts), "limit"); n = gfc_validate_kind (arrayexpr->ts.type, arrayexpr->ts.kind, false); switch (arrayexpr->ts.type) { case BT_REAL: - tmp = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge, - arrayexpr->ts.kind, 0); + if (HONOR_INFINITIES (DECL_MODE (limit))) + { + REAL_VALUE_TYPE real; + real_inf (&real); + tmp = build_real (TREE_TYPE (limit), real); + } + else + tmp = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge, + arrayexpr->ts.kind, 0); break; case BT_INTEGER: @@ -2190,12 +2272,12 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) possible value is HUGE in both cases. */ if (op == GT_EXPR) tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp); - gfc_add_modify (&se->pre, limit, tmp); - if (op == GT_EXPR && expr->ts.type == BT_INTEGER) tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (tmp), tmp, build_int_cst (type, 1)); + gfc_add_modify (&se->pre, limit, tmp); + /* Initialize the scalarizer. */ gfc_init_loopinfo (&loop); gfc_add_ss_to_loop (&loop, arrayss); @@ -2207,11 +2289,30 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) gfc_conv_loop_setup (&loop, &expr->where); gcc_assert (loop.dimen == 1); + if (nonempty == NULL && maskss == NULL && loop.from[0] && loop.to[0]) + nonempty = fold_build2 (LE_EXPR, boolean_type_node, loop.from[0], + loop.to[0]); + lab1 = NULL; + lab2 = NULL; /* Initialize the position to zero, following Fortran 2003. We are free to do this because Fortran 95 allows the result of an entirely false - mask to be processor dependent. */ - gfc_add_modify (&loop.pre, pos, gfc_index_zero_node); + mask to be processor dependent. If we know at compile time the array + is non-empty and no MASK is used, we can initialize to 1 to simplify + the inner loop. */ + if (nonempty != NULL && !HONOR_NANS (DECL_MODE (limit))) + gfc_add_modify (&loop.pre, pos, + fold_build3 (COND_EXPR, gfc_array_index_type, + nonempty, gfc_index_one_node, + gfc_index_zero_node)); + else + { + gfc_add_modify (&loop.pre, pos, gfc_index_zero_node); + lab1 = gfc_build_label_decl (NULL_TREE); + TREE_USED (lab1) = 1; + lab2 = gfc_build_label_decl (NULL_TREE); + TREE_USED (lab2) = 1; + } gfc_mark_ss_chain_used (arrayss, 1); if (maskss) @@ -2253,27 +2354,47 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) gfc_index_one_node, loop.from[0]); else tmp = gfc_index_one_node; - + gfc_add_modify (&block, offset, tmp); + if (nonempty == NULL && HONOR_NANS (DECL_MODE (limit))) + { + stmtblock_t ifblock2; + tree ifbody2; + + gfc_start_block (&ifblock2); + tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (pos), + loop.loopvar[0], offset); + gfc_add_modify (&ifblock2, pos, tmp); + ifbody2 = gfc_finish_block (&ifblock2); + cond = fold_build2 (EQ_EXPR, boolean_type_node, pos, + gfc_index_zero_node); + tmp = build3_v (COND_EXPR, cond, ifbody2, + build_empty_stmt (input_location)); + gfc_add_expr_to_block (&block, tmp); + } + tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (pos), loop.loopvar[0], offset); gfc_add_modify (&ifblock, pos, tmp); + if (lab1) + gfc_add_expr_to_block (&ifblock, build1_v (GOTO_EXPR, lab1)); + ifbody = gfc_finish_block (&ifblock); - /* If it is a more extreme value or pos is still zero and the value - equal to the limit. */ - tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, - fold_build2 (EQ_EXPR, boolean_type_node, - pos, gfc_index_zero_node), - fold_build2 (EQ_EXPR, boolean_type_node, - arrayse.expr, limit)); - tmp = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, - fold_build2 (op, boolean_type_node, - arrayse.expr, limit), tmp); - tmp = build3_v (COND_EXPR, tmp, ifbody, build_empty_stmt (input_location)); - gfc_add_expr_to_block (&block, tmp); + if (!lab1 || HONOR_NANS (DECL_MODE (limit))) + { + if (lab1) + cond = fold_build2 (op == GT_EXPR ? GE_EXPR : LE_EXPR, + boolean_type_node, arrayse.expr, limit); + else + cond = fold_build2 (op, boolean_type_node, arrayse.expr, limit); + + ifbody = build3_v (COND_EXPR, cond, ifbody, + build_empty_stmt (input_location)); + } + gfc_add_expr_to_block (&block, ifbody); if (maskss) { @@ -2287,8 +2408,95 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) tmp = gfc_finish_block (&block); gfc_add_expr_to_block (&body, tmp); + if (lab1) + { + gfc_trans_scalarized_loop_end (&loop, 0, &body); + + if (HONOR_NANS (DECL_MODE (limit))) + { + if (nonempty != NULL) + { + ifbody = build2_v (MODIFY_EXPR, pos, gfc_index_one_node); + tmp = build3_v (COND_EXPR, nonempty, ifbody, + build_empty_stmt (input_location)); + gfc_add_expr_to_block (&loop.code[0], tmp); + } + } + + gfc_add_expr_to_block (&loop.code[0], build1_v (GOTO_EXPR, lab2)); + gfc_add_expr_to_block (&loop.code[0], build1_v (LABEL_EXPR, lab1)); + gfc_start_block (&body); + + /* If we have a mask, only check this element if the mask is set. */ + if (maskss) + { + gfc_init_se (&maskse, NULL); + gfc_copy_loopinfo_to_se (&maskse, &loop); + maskse.ss = maskss; + gfc_conv_expr_val (&maskse, maskexpr); + gfc_add_block_to_block (&body, &maskse.pre); + + gfc_start_block (&block); + } + else + gfc_init_block (&block); + + /* Compare with the current limit. */ + gfc_init_se (&arrayse, NULL); + gfc_copy_loopinfo_to_se (&arrayse, &loop); + arrayse.ss = arrayss; + gfc_conv_expr_val (&arrayse, arrayexpr); + gfc_add_block_to_block (&block, &arrayse.pre); + + /* We do the following if this is a more extreme value. */ + gfc_start_block (&ifblock); + + /* Assign the value to the limit... */ + gfc_add_modify (&ifblock, limit, arrayse.expr); + + /* Remember where we are. An offset must be added to the loop + counter to obtain the required position. */ + if (loop.from[0]) + tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, + gfc_index_one_node, loop.from[0]); + else + tmp = gfc_index_one_node; + + gfc_add_modify (&block, offset, tmp); + + tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (pos), + loop.loopvar[0], offset); + gfc_add_modify (&ifblock, pos, tmp); + + ifbody = gfc_finish_block (&ifblock); + + cond = fold_build2 (op, boolean_type_node, arrayse.expr, limit); + + tmp = build3_v (COND_EXPR, cond, ifbody, + build_empty_stmt (input_location)); + gfc_add_expr_to_block (&block, tmp); + + if (maskss) + { + /* We enclose the above in if (mask) {...}. */ + tmp = gfc_finish_block (&block); + + tmp = build3_v (COND_EXPR, maskse.expr, tmp, + build_empty_stmt (input_location)); + } + else + tmp = gfc_finish_block (&block); + gfc_add_expr_to_block (&body, tmp); + /* Avoid initializing loopvar[0] again, it should be left where + it finished by the first loop. */ + loop.from[0] = loop.loopvar[0]; + } + gfc_trans_scalarizing_loops (&loop, &body); + if (lab2) + gfc_add_expr_to_block (&loop.pre, build1_v (LABEL_EXPR, lab2)); + /* For a scalar mask, enclose the loop in an if statement. */ if (maskexpr && maskss == NULL) { @@ -2320,6 +2528,99 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) se->expr = convert (type, pos); } +/* Emit code for minval or maxval intrinsic. There are many different cases + we need to handle. For performance reasons we sometimes create two + loops instead of one, where the second one is much simpler. + Examples for minval intrinsic: + 1) Result is an array, a call is generated + 2) Array mask is used and NaNs need to be supported, rank 1: + limit = Infinity; + nonempty = false; + S = from; + while (S <= to) { + if (mask[S]) { nonempty = true; if (a[S] <= limit) goto lab; } + S++; + } + limit = nonempty ? NaN : huge (limit); + lab: + while (S <= to) { if(mask[S]) limit = min (a[S], limit); S++; } + 3) NaNs need to be supported, but it is known at compile time or cheaply + at runtime whether array is nonempty or not, rank 1: + limit = Infinity; + S = from; + while (S <= to) { if (a[S] <= limit) goto lab; S++; } + limit = (from <= to) ? NaN : huge (limit); + lab: + while (S <= to) { limit = min (a[S], limit); S++; } + 4) Array mask is used and NaNs need to be supported, rank > 1: + limit = Infinity; + nonempty = false; + fast = false; + S1 = from1; + while (S1 <= to1) { + S2 = from2; + while (S2 <= to2) { + if (mask[S1][S2]) { + if (fast) limit = min (a[S1][S2], limit); + else { + nonempty = true; + if (a[S1][S2] <= limit) { + limit = a[S1][S2]; + fast = true; + } + } + } + S2++; + } + S1++; + } + if (!fast) + limit = nonempty ? NaN : huge (limit); + 5) NaNs need to be supported, but it is known at compile time or cheaply + at runtime whether array is nonempty or not, rank > 1: + limit = Infinity; + fast = false; + S1 = from1; + while (S1 <= to1) { + S2 = from2; + while (S2 <= to2) { + if (fast) limit = min (a[S1][S2], limit); + else { + if (a[S1][S2] <= limit) { + limit = a[S1][S2]; + fast = true; + } + } + S2++; + } + S1++; + } + if (!fast) + limit = (nonempty_array) ? NaN : huge (limit); + 6) NaNs aren't supported, but infinities are. Array mask is used: + limit = Infinity; + nonempty = false; + S = from; + while (S <= to) { + if (mask[S]) { nonempty = true; limit = min (a[S], limit); } + S++; + } + limit = nonempty ? limit : huge (limit); + 7) Same without array mask: + limit = Infinity; + S = from; + while (S <= to) { limit = min (a[S], limit); S++; } + limit = (from <= to) ? limit : huge (limit); + 8) Neither NaNs nor infinities are supported (-ffast-math or BT_INTEGER): + limit = huge (limit); + S = from; + while (S <= to) { limit = min (a[S], limit); S++); } + (or + while (S <= to) { if (mask[S]) limit = min (a[S], limit); S++; } + with array mask instead). + For 3), 5), 7) and 8), if mask is scalar, this all goes into a conditional, + setting limit = huge (limit); in the else branch. */ + static void gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op) { @@ -2327,8 +2628,13 @@ gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op) tree type; tree tmp; tree ifbody; + tree nonempty; + tree nonempty_var; + tree lab; + tree fast; + tree huge_cst = NULL, nan_cst = NULL; stmtblock_t body; - stmtblock_t block; + stmtblock_t block, block2; gfc_loopinfo loop; gfc_actual_arglist *actual; gfc_ss *arrayss; @@ -2352,7 +2658,22 @@ gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op) switch (expr->ts.type) { case BT_REAL: - tmp = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge, expr->ts.kind, 0); + huge_cst = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge, + expr->ts.kind, 0); + if (HONOR_INFINITIES (DECL_MODE (limit))) + { + REAL_VALUE_TYPE real; + real_inf (&real); + tmp = build_real (type, real); + } + else + tmp = huge_cst; + if (HONOR_NANS (DECL_MODE (limit))) + { + REAL_VALUE_TYPE real; + real_nan (&real, "", 1, DECL_MODE (limit)); + nan_cst = build_real (type, real); + } break; case BT_INTEGER: @@ -2368,7 +2689,11 @@ gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op) -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive possible value is HUGE in both cases. */ if (op == GT_EXPR) - tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp); + { + tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp); + if (huge_cst) + huge_cst = fold_build1 (NEGATE_EXPR, TREE_TYPE (huge_cst), huge_cst); + } if (op == GT_EXPR && expr->ts.type == BT_INTEGER) tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (tmp), @@ -2385,13 +2710,24 @@ gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op) actual = actual->next->next; gcc_assert (actual); maskexpr = actual->expr; + nonempty = NULL; if (maskexpr && maskexpr->rank != 0) { maskss = gfc_walk_expr (maskexpr); gcc_assert (maskss != gfc_ss_terminator); } else - maskss = NULL; + { + mpz_t asize; + if (gfc_array_size (arrayexpr, &asize) == SUCCESS) + { + nonempty = gfc_conv_mpz_to_tree (asize, gfc_index_integer_kind); + mpz_clear (asize); + nonempty = fold_build2 (GT_EXPR, boolean_type_node, nonempty, + gfc_index_zero_node); + } + maskss = NULL; + } /* Initialize the scalarizer. */ gfc_init_loopinfo (&loop); @@ -2403,6 +2739,35 @@ gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op) gfc_conv_ss_startstride (&loop); gfc_conv_loop_setup (&loop, &expr->where); + if (nonempty == NULL && maskss == NULL + && loop.dimen == 1 && loop.from[0] && loop.to[0]) + nonempty = fold_build2 (LE_EXPR, boolean_type_node, loop.from[0], + loop.to[0]); + nonempty_var = NULL; + if (nonempty == NULL + && (HONOR_INFINITIES (DECL_MODE (limit)) + || HONOR_NANS (DECL_MODE (limit)))) + { + nonempty_var = gfc_create_var (boolean_type_node, "nonempty"); + gfc_add_modify (&se->pre, nonempty_var, boolean_false_node); + nonempty = nonempty_var; + } + lab = NULL; + fast = NULL; + if (HONOR_NANS (DECL_MODE (limit))) + { + if (loop.dimen == 1) + { + lab = gfc_build_label_decl (NULL_TREE); + TREE_USED (lab) = 1; + } + else + { + fast = gfc_create_var (boolean_type_node, "fast"); + gfc_add_modify (&se->pre, fast, boolean_false_node); + } + } + gfc_mark_ss_chain_used (arrayss, 1); if (maskss) gfc_mark_ss_chain_used (maskss, 1); @@ -2430,13 +2795,76 @@ gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op) gfc_conv_expr_val (&arrayse, arrayexpr); gfc_add_block_to_block (&block, &arrayse.pre); - /* Assign the value to the limit... */ - ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr); + gfc_init_block (&block2); + + if (nonempty_var) + gfc_add_modify (&block2, nonempty_var, boolean_true_node); + + if (HONOR_NANS (DECL_MODE (limit))) + { + tmp = fold_build2 (op == GT_EXPR ? GE_EXPR : LE_EXPR, + boolean_type_node, arrayse.expr, limit); + if (lab) + ifbody = build1_v (GOTO_EXPR, lab); + else + { + stmtblock_t ifblock; + + gfc_init_block (&ifblock); + gfc_add_modify (&ifblock, limit, arrayse.expr); + gfc_add_modify (&ifblock, fast, boolean_true_node); + ifbody = gfc_finish_block (&ifblock); + } + tmp = build3_v (COND_EXPR, tmp, ifbody, + build_empty_stmt (input_location)); + gfc_add_expr_to_block (&block2, tmp); + } + else + { + /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or + signed zeros. */ + if (HONOR_SIGNED_ZEROS (DECL_MODE (limit))) + { + tmp = fold_build2 (op, boolean_type_node, arrayse.expr, limit); + ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr); + tmp = build3_v (COND_EXPR, tmp, ifbody, + build_empty_stmt (input_location)); + gfc_add_expr_to_block (&block2, tmp); + } + else + { + tmp = fold_build2 (op == GT_EXPR ? MAX_EXPR : MIN_EXPR, + type, arrayse.expr, limit); + gfc_add_modify (&block2, limit, tmp); + } + } + + if (fast) + { + tree elsebody = gfc_finish_block (&block2); + + /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or + signed zeros. */ + if (HONOR_NANS (DECL_MODE (limit)) + || HONOR_SIGNED_ZEROS (DECL_MODE (limit))) + { + tmp = fold_build2 (op, boolean_type_node, arrayse.expr, limit); + ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr); + ifbody = build3_v (COND_EXPR, tmp, ifbody, + build_empty_stmt (input_location)); + } + else + { + tmp = fold_build2 (op == GT_EXPR ? MAX_EXPR : MIN_EXPR, + type, arrayse.expr, limit); + ifbody = build2_v (MODIFY_EXPR, limit, tmp); + } + tmp = build3_v (COND_EXPR, fast, ifbody, elsebody); + gfc_add_expr_to_block (&block, tmp); + } + else + gfc_add_block_to_block (&block, &block2); - /* If it is a more extreme value. */ - tmp = fold_build2 (op, boolean_type_node, arrayse.expr, limit); - tmp = build3_v (COND_EXPR, tmp, ifbody, build_empty_stmt (input_location)); - gfc_add_expr_to_block (&block, tmp); gfc_add_block_to_block (&block, &arrayse.post); tmp = gfc_finish_block (&block); @@ -2446,11 +2874,88 @@ gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op) build_empty_stmt (input_location)); gfc_add_expr_to_block (&body, tmp); + if (lab) + { + gfc_trans_scalarized_loop_end (&loop, 0, &body); + + tmp = fold_build3 (COND_EXPR, type, nonempty, nan_cst, huge_cst); + gfc_add_modify (&loop.code[0], limit, tmp); + gfc_add_expr_to_block (&loop.code[0], build1_v (LABEL_EXPR, lab)); + + gfc_start_block (&body); + + /* If we have a mask, only add this element if the mask is set. */ + if (maskss) + { + gfc_init_se (&maskse, NULL); + gfc_copy_loopinfo_to_se (&maskse, &loop); + maskse.ss = maskss; + gfc_conv_expr_val (&maskse, maskexpr); + gfc_add_block_to_block (&body, &maskse.pre); + + gfc_start_block (&block); + } + else + gfc_init_block (&block); + + /* Compare with the current limit. */ + gfc_init_se (&arrayse, NULL); + gfc_copy_loopinfo_to_se (&arrayse, &loop); + arrayse.ss = arrayss; + gfc_conv_expr_val (&arrayse, arrayexpr); + gfc_add_block_to_block (&block, &arrayse.pre); + + /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or + signed zeros. */ + if (HONOR_NANS (DECL_MODE (limit)) + || HONOR_SIGNED_ZEROS (DECL_MODE (limit))) + { + tmp = fold_build2 (op, boolean_type_node, arrayse.expr, limit); + ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr); + tmp = build3_v (COND_EXPR, tmp, ifbody, + build_empty_stmt (input_location)); + gfc_add_expr_to_block (&block, tmp); + } + else + { + tmp = fold_build2 (op == GT_EXPR ? MAX_EXPR : MIN_EXPR, + type, arrayse.expr, limit); + gfc_add_modify (&block, limit, tmp); + } + + gfc_add_block_to_block (&block, &arrayse.post); + + tmp = gfc_finish_block (&block); + if (maskss) + /* We enclose the above in if (mask) {...}. */ + tmp = build3_v (COND_EXPR, maskse.expr, tmp, + build_empty_stmt (input_location)); + gfc_add_expr_to_block (&body, tmp); + /* Avoid initializing loopvar[0] again, it should be left where + it finished by the first loop. */ + loop.from[0] = loop.loopvar[0]; + } gfc_trans_scalarizing_loops (&loop, &body); + if (fast) + { + tmp = fold_build3 (COND_EXPR, type, nonempty, nan_cst, huge_cst); + ifbody = build2_v (MODIFY_EXPR, limit, tmp); + tmp = build3_v (COND_EXPR, fast, build_empty_stmt (input_location), + ifbody); + gfc_add_expr_to_block (&loop.pre, tmp); + } + else if (HONOR_INFINITIES (DECL_MODE (limit)) && !lab) + { + tmp = fold_build3 (COND_EXPR, type, nonempty, limit, huge_cst); + gfc_add_modify (&loop.pre, limit, tmp); + } + /* For a scalar mask, enclose the loop in an if statement. */ if (maskexpr && maskss == NULL) { + tree else_stmt; + gfc_init_se (&maskse, NULL); gfc_conv_expr_val (&maskse, maskexpr); gfc_init_block (&block); @@ -2458,8 +2963,11 @@ gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op) gfc_add_block_to_block (&block, &loop.post); tmp = gfc_finish_block (&block); - tmp = build3_v (COND_EXPR, maskse.expr, tmp, - build_empty_stmt (input_location)); + if (HONOR_INFINITIES (DECL_MODE (limit))) + else_stmt = build2_v (MODIFY_EXPR, limit, huge_cst); + else + else_stmt = build_empty_stmt (input_location); + tmp = build3_v (COND_EXPR, maskse.expr, tmp, else_stmt); gfc_add_expr_to_block (&block, tmp); gfc_add_block_to_block (&se->pre, &block); } @@ -2673,7 +3181,8 @@ gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr) default: gcc_unreachable (); } - se->expr = build_call_expr (tmp, 3, args[0], args[1], args[2]); + se->expr = build_call_expr_loc (input_location, + tmp, 3, args[0], args[1], args[2]); /* Convert the result back to the original type, if we extended the first argument's width above. */ if (expr->ts.kind < 4) @@ -2821,7 +3330,8 @@ gfc_conv_intrinsic_trailz (gfc_se * se, gfc_expr *expr) result_type = gfc_get_int_type (gfc_default_integer_kind); /* Compute TRAILZ for the case i .ne. 0. */ - trailz = fold_convert (result_type, build_call_expr (func, 1, arg)); + trailz = fold_convert (result_type, build_call_expr_loc (input_location, + func, 1, arg)); /* Build BIT_SIZE. */ bit_size = build_int_cst (result_type, argsize); @@ -2932,7 +3442,7 @@ gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr) && (sym->result == sym)) decl = gfc_get_fake_result_decl (sym, 0); - len = sym->ts.cl->backend_decl; + len = sym->ts.u.cl->backend_decl; gcc_assert (len); break; } @@ -2972,7 +3482,8 @@ gfc_conv_intrinsic_len_trim (gfc_se * se, gfc_expr * expr) else gcc_unreachable (); - se->expr = build_call_expr (fndecl, 2, args[0], args[1]); + se->expr = build_call_expr_loc (input_location, + fndecl, 2, args[0], args[1]); se->expr = convert (type, se->expr); } @@ -3008,7 +3519,8 @@ gfc_conv_intrinsic_index_scan_verify (gfc_se * se, gfc_expr * expr, args[4] = convert (logical4_type_node, args[4]); fndecl = build_addr (function, current_function_decl); - se->expr = build_call_array (TREE_TYPE (TREE_TYPE (function)), fndecl, + se->expr = build_call_array_loc (input_location, + TREE_TYPE (TREE_TYPE (function)), fndecl, 5, args); se->expr = convert (type, se->expr); @@ -3026,7 +3538,8 @@ gfc_conv_intrinsic_ichar (gfc_se * se, gfc_expr * expr) args[1] = fold_build1 (NOP_EXPR, pchartype, args[1]); type = gfc_typenode_for_spec (&expr->ts); - se->expr = build_fold_indirect_ref (args[1]); + se->expr = build_fold_indirect_ref_loc (input_location, + args[1]); se->expr = convert (type, se->expr); } @@ -3039,7 +3552,8 @@ gfc_conv_intrinsic_isnan (gfc_se * se, gfc_expr * expr) tree arg; gfc_conv_intrinsic_function_args (se, expr, &arg, 1); - se->expr = build_call_expr (built_in_decls[BUILT_IN_ISNAN], 1, arg); + se->expr = build_call_expr_loc (input_location, + built_in_decls[BUILT_IN_ISNAN], 1, arg); STRIP_TYPE_NOPS (se->expr); se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr); } @@ -3130,7 +3644,8 @@ gfc_conv_intrinsic_fraction (gfc_se * se, gfc_expr * expr) type = gfc_typenode_for_spec (&expr->ts); gfc_conv_intrinsic_function_args (se, expr, &arg, 1); tmp = gfc_create_var (integer_type_node, NULL); - se->expr = build_call_expr (built_in_decls[frexp], 2, + se->expr = build_call_expr_loc (input_location, + built_in_decls[frexp], 2, fold_convert (type, arg), gfc_build_addr_expr (NULL_TREE, tmp)); se->expr = fold_convert (type, se->expr); @@ -3171,10 +3686,13 @@ gfc_conv_intrinsic_nearest (gfc_se * se, gfc_expr * expr) type = gfc_typenode_for_spec (&expr->ts); gfc_conv_intrinsic_function_args (se, expr, args, 2); - tmp = build_call_expr (built_in_decls[copysign], 2, - build_call_expr (built_in_decls[huge_val], 0), + tmp = build_call_expr_loc (input_location, + built_in_decls[copysign], 2, + build_call_expr_loc (input_location, + built_in_decls[huge_val], 0), fold_convert (type, args[1])); - se->expr = build_call_expr (built_in_decls[nextafter], 2, + se->expr = build_call_expr_loc (input_location, + built_in_decls[nextafter], 2, fold_convert (type, args[0]), tmp); se->expr = fold_convert (type, se->expr); } @@ -3239,15 +3757,17 @@ gfc_conv_intrinsic_spacing (gfc_se * se, gfc_expr * expr) /* Build the block for s /= 0. */ gfc_start_block (&block); - tmp = build_call_expr (built_in_decls[frexp], 2, arg, + tmp = build_call_expr_loc (input_location, + built_in_decls[frexp], 2, arg, gfc_build_addr_expr (NULL_TREE, e)); gfc_add_expr_to_block (&block, tmp); tmp = fold_build2 (MINUS_EXPR, integer_type_node, e, prec); gfc_add_modify (&block, e, fold_build2 (MAX_EXPR, integer_type_node, - tmp, emin)); + tmp, emin)); - tmp = build_call_expr (built_in_decls[scalbn], 2, + tmp = build_call_expr_loc (input_location, + built_in_decls[scalbn], 2, build_real_from_int_cst (type, integer_one_node), e); gfc_add_modify (&block, res, tmp); @@ -3313,17 +3833,20 @@ gfc_conv_intrinsic_rrspacing (gfc_se * se, gfc_expr * expr) e = gfc_create_var (integer_type_node, NULL); x = gfc_create_var (type, NULL); gfc_add_modify (&se->pre, x, - build_call_expr (built_in_decls[fabs], 1, arg)); + build_call_expr_loc (input_location, + built_in_decls[fabs], 1, arg)); gfc_start_block (&block); - tmp = build_call_expr (built_in_decls[frexp], 2, arg, + tmp = build_call_expr_loc (input_location, + built_in_decls[frexp], 2, arg, gfc_build_addr_expr (NULL_TREE, e)); gfc_add_expr_to_block (&block, tmp); tmp = fold_build2 (MINUS_EXPR, integer_type_node, build_int_cst (NULL_TREE, prec), e); - tmp = build_call_expr (built_in_decls[scalbn], 2, x, tmp); + tmp = build_call_expr_loc (input_location, + built_in_decls[scalbn], 2, x, tmp); gfc_add_modify (&block, x, tmp); stmt = gfc_finish_block (&block); @@ -3361,7 +3884,8 @@ gfc_conv_intrinsic_scale (gfc_se * se, gfc_expr * expr) type = gfc_typenode_for_spec (&expr->ts); gfc_conv_intrinsic_function_args (se, expr, args, 2); - se->expr = build_call_expr (built_in_decls[scalbn], 2, + se->expr = build_call_expr_loc (input_location, + built_in_decls[scalbn], 2, fold_convert (type, args[0]), fold_convert (integer_type_node, args[1])); se->expr = fold_convert (type, se->expr); @@ -3399,10 +3923,12 @@ gfc_conv_intrinsic_set_exponent (gfc_se * se, gfc_expr * expr) gfc_conv_intrinsic_function_args (se, expr, args, 2); tmp = gfc_create_var (integer_type_node, NULL); - tmp = build_call_expr (built_in_decls[frexp], 2, + tmp = build_call_expr_loc (input_location, + built_in_decls[frexp], 2, fold_convert (type, args[0]), gfc_build_addr_expr (NULL_TREE, tmp)); - se->expr = build_call_expr (built_in_decls[scalbn], 2, tmp, + se->expr = build_call_expr_loc (input_location, + built_in_decls[scalbn], 2, tmp, fold_convert (integer_type_node, args[1])); se->expr = fold_convert (type, se->expr); } @@ -3432,7 +3958,8 @@ gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr) arg1 = gfc_evaluate_now (argse.expr, &se->pre); /* Build the call to size0. */ - fncall0 = build_call_expr (gfor_fndecl_size0, 1, arg1); + fncall0 = build_call_expr_loc (input_location, + gfor_fndecl_size0, 1, arg1); actual = actual->next; @@ -3451,7 +3978,8 @@ gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr) { tree tmp; /* Build the call to size1. */ - fncall1 = build_call_expr (gfor_fndecl_size1, 2, + fncall1 = build_call_expr_loc (input_location, + gfor_fndecl_size1, 2, arg1, argse.expr); gfc_init_se (&argse, NULL); @@ -3484,7 +4012,8 @@ gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr) { tree ubound, lbound; - arg1 = build_fold_indirect_ref (arg1); + arg1 = build_fold_indirect_ref_loc (input_location, + arg1); ubound = gfc_conv_descriptor_ubound_get (arg1, argse.expr); lbound = gfc_conv_descriptor_lbound_get (arg1, argse.expr); se->expr = fold_build2 (MINUS_EXPR, gfc_array_index_type, @@ -3524,7 +4053,6 @@ gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr) gfc_expr *arg; gfc_ss *ss; gfc_se argse; - tree source; tree source_bytes; tree type; tree tmp; @@ -3540,9 +4068,9 @@ gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr) if (ss == gfc_ss_terminator) { gfc_conv_expr_reference (&argse, arg); - source = argse.expr; - type = TREE_TYPE (build_fold_indirect_ref (argse.expr)); + type = TREE_TYPE (build_fold_indirect_ref_loc (input_location, + argse.expr)); /* Obtain the source word length. */ if (arg->ts.type == BT_CHARACTER) @@ -3556,7 +4084,6 @@ gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr) source_bytes = gfc_create_var (gfc_array_index_type, "bytes"); argse.want_pointer = 0; gfc_conv_expr_descriptor (&argse, arg, ss); - source = gfc_conv_descriptor_data_get (argse.expr); type = gfc_get_element_type (TREE_TYPE (argse.expr)); /* Obtain the argument's word length. */ @@ -3622,7 +4149,8 @@ gfc_conv_intrinsic_adjust (gfc_se * se, gfc_expr * expr, tree fndecl) var = gfc_conv_string_tmp (se, type, len); args[0] = var; - tmp = build_call_expr (fndecl, 3, args[0], args[1], args[2]); + tmp = build_call_expr_loc (input_location, + fndecl, 3, args[0], args[1], args[2]); gfc_add_expr_to_block (&se->pre, tmp); se->expr = var; se->string_length = len; @@ -3660,7 +4188,6 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr) tree size_bytes; tree upper; tree lower; - tree stride; tree stmt; gfc_actual_arglist *arg; gfc_se argse; @@ -3700,7 +4227,8 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr) gfc_conv_expr_reference (&argse, arg->expr); source = argse.expr; - source_type = TREE_TYPE (build_fold_indirect_ref (argse.expr)); + source_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location, + argse.expr)); /* Obtain the source word length. */ if (arg->expr->ts.type == BT_CHARACTER) @@ -3726,7 +4254,8 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr) if (gfc_option.warn_array_temp) gfc_warning ("Creating array temporary at %L", &expr->where); - source = build_call_expr (gfor_fndecl_in_pack, 1, tmp); + source = build_call_expr_loc (input_location, + gfor_fndecl_in_pack, 1, tmp); source = gfc_evaluate_now (source, &argse.pre); /* Free the temporary. */ @@ -3762,7 +4291,6 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr) tree idx; idx = gfc_rank_cst[n]; gfc_add_modify (&argse.pre, source_bytes, tmp); - stride = gfc_conv_descriptor_stride_get (argse.expr, idx); lower = gfc_conv_descriptor_lbound_get (argse.expr, idx); upper = gfc_conv_descriptor_ubound_get (argse.expr, idx); tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, @@ -3792,7 +4320,8 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr) if (ss == gfc_ss_terminator) { gfc_conv_expr_reference (&argse, arg->expr); - mold_type = TREE_TYPE (build_fold_indirect_ref (argse.expr)); + mold_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location, + argse.expr)); } else { @@ -3834,7 +4363,8 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr) gfc_init_se (&argse, NULL); gfc_conv_expr_reference (&argse, arg->expr); tmp = convert (gfc_array_index_type, - build_fold_indirect_ref (argse.expr)); + build_fold_indirect_ref_loc (input_location, + argse.expr)); gfc_add_block_to_block (&se->pre, &argse.pre); gfc_add_block_to_block (&se->post, &argse.post); } @@ -3899,7 +4429,8 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr) tmp = fold_convert (pvoid_type_node, tmp); /* Use memcpy to do the transfer. */ - tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], + tmp = build_call_expr_loc (input_location, + built_in_decls[BUILT_IN_MEMCPY], 3, tmp, fold_convert (pvoid_type_node, source), @@ -3917,6 +4448,8 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr) scalar_transfer: extent = fold_build2 (MIN_EXPR, gfc_array_index_type, dest_word_len, source_bytes); + extent = fold_build2 (MAX_EXPR, gfc_array_index_type, + extent, gfc_index_zero_node); if (expr->ts.type == BT_CHARACTER) { @@ -3940,7 +4473,8 @@ scalar_transfer: tmp = gfc_call_malloc (&block, tmp, dest_word_len); gfc_add_modify (&block, tmpdecl, fold_convert (TREE_TYPE (ptr), tmp)); - tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3, + tmp = build_call_expr_loc (input_location, + built_in_decls[BUILT_IN_MEMCPY], 3, fold_convert (pvoid_type_node, tmpdecl), fold_convert (pvoid_type_node, ptr), extent); @@ -3964,7 +4498,8 @@ scalar_transfer: /* Use memcpy to do the transfer. */ tmp = gfc_build_addr_expr (NULL_TREE, tmpdecl); - tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3, + tmp = build_call_expr_loc (input_location, + built_in_decls[BUILT_IN_MEMCPY], 3, fold_convert (pvoid_type_node, tmp), fold_convert (pvoid_type_node, ptr), extent); @@ -3989,10 +4524,22 @@ gfc_conv_allocated (gfc_se *se, gfc_expr *expr) gfc_init_se (&arg1se, NULL); arg1 = expr->value.function.actual; ss1 = gfc_walk_expr (arg1->expr); - arg1se.descriptor_only = 1; - gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1); - tmp = gfc_conv_descriptor_data_get (arg1se.expr); + if (ss1 == gfc_ss_terminator) + { + /* Allocatable scalar. */ + arg1se.want_pointer = 1; + gfc_conv_expr (&arg1se, arg1->expr); + tmp = arg1se.expr; + } + else + { + /* Allocatable array. */ + arg1se.descriptor_only = 1; + gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1); + tmp = gfc_conv_descriptor_data_get (arg1se.expr); + } + tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp, fold_convert (TREE_TYPE (tmp), null_pointer_node)); se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp); @@ -4021,6 +4568,8 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr) gfc_init_se (&arg1se, NULL); gfc_init_se (&arg2se, NULL); arg1 = expr->value.function.actual; + if (arg1->expr->ts.type == BT_CLASS) + gfc_add_component_ref (arg1->expr, "$data"); arg2 = arg1->next; ss1 = gfc_walk_expr (arg1->expr); @@ -4054,7 +4603,7 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr) nonzero_charlen = NULL_TREE; if (arg1->expr->ts.type == BT_CHARACTER) nonzero_charlen = fold_build2 (NE_EXPR, boolean_type_node, - arg1->expr->ts.cl->backend_decl, + arg1->expr->ts.u.cl->backend_decl, integer_zero_node); if (ss1 == gfc_ss_terminator) @@ -4094,7 +4643,8 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr) gfc_conv_expr_descriptor (&arg2se, arg2->expr, ss2); gfc_add_block_to_block (&se->pre, &arg2se.pre); gfc_add_block_to_block (&se->post, &arg2se.post); - se->expr = build_call_expr (gfor_fndecl_associated, 2, + se->expr = build_call_expr_loc (input_location, + gfor_fndecl_associated, 2, arg1se.expr, arg2se.expr); se->expr = convert (boolean_type_node, se->expr); se->expr = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, @@ -4112,6 +4662,47 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr) } +/* Generate code for the SAME_TYPE_AS intrinsic. + Generate inline code that directly checks the vindices. */ + +static void +gfc_conv_same_type_as (gfc_se *se, gfc_expr *expr) +{ + gfc_expr *a, *b; + gfc_se se1, se2; + tree tmp; + + gfc_init_se (&se1, NULL); + gfc_init_se (&se2, NULL); + + a = expr->value.function.actual->expr; + b = expr->value.function.actual->next->expr; + + if (a->ts.type == BT_CLASS) + { + gfc_add_component_ref (a, "$vptr"); + gfc_add_component_ref (a, "$hash"); + } + else if (a->ts.type == BT_DERIVED) + a = gfc_int_expr (a->ts.u.derived->hash_value); + + if (b->ts.type == BT_CLASS) + { + gfc_add_component_ref (b, "$vptr"); + gfc_add_component_ref (b, "$hash"); + } + else if (b->ts.type == BT_DERIVED) + b = gfc_int_expr (b->ts.u.derived->hash_value); + + gfc_conv_expr (&se1, a); + gfc_conv_expr (&se2, b); + + tmp = fold_build2 (EQ_EXPR, boolean_type_node, + se1.expr, fold_convert (TREE_TYPE (se1.expr), se2.expr)); + se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp); +} + + /* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function. */ static void @@ -4120,7 +4711,8 @@ gfc_conv_intrinsic_sc_kind (gfc_se *se, gfc_expr *expr) tree args[2]; gfc_conv_intrinsic_function_args (se, expr, args, 2); - se->expr = build_call_expr (gfor_fndecl_sc_kind, 2, args[0], args[1]); + se->expr = build_call_expr_loc (input_location, + gfor_fndecl_sc_kind, 2, args[0], args[1]); se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr); } @@ -4140,7 +4732,8 @@ gfc_conv_intrinsic_si_kind (gfc_se *se, gfc_expr *expr) /* Convert it to the required type. */ type = gfc_typenode_for_spec (&expr->ts); - se->expr = build_call_expr (gfor_fndecl_si_kind, 1, arg); + se->expr = build_call_expr_loc (input_location, + gfor_fndecl_si_kind, 1, arg); se->expr = fold_convert (type, se->expr); } @@ -4184,7 +4777,8 @@ gfc_conv_intrinsic_sr_kind (gfc_se *se, gfc_expr *expr) /* Convert it to the required type. */ type = gfc_typenode_for_spec (&expr->ts); - se->expr = build_function_call_expr (gfor_fndecl_sr_kind, args); + se->expr = build_function_call_expr (input_location, + gfor_fndecl_sr_kind, args); se->expr = fold_convert (type, se->expr); } @@ -4223,7 +4817,8 @@ gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr) gcc_unreachable (); fndecl = build_addr (function, current_function_decl); - tmp = build_call_array (TREE_TYPE (TREE_TYPE (function)), fndecl, + tmp = build_call_array_loc (input_location, + TREE_TYPE (TREE_TYPE (function)), fndecl, num_args, args); gfc_add_expr_to_block (&se->pre, tmp); @@ -4303,7 +4898,7 @@ gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr) dlen = fold_build2 (MULT_EXPR, gfc_charlen_type_node, fold_convert (gfc_charlen_type_node, slen), fold_convert (gfc_charlen_type_node, ncopies)); - type = gfc_get_character_type (expr->ts.kind, expr->ts.cl); + type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl); dest = gfc_conv_string_tmp (se, build_pointer_type (type), dlen); /* Generate the code to do the repeat operation: @@ -4334,7 +4929,8 @@ gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr) tmp = fold_build2 (POINTER_PLUS_EXPR, pvoid_type_node, fold_convert (pvoid_type_node, dest), fold_convert (sizetype, tmp)); - tmp = build_call_expr (built_in_decls[BUILT_IN_MEMMOVE], 3, tmp, src, + tmp = build_call_expr_loc (input_location, + built_in_decls[BUILT_IN_MEMMOVE], 3, tmp, src, fold_build2 (MULT_EXPR, size_type_node, slen, fold_convert (size_type_node, size))); gfc_add_expr_to_block (&body, tmp); @@ -4373,7 +4969,8 @@ gfc_conv_intrinsic_iargc (gfc_se * se, gfc_expr * expr) /* Call the library function. This always returns an INTEGER(4). */ fndecl = gfor_fndecl_iargc; - tmp = build_call_expr (fndecl, 0); + tmp = build_call_expr_loc (input_location, + fndecl, 0); /* Convert it to the required type. */ type = gfc_typenode_for_spec (&expr->ts); @@ -4400,7 +4997,7 @@ gfc_conv_intrinsic_loc (gfc_se * se, gfc_expr * expr) if (ss == gfc_ss_terminator) gfc_conv_expr_reference (se, arg_expr); else - gfc_conv_array_parameter (se, arg_expr, ss, 1, NULL, NULL, NULL); + gfc_conv_array_parameter (se, arg_expr, ss, true, NULL, NULL, NULL); se->expr= convert (gfc_get_int_type (gfc_index_integer_kind), se->expr); /* Create a temporary variable for loc return value. Without this, @@ -4417,13 +5014,10 @@ gfc_conv_intrinsic_loc (gfc_se * se, gfc_expr * expr) void gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) { - gfc_intrinsic_sym *isym; const char *name; int lib, kind; tree fndecl; - isym = expr->value.function.isym; - name = &expr->value.function.name[2]; if (expr->rank > 0 && !expr->inline_noncopying_intrinsic) @@ -4514,6 +5108,10 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) gfc_conv_associated(se, expr); break; + case GFC_ISYM_SAME_TYPE_AS: + gfc_conv_same_type_as (se, expr); + break; + case GFC_ISYM_ABS: gfc_conv_intrinsic_abs (se, expr); break; @@ -4891,6 +5489,7 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) case GFC_ISYM_CHMOD: case GFC_ISYM_DTIME: case GFC_ISYM_ETIME: + case GFC_ISYM_EXTENDS_TYPE_OF: case GFC_ISYM_FGET: case GFC_ISYM_FGETC: case GFC_ISYM_FNUM: