re PR fortran/61933 (Inquire on internal units)

2015-01-22  Jerry DeLisle  <jvdelisle@gcc.gnu.org>

	PR fortran/61933
	* libgfortran.h:
	* 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 runtime error checks and fix
	whitespace. (set_parameter_value_inquire): 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. (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.

From-SVN: r220023

gcc/fortran/ChangeLog

+2015-01-22  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/61933
+	* libgfortran.h:
+	* 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 runtime error checks and fix
+	whitespace. (set_parameter_value_inquire): 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. (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-21  Thomas Koenig  <tkoenig@netcologne.de>
 
 	PR fortran/57023
@@ -95,6 +117,7 @@
 	* decl.c (match_pointer_init): Error out if resolution of init expr
 	failed.
 
+>>>>>>> .r219925
 2015-01-15  Tobias Burnus  <burnus@net-b.de>
 
 	* openmp.c (check_symbol_not_pointer, resolve_oacc_data_clauses,

gcc/fortran/libgfortran.h

@@ -68,6 +68,10 @@ along with GCC; see the file COPYING3.  If not see
 				| 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.  */

gcc/fortran/trans-io.c

@@ -512,7 +512,37 @@ set_parameter_const (stmtblock_t *block, tree var, enum iofield type,
    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 @@ set_parameter_value (stmtblock_t *block, bool has_iostat, tree var,
       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,70 @@ set_parameter_value (stmtblock_t *block, bool has_iostat, tree 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)
+    {
+      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);
+
+      cond3 = gfc_unlikely (cond3, PRED_FORTRAN_FAIL_IO);    
+      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 +1071,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 +1122,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 +1175,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 +1217,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 +1226,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 +1319,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 +1452,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 +1502,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 +1801,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 +1832,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 +1884,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);