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