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 <assert.h>
  33 #include <gmp.h>
  34 #include "gfortran.h"
  35 #include "trans.h"
  36 #include "trans-stmt.h"
  37 #include "trans-array.h"
  38 #include "trans-types.h"
  39 #include "trans-const.h"
  40
  41
  42 static GTY(()) tree gfc_pint4_type_node;
  43
  44 /* Members of the ioparm structure.  */
  45
  46 static GTY(()) tree ioparm_unit;
  47 static GTY(()) tree ioparm_err;
  48 static GTY(()) tree ioparm_end;
  49 static GTY(()) tree ioparm_eor;
  50 static GTY(()) tree ioparm_list_format;
  51 static GTY(()) tree ioparm_library_return;
  52 static GTY(()) tree ioparm_iostat;
  53 static GTY(()) tree ioparm_exist;
  54 static GTY(()) tree ioparm_opened;
  55 static GTY(()) tree ioparm_number;
  56 static GTY(()) tree ioparm_named;
  57 static GTY(()) tree ioparm_rec;
  58 static GTY(()) tree ioparm_nextrec;
  59 static GTY(()) tree ioparm_size;
  60 static GTY(()) tree ioparm_recl_in;
  61 static GTY(()) tree ioparm_recl_out;
  62 static GTY(()) tree ioparm_iolength;
  63 static GTY(()) tree ioparm_file;
  64 static GTY(()) tree ioparm_file_len;
  65 static GTY(()) tree ioparm_status;
  66 static GTY(()) tree ioparm_status_len;
  67 static GTY(()) tree ioparm_access;
  68 static GTY(()) tree ioparm_access_len;
  69 static GTY(()) tree ioparm_form;
  70 static GTY(()) tree ioparm_form_len;
  71 static GTY(()) tree ioparm_blank;
  72 static GTY(()) tree ioparm_blank_len;
  73 static GTY(()) tree ioparm_position;
  74 static GTY(()) tree ioparm_position_len;
  75 static GTY(()) tree ioparm_action;
  76 static GTY(()) tree ioparm_action_len;
  77 static GTY(()) tree ioparm_delim;
  78 static GTY(()) tree ioparm_delim_len;
  79 static GTY(()) tree ioparm_pad;
  80 static GTY(()) tree ioparm_pad_len;
  81 static GTY(()) tree ioparm_format;
  82 static GTY(()) tree ioparm_format_len;
  83 static GTY(()) tree ioparm_advance;
  84 static GTY(()) tree ioparm_advance_len;
  85 static GTY(()) tree ioparm_name;
  86 static GTY(()) tree ioparm_name_len;
  87 static GTY(()) tree ioparm_internal_unit;
  88 static GTY(()) tree ioparm_internal_unit_len;
  89 static GTY(()) tree ioparm_sequential;
  90 static GTY(()) tree ioparm_sequential_len;
  91 static GTY(()) tree ioparm_direct;
  92 static GTY(()) tree ioparm_direct_len;
  93 static GTY(()) tree ioparm_formatted;
  94 static GTY(()) tree ioparm_formatted_len;
  95 static GTY(()) tree ioparm_unformatted;
  96 static GTY(()) tree ioparm_unformatted_len;
  97 static GTY(()) tree ioparm_read;
  98 static GTY(()) tree ioparm_read_len;
  99 static GTY(()) tree ioparm_write;
 100 static GTY(()) tree ioparm_write_len;
 101 static GTY(()) tree ioparm_readwrite;
 102 static GTY(()) tree ioparm_readwrite_len;
 103 static GTY(()) tree ioparm_namelist_name;
 104 static GTY(()) tree ioparm_namelist_name_len;
 105 static GTY(()) tree ioparm_namelist_read_mode;
 106
 107 /* The global I/O variables */
 108
 109 static GTY(()) tree ioparm_var;
 110 static GTY(()) tree locus_file;
 111 static GTY(()) tree locus_line;
 112
 113
 114 /* Library I/O subroutines */
 115
 116 static GTY(()) tree iocall_read;
 117 static GTY(()) tree iocall_read_done;
 118 static GTY(()) tree iocall_write;
 119 static GTY(()) tree iocall_write_done;
 120 static GTY(()) tree iocall_x_integer;
 121 static GTY(()) tree iocall_x_logical;
 122 static GTY(()) tree iocall_x_character;
 123 static GTY(()) tree iocall_x_real;
 124 static GTY(()) tree iocall_x_complex;
 125 static GTY(()) tree iocall_open;
 126 static GTY(()) tree iocall_close;
 127 static GTY(()) tree iocall_inquire;
 128 static GTY(()) tree iocall_iolength;
 129 static GTY(()) tree iocall_iolength_done;
 130 static GTY(()) tree iocall_rewind;
 131 static GTY(()) tree iocall_backspace;
 132 static GTY(()) tree iocall_endfile;
 133 static GTY(()) tree iocall_set_nml_val_int;
 134 static GTY(()) tree iocall_set_nml_val_float;
 135 static GTY(()) tree iocall_set_nml_val_char;
 136 static GTY(()) tree iocall_set_nml_val_complex;
 137 static GTY(()) tree iocall_set_nml_val_log;
 138
 139 /* Variable for keeping track of what the last data transfer statement
 140    was.  Used for deciding which subroutine to call when the data
 141    transfer is complete. */
 142 static enum { READ, WRITE, IOLENGTH } last_dt;
 143
 144 #define ADD_FIELD(name, type)                                           \
 145   ioparm_ ## name = gfc_add_field_to_struct                             \
 146         (&(TYPE_FIELDS (ioparm_type)), ioparm_type,                     \
 147          get_identifier (stringize(name)), type)
 148
 149 #define ADD_STRING(name) \
 150   ioparm_ ## name = gfc_add_field_to_struct                             \
 151         (&(TYPE_FIELDS (ioparm_type)), ioparm_type,                     \
 152          get_identifier (stringize(name)), pchar_type_node);            \
 153   ioparm_ ## name ## _len = gfc_add_field_to_struct                     \
 154         (&(TYPE_FIELDS (ioparm_type)), ioparm_type,                     \
 155          get_identifier (stringize(name) "_len"), gfc_int4_type_node)
 156
 157
 158 /* Create function decls for IO library functions.  */
 159
 160 void
 161 gfc_build_io_library_fndecls (void)
 162 {
 163   tree ioparm_type;
 164
 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, 4,
 333                                      pvoid_type_node, pvoid_type_node,
 334                                      gfc_int4_type_node,gfc_int4_type_node);
 335   iocall_set_nml_val_complex =
 336     gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_complex")),
 337                                      void_type_node, 4,
 338                                      pvoid_type_node, pvoid_type_node,
 339                                      gfc_int4_type_node,gfc_int4_type_node);
 340   iocall_set_nml_val_log =
 341     gfc_build_library_function_decl (get_identifier (PREFIX("st_set_nml_var_log")),
 342                                      void_type_node, 4,
 343                                      pvoid_type_node, pvoid_type_node,
 344                                      gfc_int4_type_node,gfc_int4_type_node);
 345
 346 }
 347
 348
 349 /* Generate code to store an non-string I/O parameter into the
 350    ioparm structure.  This is a pass by value.  */
 351
 352 static void
 353 set_parameter_value (stmtblock_t * block, tree var, gfc_expr * e)
 354 {
 355   gfc_se se;
 356   tree tmp;
 357
 358   gfc_init_se (&se, NULL);
 359   gfc_conv_expr_type (&se, e, TREE_TYPE (var));
 360   gfc_add_block_to_block (block, &se.pre);
 361
 362   tmp = build (COMPONENT_REF, TREE_TYPE (var), ioparm_var, var, NULL_TREE);
 363   gfc_add_modify_expr (block, tmp, se.expr);
 364 }
 365
 366
 367 /* Generate code to store an non-string I/O parameter into the
 368    ioparm structure.  This is pass by reference.  */
 369
 370 static void
 371 set_parameter_ref (stmtblock_t * block, tree var, gfc_expr * e)
 372 {
 373   gfc_se se;
 374   tree tmp;
 375
 376   gfc_init_se (&se, NULL);
 377   se.want_pointer = 1;
 378
 379   gfc_conv_expr_type (&se, e, TREE_TYPE (var));
 380   gfc_add_block_to_block (block, &se.pre);
 381
 382   tmp = build (COMPONENT_REF, TREE_TYPE (var), ioparm_var, var, NULL_TREE);
 383   gfc_add_modify_expr (block, tmp, se.expr);
 384 }
 385
 386
 387 /* Generate code to store a string and its length into the
 388    ioparm structure.  */
 389
 390 static void
 391 set_string (stmtblock_t * block, stmtblock_t * postblock, tree var,
 392             tree var_len, gfc_expr * e)
 393 {
 394   gfc_se se;
 395   tree tmp;
 396   tree msg;
 397   tree io;
 398   tree len;
 399
 400   gfc_init_se (&se, NULL);
 401   gfc_conv_expr (&se, e);
 402
 403   io = build (COMPONENT_REF, TREE_TYPE (var), ioparm_var, var, NULL_TREE);
 404   len = build (COMPONENT_REF, TREE_TYPE (var_len), ioparm_var, var_len,
 405                NULL_TREE);
 406
 407   /* Integer variable assigned a format label.  */
 408   if (e->ts.type == BT_INTEGER && e->symtree->n.sym->attr.assign == 1)
 409     {
 410       msg =
 411         gfc_build_string_const (37, "Assigned label is not a format label");
 412       tmp = GFC_DECL_STRING_LEN (se.expr);
 413       tmp = build (LE_EXPR, boolean_type_node,
 414                    tmp, convert (TREE_TYPE (tmp), integer_minus_one_node));
 415       gfc_trans_runtime_check (tmp, msg, &se.pre);
 416       gfc_add_modify_expr (&se.pre, io, GFC_DECL_ASSIGN_ADDR (se.expr));
 417       gfc_add_modify_expr (&se.pre, len, GFC_DECL_STRING_LEN (se.expr));
 418     }
 419   else
 420     {
 421       gfc_conv_string_parameter (&se);
 422       gfc_add_modify_expr (&se.pre, io, fold_convert (TREE_TYPE (io), se.expr));
 423       gfc_add_modify_expr (&se.pre, len, se.string_length);
 424     }
 425
 426   gfc_add_block_to_block (block, &se.pre);
 427   gfc_add_block_to_block (postblock, &se.post);
 428
 429 }
 430
 431
 432 /* Set a member of the ioparm structure to one.  */
 433 static void
 434 set_flag (stmtblock_t *block, tree var)
 435 {
 436   tree tmp, type = TREE_TYPE (var);
 437
 438   tmp = build (COMPONENT_REF, type, ioparm_var, var, NULL_TREE);
 439   gfc_add_modify_expr (block, tmp, convert (type, integer_one_node));
 440 }
 441
 442
 443 /* Add a case to a IO-result switch.  */
 444
 445 static void
 446 add_case (int label_value, gfc_st_label * label, stmtblock_t * body)
 447 {
 448   tree tmp, value;
 449
 450   if (label == NULL)
 451     return;                     /* No label, no case */
 452
 453   value = build_int_2 (label_value, 0);
 454
 455   /* Make a backend label for this case.  */
 456   tmp = build_decl (LABEL_DECL, NULL_TREE, NULL_TREE);
 457   DECL_CONTEXT (tmp) = current_function_decl;
 458
 459   /* And the case itself.  */
 460   tmp = build_v (CASE_LABEL_EXPR, value, NULL_TREE, tmp);
 461   gfc_add_expr_to_block (body, tmp);
 462
 463   /* Jump to the label.  */
 464   tmp = build1_v (GOTO_EXPR, gfc_get_label_decl (label));
 465   gfc_add_expr_to_block (body, tmp);
 466 }
 467
 468
 469 /* Generate a switch statement that branches to the correct I/O
 470    result label.  The last statement of an I/O call stores the
 471    result into a variable because there is often cleanup that
 472    must be done before the switch, so a temporary would have to
 473    be created anyway.  */
 474
 475 static void
 476 io_result (stmtblock_t * block, gfc_st_label * err_label,
 477            gfc_st_label * end_label, gfc_st_label * eor_label)
 478 {
 479   stmtblock_t body;
 480   tree tmp, rc;
 481
 482   /* If no labels are specified, ignore the result instead
 483      of building an empty switch.  */
 484   if (err_label == NULL
 485       && end_label == NULL
 486       && eor_label == NULL)
 487     return;
 488
 489   /* Build a switch statement.  */
 490   gfc_start_block (&body);
 491
 492   /* The label values here must be the same as the values
 493      in the library_return enum in the runtime library */
 494   add_case (1, err_label, &body);
 495   add_case (2, end_label, &body);
 496   add_case (3, eor_label, &body);
 497
 498   tmp = gfc_finish_block (&body);
 499
 500   rc = build (COMPONENT_REF, TREE_TYPE (ioparm_library_return), ioparm_var,
 501               ioparm_library_return, NULL_TREE);
 502
 503   tmp = build_v (SWITCH_EXPR, rc, tmp, NULL_TREE);
 504
 505   gfc_add_expr_to_block (block, tmp);
 506 }
 507
 508
 509 /* Store the current file and line number to variables so that if a
 510    library call goes awry, we can tell the user where the problem is.  */
 511
 512 static void
 513 set_error_locus (stmtblock_t * block, locus * where)
 514 {
 515   gfc_file *f;
 516   tree tmp;
 517   int line;
 518
 519   f = where->lb->file;
 520   tmp = gfc_build_string_const (strlen (f->filename) + 1, f->filename);
 521
 522   tmp = gfc_build_addr_expr (pchar_type_node, tmp);
 523   gfc_add_modify_expr (block, locus_file, tmp);
 524
 525   line = where->lb->linenum;
 526   gfc_add_modify_expr (block, locus_line, build_int_2 (line, 0));
 527 }
 528
 529
 530 /* Translate an OPEN statement.  */
 531
 532 tree
 533 gfc_trans_open (gfc_code * code)
 534 {
 535   stmtblock_t block, post_block;
 536   gfc_open *p;
 537   tree tmp;
 538
 539   gfc_init_block (&block);
 540   gfc_init_block (&post_block);
 541
 542   set_error_locus (&block, &code->loc);
 543   p = code->ext.open;
 544
 545   if (p->unit)
 546     set_parameter_value (&block, ioparm_unit, p->unit);
 547
 548   if (p->file)
 549     set_string (&block, &post_block, ioparm_file, ioparm_file_len, p->file);
 550
 551   if (p->status)
 552     set_string (&block, &post_block, ioparm_status,
 553                 ioparm_status_len, p->status);
 554
 555   if (p->access)
 556     set_string (&block, &post_block, ioparm_access,
 557                 ioparm_access_len, p->access);
 558
 559   if (p->form)
 560     set_string (&block, &post_block, ioparm_form, ioparm_form_len, p->form);
 561
 562   if (p->recl)
 563     set_parameter_value (&block, ioparm_recl_in, p->recl);
 564
 565   if (p->blank)
 566     set_string (&block, &post_block, ioparm_blank, ioparm_blank_len,
 567                 p->blank);
 568
 569   if (p->position)
 570     set_string (&block, &post_block, ioparm_position,
 571                 ioparm_position_len, p->position);
 572
 573   if (p->action)
 574     set_string (&block, &post_block, ioparm_action,
 575                 ioparm_action_len, p->action);
 576
 577   if (p->delim)
 578     set_string (&block, &post_block, ioparm_delim, ioparm_delim_len,
 579                 p->delim);
 580
 581   if (p->pad)
 582     set_string (&block, &post_block, ioparm_pad, ioparm_pad_len, p->pad);
 583
 584   if (p->iostat)
 585     set_parameter_ref (&block, ioparm_iostat, p->iostat);
 586
 587   if (p->err)
 588     set_flag (&block, ioparm_err);
 589
 590   tmp = gfc_build_function_call (iocall_open, NULL_TREE);
 591   gfc_add_expr_to_block (&block, tmp);
 592
 593   gfc_add_block_to_block (&block, &post_block);
 594
 595   io_result (&block, p->err, NULL, NULL);
 596
 597   return gfc_finish_block (&block);
 598 }
 599
 600
 601 /* Translate a CLOSE statement.  */
 602
 603 tree
 604 gfc_trans_close (gfc_code * code)
 605 {
 606   stmtblock_t block, post_block;
 607   gfc_close *p;
 608   tree tmp;
 609
 610   gfc_init_block (&block);
 611   gfc_init_block (&post_block);
 612
 613   set_error_locus (&block, &code->loc);
 614   p = code->ext.close;
 615
 616   if (p->unit)
 617     set_parameter_value (&block, ioparm_unit, p->unit);
 618
 619   if (p->status)
 620     set_string (&block, &post_block, ioparm_status,
 621                 ioparm_status_len, p->status);
 622
 623   if (p->iostat)
 624     set_parameter_ref (&block, ioparm_iostat, p->iostat);
 625
 626   if (p->err)
 627     set_flag (&block, ioparm_err);
 628
 629   tmp = gfc_build_function_call (iocall_close, NULL_TREE);
 630   gfc_add_expr_to_block (&block, tmp);
 631
 632   gfc_add_block_to_block (&block, &post_block);
 633
 634   io_result (&block, p->err, NULL, NULL);
 635
 636   return gfc_finish_block (&block);
 637 }
 638
 639
 640 /* Common subroutine for building a file positioning statement.  */
 641
 642 static tree
 643 build_filepos (tree function, gfc_code * code)
 644 {
 645   stmtblock_t block;
 646   gfc_filepos *p;
 647   tree tmp;
 648
 649   p = code->ext.filepos;
 650
 651   gfc_init_block (&block);
 652
 653   set_error_locus (&block, &code->loc);
 654
 655   if (p->unit)
 656     set_parameter_value (&block, ioparm_unit, p->unit);
 657
 658   if (p->iostat)
 659     set_parameter_ref (&block, ioparm_iostat, p->iostat);
 660
 661   if (p->err)
 662     set_flag (&block, ioparm_err);
 663
 664   tmp = gfc_build_function_call (function, NULL);
 665   gfc_add_expr_to_block (&block, tmp);
 666
 667   io_result (&block, p->err, NULL, NULL);
 668
 669   return gfc_finish_block (&block);
 670 }
 671
 672
 673 /* Translate a BACKSPACE statement.  */
 674
 675 tree
 676 gfc_trans_backspace (gfc_code * code)
 677 {
 678
 679   return build_filepos (iocall_backspace, code);
 680 }
 681
 682
 683 /* Translate an ENDFILE statement.  */
 684
 685 tree
 686 gfc_trans_endfile (gfc_code * code)
 687 {
 688
 689   return build_filepos (iocall_endfile, code);
 690 }
 691
 692
 693 /* Translate a REWIND statement.  */
 694
 695 tree
 696 gfc_trans_rewind (gfc_code * code)
 697 {
 698
 699   return build_filepos (iocall_rewind, code);
 700 }
 701
 702
 703 /* Translate the non-IOLENGTH form of an INQUIRE statement.  */
 704
 705 tree
 706 gfc_trans_inquire (gfc_code * code)
 707 {
 708   stmtblock_t block, post_block;
 709   gfc_inquire *p;
 710   tree tmp;
 711
 712   gfc_init_block (&block);
 713   gfc_init_block (&post_block);
 714
 715   set_error_locus (&block, &code->loc);
 716   p = code->ext.inquire;
 717
 718   if (p->unit)
 719     set_parameter_value (&block, ioparm_unit, p->unit);
 720
 721   if (p->file)
 722     set_string (&block, &post_block, ioparm_file, ioparm_file_len, p->file);
 723
 724   if (p->iostat)
 725     set_parameter_ref (&block, ioparm_iostat, p->iostat);
 726
 727   if (p->exist)
 728     set_parameter_ref (&block, ioparm_exist, p->exist);
 729
 730   if (p->opened)
 731     set_parameter_ref (&block, ioparm_opened, p->opened);
 732
 733   if (p->number)
 734     set_parameter_ref (&block, ioparm_number, p->number);
 735
 736   if (p->named)
 737     set_parameter_ref (&block, ioparm_named, p->named);
 738
 739   if (p->name)
 740     set_string (&block, &post_block, ioparm_name, ioparm_name_len, p->name);
 741
 742   if (p->access)
 743     set_string (&block, &post_block, ioparm_access,
 744                 ioparm_access_len, p->access);
 745
 746   if (p->sequential)
 747     set_string (&block, &post_block, ioparm_sequential,
 748                 ioparm_sequential_len, p->sequential);
 749
 750   if (p->direct)
 751     set_string (&block, &post_block, ioparm_direct,
 752                 ioparm_direct_len, p->direct);
 753
 754   if (p->form)
 755     set_string (&block, &post_block, ioparm_form, ioparm_form_len, p->form);
 756
 757   if (p->formatted)
 758     set_string (&block, &post_block, ioparm_formatted,
 759                 ioparm_formatted_len, p->formatted);
 760
 761   if (p->unformatted)
 762     set_string (&block, &post_block, ioparm_unformatted,
 763                 ioparm_unformatted_len, p->unformatted);
 764
 765   if (p->recl)
 766     set_parameter_ref (&block, ioparm_recl_out, p->recl);
 767
 768   if (p->nextrec)
 769     set_parameter_ref (&block, ioparm_nextrec, p->nextrec);
 770
 771   if (p->blank)
 772     set_string (&block, &post_block, ioparm_blank, ioparm_blank_len,
 773                 p->blank);
 774
 775   if (p->position)
 776     set_string (&block, &post_block, ioparm_position,
 777                 ioparm_position_len, p->position);
 778
 779   if (p->action)
 780     set_string (&block, &post_block, ioparm_action,
 781                 ioparm_action_len, p->action);
 782
 783   if (p->read)
 784     set_string (&block, &post_block, ioparm_read, ioparm_read_len, p->read);
 785
 786   if (p->write)
 787     set_string (&block, &post_block, ioparm_write,
 788                 ioparm_write_len, p->write);
 789
 790   if (p->readwrite)
 791     set_string (&block, &post_block, ioparm_readwrite,
 792                 ioparm_readwrite_len, p->readwrite);
 793
 794   if (p->delim)
 795     set_string (&block, &post_block, ioparm_delim, ioparm_delim_len,
 796                 p->delim);
 797
 798   if (p->err)
 799     set_flag (&block, ioparm_err);
 800
 801   tmp = gfc_build_function_call (iocall_inquire, NULL);
 802   gfc_add_expr_to_block (&block, tmp);
 803
 804   gfc_add_block_to_block (&block, &post_block);
 805
 806   io_result (&block, p->err, NULL, NULL);
 807
 808   return gfc_finish_block (&block);
 809 }
 810
 811
 812 static gfc_expr *
 813 gfc_new_nml_name_expr (char * name)
 814 {
 815    gfc_expr * nml_name;
 816    nml_name = gfc_get_expr();
 817    nml_name->ref = NULL;
 818    nml_name->expr_type = EXPR_CONSTANT;
 819    nml_name->ts.kind = gfc_default_character_kind ();
 820    nml_name->ts.type = BT_CHARACTER;
 821    nml_name->value.character.length = strlen(name);
 822    nml_name->value.character.string = name;
 823
 824    return nml_name;
 825 }
 826
 827 static gfc_expr *
 828 get_new_var_expr(gfc_symbol * sym)
 829 {
 830   gfc_expr * nml_var;
 831
 832   nml_var = gfc_get_expr();
 833   nml_var->expr_type = EXPR_VARIABLE;
 834   nml_var->ts = sym->ts;
 835   if (sym->as)
 836     nml_var->rank = sym->as->rank;
 837   nml_var->symtree = (gfc_symtree *)gfc_getmem (sizeof (gfc_symtree));
 838   nml_var->symtree->n.sym = sym;
 839   nml_var->where = sym->declared_at;
 840   sym->attr.referenced = 1;
 841
 842   return nml_var;
 843 }
 844
 845
 846 /* Create a data transfer statement.  Not all of the fields are valid
 847    for both reading and writing, but improper use has been filtered
 848    out by now.  */
 849
 850 static tree
 851 build_dt (tree * function, gfc_code * code)
 852 {
 853   stmtblock_t block, post_block;
 854   gfc_dt *dt;
 855   tree tmp, args, arg2;
 856   gfc_expr *nmlname, *nmlvar;
 857   gfc_namelist *nml, *nml_tail;
 858   gfc_se se,se2;
 859   int ts_kind, ts_type, name_len;
 860
 861   gfc_init_block (&block);
 862   gfc_init_block (&post_block);
 863
 864   set_error_locus (&block, &code->loc);
 865   dt = code->ext.dt;
 866
 867   assert (dt != NULL);
 868
 869   if (dt->io_unit)
 870     {
 871       if (dt->io_unit->ts.type == BT_CHARACTER)
 872         {
 873           set_string (&block, &post_block, ioparm_internal_unit,
 874                       ioparm_internal_unit_len, dt->io_unit);
 875         }
 876       else
 877         set_parameter_value (&block, ioparm_unit, dt->io_unit);
 878     }
 879
 880   if (dt->rec)
 881     set_parameter_value (&block, ioparm_rec, dt->rec);
 882
 883   if (dt->advance)
 884     set_string (&block, &post_block, ioparm_advance, ioparm_advance_len,
 885                 dt->advance);
 886
 887   if (dt->format_expr)
 888     set_string (&block, &post_block, ioparm_format, ioparm_format_len,
 889                 dt->format_expr);
 890
 891   if (dt->format_label)
 892     {
 893       if (dt->format_label == &format_asterisk)
 894         set_flag (&block, ioparm_list_format);
 895       else
 896         set_string (&block, &post_block, ioparm_format,
 897                     ioparm_format_len, dt->format_label->format);
 898     }
 899
 900   if (dt->iostat)
 901     set_parameter_ref (&block, ioparm_iostat, dt->iostat);
 902
 903   if (dt->size)
 904     set_parameter_ref (&block, ioparm_size, dt->size);
 905
 906   if (dt->err)
 907     set_flag (&block, ioparm_err);
 908
 909   if (dt->eor)
 910     set_flag(&block, ioparm_eor);
 911
 912   if (dt->end)
 913     set_flag(&block, ioparm_end);
 914
 915   if (dt->namelist)
 916     {
 917        if (dt->format_expr || dt->format_label)
 918           fatal_error("A format cannot be specified with a namelist");
 919
 920        nmlname = gfc_new_nml_name_expr(dt->namelist->name);
 921
 922        set_string (&block, &post_block, ioparm_namelist_name,
 923                 ioparm_namelist_name_len, nmlname);
 924
 925        if (last_dt == READ)
 926           set_flag (&block, ioparm_namelist_read_mode);
 927
 928        nml = dt->namelist->namelist;
 929        nml_tail = dt->namelist->namelist_tail;
 930
 931        while(nml != NULL)
 932        {
 933           gfc_init_se (&se, NULL);
 934           gfc_init_se (&se2, NULL);
 935           nmlvar = get_new_var_expr(nml->sym);
 936           nmlname = gfc_new_nml_name_expr(nml->sym->name);
 937           name_len = strlen(nml->sym->name);
 938           ts_kind = nml->sym->ts.kind;
 939           ts_type = nml->sym->ts.type;
 940
 941           gfc_conv_expr_reference (&se2, nmlname);
 942           gfc_conv_expr_reference (&se, nmlvar);
 943           args = gfc_chainon_list (NULL_TREE, se.expr);
 944           args = gfc_chainon_list (args, se2.expr);
 945           args = gfc_chainon_list (args, se2.string_length);
 946           arg2 = build_int_2 (ts_kind, 0);
 947           args = gfc_chainon_list (args,arg2);
 948           switch (ts_type)
 949             {
 950             case BT_INTEGER:
 951               tmp = gfc_build_function_call (iocall_set_nml_val_int, args);
 952               break;
 953             case BT_CHARACTER:
 954               tmp = gfc_build_function_call (iocall_set_nml_val_char, args);
 955               break;
 956             case BT_REAL:
 957               tmp = gfc_build_function_call (iocall_set_nml_val_float, args);
 958               break;
 959             case BT_LOGICAL:
 960               tmp = gfc_build_function_call (iocall_set_nml_val_log, args);
 961               break;
 962             case BT_COMPLEX:
 963               tmp = gfc_build_function_call (iocall_set_nml_val_complex, args);
 964               break;
 965             default :
 966               internal_error ("Bad namelist IO basetype (%d)", ts_type);
 967             }
 968
 969           gfc_add_expr_to_block (&block, tmp);
 970
 971           nml = nml->next;
 972        }
 973     }
 974
 975   tmp = gfc_build_function_call (*function, NULL_TREE);
 976   gfc_add_expr_to_block (&block, tmp);
 977
 978   gfc_add_block_to_block (&block, &post_block);
 979
 980   return gfc_finish_block (&block);
 981 }
 982
 983
 984 /* Translate the IOLENGTH form of an INQUIRE statement.  We treat
 985    this as a third sort of data transfer statement, except that
 986    lengths are summed instead of actually transfering any data.  */
 987
 988 tree
 989 gfc_trans_iolength (gfc_code * code)
 990 {
 991   stmtblock_t block;
 992   gfc_inquire *inq;
 993   tree dt;
 994
 995   gfc_init_block (&block);
 996
 997   set_error_locus (&block, &code->loc);
 998
 999   inq = code->ext.inquire;
1000
1001   /* First check that preconditions are met.  */
1002   assert(inq != NULL);
1003   assert(inq->iolength != NULL);
1004
1005   /* Connect to the iolength variable.  */
1006   if (inq->iolength)
1007     set_parameter_ref (&block, ioparm_iolength, inq->iolength);
1008
1009   /* Actual logic.  */
1010   last_dt = IOLENGTH;
1011   dt = build_dt(&iocall_iolength, code);
1012
1013   gfc_add_expr_to_block (&block, dt);
1014
1015   return gfc_finish_block (&block);
1016 }
1017
1018
1019 /* Translate a READ statement.  */
1020
1021 tree
1022 gfc_trans_read (gfc_code * code)
1023 {
1024
1025   last_dt = READ;
1026   return build_dt (&iocall_read, code);
1027 }
1028
1029
1030 /* Translate a WRITE statement */
1031
1032 tree
1033 gfc_trans_write (gfc_code * code)
1034 {
1035
1036   last_dt = WRITE;
1037   return build_dt (&iocall_write, code);
1038 }
1039
1040
1041 /* Finish a data transfer statement.  */
1042
1043 tree
1044 gfc_trans_dt_end (gfc_code * code)
1045 {
1046   tree function, tmp;
1047   stmtblock_t block;
1048
1049   gfc_init_block (&block);
1050
1051   switch (last_dt)
1052     {
1053     case READ:
1054       function = iocall_read_done;
1055       break;
1056
1057     case WRITE:
1058       function = iocall_write_done;
1059       break;
1060
1061     case IOLENGTH:
1062       function = iocall_iolength_done;
1063       break;
1064
1065     default:
1066       abort ();
1067     }
1068
1069   tmp = gfc_build_function_call (function, NULL);
1070   gfc_add_expr_to_block (&block, tmp);
1071
1072   if (last_dt != IOLENGTH)
1073     {
1074       assert(code->ext.dt != NULL);
1075       io_result (&block, code->ext.dt->err,
1076                  code->ext.dt->end, code->ext.dt->eor);
1077     }
1078
1079   return gfc_finish_block (&block);
1080 }
1081
1082
1083 /* Generate the call for a scalar transfer node.  */
1084
1085 static void
1086 transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr)
1087 {
1088   tree args, tmp, function, arg2, field, expr;
1089   gfc_component *c;
1090   int kind;
1091
1092   kind = ts->kind;
1093   function = NULL;
1094   arg2 = NULL;
1095
1096   switch (ts->type)
1097     {
1098     case BT_INTEGER:
1099       arg2 = build_int_2 (kind, 0);
1100       function = iocall_x_integer;
1101       break;
1102
1103     case BT_REAL:
1104       arg2 = build_int_2 (kind, 0);
1105       function = iocall_x_real;
1106       break;
1107
1108     case BT_COMPLEX:
1109       arg2 = build_int_2 (kind, 0);
1110       function = iocall_x_complex;
1111       break;
1112
1113     case BT_LOGICAL:
1114       arg2 = build_int_2 (kind, 0);
1115       function = iocall_x_logical;
1116       break;
1117
1118     case BT_CHARACTER:
1119       arg2 = se->string_length;
1120       function = iocall_x_character;
1121       break;
1122
1123     case BT_DERIVED:
1124       expr = gfc_evaluate_now (addr_expr, &se->pre);
1125       expr = gfc_build_indirect_ref (expr);
1126
1127       for (c = ts->derived->components; c; c = c->next)
1128         {
1129           field = c->backend_decl;
1130           assert (field && TREE_CODE (field) == FIELD_DECL);
1131
1132           tmp = build (COMPONENT_REF, TREE_TYPE (field), expr, field,
1133                        NULL_TREE);
1134
1135           if (c->ts.type == BT_CHARACTER)
1136             {
1137               assert (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE);
1138               se->string_length =
1139                 TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (tmp)));
1140             }
1141           transfer_expr (se, &c->ts, gfc_build_addr_expr (NULL, tmp));
1142         }
1143       return;
1144
1145     default:
1146       internal_error ("Bad IO basetype (%d)", ts->type);
1147     }
1148
1149   args = gfc_chainon_list (NULL_TREE, addr_expr);
1150   args = gfc_chainon_list (args, arg2);
1151
1152   tmp = gfc_build_function_call (function, args);
1153   gfc_add_expr_to_block (&se->pre, tmp);
1154   gfc_add_block_to_block (&se->pre, &se->post);
1155
1156 }
1157
1158
1159 /* gfc_trans_transfer()-- Translate a TRANSFER code node */
1160
1161 tree
1162 gfc_trans_transfer (gfc_code * code)
1163 {
1164   stmtblock_t block, body;
1165   gfc_loopinfo loop;
1166   gfc_expr *expr;
1167   gfc_ss *ss;
1168   gfc_se se;
1169   tree tmp;
1170
1171   gfc_start_block (&block);
1172
1173   expr = code->expr;
1174   ss = gfc_walk_expr (expr);
1175
1176   gfc_init_se (&se, NULL);
1177
1178   if (ss == gfc_ss_terminator)
1179     gfc_init_block (&body);
1180   else
1181     {
1182       /* Initialize the scalarizer.  */
1183       gfc_init_loopinfo (&loop);
1184       gfc_add_ss_to_loop (&loop, ss);
1185
1186       /* Initialize the loop.  */
1187       gfc_conv_ss_startstride (&loop);
1188       gfc_conv_loop_setup (&loop);
1189
1190       /* The main loop body.  */
1191       gfc_mark_ss_chain_used (ss, 1);
1192       gfc_start_scalarized_body (&loop, &body);
1193
1194       gfc_copy_loopinfo_to_se (&se, &loop);
1195       se.ss = ss;
1196     }
1197
1198   gfc_conv_expr_reference (&se, expr);
1199
1200   transfer_expr (&se, &expr->ts, se.expr);
1201
1202   gfc_add_block_to_block (&body, &se.pre);
1203   gfc_add_block_to_block (&body, &se.post);
1204
1205   if (se.ss == NULL)
1206     tmp = gfc_finish_block (&body);
1207   else
1208     {
1209       assert (se.ss == gfc_ss_terminator);
1210       gfc_trans_scalarizing_loops (&loop, &body);
1211
1212       gfc_add_block_to_block (&loop.pre, &loop.post);
1213       tmp = gfc_finish_block (&loop.pre);
1214       gfc_cleanup_loop (&loop);
1215     }
1216
1217   gfc_add_expr_to_block (&block, tmp);
1218
1219   return gfc_finish_block (&block);;
1220 }
1221
1222 #include "gt-fortran-trans-io.h"
1223