contrib/gcc/f/std.c

   1 /* std.c -- Implementation File (module.c template V1.0)
   2    Copyright (C) 1995, 1996 Free Software Foundation, Inc.
   3    Contributed by James Craig Burley.
   4
   5 This file is part of GNU Fortran.
   6
   7 GNU Fortran is free software; you can redistribute it and/or modify
   8 it under the terms of the GNU General Public License as published by
   9 the Free Software Foundation; either version 2, or (at your option)
  10 any later version.
  11
  12 GNU Fortran is distributed in the hope that it will be useful,
  13 but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 GNU General Public License for more details.
  16
  17 You should have received a copy of the GNU General Public License
  18 along with GNU Fortran; see the file COPYING.  If not, write to
  19 the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
  20 02111-1307, USA.
  21
  22    Related Modules:
  23       st.c
  24
  25    Description:
  26       Implements the various statements and such like.
  27
  28    Modifications:
  29       21-Nov-91  JCB  2.0
  30          Split out actual code generation to ffeste.
  31 */
  32
  33 /* Include files. */
  34
  35 #include "proj.h"
  36 #include "std.h"
  37 #include "bld.h"
  38 #include "com.h"
  39 #include "lab.h"
  40 #include "lex.h"
  41 #include "malloc.h"
  42 #include "sta.h"
  43 #include "ste.h"
  44 #include "stp.h"
  45 #include "str.h"
  46 #include "sts.h"
  47 #include "stt.h"
  48 #include "stv.h"
  49 #include "stw.h"
  50 #include "symbol.h"
  51 #include "target.h"
  52
  53 /* Externals defined here. */
  54
  55
  56 /* Simple definitions and enumerations. */
  57
  58 #define FFESTD_COPY_EASY_ 1     /* 1 for only one _subr_copy_xyz_ fn. */
  59
  60 #define FFESTD_IS_END_OPTIMIZED_ 1      /* 0=always gen STOP/RETURN before
  61                                            END. */
  62
  63 typedef enum
  64   {
  65     FFESTD_stateletSIMPLE_,     /* Expecting simple/start. */
  66     FFESTD_stateletATTRIB_,     /* Expecting attrib/item/itemstart. */
  67     FFESTD_stateletITEM_,       /* Expecting item/itemstart/finish. */
  68     FFESTD_stateletITEMVALS_,   /* Expecting itemvalue/itemendvals. */
  69     FFESTD_
  70   } ffestdStatelet_;
  71
  72 #if FFECOM_TWOPASS
  73 typedef enum
  74   {
  75     FFESTD_stmtidENDDOLOOP_,
  76     FFESTD_stmtidENDLOGIF_,
  77     FFESTD_stmtidEXECLABEL_,
  78     FFESTD_stmtidFORMATLABEL_,
  79     FFESTD_stmtidR737A_,        /* let */
  80     FFESTD_stmtidR803_,         /* IF-block */
  81     FFESTD_stmtidR804_,         /* ELSE IF */
  82     FFESTD_stmtidR805_,         /* ELSE */
  83     FFESTD_stmtidR806_,         /* END IF */
  84     FFESTD_stmtidR807_,         /* IF-logical */
  85     FFESTD_stmtidR809_,         /* SELECT CASE */
  86     FFESTD_stmtidR810_,         /* CASE */
  87     FFESTD_stmtidR811_,         /* END SELECT */
  88     FFESTD_stmtidR819A_,        /* DO-iterative */
  89     FFESTD_stmtidR819B_,        /* DO WHILE */
  90     FFESTD_stmtidR825_,         /* END DO */
  91     FFESTD_stmtidR834_,         /* CYCLE */
  92     FFESTD_stmtidR835_,         /* EXIT */
  93     FFESTD_stmtidR836_,         /* GOTO */
  94     FFESTD_stmtidR837_,         /* GOTO-computed */
  95     FFESTD_stmtidR838_,         /* ASSIGN */
  96     FFESTD_stmtidR839_,         /* GOTO-assigned */
  97     FFESTD_stmtidR840_,         /* IF-arithmetic */
  98     FFESTD_stmtidR841_,         /* CONTINUE */
  99     FFESTD_stmtidR842_,         /* STOP */
 100     FFESTD_stmtidR843_,         /* PAUSE */
 101     FFESTD_stmtidR904_,         /* OPEN */
 102     FFESTD_stmtidR907_,         /* CLOSE */
 103     FFESTD_stmtidR909_,         /* READ */
 104     FFESTD_stmtidR910_,         /* WRITE */
 105     FFESTD_stmtidR911_,         /* PRINT */
 106     FFESTD_stmtidR919_,         /* BACKSPACE */
 107     FFESTD_stmtidR920_,         /* ENDFILE */
 108     FFESTD_stmtidR921_,         /* REWIND */
 109     FFESTD_stmtidR923A_,        /* INQUIRE */
 110     FFESTD_stmtidR923B_,        /* INQUIRE-iolength */
 111     FFESTD_stmtidR1001_,        /* FORMAT */
 112     FFESTD_stmtidR1103_,        /* END_PROGRAM */
 113     FFESTD_stmtidR1112_,        /* END_BLOCK_DATA */
 114     FFESTD_stmtidR1212_,        /* CALL */
 115     FFESTD_stmtidR1221_,        /* END_FUNCTION */
 116     FFESTD_stmtidR1225_,        /* END_SUBROUTINE */
 117     FFESTD_stmtidR1226_,        /* ENTRY */
 118     FFESTD_stmtidR1227_,        /* RETURN */
 119 #if FFESTR_VXT
 120     FFESTD_stmtidV018_,         /* REWRITE */
 121     FFESTD_stmtidV019_,         /* ACCEPT */
 122 #endif
 123     FFESTD_stmtidV020_,         /* TYPE */
 124 #if FFESTR_VXT
 125     FFESTD_stmtidV021_,         /* DELETE */
 126     FFESTD_stmtidV022_,         /* UNLOCK */
 127     FFESTD_stmtidV023_,         /* ENCODE */
 128     FFESTD_stmtidV024_,         /* DECODE */
 129     FFESTD_stmtidV025start_,    /* DEFINEFILE (start) */
 130     FFESTD_stmtidV025item_,     /* (DEFINEFILE item) */
 131     FFESTD_stmtidV025finish_,   /* (DEFINEFILE finish) */
 132     FFESTD_stmtidV026_,         /* FIND */
 133 #endif
 134     FFESTD_stmtid_,
 135   } ffestdStmtId_;
 136
 137 #endif
 138
 139 /* Internal typedefs. */
 140
 141 typedef struct _ffestd_expr_item_ *ffestdExprItem_;
 142 #if FFECOM_TWOPASS
 143 typedef struct _ffestd_stmt_ *ffestdStmt_;
 144 #endif
 145
 146 /* Private include files. */
 147
 148
 149 /* Internal structure definitions. */
 150
 151 struct _ffestd_expr_item_
 152   {
 153     ffestdExprItem_ next;
 154     ffebld expr;
 155     ffelexToken token;
 156   };
 157
 158 #if FFECOM_TWOPASS
 159 struct _ffestd_stmt_
 160   {
 161     ffestdStmt_ next;
 162     ffestdStmt_ previous;
 163     ffestdStmtId_ id;
 164 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 165     char *filename;
 166     int filelinenum;
 167 #endif
 168     union
 169       {
 170         struct
 171           {
 172             ffestw block;
 173           }
 174         enddoloop;
 175         struct
 176           {
 177             ffelab label;
 178           }
 179         execlabel;
 180         struct
 181           {
 182             ffelab label;
 183           }
 184         formatlabel;
 185         struct
 186           {
 187             mallocPool pool;
 188             ffebld dest;
 189             ffebld source;
 190           }
 191         R737A;
 192         struct
 193           {
 194             mallocPool pool;
 195             ffestw block;
 196             ffebld expr;
 197           }
 198         R803;
 199         struct
 200           {
 201             mallocPool pool;
 202             ffestw block;
 203             ffebld expr;
 204           }
 205         R804;
 206         struct
 207           {
 208             ffestw block;
 209           }
 210         R805;
 211         struct
 212           {
 213             ffestw block;
 214           }
 215         R806;
 216         struct
 217           {
 218             mallocPool pool;
 219             ffebld expr;
 220           }
 221         R807;
 222         struct
 223           {
 224             mallocPool pool;
 225             ffestw block;
 226             ffebld expr;
 227           }
 228         R809;
 229         struct
 230           {
 231             mallocPool pool;
 232             ffestw block;
 233             unsigned long casenum;
 234           }
 235         R810;
 236         struct
 237           {
 238             ffestw block;
 239           }
 240         R811;
 241         struct
 242           {
 243             mallocPool pool;
 244             ffestw block;
 245             ffelab label;
 246             ffebld var;
 247             ffebld start;
 248             ffelexToken start_token;
 249             ffebld end;
 250             ffelexToken end_token;
 251             ffebld incr;
 252             ffelexToken incr_token;
 253           }
 254         R819A;
 255         struct
 256           {
 257             mallocPool pool;
 258             ffestw block;
 259             ffelab label;
 260             ffebld expr;
 261           }
 262         R819B;
 263         struct
 264           {
 265             ffestw block;
 266           }
 267         R834;
 268         struct
 269           {
 270             ffestw block;
 271           }
 272         R835;
 273         struct
 274           {
 275             ffelab label;
 276           }
 277         R836;
 278         struct
 279           {
 280             mallocPool pool;
 281             ffelab *labels;
 282             int count;
 283             ffebld expr;
 284           }
 285         R837;
 286         struct
 287           {
 288             mallocPool pool;
 289             ffelab label;
 290             ffebld target;
 291           }
 292         R838;
 293         struct
 294           {
 295             mallocPool pool;
 296             ffebld target;
 297           }
 298         R839;
 299         struct
 300           {
 301             mallocPool pool;
 302             ffebld expr;
 303             ffelab neg;
 304             ffelab zero;
 305             ffelab pos;
 306           }
 307         R840;
 308         struct
 309           {
 310             mallocPool pool;
 311             ffebld expr;
 312           }
 313         R842;
 314         struct
 315           {
 316             mallocPool pool;
 317             ffebld expr;
 318           }
 319         R843;
 320         struct
 321           {
 322             mallocPool pool;
 323             ffestpOpenStmt *params;
 324           }
 325         R904;
 326         struct
 327           {
 328             mallocPool pool;
 329             ffestpCloseStmt *params;
 330           }
 331         R907;
 332         struct
 333           {
 334             mallocPool pool;
 335             ffestpReadStmt *params;
 336             bool only_format;
 337             ffestvUnit unit;
 338             ffestvFormat format;
 339             bool rec;
 340             bool key;
 341             ffestdExprItem_ list;
 342           }
 343         R909;
 344         struct
 345           {
 346             mallocPool pool;
 347             ffestpWriteStmt *params;
 348             ffestvUnit unit;
 349             ffestvFormat format;
 350             bool rec;
 351             ffestdExprItem_ list;
 352           }
 353         R910;
 354         struct
 355           {
 356             mallocPool pool;
 357             ffestpPrintStmt *params;
 358             ffestvFormat format;
 359             ffestdExprItem_ list;
 360           }
 361         R911;
 362         struct
 363           {
 364             mallocPool pool;
 365             ffestpBeruStmt *params;
 366           }
 367         R919;
 368         struct
 369           {
 370             mallocPool pool;
 371             ffestpBeruStmt *params;
 372           }
 373         R920;
 374         struct
 375           {
 376             mallocPool pool;
 377             ffestpBeruStmt *params;
 378           }
 379         R921;
 380         struct
 381           {
 382             mallocPool pool;
 383             ffestpInquireStmt *params;
 384             bool by_file;
 385           }
 386         R923A;
 387         struct
 388           {
 389             mallocPool pool;
 390             ffestpInquireStmt *params;
 391             ffestdExprItem_ list;
 392           }
 393         R923B;
 394         struct
 395           {
 396             ffestsHolder str;
 397           }
 398         R1001;
 399         struct
 400           {
 401             mallocPool pool;
 402             ffebld expr;
 403           }
 404         R1212;
 405         struct
 406           {
 407             ffesymbol entry;
 408             int entrynum;
 409           }
 410         R1226;
 411         struct
 412           {
 413             mallocPool pool;
 414             ffestw block;
 415             ffebld expr;
 416           }
 417         R1227;
 418 #if FFESTR_VXT
 419         struct
 420           {
 421             mallocPool pool;
 422             ffestpRewriteStmt *params;
 423             ffestvFormat format;
 424             ffestdExprItem_ list;
 425           }
 426         V018;
 427         struct
 428           {
 429             mallocPool pool;
 430             ffestpAcceptStmt *params;
 431             ffestvFormat format;
 432             ffestdExprItem_ list;
 433           }
 434         V019;
 435 #endif
 436         struct
 437           {
 438             mallocPool pool;
 439             ffestpTypeStmt *params;
 440             ffestvFormat format;
 441             ffestdExprItem_ list;
 442           }
 443         V020;
 444 #if FFESTR_VXT
 445         struct
 446           {
 447             mallocPool pool;
 448             ffestpDeleteStmt *params;
 449           }
 450         V021;
 451         struct
 452           {
 453             mallocPool pool;
 454             ffestpBeruStmt *params;
 455           }
 456         V022;
 457         struct
 458           {
 459             mallocPool pool;
 460             ffestpVxtcodeStmt *params;
 461             ffestdExprItem_ list;
 462           }
 463         V023;
 464         struct
 465           {
 466             mallocPool pool;
 467             ffestpVxtcodeStmt *params;
 468             ffestdExprItem_ list;
 469           }
 470         V024;
 471         struct
 472           {
 473             ffebld u;
 474             ffebld m;
 475             ffebld n;
 476             ffebld asv;
 477           }
 478         V025item;
 479         struct
 480           {
 481             mallocPool pool;
 482           } V025finish;
 483         struct
 484           {
 485             mallocPool pool;
 486             ffestpFindStmt *params;
 487           }
 488         V026;
 489 #endif
 490       }
 491     u;
 492   };
 493
 494 #endif
 495
 496 /* Static objects accessed by functions in this module. */
 497
 498 static ffestdStatelet_ ffestd_statelet_ = FFESTD_stateletSIMPLE_;
 499 static int ffestd_block_level_ = 0;     /* Block level for reachableness. */
 500 static bool ffestd_is_reachable_;       /* Is the current stmt reachable?  */
 501 static ffelab ffestd_label_formatdef_ = NULL;
 502 #if FFECOM_TWOPASS
 503 static ffestdExprItem_ *ffestd_expr_list_;
 504 static struct
 505   {
 506     ffestdStmt_ first;
 507     ffestdStmt_ last;
 508   }
 509
 510 ffestd_stmt_list_
 511 =
 512 {
 513   NULL, NULL
 514 };
 515
 516 #endif
 517 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 518 static int ffestd_2pass_entrypoints_ = 0;       /* # ENTRY statements
 519                                                    pending. */
 520 #endif
 521
 522 /* Static functions (internal). */
 523
 524 #if FFECOM_TWOPASS
 525 static void ffestd_stmt_append_ (ffestdStmt_ stmt);
 526 static ffestdStmt_ ffestd_stmt_new_ (ffestdStmtId_ id);
 527 static void ffestd_stmt_pass_ (void);
 528 #endif
 529 #if FFESTD_COPY_EASY_ && FFECOM_TWOPASS
 530 static ffestpInquireStmt *ffestd_subr_copy_easy_ (ffestpInquireIx max);
 531 #endif
 532 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 533 static void ffestd_subr_vxt_ (void);
 534 #endif
 535 #if FFESTR_F90
 536 static void ffestd_subr_f90_ (void);
 537 #endif
 538 static void ffestd_subr_labels_ (bool unexpected);
 539 static void ffestd_R1001dump_ (ffests s, ffesttFormatList list);
 540 static void ffestd_R1001dump_1005_1_ (ffests s, ffesttFormatList f,
 541                                       const char *string);
 542 static void ffestd_R1001dump_1005_2_ (ffests s, ffesttFormatList f,
 543                                       const char *string);
 544 static void ffestd_R1001dump_1005_3_ (ffests s, ffesttFormatList f,
 545                                       const char *string);
 546 static void ffestd_R1001dump_1005_4_ (ffests s, ffesttFormatList f,
 547                                       const char *string);
 548 static void ffestd_R1001dump_1005_5_ (ffests s, ffesttFormatList f,
 549                                       const char *string);
 550 static void ffestd_R1001dump_1010_1_ (ffests s, ffesttFormatList f,
 551                                       const char *string);
 552 static void ffestd_R1001dump_1010_2_ (ffests s, ffesttFormatList f,
 553                                       const char *string);
 554 static void ffestd_R1001dump_1010_3_ (ffests s, ffesttFormatList f,
 555                                       const char *string);
 556 static void ffestd_R1001dump_1010_4_ (ffests s, ffesttFormatList f,
 557                                       const char *string);
 558 static void ffestd_R1001dump_1010_5_ (ffests s, ffesttFormatList f,
 559                                       const char *string);
 560 static void ffestd_R1001error_ (ffesttFormatList f);
 561 static void ffestd_R1001rtexpr_ (ffests s, ffesttFormatList f, ffebld expr);
 562
 563 /* Internal macros. */
 564
 565 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 566 #define ffestd_subr_line_now_()                                        \
 567   ffeste_set_line (ffelex_token_where_filename (ffesta_tokens[0]), \
 568                    ffelex_token_where_filelinenum (ffesta_tokens[0]))
 569 #define ffestd_subr_line_restore_(s) \
 570   ffeste_set_line ((s)->filename, (s)->filelinenum)
 571 #define ffestd_subr_line_save_(s)                                          \
 572   ((s)->filename = ffelex_token_where_filename (ffesta_tokens[0]),         \
 573    (s)->filelinenum = ffelex_token_where_filelinenum (ffesta_tokens[0]))
 574 #else
 575 #define ffestd_subr_line_now_()
 576 #if FFECOM_TWOPASS
 577 #define ffestd_subr_line_restore_(s)
 578 #define ffestd_subr_line_save_(s)
 579 #endif  /* FFECOM_TWOPASS */
 580 #endif  /* FFECOM_targetCURRENT != FFECOM_targetGCC */
 581 #define ffestd_check_simple_() \
 582       assert(ffestd_statelet_ == FFESTD_stateletSIMPLE_)
 583 #define ffestd_check_start_() \
 584       assert(ffestd_statelet_ == FFESTD_stateletSIMPLE_); \
 585       ffestd_statelet_ = FFESTD_stateletATTRIB_
 586 #define ffestd_check_attrib_() \
 587       assert(ffestd_statelet_ == FFESTD_stateletATTRIB_)
 588 #define ffestd_check_item_() \
 589       assert(ffestd_statelet_ == FFESTD_stateletATTRIB_  \
 590             || ffestd_statelet_ == FFESTD_stateletITEM_); \
 591       ffestd_statelet_ = FFESTD_stateletITEM_
 592 #define ffestd_check_item_startvals_() \
 593       assert(ffestd_statelet_ == FFESTD_stateletATTRIB_  \
 594             || ffestd_statelet_ == FFESTD_stateletITEM_); \
 595       ffestd_statelet_ = FFESTD_stateletITEMVALS_
 596 #define ffestd_check_item_value_() \
 597       assert(ffestd_statelet_ == FFESTD_stateletITEMVALS_)
 598 #define ffestd_check_item_endvals_() \
 599       assert(ffestd_statelet_ == FFESTD_stateletITEMVALS_); \
 600       ffestd_statelet_ = FFESTD_stateletITEM_
 601 #define ffestd_check_finish_() \
 602       assert(ffestd_statelet_ == FFESTD_stateletATTRIB_  \
 603             || ffestd_statelet_ == FFESTD_stateletITEM_); \
 604       ffestd_statelet_ = FFESTD_stateletSIMPLE_
 605
 606 #if FFESTD_COPY_EASY_ && FFECOM_TWOPASS
 607 #define ffestd_subr_copy_accept_() (ffestpAcceptStmt *) \
 608       ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_acceptix)
 609 #define ffestd_subr_copy_beru_() (ffestpBeruStmt *) \
 610       ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_beruix)
 611 #define ffestd_subr_copy_close_() (ffestpCloseStmt *) \
 612       ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_closeix)
 613 #define ffestd_subr_copy_delete_() (ffestpDeleteStmt *) \
 614       ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_deleteix)
 615 #define ffestd_subr_copy_find_() (ffestpFindStmt *) \
 616       ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_findix)
 617 #define ffestd_subr_copy_inquire_() (ffestpInquireStmt *) \
 618       ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_inquireix)
 619 #define ffestd_subr_copy_open_() (ffestpOpenStmt *) \
 620       ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_openix)
 621 #define ffestd_subr_copy_print_() (ffestpPrintStmt *) \
 622       ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_printix)
 623 #define ffestd_subr_copy_read_() (ffestpReadStmt *) \
 624       ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_readix)
 625 #define ffestd_subr_copy_rewrite_() (ffestpRewriteStmt *) \
 626       ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_rewriteix)
 627 #define ffestd_subr_copy_type_() (ffestpTypeStmt *) \
 628       ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_typeix)
 629 #define ffestd_subr_copy_vxtcode_() (ffestpVxtcodeStmt *) \
 630       ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_vxtcodeix)
 631 #define ffestd_subr_copy_write_() (ffestpWriteStmt *) \
 632       ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_writeix)
 633 #endif
 634 \f
 635 /* ffestd_stmt_append_ -- Append statement to end of stmt list
 636
 637    ffestd_stmt_append_(ffestd_stmt_new_(FFESTD_stmtidR737A_));  */
 638
 639 #if FFECOM_TWOPASS
 640 static void
 641 ffestd_stmt_append_ (ffestdStmt_ stmt)
 642 {
 643   stmt->next = (ffestdStmt_) &ffestd_stmt_list_.first;
 644   stmt->previous = ffestd_stmt_list_.last;
 645   stmt->next->previous = stmt;
 646   stmt->previous->next = stmt;
 647 }
 648
 649 #endif
 650 /* ffestd_stmt_new_ -- Make new statement with given id
 651
 652    ffestdStmt_ stmt;
 653    stmt = ffestd_stmt_new_(FFESTD_stmtidR737A_);  */
 654
 655 #if FFECOM_TWOPASS
 656 static ffestdStmt_
 657 ffestd_stmt_new_ (ffestdStmtId_ id)
 658 {
 659   ffestdStmt_ stmt;
 660
 661   stmt = malloc_new_kp (ffe_pool_any_unit (), "ffestdStmt_", sizeof (*stmt));
 662   stmt->id = id;
 663   return stmt;
 664 }
 665
 666 #endif
 667 /* ffestd_stmt_pass_ -- Pass all statements on list to ffeste
 668
 669    ffestd_stmt_pass_();  */
 670
 671 #if FFECOM_TWOPASS
 672 static void
 673 ffestd_stmt_pass_ ()
 674 {
 675   ffestdStmt_ stmt;
 676   ffestdExprItem_ expr;         /* For traversing lists. */
 677   bool okay = (TREE_CODE (current_function_decl) != ERROR_MARK);
 678
 679 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 680   if ((ffestd_2pass_entrypoints_ != 0) && okay)
 681     {
 682       tree which = ffecom_which_entrypoint_decl ();
 683       tree value;
 684       tree label;
 685       int pushok;
 686       int ents = ffestd_2pass_entrypoints_;
 687       tree duplicate;
 688
 689       expand_start_case (0, which, TREE_TYPE (which), "entrypoint dispatch");
 690       push_momentary ();
 691
 692       stmt = ffestd_stmt_list_.first;
 693       do
 694         {
 695           while (stmt->id != FFESTD_stmtidR1226_)
 696             stmt = stmt->next;
 697
 698           if (stmt->u.R1226.entry != NULL)
 699             {
 700               value = build_int_2 (stmt->u.R1226.entrynum, 0);
 701               /* Yes, we really want to build a null LABEL_DECL here and not
 702                  put it on any list.  That's what pushcase wants, so that's
 703                  what it gets!  */
 704               label = build_decl (LABEL_DECL, NULL_TREE, NULL_TREE);
 705
 706               pushok = pushcase (value, convert, label, &duplicate);
 707               assert (pushok == 0);
 708
 709               label = ffecom_temp_label ();
 710               TREE_USED (label) = 1;
 711               expand_goto (label);
 712               clear_momentary ();
 713
 714               ffesymbol_hook (stmt->u.R1226.entry).length_tree = label;
 715             }
 716           stmt = stmt->next;
 717         }
 718       while (--ents != 0);
 719
 720       pop_momentary ();
 721       expand_end_case (which);
 722       clear_momentary ();
 723     }
 724 #endif
 725
 726   for (stmt = ffestd_stmt_list_.first;
 727        stmt != (ffestdStmt_) &ffestd_stmt_list_.first;
 728        stmt = stmt->next)
 729     {
 730       switch (stmt->id)
 731         {
 732         case FFESTD_stmtidENDDOLOOP_:
 733           ffestd_subr_line_restore_ (stmt);
 734           if (okay)
 735             ffeste_do (stmt->u.enddoloop.block);
 736           ffestw_kill (stmt->u.enddoloop.block);
 737           break;
 738
 739         case FFESTD_stmtidENDLOGIF_:
 740           ffestd_subr_line_restore_ (stmt);
 741           if (okay)
 742             ffeste_end_R807 ();
 743           break;
 744
 745         case FFESTD_stmtidEXECLABEL_:
 746           if (okay)
 747             ffeste_labeldef_branch (stmt->u.execlabel.label);
 748           break;
 749
 750         case FFESTD_stmtidFORMATLABEL_:
 751           if (okay)
 752             ffeste_labeldef_format (stmt->u.formatlabel.label);
 753           break;
 754
 755         case FFESTD_stmtidR737A_:
 756           ffestd_subr_line_restore_ (stmt);
 757           if (okay)
 758             ffeste_R737A (stmt->u.R737A.dest, stmt->u.R737A.source);
 759           malloc_pool_kill (stmt->u.R737A.pool);
 760           break;
 761
 762         case FFESTD_stmtidR803_:
 763           ffestd_subr_line_restore_ (stmt);
 764           if (okay)
 765             ffeste_R803 (stmt->u.R803.block, stmt->u.R803.expr);
 766           malloc_pool_kill (stmt->u.R803.pool);
 767           break;
 768
 769         case FFESTD_stmtidR804_:
 770           ffestd_subr_line_restore_ (stmt);
 771           if (okay)
 772             ffeste_R804 (stmt->u.R803.block, stmt->u.R804.expr);
 773           malloc_pool_kill (stmt->u.R804.pool);
 774           break;
 775
 776         case FFESTD_stmtidR805_:
 777           ffestd_subr_line_restore_ (stmt);
 778           if (okay)
 779             ffeste_R805 (stmt->u.R803.block);
 780           break;
 781
 782         case FFESTD_stmtidR806_:
 783           ffestd_subr_line_restore_ (stmt);
 784           if (okay)
 785             ffeste_R806 (stmt->u.R806.block);
 786           ffestw_kill (stmt->u.R806.block);
 787           break;
 788
 789         case FFESTD_stmtidR807_:
 790           ffestd_subr_line_restore_ (stmt);
 791           if (okay)
 792             ffeste_R807 (stmt->u.R807.expr);
 793           malloc_pool_kill (stmt->u.R807.pool);
 794           break;
 795
 796         case FFESTD_stmtidR809_:
 797           ffestd_subr_line_restore_ (stmt);
 798           if (okay)
 799             ffeste_R809 (stmt->u.R809.block, stmt->u.R809.expr);
 800           malloc_pool_kill (stmt->u.R809.pool);
 801           break;
 802
 803         case FFESTD_stmtidR810_:
 804           ffestd_subr_line_restore_ (stmt);
 805           if (okay)
 806             ffeste_R810 (stmt->u.R810.block, stmt->u.R810.casenum);
 807           malloc_pool_kill (stmt->u.R810.pool);
 808           break;
 809
 810         case FFESTD_stmtidR811_:
 811           ffestd_subr_line_restore_ (stmt);
 812           if (okay)
 813             ffeste_R811 (stmt->u.R811.block);
 814           malloc_pool_kill (ffestw_select (stmt->u.R811.block)->pool);
 815           ffestw_kill (stmt->u.R811.block);
 816           break;
 817
 818         case FFESTD_stmtidR819A_:
 819           ffestd_subr_line_restore_ (stmt);
 820           if (okay)
 821             ffeste_R819A (stmt->u.R819A.block, stmt->u.R819A.label,
 822                           stmt->u.R819A.var,
 823                           stmt->u.R819A.start, stmt->u.R819A.start_token,
 824                           stmt->u.R819A.end, stmt->u.R819A.end_token,
 825                           stmt->u.R819A.incr, stmt->u.R819A.incr_token);
 826           ffelex_token_kill (stmt->u.R819A.start_token);
 827           ffelex_token_kill (stmt->u.R819A.end_token);
 828           if (stmt->u.R819A.incr_token != NULL)
 829             ffelex_token_kill (stmt->u.R819A.incr_token);
 830           malloc_pool_kill (stmt->u.R819A.pool);
 831           break;
 832
 833         case FFESTD_stmtidR819B_:
 834           ffestd_subr_line_restore_ (stmt);
 835           if (okay)
 836             ffeste_R819B (stmt->u.R819B.block, stmt->u.R819B.label,
 837                           stmt->u.R819B.expr);
 838           malloc_pool_kill (stmt->u.R819B.pool);
 839           break;
 840
 841         case FFESTD_stmtidR825_:
 842           ffestd_subr_line_restore_ (stmt);
 843           if (okay)
 844             ffeste_R825 ();
 845           break;
 846
 847         case FFESTD_stmtidR834_:
 848           ffestd_subr_line_restore_ (stmt);
 849           if (okay)
 850             ffeste_R834 (stmt->u.R834.block);
 851           break;
 852
 853         case FFESTD_stmtidR835_:
 854           ffestd_subr_line_restore_ (stmt);
 855           if (okay)
 856             ffeste_R835 (stmt->u.R835.block);
 857           break;
 858
 859         case FFESTD_stmtidR836_:
 860           ffestd_subr_line_restore_ (stmt);
 861           if (okay)
 862             ffeste_R836 (stmt->u.R836.label);
 863           break;
 864
 865         case FFESTD_stmtidR837_:
 866           ffestd_subr_line_restore_ (stmt);
 867           if (okay)
 868             ffeste_R837 (stmt->u.R837.labels, stmt->u.R837.count,
 869                          stmt->u.R837.expr);
 870           malloc_pool_kill (stmt->u.R837.pool);
 871           break;
 872
 873         case FFESTD_stmtidR838_:
 874           ffestd_subr_line_restore_ (stmt);
 875           if (okay)
 876             ffeste_R838 (stmt->u.R838.label, stmt->u.R838.target);
 877           malloc_pool_kill (stmt->u.R838.pool);
 878           break;
 879
 880         case FFESTD_stmtidR839_:
 881           ffestd_subr_line_restore_ (stmt);
 882           if (okay)
 883             ffeste_R839 (stmt->u.R839.target);
 884           malloc_pool_kill (stmt->u.R839.pool);
 885           break;
 886
 887         case FFESTD_stmtidR840_:
 888           ffestd_subr_line_restore_ (stmt);
 889           if (okay)
 890             ffeste_R840 (stmt->u.R840.expr, stmt->u.R840.neg, stmt->u.R840.zero,
 891                          stmt->u.R840.pos);
 892           malloc_pool_kill (stmt->u.R840.pool);
 893           break;
 894
 895         case FFESTD_stmtidR841_:
 896           ffestd_subr_line_restore_ (stmt);
 897           if (okay)
 898             ffeste_R841 ();
 899           break;
 900
 901         case FFESTD_stmtidR842_:
 902           ffestd_subr_line_restore_ (stmt);
 903           if (okay)
 904             ffeste_R842 (stmt->u.R842.expr);
 905           if (stmt->u.R842.pool != NULL)
 906             malloc_pool_kill (stmt->u.R842.pool);
 907           break;
 908
 909         case FFESTD_stmtidR843_:
 910           ffestd_subr_line_restore_ (stmt);
 911           if (okay)
 912             ffeste_R843 (stmt->u.R843.expr);
 913           malloc_pool_kill (stmt->u.R843.pool);
 914           break;
 915
 916         case FFESTD_stmtidR904_:
 917           ffestd_subr_line_restore_ (stmt);
 918           if (okay)
 919             ffeste_R904 (stmt->u.R904.params);
 920           malloc_pool_kill (stmt->u.R904.pool);
 921           break;
 922
 923         case FFESTD_stmtidR907_:
 924           ffestd_subr_line_restore_ (stmt);
 925           if (okay)
 926             ffeste_R907 (stmt->u.R907.params);
 927           malloc_pool_kill (stmt->u.R907.pool);
 928           break;
 929
 930         case FFESTD_stmtidR909_:
 931           ffestd_subr_line_restore_ (stmt);
 932           if (okay)
 933             ffeste_R909_start (stmt->u.R909.params, stmt->u.R909.only_format,
 934                                stmt->u.R909.unit, stmt->u.R909.format,
 935                                stmt->u.R909.rec, stmt->u.R909.key);
 936           for (expr = stmt->u.R909.list; expr != NULL; expr = expr->next)
 937             {
 938               if (okay)
 939                 ffeste_R909_item (expr->expr, expr->token);
 940               ffelex_token_kill (expr->token);
 941             }
 942           if (okay)
 943             ffeste_R909_finish ();
 944           malloc_pool_kill (stmt->u.R909.pool);
 945           break;
 946
 947         case FFESTD_stmtidR910_:
 948           ffestd_subr_line_restore_ (stmt);
 949           if (okay)
 950             ffeste_R910_start (stmt->u.R910.params, stmt->u.R910.unit,
 951                                stmt->u.R910.format, stmt->u.R910.rec);
 952           for (expr = stmt->u.R910.list; expr != NULL; expr = expr->next)
 953             {
 954               if (okay)
 955                 ffeste_R910_item (expr->expr, expr->token);
 956               ffelex_token_kill (expr->token);
 957             }
 958           if (okay)
 959             ffeste_R910_finish ();
 960           malloc_pool_kill (stmt->u.R910.pool);
 961           break;
 962
 963         case FFESTD_stmtidR911_:
 964           ffestd_subr_line_restore_ (stmt);
 965           if (okay)
 966             ffeste_R911_start (stmt->u.R911.params, stmt->u.R911.format);
 967           for (expr = stmt->u.R911.list; expr != NULL; expr = expr->next)
 968             {
 969               if (okay)
 970                 ffeste_R911_item (expr->expr, expr->token);
 971               ffelex_token_kill (expr->token);
 972             }
 973           if (okay)
 974             ffeste_R911_finish ();
 975           malloc_pool_kill (stmt->u.R911.pool);
 976           break;
 977
 978         case FFESTD_stmtidR919_:
 979           ffestd_subr_line_restore_ (stmt);
 980           if (okay)
 981             ffeste_R919 (stmt->u.R919.params);
 982           malloc_pool_kill (stmt->u.R919.pool);
 983           break;
 984
 985         case FFESTD_stmtidR920_:
 986           ffestd_subr_line_restore_ (stmt);
 987           if (okay)
 988             ffeste_R920 (stmt->u.R920.params);
 989           malloc_pool_kill (stmt->u.R920.pool);
 990           break;
 991
 992         case FFESTD_stmtidR921_:
 993           ffestd_subr_line_restore_ (stmt);
 994           if (okay)
 995             ffeste_R921 (stmt->u.R921.params);
 996           malloc_pool_kill (stmt->u.R921.pool);
 997           break;
 998
 999         case FFESTD_stmtidR923A_:
1000           ffestd_subr_line_restore_ (stmt);
1001           if (okay)
1002             ffeste_R923A (stmt->u.R923A.params, stmt->u.R923A.by_file);
1003           malloc_pool_kill (stmt->u.R923A.pool);
1004           break;
1005
1006         case FFESTD_stmtidR923B_:
1007           ffestd_subr_line_restore_ (stmt);
1008           if (okay)
1009             ffeste_R923B_start (stmt->u.R923B.params);
1010           for (expr = stmt->u.R923B.list; expr != NULL; expr = expr->next)
1011             {
1012               if (okay)
1013                 ffeste_R923B_item (expr->expr);
1014             }
1015           if (okay)
1016             ffeste_R923B_finish ();
1017           malloc_pool_kill (stmt->u.R923B.pool);
1018           break;
1019
1020         case FFESTD_stmtidR1001_:
1021           if (okay)
1022             ffeste_R1001 (&stmt->u.R1001.str);
1023           ffests_kill (&stmt->u.R1001.str);
1024           break;
1025
1026         case FFESTD_stmtidR1103_:
1027           if (okay)
1028             ffeste_R1103 ();
1029           break;
1030
1031         case FFESTD_stmtidR1112_:
1032           if (okay)
1033             ffeste_R1112 ();
1034           break;
1035
1036         case FFESTD_stmtidR1212_:
1037           ffestd_subr_line_restore_ (stmt);
1038           if (okay)
1039             ffeste_R1212 (stmt->u.R1212.expr);
1040           malloc_pool_kill (stmt->u.R1212.pool);
1041           break;
1042
1043         case FFESTD_stmtidR1221_:
1044           if (okay)
1045             ffeste_R1221 ();
1046           break;
1047
1048         case FFESTD_stmtidR1225_:
1049           if (okay)
1050             ffeste_R1225 ();
1051           break;
1052
1053         case FFESTD_stmtidR1226_:
1054           ffestd_subr_line_restore_ (stmt);
1055           if (stmt->u.R1226.entry != NULL)
1056             {
1057               if (okay)
1058                 ffeste_R1226 (stmt->u.R1226.entry);
1059             }
1060           break;
1061
1062         case FFESTD_stmtidR1227_:
1063           ffestd_subr_line_restore_ (stmt);
1064           if (okay)
1065             ffeste_R1227 (stmt->u.R1227.block, stmt->u.R1227.expr);
1066           malloc_pool_kill (stmt->u.R1227.pool);
1067           break;
1068
1069 #if FFESTR_VXT
1070         case FFESTD_stmtidV018_:
1071           ffestd_subr_line_restore_ (stmt);
1072           if (okay)
1073             ffeste_V018_start (stmt->u.V018.params, stmt->u.V018.format);
1074           for (expr = stmt->u.V018.list; expr != NULL; expr = expr->next)
1075             {
1076               if (okay)
1077                 ffeste_V018_item (expr->expr);
1078             }
1079           if (okay)
1080             ffeste_V018_finish ();
1081           malloc_pool_kill (stmt->u.V018.pool);
1082           break;
1083
1084         case FFESTD_stmtidV019_:
1085           ffestd_subr_line_restore_ (stmt);
1086           if (okay)
1087             ffeste_V019_start (stmt->u.V019.params, stmt->u.V019.format);
1088           for (expr = stmt->u.V019.list; expr != NULL; expr = expr->next)
1089             {
1090               if (okay)
1091                 ffeste_V019_item (expr->expr);
1092             }
1093           if (okay)
1094             ffeste_V019_finish ();
1095           malloc_pool_kill (stmt->u.V019.pool);
1096           break;
1097 #endif
1098
1099         case FFESTD_stmtidV020_:
1100           ffestd_subr_line_restore_ (stmt);
1101           if (okay)
1102             ffeste_V020_start (stmt->u.V020.params, stmt->u.V020.format);
1103           for (expr = stmt->u.V020.list; expr != NULL; expr = expr->next)
1104             {
1105               if (okay)
1106                 ffeste_V020_item (expr->expr);
1107             }
1108           if (okay)
1109             ffeste_V020_finish ();
1110           malloc_pool_kill (stmt->u.V020.pool);
1111           break;
1112
1113 #if FFESTR_VXT
1114         case FFESTD_stmtidV021_:
1115           ffestd_subr_line_restore_ (stmt);
1116           if (okay)
1117             ffeste_V021 (stmt->u.V021.params);
1118           malloc_pool_kill (stmt->u.V021.pool);
1119           break;
1120
1121         case FFESTD_stmtidV023_:
1122           ffestd_subr_line_restore_ (stmt);
1123           if (okay)
1124             ffeste_V023_start (stmt->u.V023.params);
1125           for (expr = stmt->u.V023.list; expr != NULL; expr = expr->next)
1126             {
1127               if (okay)
1128                 ffeste_V023_item (expr->expr);
1129             }
1130           if (okay)
1131             ffeste_V023_finish ();
1132           malloc_pool_kill (stmt->u.V023.pool);
1133           break;
1134
1135         case FFESTD_stmtidV024_:
1136           ffestd_subr_line_restore_ (stmt);
1137           if (okay)
1138             ffeste_V024_start (stmt->u.V024.params);
1139           for (expr = stmt->u.V024.list; expr != NULL; expr = expr->next)
1140             {
1141               if (okay)
1142                 ffeste_V024_item (expr->expr);
1143             }
1144           if (okay)
1145             ffeste_V024_finish ();
1146           malloc_pool_kill (stmt->u.V024.pool);
1147           break;
1148
1149         case FFESTD_stmtidV025start_:
1150           ffestd_subr_line_restore_ (stmt);
1151           if (okay)
1152             ffeste_V025_start ();
1153           break;
1154
1155         case FFESTD_stmtidV025item_:
1156           if (okay)
1157             ffeste_V025_item (stmt->u.V025item.u, stmt->u.V025item.m,
1158                               stmt->u.V025item.n, stmt->u.V025item.asv);
1159           break;
1160
1161         case FFESTD_stmtidV025finish_:
1162           if (okay)
1163             ffeste_V025_finish ();
1164           malloc_pool_kill (stmt->u.V025finish.pool);
1165           break;
1166
1167         case FFESTD_stmtidV026_:
1168           ffestd_subr_line_restore_ (stmt);
1169           if (okay)
1170             ffeste_V026 (stmt->u.V026.params);
1171           malloc_pool_kill (stmt->u.V026.pool);
1172           break;
1173 #endif
1174
1175         default:
1176           assert ("bad stmt->id" == NULL);
1177           break;
1178         }
1179     }
1180 }
1181
1182 #endif
1183 /* ffestd_subr_copy_easy_ -- Copy I/O statement data structure
1184
1185    ffestd_subr_copy_easy_();
1186
1187    Copies all data except tokens in the I/O data structure into a new
1188    structure that lasts as long as the output pool for the current
1189    statement.  Assumes that they are
1190    overlaid with each other (union) in stp.h and the typing
1191    and structure references assume (though not necessarily dangerous if
1192    FALSE) that INQUIRE has the most file elements.  */
1193
1194 #if FFESTD_COPY_EASY_ && FFECOM_TWOPASS
1195 static ffestpInquireStmt *
1196 ffestd_subr_copy_easy_ (ffestpInquireIx max)
1197 {
1198   ffestpInquireStmt *stmt;
1199   ffestpInquireIx ix;
1200
1201   stmt = (ffestpInquireStmt *) malloc_new_kp (ffesta_output_pool,
1202                                   "FFESTD easy", sizeof (ffestpFile) * max);
1203
1204   for (ix = 0; ix < max; ++ix)
1205     {
1206       if ((stmt->inquire_spec[ix].kw_or_val_present
1207            = ffestp_file.inquire.inquire_spec[ix].kw_or_val_present)
1208           && (stmt->inquire_spec[ix].value_present
1209               = ffestp_file.inquire.inquire_spec[ix].value_present))
1210         {
1211           if ((stmt->inquire_spec[ix].value_is_label
1212                = ffestp_file.inquire.inquire_spec[ix].value_is_label))
1213             stmt->inquire_spec[ix].u.label
1214               = ffestp_file.inquire.inquire_spec[ix].u.label;
1215           else
1216             stmt->inquire_spec[ix].u.expr
1217               = ffestp_file.inquire.inquire_spec[ix].u.expr;
1218         }
1219     }
1220
1221   return stmt;
1222 }
1223
1224 #endif
1225 /* ffestd_subr_labels_ -- Handle any undefined labels
1226
1227    ffestd_subr_labels_(FALSE);
1228
1229    For every undefined label, generate an error message and either define
1230    label as a FORMAT() statement (for FORMAT labels) or as a STOP statement
1231    (for all other labels).  */
1232
1233 static void
1234 ffestd_subr_labels_ (bool unexpected)
1235 {
1236   ffelab l;
1237   ffelabHandle h;
1238   ffelabNumber undef;
1239   ffesttFormatList f;
1240
1241   undef = ffelab_number () - ffestv_num_label_defines_;
1242
1243   for (h = ffelab_handle_first (); h != NULL; h = ffelab_handle_next (h))
1244     {
1245       l = ffelab_handle_target (h);
1246       if (ffewhere_line_is_unknown (ffelab_definition_line (l)))
1247         {                       /* Undefined label. */
1248           assert (!unexpected);
1249           assert (undef > 0);
1250           undef--;
1251           ffebad_start (FFEBAD_UNDEF_LABEL);
1252           if (ffelab_type (l) == FFELAB_typeLOOPEND)
1253             ffebad_here (0, ffelab_doref_line (l), ffelab_doref_column (l));
1254           else if (ffelab_type (l) != FFELAB_typeANY)
1255             ffebad_here (0, ffelab_firstref_line (l), ffelab_firstref_column (l));
1256           else if (!ffewhere_line_is_unknown (ffelab_firstref_line (l)))
1257             ffebad_here (0, ffelab_firstref_line (l), ffelab_firstref_column (l));
1258           else if (!ffewhere_line_is_unknown (ffelab_doref_line (l)))
1259             ffebad_here (0, ffelab_doref_line (l), ffelab_doref_column (l));
1260           else
1261             ffebad_here (0, ffelab_definition_line (l), ffelab_definition_column (l));
1262           ffebad_finish ();
1263
1264           switch (ffelab_type (l))
1265             {
1266             case FFELAB_typeFORMAT:
1267               ffelab_set_definition_line (l,
1268                               ffewhere_line_use (ffelab_firstref_line (l)));
1269               ffelab_set_definition_column (l,
1270                           ffewhere_column_use (ffelab_firstref_column (l)));
1271               ffestv_num_label_defines_++;
1272               f = ffestt_formatlist_create (NULL, NULL);
1273               ffestd_labeldef_format (l);
1274               ffestd_R1001 (f);
1275               ffestt_formatlist_kill (f);
1276               break;
1277
1278             case FFELAB_typeASSIGNABLE:
1279               ffelab_set_definition_line (l,
1280                               ffewhere_line_use (ffelab_firstref_line (l)));
1281               ffelab_set_definition_column (l,
1282                           ffewhere_column_use (ffelab_firstref_column (l)));
1283               ffestv_num_label_defines_++;
1284               ffelab_set_type (l, FFELAB_typeNOTLOOP);
1285               ffelab_set_blocknum (l, ffestw_blocknum (ffestw_stack_top ()));
1286               ffestd_labeldef_notloop (l);
1287               ffestd_R842 (NULL);
1288               break;
1289
1290             case FFELAB_typeNOTLOOP:
1291               ffelab_set_definition_line (l,
1292                               ffewhere_line_use (ffelab_firstref_line (l)));
1293               ffelab_set_definition_column (l,
1294                           ffewhere_column_use (ffelab_firstref_column (l)));
1295               ffestv_num_label_defines_++;
1296               ffelab_set_blocknum (l, ffestw_blocknum (ffestw_stack_top ()));
1297               ffestd_labeldef_notloop (l);
1298               ffestd_R842 (NULL);
1299               break;
1300
1301             default:
1302               assert ("bad label type" == NULL);
1303               /* Fall through. */
1304             case FFELAB_typeUNKNOWN:
1305             case FFELAB_typeANY:
1306               break;
1307             }
1308         }
1309     }
1310   ffelab_handle_done (h);
1311   assert (undef == 0);
1312 }
1313
1314 /* ffestd_subr_f90_ -- Report error about lack of full F90 support
1315
1316    ffestd_subr_f90_();  */
1317
1318 #if FFESTR_F90
1319 static void
1320 ffestd_subr_f90_ ()
1321 {
1322   ffebad_start (FFEBAD_F90);
1323   ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
1324                ffelex_token_where_column (ffesta_tokens[0]));
1325   ffebad_finish ();
1326 }
1327
1328 #endif
1329 /* ffestd_subr_vxt_ -- Report error about lack of full VXT support
1330
1331    ffestd_subr_vxt_();  */
1332
1333 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1334 static void
1335 ffestd_subr_vxt_ ()
1336 {
1337   ffebad_start (FFEBAD_VXT_UNSUPPORTED);
1338   ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
1339                ffelex_token_where_column (ffesta_tokens[0]));
1340   ffebad_finish ();
1341 }
1342
1343 #endif
1344 /* ffestd_begin_uses -- Start a bunch of USE statements
1345
1346    ffestd_begin_uses();
1347
1348    Invoked before handling the first USE statement in a block of one or
1349    more USE statements.  _end_uses_(bool ok) is invoked before handling
1350    the first statement after the block (there are no BEGIN USE and END USE
1351    statements, but the semantics of USE statements effectively requires
1352    handling them as a single block rather than one statement at a time).  */
1353
1354 void
1355 ffestd_begin_uses ()
1356 {
1357 #if FFECOM_targetCURRENT == FFECOM_targetFFE
1358   fputs ("; begin_uses\n", dmpout);
1359 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
1360 #else
1361 #error
1362 #endif
1363 }
1364
1365 /* ffestd_do -- End of statement following DO-term-stmt etc
1366
1367    ffestd_do(TRUE);
1368
1369    Also invoked by _labeldef_branch_finish_ (or, in cases
1370    of errors, other _labeldef_ functions) when the label definition is
1371    for a DO-target (LOOPEND) label, once per matching/outstanding DO
1372    block on the stack.  These cases invoke this function with ok==TRUE, so
1373    only forced stack popping (via ffestd_eof_()) invokes it with ok==FALSE.  */
1374
1375 void
1376 ffestd_do (bool ok UNUSED)
1377 {
1378 #if FFECOM_ONEPASS
1379   ffestd_subr_line_now_ ();
1380   ffeste_do (ffestw_stack_top ());
1381 #else
1382   {
1383     ffestdStmt_ stmt;
1384
1385     stmt = ffestd_stmt_new_ (FFESTD_stmtidENDDOLOOP_);
1386     ffestd_stmt_append_ (stmt);
1387     ffestd_subr_line_save_ (stmt);
1388     stmt->u.enddoloop.block = ffestw_stack_top ();
1389   }
1390 #endif
1391
1392   --ffestd_block_level_;
1393   assert (ffestd_block_level_ >= 0);
1394 }
1395
1396 /* ffestd_end_uses -- End a bunch of USE statements
1397
1398    ffestd_end_uses(TRUE);
1399
1400    ok==TRUE means simply not popping due to ffestd_eof_()
1401    being called, because there is no formal END USES statement in Fortran.  */
1402
1403 #if FFESTR_F90
1404 void
1405 ffestd_end_uses (bool ok)
1406 {
1407 #if FFECOM_targetCURRENT == FFECOM_targetFFE
1408   fputs ("; end_uses\n", dmpout);
1409 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
1410 #else
1411 #error
1412 #endif
1413 }
1414
1415 /* ffestd_end_R740 -- End a WHERE(-THEN)
1416
1417    ffestd_end_R740(TRUE);  */
1418
1419 void
1420 ffestd_end_R740 (bool ok)
1421 {
1422   return;                       /* F90. */
1423 }
1424
1425 #endif
1426 /* ffestd_end_R807 -- End of statement following logical IF
1427
1428    ffestd_end_R807(TRUE);
1429
1430    Applies ONLY to logical IF, not to IF-THEN.  For example, does not
1431    ffelex_token_kill the construct name for an IF-THEN block (the name
1432    field is invalid for logical IF).  ok==TRUE iff statement following
1433    logical IF (substatement) is valid; else, statement is invalid or
1434    stack forcibly popped due to ffestd_eof_().  */
1435
1436 void
1437 ffestd_end_R807 (bool ok UNUSED)
1438 {
1439 #if FFECOM_ONEPASS
1440   ffestd_subr_line_now_ ();
1441   ffeste_end_R807 ();
1442 #else
1443   {
1444     ffestdStmt_ stmt;
1445
1446     stmt = ffestd_stmt_new_ (FFESTD_stmtidENDLOGIF_);
1447     ffestd_stmt_append_ (stmt);
1448     ffestd_subr_line_save_ (stmt);
1449   }
1450 #endif
1451
1452   --ffestd_block_level_;
1453   assert (ffestd_block_level_ >= 0);
1454 }
1455
1456 /* ffestd_exec_begin -- Executable statements can start coming in now
1457
1458    ffestd_exec_begin();  */
1459
1460 void
1461 ffestd_exec_begin ()
1462 {
1463   ffecom_exec_transition ();
1464
1465 #if FFECOM_targetCURRENT == FFECOM_targetFFE
1466   fputs ("{ begin_exec\n", dmpout);
1467 #endif
1468
1469 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1470   if (ffestd_2pass_entrypoints_ != 0)
1471     {                           /* Process pending ENTRY statements now that
1472                                    info filled in. */
1473       ffestdStmt_ stmt;
1474       int ents = ffestd_2pass_entrypoints_;
1475
1476       stmt = ffestd_stmt_list_.first;
1477       do
1478         {
1479           while (stmt->id != FFESTD_stmtidR1226_)
1480             stmt = stmt->next;
1481
1482           if (!ffecom_2pass_advise_entrypoint (stmt->u.R1226.entry))
1483             {
1484               stmt->u.R1226.entry = NULL;
1485               --ffestd_2pass_entrypoints_;
1486             }
1487           stmt = stmt->next;
1488         }
1489       while (--ents != 0);
1490     }
1491 #endif
1492 }
1493
1494 /* ffestd_exec_end -- Executable statements can no longer come in now
1495
1496    ffestd_exec_end();  */
1497
1498 void
1499 ffestd_exec_end ()
1500 {
1501 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1502   int old_lineno = lineno;
1503   char *old_input_filename = input_filename;
1504 #endif
1505
1506   ffecom_end_transition ();
1507
1508 #if FFECOM_TWOPASS
1509   ffestd_stmt_pass_ ();
1510 #endif
1511
1512 #if FFECOM_targetCURRENT == FFECOM_targetFFE
1513   fputs ("} end_exec\n", dmpout);
1514   fputs ("> end_unit\n", dmpout);
1515 #endif
1516
1517 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1518   ffecom_finish_progunit ();
1519
1520   if (ffestd_2pass_entrypoints_ != 0)
1521     {
1522       int ents = ffestd_2pass_entrypoints_;
1523       ffestdStmt_ stmt = ffestd_stmt_list_.first;
1524
1525       do
1526         {
1527           while (stmt->id != FFESTD_stmtidR1226_)
1528             stmt = stmt->next;
1529
1530           if (stmt->u.R1226.entry != NULL)
1531             {
1532               ffestd_subr_line_restore_ (stmt);
1533               ffecom_2pass_do_entrypoint (stmt->u.R1226.entry);
1534             }
1535           stmt = stmt->next;
1536         }
1537       while (--ents != 0);
1538     }
1539
1540   ffestd_stmt_list_.first = NULL;
1541   ffestd_stmt_list_.last = NULL;
1542   ffestd_2pass_entrypoints_ = 0;
1543
1544   lineno = old_lineno;
1545   input_filename = old_input_filename;
1546 #endif
1547 }
1548
1549 /* ffestd_init_3 -- Initialize for any program unit
1550
1551    ffestd_init_3();  */
1552
1553 void
1554 ffestd_init_3 ()
1555 {
1556 #if FFECOM_TWOPASS
1557   ffestd_stmt_list_.first = (ffestdStmt_) &ffestd_stmt_list_.first;
1558   ffestd_stmt_list_.last = (ffestdStmt_) &ffestd_stmt_list_.first;
1559 #endif
1560 }
1561
1562 /* Generate "code" for "any" label def.  */
1563
1564 void
1565 ffestd_labeldef_any (ffelab label UNUSED)
1566 {
1567 #if FFECOM_targetCURRENT == FFECOM_targetFFE
1568   fprintf (dmpout, "; any_label_def %lu\n", ffelab_value (label));
1569 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
1570 #else
1571 #error
1572 #endif
1573 }
1574
1575 /* ffestd_labeldef_branch -- Generate "code" for branch label def
1576
1577    ffestd_labeldef_branch(label);  */
1578
1579 void
1580 ffestd_labeldef_branch (ffelab label)
1581 {
1582 #if FFECOM_ONEPASS
1583   ffeste_labeldef_branch (label);
1584 #else
1585   {
1586     ffestdStmt_ stmt;
1587
1588     stmt = ffestd_stmt_new_ (FFESTD_stmtidEXECLABEL_);
1589     ffestd_stmt_append_ (stmt);
1590     stmt->u.execlabel.label = label;
1591   }
1592 #endif
1593
1594   ffestd_is_reachable_ = TRUE;
1595 }
1596
1597 /* ffestd_labeldef_format -- Generate "code" for FORMAT label def
1598
1599    ffestd_labeldef_format(label);  */
1600
1601 void
1602 ffestd_labeldef_format (ffelab label)
1603 {
1604   ffestd_label_formatdef_ = label;
1605
1606 #if FFECOM_ONEPASS
1607   ffeste_labeldef_format (label);
1608 #else
1609   {
1610     ffestdStmt_ stmt;
1611
1612     stmt = ffestd_stmt_new_ (FFESTD_stmtidFORMATLABEL_);
1613 #if 0
1614     /* Don't bother with this.  See FORMAT statement.  */
1615     /* Prepend FORMAT label instead of appending it, so all the
1616        FORMAT label/statement pairs end up at the top of the list.
1617        This helps ensure all decls for a block (in the GBE) are
1618        known before any executable statements are generated.  */
1619     stmt->previous = (ffestdStmt_) &ffestd_stmt_list_.first;
1620     stmt->next = ffestd_stmt_list_.first;
1621     stmt->next->previous = stmt;
1622     stmt->previous->next = stmt;
1623 #else
1624     ffestd_stmt_append_ (stmt);
1625 #endif
1626     stmt->u.formatlabel.label = label;
1627   }
1628 #endif
1629 }
1630
1631 /* ffestd_labeldef_useless -- Generate "code" for useless label def
1632
1633    ffestd_labeldef_useless(label);  */
1634
1635 void
1636 ffestd_labeldef_useless (ffelab label UNUSED)
1637 {
1638 #if FFECOM_targetCURRENT == FFECOM_targetFFE
1639   fprintf (dmpout, "; useless_label_def %lu\n", ffelab_value (label));
1640 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
1641 #else
1642 #error
1643 #endif
1644 }
1645
1646 /* ffestd_R423A -- PRIVATE statement (in R422 derived-type statement)
1647
1648    ffestd_R423A();  */
1649
1650 #if FFESTR_F90
1651 void
1652 ffestd_R423A ()
1653 {
1654   ffestd_check_simple_ ();
1655
1656 #if FFECOM_targetCURRENT == FFECOM_targetFFE
1657   fputs ("* PRIVATE_derived_type\n", dmpout);
1658 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
1659 #else
1660 #error
1661 #endif
1662 }
1663
1664 /* ffestd_R423B -- SEQUENCE statement (in R422 derived-type-stmt)
1665
1666    ffestd_R423B();  */
1667
1668 void
1669 ffestd_R423B ()
1670 {
1671   ffestd_check_simple_ ();
1672
1673 #if FFECOM_targetCURRENT == FFECOM_targetFFE
1674   fputs ("* SEQUENCE_derived_type\n", dmpout);
1675 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
1676 #else
1677 #error
1678 #endif
1679 }
1680
1681 /* ffestd_R424 -- derived-TYPE-def statement
1682
1683    ffestd_R424(access_token,access_kw,name_token);
1684
1685    Handle a derived-type definition.  */
1686
1687 void
1688 ffestd_R424 (ffelexToken access, ffestrOther access_kw, ffelexToken name)
1689 {
1690   ffestd_check_simple_ ();
1691
1692   ffestd_subr_f90_ ();
1693   return;
1694
1695 #ifdef FFESTD_F90
1696   char *a;
1697
1698   if (access == NULL)
1699     fprintf (dmpout, "* TYPE %s\n", ffelex_token_text (name));
1700   else
1701     {
1702       switch (access_kw)
1703         {
1704         case FFESTR_otherPUBLIC:
1705           a = "PUBLIC";
1706           break;
1707
1708         case FFESTR_otherPRIVATE:
1709           a = "PRIVATE";
1710           break;
1711
1712         default:
1713           assert (FALSE);
1714         }
1715       fprintf (dmpout, "* TYPE,%s: %s\n", a, ffelex_token_text (name));
1716     }
1717 #endif
1718 }
1719
1720 /* ffestd_R425 -- End a TYPE
1721
1722    ffestd_R425(TRUE);  */
1723
1724 void
1725 ffestd_R425 (bool ok)
1726 {
1727 #if FFECOM_targetCURRENT == FFECOM_targetFFE
1728   fprintf (dmpout, "* END_TYPE %s\n", ffelex_token_text (ffestw_name (ffestw_stack_top ())));
1729 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
1730 #else
1731 #error
1732 #endif
1733 }
1734
1735 /* ffestd_R519_start -- INTENT statement list begin
1736
1737    ffestd_R519_start();
1738
1739    Verify that INTENT is valid here, and begin accepting items in the list.  */
1740
1741 void
1742 ffestd_R519_start (ffestrOther intent_kw)
1743 {
1744   ffestd_check_start_ ();
1745
1746   ffestd_subr_f90_ ();
1747   return;
1748
1749 #ifdef FFESTD_F90
1750   char *a;
1751
1752   switch (intent_kw)
1753     {
1754     case FFESTR_otherIN:
1755       a = "IN";
1756       break;
1757
1758     case FFESTR_otherOUT:
1759       a = "OUT";
1760       break;
1761
1762     case FFESTR_otherINOUT:
1763       a = "INOUT";
1764       break;
1765
1766     default:
1767       assert (FALSE);
1768     }
1769   fprintf (dmpout, "* INTENT (%s) ", a);
1770 #endif
1771 }
1772
1773 /* ffestd_R519_item -- INTENT statement for name
1774
1775    ffestd_R519_item(name_token);
1776
1777    Make sure name_token identifies a valid object to be INTENTed.  */
1778
1779 void
1780 ffestd_R519_item (ffelexToken name)
1781 {
1782   ffestd_check_item_ ();
1783
1784   return;                       /* F90. */
1785
1786 #ifdef FFESTD_F90
1787   fprintf (dmpout, "%s,", ffelex_token_text (name));
1788 #endif
1789 }
1790
1791 /* ffestd_R519_finish -- INTENT statement list complete
1792
1793    ffestd_R519_finish();
1794
1795    Just wrap up any local activities.  */
1796
1797 void
1798 ffestd_R519_finish ()
1799 {
1800   ffestd_check_finish_ ();
1801
1802   return;                       /* F90. */
1803
1804 #ifdef FFESTD_F90
1805   fputc ('\n', dmpout);
1806 #endif
1807 }
1808
1809 /* ffestd_R520_start -- OPTIONAL statement list begin
1810
1811    ffestd_R520_start();
1812
1813    Verify that OPTIONAL is valid here, and begin accepting items in the list.  */
1814
1815 void
1816 ffestd_R520_start ()
1817 {
1818   ffestd_check_start_ ();
1819
1820   ffestd_subr_f90_ ();
1821   return;
1822
1823 #ifdef FFESTD_F90
1824   fputs ("* OPTIONAL ", dmpout);
1825 #endif
1826 }
1827
1828 /* ffestd_R520_item -- OPTIONAL statement for name
1829
1830    ffestd_R520_item(name_token);
1831
1832    Make sure name_token identifies a valid object to be OPTIONALed.  */
1833
1834 void
1835 ffestd_R520_item (ffelexToken name)
1836 {
1837   ffestd_check_item_ ();
1838
1839   return;                       /* F90. */
1840
1841 #ifdef FFESTD_F90
1842   fprintf (dmpout, "%s,", ffelex_token_text (name));
1843 #endif
1844 }
1845
1846 /* ffestd_R520_finish -- OPTIONAL statement list complete
1847
1848    ffestd_R520_finish();
1849
1850    Just wrap up any local activities.  */
1851
1852 void
1853 ffestd_R520_finish ()
1854 {
1855   ffestd_check_finish_ ();
1856
1857   return;                       /* F90. */
1858
1859 #ifdef FFESTD_F90
1860   fputc ('\n', dmpout);
1861 #endif
1862 }
1863
1864 /* ffestd_R521A -- PUBLIC statement
1865
1866    ffestd_R521A();
1867
1868    Verify that PUBLIC is valid here.  */
1869
1870 void
1871 ffestd_R521A ()
1872 {
1873   ffestd_check_simple_ ();
1874
1875   ffestd_subr_f90_ ();
1876   return;
1877
1878 #ifdef FFESTD_F90
1879   fputs ("* PUBLIC\n", dmpout);
1880 #endif
1881 }
1882
1883 /* ffestd_R521Astart -- PUBLIC statement list begin
1884
1885    ffestd_R521Astart();
1886
1887    Verify that PUBLIC is valid here, and begin accepting items in the list.  */
1888
1889 void
1890 ffestd_R521Astart ()
1891 {
1892   ffestd_check_start_ ();
1893
1894   ffestd_subr_f90_ ();
1895   return;
1896
1897 #ifdef FFESTD_F90
1898   fputs ("* PUBLIC ", dmpout);
1899 #endif
1900 }
1901
1902 /* ffestd_R521Aitem -- PUBLIC statement for name
1903
1904    ffestd_R521Aitem(name_token);
1905
1906    Make sure name_token identifies a valid object to be PUBLICed.  */
1907
1908 void
1909 ffestd_R521Aitem (ffelexToken name)
1910 {
1911   ffestd_check_item_ ();
1912
1913   return;                       /* F90. */
1914
1915 #ifdef FFESTD_F90
1916   fprintf (dmpout, "%s,", ffelex_token_text (name));
1917 #endif
1918 }
1919
1920 /* ffestd_R521Afinish -- PUBLIC statement list complete
1921
1922    ffestd_R521Afinish();
1923
1924    Just wrap up any local activities.  */
1925
1926 void
1927 ffestd_R521Afinish ()
1928 {
1929   ffestd_check_finish_ ();
1930
1931   return;                       /* F90. */
1932
1933 #ifdef FFESTD_F90
1934   fputc ('\n', dmpout);
1935 #endif
1936 }
1937
1938 /* ffestd_R521B -- PRIVATE statement
1939
1940    ffestd_R521B();
1941
1942    Verify that PRIVATE is valid here (outside a derived-type statement).  */
1943
1944 void
1945 ffestd_R521B ()
1946 {
1947   ffestd_check_simple_ ();
1948
1949   ffestd_subr_f90_ ();
1950   return;
1951
1952 #ifdef FFESTD_F90
1953   fputs ("* PRIVATE_outside_of_R422_derived_type_def\n", dmpout);
1954 #endif
1955 }
1956
1957 /* ffestd_R521Bstart -- PRIVATE statement list begin
1958
1959    ffestd_R521Bstart();
1960
1961    Verify that PRIVATE is valid here, and begin accepting items in the list.  */
1962
1963 void
1964 ffestd_R521Bstart ()
1965 {
1966   ffestd_check_start_ ();
1967
1968   ffestd_subr_f90_ ();
1969   return;
1970
1971 #ifdef FFESTD_F90
1972   fputs ("* PRIVATE ", dmpout);
1973 #endif
1974 }
1975
1976 /* ffestd_R521Bitem -- PRIVATE statement for name
1977
1978    ffestd_R521Bitem(name_token);
1979
1980    Make sure name_token identifies a valid object to be PRIVATEed.  */
1981
1982 void
1983 ffestd_R521Bitem (ffelexToken name)
1984 {
1985   ffestd_check_item_ ();
1986
1987   return;                       /* F90. */
1988
1989 #ifdef FFESTD_F90
1990   fprintf (dmpout, "%s,", ffelex_token_text (name));
1991 #endif
1992 }
1993
1994 /* ffestd_R521Bfinish -- PRIVATE statement list complete
1995
1996    ffestd_R521Bfinish();
1997
1998    Just wrap up any local activities.  */
1999
2000 void
2001 ffestd_R521Bfinish ()
2002 {
2003   ffestd_check_finish_ ();
2004
2005   return;                       /* F90. */
2006
2007 #ifdef FFESTD_F90
2008   fputc ('\n', dmpout);
2009 #endif
2010 }
2011
2012 #endif
2013 /* ffestd_R522 -- SAVE statement with no list
2014
2015    ffestd_R522();
2016
2017    Verify that SAVE is valid here, and flag everything as SAVEd.  */
2018
2019 void
2020 ffestd_R522 ()
2021 {
2022   ffestd_check_simple_ ();
2023
2024 #if FFECOM_targetCURRENT == FFECOM_targetFFE
2025   fputs ("* SAVE_all\n", dmpout);
2026 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
2027 #else
2028 #error
2029 #endif
2030 }
2031
2032 /* ffestd_R522start -- SAVE statement list begin
2033
2034    ffestd_R522start();
2035
2036    Verify that SAVE is valid here, and begin accepting items in the list.  */
2037
2038 void
2039 ffestd_R522start ()
2040 {
2041   ffestd_check_start_ ();
2042
2043 #if FFECOM_targetCURRENT == FFECOM_targetFFE
2044   fputs ("* SAVE ", dmpout);
2045 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
2046 #else
2047 #error
2048 #endif
2049 }
2050
2051 /* ffestd_R522item_object -- SAVE statement for object-name
2052
2053    ffestd_R522item_object(name_token);
2054
2055    Make sure name_token identifies a valid object to be SAVEd.  */
2056
2057 void
2058 ffestd_R522item_object (ffelexToken name UNUSED)
2059 {
2060   ffestd_check_item_ ();
2061
2062 #if FFECOM_targetCURRENT == FFECOM_targetFFE
2063   fprintf (dmpout, "%s,", ffelex_token_text (name));
2064 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
2065 #else
2066 #error
2067 #endif
2068 }
2069
2070 /* ffestd_R522item_cblock -- SAVE statement for common-block-name
2071
2072    ffestd_R522item_cblock(name_token);
2073
2074    Make sure name_token identifies a valid common block to be SAVEd.  */
2075
2076 void
2077 ffestd_R522item_cblock (ffelexToken name UNUSED)
2078 {
2079   ffestd_check_item_ ();
2080
2081 #if FFECOM_targetCURRENT == FFECOM_targetFFE
2082   fprintf (dmpout, "/%s/,", ffelex_token_text (name));
2083 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
2084 #else
2085 #error
2086 #endif
2087 }
2088
2089 /* ffestd_R522finish -- SAVE statement list complete
2090
2091    ffestd_R522finish();
2092
2093    Just wrap up any local activities.  */
2094
2095 void
2096 ffestd_R522finish ()
2097 {
2098   ffestd_check_finish_ ();
2099
2100 #if FFECOM_targetCURRENT == FFECOM_targetFFE
2101   fputc ('\n', dmpout);
2102 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
2103 #else
2104 #error
2105 #endif
2106 }
2107
2108 /* ffestd_R524_start -- DIMENSION statement list begin
2109
2110    ffestd_R524_start(bool virtual);
2111
2112    Verify that DIMENSION is valid here, and begin accepting items in the list.  */
2113
2114 void
2115 ffestd_R524_start (bool virtual UNUSED)
2116 {
2117   ffestd_check_start_ ();
2118
2119 #if FFECOM_targetCURRENT == FFECOM_targetFFE
2120   if (virtual)
2121     fputs ("* VIRTUAL ", dmpout);       /* V028. */
2122   else
2123     fputs ("* DIMENSION ", dmpout);
2124 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
2125 #else
2126 #error
2127 #endif
2128 }
2129
2130 /* ffestd_R524_item -- DIMENSION statement for object-name
2131
2132    ffestd_R524_item(name_token,dim_list);
2133
2134    Make sure name_token identifies a valid object to be DIMENSIONd.  */
2135
2136 void
2137 ffestd_R524_item (ffelexToken name UNUSED, ffesttDimList dims UNUSED)
2138 {
2139   ffestd_check_item_ ();
2140
2141 #if FFECOM_targetCURRENT == FFECOM_targetFFE
2142   fputs (ffelex_token_text (name), dmpout);
2143   fputc ('(', dmpout);
2144   ffestt_dimlist_dump (dims);
2145   fputs ("),", dmpout);
2146 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
2147 #else
2148 #error
2149 #endif
2150 }
2151
2152 /* ffestd_R524_finish -- DIMENSION statement list complete
2153
2154    ffestd_R524_finish();
2155
2156    Just wrap up any local activities.  */
2157
2158 void
2159 ffestd_R524_finish ()
2160 {
2161   ffestd_check_finish_ ();
2162
2163 #if FFECOM_targetCURRENT == FFECOM_targetFFE
2164   fputc ('\n', dmpout);
2165 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
2166 #else
2167 #error
2168 #endif
2169 }
2170
2171 /* ffestd_R525_start -- ALLOCATABLE statement list begin
2172
2173    ffestd_R525_start();
2174
2175    Verify that ALLOCATABLE is valid here, and begin accepting items in the
2176    list.  */
2177
2178 #if FFESTR_F90
2179 void
2180 ffestd_R525_start ()
2181 {
2182   ffestd_check_start_ ();
2183
2184   ffestd_subr_f90_ ();
2185   return;
2186
2187 #ifdef FFESTD_F90
2188   fputs ("* ALLOCATABLE ", dmpout);
2189 #endif
2190 }
2191
2192 /* ffestd_R525_item -- ALLOCATABLE statement for object-name
2193
2194    ffestd_R525_item(name_token,dim_list);
2195
2196    Make sure name_token identifies a valid object to be ALLOCATABLEd.  */
2197
2198 void
2199 ffestd_R525_item (ffelexToken name, ffesttDimList dims)
2200 {
2201   ffestd_check_item_ ();
2202
2203   return;                       /* F90. */
2204
2205 #ifdef FFESTD_F90
2206   fputs (ffelex_token_text (name), dmpout);
2207   if (dims != NULL)
2208     {
2209       fputc ('(', dmpout);
2210       ffestt_dimlist_dump (dims);
2211       fputc (')', dmpout);
2212     }
2213   fputc (',', dmpout);
2214 #endif
2215 }
2216
2217 /* ffestd_R525_finish -- ALLOCATABLE statement list complete
2218
2219    ffestd_R525_finish();
2220
2221    Just wrap up any local activities.  */
2222
2223 void
2224 ffestd_R525_finish ()
2225 {
2226   ffestd_check_finish_ ();
2227
2228   return;                       /* F90. */
2229
2230 #ifdef FFESTD_F90
2231   fputc ('\n', dmpout);
2232 #endif
2233 }
2234
2235 /* ffestd_R526_start -- POINTER statement list begin
2236
2237    ffestd_R526_start();
2238
2239    Verify that POINTER is valid here, and begin accepting items in the
2240    list.  */
2241
2242 void
2243 ffestd_R526_start ()
2244 {
2245   ffestd_check_start_ ();
2246
2247   ffestd_subr_f90_ ();
2248   return;
2249
2250 #ifdef FFESTD_F90
2251   fputs ("* POINTER ", dmpout);
2252 #endif
2253 }
2254
2255 /* ffestd_R526_item -- POINTER statement for object-name
2256
2257    ffestd_R526_item(name_token,dim_list);
2258
2259    Make sure name_token identifies a valid object to be POINTERd.  */
2260
2261 void
2262 ffestd_R526_item (ffelexToken name, ffesttDimList dims)
2263 {
2264   ffestd_check_item_ ();
2265
2266   return;                       /* F90. */
2267
2268 #ifdef FFESTD_F90
2269   fputs (ffelex_token_text (name), dmpout);
2270   if (dims != NULL)
2271     {
2272       fputc ('(', dmpout);
2273       ffestt_dimlist_dump (dims);
2274       fputc (')', dmpout);
2275     }
2276   fputc (',', dmpout);
2277 #endif
2278 }
2279
2280 /* ffestd_R526_finish -- POINTER statement list complete
2281
2282    ffestd_R526_finish();
2283
2284    Just wrap up any local activities.  */
2285
2286 void
2287 ffestd_R526_finish ()
2288 {
2289   ffestd_check_finish_ ();
2290
2291   return;                       /* F90. */
2292
2293 #ifdef FFESTD_F90
2294   fputc ('\n', dmpout);
2295 #endif
2296 }
2297
2298 /* ffestd_R527_start -- TARGET statement list begin
2299
2300    ffestd_R527_start();
2301
2302    Verify that TARGET is valid here, and begin accepting items in the
2303    list.  */
2304
2305 void
2306 ffestd_R527_start ()
2307 {
2308   ffestd_check_start_ ();
2309
2310   ffestd_subr_f90_ ();
2311   return;
2312
2313 #ifdef FFESTD_F90
2314   fputs ("* TARGET ", dmpout);
2315 #endif
2316 }
2317
2318 /* ffestd_R527_item -- TARGET statement for object-name
2319
2320    ffestd_R527_item(name_token,dim_list);
2321
2322    Make sure name_token identifies a valid object to be TARGETd.  */
2323
2324 void
2325 ffestd_R527_item (ffelexToken name, ffesttDimList dims)
2326 {
2327   ffestd_check_item_ ();
2328
2329   return;                       /* F90. */
2330
2331 #ifdef FFESTD_F90
2332   fputs (ffelex_token_text (name), dmpout);
2333   if (dims != NULL)
2334     {
2335       fputc ('(', dmpout);
2336       ffestt_dimlist_dump (dims);
2337       fputc (')', dmpout);
2338     }
2339   fputc (',', dmpout);
2340 #endif
2341 }
2342
2343 /* ffestd_R527_finish -- TARGET statement list complete
2344
2345    ffestd_R527_finish();
2346
2347    Just wrap up any local activities.  */
2348
2349 void
2350 ffestd_R527_finish ()
2351 {
2352   ffestd_check_finish_ ();
2353
2354   return;                       /* F90. */
2355
2356 #ifdef FFESTD_F90
2357   fputc ('\n', dmpout);
2358 #endif
2359 }
2360
2361 #endif
2362 /* ffestd_R537_start -- PARAMETER statement list begin
2363
2364    ffestd_R537_start();
2365
2366    Verify that PARAMETER is valid here, and begin accepting items in the list.  */
2367
2368 void
2369 ffestd_R537_start ()
2370 {
2371   ffestd_check_start_ ();
2372
2373 #if FFECOM_targetCURRENT == FFECOM_targetFFE
2374   fputs ("* PARAMETER (", dmpout);
2375 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
2376 #else
2377 #error
2378 #endif
2379 }
2380
2381 /* ffestd_R537_item -- PARAMETER statement assignment
2382
2383    ffestd_R537_item(dest,dest_token,source,source_token);
2384
2385    Make sure the source is a valid source for the destination; make the
2386    assignment.  */
2387
2388 void
2389 ffestd_R537_item (ffebld dest UNUSED, ffebld source UNUSED)
2390 {
2391   ffestd_check_item_ ();
2392
2393 #if FFECOM_targetCURRENT == FFECOM_targetFFE
2394   ffebld_dump (dest);
2395   fputc ('=', dmpout);
2396   ffebld_dump (source);
2397   fputc (',', dmpout);
2398 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
2399 #else
2400 #error
2401 #endif
2402 }
2403
2404 /* ffestd_R537_finish -- PARAMETER statement list complete
2405
2406    ffestd_R537_finish();
2407
2408    Just wrap up any local activities.  */
2409
2410 void
2411 ffestd_R537_finish ()
2412 {
2413   ffestd_check_finish_ ();
2414
2415 #if FFECOM_targetCURRENT == FFECOM_targetFFE
2416   fputs (")\n", dmpout);
2417 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
2418 #else
2419 #error
2420 #endif
2421 }
2422
2423 /* ffestd_R539 -- IMPLICIT NONE statement
2424
2425    ffestd_R539();
2426
2427    Verify that the IMPLICIT NONE statement is ok here and implement.  */
2428
2429 void
2430 ffestd_R539 ()
2431 {
2432   ffestd_check_simple_ ();
2433
2434 #if FFECOM_targetCURRENT == FFECOM_targetFFE
2435   fputs ("* IMPLICIT_NONE\n", dmpout);
2436 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
2437 #else
2438 #error
2439 #endif
2440 }
2441
2442 /* ffestd_R539start -- IMPLICIT statement
2443
2444    ffestd_R539start();
2445
2446    Verify that the IMPLICIT statement is ok here and implement.  */
2447
2448 void
2449 ffestd_R539start ()
2450 {
2451   ffestd_check_start_ ();
2452
2453 #if FFECOM_targetCURRENT == FFECOM_targetFFE
2454   fputs ("* IMPLICIT ", dmpout);
2455 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
2456 #else
2457 #error
2458 #endif
2459 }
2460
2461 /* ffestd_R539item -- IMPLICIT statement specification (R540)
2462
2463    ffestd_R539item(...);
2464
2465    Verify that the type and letter list are all ok and implement.  */
2466
2467 void
2468 ffestd_R539item (ffestpType type UNUSED, ffebld kind UNUSED,
2469                  ffelexToken kindt UNUSED, ffebld len UNUSED,
2470                  ffelexToken lent UNUSED, ffesttImpList letters UNUSED)
2471 {
2472 #if FFECOM_targetCURRENT == FFECOM_targetFFE
2473   char *a;
2474 #endif
2475
2476   ffestd_check_item_ ();
2477
2478 #if FFECOM_targetCURRENT == FFECOM_targetFFE
2479   switch (type)
2480     {
2481     case FFESTP_typeINTEGER:
2482       a = "INTEGER";
2483       break;
2484
2485     case FFESTP_typeBYTE:
2486       a = "BYTE";
2487       break;
2488
2489     case FFESTP_typeWORD:
2490       a = "WORD";
2491       break;
2492
2493     case FFESTP_typeREAL:
2494       a = "REAL";
2495       break;
2496
2497     case FFESTP_typeCOMPLEX:
2498       a = "COMPLEX";
2499       break;
2500
2501     case FFESTP_typeLOGICAL:
2502       a = "LOGICAL";
2503       break;
2504
2505     case FFESTP_typeCHARACTER:
2506       a = "CHARACTER";
2507       break;
2508
2509     case FFESTP_typeDBLPRCSN:
2510       a = "DOUBLE PRECISION";
2511       break;
2512
2513     case FFESTP_typeDBLCMPLX:
2514       a = "DOUBLE COMPLEX";
2515       break;
2516
2517 #if FFESTR_F90
2518     case FFESTP_typeTYPE:
2519       a = "TYPE";
2520       break;
2521 #endif
2522
2523     default:
2524       assert (FALSE);
2525       a = "?";
2526       break;
2527     }
2528   fprintf (dmpout, "%s(", a);
2529   if (kindt != NULL)
2530     {
2531       fputs ("kind=", dmpout);
2532       if (kind == NULL)
2533         fputs (ffelex_token_text (kindt), dmpout);
2534       else
2535         ffebld_dump (kind);
2536       if (lent != NULL)
2537         fputc (',', dmpout);
2538     }
2539   if (lent != NULL)
2540     {
2541       fputs ("len=", dmpout);
2542       if (len == NULL)
2543         fputs (ffelex_token_text (lent), dmpout);
2544       else
2545         ffebld_dump (len);
2546     }
2547   fputs (")(", dmpout);
2548   ffestt_implist_dump (letters);
2549   fputs ("),", dmpout);
2550 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
2551 #else
2552 #error
2553 #endif
2554 }
2555
2556 /* ffestd_R539finish -- IMPLICIT statement
2557
2558    ffestd_R539finish();
2559
2560    Finish up any local activities.  */
2561
2562 void
2563 ffestd_R539finish ()
2564 {
2565   ffestd_check_finish_ ();
2566
2567 #if FFECOM_targetCURRENT == FFECOM_targetFFE
2568   fputc ('\n', dmpout);
2569 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
2570 #else
2571 #error
2572 #endif
2573 }
2574
2575 /* ffestd_R542_start -- NAMELIST statement list begin
2576
2577    ffestd_R542_start();
2578
2579    Verify that NAMELIST is valid here, and begin accepting items in the list.  */
2580
2581 void
2582 ffestd_R542_start ()
2583 {
2584   ffestd_check_start_ ();
2585
2586 #if FFECOM_targetCURRENT == FFECOM_targetFFE
2587   fputs ("* NAMELIST ", dmpout);
2588 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
2589 #else
2590 #error
2591 #endif
2592 }
2593
2594 /* ffestd_R542_item_nlist -- NAMELIST statement for group-name
2595
2596    ffestd_R542_item_nlist(groupname_token);
2597
2598    Make sure name_token identifies a valid object to be NAMELISTd.  */
2599
2600 void
2601 ffestd_R542_item_nlist (ffelexToken name UNUSED)
2602 {
2603   ffestd_check_item_ ();
2604
2605 #if FFECOM_targetCURRENT == FFECOM_targetFFE
2606   fprintf (dmpout, "/%s/", ffelex_token_text (name));
2607 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
2608 #else
2609 #error
2610 #endif
2611 }
2612
2613 /* ffestd_R542_item_nitem -- NAMELIST statement for variable-name
2614
2615    ffestd_R542_item_nitem(name_token);
2616
2617    Make sure name_token identifies a valid object to be NAMELISTd.  */
2618
2619 void
2620 ffestd_R542_item_nitem (ffelexToken name UNUSED)
2621 {
2622   ffestd_check_item_ ();
2623
2624 #if FFECOM_targetCURRENT == FFECOM_targetFFE
2625   fprintf (dmpout, "%s,", ffelex_token_text (name));
2626 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
2627 #else
2628 #error
2629 #endif
2630 }
2631
2632 /* ffestd_R542_finish -- NAMELIST statement list complete
2633
2634    ffestd_R542_finish();
2635
2636    Just wrap up any local activities.  */
2637
2638 void
2639 ffestd_R542_finish ()
2640 {
2641   ffestd_check_finish_ ();
2642
2643 #if FFECOM_targetCURRENT == FFECOM_targetFFE
2644   fputc ('\n', dmpout);
2645 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
2646 #else
2647 #error
2648 #endif
2649 }
2650
2651 /* ffestd_R544_start -- EQUIVALENCE statement list begin
2652
2653    ffestd_R544_start();
2654
2655    Verify that EQUIVALENCE is valid here, and begin accepting items in the
2656    list.  */
2657
2658 #if 0
2659 void
2660 ffestd_R544_start ()
2661 {
2662   ffestd_check_start_ ();
2663
2664 #if FFECOM_targetCURRENT == FFECOM_targetFFE
2665   fputs ("* EQUIVALENCE (", dmpout);
2666 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
2667 #else
2668 #error
2669 #endif
2670 }
2671
2672 #endif
2673 /* ffestd_R544_item -- EQUIVALENCE statement assignment
2674
2675    ffestd_R544_item(exprlist);
2676
2677    Make sure the equivalence is valid, then implement it.  */
2678
2679 #if 0
2680 void
2681 ffestd_R544_item (ffesttExprList exprlist)
2682 {
2683   ffestd_check_item_ ();
2684
2685 #if FFECOM_targetCURRENT == FFECOM_targetFFE
2686   ffestt_exprlist_dump (exprlist);
2687   fputs ("),", dmpout);
2688 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
2689 #else
2690 #error
2691 #endif
2692 }
2693
2694 #endif
2695 /* ffestd_R544_finish -- EQUIVALENCE statement list complete
2696
2697    ffestd_R544_finish();
2698
2699    Just wrap up any local activities.  */
2700
2701 #if 0
2702 void
2703 ffestd_R544_finish ()
2704 {
2705   ffestd_check_finish_ ();
2706
2707 #if FFECOM_targetCURRENT == FFECOM_targetFFE
2708   fputs (")\n", dmpout);
2709 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
2710 #else
2711 #error
2712 #endif
2713 }
2714
2715 #endif
2716 /* ffestd_R547_start -- COMMON statement list begin
2717
2718    ffestd_R547_start();
2719
2720    Verify that COMMON is valid here, and begin accepting items in the list.  */
2721
2722 void
2723 ffestd_R547_start ()
2724 {
2725   ffestd_check_start_ ();
2726
2727 #if FFECOM_targetCURRENT == FFECOM_targetFFE
2728   fputs ("* COMMON ", dmpout);
2729 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
2730 #else
2731 #error
2732 #endif
2733 }
2734
2735 /* ffestd_R547_item_object -- COMMON statement for object-name
2736
2737    ffestd_R547_item_object(name_token,dim_list);
2738
2739    Make sure name_token identifies a valid object to be COMMONd.  */
2740
2741 void
2742 ffestd_R547_item_object (ffelexToken name UNUSED,
2743                          ffesttDimList dims UNUSED)
2744 {
2745   ffestd_check_item_ ();
2746
2747 #if FFECOM_targetCURRENT == FFECOM_targetFFE
2748   fputs (ffelex_token_text (name), dmpout);
2749   if (dims != NULL)
2750     {
2751       fputc ('(', dmpout);
2752       ffestt_dimlist_dump (dims);
2753       fputc (')', dmpout);
2754     }
2755   fputc (',', dmpout);
2756 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
2757 #else
2758 #error
2759 #endif
2760 }
2761
2762 /* ffestd_R547_item_cblock -- COMMON statement for common-block-name
2763
2764    ffestd_R547_item_cblock(name_token);
2765
2766    Make sure name_token identifies a valid common block to be COMMONd.  */
2767
2768 void
2769 ffestd_R547_item_cblock (ffelexToken name UNUSED)
2770 {
2771   ffestd_check_item_ ();
2772
2773 #if FFECOM_targetCURRENT == FFECOM_targetFFE
2774   if (name == NULL)
2775     fputs ("//,", dmpout);
2776   else
2777     fprintf (dmpout, "/%s/,", ffelex_token_text (name));
2778 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
2779 #else
2780 #error
2781 #endif
2782 }
2783
2784 /* ffestd_R547_finish -- COMMON statement list complete
2785
2786    ffestd_R547_finish();
2787
2788    Just wrap up any local activities.  */
2789
2790 void
2791 ffestd_R547_finish ()
2792 {
2793   ffestd_check_finish_ ();
2794
2795 #if FFECOM_targetCURRENT == FFECOM_targetFFE
2796   fputc ('\n', dmpout);
2797 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
2798 #else
2799 #error
2800 #endif
2801 }
2802
2803 /* ffestd_R620 -- ALLOCATE statement
2804
2805    ffestd_R620(exprlist,stat,stat_token);
2806
2807    Make sure the expression list is valid, then implement it.  */
2808
2809 #if FFESTR_F90
2810 void
2811 ffestd_R620 (ffesttExprList exprlist, ffebld stat)
2812 {
2813   ffestd_check_simple_ ();
2814
2815   ffestd_subr_f90_ ();
2816   return;
2817
2818 #ifdef FFESTD_F90
2819   fputs ("+ ALLOCATE (", dmpout);
2820   ffestt_exprlist_dump (exprlist);
2821   if (stat != NULL)
2822     {
2823       fputs (",stat=", dmpout);
2824       ffebld_dump (stat);
2825     }
2826   fputs (")\n", dmpout);
2827 #endif
2828 }
2829
2830 /* ffestd_R624 -- NULLIFY statement
2831
2832    ffestd_R624(pointer_name_list);
2833
2834    Make sure pointer_name_list identifies valid pointers for a NULLIFY.  */
2835
2836 void
2837 ffestd_R624 (ffesttExprList pointers)
2838 {
2839   ffestd_check_simple_ ();
2840
2841   ffestd_subr_f90_ ();
2842   return;
2843
2844 #ifdef FFESTD_F90
2845   fputs ("+ NULLIFY (", dmpout);
2846   assert (pointers != NULL);
2847   ffestt_exprlist_dump (pointers);
2848   fputs (")\n", dmpout);
2849 #endif
2850 }
2851
2852 /* ffestd_R625 -- DEALLOCATE statement
2853
2854    ffestd_R625(exprlist,stat,stat_token);
2855
2856    Make sure the equivalence is valid, then implement it.  */
2857
2858 void
2859 ffestd_R625 (ffesttExprList exprlist, ffebld stat)
2860 {
2861   ffestd_check_simple_ ();
2862
2863   ffestd_subr_f90_ ();
2864   return;
2865
2866 #ifdef FFESTD_F90
2867   fputs ("+ DEALLOCATE (", dmpout);
2868   ffestt_exprlist_dump (exprlist);
2869   if (stat != NULL)
2870     {
2871       fputs (",stat=", dmpout);
2872       ffebld_dump (stat);
2873     }
2874   fputs (")\n", dmpout);
2875 #endif
2876 }
2877
2878 #endif
2879 /* ffestd_R737A -- Assignment statement outside of WHERE
2880
2881    ffestd_R737A(dest_expr,source_expr);  */
2882
2883 void
2884 ffestd_R737A (ffebld dest, ffebld source)
2885 {
2886   ffestd_check_simple_ ();
2887
2888 #if FFECOM_ONEPASS
2889   ffestd_subr_line_now_ ();
2890   ffeste_R737A (dest, source);
2891 #else
2892   {
2893     ffestdStmt_ stmt;
2894
2895     stmt = ffestd_stmt_new_ (FFESTD_stmtidR737A_);
2896     ffestd_stmt_append_ (stmt);
2897     ffestd_subr_line_save_ (stmt);
2898     stmt->u.R737A.pool = ffesta_output_pool;
2899     stmt->u.R737A.dest = dest;
2900     stmt->u.R737A.source = source;
2901     ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
2902   }
2903 #endif
2904 }
2905
2906 /* ffestd_R737B -- Assignment statement inside of WHERE
2907
2908    ffestd_R737B(dest_expr,source_expr);  */
2909
2910 #if FFESTR_F90
2911 void
2912 ffestd_R737B (ffebld dest, ffebld source)
2913 {
2914   ffestd_check_simple_ ();
2915
2916   return;                       /* F90. */
2917
2918 #ifdef FFESTD_F90
2919   fputs ("+ let_inside_where ", dmpout);
2920   ffebld_dump (dest);
2921   fputs ("=", dmpout);
2922   ffebld_dump (source);
2923   fputc ('\n', dmpout);
2924 #endif
2925 }
2926
2927 /* ffestd_R738 -- Pointer assignment statement
2928
2929    ffestd_R738(dest_expr,source_expr,source_token);
2930
2931    Make sure the assignment is valid.  */
2932
2933 void
2934 ffestd_R738 (ffebld dest, ffebld source)
2935 {
2936   ffestd_check_simple_ ();
2937
2938   ffestd_subr_f90_ ();
2939   return;
2940
2941 #ifdef FFESTD_F90
2942   fputs ("+ let_pointer ", dmpout);
2943   ffebld_dump (dest);
2944   fputs ("=>", dmpout);
2945   ffebld_dump (source);
2946   fputc ('\n', dmpout);
2947 #endif
2948 }
2949
2950 /* ffestd_R740 -- WHERE statement
2951
2952    ffestd_R740(expr,expr_token);
2953
2954    Make sure statement is valid here; implement.  */
2955
2956 void
2957 ffestd_R740 (ffebld expr)
2958 {
2959   ffestd_check_simple_ ();
2960
2961   ffestd_subr_f90_ ();
2962   return;
2963
2964 #ifdef FFESTD_F90
2965   fputs ("+ WHERE (", dmpout);
2966   ffebld_dump (expr);
2967   fputs (")\n", dmpout);
2968
2969   ++ffestd_block_level_;
2970   assert (ffestd_block_level_ > 0);
2971 #endif
2972 }
2973
2974 /* ffestd_R742 -- WHERE-construct statement
2975
2976    ffestd_R742(expr,expr_token);
2977
2978    Make sure statement is valid here; implement.  */
2979
2980 void
2981 ffestd_R742 (ffebld expr)
2982 {
2983   ffestd_check_simple_ ();
2984
2985   ffestd_subr_f90_ ();
2986   return;
2987
2988 #ifdef FFESTD_F90
2989   fputs ("+ WHERE_construct (", dmpout);
2990   ffebld_dump (expr);
2991   fputs (")\n", dmpout);
2992
2993   ++ffestd_block_level_;
2994   assert (ffestd_block_level_ > 0);
2995 #endif
2996 }
2997
2998 /* ffestd_R744 -- ELSE WHERE statement
2999
3000    ffestd_R744();
3001
3002    Make sure ffestd_kind_ identifies a WHERE block.
3003    Implement the ELSE of the current WHERE block.  */
3004
3005 void
3006 ffestd_R744 ()
3007 {
3008   ffestd_check_simple_ ();
3009
3010   return;                       /* F90. */
3011
3012 #ifdef FFESTD_F90
3013   fputs ("+ ELSE_WHERE\n", dmpout);
3014 #endif
3015 }
3016
3017 /* ffestd_R745 -- Implicit END WHERE statement.  */
3018
3019 void
3020 ffestd_R745 (bool ok)
3021 {
3022   return;                       /* F90. */
3023
3024 #ifdef FFESTD_F90
3025   fputs ("+ END_WHERE\n", dmpout);      /* Also see ffestd_R745. */
3026
3027   --ffestd_block_level_;
3028   assert (ffestd_block_level_ >= 0);
3029 #endif
3030 }
3031
3032 #endif
3033
3034 /* Block IF (IF-THEN) statement.  */
3035
3036 void
3037 ffestd_R803 (ffelexToken construct_name UNUSED, ffebld expr)
3038 {
3039   ffestd_check_simple_ ();
3040
3041 #if FFECOM_ONEPASS
3042   ffestd_subr_line_now_ ();
3043   ffeste_R803 (expr);           /* Don't bother with name. */
3044 #else
3045   {
3046     ffestdStmt_ stmt;
3047
3048     stmt = ffestd_stmt_new_ (FFESTD_stmtidR803_);
3049     ffestd_stmt_append_ (stmt);
3050     ffestd_subr_line_save_ (stmt);
3051     stmt->u.R803.pool = ffesta_output_pool;
3052     stmt->u.R803.block = ffestw_use (ffestw_stack_top ());
3053     stmt->u.R803.expr = expr;
3054     ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
3055   }
3056 #endif
3057
3058   ++ffestd_block_level_;
3059   assert (ffestd_block_level_ > 0);
3060 }
3061
3062 /* ELSE IF statement.  */
3063
3064 void
3065 ffestd_R804 (ffebld expr, ffelexToken name UNUSED)
3066 {
3067   ffestd_check_simple_ ();
3068
3069 #if FFECOM_ONEPASS
3070   ffestd_subr_line_now_ ();
3071   ffeste_R804 (expr);           /* Don't bother with name. */
3072 #else
3073   {
3074     ffestdStmt_ stmt;
3075
3076     stmt = ffestd_stmt_new_ (FFESTD_stmtidR804_);
3077     ffestd_stmt_append_ (stmt);
3078     ffestd_subr_line_save_ (stmt);
3079     stmt->u.R804.pool = ffesta_output_pool;
3080     stmt->u.R804.block = ffestw_use (ffestw_stack_top ());
3081     stmt->u.R804.expr = expr;
3082     ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
3083   }
3084 #endif
3085 }
3086
3087 /* ELSE statement.  */
3088
3089 void
3090 ffestd_R805 (ffelexToken name UNUSED)
3091 {
3092   ffestd_check_simple_ ();
3093
3094 #if FFECOM_ONEPASS
3095   ffestd_subr_line_now_ ();
3096   ffeste_R805 ();               /* Don't bother with name. */
3097 #else
3098   {
3099     ffestdStmt_ stmt;
3100
3101     stmt = ffestd_stmt_new_ (FFESTD_stmtidR805_);
3102     ffestd_stmt_append_ (stmt);
3103     ffestd_subr_line_save_ (stmt);
3104     stmt->u.R805.block = ffestw_use (ffestw_stack_top ());
3105   }
3106 #endif
3107 }
3108
3109 /* END IF statement.  */
3110
3111 void
3112 ffestd_R806 (bool ok UNUSED)
3113 {
3114 #if FFECOM_ONEPASS
3115   ffestd_subr_line_now_ ();
3116   ffeste_R806 ();
3117 #else
3118   {
3119     ffestdStmt_ stmt;
3120
3121     stmt = ffestd_stmt_new_ (FFESTD_stmtidR806_);
3122     ffestd_stmt_append_ (stmt);
3123     ffestd_subr_line_save_ (stmt);
3124     stmt->u.R806.block = ffestw_use (ffestw_stack_top ());
3125   }
3126 #endif
3127
3128   --ffestd_block_level_;
3129   assert (ffestd_block_level_ >= 0);
3130 }
3131
3132 /* ffestd_R807 -- Logical IF statement
3133
3134    ffestd_R807(expr,expr_token);
3135
3136    Make sure statement is valid here; implement.  */
3137
3138 void
3139 ffestd_R807 (ffebld expr)
3140 {
3141   ffestd_check_simple_ ();
3142
3143 #if FFECOM_ONEPASS
3144   ffestd_subr_line_now_ ();
3145   ffeste_R807 (expr);
3146 #else
3147   {
3148     ffestdStmt_ stmt;
3149
3150     stmt = ffestd_stmt_new_ (FFESTD_stmtidR807_);
3151     ffestd_stmt_append_ (stmt);
3152     ffestd_subr_line_save_ (stmt);
3153     stmt->u.R807.pool = ffesta_output_pool;
3154     stmt->u.R807.expr = expr;
3155     ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
3156   }
3157 #endif
3158
3159   ++ffestd_block_level_;
3160   assert (ffestd_block_level_ > 0);
3161 }
3162
3163 /* ffestd_R809 -- SELECT CASE statement
3164
3165    ffestd_R809(construct_name,expr,expr_token);
3166
3167    Make sure statement is valid here; implement.  */
3168
3169 void
3170 ffestd_R809 (ffelexToken construct_name UNUSED, ffebld expr)
3171 {
3172   ffestd_check_simple_ ();
3173
3174 #if FFECOM_ONEPASS
3175   ffestd_subr_line_now_ ();
3176   ffeste_R809 (ffestw_stack_top (), expr);
3177 #else
3178   {
3179     ffestdStmt_ stmt;
3180
3181     stmt = ffestd_stmt_new_ (FFESTD_stmtidR809_);
3182     ffestd_stmt_append_ (stmt);
3183     ffestd_subr_line_save_ (stmt);
3184     stmt->u.R809.pool = ffesta_output_pool;
3185     stmt->u.R809.block = ffestw_use (ffestw_stack_top ());
3186     stmt->u.R809.expr = expr;
3187     ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
3188     malloc_pool_use (ffestw_select (ffestw_stack_top ())->pool);
3189   }
3190 #endif
3191
3192   ++ffestd_block_level_;
3193   assert (ffestd_block_level_ > 0);
3194 }
3195
3196 /* ffestd_R810 -- CASE statement
3197
3198    ffestd_R810(case_value_range_list,name);
3199
3200    If casenum is 0, it's CASE DEFAULT.  Else it's the case ranges at
3201    the start of the first_stmt list in the select object at the top of
3202    the stack that match casenum.  */
3203
3204 void
3205 ffestd_R810 (unsigned long casenum)
3206 {
3207   ffestd_check_simple_ ();
3208
3209 #if FFECOM_ONEPASS
3210   ffestd_subr_line_now_ ();
3211   ffeste_R810 (ffestw_stack_top (), casenum);
3212 #else
3213   {
3214     ffestdStmt_ stmt;
3215
3216     stmt = ffestd_stmt_new_ (FFESTD_stmtidR810_);
3217     ffestd_stmt_append_ (stmt);
3218     ffestd_subr_line_save_ (stmt);
3219     stmt->u.R810.pool = ffesta_output_pool;
3220     stmt->u.R810.block = ffestw_stack_top ();
3221     stmt->u.R810.casenum = casenum;
3222     ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
3223   }
3224 #endif
3225 }
3226
3227 /* ffestd_R811 -- End a SELECT
3228
3229    ffestd_R811(TRUE);  */
3230
3231 void
3232 ffestd_R811 (bool ok UNUSED)
3233 {
3234 #if FFECOM_ONEPASS
3235   ffestd_subr_line_now_ ();
3236   ffeste_R811 (ffestw_stack_top ());
3237 #else
3238   {
3239     ffestdStmt_ stmt;
3240
3241     stmt = ffestd_stmt_new_ (FFESTD_stmtidR811_);
3242     ffestd_stmt_append_ (stmt);
3243     ffestd_subr_line_save_ (stmt);
3244     stmt->u.R811.block = ffestw_stack_top ();
3245   }
3246 #endif
3247
3248   --ffestd_block_level_;
3249   assert (ffestd_block_level_ >= 0);
3250 }
3251
3252 /* ffestd_R819A -- Iterative DO statement
3253
3254    ffestd_R819A(construct_name,label_token,expr,expr_token);
3255
3256    Make sure statement is valid here; implement.  */
3257
3258 void
3259 ffestd_R819A (ffelexToken construct_name UNUSED, ffelab label,
3260               ffebld var, ffebld start, ffelexToken start_token,
3261               ffebld end, ffelexToken end_token,
3262               ffebld incr, ffelexToken incr_token)
3263 {
3264   ffestd_check_simple_ ();
3265
3266 #if FFECOM_ONEPASS
3267   ffestd_subr_line_now_ ();
3268   ffeste_R819A (ffestw_stack_top (), label, var, start, end, incr,
3269                 incr_token);
3270 #else
3271   {
3272     ffestdStmt_ stmt;
3273
3274     stmt = ffestd_stmt_new_ (FFESTD_stmtidR819A_);
3275     ffestd_stmt_append_ (stmt);
3276     ffestd_subr_line_save_ (stmt);
3277     stmt->u.R819A.pool = ffesta_output_pool;
3278     stmt->u.R819A.block = ffestw_use (ffestw_stack_top ());
3279     stmt->u.R819A.label = label;
3280     stmt->u.R819A.var = var;
3281     stmt->u.R819A.start = start;
3282     stmt->u.R819A.start_token = ffelex_token_use (start_token);
3283     stmt->u.R819A.end = end;
3284     stmt->u.R819A.end_token = ffelex_token_use (end_token);
3285     stmt->u.R819A.incr = incr;
3286     stmt->u.R819A.incr_token = (incr_token == NULL) ? NULL
3287       : ffelex_token_use (incr_token);
3288     ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
3289   }
3290 #endif
3291
3292   ++ffestd_block_level_;
3293   assert (ffestd_block_level_ > 0);
3294 }
3295
3296 /* ffestd_R819B -- DO WHILE statement
3297
3298    ffestd_R819B(construct_name,label_token,expr,expr_token);
3299
3300    Make sure statement is valid here; implement.  */
3301
3302 void
3303 ffestd_R819B (ffelexToken construct_name UNUSED, ffelab label,
3304               ffebld expr)
3305 {
3306   ffestd_check_simple_ ();
3307
3308 #if FFECOM_ONEPASS
3309   ffestd_subr_line_now_ ();
3310   ffeste_R819B (ffestw_stack_top (), label, expr);
3311 #else
3312   {
3313     ffestdStmt_ stmt;
3314
3315     stmt = ffestd_stmt_new_ (FFESTD_stmtidR819B_);
3316     ffestd_stmt_append_ (stmt);
3317     ffestd_subr_line_save_ (stmt);
3318     stmt->u.R819B.pool = ffesta_output_pool;
3319     stmt->u.R819B.block = ffestw_use (ffestw_stack_top ());
3320     stmt->u.R819B.label = label;
3321     stmt->u.R819B.expr = expr;
3322     ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
3323   }
3324 #endif
3325
3326   ++ffestd_block_level_;
3327   assert (ffestd_block_level_ > 0);
3328 }
3329
3330 /* ffestd_R825 -- END DO statement
3331
3332    ffestd_R825(name_token);
3333
3334    Make sure ffestd_kind_ identifies a DO block.  If not
3335    NULL, make sure name_token gives the correct name.  Do whatever
3336    is specific to seeing END DO with a DO-target label definition on it,
3337    where the END DO is really treated as a CONTINUE (i.e. generate th
3338    same code you would for CONTINUE).  ffestd_do handles the actual
3339    generation of end-loop code.  */
3340
3341 void
3342 ffestd_R825 (ffelexToken name UNUSED)
3343 {
3344   ffestd_check_simple_ ();
3345
3346 #if FFECOM_ONEPASS
3347   ffestd_subr_line_now_ ();
3348   ffeste_R825 ();
3349 #else
3350   {
3351     ffestdStmt_ stmt;
3352
3353     stmt = ffestd_stmt_new_ (FFESTD_stmtidR825_);
3354     ffestd_stmt_append_ (stmt);
3355     ffestd_subr_line_save_ (stmt);
3356   }
3357 #endif
3358 }
3359
3360 /* ffestd_R834 -- CYCLE statement
3361
3362    ffestd_R834(name_token);
3363
3364    Handle a CYCLE within a loop.  */
3365
3366 void
3367 ffestd_R834 (ffestw block)
3368 {
3369   ffestd_check_simple_ ();
3370
3371 #if FFECOM_ONEPASS
3372   ffestd_subr_line_now_ ();
3373   ffeste_R834 (block);
3374 #else
3375   {
3376     ffestdStmt_ stmt;
3377
3378     stmt = ffestd_stmt_new_ (FFESTD_stmtidR834_);
3379     ffestd_stmt_append_ (stmt);
3380     ffestd_subr_line_save_ (stmt);
3381     stmt->u.R834.block = block;
3382   }
3383 #endif
3384 }
3385
3386 /* ffestd_R835 -- EXIT statement
3387
3388    ffestd_R835(name_token);
3389
3390    Handle a EXIT within a loop.  */
3391
3392 void
3393 ffestd_R835 (ffestw block)
3394 {
3395   ffestd_check_simple_ ();
3396
3397 #if FFECOM_ONEPASS
3398   ffestd_subr_line_now_ ();
3399   ffeste_R835 (block);
3400 #else
3401   {
3402     ffestdStmt_ stmt;
3403
3404     stmt = ffestd_stmt_new_ (FFESTD_stmtidR835_);
3405     ffestd_stmt_append_ (stmt);
3406     ffestd_subr_line_save_ (stmt);
3407     stmt->u.R835.block = block;
3408   }
3409 #endif
3410 }
3411
3412 /* ffestd_R836 -- GOTO statement
3413
3414    ffestd_R836(label);
3415
3416    Make sure label_token identifies a valid label for a GOTO.  Update
3417    that label's info to indicate it is the target of a GOTO.  */
3418
3419 void
3420 ffestd_R836 (ffelab label)
3421 {
3422   ffestd_check_simple_ ();
3423
3424 #if FFECOM_ONEPASS
3425   ffestd_subr_line_now_ ();
3426   ffeste_R836 (label);
3427 #else
3428   {
3429     ffestdStmt_ stmt;
3430
3431     stmt = ffestd_stmt_new_ (FFESTD_stmtidR836_);
3432     ffestd_stmt_append_ (stmt);
3433     ffestd_subr_line_save_ (stmt);
3434     stmt->u.R836.label = label;
3435   }
3436 #endif
3437
3438   if (ffestd_block_level_ == 0)
3439     ffestd_is_reachable_ = FALSE;
3440 }
3441
3442 /* ffestd_R837 -- Computed GOTO statement
3443
3444    ffestd_R837(labels,expr);
3445
3446    Make sure label_list identifies valid labels for a GOTO.  Update
3447    each label's info to indicate it is the target of a GOTO.  */
3448
3449 void
3450 ffestd_R837 (ffelab *labels, int count, ffebld expr)
3451 {
3452   ffestd_check_simple_ ();
3453
3454 #if FFECOM_ONEPASS
3455   ffestd_subr_line_now_ ();
3456   ffeste_R837 (labels, count, expr);
3457 #else
3458   {
3459     ffestdStmt_ stmt;
3460
3461     stmt = ffestd_stmt_new_ (FFESTD_stmtidR837_);
3462     ffestd_stmt_append_ (stmt);
3463     ffestd_subr_line_save_ (stmt);
3464     stmt->u.R837.pool = ffesta_output_pool;
3465     stmt->u.R837.labels = labels;
3466     stmt->u.R837.count = count;
3467     stmt->u.R837.expr = expr;
3468     ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
3469   }
3470 #endif
3471 }
3472
3473 /* ffestd_R838 -- ASSIGN statement
3474
3475    ffestd_R838(label_token,target_variable,target_token);
3476
3477    Make sure label_token identifies a valid label for an assignment.  Update
3478    that label's info to indicate it is the source of an assignment.  Update
3479    target_variable's info to indicate it is the target the assignment of that
3480    label.  */
3481
3482 void
3483 ffestd_R838 (ffelab label, ffebld target)
3484 {
3485   ffestd_check_simple_ ();
3486
3487 #if FFECOM_ONEPASS
3488   ffestd_subr_line_now_ ();
3489   ffeste_R838 (label, target);
3490 #else
3491   {
3492     ffestdStmt_ stmt;
3493
3494     stmt = ffestd_stmt_new_ (FFESTD_stmtidR838_);
3495     ffestd_stmt_append_ (stmt);
3496     ffestd_subr_line_save_ (stmt);
3497     stmt->u.R838.pool = ffesta_output_pool;
3498     stmt->u.R838.label = label;
3499     stmt->u.R838.target = target;
3500     ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
3501   }
3502 #endif
3503 }
3504
3505 /* ffestd_R839 -- Assigned GOTO statement
3506
3507    ffestd_R839(target,labels);
3508
3509    Make sure label_list identifies valid labels for a GOTO.  Update
3510    each label's info to indicate it is the target of a GOTO.  */
3511
3512 void
3513 ffestd_R839 (ffebld target, ffelab *labels UNUSED, int count UNUSED)
3514 {
3515   ffestd_check_simple_ ();
3516
3517 #if FFECOM_ONEPASS
3518   ffestd_subr_line_now_ ();
3519   ffeste_R839 (target);
3520 #else
3521   {
3522     ffestdStmt_ stmt;
3523
3524     stmt = ffestd_stmt_new_ (FFESTD_stmtidR839_);
3525     ffestd_stmt_append_ (stmt);
3526     ffestd_subr_line_save_ (stmt);
3527     stmt->u.R839.pool = ffesta_output_pool;
3528     stmt->u.R839.target = target;
3529     ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
3530   }
3531 #endif
3532
3533   if (ffestd_block_level_ == 0)
3534     ffestd_is_reachable_ = FALSE;
3535 }
3536
3537 /* ffestd_R840 -- Arithmetic IF statement
3538
3539    ffestd_R840(expr,expr_token,neg,zero,pos);
3540
3541    Make sure the labels are valid; implement.  */
3542
3543 void
3544 ffestd_R840 (ffebld expr, ffelab neg, ffelab zero, ffelab pos)
3545 {
3546   ffestd_check_simple_ ();
3547
3548 #if FFECOM_ONEPASS
3549   ffestd_subr_line_now_ ();
3550   ffeste_R840 (expr, neg, zero, pos);
3551 #else
3552   {
3553     ffestdStmt_ stmt;
3554
3555     stmt = ffestd_stmt_new_ (FFESTD_stmtidR840_);
3556     ffestd_stmt_append_ (stmt);
3557     ffestd_subr_line_save_ (stmt);
3558     stmt->u.R840.pool = ffesta_output_pool;
3559     stmt->u.R840.expr = expr;
3560     stmt->u.R840.neg = neg;
3561     stmt->u.R840.zero = zero;
3562     stmt->u.R840.pos = pos;
3563     ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
3564   }
3565 #endif
3566
3567   if (ffestd_block_level_ == 0)
3568     ffestd_is_reachable_ = FALSE;
3569 }
3570
3571 /* ffestd_R841 -- CONTINUE statement
3572
3573    ffestd_R841();  */
3574
3575 void
3576 ffestd_R841 (bool in_where UNUSED)
3577 {
3578   ffestd_check_simple_ ();
3579
3580 #if FFECOM_ONEPASS
3581   ffestd_subr_line_now_ ();
3582   ffeste_R841 ();
3583 #else
3584   {
3585     ffestdStmt_ stmt;
3586
3587     stmt = ffestd_stmt_new_ (FFESTD_stmtidR841_);
3588     ffestd_stmt_append_ (stmt);
3589     ffestd_subr_line_save_ (stmt);
3590   }
3591 #endif
3592 }
3593
3594 /* ffestd_R842 -- STOP statement
3595
3596    ffestd_R842(expr);  */
3597
3598 void
3599 ffestd_R842 (ffebld expr)
3600 {
3601   ffestd_check_simple_ ();
3602
3603 #if FFECOM_ONEPASS
3604   ffestd_subr_line_now_ ();
3605   ffeste_R842 (expr);
3606 #else
3607   {
3608     ffestdStmt_ stmt;
3609
3610     stmt = ffestd_stmt_new_ (FFESTD_stmtidR842_);
3611     ffestd_stmt_append_ (stmt);
3612     ffestd_subr_line_save_ (stmt);
3613     if (ffesta_outpooldisp () == FFESTA_pooldispPRESERVE)
3614       {
3615         /* This is a "spurious" (automatically-generated) STOP
3616            that follows a previous STOP or other statement.
3617            Make sure we don't have an expression in the pool,
3618            and then mark that the pool has already been killed.  */
3619         assert (expr == NULL);
3620         stmt->u.R842.pool = NULL;
3621         stmt->u.R842.expr = NULL;
3622       }
3623     else
3624       {
3625         stmt->u.R842.pool = ffesta_output_pool;
3626         stmt->u.R842.expr = expr;
3627         ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
3628       }
3629   }
3630 #endif
3631
3632   if (ffestd_block_level_ == 0)
3633     ffestd_is_reachable_ = FALSE;
3634 }
3635
3636 /* ffestd_R843 -- PAUSE statement
3637
3638    ffestd_R843(expr,expr_token);
3639
3640    Make sure statement is valid here; implement.  expr and expr_token are
3641    both NULL if there was no expression.  */
3642
3643 void
3644 ffestd_R843 (ffebld expr)
3645 {
3646   ffestd_check_simple_ ();
3647
3648 #if FFECOM_ONEPASS
3649   ffestd_subr_line_now_ ();
3650   ffeste_R843 (expr);
3651 #else
3652   {
3653     ffestdStmt_ stmt;
3654
3655     stmt = ffestd_stmt_new_ (FFESTD_stmtidR843_);
3656     ffestd_stmt_append_ (stmt);
3657     ffestd_subr_line_save_ (stmt);
3658     stmt->u.R843.pool = ffesta_output_pool;
3659     stmt->u.R843.expr = expr;
3660     ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
3661   }
3662 #endif
3663 }
3664
3665 /* ffestd_R904 -- OPEN statement
3666
3667    ffestd_R904();
3668
3669    Make sure an OPEN is valid in the current context, and implement it.  */
3670
3671 void
3672 ffestd_R904 ()
3673 {
3674   ffestd_check_simple_ ();
3675
3676 #if FFECOM_targetCURRENT == FFECOM_targetGCC
3677 #define specified(something) \
3678       (ffestp_file.open.open_spec[something].kw_or_val_present)
3679
3680   /* Warn if there are any thing we don't handle via f2c libraries. */
3681
3682   if (specified (FFESTP_openixACTION)
3683       || specified (FFESTP_openixASSOCIATEVARIABLE)
3684       || specified (FFESTP_openixBLOCKSIZE)
3685       || specified (FFESTP_openixBUFFERCOUNT)
3686       || specified (FFESTP_openixCARRIAGECONTROL)
3687       || specified (FFESTP_openixDEFAULTFILE)
3688       || specified (FFESTP_openixDELIM)
3689       || specified (FFESTP_openixDISPOSE)
3690       || specified (FFESTP_openixEXTENDSIZE)
3691       || specified (FFESTP_openixINITIALSIZE)
3692       || specified (FFESTP_openixKEY)
3693       || specified (FFESTP_openixMAXREC)
3694       || specified (FFESTP_openixNOSPANBLOCKS)
3695       || specified (FFESTP_openixORGANIZATION)
3696       || specified (FFESTP_openixPAD)
3697       || specified (FFESTP_openixPOSITION)
3698       || specified (FFESTP_openixREADONLY)
3699       || specified (FFESTP_openixRECORDTYPE)
3700       || specified (FFESTP_openixSHARED)
3701       || specified (FFESTP_openixUSEROPEN))
3702     {
3703       ffebad_start (FFEBAD_OPEN_UNSUPPORTED);
3704       ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
3705                    ffelex_token_where_column (ffesta_tokens[0]));
3706       ffebad_finish ();
3707     }
3708
3709 #undef specified
3710 #endif
3711
3712 #if FFECOM_ONEPASS
3713   ffestd_subr_line_now_ ();
3714   ffeste_R904 (&ffestp_file.open);
3715 #else
3716   {
3717     ffestdStmt_ stmt;
3718
3719     stmt = ffestd_stmt_new_ (FFESTD_stmtidR904_);
3720     ffestd_stmt_append_ (stmt);
3721     ffestd_subr_line_save_ (stmt);
3722     stmt->u.R904.pool = ffesta_output_pool;
3723     stmt->u.R904.params = ffestd_subr_copy_open_ ();
3724     ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
3725   }
3726 #endif
3727 }
3728
3729 /* ffestd_R907 -- CLOSE statement
3730
3731    ffestd_R907();
3732
3733    Make sure a CLOSE is valid in the current context, and implement it.  */
3734
3735 void
3736 ffestd_R907 ()
3737 {
3738   ffestd_check_simple_ ();
3739
3740 #if FFECOM_ONEPASS
3741   ffestd_subr_line_now_ ();
3742   ffeste_R907 (&ffestp_file.close);
3743 #else
3744   {
3745     ffestdStmt_ stmt;
3746
3747     stmt = ffestd_stmt_new_ (FFESTD_stmtidR907_);
3748     ffestd_stmt_append_ (stmt);
3749     ffestd_subr_line_save_ (stmt);
3750     stmt->u.R907.pool = ffesta_output_pool;
3751     stmt->u.R907.params = ffestd_subr_copy_close_ ();
3752     ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
3753   }
3754 #endif
3755 }
3756
3757 /* ffestd_R909_start -- READ(...) statement list begin
3758
3759    ffestd_R909_start(FALSE);
3760
3761    Verify that READ is valid here, and begin accepting items in the
3762    list.  */
3763
3764 void
3765 ffestd_R909_start (bool only_format, ffestvUnit unit,
3766                    ffestvFormat format, bool rec, bool key)
3767 {
3768   ffestd_check_start_ ();
3769
3770 #if FFECOM_targetCURRENT == FFECOM_targetGCC
3771 #define specified(something) \
3772       (ffestp_file.read.read_spec[something].kw_or_val_present)
3773
3774   /* Warn if there are any thing we don't handle via f2c libraries. */
3775   if (specified (FFESTP_readixADVANCE)
3776       || specified (FFESTP_readixEOR)
3777       || specified (FFESTP_readixKEYEQ)
3778       || specified (FFESTP_readixKEYGE)
3779       || specified (FFESTP_readixKEYGT)
3780       || specified (FFESTP_readixKEYID)
3781       || specified (FFESTP_readixNULLS)
3782       || specified (FFESTP_readixSIZE))
3783     {
3784       ffebad_start (FFEBAD_READ_UNSUPPORTED);
3785       ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
3786                    ffelex_token_where_column (ffesta_tokens[0]));
3787       ffebad_finish ();
3788     }
3789
3790 #undef specified
3791 #endif
3792
3793 #if FFECOM_ONEPASS
3794   ffestd_subr_line_now_ ();
3795   ffeste_R909_start (&ffestp_file.read, only_format, unit, format, rec, key);
3796 #else
3797   {
3798     ffestdStmt_ stmt;
3799
3800     stmt = ffestd_stmt_new_ (FFESTD_stmtidR909_);
3801     ffestd_stmt_append_ (stmt);
3802     ffestd_subr_line_save_ (stmt);
3803     stmt->u.R909.pool = ffesta_output_pool;
3804     stmt->u.R909.params = ffestd_subr_copy_read_ ();
3805     stmt->u.R909.only_format = only_format;
3806     stmt->u.R909.unit = unit;
3807     stmt->u.R909.format = format;
3808     stmt->u.R909.rec = rec;
3809     stmt->u.R909.key = key;
3810     stmt->u.R909.list = NULL;
3811     ffestd_expr_list_ = &stmt->u.R909.list;
3812     ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
3813   }
3814 #endif
3815 }
3816
3817 /* ffestd_R909_item -- READ statement i/o item
3818
3819    ffestd_R909_item(expr,expr_token);
3820
3821    Implement output-list expression.  */
3822
3823 void
3824 ffestd_R909_item (ffebld expr, ffelexToken expr_token)
3825 {
3826   ffestd_check_item_ ();
3827
3828 #if FFECOM_ONEPASS
3829   ffeste_R909_item (expr);
3830 #else
3831   {
3832     ffestdExprItem_ item
3833     = (ffestdExprItem_) malloc_new_kp (ffesta_output_pool, "ffestdExprItem_",
3834                                        sizeof (*item));
3835
3836     item->next = NULL;
3837     item->expr = expr;
3838     item->token = ffelex_token_use (expr_token);
3839     *ffestd_expr_list_ = item;
3840     ffestd_expr_list_ = &item->next;
3841   }
3842 #endif
3843 }
3844
3845 /* ffestd_R909_finish -- READ statement list complete
3846
3847    ffestd_R909_finish();
3848
3849    Just wrap up any local activities.  */
3850
3851 void
3852 ffestd_R909_finish ()
3853 {
3854   ffestd_check_finish_ ();
3855
3856 #if FFECOM_ONEPASS
3857   ffeste_R909_finish ();
3858 #else
3859   /* Nothing to do, it's implicit. */
3860 #endif
3861 }
3862
3863 /* ffestd_R910_start -- WRITE(...) statement list begin
3864
3865    ffestd_R910_start();
3866
3867    Verify that WRITE is valid here, and begin accepting items in the
3868    list.  */
3869
3870 void
3871 ffestd_R910_start (ffestvUnit unit, ffestvFormat format, bool rec)
3872 {
3873   ffestd_check_start_ ();
3874
3875 #if FFECOM_targetCURRENT == FFECOM_targetGCC
3876 #define specified(something) \
3877       (ffestp_file.write.write_spec[something].kw_or_val_present)
3878
3879   /* Warn if there are any thing we don't handle via f2c libraries. */
3880   if (specified (FFESTP_writeixADVANCE)
3881       || specified (FFESTP_writeixEOR))
3882     {
3883       ffebad_start (FFEBAD_WRITE_UNSUPPORTED);
3884       ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
3885                    ffelex_token_where_column (ffesta_tokens[0]));
3886       ffebad_finish ();
3887     }
3888
3889 #undef specified
3890 #endif
3891
3892 #if FFECOM_ONEPASS
3893   ffestd_subr_line_now_ ();
3894   ffeste_R910_start (&ffestp_file.write, unit, format, rec);
3895 #else
3896   {
3897     ffestdStmt_ stmt;
3898
3899     stmt = ffestd_stmt_new_ (FFESTD_stmtidR910_);
3900     ffestd_stmt_append_ (stmt);
3901     ffestd_subr_line_save_ (stmt);
3902     stmt->u.R910.pool = ffesta_output_pool;
3903     stmt->u.R910.params = ffestd_subr_copy_write_ ();
3904     stmt->u.R910.unit = unit;
3905     stmt->u.R910.format = format;
3906     stmt->u.R910.rec = rec;
3907     stmt->u.R910.list = NULL;
3908     ffestd_expr_list_ = &stmt->u.R910.list;
3909     ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
3910   }
3911 #endif
3912 }
3913
3914 /* ffestd_R910_item -- WRITE statement i/o item
3915
3916    ffestd_R910_item(expr,expr_token);
3917
3918    Implement output-list expression.  */
3919
3920 void
3921 ffestd_R910_item (ffebld expr, ffelexToken expr_token)
3922 {
3923   ffestd_check_item_ ();
3924
3925 #if FFECOM_ONEPASS
3926   ffeste_R910_item (expr);
3927 #else
3928   {
3929     ffestdExprItem_ item
3930     = (ffestdExprItem_) malloc_new_kp (ffesta_output_pool, "ffestdExprItem_",
3931                                        sizeof (*item));
3932
3933     item->next = NULL;
3934     item->expr = expr;
3935     item->token = ffelex_token_use (expr_token);
3936     *ffestd_expr_list_ = item;
3937     ffestd_expr_list_ = &item->next;
3938   }
3939 #endif
3940 }
3941
3942 /* ffestd_R910_finish -- WRITE statement list complete
3943
3944    ffestd_R910_finish();
3945
3946    Just wrap up any local activities.  */
3947
3948 void
3949 ffestd_R910_finish ()
3950 {
3951   ffestd_check_finish_ ();
3952
3953 #if FFECOM_ONEPASS
3954   ffeste_R910_finish ();
3955 #else
3956   /* Nothing to do, it's implicit. */
3957 #endif
3958 }
3959
3960 /* ffestd_R911_start -- PRINT statement list begin
3961
3962    ffestd_R911_start();
3963
3964    Verify that PRINT is valid here, and begin accepting items in the
3965    list.  */
3966
3967 void
3968 ffestd_R911_start (ffestvFormat format)
3969 {
3970   ffestd_check_start_ ();
3971
3972 #if FFECOM_ONEPASS
3973   ffestd_subr_line_now_ ();
3974   ffeste_R911_start (&ffestp_file.print, format);
3975 #else
3976   {
3977     ffestdStmt_ stmt;
3978
3979     stmt = ffestd_stmt_new_ (FFESTD_stmtidR911_);
3980     ffestd_stmt_append_ (stmt);
3981     ffestd_subr_line_save_ (stmt);
3982     stmt->u.R911.pool = ffesta_output_pool;
3983     stmt->u.R911.params = ffestd_subr_copy_print_ ();
3984     stmt->u.R911.format = format;
3985     stmt->u.R911.list = NULL;
3986     ffestd_expr_list_ = &stmt->u.R911.list;
3987     ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
3988   }
3989 #endif
3990 }
3991
3992 /* ffestd_R911_item -- PRINT statement i/o item
3993
3994    ffestd_R911_item(expr,expr_token);
3995
3996    Implement output-list expression.  */
3997
3998 void
3999 ffestd_R911_item (ffebld expr, ffelexToken expr_token)
4000 {
4001   ffestd_check_item_ ();
4002
4003 #if FFECOM_ONEPASS
4004   ffeste_R911_item (expr);
4005 #else
4006   {
4007     ffestdExprItem_ item
4008     = (ffestdExprItem_) malloc_new_kp (ffesta_output_pool, "ffestdExprItem_",
4009                                        sizeof (*item));
4010
4011     item->next = NULL;
4012     item->expr = expr;
4013     item->token = ffelex_token_use (expr_token);
4014     *ffestd_expr_list_ = item;
4015     ffestd_expr_list_ = &item->next;
4016   }
4017 #endif
4018 }
4019
4020 /* ffestd_R911_finish -- PRINT statement list complete
4021
4022    ffestd_R911_finish();
4023
4024    Just wrap up any local activities.  */
4025
4026 void
4027 ffestd_R911_finish ()
4028 {
4029   ffestd_check_finish_ ();
4030
4031 #if FFECOM_ONEPASS
4032   ffeste_R911_finish ();
4033 #else
4034   /* Nothing to do, it's implicit. */
4035 #endif
4036 }
4037
4038 /* ffestd_R919 -- BACKSPACE statement
4039
4040    ffestd_R919();
4041
4042    Make sure a BACKSPACE is valid in the current context, and implement it.  */
4043
4044 void
4045 ffestd_R919 ()
4046 {
4047   ffestd_check_simple_ ();
4048
4049 #if FFECOM_ONEPASS
4050   ffestd_subr_line_now_ ();
4051   ffeste_R919 (&ffestp_file.beru);
4052 #else
4053   {
4054     ffestdStmt_ stmt;
4055
4056     stmt = ffestd_stmt_new_ (FFESTD_stmtidR919_);
4057     ffestd_stmt_append_ (stmt);
4058     ffestd_subr_line_save_ (stmt);
4059     stmt->u.R919.pool = ffesta_output_pool;
4060     stmt->u.R919.params = ffestd_subr_copy_beru_ ();
4061     ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
4062   }
4063 #endif
4064 }
4065
4066 /* ffestd_R920 -- ENDFILE statement
4067
4068    ffestd_R920();
4069
4070    Make sure a ENDFILE is valid in the current context, and implement it.  */
4071
4072 void
4073 ffestd_R920 ()
4074 {
4075   ffestd_check_simple_ ();
4076
4077 #if FFECOM_ONEPASS
4078   ffestd_subr_line_now_ ();
4079   ffeste_R920 (&ffestp_file.beru);
4080 #else
4081   {
4082     ffestdStmt_ stmt;
4083
4084     stmt = ffestd_stmt_new_ (FFESTD_stmtidR920_);
4085     ffestd_stmt_append_ (stmt);
4086     ffestd_subr_line_save_ (stmt);
4087     stmt->u.R920.pool = ffesta_output_pool;
4088     stmt->u.R920.params = ffestd_subr_copy_beru_ ();
4089     ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
4090   }
4091 #endif
4092 }
4093
4094 /* ffestd_R921 -- REWIND statement
4095
4096    ffestd_R921();
4097
4098    Make sure a REWIND is valid in the current context, and implement it.  */
4099
4100 void
4101 ffestd_R921 ()
4102 {
4103   ffestd_check_simple_ ();
4104
4105 #if FFECOM_ONEPASS
4106   ffestd_subr_line_now_ ();
4107   ffeste_R921 (&ffestp_file.beru);
4108 #else
4109   {
4110     ffestdStmt_ stmt;
4111
4112     stmt = ffestd_stmt_new_ (FFESTD_stmtidR921_);
4113     ffestd_stmt_append_ (stmt);
4114     ffestd_subr_line_save_ (stmt);
4115     stmt->u.R921.pool = ffesta_output_pool;
4116     stmt->u.R921.params = ffestd_subr_copy_beru_ ();
4117     ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
4118   }
4119 #endif
4120 }
4121
4122 /* ffestd_R923A -- INQUIRE statement (non-IOLENGTH version)
4123
4124    ffestd_R923A(bool by_file);
4125
4126    Make sure an INQUIRE is valid in the current context, and implement it.  */
4127
4128 void
4129 ffestd_R923A (bool by_file)
4130 {
4131   ffestd_check_simple_ ();
4132
4133 #if FFECOM_targetCURRENT == FFECOM_targetGCC
4134 #define specified(something) \
4135       (ffestp_file.inquire.inquire_spec[something].kw_or_val_present)
4136
4137   /* Warn if there are any thing we don't handle via f2c libraries. */
4138   if (specified (FFESTP_inquireixACTION)
4139       || specified (FFESTP_inquireixCARRIAGECONTROL)
4140       || specified (FFESTP_inquireixDEFAULTFILE)
4141       || specified (FFESTP_inquireixDELIM)
4142       || specified (FFESTP_inquireixKEYED)
4143       || specified (FFESTP_inquireixORGANIZATION)
4144       || specified (FFESTP_inquireixPAD)
4145       || specified (FFESTP_inquireixPOSITION)
4146       || specified (FFESTP_inquireixREAD)
4147       || specified (FFESTP_inquireixREADWRITE)
4148       || specified (FFESTP_inquireixRECORDTYPE)
4149       || specified (FFESTP_inquireixWRITE))
4150     {
4151       ffebad_start (FFEBAD_INQUIRE_UNSUPPORTED);
4152       ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
4153                    ffelex_token_where_column (ffesta_tokens[0]));
4154       ffebad_finish ();
4155     }
4156
4157 #undef specified
4158 #endif
4159
4160 #if FFECOM_ONEPASS
4161   ffestd_subr_line_now_ ();
4162   ffeste_R923A (&ffestp_file.inquire, by_file);
4163 #else
4164   {
4165     ffestdStmt_ stmt;
4166
4167     stmt = ffestd_stmt_new_ (FFESTD_stmtidR923A_);
4168     ffestd_stmt_append_ (stmt);
4169     ffestd_subr_line_save_ (stmt);
4170     stmt->u.R923A.pool = ffesta_output_pool;
4171     stmt->u.R923A.params = ffestd_subr_copy_inquire_ ();
4172     stmt->u.R923A.by_file = by_file;
4173     ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
4174   }
4175 #endif
4176 }
4177
4178 /* ffestd_R923B_start -- INQUIRE(IOLENGTH=expr) statement list begin
4179
4180    ffestd_R923B_start();
4181
4182    Verify that INQUIRE is valid here, and begin accepting items in the
4183    list.  */
4184
4185 void
4186 ffestd_R923B_start ()
4187 {
4188   ffestd_check_start_ ();
4189
4190 #if FFECOM_ONEPASS
4191   ffestd_subr_line_now_ ();
4192   ffeste_R923B_start (&ffestp_file.inquire);
4193 #else
4194   {
4195     ffestdStmt_ stmt;
4196
4197     stmt = ffestd_stmt_new_ (FFESTD_stmtidR923B_);
4198     ffestd_stmt_append_ (stmt);
4199     ffestd_subr_line_save_ (stmt);
4200     stmt->u.R923B.pool = ffesta_output_pool;
4201     stmt->u.R923B.params = ffestd_subr_copy_inquire_ ();
4202     stmt->u.R923B.list = NULL;
4203     ffestd_expr_list_ = &stmt->u.R923B.list;
4204     ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
4205   }
4206 #endif
4207 }
4208
4209 /* ffestd_R923B_item -- INQUIRE statement i/o item
4210
4211    ffestd_R923B_item(expr,expr_token);
4212
4213    Implement output-list expression.  */
4214
4215 void
4216 ffestd_R923B_item (ffebld expr)
4217 {
4218   ffestd_check_item_ ();
4219
4220 #if FFECOM_ONEPASS
4221   ffeste_R923B_item (expr);
4222 #else
4223   {
4224     ffestdExprItem_ item
4225     = (ffestdExprItem_) malloc_new_kp (ffesta_output_pool, "ffestdExprItem_",
4226                                        sizeof (*item));
4227
4228     item->next = NULL;
4229     item->expr = expr;
4230     *ffestd_expr_list_ = item;
4231     ffestd_expr_list_ = &item->next;
4232   }
4233 #endif
4234 }
4235
4236 /* ffestd_R923B_finish -- INQUIRE statement list complete
4237
4238    ffestd_R923B_finish();
4239
4240    Just wrap up any local activities.  */
4241
4242 void
4243 ffestd_R923B_finish ()
4244 {
4245   ffestd_check_finish_ ();
4246
4247 #if FFECOM_ONEPASS
4248   ffeste_R923B_finish ();
4249 #else
4250   /* Nothing to do, it's implicit. */
4251 #endif
4252 }
4253
4254 /* ffestd_R1001 -- FORMAT statement
4255
4256    ffestd_R1001(format_list);  */
4257
4258 void
4259 ffestd_R1001 (ffesttFormatList f)
4260 {
4261   ffestsHolder str;
4262   ffests s = &str;
4263
4264   ffestd_check_simple_ ();
4265
4266   if (ffestd_label_formatdef_ == NULL)
4267     return;                     /* Nothing to hook it up to (no label def). */
4268
4269   ffests_new (s, malloc_pool_image (), 80);
4270   ffests_putc (s, '(');
4271   ffestd_R1001dump_ (s, f);     /* Build the string in s. */
4272   ffests_putc (s, ')');
4273
4274 #if FFECOM_ONEPASS
4275   ffeste_R1001 (s);
4276   ffests_kill (s);              /* Kill the string in s. */
4277 #else
4278   {
4279     ffestdStmt_ stmt;
4280
4281     stmt = ffestd_stmt_new_ (FFESTD_stmtidR1001_);
4282 #if 0
4283     /* Don't bother with this.  After all, things like cilists also are
4284        declared midway through code-generation.  Perhaps the only problems
4285        the gcc back end has with midway declarations are with stack vars,
4286        maybe only with vars that can be put in registers.  Unless/until the
4287        need is established, handle FORMAT just like cilists and others; at
4288        that point, they'd likely *all* have to be fixed, which would be
4289        very painful anyway.  */
4290     /* Insert FORMAT statement just after the first item on the
4291        statement list, which must be a FORMAT label, which see.  */
4292     assert (ffestd_stmt_list_.first->id == FFESTD_stmtidFORMATLABEL_);
4293     stmt->previous = ffestd_stmt_list_.first;
4294     stmt->next = ffestd_stmt_list_.first->next;
4295     stmt->next->previous = stmt;
4296     stmt->previous->next = stmt;
4297 #else
4298     ffestd_stmt_append_ (stmt);
4299 #endif
4300     stmt->u.R1001.str = str;
4301   }
4302 #endif
4303
4304   ffestd_label_formatdef_ = NULL;
4305 }
4306
4307 /* ffestd_R1001dump_ -- Dump list of formats
4308
4309    ffesttFormatList list;
4310    ffestd_R1001dump_(list,0);
4311
4312    The formats in the list are dumped.  */
4313
4314 static void
4315 ffestd_R1001dump_ (ffests s, ffesttFormatList list)
4316 {
4317   ffesttFormatList next;
4318
4319   for (next = list->next; next != list; next = next->next)
4320     {
4321       if (next != list->next)
4322         ffests_putc (s, ',');
4323       switch (next->type)
4324         {
4325         case FFESTP_formattypeI:
4326           ffestd_R1001dump_1005_3_ (s, next, "I");
4327           break;
4328
4329         case FFESTP_formattypeB:
4330 #if FFECOM_targetCURRENT == FFECOM_targetFFE
4331           ffestd_R1001dump_1005_3_ (s, next, "B");
4332 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
4333           ffestd_R1001error_ (next);
4334 #else
4335 #error
4336 #endif
4337           break;
4338
4339         case FFESTP_formattypeO:
4340           ffestd_R1001dump_1005_3_ (s, next, "O");
4341           break;
4342
4343         case FFESTP_formattypeZ:
4344           ffestd_R1001dump_1005_3_ (s, next, "Z");
4345           break;
4346
4347         case FFESTP_formattypeF:
4348           ffestd_R1001dump_1005_4_ (s, next, "F");
4349           break;
4350
4351         case FFESTP_formattypeE:
4352           ffestd_R1001dump_1005_5_ (s, next, "E");
4353           break;
4354
4355         case FFESTP_formattypeEN:
4356 #if FFECOM_targetCURRENT == FFECOM_targetFFE
4357           ffestd_R1001dump_1005_5_ (s, next, "EN");
4358 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
4359           ffestd_R1001error_ (next);
4360 #else
4361 #error
4362 #endif
4363           break;
4364
4365         case FFESTP_formattypeG:
4366           ffestd_R1001dump_1005_5_ (s, next, "G");
4367           break;
4368
4369         case FFESTP_formattypeL:
4370           ffestd_R1001dump_1005_2_ (s, next, "L");
4371           break;
4372
4373         case FFESTP_formattypeA:
4374           ffestd_R1001dump_1005_1_ (s, next, "A");
4375           break;
4376
4377         case FFESTP_formattypeD:
4378           ffestd_R1001dump_1005_4_ (s, next, "D");
4379           break;
4380
4381         case FFESTP_formattypeQ:
4382 #if FFECOM_targetCURRENT == FFECOM_targetFFE
4383           ffestd_R1001dump_1010_1_ (s, next, "Q");
4384 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
4385           ffestd_R1001error_ (next);
4386 #else
4387 #error
4388 #endif
4389           break;
4390
4391         case FFESTP_formattypeDOLLAR:
4392           ffestd_R1001dump_1010_1_ (s, next, "$");
4393           break;
4394
4395         case FFESTP_formattypeP:
4396           ffestd_R1001dump_1010_4_ (s, next, "P");
4397           break;
4398
4399         case FFESTP_formattypeT:
4400           ffestd_R1001dump_1010_5_ (s, next, "T");
4401           break;
4402
4403         case FFESTP_formattypeTL:
4404           ffestd_R1001dump_1010_5_ (s, next, "TL");
4405           break;
4406
4407         case FFESTP_formattypeTR:
4408           ffestd_R1001dump_1010_5_ (s, next, "TR");
4409           break;
4410
4411         case FFESTP_formattypeX:
4412           ffestd_R1001dump_1010_3_ (s, next, "X");
4413           break;
4414
4415         case FFESTP_formattypeS:
4416           ffestd_R1001dump_1010_1_ (s, next, "S");
4417           break;
4418
4419         case FFESTP_formattypeSP:
4420           ffestd_R1001dump_1010_1_ (s, next, "SP");
4421           break;
4422
4423         case FFESTP_formattypeSS:
4424           ffestd_R1001dump_1010_1_ (s, next, "SS");
4425           break;
4426
4427         case FFESTP_formattypeBN:
4428           ffestd_R1001dump_1010_1_ (s, next, "BN");
4429           break;
4430
4431         case FFESTP_formattypeBZ:
4432           ffestd_R1001dump_1010_1_ (s, next, "BZ");
4433           break;
4434
4435         case FFESTP_formattypeSLASH:
4436           ffestd_R1001dump_1010_2_ (s, next, "/");
4437           break;
4438
4439         case FFESTP_formattypeCOLON:
4440           ffestd_R1001dump_1010_1_ (s, next, ":");
4441           break;
4442
4443         case FFESTP_formattypeR1016:
4444           switch (ffelex_token_type (next->t))
4445             {
4446             case FFELEX_typeCHARACTER:
4447               {
4448                 char *p = ffelex_token_text (next->t);
4449                 ffeTokenLength i = ffelex_token_length (next->t);
4450
4451                 ffests_putc (s, '\002');
4452                 while (i-- != 0)
4453                   {
4454                     if (*p == '\002')
4455                       ffests_putc (s, '\002');
4456                     ffests_putc (s, *p);
4457                     ++p;
4458                   }
4459                 ffests_putc (s, '\002');
4460               }
4461               break;
4462
4463             case FFELEX_typeHOLLERITH:
4464               {
4465                 char *p = ffelex_token_text (next->t);
4466                 ffeTokenLength i = ffelex_token_length (next->t);
4467
4468                 ffests_printf_1U (s,
4469                                   "%" ffeTokenLength_f "uH",
4470                                   i);
4471                 while (i-- != 0)
4472                   {
4473                     ffests_putc (s, *p);
4474                     ++p;
4475                   }
4476               }
4477               break;
4478
4479             default:
4480               assert (FALSE);
4481             }
4482           break;
4483
4484         case FFESTP_formattypeFORMAT:
4485           if (next->u.R1003D.R1004.present)
4486             {
4487               if (next->u.R1003D.R1004.rtexpr)
4488                 ffestd_R1001rtexpr_ (s, next, next->u.R1003D.R1004.u.expr);
4489               else
4490                 ffests_printf_1U (s, "%lu",
4491                                   next->u.R1003D.R1004.u.unsigned_val);
4492             }
4493
4494           ffests_putc (s, '(');
4495           ffestd_R1001dump_ (s, next->u.R1003D.format);
4496           ffests_putc (s, ')');
4497           break;
4498
4499         default:
4500           assert (FALSE);
4501         }
4502     }
4503 }
4504
4505 /* ffestd_R1001dump_1005_1_ -- Dump a particular format
4506
4507    ffesttFormatList f;
4508    ffestd_R1001dump_1005_1_(f,"I");
4509
4510    The format is dumped with form [r]X[w].  */
4511
4512 static void
4513 ffestd_R1001dump_1005_1_ (ffests s, ffesttFormatList f, const char *string)
4514 {
4515   assert (!f->u.R1005.R1007_or_R1008.present);
4516   assert (!f->u.R1005.R1009.present);
4517
4518   if (f->u.R1005.R1004.present)
4519     {
4520       if (f->u.R1005.R1004.rtexpr)
4521         ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1004.u.expr);
4522       else
4523         ffests_printf_1U (s, "%lu", f->u.R1005.R1004.u.unsigned_val);
4524     }
4525
4526   ffests_puts (s, string);
4527
4528   if (f->u.R1005.R1006.present)
4529     {
4530       if (f->u.R1005.R1006.rtexpr)
4531         ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1006.u.expr);
4532       else
4533         ffests_printf_1U (s, "%lu", f->u.R1005.R1006.u.unsigned_val);
4534     }
4535 }
4536
4537 /* ffestd_R1001dump_1005_2_ -- Dump a particular format
4538
4539    ffesttFormatList f;
4540    ffestd_R1001dump_1005_2_(f,"I");
4541
4542    The format is dumped with form [r]Xw.  */
4543
4544 static void
4545 ffestd_R1001dump_1005_2_ (ffests s, ffesttFormatList f, const char *string)
4546 {
4547   assert (!f->u.R1005.R1007_or_R1008.present);
4548   assert (!f->u.R1005.R1009.present);
4549   assert (f->u.R1005.R1006.present);
4550
4551   if (f->u.R1005.R1004.present)
4552     {
4553       if (f->u.R1005.R1004.rtexpr)
4554         ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1004.u.expr);
4555       else
4556         ffests_printf_1U (s, "%lu", f->u.R1005.R1004.u.unsigned_val);
4557     }
4558
4559   ffests_puts (s, string);
4560
4561   if (f->u.R1005.R1006.rtexpr)
4562     ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1006.u.expr);
4563   else
4564     ffests_printf_1U (s, "%lu", f->u.R1005.R1006.u.unsigned_val);
4565 }
4566
4567 /* ffestd_R1001dump_1005_3_ -- Dump a particular format
4568
4569    ffesttFormatList f;
4570    ffestd_R1001dump_1005_3_(f,"I");
4571
4572    The format is dumped with form [r]Xw[.m].  */
4573
4574 static void
4575 ffestd_R1001dump_1005_3_ (ffests s, ffesttFormatList f, const char *string)
4576 {
4577   assert (!f->u.R1005.R1009.present);
4578   assert (f->u.R1005.R1006.present);
4579
4580   if (f->u.R1005.R1004.present)
4581     {
4582       if (f->u.R1005.R1004.rtexpr)
4583         ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1004.u.expr);
4584       else
4585         ffests_printf_1U (s, "%lu", f->u.R1005.R1004.u.unsigned_val);
4586     }
4587
4588   ffests_puts (s, string);
4589
4590   if (f->u.R1005.R1006.rtexpr)
4591     ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1006.u.expr);
4592   else
4593     ffests_printf_1U (s, "%lu", f->u.R1005.R1006.u.unsigned_val);
4594
4595   if (f->u.R1005.R1007_or_R1008.present)
4596     {
4597       ffests_putc (s, '.');
4598       if (f->u.R1005.R1007_or_R1008.rtexpr)
4599         ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1007_or_R1008.u.expr);
4600       else
4601         ffests_printf_1U (s, "%lu",
4602                           f->u.R1005.R1007_or_R1008.u.unsigned_val);
4603     }
4604 }
4605
4606 /* ffestd_R1001dump_1005_4_ -- Dump a particular format
4607
4608    ffesttFormatList f;
4609    ffestd_R1001dump_1005_4_(f,"I");
4610
4611    The format is dumped with form [r]Xw.d.  */
4612
4613 static void
4614 ffestd_R1001dump_1005_4_ (ffests s, ffesttFormatList f, const char *string)
4615 {
4616   assert (!f->u.R1005.R1009.present);
4617   assert (f->u.R1005.R1007_or_R1008.present);
4618   assert (f->u.R1005.R1006.present);
4619
4620   if (f->u.R1005.R1004.present)
4621     {
4622       if (f->u.R1005.R1004.rtexpr)
4623         ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1004.u.expr);
4624       else
4625         ffests_printf_1U (s, "%lu", f->u.R1005.R1004.u.unsigned_val);
4626     }
4627
4628   ffests_puts (s, string);
4629
4630   if (f->u.R1005.R1006.rtexpr)
4631     ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1006.u.expr);
4632   else
4633     ffests_printf_1U (s, "%lu", f->u.R1005.R1006.u.unsigned_val);
4634
4635   ffests_putc (s, '.');
4636   if (f->u.R1005.R1007_or_R1008.rtexpr)
4637     ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1007_or_R1008.u.expr);
4638   else
4639     ffests_printf_1U (s, "%lu", f->u.R1005.R1007_or_R1008.u.unsigned_val);
4640 }
4641
4642 /* ffestd_R1001dump_1005_5_ -- Dump a particular format
4643
4644    ffesttFormatList f;
4645    ffestd_R1001dump_1005_5_(f,"I");
4646
4647    The format is dumped with form [r]Xw.d[Ee].  */
4648
4649 static void
4650 ffestd_R1001dump_1005_5_ (ffests s, ffesttFormatList f, const char *string)
4651 {
4652   assert (f->u.R1005.R1007_or_R1008.present);
4653   assert (f->u.R1005.R1006.present);
4654
4655   if (f->u.R1005.R1004.present)
4656     {
4657       if (f->u.R1005.R1004.rtexpr)
4658         ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1004.u.expr);
4659       else
4660         ffests_printf_1U (s, "%lu", f->u.R1005.R1004.u.unsigned_val);
4661     }
4662
4663   ffests_puts (s, string);
4664
4665   if (f->u.R1005.R1006.rtexpr)
4666     ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1006.u.expr);
4667   else
4668     ffests_printf_1U (s, "%lu", f->u.R1005.R1006.u.unsigned_val);
4669
4670   ffests_putc (s, '.');
4671   if (f->u.R1005.R1007_or_R1008.rtexpr)
4672     ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1007_or_R1008.u.expr);
4673   else
4674     ffests_printf_1U (s, "%lu", f->u.R1005.R1007_or_R1008.u.unsigned_val);
4675
4676   if (f->u.R1005.R1009.present)
4677     {
4678       ffests_putc (s, 'E');
4679       if (f->u.R1005.R1009.rtexpr)
4680         ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1009.u.expr);
4681       else
4682         ffests_printf_1U (s, "%lu", f->u.R1005.R1009.u.unsigned_val);
4683     }
4684 }
4685
4686 /* ffestd_R1001dump_1010_1_ -- Dump a particular format
4687
4688    ffesttFormatList f;
4689    ffestd_R1001dump_1010_1_(f,"I");
4690
4691    The format is dumped with form X.  */
4692
4693 static void
4694 ffestd_R1001dump_1010_1_ (ffests s, ffesttFormatList f, const char *string)
4695 {
4696   assert (!f->u.R1010.val.present);
4697
4698   ffests_puts (s, string);
4699 }
4700
4701 /* ffestd_R1001dump_1010_2_ -- Dump a particular format
4702
4703    ffesttFormatList f;
4704    ffestd_R1001dump_1010_2_(f,"I");
4705
4706    The format is dumped with form [r]X.  */
4707
4708 static void
4709 ffestd_R1001dump_1010_2_ (ffests s, ffesttFormatList f, const char *string)
4710 {
4711   if (f->u.R1010.val.present)
4712     {
4713       if (f->u.R1010.val.rtexpr)
4714         ffestd_R1001rtexpr_ (s, f, f->u.R1010.val.u.expr);
4715       else
4716         ffests_printf_1U (s, "%lu", f->u.R1010.val.u.unsigned_val);
4717     }
4718
4719   ffests_puts (s, string);
4720 }
4721
4722 /* ffestd_R1001dump_1010_3_ -- Dump a particular format
4723
4724    ffesttFormatList f;
4725    ffestd_R1001dump_1010_3_(f,"I");
4726
4727    The format is dumped with form nX.  */
4728
4729 static void
4730 ffestd_R1001dump_1010_3_ (ffests s, ffesttFormatList f, const char *string)
4731 {
4732   assert (f->u.R1010.val.present);
4733
4734   if (f->u.R1010.val.rtexpr)
4735     ffestd_R1001rtexpr_ (s, f, f->u.R1010.val.u.expr);
4736   else
4737     ffests_printf_1U (s, "%lu", f->u.R1010.val.u.unsigned_val);
4738
4739   ffests_puts (s, string);
4740 }
4741
4742 /* ffestd_R1001dump_1010_4_ -- Dump a particular format
4743
4744    ffesttFormatList f;
4745    ffestd_R1001dump_1010_4_(f,"I");
4746
4747    The format is dumped with form kX.  Note that k is signed.  */
4748
4749 static void
4750 ffestd_R1001dump_1010_4_ (ffests s, ffesttFormatList f, const char *string)
4751 {
4752   assert (f->u.R1010.val.present);
4753
4754   if (f->u.R1010.val.rtexpr)
4755     ffestd_R1001rtexpr_ (s, f, f->u.R1010.val.u.expr);
4756   else
4757     ffests_printf_1D (s, "%ld", f->u.R1010.val.u.signed_val);
4758
4759   ffests_puts (s, string);
4760 }
4761
4762 /* ffestd_R1001dump_1010_5_ -- Dump a particular format
4763
4764    ffesttFormatList f;
4765    ffestd_R1001dump_1010_5_(f,"I");
4766
4767    The format is dumped with form Xn.  */
4768
4769 static void
4770 ffestd_R1001dump_1010_5_ (ffests s, ffesttFormatList f, const char *string)
4771 {
4772   assert (f->u.R1010.val.present);
4773
4774   ffests_puts (s, string);
4775
4776   if (f->u.R1010.val.rtexpr)
4777     ffestd_R1001rtexpr_ (s, f, f->u.R1010.val.u.expr);
4778   else
4779     ffests_printf_1U (s, "%lu", f->u.R1010.val.u.unsigned_val);
4780 }
4781
4782 /* ffestd_R1001error_ -- Complain about FORMAT specification not supported
4783
4784    ffesttFormatList f;
4785    ffestd_R1001error_(f);
4786
4787    An error message is produced.  */
4788
4789 static void
4790 ffestd_R1001error_ (ffesttFormatList f)
4791 {
4792   ffebad_start (FFEBAD_FORMAT_UNSUPPORTED);
4793   ffebad_here (0, ffelex_token_where_line (f->t), ffelex_token_where_column (f->t));
4794   ffebad_finish ();
4795 }
4796
4797 static void
4798 ffestd_R1001rtexpr_ (ffests s, ffesttFormatList f, ffebld expr)
4799 {
4800   if ((expr == NULL)
4801       || (ffebld_op (expr) != FFEBLD_opCONTER)
4802       || (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeINTEGER)
4803       || (ffeinfo_kindtype (ffebld_info (expr)) == FFEINFO_kindtypeINTEGER4))
4804     {
4805       ffebad_start (FFEBAD_FORMAT_VARIABLE);
4806       ffebad_here (0, ffelex_token_where_line (f->t), ffelex_token_where_column (f->t));
4807       ffebad_finish ();
4808     }
4809   else
4810     {
4811       int val;
4812
4813       switch (ffeinfo_kindtype (ffebld_info (expr)))
4814         {
4815 #if FFETARGET_okINTEGER1
4816         case FFEINFO_kindtypeINTEGER1:
4817           val = ffebld_constant_integer1 (ffebld_conter (expr));
4818           break;
4819 #endif
4820
4821 #if FFETARGET_okINTEGER2
4822         case FFEINFO_kindtypeINTEGER2:
4823           val = ffebld_constant_integer2 (ffebld_conter (expr));
4824           break;
4825 #endif
4826
4827 #if FFETARGET_okINTEGER3
4828         case FFEINFO_kindtypeINTEGER3:
4829           val = ffebld_constant_integer3 (ffebld_conter (expr));
4830           break;
4831 #endif
4832
4833         default:
4834           assert ("bad INTEGER constant kind type" == NULL);
4835           /* Fall through. */
4836         case FFEINFO_kindtypeANY:
4837           return;
4838         }
4839       ffests_printf_1D (s, "%ld", val);
4840     }
4841 }
4842
4843 /* ffestd_R1102 -- PROGRAM statement
4844
4845    ffestd_R1102(name_token);
4846
4847    Make sure ffestd_kind_ identifies an empty block.  Make sure name_token
4848    gives a valid name.  Implement the beginning of a main program.  */
4849
4850 void
4851 ffestd_R1102 (ffesymbol s, ffelexToken name UNUSED)
4852 {
4853   ffestd_check_simple_ ();
4854
4855   assert (ffestd_block_level_ == 0);
4856   ffestd_is_reachable_ = TRUE;
4857
4858   ffecom_notify_primary_entry (s);
4859   ffe_set_is_mainprog (TRUE);   /* Is a main program. */
4860   ffe_set_is_saveall (TRUE);    /* Main program always has implicit SAVE. */
4861
4862   ffestw_set_sym (ffestw_stack_top (), s);
4863
4864 #if FFECOM_targetCURRENT == FFECOM_targetFFE
4865   if (name == NULL)
4866     fputs ("< PROGRAM_unnamed\n", dmpout);
4867   else
4868     fprintf (dmpout, "< PROGRAM %s\n", ffelex_token_text (name));
4869 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
4870 #else
4871 #error
4872 #endif
4873 }
4874
4875 /* ffestd_R1103 -- End a PROGRAM
4876
4877    ffestd_R1103();  */
4878
4879 void
4880 ffestd_R1103 (bool ok UNUSED)
4881 {
4882   assert (ffestd_block_level_ == 0);
4883
4884   if (FFESTD_IS_END_OPTIMIZED_ && ffestd_is_reachable_)
4885     ffestd_R842 (NULL);         /* Generate STOP. */
4886
4887   if (ffestw_state (ffestw_stack_top ()) != FFESTV_statePROGRAM5)
4888     ffestd_subr_labels_ (FALSE);/* Handle any undefined labels. */
4889
4890 #if FFECOM_ONEPASS
4891   ffeste_R1103 ();
4892 #else
4893   {
4894     ffestdStmt_ stmt;
4895
4896     stmt = ffestd_stmt_new_ (FFESTD_stmtidR1103_);
4897     ffestd_stmt_append_ (stmt);
4898   }
4899 #endif
4900 }
4901
4902 /* ffestd_R1105 -- MODULE statement
4903
4904    ffestd_R1105(name_token);
4905
4906    Make sure ffestd_kind_ identifies an empty block.  Make sure name_token
4907    gives a valid name.  Implement the beginning of a module.  */
4908
4909 #if FFESTR_F90
4910 void
4911 ffestd_R1105 (ffelexToken name)
4912 {
4913   assert (ffestd_block_level_ == 0);
4914
4915   ffestd_check_simple_ ();
4916
4917   ffestd_subr_f90_ ();
4918   return;
4919
4920 #ifdef FFESTD_F90
4921   fprintf (dmpout, "* MODULE %s\n", ffelex_token_text (name));
4922 #endif
4923 }
4924
4925 /* ffestd_R1106 -- End a MODULE
4926
4927    ffestd_R1106(TRUE);  */
4928
4929 void
4930 ffestd_R1106 (bool ok)
4931 {
4932   assert (ffestd_block_level_ == 0);
4933
4934   /* Generate any wrap-up code here (unlikely in MODULE!). */
4935
4936   if (ffestw_state (ffestw_stack_top ()) != FFESTV_stateMODULE5)
4937     ffestd_subr_labels_ (TRUE); /* Handle any undefined labels (unlikely). */
4938
4939   return;                       /* F90. */
4940
4941 #ifdef FFESTD_F90
4942   fprintf (dmpout, "< END_MODULE %s\n",
4943            ffelex_token_text (ffestw_name (ffestw_stack_top ())));
4944 #endif
4945 }
4946
4947 /* ffestd_R1107_start -- USE statement list begin
4948
4949    ffestd_R1107_start();
4950
4951    Verify that USE is valid here, and begin accepting items in the list.  */
4952
4953 void
4954 ffestd_R1107_start (ffelexToken name, bool only)
4955 {
4956   ffestd_check_start_ ();
4957
4958   ffestd_subr_f90_ ();
4959   return;
4960
4961 #ifdef FFESTD_F90
4962   fprintf (dmpout, "* USE %s,", ffelex_token_text (name));      /* NB
4963                                                                    _shriek_begin_uses_. */
4964   if (only)
4965     fputs ("only: ", dmpout);
4966 #endif
4967 }
4968
4969 /* ffestd_R1107_item -- USE statement for name
4970
4971    ffestd_R1107_item(local_token,use_token);
4972
4973    Make sure name_token identifies a valid object to be USEed.  local_token
4974    may be NULL if _start_ was called with only==TRUE.  */
4975
4976 void
4977 ffestd_R1107_item (ffelexToken local, ffelexToken use)
4978 {
4979   ffestd_check_item_ ();
4980   assert (use != NULL);
4981
4982   return;                       /* F90. */
4983
4984 #ifdef FFESTD_F90
4985   if (local != NULL)
4986     fprintf (dmpout, "%s=>", ffelex_token_text (local));
4987   fprintf (dmpout, "%s,", ffelex_token_text (use));
4988 #endif
4989 }
4990
4991 /* ffestd_R1107_finish -- USE statement list complete
4992
4993    ffestd_R1107_finish();
4994
4995    Just wrap up any local activities.  */
4996
4997 void
4998 ffestd_R1107_finish ()
4999 {
5000   ffestd_check_finish_ ();
5001
5002   return;                       /* F90. */
5003
5004 #ifdef FFESTD_F90
5005   fputc ('\n', dmpout);
5006 #endif
5007 }
5008
5009 #endif
5010 /* ffestd_R1111 -- BLOCK DATA statement
5011
5012    ffestd_R1111(name_token);
5013
5014    Make sure ffestd_kind_ identifies no current program unit.  If not
5015    NULL, make sure name_token gives a valid name.  Implement the beginning
5016    of a block data program unit.  */
5017
5018 void
5019 ffestd_R1111 (ffesymbol s, ffelexToken name UNUSED)
5020 {
5021   assert (ffestd_block_level_ == 0);
5022   ffestd_is_reachable_ = TRUE;
5023
5024   ffestd_check_simple_ ();
5025
5026   ffecom_notify_primary_entry (s);
5027   ffestw_set_sym (ffestw_stack_top (), s);
5028
5029 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5030   if (name == NULL)
5031     fputs ("< BLOCK_DATA_unnamed\n", dmpout);
5032   else
5033     fprintf (dmpout, "< BLOCK_DATA %s\n", ffelex_token_text (name));
5034 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5035 #else
5036 #error
5037 #endif
5038 }
5039
5040 /* ffestd_R1112 -- End a BLOCK DATA
5041
5042    ffestd_R1112(TRUE);  */
5043
5044 void
5045 ffestd_R1112 (bool ok UNUSED)
5046 {
5047   assert (ffestd_block_level_ == 0);
5048
5049   /* Generate any return-like code here (not likely for BLOCK DATA!). */
5050
5051   if (ffestw_state (ffestw_stack_top ()) != FFESTV_stateBLOCKDATA5)
5052     ffestd_subr_labels_ (TRUE); /* Handle any undefined labels. */
5053
5054 #if FFECOM_ONEPASS
5055   ffeste_R1112 ();
5056 #else
5057   {
5058     ffestdStmt_ stmt;
5059
5060     stmt = ffestd_stmt_new_ (FFESTD_stmtidR1112_);
5061     ffestd_stmt_append_ (stmt);
5062   }
5063 #endif
5064 }
5065
5066 /* ffestd_R1202 -- INTERFACE statement
5067
5068    ffestd_R1202(operator,defined_name);
5069
5070    Make sure ffestd_kind_ identifies an INTERFACE block.
5071    Implement the end of the current interface.
5072
5073    06-Jun-90  JCB  1.1
5074       Allow no operator or name to mean INTERFACE by itself; missed this
5075       valid form when originally doing syntactic analysis code.  */
5076
5077 #if FFESTR_F90
5078 void
5079 ffestd_R1202 (ffestpDefinedOperator operator, ffelexToken name)
5080 {
5081   ffestd_check_simple_ ();
5082
5083   ffestd_subr_f90_ ();
5084   return;
5085
5086 #ifdef FFESTD_F90
5087   switch (operator)
5088     {
5089     case FFESTP_definedoperatorNone:
5090       if (name == NULL)
5091         fputs ("* INTERFACE_unnamed\n", dmpout);
5092       else
5093         fprintf (dmpout, "* INTERFACE %s\n", ffelex_token_text (name));
5094       break;
5095
5096     case FFESTP_definedoperatorOPERATOR:
5097       fprintf (dmpout, "* INTERFACE_OPERATOR (.%s.)\n", ffelex_token_text (name));
5098       break;
5099
5100     case FFESTP_definedoperatorASSIGNMENT:
5101       fputs ("* INTERFACE_ASSIGNMENT (=)\n", dmpout);
5102       break;
5103
5104     case FFESTP_definedoperatorPOWER:
5105       fputs ("* INTERFACE_OPERATOR (**)\n", dmpout);
5106       break;
5107
5108     case FFESTP_definedoperatorMULT:
5109       fputs ("* INTERFACE_OPERATOR (*)\n", dmpout);
5110       break;
5111
5112     case FFESTP_definedoperatorADD:
5113       fputs ("* INTERFACE_OPERATOR (+)\n", dmpout);
5114       break;
5115
5116     case FFESTP_definedoperatorCONCAT:
5117       fputs ("* INTERFACE_OPERATOR (//)\n", dmpout);
5118       break;
5119
5120     case FFESTP_definedoperatorDIVIDE:
5121       fputs ("* INTERFACE_OPERATOR (/)\n", dmpout);
5122       break;
5123
5124     case FFESTP_definedoperatorSUBTRACT:
5125       fputs ("* INTERFACE_OPERATOR (-)\n", dmpout);
5126       break;
5127
5128     case FFESTP_definedoperatorNOT:
5129       fputs ("* INTERFACE_OPERATOR (.not.)\n", dmpout);
5130       break;
5131
5132     case FFESTP_definedoperatorAND:
5133       fputs ("* INTERFACE_OPERATOR (.and.)\n", dmpout);
5134       break;
5135
5136     case FFESTP_definedoperatorOR:
5137       fputs ("* INTERFACE_OPERATOR (.or.)\n", dmpout);
5138       break;
5139
5140     case FFESTP_definedoperatorEQV:
5141       fputs ("* INTERFACE_OPERATOR (.eqv.)\n", dmpout);
5142       break;
5143
5144     case FFESTP_definedoperatorNEQV:
5145       fputs ("* INTERFACE_OPERATOR (.neqv.)\n", dmpout);
5146       break;
5147
5148     case FFESTP_definedoperatorEQ:
5149       fputs ("* INTERFACE_OPERATOR (==)\n", dmpout);
5150       break;
5151
5152     case FFESTP_definedoperatorNE:
5153       fputs ("* INTERFACE_OPERATOR (/=)\n", dmpout);
5154       break;
5155
5156     case FFESTP_definedoperatorLT:
5157       fputs ("* INTERFACE_OPERATOR (<)\n", dmpout);
5158       break;
5159
5160     case FFESTP_definedoperatorLE:
5161       fputs ("* INTERFACE_OPERATOR (<=)\n", dmpout);
5162       break;
5163
5164     case FFESTP_definedoperatorGT:
5165       fputs ("* INTERFACE_OPERATOR (>)\n", dmpout);
5166       break;
5167
5168     case FFESTP_definedoperatorGE:
5169       fputs ("* INTERFACE_OPERATOR (>=)\n", dmpout);
5170       break;
5171
5172     default:
5173       assert (FALSE);
5174       break;
5175     }
5176 #endif
5177 }
5178
5179 /* ffestd_R1203 -- End an INTERFACE
5180
5181    ffestd_R1203(TRUE);  */
5182
5183 void
5184 ffestd_R1203 (bool ok)
5185 {
5186   return;                       /* F90. */
5187
5188 #ifdef FFESTD_F90
5189   fputs ("* END_INTERFACE\n", dmpout);
5190 #endif
5191 }
5192
5193 /* ffestd_R1205_start -- MODULE PROCEDURE statement list begin
5194
5195    ffestd_R1205_start();
5196
5197    Verify that MODULE PROCEDURE is valid here, and begin accepting items in
5198    the list.  */
5199
5200 void
5201 ffestd_R1205_start ()
5202 {
5203   ffestd_check_start_ ();
5204
5205   return;                       /* F90. */
5206
5207 #ifdef FFESTD_F90
5208   fputs ("* MODULE_PROCEDURE ", dmpout);
5209 #endif
5210 }
5211
5212 /* ffestd_R1205_item -- MODULE PROCEDURE statement for name
5213
5214    ffestd_R1205_item(name_token);
5215
5216    Make sure name_token identifies a valid object to be MODULE PROCEDUREed.  */
5217
5218 void
5219 ffestd_R1205_item (ffelexToken name)
5220 {
5221   ffestd_check_item_ ();
5222   assert (name != NULL);
5223
5224   return;                       /* F90. */
5225
5226 #ifdef FFESTD_F90
5227   fprintf (dmpout, "%s,", ffelex_token_text (name));
5228 #endif
5229 }
5230
5231 /* ffestd_R1205_finish -- MODULE PROCEDURE statement list complete
5232
5233    ffestd_R1205_finish();
5234
5235    Just wrap up any local activities.  */
5236
5237 void
5238 ffestd_R1205_finish ()
5239 {
5240   ffestd_check_finish_ ();
5241
5242   return;                       /* F90. */
5243
5244 #ifdef FFESTD_F90
5245   fputc ('\n', dmpout);
5246 #endif
5247 }
5248
5249 #endif
5250 /* ffestd_R1207_start -- EXTERNAL statement list begin
5251
5252    ffestd_R1207_start();
5253
5254    Verify that EXTERNAL is valid here, and begin accepting items in the list.  */
5255
5256 void
5257 ffestd_R1207_start ()
5258 {
5259   ffestd_check_start_ ();
5260
5261 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5262   fputs ("* EXTERNAL (", dmpout);
5263 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5264 #else
5265 #error
5266 #endif
5267 }
5268
5269 /* ffestd_R1207_item -- EXTERNAL statement for name
5270
5271    ffestd_R1207_item(name_token);
5272
5273    Make sure name_token identifies a valid object to be EXTERNALd.  */
5274
5275 void
5276 ffestd_R1207_item (ffelexToken name)
5277 {
5278   ffestd_check_item_ ();
5279   assert (name != NULL);
5280
5281 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5282   fprintf (dmpout, "%s,", ffelex_token_text (name));
5283 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5284 #else
5285 #error
5286 #endif
5287 }
5288
5289 /* ffestd_R1207_finish -- EXTERNAL statement list complete
5290
5291    ffestd_R1207_finish();
5292
5293    Just wrap up any local activities.  */
5294
5295 void
5296 ffestd_R1207_finish ()
5297 {
5298   ffestd_check_finish_ ();
5299
5300 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5301   fputs (")\n", dmpout);
5302 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5303 #else
5304 #error
5305 #endif
5306 }
5307
5308 /* ffestd_R1208_start -- INTRINSIC statement list begin
5309
5310    ffestd_R1208_start();
5311
5312    Verify that INTRINSIC is valid here, and begin accepting items in the list.  */
5313
5314 void
5315 ffestd_R1208_start ()
5316 {
5317   ffestd_check_start_ ();
5318
5319 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5320   fputs ("* INTRINSIC (", dmpout);
5321 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5322 #else
5323 #error
5324 #endif
5325 }
5326
5327 /* ffestd_R1208_item -- INTRINSIC statement for name
5328
5329    ffestd_R1208_item(name_token);
5330
5331    Make sure name_token identifies a valid object to be INTRINSICd.  */
5332
5333 void
5334 ffestd_R1208_item (ffelexToken name)
5335 {
5336   ffestd_check_item_ ();
5337   assert (name != NULL);
5338
5339 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5340   fprintf (dmpout, "%s,", ffelex_token_text (name));
5341 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5342 #else
5343 #error
5344 #endif
5345 }
5346
5347 /* ffestd_R1208_finish -- INTRINSIC statement list complete
5348
5349    ffestd_R1208_finish();
5350
5351    Just wrap up any local activities.  */
5352
5353 void
5354 ffestd_R1208_finish ()
5355 {
5356   ffestd_check_finish_ ();
5357
5358 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5359   fputs (")\n", dmpout);
5360 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5361 #else
5362 #error
5363 #endif
5364 }
5365
5366 /* ffestd_R1212 -- CALL statement
5367
5368    ffestd_R1212(expr,expr_token);
5369
5370    Make sure statement is valid here; implement.  */
5371
5372 void
5373 ffestd_R1212 (ffebld expr)
5374 {
5375   ffestd_check_simple_ ();
5376
5377 #if FFECOM_ONEPASS
5378   ffestd_subr_line_now_ ();
5379   ffeste_R1212 (expr);
5380 #else
5381   {
5382     ffestdStmt_ stmt;
5383
5384     stmt = ffestd_stmt_new_ (FFESTD_stmtidR1212_);
5385     ffestd_stmt_append_ (stmt);
5386     ffestd_subr_line_save_ (stmt);
5387     stmt->u.R1212.pool = ffesta_output_pool;
5388     stmt->u.R1212.expr = expr;
5389     ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
5390   }
5391 #endif
5392 }
5393
5394 /* ffestd_R1213 -- Defined assignment statement
5395
5396    ffestd_R1213(dest_expr,source_expr,source_token);
5397
5398    Make sure the assignment is valid.  */
5399
5400 #if FFESTR_F90
5401 void
5402 ffestd_R1213 (ffebld dest, ffebld source)
5403 {
5404   ffestd_check_simple_ ();
5405
5406   ffestd_subr_f90_ ();
5407   return;
5408
5409 #ifdef FFESTD_F90
5410   fputs ("+ let_defined ", dmpout);
5411   ffebld_dump (dest);
5412   fputs ("=", dmpout);
5413   ffebld_dump (source);
5414   fputc ('\n', dmpout);
5415 #endif
5416 }
5417
5418 #endif
5419 /* ffestd_R1219 -- FUNCTION statement
5420
5421    ffestd_R1219(funcname,arglist,ending_token,kind,kindt,len,lent,
5422          recursive);
5423
5424    Make sure statement is valid here, register arguments for the
5425    function name, and so on.
5426
5427    06-Jun-90  JCB  2.0
5428       Added the kind, len, and recursive arguments.  */
5429
5430 void
5431 ffestd_R1219 (ffesymbol s, ffelexToken funcname UNUSED,
5432               ffesttTokenList args UNUSED, ffestpType type UNUSED,
5433               ffebld kind UNUSED, ffelexToken kindt UNUSED,
5434               ffebld len UNUSED, ffelexToken lent UNUSED,
5435               bool recursive UNUSED, ffelexToken result UNUSED,
5436               bool separate_result UNUSED)
5437 {
5438 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5439   char *a;
5440 #endif
5441
5442   assert (ffestd_block_level_ == 0);
5443   ffestd_is_reachable_ = TRUE;
5444
5445   ffestd_check_simple_ ();
5446
5447   ffecom_notify_primary_entry (s);
5448   ffestw_set_sym (ffestw_stack_top (), s);
5449
5450 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5451   switch (type)
5452     {
5453     case FFESTP_typeINTEGER:
5454       a = "INTEGER";
5455       break;
5456
5457     case FFESTP_typeBYTE:
5458       a = "BYTE";
5459       break;
5460
5461     case FFESTP_typeWORD:
5462       a = "WORD";
5463       break;
5464
5465     case FFESTP_typeREAL:
5466       a = "REAL";
5467       break;
5468
5469     case FFESTP_typeCOMPLEX:
5470       a = "COMPLEX";
5471       break;
5472
5473     case FFESTP_typeLOGICAL:
5474       a = "LOGICAL";
5475       break;
5476
5477     case FFESTP_typeCHARACTER:
5478       a = "CHARACTER";
5479       break;
5480
5481     case FFESTP_typeDBLPRCSN:
5482       a = "DOUBLE PRECISION";
5483       break;
5484
5485     case FFESTP_typeDBLCMPLX:
5486       a = "DOUBLE COMPLEX";
5487       break;
5488
5489 #if FFESTR_F90
5490     case FFESTP_typeTYPE:
5491       a = "TYPE";
5492       break;
5493 #endif
5494
5495     case FFESTP_typeNone:
5496       a = "";
5497       break;
5498
5499     default:
5500       assert (FALSE);
5501       a = "?";
5502       break;
5503     }
5504   fprintf (dmpout, "< FUNCTION %s ", ffelex_token_text (funcname));
5505   if (recursive)
5506     fputs ("RECURSIVE ", dmpout);
5507   fprintf (dmpout, "%s(", a);
5508   if (kindt != NULL)
5509     {
5510       fputs ("kind=", dmpout);
5511       if (kind == NULL)
5512         fputs (ffelex_token_text (kindt), dmpout);
5513       else
5514         ffebld_dump (kind);
5515       if (lent != NULL)
5516         fputc (',', dmpout);
5517     }
5518   if (lent != NULL)
5519     {
5520       fputs ("len=", dmpout);
5521       if (len == NULL)
5522         fputs (ffelex_token_text (lent), dmpout);
5523       else
5524         ffebld_dump (len);
5525     }
5526   fprintf (dmpout, ")");
5527   if (args != NULL)
5528     {
5529       fputs (" (", dmpout);
5530       ffestt_tokenlist_dump (args);
5531       fputc (')', dmpout);
5532     }
5533   if (result != NULL)
5534     fprintf (dmpout, " result(%s)", ffelex_token_text (result));
5535   fputc ('\n', dmpout);
5536 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5537 #else
5538 #error
5539 #endif
5540 }
5541
5542 /* ffestd_R1221 -- End a FUNCTION
5543
5544    ffestd_R1221(TRUE);  */
5545
5546 void
5547 ffestd_R1221 (bool ok UNUSED)
5548 {
5549   assert (ffestd_block_level_ == 0);
5550
5551   if (FFESTD_IS_END_OPTIMIZED_ && ffestd_is_reachable_)
5552     ffestd_R1227 (NULL);        /* Generate RETURN. */
5553
5554   if (ffestw_state (ffestw_stack_top ()) != FFESTV_stateFUNCTION5)
5555     ffestd_subr_labels_ (FALSE);/* Handle any undefined labels. */
5556
5557 #if FFECOM_ONEPASS
5558   ffeste_R1221 ();
5559 #else
5560   {
5561     ffestdStmt_ stmt;
5562
5563     stmt = ffestd_stmt_new_ (FFESTD_stmtidR1221_);
5564     ffestd_stmt_append_ (stmt);
5565   }
5566 #endif
5567 }
5568
5569 /* ffestd_R1223 -- SUBROUTINE statement
5570
5571    ffestd_R1223(subrname,arglist,ending_token,recursive_token);
5572
5573    Make sure statement is valid here, register arguments for the
5574    subroutine name, and so on.
5575
5576    06-Jun-90  JCB  2.0
5577       Added the recursive argument.  */
5578
5579 void
5580 ffestd_R1223 (ffesymbol s, ffelexToken subrname UNUSED,
5581               ffesttTokenList args UNUSED, ffelexToken final UNUSED,
5582               bool recursive UNUSED)
5583 {
5584   assert (ffestd_block_level_ == 0);
5585   ffestd_is_reachable_ = TRUE;
5586
5587   ffestd_check_simple_ ();
5588
5589   ffecom_notify_primary_entry (s);
5590   ffestw_set_sym (ffestw_stack_top (), s);
5591
5592 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5593   fprintf (dmpout, "< SUBROUTINE %s ", ffelex_token_text (subrname));
5594   if (recursive)
5595     fputs ("recursive ", dmpout);
5596   if (args != NULL)
5597     {
5598       fputc ('(', dmpout);
5599       ffestt_tokenlist_dump (args);
5600       fputc (')', dmpout);
5601     }
5602   fputc ('\n', dmpout);
5603 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5604 #else
5605 #error
5606 #endif
5607 }
5608
5609 /* ffestd_R1225 -- End a SUBROUTINE
5610
5611    ffestd_R1225(TRUE);  */
5612
5613 void
5614 ffestd_R1225 (bool ok UNUSED)
5615 {
5616   assert (ffestd_block_level_ == 0);
5617
5618   if (FFESTD_IS_END_OPTIMIZED_ && ffestd_is_reachable_)
5619     ffestd_R1227 (NULL);        /* Generate RETURN. */
5620
5621   if (ffestw_state (ffestw_stack_top ()) != FFESTV_stateSUBROUTINE5)
5622     ffestd_subr_labels_ (FALSE);/* Handle any undefined labels. */
5623
5624 #if FFECOM_ONEPASS
5625   ffeste_R1225 ();
5626 #else
5627   {
5628     ffestdStmt_ stmt;
5629
5630     stmt = ffestd_stmt_new_ (FFESTD_stmtidR1225_);
5631     ffestd_stmt_append_ (stmt);
5632   }
5633 #endif
5634 }
5635
5636 /* ffestd_R1226 -- ENTRY statement
5637
5638    ffestd_R1226(entryname,arglist,ending_token);
5639
5640    Make sure we're in a SUBROUTINE or FUNCTION, register arguments for the
5641    entry point name, and so on.  */
5642
5643 void
5644 ffestd_R1226 (ffesymbol entry)
5645 {
5646   ffestd_check_simple_ ();
5647
5648 #if (FFECOM_targetCURRENT == FFECOM_targetFFE) || FFECOM_ONEPASS
5649   ffestd_subr_line_now_ ();
5650   ffeste_R1226 (entry);
5651 #else
5652   if (!ffesta_seen_first_exec || ffecom_2pass_advise_entrypoint (entry))
5653     {
5654       ffestdStmt_ stmt;
5655
5656       stmt = ffestd_stmt_new_ (FFESTD_stmtidR1226_);
5657       ffestd_stmt_append_ (stmt);
5658       ffestd_subr_line_save_ (stmt);
5659       stmt->u.R1226.entry = entry;
5660       stmt->u.R1226.entrynum = ++ffestd_2pass_entrypoints_;
5661     }
5662 #endif
5663
5664   ffestd_is_reachable_ = TRUE;
5665 }
5666
5667 /* ffestd_R1227 -- RETURN statement
5668
5669    ffestd_R1227(expr);
5670
5671    Make sure statement is valid here; implement.  expr and expr_token are
5672    both NULL if there was no expression.  */
5673
5674 void
5675 ffestd_R1227 (ffebld expr)
5676 {
5677   ffestd_check_simple_ ();
5678
5679 #if FFECOM_ONEPASS
5680   ffestd_subr_line_now_ ();
5681   ffeste_R1227 (ffestw_stack_top (), expr);
5682 #else
5683   {
5684     ffestdStmt_ stmt;
5685
5686     stmt = ffestd_stmt_new_ (FFESTD_stmtidR1227_);
5687     ffestd_stmt_append_ (stmt);
5688     ffestd_subr_line_save_ (stmt);
5689     stmt->u.R1227.pool = ffesta_output_pool;
5690     stmt->u.R1227.block = ffestw_stack_top ();
5691     stmt->u.R1227.expr = expr;
5692     ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
5693   }
5694 #endif
5695
5696   if (ffestd_block_level_ == 0)
5697     ffestd_is_reachable_ = FALSE;
5698 }
5699
5700 /* ffestd_R1228 -- CONTAINS statement
5701
5702    ffestd_R1228();  */
5703
5704 #if FFESTR_F90
5705 void
5706 ffestd_R1228 ()
5707 {
5708   assert (ffestd_block_level_ == 0);
5709
5710   ffestd_check_simple_ ();
5711
5712   /* Generate RETURN/STOP code here */
5713
5714   ffestd_subr_labels_ (ffestw_state (ffestw_stack_top ())
5715                        == FFESTV_stateMODULE5); /* Handle any undefined
5716                                                    labels. */
5717
5718   ffestd_subr_f90_ ();
5719   return;
5720
5721 #ifdef FFESTD_F90
5722   fputs ("- CONTAINS\n", dmpout);
5723 #endif
5724 }
5725
5726 #endif
5727 /* ffestd_R1229_start -- STMTFUNCTION statement begin
5728
5729    ffestd_R1229_start(func_name,func_arg_list,close_paren);
5730
5731    This function does not really need to do anything, since _finish_
5732    gets all the info needed, and ffestc_R1229_start has already
5733    done all the stuff that makes a two-phase operation (start and
5734    finish) for handling statement functions necessary.
5735
5736    03-Jan-91  JCB  2.0
5737       Do nothing, now that _finish_ does everything.  */
5738
5739 void
5740 ffestd_R1229_start (ffelexToken name UNUSED, ffesttTokenList args UNUSED)
5741 {
5742   ffestd_check_start_ ();
5743
5744 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5745 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5746 #else
5747 #error
5748 #endif
5749 }
5750
5751 /* ffestd_R1229_finish -- STMTFUNCTION statement list complete
5752
5753    ffestd_R1229_finish(s);
5754
5755    The statement function's symbol is passed.  Its list of dummy args is
5756    accessed via ffesymbol_dummyargs and its expansion expression (expr)
5757    is accessed via ffesymbol_sfexpr.
5758
5759    If sfexpr is NULL, an error occurred parsing the expansion expression, so
5760    just cancel the effects of ffestd_R1229_start and pretend nothing
5761    happened.  Otherwise, install the expression as the expansion for the
5762    statement function, then clean up.
5763
5764    03-Jan-91  JCB  2.0
5765       Takes sfunc sym instead of just the expansion expression as an
5766       argument, so this function can do all the work, and _start_ is just
5767       a nicety than can do nothing in a back end.  */
5768
5769 void
5770 ffestd_R1229_finish (ffesymbol s)
5771 {
5772 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5773   ffebld args = ffesymbol_dummyargs (s);
5774 #endif
5775   ffebld expr = ffesymbol_sfexpr (s);
5776
5777   ffestd_check_finish_ ();
5778
5779   if (expr == NULL)
5780     return;                     /* Nothing to do, definition didn't work. */
5781
5782 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5783   fprintf (dmpout, "* stmtfunction %s(", ffesymbol_text (s));
5784   for (; args != NULL; args = ffebld_trail (args))
5785     fprintf (dmpout, "%s,", ffesymbol_text (ffebld_symter (ffebld_head (args))));
5786   fputs (")=", dmpout);
5787   ffebld_dump (expr);
5788   fputc ('\n', dmpout);
5789 #if 0                           /* Normally no need to preserve the
5790                                    expression. */
5791   ffesymbol_set_sfexpr (s, NULL);       /* Except expr.c sees NULL
5792                                            as recursive reference!
5793                                            So until we can use something
5794                                            convenient, like a "permanent"
5795                                            expression, don't worry about
5796                                            wasting some memory in the
5797                                            stand-alone FFE. */
5798 #else
5799   ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
5800 #endif
5801 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5802   /* With gcc, cannot do anything here, because the backend hasn't even
5803      (necessarily) been notified that we're compiling a program unit! */
5804
5805 #if 0                           /* Must preserve the expression for gcc. */
5806   ffesymbol_set_sfexpr (s, NULL);
5807 #else
5808   ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
5809 #endif
5810 #else
5811 #error
5812 #endif
5813 }
5814
5815 /* ffestd_S3P4 -- INCLUDE line
5816
5817    ffestd_S3P4(filename,filename_token);
5818
5819    Make sure INCLUDE not preceded by any semicolons or a label def; implement.  */
5820
5821 void
5822 ffestd_S3P4 (ffebld filename)
5823 {
5824   FILE *fi;
5825   ffetargetCharacterDefault buildname;
5826   ffewhereFile wf;
5827
5828   ffestd_check_simple_ ();
5829
5830   assert (filename != NULL);
5831   if (ffebld_op (filename) != FFEBLD_opANY)
5832     {
5833       assert (ffebld_op (filename) == FFEBLD_opCONTER);
5834       assert (ffeinfo_basictype (ffebld_info (filename))
5835               == FFEINFO_basictypeCHARACTER);
5836       assert (ffeinfo_kindtype (ffebld_info (filename))
5837               == FFEINFO_kindtypeCHARACTERDEFAULT);
5838       buildname = ffebld_constant_characterdefault (ffebld_conter (filename));
5839       wf = ffewhere_file_new (ffetarget_text_characterdefault (buildname),
5840                               ffetarget_length_characterdefault (buildname));
5841       fi = ffecom_open_include (ffewhere_file_name (wf),
5842                                 ffelex_token_where_line (ffesta_tokens[0]),
5843                                 ffelex_token_where_column (ffesta_tokens[0]));
5844       if (fi == NULL)
5845         ffewhere_file_kill (wf);
5846       else
5847         ffelex_set_include (wf, (ffelex_token_type (ffesta_tokens[0])
5848                                  == FFELEX_typeNAME), fi);
5849     }
5850 }
5851
5852 /* ffestd_V003_start -- STRUCTURE statement list begin
5853
5854    ffestd_V003_start(structure_name);
5855
5856    Verify that STRUCTURE is valid here, and begin accepting items in the list.  */
5857
5858 #if FFESTR_VXT
5859 void
5860 ffestd_V003_start (ffelexToken structure_name)
5861 {
5862   ffestd_check_start_ ();
5863
5864 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5865   if (structure_name == NULL)
5866     fputs ("* STRUCTURE_unnamed ", dmpout);
5867   else
5868     fprintf (dmpout, "* STRUCTURE %s ", ffelex_token_text (structure_name));
5869 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5870   ffestd_subr_vxt_ ();
5871 #else
5872 #error
5873 #endif
5874 }
5875
5876 /* ffestd_V003_item -- STRUCTURE statement for object-name
5877
5878    ffestd_V003_item(name_token,dim_list);
5879
5880    Make sure name_token identifies a valid object to be STRUCTUREd.  */
5881
5882 void
5883 ffestd_V003_item (ffelexToken name, ffesttDimList dims)
5884 {
5885   ffestd_check_item_ ();
5886
5887 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5888   fputs (ffelex_token_text (name), dmpout);
5889   if (dims != NULL)
5890     {
5891       fputc ('(', dmpout);
5892       ffestt_dimlist_dump (dims);
5893       fputc (')', dmpout);
5894     }
5895   fputc (',', dmpout);
5896 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5897 #else
5898 #error
5899 #endif
5900 }
5901
5902 /* ffestd_V003_finish -- STRUCTURE statement list complete
5903
5904    ffestd_V003_finish();
5905
5906    Just wrap up any local activities.  */
5907
5908 void
5909 ffestd_V003_finish ()
5910 {
5911   ffestd_check_finish_ ();
5912
5913 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5914   fputc ('\n', dmpout);
5915 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5916 #else
5917 #error
5918 #endif
5919 }
5920
5921 /* ffestd_V004 -- End a STRUCTURE
5922
5923    ffestd_V004(TRUE);  */
5924
5925 void
5926 ffestd_V004 (bool ok)
5927 {
5928 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5929   fputs ("* END_STRUCTURE\n", dmpout);
5930 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5931 #else
5932 #error
5933 #endif
5934 }
5935
5936 /* ffestd_V009 -- UNION statement
5937
5938    ffestd_V009();  */
5939
5940 void
5941 ffestd_V009 ()
5942 {
5943   ffestd_check_simple_ ();
5944
5945 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5946   fputs ("* UNION\n", dmpout);
5947 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5948 #else
5949 #error
5950 #endif
5951 }
5952
5953 /* ffestd_V010 -- End a UNION
5954
5955    ffestd_V010(TRUE);  */
5956
5957 void
5958 ffestd_V010 (bool ok)
5959 {
5960 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5961   fputs ("* END_UNION\n", dmpout);
5962 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5963 #else
5964 #error
5965 #endif
5966 }
5967
5968 /* ffestd_V012 -- MAP statement
5969
5970    ffestd_V012();  */
5971
5972 void
5973 ffestd_V012 ()
5974 {
5975   ffestd_check_simple_ ();
5976
5977 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5978   fputs ("* MAP\n", dmpout);
5979 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5980 #else
5981 #error
5982 #endif
5983 }
5984
5985 /* ffestd_V013 -- End a MAP
5986
5987    ffestd_V013(TRUE);  */
5988
5989 void
5990 ffestd_V013 (bool ok)
5991 {
5992 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5993   fputs ("* END_MAP\n", dmpout);
5994 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5995 #else
5996 #error
5997 #endif
5998 }
5999
6000 #endif
6001 /* ffestd_V014_start -- VOLATILE statement list begin
6002
6003    ffestd_V014_start();
6004
6005    Verify that VOLATILE is valid here, and begin accepting items in the list.  */
6006
6007 void
6008 ffestd_V014_start ()
6009 {
6010   ffestd_check_start_ ();
6011
6012 #if FFECOM_targetCURRENT == FFECOM_targetFFE
6013   fputs ("* VOLATILE (", dmpout);
6014 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
6015   ffestd_subr_vxt_ ();
6016 #else
6017 #error
6018 #endif
6019 }
6020
6021 /* ffestd_V014_item_object -- VOLATILE statement for object-name
6022
6023    ffestd_V014_item_object(name_token);
6024
6025    Make sure name_token identifies a valid object to be VOLATILEd.  */
6026
6027 void
6028 ffestd_V014_item_object (ffelexToken name UNUSED)
6029 {
6030   ffestd_check_item_ ();
6031
6032 #if FFECOM_targetCURRENT == FFECOM_targetFFE
6033   fprintf (dmpout, "%s,", ffelex_token_text (name));
6034 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
6035 #else
6036 #error
6037 #endif
6038 }
6039
6040 /* ffestd_V014_item_cblock -- VOLATILE statement for common-block-name
6041
6042    ffestd_V014_item_cblock(name_token);
6043
6044    Make sure name_token identifies a valid common block to be VOLATILEd.  */
6045
6046 void
6047 ffestd_V014_item_cblock (ffelexToken name UNUSED)
6048 {
6049   ffestd_check_item_ ();
6050
6051 #if FFECOM_targetCURRENT == FFECOM_targetFFE
6052   fprintf (dmpout, "/%s/,", ffelex_token_text (name));
6053 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
6054 #else
6055 #error
6056 #endif
6057 }
6058
6059 /* ffestd_V014_finish -- VOLATILE statement list complete
6060
6061    ffestd_V014_finish();
6062
6063    Just wrap up any local activities.  */
6064
6065 void
6066 ffestd_V014_finish ()
6067 {
6068   ffestd_check_finish_ ();
6069
6070 #if FFECOM_targetCURRENT == FFECOM_targetFFE
6071   fputs (")\n", dmpout);
6072 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
6073 #else
6074 #error
6075 #endif
6076 }
6077
6078 /* ffestd_V016_start -- RECORD statement list begin
6079
6080    ffestd_V016_start();
6081
6082    Verify that RECORD is valid here, and begin accepting items in the list.  */
6083
6084 #if FFESTR_VXT
6085 void
6086 ffestd_V016_start ()
6087 {
6088   ffestd_check_start_ ();
6089
6090 #if FFECOM_targetCURRENT == FFECOM_targetFFE
6091   fputs ("* RECORD ", dmpout);
6092 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
6093   ffestd_subr_vxt_ ();
6094 #else
6095 #error
6096 #endif
6097 }
6098
6099 /* ffestd_V016_item_structure -- RECORD statement for common-block-name
6100
6101    ffestd_V016_item_structure(name_token);
6102
6103    Make sure name_token identifies a valid structure to be RECORDed.  */
6104
6105 void
6106 ffestd_V016_item_structure (ffelexToken name)
6107 {
6108   ffestd_check_item_ ();
6109
6110 #if FFECOM_targetCURRENT == FFECOM_targetFFE
6111   fprintf (dmpout, "/%s/,", ffelex_token_text (name));
6112 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
6113 #else
6114 #error
6115 #endif
6116 }
6117
6118 /* ffestd_V016_item_object -- RECORD statement for object-name
6119
6120    ffestd_V016_item_object(name_token,dim_list);
6121
6122    Make sure name_token identifies a valid object to be RECORDd.  */
6123
6124 void
6125 ffestd_V016_item_object (ffelexToken name, ffesttDimList dims)
6126 {
6127   ffestd_check_item_ ();
6128
6129 #if FFECOM_targetCURRENT == FFECOM_targetFFE
6130   fputs (ffelex_token_text (name), dmpout);
6131   if (dims != NULL)
6132     {
6133       fputc ('(', dmpout);
6134       ffestt_dimlist_dump (dims);
6135       fputc (')', dmpout);
6136     }
6137   fputc (',', dmpout);
6138 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
6139 #else
6140 #error
6141 #endif
6142 }
6143
6144 /* ffestd_V016_finish -- RECORD statement list complete
6145
6146    ffestd_V016_finish();
6147
6148    Just wrap up any local activities.  */
6149
6150 void
6151 ffestd_V016_finish ()
6152 {
6153   ffestd_check_finish_ ();
6154
6155 #if FFECOM_targetCURRENT == FFECOM_targetFFE
6156   fputc ('\n', dmpout);
6157 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
6158 #else
6159 #error
6160 #endif
6161 }
6162
6163 /* ffestd_V018_start -- REWRITE(...) statement list begin
6164
6165    ffestd_V018_start();
6166
6167    Verify that REWRITE is valid here, and begin accepting items in the
6168    list.  */
6169
6170 void
6171 ffestd_V018_start (ffestvFormat format)
6172 {
6173   ffestd_check_start_ ();
6174
6175 #if FFECOM_targetCURRENT == FFECOM_targetFFE
6176
6177 #if FFECOM_ONEPASS
6178   ffestd_subr_line_now_ ();
6179   ffeste_V018_start (&ffestp_file.rewrite, format);
6180 #else
6181   {
6182     ffestdStmt_ stmt;
6183
6184     stmt = ffestd_stmt_new_ (FFESTD_stmtidV018_);
6185     ffestd_stmt_append_ (stmt);
6186     ffestd_subr_line_save_ (stmt);
6187     stmt->u.V018.pool = ffesta_output_pool;
6188     stmt->u.V018.params = ffestd_subr_copy_rewrite_ ();
6189     stmt->u.V018.format = format;
6190     stmt->u.V018.list = NULL;
6191     ffestd_expr_list_ = &stmt->u.V018.list;
6192     ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
6193   }
6194 #endif
6195
6196 #endif
6197 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6198   ffestd_subr_vxt_ ();
6199 #endif
6200 }
6201
6202 /* ffestd_V018_item -- REWRITE statement i/o item
6203
6204    ffestd_V018_item(expr,expr_token);
6205
6206    Implement output-list expression.  */
6207
6208 void
6209 ffestd_V018_item (ffebld expr)
6210 {
6211   ffestd_check_item_ ();
6212
6213 #if FFECOM_targetCURRENT == FFECOM_targetFFE
6214
6215 #if FFECOM_ONEPASS
6216   ffeste_V018_item (expr);
6217 #else
6218   {
6219     ffestdExprItem_ item
6220     = (ffestdExprItem_) malloc_new_kp (ffesta_output_pool, "ffestdExprItem_",
6221                                        sizeof (*item));
6222
6223     item->next = NULL;
6224     item->expr = expr;
6225     *ffestd_expr_list_ = item;
6226     ffestd_expr_list_ = &item->next;
6227   }
6228 #endif
6229
6230 #endif
6231 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6232 #endif
6233 }
6234
6235 /* ffestd_V018_finish -- REWRITE statement list complete
6236
6237    ffestd_V018_finish();
6238
6239    Just wrap up any local activities.  */
6240
6241 void
6242 ffestd_V018_finish ()
6243 {
6244   ffestd_check_finish_ ();
6245
6246 #if FFECOM_targetCURRENT == FFECOM_targetFFE
6247
6248 #if FFECOM_ONEPASS
6249   ffeste_V018_finish ();
6250 #else
6251   /* Nothing to do, it's implicit. */
6252 #endif
6253
6254 #endif
6255 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6256 #endif
6257 }
6258
6259 /* ffestd_V019_start -- ACCEPT statement list begin
6260
6261    ffestd_V019_start();
6262
6263    Verify that ACCEPT is valid here, and begin accepting items in the
6264    list.  */
6265
6266 void
6267 ffestd_V019_start (ffestvFormat format)
6268 {
6269   ffestd_check_start_ ();
6270
6271 #if FFECOM_targetCURRENT == FFECOM_targetFFE
6272
6273 #if FFECOM_ONEPASS
6274   ffestd_subr_line_now_ ();
6275   ffeste_V019_start (&ffestp_file.accept, format);
6276 #else
6277   {
6278     ffestdStmt_ stmt;
6279
6280     stmt = ffestd_stmt_new_ (FFESTD_stmtidV019_);
6281     ffestd_stmt_append_ (stmt);
6282     ffestd_subr_line_save_ (stmt);
6283     stmt->u.V019.pool = ffesta_output_pool;
6284     stmt->u.V019.params = ffestd_subr_copy_accept_ ();
6285     stmt->u.V019.format = format;
6286     stmt->u.V019.list = NULL;
6287     ffestd_expr_list_ = &stmt->u.V019.list;
6288     ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
6289   }
6290 #endif
6291
6292 #endif
6293 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6294   ffestd_subr_vxt_ ();
6295 #endif
6296 }
6297
6298 /* ffestd_V019_item -- ACCEPT statement i/o item
6299
6300    ffestd_V019_item(expr,expr_token);
6301
6302    Implement output-list expression.  */
6303
6304 void
6305 ffestd_V019_item (ffebld expr)
6306 {
6307   ffestd_check_item_ ();
6308
6309 #if FFECOM_targetCURRENT == FFECOM_targetFFE
6310
6311 #if FFECOM_ONEPASS
6312   ffeste_V019_item (expr);
6313 #else
6314   {
6315     ffestdExprItem_ item
6316     = (ffestdExprItem_) malloc_new_kp (ffesta_output_pool, "ffestdExprItem_",
6317                                        sizeof (*item));
6318
6319     item->next = NULL;
6320     item->expr = expr;
6321     *ffestd_expr_list_ = item;
6322     ffestd_expr_list_ = &item->next;
6323   }
6324 #endif
6325
6326 #endif
6327 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6328 #endif
6329 }
6330
6331 /* ffestd_V019_finish -- ACCEPT statement list complete
6332
6333    ffestd_V019_finish();
6334
6335    Just wrap up any local activities.  */
6336
6337 void
6338 ffestd_V019_finish ()
6339 {
6340   ffestd_check_finish_ ();
6341
6342 #if FFECOM_targetCURRENT == FFECOM_targetFFE
6343
6344 #if FFECOM_ONEPASS
6345   ffeste_V019_finish ();
6346 #else
6347   /* Nothing to do, it's implicit. */
6348 #endif
6349
6350 #endif
6351 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6352 #endif
6353 }
6354
6355 #endif
6356 /* ffestd_V020_start -- TYPE statement list begin
6357
6358    ffestd_V020_start();
6359
6360    Verify that TYPE is valid here, and begin accepting items in the
6361    list.  */
6362
6363 void
6364 ffestd_V020_start (ffestvFormat format UNUSED)
6365 {
6366   ffestd_check_start_ ();
6367
6368 #if FFECOM_targetCURRENT == FFECOM_targetFFE
6369
6370 #if FFECOM_ONEPASS
6371   ffestd_subr_line_now_ ();
6372   ffeste_V020_start (&ffestp_file.type, format);
6373 #else
6374   {
6375     ffestdStmt_ stmt;
6376
6377     stmt = ffestd_stmt_new_ (FFESTD_stmtidV020_);
6378     ffestd_stmt_append_ (stmt);
6379     ffestd_subr_line_save_ (stmt);
6380     stmt->u.V020.pool = ffesta_output_pool;
6381     stmt->u.V020.params = ffestd_subr_copy_type_ ();
6382     stmt->u.V020.format = format;
6383     stmt->u.V020.list = NULL;
6384     ffestd_expr_list_ = &stmt->u.V020.list;
6385     ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
6386   }
6387 #endif
6388
6389 #endif
6390 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6391   ffestd_subr_vxt_ ();
6392 #endif
6393 }
6394
6395 /* ffestd_V020_item -- TYPE statement i/o item
6396
6397    ffestd_V020_item(expr,expr_token);
6398
6399    Implement output-list expression.  */
6400
6401 void
6402 ffestd_V020_item (ffebld expr UNUSED)
6403 {
6404   ffestd_check_item_ ();
6405
6406 #if FFECOM_targetCURRENT == FFECOM_targetFFE
6407
6408 #if FFECOM_ONEPASS
6409   ffeste_V020_item (expr);
6410 #else
6411   {
6412     ffestdExprItem_ item
6413     = (ffestdExprItem_) malloc_new_kp (ffesta_output_pool, "ffestdExprItem_",
6414                                        sizeof (*item));
6415
6416     item->next = NULL;
6417     item->expr = expr;
6418     *ffestd_expr_list_ = item;
6419     ffestd_expr_list_ = &item->next;
6420   }
6421 #endif
6422
6423 #endif
6424 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6425 #endif
6426 }
6427
6428 /* ffestd_V020_finish -- TYPE statement list complete
6429
6430    ffestd_V020_finish();
6431
6432    Just wrap up any local activities.  */
6433
6434 void
6435 ffestd_V020_finish ()
6436 {
6437   ffestd_check_finish_ ();
6438
6439 #if FFECOM_targetCURRENT == FFECOM_targetFFE
6440
6441 #if FFECOM_ONEPASS
6442   ffeste_V020_finish ();
6443 #else
6444   /* Nothing to do, it's implicit. */
6445 #endif
6446
6447 #endif
6448 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6449 #endif
6450 }
6451
6452 /* ffestd_V021 -- DELETE statement
6453
6454    ffestd_V021();
6455
6456    Make sure a DELETE is valid in the current context, and implement it.  */
6457
6458 #if FFESTR_VXT
6459 void
6460 ffestd_V021 ()
6461 {
6462   ffestd_check_simple_ ();
6463
6464 #if FFECOM_targetCURRENT == FFECOM_targetFFE
6465
6466 #if FFECOM_ONEPASS
6467   ffestd_subr_line_now_ ();
6468   ffeste_V021 (&ffestp_file.delete);
6469 #else
6470   {
6471     ffestdStmt_ stmt;
6472
6473     stmt = ffestd_stmt_new_ (FFESTD_stmtidV021_);
6474     ffestd_stmt_append_ (stmt);
6475     ffestd_subr_line_save_ (stmt);
6476     stmt->u.V021.pool = ffesta_output_pool;
6477     stmt->u.V021.params = ffestd_subr_copy_delete_ ();
6478     ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
6479   }
6480 #endif
6481
6482 #endif
6483 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6484   ffestd_subr_vxt_ ();
6485 #endif
6486 }
6487
6488 /* ffestd_V022 -- UNLOCK statement
6489
6490    ffestd_V022();
6491
6492    Make sure a UNLOCK is valid in the current context, and implement it.  */
6493
6494 void
6495 ffestd_V022 ()
6496 {
6497   ffestd_check_simple_ ();
6498
6499 #if FFECOM_targetCURRENT == FFECOM_targetFFE
6500
6501 #if FFECOM_ONEPASS
6502   ffestd_subr_line_now_ ();
6503   ffeste_V022 (&ffestp_file.beru);
6504 #else
6505   {
6506     ffestdStmt_ stmt;
6507
6508     stmt = ffestd_stmt_new_ (FFESTD_stmtidV022_);
6509     ffestd_stmt_append_ (stmt);
6510     ffestd_subr_line_save_ (stmt);
6511     stmt->u.V022.pool = ffesta_output_pool;
6512     stmt->u.V022.params = ffestd_subr_copy_beru_ ();
6513     ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
6514   }
6515 #endif
6516
6517 #endif
6518 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6519   ffestd_subr_vxt_ ();
6520 #endif
6521 }
6522
6523 /* ffestd_V023_start -- ENCODE(...) statement list begin
6524
6525    ffestd_V023_start();
6526
6527    Verify that ENCODE is valid here, and begin accepting items in the
6528    list.  */
6529
6530 void
6531 ffestd_V023_start ()
6532 {
6533   ffestd_check_start_ ();
6534
6535 #if FFECOM_targetCURRENT == FFECOM_targetFFE
6536
6537 #if FFECOM_ONEPASS
6538   ffestd_subr_line_now_ ();
6539   ffeste_V023_start (&ffestp_file.vxtcode);
6540 #else
6541   {
6542     ffestdStmt_ stmt;
6543
6544     stmt = ffestd_stmt_new_ (FFESTD_stmtidV023_);
6545     ffestd_stmt_append_ (stmt);
6546     ffestd_subr_line_save_ (stmt);
6547     stmt->u.V023.pool = ffesta_output_pool;
6548     stmt->u.V023.params = ffestd_subr_copy_vxtcode_ ();
6549     stmt->u.V023.list = NULL;
6550     ffestd_expr_list_ = &stmt->u.V023.list;
6551     ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
6552   }
6553 #endif
6554
6555 #endif
6556 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6557   ffestd_subr_vxt_ ();
6558 #endif
6559 }
6560
6561 /* ffestd_V023_item -- ENCODE statement i/o item
6562
6563    ffestd_V023_item(expr,expr_token);
6564
6565    Implement output-list expression.  */
6566
6567 void
6568 ffestd_V023_item (ffebld expr)
6569 {
6570   ffestd_check_item_ ();
6571
6572 #if FFECOM_targetCURRENT == FFECOM_targetFFE
6573
6574 #if FFECOM_ONEPASS
6575   ffeste_V023_item (expr);
6576 #else
6577   {
6578     ffestdExprItem_ item
6579     = (ffestdExprItem_) malloc_new_kp (ffesta_output_pool, "ffestdExprItem_",
6580                                        sizeof (*item));
6581
6582     item->next = NULL;
6583     item->expr = expr;
6584     *ffestd_expr_list_ = item;
6585     ffestd_expr_list_ = &item->next;
6586   }
6587 #endif
6588
6589 #endif
6590 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6591 #endif
6592 }
6593
6594 /* ffestd_V023_finish -- ENCODE statement list complete
6595
6596    ffestd_V023_finish();
6597
6598    Just wrap up any local activities.  */
6599
6600 void
6601 ffestd_V023_finish ()
6602 {
6603   ffestd_check_finish_ ();
6604
6605 #if FFECOM_targetCURRENT == FFECOM_targetFFE
6606
6607 #if FFECOM_ONEPASS
6608   ffeste_V023_finish ();
6609 #else
6610   /* Nothing to do, it's implicit. */
6611 #endif
6612
6613 #endif
6614 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6615 #endif
6616 }
6617
6618 /* ffestd_V024_start -- DECODE(...) statement list begin
6619
6620    ffestd_V024_start();
6621
6622    Verify that DECODE is valid here, and begin accepting items in the
6623    list.  */
6624
6625 void
6626 ffestd_V024_start ()
6627 {
6628   ffestd_check_start_ ();
6629
6630 #if FFECOM_targetCURRENT == FFECOM_targetFFE
6631
6632 #if FFECOM_ONEPASS
6633   ffestd_subr_line_now_ ();
6634   ffeste_V024_start (&ffestp_file.vxtcode);
6635 #else
6636   {
6637     ffestdStmt_ stmt;
6638
6639     stmt = ffestd_stmt_new_ (FFESTD_stmtidV024_);
6640     ffestd_stmt_append_ (stmt);
6641     ffestd_subr_line_save_ (stmt);
6642     stmt->u.V024.pool = ffesta_output_pool;
6643     stmt->u.V024.params = ffestd_subr_copy_vxtcode_ ();
6644     stmt->u.V024.list = NULL;
6645     ffestd_expr_list_ = &stmt->u.V024.list;
6646     ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
6647   }
6648 #endif
6649
6650 #endif
6651 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6652   ffestd_subr_vxt_ ();
6653 #endif
6654 }
6655
6656 /* ffestd_V024_item -- DECODE statement i/o item
6657
6658    ffestd_V024_item(expr,expr_token);
6659
6660    Implement output-list expression.  */
6661
6662 void
6663 ffestd_V024_item (ffebld expr)
6664 {
6665   ffestd_check_item_ ();
6666
6667 #if FFECOM_targetCURRENT == FFECOM_targetFFE
6668
6669 #if FFECOM_ONEPASS
6670   ffeste_V024_item (expr);
6671 #else
6672   {
6673     ffestdExprItem_ item
6674     = (ffestdExprItem_) malloc_new_kp (ffesta_output_pool, "ffestdExprItem_",
6675                                        sizeof (*item));
6676
6677     item->next = NULL;
6678     item->expr = expr;
6679     *ffestd_expr_list_ = item;
6680     ffestd_expr_list_ = &item->next;
6681   }
6682 #endif
6683
6684 #endif
6685 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6686 #endif
6687 }
6688
6689 /* ffestd_V024_finish -- DECODE statement list complete
6690
6691    ffestd_V024_finish();
6692
6693    Just wrap up any local activities.  */
6694
6695 void
6696 ffestd_V024_finish ()
6697 {
6698   ffestd_check_finish_ ();
6699
6700 #if FFECOM_targetCURRENT == FFECOM_targetFFE
6701
6702 #if FFECOM_ONEPASS
6703   ffeste_V024_finish ();
6704 #else
6705   /* Nothing to do, it's implicit. */
6706 #endif
6707
6708 #endif
6709 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6710 #endif
6711 }
6712
6713 /* ffestd_V025_start -- DEFINEFILE statement list begin
6714
6715    ffestd_V025_start();
6716
6717    Verify that DEFINEFILE is valid here, and begin accepting items in the
6718    list.  */
6719
6720 void
6721 ffestd_V025_start ()
6722 {
6723   ffestd_check_start_ ();
6724
6725 #if FFECOM_targetCURRENT == FFECOM_targetFFE
6726
6727 #if FFECOM_ONEPASS
6728   ffestd_subr_line_now_ ();
6729   ffeste_V025_start ();
6730 #else
6731   {
6732     ffestdStmt_ stmt;
6733
6734     stmt = ffestd_stmt_new_ (FFESTD_stmtidV025start_);
6735     ffestd_stmt_append_ (stmt);
6736     ffestd_subr_line_save_ (stmt);
6737     ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
6738   }
6739 #endif
6740
6741 #endif
6742 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6743   ffestd_subr_vxt_ ();
6744 #endif
6745 }
6746
6747 /* ffestd_V025_item -- DEFINE FILE statement item
6748
6749    ffestd_V025_item(u,ut,m,mt,n,nt,asv,asvt);
6750
6751    Implement item.  Treat each item kind of like a separate statement,
6752    since there's really no need to treat them as an aggregate.  */
6753
6754 void
6755 ffestd_V025_item (ffebld u, ffebld m, ffebld n, ffebld asv)
6756 {
6757   ffestd_check_item_ ();
6758
6759 #if FFECOM_targetCURRENT == FFECOM_targetFFE
6760
6761 #if FFECOM_ONEPASS
6762   ffeste_V025_item (u, m, n, asv);
6763 #else
6764   {
6765     ffestdStmt_ stmt;
6766
6767     stmt = ffestd_stmt_new_ (FFESTD_stmtidV025item_);
6768     ffestd_stmt_append_ (stmt);
6769     stmt->u.V025item.u = u;
6770     stmt->u.V025item.m = m;
6771     stmt->u.V025item.n = n;
6772     stmt->u.V025item.asv = asv;
6773   }
6774 #endif
6775
6776 #endif
6777 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6778 #endif
6779 }
6780
6781 /* ffestd_V025_finish -- DEFINE FILE statement list complete
6782
6783    ffestd_V025_finish();
6784
6785    Just wrap up any local activities.  */
6786
6787 void
6788 ffestd_V025_finish ()
6789 {
6790   ffestd_check_finish_ ();
6791
6792 #if FFECOM_targetCURRENT == FFECOM_targetFFE
6793
6794 #if FFECOM_ONEPASS
6795   ffeste_V025_finish ();
6796 #else
6797   {
6798     ffestdStmt_ stmt;
6799
6800     stmt = ffestd_stmt_new_ (FFESTD_stmtidV025finish_);
6801     stmt->u.V025finish.pool = ffesta_output_pool;
6802     ffestd_stmt_append_ (stmt);
6803   }
6804 #endif
6805
6806 #endif
6807 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6808 #endif
6809 }
6810
6811 /* ffestd_V026 -- FIND statement
6812
6813    ffestd_V026();
6814
6815    Make sure a FIND is valid in the current context, and implement it.  */
6816
6817 void
6818 ffestd_V026 ()
6819 {
6820   ffestd_check_simple_ ();
6821
6822 #if FFECOM_targetCURRENT == FFECOM_targetFFE
6823
6824 #if FFECOM_ONEPASS
6825   ffestd_subr_line_now_ ();
6826   ffeste_V026 (&ffestp_file.find);
6827 #else
6828   {
6829     ffestdStmt_ stmt;
6830
6831     stmt = ffestd_stmt_new_ (FFESTD_stmtidV026_);
6832     ffestd_stmt_append_ (stmt);
6833     ffestd_subr_line_save_ (stmt);
6834     stmt->u.V026.pool = ffesta_output_pool;
6835     stmt->u.V026.params = ffestd_subr_copy_find_ ();
6836     ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
6837   }
6838 #endif
6839
6840 #endif
6841 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6842   ffestd_subr_vxt_ ();
6843 #endif
6844 }
6845
6846 #endif
6847 /* ffestd_V027_start -- VXT PARAMETER statement list begin
6848
6849    ffestd_V027_start();
6850
6851    Verify that PARAMETER is valid here, and begin accepting items in the list.  */
6852
6853 void
6854 ffestd_V027_start ()
6855 {
6856   ffestd_check_start_ ();
6857
6858 #if FFECOM_targetCURRENT == FFECOM_targetFFE
6859   fputs ("* PARAMETER_vxt ", dmpout);
6860 #else
6861 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6862   ffestd_subr_vxt_ ();
6863 #endif
6864 #endif
6865 }
6866
6867 /* ffestd_V027_item -- VXT PARAMETER statement assignment
6868
6869    ffestd_V027_item(dest,dest_token,source,source_token);
6870
6871    Make sure the source is a valid source for the destination; make the
6872    assignment.  */
6873
6874 void
6875 ffestd_V027_item (ffelexToken dest_token UNUSED, ffebld source UNUSED)
6876 {
6877   ffestd_check_item_ ();
6878
6879 #if FFECOM_targetCURRENT == FFECOM_targetFFE
6880   fputs (ffelex_token_text (dest_token), dmpout);
6881   fputc ('=', dmpout);
6882   ffebld_dump (source);
6883   fputc (',', dmpout);
6884 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
6885 #else
6886 #error
6887 #endif
6888 }
6889
6890 /* ffestd_V027_finish -- VXT PARAMETER statement list complete
6891
6892    ffestd_V027_finish();
6893
6894    Just wrap up any local activities.  */
6895
6896 void
6897 ffestd_V027_finish ()
6898 {
6899   ffestd_check_finish_ ();
6900
6901 #if FFECOM_targetCURRENT == FFECOM_targetFFE
6902   fputc ('\n', dmpout);
6903 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
6904 #else
6905 #error
6906 #endif
6907 }
6908
6909 /* Any executable statement.  */
6910
6911 void
6912 ffestd_any ()
6913 {
6914   ffestd_check_simple_ ();
6915
6916 #if FFECOM_ONEPASS
6917   ffestd_subr_line_now_ ();
6918   ffeste_R841 ();
6919 #else
6920   {
6921     ffestdStmt_ stmt;
6922
6923     stmt = ffestd_stmt_new_ (FFESTD_stmtidR841_);
6924     ffestd_stmt_append_ (stmt);
6925     ffestd_subr_line_save_ (stmt);
6926   }
6927 #endif
6928 }