2018-08-21 Nicolas Koenig <koenigni@gcc.gnu.org>

[thirdparty/gcc.git] / gcc / fortran / trans-io.c

diff --git a/gcc/fortran/trans-io.c b/gcc/fortran/trans-io.c
index 9eb77e5986dfd780bd6d3ef2f00b5826b05a94ce..88dbcb80a854dd71ebe53e218ade67e4a570efa5 100644 (file)
--- a/gcc/fortran/trans-io.c
+++ b/gcc/fortran/trans-io.c
@@ -438,10 +438,9 @@ gfc_build_io_library_fndecls (void)
        get_identifier (PREFIX("st_iolength")), ".w",
        void_type_node, 1, dt_parm_type);
 
-  /* TODO: Change when asynchronous I/O is implemented.  */
   parm_type = build_pointer_type (st_parameter[IOPARM_ptype_wait].type);
   iocall[IOCALL_WAIT] = gfc_build_library_function_decl_with_spec (
-       get_identifier (PREFIX("st_wait")), ".X",
+       get_identifier (PREFIX("st_wait_async")), ".w",
        void_type_node, 1, parm_type);
 
   parm_type = build_pointer_type (st_parameter[IOPARM_ptype_filepos].type);
@@ -478,12 +477,12 @@ gfc_build_io_library_fndecls (void)
   iocall[IOCALL_SET_NML_VAL] = gfc_build_library_function_decl_with_spec (
        get_identifier (PREFIX("st_set_nml_var")), ".w.R",
        void_type_node, 6, dt_parm_type, pvoid_type_node, pvoid_type_node,
-       gfc_int4_type_node, gfc_charlen_type_node, gfc_int4_type_node);
+       gfc_int4_type_node, gfc_charlen_type_node, get_dtype_type_node());
 
   iocall[IOCALL_SET_NML_DTIO_VAL] = gfc_build_library_function_decl_with_spec (
        get_identifier (PREFIX("st_set_nml_dtio_var")), ".w.R",
        void_type_node, 8, dt_parm_type, pvoid_type_node, pvoid_type_node,
-       gfc_int4_type_node, gfc_charlen_type_node, gfc_int4_type_node,
+       gfc_int4_type_node, gfc_charlen_type_node, get_dtype_type_node(),
        pvoid_type_node, pvoid_type_node);
 
   iocall[IOCALL_SET_NML_VAL_DIM] = gfc_build_library_function_decl_with_spec (
@@ -639,12 +638,12 @@ set_parameter_value_inquire (stmtblock_t *block, tree var,
       /* Don't evaluate the UNIT number multiple times.  */
       se.expr = gfc_evaluate_now (se.expr, &se.pre);
 
-      /* UNIT numbers should be greater than zero.  */
+      /* UNIT numbers should be greater than the min.  */
       i = gfc_validate_kind (BT_INTEGER, 4, false);
+      val = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].pedantic_min_int, 4);
       cond1 = build2_loc (input_location, LT_EXPR, logical_type_node,
                          se.expr,
-                         fold_convert (TREE_TYPE (se.expr),
-                         integer_zero_node));
+                         fold_convert (TREE_TYPE (se.expr), val));
       /* 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, logical_type_node,
@@ -1527,7 +1526,7 @@ gfc_trans_wait (gfc_code * code)
     mask |= IOPARM_common_err;
 
   if (p->id)
-    mask |= set_parameter_value (&block, var, IOPARM_wait_id, p->id);
+    mask |= set_parameter_ref (&block, &post_block, var, IOPARM_wait_id, p->id);
 
   set_parameter_const (&block, var, IOPARM_common_flags, mask);
 
@@ -1662,7 +1661,6 @@ transfer_namelist_element (stmtblock_t * block, const char * var_name,
   tree dtio_proc = null_pointer_node;
   tree vtable = null_pointer_node;
   int n_dim;
-  int itype;
   int rank = 0;
 
   gcc_assert (sym || c);
@@ -1699,8 +1697,8 @@ transfer_namelist_element (stmtblock_t * block, const char * var_name,
     }
   else
     {
-      itype = ts->type;
-      dtype = IARG (itype << GFC_DTYPE_TYPE_SHIFT);
+      dt =  gfc_typenode_for_spec (ts);
+      dtype = gfc_get_dtype_rank_type (0, dt);
     }
 
   /* Build up the arguments for the transfer call.
@@ -1959,8 +1957,8 @@ build_dt (tree function, gfc_code * code)
       if (dt->udtio)
        mask |= IOPARM_dt_dtio;
 
-      if (dt->default_exp)
-       mask |= IOPARM_dt_default_exp;
+      if (dt->dec_ext)
+       mask |= IOPARM_dt_dec_ext;
 
       if (dt->namelist)
        {
@@ -2227,25 +2225,9 @@ get_dtio_proc (gfc_typespec * ts, gfc_code * code, gfc_symbol **dtio_sub)
   bool formatted = false;
   gfc_dt *dt = code->ext.dt;
 
-  if (dt)
-    {
-      char *fmt = NULL;
-
-      if (dt->format_label == &format_asterisk)
-       {
-         /* List directed io must call the formatted DTIO procedure.  */
-         formatted = true;
-       }
-      else if (dt->format_expr)
-       fmt = gfc_widechar_to_char (dt->format_expr->value.character.string,
-                                     -1);
-      else if (dt->format_label)
-       fmt = gfc_widechar_to_char (dt->format_label->format->value.character.string,
-                                     -1);
-      if (fmt && strtok (fmt, "DT") != NULL)
-       formatted = true;
-
-    }
+  /* Determine when to use the formatted DTIO procedure.  */
+  if (dt && (dt->format_expr || dt->format_label))
+    formatted = true;
 
   if (ts->type == BT_CLASS)
     derived = ts->u.derived->components->ts.u.derived;
@@ -2306,6 +2288,16 @@ transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr,
       ts->kind = gfc_index_integer_kind;
     }
 
+  /* gfortran reaches here for "print *, c_loc(xxx)".  */
+  if (ts->type == BT_VOID
+      && code->expr1 && code->expr1->ts.type == BT_VOID
+      && code->expr1->symtree
+      && strcmp (code->expr1->symtree->name, "c_loc") == 0)
+    {
+      ts->type = BT_INTEGER;
+      ts->kind = gfc_index_integer_kind;
+    }
+
   kind = ts->kind;
   function = NULL;
   arg2 = NULL;
@@ -2455,8 +2447,7 @@ transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr,
            {
              /* Recurse into the elements of the derived type.  */
              expr = gfc_evaluate_now (addr_expr, &se->pre);
-             expr = build_fold_indirect_ref_loc (input_location,
-                                     expr);
+             expr = build_fold_indirect_ref_loc (input_location, expr);
 
              /* Make sure that the derived type has been built.  An external
                 function, if only referenced in an io statement, requires this