re PR fortran/31201 (Too large unit number generates wrong code)
2007-05-06 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. Co-Authored-By: Francois-Xavier Coudert <fxcoudert@gcc.gnu.org> From-SVN: r124480
This commit is contained in:
Jerry DeLisle
parent
cb13c28858
commit
f96d606f3a
|
|
@ -1,3 +1,26 @@
|
|||
2007-05-06 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-05-06 Paul Thomas <pault@gcc.gnu.org>
|
||||
|
||||
PR fortran/31540
|
||||
|
|
|
|||
|
|
@ -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. */
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
|
|
|||
Loading…
Reference in New Issue