contrib/gcc-3.4/gcc/f/ste.c

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