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