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, tmp);
 627
 628   se->string_length = fold_convert (gfc_charlen_type_node, size);
 629 }
 630
 631
 632 /* Generate code to store a string and its length into the
 633    st_parameter_XXX structure.  */
 634
 635 static unsigned int
 636 set_string (stmtblock_t * block, stmtblock_t * postblock, tree var,
 637             enum iofield type, gfc_expr * e)
 638 {
 639   gfc_se se;
 640   tree tmp;
 641   tree io;
 642   tree len;
 643   gfc_st_parameter_field *p = &st_parameter_field[type];
 644
 645   gfc_init_se (&se, NULL);
 646
 647   if (p->param_type == IOPARM_ptype_common)
 648     var = build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type,
 649                   var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
 650   io = build3 (COMPONENT_REF, TREE_TYPE (p->field), var, p->field,
 651                NULL_TREE);
 652   len = build3 (COMPONENT_REF, TREE_TYPE (p->field_len), var, p->field_len,
 653                 NULL_TREE);
 654
 655   /* Integer variable assigned a format label.  */
 656   if (e->ts.type == BT_INTEGER && e->symtree->n.sym->attr.assign == 1)
 657     {
 658       char * msg;
 659
 660       gfc_conv_label_variable (&se, e);
 661       tmp = GFC_DECL_STRING_LEN (se.expr);
 662       tmp = fold_build2 (LT_EXPR, boolean_type_node,
 663                          tmp, build_int_cst (TREE_TYPE (tmp), 0));
 664
 665       asprintf(&msg, "Label assigned to variable '%s' is not a format label",
 666                e->symtree->name);
 667       gfc_trans_runtime_check (tmp, msg, &se.pre, &e->where);
 668       gfc_free (msg);
 669
 670       gfc_add_modify_expr (&se.pre, io,
 671                  fold_convert (TREE_TYPE (io), GFC_DECL_ASSIGN_ADDR (se.expr)));
 672       gfc_add_modify_expr (&se.pre, len, GFC_DECL_STRING_LEN (se.expr));
 673     }
 674   else
 675     {
 676       /* General character.  */
 677       if (e->ts.type == BT_CHARACTER && e->rank == 0)
 678         gfc_conv_expr (&se, e);
 679       /* Array assigned Hollerith constant or character array.  */
 680       else if (e->symtree && (e->symtree->n.sym->as->rank > 0))
 681         gfc_convert_array_to_string (&se, e);
 682       else
 683         gcc_unreachable ();
 684
 685       gfc_conv_string_parameter (&se);
 686       gfc_add_modify_expr (&se.pre, io, fold_convert (TREE_TYPE (io), se.expr));
 687       gfc_add_modify_expr (&se.pre, len, se.string_length);
 688     }
 689
 690   gfc_add_block_to_block (block, &se.pre);
 691   gfc_add_block_to_block (postblock, &se.post);
 692   return p->mask;
 693 }
 694
 695
 696 /* Generate code to store the character (array) and the character length
 697    for an internal unit.  */
 698
 699 static unsigned int
 700 set_internal_unit (stmtblock_t * block, stmtblock_t * post_block,
 701                    tree var, gfc_expr * e)
 702 {
 703   gfc_se se;
 704   tree io;
 705   tree len;
 706   tree desc;
 707   tree tmp;
 708   gfc_st_parameter_field *p;
 709   unsigned int mask;
 710
 711   gfc_init_se (&se, NULL);
 712
 713   p = &st_parameter_field[IOPARM_dt_internal_unit];
 714   mask = p->mask;
 715   io = build3 (COMPONENT_REF, TREE_TYPE (p->field), var, p->field,
 716                NULL_TREE);
 717   len = build3 (COMPONENT_REF, TREE_TYPE (p->field_len), var, p->field_len,
 718                 NULL_TREE);
 719   p = &st_parameter_field[IOPARM_dt_internal_unit_desc];
 720   desc = build3 (COMPONENT_REF, TREE_TYPE (p->field), var, p->field,
 721                  NULL_TREE);
 722
 723   gcc_assert (e->ts.type == BT_CHARACTER);
 724
 725   /* Character scalars.  */
 726   if (e->rank == 0)
 727     {
 728       gfc_conv_expr (&se, e);
 729       gfc_conv_string_parameter (&se);
 730       tmp = se.expr;
 731       se.expr = build_int_cst (pchar_type_node, 0);
 732     }
 733
 734   /* Character array.  */
 735   else if (e->rank > 0)
 736     {
 737       se.ss = gfc_walk_expr (e);
 738
 739       if (is_aliased_array (e))
 740         {
 741           /* Use a temporary for components of arrays of derived types
 742              or substring array references.  */
 743           gfc_conv_aliased_arg (&se, e, 0,
 744                 last_dt == READ ? INTENT_IN : INTENT_OUT);
 745           tmp = build_fold_indirect_ref (se.expr);
 746           se.expr = gfc_build_addr_expr (pchar_type_node, tmp);
 747           tmp = gfc_conv_descriptor_data_get (tmp);
 748         }
 749       else
 750         {
 751           /* Return the data pointer and rank from the descriptor.  */
 752           gfc_conv_expr_descriptor (&se, e, se.ss);
 753           tmp = gfc_conv_descriptor_data_get (se.expr);
 754           se.expr = gfc_build_addr_expr (pchar_type_node, se.expr);
 755         }
 756     }
 757   else
 758     gcc_unreachable ();
 759
 760   /* The cast is needed for character substrings and the descriptor
 761      data.  */
 762   gfc_add_modify_expr (&se.pre, io, fold_convert (TREE_TYPE (io), tmp));
 763   gfc_add_modify_expr (&se.pre, len,
 764                        fold_convert (TREE_TYPE (len), se.string_length));
 765   gfc_add_modify_expr (&se.pre, desc, se.expr);
 766
 767   gfc_add_block_to_block (block, &se.pre);
 768   gfc_add_block_to_block (post_block, &se.post);
 769   return mask;
 770 }
 771
 772 /* Add a case to a IO-result switch.  */
 773
 774 static void
 775 add_case (int label_value, gfc_st_label * label, stmtblock_t * body)
 776 {
 777   tree tmp, value;
 778
 779   if (label == NULL)
 780     return;                     /* No label, no case */
 781
 782   value = build_int_cst (NULL_TREE, label_value);
 783
 784   /* Make a backend label for this case.  */
 785   tmp = gfc_build_label_decl (NULL_TREE);
 786
 787   /* And the case itself.  */
 788   tmp = build3_v (CASE_LABEL_EXPR, value, NULL_TREE, tmp);
 789   gfc_add_expr_to_block (body, tmp);
 790
 791   /* Jump to the label.  */
 792   tmp = build1_v (GOTO_EXPR, gfc_get_label_decl (label));
 793   gfc_add_expr_to_block (body, tmp);
 794 }
 795
 796
 797 /* Generate a switch statement that branches to the correct I/O
 798    result label.  The last statement of an I/O call stores the
 799    result into a variable because there is often cleanup that
 800    must be done before the switch, so a temporary would have to
 801    be created anyway.  */
 802
 803 static void
 804 io_result (stmtblock_t * block, tree var, gfc_st_label * err_label,
 805            gfc_st_label * end_label, gfc_st_label * eor_label)
 806 {
 807   stmtblock_t body;
 808   tree tmp, rc;
 809   gfc_st_parameter_field *p = &st_parameter_field[IOPARM_common_flags];
 810
 811   /* If no labels are specified, ignore the result instead
 812      of building an empty switch.  */
 813   if (err_label == NULL
 814       && end_label == NULL
 815       && eor_label == NULL)
 816     return;
 817
 818   /* Build a switch statement.  */
 819   gfc_start_block (&body);
 820
 821   /* The label values here must be the same as the values
 822      in the library_return enum in the runtime library */
 823   add_case (1, err_label, &body);
 824   add_case (2, end_label, &body);
 825   add_case (3, eor_label, &body);
 826
 827   tmp = gfc_finish_block (&body);
 828
 829   var = build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type,
 830                 var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
 831   rc = build3 (COMPONENT_REF, TREE_TYPE (p->field), var, p->field,
 832                NULL_TREE);
 833   rc = build2 (BIT_AND_EXPR, TREE_TYPE (rc), rc,
 834                build_int_cst (TREE_TYPE (rc), IOPARM_common_libreturn_mask));
 835
 836   tmp = build3_v (SWITCH_EXPR, rc, tmp, NULL_TREE);
 837
 838   gfc_add_expr_to_block (block, tmp);
 839 }
 840
 841
 842 /* Store the current file and line number to variables so that if a
 843    library call goes awry, we can tell the user where the problem is.  */
 844
 845 static void
 846 set_error_locus (stmtblock_t * block, tree var, locus * where)
 847 {
 848   gfc_file *f;
 849   tree str, locus_file;
 850   int line;
 851   gfc_st_parameter_field *p = &st_parameter_field[IOPARM_common_filename];
 852
 853   locus_file = build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type,
 854                        var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
 855   locus_file = build3 (COMPONENT_REF, TREE_TYPE (p->field), locus_file,
 856                        p->field, NULL_TREE);
 857   f = where->lb->file;
 858   str = gfc_build_cstring_const (f->filename);
 859
 860   str = gfc_build_addr_expr (pchar_type_node, str);
 861   gfc_add_modify_expr (block, locus_file, str);
 862
 863 #ifdef USE_MAPPED_LOCATION
 864   line = LOCATION_LINE (where->lb->location);
 865 #else
 866   line = where->lb->linenum;
 867 #endif
 868   set_parameter_const (block, var, IOPARM_common_line, line);
 869 }
 870
 871
 872 /* Translate an OPEN statement.  */
 873
 874 tree
 875 gfc_trans_open (gfc_code * code)
 876 {
 877   stmtblock_t block, post_block;
 878   gfc_open *p;
 879   tree tmp, var;
 880   unsigned int mask = 0;
 881
 882   gfc_start_block (&block);
 883   gfc_init_block (&post_block);
 884
 885   var = gfc_create_var (st_parameter[IOPARM_ptype_open].type, "open_parm");
 886
 887   set_error_locus (&block, var, &code->loc);
 888   p = code->ext.open;
 889
 890   if (p->iomsg)
 891     mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
 892                         p->iomsg);
 893
 894   if (p->iostat)
 895     mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
 896                                p->iostat);
 897
 898   if (p->err)
 899     mask |= IOPARM_common_err;
 900
 901   if (p->file)
 902     mask |= set_string (&block, &post_block, var, IOPARM_open_file, p->file);
 903
 904   if (p->status)
 905     mask |= set_string (&block, &post_block, var, IOPARM_open_status,
 906                         p->status);
 907
 908   if (p->access)
 909     mask |= set_string (&block, &post_block, var, IOPARM_open_access,
 910                         p->access);
 911
 912   if (p->form)
 913     mask |= set_string (&block, &post_block, var, IOPARM_open_form, p->form);
 914
 915   if (p->recl)
 916     mask |= set_parameter_value (&block, var, IOPARM_open_recl_in, p->recl);
 917
 918   if (p->blank)
 919     mask |= set_string (&block, &post_block, var, IOPARM_open_blank,
 920                         p->blank);
 921
 922   if (p->position)
 923     mask |= set_string (&block, &post_block, var, IOPARM_open_position,
 924                         p->position);
 925
 926   if (p->action)
 927     mask |= set_string (&block, &post_block, var, IOPARM_open_action,
 928                         p->action);
 929
 930   if (p->delim)
 931     mask |= set_string (&block, &post_block, var, IOPARM_open_delim,
 932                         p->delim);
 933
 934   if (p->pad)
 935     mask |= set_string (&block, &post_block, var, IOPARM_open_pad, p->pad);
 936
 937   if (p->convert)
 938     mask |= set_string (&block, &post_block, var, IOPARM_open_convert,
 939                         p->convert);
 940
 941   set_parameter_const (&block, var, IOPARM_common_flags, mask);
 942
 943   if (p->unit)
 944     set_parameter_value (&block, var, IOPARM_common_unit, p->unit);
 945   else
 946     set_parameter_const (&block, var, IOPARM_common_unit, 0);
 947
 948   tmp = build_fold_addr_expr (var);
 949   tmp = build_call_expr (iocall[IOCALL_OPEN], 1, tmp);
 950   gfc_add_expr_to_block (&block, tmp);
 951
 952   gfc_add_block_to_block (&block, &post_block);
 953
 954   io_result (&block, var, p->err, NULL, NULL);
 955
 956   return gfc_finish_block (&block);
 957 }
 958
 959
 960 /* Translate a CLOSE statement.  */
 961
 962 tree
 963 gfc_trans_close (gfc_code * code)
 964 {
 965   stmtblock_t block, post_block;
 966   gfc_close *p;
 967   tree tmp, var;
 968   unsigned int mask = 0;
 969
 970   gfc_start_block (&block);
 971   gfc_init_block (&post_block);
 972
 973   var = gfc_create_var (st_parameter[IOPARM_ptype_close].type, "close_parm");
 974
 975   set_error_locus (&block, var, &code->loc);
 976   p = code->ext.close;
 977
 978   if (p->iomsg)
 979     mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
 980                         p->iomsg);
 981
 982   if (p->iostat)
 983     mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
 984                                p->iostat);
 985
 986   if (p->err)
 987     mask |= IOPARM_common_err;
 988
 989   if (p->status)
 990     mask |= set_string (&block, &post_block, var, IOPARM_close_status,
 991                         p->status);
 992
 993   set_parameter_const (&block, var, IOPARM_common_flags, mask);
 994
 995   if (p->unit)
 996     set_parameter_value (&block, var, IOPARM_common_unit, p->unit);
 997   else
 998     set_parameter_const (&block, var, IOPARM_common_unit, 0);
 999
1000   tmp = build_fold_addr_expr (var);
1001   tmp = build_call_expr (iocall[IOCALL_CLOSE], 1, tmp);
1002   gfc_add_expr_to_block (&block, tmp);
1003
1004   gfc_add_block_to_block (&block, &post_block);
1005
1006   io_result (&block, var, p->err, NULL, NULL);
1007
1008   return gfc_finish_block (&block);
1009 }
1010
1011
1012 /* Common subroutine for building a file positioning statement.  */
1013
1014 static tree
1015 build_filepos (tree function, gfc_code * code)
1016 {
1017   stmtblock_t block, post_block;
1018   gfc_filepos *p;
1019   tree tmp, var;
1020   unsigned int mask = 0;
1021
1022   p = code->ext.filepos;
1023
1024   gfc_start_block (&block);
1025   gfc_init_block (&post_block);
1026
1027   var = gfc_create_var (st_parameter[IOPARM_ptype_filepos].type,
1028                         "filepos_parm");
1029
1030   set_error_locus (&block, var, &code->loc);
1031
1032   if (p->iomsg)
1033     mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
1034                         p->iomsg);
1035
1036   if (p->iostat)
1037     mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
1038                                p->iostat);
1039
1040   if (p->err)
1041     mask |= IOPARM_common_err;
1042
1043   set_parameter_const (&block, var, IOPARM_common_flags, mask);
1044
1045   if (p->unit)
1046     set_parameter_value (&block, var, IOPARM_common_unit, p->unit);
1047   else
1048     set_parameter_const (&block, var, IOPARM_common_unit, 0);
1049
1050   tmp = build_fold_addr_expr (var);
1051   tmp = build_call_expr (function, 1, tmp);
1052   gfc_add_expr_to_block (&block, tmp);
1053
1054   gfc_add_block_to_block (&block, &post_block);
1055
1056   io_result (&block, var, p->err, NULL, NULL);
1057
1058   return gfc_finish_block (&block);
1059 }
1060
1061
1062 /* Translate a BACKSPACE statement.  */
1063
1064 tree
1065 gfc_trans_backspace (gfc_code * code)
1066 {
1067   return build_filepos (iocall[IOCALL_BACKSPACE], code);
1068 }
1069
1070
1071 /* Translate an ENDFILE statement.  */
1072
1073 tree
1074 gfc_trans_endfile (gfc_code * code)
1075 {
1076   return build_filepos (iocall[IOCALL_ENDFILE], code);
1077 }
1078
1079
1080 /* Translate a REWIND statement.  */
1081
1082 tree
1083 gfc_trans_rewind (gfc_code * code)
1084 {
1085   return build_filepos (iocall[IOCALL_REWIND], code);
1086 }
1087
1088
1089 /* Translate a FLUSH statement.  */
1090
1091 tree
1092 gfc_trans_flush (gfc_code * code)
1093 {
1094   return build_filepos (iocall[IOCALL_FLUSH], code);
1095 }
1096
1097
1098 /* Translate the non-IOLENGTH form of an INQUIRE statement.  */
1099
1100 tree
1101 gfc_trans_inquire (gfc_code * code)
1102 {
1103   stmtblock_t block, post_block;
1104   gfc_inquire *p;
1105   tree tmp, var;
1106   unsigned int mask = 0;
1107
1108   gfc_start_block (&block);
1109   gfc_init_block (&post_block);
1110
1111   var = gfc_create_var (st_parameter[IOPARM_ptype_inquire].type,
1112                         "inquire_parm");
1113
1114   set_error_locus (&block, var, &code->loc);
1115   p = code->ext.inquire;
1116
1117   if (p->iomsg)
1118     mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
1119                         p->iomsg);
1120
1121   if (p->iostat)
1122     mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
1123                                p->iostat);
1124
1125   if (p->err)
1126     mask |= IOPARM_common_err;
1127
1128   /* Sanity check.  */
1129   if (p->unit && p->file)
1130     gfc_error ("INQUIRE statement at %L cannot contain both FILE and UNIT specifiers", &code->loc);
1131
1132   if (p->file)
1133     mask |= set_string (&block, &post_block, var, IOPARM_inquire_file,
1134                         p->file);
1135
1136   if (p->exist)
1137     mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_exist,
1138                                p->exist);
1139
1140   if (p->opened)
1141     mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_opened,
1142                                p->opened);
1143
1144   if (p->number)
1145     mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_number,
1146                                p->number);
1147
1148   if (p->named)
1149     mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_named,
1150                                p->named);
1151
1152   if (p->name)
1153     mask |= set_string (&block, &post_block, var, IOPARM_inquire_name,
1154                         p->name);
1155
1156   if (p->access)
1157     mask |= set_string (&block, &post_block, var, IOPARM_inquire_access,
1158                         p->access);
1159
1160   if (p->sequential)
1161     mask |= set_string (&block, &post_block, var, IOPARM_inquire_sequential,
1162                         p->sequential);
1163
1164   if (p->direct)
1165     mask |= set_string (&block, &post_block, var, IOPARM_inquire_direct,
1166                         p->direct);
1167
1168   if (p->form)
1169     mask |= set_string (&block, &post_block, var, IOPARM_inquire_form,
1170                         p->form);
1171
1172   if (p->formatted)
1173     mask |= set_string (&block, &post_block, var, IOPARM_inquire_formatted,
1174                         p->formatted);
1175
1176   if (p->unformatted)
1177     mask |= set_string (&block, &post_block, var, IOPARM_inquire_unformatted,
1178                         p->unformatted);
1179
1180   if (p->recl)
1181     mask |= set_parameter_ref (&block, &post_block, var,
1182                                IOPARM_inquire_recl_out, p->recl);
1183
1184   if (p->nextrec)
1185     mask |= set_parameter_ref (&block, &post_block, var,
1186                                IOPARM_inquire_nextrec, p->nextrec);
1187
1188   if (p->blank)
1189     mask |= set_string (&block, &post_block, var, IOPARM_inquire_blank,
1190                         p->blank);
1191
1192   if (p->position)
1193     mask |= set_string (&block, &post_block, var, IOPARM_inquire_position,
1194                         p->position);
1195
1196   if (p->action)
1197     mask |= set_string (&block, &post_block, var, IOPARM_inquire_action,
1198                         p->action);
1199
1200   if (p->read)
1201     mask |= set_string (&block, &post_block, var, IOPARM_inquire_read,
1202                         p->read);
1203
1204   if (p->write)
1205     mask |= set_string (&block, &post_block, var, IOPARM_inquire_write,
1206                         p->write);
1207
1208   if (p->readwrite)
1209     mask |= set_string (&block, &post_block, var, IOPARM_inquire_readwrite,
1210                         p->readwrite);
1211
1212   if (p->delim)
1213     mask |= set_string (&block, &post_block, var, IOPARM_inquire_delim,
1214                         p->delim);
1215
1216   if (p->pad)
1217     mask |= set_string (&block, &post_block, var, IOPARM_inquire_pad,
1218                         p->pad);
1219
1220   if (p->convert)
1221     mask |= set_string (&block, &post_block, var, IOPARM_inquire_convert,
1222                         p->convert);
1223
1224   if (p->strm_pos)
1225     mask |= set_parameter_ref (&block, &post_block, var,
1226                                IOPARM_inquire_strm_pos_out, p->strm_pos);
1227
1228   set_parameter_const (&block, var, IOPARM_common_flags, mask);
1229
1230   if (p->unit)
1231     set_parameter_value (&block, var, IOPARM_common_unit, p->unit);
1232   else
1233     set_parameter_const (&block, var, IOPARM_common_unit, 0);
1234
1235   tmp = build_fold_addr_expr (var);
1236   tmp = build_call_expr (iocall[IOCALL_INQUIRE], 1, tmp);
1237   gfc_add_expr_to_block (&block, tmp);
1238
1239   gfc_add_block_to_block (&block, &post_block);
1240
1241   io_result (&block, var, p->err, NULL, NULL);
1242
1243   return gfc_finish_block (&block);
1244 }
1245
1246 static gfc_expr *
1247 gfc_new_nml_name_expr (const char * name)
1248 {
1249    gfc_expr * nml_name;
1250
1251    nml_name = gfc_get_expr();
1252    nml_name->ref = NULL;
1253    nml_name->expr_type = EXPR_CONSTANT;
1254    nml_name->ts.kind = gfc_default_character_kind;
1255    nml_name->ts.type = BT_CHARACTER;
1256    nml_name->value.character.length = strlen(name);
1257    nml_name->value.character.string = gfc_getmem (strlen (name) + 1);
1258    strcpy (nml_name->value.character.string, name);
1259
1260    return nml_name;
1261 }
1262
1263 /* nml_full_name builds up the fully qualified name of a
1264    derived type component.  */
1265
1266 static char*
1267 nml_full_name (const char* var_name, const char* cmp_name)
1268 {
1269   int full_name_length;
1270   char * full_name;
1271
1272   full_name_length = strlen (var_name) + strlen (cmp_name) + 1;
1273   full_name = (char*)gfc_getmem (full_name_length + 1);
1274   strcpy (full_name, var_name);
1275   full_name = strcat (full_name, "%");
1276   full_name = strcat (full_name, cmp_name);
1277   return full_name;
1278 }
1279
1280 /* nml_get_addr_expr builds an address expression from the
1281    gfc_symbol or gfc_component backend_decl's. An offset is
1282    provided so that the address of an element of an array of
1283    derived types is returned. This is used in the runtime to
1284    determine that span of the derived type.  */
1285
1286 static tree
1287 nml_get_addr_expr (gfc_symbol * sym, gfc_component * c,
1288                    tree base_addr)
1289 {
1290   tree decl = NULL_TREE;
1291   tree tmp;
1292   tree itmp;
1293   int array_flagged;
1294   int dummy_arg_flagged;
1295
1296   if (sym)
1297     {
1298       sym->attr.referenced = 1;
1299       decl = gfc_get_symbol_decl (sym);
1300
1301       /* If this is the enclosing function declaration, use
1302          the fake result instead.  */
1303       if (decl == current_function_decl)
1304         decl = gfc_get_fake_result_decl (sym, 0);
1305       else if (decl == DECL_CONTEXT (current_function_decl))
1306         decl =  gfc_get_fake_result_decl (sym, 1);
1307     }
1308   else
1309     decl = c->backend_decl;
1310
1311   gcc_assert (decl && ((TREE_CODE (decl) == FIELD_DECL
1312                      || TREE_CODE (decl) == VAR_DECL
1313                      || TREE_CODE (decl) == PARM_DECL)
1314                      || TREE_CODE (decl) == COMPONENT_REF));
1315
1316   tmp = decl;
1317
1318   /* Build indirect reference, if dummy argument.  */
1319
1320   dummy_arg_flagged = POINTER_TYPE_P (TREE_TYPE(tmp));
1321
1322   itmp = (dummy_arg_flagged) ? build_fold_indirect_ref (tmp) : tmp;
1323
1324   /* If an array, set flag and use indirect ref. if built.  */
1325
1326   array_flagged = (TREE_CODE (TREE_TYPE (itmp)) == ARRAY_TYPE
1327                    && !TYPE_STRING_FLAG (TREE_TYPE (itmp)));
1328
1329   if (array_flagged)
1330     tmp = itmp;
1331
1332   /* Treat the component of a derived type, using base_addr for
1333      the derived type.  */
1334
1335   if (TREE_CODE (decl) == FIELD_DECL)
1336     tmp = build3 (COMPONENT_REF, TREE_TYPE (tmp),
1337                   base_addr, tmp, NULL_TREE);
1338
1339   /* If we have a derived type component, a reference to the first
1340      element of the array is built.  This is done so that base_addr,
1341      used in the build of the component reference, always points to
1342      a RECORD_TYPE.  */
1343
1344   if (array_flagged)
1345     tmp = gfc_build_array_ref (tmp, gfc_index_zero_node);
1346
1347   /* Now build the address expression.  */
1348
1349   tmp = build_fold_addr_expr (tmp);
1350
1351   /* If scalar dummy, resolve indirect reference now.  */
1352
1353   if (dummy_arg_flagged && !array_flagged)
1354     tmp = build_fold_indirect_ref (tmp);
1355
1356   gcc_assert (tmp && POINTER_TYPE_P (TREE_TYPE (tmp)));
1357
1358   return tmp;
1359 }
1360
1361 /* For an object VAR_NAME whose base address is BASE_ADDR, generate a
1362    call to iocall[IOCALL_SET_NML_VAL].  For derived type variable, recursively
1363    generate calls to iocall[IOCALL_SET_NML_VAL] for each component.  */
1364
1365 #define IARG(i) build_int_cst (gfc_array_index_type, i)
1366
1367 static void
1368 transfer_namelist_element (stmtblock_t * block, const char * var_name,
1369                            gfc_symbol * sym, gfc_component * c,
1370                            tree base_addr)
1371 {
1372   gfc_typespec * ts = NULL;
1373   gfc_array_spec * as = NULL;
1374   tree addr_expr = NULL;
1375   tree dt = NULL;
1376   tree string;
1377   tree tmp;
1378   tree dtype;
1379   tree dt_parm_addr;
1380   int n_dim;
1381   int itype;
1382   int rank = 0;
1383
1384   gcc_assert (sym || c);
1385
1386   /* Build the namelist object name.  */
1387
1388   string = gfc_build_cstring_const (var_name);
1389   string = gfc_build_addr_expr (pchar_type_node, string);
1390
1391   /* Build ts, as and data address using symbol or component.  */
1392
1393   ts = (sym) ? &sym->ts : &c->ts;
1394   as = (sym) ? sym->as : c->as;
1395
1396   addr_expr = nml_get_addr_expr (sym, c, base_addr);
1397
1398   if (as)
1399     rank = as->rank;
1400
1401   if (rank)
1402     {
1403       dt =  TREE_TYPE ((sym) ? sym->backend_decl : c->backend_decl);
1404       dtype = gfc_get_dtype (dt);
1405     }
1406   else
1407     {
1408       itype = GFC_DTYPE_UNKNOWN;
1409
1410       switch (ts->type)
1411
1412         {
1413         case BT_INTEGER:
1414           itype = GFC_DTYPE_INTEGER;
1415           break;
1416         case BT_LOGICAL:
1417           itype = GFC_DTYPE_LOGICAL;
1418           break;
1419         case BT_REAL:
1420           itype = GFC_DTYPE_REAL;
1421           break;
1422         case BT_COMPLEX:
1423           itype = GFC_DTYPE_COMPLEX;
1424         break;
1425         case BT_DERIVED:
1426           itype = GFC_DTYPE_DERIVED;
1427           break;
1428         case BT_CHARACTER:
1429           itype = GFC_DTYPE_CHARACTER;
1430           break;
1431         default:
1432           gcc_unreachable ();
1433         }
1434
1435       dtype = IARG (itype << GFC_DTYPE_TYPE_SHIFT);
1436     }
1437
1438   /* Build up the arguments for the transfer call.
1439      The call for the scalar part transfers:
1440      (address, name, type, kind or string_length, dtype)  */
1441
1442   dt_parm_addr = build_fold_addr_expr (dt_parm);
1443
1444   if (ts->type == BT_CHARACTER)
1445     tmp = ts->cl->backend_decl;
1446   else
1447     tmp = build_int_cst (gfc_charlen_type_node, 0);
1448   tmp = build_call_expr (iocall[IOCALL_SET_NML_VAL], 6,
1449                          dt_parm_addr, addr_expr, string,
1450                          IARG (ts->kind), tmp, dtype);
1451   gfc_add_expr_to_block (block, tmp);
1452
1453   /* If the object is an array, transfer rank times:
1454      (null pointer, name, stride, lbound, ubound)  */
1455
1456   for ( n_dim = 0 ; n_dim < rank ; n_dim++ )
1457     {
1458       tmp = build_call_expr (iocall[IOCALL_SET_NML_VAL_DIM], 5,
1459                              dt_parm_addr,
1460                              IARG (n_dim),
1461                              GFC_TYPE_ARRAY_STRIDE (dt, n_dim),
1462                              GFC_TYPE_ARRAY_LBOUND (dt, n_dim),
1463                              GFC_TYPE_ARRAY_UBOUND (dt, n_dim));
1464       gfc_add_expr_to_block (block, tmp);
1465     }
1466
1467   if (ts->type == BT_DERIVED)
1468     {
1469       gfc_component *cmp;
1470
1471       /* Provide the RECORD_TYPE to build component references.  */
1472
1473       tree expr = build_fold_indirect_ref (addr_expr);
1474
1475       for (cmp = ts->derived->components; cmp; cmp = cmp->next)
1476         {
1477           char *full_name = nml_full_name (var_name, cmp->name);
1478           transfer_namelist_element (block,
1479                                      full_name,
1480                                      NULL, cmp, expr);
1481           gfc_free (full_name);
1482         }
1483     }
1484 }
1485
1486 #undef IARG
1487
1488 /* Create a data transfer statement.  Not all of the fields are valid
1489    for both reading and writing, but improper use has been filtered
1490    out by now.  */
1491
1492 static tree
1493 build_dt (tree function, gfc_code * code)
1494 {
1495   stmtblock_t block, post_block, post_end_block, post_iu_block;
1496   gfc_dt *dt;
1497   tree tmp, var;
1498   gfc_expr *nmlname;
1499   gfc_namelist *nml;
1500   unsigned int mask = 0;
1501
1502   gfc_start_block (&block);
1503   gfc_init_block (&post_block);
1504   gfc_init_block (&post_end_block);
1505   gfc_init_block (&post_iu_block);
1506
1507   var = gfc_create_var (st_parameter[IOPARM_ptype_dt].type, "dt_parm");
1508
1509   set_error_locus (&block, var, &code->loc);
1510
1511   if (last_dt == IOLENGTH)
1512     {
1513       gfc_inquire *inq;
1514
1515       inq = code->ext.inquire;
1516
1517       /* First check that preconditions are met.  */
1518       gcc_assert (inq != NULL);
1519       gcc_assert (inq->iolength != NULL);
1520
1521       /* Connect to the iolength variable.  */
1522       mask |= set_parameter_ref (&block, &post_end_block, var,
1523                                  IOPARM_dt_iolength, inq->iolength);
1524       dt = NULL;
1525     }
1526   else
1527     {
1528       dt = code->ext.dt;
1529       gcc_assert (dt != NULL);
1530     }
1531
1532   if (dt && dt->io_unit)
1533     {
1534       if (dt->io_unit->ts.type == BT_CHARACTER)
1535         {
1536           mask |= set_internal_unit (&block, &post_iu_block,
1537                                      var, dt->io_unit);
1538           set_parameter_const (&block, var, IOPARM_common_unit, 0);
1539         }
1540     }
1541   else
1542     set_parameter_const (&block, var, IOPARM_common_unit, 0);
1543
1544   if (dt)
1545     {
1546       if (dt->iomsg)
1547         mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
1548                             dt->iomsg);
1549
1550       if (dt->iostat)
1551         mask |= set_parameter_ref (&block, &post_end_block, var,
1552                                    IOPARM_common_iostat, dt->iostat);
1553
1554       if (dt->err)
1555         mask |= IOPARM_common_err;
1556
1557       if (dt->eor)
1558         mask |= IOPARM_common_eor;
1559
1560       if (dt->end)
1561         mask |= IOPARM_common_end;
1562
1563       if (dt->rec)
1564         mask |= set_parameter_value (&block, var, IOPARM_dt_rec, dt->rec);
1565
1566       if (dt->advance)
1567         mask |= set_string (&block, &post_block, var, IOPARM_dt_advance,
1568                             dt->advance);
1569
1570       if (dt->format_expr)
1571         mask |= set_string (&block, &post_end_block, var, IOPARM_dt_format,
1572                             dt->format_expr);
1573
1574       if (dt->format_label)
1575         {
1576           if (dt->format_label == &format_asterisk)
1577             mask |= IOPARM_dt_list_format;
1578           else
1579             mask |= set_string (&block, &post_block, var, IOPARM_dt_format,
1580                                 dt->format_label->format);
1581         }
1582
1583       if (dt->size)
1584         mask |= set_parameter_ref (&block, &post_end_block, var,
1585                                    IOPARM_dt_size, dt->size);
1586
1587       if (dt->namelist)
1588         {
1589           if (dt->format_expr || dt->format_label)
1590             gfc_internal_error ("build_dt: format with namelist");
1591
1592           nmlname = gfc_new_nml_name_expr (dt->namelist->name);
1593
1594           mask |= set_string (&block, &post_block, var, IOPARM_dt_namelist_name,
1595                               nmlname);
1596
1597           if (last_dt == READ)
1598             mask |= IOPARM_dt_namelist_read_mode;
1599
1600           set_parameter_const (&block, var, IOPARM_common_flags, mask);
1601
1602           dt_parm = var;
1603
1604           for (nml = dt->namelist->namelist; nml; nml = nml->next)
1605             transfer_namelist_element (&block, nml->sym->name, nml->sym,
1606                                        NULL, NULL);
1607         }
1608       else
1609         set_parameter_const (&block, var, IOPARM_common_flags, mask);
1610
1611       if (dt->io_unit && dt->io_unit->ts.type == BT_INTEGER)
1612         set_parameter_value (&block, var, IOPARM_common_unit, dt->io_unit);
1613     }
1614   else
1615     set_parameter_const (&block, var, IOPARM_common_flags, mask);
1616
1617   tmp = build_fold_addr_expr (var);
1618   tmp = build_call_expr (function, 1, tmp);
1619   gfc_add_expr_to_block (&block, tmp);
1620
1621   gfc_add_block_to_block (&block, &post_block);
1622
1623   dt_parm = var;
1624   dt_post_end_block = &post_end_block;
1625
1626   gfc_add_expr_to_block (&block, gfc_trans_code (code->block->next));
1627
1628   gfc_add_block_to_block (&block, &post_iu_block);
1629
1630   dt_parm = NULL;
1631   dt_post_end_block = NULL;
1632
1633   return gfc_finish_block (&block);
1634 }
1635
1636
1637 /* Translate the IOLENGTH form of an INQUIRE statement.  We treat
1638    this as a third sort of data transfer statement, except that
1639    lengths are summed instead of actually transferring any data.  */
1640
1641 tree
1642 gfc_trans_iolength (gfc_code * code)
1643 {
1644   last_dt = IOLENGTH;
1645   return build_dt (iocall[IOCALL_IOLENGTH], code);
1646 }
1647
1648
1649 /* Translate a READ statement.  */
1650
1651 tree
1652 gfc_trans_read (gfc_code * code)
1653 {
1654   last_dt = READ;
1655   return build_dt (iocall[IOCALL_READ], code);
1656 }
1657
1658
1659 /* Translate a WRITE statement */
1660
1661 tree
1662 gfc_trans_write (gfc_code * code)
1663 {
1664   last_dt = WRITE;
1665   return build_dt (iocall[IOCALL_WRITE], code);
1666 }
1667
1668
1669 /* Finish a data transfer statement.  */
1670
1671 tree
1672 gfc_trans_dt_end (gfc_code * code)
1673 {
1674   tree function, tmp;
1675   stmtblock_t block;
1676
1677   gfc_init_block (&block);
1678
1679   switch (last_dt)
1680     {
1681     case READ:
1682       function = iocall[IOCALL_READ_DONE];
1683       break;
1684
1685     case WRITE:
1686       function = iocall[IOCALL_WRITE_DONE];
1687       break;
1688
1689     case IOLENGTH:
1690       function = iocall[IOCALL_IOLENGTH_DONE];
1691       break;
1692
1693     default:
1694       gcc_unreachable ();
1695     }
1696
1697   tmp = build_fold_addr_expr (dt_parm);
1698   tmp = build_call_expr (function, 1, tmp);
1699   gfc_add_expr_to_block (&block, tmp);
1700   gfc_add_block_to_block (&block, dt_post_end_block);
1701   gfc_init_block (dt_post_end_block);
1702
1703   if (last_dt != IOLENGTH)
1704     {
1705       gcc_assert (code->ext.dt != NULL);
1706       io_result (&block, dt_parm, code->ext.dt->err,
1707                  code->ext.dt->end, code->ext.dt->eor);
1708     }
1709
1710   return gfc_finish_block (&block);
1711 }
1712
1713 static void
1714 transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr);
1715
1716 /* Given an array field in a derived type variable, generate the code
1717    for the loop that iterates over array elements, and the code that
1718    accesses those array elements.  Use transfer_expr to generate code
1719    for transferring that element.  Because elements may also be
1720    derived types, transfer_expr and transfer_array_component are mutually
1721    recursive.  */
1722
1723 static tree
1724 transfer_array_component (tree expr, gfc_component * cm)
1725 {
1726   tree tmp;
1727   stmtblock_t body;
1728   stmtblock_t block;
1729   gfc_loopinfo loop;
1730   int n;
1731   gfc_ss *ss;
1732   gfc_se se;
1733
1734   gfc_start_block (&block);
1735   gfc_init_se (&se, NULL);
1736
1737   /* Create and initialize Scalarization Status.  Unlike in
1738      gfc_trans_transfer, we can't simply use gfc_walk_expr to take
1739      care of this task, because we don't have a gfc_expr at hand.
1740      Build one manually, as in gfc_trans_subarray_assign.  */
1741
1742   ss = gfc_get_ss ();
1743   ss->type = GFC_SS_COMPONENT;
1744   ss->expr = NULL;
1745   ss->shape = gfc_get_shape (cm->as->rank);
1746   ss->next = gfc_ss_terminator;
1747   ss->data.info.dimen = cm->as->rank;
1748   ss->data.info.descriptor = expr;
1749   ss->data.info.data = gfc_conv_array_data (expr);
1750   ss->data.info.offset = gfc_conv_array_offset (expr);
1751   for (n = 0; n < cm->as->rank; n++)
1752     {
1753       ss->data.info.dim[n] = n;
1754       ss->data.info.start[n] = gfc_conv_array_lbound (expr, n);
1755       ss->data.info.stride[n] = gfc_index_one_node;
1756
1757       mpz_init (ss->shape[n]);
1758       mpz_sub (ss->shape[n], cm->as->upper[n]->value.integer,
1759                cm->as->lower[n]->value.integer);
1760       mpz_add_ui (ss->shape[n], ss->shape[n], 1);
1761     }
1762
1763   /* Once we got ss, we use scalarizer to create the loop.  */
1764
1765   gfc_init_loopinfo (&loop);
1766   gfc_add_ss_to_loop (&loop, ss);
1767   gfc_conv_ss_startstride (&loop);
1768   gfc_conv_loop_setup (&loop);
1769   gfc_mark_ss_chain_used (ss, 1);
1770   gfc_start_scalarized_body (&loop, &body);
1771
1772   gfc_copy_loopinfo_to_se (&se, &loop);
1773   se.ss = ss;
1774
1775   /* gfc_conv_tmp_array_ref assumes that se.expr contains the array.  */
1776   se.expr = expr;
1777   gfc_conv_tmp_array_ref (&se);
1778
1779   /* Now se.expr contains an element of the array.  Take the address and pass
1780      it to the IO routines.  */
1781   tmp = build_fold_addr_expr (se.expr);
1782   transfer_expr (&se, &cm->ts, tmp);
1783
1784   /* We are done now with the loop body.  Wrap up the scalarizer and
1785      return.  */
1786
1787   gfc_add_block_to_block (&body, &se.pre);
1788   gfc_add_block_to_block (&body, &se.post);
1789
1790   gfc_trans_scalarizing_loops (&loop, &body);
1791
1792   gfc_add_block_to_block (&block, &loop.pre);
1793   gfc_add_block_to_block (&block, &loop.post);
1794
1795   for (n = 0; n < cm->as->rank; n++)
1796     mpz_clear (ss->shape[n]);
1797   gfc_free (ss->shape);
1798
1799   gfc_cleanup_loop (&loop);
1800
1801   return gfc_finish_block (&block);
1802 }
1803
1804 /* Generate the call for a scalar transfer node.  */
1805
1806 static void
1807 transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr)
1808 {
1809   tree tmp, function, arg2, field, expr;
1810   gfc_component *c;
1811   int kind;
1812
1813   kind = ts->kind;
1814   function = NULL;
1815   arg2 = NULL;
1816
1817   switch (ts->type)
1818     {
1819     case BT_INTEGER:
1820       arg2 = build_int_cst (NULL_TREE, kind);
1821       function = iocall[IOCALL_X_INTEGER];
1822       break;
1823
1824     case BT_REAL:
1825       arg2 = build_int_cst (NULL_TREE, kind);
1826       function = iocall[IOCALL_X_REAL];
1827       break;
1828
1829     case BT_COMPLEX:
1830       arg2 = build_int_cst (NULL_TREE, kind);
1831       function = iocall[IOCALL_X_COMPLEX];
1832       break;
1833
1834     case BT_LOGICAL:
1835       arg2 = build_int_cst (NULL_TREE, kind);
1836       function = iocall[IOCALL_X_LOGICAL];
1837       break;
1838
1839     case BT_CHARACTER:
1840     case BT_HOLLERITH:
1841       if (se->string_length)
1842         arg2 = se->string_length;
1843       else
1844         {
1845           tmp = build_fold_indirect_ref (addr_expr);
1846           gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
1847           arg2 = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp)));
1848         }
1849       function = iocall[IOCALL_X_CHARACTER];
1850       break;
1851
1852     case BT_DERIVED:
1853       /* Recurse into the elements of the derived type.  */
1854       expr = gfc_evaluate_now (addr_expr, &se->pre);
1855       expr = build_fold_indirect_ref (expr);
1856
1857       for (c = ts->derived->components; c; c = c->next)
1858         {
1859           field = c->backend_decl;
1860           gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
1861
1862           tmp = build3 (COMPONENT_REF, TREE_TYPE (field), expr, field,
1863                         NULL_TREE);
1864
1865           if (c->dimension)
1866             {
1867               tmp = transfer_array_component (tmp, c);
1868               gfc_add_expr_to_block (&se->pre, tmp);
1869             }
1870           else
1871             {
1872               if (!c->pointer)
1873                 tmp = build_fold_addr_expr (tmp);
1874               transfer_expr (se, &c->ts, tmp);
1875             }
1876         }
1877       return;
1878
1879     default:
1880       internal_error ("Bad IO basetype (%d)", ts->type);
1881     }
1882
1883   tmp = build_fold_addr_expr (dt_parm);
1884   tmp = build_call_expr (function, 3, tmp, addr_expr, arg2);
1885   gfc_add_expr_to_block (&se->pre, tmp);
1886   gfc_add_block_to_block (&se->pre, &se->post);
1887
1888 }
1889
1890
1891 /* Generate a call to pass an array descriptor to the IO library. The
1892    array should be of one of the intrinsic types.  */
1893
1894 static void
1895 transfer_array_desc (gfc_se * se, gfc_typespec * ts, tree addr_expr)
1896 {
1897   tree tmp, charlen_arg, kind_arg;
1898
1899   if (ts->type == BT_CHARACTER)
1900     charlen_arg = se->string_length;
1901   else
1902     charlen_arg = build_int_cst (NULL_TREE, 0);
1903
1904   kind_arg = build_int_cst (NULL_TREE, ts->kind);
1905
1906   tmp = build_fold_addr_expr (dt_parm);
1907   tmp = build_call_expr (iocall[IOCALL_X_ARRAY], 4,
1908                          tmp, addr_expr, kind_arg, charlen_arg);
1909   gfc_add_expr_to_block (&se->pre, tmp);
1910   gfc_add_block_to_block (&se->pre, &se->post);
1911 }
1912
1913
1914 /* gfc_trans_transfer()-- Translate a TRANSFER code node */
1915
1916 tree
1917 gfc_trans_transfer (gfc_code * code)
1918 {
1919   stmtblock_t block, body;
1920   gfc_loopinfo loop;
1921   gfc_expr *expr;
1922   gfc_ref *ref;
1923   gfc_ss *ss;
1924   gfc_se se;
1925   tree tmp;
1926
1927   gfc_start_block (&block);
1928   gfc_init_block (&body);
1929
1930   expr = code->expr;
1931   ss = gfc_walk_expr (expr);
1932
1933   ref = NULL;
1934   gfc_init_se (&se, NULL);
1935
1936   if (ss == gfc_ss_terminator)
1937     {
1938       /* Transfer a scalar value.  */
1939       gfc_conv_expr_reference (&se, expr);
1940       transfer_expr (&se, &expr->ts, se.expr);
1941     }
1942   else
1943     {
1944       /* Transfer an array. If it is an array of an intrinsic
1945          type, pass the descriptor to the library.  Otherwise
1946          scalarize the transfer.  */
1947       if (expr->ref)
1948         {
1949           for (ref = expr->ref; ref && ref->type != REF_ARRAY;
1950                  ref = ref->next);
1951           gcc_assert (ref->type == REF_ARRAY);
1952         }
1953
1954       if (expr->ts.type != BT_DERIVED && ref && ref->next == NULL)
1955         {
1956           /* Get the descriptor.  */
1957           gfc_conv_expr_descriptor (&se, expr, ss);
1958           tmp = build_fold_addr_expr (se.expr);
1959           transfer_array_desc (&se, &expr->ts, tmp);
1960           goto finish_block_label;
1961         }
1962
1963       /* Initialize the scalarizer.  */
1964       gfc_init_loopinfo (&loop);
1965       gfc_add_ss_to_loop (&loop, ss);
1966
1967       /* Initialize the loop.  */
1968       gfc_conv_ss_startstride (&loop);
1969       gfc_conv_loop_setup (&loop);
1970
1971       /* The main loop body.  */
1972       gfc_mark_ss_chain_used (ss, 1);
1973       gfc_start_scalarized_body (&loop, &body);
1974
1975       gfc_copy_loopinfo_to_se (&se, &loop);
1976       se.ss = ss;
1977
1978       gfc_conv_expr_reference (&se, expr);
1979       transfer_expr (&se, &expr->ts, se.expr);
1980     }
1981
1982  finish_block_label:
1983
1984   gfc_add_block_to_block (&body, &se.pre);
1985   gfc_add_block_to_block (&body, &se.post);
1986
1987   if (se.ss == NULL)
1988     tmp = gfc_finish_block (&body);
1989   else
1990     {
1991       gcc_assert (se.ss == gfc_ss_terminator);
1992       gfc_trans_scalarizing_loops (&loop, &body);
1993
1994       gfc_add_block_to_block (&loop.pre, &loop.post);
1995       tmp = gfc_finish_block (&loop.pre);
1996       gfc_cleanup_loop (&loop);
1997     }
1998
1999   gfc_add_expr_to_block (&block, tmp);
2000
2001   return gfc_finish_block (&block);
2002 }
2003
2004 #include "gt-fortran-trans-io.h"
2005