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