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 static GTY(()) tree ioparm_unit;
  42 static GTY(()) tree ioparm_err;
  43 static GTY(()) tree ioparm_end;
  44 static GTY(()) tree ioparm_eor;
  45 static GTY(()) tree ioparm_list_format;
  46 static GTY(()) tree ioparm_library_return;
  47 static GTY(()) tree ioparm_iostat;
  48 static GTY(()) tree ioparm_exist;
  49 static GTY(()) tree ioparm_opened;
  50 static GTY(()) tree ioparm_number;
  51 static GTY(()) tree ioparm_named;
  52 static GTY(()) tree ioparm_rec;
  53 static GTY(()) tree ioparm_nextrec;
  54 static GTY(()) tree ioparm_size;
  55 static GTY(()) tree ioparm_recl_in;
  56 static GTY(()) tree ioparm_recl_out;
  57 static GTY(()) tree ioparm_iolength;
  58 static GTY(()) tree ioparm_file;
  59 static GTY(()) tree ioparm_file_len;
  60 static GTY(()) tree ioparm_status;
  61 static GTY(()) tree ioparm_status_len;
  62 static GTY(()) tree ioparm_access;
  63 static GTY(()) tree ioparm_access_len;
  64 static GTY(()) tree ioparm_form;
  65 static GTY(()) tree ioparm_form_len;
  66 static GTY(()) tree ioparm_blank;
  67 static GTY(()) tree ioparm_blank_len;
  68 static GTY(()) tree ioparm_position;
  69 static GTY(()) tree ioparm_position_len;
  70 static GTY(()) tree ioparm_action;
  71 static GTY(()) tree ioparm_action_len;
  72 static GTY(()) tree ioparm_delim;
  73 static GTY(()) tree ioparm_delim_len;
  74 static GTY(()) tree ioparm_pad;
  75 static GTY(()) tree ioparm_pad_len;
  76 static GTY(()) tree ioparm_format;
  77 static GTY(()) tree ioparm_format_len;
  78 static GTY(()) tree ioparm_advance;
  79 static GTY(()) tree ioparm_advance_len;
  80 static GTY(()) tree ioparm_name;
  81 static GTY(()) tree ioparm_name_len;
  82 static GTY(()) tree ioparm_internal_unit;
  83 static GTY(()) tree ioparm_internal_unit_len;
  84 static GTY(()) tree ioparm_sequential;
  85 static GTY(()) tree ioparm_sequential_len;
  86 static GTY(()) tree ioparm_direct;
  87 static GTY(()) tree ioparm_direct_len;
  88 static GTY(()) tree ioparm_formatted;
  89 static GTY(()) tree ioparm_formatted_len;
  90 static GTY(()) tree ioparm_unformatted;
  91 static GTY(()) tree ioparm_unformatted_len;
  92 static GTY(()) tree ioparm_read;
  93 static GTY(()) tree ioparm_read_len;
  94 static GTY(()) tree ioparm_write;
  95 static GTY(()) tree ioparm_write_len;
  96 static GTY(()) tree ioparm_readwrite;
  97 static GTY(()) tree ioparm_readwrite_len;
  98 static GTY(()) tree ioparm_namelist_name;
  99 static GTY(()) tree ioparm_namelist_name_len;
 100 static GTY(()) tree ioparm_namelist_read_mode;
 101 static GTY(()) tree ioparm_iomsg;
 102 static GTY(()) tree ioparm_iomsg_len;
 103
 104 /* The global I/O variables */
 105
 106 static GTY(()) tree ioparm_var;
 107 static GTY(()) tree locus_file;
 108 static GTY(()) tree locus_line;
 109
 110
 111 /* Library I/O subroutines */
 112
 113 static GTY(()) tree iocall_read;
 114 static GTY(()) tree iocall_read_done;
 115 static GTY(()) tree iocall_write;
 116 static GTY(()) tree iocall_write_done;
 117 static GTY(()) tree iocall_x_integer;
 118 static GTY(()) tree iocall_x_logical;
 119 static GTY(()) tree iocall_x_character;
 120 static GTY(()) tree iocall_x_real;
 121 static GTY(()) tree iocall_x_complex;
 122 static GTY(()) tree iocall_open;
 123 static GTY(()) tree iocall_close;
 124 static GTY(()) tree iocall_inquire;
 125 static GTY(()) tree iocall_iolength;
 126 static GTY(()) tree iocall_iolength_done;
 127 static GTY(()) tree iocall_rewind;
 128 static GTY(()) tree iocall_backspace;
 129 static GTY(()) tree iocall_endfile;
 130 static GTY(()) tree iocall_flush;
 131 static GTY(()) tree iocall_set_nml_val;
 132 static GTY(()) tree iocall_set_nml_val_dim;
 133
 134 /* Variable for keeping track of what the last data transfer statement
 135    was.  Used for deciding which subroutine to call when the data
 136    transfer is complete.  */
 137 static enum { READ, WRITE, IOLENGTH } last_dt;
 138
 139 #define ADD_FIELD(name, type)                                           \
 140   ioparm_ ## name = gfc_add_field_to_struct                             \
 141         (&(TYPE_FIELDS (ioparm_type)), ioparm_type,                     \
 142          get_identifier (stringize(name)), type)
 143
 144 #define ADD_STRING(name) \
 145   ioparm_ ## name = gfc_add_field_to_struct                             \
 146         (&(TYPE_FIELDS (ioparm_type)), ioparm_type,                     \
 147          get_identifier (stringize(name)), pchar_type_node);            \
 148   ioparm_ ## name ## _len = gfc_add_field_to_struct                     \
 149         (&(TYPE_FIELDS (ioparm_type)), ioparm_type,                     \
 150          get_identifier (stringize(name) "_len"), gfc_charlen_type_node)
 151
 152
 153 /* Create function decls for IO library functions.  */
 154
 155 void
 156 gfc_build_io_library_fndecls (void)
 157 {
 158   tree gfc_int4_type_node;
 159   tree gfc_pint4_type_node;
 160   tree ioparm_type;
 161
 162   gfc_int4_type_node = gfc_get_int_type (4);
 163   gfc_pint4_type_node = build_pointer_type (gfc_int4_type_node);
 164
 165   /* Build the st_parameter structure.  Information associated with I/O
 166      calls are transferred here.  This must match the one defined in the
 167      library exactly.  */
 168
 169   ioparm_type = make_node (RECORD_TYPE);
 170   TYPE_NAME (ioparm_type) = get_identifier ("_gfc_ioparm");
 171
 172   ADD_FIELD (unit, gfc_int4_type_node);
 173   ADD_FIELD (err, gfc_int4_type_node);
 174   ADD_FIELD (end, gfc_int4_type_node);
 175   ADD_FIELD (eor, gfc_int4_type_node);
 176   ADD_FIELD (list_format, gfc_int4_type_node);
 177   ADD_FIELD (library_return, gfc_int4_type_node);
 178
 179   ADD_FIELD (iostat, gfc_pint4_type_node);
 180   ADD_FIELD (exist, gfc_pint4_type_node);
 181   ADD_FIELD (opened, gfc_pint4_type_node);
 182   ADD_FIELD (number, gfc_pint4_type_node);
 183   ADD_FIELD (named, gfc_pint4_type_node);
 184   ADD_FIELD (rec, gfc_int4_type_node);
 185   ADD_FIELD (nextrec, gfc_pint4_type_node);
 186   ADD_FIELD (size, gfc_pint4_type_node);
 187
 188   ADD_FIELD (recl_in, gfc_int4_type_node);
 189   ADD_FIELD (recl_out, gfc_pint4_type_node);
 190
 191   ADD_FIELD (iolength, gfc_pint4_type_node);
 192
 193   ADD_STRING (file);
 194   ADD_STRING (status);
 195
 196   ADD_STRING (access);
 197   ADD_STRING (form);
 198   ADD_STRING (blank);
 199   ADD_STRING (position);
 200   ADD_STRING (action);
 201   ADD_STRING (delim);
 202   ADD_STRING (pad);
 203   ADD_STRING (format);
 204   ADD_STRING (advance);
 205   ADD_STRING (name);
 206   ADD_STRING (internal_unit);
 207   ADD_STRING (sequential);
 208
 209   ADD_STRING (direct);
 210   ADD_STRING (formatted);
 211   ADD_STRING (unformatted);
 212   ADD_STRING (read);
 213   ADD_STRING (write);
 214   ADD_STRING (readwrite);
 215
 216   ADD_STRING (namelist_name);
 217   ADD_FIELD (namelist_read_mode, gfc_int4_type_node);
 218   ADD_STRING (iomsg);
 219
 220   gfc_finish_type (ioparm_type);
 221
 222   ioparm_var = build_decl (VAR_DECL, get_identifier (PREFIX("ioparm")),
 223                            ioparm_type);
 224   DECL_EXTERNAL (ioparm_var) = 1;
 225   TREE_PUBLIC (ioparm_var) = 1;
 226
 227   locus_line = build_decl (VAR_DECL, get_identifier (PREFIX("line")),
 228                            gfc_int4_type_node);
 229   DECL_EXTERNAL (locus_line) = 1;
 230   TREE_PUBLIC (locus_line) = 1;
 231
 232   locus_file = build_decl (VAR_DECL, get_identifier (PREFIX("filename")),
 233                            pchar_type_node);
 234   DECL_EXTERNAL (locus_file) = 1;
 235   TREE_PUBLIC (locus_file) = 1;
 236
 237   /* Define the transfer functions.  */
 238
 239   iocall_x_integer =
 240     gfc_build_library_function_decl (get_identifier
 241                                      (PREFIX("transfer_integer")),
 242                                      void_type_node, 2, pvoid_type_node,
 243                                      gfc_int4_type_node);
 244
 245   iocall_x_logical =
 246     gfc_build_library_function_decl (get_identifier
 247                                      (PREFIX("transfer_logical")),
 248                                      void_type_node, 2, pvoid_type_node,
 249                                      gfc_int4_type_node);
 250
 251   iocall_x_character =
 252     gfc_build_library_function_decl (get_identifier
 253                                      (PREFIX("transfer_character")),
 254                                      void_type_node, 2, pvoid_type_node,
 255                                      gfc_int4_type_node);
 256
 257   iocall_x_real =
 258     gfc_build_library_function_decl (get_identifier (PREFIX("transfer_real")),
 259                                      void_type_node, 2,
 260                                      pvoid_type_node, gfc_int4_type_node);
 261
 262   iocall_x_complex =
 263     gfc_build_library_function_decl (get_identifier
 264                                      (PREFIX("transfer_complex")),
 265                                      void_type_node, 2, pvoid_type_node,
 266                                      gfc_int4_type_node);
 267
 268   /* Library entry points */
 269
 270   iocall_read =
 271     gfc_build_library_function_decl (get_identifier (PREFIX("st_read")),
 272                                      void_type_node, 0);
 273
 274   iocall_write =
 275     gfc_build_library_function_decl (get_identifier (PREFIX("st_write")),
 276                                      void_type_node, 0);
 277   iocall_open =
 278     gfc_build_library_function_decl (get_identifier (PREFIX("st_open")),
 279                                      void_type_node, 0);
 280
 281   iocall_close =
 282     gfc_build_library_function_decl (get_identifier (PREFIX("st_close")),
 283                                      void_type_node, 0);
 284
 285   iocall_inquire =
 286     gfc_build_library_function_decl (get_identifier (PREFIX("st_inquire")),
 287                                      gfc_int4_type_node, 0);
 288
 289   iocall_iolength =
 290     gfc_build_library_function_decl(get_identifier (PREFIX("st_iolength")),
 291                                     void_type_node, 0);
 292
 293   iocall_rewind =
 294     gfc_build_library_function_decl (get_identifier (PREFIX("st_rewind")),
 295                                      gfc_int4_type_node, 0);
 296
 297   iocall_backspace =
 298     gfc_build_library_function_decl (get_identifier (PREFIX("st_backspace")),
 299                                      gfc_int4_type_node, 0);
 300
 301   iocall_endfile =
 302     gfc_build_library_function_decl (get_identifier (PREFIX("st_endfile")),
 303                                      gfc_int4_type_node, 0);
 304
 305   iocall_flush =
 306     gfc_build_library_function_decl (get_identifier (PREFIX("st_flush")),
 307                                      gfc_int4_type_node, 0);
 308
 309   /* Library helpers */
 310
 311   iocall_read_done =
 312     gfc_build_library_function_decl (get_identifier (PREFIX("st_read_done")),
 313                                      gfc_int4_type_node, 0);
 314
 315   iocall_write_done =
 316     gfc_build_library_function_decl (get_identifier (PREFIX("st_write_done")),
 317                                      gfc_int4_type_node, 0);
 318
 319   iocall_iolength_done =
 320     gfc_build_library_function_decl (get_identifier (PREFIX("st_iolength_done")),
 321                                      gfc_int4_type_node, 0);
 322
 323
 324   iocall_set_nml_val =
 325     gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var")),
 326                                      void_type_node, 5,
 327                                      pvoid_type_node, pvoid_type_node,
 328                                      gfc_int4_type_node, gfc_charlen_type_node,
 329                                      gfc_int4_type_node);
 330
 331   iocall_set_nml_val_dim =
 332     gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_dim")),
 333                                      void_type_node, 4,
 334                                      gfc_int4_type_node, gfc_int4_type_node,
 335                                      gfc_int4_type_node, gfc_int4_type_node);
 336 }
 337
 338
 339 /* Generate code to store a non-string I/O parameter into the
 340    ioparm structure.  This is a pass by value.  */
 341
 342 static void
 343 set_parameter_value (stmtblock_t * block, tree var, gfc_expr * e)
 344 {
 345   gfc_se se;
 346   tree tmp;
 347
 348   gfc_init_se (&se, NULL);
 349   gfc_conv_expr_type (&se, e, TREE_TYPE (var));
 350   gfc_add_block_to_block (block, &se.pre);
 351
 352   tmp = build3 (COMPONENT_REF, TREE_TYPE (var), ioparm_var, var, NULL_TREE);
 353   gfc_add_modify_expr (block, tmp, se.expr);
 354 }
 355
 356
 357 /* Generate code to store a non-string I/O parameter into the
 358    ioparm structure.  This is pass by reference.  */
 359
 360 static void
 361 set_parameter_ref (stmtblock_t * block, tree var, gfc_expr * e)
 362 {
 363   gfc_se se;
 364   tree tmp;
 365
 366   gfc_init_se (&se, NULL);
 367   se.want_pointer = 1;
 368
 369   gfc_conv_expr_type (&se, e, TREE_TYPE (var));
 370   gfc_add_block_to_block (block, &se.pre);
 371
 372   tmp = build3 (COMPONENT_REF, TREE_TYPE (var), ioparm_var, var, NULL_TREE);
 373   gfc_add_modify_expr (block, tmp, se.expr);
 374 }
 375
 376 /* Given an array expr, find its address and length to get a string. If the
 377    array is full, the string's address is the address of array's first element
 378    and the length is the size of the whole array. If it is an element, the
 379    string's address is the element's address and the length is the rest size of
 380    the array.
 381 */
 382
 383 static void
 384 gfc_convert_array_to_string (gfc_se * se, gfc_expr * e)
 385 {
 386   tree tmp;
 387   tree array;
 388   tree type;
 389   tree size;
 390   int rank;
 391   gfc_symbol *sym;
 392
 393   sym = e->symtree->n.sym;
 394   rank = sym->as->rank - 1;
 395
 396   if (e->ref->u.ar.type == AR_FULL)
 397     {
 398       se->expr = gfc_get_symbol_decl (sym);
 399       se->expr = gfc_conv_array_data (se->expr);
 400     }
 401   else
 402     {
 403       gfc_conv_expr (se, e);
 404     }
 405
 406   array = sym->backend_decl;
 407   type = TREE_TYPE (array);
 408
 409   if (GFC_ARRAY_TYPE_P (type))
 410     size = GFC_TYPE_ARRAY_SIZE (type);
 411   else
 412     {
 413       gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
 414       size = gfc_conv_array_stride (array, rank);
 415       tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
 416                 gfc_conv_array_ubound (array, rank),
 417                 gfc_conv_array_lbound (array, rank));
 418       tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp,
 419                 gfc_index_one_node);
 420       size = fold_build2 (MULT_EXPR, gfc_array_index_type, tmp, size);
 421     }
 422
 423   gcc_assert (size);
 424
 425   /* If it is an element, we need the its address and size of the rest.  */
 426   if (e->ref->u.ar.type == AR_ELEMENT)
 427     {
 428       size = fold_build2 (MINUS_EXPR, gfc_array_index_type, size,
 429                 TREE_OPERAND (se->expr, 1));
 430       se->expr = gfc_build_addr_expr (NULL, se->expr);
 431     }
 432
 433   tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
 434   size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
 435
 436   se->string_length = fold_convert (gfc_charlen_type_node, size);
 437 }
 438
 439 /* Generate code to store a string and its length into the
 440    ioparm structure.  */
 441
 442 static void
 443 set_string (stmtblock_t * block, stmtblock_t * postblock, tree var,
 444             tree var_len, gfc_expr * e)
 445 {
 446   gfc_se se;
 447   tree tmp;
 448   tree msg;
 449   tree io;
 450   tree len;
 451
 452   gfc_init_se (&se, NULL);
 453
 454   io = build3 (COMPONENT_REF, TREE_TYPE (var), ioparm_var, var, NULL_TREE);
 455   len = build3 (COMPONENT_REF, TREE_TYPE (var_len), ioparm_var, var_len,
 456                 NULL_TREE);
 457
 458   /* Integer variable assigned a format label.  */
 459   if (e->ts.type == BT_INTEGER && e->symtree->n.sym->attr.assign == 1)
 460     {
 461       gfc_conv_label_variable (&se, e);
 462       msg =
 463         gfc_build_cstring_const ("Assigned label is not a format label");
 464       tmp = GFC_DECL_STRING_LEN (se.expr);
 465       tmp = build2 (LE_EXPR, boolean_type_node,
 466                     tmp, convert (TREE_TYPE (tmp), integer_minus_one_node));
 467       gfc_trans_runtime_check (tmp, msg, &se.pre);
 468       gfc_add_modify_expr (&se.pre, io,
 469                  fold_convert (TREE_TYPE (io), GFC_DECL_ASSIGN_ADDR (se.expr)));
 470       gfc_add_modify_expr (&se.pre, len, GFC_DECL_STRING_LEN (se.expr));
 471     }
 472   else
 473     {
 474       /* General character.  */
 475       if (e->ts.type == BT_CHARACTER && e->rank == 0)
 476         gfc_conv_expr (&se, e);
 477       /* Array assigned Hollerith constant or character array.  */
 478       else if (e->symtree && (e->symtree->n.sym->as->rank > 0))
 479         gfc_convert_array_to_string (&se, e);
 480       else
 481         gcc_unreachable ();
 482
 483       gfc_conv_string_parameter (&se);
 484       gfc_add_modify_expr (&se.pre, io, fold_convert (TREE_TYPE (io), se.expr));
 485       gfc_add_modify_expr (&se.pre, len, se.string_length);
 486     }
 487
 488   gfc_add_block_to_block (block, &se.pre);
 489   gfc_add_block_to_block (postblock, &se.post);
 490 }
 491
 492
 493 /* Set a member of the ioparm structure to one.  */
 494 static void
 495 set_flag (stmtblock_t *block, tree var)
 496 {
 497   tree tmp, type = TREE_TYPE (var);
 498
 499   tmp = build3 (COMPONENT_REF, type, ioparm_var, var, NULL_TREE);
 500   gfc_add_modify_expr (block, tmp, convert (type, integer_one_node));
 501 }
 502
 503
 504 /* Add a case to a IO-result switch.  */
 505
 506 static void
 507 add_case (int label_value, gfc_st_label * label, stmtblock_t * body)
 508 {
 509   tree tmp, value;
 510
 511   if (label == NULL)
 512     return;                     /* No label, no case */
 513
 514   value = build_int_cst (NULL_TREE, label_value);
 515
 516   /* Make a backend label for this case.  */
 517   tmp = gfc_build_label_decl (NULL_TREE);
 518
 519   /* And the case itself.  */
 520   tmp = build3_v (CASE_LABEL_EXPR, value, NULL_TREE, tmp);
 521   gfc_add_expr_to_block (body, tmp);
 522
 523   /* Jump to the label.  */
 524   tmp = build1_v (GOTO_EXPR, gfc_get_label_decl (label));
 525   gfc_add_expr_to_block (body, tmp);
 526 }
 527
 528
 529 /* Generate a switch statement that branches to the correct I/O
 530    result label.  The last statement of an I/O call stores the
 531    result into a variable because there is often cleanup that
 532    must be done before the switch, so a temporary would have to
 533    be created anyway.  */
 534
 535 static void
 536 io_result (stmtblock_t * block, gfc_st_label * err_label,
 537            gfc_st_label * end_label, gfc_st_label * eor_label)
 538 {
 539   stmtblock_t body;
 540   tree tmp, rc;
 541
 542   /* If no labels are specified, ignore the result instead
 543      of building an empty switch.  */
 544   if (err_label == NULL
 545       && end_label == NULL
 546       && eor_label == NULL)
 547     return;
 548
 549   /* Build a switch statement.  */
 550   gfc_start_block (&body);
 551
 552   /* The label values here must be the same as the values
 553      in the library_return enum in the runtime library */
 554   add_case (1, err_label, &body);
 555   add_case (2, end_label, &body);
 556   add_case (3, eor_label, &body);
 557
 558   tmp = gfc_finish_block (&body);
 559
 560   rc = build3 (COMPONENT_REF, TREE_TYPE (ioparm_library_return), ioparm_var,
 561                ioparm_library_return, NULL_TREE);
 562
 563   tmp = build3_v (SWITCH_EXPR, rc, tmp, NULL_TREE);
 564
 565   gfc_add_expr_to_block (block, tmp);
 566 }
 567
 568
 569 /* Store the current file and line number to variables so that if a
 570    library call goes awry, we can tell the user where the problem is.  */
 571
 572 static void
 573 set_error_locus (stmtblock_t * block, locus * where)
 574 {
 575   gfc_file *f;
 576   tree tmp;
 577   int line;
 578
 579   f = where->lb->file;
 580   tmp = gfc_build_cstring_const (f->filename);
 581
 582   tmp = gfc_build_addr_expr (pchar_type_node, tmp);
 583   gfc_add_modify_expr (block, locus_file, tmp);
 584
 585 #ifdef USE_MAPPED_LOCATION
 586   line = LOCATION_LINE (where->lb->location);
 587 #else
 588   line = where->lb->linenum;
 589 #endif
 590   gfc_add_modify_expr (block, locus_line, build_int_cst (NULL_TREE, line));
 591 }
 592
 593
 594 /* Translate an OPEN statement.  */
 595
 596 tree
 597 gfc_trans_open (gfc_code * code)
 598 {
 599   stmtblock_t block, post_block;
 600   gfc_open *p;
 601   tree tmp;
 602
 603   gfc_init_block (&block);
 604   gfc_init_block (&post_block);
 605
 606   set_error_locus (&block, &code->loc);
 607   p = code->ext.open;
 608
 609   if (p->unit)
 610     set_parameter_value (&block, ioparm_unit, p->unit);
 611
 612   if (p->file)
 613     set_string (&block, &post_block, ioparm_file, ioparm_file_len, p->file);
 614
 615   if (p->status)
 616     set_string (&block, &post_block, ioparm_status,
 617                 ioparm_status_len, p->status);
 618
 619   if (p->access)
 620     set_string (&block, &post_block, ioparm_access,
 621                 ioparm_access_len, p->access);
 622
 623   if (p->form)
 624     set_string (&block, &post_block, ioparm_form, ioparm_form_len, p->form);
 625
 626   if (p->recl)
 627     set_parameter_value (&block, ioparm_recl_in, p->recl);
 628
 629   if (p->blank)
 630     set_string (&block, &post_block, ioparm_blank, ioparm_blank_len,
 631                 p->blank);
 632
 633   if (p->position)
 634     set_string (&block, &post_block, ioparm_position,
 635                 ioparm_position_len, p->position);
 636
 637   if (p->action)
 638     set_string (&block, &post_block, ioparm_action,
 639                 ioparm_action_len, p->action);
 640
 641   if (p->delim)
 642     set_string (&block, &post_block, ioparm_delim, ioparm_delim_len,
 643                 p->delim);
 644
 645   if (p->pad)
 646     set_string (&block, &post_block, ioparm_pad, ioparm_pad_len, p->pad);
 647
 648   if (p->iomsg)
 649     set_string (&block, &post_block, ioparm_iomsg, ioparm_iomsg_len,
 650                 p->iomsg);
 651
 652   if (p->iostat)
 653     set_parameter_ref (&block, ioparm_iostat, p->iostat);
 654
 655   if (p->err)
 656     set_flag (&block, ioparm_err);
 657
 658   tmp = gfc_build_function_call (iocall_open, NULL_TREE);
 659   gfc_add_expr_to_block (&block, tmp);
 660
 661   gfc_add_block_to_block (&block, &post_block);
 662
 663   io_result (&block, p->err, NULL, NULL);
 664
 665   return gfc_finish_block (&block);
 666 }
 667
 668
 669 /* Translate a CLOSE statement.  */
 670
 671 tree
 672 gfc_trans_close (gfc_code * code)
 673 {
 674   stmtblock_t block, post_block;
 675   gfc_close *p;
 676   tree tmp;
 677
 678   gfc_init_block (&block);
 679   gfc_init_block (&post_block);
 680
 681   set_error_locus (&block, &code->loc);
 682   p = code->ext.close;
 683
 684   if (p->unit)
 685     set_parameter_value (&block, ioparm_unit, p->unit);
 686
 687   if (p->status)
 688     set_string (&block, &post_block, ioparm_status,
 689                 ioparm_status_len, p->status);
 690
 691   if (p->iomsg)
 692     set_string (&block, &post_block, ioparm_iomsg, ioparm_iomsg_len,
 693                 p->iomsg);
 694
 695   if (p->iostat)
 696     set_parameter_ref (&block, ioparm_iostat, p->iostat);
 697
 698   if (p->err)
 699     set_flag (&block, ioparm_err);
 700
 701   tmp = gfc_build_function_call (iocall_close, NULL_TREE);
 702   gfc_add_expr_to_block (&block, tmp);
 703
 704   gfc_add_block_to_block (&block, &post_block);
 705
 706   io_result (&block, p->err, NULL, NULL);
 707
 708   return gfc_finish_block (&block);
 709 }
 710
 711
 712 /* Common subroutine for building a file positioning statement.  */
 713
 714 static tree
 715 build_filepos (tree function, gfc_code * code)
 716 {
 717   stmtblock_t block, post_block;
 718   gfc_filepos *p;
 719   tree tmp;
 720
 721   p = code->ext.filepos;
 722
 723   gfc_init_block (&block);
 724   gfc_init_block (&post_block);
 725
 726   set_error_locus (&block, &code->loc);
 727
 728   if (p->unit)
 729     set_parameter_value (&block, ioparm_unit, p->unit);
 730
 731   if (p->iomsg)
 732     set_string (&block, &post_block, ioparm_iomsg, ioparm_iomsg_len,
 733                 p->iomsg);
 734
 735   if (p->iostat)
 736     set_parameter_ref (&block, ioparm_iostat, p->iostat);
 737
 738   if (p->err)
 739     set_flag (&block, ioparm_err);
 740
 741   tmp = gfc_build_function_call (function, NULL);
 742   gfc_add_expr_to_block (&block, tmp);
 743
 744   gfc_add_block_to_block (&block, &post_block);
 745
 746   io_result (&block, p->err, NULL, NULL);
 747
 748   return gfc_finish_block (&block);
 749 }
 750
 751
 752 /* Translate a BACKSPACE statement.  */
 753
 754 tree
 755 gfc_trans_backspace (gfc_code * code)
 756 {
 757
 758   return build_filepos (iocall_backspace, code);
 759 }
 760
 761
 762 /* Translate an ENDFILE statement.  */
 763
 764 tree
 765 gfc_trans_endfile (gfc_code * code)
 766 {
 767
 768   return build_filepos (iocall_endfile, code);
 769 }
 770
 771
 772 /* Translate a REWIND statement.  */
 773
 774 tree
 775 gfc_trans_rewind (gfc_code * code)
 776 {
 777
 778   return build_filepos (iocall_rewind, code);
 779 }
 780
 781
 782 /* Translate a FLUSH statement.  */
 783
 784 tree
 785 gfc_trans_flush (gfc_code * code)
 786 {
 787
 788   return build_filepos (iocall_flush, code);
 789 }
 790
 791
 792 /* Translate the non-IOLENGTH form of an INQUIRE statement.  */
 793
 794 tree
 795 gfc_trans_inquire (gfc_code * code)
 796 {
 797   stmtblock_t block, post_block;
 798   gfc_inquire *p;
 799   tree tmp;
 800
 801   gfc_init_block (&block);
 802   gfc_init_block (&post_block);
 803
 804   set_error_locus (&block, &code->loc);
 805   p = code->ext.inquire;
 806
 807   /* Sanity check.  */
 808   if (p->unit && p->file)
 809     gfc_error ("INQUIRE statement at %L cannot contain both FILE and UNIT specifiers.", &code->loc);
 810
 811   if (p->unit)
 812     set_parameter_value (&block, ioparm_unit, p->unit);
 813
 814   if (p->file)
 815     set_string (&block, &post_block, ioparm_file, ioparm_file_len, p->file);
 816
 817   if (p->iomsg)
 818     set_string (&block, &post_block, ioparm_iomsg, ioparm_iomsg_len,
 819                 p->iomsg);
 820
 821   if (p->iostat)
 822     set_parameter_ref (&block, ioparm_iostat, p->iostat);
 823
 824   if (p->exist)
 825     set_parameter_ref (&block, ioparm_exist, p->exist);
 826
 827   if (p->opened)
 828     set_parameter_ref (&block, ioparm_opened, p->opened);
 829
 830   if (p->number)
 831     set_parameter_ref (&block, ioparm_number, p->number);
 832
 833   if (p->named)
 834     set_parameter_ref (&block, ioparm_named, p->named);
 835
 836   if (p->name)
 837     set_string (&block, &post_block, ioparm_name, ioparm_name_len, p->name);
 838
 839   if (p->access)
 840     set_string (&block, &post_block, ioparm_access,
 841                 ioparm_access_len, p->access);
 842
 843   if (p->sequential)
 844     set_string (&block, &post_block, ioparm_sequential,
 845                 ioparm_sequential_len, p->sequential);
 846
 847   if (p->direct)
 848     set_string (&block, &post_block, ioparm_direct,
 849                 ioparm_direct_len, p->direct);
 850
 851   if (p->form)
 852     set_string (&block, &post_block, ioparm_form, ioparm_form_len, p->form);
 853
 854   if (p->formatted)
 855     set_string (&block, &post_block, ioparm_formatted,
 856                 ioparm_formatted_len, p->formatted);
 857
 858   if (p->unformatted)
 859     set_string (&block, &post_block, ioparm_unformatted,
 860                 ioparm_unformatted_len, p->unformatted);
 861
 862   if (p->recl)
 863     set_parameter_ref (&block, ioparm_recl_out, p->recl);
 864
 865   if (p->nextrec)
 866     set_parameter_ref (&block, ioparm_nextrec, p->nextrec);
 867
 868   if (p->blank)
 869     set_string (&block, &post_block, ioparm_blank, ioparm_blank_len,
 870                 p->blank);
 871
 872   if (p->position)
 873     set_string (&block, &post_block, ioparm_position,
 874                 ioparm_position_len, p->position);
 875
 876   if (p->action)
 877     set_string (&block, &post_block, ioparm_action,
 878                 ioparm_action_len, p->action);
 879
 880   if (p->read)
 881     set_string (&block, &post_block, ioparm_read, ioparm_read_len, p->read);
 882
 883   if (p->write)
 884     set_string (&block, &post_block, ioparm_write,
 885                 ioparm_write_len, p->write);
 886
 887   if (p->readwrite)
 888     set_string (&block, &post_block, ioparm_readwrite,
 889                 ioparm_readwrite_len, p->readwrite);
 890
 891   if (p->delim)
 892     set_string (&block, &post_block, ioparm_delim, ioparm_delim_len,
 893                 p->delim);
 894
 895   if (p->pad)
 896     set_string (&block, &post_block, ioparm_pad, ioparm_pad_len,
 897                 p->pad);
 898
 899   if (p->err)
 900     set_flag (&block, ioparm_err);
 901
 902   tmp = gfc_build_function_call (iocall_inquire, NULL);
 903   gfc_add_expr_to_block (&block, tmp);
 904
 905   gfc_add_block_to_block (&block, &post_block);
 906
 907   io_result (&block, p->err, NULL, NULL);
 908
 909   return gfc_finish_block (&block);
 910 }
 911
 912 static gfc_expr *
 913 gfc_new_nml_name_expr (const char * name)
 914 {
 915    gfc_expr * nml_name;
 916
 917    nml_name = gfc_get_expr();
 918    nml_name->ref = NULL;
 919    nml_name->expr_type = EXPR_CONSTANT;
 920    nml_name->ts.kind = gfc_default_character_kind;
 921    nml_name->ts.type = BT_CHARACTER;
 922    nml_name->value.character.length = strlen(name);
 923    nml_name->value.character.string = gfc_getmem (strlen (name) + 1);
 924    strcpy (nml_name->value.character.string, name);
 925
 926    return nml_name;
 927 }
 928
 929 /* nml_full_name builds up the fully qualified name of a
 930    derived type component. */
 931
 932 static char*
 933 nml_full_name (const char* var_name, const char* cmp_name)
 934 {
 935   int full_name_length;
 936   char * full_name;
 937
 938   full_name_length = strlen (var_name) + strlen (cmp_name) + 1;
 939   full_name = (char*)gfc_getmem (full_name_length + 1);
 940   strcpy (full_name, var_name);
 941   full_name = strcat (full_name, "%");
 942   full_name = strcat (full_name, cmp_name);
 943   return full_name;
 944 }
 945
 946 /* nml_get_addr_expr builds an address expression from the
 947    gfc_symbol or gfc_component backend_decl's. An offset is
 948    provided so that the address of an element of an array of
 949    derived types is returned. This is used in the runtime to
 950    determine that span of the derived type. */
 951
 952 static tree
 953 nml_get_addr_expr (gfc_symbol * sym, gfc_component * c,
 954                    tree base_addr)
 955 {
 956   tree decl = NULL_TREE;
 957   tree tmp;
 958   tree itmp;
 959   int array_flagged;
 960   int dummy_arg_flagged;
 961
 962   if (sym)
 963     {
 964       sym->attr.referenced = 1;
 965       decl = gfc_get_symbol_decl (sym);
 966     }
 967   else
 968     decl = c->backend_decl;
 969
 970   gcc_assert (decl && ((TREE_CODE (decl) == FIELD_DECL
 971                      || TREE_CODE (decl) == VAR_DECL
 972                      || TREE_CODE (decl) == PARM_DECL)
 973                      || TREE_CODE (decl) == COMPONENT_REF));
 974
 975   tmp = decl;
 976
 977   /* Build indirect reference, if dummy argument.  */
 978
 979   dummy_arg_flagged = POINTER_TYPE_P (TREE_TYPE(tmp));
 980
 981   itmp = (dummy_arg_flagged) ? gfc_build_indirect_ref (tmp) : tmp;
 982
 983   /* If an array, set flag and use indirect ref. if built.  */
 984
 985   array_flagged = (TREE_CODE (TREE_TYPE (itmp)) == ARRAY_TYPE
 986                    && !TYPE_STRING_FLAG (TREE_TYPE (itmp)));
 987
 988   if (array_flagged)
 989     tmp = itmp;
 990
 991   /* Treat the component of a derived type, using base_addr for
 992      the derived type.  */
 993
 994   if (TREE_CODE (decl) == FIELD_DECL)
 995     tmp = build3 (COMPONENT_REF, TREE_TYPE (tmp),
 996                   base_addr, tmp, NULL_TREE);
 997
 998   /* If we have a derived type component, a reference to the first
 999      element of the array is built.  This is done so that base_addr,
1000      used in the build of the component reference, always points to
1001      a RECORD_TYPE.  */
1002
1003   if (array_flagged)
1004     tmp = gfc_build_array_ref (tmp, gfc_index_zero_node);
1005
1006   /* Now build the address expression.  */
1007
1008   tmp = gfc_build_addr_expr (NULL, tmp);
1009
1010   /* If scalar dummy, resolve indirect reference now.  */
1011
1012   if (dummy_arg_flagged && !array_flagged)
1013     tmp = gfc_build_indirect_ref (tmp);
1014
1015   gcc_assert (tmp && POINTER_TYPE_P (TREE_TYPE (tmp)));
1016
1017   return tmp;
1018 }
1019
1020 /* For an object VAR_NAME whose base address is BASE_ADDR, generate a
1021    call to iocall_set_nml_val.  For derived type variable, recursively
1022    generate calls to iocall_set_nml_val for each component.  */
1023
1024 #define NML_FIRST_ARG(a) args = gfc_chainon_list (NULL_TREE, a)
1025 #define NML_ADD_ARG(a) args = gfc_chainon_list (args, a)
1026 #define IARG(i) build_int_cst (gfc_array_index_type, i)
1027
1028 static void
1029 transfer_namelist_element (stmtblock_t * block, const char * var_name,
1030                            gfc_symbol * sym, gfc_component * c,
1031                            tree base_addr)
1032 {
1033   gfc_typespec * ts = NULL;
1034   gfc_array_spec * as = NULL;
1035   tree addr_expr = NULL;
1036   tree dt = NULL;
1037   tree string;
1038   tree tmp;
1039   tree args;
1040   tree dtype;
1041   int n_dim;
1042   int itype;
1043   int rank = 0;
1044
1045   gcc_assert (sym || c);
1046
1047   /* Build the namelist object name.  */
1048
1049   string = gfc_build_cstring_const (var_name);
1050   string = gfc_build_addr_expr (pchar_type_node, string);
1051
1052   /* Build ts, as and data address using symbol or component.  */
1053
1054   ts = (sym) ? &sym->ts : &c->ts;
1055   as = (sym) ? sym->as : c->as;
1056
1057   addr_expr = nml_get_addr_expr (sym, c, base_addr);
1058
1059   if (as)
1060     rank = as->rank;
1061
1062   if (rank)
1063     {
1064       dt =  TREE_TYPE ((sym) ? sym->backend_decl : c->backend_decl);
1065       dtype = gfc_get_dtype (dt);
1066     }
1067   else
1068     {
1069       itype = GFC_DTYPE_UNKNOWN;
1070
1071       switch (ts->type)
1072
1073         {
1074         case BT_INTEGER:
1075           itype = GFC_DTYPE_INTEGER;
1076           break;
1077         case BT_LOGICAL:
1078           itype = GFC_DTYPE_LOGICAL;
1079           break;
1080         case BT_REAL:
1081           itype = GFC_DTYPE_REAL;
1082           break;
1083         case BT_COMPLEX:
1084           itype = GFC_DTYPE_COMPLEX;
1085         break;
1086         case BT_DERIVED:
1087           itype = GFC_DTYPE_DERIVED;
1088           break;
1089         case BT_CHARACTER:
1090           itype = GFC_DTYPE_CHARACTER;
1091           break;
1092         default:
1093           gcc_unreachable ();
1094         }
1095
1096       dtype = IARG (itype << GFC_DTYPE_TYPE_SHIFT);
1097     }
1098
1099   /* Build up the arguments for the transfer call.
1100      The call for the scalar part transfers:
1101      (address, name, type, kind or string_length, dtype)  */
1102
1103   NML_FIRST_ARG (addr_expr);
1104   NML_ADD_ARG (string);
1105   NML_ADD_ARG (IARG (ts->kind));
1106
1107   if (ts->type == BT_CHARACTER)
1108     NML_ADD_ARG (ts->cl->backend_decl);
1109   else
1110     NML_ADD_ARG (convert (gfc_charlen_type_node, integer_zero_node));
1111
1112   NML_ADD_ARG (dtype);
1113   tmp = gfc_build_function_call (iocall_set_nml_val, args);
1114   gfc_add_expr_to_block (block, tmp);
1115
1116   /* If the object is an array, transfer rank times:
1117      (null pointer, name, stride, lbound, ubound)  */
1118
1119   for ( n_dim = 0 ; n_dim < rank ; n_dim++ )
1120     {
1121       NML_FIRST_ARG (IARG (n_dim));
1122       NML_ADD_ARG (GFC_TYPE_ARRAY_STRIDE (dt, n_dim));
1123       NML_ADD_ARG (GFC_TYPE_ARRAY_LBOUND (dt, n_dim));
1124       NML_ADD_ARG (GFC_TYPE_ARRAY_UBOUND (dt, n_dim));
1125       tmp = gfc_build_function_call (iocall_set_nml_val_dim, args);
1126       gfc_add_expr_to_block (block, tmp);
1127     }
1128
1129   if (ts->type == BT_DERIVED)
1130     {
1131       gfc_component *cmp;
1132
1133       /* Provide the RECORD_TYPE to build component references.  */
1134
1135       tree expr = gfc_build_indirect_ref (addr_expr);
1136
1137       for (cmp = ts->derived->components; cmp; cmp = cmp->next)
1138         {
1139           char *full_name = nml_full_name (var_name, cmp->name);
1140           transfer_namelist_element (block,
1141                                      full_name,
1142                                      NULL, cmp, expr);
1143           gfc_free (full_name);
1144         }
1145     }
1146 }
1147
1148 #undef IARG
1149 #undef NML_ADD_ARG
1150 #undef NML_FIRST_ARG
1151
1152 /* Create a data transfer statement.  Not all of the fields are valid
1153    for both reading and writing, but improper use has been filtered
1154    out by now.  */
1155
1156 static tree
1157 build_dt (tree * function, gfc_code * code)
1158 {
1159   stmtblock_t block, post_block;
1160   gfc_dt *dt;
1161   tree tmp;
1162   gfc_expr *nmlname;
1163   gfc_namelist *nml;
1164
1165   gfc_init_block (&block);
1166   gfc_init_block (&post_block);
1167
1168   set_error_locus (&block, &code->loc);
1169   dt = code->ext.dt;
1170
1171   gcc_assert (dt != NULL);
1172
1173   if (dt->io_unit)
1174     {
1175       if (dt->io_unit->ts.type == BT_CHARACTER)
1176         {
1177           set_string (&block, &post_block, ioparm_internal_unit,
1178                       ioparm_internal_unit_len, dt->io_unit);
1179         }
1180       else
1181         set_parameter_value (&block, ioparm_unit, dt->io_unit);
1182     }
1183
1184   if (dt->rec)
1185     set_parameter_value (&block, ioparm_rec, dt->rec);
1186
1187   if (dt->advance)
1188     set_string (&block, &post_block, ioparm_advance, ioparm_advance_len,
1189                 dt->advance);
1190
1191   if (dt->format_expr)
1192     set_string (&block, &post_block, ioparm_format, ioparm_format_len,
1193                 dt->format_expr);
1194
1195   if (dt->format_label)
1196     {
1197       if (dt->format_label == &format_asterisk)
1198         set_flag (&block, ioparm_list_format);
1199       else
1200         set_string (&block, &post_block, ioparm_format,
1201                     ioparm_format_len, dt->format_label->format);
1202     }
1203
1204   if (dt->iomsg)
1205     set_string (&block, &post_block, ioparm_iomsg, ioparm_iomsg_len,
1206                 dt->iomsg);
1207
1208   if (dt->iostat)
1209     set_parameter_ref (&block, ioparm_iostat, dt->iostat);
1210
1211   if (dt->size)
1212     set_parameter_ref (&block, ioparm_size, dt->size);
1213
1214   if (dt->err)
1215     set_flag (&block, ioparm_err);
1216
1217   if (dt->eor)
1218     set_flag(&block, ioparm_eor);
1219
1220   if (dt->end)
1221     set_flag(&block, ioparm_end);
1222
1223   if (dt->namelist)
1224     {
1225       if (dt->format_expr || dt->format_label)
1226         gfc_internal_error ("build_dt: format with namelist");
1227
1228       nmlname = gfc_new_nml_name_expr(dt->namelist->name);
1229
1230       set_string (&block, &post_block, ioparm_namelist_name,
1231                   ioparm_namelist_name_len, nmlname);
1232
1233       if (last_dt == READ)
1234         set_flag (&block, ioparm_namelist_read_mode);
1235
1236       for (nml = dt->namelist->namelist; nml; nml = nml->next)
1237         transfer_namelist_element (&block, nml->sym->name, nml->sym,
1238                                    NULL, NULL);
1239     }
1240
1241   tmp = gfc_build_function_call (*function, NULL_TREE);
1242   gfc_add_expr_to_block (&block, tmp);
1243
1244   gfc_add_block_to_block (&block, &post_block);
1245
1246   return gfc_finish_block (&block);
1247 }
1248
1249
1250 /* Translate the IOLENGTH form of an INQUIRE statement.  We treat
1251    this as a third sort of data transfer statement, except that
1252    lengths are summed instead of actually transferring any data.  */
1253
1254 tree
1255 gfc_trans_iolength (gfc_code * code)
1256 {
1257   stmtblock_t block;
1258   gfc_inquire *inq;
1259   tree dt;
1260
1261   gfc_init_block (&block);
1262
1263   set_error_locus (&block, &code->loc);
1264
1265   inq = code->ext.inquire;
1266
1267   /* First check that preconditions are met.  */
1268   gcc_assert (inq != NULL);
1269   gcc_assert (inq->iolength != NULL);
1270
1271   /* Connect to the iolength variable.  */
1272   if (inq->iolength)
1273     set_parameter_ref (&block, ioparm_iolength, inq->iolength);
1274
1275   /* Actual logic.  */
1276   last_dt = IOLENGTH;
1277   dt = build_dt(&iocall_iolength, code);
1278
1279   gfc_add_expr_to_block (&block, dt);
1280
1281   return gfc_finish_block (&block);
1282 }
1283
1284
1285 /* Translate a READ statement.  */
1286
1287 tree
1288 gfc_trans_read (gfc_code * code)
1289 {
1290
1291   last_dt = READ;
1292   return build_dt (&iocall_read, code);
1293 }
1294
1295
1296 /* Translate a WRITE statement */
1297
1298 tree
1299 gfc_trans_write (gfc_code * code)
1300 {
1301
1302   last_dt = WRITE;
1303   return build_dt (&iocall_write, code);
1304 }
1305
1306
1307 /* Finish a data transfer statement.  */
1308
1309 tree
1310 gfc_trans_dt_end (gfc_code * code)
1311 {
1312   tree function, tmp;
1313   stmtblock_t block;
1314
1315   gfc_init_block (&block);
1316
1317   switch (last_dt)
1318     {
1319     case READ:
1320       function = iocall_read_done;
1321       break;
1322
1323     case WRITE:
1324       function = iocall_write_done;
1325       break;
1326
1327     case IOLENGTH:
1328       function = iocall_iolength_done;
1329       break;
1330
1331     default:
1332       gcc_unreachable ();
1333     }
1334
1335   tmp = gfc_build_function_call (function, NULL);
1336   gfc_add_expr_to_block (&block, tmp);
1337
1338   if (last_dt != IOLENGTH)
1339     {
1340       gcc_assert (code->ext.dt != NULL);
1341       io_result (&block, code->ext.dt->err,
1342                  code->ext.dt->end, code->ext.dt->eor);
1343     }
1344
1345   return gfc_finish_block (&block);
1346 }
1347
1348 static void
1349 transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr);
1350
1351 /* Given an array field in a derived type variable, generate the code
1352    for the loop that iterates over array elements, and the code that
1353    accesses those array elements.  Use transfer_expr to generate code
1354    for transferring that element.  Because elements may also be
1355    derived types, transfer_expr and transfer_array_component are mutually
1356    recursive.  */
1357
1358 static tree
1359 transfer_array_component (tree expr, gfc_component * cm)
1360 {
1361   tree tmp;
1362   stmtblock_t body;
1363   stmtblock_t block;
1364   gfc_loopinfo loop;
1365   int n;
1366   gfc_ss *ss;
1367   gfc_se se;
1368
1369   gfc_start_block (&block);
1370   gfc_init_se (&se, NULL);
1371
1372   /* Create and initialize Scalarization Status.  Unlike in
1373      gfc_trans_transfer, we can't simply use gfc_walk_expr to take
1374      care of this task, because we don't have a gfc_expr at hand.
1375      Build one manually, as in gfc_trans_subarray_assign.  */
1376
1377   ss = gfc_get_ss ();
1378   ss->type = GFC_SS_COMPONENT;
1379   ss->expr = NULL;
1380   ss->shape = gfc_get_shape (cm->as->rank);
1381   ss->next = gfc_ss_terminator;
1382   ss->data.info.dimen = cm->as->rank;
1383   ss->data.info.descriptor = expr;
1384   ss->data.info.data = gfc_conv_array_data (expr);
1385   ss->data.info.offset = gfc_conv_array_offset (expr);
1386   for (n = 0; n < cm->as->rank; n++)
1387     {
1388       ss->data.info.dim[n] = n;
1389       ss->data.info.start[n] = gfc_conv_array_lbound (expr, n);
1390       ss->data.info.stride[n] = gfc_index_one_node;
1391
1392       mpz_init (ss->shape[n]);
1393       mpz_sub (ss->shape[n], cm->as->upper[n]->value.integer,
1394                cm->as->lower[n]->value.integer);
1395       mpz_add_ui (ss->shape[n], ss->shape[n], 1);
1396     }
1397
1398   /* Once we got ss, we use scalarizer to create the loop.  */
1399
1400   gfc_init_loopinfo (&loop);
1401   gfc_add_ss_to_loop (&loop, ss);
1402   gfc_conv_ss_startstride (&loop);
1403   gfc_conv_loop_setup (&loop);
1404   gfc_mark_ss_chain_used (ss, 1);
1405   gfc_start_scalarized_body (&loop, &body);
1406
1407   gfc_copy_loopinfo_to_se (&se, &loop);
1408   se.ss = ss;
1409
1410   /* gfc_conv_tmp_array_ref assumes that se.expr contains the array.  */
1411   se.expr = expr;
1412   gfc_conv_tmp_array_ref (&se);
1413
1414   /* Now se.expr contains an element of the array.  Take the address and pass
1415      it to the IO routines.  */
1416   tmp = gfc_build_addr_expr (NULL, se.expr);
1417   transfer_expr (&se, &cm->ts, tmp);
1418
1419   /* We are done now with the loop body.  Wrap up the scalarizer and
1420      return.  */
1421
1422   gfc_add_block_to_block (&body, &se.pre);
1423   gfc_add_block_to_block (&body, &se.post);
1424
1425   gfc_trans_scalarizing_loops (&loop, &body);
1426
1427   gfc_add_block_to_block (&block, &loop.pre);
1428   gfc_add_block_to_block (&block, &loop.post);
1429
1430   for (n = 0; n < cm->as->rank; n++)
1431     mpz_clear (ss->shape[n]);
1432   gfc_free (ss->shape);
1433
1434   gfc_cleanup_loop (&loop);
1435
1436   return gfc_finish_block (&block);
1437 }
1438
1439 /* Generate the call for a scalar transfer node.  */
1440
1441 static void
1442 transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr)
1443 {
1444   tree args, tmp, function, arg2, field, expr;
1445   gfc_component *c;
1446   int kind;
1447
1448   kind = ts->kind;
1449   function = NULL;
1450   arg2 = NULL;
1451
1452   switch (ts->type)
1453     {
1454     case BT_INTEGER:
1455       arg2 = build_int_cst (NULL_TREE, kind);
1456       function = iocall_x_integer;
1457       break;
1458
1459     case BT_REAL:
1460       arg2 = build_int_cst (NULL_TREE, kind);
1461       function = iocall_x_real;
1462       break;
1463
1464     case BT_COMPLEX:
1465       arg2 = build_int_cst (NULL_TREE, kind);
1466       function = iocall_x_complex;
1467       break;
1468
1469     case BT_LOGICAL:
1470       arg2 = build_int_cst (NULL_TREE, kind);
1471       function = iocall_x_logical;
1472       break;
1473
1474     case BT_CHARACTER:
1475       if (se->string_length)
1476         arg2 = se->string_length;
1477       else
1478         {
1479           tmp = gfc_build_indirect_ref (addr_expr);
1480           gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
1481           arg2 = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp)));
1482         }
1483       function = iocall_x_character;
1484       break;
1485
1486     case BT_DERIVED:
1487       /* Recurse into the elements of the derived type.  */
1488       expr = gfc_evaluate_now (addr_expr, &se->pre);
1489       expr = gfc_build_indirect_ref (expr);
1490
1491       for (c = ts->derived->components; c; c = c->next)
1492         {
1493           field = c->backend_decl;
1494           gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
1495
1496           tmp = build3 (COMPONENT_REF, TREE_TYPE (field), expr, field,
1497                         NULL_TREE);
1498
1499           if (c->dimension)
1500             {
1501               tmp = transfer_array_component (tmp, c);
1502               gfc_add_expr_to_block (&se->pre, tmp);
1503             }
1504           else
1505             {
1506               if (!c->pointer)
1507                 tmp = gfc_build_addr_expr (NULL, tmp);
1508               transfer_expr (se, &c->ts, tmp);
1509             }
1510         }
1511       return;
1512
1513     default:
1514       internal_error ("Bad IO basetype (%d)", ts->type);
1515     }
1516
1517   args = gfc_chainon_list (NULL_TREE, addr_expr);
1518   args = gfc_chainon_list (args, arg2);
1519
1520   tmp = gfc_build_function_call (function, args);
1521   gfc_add_expr_to_block (&se->pre, tmp);
1522   gfc_add_block_to_block (&se->pre, &se->post);
1523
1524 }
1525
1526
1527 /* gfc_trans_transfer()-- Translate a TRANSFER code node */
1528
1529 tree
1530 gfc_trans_transfer (gfc_code * code)
1531 {
1532   stmtblock_t block, body;
1533   gfc_loopinfo loop;
1534   gfc_expr *expr;
1535   gfc_ss *ss;
1536   gfc_se se;
1537   tree tmp;
1538
1539   gfc_start_block (&block);
1540
1541   expr = code->expr;
1542   ss = gfc_walk_expr (expr);
1543
1544   gfc_init_se (&se, NULL);
1545
1546   if (ss == gfc_ss_terminator)
1547     gfc_init_block (&body);
1548   else
1549     {
1550       /* Initialize the scalarizer.  */
1551       gfc_init_loopinfo (&loop);
1552       gfc_add_ss_to_loop (&loop, ss);
1553
1554       /* Initialize the loop.  */
1555       gfc_conv_ss_startstride (&loop);
1556       gfc_conv_loop_setup (&loop);
1557
1558       /* The main loop body.  */
1559       gfc_mark_ss_chain_used (ss, 1);
1560       gfc_start_scalarized_body (&loop, &body);
1561
1562       gfc_copy_loopinfo_to_se (&se, &loop);
1563       se.ss = ss;
1564     }
1565
1566   gfc_conv_expr_reference (&se, expr);
1567
1568   transfer_expr (&se, &expr->ts, se.expr);
1569
1570   gfc_add_block_to_block (&body, &se.pre);
1571   gfc_add_block_to_block (&body, &se.post);
1572
1573   if (se.ss == NULL)
1574     tmp = gfc_finish_block (&body);
1575   else
1576     {
1577       gcc_assert (se.ss == gfc_ss_terminator);
1578       gfc_trans_scalarizing_loops (&loop, &body);
1579
1580       gfc_add_block_to_block (&loop.pre, &loop.post);
1581       tmp = gfc_finish_block (&loop.pre);
1582       gfc_cleanup_loop (&loop);
1583     }
1584
1585   gfc_add_expr_to_block (&block, tmp);
1586
1587   return gfc_finish_block (&block);
1588 }
1589
1590 #include "gt-fortran-trans-io.h"
1591