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