gcc/f/ste.c

   1 /* ste.c -- Implementation File (module.c template V1.0)
   2    Copyright (C) 1995, 1996, 2000 Free Software Foundation, Inc.
   3    Contributed by James Craig Burley.
   4
   5 This file is part of GNU Fortran.
   6
   7 GNU Fortran 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 Fortran 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 Fortran; see the file COPYING.  If not, write to
  19 the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
  20 02111-1307, USA.
  21
  22    Related Modules:
  23       ste.c
  24
  25    Description:
  26       Implements the various statements and such like.
  27
  28    Modifications:
  29 */
  30
  31 /* Include files. */
  32
  33 #include "proj.h"
  34
  35 #if FFECOM_targetCURRENT == FFECOM_targetGCC
  36 #include "rtl.j"
  37 #include "toplev.j"
  38 #include "ggc.j"
  39 #endif
  40
  41 #include "ste.h"
  42 #include "bld.h"
  43 #include "com.h"
  44 #include "expr.h"
  45 #include "lab.h"
  46 #include "lex.h"
  47 #include "sta.h"
  48 #include "stp.h"
  49 #include "str.h"
  50 #include "sts.h"
  51 #include "stt.h"
  52 #include "stv.h"
  53 #include "stw.h"
  54 #include "symbol.h"
  55
  56 /* Externals defined here. */
  57
  58
  59 /* Simple definitions and enumerations. */
  60
  61 typedef enum
  62   {
  63     FFESTE_stateletSIMPLE_,     /* Expecting simple/start. */
  64     FFESTE_stateletATTRIB_,     /* Expecting attrib/item/itemstart. */
  65     FFESTE_stateletITEM_,       /* Expecting item/itemstart/finish. */
  66     FFESTE_stateletITEMVALS_,   /* Expecting itemvalue/itemendvals. */
  67     FFESTE_
  68   } ffesteStatelet_;
  69
  70 /* Internal typedefs. */
  71
  72
  73 /* Private include files. */
  74
  75
  76 /* Internal structure definitions. */
  77
  78
  79 /* Static objects accessed by functions in this module. */
  80
  81 static ffesteStatelet_ ffeste_statelet_ = FFESTE_stateletSIMPLE_;
  82 #if FFECOM_targetCURRENT == FFECOM_targetGCC
  83 static ffelab ffeste_label_formatdef_ = NULL;
  84 static tree (*ffeste_io_driver_) (ffebld expr); /* do?io. */
  85 static ffecomGfrt ffeste_io_endgfrt_;   /* end function to call. */
  86 static tree ffeste_io_abort_;   /* abort-io label or NULL_TREE. */
  87 static bool ffeste_io_abort_is_temp_;   /* abort-io label is a temp. */
  88 static tree ffeste_io_end_;     /* END= label or NULL_TREE. */
  89 static tree ffeste_io_err_;     /* ERR= label or NULL_TREE. */
  90 static tree ffeste_io_iostat_;  /* IOSTAT= var or NULL_TREE. */
  91 static bool ffeste_io_iostat_is_temp_;  /* IOSTAT= var is a temp. */
  92 #endif
  93
  94 /* Static functions (internal). */
  95
  96 #if FFECOM_targetCURRENT == FFECOM_targetGCC
  97 static void ffeste_begin_iterdo_ (ffestw block, tree *tvar, tree *tincr,
  98                                   tree *xitersvar, ffebld var,
  99                                   ffebld start, ffelexToken start_token,
 100                                   ffebld end, ffelexToken end_token,
 101                                   ffebld incr, ffelexToken incr_token,
 102                                   const char *msg);
 103 static void ffeste_end_iterdo_ (ffestw block, tree tvar, tree tincr,
 104                                 tree itersvar);
 105 static void ffeste_io_call_ (tree call, bool do_check);
 106 static void ffeste_io_impdo_ (ffebld impdo, ffelexToken impdo_token);
 107 static tree ffeste_io_dofio_ (ffebld expr);
 108 static tree ffeste_io_dolio_ (ffebld expr);
 109 static tree ffeste_io_douio_ (ffebld expr);
 110 static tree ffeste_io_ialist_ (bool have_err, ffestvUnit unit,
 111                                ffebld unit_expr, int unit_dflt);
 112 static tree ffeste_io_cilist_ (bool have_err, ffestvUnit unit,
 113                                ffebld unit_expr, int unit_dflt,
 114                                bool have_end, ffestvFormat format,
 115                                ffestpFile *format_spec, bool rec,
 116                                ffebld rec_expr);
 117 static tree ffeste_io_cllist_ (bool have_err, ffebld unit_expr,
 118                                ffestpFile *stat_spec);
 119 static tree ffeste_io_icilist_ (bool have_err, ffebld unit_expr,
 120                                 bool have_end, ffestvFormat format,
 121                                 ffestpFile *format_spec);
 122 static tree ffeste_io_inlist_ (bool have_err,
 123                                ffestpFile *unit_spec,
 124                                ffestpFile *file_spec,
 125                                ffestpFile *exist_spec,
 126                                ffestpFile *open_spec,
 127                                ffestpFile *number_spec,
 128                                ffestpFile *named_spec,
 129                                ffestpFile *name_spec,
 130                                ffestpFile *access_spec,
 131                                ffestpFile *sequential_spec,
 132                                ffestpFile *direct_spec,
 133                                ffestpFile *form_spec,
 134                                ffestpFile *formatted_spec,
 135                                ffestpFile *unformatted_spec,
 136                                ffestpFile *recl_spec,
 137                                ffestpFile *nextrec_spec,
 138                                ffestpFile *blank_spec);
 139 static tree ffeste_io_olist_ (bool have_err, ffebld unit_expr,
 140                               ffestpFile *file_spec,
 141                               ffestpFile *stat_spec,
 142                               ffestpFile *access_spec,
 143                               ffestpFile *form_spec,
 144                               ffestpFile *recl_spec,
 145                               ffestpFile *blank_spec);
 146 static void ffeste_subr_beru_ (ffestpBeruStmt *info, ffecomGfrt rt);
 147 #elif FFECOM_targetCURRENT == FFECOM_targetFFE
 148 static void ffeste_subr_file_ (const char *kw, ffestpFile *spec);
 149 #else
 150 #error
 151 #endif
 152
 153 /* Internal macros. */
 154
 155 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 156 #define ffeste_emit_line_note_() \
 157   emit_line_note (input_filename, lineno)
 158 #endif
 159 #define ffeste_check_simple_() \
 160   assert(ffeste_statelet_ == FFESTE_stateletSIMPLE_)
 161 #define ffeste_check_start_() \
 162   assert(ffeste_statelet_ == FFESTE_stateletSIMPLE_); \
 163   ffeste_statelet_ = FFESTE_stateletATTRIB_
 164 #define ffeste_check_attrib_() \
 165   assert(ffeste_statelet_ == FFESTE_stateletATTRIB_)
 166 #define ffeste_check_item_() \
 167   assert(ffeste_statelet_ == FFESTE_stateletATTRIB_      \
 168          || ffeste_statelet_ == FFESTE_stateletITEM_); \
 169   ffeste_statelet_ = FFESTE_stateletITEM_
 170 #define ffeste_check_item_startvals_() \
 171   assert(ffeste_statelet_ == FFESTE_stateletATTRIB_      \
 172          || ffeste_statelet_ == FFESTE_stateletITEM_); \
 173   ffeste_statelet_ = FFESTE_stateletITEMVALS_
 174 #define ffeste_check_item_value_() \
 175   assert(ffeste_statelet_ == FFESTE_stateletITEMVALS_)
 176 #define ffeste_check_item_endvals_() \
 177   assert(ffeste_statelet_ == FFESTE_stateletITEMVALS_); \
 178   ffeste_statelet_ = FFESTE_stateletITEM_
 179 #define ffeste_check_finish_() \
 180   assert(ffeste_statelet_ == FFESTE_stateletATTRIB_      \
 181          || ffeste_statelet_ == FFESTE_stateletITEM_); \
 182   ffeste_statelet_ = FFESTE_stateletSIMPLE_
 183
 184 #define ffeste_f2c_init_charnolen_(Exp,Init,Spec)                             \
 185   do                                                                          \
 186     {                                                                         \
 187       if ((Spec)->kw_or_val_present)                                          \
 188         Exp = ffecom_arg_ptr_to_const_expr ((Spec)->u.expr, &ignore);         \
 189       else                                                                    \
 190         Exp = null_pointer_node;                                              \
 191       if (Exp)                                                                \
 192         Init = Exp;                                                           \
 193       else                                                                    \
 194         {                                                                     \
 195           Init = null_pointer_node;                                           \
 196           constantp = FALSE;                                                  \
 197         }                                                                     \
 198     } while(0)
 199
 200 #define ffeste_f2c_init_char_(Exp,Init,Lenexp,Leninit,Spec)                   \
 201   do                                                                          \
 202     {                                                                         \
 203       if ((Spec)->kw_or_val_present)                                          \
 204         Exp = ffecom_arg_ptr_to_const_expr ((Spec)->u.expr, &Lenexp);         \
 205       else                                                                    \
 206         {                                                                     \
 207           Exp = null_pointer_node;                                            \
 208           Lenexp = ffecom_f2c_ftnlen_zero_node;                               \
 209         }                                                                     \
 210       if (Exp)                                                                \
 211         Init = Exp;                                                           \
 212       else                                                                    \
 213         {                                                                     \
 214           Init = null_pointer_node;                                           \
 215           constantp = FALSE;                                                  \
 216         }                                                                     \
 217       if (Lenexp)                                                             \
 218         Leninit = Lenexp;                                                     \
 219       else                                                                    \
 220         {                                                                     \
 221           Leninit = ffecom_f2c_ftnlen_zero_node;                              \
 222           constantp = FALSE;                                                  \
 223         }                                                                     \
 224     } while(0)
 225
 226 #define ffeste_f2c_init_flag_(Flag,Init)                                      \
 227   do                                                                          \
 228     {                                                                         \
 229       Init = convert (ffecom_f2c_flag_type_node,                              \
 230                       (Flag) ? integer_one_node : integer_zero_node);         \
 231     } while(0)
 232
 233 #define ffeste_f2c_init_format_(Exp,Init,Spec)                                \
 234   do                                                                          \
 235     {                                                                         \
 236       Exp = ffecom_arg_ptr_to_const_expr ((Spec)->u.expr, NULL);              \
 237       if (Exp)                                                                \
 238         Init = Exp;                                                           \
 239       else                                                                    \
 240         {                                                                     \
 241           Init = null_pointer_node;                                           \
 242           constantp = FALSE;                                                  \
 243         }                                                                     \
 244     } while(0)
 245
 246 #define ffeste_f2c_init_int_(Exp,Init,Spec)                                   \
 247   do                                                                          \
 248     {                                                                         \
 249       if ((Spec)->kw_or_val_present)                                          \
 250         Exp = ffecom_const_expr ((Spec)->u.expr);                             \
 251       else                                                                    \
 252         Exp = ffecom_integer_zero_node;                                       \
 253       if (Exp)                                                                \
 254         Init = Exp;                                                           \
 255       else                                                                    \
 256         {                                                                     \
 257           Init = ffecom_integer_zero_node;                                    \
 258           constantp = FALSE;                                                  \
 259         }                                                                     \
 260     } while(0)
 261
 262 #define ffeste_f2c_init_ptrtoint_(Exp,Init,Spec)                              \
 263   do                                                                          \
 264     {                                                                         \
 265       if ((Spec)->kw_or_val_present)                                          \
 266         Exp = ffecom_ptr_to_const_expr ((Spec)->u.expr);                      \
 267       else                                                                    \
 268         Exp = null_pointer_node;                                              \
 269       if (Exp)                                                                \
 270         Init = Exp;                                                           \
 271       else                                                                    \
 272         {                                                                     \
 273           Init = null_pointer_node;                                           \
 274           constantp = FALSE;                                                  \
 275         }                                                                     \
 276     } while(0)
 277
 278 #define ffeste_f2c_init_next_(Init)                                           \
 279   do                                                                          \
 280     {                                                                         \
 281       TREE_CHAIN (initn) = build_tree_list ((field = TREE_CHAIN (field)),     \
 282                                             (Init));                          \
 283       initn = TREE_CHAIN(initn);                                              \
 284     } while(0)
 285
 286 #define ffeste_f2c_prepare_charnolen_(Spec,Exp)                               \
 287   do                                                                          \
 288     {                                                                         \
 289       if (! (Exp))                                                            \
 290         ffecom_prepare_arg_ptr_to_expr ((Spec)->u.expr);                      \
 291     } while(0)
 292
 293 #define ffeste_f2c_prepare_char_(Spec,Exp)                                    \
 294   do                                                                          \
 295     {                                                                         \
 296       if (! (Exp))                                                            \
 297         ffecom_prepare_arg_ptr_to_expr ((Spec)->u.expr);                      \
 298     } while(0)
 299
 300 #define ffeste_f2c_prepare_format_(Spec,Exp)                                  \
 301   do                                                                          \
 302     {                                                                         \
 303       if (! (Exp))                                                            \
 304         ffecom_prepare_arg_ptr_to_expr ((Spec)->u.expr);                      \
 305     } while(0)
 306
 307 #define ffeste_f2c_prepare_int_(Spec,Exp)                                     \
 308   do                                                                          \
 309     {                                                                         \
 310       if (! (Exp))                                                            \
 311         ffecom_prepare_expr ((Spec)->u.expr);                                 \
 312     } while(0)
 313
 314 #define ffeste_f2c_prepare_ptrtoint_(Spec,Exp)                                \
 315   do                                                                          \
 316     {                                                                         \
 317       if (! (Exp))                                                            \
 318         ffecom_prepare_ptr_to_expr ((Spec)->u.expr);                          \
 319     } while(0)
 320
 321 #define ffeste_f2c_compile_(Field,Exp)                                        \
 322   do                                                                          \
 323     {                                                                         \
 324       tree exz;                                                               \
 325       if ((Exp))                                                              \
 326         {                                                                     \
 327           exz = ffecom_modify (void_type_node,                                \
 328                                ffecom_2 (COMPONENT_REF, TREE_TYPE (Field),    \
 329                                          t, (Field)),                         \
 330                                (Exp));                                        \
 331           expand_expr_stmt (exz);                                             \
 332         }                                                                     \
 333     } while(0)
 334
 335 #define ffeste_f2c_compile_charnolen_(Field,Spec,Exp)                         \
 336   do                                                                          \
 337     {                                                                         \
 338       tree exq;                                                               \
 339       if (! (Exp))                                                            \
 340         {                                                                     \
 341           exq = ffecom_arg_ptr_to_expr ((Spec)->u.expr, &ignore);             \
 342           ffeste_f2c_compile_ ((Field), exq);                                 \
 343         }                                                                     \
 344     } while(0)
 345
 346 #define ffeste_f2c_compile_char_(Field,Lenfield,Spec,Exp,Lenexp)              \
 347   do                                                                          \
 348     {                                                                         \
 349       tree exq = (Exp);                                                       \
 350       tree lenexq = (Lenexp);                                                 \
 351       int need_exq = (! exq);                                                 \
 352       int need_lenexq = (! lenexq);                                           \
 353       if (need_exq || need_lenexq)                                            \
 354         {                                                                     \
 355           exq = ffecom_arg_ptr_to_expr ((Spec)->u.expr, &lenexq);             \
 356           if (need_exq)                                                       \
 357             ffeste_f2c_compile_ ((Field), exq);                               \
 358           if (need_lenexq)                                                    \
 359             ffeste_f2c_compile_ ((Lenfield), lenexq);                         \
 360         }                                                                     \
 361     } while(0)
 362
 363 #define ffeste_f2c_compile_format_(Field,Spec,Exp)                            \
 364   do                                                                          \
 365     {                                                                         \
 366       tree exq;                                                               \
 367       if (! (Exp))                                                            \
 368         {                                                                     \
 369           exq = ffecom_arg_ptr_to_expr ((Spec)->u.expr, NULL);                \
 370           ffeste_f2c_compile_ ((Field), exq);                                 \
 371         }                                                                     \
 372     } while(0)
 373
 374 #define ffeste_f2c_compile_int_(Field,Spec,Exp)                               \
 375   do                                                                          \
 376     {                                                                         \
 377       tree exq;                                                               \
 378       if (! (Exp))                                                            \
 379         {                                                                     \
 380           exq = ffecom_expr ((Spec)->u.expr);                                 \
 381           ffeste_f2c_compile_ ((Field), exq);                                 \
 382         }                                                                     \
 383     } while(0)
 384
 385 #define ffeste_f2c_compile_ptrtoint_(Field,Spec,Exp)                          \
 386   do                                                                          \
 387     {                                                                         \
 388       tree exq;                                                               \
 389       if (! (Exp))                                                            \
 390         {                                                                     \
 391           exq = ffecom_ptr_to_expr ((Spec)->u.expr);                          \
 392           ffeste_f2c_compile_ ((Field), exq);                                 \
 393         }                                                                     \
 394     } while(0)
 395 \f
 396 /* Start a Fortran block.  */
 397
 398 #ifdef ENABLE_CHECKING
 399
 400 typedef struct gbe_block
 401 {
 402   struct gbe_block *outer;
 403   ffestw block;
 404   int lineno;
 405   char *input_filename;
 406   bool is_stmt;
 407 } *gbe_block;
 408
 409 gbe_block ffeste_top_block_ = NULL;
 410
 411 static void
 412 ffeste_start_block_ (ffestw block)
 413 {
 414   gbe_block b = xmalloc (sizeof (*b));
 415
 416   b->outer = ffeste_top_block_;
 417   b->block = block;
 418   b->lineno = lineno;
 419   b->input_filename = input_filename;
 420   b->is_stmt = FALSE;
 421
 422   ffeste_top_block_ = b;
 423
 424   ffecom_start_compstmt ();
 425 }
 426
 427 /* End a Fortran block.  */
 428
 429 static void
 430 ffeste_end_block_ (ffestw block)
 431 {
 432   gbe_block b = ffeste_top_block_;
 433
 434   assert (b);
 435   assert (! b->is_stmt);
 436   assert (b->block == block);
 437   assert (! b->is_stmt);
 438
 439   ffeste_top_block_ = b->outer;
 440
 441   free (b);
 442
 443   clear_momentary ();
 444
 445   ffecom_end_compstmt ();
 446 }
 447
 448 /* Start a Fortran statement.
 449
 450    Starts a back-end block, so temporaries can be managed, clean-ups
 451    properly handled, etc.  Nesting of statements *is* allowed -- the
 452    handling of I/O items, even implied-DO I/O lists, within a READ,
 453    PRINT, or WRITE statement is one example.  */
 454
 455 static void
 456 ffeste_start_stmt_(void)
 457 {
 458   gbe_block b = xmalloc (sizeof (*b));
 459
 460   b->outer = ffeste_top_block_;
 461   b->block = NULL;
 462   b->lineno = lineno;
 463   b->input_filename = input_filename;
 464   b->is_stmt = TRUE;
 465
 466   ffeste_top_block_ = b;
 467
 468   ffecom_start_compstmt ();
 469 }
 470
 471 /* End a Fortran statement.  */
 472
 473 static void
 474 ffeste_end_stmt_(void)
 475 {
 476   gbe_block b = ffeste_top_block_;
 477
 478   assert (b);
 479   assert (b->is_stmt);
 480
 481   ffeste_top_block_ = b->outer;
 482
 483   free (b);
 484
 485   clear_momentary ();
 486
 487   ffecom_end_compstmt ();
 488 }
 489
 490 #else  /* ! defined (ENABLE_CHECKING) */
 491
 492 #define ffeste_start_block_(b) ffecom_start_compstmt ()
 493 #define ffeste_end_block_(b)    \
 494   do                            \
 495     {                           \
 496       clear_momentary ();       \
 497       ffecom_end_compstmt ();   \
 498     } while(0)
 499 #define ffeste_start_stmt_() ffeste_start_block_(NULL)
 500 #define ffeste_end_stmt_() ffeste_end_block_(NULL)
 501
 502 #endif  /* ! defined (ENABLE_CHECKING) */
 503
 504 /* Begin an iterative DO loop.  Pass the block to start if applicable.
 505
 506    NOTE: Does _two_ push_momentary () calls, which the caller must
 507    undo (by calling ffeste_end_iterdo_).  */
 508
 509 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 510 static void
 511 ffeste_begin_iterdo_ (ffestw block, tree *xtvar, tree *xtincr,
 512                       tree *xitersvar, ffebld var,
 513                       ffebld start, ffelexToken start_token,
 514                       ffebld end, ffelexToken end_token,
 515                       ffebld incr, ffelexToken incr_token,
 516                       const char *msg)
 517 {
 518   tree tvar;
 519   tree expr;
 520   tree tstart;
 521   tree tend;
 522   tree tincr;
 523   tree tincr_saved;
 524   tree niters;
 525   struct nesting *expanded_loop;
 526
 527   /* Want to have tvar, tincr, and niters for the whole loop body. */
 528
 529   if (block)
 530     ffeste_start_block_ (block);
 531   else
 532     ffeste_start_stmt_ ();
 533
 534   niters = ffecom_make_tempvar (block ? "do" : "impdo",
 535                                 ffecom_integer_type_node,
 536                                 FFETARGET_charactersizeNONE, -1);
 537
 538   ffecom_prepare_expr (incr);
 539   ffecom_prepare_expr_rw (NULL_TREE, var);
 540
 541   ffecom_prepare_end ();
 542
 543   tvar = ffecom_expr_rw (NULL_TREE, var);
 544   tincr = ffecom_expr (incr);
 545
 546   if (TREE_CODE (tvar) == ERROR_MARK
 547       || TREE_CODE (tincr) == ERROR_MARK)
 548     {
 549       if (block)
 550         {
 551           ffeste_end_block_ (block);
 552           ffestw_set_do_tvar (block, error_mark_node);
 553         }
 554       else
 555         {
 556           ffeste_end_stmt_ ();
 557           *xtvar = error_mark_node;
 558         }
 559       return;
 560     }
 561
 562   /* Check whether incr is known to be zero, complain and fix.  */
 563
 564   if (integer_zerop (tincr) || real_zerop (tincr))
 565     {
 566       ffebad_start (FFEBAD_DO_STEP_ZERO);
 567       ffebad_here (0, ffelex_token_where_line (incr_token),
 568                    ffelex_token_where_column (incr_token));
 569       ffebad_string (msg);
 570       ffebad_finish ();
 571       tincr = convert (TREE_TYPE (tvar), integer_one_node);
 572     }
 573
 574   tincr_saved = ffecom_save_tree (tincr);
 575
 576   preserve_momentary ();
 577
 578   /* Want to have tstart, tend for just this statement. */
 579
 580   ffeste_start_stmt_ ();
 581
 582   ffecom_prepare_expr (start);
 583   ffecom_prepare_expr (end);
 584
 585   ffecom_prepare_end ();
 586
 587   tstart = ffecom_expr (start);
 588   tend = ffecom_expr (end);
 589
 590   if (TREE_CODE (tstart) == ERROR_MARK
 591       || TREE_CODE (tend) == ERROR_MARK)
 592     {
 593       ffeste_end_stmt_ ();
 594
 595       if (block)
 596         {
 597           ffeste_end_block_ (block);
 598           ffestw_set_do_tvar (block, error_mark_node);
 599         }
 600       else
 601         {
 602           ffeste_end_stmt_ ();
 603           *xtvar = error_mark_node;
 604         }
 605       return;
 606     }
 607
 608   /* For warnings only, nothing else happens here.  */
 609   {
 610     tree try;
 611
 612     if (! ffe_is_onetrip ())
 613       {
 614         try = ffecom_2 (MINUS_EXPR, TREE_TYPE (tvar),
 615                         tend,
 616                         tstart);
 617
 618         try = ffecom_2 (PLUS_EXPR, TREE_TYPE (tvar),
 619                         try,
 620                         tincr);
 621
 622         if (TREE_CODE (TREE_TYPE (tvar)) != REAL_TYPE)
 623           try = ffecom_2 (TRUNC_DIV_EXPR, integer_type_node, try,
 624                           tincr);
 625         else
 626           try = convert (integer_type_node,
 627                          ffecom_2 (RDIV_EXPR, TREE_TYPE (tvar),
 628                                    try,
 629                                    tincr));
 630
 631         /* Warn if loop never executed, since we've done the evaluation
 632            of the unofficial iteration count already.  */
 633
 634         try = ffecom_truth_value (ffecom_2 (LE_EXPR, integer_type_node,
 635                                             try,
 636                                             convert (TREE_TYPE (tvar),
 637                                                      integer_zero_node)));
 638
 639         if (integer_onep (try))
 640           {
 641             ffebad_start (FFEBAD_DO_NULL);
 642             ffebad_here (0, ffelex_token_where_line (start_token),
 643                          ffelex_token_where_column (start_token));
 644             ffebad_string (msg);
 645             ffebad_finish ();
 646           }
 647       }
 648
 649     /* Warn if end plus incr would overflow.  */
 650
 651     try = ffecom_2 (PLUS_EXPR, TREE_TYPE (tvar),
 652                     tend,
 653                     tincr);
 654
 655     if ((TREE_CODE_CLASS (TREE_CODE (try)) == 'c')
 656         && TREE_CONSTANT_OVERFLOW (try))
 657       {
 658         ffebad_start (FFEBAD_DO_END_OVERFLOW);
 659         ffebad_here (0, ffelex_token_where_line (end_token),
 660                      ffelex_token_where_column (end_token));
 661         ffebad_string (msg);
 662         ffebad_finish ();
 663       }
 664   }
 665
 666   /* Do the initial assignment into the DO var.  */
 667
 668   tstart = ffecom_save_tree (tstart);
 669
 670   expr = ffecom_2 (MINUS_EXPR, TREE_TYPE (tvar),
 671                    tend,
 672                    tstart);
 673
 674   if (! ffe_is_onetrip ())
 675     {
 676       expr = ffecom_2 (PLUS_EXPR, TREE_TYPE (expr),
 677                        expr,
 678                        convert (TREE_TYPE (expr), tincr_saved));
 679     }
 680
 681   if (TREE_CODE (TREE_TYPE (tvar)) != REAL_TYPE)
 682     expr = ffecom_2 (TRUNC_DIV_EXPR, TREE_TYPE (expr),
 683                      expr,
 684                      tincr_saved);
 685   else
 686     expr = ffecom_2 (RDIV_EXPR, TREE_TYPE (expr),
 687                      expr,
 688                      tincr_saved);
 689
 690 #if 1   /* New, F90-approved approach: convert to default INTEGER. */
 691   if (TREE_TYPE (tvar) != error_mark_node)
 692     expr = convert (ffecom_integer_type_node, expr);
 693 #else   /* Old approach; convert to INTEGER unless that's a narrowing. */
 694   if ((TREE_TYPE (tvar) != error_mark_node)
 695       && ((TREE_CODE (TREE_TYPE (tvar)) != INTEGER_TYPE)
 696           || ((TYPE_SIZE (TREE_TYPE (tvar)) != NULL_TREE)
 697               && ((TREE_CODE (TYPE_SIZE (TREE_TYPE (tvar)))
 698                    != INTEGER_CST)
 699                   || (TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (tvar)))
 700                       <= TREE_INT_CST_LOW (TYPE_SIZE (ffecom_integer_type_node)))))))
 701     /* Convert unless promoting INTEGER type of any kind downward to
 702        default INTEGER; else leave as, say, INTEGER*8 (long long int).  */
 703     expr = convert (ffecom_integer_type_node, expr);
 704 #endif
 705
 706   assert (TYPE_MAIN_VARIANT (TREE_TYPE (niters))
 707           == TYPE_MAIN_VARIANT (TREE_TYPE (expr)));
 708
 709   expr = ffecom_modify (void_type_node, niters, expr);
 710   expand_expr_stmt (expr);
 711
 712   expr = ffecom_modify (void_type_node, tvar, tstart);
 713   expand_expr_stmt (expr);
 714
 715   ffeste_end_stmt_ ();
 716
 717   expanded_loop = expand_start_loop_continue_elsewhere (!! block);
 718   if (block)
 719     ffestw_set_do_hook (block, expanded_loop);
 720
 721   if (! ffe_is_onetrip ())
 722     {
 723       expr = ffecom_truth_value
 724         (ffecom_2 (GE_EXPR, integer_type_node,
 725                    ffecom_2 (PREDECREMENT_EXPR,
 726                              TREE_TYPE (niters),
 727                              niters,
 728                              convert (TREE_TYPE (niters),
 729                                       ffecom_integer_one_node)),
 730                    convert (TREE_TYPE (niters),
 731                             ffecom_integer_zero_node)));
 732
 733       expand_exit_loop_if_false (0, expr);
 734     }
 735
 736   if (block)
 737     {
 738       ffestw_set_do_tvar (block, tvar);
 739       ffestw_set_do_incr_saved (block, tincr_saved);
 740       ffestw_set_do_count_var (block, niters);
 741     }
 742   else
 743     {
 744       *xtvar = tvar;
 745       *xtincr = tincr_saved;
 746       *xitersvar = niters;
 747     }
 748 }
 749
 750 #endif
 751
 752 /* End an iterative DO loop.  Pass the same iteration variable and increment
 753    value trees that were generated in the paired _begin_ call.  */
 754
 755 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 756 static void
 757 ffeste_end_iterdo_ (ffestw block, tree tvar, tree tincr, tree itersvar)
 758 {
 759   tree expr;
 760   tree niters = itersvar;
 761
 762   if (tvar == error_mark_node)
 763     return;
 764
 765   expand_loop_continue_here ();
 766
 767   ffeste_start_stmt_ ();
 768
 769   if (ffe_is_onetrip ())
 770     {
 771       expr = ffecom_truth_value
 772         (ffecom_2 (GE_EXPR, integer_type_node,
 773                    ffecom_2 (PREDECREMENT_EXPR,
 774                              TREE_TYPE (niters),
 775                              niters,
 776                              convert (TREE_TYPE (niters),
 777                                       ffecom_integer_one_node)),
 778                    convert (TREE_TYPE (niters),
 779                             ffecom_integer_zero_node)));
 780
 781       expand_exit_loop_if_false (0, expr);
 782     }
 783
 784   expr = ffecom_modify (void_type_node, tvar,
 785                         ffecom_2 (PLUS_EXPR, TREE_TYPE (tvar),
 786                                   tvar,
 787                                   tincr));
 788   expand_expr_stmt (expr);
 789
 790   /* Lose the stuff we just built. */
 791   ffeste_end_stmt_ ();
 792
 793   expand_end_loop ();
 794
 795   /* Lose the tvar and incr_saved trees. */
 796   if (block)
 797     ffeste_end_block_ (block);
 798   else
 799     ffeste_end_stmt_ ();
 800 }
 801 #endif
 802
 803 /* Generate call to run-time I/O routine.  */
 804
 805 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 806 static void
 807 ffeste_io_call_ (tree call, bool do_check)
 808 {
 809   /* Generate the call and optional assignment into iostat var. */
 810
 811   TREE_SIDE_EFFECTS (call) = 1;
 812   if (ffeste_io_iostat_ != NULL_TREE)
 813     call = ffecom_modify (do_check ? NULL_TREE : void_type_node,
 814                           ffeste_io_iostat_, call);
 815   expand_expr_stmt (call);
 816
 817   if (! do_check
 818       || ffeste_io_abort_ == NULL_TREE
 819       || TREE_CODE (ffeste_io_abort_) == ERROR_MARK)
 820     return;
 821
 822   /* Generate optional test. */
 823
 824   expand_start_cond (ffecom_truth_value (ffeste_io_iostat_), 0);
 825   expand_goto (ffeste_io_abort_);
 826   expand_end_cond ();
 827 }
 828 #endif
 829
 830 /* Handle implied-DO in I/O list.
 831
 832    Expands code to start up the DO loop.  Then for each item in the
 833    DO loop, handles appropriately (possibly including recursively calling
 834    itself).  Then expands code to end the DO loop.  */
 835
 836 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 837 static void
 838 ffeste_io_impdo_ (ffebld impdo, ffelexToken impdo_token)
 839 {
 840   ffebld var = ffebld_head (ffebld_right (impdo));
 841   ffebld start = ffebld_head (ffebld_trail (ffebld_right (impdo)));
 842   ffebld end = ffebld_head (ffebld_trail (ffebld_trail
 843                                           (ffebld_right (impdo))));
 844   ffebld incr = ffebld_head (ffebld_trail (ffebld_trail
 845                                     (ffebld_trail (ffebld_right (impdo)))));
 846   ffebld list;
 847   ffebld item;
 848   tree tvar;
 849   tree tincr;
 850   tree titervar;
 851
 852   if (incr == NULL)
 853     {
 854       incr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (1));
 855       ffebld_set_info (incr, ffeinfo_new
 856                        (FFEINFO_basictypeINTEGER,
 857                         FFEINFO_kindtypeINTEGERDEFAULT,
 858                         0,
 859                         FFEINFO_kindENTITY,
 860                         FFEINFO_whereCONSTANT,
 861                         FFETARGET_charactersizeNONE));
 862     }
 863
 864   /* Start the DO loop.  */
 865
 866   start = ffeexpr_convert_expr (start, impdo_token, var, impdo_token,
 867                                 FFEEXPR_contextLET);
 868   end = ffeexpr_convert_expr (end, impdo_token, var, impdo_token,
 869                               FFEEXPR_contextLET);
 870   incr = ffeexpr_convert_expr (incr, impdo_token, var, impdo_token,
 871                                FFEEXPR_contextLET);
 872
 873   ffeste_begin_iterdo_ (NULL, &tvar, &tincr, &titervar, var,
 874                         start, impdo_token,
 875                         end, impdo_token,
 876                         incr, impdo_token,
 877                         "Implied DO loop");
 878
 879   /* Handle the list of items.  */
 880
 881   for (list = ffebld_left (impdo); list != NULL; list = ffebld_trail (list))
 882     {
 883       item = ffebld_head (list);
 884       if (item == NULL)
 885         continue;
 886
 887       /* Strip parens off items such as in "READ *,(A)".  This is really a bug
 888          in the user's code, but I've been told lots of code does this.  */
 889       while (ffebld_op (item) == FFEBLD_opPAREN)
 890         item = ffebld_left (item);
 891
 892       if (ffebld_op (item) == FFEBLD_opANY)
 893         continue;
 894
 895       if (ffebld_op (item) == FFEBLD_opIMPDO)
 896         ffeste_io_impdo_ (item, impdo_token);
 897       else
 898         {
 899           ffeste_start_stmt_ ();
 900
 901           ffecom_prepare_arg_ptr_to_expr (item);
 902
 903           ffecom_prepare_end ();
 904
 905           ffeste_io_call_ ((*ffeste_io_driver_) (item), TRUE);
 906
 907           ffeste_end_stmt_ ();
 908         }
 909     }
 910
 911   /* Generate end of implied-do construct. */
 912
 913   ffeste_end_iterdo_ (NULL, tvar, tincr, titervar);
 914 }
 915 #endif
 916
 917 /* I/O driver for formatted I/O item (do_fio)
 918
 919    Returns a tree for a CALL_EXPR to the do_fio function, which handles
 920    a formatted I/O list item, along with the appropriate arguments for
 921    the function.  It is up to the caller to set the TREE_SIDE_EFFECTS flag
 922    for the CALL_EXPR, expand (emit) the expression, emit any assignment
 923    of the result to an IOSTAT= variable, and emit any checking of the
 924    result for errors.  */
 925
 926 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 927 static tree
 928 ffeste_io_dofio_ (ffebld expr)
 929 {
 930   tree num_elements;
 931   tree variable;
 932   tree size;
 933   tree arglist;
 934   ffeinfoBasictype bt;
 935   ffeinfoKindtype kt;
 936   bool is_complex;
 937
 938   bt = ffeinfo_basictype (ffebld_info (expr));
 939   kt = ffeinfo_kindtype (ffebld_info (expr));
 940
 941   if ((bt == FFEINFO_basictypeANY)
 942       || (kt == FFEINFO_kindtypeANY))
 943     return error_mark_node;
 944
 945   if (bt == FFEINFO_basictypeCOMPLEX)
 946     {
 947       is_complex = TRUE;
 948       bt = FFEINFO_basictypeREAL;
 949     }
 950   else
 951     is_complex = FALSE;
 952
 953   variable = ffecom_arg_ptr_to_expr (expr, &size);
 954
 955   if ((variable == error_mark_node)
 956       || (size == error_mark_node))
 957     return error_mark_node;
 958
 959   if (size == NULL_TREE)        /* Already filled in for CHARACTER type. */
 960     {                           /* "(ftnlen) sizeof(type)" */
 961       size = size_binop (CEIL_DIV_EXPR,
 962                          TYPE_SIZE_UNIT (ffecom_tree_type[bt][kt]),
 963                          size_int (TYPE_PRECISION (char_type_node)
 964                                    / BITS_PER_UNIT));
 965 #if 0   /* Assume that while it is possible that char * is wider than
 966            ftnlen, no object in Fortran space can get big enough for its
 967            size to be wider than ftnlen.  I really hope nobody wastes
 968            time debugging a case where it can!  */
 969       assert (TYPE_PRECISION (ffecom_f2c_ftnlen_type_node)
 970               >= TYPE_PRECISION (TREE_TYPE (size)));
 971 #endif
 972       size = convert (ffecom_f2c_ftnlen_type_node, size);
 973     }
 974
 975   if (ffeinfo_rank (ffebld_info (expr)) == 0
 976       || TREE_CODE (TREE_TYPE (TREE_TYPE (variable))) != ARRAY_TYPE)
 977     num_elements
 978       = is_complex ? ffecom_f2c_ftnlen_two_node : ffecom_f2c_ftnlen_one_node;
 979   else
 980     {
 981       num_elements
 982         = size_binop (CEIL_DIV_EXPR,
 983                       TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (variable))),
 984                       convert (sizetype, size));
 985       num_elements = size_binop (CEIL_DIV_EXPR, num_elements,
 986                                  size_int (TYPE_PRECISION (char_type_node)
 987                                            / BITS_PER_UNIT));
 988       num_elements = convert (ffecom_f2c_ftnlen_type_node,
 989                               num_elements);
 990     }
 991
 992   num_elements
 993     = ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
 994                 num_elements);
 995
 996   variable = convert (string_type_node, variable);
 997
 998   arglist = build_tree_list (NULL_TREE, num_elements);
 999   TREE_CHAIN (arglist) = build_tree_list (NULL_TREE, variable);
1000   TREE_CHAIN (TREE_CHAIN (arglist)) = build_tree_list (NULL_TREE, size);
1001
1002   return ffecom_call_gfrt (FFECOM_gfrtDOFIO, arglist, NULL_TREE);
1003 }
1004
1005 #endif
1006 /* I/O driver for list-directed I/O item (do_lio)
1007
1008    Returns a tree for a CALL_EXPR to the do_lio function, which handles
1009    a list-directed I/O list item, along with the appropriate arguments for
1010    the function.  It is up to the caller to set the TREE_SIDE_EFFECTS flag
1011    for the CALL_EXPR, expand (emit) the expression, emit any assignment
1012    of the result to an IOSTAT= variable, and emit any checking of the
1013    result for errors.  */
1014
1015 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1016 static tree
1017 ffeste_io_dolio_ (ffebld expr)
1018 {
1019   tree type_id;
1020   tree num_elements;
1021   tree variable;
1022   tree size;
1023   tree arglist;
1024   ffeinfoBasictype bt;
1025   ffeinfoKindtype kt;
1026   int tc;
1027
1028   bt = ffeinfo_basictype (ffebld_info (expr));
1029   kt = ffeinfo_kindtype (ffebld_info (expr));
1030
1031   if ((bt == FFEINFO_basictypeANY)
1032       || (kt == FFEINFO_kindtypeANY))
1033     return error_mark_node;
1034
1035   tc = ffecom_f2c_typecode (bt, kt);
1036   assert (tc != -1);
1037   type_id = build_int_2 (tc, 0);
1038
1039   type_id
1040     = ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnint_type_node,
1041                 convert (ffecom_f2c_ftnint_type_node,
1042                          type_id));
1043
1044   variable = ffecom_arg_ptr_to_expr (expr, &size);
1045
1046   if ((type_id == error_mark_node)
1047       || (variable == error_mark_node)
1048       || (size == error_mark_node))
1049     return error_mark_node;
1050
1051   if (size == NULL_TREE)        /* Already filled in for CHARACTER type. */
1052     {                           /* "(ftnlen) sizeof(type)" */
1053       size = size_binop (CEIL_DIV_EXPR,
1054                          TYPE_SIZE_UNIT (ffecom_tree_type[bt][kt]),
1055                          size_int (TYPE_PRECISION (char_type_node)
1056                                    / BITS_PER_UNIT));
1057 #if 0   /* Assume that while it is possible that char * is wider than
1058            ftnlen, no object in Fortran space can get big enough for its
1059            size to be wider than ftnlen.  I really hope nobody wastes
1060            time debugging a case where it can!  */
1061       assert (TYPE_PRECISION (ffecom_f2c_ftnlen_type_node)
1062               >= TYPE_PRECISION (TREE_TYPE (size)));
1063 #endif
1064       size = convert (ffecom_f2c_ftnlen_type_node, size);
1065     }
1066
1067   if (ffeinfo_rank (ffebld_info (expr)) == 0
1068       || TREE_CODE (TREE_TYPE (TREE_TYPE (variable))) != ARRAY_TYPE)
1069     num_elements = ffecom_integer_one_node;
1070   else
1071     {
1072       num_elements
1073         = size_binop (CEIL_DIV_EXPR,
1074                       TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (variable))),
1075                       convert (sizetype, size));
1076       num_elements = size_binop (CEIL_DIV_EXPR, num_elements,
1077                                  size_int (TYPE_PRECISION (char_type_node)
1078                                            / BITS_PER_UNIT));
1079       num_elements = convert (ffecom_f2c_ftnlen_type_node,
1080                               num_elements);
1081     }
1082
1083   num_elements
1084     = ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
1085                 num_elements);
1086
1087   variable = convert (string_type_node, variable);
1088
1089   arglist = build_tree_list (NULL_TREE, type_id);
1090   TREE_CHAIN (arglist) = build_tree_list (NULL_TREE, num_elements);
1091   TREE_CHAIN (TREE_CHAIN (arglist)) = build_tree_list (NULL_TREE, variable);
1092   TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (arglist)))
1093     = build_tree_list (NULL_TREE, size);
1094
1095   return ffecom_call_gfrt (FFECOM_gfrtDOLIO, arglist, NULL_TREE);
1096 }
1097
1098 #endif
1099 /* I/O driver for unformatted I/O item (do_uio)
1100
1101    Returns a tree for a CALL_EXPR to the do_uio function, which handles
1102    an unformatted I/O list item, along with the appropriate arguments for
1103    the function.  It is up to the caller to set the TREE_SIDE_EFFECTS flag
1104    for the CALL_EXPR, expand (emit) the expression, emit any assignment
1105    of the result to an IOSTAT= variable, and emit any checking of the
1106    result for errors.  */
1107
1108 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1109 static tree
1110 ffeste_io_douio_ (ffebld expr)
1111 {
1112   tree num_elements;
1113   tree variable;
1114   tree size;
1115   tree arglist;
1116   ffeinfoBasictype bt;
1117   ffeinfoKindtype kt;
1118   bool is_complex;
1119
1120   bt = ffeinfo_basictype (ffebld_info (expr));
1121   kt = ffeinfo_kindtype (ffebld_info (expr));
1122
1123   if ((bt == FFEINFO_basictypeANY)
1124       || (kt == FFEINFO_kindtypeANY))
1125     return error_mark_node;
1126
1127   if (bt == FFEINFO_basictypeCOMPLEX)
1128     {
1129       is_complex = TRUE;
1130       bt = FFEINFO_basictypeREAL;
1131     }
1132   else
1133     is_complex = FALSE;
1134
1135   variable = ffecom_arg_ptr_to_expr (expr, &size);
1136
1137   if ((variable == error_mark_node)
1138       || (size == error_mark_node))
1139     return error_mark_node;
1140
1141   if (size == NULL_TREE)        /* Already filled in for CHARACTER type. */
1142     {                           /* "(ftnlen) sizeof(type)" */
1143       size = size_binop (CEIL_DIV_EXPR,
1144                          TYPE_SIZE_UNIT (ffecom_tree_type[bt][kt]),
1145                          size_int (TYPE_PRECISION (char_type_node)
1146                                    / BITS_PER_UNIT));
1147 #if 0   /* Assume that while it is possible that char * is wider than
1148            ftnlen, no object in Fortran space can get big enough for its
1149            size to be wider than ftnlen.  I really hope nobody wastes
1150            time debugging a case where it can!  */
1151       assert (TYPE_PRECISION (ffecom_f2c_ftnlen_type_node)
1152               >= TYPE_PRECISION (TREE_TYPE (size)));
1153 #endif
1154       size = convert (ffecom_f2c_ftnlen_type_node, size);
1155     }
1156
1157   if (ffeinfo_rank (ffebld_info (expr)) == 0
1158       || TREE_CODE (TREE_TYPE (TREE_TYPE (variable))) != ARRAY_TYPE)
1159     num_elements
1160       = is_complex ? ffecom_f2c_ftnlen_two_node : ffecom_f2c_ftnlen_one_node;
1161   else
1162     {
1163       num_elements
1164         = size_binop (CEIL_DIV_EXPR,
1165                       TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (variable))),
1166                       convert (sizetype, size));
1167       num_elements = size_binop (CEIL_DIV_EXPR, num_elements,
1168                                  size_int (TYPE_PRECISION (char_type_node)
1169                                            / BITS_PER_UNIT));
1170       num_elements = convert (ffecom_f2c_ftnlen_type_node,
1171                               num_elements);
1172     }
1173
1174   num_elements
1175     = ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
1176                 num_elements);
1177
1178   variable = convert (string_type_node, variable);
1179
1180   arglist = build_tree_list (NULL_TREE, num_elements);
1181   TREE_CHAIN (arglist) = build_tree_list (NULL_TREE, variable);
1182   TREE_CHAIN (TREE_CHAIN (arglist)) = build_tree_list (NULL_TREE, size);
1183
1184   return ffecom_call_gfrt (FFECOM_gfrtDOUIO, arglist, NULL_TREE);
1185 }
1186
1187 #endif
1188 /* Make arglist with ptr to BACKSPACE/ENDFILE/REWIND control list.
1189
1190    Returns a tree suitable as an argument list containing a pointer to
1191    a BACKSPACE/ENDFILE/REWIND control list.  First, generates that control
1192    list, if necessary, along with any static and run-time initializations
1193    that are needed as specified by the arguments to this function.
1194
1195    Must ensure that all expressions are prepared before being evaluated,
1196    for any whose evaluation might result in the generation of temporaries.
1197
1198    Note that this means this function causes a transition, within the
1199    current block being code-generated via the back end, from the
1200    declaration of variables (temporaries) to the expanding of expressions,
1201    statements, etc.  */
1202
1203 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1204 static tree
1205 ffeste_io_ialist_ (bool have_err,
1206                    ffestvUnit unit,
1207                    ffebld unit_expr,
1208                    int unit_dflt)
1209 {
1210   static tree f2c_alist_struct = NULL_TREE;
1211   tree t;
1212   tree ttype;
1213   int yes;
1214   tree field;
1215   tree inits, initn;
1216   bool constantp = TRUE;
1217   static tree errfield, unitfield;
1218   tree errinit, unitinit;
1219   tree unitexp;
1220   static int mynumber = 0;
1221
1222   if (f2c_alist_struct == NULL_TREE)
1223     {
1224       tree ref;
1225
1226       ref = make_node (RECORD_TYPE);
1227
1228       errfield = ffecom_decl_field (ref, NULL_TREE, "err",
1229                                     ffecom_f2c_flag_type_node);
1230       unitfield = ffecom_decl_field (ref, errfield, "unit",
1231                                      ffecom_f2c_ftnint_type_node);
1232
1233       TYPE_FIELDS (ref) = errfield;
1234       layout_type (ref);
1235
1236       ggc_add_tree_root (&f2c_alist_struct, 1);
1237
1238       f2c_alist_struct = ref;
1239     }
1240
1241   /* Try to do as much compile-time initialization of the structure
1242      as possible, to save run time.  */
1243
1244   ffeste_f2c_init_flag_ (have_err, errinit);
1245
1246   switch (unit)
1247     {
1248     case FFESTV_unitNONE:
1249     case FFESTV_unitASTERISK:
1250       unitinit = build_int_2 (unit_dflt, 0);
1251       unitexp = unitinit;
1252       break;
1253
1254     case FFESTV_unitINTEXPR:
1255       unitexp = ffecom_const_expr (unit_expr);
1256       if (unitexp)
1257         unitinit = unitexp;
1258       else
1259         {
1260           unitinit = ffecom_integer_zero_node;
1261           constantp = FALSE;
1262         }
1263       break;
1264
1265     default:
1266       assert ("bad unit spec" == NULL);
1267       unitinit = ffecom_integer_zero_node;
1268       unitexp = unitinit;
1269       break;
1270     }
1271
1272   inits = build_tree_list ((field = TYPE_FIELDS (f2c_alist_struct)), errinit);
1273   initn = inits;
1274   ffeste_f2c_init_next_ (unitinit);
1275
1276   inits = build (CONSTRUCTOR, f2c_alist_struct, NULL_TREE, inits);
1277   TREE_CONSTANT (inits) = constantp ? 1 : 0;
1278   TREE_STATIC (inits) = 1;
1279
1280   yes = suspend_momentary ();
1281
1282   t = build_decl (VAR_DECL,
1283                   ffecom_get_invented_identifier ("__g77_alist_%d",
1284                                                   mynumber++),
1285                   f2c_alist_struct);
1286   TREE_STATIC (t) = 1;
1287   t = ffecom_start_decl (t, 1);
1288   ffecom_finish_decl (t, inits, 0);
1289
1290   resume_momentary (yes);
1291
1292   /* Prepare run-time expressions.  */
1293
1294   if (! unitexp)
1295     ffecom_prepare_expr (unit_expr);
1296
1297   ffecom_prepare_end ();
1298
1299   /* Now evaluate run-time expressions as needed.  */
1300
1301   if (! unitexp)
1302     {
1303       unitexp = ffecom_expr (unit_expr);
1304       ffeste_f2c_compile_ (unitfield, unitexp);
1305     }
1306
1307   ttype = build_pointer_type (TREE_TYPE (t));
1308   t = ffecom_1 (ADDR_EXPR, ttype, t);
1309
1310   t = build_tree_list (NULL_TREE, t);
1311
1312   return t;
1313 }
1314
1315 #endif
1316 /* Make arglist with ptr to external-I/O control list.
1317
1318    Returns a tree suitable as an argument list containing a pointer to
1319    an external-I/O control list.  First, generates that control
1320    list, if necessary, along with any static and run-time initializations
1321    that are needed as specified by the arguments to this function.
1322
1323    Must ensure that all expressions are prepared before being evaluated,
1324    for any whose evaluation might result in the generation of temporaries.
1325
1326    Note that this means this function causes a transition, within the
1327    current block being code-generated via the back end, from the
1328    declaration of variables (temporaries) to the expanding of expressions,
1329    statements, etc.  */
1330
1331 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1332 static tree
1333 ffeste_io_cilist_ (bool have_err,
1334                    ffestvUnit unit,
1335                    ffebld unit_expr,
1336                    int unit_dflt,
1337                    bool have_end,
1338                    ffestvFormat format,
1339                    ffestpFile *format_spec,
1340                    bool rec,
1341                    ffebld rec_expr)
1342 {
1343   static tree f2c_cilist_struct = NULL_TREE;
1344   tree t;
1345   tree ttype;
1346   int yes;
1347   tree field;
1348   tree inits, initn;
1349   bool constantp = TRUE;
1350   static tree errfield, unitfield, endfield, formatfield, recfield;
1351   tree errinit, unitinit, endinit, formatinit, recinit;
1352   tree unitexp, formatexp, recexp;
1353   static int mynumber = 0;
1354
1355   if (f2c_cilist_struct == NULL_TREE)
1356     {
1357       tree ref;
1358
1359       ref = make_node (RECORD_TYPE);
1360
1361       errfield = ffecom_decl_field (ref, NULL_TREE, "err",
1362                                     ffecom_f2c_flag_type_node);
1363       unitfield = ffecom_decl_field (ref, errfield, "unit",
1364                                      ffecom_f2c_ftnint_type_node);
1365       endfield = ffecom_decl_field (ref, unitfield, "end",
1366                                     ffecom_f2c_flag_type_node);
1367       formatfield = ffecom_decl_field (ref, endfield, "format",
1368                                        string_type_node);
1369       recfield = ffecom_decl_field (ref, formatfield, "rec",
1370                                     ffecom_f2c_ftnint_type_node);
1371
1372       TYPE_FIELDS (ref) = errfield;
1373       layout_type (ref);
1374
1375       ggc_add_tree_root (&f2c_cilist_struct, 1);
1376
1377       f2c_cilist_struct = ref;
1378     }
1379
1380   /* Try to do as much compile-time initialization of the structure
1381      as possible, to save run time.  */
1382
1383   ffeste_f2c_init_flag_ (have_err, errinit);
1384
1385   switch (unit)
1386     {
1387     case FFESTV_unitNONE:
1388     case FFESTV_unitASTERISK:
1389       unitinit = build_int_2 (unit_dflt, 0);
1390       unitexp = unitinit;
1391       break;
1392
1393     case FFESTV_unitINTEXPR:
1394       unitexp = ffecom_const_expr (unit_expr);
1395       if (unitexp)
1396         unitinit = unitexp;
1397       else
1398         {
1399           unitinit = ffecom_integer_zero_node;
1400           constantp = FALSE;
1401         }
1402       break;
1403
1404     default:
1405       assert ("bad unit spec" == NULL);
1406       unitinit = ffecom_integer_zero_node;
1407       unitexp = unitinit;
1408       break;
1409     }
1410
1411   switch (format)
1412     {
1413     case FFESTV_formatNONE:
1414       formatinit = null_pointer_node;
1415       formatexp = formatinit;
1416       break;
1417
1418     case FFESTV_formatLABEL:
1419       formatexp = error_mark_node;
1420       formatinit = ffecom_lookup_label (format_spec->u.label);
1421       if ((formatinit == NULL_TREE)
1422           || (TREE_CODE (formatinit) == ERROR_MARK))
1423         break;
1424       formatinit = ffecom_1 (ADDR_EXPR,
1425                              build_pointer_type (void_type_node),
1426                              formatinit);
1427       TREE_CONSTANT (formatinit) = 1;
1428       break;
1429
1430     case FFESTV_formatCHAREXPR:
1431       formatexp = ffecom_arg_ptr_to_const_expr (format_spec->u.expr, NULL);
1432       if (formatexp)
1433         formatinit = formatexp;
1434       else
1435         {
1436           formatinit = null_pointer_node;
1437           constantp = FALSE;
1438         }
1439       break;
1440
1441     case FFESTV_formatASTERISK:
1442       formatinit = null_pointer_node;
1443       formatexp = formatinit;
1444       break;
1445
1446     case FFESTV_formatINTEXPR:
1447       formatinit = null_pointer_node;
1448       formatexp = ffecom_expr_assign (format_spec->u.expr);
1449       if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (formatexp)))
1450           < GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
1451         error ("ASSIGNed FORMAT specifier is too small");
1452       formatexp = convert (string_type_node, formatexp);
1453       break;
1454
1455     case FFESTV_formatNAMELIST:
1456       formatinit = ffecom_expr (format_spec->u.expr);
1457       formatexp = formatinit;
1458       break;
1459
1460     default:
1461       assert ("bad format spec" == NULL);
1462       formatinit = integer_zero_node;
1463       formatexp = formatinit;
1464       break;
1465     }
1466
1467   ffeste_f2c_init_flag_ (have_end, endinit);
1468
1469   if (rec)
1470     recexp = ffecom_const_expr (rec_expr);
1471   else
1472     recexp = ffecom_integer_zero_node;
1473   if (recexp)
1474     recinit = recexp;
1475   else
1476     {
1477       recinit = ffecom_integer_zero_node;
1478       constantp = FALSE;
1479     }
1480
1481   inits = build_tree_list ((field = TYPE_FIELDS (f2c_cilist_struct)), errinit);
1482   initn = inits;
1483   ffeste_f2c_init_next_ (unitinit);
1484   ffeste_f2c_init_next_ (endinit);
1485   ffeste_f2c_init_next_ (formatinit);
1486   ffeste_f2c_init_next_ (recinit);
1487
1488   inits = build (CONSTRUCTOR, f2c_cilist_struct, NULL_TREE, inits);
1489   TREE_CONSTANT (inits) = constantp ? 1 : 0;
1490   TREE_STATIC (inits) = 1;
1491
1492   yes = suspend_momentary ();
1493
1494   t = build_decl (VAR_DECL,
1495                   ffecom_get_invented_identifier ("__g77_cilist_%d",
1496                                                   mynumber++),
1497                   f2c_cilist_struct);
1498   TREE_STATIC (t) = 1;
1499   t = ffecom_start_decl (t, 1);
1500   ffecom_finish_decl (t, inits, 0);
1501
1502   resume_momentary (yes);
1503
1504   /* Prepare run-time expressions.  */
1505
1506   if (! unitexp)
1507     ffecom_prepare_expr (unit_expr);
1508
1509   if (! formatexp)
1510     ffecom_prepare_arg_ptr_to_expr (format_spec->u.expr);
1511
1512   if (! recexp)
1513     ffecom_prepare_expr (rec_expr);
1514
1515   ffecom_prepare_end ();
1516
1517   /* Now evaluate run-time expressions as needed.  */
1518
1519   if (! unitexp)
1520     {
1521       unitexp = ffecom_expr (unit_expr);
1522       ffeste_f2c_compile_ (unitfield, unitexp);
1523     }
1524
1525   if (! formatexp)
1526     {
1527       formatexp = ffecom_arg_ptr_to_expr (format_spec->u.expr, NULL);
1528       ffeste_f2c_compile_ (formatfield, formatexp);
1529     }
1530   else if (format == FFESTV_formatINTEXPR)
1531     ffeste_f2c_compile_ (formatfield, formatexp);
1532
1533   if (! recexp)
1534     {
1535       recexp = ffecom_expr (rec_expr);
1536       ffeste_f2c_compile_ (recfield, recexp);
1537     }
1538
1539   ttype = build_pointer_type (TREE_TYPE (t));
1540   t = ffecom_1 (ADDR_EXPR, ttype, t);
1541
1542   t = build_tree_list (NULL_TREE, t);
1543
1544   return t;
1545 }
1546
1547 #endif
1548 /* Make arglist with ptr to CLOSE control list.
1549
1550    Returns a tree suitable as an argument list containing a pointer to
1551    a CLOSE-statement control list.  First, generates that control
1552    list, if necessary, along with any static and run-time initializations
1553    that are needed as specified by the arguments to this function.
1554
1555    Must ensure that all expressions are prepared before being evaluated,
1556    for any whose evaluation might result in the generation of temporaries.
1557
1558    Note that this means this function causes a transition, within the
1559    current block being code-generated via the back end, from the
1560    declaration of variables (temporaries) to the expanding of expressions,
1561    statements, etc.  */
1562
1563 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1564 static tree
1565 ffeste_io_cllist_ (bool have_err,
1566                    ffebld unit_expr,
1567                    ffestpFile *stat_spec)
1568 {
1569   static tree f2c_close_struct = NULL_TREE;
1570   tree t;
1571   tree ttype;
1572   int yes;
1573   tree field;
1574   tree inits, initn;
1575   tree ignore;                  /* Ignore length info for certain fields. */
1576   bool constantp = TRUE;
1577   static tree errfield, unitfield, statfield;
1578   tree errinit, unitinit, statinit;
1579   tree unitexp, statexp;
1580   static int mynumber = 0;
1581
1582   if (f2c_close_struct == NULL_TREE)
1583     {
1584       tree ref;
1585
1586       ref = make_node (RECORD_TYPE);
1587
1588       errfield = ffecom_decl_field (ref, NULL_TREE, "err",
1589                                     ffecom_f2c_flag_type_node);
1590       unitfield = ffecom_decl_field (ref, errfield, "unit",
1591                                      ffecom_f2c_ftnint_type_node);
1592       statfield = ffecom_decl_field (ref, unitfield, "stat",
1593                                      string_type_node);
1594
1595       TYPE_FIELDS (ref) = errfield;
1596       layout_type (ref);
1597
1598       ggc_add_tree_root (&f2c_close_struct, 1);
1599
1600       f2c_close_struct = ref;
1601     }
1602
1603   /* Try to do as much compile-time initialization of the structure
1604      as possible, to save run time.  */
1605
1606   ffeste_f2c_init_flag_ (have_err, errinit);
1607
1608   unitexp = ffecom_const_expr (unit_expr);
1609   if (unitexp)
1610     unitinit = unitexp;
1611   else
1612     {
1613       unitinit = ffecom_integer_zero_node;
1614       constantp = FALSE;
1615     }
1616
1617   ffeste_f2c_init_charnolen_ (statexp, statinit, stat_spec);
1618
1619   inits = build_tree_list ((field = TYPE_FIELDS (f2c_close_struct)), errinit);
1620   initn = inits;
1621   ffeste_f2c_init_next_ (unitinit);
1622   ffeste_f2c_init_next_ (statinit);
1623
1624   inits = build (CONSTRUCTOR, f2c_close_struct, NULL_TREE, inits);
1625   TREE_CONSTANT (inits) = constantp ? 1 : 0;
1626   TREE_STATIC (inits) = 1;
1627
1628   yes = suspend_momentary ();
1629
1630   t = build_decl (VAR_DECL,
1631                   ffecom_get_invented_identifier ("__g77_cllist_%d",
1632                                                   mynumber++),
1633                   f2c_close_struct);
1634   TREE_STATIC (t) = 1;
1635   t = ffecom_start_decl (t, 1);
1636   ffecom_finish_decl (t, inits, 0);
1637
1638   resume_momentary (yes);
1639
1640   /* Prepare run-time expressions.  */
1641
1642   if (! unitexp)
1643     ffecom_prepare_expr (unit_expr);
1644
1645   if (! statexp)
1646     ffecom_prepare_arg_ptr_to_expr (stat_spec->u.expr);
1647
1648   ffecom_prepare_end ();
1649
1650   /* Now evaluate run-time expressions as needed.  */
1651
1652   if (! unitexp)
1653     {
1654       unitexp = ffecom_expr (unit_expr);
1655       ffeste_f2c_compile_ (unitfield, unitexp);
1656     }
1657
1658   ffeste_f2c_compile_charnolen_ (statfield, stat_spec, statexp);
1659
1660   ttype = build_pointer_type (TREE_TYPE (t));
1661   t = ffecom_1 (ADDR_EXPR, ttype, t);
1662
1663   t = build_tree_list (NULL_TREE, t);
1664
1665   return t;
1666 }
1667
1668 #endif
1669 /* Make arglist with ptr to internal-I/O control list.
1670
1671    Returns a tree suitable as an argument list containing a pointer to
1672    an internal-I/O control list.  First, generates that control
1673    list, if necessary, along with any static and run-time initializations
1674    that are needed as specified by the arguments to this function.
1675
1676    Must ensure that all expressions are prepared before being evaluated,
1677    for any whose evaluation might result in the generation of temporaries.
1678
1679    Note that this means this function causes a transition, within the
1680    current block being code-generated via the back end, from the
1681    declaration of variables (temporaries) to the expanding of expressions,
1682    statements, etc.  */
1683
1684 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1685 static tree
1686 ffeste_io_icilist_ (bool have_err,
1687                     ffebld unit_expr,
1688                     bool have_end,
1689                     ffestvFormat format,
1690                     ffestpFile *format_spec)
1691 {
1692   static tree f2c_icilist_struct = NULL_TREE;
1693   tree t;
1694   tree ttype;
1695   int yes;
1696   tree field;
1697   tree inits, initn;
1698   bool constantp = TRUE;
1699   static tree errfield, unitfield, endfield, formatfield, unitlenfield,
1700     unitnumfield;
1701   tree errinit, unitinit, endinit, formatinit, unitleninit, unitnuminit;
1702   tree unitexp, formatexp, unitlenexp, unitnumexp;
1703   static int mynumber = 0;
1704
1705   if (f2c_icilist_struct == NULL_TREE)
1706     {
1707       tree ref;
1708
1709       ref = make_node (RECORD_TYPE);
1710
1711       errfield = ffecom_decl_field (ref, NULL_TREE, "err",
1712                                     ffecom_f2c_flag_type_node);
1713       unitfield = ffecom_decl_field (ref, errfield, "unit",
1714                                      string_type_node);
1715       endfield = ffecom_decl_field (ref, unitfield, "end",
1716                                     ffecom_f2c_flag_type_node);
1717       formatfield = ffecom_decl_field (ref, endfield, "format",
1718                                        string_type_node);
1719       unitlenfield = ffecom_decl_field (ref, formatfield, "unitlen",
1720                                         ffecom_f2c_ftnint_type_node);
1721       unitnumfield = ffecom_decl_field (ref, unitlenfield, "unitnum",
1722                                         ffecom_f2c_ftnint_type_node);
1723
1724       TYPE_FIELDS (ref) = errfield;
1725       layout_type (ref);
1726
1727       ggc_add_tree_root (&f2c_icilist_struct, 1);
1728
1729       f2c_icilist_struct = ref;
1730     }
1731
1732   /* Try to do as much compile-time initialization of the structure
1733      as possible, to save run time.  */
1734
1735   ffeste_f2c_init_flag_ (have_err, errinit);
1736
1737   unitexp = ffecom_arg_ptr_to_const_expr (unit_expr, &unitlenexp);
1738   if (unitexp)
1739     unitinit = unitexp;
1740   else
1741     {
1742       unitinit = null_pointer_node;
1743       constantp = FALSE;
1744     }
1745   if (unitlenexp)
1746     unitleninit = unitlenexp;
1747   else
1748     {
1749       unitleninit = ffecom_integer_zero_node;
1750       constantp = FALSE;
1751     }
1752
1753   /* Now see if we can fully initialize the number of elements, or
1754      if we have to compute that at run time.  */
1755   if (ffeinfo_rank (ffebld_info (unit_expr)) == 0
1756       || (unitexp
1757           && TREE_CODE (TREE_TYPE (TREE_TYPE (unitexp))) != ARRAY_TYPE))
1758     {
1759       /* Not an array, so just one element.  */
1760       unitnuminit = ffecom_integer_one_node;
1761       unitnumexp = unitnuminit;
1762     }
1763   else if (unitexp && unitlenexp)
1764     {
1765       /* An array, but all the info is constant, so compute now.  */
1766       unitnuminit
1767         = size_binop (CEIL_DIV_EXPR,
1768                       TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (unitexp))),
1769                       convert (sizetype, unitlenexp));
1770       unitnuminit = size_binop (CEIL_DIV_EXPR, unitnuminit,
1771                                 size_int (TYPE_PRECISION (char_type_node)
1772                                           / BITS_PER_UNIT));
1773       unitnumexp = unitnuminit;
1774     }
1775   else
1776     {
1777       /* Put off computing until run time.  */
1778       unitnuminit = ffecom_integer_zero_node;
1779       unitnumexp = NULL_TREE;
1780       constantp = FALSE;
1781     }
1782
1783   switch (format)
1784     {
1785     case FFESTV_formatNONE:
1786       formatinit = null_pointer_node;
1787       formatexp = formatinit;
1788       break;
1789
1790     case FFESTV_formatLABEL:
1791       formatexp = error_mark_node;
1792       formatinit = ffecom_lookup_label (format_spec->u.label);
1793       if ((formatinit == NULL_TREE)
1794           || (TREE_CODE (formatinit) == ERROR_MARK))
1795         break;
1796       formatinit = ffecom_1 (ADDR_EXPR,
1797                              build_pointer_type (void_type_node),
1798                              formatinit);
1799       TREE_CONSTANT (formatinit) = 1;
1800       break;
1801
1802     case FFESTV_formatCHAREXPR:
1803       ffeste_f2c_init_format_ (formatexp, formatinit, format_spec);
1804       break;
1805
1806     case FFESTV_formatASTERISK:
1807       formatinit = null_pointer_node;
1808       formatexp = formatinit;
1809       break;
1810
1811     case FFESTV_formatINTEXPR:
1812       formatinit = null_pointer_node;
1813       formatexp = ffecom_expr_assign (format_spec->u.expr);
1814       if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (formatexp)))
1815           < GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
1816         error ("ASSIGNed FORMAT specifier is too small");
1817       formatexp = convert (string_type_node, formatexp);
1818       break;
1819
1820     default:
1821       assert ("bad format spec" == NULL);
1822       formatinit = ffecom_integer_zero_node;
1823       formatexp = formatinit;
1824       break;
1825     }
1826
1827   ffeste_f2c_init_flag_ (have_end, endinit);
1828
1829   inits = build_tree_list ((field = TYPE_FIELDS (f2c_icilist_struct)),
1830                            errinit);
1831   initn = inits;
1832   ffeste_f2c_init_next_ (unitinit);
1833   ffeste_f2c_init_next_ (endinit);
1834   ffeste_f2c_init_next_ (formatinit);
1835   ffeste_f2c_init_next_ (unitleninit);
1836   ffeste_f2c_init_next_ (unitnuminit);
1837
1838   inits = build (CONSTRUCTOR, f2c_icilist_struct, NULL_TREE, inits);
1839   TREE_CONSTANT (inits) = constantp ? 1 : 0;
1840   TREE_STATIC (inits) = 1;
1841
1842   yes = suspend_momentary ();
1843
1844   t = build_decl (VAR_DECL,
1845                   ffecom_get_invented_identifier ("__g77_icilist_%d",
1846                                                   mynumber++),
1847                   f2c_icilist_struct);
1848   TREE_STATIC (t) = 1;
1849   t = ffecom_start_decl (t, 1);
1850   ffecom_finish_decl (t, inits, 0);
1851
1852   resume_momentary (yes);
1853
1854   /* Prepare run-time expressions.  */
1855
1856   if (! unitexp)
1857     ffecom_prepare_arg_ptr_to_expr (unit_expr);
1858
1859   ffeste_f2c_prepare_format_ (format_spec, formatexp);
1860
1861   ffecom_prepare_end ();
1862
1863   /* Now evaluate run-time expressions as needed.  */
1864
1865   if (! unitexp || ! unitlenexp)
1866     {
1867       int need_unitexp = (! unitexp);
1868       int need_unitlenexp = (! unitlenexp);
1869
1870       unitexp = ffecom_arg_ptr_to_expr (unit_expr, &unitlenexp);
1871       if (need_unitexp)
1872         ffeste_f2c_compile_ (unitfield, unitexp);
1873       if (need_unitlenexp)
1874         ffeste_f2c_compile_ (unitlenfield, unitlenexp);
1875     }
1876
1877   if (! unitnumexp
1878       && unitexp != error_mark_node
1879       && unitlenexp != error_mark_node)
1880     {
1881       unitnumexp
1882         = size_binop (CEIL_DIV_EXPR,
1883                       TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (unitexp))),
1884                       convert (sizetype, unitlenexp));
1885       unitnumexp = size_binop (CEIL_DIV_EXPR, unitnumexp,
1886                                size_int (TYPE_PRECISION (char_type_node)
1887                                          / BITS_PER_UNIT));
1888       ffeste_f2c_compile_ (unitnumfield, unitnumexp);
1889     }
1890
1891   if (format == FFESTV_formatINTEXPR)
1892     ffeste_f2c_compile_ (formatfield, formatexp);
1893   else
1894     ffeste_f2c_compile_format_ (formatfield, format_spec, formatexp);
1895
1896   ttype = build_pointer_type (TREE_TYPE (t));
1897   t = ffecom_1 (ADDR_EXPR, ttype, t);
1898
1899   t = build_tree_list (NULL_TREE, t);
1900
1901   return t;
1902 }
1903 #endif
1904
1905 /* Make arglist with ptr to INQUIRE control list
1906
1907    Returns a tree suitable as an argument list containing a pointer to
1908    an INQUIRE-statement control list.  First, generates that control
1909    list, if necessary, along with any static and run-time initializations
1910    that are needed as specified by the arguments to this function.
1911
1912    Must ensure that all expressions are prepared before being evaluated,
1913    for any whose evaluation might result in the generation of temporaries.
1914
1915    Note that this means this function causes a transition, within the
1916    current block being code-generated via the back end, from the
1917    declaration of variables (temporaries) to the expanding of expressions,
1918    statements, etc.  */
1919
1920 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1921 static tree
1922 ffeste_io_inlist_ (bool have_err,
1923                    ffestpFile *unit_spec,
1924                    ffestpFile *file_spec,
1925                    ffestpFile *exist_spec,
1926                    ffestpFile *open_spec,
1927                    ffestpFile *number_spec,
1928                    ffestpFile *named_spec,
1929                    ffestpFile *name_spec,
1930                    ffestpFile *access_spec,
1931                    ffestpFile *sequential_spec,
1932                    ffestpFile *direct_spec,
1933                    ffestpFile *form_spec,
1934                    ffestpFile *formatted_spec,
1935                    ffestpFile *unformatted_spec,
1936                    ffestpFile *recl_spec,
1937                    ffestpFile *nextrec_spec,
1938                    ffestpFile *blank_spec)
1939 {
1940   static tree f2c_inquire_struct = NULL_TREE;
1941   tree t;
1942   tree ttype;
1943   int yes;
1944   tree field;
1945   tree inits, initn;
1946   bool constantp = TRUE;
1947   static tree errfield, unitfield, filefield, filelenfield, existfield,
1948     openfield, numberfield, namedfield, namefield, namelenfield, accessfield,
1949     accesslenfield, sequentialfield, sequentiallenfield, directfield, directlenfield,
1950     formfield, formlenfield, formattedfield, formattedlenfield, unformattedfield,
1951     unformattedlenfield, reclfield, nextrecfield, blankfield, blanklenfield;
1952   tree errinit, unitinit, fileinit, fileleninit, existinit, openinit, numberinit,
1953     namedinit, nameinit, nameleninit, accessinit, accessleninit, sequentialinit,
1954     sequentialleninit, directinit, directleninit, forminit, formleninit,
1955     formattedinit, formattedleninit, unformattedinit, unformattedleninit,
1956     reclinit, nextrecinit, blankinit, blankleninit;
1957   tree
1958     unitexp, fileexp, filelenexp, existexp, openexp, numberexp, namedexp,
1959     nameexp, namelenexp, accessexp, accesslenexp, sequentialexp, sequentiallenexp,
1960     directexp, directlenexp, formexp, formlenexp, formattedexp, formattedlenexp,
1961     unformattedexp, unformattedlenexp, reclexp, nextrecexp, blankexp, blanklenexp;
1962   static int mynumber = 0;
1963
1964   if (f2c_inquire_struct == NULL_TREE)
1965     {
1966       tree ref;
1967
1968       ref = make_node (RECORD_TYPE);
1969
1970       errfield = ffecom_decl_field (ref, NULL_TREE, "err",
1971                                     ffecom_f2c_flag_type_node);
1972       unitfield = ffecom_decl_field (ref, errfield, "unit",
1973                                      ffecom_f2c_ftnint_type_node);
1974       filefield = ffecom_decl_field (ref, unitfield, "file",
1975                                      string_type_node);
1976       filelenfield = ffecom_decl_field (ref, filefield, "filelen",
1977                                         ffecom_f2c_ftnlen_type_node);
1978       existfield = ffecom_decl_field (ref, filelenfield, "exist",
1979                                       ffecom_f2c_ptr_to_ftnint_type_node);
1980       openfield = ffecom_decl_field (ref, existfield, "open",
1981                                      ffecom_f2c_ptr_to_ftnint_type_node);
1982       numberfield = ffecom_decl_field (ref, openfield, "number",
1983                                        ffecom_f2c_ptr_to_ftnint_type_node);
1984       namedfield = ffecom_decl_field (ref, numberfield, "named",
1985                                       ffecom_f2c_ptr_to_ftnint_type_node);
1986       namefield = ffecom_decl_field (ref, namedfield, "name",
1987                                      string_type_node);
1988       namelenfield = ffecom_decl_field (ref, namefield, "namelen",
1989                                         ffecom_f2c_ftnlen_type_node);
1990       accessfield = ffecom_decl_field (ref, namelenfield, "access",
1991                                        string_type_node);
1992       accesslenfield = ffecom_decl_field (ref, accessfield, "accesslen",
1993                                           ffecom_f2c_ftnlen_type_node);
1994       sequentialfield = ffecom_decl_field (ref, accesslenfield, "sequential",
1995                                            string_type_node);
1996       sequentiallenfield = ffecom_decl_field (ref, sequentialfield,
1997                                               "sequentiallen",
1998                                               ffecom_f2c_ftnlen_type_node);
1999       directfield = ffecom_decl_field (ref, sequentiallenfield, "direct",
2000                                        string_type_node);
2001       directlenfield = ffecom_decl_field (ref, directfield, "directlen",
2002                                           ffecom_f2c_ftnlen_type_node);
2003       formfield = ffecom_decl_field (ref, directlenfield, "form",
2004                                      string_type_node);
2005       formlenfield = ffecom_decl_field (ref, formfield, "formlen",
2006                                         ffecom_f2c_ftnlen_type_node);
2007       formattedfield = ffecom_decl_field (ref, formlenfield, "formatted",
2008                                           string_type_node);
2009       formattedlenfield = ffecom_decl_field (ref, formattedfield,
2010                                              "formattedlen",
2011                                              ffecom_f2c_ftnlen_type_node);
2012       unformattedfield = ffecom_decl_field (ref, formattedlenfield,
2013                                             "unformatted",
2014                                             string_type_node);
2015       unformattedlenfield = ffecom_decl_field (ref, unformattedfield,
2016                                                "unformattedlen",
2017                                                ffecom_f2c_ftnlen_type_node);
2018       reclfield = ffecom_decl_field (ref, unformattedlenfield, "recl",
2019                                      ffecom_f2c_ptr_to_ftnint_type_node);
2020       nextrecfield = ffecom_decl_field (ref, reclfield, "nextrec",
2021                                         ffecom_f2c_ptr_to_ftnint_type_node);
2022       blankfield = ffecom_decl_field (ref, nextrecfield, "blank",
2023                                       string_type_node);
2024       blanklenfield = ffecom_decl_field (ref, blankfield, "blanklen",
2025                                          ffecom_f2c_ftnlen_type_node);
2026
2027       TYPE_FIELDS (ref) = errfield;
2028       layout_type (ref);
2029
2030       ggc_add_tree_root (&f2c_inquire_struct, 1);
2031
2032       f2c_inquire_struct = ref;
2033     }
2034
2035   /* Try to do as much compile-time initialization of the structure
2036      as possible, to save run time.  */
2037
2038   ffeste_f2c_init_flag_ (have_err, errinit);
2039   ffeste_f2c_init_int_ (unitexp, unitinit, unit_spec);
2040   ffeste_f2c_init_char_ (fileexp, fileinit, filelenexp, fileleninit,
2041                          file_spec);
2042   ffeste_f2c_init_ptrtoint_ (existexp, existinit, exist_spec);
2043   ffeste_f2c_init_ptrtoint_ (openexp, openinit, open_spec);
2044   ffeste_f2c_init_ptrtoint_ (numberexp, numberinit, number_spec);
2045   ffeste_f2c_init_ptrtoint_ (namedexp, namedinit, named_spec);
2046   ffeste_f2c_init_char_ (nameexp, nameinit, namelenexp, nameleninit,
2047                          name_spec);
2048   ffeste_f2c_init_char_ (accessexp, accessinit, accesslenexp,
2049                          accessleninit, access_spec);
2050   ffeste_f2c_init_char_ (sequentialexp, sequentialinit, sequentiallenexp,
2051                          sequentialleninit, sequential_spec);
2052   ffeste_f2c_init_char_ (directexp, directinit, directlenexp,
2053                          directleninit, direct_spec);
2054   ffeste_f2c_init_char_ (formexp, forminit, formlenexp, formleninit,
2055                          form_spec);
2056   ffeste_f2c_init_char_ (formattedexp, formattedinit,
2057                          formattedlenexp, formattedleninit, formatted_spec);
2058   ffeste_f2c_init_char_ (unformattedexp, unformattedinit, unformattedlenexp,
2059                          unformattedleninit, unformatted_spec);
2060   ffeste_f2c_init_ptrtoint_ (reclexp, reclinit, recl_spec);
2061   ffeste_f2c_init_ptrtoint_ (nextrecexp, nextrecinit, nextrec_spec);
2062   ffeste_f2c_init_char_ (blankexp, blankinit, blanklenexp,
2063                          blankleninit, blank_spec);
2064
2065   inits = build_tree_list ((field = TYPE_FIELDS (f2c_inquire_struct)),
2066                            errinit);
2067   initn = inits;
2068   ffeste_f2c_init_next_ (unitinit);
2069   ffeste_f2c_init_next_ (fileinit);
2070   ffeste_f2c_init_next_ (fileleninit);
2071   ffeste_f2c_init_next_ (existinit);
2072   ffeste_f2c_init_next_ (openinit);
2073   ffeste_f2c_init_next_ (numberinit);
2074   ffeste_f2c_init_next_ (namedinit);
2075   ffeste_f2c_init_next_ (nameinit);
2076   ffeste_f2c_init_next_ (nameleninit);
2077   ffeste_f2c_init_next_ (accessinit);
2078   ffeste_f2c_init_next_ (accessleninit);
2079   ffeste_f2c_init_next_ (sequentialinit);
2080   ffeste_f2c_init_next_ (sequentialleninit);
2081   ffeste_f2c_init_next_ (directinit);
2082   ffeste_f2c_init_next_ (directleninit);
2083   ffeste_f2c_init_next_ (forminit);
2084   ffeste_f2c_init_next_ (formleninit);
2085   ffeste_f2c_init_next_ (formattedinit);
2086   ffeste_f2c_init_next_ (formattedleninit);
2087   ffeste_f2c_init_next_ (unformattedinit);
2088   ffeste_f2c_init_next_ (unformattedleninit);
2089   ffeste_f2c_init_next_ (reclinit);
2090   ffeste_f2c_init_next_ (nextrecinit);
2091   ffeste_f2c_init_next_ (blankinit);
2092   ffeste_f2c_init_next_ (blankleninit);
2093
2094   inits = build (CONSTRUCTOR, f2c_inquire_struct, NULL_TREE, inits);
2095   TREE_CONSTANT (inits) = constantp ? 1 : 0;
2096   TREE_STATIC (inits) = 1;
2097
2098   yes = suspend_momentary ();
2099
2100   t = build_decl (VAR_DECL,
2101                   ffecom_get_invented_identifier ("__g77_inlist_%d",
2102                                                   mynumber++),
2103                   f2c_inquire_struct);
2104   TREE_STATIC (t) = 1;
2105   t = ffecom_start_decl (t, 1);
2106   ffecom_finish_decl (t, inits, 0);
2107
2108   resume_momentary (yes);
2109
2110   /* Prepare run-time expressions.  */
2111
2112   ffeste_f2c_prepare_int_ (unit_spec, unitexp);
2113   ffeste_f2c_prepare_char_ (file_spec, fileexp);
2114   ffeste_f2c_prepare_ptrtoint_ (exist_spec, existexp);
2115   ffeste_f2c_prepare_ptrtoint_ (open_spec, openexp);
2116   ffeste_f2c_prepare_ptrtoint_ (number_spec, numberexp);
2117   ffeste_f2c_prepare_ptrtoint_ (named_spec, namedexp);
2118   ffeste_f2c_prepare_char_ (name_spec, nameexp);
2119   ffeste_f2c_prepare_char_ (access_spec, accessexp);
2120   ffeste_f2c_prepare_char_ (sequential_spec, sequentialexp);
2121   ffeste_f2c_prepare_char_ (direct_spec, directexp);
2122   ffeste_f2c_prepare_char_ (form_spec, formexp);
2123   ffeste_f2c_prepare_char_ (formatted_spec, formattedexp);
2124   ffeste_f2c_prepare_char_ (unformatted_spec, unformattedexp);
2125   ffeste_f2c_prepare_ptrtoint_ (recl_spec, reclexp);
2126   ffeste_f2c_prepare_ptrtoint_ (nextrec_spec, nextrecexp);
2127   ffeste_f2c_prepare_char_ (blank_spec, blankexp);
2128
2129   ffecom_prepare_end ();
2130
2131   /* Now evaluate run-time expressions as needed.  */
2132
2133   ffeste_f2c_compile_int_ (unitfield, unit_spec, unitexp);
2134   ffeste_f2c_compile_char_ (filefield, filelenfield, file_spec,
2135                             fileexp, filelenexp);
2136   ffeste_f2c_compile_ptrtoint_ (existfield, exist_spec, existexp);
2137   ffeste_f2c_compile_ptrtoint_ (openfield, open_spec, openexp);
2138   ffeste_f2c_compile_ptrtoint_ (numberfield, number_spec, numberexp);
2139   ffeste_f2c_compile_ptrtoint_ (namedfield, named_spec, namedexp);
2140   ffeste_f2c_compile_char_ (namefield, namelenfield, name_spec, nameexp,
2141                             namelenexp);
2142   ffeste_f2c_compile_char_ (accessfield, accesslenfield, access_spec,
2143                             accessexp, accesslenexp);
2144   ffeste_f2c_compile_char_ (sequentialfield, sequentiallenfield,
2145                             sequential_spec, sequentialexp,
2146                             sequentiallenexp);
2147   ffeste_f2c_compile_char_ (directfield, directlenfield, direct_spec,
2148                             directexp, directlenexp);
2149   ffeste_f2c_compile_char_ (formfield, formlenfield, form_spec, formexp,
2150                             formlenexp);
2151   ffeste_f2c_compile_char_ (formattedfield, formattedlenfield, formatted_spec,
2152                             formattedexp, formattedlenexp);
2153   ffeste_f2c_compile_char_ (unformattedfield, unformattedlenfield,
2154                             unformatted_spec, unformattedexp,
2155                             unformattedlenexp);
2156   ffeste_f2c_compile_ptrtoint_ (reclfield, recl_spec, reclexp);
2157   ffeste_f2c_compile_ptrtoint_ (nextrecfield, nextrec_spec, nextrecexp);
2158   ffeste_f2c_compile_char_ (blankfield, blanklenfield, blank_spec, blankexp,
2159                             blanklenexp);
2160
2161   ttype = build_pointer_type (TREE_TYPE (t));
2162   t = ffecom_1 (ADDR_EXPR, ttype, t);
2163
2164   t = build_tree_list (NULL_TREE, t);
2165
2166   return t;
2167 }
2168
2169 #endif
2170 /* Make arglist with ptr to OPEN control list
2171
2172    Returns a tree suitable as an argument list containing a pointer to
2173    an OPEN-statement control list.  First, generates that control
2174    list, if necessary, along with any static and run-time initializations
2175    that are needed as specified by the arguments to this function.
2176
2177    Must ensure that all expressions are prepared before being evaluated,
2178    for any whose evaluation might result in the generation of temporaries.
2179
2180    Note that this means this function causes a transition, within the
2181    current block being code-generated via the back end, from the
2182    declaration of variables (temporaries) to the expanding of expressions,
2183    statements, etc.  */
2184
2185 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2186 static tree
2187 ffeste_io_olist_ (bool have_err,
2188                   ffebld unit_expr,
2189                   ffestpFile *file_spec,
2190                   ffestpFile *stat_spec,
2191                   ffestpFile *access_spec,
2192                   ffestpFile *form_spec,
2193                   ffestpFile *recl_spec,
2194                   ffestpFile *blank_spec)
2195 {
2196   static tree f2c_open_struct = NULL_TREE;
2197   tree t;
2198   tree ttype;
2199   int yes;
2200   tree field;
2201   tree inits, initn;
2202   tree ignore;                  /* Ignore length info for certain fields. */
2203   bool constantp = TRUE;
2204   static tree errfield, unitfield, filefield, filelenfield, statfield,
2205     accessfield, formfield, reclfield, blankfield;
2206   tree errinit, unitinit, fileinit, fileleninit, statinit, accessinit,
2207     forminit, reclinit, blankinit;
2208   tree
2209     unitexp, fileexp, filelenexp, statexp, accessexp, formexp, reclexp,
2210     blankexp;
2211   static int mynumber = 0;
2212
2213   if (f2c_open_struct == NULL_TREE)
2214     {
2215       tree ref;
2216
2217       ref = make_node (RECORD_TYPE);
2218
2219       errfield = ffecom_decl_field (ref, NULL_TREE, "err",
2220                                     ffecom_f2c_flag_type_node);
2221       unitfield = ffecom_decl_field (ref, errfield, "unit",
2222                                      ffecom_f2c_ftnint_type_node);
2223       filefield = ffecom_decl_field (ref, unitfield, "file",
2224                                      string_type_node);
2225       filelenfield = ffecom_decl_field (ref, filefield, "filelen",
2226                                         ffecom_f2c_ftnlen_type_node);
2227       statfield = ffecom_decl_field (ref, filelenfield, "stat",
2228                                      string_type_node);
2229       accessfield = ffecom_decl_field (ref, statfield, "access",
2230                                        string_type_node);
2231       formfield = ffecom_decl_field (ref, accessfield, "form",
2232                                      string_type_node);
2233       reclfield = ffecom_decl_field (ref, formfield, "recl",
2234                                      ffecom_f2c_ftnint_type_node);
2235       blankfield = ffecom_decl_field (ref, reclfield, "blank",
2236                                       string_type_node);
2237
2238       TYPE_FIELDS (ref) = errfield;
2239       layout_type (ref);
2240
2241       ggc_add_tree_root (&f2c_open_struct, 1);
2242
2243       f2c_open_struct = ref;
2244     }
2245
2246   /* Try to do as much compile-time initialization of the structure
2247      as possible, to save run time.  */
2248
2249   ffeste_f2c_init_flag_ (have_err, errinit);
2250
2251   unitexp = ffecom_const_expr (unit_expr);
2252   if (unitexp)
2253     unitinit = unitexp;
2254   else
2255     {
2256       unitinit = ffecom_integer_zero_node;
2257       constantp = FALSE;
2258     }
2259
2260   ffeste_f2c_init_char_ (fileexp, fileinit, filelenexp, fileleninit,
2261                          file_spec);
2262   ffeste_f2c_init_charnolen_ (statexp, statinit, stat_spec);
2263   ffeste_f2c_init_charnolen_ (accessexp, accessinit, access_spec);
2264   ffeste_f2c_init_charnolen_ (formexp, forminit, form_spec);
2265   ffeste_f2c_init_int_ (reclexp, reclinit, recl_spec);
2266   ffeste_f2c_init_charnolen_ (blankexp, blankinit, blank_spec);
2267
2268   inits = build_tree_list ((field = TYPE_FIELDS (f2c_open_struct)), errinit);
2269   initn = inits;
2270   ffeste_f2c_init_next_ (unitinit);
2271   ffeste_f2c_init_next_ (fileinit);
2272   ffeste_f2c_init_next_ (fileleninit);
2273   ffeste_f2c_init_next_ (statinit);
2274   ffeste_f2c_init_next_ (accessinit);
2275   ffeste_f2c_init_next_ (forminit);
2276   ffeste_f2c_init_next_ (reclinit);
2277   ffeste_f2c_init_next_ (blankinit);
2278
2279   inits = build (CONSTRUCTOR, f2c_open_struct, NULL_TREE, inits);
2280   TREE_CONSTANT (inits) = constantp ? 1 : 0;
2281   TREE_STATIC (inits) = 1;
2282
2283   yes = suspend_momentary ();
2284
2285   t = build_decl (VAR_DECL,
2286                   ffecom_get_invented_identifier ("__g77_olist_%d",
2287                                                   mynumber++),
2288                   f2c_open_struct);
2289   TREE_STATIC (t) = 1;
2290   t = ffecom_start_decl (t, 1);
2291   ffecom_finish_decl (t, inits, 0);
2292
2293   resume_momentary (yes);
2294
2295   /* Prepare run-time expressions.  */
2296
2297   if (! unitexp)
2298     ffecom_prepare_expr (unit_expr);
2299
2300   ffeste_f2c_prepare_char_ (file_spec, fileexp);
2301   ffeste_f2c_prepare_charnolen_ (stat_spec, statexp);
2302   ffeste_f2c_prepare_charnolen_ (access_spec, accessexp);
2303   ffeste_f2c_prepare_charnolen_ (form_spec, formexp);
2304   ffeste_f2c_prepare_int_ (recl_spec, reclexp);
2305   ffeste_f2c_prepare_charnolen_ (blank_spec, blankexp);
2306
2307   ffecom_prepare_end ();
2308
2309   /* Now evaluate run-time expressions as needed.  */
2310
2311   if (! unitexp)
2312     {
2313       unitexp = ffecom_expr (unit_expr);
2314       ffeste_f2c_compile_ (unitfield, unitexp);
2315     }
2316
2317   ffeste_f2c_compile_char_ (filefield, filelenfield, file_spec, fileexp,
2318                             filelenexp);
2319   ffeste_f2c_compile_charnolen_ (statfield, stat_spec, statexp);
2320   ffeste_f2c_compile_charnolen_ (accessfield, access_spec, accessexp);
2321   ffeste_f2c_compile_charnolen_ (formfield, form_spec, formexp);
2322   ffeste_f2c_compile_int_ (reclfield, recl_spec, reclexp);
2323   ffeste_f2c_compile_charnolen_ (blankfield, blank_spec, blankexp);
2324
2325   ttype = build_pointer_type (TREE_TYPE (t));
2326   t = ffecom_1 (ADDR_EXPR, ttype, t);
2327
2328   t = build_tree_list (NULL_TREE, t);
2329
2330   return t;
2331 }
2332
2333 #endif
2334 /* Display file-statement specifier.  */
2335
2336 #if FFECOM_targetCURRENT == FFECOM_targetFFE
2337 static void
2338 ffeste_subr_file_ (const char *kw, ffestpFile *spec)
2339 {
2340   if (!spec->kw_or_val_present)
2341     return;
2342   fputs (kw, dmpout);
2343   if (spec->value_present)
2344     {
2345       fputc ('=', dmpout);
2346       if (spec->value_is_label)
2347         {
2348           assert (spec->value_is_label == 2);   /* Temporary checking only. */
2349           fprintf (dmpout, "%" ffelabValue_f "u",
2350                    ffelab_value (spec->u.label));
2351         }
2352       else
2353         ffebld_dump (spec->u.expr);
2354     }
2355   fputc (',', dmpout);
2356 }
2357 #endif
2358
2359 /* Generate code for BACKSPACE/ENDFILE/REWIND.  */
2360
2361 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2362 static void
2363 ffeste_subr_beru_ (ffestpBeruStmt *info, ffecomGfrt rt)
2364 {
2365   tree alist;
2366   bool iostat;
2367   bool errl;
2368
2369   ffeste_emit_line_note_ ();
2370
2371 #define specified(something) (info->beru_spec[something].kw_or_val_present)
2372
2373   iostat = specified (FFESTP_beruixIOSTAT);
2374   errl = specified (FFESTP_beruixERR);
2375
2376 #undef specified
2377
2378   /* ~~For now, we assume the unit number is specified and is not ASTERISK,
2379      because the FFE doesn't support BACKSPACE(*) and rejects a BACKSPACE
2380      without any unit specifier.  f2c, however, supports the former
2381      construct.  When it is time to add this feature to the FFE, which
2382      probably is fairly easy, ffestc_R919 and company will want to pass an
2383      ffestvUnit indicator of FFESTV_unitINTEXPR or _unitASTERISK to
2384      ffeste_R919 and company, and they will want to pass that same value to
2385      this function, and that argument will replace the constant _unitINTEXPR_
2386      in the call below.  Right now, the default unit number, 6, is ignored.  */
2387
2388   ffeste_start_stmt_ ();
2389
2390   if (errl)
2391     {
2392       /* Have ERR= specification.   */
2393
2394       ffeste_io_err_
2395         = ffeste_io_abort_
2396         = ffecom_lookup_label
2397         (info->beru_spec[FFESTP_beruixERR].u.label);
2398       ffeste_io_abort_is_temp_ = FALSE;
2399     }
2400   else
2401     {
2402       /* No ERR= specification.  */
2403
2404       ffeste_io_err_ = NULL_TREE;
2405
2406       if ((ffeste_io_abort_is_temp_ = iostat))
2407         ffeste_io_abort_ = ffecom_temp_label ();
2408       else
2409         ffeste_io_abort_ = NULL_TREE;
2410     }
2411
2412   if (iostat)
2413     {
2414       /* Have IOSTAT= specification.  */
2415
2416       ffeste_io_iostat_is_temp_ = FALSE;
2417       ffeste_io_iostat_ = ffecom_expr
2418         (info->beru_spec[FFESTP_beruixIOSTAT].u.expr);
2419     }
2420   else if (ffeste_io_abort_ != NULL_TREE)
2421     {
2422       /* Have no IOSTAT= but have ERR=.  */
2423
2424       ffeste_io_iostat_is_temp_ = TRUE;
2425       ffeste_io_iostat_
2426         = ffecom_make_tempvar ("beru", ffecom_integer_type_node,
2427                                FFETARGET_charactersizeNONE, -1);
2428     }
2429   else
2430     {
2431       /* No IOSTAT= or ERR= specification.  */
2432
2433       ffeste_io_iostat_is_temp_ = FALSE;
2434       ffeste_io_iostat_ = NULL_TREE;
2435     }
2436
2437   /* Now prescan, then convert, all the arguments.  */
2438
2439   alist = ffeste_io_ialist_ (errl || iostat, FFESTV_unitINTEXPR,
2440                              info->beru_spec[FFESTP_beruixUNIT].u.expr, 6);
2441
2442   /* Don't generate "if (iostat != 0) goto label;" if label is temp abort
2443      label, since we're gonna fall through to there anyway. */
2444
2445   ffeste_io_call_ (ffecom_call_gfrt (rt, alist, NULL_TREE),
2446                    ! ffeste_io_abort_is_temp_);
2447
2448   /* If we've got a temp label, generate its code here. */
2449
2450   if (ffeste_io_abort_is_temp_)
2451     {
2452       DECL_INITIAL (ffeste_io_abort_) = error_mark_node;
2453       emit_nop ();
2454       expand_label (ffeste_io_abort_);
2455
2456       assert (ffeste_io_err_ == NULL_TREE);
2457     }
2458
2459   ffeste_end_stmt_ ();
2460 }
2461 #endif
2462
2463 /* END DO statement
2464
2465    Also invoked by _labeldef_branch_finish_ (or, in cases
2466    of errors, other _labeldef_ functions) when the label definition is
2467    for a DO-target (LOOPEND) label, once per matching/outstanding DO
2468    block on the stack.  */
2469
2470 void
2471 ffeste_do (ffestw block)
2472 {
2473 #if FFECOM_targetCURRENT == FFECOM_targetFFE
2474   fputs ("+ END_DO\n", dmpout);
2475 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
2476   ffeste_emit_line_note_ ();
2477
2478   if (ffestw_do_tvar (block) == 0)
2479     {
2480       expand_end_loop ();               /* DO WHILE and just DO. */
2481
2482       ffeste_end_block_ (block);
2483     }
2484   else
2485     ffeste_end_iterdo_ (block,
2486                         ffestw_do_tvar (block),
2487                         ffestw_do_incr_saved (block),
2488                         ffestw_do_count_var (block));
2489 #else
2490 #error
2491 #endif
2492 }
2493
2494 /* End of statement following logical IF.
2495
2496    Applies to *only* logical IF, not to IF-THEN.  */
2497
2498 void
2499 ffeste_end_R807 ()
2500 {
2501 #if FFECOM_targetCURRENT == FFECOM_targetFFE
2502   fputs ("+ END_IF\n", dmpout); /* Also see ffeste_R806. */
2503 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
2504   ffeste_emit_line_note_ ();
2505
2506   expand_end_cond ();
2507
2508   ffeste_end_block_ (NULL);
2509 #else
2510 #error
2511 #endif
2512 }
2513
2514 /* Generate "code" for branch label definition.  */
2515
2516 void
2517 ffeste_labeldef_branch (ffelab label)
2518 {
2519 #if FFECOM_targetCURRENT == FFECOM_targetFFE
2520   fprintf (dmpout, "+ label %lu\n", ffelab_value (label));
2521 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
2522   {
2523     tree glabel;
2524
2525     glabel = ffecom_lookup_label (label);
2526     assert (glabel != NULL_TREE);
2527     if (TREE_CODE (glabel) == ERROR_MARK)
2528       return;
2529
2530     assert (DECL_INITIAL (glabel) == NULL_TREE);
2531
2532     DECL_INITIAL (glabel) = error_mark_node;
2533     DECL_SOURCE_FILE (glabel) = ffelab_definition_filename (label);
2534     DECL_SOURCE_LINE (glabel) = ffelab_definition_filelinenum (label);
2535
2536     emit_nop ();
2537
2538     expand_label (glabel);
2539   }
2540 #else
2541 #error
2542 #endif
2543 }
2544
2545 /* Generate "code" for FORMAT label definition.  */
2546
2547 void
2548 ffeste_labeldef_format (ffelab label)
2549 {
2550 #if FFECOM_targetCURRENT == FFECOM_targetFFE
2551   fprintf (dmpout, "$ label %lu\n", ffelab_value (label));
2552 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
2553   ffeste_label_formatdef_ = label;
2554 #else
2555 #error
2556 #endif
2557 }
2558
2559 /* Assignment statement (outside of WHERE).  */
2560
2561 void
2562 ffeste_R737A (ffebld dest, ffebld source)
2563 {
2564   ffeste_check_simple_ ();
2565
2566 #if FFECOM_targetCURRENT == FFECOM_targetFFE
2567   fputs ("+ let ", dmpout);
2568   ffebld_dump (dest);
2569   fputs ("=", dmpout);
2570   ffebld_dump (source);
2571   fputc ('\n', dmpout);
2572 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
2573   ffeste_emit_line_note_ ();
2574
2575   ffeste_start_stmt_ ();
2576
2577   ffecom_expand_let_stmt (dest, source);
2578
2579   ffeste_end_stmt_ ();
2580 #else
2581 #error
2582 #endif
2583 }
2584
2585 /* Block IF (IF-THEN) statement.  */
2586
2587 void
2588 ffeste_R803 (ffestw block, ffebld expr)
2589 {
2590   ffeste_check_simple_ ();
2591
2592 #if FFECOM_targetCURRENT == FFECOM_targetFFE
2593   fputs ("+ IF_block (", dmpout);
2594   ffebld_dump (expr);
2595   fputs (")\n", dmpout);
2596 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
2597   {
2598     tree temp;
2599
2600     ffeste_emit_line_note_ ();
2601
2602     ffeste_start_block_ (block);
2603
2604     temp = ffecom_make_tempvar ("ifthen", integer_type_node,
2605                                 FFETARGET_charactersizeNONE, -1);
2606
2607     ffeste_start_stmt_ ();
2608
2609     ffecom_prepare_expr (expr);
2610
2611     if (ffecom_prepare_end ())
2612       {
2613         tree result;
2614
2615         result = ffecom_modify (void_type_node,
2616                                 temp,
2617                                 ffecom_truth_value (ffecom_expr (expr)));
2618
2619         expand_expr_stmt (result);
2620
2621         ffeste_end_stmt_ ();
2622       }
2623     else
2624       {
2625         ffeste_end_stmt_ ();
2626
2627         temp = ffecom_truth_value (ffecom_expr (expr));
2628       }
2629
2630     expand_start_cond (temp, 0);
2631
2632     /* No fake `else' constructs introduced (yet).  */
2633     ffestw_set_ifthen_fake_else (block, 0);
2634   }
2635 #else
2636 #error
2637 #endif
2638 }
2639
2640 /* ELSE IF statement.  */
2641
2642 void
2643 ffeste_R804 (ffestw block, ffebld expr)
2644 {
2645   ffeste_check_simple_ ();
2646
2647 #if FFECOM_targetCURRENT == FFECOM_targetFFE
2648   fputs ("+ ELSE_IF (", dmpout);
2649   ffebld_dump (expr);
2650   fputs (")\n", dmpout);
2651 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
2652   {
2653     tree temp;
2654
2655     ffeste_emit_line_note_ ();
2656
2657     /* Since ELSEIF(expr) might require preparations for expr,
2658        implement as ELSE; prepare-expr; IF (expr) THEN ...; ENDIF.  */
2659
2660     expand_start_else ();
2661
2662     ffeste_start_block_ (block);
2663
2664     temp = ffecom_make_tempvar ("elseif", integer_type_node,
2665                                 FFETARGET_charactersizeNONE, -1);
2666
2667     ffeste_start_stmt_ ();
2668
2669     ffecom_prepare_expr (expr);
2670
2671     if (ffecom_prepare_end ())
2672       {
2673         tree result;
2674
2675         result = ffecom_modify (void_type_node,
2676                                 temp,
2677                                 ffecom_truth_value (ffecom_expr (expr)));
2678
2679         expand_expr_stmt (result);
2680
2681         ffeste_end_stmt_ ();
2682       }
2683     else
2684       {
2685         /* In this case, we could probably have used expand_start_elseif
2686            instead, saving the need for a fake `else' construct.  But,
2687            until it's clear that'd improve performance, it's easier this
2688            way, since we have to expand_start_else before we get to this
2689            test, given the current design.  */
2690
2691         ffeste_end_stmt_ ();
2692
2693         temp = ffecom_truth_value (ffecom_expr (expr));
2694       }
2695
2696     expand_start_cond (temp, 0);
2697
2698     /* Increment number of fake `else' constructs introduced.  */
2699     ffestw_set_ifthen_fake_else (block,
2700                                  ffestw_ifthen_fake_else (block) + 1);
2701   }
2702 #else
2703 #error
2704 #endif
2705 }
2706
2707 /* ELSE statement.  */
2708
2709 void
2710 ffeste_R805 (ffestw block UNUSED)
2711 {
2712   ffeste_check_simple_ ();
2713
2714 #if FFECOM_targetCURRENT == FFECOM_targetFFE
2715   fputs ("+ ELSE\n", dmpout);
2716 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
2717   ffeste_emit_line_note_ ();
2718
2719   expand_start_else ();
2720 #else
2721 #error
2722 #endif
2723 }
2724
2725 /* END IF statement.  */
2726
2727 void
2728 ffeste_R806 (ffestw block)
2729 {
2730 #if FFECOM_targetCURRENT == FFECOM_targetFFE
2731   fputs ("+ END_IF_then\n", dmpout);    /* Also see ffeste_shriek_if_. */
2732 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
2733   {
2734     int i = ffestw_ifthen_fake_else (block) + 1;
2735
2736     ffeste_emit_line_note_ ();
2737
2738     for (; i; --i)
2739       {
2740         expand_end_cond ();
2741
2742         ffeste_end_block_ (block);
2743       }
2744   }
2745 #else
2746 #error
2747 #endif
2748 }
2749
2750 /* Logical IF statement.  */
2751
2752 void
2753 ffeste_R807 (ffebld expr)
2754 {
2755   ffeste_check_simple_ ();
2756
2757 #if FFECOM_targetCURRENT == FFECOM_targetFFE
2758   fputs ("+ IF_logical (", dmpout);
2759   ffebld_dump (expr);
2760   fputs (")\n", dmpout);
2761 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
2762   {
2763     tree temp;
2764
2765     ffeste_emit_line_note_ ();
2766
2767     ffeste_start_block_ (NULL);
2768
2769     temp = ffecom_make_tempvar ("if", integer_type_node,
2770                                 FFETARGET_charactersizeNONE, -1);
2771
2772     ffeste_start_stmt_ ();
2773
2774     ffecom_prepare_expr (expr);
2775
2776     if (ffecom_prepare_end ())
2777       {
2778         tree result;
2779
2780         result = ffecom_modify (void_type_node,
2781                                 temp,
2782                                 ffecom_truth_value (ffecom_expr (expr)));
2783
2784         expand_expr_stmt (result);
2785
2786         ffeste_end_stmt_ ();
2787       }
2788     else
2789       {
2790         ffeste_end_stmt_ ();
2791
2792         temp = ffecom_truth_value (ffecom_expr (expr));
2793       }
2794
2795     expand_start_cond (temp, 0);
2796   }
2797 #else
2798 #error
2799 #endif
2800 }
2801
2802 /* SELECT CASE statement.  */
2803
2804 void
2805 ffeste_R809 (ffestw block, ffebld expr)
2806 {
2807   ffeste_check_simple_ ();
2808
2809 #if FFECOM_targetCURRENT == FFECOM_targetFFE
2810   fputs ("+ SELECT_CASE (", dmpout);
2811   ffebld_dump (expr);
2812   fputs (")\n", dmpout);
2813 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
2814   ffeste_emit_line_note_ ();
2815
2816   ffeste_start_block_ (block);
2817
2818   if ((expr == NULL)
2819       || (ffeinfo_basictype (ffebld_info (expr))
2820           == FFEINFO_basictypeANY))
2821     ffestw_set_select_texpr (block, error_mark_node);
2822   else if (ffeinfo_basictype (ffebld_info (expr))
2823            == FFEINFO_basictypeCHARACTER)
2824     {
2825       /* ~~~Someday handle CHARACTER*1, CHARACTER*N */
2826
2827       ffebad_start_msg ("SELECT CASE on CHARACTER type (at %0) not supported -- sorry",
2828                         FFEBAD_severityFATAL);
2829       ffebad_here (0, ffestw_line (block), ffestw_col (block));
2830       ffebad_finish ();
2831       ffestw_set_select_texpr (block, error_mark_node);
2832     }
2833   else
2834     {
2835       tree result;
2836       tree texpr;
2837
2838       result = ffecom_make_tempvar ("select", ffecom_type_expr (expr),
2839                                     ffeinfo_size (ffebld_info (expr)),
2840                                     -1);
2841
2842       ffeste_start_stmt_ ();
2843
2844       ffecom_prepare_expr (expr);
2845
2846       ffecom_prepare_end ();
2847
2848       texpr = ffecom_expr (expr);
2849
2850       assert (TYPE_MAIN_VARIANT (TREE_TYPE (texpr))
2851               == TYPE_MAIN_VARIANT (TREE_TYPE (result)));
2852
2853       texpr = ffecom_modify (void_type_node,
2854                              result,
2855                              texpr);
2856       expand_expr_stmt (texpr);
2857
2858       ffeste_end_stmt_ ();
2859
2860       expand_start_case (1, result, TREE_TYPE (result),
2861                          "SELECT CASE statement");
2862       ffestw_set_select_texpr (block, texpr);
2863       ffestw_set_select_break (block, FALSE);
2864     }
2865 #else
2866 #error
2867 #endif
2868 }
2869
2870 /* CASE statement.
2871
2872    If casenum is 0, it's CASE DEFAULT.  Else it's the case ranges at
2873    the start of the first_stmt list in the select object at the top of
2874    the stack that match casenum.  */
2875
2876 void
2877 ffeste_R810 (ffestw block, unsigned long casenum)
2878 {
2879   ffestwSelect s = ffestw_select (block);
2880   ffestwCase c;
2881
2882   ffeste_check_simple_ ();
2883
2884   if (s->first_stmt == (ffestwCase) &s->first_rel)
2885     c = NULL;
2886   else
2887     c = s->first_stmt;
2888
2889 #if FFECOM_targetCURRENT == FFECOM_targetFFE
2890   if ((c == NULL) || (casenum != c->casenum))
2891     {
2892       if (casenum == 0)         /* Intentional CASE DEFAULT. */
2893         fputs ("+ CASE_DEFAULT", dmpout);
2894     }
2895   else
2896     {
2897       bool comma = FALSE;
2898
2899       fputs ("+ CASE (", dmpout);
2900       do
2901         {
2902           if (comma)
2903             fputc (',', dmpout);
2904           else
2905             comma = TRUE;
2906           if (c->low != NULL)
2907             ffebld_constant_dump (c->low);
2908           if (c->low != c->high)
2909             {
2910               fputc (':', dmpout);
2911               if (c->high != NULL)
2912                 ffebld_constant_dump (c->high);
2913             }
2914           c = c->next_stmt;
2915           /* Unlink prev.  */
2916           c->previous_stmt->previous_stmt->next_stmt = c;
2917           c->previous_stmt = c->previous_stmt->previous_stmt;
2918         }
2919       while ((c != (ffestwCase) &s->first_rel) && (casenum == c->casenum));
2920       fputc (')', dmpout);
2921     }
2922
2923   fputc ('\n', dmpout);
2924 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
2925   {
2926     tree texprlow;
2927     tree texprhigh;
2928     tree tlabel;
2929     int pushok;
2930     tree duplicate;
2931
2932     ffeste_emit_line_note_ ();
2933
2934     if (ffestw_select_texpr (block) == error_mark_node)
2935       return;
2936
2937     /* ~~~Someday handle CHARACTER*1, CHARACTER*N */
2938
2939     tlabel = build_decl (LABEL_DECL, NULL_TREE, NULL_TREE);
2940
2941     if (ffestw_select_break (block))
2942       expand_exit_something ();
2943     else
2944       ffestw_set_select_break (block, TRUE);
2945
2946     if ((c == NULL) || (casenum != c->casenum))
2947       {
2948         if (casenum == 0)       /* Intentional CASE DEFAULT. */
2949           {
2950             pushok = pushcase (NULL_TREE, 0, tlabel, &duplicate);
2951             assert (pushok == 0);
2952           }
2953       }
2954     else
2955       do
2956         {
2957           texprlow = (c->low == NULL) ? NULL_TREE
2958             : ffecom_constantunion (&ffebld_constant_union (c->low), s->type,
2959                        s->kindtype, ffecom_tree_type[s->type][s->kindtype]);
2960           if (c->low != c->high)
2961             {
2962               texprhigh = (c->high == NULL) ? NULL_TREE
2963                 : ffecom_constantunion (&ffebld_constant_union (c->high),
2964               s->type, s->kindtype, ffecom_tree_type[s->type][s->kindtype]);
2965               pushok = pushcase_range (texprlow, texprhigh, convert,
2966                                        tlabel, &duplicate);
2967             }
2968           else
2969             pushok = pushcase (texprlow, convert, tlabel, &duplicate);
2970           assert (pushok == 0);
2971           c = c->next_stmt;
2972           /* Unlink prev.  */
2973           c->previous_stmt->previous_stmt->next_stmt = c;
2974           c->previous_stmt = c->previous_stmt->previous_stmt;
2975         }
2976       while ((c != (ffestwCase) &s->first_rel) && (casenum == c->casenum));
2977
2978     clear_momentary ();
2979   }
2980 #else
2981 #error
2982 #endif
2983 }
2984
2985 /* END SELECT statement.  */
2986
2987 void
2988 ffeste_R811 (ffestw block)
2989 {
2990 #if FFECOM_targetCURRENT == FFECOM_targetFFE
2991   fputs ("+ END_SELECT\n", dmpout);
2992 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
2993   ffeste_emit_line_note_ ();
2994
2995   /* ~~~Someday handle CHARACTER*1, CHARACTER*N */
2996
2997   if (TREE_CODE (ffestw_select_texpr (block)) != ERROR_MARK)
2998     expand_end_case (ffestw_select_texpr (block));
2999
3000   ffeste_end_block_ (block);
3001 #else
3002 #error
3003 #endif
3004 }
3005
3006 /* Iterative DO statement.  */
3007
3008 void
3009 ffeste_R819A (ffestw block, ffelab label UNUSED, ffebld var,
3010               ffebld start, ffelexToken start_token,
3011               ffebld end, ffelexToken end_token,
3012               ffebld incr, ffelexToken incr_token)
3013 {
3014   ffeste_check_simple_ ();
3015
3016 #if FFECOM_targetCURRENT == FFECOM_targetFFE
3017   if ((ffebld_op (incr) == FFEBLD_opCONTER)
3018       && (ffebld_constant_is_zero (ffebld_conter (incr))))
3019     {
3020       ffebad_start (FFEBAD_DO_STEP_ZERO);
3021       ffebad_here (0, ffelex_token_where_line (incr_token),
3022                    ffelex_token_where_column (incr_token));
3023       ffebad_string ("Iterative DO loop");
3024       ffebad_finish ();
3025       /* Don't bother replacing it with 1 yet.  */
3026     }
3027
3028   if (label == NULL)
3029     fputs ("+ DO_iterative_nonlabeled (", dmpout);
3030   else
3031     fprintf (dmpout, "+ DO_iterative_labeled %lu (", ffelab_value (label));
3032   ffebld_dump (var);
3033   fputc ('=', dmpout);
3034   ffebld_dump (start);
3035   fputc (',', dmpout);
3036   ffebld_dump (end);
3037   fputc (',', dmpout);
3038   ffebld_dump (incr);
3039   fputs (")\n", dmpout);
3040 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
3041   {
3042     ffeste_emit_line_note_ ();
3043
3044     ffeste_begin_iterdo_ (block, NULL, NULL, NULL,
3045                           var,
3046                           start, start_token,
3047                           end, end_token,
3048                           incr, incr_token,
3049                           "Iterative DO loop");
3050   }
3051 #else
3052 #error
3053 #endif
3054 }
3055
3056 /* DO WHILE statement.  */
3057
3058 void
3059 ffeste_R819B (ffestw block, ffelab label UNUSED, ffebld expr)
3060 {
3061   ffeste_check_simple_ ();
3062
3063 #if FFECOM_targetCURRENT == FFECOM_targetFFE
3064   if (label == NULL)
3065     fputs ("+ DO_WHILE_nonlabeled (", dmpout);
3066   else
3067     fprintf (dmpout, "+ DO_WHILE_labeled %lu (", ffelab_value (label));
3068   ffebld_dump (expr);
3069   fputs (")\n", dmpout);
3070 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
3071   {
3072     tree result;
3073
3074     ffeste_emit_line_note_ ();
3075
3076     ffeste_start_block_ (block);
3077
3078     if (expr)
3079       {
3080         struct nesting *loop;
3081         tree mod;
3082
3083         result = ffecom_make_tempvar ("dowhile", integer_type_node,
3084                                       FFETARGET_charactersizeNONE, -1);
3085         loop = expand_start_loop (1);
3086
3087         ffeste_start_stmt_ ();
3088
3089         ffecom_prepare_expr (expr);
3090
3091         ffecom_prepare_end ();
3092
3093         mod = ffecom_modify (void_type_node,
3094                              result,
3095                              ffecom_truth_value (ffecom_expr (expr)));
3096         expand_expr_stmt (mod);
3097
3098         ffeste_end_stmt_ ();
3099
3100         ffestw_set_do_hook (block, loop);
3101         expand_exit_loop_if_false (0, result);
3102       }
3103     else
3104       ffestw_set_do_hook (block, expand_start_loop (1));
3105
3106     ffestw_set_do_tvar (block, NULL_TREE);
3107   }
3108 #else
3109 #error
3110 #endif
3111 }
3112
3113 /* END DO statement.
3114
3115    This is the MIL-STD 1753 END DO. It's syntactic sugar, similar to
3116    CONTINUE (except that it has to have a label that is the target of
3117    one or more iterative DO statement), not the Fortran-90 structured
3118    END DO, which is handled elsewhere, as is the actual mechanism of
3119    ending an iterative DO statement, even one that ends at a label.  */
3120
3121 void
3122 ffeste_R825 ()
3123 {
3124   ffeste_check_simple_ ();
3125
3126 #if FFECOM_targetCURRENT == FFECOM_targetFFE
3127   fputs ("+ END_DO_sugar\n", dmpout);
3128 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
3129   ffeste_emit_line_note_ ();
3130
3131   emit_nop ();
3132 #else
3133 #error
3134 #endif
3135 }
3136
3137 /* CYCLE statement.  */
3138
3139 void
3140 ffeste_R834 (ffestw block)
3141 {
3142   ffeste_check_simple_ ();
3143
3144 #if FFECOM_targetCURRENT == FFECOM_targetFFE
3145   fprintf (dmpout, "+ CYCLE block #%lu\n", ffestw_blocknum (block));
3146 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
3147   ffeste_emit_line_note_ ();
3148
3149   expand_continue_loop (ffestw_do_hook (block));
3150 #else
3151 #error
3152 #endif
3153 }
3154
3155 /* EXIT statement.  */
3156
3157 void
3158 ffeste_R835 (ffestw block)
3159 {
3160   ffeste_check_simple_ ();
3161
3162 #if FFECOM_targetCURRENT == FFECOM_targetFFE
3163   fprintf (dmpout, "+ EXIT block #%lu\n", ffestw_blocknum (block));
3164 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
3165   ffeste_emit_line_note_ ();
3166
3167   expand_exit_loop (ffestw_do_hook (block));
3168 #else
3169 #error
3170 #endif
3171 }
3172
3173 /* GOTO statement.  */
3174
3175 void
3176 ffeste_R836 (ffelab label)
3177 {
3178   ffeste_check_simple_ ();
3179
3180 #if FFECOM_targetCURRENT == FFECOM_targetFFE
3181   fprintf (dmpout, "+ GOTO %lu\n", ffelab_value (label));
3182 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
3183   {
3184     tree glabel;
3185
3186     ffeste_emit_line_note_ ();
3187
3188     glabel = ffecom_lookup_label (label);
3189     if ((glabel != NULL_TREE)
3190         && (TREE_CODE (glabel) != ERROR_MARK))
3191       {
3192         expand_goto (glabel);
3193         TREE_USED (glabel) = 1;
3194       }
3195   }
3196 #else
3197 #error
3198 #endif
3199 }
3200
3201 /* Computed GOTO statement.  */
3202
3203 void
3204 ffeste_R837 (ffelab *labels, int count, ffebld expr)
3205 {
3206   int i;
3207
3208   ffeste_check_simple_ ();
3209
3210 #if FFECOM_targetCURRENT == FFECOM_targetFFE
3211   fputs ("+ CGOTO (", dmpout);
3212   for (i = 0; i < count; ++i)
3213     {
3214       if (i != 0)
3215         fputc (',', dmpout);
3216       fprintf (dmpout, "%" ffelabValue_f "u", ffelab_value (labels[i]));
3217     }
3218   fputs ("),", dmpout);
3219   ffebld_dump (expr);
3220   fputc ('\n', dmpout);
3221 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
3222   {
3223     tree texpr;
3224     tree value;
3225     tree tlabel;
3226     int pushok;
3227     tree duplicate;
3228
3229     ffeste_emit_line_note_ ();
3230
3231     ffeste_start_stmt_ ();
3232
3233     ffecom_prepare_expr (expr);
3234
3235     ffecom_prepare_end ();
3236
3237     texpr = ffecom_expr (expr);
3238
3239     expand_start_case (0, texpr, TREE_TYPE (texpr), "computed GOTO statement");
3240
3241     for (i = 0; i < count; ++i)
3242       {
3243         value = build_int_2 (i + 1, 0);
3244         tlabel = build_decl (LABEL_DECL, NULL_TREE, NULL_TREE);
3245
3246         pushok = pushcase (value, convert, tlabel, &duplicate);
3247         assert (pushok == 0);
3248
3249         tlabel = ffecom_lookup_label (labels[i]);
3250         if ((tlabel == NULL_TREE)
3251             || (TREE_CODE (tlabel) == ERROR_MARK))
3252           continue;
3253
3254         expand_goto (tlabel);
3255         TREE_USED (tlabel) = 1;
3256       }
3257     expand_end_case (texpr);
3258
3259     ffeste_end_stmt_ ();
3260   }
3261 #else
3262 #error
3263 #endif
3264 }
3265
3266 /* ASSIGN statement.  */
3267
3268 void
3269 ffeste_R838 (ffelab label, ffebld target)
3270 {
3271   ffeste_check_simple_ ();
3272
3273 #if FFECOM_targetCURRENT == FFECOM_targetFFE
3274   fprintf (dmpout, "+ ASSIGN %lu TO ", ffelab_value (label));
3275   ffebld_dump (target);
3276   fputc ('\n', dmpout);
3277 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
3278   {
3279     tree expr_tree;
3280     tree label_tree;
3281     tree target_tree;
3282
3283     ffeste_emit_line_note_ ();
3284
3285     /* No need to call ffeste_start_stmt_(), as the sorts of expressions
3286        seen here should never require use of temporaries.  */
3287
3288     label_tree = ffecom_lookup_label (label);
3289     if ((label_tree != NULL_TREE)
3290         && (TREE_CODE (label_tree) != ERROR_MARK))
3291       {
3292         label_tree = ffecom_1 (ADDR_EXPR,
3293                                build_pointer_type (void_type_node),
3294                                label_tree);
3295         TREE_CONSTANT (label_tree) = 1;
3296
3297         target_tree = ffecom_expr_assign_w (target);
3298         if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (target_tree)))
3299             < GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (label_tree))))
3300           error ("ASSIGN to variable that is too small");
3301
3302         label_tree = convert (TREE_TYPE (target_tree), label_tree);
3303
3304         expr_tree = ffecom_modify (void_type_node,
3305                                    target_tree,
3306                                    label_tree);
3307         expand_expr_stmt (expr_tree);
3308
3309         clear_momentary ();
3310       }
3311   }
3312 #else
3313 #error
3314 #endif
3315 }
3316
3317 /* Assigned GOTO statement.  */
3318
3319 void
3320 ffeste_R839 (ffebld target)
3321 {
3322   ffeste_check_simple_ ();
3323
3324 #if FFECOM_targetCURRENT == FFECOM_targetFFE
3325   fputs ("+ AGOTO ", dmpout);
3326   ffebld_dump (target);
3327   fputc ('\n', dmpout);
3328 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
3329   {
3330     tree t;
3331
3332     ffeste_emit_line_note_ ();
3333
3334     /* No need to call ffeste_start_stmt_(), as the sorts of expressions
3335        seen here should never require use of temporaries.  */
3336
3337     t = ffecom_expr_assign (target);
3338     if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (t)))
3339         < GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
3340       error ("ASSIGNed GOTO target variable is too small");
3341
3342     expand_computed_goto (convert (TREE_TYPE (null_pointer_node), t));
3343
3344     clear_momentary ();
3345   }
3346 #else
3347 #error
3348 #endif
3349 }
3350
3351 /* Arithmetic IF statement.  */
3352
3353 void
3354 ffeste_R840 (ffebld expr, ffelab neg, ffelab zero, ffelab pos)
3355 {
3356   ffeste_check_simple_ ();
3357
3358 #if FFECOM_targetCURRENT == FFECOM_targetFFE
3359   fputs ("+ IF_arithmetic (", dmpout);
3360   ffebld_dump (expr);
3361   fprintf (dmpout, ") %" ffelabValue_f "u,%" ffelabValue_f "u,%" ffelabValue_f "u\n",
3362            ffelab_value (neg), ffelab_value (zero), ffelab_value (pos));
3363 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
3364   {
3365     tree gneg = ffecom_lookup_label (neg);
3366     tree gzero = ffecom_lookup_label (zero);
3367     tree gpos = ffecom_lookup_label (pos);
3368     tree texpr;
3369
3370     ffeste_emit_line_note_ ();
3371
3372     if ((gneg == NULL_TREE) || (gzero == NULL_TREE) || (gpos == NULL_TREE))
3373       return;
3374     if ((TREE_CODE (gneg) == ERROR_MARK)
3375         || (TREE_CODE (gzero) == ERROR_MARK)
3376         || (TREE_CODE (gpos) == ERROR_MARK))
3377       return;
3378
3379     ffeste_start_stmt_ ();
3380
3381     ffecom_prepare_expr (expr);
3382
3383     ffecom_prepare_end ();
3384
3385     if (neg == zero)
3386       {
3387         if (neg == pos)
3388           expand_goto (gzero);
3389         else
3390           {
3391             /* IF (expr.LE.0) THEN GOTO neg/zero ELSE GOTO pos.  */
3392             texpr = ffecom_expr (expr);
3393             texpr = ffecom_2 (LE_EXPR, integer_type_node,
3394                               texpr,
3395                               convert (TREE_TYPE (texpr),
3396                                        integer_zero_node));
3397             expand_start_cond (ffecom_truth_value (texpr), 0);
3398             expand_goto (gzero);
3399             expand_start_else ();
3400             expand_goto (gpos);
3401             expand_end_cond ();
3402           }
3403       }
3404     else if (neg == pos)
3405       {
3406         /* IF (expr.NE.0) THEN GOTO neg/pos ELSE GOTO zero.  */
3407         texpr = ffecom_expr (expr);
3408         texpr = ffecom_2 (NE_EXPR, integer_type_node,
3409                           texpr,
3410                           convert (TREE_TYPE (texpr),
3411                                    integer_zero_node));
3412         expand_start_cond (ffecom_truth_value (texpr), 0);
3413         expand_goto (gneg);
3414         expand_start_else ();
3415         expand_goto (gzero);
3416         expand_end_cond ();
3417       }
3418     else if (zero == pos)
3419       {
3420         /* IF (expr.GE.0) THEN GOTO zero/pos ELSE GOTO neg.  */
3421         texpr = ffecom_expr (expr);
3422         texpr = ffecom_2 (GE_EXPR, integer_type_node,
3423                           texpr,
3424                           convert (TREE_TYPE (texpr),
3425                                    integer_zero_node));
3426         expand_start_cond (ffecom_truth_value (texpr), 0);
3427         expand_goto (gzero);
3428         expand_start_else ();
3429         expand_goto (gneg);
3430         expand_end_cond ();
3431       }
3432     else
3433       {
3434         /* Use a SAVE_EXPR in combo with:
3435            IF (expr.LT.0) THEN GOTO neg
3436            ELSEIF (expr.GT.0) THEN GOTO pos
3437            ELSE GOTO zero.  */
3438         tree expr_saved = ffecom_save_tree (ffecom_expr (expr));
3439
3440         texpr = ffecom_2 (LT_EXPR, integer_type_node,
3441                           expr_saved,
3442                           convert (TREE_TYPE (expr_saved),
3443                                    integer_zero_node));
3444         expand_start_cond (ffecom_truth_value (texpr), 0);
3445         expand_goto (gneg);
3446         texpr = ffecom_2 (GT_EXPR, integer_type_node,
3447                           expr_saved,
3448                           convert (TREE_TYPE (expr_saved),
3449                                    integer_zero_node));
3450         expand_start_elseif (ffecom_truth_value (texpr));
3451         expand_goto (gpos);
3452         expand_start_else ();
3453         expand_goto (gzero);
3454         expand_end_cond ();
3455       }
3456
3457     ffeste_end_stmt_ ();
3458   }
3459 #else
3460 #error
3461 #endif
3462 }
3463
3464 /* CONTINUE statement.  */
3465
3466 void
3467 ffeste_R841 ()
3468 {
3469   ffeste_check_simple_ ();
3470
3471 #if FFECOM_targetCURRENT == FFECOM_targetFFE
3472   fputs ("+ CONTINUE\n", dmpout);
3473 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
3474   ffeste_emit_line_note_ ();
3475
3476   emit_nop ();
3477 #else
3478 #error
3479 #endif
3480 }
3481
3482 /* STOP statement.  */
3483
3484 void
3485 ffeste_R842 (ffebld expr)
3486 {
3487   ffeste_check_simple_ ();
3488
3489 #if FFECOM_targetCURRENT == FFECOM_targetFFE
3490   if (expr == NULL)
3491     {
3492       fputs ("+ STOP\n", dmpout);
3493     }
3494   else
3495     {
3496       fputs ("+ STOP_coded ", dmpout);
3497       ffebld_dump (expr);
3498       fputc ('\n', dmpout);
3499     }
3500 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
3501   {
3502     tree callit;
3503     ffelexToken msg;
3504
3505     ffeste_emit_line_note_ ();
3506
3507     if ((expr == NULL)
3508         || (ffeinfo_basictype (ffebld_info (expr))
3509             == FFEINFO_basictypeANY))
3510       {
3511         msg = ffelex_token_new_character ("", ffelex_token_where_line
3512                                (ffesta_tokens[0]), ffelex_token_where_column
3513                                           (ffesta_tokens[0]));
3514         expr = ffebld_new_conter (ffebld_constant_new_characterdefault
3515                                   (msg));
3516         ffelex_token_kill (msg);
3517         ffebld_set_info (expr, ffeinfo_new (FFEINFO_basictypeCHARACTER,
3518                     FFEINFO_kindtypeCHARACTERDEFAULT, 0, FFEINFO_kindENTITY,
3519                                             FFEINFO_whereCONSTANT, 0));
3520       }
3521     else if (ffeinfo_basictype (ffebld_info (expr))
3522              == FFEINFO_basictypeINTEGER)
3523       {
3524         char num[50];
3525
3526         assert (ffebld_op (expr) == FFEBLD_opCONTER);
3527         assert (ffeinfo_kindtype (ffebld_info (expr))
3528                 == FFEINFO_kindtypeINTEGERDEFAULT);
3529         sprintf (num, "%" ffetargetIntegerDefault_f "d",
3530                  ffebld_constant_integer1 (ffebld_conter (expr)));
3531         msg = ffelex_token_new_character (num, ffelex_token_where_line
3532                                (ffesta_tokens[0]), ffelex_token_where_column
3533                                           (ffesta_tokens[0]));
3534         expr = ffebld_new_conter (ffebld_constant_new_characterdefault
3535                                   (msg));
3536         ffelex_token_kill (msg);
3537         ffebld_set_info (expr, ffeinfo_new (FFEINFO_basictypeCHARACTER,
3538                     FFEINFO_kindtypeCHARACTERDEFAULT, 0, FFEINFO_kindENTITY,
3539                                             FFEINFO_whereCONSTANT, 0));
3540       }
3541     else
3542       {
3543         assert (ffeinfo_basictype (ffebld_info (expr))
3544                 == FFEINFO_basictypeCHARACTER);
3545         assert (ffebld_op (expr) == FFEBLD_opCONTER);
3546         assert (ffeinfo_kindtype (ffebld_info (expr))
3547                 == FFEINFO_kindtypeCHARACTERDEFAULT);
3548       }
3549
3550     /* No need to call ffeste_start_stmt_(), as the sorts of expressions
3551        seen here should never require use of temporaries.  */
3552
3553     callit = ffecom_call_gfrt (FFECOM_gfrtSTOP,
3554                     ffecom_list_ptr_to_expr (ffebld_new_item (expr, NULL)),
3555                                NULL_TREE);
3556     TREE_SIDE_EFFECTS (callit) = 1;
3557
3558     expand_expr_stmt (callit);
3559
3560     clear_momentary ();
3561   }
3562 #else
3563 #error
3564 #endif
3565 }
3566
3567 /* PAUSE statement.  */
3568
3569 void
3570 ffeste_R843 (ffebld expr)
3571 {
3572   ffeste_check_simple_ ();
3573
3574 #if FFECOM_targetCURRENT == FFECOM_targetFFE
3575   if (expr == NULL)
3576     {
3577       fputs ("+ PAUSE\n", dmpout);
3578     }
3579   else
3580     {
3581       fputs ("+ PAUSE_coded ", dmpout);
3582       ffebld_dump (expr);
3583       fputc ('\n', dmpout);
3584     }
3585 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
3586   {
3587     tree callit;
3588     ffelexToken msg;
3589
3590     ffeste_emit_line_note_ ();
3591
3592     if ((expr == NULL)
3593         || (ffeinfo_basictype (ffebld_info (expr))
3594             == FFEINFO_basictypeANY))
3595       {
3596         msg = ffelex_token_new_character ("", ffelex_token_where_line
3597                                (ffesta_tokens[0]), ffelex_token_where_column
3598                                           (ffesta_tokens[0]));
3599         expr = ffebld_new_conter (ffebld_constant_new_characterdefault
3600                                   (msg));
3601         ffelex_token_kill (msg);
3602         ffebld_set_info (expr, ffeinfo_new (FFEINFO_basictypeCHARACTER,
3603                     FFEINFO_kindtypeCHARACTERDEFAULT, 0, FFEINFO_kindENTITY,
3604                                             FFEINFO_whereCONSTANT, 0));
3605       }
3606     else if (ffeinfo_basictype (ffebld_info (expr))
3607              == FFEINFO_basictypeINTEGER)
3608       {
3609         char num[50];
3610
3611         assert (ffebld_op (expr) == FFEBLD_opCONTER);
3612         assert (ffeinfo_kindtype (ffebld_info (expr))
3613                 == FFEINFO_kindtypeINTEGERDEFAULT);
3614         sprintf (num, "%" ffetargetIntegerDefault_f "d",
3615                  ffebld_constant_integer1 (ffebld_conter (expr)));
3616         msg = ffelex_token_new_character (num, ffelex_token_where_line
3617                                (ffesta_tokens[0]), ffelex_token_where_column
3618                                           (ffesta_tokens[0]));
3619         expr = ffebld_new_conter (ffebld_constant_new_characterdefault
3620                                   (msg));
3621         ffelex_token_kill (msg);
3622         ffebld_set_info (expr, ffeinfo_new (FFEINFO_basictypeCHARACTER,
3623                     FFEINFO_kindtypeCHARACTERDEFAULT, 0, FFEINFO_kindENTITY,
3624                                             FFEINFO_whereCONSTANT, 0));
3625       }
3626     else
3627       {
3628         assert (ffeinfo_basictype (ffebld_info (expr))
3629                 == FFEINFO_basictypeCHARACTER);
3630         assert (ffebld_op (expr) == FFEBLD_opCONTER);
3631         assert (ffeinfo_kindtype (ffebld_info (expr))
3632                 == FFEINFO_kindtypeCHARACTERDEFAULT);
3633       }
3634
3635     /* No need to call ffeste_start_stmt_(), as the sorts of expressions
3636        seen here should never require use of temporaries.  */
3637
3638     callit = ffecom_call_gfrt (FFECOM_gfrtPAUSE,
3639                     ffecom_list_ptr_to_expr (ffebld_new_item (expr, NULL)),
3640                                NULL_TREE);
3641     TREE_SIDE_EFFECTS (callit) = 1;
3642
3643     expand_expr_stmt (callit);
3644
3645     clear_momentary ();
3646   }
3647 #if 0                           /* Old approach for phantom g77 run-time
3648                                    library. */
3649   {
3650     tree callit;
3651
3652     ffeste_emit_line_note_ ();
3653
3654     if (expr == NULL)
3655       callit = ffecom_call_gfrt (FFECOM_gfrtPAUSENIL, NULL_TREE, NULL_TREE);
3656     else if (ffeinfo_basictype (ffebld_info (expr))
3657              == FFEINFO_basictypeINTEGER)
3658       callit = ffecom_call_gfrt (FFECOM_gfrtPAUSEINT,
3659                       ffecom_list_ptr_to_expr (ffebld_new_item (expr, NULL)),
3660                                  NULL_TREE);
3661     else if (ffeinfo_basictype (ffebld_info (expr))
3662              == FFEINFO_basictypeCHARACTER)
3663       callit = ffecom_call_gfrt (FFECOM_gfrtPAUSECHAR,
3664                       ffecom_list_ptr_to_expr (ffebld_new_item (expr, NULL)),
3665                                  NULL_TREE);
3666     else
3667       abort ();
3668     TREE_SIDE_EFFECTS (callit) = 1;
3669
3670     expand_expr_stmt (callit);
3671
3672     clear_momentary ();
3673   }
3674 #endif
3675 #else
3676 #error
3677 #endif
3678 }
3679
3680 /* OPEN statement.  */
3681
3682 void
3683 ffeste_R904 (ffestpOpenStmt *info)
3684 {
3685   ffeste_check_simple_ ();
3686
3687 #if FFECOM_targetCURRENT == FFECOM_targetFFE
3688   fputs ("+ OPEN (", dmpout);
3689   ffeste_subr_file_ ("UNIT", &info->open_spec[FFESTP_openixUNIT]);
3690   ffeste_subr_file_ ("ACCESS", &info->open_spec[FFESTP_openixACCESS]);
3691   ffeste_subr_file_ ("ACTION", &info->open_spec[FFESTP_openixACTION]);
3692   ffeste_subr_file_ ("ASSOCIATEVARIABLE", &info->open_spec[FFESTP_openixASSOCIATEVARIABLE]);
3693   ffeste_subr_file_ ("BLANK", &info->open_spec[FFESTP_openixBLANK]);
3694   ffeste_subr_file_ ("BLOCKSIZE", &info->open_spec[FFESTP_openixBLOCKSIZE]);
3695   ffeste_subr_file_ ("BUFFERCOUNT", &info->open_spec[FFESTP_openixBUFFERCOUNT]);
3696   ffeste_subr_file_ ("CARRIAGECONTROL", &info->open_spec[FFESTP_openixCARRIAGECONTROL]);
3697   ffeste_subr_file_ ("DEFAULTFILE", &info->open_spec[FFESTP_openixDEFAULTFILE]);
3698   ffeste_subr_file_ ("DELIM", &info->open_spec[FFESTP_openixDELIM]);
3699   ffeste_subr_file_ ("DISPOSE", &info->open_spec[FFESTP_openixDISPOSE]);
3700   ffeste_subr_file_ ("ERR", &info->open_spec[FFESTP_openixERR]);
3701   ffeste_subr_file_ ("EXTENDSIZE", &info->open_spec[FFESTP_openixEXTENDSIZE]);
3702   ffeste_subr_file_ ("FILE", &info->open_spec[FFESTP_openixFILE]);
3703   ffeste_subr_file_ ("FORM", &info->open_spec[FFESTP_openixFORM]);
3704   ffeste_subr_file_ ("INITIALSIZE", &info->open_spec[FFESTP_openixINITIALSIZE]);
3705   ffeste_subr_file_ ("IOSTAT", &info->open_spec[FFESTP_openixIOSTAT]);
3706   ffeste_subr_file_ ("KEY", &info->open_spec[FFESTP_openixKEY]);
3707   ffeste_subr_file_ ("MAXREC", &info->open_spec[FFESTP_openixMAXREC]);
3708   ffeste_subr_file_ ("NOSPANBLOCKS", &info->open_spec[FFESTP_openixNOSPANBLOCKS]);
3709   ffeste_subr_file_ ("ORGANIZATION", &info->open_spec[FFESTP_openixORGANIZATION]);
3710   ffeste_subr_file_ ("PAD", &info->open_spec[FFESTP_openixPAD]);
3711   ffeste_subr_file_ ("POSITION", &info->open_spec[FFESTP_openixPOSITION]);
3712   ffeste_subr_file_ ("READONLY", &info->open_spec[FFESTP_openixREADONLY]);
3713   ffeste_subr_file_ ("RECL", &info->open_spec[FFESTP_openixRECL]);
3714   ffeste_subr_file_ ("RECORDTYPE", &info->open_spec[FFESTP_openixRECORDTYPE]);
3715   ffeste_subr_file_ ("SHARED", &info->open_spec[FFESTP_openixSHARED]);
3716   ffeste_subr_file_ ("STATUS", &info->open_spec[FFESTP_openixSTATUS]);
3717   ffeste_subr_file_ ("USEROPEN", &info->open_spec[FFESTP_openixUSEROPEN]);
3718   fputs (")\n", dmpout);
3719 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
3720   {
3721     tree args;
3722     bool iostat;
3723     bool errl;
3724
3725     ffeste_emit_line_note_ ();
3726
3727 #define specified(something) (info->open_spec[something].kw_or_val_present)
3728
3729     iostat = specified (FFESTP_openixIOSTAT);
3730     errl = specified (FFESTP_openixERR);
3731
3732 #undef specified
3733
3734     ffeste_start_stmt_ ();
3735
3736     if (errl)
3737       {
3738         ffeste_io_err_
3739           = ffeste_io_abort_
3740           = ffecom_lookup_label
3741           (info->open_spec[FFESTP_openixERR].u.label);
3742         ffeste_io_abort_is_temp_ = FALSE;
3743       }
3744     else
3745       {
3746         ffeste_io_err_ = NULL_TREE;
3747
3748         if ((ffeste_io_abort_is_temp_ = iostat))
3749           ffeste_io_abort_ = ffecom_temp_label ();
3750         else
3751           ffeste_io_abort_ = NULL_TREE;
3752       }
3753
3754     if (iostat)
3755       {
3756         /* Have IOSTAT= specification.  */
3757
3758         ffeste_io_iostat_is_temp_ = FALSE;
3759         ffeste_io_iostat_ = ffecom_expr
3760           (info->open_spec[FFESTP_openixIOSTAT].u.expr);
3761       }
3762     else if (ffeste_io_abort_ != NULL_TREE)
3763       {
3764         /* Have no IOSTAT= but have ERR=.  */
3765
3766         ffeste_io_iostat_is_temp_ = TRUE;
3767         ffeste_io_iostat_
3768           = ffecom_make_tempvar ("open", ffecom_integer_type_node,
3769                                  FFETARGET_charactersizeNONE, -1);
3770       }
3771     else
3772       {
3773         /* No IOSTAT= or ERR= specification.  */
3774
3775         ffeste_io_iostat_is_temp_ = FALSE;
3776         ffeste_io_iostat_ = NULL_TREE;
3777       }
3778
3779     /* Now prescan, then convert, all the arguments.  */
3780
3781     args = ffeste_io_olist_ (errl || iostat,
3782                              info->open_spec[FFESTP_openixUNIT].u.expr,
3783                              &info->open_spec[FFESTP_openixFILE],
3784                              &info->open_spec[FFESTP_openixSTATUS],
3785                              &info->open_spec[FFESTP_openixACCESS],
3786                              &info->open_spec[FFESTP_openixFORM],
3787                              &info->open_spec[FFESTP_openixRECL],
3788                              &info->open_spec[FFESTP_openixBLANK]);
3789
3790     /* Don't generate "if (iostat != 0) goto label;" if label is temp abort
3791        label, since we're gonna fall through to there anyway. */
3792
3793     ffeste_io_call_ (ffecom_call_gfrt (FFECOM_gfrtFOPEN, args, NULL_TREE),
3794                      ! ffeste_io_abort_is_temp_);
3795
3796     /* If we've got a temp label, generate its code here.  */
3797
3798     if (ffeste_io_abort_is_temp_)
3799       {
3800         DECL_INITIAL (ffeste_io_abort_) = error_mark_node;
3801         emit_nop ();
3802         expand_label (ffeste_io_abort_);
3803
3804         assert (ffeste_io_err_ == NULL_TREE);
3805       }
3806
3807     ffeste_end_stmt_ ();
3808   }
3809 #else
3810 #error
3811 #endif
3812 }
3813
3814 /* CLOSE statement.  */
3815
3816 void
3817 ffeste_R907 (ffestpCloseStmt *info)
3818 {
3819   ffeste_check_simple_ ();
3820
3821 #if FFECOM_targetCURRENT == FFECOM_targetFFE
3822   fputs ("+ CLOSE (", dmpout);
3823   ffeste_subr_file_ ("UNIT", &info->close_spec[FFESTP_closeixUNIT]);
3824   ffeste_subr_file_ ("ERR", &info->close_spec[FFESTP_closeixERR]);
3825   ffeste_subr_file_ ("IOSTAT", &info->close_spec[FFESTP_closeixIOSTAT]);
3826   ffeste_subr_file_ ("STATUS", &info->close_spec[FFESTP_closeixSTATUS]);
3827   fputs (")\n", dmpout);
3828 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
3829   {
3830     tree args;
3831     bool iostat;
3832     bool errl;
3833
3834     ffeste_emit_line_note_ ();
3835
3836 #define specified(something) (info->close_spec[something].kw_or_val_present)
3837
3838     iostat = specified (FFESTP_closeixIOSTAT);
3839     errl = specified (FFESTP_closeixERR);
3840
3841 #undef specified
3842
3843     ffeste_start_stmt_ ();
3844
3845     if (errl)
3846       {
3847         ffeste_io_err_
3848           = ffeste_io_abort_
3849           = ffecom_lookup_label
3850           (info->close_spec[FFESTP_closeixERR].u.label);
3851         ffeste_io_abort_is_temp_ = FALSE;
3852       }
3853     else
3854       {
3855         ffeste_io_err_ = NULL_TREE;
3856
3857         if ((ffeste_io_abort_is_temp_ = iostat))
3858           ffeste_io_abort_ = ffecom_temp_label ();
3859         else
3860           ffeste_io_abort_ = NULL_TREE;
3861       }
3862
3863     if (iostat)
3864       {
3865         /* Have IOSTAT= specification.  */
3866
3867         ffeste_io_iostat_is_temp_ = FALSE;
3868         ffeste_io_iostat_ = ffecom_expr
3869           (info->close_spec[FFESTP_closeixIOSTAT].u.expr);
3870       }
3871     else if (ffeste_io_abort_ != NULL_TREE)
3872       {
3873         /* Have no IOSTAT= but have ERR=.  */
3874
3875         ffeste_io_iostat_is_temp_ = TRUE;
3876         ffeste_io_iostat_
3877           = ffecom_make_tempvar ("close", ffecom_integer_type_node,
3878                                  FFETARGET_charactersizeNONE, -1);
3879       }
3880     else
3881       {
3882         /* No IOSTAT= or ERR= specification.  */
3883
3884         ffeste_io_iostat_is_temp_ = FALSE;
3885         ffeste_io_iostat_ = NULL_TREE;
3886       }
3887
3888     /* Now prescan, then convert, all the arguments.  */
3889
3890     args = ffeste_io_cllist_ (errl || iostat,
3891                               info->close_spec[FFESTP_closeixUNIT].u.expr,
3892                               &info->close_spec[FFESTP_closeixSTATUS]);
3893
3894     /* Don't generate "if (iostat != 0) goto label;" if label is temp abort
3895        label, since we're gonna fall through to there anyway. */
3896
3897     ffeste_io_call_ (ffecom_call_gfrt (FFECOM_gfrtFCLOS, args, NULL_TREE),
3898                      ! ffeste_io_abort_is_temp_);
3899
3900     /* If we've got a temp label, generate its code here. */
3901
3902     if (ffeste_io_abort_is_temp_)
3903       {
3904         DECL_INITIAL (ffeste_io_abort_) = error_mark_node;
3905         emit_nop ();
3906         expand_label (ffeste_io_abort_);
3907
3908         assert (ffeste_io_err_ == NULL_TREE);
3909       }
3910
3911     ffeste_end_stmt_ ();
3912   }
3913 #else
3914 #error
3915 #endif
3916 }
3917
3918 /* READ(...) statement -- start.  */
3919
3920 void
3921 ffeste_R909_start (ffestpReadStmt *info, bool only_format UNUSED,
3922                    ffestvUnit unit, ffestvFormat format, bool rec,
3923                    bool key UNUSED)
3924 {
3925   ffeste_check_start_ ();
3926
3927 #if FFECOM_targetCURRENT == FFECOM_targetFFE
3928   switch (format)
3929     {
3930     case FFESTV_formatNONE:
3931       if (rec)
3932         fputs ("+ READ_ufdac", dmpout);
3933       else if (key)
3934         fputs ("+ READ_ufidx", dmpout);
3935       else
3936         fputs ("+ READ_ufseq", dmpout);
3937       break;
3938
3939     case FFESTV_formatLABEL:
3940     case FFESTV_formatCHAREXPR:
3941     case FFESTV_formatINTEXPR:
3942       if (rec)
3943         fputs ("+ READ_fmdac", dmpout);
3944       else if (key)
3945         fputs ("+ READ_fmidx", dmpout);
3946       else if (unit == FFESTV_unitCHAREXPR)
3947         fputs ("+ READ_fmint", dmpout);
3948       else
3949         fputs ("+ READ_fmseq", dmpout);
3950       break;
3951
3952     case FFESTV_formatASTERISK:
3953       if (unit == FFESTV_unitCHAREXPR)
3954         fputs ("+ READ_lsint", dmpout);
3955       else
3956         fputs ("+ READ_lsseq", dmpout);
3957       break;
3958
3959     case FFESTV_formatNAMELIST:
3960       fputs ("+ READ_nlseq", dmpout);
3961       break;
3962
3963     default:
3964       assert ("Unexpected kind of format item in R909 READ" == NULL);
3965     }
3966
3967   if (only_format)
3968     {
3969       fputc (' ', dmpout);
3970       ffeste_subr_file_ ("FORMAT", &info->read_spec[FFESTP_readixFORMAT]);
3971       fputc (' ', dmpout);
3972
3973       return;
3974     }
3975
3976   fputs (" (", dmpout);
3977   ffeste_subr_file_ ("UNIT", &info->read_spec[FFESTP_readixUNIT]);
3978   ffeste_subr_file_ ("FORMAT", &info->read_spec[FFESTP_readixFORMAT]);
3979   ffeste_subr_file_ ("ADVANCE", &info->read_spec[FFESTP_readixADVANCE]);
3980   ffeste_subr_file_ ("EOR", &info->read_spec[FFESTP_readixEOR]);
3981   ffeste_subr_file_ ("ERR", &info->read_spec[FFESTP_readixERR]);
3982   ffeste_subr_file_ ("END", &info->read_spec[FFESTP_readixEND]);
3983   ffeste_subr_file_ ("IOSTAT", &info->read_spec[FFESTP_readixIOSTAT]);
3984   ffeste_subr_file_ ("KEYEQ", &info->read_spec[FFESTP_readixKEYEQ]);
3985   ffeste_subr_file_ ("KEYGE", &info->read_spec[FFESTP_readixKEYGE]);
3986   ffeste_subr_file_ ("KEYGT", &info->read_spec[FFESTP_readixKEYGT]);
3987   ffeste_subr_file_ ("KEYID", &info->read_spec[FFESTP_readixKEYID]);
3988   ffeste_subr_file_ ("NULLS", &info->read_spec[FFESTP_readixNULLS]);
3989   ffeste_subr_file_ ("REC", &info->read_spec[FFESTP_readixREC]);
3990   ffeste_subr_file_ ("SIZE", &info->read_spec[FFESTP_readixSIZE]);
3991   fputs (") ", dmpout);
3992 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
3993
3994   ffeste_emit_line_note_ ();
3995
3996   {
3997     ffecomGfrt start;
3998     ffecomGfrt end;
3999     tree cilist;
4000     bool iostat;
4001     bool errl;
4002     bool endl;
4003
4004     /* First determine the start, per-item, and end run-time functions to
4005        call.  The per-item function is picked by choosing an ffeste function
4006        to call to handle a given item; it knows how to generate a call to the
4007        appropriate run-time function, and is called an "I/O driver".  */
4008
4009     switch (format)
4010       {
4011       case FFESTV_formatNONE:   /* no FMT= */
4012         ffeste_io_driver_ = ffeste_io_douio_;
4013         if (rec)
4014           start = FFECOM_gfrtSRDUE, end = FFECOM_gfrtERDUE;
4015 #if 0
4016         else if (key)
4017           start = FFECOM_gfrtSRIUE, end = FFECOM_gfrtERIUE;
4018 #endif
4019         else
4020           start = FFECOM_gfrtSRSUE, end = FFECOM_gfrtERSUE;
4021         break;
4022
4023       case FFESTV_formatLABEL:  /* FMT=10 */
4024       case FFESTV_formatCHAREXPR:       /* FMT='(I10)' */
4025       case FFESTV_formatINTEXPR:        /* FMT=I [after ASSIGN 10 TO I] */
4026         ffeste_io_driver_ = ffeste_io_dofio_;
4027         if (rec)
4028           start = FFECOM_gfrtSRDFE, end = FFECOM_gfrtERDFE;
4029 #if 0
4030         else if (key)
4031           start = FFECOM_gfrtSRIFE, end = FFECOM_gfrtERIFE;
4032 #endif
4033         else if (unit == FFESTV_unitCHAREXPR)
4034           start = FFECOM_gfrtSRSFI, end = FFECOM_gfrtERSFI;
4035         else
4036           start = FFECOM_gfrtSRSFE, end = FFECOM_gfrtERSFE;
4037         break;
4038
4039       case FFESTV_formatASTERISK:       /* FMT=* */
4040         ffeste_io_driver_ = ffeste_io_dolio_;
4041         if (unit == FFESTV_unitCHAREXPR)
4042           start = FFECOM_gfrtSRSLI, end = FFECOM_gfrtERSLI;
4043         else
4044           start = FFECOM_gfrtSRSLE, end = FFECOM_gfrtERSLE;
4045         break;
4046
4047       case FFESTV_formatNAMELIST:       /* FMT=FOO or NML=FOO [NAMELIST
4048                                            /FOO/] */
4049         ffeste_io_driver_ = NULL;       /* No start or driver function. */
4050         start = FFECOM_gfrtSRSNE, end = FFECOM_gfrt;
4051         break;
4052
4053       default:
4054         assert ("Weird stuff" == NULL);
4055         start = FFECOM_gfrt, end = FFECOM_gfrt;
4056         break;
4057       }
4058     ffeste_io_endgfrt_ = end;
4059
4060 #define specified(something) (info->read_spec[something].kw_or_val_present)
4061
4062     iostat = specified (FFESTP_readixIOSTAT);
4063     errl = specified (FFESTP_readixERR);
4064     endl = specified (FFESTP_readixEND);
4065
4066 #undef specified
4067
4068     ffeste_start_stmt_ ();
4069
4070     if (errl)
4071       {
4072         /* Have ERR= specification.   */
4073
4074         ffeste_io_err_
4075           = ffecom_lookup_label (info->read_spec[FFESTP_readixERR].u.label);
4076
4077         if (endl)
4078           {
4079             /* Have both ERR= and END=.  Need a temp label to handle both.  */
4080             ffeste_io_end_
4081               = ffecom_lookup_label (info->read_spec[FFESTP_readixEND].u.label);
4082             ffeste_io_abort_is_temp_ = TRUE;
4083             ffeste_io_abort_ = ffecom_temp_label ();
4084           }
4085         else
4086           {
4087             /* Have ERR= but no END=.  */
4088             ffeste_io_end_ = NULL_TREE;
4089             if ((ffeste_io_abort_is_temp_ = iostat))
4090               ffeste_io_abort_ = ffecom_temp_label ();
4091             else
4092               ffeste_io_abort_ = ffeste_io_err_;
4093           }
4094       }
4095     else
4096       {
4097         /* No ERR= specification.  */
4098
4099         ffeste_io_err_ = NULL_TREE;
4100         if (endl)
4101           {
4102             /* Have END= but no ERR=.  */
4103             ffeste_io_end_
4104               = ffecom_lookup_label (info->read_spec[FFESTP_readixEND].u.label);
4105             if ((ffeste_io_abort_is_temp_ = iostat))
4106               ffeste_io_abort_ = ffecom_temp_label ();
4107             else
4108               ffeste_io_abort_ = ffeste_io_end_;
4109           }
4110         else
4111           {
4112             /* Have no ERR= or END=.  */
4113
4114             ffeste_io_end_ = NULL_TREE;
4115             if ((ffeste_io_abort_is_temp_ = iostat))
4116               ffeste_io_abort_ = ffecom_temp_label ();
4117             else
4118               ffeste_io_abort_ = NULL_TREE;
4119           }
4120       }
4121
4122     if (iostat)
4123       {
4124         /* Have IOSTAT= specification.  */
4125
4126         ffeste_io_iostat_is_temp_ = FALSE;
4127         ffeste_io_iostat_
4128           = ffecom_expr (info->read_spec[FFESTP_readixIOSTAT].u.expr);
4129       }
4130     else if (ffeste_io_abort_ != NULL_TREE)
4131       {
4132         /* Have no IOSTAT= but have ERR= and/or END=.  */
4133
4134         ffeste_io_iostat_is_temp_ = TRUE;
4135         ffeste_io_iostat_
4136           = ffecom_make_tempvar ("read", ffecom_integer_type_node,
4137                                  FFETARGET_charactersizeNONE, -1);
4138       }
4139     else
4140       {
4141         /* No IOSTAT=, ERR=, or END= specification.  */
4142
4143         ffeste_io_iostat_is_temp_ = FALSE;
4144         ffeste_io_iostat_ = NULL_TREE;
4145       }
4146
4147     /* Now prescan, then convert, all the arguments.  */
4148
4149     if (unit == FFESTV_unitCHAREXPR)
4150       cilist = ffeste_io_icilist_ (errl || iostat,
4151                                    info->read_spec[FFESTP_readixUNIT].u.expr,
4152                                    endl || iostat, format,
4153                                    &info->read_spec[FFESTP_readixFORMAT]);
4154     else
4155       cilist = ffeste_io_cilist_ (errl || iostat, unit,
4156                                   info->read_spec[FFESTP_readixUNIT].u.expr,
4157                                   5, endl || iostat, format,
4158                                   &info->read_spec[FFESTP_readixFORMAT],
4159                                   rec,
4160                                   info->read_spec[FFESTP_readixREC].u.expr);
4161
4162     /* If there is no end function, then there are no item functions (i.e.
4163        it's a NAMELIST), and vice versa by the way.  In this situation, don't
4164        generate the "if (iostat != 0) goto label;" if the label is temp abort
4165        label, since we're gonna fall through to there anyway.  */
4166
4167     ffeste_io_call_ (ffecom_call_gfrt (start, cilist, NULL_TREE),
4168                      (! ffeste_io_abort_is_temp_) || (end != FFECOM_gfrt));
4169   }
4170 #else
4171 #error
4172 #endif
4173 }
4174
4175 /* READ statement -- I/O item.  */
4176
4177 void
4178 ffeste_R909_item (ffebld expr, ffelexToken expr_token)
4179 {
4180   ffeste_check_item_ ();
4181
4182 #if FFECOM_targetCURRENT == FFECOM_targetFFE
4183   ffebld_dump (expr);
4184   fputc (',', dmpout);
4185 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
4186   if (expr == NULL)
4187     return;
4188
4189   /* Strip parens off items such as in "READ *,(A)".  This is really a bug
4190      in the user's code, but I've been told lots of code does this.  */
4191   while (ffebld_op (expr) == FFEBLD_opPAREN)
4192     expr = ffebld_left (expr);
4193
4194   if (ffebld_op (expr) == FFEBLD_opANY)
4195     return;
4196
4197   if (ffebld_op (expr) == FFEBLD_opIMPDO)
4198     ffeste_io_impdo_ (expr, expr_token);
4199   else
4200     {
4201       ffeste_start_stmt_ ();
4202
4203       ffecom_prepare_arg_ptr_to_expr (expr);
4204
4205       ffecom_prepare_end ();
4206
4207       ffeste_io_call_ ((*ffeste_io_driver_) (expr), TRUE);
4208
4209       ffeste_end_stmt_ ();
4210     }
4211 #else
4212 #error
4213 #endif
4214 }
4215
4216 /* READ statement -- end.  */
4217
4218 void
4219 ffeste_R909_finish ()
4220 {
4221   ffeste_check_finish_ ();
4222
4223 #if FFECOM_targetCURRENT == FFECOM_targetFFE
4224   fputc ('\n', dmpout);
4225 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
4226
4227   /* Don't generate "if (iostat != 0) goto label;" if label is temp abort
4228      label, since we're gonna fall through to there anyway. */
4229
4230   if (ffeste_io_endgfrt_ != FFECOM_gfrt)
4231     ffeste_io_call_ (ffecom_call_gfrt (ffeste_io_endgfrt_, NULL_TREE,
4232                                        NULL_TREE),
4233                      ! ffeste_io_abort_is_temp_);
4234
4235   /* If we've got a temp label, generate its code here and have it fan out
4236      to the END= or ERR= label as appropriate. */
4237
4238   if (ffeste_io_abort_is_temp_)
4239     {
4240       DECL_INITIAL (ffeste_io_abort_) = error_mark_node;
4241       emit_nop ();
4242       expand_label (ffeste_io_abort_);
4243
4244       /* "if (iostat<0) goto end_label;".  */
4245
4246       if ((ffeste_io_end_ != NULL_TREE)
4247           && (TREE_CODE (ffeste_io_end_) != ERROR_MARK))
4248         {
4249           expand_start_cond (ffecom_truth_value
4250                              (ffecom_2 (LT_EXPR, integer_type_node,
4251                                         ffeste_io_iostat_,
4252                                         ffecom_integer_zero_node)),
4253                              0);
4254           expand_goto (ffeste_io_end_);
4255           expand_end_cond ();
4256         }
4257
4258       /* "if (iostat>0) goto err_label;".  */
4259
4260       if ((ffeste_io_err_ != NULL_TREE)
4261           && (TREE_CODE (ffeste_io_err_) != ERROR_MARK))
4262         {
4263           expand_start_cond (ffecom_truth_value
4264                              (ffecom_2 (GT_EXPR, integer_type_node,
4265                                         ffeste_io_iostat_,
4266                                         ffecom_integer_zero_node)),
4267                              0);
4268           expand_goto (ffeste_io_err_);
4269           expand_end_cond ();
4270         }
4271     }
4272
4273   ffeste_end_stmt_ ();
4274 #else
4275 #error
4276 #endif
4277 }
4278
4279 /* WRITE statement -- start.  */
4280
4281 void
4282 ffeste_R910_start (ffestpWriteStmt *info, ffestvUnit unit,
4283                    ffestvFormat format, bool rec)
4284 {
4285   ffeste_check_start_ ();
4286
4287 #if FFECOM_targetCURRENT == FFECOM_targetFFE
4288   switch (format)
4289     {
4290     case FFESTV_formatNONE:
4291       if (rec)
4292         fputs ("+ WRITE_ufdac (", dmpout);
4293       else
4294         fputs ("+ WRITE_ufseq_or_idx (", dmpout);
4295       break;
4296
4297     case FFESTV_formatLABEL:
4298     case FFESTV_formatCHAREXPR:
4299     case FFESTV_formatINTEXPR:
4300       if (rec)
4301         fputs ("+ WRITE_fmdac (", dmpout);
4302       else if (unit == FFESTV_unitCHAREXPR)
4303         fputs ("+ WRITE_fmint (", dmpout);
4304       else
4305         fputs ("+ WRITE_fmseq_or_idx (", dmpout);
4306       break;
4307
4308     case FFESTV_formatASTERISK:
4309       if (unit == FFESTV_unitCHAREXPR)
4310         fputs ("+ WRITE_lsint (", dmpout);
4311       else
4312         fputs ("+ WRITE_lsseq (", dmpout);
4313       break;
4314
4315     case FFESTV_formatNAMELIST:
4316       fputs ("+ WRITE_nlseq (", dmpout);
4317       break;
4318
4319     default:
4320       assert ("Unexpected kind of format item in R910 WRITE" == NULL);
4321     }
4322
4323   ffeste_subr_file_ ("UNIT", &info->write_spec[FFESTP_writeixUNIT]);
4324   ffeste_subr_file_ ("FORMAT", &info->write_spec[FFESTP_writeixFORMAT]);
4325   ffeste_subr_file_ ("ADVANCE", &info->write_spec[FFESTP_writeixADVANCE]);
4326   ffeste_subr_file_ ("EOR", &info->write_spec[FFESTP_writeixEOR]);
4327   ffeste_subr_file_ ("ERR", &info->write_spec[FFESTP_writeixERR]);
4328   ffeste_subr_file_ ("IOSTAT", &info->write_spec[FFESTP_writeixIOSTAT]);
4329   ffeste_subr_file_ ("REC", &info->write_spec[FFESTP_writeixREC]);
4330   fputs (") ", dmpout);
4331 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
4332
4333   ffeste_emit_line_note_ ();
4334
4335   {
4336     ffecomGfrt start;
4337     ffecomGfrt end;
4338     tree cilist;
4339     bool iostat;
4340     bool errl;
4341
4342     /* First determine the start, per-item, and end run-time functions to
4343        call.  The per-item function is picked by choosing an ffeste function
4344        to call to handle a given item; it knows how to generate a call to the
4345        appropriate run-time function, and is called an "I/O driver".  */
4346
4347     switch (format)
4348       {
4349       case FFESTV_formatNONE:   /* no FMT= */
4350         ffeste_io_driver_ = ffeste_io_douio_;
4351         if (rec)
4352           start = FFECOM_gfrtSWDUE, end = FFECOM_gfrtEWDUE;
4353         else
4354           start = FFECOM_gfrtSWSUE, end = FFECOM_gfrtEWSUE;
4355         break;
4356
4357       case FFESTV_formatLABEL:  /* FMT=10 */
4358       case FFESTV_formatCHAREXPR:       /* FMT='(I10)' */
4359       case FFESTV_formatINTEXPR:        /* FMT=I [after ASSIGN 10 TO I] */
4360         ffeste_io_driver_ = ffeste_io_dofio_;
4361         if (rec)
4362           start = FFECOM_gfrtSWDFE, end = FFECOM_gfrtEWDFE;
4363         else if (unit == FFESTV_unitCHAREXPR)
4364           start = FFECOM_gfrtSWSFI, end = FFECOM_gfrtEWSFI;
4365         else
4366           start = FFECOM_gfrtSWSFE, end = FFECOM_gfrtEWSFE;
4367         break;
4368
4369       case FFESTV_formatASTERISK:       /* FMT=* */
4370         ffeste_io_driver_ = ffeste_io_dolio_;
4371         if (unit == FFESTV_unitCHAREXPR)
4372           start = FFECOM_gfrtSWSLI, end = FFECOM_gfrtEWSLI;
4373         else
4374           start = FFECOM_gfrtSWSLE, end = FFECOM_gfrtEWSLE;
4375         break;
4376
4377       case FFESTV_formatNAMELIST:       /* FMT=FOO or NML=FOO [NAMELIST
4378                                            /FOO/] */
4379         ffeste_io_driver_ = NULL;       /* No start or driver function. */
4380         start = FFECOM_gfrtSWSNE, end = FFECOM_gfrt;
4381         break;
4382
4383       default:
4384         assert ("Weird stuff" == NULL);
4385         start = FFECOM_gfrt, end = FFECOM_gfrt;
4386         break;
4387       }
4388     ffeste_io_endgfrt_ = end;
4389
4390 #define specified(something) (info->write_spec[something].kw_or_val_present)
4391
4392     iostat = specified (FFESTP_writeixIOSTAT);
4393     errl = specified (FFESTP_writeixERR);
4394
4395 #undef specified
4396
4397     ffeste_start_stmt_ ();
4398
4399     ffeste_io_end_ = NULL_TREE;
4400
4401     if (errl)
4402       {
4403         /* Have ERR= specification.   */
4404
4405         ffeste_io_err_
4406           = ffeste_io_abort_
4407           = ffecom_lookup_label
4408           (info->write_spec[FFESTP_writeixERR].u.label);
4409         ffeste_io_abort_is_temp_ = FALSE;
4410       }
4411     else
4412       {
4413         /* No ERR= specification.  */
4414
4415         ffeste_io_err_ = NULL_TREE;
4416
4417         if ((ffeste_io_abort_is_temp_ = iostat))
4418           ffeste_io_abort_ = ffecom_temp_label ();
4419         else
4420           ffeste_io_abort_ = NULL_TREE;
4421       }
4422
4423     if (iostat)
4424       {
4425         /* Have IOSTAT= specification.  */
4426
4427         ffeste_io_iostat_is_temp_ = FALSE;
4428         ffeste_io_iostat_ = ffecom_expr
4429           (info->write_spec[FFESTP_writeixIOSTAT].u.expr);
4430       }
4431     else if (ffeste_io_abort_ != NULL_TREE)
4432       {
4433         /* Have no IOSTAT= but have ERR=.  */
4434
4435         ffeste_io_iostat_is_temp_ = TRUE;
4436         ffeste_io_iostat_
4437           = ffecom_make_tempvar ("write", ffecom_integer_type_node,
4438                                  FFETARGET_charactersizeNONE, -1);
4439       }
4440     else
4441       {
4442         /* No IOSTAT= or ERR= specification.  */
4443
4444         ffeste_io_iostat_is_temp_ = FALSE;
4445         ffeste_io_iostat_ = NULL_TREE;
4446       }
4447
4448     /* Now prescan, then convert, all the arguments.  */
4449
4450     if (unit == FFESTV_unitCHAREXPR)
4451       cilist = ffeste_io_icilist_ (errl || iostat,
4452                                    info->write_spec[FFESTP_writeixUNIT].u.expr,
4453                                    FALSE, format,
4454                                    &info->write_spec[FFESTP_writeixFORMAT]);
4455     else
4456       cilist = ffeste_io_cilist_ (errl || iostat, unit,
4457                                   info->write_spec[FFESTP_writeixUNIT].u.expr,
4458                                   6, FALSE, format,
4459                                   &info->write_spec[FFESTP_writeixFORMAT],
4460                                   rec,
4461                                   info->write_spec[FFESTP_writeixREC].u.expr);
4462
4463     /* If there is no end function, then there are no item functions (i.e.
4464        it's a NAMELIST), and vice versa by the way.  In this situation, don't
4465        generate the "if (iostat != 0) goto label;" if the label is temp abort
4466        label, since we're gonna fall through to there anyway.  */
4467
4468     ffeste_io_call_ (ffecom_call_gfrt (start, cilist, NULL_TREE),
4469                      (! ffeste_io_abort_is_temp_) || (end != FFECOM_gfrt));
4470   }
4471 #else
4472 #error
4473 #endif
4474 }
4475
4476 /* WRITE statement -- I/O item.  */
4477
4478 void
4479 ffeste_R910_item (ffebld expr, ffelexToken expr_token)
4480 {
4481   ffeste_check_item_ ();
4482
4483 #if FFECOM_targetCURRENT == FFECOM_targetFFE
4484   ffebld_dump (expr);
4485   fputc (',', dmpout);
4486 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
4487   if (expr == NULL)
4488     return;
4489
4490   if (ffebld_op (expr) == FFEBLD_opANY)
4491     return;
4492
4493   if (ffebld_op (expr) == FFEBLD_opIMPDO)
4494     ffeste_io_impdo_ (expr, expr_token);
4495   else
4496     {
4497       ffeste_start_stmt_ ();
4498
4499       ffecom_prepare_arg_ptr_to_expr (expr);
4500
4501       ffecom_prepare_end ();
4502
4503       ffeste_io_call_ ((*ffeste_io_driver_) (expr), TRUE);
4504
4505       ffeste_end_stmt_ ();
4506     }
4507 #else
4508 #error
4509 #endif
4510 }
4511
4512 /* WRITE statement -- end.  */
4513
4514 void
4515 ffeste_R910_finish ()
4516 {
4517   ffeste_check_finish_ ();
4518
4519 #if FFECOM_targetCURRENT == FFECOM_targetFFE
4520   fputc ('\n', dmpout);
4521 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
4522
4523   /* Don't generate "if (iostat != 0) goto label;" if label is temp abort
4524      label, since we're gonna fall through to there anyway. */
4525
4526   if (ffeste_io_endgfrt_ != FFECOM_gfrt)
4527     ffeste_io_call_ (ffecom_call_gfrt (ffeste_io_endgfrt_, NULL_TREE,
4528                                        NULL_TREE),
4529                      ! ffeste_io_abort_is_temp_);
4530
4531   /* If we've got a temp label, generate its code here. */
4532
4533   if (ffeste_io_abort_is_temp_)
4534     {
4535       DECL_INITIAL (ffeste_io_abort_) = error_mark_node;
4536       emit_nop ();
4537       expand_label (ffeste_io_abort_);
4538
4539       assert (ffeste_io_err_ == NULL_TREE);
4540     }
4541
4542   ffeste_end_stmt_ ();
4543 #else
4544 #error
4545 #endif
4546 }
4547
4548 /* PRINT statement -- start.  */
4549
4550 void
4551 ffeste_R911_start (ffestpPrintStmt *info, ffestvFormat format)
4552 {
4553   ffeste_check_start_ ();
4554
4555 #if FFECOM_targetCURRENT == FFECOM_targetFFE
4556   switch (format)
4557     {
4558     case FFESTV_formatLABEL:
4559     case FFESTV_formatCHAREXPR:
4560     case FFESTV_formatINTEXPR:
4561       fputs ("+ PRINT_fm ", dmpout);
4562       break;
4563
4564     case FFESTV_formatASTERISK:
4565       fputs ("+ PRINT_ls ", dmpout);
4566       break;
4567
4568     case FFESTV_formatNAMELIST:
4569       fputs ("+ PRINT_nl ", dmpout);
4570       break;
4571
4572     default:
4573       assert ("Unexpected kind of format item in R911 PRINT" == NULL);
4574     }
4575   ffeste_subr_file_ ("FORMAT", &info->print_spec[FFESTP_printixFORMAT]);
4576   fputc (' ', dmpout);
4577 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
4578
4579   ffeste_emit_line_note_ ();
4580
4581   {
4582     ffecomGfrt start;
4583     ffecomGfrt end;
4584     tree cilist;
4585
4586     /* First determine the start, per-item, and end run-time functions to
4587        call.  The per-item function is picked by choosing an ffeste function
4588        to call to handle a given item; it knows how to generate a call to the
4589        appropriate run-time function, and is called an "I/O driver".  */
4590
4591     switch (format)
4592       {
4593       case FFESTV_formatLABEL:  /* FMT=10 */
4594       case FFESTV_formatCHAREXPR:       /* FMT='(I10)' */
4595       case FFESTV_formatINTEXPR:        /* FMT=I [after ASSIGN 10 TO I] */
4596         ffeste_io_driver_ = ffeste_io_dofio_;
4597         start = FFECOM_gfrtSWSFE, end = FFECOM_gfrtEWSFE;
4598         break;
4599
4600       case FFESTV_formatASTERISK:       /* FMT=* */
4601         ffeste_io_driver_ = ffeste_io_dolio_;
4602         start = FFECOM_gfrtSWSLE, end = FFECOM_gfrtEWSLE;
4603         break;
4604
4605       case FFESTV_formatNAMELIST:       /* FMT=FOO or NML=FOO [NAMELIST
4606                                            /FOO/] */
4607         ffeste_io_driver_ = NULL;       /* No start or driver function. */
4608         start = FFECOM_gfrtSWSNE, end = FFECOM_gfrt;
4609         break;
4610
4611       default:
4612         assert ("Weird stuff" == NULL);
4613         start = FFECOM_gfrt, end = FFECOM_gfrt;
4614         break;
4615       }
4616     ffeste_io_endgfrt_ = end;
4617
4618     ffeste_start_stmt_ ();
4619
4620     ffeste_io_end_ = NULL_TREE;
4621     ffeste_io_err_ = NULL_TREE;
4622     ffeste_io_abort_ = NULL_TREE;
4623     ffeste_io_abort_is_temp_ = FALSE;
4624     ffeste_io_iostat_is_temp_ = FALSE;
4625     ffeste_io_iostat_ = NULL_TREE;
4626
4627     /* Now prescan, then convert, all the arguments.  */
4628
4629     cilist = ffeste_io_cilist_ (FALSE, FFESTV_unitNONE, NULL, 6, FALSE, format,
4630                       &info->print_spec[FFESTP_printixFORMAT], FALSE, NULL);
4631
4632     /* If there is no end function, then there are no item functions (i.e.
4633        it's a NAMELIST), and vice versa by the way.  In this situation, don't
4634        generate the "if (iostat != 0) goto label;" if the label is temp abort
4635        label, since we're gonna fall through to there anyway.  */
4636
4637     ffeste_io_call_ (ffecom_call_gfrt (start, cilist, NULL_TREE),
4638                      (! ffeste_io_abort_is_temp_) || (end != FFECOM_gfrt));
4639   }
4640 #else
4641 #error
4642 #endif
4643 }
4644
4645 /* PRINT statement -- I/O item.  */
4646
4647 void
4648 ffeste_R911_item (ffebld expr, ffelexToken expr_token)
4649 {
4650   ffeste_check_item_ ();
4651
4652 #if FFECOM_targetCURRENT == FFECOM_targetFFE
4653   ffebld_dump (expr);
4654   fputc (',', dmpout);
4655 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
4656   if (expr == NULL)
4657     return;
4658
4659   if (ffebld_op (expr) == FFEBLD_opANY)
4660     return;
4661
4662   if (ffebld_op (expr) == FFEBLD_opIMPDO)
4663     ffeste_io_impdo_ (expr, expr_token);
4664   else
4665     {
4666       ffeste_start_stmt_ ();
4667
4668       ffecom_prepare_arg_ptr_to_expr (expr);
4669
4670       ffecom_prepare_end ();
4671
4672       ffeste_io_call_ ((*ffeste_io_driver_) (expr), TRUE);
4673
4674       ffeste_end_stmt_ ();
4675     }
4676 #else
4677 #error
4678 #endif
4679 }
4680
4681 /* PRINT statement -- end.  */
4682
4683 void
4684 ffeste_R911_finish ()
4685 {
4686   ffeste_check_finish_ ();
4687
4688 #if FFECOM_targetCURRENT == FFECOM_targetFFE
4689   fputc ('\n', dmpout);
4690 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
4691
4692   if (ffeste_io_endgfrt_ != FFECOM_gfrt)
4693     ffeste_io_call_ (ffecom_call_gfrt (ffeste_io_endgfrt_, NULL_TREE,
4694                                        NULL_TREE),
4695                      FALSE);
4696
4697   ffeste_end_stmt_ ();
4698 #else
4699 #error
4700 #endif
4701 }
4702
4703 /* BACKSPACE statement.  */
4704
4705 void
4706 ffeste_R919 (ffestpBeruStmt *info)
4707 {
4708   ffeste_check_simple_ ();
4709
4710 #if FFECOM_targetCURRENT == FFECOM_targetFFE
4711   fputs ("+ BACKSPACE (", dmpout);
4712   ffeste_subr_file_ ("UNIT", &info->beru_spec[FFESTP_beruixUNIT]);
4713   ffeste_subr_file_ ("ERR", &info->beru_spec[FFESTP_beruixERR]);
4714   ffeste_subr_file_ ("IOSTAT", &info->beru_spec[FFESTP_beruixIOSTAT]);
4715   fputs (")\n", dmpout);
4716 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
4717   ffeste_subr_beru_ (info, FFECOM_gfrtFBACK);
4718 #else
4719 #error
4720 #endif
4721 }
4722
4723 /* ENDFILE statement.  */
4724
4725 void
4726 ffeste_R920 (ffestpBeruStmt *info)
4727 {
4728   ffeste_check_simple_ ();
4729
4730 #if FFECOM_targetCURRENT == FFECOM_targetFFE
4731   fputs ("+ ENDFILE (", dmpout);
4732   ffeste_subr_file_ ("UNIT", &info->beru_spec[FFESTP_beruixUNIT]);
4733   ffeste_subr_file_ ("ERR", &info->beru_spec[FFESTP_beruixERR]);
4734   ffeste_subr_file_ ("IOSTAT", &info->beru_spec[FFESTP_beruixIOSTAT]);
4735   fputs (")\n", dmpout);
4736 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
4737   ffeste_subr_beru_ (info, FFECOM_gfrtFEND);
4738 #else
4739 #error
4740 #endif
4741 }
4742
4743 /* REWIND statement.  */
4744
4745 void
4746 ffeste_R921 (ffestpBeruStmt *info)
4747 {
4748   ffeste_check_simple_ ();
4749
4750 #if FFECOM_targetCURRENT == FFECOM_targetFFE
4751   fputs ("+ REWIND (", dmpout);
4752   ffeste_subr_file_ ("UNIT", &info->beru_spec[FFESTP_beruixUNIT]);
4753   ffeste_subr_file_ ("ERR", &info->beru_spec[FFESTP_beruixERR]);
4754   ffeste_subr_file_ ("IOSTAT", &info->beru_spec[FFESTP_beruixIOSTAT]);
4755   fputs (")\n", dmpout);
4756 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
4757   ffeste_subr_beru_ (info, FFECOM_gfrtFREW);
4758 #else
4759 #error
4760 #endif
4761 }
4762
4763 /* INQUIRE statement (non-IOLENGTH version).  */
4764
4765 void
4766 ffeste_R923A (ffestpInquireStmt *info, bool by_file UNUSED)
4767 {
4768   ffeste_check_simple_ ();
4769
4770 #if FFECOM_targetCURRENT == FFECOM_targetFFE
4771   if (by_file)
4772     {
4773       fputs ("+ INQUIRE_file (", dmpout);
4774       ffeste_subr_file_ ("FILE", &info->inquire_spec[FFESTP_inquireixFILE]);
4775     }
4776   else
4777     {
4778       fputs ("+ INQUIRE_unit (", dmpout);
4779       ffeste_subr_file_ ("UNIT", &info->inquire_spec[FFESTP_inquireixUNIT]);
4780     }
4781   ffeste_subr_file_ ("ACCESS", &info->inquire_spec[FFESTP_inquireixACCESS]);
4782   ffeste_subr_file_ ("ACTION", &info->inquire_spec[FFESTP_inquireixACTION]);
4783   ffeste_subr_file_ ("BLANK", &info->inquire_spec[FFESTP_inquireixBLANK]);
4784   ffeste_subr_file_ ("CARRIAGECONTROL", &info->inquire_spec[FFESTP_inquireixCARRIAGECONTROL]);
4785   ffeste_subr_file_ ("DEFAULTFILE", &info->inquire_spec[FFESTP_inquireixDEFAULTFILE]);
4786   ffeste_subr_file_ ("DELIM", &info->inquire_spec[FFESTP_inquireixDELIM]);
4787   ffeste_subr_file_ ("DIRECT", &info->inquire_spec[FFESTP_inquireixDIRECT]);
4788   ffeste_subr_file_ ("ERR", &info->inquire_spec[FFESTP_inquireixERR]);
4789   ffeste_subr_file_ ("EXIST", &info->inquire_spec[FFESTP_inquireixEXIST]);
4790   ffeste_subr_file_ ("FORM", &info->inquire_spec[FFESTP_inquireixFORM]);
4791   ffeste_subr_file_ ("FORMATTED", &info->inquire_spec[FFESTP_inquireixFORMATTED]);
4792   ffeste_subr_file_ ("IOSTAT", &info->inquire_spec[FFESTP_inquireixIOSTAT]);
4793   ffeste_subr_file_ ("KEYED", &info->inquire_spec[FFESTP_inquireixKEYED]);
4794   ffeste_subr_file_ ("NAME", &info->inquire_spec[FFESTP_inquireixNAME]);
4795   ffeste_subr_file_ ("NAMED", &info->inquire_spec[FFESTP_inquireixNAMED]);
4796   ffeste_subr_file_ ("NEXTREC", &info->inquire_spec[FFESTP_inquireixNEXTREC]);
4797   ffeste_subr_file_ ("NUMBER", &info->inquire_spec[FFESTP_inquireixNUMBER]);
4798   ffeste_subr_file_ ("OPENED", &info->inquire_spec[FFESTP_inquireixOPENED]);
4799   ffeste_subr_file_ ("ORGANIZATION", &info->inquire_spec[FFESTP_inquireixORGANIZATION]);
4800   ffeste_subr_file_ ("PAD", &info->inquire_spec[FFESTP_inquireixPAD]);
4801   ffeste_subr_file_ ("POSITION", &info->inquire_spec[FFESTP_inquireixPOSITION]);
4802   ffeste_subr_file_ ("READ", &info->inquire_spec[FFESTP_inquireixREAD]);
4803   ffeste_subr_file_ ("READWRITE", &info->inquire_spec[FFESTP_inquireixREADWRITE]);
4804   ffeste_subr_file_ ("RECL", &info->inquire_spec[FFESTP_inquireixRECL]);
4805   ffeste_subr_file_ ("RECORDTYPE", &info->inquire_spec[FFESTP_inquireixRECORDTYPE]);
4806   ffeste_subr_file_ ("SEQUENTIAL", &info->inquire_spec[FFESTP_inquireixSEQUENTIAL]);
4807   ffeste_subr_file_ ("UNFORMATTED", &info->inquire_spec[FFESTP_inquireixUNFORMATTED]);
4808   ffeste_subr_file_ ("WRITE", &info->inquire_spec[FFESTP_inquireixWRITE]);
4809   fputs (")\n", dmpout);
4810 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
4811   {
4812     tree args;
4813     bool iostat;
4814     bool errl;
4815
4816     ffeste_emit_line_note_ ();
4817
4818 #define specified(something) (info->inquire_spec[something].kw_or_val_present)
4819
4820     iostat = specified (FFESTP_inquireixIOSTAT);
4821     errl = specified (FFESTP_inquireixERR);
4822
4823 #undef specified
4824
4825     ffeste_start_stmt_ ();
4826
4827     if (errl)
4828       {
4829         ffeste_io_err_
4830           = ffeste_io_abort_
4831           = ffecom_lookup_label
4832           (info->inquire_spec[FFESTP_inquireixERR].u.label);
4833         ffeste_io_abort_is_temp_ = FALSE;
4834       }
4835     else
4836       {
4837         ffeste_io_err_ = NULL_TREE;
4838
4839         if ((ffeste_io_abort_is_temp_ = iostat))
4840           ffeste_io_abort_ = ffecom_temp_label ();
4841         else
4842           ffeste_io_abort_ = NULL_TREE;
4843       }
4844
4845     if (iostat)
4846       {
4847         /* Have IOSTAT= specification.  */
4848
4849         ffeste_io_iostat_is_temp_ = FALSE;
4850         ffeste_io_iostat_ = ffecom_expr
4851           (info->inquire_spec[FFESTP_inquireixIOSTAT].u.expr);
4852       }
4853     else if (ffeste_io_abort_ != NULL_TREE)
4854       {
4855         /* Have no IOSTAT= but have ERR=.  */
4856
4857         ffeste_io_iostat_is_temp_ = TRUE;
4858         ffeste_io_iostat_
4859           = ffecom_make_tempvar ("inquire", ffecom_integer_type_node,
4860                                  FFETARGET_charactersizeNONE, -1);
4861       }
4862     else
4863       {
4864         /* No IOSTAT= or ERR= specification.  */
4865
4866         ffeste_io_iostat_is_temp_ = FALSE;
4867         ffeste_io_iostat_ = NULL_TREE;
4868       }
4869
4870     /* Now prescan, then convert, all the arguments.  */
4871
4872     args
4873       = ffeste_io_inlist_ (errl || iostat,
4874                            &info->inquire_spec[FFESTP_inquireixUNIT],
4875                            &info->inquire_spec[FFESTP_inquireixFILE],
4876                            &info->inquire_spec[FFESTP_inquireixEXIST],
4877                            &info->inquire_spec[FFESTP_inquireixOPENED],
4878                            &info->inquire_spec[FFESTP_inquireixNUMBER],
4879                            &info->inquire_spec[FFESTP_inquireixNAMED],
4880                            &info->inquire_spec[FFESTP_inquireixNAME],
4881                            &info->inquire_spec[FFESTP_inquireixACCESS],
4882                            &info->inquire_spec[FFESTP_inquireixSEQUENTIAL],
4883                            &info->inquire_spec[FFESTP_inquireixDIRECT],
4884                            &info->inquire_spec[FFESTP_inquireixFORM],
4885                            &info->inquire_spec[FFESTP_inquireixFORMATTED],
4886                            &info->inquire_spec[FFESTP_inquireixUNFORMATTED],
4887                            &info->inquire_spec[FFESTP_inquireixRECL],
4888                            &info->inquire_spec[FFESTP_inquireixNEXTREC],
4889                            &info->inquire_spec[FFESTP_inquireixBLANK]);
4890
4891     /* Don't generate "if (iostat != 0) goto label;" if label is temp abort
4892        label, since we're gonna fall through to there anyway. */
4893
4894     ffeste_io_call_ (ffecom_call_gfrt (FFECOM_gfrtFINQU, args, NULL_TREE),
4895                      ! ffeste_io_abort_is_temp_);
4896
4897     /* If we've got a temp label, generate its code here.  */
4898
4899     if (ffeste_io_abort_is_temp_)
4900       {
4901         DECL_INITIAL (ffeste_io_abort_) = error_mark_node;
4902         emit_nop ();
4903         expand_label (ffeste_io_abort_);
4904
4905         assert (ffeste_io_err_ == NULL_TREE);
4906       }
4907
4908     ffeste_end_stmt_ ();
4909   }
4910 #else
4911 #error
4912 #endif
4913 }
4914
4915 /* INQUIRE(IOLENGTH=expr) statement -- start.  */
4916
4917 void
4918 ffeste_R923B_start (ffestpInquireStmt *info UNUSED)
4919 {
4920   ffeste_check_start_ ();
4921
4922 #if FFECOM_targetCURRENT == FFECOM_targetFFE
4923   fputs ("+ INQUIRE (", dmpout);
4924   ffeste_subr_file_ ("IOLENGTH", &info->inquire_spec[FFESTP_inquireixIOLENGTH]);
4925   fputs (") ", dmpout);
4926 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
4927   assert ("INQUIRE(IOLENGTH=<var>) not implemented yet! ~~~" == NULL);
4928
4929   ffeste_emit_line_note_ ();
4930 #else
4931 #error
4932 #endif
4933 }
4934
4935 /* INQUIRE(IOLENGTH=expr) statement -- I/O item.  */
4936
4937 void
4938 ffeste_R923B_item (ffebld expr UNUSED)
4939 {
4940   ffeste_check_item_ ();
4941
4942 #if FFECOM_targetCURRENT == FFECOM_targetFFE
4943   ffebld_dump (expr);
4944   fputc (',', dmpout);
4945 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
4946 #else
4947 #error
4948 #endif
4949 }
4950
4951 /* INQUIRE(IOLENGTH=expr) statement -- end.  */
4952
4953 void
4954 ffeste_R923B_finish ()
4955 {
4956   ffeste_check_finish_ ();
4957
4958 #if FFECOM_targetCURRENT == FFECOM_targetFFE
4959   fputc ('\n', dmpout);
4960 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
4961 #else
4962 #error
4963 #endif
4964 }
4965
4966 /* ffeste_R1001 -- FORMAT statement
4967
4968    ffeste_R1001(format_list);  */
4969
4970 void
4971 ffeste_R1001 (ffests s)
4972 {
4973   ffeste_check_simple_ ();
4974
4975 #if FFECOM_targetCURRENT == FFECOM_targetFFE
4976   fprintf (dmpout, "$ FORMAT %.*s\n", (int) ffests_length (s), ffests_text (s));
4977 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
4978   {
4979     tree t;
4980     tree ttype;
4981     tree maxindex;
4982     tree var;
4983
4984     assert (ffeste_label_formatdef_ != NULL);
4985
4986     ffeste_emit_line_note_ ();
4987
4988     t = build_string (ffests_length (s), ffests_text (s));
4989
4990     TREE_TYPE (t)
4991       = build_type_variant (build_array_type
4992                             (char_type_node,
4993                              build_range_type (integer_type_node,
4994                                                integer_one_node,
4995                                              build_int_2 (ffests_length (s),
4996                                                           0))),
4997                             1, 0);
4998     TREE_CONSTANT (t) = 1;
4999     TREE_STATIC (t) = 1;
5000
5001     push_obstacks_nochange ();
5002     end_temporary_allocation ();
5003
5004     var = ffecom_lookup_label (ffeste_label_formatdef_);
5005     if ((var != NULL_TREE)
5006         && (TREE_CODE (var) == VAR_DECL))
5007       {
5008         DECL_INITIAL (var) = t;
5009         maxindex = build_int_2 (ffests_length (s) - 1, 0);
5010         ttype = TREE_TYPE (var);
5011         TYPE_DOMAIN (ttype) = build_range_type (integer_type_node,
5012                                                 integer_zero_node,
5013                                                 maxindex);
5014         if (!TREE_TYPE (maxindex))
5015           TREE_TYPE (maxindex) = TYPE_DOMAIN (ttype);
5016         layout_type (ttype);
5017         rest_of_decl_compilation (var, NULL, 1, 0);
5018         expand_decl (var);
5019         expand_decl_init (var);
5020       }
5021
5022     resume_temporary_allocation ();
5023     pop_obstacks ();
5024
5025     ffeste_label_formatdef_ = NULL;
5026   }
5027 #else
5028 #error
5029 #endif
5030 }
5031
5032 /* END PROGRAM.  */
5033
5034 void
5035 ffeste_R1103 ()
5036 {
5037 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5038   fputs ("+ END_PROGRAM\n", dmpout);
5039 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5040 #else
5041 #error
5042 #endif
5043 }
5044
5045 /* END BLOCK DATA.  */
5046
5047 void
5048 ffeste_R1112 ()
5049 {
5050 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5051   fputs ("* END_BLOCK_DATA\n", dmpout);
5052 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5053 #else
5054 #error
5055 #endif
5056 }
5057
5058 /* CALL statement.  */
5059
5060 void
5061 ffeste_R1212 (ffebld expr)
5062 {
5063   ffeste_check_simple_ ();
5064
5065 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5066   fputs ("+ CALL ", dmpout);
5067   ffebld_dump (expr);
5068   fputc ('\n', dmpout);
5069 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5070   {
5071     ffebld args = ffebld_right (expr);
5072     ffebld arg;
5073     ffebld labels = NULL;       /* First in list of LABTERs. */
5074     ffebld prevlabels = NULL;
5075     ffebld prevargs = NULL;
5076
5077     ffeste_emit_line_note_ ();
5078
5079     /* Here we split the list at ffebld_right(expr) into two lists: one at
5080        ffebld_right(expr) consisting of all items that are not LABTERs, the
5081        other at labels consisting of all items that are LABTERs.  Then, if
5082        the latter list is NULL, we have an ordinary call, else we have a call
5083        with alternate returns. */
5084
5085     for (args = ffebld_right (expr); args != NULL; args = ffebld_trail (args))
5086       {
5087         if (((arg = ffebld_head (args)) == NULL)
5088             || (ffebld_op (arg) != FFEBLD_opLABTER))
5089           {
5090             if (prevargs == NULL)
5091               {
5092                 prevargs = args;
5093                 ffebld_set_right (expr, args);
5094               }
5095             else
5096               {
5097                 ffebld_set_trail (prevargs, args);
5098                 prevargs = args;
5099               }
5100           }
5101         else
5102           {
5103             if (prevlabels == NULL)
5104               {
5105                 prevlabels = labels = args;
5106               }
5107             else
5108               {
5109                 ffebld_set_trail (prevlabels, args);
5110                 prevlabels = args;
5111               }
5112           }
5113       }
5114     if (prevlabels == NULL)
5115       labels = NULL;
5116     else
5117       ffebld_set_trail (prevlabels, NULL);
5118     if (prevargs == NULL)
5119       ffebld_set_right (expr, NULL);
5120     else
5121       ffebld_set_trail (prevargs, NULL);
5122
5123     ffeste_start_stmt_ ();
5124
5125     /* No temporaries are actually needed at this level, but we go
5126        through the motions anyway, just to be sure in case they do
5127        get made.  Temporaries needed for arguments should be in the
5128        scopes of inner blocks, and if clean-up actions are supported,
5129        such as CALL-ing an intrinsic that writes to an argument of one
5130        type when a variable of a different type is provided (requiring
5131        assignment to the variable from a temporary after the library
5132        routine returns), the clean-up must be done by the expression
5133        evaluator, generally, to handle alternate returns (which we hope
5134        won't ever be supported by intrinsics, but might be a similar
5135        issue, such as CALL-ing an F90-style subroutine with an INTERFACE
5136        block).  That implies the expression evaluator will have to
5137        recognize the need for its own temporary anyway, meaning it'll
5138        construct a block within the one constructed here.  */
5139
5140     ffecom_prepare_expr (expr);
5141
5142     ffecom_prepare_end ();
5143
5144     if (labels == NULL)
5145       expand_expr_stmt (ffecom_expr (expr));
5146     else
5147       {
5148         tree texpr;
5149         tree value;
5150         tree tlabel;
5151         int caseno;
5152         int pushok;
5153         tree duplicate;
5154         ffebld label;
5155
5156         texpr = ffecom_expr (expr);
5157         expand_start_case (0, texpr, TREE_TYPE (texpr), "CALL statement");
5158
5159         for (caseno = 1, label = labels;
5160              label != NULL;
5161              ++caseno, label = ffebld_trail (label))
5162           {
5163             value = build_int_2 (caseno, 0);
5164             tlabel = build_decl (LABEL_DECL, NULL_TREE, NULL_TREE);
5165
5166             pushok = pushcase (value, convert, tlabel, &duplicate);
5167             assert (pushok == 0);
5168
5169             tlabel
5170               = ffecom_lookup_label (ffebld_labter (ffebld_head (label)));
5171             if ((tlabel == NULL_TREE)
5172                 || (TREE_CODE (tlabel) == ERROR_MARK))
5173               continue;
5174             TREE_USED (tlabel) = 1;
5175             expand_goto (tlabel);
5176           }
5177
5178         expand_end_case (texpr);
5179       }
5180
5181     ffeste_end_stmt_ ();
5182   }
5183 #else
5184 #error
5185 #endif
5186 }
5187
5188 /* END FUNCTION.  */
5189
5190 void
5191 ffeste_R1221 ()
5192 {
5193 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5194   fputs ("+ END_FUNCTION\n", dmpout);
5195 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5196 #else
5197 #error
5198 #endif
5199 }
5200
5201 /* END SUBROUTINE.  */
5202
5203 void
5204 ffeste_R1225 ()
5205 {
5206 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5207   fprintf (dmpout, "+ END_SUBROUTINE\n");
5208 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5209 #else
5210 #error
5211 #endif
5212 }
5213
5214 /* ENTRY statement.  */
5215
5216 void
5217 ffeste_R1226 (ffesymbol entry)
5218 {
5219   ffeste_check_simple_ ();
5220
5221 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5222   fprintf (dmpout, "+ ENTRY %s", ffesymbol_text (entry));
5223   if (ffesymbol_dummyargs (entry) != NULL)
5224     {
5225       ffebld argh;
5226
5227       fputc ('(', dmpout);
5228       for (argh = ffesymbol_dummyargs (entry);
5229            argh != NULL;
5230            argh = ffebld_trail (argh))
5231         {
5232           assert (ffebld_head (argh) != NULL);
5233           switch (ffebld_op (ffebld_head (argh)))
5234             {
5235             case FFEBLD_opSYMTER:
5236               fputs (ffesymbol_text (ffebld_symter (ffebld_head (argh))),
5237                      dmpout);
5238               break;
5239
5240             case FFEBLD_opSTAR:
5241               fputc ('*', dmpout);
5242               break;
5243
5244             default:
5245               fputc ('?', dmpout);
5246               ffebld_dump (ffebld_head (argh));
5247               fputc ('?', dmpout);
5248               break;
5249             }
5250           if (ffebld_trail (argh) != NULL)
5251             fputc (',', dmpout);
5252         }
5253       fputc (')', dmpout);
5254     }
5255   fputc ('\n', dmpout);
5256 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5257   {
5258     tree label = ffesymbol_hook (entry).length_tree;
5259
5260     ffeste_emit_line_note_ ();
5261
5262     if (label == error_mark_node)
5263       return;
5264
5265     DECL_INITIAL (label) = error_mark_node;
5266     emit_nop ();
5267     expand_label (label);
5268   }
5269 #else
5270 #error
5271 #endif
5272 }
5273
5274 /* RETURN statement.  */
5275
5276 void
5277 ffeste_R1227 (ffestw block UNUSED, ffebld expr)
5278 {
5279   ffeste_check_simple_ ();
5280
5281 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5282   if (expr == NULL)
5283     {
5284       fputs ("+ RETURN\n", dmpout);
5285     }
5286   else
5287     {
5288       fputs ("+ RETURN_alternate ", dmpout);
5289       ffebld_dump (expr);
5290       fputc ('\n', dmpout);
5291     }
5292 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5293   {
5294     tree rtn;
5295
5296     ffeste_emit_line_note_ ();
5297
5298     ffeste_start_stmt_ ();
5299
5300     ffecom_prepare_return_expr (expr);
5301
5302     ffecom_prepare_end ();
5303
5304     rtn = ffecom_return_expr (expr);
5305
5306     if ((rtn == NULL_TREE)
5307         || (rtn == error_mark_node))
5308       expand_null_return ();
5309     else
5310       {
5311         tree result = DECL_RESULT (current_function_decl);
5312
5313         if ((result != error_mark_node)
5314             && (TREE_TYPE (result) != error_mark_node))
5315           expand_return (ffecom_modify (NULL_TREE,
5316                                         result,
5317                                         convert (TREE_TYPE (result),
5318                                                  rtn)));
5319         else
5320           expand_null_return ();
5321       }
5322
5323     ffeste_end_stmt_ ();
5324   }
5325 #else
5326 #error
5327 #endif
5328 }
5329
5330 /* REWRITE statement -- start.  */
5331
5332 #if FFESTR_VXT
5333 void
5334 ffeste_V018_start (ffestpRewriteStmt *info, ffestvFormat format)
5335 {
5336   ffeste_check_start_ ();
5337
5338 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5339   switch (format)
5340     {
5341     case FFESTV_formatNONE:
5342       fputs ("+ REWRITE_uf (", dmpout);
5343       break;
5344
5345     case FFESTV_formatLABEL:
5346     case FFESTV_formatCHAREXPR:
5347     case FFESTV_formatINTEXPR:
5348       fputs ("+ REWRITE_fm (", dmpout);
5349       break;
5350
5351     default:
5352       assert ("Unexpected kind of format item in V018 REWRITE" == NULL);
5353     }
5354   ffeste_subr_file_ ("UNIT", &info->rewrite_spec[FFESTP_rewriteixUNIT]);
5355   ffeste_subr_file_ ("FMT", &info->rewrite_spec[FFESTP_rewriteixFMT]);
5356   ffeste_subr_file_ ("ERR", &info->rewrite_spec[FFESTP_rewriteixERR]);
5357   ffeste_subr_file_ ("IOSTAT", &info->rewrite_spec[FFESTP_rewriteixIOSTAT]);
5358   fputs (") ", dmpout);
5359 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5360 #else
5361 #error
5362 #endif
5363 }
5364
5365 /* REWRITE statement -- I/O item.  */
5366
5367 void
5368 ffeste_V018_item (ffebld expr)
5369 {
5370   ffeste_check_item_ ();
5371
5372 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5373   ffebld_dump (expr);
5374   fputc (',', dmpout);
5375 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5376 #else
5377 #error
5378 #endif
5379 }
5380
5381 /* REWRITE statement -- end.  */
5382
5383 void
5384 ffeste_V018_finish ()
5385 {
5386   ffeste_check_finish_ ();
5387
5388 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5389   fputc ('\n', dmpout);
5390 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5391 #else
5392 #error
5393 #endif
5394 }
5395
5396 /* ACCEPT statement -- start.  */
5397
5398 void
5399 ffeste_V019_start (ffestpAcceptStmt *info, ffestvFormat format)
5400 {
5401   ffeste_check_start_ ();
5402
5403 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5404   switch (format)
5405     {
5406     case FFESTV_formatLABEL:
5407     case FFESTV_formatCHAREXPR:
5408     case FFESTV_formatINTEXPR:
5409       fputs ("+ ACCEPT_fm ", dmpout);
5410       break;
5411
5412     case FFESTV_formatASTERISK:
5413       fputs ("+ ACCEPT_ls ", dmpout);
5414       break;
5415
5416     case FFESTV_formatNAMELIST:
5417       fputs ("+ ACCEPT_nl ", dmpout);
5418       break;
5419
5420     default:
5421       assert ("Unexpected kind of format item in V019 ACCEPT" == NULL);
5422     }
5423   ffeste_subr_file_ ("FORMAT", &info->accept_spec[FFESTP_acceptixFORMAT]);
5424   fputc (' ', dmpout);
5425 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5426 #else
5427 #error
5428 #endif
5429 }
5430
5431 /* ACCEPT statement -- I/O item.  */
5432
5433 void
5434 ffeste_V019_item (ffebld expr)
5435 {
5436   ffeste_check_item_ ();
5437
5438 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5439   ffebld_dump (expr);
5440   fputc (',', dmpout);
5441 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5442 #else
5443 #error
5444 #endif
5445 }
5446
5447 /* ACCEPT statement -- end.  */
5448
5449 void
5450 ffeste_V019_finish ()
5451 {
5452   ffeste_check_finish_ ();
5453
5454 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5455   fputc ('\n', dmpout);
5456 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5457 #else
5458 #error
5459 #endif
5460 }
5461
5462 #endif
5463 /* TYPE statement -- start.  */
5464
5465 void
5466 ffeste_V020_start (ffestpTypeStmt *info UNUSED,
5467                    ffestvFormat format UNUSED)
5468 {
5469   ffeste_check_start_ ();
5470
5471 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5472   switch (format)
5473     {
5474     case FFESTV_formatLABEL:
5475     case FFESTV_formatCHAREXPR:
5476     case FFESTV_formatINTEXPR:
5477       fputs ("+ TYPE_fm ", dmpout);
5478       break;
5479
5480     case FFESTV_formatASTERISK:
5481       fputs ("+ TYPE_ls ", dmpout);
5482       break;
5483
5484     case FFESTV_formatNAMELIST:
5485       fputs ("* TYPE_nl ", dmpout);
5486       break;
5487
5488     default:
5489       assert ("Unexpected kind of format item in V020 TYPE" == NULL);
5490     }
5491   ffeste_subr_file_ ("FORMAT", &info->type_spec[FFESTP_typeixFORMAT]);
5492   fputc (' ', dmpout);
5493 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5494 #else
5495 #error
5496 #endif
5497 }
5498
5499 /* TYPE statement -- I/O item.  */
5500
5501 void
5502 ffeste_V020_item (ffebld expr UNUSED)
5503 {
5504   ffeste_check_item_ ();
5505
5506 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5507   ffebld_dump (expr);
5508   fputc (',', dmpout);
5509 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5510 #else
5511 #error
5512 #endif
5513 }
5514
5515 /* TYPE statement -- end.  */
5516
5517 void
5518 ffeste_V020_finish ()
5519 {
5520   ffeste_check_finish_ ();
5521
5522 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5523   fputc ('\n', dmpout);
5524 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5525 #else
5526 #error
5527 #endif
5528 }
5529
5530 /* DELETE statement.  */
5531
5532 #if FFESTR_VXT
5533 void
5534 ffeste_V021 (ffestpDeleteStmt *info)
5535 {
5536   ffeste_check_simple_ ();
5537
5538 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5539   fputs ("+ DELETE (", dmpout);
5540   ffeste_subr_file_ ("UNIT", &info->delete_spec[FFESTP_deleteixUNIT]);
5541   ffeste_subr_file_ ("REC", &info->delete_spec[FFESTP_deleteixREC]);
5542   ffeste_subr_file_ ("ERR", &info->delete_spec[FFESTP_deleteixERR]);
5543   ffeste_subr_file_ ("IOSTAT", &info->delete_spec[FFESTP_deleteixIOSTAT]);
5544   fputs (")\n", dmpout);
5545 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5546 #else
5547 #error
5548 #endif
5549 }
5550
5551 /* UNLOCK statement.  */
5552
5553 void
5554 ffeste_V022 (ffestpBeruStmt *info)
5555 {
5556   ffeste_check_simple_ ();
5557
5558 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5559   fputs ("+ UNLOCK (", dmpout);
5560   ffeste_subr_file_ ("UNIT", &info->beru_spec[FFESTP_beruixUNIT]);
5561   ffeste_subr_file_ ("ERR", &info->beru_spec[FFESTP_beruixERR]);
5562   ffeste_subr_file_ ("IOSTAT", &info->beru_spec[FFESTP_beruixIOSTAT]);
5563   fputs (")\n", dmpout);
5564 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5565 #else
5566 #error
5567 #endif
5568 }
5569
5570 /* ENCODE statement -- start.  */
5571
5572 void
5573 ffeste_V023_start (ffestpVxtcodeStmt *info)
5574 {
5575   ffeste_check_start_ ();
5576
5577 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5578   fputs ("+ ENCODE (", dmpout);
5579   ffeste_subr_file_ ("C", &info->vxtcode_spec[FFESTP_vxtcodeixC]);
5580   ffeste_subr_file_ ("F", &info->vxtcode_spec[FFESTP_vxtcodeixF]);
5581   ffeste_subr_file_ ("B", &info->vxtcode_spec[FFESTP_vxtcodeixB]);
5582   ffeste_subr_file_ ("ERR", &info->vxtcode_spec[FFESTP_vxtcodeixERR]);
5583   ffeste_subr_file_ ("IOSTAT", &info->vxtcode_spec[FFESTP_vxtcodeixIOSTAT]);
5584   fputs (") ", dmpout);
5585 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5586 #else
5587 #error
5588 #endif
5589 }
5590
5591 /* ENCODE statement -- I/O item.  */
5592
5593 void
5594 ffeste_V023_item (ffebld expr)
5595 {
5596   ffeste_check_item_ ();
5597
5598 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5599   ffebld_dump (expr);
5600   fputc (',', dmpout);
5601 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5602 #else
5603 #error
5604 #endif
5605 }
5606
5607 /* ENCODE statement -- end.  */
5608
5609 void
5610 ffeste_V023_finish ()
5611 {
5612   ffeste_check_finish_ ();
5613
5614 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5615   fputc ('\n', dmpout);
5616 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5617 #else
5618 #error
5619 #endif
5620 }
5621
5622 /* DECODE statement -- start.  */
5623
5624 void
5625 ffeste_V024_start (ffestpVxtcodeStmt *info)
5626 {
5627   ffeste_check_start_ ();
5628
5629 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5630   fputs ("+ DECODE (", dmpout);
5631   ffeste_subr_file_ ("C", &info->vxtcode_spec[FFESTP_vxtcodeixC]);
5632   ffeste_subr_file_ ("F", &info->vxtcode_spec[FFESTP_vxtcodeixF]);
5633   ffeste_subr_file_ ("B", &info->vxtcode_spec[FFESTP_vxtcodeixB]);
5634   ffeste_subr_file_ ("ERR", &info->vxtcode_spec[FFESTP_vxtcodeixERR]);
5635   ffeste_subr_file_ ("IOSTAT", &info->vxtcode_spec[FFESTP_vxtcodeixIOSTAT]);
5636   fputs (") ", dmpout);
5637 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5638 #else
5639 #error
5640 #endif
5641 }
5642
5643 /* DECODE statement -- I/O item.  */
5644
5645 void
5646 ffeste_V024_item (ffebld expr)
5647 {
5648   ffeste_check_item_ ();
5649
5650 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5651   ffebld_dump (expr);
5652   fputc (',', dmpout);
5653 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5654 #else
5655 #error
5656 #endif
5657 }
5658
5659 /* DECODE statement -- end.  */
5660
5661 void
5662 ffeste_V024_finish ()
5663 {
5664   ffeste_check_finish_ ();
5665
5666 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5667   fputc ('\n', dmpout);
5668 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5669 #else
5670 #error
5671 #endif
5672 }
5673
5674 /* DEFINEFILE statement -- start.  */
5675
5676 void
5677 ffeste_V025_start ()
5678 {
5679   ffeste_check_start_ ();
5680
5681 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5682   fputs ("+ DEFINE_FILE ", dmpout);
5683 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5684 #else
5685 #error
5686 #endif
5687 }
5688
5689 /* DEFINE FILE statement -- item.  */
5690
5691 void
5692 ffeste_V025_item (ffebld u, ffebld m, ffebld n, ffebld asv)
5693 {
5694   ffeste_check_item_ ();
5695
5696 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5697   ffebld_dump (u);
5698   fputc ('(', dmpout);
5699   ffebld_dump (m);
5700   fputc (',', dmpout);
5701   ffebld_dump (n);
5702   fputs (",U,", dmpout);
5703   ffebld_dump (asv);
5704   fputs ("),", dmpout);
5705 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5706 #else
5707 #error
5708 #endif
5709 }
5710
5711 /* DEFINE FILE statement -- end.  */
5712
5713 void
5714 ffeste_V025_finish ()
5715 {
5716   ffeste_check_finish_ ();
5717
5718 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5719   fputc ('\n', dmpout);
5720 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5721 #else
5722 #error
5723 #endif
5724 }
5725
5726 /* FIND statement.  */
5727
5728 void
5729 ffeste_V026 (ffestpFindStmt *info)
5730 {
5731   ffeste_check_simple_ ();
5732
5733 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5734   fputs ("+ FIND (", dmpout);
5735   ffeste_subr_file_ ("UNIT", &info->find_spec[FFESTP_findixUNIT]);
5736   ffeste_subr_file_ ("REC", &info->find_spec[FFESTP_findixREC]);
5737   ffeste_subr_file_ ("ERR", &info->find_spec[FFESTP_findixERR]);
5738   ffeste_subr_file_ ("IOSTAT", &info->find_spec[FFESTP_findixIOSTAT]);
5739   fputs (")\n", dmpout);
5740 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5741 #else
5742 #error
5743 #endif
5744 }
5745
5746 #endif
5747
5748 #ifdef ENABLE_CHECKING
5749 void
5750 ffeste_terminate_2 (void)
5751 {
5752   assert (! ffeste_top_block_);
5753 }
5754 #endif