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