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_ (void)
 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 = malloc_new_kp (ffesta_output_pool, "FFESTD easy",
 988                         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_ (void)
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 (void)
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 (void)
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 (void)
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 (void)
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 (void)
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 (void)
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 (void)
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 (void)
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 (void)
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 (void)
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 (void)
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 (void)
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 (void)
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 (void)
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 (void)
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 (void)
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 (void)
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 (void)
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 (void)
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 = malloc_new_kp (ffesta_output_pool, "ffestdExprItem_", sizeof (*item));
2233
2234   item->next = NULL;
2235   item->expr = expr;
2236   item->token = ffelex_token_use (expr_token);
2237   *ffestd_expr_list_ = item;
2238   ffestd_expr_list_ = &item->next;
2239 }
2240
2241 /* ffestd_R909_finish -- READ statement list complete
2242
2243    ffestd_R909_finish();
2244
2245    Just wrap up any local activities.  */
2246
2247 void
2248 ffestd_R909_finish (void)
2249 {
2250   ffestd_check_finish_ ();
2251 }
2252
2253 /* ffestd_R910_start -- WRITE(...) statement list begin
2254
2255    ffestd_R910_start();
2256
2257    Verify that WRITE is valid here, and begin accepting items in the
2258    list.  */
2259
2260 void
2261 ffestd_R910_start (ffestvUnit unit, ffestvFormat format, bool rec)
2262 {
2263   ffestdStmt_ stmt;
2264
2265   ffestd_check_start_ ();
2266
2267 #define specified(something) \
2268       (ffestp_file.write.write_spec[something].kw_or_val_present)
2269
2270   /* Warn if there are any thing we don't handle via f2c libraries. */
2271   if (specified (FFESTP_writeixADVANCE)
2272       || specified (FFESTP_writeixEOR))
2273     {
2274       ffebad_start (FFEBAD_WRITE_UNSUPPORTED);
2275       ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
2276                    ffelex_token_where_column (ffesta_tokens[0]));
2277       ffebad_finish ();
2278     }
2279
2280 #undef specified
2281
2282   stmt = ffestd_stmt_new_ (FFESTD_stmtidR910_);
2283   ffestd_stmt_append_ (stmt);
2284   ffestd_subr_line_save_ (stmt);
2285   stmt->u.R910.pool = ffesta_output_pool;
2286   stmt->u.R910.params = ffestd_subr_copy_write_ ();
2287   stmt->u.R910.unit = unit;
2288   stmt->u.R910.format = format;
2289   stmt->u.R910.rec = rec;
2290   stmt->u.R910.list = NULL;
2291   ffestd_expr_list_ = &stmt->u.R910.list;
2292   ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
2293 }
2294
2295 /* ffestd_R910_item -- WRITE statement i/o item
2296
2297    ffestd_R910_item(expr,expr_token);
2298
2299    Implement output-list expression.  */
2300
2301 void
2302 ffestd_R910_item (ffebld expr, ffelexToken expr_token)
2303 {
2304   ffestdExprItem_ item;
2305
2306   ffestd_check_item_ ();
2307
2308   item = malloc_new_kp (ffesta_output_pool, "ffestdExprItem_", sizeof (*item));
2309
2310   item->next = NULL;
2311   item->expr = expr;
2312   item->token = ffelex_token_use (expr_token);
2313   *ffestd_expr_list_ = item;
2314   ffestd_expr_list_ = &item->next;
2315 }
2316
2317 /* ffestd_R910_finish -- WRITE statement list complete
2318
2319    ffestd_R910_finish();
2320
2321    Just wrap up any local activities.  */
2322
2323 void
2324 ffestd_R910_finish (void)
2325 {
2326   ffestd_check_finish_ ();
2327 }
2328
2329 /* ffestd_R911_start -- PRINT statement list begin
2330
2331    ffestd_R911_start();
2332
2333    Verify that PRINT is valid here, and begin accepting items in the
2334    list.  */
2335
2336 void
2337 ffestd_R911_start (ffestvFormat format)
2338 {
2339   ffestdStmt_ stmt;
2340
2341   ffestd_check_start_ ();
2342
2343   stmt = ffestd_stmt_new_ (FFESTD_stmtidR911_);
2344   ffestd_stmt_append_ (stmt);
2345   ffestd_subr_line_save_ (stmt);
2346   stmt->u.R911.pool = ffesta_output_pool;
2347   stmt->u.R911.params = ffestd_subr_copy_print_ ();
2348   stmt->u.R911.format = format;
2349   stmt->u.R911.list = NULL;
2350   ffestd_expr_list_ = &stmt->u.R911.list;
2351   ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
2352 }
2353
2354 /* ffestd_R911_item -- PRINT statement i/o item
2355
2356    ffestd_R911_item(expr,expr_token);
2357
2358    Implement output-list expression.  */
2359
2360 void
2361 ffestd_R911_item (ffebld expr, ffelexToken expr_token)
2362 {
2363   ffestdExprItem_ item;
2364
2365   ffestd_check_item_ ();
2366
2367   item = malloc_new_kp (ffesta_output_pool, "ffestdExprItem_", sizeof (*item));
2368
2369   item->next = NULL;
2370   item->expr = expr;
2371   item->token = ffelex_token_use (expr_token);
2372   *ffestd_expr_list_ = item;
2373   ffestd_expr_list_ = &item->next;
2374 }
2375
2376 /* ffestd_R911_finish -- PRINT statement list complete
2377
2378    ffestd_R911_finish();
2379
2380    Just wrap up any local activities.  */
2381
2382 void
2383 ffestd_R911_finish (void)
2384 {
2385   ffestd_check_finish_ ();
2386 }
2387
2388 /* ffestd_R919 -- BACKSPACE statement
2389
2390    ffestd_R919();
2391
2392    Make sure a BACKSPACE is valid in the current context, and implement it.  */
2393
2394 void
2395 ffestd_R919 (void)
2396 {
2397   ffestdStmt_ stmt;
2398
2399   ffestd_check_simple_ ();
2400
2401   stmt = ffestd_stmt_new_ (FFESTD_stmtidR919_);
2402   ffestd_stmt_append_ (stmt);
2403   ffestd_subr_line_save_ (stmt);
2404   stmt->u.R919.pool = ffesta_output_pool;
2405   stmt->u.R919.params = ffestd_subr_copy_beru_ ();
2406   ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
2407 }
2408
2409 /* ffestd_R920 -- ENDFILE statement
2410
2411    ffestd_R920();
2412
2413    Make sure a ENDFILE is valid in the current context, and implement it.  */
2414
2415 void
2416 ffestd_R920 (void)
2417 {
2418   ffestdStmt_ stmt;
2419
2420   ffestd_check_simple_ ();
2421
2422   stmt = ffestd_stmt_new_ (FFESTD_stmtidR920_);
2423   ffestd_stmt_append_ (stmt);
2424   ffestd_subr_line_save_ (stmt);
2425   stmt->u.R920.pool = ffesta_output_pool;
2426   stmt->u.R920.params = ffestd_subr_copy_beru_ ();
2427   ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
2428 }
2429
2430 /* ffestd_R921 -- REWIND statement
2431
2432    ffestd_R921();
2433
2434    Make sure a REWIND is valid in the current context, and implement it.  */
2435
2436 void
2437 ffestd_R921 (void)
2438 {
2439   ffestdStmt_ stmt;
2440
2441   ffestd_check_simple_ ();
2442
2443   stmt = ffestd_stmt_new_ (FFESTD_stmtidR921_);
2444   ffestd_stmt_append_ (stmt);
2445   ffestd_subr_line_save_ (stmt);
2446   stmt->u.R921.pool = ffesta_output_pool;
2447   stmt->u.R921.params = ffestd_subr_copy_beru_ ();
2448   ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
2449 }
2450
2451 /* ffestd_R923A -- INQUIRE statement (non-IOLENGTH version)
2452
2453    ffestd_R923A(bool by_file);
2454
2455    Make sure an INQUIRE is valid in the current context, and implement it.  */
2456
2457 void
2458 ffestd_R923A (bool by_file)
2459 {
2460   ffestdStmt_ stmt;
2461
2462   ffestd_check_simple_ ();
2463
2464 #define specified(something) \
2465       (ffestp_file.inquire.inquire_spec[something].kw_or_val_present)
2466
2467   /* Warn if there are any thing we don't handle via f2c libraries. */
2468   if (specified (FFESTP_inquireixACTION)
2469       || specified (FFESTP_inquireixCARRIAGECONTROL)
2470       || specified (FFESTP_inquireixDEFAULTFILE)
2471       || specified (FFESTP_inquireixDELIM)
2472       || specified (FFESTP_inquireixKEYED)
2473       || specified (FFESTP_inquireixORGANIZATION)
2474       || specified (FFESTP_inquireixPAD)
2475       || specified (FFESTP_inquireixPOSITION)
2476       || specified (FFESTP_inquireixREAD)
2477       || specified (FFESTP_inquireixREADWRITE)
2478       || specified (FFESTP_inquireixRECORDTYPE)
2479       || specified (FFESTP_inquireixWRITE))
2480     {
2481       ffebad_start (FFEBAD_INQUIRE_UNSUPPORTED);
2482       ffebad_here (0, ffelex_token_where_line (ffesta_tokens[0]),
2483                    ffelex_token_where_column (ffesta_tokens[0]));
2484       ffebad_finish ();
2485     }
2486
2487 #undef specified
2488
2489   stmt = ffestd_stmt_new_ (FFESTD_stmtidR923A_);
2490   ffestd_stmt_append_ (stmt);
2491   ffestd_subr_line_save_ (stmt);
2492   stmt->u.R923A.pool = ffesta_output_pool;
2493   stmt->u.R923A.params = ffestd_subr_copy_inquire_ ();
2494   stmt->u.R923A.by_file = by_file;
2495   ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
2496 }
2497
2498 /* ffestd_R923B_start -- INQUIRE(IOLENGTH=expr) statement list begin
2499
2500    ffestd_R923B_start();
2501
2502    Verify that INQUIRE is valid here, and begin accepting items in the
2503    list.  */
2504
2505 void
2506 ffestd_R923B_start (void)
2507 {
2508   ffestdStmt_ stmt;
2509
2510   ffestd_check_start_ ();
2511
2512   stmt = ffestd_stmt_new_ (FFESTD_stmtidR923B_);
2513   ffestd_stmt_append_ (stmt);
2514   ffestd_subr_line_save_ (stmt);
2515   stmt->u.R923B.pool = ffesta_output_pool;
2516   stmt->u.R923B.params = ffestd_subr_copy_inquire_ ();
2517   stmt->u.R923B.list = NULL;
2518   ffestd_expr_list_ = &stmt->u.R923B.list;
2519   ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
2520 }
2521
2522 /* ffestd_R923B_item -- INQUIRE statement i/o item
2523
2524    ffestd_R923B_item(expr,expr_token);
2525
2526    Implement output-list expression.  */
2527
2528 void
2529 ffestd_R923B_item (ffebld expr)
2530 {
2531   ffestdExprItem_ item;
2532
2533   ffestd_check_item_ ();
2534
2535   item = malloc_new_kp (ffesta_output_pool, "ffestdExprItem_", sizeof (*item));
2536
2537   item->next = NULL;
2538   item->expr = expr;
2539   *ffestd_expr_list_ = item;
2540   ffestd_expr_list_ = &item->next;
2541 }
2542
2543 /* ffestd_R923B_finish -- INQUIRE statement list complete
2544
2545    ffestd_R923B_finish();
2546
2547    Just wrap up any local activities.  */
2548
2549 void
2550 ffestd_R923B_finish (void)
2551 {
2552   ffestd_check_finish_ ();
2553 }
2554
2555 /* ffestd_R1001 -- FORMAT statement
2556
2557    ffestd_R1001(format_list);  */
2558
2559 void
2560 ffestd_R1001 (ffesttFormatList f)
2561 {
2562   ffestsHolder str;
2563   ffests s = &str;
2564   ffestdStmt_ stmt;
2565
2566   ffestd_check_simple_ ();
2567
2568   if (ffestd_label_formatdef_ == NULL)
2569     return;                     /* Nothing to hook it up to (no label def). */
2570
2571   ffests_new (s, malloc_pool_image (), 80);
2572   ffests_putc (s, '(');
2573   ffestd_R1001dump_ (s, f);     /* Build the string in s. */
2574   ffests_putc (s, ')');
2575
2576   stmt = ffestd_stmt_new_ (FFESTD_stmtidR1001_);
2577   ffestd_stmt_append_ (stmt);
2578   stmt->u.R1001.str = str;
2579
2580   ffestd_label_formatdef_ = NULL;
2581 }
2582
2583 /* ffestd_R1001dump_ -- Dump list of formats
2584
2585    ffesttFormatList list;
2586    ffestd_R1001dump_(list,0);
2587
2588    The formats in the list are dumped.  */
2589
2590 static void
2591 ffestd_R1001dump_ (ffests s, ffesttFormatList list)
2592 {
2593   ffesttFormatList next;
2594
2595   for (next = list->next; next != list; next = next->next)
2596     {
2597       if (next != list->next)
2598         ffests_putc (s, ',');
2599       switch (next->type)
2600         {
2601         case FFESTP_formattypeI:
2602           ffestd_R1001dump_1005_3_ (s, next, "I");
2603           break;
2604
2605         case FFESTP_formattypeB:
2606           ffestd_R1001error_ (next);
2607           break;
2608
2609         case FFESTP_formattypeO:
2610           ffestd_R1001dump_1005_3_ (s, next, "O");
2611           break;
2612
2613         case FFESTP_formattypeZ:
2614           ffestd_R1001dump_1005_3_ (s, next, "Z");
2615           break;
2616
2617         case FFESTP_formattypeF:
2618           ffestd_R1001dump_1005_4_ (s, next, "F");
2619           break;
2620
2621         case FFESTP_formattypeE:
2622           ffestd_R1001dump_1005_5_ (s, next, "E");
2623           break;
2624
2625         case FFESTP_formattypeEN:
2626           ffestd_R1001error_ (next);
2627           break;
2628
2629         case FFESTP_formattypeG:
2630           ffestd_R1001dump_1005_5_ (s, next, "G");
2631           break;
2632
2633         case FFESTP_formattypeL:
2634           ffestd_R1001dump_1005_2_ (s, next, "L");
2635           break;
2636
2637         case FFESTP_formattypeA:
2638           ffestd_R1001dump_1005_1_ (s, next, "A");
2639           break;
2640
2641         case FFESTP_formattypeD:
2642           ffestd_R1001dump_1005_4_ (s, next, "D");
2643           break;
2644
2645         case FFESTP_formattypeQ:
2646           ffestd_R1001error_ (next);
2647           break;
2648
2649         case FFESTP_formattypeDOLLAR:
2650           ffestd_R1001dump_1010_1_ (s, next, "$");
2651           break;
2652
2653         case FFESTP_formattypeP:
2654           ffestd_R1001dump_1010_4_ (s, next, "P");
2655           break;
2656
2657         case FFESTP_formattypeT:
2658           ffestd_R1001dump_1010_5_ (s, next, "T");
2659           break;
2660
2661         case FFESTP_formattypeTL:
2662           ffestd_R1001dump_1010_5_ (s, next, "TL");
2663           break;
2664
2665         case FFESTP_formattypeTR:
2666           ffestd_R1001dump_1010_5_ (s, next, "TR");
2667           break;
2668
2669         case FFESTP_formattypeX:
2670           ffestd_R1001dump_1010_2_ (s, next, "X");
2671           break;
2672
2673         case FFESTP_formattypeS:
2674           ffestd_R1001dump_1010_1_ (s, next, "S");
2675           break;
2676
2677         case FFESTP_formattypeSP:
2678           ffestd_R1001dump_1010_1_ (s, next, "SP");
2679           break;
2680
2681         case FFESTP_formattypeSS:
2682           ffestd_R1001dump_1010_1_ (s, next, "SS");
2683           break;
2684
2685         case FFESTP_formattypeBN:
2686           ffestd_R1001dump_1010_1_ (s, next, "BN");
2687           break;
2688
2689         case FFESTP_formattypeBZ:
2690           ffestd_R1001dump_1010_1_ (s, next, "BZ");
2691           break;
2692
2693         case FFESTP_formattypeSLASH:
2694           ffestd_R1001dump_1010_2_ (s, next, "/");
2695           break;
2696
2697         case FFESTP_formattypeCOLON:
2698           ffestd_R1001dump_1010_1_ (s, next, ":");
2699           break;
2700
2701         case FFESTP_formattypeR1016:
2702           switch (ffelex_token_type (next->t))
2703             {
2704             case FFELEX_typeCHARACTER:
2705               {
2706                 char *p = ffelex_token_text (next->t);
2707                 ffeTokenLength i = ffelex_token_length (next->t);
2708
2709                 ffests_putc (s, '\002');
2710                 while (i-- != 0)
2711                   {
2712                     if (*p == '\002')
2713                       ffests_putc (s, '\002');
2714                     ffests_putc (s, *p);
2715                     ++p;
2716                   }
2717                 ffests_putc (s, '\002');
2718               }
2719               break;
2720
2721             case FFELEX_typeHOLLERITH:
2722               {
2723                 char *p = ffelex_token_text (next->t);
2724                 ffeTokenLength i = ffelex_token_length (next->t);
2725
2726                 ffests_printf (s, "%" ffeTokenLength_f "uH", i);
2727                 while (i-- != 0)
2728                   {
2729                     ffests_putc (s, *p);
2730                     ++p;
2731                   }
2732               }
2733               break;
2734
2735             default:
2736               assert (FALSE);
2737             }
2738           break;
2739
2740         case FFESTP_formattypeFORMAT:
2741           if (next->u.R1003D.R1004.present)
2742             {
2743               if (next->u.R1003D.R1004.rtexpr)
2744                 ffestd_R1001rtexpr_ (s, next, next->u.R1003D.R1004.u.expr);
2745               else
2746                 ffests_printf (s, "%lu", next->u.R1003D.R1004.u.unsigned_val);
2747             }
2748
2749           ffests_putc (s, '(');
2750           ffestd_R1001dump_ (s, next->u.R1003D.format);
2751           ffests_putc (s, ')');
2752           break;
2753
2754         default:
2755           assert (FALSE);
2756         }
2757     }
2758 }
2759
2760 /* ffestd_R1001dump_1005_1_ -- Dump a particular format
2761
2762    ffesttFormatList f;
2763    ffestd_R1001dump_1005_1_(f,"I");
2764
2765    The format is dumped with form [r]X[w].  */
2766
2767 static void
2768 ffestd_R1001dump_1005_1_ (ffests s, ffesttFormatList f, const char *string)
2769 {
2770   assert (!f->u.R1005.R1007_or_R1008.present);
2771   assert (!f->u.R1005.R1009.present);
2772
2773   if (f->u.R1005.R1004.present)
2774     {
2775       if (f->u.R1005.R1004.rtexpr)
2776         ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1004.u.expr);
2777       else
2778         ffests_printf (s, "%lu", f->u.R1005.R1004.u.unsigned_val);
2779     }
2780
2781   ffests_puts (s, string);
2782
2783   if (f->u.R1005.R1006.present)
2784     {
2785       if (f->u.R1005.R1006.rtexpr)
2786         ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1006.u.expr);
2787       else
2788         ffests_printf (s, "%lu", f->u.R1005.R1006.u.unsigned_val);
2789     }
2790 }
2791
2792 /* ffestd_R1001dump_1005_2_ -- Dump a particular format
2793
2794    ffesttFormatList f;
2795    ffestd_R1001dump_1005_2_(f,"I");
2796
2797    The format is dumped with form [r]Xw.  */
2798
2799 static void
2800 ffestd_R1001dump_1005_2_ (ffests s, ffesttFormatList f, const char *string)
2801 {
2802   assert (!f->u.R1005.R1007_or_R1008.present);
2803   assert (!f->u.R1005.R1009.present);
2804   assert (f->u.R1005.R1006.present);
2805
2806   if (f->u.R1005.R1004.present)
2807     {
2808       if (f->u.R1005.R1004.rtexpr)
2809         ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1004.u.expr);
2810       else
2811         ffests_printf (s, "%lu", f->u.R1005.R1004.u.unsigned_val);
2812     }
2813
2814   ffests_puts (s, string);
2815
2816   if (f->u.R1005.R1006.rtexpr)
2817     ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1006.u.expr);
2818   else
2819     ffests_printf (s, "%lu", f->u.R1005.R1006.u.unsigned_val);
2820 }
2821
2822 /* ffestd_R1001dump_1005_3_ -- Dump a particular format
2823
2824    ffesttFormatList f;
2825    ffestd_R1001dump_1005_3_(f,"I");
2826
2827    The format is dumped with form [r]Xw[.m].  */
2828
2829 static void
2830 ffestd_R1001dump_1005_3_ (ffests s, ffesttFormatList f, const char *string)
2831 {
2832   assert (!f->u.R1005.R1009.present);
2833   assert (f->u.R1005.R1006.present);
2834
2835   if (f->u.R1005.R1004.present)
2836     {
2837       if (f->u.R1005.R1004.rtexpr)
2838         ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1004.u.expr);
2839       else
2840         ffests_printf (s, "%lu", f->u.R1005.R1004.u.unsigned_val);
2841     }
2842
2843   ffests_puts (s, string);
2844
2845   if (f->u.R1005.R1006.rtexpr)
2846     ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1006.u.expr);
2847   else
2848     ffests_printf (s, "%lu", f->u.R1005.R1006.u.unsigned_val);
2849
2850   if (f->u.R1005.R1007_or_R1008.present)
2851     {
2852       ffests_putc (s, '.');
2853       if (f->u.R1005.R1007_or_R1008.rtexpr)
2854         ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1007_or_R1008.u.expr);
2855       else
2856         ffests_printf (s, "%lu", f->u.R1005.R1007_or_R1008.u.unsigned_val);
2857     }
2858 }
2859
2860 /* ffestd_R1001dump_1005_4_ -- Dump a particular format
2861
2862    ffesttFormatList f;
2863    ffestd_R1001dump_1005_4_(f,"I");
2864
2865    The format is dumped with form [r]Xw.d.  */
2866
2867 static void
2868 ffestd_R1001dump_1005_4_ (ffests s, ffesttFormatList f, const char *string)
2869 {
2870   assert (!f->u.R1005.R1009.present);
2871   assert (f->u.R1005.R1007_or_R1008.present);
2872   assert (f->u.R1005.R1006.present);
2873
2874   if (f->u.R1005.R1004.present)
2875     {
2876       if (f->u.R1005.R1004.rtexpr)
2877         ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1004.u.expr);
2878       else
2879         ffests_printf (s, "%lu", f->u.R1005.R1004.u.unsigned_val);
2880     }
2881
2882   ffests_puts (s, string);
2883
2884   if (f->u.R1005.R1006.rtexpr)
2885     ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1006.u.expr);
2886   else
2887     ffests_printf (s, "%lu", f->u.R1005.R1006.u.unsigned_val);
2888
2889   ffests_putc (s, '.');
2890   if (f->u.R1005.R1007_or_R1008.rtexpr)
2891     ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1007_or_R1008.u.expr);
2892   else
2893     ffests_printf (s, "%lu", f->u.R1005.R1007_or_R1008.u.unsigned_val);
2894 }
2895
2896 /* ffestd_R1001dump_1005_5_ -- Dump a particular format
2897
2898    ffesttFormatList f;
2899    ffestd_R1001dump_1005_5_(f,"I");
2900
2901    The format is dumped with form [r]Xw.d[Ee].  */
2902
2903 static void
2904 ffestd_R1001dump_1005_5_ (ffests s, ffesttFormatList f, const char *string)
2905 {
2906   assert (f->u.R1005.R1007_or_R1008.present);
2907   assert (f->u.R1005.R1006.present);
2908
2909   if (f->u.R1005.R1004.present)
2910     {
2911       if (f->u.R1005.R1004.rtexpr)
2912         ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1004.u.expr);
2913       else
2914         ffests_printf (s, "%lu", f->u.R1005.R1004.u.unsigned_val);
2915     }
2916
2917   ffests_puts (s, string);
2918
2919   if (f->u.R1005.R1006.rtexpr)
2920     ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1006.u.expr);
2921   else
2922     ffests_printf (s, "%lu", f->u.R1005.R1006.u.unsigned_val);
2923
2924   ffests_putc (s, '.');
2925   if (f->u.R1005.R1007_or_R1008.rtexpr)
2926     ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1007_or_R1008.u.expr);
2927   else
2928     ffests_printf (s, "%lu", f->u.R1005.R1007_or_R1008.u.unsigned_val);
2929
2930   if (f->u.R1005.R1009.present)
2931     {
2932       ffests_putc (s, 'E');
2933       if (f->u.R1005.R1009.rtexpr)
2934         ffestd_R1001rtexpr_ (s, f, f->u.R1005.R1009.u.expr);
2935       else
2936         ffests_printf (s, "%lu", f->u.R1005.R1009.u.unsigned_val);
2937     }
2938 }
2939
2940 /* ffestd_R1001dump_1010_1_ -- Dump a particular format
2941
2942    ffesttFormatList f;
2943    ffestd_R1001dump_1010_1_(f,"I");
2944
2945    The format is dumped with form X.  */
2946
2947 static void
2948 ffestd_R1001dump_1010_1_ (ffests s, ffesttFormatList f, const char *string)
2949 {
2950   assert (!f->u.R1010.val.present);
2951
2952   ffests_puts (s, string);
2953 }
2954
2955 /* ffestd_R1001dump_1010_2_ -- Dump a particular format
2956
2957    ffesttFormatList f;
2958    ffestd_R1001dump_1010_2_(f,"I");
2959
2960    The format is dumped with form [r]X.  */
2961
2962 static void
2963 ffestd_R1001dump_1010_2_ (ffests s, ffesttFormatList f, const char *string)
2964 {
2965   if (f->u.R1010.val.present)
2966     {
2967       if (f->u.R1010.val.rtexpr)
2968         ffestd_R1001rtexpr_ (s, f, f->u.R1010.val.u.expr);
2969       else
2970         ffests_printf (s, "%lu", f->u.R1010.val.u.unsigned_val);
2971     }
2972
2973   ffests_puts (s, string);
2974 }
2975
2976 /* ffestd_R1001dump_1010_4_ -- Dump a particular format
2977
2978    ffesttFormatList f;
2979    ffestd_R1001dump_1010_4_(f,"I");
2980
2981    The format is dumped with form kX.  Note that k is signed.  */
2982
2983 static void
2984 ffestd_R1001dump_1010_4_ (ffests s, ffesttFormatList f, const char *string)
2985 {
2986   assert (f->u.R1010.val.present);
2987
2988   if (f->u.R1010.val.rtexpr)
2989     ffestd_R1001rtexpr_ (s, f, f->u.R1010.val.u.expr);
2990   else
2991     ffests_printf (s, "%ld", f->u.R1010.val.u.signed_val);
2992
2993   ffests_puts (s, string);
2994 }
2995
2996 /* ffestd_R1001dump_1010_5_ -- Dump a particular format
2997
2998    ffesttFormatList f;
2999    ffestd_R1001dump_1010_5_(f,"I");
3000
3001    The format is dumped with form Xn.  */
3002
3003 static void
3004 ffestd_R1001dump_1010_5_ (ffests s, ffesttFormatList f, const char *string)
3005 {
3006   assert (f->u.R1010.val.present);
3007
3008   ffests_puts (s, string);
3009
3010   if (f->u.R1010.val.rtexpr)
3011     ffestd_R1001rtexpr_ (s, f, f->u.R1010.val.u.expr);
3012   else
3013     ffests_printf (s, "%lu", f->u.R1010.val.u.unsigned_val);
3014 }
3015
3016 /* ffestd_R1001error_ -- Complain about FORMAT specification not supported
3017
3018    ffesttFormatList f;
3019    ffestd_R1001error_(f);
3020
3021    An error message is produced.  */
3022
3023 static void
3024 ffestd_R1001error_ (ffesttFormatList f)
3025 {
3026   ffebad_start (FFEBAD_FORMAT_UNSUPPORTED);
3027   ffebad_here (0, ffelex_token_where_line (f->t), ffelex_token_where_column (f->t));
3028   ffebad_finish ();
3029 }
3030
3031 static void
3032 ffestd_R1001rtexpr_ (ffests s, ffesttFormatList f, ffebld expr)
3033 {
3034   if ((expr == NULL)
3035       || (ffebld_op (expr) != FFEBLD_opCONTER)
3036       || (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeINTEGER)
3037       || (ffeinfo_kindtype (ffebld_info (expr)) == FFEINFO_kindtypeINTEGER4))
3038     {
3039       ffebad_start (FFEBAD_FORMAT_VARIABLE);
3040       ffebad_here (0, ffelex_token_where_line (f->t), ffelex_token_where_column (f->t));
3041       ffebad_finish ();
3042     }
3043   else
3044     {
3045       int val;
3046
3047       switch (ffeinfo_kindtype (ffebld_info (expr)))
3048         {
3049 #if FFETARGET_okINTEGER1
3050         case FFEINFO_kindtypeINTEGER1:
3051           val = ffebld_constant_integer1 (ffebld_conter (expr));
3052           break;
3053 #endif
3054
3055 #if FFETARGET_okINTEGER2
3056         case FFEINFO_kindtypeINTEGER2:
3057           val = ffebld_constant_integer2 (ffebld_conter (expr));
3058           break;
3059 #endif
3060
3061 #if FFETARGET_okINTEGER3
3062         case FFEINFO_kindtypeINTEGER3:
3063           val = ffebld_constant_integer3 (ffebld_conter (expr));
3064           break;
3065 #endif
3066
3067         default:
3068           assert ("bad INTEGER constant kind type" == NULL);
3069           /* Fall through. */
3070         case FFEINFO_kindtypeANY:
3071           return;
3072         }
3073       ffests_printf (s, "%ld", (long) val);
3074     }
3075 }
3076
3077 /* ffestd_R1102 -- PROGRAM statement
3078
3079    ffestd_R1102(name_token);
3080
3081    Make sure ffestd_kind_ identifies an empty block.  Make sure name_token
3082    gives a valid name.  Implement the beginning of a main program.  */
3083
3084 void
3085 ffestd_R1102 (ffesymbol s, ffelexToken name UNUSED)
3086 {
3087   ffestd_check_simple_ ();
3088
3089   assert (ffestd_block_level_ == 0);
3090   ffestd_is_reachable_ = TRUE;
3091
3092   ffecom_notify_primary_entry (s);
3093   ffe_set_is_mainprog (TRUE);   /* Is a main program. */
3094   ffe_set_is_saveall (TRUE);    /* Main program always has implicit SAVE. */
3095
3096   ffestw_set_sym (ffestw_stack_top (), s);
3097 }
3098
3099 /* ffestd_R1103 -- End a PROGRAM
3100
3101    ffestd_R1103();  */
3102
3103 void
3104 ffestd_R1103 (bool ok UNUSED)
3105 {
3106   ffestdStmt_ stmt;
3107
3108   assert (ffestd_block_level_ == 0);
3109
3110   if (FFESTD_IS_END_OPTIMIZED_ && ffestd_is_reachable_)
3111     ffestd_R842 (NULL);         /* Generate STOP. */
3112
3113   if (ffestw_state (ffestw_stack_top ()) != FFESTV_statePROGRAM5)
3114     ffestd_subr_labels_ (FALSE);/* Handle any undefined labels. */
3115
3116   stmt = ffestd_stmt_new_ (FFESTD_stmtidR1103_);
3117   ffestd_stmt_append_ (stmt);
3118 }
3119
3120 /* ffestd_R1111 -- BLOCK DATA statement
3121
3122    ffestd_R1111(name_token);
3123
3124    Make sure ffestd_kind_ identifies no current program unit.  If not
3125    NULL, make sure name_token gives a valid name.  Implement the beginning
3126    of a block data program unit.  */
3127
3128 void
3129 ffestd_R1111 (ffesymbol s, ffelexToken name UNUSED)
3130 {
3131   assert (ffestd_block_level_ == 0);
3132   ffestd_is_reachable_ = TRUE;
3133
3134   ffestd_check_simple_ ();
3135
3136   ffecom_notify_primary_entry (s);
3137   ffestw_set_sym (ffestw_stack_top (), s);
3138 }
3139
3140 /* ffestd_R1112 -- End a BLOCK DATA
3141
3142    ffestd_R1112(TRUE);  */
3143
3144 void
3145 ffestd_R1112 (bool ok UNUSED)
3146 {
3147   ffestdStmt_ stmt;
3148
3149   assert (ffestd_block_level_ == 0);
3150
3151   /* Generate any return-like code here (not likely for BLOCK DATA!). */
3152
3153   if (ffestw_state (ffestw_stack_top ()) != FFESTV_stateBLOCKDATA5)
3154     ffestd_subr_labels_ (TRUE); /* Handle any undefined labels. */
3155
3156   stmt = ffestd_stmt_new_ (FFESTD_stmtidR1112_);
3157   ffestd_stmt_append_ (stmt);
3158 }
3159
3160 /* ffestd_R1207_start -- EXTERNAL statement list begin
3161
3162    ffestd_R1207_start();
3163
3164    Verify that EXTERNAL is valid here, and begin accepting items in the list.  */
3165
3166 void
3167 ffestd_R1207_start (void)
3168 {
3169   ffestd_check_start_ ();
3170 }
3171
3172 /* ffestd_R1207_item -- EXTERNAL statement for name
3173
3174    ffestd_R1207_item(name_token);
3175
3176    Make sure name_token identifies a valid object to be EXTERNALd.  */
3177
3178 void
3179 ffestd_R1207_item (ffelexToken name)
3180 {
3181   ffestd_check_item_ ();
3182   assert (name != NULL);
3183 }
3184
3185 /* ffestd_R1207_finish -- EXTERNAL statement list complete
3186
3187    ffestd_R1207_finish();
3188
3189    Just wrap up any local activities.  */
3190
3191 void
3192 ffestd_R1207_finish (void)
3193 {
3194   ffestd_check_finish_ ();
3195 }
3196
3197 /* ffestd_R1208_start -- INTRINSIC statement list begin
3198
3199    ffestd_R1208_start();
3200
3201    Verify that INTRINSIC is valid here, and begin accepting items in the list.  */
3202
3203 void
3204 ffestd_R1208_start (void)
3205 {
3206   ffestd_check_start_ ();
3207 }
3208
3209 /* ffestd_R1208_item -- INTRINSIC statement for name
3210
3211    ffestd_R1208_item(name_token);
3212
3213    Make sure name_token identifies a valid object to be INTRINSICd.  */
3214
3215 void
3216 ffestd_R1208_item (ffelexToken name)
3217 {
3218   ffestd_check_item_ ();
3219   assert (name != NULL);
3220 }
3221
3222 /* ffestd_R1208_finish -- INTRINSIC statement list complete
3223
3224    ffestd_R1208_finish();
3225
3226    Just wrap up any local activities.  */
3227
3228 void
3229 ffestd_R1208_finish (void)
3230 {
3231   ffestd_check_finish_ ();
3232 }
3233
3234 /* ffestd_R1212 -- CALL statement
3235
3236    ffestd_R1212(expr,expr_token);
3237
3238    Make sure statement is valid here; implement.  */
3239
3240 void
3241 ffestd_R1212 (ffebld expr)
3242 {
3243   ffestdStmt_ stmt;
3244
3245   ffestd_check_simple_ ();
3246
3247   stmt = ffestd_stmt_new_ (FFESTD_stmtidR1212_);
3248   ffestd_stmt_append_ (stmt);
3249   ffestd_subr_line_save_ (stmt);
3250   stmt->u.R1212.pool = ffesta_output_pool;
3251   stmt->u.R1212.expr = expr;
3252   ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
3253 }
3254
3255 /* ffestd_R1219 -- FUNCTION statement
3256
3257    ffestd_R1219(funcname,arglist,ending_token,kind,kindt,len,lent,
3258          recursive);
3259
3260    Make sure statement is valid here, register arguments for the
3261    function name, and so on.
3262
3263    06-Jun-90  JCB  2.0
3264       Added the kind, len, and recursive arguments.  */
3265
3266 void
3267 ffestd_R1219 (ffesymbol s, ffelexToken funcname UNUSED,
3268               ffesttTokenList args UNUSED, ffestpType type UNUSED,
3269               ffebld kind UNUSED, ffelexToken kindt UNUSED,
3270               ffebld len UNUSED, ffelexToken lent UNUSED,
3271               bool recursive UNUSED, ffelexToken result UNUSED,
3272               bool separate_result UNUSED)
3273 {
3274   assert (ffestd_block_level_ == 0);
3275   ffestd_is_reachable_ = TRUE;
3276
3277   ffestd_check_simple_ ();
3278
3279   ffecom_notify_primary_entry (s);
3280   ffestw_set_sym (ffestw_stack_top (), s);
3281 }
3282
3283 /* ffestd_R1221 -- End a FUNCTION
3284
3285    ffestd_R1221(TRUE);  */
3286
3287 void
3288 ffestd_R1221 (bool ok UNUSED)
3289 {
3290   ffestdStmt_ stmt;
3291
3292   assert (ffestd_block_level_ == 0);
3293
3294   if (FFESTD_IS_END_OPTIMIZED_ && ffestd_is_reachable_)
3295     ffestd_R1227 (NULL);        /* Generate RETURN. */
3296
3297   if (ffestw_state (ffestw_stack_top ()) != FFESTV_stateFUNCTION5)
3298     ffestd_subr_labels_ (FALSE);/* Handle any undefined labels. */
3299
3300   stmt = ffestd_stmt_new_ (FFESTD_stmtidR1221_);
3301   ffestd_stmt_append_ (stmt);
3302 }
3303
3304 /* ffestd_R1223 -- SUBROUTINE statement
3305
3306    ffestd_R1223(subrname,arglist,ending_token,recursive_token);
3307
3308    Make sure statement is valid here, register arguments for the
3309    subroutine name, and so on.
3310
3311    06-Jun-90  JCB  2.0
3312       Added the recursive argument.  */
3313
3314 void
3315 ffestd_R1223 (ffesymbol s, ffelexToken subrname UNUSED,
3316               ffesttTokenList args UNUSED, ffelexToken final UNUSED,
3317               bool recursive UNUSED)
3318 {
3319   assert (ffestd_block_level_ == 0);
3320   ffestd_is_reachable_ = TRUE;
3321
3322   ffestd_check_simple_ ();
3323
3324   ffecom_notify_primary_entry (s);
3325   ffestw_set_sym (ffestw_stack_top (), s);
3326 }
3327
3328 /* ffestd_R1225 -- End a SUBROUTINE
3329
3330    ffestd_R1225(TRUE);  */
3331
3332 void
3333 ffestd_R1225 (bool ok UNUSED)
3334 {
3335   ffestdStmt_ stmt;
3336
3337   assert (ffestd_block_level_ == 0);
3338
3339   if (FFESTD_IS_END_OPTIMIZED_ && ffestd_is_reachable_)
3340     ffestd_R1227 (NULL);        /* Generate RETURN. */
3341
3342   if (ffestw_state (ffestw_stack_top ()) != FFESTV_stateSUBROUTINE5)
3343     ffestd_subr_labels_ (FALSE);/* Handle any undefined labels. */
3344
3345   stmt = ffestd_stmt_new_ (FFESTD_stmtidR1225_);
3346   ffestd_stmt_append_ (stmt);
3347 }
3348
3349 /* ffestd_R1226 -- ENTRY statement
3350
3351    ffestd_R1226(entryname,arglist,ending_token);
3352
3353    Make sure we're in a SUBROUTINE or FUNCTION, register arguments for the
3354    entry point name, and so on.  */
3355
3356 void
3357 ffestd_R1226 (ffesymbol entry)
3358 {
3359   ffestd_check_simple_ ();
3360
3361   if (!ffesta_seen_first_exec || ffecom_2pass_advise_entrypoint (entry))
3362     {
3363       ffestdStmt_ stmt;
3364
3365       stmt = ffestd_stmt_new_ (FFESTD_stmtidR1226_);
3366       ffestd_stmt_append_ (stmt);
3367       ffestd_subr_line_save_ (stmt);
3368       stmt->u.R1226.entry = entry;
3369       stmt->u.R1226.entrynum = ++ffestd_2pass_entrypoints_;
3370     }
3371
3372   ffestd_is_reachable_ = TRUE;
3373 }
3374
3375 /* ffestd_R1227 -- RETURN statement
3376
3377    ffestd_R1227(expr);
3378
3379    Make sure statement is valid here; implement.  expr and expr_token are
3380    both NULL if there was no expression.  */
3381
3382 void
3383 ffestd_R1227 (ffebld expr)
3384 {
3385   ffestdStmt_ stmt;
3386
3387   ffestd_check_simple_ ();
3388
3389   stmt = ffestd_stmt_new_ (FFESTD_stmtidR1227_);
3390   ffestd_stmt_append_ (stmt);
3391   ffestd_subr_line_save_ (stmt);
3392   stmt->u.R1227.pool = ffesta_output_pool;
3393   stmt->u.R1227.block = ffestw_stack_top ();
3394   stmt->u.R1227.expr = expr;
3395   ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
3396
3397   if (ffestd_block_level_ == 0)
3398     ffestd_is_reachable_ = FALSE;
3399 }
3400
3401 /* ffestd_R1229_start -- STMTFUNCTION statement begin
3402
3403    ffestd_R1229_start(func_name,func_arg_list,close_paren);
3404
3405    This function does not really need to do anything, since _finish_
3406    gets all the info needed, and ffestc_R1229_start has already
3407    done all the stuff that makes a two-phase operation (start and
3408    finish) for handling statement functions necessary.
3409
3410    03-Jan-91  JCB  2.0
3411       Do nothing, now that _finish_ does everything.  */
3412
3413 void
3414 ffestd_R1229_start (ffelexToken name UNUSED, ffesttTokenList args UNUSED)
3415 {
3416   ffestd_check_start_ ();
3417 }
3418
3419 /* ffestd_R1229_finish -- STMTFUNCTION statement list complete
3420
3421    ffestd_R1229_finish(s);
3422
3423    The statement function's symbol is passed.  Its list of dummy args is
3424    accessed via ffesymbol_dummyargs and its expansion expression (expr)
3425    is accessed via ffesymbol_sfexpr.
3426
3427    If sfexpr is NULL, an error occurred parsing the expansion expression, so
3428    just cancel the effects of ffestd_R1229_start and pretend nothing
3429    happened.  Otherwise, install the expression as the expansion for the
3430    statement function, then clean up.
3431
3432    03-Jan-91  JCB  2.0
3433       Takes sfunc sym instead of just the expansion expression as an
3434       argument, so this function can do all the work, and _start_ is just
3435       a nicety than can do nothing in a back end.  */
3436
3437 void
3438 ffestd_R1229_finish (ffesymbol s)
3439 {
3440   ffebld expr = ffesymbol_sfexpr (s);
3441
3442   ffestd_check_finish_ ();
3443
3444   if (expr == NULL)
3445     return;                     /* Nothing to do, definition didn't work. */
3446
3447   /* With gcc, cannot do anything here, because the backend hasn't even
3448      (necessarily) been notified that we're compiling a program unit! */
3449   ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
3450 }
3451
3452 /* ffestd_S3P4 -- INCLUDE line
3453
3454    ffestd_S3P4(filename,filename_token);
3455
3456    Make sure INCLUDE not preceded by any semicolons or a label def; implement.  */
3457
3458 void
3459 ffestd_S3P4 (ffebld filename)
3460 {
3461   FILE *fi;
3462   ffetargetCharacterDefault buildname;
3463   ffewhereFile wf;
3464
3465   ffestd_check_simple_ ();
3466
3467   assert (filename != NULL);
3468   if (ffebld_op (filename) != FFEBLD_opANY)
3469     {
3470       assert (ffebld_op (filename) == FFEBLD_opCONTER);
3471       assert (ffeinfo_basictype (ffebld_info (filename))
3472               == FFEINFO_basictypeCHARACTER);
3473       assert (ffeinfo_kindtype (ffebld_info (filename))
3474               == FFEINFO_kindtypeCHARACTERDEFAULT);
3475       buildname = ffebld_constant_characterdefault (ffebld_conter (filename));
3476       wf = ffewhere_file_new (ffetarget_text_characterdefault (buildname),
3477                               ffetarget_length_characterdefault (buildname));
3478       fi = ffecom_open_include (ffewhere_file_name (wf),
3479                                 ffelex_token_where_line (ffesta_tokens[0]),
3480                                 ffelex_token_where_column (ffesta_tokens[0]));
3481       if (fi != NULL)
3482         ffelex_set_include (wf, (ffelex_token_type (ffesta_tokens[0])
3483                                  == FFELEX_typeNAME), fi);
3484     }
3485 }
3486
3487 /* ffestd_V014_start -- VOLATILE statement list begin
3488
3489    ffestd_V014_start();
3490
3491    Verify that VOLATILE is valid here, and begin accepting items in the list.  */
3492
3493 void
3494 ffestd_V014_start (void)
3495 {
3496   ffestd_check_start_ ();
3497 }
3498
3499 /* ffestd_V014_item_object -- VOLATILE statement for object-name
3500
3501    ffestd_V014_item_object(name_token);
3502
3503    Make sure name_token identifies a valid object to be VOLATILEd.  */
3504
3505 void
3506 ffestd_V014_item_object (ffelexToken name UNUSED)
3507 {
3508   ffestd_check_item_ ();
3509 }
3510
3511 /* ffestd_V014_item_cblock -- VOLATILE statement for common-block-name
3512
3513    ffestd_V014_item_cblock(name_token);
3514
3515    Make sure name_token identifies a valid common block to be VOLATILEd.  */
3516
3517 void
3518 ffestd_V014_item_cblock (ffelexToken name UNUSED)
3519 {
3520   ffestd_check_item_ ();
3521 }
3522
3523 /* ffestd_V014_finish -- VOLATILE statement list complete
3524
3525    ffestd_V014_finish();
3526
3527    Just wrap up any local activities.  */
3528
3529 void
3530 ffestd_V014_finish (void)
3531 {
3532   ffestd_check_finish_ ();
3533 }
3534
3535 /* ffestd_V020_start -- TYPE statement list begin
3536
3537    ffestd_V020_start();
3538
3539    Verify that TYPE is valid here, and begin accepting items in the
3540    list.  */
3541
3542 void
3543 ffestd_V020_start (ffestvFormat format UNUSED)
3544 {
3545   ffestd_check_start_ ();
3546   ffestd_subr_vxt_ ();
3547 }
3548
3549 /* ffestd_V020_item -- TYPE statement i/o item
3550
3551    ffestd_V020_item(expr,expr_token);
3552
3553    Implement output-list expression.  */
3554
3555 void
3556 ffestd_V020_item (ffebld expr UNUSED)
3557 {
3558   ffestd_check_item_ ();
3559 }
3560
3561 /* ffestd_V020_finish -- TYPE statement list complete
3562
3563    ffestd_V020_finish();
3564
3565    Just wrap up any local activities.  */
3566
3567 void
3568 ffestd_V020_finish (void)
3569 {
3570   ffestd_check_finish_ ();
3571 }
3572
3573 /* ffestd_V027_start -- VXT PARAMETER statement list begin
3574
3575    ffestd_V027_start();
3576
3577    Verify that PARAMETER is valid here, and begin accepting items in the list.  */
3578
3579 void
3580 ffestd_V027_start (void)
3581 {
3582   ffestd_check_start_ ();
3583   ffestd_subr_vxt_ ();
3584 }
3585
3586 /* ffestd_V027_item -- VXT PARAMETER statement assignment
3587
3588    ffestd_V027_item(dest,dest_token,source,source_token);
3589
3590    Make sure the source is a valid source for the destination; make the
3591    assignment.  */
3592
3593 void
3594 ffestd_V027_item (ffelexToken dest_token UNUSED, ffebld source UNUSED)
3595 {
3596   ffestd_check_item_ ();
3597 }
3598
3599 /* ffestd_V027_finish -- VXT PARAMETER statement list complete
3600
3601    ffestd_V027_finish();
3602
3603    Just wrap up any local activities.  */
3604
3605 void
3606 ffestd_V027_finish (void)
3607 {
3608   ffestd_check_finish_ ();
3609 }
3610
3611 /* Any executable statement.  */
3612
3613 void
3614 ffestd_any (void)
3615 {
3616   ffestdStmt_ stmt;
3617
3618   ffestd_check_simple_ ();
3619
3620   stmt = ffestd_stmt_new_ (FFESTD_stmtidR841_);
3621   ffestd_stmt_append_ (stmt);
3622   ffestd_subr_line_save_ (stmt);
3623 }