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