gcc/fortran/trans-io.c

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