On 01/19/2015 11:28 PM, Tobias Burnus wrote:
Hi Jerry, hi all,
sorry for the slow patch review. I also still want to review your other inquire
patch.
Jerry DeLisle wrote:
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.
Regression tested on x86-64 and Joost's case in the PR now works as expected.
OK for trunk?
Mostly OK, however, some remarks are below.
--- snip---
I don't know where this number is used, but I really should be a #define; if it
is shared with libgfortran, it belongs to libgfortran.h. You wrote that -1 is
also reserved and used; is the -1 somewhere defined? [Disclaimer: I have only
browsed the other patch and do not recall whether it add, handles or #defines -1
- or whether -1 is already defined somewhere.]
I have added the following to libgfortran.h and used them (see patch)
/* Special unit numbers used to convey certain conditions. Numbers -3
thru -9 available. NEWUNIT values start at -10. */
#define GFC_INTERNAL_UNIT -1
#define GFC_INVALID_UNIT -2
--- snip ---
The conditions could be combined with a fold_build2_loc(...,TRUTH_AND_EXPR,...).
I have combined the conditions using TRUTH_OR_EXPR which is what we want. I
also rolled the one helper function I had into the caller since I now only build
one block in the combined condition.
The new -fdump-tree-orginal result looks good:
inquire_parm.4.common.unit = (integer(kind=4)) i;
D.3393 = i;
if (D.3393 < 0 || D.3393 > 2147483647)
{
inquire_parm.4.common.unit = -2;
}
_gfortran_st_inquire (&inquire_parm.4);
The updated patch is attached.
Regression tested completely again. OK for Trunk?
Thanks for the review.
Regards,
Jerry
Index: gcc/fortran/libgfortran.h
===================================================================
--- gcc/fortran/libgfortran.h (revision 219925)
+++ gcc/fortran/libgfortran.h (working copy)
@@ -68,6 +68,10 @@
| GFC_RTCHECK_RECURSION | GFC_RTCHECK_DO \
| GFC_RTCHECK_POINTER | GFC_RTCHECK_MEM)
+/* Special unit numbers used to convey certain conditions. Numbers -3
+ thru -9 available. NEWUNIT values start at -10. */
+#define GFC_INTERNAL_UNIT -1
+#define GFC_INVALID_UNIT -2
/* Possible values for the CONVERT I/O specifier. */
/* Keep in sync with GFC_FLAG_CONVERT_* in gcc/flags.h. */
Index: gcc/fortran/trans-io.c
===================================================================
--- gcc/fortran/trans-io.c (revision 219925)
+++ gcc/fortran/trans-io.c (working copy)
@@ -512,7 +512,37 @@
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 @@
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,69 @@
}
+/* 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)
+ {
+ stmtblock_t newblock;
+ tree cond1, cond2, cond3, val, body;
+ 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);
+ cond1 = build2_loc (input_location, LT_EXPR, boolean_type_node,
+ se.expr,
+ fold_convert (TREE_TYPE (se.expr),
+ integer_zero_node));
+ /* UNIT numbers should be less than the max. */
+ val = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, 4);
+ cond2 = build2_loc (input_location, GT_EXPR, boolean_type_node,
+ se.expr,
+ fold_convert (TREE_TYPE (se.expr), val));
+ cond3 = build2_loc (input_location, TRUTH_OR_EXPR,
+ boolean_type_node, cond1, cond2);
+
+ gfc_start_block (&newblock);
+
+ /* The unit number GFC_INVALID_UNIT 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 used. */
+ set_parameter_const (&newblock, var, IOPARM_common_unit,
+ GFC_INVALID_UNIT);
+
+ body = gfc_finish_block (&newblock);
+
+ var = build3_v (COND_EXPR, cond3, body, build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&se.pre, var);
+ }
+
+ 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 +1070,7 @@
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 +1121,7 @@
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 +1174,7 @@
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 +1216,8 @@
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 +1225,8 @@
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 +1318,8 @@
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 +1451,10 @@
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 +1501,12 @@
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 +1800,11 @@
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 +1831,7 @@
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 +1883,8 @@
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 219925)
+++ 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 219925)
+++ libgfortran/io/inquire.c (working copy)
@@ -41,11 +41,12 @@
const char *p;
GFC_INTEGER_4 cf = iqp->common.flags;
- if (iqp->common.unit == -1)
+ if (iqp->common.unit == GFC_INTERNAL_UNIT)
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);
