gcc/f/ste.c

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