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