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