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

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