gcc/f/lex.c

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