gcc/fortran/trans-io.c

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