From e344505cec510fe08af6c3263fc10619295ccd45 Mon Sep 17 00:00:00 2001 From: Jerry DeLisle Date: Fri, 23 Jan 2015 01:59:23 +0000 Subject: re PR fortran/61933 (Inquire on internal units) 2015-01-22 Jerry DeLisle PR fortran/61933 * libgfortran.h: * trans-io.c (set_parameter_value): Delete use of has_iostat. Redefine to not generate any runtime error check calls. (set_parameter_value_chk): Rename of the former set_parameter_value with the runtime error checks and fix whitespace. (set_parameter_value_inquire): New function that builds a runtime conditional block to set the INQUIRE common parameter block unit number to -2 when unit numbers exceed positive KIND=4 limits. (gfc_trans_open): Whitespace. For unit, use the renamed set_parameter_value_chk. (gfc_trans_close): Likewise use renamed function. (build_filepos): Whitespace and use renamed function. (gfc_trans_inquire): Whitespace and for unit use set_parameter_value and set_parameter_value_inquire. (gfc_trans_wait): Remove p->iostat from call to set_parameter_value. Use new set_parameter_value_chk for unit. (build_dt): Use the new set_parameter_value without p->iostat and fix whitespace. Use set_parameter_value_chk for unit. From-SVN: r220023 --- gcc/fortran/ChangeLog | 23 ++++++++ gcc/fortran/libgfortran.h | 4 ++ gcc/fortran/trans-io.c | 137 ++++++++++++++++++++++++++++++++++++++-------- 3 files changed, 142 insertions(+), 22 deletions(-) diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index db43df4..d2742c8 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,25 @@ +2015-01-22 Jerry DeLisle + + PR fortran/61933 + * libgfortran.h: + * trans-io.c (set_parameter_value): Delete use of has_iostat. + Redefine to not generate any runtime error check calls. + (set_parameter_value_chk): Rename of the former + set_parameter_value with the runtime error checks and fix + whitespace. (set_parameter_value_inquire): New function that + builds a runtime conditional block to set the INQUIRE + common parameter block unit number to -2 when unit numbers + exceed positive KIND=4 limits. (gfc_trans_open): Whitespace. + For unit, use the renamed set_parameter_value_chk. + (gfc_trans_close): Likewise use renamed function. + (build_filepos): Whitespace and use renamed function. + (gfc_trans_inquire): Whitespace and for unit use + set_parameter_value and set_parameter_value_inquire. + (gfc_trans_wait): Remove p->iostat from call to + set_parameter_value. Use new set_parameter_value_chk for unit. + (build_dt): Use the new set_parameter_value without p->iostat + and fix whitespace. Use set_parameter_value_chk for unit. + 2015-01-21 Thomas Koenig PR fortran/57023 @@ -95,6 +117,7 @@ * decl.c (match_pointer_init): Error out if resolution of init expr failed. +>>>>>>> .r219925 2015-01-15 Tobias Burnus * openmp.c (check_symbol_not_pointer, resolve_oacc_data_clauses, diff --git a/gcc/fortran/libgfortran.h b/gcc/fortran/libgfortran.h index 5706d73..df11162 100644 --- a/gcc/fortran/libgfortran.h +++ b/gcc/fortran/libgfortran.h @@ -68,6 +68,10 @@ along with GCC; see the file COPYING3. If not see | GFC_RTCHECK_RECURSION | GFC_RTCHECK_DO \ | GFC_RTCHECK_POINTER | GFC_RTCHECK_MEM) +/* Special unit numbers used to convey certain conditions. Numbers -3 + thru -9 available. NEWUNIT values start at -10. */ +#define GFC_INTERNAL_UNIT -1 +#define GFC_INVALID_UNIT -2 /* Possible values for the CONVERT I/O specifier. */ /* Keep in sync with GFC_FLAG_CONVERT_* in gcc/flags.h. */ diff --git a/gcc/fortran/trans-io.c b/gcc/fortran/trans-io.c index e619acb..aa14706 100644 --- a/gcc/fortran/trans-io.c +++ b/gcc/fortran/trans-io.c @@ -512,7 +512,37 @@ set_parameter_const (stmtblock_t *block, tree var, enum iofield type, st_parameter_XXX structure. This is a pass by value. */ static unsigned int -set_parameter_value (stmtblock_t *block, bool has_iostat, tree var, +set_parameter_value (stmtblock_t *block, tree var, enum iofield type, + gfc_expr *e) +{ + gfc_se se; + tree tmp; + gfc_st_parameter_field *p = &st_parameter_field[type]; + tree dest_type = TREE_TYPE (p->field); + + gfc_init_se (&se, NULL); + gfc_conv_expr_val (&se, e); + + se.expr = convert (dest_type, se.expr); + gfc_add_block_to_block (block, &se.pre); + + if (p->param_type == IOPARM_ptype_common) + var = fold_build3_loc (input_location, COMPONENT_REF, + st_parameter[IOPARM_ptype_common].type, + var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE); + + tmp = fold_build3_loc (input_location, COMPONENT_REF, dest_type, var, + p->field, NULL_TREE); + gfc_add_modify (block, tmp, se.expr); + return p->mask; +} + + +/* Similar to set_parameter_value except generate runtime + error checks. */ + +static unsigned int +set_parameter_value_chk (stmtblock_t *block, bool has_iostat, tree var, enum iofield type, gfc_expr *e) { gfc_se se; @@ -550,7 +580,6 @@ set_parameter_value (stmtblock_t *block, bool has_iostat, tree var, gfc_trans_io_runtime_check (has_iostat, cond, var, LIBERROR_BAD_UNIT, "Unit number in I/O statement too large", &se.pre); - } se.expr = convert (dest_type, se.expr); @@ -568,6 +597,70 @@ set_parameter_value (stmtblock_t *block, bool has_iostat, tree var, } +/* Build code to check the unit range if KIND=8 is used. Similar to + set_parameter_value_chk but we do not generate error calls for + inquire statements. */ + +static unsigned int +set_parameter_value_inquire (stmtblock_t *block, tree var, + enum iofield type, gfc_expr *e) +{ + gfc_se se; + gfc_st_parameter_field *p = &st_parameter_field[type]; + tree dest_type = TREE_TYPE (p->field); + + gfc_init_se (&se, NULL); + gfc_conv_expr_val (&se, e); + + /* If we're inquiring on a UNIT number, we need to check to make + sure it exists for larger than kind = 4. */ + if (type == IOPARM_common_unit && e->ts.kind > 4) + { + stmtblock_t newblock; + tree cond1, cond2, cond3, val, body; + int i; + + /* Don't evaluate the UNIT number multiple times. */ + se.expr = gfc_evaluate_now (se.expr, &se.pre); + + /* 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, + 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, + se.expr, + fold_convert (TREE_TYPE (se.expr), val)); + cond3 = build2_loc (input_location, TRUTH_OR_EXPR, + boolean_type_node, cond1, cond2); + + gfc_start_block (&newblock); + + /* The unit number GFC_INVALID_UNIT is reserved. No units can + ever have this value. It is used here to signal to the + runtime library that the inquire unit number is outside the + allowable range and so cannot exist. It is needed when + -fdefault-integer-8 is used. */ + set_parameter_const (&newblock, var, IOPARM_common_unit, + GFC_INVALID_UNIT); + + body = gfc_finish_block (&newblock); + + cond3 = gfc_unlikely (cond3, PRED_FORTRAN_FAIL_IO); + var = build3_v (COND_EXPR, cond3, body, build_empty_stmt (input_location)); + gfc_add_expr_to_block (&se.pre, var); + } + + se.expr = convert (dest_type, se.expr); + gfc_add_block_to_block (block, &se.pre); + + return p->mask; +} + + /* Generate code to store a non-string I/O parameter into the st_parameter_XXX structure. This is pass by reference. */ @@ -978,7 +1071,7 @@ gfc_trans_open (gfc_code * code) mask |= set_string (&block, &post_block, var, IOPARM_open_form, p->form); if (p->recl) - mask |= set_parameter_value (&block, p->iostat, var, IOPARM_open_recl_in, + mask |= set_parameter_value (&block, var, IOPARM_open_recl_in, p->recl); if (p->blank) @@ -1029,7 +1122,7 @@ gfc_trans_open (gfc_code * code) set_parameter_const (&block, var, IOPARM_common_flags, mask); if (p->unit) - set_parameter_value (&block, p->iostat, var, IOPARM_common_unit, p->unit); + set_parameter_value_chk (&block, p->iostat, var, IOPARM_common_unit, p->unit); else set_parameter_const (&block, var, IOPARM_common_unit, 0); @@ -1082,7 +1175,7 @@ gfc_trans_close (gfc_code * code) set_parameter_const (&block, var, IOPARM_common_flags, mask); if (p->unit) - set_parameter_value (&block, p->iostat, var, IOPARM_common_unit, p->unit); + set_parameter_value_chk (&block, p->iostat, var, IOPARM_common_unit, p->unit); else set_parameter_const (&block, var, IOPARM_common_unit, 0); @@ -1124,8 +1217,8 @@ build_filepos (tree function, gfc_code * code) p->iomsg); if (p->iostat) - mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat, - p->iostat); + mask |= set_parameter_ref (&block, &post_block, var, + IOPARM_common_iostat, p->iostat); if (p->err) mask |= IOPARM_common_err; @@ -1133,7 +1226,8 @@ build_filepos (tree function, gfc_code * code) set_parameter_const (&block, var, IOPARM_common_flags, mask); if (p->unit) - set_parameter_value (&block, p->iostat, var, IOPARM_common_unit, p->unit); + set_parameter_value_chk (&block, p->iostat, var, IOPARM_common_unit, + p->unit); else set_parameter_const (&block, var, IOPARM_common_unit, 0); @@ -1225,10 +1319,8 @@ gfc_trans_inquire (gfc_code * code) p->file); if (p->exist) - { - mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_exist, + mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_exist, p->exist); - } if (p->opened) mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_opened, @@ -1360,7 +1452,10 @@ gfc_trans_inquire (gfc_code * code) set_parameter_const (&block, var, IOPARM_common_flags, mask); if (p->unit) - set_parameter_value (&block, p->iostat, var, IOPARM_common_unit, p->unit); + { + set_parameter_value (&block, var, IOPARM_common_unit, p->unit); + set_parameter_value_inquire (&block, var, IOPARM_common_unit, p->unit); + } else set_parameter_const (&block, var, IOPARM_common_unit, 0); @@ -1407,12 +1502,12 @@ gfc_trans_wait (gfc_code * code) mask |= IOPARM_common_err; if (p->id) - mask |= set_parameter_value (&block, p->iostat, var, IOPARM_wait_id, p->id); + mask |= set_parameter_value (&block, var, IOPARM_wait_id, p->id); set_parameter_const (&block, var, IOPARM_common_flags, mask); if (p->unit) - set_parameter_value (&block, p->iostat, var, IOPARM_common_unit, p->unit); + set_parameter_value_chk (&block, p->iostat, var, IOPARM_common_unit, p->unit); tmp = gfc_build_addr_expr (NULL_TREE, var); tmp = build_call_expr_loc (input_location, @@ -1706,12 +1801,11 @@ build_dt (tree function, gfc_code * code) IOPARM_dt_id, dt->id); if (dt->pos) - mask |= set_parameter_value (&block, dt->iostat, var, IOPARM_dt_pos, - dt->pos); + mask |= set_parameter_value (&block, var, IOPARM_dt_pos, dt->pos); if (dt->asynchronous) - mask |= set_string (&block, &post_block, var, IOPARM_dt_asynchronous, - dt->asynchronous); + mask |= set_string (&block, &post_block, var, + IOPARM_dt_asynchronous, dt->asynchronous); if (dt->blank) mask |= set_string (&block, &post_block, var, IOPARM_dt_blank, @@ -1738,8 +1832,7 @@ build_dt (tree function, gfc_code * code) dt->sign); if (dt->rec) - mask |= set_parameter_value (&block, dt->iostat, var, IOPARM_dt_rec, - dt->rec); + mask |= set_parameter_value (&block, var, IOPARM_dt_rec, dt->rec); if (dt->advance) mask |= set_string (&block, &post_block, var, IOPARM_dt_advance, @@ -1791,8 +1884,8 @@ build_dt (tree function, gfc_code * code) set_parameter_const (&block, var, IOPARM_common_flags, mask); if (dt->io_unit && dt->io_unit->ts.type == BT_INTEGER) - set_parameter_value (&block, dt->iostat, var, IOPARM_common_unit, - dt->io_unit); + set_parameter_value_chk (&block, dt->iostat, var, + IOPARM_common_unit, dt->io_unit); } else set_parameter_const (&block, var, IOPARM_common_flags, mask); -- cgit v1.1