gcc/fortran/trans-io.c

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