gcc/fortran/trans-io.c

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