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