From f96d606f3a2b4cb25486d8c7dac01be2d4963e00 Mon Sep 17 00:00:00 2001 From: Jerry DeLisle Date: Sun, 6 May 2007 22:32:33 +0000 Subject: [PATCH] re PR fortran/31201 (Too large unit number generates wrong code) 2007-05-06 Jerry DeLisle Francois-Xavier Coudert PR fortran/31201 * gfortran.h: Add runtime error codes from libgfortran.h. Define MAX_UNIT_NUMBER. * trans.c (gfc_trans_runtime_check): Update the format of runtime error messages to match library runtime errors. Use call to new library function runtime_error_at(). * trans.h: Add prototype for new function gfc_trans_io_runtime_check. Add declaration for library functions runtime_error_at and generate_error. * trans_io.c (gfc_trans_io_runtime_check): New function. (set_parameter_value): Add error checking for UNIT numbers. (set_parameter_ref): Initialize the users variable to zero. (gfc_trans_open): Move setting of unit number to after setting of common flags so that runtime error trapping can be detected. (gfc_trans_close): Likewise. (build_filepos): Likewise. (gfc_trans_inquire): Likewise. (build_dt): Likewise. * trans-decl.c: Add declarations for runtime_error_at and generate_error. (gfc_build_builtin_function_decls): Build function declarations for runtime_error_at and generate_error. Co-Authored-By: Francois-Xavier Coudert From-SVN: r124480 --- gcc/fortran/ChangeLog | 23 +++++ gcc/fortran/gfortran.h | 33 ++++++ gcc/fortran/trans-decl.c | 14 +++ gcc/fortran/trans-io.c | 262 +++++++++++++++++++++++++++++++++-------------- gcc/fortran/trans.c | 16 +-- gcc/fortran/trans.h | 3 + 6 files changed, 270 insertions(+), 81 deletions(-) diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 361ffcc..8d15bf2 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,26 @@ +2007-05-06 Jerry DeLisle + Francois-Xavier Coudert + + PR fortran/31201 + * gfortran.h: Add runtime error codes from libgfortran.h. Define + MAX_UNIT_NUMBER. + * trans.c (gfc_trans_runtime_check): Update the format of runtime error + messages to match library runtime errors. Use call to new library + function runtime_error_at(). + * trans.h: Add prototype for new function gfc_trans_io_runtime_check. + Add declaration for library functions runtime_error_at and + generate_error. + * trans_io.c (gfc_trans_io_runtime_check): New function. + (set_parameter_value): Add error checking for UNIT numbers. + (set_parameter_ref): Initialize the users variable to zero. + (gfc_trans_open): Move setting of unit number to after setting of common + flags so that runtime error trapping can be detected. + (gfc_trans_close): Likewise. (build_filepos): Likewise. + (gfc_trans_inquire): Likewise. (build_dt): Likewise. + * trans-decl.c: Add declarations for runtime_error_at and + generate_error. (gfc_build_builtin_function_decls): Build function + declarations for runtime_error_at and generate_error. + 2007-05-06 Paul Thomas PR fortran/31540 diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 039c1ee..df0896d 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -472,6 +472,39 @@ enum gfc_generic_isym_id }; typedef enum gfc_generic_isym_id gfc_generic_isym_id; +/* Runtime errors. The EOR and EOF errors are required to be negative. + These codes must be kept synchronized with their equivalents in + libgfortran/libgfortran.h . */ + +typedef enum +{ + IOERROR_FIRST = -3, /* Marker for the first error. */ + IOERROR_EOR = -2, + IOERROR_END = -1, + IOERROR_OK = 0, /* Indicates success, must be zero. */ + IOERROR_OS = 5000, /* Operating system error, more info in errno. */ + IOERROR_OPTION_CONFLICT, + IOERROR_BAD_OPTION, + IOERROR_MISSING_OPTION, + IOERROR_ALREADY_OPEN, + IOERROR_BAD_UNIT, + IOERROR_FORMAT, + IOERROR_BAD_ACTION, + IOERROR_ENDFILE, + IOERROR_BAD_US, + IOERROR_READ_VALUE, + IOERROR_READ_OVERFLOW, + IOERROR_INTERNAL, + IOERROR_INTERNAL_UNIT, + IOERROR_ALLOCATION, + IOERROR_DIRECT_EOR, + IOERROR_SHORT_RECORD, + IOERROR_CORRUPT_FILE, + IOERROR_LAST /* Not a real error, the last error # + 1. */ +} +ioerror_codes; + + /************************* Structures *****************************/ /* Used for keeping things in balanced binary trees. */ diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index ccf4685..835e515 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -90,6 +90,8 @@ tree gfor_fndecl_stop_numeric; tree gfor_fndecl_stop_string; tree gfor_fndecl_select_string; tree gfor_fndecl_runtime_error; +tree gfor_fndecl_runtime_error_at; +tree gfor_fndecl_generate_error; tree gfor_fndecl_set_fpe; tree gfor_fndecl_set_std; tree gfor_fndecl_set_convert; @@ -2335,6 +2337,18 @@ gfc_build_builtin_function_decls (void) /* The runtime_error function does not return. */ TREE_THIS_VOLATILE (gfor_fndecl_runtime_error) = 1; + gfor_fndecl_runtime_error_at = + gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error_at")), + void_type_node, 2, pchar_type_node, + pchar_type_node); + /* The runtime_error_at function does not return. */ + TREE_THIS_VOLATILE (gfor_fndecl_runtime_error_at) = 1; + + gfor_fndecl_generate_error = + gfc_build_library_function_decl (get_identifier (PREFIX("generate_error")), + void_type_node, 3, pvoid_type_node, + gfc_c_int_type_node, pchar_type_node); + gfor_fndecl_set_fpe = gfc_build_library_function_decl (get_identifier (PREFIX("set_fpe")), void_type_node, 1, gfc_c_int_type_node); diff --git a/gcc/fortran/trans-io.c b/gcc/fortran/trans-io.c index 856938c..4b87bcb 100644 --- a/gcc/fortran/trans-io.c +++ b/gcc/fortran/trans-io.c @@ -212,6 +212,62 @@ gfc_build_st_parameter (enum ioparam_type ptype, tree *types) st_parameter[ptype].type = t; } + +/* Build code to test an error condition and call generate_error if needed. + Note: This builds calls to generate_error in the runtime library function. + The function generate_error is dependent on certain parameters in the + st_parameter_common flags to be set. (See libgfortran/runtime/error.c) + Therefore, the code to set these flags must be generated before + this function is used. */ + +void +gfc_trans_io_runtime_check (tree cond, tree var, int error_code, + const char * msgid, stmtblock_t * pblock) +{ + stmtblock_t block; + tree body; + tree tmp; + tree arg1, arg2, arg3; + char *message; + + if (integer_zerop (cond)) + return; + + /* The code to generate the error. */ + gfc_start_block (&block); + + arg1 = build_fold_addr_expr (var); + + arg2 = build_int_cst (integer_type_node, error_code), + + asprintf (&message, "%s", _(msgid)); + arg3 = gfc_build_addr_expr (pchar_type_node, gfc_build_cstring_const(message)); + gfc_free(message); + + tmp = build_call_expr (gfor_fndecl_generate_error, 3, arg1, arg2, arg3); + + gfc_add_expr_to_block (&block, tmp); + + body = gfc_finish_block (&block); + + if (integer_onep (cond)) + { + gfc_add_expr_to_block (pblock, body); + } + else + { + /* Tell the compiler that this isn't likely. */ + cond = fold_convert (long_integer_type_node, cond); + tmp = build_int_cst (long_integer_type_node, 0); + cond = build_call_expr (built_in_decls[BUILT_IN_EXPECT], 2, cond, tmp); + cond = fold_convert (boolean_type_node, cond); + + tmp = build3_v (COND_EXPR, cond, body, build_empty_stmt ()); + gfc_add_expr_to_block (pblock, tmp); + } +} + + /* Create function decls for IO library functions. */ void @@ -396,16 +452,49 @@ set_parameter_value (stmtblock_t *block, tree var, enum iofield type, 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_type (&se, e, TREE_TYPE (p->field)); + gfc_conv_expr_val (&se, e); + + /* If we're storing a UNIT number, we need to check it first. */ + if (type == IOPARM_common_unit && e->ts.kind != 4) + { + tree cond, max; + ioerror_codes bad_unit; + int i; + + bad_unit = IOERROR_BAD_UNIT; + + /* Don't evaluate the UNIT number multiple times. */ + se.expr = gfc_evaluate_now (se.expr, &se.pre); + + /* UNIT numbers should be nonnegative. */ + cond = fold_build2 (LT_EXPR, boolean_type_node, se.expr, + build_int_cst (TREE_TYPE (se.expr),0)); + gfc_trans_io_runtime_check (cond, var, bad_unit, + "Negative unit number in I/O statement", + &se.pre); + + /* UNIT numbers should be less than the max. */ + i = gfc_validate_kind (BT_INTEGER, 4, false); + max = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, 4); + cond = fold_build2 (GT_EXPR, boolean_type_node, se.expr, + fold_convert (TREE_TYPE (se.expr), max)); + gfc_trans_io_runtime_check (cond, var, bad_unit, + "Unit number in I/O statement too large", + &se.pre); + + } + + se.expr = convert (dest_type, se.expr); gfc_add_block_to_block (block, &se.pre); if (p->param_type == IOPARM_ptype_common) var = build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type, var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE); - tmp = build3 (COMPONENT_REF, TREE_TYPE (p->field), var, p->field, - NULL_TREE); + + tmp = build3 (COMPONENT_REF, dest_type, var, p->field, NULL_TREE); gfc_add_modify_expr (block, tmp, se.expr); return p->mask; } @@ -430,20 +519,42 @@ set_parameter_ref (stmtblock_t *block, stmtblock_t *postblock, if (TYPE_MODE (TREE_TYPE (se.expr)) == TYPE_MODE (TREE_TYPE (TREE_TYPE (p->field)))) - addr = convert (TREE_TYPE (p->field), - build_fold_addr_expr (se.expr)); + { + addr = convert (TREE_TYPE (p->field), build_fold_addr_expr (se.expr)); + + /* If this is for the iostat variable initialize the + user variable to IOERROR_OK which is zero. */ + if (type == IOPARM_common_iostat) + { + ioerror_codes ok; + ok = IOERROR_OK; + gfc_add_modify_expr (block, se.expr, + build_int_cst (TREE_TYPE (se.expr), ok)); + } + } else { /* The type used by the library has different size - from the type of the variable supplied by the user. - Need to use a temporary. */ - tree tmpvar - = gfc_create_var (TREE_TYPE (TREE_TYPE (p->field)), - st_parameter_field[type].name); + from the type of the variable supplied by the user. + Need to use a temporary. */ + tree tmpvar = gfc_create_var (TREE_TYPE (TREE_TYPE (p->field)), + st_parameter_field[type].name); + + /* If this is for the iostat variable, initialize the + user variable to IOERROR_OK which is zero. */ + if (type == IOPARM_common_iostat) + { + ioerror_codes ok; + ok = IOERROR_OK; + gfc_add_modify_expr (block, tmpvar, + build_int_cst (TREE_TYPE (tmpvar), ok)); + } + addr = build_fold_addr_expr (tmpvar); + /* After the I/O operation, we set the variable from the temporary. */ tmp = convert (TREE_TYPE (se.expr), tmpvar); gfc_add_modify_expr (postblock, se.expr, tmp); - } + } if (p->param_type == IOPARM_ptype_common) var = build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type, @@ -776,10 +887,16 @@ gfc_trans_open (gfc_code * code) set_error_locus (&block, var, &code->loc); p = code->ext.open; - if (p->unit) - set_parameter_value (&block, var, IOPARM_common_unit, p->unit); - else - set_parameter_const (&block, var, IOPARM_common_unit, 0); + if (p->iomsg) + mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg, + p->iomsg); + + if (p->iostat) + mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat, + p->iostat); + + if (p->err) + mask |= IOPARM_common_err; if (p->file) mask |= set_string (&block, &post_block, var, IOPARM_open_file, p->file); @@ -817,23 +934,17 @@ gfc_trans_open (gfc_code * code) if (p->pad) mask |= set_string (&block, &post_block, var, IOPARM_open_pad, p->pad); - if (p->iomsg) - mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg, - p->iomsg); - - if (p->iostat) - mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat, - p->iostat); - - if (p->err) - mask |= IOPARM_common_err; - if (p->convert) mask |= set_string (&block, &post_block, var, IOPARM_open_convert, p->convert); set_parameter_const (&block, var, IOPARM_common_flags, mask); + if (p->unit) + set_parameter_value (&block, var, IOPARM_common_unit, p->unit); + else + set_parameter_const (&block, var, IOPARM_common_unit, 0); + tmp = build_fold_addr_expr (var); tmp = build_call_expr (iocall[IOCALL_OPEN], 1, tmp); gfc_add_expr_to_block (&block, tmp); @@ -864,15 +975,6 @@ gfc_trans_close (gfc_code * code) set_error_locus (&block, var, &code->loc); p = code->ext.close; - if (p->unit) - set_parameter_value (&block, var, IOPARM_common_unit, p->unit); - else - set_parameter_const (&block, var, IOPARM_common_unit, 0); - - if (p->status) - mask |= set_string (&block, &post_block, var, IOPARM_close_status, - p->status); - if (p->iomsg) mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg, p->iomsg); @@ -884,8 +986,17 @@ gfc_trans_close (gfc_code * code) if (p->err) mask |= IOPARM_common_err; + if (p->status) + mask |= set_string (&block, &post_block, var, IOPARM_close_status, + p->status); + set_parameter_const (&block, var, IOPARM_common_flags, mask); + if (p->unit) + set_parameter_value (&block, var, IOPARM_common_unit, p->unit); + else + set_parameter_const (&block, var, IOPARM_common_unit, 0); + tmp = build_fold_addr_expr (var); tmp = build_call_expr (iocall[IOCALL_CLOSE], 1, tmp); gfc_add_expr_to_block (&block, tmp); @@ -918,11 +1029,6 @@ build_filepos (tree function, gfc_code * code) set_error_locus (&block, var, &code->loc); - if (p->unit) - set_parameter_value (&block, var, IOPARM_common_unit, p->unit); - else - set_parameter_const (&block, var, IOPARM_common_unit, 0); - if (p->iomsg) mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg, p->iomsg); @@ -936,6 +1042,11 @@ build_filepos (tree function, gfc_code * code) set_parameter_const (&block, var, IOPARM_common_flags, mask); + if (p->unit) + set_parameter_value (&block, var, IOPARM_common_unit, p->unit); + else + set_parameter_const (&block, var, IOPARM_common_unit, 0); + tmp = build_fold_addr_expr (var); tmp = build_call_expr (function, 1, tmp); gfc_add_expr_to_block (&block, tmp); @@ -1003,19 +1114,6 @@ gfc_trans_inquire (gfc_code * code) set_error_locus (&block, var, &code->loc); p = code->ext.inquire; - /* Sanity check. */ - if (p->unit && p->file) - gfc_error ("INQUIRE statement at %L cannot contain both FILE and UNIT specifiers", &code->loc); - - if (p->unit) - set_parameter_value (&block, var, IOPARM_common_unit, p->unit); - else - set_parameter_const (&block, var, IOPARM_common_unit, 0); - - if (p->file) - mask |= set_string (&block, &post_block, var, IOPARM_inquire_file, - p->file); - if (p->iomsg) mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg, p->iomsg); @@ -1024,6 +1122,17 @@ gfc_trans_inquire (gfc_code * code) mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat, p->iostat); + if (p->err) + mask |= IOPARM_common_err; + + /* Sanity check. */ + if (p->unit && p->file) + gfc_error ("INQUIRE statement at %L cannot contain both FILE and UNIT specifiers", &code->loc); + + if (p->file) + mask |= set_string (&block, &post_block, var, IOPARM_inquire_file, + p->file); + if (p->exist) mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_exist, p->exist); @@ -1108,9 +1217,6 @@ gfc_trans_inquire (gfc_code * code) mask |= set_string (&block, &post_block, var, IOPARM_inquire_pad, p->pad); - if (p->err) - mask |= IOPARM_common_err; - if (p->convert) mask |= set_string (&block, &post_block, var, IOPARM_inquire_convert, p->convert); @@ -1121,6 +1227,11 @@ gfc_trans_inquire (gfc_code * code) set_parameter_const (&block, var, IOPARM_common_flags, mask); + if (p->unit) + set_parameter_value (&block, var, IOPARM_common_unit, p->unit); + else + set_parameter_const (&block, var, IOPARM_common_unit, 0); + tmp = build_fold_addr_expr (var); tmp = build_call_expr (iocall[IOCALL_INQUIRE], 1, tmp); gfc_add_expr_to_block (&block, tmp); @@ -1419,14 +1530,29 @@ build_dt (tree function, gfc_code * code) var, dt->io_unit); set_parameter_const (&block, var, IOPARM_common_unit, 0); } - else - set_parameter_value (&block, var, IOPARM_common_unit, dt->io_unit); } else set_parameter_const (&block, var, IOPARM_common_unit, 0); if (dt) { + if (dt->iomsg) + mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg, + dt->iomsg); + + if (dt->iostat) + mask |= set_parameter_ref (&block, &post_end_block, var, + IOPARM_common_iostat, dt->iostat); + + if (dt->err) + mask |= IOPARM_common_err; + + if (dt->eor) + mask |= IOPARM_common_eor; + + if (dt->end) + mask |= IOPARM_common_end; + if (dt->rec) mask |= set_parameter_value (&block, var, IOPARM_dt_rec, dt->rec); @@ -1447,27 +1573,10 @@ build_dt (tree function, gfc_code * code) dt->format_label->format); } - if (dt->iomsg) - mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg, - dt->iomsg); - - if (dt->iostat) - mask |= set_parameter_ref (&block, &post_end_block, var, - IOPARM_common_iostat, dt->iostat); - if (dt->size) mask |= set_parameter_ref (&block, &post_end_block, var, IOPARM_dt_size, dt->size); - if (dt->err) - mask |= IOPARM_common_err; - - if (dt->eor) - mask |= IOPARM_common_eor; - - if (dt->end) - mask |= IOPARM_common_end; - if (dt->namelist) { if (dt->format_expr || dt->format_label) @@ -1491,6 +1600,9 @@ build_dt (tree function, gfc_code * code) } else set_parameter_const (&block, var, IOPARM_common_flags, mask); + + if (dt->io_unit && dt->io_unit->ts.type == BT_INTEGER) + set_parameter_value (&block, var, IOPARM_common_unit, dt->io_unit); } else set_parameter_const (&block, var, IOPARM_common_flags, mask); diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c index 64dbb73..5e717e4 100644 --- a/gcc/fortran/trans.c +++ b/gcc/fortran/trans.c @@ -318,8 +318,8 @@ gfc_trans_runtime_check (tree cond, const char * msgid, stmtblock_t * pblock, stmtblock_t block; tree body; tree tmp; - tree arg; - char * message; + tree arg, arg2; + char *message; int line; if (integer_zerop (cond)) @@ -335,17 +335,21 @@ gfc_trans_runtime_check (tree cond, const char * msgid, stmtblock_t * pblock, #else line = where->lb->linenum; #endif - asprintf (&message, "%s (in file '%s', at line %d)", _(msgid), - where->lb->file->filename, line); + asprintf (&message, "At line %d of file %s", line, + where->lb->file->filename); } else - asprintf (&message, "%s (in file '%s', around line %d)", _(msgid), + asprintf (&message, "In file '%s', around line %d", gfc_source_file, input_line + 1); arg = gfc_build_addr_expr (pchar_type_node, gfc_build_cstring_const(message)); gfc_free(message); + + asprintf (&message, "%s", _(msgid)); + arg2 = gfc_build_addr_expr (pchar_type_node, gfc_build_cstring_const(message)); + gfc_free(message); - tmp = build_call_expr (gfor_fndecl_runtime_error, 1, arg); + tmp = build_call_expr (gfor_fndecl_runtime_error_at, 2, arg, arg2); gfc_add_expr_to_block (&block, tmp); body = gfc_finish_block (&block); diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 7ca3966..731045a 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -448,6 +448,7 @@ tree gfc_trans_pointer_assignment (gfc_expr *, gfc_expr *); /* Initialize function decls for library functions. */ void gfc_build_intrinsic_lib_fndecls (void); /* Create function decls for IO library functions. */ +void gfc_trans_io_runtime_check (tree, tree, int, const char *, stmtblock_t *); void gfc_build_io_library_fndecls (void); /* Build a function decl for a library function. */ tree gfc_build_library_function_decl (tree, tree, int, ...); @@ -487,6 +488,8 @@ extern GTY(()) tree gfor_fndecl_stop_numeric; extern GTY(()) tree gfor_fndecl_stop_string; extern GTY(()) tree gfor_fndecl_select_string; extern GTY(()) tree gfor_fndecl_runtime_error; +extern GTY(()) tree gfor_fndecl_runtime_error_at; +extern GTY(()) tree gfor_fndecl_generate_error; extern GTY(()) tree gfor_fndecl_set_fpe; extern GTY(()) tree gfor_fndecl_set_std; extern GTY(()) tree gfor_fndecl_ttynam; -- 2.7.4