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