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         result = ffecom_make_tempvar ("dowhile", integer_type_node,
3100                                       FFETARGET_charactersizeNONE, -1);
3101
3102         ffeste_start_stmt_ ();
3103
3104         ffecom_prepare_expr (expr);
3105
3106         ffecom_prepare_end ();
3107
3108         result = ffecom_modify (void_type_node,
3109                                 result,
3110                                 ffecom_truth_value (ffecom_expr (expr)));
3111         expand_expr_stmt (result);
3112
3113         ffeste_end_stmt_ ();
3114
3115         ffestw_set_do_hook (block, expand_start_loop (1));
3116         expand_exit_loop_if_false (0, result);
3117       }
3118     else
3119       ffestw_set_do_hook (block, expand_start_loop (1));
3120
3121     ffestw_set_do_tvar (block, NULL_TREE);
3122   }
3123 #else
3124 #error
3125 #endif
3126 }
3127
3128 /* END DO statement.
3129
3130    This is the MIL-STD 1753 END DO. It's syntactic sugar, similar to
3131    CONTINUE (except that it has to have a label that is the target of
3132    one or more iterative DO statement), not the Fortran-90 structured
3133    END DO, which is handled elsewhere, as is the actual mechanism of
3134    ending an iterative DO statement, even one that ends at a label.  */
3135
3136 void
3137 ffeste_R825 ()
3138 {
3139   ffeste_check_simple_ ();
3140
3141 #if FFECOM_targetCURRENT == FFECOM_targetFFE
3142   fputs ("+ END_DO_sugar\n", dmpout);
3143 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
3144   ffeste_emit_line_note_ ();
3145
3146   emit_nop ();
3147 #else
3148 #error
3149 #endif
3150 }
3151
3152 /* CYCLE statement.  */
3153
3154 void
3155 ffeste_R834 (ffestw block)
3156 {
3157   ffeste_check_simple_ ();
3158
3159 #if FFECOM_targetCURRENT == FFECOM_targetFFE
3160   fprintf (dmpout, "+ CYCLE block #%lu\n", ffestw_blocknum (block));
3161 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
3162   ffeste_emit_line_note_ ();
3163
3164   expand_continue_loop (ffestw_do_hook (block));
3165 #else
3166 #error
3167 #endif
3168 }
3169
3170 /* EXIT statement.  */
3171
3172 void
3173 ffeste_R835 (ffestw block)
3174 {
3175   ffeste_check_simple_ ();
3176
3177 #if FFECOM_targetCURRENT == FFECOM_targetFFE
3178   fprintf (dmpout, "+ EXIT block #%lu\n", ffestw_blocknum (block));
3179 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
3180   ffeste_emit_line_note_ ();
3181
3182   expand_exit_loop (ffestw_do_hook (block));
3183 #else
3184 #error
3185 #endif
3186 }
3187
3188 /* GOTO statement.  */
3189
3190 void
3191 ffeste_R836 (ffelab label)
3192 {
3193   ffeste_check_simple_ ();
3194
3195 #if FFECOM_targetCURRENT == FFECOM_targetFFE
3196   fprintf (dmpout, "+ GOTO %lu\n", ffelab_value (label));
3197 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
3198   {
3199     tree glabel;
3200
3201     ffeste_emit_line_note_ ();
3202
3203     glabel = ffecom_lookup_label (label);
3204     if ((glabel != NULL_TREE)
3205         && (TREE_CODE (glabel) != ERROR_MARK))
3206       {
3207         expand_goto (glabel);
3208         TREE_USED (glabel) = 1;
3209       }
3210   }
3211 #else
3212 #error
3213 #endif
3214 }
3215
3216 /* Computed GOTO statement.  */
3217
3218 void
3219 ffeste_R837 (ffelab *labels, int count, ffebld expr)
3220 {
3221   int i;
3222
3223   ffeste_check_simple_ ();
3224
3225 #if FFECOM_targetCURRENT == FFECOM_targetFFE
3226   fputs ("+ CGOTO (", dmpout);
3227   for (i = 0; i < count; ++i)
3228     {
3229       if (i != 0)
3230         fputc (',', dmpout);
3231       fprintf (dmpout, "%" ffelabValue_f "u", ffelab_value (labels[i]));
3232     }
3233   fputs ("),", dmpout);
3234   ffebld_dump (expr);
3235   fputc ('\n', dmpout);
3236 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
3237   {
3238     tree texpr;
3239     tree value;
3240     tree tlabel;
3241     int pushok;
3242     tree duplicate;
3243
3244     ffeste_emit_line_note_ ();
3245
3246     ffeste_start_stmt_ ();
3247
3248     ffecom_prepare_expr (expr);
3249
3250     ffecom_prepare_end ();
3251
3252     texpr = ffecom_expr (expr);
3253
3254     expand_start_case (0, texpr, TREE_TYPE (texpr), "computed GOTO statement");
3255
3256     for (i = 0; i < count; ++i)
3257       {
3258         value = build_int_2 (i + 1, 0);
3259         tlabel = build_decl (LABEL_DECL, NULL_TREE, NULL_TREE);
3260
3261         pushok = pushcase (value, convert, tlabel, &duplicate);
3262         assert (pushok == 0);
3263
3264         tlabel = ffecom_lookup_label (labels[i]);
3265         if ((tlabel == NULL_TREE)
3266             || (TREE_CODE (tlabel) == ERROR_MARK))
3267           continue;
3268
3269         expand_goto (tlabel);
3270         TREE_USED (tlabel) = 1;
3271       }
3272     expand_end_case (texpr);
3273
3274     ffeste_end_stmt_ ();
3275   }
3276 #else
3277 #error
3278 #endif
3279 }
3280
3281 /* ASSIGN statement.  */
3282
3283 void
3284 ffeste_R838 (ffelab label, ffebld target)
3285 {
3286   ffeste_check_simple_ ();
3287
3288 #if FFECOM_targetCURRENT == FFECOM_targetFFE
3289   fprintf (dmpout, "+ ASSIGN %lu TO ", ffelab_value (label));
3290   ffebld_dump (target);
3291   fputc ('\n', dmpout);
3292 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
3293   {
3294     tree expr_tree;
3295     tree label_tree;
3296     tree target_tree;
3297
3298     ffeste_emit_line_note_ ();
3299
3300     /* No need to call ffeste_start_stmt_(), as the sorts of expressions
3301        seen here should never require use of temporaries.  */
3302
3303     label_tree = ffecom_lookup_label (label);
3304     if ((label_tree != NULL_TREE)
3305         && (TREE_CODE (label_tree) != ERROR_MARK))
3306       {
3307         label_tree = ffecom_1 (ADDR_EXPR,
3308                                build_pointer_type (void_type_node),
3309                                label_tree);
3310         TREE_CONSTANT (label_tree) = 1;
3311
3312         target_tree = ffecom_expr_assign_w (target);
3313         if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (target_tree)))
3314             < GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (label_tree))))
3315           error ("ASSIGN to variable that is too small");
3316
3317         label_tree = convert (TREE_TYPE (target_tree), label_tree);
3318
3319         expr_tree = ffecom_modify (void_type_node,
3320                                    target_tree,
3321                                    label_tree);
3322         expand_expr_stmt (expr_tree);
3323
3324         clear_momentary ();
3325       }
3326   }
3327 #else
3328 #error
3329 #endif
3330 }
3331
3332 /* Assigned GOTO statement.  */
3333
3334 void
3335 ffeste_R839 (ffebld target)
3336 {
3337   ffeste_check_simple_ ();
3338
3339 #if FFECOM_targetCURRENT == FFECOM_targetFFE
3340   fputs ("+ AGOTO ", dmpout);
3341   ffebld_dump (target);
3342   fputc ('\n', dmpout);
3343 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
3344   {
3345     tree t;
3346
3347     ffeste_emit_line_note_ ();
3348
3349     /* No need to call ffeste_start_stmt_(), as the sorts of expressions
3350        seen here should never require use of temporaries.  */
3351
3352     t = ffecom_expr_assign (target);
3353     if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (t)))
3354         < GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
3355       error ("ASSIGNed GOTO target variable is too small");
3356
3357     expand_computed_goto (convert (TREE_TYPE (null_pointer_node), t));
3358
3359     clear_momentary ();
3360   }
3361 #else
3362 #error
3363 #endif
3364 }
3365
3366 /* Arithmetic IF statement.  */
3367
3368 void
3369 ffeste_R840 (ffebld expr, ffelab neg, ffelab zero, ffelab pos)
3370 {
3371   ffeste_check_simple_ ();
3372
3373 #if FFECOM_targetCURRENT == FFECOM_targetFFE
3374   fputs ("+ IF_arithmetic (", dmpout);
3375   ffebld_dump (expr);
3376   fprintf (dmpout, ") %" ffelabValue_f "u,%" ffelabValue_f "u,%" ffelabValue_f "u\n",
3377            ffelab_value (neg), ffelab_value (zero), ffelab_value (pos));
3378 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
3379   {
3380     tree gneg = ffecom_lookup_label (neg);
3381     tree gzero = ffecom_lookup_label (zero);
3382     tree gpos = ffecom_lookup_label (pos);
3383     tree texpr;
3384
3385     ffeste_emit_line_note_ ();
3386
3387     if ((gneg == NULL_TREE) || (gzero == NULL_TREE) || (gpos == NULL_TREE))
3388       return;
3389     if ((TREE_CODE (gneg) == ERROR_MARK)
3390         || (TREE_CODE (gzero) == ERROR_MARK)
3391         || (TREE_CODE (gpos) == ERROR_MARK))
3392       return;
3393
3394     ffeste_start_stmt_ ();
3395
3396     ffecom_prepare_expr (expr);
3397
3398     ffecom_prepare_end ();
3399
3400     if (neg == zero)
3401       {
3402         if (neg == pos)
3403           expand_goto (gzero);
3404         else
3405           {
3406             /* IF (expr.LE.0) THEN GOTO neg/zero ELSE GOTO pos.  */
3407             texpr = ffecom_expr (expr);
3408             texpr = ffecom_2 (LE_EXPR, integer_type_node,
3409                               texpr,
3410                               convert (TREE_TYPE (texpr),
3411                                        integer_zero_node));
3412             expand_start_cond (ffecom_truth_value (texpr), 0);
3413             expand_goto (gzero);
3414             expand_start_else ();
3415             expand_goto (gpos);
3416             expand_end_cond ();
3417           }
3418       }
3419     else if (neg == pos)
3420       {
3421         /* IF (expr.NE.0) THEN GOTO neg/pos ELSE GOTO zero.  */
3422         texpr = ffecom_expr (expr);
3423         texpr = ffecom_2 (NE_EXPR, integer_type_node,
3424                           texpr,
3425                           convert (TREE_TYPE (texpr),
3426                                    integer_zero_node));
3427         expand_start_cond (ffecom_truth_value (texpr), 0);
3428         expand_goto (gneg);
3429         expand_start_else ();
3430         expand_goto (gzero);
3431         expand_end_cond ();
3432       }
3433     else if (zero == pos)
3434       {
3435         /* IF (expr.GE.0) THEN GOTO zero/pos ELSE GOTO neg.  */
3436         texpr = ffecom_expr (expr);
3437         texpr = ffecom_2 (GE_EXPR, integer_type_node,
3438                           texpr,
3439                           convert (TREE_TYPE (texpr),
3440                                    integer_zero_node));
3441         expand_start_cond (ffecom_truth_value (texpr), 0);
3442         expand_goto (gzero);
3443         expand_start_else ();
3444         expand_goto (gneg);
3445         expand_end_cond ();
3446       }
3447     else
3448       {
3449         /* Use a SAVE_EXPR in combo with:
3450            IF (expr.LT.0) THEN GOTO neg
3451            ELSEIF (expr.GT.0) THEN GOTO pos
3452            ELSE GOTO zero.  */
3453         tree expr_saved = ffecom_save_tree (ffecom_expr (expr));
3454
3455         texpr = ffecom_2 (LT_EXPR, integer_type_node,
3456                           expr_saved,
3457                           convert (TREE_TYPE (expr_saved),
3458                                    integer_zero_node));
3459         expand_start_cond (ffecom_truth_value (texpr), 0);
3460         expand_goto (gneg);
3461         texpr = ffecom_2 (GT_EXPR, integer_type_node,
3462                           expr_saved,
3463                           convert (TREE_TYPE (expr_saved),
3464                                    integer_zero_node));
3465         expand_start_elseif (ffecom_truth_value (texpr));
3466         expand_goto (gpos);
3467         expand_start_else ();
3468         expand_goto (gzero);
3469         expand_end_cond ();
3470       }
3471
3472     ffeste_end_stmt_ ();
3473   }
3474 #else
3475 #error
3476 #endif
3477 }
3478
3479 /* CONTINUE statement.  */
3480
3481 void
3482 ffeste_R841 ()
3483 {
3484   ffeste_check_simple_ ();
3485
3486 #if FFECOM_targetCURRENT == FFECOM_targetFFE
3487   fputs ("+ CONTINUE\n", dmpout);
3488 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
3489   ffeste_emit_line_note_ ();
3490
3491   emit_nop ();
3492 #else
3493 #error
3494 #endif
3495 }
3496
3497 /* STOP statement.  */
3498
3499 void
3500 ffeste_R842 (ffebld expr)
3501 {
3502   ffeste_check_simple_ ();
3503
3504 #if FFECOM_targetCURRENT == FFECOM_targetFFE
3505   if (expr == NULL)
3506     {
3507       fputs ("+ STOP\n", dmpout);
3508     }
3509   else
3510     {
3511       fputs ("+ STOP_coded ", dmpout);
3512       ffebld_dump (expr);
3513       fputc ('\n', dmpout);
3514     }
3515 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
3516   {
3517     tree callit;
3518     ffelexToken msg;
3519
3520     ffeste_emit_line_note_ ();
3521
3522     if ((expr == NULL)
3523         || (ffeinfo_basictype (ffebld_info (expr))
3524             == FFEINFO_basictypeANY))
3525       {
3526         msg = ffelex_token_new_character ("", ffelex_token_where_line
3527                                (ffesta_tokens[0]), ffelex_token_where_column
3528                                           (ffesta_tokens[0]));
3529         expr = ffebld_new_conter (ffebld_constant_new_characterdefault
3530                                   (msg));
3531         ffelex_token_kill (msg);
3532         ffebld_set_info (expr, ffeinfo_new (FFEINFO_basictypeCHARACTER,
3533                     FFEINFO_kindtypeCHARACTERDEFAULT, 0, FFEINFO_kindENTITY,
3534                                             FFEINFO_whereCONSTANT, 0));
3535       }
3536     else if (ffeinfo_basictype (ffebld_info (expr))
3537              == FFEINFO_basictypeINTEGER)
3538       {
3539         char num[50];
3540
3541         assert (ffebld_op (expr) == FFEBLD_opCONTER);
3542         assert (ffeinfo_kindtype (ffebld_info (expr))
3543                 == FFEINFO_kindtypeINTEGERDEFAULT);
3544         sprintf (num, "%" ffetargetIntegerDefault_f "d",
3545                  ffebld_constant_integer1 (ffebld_conter (expr)));
3546         msg = ffelex_token_new_character (num, ffelex_token_where_line
3547                                (ffesta_tokens[0]), ffelex_token_where_column
3548                                           (ffesta_tokens[0]));
3549         expr = ffebld_new_conter (ffebld_constant_new_characterdefault
3550                                   (msg));
3551         ffelex_token_kill (msg);
3552         ffebld_set_info (expr, ffeinfo_new (FFEINFO_basictypeCHARACTER,
3553                     FFEINFO_kindtypeCHARACTERDEFAULT, 0, FFEINFO_kindENTITY,
3554                                             FFEINFO_whereCONSTANT, 0));
3555       }
3556     else
3557       {
3558         assert (ffeinfo_basictype (ffebld_info (expr))
3559                 == FFEINFO_basictypeCHARACTER);
3560         assert (ffebld_op (expr) == FFEBLD_opCONTER);
3561         assert (ffeinfo_kindtype (ffebld_info (expr))
3562                 == FFEINFO_kindtypeCHARACTERDEFAULT);
3563       }
3564
3565     /* No need to call ffeste_start_stmt_(), as the sorts of expressions
3566        seen here should never require use of temporaries.  */
3567
3568     callit = ffecom_call_gfrt (FFECOM_gfrtSTOP,
3569                     ffecom_list_ptr_to_expr (ffebld_new_item (expr, NULL)),
3570                                NULL_TREE);
3571     TREE_SIDE_EFFECTS (callit) = 1;
3572
3573     expand_expr_stmt (callit);
3574
3575     clear_momentary ();
3576   }
3577 #else
3578 #error
3579 #endif
3580 }
3581
3582 /* PAUSE statement.  */
3583
3584 void
3585 ffeste_R843 (ffebld expr)
3586 {
3587   ffeste_check_simple_ ();
3588
3589 #if FFECOM_targetCURRENT == FFECOM_targetFFE
3590   if (expr == NULL)
3591     {
3592       fputs ("+ PAUSE\n", dmpout);
3593     }
3594   else
3595     {
3596       fputs ("+ PAUSE_coded ", dmpout);
3597       ffebld_dump (expr);
3598       fputc ('\n', dmpout);
3599     }
3600 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
3601   {
3602     tree callit;
3603     ffelexToken msg;
3604
3605     ffeste_emit_line_note_ ();
3606
3607     if ((expr == NULL)
3608         || (ffeinfo_basictype (ffebld_info (expr))
3609             == FFEINFO_basictypeANY))
3610       {
3611         msg = ffelex_token_new_character ("", ffelex_token_where_line
3612                                (ffesta_tokens[0]), ffelex_token_where_column
3613                                           (ffesta_tokens[0]));
3614         expr = ffebld_new_conter (ffebld_constant_new_characterdefault
3615                                   (msg));
3616         ffelex_token_kill (msg);
3617         ffebld_set_info (expr, ffeinfo_new (FFEINFO_basictypeCHARACTER,
3618                     FFEINFO_kindtypeCHARACTERDEFAULT, 0, FFEINFO_kindENTITY,
3619                                             FFEINFO_whereCONSTANT, 0));
3620       }
3621     else if (ffeinfo_basictype (ffebld_info (expr))
3622              == FFEINFO_basictypeINTEGER)
3623       {
3624         char num[50];
3625
3626         assert (ffebld_op (expr) == FFEBLD_opCONTER);
3627         assert (ffeinfo_kindtype (ffebld_info (expr))
3628                 == FFEINFO_kindtypeINTEGERDEFAULT);
3629         sprintf (num, "%" ffetargetIntegerDefault_f "d",
3630                  ffebld_constant_integer1 (ffebld_conter (expr)));
3631         msg = ffelex_token_new_character (num, ffelex_token_where_line
3632                                (ffesta_tokens[0]), ffelex_token_where_column
3633                                           (ffesta_tokens[0]));
3634         expr = ffebld_new_conter (ffebld_constant_new_characterdefault
3635                                   (msg));
3636         ffelex_token_kill (msg);
3637         ffebld_set_info (expr, ffeinfo_new (FFEINFO_basictypeCHARACTER,
3638                     FFEINFO_kindtypeCHARACTERDEFAULT, 0, FFEINFO_kindENTITY,
3639                                             FFEINFO_whereCONSTANT, 0));
3640       }
3641     else
3642       {
3643         assert (ffeinfo_basictype (ffebld_info (expr))
3644                 == FFEINFO_basictypeCHARACTER);
3645         assert (ffebld_op (expr) == FFEBLD_opCONTER);
3646         assert (ffeinfo_kindtype (ffebld_info (expr))
3647                 == FFEINFO_kindtypeCHARACTERDEFAULT);
3648       }
3649
3650     /* No need to call ffeste_start_stmt_(), as the sorts of expressions
3651        seen here should never require use of temporaries.  */
3652
3653     callit = ffecom_call_gfrt (FFECOM_gfrtPAUSE,
3654                     ffecom_list_ptr_to_expr (ffebld_new_item (expr, NULL)),
3655                                NULL_TREE);
3656     TREE_SIDE_EFFECTS (callit) = 1;
3657
3658     expand_expr_stmt (callit);
3659
3660     clear_momentary ();
3661   }
3662 #if 0                           /* Old approach for phantom g77 run-time
3663                                    library. */
3664   {
3665     tree callit;
3666
3667     ffeste_emit_line_note_ ();
3668
3669     if (expr == NULL)
3670       callit = ffecom_call_gfrt (FFECOM_gfrtPAUSENIL, NULL_TREE, NULL_TREE);
3671     else if (ffeinfo_basictype (ffebld_info (expr))
3672              == FFEINFO_basictypeINTEGER)
3673       callit = ffecom_call_gfrt (FFECOM_gfrtPAUSEINT,
3674                       ffecom_list_ptr_to_expr (ffebld_new_item (expr, NULL)),
3675                                  NULL_TREE);
3676     else if (ffeinfo_basictype (ffebld_info (expr))
3677              == FFEINFO_basictypeCHARACTER)
3678       callit = ffecom_call_gfrt (FFECOM_gfrtPAUSECHAR,
3679                       ffecom_list_ptr_to_expr (ffebld_new_item (expr, NULL)),
3680                                  NULL_TREE);
3681     else
3682       abort ();
3683     TREE_SIDE_EFFECTS (callit) = 1;
3684
3685     expand_expr_stmt (callit);
3686
3687     clear_momentary ();
3688   }
3689 #endif
3690 #else
3691 #error
3692 #endif
3693 }
3694
3695 /* OPEN statement.  */
3696
3697 void
3698 ffeste_R904 (ffestpOpenStmt *info)
3699 {
3700   ffeste_check_simple_ ();
3701
3702 #if FFECOM_targetCURRENT == FFECOM_targetFFE
3703   fputs ("+ OPEN (", dmpout);
3704   ffeste_subr_file_ ("UNIT", &info->open_spec[FFESTP_openixUNIT]);
3705   ffeste_subr_file_ ("ACCESS", &info->open_spec[FFESTP_openixACCESS]);
3706   ffeste_subr_file_ ("ACTION", &info->open_spec[FFESTP_openixACTION]);
3707   ffeste_subr_file_ ("ASSOCIATEVARIABLE", &info->open_spec[FFESTP_openixASSOCIATEVARIABLE]);
3708   ffeste_subr_file_ ("BLANK", &info->open_spec[FFESTP_openixBLANK]);
3709   ffeste_subr_file_ ("BLOCKSIZE", &info->open_spec[FFESTP_openixBLOCKSIZE]);
3710   ffeste_subr_file_ ("BUFFERCOUNT", &info->open_spec[FFESTP_openixBUFFERCOUNT]);
3711   ffeste_subr_file_ ("CARRIAGECONTROL", &info->open_spec[FFESTP_openixCARRIAGECONTROL]);
3712   ffeste_subr_file_ ("DEFAULTFILE", &info->open_spec[FFESTP_openixDEFAULTFILE]);
3713   ffeste_subr_file_ ("DELIM", &info->open_spec[FFESTP_openixDELIM]);
3714   ffeste_subr_file_ ("DISPOSE", &info->open_spec[FFESTP_openixDISPOSE]);
3715   ffeste_subr_file_ ("ERR", &info->open_spec[FFESTP_openixERR]);
3716   ffeste_subr_file_ ("EXTENDSIZE", &info->open_spec[FFESTP_openixEXTENDSIZE]);
3717   ffeste_subr_file_ ("FILE", &info->open_spec[FFESTP_openixFILE]);
3718   ffeste_subr_file_ ("FORM", &info->open_spec[FFESTP_openixFORM]);
3719   ffeste_subr_file_ ("INITIALSIZE", &info->open_spec[FFESTP_openixINITIALSIZE]);
3720   ffeste_subr_file_ ("IOSTAT", &info->open_spec[FFESTP_openixIOSTAT]);
3721   ffeste_subr_file_ ("KEY", &info->open_spec[FFESTP_openixKEY]);
3722   ffeste_subr_file_ ("MAXREC", &info->open_spec[FFESTP_openixMAXREC]);
3723   ffeste_subr_file_ ("NOSPANBLOCKS", &info->open_spec[FFESTP_openixNOSPANBLOCKS]);
3724   ffeste_subr_file_ ("ORGANIZATION", &info->open_spec[FFESTP_openixORGANIZATION]);
3725   ffeste_subr_file_ ("PAD", &info->open_spec[FFESTP_openixPAD]);
3726   ffeste_subr_file_ ("POSITION", &info->open_spec[FFESTP_openixPOSITION]);
3727   ffeste_subr_file_ ("READONLY", &info->open_spec[FFESTP_openixREADONLY]);
3728   ffeste_subr_file_ ("RECL", &info->open_spec[FFESTP_openixRECL]);
3729   ffeste_subr_file_ ("RECORDTYPE", &info->open_spec[FFESTP_openixRECORDTYPE]);
3730   ffeste_subr_file_ ("SHARED", &info->open_spec[FFESTP_openixSHARED]);
3731   ffeste_subr_file_ ("STATUS", &info->open_spec[FFESTP_openixSTATUS]);
3732   ffeste_subr_file_ ("USEROPEN", &info->open_spec[FFESTP_openixUSEROPEN]);
3733   fputs (")\n", dmpout);
3734 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
3735   {
3736     tree args;
3737     bool iostat;
3738     bool errl;
3739
3740     ffeste_emit_line_note_ ();
3741
3742 #define specified(something) (info->open_spec[something].kw_or_val_present)
3743
3744     iostat = specified (FFESTP_openixIOSTAT);
3745     errl = specified (FFESTP_openixERR);
3746
3747 #undef specified
3748
3749     ffeste_start_stmt_ ();
3750
3751     if (errl)
3752       {
3753         ffeste_io_err_
3754           = ffeste_io_abort_
3755           = ffecom_lookup_label
3756           (info->open_spec[FFESTP_openixERR].u.label);
3757         ffeste_io_abort_is_temp_ = FALSE;
3758       }
3759     else
3760       {
3761         ffeste_io_err_ = NULL_TREE;
3762
3763         if ((ffeste_io_abort_is_temp_ = iostat))
3764           ffeste_io_abort_ = ffecom_temp_label ();
3765         else
3766           ffeste_io_abort_ = NULL_TREE;
3767       }
3768
3769     if (iostat)
3770       {
3771         /* Have IOSTAT= specification.  */
3772
3773         ffeste_io_iostat_is_temp_ = FALSE;
3774         ffeste_io_iostat_ = ffecom_expr
3775           (info->open_spec[FFESTP_openixIOSTAT].u.expr);
3776       }
3777     else if (ffeste_io_abort_ != NULL_TREE)
3778       {
3779         /* Have no IOSTAT= but have ERR=.  */
3780
3781         ffeste_io_iostat_is_temp_ = TRUE;
3782         ffeste_io_iostat_
3783           = ffecom_make_tempvar ("open", ffecom_integer_type_node,
3784                                  FFETARGET_charactersizeNONE, -1);
3785       }
3786     else
3787       {
3788         /* No IOSTAT= or ERR= specification.  */
3789
3790         ffeste_io_iostat_is_temp_ = FALSE;
3791         ffeste_io_iostat_ = NULL_TREE;
3792       }
3793
3794     /* Now prescan, then convert, all the arguments.  */
3795
3796     args = ffeste_io_olist_ (errl || iostat,
3797                              info->open_spec[FFESTP_openixUNIT].u.expr,
3798                              &info->open_spec[FFESTP_openixFILE],
3799                              &info->open_spec[FFESTP_openixSTATUS],
3800                              &info->open_spec[FFESTP_openixACCESS],
3801                              &info->open_spec[FFESTP_openixFORM],
3802                              &info->open_spec[FFESTP_openixRECL],
3803                              &info->open_spec[FFESTP_openixBLANK]);
3804
3805     /* Don't generate "if (iostat != 0) goto label;" if label is temp abort
3806        label, since we're gonna fall through to there anyway. */
3807
3808     ffeste_io_call_ (ffecom_call_gfrt (FFECOM_gfrtFOPEN, args, NULL_TREE),
3809                      ! ffeste_io_abort_is_temp_);
3810
3811     /* If we've got a temp label, generate its code here.  */
3812
3813     if (ffeste_io_abort_is_temp_)
3814       {
3815         DECL_INITIAL (ffeste_io_abort_) = error_mark_node;
3816         emit_nop ();
3817         expand_label (ffeste_io_abort_);
3818
3819         assert (ffeste_io_err_ == NULL_TREE);
3820       }
3821
3822     ffeste_end_stmt_ ();
3823   }
3824 #else
3825 #error
3826 #endif
3827 }
3828
3829 /* CLOSE statement.  */
3830
3831 void
3832 ffeste_R907 (ffestpCloseStmt *info)
3833 {
3834   ffeste_check_simple_ ();
3835
3836 #if FFECOM_targetCURRENT == FFECOM_targetFFE
3837   fputs ("+ CLOSE (", dmpout);
3838   ffeste_subr_file_ ("UNIT", &info->close_spec[FFESTP_closeixUNIT]);
3839   ffeste_subr_file_ ("ERR", &info->close_spec[FFESTP_closeixERR]);
3840   ffeste_subr_file_ ("IOSTAT", &info->close_spec[FFESTP_closeixIOSTAT]);
3841   ffeste_subr_file_ ("STATUS", &info->close_spec[FFESTP_closeixSTATUS]);
3842   fputs (")\n", dmpout);
3843 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
3844   {
3845     tree args;
3846     bool iostat;
3847     bool errl;
3848
3849     ffeste_emit_line_note_ ();
3850
3851 #define specified(something) (info->close_spec[something].kw_or_val_present)
3852
3853     iostat = specified (FFESTP_closeixIOSTAT);
3854     errl = specified (FFESTP_closeixERR);
3855
3856 #undef specified
3857
3858     ffeste_start_stmt_ ();
3859
3860     if (errl)
3861       {
3862         ffeste_io_err_
3863           = ffeste_io_abort_
3864           = ffecom_lookup_label
3865           (info->close_spec[FFESTP_closeixERR].u.label);
3866         ffeste_io_abort_is_temp_ = FALSE;
3867       }
3868     else
3869       {
3870         ffeste_io_err_ = NULL_TREE;
3871
3872         if ((ffeste_io_abort_is_temp_ = iostat))
3873           ffeste_io_abort_ = ffecom_temp_label ();
3874         else
3875           ffeste_io_abort_ = NULL_TREE;
3876       }
3877
3878     if (iostat)
3879       {
3880         /* Have IOSTAT= specification.  */
3881
3882         ffeste_io_iostat_is_temp_ = FALSE;
3883         ffeste_io_iostat_ = ffecom_expr
3884           (info->close_spec[FFESTP_closeixIOSTAT].u.expr);
3885       }
3886     else if (ffeste_io_abort_ != NULL_TREE)
3887       {
3888         /* Have no IOSTAT= but have ERR=.  */
3889
3890         ffeste_io_iostat_is_temp_ = TRUE;
3891         ffeste_io_iostat_
3892           = ffecom_make_tempvar ("close", ffecom_integer_type_node,
3893                                  FFETARGET_charactersizeNONE, -1);
3894       }
3895     else
3896       {
3897         /* No IOSTAT= or ERR= specification.  */
3898
3899         ffeste_io_iostat_is_temp_ = FALSE;
3900         ffeste_io_iostat_ = NULL_TREE;
3901       }
3902
3903     /* Now prescan, then convert, all the arguments.  */
3904
3905     args = ffeste_io_cllist_ (errl || iostat,
3906                               info->close_spec[FFESTP_closeixUNIT].u.expr,
3907                               &info->close_spec[FFESTP_closeixSTATUS]);
3908
3909     /* Don't generate "if (iostat != 0) goto label;" if label is temp abort
3910        label, since we're gonna fall through to there anyway. */
3911
3912     ffeste_io_call_ (ffecom_call_gfrt (FFECOM_gfrtFCLOS, args, NULL_TREE),
3913                      ! ffeste_io_abort_is_temp_);
3914
3915     /* If we've got a temp label, generate its code here. */
3916
3917     if (ffeste_io_abort_is_temp_)
3918       {
3919         DECL_INITIAL (ffeste_io_abort_) = error_mark_node;
3920         emit_nop ();
3921         expand_label (ffeste_io_abort_);
3922
3923         assert (ffeste_io_err_ == NULL_TREE);
3924       }
3925
3926     ffeste_end_stmt_ ();
3927   }
3928 #else
3929 #error
3930 #endif
3931 }
3932
3933 /* READ(...) statement -- start.  */
3934
3935 void
3936 ffeste_R909_start (ffestpReadStmt *info, bool only_format UNUSED,
3937                    ffestvUnit unit, ffestvFormat format, bool rec,
3938                    bool key UNUSED)
3939 {
3940   ffeste_check_start_ ();
3941
3942 #if FFECOM_targetCURRENT == FFECOM_targetFFE
3943   switch (format)
3944     {
3945     case FFESTV_formatNONE:
3946       if (rec)
3947         fputs ("+ READ_ufdac", dmpout);
3948       else if (key)
3949         fputs ("+ READ_ufidx", dmpout);
3950       else
3951         fputs ("+ READ_ufseq", dmpout);
3952       break;
3953
3954     case FFESTV_formatLABEL:
3955     case FFESTV_formatCHAREXPR:
3956     case FFESTV_formatINTEXPR:
3957       if (rec)
3958         fputs ("+ READ_fmdac", dmpout);
3959       else if (key)
3960         fputs ("+ READ_fmidx", dmpout);
3961       else if (unit == FFESTV_unitCHAREXPR)
3962         fputs ("+ READ_fmint", dmpout);
3963       else
3964         fputs ("+ READ_fmseq", dmpout);
3965       break;
3966
3967     case FFESTV_formatASTERISK:
3968       if (unit == FFESTV_unitCHAREXPR)
3969         fputs ("+ READ_lsint", dmpout);
3970       else
3971         fputs ("+ READ_lsseq", dmpout);
3972       break;
3973
3974     case FFESTV_formatNAMELIST:
3975       fputs ("+ READ_nlseq", dmpout);
3976       break;
3977
3978     default:
3979       assert ("Unexpected kind of format item in R909 READ" == NULL);
3980     }
3981
3982   if (only_format)
3983     {
3984       fputc (' ', dmpout);
3985       ffeste_subr_file_ ("FORMAT", &info->read_spec[FFESTP_readixFORMAT]);
3986       fputc (' ', dmpout);
3987
3988       return;
3989     }
3990
3991   fputs (" (", dmpout);
3992   ffeste_subr_file_ ("UNIT", &info->read_spec[FFESTP_readixUNIT]);
3993   ffeste_subr_file_ ("FORMAT", &info->read_spec[FFESTP_readixFORMAT]);
3994   ffeste_subr_file_ ("ADVANCE", &info->read_spec[FFESTP_readixADVANCE]);
3995   ffeste_subr_file_ ("EOR", &info->read_spec[FFESTP_readixEOR]);
3996   ffeste_subr_file_ ("ERR", &info->read_spec[FFESTP_readixERR]);
3997   ffeste_subr_file_ ("END", &info->read_spec[FFESTP_readixEND]);
3998   ffeste_subr_file_ ("IOSTAT", &info->read_spec[FFESTP_readixIOSTAT]);
3999   ffeste_subr_file_ ("KEYEQ", &info->read_spec[FFESTP_readixKEYEQ]);
4000   ffeste_subr_file_ ("KEYGE", &info->read_spec[FFESTP_readixKEYGE]);
4001   ffeste_subr_file_ ("KEYGT", &info->read_spec[FFESTP_readixKEYGT]);
4002   ffeste_subr_file_ ("KEYID", &info->read_spec[FFESTP_readixKEYID]);
4003   ffeste_subr_file_ ("NULLS", &info->read_spec[FFESTP_readixNULLS]);
4004   ffeste_subr_file_ ("REC", &info->read_spec[FFESTP_readixREC]);
4005   ffeste_subr_file_ ("SIZE", &info->read_spec[FFESTP_readixSIZE]);
4006   fputs (") ", dmpout);
4007 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
4008
4009   ffeste_emit_line_note_ ();
4010
4011   {
4012     ffecomGfrt start;
4013     ffecomGfrt end;
4014     tree cilist;
4015     bool iostat;
4016     bool errl;
4017     bool endl;
4018
4019     /* First determine the start, per-item, and end run-time functions to
4020        call.  The per-item function is picked by choosing an ffeste function
4021        to call to handle a given item; it knows how to generate a call to the
4022        appropriate run-time function, and is called an "I/O driver".  */
4023
4024     switch (format)
4025       {
4026       case FFESTV_formatNONE:   /* no FMT= */
4027         ffeste_io_driver_ = ffeste_io_douio_;
4028         if (rec)
4029           start = FFECOM_gfrtSRDUE, end = FFECOM_gfrtERDUE;
4030 #if 0
4031         else if (key)
4032           start = FFECOM_gfrtSRIUE, end = FFECOM_gfrtERIUE;
4033 #endif
4034         else
4035           start = FFECOM_gfrtSRSUE, end = FFECOM_gfrtERSUE;
4036         break;
4037
4038       case FFESTV_formatLABEL:  /* FMT=10 */
4039       case FFESTV_formatCHAREXPR:       /* FMT='(I10)' */
4040       case FFESTV_formatINTEXPR:        /* FMT=I [after ASSIGN 10 TO I] */
4041         ffeste_io_driver_ = ffeste_io_dofio_;
4042         if (rec)
4043           start = FFECOM_gfrtSRDFE, end = FFECOM_gfrtERDFE;
4044 #if 0
4045         else if (key)
4046           start = FFECOM_gfrtSRIFE, end = FFECOM_gfrtERIFE;
4047 #endif
4048         else if (unit == FFESTV_unitCHAREXPR)
4049           start = FFECOM_gfrtSRSFI, end = FFECOM_gfrtERSFI;
4050         else
4051           start = FFECOM_gfrtSRSFE, end = FFECOM_gfrtERSFE;
4052         break;
4053
4054       case FFESTV_formatASTERISK:       /* FMT=* */
4055         ffeste_io_driver_ = ffeste_io_dolio_;
4056         if (unit == FFESTV_unitCHAREXPR)
4057           start = FFECOM_gfrtSRSLI, end = FFECOM_gfrtERSLI;
4058         else
4059           start = FFECOM_gfrtSRSLE, end = FFECOM_gfrtERSLE;
4060         break;
4061
4062       case FFESTV_formatNAMELIST:       /* FMT=FOO or NML=FOO [NAMELIST
4063                                            /FOO/] */
4064         ffeste_io_driver_ = NULL;       /* No start or driver function. */
4065         start = FFECOM_gfrtSRSNE, end = FFECOM_gfrt;
4066         break;
4067
4068       default:
4069         assert ("Weird stuff" == NULL);
4070         start = FFECOM_gfrt, end = FFECOM_gfrt;
4071         break;
4072       }
4073     ffeste_io_endgfrt_ = end;
4074
4075 #define specified(something) (info->read_spec[something].kw_or_val_present)
4076
4077     iostat = specified (FFESTP_readixIOSTAT);
4078     errl = specified (FFESTP_readixERR);
4079     endl = specified (FFESTP_readixEND);
4080
4081 #undef specified
4082
4083     ffeste_start_stmt_ ();
4084
4085     if (errl)
4086       {
4087         /* Have ERR= specification.   */
4088
4089         ffeste_io_err_
4090           = ffecom_lookup_label (info->read_spec[FFESTP_readixERR].u.label);
4091
4092         if (endl)
4093           {
4094             /* Have both ERR= and END=.  Need a temp label to handle both.  */
4095             ffeste_io_end_
4096               = ffecom_lookup_label (info->read_spec[FFESTP_readixEND].u.label);
4097             ffeste_io_abort_is_temp_ = TRUE;
4098             ffeste_io_abort_ = ffecom_temp_label ();
4099           }
4100         else
4101           {
4102             /* Have ERR= but no END=.  */
4103             ffeste_io_end_ = NULL_TREE;
4104             if ((ffeste_io_abort_is_temp_ = iostat))
4105               ffeste_io_abort_ = ffecom_temp_label ();
4106             else
4107               ffeste_io_abort_ = ffeste_io_err_;
4108           }
4109       }
4110     else
4111       {
4112         /* No ERR= specification.  */
4113
4114         ffeste_io_err_ = NULL_TREE;
4115         if (endl)
4116           {
4117             /* Have END= but no ERR=.  */
4118             ffeste_io_end_
4119               = ffecom_lookup_label (info->read_spec[FFESTP_readixEND].u.label);
4120             if ((ffeste_io_abort_is_temp_ = iostat))
4121               ffeste_io_abort_ = ffecom_temp_label ();
4122             else
4123               ffeste_io_abort_ = ffeste_io_end_;
4124           }
4125         else
4126           {
4127             /* Have no ERR= or END=.  */
4128
4129             ffeste_io_end_ = NULL_TREE;
4130             if ((ffeste_io_abort_is_temp_ = iostat))
4131               ffeste_io_abort_ = ffecom_temp_label ();
4132             else
4133               ffeste_io_abort_ = NULL_TREE;
4134           }
4135       }
4136
4137     if (iostat)
4138       {
4139         /* Have IOSTAT= specification.  */
4140
4141         ffeste_io_iostat_is_temp_ = FALSE;
4142         ffeste_io_iostat_
4143           = ffecom_expr (info->read_spec[FFESTP_readixIOSTAT].u.expr);
4144       }
4145     else if (ffeste_io_abort_ != NULL_TREE)
4146       {
4147         /* Have no IOSTAT= but have ERR= and/or END=.  */
4148
4149         ffeste_io_iostat_is_temp_ = TRUE;
4150         ffeste_io_iostat_
4151           = ffecom_make_tempvar ("read", ffecom_integer_type_node,
4152                                  FFETARGET_charactersizeNONE, -1);
4153       }
4154     else
4155       {
4156         /* No IOSTAT=, ERR=, or END= specification.  */
4157
4158         ffeste_io_iostat_is_temp_ = FALSE;
4159         ffeste_io_iostat_ = NULL_TREE;
4160       }
4161
4162     /* Now prescan, then convert, all the arguments.  */
4163
4164     if (unit == FFESTV_unitCHAREXPR)
4165       cilist = ffeste_io_icilist_ (errl || iostat,
4166                                    info->read_spec[FFESTP_readixUNIT].u.expr,
4167                                    endl || iostat, format,
4168                                    &info->read_spec[FFESTP_readixFORMAT]);
4169     else
4170       cilist = ffeste_io_cilist_ (errl || iostat, unit,
4171                                   info->read_spec[FFESTP_readixUNIT].u.expr,
4172                                   5, endl || iostat, format,
4173                                   &info->read_spec[FFESTP_readixFORMAT],
4174                                   rec,
4175                                   info->read_spec[FFESTP_readixREC].u.expr);
4176
4177     /* If there is no end function, then there are no item functions (i.e.
4178        it's a NAMELIST), and vice versa by the way.  In this situation, don't
4179        generate the "if (iostat != 0) goto label;" if the label is temp abort
4180        label, since we're gonna fall through to there anyway.  */
4181
4182     ffeste_io_call_ (ffecom_call_gfrt (start, cilist, NULL_TREE),
4183                      (! ffeste_io_abort_is_temp_) || (end != FFECOM_gfrt));
4184   }
4185 #else
4186 #error
4187 #endif
4188 }
4189
4190 /* READ statement -- I/O item.  */
4191
4192 void
4193 ffeste_R909_item (ffebld expr, ffelexToken expr_token)
4194 {
4195   ffeste_check_item_ ();
4196
4197 #if FFECOM_targetCURRENT == FFECOM_targetFFE
4198   ffebld_dump (expr);
4199   fputc (',', dmpout);
4200 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
4201   if (expr == NULL)
4202     return;
4203
4204   /* Strip parens off items such as in "READ *,(A)".  This is really a bug
4205      in the user's code, but I've been told lots of code does this.  */
4206   while (ffebld_op (expr) == FFEBLD_opPAREN)
4207     expr = ffebld_left (expr);
4208
4209   if (ffebld_op (expr) == FFEBLD_opANY)
4210     return;
4211
4212   if (ffebld_op (expr) == FFEBLD_opIMPDO)
4213     ffeste_io_impdo_ (expr, expr_token);
4214   else
4215     {
4216       ffeste_start_stmt_ ();
4217
4218       ffecom_prepare_arg_ptr_to_expr (expr);
4219
4220       ffecom_prepare_end ();
4221
4222       ffeste_io_call_ ((*ffeste_io_driver_) (expr), TRUE);
4223
4224       ffeste_end_stmt_ ();
4225     }
4226 #else
4227 #error
4228 #endif
4229 }
4230
4231 /* READ statement -- end.  */
4232
4233 void
4234 ffeste_R909_finish ()
4235 {
4236   ffeste_check_finish_ ();
4237
4238 #if FFECOM_targetCURRENT == FFECOM_targetFFE
4239   fputc ('\n', dmpout);
4240 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
4241
4242   /* Don't generate "if (iostat != 0) goto label;" if label is temp abort
4243      label, since we're gonna fall through to there anyway. */
4244
4245   if (ffeste_io_endgfrt_ != FFECOM_gfrt)
4246     ffeste_io_call_ (ffecom_call_gfrt (ffeste_io_endgfrt_, NULL_TREE,
4247                                        NULL_TREE),
4248                      ! ffeste_io_abort_is_temp_);
4249
4250   /* If we've got a temp label, generate its code here and have it fan out
4251      to the END= or ERR= label as appropriate. */
4252
4253   if (ffeste_io_abort_is_temp_)
4254     {
4255       DECL_INITIAL (ffeste_io_abort_) = error_mark_node;
4256       emit_nop ();
4257       expand_label (ffeste_io_abort_);
4258
4259       /* "if (iostat<0) goto end_label;".  */
4260
4261       if ((ffeste_io_end_ != NULL_TREE)
4262           && (TREE_CODE (ffeste_io_end_) != ERROR_MARK))
4263         {
4264           expand_start_cond (ffecom_truth_value
4265                              (ffecom_2 (LT_EXPR, integer_type_node,
4266                                         ffeste_io_iostat_,
4267                                         ffecom_integer_zero_node)),
4268                              0);
4269           expand_goto (ffeste_io_end_);
4270           expand_end_cond ();
4271         }
4272
4273       /* "if (iostat>0) goto err_label;".  */
4274
4275       if ((ffeste_io_err_ != NULL_TREE)
4276           && (TREE_CODE (ffeste_io_err_) != ERROR_MARK))
4277         {
4278           expand_start_cond (ffecom_truth_value
4279                              (ffecom_2 (GT_EXPR, integer_type_node,
4280                                         ffeste_io_iostat_,
4281                                         ffecom_integer_zero_node)),
4282                              0);
4283           expand_goto (ffeste_io_err_);
4284           expand_end_cond ();
4285         }
4286     }
4287
4288   ffeste_end_stmt_ ();
4289 #else
4290 #error
4291 #endif
4292 }
4293
4294 /* WRITE statement -- start.  */
4295
4296 void
4297 ffeste_R910_start (ffestpWriteStmt *info, ffestvUnit unit,
4298                    ffestvFormat format, bool rec)
4299 {
4300   ffeste_check_start_ ();
4301
4302 #if FFECOM_targetCURRENT == FFECOM_targetFFE
4303   switch (format)
4304     {
4305     case FFESTV_formatNONE:
4306       if (rec)
4307         fputs ("+ WRITE_ufdac (", dmpout);
4308       else
4309         fputs ("+ WRITE_ufseq_or_idx (", dmpout);
4310       break;
4311
4312     case FFESTV_formatLABEL:
4313     case FFESTV_formatCHAREXPR:
4314     case FFESTV_formatINTEXPR:
4315       if (rec)
4316         fputs ("+ WRITE_fmdac (", dmpout);
4317       else if (unit == FFESTV_unitCHAREXPR)
4318         fputs ("+ WRITE_fmint (", dmpout);
4319       else
4320         fputs ("+ WRITE_fmseq_or_idx (", dmpout);
4321       break;
4322
4323     case FFESTV_formatASTERISK:
4324       if (unit == FFESTV_unitCHAREXPR)
4325         fputs ("+ WRITE_lsint (", dmpout);
4326       else
4327         fputs ("+ WRITE_lsseq (", dmpout);
4328       break;
4329
4330     case FFESTV_formatNAMELIST:
4331       fputs ("+ WRITE_nlseq (", dmpout);
4332       break;
4333
4334     default:
4335       assert ("Unexpected kind of format item in R910 WRITE" == NULL);
4336     }
4337
4338   ffeste_subr_file_ ("UNIT", &info->write_spec[FFESTP_writeixUNIT]);
4339   ffeste_subr_file_ ("FORMAT", &info->write_spec[FFESTP_writeixFORMAT]);
4340   ffeste_subr_file_ ("ADVANCE", &info->write_spec[FFESTP_writeixADVANCE]);
4341   ffeste_subr_file_ ("EOR", &info->write_spec[FFESTP_writeixEOR]);
4342   ffeste_subr_file_ ("ERR", &info->write_spec[FFESTP_writeixERR]);
4343   ffeste_subr_file_ ("IOSTAT", &info->write_spec[FFESTP_writeixIOSTAT]);
4344   ffeste_subr_file_ ("REC", &info->write_spec[FFESTP_writeixREC]);
4345   fputs (") ", dmpout);
4346 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
4347
4348   ffeste_emit_line_note_ ();
4349
4350   {
4351     ffecomGfrt start;
4352     ffecomGfrt end;
4353     tree cilist;
4354     bool iostat;
4355     bool errl;
4356
4357     /* First determine the start, per-item, and end run-time functions to
4358        call.  The per-item function is picked by choosing an ffeste function
4359        to call to handle a given item; it knows how to generate a call to the
4360        appropriate run-time function, and is called an "I/O driver".  */
4361
4362     switch (format)
4363       {
4364       case FFESTV_formatNONE:   /* no FMT= */
4365         ffeste_io_driver_ = ffeste_io_douio_;
4366         if (rec)
4367           start = FFECOM_gfrtSWDUE, end = FFECOM_gfrtEWDUE;
4368         else
4369           start = FFECOM_gfrtSWSUE, end = FFECOM_gfrtEWSUE;
4370         break;
4371
4372       case FFESTV_formatLABEL:  /* FMT=10 */
4373       case FFESTV_formatCHAREXPR:       /* FMT='(I10)' */
4374       case FFESTV_formatINTEXPR:        /* FMT=I [after ASSIGN 10 TO I] */
4375         ffeste_io_driver_ = ffeste_io_dofio_;
4376         if (rec)
4377           start = FFECOM_gfrtSWDFE, end = FFECOM_gfrtEWDFE;
4378         else if (unit == FFESTV_unitCHAREXPR)
4379           start = FFECOM_gfrtSWSFI, end = FFECOM_gfrtEWSFI;
4380         else
4381           start = FFECOM_gfrtSWSFE, end = FFECOM_gfrtEWSFE;
4382         break;
4383
4384       case FFESTV_formatASTERISK:       /* FMT=* */
4385         ffeste_io_driver_ = ffeste_io_dolio_;
4386         if (unit == FFESTV_unitCHAREXPR)
4387           start = FFECOM_gfrtSWSLI, end = FFECOM_gfrtEWSLI;
4388         else
4389           start = FFECOM_gfrtSWSLE, end = FFECOM_gfrtEWSLE;
4390         break;
4391
4392       case FFESTV_formatNAMELIST:       /* FMT=FOO or NML=FOO [NAMELIST
4393                                            /FOO/] */
4394         ffeste_io_driver_ = NULL;       /* No start or driver function. */
4395         start = FFECOM_gfrtSWSNE, end = FFECOM_gfrt;
4396         break;
4397
4398       default:
4399         assert ("Weird stuff" == NULL);
4400         start = FFECOM_gfrt, end = FFECOM_gfrt;
4401         break;
4402       }
4403     ffeste_io_endgfrt_ = end;
4404
4405 #define specified(something) (info->write_spec[something].kw_or_val_present)
4406
4407     iostat = specified (FFESTP_writeixIOSTAT);
4408     errl = specified (FFESTP_writeixERR);
4409
4410 #undef specified
4411
4412     ffeste_start_stmt_ ();
4413
4414     ffeste_io_end_ = NULL_TREE;
4415
4416     if (errl)
4417       {
4418         /* Have ERR= specification.   */
4419
4420         ffeste_io_err_
4421           = ffeste_io_abort_
4422           = ffecom_lookup_label
4423           (info->write_spec[FFESTP_writeixERR].u.label);
4424         ffeste_io_abort_is_temp_ = FALSE;
4425       }
4426     else
4427       {
4428         /* No ERR= specification.  */
4429
4430         ffeste_io_err_ = NULL_TREE;
4431
4432         if ((ffeste_io_abort_is_temp_ = iostat))
4433           ffeste_io_abort_ = ffecom_temp_label ();
4434         else
4435           ffeste_io_abort_ = NULL_TREE;
4436       }
4437
4438     if (iostat)
4439       {
4440         /* Have IOSTAT= specification.  */
4441
4442         ffeste_io_iostat_is_temp_ = FALSE;
4443         ffeste_io_iostat_ = ffecom_expr
4444           (info->write_spec[FFESTP_writeixIOSTAT].u.expr);
4445       }
4446     else if (ffeste_io_abort_ != NULL_TREE)
4447       {
4448         /* Have no IOSTAT= but have ERR=.  */
4449
4450         ffeste_io_iostat_is_temp_ = TRUE;
4451         ffeste_io_iostat_
4452           = ffecom_make_tempvar ("write", ffecom_integer_type_node,
4453                                  FFETARGET_charactersizeNONE, -1);
4454       }
4455     else
4456       {
4457         /* No IOSTAT= or ERR= specification.  */
4458
4459         ffeste_io_iostat_is_temp_ = FALSE;
4460         ffeste_io_iostat_ = NULL_TREE;
4461       }
4462
4463     /* Now prescan, then convert, all the arguments.  */
4464
4465     if (unit == FFESTV_unitCHAREXPR)
4466       cilist = ffeste_io_icilist_ (errl || iostat,
4467                                    info->write_spec[FFESTP_writeixUNIT].u.expr,
4468                                    FALSE, format,
4469                                    &info->write_spec[FFESTP_writeixFORMAT]);
4470     else
4471       cilist = ffeste_io_cilist_ (errl || iostat, unit,
4472                                   info->write_spec[FFESTP_writeixUNIT].u.expr,
4473                                   6, FALSE, format,
4474                                   &info->write_spec[FFESTP_writeixFORMAT],
4475                                   rec,
4476                                   info->write_spec[FFESTP_writeixREC].u.expr);
4477
4478     /* If there is no end function, then there are no item functions (i.e.
4479        it's a NAMELIST), and vice versa by the way.  In this situation, don't
4480        generate the "if (iostat != 0) goto label;" if the label is temp abort
4481        label, since we're gonna fall through to there anyway.  */
4482
4483     ffeste_io_call_ (ffecom_call_gfrt (start, cilist, NULL_TREE),
4484                      (! ffeste_io_abort_is_temp_) || (end != FFECOM_gfrt));
4485   }
4486 #else
4487 #error
4488 #endif
4489 }
4490
4491 /* WRITE statement -- I/O item.  */
4492
4493 void
4494 ffeste_R910_item (ffebld expr, ffelexToken expr_token)
4495 {
4496   ffeste_check_item_ ();
4497
4498 #if FFECOM_targetCURRENT == FFECOM_targetFFE
4499   ffebld_dump (expr);
4500   fputc (',', dmpout);
4501 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
4502   if (expr == NULL)
4503     return;
4504
4505   if (ffebld_op (expr) == FFEBLD_opANY)
4506     return;
4507
4508   if (ffebld_op (expr) == FFEBLD_opIMPDO)
4509     ffeste_io_impdo_ (expr, expr_token);
4510   else
4511     {
4512       ffeste_start_stmt_ ();
4513
4514       ffecom_prepare_arg_ptr_to_expr (expr);
4515
4516       ffecom_prepare_end ();
4517
4518       ffeste_io_call_ ((*ffeste_io_driver_) (expr), TRUE);
4519
4520       ffeste_end_stmt_ ();
4521     }
4522 #else
4523 #error
4524 #endif
4525 }
4526
4527 /* WRITE statement -- end.  */
4528
4529 void
4530 ffeste_R910_finish ()
4531 {
4532   ffeste_check_finish_ ();
4533
4534 #if FFECOM_targetCURRENT == FFECOM_targetFFE
4535   fputc ('\n', dmpout);
4536 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
4537
4538   /* Don't generate "if (iostat != 0) goto label;" if label is temp abort
4539      label, since we're gonna fall through to there anyway. */
4540
4541   if (ffeste_io_endgfrt_ != FFECOM_gfrt)
4542     ffeste_io_call_ (ffecom_call_gfrt (ffeste_io_endgfrt_, NULL_TREE,
4543                                        NULL_TREE),
4544                      ! ffeste_io_abort_is_temp_);
4545
4546   /* If we've got a temp label, generate its code here. */
4547
4548   if (ffeste_io_abort_is_temp_)
4549     {
4550       DECL_INITIAL (ffeste_io_abort_) = error_mark_node;
4551       emit_nop ();
4552       expand_label (ffeste_io_abort_);
4553
4554       assert (ffeste_io_err_ == NULL_TREE);
4555     }
4556
4557   ffeste_end_stmt_ ();
4558 #else
4559 #error
4560 #endif
4561 }
4562
4563 /* PRINT statement -- start.  */
4564
4565 void
4566 ffeste_R911_start (ffestpPrintStmt *info, ffestvFormat format)
4567 {
4568   ffeste_check_start_ ();
4569
4570 #if FFECOM_targetCURRENT == FFECOM_targetFFE
4571   switch (format)
4572     {
4573     case FFESTV_formatLABEL:
4574     case FFESTV_formatCHAREXPR:
4575     case FFESTV_formatINTEXPR:
4576       fputs ("+ PRINT_fm ", dmpout);
4577       break;
4578
4579     case FFESTV_formatASTERISK:
4580       fputs ("+ PRINT_ls ", dmpout);
4581       break;
4582
4583     case FFESTV_formatNAMELIST:
4584       fputs ("+ PRINT_nl ", dmpout);
4585       break;
4586
4587     default:
4588       assert ("Unexpected kind of format item in R911 PRINT" == NULL);
4589     }
4590   ffeste_subr_file_ ("FORMAT", &info->print_spec[FFESTP_printixFORMAT]);
4591   fputc (' ', dmpout);
4592 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
4593
4594   ffeste_emit_line_note_ ();
4595
4596   {
4597     ffecomGfrt start;
4598     ffecomGfrt end;
4599     tree cilist;
4600
4601     /* First determine the start, per-item, and end run-time functions to
4602        call.  The per-item function is picked by choosing an ffeste function
4603        to call to handle a given item; it knows how to generate a call to the
4604        appropriate run-time function, and is called an "I/O driver".  */
4605
4606     switch (format)
4607       {
4608       case FFESTV_formatLABEL:  /* FMT=10 */
4609       case FFESTV_formatCHAREXPR:       /* FMT='(I10)' */
4610       case FFESTV_formatINTEXPR:        /* FMT=I [after ASSIGN 10 TO I] */
4611         ffeste_io_driver_ = ffeste_io_dofio_;
4612         start = FFECOM_gfrtSWSFE, end = FFECOM_gfrtEWSFE;
4613         break;
4614
4615       case FFESTV_formatASTERISK:       /* FMT=* */
4616         ffeste_io_driver_ = ffeste_io_dolio_;
4617         start = FFECOM_gfrtSWSLE, end = FFECOM_gfrtEWSLE;
4618         break;
4619
4620       case FFESTV_formatNAMELIST:       /* FMT=FOO or NML=FOO [NAMELIST
4621                                            /FOO/] */
4622         ffeste_io_driver_ = NULL;       /* No start or driver function. */
4623         start = FFECOM_gfrtSWSNE, end = FFECOM_gfrt;
4624         break;
4625
4626       default:
4627         assert ("Weird stuff" == NULL);
4628         start = FFECOM_gfrt, end = FFECOM_gfrt;
4629         break;
4630       }
4631     ffeste_io_endgfrt_ = end;
4632
4633     ffeste_start_stmt_ ();
4634
4635     ffeste_io_end_ = NULL_TREE;
4636     ffeste_io_err_ = NULL_TREE;
4637     ffeste_io_abort_ = NULL_TREE;
4638     ffeste_io_abort_is_temp_ = FALSE;
4639     ffeste_io_iostat_is_temp_ = FALSE;
4640     ffeste_io_iostat_ = NULL_TREE;
4641
4642     /* Now prescan, then convert, all the arguments.  */
4643
4644     cilist = ffeste_io_cilist_ (FALSE, FFESTV_unitNONE, NULL, 6, FALSE, format,
4645                       &info->print_spec[FFESTP_printixFORMAT], FALSE, NULL);
4646
4647     /* If there is no end function, then there are no item functions (i.e.
4648        it's a NAMELIST), and vice versa by the way.  In this situation, don't
4649        generate the "if (iostat != 0) goto label;" if the label is temp abort
4650        label, since we're gonna fall through to there anyway.  */
4651
4652     ffeste_io_call_ (ffecom_call_gfrt (start, cilist, NULL_TREE),
4653                      (! ffeste_io_abort_is_temp_) || (end != FFECOM_gfrt));
4654   }
4655 #else
4656 #error
4657 #endif
4658 }
4659
4660 /* PRINT statement -- I/O item.  */
4661
4662 void
4663 ffeste_R911_item (ffebld expr, ffelexToken expr_token)
4664 {
4665   ffeste_check_item_ ();
4666
4667 #if FFECOM_targetCURRENT == FFECOM_targetFFE
4668   ffebld_dump (expr);
4669   fputc (',', dmpout);
4670 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
4671   if (expr == NULL)
4672     return;
4673
4674   if (ffebld_op (expr) == FFEBLD_opANY)
4675     return;
4676
4677   if (ffebld_op (expr) == FFEBLD_opIMPDO)
4678     ffeste_io_impdo_ (expr, expr_token);
4679   else
4680     {
4681       ffeste_start_stmt_ ();
4682
4683       ffecom_prepare_arg_ptr_to_expr (expr);
4684
4685       ffecom_prepare_end ();
4686
4687       ffeste_io_call_ ((*ffeste_io_driver_) (expr), TRUE);
4688
4689       ffeste_end_stmt_ ();
4690     }
4691 #else
4692 #error
4693 #endif
4694 }
4695
4696 /* PRINT statement -- end.  */
4697
4698 void
4699 ffeste_R911_finish ()
4700 {
4701   ffeste_check_finish_ ();
4702
4703 #if FFECOM_targetCURRENT == FFECOM_targetFFE
4704   fputc ('\n', dmpout);
4705 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
4706
4707   if (ffeste_io_endgfrt_ != FFECOM_gfrt)
4708     ffeste_io_call_ (ffecom_call_gfrt (ffeste_io_endgfrt_, NULL_TREE,
4709                                        NULL_TREE),
4710                      FALSE);
4711
4712   ffeste_end_stmt_ ();
4713 #else
4714 #error
4715 #endif
4716 }
4717
4718 /* BACKSPACE statement.  */
4719
4720 void
4721 ffeste_R919 (ffestpBeruStmt *info)
4722 {
4723   ffeste_check_simple_ ();
4724
4725 #if FFECOM_targetCURRENT == FFECOM_targetFFE
4726   fputs ("+ BACKSPACE (", dmpout);
4727   ffeste_subr_file_ ("UNIT", &info->beru_spec[FFESTP_beruixUNIT]);
4728   ffeste_subr_file_ ("ERR", &info->beru_spec[FFESTP_beruixERR]);
4729   ffeste_subr_file_ ("IOSTAT", &info->beru_spec[FFESTP_beruixIOSTAT]);
4730   fputs (")\n", dmpout);
4731 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
4732   ffeste_subr_beru_ (info, FFECOM_gfrtFBACK);
4733 #else
4734 #error
4735 #endif
4736 }
4737
4738 /* ENDFILE statement.  */
4739
4740 void
4741 ffeste_R920 (ffestpBeruStmt *info)
4742 {
4743   ffeste_check_simple_ ();
4744
4745 #if FFECOM_targetCURRENT == FFECOM_targetFFE
4746   fputs ("+ ENDFILE (", dmpout);
4747   ffeste_subr_file_ ("UNIT", &info->beru_spec[FFESTP_beruixUNIT]);
4748   ffeste_subr_file_ ("ERR", &info->beru_spec[FFESTP_beruixERR]);
4749   ffeste_subr_file_ ("IOSTAT", &info->beru_spec[FFESTP_beruixIOSTAT]);
4750   fputs (")\n", dmpout);
4751 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
4752   ffeste_subr_beru_ (info, FFECOM_gfrtFEND);
4753 #else
4754 #error
4755 #endif
4756 }
4757
4758 /* REWIND statement.  */
4759
4760 void
4761 ffeste_R921 (ffestpBeruStmt *info)
4762 {
4763   ffeste_check_simple_ ();
4764
4765 #if FFECOM_targetCURRENT == FFECOM_targetFFE
4766   fputs ("+ REWIND (", dmpout);
4767   ffeste_subr_file_ ("UNIT", &info->beru_spec[FFESTP_beruixUNIT]);
4768   ffeste_subr_file_ ("ERR", &info->beru_spec[FFESTP_beruixERR]);
4769   ffeste_subr_file_ ("IOSTAT", &info->beru_spec[FFESTP_beruixIOSTAT]);
4770   fputs (")\n", dmpout);
4771 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
4772   ffeste_subr_beru_ (info, FFECOM_gfrtFREW);
4773 #else
4774 #error
4775 #endif
4776 }
4777
4778 /* INQUIRE statement (non-IOLENGTH version).  */
4779
4780 void
4781 ffeste_R923A (ffestpInquireStmt *info, bool by_file UNUSED)
4782 {
4783   ffeste_check_simple_ ();
4784
4785 #if FFECOM_targetCURRENT == FFECOM_targetFFE
4786   if (by_file)
4787     {
4788       fputs ("+ INQUIRE_file (", dmpout);
4789       ffeste_subr_file_ ("FILE", &info->inquire_spec[FFESTP_inquireixFILE]);
4790     }
4791   else
4792     {
4793       fputs ("+ INQUIRE_unit (", dmpout);
4794       ffeste_subr_file_ ("UNIT", &info->inquire_spec[FFESTP_inquireixUNIT]);
4795     }
4796   ffeste_subr_file_ ("ACCESS", &info->inquire_spec[FFESTP_inquireixACCESS]);
4797   ffeste_subr_file_ ("ACTION", &info->inquire_spec[FFESTP_inquireixACTION]);
4798   ffeste_subr_file_ ("BLANK", &info->inquire_spec[FFESTP_inquireixBLANK]);
4799   ffeste_subr_file_ ("CARRIAGECONTROL", &info->inquire_spec[FFESTP_inquireixCARRIAGECONTROL]);
4800   ffeste_subr_file_ ("DEFAULTFILE", &info->inquire_spec[FFESTP_inquireixDEFAULTFILE]);
4801   ffeste_subr_file_ ("DELIM", &info->inquire_spec[FFESTP_inquireixDELIM]);
4802   ffeste_subr_file_ ("DIRECT", &info->inquire_spec[FFESTP_inquireixDIRECT]);
4803   ffeste_subr_file_ ("ERR", &info->inquire_spec[FFESTP_inquireixERR]);
4804   ffeste_subr_file_ ("EXIST", &info->inquire_spec[FFESTP_inquireixEXIST]);
4805   ffeste_subr_file_ ("FORM", &info->inquire_spec[FFESTP_inquireixFORM]);
4806   ffeste_subr_file_ ("FORMATTED", &info->inquire_spec[FFESTP_inquireixFORMATTED]);
4807   ffeste_subr_file_ ("IOSTAT", &info->inquire_spec[FFESTP_inquireixIOSTAT]);
4808   ffeste_subr_file_ ("KEYED", &info->inquire_spec[FFESTP_inquireixKEYED]);
4809   ffeste_subr_file_ ("NAME", &info->inquire_spec[FFESTP_inquireixNAME]);
4810   ffeste_subr_file_ ("NAMED", &info->inquire_spec[FFESTP_inquireixNAMED]);
4811   ffeste_subr_file_ ("NEXTREC", &info->inquire_spec[FFESTP_inquireixNEXTREC]);
4812   ffeste_subr_file_ ("NUMBER", &info->inquire_spec[FFESTP_inquireixNUMBER]);
4813   ffeste_subr_file_ ("OPENED", &info->inquire_spec[FFESTP_inquireixOPENED]);
4814   ffeste_subr_file_ ("ORGANIZATION", &info->inquire_spec[FFESTP_inquireixORGANIZATION]);
4815   ffeste_subr_file_ ("PAD", &info->inquire_spec[FFESTP_inquireixPAD]);
4816   ffeste_subr_file_ ("POSITION", &info->inquire_spec[FFESTP_inquireixPOSITION]);
4817   ffeste_subr_file_ ("READ", &info->inquire_spec[FFESTP_inquireixREAD]);
4818   ffeste_subr_file_ ("READWRITE", &info->inquire_spec[FFESTP_inquireixREADWRITE]);
4819   ffeste_subr_file_ ("RECL", &info->inquire_spec[FFESTP_inquireixRECL]);
4820   ffeste_subr_file_ ("RECORDTYPE", &info->inquire_spec[FFESTP_inquireixRECORDTYPE]);
4821   ffeste_subr_file_ ("SEQUENTIAL", &info->inquire_spec[FFESTP_inquireixSEQUENTIAL]);
4822   ffeste_subr_file_ ("UNFORMATTED", &info->inquire_spec[FFESTP_inquireixUNFORMATTED]);
4823   ffeste_subr_file_ ("WRITE", &info->inquire_spec[FFESTP_inquireixWRITE]);
4824   fputs (")\n", dmpout);
4825 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
4826   {
4827     tree args;
4828     bool iostat;
4829     bool errl;
4830
4831     ffeste_emit_line_note_ ();
4832
4833 #define specified(something) (info->inquire_spec[something].kw_or_val_present)
4834
4835     iostat = specified (FFESTP_inquireixIOSTAT);
4836     errl = specified (FFESTP_inquireixERR);
4837
4838 #undef specified
4839
4840     ffeste_start_stmt_ ();
4841
4842     if (errl)
4843       {
4844         ffeste_io_err_
4845           = ffeste_io_abort_
4846           = ffecom_lookup_label
4847           (info->inquire_spec[FFESTP_inquireixERR].u.label);
4848         ffeste_io_abort_is_temp_ = FALSE;
4849       }
4850     else
4851       {
4852         ffeste_io_err_ = NULL_TREE;
4853
4854         if ((ffeste_io_abort_is_temp_ = iostat))
4855           ffeste_io_abort_ = ffecom_temp_label ();
4856         else
4857           ffeste_io_abort_ = NULL_TREE;
4858       }
4859
4860     if (iostat)
4861       {
4862         /* Have IOSTAT= specification.  */
4863
4864         ffeste_io_iostat_is_temp_ = FALSE;
4865         ffeste_io_iostat_ = ffecom_expr
4866           (info->inquire_spec[FFESTP_inquireixIOSTAT].u.expr);
4867       }
4868     else if (ffeste_io_abort_ != NULL_TREE)
4869       {
4870         /* Have no IOSTAT= but have ERR=.  */
4871
4872         ffeste_io_iostat_is_temp_ = TRUE;
4873         ffeste_io_iostat_
4874           = ffecom_make_tempvar ("inquire", ffecom_integer_type_node,
4875                                  FFETARGET_charactersizeNONE, -1);
4876       }
4877     else
4878       {
4879         /* No IOSTAT= or ERR= specification.  */
4880
4881         ffeste_io_iostat_is_temp_ = FALSE;
4882         ffeste_io_iostat_ = NULL_TREE;
4883       }
4884
4885     /* Now prescan, then convert, all the arguments.  */
4886
4887     args
4888       = ffeste_io_inlist_ (errl || iostat,
4889                            &info->inquire_spec[FFESTP_inquireixUNIT],
4890                            &info->inquire_spec[FFESTP_inquireixFILE],
4891                            &info->inquire_spec[FFESTP_inquireixEXIST],
4892                            &info->inquire_spec[FFESTP_inquireixOPENED],
4893                            &info->inquire_spec[FFESTP_inquireixNUMBER],
4894                            &info->inquire_spec[FFESTP_inquireixNAMED],
4895                            &info->inquire_spec[FFESTP_inquireixNAME],
4896                            &info->inquire_spec[FFESTP_inquireixACCESS],
4897                            &info->inquire_spec[FFESTP_inquireixSEQUENTIAL],
4898                            &info->inquire_spec[FFESTP_inquireixDIRECT],
4899                            &info->inquire_spec[FFESTP_inquireixFORM],
4900                            &info->inquire_spec[FFESTP_inquireixFORMATTED],
4901                            &info->inquire_spec[FFESTP_inquireixUNFORMATTED],
4902                            &info->inquire_spec[FFESTP_inquireixRECL],
4903                            &info->inquire_spec[FFESTP_inquireixNEXTREC],
4904                            &info->inquire_spec[FFESTP_inquireixBLANK]);
4905
4906     /* Don't generate "if (iostat != 0) goto label;" if label is temp abort
4907        label, since we're gonna fall through to there anyway. */
4908
4909     ffeste_io_call_ (ffecom_call_gfrt (FFECOM_gfrtFINQU, args, NULL_TREE),
4910                      ! ffeste_io_abort_is_temp_);
4911
4912     /* If we've got a temp label, generate its code here.  */
4913
4914     if (ffeste_io_abort_is_temp_)
4915       {
4916         DECL_INITIAL (ffeste_io_abort_) = error_mark_node;
4917         emit_nop ();
4918         expand_label (ffeste_io_abort_);
4919
4920         assert (ffeste_io_err_ == NULL_TREE);
4921       }
4922
4923     ffeste_end_stmt_ ();
4924   }
4925 #else
4926 #error
4927 #endif
4928 }
4929
4930 /* INQUIRE(IOLENGTH=expr) statement -- start.  */
4931
4932 void
4933 ffeste_R923B_start (ffestpInquireStmt *info UNUSED)
4934 {
4935   ffeste_check_start_ ();
4936
4937 #if FFECOM_targetCURRENT == FFECOM_targetFFE
4938   fputs ("+ INQUIRE (", dmpout);
4939   ffeste_subr_file_ ("IOLENGTH", &info->inquire_spec[FFESTP_inquireixIOLENGTH]);
4940   fputs (") ", dmpout);
4941 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
4942   assert ("INQUIRE(IOLENGTH=<var>) not implemented yet! ~~~" == NULL);
4943
4944   ffeste_emit_line_note_ ();
4945 #else
4946 #error
4947 #endif
4948 }
4949
4950 /* INQUIRE(IOLENGTH=expr) statement -- I/O item.  */
4951
4952 void
4953 ffeste_R923B_item (ffebld expr UNUSED)
4954 {
4955   ffeste_check_item_ ();
4956
4957 #if FFECOM_targetCURRENT == FFECOM_targetFFE
4958   ffebld_dump (expr);
4959   fputc (',', dmpout);
4960 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
4961 #else
4962 #error
4963 #endif
4964 }
4965
4966 /* INQUIRE(IOLENGTH=expr) statement -- end.  */
4967
4968 void
4969 ffeste_R923B_finish ()
4970 {
4971   ffeste_check_finish_ ();
4972
4973 #if FFECOM_targetCURRENT == FFECOM_targetFFE
4974   fputc ('\n', dmpout);
4975 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
4976 #else
4977 #error
4978 #endif
4979 }
4980
4981 /* ffeste_R1001 -- FORMAT statement
4982
4983    ffeste_R1001(format_list);  */
4984
4985 void
4986 ffeste_R1001 (ffests s)
4987 {
4988   ffeste_check_simple_ ();
4989
4990 #if FFECOM_targetCURRENT == FFECOM_targetFFE
4991   fprintf (dmpout, "$ FORMAT %.*s\n", (int) ffests_length (s), ffests_text (s));
4992 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
4993   {
4994     tree t;
4995     tree ttype;
4996     tree maxindex;
4997     tree var;
4998
4999     assert (ffeste_label_formatdef_ != NULL);
5000
5001     ffeste_emit_line_note_ ();
5002
5003     t = build_string (ffests_length (s), ffests_text (s));
5004
5005     TREE_TYPE (t)
5006       = build_type_variant (build_array_type
5007                             (char_type_node,
5008                              build_range_type (integer_type_node,
5009                                                integer_one_node,
5010                                              build_int_2 (ffests_length (s),
5011                                                           0))),
5012                             1, 0);
5013     TREE_CONSTANT (t) = 1;
5014     TREE_STATIC (t) = 1;
5015
5016     push_obstacks_nochange ();
5017     end_temporary_allocation ();
5018
5019     var = ffecom_lookup_label (ffeste_label_formatdef_);
5020     if ((var != NULL_TREE)
5021         && (TREE_CODE (var) == VAR_DECL))
5022       {
5023         DECL_INITIAL (var) = t;
5024         maxindex = build_int_2 (ffests_length (s) - 1, 0);
5025         ttype = TREE_TYPE (var);
5026         TYPE_DOMAIN (ttype) = build_range_type (integer_type_node,
5027                                                 integer_zero_node,
5028                                                 maxindex);
5029         if (!TREE_TYPE (maxindex))
5030           TREE_TYPE (maxindex) = TYPE_DOMAIN (ttype);
5031         layout_type (ttype);
5032         rest_of_decl_compilation (var, NULL, 1, 0);
5033         expand_decl (var);
5034         expand_decl_init (var);
5035       }
5036
5037     resume_temporary_allocation ();
5038     pop_obstacks ();
5039
5040     ffeste_label_formatdef_ = NULL;
5041   }
5042 #else
5043 #error
5044 #endif
5045 }
5046
5047 /* END PROGRAM.  */
5048
5049 void
5050 ffeste_R1103 ()
5051 {
5052 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5053   fputs ("+ END_PROGRAM\n", dmpout);
5054 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5055 #else
5056 #error
5057 #endif
5058 }
5059
5060 /* END BLOCK DATA.  */
5061
5062 void
5063 ffeste_R1112 ()
5064 {
5065 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5066   fputs ("* END_BLOCK_DATA\n", dmpout);
5067 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5068 #else
5069 #error
5070 #endif
5071 }
5072
5073 /* CALL statement.  */
5074
5075 void
5076 ffeste_R1212 (ffebld expr)
5077 {
5078   ffeste_check_simple_ ();
5079
5080 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5081   fputs ("+ CALL ", dmpout);
5082   ffebld_dump (expr);
5083   fputc ('\n', dmpout);
5084 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5085   {
5086     ffebld args = ffebld_right (expr);
5087     ffebld arg;
5088     ffebld labels = NULL;       /* First in list of LABTERs. */
5089     ffebld prevlabels = NULL;
5090     ffebld prevargs = NULL;
5091
5092     ffeste_emit_line_note_ ();
5093
5094     /* Here we split the list at ffebld_right(expr) into two lists: one at
5095        ffebld_right(expr) consisting of all items that are not LABTERs, the
5096        other at labels consisting of all items that are LABTERs.  Then, if
5097        the latter list is NULL, we have an ordinary call, else we have a call
5098        with alternate returns. */
5099
5100     for (args = ffebld_right (expr); args != NULL; args = ffebld_trail (args))
5101       {
5102         if (((arg = ffebld_head (args)) == NULL)
5103             || (ffebld_op (arg) != FFEBLD_opLABTER))
5104           {
5105             if (prevargs == NULL)
5106               {
5107                 prevargs = args;
5108                 ffebld_set_right (expr, args);
5109               }
5110             else
5111               {
5112                 ffebld_set_trail (prevargs, args);
5113                 prevargs = args;
5114               }
5115           }
5116         else
5117           {
5118             if (prevlabels == NULL)
5119               {
5120                 prevlabels = labels = args;
5121               }
5122             else
5123               {
5124                 ffebld_set_trail (prevlabels, args);
5125                 prevlabels = args;
5126               }
5127           }
5128       }
5129     if (prevlabels == NULL)
5130       labels = NULL;
5131     else
5132       ffebld_set_trail (prevlabels, NULL);
5133     if (prevargs == NULL)
5134       ffebld_set_right (expr, NULL);
5135     else
5136       ffebld_set_trail (prevargs, NULL);
5137
5138     ffeste_start_stmt_ ();
5139
5140     /* No temporaries are actually needed at this level, but we go
5141        through the motions anyway, just to be sure in case they do
5142        get made.  Temporaries needed for arguments should be in the
5143        scopes of inner blocks, and if clean-up actions are supported,
5144        such as CALL-ing an intrinsic that writes to an argument of one
5145        type when a variable of a different type is provided (requiring
5146        assignment to the variable from a temporary after the library
5147        routine returns), the clean-up must be done by the expression
5148        evaluator, generally, to handle alternate returns (which we hope
5149        won't ever be supported by intrinsics, but might be a similar
5150        issue, such as CALL-ing an F90-style subroutine with an INTERFACE
5151        block).  That implies the expression evaluator will have to
5152        recognize the need for its own temporary anyway, meaning it'll
5153        construct a block within the one constructed here.  */
5154
5155     ffecom_prepare_expr (expr);
5156
5157     ffecom_prepare_end ();
5158
5159     if (labels == NULL)
5160       expand_expr_stmt (ffecom_expr (expr));
5161     else
5162       {
5163         tree texpr;
5164         tree value;
5165         tree tlabel;
5166         int caseno;
5167         int pushok;
5168         tree duplicate;
5169         ffebld label;
5170
5171         texpr = ffecom_expr (expr);
5172         expand_start_case (0, texpr, TREE_TYPE (texpr), "CALL statement");
5173
5174         for (caseno = 1, label = labels;
5175              label != NULL;
5176              ++caseno, label = ffebld_trail (label))
5177           {
5178             value = build_int_2 (caseno, 0);
5179             tlabel = build_decl (LABEL_DECL, NULL_TREE, NULL_TREE);
5180
5181             pushok = pushcase (value, convert, tlabel, &duplicate);
5182             assert (pushok == 0);
5183
5184             tlabel
5185               = ffecom_lookup_label (ffebld_labter (ffebld_head (label)));
5186             if ((tlabel == NULL_TREE)
5187                 || (TREE_CODE (tlabel) == ERROR_MARK))
5188               continue;
5189             TREE_USED (tlabel) = 1;
5190             expand_goto (tlabel);
5191           }
5192
5193         expand_end_case (texpr);
5194       }
5195
5196     ffeste_end_stmt_ ();
5197   }
5198 #else
5199 #error
5200 #endif
5201 }
5202
5203 /* END FUNCTION.  */
5204
5205 void
5206 ffeste_R1221 ()
5207 {
5208 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5209   fputs ("+ END_FUNCTION\n", dmpout);
5210 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5211 #else
5212 #error
5213 #endif
5214 }
5215
5216 /* END SUBROUTINE.  */
5217
5218 void
5219 ffeste_R1225 ()
5220 {
5221 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5222   fprintf (dmpout, "+ END_SUBROUTINE\n");
5223 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5224 #else
5225 #error
5226 #endif
5227 }
5228
5229 /* ENTRY statement.  */
5230
5231 void
5232 ffeste_R1226 (ffesymbol entry)
5233 {
5234   ffeste_check_simple_ ();
5235
5236 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5237   fprintf (dmpout, "+ ENTRY %s", ffesymbol_text (entry));
5238   if (ffesymbol_dummyargs (entry) != NULL)
5239     {
5240       ffebld argh;
5241
5242       fputc ('(', dmpout);
5243       for (argh = ffesymbol_dummyargs (entry);
5244            argh != NULL;
5245            argh = ffebld_trail (argh))
5246         {
5247           assert (ffebld_head (argh) != NULL);
5248           switch (ffebld_op (ffebld_head (argh)))
5249             {
5250             case FFEBLD_opSYMTER:
5251               fputs (ffesymbol_text (ffebld_symter (ffebld_head (argh))),
5252                      dmpout);
5253               break;
5254
5255             case FFEBLD_opSTAR:
5256               fputc ('*', dmpout);
5257               break;
5258
5259             default:
5260               fputc ('?', dmpout);
5261               ffebld_dump (ffebld_head (argh));
5262               fputc ('?', dmpout);
5263               break;
5264             }
5265           if (ffebld_trail (argh) != NULL)
5266             fputc (',', dmpout);
5267         }
5268       fputc (')', dmpout);
5269     }
5270   fputc ('\n', dmpout);
5271 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5272   {
5273     tree label = ffesymbol_hook (entry).length_tree;
5274
5275     ffeste_emit_line_note_ ();
5276
5277     if (label == error_mark_node)
5278       return;
5279
5280     DECL_INITIAL (label) = error_mark_node;
5281     emit_nop ();
5282     expand_label (label);
5283   }
5284 #else
5285 #error
5286 #endif
5287 }
5288
5289 /* RETURN statement.  */
5290
5291 void
5292 ffeste_R1227 (ffestw block UNUSED, ffebld expr)
5293 {
5294   ffeste_check_simple_ ();
5295
5296 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5297   if (expr == NULL)
5298     {
5299       fputs ("+ RETURN\n", dmpout);
5300     }
5301   else
5302     {
5303       fputs ("+ RETURN_alternate ", dmpout);
5304       ffebld_dump (expr);
5305       fputc ('\n', dmpout);
5306     }
5307 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5308   {
5309     tree rtn;
5310
5311     ffeste_emit_line_note_ ();
5312
5313     ffeste_start_stmt_ ();
5314
5315     ffecom_prepare_return_expr (expr);
5316
5317     ffecom_prepare_end ();
5318
5319     rtn = ffecom_return_expr (expr);
5320
5321     if ((rtn == NULL_TREE)
5322         || (rtn == error_mark_node))
5323       expand_null_return ();
5324     else
5325       {
5326         tree result = DECL_RESULT (current_function_decl);
5327
5328         if ((result != error_mark_node)
5329             && (TREE_TYPE (result) != error_mark_node))
5330           expand_return (ffecom_modify (NULL_TREE,
5331                                         result,
5332                                         convert (TREE_TYPE (result),
5333                                                  rtn)));
5334         else
5335           expand_null_return ();
5336       }
5337
5338     ffeste_end_stmt_ ();
5339   }
5340 #else
5341 #error
5342 #endif
5343 }
5344
5345 /* REWRITE statement -- start.  */
5346
5347 #if FFESTR_VXT
5348 void
5349 ffeste_V018_start (ffestpRewriteStmt *info, ffestvFormat format)
5350 {
5351   ffeste_check_start_ ();
5352
5353 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5354   switch (format)
5355     {
5356     case FFESTV_formatNONE:
5357       fputs ("+ REWRITE_uf (", dmpout);
5358       break;
5359
5360     case FFESTV_formatLABEL:
5361     case FFESTV_formatCHAREXPR:
5362     case FFESTV_formatINTEXPR:
5363       fputs ("+ REWRITE_fm (", dmpout);
5364       break;
5365
5366     default:
5367       assert ("Unexpected kind of format item in V018 REWRITE" == NULL);
5368     }
5369   ffeste_subr_file_ ("UNIT", &info->rewrite_spec[FFESTP_rewriteixUNIT]);
5370   ffeste_subr_file_ ("FMT", &info->rewrite_spec[FFESTP_rewriteixFMT]);
5371   ffeste_subr_file_ ("ERR", &info->rewrite_spec[FFESTP_rewriteixERR]);
5372   ffeste_subr_file_ ("IOSTAT", &info->rewrite_spec[FFESTP_rewriteixIOSTAT]);
5373   fputs (") ", dmpout);
5374 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5375 #else
5376 #error
5377 #endif
5378 }
5379
5380 /* REWRITE statement -- I/O item.  */
5381
5382 void
5383 ffeste_V018_item (ffebld expr)
5384 {
5385   ffeste_check_item_ ();
5386
5387 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5388   ffebld_dump (expr);
5389   fputc (',', dmpout);
5390 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5391 #else
5392 #error
5393 #endif
5394 }
5395
5396 /* REWRITE statement -- end.  */
5397
5398 void
5399 ffeste_V018_finish ()
5400 {
5401   ffeste_check_finish_ ();
5402
5403 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5404   fputc ('\n', dmpout);
5405 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5406 #else
5407 #error
5408 #endif
5409 }
5410
5411 /* ACCEPT statement -- start.  */
5412
5413 void
5414 ffeste_V019_start (ffestpAcceptStmt *info, ffestvFormat format)
5415 {
5416   ffeste_check_start_ ();
5417
5418 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5419   switch (format)
5420     {
5421     case FFESTV_formatLABEL:
5422     case FFESTV_formatCHAREXPR:
5423     case FFESTV_formatINTEXPR:
5424       fputs ("+ ACCEPT_fm ", dmpout);
5425       break;
5426
5427     case FFESTV_formatASTERISK:
5428       fputs ("+ ACCEPT_ls ", dmpout);
5429       break;
5430
5431     case FFESTV_formatNAMELIST:
5432       fputs ("+ ACCEPT_nl ", dmpout);
5433       break;
5434
5435     default:
5436       assert ("Unexpected kind of format item in V019 ACCEPT" == NULL);
5437     }
5438   ffeste_subr_file_ ("FORMAT", &info->accept_spec[FFESTP_acceptixFORMAT]);
5439   fputc (' ', dmpout);
5440 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5441 #else
5442 #error
5443 #endif
5444 }
5445
5446 /* ACCEPT statement -- I/O item.  */
5447
5448 void
5449 ffeste_V019_item (ffebld expr)
5450 {
5451   ffeste_check_item_ ();
5452
5453 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5454   ffebld_dump (expr);
5455   fputc (',', dmpout);
5456 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5457 #else
5458 #error
5459 #endif
5460 }
5461
5462 /* ACCEPT statement -- end.  */
5463
5464 void
5465 ffeste_V019_finish ()
5466 {
5467   ffeste_check_finish_ ();
5468
5469 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5470   fputc ('\n', dmpout);
5471 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5472 #else
5473 #error
5474 #endif
5475 }
5476
5477 #endif
5478 /* TYPE statement -- start.  */
5479
5480 void
5481 ffeste_V020_start (ffestpTypeStmt *info UNUSED,
5482                    ffestvFormat format UNUSED)
5483 {
5484   ffeste_check_start_ ();
5485
5486 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5487   switch (format)
5488     {
5489     case FFESTV_formatLABEL:
5490     case FFESTV_formatCHAREXPR:
5491     case FFESTV_formatINTEXPR:
5492       fputs ("+ TYPE_fm ", dmpout);
5493       break;
5494
5495     case FFESTV_formatASTERISK:
5496       fputs ("+ TYPE_ls ", dmpout);
5497       break;
5498
5499     case FFESTV_formatNAMELIST:
5500       fputs ("* TYPE_nl ", dmpout);
5501       break;
5502
5503     default:
5504       assert ("Unexpected kind of format item in V020 TYPE" == NULL);
5505     }
5506   ffeste_subr_file_ ("FORMAT", &info->type_spec[FFESTP_typeixFORMAT]);
5507   fputc (' ', dmpout);
5508 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5509 #else
5510 #error
5511 #endif
5512 }
5513
5514 /* TYPE statement -- I/O item.  */
5515
5516 void
5517 ffeste_V020_item (ffebld expr UNUSED)
5518 {
5519   ffeste_check_item_ ();
5520
5521 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5522   ffebld_dump (expr);
5523   fputc (',', dmpout);
5524 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5525 #else
5526 #error
5527 #endif
5528 }
5529
5530 /* TYPE statement -- end.  */
5531
5532 void
5533 ffeste_V020_finish ()
5534 {
5535   ffeste_check_finish_ ();
5536
5537 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5538   fputc ('\n', dmpout);
5539 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5540 #else
5541 #error
5542 #endif
5543 }
5544
5545 /* DELETE statement.  */
5546
5547 #if FFESTR_VXT
5548 void
5549 ffeste_V021 (ffestpDeleteStmt *info)
5550 {
5551   ffeste_check_simple_ ();
5552
5553 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5554   fputs ("+ DELETE (", dmpout);
5555   ffeste_subr_file_ ("UNIT", &info->delete_spec[FFESTP_deleteixUNIT]);
5556   ffeste_subr_file_ ("REC", &info->delete_spec[FFESTP_deleteixREC]);
5557   ffeste_subr_file_ ("ERR", &info->delete_spec[FFESTP_deleteixERR]);
5558   ffeste_subr_file_ ("IOSTAT", &info->delete_spec[FFESTP_deleteixIOSTAT]);
5559   fputs (")\n", dmpout);
5560 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5561 #else
5562 #error
5563 #endif
5564 }
5565
5566 /* UNLOCK statement.  */
5567
5568 void
5569 ffeste_V022 (ffestpBeruStmt *info)
5570 {
5571   ffeste_check_simple_ ();
5572
5573 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5574   fputs ("+ UNLOCK (", dmpout);
5575   ffeste_subr_file_ ("UNIT", &info->beru_spec[FFESTP_beruixUNIT]);
5576   ffeste_subr_file_ ("ERR", &info->beru_spec[FFESTP_beruixERR]);
5577   ffeste_subr_file_ ("IOSTAT", &info->beru_spec[FFESTP_beruixIOSTAT]);
5578   fputs (")\n", dmpout);
5579 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5580 #else
5581 #error
5582 #endif
5583 }
5584
5585 /* ENCODE statement -- start.  */
5586
5587 void
5588 ffeste_V023_start (ffestpVxtcodeStmt *info)
5589 {
5590   ffeste_check_start_ ();
5591
5592 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5593   fputs ("+ ENCODE (", dmpout);
5594   ffeste_subr_file_ ("C", &info->vxtcode_spec[FFESTP_vxtcodeixC]);
5595   ffeste_subr_file_ ("F", &info->vxtcode_spec[FFESTP_vxtcodeixF]);
5596   ffeste_subr_file_ ("B", &info->vxtcode_spec[FFESTP_vxtcodeixB]);
5597   ffeste_subr_file_ ("ERR", &info->vxtcode_spec[FFESTP_vxtcodeixERR]);
5598   ffeste_subr_file_ ("IOSTAT", &info->vxtcode_spec[FFESTP_vxtcodeixIOSTAT]);
5599   fputs (") ", dmpout);
5600 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5601 #else
5602 #error
5603 #endif
5604 }
5605
5606 /* ENCODE statement -- I/O item.  */
5607
5608 void
5609 ffeste_V023_item (ffebld expr)
5610 {
5611   ffeste_check_item_ ();
5612
5613 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5614   ffebld_dump (expr);
5615   fputc (',', dmpout);
5616 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5617 #else
5618 #error
5619 #endif
5620 }
5621
5622 /* ENCODE statement -- end.  */
5623
5624 void
5625 ffeste_V023_finish ()
5626 {
5627   ffeste_check_finish_ ();
5628
5629 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5630   fputc ('\n', dmpout);
5631 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5632 #else
5633 #error
5634 #endif
5635 }
5636
5637 /* DECODE statement -- start.  */
5638
5639 void
5640 ffeste_V024_start (ffestpVxtcodeStmt *info)
5641 {
5642   ffeste_check_start_ ();
5643
5644 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5645   fputs ("+ DECODE (", dmpout);
5646   ffeste_subr_file_ ("C", &info->vxtcode_spec[FFESTP_vxtcodeixC]);
5647   ffeste_subr_file_ ("F", &info->vxtcode_spec[FFESTP_vxtcodeixF]);
5648   ffeste_subr_file_ ("B", &info->vxtcode_spec[FFESTP_vxtcodeixB]);
5649   ffeste_subr_file_ ("ERR", &info->vxtcode_spec[FFESTP_vxtcodeixERR]);
5650   ffeste_subr_file_ ("IOSTAT", &info->vxtcode_spec[FFESTP_vxtcodeixIOSTAT]);
5651   fputs (") ", dmpout);
5652 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5653 #else
5654 #error
5655 #endif
5656 }
5657
5658 /* DECODE statement -- I/O item.  */
5659
5660 void
5661 ffeste_V024_item (ffebld expr)
5662 {
5663   ffeste_check_item_ ();
5664
5665 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5666   ffebld_dump (expr);
5667   fputc (',', dmpout);
5668 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5669 #else
5670 #error
5671 #endif
5672 }
5673
5674 /* DECODE statement -- end.  */
5675
5676 void
5677 ffeste_V024_finish ()
5678 {
5679   ffeste_check_finish_ ();
5680
5681 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5682   fputc ('\n', dmpout);
5683 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5684 #else
5685 #error
5686 #endif
5687 }
5688
5689 /* DEFINEFILE statement -- start.  */
5690
5691 void
5692 ffeste_V025_start ()
5693 {
5694   ffeste_check_start_ ();
5695
5696 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5697   fputs ("+ DEFINE_FILE ", dmpout);
5698 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5699 #else
5700 #error
5701 #endif
5702 }
5703
5704 /* DEFINE FILE statement -- item.  */
5705
5706 void
5707 ffeste_V025_item (ffebld u, ffebld m, ffebld n, ffebld asv)
5708 {
5709   ffeste_check_item_ ();
5710
5711 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5712   ffebld_dump (u);
5713   fputc ('(', dmpout);
5714   ffebld_dump (m);
5715   fputc (',', dmpout);
5716   ffebld_dump (n);
5717   fputs (",U,", dmpout);
5718   ffebld_dump (asv);
5719   fputs ("),", dmpout);
5720 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5721 #else
5722 #error
5723 #endif
5724 }
5725
5726 /* DEFINE FILE statement -- end.  */
5727
5728 void
5729 ffeste_V025_finish ()
5730 {
5731   ffeste_check_finish_ ();
5732
5733 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5734   fputc ('\n', dmpout);
5735 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5736 #else
5737 #error
5738 #endif
5739 }
5740
5741 /* FIND statement.  */
5742
5743 void
5744 ffeste_V026 (ffestpFindStmt *info)
5745 {
5746   ffeste_check_simple_ ();
5747
5748 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5749   fputs ("+ FIND (", dmpout);
5750   ffeste_subr_file_ ("UNIT", &info->find_spec[FFESTP_findixUNIT]);
5751   ffeste_subr_file_ ("REC", &info->find_spec[FFESTP_findixREC]);
5752   ffeste_subr_file_ ("ERR", &info->find_spec[FFESTP_findixERR]);
5753   ffeste_subr_file_ ("IOSTAT", &info->find_spec[FFESTP_findixIOSTAT]);
5754   fputs (")\n", dmpout);
5755 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5756 #else
5757 #error
5758 #endif
5759 }
5760
5761 #endif
5762
5763 #ifdef ENABLE_CHECKING
5764 void
5765 ffeste_terminate_2 (void)
5766 {
5767   assert (! ffeste_top_block_);
5768 }
5769 #endif