gcc/f/lex.c

   1 /* Implementation of Fortran lexer
   2    Copyright (C) 1995, 1996, 1997, 1998, 2001 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 #include "proj.h"
  23 #include "top.h"
  24 #include "bad.h"
  25 #include "com.h"
  26 #include "lex.h"
  27 #include "malloc.h"
  28 #include "src.h"
  29 #include "debug.h"
  30 #include "flags.h"
  31 #include "input.h"
  32 #include "toplev.h"
  33 #include "output.h"
  34 #include "ggc.h"
  35
  36 static void ffelex_append_to_token_ (char c);
  37 static int ffelex_backslash_ (int c, ffewhereColumnNumber col);
  38 static void ffelex_bad_1_ (ffebad errnum, ffewhereLineNumber ln0,
  39                            ffewhereColumnNumber cn0);
  40 static void ffelex_bad_2_ (ffebad errnum, ffewhereLineNumber ln0,
  41                            ffewhereColumnNumber cn0, ffewhereLineNumber ln1,
  42                            ffewhereColumnNumber cn1);
  43 static void ffelex_bad_here_ (int num, ffewhereLineNumber ln0,
  44                               ffewhereColumnNumber cn0);
  45 static void ffelex_finish_statement_ (void);
  46 static int ffelex_get_directive_line_ (char **text, FILE *finput);
  47 static int ffelex_hash_ (FILE *f);
  48 static ffewhereColumnNumber ffelex_image_char_ (int c,
  49                                                 ffewhereColumnNumber col);
  50 static void ffelex_include_ (void);
  51 static bool ffelex_is_free_char_ctx_contin_ (ffewhereColumnNumber col);
  52 static bool ffelex_is_free_nonc_ctx_contin_ (ffewhereColumnNumber col);
  53 static void ffelex_next_line_ (void);
  54 static void ffelex_prepare_eos_ (void);
  55 static void ffelex_send_token_ (void);
  56 static ffelexHandler ffelex_swallow_tokens_ (ffelexToken t);
  57 static ffelexToken ffelex_token_new_ (void);
  58
  59 /* Pertaining to the geometry of the input file.  */
  60
  61 /* Initial size for card image to be allocated.  */
  62 #define FFELEX_columnINITIAL_SIZE_ 255
  63
  64 /* The card image itself, which grows as source lines get longer.  It
  65    has room for ffelex_card_size_ + 8 characters, and the length of the
  66    current image is ffelex_card_length_.  (The + 8 characters are made
  67    available for easy handling of tabs and such.)  */
  68 static char *ffelex_card_image_;
  69 static ffewhereColumnNumber ffelex_card_size_;
  70 static ffewhereColumnNumber ffelex_card_length_;
  71
  72 /* Max width for free-form lines (ISO F90).  */
  73 #define FFELEX_FREE_MAX_COLUMNS_ 132
  74
  75 /* True if we saw a tab on the current line, as this (currently) means
  76    the line is therefore treated as though final_nontab_column_ were
  77    infinite.  */
  78 static bool ffelex_saw_tab_;
  79
  80 /* TRUE if current line is known to be erroneous, so don't bother
  81    expanding room for it just to display it.  */
  82 static bool ffelex_bad_line_ = FALSE;
  83
  84 /* Last column for vanilla, i.e. non-tabbed, line.  Usually 72 or 132. */
  85 static ffewhereColumnNumber ffelex_final_nontab_column_;
  86
  87 /* Array for quickly deciding what kind of line the current card has,
  88    based on its first character.  */
  89 static ffelexType ffelex_first_char_[256];
  90
  91 /* Pertaining to file management.  */
  92
  93 /* The wf argument of the most recent active ffelex_file_(fixed,free)
  94    function.  */
  95 static ffewhereFile ffelex_current_wf_;
  96
  97 /* TRUE if an INCLUDE statement can be processed (ffelex_set_include
  98    can be called).  */
  99 static bool ffelex_permit_include_;
 100
 101 /* TRUE if an INCLUDE statement is pending (ffelex_set_include has been
 102    called).  */
 103 static bool ffelex_set_include_;
 104
 105 /* Information on the pending INCLUDE file.  */
 106 static FILE *ffelex_include_file_;
 107 static bool ffelex_include_free_form_;
 108 static ffewhereFile ffelex_include_wherefile_;
 109
 110 /* Current master line count.  */
 111 static ffewhereLineNumber ffelex_linecount_current_;
 112 /* Next master line count.  */
 113 static ffewhereLineNumber ffelex_linecount_next_;
 114
 115 /* ffewhere info on the latest (currently active) line read from the
 116    active source file.  */
 117 static ffewhereLine ffelex_current_wl_;
 118 static ffewhereColumn ffelex_current_wc_;
 119
 120 /* Pertaining to tokens in general.  */
 121
 122 /* Initial capacity for text in a CHARACTER/HOLLERITH/NAME/NAMES/NUMBER
 123    token.  */
 124 #define FFELEX_columnTOKEN_SIZE_ 63
 125 #if FFELEX_columnTOKEN_SIZE_ < FFEWHERE_indexMAX
 126 #error "token size too small!"
 127 #endif
 128
 129 /* Current token being lexed.  */
 130 static ffelexToken ffelex_token_;
 131
 132 /* Handler for current token.  */
 133 static ffelexHandler ffelex_handler_;
 134
 135 /* TRUE if fixed-form lexer is to generate NAMES instead of NAME tokens.  */
 136 static bool ffelex_names_;
 137
 138 /* TRUE if both lexers are to generate NAMES instead of NAME tokens.  */
 139 static bool ffelex_names_pure_;
 140
 141 /* TRUE if 0-9 starts a NAME token instead of NUMBER, for parsing hex
 142    numbers.  */
 143 static bool ffelex_hexnum_;
 144
 145 /* For ffelex_swallow_tokens().  */
 146 static ffelexHandler ffelex_eos_handler_;
 147
 148 /* Number of tokens sent since last EOS or beginning of input file
 149    (include INCLUDEd files).  */
 150 static unsigned long int ffelex_number_of_tokens_;
 151
 152 /* Number of labels sent (as NUMBER tokens) since last reset of
 153    ffelex_number_of_tokens_ to 0, should be 0 or 1 in most cases.
 154    (Fixed-form source only.)  */
 155 static unsigned long int ffelex_label_tokens_;
 156
 157 /* Metering for token management, to catch token-memory leaks.  */
 158 static long int ffelex_total_tokens_ = 0;
 159 static long int ffelex_old_total_tokens_ = 1;
 160 static long int ffelex_token_nextid_ = 0;
 161
 162 /* Pertaining to lexing CHARACTER and HOLLERITH tokens.  */
 163
 164 /* >0 if a Hollerith constant of that length might be in mid-lex, used
 165    when the next character seen is 'H' or 'h' to enter HOLLERITH lexing
 166    mode (see ffelex_raw_mode_).  */
 167 static long int ffelex_expecting_hollerith_;
 168
 169 /* -3: Backslash (escape) sequence being lexed in CHARACTER.
 170    -2: Possible closing apostrophe/quote seen in CHARACTER.
 171    -1: Lexing CHARACTER.
 172     0: Not lexing CHARACTER or HOLLERITH.
 173    >0: Lexing HOLLERITH, value is # chars remaining to expect.  */
 174 static long int ffelex_raw_mode_;
 175
 176 /* When lexing CHARACTER, open quote/apostrophe (either ' or ").  */
 177 static char ffelex_raw_char_;
 178
 179 /* TRUE when backslash processing had to use most recent character
 180    to finish its state engine, but that character is not part of
 181    the backslash sequence, so must be reconsidered as a "normal"
 182    character in CHARACTER/HOLLERITH lexing.  */
 183 static bool ffelex_backslash_reconsider_ = FALSE;
 184
 185 /* Characters preread before lexing happened (might include EOF).  */
 186 static int *ffelex_kludge_chars_ = NULL;
 187
 188 /* Doing the kludge processing, so not initialized yet.  */
 189 static bool ffelex_kludge_flag_ = FALSE;
 190
 191 /* The beginning of a (possible) CHARACTER/HOLLERITH token.  */
 192 static ffewhereLine ffelex_raw_where_line_;
 193 static ffewhereColumn ffelex_raw_where_col_;
 194 \f
 195
 196 /* Call this to append another character to the current token.  If it isn't
 197    currently big enough for it, it will be enlarged.  The current token
 198    must be a CHARACTER, HOLLERITH, NAME, NAMES, or NUMBER.  */
 199
 200 static void
 201 ffelex_append_to_token_ (char c)
 202 {
 203   if (ffelex_token_->text == NULL)
 204     {
 205       ffelex_token_->text
 206         = malloc_new_ksr (malloc_pool_image (), "FFELEX token text",
 207                           FFELEX_columnTOKEN_SIZE_ + 1);
 208       ffelex_token_->size = FFELEX_columnTOKEN_SIZE_;
 209       ffelex_token_->length = 0;
 210     }
 211   else if (ffelex_token_->length >= ffelex_token_->size)
 212     {
 213       ffelex_token_->text
 214         = malloc_resize_ksr (malloc_pool_image (),
 215                              ffelex_token_->text,
 216                              (ffelex_token_->size << 1) + 1,
 217                              ffelex_token_->size + 1);
 218       ffelex_token_->size <<= 1;
 219       assert (ffelex_token_->length < ffelex_token_->size);
 220     }
 221 #ifdef MAP_CHARACTER
 222 Sorry, MAP_CHARACTER is not going to work as expected in GNU Fortran,
 223 please contact fortran@gnu.org if you wish to fund work to
 224 port g77 to non-ASCII machines.
 225 #endif
 226   ffelex_token_->text[ffelex_token_->length++] = c;
 227 }
 228
 229 /* Do backslash (escape) processing for a CHARACTER/HOLLERITH token
 230    being lexed.  */
 231
 232 static int
 233 ffelex_backslash_ (int c, ffewhereColumnNumber col)
 234 {
 235   static int state = 0;
 236   static unsigned int count;
 237   static int code;
 238   static unsigned int firstdig = 0;
 239   static int nonnull;
 240   static ffewhereLineNumber line;
 241   static ffewhereColumnNumber column;
 242
 243   /* See gcc/c-lex.c readescape() for a straightforward version
 244      of this state engine for handling backslashes in character/
 245      hollerith constants.  */
 246
 247 #define wide_flag 0
 248 #define warn_traditional 0
 249 #define flag_traditional 0
 250
 251   switch (state)
 252     {
 253     case 0:
 254       if ((c == '\\')
 255           && (ffelex_raw_mode_ != 0)
 256           && ffe_is_backslash ())
 257         {
 258           state = 1;
 259           column = col + 1;
 260           line = ffelex_linecount_current_;
 261           return EOF;
 262         }
 263       return c;
 264
 265     case 1:
 266       state = 0;                /* Assume simple case. */
 267       switch (c)
 268         {
 269         case 'x':
 270           if (warn_traditional)
 271             {
 272               ffebad_start_msg_lex ("The meaning of `\\x' (at %0) varies with -traditional",
 273                                     FFEBAD_severityWARNING);
 274               ffelex_bad_here_ (0, line, column);
 275               ffebad_finish ();
 276             }
 277
 278           if (flag_traditional)
 279             return c;
 280
 281           code = 0;
 282           count = 0;
 283           nonnull = 0;
 284           state = 2;
 285           return EOF;
 286
 287         case '0':  case '1':  case '2':  case '3':  case '4':
 288         case '5':  case '6':  case '7':
 289           code = c - '0';
 290           count = 1;
 291           state = 3;
 292           return EOF;
 293
 294         case '\\': case '\'': case '"':
 295           return c;
 296
 297 #if 0   /* Inappropriate for Fortran. */
 298         case '\n':
 299           ffelex_next_line_ ();
 300           *ignore_ptr = 1;
 301           return 0;
 302 #endif
 303
 304         case 'n':
 305           return TARGET_NEWLINE;
 306
 307         case 't':
 308           return TARGET_TAB;
 309
 310         case 'r':
 311           return TARGET_CR;
 312
 313         case 'f':
 314           return TARGET_FF;
 315
 316         case 'b':
 317           return TARGET_BS;
 318
 319         case 'a':
 320           if (warn_traditional)
 321             {
 322               ffebad_start_msg_lex ("The meaning of `\\a' (at %0) varies with -traditional",
 323                                     FFEBAD_severityWARNING);
 324               ffelex_bad_here_ (0, line, column);
 325               ffebad_finish ();
 326             }
 327
 328           if (flag_traditional)
 329             return c;
 330           return TARGET_BELL;
 331
 332         case 'v':
 333 #if 0 /* Vertical tab is present in common usage compilers.  */
 334           if (flag_traditional)
 335             return c;
 336 #endif
 337           return TARGET_VT;
 338
 339         case 'e':
 340         case 'E':
 341         case '(':
 342         case '{':
 343         case '[':
 344         case '%':
 345           if (pedantic)
 346             {
 347               char m[2];
 348
 349               m[0] = c;
 350               m[1] = '\0';
 351               ffebad_start_msg_lex ("Non-ISO-C-standard escape sequence `\\%A' at %0",
 352                                     FFEBAD_severityPEDANTIC);
 353               ffelex_bad_here_ (0, line, column);
 354               ffebad_string (m);
 355               ffebad_finish ();
 356             }
 357           return (c == 'E' || c == 'e') ? 033 : c;
 358
 359         case '?':
 360           return c;
 361
 362         default:
 363           if (c >= 040 && c < 0177)
 364             {
 365               char m[2];
 366
 367               m[0] = c;
 368               m[1] = '\0';
 369               ffebad_start_msg_lex ("Unknown escape sequence `\\%A' at %0",
 370                                     FFEBAD_severityPEDANTIC);
 371               ffelex_bad_here_ (0, line, column);
 372               ffebad_string (m);
 373               ffebad_finish ();
 374             }
 375           else if (c == EOF)
 376             {
 377               ffebad_start_msg_lex ("Unterminated escape sequence `\\' at %0",
 378                                     FFEBAD_severityPEDANTIC);
 379               ffelex_bad_here_ (0, line, column);
 380               ffebad_finish ();
 381             }
 382           else
 383             {
 384               char m[20];
 385
 386               sprintf (&m[0], "%x", c);
 387               ffebad_start_msg_lex ("Unknown escape sequence `\\' followed by char code 0x%A at %0",
 388                                     FFEBAD_severityPEDANTIC);
 389               ffelex_bad_here_ (0, line, column);
 390               ffebad_string (m);
 391               ffebad_finish ();
 392             }
 393         }
 394       return c;
 395
 396     case 2:
 397       if (ISXDIGIT (c))
 398         {
 399           code = (code * 16) + hex_value (c);
 400           if (code != 0 || count != 0)
 401             {
 402               if (count == 0)
 403                 firstdig = code;
 404               count++;
 405             }
 406           nonnull = 1;
 407           return EOF;
 408         }
 409
 410       state = 0;
 411
 412       if (! nonnull)
 413         {
 414           ffebad_start_msg_lex ("\\x used at %0 with no following hex digits",
 415                                 FFEBAD_severityFATAL);
 416           ffelex_bad_here_ (0, line, column);
 417           ffebad_finish ();
 418         }
 419       else if (count == 0)
 420         /* Digits are all 0's.  Ok.  */
 421         ;
 422       else if ((count - 1) * 4 >= TYPE_PRECISION (integer_type_node)
 423                || (count > 1
 424                    && ((1 << (TYPE_PRECISION (integer_type_node) - (count - 1) * 4))
 425                        <= (int) firstdig)))
 426         {
 427           ffebad_start_msg_lex ("Hex escape at %0 out of range",
 428                                 FFEBAD_severityPEDANTIC);
 429           ffelex_bad_here_ (0, line, column);
 430           ffebad_finish ();
 431         }
 432       break;
 433
 434     case 3:
 435       if ((c <= '7') && (c >= '0') && (count++ < 3))
 436         {
 437           code = (code * 8) + (c - '0');
 438           return EOF;
 439         }
 440       state = 0;
 441       break;
 442
 443     default:
 444       assert ("bad backslash state" == NULL);
 445       abort ();
 446     }
 447
 448   /* Come here when code has a built character, and c is the next
 449      character that might (or might not) be the next one in the constant.  */
 450
 451   /* Don't bother doing this check for each character going into
 452      CHARACTER or HOLLERITH constants, just the escaped-value ones.
 453      gcc apparently checks every single character, which seems
 454      like it'd be kinda slow and not worth doing anyway.  */
 455
 456   if (!wide_flag
 457       && TYPE_PRECISION (char_type_node) < HOST_BITS_PER_INT
 458       && code >= (1 << TYPE_PRECISION (char_type_node)))
 459     {
 460       ffebad_start_msg_lex ("Escape sequence at %0 out of range for character",
 461                             FFEBAD_severityFATAL);
 462       ffelex_bad_here_ (0, line, column);
 463       ffebad_finish ();
 464     }
 465
 466   if (c == EOF)
 467     {
 468       /* Known end of constant, just append this character.  */
 469       ffelex_append_to_token_ (code);
 470       if (ffelex_raw_mode_ > 0)
 471         --ffelex_raw_mode_;
 472       return EOF;
 473     }
 474
 475   /* Have two characters to handle.  Do the first, then leave it to the
 476      caller to detect anything special about the second.  */
 477
 478   ffelex_append_to_token_ (code);
 479   if (ffelex_raw_mode_ > 0)
 480     --ffelex_raw_mode_;
 481   ffelex_backslash_reconsider_ = TRUE;
 482   return c;
 483 }
 484
 485 /* ffelex_bad_1_ -- Issue diagnostic with one source point
 486
 487    ffelex_bad_1_(FFEBAD_SOME_ERROR,ffelex_linecount_current_,column + 1);
 488
 489    Creates ffewhere line and column objects for the source point, sends them
 490    along with the error code to ffebad, then kills the line and column
 491    objects before returning.  */
 492
 493 static void
 494 ffelex_bad_1_ (ffebad errnum, ffewhereLineNumber ln0, ffewhereColumnNumber cn0)
 495 {
 496   ffewhereLine wl0;
 497   ffewhereColumn wc0;
 498
 499   wl0 = ffewhere_line_new (ln0);
 500   wc0 = ffewhere_column_new (cn0);
 501   ffebad_start_lex (errnum);
 502   ffebad_here (0, wl0, wc0);
 503   ffebad_finish ();
 504   ffewhere_line_kill (wl0);
 505   ffewhere_column_kill (wc0);
 506 }
 507
 508 /* ffelex_bad_2_ -- Issue diagnostic with two source points
 509
 510    ffelex_bad_2_(FFEBAD_SOME_ERROR,ffelex_linecount_current_,column + 1,
 511          otherline,othercolumn);
 512
 513    Creates ffewhere line and column objects for the source points, sends them
 514    along with the error code to ffebad, then kills the line and column
 515    objects before returning.  */
 516
 517 static void
 518 ffelex_bad_2_ (ffebad errnum, ffewhereLineNumber ln0, ffewhereColumnNumber cn0,
 519                ffewhereLineNumber ln1, ffewhereColumnNumber cn1)
 520 {
 521   ffewhereLine wl0, wl1;
 522   ffewhereColumn wc0, wc1;
 523
 524   wl0 = ffewhere_line_new (ln0);
 525   wc0 = ffewhere_column_new (cn0);
 526   wl1 = ffewhere_line_new (ln1);
 527   wc1 = ffewhere_column_new (cn1);
 528   ffebad_start_lex (errnum);
 529   ffebad_here (0, wl0, wc0);
 530   ffebad_here (1, wl1, wc1);
 531   ffebad_finish ();
 532   ffewhere_line_kill (wl0);
 533   ffewhere_column_kill (wc0);
 534   ffewhere_line_kill (wl1);
 535   ffewhere_column_kill (wc1);
 536 }
 537
 538 static void
 539 ffelex_bad_here_ (int n, ffewhereLineNumber ln0,
 540                   ffewhereColumnNumber cn0)
 541 {
 542   ffewhereLine wl0;
 543   ffewhereColumn wc0;
 544
 545   wl0 = ffewhere_line_new (ln0);
 546   wc0 = ffewhere_column_new (cn0);
 547   ffebad_here (n, wl0, wc0);
 548   ffewhere_line_kill (wl0);
 549   ffewhere_column_kill (wc0);
 550 }
 551
 552 static int
 553 ffelex_getc_ (FILE *finput)
 554 {
 555   int c;
 556
 557   if (ffelex_kludge_chars_ == NULL)
 558     return getc (finput);
 559
 560   c = *ffelex_kludge_chars_++;
 561   if (c != 0)
 562     return c;
 563
 564   ffelex_kludge_chars_ = NULL;
 565   return getc (finput);
 566 }
 567
 568 static int
 569 ffelex_cfebackslash_ (int *use_d, int *d, FILE *finput)
 570 {
 571   register int c = getc (finput);
 572   register int code;
 573   register unsigned count;
 574   unsigned firstdig = 0;
 575   int nonnull;
 576
 577   *use_d = 0;
 578
 579   switch (c)
 580     {
 581     case 'x':
 582       if (warn_traditional)
 583         warning ("the meaning of `\\x' varies with -traditional");
 584
 585       if (flag_traditional)
 586         return c;
 587
 588       code = 0;
 589       count = 0;
 590       nonnull = 0;
 591       while (1)
 592         {
 593           c = getc (finput);
 594           if (! ISXDIGIT (c))
 595             {
 596               *use_d = 1;
 597               *d = c;
 598               break;
 599             }
 600           code = (code * 16) + hex_value (c);
 601           if (code != 0 || count != 0)
 602             {
 603               if (count == 0)
 604                 firstdig = code;
 605               count++;
 606             }
 607           nonnull = 1;
 608         }
 609       if (! nonnull)
 610         error ("\\x used with no following hex digits");
 611       else if (count == 0)
 612         /* Digits are all 0's.  Ok.  */
 613         ;
 614       else if ((count - 1) * 4 >= TYPE_PRECISION (integer_type_node)
 615                || (count > 1
 616                    && (((unsigned) 1
 617                         << (TYPE_PRECISION (integer_type_node) - (count - 1)
 618                             * 4))
 619                        <= firstdig)))
 620         pedwarn ("hex escape out of range");
 621       return code;
 622
 623     case '0':  case '1':  case '2':  case '3':  case '4':
 624     case '5':  case '6':  case '7':
 625       code = 0;
 626       count = 0;
 627       while ((c <= '7') && (c >= '0') && (count++ < 3))
 628         {
 629           code = (code * 8) + (c - '0');
 630           c = getc (finput);
 631         }
 632       *use_d = 1;
 633       *d = c;
 634       return code;
 635
 636     case '\\': case '\'': case '"':
 637       return c;
 638
 639     case '\n':
 640       ffelex_next_line_ ();
 641       *use_d = 2;
 642       return 0;
 643
 644     case EOF:
 645       *use_d = 1;
 646       *d = EOF;
 647       return EOF;
 648
 649     case 'n':
 650       return TARGET_NEWLINE;
 651
 652     case 't':
 653       return TARGET_TAB;
 654
 655     case 'r':
 656       return TARGET_CR;
 657
 658     case 'f':
 659       return TARGET_FF;
 660
 661     case 'b':
 662       return TARGET_BS;
 663
 664     case 'a':
 665       if (warn_traditional)
 666         warning ("the meaning of `\\a' varies with -traditional");
 667
 668       if (flag_traditional)
 669         return c;
 670       return TARGET_BELL;
 671
 672     case 'v':
 673 #if 0 /* Vertical tab is present in common usage compilers.  */
 674       if (flag_traditional)
 675         return c;
 676 #endif
 677       return TARGET_VT;
 678
 679     case 'e':
 680     case 'E':
 681       if (pedantic)
 682         pedwarn ("non-ANSI-standard escape sequence, `\\%c'", c);
 683       return 033;
 684
 685     case '?':
 686       return c;
 687
 688       /* `\(', etc, are used at beginning of line to avoid confusing Emacs.  */
 689     case '(':
 690     case '{':
 691     case '[':
 692       /* `\%' is used to prevent SCCS from getting confused.  */
 693     case '%':
 694       if (pedantic)
 695         pedwarn ("non-ISO escape sequence `\\%c'", c);
 696       return c;
 697     }
 698   if (c >= 040 && c < 0177)
 699     pedwarn ("unknown escape sequence `\\%c'", c);
 700   else
 701     pedwarn ("unknown escape sequence: `\\' followed by char code 0x%x", c);
 702   return c;
 703 }
 704
 705 /* A miniature version of the C front-end lexer.  */
 706
 707 static int
 708 ffelex_cfelex_ (ffelexToken *xtoken, FILE *finput, int c)
 709 {
 710   ffelexToken token;
 711   char buff[129];
 712   char *p;
 713   char *q;
 714   char *r;
 715   register unsigned buffer_length;
 716
 717   if ((*xtoken != NULL) && !ffelex_kludge_flag_)
 718     ffelex_token_kill (*xtoken);
 719
 720   switch (c)
 721     {
 722     case '0': case '1': case '2': case '3': case '4':
 723     case '5': case '6': case '7': case '8': case '9':
 724       buffer_length = ARRAY_SIZE (buff);
 725       p = &buff[0];
 726       q = p;
 727       r = &buff[buffer_length];
 728       for (;;)
 729         {
 730           *p++ = c;
 731           if (p >= r)
 732             {
 733               register unsigned bytes_used = (p - q);
 734
 735               buffer_length *= 2;
 736               q = (char *)xrealloc (q, buffer_length);
 737               p = &q[bytes_used];
 738               r = &q[buffer_length];
 739             }
 740           c = ffelex_getc_ (finput);
 741           if (! ISDIGIT (c))
 742             break;
 743         }
 744       *p = '\0';
 745       token = ffelex_token_new_number (q, ffewhere_line_unknown (),
 746                                        ffewhere_column_unknown ());
 747
 748       if (q != &buff[0])
 749         free (q);
 750
 751       break;
 752
 753     case '\"':
 754       buffer_length = ARRAY_SIZE (buff);
 755       p = &buff[0];
 756       q = p;
 757       r = &buff[buffer_length];
 758       c = ffelex_getc_ (finput);
 759       for (;;)
 760         {
 761           bool done = FALSE;
 762           int use_d = 0;
 763           int d;
 764
 765           switch (c)
 766             {
 767             case '\"':
 768               c = getc (finput);
 769               done = TRUE;
 770               break;
 771
 772             case '\\':          /* ~~~~~ */
 773               c = ffelex_cfebackslash_ (&use_d, &d, finput);
 774               break;
 775
 776             case EOF:
 777             case '\n':
 778               error ("badly formed directive -- no closing quote");
 779               done = TRUE;
 780               break;
 781
 782             default:
 783               break;
 784             }
 785           if (done)
 786             break;
 787
 788           if (use_d != 2)       /* 0=>c, 1=>cd, 2=>nil. */
 789             {
 790               *p++ = c;
 791               if (p >= r)
 792                 {
 793                   register unsigned bytes_used = (p - q);
 794
 795                   buffer_length = bytes_used * 2;
 796                   q = (char *)xrealloc (q, buffer_length);
 797                   p = &q[bytes_used];
 798                   r = &q[buffer_length];
 799                 }
 800             }
 801           if (use_d == 1)
 802             c = d;
 803           else
 804             c = getc (finput);
 805         }
 806       *p = '\0';
 807       token = ffelex_token_new_character (q, ffewhere_line_unknown (),
 808                                           ffewhere_column_unknown ());
 809
 810       if (q != &buff[0])
 811         free (q);
 812
 813       break;
 814
 815     default:
 816       token = NULL;
 817       break;
 818     }
 819
 820   *xtoken = token;
 821   return c;
 822 }
 823
 824 static void
 825 ffelex_file_pop_ (const char *input_filename)
 826 {
 827   if (input_file_stack->next)
 828     {
 829       struct file_stack *p = input_file_stack;
 830       input_file_stack = p->next;
 831       free (p);
 832       input_file_stack_tick++;
 833       (*debug_hooks->end_source_file) (input_file_stack->line);
 834     }
 835   else
 836     error ("#-lines for entering and leaving files don't match");
 837
 838   /* Now that we've pushed or popped the input stack,
 839      update the name in the top element.  */
 840   if (input_file_stack)
 841     input_file_stack->name = input_filename;
 842 }
 843
 844 static void
 845 ffelex_file_push_ (int old_lineno, const char *input_filename)
 846 {
 847   struct file_stack *p
 848     = (struct file_stack *) xmalloc (sizeof (struct file_stack));
 849
 850   input_file_stack->line = old_lineno;
 851   p->next = input_file_stack;
 852   p->name = input_filename;
 853   input_file_stack = p;
 854   input_file_stack_tick++;
 855
 856   (*debug_hooks->start_source_file) (0, input_filename);
 857
 858   /* Now that we've pushed or popped the input stack,
 859      update the name in the top element.  */
 860   if (input_file_stack)
 861     input_file_stack->name = input_filename;
 862 }
 863
 864 /* Prepare to finish a statement-in-progress by sending the current
 865    token, if any, then setting up EOS as the current token with the
 866    appropriate current pointer.  The caller can then move the current
 867    pointer before actually sending EOS, if desired, as it is in
 868    typical fixed-form cases.  */
 869
 870 static void
 871 ffelex_prepare_eos_ ()
 872 {
 873   if (ffelex_token_->type != FFELEX_typeNONE)
 874     {
 875       ffelex_backslash_ (EOF, 0);
 876
 877       switch (ffelex_raw_mode_)
 878         {
 879         case -2:
 880           break;
 881
 882         case -1:
 883           ffebad_start_lex ((ffelex_raw_char_ == '\'') ? FFEBAD_NO_CLOSING_APOSTROPHE
 884                             : FFEBAD_NO_CLOSING_QUOTE);
 885           ffebad_here (0, ffelex_token_->where_line, ffelex_token_->where_col);
 886           ffebad_here (1, ffelex_current_wl_, ffelex_current_wc_);
 887           ffebad_finish ();
 888           break;
 889
 890         case 0:
 891           break;
 892
 893         default:
 894           {
 895             char num[20];
 896
 897             ffebad_start_lex (FFEBAD_NOT_ENOUGH_HOLLERITH_CHARS);
 898             ffebad_here (0, ffelex_token_->where_line, ffelex_token_->where_col);
 899             ffebad_here (1, ffelex_current_wl_, ffelex_current_wc_);
 900             sprintf (num, "%lu", (unsigned long) ffelex_raw_mode_);
 901             ffebad_string (num);
 902             ffebad_finish ();
 903             /* Make sure the token has some text, might as well fill up with spaces.  */
 904             do
 905               {
 906                 ffelex_append_to_token_ (' ');
 907               } while (--ffelex_raw_mode_ > 0);
 908             break;
 909           }
 910         }
 911       ffelex_raw_mode_ = 0;
 912       ffelex_send_token_ ();
 913     }
 914   ffelex_token_->type = FFELEX_typeEOS;
 915   ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
 916   ffelex_token_->where_col = ffewhere_column_use (ffelex_current_wc_);
 917 }
 918
 919 static void
 920 ffelex_finish_statement_ ()
 921 {
 922   if ((ffelex_number_of_tokens_ == 0)
 923       && (ffelex_token_->type == FFELEX_typeNONE))
 924     return;                     /* Don't have a statement pending. */
 925
 926   if (ffelex_token_->type != FFELEX_typeEOS)
 927     ffelex_prepare_eos_ ();
 928
 929   ffelex_permit_include_ = TRUE;
 930   ffelex_send_token_ ();
 931   ffelex_permit_include_ = FALSE;
 932   ffelex_number_of_tokens_ = 0;
 933   ffelex_label_tokens_ = 0;
 934   ffelex_names_ = TRUE;
 935   ffelex_names_pure_ = FALSE;   /* Probably not necessary. */
 936   ffelex_hexnum_ = FALSE;
 937
 938   if (!ffe_is_ffedebug ())
 939     return;
 940
 941   /* For debugging purposes only. */
 942
 943   if (ffelex_total_tokens_ != ffelex_old_total_tokens_)
 944     {
 945       fprintf (dmpout, "; token_track had %ld tokens, now have %ld.\n",
 946                ffelex_old_total_tokens_, ffelex_total_tokens_);
 947       ffelex_old_total_tokens_ = ffelex_total_tokens_;
 948     }
 949 }
 950
 951 /* Copied from gcc/c-common.c get_directive_line.  */
 952
 953 static int
 954 ffelex_get_directive_line_ (char **text, FILE *finput)
 955 {
 956   static char *directive_buffer = NULL;
 957   static unsigned buffer_length = 0;
 958   register char *p;
 959   register char *buffer_limit;
 960   register int looking_for = 0;
 961   register int char_escaped = 0;
 962
 963   if (buffer_length == 0)
 964     {
 965       directive_buffer = (char *)xmalloc (128);
 966       buffer_length = 128;
 967     }
 968
 969   buffer_limit = &directive_buffer[buffer_length];
 970
 971   for (p = directive_buffer; ; )
 972     {
 973       int c;
 974
 975       /* Make buffer bigger if it is full.  */
 976       if (p >= buffer_limit)
 977         {
 978           register unsigned bytes_used = (p - directive_buffer);
 979
 980           buffer_length *= 2;
 981           directive_buffer
 982             = (char *)xrealloc (directive_buffer, buffer_length);
 983           p = &directive_buffer[bytes_used];
 984           buffer_limit = &directive_buffer[buffer_length];
 985         }
 986
 987       c = getc (finput);
 988
 989       /* Discard initial whitespace.  */
 990       if ((c == ' ' || c == '\t') && p == directive_buffer)
 991         continue;
 992
 993       /* Detect the end of the directive.  */
 994       if ((c == '\n' && looking_for == 0)
 995           || c == EOF)
 996         {
 997           if (looking_for != 0)
 998             error ("bad directive -- missing close-quote");
 999
1000           *p++ = '\0';
1001           *text = directive_buffer;
1002           return c;
1003         }
1004
1005       *p++ = c;
1006       if (c == '\n')
1007         ffelex_next_line_ ();
1008
1009       /* Handle string and character constant syntax.  */
1010       if (looking_for)
1011         {
1012           if (looking_for == c && !char_escaped)
1013             looking_for = 0;    /* Found terminator... stop looking.  */
1014         }
1015       else
1016         if (c == '\'' || c == '"')
1017           looking_for = c;      /* Don't stop buffering until we see another
1018                                    one of these (or an EOF).  */
1019
1020       /* Handle backslash.  */
1021       char_escaped = (c == '\\' && ! char_escaped);
1022     }
1023 }
1024
1025 /* Handle # directives that make it through (or are generated by) the
1026    preprocessor.  As much as reasonably possible, emulate the behavior
1027    of the gcc compiler phase cc1, though interactions between #include
1028    and INCLUDE might possibly produce bizarre results in terms of
1029    error reporting and the generation of debugging info vis-a-vis the
1030    locations of some things.
1031
1032    Returns the next character unhandled, which is always newline or EOF.  */
1033
1034 #if defined HANDLE_PRAGMA
1035 /* Local versions of these macros, that can be passed as function pointers.  */
1036 static int
1037 pragma_getc ()
1038 {
1039   return getc (finput);
1040 }
1041
1042 static void
1043 pragma_ungetc (arg)
1044      int arg;
1045 {
1046   ungetc (arg, finput);
1047 }
1048 #endif /* HANDLE_PRAGMA */
1049
1050 static int
1051 ffelex_hash_ (FILE *finput)
1052 {
1053   register int c;
1054   ffelexToken token = NULL;
1055
1056   /* Read first nonwhite char after the `#'.  */
1057
1058   c = ffelex_getc_ (finput);
1059   while (c == ' ' || c == '\t')
1060     c = ffelex_getc_ (finput);
1061
1062   /* If a letter follows, then if the word here is `line', skip
1063      it and ignore it; otherwise, ignore the line, with an error
1064      if the word isn't `pragma', `ident', `define', or `undef'.  */
1065
1066   if (ISALPHA(c))
1067     {
1068       if (c == 'p')
1069         {
1070           if (getc (finput) == 'r'
1071               && getc (finput) == 'a'
1072               && getc (finput) == 'g'
1073               && getc (finput) == 'm'
1074               && getc (finput) == 'a'
1075               && ((c = getc (finput)) == ' ' || c == '\t' || c == '\n'
1076                   || c == EOF))
1077             {
1078 #if 0   /* g77 doesn't handle pragmas, so ignores them FOR NOW. */
1079               static char buffer [128];
1080               char * buff = buffer;
1081
1082               /* Read the pragma name into a buffer.
1083                  ISSPACE() may evaluate its argument more than once!  */
1084               while (((c = getc (finput)), ISSPACE(c)))
1085                 continue;
1086
1087               do
1088                 {
1089                   * buff ++ = c;
1090                   c = getc (finput);
1091                 }
1092               while (c != EOF && ! ISSPACE (c) && c != '\n'
1093                      && buff < buffer + 128);
1094
1095               pragma_ungetc (c);
1096
1097               * -- buff = 0;
1098 #ifdef HANDLE_PRAGMA
1099               if (HANDLE_PRAGMA (pragma_getc, pragma_ungetc, buffer))
1100                 goto skipline;
1101 #endif /* HANDLE_PRAGMA */
1102 #ifdef HANDLE_GENERIC_PRAGMAS
1103               if (handle_generic_pragma (buffer))
1104                 goto skipline;
1105 #endif /* !HANDLE_GENERIC_PRAGMAS */
1106
1107               /* Issue a warning message if we have been asked to do so.
1108                  Ignoring unknown pragmas in system header file unless
1109                  an explcit -Wunknown-pragmas has been given. */
1110               if (warn_unknown_pragmas > 1
1111                   || (warn_unknown_pragmas && ! in_system_header))
1112                 warning ("ignoring pragma: %s", token_buffer);
1113 #endif /* 0 */
1114               goto skipline;
1115             }
1116         }
1117
1118       else if (c == 'd')
1119         {
1120           if (getc (finput) == 'e'
1121               && getc (finput) == 'f'
1122               && getc (finput) == 'i'
1123               && getc (finput) == 'n'
1124               && getc (finput) == 'e'
1125               && ((c = getc (finput)) == ' ' || c == '\t' || c == '\n'
1126                   || c == EOF))
1127             {
1128               char *text;
1129
1130               c = ffelex_get_directive_line_ (&text, finput);
1131
1132               if (debug_info_level == DINFO_LEVEL_VERBOSE)
1133                 (*debug_hooks->define) (lineno, text);
1134
1135               goto skipline;
1136             }
1137         }
1138       else if (c == 'u')
1139         {
1140           if (getc (finput) == 'n'
1141               && getc (finput) == 'd'
1142               && getc (finput) == 'e'
1143               && getc (finput) == 'f'
1144               && ((c = getc (finput)) == ' ' || c == '\t' || c == '\n'
1145                   || c == EOF))
1146             {
1147               char *text;
1148
1149               c = ffelex_get_directive_line_ (&text, finput);
1150
1151               if (debug_info_level == DINFO_LEVEL_VERBOSE)
1152                 (*debug_hooks->undef) (lineno, text);
1153
1154               goto skipline;
1155             }
1156         }
1157       else if (c == 'l')
1158         {
1159           if (getc (finput) == 'i'
1160               && getc (finput) == 'n'
1161               && getc (finput) == 'e'
1162               && ((c = getc (finput)) == ' ' || c == '\t'))
1163             goto linenum;
1164         }
1165       else if (c == 'i')
1166         {
1167           if (getc (finput) == 'd'
1168               && getc (finput) == 'e'
1169               && getc (finput) == 'n'
1170               && getc (finput) == 't'
1171               && ((c = getc (finput)) == ' ' || c == '\t'))
1172             {
1173               /* #ident.  The pedantic warning is now in cpp.  */
1174
1175               /* Here we have just seen `#ident '.
1176                  A string constant should follow.  */
1177
1178               while (c == ' ' || c == '\t')
1179                 c = getc (finput);
1180
1181               /* If no argument, ignore the line.  */
1182               if (c == '\n' || c == EOF)
1183                 return c;
1184
1185               c = ffelex_cfelex_ (&token, finput, c);
1186
1187               if ((token == NULL)
1188                   || (ffelex_token_type (token) != FFELEX_typeCHARACTER))
1189                 {
1190                   error ("invalid #ident");
1191                   goto skipline;
1192                 }
1193
1194               if (! flag_no_ident)
1195                 {
1196 #ifdef ASM_OUTPUT_IDENT
1197                   ASM_OUTPUT_IDENT (asm_out_file,
1198                                     ffelex_token_text (token));
1199 #endif
1200                 }
1201
1202               /* Skip the rest of this line.  */
1203               goto skipline;
1204             }
1205         }
1206
1207       error ("undefined or invalid # directive");
1208       goto skipline;
1209     }
1210
1211  linenum:
1212   /* Here we have either `#line' or `# <nonletter>'.
1213      In either case, it should be a line number; a digit should follow.  */
1214
1215   while (c == ' ' || c == '\t')
1216     c = ffelex_getc_ (finput);
1217
1218   /* If the # is the only nonwhite char on the line,
1219      just ignore it.  Check the new newline.  */
1220   if (c == '\n' || c == EOF)
1221     return c;
1222
1223   /* Something follows the #; read a token.  */
1224
1225   c = ffelex_cfelex_ (&token, finput, c);
1226
1227   if ((token != NULL)
1228       && (ffelex_token_type (token) == FFELEX_typeNUMBER))
1229     {
1230       int old_lineno = lineno;
1231       const char *old_input_filename = input_filename;
1232       ffewhereFile wf;
1233
1234       /* subtract one, because it is the following line that
1235          gets the specified number */
1236       int l = atoi (ffelex_token_text (token)) - 1;
1237
1238       /* Is this the last nonwhite stuff on the line?  */
1239       while (c == ' ' || c == '\t')
1240         c = ffelex_getc_ (finput);
1241       if (c == '\n' || c == EOF)
1242         {
1243           /* No more: store the line number and check following line.  */
1244           lineno = l;
1245           if (!ffelex_kludge_flag_)
1246             {
1247               ffewhere_file_set (NULL, TRUE, (ffewhereLineNumber) l);
1248
1249               if (token != NULL)
1250                 ffelex_token_kill (token);
1251             }
1252           return c;
1253         }
1254
1255       /* More follows: it must be a string constant (filename).  */
1256
1257       /* Read the string constant.  */
1258       c = ffelex_cfelex_ (&token, finput, c);
1259
1260       if ((token == NULL)
1261           || (ffelex_token_type (token) != FFELEX_typeCHARACTER))
1262         {
1263           error ("invalid #line");
1264           goto skipline;
1265         }
1266
1267       lineno = l;
1268
1269       if (ffelex_kludge_flag_)
1270         input_filename = ggc_strdup (ffelex_token_text (token));
1271       else
1272         {
1273           wf = ffewhere_file_new (ffelex_token_text (token),
1274                                   ffelex_token_length (token));
1275           input_filename = ffewhere_file_name (wf);
1276           ffewhere_file_set (wf, TRUE, (ffewhereLineNumber) l);
1277         }
1278
1279 #if 0   /* Not sure what g77 should do with this yet. */
1280       /* Each change of file name
1281          reinitializes whether we are now in a system header.  */
1282       in_system_header = 0;
1283 #endif
1284
1285       if (main_input_filename == 0)
1286         main_input_filename = input_filename;
1287
1288       /* Is this the last nonwhite stuff on the line?  */
1289       while (c == ' ' || c == '\t')
1290         c = getc (finput);
1291       if (c == '\n' || c == EOF)
1292         {
1293           if (!ffelex_kludge_flag_)
1294             {
1295               /* Update the name in the top element of input_file_stack.  */
1296               if (input_file_stack)
1297                 input_file_stack->name = input_filename;
1298
1299               if (token != NULL)
1300                 ffelex_token_kill (token);
1301             }
1302           return c;
1303         }
1304
1305       c = ffelex_cfelex_ (&token, finput, c);
1306
1307       /* `1' after file name means entering new file.
1308          `2' after file name means just left a file.  */
1309
1310       if ((token != NULL)
1311           && (ffelex_token_type (token) == FFELEX_typeNUMBER))
1312         {
1313           int num = atoi (ffelex_token_text (token));
1314
1315           if (ffelex_kludge_flag_)
1316             {
1317               lineno = 1;
1318               input_filename = old_input_filename;
1319               error ("use `#line ...' instead of `# ...' in first line");
1320             }
1321
1322           if (num == 1)
1323             {
1324               /* Pushing to a new file.  */
1325               ffelex_file_push_ (old_lineno, input_filename);
1326             }
1327           else if (num == 2)
1328             {
1329               /* Popping out of a file.  */
1330               ffelex_file_pop_ (input_filename);
1331             }
1332
1333           /* Is this the last nonwhite stuff on the line?  */
1334           while (c == ' ' || c == '\t')
1335             c = getc (finput);
1336           if (c == '\n' || c == EOF)
1337             {
1338               if (token != NULL)
1339                 ffelex_token_kill (token);
1340               return c;
1341             }
1342
1343           c = ffelex_cfelex_ (&token, finput, c);
1344         }
1345
1346       /* `3' after file name means this is a system header file.  */
1347
1348 #if 0   /* Not sure what g77 should do with this yet. */
1349       if ((token != NULL)
1350           && (ffelex_token_type (token) == FFELEX_typeNUMBER)
1351           && (atoi (ffelex_token_text (token)) == 3))
1352         in_system_header = 1;
1353 #endif
1354
1355       while (c == ' ' || c == '\t')
1356         c = getc (finput);
1357       if (((token != NULL)
1358            || (c != '\n' && c != EOF))
1359           && ffelex_kludge_flag_)
1360         {
1361           lineno = 1;
1362           input_filename = old_input_filename;
1363           error ("use `#line ...' instead of `# ...' in first line");
1364         }
1365       if (c == '\n' || c == EOF)
1366         {
1367           if (token != NULL && !ffelex_kludge_flag_)
1368             ffelex_token_kill (token);
1369           return c;
1370         }
1371     }
1372   else
1373     error ("invalid #-line");
1374
1375   /* skip the rest of this line.  */
1376  skipline:
1377   if ((token != NULL) && !ffelex_kludge_flag_)
1378     ffelex_token_kill (token);
1379   while ((c = getc (finput)) != EOF && c != '\n')
1380     ;
1381   return c;
1382 }
1383
1384 /* "Image" a character onto the card image, return incremented column number.
1385
1386    Normally invoking this function as in
1387      column = ffelex_image_char_ (c, column);
1388    is the same as doing:
1389      ffelex_card_image_[column++] = c;
1390
1391    However, tabs and carriage returns are handled specially, to preserve
1392    the visual "image" of the input line (in most editors) in the card
1393    image.
1394
1395    Carriage returns are ignored, as they are assumed to be followed
1396    by newlines.
1397
1398    A tab is handled by first doing:
1399      ffelex_card_image_[column++] = ' ';
1400    That is, it translates to at least one space.  Then, as many spaces
1401    are imaged as necessary to bring the column number to the next tab
1402    position, where tab positions start in the ninth column and each
1403    eighth column afterwards.  ALSO, a static var named ffelex_saw_tab_
1404    is set to TRUE to notify the lexer that a tab was seen.
1405
1406    Columns are numbered and tab stops set as illustrated below:
1407
1408    012345670123456701234567...
1409    x       y       z
1410    xx      yy      zz
1411    ...
1412    xxxxxxx yyyyyyy zzzzzzz
1413    xxxxxxxx        yyyyyyyy...  */
1414
1415 static ffewhereColumnNumber
1416 ffelex_image_char_ (int c, ffewhereColumnNumber column)
1417 {
1418   ffewhereColumnNumber old_column = column;
1419
1420   if (column >= ffelex_card_size_)
1421     {
1422       ffewhereColumnNumber newmax = ffelex_card_size_ << 1;
1423
1424       if (ffelex_bad_line_)
1425         return column;
1426
1427       if ((newmax >> 1) != ffelex_card_size_)
1428         {                       /* Overflowed column number. */
1429         overflow:       /* :::::::::::::::::::: */
1430
1431           ffelex_bad_line_ = TRUE;
1432           strcpy (&ffelex_card_image_[column - 3], "...");
1433           ffelex_card_length_ = column;
1434           ffelex_bad_1_ (FFEBAD_LINE_TOO_LONG,
1435                          ffelex_linecount_current_, column + 1);
1436           return column;
1437         }
1438
1439       ffelex_card_image_
1440         = malloc_resize_ksr (malloc_pool_image (),
1441                              ffelex_card_image_,
1442                              newmax + 9,
1443                              ffelex_card_size_ + 9);
1444       ffelex_card_size_ = newmax;
1445     }
1446
1447   switch (c)
1448     {
1449     case '\r':
1450       break;
1451
1452     case '\t':
1453       ffelex_saw_tab_ = TRUE;
1454       ffelex_card_image_[column++] = ' ';
1455       while ((column & 7) != 0)
1456         ffelex_card_image_[column++] = ' ';
1457       break;
1458
1459     case '\0':
1460       if (!ffelex_bad_line_)
1461         {
1462           ffelex_bad_line_ = TRUE;
1463           strcpy (&ffelex_card_image_[column], "[\\0]");
1464           ffelex_card_length_ = column + 4;
1465           ffebad_start_msg_lex ("Null character at %0 -- line ignored",
1466                                 FFEBAD_severityFATAL);
1467           ffelex_bad_here_ (0, ffelex_linecount_current_, column + 1);
1468           ffebad_finish ();
1469           column += 4;
1470         }
1471       break;
1472
1473     default:
1474       ffelex_card_image_[column++] = c;
1475       break;
1476     }
1477
1478   if (column < old_column)
1479     {
1480       column = old_column;
1481       goto overflow;    /* :::::::::::::::::::: */
1482     }
1483
1484   return column;
1485 }
1486
1487 static void
1488 ffelex_include_ ()
1489 {
1490   ffewhereFile include_wherefile = ffelex_include_wherefile_;
1491   FILE *include_file = ffelex_include_file_;
1492   /* The rest of this is to push, and after the INCLUDE file is processed,
1493      pop, the static lexer state info that pertains to each particular
1494      input file.  */
1495   char *card_image;
1496   ffewhereColumnNumber card_size = ffelex_card_size_;
1497   ffewhereColumnNumber card_length = ffelex_card_length_;
1498   ffewhereLine current_wl = ffelex_current_wl_;
1499   ffewhereColumn current_wc = ffelex_current_wc_;
1500   bool saw_tab = ffelex_saw_tab_;
1501   ffewhereColumnNumber final_nontab_column = ffelex_final_nontab_column_;
1502   ffewhereFile current_wf = ffelex_current_wf_;
1503   ffewhereLineNumber linecount_current = ffelex_linecount_current_;
1504   ffewhereLineNumber linecount_offset
1505     = ffewhere_line_filelinenum (current_wl);
1506   int old_lineno = lineno;
1507   const char *old_input_filename = input_filename;
1508
1509   if (card_length != 0)
1510     {
1511       card_image = malloc_new_ks (malloc_pool_image (),
1512                                   "FFELEX saved card image",
1513                                   card_length);
1514       memcpy (card_image, ffelex_card_image_, card_length);
1515     }
1516   else
1517     card_image = NULL;
1518
1519   ffelex_set_include_ = FALSE;
1520
1521   ffelex_next_line_ ();
1522
1523   ffewhere_file_set (include_wherefile, TRUE, 0);
1524
1525   ffelex_file_push_ (old_lineno, ffewhere_file_name (include_wherefile));
1526
1527   if (ffelex_include_free_form_)
1528     ffelex_file_free (include_wherefile, include_file);
1529   else
1530     ffelex_file_fixed (include_wherefile, include_file);
1531
1532   ffelex_file_pop_ (ffewhere_file_name (current_wf));
1533
1534   ffewhere_file_set (current_wf, TRUE, linecount_offset);
1535
1536   ffecom_close_include (include_file);
1537
1538   if (card_length != 0)
1539     {
1540 #ifdef REDUCE_CARD_SIZE_AFTER_BIGGY     /* Define if occasional large lines. */
1541 #error "need to handle possible reduction of card size here!!"
1542 #endif
1543       assert (ffelex_card_size_ >= card_length);        /* It shrunk?? */
1544       memcpy (ffelex_card_image_, card_image, card_length);
1545     }
1546   ffelex_card_image_[card_length] = '\0';
1547
1548   input_filename = old_input_filename;
1549   lineno = old_lineno;
1550   ffelex_linecount_current_ = linecount_current;
1551   ffelex_current_wf_ = current_wf;
1552   ffelex_final_nontab_column_ = final_nontab_column;
1553   ffelex_saw_tab_ = saw_tab;
1554   ffelex_current_wc_ = current_wc;
1555   ffelex_current_wl_ = current_wl;
1556   ffelex_card_length_ = card_length;
1557   ffelex_card_size_ = card_size;
1558 }
1559
1560 /* ffelex_is_free_char_ctx_contin_ -- Character Context Continuation?
1561
1562    ffewhereColumnNumber col;
1563    int c;  // Char at col.
1564    if ((c == '&') && ffelex_is_free_char_ctx_contin_(col + 1))
1565        // We have a continuation indicator.
1566
1567    If there are <n> spaces starting at ffelex_card_image_[col] up through
1568    the null character, where <n> is 0 or greater, returns TRUE.  */
1569
1570 static bool
1571 ffelex_is_free_char_ctx_contin_ (ffewhereColumnNumber col)
1572 {
1573   while (ffelex_card_image_[col] != '\0')
1574     {
1575       if (ffelex_card_image_[col++] != ' ')
1576         return FALSE;
1577     }
1578   return TRUE;
1579 }
1580
1581 /* ffelex_is_free_nonc_ctx_contin_ -- Noncharacter Context Continuation?
1582
1583    ffewhereColumnNumber col;
1584    int c;  // Char at col.
1585    if ((c == '&') && ffelex_is_free_nonc_ctx_contin_(col + 1))
1586        // We have a continuation indicator.
1587
1588    If there are <n> spaces starting at ffelex_card_image_[col] up through
1589    the null character or '!', where <n> is 0 or greater, returns TRUE.  */
1590
1591 static bool
1592 ffelex_is_free_nonc_ctx_contin_ (ffewhereColumnNumber col)
1593 {
1594   while ((ffelex_card_image_[col] != '\0') && (ffelex_card_image_[col] != '!'))
1595     {
1596       if (ffelex_card_image_[col++] != ' ')
1597         return FALSE;
1598     }
1599   return TRUE;
1600 }
1601
1602 static void
1603 ffelex_next_line_ ()
1604 {
1605   ffelex_linecount_current_ = ffelex_linecount_next_;
1606   ++ffelex_linecount_next_;
1607   ++lineno;
1608 }
1609
1610 static void
1611 ffelex_send_token_ ()
1612 {
1613   ++ffelex_number_of_tokens_;
1614
1615   ffelex_backslash_ (EOF, 0);
1616
1617   if (ffelex_token_->text == NULL)
1618     {
1619       if (ffelex_token_->type == FFELEX_typeCHARACTER)
1620         {
1621           ffelex_append_to_token_ ('\0');
1622           ffelex_token_->length = 0;
1623         }
1624     }
1625   else
1626     ffelex_token_->text[ffelex_token_->length] = '\0';
1627
1628   assert (ffelex_raw_mode_ == 0);
1629
1630   if (ffelex_token_->type == FFELEX_typeNAMES)
1631     {
1632       ffewhere_line_kill (ffelex_token_->currentnames_line);
1633       ffewhere_column_kill (ffelex_token_->currentnames_col);
1634     }
1635
1636   assert (ffelex_handler_ != NULL);
1637   ffelex_handler_ = (ffelexHandler) (*ffelex_handler_) (ffelex_token_);
1638   assert (ffelex_handler_ != NULL);
1639
1640   ffelex_token_kill (ffelex_token_);
1641
1642   ffelex_token_ = ffelex_token_new_ ();
1643   ffelex_token_->uses = 1;
1644   ffelex_token_->text = NULL;
1645   if (ffelex_raw_mode_ < 0)
1646     {
1647       ffelex_token_->type = FFELEX_typeCHARACTER;
1648       ffelex_token_->where_line = ffelex_raw_where_line_;
1649       ffelex_token_->where_col = ffelex_raw_where_col_;
1650       ffelex_raw_where_line_ = ffewhere_line_unknown ();
1651       ffelex_raw_where_col_ = ffewhere_column_unknown ();
1652     }
1653   else
1654     {
1655       ffelex_token_->type = FFELEX_typeNONE;
1656       ffelex_token_->where_line = ffewhere_line_unknown ();
1657       ffelex_token_->where_col = ffewhere_column_unknown ();
1658     }
1659
1660   if (ffelex_set_include_)
1661     ffelex_include_ ();
1662 }
1663
1664 /* ffelex_swallow_tokens_ -- Eat all tokens delivered to me
1665
1666    return ffelex_swallow_tokens_;
1667
1668    Return this handler when you don't want to look at any more tokens in the
1669    statement because you've encountered an unrecoverable error in the
1670    statement.  */
1671
1672 static ffelexHandler
1673 ffelex_swallow_tokens_ (ffelexToken t)
1674 {
1675   assert (ffelex_eos_handler_ != NULL);
1676
1677   if ((ffelex_token_type (t) == FFELEX_typeEOS)
1678       || (ffelex_token_type (t) == FFELEX_typeSEMICOLON))
1679     return (ffelexHandler) (*ffelex_eos_handler_) (t);
1680
1681   return (ffelexHandler) ffelex_swallow_tokens_;
1682 }
1683
1684 static ffelexToken
1685 ffelex_token_new_ ()
1686 {
1687   ffelexToken t;
1688
1689   ++ffelex_total_tokens_;
1690
1691   t = (ffelexToken) malloc_new_ks (malloc_pool_image (),
1692                                    "FFELEX token", sizeof (*t));
1693   t->id_ = ffelex_token_nextid_++;
1694   return t;
1695 }
1696
1697 static const char *
1698 ffelex_type_string_ (ffelexType type)
1699 {
1700   static const char *const types[] = {
1701     "FFELEX_typeNONE",
1702     "FFELEX_typeCOMMENT",
1703     "FFELEX_typeEOS",
1704     "FFELEX_typeEOF",
1705     "FFELEX_typeERROR",
1706     "FFELEX_typeRAW",
1707     "FFELEX_typeQUOTE",
1708     "FFELEX_typeDOLLAR",
1709     "FFELEX_typeHASH",
1710     "FFELEX_typePERCENT",
1711     "FFELEX_typeAMPERSAND",
1712     "FFELEX_typeAPOSTROPHE",
1713     "FFELEX_typeOPEN_PAREN",
1714     "FFELEX_typeCLOSE_PAREN",
1715     "FFELEX_typeASTERISK",
1716     "FFELEX_typePLUS",
1717     "FFELEX_typeMINUS",
1718     "FFELEX_typePERIOD",
1719     "FFELEX_typeSLASH",
1720     "FFELEX_typeNUMBER",
1721     "FFELEX_typeOPEN_ANGLE",
1722     "FFELEX_typeEQUALS",
1723     "FFELEX_typeCLOSE_ANGLE",
1724     "FFELEX_typeNAME",
1725     "FFELEX_typeCOMMA",
1726     "FFELEX_typePOWER",
1727     "FFELEX_typeCONCAT",
1728     "FFELEX_typeDEBUG",
1729     "FFELEX_typeNAMES",
1730     "FFELEX_typeHOLLERITH",
1731     "FFELEX_typeCHARACTER",
1732     "FFELEX_typeCOLON",
1733     "FFELEX_typeSEMICOLON",
1734     "FFELEX_typeUNDERSCORE",
1735     "FFELEX_typeQUESTION",
1736     "FFELEX_typeOPEN_ARRAY",
1737     "FFELEX_typeCLOSE_ARRAY",
1738     "FFELEX_typeCOLONCOLON",
1739     "FFELEX_typeREL_LE",
1740     "FFELEX_typeREL_NE",
1741     "FFELEX_typeREL_EQ",
1742     "FFELEX_typePOINTS",
1743     "FFELEX_typeREL_GE"
1744   };
1745
1746   if (type >= ARRAY_SIZE (types))
1747     return "???";
1748   return types[type];
1749 }
1750
1751 void
1752 ffelex_display_token (ffelexToken t)
1753 {
1754   if (t == NULL)
1755     t = ffelex_token_;
1756
1757   fprintf (dmpout, "; Token #%lu is %s (line %" ffewhereLineNumber_f "u, col %"
1758            ffewhereColumnNumber_f "u)",
1759            t->id_,
1760            ffelex_type_string_ (t->type),
1761            ffewhere_line_number (t->where_line),
1762            ffewhere_column_number (t->where_col));
1763
1764   if (t->text != NULL)
1765     fprintf (dmpout, ": \"%.*s\"\n",
1766              (int) t->length,
1767              t->text);
1768   else
1769     fprintf (dmpout, ".\n");
1770 }
1771
1772 /* ffelex_expecting_character -- Tells if next token expected to be CHARACTER
1773
1774    if (ffelex_expecting_character())
1775        // next token delivered by lexer will be CHARACTER.
1776
1777    If the most recent call to ffelex_set_expecting_hollerith since the last
1778    token was delivered by the lexer passed a length of -1, then we return
1779    TRUE, because the next token we deliver will be typeCHARACTER, else we
1780    return FALSE.  */
1781
1782 bool
1783 ffelex_expecting_character ()
1784 {
1785   return (ffelex_raw_mode_ != 0);
1786 }
1787
1788 /* ffelex_file_fixed -- Lex a given file in fixed source form
1789
1790    ffewhere wf;
1791    FILE *f;
1792    ffelex_file_fixed(wf,f);
1793
1794    Lexes the file according to Fortran 90 ANSI + VXT specifications.  */
1795
1796 ffelexHandler
1797 ffelex_file_fixed (ffewhereFile wf, FILE *f)
1798 {
1799   register int c = 0;           /* Character currently under consideration. */
1800   register ffewhereColumnNumber column = 0;     /* Not really; 0 means column 1... */
1801   bool disallow_continuation_line;
1802   bool ignore_disallowed_continuation = FALSE;
1803   int latest_char_in_file = 0;  /* For getting back into comment-skipping
1804                                    code. */
1805   ffelexType lextype;
1806   ffewhereColumnNumber first_label_char;        /* First char of label --
1807                                                    column number. */
1808   char label_string[6];         /* Text of label. */
1809   int labi;                     /* Length of label text. */
1810   bool finish_statement;        /* Previous statement finished? */
1811   bool have_content;            /* This line have content? */
1812   bool just_do_label;           /* Nothing but label (and continuation?) on
1813                                    line. */
1814
1815   /* Lex is called for a particular file, not for a particular program unit.
1816      Yet the two events do share common characteristics.  The first line in a
1817      file or in a program unit cannot be a continuation line.  No token can
1818      be in mid-formation.  No current label for the statement exists, since
1819      there is no current statement. */
1820
1821   assert (ffelex_handler_ != NULL);
1822
1823   lineno = 0;
1824   input_filename = ffewhere_file_name (wf);
1825   ffelex_current_wf_ = wf;
1826   disallow_continuation_line = TRUE;
1827   ignore_disallowed_continuation = FALSE;
1828   ffelex_token_->type = FFELEX_typeNONE;
1829   ffelex_number_of_tokens_ = 0;
1830   ffelex_label_tokens_ = 0;
1831   ffelex_current_wl_ = ffewhere_line_unknown ();
1832   ffelex_current_wc_ = ffewhere_column_unknown ();
1833   latest_char_in_file = '\n';
1834
1835   goto first_line;              /* :::::::::::::::::::: */
1836
1837   /* Come here to get a new line. */
1838
1839  beginning_of_line:             /* :::::::::::::::::::: */
1840
1841   disallow_continuation_line = FALSE;
1842
1843   /* Come here directly when last line didn't clarify the continuation issue. */
1844
1845  beginning_of_line_again:       /* :::::::::::::::::::: */
1846
1847 #ifdef REDUCE_CARD_SIZE_AFTER_BIGGY     /* Define if occasional large lines. */
1848   if (ffelex_card_size_ != FFELEX_columnINITIAL_SIZE_)
1849     {
1850       ffelex_card_image_
1851         = malloc_resize_ks (malloc_pool_image (),
1852                             ffelex_card_image_,
1853                             FFELEX_columnINITIAL_SIZE_ + 9,
1854                             ffelex_card_size_ + 9);
1855       ffelex_card_size_ = FFELEX_columnINITIAL_SIZE_;
1856     }
1857 #endif
1858
1859  first_line:                    /* :::::::::::::::::::: */
1860
1861   c = latest_char_in_file;
1862   if ((c == EOF) || ((c = ffelex_getc_ (f)) == EOF))
1863     {
1864
1865     end_of_file:                /* :::::::::::::::::::: */
1866
1867       /* Line ending in EOF instead of \n still counts as a whole line. */
1868
1869       ffelex_finish_statement_ ();
1870       ffewhere_line_kill (ffelex_current_wl_);
1871       ffewhere_column_kill (ffelex_current_wc_);
1872       return (ffelexHandler) ffelex_handler_;
1873     }
1874
1875   ffelex_next_line_ ();
1876
1877   ffelex_bad_line_ = FALSE;
1878
1879   /* Skip over comment (and otherwise ignored) lines as quickly as possible! */
1880
1881   while (((lextype = ffelex_first_char_[c]) == FFELEX_typeCOMMENT)
1882          || (lextype == FFELEX_typeERROR)
1883          || (lextype == FFELEX_typeSLASH)
1884          || (lextype == FFELEX_typeHASH))
1885     {
1886       /* Test most frequent type of line first, etc.  */
1887       if ((lextype == FFELEX_typeCOMMENT)
1888           || ((lextype == FFELEX_typeSLASH)
1889               && ((c = getc (f)) == '*')))      /* NOTE SIDE-EFFECT. */
1890         {
1891           /* Typical case (straight comment), just ignore rest of line. */
1892         comment_line:           /* :::::::::::::::::::: */
1893
1894           while ((c != '\n') && (c != EOF))
1895             c = getc (f);
1896         }
1897       else if (lextype == FFELEX_typeHASH)
1898         c = ffelex_hash_ (f);
1899       else if (lextype == FFELEX_typeSLASH)
1900         {
1901           /* SIDE-EFFECT ABOVE HAS HAPPENED. */
1902           ffelex_card_image_[0] = '/';
1903           ffelex_card_image_[1] = c;
1904           column = 2;
1905           goto bad_first_character;     /* :::::::::::::::::::: */
1906         }
1907       else
1908         /* typeERROR or unsupported typeHASH.  */
1909         {                       /* Bad first character, get line and display
1910                                    it with message. */
1911           column = ffelex_image_char_ (c, 0);
1912
1913         bad_first_character:    /* :::::::::::::::::::: */
1914
1915           ffelex_bad_line_ = TRUE;
1916           while (((c = getc (f)) != '\n') && (c != EOF))
1917             column = ffelex_image_char_ (c, column);
1918           ffelex_card_image_[column] = '\0';
1919           ffelex_card_length_ = column;
1920           ffelex_bad_1_ (FFEBAD_FIRST_CHAR_INVALID,
1921                          ffelex_linecount_current_, 1);
1922         }
1923
1924       /* Read past last char in line.  */
1925
1926       if (c == EOF)
1927         {
1928           ffelex_next_line_ ();
1929           goto end_of_file;     /* :::::::::::::::::::: */
1930         }
1931
1932       c = getc (f);
1933
1934       ffelex_next_line_ ();
1935
1936       if (c == EOF)
1937         goto end_of_file;       /* :::::::::::::::::::: */
1938
1939       ffelex_bad_line_ = FALSE;
1940     }                           /* while [c, first char, means comment] */
1941
1942   ffelex_saw_tab_
1943     = (c == '&')
1944       || (ffelex_final_nontab_column_ == 0);
1945
1946   if (lextype == FFELEX_typeDEBUG)
1947     c = ' ';                    /* A 'D' or 'd' in column 1 with the
1948                                    debug-lines option on. */
1949
1950   column = ffelex_image_char_ (c, 0);
1951
1952   /* Read the entire line in as is (with whitespace processing).  */
1953
1954   while (((c = getc (f)) != '\n') && (c != EOF))
1955     column = ffelex_image_char_ (c, column);
1956
1957   if (ffelex_bad_line_)
1958     {
1959       ffelex_card_image_[column] = '\0';
1960       ffelex_card_length_ = column;
1961       goto comment_line;                /* :::::::::::::::::::: */
1962     }
1963
1964   /* If no tab, cut off line after column 72/132.  */
1965
1966   if (!ffelex_saw_tab_ && (column > ffelex_final_nontab_column_))
1967     {
1968       /* Technically, we should now fill ffelex_card_image_ up thru column
1969          72/132 with spaces, since character/hollerith constants must count
1970          them in that manner. To save CPU time in several ways (avoid a loop
1971          here that would be used only when we actually end a line in
1972          character-constant mode; avoid writing memory unnecessarily; avoid a
1973          loop later checking spaces when not scanning for character-constant
1974          characters), we don't do this, and we do the appropriate thing when
1975          we encounter end-of-line while actually processing a character
1976          constant. */
1977
1978       column = ffelex_final_nontab_column_;
1979     }
1980
1981   ffelex_card_image_[column] = '\0';
1982   ffelex_card_length_ = column;
1983
1984   /* Save next char in file so we can use register-based c while analyzing
1985      line we just read. */
1986
1987   latest_char_in_file = c;      /* Should be either '\n' or EOF. */
1988
1989   have_content = FALSE;
1990
1991   /* Handle label, if any. */
1992
1993   labi = 0;
1994   first_label_char = FFEWHERE_columnUNKNOWN;
1995   for (column = 0; column < 5; ++column)
1996     {
1997       switch (c = ffelex_card_image_[column])
1998         {
1999         case '\0':
2000         case '!':
2001           goto stop_looking;    /* :::::::::::::::::::: */
2002
2003         case ' ':
2004           break;
2005
2006         case '0':
2007         case '1':
2008         case '2':
2009         case '3':
2010         case '4':
2011         case '5':
2012         case '6':
2013         case '7':
2014         case '8':
2015         case '9':
2016           label_string[labi++] = c;
2017           if (first_label_char == FFEWHERE_columnUNKNOWN)
2018             first_label_char = column + 1;
2019           break;
2020
2021         case '&':
2022           if (column != 0)
2023             {
2024               ffelex_bad_1_ (FFEBAD_LABEL_FIELD_NOT_NUMERIC,
2025                              ffelex_linecount_current_,
2026                              column + 1);
2027               goto beginning_of_line_again;     /* :::::::::::::::::::: */
2028             }
2029           if (ffe_is_pedantic ())
2030             ffelex_bad_1_ (FFEBAD_AMPERSAND,
2031                            ffelex_linecount_current_, 1);
2032           finish_statement = FALSE;
2033           just_do_label = FALSE;
2034           goto got_a_continuation;      /* :::::::::::::::::::: */
2035
2036         case '/':
2037           if (ffelex_card_image_[column + 1] == '*')
2038             goto stop_looking;  /* :::::::::::::::::::: */
2039           /* Fall through. */
2040         default:
2041           ffelex_bad_1_ (FFEBAD_LABEL_FIELD_NOT_NUMERIC,
2042                          ffelex_linecount_current_, column + 1);
2043           goto beginning_of_line_again; /* :::::::::::::::::::: */
2044         }
2045     }
2046
2047  stop_looking:                  /* :::::::::::::::::::: */
2048
2049   label_string[labi] = '\0';
2050
2051   /* Find first nonblank char starting with continuation column. */
2052
2053   if (column == 5)              /* In which case we didn't see end of line in
2054                                    label field. */
2055     while ((c = ffelex_card_image_[column]) == ' ')
2056       ++column;
2057
2058   /* Now we're trying to figure out whether this is a continuation line and
2059      whether there's anything else of substance on the line.  The cases are
2060      as follows:
2061
2062      1. If a line has an explicit continuation character (other than the digit
2063      zero), then if it also has a label, the label is ignored and an error
2064      message is printed.  Any remaining text on the line is passed to the
2065      parser tasks, thus even an all-blank line (possibly with an ignored
2066      label) aside from a positive continuation character might have meaning
2067      in the midst of a character or hollerith constant.
2068
2069      2. If a line has no explicit continuation character (that is, it has a
2070      space in column 6 and the first non-space character past column 6 is
2071      not a digit 0-9), then there are two possibilities:
2072
2073      A. A label is present and/or a non-space (and non-comment) character
2074      appears somewhere after column 6.  Terminate processing of the previous
2075      statement, if any, send the new label for the next statement, if any,
2076      and start processing a new statement with this non-blank character, if
2077      any.
2078
2079      B. The line is essentially blank, except for a possible comment character.
2080      Don't terminate processing of the previous statement and don't pass any
2081      characters to the parser tasks, since the line is not flagged as a
2082      continuation line.  We treat it just like a completely blank line.
2083
2084      3. If a line has a continuation character of zero (0), then we terminate
2085      processing of the previous statement, if any, send the new label for the
2086      next statement, if any, and start processing a new statement, if any
2087      non-blank characters are present.
2088
2089      If, when checking to see if we should terminate the previous statement, it
2090      is found that there is no previous statement but that there is an
2091      outstanding label, substitute CONTINUE as the statement for the label
2092      and display an error message. */
2093
2094   finish_statement = FALSE;
2095   just_do_label = FALSE;
2096
2097   switch (c)
2098     {
2099     case '!':                   /* ANSI Fortran 90 says ! in column 6 is
2100                                    continuation. */
2101       /* VXT Fortran says ! anywhere is comment, even column 6. */
2102       if (ffe_is_vxt () || (column != 5))
2103         goto no_tokens_on_line; /* :::::::::::::::::::: */
2104       goto got_a_continuation;  /* :::::::::::::::::::: */
2105
2106     case '/':
2107       if (ffelex_card_image_[column + 1] != '*')
2108         goto some_other_character;      /* :::::::::::::::::::: */
2109       /* Fall through. */
2110       if (column == 5)
2111         {
2112           /* This seems right to do. But it is close to call, since / * starting
2113              in column 6 will thus be interpreted as a continuation line
2114              beginning with '*'. */
2115
2116           goto got_a_continuation;/* :::::::::::::::::::: */
2117         }
2118       /* Fall through. */
2119     case '\0':
2120       /* End of line.  Therefore may be continued-through line, so handle
2121          pending label as possible to-be-continued and drive end-of-statement
2122          for any previous statement, else treat as blank line. */
2123
2124      no_tokens_on_line:         /* :::::::::::::::::::: */
2125
2126       if (ffe_is_pedantic () && (c == '/'))
2127         ffelex_bad_1_ (FFEBAD_NON_ANSI_COMMENT,
2128                        ffelex_linecount_current_, column + 1);
2129       if (first_label_char != FFEWHERE_columnUNKNOWN)
2130         {                       /* Can't be a continued-through line if it
2131                                    has a label. */
2132           finish_statement = TRUE;
2133           have_content = TRUE;
2134           just_do_label = TRUE;
2135           break;
2136         }
2137       goto beginning_of_line_again;     /* :::::::::::::::::::: */
2138
2139     case '0':
2140       if (ffe_is_pedantic () && (column != 5))
2141         ffelex_bad_1_ (FFEBAD_NON_ANSI_CONTINUATION_COLUMN,
2142                        ffelex_linecount_current_, column + 1);
2143       finish_statement = TRUE;
2144       goto check_for_content;   /* :::::::::::::::::::: */
2145
2146     case '1':
2147     case '2':
2148     case '3':
2149     case '4':
2150     case '5':
2151     case '6':
2152     case '7':
2153     case '8':
2154     case '9':
2155
2156       /* NOTE: This label can be reached directly from the code
2157          that lexes the label field in columns 1-5.  */
2158      got_a_continuation:        /* :::::::::::::::::::: */
2159
2160       if (first_label_char != FFEWHERE_columnUNKNOWN)
2161         {
2162           ffelex_bad_2_ (FFEBAD_LABEL_ON_CONTINUATION,
2163                          ffelex_linecount_current_,
2164                          first_label_char,
2165                          ffelex_linecount_current_,
2166                          column + 1);
2167           first_label_char = FFEWHERE_columnUNKNOWN;
2168         }
2169       if (disallow_continuation_line)
2170         {
2171           if (!ignore_disallowed_continuation)
2172             ffelex_bad_1_ (FFEBAD_INVALID_CONTINUATION,
2173                            ffelex_linecount_current_, column + 1);
2174           goto beginning_of_line_again; /* :::::::::::::::::::: */
2175         }
2176       if (ffe_is_pedantic () && (column != 5))
2177         ffelex_bad_1_ (FFEBAD_NON_ANSI_CONTINUATION_COLUMN,
2178                        ffelex_linecount_current_, column + 1);
2179       if ((ffelex_raw_mode_ != 0)
2180           && (((c = ffelex_card_image_[column + 1]) != '\0')
2181               || !ffelex_saw_tab_))
2182         {
2183           ++column;
2184           have_content = TRUE;
2185           break;
2186         }
2187
2188      check_for_content:         /* :::::::::::::::::::: */
2189
2190       while ((c = ffelex_card_image_[++column]) == ' ')
2191         ;
2192       if ((c == '\0')
2193           || (c == '!')
2194           || ((c == '/')
2195               && (ffelex_card_image_[column + 1] == '*')))
2196         {
2197           if (ffe_is_pedantic () && (c == '/'))
2198             ffelex_bad_1_ (FFEBAD_NON_ANSI_COMMENT,
2199                            ffelex_linecount_current_, column + 1);
2200           just_do_label = TRUE;
2201         }
2202       else
2203         have_content = TRUE;
2204       break;
2205
2206     default:
2207
2208      some_other_character:      /* :::::::::::::::::::: */
2209
2210       if (column == 5)
2211         goto got_a_continuation;/* :::::::::::::::::::: */
2212
2213       /* Here is the very normal case of a regular character starting in
2214          column 7 or beyond with a blank in column 6. */
2215
2216       finish_statement = TRUE;
2217       have_content = TRUE;
2218       break;
2219     }
2220
2221   if (have_content
2222       || (first_label_char != FFEWHERE_columnUNKNOWN))
2223     {
2224       /* The line has content of some kind, install new end-statement
2225          point for error messages.  Note that "content" includes cases
2226          where there's little apparent content but enough to finish
2227          a statement.  That's because finishing a statement can trigger
2228          an impending INCLUDE, and that requires accurate line info being
2229          maintained by the lexer.  */
2230
2231       if (finish_statement)
2232         ffelex_prepare_eos_ (); /* Prepare EOS before we move current pointer. */
2233
2234       ffewhere_line_kill (ffelex_current_wl_);
2235       ffewhere_column_kill (ffelex_current_wc_);
2236       ffelex_current_wl_ = ffewhere_line_new (ffelex_linecount_current_);
2237       ffelex_current_wc_ = ffewhere_column_new (ffelex_card_length_ + 1);
2238     }
2239
2240   /* We delay this for a combination of reasons.  Mainly, it can start
2241      INCLUDE processing, and we want to delay that until the lexer's
2242      info on the line is coherent.  And we want to delay that until we're
2243      sure there's a reason to make that info coherent, to avoid saving
2244      lots of useless lines.  */
2245
2246   if (finish_statement)
2247     ffelex_finish_statement_ ();
2248
2249   /* If label is present, enclose it in a NUMBER token and send it along. */
2250
2251   if (first_label_char != FFEWHERE_columnUNKNOWN)
2252     {
2253       assert (ffelex_token_->type == FFELEX_typeNONE);
2254       ffelex_token_->type = FFELEX_typeNUMBER;
2255       ffelex_append_to_token_ ('\0');   /* Make room for label text. */
2256       strcpy (ffelex_token_->text, label_string);
2257       ffelex_token_->where_line
2258         = ffewhere_line_use (ffelex_current_wl_);
2259       ffelex_token_->where_col = ffewhere_column_new (first_label_char);
2260       ffelex_token_->length = labi;
2261       ffelex_send_token_ ();
2262       ++ffelex_label_tokens_;
2263     }
2264
2265   if (just_do_label)
2266     goto beginning_of_line;     /* :::::::::::::::::::: */
2267
2268   /* Here is the main engine for parsing.  c holds the character at column.
2269      It is already known that c is not a blank, end of line, or shriek,
2270      unless ffelex_raw_mode_ is not 0 (indicating we are in a
2271      character/hollerith constant). A partially filled token may already
2272      exist in ffelex_token_.  One special case: if, when the end of the line
2273      is reached, continuation_line is FALSE and the only token on the line is
2274      END, then it is indeed the last statement. We don't look for
2275      continuation lines during this program unit in that case. This is
2276      according to ANSI. */
2277
2278   if (ffelex_raw_mode_ != 0)
2279     {
2280
2281     parse_raw_character:        /* :::::::::::::::::::: */
2282
2283       if (c == '\0')
2284         {
2285           ffewhereColumnNumber i;
2286
2287           if (ffelex_saw_tab_ || (column >= ffelex_final_nontab_column_))
2288             goto beginning_of_line;     /* :::::::::::::::::::: */
2289
2290           /* Pad out line with "virtual" spaces. */
2291
2292           for (i = column; i < ffelex_final_nontab_column_; ++i)
2293             ffelex_card_image_[i] = ' ';
2294           ffelex_card_image_[i] = '\0';
2295           ffelex_card_length_ = i;
2296           c = ' ';
2297         }
2298
2299       switch (ffelex_raw_mode_)
2300         {
2301         case -3:
2302           c = ffelex_backslash_ (c, column);
2303           if (c == EOF)
2304             break;
2305
2306           if (!ffelex_backslash_reconsider_)
2307             ffelex_append_to_token_ (c);
2308           ffelex_raw_mode_ = -1;
2309           break;
2310
2311         case -2:
2312           if (c == ffelex_raw_char_)
2313             {
2314               ffelex_raw_mode_ = -1;
2315               ffelex_append_to_token_ (c);
2316             }
2317           else
2318             {
2319               ffelex_raw_mode_ = 0;
2320               ffelex_backslash_reconsider_ = TRUE;
2321             }
2322           break;
2323
2324         case -1:
2325           if (c == ffelex_raw_char_)
2326             ffelex_raw_mode_ = -2;
2327           else
2328             {
2329               c = ffelex_backslash_ (c, column);
2330               if (c == EOF)
2331                 {
2332                   ffelex_raw_mode_ = -3;
2333                   break;
2334                 }
2335
2336               ffelex_append_to_token_ (c);
2337             }
2338           break;
2339
2340         default:
2341           c = ffelex_backslash_ (c, column);
2342           if (c == EOF)
2343             break;
2344
2345           if (!ffelex_backslash_reconsider_)
2346             {
2347               ffelex_append_to_token_ (c);
2348               --ffelex_raw_mode_;
2349             }
2350           break;
2351         }
2352
2353       if (ffelex_backslash_reconsider_)
2354         ffelex_backslash_reconsider_ = FALSE;
2355       else
2356         c = ffelex_card_image_[++column];
2357
2358       if (ffelex_raw_mode_ == 0)
2359         {
2360           ffelex_send_token_ ();
2361           assert (ffelex_raw_mode_ == 0);
2362           while (c == ' ')
2363             c = ffelex_card_image_[++column];
2364           if ((c == '\0')
2365               || (c == '!')
2366               || ((c == '/')
2367                   && (ffelex_card_image_[column + 1] == '*')))
2368             goto beginning_of_line;     /* :::::::::::::::::::: */
2369           goto parse_nonraw_character;  /* :::::::::::::::::::: */
2370         }
2371       goto parse_raw_character; /* :::::::::::::::::::: */
2372     }
2373
2374  parse_nonraw_character:        /* :::::::::::::::::::: */
2375
2376   switch (ffelex_token_->type)
2377     {
2378     case FFELEX_typeNONE:
2379       switch (c)
2380         {
2381         case '\"':
2382           ffelex_token_->type = FFELEX_typeQUOTE;
2383           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
2384           ffelex_token_->where_col = ffewhere_column_new (column + 1);
2385           ffelex_send_token_ ();
2386           break;
2387
2388         case '$':
2389           ffelex_token_->type = FFELEX_typeDOLLAR;
2390           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
2391           ffelex_token_->where_col = ffewhere_column_new (column + 1);
2392           ffelex_send_token_ ();
2393           break;
2394
2395         case '%':
2396           ffelex_token_->type = FFELEX_typePERCENT;
2397           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
2398           ffelex_token_->where_col = ffewhere_column_new (column + 1);
2399           ffelex_send_token_ ();
2400           break;
2401
2402         case '&':
2403           ffelex_token_->type = FFELEX_typeAMPERSAND;
2404           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
2405           ffelex_token_->where_col = ffewhere_column_new (column + 1);
2406           ffelex_send_token_ ();
2407           break;
2408
2409         case '\'':
2410           ffelex_token_->type = FFELEX_typeAPOSTROPHE;
2411           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
2412           ffelex_token_->where_col = ffewhere_column_new (column + 1);
2413           ffelex_send_token_ ();
2414           break;
2415
2416         case '(':
2417           ffelex_token_->type = FFELEX_typeOPEN_PAREN;
2418           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
2419           ffelex_token_->where_col = ffewhere_column_new (column + 1);
2420           break;
2421
2422         case ')':
2423           ffelex_token_->type = FFELEX_typeCLOSE_PAREN;
2424           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
2425           ffelex_token_->where_col = ffewhere_column_new (column + 1);
2426           ffelex_send_token_ ();
2427           break;
2428
2429         case '*':
2430           ffelex_token_->type = FFELEX_typeASTERISK;
2431           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
2432           ffelex_token_->where_col = ffewhere_column_new (column + 1);
2433           break;
2434
2435         case '+':
2436           ffelex_token_->type = FFELEX_typePLUS;
2437           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
2438           ffelex_token_->where_col = ffewhere_column_new (column + 1);
2439           ffelex_send_token_ ();
2440           break;
2441
2442         case ',':
2443           ffelex_token_->type = FFELEX_typeCOMMA;
2444           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
2445           ffelex_token_->where_col = ffewhere_column_new (column + 1);
2446           ffelex_send_token_ ();
2447           break;
2448
2449         case '-':
2450           ffelex_token_->type = FFELEX_typeMINUS;
2451           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
2452           ffelex_token_->where_col = ffewhere_column_new (column + 1);
2453           ffelex_send_token_ ();
2454           break;
2455
2456         case '.':
2457           ffelex_token_->type = FFELEX_typePERIOD;
2458           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
2459           ffelex_token_->where_col = ffewhere_column_new (column + 1);
2460           ffelex_send_token_ ();
2461           break;
2462
2463         case '/':
2464           ffelex_token_->type = FFELEX_typeSLASH;
2465           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
2466           ffelex_token_->where_col = ffewhere_column_new (column + 1);
2467           break;
2468
2469         case '0':
2470         case '1':
2471         case '2':
2472         case '3':
2473         case '4':
2474         case '5':
2475         case '6':
2476         case '7':
2477         case '8':
2478         case '9':
2479           ffelex_token_->type
2480             = ffelex_hexnum_ ? FFELEX_typeNAME : FFELEX_typeNUMBER;
2481           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
2482           ffelex_token_->where_col = ffewhere_column_new (column + 1);
2483           ffelex_append_to_token_ (c);
2484           break;
2485
2486         case ':':
2487           ffelex_token_->type = FFELEX_typeCOLON;
2488           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
2489           ffelex_token_->where_col = ffewhere_column_new (column + 1);
2490           break;
2491
2492         case ';':
2493           ffelex_token_->type = FFELEX_typeSEMICOLON;
2494           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
2495           ffelex_token_->where_col = ffewhere_column_new (column + 1);
2496           ffelex_permit_include_ = TRUE;
2497           ffelex_send_token_ ();
2498           ffelex_permit_include_ = FALSE;
2499           break;
2500
2501         case '<':
2502           ffelex_token_->type = FFELEX_typeOPEN_ANGLE;
2503           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
2504           ffelex_token_->where_col = ffewhere_column_new (column + 1);
2505           break;
2506
2507         case '=':
2508           ffelex_token_->type = FFELEX_typeEQUALS;
2509           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
2510           ffelex_token_->where_col = ffewhere_column_new (column + 1);
2511           break;
2512
2513         case '>':
2514           ffelex_token_->type = FFELEX_typeCLOSE_ANGLE;
2515           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
2516           ffelex_token_->where_col = ffewhere_column_new (column + 1);
2517           break;
2518
2519         case '?':
2520           ffelex_token_->type = FFELEX_typeQUESTION;
2521           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
2522           ffelex_token_->where_col = ffewhere_column_new (column + 1);
2523           ffelex_send_token_ ();
2524           break;
2525
2526         case '_':
2527           if (1 || ffe_is_90 ())
2528             {
2529               ffelex_token_->type = FFELEX_typeUNDERSCORE;
2530               ffelex_token_->where_line
2531                 = ffewhere_line_use (ffelex_current_wl_);
2532               ffelex_token_->where_col
2533                 = ffewhere_column_new (column + 1);
2534               ffelex_send_token_ ();
2535               break;
2536             }
2537           /* Fall through. */
2538         case 'A':
2539         case 'B':
2540         case 'C':
2541         case 'D':
2542         case 'E':
2543         case 'F':
2544         case 'G':
2545         case 'H':
2546         case 'I':
2547         case 'J':
2548         case 'K':
2549         case 'L':
2550         case 'M':
2551         case 'N':
2552         case 'O':
2553         case 'P':
2554         case 'Q':
2555         case 'R':
2556         case 'S':
2557         case 'T':
2558         case 'U':
2559         case 'V':
2560         case 'W':
2561         case 'X':
2562         case 'Y':
2563         case 'Z':
2564         case 'a':
2565         case 'b':
2566         case 'c':
2567         case 'd':
2568         case 'e':
2569         case 'f':
2570         case 'g':
2571         case 'h':
2572         case 'i':
2573         case 'j':
2574         case 'k':
2575         case 'l':
2576         case 'm':
2577         case 'n':
2578         case 'o':
2579         case 'p':
2580         case 'q':
2581         case 'r':
2582         case 's':
2583         case 't':
2584         case 'u':
2585         case 'v':
2586         case 'w':
2587         case 'x':
2588         case 'y':
2589         case 'z':
2590           c = ffesrc_char_source (c);
2591
2592           if (ffesrc_char_match_init (c, 'H', 'h')
2593               && ffelex_expecting_hollerith_ != 0)
2594             {
2595               ffelex_raw_mode_ = ffelex_expecting_hollerith_;
2596               ffelex_token_->type = FFELEX_typeHOLLERITH;
2597               ffelex_token_->where_line = ffelex_raw_where_line_;
2598               ffelex_token_->where_col = ffelex_raw_where_col_;
2599               ffelex_raw_where_line_ = ffewhere_line_unknown ();
2600               ffelex_raw_where_col_ = ffewhere_column_unknown ();
2601               c = ffelex_card_image_[++column];
2602               goto parse_raw_character; /* :::::::::::::::::::: */
2603             }
2604
2605           if (ffelex_names_)
2606             {
2607               ffelex_token_->where_line
2608                 = ffewhere_line_use (ffelex_token_->currentnames_line
2609                                      = ffewhere_line_use (ffelex_current_wl_));
2610               ffelex_token_->where_col
2611                 = ffewhere_column_use (ffelex_token_->currentnames_col
2612                                        = ffewhere_column_new (column + 1));
2613               ffelex_token_->type = FFELEX_typeNAMES;
2614             }
2615           else
2616             {
2617               ffelex_token_->where_line
2618                 = ffewhere_line_use (ffelex_current_wl_);
2619               ffelex_token_->where_col = ffewhere_column_new (column + 1);
2620               ffelex_token_->type = FFELEX_typeNAME;
2621             }
2622           ffelex_append_to_token_ (c);
2623           break;
2624
2625         default:
2626           ffelex_bad_1_ (FFEBAD_UNRECOGNIZED_CHARACTER,
2627                          ffelex_linecount_current_, column + 1);
2628           ffelex_finish_statement_ ();
2629           disallow_continuation_line = TRUE;
2630           ignore_disallowed_continuation = TRUE;
2631           goto beginning_of_line_again; /* :::::::::::::::::::: */
2632         }
2633       break;
2634
2635     case FFELEX_typeNAME:
2636       switch (c)
2637         {
2638         case 'A':
2639         case 'B':
2640         case 'C':
2641         case 'D':
2642         case 'E':
2643         case 'F':
2644         case 'G':
2645         case 'H':
2646         case 'I':
2647         case 'J':
2648         case 'K':
2649         case 'L':
2650         case 'M':
2651         case 'N':
2652         case 'O':
2653         case 'P':
2654         case 'Q':
2655         case 'R':
2656         case 'S':
2657         case 'T':
2658         case 'U':
2659         case 'V':
2660         case 'W':
2661         case 'X':
2662         case 'Y':
2663         case 'Z':
2664         case 'a':
2665         case 'b':
2666         case 'c':
2667         case 'd':
2668         case 'e':
2669         case 'f':
2670         case 'g':
2671         case 'h':
2672         case 'i':
2673         case 'j':
2674         case 'k':
2675         case 'l':
2676         case 'm':
2677         case 'n':
2678         case 'o':
2679         case 'p':
2680         case 'q':
2681         case 'r':
2682         case 's':
2683         case 't':
2684         case 'u':
2685         case 'v':
2686         case 'w':
2687         case 'x':
2688         case 'y':
2689         case 'z':
2690           c = ffesrc_char_source (c);
2691           /* Fall through.  */
2692         case '0':
2693         case '1':
2694         case '2':
2695         case '3':
2696         case '4':
2697         case '5':
2698         case '6':
2699         case '7':
2700         case '8':
2701         case '9':
2702         case '_':
2703         case '$':
2704           if ((c == '$')
2705               && !ffe_is_dollar_ok ())
2706             {
2707               ffelex_send_token_ ();
2708               goto parse_next_character;        /* :::::::::::::::::::: */
2709             }
2710           ffelex_append_to_token_ (c);
2711           break;
2712
2713         default:
2714           ffelex_send_token_ ();
2715           goto parse_next_character;    /* :::::::::::::::::::: */
2716         }
2717       break;
2718
2719     case FFELEX_typeNAMES:
2720       switch (c)
2721         {
2722         case 'A':
2723         case 'B':
2724         case 'C':
2725         case 'D':
2726         case 'E':
2727         case 'F':
2728         case 'G':
2729         case 'H':
2730         case 'I':
2731         case 'J':
2732         case 'K':
2733         case 'L':
2734         case 'M':
2735         case 'N':
2736         case 'O':
2737         case 'P':
2738         case 'Q':
2739         case 'R':
2740         case 'S':
2741         case 'T':
2742         case 'U':
2743         case 'V':
2744         case 'W':
2745         case 'X':
2746         case 'Y':
2747         case 'Z':
2748         case 'a':
2749         case 'b':
2750         case 'c':
2751         case 'd':
2752         case 'e':
2753         case 'f':
2754         case 'g':
2755         case 'h':
2756         case 'i':
2757         case 'j':
2758         case 'k':
2759         case 'l':
2760         case 'm':
2761         case 'n':
2762         case 'o':
2763         case 'p':
2764         case 'q':
2765         case 'r':
2766         case 's':
2767         case 't':
2768         case 'u':
2769         case 'v':
2770         case 'w':
2771         case 'x':
2772         case 'y':
2773         case 'z':
2774           c = ffesrc_char_source (c);
2775           /* Fall through.  */
2776         case '0':
2777         case '1':
2778         case '2':
2779         case '3':
2780         case '4':
2781         case '5':
2782         case '6':
2783         case '7':
2784         case '8':
2785         case '9':
2786         case '_':
2787         case '$':
2788           if ((c == '$')
2789               && !ffe_is_dollar_ok ())
2790             {
2791               ffelex_send_token_ ();
2792               goto parse_next_character;        /* :::::::::::::::::::: */
2793             }
2794           if (ffelex_token_->length < FFEWHERE_indexMAX)
2795             {
2796               ffewhere_track (&ffelex_token_->currentnames_line,
2797                               &ffelex_token_->currentnames_col,
2798                               ffelex_token_->wheretrack,
2799                               ffelex_token_->length,
2800                               ffelex_linecount_current_,
2801                               column + 1);
2802             }
2803           ffelex_append_to_token_ (c);
2804           break;
2805
2806         default:
2807           ffelex_send_token_ ();
2808           goto parse_next_character;    /* :::::::::::::::::::: */
2809         }
2810       break;
2811
2812     case FFELEX_typeNUMBER:
2813       switch (c)
2814         {
2815         case '0':
2816         case '1':
2817         case '2':
2818         case '3':
2819         case '4':
2820         case '5':
2821         case '6':
2822         case '7':
2823         case '8':
2824         case '9':
2825           ffelex_append_to_token_ (c);
2826           break;
2827
2828         default:
2829           ffelex_send_token_ ();
2830           goto parse_next_character;    /* :::::::::::::::::::: */
2831         }
2832       break;
2833
2834     case FFELEX_typeASTERISK:
2835       switch (c)
2836         {
2837         case '*':               /* ** */
2838           ffelex_token_->type = FFELEX_typePOWER;
2839           ffelex_send_token_ ();
2840           break;
2841
2842         default:                /* * not followed by another *. */
2843           ffelex_send_token_ ();
2844           goto parse_next_character;    /* :::::::::::::::::::: */
2845         }
2846       break;
2847
2848     case FFELEX_typeCOLON:
2849       switch (c)
2850         {
2851         case ':':               /* :: */
2852           ffelex_token_->type = FFELEX_typeCOLONCOLON;
2853           ffelex_send_token_ ();
2854           break;
2855
2856         default:                /* : not followed by another :. */
2857           ffelex_send_token_ ();
2858           goto parse_next_character;    /* :::::::::::::::::::: */
2859         }
2860       break;
2861
2862     case FFELEX_typeSLASH:
2863       switch (c)
2864         {
2865         case '/':               /* // */
2866           ffelex_token_->type = FFELEX_typeCONCAT;
2867           ffelex_send_token_ ();
2868           break;
2869
2870         case ')':               /* /) */
2871           ffelex_token_->type = FFELEX_typeCLOSE_ARRAY;
2872           ffelex_send_token_ ();
2873           break;
2874
2875         case '=':               /* /= */
2876           ffelex_token_->type = FFELEX_typeREL_NE;
2877           ffelex_send_token_ ();
2878           break;
2879
2880         default:
2881           ffelex_send_token_ ();
2882           goto parse_next_character;    /* :::::::::::::::::::: */
2883         }
2884       break;
2885
2886     case FFELEX_typeOPEN_PAREN:
2887       switch (c)
2888         {
2889         case '/':               /* (/ */
2890           ffelex_token_->type = FFELEX_typeOPEN_ARRAY;
2891           ffelex_send_token_ ();
2892           break;
2893
2894         default:
2895           ffelex_send_token_ ();
2896           goto parse_next_character;    /* :::::::::::::::::::: */
2897         }
2898       break;
2899
2900     case FFELEX_typeOPEN_ANGLE:
2901       switch (c)
2902         {
2903         case '=':               /* <= */
2904           ffelex_token_->type = FFELEX_typeREL_LE;
2905           ffelex_send_token_ ();
2906           break;
2907
2908         default:
2909           ffelex_send_token_ ();
2910           goto parse_next_character;    /* :::::::::::::::::::: */
2911         }
2912       break;
2913
2914     case FFELEX_typeEQUALS:
2915       switch (c)
2916         {
2917         case '=':               /* == */
2918           ffelex_token_->type = FFELEX_typeREL_EQ;
2919           ffelex_send_token_ ();
2920           break;
2921
2922         case '>':               /* => */
2923           ffelex_token_->type = FFELEX_typePOINTS;
2924           ffelex_send_token_ ();
2925           break;
2926
2927         default:
2928           ffelex_send_token_ ();
2929           goto parse_next_character;    /* :::::::::::::::::::: */
2930         }
2931       break;
2932
2933     case FFELEX_typeCLOSE_ANGLE:
2934       switch (c)
2935         {
2936         case '=':               /* >= */
2937           ffelex_token_->type = FFELEX_typeREL_GE;
2938           ffelex_send_token_ ();
2939           break;
2940
2941         default:
2942           ffelex_send_token_ ();
2943           goto parse_next_character;    /* :::::::::::::::::::: */
2944         }
2945       break;
2946
2947     default:
2948       assert ("Serious error!!" == NULL);
2949       abort ();
2950       break;
2951     }
2952
2953   c = ffelex_card_image_[++column];
2954
2955  parse_next_character:          /* :::::::::::::::::::: */
2956
2957   if (ffelex_raw_mode_ != 0)
2958     goto parse_raw_character;   /* :::::::::::::::::::: */
2959
2960   while (c == ' ')
2961     c = ffelex_card_image_[++column];
2962
2963   if ((c == '\0')
2964       || (c == '!')
2965       || ((c == '/')
2966           && (ffelex_card_image_[column + 1] == '*')))
2967     {
2968       if ((ffelex_number_of_tokens_ == ffelex_label_tokens_)
2969           && (ffelex_token_->type == FFELEX_typeNAMES)
2970           && (ffelex_token_->length == 3)
2971           && (ffesrc_strncmp_2c (ffe_case_match (),
2972                                  ffelex_token_->text,
2973                                  "END", "end", "End",
2974                                  3)
2975            == 0))
2976         {
2977           ffelex_finish_statement_ ();
2978           disallow_continuation_line = TRUE;
2979           ignore_disallowed_continuation = FALSE;
2980           goto beginning_of_line_again; /* :::::::::::::::::::: */
2981         }
2982       goto beginning_of_line;   /* :::::::::::::::::::: */
2983     }
2984   goto parse_nonraw_character;  /* :::::::::::::::::::: */
2985 }
2986
2987 /* ffelex_file_free -- Lex a given file in free source form
2988
2989    ffewhere wf;
2990    FILE *f;
2991    ffelex_file_free(wf,f);
2992
2993    Lexes the file according to Fortran 90 ANSI + VXT specifications.  */
2994
2995 ffelexHandler
2996 ffelex_file_free (ffewhereFile wf, FILE *f)
2997 {
2998   register int c = 0;           /* Character currently under consideration. */
2999   register ffewhereColumnNumber column = 0;     /* Not really; 0 means column 1... */
3000   bool continuation_line = FALSE;
3001   ffewhereColumnNumber continuation_column;
3002   int latest_char_in_file = 0;  /* For getting back into comment-skipping
3003                                    code. */
3004
3005   /* Lex is called for a particular file, not for a particular program unit.
3006      Yet the two events do share common characteristics.  The first line in a
3007      file or in a program unit cannot be a continuation line.  No token can
3008      be in mid-formation.  No current label for the statement exists, since
3009      there is no current statement. */
3010
3011   assert (ffelex_handler_ != NULL);
3012
3013   lineno = 0;
3014   input_filename = ffewhere_file_name (wf);
3015   ffelex_current_wf_ = wf;
3016   continuation_line = FALSE;
3017   ffelex_token_->type = FFELEX_typeNONE;
3018   ffelex_number_of_tokens_ = 0;
3019   ffelex_current_wl_ = ffewhere_line_unknown ();
3020   ffelex_current_wc_ = ffewhere_column_unknown ();
3021   latest_char_in_file = '\n';
3022
3023   /* Come here to get a new line. */
3024
3025  beginning_of_line:             /* :::::::::::::::::::: */
3026
3027   c = latest_char_in_file;
3028   if ((c == EOF) || ((c = ffelex_getc_ (f)) == EOF))
3029     {
3030
3031      end_of_file:               /* :::::::::::::::::::: */
3032
3033       /* Line ending in EOF instead of \n still counts as a whole line. */
3034
3035       ffelex_finish_statement_ ();
3036       ffewhere_line_kill (ffelex_current_wl_);
3037       ffewhere_column_kill (ffelex_current_wc_);
3038       return (ffelexHandler) ffelex_handler_;
3039     }
3040
3041   ffelex_next_line_ ();
3042
3043   ffelex_bad_line_ = FALSE;
3044
3045   /* Skip over initial-comment and empty lines as quickly as possible! */
3046
3047   while ((c == '\n')
3048          || (c == '!')
3049          || (c == '#'))
3050     {
3051       if (c == '#')
3052         c = ffelex_hash_ (f);
3053
3054      comment_line:              /* :::::::::::::::::::: */
3055
3056       while ((c != '\n') && (c != EOF))
3057         c = getc (f);
3058
3059       if (c == EOF)
3060         {
3061           ffelex_next_line_ ();
3062           goto end_of_file;     /* :::::::::::::::::::: */
3063         }
3064
3065       c = getc (f);
3066
3067       ffelex_next_line_ ();
3068
3069       if (c == EOF)
3070         goto end_of_file;       /* :::::::::::::::::::: */
3071     }
3072
3073   ffelex_saw_tab_ = FALSE;
3074
3075   column = ffelex_image_char_ (c, 0);
3076
3077   /* Read the entire line in as is (with whitespace processing).  */
3078
3079   while (((c = getc (f)) != '\n') && (c != EOF))
3080     column = ffelex_image_char_ (c, column);
3081
3082   if (ffelex_bad_line_)
3083     {
3084       ffelex_card_image_[column] = '\0';
3085       ffelex_card_length_ = column;
3086       goto comment_line;                /* :::::::::::::::::::: */
3087     }
3088
3089   /* If no tab, cut off line after column 132.  */
3090
3091   if (!ffelex_saw_tab_ && (column > FFELEX_FREE_MAX_COLUMNS_))
3092     column = FFELEX_FREE_MAX_COLUMNS_;
3093
3094   ffelex_card_image_[column] = '\0';
3095   ffelex_card_length_ = column;
3096
3097   /* Save next char in file so we can use register-based c while analyzing
3098      line we just read. */
3099
3100   latest_char_in_file = c;      /* Should be either '\n' or EOF. */
3101
3102   column = 0;
3103   continuation_column = 0;
3104
3105   /* Skip over initial spaces to see if the first nonblank character
3106      is exclamation point, newline, or EOF (line is therefore a comment) or
3107      ampersand (line is therefore a continuation line). */
3108
3109   while ((c = ffelex_card_image_[column]) == ' ')
3110     ++column;
3111
3112   switch (c)
3113     {
3114     case '!':
3115     case '\0':
3116       goto beginning_of_line;   /* :::::::::::::::::::: */
3117
3118     case '&':
3119       continuation_column = column + 1;
3120       break;
3121
3122     default:
3123       break;
3124     }
3125
3126   /* The line definitely has content of some kind, install new end-statement
3127      point for error messages. */
3128
3129   ffewhere_line_kill (ffelex_current_wl_);
3130   ffewhere_column_kill (ffelex_current_wc_);
3131   ffelex_current_wl_ = ffewhere_line_new (ffelex_linecount_current_);
3132   ffelex_current_wc_ = ffewhere_column_new (ffelex_card_length_ + 1);
3133
3134   /* Figure out which column to start parsing at. */
3135
3136   if (continuation_line)
3137     {
3138       if (continuation_column == 0)
3139         {
3140           if (ffelex_raw_mode_ != 0)
3141             {
3142               ffelex_bad_1_ (FFEBAD_BAD_CHAR_CONTINUE,
3143                              ffelex_linecount_current_, column + 1);
3144             }
3145           else if (ffelex_token_->type != FFELEX_typeNONE)
3146             {
3147               ffelex_bad_1_ (FFEBAD_BAD_LEXTOK_CONTINUE,
3148                              ffelex_linecount_current_, column + 1);
3149             }
3150         }
3151       else if (ffelex_is_free_char_ctx_contin_ (continuation_column))
3152         {                       /* Line contains only a single "&" as only
3153                                    nonblank character. */
3154           ffelex_bad_1_ (FFEBAD_BAD_FREE_CONTINUE,
3155                          ffelex_linecount_current_, continuation_column);
3156           goto beginning_of_line;       /* :::::::::::::::::::: */
3157         }
3158       column = continuation_column;
3159     }
3160   else
3161     column = 0;
3162
3163   c = ffelex_card_image_[column];
3164   continuation_line = FALSE;
3165
3166   /* Here is the main engine for parsing.  c holds the character at column.
3167      It is already known that c is not a blank, end of line, or shriek,
3168      unless ffelex_raw_mode_ is not 0 (indicating we are in a
3169      character/hollerith constant).  A partially filled token may already
3170      exist in ffelex_token_. */
3171
3172   if (ffelex_raw_mode_ != 0)
3173     {
3174
3175     parse_raw_character:        /* :::::::::::::::::::: */
3176
3177       switch (c)
3178         {
3179         case '&':
3180           if (ffelex_is_free_char_ctx_contin_ (column + 1))
3181             {
3182               continuation_line = TRUE;
3183               goto beginning_of_line;   /* :::::::::::::::::::: */
3184             }
3185           break;
3186
3187         case '\0':
3188           ffelex_finish_statement_ ();
3189           goto beginning_of_line;       /* :::::::::::::::::::: */
3190
3191         default:
3192           break;
3193         }
3194
3195       switch (ffelex_raw_mode_)
3196         {
3197         case -3:
3198           c = ffelex_backslash_ (c, column);
3199           if (c == EOF)
3200             break;
3201
3202           if (!ffelex_backslash_reconsider_)
3203             ffelex_append_to_token_ (c);
3204           ffelex_raw_mode_ = -1;
3205           break;
3206
3207         case -2:
3208           if (c == ffelex_raw_char_)
3209             {
3210               ffelex_raw_mode_ = -1;
3211               ffelex_append_to_token_ (c);
3212             }
3213           else
3214             {
3215               ffelex_raw_mode_ = 0;
3216               ffelex_backslash_reconsider_ = TRUE;
3217             }
3218           break;
3219
3220         case -1:
3221           if (c == ffelex_raw_char_)
3222             ffelex_raw_mode_ = -2;
3223           else
3224             {
3225               c = ffelex_backslash_ (c, column);
3226               if (c == EOF)
3227                 {
3228                   ffelex_raw_mode_ = -3;
3229                   break;
3230                 }
3231
3232               ffelex_append_to_token_ (c);
3233             }
3234           break;
3235
3236         default:
3237           c = ffelex_backslash_ (c, column);
3238           if (c == EOF)
3239             break;
3240
3241           if (!ffelex_backslash_reconsider_)
3242             {
3243               ffelex_append_to_token_ (c);
3244               --ffelex_raw_mode_;
3245             }
3246           break;
3247         }
3248
3249       if (ffelex_backslash_reconsider_)
3250         ffelex_backslash_reconsider_ = FALSE;
3251       else
3252         c = ffelex_card_image_[++column];
3253
3254       if (ffelex_raw_mode_ == 0)
3255         {
3256           ffelex_send_token_ ();
3257           assert (ffelex_raw_mode_ == 0);
3258           while (c == ' ')
3259             c = ffelex_card_image_[++column];
3260           if ((c == '\0') || (c == '!'))
3261             {
3262               ffelex_finish_statement_ ();
3263               goto beginning_of_line;   /* :::::::::::::::::::: */
3264             }
3265           if ((c == '&') && ffelex_is_free_nonc_ctx_contin_ (column + 1))
3266             {
3267               continuation_line = TRUE;
3268               goto beginning_of_line;   /* :::::::::::::::::::: */
3269             }
3270           goto parse_nonraw_character_noncontin;        /* :::::::::::::::::::: */
3271         }
3272       goto parse_raw_character; /* :::::::::::::::::::: */
3273     }
3274
3275  parse_nonraw_character:        /* :::::::::::::::::::: */
3276
3277   if ((c == '&') && ffelex_is_free_nonc_ctx_contin_ (column + 1))
3278     {
3279       continuation_line = TRUE;
3280       goto beginning_of_line;   /* :::::::::::::::::::: */
3281     }
3282
3283  parse_nonraw_character_noncontin:      /* :::::::::::::::::::: */
3284
3285   switch (ffelex_token_->type)
3286     {
3287     case FFELEX_typeNONE:
3288       if (c == ' ')
3289         {                       /* Otherwise
3290                                    finish-statement/continue-statement
3291                                    already checked. */
3292           while (c == ' ')
3293             c = ffelex_card_image_[++column];
3294           if ((c == '\0') || (c == '!'))
3295             {
3296               ffelex_finish_statement_ ();
3297               goto beginning_of_line;   /* :::::::::::::::::::: */
3298             }
3299           if ((c == '&') && ffelex_is_free_nonc_ctx_contin_ (column + 1))
3300             {
3301               continuation_line = TRUE;
3302               goto beginning_of_line;   /* :::::::::::::::::::: */
3303             }
3304         }
3305
3306       switch (c)
3307         {
3308         case '\"':
3309           ffelex_token_->type = FFELEX_typeQUOTE;
3310           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
3311           ffelex_token_->where_col = ffewhere_column_new (column + 1);
3312           ffelex_send_token_ ();
3313           break;
3314
3315         case '$':
3316           ffelex_token_->type = FFELEX_typeDOLLAR;
3317           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
3318           ffelex_token_->where_col = ffewhere_column_new (column + 1);
3319           ffelex_send_token_ ();
3320           break;
3321
3322         case '%':
3323           ffelex_token_->type = FFELEX_typePERCENT;
3324           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
3325           ffelex_token_->where_col = ffewhere_column_new (column + 1);
3326           ffelex_send_token_ ();
3327           break;
3328
3329         case '&':
3330           ffelex_token_->type = FFELEX_typeAMPERSAND;
3331           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
3332           ffelex_token_->where_col = ffewhere_column_new (column + 1);
3333           ffelex_send_token_ ();
3334           break;
3335
3336         case '\'':
3337           ffelex_token_->type = FFELEX_typeAPOSTROPHE;
3338           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
3339           ffelex_token_->where_col = ffewhere_column_new (column + 1);
3340           ffelex_send_token_ ();
3341           break;
3342
3343         case '(':
3344           ffelex_token_->type = FFELEX_typeOPEN_PAREN;
3345           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
3346           ffelex_token_->where_col = ffewhere_column_new (column + 1);
3347           break;
3348
3349         case ')':
3350           ffelex_token_->type = FFELEX_typeCLOSE_PAREN;
3351           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
3352           ffelex_token_->where_col = ffewhere_column_new (column + 1);
3353           ffelex_send_token_ ();
3354           break;
3355
3356         case '*':
3357           ffelex_token_->type = FFELEX_typeASTERISK;
3358           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
3359           ffelex_token_->where_col = ffewhere_column_new (column + 1);
3360           break;
3361
3362         case '+':
3363           ffelex_token_->type = FFELEX_typePLUS;
3364           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
3365           ffelex_token_->where_col = ffewhere_column_new (column + 1);
3366           ffelex_send_token_ ();
3367           break;
3368
3369         case ',':
3370           ffelex_token_->type = FFELEX_typeCOMMA;
3371           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
3372           ffelex_token_->where_col = ffewhere_column_new (column + 1);
3373           ffelex_send_token_ ();
3374           break;
3375
3376         case '-':
3377           ffelex_token_->type = FFELEX_typeMINUS;
3378           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
3379           ffelex_token_->where_col = ffewhere_column_new (column + 1);
3380           ffelex_send_token_ ();
3381           break;
3382
3383         case '.':
3384           ffelex_token_->type = FFELEX_typePERIOD;
3385           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
3386           ffelex_token_->where_col = ffewhere_column_new (column + 1);
3387           ffelex_send_token_ ();
3388           break;
3389
3390         case '/':
3391           ffelex_token_->type = FFELEX_typeSLASH;
3392           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
3393           ffelex_token_->where_col = ffewhere_column_new (column + 1);
3394           break;
3395
3396         case '0':
3397         case '1':
3398         case '2':
3399         case '3':
3400         case '4':
3401         case '5':
3402         case '6':
3403         case '7':
3404         case '8':
3405         case '9':
3406           ffelex_token_->type
3407             = ffelex_hexnum_ ? FFELEX_typeNAME : FFELEX_typeNUMBER;
3408           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
3409           ffelex_token_->where_col = ffewhere_column_new (column + 1);
3410           ffelex_append_to_token_ (c);
3411           break;
3412
3413         case ':':
3414           ffelex_token_->type = FFELEX_typeCOLON;
3415           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
3416           ffelex_token_->where_col = ffewhere_column_new (column + 1);
3417           break;
3418
3419         case ';':
3420           ffelex_token_->type = FFELEX_typeSEMICOLON;
3421           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
3422           ffelex_token_->where_col = ffewhere_column_new (column + 1);
3423           ffelex_permit_include_ = TRUE;
3424           ffelex_send_token_ ();
3425           ffelex_permit_include_ = FALSE;
3426           break;
3427
3428         case '<':
3429           ffelex_token_->type = FFELEX_typeOPEN_ANGLE;
3430           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
3431           ffelex_token_->where_col = ffewhere_column_new (column + 1);
3432           break;
3433
3434         case '=':
3435           ffelex_token_->type = FFELEX_typeEQUALS;
3436           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
3437           ffelex_token_->where_col = ffewhere_column_new (column + 1);
3438           break;
3439
3440         case '>':
3441           ffelex_token_->type = FFELEX_typeCLOSE_ANGLE;
3442           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
3443           ffelex_token_->where_col = ffewhere_column_new (column + 1);
3444           break;
3445
3446         case '?':
3447           ffelex_token_->type = FFELEX_typeQUESTION;
3448           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
3449           ffelex_token_->where_col = ffewhere_column_new (column + 1);
3450           ffelex_send_token_ ();
3451           break;
3452
3453         case '_':
3454           if (1 || ffe_is_90 ())
3455             {
3456               ffelex_token_->type = FFELEX_typeUNDERSCORE;
3457               ffelex_token_->where_line
3458                 = ffewhere_line_use (ffelex_current_wl_);
3459               ffelex_token_->where_col
3460                 = ffewhere_column_new (column + 1);
3461               ffelex_send_token_ ();
3462               break;
3463             }
3464           /* Fall through. */
3465         case 'A':
3466         case 'B':
3467         case 'C':
3468         case 'D':
3469         case 'E':
3470         case 'F':
3471         case 'G':
3472         case 'H':
3473         case 'I':
3474         case 'J':
3475         case 'K':
3476         case 'L':
3477         case 'M':
3478         case 'N':
3479         case 'O':
3480         case 'P':
3481         case 'Q':
3482         case 'R':
3483         case 'S':
3484         case 'T':
3485         case 'U':
3486         case 'V':
3487         case 'W':
3488         case 'X':
3489         case 'Y':
3490         case 'Z':
3491         case 'a':
3492         case 'b':
3493         case 'c':
3494         case 'd':
3495         case 'e':
3496         case 'f':
3497         case 'g':
3498         case 'h':
3499         case 'i':
3500         case 'j':
3501         case 'k':
3502         case 'l':
3503         case 'm':
3504         case 'n':
3505         case 'o':
3506         case 'p':
3507         case 'q':
3508         case 'r':
3509         case 's':
3510         case 't':
3511         case 'u':
3512         case 'v':
3513         case 'w':
3514         case 'x':
3515         case 'y':
3516         case 'z':
3517           c = ffesrc_char_source (c);
3518
3519           if (ffesrc_char_match_init (c, 'H', 'h')
3520               && ffelex_expecting_hollerith_ != 0)
3521             {
3522               ffelex_raw_mode_ = ffelex_expecting_hollerith_;
3523               ffelex_token_->type = FFELEX_typeHOLLERITH;
3524               ffelex_token_->where_line = ffelex_raw_where_line_;
3525               ffelex_token_->where_col = ffelex_raw_where_col_;
3526               ffelex_raw_where_line_ = ffewhere_line_unknown ();
3527               ffelex_raw_where_col_ = ffewhere_column_unknown ();
3528               c = ffelex_card_image_[++column];
3529               goto parse_raw_character; /* :::::::::::::::::::: */
3530             }
3531
3532           if (ffelex_names_pure_)
3533             {
3534               ffelex_token_->where_line
3535                 = ffewhere_line_use (ffelex_token_->currentnames_line
3536                                      = ffewhere_line_use (ffelex_current_wl_));
3537               ffelex_token_->where_col
3538                 = ffewhere_column_use (ffelex_token_->currentnames_col
3539                                        = ffewhere_column_new (column + 1));
3540               ffelex_token_->type = FFELEX_typeNAMES;
3541             }
3542           else
3543             {
3544               ffelex_token_->where_line
3545                 = ffewhere_line_use (ffelex_current_wl_);
3546               ffelex_token_->where_col = ffewhere_column_new (column + 1);
3547               ffelex_token_->type = FFELEX_typeNAME;
3548             }
3549           ffelex_append_to_token_ (c);
3550           break;
3551
3552         default:
3553           ffelex_bad_1_ (FFEBAD_UNRECOGNIZED_CHARACTER,
3554                          ffelex_linecount_current_, column + 1);
3555           ffelex_finish_statement_ ();
3556           goto beginning_of_line;       /* :::::::::::::::::::: */
3557         }
3558       break;
3559
3560     case FFELEX_typeNAME:
3561       switch (c)
3562         {
3563         case 'A':
3564         case 'B':
3565         case 'C':
3566         case 'D':
3567         case 'E':
3568         case 'F':
3569         case 'G':
3570         case 'H':
3571         case 'I':
3572         case 'J':
3573         case 'K':
3574         case 'L':
3575         case 'M':
3576         case 'N':
3577         case 'O':
3578         case 'P':
3579         case 'Q':
3580         case 'R':
3581         case 'S':
3582         case 'T':
3583         case 'U':
3584         case 'V':
3585         case 'W':
3586         case 'X':
3587         case 'Y':
3588         case 'Z':
3589         case 'a':
3590         case 'b':
3591         case 'c':
3592         case 'd':
3593         case 'e':
3594         case 'f':
3595         case 'g':
3596         case 'h':
3597         case 'i':
3598         case 'j':
3599         case 'k':
3600         case 'l':
3601         case 'm':
3602         case 'n':
3603         case 'o':
3604         case 'p':
3605         case 'q':
3606         case 'r':
3607         case 's':
3608         case 't':
3609         case 'u':
3610         case 'v':
3611         case 'w':
3612         case 'x':
3613         case 'y':
3614         case 'z':
3615           c = ffesrc_char_source (c);
3616           /* Fall through.  */
3617         case '0':
3618         case '1':
3619         case '2':
3620         case '3':
3621         case '4':
3622         case '5':
3623         case '6':
3624         case '7':
3625         case '8':
3626         case '9':
3627         case '_':
3628         case '$':
3629           if ((c == '$')
3630               && !ffe_is_dollar_ok ())
3631             {
3632               ffelex_send_token_ ();
3633               goto parse_next_character;        /* :::::::::::::::::::: */
3634             }
3635           ffelex_append_to_token_ (c);
3636           break;
3637
3638         default:
3639           ffelex_send_token_ ();
3640           goto parse_next_character;    /* :::::::::::::::::::: */
3641         }
3642       break;
3643
3644     case FFELEX_typeNAMES:
3645       switch (c)
3646         {
3647         case 'A':
3648         case 'B':
3649         case 'C':
3650         case 'D':
3651         case 'E':
3652         case 'F':
3653         case 'G':
3654         case 'H':
3655         case 'I':
3656         case 'J':
3657         case 'K':
3658         case 'L':
3659         case 'M':
3660         case 'N':
3661         case 'O':
3662         case 'P':
3663         case 'Q':
3664         case 'R':
3665         case 'S':
3666         case 'T':
3667         case 'U':
3668         case 'V':
3669         case 'W':
3670         case 'X':
3671         case 'Y':
3672         case 'Z':
3673         case 'a':
3674         case 'b':
3675         case 'c':
3676         case 'd':
3677         case 'e':
3678         case 'f':
3679         case 'g':
3680         case 'h':
3681         case 'i':
3682         case 'j':
3683         case 'k':
3684         case 'l':
3685         case 'm':
3686         case 'n':
3687         case 'o':
3688         case 'p':
3689         case 'q':
3690         case 'r':
3691         case 's':
3692         case 't':
3693         case 'u':
3694         case 'v':
3695         case 'w':
3696         case 'x':
3697         case 'y':
3698         case 'z':
3699           c = ffesrc_char_source (c);
3700           /* Fall through.  */
3701         case '0':
3702         case '1':
3703         case '2':
3704         case '3':
3705         case '4':
3706         case '5':
3707         case '6':
3708         case '7':
3709         case '8':
3710         case '9':
3711         case '_':
3712         case '$':
3713           if ((c == '$')
3714               && !ffe_is_dollar_ok ())
3715             {
3716               ffelex_send_token_ ();
3717               goto parse_next_character;        /* :::::::::::::::::::: */
3718             }
3719           if (ffelex_token_->length < FFEWHERE_indexMAX)
3720             {
3721               ffewhere_track (&ffelex_token_->currentnames_line,
3722                               &ffelex_token_->currentnames_col,
3723                               ffelex_token_->wheretrack,
3724                               ffelex_token_->length,
3725                               ffelex_linecount_current_,
3726                               column + 1);
3727             }
3728           ffelex_append_to_token_ (c);
3729           break;
3730
3731         default:
3732           ffelex_send_token_ ();
3733           goto parse_next_character;    /* :::::::::::::::::::: */
3734         }
3735       break;
3736
3737     case FFELEX_typeNUMBER:
3738       switch (c)
3739         {
3740         case '0':
3741         case '1':
3742         case '2':
3743         case '3':
3744         case '4':
3745         case '5':
3746         case '6':
3747         case '7':
3748         case '8':
3749         case '9':
3750           ffelex_append_to_token_ (c);
3751           break;
3752
3753         default:
3754           ffelex_send_token_ ();
3755           goto parse_next_character;    /* :::::::::::::::::::: */
3756         }
3757       break;
3758
3759     case FFELEX_typeASTERISK:
3760       switch (c)
3761         {
3762         case '*':               /* ** */
3763           ffelex_token_->type = FFELEX_typePOWER;
3764           ffelex_send_token_ ();
3765           break;
3766
3767         default:                /* * not followed by another *. */
3768           ffelex_send_token_ ();
3769           goto parse_next_character;    /* :::::::::::::::::::: */
3770         }
3771       break;
3772
3773     case FFELEX_typeCOLON:
3774       switch (c)
3775         {
3776         case ':':               /* :: */
3777           ffelex_token_->type = FFELEX_typeCOLONCOLON;
3778           ffelex_send_token_ ();
3779           break;
3780
3781         default:                /* : not followed by another :. */
3782           ffelex_send_token_ ();
3783           goto parse_next_character;    /* :::::::::::::::::::: */
3784         }
3785       break;
3786
3787     case FFELEX_typeSLASH:
3788       switch (c)
3789         {
3790         case '/':               /* // */
3791           ffelex_token_->type = FFELEX_typeCONCAT;
3792           ffelex_send_token_ ();
3793           break;
3794
3795         case ')':               /* /) */
3796           ffelex_token_->type = FFELEX_typeCLOSE_ARRAY;
3797           ffelex_send_token_ ();
3798           break;
3799
3800         case '=':               /* /= */
3801           ffelex_token_->type = FFELEX_typeREL_NE;
3802           ffelex_send_token_ ();
3803           break;
3804
3805         default:
3806           ffelex_send_token_ ();
3807           goto parse_next_character;    /* :::::::::::::::::::: */
3808         }
3809       break;
3810
3811     case FFELEX_typeOPEN_PAREN:
3812       switch (c)
3813         {
3814         case '/':               /* (/ */
3815           ffelex_token_->type = FFELEX_typeOPEN_ARRAY;
3816           ffelex_send_token_ ();
3817           break;
3818
3819         default:
3820           ffelex_send_token_ ();
3821           goto parse_next_character;    /* :::::::::::::::::::: */
3822         }
3823       break;
3824
3825     case FFELEX_typeOPEN_ANGLE:
3826       switch (c)
3827         {
3828         case '=':               /* <= */
3829           ffelex_token_->type = FFELEX_typeREL_LE;
3830           ffelex_send_token_ ();
3831           break;
3832
3833         default:
3834           ffelex_send_token_ ();
3835           goto parse_next_character;    /* :::::::::::::::::::: */
3836         }
3837       break;
3838
3839     case FFELEX_typeEQUALS:
3840       switch (c)
3841         {
3842         case '=':               /* == */
3843           ffelex_token_->type = FFELEX_typeREL_EQ;
3844           ffelex_send_token_ ();
3845           break;
3846
3847         case '>':               /* => */
3848           ffelex_token_->type = FFELEX_typePOINTS;
3849           ffelex_send_token_ ();
3850           break;
3851
3852         default:
3853           ffelex_send_token_ ();
3854           goto parse_next_character;    /* :::::::::::::::::::: */
3855         }
3856       break;
3857
3858     case FFELEX_typeCLOSE_ANGLE:
3859       switch (c)
3860         {
3861         case '=':               /* >= */
3862           ffelex_token_->type = FFELEX_typeREL_GE;
3863           ffelex_send_token_ ();
3864           break;
3865
3866         default:
3867           ffelex_send_token_ ();
3868           goto parse_next_character;    /* :::::::::::::::::::: */
3869         }
3870       break;
3871
3872     default:
3873       assert ("Serious error!" == NULL);
3874       abort ();
3875       break;
3876     }
3877
3878   c = ffelex_card_image_[++column];
3879
3880  parse_next_character:          /* :::::::::::::::::::: */
3881
3882   if (ffelex_raw_mode_ != 0)
3883     goto parse_raw_character;   /* :::::::::::::::::::: */
3884
3885   if ((c == '\0') || (c == '!'))
3886     {
3887       ffelex_finish_statement_ ();
3888       goto beginning_of_line;   /* :::::::::::::::::::: */
3889     }
3890   goto parse_nonraw_character;  /* :::::::::::::::::::: */
3891 }
3892
3893 /* See the code in com.c that calls this to understand why.  */
3894
3895 void
3896 ffelex_hash_kludge (FILE *finput)
3897 {
3898   /* If you change this constant string, you have to change whatever
3899      code might thus be affected by it in terms of having to use
3900      ffelex_getc_() instead of getc() in the lexers and _hash_.  */
3901   static const char match[] = "# 1 \"";
3902   static int kludge[ARRAY_SIZE (match) + 1];
3903   int c;
3904   const char *p;
3905   int *q;
3906
3907   /* Read chars as long as they match the target string.
3908      Copy them into an array that will serve as a record
3909      of what we read (essentially a multi-char ungetc(),
3910      for code that uses ffelex_getc_ instead of getc() elsewhere
3911      in the lexer.  */
3912   for (p = &match[0], q = &kludge[0], c = getc (finput);
3913        (c == *p) && (*p != '\0') && (c != EOF);
3914        ++p, ++q, c = getc (finput))
3915     *q = c;
3916
3917   *q = c;                       /* Might be EOF, which requires int. */
3918   *++q = 0;
3919
3920   ffelex_kludge_chars_ = &kludge[0];
3921
3922   if (*p == 0)
3923     {
3924       ffelex_kludge_flag_ = TRUE;
3925       ++ffelex_kludge_chars_;
3926       ffelex_hash_ (finput);    /* Handle it NOW rather than later. */
3927       ffelex_kludge_flag_ = FALSE;
3928     }
3929 }
3930
3931 void
3932 ffelex_init_1 ()
3933 {
3934   unsigned int i;
3935
3936   ffelex_final_nontab_column_ = ffe_fixed_line_length ();
3937   ffelex_card_size_ = FFELEX_columnINITIAL_SIZE_;
3938   ffelex_card_image_ = malloc_new_ksr (malloc_pool_image (),
3939                                        "FFELEX card image",
3940                                        FFELEX_columnINITIAL_SIZE_ + 9);
3941   ffelex_card_image_[0] = '\0';
3942
3943   for (i = 0; i < 256; ++i)
3944     ffelex_first_char_[i] = FFELEX_typeERROR;
3945
3946   ffelex_first_char_['\t'] = FFELEX_typeRAW;
3947   ffelex_first_char_['\n'] = FFELEX_typeCOMMENT;
3948   ffelex_first_char_['\v'] = FFELEX_typeCOMMENT;
3949   ffelex_first_char_['\f'] = FFELEX_typeCOMMENT;
3950   ffelex_first_char_['\r'] = FFELEX_typeRAW;
3951   ffelex_first_char_[' '] = FFELEX_typeRAW;
3952   ffelex_first_char_['!'] = FFELEX_typeCOMMENT;
3953   ffelex_first_char_['*'] = FFELEX_typeCOMMENT;
3954   ffelex_first_char_['/'] = FFELEX_typeSLASH;
3955   ffelex_first_char_['&'] = FFELEX_typeRAW;
3956   ffelex_first_char_['#'] = FFELEX_typeHASH;
3957
3958   for (i = '0'; i <= '9'; ++i)
3959     ffelex_first_char_[i] = FFELEX_typeRAW;
3960
3961   if ((ffe_case_match () == FFE_caseNONE)
3962       || ((ffe_case_match () == FFE_caseUPPER)
3963           && (ffe_case_source () != FFE_caseLOWER))     /* Idiot!  :-) */
3964       || ((ffe_case_match () == FFE_caseLOWER)
3965           && (ffe_case_source () == FFE_caseLOWER)))
3966     {
3967       ffelex_first_char_['C'] = FFELEX_typeCOMMENT;
3968       ffelex_first_char_['D'] = FFELEX_typeCOMMENT;
3969     }
3970   if ((ffe_case_match () == FFE_caseNONE)
3971       || ((ffe_case_match () == FFE_caseLOWER)
3972           && (ffe_case_source () != FFE_caseUPPER))     /* Idiot!  :-) */
3973       || ((ffe_case_match () == FFE_caseUPPER)
3974           && (ffe_case_source () == FFE_caseUPPER)))
3975     {
3976       ffelex_first_char_['c'] = FFELEX_typeCOMMENT;
3977       ffelex_first_char_['d'] = FFELEX_typeCOMMENT;
3978     }
3979
3980   ffelex_linecount_current_ = 0;
3981   ffelex_linecount_next_ = 1;
3982   ffelex_raw_mode_ = 0;
3983   ffelex_set_include_ = FALSE;
3984   ffelex_permit_include_ = FALSE;
3985   ffelex_names_ = TRUE;         /* First token in program is a names. */
3986   ffelex_names_pure_ = FALSE;   /* Free-form lexer does NAMES only for
3987                                    FORMAT. */
3988   ffelex_hexnum_ = FALSE;
3989   ffelex_expecting_hollerith_ = 0;
3990   ffelex_raw_where_line_ = ffewhere_line_unknown ();
3991   ffelex_raw_where_col_ = ffewhere_column_unknown ();
3992
3993   ffelex_token_ = ffelex_token_new_ ();
3994   ffelex_token_->type = FFELEX_typeNONE;
3995   ffelex_token_->uses = 1;
3996   ffelex_token_->where_line = ffewhere_line_unknown ();
3997   ffelex_token_->where_col = ffewhere_column_unknown ();
3998   ffelex_token_->text = NULL;
3999
4000   ffelex_handler_ = NULL;
4001 }
4002
4003 /* ffelex_is_names_expected -- Is the current parser expecting NAMES vs. NAME?
4004
4005    if (ffelex_is_names_expected())
4006        // Deliver NAMES token
4007      else
4008        // Deliver NAME token
4009
4010    Must be called while lexer is active, obviously.  */
4011
4012 bool
4013 ffelex_is_names_expected ()
4014 {
4015   return ffelex_names_;
4016 }
4017
4018 /* Current card image, which has the master linecount number
4019    ffelex_linecount_current_.  */
4020
4021 char *
4022 ffelex_line ()
4023 {
4024   return ffelex_card_image_;
4025 }
4026
4027 /* ffelex_line_length -- Return length of current lexer line
4028
4029    printf("Length is %lu\n",ffelex_line_length());
4030
4031    Must be called while lexer is active, obviously.  */
4032
4033 ffewhereColumnNumber
4034 ffelex_line_length ()
4035 {
4036   return ffelex_card_length_;
4037 }
4038
4039 /* Master line count of current card image, or 0 if no card image
4040    is current.  */
4041
4042 ffewhereLineNumber
4043 ffelex_line_number ()
4044 {
4045   return ffelex_linecount_current_;
4046 }
4047
4048 /* ffelex_set_expecting_hollerith -- Set hollerith expectation status
4049
4050    ffelex_set_expecting_hollerith(0);
4051
4052    Lex initially assumes no hollerith constant is about to show up.  If
4053    syntactic analysis expects one, it should call this function with the
4054    number of characters expected in the constant immediately after recognizing
4055    the decimal number preceding the "H" and the constant itself.  Then, if
4056    the next character is indeed H, the lexer will interpret it as beginning
4057    a hollerith constant and ship the token formed by reading the specified
4058    number of characters (interpreting blanks and otherwise-comments too)
4059    from the input file.  It is up to syntactic analysis to call this routine
4060    again with 0 to turn hollerith detection off immediately upon receiving
4061    the token that might or might not be HOLLERITH.
4062
4063    Also call this after seeing an APOSTROPHE or QUOTE token that begins a
4064    character constant.  Pass the expected termination character (apostrophe
4065    or quote).
4066
4067    Pass for length either the length of the hollerith (must be > 0), -1
4068    meaning expecting a character constant, or 0 to cancel expectation of
4069    a hollerith only after calling it with a length of > 0 and receiving the
4070    next token (which may or may not have been a HOLLERITH token).
4071
4072    Pass for which either an apostrophe or quote when passing length of -1.
4073    Else which is a don't-care.
4074
4075    Pass for line and column the line/column info for the token beginning the
4076    character or hollerith constant, for use in error messages, when passing
4077    a length of -1 -- this function will invoke ffewhere_line/column_use to
4078    make its own copies.  Else line and column are don't-cares (when length
4079    is 0) and the outstanding copies of the previous line/column info, if
4080    still around, are killed.
4081
4082    21-Feb-90  JCB  3.1
4083       When called with length of 0, also zero ffelex_raw_mode_.  This is
4084       so ffest_save_ can undo the effects of replaying tokens like
4085       APOSTROPHE and QUOTE.
4086    25-Jan-90  JCB  3.0
4087       New line, column arguments allow error messages to point to the true
4088       beginning of a character/hollerith constant, rather than the beginning
4089       of the content part, which makes them more consistent and helpful.
4090    05-Nov-89  JCB  2.0
4091       New "which" argument allows caller to specify termination character,
4092       which should be apostrophe or double-quote, to support Fortran 90.  */
4093
4094 void
4095 ffelex_set_expecting_hollerith (long length, char which,
4096                                 ffewhereLine line, ffewhereColumn column)
4097 {
4098
4099   /* First kill the pending line/col info, if any (should only be pending
4100      when this call has length==0, the previous call had length>0, and a
4101      non-HOLLERITH token was sent in between the calls, but play it safe). */
4102
4103   ffewhere_line_kill (ffelex_raw_where_line_);
4104   ffewhere_column_kill (ffelex_raw_where_col_);
4105
4106   /* Now handle the length function. */
4107   switch (length)
4108     {
4109     case 0:
4110       ffelex_expecting_hollerith_ = 0;
4111       ffelex_raw_mode_ = 0;
4112       ffelex_raw_where_line_ = ffewhere_line_unknown ();
4113       ffelex_raw_where_col_ = ffewhere_column_unknown ();
4114       return;                   /* Don't set new line/column info from args. */
4115
4116     case -1:
4117       ffelex_raw_mode_ = -1;
4118       ffelex_raw_char_ = which;
4119       break;
4120
4121     default:                    /* length > 0 */
4122       ffelex_expecting_hollerith_ = length;
4123       break;
4124     }
4125
4126   /* Now set new line/column information from passed args. */
4127
4128   ffelex_raw_where_line_ = ffewhere_line_use (line);
4129   ffelex_raw_where_col_ = ffewhere_column_use (column);
4130 }
4131
4132 /* ffelex_set_handler -- Set handler for tokens before calling _fixed or _free
4133
4134    ffelex_set_handler((ffelexHandler) my_first_handler);
4135
4136    Must be called before calling ffelex_file_fixed or ffelex_file_free or
4137    after they return, but not while they are active.  */
4138
4139 void
4140 ffelex_set_handler (ffelexHandler first)
4141 {
4142   ffelex_handler_ = first;
4143 }
4144
4145 /* ffelex_set_hexnum -- Set hexnum flag
4146
4147    ffelex_set_hexnum(TRUE);
4148
4149    Lex normally interprets a token starting with [0-9] as a NUMBER token,
4150    so if it sees a [A-Za-z] in it, it stops parsing the NUMBER and leaves
4151    the character as the first of the next token.  But when parsing a
4152    hexadecimal number, by calling this function with TRUE before starting
4153    the parse of the token itself, lex will interpret [0-9] as the start
4154    of a NAME token.  */
4155
4156 void
4157 ffelex_set_hexnum (bool f)
4158 {
4159   ffelex_hexnum_ = f;
4160 }
4161
4162 /* ffelex_set_include -- Set INCLUDE file to be processed next
4163
4164    ffewhereFile wf;  // The ffewhereFile object for the file.
4165    bool free_form;  // TRUE means read free-form file, FALSE fixed-form.
4166    FILE *fi;  // The file to INCLUDE.
4167    ffelex_set_include(wf,free_form,fi);
4168
4169    Must be called only after receiving the EOS token following a valid
4170    INCLUDE statement specifying a file that has already been successfully
4171    opened.  */
4172
4173 void
4174 ffelex_set_include (ffewhereFile wf, bool free_form, FILE *fi)
4175 {
4176   assert (ffelex_permit_include_);
4177   assert (!ffelex_set_include_);
4178   ffelex_set_include_ = TRUE;
4179   ffelex_include_free_form_ = free_form;
4180   ffelex_include_file_ = fi;
4181   ffelex_include_wherefile_ = wf;
4182 }
4183
4184 /* ffelex_set_names -- Set names/name flag, names = TRUE
4185
4186    ffelex_set_names(FALSE);
4187
4188    Lex initially assumes multiple names should be formed.  If this function is
4189    called with FALSE, then single names are formed instead.  The differences
4190    are a difference in the token type (FFELEX_typeNAMES vs. FFELEX_typeNAME)
4191    and in whether full source-location tracking is performed (it is for
4192    multiple names, not for single names), which is more expensive in terms of
4193    CPU time.  */
4194
4195 void
4196 ffelex_set_names (bool f)
4197 {
4198   ffelex_names_ = f;
4199   if (!f)
4200     ffelex_names_pure_ = FALSE;
4201 }
4202
4203 /* ffelex_set_names_pure -- Set names/name (pure) flag, names = TRUE
4204
4205    ffelex_set_names_pure(FALSE);
4206
4207    Like ffelex_set_names, except affects both lexers.  Normally, the
4208    free-form lexer need not generate NAMES tokens because adjacent NAME
4209    tokens must be separated by spaces which causes the lexer to generate
4210    separate tokens for analysis (whereas in fixed-form the spaces are
4211    ignored resulting in one long token).  But in FORMAT statements, for
4212    some reason, the Fortran 90 standard specifies that spaces can occur
4213    anywhere within a format-item-list with no effect on the format spec
4214    (except of course within character string edit descriptors), which means
4215    that "1PE14.2" and "1 P E 1 4 . 2" are equivalent.  For the FORMAT
4216    statement handling, the existence of spaces makes it hard to deal with,
4217    because each token is seen distinctly (i.e. seven tokens in the latter
4218    example).  But when no spaces are provided, as in the former example,
4219    then only four tokens are generated, NUMBER("1"), NAME("PE14"), PERIOD,
4220    NUMBER ("2").  By generating a NAMES instead of NAME, three things happen:
4221    One, ffest_kw_format_ does a substring rather than full-string match,
4222    and thus matches "PE14" to "PE"; two, ffelex_token_xyz_from_names functions
4223    may be used to pull NAME/NAMES and NUMBER tokens out of the NAMES token;
4224    and three, error reporting can point to the actual character rather than
4225    at or prior to it.  The first two things could be resolved by providing
4226    alternate functions fairly easy, thus allowing FORMAT handling to expect
4227    both lexers to generate NAME tokens instead of NAMES (with otherwise minor
4228    changes to FORMAT parsing), but the third, error reporting, would suffer,
4229    and when one makes mistakes in a FORMAT, believe me, one wants a pointer
4230    to exactly where the compilers thinks the problem is, to even begin to get
4231    a handle on it.  So there.  */
4232
4233 void
4234 ffelex_set_names_pure (bool f)
4235 {
4236   ffelex_names_pure_ = f;
4237   ffelex_names_ = f;
4238 }
4239
4240 /* ffelex_splice_tokens -- Splice off and send tokens from a NAMES
4241
4242    return (ffelexHandler) ffelex_splice_tokens(first_handler,master_token,
4243          start_char_index);
4244
4245    Returns first_handler if start_char_index chars into master_token (which
4246    must be a NAMES token) is '\0'. Else, creates a subtoken from that
4247    char, either NUMBER (if it is a digit), a NAME (if a valid firstnamechar),
4248    an UNDERSCORE (if an underscore), or DOLLAR (if a dollar sign)
4249    and sends it to first_handler. If anything other than NAME is sent, the
4250    character at the end of it in the master token is examined to see if it
4251    begins a NAME, NUMBER, UNDERSCORE, or DOLLAR, and, if so,
4252    the handler returned by first_handler is invoked with that token, and
4253    this process is repeated until the end of the master token or a NAME
4254    token is reached.  */
4255
4256 ffelexHandler
4257 ffelex_splice_tokens (ffelexHandler first, ffelexToken master,
4258                       ffeTokenLength start)
4259 {
4260   unsigned char *p;
4261   ffeTokenLength i;
4262   ffelexToken t;
4263
4264   p = ffelex_token_text (master) + (i = start);
4265
4266   while (*p != '\0')
4267     {
4268       if (ISDIGIT (*p))
4269         {
4270           t = ffelex_token_number_from_names (master, i);
4271           p += ffelex_token_length (t);
4272           i += ffelex_token_length (t);
4273         }
4274       else if (ffesrc_is_name_init (*p))
4275         {
4276           t = ffelex_token_name_from_names (master, i, 0);
4277           p += ffelex_token_length (t);
4278           i += ffelex_token_length (t);
4279         }
4280       else if (*p == '$')
4281         {
4282           t = ffelex_token_dollar_from_names (master, i);
4283           ++p;
4284           ++i;
4285         }
4286       else if (*p == '_')
4287         {
4288           t = ffelex_token_uscore_from_names (master, i);
4289           ++p;
4290           ++i;
4291         }
4292       else
4293         {
4294           assert ("not a valid NAMES character" == NULL);
4295           t = NULL;
4296         }
4297       assert (first != NULL);
4298       first = (ffelexHandler) (*first) (t);
4299       ffelex_token_kill (t);
4300     }
4301
4302   return first;
4303 }
4304
4305 /* ffelex_swallow_tokens -- Eat all tokens delivered to me
4306
4307    return ffelex_swallow_tokens;
4308
4309    Return this handler when you don't want to look at any more tokens in the
4310    statement because you've encountered an unrecoverable error in the
4311    statement.  */
4312
4313 ffelexHandler
4314 ffelex_swallow_tokens (ffelexToken t, ffelexHandler handler)
4315 {
4316   assert (handler != NULL);
4317
4318   if ((t != NULL) && ((ffelex_token_type (t) == FFELEX_typeEOS)
4319                       || (ffelex_token_type (t) == FFELEX_typeSEMICOLON)))
4320     return (ffelexHandler) (*handler) (t);
4321
4322   ffelex_eos_handler_ = handler;
4323   return (ffelexHandler) ffelex_swallow_tokens_;
4324 }
4325
4326 /* ffelex_token_dollar_from_names -- Return a dollar from within a names token
4327
4328    ffelexToken t;
4329    t = ffelex_token_dollar_from_names(t,6);
4330
4331    It's as if you made a new token of dollar type having the dollar
4332    at, in the example above, the sixth character of the NAMES token.  */
4333
4334 ffelexToken
4335 ffelex_token_dollar_from_names (ffelexToken t, ffeTokenLength start)
4336 {
4337   ffelexToken nt;
4338
4339   assert (t != NULL);
4340   assert (ffelex_token_type (t) == FFELEX_typeNAMES);
4341   assert (start < t->length);
4342   assert (t->text[start] == '$');
4343
4344   /* Now make the token. */
4345
4346   nt = ffelex_token_new_ ();
4347   nt->type = FFELEX_typeDOLLAR;
4348   nt->length = 0;
4349   nt->uses = 1;
4350   ffewhere_set_from_track (&nt->where_line, &nt->where_col, t->where_line,
4351                            t->where_col, t->wheretrack, start);
4352   nt->text = NULL;
4353   return nt;
4354 }
4355
4356 /* ffelex_token_kill -- Decrement use count for token, kill if no uses left
4357
4358    ffelexToken t;
4359    ffelex_token_kill(t);
4360
4361    Complements a call to ffelex_token_use or ffelex_token_new_....  */
4362
4363 void
4364 ffelex_token_kill (ffelexToken t)
4365 {
4366   assert (t != NULL);
4367
4368   assert (t->uses > 0);
4369
4370   if (--t->uses != 0)
4371     return;
4372
4373   --ffelex_total_tokens_;
4374
4375   if (t->type == FFELEX_typeNAMES)
4376     ffewhere_track_kill (t->where_line, t->where_col,
4377                          t->wheretrack, t->length);
4378   ffewhere_line_kill (t->where_line);
4379   ffewhere_column_kill (t->where_col);
4380   if (t->text != NULL)
4381     malloc_kill_ksr (malloc_pool_image (), t->text, t->size + 1);
4382   malloc_kill_ks (malloc_pool_image (), t, sizeof (*t));
4383 }
4384
4385 /* Make a new NAME token that is a substring of a NAMES token.  */
4386
4387 ffelexToken
4388 ffelex_token_name_from_names (ffelexToken t, ffeTokenLength start,
4389                               ffeTokenLength len)
4390 {
4391   ffelexToken nt;
4392
4393   assert (t != NULL);
4394   assert (ffelex_token_type (t) == FFELEX_typeNAMES);
4395   assert (start < t->length);
4396   if (len == 0)
4397     len = t->length - start;
4398   else
4399     {
4400       assert (len > 0);
4401       assert ((start + len) <= t->length);
4402     }
4403   assert (ffelex_is_firstnamechar ((unsigned char)(t->text[start])));
4404
4405   nt = ffelex_token_new_ ();
4406   nt->type = FFELEX_typeNAME;
4407   nt->size = len;               /* Assume nobody's gonna fiddle with token
4408                                    text. */
4409   nt->length = len;
4410   nt->uses = 1;
4411   ffewhere_set_from_track (&nt->where_line, &nt->where_col, t->where_line,
4412                            t->where_col, t->wheretrack, start);
4413   nt->text = malloc_new_ksr (malloc_pool_image (), "FFELEX token text",
4414                              len + 1);
4415   strncpy (nt->text, t->text + start, len);
4416   nt->text[len] = '\0';
4417   return nt;
4418 }
4419
4420 /* Make a new NAMES token that is a substring of another NAMES token.  */
4421
4422 ffelexToken
4423 ffelex_token_names_from_names (ffelexToken t, ffeTokenLength start,
4424                                ffeTokenLength len)
4425 {
4426   ffelexToken nt;
4427
4428   assert (t != NULL);
4429   assert (ffelex_token_type (t) == FFELEX_typeNAMES);
4430   assert (start < t->length);
4431   if (len == 0)
4432     len = t->length - start;
4433   else
4434     {
4435       assert (len > 0);
4436       assert ((start + len) <= t->length);
4437     }
4438   assert (ffelex_is_firstnamechar ((unsigned char)(t->text[start])));
4439
4440   nt = ffelex_token_new_ ();
4441   nt->type = FFELEX_typeNAMES;
4442   nt->size = len;               /* Assume nobody's gonna fiddle with token
4443                                    text. */
4444   nt->length = len;
4445   nt->uses = 1;
4446   ffewhere_set_from_track (&nt->where_line, &nt->where_col, t->where_line,
4447                            t->where_col, t->wheretrack, start);
4448   ffewhere_track_copy (nt->wheretrack, t->wheretrack, start, len);
4449   nt->text = malloc_new_ksr (malloc_pool_image (), "FFELEX token text",
4450                              len + 1);
4451   strncpy (nt->text, t->text + start, len);
4452   nt->text[len] = '\0';
4453   return nt;
4454 }
4455
4456 /* Make a new CHARACTER token.  */
4457
4458 ffelexToken
4459 ffelex_token_new_character (const char *s, ffewhereLine l, ffewhereColumn c)
4460 {
4461   ffelexToken t;
4462
4463   t = ffelex_token_new_ ();
4464   t->type = FFELEX_typeCHARACTER;
4465   t->length = t->size = strlen (s);     /* Assume it won't get bigger. */
4466   t->uses = 1;
4467   t->text = malloc_new_ksr (malloc_pool_image (), "FFELEX token text",
4468                             t->size + 1);
4469   strcpy (t->text, s);
4470   t->where_line = ffewhere_line_use (l);
4471   t->where_col = ffewhere_column_new (c);
4472   return t;
4473 }
4474
4475 /* Make a new EOF token right after end of file.  */
4476
4477 ffelexToken
4478 ffelex_token_new_eof ()
4479 {
4480   ffelexToken t;
4481
4482   t = ffelex_token_new_ ();
4483   t->type = FFELEX_typeEOF;
4484   t->uses = 1;
4485   t->text = NULL;
4486   t->where_line = ffewhere_line_new (ffelex_linecount_current_);
4487   t->where_col = ffewhere_column_new (1);
4488   return t;
4489 }
4490
4491 /* Make a new NAME token.  */
4492
4493 ffelexToken
4494 ffelex_token_new_name (const char *s, ffewhereLine l, ffewhereColumn c)
4495 {
4496   ffelexToken t;
4497
4498   assert (ffelex_is_firstnamechar ((unsigned char)*s));
4499
4500   t = ffelex_token_new_ ();
4501   t->type = FFELEX_typeNAME;
4502   t->length = t->size = strlen (s);     /* Assume it won't get bigger. */
4503   t->uses = 1;
4504   t->text = malloc_new_ksr (malloc_pool_image (), "FFELEX token text",
4505                             t->size + 1);
4506   strcpy (t->text, s);
4507   t->where_line = ffewhere_line_use (l);
4508   t->where_col = ffewhere_column_new (c);
4509   return t;
4510 }
4511
4512 /* Make a new NAMES token.  */
4513
4514 ffelexToken
4515 ffelex_token_new_names (const char *s, ffewhereLine l, ffewhereColumn c)
4516 {
4517   ffelexToken t;
4518
4519   assert (ffelex_is_firstnamechar ((unsigned char)*s));
4520
4521   t = ffelex_token_new_ ();
4522   t->type = FFELEX_typeNAMES;
4523   t->length = t->size = strlen (s);     /* Assume it won't get bigger. */
4524   t->uses = 1;
4525   t->text = malloc_new_ksr (malloc_pool_image (), "FFELEX token text",
4526                             t->size + 1);
4527   strcpy (t->text, s);
4528   t->where_line = ffewhere_line_use (l);
4529   t->where_col = ffewhere_column_new (c);
4530   ffewhere_track_clear (t->wheretrack, t->length);      /* Assume contiguous
4531                                                            names. */
4532   return t;
4533 }
4534
4535 /* Make a new NUMBER token.
4536
4537    The first character of the string must be a digit, and only the digits
4538    are copied into the new number.  So this may be used to easily extract
4539    a NUMBER token from within any text string.  Then the length of the
4540    resulting token may be used to calculate where the digits stopped
4541    in the original string.  */
4542
4543 ffelexToken
4544 ffelex_token_new_number (const char *s, ffewhereLine l, ffewhereColumn c)
4545 {
4546   ffelexToken t;
4547   ffeTokenLength len;
4548
4549   /* How long is the string of decimal digits at s? */
4550
4551   len = strspn (s, "0123456789");
4552
4553   /* Make sure there is at least one digit. */
4554
4555   assert (len != 0);
4556
4557   /* Now make the token. */
4558
4559   t = ffelex_token_new_ ();
4560   t->type = FFELEX_typeNUMBER;
4561   t->length = t->size = len;    /* Assume it won't get bigger. */
4562   t->uses = 1;
4563   t->text = malloc_new_ksr (malloc_pool_image (), "FFELEX token text",
4564                             len + 1);
4565   strncpy (t->text, s, len);
4566   t->text[len] = '\0';
4567   t->where_line = ffewhere_line_use (l);
4568   t->where_col = ffewhere_column_new (c);
4569   return t;
4570 }
4571
4572 /* Make a new token of any type that doesn't contain text.  A private
4573    function that is used by public macros in the interface file.  */
4574
4575 ffelexToken
4576 ffelex_token_new_simple_ (ffelexType type, ffewhereLine l, ffewhereColumn c)
4577 {
4578   ffelexToken t;
4579
4580   t = ffelex_token_new_ ();
4581   t->type = type;
4582   t->uses = 1;
4583   t->text = NULL;
4584   t->where_line = ffewhere_line_use (l);
4585   t->where_col = ffewhere_column_new (c);
4586   return t;
4587 }
4588
4589 /* Make a new NUMBER token from an existing NAMES token.
4590
4591    Like ffelex_token_new_number, this function calculates the length
4592    of the digit string itself.  */
4593
4594 ffelexToken
4595 ffelex_token_number_from_names (ffelexToken t, ffeTokenLength start)
4596 {
4597   ffelexToken nt;
4598   ffeTokenLength len;
4599
4600   assert (t != NULL);
4601   assert (ffelex_token_type (t) == FFELEX_typeNAMES);
4602   assert (start < t->length);
4603
4604   /* How long is the string of decimal digits at s? */
4605
4606   len = strspn (t->text + start, "0123456789");
4607
4608   /* Make sure there is at least one digit. */
4609
4610   assert (len != 0);
4611
4612   /* Now make the token. */
4613
4614   nt = ffelex_token_new_ ();
4615   nt->type = FFELEX_typeNUMBER;
4616   nt->size = len;               /* Assume nobody's gonna fiddle with token
4617                                    text. */
4618   nt->length = len;
4619   nt->uses = 1;
4620   ffewhere_set_from_track (&nt->where_line, &nt->where_col, t->where_line,
4621                            t->where_col, t->wheretrack, start);
4622   nt->text = malloc_new_ksr (malloc_pool_image (), "FFELEX token text",
4623                              len + 1);
4624   strncpy (nt->text, t->text + start, len);
4625   nt->text[len] = '\0';
4626   return nt;
4627 }
4628
4629 /* Make a new UNDERSCORE token from a NAMES token.  */
4630
4631 ffelexToken
4632 ffelex_token_uscore_from_names (ffelexToken t, ffeTokenLength start)
4633 {
4634   ffelexToken nt;
4635
4636   assert (t != NULL);
4637   assert (ffelex_token_type (t) == FFELEX_typeNAMES);
4638   assert (start < t->length);
4639   assert (t->text[start] == '_');
4640
4641   /* Now make the token. */
4642
4643   nt = ffelex_token_new_ ();
4644   nt->type = FFELEX_typeUNDERSCORE;
4645   nt->uses = 1;
4646   ffewhere_set_from_track (&nt->where_line, &nt->where_col, t->where_line,
4647                            t->where_col, t->wheretrack, start);
4648   nt->text = NULL;
4649   return nt;
4650 }
4651
4652 /* ffelex_token_use -- Return another instance of a token
4653
4654    ffelexToken t;
4655    t = ffelex_token_use(t);
4656
4657    In a sense, the new token is a copy of the old, though it might be the
4658    same with just a new use count.
4659
4660    We use the use count method (easy).  */
4661
4662 ffelexToken
4663 ffelex_token_use (ffelexToken t)
4664 {
4665   if (t == NULL)
4666     assert ("_token_use: null token" == NULL);
4667   t->uses++;
4668   return t;
4669 }