gcc/f/ste.c

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