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   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 = 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 = build3 (COMPONENT_REF, TREE_TYPE (field), expr, field,
1911                         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
1975   gfc_start_block (&block);
1976   gfc_init_block (&body);
1977
1978   expr = code->expr;
1979   ss = gfc_walk_expr (expr);
1980
1981   ref = NULL;
1982   gfc_init_se (&se, NULL);
1983
1984   if (ss == gfc_ss_terminator)
1985     {
1986       /* Transfer a scalar value.  */
1987       gfc_conv_expr_reference (&se, expr);
1988       transfer_expr (&se, &expr->ts, se.expr, code);
1989     }
1990   else
1991     {
1992       /* Transfer an array. If it is an array of an intrinsic
1993          type, pass the descriptor to the library.  Otherwise
1994          scalarize the transfer.  */
1995       if (expr->ref)
1996         {
1997           for (ref = expr->ref; ref && ref->type != REF_ARRAY;
1998                  ref = ref->next);
1999           gcc_assert (ref->type == REF_ARRAY);
2000         }
2001
2002       if (expr->ts.type != BT_DERIVED
2003             && ref && ref->next == NULL
2004             && !is_subref_array (expr))
2005         {
2006           /* Get the descriptor.  */
2007           gfc_conv_expr_descriptor (&se, expr, ss);
2008           tmp = build_fold_addr_expr (se.expr);
2009           transfer_array_desc (&se, &expr->ts, tmp);
2010           goto finish_block_label;
2011         }
2012
2013       /* Initialize the scalarizer.  */
2014       gfc_init_loopinfo (&loop);
2015       gfc_add_ss_to_loop (&loop, ss);
2016
2017       /* Initialize the loop.  */
2018       gfc_conv_ss_startstride (&loop);
2019       gfc_conv_loop_setup (&loop);
2020
2021       /* The main loop body.  */
2022       gfc_mark_ss_chain_used (ss, 1);
2023       gfc_start_scalarized_body (&loop, &body);
2024
2025       gfc_copy_loopinfo_to_se (&se, &loop);
2026       se.ss = ss;
2027
2028       gfc_conv_expr_reference (&se, expr);
2029       transfer_expr (&se, &expr->ts, se.expr, code);
2030     }
2031
2032  finish_block_label:
2033
2034   gfc_add_block_to_block (&body, &se.pre);
2035   gfc_add_block_to_block (&body, &se.post);
2036
2037   if (se.ss == NULL)
2038     tmp = gfc_finish_block (&body);
2039   else
2040     {
2041       gcc_assert (se.ss == gfc_ss_terminator);
2042       gfc_trans_scalarizing_loops (&loop, &body);
2043
2044       gfc_add_block_to_block (&loop.pre, &loop.post);
2045       tmp = gfc_finish_block (&loop.pre);
2046       gfc_cleanup_loop (&loop);
2047     }
2048
2049   gfc_add_expr_to_block (&block, tmp);
2050
2051   return gfc_finish_block (&block);
2052 }
2053
2054 #include "gt-fortran-trans-io.h"
2055