contrib/gcc-3.4/gcc/f/sta.c

   1 /* sta.c -- Implementation File (module.c template V1.0)
   2    Copyright (C) 1995, 1996, 1997, 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       None
  24
  25    Description:
  26       Analyzes the first two tokens, figures out what statements are
  27       possible, tries parsing the possible statements by calling on
  28       the ffestb functions.
  29
  30    Modifications:
  31 */
  32
  33 /* Include files. */
  34
  35 #include "proj.h"
  36 #include "sta.h"
  37 #include "bad.h"
  38 #include "implic.h"
  39 #include "lex.h"
  40 #include "malloc.h"
  41 #include "stb.h"
  42 #include "stc.h"
  43 #include "std.h"
  44 #include "str.h"
  45 #include "storag.h"
  46 #include "symbol.h"
  47
  48 /* Externals defined here. */
  49
  50 ffelexToken ffesta_tokens[FFESTA_tokensMAX];    /* For use by a possible. */
  51 ffestrFirst ffesta_first_kw;    /* First NAME(S) looked up. */
  52 ffestrSecond ffesta_second_kw;  /* Second NAME(S) looked up. */
  53 mallocPool ffesta_output_pool;  /* Pool for results of stmt handling. */
  54 mallocPool ffesta_scratch_pool; /* Pool for stmt scratch handling. */
  55 ffelexToken ffesta_construct_name;
  56 ffelexToken ffesta_label_token; /* Pending label stuff. */
  57 bool ffesta_seen_first_exec;
  58 bool ffesta_is_entry_valid = FALSE;     /* TRUE only in SUBROUTINE/FUNCTION. */
  59 bool ffesta_line_has_semicolons = FALSE;
  60
  61 /* Simple definitions and enumerations. */
  62
  63 #define FFESTA_ABORT_ON_CONFIRM_ 1      /* 0=slow, tested way; 1=faster way
  64                                            that might not always work. Here's
  65                                            the old description of what used
  66                                            to not work with ==1: (try
  67                                            "CONTINUE\10
  68                                            FORMAT('hi',I11)\END").  Problem
  69                                            is that the "topology" of the
  70                                            confirmed stmt's tokens with
  71                                            regard to CHARACTER, HOLLERITH,
  72                                            NAME/NAMES/NUMBER tokens (like hex
  73                                            numbers), isn't traced if we abort
  74                                            early, then other stmts might get
  75                                            their grubby hands on those
  76                                            unprocessed tokens and commit them
  77                                            improperly.  Ideal fix is to rerun
  78                                            the confirmed stmt and forget the
  79                                            rest.  */
  80
  81 #define FFESTA_maxPOSSIBLES_ 8/* Never more than this # of possibles. */
  82
  83 /* Internal typedefs. */
  84
  85 typedef struct _ffesta_possible_ *ffestaPossible_;
  86
  87 /* Private include files. */
  88
  89
  90 /* Internal structure definitions. */
  91
  92 struct _ffesta_possible_
  93   {
  94     ffestaPossible_ next;
  95     ffestaPossible_ previous;
  96     ffelexHandler handler;
  97     bool named;
  98   };
  99
 100 struct _ffesta_possible_root_
 101   {
 102     ffestaPossible_ first;
 103     ffestaPossible_ last;
 104     ffelexHandler nil;
 105   };
 106
 107 /* Static objects accessed by functions in this module. */
 108
 109 static bool ffesta_is_inhibited_ = FALSE;
 110 static ffelexToken ffesta_token_0_;     /* For use by ffest possibility
 111                                            handling. */
 112 static ffestaPossible_ ffesta_possibles_[FFESTA_maxPOSSIBLES_];
 113 static int ffesta_num_possibles_ = 0;   /* Number of possibilities. */
 114 static struct _ffesta_possible_root_ ffesta_possible_nonexecs_;
 115 static struct _ffesta_possible_root_ ffesta_possible_execs_;
 116 static ffestaPossible_ ffesta_current_possible_;
 117 static ffelexHandler ffesta_current_handler_;
 118 static bool ffesta_confirmed_current_ = FALSE;
 119 static bool ffesta_confirmed_other_ = FALSE;
 120 static ffestaPossible_ ffesta_confirmed_possible_;
 121 static bool ffesta_current_shutdown_ = FALSE;
 122 #if !FFESTA_ABORT_ON_CONFIRM_
 123 static bool ffesta_is_two_into_statement_ = FALSE;      /* For IF, WHERE stmts. */
 124 static ffelexToken ffesta_twotokens_1_; /* For IF, WHERE stmts. */
 125 static ffelexToken ffesta_twotokens_2_; /* For IF, WHERE stmts. */
 126 #endif
 127 static ffestaPooldisp ffesta_outpooldisp_;      /* After statement dealt
 128                                                    with. */
 129 static bool ffesta_inhibit_confirmation_ = FALSE;
 130
 131 /* Static functions (internal). */
 132
 133 static void ffesta_add_possible_ (ffelexHandler fn, bool exec, bool named);
 134 static bool ffesta_inhibited_exec_transition_ (void);
 135 static void ffesta_reset_possibles_ (void);
 136 static ffelexHandler ffesta_save_ (ffelexToken t);
 137 static ffelexHandler ffesta_second_ (ffelexToken t);
 138 #if !FFESTA_ABORT_ON_CONFIRM_
 139 static ffelexHandler ffesta_send_two_ (ffelexToken t);
 140 #endif
 141
 142 /* Internal macros. */
 143
 144 #define ffesta_add_possible_exec_(fn) (ffesta_add_possible_ (fn, TRUE, TRUE))
 145 #define ffesta_add_possible_nonexec_(fn) (ffesta_add_possible_ (fn, FALSE, TRUE))
 146 #define ffesta_add_possible_unnamed_exec_(fn) (ffesta_add_possible_ (fn, TRUE, FALSE))
 147 #define ffesta_add_possible_unnamed_nonexec_(fn) (ffesta_add_possible_ (fn, FALSE, FALSE))
 148 \f
 149 /* Add possible statement to appropriate list.  */
 150
 151 static void
 152 ffesta_add_possible_ (ffelexHandler fn, bool exec, bool named)
 153 {
 154   ffestaPossible_ p;
 155
 156   assert (ffesta_num_possibles_ < FFESTA_maxPOSSIBLES_);
 157
 158   p = ffesta_possibles_[ffesta_num_possibles_++];
 159
 160   if (exec)
 161     {
 162       p->next = (ffestaPossible_) &ffesta_possible_execs_.first;
 163       p->previous = ffesta_possible_execs_.last;
 164     }
 165   else
 166     {
 167       p->next = (ffestaPossible_) &ffesta_possible_nonexecs_.first;
 168       p->previous = ffesta_possible_nonexecs_.last;
 169     }
 170   p->next->previous = p;
 171   p->previous->next = p;
 172
 173   p->handler = fn;
 174   p->named = named;
 175 }
 176
 177 /* ffesta_inhibited_exec_transition_ -- Do exec transition while inhibited
 178
 179    if (!ffesta_inhibited_exec_transition_())  // couldn't transition...
 180
 181    Invokes ffestc_exec_transition, but first enables ffebad and ffesta and
 182    afterwards disables them again.  Then returns the result of the
 183    invocation of ffestc_exec_transition.  */
 184
 185 static bool
 186 ffesta_inhibited_exec_transition_ (void)
 187 {
 188   bool result;
 189
 190   assert (ffebad_inhibit ());
 191   assert (ffesta_is_inhibited_);
 192
 193   ffebad_set_inhibit (FALSE);
 194   ffesta_is_inhibited_ = FALSE;
 195
 196   result = ffestc_exec_transition ();
 197
 198   ffebad_set_inhibit (TRUE);
 199   ffesta_is_inhibited_ = TRUE;
 200
 201   return result;
 202 }
 203
 204 /* ffesta_reset_possibles_ -- Reset (clear) lists of possible statements
 205
 206    ffesta_reset_possibles_();
 207
 208    Clears the lists of executable and nonexecutable statements.  */
 209
 210 static void
 211 ffesta_reset_possibles_ (void)
 212 {
 213   ffesta_num_possibles_ = 0;
 214
 215   ffesta_possible_execs_.first = ffesta_possible_execs_.last
 216     = (ffestaPossible_) &ffesta_possible_execs_.first;
 217   ffesta_possible_nonexecs_.first = ffesta_possible_nonexecs_.last
 218     = (ffestaPossible_) &ffesta_possible_nonexecs_.first;
 219 }
 220
 221 /* ffesta_save_ -- Save token on list, pass thru to current handler
 222
 223    return ffesta_save_;  // to lexer.
 224
 225    Receives a token from the lexer.  Saves it in the list of tokens.  Calls
 226    the current handler with the token.
 227
 228    If no shutdown error occurred (via
 229    ffest_ffebad_start), then if the token was EOS or SEMICOLON, mark the
 230    current possible as successful and confirmed but try the next possible
 231    anyway until ambiguities in the form handling are ironed out.  */
 232
 233 static ffelexHandler
 234 ffesta_save_ (ffelexToken t)
 235 {
 236   static ffelexToken *saved_tokens = NULL;      /* A variable-sized array. */
 237   static unsigned int num_saved_tokens = 0;     /* Number currently saved. */
 238   static unsigned int max_saved_tokens = 0;     /* Maximum to be saved. */
 239   unsigned int toknum;          /* Index into saved_tokens array. */
 240   ffelexToken eos;              /* EOS created on-the-fly for shutdown
 241                                    purposes. */
 242   ffelexToken t2;               /* Another temporary token (no intersect with
 243                                    eos, btw). */
 244
 245   /* Save the current token. */
 246
 247   if (saved_tokens == NULL)
 248     {
 249       saved_tokens
 250         = malloc_new_ksr (malloc_pool_image (), "FFEST Saved Tokens",
 251                           (max_saved_tokens = 8) * sizeof (ffelexToken));
 252       /* Start off with 8. */
 253     }
 254   else if (num_saved_tokens >= max_saved_tokens)
 255     {
 256       toknum = max_saved_tokens;
 257       max_saved_tokens <<= 1;   /* Multiply by two. */
 258       assert (max_saved_tokens > toknum);
 259       saved_tokens
 260         = malloc_resize_ksr (malloc_pool_image (), saved_tokens,
 261                              max_saved_tokens * sizeof (ffelexToken),
 262                              toknum * sizeof (ffelexToken));
 263     }
 264
 265   *(saved_tokens + num_saved_tokens++) = ffelex_token_use (t);
 266
 267   /* Transmit the current token to the current handler. */
 268
 269   ffesta_current_handler_ = (ffelexHandler) (*ffesta_current_handler_) (t);
 270
 271   /* See if this possible has been shut down, or confirmed in which case we
 272      might as well shut it down anyway to save time. */
 273
 274   if ((ffesta_current_shutdown_ || (FFESTA_ABORT_ON_CONFIRM_
 275                                     && ffesta_confirmed_current_))
 276       && !ffelex_expecting_character ())
 277     {
 278       switch (ffelex_token_type (t))
 279         {
 280         case FFELEX_typeEOS:
 281         case FFELEX_typeSEMICOLON:
 282           break;
 283
 284         default:
 285           eos = ffelex_token_new_eos (ffelex_token_where_line (t),
 286                                       ffelex_token_where_column (t));
 287           ffesta_inhibit_confirmation_ = ffesta_current_shutdown_;
 288           (*ffesta_current_handler_) (eos);
 289           ffesta_inhibit_confirmation_ = FALSE;
 290           ffelex_token_kill (eos);
 291           break;
 292         }
 293     }
 294   else
 295     {
 296
 297       /* If this is an EOS or SEMICOLON token, switch to next handler, else
 298          return self as next handler for lexer. */
 299
 300       switch (ffelex_token_type (t))
 301         {
 302         case FFELEX_typeEOS:
 303         case FFELEX_typeSEMICOLON:
 304           break;
 305
 306         default:
 307           return (ffelexHandler) ffesta_save_;
 308         }
 309     }
 310
 311  next_handler:                  /* :::::::::::::::::::: */
 312
 313   /* Note that a shutdown also happens after seeing the first two tokens
 314      after "IF (expr)" or "WHERE (expr)" where a statement follows, even
 315      though there is no error.  This causes the IF or WHERE form to be
 316      implemented first before ffest_first is called for the first token in
 317      the following statement. */
 318
 319   if (ffesta_current_shutdown_)
 320     ffesta_current_shutdown_ = FALSE;   /* Only after sending EOS! */
 321   else
 322     assert (ffesta_confirmed_current_);
 323
 324   if (ffesta_confirmed_current_)
 325     {
 326       ffesta_confirmed_current_ = FALSE;
 327       ffesta_confirmed_other_ = TRUE;
 328     }
 329
 330   /* Pick next handler. */
 331
 332   ffesta_current_possible_ = ffesta_current_possible_->next;
 333   ffesta_current_handler_ = ffesta_current_possible_->handler;
 334   if (ffesta_current_handler_ == NULL)
 335     {                           /* No handler in this list, try exec list if
 336                                    not tried yet. */
 337       if (ffesta_current_possible_
 338           == (ffestaPossible_) &ffesta_possible_nonexecs_.first)
 339         {
 340           ffesta_current_possible_ = ffesta_possible_execs_.first;
 341           ffesta_current_handler_ = ffesta_current_possible_->handler;
 342         }
 343       if ((ffesta_current_handler_ == NULL)
 344           || (!ffesta_seen_first_exec
 345               && ((ffesta_confirmed_possible_ != NULL)
 346                   || !ffesta_inhibited_exec_transition_ ())))
 347         /* Don't run execs if:    (decoding the "if" ^^^ up here ^^^) - we
 348            have no exec handler available, or - we haven't seen the first
 349            executable statement yet, and - we've confirmed a nonexec
 350            (otherwise even a nonexec would cause a transition), or - a
 351            nonexec-to-exec transition can't be made at the statement context
 352            level (as in an executable statement in the middle of a STRUCTURE
 353            definition); if it can be made, ffestc_exec_transition makes the
 354            corresponding transition at the statement state level so
 355            specification statements are no longer accepted following an
 356            unrecognized statement.  (Note: it is valid for f_e_t_ to decide
 357            to always return TRUE by "shrieking" away the statement state
 358            stack until a transitionable state is reached.  Or it can leave
 359            the stack as is and return FALSE.)
 360
 361            If we decide not to run execs, enter this block to rerun the
 362            confirmed statement, if any. */
 363         {                       /* At end of both lists!  Pick confirmed or
 364                                    first possible. */
 365           ffebad_set_inhibit (FALSE);
 366           ffesta_is_inhibited_ = FALSE;
 367           ffesta_confirmed_other_ = FALSE;
 368           ffesta_tokens[0] = ffesta_token_0_;
 369           if (ffesta_confirmed_possible_ == NULL)
 370             {                   /* No confirmed success, just use first
 371                                    named possible, or first possible if
 372                                    no named possibles. */
 373               ffestaPossible_ possible = ffesta_possible_nonexecs_.first;
 374               ffestaPossible_ first = NULL;
 375               ffestaPossible_ first_named = NULL;
 376               ffestaPossible_ first_exec = NULL;
 377
 378               for (;;)
 379                 {
 380                   if (possible->handler == NULL)
 381                     {
 382                       if (possible == (ffestaPossible_) &ffesta_possible_nonexecs_.first)
 383                         {
 384                           possible = first_exec = ffesta_possible_execs_.first;
 385                           continue;
 386                         }
 387                       else
 388                         break;
 389                     }
 390                   if (first == NULL)
 391                     first = possible;
 392                   if (possible->named
 393                       && (first_named == NULL))
 394                     first_named = possible;
 395
 396                   possible = possible->next;
 397                 }
 398
 399               if (first_named != NULL)
 400                 ffesta_current_possible_ = first_named;
 401               else if (ffesta_seen_first_exec
 402                        && (first_exec != NULL))
 403                 ffesta_current_possible_ = first_exec;
 404               else
 405                 ffesta_current_possible_ = first;
 406
 407               ffesta_current_handler_ = ffesta_current_possible_->handler;
 408               assert (ffesta_current_handler_ != NULL);
 409             }
 410           else
 411             {                   /* Confirmed success, use it. */
 412               ffesta_current_possible_ = ffesta_confirmed_possible_;
 413               ffesta_current_handler_ = ffesta_confirmed_possible_->handler;
 414             }
 415           ffesta_reset_possibles_ ();
 416         }
 417       else
 418         {                       /* Switching from [empty?] list of nonexecs
 419                                    to nonempty list of execs at this point. */
 420           ffesta_tokens[0] = ffelex_token_use (ffesta_token_0_);
 421           ffesymbol_set_retractable (ffesta_scratch_pool);
 422         }
 423     }
 424   else
 425     {
 426       ffesta_tokens[0] = ffelex_token_use (ffesta_token_0_);
 427       ffesymbol_set_retractable (ffesta_scratch_pool);
 428     }
 429
 430   /* Send saved tokens to current handler until either shut down or all
 431      tokens sent. */
 432
 433   for (toknum = 0; toknum < num_saved_tokens; ++toknum)
 434     {
 435       t = *(saved_tokens + toknum);
 436       switch (ffelex_token_type (t))
 437         {
 438         case FFELEX_typeCHARACTER:
 439           ffelex_set_expecting_hollerith (0, '\0',
 440                                           ffewhere_line_unknown (),
 441                                           ffewhere_column_unknown ());
 442           ffesta_current_handler_
 443             = (ffelexHandler) (*ffesta_current_handler_) (t);
 444           break;
 445
 446         case FFELEX_typeNAMES:
 447           if (ffelex_is_names_expected ())
 448             ffesta_current_handler_
 449               = (ffelexHandler) (*ffesta_current_handler_) (t);
 450           else
 451             {
 452               t2 = ffelex_token_name_from_names (t, 0, 0);
 453               ffesta_current_handler_
 454                 = (ffelexHandler) (*ffesta_current_handler_) (t2);
 455               ffelex_token_kill (t2);
 456             }
 457           break;
 458
 459         default:
 460           ffesta_current_handler_
 461             = (ffelexHandler) (*ffesta_current_handler_) (t);
 462           break;
 463         }
 464
 465       if (!ffesta_is_inhibited_)
 466         ffelex_token_kill (t);  /* Won't need this any more. */
 467
 468       /* See if this possible has been shut down. */
 469
 470       else if ((ffesta_current_shutdown_ || (FFESTA_ABORT_ON_CONFIRM_
 471                                              && ffesta_confirmed_current_))
 472                && !ffelex_expecting_character ())
 473         {
 474           switch (ffelex_token_type (t))
 475             {
 476             case FFELEX_typeEOS:
 477             case FFELEX_typeSEMICOLON:
 478               break;
 479
 480             default:
 481               eos = ffelex_token_new_eos (ffelex_token_where_line (t),
 482                                           ffelex_token_where_column (t));
 483               ffesta_inhibit_confirmation_ = ffesta_current_shutdown_;
 484               (*ffesta_current_handler_) (eos);
 485               ffesta_inhibit_confirmation_ = FALSE;
 486               ffelex_token_kill (eos);
 487               break;
 488             }
 489           goto next_handler;    /* :::::::::::::::::::: */
 490         }
 491     }
 492
 493   /* Finished sending all the tokens so far.  If still trying possibilities,
 494      then if we've just sent an EOS or SEMICOLON token through, go to the
 495      next handler.  Otherwise, return self so we can gather and process more
 496      tokens. */
 497
 498   if (ffesta_is_inhibited_)
 499     {
 500       switch (ffelex_token_type (t))
 501         {
 502         case FFELEX_typeEOS:
 503         case FFELEX_typeSEMICOLON:
 504           goto next_handler;    /* :::::::::::::::::::: */
 505
 506         default:
 507 #if FFESTA_ABORT_ON_CONFIRM_
 508           assert (!ffesta_confirmed_other_);    /* Catch ambiguities. */
 509 #endif
 510           return (ffelexHandler) ffesta_save_;
 511         }
 512     }
 513
 514   /* This was the one final possibility, uninhibited, so send the final
 515      handler it sent. */
 516
 517   num_saved_tokens = 0;
 518 #if !FFESTA_ABORT_ON_CONFIRM_
 519   if (ffesta_is_two_into_statement_)
 520     {                           /* End of the line for the previous two
 521                                    tokens, resurrect them. */
 522       ffelexHandler next;
 523
 524       ffesta_is_two_into_statement_ = FALSE;
 525       next = (ffelexHandler) ffesta_first (ffesta_twotokens_1_);
 526       ffelex_token_kill (ffesta_twotokens_1_);
 527       next = (ffelexHandler) (*next) (ffesta_twotokens_2_);
 528       ffelex_token_kill (ffesta_twotokens_2_);
 529       return (ffelexHandler) next;
 530     }
 531 #endif
 532
 533   assert (ffesta_current_handler_ != NULL);
 534   return (ffelexHandler) ffesta_current_handler_;
 535 }
 536
 537 /* ffesta_second_ -- Parse the token after a NAME/NAMES in a statement
 538
 539    return ffesta_second_;  // to lexer.
 540
 541    The second token cannot be a NAMES, since the first token is a NAME or
 542    NAMES.  If the second token is a NAME, look up its name in the list of
 543    second names for use by whoever needs it.
 544
 545    Then make a list of all the possible statements this could be, based on
 546    looking at the first two tokens.  Two lists of possible statements are
 547    created, one consisting of nonexecutable statements, the other consisting
 548    of executable statements.
 549
 550    If the total number of possibilities is one, just fire up that
 551    possibility by calling its handler function, passing the first two
 552    tokens through it and so on.
 553
 554    Otherwise, start up a process whereby tokens are passed to the first
 555    possibility on the list until EOS or SEMICOLON is reached or an error
 556    is detected.  But inhibit any actual reporting of errors; just record
 557    their existence in the list.  If EOS or SEMICOLON is reached with no
 558    errors (other than non-form errors happening downstream, such as an
 559    overflowing value for an integer or a GOTO statement identifying a label
 560    on a FORMAT statement), then that is the only possible statement.  Rerun
 561    the statement with error-reporting turned on if any non-form errors were
 562    generated, otherwise just use its results, then erase the list of tokens
 563    memorized during the search process.  If a form error occurs, immediately
 564    cancel that possibility by sending EOS as the next token, remember the
 565    error code for that possibility, and try the next possibility on the list,
 566    first sending it the list of tokens memorized while handling the first
 567    possibility, then continuing on as before.
 568
 569    Ultimately, either the end of the list of possibilities will be reached
 570    without any successful forms being detected, in which case we pick one
 571    based on hueristics (usually the first possibility) and rerun it with
 572    error reporting turned on using the list of memorized tokens so the user
 573    sees the error, or one of the possibilities will effectively succeed.  */
 574
 575 static ffelexHandler
 576 ffesta_second_ (ffelexToken t)
 577 {
 578   ffelexHandler next;
 579   ffesymbol s;
 580
 581   assert (ffelex_token_type (t) != FFELEX_typeNAMES);
 582
 583   if (ffelex_token_type (t) == FFELEX_typeNAME)
 584     ffesta_second_kw = ffestr_second (t);
 585
 586   /* Here we use switch on the first keyword name and handle each possible
 587      recognizable name by looking at the second token, and building the list
 588      of possible names accordingly.  For now, just put every possible
 589      statement on the list for ambiguity checking. */
 590
 591   switch (ffesta_first_kw)
 592     {
 593     case FFESTR_firstASSIGN:
 594       ffesta_add_possible_exec_ ((ffelexHandler) ffestb_R838);
 595       break;
 596
 597     case FFESTR_firstBACKSPACE:
 598       ffestb_args.beru.len = FFESTR_firstlBACKSPACE;
 599       ffestb_args.beru.badname = "BACKSPACE";
 600       ffesta_add_possible_exec_ ((ffelexHandler) ffestb_beru);
 601       break;
 602
 603     case FFESTR_firstBLOCK:
 604       ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_block);
 605       break;
 606
 607     case FFESTR_firstBLOCKDATA:
 608       ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_blockdata);
 609       break;
 610
 611     case FFESTR_firstBYTE:
 612       ffestb_args.decl.len = FFESTR_firstlBYTE;
 613       ffestb_args.decl.type = FFESTP_typeBYTE;
 614       ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_decl_gentype);
 615       break;
 616
 617     case FFESTR_firstCALL:
 618       ffesta_add_possible_exec_ ((ffelexHandler) ffestb_R1212);
 619       break;
 620
 621     case FFESTR_firstCASE:
 622     case FFESTR_firstCASEDEFAULT:
 623       ffesta_add_possible_exec_ ((ffelexHandler) ffestb_R810);
 624       break;
 625
 626     case FFESTR_firstCHRCTR:
 627       ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_decl_chartype);
 628       break;
 629
 630     case FFESTR_firstCLOSE:
 631       ffesta_add_possible_exec_ ((ffelexHandler) ffestb_R907);
 632       break;
 633
 634     case FFESTR_firstCOMMON:
 635       ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_R547);
 636       break;
 637
 638     case FFESTR_firstCMPLX:
 639       ffestb_args.decl.len = FFESTR_firstlCMPLX;
 640       ffestb_args.decl.type = FFESTP_typeCOMPLEX;
 641       ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_decl_gentype);
 642       break;
 643
 644     case FFESTR_firstCONTINUE:
 645       ffesta_add_possible_exec_ ((ffelexHandler) ffestb_R841);
 646       break;
 647
 648     case FFESTR_firstCYCLE:
 649       ffesta_add_possible_exec_ ((ffelexHandler) ffestb_R834);
 650       break;
 651
 652     case FFESTR_firstDATA:
 653       if (ffe_is_pedantic_not_90 ())
 654         ffesta_add_possible_exec_ ((ffelexHandler) ffestb_R528);
 655       else
 656         ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_R528);
 657       break;
 658
 659     case FFESTR_firstDIMENSION:
 660       ffestb_args.R524.len = FFESTR_firstlDIMENSION;
 661       ffestb_args.R524.badname = "DIMENSION";
 662       ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_R524);
 663       break;
 664
 665     case FFESTR_firstDO:
 666       ffesta_add_possible_exec_ ((ffelexHandler) ffestb_do);
 667       break;
 668
 669     case FFESTR_firstDBL:
 670       ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_decl_double);
 671       break;
 672
 673     case FFESTR_firstDBLCMPLX:
 674       ffestb_args.decl.len = FFESTR_firstlDBLCMPLX;
 675       ffestb_args.decl.type = FFESTP_typeDBLCMPLX;
 676       ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_decl_dbltype);
 677       break;
 678
 679     case FFESTR_firstDBLPRCSN:
 680       ffestb_args.decl.len = FFESTR_firstlDBLPRCSN;
 681       ffestb_args.decl.type = FFESTP_typeDBLPRCSN;
 682       ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_decl_dbltype);
 683       break;
 684
 685     case FFESTR_firstDOWHILE:
 686       ffesta_add_possible_exec_ ((ffelexHandler) ffestb_dowhile);
 687       break;
 688
 689     case FFESTR_firstELSE:
 690       ffesta_add_possible_exec_ ((ffelexHandler) ffestb_else);
 691       break;
 692
 693     case FFESTR_firstELSEIF:
 694       ffestb_args.elsexyz.second = FFESTR_secondIF;
 695       ffesta_add_possible_exec_ ((ffelexHandler) ffestb_elsexyz);
 696       break;
 697
 698     case FFESTR_firstEND:
 699       if ((ffelex_token_type (ffesta_token_0_) == FFELEX_typeNAMES)
 700           || (ffelex_token_type (t) != FFELEX_typeNAME))
 701         ffesta_add_possible_exec_ ((ffelexHandler) ffestb_end);
 702       else
 703         {
 704           switch (ffesta_second_kw)
 705             {
 706             case FFESTR_secondBLOCK:
 707             case FFESTR_secondBLOCKDATA:
 708             case FFESTR_secondDO:
 709             case FFESTR_secondFILE:
 710             case FFESTR_secondFUNCTION:
 711             case FFESTR_secondIF:
 712             case FFESTR_secondPROGRAM:
 713             case FFESTR_secondSELECT:
 714             case FFESTR_secondSUBROUTINE:
 715               ffesta_add_possible_exec_ ((ffelexHandler) ffestb_end);
 716               break;
 717
 718             default:
 719               ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_end);
 720               break;
 721             }
 722         }
 723       break;
 724
 725     case FFESTR_firstENDBLOCK:
 726       ffestb_args.endxyz.len = FFESTR_firstlENDBLOCK;
 727       ffestb_args.endxyz.second = FFESTR_secondBLOCK;
 728       ffesta_add_possible_exec_ ((ffelexHandler) ffestb_endxyz);
 729       break;
 730
 731     case FFESTR_firstENDBLOCKDATA:
 732       ffestb_args.endxyz.len = FFESTR_firstlENDBLOCKDATA;
 733       ffestb_args.endxyz.second = FFESTR_secondBLOCKDATA;
 734       ffesta_add_possible_exec_ ((ffelexHandler) ffestb_endxyz);
 735       break;
 736
 737     case FFESTR_firstENDDO:
 738       ffestb_args.endxyz.len = FFESTR_firstlENDDO;
 739       ffestb_args.endxyz.second = FFESTR_secondDO;
 740       ffesta_add_possible_exec_ ((ffelexHandler) ffestb_endxyz);
 741       break;
 742
 743     case FFESTR_firstENDFILE:
 744       ffestb_args.beru.len = FFESTR_firstlENDFILE;
 745       ffestb_args.beru.badname = "ENDFILE";
 746       ffesta_add_possible_exec_ ((ffelexHandler) ffestb_beru);
 747       break;
 748
 749     case FFESTR_firstENDFUNCTION:
 750       ffestb_args.endxyz.len = FFESTR_firstlENDFUNCTION;
 751       ffestb_args.endxyz.second = FFESTR_secondFUNCTION;
 752       ffesta_add_possible_exec_ ((ffelexHandler) ffestb_endxyz);
 753       break;
 754
 755     case FFESTR_firstENDIF:
 756       ffestb_args.endxyz.len = FFESTR_firstlENDIF;
 757       ffestb_args.endxyz.second = FFESTR_secondIF;
 758       ffesta_add_possible_exec_ ((ffelexHandler) ffestb_endxyz);
 759       break;
 760
 761     case FFESTR_firstENDPROGRAM:
 762       ffestb_args.endxyz.len = FFESTR_firstlENDPROGRAM;
 763       ffestb_args.endxyz.second = FFESTR_secondPROGRAM;
 764       ffesta_add_possible_exec_ ((ffelexHandler) ffestb_endxyz);
 765       break;
 766
 767     case FFESTR_firstENDSELECT:
 768       ffestb_args.endxyz.len = FFESTR_firstlENDSELECT;
 769       ffestb_args.endxyz.second = FFESTR_secondSELECT;
 770       ffesta_add_possible_exec_ ((ffelexHandler) ffestb_endxyz);
 771       break;
 772
 773     case FFESTR_firstENDSUBROUTINE:
 774       ffestb_args.endxyz.len = FFESTR_firstlENDSUBROUTINE;
 775       ffestb_args.endxyz.second = FFESTR_secondSUBROUTINE;
 776       ffesta_add_possible_exec_ ((ffelexHandler) ffestb_endxyz);
 777       break;
 778
 779     case FFESTR_firstENTRY:
 780       ffestb_args.dummy.len = FFESTR_firstlENTRY;
 781       ffestb_args.dummy.badname = "ENTRY";
 782       ffestb_args.dummy.is_subr = ffestc_is_entry_in_subr ();
 783       ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_dummy);
 784       break;
 785
 786     case FFESTR_firstEQUIVALENCE:
 787       ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_R544);
 788       break;
 789
 790     case FFESTR_firstEXIT:
 791       ffesta_add_possible_exec_ ((ffelexHandler) ffestb_R835);
 792       break;
 793
 794     case FFESTR_firstEXTERNAL:
 795       ffestb_args.varlist.len = FFESTR_firstlEXTERNAL;
 796       ffestb_args.varlist.badname = "EXTERNAL";
 797       ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_varlist);
 798       break;
 799
 800       /* WARNING: don't put anything that might cause an item to precede
 801          FORMAT in the list of possible statements (it's added below) without
 802          making sure FORMAT still is first.  It has to run with
 803          ffelex_set_names_pure(TRUE), to make sure the lexer delivers NAMES
 804          tokens. */
 805
 806     case FFESTR_firstFORMAT:
 807       ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_R1001);
 808       break;
 809
 810     case FFESTR_firstFUNCTION:
 811       ffestb_args.dummy.len = FFESTR_firstlFUNCTION;
 812       ffestb_args.dummy.badname = "FUNCTION";
 813       ffestb_args.dummy.is_subr = FALSE;
 814       ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_dummy);
 815       break;
 816
 817     case FFESTR_firstGO:
 818       if ((ffelex_token_type (ffesta_token_0_) == FFELEX_typeNAMES)
 819         || (ffelex_token_type (t) != FFELEX_typeNAME))
 820         ffesta_add_possible_exec_ ((ffelexHandler) ffestb_goto);
 821       else
 822         switch (ffesta_second_kw)
 823           {
 824             case FFESTR_secondTO:
 825               ffesta_add_possible_exec_ ((ffelexHandler) ffestb_goto);
 826               break;
 827             default:
 828               ffesta_add_possible_exec_ ((ffelexHandler) ffestb_goto);
 829               break;
 830           }
 831       break;
 832
 833     case FFESTR_firstGOTO:
 834       ffesta_add_possible_exec_ ((ffelexHandler) ffestb_goto);
 835       break;
 836
 837     case FFESTR_firstIF:
 838       ffesta_add_possible_exec_ ((ffelexHandler) ffestb_if);
 839       ffesta_add_possible_exec_ ((ffelexHandler) ffestb_R840);
 840       break;
 841
 842     case FFESTR_firstIMPLICIT:
 843       ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_decl_R539);
 844       break;
 845
 846     case FFESTR_firstINCLUDE:
 847       ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_S3P4);
 848       switch (ffelex_token_type (t))
 849         {
 850         case FFELEX_typeNUMBER:
 851         case FFELEX_typeNAME:
 852         case FFELEX_typeAPOSTROPHE:
 853         case FFELEX_typeQUOTE:
 854           break;
 855
 856         default:
 857           break;
 858         }
 859       break;
 860
 861     case FFESTR_firstINQUIRE:
 862       ffesta_add_possible_exec_ ((ffelexHandler) ffestb_R923);
 863       break;
 864
 865     case FFESTR_firstINTGR:
 866       ffestb_args.decl.len = FFESTR_firstlINTGR;
 867       ffestb_args.decl.type = FFESTP_typeINTEGER;
 868       ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_decl_gentype);
 869       break;
 870
 871     case FFESTR_firstINTRINSIC:
 872       ffestb_args.varlist.len = FFESTR_firstlINTRINSIC;
 873       ffestb_args.varlist.badname = "INTRINSIC";
 874       ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_varlist);
 875       break;
 876
 877     case FFESTR_firstLGCL:
 878       ffestb_args.decl.len = FFESTR_firstlLGCL;
 879       ffestb_args.decl.type = FFESTP_typeLOGICAL;
 880       ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_decl_gentype);
 881       break;
 882
 883     case FFESTR_firstNAMELIST:
 884       ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_R542);
 885       break;
 886
 887     case FFESTR_firstOPEN:
 888       ffesta_add_possible_exec_ ((ffelexHandler) ffestb_R904);
 889       break;
 890
 891     case FFESTR_firstPARAMETER:
 892       ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_R537);
 893       ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_V027);
 894       break;
 895
 896     case FFESTR_firstPAUSE:
 897       ffestb_args.halt.len = FFESTR_firstlPAUSE;
 898       ffesta_add_possible_exec_ ((ffelexHandler) ffestb_halt);
 899       break;
 900
 901     case FFESTR_firstPRINT:
 902       ffesta_add_possible_exec_ ((ffelexHandler) ffestb_R911);
 903       break;
 904
 905     case FFESTR_firstPROGRAM:
 906       ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_R1102);
 907       break;
 908
 909     case FFESTR_firstREAD:
 910       ffesta_add_possible_exec_ ((ffelexHandler) ffestb_R909);
 911       break;
 912
 913     case FFESTR_firstREAL:
 914       ffestb_args.decl.len = FFESTR_firstlREAL;
 915       ffestb_args.decl.type = FFESTP_typeREAL;
 916       ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_decl_gentype);
 917       break;
 918
 919     case FFESTR_firstRETURN:
 920       ffesta_add_possible_exec_ ((ffelexHandler) ffestb_R1227);
 921       break;
 922
 923     case FFESTR_firstREWIND:
 924       ffestb_args.beru.len = FFESTR_firstlREWIND;
 925       ffestb_args.beru.badname = "REWIND";
 926       ffesta_add_possible_exec_ ((ffelexHandler) ffestb_beru);
 927       break;
 928
 929     case FFESTR_firstSAVE:
 930       ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_R522);
 931       break;
 932
 933     case FFESTR_firstSELECT:
 934       ffesta_add_possible_exec_ ((ffelexHandler) ffestb_R809);
 935       break;
 936
 937     case FFESTR_firstSELECTCASE:
 938       ffesta_add_possible_exec_ ((ffelexHandler) ffestb_R809);
 939       break;
 940
 941     case FFESTR_firstSTOP:
 942       ffestb_args.halt.len = FFESTR_firstlSTOP;
 943       ffesta_add_possible_exec_ ((ffelexHandler) ffestb_halt);
 944       break;
 945
 946     case FFESTR_firstSUBROUTINE:
 947       ffestb_args.dummy.len = FFESTR_firstlSUBROUTINE;
 948       ffestb_args.dummy.badname = "SUBROUTINE";
 949       ffestb_args.dummy.is_subr = TRUE;
 950       ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_dummy);
 951       break;
 952
 953     case FFESTR_firstTYPE:
 954       ffesta_add_possible_exec_ ((ffelexHandler) ffestb_V020);
 955       break;
 956
 957     case FFESTR_firstVIRTUAL:
 958       ffestb_args.R524.len = FFESTR_firstlVIRTUAL;
 959       ffestb_args.R524.badname = "VIRTUAL";
 960       ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_R524);
 961       break;
 962
 963     case FFESTR_firstVOLATILE:
 964       ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_V014);
 965       break;
 966
 967     case FFESTR_firstWORD:
 968       ffestb_args.decl.len = FFESTR_firstlWORD;
 969       ffestb_args.decl.type = FFESTP_typeWORD;
 970       ffesta_add_possible_nonexec_ ((ffelexHandler) ffestb_decl_gentype);
 971       break;
 972
 973     case FFESTR_firstWRITE:
 974       ffesta_add_possible_exec_ ((ffelexHandler) ffestb_R910);
 975       break;
 976
 977     default:
 978       break;
 979     }
 980
 981   /* Now check the default cases, which are always "live" (meaning that no
 982      other possibility can override them).  These are where the second token
 983      is OPEN_PAREN, PERCENT, EQUALS, POINTS, or COLON. */
 984
 985   switch (ffelex_token_type (t))
 986     {
 987     case FFELEX_typeOPEN_PAREN:
 988       s = ffesymbol_lookup_local (ffesta_token_0_);
 989       if (((s == NULL) || (ffesymbol_dims (s) == NULL))
 990           && !ffesta_seen_first_exec)
 991         {                       /* Not known as array; may be stmt function. */
 992           ffesta_add_possible_unnamed_nonexec_ ((ffelexHandler) ffestb_R1229);
 993
 994           /* If the symbol is (or will be due to implicit typing) of
 995              CHARACTER type, then the statement might be an assignment
 996              statement.  If so, since it can't be a function invocation nor
 997              an array element reference, the open paren following the symbol
 998              name must be followed by an expression and a colon.  Without the
 999              colon (which cannot appear in a stmt function definition), the
1000              let stmt rejects.  So CHARACTER_NAME(...)=expr, unlike any other
1001              type, is not ambiguous alone. */
1002
1003           if (ffeimplic_peek_symbol_type (s,
1004                                         ffelex_token_text (ffesta_token_0_))
1005               == FFEINFO_basictypeCHARACTER)
1006             ffesta_add_possible_unnamed_exec_ ((ffelexHandler) ffestb_let);
1007         }
1008       else                      /* Not statement function if known as an
1009                                    array. */
1010         ffesta_add_possible_unnamed_exec_ ((ffelexHandler) ffestb_let);
1011       break;
1012
1013     case FFELEX_typeEQUALS:
1014       ffesta_add_possible_unnamed_exec_ ((ffelexHandler) ffestb_let);
1015       break;
1016
1017     case FFELEX_typeCOLON:
1018       ffesta_add_possible_exec_ ((ffelexHandler) ffestb_construct);
1019       break;
1020
1021     default:
1022       ;
1023     }
1024
1025   /* Now see how many possibilities are on the list. */
1026
1027   switch (ffesta_num_possibles_)
1028     {
1029     case 0:                     /* None, so invalid statement. */
1030     no_stmts:                   /* :::::::::::::::::::: */
1031       ffesta_tokens[0] = ffesta_token_0_;
1032       ffesta_ffebad_2t (FFEBAD_UNREC_STMT, ffesta_token_0_, t);
1033       next = (ffelexHandler) ffelex_swallow_tokens (NULL,
1034                                                (ffelexHandler) ffesta_zero);
1035       break;
1036
1037     case 1:                     /* One, so just do it! */
1038       ffesta_tokens[0] = ffesta_token_0_;
1039       next = ffesta_possible_execs_.first->handler;
1040       if (next == NULL)
1041         {                       /* Have a nonexec stmt. */
1042           next = ffesta_possible_nonexecs_.first->handler;
1043           assert (next != NULL);
1044         }
1045       else if (ffesta_seen_first_exec)
1046         ;                       /* Have an exec stmt after exec transition. */
1047       else if (!ffestc_exec_transition ())
1048         /* 1 exec stmt only, but not valid in context, so pretend as though
1049            statement is unrecognized. */
1050         goto no_stmts;          /* :::::::::::::::::::: */
1051       break;
1052
1053     default:                    /* More than one, so try them in order. */
1054       ffesta_confirmed_possible_ = NULL;
1055       ffesta_current_possible_ = ffesta_possible_nonexecs_.first;
1056       ffesta_current_handler_ = ffesta_current_possible_->handler;
1057       if (ffesta_current_handler_ == NULL)
1058         {
1059           ffesta_current_possible_ = ffesta_possible_execs_.first;
1060           ffesta_current_handler_ = ffesta_current_possible_->handler;
1061           assert (ffesta_current_handler_ != NULL);
1062           if (!ffesta_seen_first_exec)
1063             {                   /* Need to do exec transition now. */
1064               ffesta_tokens[0] = ffesta_token_0_;
1065               if (!ffestc_exec_transition ())
1066                 goto no_stmts;  /* :::::::::::::::::::: */
1067             }
1068         }
1069       ffesta_tokens[0] = ffelex_token_use (ffesta_token_0_);
1070       next = (ffelexHandler) ffesta_save_;
1071       ffebad_set_inhibit (TRUE);
1072       ffesta_is_inhibited_ = TRUE;
1073       break;
1074     }
1075
1076   ffesta_output_pool
1077     = malloc_pool_new ("Statement Output", ffe_pool_program_unit (), 1024);
1078   ffesta_scratch_pool
1079     = malloc_pool_new ("Statement Scratch", ffe_pool_program_unit (), 1024);
1080   ffesta_outpooldisp_ = FFESTA_pooldispDISCARD;
1081
1082   if (ffesta_is_inhibited_)
1083     ffesymbol_set_retractable (ffesta_scratch_pool);
1084
1085   ffelex_set_names (FALSE);     /* Most handlers will want this.  If not,
1086                                    they have to set it TRUE again (its value
1087                                    at the beginning of a statement). */
1088
1089   return (ffelexHandler) (*next) (t);
1090 }
1091
1092 /* ffesta_send_two_ -- Send the two tokens saved by ffesta_two after all
1093
1094    return ffesta_send_two_;  // to lexer.
1095
1096    Currently, if this function gets called, it means that the two tokens
1097    saved by ffesta_two did not have their handlers derailed by
1098    ffesta_save_, which probably means they weren't sent by ffesta_save_
1099    but directly by the lexer, which probably means the original statement
1100    (which should be IF (expr) or WHERE (expr)) somehow evaluated to only
1101    one possibility in ffesta_second_ or somebody optimized FFEST to
1102    immediately revert to one possibility upon confirmation but forgot to
1103    change this function (and thus perhaps the entire resubmission
1104    mechanism).  */
1105
1106 #if !FFESTA_ABORT_ON_CONFIRM_
1107 static ffelexHandler
1108 ffesta_send_two_ (ffelexToken t)
1109 {
1110   assert ("what am I doing here?" == NULL);
1111   return NULL;
1112 }
1113
1114 #endif
1115 /* ffesta_confirmed -- Confirm current possibility as only one
1116
1117    ffesta_confirmed();
1118
1119    Sets the confirmation flag.  During debugging for ambiguous constructs,
1120    asserts that the confirmation flag for a previous possibility has not
1121    yet been set.  */
1122
1123 void
1124 ffesta_confirmed (void)
1125 {
1126   if (ffesta_inhibit_confirmation_)
1127     return;
1128   ffesta_confirmed_current_ = TRUE;
1129   assert (!ffesta_confirmed_other_
1130           || (ffesta_confirmed_possible_ == ffesta_current_possible_));
1131   ffesta_confirmed_possible_ = ffesta_current_possible_;
1132 }
1133
1134 /* ffesta_eof -- End of (non-INCLUDEd) source file
1135
1136    ffesta_eof();
1137
1138    Call after piping tokens through ffest_first, where the most recent
1139    token sent through must be EOS.
1140
1141    20-Feb-91  JCB  1.1
1142       Put new EOF token in ffesta_tokens[0], not NULL, because too much
1143       code expects something there for error reporting and the like.  Also,
1144       do basically the same things ffest_second and ffesta_zero do for
1145       processing a statement (make and destroy pools, et cetera).  */
1146
1147 void
1148 ffesta_eof (void)
1149 {
1150   ffesta_tokens[0] = ffelex_token_new_eof ();
1151
1152   ffesta_output_pool
1153     = malloc_pool_new ("Statement Output", ffe_pool_program_unit (), 1024);
1154   ffesta_scratch_pool
1155     = malloc_pool_new ("Statement Scratch", ffe_pool_program_unit (), 1024);
1156   ffesta_outpooldisp_ = FFESTA_pooldispDISCARD;
1157
1158   ffestc_eof ();
1159
1160   if (ffesta_tokens[0] != NULL)
1161     ffelex_token_kill (ffesta_tokens[0]);
1162
1163   if (ffesta_output_pool != NULL)
1164     {
1165       if (ffesta_outpooldisp_ == FFESTA_pooldispDISCARD)
1166         malloc_pool_kill (ffesta_output_pool);
1167       ffesta_output_pool = NULL;
1168     }
1169
1170   if (ffesta_scratch_pool != NULL)
1171     {
1172       malloc_pool_kill (ffesta_scratch_pool);
1173       ffesta_scratch_pool = NULL;
1174     }
1175
1176   if (ffesta_label_token != NULL)
1177     {
1178       ffelex_token_kill (ffesta_label_token);
1179       ffesta_label_token = NULL;
1180     }
1181
1182   if (ffe_is_ffedebug ())
1183     {
1184       ffestorag_report ();
1185     }
1186 }
1187
1188 /* ffesta_ffebad_here_current_stmt -- ffebad_here with ptr to current stmt
1189
1190    ffesta_ffebad_here_current_stmt(0);
1191
1192    Outsiders can call this fn if they have no more convenient place to
1193    point to (via a token or pair of ffewhere objects) and they know a
1194    current, useful statement is being evaluted by ffest (i.e. they are
1195    being called from ffestb, ffestc, ffestd, ... functions).  */
1196
1197 void
1198 ffesta_ffebad_here_current_stmt (ffebadIndex i)
1199 {
1200   assert (ffesta_tokens[0] != NULL);
1201   ffebad_here (i, ffelex_token_where_line (ffesta_tokens[0]),
1202                ffelex_token_where_column (ffesta_tokens[0]));
1203 }
1204
1205 /* ffesta_ffebad_start -- Start a possibly inhibited error report
1206
1207    if (ffesta_ffebad_start(FFEBAD_SOME_ERROR))
1208        {
1209        ffebad_here, ffebad_string ...;
1210        ffebad_finish();
1211        }
1212
1213    Call if the error might indicate that ffest is evaluating the wrong
1214    statement form, instead of calling ffebad_start directly.  If ffest
1215    is choosing between forms, it will return FALSE, send an EOS/SEMICOLON
1216    token through as the next token (if the current one isn't already one
1217    of those), and try another possible form.  Otherwise, ffebad_start is
1218    called with the argument and TRUE returned.  */
1219
1220 bool
1221 ffesta_ffebad_start (ffebad errnum)
1222 {
1223   if (!ffesta_is_inhibited_)
1224     {
1225       ffebad_start (errnum);
1226       return TRUE;
1227     }
1228
1229   if (!ffesta_confirmed_current_)
1230     ffesta_current_shutdown_ = TRUE;
1231
1232   return FALSE;
1233 }
1234
1235 /* ffesta_first -- Parse the first token in a statement
1236
1237    return ffesta_first;  // to lexer.  */
1238
1239 ffelexHandler
1240 ffesta_first (ffelexToken t)
1241 {
1242   switch (ffelex_token_type (t))
1243     {
1244     case FFELEX_typeSEMICOLON:
1245     case FFELEX_typeEOS:
1246       ffesta_tokens[0] = ffelex_token_use (t);
1247       if (ffesta_label_token != NULL)
1248         {
1249           ffebad_start (FFEBAD_LABEL_WITHOUT_STMT);
1250           ffebad_here (0, ffelex_token_where_line (ffesta_label_token),
1251                        ffelex_token_where_column (ffesta_label_token));
1252           ffebad_string (ffelex_token_text (ffesta_label_token));
1253           ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
1254           ffebad_finish ();
1255         }
1256       return (ffelexHandler) ffesta_zero (t);
1257
1258     case FFELEX_typeNAME:
1259     case FFELEX_typeNAMES:
1260       ffesta_token_0_ = ffelex_token_use (t);
1261       ffesta_first_kw = ffestr_first (t);
1262       return (ffelexHandler) ffesta_second_;
1263
1264     case FFELEX_typeNUMBER:
1265       if (ffesta_line_has_semicolons
1266           && !ffe_is_free_form ()
1267           && ffe_is_pedantic ())
1268         {
1269           ffebad_start (FFEBAD_LABEL_WRONG_PLACE);
1270           ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
1271           ffebad_string (ffelex_token_text (t));
1272           ffebad_finish ();
1273         }
1274       if (ffesta_label_token == NULL)
1275         {
1276           ffesta_label_token = ffelex_token_use (t);
1277           return (ffelexHandler) ffesta_first;
1278         }
1279       else
1280         {
1281           ffebad_start (FFEBAD_EXTRA_LABEL_DEF);
1282           ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
1283           ffebad_string (ffelex_token_text (t));
1284           ffebad_here (1, ffelex_token_where_line (ffesta_label_token),
1285                        ffelex_token_where_column (ffesta_label_token));
1286           ffebad_string (ffelex_token_text (ffesta_label_token));
1287           ffebad_finish ();
1288
1289           return (ffelexHandler) ffesta_first;
1290         }
1291
1292     default:                    /* Invalid first token. */
1293       ffesta_tokens[0] = ffelex_token_use (t);
1294       ffebad_start (FFEBAD_STMT_BEGINS_BAD);
1295       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
1296       ffebad_finish ();
1297       return (ffelexHandler) ffelex_swallow_tokens (t,
1298                                                (ffelexHandler) ffesta_zero);
1299     }
1300 }
1301
1302 /* ffesta_init_0 -- Initialize for entire image invocation
1303
1304    ffesta_init_0();
1305
1306    Call just once per invocation of the compiler (not once per invocation
1307    of the front end).
1308
1309    Gets memory for the list of possibles once and for all, since this
1310    list never gets larger than a certain size (FFESTA_maxPOSSIBLES_)
1311    and is not particularly large.  Initializes the array of pointers to
1312    this list.  Initializes the executable and nonexecutable lists.  */
1313
1314 void
1315 ffesta_init_0 (void)
1316 {
1317   ffestaPossible_ ptr;
1318   int i;
1319
1320   ptr = malloc_new_kp (malloc_pool_image (), "FFEST possibles",
1321                        FFESTA_maxPOSSIBLES_ * sizeof (*ptr));
1322
1323   for (i = 0; i < FFESTA_maxPOSSIBLES_; ++i)
1324     ffesta_possibles_[i] = ptr++;
1325
1326   ffesta_possible_execs_.first = ffesta_possible_execs_.last
1327     = (ffestaPossible_) &ffesta_possible_execs_.first;
1328   ffesta_possible_nonexecs_.first = ffesta_possible_nonexecs_.last
1329     = (ffestaPossible_) &ffesta_possible_nonexecs_.first;
1330   ffesta_possible_execs_.nil = ffesta_possible_nonexecs_.nil = NULL;
1331 }
1332
1333 /* ffesta_init_3 -- Initialize for any program unit
1334
1335    ffesta_init_3();  */
1336
1337 void
1338 ffesta_init_3 (void)
1339 {
1340   ffesta_output_pool = NULL;    /* May be doing this just before reaching */
1341   ffesta_scratch_pool = NULL;   /* ffesta_zero or ffesta_two. */
1342   /* NOTE: we let the ffe_terminate_2 action of killing the program_unit pool
1343      handle the killing of the output and scratch pools for us, which is why
1344      we don't have a terminate_3 action to do so. */
1345   ffesta_construct_name = NULL;
1346   ffesta_label_token = NULL;
1347   ffesta_seen_first_exec = FALSE;
1348 }
1349
1350 /* ffesta_is_inhibited -- Test whether the current possibility is inhibited
1351
1352    if (!ffesta_is_inhibited())
1353        // implement the statement.
1354
1355    Just make sure the current possibility has been confirmed.  If anyone
1356    really needs to test whether the current possibility is inhibited prior
1357    to confirming it, that indicates a need to begin statement processing
1358    before it is certain that the given possibility is indeed the statement
1359    to be processed.  As of this writing, there does not appear to be such
1360    a need.  If there is, then when confirming a statement would normally
1361    immediately disable the inhibition (whereas currently we leave the
1362    confirmed statement disabled until we've tried the other possibilities,
1363    to check for ambiguities), we must check to see if the possibility has
1364    already tested for inhibition prior to confirmation and, if so, maintain
1365    inhibition until the end of the statement (which may be forced right
1366    away) and then rerun the entire statement from the beginning.  Otherwise,
1367    initial calls to ffestb functions won't have been made, but subsequent
1368    calls (after confirmation) will, which is wrong.  Of course, this all
1369    applies only to those statements implemented via multiple calls to
1370    ffestb, although if a statement requiring only a single ffestb call
1371    tested for inhibition prior to confirmation, it would likely mean that
1372    the ffestb call would be completely dropped without this mechanism.  */
1373
1374 bool
1375 ffesta_is_inhibited (void)
1376 {
1377   assert (ffesta_confirmed_current_ || ffesta_inhibit_confirmation_);
1378   return ffesta_is_inhibited_;
1379 }
1380
1381 /* ffesta_ffebad_1p -- Issue diagnostic with one source character
1382
1383    ffelexToken names_token;
1384    ffeTokenLength index;
1385    ffelexToken next_token;
1386    ffesta_ffebad_1p(FFEBAD_SOME_ERROR,names_token,index,next_token);
1387
1388    Equivalent to "if (ffest_ffebad_start(FFEBAD_SOME_ERROR))" followed by
1389    sending one argument, the location of index with names_token, if TRUE is
1390    returned.  If index is equal to the length of names_token, meaning it
1391    points to the end of the token, then uses the location in next_token
1392    (which should be the token sent by the lexer after it sent names_token)
1393    instead.  */
1394
1395 void
1396 ffesta_ffebad_1p (ffebad errnum, ffelexToken names_token, ffeTokenLength index,
1397                   ffelexToken next_token)
1398 {
1399   ffewhereLine line;
1400   ffewhereColumn col;
1401
1402   assert (index <= ffelex_token_length (names_token));
1403
1404   if (ffesta_ffebad_start (errnum))
1405     {
1406       if (index == ffelex_token_length (names_token))
1407         {
1408           assert (next_token != NULL);
1409           line = ffelex_token_where_line (next_token);
1410           col = ffelex_token_where_column (next_token);
1411           ffebad_here (0, line, col);
1412         }
1413       else
1414         {
1415           ffewhere_set_from_track (&line, &col,
1416                                    ffelex_token_where_line (names_token),
1417                                    ffelex_token_where_column (names_token),
1418                                    ffelex_token_wheretrack (names_token),
1419                                    index);
1420           ffebad_here (0, line, col);
1421           ffewhere_line_kill (line);
1422           ffewhere_column_kill (col);
1423         }
1424       ffebad_finish ();
1425     }
1426 }
1427
1428 void
1429 ffesta_ffebad_1sp (ffebad errnum, const char *s, ffelexToken names_token,
1430                    ffeTokenLength index, ffelexToken next_token)
1431 {
1432   ffewhereLine line;
1433   ffewhereColumn col;
1434
1435   assert (index <= ffelex_token_length (names_token));
1436
1437   if (ffesta_ffebad_start (errnum))
1438     {
1439       ffebad_string (s);
1440       if (index == ffelex_token_length (names_token))
1441         {
1442           assert (next_token != NULL);
1443           line = ffelex_token_where_line (next_token);
1444           col = ffelex_token_where_column (next_token);
1445           ffebad_here (0, line, col);
1446         }
1447       else
1448         {
1449           ffewhere_set_from_track (&line, &col,
1450                                    ffelex_token_where_line (names_token),
1451                                    ffelex_token_where_column (names_token),
1452                                    ffelex_token_wheretrack (names_token),
1453                                    index);
1454           ffebad_here (0, line, col);
1455           ffewhere_line_kill (line);
1456           ffewhere_column_kill (col);
1457         }
1458       ffebad_finish ();
1459     }
1460 }
1461
1462 void
1463 ffesta_ffebad_1st (ffebad errnum, const char *s, ffelexToken t)
1464 {
1465   if (ffesta_ffebad_start (errnum))
1466     {
1467       ffebad_string (s);
1468       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
1469       ffebad_finish ();
1470     }
1471 }
1472
1473 /* ffesta_ffebad_1t -- Issue diagnostic with one source token
1474
1475    ffelexToken t;
1476    ffesta_ffebad_1t(FFEBAD_SOME_ERROR,t);
1477
1478    Equivalent to "if (ffesta_ffebad_start(FFEBAD_SOME_ERROR))" followed by
1479    sending one argument, the location of the token t, if TRUE is returned.  */
1480
1481 void
1482 ffesta_ffebad_1t (ffebad errnum, ffelexToken t)
1483 {
1484   if (ffesta_ffebad_start (errnum))
1485     {
1486       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
1487       ffebad_finish ();
1488     }
1489 }
1490
1491 void
1492 ffesta_ffebad_2st (ffebad errnum, const char *s, ffelexToken t1, ffelexToken t2)
1493 {
1494   if (ffesta_ffebad_start (errnum))
1495     {
1496       ffebad_string (s);
1497       ffebad_here (0, ffelex_token_where_line (t1), ffelex_token_where_column (t1));
1498       ffebad_here (1, ffelex_token_where_line (t2), ffelex_token_where_column (t2));
1499       ffebad_finish ();
1500     }
1501 }
1502
1503 /* ffesta_ffebad_2t -- Issue diagnostic with two source tokens
1504
1505    ffelexToken t1, t2;
1506    ffesta_ffebad_2t(FFEBAD_SOME_ERROR,t1,t2);
1507
1508    Equivalent to "if (ffesta_ffebad_start(FFEBAD_SOME_ERROR))" followed by
1509    sending two argument, the locations of the tokens t1 and t2, if TRUE is
1510    returned.  */
1511
1512 void
1513 ffesta_ffebad_2t (ffebad errnum, ffelexToken t1, ffelexToken t2)
1514 {
1515   if (ffesta_ffebad_start (errnum))
1516     {
1517       ffebad_here (0, ffelex_token_where_line (t1), ffelex_token_where_column (t1));
1518       ffebad_here (1, ffelex_token_where_line (t2), ffelex_token_where_column (t2));
1519       ffebad_finish ();
1520     }
1521 }
1522
1523 ffestaPooldisp
1524 ffesta_outpooldisp (void)
1525 {
1526   return ffesta_outpooldisp_;
1527 }
1528
1529 void
1530 ffesta_set_outpooldisp (ffestaPooldisp d)
1531 {
1532   ffesta_outpooldisp_ = d;
1533 }
1534
1535 /* Shut down current parsing possibility, but without bothering the
1536    user with a diagnostic if we're not inhibited.  */
1537
1538 void
1539 ffesta_shutdown (void)
1540 {
1541   if (ffesta_is_inhibited_)
1542     ffesta_current_shutdown_ = TRUE;
1543 }
1544
1545 /* ffesta_two -- Deal with the first two tokens after a swallowed statement
1546
1547    return ffesta_two(first_token,second_token);  // to lexer.
1548
1549    Like ffesta_zero, except instead of expecting an EOS or SEMICOLON, it
1550    expects the first two tokens of a statement that is part of another
1551    statement: the first two tokens of statement in "IF (expr) statement" or
1552    "WHERE (expr) statement", in particular.  The first token must be a NAME
1553    or NAMES, the second can be basically anything.  The statement type MUST
1554    be confirmed by now.
1555
1556    If we're not inhibited, just handle things as if we were ffesta_zero
1557    and saw an EOS just before the two tokens.
1558
1559    If we're inhibited, set ffesta_current_shutdown_ to shut down the current
1560    statement and continue with other possibilities, then (presumably) come
1561    back to this one for real when not inhibited.  */
1562
1563 ffelexHandler
1564 ffesta_two (ffelexToken first, ffelexToken second)
1565 {
1566 #if FFESTA_ABORT_ON_CONFIRM_
1567   ffelexHandler next;
1568 #endif
1569
1570   assert ((ffelex_token_type (first) == FFELEX_typeNAME)
1571           || (ffelex_token_type (first) == FFELEX_typeNAMES));
1572   assert (ffesta_tokens[0] != NULL);
1573
1574   if (ffesta_is_inhibited_)     /* Oh, not really done with statement. */
1575     {
1576       ffesta_current_shutdown_ = TRUE;
1577       /* To catch the EOS on shutdown. */
1578       return (ffelexHandler) ffelex_swallow_tokens (second,
1579                                                (ffelexHandler) ffesta_zero);
1580     }
1581
1582   ffestw_display_state ();
1583
1584   ffelex_token_kill (ffesta_tokens[0]);
1585
1586   if (ffesta_output_pool != NULL)
1587     {
1588       if (ffesta_outpooldisp_ == FFESTA_pooldispDISCARD)
1589         malloc_pool_kill (ffesta_output_pool);
1590       ffesta_output_pool = NULL;
1591     }
1592
1593   if (ffesta_scratch_pool != NULL)
1594     {
1595       malloc_pool_kill (ffesta_scratch_pool);
1596       ffesta_scratch_pool = NULL;
1597     }
1598
1599   ffesta_reset_possibles_ ();
1600   ffesta_confirmed_current_ = FALSE;
1601
1602   /* What happens here is somewhat interesting.  We effectively derail the
1603      line of handlers for these two tokens, the first two in a statement, by
1604      setting a flag to TRUE.  This flag tells ffesta_save_ (or, conceivably,
1605      the lexer via ffesta_second_'s case 1:, where it has only one possible
1606      kind of statement -- someday this will be more likely, i.e. after
1607      confirmation causes an immediate switch to only the one context rather
1608      than just setting a flag and running through the remaining possibles to
1609      look for ambiguities) that the last two tokens it sent did not reach the
1610      truly desired targets (ffest_first and ffesta_second_) since that would
1611      otherwise attempt to recursively invoke ffesta_save_ in most cases,
1612      while the existing ffesta_save_ was still alive and making use of static
1613      (nonrecursive) variables.  Instead, ffesta_save_, upon seeing this flag
1614      set TRUE, sets it to FALSE and resubmits the two tokens copied here to
1615      ffest_first and, presumably, ffesta_second_, kills them, and returns the
1616      handler returned by the handler for the second token.  Thus, even though
1617      ffesta_save_ is still (likely to be) recursively invoked, the former
1618      invocation is past the use of any static variables possibly changed
1619      during the first-two-token invocation of the latter invocation. */
1620
1621 #if FFESTA_ABORT_ON_CONFIRM_
1622   /* Shouldn't be in ffesta_save_ at all here. */
1623
1624   next = (ffelexHandler) ffesta_first (first);
1625   return (ffelexHandler) (*next) (second);
1626 #else
1627   ffesta_twotokens_1_ = ffelex_token_use (first);
1628   ffesta_twotokens_2_ = ffelex_token_use (second);
1629
1630   ffesta_is_two_into_statement_ = TRUE;
1631   return (ffelexHandler) ffesta_send_two_;      /* Shouldn't get called. */
1632 #endif
1633 }
1634
1635 /* ffesta_zero -- Deal with the end of a swallowed statement
1636
1637    return ffesta_zero;  // to lexer.
1638
1639    NOTICE that this code is COPIED, largely, into a
1640    similar function named ffesta_two that gets invoked in place of
1641    _zero_ when the end of the statement happens before EOS or SEMICOLON and
1642    to tokens into the next statement have been read (as is the case with the
1643    logical-IF and WHERE-stmt statements).  So any changes made here should
1644    probably be made in _two_ at the same time.  */
1645
1646 ffelexHandler
1647 ffesta_zero (ffelexToken t)
1648 {
1649   assert ((ffelex_token_type (t) == FFELEX_typeEOS)
1650           || (ffelex_token_type (t) == FFELEX_typeSEMICOLON));
1651   assert (ffesta_tokens[0] != NULL);
1652
1653   if (ffesta_is_inhibited_)
1654     ffesymbol_retract (TRUE);
1655   else
1656     ffestw_display_state ();
1657
1658   /* Do CONTINUE if nothing else.  This is done specifically so that "IF
1659      (...) BLAH" causes the same things to happen as if "IF (...) CONTINUE"
1660      was done, so that tracking of labels and such works.  (Try a small
1661      program like "DO 10 ...", "IF (...) BLAH", "10 CONTINUE", "END".)
1662
1663      But it turns out that just testing "!ffesta_confirmed_current_"
1664      isn't enough, because then typing "GOTO" instead of "BLAH" above
1665      doesn't work -- the statement is confirmed (we know the user
1666      attempted a GOTO) but ffestc hasn't seen it.  So, instead, just
1667      always tell ffestc to do "any" statement it needs to reset.  */
1668
1669   if (!ffesta_is_inhibited_
1670       && ffesta_seen_first_exec)
1671     {
1672       ffestc_any ();
1673     }
1674
1675   ffelex_token_kill (ffesta_tokens[0]);
1676
1677   if (ffesta_is_inhibited_)     /* Oh, not really done with statement. */
1678     return (ffelexHandler) ffesta_zero; /* Call me again when done! */
1679
1680   if (ffesta_output_pool != NULL)
1681     {
1682       if (ffesta_outpooldisp_ == FFESTA_pooldispDISCARD)
1683         malloc_pool_kill (ffesta_output_pool);
1684       ffesta_output_pool = NULL;
1685     }
1686
1687   if (ffesta_scratch_pool != NULL)
1688     {
1689       malloc_pool_kill (ffesta_scratch_pool);
1690       ffesta_scratch_pool = NULL;
1691     }
1692
1693   ffesta_reset_possibles_ ();
1694   ffesta_confirmed_current_ = FALSE;
1695
1696   if (ffelex_token_type (t) == FFELEX_typeSEMICOLON)
1697     {
1698       ffesta_line_has_semicolons = TRUE;
1699       if (ffe_is_pedantic_not_90 ())
1700         {
1701           ffebad_start (FFEBAD_SEMICOLON);
1702           ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
1703           ffebad_finish ();
1704         }
1705     }
1706   else
1707     ffesta_line_has_semicolons = FALSE;
1708
1709   if (ffesta_label_token != NULL)
1710     {
1711       ffelex_token_kill (ffesta_label_token);
1712       ffesta_label_token = NULL;
1713     }
1714
1715   if (ffe_is_ffedebug ())
1716     {
1717       ffestorag_report ();
1718     }
1719
1720   ffelex_set_names (TRUE);
1721   return (ffelexHandler) ffesta_first;
1722 }