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