contrib/gcc/f/ste.c

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