gcc/f/lex.c

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