gcc/fortran/trans-io.c

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