gcc/f/ste.c

   1 /* ste.c -- Implementation File (module.c template V1.0)
   2    Copyright (C) 1995, 1996, 2000, 2002 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_top_cond (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 GTY(()) tree f2c_alist_struct;
1166 static tree
1167 ffeste_io_ialist_ (bool have_err,
1168                    ffestvUnit unit,
1169                    ffebld unit_expr,
1170                    int unit_dflt)
1171 {
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       f2c_alist_struct = ref;
1197     }
1198
1199   /* Try to do as much compile-time initialization of the structure
1200      as possible, to save run time.  */
1201
1202   ffeste_f2c_init_flag_ (have_err, errinit);
1203
1204   switch (unit)
1205     {
1206     case FFESTV_unitNONE:
1207     case FFESTV_unitASTERISK:
1208       unitinit = build_int_2 (unit_dflt, 0);
1209       unitexp = unitinit;
1210       break;
1211
1212     case FFESTV_unitINTEXPR:
1213       unitexp = ffecom_const_expr (unit_expr);
1214       if (unitexp)
1215         unitinit = unitexp;
1216       else
1217         {
1218           unitinit = ffecom_integer_zero_node;
1219           constantp = FALSE;
1220         }
1221       break;
1222
1223     default:
1224       assert ("bad unit spec" == NULL);
1225       unitinit = ffecom_integer_zero_node;
1226       unitexp = unitinit;
1227       break;
1228     }
1229
1230   inits = build_tree_list ((field = TYPE_FIELDS (f2c_alist_struct)), errinit);
1231   initn = inits;
1232   ffeste_f2c_init_next_ (unitinit);
1233
1234   inits = build (CONSTRUCTOR, f2c_alist_struct, NULL_TREE, inits);
1235   TREE_CONSTANT (inits) = constantp ? 1 : 0;
1236   TREE_STATIC (inits) = 1;
1237
1238   t = build_decl (VAR_DECL,
1239                   ffecom_get_invented_identifier ("__g77_alist_%d",
1240                                                   mynumber++),
1241                   f2c_alist_struct);
1242   TREE_STATIC (t) = 1;
1243   t = ffecom_start_decl (t, 1);
1244   ffecom_finish_decl (t, inits, 0);
1245
1246   /* Prepare run-time expressions.  */
1247
1248   if (! unitexp)
1249     ffecom_prepare_expr (unit_expr);
1250
1251   ffecom_prepare_end ();
1252
1253   /* Now evaluate run-time expressions as needed.  */
1254
1255   if (! unitexp)
1256     {
1257       unitexp = ffecom_expr (unit_expr);
1258       ffeste_f2c_compile_ (unitfield, unitexp);
1259     }
1260
1261   ttype = build_pointer_type (TREE_TYPE (t));
1262   t = ffecom_1 (ADDR_EXPR, ttype, t);
1263
1264   t = build_tree_list (NULL_TREE, t);
1265
1266   return t;
1267 }
1268
1269 /* Make arglist with ptr to external-I/O control list.
1270
1271    Returns a tree suitable as an argument list containing a pointer to
1272    an external-I/O control list.  First, generates that control
1273    list, if necessary, along with any static and run-time initializations
1274    that are needed as specified by the arguments to this function.
1275
1276    Must ensure that all expressions are prepared before being evaluated,
1277    for any whose evaluation might result in the generation of temporaries.
1278
1279    Note that this means this function causes a transition, within the
1280    current block being code-generated via the back end, from the
1281    declaration of variables (temporaries) to the expanding of expressions,
1282    statements, etc.  */
1283
1284 static GTY(()) tree f2c_cilist_struct;
1285 static tree
1286 ffeste_io_cilist_ (bool have_err,
1287                    ffestvUnit unit,
1288                    ffebld unit_expr,
1289                    int unit_dflt,
1290                    bool have_end,
1291                    ffestvFormat format,
1292                    ffestpFile *format_spec,
1293                    bool rec,
1294                    ffebld rec_expr)
1295 {
1296   tree t;
1297   tree ttype;
1298   tree field;
1299   tree inits, initn;
1300   bool constantp = TRUE;
1301   static tree errfield, unitfield, endfield, formatfield, recfield;
1302   tree errinit, unitinit, endinit, formatinit, recinit;
1303   tree unitexp, formatexp, recexp;
1304   static int mynumber = 0;
1305
1306   if (f2c_cilist_struct == NULL_TREE)
1307     {
1308       tree ref;
1309
1310       ref = make_node (RECORD_TYPE);
1311
1312       errfield = ffecom_decl_field (ref, NULL_TREE, "err",
1313                                     ffecom_f2c_flag_type_node);
1314       unitfield = ffecom_decl_field (ref, errfield, "unit",
1315                                      ffecom_f2c_ftnint_type_node);
1316       endfield = ffecom_decl_field (ref, unitfield, "end",
1317                                     ffecom_f2c_flag_type_node);
1318       formatfield = ffecom_decl_field (ref, endfield, "format",
1319                                        string_type_node);
1320       recfield = ffecom_decl_field (ref, formatfield, "rec",
1321                                     ffecom_f2c_ftnint_type_node);
1322
1323       TYPE_FIELDS (ref) = errfield;
1324       layout_type (ref);
1325
1326       f2c_cilist_struct = ref;
1327     }
1328
1329   /* Try to do as much compile-time initialization of the structure
1330      as possible, to save run time.  */
1331
1332   ffeste_f2c_init_flag_ (have_err, errinit);
1333
1334   switch (unit)
1335     {
1336     case FFESTV_unitNONE:
1337     case FFESTV_unitASTERISK:
1338       unitinit = build_int_2 (unit_dflt, 0);
1339       unitexp = unitinit;
1340       break;
1341
1342     case FFESTV_unitINTEXPR:
1343       unitexp = ffecom_const_expr (unit_expr);
1344       if (unitexp)
1345         unitinit = unitexp;
1346       else
1347         {
1348           unitinit = ffecom_integer_zero_node;
1349           constantp = FALSE;
1350         }
1351       break;
1352
1353     default:
1354       assert ("bad unit spec" == NULL);
1355       unitinit = ffecom_integer_zero_node;
1356       unitexp = unitinit;
1357       break;
1358     }
1359
1360   switch (format)
1361     {
1362     case FFESTV_formatNONE:
1363       formatinit = null_pointer_node;
1364       formatexp = formatinit;
1365       break;
1366
1367     case FFESTV_formatLABEL:
1368       formatexp = error_mark_node;
1369       formatinit = ffecom_lookup_label (format_spec->u.label);
1370       if ((formatinit == NULL_TREE)
1371           || (TREE_CODE (formatinit) == ERROR_MARK))
1372         break;
1373       formatinit = ffecom_1 (ADDR_EXPR,
1374                              build_pointer_type (void_type_node),
1375                              formatinit);
1376       TREE_CONSTANT (formatinit) = 1;
1377       break;
1378
1379     case FFESTV_formatCHAREXPR:
1380       formatexp = ffecom_arg_ptr_to_const_expr (format_spec->u.expr, NULL);
1381       if (formatexp)
1382         formatinit = formatexp;
1383       else
1384         {
1385           formatinit = null_pointer_node;
1386           constantp = FALSE;
1387         }
1388       break;
1389
1390     case FFESTV_formatASTERISK:
1391       formatinit = null_pointer_node;
1392       formatexp = formatinit;
1393       break;
1394
1395     case FFESTV_formatINTEXPR:
1396       formatinit = null_pointer_node;
1397       formatexp = ffecom_expr_assign (format_spec->u.expr);
1398       if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (formatexp)))
1399           < GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
1400         error ("ASSIGNed FORMAT specifier is too small");
1401       formatexp = convert (string_type_node, formatexp);
1402       break;
1403
1404     case FFESTV_formatNAMELIST:
1405       formatinit = ffecom_expr (format_spec->u.expr);
1406       formatexp = formatinit;
1407       break;
1408
1409     default:
1410       assert ("bad format spec" == NULL);
1411       formatinit = integer_zero_node;
1412       formatexp = formatinit;
1413       break;
1414     }
1415
1416   ffeste_f2c_init_flag_ (have_end, endinit);
1417
1418   if (rec)
1419     recexp = ffecom_const_expr (rec_expr);
1420   else
1421     recexp = ffecom_integer_zero_node;
1422   if (recexp)
1423     recinit = recexp;
1424   else
1425     {
1426       recinit = ffecom_integer_zero_node;
1427       constantp = FALSE;
1428     }
1429
1430   inits = build_tree_list ((field = TYPE_FIELDS (f2c_cilist_struct)), errinit);
1431   initn = inits;
1432   ffeste_f2c_init_next_ (unitinit);
1433   ffeste_f2c_init_next_ (endinit);
1434   ffeste_f2c_init_next_ (formatinit);
1435   ffeste_f2c_init_next_ (recinit);
1436
1437   inits = build (CONSTRUCTOR, f2c_cilist_struct, NULL_TREE, inits);
1438   TREE_CONSTANT (inits) = constantp ? 1 : 0;
1439   TREE_STATIC (inits) = 1;
1440
1441   t = build_decl (VAR_DECL,
1442                   ffecom_get_invented_identifier ("__g77_cilist_%d",
1443                                                   mynumber++),
1444                   f2c_cilist_struct);
1445   TREE_STATIC (t) = 1;
1446   t = ffecom_start_decl (t, 1);
1447   ffecom_finish_decl (t, inits, 0);
1448
1449   /* Prepare run-time expressions.  */
1450
1451   if (! unitexp)
1452     ffecom_prepare_expr (unit_expr);
1453
1454   if (! formatexp)
1455     ffecom_prepare_arg_ptr_to_expr (format_spec->u.expr);
1456
1457   if (! recexp)
1458     ffecom_prepare_expr (rec_expr);
1459
1460   ffecom_prepare_end ();
1461
1462   /* Now evaluate run-time expressions as needed.  */
1463
1464   if (! unitexp)
1465     {
1466       unitexp = ffecom_expr (unit_expr);
1467       ffeste_f2c_compile_ (unitfield, unitexp);
1468     }
1469
1470   if (! formatexp)
1471     {
1472       formatexp = ffecom_arg_ptr_to_expr (format_spec->u.expr, NULL);
1473       ffeste_f2c_compile_ (formatfield, formatexp);
1474     }
1475   else if (format == FFESTV_formatINTEXPR)
1476     ffeste_f2c_compile_ (formatfield, formatexp);
1477
1478   if (! recexp)
1479     {
1480       recexp = ffecom_expr (rec_expr);
1481       ffeste_f2c_compile_ (recfield, recexp);
1482     }
1483
1484   ttype = build_pointer_type (TREE_TYPE (t));
1485   t = ffecom_1 (ADDR_EXPR, ttype, t);
1486
1487   t = build_tree_list (NULL_TREE, t);
1488
1489   return t;
1490 }
1491
1492 /* Make arglist with ptr to CLOSE control list.
1493
1494    Returns a tree suitable as an argument list containing a pointer to
1495    a CLOSE-statement control list.  First, generates that control
1496    list, if necessary, along with any static and run-time initializations
1497    that are needed as specified by the arguments to this function.
1498
1499    Must ensure that all expressions are prepared before being evaluated,
1500    for any whose evaluation might result in the generation of temporaries.
1501
1502    Note that this means this function causes a transition, within the
1503    current block being code-generated via the back end, from the
1504    declaration of variables (temporaries) to the expanding of expressions,
1505    statements, etc.  */
1506
1507 static GTY(()) tree f2c_close_struct;
1508 static tree
1509 ffeste_io_cllist_ (bool have_err,
1510                    ffebld unit_expr,
1511                    ffestpFile *stat_spec)
1512 {
1513   tree t;
1514   tree ttype;
1515   tree field;
1516   tree inits, initn;
1517   tree ignore;                  /* Ignore length info for certain fields. */
1518   bool constantp = TRUE;
1519   static tree errfield, unitfield, statfield;
1520   tree errinit, unitinit, statinit;
1521   tree unitexp, statexp;
1522   static int mynumber = 0;
1523
1524   if (f2c_close_struct == NULL_TREE)
1525     {
1526       tree ref;
1527
1528       ref = make_node (RECORD_TYPE);
1529
1530       errfield = ffecom_decl_field (ref, NULL_TREE, "err",
1531                                     ffecom_f2c_flag_type_node);
1532       unitfield = ffecom_decl_field (ref, errfield, "unit",
1533                                      ffecom_f2c_ftnint_type_node);
1534       statfield = ffecom_decl_field (ref, unitfield, "stat",
1535                                      string_type_node);
1536
1537       TYPE_FIELDS (ref) = errfield;
1538       layout_type (ref);
1539
1540       f2c_close_struct = ref;
1541     }
1542
1543   /* Try to do as much compile-time initialization of the structure
1544      as possible, to save run time.  */
1545
1546   ffeste_f2c_init_flag_ (have_err, errinit);
1547
1548   unitexp = ffecom_const_expr (unit_expr);
1549   if (unitexp)
1550     unitinit = unitexp;
1551   else
1552     {
1553       unitinit = ffecom_integer_zero_node;
1554       constantp = FALSE;
1555     }
1556
1557   ffeste_f2c_init_charnolen_ (statexp, statinit, stat_spec);
1558
1559   inits = build_tree_list ((field = TYPE_FIELDS (f2c_close_struct)), errinit);
1560   initn = inits;
1561   ffeste_f2c_init_next_ (unitinit);
1562   ffeste_f2c_init_next_ (statinit);
1563
1564   inits = build (CONSTRUCTOR, f2c_close_struct, NULL_TREE, inits);
1565   TREE_CONSTANT (inits) = constantp ? 1 : 0;
1566   TREE_STATIC (inits) = 1;
1567
1568   t = build_decl (VAR_DECL,
1569                   ffecom_get_invented_identifier ("__g77_cllist_%d",
1570                                                   mynumber++),
1571                   f2c_close_struct);
1572   TREE_STATIC (t) = 1;
1573   t = ffecom_start_decl (t, 1);
1574   ffecom_finish_decl (t, inits, 0);
1575
1576   /* Prepare run-time expressions.  */
1577
1578   if (! unitexp)
1579     ffecom_prepare_expr (unit_expr);
1580
1581   if (! statexp)
1582     ffecom_prepare_arg_ptr_to_expr (stat_spec->u.expr);
1583
1584   ffecom_prepare_end ();
1585
1586   /* Now evaluate run-time expressions as needed.  */
1587
1588   if (! unitexp)
1589     {
1590       unitexp = ffecom_expr (unit_expr);
1591       ffeste_f2c_compile_ (unitfield, unitexp);
1592     }
1593
1594   ffeste_f2c_compile_charnolen_ (statfield, stat_spec, statexp);
1595
1596   ttype = build_pointer_type (TREE_TYPE (t));
1597   t = ffecom_1 (ADDR_EXPR, ttype, t);
1598
1599   t = build_tree_list (NULL_TREE, t);
1600
1601   return t;
1602 }
1603
1604 /* Make arglist with ptr to internal-I/O control list.
1605
1606    Returns a tree suitable as an argument list containing a pointer to
1607    an internal-I/O control list.  First, generates that control
1608    list, if necessary, along with any static and run-time initializations
1609    that are needed as specified by the arguments to this function.
1610
1611    Must ensure that all expressions are prepared before being evaluated,
1612    for any whose evaluation might result in the generation of temporaries.
1613
1614    Note that this means this function causes a transition, within the
1615    current block being code-generated via the back end, from the
1616    declaration of variables (temporaries) to the expanding of expressions,
1617    statements, etc.  */
1618
1619 static GTY(()) tree f2c_icilist_struct;
1620 static tree
1621 ffeste_io_icilist_ (bool have_err,
1622                     ffebld unit_expr,
1623                     bool have_end,
1624                     ffestvFormat format,
1625                     ffestpFile *format_spec)
1626 {
1627   tree t;
1628   tree ttype;
1629   tree field;
1630   tree inits, initn;
1631   bool constantp = TRUE;
1632   static tree errfield, unitfield, endfield, formatfield, unitlenfield,
1633     unitnumfield;
1634   tree errinit, unitinit, endinit, formatinit, unitleninit, unitnuminit;
1635   tree unitexp, formatexp, unitlenexp, unitnumexp;
1636   static int mynumber = 0;
1637
1638   if (f2c_icilist_struct == NULL_TREE)
1639     {
1640       tree ref;
1641
1642       ref = make_node (RECORD_TYPE);
1643
1644       errfield = ffecom_decl_field (ref, NULL_TREE, "err",
1645                                     ffecom_f2c_flag_type_node);
1646       unitfield = ffecom_decl_field (ref, errfield, "unit",
1647                                      string_type_node);
1648       endfield = ffecom_decl_field (ref, unitfield, "end",
1649                                     ffecom_f2c_flag_type_node);
1650       formatfield = ffecom_decl_field (ref, endfield, "format",
1651                                        string_type_node);
1652       unitlenfield = ffecom_decl_field (ref, formatfield, "unitlen",
1653                                         ffecom_f2c_ftnint_type_node);
1654       unitnumfield = ffecom_decl_field (ref, unitlenfield, "unitnum",
1655                                         ffecom_f2c_ftnint_type_node);
1656
1657       TYPE_FIELDS (ref) = errfield;
1658       layout_type (ref);
1659
1660       f2c_icilist_struct = ref;
1661     }
1662
1663   /* Try to do as much compile-time initialization of the structure
1664      as possible, to save run time.  */
1665
1666   ffeste_f2c_init_flag_ (have_err, errinit);
1667
1668   unitexp = ffecom_arg_ptr_to_const_expr (unit_expr, &unitlenexp);
1669   if (unitexp)
1670     unitinit = unitexp;
1671   else
1672     {
1673       unitinit = null_pointer_node;
1674       constantp = FALSE;
1675     }
1676   if (unitlenexp)
1677     unitleninit = unitlenexp;
1678   else
1679     {
1680       unitleninit = ffecom_integer_zero_node;
1681       constantp = FALSE;
1682     }
1683
1684   /* Now see if we can fully initialize the number of elements, or
1685      if we have to compute that at run time.  */
1686   if (ffeinfo_rank (ffebld_info (unit_expr)) == 0
1687       || (unitexp
1688           && TREE_CODE (TREE_TYPE (TREE_TYPE (unitexp))) != ARRAY_TYPE))
1689     {
1690       /* Not an array, so just one element.  */
1691       unitnuminit = ffecom_integer_one_node;
1692       unitnumexp = unitnuminit;
1693     }
1694   else if (unitexp && unitlenexp)
1695     {
1696       /* An array, but all the info is constant, so compute now.  */
1697       unitnuminit
1698         = size_binop (CEIL_DIV_EXPR,
1699                       TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (unitexp))),
1700                       convert (sizetype, unitlenexp));
1701       unitnuminit = size_binop (CEIL_DIV_EXPR, unitnuminit,
1702                                 size_int (TYPE_PRECISION (char_type_node)
1703                                           / BITS_PER_UNIT));
1704       unitnumexp = unitnuminit;
1705     }
1706   else
1707     {
1708       /* Put off computing until run time.  */
1709       unitnuminit = ffecom_integer_zero_node;
1710       unitnumexp = NULL_TREE;
1711       constantp = FALSE;
1712     }
1713
1714   switch (format)
1715     {
1716     case FFESTV_formatNONE:
1717       formatinit = null_pointer_node;
1718       formatexp = formatinit;
1719       break;
1720
1721     case FFESTV_formatLABEL:
1722       formatexp = error_mark_node;
1723       formatinit = ffecom_lookup_label (format_spec->u.label);
1724       if ((formatinit == NULL_TREE)
1725           || (TREE_CODE (formatinit) == ERROR_MARK))
1726         break;
1727       formatinit = ffecom_1 (ADDR_EXPR,
1728                              build_pointer_type (void_type_node),
1729                              formatinit);
1730       TREE_CONSTANT (formatinit) = 1;
1731       break;
1732
1733     case FFESTV_formatCHAREXPR:
1734       ffeste_f2c_init_format_ (formatexp, formatinit, format_spec);
1735       break;
1736
1737     case FFESTV_formatASTERISK:
1738       formatinit = null_pointer_node;
1739       formatexp = formatinit;
1740       break;
1741
1742     case FFESTV_formatINTEXPR:
1743       formatinit = null_pointer_node;
1744       formatexp = ffecom_expr_assign (format_spec->u.expr);
1745       if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (formatexp)))
1746           < GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
1747         error ("ASSIGNed FORMAT specifier is too small");
1748       formatexp = convert (string_type_node, formatexp);
1749       break;
1750
1751     default:
1752       assert ("bad format spec" == NULL);
1753       formatinit = ffecom_integer_zero_node;
1754       formatexp = formatinit;
1755       break;
1756     }
1757
1758   ffeste_f2c_init_flag_ (have_end, endinit);
1759
1760   inits = build_tree_list ((field = TYPE_FIELDS (f2c_icilist_struct)),
1761                            errinit);
1762   initn = inits;
1763   ffeste_f2c_init_next_ (unitinit);
1764   ffeste_f2c_init_next_ (endinit);
1765   ffeste_f2c_init_next_ (formatinit);
1766   ffeste_f2c_init_next_ (unitleninit);
1767   ffeste_f2c_init_next_ (unitnuminit);
1768
1769   inits = build (CONSTRUCTOR, f2c_icilist_struct, NULL_TREE, inits);
1770   TREE_CONSTANT (inits) = constantp ? 1 : 0;
1771   TREE_STATIC (inits) = 1;
1772
1773   t = build_decl (VAR_DECL,
1774                   ffecom_get_invented_identifier ("__g77_icilist_%d",
1775                                                   mynumber++),
1776                   f2c_icilist_struct);
1777   TREE_STATIC (t) = 1;
1778   t = ffecom_start_decl (t, 1);
1779   ffecom_finish_decl (t, inits, 0);
1780
1781   /* Prepare run-time expressions.  */
1782
1783   if (! unitexp)
1784     ffecom_prepare_arg_ptr_to_expr (unit_expr);
1785
1786   ffeste_f2c_prepare_format_ (format_spec, formatexp);
1787
1788   ffecom_prepare_end ();
1789
1790   /* Now evaluate run-time expressions as needed.  */
1791
1792   if (! unitexp || ! unitlenexp)
1793     {
1794       int need_unitexp = (! unitexp);
1795       int need_unitlenexp = (! unitlenexp);
1796
1797       unitexp = ffecom_arg_ptr_to_expr (unit_expr, &unitlenexp);
1798       if (need_unitexp)
1799         ffeste_f2c_compile_ (unitfield, unitexp);
1800       if (need_unitlenexp)
1801         ffeste_f2c_compile_ (unitlenfield, unitlenexp);
1802     }
1803
1804   if (! unitnumexp
1805       && unitexp != error_mark_node
1806       && unitlenexp != error_mark_node)
1807     {
1808       unitnumexp
1809         = size_binop (CEIL_DIV_EXPR,
1810                       TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (unitexp))),
1811                       convert (sizetype, unitlenexp));
1812       unitnumexp = size_binop (CEIL_DIV_EXPR, unitnumexp,
1813                                size_int (TYPE_PRECISION (char_type_node)
1814                                          / BITS_PER_UNIT));
1815       ffeste_f2c_compile_ (unitnumfield, unitnumexp);
1816     }
1817
1818   if (format == FFESTV_formatINTEXPR)
1819     ffeste_f2c_compile_ (formatfield, formatexp);
1820   else
1821     ffeste_f2c_compile_format_ (formatfield, format_spec, formatexp);
1822
1823   ttype = build_pointer_type (TREE_TYPE (t));
1824   t = ffecom_1 (ADDR_EXPR, ttype, t);
1825
1826   t = build_tree_list (NULL_TREE, t);
1827
1828   return t;
1829 }
1830
1831 /* Make arglist with ptr to INQUIRE control list
1832
1833    Returns a tree suitable as an argument list containing a pointer to
1834    an INQUIRE-statement control list.  First, generates that control
1835    list, if necessary, along with any static and run-time initializations
1836    that are needed as specified by the arguments to this function.
1837
1838    Must ensure that all expressions are prepared before being evaluated,
1839    for any whose evaluation might result in the generation of temporaries.
1840
1841    Note that this means this function causes a transition, within the
1842    current block being code-generated via the back end, from the
1843    declaration of variables (temporaries) to the expanding of expressions,
1844    statements, etc.  */
1845
1846 static GTY(()) tree f2c_inquire_struct;
1847 static tree
1848 ffeste_io_inlist_ (bool have_err,
1849                    ffestpFile *unit_spec,
1850                    ffestpFile *file_spec,
1851                    ffestpFile *exist_spec,
1852                    ffestpFile *open_spec,
1853                    ffestpFile *number_spec,
1854                    ffestpFile *named_spec,
1855                    ffestpFile *name_spec,
1856                    ffestpFile *access_spec,
1857                    ffestpFile *sequential_spec,
1858                    ffestpFile *direct_spec,
1859                    ffestpFile *form_spec,
1860                    ffestpFile *formatted_spec,
1861                    ffestpFile *unformatted_spec,
1862                    ffestpFile *recl_spec,
1863                    ffestpFile *nextrec_spec,
1864                    ffestpFile *blank_spec)
1865 {
1866   tree t;
1867   tree ttype;
1868   tree field;
1869   tree inits, initn;
1870   bool constantp = TRUE;
1871   static tree errfield, unitfield, filefield, filelenfield, existfield,
1872     openfield, numberfield, namedfield, namefield, namelenfield, accessfield,
1873     accesslenfield, sequentialfield, sequentiallenfield, directfield, directlenfield,
1874     formfield, formlenfield, formattedfield, formattedlenfield, unformattedfield,
1875     unformattedlenfield, reclfield, nextrecfield, blankfield, blanklenfield;
1876   tree errinit, unitinit, fileinit, fileleninit, existinit, openinit, numberinit,
1877     namedinit, nameinit, nameleninit, accessinit, accessleninit, sequentialinit,
1878     sequentialleninit, directinit, directleninit, forminit, formleninit,
1879     formattedinit, formattedleninit, unformattedinit, unformattedleninit,
1880     reclinit, nextrecinit, blankinit, blankleninit;
1881   tree
1882     unitexp, fileexp, filelenexp, existexp, openexp, numberexp, namedexp,
1883     nameexp, namelenexp, accessexp, accesslenexp, sequentialexp, sequentiallenexp,
1884     directexp, directlenexp, formexp, formlenexp, formattedexp, formattedlenexp,
1885     unformattedexp, unformattedlenexp, reclexp, nextrecexp, blankexp, blanklenexp;
1886   static int mynumber = 0;
1887
1888   if (f2c_inquire_struct == NULL_TREE)
1889     {
1890       tree ref;
1891
1892       ref = make_node (RECORD_TYPE);
1893
1894       errfield = ffecom_decl_field (ref, NULL_TREE, "err",
1895                                     ffecom_f2c_flag_type_node);
1896       unitfield = ffecom_decl_field (ref, errfield, "unit",
1897                                      ffecom_f2c_ftnint_type_node);
1898       filefield = ffecom_decl_field (ref, unitfield, "file",
1899                                      string_type_node);
1900       filelenfield = ffecom_decl_field (ref, filefield, "filelen",
1901                                         ffecom_f2c_ftnlen_type_node);
1902       existfield = ffecom_decl_field (ref, filelenfield, "exist",
1903                                       ffecom_f2c_ptr_to_ftnint_type_node);
1904       openfield = ffecom_decl_field (ref, existfield, "open",
1905                                      ffecom_f2c_ptr_to_ftnint_type_node);
1906       numberfield = ffecom_decl_field (ref, openfield, "number",
1907                                        ffecom_f2c_ptr_to_ftnint_type_node);
1908       namedfield = ffecom_decl_field (ref, numberfield, "named",
1909                                       ffecom_f2c_ptr_to_ftnint_type_node);
1910       namefield = ffecom_decl_field (ref, namedfield, "name",
1911                                      string_type_node);
1912       namelenfield = ffecom_decl_field (ref, namefield, "namelen",
1913                                         ffecom_f2c_ftnlen_type_node);
1914       accessfield = ffecom_decl_field (ref, namelenfield, "access",
1915                                        string_type_node);
1916       accesslenfield = ffecom_decl_field (ref, accessfield, "accesslen",
1917                                           ffecom_f2c_ftnlen_type_node);
1918       sequentialfield = ffecom_decl_field (ref, accesslenfield, "sequential",
1919                                            string_type_node);
1920       sequentiallenfield = ffecom_decl_field (ref, sequentialfield,
1921                                               "sequentiallen",
1922                                               ffecom_f2c_ftnlen_type_node);
1923       directfield = ffecom_decl_field (ref, sequentiallenfield, "direct",
1924                                        string_type_node);
1925       directlenfield = ffecom_decl_field (ref, directfield, "directlen",
1926                                           ffecom_f2c_ftnlen_type_node);
1927       formfield = ffecom_decl_field (ref, directlenfield, "form",
1928                                      string_type_node);
1929       formlenfield = ffecom_decl_field (ref, formfield, "formlen",
1930                                         ffecom_f2c_ftnlen_type_node);
1931       formattedfield = ffecom_decl_field (ref, formlenfield, "formatted",
1932                                           string_type_node);
1933       formattedlenfield = ffecom_decl_field (ref, formattedfield,
1934                                              "formattedlen",
1935                                              ffecom_f2c_ftnlen_type_node);
1936       unformattedfield = ffecom_decl_field (ref, formattedlenfield,
1937                                             "unformatted",
1938                                             string_type_node);
1939       unformattedlenfield = ffecom_decl_field (ref, unformattedfield,
1940                                                "unformattedlen",
1941                                                ffecom_f2c_ftnlen_type_node);
1942       reclfield = ffecom_decl_field (ref, unformattedlenfield, "recl",
1943                                      ffecom_f2c_ptr_to_ftnint_type_node);
1944       nextrecfield = ffecom_decl_field (ref, reclfield, "nextrec",
1945                                         ffecom_f2c_ptr_to_ftnint_type_node);
1946       blankfield = ffecom_decl_field (ref, nextrecfield, "blank",
1947                                       string_type_node);
1948       blanklenfield = ffecom_decl_field (ref, blankfield, "blanklen",
1949                                          ffecom_f2c_ftnlen_type_node);
1950
1951       TYPE_FIELDS (ref) = errfield;
1952       layout_type (ref);
1953
1954       f2c_inquire_struct = ref;
1955     }
1956
1957   /* Try to do as much compile-time initialization of the structure
1958      as possible, to save run time.  */
1959
1960   ffeste_f2c_init_flag_ (have_err, errinit);
1961   ffeste_f2c_init_int_ (unitexp, unitinit, unit_spec);
1962   ffeste_f2c_init_char_ (fileexp, fileinit, filelenexp, fileleninit,
1963                          file_spec);
1964   ffeste_f2c_init_ptrtoint_ (existexp, existinit, exist_spec);
1965   ffeste_f2c_init_ptrtoint_ (openexp, openinit, open_spec);
1966   ffeste_f2c_init_ptrtoint_ (numberexp, numberinit, number_spec);
1967   ffeste_f2c_init_ptrtoint_ (namedexp, namedinit, named_spec);
1968   ffeste_f2c_init_char_ (nameexp, nameinit, namelenexp, nameleninit,
1969                          name_spec);
1970   ffeste_f2c_init_char_ (accessexp, accessinit, accesslenexp,
1971                          accessleninit, access_spec);
1972   ffeste_f2c_init_char_ (sequentialexp, sequentialinit, sequentiallenexp,
1973                          sequentialleninit, sequential_spec);
1974   ffeste_f2c_init_char_ (directexp, directinit, directlenexp,
1975                          directleninit, direct_spec);
1976   ffeste_f2c_init_char_ (formexp, forminit, formlenexp, formleninit,
1977                          form_spec);
1978   ffeste_f2c_init_char_ (formattedexp, formattedinit,
1979                          formattedlenexp, formattedleninit, formatted_spec);
1980   ffeste_f2c_init_char_ (unformattedexp, unformattedinit, unformattedlenexp,
1981                          unformattedleninit, unformatted_spec);
1982   ffeste_f2c_init_ptrtoint_ (reclexp, reclinit, recl_spec);
1983   ffeste_f2c_init_ptrtoint_ (nextrecexp, nextrecinit, nextrec_spec);
1984   ffeste_f2c_init_char_ (blankexp, blankinit, blanklenexp,
1985                          blankleninit, blank_spec);
1986
1987   inits = build_tree_list ((field = TYPE_FIELDS (f2c_inquire_struct)),
1988                            errinit);
1989   initn = inits;
1990   ffeste_f2c_init_next_ (unitinit);
1991   ffeste_f2c_init_next_ (fileinit);
1992   ffeste_f2c_init_next_ (fileleninit);
1993   ffeste_f2c_init_next_ (existinit);
1994   ffeste_f2c_init_next_ (openinit);
1995   ffeste_f2c_init_next_ (numberinit);
1996   ffeste_f2c_init_next_ (namedinit);
1997   ffeste_f2c_init_next_ (nameinit);
1998   ffeste_f2c_init_next_ (nameleninit);
1999   ffeste_f2c_init_next_ (accessinit);
2000   ffeste_f2c_init_next_ (accessleninit);
2001   ffeste_f2c_init_next_ (sequentialinit);
2002   ffeste_f2c_init_next_ (sequentialleninit);
2003   ffeste_f2c_init_next_ (directinit);
2004   ffeste_f2c_init_next_ (directleninit);
2005   ffeste_f2c_init_next_ (forminit);
2006   ffeste_f2c_init_next_ (formleninit);
2007   ffeste_f2c_init_next_ (formattedinit);
2008   ffeste_f2c_init_next_ (formattedleninit);
2009   ffeste_f2c_init_next_ (unformattedinit);
2010   ffeste_f2c_init_next_ (unformattedleninit);
2011   ffeste_f2c_init_next_ (reclinit);
2012   ffeste_f2c_init_next_ (nextrecinit);
2013   ffeste_f2c_init_next_ (blankinit);
2014   ffeste_f2c_init_next_ (blankleninit);
2015
2016   inits = build (CONSTRUCTOR, f2c_inquire_struct, NULL_TREE, inits);
2017   TREE_CONSTANT (inits) = constantp ? 1 : 0;
2018   TREE_STATIC (inits) = 1;
2019
2020   t = build_decl (VAR_DECL,
2021                   ffecom_get_invented_identifier ("__g77_inlist_%d",
2022                                                   mynumber++),
2023                   f2c_inquire_struct);
2024   TREE_STATIC (t) = 1;
2025   t = ffecom_start_decl (t, 1);
2026   ffecom_finish_decl (t, inits, 0);
2027
2028   /* Prepare run-time expressions.  */
2029
2030   ffeste_f2c_prepare_int_ (unit_spec, unitexp);
2031   ffeste_f2c_prepare_char_ (file_spec, fileexp);
2032   ffeste_f2c_prepare_ptrtoint_ (exist_spec, existexp);
2033   ffeste_f2c_prepare_ptrtoint_ (open_spec, openexp);
2034   ffeste_f2c_prepare_ptrtoint_ (number_spec, numberexp);
2035   ffeste_f2c_prepare_ptrtoint_ (named_spec, namedexp);
2036   ffeste_f2c_prepare_char_ (name_spec, nameexp);
2037   ffeste_f2c_prepare_char_ (access_spec, accessexp);
2038   ffeste_f2c_prepare_char_ (sequential_spec, sequentialexp);
2039   ffeste_f2c_prepare_char_ (direct_spec, directexp);
2040   ffeste_f2c_prepare_char_ (form_spec, formexp);
2041   ffeste_f2c_prepare_char_ (formatted_spec, formattedexp);
2042   ffeste_f2c_prepare_char_ (unformatted_spec, unformattedexp);
2043   ffeste_f2c_prepare_ptrtoint_ (recl_spec, reclexp);
2044   ffeste_f2c_prepare_ptrtoint_ (nextrec_spec, nextrecexp);
2045   ffeste_f2c_prepare_char_ (blank_spec, blankexp);
2046
2047   ffecom_prepare_end ();
2048
2049   /* Now evaluate run-time expressions as needed.  */
2050
2051   ffeste_f2c_compile_int_ (unitfield, unit_spec, unitexp);
2052   ffeste_f2c_compile_char_ (filefield, filelenfield, file_spec,
2053                             fileexp, filelenexp);
2054   ffeste_f2c_compile_ptrtoint_ (existfield, exist_spec, existexp);
2055   ffeste_f2c_compile_ptrtoint_ (openfield, open_spec, openexp);
2056   ffeste_f2c_compile_ptrtoint_ (numberfield, number_spec, numberexp);
2057   ffeste_f2c_compile_ptrtoint_ (namedfield, named_spec, namedexp);
2058   ffeste_f2c_compile_char_ (namefield, namelenfield, name_spec, nameexp,
2059                             namelenexp);
2060   ffeste_f2c_compile_char_ (accessfield, accesslenfield, access_spec,
2061                             accessexp, accesslenexp);
2062   ffeste_f2c_compile_char_ (sequentialfield, sequentiallenfield,
2063                             sequential_spec, sequentialexp,
2064                             sequentiallenexp);
2065   ffeste_f2c_compile_char_ (directfield, directlenfield, direct_spec,
2066                             directexp, directlenexp);
2067   ffeste_f2c_compile_char_ (formfield, formlenfield, form_spec, formexp,
2068                             formlenexp);
2069   ffeste_f2c_compile_char_ (formattedfield, formattedlenfield, formatted_spec,
2070                             formattedexp, formattedlenexp);
2071   ffeste_f2c_compile_char_ (unformattedfield, unformattedlenfield,
2072                             unformatted_spec, unformattedexp,
2073                             unformattedlenexp);
2074   ffeste_f2c_compile_ptrtoint_ (reclfield, recl_spec, reclexp);
2075   ffeste_f2c_compile_ptrtoint_ (nextrecfield, nextrec_spec, nextrecexp);
2076   ffeste_f2c_compile_char_ (blankfield, blanklenfield, blank_spec, blankexp,
2077                             blanklenexp);
2078
2079   ttype = build_pointer_type (TREE_TYPE (t));
2080   t = ffecom_1 (ADDR_EXPR, ttype, t);
2081
2082   t = build_tree_list (NULL_TREE, t);
2083
2084   return t;
2085 }
2086
2087 /* Make arglist with ptr to OPEN control list
2088
2089    Returns a tree suitable as an argument list containing a pointer to
2090    an OPEN-statement control list.  First, generates that control
2091    list, if necessary, along with any static and run-time initializations
2092    that are needed as specified by the arguments to this function.
2093
2094    Must ensure that all expressions are prepared before being evaluated,
2095    for any whose evaluation might result in the generation of temporaries.
2096
2097    Note that this means this function causes a transition, within the
2098    current block being code-generated via the back end, from the
2099    declaration of variables (temporaries) to the expanding of expressions,
2100    statements, etc.  */
2101
2102 static GTY(()) tree f2c_open_struct;
2103 static tree
2104 ffeste_io_olist_ (bool have_err,
2105                   ffebld unit_expr,
2106                   ffestpFile *file_spec,
2107                   ffestpFile *stat_spec,
2108                   ffestpFile *access_spec,
2109                   ffestpFile *form_spec,
2110                   ffestpFile *recl_spec,
2111                   ffestpFile *blank_spec)
2112 {
2113   tree t;
2114   tree ttype;
2115   tree field;
2116   tree inits, initn;
2117   tree ignore;                  /* Ignore length info for certain fields. */
2118   bool constantp = TRUE;
2119   static tree errfield, unitfield, filefield, filelenfield, statfield,
2120     accessfield, formfield, reclfield, blankfield;
2121   tree errinit, unitinit, fileinit, fileleninit, statinit, accessinit,
2122     forminit, reclinit, blankinit;
2123   tree
2124     unitexp, fileexp, filelenexp, statexp, accessexp, formexp, reclexp,
2125     blankexp;
2126   static int mynumber = 0;
2127
2128   if (f2c_open_struct == NULL_TREE)
2129     {
2130       tree ref;
2131
2132       ref = make_node (RECORD_TYPE);
2133
2134       errfield = ffecom_decl_field (ref, NULL_TREE, "err",
2135                                     ffecom_f2c_flag_type_node);
2136       unitfield = ffecom_decl_field (ref, errfield, "unit",
2137                                      ffecom_f2c_ftnint_type_node);
2138       filefield = ffecom_decl_field (ref, unitfield, "file",
2139                                      string_type_node);
2140       filelenfield = ffecom_decl_field (ref, filefield, "filelen",
2141                                         ffecom_f2c_ftnlen_type_node);
2142       statfield = ffecom_decl_field (ref, filelenfield, "stat",
2143                                      string_type_node);
2144       accessfield = ffecom_decl_field (ref, statfield, "access",
2145                                        string_type_node);
2146       formfield = ffecom_decl_field (ref, accessfield, "form",
2147                                      string_type_node);
2148       reclfield = ffecom_decl_field (ref, formfield, "recl",
2149                                      ffecom_f2c_ftnint_type_node);
2150       blankfield = ffecom_decl_field (ref, reclfield, "blank",
2151                                       string_type_node);
2152
2153       TYPE_FIELDS (ref) = errfield;
2154       layout_type (ref);
2155
2156       f2c_open_struct = ref;
2157     }
2158
2159   /* Try to do as much compile-time initialization of the structure
2160      as possible, to save run time.  */
2161
2162   ffeste_f2c_init_flag_ (have_err, errinit);
2163
2164   unitexp = ffecom_const_expr (unit_expr);
2165   if (unitexp)
2166     unitinit = unitexp;
2167   else
2168     {
2169       unitinit = ffecom_integer_zero_node;
2170       constantp = FALSE;
2171     }
2172
2173   ffeste_f2c_init_char_ (fileexp, fileinit, filelenexp, fileleninit,
2174                          file_spec);
2175   ffeste_f2c_init_charnolen_ (statexp, statinit, stat_spec);
2176   ffeste_f2c_init_charnolen_ (accessexp, accessinit, access_spec);
2177   ffeste_f2c_init_charnolen_ (formexp, forminit, form_spec);
2178   ffeste_f2c_init_int_ (reclexp, reclinit, recl_spec);
2179   ffeste_f2c_init_charnolen_ (blankexp, blankinit, blank_spec);
2180
2181   inits = build_tree_list ((field = TYPE_FIELDS (f2c_open_struct)), errinit);
2182   initn = inits;
2183   ffeste_f2c_init_next_ (unitinit);
2184   ffeste_f2c_init_next_ (fileinit);
2185   ffeste_f2c_init_next_ (fileleninit);
2186   ffeste_f2c_init_next_ (statinit);
2187   ffeste_f2c_init_next_ (accessinit);
2188   ffeste_f2c_init_next_ (forminit);
2189   ffeste_f2c_init_next_ (reclinit);
2190   ffeste_f2c_init_next_ (blankinit);
2191
2192   inits = build (CONSTRUCTOR, f2c_open_struct, NULL_TREE, inits);
2193   TREE_CONSTANT (inits) = constantp ? 1 : 0;
2194   TREE_STATIC (inits) = 1;
2195
2196   t = build_decl (VAR_DECL,
2197                   ffecom_get_invented_identifier ("__g77_olist_%d",
2198                                                   mynumber++),
2199                   f2c_open_struct);
2200   TREE_STATIC (t) = 1;
2201   t = ffecom_start_decl (t, 1);
2202   ffecom_finish_decl (t, inits, 0);
2203
2204   /* Prepare run-time expressions.  */
2205
2206   if (! unitexp)
2207     ffecom_prepare_expr (unit_expr);
2208
2209   ffeste_f2c_prepare_char_ (file_spec, fileexp);
2210   ffeste_f2c_prepare_charnolen_ (stat_spec, statexp);
2211   ffeste_f2c_prepare_charnolen_ (access_spec, accessexp);
2212   ffeste_f2c_prepare_charnolen_ (form_spec, formexp);
2213   ffeste_f2c_prepare_int_ (recl_spec, reclexp);
2214   ffeste_f2c_prepare_charnolen_ (blank_spec, blankexp);
2215
2216   ffecom_prepare_end ();
2217
2218   /* Now evaluate run-time expressions as needed.  */
2219
2220   if (! unitexp)
2221     {
2222       unitexp = ffecom_expr (unit_expr);
2223       ffeste_f2c_compile_ (unitfield, unitexp);
2224     }
2225
2226   ffeste_f2c_compile_char_ (filefield, filelenfield, file_spec, fileexp,
2227                             filelenexp);
2228   ffeste_f2c_compile_charnolen_ (statfield, stat_spec, statexp);
2229   ffeste_f2c_compile_charnolen_ (accessfield, access_spec, accessexp);
2230   ffeste_f2c_compile_charnolen_ (formfield, form_spec, formexp);
2231   ffeste_f2c_compile_int_ (reclfield, recl_spec, reclexp);
2232   ffeste_f2c_compile_charnolen_ (blankfield, blank_spec, blankexp);
2233
2234   ttype = build_pointer_type (TREE_TYPE (t));
2235   t = ffecom_1 (ADDR_EXPR, ttype, t);
2236
2237   t = build_tree_list (NULL_TREE, t);
2238
2239   return t;
2240 }
2241
2242 /* Generate code for BACKSPACE/ENDFILE/REWIND.  */
2243
2244 static void
2245 ffeste_subr_beru_ (ffestpBeruStmt *info, ffecomGfrt rt)
2246 {
2247   tree alist;
2248   bool iostat;
2249   bool errl;
2250
2251   ffeste_emit_line_note_ ();
2252
2253 #define specified(something) (info->beru_spec[something].kw_or_val_present)
2254
2255   iostat = specified (FFESTP_beruixIOSTAT);
2256   errl = specified (FFESTP_beruixERR);
2257
2258 #undef specified
2259
2260   /* ~~For now, we assume the unit number is specified and is not ASTERISK,
2261      because the FFE doesn't support BACKSPACE(*) and rejects a BACKSPACE
2262      without any unit specifier.  f2c, however, supports the former
2263      construct.  When it is time to add this feature to the FFE, which
2264      probably is fairly easy, ffestc_R919 and company will want to pass an
2265      ffestvUnit indicator of FFESTV_unitINTEXPR or _unitASTERISK to
2266      ffeste_R919 and company, and they will want to pass that same value to
2267      this function, and that argument will replace the constant _unitINTEXPR_
2268      in the call below.  Right now, the default unit number, 6, is ignored.  */
2269
2270   ffeste_start_stmt_ ();
2271
2272   if (errl)
2273     {
2274       /* Have ERR= specification.   */
2275
2276       ffeste_io_err_
2277         = ffeste_io_abort_
2278         = ffecom_lookup_label
2279         (info->beru_spec[FFESTP_beruixERR].u.label);
2280       ffeste_io_abort_is_temp_ = FALSE;
2281     }
2282   else
2283     {
2284       /* No ERR= specification.  */
2285
2286       ffeste_io_err_ = NULL_TREE;
2287
2288       if ((ffeste_io_abort_is_temp_ = iostat))
2289         ffeste_io_abort_ = ffecom_temp_label ();
2290       else
2291         ffeste_io_abort_ = NULL_TREE;
2292     }
2293
2294   if (iostat)
2295     {
2296       /* Have IOSTAT= specification.  */
2297
2298       ffeste_io_iostat_is_temp_ = FALSE;
2299       ffeste_io_iostat_ = ffecom_expr
2300         (info->beru_spec[FFESTP_beruixIOSTAT].u.expr);
2301     }
2302   else if (ffeste_io_abort_ != NULL_TREE)
2303     {
2304       /* Have no IOSTAT= but have ERR=.  */
2305
2306       ffeste_io_iostat_is_temp_ = TRUE;
2307       ffeste_io_iostat_
2308         = ffecom_make_tempvar ("beru", ffecom_integer_type_node,
2309                                FFETARGET_charactersizeNONE, -1);
2310     }
2311   else
2312     {
2313       /* No IOSTAT= or ERR= specification.  */
2314
2315       ffeste_io_iostat_is_temp_ = FALSE;
2316       ffeste_io_iostat_ = NULL_TREE;
2317     }
2318
2319   /* Now prescan, then convert, all the arguments.  */
2320
2321   alist = ffeste_io_ialist_ (errl || iostat, FFESTV_unitINTEXPR,
2322                              info->beru_spec[FFESTP_beruixUNIT].u.expr, 6);
2323
2324   /* Don't generate "if (iostat != 0) goto label;" if label is temp abort
2325      label, since we're gonna fall through to there anyway. */
2326
2327   ffeste_io_call_ (ffecom_call_gfrt (rt, alist, NULL_TREE),
2328                    ! ffeste_io_abort_is_temp_);
2329
2330   /* If we've got a temp label, generate its code here. */
2331
2332   if (ffeste_io_abort_is_temp_)
2333     {
2334       DECL_INITIAL (ffeste_io_abort_) = error_mark_node;
2335       emit_nop ();
2336       expand_label (ffeste_io_abort_);
2337
2338       assert (ffeste_io_err_ == NULL_TREE);
2339     }
2340
2341   ffeste_end_stmt_ ();
2342 }
2343
2344 /* END DO statement
2345
2346    Also invoked by _labeldef_branch_finish_ (or, in cases
2347    of errors, other _labeldef_ functions) when the label definition is
2348    for a DO-target (LOOPEND) label, once per matching/outstanding DO
2349    block on the stack.  */
2350
2351 void
2352 ffeste_do (ffestw block)
2353 {
2354   ffeste_emit_line_note_ ();
2355
2356   if (ffestw_do_tvar (block) == 0)
2357     {
2358       expand_end_loop ();               /* DO WHILE and just DO. */
2359
2360       ffeste_end_block_ (block);
2361     }
2362   else
2363     ffeste_end_iterdo_ (block,
2364                         ffestw_do_tvar (block),
2365                         ffestw_do_incr_saved (block),
2366                         ffestw_do_count_var (block));
2367 }
2368
2369 /* End of statement following logical IF.
2370
2371    Applies to *only* logical IF, not to IF-THEN.  */
2372
2373 void
2374 ffeste_end_R807 ()
2375 {
2376   ffeste_emit_line_note_ ();
2377
2378   expand_end_cond ();
2379
2380   ffeste_end_block_ (NULL);
2381 }
2382
2383 /* Generate "code" for branch label definition.  */
2384
2385 void
2386 ffeste_labeldef_branch (ffelab label)
2387 {
2388   tree glabel;
2389
2390   glabel = ffecom_lookup_label (label);
2391   assert (glabel != NULL_TREE);
2392   if (TREE_CODE (glabel) == ERROR_MARK)
2393     return;
2394
2395   assert (DECL_INITIAL (glabel) == NULL_TREE);
2396
2397   DECL_INITIAL (glabel) = error_mark_node;
2398   DECL_SOURCE_FILE (glabel) = ffelab_definition_filename (label);
2399   DECL_SOURCE_LINE (glabel) = ffelab_definition_filelinenum (label);
2400
2401   emit_nop ();
2402
2403   expand_label (glabel);
2404 }
2405
2406 /* Generate "code" for FORMAT label definition.  */
2407
2408 void
2409 ffeste_labeldef_format (ffelab label)
2410 {
2411   ffeste_label_formatdef_ = label;
2412 }
2413
2414 /* Assignment statement (outside of WHERE).  */
2415
2416 void
2417 ffeste_R737A (ffebld dest, ffebld source)
2418 {
2419   ffeste_check_simple_ ();
2420
2421   ffeste_emit_line_note_ ();
2422
2423   ffeste_start_stmt_ ();
2424
2425   ffecom_expand_let_stmt (dest, source);
2426
2427   ffeste_end_stmt_ ();
2428 }
2429
2430 /* Block IF (IF-THEN) statement.  */
2431
2432 void
2433 ffeste_R803 (ffestw block, ffebld expr)
2434 {
2435   tree temp;
2436
2437   ffeste_check_simple_ ();
2438
2439   ffeste_emit_line_note_ ();
2440
2441   ffeste_start_block_ (block);
2442
2443   temp = ffecom_make_tempvar ("ifthen", integer_type_node,
2444                               FFETARGET_charactersizeNONE, -1);
2445
2446   ffeste_start_stmt_ ();
2447
2448   ffecom_prepare_expr (expr);
2449
2450   if (ffecom_prepare_end ())
2451     {
2452       tree result;
2453
2454       result = ffecom_modify (void_type_node,
2455                               temp,
2456                               ffecom_truth_value (ffecom_expr (expr)));
2457
2458       expand_expr_stmt (result);
2459
2460       ffeste_end_stmt_ ();
2461     }
2462   else
2463     {
2464       ffeste_end_stmt_ ();
2465
2466       temp = ffecom_truth_value (ffecom_expr (expr));
2467     }
2468
2469   expand_start_cond (temp, 0);
2470
2471   /* No fake `else' constructs introduced (yet).  */
2472   ffestw_set_ifthen_fake_else (block, 0);
2473 }
2474
2475 /* ELSE IF statement.  */
2476
2477 void
2478 ffeste_R804 (ffestw block, ffebld expr)
2479 {
2480   tree temp;
2481
2482   ffeste_check_simple_ ();
2483
2484   ffeste_emit_line_note_ ();
2485
2486   /* Since ELSEIF(expr) might require preparations for expr,
2487      implement as ELSE; prepare-expr; IF (expr) THEN ...; ENDIF.  */
2488
2489   expand_start_else ();
2490
2491   ffeste_start_block_ (block);
2492
2493   temp = ffecom_make_tempvar ("elseif", integer_type_node,
2494                               FFETARGET_charactersizeNONE, -1);
2495
2496   ffeste_start_stmt_ ();
2497
2498   ffecom_prepare_expr (expr);
2499
2500   if (ffecom_prepare_end ())
2501     {
2502       tree result;
2503
2504       result = ffecom_modify (void_type_node,
2505                               temp,
2506                               ffecom_truth_value (ffecom_expr (expr)));
2507
2508       expand_expr_stmt (result);
2509
2510       ffeste_end_stmt_ ();
2511     }
2512   else
2513     {
2514       /* In this case, we could probably have used expand_start_elseif
2515          instead, saving the need for a fake `else' construct.  But,
2516          until it's clear that'd improve performance, it's easier this
2517          way, since we have to expand_start_else before we get to this
2518          test, given the current design.  */
2519
2520       ffeste_end_stmt_ ();
2521
2522       temp = ffecom_truth_value (ffecom_expr (expr));
2523     }
2524
2525   expand_start_cond (temp, 0);
2526
2527   /* Increment number of fake `else' constructs introduced.  */
2528   ffestw_set_ifthen_fake_else (block,
2529                                ffestw_ifthen_fake_else (block) + 1);
2530 }
2531
2532 /* ELSE statement.  */
2533
2534 void
2535 ffeste_R805 (ffestw block UNUSED)
2536 {
2537   ffeste_check_simple_ ();
2538
2539   ffeste_emit_line_note_ ();
2540
2541   expand_start_else ();
2542 }
2543
2544 /* END IF statement.  */
2545
2546 void
2547 ffeste_R806 (ffestw block)
2548 {
2549   int i = ffestw_ifthen_fake_else (block) + 1;
2550
2551   ffeste_emit_line_note_ ();
2552
2553   for (; i; --i)
2554     {
2555       expand_end_cond ();
2556
2557       ffeste_end_block_ (block);
2558     }
2559 }
2560
2561 /* Logical IF statement.  */
2562
2563 void
2564 ffeste_R807 (ffebld expr)
2565 {
2566   tree temp;
2567
2568   ffeste_check_simple_ ();
2569
2570   ffeste_emit_line_note_ ();
2571
2572   ffeste_start_block_ (NULL);
2573
2574   temp = ffecom_make_tempvar ("if", integer_type_node,
2575                               FFETARGET_charactersizeNONE, -1);
2576
2577   ffeste_start_stmt_ ();
2578
2579   ffecom_prepare_expr (expr);
2580
2581   if (ffecom_prepare_end ())
2582     {
2583       tree result;
2584
2585       result = ffecom_modify (void_type_node,
2586                               temp,
2587                               ffecom_truth_value (ffecom_expr (expr)));
2588
2589       expand_expr_stmt (result);
2590
2591       ffeste_end_stmt_ ();
2592     }
2593   else
2594     {
2595       ffeste_end_stmt_ ();
2596
2597       temp = ffecom_truth_value (ffecom_expr (expr));
2598     }
2599
2600   expand_start_cond (temp, 0);
2601 }
2602
2603 /* SELECT CASE statement.  */
2604
2605 void
2606 ffeste_R809 (ffestw block, ffebld expr)
2607 {
2608   ffeste_check_simple_ ();
2609
2610   ffeste_emit_line_note_ ();
2611
2612   ffeste_start_block_ (block);
2613
2614   if ((expr == NULL)
2615       || (ffeinfo_basictype (ffebld_info (expr))
2616           == FFEINFO_basictypeANY))
2617     ffestw_set_select_texpr (block, error_mark_node);
2618   else if (ffeinfo_basictype (ffebld_info (expr))
2619            == FFEINFO_basictypeCHARACTER)
2620     {
2621       /* ~~~Someday handle CHARACTER*1, CHARACTER*N */
2622
2623       /* xgettext:no-c-format */
2624       ffebad_start_msg ("SELECT CASE on CHARACTER type (at %0) not supported -- sorry",
2625                         FFEBAD_severityFATAL);
2626       ffebad_here (0, ffestw_line (block), ffestw_col (block));
2627       ffebad_finish ();
2628       ffestw_set_select_texpr (block, error_mark_node);
2629     }
2630   else
2631     {
2632       tree result;
2633       tree texpr;
2634
2635       result = ffecom_make_tempvar ("select", ffecom_type_expr (expr),
2636                                     ffeinfo_size (ffebld_info (expr)),
2637                                     -1);
2638
2639       ffeste_start_stmt_ ();
2640
2641       ffecom_prepare_expr (expr);
2642
2643       ffecom_prepare_end ();
2644
2645       texpr = ffecom_expr (expr);
2646
2647       assert (TYPE_MAIN_VARIANT (TREE_TYPE (texpr))
2648               == TYPE_MAIN_VARIANT (TREE_TYPE (result)));
2649
2650       texpr = ffecom_modify (void_type_node,
2651                              result,
2652                              texpr);
2653       expand_expr_stmt (texpr);
2654
2655       ffeste_end_stmt_ ();
2656
2657       expand_start_case (1, result, TREE_TYPE (result),
2658                          "SELECT CASE statement");
2659       ffestw_set_select_texpr (block, texpr);
2660       ffestw_set_select_break (block, FALSE);
2661     }
2662 }
2663
2664 /* CASE statement.
2665
2666    If casenum is 0, it's CASE DEFAULT.  Else it's the case ranges at
2667    the start of the first_stmt list in the select object at the top of
2668    the stack that match casenum.  */
2669
2670 void
2671 ffeste_R810 (ffestw block, unsigned long casenum)
2672 {
2673   ffestwSelect s = ffestw_select (block);
2674   ffestwCase c;
2675   tree texprlow;
2676   tree texprhigh;
2677   tree tlabel;
2678   int pushok;
2679   tree duplicate;
2680
2681   ffeste_check_simple_ ();
2682
2683   if (s->first_stmt == (ffestwCase) &s->first_rel)
2684     c = NULL;
2685   else
2686     c = s->first_stmt;
2687
2688   ffeste_emit_line_note_ ();
2689
2690   if (ffestw_select_texpr (block) == error_mark_node)
2691     return;
2692
2693   /* ~~~Someday handle CHARACTER*1, CHARACTER*N */
2694
2695   tlabel = build_decl (LABEL_DECL, NULL_TREE, NULL_TREE);
2696
2697   if (ffestw_select_break (block))
2698     expand_exit_something ();
2699   else
2700     ffestw_set_select_break (block, TRUE);
2701
2702   if ((c == NULL) || (casenum != c->casenum))
2703     {
2704       if (casenum == 0) /* Intentional CASE DEFAULT. */
2705         {
2706           pushok = pushcase (NULL_TREE, 0, tlabel, &duplicate);
2707           assert (pushok == 0);
2708         }
2709     }
2710   else
2711     do
2712       {
2713         texprlow = (c->low == NULL) ? NULL_TREE
2714           : ffecom_constantunion (&ffebld_constant_union (c->low), s->type,
2715                                   s->kindtype,
2716                                   ffecom_tree_type[s->type][s->kindtype]);
2717         if (c->low != c->high)
2718           {
2719             texprhigh = (c->high == NULL) ? NULL_TREE
2720               : ffecom_constantunion (&ffebld_constant_union (c->high),
2721                                       s->type, s->kindtype,
2722                                       ffecom_tree_type[s->type][s->kindtype]);
2723             pushok = pushcase_range (texprlow, texprhigh, convert,
2724                                      tlabel, &duplicate);
2725           }
2726         else
2727           pushok = pushcase (texprlow, convert, tlabel, &duplicate);
2728         assert (pushok == 0);
2729         c = c->next_stmt;
2730         /* Unlink prev.  */
2731         c->previous_stmt->previous_stmt->next_stmt = c;
2732         c->previous_stmt = c->previous_stmt->previous_stmt;
2733       }
2734     while ((c != (ffestwCase) &s->first_rel) && (casenum == c->casenum));
2735 }
2736
2737 /* END SELECT statement.  */
2738
2739 void
2740 ffeste_R811 (ffestw block)
2741 {
2742   ffeste_emit_line_note_ ();
2743
2744   /* ~~~Someday handle CHARACTER*1, CHARACTER*N */
2745
2746   if (TREE_CODE (ffestw_select_texpr (block)) != ERROR_MARK)
2747     expand_end_case (ffestw_select_texpr (block));
2748
2749   ffeste_end_block_ (block);
2750 }
2751
2752 /* Iterative DO statement.  */
2753
2754 void
2755 ffeste_R819A (ffestw block, ffelab label UNUSED, ffebld var,
2756               ffebld start, ffelexToken start_token,
2757               ffebld end, ffelexToken end_token,
2758               ffebld incr, ffelexToken incr_token)
2759 {
2760   ffeste_check_simple_ ();
2761
2762   ffeste_emit_line_note_ ();
2763
2764   ffeste_begin_iterdo_ (block, NULL, NULL, NULL,
2765                         var,
2766                         start, start_token,
2767                         end, end_token,
2768                         incr, incr_token,
2769                         "Iterative DO loop");
2770 }
2771
2772 /* DO WHILE statement.  */
2773
2774 void
2775 ffeste_R819B (ffestw block, ffelab label UNUSED, ffebld expr)
2776 {
2777   tree result;
2778
2779   ffeste_check_simple_ ();
2780
2781   ffeste_emit_line_note_ ();
2782
2783   ffeste_start_block_ (block);
2784
2785   if (expr)
2786     {
2787       struct nesting *loop;
2788       tree mod;
2789
2790       result = ffecom_make_tempvar ("dowhile", integer_type_node,
2791                                     FFETARGET_charactersizeNONE, -1);
2792       loop = expand_start_loop (1);
2793
2794       ffeste_start_stmt_ ();
2795
2796       ffecom_prepare_expr (expr);
2797
2798       ffecom_prepare_end ();
2799
2800       mod = ffecom_modify (void_type_node,
2801                            result,
2802                            ffecom_truth_value (ffecom_expr (expr)));
2803       expand_expr_stmt (mod);
2804
2805       ffeste_end_stmt_ ();
2806
2807       ffestw_set_do_hook (block, loop);
2808       expand_exit_loop_top_cond (0, result);
2809     }
2810   else
2811     ffestw_set_do_hook (block, expand_start_loop (1));
2812
2813   ffestw_set_do_tvar (block, NULL_TREE);
2814 }
2815
2816 /* END DO statement.
2817
2818    This is the MIL-STD 1753 END DO. It's syntactic sugar, similar to
2819    CONTINUE (except that it has to have a label that is the target of
2820    one or more iterative DO statement), not the Fortran-90 structured
2821    END DO, which is handled elsewhere, as is the actual mechanism of
2822    ending an iterative DO statement, even one that ends at a label.  */
2823
2824 void
2825 ffeste_R825 ()
2826 {
2827   ffeste_check_simple_ ();
2828
2829   ffeste_emit_line_note_ ();
2830
2831   emit_nop ();
2832 }
2833
2834 /* CYCLE statement.  */
2835
2836 void
2837 ffeste_R834 (ffestw block)
2838 {
2839   ffeste_check_simple_ ();
2840
2841   ffeste_emit_line_note_ ();
2842
2843   expand_continue_loop (ffestw_do_hook (block));
2844 }
2845
2846 /* EXIT statement.  */
2847
2848 void
2849 ffeste_R835 (ffestw block)
2850 {
2851   ffeste_check_simple_ ();
2852
2853   ffeste_emit_line_note_ ();
2854
2855   expand_exit_loop (ffestw_do_hook (block));
2856 }
2857
2858 /* GOTO statement.  */
2859
2860 void
2861 ffeste_R836 (ffelab label)
2862 {
2863   tree glabel;
2864
2865   ffeste_check_simple_ ();
2866
2867   ffeste_emit_line_note_ ();
2868
2869   glabel = ffecom_lookup_label (label);
2870   if ((glabel != NULL_TREE)
2871       && (TREE_CODE (glabel) != ERROR_MARK))
2872     {
2873       expand_goto (glabel);
2874       TREE_USED (glabel) = 1;
2875     }
2876 }
2877
2878 /* Computed GOTO statement.  */
2879
2880 void
2881 ffeste_R837 (ffelab *labels, int count, ffebld expr)
2882 {
2883   int i;
2884   tree texpr;
2885   tree value;
2886   tree tlabel;
2887   int pushok;
2888   tree duplicate;
2889
2890   ffeste_check_simple_ ();
2891
2892   ffeste_emit_line_note_ ();
2893
2894   ffeste_start_stmt_ ();
2895
2896   ffecom_prepare_expr (expr);
2897
2898   ffecom_prepare_end ();
2899
2900   texpr = ffecom_expr (expr);
2901
2902   expand_start_case (0, texpr, TREE_TYPE (texpr), "computed GOTO statement");
2903
2904   for (i = 0; i < count; ++i)
2905     {
2906       value = build_int_2 (i + 1, 0);
2907       tlabel = build_decl (LABEL_DECL, NULL_TREE, NULL_TREE);
2908
2909       pushok = pushcase (value, convert, tlabel, &duplicate);
2910       assert (pushok == 0);
2911
2912       tlabel = ffecom_lookup_label (labels[i]);
2913       if ((tlabel == NULL_TREE)
2914           || (TREE_CODE (tlabel) == ERROR_MARK))
2915         continue;
2916
2917       expand_goto (tlabel);
2918       TREE_USED (tlabel) = 1;
2919     }
2920   expand_end_case (texpr);
2921
2922   ffeste_end_stmt_ ();
2923 }
2924
2925 /* ASSIGN statement.  */
2926
2927 void
2928 ffeste_R838 (ffelab label, ffebld target)
2929 {
2930   tree expr_tree;
2931   tree label_tree;
2932   tree target_tree;
2933
2934   ffeste_check_simple_ ();
2935
2936   ffeste_emit_line_note_ ();
2937
2938     /* No need to call ffeste_start_stmt_(), as the sorts of expressions
2939        seen here should never require use of temporaries.  */
2940
2941   label_tree = ffecom_lookup_label (label);
2942   if ((label_tree != NULL_TREE)
2943       && (TREE_CODE (label_tree) != ERROR_MARK))
2944     {
2945       label_tree = ffecom_1 (ADDR_EXPR,
2946                              build_pointer_type (void_type_node),
2947                              label_tree);
2948       TREE_CONSTANT (label_tree) = 1;
2949
2950       target_tree = ffecom_expr_assign_w (target);
2951       if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (target_tree)))
2952           < GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (label_tree))))
2953         error ("ASSIGN to variable that is too small");
2954
2955       label_tree = convert (TREE_TYPE (target_tree), label_tree);
2956
2957       expr_tree = ffecom_modify (void_type_node,
2958                                  target_tree,
2959                                  label_tree);
2960       expand_expr_stmt (expr_tree);
2961     }
2962 }
2963
2964 /* Assigned GOTO statement.  */
2965
2966 void
2967 ffeste_R839 (ffebld target)
2968 {
2969   tree t;
2970
2971   ffeste_check_simple_ ();
2972
2973   ffeste_emit_line_note_ ();
2974
2975   /* No need to call ffeste_start_stmt_(), as the sorts of expressions
2976      seen here should never require use of temporaries.  */
2977
2978   t = ffecom_expr_assign (target);
2979   if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (t)))
2980       < GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
2981     error ("ASSIGNed GOTO target variable is too small");
2982
2983   expand_computed_goto (convert (TREE_TYPE (null_pointer_node), t));
2984 }
2985
2986 /* Arithmetic IF statement.  */
2987
2988 void
2989 ffeste_R840 (ffebld expr, ffelab neg, ffelab zero, ffelab pos)
2990 {
2991   tree gneg = ffecom_lookup_label (neg);
2992   tree gzero = ffecom_lookup_label (zero);
2993   tree gpos = ffecom_lookup_label (pos);
2994   tree texpr;
2995
2996   ffeste_check_simple_ ();
2997
2998   ffeste_emit_line_note_ ();
2999
3000   if ((gneg == NULL_TREE) || (gzero == NULL_TREE) || (gpos == NULL_TREE))
3001     return;
3002   if ((TREE_CODE (gneg) == ERROR_MARK)
3003       || (TREE_CODE (gzero) == ERROR_MARK)
3004       || (TREE_CODE (gpos) == ERROR_MARK))
3005     return;
3006
3007   ffeste_start_stmt_ ();
3008
3009   ffecom_prepare_expr (expr);
3010
3011   ffecom_prepare_end ();
3012
3013   if (neg == zero)
3014     {
3015       if (neg == pos)
3016         expand_goto (gzero);
3017       else
3018         {
3019           /* IF (expr.LE.0) THEN GOTO neg/zero ELSE GOTO pos.  */
3020           texpr = ffecom_expr (expr);
3021           texpr = ffecom_2 (LE_EXPR, integer_type_node,
3022                             texpr,
3023                             convert (TREE_TYPE (texpr),
3024                                      integer_zero_node));
3025           expand_start_cond (ffecom_truth_value (texpr), 0);
3026           expand_goto (gzero);
3027           expand_start_else ();
3028           expand_goto (gpos);
3029           expand_end_cond ();
3030         }
3031     }
3032   else if (neg == pos)
3033     {
3034       /* IF (expr.NE.0) THEN GOTO neg/pos ELSE GOTO zero.  */
3035       texpr = ffecom_expr (expr);
3036       texpr = ffecom_2 (NE_EXPR, integer_type_node,
3037                         texpr,
3038                         convert (TREE_TYPE (texpr),
3039                                  integer_zero_node));
3040       expand_start_cond (ffecom_truth_value (texpr), 0);
3041       expand_goto (gneg);
3042       expand_start_else ();
3043       expand_goto (gzero);
3044       expand_end_cond ();
3045     }
3046   else if (zero == pos)
3047     {
3048       /* IF (expr.GE.0) THEN GOTO zero/pos ELSE GOTO neg.  */
3049       texpr = ffecom_expr (expr);
3050       texpr = ffecom_2 (GE_EXPR, integer_type_node,
3051                         texpr,
3052                         convert (TREE_TYPE (texpr),
3053                                  integer_zero_node));
3054       expand_start_cond (ffecom_truth_value (texpr), 0);
3055       expand_goto (gzero);
3056       expand_start_else ();
3057       expand_goto (gneg);
3058       expand_end_cond ();
3059     }
3060   else
3061     {
3062       /* Use a SAVE_EXPR in combo with:
3063          IF (expr.LT.0) THEN GOTO neg
3064          ELSEIF (expr.GT.0) THEN GOTO pos
3065          ELSE GOTO zero.  */
3066       tree expr_saved = ffecom_save_tree (ffecom_expr (expr));
3067
3068       texpr = ffecom_2 (LT_EXPR, integer_type_node,
3069                         expr_saved,
3070                         convert (TREE_TYPE (expr_saved),
3071                                  integer_zero_node));
3072       expand_start_cond (ffecom_truth_value (texpr), 0);
3073       expand_goto (gneg);
3074       texpr = ffecom_2 (GT_EXPR, integer_type_node,
3075                         expr_saved,
3076                         convert (TREE_TYPE (expr_saved),
3077                                  integer_zero_node));
3078       expand_start_elseif (ffecom_truth_value (texpr));
3079       expand_goto (gpos);
3080       expand_start_else ();
3081       expand_goto (gzero);
3082       expand_end_cond ();
3083     }
3084
3085   ffeste_end_stmt_ ();
3086 }
3087
3088 /* CONTINUE statement.  */
3089
3090 void
3091 ffeste_R841 ()
3092 {
3093   ffeste_check_simple_ ();
3094
3095   ffeste_emit_line_note_ ();
3096
3097   emit_nop ();
3098 }
3099
3100 /* STOP statement.  */
3101
3102 void
3103 ffeste_R842 (ffebld expr)
3104 {
3105   tree callit;
3106   ffelexToken msg;
3107
3108   ffeste_check_simple_ ();
3109
3110   ffeste_emit_line_note_ ();
3111
3112   if ((expr == NULL)
3113       || (ffeinfo_basictype (ffebld_info (expr))
3114           == FFEINFO_basictypeANY))
3115     {
3116       msg = ffelex_token_new_character ("",
3117                                         ffelex_token_where_line (ffesta_tokens[0]),
3118                                         ffelex_token_where_column (ffesta_tokens[0]));
3119       expr = ffebld_new_conter (ffebld_constant_new_characterdefault
3120                                 (msg));
3121       ffelex_token_kill (msg);
3122       ffebld_set_info (expr, ffeinfo_new (FFEINFO_basictypeCHARACTER,
3123                                           FFEINFO_kindtypeCHARACTERDEFAULT,
3124                                           0, FFEINFO_kindENTITY,
3125                                           FFEINFO_whereCONSTANT, 0));
3126     }
3127   else if (ffeinfo_basictype (ffebld_info (expr))
3128            == FFEINFO_basictypeINTEGER)
3129     {
3130       char num[50];
3131
3132       assert (ffebld_op (expr) == FFEBLD_opCONTER);
3133       assert (ffeinfo_kindtype (ffebld_info (expr))
3134               == FFEINFO_kindtypeINTEGERDEFAULT);
3135       sprintf (num, "%" ffetargetIntegerDefault_f "d",
3136                ffebld_constant_integer1 (ffebld_conter (expr)));
3137       msg = ffelex_token_new_character (num,
3138                                         ffelex_token_where_line (ffesta_tokens[0]),
3139                                         ffelex_token_where_column (ffesta_tokens[0]));
3140       expr = ffebld_new_conter (ffebld_constant_new_characterdefault (msg));
3141       ffelex_token_kill (msg);
3142       ffebld_set_info (expr, ffeinfo_new (FFEINFO_basictypeCHARACTER,
3143                                           FFEINFO_kindtypeCHARACTERDEFAULT,
3144                                           0, FFEINFO_kindENTITY,
3145                                           FFEINFO_whereCONSTANT, 0));
3146     }
3147   else
3148     {
3149       assert (ffeinfo_basictype (ffebld_info (expr))
3150               == FFEINFO_basictypeCHARACTER);
3151       assert (ffebld_op (expr) == FFEBLD_opCONTER);
3152       assert (ffeinfo_kindtype (ffebld_info (expr))
3153               == FFEINFO_kindtypeCHARACTERDEFAULT);
3154     }
3155
3156   /* No need to call ffeste_start_stmt_(), as the sorts of expressions
3157      seen here should never require use of temporaries.  */
3158
3159   callit = ffecom_call_gfrt (FFECOM_gfrtSTOP,
3160                              ffecom_list_ptr_to_expr (ffebld_new_item (expr, NULL)),
3161                              NULL_TREE);
3162   TREE_SIDE_EFFECTS (callit) = 1;
3163
3164   expand_expr_stmt (callit);
3165 }
3166
3167 /* PAUSE statement.  */
3168
3169 void
3170 ffeste_R843 (ffebld expr)
3171 {
3172   tree callit;
3173   ffelexToken msg;
3174
3175   ffeste_check_simple_ ();
3176
3177   ffeste_emit_line_note_ ();
3178
3179   if ((expr == NULL)
3180       || (ffeinfo_basictype (ffebld_info (expr))
3181           == FFEINFO_basictypeANY))
3182     {
3183       msg = ffelex_token_new_character ("",
3184                                         ffelex_token_where_line (ffesta_tokens[0]),
3185                                         ffelex_token_where_column (ffesta_tokens[0]));
3186       expr = ffebld_new_conter (ffebld_constant_new_characterdefault (msg));
3187       ffelex_token_kill (msg);
3188       ffebld_set_info (expr, ffeinfo_new (FFEINFO_basictypeCHARACTER,
3189                                           FFEINFO_kindtypeCHARACTERDEFAULT,
3190                                           0, FFEINFO_kindENTITY,
3191                                           FFEINFO_whereCONSTANT, 0));
3192     }
3193   else if (ffeinfo_basictype (ffebld_info (expr)) == FFEINFO_basictypeINTEGER)
3194     {
3195       char num[50];
3196
3197       assert (ffebld_op (expr) == FFEBLD_opCONTER);
3198       assert (ffeinfo_kindtype (ffebld_info (expr))
3199               == FFEINFO_kindtypeINTEGERDEFAULT);
3200       sprintf (num, "%" ffetargetIntegerDefault_f "d",
3201                ffebld_constant_integer1 (ffebld_conter (expr)));
3202       msg = ffelex_token_new_character (num, ffelex_token_where_line (ffesta_tokens[0]),
3203                                         ffelex_token_where_column (ffesta_tokens[0]));
3204       expr = ffebld_new_conter (ffebld_constant_new_characterdefault (msg));
3205       ffelex_token_kill (msg);
3206       ffebld_set_info (expr, ffeinfo_new (FFEINFO_basictypeCHARACTER,
3207                                           FFEINFO_kindtypeCHARACTERDEFAULT,
3208                                           0, FFEINFO_kindENTITY,
3209                                           FFEINFO_whereCONSTANT, 0));
3210     }
3211   else
3212     {
3213       assert (ffeinfo_basictype (ffebld_info (expr))
3214               == FFEINFO_basictypeCHARACTER);
3215       assert (ffebld_op (expr) == FFEBLD_opCONTER);
3216       assert (ffeinfo_kindtype (ffebld_info (expr))
3217               == FFEINFO_kindtypeCHARACTERDEFAULT);
3218     }
3219
3220   /* No need to call ffeste_start_stmt_(), as the sorts of expressions
3221      seen here should never require use of temporaries.  */
3222
3223   callit = ffecom_call_gfrt (FFECOM_gfrtPAUSE,
3224                              ffecom_list_ptr_to_expr (ffebld_new_item (expr, NULL)),
3225                              NULL_TREE);
3226   TREE_SIDE_EFFECTS (callit) = 1;
3227
3228   expand_expr_stmt (callit);
3229 }
3230
3231 /* OPEN statement.  */
3232
3233 void
3234 ffeste_R904 (ffestpOpenStmt *info)
3235 {
3236   tree args;
3237   bool iostat;
3238   bool errl;
3239
3240   ffeste_check_simple_ ();
3241
3242   ffeste_emit_line_note_ ();
3243
3244 #define specified(something) (info->open_spec[something].kw_or_val_present)
3245
3246   iostat = specified (FFESTP_openixIOSTAT);
3247   errl = specified (FFESTP_openixERR);
3248
3249 #undef specified
3250
3251   ffeste_start_stmt_ ();
3252
3253   if (errl)
3254     {
3255       ffeste_io_err_
3256         = ffeste_io_abort_
3257         = ffecom_lookup_label
3258         (info->open_spec[FFESTP_openixERR].u.label);
3259       ffeste_io_abort_is_temp_ = FALSE;
3260     }
3261   else
3262     {
3263       ffeste_io_err_ = NULL_TREE;
3264
3265       if ((ffeste_io_abort_is_temp_ = iostat))
3266         ffeste_io_abort_ = ffecom_temp_label ();
3267       else
3268         ffeste_io_abort_ = NULL_TREE;
3269     }
3270
3271   if (iostat)
3272     {
3273       /* Have IOSTAT= specification.  */
3274
3275       ffeste_io_iostat_is_temp_ = FALSE;
3276       ffeste_io_iostat_ = ffecom_expr
3277         (info->open_spec[FFESTP_openixIOSTAT].u.expr);
3278     }
3279   else if (ffeste_io_abort_ != NULL_TREE)
3280     {
3281       /* Have no IOSTAT= but have ERR=.  */
3282
3283       ffeste_io_iostat_is_temp_ = TRUE;
3284       ffeste_io_iostat_
3285         = ffecom_make_tempvar ("open", ffecom_integer_type_node,
3286                                FFETARGET_charactersizeNONE, -1);
3287     }
3288   else
3289     {
3290       /* No IOSTAT= or ERR= specification.  */
3291
3292       ffeste_io_iostat_is_temp_ = FALSE;
3293       ffeste_io_iostat_ = NULL_TREE;
3294     }
3295
3296   /* Now prescan, then convert, all the arguments.  */
3297
3298   args = ffeste_io_olist_ (errl || iostat,
3299                            info->open_spec[FFESTP_openixUNIT].u.expr,
3300                            &info->open_spec[FFESTP_openixFILE],
3301                            &info->open_spec[FFESTP_openixSTATUS],
3302                            &info->open_spec[FFESTP_openixACCESS],
3303                            &info->open_spec[FFESTP_openixFORM],
3304                            &info->open_spec[FFESTP_openixRECL],
3305                            &info->open_spec[FFESTP_openixBLANK]);
3306
3307   /* Don't generate "if (iostat != 0) goto label;" if label is temp abort
3308        label, since we're gonna fall through to there anyway. */
3309
3310   ffeste_io_call_ (ffecom_call_gfrt (FFECOM_gfrtFOPEN, args, NULL_TREE),
3311                    ! ffeste_io_abort_is_temp_);
3312
3313   /* If we've got a temp label, generate its code here.  */
3314
3315   if (ffeste_io_abort_is_temp_)
3316     {
3317       DECL_INITIAL (ffeste_io_abort_) = error_mark_node;
3318       emit_nop ();
3319       expand_label (ffeste_io_abort_);
3320
3321       assert (ffeste_io_err_ == NULL_TREE);
3322     }
3323
3324   ffeste_end_stmt_ ();
3325 }
3326
3327 /* CLOSE statement.  */
3328
3329 void
3330 ffeste_R907 (ffestpCloseStmt *info)
3331 {
3332   tree args;
3333   bool iostat;
3334   bool errl;
3335
3336   ffeste_check_simple_ ();
3337
3338   ffeste_emit_line_note_ ();
3339
3340 #define specified(something) (info->close_spec[something].kw_or_val_present)
3341
3342   iostat = specified (FFESTP_closeixIOSTAT);
3343   errl = specified (FFESTP_closeixERR);
3344
3345 #undef specified
3346
3347   ffeste_start_stmt_ ();
3348
3349   if (errl)
3350     {
3351       ffeste_io_err_
3352         = ffeste_io_abort_
3353         = ffecom_lookup_label
3354         (info->close_spec[FFESTP_closeixERR].u.label);
3355       ffeste_io_abort_is_temp_ = FALSE;
3356     }
3357   else
3358     {
3359       ffeste_io_err_ = NULL_TREE;
3360
3361       if ((ffeste_io_abort_is_temp_ = iostat))
3362         ffeste_io_abort_ = ffecom_temp_label ();
3363       else
3364         ffeste_io_abort_ = NULL_TREE;
3365     }
3366
3367   if (iostat)
3368     {
3369       /* Have IOSTAT= specification.  */
3370
3371       ffeste_io_iostat_is_temp_ = FALSE;
3372       ffeste_io_iostat_ = ffecom_expr
3373         (info->close_spec[FFESTP_closeixIOSTAT].u.expr);
3374     }
3375   else if (ffeste_io_abort_ != NULL_TREE)
3376     {
3377       /* Have no IOSTAT= but have ERR=.  */
3378
3379       ffeste_io_iostat_is_temp_ = TRUE;
3380       ffeste_io_iostat_
3381         = ffecom_make_tempvar ("close", ffecom_integer_type_node,
3382                                FFETARGET_charactersizeNONE, -1);
3383     }
3384   else
3385     {
3386       /* No IOSTAT= or ERR= specification.  */
3387
3388       ffeste_io_iostat_is_temp_ = FALSE;
3389       ffeste_io_iostat_ = NULL_TREE;
3390     }
3391
3392   /* Now prescan, then convert, all the arguments.  */
3393
3394   args = ffeste_io_cllist_ (errl || iostat,
3395                             info->close_spec[FFESTP_closeixUNIT].u.expr,
3396                             &info->close_spec[FFESTP_closeixSTATUS]);
3397
3398   /* Don't generate "if (iostat != 0) goto label;" if label is temp abort
3399        label, since we're gonna fall through to there anyway. */
3400
3401   ffeste_io_call_ (ffecom_call_gfrt (FFECOM_gfrtFCLOS, args, NULL_TREE),
3402                    ! ffeste_io_abort_is_temp_);
3403
3404   /* If we've got a temp label, generate its code here. */
3405
3406   if (ffeste_io_abort_is_temp_)
3407     {
3408       DECL_INITIAL (ffeste_io_abort_) = error_mark_node;
3409       emit_nop ();
3410       expand_label (ffeste_io_abort_);
3411
3412       assert (ffeste_io_err_ == NULL_TREE);
3413     }
3414
3415   ffeste_end_stmt_ ();
3416 }
3417
3418 /* READ(...) statement -- start.  */
3419
3420 void
3421 ffeste_R909_start (ffestpReadStmt *info, bool only_format UNUSED,
3422                    ffestvUnit unit, ffestvFormat format, bool rec,
3423                    bool key UNUSED)
3424 {
3425   ffecomGfrt start;
3426   ffecomGfrt end;
3427   tree cilist;
3428   bool iostat;
3429   bool errl;
3430   bool endl;
3431
3432   ffeste_check_start_ ();
3433
3434   ffeste_emit_line_note_ ();
3435
3436   /* First determine the start, per-item, and end run-time functions to
3437      call.  The per-item function is picked by choosing an ffeste function
3438      to call to handle a given item; it knows how to generate a call to the
3439      appropriate run-time function, and is called an "I/O driver".  */
3440
3441   switch (format)
3442     {
3443     case FFESTV_formatNONE:     /* no FMT= */
3444       ffeste_io_driver_ = ffeste_io_douio_;
3445       if (rec)
3446         start = FFECOM_gfrtSRDUE, end = FFECOM_gfrtERDUE;
3447       else
3448         start = FFECOM_gfrtSRSUE, end = FFECOM_gfrtERSUE;
3449       break;
3450
3451     case FFESTV_formatLABEL:    /* FMT=10 */
3452     case FFESTV_formatCHAREXPR: /* FMT='(I10)' */
3453     case FFESTV_formatINTEXPR:  /* FMT=I [after ASSIGN 10 TO I] */
3454       ffeste_io_driver_ = ffeste_io_dofio_;
3455       if (rec)
3456         start = FFECOM_gfrtSRDFE, end = FFECOM_gfrtERDFE;
3457       else if (unit == FFESTV_unitCHAREXPR)
3458         start = FFECOM_gfrtSRSFI, end = FFECOM_gfrtERSFI;
3459       else
3460         start = FFECOM_gfrtSRSFE, end = FFECOM_gfrtERSFE;
3461       break;
3462
3463     case FFESTV_formatASTERISK: /* FMT=* */
3464       ffeste_io_driver_ = ffeste_io_dolio_;
3465       if (unit == FFESTV_unitCHAREXPR)
3466         start = FFECOM_gfrtSRSLI, end = FFECOM_gfrtERSLI;
3467       else
3468         start = FFECOM_gfrtSRSLE, end = FFECOM_gfrtERSLE;
3469       break;
3470
3471     case FFESTV_formatNAMELIST: /* FMT=FOO or NML=FOO [NAMELIST
3472                                    /FOO/] */
3473       ffeste_io_driver_ = NULL; /* No start or driver function. */
3474       start = FFECOM_gfrtSRSNE, end = FFECOM_gfrt;
3475       break;
3476
3477     default:
3478       assert ("Weird stuff" == NULL);
3479       start = FFECOM_gfrt, end = FFECOM_gfrt;
3480       break;
3481     }
3482   ffeste_io_endgfrt_ = end;
3483
3484 #define specified(something) (info->read_spec[something].kw_or_val_present)
3485
3486   iostat = specified (FFESTP_readixIOSTAT);
3487   errl = specified (FFESTP_readixERR);
3488   endl = specified (FFESTP_readixEND);
3489
3490 #undef specified
3491
3492   ffeste_start_stmt_ ();
3493
3494   if (errl)
3495     {
3496       /* Have ERR= specification.   */
3497
3498       ffeste_io_err_
3499         = ffecom_lookup_label (info->read_spec[FFESTP_readixERR].u.label);
3500
3501       if (endl)
3502         {
3503           /* Have both ERR= and END=.  Need a temp label to handle both.  */
3504           ffeste_io_end_
3505             = ffecom_lookup_label (info->read_spec[FFESTP_readixEND].u.label);
3506           ffeste_io_abort_is_temp_ = TRUE;
3507           ffeste_io_abort_ = ffecom_temp_label ();
3508         }
3509       else
3510         {
3511           /* Have ERR= but no END=.  */
3512           ffeste_io_end_ = NULL_TREE;
3513           if ((ffeste_io_abort_is_temp_ = iostat))
3514             ffeste_io_abort_ = ffecom_temp_label ();
3515           else
3516             ffeste_io_abort_ = ffeste_io_err_;
3517         }
3518     }
3519   else
3520     {
3521       /* No ERR= specification.  */
3522
3523       ffeste_io_err_ = NULL_TREE;
3524       if (endl)
3525         {
3526           /* Have END= but no ERR=.  */
3527           ffeste_io_end_
3528             = ffecom_lookup_label (info->read_spec[FFESTP_readixEND].u.label);
3529           if ((ffeste_io_abort_is_temp_ = iostat))
3530             ffeste_io_abort_ = ffecom_temp_label ();
3531           else
3532             ffeste_io_abort_ = ffeste_io_end_;
3533         }
3534       else
3535         {
3536           /* Have no ERR= or END=.  */
3537
3538           ffeste_io_end_ = NULL_TREE;
3539           if ((ffeste_io_abort_is_temp_ = iostat))
3540             ffeste_io_abort_ = ffecom_temp_label ();
3541           else
3542             ffeste_io_abort_ = NULL_TREE;
3543         }
3544     }
3545
3546   if (iostat)
3547     {
3548       /* Have IOSTAT= specification.  */
3549
3550       ffeste_io_iostat_is_temp_ = FALSE;
3551       ffeste_io_iostat_
3552         = ffecom_expr (info->read_spec[FFESTP_readixIOSTAT].u.expr);
3553     }
3554   else if (ffeste_io_abort_ != NULL_TREE)
3555     {
3556       /* Have no IOSTAT= but have ERR= and/or END=.  */
3557
3558       ffeste_io_iostat_is_temp_ = TRUE;
3559       ffeste_io_iostat_
3560         = ffecom_make_tempvar ("read", ffecom_integer_type_node,
3561                                FFETARGET_charactersizeNONE, -1);
3562     }
3563   else
3564     {
3565       /* No IOSTAT=, ERR=, or END= specification.  */
3566
3567       ffeste_io_iostat_is_temp_ = FALSE;
3568       ffeste_io_iostat_ = NULL_TREE;
3569     }
3570
3571   /* Now prescan, then convert, all the arguments.  */
3572
3573   if (unit == FFESTV_unitCHAREXPR)
3574     cilist = ffeste_io_icilist_ (errl || iostat,
3575                                  info->read_spec[FFESTP_readixUNIT].u.expr,
3576                                  endl || iostat, format,
3577                                  &info->read_spec[FFESTP_readixFORMAT]);
3578   else
3579     cilist = ffeste_io_cilist_ (errl || iostat, unit,
3580                                 info->read_spec[FFESTP_readixUNIT].u.expr,
3581                                 5, endl || iostat, format,
3582                                 &info->read_spec[FFESTP_readixFORMAT],
3583                                 rec,
3584                                 info->read_spec[FFESTP_readixREC].u.expr);
3585
3586   /* If there is no end function, then there are no item functions (i.e.
3587      it's a NAMELIST), and vice versa by the way.  In this situation, don't
3588      generate the "if (iostat != 0) goto label;" if the label is temp abort
3589      label, since we're gonna fall through to there anyway.  */
3590
3591   ffeste_io_call_ (ffecom_call_gfrt (start, cilist, NULL_TREE),
3592                    (! ffeste_io_abort_is_temp_) || (end != FFECOM_gfrt));
3593 }
3594
3595 /* READ statement -- I/O item.  */
3596
3597 void
3598 ffeste_R909_item (ffebld expr, ffelexToken expr_token)
3599 {
3600   ffeste_check_item_ ();
3601
3602   if (expr == NULL)
3603     return;
3604
3605   /* Strip parens off items such as in "READ *,(A)".  This is really a bug
3606      in the user's code, but I've been told lots of code does this.  */
3607   while (ffebld_op (expr) == FFEBLD_opPAREN)
3608     expr = ffebld_left (expr);
3609
3610   if (ffebld_op (expr) == FFEBLD_opANY)
3611     return;
3612
3613   if (ffebld_op (expr) == FFEBLD_opIMPDO)
3614     ffeste_io_impdo_ (expr, expr_token);
3615   else
3616     {
3617       ffeste_start_stmt_ ();
3618
3619       ffecom_prepare_arg_ptr_to_expr (expr);
3620
3621       ffecom_prepare_end ();
3622
3623       ffeste_io_call_ ((*ffeste_io_driver_) (expr), TRUE);
3624
3625       ffeste_end_stmt_ ();
3626     }
3627 }
3628
3629 /* READ statement -- end.  */
3630
3631 void
3632 ffeste_R909_finish ()
3633 {
3634   ffeste_check_finish_ ();
3635
3636   /* Don't generate "if (iostat != 0) goto label;" if label is temp abort
3637      label, since we're gonna fall through to there anyway. */
3638
3639   if (ffeste_io_endgfrt_ != FFECOM_gfrt)
3640     ffeste_io_call_ (ffecom_call_gfrt (ffeste_io_endgfrt_, NULL_TREE,
3641                                        NULL_TREE),
3642                      ! ffeste_io_abort_is_temp_);
3643
3644   /* If we've got a temp label, generate its code here and have it fan out
3645      to the END= or ERR= label as appropriate. */
3646
3647   if (ffeste_io_abort_is_temp_)
3648     {
3649       DECL_INITIAL (ffeste_io_abort_) = error_mark_node;
3650       emit_nop ();
3651       expand_label (ffeste_io_abort_);
3652
3653       /* "if (iostat<0) goto end_label;".  */
3654
3655       if ((ffeste_io_end_ != NULL_TREE)
3656           && (TREE_CODE (ffeste_io_end_) != ERROR_MARK))
3657         {
3658           expand_start_cond (ffecom_truth_value
3659                              (ffecom_2 (LT_EXPR, integer_type_node,
3660                                         ffeste_io_iostat_,
3661                                         ffecom_integer_zero_node)),
3662                              0);
3663           expand_goto (ffeste_io_end_);
3664           expand_end_cond ();
3665         }
3666
3667       /* "if (iostat>0) goto err_label;".  */
3668
3669       if ((ffeste_io_err_ != NULL_TREE)
3670           && (TREE_CODE (ffeste_io_err_) != ERROR_MARK))
3671         {
3672           expand_start_cond (ffecom_truth_value
3673                              (ffecom_2 (GT_EXPR, integer_type_node,
3674                                         ffeste_io_iostat_,
3675                                         ffecom_integer_zero_node)),
3676                              0);
3677           expand_goto (ffeste_io_err_);
3678           expand_end_cond ();
3679         }
3680     }
3681
3682   ffeste_end_stmt_ ();
3683 }
3684
3685 /* WRITE statement -- start.  */
3686
3687 void
3688 ffeste_R910_start (ffestpWriteStmt *info, ffestvUnit unit,
3689                    ffestvFormat format, bool rec)
3690 {
3691   ffecomGfrt start;
3692   ffecomGfrt end;
3693   tree cilist;
3694   bool iostat;
3695   bool errl;
3696
3697   ffeste_check_start_ ();
3698
3699   ffeste_emit_line_note_ ();
3700
3701   /* First determine the start, per-item, and end run-time functions to
3702      call.  The per-item function is picked by choosing an ffeste function
3703      to call to handle a given item; it knows how to generate a call to the
3704      appropriate run-time function, and is called an "I/O driver".  */
3705
3706   switch (format)
3707     {
3708     case FFESTV_formatNONE:     /* no FMT= */
3709       ffeste_io_driver_ = ffeste_io_douio_;
3710       if (rec)
3711         start = FFECOM_gfrtSWDUE, end = FFECOM_gfrtEWDUE;
3712       else
3713         start = FFECOM_gfrtSWSUE, end = FFECOM_gfrtEWSUE;
3714       break;
3715
3716     case FFESTV_formatLABEL:    /* FMT=10 */
3717     case FFESTV_formatCHAREXPR: /* FMT='(I10)' */
3718     case FFESTV_formatINTEXPR:  /* FMT=I [after ASSIGN 10 TO I] */
3719       ffeste_io_driver_ = ffeste_io_dofio_;
3720       if (rec)
3721         start = FFECOM_gfrtSWDFE, end = FFECOM_gfrtEWDFE;
3722       else if (unit == FFESTV_unitCHAREXPR)
3723         start = FFECOM_gfrtSWSFI, end = FFECOM_gfrtEWSFI;
3724       else
3725         start = FFECOM_gfrtSWSFE, end = FFECOM_gfrtEWSFE;
3726       break;
3727
3728     case FFESTV_formatASTERISK: /* FMT=* */
3729       ffeste_io_driver_ = ffeste_io_dolio_;
3730       if (unit == FFESTV_unitCHAREXPR)
3731         start = FFECOM_gfrtSWSLI, end = FFECOM_gfrtEWSLI;
3732       else
3733         start = FFECOM_gfrtSWSLE, end = FFECOM_gfrtEWSLE;
3734       break;
3735
3736     case FFESTV_formatNAMELIST: /* FMT=FOO or NML=FOO [NAMELIST
3737                                    /FOO/] */
3738       ffeste_io_driver_ = NULL; /* No start or driver function. */
3739       start = FFECOM_gfrtSWSNE, end = FFECOM_gfrt;
3740       break;
3741
3742     default:
3743       assert ("Weird stuff" == NULL);
3744       start = FFECOM_gfrt, end = FFECOM_gfrt;
3745       break;
3746     }
3747   ffeste_io_endgfrt_ = end;
3748
3749 #define specified(something) (info->write_spec[something].kw_or_val_present)
3750
3751   iostat = specified (FFESTP_writeixIOSTAT);
3752   errl = specified (FFESTP_writeixERR);
3753
3754 #undef specified
3755
3756   ffeste_start_stmt_ ();
3757
3758   ffeste_io_end_ = NULL_TREE;
3759
3760   if (errl)
3761     {
3762       /* Have ERR= specification.   */
3763
3764       ffeste_io_err_
3765         = ffeste_io_abort_
3766         = ffecom_lookup_label
3767         (info->write_spec[FFESTP_writeixERR].u.label);
3768       ffeste_io_abort_is_temp_ = FALSE;
3769     }
3770   else
3771     {
3772       /* No ERR= specification.  */
3773
3774       ffeste_io_err_ = NULL_TREE;
3775
3776       if ((ffeste_io_abort_is_temp_ = iostat))
3777         ffeste_io_abort_ = ffecom_temp_label ();
3778       else
3779         ffeste_io_abort_ = NULL_TREE;
3780     }
3781
3782   if (iostat)
3783     {
3784       /* Have IOSTAT= specification.  */
3785
3786       ffeste_io_iostat_is_temp_ = FALSE;
3787       ffeste_io_iostat_ = ffecom_expr
3788         (info->write_spec[FFESTP_writeixIOSTAT].u.expr);
3789     }
3790   else if (ffeste_io_abort_ != NULL_TREE)
3791     {
3792       /* Have no IOSTAT= but have ERR=.  */
3793
3794       ffeste_io_iostat_is_temp_ = TRUE;
3795       ffeste_io_iostat_
3796         = ffecom_make_tempvar ("write", ffecom_integer_type_node,
3797                                FFETARGET_charactersizeNONE, -1);
3798     }
3799   else
3800     {
3801       /* No IOSTAT= or ERR= specification.  */
3802
3803       ffeste_io_iostat_is_temp_ = FALSE;
3804       ffeste_io_iostat_ = NULL_TREE;
3805     }
3806
3807   /* Now prescan, then convert, all the arguments.  */
3808
3809   if (unit == FFESTV_unitCHAREXPR)
3810     cilist = ffeste_io_icilist_ (errl || iostat,
3811                                  info->write_spec[FFESTP_writeixUNIT].u.expr,
3812                                  FALSE, format,
3813                                  &info->write_spec[FFESTP_writeixFORMAT]);
3814   else
3815     cilist = ffeste_io_cilist_ (errl || iostat, unit,
3816                                 info->write_spec[FFESTP_writeixUNIT].u.expr,
3817                                 6, FALSE, format,
3818                                 &info->write_spec[FFESTP_writeixFORMAT],
3819                                 rec,
3820                                 info->write_spec[FFESTP_writeixREC].u.expr);
3821
3822   /* If there is no end function, then there are no item functions (i.e.
3823      it's a NAMELIST), and vice versa by the way.  In this situation, don't
3824      generate the "if (iostat != 0) goto label;" if the label is temp abort
3825      label, since we're gonna fall through to there anyway.  */
3826
3827   ffeste_io_call_ (ffecom_call_gfrt (start, cilist, NULL_TREE),
3828                    (! ffeste_io_abort_is_temp_) || (end != FFECOM_gfrt));
3829 }
3830
3831 /* WRITE statement -- I/O item.  */
3832
3833 void
3834 ffeste_R910_item (ffebld expr, ffelexToken expr_token)
3835 {
3836   ffeste_check_item_ ();
3837
3838   if (expr == NULL)
3839     return;
3840
3841   if (ffebld_op (expr) == FFEBLD_opANY)
3842     return;
3843
3844   if (ffebld_op (expr) == FFEBLD_opIMPDO)
3845     ffeste_io_impdo_ (expr, expr_token);
3846   else
3847     {
3848       ffeste_start_stmt_ ();
3849
3850       ffecom_prepare_arg_ptr_to_expr (expr);
3851
3852       ffecom_prepare_end ();
3853
3854       ffeste_io_call_ ((*ffeste_io_driver_) (expr), TRUE);
3855
3856       ffeste_end_stmt_ ();
3857     }
3858 }
3859
3860 /* WRITE statement -- end.  */
3861
3862 void
3863 ffeste_R910_finish ()
3864 {
3865   ffeste_check_finish_ ();
3866
3867   /* Don't generate "if (iostat != 0) goto label;" if label is temp abort
3868      label, since we're gonna fall through to there anyway. */
3869
3870   if (ffeste_io_endgfrt_ != FFECOM_gfrt)
3871     ffeste_io_call_ (ffecom_call_gfrt (ffeste_io_endgfrt_, NULL_TREE,
3872                                        NULL_TREE),
3873                      ! ffeste_io_abort_is_temp_);
3874
3875   /* If we've got a temp label, generate its code here. */
3876
3877   if (ffeste_io_abort_is_temp_)
3878     {
3879       DECL_INITIAL (ffeste_io_abort_) = error_mark_node;
3880       emit_nop ();
3881       expand_label (ffeste_io_abort_);
3882
3883       assert (ffeste_io_err_ == NULL_TREE);
3884     }
3885
3886   ffeste_end_stmt_ ();
3887 }
3888
3889 /* PRINT statement -- start.  */
3890
3891 void
3892 ffeste_R911_start (ffestpPrintStmt *info, ffestvFormat format)
3893 {
3894   ffecomGfrt start;
3895   ffecomGfrt end;
3896   tree cilist;
3897
3898   ffeste_check_start_ ();
3899
3900   ffeste_emit_line_note_ ();
3901
3902   /* First determine the start, per-item, and end run-time functions to
3903      call.  The per-item function is picked by choosing an ffeste function
3904      to call to handle a given item; it knows how to generate a call to the
3905      appropriate run-time function, and is called an "I/O driver".  */
3906
3907   switch (format)
3908     {
3909     case FFESTV_formatLABEL:    /* FMT=10 */
3910     case FFESTV_formatCHAREXPR: /* FMT='(I10)' */
3911     case FFESTV_formatINTEXPR:  /* FMT=I [after ASSIGN 10 TO I] */
3912       ffeste_io_driver_ = ffeste_io_dofio_;
3913       start = FFECOM_gfrtSWSFE, end = FFECOM_gfrtEWSFE;
3914       break;
3915
3916     case FFESTV_formatASTERISK: /* FMT=* */
3917       ffeste_io_driver_ = ffeste_io_dolio_;
3918       start = FFECOM_gfrtSWSLE, end = FFECOM_gfrtEWSLE;
3919       break;
3920
3921     case FFESTV_formatNAMELIST: /* FMT=FOO or NML=FOO [NAMELIST
3922                                    /FOO/] */
3923       ffeste_io_driver_ = NULL; /* No start or driver function. */
3924       start = FFECOM_gfrtSWSNE, end = FFECOM_gfrt;
3925       break;
3926
3927     default:
3928       assert ("Weird stuff" == NULL);
3929       start = FFECOM_gfrt, end = FFECOM_gfrt;
3930       break;
3931     }
3932   ffeste_io_endgfrt_ = end;
3933
3934   ffeste_start_stmt_ ();
3935
3936   ffeste_io_end_ = NULL_TREE;
3937   ffeste_io_err_ = NULL_TREE;
3938   ffeste_io_abort_ = NULL_TREE;
3939   ffeste_io_abort_is_temp_ = FALSE;
3940   ffeste_io_iostat_is_temp_ = FALSE;
3941   ffeste_io_iostat_ = NULL_TREE;
3942
3943   /* Now prescan, then convert, all the arguments.  */
3944
3945   cilist = ffeste_io_cilist_ (FALSE, FFESTV_unitNONE, NULL, 6, FALSE, format,
3946                               &info->print_spec[FFESTP_printixFORMAT],
3947                               FALSE, NULL);
3948
3949   /* If there is no end function, then there are no item functions (i.e.
3950      it's a NAMELIST), and vice versa by the way.  In this situation, don't
3951      generate the "if (iostat != 0) goto label;" if the label is temp abort
3952      label, since we're gonna fall through to there anyway.  */
3953
3954   ffeste_io_call_ (ffecom_call_gfrt (start, cilist, NULL_TREE),
3955                    (! ffeste_io_abort_is_temp_) || (end != FFECOM_gfrt));
3956 }
3957
3958 /* PRINT statement -- I/O item.  */
3959
3960 void
3961 ffeste_R911_item (ffebld expr, ffelexToken expr_token)
3962 {
3963   ffeste_check_item_ ();
3964
3965   if (expr == NULL)
3966     return;
3967
3968   if (ffebld_op (expr) == FFEBLD_opANY)
3969     return;
3970
3971   if (ffebld_op (expr) == FFEBLD_opIMPDO)
3972     ffeste_io_impdo_ (expr, expr_token);
3973   else
3974     {
3975       ffeste_start_stmt_ ();
3976
3977       ffecom_prepare_arg_ptr_to_expr (expr);
3978
3979       ffecom_prepare_end ();
3980
3981       ffeste_io_call_ ((*ffeste_io_driver_) (expr), TRUE);
3982
3983       ffeste_end_stmt_ ();
3984     }
3985 }
3986
3987 /* PRINT statement -- end.  */
3988
3989 void
3990 ffeste_R911_finish ()
3991 {
3992   ffeste_check_finish_ ();
3993
3994   if (ffeste_io_endgfrt_ != FFECOM_gfrt)
3995     ffeste_io_call_ (ffecom_call_gfrt (ffeste_io_endgfrt_, NULL_TREE,
3996                                        NULL_TREE),
3997                      FALSE);
3998
3999   ffeste_end_stmt_ ();
4000 }
4001
4002 /* BACKSPACE statement.  */
4003
4004 void
4005 ffeste_R919 (ffestpBeruStmt *info)
4006 {
4007   ffeste_check_simple_ ();
4008
4009   ffeste_subr_beru_ (info, FFECOM_gfrtFBACK);
4010 }
4011
4012 /* ENDFILE statement.  */
4013
4014 void
4015 ffeste_R920 (ffestpBeruStmt *info)
4016 {
4017   ffeste_check_simple_ ();
4018
4019   ffeste_subr_beru_ (info, FFECOM_gfrtFEND);
4020 }
4021
4022 /* REWIND statement.  */
4023
4024 void
4025 ffeste_R921 (ffestpBeruStmt *info)
4026 {
4027   ffeste_check_simple_ ();
4028
4029   ffeste_subr_beru_ (info, FFECOM_gfrtFREW);
4030 }
4031
4032 /* INQUIRE statement (non-IOLENGTH version).  */
4033
4034 void
4035 ffeste_R923A (ffestpInquireStmt *info, bool by_file UNUSED)
4036 {
4037   tree args;
4038   bool iostat;
4039   bool errl;
4040
4041   ffeste_check_simple_ ();
4042
4043   ffeste_emit_line_note_ ();
4044
4045 #define specified(something) (info->inquire_spec[something].kw_or_val_present)
4046
4047   iostat = specified (FFESTP_inquireixIOSTAT);
4048   errl = specified (FFESTP_inquireixERR);
4049
4050 #undef specified
4051
4052   ffeste_start_stmt_ ();
4053
4054   if (errl)
4055     {
4056       ffeste_io_err_
4057         = ffeste_io_abort_
4058         = ffecom_lookup_label
4059         (info->inquire_spec[FFESTP_inquireixERR].u.label);
4060       ffeste_io_abort_is_temp_ = FALSE;
4061     }
4062   else
4063     {
4064       ffeste_io_err_ = NULL_TREE;
4065
4066       if ((ffeste_io_abort_is_temp_ = iostat))
4067         ffeste_io_abort_ = ffecom_temp_label ();
4068       else
4069         ffeste_io_abort_ = NULL_TREE;
4070     }
4071
4072   if (iostat)
4073     {
4074       /* Have IOSTAT= specification.  */
4075
4076       ffeste_io_iostat_is_temp_ = FALSE;
4077       ffeste_io_iostat_ = ffecom_expr
4078         (info->inquire_spec[FFESTP_inquireixIOSTAT].u.expr);
4079     }
4080   else if (ffeste_io_abort_ != NULL_TREE)
4081     {
4082       /* Have no IOSTAT= but have ERR=.  */
4083
4084       ffeste_io_iostat_is_temp_ = TRUE;
4085       ffeste_io_iostat_
4086         = ffecom_make_tempvar ("inquire", ffecom_integer_type_node,
4087                                FFETARGET_charactersizeNONE, -1);
4088     }
4089   else
4090     {
4091       /* No IOSTAT= or ERR= specification.  */
4092
4093       ffeste_io_iostat_is_temp_ = FALSE;
4094       ffeste_io_iostat_ = NULL_TREE;
4095     }
4096
4097   /* Now prescan, then convert, all the arguments.  */
4098
4099   args
4100     = ffeste_io_inlist_ (errl || iostat,
4101                          &info->inquire_spec[FFESTP_inquireixUNIT],
4102                          &info->inquire_spec[FFESTP_inquireixFILE],
4103                          &info->inquire_spec[FFESTP_inquireixEXIST],
4104                          &info->inquire_spec[FFESTP_inquireixOPENED],
4105                          &info->inquire_spec[FFESTP_inquireixNUMBER],
4106                          &info->inquire_spec[FFESTP_inquireixNAMED],
4107                          &info->inquire_spec[FFESTP_inquireixNAME],
4108                          &info->inquire_spec[FFESTP_inquireixACCESS],
4109                          &info->inquire_spec[FFESTP_inquireixSEQUENTIAL],
4110                          &info->inquire_spec[FFESTP_inquireixDIRECT],
4111                          &info->inquire_spec[FFESTP_inquireixFORM],
4112                          &info->inquire_spec[FFESTP_inquireixFORMATTED],
4113                          &info->inquire_spec[FFESTP_inquireixUNFORMATTED],
4114                          &info->inquire_spec[FFESTP_inquireixRECL],
4115                          &info->inquire_spec[FFESTP_inquireixNEXTREC],
4116                          &info->inquire_spec[FFESTP_inquireixBLANK]);
4117
4118   /* Don't generate "if (iostat != 0) goto label;" if label is temp abort
4119      label, since we're gonna fall through to there anyway. */
4120
4121   ffeste_io_call_ (ffecom_call_gfrt (FFECOM_gfrtFINQU, args, NULL_TREE),
4122                    ! ffeste_io_abort_is_temp_);
4123
4124   /* If we've got a temp label, generate its code here.  */
4125
4126   if (ffeste_io_abort_is_temp_)
4127     {
4128       DECL_INITIAL (ffeste_io_abort_) = error_mark_node;
4129       emit_nop ();
4130       expand_label (ffeste_io_abort_);
4131
4132       assert (ffeste_io_err_ == NULL_TREE);
4133     }
4134
4135   ffeste_end_stmt_ ();
4136 }
4137
4138 /* INQUIRE(IOLENGTH=expr) statement -- start.  */
4139
4140 void
4141 ffeste_R923B_start (ffestpInquireStmt *info UNUSED)
4142 {
4143   ffeste_check_start_ ();
4144
4145   assert ("INQUIRE(IOLENGTH=<var>) not implemented yet! ~~~" == NULL);
4146
4147   ffeste_emit_line_note_ ();
4148 }
4149
4150 /* INQUIRE(IOLENGTH=expr) statement -- I/O item.  */
4151
4152 void
4153 ffeste_R923B_item (ffebld expr UNUSED)
4154 {
4155   ffeste_check_item_ ();
4156 }
4157
4158 /* INQUIRE(IOLENGTH=expr) statement -- end.  */
4159
4160 void
4161 ffeste_R923B_finish ()
4162 {
4163   ffeste_check_finish_ ();
4164 }
4165
4166 /* ffeste_R1001 -- FORMAT statement
4167
4168    ffeste_R1001(format_list);  */
4169
4170 void
4171 ffeste_R1001 (ffests s)
4172 {
4173   tree t;
4174   tree ttype;
4175   tree maxindex;
4176   tree var;
4177
4178   ffeste_check_simple_ ();
4179
4180   assert (ffeste_label_formatdef_ != NULL);
4181
4182   ffeste_emit_line_note_ ();
4183
4184   t = build_string (ffests_length (s), ffests_text (s));
4185
4186   TREE_TYPE (t)
4187     = build_type_variant (build_array_type
4188                           (char_type_node,
4189                            build_range_type (integer_type_node,
4190                                              integer_one_node,
4191                                              build_int_2 (ffests_length (s),
4192                                                           0))),
4193                           1, 0);
4194   TREE_CONSTANT (t) = 1;
4195   TREE_STATIC (t) = 1;
4196
4197   var = ffecom_lookup_label (ffeste_label_formatdef_);
4198   if ((var != NULL_TREE)
4199       && (TREE_CODE (var) == VAR_DECL))
4200     {
4201       DECL_INITIAL (var) = t;
4202       maxindex = build_int_2 (ffests_length (s) - 1, 0);
4203       ttype = TREE_TYPE (var);
4204       TYPE_DOMAIN (ttype) = build_range_type (integer_type_node,
4205                                               integer_zero_node,
4206                                               maxindex);
4207       if (!TREE_TYPE (maxindex))
4208         TREE_TYPE (maxindex) = TYPE_DOMAIN (ttype);
4209       layout_type (ttype);
4210       rest_of_decl_compilation (var, NULL, 1, 0);
4211       expand_decl (var);
4212       expand_decl_init (var);
4213     }
4214
4215   ffeste_label_formatdef_ = NULL;
4216 }
4217
4218 /* END PROGRAM.  */
4219
4220 void
4221 ffeste_R1103 ()
4222 {
4223 }
4224
4225 /* END BLOCK DATA.  */
4226
4227 void
4228 ffeste_R1112 ()
4229 {
4230 }
4231
4232 /* CALL statement.  */
4233
4234 void
4235 ffeste_R1212 (ffebld expr)
4236 {
4237   ffebld args;
4238   ffebld arg;
4239   ffebld labels = NULL; /* First in list of LABTERs. */
4240   ffebld prevlabels = NULL;
4241   ffebld prevargs = NULL;
4242
4243   ffeste_check_simple_ ();
4244
4245   args = ffebld_right (expr);
4246
4247   ffeste_emit_line_note_ ();
4248
4249   /* Here we split the list at ffebld_right(expr) into two lists: one at
4250      ffebld_right(expr) consisting of all items that are not LABTERs, the
4251      other at labels consisting of all items that are LABTERs.  Then, if
4252      the latter list is NULL, we have an ordinary call, else we have a call
4253      with alternate returns. */
4254
4255   for (args = ffebld_right (expr); args != NULL; args = ffebld_trail (args))
4256     {
4257       if (((arg = ffebld_head (args)) == NULL)
4258           || (ffebld_op (arg) != FFEBLD_opLABTER))
4259         {
4260           if (prevargs == NULL)
4261             {
4262               prevargs = args;
4263               ffebld_set_right (expr, args);
4264             }
4265           else
4266             {
4267               ffebld_set_trail (prevargs, args);
4268               prevargs = args;
4269             }
4270         }
4271       else
4272         {
4273           if (prevlabels == NULL)
4274             {
4275               prevlabels = labels = args;
4276             }
4277           else
4278             {
4279               ffebld_set_trail (prevlabels, args);
4280               prevlabels = args;
4281             }
4282         }
4283     }
4284   if (prevlabels == NULL)
4285     labels = NULL;
4286   else
4287     ffebld_set_trail (prevlabels, NULL);
4288   if (prevargs == NULL)
4289     ffebld_set_right (expr, NULL);
4290   else
4291     ffebld_set_trail (prevargs, NULL);
4292
4293   ffeste_start_stmt_ ();
4294
4295   /* No temporaries are actually needed at this level, but we go
4296      through the motions anyway, just to be sure in case they do
4297      get made.  Temporaries needed for arguments should be in the
4298      scopes of inner blocks, and if clean-up actions are supported,
4299      such as CALL-ing an intrinsic that writes to an argument of one
4300      type when a variable of a different type is provided (requiring
4301      assignment to the variable from a temporary after the library
4302      routine returns), the clean-up must be done by the expression
4303      evaluator, generally, to handle alternate returns (which we hope
4304      won't ever be supported by intrinsics, but might be a similar
4305      issue, such as CALL-ing an F90-style subroutine with an INTERFACE
4306      block).  That implies the expression evaluator will have to
4307      recognize the need for its own temporary anyway, meaning it'll
4308      construct a block within the one constructed here.  */
4309
4310   ffecom_prepare_expr (expr);
4311
4312   ffecom_prepare_end ();
4313
4314   if (labels == NULL)
4315     expand_expr_stmt (ffecom_expr (expr));
4316   else
4317     {
4318       tree texpr;
4319       tree value;
4320       tree tlabel;
4321       int caseno;
4322       int pushok;
4323       tree duplicate;
4324       ffebld label;
4325
4326       texpr = ffecom_expr (expr);
4327       expand_start_case (0, texpr, TREE_TYPE (texpr), "CALL statement");
4328
4329       for (caseno = 1, label = labels;
4330            label != NULL;
4331            ++caseno, label = ffebld_trail (label))
4332         {
4333           value = build_int_2 (caseno, 0);
4334           tlabel = build_decl (LABEL_DECL, NULL_TREE, NULL_TREE);
4335
4336           pushok = pushcase (value, convert, tlabel, &duplicate);
4337           assert (pushok == 0);
4338
4339           tlabel
4340             = ffecom_lookup_label (ffebld_labter (ffebld_head (label)));
4341           if ((tlabel == NULL_TREE)
4342               || (TREE_CODE (tlabel) == ERROR_MARK))
4343             continue;
4344           TREE_USED (tlabel) = 1;
4345           expand_goto (tlabel);
4346         }
4347
4348       expand_end_case (texpr);
4349     }
4350
4351   ffeste_end_stmt_ ();
4352 }
4353
4354 /* END FUNCTION.  */
4355
4356 void
4357 ffeste_R1221 ()
4358 {
4359 }
4360
4361 /* END SUBROUTINE.  */
4362
4363 void
4364 ffeste_R1225 ()
4365 {
4366 }
4367
4368 /* ENTRY statement.  */
4369
4370 void
4371 ffeste_R1226 (ffesymbol entry)
4372 {
4373   tree label;
4374
4375   ffeste_check_simple_ ();
4376
4377   label = ffesymbol_hook (entry).length_tree;
4378
4379   ffeste_emit_line_note_ ();
4380
4381   if (label == error_mark_node)
4382     return;
4383
4384   DECL_INITIAL (label) = error_mark_node;
4385   emit_nop ();
4386   expand_label (label);
4387 }
4388
4389 /* RETURN statement.  */
4390
4391 void
4392 ffeste_R1227 (ffestw block UNUSED, ffebld expr)
4393 {
4394   tree rtn;
4395
4396   ffeste_check_simple_ ();
4397
4398   ffeste_emit_line_note_ ();
4399
4400   ffeste_start_stmt_ ();
4401
4402   ffecom_prepare_return_expr (expr);
4403
4404   ffecom_prepare_end ();
4405
4406   rtn = ffecom_return_expr (expr);
4407
4408   if ((rtn == NULL_TREE)
4409       || (rtn == error_mark_node))
4410     expand_null_return ();
4411   else
4412     {
4413       tree result = DECL_RESULT (current_function_decl);
4414
4415       if ((result != error_mark_node)
4416           && (TREE_TYPE (result) != error_mark_node))
4417         expand_return (ffecom_modify (NULL_TREE,
4418                                       result,
4419                                       convert (TREE_TYPE (result),
4420                                                rtn)));
4421       else
4422         expand_null_return ();
4423     }
4424
4425   ffeste_end_stmt_ ();
4426 }
4427
4428 /* REWRITE statement -- start.  */
4429
4430 #if FFESTR_VXT
4431 void
4432 ffeste_V018_start (ffestpRewriteStmt *info, ffestvFormat format)
4433 {
4434   ffeste_check_start_ ();
4435 }
4436
4437 /* REWRITE statement -- I/O item.  */
4438
4439 void
4440 ffeste_V018_item (ffebld expr)
4441 {
4442   ffeste_check_item_ ();
4443 }
4444
4445 /* REWRITE statement -- end.  */
4446
4447 void
4448 ffeste_V018_finish ()
4449 {
4450   ffeste_check_finish_ ();
4451 }
4452
4453 /* ACCEPT statement -- start.  */
4454
4455 void
4456 ffeste_V019_start (ffestpAcceptStmt *info, ffestvFormat format)
4457 {
4458   ffeste_check_start_ ();
4459 }
4460
4461 /* ACCEPT statement -- I/O item.  */
4462
4463 void
4464 ffeste_V019_item (ffebld expr)
4465 {
4466   ffeste_check_item_ ();
4467 }
4468
4469 /* ACCEPT statement -- end.  */
4470
4471 void
4472 ffeste_V019_finish ()
4473 {
4474   ffeste_check_finish_ ();
4475 }
4476
4477 #endif
4478 /* TYPE statement -- start.  */
4479
4480 void
4481 ffeste_V020_start (ffestpTypeStmt *info UNUSED,
4482                    ffestvFormat format UNUSED)
4483 {
4484   ffeste_check_start_ ();
4485 }
4486
4487 /* TYPE statement -- I/O item.  */
4488
4489 void
4490 ffeste_V020_item (ffebld expr UNUSED)
4491 {
4492   ffeste_check_item_ ();
4493 }
4494
4495 /* TYPE statement -- end.  */
4496
4497 void
4498 ffeste_V020_finish ()
4499 {
4500   ffeste_check_finish_ ();
4501 }
4502
4503 /* DELETE statement.  */
4504
4505 #if FFESTR_VXT
4506 void
4507 ffeste_V021 (ffestpDeleteStmt *info)
4508 {
4509   ffeste_check_simple_ ();
4510 }
4511
4512 /* UNLOCK statement.  */
4513
4514 void
4515 ffeste_V022 (ffestpBeruStmt *info)
4516 {
4517   ffeste_check_simple_ ();
4518 }
4519
4520 /* ENCODE statement -- start.  */
4521
4522 void
4523 ffeste_V023_start (ffestpVxtcodeStmt *info)
4524 {
4525   ffeste_check_start_ ();
4526 }
4527
4528 /* ENCODE statement -- I/O item.  */
4529
4530 void
4531 ffeste_V023_item (ffebld expr)
4532 {
4533   ffeste_check_item_ ();
4534 }
4535
4536 /* ENCODE statement -- end.  */
4537
4538 void
4539 ffeste_V023_finish ()
4540 {
4541   ffeste_check_finish_ ();
4542 }
4543
4544 /* DECODE statement -- start.  */
4545
4546 void
4547 ffeste_V024_start (ffestpVxtcodeStmt *info)
4548 {
4549   ffeste_check_start_ ();
4550 }
4551
4552 /* DECODE statement -- I/O item.  */
4553
4554 void
4555 ffeste_V024_item (ffebld expr)
4556 {
4557   ffeste_check_item_ ();
4558 }
4559
4560 /* DECODE statement -- end.  */
4561
4562 void
4563 ffeste_V024_finish ()
4564 {
4565   ffeste_check_finish_ ();
4566 }
4567
4568 /* DEFINEFILE statement -- start.  */
4569
4570 void
4571 ffeste_V025_start ()
4572 {
4573   ffeste_check_start_ ();
4574 }
4575
4576 /* DEFINE FILE statement -- item.  */
4577
4578 void
4579 ffeste_V025_item (ffebld u, ffebld m, ffebld n, ffebld asv)
4580 {
4581   ffeste_check_item_ ();
4582 }
4583
4584 /* DEFINE FILE statement -- end.  */
4585
4586 void
4587 ffeste_V025_finish ()
4588 {
4589   ffeste_check_finish_ ();
4590 }
4591
4592 /* FIND statement.  */
4593
4594 void
4595 ffeste_V026 (ffestpFindStmt *info)
4596 {
4597   ffeste_check_simple_ ();
4598 }
4599
4600 #endif
4601
4602 #ifdef ENABLE_CHECKING
4603 void
4604 ffeste_terminate_2 (void)
4605 {
4606   assert (! ffeste_top_block_);
4607 }
4608 #endif
4609
4610 #include "gt-f-ste.h"