gcc/fortran/trans-io.c

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