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