gcc/fortran/trans-io.c

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