gcc/fortran/trans-io.c

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