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