gcc/fortran/trans-io.c

   1 /* IO Code translation/library interface
   2    Copyright (C) 2002, 2003, 2004 Free Software Foundation, Inc.
   3    Contributed by Paul Brook
   4
   5 This file is part of GCC.
   6
   7 GCC is free software; you can redistribute it and/or modify it under
   8 the terms of the GNU General Public License as published by the Free
   9 Software Foundation; either version 2, or (at your option) any later
  10 version.
  11
  12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
  13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
  14 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  15 for more details.
  16
  17 You should have received a copy of the GNU General Public License
  18 along with GCC; see the file COPYING.  If not, write to the Free
  19 Software Foundation, 59 Temple Place - Suite 330, Boston, MA
  20 02111-1307, USA.  */
  21
  22
  23 #include "config.h"
  24 #include "system.h"
  25 #include "coretypes.h"
  26 #include "tree.h"
  27 #include "tree-gimple.h"
  28 #include <stdio.h>
  29 #include "ggc.h"
  30 #include "toplev.h"
  31 #include "real.h"
  32 #include <gmp.h>
  33 #include "gfortran.h"
  34 #include "trans.h"
  35 #include "trans-stmt.h"
  36 #include "trans-array.h"
  37 #include "trans-types.h"
  38 #include "trans-const.h"
  39
  40
  41 /* Members of the ioparm structure.  */
  42
  43 static GTY(()) tree ioparm_unit;
  44 static GTY(()) tree ioparm_err;
  45 static GTY(()) tree ioparm_end;
  46 static GTY(()) tree ioparm_eor;
  47 static GTY(()) tree ioparm_list_format;
  48 static GTY(()) tree ioparm_library_return;
  49 static GTY(()) tree ioparm_iostat;
  50 static GTY(()) tree ioparm_exist;
  51 static GTY(()) tree ioparm_opened;
  52 static GTY(()) tree ioparm_number;
  53 static GTY(()) tree ioparm_named;
  54 static GTY(()) tree ioparm_rec;
  55 static GTY(()) tree ioparm_nextrec;
  56 static GTY(()) tree ioparm_size;
  57 static GTY(()) tree ioparm_recl_in;
  58 static GTY(()) tree ioparm_recl_out;
  59 static GTY(()) tree ioparm_iolength;
  60 static GTY(()) tree ioparm_file;
  61 static GTY(()) tree ioparm_file_len;
  62 static GTY(()) tree ioparm_status;
  63 static GTY(()) tree ioparm_status_len;
  64 static GTY(()) tree ioparm_access;
  65 static GTY(()) tree ioparm_access_len;
  66 static GTY(()) tree ioparm_form;
  67 static GTY(()) tree ioparm_form_len;
  68 static GTY(()) tree ioparm_blank;
  69 static GTY(()) tree ioparm_blank_len;
  70 static GTY(()) tree ioparm_position;
  71 static GTY(()) tree ioparm_position_len;
  72 static GTY(()) tree ioparm_action;
  73 static GTY(()) tree ioparm_action_len;
  74 static GTY(()) tree ioparm_delim;
  75 static GTY(()) tree ioparm_delim_len;
  76 static GTY(()) tree ioparm_pad;
  77 static GTY(()) tree ioparm_pad_len;
  78 static GTY(()) tree ioparm_format;
  79 static GTY(()) tree ioparm_format_len;
  80 static GTY(()) tree ioparm_advance;
  81 static GTY(()) tree ioparm_advance_len;
  82 static GTY(()) tree ioparm_name;
  83 static GTY(()) tree ioparm_name_len;
  84 static GTY(()) tree ioparm_internal_unit;
  85 static GTY(()) tree ioparm_internal_unit_len;
  86 static GTY(()) tree ioparm_sequential;
  87 static GTY(()) tree ioparm_sequential_len;
  88 static GTY(()) tree ioparm_direct;
  89 static GTY(()) tree ioparm_direct_len;
  90 static GTY(()) tree ioparm_formatted;
  91 static GTY(()) tree ioparm_formatted_len;
  92 static GTY(()) tree ioparm_unformatted;
  93 static GTY(()) tree ioparm_unformatted_len;
  94 static GTY(()) tree ioparm_read;
  95 static GTY(()) tree ioparm_read_len;
  96 static GTY(()) tree ioparm_write;
  97 static GTY(()) tree ioparm_write_len;
  98 static GTY(()) tree ioparm_readwrite;
  99 static GTY(()) tree ioparm_readwrite_len;
 100 static GTY(()) tree ioparm_namelist_name;
 101 static GTY(()) tree ioparm_namelist_name_len;
 102 static GTY(()) tree ioparm_namelist_read_mode;
 103
 104 /* The global I/O variables */
 105
 106 static GTY(()) tree ioparm_var;
 107 static GTY(()) tree locus_file;
 108 static GTY(()) tree locus_line;
 109
 110
 111 /* Library I/O subroutines */
 112
 113 static GTY(()) tree iocall_read;
 114 static GTY(()) tree iocall_read_done;
 115 static GTY(()) tree iocall_write;
 116 static GTY(()) tree iocall_write_done;
 117 static GTY(()) tree iocall_x_integer;
 118 static GTY(()) tree iocall_x_logical;
 119 static GTY(()) tree iocall_x_character;
 120 static GTY(()) tree iocall_x_real;
 121 static GTY(()) tree iocall_x_complex;
 122 static GTY(()) tree iocall_open;
 123 static GTY(()) tree iocall_close;
 124 static GTY(()) tree iocall_inquire;
 125 static GTY(()) tree iocall_iolength;
 126 static GTY(()) tree iocall_iolength_done;
 127 static GTY(()) tree iocall_rewind;
 128 static GTY(()) tree iocall_backspace;
 129 static GTY(()) tree iocall_endfile;
 130 static GTY(()) tree iocall_set_nml_val_int;
 131 static GTY(()) tree iocall_set_nml_val_float;
 132 static GTY(()) tree iocall_set_nml_val_char;
 133 static GTY(()) tree iocall_set_nml_val_complex;
 134 static GTY(()) tree iocall_set_nml_val_log;
 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_int4_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_pint4_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_pint4_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_STRING (sequential);
 210
 211   ADD_STRING (direct);
 212   ADD_STRING (formatted);
 213   ADD_STRING (unformatted);
 214   ADD_STRING (read);
 215   ADD_STRING (write);
 216   ADD_STRING (readwrite);
 217
 218   ADD_STRING (namelist_name);
 219   ADD_FIELD (namelist_read_mode, gfc_int4_type_node);
 220
 221   gfc_finish_type (ioparm_type);
 222
 223   ioparm_var = build_decl (VAR_DECL, get_identifier (PREFIX("ioparm")),
 224                            ioparm_type);
 225   DECL_EXTERNAL (ioparm_var) = 1;
 226   TREE_PUBLIC (ioparm_var) = 1;
 227
 228   locus_line = build_decl (VAR_DECL, get_identifier (PREFIX("line")),
 229                            gfc_int4_type_node);
 230   DECL_EXTERNAL (locus_line) = 1;
 231   TREE_PUBLIC (locus_line) = 1;
 232
 233   locus_file = build_decl (VAR_DECL, get_identifier (PREFIX("filename")),
 234                            pchar_type_node);
 235   DECL_EXTERNAL (locus_file) = 1;
 236   TREE_PUBLIC (locus_file) = 1;
 237
 238   /* Define the transfer functions.  */
 239
 240   iocall_x_integer =
 241     gfc_build_library_function_decl (get_identifier
 242                                      (PREFIX("transfer_integer")),
 243                                      void_type_node, 2, pvoid_type_node,
 244                                      gfc_int4_type_node);
 245
 246   iocall_x_logical =
 247     gfc_build_library_function_decl (get_identifier
 248                                      (PREFIX("transfer_logical")),
 249                                      void_type_node, 2, pvoid_type_node,
 250                                      gfc_int4_type_node);
 251
 252   iocall_x_character =
 253     gfc_build_library_function_decl (get_identifier
 254                                      (PREFIX("transfer_character")),
 255                                      void_type_node, 2, pvoid_type_node,
 256                                      gfc_int4_type_node);
 257
 258   iocall_x_real =
 259     gfc_build_library_function_decl (get_identifier (PREFIX("transfer_real")),
 260                                      void_type_node, 2,
 261                                      pvoid_type_node, gfc_int4_type_node);
 262
 263   iocall_x_complex =
 264     gfc_build_library_function_decl (get_identifier
 265                                      (PREFIX("transfer_complex")),
 266                                      void_type_node, 2, pvoid_type_node,
 267                                      gfc_int4_type_node);
 268
 269   /* Library entry points */
 270
 271   iocall_read =
 272     gfc_build_library_function_decl (get_identifier (PREFIX("st_read")),
 273                                      void_type_node, 0);
 274
 275   iocall_write =
 276     gfc_build_library_function_decl (get_identifier (PREFIX("st_write")),
 277                                      void_type_node, 0);
 278   iocall_open =
 279     gfc_build_library_function_decl (get_identifier (PREFIX("st_open")),
 280                                      void_type_node, 0);
 281
 282   iocall_close =
 283     gfc_build_library_function_decl (get_identifier (PREFIX("st_close")),
 284                                      void_type_node, 0);
 285
 286   iocall_inquire =
 287     gfc_build_library_function_decl (get_identifier (PREFIX("st_inquire")),
 288                                      gfc_int4_type_node, 0);
 289
 290   iocall_iolength =
 291     gfc_build_library_function_decl(get_identifier (PREFIX("st_iolength")),
 292                                     void_type_node, 0);
 293
 294   iocall_rewind =
 295     gfc_build_library_function_decl (get_identifier (PREFIX("st_rewind")),
 296                                      gfc_int4_type_node, 0);
 297
 298   iocall_backspace =
 299     gfc_build_library_function_decl (get_identifier (PREFIX("st_backspace")),
 300                                      gfc_int4_type_node, 0);
 301
 302   iocall_endfile =
 303     gfc_build_library_function_decl (get_identifier (PREFIX("st_endfile")),
 304                                      gfc_int4_type_node, 0);
 305   /* Library helpers */
 306
 307   iocall_read_done =
 308     gfc_build_library_function_decl (get_identifier (PREFIX("st_read_done")),
 309                                      gfc_int4_type_node, 0);
 310
 311   iocall_write_done =
 312     gfc_build_library_function_decl (get_identifier (PREFIX("st_write_done")),
 313                                      gfc_int4_type_node, 0);
 314
 315   iocall_iolength_done =
 316     gfc_build_library_function_decl (get_identifier (PREFIX("st_iolength_done")),
 317                                      gfc_int4_type_node, 0);
 318
 319   iocall_set_nml_val_int =
 320     gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_int")),
 321                                      void_type_node, 4,
 322                                      pvoid_type_node, pvoid_type_node,
 323                                      gfc_int4_type_node,gfc_int4_type_node);
 324
 325   iocall_set_nml_val_float =
 326     gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_float")),
 327                                      void_type_node, 4,
 328                                      pvoid_type_node, pvoid_type_node,
 329                                      gfc_int4_type_node,gfc_int4_type_node);
 330   iocall_set_nml_val_char =
 331     gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_char")),
 332                                      void_type_node, 5,
 333                                      pvoid_type_node, pvoid_type_node,
 334                                      gfc_int4_type_node, gfc_int4_type_node,
 335                                      gfc_charlen_type_node);
 336   iocall_set_nml_val_complex =
 337     gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_complex")),
 338                                      void_type_node, 4,
 339                                      pvoid_type_node, pvoid_type_node,
 340                                      gfc_int4_type_node,gfc_int4_type_node);
 341   iocall_set_nml_val_log =
 342     gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_log")),
 343                                      void_type_node, 4,
 344                                      pvoid_type_node, pvoid_type_node,
 345                                      gfc_int4_type_node,gfc_int4_type_node);
 346
 347 }
 348
 349
 350 /* Generate code to store an non-string I/O parameter into the
 351    ioparm structure.  This is a pass by value.  */
 352
 353 static void
 354 set_parameter_value (stmtblock_t * block, tree var, gfc_expr * e)
 355 {
 356   gfc_se se;
 357   tree tmp;
 358
 359   gfc_init_se (&se, NULL);
 360   gfc_conv_expr_type (&se, e, TREE_TYPE (var));
 361   gfc_add_block_to_block (block, &se.pre);
 362
 363   tmp = build3 (COMPONENT_REF, TREE_TYPE (var), ioparm_var, var, NULL_TREE);
 364   gfc_add_modify_expr (block, tmp, se.expr);
 365 }
 366
 367
 368 /* Generate code to store an non-string I/O parameter into the
 369    ioparm structure.  This is pass by reference.  */
 370
 371 static void
 372 set_parameter_ref (stmtblock_t * block, tree var, gfc_expr * e)
 373 {
 374   gfc_se se;
 375   tree tmp;
 376
 377   gfc_init_se (&se, NULL);
 378   se.want_pointer = 1;
 379
 380   gfc_conv_expr_type (&se, e, TREE_TYPE (var));
 381   gfc_add_block_to_block (block, &se.pre);
 382
 383   tmp = build3 (COMPONENT_REF, TREE_TYPE (var), ioparm_var, var, NULL_TREE);
 384   gfc_add_modify_expr (block, tmp, se.expr);
 385 }
 386
 387
 388 /* Generate code to store a string and its length into the
 389    ioparm structure.  */
 390
 391 static void
 392 set_string (stmtblock_t * block, stmtblock_t * postblock, tree var,
 393             tree var_len, gfc_expr * e)
 394 {
 395   gfc_se se;
 396   tree tmp;
 397   tree msg;
 398   tree io;
 399   tree len;
 400
 401   gfc_init_se (&se, NULL);
 402   gfc_conv_expr (&se, e);
 403
 404   io = build3 (COMPONENT_REF, TREE_TYPE (var), ioparm_var, var, NULL_TREE);
 405   len = build3 (COMPONENT_REF, TREE_TYPE (var_len), ioparm_var, var_len,
 406                 NULL_TREE);
 407
 408   /* Integer variable assigned a format label.  */
 409   if (e->ts.type == BT_INTEGER && e->symtree->n.sym->attr.assign == 1)
 410     {
 411       msg =
 412         gfc_build_string_const (37, "Assigned label is not a format label");
 413       tmp = GFC_DECL_STRING_LEN (se.expr);
 414       tmp = build2 (LE_EXPR, boolean_type_node,
 415                     tmp, convert (TREE_TYPE (tmp), integer_minus_one_node));
 416       gfc_trans_runtime_check (tmp, msg, &se.pre);
 417       gfc_add_modify_expr (&se.pre, io, GFC_DECL_ASSIGN_ADDR (se.expr));
 418       gfc_add_modify_expr (&se.pre, len, GFC_DECL_STRING_LEN (se.expr));
 419     }
 420   else
 421     {
 422       gfc_conv_string_parameter (&se);
 423       gfc_add_modify_expr (&se.pre, io, fold_convert (TREE_TYPE (io), se.expr));
 424       gfc_add_modify_expr (&se.pre, len, se.string_length);
 425     }
 426
 427   gfc_add_block_to_block (block, &se.pre);
 428   gfc_add_block_to_block (postblock, &se.post);
 429
 430 }
 431
 432
 433 /* Set a member of the ioparm structure to one.  */
 434 static void
 435 set_flag (stmtblock_t *block, tree var)
 436 {
 437   tree tmp, type = TREE_TYPE (var);
 438
 439   tmp = build3 (COMPONENT_REF, type, ioparm_var, var, NULL_TREE);
 440   gfc_add_modify_expr (block, tmp, convert (type, integer_one_node));
 441 }
 442
 443
 444 /* Add a case to a IO-result switch.  */
 445
 446 static void
 447 add_case (int label_value, gfc_st_label * label, stmtblock_t * body)
 448 {
 449   tree tmp, value;
 450
 451   if (label == NULL)
 452     return;                     /* No label, no case */
 453
 454   value = build_int_cst (NULL_TREE, label_value);
 455
 456   /* Make a backend label for this case.  */
 457   tmp = build_decl (LABEL_DECL, NULL_TREE, NULL_TREE);
 458   DECL_CONTEXT (tmp) = current_function_decl;
 459
 460   /* And the case itself.  */
 461   tmp = build3_v (CASE_LABEL_EXPR, value, NULL_TREE, tmp);
 462   gfc_add_expr_to_block (body, tmp);
 463
 464   /* Jump to the label.  */
 465   tmp = build1_v (GOTO_EXPR, gfc_get_label_decl (label));
 466   gfc_add_expr_to_block (body, tmp);
 467 }
 468
 469
 470 /* Generate a switch statement that branches to the correct I/O
 471    result label.  The last statement of an I/O call stores the
 472    result into a variable because there is often cleanup that
 473    must be done before the switch, so a temporary would have to
 474    be created anyway.  */
 475
 476 static void
 477 io_result (stmtblock_t * block, gfc_st_label * err_label,
 478            gfc_st_label * end_label, gfc_st_label * eor_label)
 479 {
 480   stmtblock_t body;
 481   tree tmp, rc;
 482
 483   /* If no labels are specified, ignore the result instead
 484      of building an empty switch.  */
 485   if (err_label == NULL
 486       && end_label == NULL
 487       && eor_label == NULL)
 488     return;
 489
 490   /* Build a switch statement.  */
 491   gfc_start_block (&body);
 492
 493   /* The label values here must be the same as the values
 494      in the library_return enum in the runtime library */
 495   add_case (1, err_label, &body);
 496   add_case (2, end_label, &body);
 497   add_case (3, eor_label, &body);
 498
 499   tmp = gfc_finish_block (&body);
 500
 501   rc = build3 (COMPONENT_REF, TREE_TYPE (ioparm_library_return), ioparm_var,
 502                ioparm_library_return, NULL_TREE);
 503
 504   tmp = build3_v (SWITCH_EXPR, rc, tmp, NULL_TREE);
 505
 506   gfc_add_expr_to_block (block, tmp);
 507 }
 508
 509
 510 /* Store the current file and line number to variables so that if a
 511    library call goes awry, we can tell the user where the problem is.  */
 512
 513 static void
 514 set_error_locus (stmtblock_t * block, locus * where)
 515 {
 516   gfc_file *f;
 517   tree tmp;
 518   int line;
 519
 520   f = where->lb->file;
 521   tmp = gfc_build_string_const (strlen (f->filename) + 1, f->filename);
 522
 523   tmp = gfc_build_addr_expr (pchar_type_node, tmp);
 524   gfc_add_modify_expr (block, locus_file, tmp);
 525
 526 #ifdef USE_MAPPED_LOCATION
 527   line = LOCATION_LINE (where->lb->location);
 528 #else
 529   line = where->lb->linenum;
 530 #endif
 531   gfc_add_modify_expr (block, locus_line, build_int_cst (NULL_TREE, line));
 532 }
 533
 534
 535 /* Translate an OPEN statement.  */
 536
 537 tree
 538 gfc_trans_open (gfc_code * code)
 539 {
 540   stmtblock_t block, post_block;
 541   gfc_open *p;
 542   tree tmp;
 543
 544   gfc_init_block (&block);
 545   gfc_init_block (&post_block);
 546
 547   set_error_locus (&block, &code->loc);
 548   p = code->ext.open;
 549
 550   if (p->unit)
 551     set_parameter_value (&block, ioparm_unit, p->unit);
 552
 553   if (p->file)
 554     set_string (&block, &post_block, ioparm_file, ioparm_file_len, p->file);
 555
 556   if (p->status)
 557     set_string (&block, &post_block, ioparm_status,
 558                 ioparm_status_len, p->status);
 559
 560   if (p->access)
 561     set_string (&block, &post_block, ioparm_access,
 562                 ioparm_access_len, p->access);
 563
 564   if (p->form)
 565     set_string (&block, &post_block, ioparm_form, ioparm_form_len, p->form);
 566
 567   if (p->recl)
 568     set_parameter_value (&block, ioparm_recl_in, p->recl);
 569
 570   if (p->blank)
 571     set_string (&block, &post_block, ioparm_blank, ioparm_blank_len,
 572                 p->blank);
 573
 574   if (p->position)
 575     set_string (&block, &post_block, ioparm_position,
 576                 ioparm_position_len, p->position);
 577
 578   if (p->action)
 579     set_string (&block, &post_block, ioparm_action,
 580                 ioparm_action_len, p->action);
 581
 582   if (p->delim)
 583     set_string (&block, &post_block, ioparm_delim, ioparm_delim_len,
 584                 p->delim);
 585
 586   if (p->pad)
 587     set_string (&block, &post_block, ioparm_pad, ioparm_pad_len, p->pad);
 588
 589   if (p->iostat)
 590     set_parameter_ref (&block, ioparm_iostat, p->iostat);
 591
 592   if (p->err)
 593     set_flag (&block, ioparm_err);
 594
 595   tmp = gfc_build_function_call (iocall_open, NULL_TREE);
 596   gfc_add_expr_to_block (&block, tmp);
 597
 598   gfc_add_block_to_block (&block, &post_block);
 599
 600   io_result (&block, p->err, NULL, NULL);
 601
 602   return gfc_finish_block (&block);
 603 }
 604
 605
 606 /* Translate a CLOSE statement.  */
 607
 608 tree
 609 gfc_trans_close (gfc_code * code)
 610 {
 611   stmtblock_t block, post_block;
 612   gfc_close *p;
 613   tree tmp;
 614
 615   gfc_init_block (&block);
 616   gfc_init_block (&post_block);
 617
 618   set_error_locus (&block, &code->loc);
 619   p = code->ext.close;
 620
 621   if (p->unit)
 622     set_parameter_value (&block, ioparm_unit, p->unit);
 623
 624   if (p->status)
 625     set_string (&block, &post_block, ioparm_status,
 626                 ioparm_status_len, p->status);
 627
 628   if (p->iostat)
 629     set_parameter_ref (&block, ioparm_iostat, p->iostat);
 630
 631   if (p->err)
 632     set_flag (&block, ioparm_err);
 633
 634   tmp = gfc_build_function_call (iocall_close, NULL_TREE);
 635   gfc_add_expr_to_block (&block, tmp);
 636
 637   gfc_add_block_to_block (&block, &post_block);
 638
 639   io_result (&block, p->err, NULL, NULL);
 640
 641   return gfc_finish_block (&block);
 642 }
 643
 644
 645 /* Common subroutine for building a file positioning statement.  */
 646
 647 static tree
 648 build_filepos (tree function, gfc_code * code)
 649 {
 650   stmtblock_t block;
 651   gfc_filepos *p;
 652   tree tmp;
 653
 654   p = code->ext.filepos;
 655
 656   gfc_init_block (&block);
 657
 658   set_error_locus (&block, &code->loc);
 659
 660   if (p->unit)
 661     set_parameter_value (&block, ioparm_unit, p->unit);
 662
 663   if (p->iostat)
 664     set_parameter_ref (&block, ioparm_iostat, p->iostat);
 665
 666   if (p->err)
 667     set_flag (&block, ioparm_err);
 668
 669   tmp = gfc_build_function_call (function, NULL);
 670   gfc_add_expr_to_block (&block, tmp);
 671
 672   io_result (&block, p->err, NULL, NULL);
 673
 674   return gfc_finish_block (&block);
 675 }
 676
 677
 678 /* Translate a BACKSPACE statement.  */
 679
 680 tree
 681 gfc_trans_backspace (gfc_code * code)
 682 {
 683
 684   return build_filepos (iocall_backspace, code);
 685 }
 686
 687
 688 /* Translate an ENDFILE statement.  */
 689
 690 tree
 691 gfc_trans_endfile (gfc_code * code)
 692 {
 693
 694   return build_filepos (iocall_endfile, code);
 695 }
 696
 697
 698 /* Translate a REWIND statement.  */
 699
 700 tree
 701 gfc_trans_rewind (gfc_code * code)
 702 {
 703
 704   return build_filepos (iocall_rewind, code);
 705 }
 706
 707
 708 /* Translate the non-IOLENGTH form of an INQUIRE statement.  */
 709
 710 tree
 711 gfc_trans_inquire (gfc_code * code)
 712 {
 713   stmtblock_t block, post_block;
 714   gfc_inquire *p;
 715   tree tmp;
 716
 717   gfc_init_block (&block);
 718   gfc_init_block (&post_block);
 719
 720   set_error_locus (&block, &code->loc);
 721   p = code->ext.inquire;
 722
 723   if (p->unit)
 724     set_parameter_value (&block, ioparm_unit, p->unit);
 725
 726   if (p->file)
 727     set_string (&block, &post_block, ioparm_file, ioparm_file_len, p->file);
 728
 729   if (p->iostat)
 730     set_parameter_ref (&block, ioparm_iostat, p->iostat);
 731
 732   if (p->exist)
 733     set_parameter_ref (&block, ioparm_exist, p->exist);
 734
 735   if (p->opened)
 736     set_parameter_ref (&block, ioparm_opened, p->opened);
 737
 738   if (p->number)
 739     set_parameter_ref (&block, ioparm_number, p->number);
 740
 741   if (p->named)
 742     set_parameter_ref (&block, ioparm_named, p->named);
 743
 744   if (p->name)
 745     set_string (&block, &post_block, ioparm_name, ioparm_name_len, p->name);
 746
 747   if (p->access)
 748     set_string (&block, &post_block, ioparm_access,
 749                 ioparm_access_len, p->access);
 750
 751   if (p->sequential)
 752     set_string (&block, &post_block, ioparm_sequential,
 753                 ioparm_sequential_len, p->sequential);
 754
 755   if (p->direct)
 756     set_string (&block, &post_block, ioparm_direct,
 757                 ioparm_direct_len, p->direct);
 758
 759   if (p->form)
 760     set_string (&block, &post_block, ioparm_form, ioparm_form_len, p->form);
 761
 762   if (p->formatted)
 763     set_string (&block, &post_block, ioparm_formatted,
 764                 ioparm_formatted_len, p->formatted);
 765
 766   if (p->unformatted)
 767     set_string (&block, &post_block, ioparm_unformatted,
 768                 ioparm_unformatted_len, p->unformatted);
 769
 770   if (p->recl)
 771     set_parameter_ref (&block, ioparm_recl_out, p->recl);
 772
 773   if (p->nextrec)
 774     set_parameter_ref (&block, ioparm_nextrec, p->nextrec);
 775
 776   if (p->blank)
 777     set_string (&block, &post_block, ioparm_blank, ioparm_blank_len,
 778                 p->blank);
 779
 780   if (p->position)
 781     set_string (&block, &post_block, ioparm_position,
 782                 ioparm_position_len, p->position);
 783
 784   if (p->action)
 785     set_string (&block, &post_block, ioparm_action,
 786                 ioparm_action_len, p->action);
 787
 788   if (p->read)
 789     set_string (&block, &post_block, ioparm_read, ioparm_read_len, p->read);
 790
 791   if (p->write)
 792     set_string (&block, &post_block, ioparm_write,
 793                 ioparm_write_len, p->write);
 794
 795   if (p->readwrite)
 796     set_string (&block, &post_block, ioparm_readwrite,
 797                 ioparm_readwrite_len, p->readwrite);
 798
 799   if (p->delim)
 800     set_string (&block, &post_block, ioparm_delim, ioparm_delim_len,
 801                 p->delim);
 802
 803   if (p->err)
 804     set_flag (&block, ioparm_err);
 805
 806   tmp = gfc_build_function_call (iocall_inquire, NULL);
 807   gfc_add_expr_to_block (&block, tmp);
 808
 809   gfc_add_block_to_block (&block, &post_block);
 810
 811   io_result (&block, p->err, NULL, NULL);
 812
 813   return gfc_finish_block (&block);
 814 }
 815
 816
 817 static gfc_expr *
 818 gfc_new_nml_name_expr (char * name)
 819 {
 820    gfc_expr * nml_name;
 821    nml_name = gfc_get_expr();
 822    nml_name->ref = NULL;
 823    nml_name->expr_type = EXPR_CONSTANT;
 824    nml_name->ts.kind = gfc_default_character_kind;
 825    nml_name->ts.type = BT_CHARACTER;
 826    nml_name->value.character.length = strlen(name);
 827    nml_name->value.character.string = name;
 828
 829    return nml_name;
 830 }
 831
 832 static gfc_expr *
 833 get_new_var_expr(gfc_symbol * sym)
 834 {
 835   gfc_expr * nml_var;
 836
 837   nml_var = gfc_get_expr();
 838   nml_var->expr_type = EXPR_VARIABLE;
 839   nml_var->ts = sym->ts;
 840   if (sym->as)
 841     nml_var->rank = sym->as->rank;
 842   nml_var->symtree = (gfc_symtree *)gfc_getmem (sizeof (gfc_symtree));
 843   nml_var->symtree->n.sym = sym;
 844   nml_var->where = sym->declared_at;
 845   sym->attr.referenced = 1;
 846
 847   return nml_var;
 848 }
 849
 850 /* For a scalar variable STRING whose address is ADDR_EXPR, generate a
 851    call to iocall_set_nml_val.  For derived type variable, recursively
 852    generate calls to iocall_set_nml_val for each leaf field. The leafs
 853    have no names -- their STRING field is null, and are interpreted by
 854    the run-time library as having only the value, as in the example:
 855
 856    &foo bzz=1,2,3,4,5/
 857
 858    Note that the first output field appears after the name of the
 859    variable, not of the field name.  This causes a little complication
 860    documented below. */
 861
 862 static void
 863 transfer_namelist_element (stmtblock_t * block, gfc_typespec * ts, tree addr_expr,
 864                            tree string, tree string_length)
 865 {
 866   tree tmp, args, arg2;
 867   tree expr;
 868
 869   gcc_assert (POINTER_TYPE_P (TREE_TYPE (addr_expr)));
 870
 871   if (ts->type == BT_DERIVED)
 872     {
 873       gfc_component *c;
 874       expr = gfc_build_indirect_ref (addr_expr);
 875
 876       for (c = ts->derived->components; c; c = c->next)
 877         {
 878           tree field = c->backend_decl;
 879           gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
 880           tmp = build3 (COMPONENT_REF, TREE_TYPE (field),
 881                         expr, field, NULL_TREE);
 882
 883           if (c->dimension)
 884             gfc_todo_error ("NAMELIST IO of array in derived type");
 885           if (!c->pointer)
 886             tmp = gfc_build_addr_expr (NULL, tmp);
 887           transfer_namelist_element (block, &c->ts, tmp, string, string_length);
 888
 889           /* The first output field bears the name of the topmost
 890              derived type variable.  All other fields are anonymous
 891              and appear with nulls in their string and string_length
 892              fields.  After the first use, we set string and
 893              string_length to null. */
 894           string = null_pointer_node;
 895           string_length = integer_zero_node;
 896         }
 897
 898       return;
 899     }
 900
 901   args = gfc_chainon_list (NULL_TREE, addr_expr);
 902   args = gfc_chainon_list (args, string);
 903   args = gfc_chainon_list (args, string_length);
 904   arg2 = build_int_cst (gfc_array_index_type, ts->kind);
 905   args = gfc_chainon_list (args,arg2);
 906
 907   switch (ts->type)
 908     {
 909     case BT_INTEGER:
 910       tmp = gfc_build_function_call (iocall_set_nml_val_int, args);
 911       break;
 912
 913     case BT_CHARACTER:
 914       expr = gfc_build_indirect_ref (addr_expr);
 915       gcc_assert (TREE_CODE (TREE_TYPE (expr)) == ARRAY_TYPE);
 916       args = gfc_chainon_list (args,
 917                                TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (expr))));
 918       tmp = gfc_build_function_call (iocall_set_nml_val_char, args);
 919       break;
 920
 921     case BT_REAL:
 922       tmp = gfc_build_function_call (iocall_set_nml_val_float, args);
 923       break;
 924
 925     case BT_LOGICAL:
 926       tmp = gfc_build_function_call (iocall_set_nml_val_log, args);
 927       break;
 928
 929     case BT_COMPLEX:
 930       tmp = gfc_build_function_call (iocall_set_nml_val_complex, args);
 931       break;
 932
 933     default :
 934       internal_error ("Bad namelist IO basetype (%d)", ts->type);
 935     }
 936
 937   gfc_add_expr_to_block (block, tmp);
 938 }
 939
 940 /* Create a data transfer statement.  Not all of the fields are valid
 941    for both reading and writing, but improper use has been filtered
 942    out by now.  */
 943
 944 static tree
 945 build_dt (tree * function, gfc_code * code)
 946 {
 947   stmtblock_t block, post_block;
 948   gfc_dt *dt;
 949   tree tmp;
 950   gfc_expr *nmlname, *nmlvar;
 951   gfc_namelist *nml;
 952   gfc_se se,se2;
 953
 954   gfc_init_block (&block);
 955   gfc_init_block (&post_block);
 956
 957   set_error_locus (&block, &code->loc);
 958   dt = code->ext.dt;
 959
 960   gcc_assert (dt != NULL);
 961
 962   if (dt->io_unit)
 963     {
 964       if (dt->io_unit->ts.type == BT_CHARACTER)
 965         {
 966           set_string (&block, &post_block, ioparm_internal_unit,
 967                       ioparm_internal_unit_len, dt->io_unit);
 968         }
 969       else
 970         set_parameter_value (&block, ioparm_unit, dt->io_unit);
 971     }
 972
 973   if (dt->rec)
 974     set_parameter_value (&block, ioparm_rec, dt->rec);
 975
 976   if (dt->advance)
 977     set_string (&block, &post_block, ioparm_advance, ioparm_advance_len,
 978                 dt->advance);
 979
 980   if (dt->format_expr)
 981     set_string (&block, &post_block, ioparm_format, ioparm_format_len,
 982                 dt->format_expr);
 983
 984   if (dt->format_label)
 985     {
 986       if (dt->format_label == &format_asterisk)
 987         set_flag (&block, ioparm_list_format);
 988       else
 989         set_string (&block, &post_block, ioparm_format,
 990                     ioparm_format_len, dt->format_label->format);
 991     }
 992
 993   if (dt->iostat)
 994     set_parameter_ref (&block, ioparm_iostat, dt->iostat);
 995
 996   if (dt->size)
 997     set_parameter_ref (&block, ioparm_size, dt->size);
 998
 999   if (dt->err)
1000     set_flag (&block, ioparm_err);
1001
1002   if (dt->eor)
1003     set_flag(&block, ioparm_eor);
1004
1005   if (dt->end)
1006     set_flag(&block, ioparm_end);
1007
1008   if (dt->namelist)
1009     {
1010        if (dt->format_expr || dt->format_label)
1011           fatal_error("A format cannot be specified with a namelist");
1012
1013        nmlname = gfc_new_nml_name_expr(dt->namelist->name);
1014
1015        set_string (&block, &post_block, ioparm_namelist_name,
1016                 ioparm_namelist_name_len, nmlname);
1017
1018        if (last_dt == READ)
1019           set_flag (&block, ioparm_namelist_read_mode);
1020
1021         for (nml = dt->namelist->namelist; nml; nml = nml->next)
1022           {
1023             gfc_init_se (&se, NULL);
1024             gfc_init_se (&se2, NULL);
1025             nmlvar = get_new_var_expr (nml->sym);
1026             nmlname = gfc_new_nml_name_expr (nml->sym->name);
1027             gfc_conv_expr_reference (&se2, nmlname);
1028             gfc_conv_expr_reference (&se, nmlvar);
1029             gfc_evaluate_now (se.expr, &se.pre);
1030
1031             transfer_namelist_element (&block, &nml->sym->ts, se.expr,
1032                                        se2.expr, se2.string_length);
1033           }
1034     }
1035
1036   tmp = gfc_build_function_call (*function, NULL_TREE);
1037   gfc_add_expr_to_block (&block, tmp);
1038
1039   gfc_add_block_to_block (&block, &post_block);
1040
1041   return gfc_finish_block (&block);
1042 }
1043
1044
1045 /* Translate the IOLENGTH form of an INQUIRE statement.  We treat
1046    this as a third sort of data transfer statement, except that
1047    lengths are summed instead of actually transfering any data.  */
1048
1049 tree
1050 gfc_trans_iolength (gfc_code * code)
1051 {
1052   stmtblock_t block;
1053   gfc_inquire *inq;
1054   tree dt;
1055
1056   gfc_init_block (&block);
1057
1058   set_error_locus (&block, &code->loc);
1059
1060   inq = code->ext.inquire;
1061
1062   /* First check that preconditions are met.  */
1063   gcc_assert (inq != NULL);
1064   gcc_assert (inq->iolength != NULL);
1065
1066   /* Connect to the iolength variable.  */
1067   if (inq->iolength)
1068     set_parameter_ref (&block, ioparm_iolength, inq->iolength);
1069
1070   /* Actual logic.  */
1071   last_dt = IOLENGTH;
1072   dt = build_dt(&iocall_iolength, code);
1073
1074   gfc_add_expr_to_block (&block, dt);
1075
1076   return gfc_finish_block (&block);
1077 }
1078
1079
1080 /* Translate a READ statement.  */
1081
1082 tree
1083 gfc_trans_read (gfc_code * code)
1084 {
1085
1086   last_dt = READ;
1087   return build_dt (&iocall_read, code);
1088 }
1089
1090
1091 /* Translate a WRITE statement */
1092
1093 tree
1094 gfc_trans_write (gfc_code * code)
1095 {
1096
1097   last_dt = WRITE;
1098   return build_dt (&iocall_write, code);
1099 }
1100
1101
1102 /* Finish a data transfer statement.  */
1103
1104 tree
1105 gfc_trans_dt_end (gfc_code * code)
1106 {
1107   tree function, tmp;
1108   stmtblock_t block;
1109
1110   gfc_init_block (&block);
1111
1112   switch (last_dt)
1113     {
1114     case READ:
1115       function = iocall_read_done;
1116       break;
1117
1118     case WRITE:
1119       function = iocall_write_done;
1120       break;
1121
1122     case IOLENGTH:
1123       function = iocall_iolength_done;
1124       break;
1125
1126     default:
1127       gcc_unreachable ();
1128     }
1129
1130   tmp = gfc_build_function_call (function, NULL);
1131   gfc_add_expr_to_block (&block, tmp);
1132
1133   if (last_dt != IOLENGTH)
1134     {
1135       gcc_assert (code->ext.dt != NULL);
1136       io_result (&block, code->ext.dt->err,
1137                  code->ext.dt->end, code->ext.dt->eor);
1138     }
1139
1140   return gfc_finish_block (&block);
1141 }
1142
1143
1144 /* Generate the call for a scalar transfer node.  */
1145
1146 static void
1147 transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr)
1148 {
1149   tree args, tmp, function, arg2, field, expr;
1150   gfc_component *c;
1151   int kind;
1152
1153   kind = ts->kind;
1154   function = NULL;
1155   arg2 = NULL;
1156
1157   switch (ts->type)
1158     {
1159     case BT_INTEGER:
1160       arg2 = build_int_cst (NULL_TREE, kind);
1161       function = iocall_x_integer;
1162       break;
1163
1164     case BT_REAL:
1165       arg2 = build_int_cst (NULL_TREE, kind);
1166       function = iocall_x_real;
1167       break;
1168
1169     case BT_COMPLEX:
1170       arg2 = build_int_cst (NULL_TREE, kind);
1171       function = iocall_x_complex;
1172       break;
1173
1174     case BT_LOGICAL:
1175       arg2 = build_int_cst (NULL_TREE, kind);
1176       function = iocall_x_logical;
1177       break;
1178
1179     case BT_CHARACTER:
1180       arg2 = se->string_length;
1181       function = iocall_x_character;
1182       break;
1183
1184     case BT_DERIVED:
1185       expr = gfc_evaluate_now (addr_expr, &se->pre);
1186       expr = gfc_build_indirect_ref (expr);
1187
1188       for (c = ts->derived->components; c; c = c->next)
1189         {
1190           field = c->backend_decl;
1191           gcc_assert (field && TREE_CODE (field) == FIELD_DECL);
1192
1193           tmp = build3 (COMPONENT_REF, TREE_TYPE (field), expr, field,
1194                         NULL_TREE);
1195
1196           if (c->ts.type == BT_CHARACTER)
1197             {
1198               gcc_assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
1199               se->string_length =
1200                 TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp)));
1201             }
1202           if (c->dimension)
1203             gfc_todo_error ("IO of arrays in derived types");
1204           if (!c->pointer)
1205             tmp = gfc_build_addr_expr (NULL, tmp);
1206           transfer_expr (se, &c->ts, tmp);
1207         }
1208       return;
1209
1210     default:
1211       internal_error ("Bad IO basetype (%d)", ts->type);
1212     }
1213
1214   args = gfc_chainon_list (NULL_TREE, addr_expr);
1215   args = gfc_chainon_list (args, arg2);
1216
1217   tmp = gfc_build_function_call (function, args);
1218   gfc_add_expr_to_block (&se->pre, tmp);
1219   gfc_add_block_to_block (&se->pre, &se->post);
1220
1221 }
1222
1223
1224 /* gfc_trans_transfer()-- Translate a TRANSFER code node */
1225
1226 tree
1227 gfc_trans_transfer (gfc_code * code)
1228 {
1229   stmtblock_t block, body;
1230   gfc_loopinfo loop;
1231   gfc_expr *expr;
1232   gfc_ss *ss;
1233   gfc_se se;
1234   tree tmp;
1235
1236   gfc_start_block (&block);
1237
1238   expr = code->expr;
1239   ss = gfc_walk_expr (expr);
1240
1241   gfc_init_se (&se, NULL);
1242
1243   if (ss == gfc_ss_terminator)
1244     gfc_init_block (&body);
1245   else
1246     {
1247       /* Initialize the scalarizer.  */
1248       gfc_init_loopinfo (&loop);
1249       gfc_add_ss_to_loop (&loop, ss);
1250
1251       /* Initialize the loop.  */
1252       gfc_conv_ss_startstride (&loop);
1253       gfc_conv_loop_setup (&loop);
1254
1255       /* The main loop body.  */
1256       gfc_mark_ss_chain_used (ss, 1);
1257       gfc_start_scalarized_body (&loop, &body);
1258
1259       gfc_copy_loopinfo_to_se (&se, &loop);
1260       se.ss = ss;
1261     }
1262
1263   gfc_conv_expr_reference (&se, expr);
1264
1265   transfer_expr (&se, &expr->ts, se.expr);
1266
1267   gfc_add_block_to_block (&body, &se.pre);
1268   gfc_add_block_to_block (&body, &se.post);
1269
1270   if (se.ss == NULL)
1271     tmp = gfc_finish_block (&body);
1272   else
1273     {
1274       gcc_assert (se.ss == gfc_ss_terminator);
1275       gfc_trans_scalarizing_loops (&loop, &body);
1276
1277       gfc_add_block_to_block (&loop.pre, &loop.post);
1278       tmp = gfc_finish_block (&loop.pre);
1279       gfc_cleanup_loop (&loop);
1280     }
1281
1282   gfc_add_expr_to_block (&block, tmp);
1283
1284   return gfc_finish_block (&block);;
1285 }
1286
1287 #include "gt-fortran-trans-io.h"
1288