diff options
Diffstat (limited to 'gcc/fortran')
| -rw-r--r-- | gcc/fortran/check.c | 5 | ||||
| -rw-r--r-- | gcc/fortran/simplify.c | 4 | ||||
| -rw-r--r-- | gcc/fortran/trans-intrinsic.c | 28 |
3 files changed, 29 insertions, 8 deletions
diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index 74e5e44..65b46cd 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -3693,6 +3693,11 @@ check_rest (bt type, int kind, gfc_actual_arglist *arglist) { if (x->ts.type == type) { + if (x->ts.type == BT_CHARACTER) + { + gfc_error ("Different character kinds at %L", &x->where); + return false; + } if (!gfc_notify_std (GFC_STD_GNU, "Different type " "kinds at %L", &x->where)) return false; diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c index eb8b2af..074b50c 100644 --- a/gcc/fortran/simplify.c +++ b/gcc/fortran/simplify.c @@ -4924,6 +4924,8 @@ min_max_choose (gfc_expr *arg, gfc_expr *extremum, int sign, bool back_val) switch (arg->ts.type) { case BT_INTEGER: + if (extremum->ts.kind < arg->ts.kind) + extremum->ts.kind = arg->ts.kind; ret = mpz_cmp (arg->value.integer, extremum->value.integer) * sign; if (ret > 0) @@ -4931,6 +4933,8 @@ min_max_choose (gfc_expr *arg, gfc_expr *extremum, int sign, bool back_val) break; case BT_REAL: + if (extremum->ts.kind < arg->ts.kind) + extremum->ts.kind = arg->ts.kind; if (mpfr_nan_p (extremum->value.real)) { ret = 1; diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index fd88099..2483f01 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -4073,6 +4073,7 @@ gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, enum tree_code op) tree val; tree *args; tree type; + tree argtype; gfc_actual_arglist *argexpr; unsigned int i, nargs; @@ -4082,16 +4083,24 @@ gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, enum tree_code op) gfc_conv_intrinsic_function_args (se, expr, args, nargs); type = gfc_typenode_for_spec (&expr->ts); - argexpr = expr->value.function.actual; - if (TREE_TYPE (args[0]) != type) - args[0] = convert (type, args[0]); /* Only evaluate the argument once. */ if (!VAR_P (args[0]) && !TREE_CONSTANT (args[0])) args[0] = gfc_evaluate_now (args[0], &se->pre); - mvar = gfc_create_var (type, "M"); - gfc_add_modify (&se->pre, mvar, args[0]); + /* Determine suitable type of temporary, as a GNU extension allows + different argument kinds. */ + argtype = TREE_TYPE (args[0]); + argexpr = expr->value.function.actual; + for (i = 1, argexpr = argexpr->next; i < nargs; i++, argexpr = argexpr->next) + { + tree tmptype = TREE_TYPE (args[i]); + if (TYPE_PRECISION (tmptype) > TYPE_PRECISION (argtype)) + argtype = tmptype; + } + mvar = gfc_create_var (argtype, "M"); + gfc_add_modify (&se->pre, mvar, convert (argtype, args[0])); + argexpr = expr->value.function.actual; for (i = 1, argexpr = argexpr->next; i < nargs; i++, argexpr = argexpr->next) { tree cond = NULL_TREE; @@ -4119,8 +4128,8 @@ gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, enum tree_code op) Also, there is no consensus among other tested compilers. In short, it's a mess. So lets just do whatever is fastest. */ tree_code code = op == GT_EXPR ? MAX_EXPR : MIN_EXPR; - calc = fold_build2_loc (input_location, code, type, - convert (type, val), mvar); + calc = fold_build2_loc (input_location, code, argtype, + convert (argtype, val), mvar); tmp = build2_v (MODIFY_EXPR, mvar, calc); if (cond != NULL_TREE) @@ -4128,7 +4137,10 @@ gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, enum tree_code op) build_empty_stmt (input_location)); gfc_add_expr_to_block (&se->pre, tmp); } - se->expr = mvar; + if (TREE_CODE (type) == INTEGER_TYPE) + se->expr = fold_build1_loc (input_location, FIX_TRUNC_EXPR, type, mvar); + else + se->expr = convert (type, mvar); } |