gcc/fortran/trans-io.c

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