gcc/fortran/trans-io.c

   1 /* IO Code translation/library interface
   2    Copyright (C) 2002-2016 Free Software Foundation, Inc.
   3    Contributed by Paul Brook
   4
   5 This file is part of GCC.
   6
   7 GCC is free software; you can redistribute it and/or modify it under
   8 the terms of the GNU General Public License as published by the Free
   9 Software Foundation; either version 3, or (at your option) any later
  10 version.
  11
  12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
  13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
  14 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  15 for more details.
  16
  17 You should have received a copy of the GNU General Public License
  18 along with GCC; see the file COPYING3.  If not see
  19 <http://www.gnu.org/licenses/>.  */
  20
  21
  22 #include "config.h"
  23 #include "system.h"
  24 #include "coretypes.h"
  25 #include "tree.h"
  26 #include "gfortran.h"
  27 #include "trans.h"
  28 #include "stringpool.h"
  29 #include "fold-const.h"
  30 #include "stor-layout.h"
  31 #include "trans-stmt.h"
  32 #include "trans-array.h"
  33 #include "trans-types.h"
  34 #include "trans-const.h"
  35
  36 /* Members of the ioparm structure.  */
  37
  38 enum ioparam_type
  39 {
  40   IOPARM_ptype_common,
  41   IOPARM_ptype_open,
  42   IOPARM_ptype_close,
  43   IOPARM_ptype_filepos,
  44   IOPARM_ptype_inquire,
  45   IOPARM_ptype_dt,
  46   IOPARM_ptype_wait,
  47   IOPARM_ptype_num
  48 };
  49
  50 enum iofield_type
  51 {
  52   IOPARM_type_int4,
  53   IOPARM_type_intio,
  54   IOPARM_type_pint4,
  55   IOPARM_type_pintio,
  56   IOPARM_type_pchar,
  57   IOPARM_type_parray,
  58   IOPARM_type_pad,
  59   IOPARM_type_char1,
  60   IOPARM_type_char2,
  61   IOPARM_type_common,
  62   IOPARM_type_num
  63 };
  64
  65 typedef struct GTY(()) gfc_st_parameter_field {
  66   const char *name;
  67   unsigned int mask;
  68   enum ioparam_type param_type;
  69   enum iofield_type type;
  70   tree field;
  71   tree field_len;
  72 }
  73 gfc_st_parameter_field;
  74
  75 typedef struct GTY(()) gfc_st_parameter {
  76   const char *name;
  77   tree type;
  78 }
  79 gfc_st_parameter;
  80
  81 enum iofield
  82 {
  83 #define IOPARM(param_type, name, mask, type) IOPARM_##param_type##_##name,
  84 #include "ioparm.def"
  85 #undef IOPARM
  86   IOPARM_field_num
  87 };
  88
  89 static GTY(()) gfc_st_parameter st_parameter[] =
  90 {
  91   { "common", NULL },
  92   { "open", NULL },
  93   { "close", NULL },
  94   { "filepos", NULL },
  95   { "inquire", NULL },
  96   { "dt", NULL },
  97   { "wait", NULL }
  98 };
  99
 100 static GTY(()) gfc_st_parameter_field st_parameter_field[] =
 101 {
 102 #define IOPARM(param_type, name, mask, type) \
 103   { #name, mask, IOPARM_ptype_##param_type, IOPARM_type_##type, NULL, NULL },
 104 #include "ioparm.def"
 105 #undef IOPARM
 106   { NULL, 0, (enum ioparam_type) 0, (enum iofield_type) 0, NULL, NULL }
 107 };
 108
 109 /* Library I/O subroutines */
 110
 111 enum iocall
 112 {
 113   IOCALL_READ,
 114   IOCALL_READ_DONE,
 115   IOCALL_WRITE,
 116   IOCALL_WRITE_DONE,
 117   IOCALL_X_INTEGER,
 118   IOCALL_X_INTEGER_WRITE,
 119   IOCALL_X_LOGICAL,
 120   IOCALL_X_LOGICAL_WRITE,
 121   IOCALL_X_CHARACTER,
 122   IOCALL_X_CHARACTER_WRITE,
 123   IOCALL_X_CHARACTER_WIDE,
 124   IOCALL_X_CHARACTER_WIDE_WRITE,
 125   IOCALL_X_REAL,
 126   IOCALL_X_REAL_WRITE,
 127   IOCALL_X_COMPLEX,
 128   IOCALL_X_COMPLEX_WRITE,
 129   IOCALL_X_REAL128,
 130   IOCALL_X_REAL128_WRITE,
 131   IOCALL_X_COMPLEX128,
 132   IOCALL_X_COMPLEX128_WRITE,
 133   IOCALL_X_ARRAY,
 134   IOCALL_X_ARRAY_WRITE,
 135   IOCALL_OPEN,
 136   IOCALL_CLOSE,
 137   IOCALL_INQUIRE,
 138   IOCALL_IOLENGTH,
 139   IOCALL_IOLENGTH_DONE,
 140   IOCALL_REWIND,
 141   IOCALL_BACKSPACE,
 142   IOCALL_ENDFILE,
 143   IOCALL_FLUSH,
 144   IOCALL_SET_NML_VAL,
 145   IOCALL_SET_NML_VAL_DIM,
 146   IOCALL_WAIT,
 147   IOCALL_NUM
 148 };
 149
 150 static GTY(()) tree iocall[IOCALL_NUM];
 151
 152 /* Variable for keeping track of what the last data transfer statement
 153    was.  Used for deciding which subroutine to call when the data
 154    transfer is complete.  */
 155 static enum { READ, WRITE, IOLENGTH } last_dt;
 156
 157 /* The data transfer parameter block that should be shared by all
 158    data transfer calls belonging to the same read/write/iolength.  */
 159 static GTY(()) tree dt_parm;
 160 static stmtblock_t *dt_post_end_block;
 161
 162 static void
 163 gfc_build_st_parameter (enum ioparam_type ptype, tree *types)
 164 {
 165   unsigned int type;
 166   gfc_st_parameter_field *p;
 167   char name[64];
 168   size_t len;
 169   tree t = make_node (RECORD_TYPE);
 170   tree *chain = NULL;
 171
 172   len = strlen (st_parameter[ptype].name);
 173   gcc_assert (len <= sizeof (name) - sizeof ("__st_parameter_"));
 174   memcpy (name, "__st_parameter_", sizeof ("__st_parameter_"));
 175   memcpy (name + sizeof ("__st_parameter_") - 1, st_parameter[ptype].name,
 176           len + 1);
 177   TYPE_NAME (t) = get_identifier (name);
 178
 179   for (type = 0, p = st_parameter_field; type < IOPARM_field_num; type++, p++)
 180     if (p->param_type == ptype)
 181       switch (p->type)
 182         {
 183         case IOPARM_type_int4:
 184         case IOPARM_type_intio:
 185         case IOPARM_type_pint4:
 186         case IOPARM_type_pintio:
 187         case IOPARM_type_parray:
 188         case IOPARM_type_pchar:
 189         case IOPARM_type_pad:
 190           p->field = gfc_add_field_to_struct (t, get_identifier (p->name),
 191                                               types[p->type], &chain);
 192           break;
 193         case IOPARM_type_char1:
 194           p->field = gfc_add_field_to_struct (t, get_identifier (p->name),
 195                                               pchar_type_node, &chain);
 196           /* FALLTHROUGH */
 197         case IOPARM_type_char2:
 198           len = strlen (p->name);
 199           gcc_assert (len <= sizeof (name) - sizeof ("_len"));
 200           memcpy (name, p->name, len);
 201           memcpy (name + len, "_len", sizeof ("_len"));
 202           p->field_len = gfc_add_field_to_struct (t, get_identifier (name),
 203                                                   gfc_charlen_type_node,
 204                                                   &chain);
 205           if (p->type == IOPARM_type_char2)
 206             p->field = gfc_add_field_to_struct (t, get_identifier (p->name),
 207                                                 pchar_type_node, &chain);
 208           break;
 209         case IOPARM_type_common:
 210           p->field
 211             = gfc_add_field_to_struct (t,
 212                                        get_identifier (p->name),
 213                                        st_parameter[IOPARM_ptype_common].type,
 214                                        &chain);
 215           break;
 216         case IOPARM_type_num:
 217           gcc_unreachable ();
 218         }
 219
 220   gfc_finish_type (t);
 221   st_parameter[ptype].type = t;
 222 }
 223
 224
 225 /* Build code to test an error condition and call generate_error if needed.
 226    Note: This builds calls to generate_error in the runtime library function.
 227    The function generate_error is dependent on certain parameters in the
 228    st_parameter_common flags to be set. (See libgfortran/runtime/error.c)
 229    Therefore, the code to set these flags must be generated before
 230    this function is used.  */
 231
 232 static void
 233 gfc_trans_io_runtime_check (bool has_iostat, tree cond, tree var,
 234                             int error_code, const char * msgid,
 235                             stmtblock_t * pblock)
 236 {
 237   stmtblock_t block;
 238   tree body;
 239   tree tmp;
 240   tree arg1, arg2, arg3;
 241   char *message;
 242
 243   if (integer_zerop (cond))
 244     return;
 245
 246   /* The code to generate the error.  */
 247   gfc_start_block (&block);
 248
 249   if (has_iostat)
 250     gfc_add_expr_to_block (&block, build_predict_expr (PRED_FORTRAN_FAIL_IO,
 251                                                        NOT_TAKEN));
 252   else
 253     gfc_add_expr_to_block (&block, build_predict_expr (PRED_NORETURN,
 254                                                        NOT_TAKEN));
 255
 256   arg1 = gfc_build_addr_expr (NULL_TREE, var);
 257
 258   arg2 = build_int_cst (integer_type_node, error_code),
 259
 260   message = xasprintf ("%s", _(msgid));
 261   arg3 = gfc_build_addr_expr (pchar_type_node,
 262                               gfc_build_localized_cstring_const (message));
 263   free (message);
 264
 265   tmp = build_call_expr_loc (input_location,
 266                          gfor_fndecl_generate_error, 3, arg1, arg2, arg3);
 267
 268   gfc_add_expr_to_block (&block, tmp);
 269
 270   body = gfc_finish_block (&block);
 271
 272   if (integer_onep (cond))
 273     {
 274       gfc_add_expr_to_block (pblock, body);
 275     }
 276   else
 277     {
 278       tmp = build3_v (COND_EXPR, cond, body, build_empty_stmt (input_location));
 279       gfc_add_expr_to_block (pblock, tmp);
 280     }
 281 }
 282
 283
 284 /* Create function decls for IO library functions.  */
 285
 286 void
 287 gfc_build_io_library_fndecls (void)
 288 {
 289   tree types[IOPARM_type_num], pad_idx, gfc_int4_type_node;
 290   tree gfc_intio_type_node;
 291   tree parm_type, dt_parm_type;
 292   HOST_WIDE_INT pad_size;
 293   unsigned int ptype;
 294
 295   types[IOPARM_type_int4] = gfc_int4_type_node = gfc_get_int_type (4);
 296   types[IOPARM_type_intio] = gfc_intio_type_node
 297                             = gfc_get_int_type (gfc_intio_kind);
 298   types[IOPARM_type_pint4] = build_pointer_type (gfc_int4_type_node);
 299   types[IOPARM_type_pintio]
 300                             = build_pointer_type (gfc_intio_type_node);
 301   types[IOPARM_type_parray] = pchar_type_node;
 302   types[IOPARM_type_pchar] = pchar_type_node;
 303   pad_size = 16 * TREE_INT_CST_LOW (TYPE_SIZE_UNIT (pchar_type_node));
 304   pad_size += 32 * TREE_INT_CST_LOW (TYPE_SIZE_UNIT (integer_type_node));
 305   pad_idx = build_index_type (size_int (pad_size - 1));
 306   types[IOPARM_type_pad] = build_array_type (char_type_node, pad_idx);
 307
 308   /* pad actually contains pointers and integers so it needs to have an
 309      alignment that is at least as large as the needed alignment for those
 310      types.  See the st_parameter_dt structure in libgfortran/io/io.h for
 311      what really goes into this space.  */
 312   TYPE_ALIGN (types[IOPARM_type_pad]) = MAX (TYPE_ALIGN (pchar_type_node),
 313                      TYPE_ALIGN (gfc_get_int_type (gfc_intio_kind)));
 314
 315   for (ptype = IOPARM_ptype_common; ptype < IOPARM_ptype_num; ptype++)
 316     gfc_build_st_parameter ((enum ioparam_type) ptype, types);
 317
 318   /* Define the transfer functions.  */
 319
 320   dt_parm_type = build_pointer_type (st_parameter[IOPARM_ptype_dt].type);
 321
 322   iocall[IOCALL_X_INTEGER] = gfc_build_library_function_decl_with_spec (
 323         get_identifier (PREFIX("transfer_integer")), ".wW",
 324         void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
 325
 326   iocall[IOCALL_X_INTEGER_WRITE] = gfc_build_library_function_decl_with_spec (
 327         get_identifier (PREFIX("transfer_integer_write")), ".wR",
 328         void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
 329
 330   iocall[IOCALL_X_LOGICAL] = gfc_build_library_function_decl_with_spec (
 331         get_identifier (PREFIX("transfer_logical")), ".wW",
 332         void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
 333
 334   iocall[IOCALL_X_LOGICAL_WRITE] = gfc_build_library_function_decl_with_spec (
 335         get_identifier (PREFIX("transfer_logical_write")), ".wR",
 336         void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
 337
 338   iocall[IOCALL_X_CHARACTER] = gfc_build_library_function_decl_with_spec (
 339         get_identifier (PREFIX("transfer_character")), ".wW",
 340         void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
 341
 342   iocall[IOCALL_X_CHARACTER_WRITE] = gfc_build_library_function_decl_with_spec (
 343         get_identifier (PREFIX("transfer_character_write")), ".wR",
 344         void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
 345
 346   iocall[IOCALL_X_CHARACTER_WIDE] = gfc_build_library_function_decl_with_spec (
 347         get_identifier (PREFIX("transfer_character_wide")), ".wW",
 348         void_type_node, 4, dt_parm_type, pvoid_type_node,
 349         gfc_charlen_type_node, gfc_int4_type_node);
 350
 351   iocall[IOCALL_X_CHARACTER_WIDE_WRITE] =
 352     gfc_build_library_function_decl_with_spec (
 353         get_identifier (PREFIX("transfer_character_wide_write")), ".wR",
 354         void_type_node, 4, dt_parm_type, pvoid_type_node,
 355         gfc_charlen_type_node, gfc_int4_type_node);
 356
 357   iocall[IOCALL_X_REAL] = gfc_build_library_function_decl_with_spec (
 358         get_identifier (PREFIX("transfer_real")), ".wW",
 359         void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
 360
 361   iocall[IOCALL_X_REAL_WRITE] = gfc_build_library_function_decl_with_spec (
 362         get_identifier (PREFIX("transfer_real_write")), ".wR",
 363         void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
 364
 365   iocall[IOCALL_X_COMPLEX] = gfc_build_library_function_decl_with_spec (
 366         get_identifier (PREFIX("transfer_complex")), ".wW",
 367         void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
 368
 369   iocall[IOCALL_X_COMPLEX_WRITE] = gfc_build_library_function_decl_with_spec (
 370         get_identifier (PREFIX("transfer_complex_write")), ".wR",
 371         void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
 372
 373   /* Version for __float128.  */
 374   iocall[IOCALL_X_REAL128] = gfc_build_library_function_decl_with_spec (
 375         get_identifier (PREFIX("transfer_real128")), ".wW",
 376         void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
 377
 378   iocall[IOCALL_X_REAL128_WRITE] = gfc_build_library_function_decl_with_spec (
 379         get_identifier (PREFIX("transfer_real128_write")), ".wR",
 380         void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
 381
 382   iocall[IOCALL_X_COMPLEX128] = gfc_build_library_function_decl_with_spec (
 383         get_identifier (PREFIX("transfer_complex128")), ".wW",
 384         void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
 385
 386   iocall[IOCALL_X_COMPLEX128_WRITE] = gfc_build_library_function_decl_with_spec (
 387         get_identifier (PREFIX("transfer_complex128_write")), ".wR",
 388         void_type_node, 3, dt_parm_type, pvoid_type_node, gfc_int4_type_node);
 389
 390   iocall[IOCALL_X_ARRAY] = gfc_build_library_function_decl_with_spec (
 391         get_identifier (PREFIX("transfer_array")), ".ww",
 392         void_type_node, 4, dt_parm_type, pvoid_type_node,
 393         integer_type_node, gfc_charlen_type_node);
 394
 395   iocall[IOCALL_X_ARRAY_WRITE] = gfc_build_library_function_decl_with_spec (
 396         get_identifier (PREFIX("transfer_array_write")), ".wr",
 397         void_type_node, 4, dt_parm_type, pvoid_type_node,
 398         integer_type_node, gfc_charlen_type_node);
 399
 400   /* Library entry points */
 401
 402   iocall[IOCALL_READ] = gfc_build_library_function_decl_with_spec (
 403         get_identifier (PREFIX("st_read")), ".w",
 404         void_type_node, 1, dt_parm_type);
 405
 406   iocall[IOCALL_WRITE] = gfc_build_library_function_decl_with_spec (
 407         get_identifier (PREFIX("st_write")), ".w",
 408         void_type_node, 1, dt_parm_type);
 409
 410   parm_type = build_pointer_type (st_parameter[IOPARM_ptype_open].type);
 411   iocall[IOCALL_OPEN] = gfc_build_library_function_decl_with_spec (
 412         get_identifier (PREFIX("st_open")), ".w",
 413         void_type_node, 1, parm_type);
 414
 415   parm_type = build_pointer_type (st_parameter[IOPARM_ptype_close].type);
 416   iocall[IOCALL_CLOSE] = gfc_build_library_function_decl_with_spec (
 417         get_identifier (PREFIX("st_close")), ".w",
 418         void_type_node, 1, parm_type);
 419
 420   parm_type = build_pointer_type (st_parameter[IOPARM_ptype_inquire].type);
 421   iocall[IOCALL_INQUIRE] = gfc_build_library_function_decl_with_spec (
 422         get_identifier (PREFIX("st_inquire")), ".w",
 423         void_type_node, 1, parm_type);
 424
 425   iocall[IOCALL_IOLENGTH] = gfc_build_library_function_decl_with_spec(
 426         get_identifier (PREFIX("st_iolength")), ".w",
 427         void_type_node, 1, dt_parm_type);
 428
 429   /* TODO: Change when asynchronous I/O is implemented.  */
 430   parm_type = build_pointer_type (st_parameter[IOPARM_ptype_wait].type);
 431   iocall[IOCALL_WAIT] = gfc_build_library_function_decl_with_spec (
 432         get_identifier (PREFIX("st_wait")), ".X",
 433         void_type_node, 1, parm_type);
 434
 435   parm_type = build_pointer_type (st_parameter[IOPARM_ptype_filepos].type);
 436   iocall[IOCALL_REWIND] = gfc_build_library_function_decl_with_spec (
 437         get_identifier (PREFIX("st_rewind")), ".w",
 438         void_type_node, 1, parm_type);
 439
 440   iocall[IOCALL_BACKSPACE] = gfc_build_library_function_decl_with_spec (
 441         get_identifier (PREFIX("st_backspace")), ".w",
 442         void_type_node, 1, parm_type);
 443
 444   iocall[IOCALL_ENDFILE] = gfc_build_library_function_decl_with_spec (
 445         get_identifier (PREFIX("st_endfile")), ".w",
 446         void_type_node, 1, parm_type);
 447
 448   iocall[IOCALL_FLUSH] = gfc_build_library_function_decl_with_spec (
 449         get_identifier (PREFIX("st_flush")), ".w",
 450         void_type_node, 1, parm_type);
 451
 452   /* Library helpers */
 453
 454   iocall[IOCALL_READ_DONE] = gfc_build_library_function_decl_with_spec (
 455         get_identifier (PREFIX("st_read_done")), ".w",
 456         void_type_node, 1, dt_parm_type);
 457
 458   iocall[IOCALL_WRITE_DONE] = gfc_build_library_function_decl_with_spec (
 459         get_identifier (PREFIX("st_write_done")), ".w",
 460         void_type_node, 1, dt_parm_type);
 461
 462   iocall[IOCALL_IOLENGTH_DONE] = gfc_build_library_function_decl_with_spec (
 463         get_identifier (PREFIX("st_iolength_done")), ".w",
 464         void_type_node, 1, dt_parm_type);
 465
 466   iocall[IOCALL_SET_NML_VAL] = gfc_build_library_function_decl_with_spec (
 467         get_identifier (PREFIX("st_set_nml_var")), ".w.R",
 468         void_type_node, 6, dt_parm_type, pvoid_type_node, pvoid_type_node,
 469         gfc_int4_type_node, gfc_charlen_type_node, gfc_int4_type_node);
 470
 471   iocall[IOCALL_SET_NML_VAL_DIM] = gfc_build_library_function_decl_with_spec (
 472         get_identifier (PREFIX("st_set_nml_var_dim")), ".w",
 473         void_type_node, 5, dt_parm_type, gfc_int4_type_node,
 474         gfc_array_index_type, gfc_array_index_type, gfc_array_index_type);
 475 }
 476
 477
 478 /* Generate code to store an integer constant into the
 479    st_parameter_XXX structure.  */
 480
 481 static unsigned int
 482 set_parameter_const (stmtblock_t *block, tree var, enum iofield type,
 483                      unsigned int val)
 484 {
 485   tree tmp;
 486   gfc_st_parameter_field *p = &st_parameter_field[type];
 487
 488   if (p->param_type == IOPARM_ptype_common)
 489     var = fold_build3_loc (input_location, COMPONENT_REF,
 490                            st_parameter[IOPARM_ptype_common].type,
 491                            var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
 492   tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field),
 493                          var, p->field, NULL_TREE);
 494   gfc_add_modify (block, tmp, build_int_cst (TREE_TYPE (p->field), val));
 495   return p->mask;
 496 }
 497
 498
 499 /* Generate code to store a non-string I/O parameter into the
 500    st_parameter_XXX structure.  This is a pass by value.  */
 501
 502 static unsigned int
 503 set_parameter_value (stmtblock_t *block, tree var, enum iofield type,
 504                      gfc_expr *e)
 505 {
 506   gfc_se se;
 507   tree tmp;
 508   gfc_st_parameter_field *p = &st_parameter_field[type];
 509   tree dest_type = TREE_TYPE (p->field);
 510
 511   gfc_init_se (&se, NULL);
 512   gfc_conv_expr_val (&se, e);
 513
 514   se.expr = convert (dest_type, se.expr);
 515   gfc_add_block_to_block (block, &se.pre);
 516
 517   if (p->param_type == IOPARM_ptype_common)
 518     var = fold_build3_loc (input_location, COMPONENT_REF,
 519                            st_parameter[IOPARM_ptype_common].type,
 520                            var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
 521
 522   tmp = fold_build3_loc (input_location, COMPONENT_REF, dest_type, var,
 523                          p->field, NULL_TREE);
 524   gfc_add_modify (block, tmp, se.expr);
 525   return p->mask;
 526 }
 527
 528
 529 /* Similar to set_parameter_value except generate runtime
 530    error checks.  */
 531
 532 static unsigned int
 533 set_parameter_value_chk (stmtblock_t *block, bool has_iostat, tree var,
 534                      enum iofield type, gfc_expr *e)
 535 {
 536   gfc_se se;
 537   tree tmp;
 538   gfc_st_parameter_field *p = &st_parameter_field[type];
 539   tree dest_type = TREE_TYPE (p->field);
 540
 541   gfc_init_se (&se, NULL);
 542   gfc_conv_expr_val (&se, e);
 543
 544   /* If we're storing a UNIT number, we need to check it first.  */
 545   if (type == IOPARM_common_unit && e->ts.kind > 4)
 546     {
 547       tree cond, val;
 548       int i;
 549
 550       /* Don't evaluate the UNIT number multiple times.  */
 551       se.expr = gfc_evaluate_now (se.expr, &se.pre);
 552
 553       /* UNIT numbers should be greater than the min.  */
 554       i = gfc_validate_kind (BT_INTEGER, 4, false);
 555       val = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].pedantic_min_int, 4);
 556       cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
 557                               se.expr,
 558                               fold_convert (TREE_TYPE (se.expr), val));
 559       gfc_trans_io_runtime_check (has_iostat, cond, var, LIBERROR_BAD_UNIT,
 560                                   "Unit number in I/O statement too small",
 561                                   &se.pre);
 562
 563       /* UNIT numbers should be less than the max.  */
 564       val = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, 4);
 565       cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
 566                               se.expr,
 567                               fold_convert (TREE_TYPE (se.expr), val));
 568       gfc_trans_io_runtime_check (has_iostat, cond, var, LIBERROR_BAD_UNIT,
 569                                   "Unit number in I/O statement too large",
 570                                   &se.pre);
 571     }
 572
 573   se.expr = convert (dest_type, se.expr);
 574   gfc_add_block_to_block (block, &se.pre);
 575
 576   if (p->param_type == IOPARM_ptype_common)
 577     var = fold_build3_loc (input_location, COMPONENT_REF,
 578                            st_parameter[IOPARM_ptype_common].type,
 579                            var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
 580
 581   tmp = fold_build3_loc (input_location, COMPONENT_REF, dest_type, var,
 582                          p->field, NULL_TREE);
 583   gfc_add_modify (block, tmp, se.expr);
 584   return p->mask;
 585 }
 586
 587
 588 /* Build code to check the unit range if KIND=8 is used.  Similar to
 589    set_parameter_value_chk but we do not generate error calls for
 590    inquire statements.  */
 591
 592 static unsigned int
 593 set_parameter_value_inquire (stmtblock_t *block, tree var,
 594                              enum iofield type, gfc_expr *e)
 595 {
 596   gfc_se se;
 597   gfc_st_parameter_field *p = &st_parameter_field[type];
 598   tree dest_type = TREE_TYPE (p->field);
 599
 600   gfc_init_se (&se, NULL);
 601   gfc_conv_expr_val (&se, e);
 602
 603   /* If we're inquiring on a UNIT number, we need to check to make
 604      sure it exists for larger than kind = 4.  */
 605   if (type == IOPARM_common_unit && e->ts.kind > 4)
 606     {
 607       stmtblock_t newblock;
 608       tree cond1, cond2, cond3, val, body;
 609       int i;
 610
 611       /* Don't evaluate the UNIT number multiple times.  */
 612       se.expr = gfc_evaluate_now (se.expr, &se.pre);
 613
 614       /* UNIT numbers should be greater than zero.  */
 615       i = gfc_validate_kind (BT_INTEGER, 4, false);
 616       cond1 = build2_loc (input_location, LT_EXPR, boolean_type_node,
 617                           se.expr,
 618                           fold_convert (TREE_TYPE (se.expr),
 619                           integer_zero_node));
 620       /* UNIT numbers should be less than the max.  */
 621       val = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, 4);
 622       cond2 = build2_loc (input_location, GT_EXPR, boolean_type_node,
 623                           se.expr,
 624                           fold_convert (TREE_TYPE (se.expr), val));
 625       cond3 = build2_loc (input_location, TRUTH_OR_EXPR,
 626                           boolean_type_node, cond1, cond2);
 627
 628       gfc_start_block (&newblock);
 629
 630       /* The unit number GFC_INVALID_UNIT is reserved.  No units can
 631          ever have this value.  It is used here to signal to the
 632          runtime library that the inquire unit number is outside the
 633          allowable range and so cannot exist.  It is needed when
 634          -fdefault-integer-8 is used.  */
 635       set_parameter_const (&newblock, var, IOPARM_common_unit,
 636                            GFC_INVALID_UNIT);
 637
 638       body = gfc_finish_block (&newblock);
 639
 640       cond3 = gfc_unlikely (cond3, PRED_FORTRAN_FAIL_IO);
 641       var = build3_v (COND_EXPR, cond3, body, build_empty_stmt (input_location));
 642       gfc_add_expr_to_block (&se.pre, var);
 643     }
 644
 645   se.expr = convert (dest_type, se.expr);
 646   gfc_add_block_to_block (block, &se.pre);
 647
 648   return p->mask;
 649 }
 650
 651
 652 /* Generate code to store a non-string I/O parameter into the
 653    st_parameter_XXX structure.  This is pass by reference.  */
 654
 655 static unsigned int
 656 set_parameter_ref (stmtblock_t *block, stmtblock_t *postblock,
 657                    tree var, enum iofield type, gfc_expr *e)
 658 {
 659   gfc_se se;
 660   tree tmp, addr;
 661   gfc_st_parameter_field *p = &st_parameter_field[type];
 662
 663   gcc_assert (e->ts.type == BT_INTEGER || e->ts.type == BT_LOGICAL);
 664   gfc_init_se (&se, NULL);
 665   gfc_conv_expr_lhs (&se, e);
 666
 667   gfc_add_block_to_block (block, &se.pre);
 668
 669   if (TYPE_MODE (TREE_TYPE (se.expr))
 670       == TYPE_MODE (TREE_TYPE (TREE_TYPE (p->field))))
 671     {
 672       addr = convert (TREE_TYPE (p->field), gfc_build_addr_expr (NULL_TREE, se.expr));
 673
 674       /* If this is for the iostat variable initialize the
 675          user variable to LIBERROR_OK which is zero.  */
 676       if (type == IOPARM_common_iostat)
 677         gfc_add_modify (block, se.expr,
 678                              build_int_cst (TREE_TYPE (se.expr), LIBERROR_OK));
 679     }
 680   else
 681     {
 682       /* The type used by the library has different size
 683         from the type of the variable supplied by the user.
 684         Need to use a temporary.  */
 685       tree tmpvar = gfc_create_var (TREE_TYPE (TREE_TYPE (p->field)),
 686                                     st_parameter_field[type].name);
 687
 688       /* If this is for the iostat variable, initialize the
 689          user variable to LIBERROR_OK which is zero.  */
 690       if (type == IOPARM_common_iostat)
 691         gfc_add_modify (block, tmpvar,
 692                              build_int_cst (TREE_TYPE (tmpvar), LIBERROR_OK));
 693
 694       addr = gfc_build_addr_expr (NULL_TREE, tmpvar);
 695         /* After the I/O operation, we set the variable from the temporary.  */
 696       tmp = convert (TREE_TYPE (se.expr), tmpvar);
 697       gfc_add_modify (postblock, se.expr, tmp);
 698      }
 699
 700   if (p->param_type == IOPARM_ptype_common)
 701     var = fold_build3_loc (input_location, COMPONENT_REF,
 702                            st_parameter[IOPARM_ptype_common].type,
 703                            var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
 704   tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field),
 705                          var, p->field, NULL_TREE);
 706   gfc_add_modify (block, tmp, addr);
 707   return p->mask;
 708 }
 709
 710 /* Given an array expr, find its address and length to get a string. If the
 711    array is full, the string's address is the address of array's first element
 712    and the length is the size of the whole array.  If it is an element, the
 713    string's address is the element's address and the length is the rest size of
 714    the array.  */
 715
 716 static void
 717 gfc_convert_array_to_string (gfc_se * se, gfc_expr * e)
 718 {
 719   tree size;
 720
 721   if (e->rank == 0)
 722     {
 723       tree type, array, tmp;
 724       gfc_symbol *sym;
 725       int rank;
 726
 727       /* If it is an element, we need its address and size of the rest.  */
 728       gcc_assert (e->expr_type == EXPR_VARIABLE);
 729       gcc_assert (e->ref->u.ar.type == AR_ELEMENT);
 730       sym = e->symtree->n.sym;
 731       rank = sym->as->rank - 1;
 732       gfc_conv_expr (se, e);
 733
 734       array = sym->backend_decl;
 735       type = TREE_TYPE (array);
 736
 737       if (GFC_ARRAY_TYPE_P (type))
 738         size = GFC_TYPE_ARRAY_SIZE (type);
 739       else
 740         {
 741           gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
 742           size = gfc_conv_array_stride (array, rank);
 743           tmp = fold_build2_loc (input_location, MINUS_EXPR,
 744                                  gfc_array_index_type,
 745                                  gfc_conv_array_ubound (array, rank),
 746                                  gfc_conv_array_lbound (array, rank));
 747           tmp = fold_build2_loc (input_location, PLUS_EXPR,
 748                                  gfc_array_index_type, tmp,
 749                                  gfc_index_one_node);
 750           size = fold_build2_loc (input_location, MULT_EXPR,
 751                                   gfc_array_index_type, tmp, size);
 752         }
 753       gcc_assert (size);
 754
 755       size = fold_build2_loc (input_location, MINUS_EXPR,
 756                               gfc_array_index_type, size,
 757                               TREE_OPERAND (se->expr, 1));
 758       se->expr = gfc_build_addr_expr (NULL_TREE, se->expr);
 759       tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
 760       size = fold_build2_loc (input_location, MULT_EXPR,
 761                               gfc_array_index_type, size,
 762                               fold_convert (gfc_array_index_type, tmp));
 763       se->string_length = fold_convert (gfc_charlen_type_node, size);
 764       return;
 765     }
 766
 767   gfc_conv_array_parameter (se, e, true, NULL, NULL, &size);
 768   se->string_length = fold_convert (gfc_charlen_type_node, size);
 769 }
 770
 771
 772 /* Generate code to store a string and its length into the
 773    st_parameter_XXX structure.  */
 774
 775 static unsigned int
 776 set_string (stmtblock_t * block, stmtblock_t * postblock, tree var,
 777             enum iofield type, gfc_expr * e)
 778 {
 779   gfc_se se;
 780   tree tmp;
 781   tree io;
 782   tree len;
 783   gfc_st_parameter_field *p = &st_parameter_field[type];
 784
 785   gfc_init_se (&se, NULL);
 786
 787   if (p->param_type == IOPARM_ptype_common)
 788     var = fold_build3_loc (input_location, COMPONENT_REF,
 789                            st_parameter[IOPARM_ptype_common].type,
 790                            var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
 791   io = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field),
 792                     var, p->field, NULL_TREE);
 793   len = fold_build3_loc (input_location, COMPONENT_REF,
 794                          TREE_TYPE (p->field_len),
 795                          var, p->field_len, NULL_TREE);
 796
 797   /* Integer variable assigned a format label.  */
 798   if (e->ts.type == BT_INTEGER
 799       && e->rank == 0
 800       && e->symtree->n.sym->attr.assign == 1)
 801     {
 802       char * msg;
 803       tree cond;
 804
 805       gfc_conv_label_variable (&se, e);
 806       tmp = GFC_DECL_STRING_LEN (se.expr);
 807       cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
 808                               tmp, build_int_cst (TREE_TYPE (tmp), 0));
 809
 810       msg = xasprintf ("Label assigned to variable '%s' (%%ld) is not a format "
 811                        "label", e->symtree->name);
 812       gfc_trans_runtime_check (true, false, cond, &se.pre, &e->where, msg,
 813                                fold_convert (long_integer_type_node, tmp));
 814       free (msg);
 815
 816       gfc_add_modify (&se.pre, io,
 817                  fold_convert (TREE_TYPE (io), GFC_DECL_ASSIGN_ADDR (se.expr)));
 818       gfc_add_modify (&se.pre, len, GFC_DECL_STRING_LEN (se.expr));
 819     }
 820   else
 821     {
 822       /* General character.  */
 823       if (e->ts.type == BT_CHARACTER && e->rank == 0)
 824         gfc_conv_expr (&se, e);
 825       /* Array assigned Hollerith constant or character array.  */
 826       else if (e->rank > 0 || (e->symtree && e->symtree->n.sym->as->rank > 0))
 827         gfc_convert_array_to_string (&se, e);
 828       else
 829         gcc_unreachable ();
 830
 831       gfc_conv_string_parameter (&se);
 832       gfc_add_modify (&se.pre, io, fold_convert (TREE_TYPE (io), se.expr));
 833       gfc_add_modify (&se.pre, len, se.string_length);
 834     }
 835
 836   gfc_add_block_to_block (block, &se.pre);
 837   gfc_add_block_to_block (postblock, &se.post);
 838   return p->mask;
 839 }
 840
 841
 842 /* Generate code to store the character (array) and the character length
 843    for an internal unit.  */
 844
 845 static unsigned int
 846 set_internal_unit (stmtblock_t * block, stmtblock_t * post_block,
 847                    tree var, gfc_expr * e)
 848 {
 849   gfc_se se;
 850   tree io;
 851   tree len;
 852   tree desc;
 853   tree tmp;
 854   gfc_st_parameter_field *p;
 855   unsigned int mask;
 856
 857   gfc_init_se (&se, NULL);
 858
 859   p = &st_parameter_field[IOPARM_dt_internal_unit];
 860   mask = p->mask;
 861   io = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field),
 862                         var, p->field, NULL_TREE);
 863   len = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field_len),
 864                          var, p->field_len,     NULL_TREE);
 865   p = &st_parameter_field[IOPARM_dt_internal_unit_desc];
 866   desc = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field),
 867                           var, p->field, NULL_TREE);
 868
 869   gcc_assert (e->ts.type == BT_CHARACTER);
 870
 871   /* Character scalars.  */
 872   if (e->rank == 0)
 873     {
 874       gfc_conv_expr (&se, e);
 875       gfc_conv_string_parameter (&se);
 876       tmp = se.expr;
 877       se.expr = build_int_cst (pchar_type_node, 0);
 878     }
 879
 880   /* Character array.  */
 881   else if (e->rank > 0)
 882     {
 883       if (is_subref_array (e))
 884         {
 885           /* Use a temporary for components of arrays of derived types
 886              or substring array references.  */
 887           gfc_conv_subref_array_arg (&se, e, 0,
 888                 last_dt == READ ? INTENT_IN : INTENT_OUT, false);
 889           tmp = build_fold_indirect_ref_loc (input_location,
 890                                          se.expr);
 891           se.expr = gfc_build_addr_expr (pchar_type_node, tmp);
 892           tmp = gfc_conv_descriptor_data_get (tmp);
 893         }
 894       else
 895         {
 896           /* Return the data pointer and rank from the descriptor.  */
 897           gfc_conv_expr_descriptor (&se, e);
 898           tmp = gfc_conv_descriptor_data_get (se.expr);
 899           se.expr = gfc_build_addr_expr (pchar_type_node, se.expr);
 900         }
 901     }
 902   else
 903     gcc_unreachable ();
 904
 905   /* The cast is needed for character substrings and the descriptor
 906      data.  */
 907   gfc_add_modify (&se.pre, io, fold_convert (TREE_TYPE (io), tmp));
 908   gfc_add_modify (&se.pre, len,
 909                        fold_convert (TREE_TYPE (len), se.string_length));
 910   gfc_add_modify (&se.pre, desc, se.expr);
 911
 912   gfc_add_block_to_block (block, &se.pre);
 913   gfc_add_block_to_block (post_block, &se.post);
 914   return mask;
 915 }
 916
 917 /* Add a case to a IO-result switch.  */
 918
 919 static void
 920 add_case (int label_value, gfc_st_label * label, stmtblock_t * body)
 921 {
 922   tree tmp, value;
 923
 924   if (label == NULL)
 925     return;                     /* No label, no case */
 926
 927   value = build_int_cst (integer_type_node, label_value);
 928
 929   /* Make a backend label for this case.  */
 930   tmp = gfc_build_label_decl (NULL_TREE);
 931
 932   /* And the case itself.  */
 933   tmp = build_case_label (value, NULL_TREE, tmp);
 934   gfc_add_expr_to_block (body, tmp);
 935
 936   /* Jump to the label.  */
 937   tmp = build1_v (GOTO_EXPR, gfc_get_label_decl (label));
 938   gfc_add_expr_to_block (body, tmp);
 939 }
 940
 941
 942 /* Generate a switch statement that branches to the correct I/O
 943    result label.  The last statement of an I/O call stores the
 944    result into a variable because there is often cleanup that
 945    must be done before the switch, so a temporary would have to
 946    be created anyway.  */
 947
 948 static void
 949 io_result (stmtblock_t * block, tree var, gfc_st_label * err_label,
 950            gfc_st_label * end_label, gfc_st_label * eor_label)
 951 {
 952   stmtblock_t body;
 953   tree tmp, rc;
 954   gfc_st_parameter_field *p = &st_parameter_field[IOPARM_common_flags];
 955
 956   /* If no labels are specified, ignore the result instead
 957      of building an empty switch.  */
 958   if (err_label == NULL
 959       && end_label == NULL
 960       && eor_label == NULL)
 961     return;
 962
 963   /* Build a switch statement.  */
 964   gfc_start_block (&body);
 965
 966   /* The label values here must be the same as the values
 967      in the library_return enum in the runtime library */
 968   add_case (1, err_label, &body);
 969   add_case (2, end_label, &body);
 970   add_case (3, eor_label, &body);
 971
 972   tmp = gfc_finish_block (&body);
 973
 974   var = fold_build3_loc (input_location, COMPONENT_REF,
 975                          st_parameter[IOPARM_ptype_common].type,
 976                          var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
 977   rc = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (p->field),
 978                         var, p->field, NULL_TREE);
 979   rc = fold_build2_loc (input_location, BIT_AND_EXPR, TREE_TYPE (rc),
 980                         rc, build_int_cst (TREE_TYPE (rc),
 981                                            IOPARM_common_libreturn_mask));
 982
 983   tmp = fold_build3_loc (input_location, SWITCH_EXPR, NULL_TREE,
 984                          rc, tmp, NULL_TREE);
 985
 986   gfc_add_expr_to_block (block, tmp);
 987 }
 988
 989
 990 /* Store the current file and line number to variables so that if a
 991    library call goes awry, we can tell the user where the problem is.  */
 992
 993 static void
 994 set_error_locus (stmtblock_t * block, tree var, locus * where)
 995 {
 996   gfc_file *f;
 997   tree str, locus_file;
 998   int line;
 999   gfc_st_parameter_field *p = &st_parameter_field[IOPARM_common_filename];
1000
1001   locus_file = fold_build3_loc (input_location, COMPONENT_REF,
1002                                 st_parameter[IOPARM_ptype_common].type,
1003                                 var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
1004   locus_file = fold_build3_loc (input_location, COMPONENT_REF,
1005                                 TREE_TYPE (p->field), locus_file,
1006                                 p->field, NULL_TREE);
1007   f = where->lb->file;
1008   str = gfc_build_cstring_const (f->filename);
1009
1010   str = gfc_build_addr_expr (pchar_type_node, str);
1011   gfc_add_modify (block, locus_file, str);
1012
1013   line = LOCATION_LINE (where->lb->location);
1014   set_parameter_const (block, var, IOPARM_common_line, line);
1015 }
1016
1017
1018 /* Translate an OPEN statement.  */
1019
1020 tree
1021 gfc_trans_open (gfc_code * code)
1022 {
1023   stmtblock_t block, post_block;
1024   gfc_open *p;
1025   tree tmp, var;
1026   unsigned int mask = 0;
1027
1028   gfc_start_block (&block);
1029   gfc_init_block (&post_block);
1030
1031   var = gfc_create_var (st_parameter[IOPARM_ptype_open].type, "open_parm");
1032
1033   set_error_locus (&block, var, &code->loc);
1034   p = code->ext.open;
1035
1036   if (p->iomsg)
1037     mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
1038                         p->iomsg);
1039
1040   if (p->iostat)
1041     mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
1042                                p->iostat);
1043
1044   if (p->err)
1045     mask |= IOPARM_common_err;
1046
1047   if (p->file)
1048     mask |= set_string (&block, &post_block, var, IOPARM_open_file, p->file);
1049
1050   if (p->status)
1051     mask |= set_string (&block, &post_block, var, IOPARM_open_status,
1052                         p->status);
1053
1054   if (p->access)
1055     mask |= set_string (&block, &post_block, var, IOPARM_open_access,
1056                         p->access);
1057
1058   if (p->form)
1059     mask |= set_string (&block, &post_block, var, IOPARM_open_form, p->form);
1060
1061   if (p->recl)
1062     mask |= set_parameter_value (&block, var, IOPARM_open_recl_in,
1063                                  p->recl);
1064
1065   if (p->blank)
1066     mask |= set_string (&block, &post_block, var, IOPARM_open_blank,
1067                         p->blank);
1068
1069   if (p->position)
1070     mask |= set_string (&block, &post_block, var, IOPARM_open_position,
1071                         p->position);
1072
1073   if (p->action)
1074     mask |= set_string (&block, &post_block, var, IOPARM_open_action,
1075                         p->action);
1076
1077   if (p->delim)
1078     mask |= set_string (&block, &post_block, var, IOPARM_open_delim,
1079                         p->delim);
1080
1081   if (p->pad)
1082     mask |= set_string (&block, &post_block, var, IOPARM_open_pad, p->pad);
1083
1084   if (p->decimal)
1085     mask |= set_string (&block, &post_block, var, IOPARM_open_decimal,
1086                         p->decimal);
1087
1088   if (p->encoding)
1089     mask |= set_string (&block, &post_block, var, IOPARM_open_encoding,
1090                         p->encoding);
1091
1092   if (p->round)
1093     mask |= set_string (&block, &post_block, var, IOPARM_open_round, p->round);
1094
1095   if (p->sign)
1096     mask |= set_string (&block, &post_block, var, IOPARM_open_sign, p->sign);
1097
1098   if (p->asynchronous)
1099     mask |= set_string (&block, &post_block, var, IOPARM_open_asynchronous,
1100                         p->asynchronous);
1101
1102   if (p->convert)
1103     mask |= set_string (&block, &post_block, var, IOPARM_open_convert,
1104                         p->convert);
1105
1106   if (p->newunit)
1107     mask |= set_parameter_ref (&block, &post_block, var, IOPARM_open_newunit,
1108                                p->newunit);
1109
1110   set_parameter_const (&block, var, IOPARM_common_flags, mask);
1111
1112   if (p->unit)
1113     set_parameter_value_chk (&block, p->iostat, var, IOPARM_common_unit, p->unit);
1114   else
1115     set_parameter_const (&block, var, IOPARM_common_unit, 0);
1116
1117   tmp = gfc_build_addr_expr (NULL_TREE, var);
1118   tmp = build_call_expr_loc (input_location,
1119                          iocall[IOCALL_OPEN], 1, tmp);
1120   gfc_add_expr_to_block (&block, tmp);
1121
1122   gfc_add_block_to_block (&block, &post_block);
1123
1124   io_result (&block, var, p->err, NULL, NULL);
1125
1126   return gfc_finish_block (&block);
1127 }
1128
1129
1130 /* Translate a CLOSE statement.  */
1131
1132 tree
1133 gfc_trans_close (gfc_code * code)
1134 {
1135   stmtblock_t block, post_block;
1136   gfc_close *p;
1137   tree tmp, var;
1138   unsigned int mask = 0;
1139
1140   gfc_start_block (&block);
1141   gfc_init_block (&post_block);
1142
1143   var = gfc_create_var (st_parameter[IOPARM_ptype_close].type, "close_parm");
1144
1145   set_error_locus (&block, var, &code->loc);
1146   p = code->ext.close;
1147
1148   if (p->iomsg)
1149     mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
1150                         p->iomsg);
1151
1152   if (p->iostat)
1153     mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
1154                                p->iostat);
1155
1156   if (p->err)
1157     mask |= IOPARM_common_err;
1158
1159   if (p->status)
1160     mask |= set_string (&block, &post_block, var, IOPARM_close_status,
1161                         p->status);
1162
1163   set_parameter_const (&block, var, IOPARM_common_flags, mask);
1164
1165   if (p->unit)
1166     set_parameter_value_chk (&block, p->iostat, var, IOPARM_common_unit, p->unit);
1167   else
1168     set_parameter_const (&block, var, IOPARM_common_unit, 0);
1169
1170   tmp = gfc_build_addr_expr (NULL_TREE, var);
1171   tmp = build_call_expr_loc (input_location,
1172                          iocall[IOCALL_CLOSE], 1, tmp);
1173   gfc_add_expr_to_block (&block, tmp);
1174
1175   gfc_add_block_to_block (&block, &post_block);
1176
1177   io_result (&block, var, p->err, NULL, NULL);
1178
1179   return gfc_finish_block (&block);
1180 }
1181
1182
1183 /* Common subroutine for building a file positioning statement.  */
1184
1185 static tree
1186 build_filepos (tree function, gfc_code * code)
1187 {
1188   stmtblock_t block, post_block;
1189   gfc_filepos *p;
1190   tree tmp, var;
1191   unsigned int mask = 0;
1192
1193   p = code->ext.filepos;
1194
1195   gfc_start_block (&block);
1196   gfc_init_block (&post_block);
1197
1198   var = gfc_create_var (st_parameter[IOPARM_ptype_filepos].type,
1199                         "filepos_parm");
1200
1201   set_error_locus (&block, var, &code->loc);
1202
1203   if (p->iomsg)
1204     mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
1205                         p->iomsg);
1206
1207   if (p->iostat)
1208     mask |= set_parameter_ref (&block, &post_block, var,
1209                                IOPARM_common_iostat, p->iostat);
1210
1211   if (p->err)
1212     mask |= IOPARM_common_err;
1213
1214   set_parameter_const (&block, var, IOPARM_common_flags, mask);
1215
1216   if (p->unit)
1217     set_parameter_value_chk (&block, p->iostat, var, IOPARM_common_unit,
1218                              p->unit);
1219   else
1220     set_parameter_const (&block, var, IOPARM_common_unit, 0);
1221
1222   tmp = gfc_build_addr_expr (NULL_TREE, var);
1223   tmp = build_call_expr_loc (input_location,
1224                          function, 1, tmp);
1225   gfc_add_expr_to_block (&block, tmp);
1226
1227   gfc_add_block_to_block (&block, &post_block);
1228
1229   io_result (&block, var, p->err, NULL, NULL);
1230
1231   return gfc_finish_block (&block);
1232 }
1233
1234
1235 /* Translate a BACKSPACE statement.  */
1236
1237 tree
1238 gfc_trans_backspace (gfc_code * code)
1239 {
1240   return build_filepos (iocall[IOCALL_BACKSPACE], code);
1241 }
1242
1243
1244 /* Translate an ENDFILE statement.  */
1245
1246 tree
1247 gfc_trans_endfile (gfc_code * code)
1248 {
1249   return build_filepos (iocall[IOCALL_ENDFILE], code);
1250 }
1251
1252
1253 /* Translate a REWIND statement.  */
1254
1255 tree
1256 gfc_trans_rewind (gfc_code * code)
1257 {
1258   return build_filepos (iocall[IOCALL_REWIND], code);
1259 }
1260
1261
1262 /* Translate a FLUSH statement.  */
1263
1264 tree
1265 gfc_trans_flush (gfc_code * code)
1266 {
1267   return build_filepos (iocall[IOCALL_FLUSH], code);
1268 }
1269
1270
1271 /* Translate the non-IOLENGTH form of an INQUIRE statement.  */
1272
1273 tree
1274 gfc_trans_inquire (gfc_code * code)
1275 {
1276   stmtblock_t block, post_block;
1277   gfc_inquire *p;
1278   tree tmp, var;
1279   unsigned int mask = 0, mask2 = 0;
1280
1281   gfc_start_block (&block);
1282   gfc_init_block (&post_block);
1283
1284   var = gfc_create_var (st_parameter[IOPARM_ptype_inquire].type,
1285                         "inquire_parm");
1286
1287   set_error_locus (&block, var, &code->loc);
1288   p = code->ext.inquire;
1289
1290   if (p->iomsg)
1291     mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
1292                         p->iomsg);
1293
1294   if (p->iostat)
1295     mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
1296                                p->iostat);
1297
1298   if (p->err)
1299     mask |= IOPARM_common_err;
1300
1301   /* Sanity check.  */
1302   if (p->unit && p->file)
1303     gfc_error ("INQUIRE statement at %L cannot contain both FILE and UNIT specifiers", &code->loc);
1304
1305   if (p->file)
1306     mask |= set_string (&block, &post_block, var, IOPARM_inquire_file,
1307                         p->file);
1308
1309   if (p->exist)
1310     mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_exist,
1311                                  p->exist);
1312
1313   if (p->opened)
1314     mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_opened,
1315                                p->opened);
1316
1317   if (p->number)
1318     mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_number,
1319                                p->number);
1320
1321   if (p->named)
1322     mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_named,
1323                                p->named);
1324
1325   if (p->name)
1326     mask |= set_string (&block, &post_block, var, IOPARM_inquire_name,
1327                         p->name);
1328
1329   if (p->access)
1330     mask |= set_string (&block, &post_block, var, IOPARM_inquire_access,
1331                         p->access);
1332
1333   if (p->sequential)
1334     mask |= set_string (&block, &post_block, var, IOPARM_inquire_sequential,
1335                         p->sequential);
1336
1337   if (p->direct)
1338     mask |= set_string (&block, &post_block, var, IOPARM_inquire_direct,
1339                         p->direct);
1340
1341   if (p->form)
1342     mask |= set_string (&block, &post_block, var, IOPARM_inquire_form,
1343                         p->form);
1344
1345   if (p->formatted)
1346     mask |= set_string (&block, &post_block, var, IOPARM_inquire_formatted,
1347                         p->formatted);
1348
1349   if (p->unformatted)
1350     mask |= set_string (&block, &post_block, var, IOPARM_inquire_unformatted,
1351                         p->unformatted);
1352
1353   if (p->recl)
1354     mask |= set_parameter_ref (&block, &post_block, var,
1355                                IOPARM_inquire_recl_out, p->recl);
1356
1357   if (p->nextrec)
1358     mask |= set_parameter_ref (&block, &post_block, var,
1359                                IOPARM_inquire_nextrec, p->nextrec);
1360
1361   if (p->blank)
1362     mask |= set_string (&block, &post_block, var, IOPARM_inquire_blank,
1363                         p->blank);
1364
1365   if (p->delim)
1366     mask |= set_string (&block, &post_block, var, IOPARM_inquire_delim,
1367                         p->delim);
1368
1369   if (p->position)
1370     mask |= set_string (&block, &post_block, var, IOPARM_inquire_position,
1371                         p->position);
1372
1373   if (p->action)
1374     mask |= set_string (&block, &post_block, var, IOPARM_inquire_action,
1375                         p->action);
1376
1377   if (p->read)
1378     mask |= set_string (&block, &post_block, var, IOPARM_inquire_read,
1379                         p->read);
1380
1381   if (p->write)
1382     mask |= set_string (&block, &post_block, var, IOPARM_inquire_write,
1383                         p->write);
1384
1385   if (p->readwrite)
1386     mask |= set_string (&block, &post_block, var, IOPARM_inquire_readwrite,
1387                         p->readwrite);
1388
1389   if (p->pad)
1390     mask |= set_string (&block, &post_block, var, IOPARM_inquire_pad,
1391                         p->pad);
1392
1393   if (p->convert)
1394     mask |= set_string (&block, &post_block, var, IOPARM_inquire_convert,
1395                         p->convert);
1396
1397   if (p->strm_pos)
1398     mask |= set_parameter_ref (&block, &post_block, var,
1399                                IOPARM_inquire_strm_pos_out, p->strm_pos);
1400
1401   /* The second series of flags.  */
1402   if (p->asynchronous)
1403     mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_asynchronous,
1404                          p->asynchronous);
1405
1406   if (p->decimal)
1407     mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_decimal,
1408                          p->decimal);
1409
1410   if (p->encoding)
1411     mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_encoding,
1412                          p->encoding);
1413
1414   if (p->round)
1415     mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_round,
1416                          p->round);
1417
1418   if (p->sign)
1419     mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_sign,
1420                          p->sign);
1421
1422   if (p->pending)
1423     mask2 |= set_parameter_ref (&block, &post_block, var,
1424                                 IOPARM_inquire_pending, p->pending);
1425
1426   if (p->size)
1427     mask2 |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_size,
1428                                 p->size);
1429
1430   if (p->id)
1431     mask2 |= set_parameter_ref (&block, &post_block,var, IOPARM_inquire_id,
1432                                 p->id);
1433   if (p->iqstream)
1434     mask2 |= set_string (&block, &post_block, var, IOPARM_inquire_iqstream,
1435                          p->iqstream);
1436
1437   if (mask2)
1438     mask |= set_parameter_const (&block, var, IOPARM_inquire_flags2, mask2);
1439
1440   set_parameter_const (&block, var, IOPARM_common_flags, mask);
1441
1442   if (p->unit)
1443     {
1444       set_parameter_value (&block, var, IOPARM_common_unit, p->unit);
1445       set_parameter_value_inquire (&block, var, IOPARM_common_unit, p->unit);
1446     }
1447   else
1448     set_parameter_const (&block, var, IOPARM_common_unit, 0);
1449
1450   tmp = gfc_build_addr_expr (NULL_TREE, var);
1451   tmp = build_call_expr_loc (input_location,
1452                          iocall[IOCALL_INQUIRE], 1, tmp);
1453   gfc_add_expr_to_block (&block, tmp);
1454
1455   gfc_add_block_to_block (&block, &post_block);
1456
1457   io_result (&block, var, p->err, NULL, NULL);
1458
1459   return gfc_finish_block (&block);
1460 }
1461
1462
1463 tree
1464 gfc_trans_wait (gfc_code * code)
1465 {
1466   stmtblock_t block, post_block;
1467   gfc_wait *p;
1468   tree tmp, var;
1469   unsigned int mask = 0;
1470
1471   gfc_start_block (&block);
1472   gfc_init_block (&post_block);
1473
1474   var = gfc_create_var (st_parameter[IOPARM_ptype_wait].type,
1475                         "wait_parm");
1476
1477   set_error_locus (&block, var, &code->loc);
1478   p = code->ext.wait;
1479
1480   /* Set parameters here.  */
1481   if (p->iomsg)
1482     mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
1483                         p->iomsg);
1484
1485   if (p->iostat)
1486     mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
1487                                p->iostat);
1488
1489   if (p->err)
1490     mask |= IOPARM_common_err;
1491
1492   if (p->id)
1493     mask |= set_parameter_value (&block, var, IOPARM_wait_id, p->id);
1494
1495   set_parameter_const (&block, var, IOPARM_common_flags, mask);
1496
1497   if (p->unit)
1498     set_parameter_value_chk (&block, p->iostat, var, IOPARM_common_unit, p->unit);
1499
1500   tmp = gfc_build_addr_expr (NULL_TREE, var);
1501   tmp = build_call_expr_loc (input_location,
1502                          iocall[IOCALL_WAIT], 1, tmp);
1503   gfc_add_expr_to_block (&block, tmp);
1504
1505   gfc_add_block_to_block (&block, &post_block);
1506
1507   io_result (&block, var, p->err, NULL, NULL);
1508
1509   return gfc_finish_block (&block);
1510
1511 }
1512
1513
1514 /* nml_full_name builds up the fully qualified name of a
1515    derived type component. '+' is used to denote a type extension.  */
1516
1517 static char*
1518 nml_full_name (const char* var_name, const char* cmp_name, bool parent)
1519 {
1520   int full_name_length;
1521   char * full_name;
1522
1523   full_name_length = strlen (var_name) + strlen (cmp_name) + 1;
1524   full_name = XCNEWVEC (char, full_name_length + 1);
1525   strcpy (full_name, var_name);
1526   full_name = strcat (full_name, parent ? "+" : "%");
1527   full_name = strcat (full_name, cmp_name);
1528   return full_name;
1529 }
1530
1531
1532 /* nml_get_addr_expr builds an address expression from the
1533    gfc_symbol or gfc_component backend_decl's. An offset is
1534    provided so that the address of an element of an array of
1535    derived types is returned. This is used in the runtime to
1536    determine that span of the derived type.  */
1537
1538 static tree
1539 nml_get_addr_expr (gfc_symbol * sym, gfc_component * c,
1540                    tree base_addr)
1541 {
1542   tree decl = NULL_TREE;
1543   tree tmp;
1544
1545   if (sym)
1546     {
1547       sym->attr.referenced = 1;
1548       decl = gfc_get_symbol_decl (sym);
1549
1550       /* If this is the enclosing function declaration, use
1551          the fake result instead.  */
1552       if (decl == current_function_decl)
1553         decl = gfc_get_fake_result_decl (sym, 0);
1554       else if (decl == DECL_CONTEXT (current_function_decl))
1555         decl =  gfc_get_fake_result_decl (sym, 1);
1556     }
1557   else
1558     decl = c->backend_decl;
1559
1560   gcc_assert (decl && ((TREE_CODE (decl) == FIELD_DECL
1561                      || TREE_CODE (decl) == VAR_DECL
1562                      || TREE_CODE (decl) == PARM_DECL)
1563                      || TREE_CODE (decl) == COMPONENT_REF));
1564
1565   tmp = decl;
1566
1567   /* Build indirect reference, if dummy argument.  */
1568
1569   if (POINTER_TYPE_P (TREE_TYPE(tmp)))
1570     tmp = build_fold_indirect_ref_loc (input_location, tmp);
1571
1572   /* Treat the component of a derived type, using base_addr for
1573      the derived type.  */
1574
1575   if (TREE_CODE (decl) == FIELD_DECL)
1576     tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
1577                            base_addr, tmp, NULL_TREE);
1578
1579   if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
1580     tmp = gfc_conv_array_data (tmp);
1581   else
1582     {
1583       if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
1584         tmp = gfc_build_addr_expr (NULL_TREE, tmp);
1585
1586       if (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE)
1587          tmp = gfc_build_array_ref (tmp, gfc_index_zero_node, NULL);
1588
1589       if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
1590         tmp = build_fold_indirect_ref_loc (input_location,
1591                                    tmp);
1592     }
1593
1594   gcc_assert (tmp && POINTER_TYPE_P (TREE_TYPE (tmp)));
1595
1596   return tmp;
1597 }
1598
1599
1600 /* For an object VAR_NAME whose base address is BASE_ADDR, generate a
1601    call to iocall[IOCALL_SET_NML_VAL].  For derived type variable, recursively
1602    generate calls to iocall[IOCALL_SET_NML_VAL] for each component.  */
1603
1604 #define IARG(i) build_int_cst (gfc_array_index_type, i)
1605
1606 static void
1607 transfer_namelist_element (stmtblock_t * block, const char * var_name,
1608                            gfc_symbol * sym, gfc_component * c,
1609                            tree base_addr)
1610 {
1611   gfc_typespec * ts = NULL;
1612   gfc_array_spec * as = NULL;
1613   tree addr_expr = NULL;
1614   tree dt = NULL;
1615   tree string;
1616   tree tmp;
1617   tree dtype;
1618   tree dt_parm_addr;
1619   tree decl = NULL_TREE;
1620   tree gfc_int4_type_node = gfc_get_int_type (4);
1621   int n_dim;
1622   int itype;
1623   int rank = 0;
1624
1625   gcc_assert (sym || c);
1626
1627   /* Build the namelist object name.  */
1628
1629   string = gfc_build_cstring_const (var_name);
1630   string = gfc_build_addr_expr (pchar_type_node, string);
1631
1632   /* Build ts, as and data address using symbol or component.  */
1633
1634   ts = (sym) ? &sym->ts : &c->ts;
1635   as = (sym) ? sym->as : c->as;
1636
1637   addr_expr = nml_get_addr_expr (sym, c, base_addr);
1638
1639   if (as)
1640     rank = as->rank;
1641
1642   if (rank)
1643     {
1644       decl = (sym) ? sym->backend_decl : c->backend_decl;
1645       if (sym && sym->attr.dummy)
1646         decl = build_fold_indirect_ref_loc (input_location, decl);
1647       dt =  TREE_TYPE (decl);
1648       dtype = gfc_get_dtype (dt);
1649     }
1650   else
1651     {
1652       itype = ts->type;
1653       dtype = IARG (itype << GFC_DTYPE_TYPE_SHIFT);
1654     }
1655
1656   /* Build up the arguments for the transfer call.
1657      The call for the scalar part transfers:
1658      (address, name, type, kind or string_length, dtype)  */
1659
1660   dt_parm_addr = gfc_build_addr_expr (NULL_TREE, dt_parm);
1661
1662   if (ts->type == BT_CHARACTER)
1663     tmp = ts->u.cl->backend_decl;
1664   else
1665     tmp = build_int_cst (gfc_charlen_type_node, 0);
1666   tmp = build_call_expr_loc (input_location,
1667                          iocall[IOCALL_SET_NML_VAL], 6,
1668                          dt_parm_addr, addr_expr, string,
1669                          build_int_cst (gfc_int4_type_node, ts->kind),
1670                          tmp, dtype);
1671   gfc_add_expr_to_block (block, tmp);
1672
1673   /* If the object is an array, transfer rank times:
1674      (null pointer, name, stride, lbound, ubound)  */
1675
1676   for ( n_dim = 0 ; n_dim < rank ; n_dim++ )
1677     {
1678       tmp = build_call_expr_loc (input_location,
1679                              iocall[IOCALL_SET_NML_VAL_DIM], 5,
1680                              dt_parm_addr,
1681                              build_int_cst (gfc_int4_type_node, n_dim),
1682                              gfc_conv_array_stride (decl, n_dim),
1683                              gfc_conv_array_lbound (decl, n_dim),
1684                              gfc_conv_array_ubound (decl, n_dim));
1685       gfc_add_expr_to_block (block, tmp);
1686     }
1687
1688   if (gfc_bt_struct (ts->type) && ts->u.derived->components)
1689     {
1690       gfc_component *cmp;
1691
1692       /* Provide the RECORD_TYPE to build component references.  */
1693
1694       tree expr = build_fold_indirect_ref_loc (input_location,
1695                                            addr_expr);
1696
1697       for (cmp = ts->u.derived->components; cmp; cmp = cmp->next)
1698         {
1699           char *full_name = nml_full_name (var_name, cmp->name,
1700                                            ts->u.derived->attr.extension);
1701           transfer_namelist_element (block,
1702                                      full_name,
1703                                      NULL, cmp, expr);
1704           free (full_name);
1705         }
1706     }
1707 }
1708
1709 #undef IARG
1710
1711 /* Create a data transfer statement.  Not all of the fields are valid
1712    for both reading and writing, but improper use has been filtered
1713    out by now.  */
1714
1715 static tree
1716 build_dt (tree function, gfc_code * code)
1717 {
1718   stmtblock_t block, post_block, post_end_block, post_iu_block;
1719   gfc_dt *dt;
1720   tree tmp, var;
1721   gfc_expr *nmlname;
1722   gfc_namelist *nml;
1723   unsigned int mask = 0;
1724
1725   gfc_start_block (&block);
1726   gfc_init_block (&post_block);
1727   gfc_init_block (&post_end_block);
1728   gfc_init_block (&post_iu_block);
1729
1730   var = gfc_create_var (st_parameter[IOPARM_ptype_dt].type, "dt_parm");
1731
1732   set_error_locus (&block, var, &code->loc);
1733
1734   if (last_dt == IOLENGTH)
1735     {
1736       gfc_inquire *inq;
1737
1738       inq = code->ext.inquire;
1739
1740       /* First check that preconditions are met.  */
1741       gcc_assert (inq != NULL);
1742       gcc_assert (inq->iolength != NULL);
1743
1744       /* Connect to the iolength variable.  */
1745       mask |= set_parameter_ref (&block, &post_end_block, var,
1746                                  IOPARM_dt_iolength, inq->iolength);
1747       dt = NULL;
1748     }
1749   else
1750     {
1751       dt = code->ext.dt;
1752       gcc_assert (dt != NULL);
1753     }
1754
1755   if (dt && dt->io_unit)
1756     {
1757       if (dt->io_unit->ts.type == BT_CHARACTER)
1758         {
1759           mask |= set_internal_unit (&block, &post_iu_block,
1760                                      var, dt->io_unit);
1761           set_parameter_const (&block, var, IOPARM_common_unit,
1762                                dt->io_unit->ts.kind == 1 ? 0 : -1);
1763         }
1764     }
1765   else
1766     set_parameter_const (&block, var, IOPARM_common_unit, 0);
1767
1768   if (dt)
1769     {
1770       if (dt->iomsg)
1771         mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
1772                             dt->iomsg);
1773
1774       if (dt->iostat)
1775         mask |= set_parameter_ref (&block, &post_end_block, var,
1776                                    IOPARM_common_iostat, dt->iostat);
1777
1778       if (dt->err)
1779         mask |= IOPARM_common_err;
1780
1781       if (dt->eor)
1782         mask |= IOPARM_common_eor;
1783
1784       if (dt->end)
1785         mask |= IOPARM_common_end;
1786
1787       if (dt->id)
1788         mask |= set_parameter_ref (&block, &post_end_block, var,
1789                                    IOPARM_dt_id, dt->id);
1790
1791       if (dt->pos)
1792         mask |= set_parameter_value (&block, var, IOPARM_dt_pos, dt->pos);
1793
1794       if (dt->asynchronous)
1795         mask |= set_string (&block, &post_block, var,
1796                             IOPARM_dt_asynchronous, dt->asynchronous);
1797
1798       if (dt->blank)
1799         mask |= set_string (&block, &post_block, var, IOPARM_dt_blank,
1800                             dt->blank);
1801
1802       if (dt->decimal)
1803         mask |= set_string (&block, &post_block, var, IOPARM_dt_decimal,
1804                             dt->decimal);
1805
1806       if (dt->delim)
1807         mask |= set_string (&block, &post_block, var, IOPARM_dt_delim,
1808                             dt->delim);
1809
1810       if (dt->pad)
1811         mask |= set_string (&block, &post_block, var, IOPARM_dt_pad,
1812                             dt->pad);
1813
1814       if (dt->round)
1815         mask |= set_string (&block, &post_block, var, IOPARM_dt_round,
1816                             dt->round);
1817
1818       if (dt->sign)
1819         mask |= set_string (&block, &post_block, var, IOPARM_dt_sign,
1820                             dt->sign);
1821
1822       if (dt->rec)
1823         mask |= set_parameter_value (&block, var, IOPARM_dt_rec, dt->rec);
1824
1825       if (dt->advance)
1826         mask |= set_string (&block, &post_block, var, IOPARM_dt_advance,
1827                             dt->advance);
1828
1829       if (dt->format_expr)
1830         mask |= set_string (&block, &post_end_block, var, IOPARM_dt_format,
1831                             dt->format_expr);
1832
1833       if (dt->format_label)
1834         {
1835           if (dt->format_label == &format_asterisk)
1836             mask |= IOPARM_dt_list_format;
1837           else
1838             mask |= set_string (&block, &post_block, var, IOPARM_dt_format,
1839                                 dt->format_label->format);
1840         }
1841
1842       if (dt->size)
1843         mask |= set_parameter_ref (&block, &post_end_block, var,
1844                                    IOPARM_dt_size, dt->size);
1845
1846       if (dt->namelist)
1847         {
1848           if (dt->format_expr || dt->format_label)
1849             gfc_internal_error ("build_dt: format with namelist");
1850
1851           nmlname = gfc_get_character_expr (gfc_default_character_kind, NULL,
1852                                             dt->namelist->name,
1853                                             strlen (dt->namelist->name));
1854
1855           mask |= set_string (&block, &post_block, var, IOPARM_dt_namelist_name,
1856                               nmlname);
1857
1858           gfc_free_expr (nmlname);
1859
1860           if (last_dt == READ)
1861             mask |= IOPARM_dt_namelist_read_mode;
1862
1863           set_parameter_const (&block, var, IOPARM_common_flags, mask);
1864
1865           dt_parm = var;
1866
1867           for (nml = dt->namelist->namelist; nml; nml = nml->next)
1868             transfer_namelist_element (&block, nml->sym->name, nml->sym,
1869                                        NULL, NULL_TREE);
1870         }
1871       else
1872         set_parameter_const (&block, var, IOPARM_common_flags, mask);
1873
1874       if (dt->io_unit && dt->io_unit->ts.type == BT_INTEGER)
1875         set_parameter_value_chk (&block, dt->iostat, var,
1876                                  IOPARM_common_unit, dt->io_unit);
1877     }
1878   else
1879     set_parameter_const (&block, var, IOPARM_common_flags, mask);
1880
1881   tmp = gfc_build_addr_expr (NULL_TREE, var);
1882   tmp = build_call_expr_loc (UNKNOWN_LOCATION,
1883                          function, 1, tmp);
1884   gfc_add_expr_to_block (&block, tmp);
1885
1886   gfc_add_block_to_block (&block, &post_block);
1887
1888   dt_parm = var;
1889   dt_post_end_block = &post_end_block;
1890
1891   /* Set implied do loop exit condition.  */
1892   if (last_dt == READ || last_dt == WRITE)
1893     {
1894       gfc_st_parameter_field *p = &st_parameter_field[IOPARM_common_flags];
1895
1896       tmp = fold_build3_loc (input_location, COMPONENT_REF,
1897                              st_parameter[IOPARM_ptype_common].type,
1898                              dt_parm, TYPE_FIELDS (TREE_TYPE (dt_parm)),
1899                              NULL_TREE);
1900       tmp = fold_build3_loc (input_location, COMPONENT_REF,
1901                              TREE_TYPE (p->field), tmp, p->field, NULL_TREE);
1902       tmp = fold_build2_loc (input_location, BIT_AND_EXPR, TREE_TYPE (tmp),
1903                              tmp, build_int_cst (TREE_TYPE (tmp),
1904                              IOPARM_common_libreturn_mask));
1905     }
1906   else /* IOLENGTH */
1907     tmp = NULL_TREE;
1908
1909   gfc_add_expr_to_block (&block, gfc_trans_code_cond (code->block->next, tmp));
1910
1911   gfc_add_block_to_block (&block, &post_iu_block);
1912
1913   dt_parm = NULL;
1914   dt_post_end_block = NULL;
1915
1916   return gfc_finish_block (&block);
1917 }
1918
1919
1920 /* Translate the IOLENGTH form of an INQUIRE statement.  We treat
1921    this as a third sort of data transfer statement, except that
1922    lengths are summed instead of actually transferring any data.  */
1923
1924 tree
1925 gfc_trans_iolength (gfc_code * code)
1926 {
1927   last_dt = IOLENGTH;
1928   return build_dt (iocall[IOCALL_IOLENGTH], code);
1929 }
1930
1931
1932 /* Translate a READ statement.  */
1933
1934 tree
1935 gfc_trans_read (gfc_code * code)
1936 {
1937   last_dt = READ;
1938   return build_dt (iocall[IOCALL_READ], code);
1939 }
1940
1941
1942 /* Translate a WRITE statement */
1943
1944 tree
1945 gfc_trans_write (gfc_code * code)
1946 {
1947   last_dt = WRITE;
1948   return build_dt (iocall[IOCALL_WRITE], code);
1949 }
1950
1951
1952 /* Finish a data transfer statement.  */
1953
1954 tree
1955 gfc_trans_dt_end (gfc_code * code)
1956 {
1957   tree function, tmp;
1958   stmtblock_t block;
1959
1960   gfc_init_block (&block);
1961
1962   switch (last_dt)
1963     {
1964     case READ:
1965       function = iocall[IOCALL_READ_DONE];
1966       break;
1967
1968     case WRITE:
1969       function = iocall[IOCALL_WRITE_DONE];
1970       break;
1971
1972     case IOLENGTH:
1973       function = iocall[IOCALL_IOLENGTH_DONE];
1974       break;
1975
1976     default:
1977       gcc_unreachable ();
1978     }
1979
1980   tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
1981   tmp = build_call_expr_loc (input_location,
1982                          function, 1, tmp);
1983   gfc_add_expr_to_block (&block, tmp);
1984   gfc_add_block_to_block (&block, dt_post_end_block);
1985   gfc_init_block (dt_post_end_block);
1986
1987   if (last_dt != IOLENGTH)
1988     {
1989       gcc_assert (code->ext.dt != NULL);
1990       io_result (&block, dt_parm, code->ext.dt->err,
1991                  code->ext.dt->end, code->ext.dt->eor);
1992     }
1993
1994   return gfc_finish_block (&block);
1995 }
1996
1997 static void
1998 transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr, gfc_code * code);
1999
2000 /* Given an array field in a derived type variable, generate the code
2001    for the loop that iterates over array elements, and the code that
2002    accesses those array elements.  Use transfer_expr to generate code
2003    for transferring that element.  Because elements may also be
2004    derived types, transfer_expr and transfer_array_component are mutually
2005    recursive.  */
2006
2007 static tree
2008 transfer_array_component (tree expr, gfc_component * cm, locus * where)
2009 {
2010   tree tmp;
2011   stmtblock_t body;
2012   stmtblock_t block;
2013   gfc_loopinfo loop;
2014   int n;
2015   gfc_ss *ss;
2016   gfc_se se;
2017   gfc_array_info *ss_array;
2018
2019   gfc_start_block (&block);
2020   gfc_init_se (&se, NULL);
2021
2022   /* Create and initialize Scalarization Status.  Unlike in
2023      gfc_trans_transfer, we can't simply use gfc_walk_expr to take
2024      care of this task, because we don't have a gfc_expr at hand.
2025      Build one manually, as in gfc_trans_subarray_assign.  */
2026
2027   ss = gfc_get_array_ss (gfc_ss_terminator, NULL, cm->as->rank,
2028                          GFC_SS_COMPONENT);
2029   ss_array = &ss->info->data.array;
2030   ss_array->shape = gfc_get_shape (cm->as->rank);
2031   ss_array->descriptor = expr;
2032   ss_array->data = gfc_conv_array_data (expr);
2033   ss_array->offset = gfc_conv_array_offset (expr);
2034   for (n = 0; n < cm->as->rank; n++)
2035     {
2036       ss_array->start[n] = gfc_conv_array_lbound (expr, n);
2037       ss_array->stride[n] = gfc_index_one_node;
2038
2039       mpz_init (ss_array->shape[n]);
2040       mpz_sub (ss_array->shape[n], cm->as->upper[n]->value.integer,
2041                cm->as->lower[n]->value.integer);
2042       mpz_add_ui (ss_array->shape[n], ss_array->shape[n], 1);
2043     }
2044
2045   /* Once we got ss, we use scalarizer to create the loop.  */
2046
2047   gfc_init_loopinfo (&loop);
2048   gfc_add_ss_to_loop (&loop, ss);
2049   gfc_conv_ss_startstride (&loop);
2050   gfc_conv_loop_setup (&loop, where);
2051   gfc_mark_ss_chain_used (ss, 1);
2052   gfc_start_scalarized_body (&loop, &body);
2053
2054   gfc_copy_loopinfo_to_se (&se, &loop);
2055   se.ss = ss;
2056
2057   /* gfc_conv_tmp_array_ref assumes that se.expr contains the array.  */
2058   se.expr = expr;
2059   gfc_conv_tmp_array_ref (&se);
2060
2061   /* Now se.expr contains an element of the array.  Take the address and pass
2062      it to the IO routines.  */
2063   tmp = gfc_build_addr_expr (NULL_TREE, se.expr);
2064   transfer_expr (&se, &cm->ts, tmp, NULL);
2065
2066   /* We are done now with the loop body.  Wrap up the scalarizer and
2067      return.  */
2068
2069   gfc_add_block_to_block (&body, &se.pre);
2070   gfc_add_block_to_block (&body, &se.post);
2071
2072   gfc_trans_scalarizing_loops (&loop, &body);
2073
2074   gfc_add_block_to_block (&block, &loop.pre);
2075   gfc_add_block_to_block (&block, &loop.post);
2076
2077   gcc_assert (ss_array->shape != NULL);
2078   gfc_free_shape (&ss_array->shape, cm->as->rank);
2079   gfc_cleanup_loop (&loop);
2080
2081   return gfc_finish_block (&block);
2082 }
2083
2084 /* Generate the call for a scalar transfer node.  */
2085
2086 static void
2087 transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr, gfc_code * code)
2088 {
2089   tree tmp, function, arg2, arg3, field, expr;
2090   gfc_component *c;
2091   int kind;
2092
2093   /* It is possible to get a C_NULL_PTR or C_NULL_FUNPTR expression here if
2094      the user says something like: print *, 'c_null_ptr: ', c_null_ptr
2095      We need to translate the expression to a constant if it's either
2096      C_NULL_PTR or C_NULL_FUNPTR.  We could also get a user variable of
2097      type C_PTR or C_FUNPTR, in which case the ts->type may no longer be
2098      BT_DERIVED (could have been changed by gfc_conv_expr).  */
2099   if ((ts->type == BT_DERIVED || ts->type == BT_INTEGER)
2100       && ts->u.derived != NULL
2101       && (ts->is_iso_c == 1 || ts->u.derived->ts.is_iso_c == 1))
2102     {
2103       ts->type = BT_INTEGER;
2104       ts->kind = gfc_index_integer_kind;
2105     }
2106
2107   kind = ts->kind;
2108   function = NULL;
2109   arg2 = NULL;
2110   arg3 = NULL;
2111
2112   switch (ts->type)
2113     {
2114     case BT_INTEGER:
2115       arg2 = build_int_cst (integer_type_node, kind);
2116       if (last_dt == READ)
2117         function = iocall[IOCALL_X_INTEGER];
2118       else
2119         function = iocall[IOCALL_X_INTEGER_WRITE];
2120
2121       break;
2122
2123     case BT_REAL:
2124       arg2 = build_int_cst (integer_type_node, kind);
2125       if (last_dt == READ)
2126         {
2127           if (gfc_real16_is_float128 && ts->kind == 16)
2128             function = iocall[IOCALL_X_REAL128];
2129           else
2130             function = iocall[IOCALL_X_REAL];
2131         }
2132       else
2133         {
2134           if (gfc_real16_is_float128 && ts->kind == 16)
2135             function = iocall[IOCALL_X_REAL128_WRITE];
2136           else
2137             function = iocall[IOCALL_X_REAL_WRITE];
2138         }
2139
2140       break;
2141
2142     case BT_COMPLEX:
2143       arg2 = build_int_cst (integer_type_node, kind);
2144       if (last_dt == READ)
2145         {
2146           if (gfc_real16_is_float128 && ts->kind == 16)
2147             function = iocall[IOCALL_X_COMPLEX128];
2148           else
2149             function = iocall[IOCALL_X_COMPLEX];
2150         }
2151       else
2152         {
2153           if (gfc_real16_is_float128 && ts->kind == 16)
2154             function = iocall[IOCALL_X_COMPLEX128_WRITE];
2155           else
2156             function = iocall[IOCALL_X_COMPLEX_WRITE];
2157         }
2158
2159       break;
2160
2161     case BT_LOGICAL:
2162       arg2 = build_int_cst (integer_type_node, kind);
2163       if (last_dt == READ)
2164         function = iocall[IOCALL_X_LOGICAL];
2165       else
2166         function = iocall[IOCALL_X_LOGICAL_WRITE];
2167
2168       break;
2169
2170     case BT_CHARACTER:
2171       if (kind == 4)
2172         {
2173           if (se->string_length)
2174             arg2 = se->string_length;
2175           else
2176             {
2177               tmp = build_fold_indirect_ref_loc (input_location,
2178                                              addr_expr);
2179               gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
2180               arg2 = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp)));
2181               arg2 = fold_convert (gfc_charlen_type_node, arg2);
2182             }
2183           arg3 = build_int_cst (integer_type_node, kind);
2184           if (last_dt == READ)
2185             function = iocall[IOCALL_X_CHARACTER_WIDE];
2186           else
2187             function = iocall[IOCALL_X_CHARACTER_WIDE_WRITE];
2188
2189           tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
2190           tmp = build_call_expr_loc (input_location,
2191                                  function, 4, tmp, addr_expr, arg2, arg3);
2192           gfc_add_expr_to_block (&se->pre, tmp);
2193           gfc_add_block_to_block (&se->pre, &se->post);
2194           return;
2195         }
2196       /* Fall through.  */
2197     case BT_HOLLERITH:
2198       if (se->string_length)
2199         arg2 = se->string_length;
2200       else
2201         {
2202           tmp = build_fold_indirect_ref_loc (input_location,
2203                                          addr_expr);
2204           gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
2205           arg2 = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp)));
2206         }
2207       if (last_dt == READ)
2208         function = iocall[IOCALL_X_CHARACTER];
2209       else
2210         function = iocall[IOCALL_X_CHARACTER_WRITE];
2211
2212       break;
2213
2214     case_bt_struct:
2215       if (ts->u.derived->components == NULL)
2216         return;
2217
2218       /* Recurse into the elements of the derived type.  */
2219       expr = gfc_evaluate_now (addr_expr, &se->pre);
2220       expr = build_fold_indirect_ref_loc (input_location,
2221                                       expr);
2222
2223       /* Make sure that the derived type has been built.  An external
2224          function, if only referenced in an io statement, requires this
2225          check (see PR58771).  */
2226       if (ts->u.derived->backend_decl == NULL_TREE)
2227         (void) gfc_typenode_for_spec (ts);
2228
2229       for (c = ts->u.derived->components; c; c = c->next)
2230         {
2231           field = c->backend_decl;
2232           gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
2233
2234           tmp = fold_build3_loc (UNKNOWN_LOCATION,
2235                              COMPONENT_REF, TREE_TYPE (field),
2236                              expr, field, NULL_TREE);
2237
2238           if (c->attr.dimension)
2239             {
2240               tmp = transfer_array_component (tmp, c, & code->loc);
2241               gfc_add_expr_to_block (&se->pre, tmp);
2242             }
2243           else
2244             {
2245               if (!c->attr.pointer)
2246                 tmp = gfc_build_addr_expr (NULL_TREE, tmp);
2247               transfer_expr (se, &c->ts, tmp, code);
2248             }
2249         }
2250       return;
2251
2252     default:
2253       gfc_internal_error ("Bad IO basetype (%d)", ts->type);
2254     }
2255
2256   tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
2257   tmp = build_call_expr_loc (input_location,
2258                          function, 3, tmp, addr_expr, arg2);
2259   gfc_add_expr_to_block (&se->pre, tmp);
2260   gfc_add_block_to_block (&se->pre, &se->post);
2261
2262 }
2263
2264
2265 /* Generate a call to pass an array descriptor to the IO library. The
2266    array should be of one of the intrinsic types.  */
2267
2268 static void
2269 transfer_array_desc (gfc_se * se, gfc_typespec * ts, tree addr_expr)
2270 {
2271   tree tmp, charlen_arg, kind_arg, io_call;
2272
2273   if (ts->type == BT_CHARACTER)
2274     charlen_arg = se->string_length;
2275   else
2276     charlen_arg = build_int_cst (gfc_charlen_type_node, 0);
2277
2278   kind_arg = build_int_cst (integer_type_node, ts->kind);
2279
2280   tmp = gfc_build_addr_expr (NULL_TREE, dt_parm);
2281   if (last_dt == READ)
2282     io_call = iocall[IOCALL_X_ARRAY];
2283   else
2284     io_call = iocall[IOCALL_X_ARRAY_WRITE];
2285
2286   tmp = build_call_expr_loc (UNKNOWN_LOCATION,
2287                          io_call, 4,
2288                          tmp, addr_expr, kind_arg, charlen_arg);
2289   gfc_add_expr_to_block (&se->pre, tmp);
2290   gfc_add_block_to_block (&se->pre, &se->post);
2291 }
2292
2293
2294 /* gfc_trans_transfer()-- Translate a TRANSFER code node */
2295
2296 tree
2297 gfc_trans_transfer (gfc_code * code)
2298 {
2299   stmtblock_t block, body;
2300   gfc_loopinfo loop;
2301   gfc_expr *expr;
2302   gfc_ref *ref;
2303   gfc_ss *ss;
2304   gfc_se se;
2305   tree tmp;
2306   int n;
2307
2308   gfc_start_block (&block);
2309   gfc_init_block (&body);
2310
2311   expr = code->expr1;
2312   ref = NULL;
2313   gfc_init_se (&se, NULL);
2314
2315   if (expr->rank == 0)
2316     {
2317       /* Transfer a scalar value.  */
2318       gfc_conv_expr_reference (&se, expr);
2319       transfer_expr (&se, &expr->ts, se.expr, code);
2320     }
2321   else
2322     {
2323       /* Transfer an array. If it is an array of an intrinsic
2324          type, pass the descriptor to the library.  Otherwise
2325          scalarize the transfer.  */
2326       if (expr->ref && !gfc_is_proc_ptr_comp (expr))
2327         {
2328           for (ref = expr->ref; ref && ref->type != REF_ARRAY;
2329             ref = ref->next);
2330           gcc_assert (ref && ref->type == REF_ARRAY);
2331         }
2332
2333       if (!gfc_bt_struct (expr->ts.type)
2334             && ref && ref->next == NULL
2335             && !is_subref_array (expr))
2336         {
2337           bool seen_vector = false;
2338
2339           if (ref && ref->u.ar.type == AR_SECTION)
2340             {
2341               for (n = 0; n < ref->u.ar.dimen; n++)
2342                 if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR)
2343                   {
2344                     seen_vector = true;
2345                     break;
2346                   }
2347             }
2348
2349           if (seen_vector && last_dt == READ)
2350             {
2351               /* Create a temp, read to that and copy it back.  */
2352               gfc_conv_subref_array_arg (&se, expr, 0, INTENT_OUT, false);
2353               tmp =  se.expr;
2354             }
2355           else
2356             {
2357               /* Get the descriptor.  */
2358               gfc_conv_expr_descriptor (&se, expr);
2359               tmp = gfc_build_addr_expr (NULL_TREE, se.expr);
2360             }
2361
2362           transfer_array_desc (&se, &expr->ts, tmp);
2363           goto finish_block_label;
2364         }
2365
2366       /* Initialize the scalarizer.  */
2367       ss = gfc_walk_expr (expr);
2368       gfc_init_loopinfo (&loop);
2369       gfc_add_ss_to_loop (&loop, ss);
2370
2371       /* Initialize the loop.  */
2372       gfc_conv_ss_startstride (&loop);
2373       gfc_conv_loop_setup (&loop, &code->expr1->where);
2374
2375       /* The main loop body.  */
2376       gfc_mark_ss_chain_used (ss, 1);
2377       gfc_start_scalarized_body (&loop, &body);
2378
2379       gfc_copy_loopinfo_to_se (&se, &loop);
2380       se.ss = ss;
2381
2382       gfc_conv_expr_reference (&se, expr);
2383       transfer_expr (&se, &expr->ts, se.expr, code);
2384     }
2385
2386  finish_block_label:
2387
2388   gfc_add_block_to_block (&body, &se.pre);
2389   gfc_add_block_to_block (&body, &se.post);
2390
2391   if (se.ss == NULL)
2392     tmp = gfc_finish_block (&body);
2393   else
2394     {
2395       gcc_assert (expr->rank != 0);
2396       gcc_assert (se.ss == gfc_ss_terminator);
2397       gfc_trans_scalarizing_loops (&loop, &body);
2398
2399       gfc_add_block_to_block (&loop.pre, &loop.post);
2400       tmp = gfc_finish_block (&loop.pre);
2401       gfc_cleanup_loop (&loop);
2402     }
2403
2404   gfc_add_expr_to_block (&block, tmp);
2405
2406   return gfc_finish_block (&block);
2407 }
2408
2409 #include "gt-fortran-trans-io.h"