gcc/fortran/trans-io.c

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