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