gcc/f/ste.c

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