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