This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
Re: [patch, fortran] New fix: PR31201 Too large unit number generates wrong code
:REVIEWMAIL:
Here is the updated patch with comments incorporated.
Bootstrapped and regression tested on x86-64-Gnu/Linux. A test case will be
derived from the PR. (I have tested the heck out of it)
I will clean up the ChangeLog.
OK for mainline?
Regards,
Jerry
Index: gcc/fortran/gfortran.h
===================================================================
*** gcc/fortran/gfortran.h (revision 124094)
--- gcc/fortran/gfortran.h (working copy)
*************** enum gfc_generic_isym_id
*** 472,477 ****
--- 472,510 ----
};
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
+ {
+ ERROR_FIRST = -3, /* Marker for the first error. */
+ ERROR_EOR = -2,
+ ERROR_END = -1,
+ ERROR_OK = 0, /* Indicates success, must be zero. */
+ ERROR_OS = 5000, /* Operating system error, more info in errno. */
+ ERROR_OPTION_CONFLICT,
+ ERROR_BAD_OPTION,
+ ERROR_MISSING_OPTION,
+ ERROR_ALREADY_OPEN,
+ ERROR_BAD_UNIT,
+ ERROR_FORMAT,
+ ERROR_BAD_ACTION,
+ ERROR_ENDFILE,
+ ERROR_BAD_US,
+ ERROR_READ_VALUE,
+ ERROR_READ_OVERFLOW,
+ ERROR_INTERNAL,
+ ERROR_INTERNAL_UNIT,
+ ERROR_ALLOCATION,
+ ERROR_DIRECT_EOR,
+ ERROR_SHORT_RECORD,
+ ERROR_CORRUPT_FILE,
+ ERROR_LAST /* Not a real error, the last error # + 1. */
+ }
+ error_codes;
+
+
/************************* Structures *****************************/
/* Used for keeping things in balanced binary trees. */
Index: gcc/fortran/trans.c
===================================================================
*** gcc/fortran/trans.c (revision 124094)
--- gcc/fortran/trans.c (working copy)
*************** gfc_trans_runtime_check (tree cond, cons
*** 318,325 ****
stmtblock_t block;
tree body;
tree tmp;
! tree arg;
! char * message;
int line;
if (integer_zerop (cond))
--- 318,325 ----
stmtblock_t block;
tree body;
tree tmp;
! tree arg, arg2;
! char *message;
int line;
if (integer_zerop (cond))
*************** gfc_trans_runtime_check (tree cond, cons
*** 335,351 ****
#else
line = where->lb->linenum;
#endif
! asprintf (&message, "%s (in file '%s', at line %d)", _(msgid),
! where->lb->file->filename, line);
}
else
! asprintf (&message, "%s (in file '%s', around line %d)", _(msgid),
gfc_source_file, input_line + 1);
arg = 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);
gfc_add_expr_to_block (&block, tmp);
body = gfc_finish_block (&block);
--- 335,355 ----
#else
line = where->lb->linenum;
#endif
! asprintf (&message, "At line %d of file %s", line,
! where->lb->file->filename);
}
else
! 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_at, 2, arg, arg2);
gfc_add_expr_to_block (&block, tmp);
body = gfc_finish_block (&block);
Index: gcc/fortran/trans.h
===================================================================
*** gcc/fortran/trans.h (revision 124094)
--- gcc/fortran/trans.h (working copy)
*************** tree gfc_trans_pointer_assignment (gfc_e
*** 448,453 ****
--- 448,454 ----
/* 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, ...);
*************** extern GTY(()) tree gfor_fndecl_stop_num
*** 487,492 ****
--- 488,495 ----
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;
Index: gcc/fortran/trans-decl.c
===================================================================
*** gcc/fortran/trans-decl.c (revision 124094)
--- gcc/fortran/trans-decl.c (working copy)
*************** tree gfor_fndecl_stop_numeric;
*** 90,95 ****
--- 90,97 ----
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;
*************** gfc_build_builtin_function_decls (void)
*** 2335,2340 ****
--- 2337,2354 ----
/* 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, gfc_int4_type_node,
+ pvoid_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);
Index: gcc/fortran/trans-io.c
===================================================================
*** gcc/fortran/trans-io.c (revision 124094)
--- gcc/fortran/trans-io.c (working copy)
*************** gfc_build_st_parameter (enum ioparam_typ
*** 212,217 ****
--- 212,273 ----
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
*************** set_parameter_value (stmtblock_t *block,
*** 396,411 ****
gfc_se se;
tree tmp;
gfc_st_parameter_field *p = &st_parameter_field[type];
gfc_init_se (&se, NULL);
! gfc_conv_expr_type (&se, e, TREE_TYPE (p->field));
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);
gfc_add_modify_expr (block, tmp, se.expr);
return p->mask;
}
--- 452,499 ----
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);
!
! /* If we're storing a UNIT number, we need to check it first. */
! if (type == IOPARM_common_unit && e->ts.kind != 4)
! {
! int i;
! tree cond, max;
! error_codes bad_unit;
! bad_unit = ERROR_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);
! /* Get the maximum possible integer for KIND=4. */
! i = gfc_validate_kind (BT_INTEGER, 4, false);
! max = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, 4);
!
! /* UNIT numbers should be less than the max. */
! cond = fold_build2 (GT_EXPR, boolean_type_node, 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, dest_type, var, p->field, NULL_TREE);
gfc_add_modify_expr (block, tmp, se.expr);
return p->mask;
}
*************** gfc_trans_open (gfc_code * code)
*** 776,785 ****
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->file)
mask |= set_string (&block, &post_block, var, IOPARM_open_file, p->file);
--- 864,879 ----
set_error_locus (&block, var, &code->loc);
p = code->ext.open;
! 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);
*************** gfc_trans_open (gfc_code * code)
*** 817,839 ****
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);
tmp = build_fold_addr_expr (var);
tmp = build_call_expr (iocall[IOCALL_OPEN], 1, tmp);
gfc_add_expr_to_block (&block, tmp);
--- 911,927 ----
if (p->pad)
mask |= set_string (&block, &post_block, var, IOPARM_open_pad, p->pad);
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);
*************** gfc_trans_close (gfc_code * code)
*** 864,878 ****
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);
--- 952,957 ----
*************** gfc_trans_close (gfc_code * code)
*** 884,891 ****
--- 963,979 ----
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);
*************** build_filepos (tree function, gfc_code *
*** 918,928 ****
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);
--- 1006,1011 ----
*************** build_filepos (tree function, gfc_code *
*** 936,941 ****
--- 1019,1029 ----
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);
*************** gfc_trans_inquire (gfc_code * code)
*** 1003,1021 ****
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);
--- 1091,1096 ----
*************** gfc_trans_inquire (gfc_code * code)
*** 1024,1029 ****
--- 1099,1115 ----
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);
*************** gfc_trans_inquire (gfc_code * code)
*** 1108,1116 ****
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);
--- 1194,1199 ----
*************** gfc_trans_inquire (gfc_code * code)
*** 1121,1126 ****
--- 1204,1214 ----
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);
*************** build_dt (tree function, gfc_code * code
*** 1419,1432 ****
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->rec)
mask |= set_parameter_value (&block, var, IOPARM_dt_rec, dt->rec);
--- 1507,1535 ----
var, dt->io_unit);
set_parameter_const (&block, var, IOPARM_common_unit, 0);
}
}
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);
*************** build_dt (tree function, gfc_code * code
*** 1447,1473 ****
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)
--- 1550,1559 ----
*************** build_dt (tree function, gfc_code * code
*** 1491,1496 ****
--- 1577,1585 ----
}
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);
Index: libgfortran/runtime/error.c
===================================================================
*** libgfortran/runtime/error.c (revision 124094)
--- libgfortran/runtime/error.c (working copy)
*************** runtime_error (const char *message)
*** 299,304 ****
--- 299,317 ----
}
iexport(runtime_error);
+ /* void runtime_error_at()-- These are errors associated with a
+ * run time error generated by the front end compiler. */
+
+ void
+ runtime_error_at (const char *where, const char *message)
+ {
+ recursion_check ();
+ st_printf ("%s\n", where);
+ st_printf ("Fortran runtime error: %s\n", message);
+ sys_exit (2);
+ }
+ iexport(runtime_error_at);
+
/* void internal_error()-- These are this-can't-happen errors
* that indicate something deeply wrong. */
*************** generate_error (st_parameter_common *cmp
*** 475,481 ****
st_printf ("Fortran runtime error: %s\n", message);
sys_exit (2);
}
!
/* Whether, for a feature included in a given standard set (GFC_STD_*),
we should issue an error or a warning, or be quiet. */
--- 488,494 ----
st_printf ("Fortran runtime error: %s\n", message);
sys_exit (2);
}
! iexport(generate_error);
/* Whether, for a feature included in a given standard set (GFC_STD_*),
we should issue an error or a warning, or be quiet. */
Index: libgfortran/libgfortran.h
===================================================================
*** libgfortran/libgfortran.h (revision 124094)
--- libgfortran/libgfortran.h (working copy)
*************** typedef struct
*** 401,407 ****
}
st_option;
! /* Runtime errors. The EOR and EOF errors are required to be negative. */
typedef enum
{
--- 401,409 ----
}
st_option;
! /* Runtime errors. The EOR and EOF errors are required to be negative.
! These codes must be kept sychronized with their equivalents in
! gcc/fortran/gfortran.h . */
typedef enum
{
*************** internal_proto(show_locus);
*** 587,592 ****
--- 589,598 ----
extern void runtime_error (const char *) __attribute__ ((noreturn));
iexport_proto(runtime_error);
+ extern void runtime_error_at (const char *, const char *)
+ __attribute__ ((noreturn));
+ iexport_proto(runtime_error_at);
+
extern void internal_error (st_parameter_common *, const char *)
__attribute__ ((noreturn));
internal_proto(internal_error);
*************** extern const char *translate_error (int)
*** 602,608 ****
internal_proto(translate_error);
extern void generate_error (st_parameter_common *, int, const char *);
! internal_proto(generate_error);
extern try notify_std (st_parameter_common *, int, const char *);
internal_proto(notify_std);
--- 608,614 ----
internal_proto(translate_error);
extern void generate_error (st_parameter_common *, int, const char *);
! iexport_proto(generate_error);
extern try notify_std (st_parameter_common *, int, const char *);
internal_proto(notify_std);