diff mbox

[Fortran] PR61933 Inquire on Internal Units

Message ID 54BF36F5.2040809@charter.net
State New
Headers show

Commit Message

Jerry DeLisle Jan. 21, 2015, 5:19 a.m. UTC 
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

Comments

Tobias Burnus Jan. 21, 2015, 11:33 p.m. UTC | #1 
Hi Jerry et al.,

Jerry DeLisle wrote:
> 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
>

Thanks!

>>
>> 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.
>
>
> Regression tested completely again.  OK for Trunk?
> Thanks for the review.

Looks quite good to me. On possible modification would be for:

> +      var = build3_v (COND_EXPR, cond3, body, build_empty_stmt (input_location));

You could add before that line:
   cond3 = gfc_unlikely (cond3, PRED_FORTRAN_FAIL_IO);
which tells the compiler that it is less likely that that branch is taken.


However, I don't quite understand:

+    *iqp->exist = (u != NULL) || (iqp->common.unit >= 0 	
+		   && iqp->common.unit <= GFC_INTEGER_4_HUGE);

The "ipq->common.unit <= GFC_INTEGER_4_HUGE" is always true, isn't it? Or do I miss something?

Also, I miss the test case. I assume that you still include it, don't you?


Tobias
Jerry DeLisle Jan. 22, 2015, 2:31 a.m. UTC | #2 
On 01/21/2015 03:33 PM, Tobias Burnus wrote:
> Hi Jerry et al.,
>
> Jerry DeLisle wrote:
>> 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
>>
>
> Thanks!
>
>>>
>>> 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.
>>
>>
>> Regression tested completely again.  OK for Trunk?
>> Thanks for the review.
>
> Looks quite good to me. On possible modification would be for:
>
>> +      var = build3_v (COND_EXPR, cond3, body, build_empty_stmt
>> (input_location));
>
> You could add before that line:
>    cond3 = gfc_unlikely (cond3, PRED_FORTRAN_FAIL_IO);
> which tells the compiler that it is less likely that that branch is taken.
>

OK, I will add this.

> However, I don't quite understand:
>
> +    *iqp->exist = (u != NULL) || (iqp->common.unit >= 0
> +           && iqp->common.unit <= GFC_INTEGER_4_HUGE);
>
> The "ipq->common.unit <= GFC_INTEGER_4_HUGE" is always true, isn't it? Or do I
> miss something?

No you do not miss something.  I will fix that. (gadzooks)

It should be:

	 *iqp->exist = (u != NULL) || (iqp->common.unit >= 0)

>
> Also, I miss the test case. I assume that you still include it, don't you?

Yes test case will be included.

With those corrections OK?

Jerry
Tobias Burnus Jan. 22, 2015, 6:46 a.m. UTC | #3 
Am 22.01.2015 um 03:31 schrieb Jerry DeLisle:
>>
>> Also, I miss the test case. I assume that you still include it, don't 
>> you?
>
> Yes test case will be included.
> With those corrections OK?

Yes. Thanks for the patch!

Tobias
diff mbox

Patch

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);