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