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, tree var, gfc_expr * e)
 590 {
 591   gfc_se se;
 592   tree io;
 593   tree len;
 594   tree desc;
 595   tree tmp;
 596   gfc_st_parameter_field *p;
 597   unsigned int mask;
 598
 599   gfc_init_se (&se, NULL);
 600
 601   p = &st_parameter_field[IOPARM_dt_internal_unit];
 602   mask = p->mask;
 603   io = build3 (COMPONENT_REF, TREE_TYPE (p->field), var, p->field,
 604                NULL_TREE);
 605   len = build3 (COMPONENT_REF, TREE_TYPE (p->field_len), var, p->field_len,
 606                 NULL_TREE);
 607   p = &st_parameter_field[IOPARM_dt_internal_unit_desc];
 608   desc = build3 (COMPONENT_REF, TREE_TYPE (p->field), var, p->field,
 609                  NULL_TREE);
 610
 611   gcc_assert (e->ts.type == BT_CHARACTER);
 612
 613   /* Character scalars.  */
 614   if (e->rank == 0)
 615     {
 616       gfc_conv_expr (&se, e);
 617       gfc_conv_string_parameter (&se);
 618       tmp = se.expr;
 619       se.expr = build_int_cst (pchar_type_node, 0);
 620     }
 621
 622   /* Character array.  */
 623   else if (e->rank > 0)
 624     {
 625       se.ss = gfc_walk_expr (e);
 626
 627       /* Return the data pointer and rank from the descriptor.  */
 628       gfc_conv_expr_descriptor (&se, e, se.ss);
 629       tmp = gfc_conv_descriptor_data_get (se.expr);
 630       se.expr = gfc_build_addr_expr (pchar_type_node, se.expr);
 631     }
 632   else
 633     gcc_unreachable ();
 634
 635   /* The cast is needed for character substrings and the descriptor
 636      data.  */
 637   gfc_add_modify_expr (&se.pre, io, fold_convert (TREE_TYPE (io), tmp));
 638   gfc_add_modify_expr (&se.pre, len, se.string_length);
 639   gfc_add_modify_expr (&se.pre, desc, se.expr);
 640
 641   gfc_add_block_to_block (block, &se.pre);
 642   return mask;
 643 }
 644
 645 /* Add a case to a IO-result switch.  */
 646
 647 static void
 648 add_case (int label_value, gfc_st_label * label, stmtblock_t * body)
 649 {
 650   tree tmp, value;
 651
 652   if (label == NULL)
 653     return;                     /* No label, no case */
 654
 655   value = build_int_cst (NULL_TREE, label_value);
 656
 657   /* Make a backend label for this case.  */
 658   tmp = gfc_build_label_decl (NULL_TREE);
 659
 660   /* And the case itself.  */
 661   tmp = build3_v (CASE_LABEL_EXPR, value, NULL_TREE, tmp);
 662   gfc_add_expr_to_block (body, tmp);
 663
 664   /* Jump to the label.  */
 665   tmp = build1_v (GOTO_EXPR, gfc_get_label_decl (label));
 666   gfc_add_expr_to_block (body, tmp);
 667 }
 668
 669
 670 /* Generate a switch statement that branches to the correct I/O
 671    result label.  The last statement of an I/O call stores the
 672    result into a variable because there is often cleanup that
 673    must be done before the switch, so a temporary would have to
 674    be created anyway.  */
 675
 676 static void
 677 io_result (stmtblock_t * block, tree var, gfc_st_label * err_label,
 678            gfc_st_label * end_label, gfc_st_label * eor_label)
 679 {
 680   stmtblock_t body;
 681   tree tmp, rc;
 682   gfc_st_parameter_field *p = &st_parameter_field[IOPARM_common_flags];
 683
 684   /* If no labels are specified, ignore the result instead
 685      of building an empty switch.  */
 686   if (err_label == NULL
 687       && end_label == NULL
 688       && eor_label == NULL)
 689     return;
 690
 691   /* Build a switch statement.  */
 692   gfc_start_block (&body);
 693
 694   /* The label values here must be the same as the values
 695      in the library_return enum in the runtime library */
 696   add_case (1, err_label, &body);
 697   add_case (2, end_label, &body);
 698   add_case (3, eor_label, &body);
 699
 700   tmp = gfc_finish_block (&body);
 701
 702   var = build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type,
 703                 var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
 704   rc = build3 (COMPONENT_REF, TREE_TYPE (p->field), var, p->field,
 705                NULL_TREE);
 706   rc = build2 (BIT_AND_EXPR, TREE_TYPE (rc), rc,
 707                build_int_cst (TREE_TYPE (rc), IOPARM_common_libreturn_mask));
 708
 709   tmp = build3_v (SWITCH_EXPR, rc, tmp, NULL_TREE);
 710
 711   gfc_add_expr_to_block (block, tmp);
 712 }
 713
 714
 715 /* Store the current file and line number to variables so that if a
 716    library call goes awry, we can tell the user where the problem is.  */
 717
 718 static void
 719 set_error_locus (stmtblock_t * block, tree var, locus * where)
 720 {
 721   gfc_file *f;
 722   tree str, locus_file;
 723   int line;
 724   gfc_st_parameter_field *p = &st_parameter_field[IOPARM_common_filename];
 725
 726   locus_file = build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type,
 727                        var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE);
 728   locus_file = build3 (COMPONENT_REF, TREE_TYPE (p->field), locus_file,
 729                        p->field, NULL_TREE);
 730   f = where->lb->file;
 731   str = gfc_build_cstring_const (f->filename);
 732
 733   str = gfc_build_addr_expr (pchar_type_node, str);
 734   gfc_add_modify_expr (block, locus_file, str);
 735
 736 #ifdef USE_MAPPED_LOCATION
 737   line = LOCATION_LINE (where->lb->location);
 738 #else
 739   line = where->lb->linenum;
 740 #endif
 741   set_parameter_const (block, var, IOPARM_common_line, line);
 742 }
 743
 744
 745 /* Translate an OPEN statement.  */
 746
 747 tree
 748 gfc_trans_open (gfc_code * code)
 749 {
 750   stmtblock_t block, post_block;
 751   gfc_open *p;
 752   tree tmp, var;
 753   unsigned int mask = 0;
 754
 755   gfc_start_block (&block);
 756   gfc_init_block (&post_block);
 757
 758   var = gfc_create_var (st_parameter[IOPARM_ptype_open].type, "open_parm");
 759
 760   set_error_locus (&block, var, &code->loc);
 761   p = code->ext.open;
 762
 763   if (p->unit)
 764     set_parameter_value (&block, var, IOPARM_common_unit, p->unit);
 765   else
 766     set_parameter_const (&block, var, IOPARM_common_unit, 0);
 767
 768   if (p->file)
 769     mask |= set_string (&block, &post_block, var, IOPARM_open_file, p->file);
 770
 771   if (p->status)
 772     mask |= set_string (&block, &post_block, var, IOPARM_open_status,
 773                         p->status);
 774
 775   if (p->access)
 776     mask |= set_string (&block, &post_block, var, IOPARM_open_access,
 777                         p->access);
 778
 779   if (p->form)
 780     mask |= set_string (&block, &post_block, var, IOPARM_open_form, p->form);
 781
 782   if (p->recl)
 783     mask |= set_parameter_value (&block, var, IOPARM_open_recl_in, p->recl);
 784
 785   if (p->blank)
 786     mask |= set_string (&block, &post_block, var, IOPARM_open_blank,
 787                         p->blank);
 788
 789   if (p->position)
 790     mask |= set_string (&block, &post_block, var, IOPARM_open_position,
 791                         p->position);
 792
 793   if (p->action)
 794     mask |= set_string (&block, &post_block, var, IOPARM_open_action,
 795                         p->action);
 796
 797   if (p->delim)
 798     mask |= set_string (&block, &post_block, var, IOPARM_open_delim,
 799                         p->delim);
 800
 801   if (p->pad)
 802     mask |= set_string (&block, &post_block, var, IOPARM_open_pad, p->pad);
 803
 804   if (p->iomsg)
 805     mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
 806                         p->iomsg);
 807
 808   if (p->iostat)
 809     mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
 810                                p->iostat);
 811
 812   if (p->err)
 813     mask |= IOPARM_common_err;
 814
 815   if (p->convert)
 816     mask |= set_string (&block, &post_block, var, IOPARM_open_convert,
 817                         p->convert);
 818
 819   set_parameter_const (&block, var, IOPARM_common_flags, mask);
 820
 821   tmp = build_fold_addr_expr (var);
 822   tmp = gfc_chainon_list (NULL_TREE, tmp);
 823   tmp = build_function_call_expr (iocall[IOCALL_OPEN], tmp);
 824   gfc_add_expr_to_block (&block, tmp);
 825
 826   gfc_add_block_to_block (&block, &post_block);
 827
 828   io_result (&block, var, p->err, NULL, NULL);
 829
 830   return gfc_finish_block (&block);
 831 }
 832
 833
 834 /* Translate a CLOSE statement.  */
 835
 836 tree
 837 gfc_trans_close (gfc_code * code)
 838 {
 839   stmtblock_t block, post_block;
 840   gfc_close *p;
 841   tree tmp, var;
 842   unsigned int mask = 0;
 843
 844   gfc_start_block (&block);
 845   gfc_init_block (&post_block);
 846
 847   var = gfc_create_var (st_parameter[IOPARM_ptype_close].type, "close_parm");
 848
 849   set_error_locus (&block, var, &code->loc);
 850   p = code->ext.close;
 851
 852   if (p->unit)
 853     set_parameter_value (&block, var, IOPARM_common_unit, p->unit);
 854   else
 855     set_parameter_const (&block, var, IOPARM_common_unit, 0);
 856
 857   if (p->status)
 858     mask |= set_string (&block, &post_block, var, IOPARM_close_status,
 859                         p->status);
 860
 861   if (p->iomsg)
 862     mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
 863                         p->iomsg);
 864
 865   if (p->iostat)
 866     mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
 867                                p->iostat);
 868
 869   if (p->err)
 870     mask |= IOPARM_common_err;
 871
 872   set_parameter_const (&block, var, IOPARM_common_flags, mask);
 873
 874   tmp = build_fold_addr_expr (var);
 875   tmp = gfc_chainon_list (NULL_TREE, tmp);
 876   tmp = build_function_call_expr (iocall[IOCALL_CLOSE], tmp);
 877   gfc_add_expr_to_block (&block, tmp);
 878
 879   gfc_add_block_to_block (&block, &post_block);
 880
 881   io_result (&block, var, p->err, NULL, NULL);
 882
 883   return gfc_finish_block (&block);
 884 }
 885
 886
 887 /* Common subroutine for building a file positioning statement.  */
 888
 889 static tree
 890 build_filepos (tree function, gfc_code * code)
 891 {
 892   stmtblock_t block, post_block;
 893   gfc_filepos *p;
 894   tree tmp, var;
 895   unsigned int mask = 0;
 896
 897   p = code->ext.filepos;
 898
 899   gfc_start_block (&block);
 900   gfc_init_block (&post_block);
 901
 902   var = gfc_create_var (st_parameter[IOPARM_ptype_filepos].type,
 903                         "filepos_parm");
 904
 905   set_error_locus (&block, var, &code->loc);
 906
 907   if (p->unit)
 908     set_parameter_value (&block, var, IOPARM_common_unit, p->unit);
 909   else
 910     set_parameter_const (&block, var, IOPARM_common_unit, 0);
 911
 912   if (p->iomsg)
 913     mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
 914                         p->iomsg);
 915
 916   if (p->iostat)
 917     mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
 918                                p->iostat);
 919
 920   if (p->err)
 921     mask |= IOPARM_common_err;
 922
 923   set_parameter_const (&block, var, IOPARM_common_flags, mask);
 924
 925   tmp = build_fold_addr_expr (var);
 926   tmp = gfc_chainon_list (NULL_TREE, tmp);
 927   tmp = build_function_call_expr (function, tmp);
 928   gfc_add_expr_to_block (&block, tmp);
 929
 930   gfc_add_block_to_block (&block, &post_block);
 931
 932   io_result (&block, var, p->err, NULL, NULL);
 933
 934   return gfc_finish_block (&block);
 935 }
 936
 937
 938 /* Translate a BACKSPACE statement.  */
 939
 940 tree
 941 gfc_trans_backspace (gfc_code * code)
 942 {
 943   return build_filepos (iocall[IOCALL_BACKSPACE], code);
 944 }
 945
 946
 947 /* Translate an ENDFILE statement.  */
 948
 949 tree
 950 gfc_trans_endfile (gfc_code * code)
 951 {
 952   return build_filepos (iocall[IOCALL_ENDFILE], code);
 953 }
 954
 955
 956 /* Translate a REWIND statement.  */
 957
 958 tree
 959 gfc_trans_rewind (gfc_code * code)
 960 {
 961   return build_filepos (iocall[IOCALL_REWIND], code);
 962 }
 963
 964
 965 /* Translate a FLUSH statement.  */
 966
 967 tree
 968 gfc_trans_flush (gfc_code * code)
 969 {
 970   return build_filepos (iocall[IOCALL_FLUSH], code);
 971 }
 972
 973
 974 /* Translate the non-IOLENGTH form of an INQUIRE statement.  */
 975
 976 tree
 977 gfc_trans_inquire (gfc_code * code)
 978 {
 979   stmtblock_t block, post_block;
 980   gfc_inquire *p;
 981   tree tmp, var;
 982   unsigned int mask = 0;
 983
 984   gfc_start_block (&block);
 985   gfc_init_block (&post_block);
 986
 987   var = gfc_create_var (st_parameter[IOPARM_ptype_inquire].type,
 988                         "inquire_parm");
 989
 990   set_error_locus (&block, var, &code->loc);
 991   p = code->ext.inquire;
 992
 993   /* Sanity check.  */
 994   if (p->unit && p->file)
 995     gfc_error ("INQUIRE statement at %L cannot contain both FILE and UNIT specifiers", &code->loc);
 996
 997   if (p->unit)
 998     set_parameter_value (&block, var, IOPARM_common_unit, p->unit);
 999   else
1000     set_parameter_const (&block, var, IOPARM_common_unit, 0);
1001
1002   if (p->file)
1003     mask |= set_string (&block, &post_block, var, IOPARM_inquire_file,
1004                         p->file);
1005
1006   if (p->iomsg)
1007     mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
1008                         p->iomsg);
1009
1010   if (p->iostat)
1011     mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat,
1012                                p->iostat);
1013
1014   if (p->exist)
1015     mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_exist,
1016                                p->exist);
1017
1018   if (p->opened)
1019     mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_opened,
1020                                p->opened);
1021
1022   if (p->number)
1023     mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_number,
1024                                p->number);
1025
1026   if (p->named)
1027     mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_named,
1028                                p->named);
1029
1030   if (p->name)
1031     mask |= set_string (&block, &post_block, var, IOPARM_inquire_name,
1032                         p->name);
1033
1034   if (p->access)
1035     mask |= set_string (&block, &post_block, var, IOPARM_inquire_access,
1036                         p->access);
1037
1038   if (p->sequential)
1039     mask |= set_string (&block, &post_block, var, IOPARM_inquire_sequential,
1040                         p->sequential);
1041
1042   if (p->direct)
1043     mask |= set_string (&block, &post_block, var, IOPARM_inquire_direct,
1044                         p->direct);
1045
1046   if (p->form)
1047     mask |= set_string (&block, &post_block, var, IOPARM_inquire_form,
1048                         p->form);
1049
1050   if (p->formatted)
1051     mask |= set_string (&block, &post_block, var, IOPARM_inquire_formatted,
1052                         p->formatted);
1053
1054   if (p->unformatted)
1055     mask |= set_string (&block, &post_block, var, IOPARM_inquire_unformatted,
1056                         p->unformatted);
1057
1058   if (p->recl)
1059     mask |= set_parameter_ref (&block, &post_block, var,
1060                                IOPARM_inquire_recl_out, p->recl);
1061
1062   if (p->nextrec)
1063     mask |= set_parameter_ref (&block, &post_block, var,
1064                                IOPARM_inquire_nextrec, p->nextrec);
1065
1066   if (p->blank)
1067     mask |= set_string (&block, &post_block, var, IOPARM_inquire_blank,
1068                         p->blank);
1069
1070   if (p->position)
1071     mask |= set_string (&block, &post_block, var, IOPARM_inquire_position,
1072                         p->position);
1073
1074   if (p->action)
1075     mask |= set_string (&block, &post_block, var, IOPARM_inquire_action,
1076                         p->action);
1077
1078   if (p->read)
1079     mask |= set_string (&block, &post_block, var, IOPARM_inquire_read,
1080                         p->read);
1081
1082   if (p->write)
1083     mask |= set_string (&block, &post_block, var, IOPARM_inquire_write,
1084                         p->write);
1085
1086   if (p->readwrite)
1087     mask |= set_string (&block, &post_block, var, IOPARM_inquire_readwrite,
1088                         p->readwrite);
1089
1090   if (p->delim)
1091     mask |= set_string (&block, &post_block, var, IOPARM_inquire_delim,
1092                         p->delim);
1093
1094   if (p->pad)
1095     mask |= set_string (&block, &post_block, var, IOPARM_inquire_pad,
1096                         p->pad);
1097
1098   if (p->err)
1099     mask |= IOPARM_common_err;
1100
1101   if (p->convert)
1102     mask |= set_string (&block, &post_block, var, IOPARM_inquire_convert,
1103                         p->convert);
1104
1105   if (p->strm_pos)
1106     mask |= set_parameter_ref (&block, &post_block, var,
1107                                IOPARM_inquire_strm_pos_out, p->strm_pos);
1108
1109   set_parameter_const (&block, var, IOPARM_common_flags, mask);
1110
1111   tmp = build_fold_addr_expr (var);
1112   tmp = gfc_chainon_list (NULL_TREE, tmp);
1113   tmp = build_function_call_expr (iocall[IOCALL_INQUIRE], tmp);
1114   gfc_add_expr_to_block (&block, tmp);
1115
1116   gfc_add_block_to_block (&block, &post_block);
1117
1118   io_result (&block, var, p->err, NULL, NULL);
1119
1120   return gfc_finish_block (&block);
1121 }
1122
1123 static gfc_expr *
1124 gfc_new_nml_name_expr (const char * name)
1125 {
1126    gfc_expr * nml_name;
1127
1128    nml_name = gfc_get_expr();
1129    nml_name->ref = NULL;
1130    nml_name->expr_type = EXPR_CONSTANT;
1131    nml_name->ts.kind = gfc_default_character_kind;
1132    nml_name->ts.type = BT_CHARACTER;
1133    nml_name->value.character.length = strlen(name);
1134    nml_name->value.character.string = gfc_getmem (strlen (name) + 1);
1135    strcpy (nml_name->value.character.string, name);
1136
1137    return nml_name;
1138 }
1139
1140 /* nml_full_name builds up the fully qualified name of a
1141    derived type component. */
1142
1143 static char*
1144 nml_full_name (const char* var_name, const char* cmp_name)
1145 {
1146   int full_name_length;
1147   char * full_name;
1148
1149   full_name_length = strlen (var_name) + strlen (cmp_name) + 1;
1150   full_name = (char*)gfc_getmem (full_name_length + 1);
1151   strcpy (full_name, var_name);
1152   full_name = strcat (full_name, "%");
1153   full_name = strcat (full_name, cmp_name);
1154   return full_name;
1155 }
1156
1157 /* nml_get_addr_expr builds an address expression from the
1158    gfc_symbol or gfc_component backend_decl's. An offset is
1159    provided so that the address of an element of an array of
1160    derived types is returned. This is used in the runtime to
1161    determine that span of the derived type. */
1162
1163 static tree
1164 nml_get_addr_expr (gfc_symbol * sym, gfc_component * c,
1165                    tree base_addr)
1166 {
1167   tree decl = NULL_TREE;
1168   tree tmp;
1169   tree itmp;
1170   int array_flagged;
1171   int dummy_arg_flagged;
1172
1173   if (sym)
1174     {
1175       sym->attr.referenced = 1;
1176       decl = gfc_get_symbol_decl (sym);
1177     }
1178   else
1179     decl = c->backend_decl;
1180
1181   gcc_assert (decl && ((TREE_CODE (decl) == FIELD_DECL
1182                      || TREE_CODE (decl) == VAR_DECL
1183                      || TREE_CODE (decl) == PARM_DECL)
1184                      || TREE_CODE (decl) == COMPONENT_REF));
1185
1186   tmp = decl;
1187
1188   /* Build indirect reference, if dummy argument.  */
1189
1190   dummy_arg_flagged = POINTER_TYPE_P (TREE_TYPE(tmp));
1191
1192   itmp = (dummy_arg_flagged) ? build_fold_indirect_ref (tmp) : tmp;
1193
1194   /* If an array, set flag and use indirect ref. if built.  */
1195
1196   array_flagged = (TREE_CODE (TREE_TYPE (itmp)) == ARRAY_TYPE
1197                    && !TYPE_STRING_FLAG (TREE_TYPE (itmp)));
1198
1199   if (array_flagged)
1200     tmp = itmp;
1201
1202   /* Treat the component of a derived type, using base_addr for
1203      the derived type.  */
1204
1205   if (TREE_CODE (decl) == FIELD_DECL)
1206     tmp = build3 (COMPONENT_REF, TREE_TYPE (tmp),
1207                   base_addr, tmp, NULL_TREE);
1208
1209   /* If we have a derived type component, a reference to the first
1210      element of the array is built.  This is done so that base_addr,
1211      used in the build of the component reference, always points to
1212      a RECORD_TYPE.  */
1213
1214   if (array_flagged)
1215     tmp = gfc_build_array_ref (tmp, gfc_index_zero_node);
1216
1217   /* Now build the address expression.  */
1218
1219   tmp = build_fold_addr_expr (tmp);
1220
1221   /* If scalar dummy, resolve indirect reference now.  */
1222
1223   if (dummy_arg_flagged && !array_flagged)
1224     tmp = build_fold_indirect_ref (tmp);
1225
1226   gcc_assert (tmp && POINTER_TYPE_P (TREE_TYPE (tmp)));
1227
1228   return tmp;
1229 }
1230
1231 /* For an object VAR_NAME whose base address is BASE_ADDR, generate a
1232    call to iocall[IOCALL_SET_NML_VAL].  For derived type variable, recursively
1233    generate calls to iocall[IOCALL_SET_NML_VAL] for each component.  */
1234
1235 #define NML_FIRST_ARG(a) args = gfc_chainon_list (NULL_TREE, a)
1236 #define NML_ADD_ARG(a) args = gfc_chainon_list (args, a)
1237 #define IARG(i) build_int_cst (gfc_array_index_type, i)
1238
1239 static void
1240 transfer_namelist_element (stmtblock_t * block, const char * var_name,
1241                            gfc_symbol * sym, gfc_component * c,
1242                            tree base_addr)
1243 {
1244   gfc_typespec * ts = NULL;
1245   gfc_array_spec * as = NULL;
1246   tree addr_expr = NULL;
1247   tree dt = NULL;
1248   tree string;
1249   tree tmp;
1250   tree args;
1251   tree dtype;
1252   tree dt_parm_addr;
1253   int n_dim;
1254   int itype;
1255   int rank = 0;
1256
1257   gcc_assert (sym || c);
1258
1259   /* Build the namelist object name.  */
1260
1261   string = gfc_build_cstring_const (var_name);
1262   string = gfc_build_addr_expr (pchar_type_node, string);
1263
1264   /* Build ts, as and data address using symbol or component.  */
1265
1266   ts = (sym) ? &sym->ts : &c->ts;
1267   as = (sym) ? sym->as : c->as;
1268
1269   addr_expr = nml_get_addr_expr (sym, c, base_addr);
1270
1271   if (as)
1272     rank = as->rank;
1273
1274   if (rank)
1275     {
1276       dt =  TREE_TYPE ((sym) ? sym->backend_decl : c->backend_decl);
1277       dtype = gfc_get_dtype (dt);
1278     }
1279   else
1280     {
1281       itype = GFC_DTYPE_UNKNOWN;
1282
1283       switch (ts->type)
1284
1285         {
1286         case BT_INTEGER:
1287           itype = GFC_DTYPE_INTEGER;
1288           break;
1289         case BT_LOGICAL:
1290           itype = GFC_DTYPE_LOGICAL;
1291           break;
1292         case BT_REAL:
1293           itype = GFC_DTYPE_REAL;
1294           break;
1295         case BT_COMPLEX:
1296           itype = GFC_DTYPE_COMPLEX;
1297         break;
1298         case BT_DERIVED:
1299           itype = GFC_DTYPE_DERIVED;
1300           break;
1301         case BT_CHARACTER:
1302           itype = GFC_DTYPE_CHARACTER;
1303           break;
1304         default:
1305           gcc_unreachable ();
1306         }
1307
1308       dtype = IARG (itype << GFC_DTYPE_TYPE_SHIFT);
1309     }
1310
1311   /* Build up the arguments for the transfer call.
1312      The call for the scalar part transfers:
1313      (address, name, type, kind or string_length, dtype)  */
1314
1315   dt_parm_addr = build_fold_addr_expr (dt_parm);
1316   NML_FIRST_ARG (dt_parm_addr);
1317   NML_ADD_ARG (addr_expr);
1318   NML_ADD_ARG (string);
1319   NML_ADD_ARG (IARG (ts->kind));
1320
1321   if (ts->type == BT_CHARACTER)
1322     NML_ADD_ARG (ts->cl->backend_decl);
1323   else
1324     NML_ADD_ARG (build_int_cst (gfc_charlen_type_node, 0));
1325
1326   NML_ADD_ARG (dtype);
1327   tmp = build_function_call_expr (iocall[IOCALL_SET_NML_VAL], args);
1328   gfc_add_expr_to_block (block, tmp);
1329
1330   /* If the object is an array, transfer rank times:
1331      (null pointer, name, stride, lbound, ubound)  */
1332
1333   for ( n_dim = 0 ; n_dim < rank ; n_dim++ )
1334     {
1335       NML_FIRST_ARG (dt_parm_addr);
1336       NML_ADD_ARG (IARG (n_dim));
1337       NML_ADD_ARG (GFC_TYPE_ARRAY_STRIDE (dt, n_dim));
1338       NML_ADD_ARG (GFC_TYPE_ARRAY_LBOUND (dt, n_dim));
1339       NML_ADD_ARG (GFC_TYPE_ARRAY_UBOUND (dt, n_dim));
1340       tmp = build_function_call_expr (iocall[IOCALL_SET_NML_VAL_DIM], args);
1341       gfc_add_expr_to_block (block, tmp);
1342     }
1343
1344   if (ts->type == BT_DERIVED)
1345     {
1346       gfc_component *cmp;
1347
1348       /* Provide the RECORD_TYPE to build component references.  */
1349
1350       tree expr = build_fold_indirect_ref (addr_expr);
1351
1352       for (cmp = ts->derived->components; cmp; cmp = cmp->next)
1353         {
1354           char *full_name = nml_full_name (var_name, cmp->name);
1355           transfer_namelist_element (block,
1356                                      full_name,
1357                                      NULL, cmp, expr);
1358           gfc_free (full_name);
1359         }
1360     }
1361 }
1362
1363 #undef IARG
1364 #undef NML_ADD_ARG
1365 #undef NML_FIRST_ARG
1366
1367 /* Create a data transfer statement.  Not all of the fields are valid
1368    for both reading and writing, but improper use has been filtered
1369    out by now.  */
1370
1371 static tree
1372 build_dt (tree function, gfc_code * code)
1373 {
1374   stmtblock_t block, post_block, post_end_block;
1375   gfc_dt *dt;
1376   tree tmp, var;
1377   gfc_expr *nmlname;
1378   gfc_namelist *nml;
1379   unsigned int mask = 0;
1380
1381   gfc_start_block (&block);
1382   gfc_init_block (&post_block);
1383   gfc_init_block (&post_end_block);
1384
1385   var = gfc_create_var (st_parameter[IOPARM_ptype_dt].type, "dt_parm");
1386
1387   set_error_locus (&block, var, &code->loc);
1388
1389   if (last_dt == IOLENGTH)
1390     {
1391       gfc_inquire *inq;
1392
1393       inq = code->ext.inquire;
1394
1395       /* First check that preconditions are met.  */
1396       gcc_assert (inq != NULL);
1397       gcc_assert (inq->iolength != NULL);
1398
1399       /* Connect to the iolength variable.  */
1400       mask |= set_parameter_ref (&block, &post_end_block, var,
1401                                  IOPARM_dt_iolength, inq->iolength);
1402       dt = NULL;
1403     }
1404   else
1405     {
1406       dt = code->ext.dt;
1407       gcc_assert (dt != NULL);
1408     }
1409
1410   if (dt && dt->io_unit)
1411     {
1412       if (dt->io_unit->ts.type == BT_CHARACTER)
1413         {
1414           mask |= set_internal_unit (&block, var, dt->io_unit);
1415           set_parameter_const (&block, var, IOPARM_common_unit, 0);
1416         }
1417       else
1418         set_parameter_value (&block, var, IOPARM_common_unit, dt->io_unit);
1419     }
1420   else
1421     set_parameter_const (&block, var, IOPARM_common_unit, 0);
1422
1423   if (dt)
1424     {
1425       if (dt->rec)
1426         mask |= set_parameter_value (&block, var, IOPARM_dt_rec, dt->rec);
1427
1428       if (dt->advance)
1429         mask |= set_string (&block, &post_block, var, IOPARM_dt_advance,
1430                             dt->advance);
1431
1432       if (dt->format_expr)
1433         mask |= set_string (&block, &post_end_block, var, IOPARM_dt_format,
1434                             dt->format_expr);
1435
1436       if (dt->format_label)
1437         {
1438           if (dt->format_label == &format_asterisk)
1439             mask |= IOPARM_dt_list_format;
1440           else
1441             mask |= set_string (&block, &post_block, var, IOPARM_dt_format,
1442                                 dt->format_label->format);
1443         }
1444
1445       if (dt->iomsg)
1446         mask |= set_string (&block, &post_block, var, IOPARM_common_iomsg,
1447                             dt->iomsg);
1448
1449       if (dt->iostat)
1450         mask |= set_parameter_ref (&block, &post_end_block, var,
1451                                    IOPARM_common_iostat, dt->iostat);
1452
1453       if (dt->size)
1454         mask |= set_parameter_ref (&block, &post_end_block, var,
1455                                    IOPARM_dt_size, dt->size);
1456
1457       if (dt->err)
1458         mask |= IOPARM_common_err;
1459
1460       if (dt->eor)
1461         mask |= IOPARM_common_eor;
1462
1463       if (dt->end)
1464         mask |= IOPARM_common_end;
1465
1466       if (dt->namelist)
1467         {
1468           if (dt->format_expr || dt->format_label)
1469             gfc_internal_error ("build_dt: format with namelist");
1470
1471           nmlname = gfc_new_nml_name_expr (dt->namelist->name);
1472
1473           mask |= set_string (&block, &post_block, var, IOPARM_dt_namelist_name,
1474                               nmlname);
1475
1476           if (last_dt == READ)
1477             mask |= IOPARM_dt_namelist_read_mode;
1478
1479           set_parameter_const (&block, var, IOPARM_common_flags, mask);
1480
1481           dt_parm = var;
1482
1483           for (nml = dt->namelist->namelist; nml; nml = nml->next)
1484             transfer_namelist_element (&block, nml->sym->name, nml->sym,
1485                                        NULL, NULL);
1486         }
1487       else
1488         set_parameter_const (&block, var, IOPARM_common_flags, mask);
1489     }
1490   else
1491     set_parameter_const (&block, var, IOPARM_common_flags, mask);
1492
1493   tmp = build_fold_addr_expr (var);
1494   tmp = gfc_chainon_list (NULL_TREE, tmp);
1495   tmp = build_function_call_expr (function, tmp);
1496   gfc_add_expr_to_block (&block, tmp);
1497
1498   gfc_add_block_to_block (&block, &post_block);
1499
1500   dt_parm = var;
1501   dt_post_end_block = &post_end_block;
1502
1503   gfc_add_expr_to_block (&block, gfc_trans_code (code->block->next));
1504
1505   dt_parm = NULL;
1506   dt_post_end_block = NULL;
1507
1508   return gfc_finish_block (&block);
1509 }
1510
1511
1512 /* Translate the IOLENGTH form of an INQUIRE statement.  We treat
1513    this as a third sort of data transfer statement, except that
1514    lengths are summed instead of actually transferring any data.  */
1515
1516 tree
1517 gfc_trans_iolength (gfc_code * code)
1518 {
1519   last_dt = IOLENGTH;
1520   return build_dt (iocall[IOCALL_IOLENGTH], code);
1521 }
1522
1523
1524 /* Translate a READ statement.  */
1525
1526 tree
1527 gfc_trans_read (gfc_code * code)
1528 {
1529   last_dt = READ;
1530   return build_dt (iocall[IOCALL_READ], code);
1531 }
1532
1533
1534 /* Translate a WRITE statement */
1535
1536 tree
1537 gfc_trans_write (gfc_code * code)
1538 {
1539   last_dt = WRITE;
1540   return build_dt (iocall[IOCALL_WRITE], code);
1541 }
1542
1543
1544 /* Finish a data transfer statement.  */
1545
1546 tree
1547 gfc_trans_dt_end (gfc_code * code)
1548 {
1549   tree function, tmp;
1550   stmtblock_t block;
1551
1552   gfc_init_block (&block);
1553
1554   switch (last_dt)
1555     {
1556     case READ:
1557       function = iocall[IOCALL_READ_DONE];
1558       break;
1559
1560     case WRITE:
1561       function = iocall[IOCALL_WRITE_DONE];
1562       break;
1563
1564     case IOLENGTH:
1565       function = iocall[IOCALL_IOLENGTH_DONE];
1566       break;
1567
1568     default:
1569       gcc_unreachable ();
1570     }
1571
1572   tmp = build_fold_addr_expr (dt_parm);
1573   tmp = gfc_chainon_list (NULL_TREE, tmp);
1574   tmp = build_function_call_expr (function, tmp);
1575   gfc_add_expr_to_block (&block, tmp);
1576   gfc_add_block_to_block (&block, dt_post_end_block);
1577   gfc_init_block (dt_post_end_block);
1578
1579   if (last_dt != IOLENGTH)
1580     {
1581       gcc_assert (code->ext.dt != NULL);
1582       io_result (&block, dt_parm, code->ext.dt->err,
1583                  code->ext.dt->end, code->ext.dt->eor);
1584     }
1585
1586   return gfc_finish_block (&block);
1587 }
1588
1589 static void
1590 transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr);
1591
1592 /* Given an array field in a derived type variable, generate the code
1593    for the loop that iterates over array elements, and the code that
1594    accesses those array elements.  Use transfer_expr to generate code
1595    for transferring that element.  Because elements may also be
1596    derived types, transfer_expr and transfer_array_component are mutually
1597    recursive.  */
1598
1599 static tree
1600 transfer_array_component (tree expr, gfc_component * cm)
1601 {
1602   tree tmp;
1603   stmtblock_t body;
1604   stmtblock_t block;
1605   gfc_loopinfo loop;
1606   int n;
1607   gfc_ss *ss;
1608   gfc_se se;
1609
1610   gfc_start_block (&block);
1611   gfc_init_se (&se, NULL);
1612
1613   /* Create and initialize Scalarization Status.  Unlike in
1614      gfc_trans_transfer, we can't simply use gfc_walk_expr to take
1615      care of this task, because we don't have a gfc_expr at hand.
1616      Build one manually, as in gfc_trans_subarray_assign.  */
1617
1618   ss = gfc_get_ss ();
1619   ss->type = GFC_SS_COMPONENT;
1620   ss->expr = NULL;
1621   ss->shape = gfc_get_shape (cm->as->rank);
1622   ss->next = gfc_ss_terminator;
1623   ss->data.info.dimen = cm->as->rank;
1624   ss->data.info.descriptor = expr;
1625   ss->data.info.data = gfc_conv_array_data (expr);
1626   ss->data.info.offset = gfc_conv_array_offset (expr);
1627   for (n = 0; n < cm->as->rank; n++)
1628     {
1629       ss->data.info.dim[n] = n;
1630       ss->data.info.start[n] = gfc_conv_array_lbound (expr, n);
1631       ss->data.info.stride[n] = gfc_index_one_node;
1632
1633       mpz_init (ss->shape[n]);
1634       mpz_sub (ss->shape[n], cm->as->upper[n]->value.integer,
1635                cm->as->lower[n]->value.integer);
1636       mpz_add_ui (ss->shape[n], ss->shape[n], 1);
1637     }
1638
1639   /* Once we got ss, we use scalarizer to create the loop.  */
1640
1641   gfc_init_loopinfo (&loop);
1642   gfc_add_ss_to_loop (&loop, ss);
1643   gfc_conv_ss_startstride (&loop);
1644   gfc_conv_loop_setup (&loop);
1645   gfc_mark_ss_chain_used (ss, 1);
1646   gfc_start_scalarized_body (&loop, &body);
1647
1648   gfc_copy_loopinfo_to_se (&se, &loop);
1649   se.ss = ss;
1650
1651   /* gfc_conv_tmp_array_ref assumes that se.expr contains the array.  */
1652   se.expr = expr;
1653   gfc_conv_tmp_array_ref (&se);
1654
1655   /* Now se.expr contains an element of the array.  Take the address and pass
1656      it to the IO routines.  */
1657   tmp = build_fold_addr_expr (se.expr);
1658   transfer_expr (&se, &cm->ts, tmp);
1659
1660   /* We are done now with the loop body.  Wrap up the scalarizer and
1661      return.  */
1662
1663   gfc_add_block_to_block (&body, &se.pre);
1664   gfc_add_block_to_block (&body, &se.post);
1665
1666   gfc_trans_scalarizing_loops (&loop, &body);
1667
1668   gfc_add_block_to_block (&block, &loop.pre);
1669   gfc_add_block_to_block (&block, &loop.post);
1670
1671   for (n = 0; n < cm->as->rank; n++)
1672     mpz_clear (ss->shape[n]);
1673   gfc_free (ss->shape);
1674
1675   gfc_cleanup_loop (&loop);
1676
1677   return gfc_finish_block (&block);
1678 }
1679
1680 /* Generate the call for a scalar transfer node.  */
1681
1682 static void
1683 transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr)
1684 {
1685   tree args, tmp, function, arg2, field, expr;
1686   gfc_component *c;
1687   int kind;
1688
1689   kind = ts->kind;
1690   function = NULL;
1691   arg2 = NULL;
1692
1693   switch (ts->type)
1694     {
1695     case BT_INTEGER:
1696       arg2 = build_int_cst (NULL_TREE, kind);
1697       function = iocall[IOCALL_X_INTEGER];
1698       break;
1699
1700     case BT_REAL:
1701       arg2 = build_int_cst (NULL_TREE, kind);
1702       function = iocall[IOCALL_X_REAL];
1703       break;
1704
1705     case BT_COMPLEX:
1706       arg2 = build_int_cst (NULL_TREE, kind);
1707       function = iocall[IOCALL_X_COMPLEX];
1708       break;
1709
1710     case BT_LOGICAL:
1711       arg2 = build_int_cst (NULL_TREE, kind);
1712       function = iocall[IOCALL_X_LOGICAL];
1713       break;
1714
1715     case BT_CHARACTER:
1716     case BT_HOLLERITH:
1717       if (se->string_length)
1718         arg2 = se->string_length;
1719       else
1720         {
1721           tmp = build_fold_indirect_ref (addr_expr);
1722           gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
1723           arg2 = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp)));
1724         }
1725       function = iocall[IOCALL_X_CHARACTER];
1726       break;
1727
1728     case BT_DERIVED:
1729       /* Recurse into the elements of the derived type.  */
1730       expr = gfc_evaluate_now (addr_expr, &se->pre);
1731       expr = build_fold_indirect_ref (expr);
1732
1733       for (c = ts->derived->components; c; c = c->next)
1734         {
1735           field = c->backend_decl;
1736           gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
1737
1738           tmp = build3 (COMPONENT_REF, TREE_TYPE (field), expr, field,
1739                         NULL_TREE);
1740
1741           if (c->dimension)
1742             {
1743               tmp = transfer_array_component (tmp, c);
1744               gfc_add_expr_to_block (&se->pre, tmp);
1745             }
1746           else
1747             {
1748               if (!c->pointer)
1749                 tmp = build_fold_addr_expr (tmp);
1750               transfer_expr (se, &c->ts, tmp);
1751             }
1752         }
1753       return;
1754
1755     default:
1756       internal_error ("Bad IO basetype (%d)", ts->type);
1757     }
1758
1759   tmp = build_fold_addr_expr (dt_parm);
1760   args = gfc_chainon_list (NULL_TREE, tmp);
1761   args = gfc_chainon_list (args, addr_expr);
1762   args = gfc_chainon_list (args, arg2);
1763
1764   tmp = build_function_call_expr (function, args);
1765   gfc_add_expr_to_block (&se->pre, tmp);
1766   gfc_add_block_to_block (&se->pre, &se->post);
1767
1768 }
1769
1770
1771 /* Generate a call to pass an array descriptor to the IO library. The
1772    array should be of one of the intrinsic types.  */
1773
1774 static void
1775 transfer_array_desc (gfc_se * se, gfc_typespec * ts, tree addr_expr)
1776 {
1777   tree args, tmp, charlen_arg, kind_arg;
1778
1779   if (ts->type == BT_CHARACTER)
1780     charlen_arg = se->string_length;
1781   else
1782     charlen_arg = build_int_cst (NULL_TREE, 0);
1783
1784   kind_arg = build_int_cst (NULL_TREE, ts->kind);
1785
1786   tmp = build_fold_addr_expr (dt_parm);
1787   args = gfc_chainon_list (NULL_TREE, tmp);
1788   args = gfc_chainon_list (args, addr_expr);
1789   args = gfc_chainon_list (args, kind_arg);
1790   args = gfc_chainon_list (args, charlen_arg);
1791   tmp = build_function_call_expr (iocall[IOCALL_X_ARRAY], args);
1792   gfc_add_expr_to_block (&se->pre, tmp);
1793   gfc_add_block_to_block (&se->pre, &se->post);
1794 }
1795
1796
1797 /* gfc_trans_transfer()-- Translate a TRANSFER code node */
1798
1799 tree
1800 gfc_trans_transfer (gfc_code * code)
1801 {
1802   stmtblock_t block, body;
1803   gfc_loopinfo loop;
1804   gfc_expr *expr;
1805   gfc_ref *ref;
1806   gfc_ss *ss;
1807   gfc_se se;
1808   tree tmp;
1809
1810   gfc_start_block (&block);
1811   gfc_init_block (&body);
1812
1813   expr = code->expr;
1814   ss = gfc_walk_expr (expr);
1815
1816   ref = NULL;
1817   gfc_init_se (&se, NULL);
1818
1819   if (ss == gfc_ss_terminator)
1820     {
1821       /* Transfer a scalar value.  */
1822       gfc_conv_expr_reference (&se, expr);
1823       transfer_expr (&se, &expr->ts, se.expr);
1824     }
1825   else
1826     {
1827       /* Transfer an array. If it is an array of an intrinsic
1828          type, pass the descriptor to the library.  Otherwise
1829          scalarize the transfer.  */
1830       if (expr->ref)
1831         {
1832           for (ref = expr->ref; ref && ref->type != REF_ARRAY;
1833                  ref = ref->next);
1834           gcc_assert (ref->type == REF_ARRAY);
1835         }
1836
1837       if (expr->ts.type != BT_DERIVED && ref && ref->next == NULL)
1838         {
1839           /* Get the descriptor.  */
1840           gfc_conv_expr_descriptor (&se, expr, ss);
1841           tmp = build_fold_addr_expr (se.expr);
1842           transfer_array_desc (&se, &expr->ts, tmp);
1843           goto finish_block_label;
1844         }
1845
1846       /* Initialize the scalarizer.  */
1847       gfc_init_loopinfo (&loop);
1848       gfc_add_ss_to_loop (&loop, ss);
1849
1850       /* Initialize the loop.  */
1851       gfc_conv_ss_startstride (&loop);
1852       gfc_conv_loop_setup (&loop);
1853
1854       /* The main loop body.  */
1855       gfc_mark_ss_chain_used (ss, 1);
1856       gfc_start_scalarized_body (&loop, &body);
1857
1858       gfc_copy_loopinfo_to_se (&se, &loop);
1859       se.ss = ss;
1860
1861       gfc_conv_expr_reference (&se, expr);
1862       transfer_expr (&se, &expr->ts, se.expr);
1863     }
1864
1865  finish_block_label:
1866
1867   gfc_add_block_to_block (&body, &se.pre);
1868   gfc_add_block_to_block (&body, &se.post);
1869
1870   if (se.ss == NULL)
1871     tmp = gfc_finish_block (&body);
1872   else
1873     {
1874       gcc_assert (se.ss == gfc_ss_terminator);
1875       gfc_trans_scalarizing_loops (&loop, &body);
1876
1877       gfc_add_block_to_block (&loop.pre, &loop.post);
1878       tmp = gfc_finish_block (&loop.pre);
1879       gfc_cleanup_loop (&loop);
1880     }
1881
1882   gfc_add_expr_to_block (&block, tmp);
1883
1884   return gfc_finish_block (&block);
1885 }
1886
1887 #include "gt-fortran-trans-io.h"
1888