gcc/fortran/trans-io.c

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