diff options
Diffstat (limited to 'gcc/fortran')
| -rw-r--r-- | gcc/fortran/ChangeLog | 273 | ||||
| -rw-r--r-- | gcc/fortran/arith.c | 1 | ||||
| -rw-r--r-- | gcc/fortran/check.c | 25 | ||||
| -rw-r--r-- | gcc/fortran/convert.c | 22 | ||||
| -rw-r--r-- | gcc/fortran/decl.c | 43 | ||||
| -rw-r--r-- | gcc/fortran/expr.c | 42 | ||||
| -rw-r--r-- | gcc/fortran/frontend-passes.c | 214 | ||||
| -rw-r--r-- | gcc/fortran/gfortran.h | 5 | ||||
| -rw-r--r-- | gcc/fortran/interface.c | 9 | ||||
| -rw-r--r-- | gcc/fortran/intrinsic.c | 26 | ||||
| -rw-r--r-- | gcc/fortran/intrinsic.h | 4 | ||||
| -rw-r--r-- | gcc/fortran/invoke.texi | 32 | ||||
| -rw-r--r-- | gcc/fortran/iresolve.c | 60 | ||||
| -rw-r--r-- | gcc/fortran/lang.opt | 8 | ||||
| -rw-r--r-- | gcc/fortran/options.c | 5 | ||||
| -rw-r--r-- | gcc/fortran/parse.c | 12 | ||||
| -rw-r--r-- | gcc/fortran/resolve.c | 28 | ||||
| -rw-r--r-- | gcc/fortran/simplify.c | 5 | ||||
| -rw-r--r-- | gcc/fortran/trans-array.c | 161 | ||||
| -rw-r--r-- | gcc/fortran/trans-decl.c | 24 | ||||
| -rw-r--r-- | gcc/fortran/trans-expr.c | 96 | ||||
| -rw-r--r-- | gcc/fortran/trans-intrinsic.c | 289 | ||||
| -rw-r--r-- | gcc/fortran/trans-io.c | 12 | ||||
| -rw-r--r-- | gcc/fortran/trans-openmp.c | 26 | ||||
| -rw-r--r-- | gcc/fortran/trans-stmt.c | 63 | ||||
| -rw-r--r-- | gcc/fortran/trans-types.c | 12 | ||||
| -rw-r--r-- | gcc/fortran/trans-types.h | 14 | ||||
| -rw-r--r-- | gcc/fortran/trans.c | 58 |
28 files changed, 1116 insertions, 453 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index aa43ff4ebff..d3170c7370a 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,276 @@ +2017-11-15 Martin Liska <mliska@suse.cz> + + * options.c (gfc_post_options): + Do not set default value of warn_return_type. + * trans-decl.c (gfc_trans_deferred_vars): + Compare warn_return_type for greater than zero. + (generate_local_decl): Likewise + (gfc_generate_function_code): Likewise. + +2017-11-13 Fritz Reese <fritzoreese@gmail.com> + + PR fortran/78240 + * decl.c (match_clist_expr): Replace gcc_assert with proper + handling of bad result from spec_size(). + * resolve.c (check_data_variable): Avoid NULL dereference when passing + locus to gfc_error. + +2017-11-11 Janus Weil <janus@gcc.gnu.org> + + PR fortran/82932 + * resolve.c (update_compcall_arglist): Improve error recovery, + remove a gcc_assert. + +2017-11-10 Fritz Reese <fritzoreese@gmail.com> + + PR fortran/82886 + * gfortran.h (gfc_build_init_expr): New prototype. + * invoke.texi (finit-derived): Update documentation. + * expr.c (gfc_build_init_expr): New, from gfc_build_default_init_expr. + (gfc_build_default_init_expr): Redirect to gfc_build_init_expr(,,false) + (component_initializer): Force building initializers using + gfc_build_init_expr(,,true). + +2017-11-10 Martin Sebor <msebor@redhat.com> + + PR c/81117 + * gcc/fortran/decl.c (build_sym): Use strcpy instead of strncpy. + +2017-11-10 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/82934 + * trans-stmt.c (gfc_trans_allocate): Remove the gcc_assert on + null string length for assumed length typespec and set + expr3_esize to NULL_TREE; + +2017-11-09 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/78619 + * check.c (same_type_check): Introduce a new argument 'assoc' + with default value false. If this is true, use the symbol type + spec of BT_PROCEDURE expressions. + (gfc_check_associated): Set 'assoc' true in the call to + 'same_type_check'. + +2017-11-09 Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/78814 + * interface.c (symbol_rank): Check for NULL pointer. + +2017-11-08 Steven G. Kargl <kargl@kgcc.gnu.org> + + PR Fortran/82841 + * simplify.c(gfc_simplify_transfer): Do not dereference a NULL pointer. + Unwrap a short line. + +2017-11-08 Steven G. Kargl <kargl@gcc.gnu.org> + + PR fortran/82884 + * arith.c (gfc_hollerith2character): Clear pad. + +2017-11-08 Janne Blomqvist <jb@gcc.gnu.org> + + PR 82869 + * convert.c (truthvalue_conversion): Use logical_type_node. + * trans-array.c (gfc_trans_allocate_array_storage): Likewise. + (gfc_trans_create_temp_array): Likewise. + (gfc_trans_array_ctor_element): Likewise. + (gfc_trans_array_constructor_value): Likewise. + (trans_array_constructor): Likewise. + (trans_array_bound_check): Likewise. + (gfc_conv_array_ref): Likewise. + (gfc_trans_scalarized_loop_end): Likewise. + (gfc_conv_array_extent_dim): Likewise. + (gfc_array_init_size): Likewise. + (gfc_array_allocate): Likewise. + (gfc_trans_array_bounds): Likewise. + (gfc_trans_dummy_array_bias): Likewise. + (gfc_conv_array_parameter): Likewise. + (duplicate_allocatable): Likewise. + (duplicate_allocatable_coarray): Likewise. + (structure_alloc_comps): Likewise + (get_std_lbound): Likewise + (gfc_alloc_allocatable_for_assignment): Likewise + * trans-decl.c (add_argument_checking): Likewise + (gfc_generate_function_code): Likewise + * trans-expr.c (gfc_copy_class_to_class): Likewise + (gfc_trans_class_array_init_assign): Likewise + (gfc_trans_class_init_assign): Likewise + (gfc_conv_expr_present): Likewise + (gfc_conv_substring): Likewise + (gfc_conv_cst_int_power): Likewise + (gfc_conv_expr_op): Likewise + (gfc_conv_procedure_call): Likewise + (fill_with_spaces): Likewise + (gfc_trans_string_copy): Likewise + (gfc_trans_alloc_subarray_assign): Likewise + (gfc_trans_pointer_assignment): Likewise + (gfc_trans_scalar_assign): Likewise + (fcncall_realloc_result): Likewise + (alloc_scalar_allocatable_for_assignment): Likewise + (trans_class_assignment): Likewise + (gfc_trans_assignment_1): Likewise + * trans-intrinsic.c (build_fixbound_expr): Likewise + (gfc_conv_intrinsic_aint): Likewise + (gfc_trans_same_strlen_check): Likewise + (conv_caf_send): Likewise + (trans_this_image): Likewise + (conv_intrinsic_image_status): Likewise + (trans_image_index): Likewise + (gfc_conv_intrinsic_bound): Likewise + (conv_intrinsic_cobound): Likewise + (gfc_conv_intrinsic_mod): Likewise + (gfc_conv_intrinsic_dshift): Likewise + (gfc_conv_intrinsic_dim): Likewise + (gfc_conv_intrinsic_sign): Likewise + (gfc_conv_intrinsic_ctime): Likewise + (gfc_conv_intrinsic_fdate): Likewise + (gfc_conv_intrinsic_ttynam): Likewise + (gfc_conv_intrinsic_minmax): Likewise + (gfc_conv_intrinsic_minmax_char): Likewise + (gfc_conv_intrinsic_anyall): Likewise + (gfc_conv_intrinsic_arith): Likewise + (gfc_conv_intrinsic_minmaxloc): Likewise + (gfc_conv_intrinsic_minmaxval): Likewise + (gfc_conv_intrinsic_btest): Likewise + (gfc_conv_intrinsic_bitcomp): Likewise + (gfc_conv_intrinsic_shift): Likewise + (gfc_conv_intrinsic_ishft): Likewise + (gfc_conv_intrinsic_ishftc): Likewise + (gfc_conv_intrinsic_leadz): Likewise + (gfc_conv_intrinsic_trailz): Likewise + (gfc_conv_intrinsic_mask): Likewise + (gfc_conv_intrinsic_spacing): Likewise + (gfc_conv_intrinsic_rrspacing): Likewise + (gfc_conv_intrinsic_size): Likewise + (gfc_conv_intrinsic_sizeof): Likewise + (gfc_conv_intrinsic_transfer): Likewise + (gfc_conv_allocated): Likewise + (gfc_conv_associated): Likewise + (gfc_conv_same_type_as): Likewise + (gfc_conv_intrinsic_trim): Likewise + (gfc_conv_intrinsic_repeat): Likewise + (conv_isocbinding_function): Likewise + (conv_intrinsic_ieee_is_normal): Likewise + (conv_intrinsic_ieee_is_negative): Likewise + (conv_intrinsic_ieee_copy_sign): Likewise + (conv_intrinsic_move_alloc): Likewise + * trans-io.c (set_parameter_value_chk): Likewise + (set_parameter_value_inquire): Likewise + (set_string): Likewise + * trans-openmp.c (gfc_walk_alloc_comps): Likewise + (gfc_omp_clause_default_ctor): Likewise + (gfc_omp_clause_copy_ctor): Likewise + (gfc_omp_clause_assign_op): Likewise + (gfc_omp_clause_dtor): Likewise + (gfc_omp_finish_clause): Likewise + (gfc_trans_omp_clauses): Likewise + (gfc_trans_omp_do): Likewise + * trans-stmt.c (gfc_trans_goto): Likewise + (gfc_trans_sync): Likewise + (gfc_trans_arithmetic_if): Likewise + (gfc_trans_simple_do): Likewise + (gfc_trans_do): Likewise + (gfc_trans_forall_loop): Likewise + (gfc_trans_where_2): Likewise + (gfc_trans_allocate): Likewise + (gfc_trans_deallocate): Likewise + * trans-types.c (gfc_init_types): Initialize logical_type_node and + their true/false trees. + (gfc_get_array_descr_info): Use logical_type_node. + * trans-types.h (logical_type_node): New tree. + (logical_true_node): Likewise. + (logical_false_node): Likewise. + * trans.c (gfc_trans_runtime_check): Use logical_type_node. + (gfc_call_malloc): Likewise + (gfc_allocate_using_malloc): Likewise + (gfc_allocate_allocatable): Likewise + (gfc_add_comp_finalizer_call): Likewise + (gfc_add_finalizer_call): Likewise + (gfc_deallocate_with_status): Likewise + (gfc_deallocate_scalar_with_status): Likewise + (gfc_call_realloc): Likewise + +2017-11-06 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/69739 + * trans-expr.c (gfc_map_intrinsic_function): Return false for + bounds without the DIM argument instead of ICEing. + +2017-11-06 Martin Liska <mliska@suse.cz> + + PR middle-end/82404 + * options.c (gfc_post_options): Set default value of + -Wreturn-type to false. + +2017-11-05 Thomas Koenig <tkoenig@gcc.gnu.org> + + PR fortran/82471 + * lang.opt (ffrontend-loop-interchange): New option. + (Wfrontend-loop-interchange): New option. + * options.c (gfc_post_options): Handle ffrontend-loop-interchange. + * frontend-passes.c (gfc_run_passes): Run + optimize_namespace if flag_frontend_optimize or + flag_frontend_loop_interchange are set. + (optimize_namespace): Run functions according to flags set; + also call index_interchange. + (ind_type): New function. + (has_var): New function. + (index_cost): New function. + (loop_comp): New function. + +2017-11-05 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/78641 + * resolve.c (resolve_ordinary_assign): Do not add the _data + component for class valued array constructors being assigned + to derived type arrays. + * trans-array.c (gfc_trans_array_ctor_element): Take the _data + of class valued elements for assignment to derived type arrays. + +2017-11-05 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/81447 + PR fortran/82783 + * resolve.c (resolve_component): There is no need to resolve + the components of a use associated vtype. + (resolve_fl_derived): Unconditionally generate a vtable for any + module derived type, as long as the standard is F2003 or later + and it is not a vtype or a PDT template. + +2017-11-05 Tom de Vries <tom@codesourcery.com> + + PR other/82784 + * parse.c (match, matcha, matchs, matcho, matchds, matchdo): Remove + semicolon after "do {} while (0)". + +2017-11-04 Andre Vehreschild <vehre@gcc.gnu.org> + + * trans-expr.c (gfc_trans_assignment_1): Character kind conversion may + create a loop variant temporary, too. + * trans-intrinsic.c (conv_caf_send): Treat char arrays as arrays and + not as scalars. + * trans.c (get_array_span): Take the character kind into account when + doing pointer arithmetic. + +2017-11-04 Thomas Koenig <tkoenig@gcc.gnu.org> + + PR fortran/29600 + * gfortran.h (gfc_check_f): Replace fm3l with fm4l. + * intrinsic.h (gfc_resolve_maxloc): Add gfc_expr * to argument + list in protoytpe. + (gfc_resolve_minloc): Likewise. + * check.c (gfc_check_minloc_maxloc): Handle kind argument. + * intrinsic.c (add_sym_3_ml): Rename to + (add_sym_4_ml): and handle kind argument. + (add_function): Replace add_sym_3ml with add_sym_4ml and add + extra arguments for maxloc and minloc. + (check_specific): Change use of check.f3ml with check.f4ml. + * iresolve.c (gfc_resolve_maxloc): Handle kind argument. If + the kind is smaller than the smallest library version available, + use gfc_default_integer_kind and convert afterwards. + (gfc_resolve_minloc): Likewise. + 2017-11-04 Paul Thomas <pault@gcc.gnu.org> PR fortran/81735 diff --git a/gcc/fortran/arith.c b/gcc/fortran/arith.c index c3be14df522..3c75895e2ef 100644 --- a/gcc/fortran/arith.c +++ b/gcc/fortran/arith.c @@ -2604,6 +2604,7 @@ gfc_hollerith2character (gfc_expr *src, int kind) result = gfc_copy_expr (src); result->ts.type = BT_CHARACTER; result->ts.kind = kind; + result->ts.u.pad = 0; result->value.character.length = result->representation.length; result->value.character.string diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index 759c15adaec..a147449bf70 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -427,15 +427,22 @@ less_than_bitsize2 (const char *arg1, gfc_expr *expr1, const char *arg2, /* Make sure two expressions have the same type. */ static bool -same_type_check (gfc_expr *e, int n, gfc_expr *f, int m) +same_type_check (gfc_expr *e, int n, gfc_expr *f, int m, bool assoc = false) { gfc_typespec *ets = &e->ts; gfc_typespec *fts = &f->ts; - if (e->ts.type == BT_PROCEDURE && e->symtree->n.sym) - ets = &e->symtree->n.sym->ts; - if (f->ts.type == BT_PROCEDURE && f->symtree->n.sym) - fts = &f->symtree->n.sym->ts; + if (assoc) + { + /* Procedure pointer component expressions have the type of the interface + procedure. If they are being tested for association with a procedure + pointer (ie. not a component), the type of the procedure must be + determined. */ + if (e->ts.type == BT_PROCEDURE && e->symtree->n.sym) + ets = &e->symtree->n.sym->ts; + if (f->ts.type == BT_PROCEDURE && f->symtree->n.sym) + fts = &f->symtree->n.sym->ts; + } if (gfc_compare_types (ets, fts)) return true; @@ -1002,7 +1009,7 @@ gfc_check_associated (gfc_expr *pointer, gfc_expr *target) } t = true; - if (!same_type_check (pointer, 0, target, 1)) + if (!same_type_check (pointer, 0, target, 1, true)) t = false; if (!rank_check (target, 0, pointer->rank)) t = false; @@ -3179,7 +3186,7 @@ gfc_check_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b) bool gfc_check_minloc_maxloc (gfc_actual_arglist *ap) { - gfc_expr *a, *m, *d; + gfc_expr *a, *m, *d, *k; a = ap->expr; if (!int_or_real_check (a, 0) || !array_check (a, 0)) @@ -3187,6 +3194,7 @@ gfc_check_minloc_maxloc (gfc_actual_arglist *ap) d = ap->next->expr; m = ap->next->next->expr; + k = ap->next->next->next->expr; if (m == NULL && d != NULL && d->ts.type == BT_LOGICAL && ap->next->name == NULL) @@ -3214,6 +3222,9 @@ gfc_check_minloc_maxloc (gfc_actual_arglist *ap) gfc_current_intrinsic)) return false; + if (!kind_check (k, 1, BT_INTEGER)) + return false; + return true; } diff --git a/gcc/fortran/convert.c b/gcc/fortran/convert.c index 35203235e8f..13bff7345aa 100644 --- a/gcc/fortran/convert.c +++ b/gcc/fortran/convert.c @@ -29,10 +29,14 @@ along with GCC; see the file COPYING3. If not see #include "fold-const.h" #include "convert.h" +#include "gfortran.h" +#include "trans.h" +#include "trans-types.h" + /* Prepare expr to be an argument of a TRUTH_NOT_EXPR, or validate its data type for a GIMPLE `if' or `while' statement. - The resulting type should always be `boolean_type_node'. */ + The resulting type should always be `logical_type_node'. */ static tree truthvalue_conversion (tree expr) @@ -40,25 +44,29 @@ truthvalue_conversion (tree expr) switch (TREE_CODE (TREE_TYPE (expr))) { case BOOLEAN_TYPE: - if (TREE_TYPE (expr) == boolean_type_node) + if (TREE_TYPE (expr) == logical_type_node) return expr; else if (COMPARISON_CLASS_P (expr)) { - TREE_TYPE (expr) = boolean_type_node; + TREE_TYPE (expr) = logical_type_node; return expr; } else if (TREE_CODE (expr) == NOP_EXPR) return fold_build1_loc (input_location, NOP_EXPR, - boolean_type_node, TREE_OPERAND (expr, 0)); + logical_type_node, + TREE_OPERAND (expr, 0)); else - return fold_build1_loc (input_location, NOP_EXPR, boolean_type_node, + return fold_build1_loc (input_location, NOP_EXPR, + logical_type_node, expr); case INTEGER_TYPE: if (TREE_CODE (expr) == INTEGER_CST) - return integer_zerop (expr) ? boolean_false_node : boolean_true_node; + return integer_zerop (expr) ? logical_false_node + : logical_true_node; else - return fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + return fold_build2_loc (input_location, NE_EXPR, + logical_type_node, expr, build_int_cst (TREE_TYPE (expr), 0)); default: diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index 1a2d8f004ca..e57cfded540 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -632,14 +632,13 @@ match_clist_expr (gfc_expr **result, gfc_typespec *ts, gfc_array_spec *as) gfc_expr *expr = NULL; match m; locus where; - mpz_t repeat, size; + mpz_t repeat, cons_size, as_size; bool scalar; int cmp; gcc_assert (ts); mpz_init_set_ui (repeat, 0); - mpz_init (size); scalar = !as || !as->rank; /* We have already matched '/' - now look for a constant list, as with @@ -733,16 +732,30 @@ match_clist_expr (gfc_expr **result, gfc_typespec *ts, gfc_array_spec *as) expr->rank = as->rank; expr->shape = gfc_get_shape (expr->rank); - /* Validate sizes. */ - gcc_assert (gfc_array_size (expr, &size)); - gcc_assert (spec_size (as, &repeat)); - cmp = mpz_cmp (size, repeat); - if (cmp < 0) - gfc_error ("Not enough elements in array initializer at %C"); - else if (cmp > 0) - gfc_error ("Too many elements in array initializer at %C"); + /* Validate sizes. We built expr ourselves, so cons_size will be + constant (we fail above for non-constant expressions). + We still need to verify that the array-spec has constant size. */ + cmp = 0; + gcc_assert (gfc_array_size (expr, &cons_size)); + if (!spec_size (as, &as_size)) + { + gfc_error ("Expected constant array-spec in initializer list at %L", + as->type == AS_EXPLICIT ? &as->upper[0]->where : &where); + cmp = -1; + } + else + { + /* Make sure the specs are of the same size. */ + cmp = mpz_cmp (cons_size, as_size); + if (cmp < 0) + gfc_error ("Not enough elements in array initializer at %C"); + else if (cmp > 0) + gfc_error ("Too many elements in array initializer at %C"); + mpz_clear (as_size); + } + mpz_clear (cons_size); if (cmp) - goto cleanup; + goto cleanup; } /* Make sure scalar types match. */ @@ -754,7 +767,6 @@ match_clist_expr (gfc_expr **result, gfc_typespec *ts, gfc_array_spec *as) expr->ts.u.cl->length_from_typespec = 1; *result = expr; - mpz_clear (size); mpz_clear (repeat); return MATCH_YES; @@ -766,7 +778,6 @@ cleanup: expr->value.constructor = NULL; gfc_free_expr (expr); gfc_constructor_free (array_head); - mpz_clear (size); mpz_clear (repeat); return MATCH_ERROR; } @@ -1427,11 +1438,9 @@ build_sym (const char *name, gfc_charlen *cl, bool cl_deferred, { char u_name[GFC_MAX_SYMBOL_LEN + 1]; gfc_symtree *st; - int nlen; - nlen = strlen(name); - gcc_assert (nlen <= GFC_MAX_SYMBOL_LEN); - strncpy (u_name, name, nlen + 1); + gcc_assert (strlen(name) <= GFC_MAX_SYMBOL_LEN); + strcpy (u_name, name); u_name[0] = upper; st = gfc_find_symtree (gfc_current_ns->sym_root, u_name); diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index bc05db2fbae..09abacf83ec 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -4013,13 +4013,22 @@ gfc_check_assign_symbol (gfc_symbol *sym, gfc_component *comp, gfc_expr *rvalue) return true; } +/* Invoke gfc_build_init_expr to create an initializer expression, but do not + * require that an expression be built. */ + +gfc_expr * +gfc_build_default_init_expr (gfc_typespec *ts, locus *where) +{ + return gfc_build_init_expr (ts, where, false); +} /* Build an initializer for a local integer, real, complex, logical, or character variable, based on the command line flags finit-local-zero, - finit-integer=, finit-real=, finit-logical=, and finit-character=. */ + finit-integer=, finit-real=, finit-logical=, and finit-character=. + With force, an initializer is ALWAYS generated. */ gfc_expr * -gfc_build_default_init_expr (gfc_typespec *ts, locus *where) +gfc_build_init_expr (gfc_typespec *ts, locus *where, bool force) { int char_len; gfc_expr *init_expr; @@ -4028,13 +4037,24 @@ gfc_build_default_init_expr (gfc_typespec *ts, locus *where) /* Try to build an initializer expression. */ init_expr = gfc_get_constant_expr (ts->type, ts->kind, where); + /* If we want to force generation, make sure we default to zero. */ + gfc_init_local_real init_real = flag_init_real; + int init_logical = gfc_option.flag_init_logical; + if (force) + { + if (init_real == GFC_INIT_REAL_OFF) + init_real = GFC_INIT_REAL_ZERO; + if (init_logical == GFC_INIT_LOGICAL_OFF) + init_logical = GFC_INIT_LOGICAL_FALSE; + } + /* We will only initialize integers, reals, complex, logicals, and characters, and only if the corresponding command-line flags were set. Otherwise, we free init_expr and return null. */ switch (ts->type) { case BT_INTEGER: - if (gfc_option.flag_init_integer != GFC_INIT_INTEGER_OFF) + if (force || gfc_option.flag_init_integer != GFC_INIT_INTEGER_OFF) mpz_set_si (init_expr->value.integer, gfc_option.flag_init_integer_value); else @@ -4045,7 +4065,7 @@ gfc_build_default_init_expr (gfc_typespec *ts, locus *where) break; case BT_REAL: - switch (flag_init_real) + switch (init_real) { case GFC_INIT_REAL_SNAN: init_expr->is_snan = 1; @@ -4074,7 +4094,7 @@ gfc_build_default_init_expr (gfc_typespec *ts, locus *where) break; case BT_COMPLEX: - switch (flag_init_real) + switch (init_real) { case GFC_INIT_REAL_SNAN: init_expr->is_snan = 1; @@ -4106,9 +4126,9 @@ gfc_build_default_init_expr (gfc_typespec *ts, locus *where) break; case BT_LOGICAL: - if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_FALSE) + if (init_logical == GFC_INIT_LOGICAL_FALSE) init_expr->value.logical = 0; - else if (gfc_option.flag_init_logical == GFC_INIT_LOGICAL_TRUE) + else if (init_logical == GFC_INIT_LOGICAL_TRUE) init_expr->value.logical = 1; else { @@ -4120,7 +4140,7 @@ gfc_build_default_init_expr (gfc_typespec *ts, locus *where) case BT_CHARACTER: /* For characters, the length must be constant in order to create a default initializer. */ - if (gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON + if ((force || gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON) && ts->u.cl->length && ts->u.cl->length->expr_type == EXPR_CONSTANT) { @@ -4136,7 +4156,8 @@ gfc_build_default_init_expr (gfc_typespec *ts, locus *where) gfc_free_expr (init_expr); init_expr = NULL; } - if (!init_expr && gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON + if (!init_expr + && (force || gfc_option.flag_init_character == GFC_INIT_CHARACTER_ON) && ts->u.cl->length && flag_max_stack_var_size != 0) { gfc_actual_arglist *arg; @@ -4391,7 +4412,8 @@ component_initializer (gfc_typespec *ts, gfc_component *c, bool generate) /* Treat simple components like locals. */ else { - init = gfc_build_default_init_expr (&c->ts, &c->loc); + /* We MUST give an initializer, so force generation. */ + init = gfc_build_init_expr (&c->ts, &c->loc, true); gfc_apply_init (&c->ts, &c->attr, init); } diff --git a/gcc/fortran/frontend-passes.c b/gcc/fortran/frontend-passes.c index fcfaf9508c2..b3db18ac5f1 100644 --- a/gcc/fortran/frontend-passes.c +++ b/gcc/fortran/frontend-passes.c @@ -55,6 +55,7 @@ static gfc_expr* check_conjg_transpose_variable (gfc_expr *, bool *, bool *); static bool has_dimen_vector_ref (gfc_expr *); static int matmul_temp_args (gfc_code **, int *,void *data); +static int index_interchange (gfc_code **, int*, void *); #ifdef CHECKING_P static void check_locus (gfc_namespace *); @@ -155,9 +156,11 @@ gfc_run_passes (gfc_namespace *ns) check_locus (ns); #endif + if (flag_frontend_optimize || flag_frontend_loop_interchange) + optimize_namespace (ns); + if (flag_frontend_optimize) { - optimize_namespace (ns); optimize_reduction (ns); if (flag_dump_fortran_optimized) gfc_dump_parse_tree (ns, stdout); @@ -1350,7 +1353,9 @@ simplify_io_impl_do (gfc_code **code, int *walk_subtrees, return 0; } -/* Optimize a namespace, including all contained namespaces. */ +/* Optimize a namespace, including all contained namespaces. + flag_frontend_optimize and flag_fronend_loop_interchange are + handled separately. */ static void optimize_namespace (gfc_namespace *ns) @@ -1363,28 +1368,35 @@ optimize_namespace (gfc_namespace *ns) in_assoc_list = false; in_omp_workshare = false; - gfc_code_walker (&ns->code, simplify_io_impl_do, dummy_expr_callback, NULL); - gfc_code_walker (&ns->code, convert_do_while, dummy_expr_callback, NULL); - gfc_code_walker (&ns->code, convert_elseif, dummy_expr_callback, NULL); - gfc_code_walker (&ns->code, cfe_code, cfe_expr_0, NULL); - gfc_code_walker (&ns->code, optimize_code, optimize_expr, NULL); - if (flag_inline_matmul_limit != 0) + if (flag_frontend_optimize) { - bool found; - do + gfc_code_walker (&ns->code, simplify_io_impl_do, dummy_expr_callback, NULL); + gfc_code_walker (&ns->code, convert_do_while, dummy_expr_callback, NULL); + gfc_code_walker (&ns->code, convert_elseif, dummy_expr_callback, NULL); + gfc_code_walker (&ns->code, cfe_code, cfe_expr_0, NULL); + gfc_code_walker (&ns->code, optimize_code, optimize_expr, NULL); + if (flag_inline_matmul_limit != 0) { - found = false; - gfc_code_walker (&ns->code, matmul_to_var_code, matmul_to_var_expr, - (void *) &found); - } - while (found); + bool found; + do + { + found = false; + gfc_code_walker (&ns->code, matmul_to_var_code, matmul_to_var_expr, + (void *) &found); + } + while (found); - gfc_code_walker (&ns->code, matmul_temp_args, dummy_expr_callback, - NULL); - gfc_code_walker (&ns->code, inline_matmul_assign, dummy_expr_callback, - NULL); + gfc_code_walker (&ns->code, matmul_temp_args, dummy_expr_callback, + NULL); + gfc_code_walker (&ns->code, inline_matmul_assign, dummy_expr_callback, + NULL); + } } + if (flag_frontend_loop_interchange) + gfc_code_walker (&ns->code, index_interchange, dummy_expr_callback, + NULL); + /* BLOCKs are handled in the expression walker below. */ for (ns = ns->contained; ns; ns = ns->sibling) { @@ -4225,6 +4237,170 @@ inline_matmul_assign (gfc_code **c, int *walk_subtrees, return 0; } + +/* Code for index interchange for loops which are grouped together in DO + CONCURRENT or FORALL statements. This is currently only applied if the + iterations are grouped together in a single statement. + + For this transformation, it is assumed that memory access in strides is + expensive, and that loops which access later indices (which access memory + in bigger strides) should be moved to the first loops. + + For this, a loop over all the statements is executed, counting the times + that the loop iteration values are accessed in each index. The loop + indices are then sorted to minimize access to later indices from inner + loops. */ + +/* Type for holding index information. */ + +typedef struct { + gfc_symbol *sym; + gfc_forall_iterator *fa; + int num; + int n[GFC_MAX_DIMENSIONS]; +} ind_type; + +/* Callback function to determine if an expression is the + corresponding variable. */ + +static int +has_var (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, void *data) +{ + gfc_expr *expr = *e; + gfc_symbol *sym; + + if (expr->expr_type != EXPR_VARIABLE) + return 0; + + sym = (gfc_symbol *) data; + return sym == expr->symtree->n.sym; +} + +/* Callback function to calculate the cost of a certain index. */ + +static int +index_cost (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, + void *data) +{ + ind_type *ind; + gfc_expr *expr; + gfc_array_ref *ar; + gfc_ref *ref; + int i,j; + + expr = *e; + if (expr->expr_type != EXPR_VARIABLE) + return 0; + + ar = NULL; + for (ref = expr->ref; ref; ref = ref->next) + { + if (ref->type == REF_ARRAY) + { + ar = &ref->u.ar; + break; + } + } + if (ar == NULL || ar->type != AR_ELEMENT) + return 0; + + ind = (ind_type *) data; + for (i = 0; i < ar->dimen; i++) + { + for (j=0; ind[j].sym != NULL; j++) + { + if (gfc_expr_walker (&ar->start[i], has_var, (void *) (ind[j].sym))) + ind[j].n[i]++; + } + } + return 0; +} + +/* Callback function for qsort, to sort the loop indices. */ + +static int +loop_comp (const void *e1, const void *e2) +{ + const ind_type *i1 = (const ind_type *) e1; + const ind_type *i2 = (const ind_type *) e2; + int i; + + for (i=GFC_MAX_DIMENSIONS-1; i >= 0; i--) + { + if (i1->n[i] != i2->n[i]) + return i1->n[i] - i2->n[i]; + } + /* All other things being equal, let's not change the ordering. */ + return i2->num - i1->num; +} + +/* Main function to do the index interchange. */ + +static int +index_interchange (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED, + void *data ATTRIBUTE_UNUSED) +{ + gfc_code *co; + co = *c; + int n_iter; + gfc_forall_iterator *fa; + ind_type *ind; + int i, j; + + if (co->op != EXEC_FORALL && co->op != EXEC_DO_CONCURRENT) + return 0; + + n_iter = 0; + for (fa = co->ext.forall_iterator; fa; fa = fa->next) + n_iter ++; + + /* Nothing to reorder. */ + if (n_iter < 2) + return 0; + + ind = XALLOCAVEC (ind_type, n_iter + 1); + + i = 0; + for (fa = co->ext.forall_iterator; fa; fa = fa->next) + { + ind[i].sym = fa->var->symtree->n.sym; + ind[i].fa = fa; + for (j=0; j<GFC_MAX_DIMENSIONS; j++) + ind[i].n[j] = 0; + ind[i].num = i; + i++; + } + ind[n_iter].sym = NULL; + ind[n_iter].fa = NULL; + + gfc_code_walker (c, gfc_dummy_code_callback, index_cost, (void *) ind); + qsort ((void *) ind, n_iter, sizeof (ind_type), loop_comp); + + /* Do the actual index interchange. */ + co->ext.forall_iterator = fa = ind[0].fa; + for (i=1; i<n_iter; i++) + { + fa->next = ind[i].fa; + fa = fa->next; + } + fa->next = NULL; + + if (flag_warn_frontend_loop_interchange) + { + for (i=1; i<n_iter; i++) + { + if (ind[i-1].num > ind[i].num) + { + gfc_warning (OPT_Wfrontend_loop_interchange, + "Interchanging loops at %L", &co->loc); + break; + } + } + } + + return 0; +} + #define WALK_SUBEXPR(NODE) \ do \ { \ diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 2c2fc636708..a57676a2be1 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -1989,7 +1989,7 @@ gfc_intrinsic_arg; argument lists of intrinsic functions. fX with X an integer refer to check functions of intrinsics with X arguments. f1m is used for the MAX and MIN intrinsics which can have an arbitrary number of - arguments, f3ml is used for the MINLOC and MAXLOC intrinsics as + arguments, f4ml is used for the MINLOC and MAXLOC intrinsics as these have special semantics. */ typedef union @@ -1999,7 +1999,7 @@ typedef union bool (*f1m)(gfc_actual_arglist *); bool (*f2)(struct gfc_expr *, struct gfc_expr *); bool (*f3)(struct gfc_expr *, struct gfc_expr *, struct gfc_expr *); - bool (*f3ml)(gfc_actual_arglist *); + bool (*f4ml)(gfc_actual_arglist *); bool (*f3red)(gfc_actual_arglist *); bool (*f4)(struct gfc_expr *, struct gfc_expr *, struct gfc_expr *, struct gfc_expr *); @@ -3174,6 +3174,7 @@ bool gfc_check_pointer_assign (gfc_expr *, gfc_expr *); bool gfc_check_assign_symbol (gfc_symbol *, gfc_component *, gfc_expr *); gfc_expr *gfc_build_default_init_expr (gfc_typespec *, locus *); +gfc_expr *gfc_build_init_expr (gfc_typespec *, locus *, bool); void gfc_apply_init (gfc_typespec *, symbol_attribute *, gfc_expr *); bool gfc_has_default_initializer (gfc_symbol *); gfc_expr *gfc_default_initializer (gfc_typespec *); diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index 9f0fcc82f24..1b7ebf56b92 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -1262,8 +1262,13 @@ generic_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2, static int symbol_rank (gfc_symbol *sym) { - gfc_array_spec *as; - as = (sym->ts.type == BT_CLASS) ? CLASS_DATA (sym)->as : sym->as; + gfc_array_spec *as = NULL; + + if (sym->ts.type == BT_CLASS && CLASS_DATA (sym) && CLASS_DATA (sym)->as) + as = CLASS_DATA (sym)->as; + else + as = sym->as; + return as ? as->rank : 0; } diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c index da96e8ff30c..cb18b21a90d 100644 --- a/gcc/fortran/intrinsic.c +++ b/gcc/fortran/intrinsic.c @@ -687,27 +687,29 @@ add_sym_3 (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt ty might have to be reordered. */ static void -add_sym_3ml (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type, +add_sym_4ml (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type, int kind, int standard, bool (*check) (gfc_actual_arglist *), - gfc_expr *(*simplify) (gfc_expr *, gfc_expr *, gfc_expr *), - void (*resolve) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *), + gfc_expr *(*simplify) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *), + void (*resolve) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *), const char *a1, bt type1, int kind1, int optional1, const char *a2, bt type2, int kind2, int optional2, - const char *a3, bt type3, int kind3, int optional3) + const char *a3, bt type3, int kind3, int optional3, + const char *a4, bt type4, int kind4, int optional4) { gfc_check_f cf; gfc_simplify_f sf; gfc_resolve_f rf; - cf.f3ml = check; - sf.f3 = simplify; - rf.f3 = resolve; + cf.f4ml = check; + sf.f4 = simplify; + rf.f4 = resolve; add_sym (name, id, cl, actual_ok, type, kind, standard, cf, sf, rf, a1, type1, kind1, optional1, INTENT_IN, a2, type2, kind2, optional2, INTENT_IN, a3, type3, kind3, optional3, INTENT_IN, + a4, type4, kind4, optional4, INTENT_IN, (void *) 0); } @@ -2455,10 +2457,10 @@ add_functions (void) make_generic ("maxexponent", GFC_ISYM_MAXEXPONENT, GFC_STD_F95); - add_sym_3ml ("maxloc", GFC_ISYM_MAXLOC, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95, + add_sym_4ml ("maxloc", GFC_ISYM_MAXLOC, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95, gfc_check_minloc_maxloc, NULL, gfc_resolve_maxloc, ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL, - msk, BT_LOGICAL, dl, OPTIONAL); + msk, BT_LOGICAL, dl, OPTIONAL, kind, BT_INTEGER, di, OPTIONAL); make_generic ("maxloc", GFC_ISYM_MAXLOC, GFC_STD_F95); @@ -2531,10 +2533,10 @@ add_functions (void) make_generic ("minexponent", GFC_ISYM_MINEXPONENT, GFC_STD_F95); - add_sym_3ml ("minloc", GFC_ISYM_MINLOC, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95, + add_sym_4ml ("minloc", GFC_ISYM_MINLOC, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95, gfc_check_minloc_maxloc, NULL, gfc_resolve_minloc, ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL, - msk, BT_LOGICAL, dl, OPTIONAL); + msk, BT_LOGICAL, dl, OPTIONAL, kind, BT_INTEGER, di, OPTIONAL); make_generic ("minloc", GFC_ISYM_MINLOC, GFC_STD_F95); @@ -4498,7 +4500,7 @@ check_specific (gfc_intrinsic_sym *specific, gfc_expr *expr, int error_flag) if (!do_ts29113_check (specific, *ap)) return false; - if (specific->check.f3ml == gfc_check_minloc_maxloc) + if (specific->check.f4ml == gfc_check_minloc_maxloc) /* This is special because we might have to reorder the argument list. */ t = gfc_check_minloc_maxloc (*ap); else if (specific->check.f3red == gfc_check_minval_maxval) diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h index e8280f6f2ac..62827887b3c 100644 --- a/gcc/fortran/intrinsic.h +++ b/gcc/fortran/intrinsic.h @@ -537,7 +537,7 @@ void gfc_resolve_logical (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_lstat (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_matmul (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_max (gfc_expr *, gfc_actual_arglist *); -void gfc_resolve_maxloc (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); +void gfc_resolve_maxloc (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_maxval (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_mclock (gfc_expr *); void gfc_resolve_mclock8 (gfc_expr *); @@ -545,7 +545,7 @@ void gfc_resolve_mask (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_merge (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_merge_bits (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_min (gfc_expr *, gfc_actual_arglist *); -void gfc_resolve_minloc (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); +void gfc_resolve_minloc (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_minval (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_mod (gfc_expr *, gfc_expr *, gfc_expr *); void gfc_resolve_modulo (gfc_expr *, gfc_expr *, gfc_expr *); diff --git a/gcc/fortran/invoke.texi b/gcc/fortran/invoke.texi index 261f2535bb5..f3a8b34a26b 100644 --- a/gcc/fortran/invoke.texi +++ b/gcc/fortran/invoke.texi @@ -149,8 +149,9 @@ and warnings}. -Wdo-subscript -Wfunction-elimination -Wimplicit-interface @gol -Wimplicit-procedure -Wintrinsic-shadow -Wuse-without-only -Wintrinsics-std @gol -Wline-truncation -Wno-align-commons -Wno-tabs -Wreal-q-constant @gol --Wsurprising -Wunderflow -Wunused-parameter -Wrealloc-lhs -Wrealloc-lhs-all @gol --Wtarget-lifetime -fmax-errors=@var{n} -fsyntax-only -pedantic -pedantic-errors +-Wsurprising -Wunderflow -Wunused-parameter -Wrealloc-lhs @gol +-Wrealloc-lhs-all -Wfrontend-loop-interchange -Wtarget-lifetime @gol +-fmax-errors=@var{n} -fsyntax-only -pedantic -pedantic-errors @gol } @item Debugging Options @@ -183,6 +184,7 @@ and warnings}. -fbounds-check -fcheck-array-temporaries @gol -fcheck=@var{<all|array-temps|bounds|do|mem|pointer|recursion>} @gol -fcoarray=@var{<none|single|lib>} -fexternal-blas -ff2c +-ffrontend-loop-interchange @gol -ffrontend-optimize @gol -finit-character=@var{n} -finit-integer=@var{n} -finit-local-zero @gol -finit-derived @gol @@ -910,6 +912,13 @@ Enables some warning options for usages of language features which may be problematic. This currently includes @option{-Wcompare-reals}, @option{-Wunused-parameter} and @option{-Wdo-subscript}. +@item -Wfrontend-loop-interchange +@opindex @code{Wfrontend-loop-interchange} +@cindex warnings, loop interchange +@cindex loop interchange, warning +Enable warning for loop interchanges performed by the +@option{-ffrontend-loop-interchange} option. + @item -Wimplicit-interface @opindex @code{Wimplicit-interface} @cindex warnings, implicit interface @@ -1705,9 +1714,14 @@ initialization options are provided by the the real and imaginary parts of local @code{COMPLEX} variables), @option{-finit-logical=@var{<true|false>}}, and @option{-finit-character=@var{n}} (where @var{n} is an ASCII character -value) options. Components of derived type variables will be initialized -according to these flags only with @option{-finit-derived}. These options do -not initialize +value) options. + +With @option{-finit-derived}, components of derived type variables will be +initialized according to these flags. Components whose type is not covered by +an explicit @option{-finit-*} flag will be treated as described above with +@option{-finit-local-zero}. + +These options do not initialize @itemize @bullet @item objects with the POINTER attribute @@ -1782,6 +1796,14 @@ expressions, removing unnecessary calls to @code{TRIM} in comparisons and assignments and replacing @code{TRIM(a)} with @code{a(1:LEN_TRIM(a))}. It can be deselected by specifying @option{-fno-frontend-optimize}. + +@item -ffrontend-loop-interchange +@opindex @code{frontend-loop-interchange} +@cindex loop interchange, Fortran +Attempt to interchange loops in the Fortran front end where +profitable. Enabled by default by any @option{-O} option. +At the moment, this option only affects @code{FORALL} and +@code{DO CONCURRENT} statements with several forall triplets. @end table @xref{Code Gen Options,,Options for Code Generation Conventions, diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c index b784ac339e9..a54ed2295b5 100644 --- a/gcc/fortran/iresolve.c +++ b/gcc/fortran/iresolve.c @@ -1691,16 +1691,31 @@ gfc_resolve_max (gfc_expr *f, gfc_actual_arglist *args) gfc_resolve_minmax ("__max_%c%d", f, args); } +/* The smallest kind for which a minloc and maxloc implementation exists. */ + +#define MINMAXLOC_MIN_KIND 4 void gfc_resolve_maxloc (gfc_expr *f, gfc_expr *array, gfc_expr *dim, - gfc_expr *mask) + gfc_expr *mask, gfc_expr *kind) { const char *name; int i, j, idim; + int fkind; f->ts.type = BT_INTEGER; - f->ts.kind = gfc_default_integer_kind; + + /* The library versions only exist for kinds 4, 8 and 16. For smaller kinds, + we do a type conversion further down. */ + if (kind) + fkind = mpz_get_si (kind->value.integer); + else + fkind = gfc_default_integer_kind; + + if (fkind < MINMAXLOC_MIN_KIND) + f->ts.kind = MINMAXLOC_MIN_KIND; + else + f->ts.kind = fkind; if (dim == NULL) { @@ -1740,6 +1755,21 @@ gfc_resolve_maxloc (gfc_expr *f, gfc_expr *array, gfc_expr *dim, f->value.function.name = gfc_get_string (PREFIX ("%s%d_%d_%c%d"), name, dim != NULL, f->ts.kind, gfc_type_letter (array->ts.type), array->ts.kind); + + if (kind) + fkind = mpz_get_si (kind->value.integer); + else + fkind = gfc_default_integer_kind; + + if (fkind != f->ts.kind) + { + gfc_typespec ts; + gfc_clear_ts (&ts); + + ts.type = BT_INTEGER; + ts.kind = fkind; + gfc_convert_type_warn (f, &ts, 2, 0); + } } @@ -1861,13 +1891,25 @@ gfc_resolve_min (gfc_expr *f, gfc_actual_arglist *args) void gfc_resolve_minloc (gfc_expr *f, gfc_expr *array, gfc_expr *dim, - gfc_expr *mask) + gfc_expr *mask, gfc_expr *kind) { const char *name; int i, j, idim; + int fkind; f->ts.type = BT_INTEGER; - f->ts.kind = gfc_default_integer_kind; + + /* The library versions only exist for kinds 4, 8 and 16. For smaller kinds, + we do a type conversion further down. */ + if (kind) + fkind = mpz_get_si (kind->value.integer); + else + fkind = gfc_default_integer_kind; + + if (fkind < MINMAXLOC_MIN_KIND) + f->ts.kind = MINMAXLOC_MIN_KIND; + else + f->ts.kind = fkind; if (dim == NULL) { @@ -1907,6 +1949,16 @@ gfc_resolve_minloc (gfc_expr *f, gfc_expr *array, gfc_expr *dim, f->value.function.name = gfc_get_string (PREFIX ("%s%d_%d_%c%d"), name, dim != NULL, f->ts.kind, gfc_type_letter (array->ts.type), array->ts.kind); + + if (fkind != f->ts.kind) + { + gfc_typespec ts; + gfc_clear_ts (&ts); + + ts.type = BT_INTEGER; + ts.kind = fkind; + gfc_convert_type_warn (f, &ts, 2, 0); + } } diff --git a/gcc/fortran/lang.opt b/gcc/fortran/lang.opt index 88f6af57ee8..780335f3de7 100644 --- a/gcc/fortran/lang.opt +++ b/gcc/fortran/lang.opt @@ -245,6 +245,10 @@ Wextra Fortran Warning ; Documented in common +Wfrontend-loop-interchange +Fortran Var(flag_warn_frontend_loop_interchange) +Warn if loops have been interchanged. + Wfunction-elimination Fortran Warning Var(warn_function_elimination) Warn about function call elimination. @@ -548,6 +552,10 @@ ffree-line-length- Fortran RejectNegative Joined UInteger Var(flag_free_line_length) Init(132) -ffree-line-length-<n> Use n as character line width in free mode. +ffrontend-loop-interchange +Fortran Var(flag_frontend_loop_interchange) Init(-1) +Try to interchange loops if profitable. + ffrontend-optimize Fortran Var(flag_frontend_optimize) Init(-1) Enable front end optimization. diff --git a/gcc/fortran/options.c b/gcc/fortran/options.c index f7bbd7f2cde..0ee6b7808d9 100644 --- a/gcc/fortran/options.c +++ b/gcc/fortran/options.c @@ -417,6 +417,11 @@ gfc_post_options (const char **pfilename) if (flag_frontend_optimize == -1) flag_frontend_optimize = optimize; + /* Same for front end loop interchange. */ + + if (flag_frontend_loop_interchange == -1) + flag_frontend_loop_interchange = optimize; + if (flag_max_array_constructor < 65535) flag_max_array_constructor = 65535; diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c index e4deff9c79e..d025c912921 100644 --- a/gcc/fortran/parse.c +++ b/gcc/fortran/parse.c @@ -132,7 +132,7 @@ use_modules (void) return st; \ else \ undo_new_statement (); \ - } while (0); + } while (0) /* This is a specialist version of decode_statement that is used @@ -606,7 +606,7 @@ decode_statement (void) return st; \ else \ undo_new_statement (); \ - } while (0); + } while (0) static gfc_statement decode_oacc_directive (void) @@ -728,7 +728,7 @@ decode_oacc_directive (void) } \ else \ undo_new_statement (); \ - } while (0); + } while (0) /* Like match, but don't match anything if not -fopenmp and if spec_only, goto do_spec_only without actually matching. */ @@ -746,7 +746,7 @@ decode_oacc_directive (void) } \ else \ undo_new_statement (); \ - } while (0); + } while (0) /* Like match, but set a flag simd_matched if keyword matched. */ #define matchds(keyword, subr, st) \ @@ -759,7 +759,7 @@ decode_oacc_directive (void) } \ else \ undo_new_statement (); \ - } while (0); + } while (0) /* Like match, but don't match anything if not -fopenmp. */ #define matchdo(keyword, subr, st) \ @@ -774,7 +774,7 @@ decode_oacc_directive (void) } \ else \ undo_new_statement (); \ - } while (0); + } while (0) static gfc_statement decode_omp_directive (void) diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 40c1cd3c96f..bdb4015b34d 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -5834,7 +5834,9 @@ update_compcall_arglist (gfc_expr* e) return true; } - gcc_assert (tbp->pass_arg_num > 0); + if (tbp->pass_arg_num <= 0) + return false; + e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po, tbp->pass_arg_num, tbp->pass_arg); @@ -10324,7 +10326,8 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns) /* Assign the 'data' of a class object to a derived type. */ if (lhs->ts.type == BT_DERIVED - && rhs->ts.type == BT_CLASS) + && rhs->ts.type == BT_CLASS + && rhs->expr_type != EXPR_ARRAY) gfc_add_data_component (rhs); bool caf_convert_to_send = flag_coarray == GFC_FCOARRAY_LIB @@ -13496,6 +13499,9 @@ resolve_component (gfc_component *c, gfc_symbol *sym) if (c->attr.artificial) return true; + if (sym->attr.vtype && sym->attr.use_assoc) + return true; + /* F2008, C442. */ if ((!sym->attr.is_class || c != sym->components) && c->attr.codimension @@ -14075,6 +14081,20 @@ resolve_fl_derived (gfc_symbol *sym) if (!resolve_typebound_procedures (sym)) return false; + /* Generate module vtables subject to their accessibility and their not + being vtables or pdt templates. If this is not done class declarations + in external procedures wind up with their own version and so SELECT TYPE + fails because the vptrs do not have the same address. */ + if (gfc_option.allow_std & GFC_STD_F2003 + && sym->ns->proc_name + && sym->ns->proc_name->attr.flavor == FL_MODULE + && sym->attr.access != ACCESS_PRIVATE + && !(sym->attr.use_assoc || sym->attr.vtype || sym->attr.pdt_template)) + { + gfc_symbol *vtab = gfc_find_derived_vtab (sym); + gfc_set_sym_referenced (vtab); + } + return true; } @@ -15266,7 +15286,7 @@ check_data_variable (gfc_data_variable *var, locus *where) if (!gfc_array_size (e, &size)) { gfc_error ("Nonconstant array section at %L in DATA statement", - &e->where); + where); mpz_clear (offset); return false; } @@ -15943,7 +15963,7 @@ resolve_equivalence (gfc_equiv *eq) { gfc_use_rename *r; for (r = sym->ns->use_stmts->rename; r; r = r->next) - if (strcmp(r->use_name, sym->name) == 0) saw_sym = true; + if (strcmp(r->use_name, sym->name) == 0) saw_sym = true; } else saw_sym = true; diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c index ba010a0aebf..c7b7e1a8297 100644 --- a/gcc/fortran/simplify.c +++ b/gcc/fortran/simplify.c @@ -6576,8 +6576,7 @@ gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size) return NULL; /* Calculate the size of the source. */ - if (source->expr_type == EXPR_ARRAY - && !gfc_array_size (source, &tmp)) + if (source->expr_type == EXPR_ARRAY && !gfc_array_size (source, &tmp)) gfc_internal_error ("Failure getting length of a constant array."); /* Create an empty new expression with the appropriate characteristics. */ @@ -6585,7 +6584,7 @@ gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size) &source->where); result->ts = mold->ts; - mold_element = mold->expr_type == EXPR_ARRAY + mold_element = (mold->expr_type == EXPR_ARRAY && mold->value.constructor) ? gfc_constructor_first (mold->value.constructor)->expr : mold; diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index a357389ae64..93ce68e2a52 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -1034,7 +1034,7 @@ gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post, gfc_add_expr_to_block (&do_copying, tmp); was_packed = fold_build2_loc (input_location, EQ_EXPR, - boolean_type_node, packed, + logical_type_node, packed, source_data); tmp = gfc_finish_block (&do_copying); tmp = build3_v (COND_EXPR, was_packed, tmp, @@ -1302,7 +1302,7 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss, to[n], gfc_index_one_node); /* Check whether the size for this dimension is negative. */ - cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, + cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node, tmp, gfc_index_zero_node); cond = gfc_evaluate_now (cond, pre); @@ -1310,7 +1310,7 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss, or_expr = cond; else or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR, - boolean_type_node, or_expr, cond); + logical_type_node, or_expr, cond); size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, size, tmp); @@ -1570,7 +1570,7 @@ gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc, /* Verify that all constructor elements are of the same length. */ tree cond = fold_build2_loc (input_location, NE_EXPR, - boolean_type_node, first_len_val, + logical_type_node, first_len_val, se->string_length); gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where, @@ -1580,6 +1580,17 @@ gfc_trans_array_ctor_element (stmtblock_t * pblock, tree desc, } } } + else if (GFC_CLASS_TYPE_P (TREE_TYPE (se->expr)) + && !GFC_CLASS_TYPE_P (gfc_get_element_type (TREE_TYPE (desc)))) + { + /* Assignment of a CLASS array constructor to a derived type array. */ + if (expr->expr_type == EXPR_FUNCTION) + se->expr = gfc_evaluate_now (se->expr, pblock); + se->expr = gfc_class_data_get (se->expr); + se->expr = build_fold_indirect_ref_loc (input_location, se->expr); + se->expr = fold_convert (TREE_TYPE (tmp), se->expr); + gfc_add_modify (&se->pre, tmp, se->expr); + } else { /* TODO: Should the frontend already have done this conversion? */ @@ -1901,14 +1912,14 @@ gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type, /* Generate the exit condition. Depending on the sign of the step variable we have to generate the correct comparison. */ - tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, + tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node, step, build_int_cst (TREE_TYPE (step), 0)); cond = fold_build3_loc (input_location, COND_EXPR, - boolean_type_node, tmp, + logical_type_node, tmp, fold_build2_loc (input_location, GT_EXPR, - boolean_type_node, shadow_loopvar, end), + logical_type_node, shadow_loopvar, end), fold_build2_loc (input_location, LT_EXPR, - boolean_type_node, shadow_loopvar, end)); + logical_type_node, shadow_loopvar, end)); tmp = build1_v (GOTO_EXPR, exit_label); TREE_USED (exit_label) = 1; tmp = build3_v (COND_EXPR, cond, tmp, @@ -2416,7 +2427,7 @@ trans_array_constructor (gfc_ss * ss, locus * where) /* Check if the character length is negative. If it is, then set LEN = 0. */ neg_len = fold_build2_loc (input_location, LT_EXPR, - boolean_type_node, ss_info->string_length, + logical_type_node, ss_info->string_length, build_int_cst (gfc_charlen_type_node, 0)); /* Print a warning if bounds checking is enabled. */ if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) @@ -3054,13 +3065,13 @@ trans_array_bound_check (gfc_se * se, gfc_ss *ss, tree index, int n, msg = xasprintf ("Index '%%ld' of dimension %d " "outside of expected range (%%ld:%%ld)", n+1); - fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, + fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node, index, tmp_lo); gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg, fold_convert (long_integer_type_node, index), fold_convert (long_integer_type_node, tmp_lo), fold_convert (long_integer_type_node, tmp_up)); - fault = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, + fault = fold_build2_loc (input_location, GT_EXPR, logical_type_node, index, tmp_up); gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg, fold_convert (long_integer_type_node, index), @@ -3079,7 +3090,7 @@ trans_array_bound_check (gfc_se * se, gfc_ss *ss, tree index, int n, msg = xasprintf ("Index '%%ld' of dimension %d " "below lower bound of %%ld", n+1); - fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, + fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node, index, tmp_lo); gfc_trans_runtime_check (true, false, fault, &se->pre, where, msg, fold_convert (long_integer_type_node, index), @@ -3586,7 +3597,7 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_expr *expr, tmp = tmpse.expr; } - cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, + cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node, indexse.expr, tmp); msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' " "below lower bound of %%ld", n+1, var_name); @@ -3611,7 +3622,7 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_expr *expr, } cond = fold_build2_loc (input_location, GT_EXPR, - boolean_type_node, indexse.expr, tmp); + logical_type_node, indexse.expr, tmp); msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' " "above upper bound of %%ld", n+1, var_name); gfc_trans_runtime_check (true, false, cond, &se->pre, where, msg, @@ -3879,7 +3890,7 @@ gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n, OMP_FOR_INIT (stmt) = init; /* The exit condition. */ TREE_VEC_ELT (cond, 0) = build2_loc (input_location, LE_EXPR, - boolean_type_node, + logical_type_node, loop->loopvar[n], loop->to[n]); SET_EXPR_LOCATION (TREE_VEC_ELT (cond, 0), input_location); OMP_FOR_COND (stmt) = cond; @@ -3914,7 +3925,7 @@ gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n, /* The exit condition. */ cond = fold_build2_loc (input_location, reverse_loop ? LT_EXPR : GT_EXPR, - boolean_type_node, loop->loopvar[n], loop->to[n]); + logical_type_node, loop->loopvar[n], loop->to[n]); tmp = build1_v (GOTO_EXPR, exit_label); TREE_USED (exit_label) = 1; tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location)); @@ -4346,7 +4357,7 @@ done: check_upper = true; /* Zero stride is not allowed. */ - tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, + tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, info->stride[dim], gfc_index_zero_node); msg = xasprintf ("Zero stride is not allowed, for dimension %d " "of array '%s'", dim + 1, expr_name); @@ -4369,23 +4380,23 @@ done: /* non_zerosized is true when the selected range is not empty. */ stride_pos = fold_build2_loc (input_location, GT_EXPR, - boolean_type_node, info->stride[dim], + logical_type_node, info->stride[dim], gfc_index_zero_node); - tmp = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, + tmp = fold_build2_loc (input_location, LE_EXPR, logical_type_node, info->start[dim], end); stride_pos = fold_build2_loc (input_location, TRUTH_AND_EXPR, - boolean_type_node, stride_pos, tmp); + logical_type_node, stride_pos, tmp); stride_neg = fold_build2_loc (input_location, LT_EXPR, - boolean_type_node, + logical_type_node, info->stride[dim], gfc_index_zero_node); - tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, + tmp = fold_build2_loc (input_location, GE_EXPR, logical_type_node, info->start[dim], end); stride_neg = fold_build2_loc (input_location, TRUTH_AND_EXPR, - boolean_type_node, + logical_type_node, stride_neg, tmp); non_zerosized = fold_build2_loc (input_location, TRUTH_OR_EXPR, - boolean_type_node, + logical_type_node, stride_pos, stride_neg); /* Check the start of the range against the lower and upper @@ -4395,16 +4406,16 @@ done: if (check_upper) { tmp = fold_build2_loc (input_location, LT_EXPR, - boolean_type_node, + logical_type_node, info->start[dim], lbound); tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, - boolean_type_node, + logical_type_node, non_zerosized, tmp); tmp2 = fold_build2_loc (input_location, GT_EXPR, - boolean_type_node, + logical_type_node, info->start[dim], ubound); tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR, - boolean_type_node, + logical_type_node, non_zerosized, tmp2); msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' " "outside of expected range (%%ld:%%ld)", @@ -4424,10 +4435,10 @@ done: else { tmp = fold_build2_loc (input_location, LT_EXPR, - boolean_type_node, + logical_type_node, info->start[dim], lbound); tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, - boolean_type_node, non_zerosized, tmp); + logical_type_node, non_zerosized, tmp); msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' " "below lower bound of %%ld", dim + 1, expr_name); @@ -4451,15 +4462,15 @@ done: tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, end, tmp); tmp2 = fold_build2_loc (input_location, LT_EXPR, - boolean_type_node, tmp, lbound); + logical_type_node, tmp, lbound); tmp2 = fold_build2_loc (input_location, TRUTH_AND_EXPR, - boolean_type_node, non_zerosized, tmp2); + logical_type_node, non_zerosized, tmp2); if (check_upper) { tmp3 = fold_build2_loc (input_location, GT_EXPR, - boolean_type_node, tmp, ubound); + logical_type_node, tmp, ubound); tmp3 = fold_build2_loc (input_location, TRUTH_AND_EXPR, - boolean_type_node, non_zerosized, tmp3); + logical_type_node, non_zerosized, tmp3); msg = xasprintf ("Index '%%ld' of dimension %d of array '%s' " "outside of expected range (%%ld:%%ld)", dim + 1, expr_name); @@ -4505,7 +4516,7 @@ done: if (size[n]) { tmp3 = fold_build2_loc (input_location, NE_EXPR, - boolean_type_node, tmp, size[n]); + logical_type_node, tmp, size[n]); msg = xasprintf ("Array bound mismatch for dimension %d " "of array '%s' (%%ld/%%ld)", dim + 1, expr_name); @@ -5192,7 +5203,7 @@ gfc_conv_array_extent_dim (tree lbound, tree ubound, tree* or_expr) gfc_index_one_node); /* Check whether the size for this dimension is negative. */ - cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, res, + cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node, res, gfc_index_zero_node); res = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type, cond, gfc_index_zero_node, res); @@ -5200,7 +5211,7 @@ gfc_conv_array_extent_dim (tree lbound, tree ubound, tree* or_expr) /* Build OR expression. */ if (or_expr) *or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR, - boolean_type_node, *or_expr, cond); + logical_type_node, *or_expr, cond); return res; } @@ -5329,7 +5340,7 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset, gfc_add_modify (pblock, tmp, gfc_get_dtype (type)); } - or_expr = boolean_false_node; + or_expr = logical_false_node; for (n = 0; n < rank; n++) { @@ -5437,12 +5448,12 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset, TYPE_MAX_VALUE (gfc_array_index_type)), size); cond = gfc_unlikely (fold_build2_loc (input_location, LT_EXPR, - boolean_type_node, tmp, stride), + logical_type_node, tmp, stride), PRED_FORTRAN_OVERFLOW); tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond, integer_one_node, integer_zero_node); cond = gfc_unlikely (fold_build2_loc (input_location, EQ_EXPR, - boolean_type_node, size, + logical_type_node, size, gfc_index_zero_node), PRED_FORTRAN_SIZE_ZERO); tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond, @@ -5538,12 +5549,12 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset, size_type_node, TYPE_MAX_VALUE (size_type_node), element_size); cond = gfc_unlikely (fold_build2_loc (input_location, LT_EXPR, - boolean_type_node, tmp, stride), + logical_type_node, tmp, stride), PRED_FORTRAN_OVERFLOW); tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond, integer_one_node, integer_zero_node); cond = gfc_unlikely (fold_build2_loc (input_location, EQ_EXPR, - boolean_type_node, element_size, + logical_type_node, element_size, build_int_cst (size_type_node, 0)), PRED_FORTRAN_SIZE_ZERO); tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, cond, @@ -5801,7 +5812,7 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg, if (dimension) { cond = gfc_unlikely (fold_build2_loc (input_location, NE_EXPR, - boolean_type_node, var_overflow, integer_zero_node), + logical_type_node, var_overflow, integer_zero_node), PRED_FORTRAN_OVERFLOW); tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, error, gfc_finish_block (&elseblock)); @@ -5832,7 +5843,7 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg, if (status != NULL_TREE) { cond = fold_build2_loc (input_location, EQ_EXPR, - boolean_type_node, status, + logical_type_node, status, build_int_cst (TREE_TYPE (status), 0)); gfc_add_expr_to_block (&se->pre, fold_build3_loc (input_location, COND_EXPR, void_type_node, @@ -6082,7 +6093,7 @@ gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset, /* Make sure that negative size arrays are translated to being zero size. */ - tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, + tmp = fold_build2_loc (input_location, GE_EXPR, logical_type_node, stride, gfc_index_zero_node); tmp = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type, tmp, @@ -6369,10 +6380,10 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, /* For non-constant shape arrays we only check if the first dimension is contiguous. Repacking higher dimensions wouldn't gain us anything as we still don't know the array stride. */ - partial = gfc_create_var (boolean_type_node, "partial"); + partial = gfc_create_var (logical_type_node, "partial"); TREE_USED (partial) = 1; tmp = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]); - tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, tmp, + tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, tmp, gfc_index_one_node); gfc_add_modify (&init, partial, tmp); } @@ -6387,7 +6398,7 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, stride = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]); stride = gfc_evaluate_now (stride, &init); - tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, + tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, stride, gfc_index_zero_node); tmp = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type, tmp, gfc_index_one_node, stride); @@ -6628,7 +6639,7 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, else tmp = build_fold_indirect_ref_loc (input_location, dumdesc); tmp = gfc_conv_descriptor_data_get (tmp); - tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp, tmpdesc); stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup, build_empty_stmt (input_location)); @@ -7911,12 +7922,12 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77, tmp = build_fold_indirect_ref_loc (input_location, desc); tmp = gfc_conv_array_data (tmp); - tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, fold_convert (TREE_TYPE (tmp), ptr), tmp); if (fsym && fsym->attr.optional && sym && sym->attr.optional) tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, - boolean_type_node, + logical_type_node, gfc_conv_expr_present (sym), tmp); gfc_trans_runtime_check (false, true, tmp, &se->pre, @@ -7946,12 +7957,12 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77, tmp = build_fold_indirect_ref_loc (input_location, desc); tmp = gfc_conv_array_data (tmp); - tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, fold_convert (TREE_TYPE (tmp), ptr), tmp); if (fsym && fsym->attr.optional && sym && sym->attr.optional) tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, - boolean_type_node, + logical_type_node, gfc_conv_expr_present (sym), tmp); tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location)); @@ -8090,7 +8101,7 @@ duplicate_allocatable (tree dest, tree src, tree type, int rank, null_cond = gfc_conv_descriptor_data_get (src); null_cond = convert (pvoid_type_node, null_cond); - null_cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + null_cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, null_cond, null_pointer_node); return build3_v (COND_EXPR, null_cond, tmp, null_data); } @@ -8224,7 +8235,7 @@ duplicate_allocatable_coarray (tree dest, tree dest_tok, tree src, null_cond = gfc_conv_descriptor_data_get (src); null_cond = convert (pvoid_type_node, null_cond); - null_cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + null_cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, null_cond, null_pointer_node); gfc_add_expr_to_block (&globalblock, build3_v (COND_EXPR, null_cond, tmp, null_data)); @@ -8339,7 +8350,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, null_cond = gfc_conv_descriptor_data_get (decl); null_cond = fold_build2_loc (input_location, NE_EXPR, - boolean_type_node, null_cond, + logical_type_node, null_cond, build_int_cst (TREE_TYPE (null_cond), 0)); } else @@ -8590,7 +8601,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, dealloc_fndecl); tmp = build_int_cst (TREE_TYPE (comp), 0); is_allocated = fold_build2_loc (input_location, NE_EXPR, - boolean_type_node, tmp, + logical_type_node, tmp, comp); cdesc = gfc_build_addr_expr (NULL_TREE, cdesc); @@ -8870,7 +8881,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, null_data = gfc_finish_block (&tmpblock); null_cond = fold_build2_loc (input_location, NE_EXPR, - boolean_type_node, src_data, + logical_type_node, src_data, null_pointer_node); gfc_add_expr_to_block (&fnblock, build3_v (COND_EXPR, null_cond, @@ -9132,7 +9143,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, { tmp = gfc_conv_descriptor_data_get (comp); null_cond = fold_build2_loc (input_location, NE_EXPR, - boolean_type_node, tmp, + logical_type_node, tmp, build_int_cst (TREE_TYPE (tmp), 0)); tmp = gfc_call_free (tmp); tmp = build3_v (COND_EXPR, null_cond, tmp, @@ -9143,7 +9154,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, else if (c->attr.pdt_string) { null_cond = fold_build2_loc (input_location, NE_EXPR, - boolean_type_node, comp, + logical_type_node, comp, build_int_cst (TREE_TYPE (comp), 0)); tmp = gfc_call_free (comp); tmp = build3_v (COND_EXPR, null_cond, tmp, @@ -9190,7 +9201,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, tree error, cond, cname; gfc_conv_expr_type (&tse, c_expr, TREE_TYPE (comp)); cond = fold_build2_loc (input_location, NE_EXPR, - boolean_type_node, + logical_type_node, comp, tse.expr); cname = gfc_build_cstring_const (c->name); cname = gfc_build_addr_expr (pchar_type_node, cname); @@ -9350,25 +9361,25 @@ get_std_lbound (gfc_expr *expr, tree desc, int dim, bool assumed_size) lbound = gfc_conv_descriptor_lbound_get (desc, tmp); ubound = gfc_conv_descriptor_ubound_get (desc, tmp); stride = gfc_conv_descriptor_stride_get (desc, tmp); - cond1 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, + cond1 = fold_build2_loc (input_location, GE_EXPR, logical_type_node, ubound, lbound); - cond3 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, + cond3 = fold_build2_loc (input_location, GE_EXPR, logical_type_node, stride, gfc_index_zero_node); cond3 = fold_build2_loc (input_location, TRUTH_AND_EXPR, - boolean_type_node, cond3, cond1); - cond4 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, + logical_type_node, cond3, cond1); + cond4 = fold_build2_loc (input_location, LT_EXPR, logical_type_node, stride, gfc_index_zero_node); if (assumed_size) - cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, + cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, tmp, build_int_cst (gfc_array_index_type, expr->rank - 1)); else - cond = boolean_false_node; + cond = logical_false_node; cond1 = fold_build2_loc (input_location, TRUTH_OR_EXPR, - boolean_type_node, cond3, cond4); + logical_type_node, cond3, cond4); cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, - boolean_type_node, cond, cond1); + logical_type_node, cond, cond1); return fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type, cond, @@ -9621,11 +9632,11 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop, jump_label2 = gfc_build_label_decl (NULL_TREE); /* Allocate if data is NULL. */ - cond_null = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, + cond_null = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, array1, build_int_cst (TREE_TYPE (array1), 0)); if (expr1->ts.deferred) - cond_null = gfc_evaluate_now (boolean_true_node, &fblock); + cond_null = gfc_evaluate_now (logical_true_node, &fblock); else cond_null= gfc_evaluate_now (cond_null, &fblock); @@ -9665,7 +9676,7 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop, gfc_array_index_type, tmp, ubound); cond = fold_build2_loc (input_location, NE_EXPR, - boolean_type_node, + logical_type_node, tmp, gfc_index_zero_node); tmp = build3_v (COND_EXPR, cond, build1_v (GOTO_EXPR, jump_label1), @@ -9715,13 +9726,13 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop, } size2 = gfc_evaluate_now (size2, &fblock); - cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, size1, size2); /* If the lhs is deferred length, assume that the element size changes and force a reallocation. */ if (expr1->ts.deferred) - neq_size = gfc_evaluate_now (boolean_true_node, &fblock); + neq_size = gfc_evaluate_now (logical_true_node, &fblock); else neq_size = gfc_evaluate_now (cond, &fblock); @@ -10001,7 +10012,7 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop, /* Malloc if not allocated; realloc otherwise. */ tmp = build_int_cst (TREE_TYPE (array1), 0); cond = fold_build2_loc (input_location, EQ_EXPR, - boolean_type_node, + logical_type_node, array1, tmp); tmp = build3_v (COND_EXPR, cond, alloc_expr, realloc_expr); gfc_add_expr_to_block (&fblock, tmp); diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 45d5119236a..60e7d8f79ee 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -4198,7 +4198,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) break; } /* TODO: move to the appropriate place in resolve.c. */ - if (warn_return_type && el == NULL) + if (warn_return_type > 0 && el == NULL) gfc_warning (OPT_Wreturn_type, "Return value of function %qs at %L not set", proc_sym->name, &proc_sym->declared_at); @@ -5619,7 +5619,7 @@ generate_local_decl (gfc_symbol * sym) else if (sym->attr.flavor == FL_PROCEDURE) { /* TODO: move to the appropriate place in resolve.c. */ - if (warn_return_type + if (warn_return_type > 0 && sym->attr.function && sym->result && sym != sym->result @@ -5784,7 +5784,7 @@ add_argument_checking (stmtblock_t *block, gfc_symbol *sym) /* Build the condition. For optional arguments, an actual length of 0 is also acceptable if the associated string is NULL, which means the argument was not passed. */ - cond = fold_build2_loc (input_location, comparison, boolean_type_node, + cond = fold_build2_loc (input_location, comparison, logical_type_node, cl->passed_length, cl->backend_decl); if (fsym->attr.optional) { @@ -5793,7 +5793,7 @@ add_argument_checking (stmtblock_t *block, gfc_symbol *sym) tree absent_failed; not_0length = fold_build2_loc (input_location, NE_EXPR, - boolean_type_node, + logical_type_node, cl->passed_length, build_zero_cst (gfc_charlen_type_node)); /* The symbol needs to be referenced for gfc_get_symbol_decl. */ @@ -5801,11 +5801,11 @@ add_argument_checking (stmtblock_t *block, gfc_symbol *sym) not_absent = gfc_conv_expr_present (fsym); absent_failed = fold_build2_loc (input_location, TRUTH_OR_EXPR, - boolean_type_node, not_0length, + logical_type_node, not_0length, not_absent); cond = fold_build2_loc (input_location, TRUTH_AND_EXPR, - boolean_type_node, cond, absent_failed); + logical_type_node, cond, absent_failed); } /* Build the runtime check. */ @@ -6376,13 +6376,13 @@ gfc_generate_function_code (gfc_namespace * ns) msg = xasprintf ("Recursive call to nonrecursive procedure '%s'", sym->name); - recurcheckvar = gfc_create_var (boolean_type_node, "is_recursive"); + recurcheckvar = gfc_create_var (logical_type_node, "is_recursive"); TREE_STATIC (recurcheckvar) = 1; - DECL_INITIAL (recurcheckvar) = boolean_false_node; + DECL_INITIAL (recurcheckvar) = logical_false_node; gfc_add_expr_to_block (&init, recurcheckvar); gfc_trans_runtime_check (true, false, recurcheckvar, &init, &sym->declared_at, msg); - gfc_add_modify (&init, recurcheckvar, boolean_true_node); + gfc_add_modify (&init, recurcheckvar, logical_true_node); free (msg); } @@ -6494,11 +6494,11 @@ gfc_generate_function_code (gfc_namespace * ns) if (result == NULL_TREE || artificial_result_decl) { /* TODO: move to the appropriate place in resolve.c. */ - if (warn_return_type && sym == sym->result) + if (warn_return_type > 0 && sym == sym->result) gfc_warning (OPT_Wreturn_type, "Return value of function %qs at %L not set", sym->name, &sym->declared_at); - if (warn_return_type) + if (warn_return_type > 0) TREE_NO_WARNING(sym->backend_decl) = 1; } if (result != NULL_TREE) @@ -6511,7 +6511,7 @@ gfc_generate_function_code (gfc_namespace * ns) if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION) && !is_recursive && !flag_openmp && recurcheckvar != NULL_TREE) { - gfc_add_modify (&cleanup, recurcheckvar, boolean_false_node); + gfc_add_modify (&cleanup, recurcheckvar, logical_false_node); recurcheckvar = NULL; } diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 1a3e3d45e4c..c5e1d72bd04 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -1287,7 +1287,7 @@ gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited) from_len = gfc_conv_descriptor_size (from_data, 1); tmp = fold_build2_loc (input_location, NE_EXPR, - boolean_type_node, from_len, orig_nelems); + logical_type_node, from_len, orig_nelems); msg = xasprintf ("Array bound mismatch for dimension %d " "of array '%s' (%%ld/%%ld)", 1, name); @@ -1338,7 +1338,7 @@ gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited) extcopy = gfc_finish_block (&ifbody); tmp = fold_build2_loc (input_location, GT_EXPR, - boolean_type_node, from_len, + logical_type_node, from_len, integer_zero_node); tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, tmp, extcopy, stdcopy); @@ -1366,7 +1366,7 @@ gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited) vec_safe_push (args, to_len); extcopy = build_call_vec (fcn_type, fcn, args); tmp = fold_build2_loc (input_location, GT_EXPR, - boolean_type_node, from_len, + logical_type_node, from_len, integer_zero_node); tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, tmp, extcopy, stdcopy); @@ -1380,7 +1380,7 @@ gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited) { tree cond; cond = fold_build2_loc (input_location, NE_EXPR, - boolean_type_node, + logical_type_node, from_data, null_pointer_node); tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, @@ -1425,7 +1425,7 @@ gfc_trans_class_array_init_assign (gfc_expr *rhs, gfc_expr *lhs, gfc_expr *obj) gfc_init_se (&src, NULL); gfc_conv_expr (&src, rhs); src.expr = gfc_build_addr_expr (NULL_TREE, src.expr); - tree cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + tree cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, src.expr, fold_convert (TREE_TYPE (src.expr), null_pointer_node)); res = build3_loc (input_location, COND_EXPR, TREE_TYPE (res), cond, res, @@ -1492,7 +1492,7 @@ gfc_trans_class_init_assign (gfc_code *code) { /* Check if _def_init is non-NULL. */ tree cond = fold_build2_loc (input_location, NE_EXPR, - boolean_type_node, src.expr, + logical_type_node, src.expr, fold_convert (TREE_TYPE (src.expr), null_pointer_node)); tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), cond, @@ -1662,7 +1662,7 @@ gfc_conv_expr_present (gfc_symbol * sym) decl = GFC_DECL_SAVED_DESCRIPTOR (decl); } - cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, decl, + cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, decl, fold_convert (TREE_TYPE (decl), null_pointer_node)); /* Fortran 2008 allows to pass null pointers and non-associated pointers @@ -1699,10 +1699,10 @@ gfc_conv_expr_present (gfc_symbol * sym) if (tmp != NULL_TREE) { - tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp, + tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp, fold_convert (TREE_TYPE (tmp), null_pointer_node)); cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR, - boolean_type_node, cond, tmp); + logical_type_node, cond, tmp); } } @@ -2264,15 +2264,15 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind, if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) { tree nonempty = fold_build2_loc (input_location, LE_EXPR, - boolean_type_node, start.expr, + logical_type_node, start.expr, end.expr); /* Check lower bound. */ - fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, + fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node, start.expr, build_int_cst (gfc_charlen_type_node, 1)); fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR, - boolean_type_node, nonempty, fault); + logical_type_node, nonempty, fault); if (name) msg = xasprintf ("Substring out of bounds: lower bound (%%ld) of '%s' " "is less than one", name); @@ -2285,10 +2285,10 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind, free (msg); /* Check upper bound. */ - fault = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, + fault = fold_build2_loc (input_location, GT_EXPR, logical_type_node, end.expr, se->string_length); fault = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR, - boolean_type_node, nonempty, fault); + logical_type_node, nonempty, fault); if (name) msg = xasprintf ("Substring out of bounds: upper bound (%%ld) of '%s' " "exceeds string length (%%ld)", name); @@ -2890,9 +2890,9 @@ gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs) /* If rhs < 0 and lhs is an integer, the result is -1, 0 or 1. */ if ((sgn == -1) && (TREE_CODE (type) == INTEGER_TYPE)) { - tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, + tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, lhs, build_int_cst (TREE_TYPE (lhs), -1)); - cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, + cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, lhs, build_int_cst (TREE_TYPE (lhs), 1)); /* If rhs is even, @@ -2900,7 +2900,7 @@ gfc_conv_cst_int_power (gfc_se * se, tree lhs, tree rhs) if ((n & 1) == 0) { tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR, - boolean_type_node, tmp, cond); + logical_type_node, tmp, cond); se->expr = fold_build3_loc (input_location, COND_EXPR, type, tmp, build_int_cst (type, 1), build_int_cst (type, 0)); @@ -3386,8 +3386,8 @@ gfc_conv_expr_op (gfc_se * se, gfc_expr * expr) if (lop) { - /* The result of logical ops is always boolean_type_node. */ - tmp = fold_build2_loc (input_location, code, boolean_type_node, + /* The result of logical ops is always logical_type_node. */ + tmp = fold_build2_loc (input_location, code, logical_type_node, lse.expr, rse.expr); se->expr = convert (type, tmp); } @@ -4178,9 +4178,7 @@ gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping) if (arg2 && arg2->expr_type == EXPR_CONSTANT) d = mpz_get_si (arg2->value.integer) - 1; else - /* TODO: If the need arises, this could produce an array of - ubound/lbounds. */ - gcc_unreachable (); + return false; if (expr->value.function.isym->id == GFC_ISYM_LBOUND) { @@ -4987,7 +4985,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, tree descriptor_data; descriptor_data = ss->info->data.array.data; - tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, + tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, descriptor_data, fold_convert (TREE_TYPE (descriptor_data), null_pointer_node)); @@ -5151,7 +5149,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, tree cond; tmp = gfc_build_addr_expr (NULL_TREE, parmse.expr); cond = fold_build2_loc (input_location, NE_EXPR, - boolean_type_node, tmp, + logical_type_node, tmp, fold_convert (TREE_TYPE (tmp), null_pointer_node)); gfc_start_block (&block); @@ -5683,16 +5681,16 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, present = gfc_conv_expr_present (e->symtree->n.sym); type = TREE_TYPE (present); present = fold_build2_loc (input_location, EQ_EXPR, - boolean_type_node, present, + logical_type_node, present, fold_convert (type, null_pointer_node)); type = TREE_TYPE (parmse.expr); null_ptr = fold_build2_loc (input_location, EQ_EXPR, - boolean_type_node, parmse.expr, + logical_type_node, parmse.expr, fold_convert (type, null_pointer_node)); cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR, - boolean_type_node, present, null_ptr); + logical_type_node, present, null_ptr); } else { @@ -5719,7 +5717,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, tmp = gfc_build_addr_expr (NULL_TREE, tmp); cond = fold_build2_loc (input_location, EQ_EXPR, - boolean_type_node, tmp, + logical_type_node, tmp, fold_convert (TREE_TYPE (tmp), null_pointer_node)); } @@ -6215,7 +6213,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, happen in a function returning a pointer. */ tmp = gfc_conv_descriptor_data_get (info->descriptor); tmp = fold_build2_loc (input_location, NE_EXPR, - boolean_type_node, + logical_type_node, tmp, info->data); gfc_trans_runtime_check (true, false, tmp, &se->pre, NULL, gfc_msg_fault); @@ -6341,7 +6339,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, final_fndecl = gfc_class_vtab_final_get (se->expr); is_final = fold_build2_loc (input_location, NE_EXPR, - boolean_type_node, + logical_type_node, final_fndecl, fold_convert (TREE_TYPE (final_fndecl), null_pointer_node)); @@ -6415,7 +6413,7 @@ fill_with_spaces (tree start, tree type, tree size) gfc_init_block (&loop); /* Exit condition. */ - cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, i, + cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node, i, build_zero_cst (sizetype)); tmp = build1_v (GOTO_EXPR, exit_label); tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp, @@ -6508,7 +6506,7 @@ gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest, */ /* Do nothing if the destination length is zero. */ - cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, dlen, + cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, dlen, build_int_cst (size_type_node, 0)); /* For non-default character kinds, we have to multiply the string @@ -6544,7 +6542,7 @@ gfc_trans_string_copy (stmtblock_t * block, tree dlength, tree dest, gfc_add_expr_to_block (&tmpblock2, tmp2); /* If the destination is longer, fill the end with spaces. */ - cond2 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, slen, + cond2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node, slen, dlen); /* Wstringop-overflow appears at -O3 even though this warning is not @@ -7129,7 +7127,7 @@ gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm, null_pointer_node); null_expr = gfc_finish_block (&block); tmp = gfc_conv_descriptor_data_get (arg->symtree->n.sym->backend_decl); - tmp = build2_loc (input_location, EQ_EXPR, boolean_type_node, tmp, + tmp = build2_loc (input_location, EQ_EXPR, logical_type_node, tmp, fold_convert (TREE_TYPE (tmp), null_pointer_node)); return build3_v (COND_EXPR, tmp, null_expr, non_null_expr); @@ -8686,7 +8684,7 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2) lsize = gfc_evaluate_now (lsize, &block); rsize = gfc_evaluate_now (rsize, &block); - fault = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, + fault = fold_build2_loc (input_location, LT_EXPR, logical_type_node, rsize, lsize); msg = _("Target of rank remapping is too small (%ld < %ld)"); @@ -8805,7 +8803,7 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts, /* Are the rhs and the lhs the same? */ if (deep_copy) { - cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, + cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, gfc_build_addr_expr (NULL_TREE, lse->expr), gfc_build_addr_expr (NULL_TREE, rse->expr)); cond = gfc_evaluate_now (cond, &lse->pre); @@ -9080,7 +9078,7 @@ fcncall_realloc_result (gfc_se *se, int rank) the lhs descriptor. */ tmp = gfc_conv_descriptor_data_get (desc); zero_cond = fold_build2_loc (input_location, EQ_EXPR, - boolean_type_node, tmp, + logical_type_node, tmp, build_int_cst (TREE_TYPE (tmp), 0)); zero_cond = gfc_evaluate_now (zero_cond, &se->post); tmp = gfc_call_free (tmp); @@ -9104,11 +9102,11 @@ fcncall_realloc_result (gfc_se *se, int rank) tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, tmp, tmp1); tmp = fold_build2_loc (input_location, NE_EXPR, - boolean_type_node, tmp, + logical_type_node, tmp, gfc_index_zero_node); tmp = gfc_evaluate_now (tmp, &se->post); zero_cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, - boolean_type_node, tmp, + logical_type_node, tmp, zero_cond); } @@ -9547,7 +9545,7 @@ alloc_scalar_allocatable_for_assignment (stmtblock_t *block, /* Do the allocation if the lhs is NULL. Otherwise go to label 1. */ tmp = build_int_cst (TREE_TYPE (lse.expr), 0); - cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, lse.expr, tmp); tmp = build3_v (COND_EXPR, cond, build1_v (GOTO_EXPR, jump_label1), @@ -9625,7 +9623,7 @@ alloc_scalar_allocatable_for_assignment (stmtblock_t *block, rhs are different. */ if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred) { - cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, + cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, lse.string_length, size); /* Jump past the realloc if the lengths are the same. */ tmp = build3_v (COND_EXPR, cond, @@ -9771,7 +9769,7 @@ trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs, gfc_init_block (&alloc); gfc_allocate_using_malloc (&alloc, class_han, tmp, NULL_TREE); tmp = fold_build2_loc (input_location, EQ_EXPR, - boolean_type_node, class_han, + logical_type_node, class_han, build_int_cst (prvoid_type_node, 0)); tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, gfc_unlikely (tmp, @@ -9824,7 +9822,7 @@ trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs, extcopy = build_call_vec (TREE_TYPE (TREE_TYPE (fcn)), fcn, args); tmp = fold_build2_loc (input_location, GT_EXPR, - boolean_type_node, from_len, + logical_type_node, from_len, integer_zero_node); return fold_build3_loc (input_location, COND_EXPR, void_type_node, tmp, @@ -10053,7 +10051,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, if (TREE_CODE (lse.expr) == ARRAY_REF) tmp = gfc_build_addr_expr (NULL_TREE, tmp); - cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, + cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, tmp, build_int_cst (TREE_TYPE (tmp), 0)); msg = _("Assignment of scalar to unallocated array"); gfc_trans_runtime_check (true, false, cond, &loop.pre, @@ -10084,12 +10082,16 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, NOTE: This relies on having the exact dependence of the length type parameter available to the caller; gfortran saves it in the .mod files. NOTE ALSO: The concatenation operation generates a temporary pointer, - whose allocation must go to the innermost loop. */ + whose allocation must go to the innermost loop. + NOTE ALSO (2): A character conversion may generate a temporary, too. */ if (flag_realloc_lhs && expr2->ts.type == BT_CHARACTER && expr1->ts.deferred && !(lss != gfc_ss_terminator - && expr2->expr_type == EXPR_OP - && expr2->value.op.op == INTRINSIC_CONCAT)) + && ((expr2->expr_type == EXPR_OP + && expr2->value.op.op == INTRINSIC_CONCAT) + || (expr2->expr_type == EXPR_FUNCTION + && expr2->value.function.isym != NULL + && expr2->value.function.isym->id == GFC_ISYM_CONVERSION)))) gfc_add_block_to_block (&block, &rse.pre); /* Nullify the allocatable components corresponding to those of the lhs diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index 532d3ab237d..ed4496c845d 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -358,7 +358,7 @@ build_fixbound_expr (stmtblock_t * pblock, tree arg, tree type, int up) tmp = convert (argtype, intval); cond = fold_build2_loc (input_location, up ? GE_EXPR : LE_EXPR, - boolean_type_node, tmp, arg); + logical_type_node, tmp, arg); tmp = fold_build2_loc (input_location, up ? PLUS_EXPR : MINUS_EXPR, type, intval, build_int_cst (type, 1)); @@ -490,14 +490,14 @@ gfc_conv_intrinsic_aint (gfc_se * se, gfc_expr * expr, enum rounding_mode op) 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, 0); - cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, arg[0], + cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node, arg[0], tmp); mpfr_neg (huge, huge, GFC_RND_MODE); tmp = gfc_conv_mpfr_to_tree (huge, kind, 0); - tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, arg[0], + tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node, arg[0], tmp); - cond = fold_build2_loc (input_location, TRUTH_AND_EXPR, boolean_type_node, + cond = fold_build2_loc (input_location, TRUTH_AND_EXPR, logical_type_node, cond, tmp); itype = gfc_get_int_type (kind); @@ -885,7 +885,7 @@ gfc_trans_same_strlen_check (const char* intr_name, locus* where, return; /* Compare the two string lengths. */ - cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, a, b); + cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, a, b); /* Output the runtime-check. */ name = gfc_build_cstring_const (intr_name); @@ -1871,12 +1871,21 @@ conv_caf_send (gfc_code *code) { gfc_init_se (&lhs_se, NULL); if (lhs_expr->rank == 0) { - symbol_attribute attr; - gfc_clear_attr (&attr); - gfc_conv_expr (&lhs_se, lhs_expr); - lhs_type = TREE_TYPE (lhs_se.expr); - lhs_se.expr = gfc_conv_scalar_to_descriptor (&lhs_se, lhs_se.expr, attr); - lhs_se.expr = gfc_build_addr_expr (NULL_TREE, lhs_se.expr); + if (lhs_expr->ts.type == BT_CHARACTER && lhs_expr->ts.deferred) + { + lhs_se.expr = gfc_get_tree_for_caf_expr (lhs_expr); + lhs_se.expr = gfc_build_addr_expr (NULL_TREE, lhs_se.expr); + } + else + { + symbol_attribute attr; + gfc_clear_attr (&attr); + gfc_conv_expr (&lhs_se, lhs_expr); + lhs_type = TREE_TYPE (lhs_se.expr); + lhs_se.expr = gfc_conv_scalar_to_descriptor (&lhs_se, lhs_se.expr, + attr); + lhs_se.expr = gfc_build_addr_expr (NULL_TREE, lhs_se.expr); + } } else if ((lhs_caf_attr.alloc_comp || lhs_caf_attr.pointer_comp) && lhs_caf_attr.codimension) @@ -1952,7 +1961,7 @@ conv_caf_send (gfc_code *code) { TYPE_SIZE_UNIT ( gfc_typenode_for_spec (&lhs_expr->ts)), NULL_TREE); - tmp = fold_build2 (EQ_EXPR, boolean_type_node, scal_se.expr, + tmp = fold_build2 (EQ_EXPR, logical_type_node, scal_se.expr, null_pointer_node); tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, tmp, gfc_finish_block (&scal_se.pre), @@ -2245,14 +2254,14 @@ trans_this_image (gfc_se * se, gfc_expr *expr) else if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) { dim_arg = gfc_evaluate_now (dim_arg, &se->pre); - cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, + cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node, dim_arg, build_int_cst (TREE_TYPE (dim_arg), 1)); tmp = gfc_rank_cst[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))]; - tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, + tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node, dim_arg, tmp); cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR, - boolean_type_node, cond, tmp); + logical_type_node, cond, tmp); gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where, gfc_msg_fault); } @@ -2343,7 +2352,7 @@ trans_this_image (gfc_se * se, gfc_expr *expr) m, extent)); /* Exit condition: if (i >= min_var) goto exit_label. */ - cond = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, loop_var, + cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node, loop_var, min_var); tmp = build1_v (GOTO_EXPR, exit_label); tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp, @@ -2368,7 +2377,7 @@ trans_this_image (gfc_se * se, gfc_expr *expr) /* sub(co_dim) = (co_dim < corank) ? ml - m*extent + lcobound(dim_arg) : m + lcobound(corank) */ - cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, dim_arg, + cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node, dim_arg, build_int_cst (TREE_TYPE (dim_arg), corank)); lbound = gfc_conv_descriptor_lbound_get (desc, @@ -2406,7 +2415,7 @@ conv_intrinsic_image_status (gfc_se *se, gfc_expr *expr) { tree arg; arg = gfc_evaluate_now (args[0], &se->pre); - tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, + tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, fold_convert (integer_type_node, arg), integer_one_node); tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node, @@ -2457,7 +2466,7 @@ trans_image_index (gfc_se * se, gfc_expr *expr) lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[rank+corank-1]); tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[corank-1], NULL); - invalid_bound = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, + invalid_bound = fold_build2_loc (input_location, LT_EXPR, logical_type_node, fold_convert (gfc_array_index_type, tmp), lbound); @@ -2466,16 +2475,16 @@ trans_image_index (gfc_se * se, gfc_expr *expr) lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]); ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[codim]); tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[codim-rank], NULL); - cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, + cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node, fold_convert (gfc_array_index_type, tmp), lbound); invalid_bound = fold_build2_loc (input_location, TRUTH_OR_EXPR, - boolean_type_node, invalid_bound, cond); - cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, + logical_type_node, invalid_bound, cond); + cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, fold_convert (gfc_array_index_type, tmp), ubound); invalid_bound = fold_build2_loc (input_location, TRUTH_OR_EXPR, - boolean_type_node, invalid_bound, cond); + logical_type_node, invalid_bound, cond); } invalid_bound = gfc_unlikely (invalid_bound, PRED_FORTRAN_INVALID_BOUND); @@ -2535,11 +2544,11 @@ trans_image_index (gfc_se * se, gfc_expr *expr) tmp = gfc_create_var (type, NULL); gfc_add_modify (&se->pre, tmp, coindex); - cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, tmp, + cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, tmp, num_images); - cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, boolean_type_node, + cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, logical_type_node, cond, - fold_convert (boolean_type_node, invalid_bound)); + fold_convert (logical_type_node, invalid_bound)); se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond, build_int_cst (type, 0), tmp); } @@ -2671,16 +2680,16 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper) if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) { bound = gfc_evaluate_now (bound, &se->pre); - cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, + cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node, bound, build_int_cst (TREE_TYPE (bound), 0)); if (as && as->type == AS_ASSUMED_RANK) tmp = gfc_conv_descriptor_rank (desc); else tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))]; - tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, + tmp = fold_build2_loc (input_location, GE_EXPR, logical_type_node, bound, fold_convert(TREE_TYPE (bound), tmp)); cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR, - boolean_type_node, cond, tmp); + logical_type_node, cond, tmp); gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where, gfc_msg_fault); } @@ -2726,27 +2735,27 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper) { tree stride = gfc_conv_descriptor_stride_get (desc, bound); - cond1 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, + cond1 = fold_build2_loc (input_location, GE_EXPR, logical_type_node, ubound, lbound); - cond3 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, + cond3 = fold_build2_loc (input_location, GE_EXPR, logical_type_node, stride, gfc_index_zero_node); cond3 = fold_build2_loc (input_location, TRUTH_AND_EXPR, - boolean_type_node, cond3, cond1); - cond4 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, + logical_type_node, cond3, cond1); + cond4 = fold_build2_loc (input_location, LT_EXPR, logical_type_node, stride, gfc_index_zero_node); if (upper) { tree cond5; cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, - boolean_type_node, cond3, cond4); - cond5 = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, + logical_type_node, cond3, cond4); + cond5 = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, gfc_index_one_node, lbound); cond5 = fold_build2_loc (input_location, TRUTH_AND_EXPR, - boolean_type_node, cond4, cond5); + logical_type_node, cond4, cond5); cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, - boolean_type_node, cond, cond5); + logical_type_node, cond, cond5); if (assumed_rank_lb_one) { @@ -2765,16 +2774,16 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper) else { if (as->type == AS_ASSUMED_SIZE) - cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, + cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, bound, build_int_cst (TREE_TYPE (bound), arg->expr->rank - 1)); else - cond = boolean_false_node; + cond = logical_false_node; cond1 = fold_build2_loc (input_location, TRUTH_OR_EXPR, - boolean_type_node, cond3, cond4); + logical_type_node, cond3, cond4); cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, - boolean_type_node, cond, cond1); + logical_type_node, cond, cond1); se->expr = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type, cond, @@ -2865,13 +2874,13 @@ conv_intrinsic_cobound (gfc_se * se, gfc_expr * expr) else if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) { bound = gfc_evaluate_now (bound, &se->pre); - cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, + cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node, bound, build_int_cst (TREE_TYPE (bound), 1)); tmp = gfc_rank_cst[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))]; - tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, + tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node, bound, tmp); cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR, - boolean_type_node, cond, tmp); + logical_type_node, cond, tmp); gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where, gfc_msg_fault); } @@ -2940,7 +2949,7 @@ conv_intrinsic_cobound (gfc_se * se, gfc_expr * expr) if (corank > 1) { - cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, + cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, bound, build_int_cst (TREE_TYPE (bound), arg->expr->rank + corank - 1)); @@ -3129,16 +3138,16 @@ gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo) tmp = gfc_evaluate_now (se->expr, &se->pre); if (!flag_signed_zeros) { - test = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, + test = fold_build2_loc (input_location, LT_EXPR, logical_type_node, args[0], zero); - test2 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, + test2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node, args[1], zero); test2 = fold_build2_loc (input_location, TRUTH_XOR_EXPR, - boolean_type_node, test, test2); - test = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + logical_type_node, test, test2); + test = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp, zero); test = fold_build2_loc (input_location, TRUTH_AND_EXPR, - boolean_type_node, test, test2); + logical_type_node, test, test2); test = gfc_evaluate_now (test, &se->pre); se->expr = fold_build3_loc (input_location, COND_EXPR, type, test, fold_build2_loc (input_location, @@ -3151,18 +3160,18 @@ gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo) tree expr1, copysign, cscall; copysign = gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN, expr->ts.kind); - test = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, + test = fold_build2_loc (input_location, LT_EXPR, logical_type_node, args[0], zero); - test2 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, + test2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node, args[1], zero); test2 = fold_build2_loc (input_location, TRUTH_XOR_EXPR, - boolean_type_node, test, test2); + logical_type_node, test, test2); expr1 = fold_build3_loc (input_location, COND_EXPR, type, test2, fold_build2_loc (input_location, PLUS_EXPR, type, tmp, args[1]), tmp); - test = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + test = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp, zero); cscall = build_call_expr_loc (input_location, copysign, 2, zero, args[1]); @@ -3218,12 +3227,12 @@ gfc_conv_intrinsic_dshift (gfc_se * se, gfc_expr * expr, bool dshiftl) res = fold_build2_loc (input_location, BIT_IOR_EXPR, type, left, right); /* Special cases. */ - cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, shift, + cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, shift, build_int_cst (stype, 0)); res = fold_build3_loc (input_location, COND_EXPR, type, cond, dshiftl ? arg1 : arg2, res); - cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, shift, + cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, shift, build_int_cst (stype, bitsize)); res = fold_build3_loc (input_location, COND_EXPR, type, cond, dshiftl ? arg2 : arg1, res); @@ -3250,7 +3259,7 @@ gfc_conv_intrinsic_dim (gfc_se * se, gfc_expr * expr) val = gfc_evaluate_now (val, &se->pre); zero = gfc_build_const (type, integer_zero_node); - tmp = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, val, zero); + tmp = fold_build2_loc (input_location, LE_EXPR, logical_type_node, val, zero); se->expr = fold_build3_loc (input_location, COND_EXPR, type, tmp, zero, val); } @@ -3283,7 +3292,7 @@ gfc_conv_intrinsic_sign (gfc_se * se, gfc_expr * expr) { tree cond, zero; zero = build_real_from_int_cst (TREE_TYPE (args[1]), integer_zero_node); - cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, + cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, args[1], zero); se->expr = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (args[0]), cond, @@ -3404,7 +3413,7 @@ gfc_conv_intrinsic_ctime (gfc_se * se, gfc_expr * expr) gfc_add_expr_to_block (&se->pre, tmp); /* Free the temporary afterwards, if necessary. */ - cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, + cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, len, build_int_cst (TREE_TYPE (len), 0)); tmp = gfc_call_free (var); tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location)); @@ -3443,7 +3452,7 @@ gfc_conv_intrinsic_fdate (gfc_se * se, gfc_expr * expr) gfc_add_expr_to_block (&se->pre, tmp); /* Free the temporary afterwards, if necessary. */ - cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, + cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, len, build_int_cst (TREE_TYPE (len), 0)); tmp = gfc_call_free (var); tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location)); @@ -3653,7 +3662,7 @@ gfc_conv_intrinsic_ttynam (gfc_se * se, gfc_expr * expr) gfc_add_expr_to_block (&se->pre, tmp); /* Free the temporary afterwards, if necessary. */ - cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, + cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, len, build_int_cst (TREE_TYPE (len), 0)); tmp = gfc_call_free (var); tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location)); @@ -3717,7 +3726,7 @@ gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, enum tree_code op) && argexpr->expr->symtree->n.sym->attr.optional && TREE_CODE (val) == INDIRECT_REF) cond = fold_build2_loc (input_location, - NE_EXPR, boolean_type_node, + NE_EXPR, logical_type_node, TREE_OPERAND (val, 0), build_int_cst (TREE_TYPE (TREE_OPERAND (val, 0)), 0)); else @@ -3731,7 +3740,7 @@ gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, enum tree_code op) thencase = build2_v (MODIFY_EXPR, mvar, convert (type, val)); - tmp = fold_build2_loc (input_location, op, boolean_type_node, + tmp = fold_build2_loc (input_location, op, logical_type_node, convert (type, val), mvar); /* FIXME: When the IEEE_ARITHMETIC module is implemented, the call to @@ -3743,8 +3752,8 @@ gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, enum tree_code op) builtin_decl_explicit (BUILT_IN_ISNAN), 1, mvar); tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR, - boolean_type_node, tmp, - fold_convert (boolean_type_node, isnan)); + logical_type_node, tmp, + fold_convert (logical_type_node, isnan)); } tmp = build3_v (COND_EXPR, tmp, thencase, build_empty_stmt (input_location)); @@ -3796,7 +3805,7 @@ gfc_conv_intrinsic_minmax_char (gfc_se * se, gfc_expr * expr, int op) gfc_add_expr_to_block (&se->pre, tmp); /* Free the temporary afterwards, if necessary. */ - cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, + cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, len, build_int_cst (TREE_TYPE (len), 0)); tmp = gfc_call_free (var); tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location)); @@ -3996,7 +4005,7 @@ gfc_conv_intrinsic_anyall (gfc_se * se, gfc_expr * expr, enum tree_code op) gfc_conv_expr_val (&arrayse, actual->expr); gfc_add_block_to_block (&body, &arrayse.pre); - tmp = fold_build2_loc (input_location, op, boolean_type_node, arrayse.expr, + tmp = fold_build2_loc (input_location, op, logical_type_node, arrayse.expr, build_int_cst (TREE_TYPE (arrayse.expr), 0)); tmp = build3_v (COND_EXPR, tmp, found, build_empty_stmt (input_location)); gfc_add_expr_to_block (&body, tmp); @@ -4275,13 +4284,13 @@ gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, enum tree_code op, gfc_add_modify (&ifblock3, resvar, res2); res2 = gfc_finish_block (&ifblock3); - cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, + cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, absX, scale); tmp = build3_v (COND_EXPR, cond, res1, res2); gfc_add_expr_to_block (&ifblock1, tmp); tmp = gfc_finish_block (&ifblock1); - cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, arrayse.expr, gfc_build_const (type, integer_zero_node)); @@ -4587,7 +4596,7 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) nonempty = gfc_conv_mpz_to_tree (asize, gfc_index_integer_kind); mpz_clear (asize); nonempty = fold_build2_loc (input_location, GT_EXPR, - boolean_type_node, nonempty, + logical_type_node, nonempty, gfc_index_zero_node); } maskss = NULL; @@ -4651,7 +4660,7 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) gcc_assert (loop.dimen == 1); if (nonempty == NULL && maskss == NULL && loop.from[0] && loop.to[0]) - nonempty = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, + nonempty = fold_build2_loc (input_location, LE_EXPR, logical_type_node, loop.from[0], loop.to[0]); lab1 = NULL; @@ -4727,7 +4736,7 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) loop.loopvar[0], offset); gfc_add_modify (&ifblock2, pos, tmp); ifbody2 = gfc_finish_block (&ifblock2); - cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, pos, + cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, pos, gfc_index_zero_node); tmp = build3_v (COND_EXPR, cond, ifbody2, build_empty_stmt (input_location)); @@ -4748,9 +4757,9 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) if (lab1) cond = fold_build2_loc (input_location, op == GT_EXPR ? GE_EXPR : LE_EXPR, - boolean_type_node, arrayse.expr, limit); + logical_type_node, arrayse.expr, limit); else - cond = fold_build2_loc (input_location, op, boolean_type_node, + cond = fold_build2_loc (input_location, op, logical_type_node, arrayse.expr, limit); ifbody = build3_v (COND_EXPR, cond, ifbody, @@ -4821,7 +4830,7 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op) ifbody = gfc_finish_block (&ifblock); - cond = fold_build2_loc (input_location, op, boolean_type_node, + cond = fold_build2_loc (input_location, op, logical_type_node, arrayse.expr, limit); tmp = build3_v (COND_EXPR, cond, ifbody, @@ -5073,7 +5082,7 @@ gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op) nonempty = gfc_conv_mpz_to_tree (asize, gfc_index_integer_kind); mpz_clear (asize); nonempty = fold_build2_loc (input_location, GT_EXPR, - boolean_type_node, nonempty, + logical_type_node, nonempty, gfc_index_zero_node); } maskss = NULL; @@ -5107,15 +5116,15 @@ gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op) if (nonempty == NULL && maskss == NULL && loop.dimen == 1 && loop.from[0] && loop.to[0]) - nonempty = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, + nonempty = fold_build2_loc (input_location, LE_EXPR, logical_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_var = gfc_create_var (logical_type_node, "nonempty"); + gfc_add_modify (&se->pre, nonempty_var, logical_false_node); nonempty = nonempty_var; } lab = NULL; @@ -5129,8 +5138,8 @@ gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op) } else { - fast = gfc_create_var (boolean_type_node, "fast"); - gfc_add_modify (&se->pre, fast, boolean_false_node); + fast = gfc_create_var (logical_type_node, "fast"); + gfc_add_modify (&se->pre, fast, logical_false_node); } } @@ -5164,12 +5173,12 @@ gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op) gfc_init_block (&block2); if (nonempty_var) - gfc_add_modify (&block2, nonempty_var, boolean_true_node); + gfc_add_modify (&block2, nonempty_var, logical_true_node); if (HONOR_NANS (DECL_MODE (limit))) { tmp = fold_build2_loc (input_location, op == GT_EXPR ? GE_EXPR : LE_EXPR, - boolean_type_node, arrayse.expr, limit); + logical_type_node, arrayse.expr, limit); if (lab) ifbody = build1_v (GOTO_EXPR, lab); else @@ -5178,7 +5187,7 @@ gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op) gfc_init_block (&ifblock); gfc_add_modify (&ifblock, limit, arrayse.expr); - gfc_add_modify (&ifblock, fast, boolean_true_node); + gfc_add_modify (&ifblock, fast, logical_true_node); ifbody = gfc_finish_block (&ifblock); } tmp = build3_v (COND_EXPR, tmp, ifbody, @@ -5191,7 +5200,7 @@ gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op) signed zeros. */ if (HONOR_SIGNED_ZEROS (DECL_MODE (limit))) { - tmp = fold_build2_loc (input_location, op, boolean_type_node, + tmp = fold_build2_loc (input_location, op, logical_type_node, arrayse.expr, limit); ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr); tmp = build3_v (COND_EXPR, tmp, ifbody, @@ -5216,7 +5225,7 @@ gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op) if (HONOR_NANS (DECL_MODE (limit)) || HONOR_SIGNED_ZEROS (DECL_MODE (limit))) { - tmp = fold_build2_loc (input_location, op, boolean_type_node, + tmp = fold_build2_loc (input_location, op, logical_type_node, arrayse.expr, limit); ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr); ifbody = build3_v (COND_EXPR, tmp, ifbody, @@ -5279,7 +5288,7 @@ gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op) if (HONOR_NANS (DECL_MODE (limit)) || HONOR_SIGNED_ZEROS (DECL_MODE (limit))) { - tmp = fold_build2_loc (input_location, op, boolean_type_node, + tmp = fold_build2_loc (input_location, op, logical_type_node, arrayse.expr, limit); ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr); tmp = build3_v (COND_EXPR, tmp, ifbody, @@ -5369,7 +5378,7 @@ gfc_conv_intrinsic_btest (gfc_se * se, gfc_expr * expr) tmp = fold_build2_loc (input_location, LSHIFT_EXPR, type, build_int_cst (type, 1), args[1]); tmp = fold_build2_loc (input_location, BIT_AND_EXPR, type, args[0], tmp); - tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp, + tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp, build_int_cst (type, 0)); type = gfc_typenode_for_spec (&expr->ts); se->expr = convert (type, tmp); @@ -5397,7 +5406,7 @@ gfc_conv_intrinsic_bitcomp (gfc_se * se, gfc_expr * expr, enum tree_code op) args[0] = fold_convert (TREE_TYPE (args[1]), args[0]); /* Now, we compare them. */ - se->expr = fold_build2_loc (input_location, op, boolean_type_node, + se->expr = fold_build2_loc (input_location, op, logical_type_node, args[0], args[1]); } @@ -5498,7 +5507,7 @@ gfc_conv_intrinsic_shift (gfc_se * se, gfc_expr * expr, bool right_shift, gcc requires a shift width < BIT_SIZE(I), so we have to catch this special case. */ num_bits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type)); - cond = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, + cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node, args[1], num_bits); se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond, @@ -5544,7 +5553,7 @@ gfc_conv_intrinsic_ishft (gfc_se * se, gfc_expr * expr) rshift = fold_convert (type, fold_build2_loc (input_location, RSHIFT_EXPR, utype, convert (utype, args[0]), width)); - tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, args[1], + tmp = fold_build2_loc (input_location, GE_EXPR, logical_type_node, args[1], build_int_cst (TREE_TYPE (args[1]), 0)); tmp = fold_build3_loc (input_location, COND_EXPR, type, tmp, lshift, rshift); @@ -5552,7 +5561,7 @@ gfc_conv_intrinsic_ishft (gfc_se * se, gfc_expr * expr) gcc requires a shift width < BIT_SIZE(I), so we have to catch this special case. */ num_bits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type)); - cond = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, width, + cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node, width, num_bits); se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond, build_int_cst (type, 0), tmp); @@ -5636,12 +5645,12 @@ gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr) rrot = fold_build2_loc (input_location,RROTATE_EXPR, type, args[0], tmp); zero = build_int_cst (TREE_TYPE (args[1]), 0); - tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, args[1], + tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node, args[1], zero); rrot = fold_build3_loc (input_location, COND_EXPR, type, tmp, lrot, rrot); /* Do nothing if shift == 0. */ - tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, args[1], + tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, args[1], zero); se->expr = fold_build3_loc (input_location, COND_EXPR, type, tmp, args[0], rrot); @@ -5739,7 +5748,7 @@ gfc_conv_intrinsic_leadz (gfc_se * se, gfc_expr * expr) fold_convert (arg_type, ullmax), ullsize); cond = fold_build2_loc (input_location, BIT_AND_EXPR, arg_type, arg, cond); - cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, cond, build_int_cst (arg_type, 0)); tmp1 = fold_build2_loc (input_location, RSHIFT_EXPR, arg_type, @@ -5763,7 +5772,7 @@ gfc_conv_intrinsic_leadz (gfc_se * se, gfc_expr * expr) /* Build BIT_SIZE. */ bit_size = build_int_cst (result_type, argsize); - cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, + cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, arg, build_int_cst (arg_type, 0)); se->expr = fold_build3_loc (input_location, COND_EXPR, result_type, cond, bit_size, leadz); @@ -5848,7 +5857,7 @@ gfc_conv_intrinsic_trailz (gfc_se * se, gfc_expr *expr) cond = fold_build2_loc (input_location, BIT_AND_EXPR, arg_type, arg, fold_convert (arg_type, ullmax)); - cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, cond, + cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, cond, build_int_cst (arg_type, 0)); tmp1 = fold_build2_loc (input_location, RSHIFT_EXPR, arg_type, @@ -5872,7 +5881,7 @@ gfc_conv_intrinsic_trailz (gfc_se * se, gfc_expr *expr) /* Build BIT_SIZE. */ bit_size = build_int_cst (result_type, argsize); - cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, + cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, arg, build_int_cst (arg_type, 0)); se->expr = fold_build3_loc (input_location, COND_EXPR, result_type, cond, bit_size, trailz); @@ -6305,7 +6314,7 @@ gfc_conv_intrinsic_mask (gfc_se * se, gfc_expr * expr, int left) /* Special case arg == 0, because SHIFT_EXPR wants a shift strictly smaller than type width. */ - cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, arg, + cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, arg, build_int_cst (TREE_TYPE (arg), 0)); res = fold_build3_loc (input_location, COND_EXPR, utype, cond, build_int_cst (utype, 0), res); @@ -6319,7 +6328,7 @@ gfc_conv_intrinsic_mask (gfc_se * se, gfc_expr * expr, int left) /* Special case agr == bit_size, because SHIFT_EXPR wants a shift strictly smaller than type width. */ - cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, + cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, arg, bitsize); res = fold_build3_loc (input_location, COND_EXPR, utype, cond, allones, res); @@ -6440,7 +6449,7 @@ gfc_conv_intrinsic_spacing (gfc_se * se, gfc_expr * expr) gfc_add_modify (&block, res, tmp); /* Finish by building the IF statement for value zero. */ - cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, arg, + cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, arg, build_real_from_int_cst (type, integer_zero_node)); tmp = build3_v (COND_EXPR, cond, build2_v (MODIFY_EXPR, res, tiny), gfc_finish_block (&block)); @@ -6511,7 +6520,7 @@ gfc_conv_intrinsic_rrspacing (gfc_se * se, gfc_expr * expr) stmt = gfc_finish_block (&block); /* if (x != 0) */ - cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, x, + cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, x, build_real_from_int_cst (type, integer_zero_node)); tmp = build3_v (COND_EXPR, cond, stmt, build_empty_stmt (input_location)); @@ -6641,7 +6650,7 @@ gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr) argse.data_not_needed = 1; gfc_conv_expr (&argse, actual->expr); gfc_add_block_to_block (&se->pre, &argse.pre); - tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, argse.expr, null_pointer_node); tmp = gfc_evaluate_now (tmp, &se->pre); se->expr = fold_build3_loc (input_location, COND_EXPR, @@ -6810,7 +6819,7 @@ gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr) } exit: */ gfc_start_block (&body); - cond = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, + cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node, loop_var, tmp); tmp = build1_v (GOTO_EXPR, exit_label); tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, @@ -7081,7 +7090,7 @@ gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr) /* Clean up if it was repacked. */ gfc_init_block (&block); tmp = gfc_conv_array_data (argse.expr); - tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, source, tmp); tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location)); @@ -7306,14 +7315,14 @@ scalar_transfer: indirect = gfc_finish_block (&block); /* Wrap it up with the condition. */ - tmp = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, + tmp = fold_build2_loc (input_location, LE_EXPR, logical_type_node, dest_word_len, source_bytes); tmp = build3_v (COND_EXPR, tmp, direct, indirect); gfc_add_expr_to_block (&se->pre, tmp); /* Free the temporary string, if necessary. */ free = gfc_call_free (tmpdecl); - tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, + tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node, dest_word_len, source_bytes); tmp = build3_v (COND_EXPR, tmp, free, build_empty_stmt (input_location)); gfc_add_expr_to_block (&se->post, tmp); @@ -7455,7 +7464,7 @@ gfc_conv_allocated (gfc_se *se, gfc_expr *expr) tmp = gfc_conv_descriptor_data_get (arg1se.expr); } - tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp, + tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp, fold_convert (TREE_TYPE (tmp), null_pointer_node)); } se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp); @@ -7523,7 +7532,7 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr) } gfc_add_block_to_block (&se->pre, &arg1se.pre); gfc_add_block_to_block (&se->post, &arg1se.post); - tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp2, + tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp2, fold_convert (TREE_TYPE (tmp2), null_pointer_node)); se->expr = tmp; } @@ -7536,7 +7545,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_loc (input_location, NE_EXPR, - boolean_type_node, + logical_type_node, arg1->expr->ts.u.cl->backend_decl, integer_zero_node); if (scalar) @@ -7561,12 +7570,12 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr) gfc_add_block_to_block (&se->post, &arg1se.post); gfc_add_block_to_block (&se->pre, &arg2se.pre); gfc_add_block_to_block (&se->post, &arg2se.post); - tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, + tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, arg1se.expr, arg2se.expr); - tmp2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + tmp2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node, arg1se.expr, null_pointer_node); se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR, - boolean_type_node, tmp, tmp2); + logical_type_node, tmp, tmp2); } else { @@ -7584,7 +7593,7 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr) tmp = gfc_rank_cst[arg1->expr->rank - 1]; tmp = gfc_conv_descriptor_stride_get (arg1se.expr, tmp); nonzero_arraylen = fold_build2_loc (input_location, NE_EXPR, - boolean_type_node, tmp, + logical_type_node, tmp, build_int_cst (TREE_TYPE (tmp), 0)); /* A pointer to an array, call library function _gfor_associated. */ @@ -7598,9 +7607,9 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr) 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 = convert (logical_type_node, se->expr); se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR, - boolean_type_node, se->expr, + logical_type_node, se->expr, nonzero_arraylen); } @@ -7608,7 +7617,7 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr) be associated. */ if (nonzero_charlen != NULL_TREE) se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR, - boolean_type_node, + logical_type_node, se->expr, nonzero_charlen); } @@ -7636,14 +7645,14 @@ gfc_conv_same_type_as (gfc_se *se, gfc_expr *expr) if (UNLIMITED_POLY (a)) { tmp = gfc_class_vptr_get (a->symtree->n.sym->backend_decl); - conda = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + conda = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp, build_int_cst (TREE_TYPE (tmp), 0)); } if (UNLIMITED_POLY (b)) { tmp = gfc_class_vptr_get (b->symtree->n.sym->backend_decl); - condb = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + condb = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp, build_int_cst (TREE_TYPE (tmp), 0)); } @@ -7669,16 +7678,16 @@ gfc_conv_same_type_as (gfc_se *se, gfc_expr *expr) gfc_conv_expr (&se2, b); tmp = fold_build2_loc (input_location, EQ_EXPR, - boolean_type_node, se1.expr, + logical_type_node, se1.expr, fold_convert (TREE_TYPE (se1.expr), se2.expr)); if (conda) tmp = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR, - boolean_type_node, conda, tmp); + logical_type_node, conda, tmp); if (condb) tmp = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR, - boolean_type_node, condb, tmp); + logical_type_node, condb, tmp); se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp); } @@ -7804,7 +7813,7 @@ gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr) gfc_add_expr_to_block (&se->pre, tmp); /* Free the temporary afterwards, if necessary. */ - cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, + cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, len, build_int_cst (TREE_TYPE (len), 0)); tmp = gfc_call_free (var); tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location)); @@ -7838,7 +7847,7 @@ gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr) ncopies_type = TREE_TYPE (ncopies); /* Check that NCOPIES is not negative. */ - cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, ncopies, + cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node, ncopies, build_int_cst (ncopies_type, 0)); gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where, "Argument NCOPIES of REPEAT intrinsic is negative " @@ -7848,7 +7857,7 @@ gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr) /* If the source length is zero, any non negative value of NCOPIES is valid, and nothing happens. */ n = gfc_create_var (ncopies_type, "ncopies"); - cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, slen, + cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, slen, build_int_cst (size_type_node, 0)); tmp = fold_build3_loc (input_location, COND_EXPR, ncopies_type, cond, build_int_cst (ncopies_type, 0), ncopies); @@ -7865,13 +7874,13 @@ gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr) fold_convert (size_type_node, max), slen); largest = TYPE_PRECISION (size_type_node) > TYPE_PRECISION (ncopies_type) ? size_type_node : ncopies_type; - cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, + cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, fold_convert (largest, ncopies), fold_convert (largest, max)); - tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, slen, + tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, slen, build_int_cst (size_type_node, 0)); - cond = fold_build3_loc (input_location, COND_EXPR, boolean_type_node, tmp, - boolean_false_node, cond); + cond = fold_build3_loc (input_location, COND_EXPR, logical_type_node, tmp, + logical_false_node, cond); gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where, "Argument NCOPIES of REPEAT intrinsic is too large"); @@ -7894,7 +7903,7 @@ gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr) gfc_start_block (&body); /* Exit the loop if count >= ncopies. */ - cond = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, count, + cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node, count, ncopies); tmp = build1_v (GOTO_EXPR, exit_label); TREE_USED (exit_label) = 1; @@ -8043,7 +8052,7 @@ conv_isocbinding_function (gfc_se *se, gfc_expr *expr) if (arg->next->expr == NULL) /* Only given one arg so generate a null and do a not-equal comparison against the first arg. */ - se->expr = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + se->expr = fold_build2_loc (input_location, NE_EXPR, logical_type_node, arg1se.expr, fold_convert (TREE_TYPE (arg1se.expr), null_pointer_node)); @@ -8059,17 +8068,17 @@ conv_isocbinding_function (gfc_se *se, gfc_expr *expr) gfc_add_block_to_block (&se->post, &arg2se.post); /* Generate test to compare that the two args are equal. */ - eq_expr = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, + eq_expr = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, arg1se.expr, arg2se.expr); /* Generate test to ensure that the first arg is not null. */ not_null_expr = fold_build2_loc (input_location, NE_EXPR, - boolean_type_node, + logical_type_node, arg1se.expr, null_pointer_node); /* Finally, the generated test must check that both arg1 is not NULL and that it is equal to the second arg. */ se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR, - boolean_type_node, + logical_type_node, not_null_expr, eq_expr); } } @@ -8299,11 +8308,11 @@ conv_intrinsic_ieee_is_normal (gfc_se * se, gfc_expr * expr) isnormal = build_call_expr_loc (input_location, builtin_decl_explicit (BUILT_IN_ISNORMAL), 1, arg); - iszero = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, arg, + iszero = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, arg, build_real_from_int_cst (TREE_TYPE (arg), integer_zero_node)); se->expr = fold_build2_loc (input_location, TRUTH_OR_EXPR, - boolean_type_node, isnormal, iszero); + logical_type_node, isnormal, iszero); se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr); } @@ -8328,11 +8337,11 @@ conv_intrinsic_ieee_is_negative (gfc_se * se, gfc_expr * expr) signbit = build_call_expr_loc (input_location, builtin_decl_explicit (BUILT_IN_SIGNBIT), 1, arg); - signbit = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + signbit = fold_build2_loc (input_location, NE_EXPR, logical_type_node, signbit, integer_zero_node); se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR, - boolean_type_node, signbit, + logical_type_node, signbit, fold_build1_loc (input_location, TRUTH_NOT_EXPR, TREE_TYPE(isnan), isnan)); @@ -8478,7 +8487,7 @@ conv_intrinsic_ieee_copy_sign (gfc_se * se, gfc_expr * expr) sign = build_call_expr_loc (input_location, builtin_decl_explicit (BUILT_IN_SIGNBIT), 1, args[1]); - sign = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + sign = fold_build2_loc (input_location, NE_EXPR, logical_type_node, sign, integer_zero_node); /* Create a value of one, with the right sign. */ @@ -10544,7 +10553,7 @@ conv_intrinsic_move_alloc (gfc_code *code) tmp = gfc_conv_descriptor_data_get (to_se.expr); cond = fold_build2_loc (input_location, EQ_EXPR, - boolean_type_node, tmp, + logical_type_node, tmp, fold_convert (TREE_TYPE (tmp), null_pointer_node)); tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_all, diff --git a/gcc/fortran/trans-io.c b/gcc/fortran/trans-io.c index f3e1f3e4d09..9cd33b331e1 100644 --- a/gcc/fortran/trans-io.c +++ b/gcc/fortran/trans-io.c @@ -581,7 +581,7 @@ set_parameter_value_chk (stmtblock_t *block, bool has_iostat, tree var, /* UNIT numbers should be greater than the min. */ i = gfc_validate_kind (BT_INTEGER, 4, false); val = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].pedantic_min_int, 4); - cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, + cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node, se.expr, fold_convert (TREE_TYPE (se.expr), val)); gfc_trans_io_runtime_check (has_iostat, cond, var, LIBERROR_BAD_UNIT, @@ -590,7 +590,7 @@ set_parameter_value_chk (stmtblock_t *block, bool has_iostat, tree var, /* UNIT numbers should be less than the max. */ val = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, 4); - cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, + cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, se.expr, fold_convert (TREE_TYPE (se.expr), val)); gfc_trans_io_runtime_check (has_iostat, cond, var, LIBERROR_BAD_UNIT, @@ -641,17 +641,17 @@ set_parameter_value_inquire (stmtblock_t *block, tree var, /* UNIT numbers should be greater than zero. */ i = gfc_validate_kind (BT_INTEGER, 4, false); - cond1 = build2_loc (input_location, LT_EXPR, boolean_type_node, + cond1 = build2_loc (input_location, LT_EXPR, logical_type_node, se.expr, fold_convert (TREE_TYPE (se.expr), integer_zero_node)); /* UNIT numbers should be less than the max. */ val = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, 4); - cond2 = build2_loc (input_location, GT_EXPR, boolean_type_node, + cond2 = build2_loc (input_location, GT_EXPR, logical_type_node, se.expr, fold_convert (TREE_TYPE (se.expr), val)); cond3 = build2_loc (input_location, TRUTH_OR_EXPR, - boolean_type_node, cond1, cond2); + logical_type_node, cond1, cond2); gfc_start_block (&newblock); @@ -826,7 +826,7 @@ set_string (stmtblock_t * block, stmtblock_t * postblock, tree var, gfc_conv_label_variable (&se, e); tmp = GFC_DECL_STRING_LEN (se.expr); - cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, + cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node, tmp, build_int_cst (TREE_TYPE (tmp), 0)); msg = xasprintf ("Label assigned to variable '%s' (%%ld) is not a format " diff --git a/gcc/fortran/trans-openmp.c b/gcc/fortran/trans-openmp.c index 00c02a75d18..75eafe42f93 100644 --- a/gcc/fortran/trans-openmp.c +++ b/gcc/fortran/trans-openmp.c @@ -413,7 +413,7 @@ gfc_walk_alloc_comps (tree decl, tree dest, tree var, { tem = fold_convert (pvoid_type_node, tem); tem = fold_build2_loc (input_location, NE_EXPR, - boolean_type_node, tem, + logical_type_node, tem, null_pointer_node); then_b = build3_loc (input_location, COND_EXPR, void_type_node, tem, then_b, @@ -540,7 +540,7 @@ gfc_omp_clause_default_ctor (tree clause, tree decl, tree outer) GFC_DESCRIPTOR_TYPE_P (type) ? gfc_conv_descriptor_data_get (outer) : outer); tem = unshare_expr (tem); - cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tem, null_pointer_node); gfc_add_expr_to_block (&block, build3_loc (input_location, COND_EXPR, @@ -646,7 +646,7 @@ gfc_omp_clause_copy_ctor (tree clause, tree dest, tree src) build_zero_cst (TREE_TYPE (dest))); else_b = gfc_finish_block (&cond_block); - cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, unshare_expr (srcptr), null_pointer_node); gfc_add_expr_to_block (&block, build3_loc (input_location, COND_EXPR, @@ -699,7 +699,7 @@ gfc_omp_clause_assign_op (tree clause, tree dest, tree src) GFC_DESCRIPTOR_TYPE_P (type) ? gfc_conv_descriptor_data_get (dest) : dest); tem = unshare_expr (tem); - cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tem, null_pointer_node); tem = build3_loc (input_location, COND_EXPR, void_type_node, cond, then_b, build_empty_stmt (input_location)); @@ -739,7 +739,7 @@ gfc_omp_clause_assign_op (tree clause, tree dest, tree src) destptr = fold_convert (pvoid_type_node, destptr); gfc_add_modify (&cond_block, ptr, destptr); - nonalloc = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, + nonalloc = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, destptr, null_pointer_node); cond = nonalloc; if (GFC_DESCRIPTOR_TYPE_P (type)) @@ -755,11 +755,11 @@ gfc_omp_clause_assign_op (tree clause, tree dest, tree src) tem = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, tem, gfc_conv_descriptor_lbound_get (dest, rank)); - tem = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + tem = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tem, gfc_conv_descriptor_ubound_get (dest, rank)); cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR, - boolean_type_node, cond, tem); + logical_type_node, cond, tem); } } @@ -835,7 +835,7 @@ gfc_omp_clause_assign_op (tree clause, tree dest, tree src) } else_b = gfc_finish_block (&cond_block); - cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, unshare_expr (srcptr), null_pointer_node); gfc_add_expr_to_block (&block, build3_loc (input_location, COND_EXPR, @@ -1028,7 +1028,7 @@ gfc_omp_clause_dtor (tree clause, tree decl) GFC_DESCRIPTOR_TYPE_P (type) ? gfc_conv_descriptor_data_get (decl) : decl); tem = unshare_expr (tem); - tree cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + tree cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tem, null_pointer_node); tem = build3_loc (input_location, COND_EXPR, void_type_node, cond, then_b, build_empty_stmt (input_location)); @@ -1129,7 +1129,7 @@ gfc_omp_finish_clause (tree c, gimple_seq *pre_p) tem = gfc_conv_descriptor_data_get (decl); tem = fold_convert (pvoid_type_node, tem); cond = fold_build2_loc (input_location, NE_EXPR, - boolean_type_node, tem, null_pointer_node); + logical_type_node, tem, null_pointer_node); gfc_add_expr_to_block (&block, build3_loc (input_location, COND_EXPR, void_type_node, cond, then_b, else_b)); @@ -2155,7 +2155,7 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, tem = gfc_conv_descriptor_data_get (decl); tem = fold_convert (pvoid_type_node, tem); cond = fold_build2_loc (input_location, NE_EXPR, - boolean_type_node, + logical_type_node, tem, null_pointer_node); gfc_add_expr_to_block (block, build3_loc (input_location, @@ -3599,7 +3599,7 @@ gfc_trans_omp_do (gfc_code *code, gfc_exec_op op, stmtblock_t *pblock, /* The condition should not be folded. */ TREE_VEC_ELT (cond, i) = build2_loc (input_location, simple > 0 ? LE_EXPR : GE_EXPR, - boolean_type_node, dovar, to); + logical_type_node, dovar, to); TREE_VEC_ELT (incr, i) = fold_build2_loc (input_location, PLUS_EXPR, type, dovar, step); TREE_VEC_ELT (incr, i) = fold_build2_loc (input_location, @@ -3626,7 +3626,7 @@ gfc_trans_omp_do (gfc_code *code, gfc_exec_op op, stmtblock_t *pblock, build_int_cst (type, 0)); /* The condition should not be folded. */ TREE_VEC_ELT (cond, i) = build2_loc (input_location, LT_EXPR, - boolean_type_node, + logical_type_node, count, tmp); TREE_VEC_ELT (incr, i) = fold_build2_loc (input_location, PLUS_EXPR, type, count, diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 7a76b8ead31..ea0f9529f1c 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -150,7 +150,7 @@ gfc_trans_goto (gfc_code * code) gfc_start_block (&se.pre); gfc_conv_label_variable (&se, code->expr1); tmp = GFC_DECL_STRING_LEN (se.expr); - tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp, + tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp, build_int_cst (TREE_TYPE (tmp), -1)); gfc_trans_runtime_check (true, false, tmp, &se.pre, &loc, "Assigned label is not a target label"); @@ -1107,7 +1107,7 @@ gfc_trans_sync (gfc_code *code, gfc_exec_op type) { tree cond; if (flag_coarray != GFC_FCOARRAY_LIB) - cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, images, build_int_cst (TREE_TYPE (images), 1)); else { @@ -1115,13 +1115,13 @@ gfc_trans_sync (gfc_code *code, gfc_exec_op type) tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images, 2, integer_zero_node, build_int_cst (integer_type_node, -1)); - cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, + cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, images, tmp); - cond2 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, + cond2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node, images, build_int_cst (TREE_TYPE (images), 1)); cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, - boolean_type_node, cond, cond2); + logical_type_node, cond, cond2); } gfc_trans_runtime_check (true, false, cond, &se.pre, &code->expr1->where, "Invalid image number " @@ -1413,10 +1413,10 @@ gfc_trans_arithmetic_if (gfc_code * code) branch2 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label2)); if (code->label1->value != code->label3->value) - tmp = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, + tmp = fold_build2_loc (input_location, LT_EXPR, logical_type_node, se.expr, zero); else - tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, se.expr, zero); branch1 = fold_build3_loc (input_location, COND_EXPR, void_type_node, @@ -1430,7 +1430,7 @@ gfc_trans_arithmetic_if (gfc_code * code) { /* if (cond <= 0) take branch1 else take branch2. */ branch2 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label3)); - tmp = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, + tmp = fold_build2_loc (input_location, LE_EXPR, logical_type_node, se.expr, zero); branch1 = fold_build3_loc (input_location, COND_EXPR, void_type_node, tmp, branch1, branch2); @@ -1966,10 +1966,10 @@ gfc_trans_simple_do (gfc_code * code, stmtblock_t *pblock, tree dovar, /* Evaluate the loop condition. */ if (is_step_positive) - cond = fold_build2_loc (loc, GT_EXPR, boolean_type_node, dovar, + cond = fold_build2_loc (loc, GT_EXPR, logical_type_node, dovar, fold_convert (type, to)); else - cond = fold_build2_loc (loc, LT_EXPR, boolean_type_node, dovar, + cond = fold_build2_loc (loc, LT_EXPR, logical_type_node, dovar, fold_convert (type, to)); cond = gfc_evaluate_now_loc (loc, cond, &body); @@ -1988,7 +1988,7 @@ gfc_trans_simple_do (gfc_code * code, stmtblock_t *pblock, tree dovar, tree boundary = is_step_positive ? TYPE_MAX_VALUE (type) : TYPE_MIN_VALUE (type); - tmp = fold_build2_loc (loc, EQ_EXPR, boolean_type_node, + tmp = fold_build2_loc (loc, EQ_EXPR, logical_type_node, dovar, boundary); gfc_trans_runtime_check (true, false, tmp, &body, &code->loc, "Loop iterates infinitely"); @@ -2008,7 +2008,7 @@ gfc_trans_simple_do (gfc_code * code, stmtblock_t *pblock, tree dovar, /* Check whether someone has modified the loop variable. */ if (gfc_option.rtcheck & GFC_RTCHECK_DO) { - tmp = fold_build2_loc (loc, NE_EXPR, boolean_type_node, + tmp = fold_build2_loc (loc, NE_EXPR, logical_type_node, dovar, saved_dovar); gfc_trans_runtime_check (true, false, tmp, &body, &code->loc, "Loop variable has been modified"); @@ -2117,7 +2117,7 @@ gfc_trans_do (gfc_code * code, tree exit_cond) if (gfc_option.rtcheck & GFC_RTCHECK_DO) { - tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, step, + tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, step, build_zero_cst (type)); gfc_trans_runtime_check (true, false, tmp, &block, &code->loc, "DO step value is zero"); @@ -2184,7 +2184,7 @@ gfc_trans_do (gfc_code * code, tree exit_cond) /* For a positive step, when to < from, exit, otherwise compute countm1 = ((unsigned)to - (unsigned)from) / (unsigned)step */ - tmp = fold_build2_loc (loc, LT_EXPR, boolean_type_node, to, from); + tmp = fold_build2_loc (loc, LT_EXPR, logical_type_node, to, from); tmp2 = fold_build2_loc (loc, TRUNC_DIV_EXPR, utype, fold_build2_loc (loc, MINUS_EXPR, utype, tou, fromu), @@ -2199,7 +2199,7 @@ gfc_trans_do (gfc_code * code, tree exit_cond) /* For a negative step, when to > from, exit, otherwise compute countm1 = ((unsigned)from - (unsigned)to) / -(unsigned)step */ - tmp = fold_build2_loc (loc, GT_EXPR, boolean_type_node, to, from); + tmp = fold_build2_loc (loc, GT_EXPR, logical_type_node, to, from); tmp2 = fold_build2_loc (loc, TRUNC_DIV_EXPR, utype, fold_build2_loc (loc, MINUS_EXPR, utype, fromu, tou), @@ -2212,7 +2212,7 @@ gfc_trans_do (gfc_code * code, tree exit_cond) build1_loc (loc, GOTO_EXPR, void_type_node, exit_label), NULL_TREE)); - tmp = fold_build2_loc (loc, LT_EXPR, boolean_type_node, step, + tmp = fold_build2_loc (loc, LT_EXPR, logical_type_node, step, build_int_cst (TREE_TYPE (step), 0)); tmp = fold_build3_loc (loc, COND_EXPR, void_type_node, tmp, neg, pos); @@ -2233,13 +2233,13 @@ gfc_trans_do (gfc_code * code, tree exit_cond) /* We need a special check for empty loops: empty = (step > 0 ? to < from : to > from); */ - pos_step = fold_build2_loc (loc, GT_EXPR, boolean_type_node, step, + pos_step = fold_build2_loc (loc, GT_EXPR, logical_type_node, step, build_zero_cst (type)); - tmp = fold_build3_loc (loc, COND_EXPR, boolean_type_node, pos_step, + tmp = fold_build3_loc (loc, COND_EXPR, logical_type_node, pos_step, fold_build2_loc (loc, LT_EXPR, - boolean_type_node, to, from), + logical_type_node, to, from), fold_build2_loc (loc, GT_EXPR, - boolean_type_node, to, from)); + logical_type_node, to, from)); /* If the loop is empty, go directly to the exit label. */ tmp = fold_build3_loc (loc, COND_EXPR, void_type_node, tmp, build1_v (GOTO_EXPR, exit_label), @@ -2264,7 +2264,7 @@ gfc_trans_do (gfc_code * code, tree exit_cond) /* Check whether someone has modified the loop variable. */ if (gfc_option.rtcheck & GFC_RTCHECK_DO) { - tmp = fold_build2_loc (loc, NE_EXPR, boolean_type_node, dovar, + tmp = fold_build2_loc (loc, NE_EXPR, logical_type_node, dovar, saved_dovar); gfc_trans_runtime_check (true, false, tmp, &body, &code->loc, "Loop variable has been modified"); @@ -2297,7 +2297,7 @@ gfc_trans_do (gfc_code * code, tree exit_cond) gfc_add_modify_loc (loc, &body, countm1, tmp); /* End with the loop condition. Loop until countm1t == 0. */ - cond = fold_build2_loc (loc, EQ_EXPR, boolean_type_node, countm1t, + cond = fold_build2_loc (loc, EQ_EXPR, logical_type_node, countm1t, build_int_cst (utype, 0)); tmp = fold_build1_loc (loc, GOTO_EXPR, void_type_node, exit_label); tmp = fold_build3_loc (loc, COND_EXPR, void_type_node, @@ -3450,7 +3450,7 @@ gfc_trans_forall_loop (forall_info *forall_tmp, tree body, gfc_init_block (&block); /* The exit condition. */ - cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, + cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node, count, build_int_cst (TREE_TYPE (count), 0)); if (forall_tmp->do_concurrent) cond = build2 (ANNOTATE_EXPR, TREE_TYPE (cond), cond, @@ -5128,7 +5128,7 @@ gfc_trans_where_2 (gfc_code * code, tree mask, bool invert, &inner_size_body, block); /* Check whether the size is negative. */ - cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, size, + cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node, size, gfc_index_zero_node); size = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type, cond, gfc_index_zero_node, size); @@ -5913,10 +5913,9 @@ gfc_trans_allocate (gfc_code * code) if (code->ext.alloc.ts.type != BT_CHARACTER) expr3_esize = TYPE_SIZE_UNIT ( gfc_typenode_for_spec (&code->ext.alloc.ts)); - else + else if (code->ext.alloc.ts.u.cl->length != NULL) { gfc_expr *sz; - gcc_assert (code->ext.alloc.ts.u.cl->length != NULL); sz = gfc_copy_expr (code->ext.alloc.ts.u.cl->length); gfc_init_se (&se_sz, NULL); gfc_conv_expr (&se_sz, sz); @@ -5930,6 +5929,8 @@ gfc_trans_allocate (gfc_code * code) tmp, se_sz.expr); expr3_esize = gfc_evaluate_now (expr3_esize, &block); } + else + expr3_esize = NULL_TREE; } /* The routine gfc_trans_assignment () already implements all @@ -6134,7 +6135,7 @@ gfc_trans_allocate (gfc_code * code) polymorphic and stores a _len dependent object, e.g., a string. */ memsz = fold_build2_loc (input_location, GT_EXPR, - boolean_type_node, expr3_len, + logical_type_node, expr3_len, integer_zero_node); memsz = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (expr3_esize), @@ -6267,7 +6268,7 @@ gfc_trans_allocate (gfc_code * code) { tmp = build1_v (GOTO_EXPR, label_errmsg); parm = fold_build2_loc (input_location, NE_EXPR, - boolean_type_node, stat, + logical_type_node, stat, build_int_cst (TREE_TYPE (stat), 0)); tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, gfc_unlikely (parm, PRED_FORTRAN_FAIL_ALLOC), @@ -6515,7 +6516,7 @@ gfc_trans_allocate (gfc_code * code) gfc_default_character_kind); dlen = gfc_finish_block (&errmsg_block); - tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, stat, build_int_cst (TREE_TYPE (stat), 0)); tmp = build3_v (COND_EXPR, tmp, @@ -6768,7 +6769,7 @@ gfc_trans_deallocate (gfc_code *code) { tree cond; - cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, stat, + cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, stat, build_int_cst (TREE_TYPE (stat), 0)); tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, gfc_unlikely (cond, PRED_FORTRAN_FAIL_ALLOC), @@ -6808,7 +6809,7 @@ gfc_trans_deallocate (gfc_code *code) slen, errmsg_str, gfc_default_character_kind); tmp = gfc_finish_block (&errmsg_block); - cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, stat, + cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, stat, build_int_cst (TREE_TYPE (stat), 0)); tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, gfc_unlikely (cond, PRED_FORTRAN_FAIL_ALLOC), tmp, diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index c8ca144b896..10a454cf40f 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -62,6 +62,9 @@ tree ppvoid_type_node; tree pchar_type_node; tree pfunc_type_node; +tree logical_type_node; +tree logical_true_node; +tree logical_false_node; tree gfc_charlen_type_node; tree gfc_float128_type_node = NULL_TREE; @@ -1003,6 +1006,11 @@ gfc_init_types (void) wi::mask (n, UNSIGNED, TYPE_PRECISION (size_type_node))); + + logical_type_node = gfc_get_logical_type (gfc_default_logical_kind); + logical_true_node = build_int_cst (logical_type_node, 1); + logical_false_node = build_int_cst (logical_type_node, 0); + /* ??? Shouldn't this be based on gfc_index_integer_kind or so? */ gfc_charlen_int_kind = 4; gfc_charlen_type_node = gfc_get_int_type (gfc_charlen_int_kind); @@ -3266,11 +3274,11 @@ gfc_get_array_descr_info (const_tree type, struct array_descr_info *info) t = build1 (NOP_EXPR, build_pointer_type (ptr_type_node), t); info->data_location = build1 (INDIRECT_REF, ptr_type_node, t); if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE) - info->allocated = build2 (NE_EXPR, boolean_type_node, + info->allocated = build2 (NE_EXPR, logical_type_node, info->data_location, null_pointer_node); else if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT) - info->associated = build2 (NE_EXPR, boolean_type_node, + info->associated = build2 (NE_EXPR, logical_type_node, info->data_location, null_pointer_node); if ((GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK_CONT) diff --git a/gcc/fortran/trans-types.h b/gcc/fortran/trans-types.h index 2974e451304..6dba78e3671 100644 --- a/gcc/fortran/trans-types.h +++ b/gcc/fortran/trans-types.h @@ -33,6 +33,20 @@ extern GTY(()) tree pchar_type_node; extern GTY(()) tree gfc_float128_type_node; extern GTY(()) tree gfc_complex_float128_type_node; +/* logical_type_node is the Fortran LOGICAL type of default kind. In + addition to uses mandated by the Fortran standard, also prefer it + for compiler generated temporary variables, is it avoids some minor + issues with boolean_type_node (the C/C++ _Bool/bool). Namely: + - On x86, partial register stalls with 8/16 bit register access, + and length prefix changes. + - On s390 there is a compare with immediate and jump instruction, + but it works only with 32-bit quantities and not 8-bit such as + boolean_type_node. +*/ +extern GTY(()) tree logical_type_node; +extern GTY(()) tree logical_true_node; +extern GTY(()) tree logical_false_node; + /* This is the type used to hold the lengths of character variables. It must be the same as the corresponding definition in gfortran.h. */ /* TODO: This is still hardcoded as kind=4 in some bits of the compiler diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c index 53bc4285c78..8c1733448f4 100644 --- a/gcc/fortran/trans.c +++ b/gcc/fortran/trans.c @@ -320,8 +320,12 @@ get_array_span (tree type, tree decl) || DECL_CONTEXT (TYPE_MAX_VALUE (TYPE_DOMAIN (type))) == DECL_CONTEXT (decl))) { - span = TYPE_MAX_VALUE (TYPE_DOMAIN (type)); - span = fold_convert (gfc_array_index_type, span); + span = fold_convert (gfc_array_index_type, + TYPE_MAX_VALUE (TYPE_DOMAIN (type))); + span = fold_build2 (MULT_EXPR, gfc_array_index_type, + fold_convert (gfc_array_index_type, + TYPE_SIZE_UNIT (TREE_TYPE (type))), + span); } /* Likewise for class array or pointer array references. */ else if (TREE_CODE (decl) == FIELD_DECL @@ -533,9 +537,9 @@ gfc_trans_runtime_check (bool error, bool once, tree cond, stmtblock_t * pblock, if (once) { - tmpvar = gfc_create_var (boolean_type_node, "print_warning"); + tmpvar = gfc_create_var (logical_type_node, "print_warning"); TREE_STATIC (tmpvar) = 1; - DECL_INITIAL (tmpvar) = boolean_true_node; + DECL_INITIAL (tmpvar) = logical_true_node; gfc_add_expr_to_block (pblock, tmpvar); } @@ -554,7 +558,7 @@ gfc_trans_runtime_check (bool error, bool once, tree cond, stmtblock_t * pblock, va_end (ap); if (once) - gfc_add_modify (&block, tmpvar, boolean_false_node); + gfc_add_modify (&block, tmpvar, logical_false_node); body = gfc_finish_block (&block); @@ -607,7 +611,7 @@ gfc_call_malloc (stmtblock_t * block, tree type, tree size) if (gfc_option.rtcheck & GFC_RTCHECK_MEM) { null_result = fold_build2_loc (input_location, EQ_EXPR, - boolean_type_node, res, + logical_type_node, res, build_int_cst (pvoid_type_node, 0)); msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const ("Memory allocation failed")); @@ -693,7 +697,7 @@ gfc_allocate_using_malloc (stmtblock_t * block, tree pointer, } error_cond = fold_build2_loc (input_location, EQ_EXPR, - boolean_type_node, pointer, + logical_type_node, pointer, build_int_cst (prvoid_type_node, 0)); tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, gfc_unlikely (error_cond, PRED_FORTRAN_FAIL_ALLOC), @@ -795,7 +799,7 @@ gfc_allocate_allocatable (stmtblock_t * block, tree mem, tree size, size = fold_convert (size_type_node, size); null_mem = gfc_unlikely (fold_build2_loc (input_location, NE_EXPR, - boolean_type_node, mem, + logical_type_node, mem, build_int_cst (type, 0)), PRED_FORTRAN_REALLOC); @@ -873,7 +877,7 @@ gfc_allocate_allocatable (stmtblock_t * block, tree mem, tree size, { TREE_USED (label_finish) = 1; tmp = build1_v (GOTO_EXPR, label_finish); - cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, status, build_zero_cst (TREE_TYPE (status))); tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, gfc_unlikely (cond, PRED_FORTRAN_FAIL_ALLOC), @@ -1090,12 +1094,12 @@ gfc_add_comp_finalizer_call (stmtblock_t *block, tree decl, gfc_component *comp, { tmp = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (array)) ? gfc_conv_descriptor_data_get (array) : array; - cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp, fold_convert (TREE_TYPE (tmp), null_pointer_node)); } else - cond = boolean_true_node; + cond = logical_true_node; if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (array))) { @@ -1111,12 +1115,12 @@ gfc_add_comp_finalizer_call (stmtblock_t *block, tree decl, gfc_component *comp, if (!final_expr) { - tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, final_fndecl, fold_convert (TREE_TYPE (final_fndecl), null_pointer_node)); cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR, - boolean_type_node, cond, tmp); + logical_type_node, cond, tmp); } if (POINTER_TYPE_P (TREE_TYPE (final_fndecl))) @@ -1212,7 +1216,7 @@ gfc_add_finalizer_call (stmtblock_t *block, gfc_expr *expr2) gfc_init_se (&se, NULL); se.want_pointer = 1; gfc_conv_expr (&se, final_expr); - cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, se.expr, build_int_cst (TREE_TYPE (se.expr), 0)); /* For CLASS(*) not only sym->_vtab->_final can be NULL @@ -1230,11 +1234,11 @@ gfc_add_finalizer_call (stmtblock_t *block, gfc_expr *expr2) gfc_conv_expr (&se, vptr_expr); gfc_free_expr (vptr_expr); - cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + cond2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node, se.expr, build_int_cst (TREE_TYPE (se.expr), 0)); cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR, - boolean_type_node, cond2, cond); + logical_type_node, cond2, cond); } tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, @@ -1340,7 +1344,7 @@ gfc_deallocate_with_status (tree pointer, tree status, tree errmsg, else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (pointer))) pointer = gfc_conv_descriptor_data_get (pointer); - cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, pointer, + cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, pointer, build_int_cst (TREE_TYPE (pointer), 0)); /* When POINTER is NULL, we set STATUS to 1 if it's present, otherwise @@ -1367,7 +1371,7 @@ gfc_deallocate_with_status (tree pointer, tree status, tree errmsg, tree cond2; status_type = TREE_TYPE (TREE_TYPE (status)); - cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + cond2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node, status, build_int_cst (TREE_TYPE (status), 0)); tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type, fold_build1_loc (input_location, INDIRECT_REF, @@ -1400,7 +1404,7 @@ gfc_deallocate_with_status (tree pointer, tree status, tree errmsg, tree status_type = TREE_TYPE (TREE_TYPE (status)); tree cond2; - cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + cond2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node, status, build_int_cst (TREE_TYPE (status), 0)); tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type, @@ -1463,7 +1467,7 @@ gfc_deallocate_with_status (tree pointer, tree status, tree errmsg, TREE_USED (label_finish) = 1; tmp = build1_v (GOTO_EXPR, label_finish); - cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + cond2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node, stat, build_zero_cst (TREE_TYPE (stat))); tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, gfc_unlikely (cond2, PRED_FORTRAN_REALLOC), @@ -1499,7 +1503,7 @@ gfc_deallocate_scalar_with_status (tree pointer, tree status, tree label_finish, && comp_ref) caf_dereg_type = GFC_CAF_COARRAY_DEALLOCATE_ONLY; - cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, pointer, + cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, pointer, build_int_cst (TREE_TYPE (pointer), 0)); /* When POINTER is NULL, we set STATUS to 1 if it's present, otherwise @@ -1526,7 +1530,7 @@ gfc_deallocate_scalar_with_status (tree pointer, tree status, tree label_finish, tree status_type = TREE_TYPE (TREE_TYPE (status)); tree cond2; - cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + cond2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node, status, build_int_cst (TREE_TYPE (status), 0)); tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type, fold_build1_loc (input_location, INDIRECT_REF, @@ -1571,7 +1575,7 @@ gfc_deallocate_scalar_with_status (tree pointer, tree status, tree label_finish, tree status_type = TREE_TYPE (TREE_TYPE (status)); tree cond2; - cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + cond2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node, status, build_int_cst (TREE_TYPE (status), 0)); tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type, @@ -1621,7 +1625,7 @@ gfc_deallocate_scalar_with_status (tree pointer, tree status, tree label_finish, TREE_USED (label_finish) = 1; tmp = build1_v (GOTO_EXPR, label_finish); - cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + cond2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node, stat, build_zero_cst (TREE_TYPE (stat))); tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, gfc_unlikely (cond2, PRED_FORTRAN_REALLOC), @@ -1664,11 +1668,11 @@ gfc_call_realloc (stmtblock_t * block, tree mem, tree size) builtin_decl_explicit (BUILT_IN_REALLOC), 2, fold_convert (pvoid_type_node, mem), size); gfc_add_modify (block, res, fold_convert (type, tmp)); - null_result = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, + null_result = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, res, build_int_cst (pvoid_type_node, 0)); - nonzero = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, size, + nonzero = fold_build2_loc (input_location, NE_EXPR, logical_type_node, size, build_int_cst (size_type_node, 0)); - null_result = fold_build2_loc (input_location, TRUTH_AND_EXPR, boolean_type_node, + null_result = fold_build2_loc (input_location, TRUTH_AND_EXPR, logical_type_node, null_result, nonzero); msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const ("Allocation would exceed memory limit")); |