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   line = LOCATION_LINE (where->lb->location);
 855   set_parameter_const (block, var, IOPARM_common_line, line);
 856 }
 857
 858
 859 /* Translate an OPEN statement.  */
 860
 861 tree
 862 gfc_trans_open (gfc_code * code)
 863 {
 864   stmtblock_t block, post_block;
 865   gfc_open *p;
 866   tree tmp, var;
 867   unsigned int mask = 0;
 868
 869   gfc_start_block (&block);
 870   gfc_init_block (&post_block);
 871
 872   var = gfc_create_var (st_parameter[IOPARM_ptype_open].type, "open_parm");
 873
 874   set_error_locus (&block, var, &code->loc);
 875   p = code->ext.open;
 876
 877   if (p->iomsg)
 878     mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
 879                         p->iomsg);
 880
 881   if (p->iostat)
 882     mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
 883                                p->iostat);
 884
 885   if (p->err)
 886     mask |= IOPARM_common_err;
 887
 888   if (p->file)
 889     mask |= set_string (&block, &post_block, var, IOPARM_open_file, p->file);
 890
 891   if (p->status)
 892     mask |= set_string (&block, &post_block, var, IOPARM_open_status,
 893                         p->status);
 894
 895   if (p->access)
 896     mask |= set_string (&block, &post_block, var, IOPARM_open_access,
 897                         p->access);
 898
 899   if (p->form)
 900     mask |= set_string (&block, &post_block, var, IOPARM_open_form, p->form);
 901
 902   if (p->recl)
 903     mask |= set_parameter_value (&block, var, IOPARM_open_recl_in, p->recl);
 904
 905   if (p->blank)
 906     mask |= set_string (&block, &post_block, var, IOPARM_open_blank,
 907                         p->blank);
 908
 909   if (p->position)
 910     mask |= set_string (&block, &post_block, var, IOPARM_open_position,
 911                         p->position);
 912
 913   if (p->action)
 914     mask |= set_string (&block, &post_block, var, IOPARM_open_action,
 915                         p->action);
 916
 917   if (p->delim)
 918     mask |= set_string (&block, &post_block, var, IOPARM_open_delim,
 919                         p->delim);
 920
 921   if (p->pad)
 922     mask |= set_string (&block, &post_block, var, IOPARM_open_pad, p->pad);
 923
 924   if (p->convert)
 925     mask |= set_string (&block, &post_block, var, IOPARM_open_convert,
 926                         p->convert);
 927
 928   set_parameter_const (&block, var, IOPARM_common_flags, mask);
 929
 930   if (p->unit)
 931     set_parameter_value (&block, var, IOPARM_common_unit, p->unit);
 932   else
 933     set_parameter_const (&block, var, IOPARM_common_unit, 0);
 934
 935   tmp = build_fold_addr_expr (var);
 936   tmp = build_call_expr (iocall[IOCALL_OPEN], 1, tmp);
 937   gfc_add_expr_to_block (&block, tmp);
 938
 939   gfc_add_block_to_block (&block, &post_block);
 940
 941   io_result (&block, var, p->err, NULL, NULL);
 942
 943   return gfc_finish_block (&block);
 944 }
 945
 946
 947 /* Translate a CLOSE statement.  */
 948
 949 tree
 950 gfc_trans_close (gfc_code * code)
 951 {
 952   stmtblock_t block, post_block;
 953   gfc_close *p;
 954   tree tmp, var;
 955   unsigned int mask = 0;
 956
 957   gfc_start_block (&block);
 958   gfc_init_block (&post_block);
 959
 960   var = gfc_create_var (st_parameter[IOPARM_ptype_close].type, "close_parm");
 961
 962   set_error_locus (&block, var, &code->loc);
 963   p = code->ext.close;
 964
 965   if (p->iomsg)
 966     mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
 967                         p->iomsg);
 968
 969   if (p->iostat)
 970     mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
 971                                p->iostat);
 972
 973   if (p->err)
 974     mask |= IOPARM_common_err;
 975
 976   if (p->status)
 977     mask |= set_string (&block, &post_block, var, IOPARM_close_status,
 978                         p->status);
 979
 980   set_parameter_const (&block, var, IOPARM_common_flags, mask);
 981
 982   if (p->unit)
 983     set_parameter_value (&block, var, IOPARM_common_unit, p->unit);
 984   else
 985     set_parameter_const (&block, var, IOPARM_common_unit, 0);
 986
 987   tmp = build_fold_addr_expr (var);
 988   tmp = build_call_expr (iocall[IOCALL_CLOSE], 1, tmp);
 989   gfc_add_expr_to_block (&block, tmp);
 990
 991   gfc_add_block_to_block (&block, &post_block);
 992
 993   io_result (&block, var, p->err, NULL, NULL);
 994
 995   return gfc_finish_block (&block);
 996 }
 997
 998
 999 /* Common subroutine for building a file positioning statement.  */
1000
1001 static tree
1002 build_filepos (tree function, gfc_code * code)
1003 {
1004   stmtblock_t block, post_block;
1005   gfc_filepos *p;
1006   tree tmp, var;
1007   unsigned int mask = 0;
1008
1009   p = code->ext.filepos;
1010
1011   gfc_start_block (&block);
1012   gfc_init_block (&post_block);
1013
1014   var = gfc_create_var (st_parameter[IOPARM_ptype_filepos].type,
1015                         "filepos_parm");
1016
1017   set_error_locus (&block, var, &code->loc);
1018
1019   if (p->iomsg)
1020     mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
1021                         p->iomsg);
1022
1023   if (p->iostat)
1024     mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
1025                                p->iostat);
1026
1027   if (p->err)
1028     mask |= IOPARM_common_err;
1029
1030   set_parameter_const (&block, var, IOPARM_common_flags, mask);
1031
1032   if (p->unit)
1033     set_parameter_value (&block, var, IOPARM_common_unit, p->unit);
1034   else
1035     set_parameter_const (&block, var, IOPARM_common_unit, 0);
1036
1037   tmp = build_fold_addr_expr (var);
1038   tmp = build_call_expr (function, 1, tmp);
1039   gfc_add_expr_to_block (&block, tmp);
1040
1041   gfc_add_block_to_block (&block, &post_block);
1042
1043   io_result (&block, var, p->err, NULL, NULL);
1044
1045   return gfc_finish_block (&block);
1046 }
1047
1048
1049 /* Translate a BACKSPACE statement.  */
1050
1051 tree
1052 gfc_trans_backspace (gfc_code * code)
1053 {
1054   return build_filepos (iocall[IOCALL_BACKSPACE], code);
1055 }
1056
1057
1058 /* Translate an ENDFILE statement.  */
1059
1060 tree
1061 gfc_trans_endfile (gfc_code * code)
1062 {
1063   return build_filepos (iocall[IOCALL_ENDFILE], code);
1064 }
1065
1066
1067 /* Translate a REWIND statement.  */
1068
1069 tree
1070 gfc_trans_rewind (gfc_code * code)
1071 {
1072   return build_filepos (iocall[IOCALL_REWIND], code);
1073 }
1074
1075
1076 /* Translate a FLUSH statement.  */
1077
1078 tree
1079 gfc_trans_flush (gfc_code * code)
1080 {
1081   return build_filepos (iocall[IOCALL_FLUSH], code);
1082 }
1083
1084
1085 /* Create a dummy iostat variable to catch any error due to bad unit.  */
1086
1087 static gfc_expr *
1088 create_dummy_iostat (void)
1089 {
1090   gfc_symtree *st;
1091   gfc_expr *e;
1092
1093   gfc_get_ha_sym_tree ("@iostat", &st);
1094   st->n.sym->ts.type = BT_INTEGER;
1095   st->n.sym->ts.kind = gfc_default_integer_kind;
1096   gfc_set_sym_referenced (st->n.sym);
1097   gfc_commit_symbol (st->n.sym);
1098   st->n.sym->backend_decl
1099         = gfc_create_var (gfc_get_int_type (st->n.sym->ts.kind),
1100                           st->n.sym->name);
1101
1102   e = gfc_get_expr ();
1103   e->expr_type = EXPR_VARIABLE;
1104   e->symtree = st;
1105   e->ts.type = BT_INTEGER;
1106   e->ts.kind = st->n.sym->ts.kind;
1107
1108   return e;
1109 }
1110
1111
1112 /* Translate the non-IOLENGTH form of an INQUIRE statement.  */
1113
1114 tree
1115 gfc_trans_inquire (gfc_code * code)
1116 {
1117   stmtblock_t block, post_block;
1118   gfc_inquire *p;
1119   tree tmp, var;
1120   unsigned int mask = 0;
1121
1122   gfc_start_block (&block);
1123   gfc_init_block (&post_block);
1124
1125   var = gfc_create_var (st_parameter[IOPARM_ptype_inquire].type,
1126                         "inquire_parm");
1127
1128   set_error_locus (&block, var, &code->loc);
1129   p = code->ext.inquire;
1130
1131   if (p->iomsg)
1132     mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
1133                         p->iomsg);
1134
1135   if (p->iostat)
1136     mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
1137                                p->iostat);
1138
1139   if (p->err)
1140     mask |= IOPARM_common_err;
1141
1142   /* Sanity check.  */
1143   if (p->unit && p->file)
1144     gfc_error ("INQUIRE statement at %L cannot contain both FILE and UNIT specifiers", &code->loc);
1145
1146   if (p->file)
1147     mask |= set_string (&block, &post_block, var, IOPARM_inquire_file,
1148                         p->file);
1149
1150   if (p->exist)
1151     {
1152       mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_exist,
1153                                  p->exist);
1154
1155       if (p->unit && !p->iostat)
1156         {
1157           p->iostat = create_dummy_iostat ();
1158           mask |= set_parameter_ref (&block, &post_block, var,
1159                                      IOPARM_common_iostat, p->iostat);
1160         }
1161     }
1162
1163   if (p->opened)
1164     mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_opened,
1165                                p->opened);
1166
1167   if (p->number)
1168     mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_number,
1169                                p->number);
1170
1171   if (p->named)
1172     mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_named,
1173                                p->named);
1174
1175   if (p->name)
1176     mask |= set_string (&block, &post_block, var, IOPARM_inquire_name,
1177                         p->name);
1178
1179   if (p->access)
1180     mask |= set_string (&block, &post_block, var, IOPARM_inquire_access,
1181                         p->access);
1182
1183   if (p->sequential)
1184     mask |= set_string (&block, &post_block, var, IOPARM_inquire_sequential,
1185                         p->sequential);
1186
1187   if (p->direct)
1188     mask |= set_string (&block, &post_block, var, IOPARM_inquire_direct,
1189                         p->direct);
1190
1191   if (p->form)
1192     mask |= set_string (&block, &post_block, var, IOPARM_inquire_form,
1193                         p->form);
1194
1195   if (p->formatted)
1196     mask |= set_string (&block, &post_block, var, IOPARM_inquire_formatted,
1197                         p->formatted);
1198
1199   if (p->unformatted)
1200     mask |= set_string (&block, &post_block, var, IOPARM_inquire_unformatted,
1201                         p->unformatted);
1202
1203   if (p->recl)
1204     mask |= set_parameter_ref (&block, &post_block, var,
1205                                IOPARM_inquire_recl_out, p->recl);
1206
1207   if (p->nextrec)
1208     mask |= set_parameter_ref (&block, &post_block, var,
1209                                IOPARM_inquire_nextrec, p->nextrec);
1210
1211   if (p->blank)
1212     mask |= set_string (&block, &post_block, var, IOPARM_inquire_blank,
1213                         p->blank);
1214
1215   if (p->position)
1216     mask |= set_string (&block, &post_block, var, IOPARM_inquire_position,
1217                         p->position);
1218
1219   if (p->action)
1220     mask |= set_string (&block, &post_block, var, IOPARM_inquire_action,
1221                         p->action);
1222
1223   if (p->read)
1224     mask |= set_string (&block, &post_block, var, IOPARM_inquire_read,
1225                         p->read);
1226
1227   if (p->write)
1228     mask |= set_string (&block, &post_block, var, IOPARM_inquire_write,
1229                         p->write);
1230
1231   if (p->readwrite)
1232     mask |= set_string (&block, &post_block, var, IOPARM_inquire_readwrite,
1233                         p->readwrite);
1234
1235   if (p->delim)
1236     mask |= set_string (&block, &post_block, var, IOPARM_inquire_delim,
1237                         p->delim);
1238
1239   if (p->pad)
1240     mask |= set_string (&block, &post_block, var, IOPARM_inquire_pad,
1241                         p->pad);
1242
1243   if (p->convert)
1244     mask |= set_string (&block, &post_block, var, IOPARM_inquire_convert,
1245                         p->convert);
1246
1247   if (p->strm_pos)
1248     mask |= set_parameter_ref (&block, &post_block, var,
1249                                IOPARM_inquire_strm_pos_out, p->strm_pos);
1250
1251   set_parameter_const (&block, var, IOPARM_common_flags, mask);
1252
1253   if (p->unit)
1254     set_parameter_value (&block, var, IOPARM_common_unit, p->unit);
1255   else
1256     set_parameter_const (&block, var, IOPARM_common_unit, 0);
1257
1258   tmp = build_fold_addr_expr (var);
1259   tmp = build_call_expr (iocall[IOCALL_INQUIRE], 1, tmp);
1260   gfc_add_expr_to_block (&block, tmp);
1261
1262   gfc_add_block_to_block (&block, &post_block);
1263
1264   io_result (&block, var, p->err, NULL, NULL);
1265
1266   return gfc_finish_block (&block);
1267 }
1268
1269 static gfc_expr *
1270 gfc_new_nml_name_expr (const char * name)
1271 {
1272    gfc_expr * nml_name;
1273
1274    nml_name = gfc_get_expr();
1275    nml_name->ref = NULL;
1276    nml_name->expr_type = EXPR_CONSTANT;
1277    nml_name->ts.kind = gfc_default_character_kind;
1278    nml_name->ts.type = BT_CHARACTER;
1279    nml_name->value.character.length = strlen(name);
1280    nml_name->value.character.string = gfc_getmem (strlen (name) + 1);
1281    strcpy (nml_name->value.character.string, name);
1282
1283    return nml_name;
1284 }
1285
1286 /* nml_full_name builds up the fully qualified name of a
1287    derived type component.  */
1288
1289 static char*
1290 nml_full_name (const char* var_name, const char* cmp_name)
1291 {
1292   int full_name_length;
1293   char * full_name;
1294
1295   full_name_length = strlen (var_name) + strlen (cmp_name) + 1;
1296   full_name = (char*)gfc_getmem (full_name_length + 1);
1297   strcpy (full_name, var_name);
1298   full_name = strcat (full_name, "%");
1299   full_name = strcat (full_name, cmp_name);
1300   return full_name;
1301 }
1302
1303 /* nml_get_addr_expr builds an address expression from the
1304    gfc_symbol or gfc_component backend_decl's. An offset is
1305    provided so that the address of an element of an array of
1306    derived types is returned. This is used in the runtime to
1307    determine that span of the derived type.  */
1308
1309 static tree
1310 nml_get_addr_expr (gfc_symbol * sym, gfc_component * c,
1311                    tree base_addr)
1312 {
1313   tree decl = NULL_TREE;
1314   tree tmp;
1315   tree itmp;
1316   int array_flagged;
1317   int dummy_arg_flagged;
1318
1319   if (sym)
1320     {
1321       sym->attr.referenced = 1;
1322       decl = gfc_get_symbol_decl (sym);
1323
1324       /* If this is the enclosing function declaration, use
1325          the fake result instead.  */
1326       if (decl == current_function_decl)
1327         decl = gfc_get_fake_result_decl (sym, 0);
1328       else if (decl == DECL_CONTEXT (current_function_decl))
1329         decl =  gfc_get_fake_result_decl (sym, 1);
1330     }
1331   else
1332     decl = c->backend_decl;
1333
1334   gcc_assert (decl && ((TREE_CODE (decl) == FIELD_DECL
1335                      || TREE_CODE (decl) == VAR_DECL
1336                      || TREE_CODE (decl) == PARM_DECL)
1337                      || TREE_CODE (decl) == COMPONENT_REF));
1338
1339   tmp = decl;
1340
1341   /* Build indirect reference, if dummy argument.  */
1342
1343   dummy_arg_flagged = POINTER_TYPE_P (TREE_TYPE(tmp));
1344
1345   itmp = (dummy_arg_flagged) ? build_fold_indirect_ref (tmp) : tmp;
1346
1347   /* If an array, set flag and use indirect ref. if built.  */
1348
1349   array_flagged = (TREE_CODE (TREE_TYPE (itmp)) == ARRAY_TYPE
1350                    && !TYPE_STRING_FLAG (TREE_TYPE (itmp)));
1351
1352   if (array_flagged)
1353     tmp = itmp;
1354
1355   /* Treat the component of a derived type, using base_addr for
1356      the derived type.  */
1357
1358   if (TREE_CODE (decl) == FIELD_DECL)
1359     tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp),
1360                        base_addr, tmp, NULL_TREE);
1361
1362   /* If we have a derived type component, a reference to the first
1363      element of the array is built.  This is done so that base_addr,
1364      used in the build of the component reference, always points to
1365      a RECORD_TYPE.  */
1366
1367   if (array_flagged)
1368     tmp = gfc_build_array_ref (tmp, gfc_index_zero_node, NULL);
1369
1370   /* Now build the address expression.  */
1371
1372   tmp = build_fold_addr_expr (tmp);
1373
1374   /* If scalar dummy, resolve indirect reference now.  */
1375
1376   if (dummy_arg_flagged && !array_flagged)
1377     tmp = build_fold_indirect_ref (tmp);
1378
1379   gcc_assert (tmp && POINTER_TYPE_P (TREE_TYPE (tmp)));
1380
1381   return tmp;
1382 }
1383
1384 /* For an object VAR_NAME whose base address is BASE_ADDR, generate a
1385    call to iocall[IOCALL_SET_NML_VAL].  For derived type variable, recursively
1386    generate calls to iocall[IOCALL_SET_NML_VAL] for each component.  */
1387
1388 #define IARG(i) build_int_cst (gfc_array_index_type, i)
1389
1390 static void
1391 transfer_namelist_element (stmtblock_t * block, const char * var_name,
1392                            gfc_symbol * sym, gfc_component * c,
1393                            tree base_addr)
1394 {
1395   gfc_typespec * ts = NULL;
1396   gfc_array_spec * as = NULL;
1397   tree addr_expr = NULL;
1398   tree dt = NULL;
1399   tree string;
1400   tree tmp;
1401   tree dtype;
1402   tree dt_parm_addr;
1403   int n_dim;
1404   int itype;
1405   int rank = 0;
1406
1407   gcc_assert (sym || c);
1408
1409   /* Build the namelist object name.  */
1410
1411   string = gfc_build_cstring_const (var_name);
1412   string = gfc_build_addr_expr (pchar_type_node, string);
1413
1414   /* Build ts, as and data address using symbol or component.  */
1415
1416   ts = (sym) ? &sym->ts : &c->ts;
1417   as = (sym) ? sym->as : c->as;
1418
1419   addr_expr = nml_get_addr_expr (sym, c, base_addr);
1420
1421   if (as)
1422     rank = as->rank;
1423
1424   if (rank)
1425     {
1426       dt =  TREE_TYPE ((sym) ? sym->backend_decl : c->backend_decl);
1427       dtype = gfc_get_dtype (dt);
1428     }
1429   else
1430     {
1431       itype = GFC_DTYPE_UNKNOWN;
1432
1433       switch (ts->type)
1434
1435         {
1436         case BT_INTEGER:
1437           itype = GFC_DTYPE_INTEGER;
1438           break;
1439         case BT_LOGICAL:
1440           itype = GFC_DTYPE_LOGICAL;
1441           break;
1442         case BT_REAL:
1443           itype = GFC_DTYPE_REAL;
1444           break;
1445         case BT_COMPLEX:
1446           itype = GFC_DTYPE_COMPLEX;
1447         break;
1448         case BT_DERIVED:
1449           itype = GFC_DTYPE_DERIVED;
1450           break;
1451         case BT_CHARACTER:
1452           itype = GFC_DTYPE_CHARACTER;
1453           break;
1454         default:
1455           gcc_unreachable ();
1456         }
1457
1458       dtype = IARG (itype << GFC_DTYPE_TYPE_SHIFT);
1459     }
1460
1461   /* Build up the arguments for the transfer call.
1462      The call for the scalar part transfers:
1463      (address, name, type, kind or string_length, dtype)  */
1464
1465   dt_parm_addr = build_fold_addr_expr (dt_parm);
1466
1467   if (ts->type == BT_CHARACTER)
1468     tmp = ts->cl->backend_decl;
1469   else
1470     tmp = build_int_cst (gfc_charlen_type_node, 0);
1471   tmp = build_call_expr (iocall[IOCALL_SET_NML_VAL], 6,
1472                          dt_parm_addr, addr_expr, string,
1473                          IARG (ts->kind), tmp, dtype);
1474   gfc_add_expr_to_block (block, tmp);
1475
1476   /* If the object is an array, transfer rank times:
1477      (null pointer, name, stride, lbound, ubound)  */
1478
1479   for ( n_dim = 0 ; n_dim < rank ; n_dim++ )
1480     {
1481       tmp = build_call_expr (iocall[IOCALL_SET_NML_VAL_DIM], 5,
1482                              dt_parm_addr,
1483                              IARG (n_dim),
1484                              GFC_TYPE_ARRAY_STRIDE (dt, n_dim),
1485                              GFC_TYPE_ARRAY_LBOUND (dt, n_dim),
1486                              GFC_TYPE_ARRAY_UBOUND (dt, n_dim));
1487       gfc_add_expr_to_block (block, tmp);
1488     }
1489
1490   if (ts->type == BT_DERIVED)
1491     {
1492       gfc_component *cmp;
1493
1494       /* Provide the RECORD_TYPE to build component references.  */
1495
1496       tree expr = build_fold_indirect_ref (addr_expr);
1497
1498       for (cmp = ts->derived->components; cmp; cmp = cmp->next)
1499         {
1500           char *full_name = nml_full_name (var_name, cmp->name);
1501           transfer_namelist_element (block,
1502                                      full_name,
1503                                      NULL, cmp, expr);
1504           gfc_free (full_name);
1505         }
1506     }
1507 }
1508
1509 #undef IARG
1510
1511 /* Create a data transfer statement.  Not all of the fields are valid
1512    for both reading and writing, but improper use has been filtered
1513    out by now.  */
1514
1515 static tree
1516 build_dt (tree function, gfc_code * code)
1517 {
1518   stmtblock_t block, post_block, post_end_block, post_iu_block;
1519   gfc_dt *dt;
1520   tree tmp, var;
1521   gfc_expr *nmlname;
1522   gfc_namelist *nml;
1523   unsigned int mask = 0;
1524
1525   gfc_start_block (&block);
1526   gfc_init_block (&post_block);
1527   gfc_init_block (&post_end_block);
1528   gfc_init_block (&post_iu_block);
1529
1530   var = gfc_create_var (st_parameter[IOPARM_ptype_dt].type, "dt_parm");
1531
1532   set_error_locus (&block, var, &code->loc);
1533
1534   if (last_dt == IOLENGTH)
1535     {
1536       gfc_inquire *inq;
1537
1538       inq = code->ext.inquire;
1539
1540       /* First check that preconditions are met.  */
1541       gcc_assert (inq != NULL);
1542       gcc_assert (inq->iolength != NULL);
1543
1544       /* Connect to the iolength variable.  */
1545       mask |= set_parameter_ref (&block, &post_end_block, var,
1546                                  IOPARM_dt_iolength, inq->iolength);
1547       dt = NULL;
1548     }
1549   else
1550     {
1551       dt = code->ext.dt;
1552       gcc_assert (dt != NULL);
1553     }
1554
1555   if (dt && dt->io_unit)
1556     {
1557       if (dt->io_unit->ts.type == BT_CHARACTER)
1558         {
1559           mask |= set_internal_unit (&block, &post_iu_block,
1560                                      var, dt->io_unit);
1561           set_parameter_const (&block, var, IOPARM_common_unit, 0);
1562         }
1563     }
1564   else
1565     set_parameter_const (&block, var, IOPARM_common_unit, 0);
1566
1567   if (dt)
1568     {
1569       if (dt->iomsg)
1570         mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
1571                             dt->iomsg);
1572
1573       if (dt->iostat)
1574         mask |= set_parameter_ref (&block, &post_end_block, var,
1575                                    IOPARM_common_iostat, dt->iostat);
1576
1577       if (dt->err)
1578         mask |= IOPARM_common_err;
1579
1580       if (dt->eor)
1581         mask |= IOPARM_common_eor;
1582
1583       if (dt->end)
1584         mask |= IOPARM_common_end;
1585
1586       if (dt->rec)
1587         mask |= set_parameter_value (&block, var, IOPARM_dt_rec, dt->rec);
1588
1589       if (dt->advance)
1590         mask |= set_string (&block, &post_block, var, IOPARM_dt_advance,
1591                             dt->advance);
1592
1593       if (dt->format_expr)
1594         mask |= set_string (&block, &post_end_block, var, IOPARM_dt_format,
1595                             dt->format_expr);
1596
1597       if (dt->format_label)
1598         {
1599           if (dt->format_label == &format_asterisk)
1600             mask |= IOPARM_dt_list_format;
1601           else
1602             mask |= set_string (&block, &post_block, var, IOPARM_dt_format,
1603                                 dt->format_label->format);
1604         }
1605
1606       if (dt->size)
1607         mask |= set_parameter_ref (&block, &post_end_block, var,
1608                                    IOPARM_dt_size, dt->size);
1609
1610       if (dt->namelist)
1611         {
1612           if (dt->format_expr || dt->format_label)
1613             gfc_internal_error ("build_dt: format with namelist");
1614
1615           nmlname = gfc_new_nml_name_expr (dt->namelist->name);
1616
1617           mask |= set_string (&block, &post_block, var, IOPARM_dt_namelist_name,
1618                               nmlname);
1619
1620           if (last_dt == READ)
1621             mask |= IOPARM_dt_namelist_read_mode;
1622
1623           set_parameter_const (&block, var, IOPARM_common_flags, mask);
1624
1625           dt_parm = var;
1626
1627           for (nml = dt->namelist->namelist; nml; nml = nml->next)
1628             transfer_namelist_element (&block, nml->sym->name, nml->sym,
1629                                        NULL, NULL);
1630         }
1631       else
1632         set_parameter_const (&block, var, IOPARM_common_flags, mask);
1633
1634       if (dt->io_unit && dt->io_unit->ts.type == BT_INTEGER)
1635         set_parameter_value (&block, var, IOPARM_common_unit, dt->io_unit);
1636     }
1637   else
1638     set_parameter_const (&block, var, IOPARM_common_flags, mask);
1639
1640   tmp = build_fold_addr_expr (var);
1641   tmp = build_call_expr (function, 1, tmp);
1642   gfc_add_expr_to_block (&block, tmp);
1643
1644   gfc_add_block_to_block (&block, &post_block);
1645
1646   dt_parm = var;
1647   dt_post_end_block = &post_end_block;
1648
1649   gfc_add_expr_to_block (&block, gfc_trans_code (code->block->next));
1650
1651   gfc_add_block_to_block (&block, &post_iu_block);
1652
1653   dt_parm = NULL;
1654   dt_post_end_block = NULL;
1655
1656   return gfc_finish_block (&block);
1657 }
1658
1659
1660 /* Translate the IOLENGTH form of an INQUIRE statement.  We treat
1661    this as a third sort of data transfer statement, except that
1662    lengths are summed instead of actually transferring any data.  */
1663
1664 tree
1665 gfc_trans_iolength (gfc_code * code)
1666 {
1667   last_dt = IOLENGTH;
1668   return build_dt (iocall[IOCALL_IOLENGTH], code);
1669 }
1670
1671
1672 /* Translate a READ statement.  */
1673
1674 tree
1675 gfc_trans_read (gfc_code * code)
1676 {
1677   last_dt = READ;
1678   return build_dt (iocall[IOCALL_READ], code);
1679 }
1680
1681
1682 /* Translate a WRITE statement */
1683
1684 tree
1685 gfc_trans_write (gfc_code * code)
1686 {
1687   last_dt = WRITE;
1688   return build_dt (iocall[IOCALL_WRITE], code);
1689 }
1690
1691
1692 /* Finish a data transfer statement.  */
1693
1694 tree
1695 gfc_trans_dt_end (gfc_code * code)
1696 {
1697   tree function, tmp;
1698   stmtblock_t block;
1699
1700   gfc_init_block (&block);
1701
1702   switch (last_dt)
1703     {
1704     case READ:
1705       function = iocall[IOCALL_READ_DONE];
1706       break;
1707
1708     case WRITE:
1709       function = iocall[IOCALL_WRITE_DONE];
1710       break;
1711
1712     case IOLENGTH:
1713       function = iocall[IOCALL_IOLENGTH_DONE];
1714       break;
1715
1716     default:
1717       gcc_unreachable ();
1718     }
1719
1720   tmp = build_fold_addr_expr (dt_parm);
1721   tmp = build_call_expr (function, 1, tmp);
1722   gfc_add_expr_to_block (&block, tmp);
1723   gfc_add_block_to_block (&block, dt_post_end_block);
1724   gfc_init_block (dt_post_end_block);
1725
1726   if (last_dt != IOLENGTH)
1727     {
1728       gcc_assert (code->ext.dt != NULL);
1729       io_result (&block, dt_parm, code->ext.dt->err,
1730                  code->ext.dt->end, code->ext.dt->eor);
1731     }
1732
1733   return gfc_finish_block (&block);
1734 }
1735
1736 static void
1737 transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr, gfc_code * code);
1738
1739 /* Given an array field in a derived type variable, generate the code
1740    for the loop that iterates over array elements, and the code that
1741    accesses those array elements.  Use transfer_expr to generate code
1742    for transferring that element.  Because elements may also be
1743    derived types, transfer_expr and transfer_array_component are mutually
1744    recursive.  */
1745
1746 static tree
1747 transfer_array_component (tree expr, gfc_component * cm)
1748 {
1749   tree tmp;
1750   stmtblock_t body;
1751   stmtblock_t block;
1752   gfc_loopinfo loop;
1753   int n;
1754   gfc_ss *ss;
1755   gfc_se se;
1756
1757   gfc_start_block (&block);
1758   gfc_init_se (&se, NULL);
1759
1760   /* Create and initialize Scalarization Status.  Unlike in
1761      gfc_trans_transfer, we can't simply use gfc_walk_expr to take
1762      care of this task, because we don't have a gfc_expr at hand.
1763      Build one manually, as in gfc_trans_subarray_assign.  */
1764
1765   ss = gfc_get_ss ();
1766   ss->type = GFC_SS_COMPONENT;
1767   ss->expr = NULL;
1768   ss->shape = gfc_get_shape (cm->as->rank);
1769   ss->next = gfc_ss_terminator;
1770   ss->data.info.dimen = cm->as->rank;
1771   ss->data.info.descriptor = expr;
1772   ss->data.info.data = gfc_conv_array_data (expr);
1773   ss->data.info.offset = gfc_conv_array_offset (expr);
1774   for (n = 0; n < cm->as->rank; n++)
1775     {
1776       ss->data.info.dim[n] = n;
1777       ss->data.info.start[n] = gfc_conv_array_lbound (expr, n);
1778       ss->data.info.stride[n] = gfc_index_one_node;
1779
1780       mpz_init (ss->shape[n]);
1781       mpz_sub (ss->shape[n], cm->as->upper[n]->value.integer,
1782                cm->as->lower[n]->value.integer);
1783       mpz_add_ui (ss->shape[n], ss->shape[n], 1);
1784     }
1785
1786   /* Once we got ss, we use scalarizer to create the loop.  */
1787
1788   gfc_init_loopinfo (&loop);
1789   gfc_add_ss_to_loop (&loop, ss);
1790   gfc_conv_ss_startstride (&loop);
1791   gfc_conv_loop_setup (&loop);
1792   gfc_mark_ss_chain_used (ss, 1);
1793   gfc_start_scalarized_body (&loop, &body);
1794
1795   gfc_copy_loopinfo_to_se (&se, &loop);
1796   se.ss = ss;
1797
1798   /* gfc_conv_tmp_array_ref assumes that se.expr contains the array.  */
1799   se.expr = expr;
1800   gfc_conv_tmp_array_ref (&se);
1801
1802   /* Now se.expr contains an element of the array.  Take the address and pass
1803      it to the IO routines.  */
1804   tmp = build_fold_addr_expr (se.expr);
1805   transfer_expr (&se, &cm->ts, tmp, NULL);
1806
1807   /* We are done now with the loop body.  Wrap up the scalarizer and
1808      return.  */
1809
1810   gfc_add_block_to_block (&body, &se.pre);
1811   gfc_add_block_to_block (&body, &se.post);
1812
1813   gfc_trans_scalarizing_loops (&loop, &body);
1814
1815   gfc_add_block_to_block (&block, &loop.pre);
1816   gfc_add_block_to_block (&block, &loop.post);
1817
1818   for (n = 0; n < cm->as->rank; n++)
1819     mpz_clear (ss->shape[n]);
1820   gfc_free (ss->shape);
1821
1822   gfc_cleanup_loop (&loop);
1823
1824   return gfc_finish_block (&block);
1825 }
1826
1827 /* Generate the call for a scalar transfer node.  */
1828
1829 static void
1830 transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr, gfc_code * code)
1831 {
1832   tree tmp, function, arg2, field, expr;
1833   gfc_component *c;
1834   int kind;
1835
1836   /* It is possible to get a C_NULL_PTR or C_NULL_FUNPTR expression here if
1837      the user says something like: print *, 'c_null_ptr: ', c_null_ptr
1838      We need to translate the expression to a constant if it's either
1839      C_NULL_PTR or C_NULL_FUNPTR.  We could also get a user variable of
1840      type C_PTR or C_FUNPTR, in which case the ts->type may no longer be
1841      BT_DERIVED (could have been changed by gfc_conv_expr).  */
1842   if ((ts->type == BT_DERIVED && ts->is_iso_c == 1 && ts->derived != NULL)
1843       || (ts->derived != NULL && ts->derived->ts.is_iso_c == 1))
1844     {
1845       /* C_PTR and C_FUNPTR have private components which means they can not
1846          be printed.  However, if -std=gnu and not -pedantic, allow
1847          the component to be printed to help debugging.  */
1848       if (gfc_notification_std (GFC_STD_GNU) != SILENT)
1849         {
1850           gfc_error_now ("Derived type '%s' at %L has PRIVATE components",
1851                          ts->derived->name, code != NULL ? &(code->loc) :
1852                          &gfc_current_locus);
1853           return;
1854         }
1855
1856       ts->type = ts->derived->ts.type;
1857       ts->kind = ts->derived->ts.kind;
1858       ts->f90_type = ts->derived->ts.f90_type;
1859     }
1860
1861   kind = ts->kind;
1862   function = NULL;
1863   arg2 = NULL;
1864
1865   switch (ts->type)
1866     {
1867     case BT_INTEGER:
1868       arg2 = build_int_cst (NULL_TREE, kind);
1869       function = iocall[IOCALL_X_INTEGER];
1870       break;
1871
1872     case BT_REAL:
1873       arg2 = build_int_cst (NULL_TREE, kind);
1874       function = iocall[IOCALL_X_REAL];
1875       break;
1876
1877     case BT_COMPLEX:
1878       arg2 = build_int_cst (NULL_TREE, kind);
1879       function = iocall[IOCALL_X_COMPLEX];
1880       break;
1881
1882     case BT_LOGICAL:
1883       arg2 = build_int_cst (NULL_TREE, kind);
1884       function = iocall[IOCALL_X_LOGICAL];
1885       break;
1886
1887     case BT_CHARACTER:
1888     case BT_HOLLERITH:
1889       if (se->string_length)
1890         arg2 = se->string_length;
1891       else
1892         {
1893           tmp = build_fold_indirect_ref (addr_expr);
1894           gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
1895           arg2 = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp)));
1896         }
1897       function = iocall[IOCALL_X_CHARACTER];
1898       break;
1899
1900     case BT_DERIVED:
1901       /* Recurse into the elements of the derived type.  */
1902       expr = gfc_evaluate_now (addr_expr, &se->pre);
1903       expr = build_fold_indirect_ref (expr);
1904
1905       for (c = ts->derived->components; c; c = c->next)
1906         {
1907           field = c->backend_decl;
1908           gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
1909
1910           tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
1911                              expr, field, NULL_TREE);
1912
1913           if (c->dimension)
1914             {
1915               tmp = transfer_array_component (tmp, c);
1916               gfc_add_expr_to_block (&se->pre, tmp);
1917             }
1918           else
1919             {
1920               if (!c->pointer)
1921                 tmp = build_fold_addr_expr (tmp);
1922               transfer_expr (se, &c->ts, tmp, code);
1923             }
1924         }
1925       return;
1926
1927     default:
1928       internal_error ("Bad IO basetype (%d)", ts->type);
1929     }
1930
1931   tmp = build_fold_addr_expr (dt_parm);
1932   tmp = build_call_expr (function, 3, tmp, addr_expr, arg2);
1933   gfc_add_expr_to_block (&se->pre, tmp);
1934   gfc_add_block_to_block (&se->pre, &se->post);
1935
1936 }
1937
1938
1939 /* Generate a call to pass an array descriptor to the IO library. The
1940    array should be of one of the intrinsic types.  */
1941
1942 static void
1943 transfer_array_desc (gfc_se * se, gfc_typespec * ts, tree addr_expr)
1944 {
1945   tree tmp, charlen_arg, kind_arg;
1946
1947   if (ts->type == BT_CHARACTER)
1948     charlen_arg = se->string_length;
1949   else
1950     charlen_arg = build_int_cst (NULL_TREE, 0);
1951
1952   kind_arg = build_int_cst (NULL_TREE, ts->kind);
1953
1954   tmp = build_fold_addr_expr (dt_parm);
1955   tmp = build_call_expr (iocall[IOCALL_X_ARRAY], 4,
1956                          tmp, addr_expr, kind_arg, charlen_arg);
1957   gfc_add_expr_to_block (&se->pre, tmp);
1958   gfc_add_block_to_block (&se->pre, &se->post);
1959 }
1960
1961
1962 /* gfc_trans_transfer()-- Translate a TRANSFER code node */
1963
1964 tree
1965 gfc_trans_transfer (gfc_code * code)
1966 {
1967   stmtblock_t block, body;
1968   gfc_loopinfo loop;
1969   gfc_expr *expr;
1970   gfc_ref *ref;
1971   gfc_ss *ss;
1972   gfc_se se;
1973   tree tmp;
1974   int n;
1975
1976   gfc_start_block (&block);
1977   gfc_init_block (&body);
1978
1979   expr = code->expr;
1980   ss = gfc_walk_expr (expr);
1981
1982   ref = NULL;
1983   gfc_init_se (&se, NULL);
1984
1985   if (ss == gfc_ss_terminator)
1986     {
1987       /* Transfer a scalar value.  */
1988       gfc_conv_expr_reference (&se, expr);
1989       transfer_expr (&se, &expr->ts, se.expr, code);
1990     }
1991   else
1992     {
1993       /* Transfer an array. If it is an array of an intrinsic
1994          type, pass the descriptor to the library.  Otherwise
1995          scalarize the transfer.  */
1996       if (expr->ref)
1997         {
1998           for (ref = expr->ref; ref && ref->type != REF_ARRAY;
1999                  ref = ref->next);
2000           gcc_assert (ref->type == REF_ARRAY);
2001         }
2002
2003       if (expr->ts.type != BT_DERIVED
2004             && ref && ref->next == NULL
2005             && !is_subref_array (expr))
2006         {
2007           bool seen_vector = false;
2008
2009           if (ref && ref->u.ar.type == AR_SECTION)
2010             {
2011               for (n = 0; n < ref->u.ar.dimen; n++)
2012                 if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR)
2013                   seen_vector = true;
2014             }
2015
2016           if (seen_vector && last_dt == READ)
2017             {
2018               /* Create a temp, read to that and copy it back.  */
2019               gfc_conv_subref_array_arg (&se, expr, 0, INTENT_OUT);
2020               tmp =  se.expr;
2021             }
2022           else
2023             {
2024               /* Get the descriptor.  */
2025               gfc_conv_expr_descriptor (&se, expr, ss);
2026               tmp = build_fold_addr_expr (se.expr);
2027             }
2028
2029           transfer_array_desc (&se, &expr->ts, tmp);
2030           goto finish_block_label;
2031         }
2032
2033       /* Initialize the scalarizer.  */
2034       gfc_init_loopinfo (&loop);
2035       gfc_add_ss_to_loop (&loop, ss);
2036
2037       /* Initialize the loop.  */
2038       gfc_conv_ss_startstride (&loop);
2039       gfc_conv_loop_setup (&loop);
2040
2041       /* The main loop body.  */
2042       gfc_mark_ss_chain_used (ss, 1);
2043       gfc_start_scalarized_body (&loop, &body);
2044
2045       gfc_copy_loopinfo_to_se (&se, &loop);
2046       se.ss = ss;
2047
2048       gfc_conv_expr_reference (&se, expr);
2049       transfer_expr (&se, &expr->ts, se.expr, code);
2050     }
2051
2052  finish_block_label:
2053
2054   gfc_add_block_to_block (&body, &se.pre);
2055   gfc_add_block_to_block (&body, &se.post);
2056
2057   if (se.ss == NULL)
2058     tmp = gfc_finish_block (&body);
2059   else
2060     {
2061       gcc_assert (se.ss == gfc_ss_terminator);
2062       gfc_trans_scalarizing_loops (&loop, &body);
2063
2064       gfc_add_block_to_block (&loop.pre, &loop.post);
2065       tmp = gfc_finish_block (&loop.pre);
2066       gfc_cleanup_loop (&loop);
2067     }
2068
2069   gfc_add_expr_to_block (&block, tmp);
2070
2071   return gfc_finish_block (&block);
2072 }
2073
2074 #include "gt-fortran-trans-io.h"
2075