gcc/fortran/trans-io.c

   1 /* IO Code translation/library interface
   2    Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007 Free Software
   3    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 "tree-gimple.h"
  28 #include "ggc.h"
  29 #include "toplev.h"
  30 #include "real.h"
  31 #include "gfortran.h"
  32 #include "trans.h"
  33 #include "trans-stmt.h"
  34 #include "trans-array.h"
  35 #include "trans-types.h"
  36 #include "trans-const.h"
  37
  38 /* Members of the ioparm structure.  */
  39
  40 enum ioparam_type
  41 {
  42   IOPARM_ptype_common,
  43   IOPARM_ptype_open,
  44   IOPARM_ptype_close,
  45   IOPARM_ptype_filepos,
  46   IOPARM_ptype_inquire,
  47   IOPARM_ptype_dt,
  48   IOPARM_ptype_num
  49 };
  50
  51 enum iofield_type
  52 {
  53   IOPARM_type_int4,
  54   IOPARM_type_intio,
  55   IOPARM_type_pint4,
  56   IOPARM_type_pintio,
  57   IOPARM_type_pchar,
  58   IOPARM_type_parray,
  59   IOPARM_type_pad,
  60   IOPARM_type_char1,
  61   IOPARM_type_char2,
  62   IOPARM_type_common,
  63   IOPARM_type_num
  64 };
  65
  66 typedef struct gfc_st_parameter_field GTY(())
  67 {
  68   const char *name;
  69   unsigned int mask;
  70   enum ioparam_type param_type;
  71   enum iofield_type type;
  72   tree field;
  73   tree field_len;
  74 }
  75 gfc_st_parameter_field;
  76
  77 typedef struct gfc_st_parameter GTY(())
  78 {
  79   const char *name;
  80   tree type;
  81 }
  82 gfc_st_parameter;
  83
  84 enum iofield
  85 {
  86 #define IOPARM(param_type, name, mask, type) IOPARM_##param_type##_##name,
  87 #include "ioparm.def"
  88 #undef IOPARM
  89   IOPARM_field_num
  90 };
  91
  92 static GTY(()) gfc_st_parameter st_parameter[] =
  93 {
  94   { "common", NULL },
  95   { "open", NULL },
  96   { "close", NULL },
  97   { "filepos", NULL },
  98   { "inquire", NULL },
  99   { "dt", NULL }
 100 };
 101
 102 static GTY(()) gfc_st_parameter_field st_parameter_field[] =
 103 {
 104 #define IOPARM(param_type, name, mask, type) \
 105   { #name, mask, IOPARM_ptype_##param_type, IOPARM_type_##type, NULL, NULL },
 106 #include "ioparm.def"
 107 #undef IOPARM
 108   { NULL, 0, 0, 0, NULL, NULL }
 109 };
 110
 111 /* Library I/O subroutines */
 112
 113 enum iocall
 114 {
 115   IOCALL_READ,
 116   IOCALL_READ_DONE,
 117   IOCALL_WRITE,
 118   IOCALL_WRITE_DONE,
 119   IOCALL_X_INTEGER,
 120   IOCALL_X_LOGICAL,
 121   IOCALL_X_CHARACTER,
 122   IOCALL_X_REAL,
 123   IOCALL_X_COMPLEX,
 124   IOCALL_X_ARRAY,
 125   IOCALL_OPEN,
 126   IOCALL_CLOSE,
 127   IOCALL_INQUIRE,
 128   IOCALL_IOLENGTH,
 129   IOCALL_IOLENGTH_DONE,
 130   IOCALL_REWIND,
 131   IOCALL_BACKSPACE,
 132   IOCALL_ENDFILE,
 133   IOCALL_FLUSH,
 134   IOCALL_SET_NML_VAL,
 135   IOCALL_SET_NML_VAL_DIM,
 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   enum iofield 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 = build_fold_addr_expr (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, gfc_build_cstring_const(message));
 244   gfc_free(message);
 245
 246   tmp = build_call_expr (gfor_fndecl_generate_error, 3, arg1, arg2, arg3);
 247
 248   gfc_add_expr_to_block (&block, tmp);
 249
 250   body = gfc_finish_block (&block);
 251
 252   if (integer_onep (cond))
 253     {
 254       gfc_add_expr_to_block (pblock, body);
 255     }
 256   else
 257     {
 258       /* Tell the compiler that this isn't likely.  */
 259       cond = fold_convert (long_integer_type_node, cond);
 260       tmp = build_int_cst (long_integer_type_node, 0);
 261       cond = build_call_expr (built_in_decls[BUILT_IN_EXPECT], 2, cond, tmp);
 262       cond = fold_convert (boolean_type_node, cond);
 263
 264       tmp = build3_v (COND_EXPR, cond, body, build_empty_stmt ());
 265       gfc_add_expr_to_block (pblock, tmp);
 266     }
 267 }
 268
 269
 270 /* Create function decls for IO library functions.  */
 271
 272 void
 273 gfc_build_io_library_fndecls (void)
 274 {
 275   tree types[IOPARM_type_num], pad_idx, gfc_int4_type_node;
 276   tree gfc_intio_type_node;
 277   tree parm_type, dt_parm_type;
 278   HOST_WIDE_INT pad_size;
 279   enum ioparam_type ptype;
 280
 281   types[IOPARM_type_int4] = gfc_int4_type_node = gfc_get_int_type (4);
 282   types[IOPARM_type_intio] = gfc_intio_type_node
 283                             = gfc_get_int_type (gfc_intio_kind);
 284   types[IOPARM_type_pint4] = build_pointer_type (gfc_int4_type_node);
 285   types[IOPARM_type_pintio]
 286                             = build_pointer_type (gfc_intio_type_node);
 287   types[IOPARM_type_parray] = pchar_type_node;
 288   types[IOPARM_type_pchar] = pchar_type_node;
 289   pad_size = 16 * TREE_INT_CST_LOW (TYPE_SIZE_UNIT (pchar_type_node));
 290   pad_size += 32 * TREE_INT_CST_LOW (TYPE_SIZE_UNIT (integer_type_node));
 291   pad_idx = build_index_type (build_int_cst (NULL_TREE, pad_size));
 292   types[IOPARM_type_pad] = build_array_type (char_type_node, pad_idx);
 293
 294   /* pad actually contains pointers and integers so it needs to have an
 295      alignment that is at least as large as the needed alignment for those
 296      types.  See the st_parameter_dt structure in libgfortran/io/io.h for
 297      what really goes into this space.  */
 298   TYPE_ALIGN (types[IOPARM_type_pad]) = MAX (TYPE_ALIGN (pchar_type_node),
 299                      TYPE_ALIGN (gfc_get_int_type (gfc_max_integer_kind)));
 300
 301   for (ptype = IOPARM_ptype_common; ptype < IOPARM_ptype_num; ptype++)
 302     gfc_build_st_parameter (ptype, types);
 303
 304   /* Define the transfer functions.  */
 305
 306   dt_parm_type = build_pointer_type (st_parameter[IOPARM_ptype_dt].type);
 307
 308   iocall[IOCALL_X_INTEGER] =
 309     gfc_build_library_function_decl (get_identifier
 310                                      (PREFIX("transfer_integer")),
 311                                      void_type_node, 3, dt_parm_type,
 312                                      pvoid_type_node, gfc_int4_type_node);
 313
 314   iocall[IOCALL_X_LOGICAL] =
 315     gfc_build_library_function_decl (get_identifier
 316                                      (PREFIX("transfer_logical")),
 317                                      void_type_node, 3, dt_parm_type,
 318                                      pvoid_type_node, gfc_int4_type_node);
 319
 320   iocall[IOCALL_X_CHARACTER] =
 321     gfc_build_library_function_decl (get_identifier
 322                                      (PREFIX("transfer_character")),
 323                                      void_type_node, 3, dt_parm_type,
 324                                      pvoid_type_node, gfc_int4_type_node);
 325
 326   iocall[IOCALL_X_REAL] =
 327     gfc_build_library_function_decl (get_identifier (PREFIX("transfer_real")),
 328                                      void_type_node, 3, dt_parm_type,
 329                                      pvoid_type_node, gfc_int4_type_node);
 330
 331   iocall[IOCALL_X_COMPLEX] =
 332     gfc_build_library_function_decl (get_identifier
 333                                      (PREFIX("transfer_complex")),
 334                                      void_type_node, 3, dt_parm_type,
 335                                      pvoid_type_node, gfc_int4_type_node);
 336
 337   iocall[IOCALL_X_ARRAY] =
 338     gfc_build_library_function_decl (get_identifier
 339                                      (PREFIX("transfer_array")),
 340                                      void_type_node, 4, dt_parm_type,
 341                                      pvoid_type_node, integer_type_node,
 342                                      gfc_charlen_type_node);
 343
 344   /* Library entry points */
 345
 346   iocall[IOCALL_READ] =
 347     gfc_build_library_function_decl (get_identifier (PREFIX("st_read")),
 348                                      void_type_node, 1, dt_parm_type);
 349
 350   iocall[IOCALL_WRITE] =
 351     gfc_build_library_function_decl (get_identifier (PREFIX("st_write")),
 352                                      void_type_node, 1, dt_parm_type);
 353
 354   parm_type = build_pointer_type (st_parameter[IOPARM_ptype_open].type);
 355   iocall[IOCALL_OPEN] =
 356     gfc_build_library_function_decl (get_identifier (PREFIX("st_open")),
 357                                      void_type_node, 1, parm_type);
 358
 359
 360   parm_type = build_pointer_type (st_parameter[IOPARM_ptype_close].type);
 361   iocall[IOCALL_CLOSE] =
 362     gfc_build_library_function_decl (get_identifier (PREFIX("st_close")),
 363                                      void_type_node, 1, parm_type);
 364
 365   parm_type = build_pointer_type (st_parameter[IOPARM_ptype_inquire].type);
 366   iocall[IOCALL_INQUIRE] =
 367     gfc_build_library_function_decl (get_identifier (PREFIX("st_inquire")),
 368                                      gfc_int4_type_node, 1, parm_type);
 369
 370   iocall[IOCALL_IOLENGTH] =
 371     gfc_build_library_function_decl(get_identifier (PREFIX("st_iolength")),
 372                                     void_type_node, 1, dt_parm_type);
 373
 374   parm_type = build_pointer_type (st_parameter[IOPARM_ptype_filepos].type);
 375   iocall[IOCALL_REWIND] =
 376     gfc_build_library_function_decl (get_identifier (PREFIX("st_rewind")),
 377                                      gfc_int4_type_node, 1, parm_type);
 378
 379   iocall[IOCALL_BACKSPACE] =
 380     gfc_build_library_function_decl (get_identifier (PREFIX("st_backspace")),
 381                                      gfc_int4_type_node, 1, parm_type);
 382
 383   iocall[IOCALL_ENDFILE] =
 384     gfc_build_library_function_decl (get_identifier (PREFIX("st_endfile")),
 385                                      gfc_int4_type_node, 1, parm_type);
 386
 387   iocall[IOCALL_FLUSH] =
 388     gfc_build_library_function_decl (get_identifier (PREFIX("st_flush")),
 389                                      gfc_int4_type_node, 1, parm_type);
 390
 391   /* Library helpers */
 392
 393   iocall[IOCALL_READ_DONE] =
 394     gfc_build_library_function_decl (get_identifier (PREFIX("st_read_done")),
 395                                      gfc_int4_type_node, 1, dt_parm_type);
 396
 397   iocall[IOCALL_WRITE_DONE] =
 398     gfc_build_library_function_decl (get_identifier (PREFIX("st_write_done")),
 399                                      gfc_int4_type_node, 1, dt_parm_type);
 400
 401   iocall[IOCALL_IOLENGTH_DONE] =
 402     gfc_build_library_function_decl (get_identifier (PREFIX("st_iolength_done")),
 403                                      gfc_int4_type_node, 1, dt_parm_type);
 404
 405
 406   iocall[IOCALL_SET_NML_VAL] =
 407     gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var")),
 408                                      void_type_node, 6, dt_parm_type,
 409                                      pvoid_type_node, pvoid_type_node,
 410                                      gfc_int4_type_node, gfc_charlen_type_node,
 411                                      gfc_int4_type_node);
 412
 413   iocall[IOCALL_SET_NML_VAL_DIM] =
 414     gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_dim")),
 415                                      void_type_node, 5, dt_parm_type,
 416                                      gfc_int4_type_node, gfc_array_index_type,
 417                                      gfc_array_index_type, gfc_array_index_type);
 418 }
 419
 420
 421 /* Generate code to store an integer constant into the
 422    st_parameter_XXX structure.  */
 423
 424 static unsigned int
 425 set_parameter_const (stmtblock_t *block, tree var, enum iofield type,
 426                      unsigned int val)
 427 {
 428   tree tmp;
 429   gfc_st_parameter_field *p = &st_parameter_field[type];
 430
 431   if (p->param_type == IOPARM_ptype_common)
 432     var = build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type,
 433                   var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
 434   tmp = build3 (COMPONENT_REF, TREE_TYPE (p->field), var, p->field,
 435                 NULL_TREE);
 436   gfc_add_modify_expr (block, tmp, build_int_cst (TREE_TYPE (p->field), val));
 437   return p->mask;
 438 }
 439
 440
 441 /* Generate code to store a non-string I/O parameter into the
 442    st_parameter_XXX structure.  This is a pass by value.  */
 443
 444 static unsigned int
 445 set_parameter_value (stmtblock_t *block, tree var, enum iofield type,
 446                      gfc_expr *e)
 447 {
 448   gfc_se se;
 449   tree tmp;
 450   gfc_st_parameter_field *p = &st_parameter_field[type];
 451   tree dest_type = TREE_TYPE (p->field);
 452
 453   gfc_init_se (&se, NULL);
 454   gfc_conv_expr_val (&se, e);
 455
 456   /* If we're storing a UNIT number, we need to check it first.  */
 457   if (type == IOPARM_common_unit && e->ts.kind != 4)
 458     {
 459       tree cond, max;
 460       ioerror_codes bad_unit;
 461       int i;
 462
 463       bad_unit = IOERROR_BAD_UNIT;
 464
 465       /* Don't evaluate the UNIT number multiple times.  */
 466       se.expr = gfc_evaluate_now (se.expr, &se.pre);
 467
 468       /* UNIT numbers should be nonnegative.  */
 469       cond = fold_build2 (LT_EXPR, boolean_type_node, se.expr,
 470                           build_int_cst (TREE_TYPE (se.expr),0));
 471       gfc_trans_io_runtime_check (cond, var, bad_unit,
 472                                "Negative unit number in I/O statement",
 473                                &se.pre);
 474
 475       /* UNIT numbers should be less than the max.  */
 476       i = gfc_validate_kind (BT_INTEGER, 4, false);
 477       max = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, 4);
 478       cond = fold_build2 (GT_EXPR, boolean_type_node, se.expr,
 479                           fold_convert (TREE_TYPE (se.expr), max));
 480       gfc_trans_io_runtime_check (cond, var, bad_unit,
 481                                "Unit number in I/O statement too large",
 482                                &se.pre);
 483
 484     }
 485
 486   se.expr = convert (dest_type, se.expr);
 487   gfc_add_block_to_block (block, &se.pre);
 488
 489   if (p->param_type == IOPARM_ptype_common)
 490     var = build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type,
 491                   var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
 492
 493   tmp = build3 (COMPONENT_REF, dest_type, var, p->field, NULL_TREE);
 494   gfc_add_modify_expr (block, tmp, se.expr);
 495   return p->mask;
 496 }
 497
 498
 499 /* Generate code to store a non-string I/O parameter into the
 500    st_parameter_XXX structure.  This is pass by reference.  */
 501
 502 static unsigned int
 503 set_parameter_ref (stmtblock_t *block, stmtblock_t *postblock,
 504                    tree var, enum iofield type, gfc_expr *e)
 505 {
 506   gfc_se se;
 507   tree tmp, addr;
 508   gfc_st_parameter_field *p = &st_parameter_field[type];
 509
 510   gcc_assert (e->ts.type == BT_INTEGER || e->ts.type == BT_LOGICAL);
 511   gfc_init_se (&se, NULL);
 512   gfc_conv_expr_lhs (&se, e);
 513
 514   gfc_add_block_to_block (block, &se.pre);
 515
 516   if (TYPE_MODE (TREE_TYPE (se.expr))
 517       == TYPE_MODE (TREE_TYPE (TREE_TYPE (p->field))))
 518     {
 519       addr = convert (TREE_TYPE (p->field), build_fold_addr_expr (se.expr));
 520
 521       /* If this is for the iostat variable initialize the
 522          user variable to IOERROR_OK which is zero.  */
 523       if (type == IOPARM_common_iostat)
 524         {
 525           ioerror_codes ok;
 526           ok = IOERROR_OK;
 527           gfc_add_modify_expr (block, se.expr,
 528                                build_int_cst (TREE_TYPE (se.expr), ok));
 529         }
 530     }
 531   else
 532     {
 533       /* The type used by the library has different size
 534         from the type of the variable supplied by the user.
 535         Need to use a temporary.  */
 536       tree tmpvar = gfc_create_var (TREE_TYPE (TREE_TYPE (p->field)),
 537                                     st_parameter_field[type].name);
 538
 539       /* If this is for the iostat variable, initialize the
 540          user variable to IOERROR_OK which is zero.  */
 541       if (type == IOPARM_common_iostat)
 542         {
 543           ioerror_codes ok;
 544           ok = IOERROR_OK;
 545           gfc_add_modify_expr (block, tmpvar,
 546                                build_int_cst (TREE_TYPE (tmpvar), ok));
 547         }
 548
 549       addr = build_fold_addr_expr (tmpvar);
 550         /* After the I/O operation, we set the variable from the temporary.  */
 551       tmp = convert (TREE_TYPE (se.expr), tmpvar);
 552       gfc_add_modify_expr (postblock, se.expr, tmp);
 553      }
 554
 555   if (p->param_type == IOPARM_ptype_common)
 556     var = build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type,
 557                   var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
 558   tmp = build3 (COMPONENT_REF, TREE_TYPE (p->field), var, p->field,
 559                 NULL_TREE);
 560   gfc_add_modify_expr (block, tmp, addr);
 561   return p->mask;
 562 }
 563
 564 /* Given an array expr, find its address and length to get a string. If the
 565    array is full, the string's address is the address of array's first element
 566    and the length is the size of the whole array. If it is an element, the
 567    string's address is the element's address and the length is the rest size of
 568    the array.
 569 */
 570
 571 static void
 572 gfc_convert_array_to_string (gfc_se * se, gfc_expr * e)
 573 {
 574   tree tmp;
 575   tree array;
 576   tree type;
 577   tree size;
 578   int rank;
 579   gfc_symbol *sym;
 580
 581   sym = e->symtree->n.sym;
 582   rank = sym->as->rank - 1;
 583
 584   if (e->ref->u.ar.type == AR_FULL)
 585     {
 586       se->expr = gfc_get_symbol_decl (sym);
 587       se->expr = gfc_conv_array_data (se->expr);
 588     }
 589   else
 590     {
 591       gfc_conv_expr (se, e);
 592     }
 593
 594   array = sym->backend_decl;
 595   type = TREE_TYPE (array);
 596
 597   if (GFC_ARRAY_TYPE_P (type))
 598     size = GFC_TYPE_ARRAY_SIZE (type);
 599   else
 600     {
 601       gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
 602       size = gfc_conv_array_stride (array, rank);
 603       tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
 604                 gfc_conv_array_ubound (array, rank),
 605                 gfc_conv_array_lbound (array, rank));
 606       tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp,
 607                 gfc_index_one_node);
 608       size = fold_build2 (MULT_EXPR, gfc_array_index_type, tmp, size);
 609     }
 610
 611   gcc_assert (size);
 612
 613   /* If it is an element, we need the its address and size of the rest.  */
 614   if (e->ref->u.ar.type == AR_ELEMENT)
 615     {
 616       size = fold_build2 (MINUS_EXPR, gfc_array_index_type, size,
 617                 TREE_OPERAND (se->expr, 1));
 618       se->expr = build_fold_addr_expr (se->expr);
 619     }
 620
 621   tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
 622   size = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
 623                       fold_convert (gfc_array_index_type, tmp));
 624
 625   se->string_length = fold_convert (gfc_charlen_type_node, size);
 626 }
 627
 628
 629 /* Generate code to store a string and its length into the
 630    st_parameter_XXX structure.  */
 631
 632 static unsigned int
 633 set_string (stmtblock_t * block, stmtblock_t * postblock, tree var,
 634             enum iofield type, gfc_expr * e)
 635 {
 636   gfc_se se;
 637   tree tmp;
 638   tree io;
 639   tree len;
 640   gfc_st_parameter_field *p = &st_parameter_field[type];
 641
 642   gfc_init_se (&se, NULL);
 643
 644   if (p->param_type == IOPARM_ptype_common)
 645     var = build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type,
 646                   var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
 647   io = build3 (COMPONENT_REF, TREE_TYPE (p->field), var, p->field,
 648                NULL_TREE);
 649   len = build3 (COMPONENT_REF, TREE_TYPE (p->field_len), var, p->field_len,
 650                 NULL_TREE);
 651
 652   /* Integer variable assigned a format label.  */
 653   if (e->ts.type == BT_INTEGER && e->symtree->n.sym->attr.assign == 1)
 654     {
 655       char * msg;
 656       tree cond;
 657
 658       gfc_conv_label_variable (&se, e);
 659       tmp = GFC_DECL_STRING_LEN (se.expr);
 660       cond = fold_build2 (LT_EXPR, boolean_type_node,
 661                           tmp, build_int_cst (TREE_TYPE (tmp), 0));
 662
 663       asprintf(&msg, "Label assigned to variable '%s' (%%ld) is not a format "
 664                "label", e->symtree->name);
 665       gfc_trans_runtime_check (cond, &se.pre, &e->where, msg,
 666                                fold_convert (long_integer_type_node, tmp));
 667       gfc_free (msg);
 668
 669       gfc_add_modify_expr (&se.pre, io,
 670                  fold_convert (TREE_TYPE (io), GFC_DECL_ASSIGN_ADDR (se.expr)));
 671       gfc_add_modify_expr (&se.pre, len, GFC_DECL_STRING_LEN (se.expr));
 672     }
 673   else
 674     {
 675       /* General character.  */
 676       if (e->ts.type == BT_CHARACTER && e->rank == 0)
 677         gfc_conv_expr (&se, e);
 678       /* Array assigned Hollerith constant or character array.  */
 679       else if (e->symtree && (e->symtree->n.sym->as->rank > 0))
 680         gfc_convert_array_to_string (&se, e);
 681       else
 682         gcc_unreachable ();
 683
 684       gfc_conv_string_parameter (&se);
 685       gfc_add_modify_expr (&se.pre, io, fold_convert (TREE_TYPE (io), se.expr));
 686       gfc_add_modify_expr (&se.pre, len, se.string_length);
 687     }
 688
 689   gfc_add_block_to_block (block, &se.pre);
 690   gfc_add_block_to_block (postblock, &se.post);
 691   return p->mask;
 692 }
 693
 694
 695 /* Generate code to store the character (array) and the character length
 696    for an internal unit.  */
 697
 698 static unsigned int
 699 set_internal_unit (stmtblock_t * block, stmtblock_t * post_block,
 700                    tree var, gfc_expr * e)
 701 {
 702   gfc_se se;
 703   tree io;
 704   tree len;
 705   tree desc;
 706   tree tmp;
 707   gfc_st_parameter_field *p;
 708   unsigned int mask;
 709
 710   gfc_init_se (&se, NULL);
 711
 712   p = &st_parameter_field[IOPARM_dt_internal_unit];
 713   mask = p->mask;
 714   io = build3 (COMPONENT_REF, TREE_TYPE (p->field), var, p->field,
 715                NULL_TREE);
 716   len = build3 (COMPONENT_REF, TREE_TYPE (p->field_len), var, p->field_len,
 717                 NULL_TREE);
 718   p = &st_parameter_field[IOPARM_dt_internal_unit_desc];
 719   desc = build3 (COMPONENT_REF, TREE_TYPE (p->field), var, p->field,
 720                  NULL_TREE);
 721
 722   gcc_assert (e->ts.type == BT_CHARACTER);
 723
 724   /* Character scalars.  */
 725   if (e->rank == 0)
 726     {
 727       gfc_conv_expr (&se, e);
 728       gfc_conv_string_parameter (&se);
 729       tmp = se.expr;
 730       se.expr = build_int_cst (pchar_type_node, 0);
 731     }
 732
 733   /* Character array.  */
 734   else if (e->rank > 0)
 735     {
 736       se.ss = gfc_walk_expr (e);
 737
 738       if (is_aliased_array (e))
 739         {
 740           /* Use a temporary for components of arrays of derived types
 741              or substring array references.  */
 742           gfc_conv_aliased_arg (&se, e, 0,
 743                 last_dt == READ ? INTENT_IN : INTENT_OUT);
 744           tmp = build_fold_indirect_ref (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_expr (&se.pre, io, fold_convert (TREE_TYPE (io), tmp));
 762   gfc_add_modify_expr (&se.pre, len,
 763                        fold_convert (TREE_TYPE (len), se.string_length));
 764   gfc_add_modify_expr (&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 = build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type,
 829                 var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
 830   rc = build3 (COMPONENT_REF, TREE_TYPE (p->field), var, p->field,
 831                NULL_TREE);
 832   rc = build2 (BIT_AND_EXPR, TREE_TYPE (rc), rc,
 833                build_int_cst (TREE_TYPE (rc), IOPARM_common_libreturn_mask));
 834
 835   tmp = build3_v (SWITCH_EXPR, rc, tmp, NULL_TREE);
 836
 837   gfc_add_expr_to_block (block, tmp);
 838 }
 839
 840
 841 /* Store the current file and line number to variables so that if a
 842    library call goes awry, we can tell the user where the problem is.  */
 843
 844 static void
 845 set_error_locus (stmtblock_t * block, tree var, locus * where)
 846 {
 847   gfc_file *f;
 848   tree str, locus_file;
 849   int line;
 850   gfc_st_parameter_field *p = &st_parameter_field[IOPARM_common_filename];
 851
 852   locus_file = build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type,
 853                        var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
 854   locus_file = build3 (COMPONENT_REF, TREE_TYPE (p->field), locus_file,
 855                        p->field, NULL_TREE);
 856   f = where->lb->file;
 857   str = gfc_build_cstring_const (f->filename);
 858
 859   str = gfc_build_addr_expr (pchar_type_node, str);
 860   gfc_add_modify_expr (block, locus_file, str);
 861
 862 #ifdef USE_MAPPED_LOCATION
 863   line = LOCATION_LINE (where->lb->location);
 864 #else
 865   line = where->lb->linenum;
 866 #endif
 867   set_parameter_const (block, var, IOPARM_common_line, line);
 868 }
 869
 870
 871 /* Translate an OPEN statement.  */
 872
 873 tree
 874 gfc_trans_open (gfc_code * code)
 875 {
 876   stmtblock_t block, post_block;
 877   gfc_open *p;
 878   tree tmp, var;
 879   unsigned int mask = 0;
 880
 881   gfc_start_block (&block);
 882   gfc_init_block (&post_block);
 883
 884   var = gfc_create_var (st_parameter[IOPARM_ptype_open].type, "open_parm");
 885
 886   set_error_locus (&block, var, &code->loc);
 887   p = code->ext.open;
 888
 889   if (p->iomsg)
 890     mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
 891                         p->iomsg);
 892
 893   if (p->iostat)
 894     mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
 895                                p->iostat);
 896
 897   if (p->err)
 898     mask |= IOPARM_common_err;
 899
 900   if (p->file)
 901     mask |= set_string (&block, &post_block, var, IOPARM_open_file, p->file);
 902
 903   if (p->status)
 904     mask |= set_string (&block, &post_block, var, IOPARM_open_status,
 905                         p->status);
 906
 907   if (p->access)
 908     mask |= set_string (&block, &post_block, var, IOPARM_open_access,
 909                         p->access);
 910
 911   if (p->form)
 912     mask |= set_string (&block, &post_block, var, IOPARM_open_form, p->form);
 913
 914   if (p->recl)
 915     mask |= set_parameter_value (&block, var, IOPARM_open_recl_in, p->recl);
 916
 917   if (p->blank)
 918     mask |= set_string (&block, &post_block, var, IOPARM_open_blank,
 919                         p->blank);
 920
 921   if (p->position)
 922     mask |= set_string (&block, &post_block, var, IOPARM_open_position,
 923                         p->position);
 924
 925   if (p->action)
 926     mask |= set_string (&block, &post_block, var, IOPARM_open_action,
 927                         p->action);
 928
 929   if (p->delim)
 930     mask |= set_string (&block, &post_block, var, IOPARM_open_delim,
 931                         p->delim);
 932
 933   if (p->pad)
 934     mask |= set_string (&block, &post_block, var, IOPARM_open_pad, p->pad);
 935
 936   if (p->convert)
 937     mask |= set_string (&block, &post_block, var, IOPARM_open_convert,
 938                         p->convert);
 939
 940   set_parameter_const (&block, var, IOPARM_common_flags, mask);
 941
 942   if (p->unit)
 943     set_parameter_value (&block, var, IOPARM_common_unit, p->unit);
 944   else
 945     set_parameter_const (&block, var, IOPARM_common_unit, 0);
 946
 947   tmp = build_fold_addr_expr (var);
 948   tmp = build_call_expr (iocall[IOCALL_OPEN], 1, tmp);
 949   gfc_add_expr_to_block (&block, tmp);
 950
 951   gfc_add_block_to_block (&block, &post_block);
 952
 953   io_result (&block, var, p->err, NULL, NULL);
 954
 955   return gfc_finish_block (&block);
 956 }
 957
 958
 959 /* Translate a CLOSE statement.  */
 960
 961 tree
 962 gfc_trans_close (gfc_code * code)
 963 {
 964   stmtblock_t block, post_block;
 965   gfc_close *p;
 966   tree tmp, var;
 967   unsigned int mask = 0;
 968
 969   gfc_start_block (&block);
 970   gfc_init_block (&post_block);
 971
 972   var = gfc_create_var (st_parameter[IOPARM_ptype_close].type, "close_parm");
 973
 974   set_error_locus (&block, var, &code->loc);
 975   p = code->ext.close;
 976
 977   if (p->iomsg)
 978     mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
 979                         p->iomsg);
 980
 981   if (p->iostat)
 982     mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
 983                                p->iostat);
 984
 985   if (p->err)
 986     mask |= IOPARM_common_err;
 987
 988   if (p->status)
 989     mask |= set_string (&block, &post_block, var, IOPARM_close_status,
 990                         p->status);
 991
 992   set_parameter_const (&block, var, IOPARM_common_flags, mask);
 993
 994   if (p->unit)
 995     set_parameter_value (&block, var, IOPARM_common_unit, p->unit);
 996   else
 997     set_parameter_const (&block, var, IOPARM_common_unit, 0);
 998
 999   tmp = build_fold_addr_expr (var);
1000   tmp = build_call_expr (iocall[IOCALL_CLOSE], 1, tmp);
1001   gfc_add_expr_to_block (&block, tmp);
1002
1003   gfc_add_block_to_block (&block, &post_block);
1004
1005   io_result (&block, var, p->err, NULL, NULL);
1006
1007   return gfc_finish_block (&block);
1008 }
1009
1010
1011 /* Common subroutine for building a file positioning statement.  */
1012
1013 static tree
1014 build_filepos (tree function, gfc_code * code)
1015 {
1016   stmtblock_t block, post_block;
1017   gfc_filepos *p;
1018   tree tmp, var;
1019   unsigned int mask = 0;
1020
1021   p = code->ext.filepos;
1022
1023   gfc_start_block (&block);
1024   gfc_init_block (&post_block);
1025
1026   var = gfc_create_var (st_parameter[IOPARM_ptype_filepos].type,
1027                         "filepos_parm");
1028
1029   set_error_locus (&block, var, &code->loc);
1030
1031   if (p->iomsg)
1032     mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
1033                         p->iomsg);
1034
1035   if (p->iostat)
1036     mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
1037                                p->iostat);
1038
1039   if (p->err)
1040     mask |= IOPARM_common_err;
1041
1042   set_parameter_const (&block, var, IOPARM_common_flags, mask);
1043
1044   if (p->unit)
1045     set_parameter_value (&block, var, IOPARM_common_unit, p->unit);
1046   else
1047     set_parameter_const (&block, var, IOPARM_common_unit, 0);
1048
1049   tmp = build_fold_addr_expr (var);
1050   tmp = build_call_expr (function, 1, tmp);
1051   gfc_add_expr_to_block (&block, tmp);
1052
1053   gfc_add_block_to_block (&block, &post_block);
1054
1055   io_result (&block, var, p->err, NULL, NULL);
1056
1057   return gfc_finish_block (&block);
1058 }
1059
1060
1061 /* Translate a BACKSPACE statement.  */
1062
1063 tree
1064 gfc_trans_backspace (gfc_code * code)
1065 {
1066   return build_filepos (iocall[IOCALL_BACKSPACE], code);
1067 }
1068
1069
1070 /* Translate an ENDFILE statement.  */
1071
1072 tree
1073 gfc_trans_endfile (gfc_code * code)
1074 {
1075   return build_filepos (iocall[IOCALL_ENDFILE], code);
1076 }
1077
1078
1079 /* Translate a REWIND statement.  */
1080
1081 tree
1082 gfc_trans_rewind (gfc_code * code)
1083 {
1084   return build_filepos (iocall[IOCALL_REWIND], code);
1085 }
1086
1087
1088 /* Translate a FLUSH statement.  */
1089
1090 tree
1091 gfc_trans_flush (gfc_code * code)
1092 {
1093   return build_filepos (iocall[IOCALL_FLUSH], code);
1094 }
1095
1096
1097 /* Create a dummy iostat variable to catch any error due to bad unit.  */
1098
1099 static gfc_expr *
1100 create_dummy_iostat (void)
1101 {
1102   gfc_symtree *st;
1103   gfc_expr *e;
1104
1105   st = gfc_get_unique_symtree (gfc_current_ns);
1106   st->n.sym = gfc_new_symbol (st->name, gfc_current_ns);
1107   st->n.sym->ts.type = BT_INTEGER;
1108   st->n.sym->ts.kind = 4;
1109   st->n.sym->attr.referenced = 1;
1110   st->n.sym->refs = 1;
1111   e = gfc_get_expr ();
1112   e->expr_type = EXPR_VARIABLE;
1113   e->symtree = st;
1114   e->ts.type = BT_INTEGER;
1115   e->ts.kind = 4;
1116
1117   return e;
1118 }
1119
1120
1121 /* Translate the non-IOLENGTH form of an INQUIRE statement.  */
1122
1123 tree
1124 gfc_trans_inquire (gfc_code * code)
1125 {
1126   stmtblock_t block, post_block;
1127   gfc_inquire *p;
1128   tree tmp, var;
1129   unsigned int mask = 0;
1130
1131   gfc_start_block (&block);
1132   gfc_init_block (&post_block);
1133
1134   var = gfc_create_var (st_parameter[IOPARM_ptype_inquire].type,
1135                         "inquire_parm");
1136
1137   set_error_locus (&block, var, &code->loc);
1138   p = code->ext.inquire;
1139
1140   if (p->iomsg)
1141     mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
1142                         p->iomsg);
1143
1144   if (p->iostat)
1145     mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
1146                                p->iostat);
1147
1148   if (p->err)
1149     mask |= IOPARM_common_err;
1150
1151   /* Sanity check.  */
1152   if (p->unit && p->file)
1153     gfc_error ("INQUIRE statement at %L cannot contain both FILE and UNIT specifiers", &code->loc);
1154
1155   if (p->file)
1156     mask |= set_string (&block, &post_block, var, IOPARM_inquire_file,
1157                         p->file);
1158
1159   if (p->exist)
1160     {
1161       mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_exist,
1162                                  p->exist);
1163
1164       if (p->unit && !p->iostat)
1165         {
1166           p->iostat = create_dummy_iostat ();
1167           mask |= set_parameter_ref (&block, &post_block, var,
1168                                      IOPARM_common_iostat, p->iostat);
1169         }
1170     }
1171
1172   if (p->opened)
1173     mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_opened,
1174                                p->opened);
1175
1176   if (p->number)
1177     mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_number,
1178                                p->number);
1179
1180   if (p->named)
1181     mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_named,
1182                                p->named);
1183
1184   if (p->name)
1185     mask |= set_string (&block, &post_block, var, IOPARM_inquire_name,
1186                         p->name);
1187
1188   if (p->access)
1189     mask |= set_string (&block, &post_block, var, IOPARM_inquire_access,
1190                         p->access);
1191
1192   if (p->sequential)
1193     mask |= set_string (&block, &post_block, var, IOPARM_inquire_sequential,
1194                         p->sequential);
1195
1196   if (p->direct)
1197     mask |= set_string (&block, &post_block, var, IOPARM_inquire_direct,
1198                         p->direct);
1199
1200   if (p->form)
1201     mask |= set_string (&block, &post_block, var, IOPARM_inquire_form,
1202                         p->form);
1203
1204   if (p->formatted)
1205     mask |= set_string (&block, &post_block, var, IOPARM_inquire_formatted,
1206                         p->formatted);
1207
1208   if (p->unformatted)
1209     mask |= set_string (&block, &post_block, var, IOPARM_inquire_unformatted,
1210                         p->unformatted);
1211
1212   if (p->recl)
1213     mask |= set_parameter_ref (&block, &post_block, var,
1214                                IOPARM_inquire_recl_out, p->recl);
1215
1216   if (p->nextrec)
1217     mask |= set_parameter_ref (&block, &post_block, var,
1218                                IOPARM_inquire_nextrec, p->nextrec);
1219
1220   if (p->blank)
1221     mask |= set_string (&block, &post_block, var, IOPARM_inquire_blank,
1222                         p->blank);
1223
1224   if (p->position)
1225     mask |= set_string (&block, &post_block, var, IOPARM_inquire_position,
1226                         p->position);
1227
1228   if (p->action)
1229     mask |= set_string (&block, &post_block, var, IOPARM_inquire_action,
1230                         p->action);
1231
1232   if (p->read)
1233     mask |= set_string (&block, &post_block, var, IOPARM_inquire_read,
1234                         p->read);
1235
1236   if (p->write)
1237     mask |= set_string (&block, &post_block, var, IOPARM_inquire_write,
1238                         p->write);
1239
1240   if (p->readwrite)
1241     mask |= set_string (&block, &post_block, var, IOPARM_inquire_readwrite,
1242                         p->readwrite);
1243
1244   if (p->delim)
1245     mask |= set_string (&block, &post_block, var, IOPARM_inquire_delim,
1246                         p->delim);
1247
1248   if (p->pad)
1249     mask |= set_string (&block, &post_block, var, IOPARM_inquire_pad,
1250                         p->pad);
1251
1252   if (p->convert)
1253     mask |= set_string (&block, &post_block, var, IOPARM_inquire_convert,
1254                         p->convert);
1255
1256   if (p->strm_pos)
1257     mask |= set_parameter_ref (&block, &post_block, var,
1258                                IOPARM_inquire_strm_pos_out, p->strm_pos);
1259
1260   set_parameter_const (&block, var, IOPARM_common_flags, mask);
1261
1262   if (p->unit)
1263     set_parameter_value (&block, var, IOPARM_common_unit, p->unit);
1264   else
1265     set_parameter_const (&block, var, IOPARM_common_unit, 0);
1266
1267   tmp = build_fold_addr_expr (var);
1268   tmp = build_call_expr (iocall[IOCALL_INQUIRE], 1, tmp);
1269   gfc_add_expr_to_block (&block, tmp);
1270
1271   gfc_add_block_to_block (&block, &post_block);
1272
1273   io_result (&block, var, p->err, NULL, NULL);
1274
1275   return gfc_finish_block (&block);
1276 }
1277
1278 static gfc_expr *
1279 gfc_new_nml_name_expr (const char * name)
1280 {
1281    gfc_expr * nml_name;
1282
1283    nml_name = gfc_get_expr();
1284    nml_name->ref = NULL;
1285    nml_name->expr_type = EXPR_CONSTANT;
1286    nml_name->ts.kind = gfc_default_character_kind;
1287    nml_name->ts.type = BT_CHARACTER;
1288    nml_name->value.character.length = strlen(name);
1289    nml_name->value.character.string = gfc_getmem (strlen (name) + 1);
1290    strcpy (nml_name->value.character.string, name);
1291
1292    return nml_name;
1293 }
1294
1295 /* nml_full_name builds up the fully qualified name of a
1296    derived type component.  */
1297
1298 static char*
1299 nml_full_name (const char* var_name, const char* cmp_name)
1300 {
1301   int full_name_length;
1302   char * full_name;
1303
1304   full_name_length = strlen (var_name) + strlen (cmp_name) + 1;
1305   full_name = (char*)gfc_getmem (full_name_length + 1);
1306   strcpy (full_name, var_name);
1307   full_name = strcat (full_name, "%");
1308   full_name = strcat (full_name, cmp_name);
1309   return full_name;
1310 }
1311
1312 /* nml_get_addr_expr builds an address expression from the
1313    gfc_symbol or gfc_component backend_decl's. An offset is
1314    provided so that the address of an element of an array of
1315    derived types is returned. This is used in the runtime to
1316    determine that span of the derived type.  */
1317
1318 static tree
1319 nml_get_addr_expr (gfc_symbol * sym, gfc_component * c,
1320                    tree base_addr)
1321 {
1322   tree decl = NULL_TREE;
1323   tree tmp;
1324   tree itmp;
1325   int array_flagged;
1326   int dummy_arg_flagged;
1327
1328   if (sym)
1329     {
1330       sym->attr.referenced = 1;
1331       decl = gfc_get_symbol_decl (sym);
1332
1333       /* If this is the enclosing function declaration, use
1334          the fake result instead.  */
1335       if (decl == current_function_decl)
1336         decl = gfc_get_fake_result_decl (sym, 0);
1337       else if (decl == DECL_CONTEXT (current_function_decl))
1338         decl =  gfc_get_fake_result_decl (sym, 1);
1339     }
1340   else
1341     decl = c->backend_decl;
1342
1343   gcc_assert (decl && ((TREE_CODE (decl) == FIELD_DECL
1344                      || TREE_CODE (decl) == VAR_DECL
1345                      || TREE_CODE (decl) == PARM_DECL)
1346                      || TREE_CODE (decl) == COMPONENT_REF));
1347
1348   tmp = decl;
1349
1350   /* Build indirect reference, if dummy argument.  */
1351
1352   dummy_arg_flagged = POINTER_TYPE_P (TREE_TYPE(tmp));
1353
1354   itmp = (dummy_arg_flagged) ? build_fold_indirect_ref (tmp) : tmp;
1355
1356   /* If an array, set flag and use indirect ref. if built.  */
1357
1358   array_flagged = (TREE_CODE (TREE_TYPE (itmp)) == ARRAY_TYPE
1359                    && !TYPE_STRING_FLAG (TREE_TYPE (itmp)));
1360
1361   if (array_flagged)
1362     tmp = itmp;
1363
1364   /* Treat the component of a derived type, using base_addr for
1365      the derived type.  */
1366
1367   if (TREE_CODE (decl) == FIELD_DECL)
1368     tmp = build3 (COMPONENT_REF, TREE_TYPE (tmp),
1369                   base_addr, tmp, NULL_TREE);
1370
1371   /* If we have a derived type component, a reference to the first
1372      element of the array is built.  This is done so that base_addr,
1373      used in the build of the component reference, always points to
1374      a RECORD_TYPE.  */
1375
1376   if (array_flagged)
1377     tmp = gfc_build_array_ref (tmp, gfc_index_zero_node);
1378
1379   /* Now build the address expression.  */
1380
1381   tmp = build_fold_addr_expr (tmp);
1382
1383   /* If scalar dummy, resolve indirect reference now.  */
1384
1385   if (dummy_arg_flagged && !array_flagged)
1386     tmp = build_fold_indirect_ref (tmp);
1387
1388   gcc_assert (tmp && POINTER_TYPE_P (TREE_TYPE (tmp)));
1389
1390   return tmp;
1391 }
1392
1393 /* For an object VAR_NAME whose base address is BASE_ADDR, generate a
1394    call to iocall[IOCALL_SET_NML_VAL].  For derived type variable, recursively
1395    generate calls to iocall[IOCALL_SET_NML_VAL] for each component.  */
1396
1397 #define IARG(i) build_int_cst (gfc_array_index_type, i)
1398
1399 static void
1400 transfer_namelist_element (stmtblock_t * block, const char * var_name,
1401                            gfc_symbol * sym, gfc_component * c,
1402                            tree base_addr)
1403 {
1404   gfc_typespec * ts = NULL;
1405   gfc_array_spec * as = NULL;
1406   tree addr_expr = NULL;
1407   tree dt = NULL;
1408   tree string;
1409   tree tmp;
1410   tree dtype;
1411   tree dt_parm_addr;
1412   int n_dim;
1413   int itype;
1414   int rank = 0;
1415
1416   gcc_assert (sym || c);
1417
1418   /* Build the namelist object name.  */
1419
1420   string = gfc_build_cstring_const (var_name);
1421   string = gfc_build_addr_expr (pchar_type_node, string);
1422
1423   /* Build ts, as and data address using symbol or component.  */
1424
1425   ts = (sym) ? &sym->ts : &c->ts;
1426   as = (sym) ? sym->as : c->as;
1427
1428   addr_expr = nml_get_addr_expr (sym, c, base_addr);
1429
1430   if (as)
1431     rank = as->rank;
1432
1433   if (rank)
1434     {
1435       dt =  TREE_TYPE ((sym) ? sym->backend_decl : c->backend_decl);
1436       dtype = gfc_get_dtype (dt);
1437     }
1438   else
1439     {
1440       itype = GFC_DTYPE_UNKNOWN;
1441
1442       switch (ts->type)
1443
1444         {
1445         case BT_INTEGER:
1446           itype = GFC_DTYPE_INTEGER;
1447           break;
1448         case BT_LOGICAL:
1449           itype = GFC_DTYPE_LOGICAL;
1450           break;
1451         case BT_REAL:
1452           itype = GFC_DTYPE_REAL;
1453           break;
1454         case BT_COMPLEX:
1455           itype = GFC_DTYPE_COMPLEX;
1456         break;
1457         case BT_DERIVED:
1458           itype = GFC_DTYPE_DERIVED;
1459           break;
1460         case BT_CHARACTER:
1461           itype = GFC_DTYPE_CHARACTER;
1462           break;
1463         default:
1464           gcc_unreachable ();
1465         }
1466
1467       dtype = IARG (itype << GFC_DTYPE_TYPE_SHIFT);
1468     }
1469
1470   /* Build up the arguments for the transfer call.
1471      The call for the scalar part transfers:
1472      (address, name, type, kind or string_length, dtype)  */
1473
1474   dt_parm_addr = build_fold_addr_expr (dt_parm);
1475
1476   if (ts->type == BT_CHARACTER)
1477     tmp = ts->cl->backend_decl;
1478   else
1479     tmp = build_int_cst (gfc_charlen_type_node, 0);
1480   tmp = build_call_expr (iocall[IOCALL_SET_NML_VAL], 6,
1481                          dt_parm_addr, addr_expr, string,
1482                          IARG (ts->kind), tmp, dtype);
1483   gfc_add_expr_to_block (block, tmp);
1484
1485   /* If the object is an array, transfer rank times:
1486      (null pointer, name, stride, lbound, ubound)  */
1487
1488   for ( n_dim = 0 ; n_dim < rank ; n_dim++ )
1489     {
1490       tmp = build_call_expr (iocall[IOCALL_SET_NML_VAL_DIM], 5,
1491                              dt_parm_addr,
1492                              IARG (n_dim),
1493                              GFC_TYPE_ARRAY_STRIDE (dt, n_dim),
1494                              GFC_TYPE_ARRAY_LBOUND (dt, n_dim),
1495                              GFC_TYPE_ARRAY_UBOUND (dt, n_dim));
1496       gfc_add_expr_to_block (block, tmp);
1497     }
1498
1499   if (ts->type == BT_DERIVED)
1500     {
1501       gfc_component *cmp;
1502
1503       /* Provide the RECORD_TYPE to build component references.  */
1504
1505       tree expr = build_fold_indirect_ref (addr_expr);
1506
1507       for (cmp = ts->derived->components; cmp; cmp = cmp->next)
1508         {
1509           char *full_name = nml_full_name (var_name, cmp->name);
1510           transfer_namelist_element (block,
1511                                      full_name,
1512                                      NULL, cmp, expr);
1513           gfc_free (full_name);
1514         }
1515     }
1516 }
1517
1518 #undef IARG
1519
1520 /* Create a data transfer statement.  Not all of the fields are valid
1521    for both reading and writing, but improper use has been filtered
1522    out by now.  */
1523
1524 static tree
1525 build_dt (tree function, gfc_code * code)
1526 {
1527   stmtblock_t block, post_block, post_end_block, post_iu_block;
1528   gfc_dt *dt;
1529   tree tmp, var;
1530   gfc_expr *nmlname;
1531   gfc_namelist *nml;
1532   unsigned int mask = 0;
1533
1534   gfc_start_block (&block);
1535   gfc_init_block (&post_block);
1536   gfc_init_block (&post_end_block);
1537   gfc_init_block (&post_iu_block);
1538
1539   var = gfc_create_var (st_parameter[IOPARM_ptype_dt].type, "dt_parm");
1540
1541   set_error_locus (&block, var, &code->loc);
1542
1543   if (last_dt == IOLENGTH)
1544     {
1545       gfc_inquire *inq;
1546
1547       inq = code->ext.inquire;
1548
1549       /* First check that preconditions are met.  */
1550       gcc_assert (inq != NULL);
1551       gcc_assert (inq->iolength != NULL);
1552
1553       /* Connect to the iolength variable.  */
1554       mask |= set_parameter_ref (&block, &post_end_block, var,
1555                                  IOPARM_dt_iolength, inq->iolength);
1556       dt = NULL;
1557     }
1558   else
1559     {
1560       dt = code->ext.dt;
1561       gcc_assert (dt != NULL);
1562     }
1563
1564   if (dt && dt->io_unit)
1565     {
1566       if (dt->io_unit->ts.type == BT_CHARACTER)
1567         {
1568           mask |= set_internal_unit (&block, &post_iu_block,
1569                                      var, dt->io_unit);
1570           set_parameter_const (&block, var, IOPARM_common_unit, 0);
1571         }
1572     }
1573   else
1574     set_parameter_const (&block, var, IOPARM_common_unit, 0);
1575
1576   if (dt)
1577     {
1578       if (dt->iomsg)
1579         mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
1580                             dt->iomsg);
1581
1582       if (dt->iostat)
1583         mask |= set_parameter_ref (&block, &post_end_block, var,
1584                                    IOPARM_common_iostat, dt->iostat);
1585
1586       if (dt->err)
1587         mask |= IOPARM_common_err;
1588
1589       if (dt->eor)
1590         mask |= IOPARM_common_eor;
1591
1592       if (dt->end)
1593         mask |= IOPARM_common_end;
1594
1595       if (dt->rec)
1596         mask |= set_parameter_value (&block, var, IOPARM_dt_rec, dt->rec);
1597
1598       if (dt->advance)
1599         mask |= set_string (&block, &post_block, var, IOPARM_dt_advance,
1600                             dt->advance);
1601
1602       if (dt->format_expr)
1603         mask |= set_string (&block, &post_end_block, var, IOPARM_dt_format,
1604                             dt->format_expr);
1605
1606       if (dt->format_label)
1607         {
1608           if (dt->format_label == &format_asterisk)
1609             mask |= IOPARM_dt_list_format;
1610           else
1611             mask |= set_string (&block, &post_block, var, IOPARM_dt_format,
1612                                 dt->format_label->format);
1613         }
1614
1615       if (dt->size)
1616         mask |= set_parameter_ref (&block, &post_end_block, var,
1617                                    IOPARM_dt_size, dt->size);
1618
1619       if (dt->namelist)
1620         {
1621           if (dt->format_expr || dt->format_label)
1622             gfc_internal_error ("build_dt: format with namelist");
1623
1624           nmlname = gfc_new_nml_name_expr (dt->namelist->name);
1625
1626           mask |= set_string (&block, &post_block, var, IOPARM_dt_namelist_name,
1627                               nmlname);
1628
1629           if (last_dt == READ)
1630             mask |= IOPARM_dt_namelist_read_mode;
1631
1632           set_parameter_const (&block, var, IOPARM_common_flags, mask);
1633
1634           dt_parm = var;
1635
1636           for (nml = dt->namelist->namelist; nml; nml = nml->next)
1637             transfer_namelist_element (&block, nml->sym->name, nml->sym,
1638                                        NULL, NULL);
1639         }
1640       else
1641         set_parameter_const (&block, var, IOPARM_common_flags, mask);
1642
1643       if (dt->io_unit && dt->io_unit->ts.type == BT_INTEGER)
1644         set_parameter_value (&block, var, IOPARM_common_unit, dt->io_unit);
1645     }
1646   else
1647     set_parameter_const (&block, var, IOPARM_common_flags, mask);
1648
1649   tmp = build_fold_addr_expr (var);
1650   tmp = build_call_expr (function, 1, tmp);
1651   gfc_add_expr_to_block (&block, tmp);
1652
1653   gfc_add_block_to_block (&block, &post_block);
1654
1655   dt_parm = var;
1656   dt_post_end_block = &post_end_block;
1657
1658   gfc_add_expr_to_block (&block, gfc_trans_code (code->block->next));
1659
1660   gfc_add_block_to_block (&block, &post_iu_block);
1661
1662   dt_parm = NULL;
1663   dt_post_end_block = NULL;
1664
1665   return gfc_finish_block (&block);
1666 }
1667
1668
1669 /* Translate the IOLENGTH form of an INQUIRE statement.  We treat
1670    this as a third sort of data transfer statement, except that
1671    lengths are summed instead of actually transferring any data.  */
1672
1673 tree
1674 gfc_trans_iolength (gfc_code * code)
1675 {
1676   last_dt = IOLENGTH;
1677   return build_dt (iocall[IOCALL_IOLENGTH], code);
1678 }
1679
1680
1681 /* Translate a READ statement.  */
1682
1683 tree
1684 gfc_trans_read (gfc_code * code)
1685 {
1686   last_dt = READ;
1687   return build_dt (iocall[IOCALL_READ], code);
1688 }
1689
1690
1691 /* Translate a WRITE statement */
1692
1693 tree
1694 gfc_trans_write (gfc_code * code)
1695 {
1696   last_dt = WRITE;
1697   return build_dt (iocall[IOCALL_WRITE], code);
1698 }
1699
1700
1701 /* Finish a data transfer statement.  */
1702
1703 tree
1704 gfc_trans_dt_end (gfc_code * code)
1705 {
1706   tree function, tmp;
1707   stmtblock_t block;
1708
1709   gfc_init_block (&block);
1710
1711   switch (last_dt)
1712     {
1713     case READ:
1714       function = iocall[IOCALL_READ_DONE];
1715       break;
1716
1717     case WRITE:
1718       function = iocall[IOCALL_WRITE_DONE];
1719       break;
1720
1721     case IOLENGTH:
1722       function = iocall[IOCALL_IOLENGTH_DONE];
1723       break;
1724
1725     default:
1726       gcc_unreachable ();
1727     }
1728
1729   tmp = build_fold_addr_expr (dt_parm);
1730   tmp = build_call_expr (function, 1, tmp);
1731   gfc_add_expr_to_block (&block, tmp);
1732   gfc_add_block_to_block (&block, dt_post_end_block);
1733   gfc_init_block (dt_post_end_block);
1734
1735   if (last_dt != IOLENGTH)
1736     {
1737       gcc_assert (code->ext.dt != NULL);
1738       io_result (&block, dt_parm, code->ext.dt->err,
1739                  code->ext.dt->end, code->ext.dt->eor);
1740     }
1741
1742   return gfc_finish_block (&block);
1743 }
1744
1745 static void
1746 transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr, gfc_code * code);
1747
1748 /* Given an array field in a derived type variable, generate the code
1749    for the loop that iterates over array elements, and the code that
1750    accesses those array elements.  Use transfer_expr to generate code
1751    for transferring that element.  Because elements may also be
1752    derived types, transfer_expr and transfer_array_component are mutually
1753    recursive.  */
1754
1755 static tree
1756 transfer_array_component (tree expr, gfc_component * cm)
1757 {
1758   tree tmp;
1759   stmtblock_t body;
1760   stmtblock_t block;
1761   gfc_loopinfo loop;
1762   int n;
1763   gfc_ss *ss;
1764   gfc_se se;
1765
1766   gfc_start_block (&block);
1767   gfc_init_se (&se, NULL);
1768
1769   /* Create and initialize Scalarization Status.  Unlike in
1770      gfc_trans_transfer, we can't simply use gfc_walk_expr to take
1771      care of this task, because we don't have a gfc_expr at hand.
1772      Build one manually, as in gfc_trans_subarray_assign.  */
1773
1774   ss = gfc_get_ss ();
1775   ss->type = GFC_SS_COMPONENT;
1776   ss->expr = NULL;
1777   ss->shape = gfc_get_shape (cm->as->rank);
1778   ss->next = gfc_ss_terminator;
1779   ss->data.info.dimen = cm->as->rank;
1780   ss->data.info.descriptor = expr;
1781   ss->data.info.data = gfc_conv_array_data (expr);
1782   ss->data.info.offset = gfc_conv_array_offset (expr);
1783   for (n = 0; n < cm->as->rank; n++)
1784     {
1785       ss->data.info.dim[n] = n;
1786       ss->data.info.start[n] = gfc_conv_array_lbound (expr, n);
1787       ss->data.info.stride[n] = gfc_index_one_node;
1788
1789       mpz_init (ss->shape[n]);
1790       mpz_sub (ss->shape[n], cm->as->upper[n]->value.integer,
1791                cm->as->lower[n]->value.integer);
1792       mpz_add_ui (ss->shape[n], ss->shape[n], 1);
1793     }
1794
1795   /* Once we got ss, we use scalarizer to create the loop.  */
1796
1797   gfc_init_loopinfo (&loop);
1798   gfc_add_ss_to_loop (&loop, ss);
1799   gfc_conv_ss_startstride (&loop);
1800   gfc_conv_loop_setup (&loop);
1801   gfc_mark_ss_chain_used (ss, 1);
1802   gfc_start_scalarized_body (&loop, &body);
1803
1804   gfc_copy_loopinfo_to_se (&se, &loop);
1805   se.ss = ss;
1806
1807   /* gfc_conv_tmp_array_ref assumes that se.expr contains the array.  */
1808   se.expr = expr;
1809   gfc_conv_tmp_array_ref (&se);
1810
1811   /* Now se.expr contains an element of the array.  Take the address and pass
1812      it to the IO routines.  */
1813   tmp = build_fold_addr_expr (se.expr);
1814   transfer_expr (&se, &cm->ts, tmp, NULL);
1815
1816   /* We are done now with the loop body.  Wrap up the scalarizer and
1817      return.  */
1818
1819   gfc_add_block_to_block (&body, &se.pre);
1820   gfc_add_block_to_block (&body, &se.post);
1821
1822   gfc_trans_scalarizing_loops (&loop, &body);
1823
1824   gfc_add_block_to_block (&block, &loop.pre);
1825   gfc_add_block_to_block (&block, &loop.post);
1826
1827   for (n = 0; n < cm->as->rank; n++)
1828     mpz_clear (ss->shape[n]);
1829   gfc_free (ss->shape);
1830
1831   gfc_cleanup_loop (&loop);
1832
1833   return gfc_finish_block (&block);
1834 }
1835
1836 /* Generate the call for a scalar transfer node.  */
1837
1838 static void
1839 transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr, gfc_code * code)
1840 {
1841   tree tmp, function, arg2, field, expr;
1842   gfc_component *c;
1843   int kind;
1844
1845   /* It is possible to get a C_NULL_PTR or C_NULL_FUNPTR expression here if
1846      the user says something like: print *, 'c_null_ptr: ', c_null_ptr
1847      We need to translate the expression to a constant if it's either
1848      C_NULL_PTR or C_NULL_FUNPTR.  We could also get a user variable of
1849      type C_PTR or C_FUNPTR, in which case the ts->type may no longer be
1850      BT_DERIVED (could have been changed by gfc_conv_expr).  */
1851   if ((ts->type == BT_DERIVED && ts->is_iso_c == 1 && ts->derived != NULL)
1852       || (ts->derived != NULL && ts->derived->ts.is_iso_c == 1))
1853     {
1854       /* C_PTR and C_FUNPTR have private components which means they can not
1855          be printed.  However, if -std=gnu and not -pedantic, allow
1856          the component to be printed to help debugging.  */
1857       if (gfc_notification_std (GFC_STD_GNU) != SILENT)
1858         {
1859           gfc_error_now ("Derived type '%s' at %L has PRIVATE components",
1860                          ts->derived->name, code != NULL ? &(code->loc) :
1861                          &gfc_current_locus);
1862           return;
1863         }
1864
1865       ts->type = ts->derived->ts.type;
1866       ts->kind = ts->derived->ts.kind;
1867       ts->f90_type = ts->derived->ts.f90_type;
1868     }
1869
1870   kind = ts->kind;
1871   function = NULL;
1872   arg2 = NULL;
1873
1874   switch (ts->type)
1875     {
1876     case BT_INTEGER:
1877       arg2 = build_int_cst (NULL_TREE, kind);
1878       function = iocall[IOCALL_X_INTEGER];
1879       break;
1880
1881     case BT_REAL:
1882       arg2 = build_int_cst (NULL_TREE, kind);
1883       function = iocall[IOCALL_X_REAL];
1884       break;
1885
1886     case BT_COMPLEX:
1887       arg2 = build_int_cst (NULL_TREE, kind);
1888       function = iocall[IOCALL_X_COMPLEX];
1889       break;
1890
1891     case BT_LOGICAL:
1892       arg2 = build_int_cst (NULL_TREE, kind);
1893       function = iocall[IOCALL_X_LOGICAL];
1894       break;
1895
1896     case BT_CHARACTER:
1897     case BT_HOLLERITH:
1898       if (se->string_length)
1899         arg2 = se->string_length;
1900       else
1901         {
1902           tmp = build_fold_indirect_ref (addr_expr);
1903           gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
1904           arg2 = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp)));
1905         }
1906       function = iocall[IOCALL_X_CHARACTER];
1907       break;
1908
1909     case BT_DERIVED:
1910       /* Recurse into the elements of the derived type.  */
1911       expr = gfc_evaluate_now (addr_expr, &se->pre);
1912       expr = build_fold_indirect_ref (expr);
1913
1914       for (c = ts->derived->components; c; c = c->next)
1915         {
1916           field = c->backend_decl;
1917           gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
1918
1919           tmp = build3 (COMPONENT_REF, TREE_TYPE (field), expr, field,
1920                         NULL_TREE);
1921
1922           if (c->dimension)
1923             {
1924               tmp = transfer_array_component (tmp, c);
1925               gfc_add_expr_to_block (&se->pre, tmp);
1926             }
1927           else
1928             {
1929               if (!c->pointer)
1930                 tmp = build_fold_addr_expr (tmp);
1931               transfer_expr (se, &c->ts, tmp, code);
1932             }
1933         }
1934       return;
1935
1936     default:
1937       internal_error ("Bad IO basetype (%d)", ts->type);
1938     }
1939
1940   tmp = build_fold_addr_expr (dt_parm);
1941   tmp = build_call_expr (function, 3, tmp, addr_expr, arg2);
1942   gfc_add_expr_to_block (&se->pre, tmp);
1943   gfc_add_block_to_block (&se->pre, &se->post);
1944
1945 }
1946
1947
1948 /* Generate a call to pass an array descriptor to the IO library. The
1949    array should be of one of the intrinsic types.  */
1950
1951 static void
1952 transfer_array_desc (gfc_se * se, gfc_typespec * ts, tree addr_expr)
1953 {
1954   tree tmp, charlen_arg, kind_arg;
1955
1956   if (ts->type == BT_CHARACTER)
1957     charlen_arg = se->string_length;
1958   else
1959     charlen_arg = build_int_cst (NULL_TREE, 0);
1960
1961   kind_arg = build_int_cst (NULL_TREE, ts->kind);
1962
1963   tmp = build_fold_addr_expr (dt_parm);
1964   tmp = build_call_expr (iocall[IOCALL_X_ARRAY], 4,
1965                          tmp, addr_expr, kind_arg, charlen_arg);
1966   gfc_add_expr_to_block (&se->pre, tmp);
1967   gfc_add_block_to_block (&se->pre, &se->post);
1968 }
1969
1970
1971 /* gfc_trans_transfer()-- Translate a TRANSFER code node */
1972
1973 tree
1974 gfc_trans_transfer (gfc_code * code)
1975 {
1976   stmtblock_t block, body;
1977   gfc_loopinfo loop;
1978   gfc_expr *expr;
1979   gfc_ref *ref;
1980   gfc_ss *ss;
1981   gfc_se se;
1982   tree tmp;
1983
1984   gfc_start_block (&block);
1985   gfc_init_block (&body);
1986
1987   expr = code->expr;
1988   ss = gfc_walk_expr (expr);
1989
1990   ref = NULL;
1991   gfc_init_se (&se, NULL);
1992
1993   if (ss == gfc_ss_terminator)
1994     {
1995       /* Transfer a scalar value.  */
1996       gfc_conv_expr_reference (&se, expr);
1997       transfer_expr (&se, &expr->ts, se.expr, code);
1998     }
1999   else
2000     {
2001       /* Transfer an array. If it is an array of an intrinsic
2002          type, pass the descriptor to the library.  Otherwise
2003          scalarize the transfer.  */
2004       if (expr->ref)
2005         {
2006           for (ref = expr->ref; ref && ref->type != REF_ARRAY;
2007                  ref = ref->next);
2008           gcc_assert (ref->type == REF_ARRAY);
2009         }
2010
2011       if (expr->ts.type != BT_DERIVED && ref && ref->next == NULL)
2012         {
2013           /* Get the descriptor.  */
2014           gfc_conv_expr_descriptor (&se, expr, ss);
2015           tmp = build_fold_addr_expr (se.expr);
2016           transfer_array_desc (&se, &expr->ts, tmp);
2017           goto finish_block_label;
2018         }
2019
2020       /* Initialize the scalarizer.  */
2021       gfc_init_loopinfo (&loop);
2022       gfc_add_ss_to_loop (&loop, ss);
2023
2024       /* Initialize the loop.  */
2025       gfc_conv_ss_startstride (&loop);
2026       gfc_conv_loop_setup (&loop);
2027
2028       /* The main loop body.  */
2029       gfc_mark_ss_chain_used (ss, 1);
2030       gfc_start_scalarized_body (&loop, &body);
2031
2032       gfc_copy_loopinfo_to_se (&se, &loop);
2033       se.ss = ss;
2034
2035       gfc_conv_expr_reference (&se, expr);
2036       transfer_expr (&se, &expr->ts, se.expr, code);
2037     }
2038
2039  finish_block_label:
2040
2041   gfc_add_block_to_block (&body, &se.pre);
2042   gfc_add_block_to_block (&body, &se.post);
2043
2044   if (se.ss == NULL)
2045     tmp = gfc_finish_block (&body);
2046   else
2047     {
2048       gcc_assert (se.ss == gfc_ss_terminator);
2049       gfc_trans_scalarizing_loops (&loop, &body);
2050
2051       gfc_add_block_to_block (&loop.pre, &loop.post);
2052       tmp = gfc_finish_block (&loop.pre);
2053       gfc_cleanup_loop (&loop);
2054     }
2055
2056   gfc_add_expr_to_block (&block, tmp);
2057
2058   return gfc_finish_block (&block);
2059 }
2060
2061 #include "gt-fortran-trans-io.h"
2062