I reopened this PR to do some cleanup and to address a use case presented by
Joost in comment #7 of the subject PR.
The fundamental problem: if the variable containing the unit number in an
INQUIRE statement is of type KIND greater than 4 and the value is outside the
range of a KIND=4 we cannot test for it within the run-time library. Unit
numbers are passed to the run-time in the IOPARM structures as a KIND=4. KIND=8
are cast into the KIND=4. The test case gfortran.dg/negative_unit_int8.f
illustrates a case where a bogus unit number can get passed to the library.
To resolve this previously we built range checks in trans_io.c
(set_parameter_value) that tests the unit numbers and issues an error call to
the run-time library. This is fine for all statements except INQUIRE which
should not give an error. However, we do want to identify such an out-of-range
unit number as not existing.
This patch changes this by renaming the previous set_parameter_value to
set_parameter_value_chk. I then created a new version of set_parameter_value
that does no checking so that it can be used where generating errors is not
needed. I have created two new functions which build code that tests for the
out of range cases specific to INQUIRE. If a bad unit number is found, the UNIT
value in the IOPARM structure is set to -2, a new reserved value. (after this
patch we will have reserved values -3 thru -9 still available for future uses)
The definition of unit existence is adjusted to be any negative unit currently
connected having been created with NEWUNIT and all KIND=4 positive values. A -2
indicating an invalid unit will, by default, return EXISTS=false.
The behind the scenes testing is never seen in user space as shown here with an
-fdump-tree-original example from the negative_unit_int8.f .
For non-INQUIRE cases:
D.3384 = i;
if (D.3384 < -2147483647)
{
_gfortran_generate_error (&dt_parm.0, 5005, &"Unit number in I/O
statement too small"
[1]{lb: 1 sz: 1});
}
if (D.3384 > 2147483647)
{
_gfortran_generate_error (&dt_parm.0, 5005, &"Unit number in I/O
statement too large"
[1]{lb: 1 sz: 1});
}
dt_parm.0.common.unit = (integer(kind=4)) D.3384;
For the new INQUIRE case:
integer(kind=8) i;
--- snip ---
inquire_parm.4.common.unit = (integer(kind=4)) i;<---notice the conversion
to kind=4 here
D.3393 = i;
if (D.3393 < 0)
{
inquire_parm.4.common.unit = -2;
}
if (D.3393 > 2147483647)
{
inquire_parm.4.common.unit = -2;
}
When all is acceptable, common.unit is untouched and the normal assignment has
happened. The users variable, in this case i, is untouched as well because of
the temporary D.3393. The IOPARM stucture is also temporary and not used again.
The patch updates the test case mentioned above.
Regression tested on x86-64 and Joost's case in the PR now works as expected.
OK for trunk?
Regards,
Jerry
2015-01-18 Jerry DeLisle <jvdeli...@gcc.gnu.org>
PR fortran/61933
* 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 runtimr error checks and fix
whitespace. (gfc_trans_io_inquire_check): 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. (set_parameter_value_inquire):
New function that builds the conditional expressions and calls
gfc_trans_io_inquire_check. (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-18 Jerry DeLisle <jvdeli...@gcc.gnu.org>
PR libgfortran/61933
* io/inquire.c (inquire_via_unit): Set existing to true for
any negative unit that is currently connected and any positive
units within range of KIND=4 value. The unit value for any out
of range case that may occur if the user is using a KIND=8 will
have been set to -2 which is reserved and can never be opened,
and therefore the unit does not exist.
Index: gcc/fortran/trans-io.c
===================================================================
--- gcc/fortran/trans-io.c (revision 219703)
+++ gcc/fortran/trans-io.c (working copy)
@@ -512,7 +512,37 @@ set_parameter_const (stmtblock_t *block, tree var,
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 @@ static unsigned int
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,78 @@ static unsigned int
}
+/* Set the unit number in the inquire parameter block to -2. */
+
+static void
+gfc_trans_io_inquire_check (tree cond, tree var, stmtblock_t * pblock)
+{
+ stmtblock_t block;
+ tree body;
+
+ gfc_start_block (&block);
+
+ /* The unit number -2 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 uesed. */
+
+ set_parameter_const (&block, var, IOPARM_common_unit, -2);
+
+ body = gfc_finish_block (&block);
+
+ var = build3_v (COND_EXPR, cond, body, build_empty_stmt (input_location));
+ gfc_add_expr_to_block (pblock, 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)
+ {
+ tree cond, val;
+ 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);
+ cond = build2_loc (input_location, LT_EXPR, boolean_type_node,
+ se.expr,
+ fold_convert (TREE_TYPE (se.expr),
+ integer_zero_node));
+ gfc_trans_io_inquire_check (cond, var, &se.pre);
+
+ /* UNIT numbers should be less than the max. */
+ val = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, 4);
+ cond = build2_loc (input_location, GT_EXPR, boolean_type_node,
+ se.expr,
+ fold_convert (TREE_TYPE (se.expr), val));
+ gfc_trans_io_inquire_check (cond, var, &se.pre);
+ }
+
+ 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 +1079,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 +1130,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 +1183,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 +1225,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 +1234,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 +1327,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 +1460,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 +1510,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 +1809,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 +1840,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 +1892,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);
Index: gcc/testsuite/gfortran.dg/negative_unit_int8.f
===================================================================
--- gcc/testsuite/gfortran.dg/negative_unit_int8.f (revision 219703)
+++ gcc/testsuite/gfortran.dg/negative_unit_int8.f (working copy)
@@ -30,6 +30,6 @@
! This one is nasty
inquire (unit=i, exist=l, iostat=i)
if (l) call abort
- if (i.ne.ERROR_BAD_UNIT) call abort
+ if (i.ne.0) call abort
end
Index: libgfortran/io/inquire.c
===================================================================
--- libgfortran/io/inquire.c (revision 219703)
+++ libgfortran/io/inquire.c (working copy)
@@ -45,7 +45,8 @@ inquire_via_unit (st_parameter_inquire *iqp, gfc_u
generate_error (&iqp->common, LIBERROR_INQUIRE_INTERNAL_UNIT, NULL);
if ((cf & IOPARM_INQUIRE_HAS_EXIST) != 0)
- *iqp->exist = (u != NULL);
+ *iqp->exist = (u != NULL) || (iqp->common.unit >= 0
+ && iqp->common.unit <= GFC_INTEGER_4_HUGE);
if ((cf & IOPARM_INQUIRE_HAS_OPENED) != 0)
*iqp->opened = (u != NULL);
! { dg-do run }
! { dg-options "-fdefault-integer-8" }
!
! NOTE: This test is identical to negative_unit.f except -fdefault-integer-8
!
! PR libfortran/20660 and other bugs (not filed in bugzilla) relating
! to negative units
! PR 33055 Runtime error in INQUIRE unit existance with -fdefault-integer-8
! Test case update by Jerry DeLisle <jvdeli...@gcc.gnu.org>
!
! Bugs submitted by Walt Brainerd
integer i
integer, parameter ::ERROR_BAD_UNIT = 5005
logical l
i = -1
! gfortran created a 'fort.-1' file and wrote "Hello" in it
write (unit=i, fmt=*, iostat=i) "Hello"
if (i <= 0) call abort
i = -11
open (unit=i, file="xxx", iostat=i)
if (i <= 0) call abort
i = -42
inquire (unit=i, exist=l)
if (l) call abort
i = 2_8*huge(0_4)+20_8
! This one is nasty
inquire (unit=i, exist=l, iostat=i)
if (l) call abort
if (i.ne.0) call abort
end
