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