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