gcc/fortran/trans-io.c

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