gcc/fortran/trans-io.c

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