main/gcc/fortran/trans-io.c

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