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:
Thanks to FX for coming up with the last tweak on this patch. (double thanks!)
We now initialize the user variable passed with IOSTAT=uservar in I/O
statements. This allows deleting that initialization from the library_start
function so that it does not overwrite what we are doing with earlier error checks.
This allowed library_start to be converted to a macro as well for efficiency and
I added a comment to note that it can be changed to a function later if more
needs to be done with it. I put library_end with library_start for
maintainability. Currently, library_end expands to nothing.
I tested this with the two attached cases. I will dejagnuize these before I commit.
Fully regression tested on X86-64-Gnu/Linux.
OK for trunk?
Jerry
PS
(Note: We initialize to zero. ERROR_OK must be zero all the time. I could go
ahead and change the zero to IOERROR_OK so we track the enumeration closely.)
2007-04-29 Jerry DeLisle <jvdelisle@gcc.gnu.org>
Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
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-04-29 Jerry DeLisle <jvdelisle@gcc.gnu.org>
PR libfortran/31201
* runtime/error.c (runtime_error_at): New function.
(generate_error): Export this function.
* gfortran.map: Add _gfortran_generate_error and
_gfortran_runtime_error_at.
* libgfortran.h: Add comment to reference error codes in front end.
(library_start): Convert to macro. Group with library_end macro with
a new comment. Add prototype for runtime_error_at. Export prototype for
generate_error.
* io/lock.c (library_start): Delete function, replaced by macro.
Index: gcc/testsuite/gfortran.dg/bounds_check_fail_1.f90
===================================================================
*** gcc/testsuite/gfortran.dg/bounds_check_fail_1.f90 (revision 124261)
--- gcc/testsuite/gfortran.dg/bounds_check_fail_1.f90 (working copy)
***************
*** 4,7 ****
integer x(1)
x(2) = x(1) ! { dg-warning "out of bounds" }
end
! ! { dg-output "out of bounds for array 'x', upper bound of dimension 1 exceeded.*at line 5" }
--- 4,7 ----
integer x(1)
x(2) = x(1) ! { dg-warning "out of bounds" }
end
! ! { dg-output "out of bounds for array 'x', upper bound of dimension 1 exceeded." }
Index: gcc/fortran/gfortran.h
===================================================================
*** gcc/fortran/gfortran.h (revision 124261)
--- gcc/fortran/gfortran.h (working copy)
*************** char *alloca ();
*** 60,65 ****
--- 60,66 ----
#define GFC_LETTERS 26 /* Number of letters in the alphabet. */
#define MAX_SUBRECORD_LENGTH 2147483639 /* 2**31-9 */
+ #define MAX_UNIT_NUMBER 2147483647 /* 2**31-1 */
#define free(x) Use_gfc_free_instead_of_free()
*************** enum gfc_generic_isym_id
*** 472,477 ****
--- 473,511 ----
};
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. */
Index: gcc/fortran/trans.c
===================================================================
*** gcc/fortran/trans.c (revision 124261)
--- 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 124261)
--- 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-io.c
===================================================================
*** gcc/fortran/trans-io.c (revision 124261)
--- 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,496 ----
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)
! {
! tree cond;
! ioerror_codes bad_unit;
! 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. */
! cond = fold_build2 (GT_EXPR, boolean_type_node, se.expr,
! build_int_cst (TREE_TYPE (se.expr),MAX_UNIT_NUMBER));
! 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;
}
*************** set_parameter_ref (stmtblock_t *block, s
*** 430,449 ****
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));
! 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);
! addr = build_fold_addr_expr (tmpvar);
! 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,
--- 515,539 ----
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));
! gfc_add_modify_expr (block, se.expr,
! build_int_cst (TREE_TYPE (se.expr), 0));
! }
! 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);
! gfc_add_modify_expr (block, tmpvar,
! build_int_cst (TREE_TYPE (tmpvar), 0));
! 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,
*************** 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);
--- 866,881 ----
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);
--- 913,929 ----
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);
--- 954,959 ----
*************** gfc_trans_close (gfc_code * code)
*** 884,891 ****
--- 965,981 ----
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);
--- 1008,1013 ----
*************** build_filepos (tree function, gfc_code *
*** 936,941 ****
--- 1021,1031 ----
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);
--- 1093,1098 ----
*************** gfc_trans_inquire (gfc_code * code)
*** 1024,1029 ****
--- 1101,1117 ----
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);
--- 1196,1201 ----
*************** gfc_trans_inquire (gfc_code * code)
*** 1121,1126 ****
--- 1206,1216 ----
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);
--- 1509,1537 ----
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)
--- 1552,1561 ----
*************** build_dt (tree function, gfc_code * code
*** 1491,1496 ****
--- 1579,1587 ----
}
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: gcc/fortran/trans-decl.c
===================================================================
*** gcc/fortran/trans-decl.c (revision 124261)
--- 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, 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);
Index: libgfortran/runtime/error.c
===================================================================
*** libgfortran/runtime/error.c (revision 124261)
--- 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/gfortran.map
===================================================================
*** libgfortran/gfortran.map (revision 124261)
--- libgfortran/gfortran.map (working copy)
*************** GFORTRAN_1.0 {
*** 137,142 ****
--- 137,143 ----
_gfortran_ftell_i2_sub;
_gfortran_ftell_i4_sub;
_gfortran_ftell_i8_sub;
+ _gfortran_generate_error;
_gfortran_gerror;
_gfortran_getarg_i4;
_gfortran_getarg_i8;
*************** GFORTRAN_1.0 {
*** 581,586 ****
--- 582,588 ----
_gfortran_rrspacing_r4;
_gfortran_rrspacing_r8;
_gfortran_runtime_error;
+ _gfortran_runtime_error_at;
_gfortran_secnds;
_gfortran_second;
_gfortran_second_sub;
Index: libgfortran/libgfortran.h
===================================================================
*** libgfortran/libgfortran.h (revision 124261)
--- 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
{
*************** st_parameter_common;
*** 534,550 ****
#define IOPARM_OPEN_HAS_PAD (1 << 16)
#define IOPARM_OPEN_HAS_CONVERT (1 << 17)
/* main.c */
extern void stupid_function_name_for_static_linking (void);
internal_proto(stupid_function_name_for_static_linking);
- extern void library_start (st_parameter_common *);
- internal_proto(library_start);
-
- #define library_end()
-
extern void set_args (int, char **);
export_proto(set_args);
--- 536,552 ----
#define IOPARM_OPEN_HAS_PAD (1 << 16)
#define IOPARM_OPEN_HAS_CONVERT (1 << 17)
+ /* library start and end macros. These can be expanded to functions if needed
+ in the future. cmp is st_parameter_common *cmp */
+
+ #define library_start(cmp) ((cmp)->flags &= ~IOPARM_LIBRETURN_MASK)
+ #define library_end()
/* main.c */
extern void stupid_function_name_for_static_linking (void);
internal_proto(stupid_function_name_for_static_linking);
extern void set_args (int, char **);
export_proto(set_args);
*************** 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);
Index: libgfortran/io/lock.c
===================================================================
*** libgfortran/io/lock.c (revision 124261)
--- libgfortran/io/lock.c (working copy)
*************** Boston, MA 02110-1301, USA. */
*** 33,50 ****
#include "libgfortran.h"
#include "io.h"
- /* library_start()-- Called with a library call is entered. */
-
- void
- library_start (st_parameter_common *cmp)
- {
- if ((cmp->flags & IOPARM_HAS_IOSTAT) != 0)
- *cmp->iostat = ERROR_OK;
-
- cmp->flags &= ~IOPARM_LIBRETURN_MASK;
- }
-
-
void
free_ionml (st_parameter_dt *dtp)
{
--- 33,38 ----
integer :: i
character(len=50) :: str
print *, int(2_8*int(huge(0_4),kind=8)+9_8,kind=4)
write (2_8*int(huge(0_4),kind=8)+9_8, iostat=i, iomsg=str) 555
print *, str, i
end
integer*8 :: k= 2_8**36 + 10
integer*4 :: j= 10
logical ex,op
INQUIRE(unit=k, exist=ex,opened=op)
print *, ex, op
IF (ex) THEN
OPEN(unit=k)
INQUIRE(unit=j, opened=op)
IF (op) CALL ABORT()
ENDIF
close(k)
end