gcc/fortran/trans-io.c

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