gcc/f/lex.c

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