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