gcc/f/std.c

   1 /* std.c -- Implementation File (module.c template V1.0)
   2    Copyright (C) 1995, 1996, 2000, 2002, 2003 Free Software Foundation, Inc.
   3    Contributed by James Craig Burley.
   4
   5 This file is part of GNU Fortran.
   6
   7 GNU Fortran is free software; you can redistribute it and/or modify
   8 it under the terms of the GNU General Public License as published by
   9 the Free Software Foundation; either version 2, or (at your option)
  10 any later version.
  11
  12 GNU Fortran is distributed in the hope that it will be useful,
  13 but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 GNU General Public License for more details.
  16
  17 You should have received a copy of the GNU General Public License
  18 along with GNU Fortran; see the file COPYING.  If not, write to
  19 the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
  20 02111-1307, USA.
  21
  22    Related Modules:
  23       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 typedef enum
  73   {
  74     FFESTD_stmtidENDDOLOOP_,
  75     FFESTD_stmtidENDLOGIF_,
  76     FFESTD_stmtidEXECLABEL_,
  77     FFESTD_stmtidFORMATLABEL_,
  78     FFESTD_stmtidR737A_,        /* let */
  79     FFESTD_stmtidR803_,         /* IF-block */
  80     FFESTD_stmtidR804_,         /* ELSE IF */
  81     FFESTD_stmtidR805_,         /* ELSE */
  82     FFESTD_stmtidR806_,         /* END IF */
  83     FFESTD_stmtidR807_,         /* IF-logical */
  84     FFESTD_stmtidR809_,         /* SELECT CASE */
  85     FFESTD_stmtidR810_,         /* CASE */
  86     FFESTD_stmtidR811_,         /* END SELECT */
  87     FFESTD_stmtidR819A_,        /* DO-iterative */
  88     FFESTD_stmtidR819B_,        /* DO WHILE */
  89     FFESTD_stmtidR825_,         /* END DO */
  90     FFESTD_stmtidR834_,         /* CYCLE */
  91     FFESTD_stmtidR835_,         /* EXIT */
  92     FFESTD_stmtidR836_,         /* GOTO */
  93     FFESTD_stmtidR837_,         /* GOTO-computed */
  94     FFESTD_stmtidR838_,         /* ASSIGN */
  95     FFESTD_stmtidR839_,         /* GOTO-assigned */
  96     FFESTD_stmtidR840_,         /* IF-arithmetic */
  97     FFESTD_stmtidR841_,         /* CONTINUE */
  98     FFESTD_stmtidR842_,         /* STOP */
  99     FFESTD_stmtidR843_,         /* PAUSE */
 100     FFESTD_stmtidR904_,         /* OPEN */
 101     FFESTD_stmtidR907_,         /* CLOSE */
 102     FFESTD_stmtidR909_,         /* READ */
 103     FFESTD_stmtidR910_,         /* WRITE */
 104     FFESTD_stmtidR911_,         /* PRINT */
 105     FFESTD_stmtidR919_,         /* BACKSPACE */
 106     FFESTD_stmtidR920_,         /* ENDFILE */
 107     FFESTD_stmtidR921_,         /* REWIND */
 108     FFESTD_stmtidR923A_,        /* INQUIRE */
 109     FFESTD_stmtidR923B_,        /* INQUIRE-iolength */
 110     FFESTD_stmtidR1001_,        /* FORMAT */
 111     FFESTD_stmtidR1103_,        /* END_PROGRAM */
 112     FFESTD_stmtidR1112_,        /* END_BLOCK_DATA */
 113     FFESTD_stmtidR1212_,        /* CALL */
 114     FFESTD_stmtidR1221_,        /* END_FUNCTION */
 115     FFESTD_stmtidR1225_,        /* END_SUBROUTINE */
 116     FFESTD_stmtidR1226_,        /* ENTRY */
 117     FFESTD_stmtidR1227_,        /* RETURN */
 118     FFESTD_stmtidV020_,         /* TYPE */
 119     FFESTD_stmtid_,
 120   } ffestdStmtId_;
 121
 122 /* Internal typedefs. */
 123
 124 typedef struct _ffestd_expr_item_ *ffestdExprItem_;
 125 typedef struct _ffestd_stmt_ *ffestdStmt_;
 126
 127 /* Private include files. */
 128
 129
 130 /* Internal structure definitions. */
 131
 132 struct _ffestd_expr_item_
 133   {
 134     ffestdExprItem_ next;
 135     ffebld expr;
 136     ffelexToken token;
 137   };
 138
 139 struct _ffestd_stmt_
 140   {
 141     ffestdStmt_ next;
 142     ffestdStmt_ previous;
 143     ffestdStmtId_ id;
 144     char *filename;
 145     int filelinenum;
 146     union
 147       {
 148         struct
 149           {
 150             ffestw block;
 151           }
 152         enddoloop;
 153         struct
 154           {
 155             ffelab label;
 156           }
 157         execlabel;
 158         struct
 159           {
 160             ffelab label;
 161           }
 162         formatlabel;
 163         struct
 164           {
 165             mallocPool pool;
 166             ffebld dest;
 167             ffebld source;
 168           }
 169         R737A;
 170         struct
 171           {
 172             mallocPool pool;
 173             ffestw block;
 174             ffebld expr;
 175           }
 176         R803;
 177         struct
 178           {
 179             mallocPool pool;
 180             ffestw block;
 181             ffebld expr;
 182           }
 183         R804;
 184         struct
 185           {
 186             ffestw block;
 187           }
 188         R805;
 189         struct
 190           {
 191             ffestw block;
 192           }
 193         R806;
 194         struct
 195           {
 196             mallocPool pool;
 197             ffebld expr;
 198           }
 199         R807;
 200         struct
 201           {
 202             mallocPool pool;
 203             ffestw block;
 204             ffebld expr;
 205           }
 206         R809;
 207         struct
 208           {
 209             mallocPool pool;
 210             ffestw block;
 211             unsigned long casenum;
 212           }
 213         R810;
 214         struct
 215           {
 216             ffestw block;
 217           }
 218         R811;
 219         struct
 220           {
 221             mallocPool pool;
 222             ffestw block;
 223             ffelab label;
 224             ffebld var;
 225             ffebld start;
 226             ffelexToken start_token;
 227             ffebld end;
 228             ffelexToken end_token;
 229             ffebld incr;
 230             ffelexToken incr_token;
 231           }
 232         R819A;
 233         struct
 234           {
 235             mallocPool pool;
 236             ffestw block;
 237             ffelab label;
 238             ffebld expr;
 239           }
 240         R819B;
 241         struct
 242           {
 243             ffestw block;
 244           }
 245         R834;
 246         struct
 247           {
 248             ffestw block;
 249           }
 250         R835;
 251         struct
 252           {
 253             ffelab label;
 254           }
 255         R836;
 256         struct
 257           {
 258             mallocPool pool;
 259             ffelab *labels;
 260             int count;
 261             ffebld expr;
 262           }
 263         R837;
 264         struct
 265           {
 266             mallocPool pool;
 267             ffelab label;
 268             ffebld target;
 269           }
 270         R838;
 271         struct
 272           {
 273             mallocPool pool;
 274             ffebld target;
 275           }
 276         R839;
 277         struct
 278           {
 279             mallocPool pool;
 280             ffebld expr;
 281             ffelab neg;
 282             ffelab zero;
 283             ffelab pos;
 284           }
 285         R840;
 286         struct
 287           {
 288             mallocPool pool;
 289             ffebld expr;
 290           }
 291         R842;
 292         struct
 293           {
 294             mallocPool pool;
 295             ffebld expr;
 296           }
 297         R843;
 298         struct
 299           {
 300             mallocPool pool;
 301             ffestpOpenStmt *params;
 302           }
 303         R904;
 304         struct
 305           {
 306             mallocPool pool;
 307             ffestpCloseStmt *params;
 308           }
 309         R907;
 310         struct
 311           {
 312             mallocPool pool;
 313             ffestpReadStmt *params;
 314             bool only_format;
 315             ffestvUnit unit;
 316             ffestvFormat format;
 317             bool rec;
 318             bool key;
 319             ffestdExprItem_ list;
 320           }
 321         R909;
 322         struct
 323           {
 324             mallocPool pool;
 325             ffestpWriteStmt *params;
 326             ffestvUnit unit;
 327             ffestvFormat format;
 328             bool rec;
 329             ffestdExprItem_ list;
 330           }
 331         R910;
 332         struct
 333           {
 334             mallocPool pool;
 335             ffestpPrintStmt *params;
 336             ffestvFormat format;
 337             ffestdExprItem_ list;
 338           }
 339         R911;
 340         struct
 341           {
 342             mallocPool pool;
 343             ffestpBeruStmt *params;
 344           }
 345         R919;
 346         struct
 347           {
 348             mallocPool pool;
 349             ffestpBeruStmt *params;
 350           }
 351         R920;
 352         struct
 353           {
 354             mallocPool pool;
 355             ffestpBeruStmt *params;
 356           }
 357         R921;
 358         struct
 359           {
 360             mallocPool pool;
 361             ffestpInquireStmt *params;
 362             bool by_file;
 363           }
 364         R923A;
 365         struct
 366           {
 367             mallocPool pool;
 368             ffestpInquireStmt *params;
 369             ffestdExprItem_ list;
 370           }
 371         R923B;
 372         struct
 373           {
 374             ffestsHolder str;
 375           }
 376         R1001;
 377         struct
 378           {
 379             mallocPool pool;
 380             ffebld expr;
 381           }
 382         R1212;
 383         struct
 384           {
 385             ffesymbol entry;
 386             int entrynum;
 387           }
 388         R1226;
 389         struct
 390           {
 391             mallocPool pool;
 392             ffestw block;
 393             ffebld expr;
 394           }
 395         R1227;
 396         struct
 397           {
 398             mallocPool pool;
 399             ffestpTypeStmt *params;
 400             ffestvFormat format;
 401             ffestdExprItem_ list;
 402           }
 403         V020;
 404       }
 405     u;
 406   };
 407
 408 /* Static objects accessed by functions in this module. */
 409
 410 static ffestdStatelet_ ffestd_statelet_ = FFESTD_stateletSIMPLE_;
 411 static int ffestd_block_level_ = 0;     /* Block level for reachableness. */
 412 static bool ffestd_is_reachable_;       /* Is the current stmt reachable?  */
 413 static ffelab ffestd_label_formatdef_ = NULL;
 414 static ffestdExprItem_ *ffestd_expr_list_;
 415 static struct
 416   {
 417     ffestdStmt_ first;
 418     ffestdStmt_ last;
 419   }
 420 ffestd_stmt_list_ =
 421 {
 422   NULL, NULL
 423 };
 424
 425
 426 /* # ENTRY statements pending. */
 427 static int ffestd_2pass_entrypoints_ = 0;
 428
 429 /* Static functions (internal). */
 430
 431 static void ffestd_stmt_append_ (ffestdStmt_ stmt);
 432 static ffestdStmt_ ffestd_stmt_new_ (ffestdStmtId_ id);
 433 static void ffestd_stmt_pass_ (void);
 434 #if FFESTD_COPY_EASY_
 435 static ffestpInquireStmt *ffestd_subr_copy_easy_ (ffestpInquireIx max);
 436 #endif
 437 static void ffestd_subr_vxt_ (void);
 438 static void ffestd_subr_labels_ (bool unexpected);
 439 static void ffestd_R1001dump_ (ffests s, ffesttFormatList list);
 440 static void ffestd_R1001dump_1005_1_ (ffests s, ffesttFormatList f,
 441                                       const char *string);
 442 static void ffestd_R1001dump_1005_2_ (ffests s, ffesttFormatList f,
 443                                       const char *string);
 444 static void ffestd_R1001dump_1005_3_ (ffests s, ffesttFormatList f,
 445                                       const char *string);
 446 static void ffestd_R1001dump_1005_4_ (ffests s, ffesttFormatList f,
 447                                       const char *string);
 448 static void ffestd_R1001dump_1005_5_ (ffests s, ffesttFormatList f,
 449                                       const char *string);
 450 static void ffestd_R1001dump_1010_1_ (ffests s, ffesttFormatList f,
 451                                       const char *string);
 452 static void ffestd_R1001dump_1010_2_ (ffests s, ffesttFormatList f,
 453                                       const char *string);
 454 static void ffestd_R1001dump_1010_4_ (ffests s, ffesttFormatList f,
 455                                       const char *string);
 456 static void ffestd_R1001dump_1010_5_ (ffests s, ffesttFormatList f,
 457                                       const char *string);
 458 static void ffestd_R1001error_ (ffesttFormatList f);
 459 static void ffestd_R1001rtexpr_ (ffests s, ffesttFormatList f, ffebld expr);
 460
 461 /* Internal macros. */
 462
 463 #define ffestd_subr_line_now_()                                        \
 464   ffeste_set_line (ffelex_token_where_filename (ffesta_tokens[0]), \
 465                    ffelex_token_where_filelinenum (ffesta_tokens[0]))
 466 #define ffestd_subr_line_restore_(s) \
 467   ffeste_set_line ((s)->filename, (s)->filelinenum)
 468 #define ffestd_subr_line_save_(s)                                          \
 469   ((s)->filename = ffelex_token_where_filename (ffesta_tokens[0]),         \
 470    (s)->filelinenum = ffelex_token_where_filelinenum (ffesta_tokens[0]))
 471 #define ffestd_check_simple_() \
 472       assert(ffestd_statelet_ == FFESTD_stateletSIMPLE_)
 473 #define ffestd_check_start_() \
 474       assert(ffestd_statelet_ == FFESTD_stateletSIMPLE_); \
 475       ffestd_statelet_ = FFESTD_stateletATTRIB_
 476 #define ffestd_check_attrib_() \
 477       assert(ffestd_statelet_ == FFESTD_stateletATTRIB_)
 478 #define ffestd_check_item_() \
 479       assert(ffestd_statelet_ == FFESTD_stateletATTRIB_  \
 480             || ffestd_statelet_ == FFESTD_stateletITEM_); \
 481       ffestd_statelet_ = FFESTD_stateletITEM_
 482 #define ffestd_check_item_startvals_() \
 483       assert(ffestd_statelet_ == FFESTD_stateletATTRIB_  \
 484             || ffestd_statelet_ == FFESTD_stateletITEM_); \
 485       ffestd_statelet_ = FFESTD_stateletITEMVALS_
 486 #define ffestd_check_item_value_() \
 487       assert(ffestd_statelet_ == FFESTD_stateletITEMVALS_)
 488 #define ffestd_check_item_endvals_() \
 489       assert(ffestd_statelet_ == FFESTD_stateletITEMVALS_); \
 490       ffestd_statelet_ = FFESTD_stateletITEM_
 491 #define ffestd_check_finish_() \
 492       assert(ffestd_statelet_ == FFESTD_stateletATTRIB_  \
 493             || ffestd_statelet_ == FFESTD_stateletITEM_); \
 494       ffestd_statelet_ = FFESTD_stateletSIMPLE_
 495
 496 #if FFESTD_COPY_EASY_
 497 #define ffestd_subr_copy_accept_() (ffestpAcceptStmt *) \
 498       ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_acceptix)
 499 #define ffestd_subr_copy_beru_() (ffestpBeruStmt *) \
 500       ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_beruix)
 501 #define ffestd_subr_copy_close_() (ffestpCloseStmt *) \
 502       ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_closeix)
 503 #define ffestd_subr_copy_delete_() (ffestpDeleteStmt *) \
 504       ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_deleteix)
 505 #define ffestd_subr_copy_find_() (ffestpFindStmt *) \
 506       ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_findix)
 507 #define ffestd_subr_copy_inquire_() (ffestpInquireStmt *) \
 508       ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_inquireix)
 509 #define ffestd_subr_copy_open_() (ffestpOpenStmt *) \
 510       ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_openix)
 511 #define ffestd_subr_copy_print_() (ffestpPrintStmt *) \
 512       ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_printix)
 513 #define ffestd_subr_copy_read_() (ffestpReadStmt *) \
 514       ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_readix)
 515 #define ffestd_subr_copy_rewrite_() (ffestpRewriteStmt *) \
 516       ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_rewriteix)
 517 #define ffestd_subr_copy_type_() (ffestpTypeStmt *) \
 518       ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_typeix)
 519 #define ffestd_subr_copy_vxtcode_() (ffestpVxtcodeStmt *) \
 520       ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_vxtcodeix)
 521 #define ffestd_subr_copy_write_() (ffestpWriteStmt *) \
 522       ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_writeix)
 523 #endif
 524 \f
 525 /* ffestd_stmt_append_ -- Append statement to end of stmt list
 526
 527    ffestd_stmt_append_(ffestd_stmt_new_(FFESTD_stmtidR737A_));  */
 528
 529 static void
 530 ffestd_stmt_append_ (ffestdStmt_ stmt)
 531 {
 532   stmt->next = (ffestdStmt_) &ffestd_stmt_list_.first;
 533   stmt->previous = ffestd_stmt_list_.last;
 534   stmt->next->previous = stmt;
 535   stmt->previous->next = stmt;
 536 }
 537
 538 /* ffestd_stmt_new_ -- Make new statement with given id
 539
 540    ffestdStmt_ stmt;
 541    stmt = ffestd_stmt_new_(FFESTD_stmtidR737A_);  */
 542
 543 static ffestdStmt_
 544 ffestd_stmt_new_ (ffestdStmtId_ id)
 545 {
 546   ffestdStmt_ stmt;
 547
 548   stmt = malloc_new_kp (ffe_pool_any_unit (), "ffestdStmt_", sizeof (*stmt));
 549   stmt->id = id;
 550   return stmt;
 551 }
 552
 553 /* ffestd_stmt_pass_ -- Pass all statements on list to ffeste
 554
 555    ffestd_stmt_pass_();  */
 556
 557 static void
 558 ffestd_stmt_pass_ ()
 559 {
 560   ffestdStmt_ stmt;
 561   ffestdExprItem_ expr;         /* For traversing lists. */
 562   bool okay = (TREE_CODE (current_function_decl) != ERROR_MARK);
 563
 564   if ((ffestd_2pass_entrypoints_ != 0) && okay)
 565     {
 566       tree which = ffecom_which_entrypoint_decl ();
 567       tree value;
 568       tree label;
 569       int pushok;
 570       int ents = ffestd_2pass_entrypoints_;
 571       tree duplicate;
 572
 573       expand_start_case (0, which, TREE_TYPE (which), "entrypoint dispatch");
 574
 575       stmt = ffestd_stmt_list_.first;
 576       do
 577         {
 578           while (stmt->id != FFESTD_stmtidR1226_)
 579             stmt = stmt->next;
 580
 581           if (stmt->u.R1226.entry != NULL)
 582             {
 583               value = build_int_2 (stmt->u.R1226.entrynum, 0);
 584               /* Yes, we really want to build a null LABEL_DECL here and not
 585                  put it on any list.  That's what pushcase wants, so that's
 586                  what it gets!  */
 587               label = build_decl (LABEL_DECL, NULL_TREE, NULL_TREE);
 588
 589               pushok = pushcase (value, convert, label, &duplicate);
 590               assert (pushok == 0);
 591
 592               label = ffecom_temp_label ();
 593               TREE_USED (label) = 1;
 594               expand_goto (label);
 595
 596               ffesymbol_hook (stmt->u.R1226.entry).length_tree = label;
 597             }
 598           stmt = stmt->next;
 599         }
 600       while (--ents != 0);
 601
 602       expand_end_case (which);
 603     }
 604
 605   for (stmt = ffestd_stmt_list_.first;
 606        stmt != (ffestdStmt_) &ffestd_stmt_list_.first;
 607        stmt = stmt->next)
 608     {
 609       switch (stmt->id)
 610         {
 611         case FFESTD_stmtidENDDOLOOP_:
 612           ffestd_subr_line_restore_ (stmt);
 613           if (okay)
 614             ffeste_do (stmt->u.enddoloop.block);
 615           ffestw_kill (stmt->u.enddoloop.block);
 616           break;
 617
 618         case FFESTD_stmtidENDLOGIF_:
 619           ffestd_subr_line_restore_ (stmt);
 620           if (okay)
 621             ffeste_end_R807 ();
 622           break;
 623
 624         case FFESTD_stmtidEXECLABEL_:
 625           if (okay)
 626             ffeste_labeldef_branch (stmt->u.execlabel.label);
 627           break;
 628
 629         case FFESTD_stmtidFORMATLABEL_:
 630           if (okay)
 631             ffeste_labeldef_format (stmt->u.formatlabel.label);
 632           break;
 633
 634         case FFESTD_stmtidR737A_:
 635           ffestd_subr_line_restore_ (stmt);
 636           if (okay)
 637             ffeste_R737A (stmt->u.R737A.dest, stmt->u.R737A.source);
 638           malloc_pool_kill (stmt->u.R737A.pool);
 639           break;
 640
 641         case FFESTD_stmtidR803_:
 642           ffestd_subr_line_restore_ (stmt);
 643           if (okay)
 644             ffeste_R803 (stmt->u.R803.block, stmt->u.R803.expr);
 645           malloc_pool_kill (stmt->u.R803.pool);
 646           break;
 647
 648         case FFESTD_stmtidR804_:
 649           ffestd_subr_line_restore_ (stmt);
 650           if (okay)
 651             ffeste_R804 (stmt->u.R803.block, stmt->u.R804.expr);
 652           malloc_pool_kill (stmt->u.R804.pool);
 653           break;
 654
 655         case FFESTD_stmtidR805_:
 656           ffestd_subr_line_restore_ (stmt);
 657           if (okay)
 658             ffeste_R805 (stmt->u.R803.block);
 659           break;
 660
 661         case FFESTD_stmtidR806_:
 662           ffestd_subr_line_restore_ (stmt);
 663           if (okay)
 664             ffeste_R806 (stmt->u.R806.block);
 665           ffestw_kill (stmt->u.R806.block);
 666           break;
 667
 668         case FFESTD_stmtidR807_:
 669           ffestd_subr_line_restore_ (stmt);
 670           if (okay)
 671             ffeste_R807 (stmt->u.R807.expr);
 672           malloc_pool_kill (stmt->u.R807.pool);
 673           break;
 674
 675         case FFESTD_stmtidR809_:
 676           ffestd_subr_line_restore_ (stmt);
 677           if (okay)
 678             ffeste_R809 (stmt->u.R809.block, stmt->u.R809.expr);
 679           malloc_pool_kill (stmt->u.R809.pool);
 680           break;
 681
 682         case FFESTD_stmtidR810_:
 683           ffestd_subr_line_restore_ (stmt);
 684           if (okay)
 685             ffeste_R810 (stmt->u.R810.block, stmt->u.R810.casenum);
 686           malloc_pool_kill (stmt->u.R810.pool);
 687           break;
 688
 689         case FFESTD_stmtidR811_:
 690           ffestd_subr_line_restore_ (stmt);
 691           if (okay)
 692             ffeste_R811 (stmt->u.R811.block);
 693           malloc_pool_kill (ffestw_select (stmt->u.R811.block)->pool);
 694           ffestw_kill (stmt->u.R811.block);
 695           break;
 696
 697         case FFESTD_stmtidR819A_:
 698           ffestd_subr_line_restore_ (stmt);
 699           if (okay)
 700             ffeste_R819A (stmt->u.R819A.block, stmt->u.R819A.label,
 701                           stmt->u.R819A.var,
 702                           stmt->u.R819A.start, stmt->u.R819A.start_token,
 703                           stmt->u.R819A.end, stmt->u.R819A.end_token,
 704                           stmt->u.R819A.incr, stmt->u.R819A.incr_token);
 705           ffelex_token_kill (stmt->u.R819A.start_token);
 706           ffelex_token_kill (stmt->u.R819A.end_token);
 707           if (stmt->u.R819A.incr_token != NULL)
 708             ffelex_token_kill (stmt->u.R819A.incr_token);
 709           malloc_pool_kill (stmt->u.R819A.pool);
 710           break;
 711
 712         case FFESTD_stmtidR819B_:
 713           ffestd_subr_line_restore_ (stmt);
 714           if (okay)
 715             ffeste_R819B (stmt->u.R819B.block, stmt->u.R819B.label,
 716                           stmt->u.R819B.expr);
 717           malloc_pool_kill (stmt->u.R819B.pool);
 718           break;
 719
 720         case FFESTD_stmtidR825_:
 721           ffestd_subr_line_restore_ (stmt);
 722           if (okay)
 723             ffeste_R825 ();
 724           break;
 725
 726         case FFESTD_stmtidR834_:
 727           ffestd_subr_line_restore_ (stmt);
 728           if (okay)
 729             ffeste_R834 (stmt->u.R834.block);
 730           break;
 731
 732         case FFESTD_stmtidR835_:
 733           ffestd_subr_line_restore_ (stmt);
 734           if (okay)
 735             ffeste_R835 (stmt->u.R835.block);
 736           break;
 737
 738         case FFESTD_stmtidR836_:
 739           ffestd_subr_line_restore_ (stmt);
 740           if (okay)
 741             ffeste_R836 (stmt->u.R836.label);
 742           break;
 743
 744         case FFESTD_stmtidR837_:
 745           ffestd_subr_line_restore_ (stmt);
 746           if (okay)
 747             ffeste_R837 (stmt->u.R837.labels, stmt->u.R837.count,
 748                          stmt->u.R837.expr);
 749           malloc_pool_kill (stmt->u.R837.pool);
 750           break;
 751
 752         case FFESTD_stmtidR838_:
 753           ffestd_subr_line_restore_ (stmt);
 754           if (okay)
 755             ffeste_R838 (stmt->u.R838.label, stmt->u.R838.target);
 756           malloc_pool_kill (stmt->u.R838.pool);
 757           break;
 758
 759         case FFESTD_stmtidR839_:
 760           ffestd_subr_line_restore_ (stmt);
 761           if (okay)
 762             ffeste_R839 (stmt->u.R839.target);
 763           malloc_pool_kill (stmt->u.R839.pool);
 764           break;
 765
 766         case FFESTD_stmtidR840_:
 767           ffestd_subr_line_restore_ (stmt);
 768           if (okay)
 769             ffeste_R840 (stmt->u.R840.expr, stmt->u.R840.neg, stmt->u.R840.zero,
 770                          stmt->u.R840.pos);
 771           malloc_pool_kill (stmt->u.R840.pool);
 772           break;
 773
 774         case FFESTD_stmtidR841_:
 775           ffestd_subr_line_restore_ (stmt);
 776           if (okay)
 777             ffeste_R841 ();
 778           break;
 779
 780         case FFESTD_stmtidR842_:
 781           ffestd_subr_line_restore_ (stmt);
 782           if (okay)
 783             ffeste_R842 (stmt->u.R842.expr);
 784           if (stmt->u.R842.pool != NULL)
 785             malloc_pool_kill (stmt->u.R842.pool);
 786           break;
 787
 788         case FFESTD_stmtidR843_:
 789           ffestd_subr_line_restore_ (stmt);
 790           if (okay)
 791             ffeste_R843 (stmt->u.R843.expr);
 792           malloc_pool_kill (stmt->u.R843.pool);
 793           break;
 794
 795         case FFESTD_stmtidR904_:
 796           ffestd_subr_line_restore_ (stmt);
 797           if (okay)
 798             ffeste_R904 (stmt->u.R904.params);
 799           malloc_pool_kill (stmt->u.R904.pool);
 800           break;
 801
 802         case FFESTD_stmtidR907_:
 803           ffestd_subr_line_restore_ (stmt);
 804           if (okay)
 805             ffeste_R907 (stmt->u.R907.params);
 806           malloc_pool_kill (stmt->u.R907.pool);
 807           break;
 808
 809         case FFESTD_stmtidR909_:
 810           ffestd_subr_line_restore_ (stmt);
 811           if (okay)
 812             ffeste_R909_start (stmt->u.R909.params, stmt->u.R909.only_format,
 813                                stmt->u.R909.unit, stmt->u.R909.format,
 814                                stmt->u.R909.rec, stmt->u.R909.key);
 815           for (expr = stmt->u.R909.list; expr != NULL; expr = expr->next)
 816             {
 817               if (okay)
 818                 ffeste_R909_item (expr->expr, expr->token);
 819               ffelex_token_kill (expr->token);
 820             }
 821           if (okay)
 822             ffeste_R909_finish ();
 823           malloc_pool_kill (stmt->u.R909.pool);
 824           break;
 825
 826         case FFESTD_stmtidR910_:
 827           ffestd_subr_line_restore_ (stmt);
 828           if (okay)
 829             ffeste_R910_start (stmt->u.R910.params, stmt->u.R910.unit,
 830                                stmt->u.R910.format, stmt->u.R910.rec);
 831           for (expr = stmt->u.R910.list; expr != NULL; expr = expr->next)
 832             {
 833               if (okay)
 834                 ffeste_R910_item (expr->expr, expr->token);
 835               ffelex_token_kill (expr->token);
 836             }
 837           if (okay)
 838             ffeste_R910_finish ();
 839           malloc_pool_kill (stmt->u.R910.pool);
 840           break;
 841
 842         case FFESTD_stmtidR911_:
 843           ffestd_subr_line_restore_ (stmt);
 844           if (okay)
 845             ffeste_R911_start (stmt->u.R911.params, stmt->u.R911.format);
 846           for (expr = stmt->u.R911.list; expr != NULL; expr = expr->next)
 847             {
 848               if (okay)
 849                 ffeste_R911_item (expr->expr, expr->token);
 850               ffelex_token_kill (expr->token);
 851             }
 852           if (okay)
 853             ffeste_R911_finish ();
 854           malloc_pool_kill (stmt->u.R911.pool);
 855           break;
 856
 857         case FFESTD_stmtidR919_:
 858           ffestd_subr_line_restore_ (stmt);
 859           if (okay)
 860             ffeste_R919 (stmt->u.R919.params);
 861           malloc_pool_kill (stmt->u.R919.pool);
 862           break;
 863
 864         case FFESTD_stmtidR920_:
 865           ffestd_subr_line_restore_ (stmt);
 866           if (okay)
 867             ffeste_R920 (stmt->u.R920.params);
 868           malloc_pool_kill (stmt->u.R920.pool);
 869           break;
 870
 871         case FFESTD_stmtidR921_:
 872           ffestd_subr_line_restore_ (stmt);
 873           if (okay)
 874             ffeste_R921 (stmt->u.R921.params);
 875           malloc_pool_kill (stmt->u.R921.pool);
 876           break;
 877
 878         case FFESTD_stmtidR923A_:
 879           ffestd_subr_line_restore_ (stmt);
 880           if (okay)
 881             ffeste_R923A (stmt->u.R923A.params, stmt->u.R923A.by_file);
 882           malloc_pool_kill (stmt->u.R923A.pool);
 883           break;
 884
 885         case FFESTD_stmtidR923B_:
 886           ffestd_subr_line_restore_ (stmt);
 887           if (okay)
 888             ffeste_R923B_start (stmt->u.R923B.params);
 889           for (expr = stmt->u.R923B.list; expr != NULL; expr = expr->next)
 890             {
 891               if (okay)
 892                 ffeste_R923B_item (expr->expr);
 893             }
 894           if (okay)
 895             ffeste_R923B_finish ();
 896           malloc_pool_kill (stmt->u.R923B.pool);
 897           break;
 898
 899         case FFESTD_stmtidR1001_:
 900           if (okay)
 901             ffeste_R1001 (&stmt->u.R1001.str);
 902           ffests_kill (&stmt->u.R1001.str);
 903           break;
 904
 905         case FFESTD_stmtidR1103_:
 906           if (okay)
 907             ffeste_R1103 ();
 908           break;
 909
 910         case FFESTD_stmtidR1112_:
 911           if (okay)
 912             ffeste_R1112 ();
 913           break;
 914
 915         case FFESTD_stmtidR1212_:
 916           ffestd_subr_line_restore_ (stmt);
 917           if (okay)
 918             ffeste_R1212 (stmt->u.R1212.expr);
 919           malloc_pool_kill (stmt->u.R1212.pool);
 920           break;
 921
 922         case FFESTD_stmtidR1221_:
 923           if (okay)
 924             ffeste_R1221 ();
 925           break;
 926
 927         case FFESTD_stmtidR1225_:
 928           if (okay)
 929             ffeste_R1225 ();
 930           break;
 931
 932         case FFESTD_stmtidR1226_:
 933           ffestd_subr_line_restore_ (stmt);
 934           if (stmt->u.R1226.entry != NULL)
 935             {
 936               if (okay)
 937                 ffeste_R1226 (stmt->u.R1226.entry);
 938             }
 939           break;
 940
 941         case FFESTD_stmtidR1227_:
 942           ffestd_subr_line_restore_ (stmt);
 943           if (okay)
 944             ffeste_R1227 (stmt->u.R1227.block, stmt->u.R1227.expr);
 945           malloc_pool_kill (stmt->u.R1227.pool);
 946           break;
 947
 948         case FFESTD_stmtidV020_:
 949           ffestd_subr_line_restore_ (stmt);
 950           if (okay)
 951             ffeste_V020_start (stmt->u.V020.params, stmt->u.V020.format);
 952           for (expr = stmt->u.V020.list; expr != NULL; expr = expr->next)
 953             {
 954               if (okay)
 955                 ffeste_V020_item (expr->expr);
 956             }
 957           if (okay)
 958             ffeste_V020_finish ();
 959           malloc_pool_kill (stmt->u.V020.pool);
 960           break;
 961
 962         default:
 963           assert ("bad stmt->id" == NULL);
 964           break;
 965         }
 966     }
 967 }
 968
 969 /* ffestd_subr_copy_easy_ -- Copy I/O statement data structure
 970
 971    ffestd_subr_copy_easy_();
 972
 973    Copies all data except tokens in the I/O data structure into a new
 974    structure that lasts as long as the output pool for the current
 975    statement.  Assumes that they are
 976    overlaid with each other (union) in stp.h and the typing
 977    and structure references assume (though not necessarily dangerous if
 978    FALSE) that INQUIRE has the most file elements.  */
 979
 980 #if FFESTD_COPY_EASY_
 981 static ffestpInquireStmt *
 982 ffestd_subr_copy_easy_ (ffestpInquireIx max)
 983 {
 984   ffestpInquireStmt *stmt;
 985   ffestpInquireIx ix;
 986
 987   stmt = (ffestpInquireStmt *) malloc_new_kp (ffesta_output_pool,
 988                                   "FFESTD easy", sizeof (ffestpFile) * max);
 989
 990   for (ix = 0; ix < max; ++ix)
 991     {
 992       if ((stmt->inquire_spec[ix].kw_or_val_present
 993            = ffestp_file.inquire.inquire_spec[ix].kw_or_val_present)
 994           && (stmt->inquire_spec[ix].value_present
 995               = ffestp_file.inquire.inquire_spec[ix].value_present))
 996         {
 997           if ((stmt->inquire_spec[ix].value_is_label
 998                = ffestp_file.inquire.inquire_spec[ix].value_is_label))
 999             stmt->inquire_spec[ix].u.label
1000               = ffestp_file.inquire.inquire_spec[ix].u.label;
1001           else
1002             stmt->inquire_spec[ix].u.expr
1003               = ffestp_file.inquire.inquire_spec[ix].u.expr;
1004         }
1005     }
1006
1007   return stmt;
1008 }
1009
1010 #endif
1011 /* ffestd_subr_labels_ -- Handle any undefined labels
1012
1013    ffestd_subr_labels_(FALSE);
1014
1015    For every undefined label, generate an error message and either define
1016    label as a FORMAT() statement (for FORMAT labels) or as a STOP statement
1017    (for all other labels).  */
1018
1019 static void
1020 ffestd_subr_labels_ (bool unexpected)
1021 {
1022   ffelab l;
1023   ffelabHandle h;
1024   ffelabNumber undef;
1025   ffesttFormatList f;
1026
1027   undef = ffelab_number () - ffestv_num_label_defines_;
1028
1029   for (h = ffelab_handle_first (); h != NULL; h = ffelab_handle_next (h))
1030     {
1031       l = ffelab_handle_target (h);
1032       if (ffewhere_line_is_unknown (ffelab_definition_line (l)))
1033         {                       /* Undefined label. */
1034           assert (!unexpected);
1035           assert (undef > 0);
1036           undef--;
1037           ffebad_start (FFEBAD_UNDEF_LABEL);
1038           if (ffelab_type (l) == FFELAB_typeLOOPEND)
1039             ffebad_here (0, ffelab_doref_line (l), ffelab_doref_column (l));
1040           else if (ffelab_type (l) != FFELAB_typeANY)
1041             ffebad_here (0, ffelab_firstref_line (l), ffelab_firstref_column (l));
1042           else if (!ffewhere_line_is_unknown (ffelab_firstref_line (l)))
1043             ffebad_here (0, ffelab_firstref_line (l), ffelab_firstref_column (l));
1044           else if (!ffewhere_line_is_unknown (ffelab_doref_line (l)))
1045             ffebad_here (0, ffelab_doref_line (l), ffelab_doref_column (l));
1046           else
1047             ffebad_here (0, ffelab_definition_line (l), ffelab_definition_column (l));
1048           ffebad_finish ();
1049
1050           switch (ffelab_type (l))
1051             {
1052             case FFELAB_typeFORMAT:
1053               ffelab_set_definition_line (l,
1054                               ffewhere_line_use (ffelab_firstref_line (l)));
1055               ffelab_set_definition_column (l,
1056                           ffewhere_column_use (ffelab_firstref_column (l)));
1057               ffestv_num_label_defines_++;
1058               f = ffestt_formatlist_create (NULL, NULL);
1059               ffestd_labeldef_format (l);
1060               ffestd_R1001 (f);
1061               ffestt_formatlist_kill (f);
1062               break;
1063
1064             case FFELAB_typeASSIGNABLE:
1065               ffelab_set_definition_line (l,
1066                               ffewhere_line_use (ffelab_firstref_line (l)));
1067               ffelab_set_definition_column (l,
1068                           ffewhere_column_use (ffelab_firstref_column (l)));
1069               ffestv_num_label_defines_++;
1070               ffelab_set_type (l, FFELAB_typeNOTLOOP);
1071               ffelab_set_blocknum (l, ffestw_blocknum (ffestw_stack_top ()));
1072               ffestd_labeldef_notloop (l);
1073               ffestd_R842 (NULL);
1074               break;
1075
1076             case FFELAB_typeNOTLOOP:
1077               ffelab_set_definition_line (l,
1078                               ffewhere_line_use (ffelab_firstref_line (l)));
1079               ffelab_set_definition_column (l,
1080                           ffewhere_column_use (ffelab_firstref_column (l)));
1081               ffestv_num_label_defines_++;
1082               ffelab_set_blocknum (l, ffestw_blocknum (ffestw_stack_top ()));
1083               ffestd_labeldef_notloop (l);
1084               ffestd_R842 (NULL);
1085               break;
1086
1087             default:
1088               assert ("bad label type" == NULL);
1089               /* Fall through. */
1090             case FFELAB_typeUNKNOWN:
1091             case FFELAB_typeANY:
1092               break;
1093             }
1094         }
1095     }
1096   ffelab_handle_done (h);
1097   assert (undef == 0);
1098 }
1099
1100 /* ffestd_subr_vxt_ -- Report error about lack of full VXT support
1101
1102    ffestd_subr_vxt_();  */
1103
1104 static void
1105 ffestd_subr_vxt_ ()
1106 {
1107   ffebad_start (FFEBAD_VXT_UNSUPPORTED);
1108   ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
1109                ffelex_token_where_column (ffesta_tokens[0]));
1110   ffebad_finish ();
1111 }
1112
1113 /* ffestd_begin_uses -- Start a bunch of USE statements
1114
1115    ffestd_begin_uses();
1116
1117    Invoked before handling the first USE statement in a block of one or
1118    more USE statements.  _end_uses_(bool ok) is invoked before handling
1119    the first statement after the block (there are no BEGIN USE and END USE
1120    statements, but the semantics of USE statements effectively requires
1121    handling them as a single block rather than one statement at a time).  */
1122
1123 void
1124 ffestd_begin_uses ()
1125 {
1126 }
1127
1128 /* ffestd_do -- End of statement following DO-term-stmt etc
1129
1130    ffestd_do(TRUE);
1131
1132    Also invoked by _labeldef_branch_finish_ (or, in cases
1133    of errors, other _labeldef_ functions) when the label definition is
1134    for a DO-target (LOOPEND) label, once per matching/outstanding DO
1135    block on the stack.  These cases invoke this function with ok==TRUE, so
1136    only forced stack popping (via ffestd_eof_()) invokes it with ok==FALSE.  */
1137
1138 void
1139 ffestd_do (bool ok UNUSED)
1140 {
1141   ffestdStmt_ stmt;
1142
1143   stmt = ffestd_stmt_new_ (FFESTD_stmtidENDDOLOOP_);
1144   ffestd_stmt_append_ (stmt);
1145   ffestd_subr_line_save_ (stmt);
1146   stmt->u.enddoloop.block = ffestw_stack_top ();
1147
1148   --ffestd_block_level_;
1149   assert (ffestd_block_level_ >= 0);
1150 }
1151
1152 /* ffestd_end_R807 -- End of statement following logical IF
1153
1154    ffestd_end_R807(TRUE);
1155
1156    Applies ONLY to logical IF, not to IF-THEN.  For example, does not
1157    ffelex_token_kill the construct name for an IF-THEN block (the name
1158    field is invalid for logical IF).  ok==TRUE iff statement following
1159    logical IF (substatement) is valid; else, statement is invalid or
1160    stack forcibly popped due to ffestd_eof_().  */
1161
1162 void
1163 ffestd_end_R807 (bool ok UNUSED)
1164 {
1165   ffestdStmt_ stmt;
1166
1167   stmt = ffestd_stmt_new_ (FFESTD_stmtidENDLOGIF_);
1168   ffestd_stmt_append_ (stmt);
1169   ffestd_subr_line_save_ (stmt);
1170
1171   --ffestd_block_level_;
1172   assert (ffestd_block_level_ >= 0);
1173 }
1174
1175 /* ffestd_exec_begin -- Executable statements can start coming in now
1176
1177    ffestd_exec_begin();  */
1178
1179 void
1180 ffestd_exec_begin ()
1181 {
1182   ffecom_exec_transition ();
1183
1184   if (ffestd_2pass_entrypoints_ != 0)
1185     {                           /* Process pending ENTRY statements now that
1186                                    info filled in. */
1187       ffestdStmt_ stmt;
1188       int ents = ffestd_2pass_entrypoints_;
1189
1190       stmt = ffestd_stmt_list_.first;
1191       do
1192         {
1193           while (stmt->id != FFESTD_stmtidR1226_)
1194             stmt = stmt->next;
1195
1196           if (!ffecom_2pass_advise_entrypoint (stmt->u.R1226.entry))
1197             {
1198               stmt->u.R1226.entry = NULL;
1199               --ffestd_2pass_entrypoints_;
1200             }
1201           stmt = stmt->next;
1202         }
1203       while (--ents != 0);
1204     }
1205 }
1206
1207 /* ffestd_exec_end -- Executable statements can no longer come in now
1208
1209    ffestd_exec_end();  */
1210
1211 void
1212 ffestd_exec_end ()
1213 {
1214   location_t old_loc = input_location;
1215
1216   ffecom_end_transition ();
1217
1218   ffestd_stmt_pass_ ();
1219
1220   ffecom_finish_progunit ();
1221
1222   if (ffestd_2pass_entrypoints_ != 0)
1223     {
1224       int ents = ffestd_2pass_entrypoints_;
1225       ffestdStmt_ stmt = ffestd_stmt_list_.first;
1226
1227       do
1228         {
1229           while (stmt->id != FFESTD_stmtidR1226_)
1230             stmt = stmt->next;
1231
1232           if (stmt->u.R1226.entry != NULL)
1233             {
1234               ffestd_subr_line_restore_ (stmt);
1235               ffecom_2pass_do_entrypoint (stmt->u.R1226.entry);
1236             }
1237           stmt = stmt->next;
1238         }
1239       while (--ents != 0);
1240     }
1241
1242   ffestd_stmt_list_.first = NULL;
1243   ffestd_stmt_list_.last = NULL;
1244   ffestd_2pass_entrypoints_ = 0;
1245
1246   input_location = old_loc;
1247 }
1248
1249 /* ffestd_init_3 -- Initialize for any program unit
1250
1251    ffestd_init_3();  */
1252
1253 void
1254 ffestd_init_3 ()
1255 {
1256   ffestd_stmt_list_.first = (ffestdStmt_) &ffestd_stmt_list_.first;
1257   ffestd_stmt_list_.last = (ffestdStmt_) &ffestd_stmt_list_.first;
1258 }
1259
1260 /* Generate "code" for "any" label def.  */
1261
1262 void
1263 ffestd_labeldef_any (ffelab label UNUSED)
1264 {
1265 }
1266
1267 /* ffestd_labeldef_branch -- Generate "code" for branch label def
1268
1269    ffestd_labeldef_branch(label);  */
1270
1271 void
1272 ffestd_labeldef_branch (ffelab label)
1273 {
1274   ffestdStmt_ stmt;
1275
1276   stmt = ffestd_stmt_new_ (FFESTD_stmtidEXECLABEL_);
1277   ffestd_stmt_append_ (stmt);
1278   stmt->u.execlabel.label = label;
1279
1280   ffestd_is_reachable_ = TRUE;
1281 }
1282
1283 /* ffestd_labeldef_format -- Generate "code" for FORMAT label def
1284
1285    ffestd_labeldef_format(label);  */
1286
1287 void
1288 ffestd_labeldef_format (ffelab label)
1289 {
1290   ffestdStmt_ stmt;
1291
1292   ffestd_label_formatdef_ = label;
1293
1294   stmt = ffestd_stmt_new_ (FFESTD_stmtidFORMATLABEL_);
1295   ffestd_stmt_append_ (stmt);
1296   stmt->u.formatlabel.label = label;
1297 }
1298
1299 /* ffestd_labeldef_useless -- Generate "code" for useless label def
1300
1301    ffestd_labeldef_useless(label);  */
1302
1303 void
1304 ffestd_labeldef_useless (ffelab label UNUSED)
1305 {
1306 }
1307
1308 /* ffestd_R522 -- SAVE statement with no list
1309
1310    ffestd_R522();
1311
1312    Verify that SAVE is valid here, and flag everything as SAVEd.  */
1313
1314 void
1315 ffestd_R522 ()
1316 {
1317   ffestd_check_simple_ ();
1318 }
1319
1320 /* ffestd_R522start -- SAVE statement list begin
1321
1322    ffestd_R522start();
1323
1324    Verify that SAVE is valid here, and begin accepting items in the list.  */
1325
1326 void
1327 ffestd_R522start ()
1328 {
1329   ffestd_check_start_ ();
1330 }
1331
1332 /* ffestd_R522item_object -- SAVE statement for object-name
1333
1334    ffestd_R522item_object(name_token);
1335
1336    Make sure name_token identifies a valid object to be SAVEd.  */
1337
1338 void
1339 ffestd_R522item_object (ffelexToken name UNUSED)
1340 {
1341   ffestd_check_item_ ();
1342 }
1343
1344 /* ffestd_R522item_cblock -- SAVE statement for common-block-name
1345
1346    ffestd_R522item_cblock(name_token);
1347
1348    Make sure name_token identifies a valid common block to be SAVEd.  */
1349
1350 void
1351 ffestd_R522item_cblock (ffelexToken name UNUSED)
1352 {
1353   ffestd_check_item_ ();
1354 }
1355
1356 /* ffestd_R522finish -- SAVE statement list complete
1357
1358    ffestd_R522finish();
1359
1360    Just wrap up any local activities.  */
1361
1362 void
1363 ffestd_R522finish ()
1364 {
1365   ffestd_check_finish_ ();
1366 }
1367
1368 /* ffestd_R524_start -- DIMENSION statement list begin
1369
1370    ffestd_R524_start(bool virtual);
1371
1372    Verify that DIMENSION is valid here, and begin accepting items in the list.  */
1373
1374 void
1375 ffestd_R524_start (bool virtual UNUSED)
1376 {
1377   ffestd_check_start_ ();
1378 }
1379
1380 /* ffestd_R524_item -- DIMENSION statement for object-name
1381
1382    ffestd_R524_item(name_token,dim_list);
1383
1384    Make sure name_token identifies a valid object to be DIMENSIONd.  */
1385
1386 void
1387 ffestd_R524_item (ffelexToken name UNUSED, ffesttDimList dims UNUSED)
1388 {
1389   ffestd_check_item_ ();
1390 }
1391
1392 /* ffestd_R524_finish -- DIMENSION statement list complete
1393
1394    ffestd_R524_finish();
1395
1396    Just wrap up any local activities.  */
1397
1398 void
1399 ffestd_R524_finish ()
1400 {
1401   ffestd_check_finish_ ();
1402 }
1403
1404 /* ffestd_R537_start -- PARAMETER statement list begin
1405
1406    ffestd_R537_start();
1407
1408    Verify that PARAMETER is valid here, and begin accepting items in the list.  */
1409
1410 void
1411 ffestd_R537_start ()
1412 {
1413   ffestd_check_start_ ();
1414 }
1415
1416 /* ffestd_R537_item -- PARAMETER statement assignment
1417
1418    ffestd_R537_item(dest,dest_token,source,source_token);
1419
1420    Make sure the source is a valid source for the destination; make the
1421    assignment.  */
1422
1423 void
1424 ffestd_R537_item (ffebld dest UNUSED, ffebld source UNUSED)
1425 {
1426   ffestd_check_item_ ();
1427 }
1428
1429 /* ffestd_R537_finish -- PARAMETER statement list complete
1430
1431    ffestd_R537_finish();
1432
1433    Just wrap up any local activities.  */
1434
1435 void
1436 ffestd_R537_finish ()
1437 {
1438   ffestd_check_finish_ ();
1439 }
1440
1441 /* ffestd_R539 -- IMPLICIT NONE statement
1442
1443    ffestd_R539();
1444
1445    Verify that the IMPLICIT NONE statement is ok here and implement.  */
1446
1447 void
1448 ffestd_R539 ()
1449 {
1450   ffestd_check_simple_ ();
1451 }
1452
1453 /* ffestd_R539start -- IMPLICIT statement
1454
1455    ffestd_R539start();
1456
1457    Verify that the IMPLICIT statement is ok here and implement.  */
1458
1459 void
1460 ffestd_R539start ()
1461 {
1462   ffestd_check_start_ ();
1463 }
1464
1465 /* ffestd_R539item -- IMPLICIT statement specification (R540)
1466
1467    ffestd_R539item(...);
1468
1469    Verify that the type and letter list are all ok and implement.  */
1470
1471 void
1472 ffestd_R539item (ffestpType type UNUSED, ffebld kind UNUSED,
1473                  ffelexToken kindt UNUSED, ffebld len UNUSED,
1474                  ffelexToken lent UNUSED, ffesttImpList letters UNUSED)
1475 {
1476   ffestd_check_item_ ();
1477 }
1478
1479 /* ffestd_R539finish -- IMPLICIT statement
1480
1481    ffestd_R539finish();
1482
1483    Finish up any local activities.  */
1484
1485 void
1486 ffestd_R539finish ()
1487 {
1488   ffestd_check_finish_ ();
1489 }
1490
1491 /* ffestd_R542_start -- NAMELIST statement list begin
1492
1493    ffestd_R542_start();
1494
1495    Verify that NAMELIST is valid here, and begin accepting items in the list.  */
1496
1497 void
1498 ffestd_R542_start ()
1499 {
1500   ffestd_check_start_ ();
1501 }
1502
1503 /* ffestd_R542_item_nlist -- NAMELIST statement for group-name
1504
1505    ffestd_R542_item_nlist(groupname_token);
1506
1507    Make sure name_token identifies a valid object to be NAMELISTd.  */
1508
1509 void
1510 ffestd_R542_item_nlist (ffelexToken name UNUSED)
1511 {
1512   ffestd_check_item_ ();
1513 }
1514
1515 /* ffestd_R542_item_nitem -- NAMELIST statement for variable-name
1516
1517    ffestd_R542_item_nitem(name_token);
1518
1519    Make sure name_token identifies a valid object to be NAMELISTd.  */
1520
1521 void
1522 ffestd_R542_item_nitem (ffelexToken name UNUSED)
1523 {
1524   ffestd_check_item_ ();
1525 }
1526
1527 /* ffestd_R542_finish -- NAMELIST statement list complete
1528
1529    ffestd_R542_finish();
1530
1531    Just wrap up any local activities.  */
1532
1533 void
1534 ffestd_R542_finish ()
1535 {
1536   ffestd_check_finish_ ();
1537 }
1538
1539 /* ffestd_R547_start -- COMMON statement list begin
1540
1541    ffestd_R547_start();
1542
1543    Verify that COMMON is valid here, and begin accepting items in the list.  */
1544
1545 void
1546 ffestd_R547_start ()
1547 {
1548   ffestd_check_start_ ();
1549 }
1550
1551 /* ffestd_R547_item_object -- COMMON statement for object-name
1552
1553    ffestd_R547_item_object(name_token,dim_list);
1554
1555    Make sure name_token identifies a valid object to be COMMONd.  */
1556
1557 void
1558 ffestd_R547_item_object (ffelexToken name UNUSED,
1559                          ffesttDimList dims UNUSED)
1560 {
1561   ffestd_check_item_ ();
1562 }
1563
1564 /* ffestd_R547_item_cblock -- COMMON statement for common-block-name
1565
1566    ffestd_R547_item_cblock(name_token);
1567
1568    Make sure name_token identifies a valid common block to be COMMONd.  */
1569
1570 void
1571 ffestd_R547_item_cblock (ffelexToken name UNUSED)
1572 {
1573   ffestd_check_item_ ();
1574 }
1575
1576 /* ffestd_R547_finish -- COMMON statement list complete
1577
1578    ffestd_R547_finish();
1579
1580    Just wrap up any local activities.  */
1581
1582 void
1583 ffestd_R547_finish ()
1584 {
1585   ffestd_check_finish_ ();
1586 }
1587
1588 /* ffestd_R737A -- Assignment statement outside of WHERE
1589
1590    ffestd_R737A(dest_expr,source_expr);  */
1591
1592 void
1593 ffestd_R737A (ffebld dest, ffebld source)
1594 {
1595   ffestdStmt_ stmt;
1596
1597   ffestd_check_simple_ ();
1598
1599   stmt = ffestd_stmt_new_ (FFESTD_stmtidR737A_);
1600   ffestd_stmt_append_ (stmt);
1601   ffestd_subr_line_save_ (stmt);
1602   stmt->u.R737A.pool = ffesta_output_pool;
1603   stmt->u.R737A.dest = dest;
1604   stmt->u.R737A.source = source;
1605   ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
1606 }
1607
1608
1609 /* Block IF (IF-THEN) statement.  */
1610
1611 void
1612 ffestd_R803 (ffelexToken construct_name UNUSED, ffebld expr)
1613 {
1614   ffestdStmt_ stmt;
1615
1616   ffestd_check_simple_ ();
1617
1618   stmt = ffestd_stmt_new_ (FFESTD_stmtidR803_);
1619   ffestd_stmt_append_ (stmt);
1620   ffestd_subr_line_save_ (stmt);
1621   stmt->u.R803.pool = ffesta_output_pool;
1622   stmt->u.R803.block = ffestw_use (ffestw_stack_top ());
1623   stmt->u.R803.expr = expr;
1624   ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
1625
1626   ++ffestd_block_level_;
1627   assert (ffestd_block_level_ > 0);
1628 }
1629
1630 /* ELSE IF statement.  */
1631
1632 void
1633 ffestd_R804 (ffebld expr, ffelexToken name UNUSED)
1634 {
1635   ffestdStmt_ stmt;
1636
1637   ffestd_check_simple_ ();
1638
1639   stmt = ffestd_stmt_new_ (FFESTD_stmtidR804_);
1640   ffestd_stmt_append_ (stmt);
1641   ffestd_subr_line_save_ (stmt);
1642   stmt->u.R804.pool = ffesta_output_pool;
1643   stmt->u.R804.block = ffestw_use (ffestw_stack_top ());
1644   stmt->u.R804.expr = expr;
1645   ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
1646 }
1647
1648 /* ELSE statement.  */
1649
1650 void
1651 ffestd_R805 (ffelexToken name UNUSED)
1652 {
1653   ffestdStmt_ stmt;
1654
1655   ffestd_check_simple_ ();
1656
1657   stmt = ffestd_stmt_new_ (FFESTD_stmtidR805_);
1658   ffestd_stmt_append_ (stmt);
1659   ffestd_subr_line_save_ (stmt);
1660   stmt->u.R805.block = ffestw_use (ffestw_stack_top ());
1661 }
1662
1663 /* END IF statement.  */
1664
1665 void
1666 ffestd_R806 (bool ok UNUSED)
1667 {
1668   ffestdStmt_ stmt;
1669
1670   stmt = ffestd_stmt_new_ (FFESTD_stmtidR806_);
1671   ffestd_stmt_append_ (stmt);
1672   ffestd_subr_line_save_ (stmt);
1673   stmt->u.R806.block = ffestw_use (ffestw_stack_top ());
1674
1675   --ffestd_block_level_;
1676   assert (ffestd_block_level_ >= 0);
1677 }
1678
1679 /* ffestd_R807 -- Logical IF statement
1680
1681    ffestd_R807(expr,expr_token);
1682
1683    Make sure statement is valid here; implement.  */
1684
1685 void
1686 ffestd_R807 (ffebld expr)
1687 {
1688   ffestdStmt_ stmt;
1689
1690   ffestd_check_simple_ ();
1691
1692   stmt = ffestd_stmt_new_ (FFESTD_stmtidR807_);
1693   ffestd_stmt_append_ (stmt);
1694   ffestd_subr_line_save_ (stmt);
1695   stmt->u.R807.pool = ffesta_output_pool;
1696   stmt->u.R807.expr = expr;
1697   ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
1698
1699   ++ffestd_block_level_;
1700   assert (ffestd_block_level_ > 0);
1701 }
1702
1703 /* ffestd_R809 -- SELECT CASE statement
1704
1705    ffestd_R809(construct_name,expr,expr_token);
1706
1707    Make sure statement is valid here; implement.  */
1708
1709 void
1710 ffestd_R809 (ffelexToken construct_name UNUSED, ffebld expr)
1711 {
1712   ffestdStmt_ stmt;
1713
1714   ffestd_check_simple_ ();
1715
1716   stmt = ffestd_stmt_new_ (FFESTD_stmtidR809_);
1717   ffestd_stmt_append_ (stmt);
1718   ffestd_subr_line_save_ (stmt);
1719   stmt->u.R809.pool = ffesta_output_pool;
1720   stmt->u.R809.block = ffestw_use (ffestw_stack_top ());
1721   stmt->u.R809.expr = expr;
1722   ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
1723   malloc_pool_use (ffestw_select (ffestw_stack_top ())->pool);
1724
1725   ++ffestd_block_level_;
1726   assert (ffestd_block_level_ > 0);
1727 }
1728
1729 /* ffestd_R810 -- CASE statement
1730
1731    ffestd_R810(case_value_range_list,name);
1732
1733    If casenum is 0, it's CASE DEFAULT.  Else it's the case ranges at
1734    the start of the first_stmt list in the select object at the top of
1735    the stack that match casenum.  */
1736
1737 void
1738 ffestd_R810 (unsigned long casenum)
1739 {
1740   ffestdStmt_ stmt;
1741
1742   ffestd_check_simple_ ();
1743
1744   stmt = ffestd_stmt_new_ (FFESTD_stmtidR810_);
1745   ffestd_stmt_append_ (stmt);
1746   ffestd_subr_line_save_ (stmt);
1747   stmt->u.R810.pool = ffesta_output_pool;
1748   stmt->u.R810.block = ffestw_stack_top ();
1749   stmt->u.R810.casenum = casenum;
1750   ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
1751 }
1752
1753 /* ffestd_R811 -- End a SELECT
1754
1755    ffestd_R811(TRUE);  */
1756
1757 void
1758 ffestd_R811 (bool ok UNUSED)
1759 {
1760   ffestdStmt_ stmt;
1761
1762   stmt = ffestd_stmt_new_ (FFESTD_stmtidR811_);
1763   ffestd_stmt_append_ (stmt);
1764   ffestd_subr_line_save_ (stmt);
1765   stmt->u.R811.block = ffestw_stack_top ();
1766
1767   --ffestd_block_level_;
1768   assert (ffestd_block_level_ >= 0);
1769 }
1770
1771 /* ffestd_R819A -- Iterative DO statement
1772
1773    ffestd_R819A(construct_name,label_token,expr,expr_token);
1774
1775    Make sure statement is valid here; implement.  */
1776
1777 void
1778 ffestd_R819A (ffelexToken construct_name UNUSED, ffelab label,
1779               ffebld var, ffebld start, ffelexToken start_token,
1780               ffebld end, ffelexToken end_token,
1781               ffebld incr, ffelexToken incr_token)
1782 {
1783   ffestdStmt_ stmt;
1784
1785   ffestd_check_simple_ ();
1786
1787   stmt = ffestd_stmt_new_ (FFESTD_stmtidR819A_);
1788   ffestd_stmt_append_ (stmt);
1789   ffestd_subr_line_save_ (stmt);
1790   stmt->u.R819A.pool = ffesta_output_pool;
1791   stmt->u.R819A.block = ffestw_use (ffestw_stack_top ());
1792   stmt->u.R819A.label = label;
1793   stmt->u.R819A.var = var;
1794   stmt->u.R819A.start = start;
1795   stmt->u.R819A.start_token = ffelex_token_use (start_token);
1796   stmt->u.R819A.end = end;
1797   stmt->u.R819A.end_token = ffelex_token_use (end_token);
1798   stmt->u.R819A.incr = incr;
1799   stmt->u.R819A.incr_token = (incr_token == NULL) ? NULL
1800     : ffelex_token_use (incr_token);
1801   ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
1802
1803   ++ffestd_block_level_;
1804   assert (ffestd_block_level_ > 0);
1805 }
1806
1807 /* ffestd_R819B -- DO WHILE statement
1808
1809    ffestd_R819B(construct_name,label_token,expr,expr_token);
1810
1811    Make sure statement is valid here; implement.  */
1812
1813 void
1814 ffestd_R819B (ffelexToken construct_name UNUSED, ffelab label,
1815               ffebld expr)
1816 {
1817   ffestdStmt_ stmt;
1818
1819   ffestd_check_simple_ ();
1820
1821   stmt = ffestd_stmt_new_ (FFESTD_stmtidR819B_);
1822   ffestd_stmt_append_ (stmt);
1823   ffestd_subr_line_save_ (stmt);
1824   stmt->u.R819B.pool = ffesta_output_pool;
1825   stmt->u.R819B.block = ffestw_use (ffestw_stack_top ());
1826   stmt->u.R819B.label = label;
1827   stmt->u.R819B.expr = expr;
1828   ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
1829
1830   ++ffestd_block_level_;
1831   assert (ffestd_block_level_ > 0);
1832 }
1833
1834 /* ffestd_R825 -- END DO statement
1835
1836    ffestd_R825(name_token);
1837
1838    Make sure ffestd_kind_ identifies a DO block.  If not
1839    NULL, make sure name_token gives the correct name.  Do whatever
1840    is specific to seeing END DO with a DO-target label definition on it,
1841    where the END DO is really treated as a CONTINUE (i.e. generate th
1842    same code you would for CONTINUE).  ffestd_do handles the actual
1843    generation of end-loop code.  */
1844
1845 void
1846 ffestd_R825 (ffelexToken name UNUSED)
1847 {
1848   ffestdStmt_ stmt;
1849
1850   ffestd_check_simple_ ();
1851
1852   stmt = ffestd_stmt_new_ (FFESTD_stmtidR825_);
1853   ffestd_stmt_append_ (stmt);
1854   ffestd_subr_line_save_ (stmt);
1855 }
1856
1857 /* ffestd_R834 -- CYCLE statement
1858
1859    ffestd_R834(name_token);
1860
1861    Handle a CYCLE within a loop.  */
1862
1863 void
1864 ffestd_R834 (ffestw block)
1865 {
1866   ffestdStmt_ stmt;
1867
1868   ffestd_check_simple_ ();
1869
1870   stmt = ffestd_stmt_new_ (FFESTD_stmtidR834_);
1871   ffestd_stmt_append_ (stmt);
1872   ffestd_subr_line_save_ (stmt);
1873   stmt->u.R834.block = block;
1874 }
1875
1876 /* ffestd_R835 -- EXIT statement
1877
1878    ffestd_R835(name_token);
1879
1880    Handle a EXIT within a loop.  */
1881
1882 void
1883 ffestd_R835 (ffestw block)
1884 {
1885   ffestdStmt_ stmt;
1886
1887   ffestd_check_simple_ ();
1888
1889   stmt = ffestd_stmt_new_ (FFESTD_stmtidR835_);
1890   ffestd_stmt_append_ (stmt);
1891   ffestd_subr_line_save_ (stmt);
1892   stmt->u.R835.block = block;
1893 }
1894
1895 /* ffestd_R836 -- GOTO statement
1896
1897    ffestd_R836(label);
1898
1899    Make sure label_token identifies a valid label for a GOTO.  Update
1900    that label's info to indicate it is the target of a GOTO.  */
1901
1902 void
1903 ffestd_R836 (ffelab label)
1904 {
1905   ffestdStmt_ stmt;
1906
1907   ffestd_check_simple_ ();
1908
1909   stmt = ffestd_stmt_new_ (FFESTD_stmtidR836_);
1910   ffestd_stmt_append_ (stmt);
1911   ffestd_subr_line_save_ (stmt);
1912   stmt->u.R836.label = label;
1913
1914   if (ffestd_block_level_ == 0)
1915     ffestd_is_reachable_ = FALSE;
1916 }
1917
1918 /* ffestd_R837 -- Computed GOTO statement
1919
1920    ffestd_R837(labels,expr);
1921
1922    Make sure label_list identifies valid labels for a GOTO.  Update
1923    each label's info to indicate it is the target of a GOTO.  */
1924
1925 void
1926 ffestd_R837 (ffelab *labels, int count, ffebld expr)
1927 {
1928   ffestdStmt_ stmt;
1929
1930   ffestd_check_simple_ ();
1931
1932   stmt = ffestd_stmt_new_ (FFESTD_stmtidR837_);
1933   ffestd_stmt_append_ (stmt);
1934   ffestd_subr_line_save_ (stmt);
1935   stmt->u.R837.pool = ffesta_output_pool;
1936   stmt->u.R837.labels = labels;
1937   stmt->u.R837.count = count;
1938   stmt->u.R837.expr = expr;
1939   ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
1940 }
1941
1942 /* ffestd_R838 -- ASSIGN statement
1943
1944    ffestd_R838(label_token,target_variable,target_token);
1945
1946    Make sure label_token identifies a valid label for an assignment.  Update
1947    that label's info to indicate it is the source of an assignment.  Update
1948    target_variable's info to indicate it is the target the assignment of that
1949    label.  */
1950
1951 void
1952 ffestd_R838 (ffelab label, ffebld target)
1953 {
1954   ffestdStmt_ stmt;
1955
1956   ffestd_check_simple_ ();
1957
1958   stmt = ffestd_stmt_new_ (FFESTD_stmtidR838_);
1959   ffestd_stmt_append_ (stmt);
1960   ffestd_subr_line_save_ (stmt);
1961   stmt->u.R838.pool = ffesta_output_pool;
1962   stmt->u.R838.label = label;
1963   stmt->u.R838.target = target;
1964   ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
1965 }
1966
1967 /* ffestd_R839 -- Assigned GOTO statement
1968
1969    ffestd_R839(target,labels);
1970
1971    Make sure label_list identifies valid labels for a GOTO.  Update
1972    each label's info to indicate it is the target of a GOTO.  */
1973
1974 void
1975 ffestd_R839 (ffebld target, ffelab *labels UNUSED, int count UNUSED)
1976 {
1977   ffestdStmt_ stmt;
1978
1979   ffestd_check_simple_ ();
1980
1981   stmt = ffestd_stmt_new_ (FFESTD_stmtidR839_);
1982   ffestd_stmt_append_ (stmt);
1983   ffestd_subr_line_save_ (stmt);
1984   stmt->u.R839.pool = ffesta_output_pool;
1985   stmt->u.R839.target = target;
1986   ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
1987
1988   if (ffestd_block_level_ == 0)
1989     ffestd_is_reachable_ = FALSE;
1990 }
1991
1992 /* ffestd_R840 -- Arithmetic IF statement
1993
1994    ffestd_R840(expr,expr_token,neg,zero,pos);
1995
1996    Make sure the labels are valid; implement.  */
1997
1998 void
1999 ffestd_R840 (ffebld expr, ffelab neg, ffelab zero, ffelab pos)
2000 {
2001   ffestdStmt_ stmt;
2002
2003   ffestd_check_simple_ ();
2004
2005   stmt = ffestd_stmt_new_ (FFESTD_stmtidR840_);
2006   ffestd_stmt_append_ (stmt);
2007   ffestd_subr_line_save_ (stmt);
2008   stmt->u.R840.pool = ffesta_output_pool;
2009   stmt->u.R840.expr = expr;
2010   stmt->u.R840.neg = neg;
2011   stmt->u.R840.zero = zero;
2012   stmt->u.R840.pos = pos;
2013   ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
2014
2015   if (ffestd_block_level_ == 0)
2016     ffestd_is_reachable_ = FALSE;
2017 }
2018
2019 /* ffestd_R841 -- CONTINUE statement
2020
2021    ffestd_R841();  */
2022
2023 void
2024 ffestd_R841 (bool in_where UNUSED)
2025 {
2026   ffestdStmt_ stmt;
2027
2028   ffestd_check_simple_ ();
2029
2030   stmt = ffestd_stmt_new_ (FFESTD_stmtidR841_);
2031   ffestd_stmt_append_ (stmt);
2032   ffestd_subr_line_save_ (stmt);
2033 }
2034
2035 /* ffestd_R842 -- STOP statement
2036
2037    ffestd_R842(expr);  */
2038
2039 void
2040 ffestd_R842 (ffebld expr)
2041 {
2042   ffestdStmt_ stmt;
2043
2044   ffestd_check_simple_ ();
2045
2046   stmt = ffestd_stmt_new_ (FFESTD_stmtidR842_);
2047   ffestd_stmt_append_ (stmt);
2048   ffestd_subr_line_save_ (stmt);
2049   if (ffesta_outpooldisp () == FFESTA_pooldispPRESERVE)
2050     {
2051       /* This is a "spurious" (automatically-generated) STOP
2052          that follows a previous STOP or other statement.
2053          Make sure we don't have an expression in the pool,
2054          and then mark that the pool has already been killed.  */
2055       assert (expr == NULL);
2056       stmt->u.R842.pool = NULL;
2057       stmt->u.R842.expr = NULL;
2058     }
2059   else
2060     {
2061       stmt->u.R842.pool = ffesta_output_pool;
2062       stmt->u.R842.expr = expr;
2063       ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
2064     }
2065
2066   if (ffestd_block_level_ == 0)
2067     ffestd_is_reachable_ = FALSE;
2068 }
2069
2070 /* ffestd_R843 -- PAUSE statement
2071
2072    ffestd_R843(expr,expr_token);
2073
2074    Make sure statement is valid here; implement.  expr and expr_token are
2075    both NULL if there was no expression.  */
2076
2077 void
2078 ffestd_R843 (ffebld expr)
2079 {
2080   ffestdStmt_ stmt;
2081
2082   ffestd_check_simple_ ();
2083
2084   stmt = ffestd_stmt_new_ (FFESTD_stmtidR843_);
2085   ffestd_stmt_append_ (stmt);
2086   ffestd_subr_line_save_ (stmt);
2087   stmt->u.R843.pool = ffesta_output_pool;
2088   stmt->u.R843.expr = expr;
2089   ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
2090 }
2091
2092 /* ffestd_R904 -- OPEN statement
2093
2094    ffestd_R904();
2095
2096    Make sure an OPEN is valid in the current context, and implement it.  */
2097
2098 void
2099 ffestd_R904 ()
2100 {
2101   ffestdStmt_ stmt;
2102
2103   ffestd_check_simple_ ();
2104
2105 #define specified(something) \
2106       (ffestp_file.open.open_spec[something].kw_or_val_present)
2107
2108   /* Warn if there are any thing we don't handle via f2c libraries. */
2109
2110   if (specified (FFESTP_openixACTION)
2111       || specified (FFESTP_openixASSOCIATEVARIABLE)
2112       || specified (FFESTP_openixBLOCKSIZE)
2113       || specified (FFESTP_openixBUFFERCOUNT)
2114       || specified (FFESTP_openixCARRIAGECONTROL)
2115       || specified (FFESTP_openixDEFAULTFILE)
2116       || specified (FFESTP_openixDELIM)
2117       || specified (FFESTP_openixDISPOSE)
2118       || specified (FFESTP_openixEXTENDSIZE)
2119       || specified (FFESTP_openixINITIALSIZE)
2120       || specified (FFESTP_openixKEY)
2121       || specified (FFESTP_openixMAXREC)
2122       || specified (FFESTP_openixNOSPANBLOCKS)
2123       || specified (FFESTP_openixORGANIZATION)
2124       || specified (FFESTP_openixPAD)
2125       || specified (FFESTP_openixPOSITION)
2126       || specified (FFESTP_openixREADONLY)
2127       || specified (FFESTP_openixRECORDTYPE)
2128       || specified (FFESTP_openixSHARED)
2129       || specified (FFESTP_openixUSEROPEN))
2130     {
2131       ffebad_start (FFEBAD_OPEN_UNSUPPORTED);
2132       ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
2133                    ffelex_token_where_column (ffesta_tokens[0]));
2134       ffebad_finish ();
2135     }
2136
2137 #undef specified
2138
2139   stmt = ffestd_stmt_new_ (FFESTD_stmtidR904_);
2140   ffestd_stmt_append_ (stmt);
2141   ffestd_subr_line_save_ (stmt);
2142   stmt->u.R904.pool = ffesta_output_pool;
2143   stmt->u.R904.params = ffestd_subr_copy_open_ ();
2144   ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
2145 }
2146
2147 /* ffestd_R907 -- CLOSE statement
2148
2149    ffestd_R907();
2150
2151    Make sure a CLOSE is valid in the current context, and implement it.  */
2152
2153 void
2154 ffestd_R907 ()
2155 {
2156   ffestdStmt_ stmt;
2157
2158   ffestd_check_simple_ ();
2159
2160   stmt = ffestd_stmt_new_ (FFESTD_stmtidR907_);
2161   ffestd_stmt_append_ (stmt);
2162   ffestd_subr_line_save_ (stmt);
2163   stmt->u.R907.pool = ffesta_output_pool;
2164   stmt->u.R907.params = ffestd_subr_copy_close_ ();
2165   ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
2166 }
2167
2168 /* ffestd_R909_start -- READ(...) statement list begin
2169
2170    ffestd_R909_start(FALSE);
2171
2172    Verify that READ is valid here, and begin accepting items in the
2173    list.  */
2174
2175 void
2176 ffestd_R909_start (bool only_format, ffestvUnit unit,
2177                    ffestvFormat format, bool rec, bool key)
2178 {
2179   ffestdStmt_ stmt;
2180
2181   ffestd_check_start_ ();
2182
2183 #define specified(something) \
2184       (ffestp_file.read.read_spec[something].kw_or_val_present)
2185
2186   /* Warn if there are any thing we don't handle via f2c libraries. */
2187   if (specified (FFESTP_readixADVANCE)
2188       || specified (FFESTP_readixEOR)
2189       || specified (FFESTP_readixKEYEQ)
2190       || specified (FFESTP_readixKEYGE)
2191       || specified (FFESTP_readixKEYGT)
2192       || specified (FFESTP_readixKEYID)
2193       || specified (FFESTP_readixNULLS)
2194       || specified (FFESTP_readixSIZE))
2195     {
2196       ffebad_start (FFEBAD_READ_UNSUPPORTED);
2197       ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
2198                    ffelex_token_where_column (ffesta_tokens[0]));
2199       ffebad_finish ();
2200     }
2201
2202 #undef specified
2203
2204   stmt = ffestd_stmt_new_ (FFESTD_stmtidR909_);
2205   ffestd_stmt_append_ (stmt);
2206   ffestd_subr_line_save_ (stmt);
2207   stmt->u.R909.pool = ffesta_output_pool;
2208   stmt->u.R909.params = ffestd_subr_copy_read_ ();
2209   stmt->u.R909.only_format = only_format;
2210   stmt->u.R909.unit = unit;
2211   stmt->u.R909.format = format;
2212   stmt->u.R909.rec = rec;
2213   stmt->u.R909.key = key;
2214   stmt->u.R909.list = NULL;
2215   ffestd_expr_list_ = &stmt->u.R909.list;
2216   ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
2217 }
2218
2219 /* ffestd_R909_item -- READ statement i/o item
2220
2221    ffestd_R909_item(expr,expr_token);
2222
2223    Implement output-list expression.  */
2224
2225 void
2226 ffestd_R909_item (ffebld expr, ffelexToken expr_token)
2227 {
2228   ffestdExprItem_ item;
2229
2230   ffestd_check_item_ ();
2231
2232   item = (ffestdExprItem_) malloc_new_kp (ffesta_output_pool,
2233                                           "ffestdExprItem_", sizeof (*item));
2234
2235   item->next = NULL;
2236   item->expr = expr;
2237   item->token = ffelex_token_use (expr_token);
2238   *ffestd_expr_list_ = item;
2239   ffestd_expr_list_ = &item->next;
2240 }
2241
2242 /* ffestd_R909_finish -- READ statement list complete
2243
2244    ffestd_R909_finish();
2245
2246    Just wrap up any local activities.  */
2247
2248 void
2249 ffestd_R909_finish ()
2250 {
2251   ffestd_check_finish_ ();
2252 }
2253
2254 /* ffestd_R910_start -- WRITE(...) statement list begin
2255
2256    ffestd_R910_start();
2257
2258    Verify that WRITE is valid here, and begin accepting items in the
2259    list.  */
2260
2261 void
2262 ffestd_R910_start (ffestvUnit unit, ffestvFormat format, bool rec)
2263 {
2264   ffestdStmt_ stmt;
2265
2266   ffestd_check_start_ ();
2267
2268 #define specified(something) \
2269       (ffestp_file.write.write_spec[something].kw_or_val_present)
2270
2271   /* Warn if there are any thing we don't handle via f2c libraries. */
2272   if (specified (FFESTP_writeixADVANCE)
2273       || specified (FFESTP_writeixEOR))
2274     {
2275       ffebad_start (FFEBAD_WRITE_UNSUPPORTED);
2276       ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
2277                    ffelex_token_where_column (ffesta_tokens[0]));
2278       ffebad_finish ();
2279     }
2280
2281 #undef specified
2282
2283   stmt = ffestd_stmt_new_ (FFESTD_stmtidR910_);
2284   ffestd_stmt_append_ (stmt);
2285   ffestd_subr_line_save_ (stmt);
2286   stmt->u.R910.pool = ffesta_output_pool;
2287   stmt->u.R910.params = ffestd_subr_copy_write_ ();
2288   stmt->u.R910.unit = unit;
2289   stmt->u.R910.format = format;
2290   stmt->u.R910.rec = rec;
2291   stmt->u.R910.list = NULL;
2292   ffestd_expr_list_ = &stmt->u.R910.list;
2293   ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
2294 }
2295
2296 /* ffestd_R910_item -- WRITE statement i/o item
2297
2298    ffestd_R910_item(expr,expr_token);
2299
2300    Implement output-list expression.  */
2301
2302 void
2303 ffestd_R910_item (ffebld expr, ffelexToken expr_token)
2304 {
2305   ffestdExprItem_ item;
2306
2307   ffestd_check_item_ ();
2308
2309   item = (ffestdExprItem_) malloc_new_kp (ffesta_output_pool,
2310                                           "ffestdExprItem_", sizeof (*item));
2311
2312   item->next = NULL;
2313   item->expr = expr;
2314   item->token = ffelex_token_use (expr_token);
2315   *ffestd_expr_list_ = item;
2316   ffestd_expr_list_ = &item->next;
2317 }
2318
2319 /* ffestd_R910_finish -- WRITE statement list complete
2320
2321    ffestd_R910_finish();
2322
2323    Just wrap up any local activities.  */
2324
2325 void
2326 ffestd_R910_finish ()
2327 {
2328   ffestd_check_finish_ ();
2329 }
2330
2331 /* ffestd_R911_start -- PRINT statement list begin
2332
2333    ffestd_R911_start();
2334
2335    Verify that PRINT is valid here, and begin accepting items in the
2336    list.  */
2337
2338 void
2339 ffestd_R911_start (ffestvFormat format)
2340 {
2341   ffestdStmt_ stmt;
2342
2343   ffestd_check_start_ ();
2344
2345   stmt = ffestd_stmt_new_ (FFESTD_stmtidR911_);
2346   ffestd_stmt_append_ (stmt);
2347   ffestd_subr_line_save_ (stmt);
2348   stmt->u.R911.pool = ffesta_output_pool;
2349   stmt->u.R911.params = ffestd_subr_copy_print_ ();
2350   stmt->u.R911.format = format;
2351   stmt->u.R911.list = NULL;
2352   ffestd_expr_list_ = &stmt->u.R911.list;
2353   ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
2354 }
2355
2356 /* ffestd_R911_item -- PRINT statement i/o item
2357
2358    ffestd_R911_item(expr,expr_token);
2359
2360    Implement output-list expression.  */
2361
2362 void
2363 ffestd_R911_item (ffebld expr, ffelexToken expr_token)
2364 {
2365   ffestdExprItem_ item;
2366
2367   ffestd_check_item_ ();
2368
2369   item = (ffestdExprItem_) malloc_new_kp (ffesta_output_pool,
2370                                           "ffestdExprItem_", sizeof (*item));
2371
2372   item->next = NULL;
2373   item->expr = expr;
2374   item->token = ffelex_token_use (expr_token);
2375   *ffestd_expr_list_ = item;
2376   ffestd_expr_list_ = &item->next;
2377 }
2378
2379 /* ffestd_R911_finish -- PRINT statement list complete
2380
2381    ffestd_R911_finish();
2382
2383    Just wrap up any local activities.  */
2384
2385 void
2386 ffestd_R911_finish ()
2387 {
2388   ffestd_check_finish_ ();
2389 }
2390
2391 /* ffestd_R919 -- BACKSPACE statement
2392
2393    ffestd_R919();
2394
2395    Make sure a BACKSPACE is valid in the current context, and implement it.  */
2396
2397 void
2398 ffestd_R919 ()
2399 {
2400   ffestdStmt_ stmt;
2401
2402   ffestd_check_simple_ ();
2403
2404   stmt = ffestd_stmt_new_ (FFESTD_stmtidR919_);
2405   ffestd_stmt_append_ (stmt);
2406   ffestd_subr_line_save_ (stmt);
2407   stmt->u.R919.pool = ffesta_output_pool;
2408   stmt->u.R919.params = ffestd_subr_copy_beru_ ();
2409   ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
2410 }
2411
2412 /* ffestd_R920 -- ENDFILE statement
2413
2414    ffestd_R920();
2415
2416    Make sure a ENDFILE is valid in the current context, and implement it.  */
2417
2418 void
2419 ffestd_R920 ()
2420 {
2421   ffestdStmt_ stmt;
2422
2423   ffestd_check_simple_ ();
2424
2425   stmt = ffestd_stmt_new_ (FFESTD_stmtidR920_);
2426   ffestd_stmt_append_ (stmt);
2427   ffestd_subr_line_save_ (stmt);
2428   stmt->u.R920.pool = ffesta_output_pool;
2429   stmt->u.R920.params = ffestd_subr_copy_beru_ ();
2430   ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
2431 }
2432
2433 /* ffestd_R921 -- REWIND statement
2434
2435    ffestd_R921();
2436
2437    Make sure a REWIND is valid in the current context, and implement it.  */
2438
2439 void
2440 ffestd_R921 ()
2441 {
2442   ffestdStmt_ stmt;
2443
2444   ffestd_check_simple_ ();
2445
2446   stmt = ffestd_stmt_new_ (FFESTD_stmtidR921_);
2447   ffestd_stmt_append_ (stmt);
2448   ffestd_subr_line_save_ (stmt);
2449   stmt->u.R921.pool = ffesta_output_pool;
2450   stmt->u.R921.params = ffestd_subr_copy_beru_ ();
2451   ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
2452 }
2453
2454 /* ffestd_R923A -- INQUIRE statement (non-IOLENGTH version)
2455
2456    ffestd_R923A(bool by_file);
2457
2458    Make sure an INQUIRE is valid in the current context, and implement it.  */
2459
2460 void
2461 ffestd_R923A (bool by_file)
2462 {
2463   ffestdStmt_ stmt;
2464
2465   ffestd_check_simple_ ();
2466
2467 #define specified(something) \
2468       (ffestp_file.inquire.inquire_spec[something].kw_or_val_present)
2469
2470   /* Warn if there are any thing we don't handle via f2c libraries. */
2471   if (specified (FFESTP_inquireixACTION)
2472       || specified (FFESTP_inquireixCARRIAGECONTROL)
2473       || specified (FFESTP_inquireixDEFAULTFILE)
2474       || specified (FFESTP_inquireixDELIM)
2475       || specified (FFESTP_inquireixKEYED)
2476       || specified (FFESTP_inquireixORGANIZATION)
2477       || specified (FFESTP_inquireixPAD)
2478       || specified (FFESTP_inquireixPOSITION)
2479       || specified (FFESTP_inquireixREAD)
2480       || specified (FFESTP_inquireixREADWRITE)
2481       || specified (FFESTP_inquireixRECORDTYPE)
2482       || specified (FFESTP_inquireixWRITE))
2483     {
2484       ffebad_start (FFEBAD_INQUIRE_UNSUPPORTED);
2485       ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
2486                    ffelex_token_where_column (ffesta_tokens[0]));
2487       ffebad_finish ();
2488     }
2489
2490 #undef specified
2491
2492   stmt = ffestd_stmt_new_ (FFESTD_stmtidR923A_);
2493   ffestd_stmt_append_ (stmt);
2494   ffestd_subr_line_save_ (stmt);
2495   stmt->u.R923A.pool = ffesta_output_pool;
2496   stmt->u.R923A.params = ffestd_subr_copy_inquire_ ();
2497   stmt->u.R923A.by_file = by_file;
2498   ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
2499 }
2500
2501 /* ffestd_R923B_start -- INQUIRE(IOLENGTH=expr) statement list begin
2502
2503    ffestd_R923B_start();
2504
2505    Verify that INQUIRE is valid here, and begin accepting items in the
2506    list.  */
2507
2508 void
2509 ffestd_R923B_start ()
2510 {
2511   ffestdStmt_ stmt;
2512
2513   ffestd_check_start_ ();
2514
2515   stmt = ffestd_stmt_new_ (FFESTD_stmtidR923B_);
2516   ffestd_stmt_append_ (stmt);
2517   ffestd_subr_line_save_ (stmt);
2518   stmt->u.R923B.pool = ffesta_output_pool;
2519   stmt->u.R923B.params = ffestd_subr_copy_inquire_ ();
2520   stmt->u.R923B.list = NULL;
2521   ffestd_expr_list_ = &stmt->u.R923B.list;
2522   ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
2523 }
2524
2525 /* ffestd_R923B_item -- INQUIRE statement i/o item
2526
2527    ffestd_R923B_item(expr,expr_token);
2528
2529    Implement output-list expression.  */
2530
2531 void
2532 ffestd_R923B_item (ffebld expr)
2533 {
2534   ffestdExprItem_ item;
2535
2536   ffestd_check_item_ ();
2537
2538   item = (ffestdExprItem_) malloc_new_kp (ffesta_output_pool,
2539                                           "ffestdExprItem_", sizeof (*item));
2540
2541   item->next = NULL;
2542   item->expr = expr;
2543   *ffestd_expr_list_ = item;
2544   ffestd_expr_list_ = &item->next;
2545 }
2546
2547 /* ffestd_R923B_finish -- INQUIRE statement list complete
2548
2549    ffestd_R923B_finish();
2550
2551    Just wrap up any local activities.  */
2552
2553 void
2554 ffestd_R923B_finish ()
2555 {
2556   ffestd_check_finish_ ();
2557 }
2558
2559 /* ffestd_R1001 -- FORMAT statement
2560
2561    ffestd_R1001(format_list);  */
2562
2563 void
2564 ffestd_R1001 (ffesttFormatList f)
2565 {
2566   ffestsHolder str;
2567   ffests s = &str;
2568   ffestdStmt_ stmt;
2569
2570   ffestd_check_simple_ ();
2571
2572   if (ffestd_label_formatdef_ == NULL)
2573     return;                     /* Nothing to hook it up to (no label def). */
2574
2575   ffests_new (s, malloc_pool_image (), 80);
2576   ffests_putc (s, '(');
2577   ffestd_R1001dump_ (s, f);     /* Build the string in s. */
2578   ffests_putc (s, ')');
2579
2580   stmt = ffestd_stmt_new_ (FFESTD_stmtidR1001_);
2581   ffestd_stmt_append_ (stmt);
2582   stmt->u.R1001.str = str;
2583
2584   ffestd_label_formatdef_ = NULL;
2585 }
2586
2587 /* ffestd_R1001dump_ -- Dump list of formats
2588
2589    ffesttFormatList list;
2590    ffestd_R1001dump_(list,0);
2591
2592    The formats in the list are dumped.  */
2593
2594 static void
2595 ffestd_R1001dump_ (ffests s, ffesttFormatList list)
2596 {
2597   ffesttFormatList next;
2598
2599   for (next = list->next; next != list; next = next->next)
2600     {
2601       if (next != list->next)
2602         ffests_putc (s, ',');
2603       switch (next->type)
2604         {
2605         case FFESTP_formattypeI:
2606           ffestd_R1001dump_1005_3_ (s, next, "I");
2607           break;
2608
2609         case FFESTP_formattypeB:
2610           ffestd_R1001error_ (next);
2611           break;
2612
2613         case FFESTP_formattypeO:
2614           ffestd_R1001dump_1005_3_ (s, next, "O");
2615           break;
2616
2617         case FFESTP_formattypeZ:
2618           ffestd_R1001dump_1005_3_ (s, next, "Z");
2619           break;
2620
2621         case FFESTP_formattypeF:
2622           ffestd_R1001dump_1005_4_ (s, next, "F");
2623           break;
2624
2625         case FFESTP_formattypeE:
2626           ffestd_R1001dump_1005_5_ (s, next, "E");
2627           break;
2628
2629         case FFESTP_formattypeEN:
2630           ffestd_R1001error_ (next);
2631           break;
2632
2633         case FFESTP_formattypeG:
2634           ffestd_R1001dump_1005_5_ (s, next, "G");
2635           break;
2636
2637         case FFESTP_formattypeL:
2638           ffestd_R1001dump_1005_2_ (s, next, "L");
2639           break;
2640
2641         case FFESTP_formattypeA:
2642           ffestd_R1001dump_1005_1_ (s, next, "A");
2643           break;
2644
2645         case FFESTP_formattypeD:
2646           ffestd_R1001dump_1005_4_ (s, next, "D");
2647           break;
2648
2649         case FFESTP_formattypeQ:
2650           ffestd_R1001error_ (next);
2651           break;
2652
2653         case FFESTP_formattypeDOLLAR:
2654           ffestd_R1001dump_1010_1_ (s, next, "$");
2655           break;
2656
2657         case FFESTP_formattypeP:
2658           ffestd_R1001dump_1010_4_ (s, next, "P");
2659           break;
2660
2661         case FFESTP_formattypeT:
2662           ffestd_R1001dump_1010_5_ (s, next, "T");
2663           break;
2664
2665         case FFESTP_formattypeTL:
2666           ffestd_R1001dump_1010_5_ (s, next, "TL");
2667           break;
2668
2669         case FFESTP_formattypeTR:
2670           ffestd_R1001dump_1010_5_ (s, next, "TR");
2671           break;
2672
2673         case FFESTP_formattypeX:
2674           ffestd_R1001dump_1010_2_ (s, next, "X");
2675           break;
2676
2677         case FFESTP_formattypeS:
2678           ffestd_R1001dump_1010_1_ (s, next, "S");
2679           break;
2680
2681         case FFESTP_formattypeSP:
2682           ffestd_R1001dump_1010_1_ (s, next, "SP");
2683           break;
2684
2685         case FFESTP_formattypeSS:
2686           ffestd_R1001dump_1010_1_ (s, next, "SS");
2687           break;
2688
2689         case FFESTP_formattypeBN:
2690           ffestd_R1001dump_1010_1_ (s, next, "BN");
2691           break;
2692
2693         case FFESTP_formattypeBZ:
2694           ffestd_R1001dump_1010_1_ (s, next, "BZ");
2695           break;
2696
2697         case FFESTP_formattypeSLASH:
2698           ffestd_R1001dump_1010_2_ (s, next, "/");
2699           break;
2700
2701         case FFESTP_formattypeCOLON:
2702           ffestd_R1001dump_1010_1_ (s, next, ":");
2703           break;
2704
2705         case FFESTP_formattypeR1016:
2706           switch (ffelex_token_type (next->t))
2707             {
2708             case FFELEX_typeCHARACTER:
2709               {
2710                 char *p = ffelex_token_text (next->t);
2711                 ffeTokenLength i = ffelex_token_length (next->t);
2712
2713                 ffests_putc (s, '\002');
2714                 while (i-- != 0)
2715                   {
2716                     if (*p == '\002')
2717                       ffests_putc (s, '\002');
2718                     ffests_putc (s, *p);
2719                     ++p;
2720                   }
2721                 ffests_putc (s, '\002');
2722               }
2723               break;
2724
2725             case FFELEX_typeHOLLERITH:
2726               {
2727                 char *p = ffelex_token_text (next->t);
2728                 ffeTokenLength i = ffelex_token_length (next->t);
2729
2730                 ffests_printf (s, "%" ffeTokenLength_f "uH", i);
2731                 while (i-- != 0)
2732                   {
2733                     ffests_putc (s, *p);
2734                     ++p;
2735                   }
2736               }
2737               break;
2738
2739             default:
2740               assert (FALSE);
2741             }
2742           break;
2743
2744         case FFESTP_formattypeFORMAT:
2745           if (next->u.R1003D.R1004.present)
2746             {
2747               if (next->u.R1003D.R1004.rtexpr)
2748                 ffestd_R1001rtexpr_ (s, next, next->u.R1003D.R1004.u.expr);
2749               else
2750                 ffests_printf (s, "%lu", next->u.R1003D.R1004.u.unsigned_val);
2751             }
2752
2753           ffests_putc (s, '(');
2754           ffestd_R1001dump_ (s, next->u.R1003D.format);
2755           ffests_putc (s, ')');
2756           break;
2757
2758         default:
2759           assert (FALSE);
2760         }
2761     }
2762 }
2763
2764 /* ffestd_R1001dump_1005_1_ -- Dump a particular format
2765
2766    ffesttFormatList f;
2767    ffestd_R1001dump_1005_1_(f,"I");
2768
2769    The format is dumped with form [r]X[w].  */
2770
2771 static void
2772 ffestd_R1001dump_1005_1_ (ffests s, ffesttFormatList f, const char *string)
2773 {
2774   assert (!f->u.R1005.R1007_or_R1008.present);
2775   assert (!f->u.R1005.R1009.present);
2776
2777   if (f->u.R1005.R1004.present)
2778     {
2779       if (f->u.R1005.R1004.rtexpr)
2780         ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1004.u.expr);
2781       else
2782         ffests_printf (s, "%lu", f->u.R1005.R1004.u.unsigned_val);
2783     }
2784
2785   ffests_puts (s, string);
2786
2787   if (f->u.R1005.R1006.present)
2788     {
2789       if (f->u.R1005.R1006.rtexpr)
2790         ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1006.u.expr);
2791       else
2792         ffests_printf (s, "%lu", f->u.R1005.R1006.u.unsigned_val);
2793     }
2794 }
2795
2796 /* ffestd_R1001dump_1005_2_ -- Dump a particular format
2797
2798    ffesttFormatList f;
2799    ffestd_R1001dump_1005_2_(f,"I");
2800
2801    The format is dumped with form [r]Xw.  */
2802
2803 static void
2804 ffestd_R1001dump_1005_2_ (ffests s, ffesttFormatList f, const char *string)
2805 {
2806   assert (!f->u.R1005.R1007_or_R1008.present);
2807   assert (!f->u.R1005.R1009.present);
2808   assert (f->u.R1005.R1006.present);
2809
2810   if (f->u.R1005.R1004.present)
2811     {
2812       if (f->u.R1005.R1004.rtexpr)
2813         ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1004.u.expr);
2814       else
2815         ffests_printf (s, "%lu", f->u.R1005.R1004.u.unsigned_val);
2816     }
2817
2818   ffests_puts (s, string);
2819
2820   if (f->u.R1005.R1006.rtexpr)
2821     ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1006.u.expr);
2822   else
2823     ffests_printf (s, "%lu", f->u.R1005.R1006.u.unsigned_val);
2824 }
2825
2826 /* ffestd_R1001dump_1005_3_ -- Dump a particular format
2827
2828    ffesttFormatList f;
2829    ffestd_R1001dump_1005_3_(f,"I");
2830
2831    The format is dumped with form [r]Xw[.m].  */
2832
2833 static void
2834 ffestd_R1001dump_1005_3_ (ffests s, ffesttFormatList f, const char *string)
2835 {
2836   assert (!f->u.R1005.R1009.present);
2837   assert (f->u.R1005.R1006.present);
2838
2839   if (f->u.R1005.R1004.present)
2840     {
2841       if (f->u.R1005.R1004.rtexpr)
2842         ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1004.u.expr);
2843       else
2844         ffests_printf (s, "%lu", f->u.R1005.R1004.u.unsigned_val);
2845     }
2846
2847   ffests_puts (s, string);
2848
2849   if (f->u.R1005.R1006.rtexpr)
2850     ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1006.u.expr);
2851   else
2852     ffests_printf (s, "%lu", f->u.R1005.R1006.u.unsigned_val);
2853
2854   if (f->u.R1005.R1007_or_R1008.present)
2855     {
2856       ffests_putc (s, '.');
2857       if (f->u.R1005.R1007_or_R1008.rtexpr)
2858         ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1007_or_R1008.u.expr);
2859       else
2860         ffests_printf (s, "%lu", f->u.R1005.R1007_or_R1008.u.unsigned_val);
2861     }
2862 }
2863
2864 /* ffestd_R1001dump_1005_4_ -- Dump a particular format
2865
2866    ffesttFormatList f;
2867    ffestd_R1001dump_1005_4_(f,"I");
2868
2869    The format is dumped with form [r]Xw.d.  */
2870
2871 static void
2872 ffestd_R1001dump_1005_4_ (ffests s, ffesttFormatList f, const char *string)
2873 {
2874   assert (!f->u.R1005.R1009.present);
2875   assert (f->u.R1005.R1007_or_R1008.present);
2876   assert (f->u.R1005.R1006.present);
2877
2878   if (f->u.R1005.R1004.present)
2879     {
2880       if (f->u.R1005.R1004.rtexpr)
2881         ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1004.u.expr);
2882       else
2883         ffests_printf (s, "%lu", f->u.R1005.R1004.u.unsigned_val);
2884     }
2885
2886   ffests_puts (s, string);
2887
2888   if (f->u.R1005.R1006.rtexpr)
2889     ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1006.u.expr);
2890   else
2891     ffests_printf (s, "%lu", f->u.R1005.R1006.u.unsigned_val);
2892
2893   ffests_putc (s, '.');
2894   if (f->u.R1005.R1007_or_R1008.rtexpr)
2895     ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1007_or_R1008.u.expr);
2896   else
2897     ffests_printf (s, "%lu", f->u.R1005.R1007_or_R1008.u.unsigned_val);
2898 }
2899
2900 /* ffestd_R1001dump_1005_5_ -- Dump a particular format
2901
2902    ffesttFormatList f;
2903    ffestd_R1001dump_1005_5_(f,"I");
2904
2905    The format is dumped with form [r]Xw.d[Ee].  */
2906
2907 static void
2908 ffestd_R1001dump_1005_5_ (ffests s, ffesttFormatList f, const char *string)
2909 {
2910   assert (f->u.R1005.R1007_or_R1008.present);
2911   assert (f->u.R1005.R1006.present);
2912
2913   if (f->u.R1005.R1004.present)
2914     {
2915       if (f->u.R1005.R1004.rtexpr)
2916         ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1004.u.expr);
2917       else
2918         ffests_printf (s, "%lu", f->u.R1005.R1004.u.unsigned_val);
2919     }
2920
2921   ffests_puts (s, string);
2922
2923   if (f->u.R1005.R1006.rtexpr)
2924     ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1006.u.expr);
2925   else
2926     ffests_printf (s, "%lu", f->u.R1005.R1006.u.unsigned_val);
2927
2928   ffests_putc (s, '.');
2929   if (f->u.R1005.R1007_or_R1008.rtexpr)
2930     ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1007_or_R1008.u.expr);
2931   else
2932     ffests_printf (s, "%lu", f->u.R1005.R1007_or_R1008.u.unsigned_val);
2933
2934   if (f->u.R1005.R1009.present)
2935     {
2936       ffests_putc (s, 'E');
2937       if (f->u.R1005.R1009.rtexpr)
2938         ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1009.u.expr);
2939       else
2940         ffests_printf (s, "%lu", f->u.R1005.R1009.u.unsigned_val);
2941     }
2942 }
2943
2944 /* ffestd_R1001dump_1010_1_ -- Dump a particular format
2945
2946    ffesttFormatList f;
2947    ffestd_R1001dump_1010_1_(f,"I");
2948
2949    The format is dumped with form X.  */
2950
2951 static void
2952 ffestd_R1001dump_1010_1_ (ffests s, ffesttFormatList f, const char *string)
2953 {
2954   assert (!f->u.R1010.val.present);
2955
2956   ffests_puts (s, string);
2957 }
2958
2959 /* ffestd_R1001dump_1010_2_ -- Dump a particular format
2960
2961    ffesttFormatList f;
2962    ffestd_R1001dump_1010_2_(f,"I");
2963
2964    The format is dumped with form [r]X.  */
2965
2966 static void
2967 ffestd_R1001dump_1010_2_ (ffests s, ffesttFormatList f, const char *string)
2968 {
2969   if (f->u.R1010.val.present)
2970     {
2971       if (f->u.R1010.val.rtexpr)
2972         ffestd_R1001rtexpr_ (s, f, f->u.R1010.val.u.expr);
2973       else
2974         ffests_printf (s, "%lu", f->u.R1010.val.u.unsigned_val);
2975     }
2976
2977   ffests_puts (s, string);
2978 }
2979
2980 /* ffestd_R1001dump_1010_4_ -- Dump a particular format
2981
2982    ffesttFormatList f;
2983    ffestd_R1001dump_1010_4_(f,"I");
2984
2985    The format is dumped with form kX.  Note that k is signed.  */
2986
2987 static void
2988 ffestd_R1001dump_1010_4_ (ffests s, ffesttFormatList f, const char *string)
2989 {
2990   assert (f->u.R1010.val.present);
2991
2992   if (f->u.R1010.val.rtexpr)
2993     ffestd_R1001rtexpr_ (s, f, f->u.R1010.val.u.expr);
2994   else
2995     ffests_printf (s, "%ld", f->u.R1010.val.u.signed_val);
2996
2997   ffests_puts (s, string);
2998 }
2999
3000 /* ffestd_R1001dump_1010_5_ -- Dump a particular format
3001
3002    ffesttFormatList f;
3003    ffestd_R1001dump_1010_5_(f,"I");
3004
3005    The format is dumped with form Xn.  */
3006
3007 static void
3008 ffestd_R1001dump_1010_5_ (ffests s, ffesttFormatList f, const char *string)
3009 {
3010   assert (f->u.R1010.val.present);
3011
3012   ffests_puts (s, string);
3013
3014   if (f->u.R1010.val.rtexpr)
3015     ffestd_R1001rtexpr_ (s, f, f->u.R1010.val.u.expr);
3016   else
3017     ffests_printf (s, "%lu", f->u.R1010.val.u.unsigned_val);
3018 }
3019
3020 /* ffestd_R1001error_ -- Complain about FORMAT specification not supported
3021
3022    ffesttFormatList f;
3023    ffestd_R1001error_(f);
3024
3025    An error message is produced.  */
3026
3027 static void
3028 ffestd_R1001error_ (ffesttFormatList f)
3029 {
3030   ffebad_start (FFEBAD_FORMAT_UNSUPPORTED);
3031   ffebad_here (0, ffelex_token_where_line (f->t), ffelex_token_where_column (f->t));
3032   ffebad_finish ();
3033 }
3034
3035 static void
3036 ffestd_R1001rtexpr_ (ffests s, ffesttFormatList f, ffebld expr)
3037 {
3038   if ((expr == NULL)
3039       || (ffebld_op (expr) != FFEBLD_opCONTER)
3040       || (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeINTEGER)
3041       || (ffeinfo_kindtype (ffebld_info (expr)) == FFEINFO_kindtypeINTEGER4))
3042     {
3043       ffebad_start (FFEBAD_FORMAT_VARIABLE);
3044       ffebad_here (0, ffelex_token_where_line (f->t), ffelex_token_where_column (f->t));
3045       ffebad_finish ();
3046     }
3047   else
3048     {
3049       int val;
3050
3051       switch (ffeinfo_kindtype (ffebld_info (expr)))
3052         {
3053 #if FFETARGET_okINTEGER1
3054         case FFEINFO_kindtypeINTEGER1:
3055           val = ffebld_constant_integer1 (ffebld_conter (expr));
3056           break;
3057 #endif
3058
3059 #if FFETARGET_okINTEGER2
3060         case FFEINFO_kindtypeINTEGER2:
3061           val = ffebld_constant_integer2 (ffebld_conter (expr));
3062           break;
3063 #endif
3064
3065 #if FFETARGET_okINTEGER3
3066         case FFEINFO_kindtypeINTEGER3:
3067           val = ffebld_constant_integer3 (ffebld_conter (expr));
3068           break;
3069 #endif
3070
3071         default:
3072           assert ("bad INTEGER constant kind type" == NULL);
3073           /* Fall through. */
3074         case FFEINFO_kindtypeANY:
3075           return;
3076         }
3077       ffests_printf (s, "%ld", (long) val);
3078     }
3079 }
3080
3081 /* ffestd_R1102 -- PROGRAM statement
3082
3083    ffestd_R1102(name_token);
3084
3085    Make sure ffestd_kind_ identifies an empty block.  Make sure name_token
3086    gives a valid name.  Implement the beginning of a main program.  */
3087
3088 void
3089 ffestd_R1102 (ffesymbol s, ffelexToken name UNUSED)
3090 {
3091   ffestd_check_simple_ ();
3092
3093   assert (ffestd_block_level_ == 0);
3094   ffestd_is_reachable_ = TRUE;
3095
3096   ffecom_notify_primary_entry (s);
3097   ffe_set_is_mainprog (TRUE);   /* Is a main program. */
3098   ffe_set_is_saveall (TRUE);    /* Main program always has implicit SAVE. */
3099
3100   ffestw_set_sym (ffestw_stack_top (), s);
3101 }
3102
3103 /* ffestd_R1103 -- End a PROGRAM
3104
3105    ffestd_R1103();  */
3106
3107 void
3108 ffestd_R1103 (bool ok UNUSED)
3109 {
3110   ffestdStmt_ stmt;
3111
3112   assert (ffestd_block_level_ == 0);
3113
3114   if (FFESTD_IS_END_OPTIMIZED_ && ffestd_is_reachable_)
3115     ffestd_R842 (NULL);         /* Generate STOP. */
3116
3117   if (ffestw_state (ffestw_stack_top ()) != FFESTV_statePROGRAM5)
3118     ffestd_subr_labels_ (FALSE);/* Handle any undefined labels. */
3119
3120   stmt = ffestd_stmt_new_ (FFESTD_stmtidR1103_);
3121   ffestd_stmt_append_ (stmt);
3122 }
3123
3124 /* ffestd_R1111 -- BLOCK DATA statement
3125
3126    ffestd_R1111(name_token);
3127
3128    Make sure ffestd_kind_ identifies no current program unit.  If not
3129    NULL, make sure name_token gives a valid name.  Implement the beginning
3130    of a block data program unit.  */
3131
3132 void
3133 ffestd_R1111 (ffesymbol s, ffelexToken name UNUSED)
3134 {
3135   assert (ffestd_block_level_ == 0);
3136   ffestd_is_reachable_ = TRUE;
3137
3138   ffestd_check_simple_ ();
3139
3140   ffecom_notify_primary_entry (s);
3141   ffestw_set_sym (ffestw_stack_top (), s);
3142 }
3143
3144 /* ffestd_R1112 -- End a BLOCK DATA
3145
3146    ffestd_R1112(TRUE);  */
3147
3148 void
3149 ffestd_R1112 (bool ok UNUSED)
3150 {
3151   ffestdStmt_ stmt;
3152
3153   assert (ffestd_block_level_ == 0);
3154
3155   /* Generate any return-like code here (not likely for BLOCK DATA!). */
3156
3157   if (ffestw_state (ffestw_stack_top ()) != FFESTV_stateBLOCKDATA5)
3158     ffestd_subr_labels_ (TRUE); /* Handle any undefined labels. */
3159
3160   stmt = ffestd_stmt_new_ (FFESTD_stmtidR1112_);
3161   ffestd_stmt_append_ (stmt);
3162 }
3163
3164 /* ffestd_R1207_start -- EXTERNAL statement list begin
3165
3166    ffestd_R1207_start();
3167
3168    Verify that EXTERNAL is valid here, and begin accepting items in the list.  */
3169
3170 void
3171 ffestd_R1207_start ()
3172 {
3173   ffestd_check_start_ ();
3174 }
3175
3176 /* ffestd_R1207_item -- EXTERNAL statement for name
3177
3178    ffestd_R1207_item(name_token);
3179
3180    Make sure name_token identifies a valid object to be EXTERNALd.  */
3181
3182 void
3183 ffestd_R1207_item (ffelexToken name)
3184 {
3185   ffestd_check_item_ ();
3186   assert (name != NULL);
3187 }
3188
3189 /* ffestd_R1207_finish -- EXTERNAL statement list complete
3190
3191    ffestd_R1207_finish();
3192
3193    Just wrap up any local activities.  */
3194
3195 void
3196 ffestd_R1207_finish ()
3197 {
3198   ffestd_check_finish_ ();
3199 }
3200
3201 /* ffestd_R1208_start -- INTRINSIC statement list begin
3202
3203    ffestd_R1208_start();
3204
3205    Verify that INTRINSIC is valid here, and begin accepting items in the list.  */
3206
3207 void
3208 ffestd_R1208_start ()
3209 {
3210   ffestd_check_start_ ();
3211 }
3212
3213 /* ffestd_R1208_item -- INTRINSIC statement for name
3214
3215    ffestd_R1208_item(name_token);
3216
3217    Make sure name_token identifies a valid object to be INTRINSICd.  */
3218
3219 void
3220 ffestd_R1208_item (ffelexToken name)
3221 {
3222   ffestd_check_item_ ();
3223   assert (name != NULL);
3224 }
3225
3226 /* ffestd_R1208_finish -- INTRINSIC statement list complete
3227
3228    ffestd_R1208_finish();
3229
3230    Just wrap up any local activities.  */
3231
3232 void
3233 ffestd_R1208_finish ()
3234 {
3235   ffestd_check_finish_ ();
3236 }
3237
3238 /* ffestd_R1212 -- CALL statement
3239
3240    ffestd_R1212(expr,expr_token);
3241
3242    Make sure statement is valid here; implement.  */
3243
3244 void
3245 ffestd_R1212 (ffebld expr)
3246 {
3247   ffestdStmt_ stmt;
3248
3249   ffestd_check_simple_ ();
3250
3251   stmt = ffestd_stmt_new_ (FFESTD_stmtidR1212_);
3252   ffestd_stmt_append_ (stmt);
3253   ffestd_subr_line_save_ (stmt);
3254   stmt->u.R1212.pool = ffesta_output_pool;
3255   stmt->u.R1212.expr = expr;
3256   ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
3257 }
3258
3259 /* ffestd_R1219 -- FUNCTION statement
3260
3261    ffestd_R1219(funcname,arglist,ending_token,kind,kindt,len,lent,
3262          recursive);
3263
3264    Make sure statement is valid here, register arguments for the
3265    function name, and so on.
3266
3267    06-Jun-90  JCB  2.0
3268       Added the kind, len, and recursive arguments.  */
3269
3270 void
3271 ffestd_R1219 (ffesymbol s, ffelexToken funcname UNUSED,
3272               ffesttTokenList args UNUSED, ffestpType type UNUSED,
3273               ffebld kind UNUSED, ffelexToken kindt UNUSED,
3274               ffebld len UNUSED, ffelexToken lent UNUSED,
3275               bool recursive UNUSED, ffelexToken result UNUSED,
3276               bool separate_result UNUSED)
3277 {
3278   assert (ffestd_block_level_ == 0);
3279   ffestd_is_reachable_ = TRUE;
3280
3281   ffestd_check_simple_ ();
3282
3283   ffecom_notify_primary_entry (s);
3284   ffestw_set_sym (ffestw_stack_top (), s);
3285 }
3286
3287 /* ffestd_R1221 -- End a FUNCTION
3288
3289    ffestd_R1221(TRUE);  */
3290
3291 void
3292 ffestd_R1221 (bool ok UNUSED)
3293 {
3294   ffestdStmt_ stmt;
3295
3296   assert (ffestd_block_level_ == 0);
3297
3298   if (FFESTD_IS_END_OPTIMIZED_ && ffestd_is_reachable_)
3299     ffestd_R1227 (NULL);        /* Generate RETURN. */
3300
3301   if (ffestw_state (ffestw_stack_top ()) != FFESTV_stateFUNCTION5)
3302     ffestd_subr_labels_ (FALSE);/* Handle any undefined labels. */
3303
3304   stmt = ffestd_stmt_new_ (FFESTD_stmtidR1221_);
3305   ffestd_stmt_append_ (stmt);
3306 }
3307
3308 /* ffestd_R1223 -- SUBROUTINE statement
3309
3310    ffestd_R1223(subrname,arglist,ending_token,recursive_token);
3311
3312    Make sure statement is valid here, register arguments for the
3313    subroutine name, and so on.
3314
3315    06-Jun-90  JCB  2.0
3316       Added the recursive argument.  */
3317
3318 void
3319 ffestd_R1223 (ffesymbol s, ffelexToken subrname UNUSED,
3320               ffesttTokenList args UNUSED, ffelexToken final UNUSED,
3321               bool recursive UNUSED)
3322 {
3323   assert (ffestd_block_level_ == 0);
3324   ffestd_is_reachable_ = TRUE;
3325
3326   ffestd_check_simple_ ();
3327
3328   ffecom_notify_primary_entry (s);
3329   ffestw_set_sym (ffestw_stack_top (), s);
3330 }
3331
3332 /* ffestd_R1225 -- End a SUBROUTINE
3333
3334    ffestd_R1225(TRUE);  */
3335
3336 void
3337 ffestd_R1225 (bool ok UNUSED)
3338 {
3339   ffestdStmt_ stmt;
3340
3341   assert (ffestd_block_level_ == 0);
3342
3343   if (FFESTD_IS_END_OPTIMIZED_ && ffestd_is_reachable_)
3344     ffestd_R1227 (NULL);        /* Generate RETURN. */
3345
3346   if (ffestw_state (ffestw_stack_top ()) != FFESTV_stateSUBROUTINE5)
3347     ffestd_subr_labels_ (FALSE);/* Handle any undefined labels. */
3348
3349   stmt = ffestd_stmt_new_ (FFESTD_stmtidR1225_);
3350   ffestd_stmt_append_ (stmt);
3351 }
3352
3353 /* ffestd_R1226 -- ENTRY statement
3354
3355    ffestd_R1226(entryname,arglist,ending_token);
3356
3357    Make sure we're in a SUBROUTINE or FUNCTION, register arguments for the
3358    entry point name, and so on.  */
3359
3360 void
3361 ffestd_R1226 (ffesymbol entry)
3362 {
3363   ffestd_check_simple_ ();
3364
3365   if (!ffesta_seen_first_exec || ffecom_2pass_advise_entrypoint (entry))
3366     {
3367       ffestdStmt_ stmt;
3368
3369       stmt = ffestd_stmt_new_ (FFESTD_stmtidR1226_);
3370       ffestd_stmt_append_ (stmt);
3371       ffestd_subr_line_save_ (stmt);
3372       stmt->u.R1226.entry = entry;
3373       stmt->u.R1226.entrynum = ++ffestd_2pass_entrypoints_;
3374     }
3375
3376   ffestd_is_reachable_ = TRUE;
3377 }
3378
3379 /* ffestd_R1227 -- RETURN statement
3380
3381    ffestd_R1227(expr);
3382
3383    Make sure statement is valid here; implement.  expr and expr_token are
3384    both NULL if there was no expression.  */
3385
3386 void
3387 ffestd_R1227 (ffebld expr)
3388 {
3389   ffestdStmt_ stmt;
3390
3391   ffestd_check_simple_ ();
3392
3393   stmt = ffestd_stmt_new_ (FFESTD_stmtidR1227_);
3394   ffestd_stmt_append_ (stmt);
3395   ffestd_subr_line_save_ (stmt);
3396   stmt->u.R1227.pool = ffesta_output_pool;
3397   stmt->u.R1227.block = ffestw_stack_top ();
3398   stmt->u.R1227.expr = expr;
3399   ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
3400
3401   if (ffestd_block_level_ == 0)
3402     ffestd_is_reachable_ = FALSE;
3403 }
3404
3405 /* ffestd_R1229_start -- STMTFUNCTION statement begin
3406
3407    ffestd_R1229_start(func_name,func_arg_list,close_paren);
3408
3409    This function does not really need to do anything, since _finish_
3410    gets all the info needed, and ffestc_R1229_start has already
3411    done all the stuff that makes a two-phase operation (start and
3412    finish) for handling statement functions necessary.
3413
3414    03-Jan-91  JCB  2.0
3415       Do nothing, now that _finish_ does everything.  */
3416
3417 void
3418 ffestd_R1229_start (ffelexToken name UNUSED, ffesttTokenList args UNUSED)
3419 {
3420   ffestd_check_start_ ();
3421 }
3422
3423 /* ffestd_R1229_finish -- STMTFUNCTION statement list complete
3424
3425    ffestd_R1229_finish(s);
3426
3427    The statement function's symbol is passed.  Its list of dummy args is
3428    accessed via ffesymbol_dummyargs and its expansion expression (expr)
3429    is accessed via ffesymbol_sfexpr.
3430
3431    If sfexpr is NULL, an error occurred parsing the expansion expression, so
3432    just cancel the effects of ffestd_R1229_start and pretend nothing
3433    happened.  Otherwise, install the expression as the expansion for the
3434    statement function, then clean up.
3435
3436    03-Jan-91  JCB  2.0
3437       Takes sfunc sym instead of just the expansion expression as an
3438       argument, so this function can do all the work, and _start_ is just
3439       a nicety than can do nothing in a back end.  */
3440
3441 void
3442 ffestd_R1229_finish (ffesymbol s)
3443 {
3444   ffebld expr = ffesymbol_sfexpr (s);
3445
3446   ffestd_check_finish_ ();
3447
3448   if (expr == NULL)
3449     return;                     /* Nothing to do, definition didn't work. */
3450
3451   /* With gcc, cannot do anything here, because the backend hasn't even
3452      (necessarily) been notified that we're compiling a program unit! */
3453   ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
3454 }
3455
3456 /* ffestd_S3P4 -- INCLUDE line
3457
3458    ffestd_S3P4(filename,filename_token);
3459
3460    Make sure INCLUDE not preceded by any semicolons or a label def; implement.  */
3461
3462 void
3463 ffestd_S3P4 (ffebld filename)
3464 {
3465   FILE *fi;
3466   ffetargetCharacterDefault buildname;
3467   ffewhereFile wf;
3468
3469   ffestd_check_simple_ ();
3470
3471   assert (filename != NULL);
3472   if (ffebld_op (filename) != FFEBLD_opANY)
3473     {
3474       assert (ffebld_op (filename) == FFEBLD_opCONTER);
3475       assert (ffeinfo_basictype (ffebld_info (filename))
3476               == FFEINFO_basictypeCHARACTER);
3477       assert (ffeinfo_kindtype (ffebld_info (filename))
3478               == FFEINFO_kindtypeCHARACTERDEFAULT);
3479       buildname = ffebld_constant_characterdefault (ffebld_conter (filename));
3480       wf = ffewhere_file_new (ffetarget_text_characterdefault (buildname),
3481                               ffetarget_length_characterdefault (buildname));
3482       fi = ffecom_open_include (ffewhere_file_name (wf),
3483                                 ffelex_token_where_line (ffesta_tokens[0]),
3484                                 ffelex_token_where_column (ffesta_tokens[0]));
3485       if (fi != NULL)
3486         ffelex_set_include (wf, (ffelex_token_type (ffesta_tokens[0])
3487                                  == FFELEX_typeNAME), fi);
3488     }
3489 }
3490
3491 /* ffestd_V014_start -- VOLATILE statement list begin
3492
3493    ffestd_V014_start();
3494
3495    Verify that VOLATILE is valid here, and begin accepting items in the list.  */
3496
3497 void
3498 ffestd_V014_start ()
3499 {
3500   ffestd_check_start_ ();
3501 }
3502
3503 /* ffestd_V014_item_object -- VOLATILE statement for object-name
3504
3505    ffestd_V014_item_object(name_token);
3506
3507    Make sure name_token identifies a valid object to be VOLATILEd.  */
3508
3509 void
3510 ffestd_V014_item_object (ffelexToken name UNUSED)
3511 {
3512   ffestd_check_item_ ();
3513 }
3514
3515 /* ffestd_V014_item_cblock -- VOLATILE statement for common-block-name
3516
3517    ffestd_V014_item_cblock(name_token);
3518
3519    Make sure name_token identifies a valid common block to be VOLATILEd.  */
3520
3521 void
3522 ffestd_V014_item_cblock (ffelexToken name UNUSED)
3523 {
3524   ffestd_check_item_ ();
3525 }
3526
3527 /* ffestd_V014_finish -- VOLATILE statement list complete
3528
3529    ffestd_V014_finish();
3530
3531    Just wrap up any local activities.  */
3532
3533 void
3534 ffestd_V014_finish ()
3535 {
3536   ffestd_check_finish_ ();
3537 }
3538
3539 /* ffestd_V020_start -- TYPE statement list begin
3540
3541    ffestd_V020_start();
3542
3543    Verify that TYPE is valid here, and begin accepting items in the
3544    list.  */
3545
3546 void
3547 ffestd_V020_start (ffestvFormat format UNUSED)
3548 {
3549   ffestd_check_start_ ();
3550   ffestd_subr_vxt_ ();
3551 }
3552
3553 /* ffestd_V020_item -- TYPE statement i/o item
3554
3555    ffestd_V020_item(expr,expr_token);
3556
3557    Implement output-list expression.  */
3558
3559 void
3560 ffestd_V020_item (ffebld expr UNUSED)
3561 {
3562   ffestd_check_item_ ();
3563 }
3564
3565 /* ffestd_V020_finish -- TYPE statement list complete
3566
3567    ffestd_V020_finish();
3568
3569    Just wrap up any local activities.  */
3570
3571 void
3572 ffestd_V020_finish ()
3573 {
3574   ffestd_check_finish_ ();
3575 }
3576
3577 /* ffestd_V027_start -- VXT PARAMETER statement list begin
3578
3579    ffestd_V027_start();
3580
3581    Verify that PARAMETER is valid here, and begin accepting items in the list.  */
3582
3583 void
3584 ffestd_V027_start ()
3585 {
3586   ffestd_check_start_ ();
3587   ffestd_subr_vxt_ ();
3588 }
3589
3590 /* ffestd_V027_item -- VXT PARAMETER statement assignment
3591
3592    ffestd_V027_item(dest,dest_token,source,source_token);
3593
3594    Make sure the source is a valid source for the destination; make the
3595    assignment.  */
3596
3597 void
3598 ffestd_V027_item (ffelexToken dest_token UNUSED, ffebld source UNUSED)
3599 {
3600   ffestd_check_item_ ();
3601 }
3602
3603 /* ffestd_V027_finish -- VXT PARAMETER statement list complete
3604
3605    ffestd_V027_finish();
3606
3607    Just wrap up any local activities.  */
3608
3609 void
3610 ffestd_V027_finish ()
3611 {
3612   ffestd_check_finish_ ();
3613 }
3614
3615 /* Any executable statement.  */
3616
3617 void
3618 ffestd_any ()
3619 {
3620   ffestdStmt_ stmt;
3621
3622   ffestd_check_simple_ ();
3623
3624   stmt = ffestd_stmt_new_ (FFESTD_stmtidR841_);
3625   ffestd_stmt_append_ (stmt);
3626   ffestd_subr_line_save_ (stmt);
3627 }