gcc/fortran/trans-io.c

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