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-ISO-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-ISO 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   goto first_line;              /* :::::::::::::::::::: */
1848
1849   /* Come here to get a new line. */
1850
1851  beginning_of_line:             /* :::::::::::::::::::: */
1852
1853   disallow_continuation_line = FALSE;
1854
1855   /* Come here directly when last line didn't clarify the continuation issue. */
1856
1857  beginning_of_line_again:       /* :::::::::::::::::::: */
1858
1859 #ifdef REDUCE_CARD_SIZE_AFTER_BIGGY     /* Define if occasional large lines. */
1860   if (ffelex_card_size_ != FFELEX_columnINITIAL_SIZE_)
1861     {
1862       ffelex_card_image_
1863         = malloc_resize_ks (malloc_pool_image (),
1864                             ffelex_card_image_,
1865                             FFELEX_columnINITIAL_SIZE_ + 9,
1866                             ffelex_card_size_ + 9);
1867       ffelex_card_size_ = FFELEX_columnINITIAL_SIZE_;
1868     }
1869 #endif
1870
1871  first_line:                    /* :::::::::::::::::::: */
1872
1873   c = latest_char_in_file;
1874   if ((c == EOF) || ((c = ffelex_getc_ (f)) == EOF))
1875     {
1876
1877     end_of_file:                /* :::::::::::::::::::: */
1878
1879       /* Line ending in EOF instead of \n still counts as a whole line. */
1880
1881       ffelex_finish_statement_ ();
1882       ffewhere_line_kill (ffelex_current_wl_);
1883       ffewhere_column_kill (ffelex_current_wc_);
1884       return (ffelexHandler) ffelex_handler_;
1885     }
1886
1887   ffelex_next_line_ ();
1888
1889   ffelex_bad_line_ = FALSE;
1890
1891   /* Skip over comment (and otherwise ignored) lines as quickly as possible! */
1892
1893   while (((lextype = ffelex_first_char_[c]) == FFELEX_typeCOMMENT)
1894          || (lextype == FFELEX_typeERROR)
1895          || (lextype == FFELEX_typeSLASH)
1896          || (lextype == FFELEX_typeHASH))
1897     {
1898       /* Test most frequent type of line first, etc.  */
1899       if ((lextype == FFELEX_typeCOMMENT)
1900           || ((lextype == FFELEX_typeSLASH)
1901               && ((c = getc (f)) == '*')))      /* NOTE SIDE-EFFECT. */
1902         {
1903           /* Typical case (straight comment), just ignore rest of line. */
1904         comment_line:           /* :::::::::::::::::::: */
1905
1906           while ((c != '\n') && (c != EOF))
1907             c = getc (f);
1908         }
1909       else if (lextype == FFELEX_typeHASH)
1910         c = ffelex_hash_ (f);
1911       else if (lextype == FFELEX_typeSLASH)
1912         {
1913           /* SIDE-EFFECT ABOVE HAS HAPPENED. */
1914           ffelex_card_image_[0] = '/';
1915           ffelex_card_image_[1] = c;
1916           column = 2;
1917           goto bad_first_character;     /* :::::::::::::::::::: */
1918         }
1919       else
1920         /* typeERROR or unsupported typeHASH.  */
1921         {                       /* Bad first character, get line and display
1922                                    it with message. */
1923           column = ffelex_image_char_ (c, 0);
1924
1925         bad_first_character:    /* :::::::::::::::::::: */
1926
1927           ffelex_bad_line_ = TRUE;
1928           while (((c = getc (f)) != '\n') && (c != EOF))
1929             column = ffelex_image_char_ (c, column);
1930           ffelex_card_image_[column] = '\0';
1931           ffelex_card_length_ = column;
1932           ffelex_bad_1_ (FFEBAD_FIRST_CHAR_INVALID,
1933                          ffelex_linecount_current_, 1);
1934         }
1935
1936       /* Read past last char in line.  */
1937
1938       if (c == EOF)
1939         {
1940           ffelex_next_line_ ();
1941           goto end_of_file;     /* :::::::::::::::::::: */
1942         }
1943
1944       c = getc (f);
1945
1946       ffelex_next_line_ ();
1947
1948       if (c == EOF)
1949         goto end_of_file;       /* :::::::::::::::::::: */
1950
1951       ffelex_bad_line_ = FALSE;
1952     }                           /* while [c, first char, means comment] */
1953
1954   ffelex_saw_tab_
1955     = (c == '&')
1956       || (ffelex_final_nontab_column_ == 0);
1957
1958   if (lextype == FFELEX_typeDEBUG)
1959     c = ' ';                    /* A 'D' or 'd' in column 1 with the
1960                                    debug-lines option on. */
1961
1962   column = ffelex_image_char_ (c, 0);
1963
1964   /* Read the entire line in as is (with whitespace processing).  */
1965
1966   while (((c = getc (f)) != '\n') && (c != EOF))
1967     column = ffelex_image_char_ (c, column);
1968
1969   if (ffelex_bad_line_)
1970     {
1971       ffelex_card_image_[column] = '\0';
1972       ffelex_card_length_ = column;
1973       goto comment_line;                /* :::::::::::::::::::: */
1974     }
1975
1976   /* If no tab, cut off line after column 72/132.  */
1977
1978   if (!ffelex_saw_tab_ && (column > ffelex_final_nontab_column_))
1979     {
1980       /* Technically, we should now fill ffelex_card_image_ up thru column
1981          72/132 with spaces, since character/hollerith constants must count
1982          them in that manner. To save CPU time in several ways (avoid a loop
1983          here that would be used only when we actually end a line in
1984          character-constant mode; avoid writing memory unnecessarily; avoid a
1985          loop later checking spaces when not scanning for character-constant
1986          characters), we don't do this, and we do the appropriate thing when
1987          we encounter end-of-line while actually processing a character
1988          constant. */
1989
1990       column = ffelex_final_nontab_column_;
1991     }
1992
1993   ffelex_card_image_[column] = '\0';
1994   ffelex_card_length_ = column;
1995
1996   /* Save next char in file so we can use register-based c while analyzing
1997      line we just read. */
1998
1999   latest_char_in_file = c;      /* Should be either '\n' or EOF. */
2000
2001   have_content = FALSE;
2002
2003   /* Handle label, if any. */
2004
2005   labi = 0;
2006   first_label_char = FFEWHERE_columnUNKNOWN;
2007   for (column = 0; column < 5; ++column)
2008     {
2009       switch (c = ffelex_card_image_[column])
2010         {
2011         case '\0':
2012         case '!':
2013           goto stop_looking;    /* :::::::::::::::::::: */
2014
2015         case ' ':
2016           break;
2017
2018         case '0':
2019         case '1':
2020         case '2':
2021         case '3':
2022         case '4':
2023         case '5':
2024         case '6':
2025         case '7':
2026         case '8':
2027         case '9':
2028           label_string[labi++] = c;
2029           if (first_label_char == FFEWHERE_columnUNKNOWN)
2030             first_label_char = column + 1;
2031           break;
2032
2033         case '&':
2034           if (column != 0)
2035             {
2036               ffelex_bad_1_ (FFEBAD_LABEL_FIELD_NOT_NUMERIC,
2037                              ffelex_linecount_current_,
2038                              column + 1);
2039               goto beginning_of_line_again;     /* :::::::::::::::::::: */
2040             }
2041           if (ffe_is_pedantic ())
2042             ffelex_bad_1_ (FFEBAD_AMPERSAND,
2043                            ffelex_linecount_current_, 1);
2044           finish_statement = FALSE;
2045           just_do_label = FALSE;
2046           goto got_a_continuation;      /* :::::::::::::::::::: */
2047
2048         case '/':
2049           if (ffelex_card_image_[column + 1] == '*')
2050             goto stop_looking;  /* :::::::::::::::::::: */
2051           /* Fall through. */
2052         default:
2053           ffelex_bad_1_ (FFEBAD_LABEL_FIELD_NOT_NUMERIC,
2054                          ffelex_linecount_current_, column + 1);
2055           goto beginning_of_line_again; /* :::::::::::::::::::: */
2056         }
2057     }
2058
2059  stop_looking:                  /* :::::::::::::::::::: */
2060
2061   label_string[labi] = '\0';
2062
2063   /* Find first nonblank char starting with continuation column. */
2064
2065   if (column == 5)              /* In which case we didn't see end of line in
2066                                    label field. */
2067     while ((c = ffelex_card_image_[column]) == ' ')
2068       ++column;
2069
2070   /* Now we're trying to figure out whether this is a continuation line and
2071      whether there's anything else of substance on the line.  The cases are
2072      as follows:
2073
2074      1. If a line has an explicit continuation character (other than the digit
2075      zero), then if it also has a label, the label is ignored and an error
2076      message is printed.  Any remaining text on the line is passed to the
2077      parser tasks, thus even an all-blank line (possibly with an ignored
2078      label) aside from a positive continuation character might have meaning
2079      in the midst of a character or hollerith constant.
2080
2081      2. If a line has no explicit continuation character (that is, it has a
2082      space in column 6 and the first non-space character past column 6 is
2083      not a digit 0-9), then there are two possibilities:
2084
2085      A. A label is present and/or a non-space (and non-comment) character
2086      appears somewhere after column 6.  Terminate processing of the previous
2087      statement, if any, send the new label for the next statement, if any,
2088      and start processing a new statement with this non-blank character, if
2089      any.
2090
2091      B. The line is essentially blank, except for a possible comment character.
2092      Don't terminate processing of the previous statement and don't pass any
2093      characters to the parser tasks, since the line is not flagged as a
2094      continuation line.  We treat it just like a completely blank line.
2095
2096      3. If a line has a continuation character of zero (0), then we terminate
2097      processing of the previous statement, if any, send the new label for the
2098      next statement, if any, and start processing a new statement, if any
2099      non-blank characters are present.
2100
2101      If, when checking to see if we should terminate the previous statement, it
2102      is found that there is no previous statement but that there is an
2103      outstanding label, substitute CONTINUE as the statement for the label
2104      and display an error message. */
2105
2106   finish_statement = FALSE;
2107   just_do_label = FALSE;
2108
2109   switch (c)
2110     {
2111     case '!':                   /* ANSI Fortran 90 says ! in column 6 is
2112                                    continuation. */
2113       /* VXT Fortran says ! anywhere is comment, even column 6. */
2114       if (ffe_is_vxt () || (column != 5))
2115         goto no_tokens_on_line; /* :::::::::::::::::::: */
2116       goto got_a_continuation;  /* :::::::::::::::::::: */
2117
2118     case '/':
2119       if (ffelex_card_image_[column + 1] != '*')
2120         goto some_other_character;      /* :::::::::::::::::::: */
2121       /* Fall through. */
2122       if (column == 5)
2123         {
2124           /* This seems right to do. But it is close to call, since / * starting
2125              in column 6 will thus be interpreted as a continuation line
2126              beginning with '*'. */
2127
2128           goto got_a_continuation;/* :::::::::::::::::::: */
2129         }
2130       /* Fall through. */
2131     case '\0':
2132       /* End of line.  Therefore may be continued-through line, so handle
2133          pending label as possible to-be-continued and drive end-of-statement
2134          for any previous statement, else treat as blank line. */
2135
2136      no_tokens_on_line:         /* :::::::::::::::::::: */
2137
2138       if (ffe_is_pedantic () && (c == '/'))
2139         ffelex_bad_1_ (FFEBAD_NON_ANSI_COMMENT,
2140                        ffelex_linecount_current_, column + 1);
2141       if (first_label_char != FFEWHERE_columnUNKNOWN)
2142         {                       /* Can't be a continued-through line if it
2143                                    has a label. */
2144           finish_statement = TRUE;
2145           have_content = TRUE;
2146           just_do_label = TRUE;
2147           break;
2148         }
2149       goto beginning_of_line_again;     /* :::::::::::::::::::: */
2150
2151     case '0':
2152       if (ffe_is_pedantic () && (column != 5))
2153         ffelex_bad_1_ (FFEBAD_NON_ANSI_CONTINUATION_COLUMN,
2154                        ffelex_linecount_current_, column + 1);
2155       finish_statement = TRUE;
2156       goto check_for_content;   /* :::::::::::::::::::: */
2157
2158     case '1':
2159     case '2':
2160     case '3':
2161     case '4':
2162     case '5':
2163     case '6':
2164     case '7':
2165     case '8':
2166     case '9':
2167
2168       /* NOTE: This label can be reached directly from the code
2169          that lexes the label field in columns 1-5.  */
2170      got_a_continuation:        /* :::::::::::::::::::: */
2171
2172       if (first_label_char != FFEWHERE_columnUNKNOWN)
2173         {
2174           ffelex_bad_2_ (FFEBAD_LABEL_ON_CONTINUATION,
2175                          ffelex_linecount_current_,
2176                          first_label_char,
2177                          ffelex_linecount_current_,
2178                          column + 1);
2179           first_label_char = FFEWHERE_columnUNKNOWN;
2180         }
2181       if (disallow_continuation_line)
2182         {
2183           if (!ignore_disallowed_continuation)
2184             ffelex_bad_1_ (FFEBAD_INVALID_CONTINUATION,
2185                            ffelex_linecount_current_, column + 1);
2186           goto beginning_of_line_again; /* :::::::::::::::::::: */
2187         }
2188       if (ffe_is_pedantic () && (column != 5))
2189         ffelex_bad_1_ (FFEBAD_NON_ANSI_CONTINUATION_COLUMN,
2190                        ffelex_linecount_current_, column + 1);
2191       if ((ffelex_raw_mode_ != 0)
2192           && (((c = ffelex_card_image_[column + 1]) != '\0')
2193               || !ffelex_saw_tab_))
2194         {
2195           ++column;
2196           have_content = TRUE;
2197           break;
2198         }
2199
2200      check_for_content:         /* :::::::::::::::::::: */
2201
2202       while ((c = ffelex_card_image_[++column]) == ' ')
2203         ;
2204       if ((c == '\0')
2205           || (c == '!')
2206           || ((c == '/')
2207               && (ffelex_card_image_[column + 1] == '*')))
2208         {
2209           if (ffe_is_pedantic () && (c == '/'))
2210             ffelex_bad_1_ (FFEBAD_NON_ANSI_COMMENT,
2211                            ffelex_linecount_current_, column + 1);
2212           just_do_label = TRUE;
2213         }
2214       else
2215         have_content = TRUE;
2216       break;
2217
2218     default:
2219
2220      some_other_character:      /* :::::::::::::::::::: */
2221
2222       if (column == 5)
2223         goto got_a_continuation;/* :::::::::::::::::::: */
2224
2225       /* Here is the very normal case of a regular character starting in
2226          column 7 or beyond with a blank in column 6. */
2227
2228       finish_statement = TRUE;
2229       have_content = TRUE;
2230       break;
2231     }
2232
2233   if (have_content
2234       || (first_label_char != FFEWHERE_columnUNKNOWN))
2235     {
2236       /* The line has content of some kind, install new end-statement
2237          point for error messages.  Note that "content" includes cases
2238          where there's little apparent content but enough to finish
2239          a statement.  That's because finishing a statement can trigger
2240          an impending INCLUDE, and that requires accurate line info being
2241          maintained by the lexer.  */
2242
2243       if (finish_statement)
2244         ffelex_prepare_eos_ (); /* Prepare EOS before we move current pointer. */
2245
2246       ffewhere_line_kill (ffelex_current_wl_);
2247       ffewhere_column_kill (ffelex_current_wc_);
2248       ffelex_current_wl_ = ffewhere_line_new (ffelex_linecount_current_);
2249       ffelex_current_wc_ = ffewhere_column_new (ffelex_card_length_ + 1);
2250     }
2251
2252   /* We delay this for a combination of reasons.  Mainly, it can start
2253      INCLUDE processing, and we want to delay that until the lexer's
2254      info on the line is coherent.  And we want to delay that until we're
2255      sure there's a reason to make that info coherent, to avoid saving
2256      lots of useless lines.  */
2257
2258   if (finish_statement)
2259     ffelex_finish_statement_ ();
2260
2261   /* If label is present, enclose it in a NUMBER token and send it along. */
2262
2263   if (first_label_char != FFEWHERE_columnUNKNOWN)
2264     {
2265       assert (ffelex_token_->type == FFELEX_typeNONE);
2266       ffelex_token_->type = FFELEX_typeNUMBER;
2267       ffelex_append_to_token_ ('\0');   /* Make room for label text. */
2268       strcpy (ffelex_token_->text, label_string);
2269       ffelex_token_->where_line
2270         = ffewhere_line_use (ffelex_current_wl_);
2271       ffelex_token_->where_col = ffewhere_column_new (first_label_char);
2272       ffelex_token_->length = labi;
2273       ffelex_send_token_ ();
2274       ++ffelex_label_tokens_;
2275     }
2276
2277   if (just_do_label)
2278     goto beginning_of_line;     /* :::::::::::::::::::: */
2279
2280   /* Here is the main engine for parsing.  c holds the character at column.
2281      It is already known that c is not a blank, end of line, or shriek,
2282      unless ffelex_raw_mode_ is not 0 (indicating we are in a
2283      character/hollerith constant). A partially filled token may already
2284      exist in ffelex_token_.  One special case: if, when the end of the line
2285      is reached, continuation_line is FALSE and the only token on the line is
2286      END, then it is indeed the last statement. We don't look for
2287      continuation lines during this program unit in that case. This is
2288      according to ANSI. */
2289
2290   if (ffelex_raw_mode_ != 0)
2291     {
2292
2293     parse_raw_character:        /* :::::::::::::::::::: */
2294
2295       if (c == '\0')
2296         {
2297           ffewhereColumnNumber i;
2298
2299           if (ffelex_saw_tab_ || (column >= ffelex_final_nontab_column_))
2300             goto beginning_of_line;     /* :::::::::::::::::::: */
2301
2302           /* Pad out line with "virtual" spaces. */
2303
2304           for (i = column; i < ffelex_final_nontab_column_; ++i)
2305             ffelex_card_image_[i] = ' ';
2306           ffelex_card_image_[i] = '\0';
2307           ffelex_card_length_ = i;
2308           c = ' ';
2309         }
2310
2311       switch (ffelex_raw_mode_)
2312         {
2313         case -3:
2314           c = ffelex_backslash_ (c, column);
2315           if (c == EOF)
2316             break;
2317
2318           if (!ffelex_backslash_reconsider_)
2319             ffelex_append_to_token_ (c);
2320           ffelex_raw_mode_ = -1;
2321           break;
2322
2323         case -2:
2324           if (c == ffelex_raw_char_)
2325             {
2326               ffelex_raw_mode_ = -1;
2327               ffelex_append_to_token_ (c);
2328             }
2329           else
2330             {
2331               ffelex_raw_mode_ = 0;
2332               ffelex_backslash_reconsider_ = TRUE;
2333             }
2334           break;
2335
2336         case -1:
2337           if (c == ffelex_raw_char_)
2338             ffelex_raw_mode_ = -2;
2339           else
2340             {
2341               c = ffelex_backslash_ (c, column);
2342               if (c == EOF)
2343                 {
2344                   ffelex_raw_mode_ = -3;
2345                   break;
2346                 }
2347
2348               ffelex_append_to_token_ (c);
2349             }
2350           break;
2351
2352         default:
2353           c = ffelex_backslash_ (c, column);
2354           if (c == EOF)
2355             break;
2356
2357           if (!ffelex_backslash_reconsider_)
2358             {
2359               ffelex_append_to_token_ (c);
2360               --ffelex_raw_mode_;
2361             }
2362           break;
2363         }
2364
2365       if (ffelex_backslash_reconsider_)
2366         ffelex_backslash_reconsider_ = FALSE;
2367       else
2368         c = ffelex_card_image_[++column];
2369
2370       if (ffelex_raw_mode_ == 0)
2371         {
2372           ffelex_send_token_ ();
2373           assert (ffelex_raw_mode_ == 0);
2374           while (c == ' ')
2375             c = ffelex_card_image_[++column];
2376           if ((c == '\0')
2377               || (c == '!')
2378               || ((c == '/')
2379                   && (ffelex_card_image_[column + 1] == '*')))
2380             goto beginning_of_line;     /* :::::::::::::::::::: */
2381           goto parse_nonraw_character;  /* :::::::::::::::::::: */
2382         }
2383       goto parse_raw_character; /* :::::::::::::::::::: */
2384     }
2385
2386  parse_nonraw_character:        /* :::::::::::::::::::: */
2387
2388   switch (ffelex_token_->type)
2389     {
2390     case FFELEX_typeNONE:
2391       switch (c)
2392         {
2393         case '\"':
2394           ffelex_token_->type = FFELEX_typeQUOTE;
2395           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
2396           ffelex_token_->where_col = ffewhere_column_new (column + 1);
2397           ffelex_send_token_ ();
2398           break;
2399
2400         case '$':
2401           ffelex_token_->type = FFELEX_typeDOLLAR;
2402           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
2403           ffelex_token_->where_col = ffewhere_column_new (column + 1);
2404           ffelex_send_token_ ();
2405           break;
2406
2407         case '%':
2408           ffelex_token_->type = FFELEX_typePERCENT;
2409           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
2410           ffelex_token_->where_col = ffewhere_column_new (column + 1);
2411           ffelex_send_token_ ();
2412           break;
2413
2414         case '&':
2415           ffelex_token_->type = FFELEX_typeAMPERSAND;
2416           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
2417           ffelex_token_->where_col = ffewhere_column_new (column + 1);
2418           ffelex_send_token_ ();
2419           break;
2420
2421         case '\'':
2422           ffelex_token_->type = FFELEX_typeAPOSTROPHE;
2423           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
2424           ffelex_token_->where_col = ffewhere_column_new (column + 1);
2425           ffelex_send_token_ ();
2426           break;
2427
2428         case '(':
2429           ffelex_token_->type = FFELEX_typeOPEN_PAREN;
2430           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
2431           ffelex_token_->where_col = ffewhere_column_new (column + 1);
2432           break;
2433
2434         case ')':
2435           ffelex_token_->type = FFELEX_typeCLOSE_PAREN;
2436           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
2437           ffelex_token_->where_col = ffewhere_column_new (column + 1);
2438           ffelex_send_token_ ();
2439           break;
2440
2441         case '*':
2442           ffelex_token_->type = FFELEX_typeASTERISK;
2443           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
2444           ffelex_token_->where_col = ffewhere_column_new (column + 1);
2445           break;
2446
2447         case '+':
2448           ffelex_token_->type = FFELEX_typePLUS;
2449           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
2450           ffelex_token_->where_col = ffewhere_column_new (column + 1);
2451           ffelex_send_token_ ();
2452           break;
2453
2454         case ',':
2455           ffelex_token_->type = FFELEX_typeCOMMA;
2456           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
2457           ffelex_token_->where_col = ffewhere_column_new (column + 1);
2458           ffelex_send_token_ ();
2459           break;
2460
2461         case '-':
2462           ffelex_token_->type = FFELEX_typeMINUS;
2463           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
2464           ffelex_token_->where_col = ffewhere_column_new (column + 1);
2465           ffelex_send_token_ ();
2466           break;
2467
2468         case '.':
2469           ffelex_token_->type = FFELEX_typePERIOD;
2470           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
2471           ffelex_token_->where_col = ffewhere_column_new (column + 1);
2472           ffelex_send_token_ ();
2473           break;
2474
2475         case '/':
2476           ffelex_token_->type = FFELEX_typeSLASH;
2477           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
2478           ffelex_token_->where_col = ffewhere_column_new (column + 1);
2479           break;
2480
2481         case '0':
2482         case '1':
2483         case '2':
2484         case '3':
2485         case '4':
2486         case '5':
2487         case '6':
2488         case '7':
2489         case '8':
2490         case '9':
2491           ffelex_token_->type
2492             = ffelex_hexnum_ ? FFELEX_typeNAME : FFELEX_typeNUMBER;
2493           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
2494           ffelex_token_->where_col = ffewhere_column_new (column + 1);
2495           ffelex_append_to_token_ (c);
2496           break;
2497
2498         case ':':
2499           ffelex_token_->type = FFELEX_typeCOLON;
2500           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
2501           ffelex_token_->where_col = ffewhere_column_new (column + 1);
2502           break;
2503
2504         case ';':
2505           ffelex_token_->type = FFELEX_typeSEMICOLON;
2506           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
2507           ffelex_token_->where_col = ffewhere_column_new (column + 1);
2508           ffelex_permit_include_ = TRUE;
2509           ffelex_send_token_ ();
2510           ffelex_permit_include_ = FALSE;
2511           break;
2512
2513         case '<':
2514           ffelex_token_->type = FFELEX_typeOPEN_ANGLE;
2515           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
2516           ffelex_token_->where_col = ffewhere_column_new (column + 1);
2517           break;
2518
2519         case '=':
2520           ffelex_token_->type = FFELEX_typeEQUALS;
2521           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
2522           ffelex_token_->where_col = ffewhere_column_new (column + 1);
2523           break;
2524
2525         case '>':
2526           ffelex_token_->type = FFELEX_typeCLOSE_ANGLE;
2527           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
2528           ffelex_token_->where_col = ffewhere_column_new (column + 1);
2529           break;
2530
2531         case '?':
2532           ffelex_token_->type = FFELEX_typeQUESTION;
2533           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
2534           ffelex_token_->where_col = ffewhere_column_new (column + 1);
2535           ffelex_send_token_ ();
2536           break;
2537
2538         case '_':
2539           if (1 || ffe_is_90 ())
2540             {
2541               ffelex_token_->type = FFELEX_typeUNDERSCORE;
2542               ffelex_token_->where_line
2543                 = ffewhere_line_use (ffelex_current_wl_);
2544               ffelex_token_->where_col
2545                 = ffewhere_column_new (column + 1);
2546               ffelex_send_token_ ();
2547               break;
2548             }
2549           /* Fall through. */
2550         case 'A':
2551         case 'B':
2552         case 'C':
2553         case 'D':
2554         case 'E':
2555         case 'F':
2556         case 'G':
2557         case 'H':
2558         case 'I':
2559         case 'J':
2560         case 'K':
2561         case 'L':
2562         case 'M':
2563         case 'N':
2564         case 'O':
2565         case 'P':
2566         case 'Q':
2567         case 'R':
2568         case 'S':
2569         case 'T':
2570         case 'U':
2571         case 'V':
2572         case 'W':
2573         case 'X':
2574         case 'Y':
2575         case 'Z':
2576         case 'a':
2577         case 'b':
2578         case 'c':
2579         case 'd':
2580         case 'e':
2581         case 'f':
2582         case 'g':
2583         case 'h':
2584         case 'i':
2585         case 'j':
2586         case 'k':
2587         case 'l':
2588         case 'm':
2589         case 'n':
2590         case 'o':
2591         case 'p':
2592         case 'q':
2593         case 'r':
2594         case 's':
2595         case 't':
2596         case 'u':
2597         case 'v':
2598         case 'w':
2599         case 'x':
2600         case 'y':
2601         case 'z':
2602           c = ffesrc_char_source (c);
2603
2604           if (ffesrc_char_match_init (c, 'H', 'h')
2605               && ffelex_expecting_hollerith_ != 0)
2606             {
2607               ffelex_raw_mode_ = ffelex_expecting_hollerith_;
2608               ffelex_token_->type = FFELEX_typeHOLLERITH;
2609               ffelex_token_->where_line = ffelex_raw_where_line_;
2610               ffelex_token_->where_col = ffelex_raw_where_col_;
2611               ffelex_raw_where_line_ = ffewhere_line_unknown ();
2612               ffelex_raw_where_col_ = ffewhere_column_unknown ();
2613               c = ffelex_card_image_[++column];
2614               goto parse_raw_character; /* :::::::::::::::::::: */
2615             }
2616
2617           if (ffelex_names_)
2618             {
2619               ffelex_token_->where_line
2620                 = ffewhere_line_use (ffelex_token_->currentnames_line
2621                                      = ffewhere_line_use (ffelex_current_wl_));
2622               ffelex_token_->where_col
2623                 = ffewhere_column_use (ffelex_token_->currentnames_col
2624                                        = ffewhere_column_new (column + 1));
2625               ffelex_token_->type = FFELEX_typeNAMES;
2626             }
2627           else
2628             {
2629               ffelex_token_->where_line
2630                 = ffewhere_line_use (ffelex_current_wl_);
2631               ffelex_token_->where_col = ffewhere_column_new (column + 1);
2632               ffelex_token_->type = FFELEX_typeNAME;
2633             }
2634           ffelex_append_to_token_ (c);
2635           break;
2636
2637         default:
2638           ffelex_bad_1_ (FFEBAD_UNRECOGNIZED_CHARACTER,
2639                          ffelex_linecount_current_, column + 1);
2640           ffelex_finish_statement_ ();
2641           disallow_continuation_line = TRUE;
2642           ignore_disallowed_continuation = TRUE;
2643           goto beginning_of_line_again; /* :::::::::::::::::::: */
2644         }
2645       break;
2646
2647     case FFELEX_typeNAME:
2648       switch (c)
2649         {
2650         case 'A':
2651         case 'B':
2652         case 'C':
2653         case 'D':
2654         case 'E':
2655         case 'F':
2656         case 'G':
2657         case 'H':
2658         case 'I':
2659         case 'J':
2660         case 'K':
2661         case 'L':
2662         case 'M':
2663         case 'N':
2664         case 'O':
2665         case 'P':
2666         case 'Q':
2667         case 'R':
2668         case 'S':
2669         case 'T':
2670         case 'U':
2671         case 'V':
2672         case 'W':
2673         case 'X':
2674         case 'Y':
2675         case 'Z':
2676         case 'a':
2677         case 'b':
2678         case 'c':
2679         case 'd':
2680         case 'e':
2681         case 'f':
2682         case 'g':
2683         case 'h':
2684         case 'i':
2685         case 'j':
2686         case 'k':
2687         case 'l':
2688         case 'm':
2689         case 'n':
2690         case 'o':
2691         case 'p':
2692         case 'q':
2693         case 'r':
2694         case 's':
2695         case 't':
2696         case 'u':
2697         case 'v':
2698         case 'w':
2699         case 'x':
2700         case 'y':
2701         case 'z':
2702           c = ffesrc_char_source (c);
2703           /* Fall through.  */
2704         case '0':
2705         case '1':
2706         case '2':
2707         case '3':
2708         case '4':
2709         case '5':
2710         case '6':
2711         case '7':
2712         case '8':
2713         case '9':
2714         case '_':
2715         case '$':
2716           if ((c == '$')
2717               && !ffe_is_dollar_ok ())
2718             {
2719               ffelex_send_token_ ();
2720               goto parse_next_character;        /* :::::::::::::::::::: */
2721             }
2722           ffelex_append_to_token_ (c);
2723           break;
2724
2725         default:
2726           ffelex_send_token_ ();
2727           goto parse_next_character;    /* :::::::::::::::::::: */
2728         }
2729       break;
2730
2731     case FFELEX_typeNAMES:
2732       switch (c)
2733         {
2734         case 'A':
2735         case 'B':
2736         case 'C':
2737         case 'D':
2738         case 'E':
2739         case 'F':
2740         case 'G':
2741         case 'H':
2742         case 'I':
2743         case 'J':
2744         case 'K':
2745         case 'L':
2746         case 'M':
2747         case 'N':
2748         case 'O':
2749         case 'P':
2750         case 'Q':
2751         case 'R':
2752         case 'S':
2753         case 'T':
2754         case 'U':
2755         case 'V':
2756         case 'W':
2757         case 'X':
2758         case 'Y':
2759         case 'Z':
2760         case 'a':
2761         case 'b':
2762         case 'c':
2763         case 'd':
2764         case 'e':
2765         case 'f':
2766         case 'g':
2767         case 'h':
2768         case 'i':
2769         case 'j':
2770         case 'k':
2771         case 'l':
2772         case 'm':
2773         case 'n':
2774         case 'o':
2775         case 'p':
2776         case 'q':
2777         case 'r':
2778         case 's':
2779         case 't':
2780         case 'u':
2781         case 'v':
2782         case 'w':
2783         case 'x':
2784         case 'y':
2785         case 'z':
2786           c = ffesrc_char_source (c);
2787           /* Fall through.  */
2788         case '0':
2789         case '1':
2790         case '2':
2791         case '3':
2792         case '4':
2793         case '5':
2794         case '6':
2795         case '7':
2796         case '8':
2797         case '9':
2798         case '_':
2799         case '$':
2800           if ((c == '$')
2801               && !ffe_is_dollar_ok ())
2802             {
2803               ffelex_send_token_ ();
2804               goto parse_next_character;        /* :::::::::::::::::::: */
2805             }
2806           if (ffelex_token_->length < FFEWHERE_indexMAX)
2807             {
2808               ffewhere_track (&ffelex_token_->currentnames_line,
2809                               &ffelex_token_->currentnames_col,
2810                               ffelex_token_->wheretrack,
2811                               ffelex_token_->length,
2812                               ffelex_linecount_current_,
2813                               column + 1);
2814             }
2815           ffelex_append_to_token_ (c);
2816           break;
2817
2818         default:
2819           ffelex_send_token_ ();
2820           goto parse_next_character;    /* :::::::::::::::::::: */
2821         }
2822       break;
2823
2824     case FFELEX_typeNUMBER:
2825       switch (c)
2826         {
2827         case '0':
2828         case '1':
2829         case '2':
2830         case '3':
2831         case '4':
2832         case '5':
2833         case '6':
2834         case '7':
2835         case '8':
2836         case '9':
2837           ffelex_append_to_token_ (c);
2838           break;
2839
2840         default:
2841           ffelex_send_token_ ();
2842           goto parse_next_character;    /* :::::::::::::::::::: */
2843         }
2844       break;
2845
2846     case FFELEX_typeASTERISK:
2847       switch (c)
2848         {
2849         case '*':               /* ** */
2850           ffelex_token_->type = FFELEX_typePOWER;
2851           ffelex_send_token_ ();
2852           break;
2853
2854         default:                /* * not followed by another *. */
2855           ffelex_send_token_ ();
2856           goto parse_next_character;    /* :::::::::::::::::::: */
2857         }
2858       break;
2859
2860     case FFELEX_typeCOLON:
2861       switch (c)
2862         {
2863         case ':':               /* :: */
2864           ffelex_token_->type = FFELEX_typeCOLONCOLON;
2865           ffelex_send_token_ ();
2866           break;
2867
2868         default:                /* : not followed by another :. */
2869           ffelex_send_token_ ();
2870           goto parse_next_character;    /* :::::::::::::::::::: */
2871         }
2872       break;
2873
2874     case FFELEX_typeSLASH:
2875       switch (c)
2876         {
2877         case '/':               /* // */
2878           ffelex_token_->type = FFELEX_typeCONCAT;
2879           ffelex_send_token_ ();
2880           break;
2881
2882         case ')':               /* /) */
2883           ffelex_token_->type = FFELEX_typeCLOSE_ARRAY;
2884           ffelex_send_token_ ();
2885           break;
2886
2887         case '=':               /* /= */
2888           ffelex_token_->type = FFELEX_typeREL_NE;
2889           ffelex_send_token_ ();
2890           break;
2891
2892         default:
2893           ffelex_send_token_ ();
2894           goto parse_next_character;    /* :::::::::::::::::::: */
2895         }
2896       break;
2897
2898     case FFELEX_typeOPEN_PAREN:
2899       switch (c)
2900         {
2901         case '/':               /* (/ */
2902           ffelex_token_->type = FFELEX_typeOPEN_ARRAY;
2903           ffelex_send_token_ ();
2904           break;
2905
2906         default:
2907           ffelex_send_token_ ();
2908           goto parse_next_character;    /* :::::::::::::::::::: */
2909         }
2910       break;
2911
2912     case FFELEX_typeOPEN_ANGLE:
2913       switch (c)
2914         {
2915         case '=':               /* <= */
2916           ffelex_token_->type = FFELEX_typeREL_LE;
2917           ffelex_send_token_ ();
2918           break;
2919
2920         default:
2921           ffelex_send_token_ ();
2922           goto parse_next_character;    /* :::::::::::::::::::: */
2923         }
2924       break;
2925
2926     case FFELEX_typeEQUALS:
2927       switch (c)
2928         {
2929         case '=':               /* == */
2930           ffelex_token_->type = FFELEX_typeREL_EQ;
2931           ffelex_send_token_ ();
2932           break;
2933
2934         case '>':               /* => */
2935           ffelex_token_->type = FFELEX_typePOINTS;
2936           ffelex_send_token_ ();
2937           break;
2938
2939         default:
2940           ffelex_send_token_ ();
2941           goto parse_next_character;    /* :::::::::::::::::::: */
2942         }
2943       break;
2944
2945     case FFELEX_typeCLOSE_ANGLE:
2946       switch (c)
2947         {
2948         case '=':               /* >= */
2949           ffelex_token_->type = FFELEX_typeREL_GE;
2950           ffelex_send_token_ ();
2951           break;
2952
2953         default:
2954           ffelex_send_token_ ();
2955           goto parse_next_character;    /* :::::::::::::::::::: */
2956         }
2957       break;
2958
2959     default:
2960       assert ("Serious error!!" == NULL);
2961       abort ();
2962       break;
2963     }
2964
2965   c = ffelex_card_image_[++column];
2966
2967  parse_next_character:          /* :::::::::::::::::::: */
2968
2969   if (ffelex_raw_mode_ != 0)
2970     goto parse_raw_character;   /* :::::::::::::::::::: */
2971
2972   while (c == ' ')
2973     c = ffelex_card_image_[++column];
2974
2975   if ((c == '\0')
2976       || (c == '!')
2977       || ((c == '/')
2978           && (ffelex_card_image_[column + 1] == '*')))
2979     {
2980       if ((ffelex_number_of_tokens_ == ffelex_label_tokens_)
2981           && (ffelex_token_->type == FFELEX_typeNAMES)
2982           && (ffelex_token_->length == 3)
2983           && (ffesrc_strncmp_2c (ffe_case_match (),
2984                                  ffelex_token_->text,
2985                                  "END", "end", "End",
2986                                  3)
2987            == 0))
2988         {
2989           ffelex_finish_statement_ ();
2990           disallow_continuation_line = TRUE;
2991           ignore_disallowed_continuation = FALSE;
2992           goto beginning_of_line_again; /* :::::::::::::::::::: */
2993         }
2994       goto beginning_of_line;   /* :::::::::::::::::::: */
2995     }
2996   goto parse_nonraw_character;  /* :::::::::::::::::::: */
2997 }
2998
2999 /* ffelex_file_free -- Lex a given file in free source form
3000
3001    ffewhere wf;
3002    FILE *f;
3003    ffelex_file_free(wf,f);
3004
3005    Lexes the file according to Fortran 90 ANSI + VXT specifications.  */
3006
3007 ffelexHandler
3008 ffelex_file_free (ffewhereFile wf, FILE *f)
3009 {
3010   register int c = 0;           /* Character currently under consideration. */
3011   register ffewhereColumnNumber column = 0;     /* Not really; 0 means column 1... */
3012   bool continuation_line = FALSE;
3013   ffewhereColumnNumber continuation_column;
3014   int latest_char_in_file = 0;  /* For getting back into comment-skipping
3015                                    code. */
3016
3017   /* Lex is called for a particular file, not for a particular program unit.
3018      Yet the two events do share common characteristics.  The first line in a
3019      file or in a program unit cannot be a continuation line.  No token can
3020      be in mid-formation.  No current label for the statement exists, since
3021      there is no current statement. */
3022
3023   assert (ffelex_handler_ != NULL);
3024
3025   lineno = 0;
3026   input_filename = ffewhere_file_name (wf);
3027   ffelex_current_wf_ = wf;
3028   continuation_line = FALSE;
3029   ffelex_token_->type = FFELEX_typeNONE;
3030   ffelex_number_of_tokens_ = 0;
3031   ffelex_current_wl_ = ffewhere_line_unknown ();
3032   ffelex_current_wc_ = ffewhere_column_unknown ();
3033   latest_char_in_file = '\n';
3034
3035   /* Come here to get a new line. */
3036
3037  beginning_of_line:             /* :::::::::::::::::::: */
3038
3039   c = latest_char_in_file;
3040   if ((c == EOF) || ((c = ffelex_getc_ (f)) == EOF))
3041     {
3042
3043      end_of_file:               /* :::::::::::::::::::: */
3044
3045       /* Line ending in EOF instead of \n still counts as a whole line. */
3046
3047       ffelex_finish_statement_ ();
3048       ffewhere_line_kill (ffelex_current_wl_);
3049       ffewhere_column_kill (ffelex_current_wc_);
3050       return (ffelexHandler) ffelex_handler_;
3051     }
3052
3053   ffelex_next_line_ ();
3054
3055   ffelex_bad_line_ = FALSE;
3056
3057   /* Skip over initial-comment and empty lines as quickly as possible! */
3058
3059   while ((c == '\n')
3060          || (c == '!')
3061          || (c == '#'))
3062     {
3063       if (c == '#')
3064         c = ffelex_hash_ (f);
3065
3066      comment_line:              /* :::::::::::::::::::: */
3067
3068       while ((c != '\n') && (c != EOF))
3069         c = getc (f);
3070
3071       if (c == EOF)
3072         {
3073           ffelex_next_line_ ();
3074           goto end_of_file;     /* :::::::::::::::::::: */
3075         }
3076
3077       c = getc (f);
3078
3079       ffelex_next_line_ ();
3080
3081       if (c == EOF)
3082         goto end_of_file;       /* :::::::::::::::::::: */
3083     }
3084
3085   ffelex_saw_tab_ = FALSE;
3086
3087   column = ffelex_image_char_ (c, 0);
3088
3089   /* Read the entire line in as is (with whitespace processing).  */
3090
3091   while (((c = getc (f)) != '\n') && (c != EOF))
3092     column = ffelex_image_char_ (c, column);
3093
3094   if (ffelex_bad_line_)
3095     {
3096       ffelex_card_image_[column] = '\0';
3097       ffelex_card_length_ = column;
3098       goto comment_line;                /* :::::::::::::::::::: */
3099     }
3100
3101   /* If no tab, cut off line after column 132.  */
3102
3103   if (!ffelex_saw_tab_ && (column > FFELEX_FREE_MAX_COLUMNS_))
3104     column = FFELEX_FREE_MAX_COLUMNS_;
3105
3106   ffelex_card_image_[column] = '\0';
3107   ffelex_card_length_ = column;
3108
3109   /* Save next char in file so we can use register-based c while analyzing
3110      line we just read. */
3111
3112   latest_char_in_file = c;      /* Should be either '\n' or EOF. */
3113
3114   column = 0;
3115   continuation_column = 0;
3116
3117   /* Skip over initial spaces to see if the first nonblank character
3118      is exclamation point, newline, or EOF (line is therefore a comment) or
3119      ampersand (line is therefore a continuation line). */
3120
3121   while ((c = ffelex_card_image_[column]) == ' ')
3122     ++column;
3123
3124   switch (c)
3125     {
3126     case '!':
3127     case '\0':
3128       goto beginning_of_line;   /* :::::::::::::::::::: */
3129
3130     case '&':
3131       continuation_column = column + 1;
3132       break;
3133
3134     default:
3135       break;
3136     }
3137
3138   /* The line definitely has content of some kind, install new end-statement
3139      point for error messages. */
3140
3141   ffewhere_line_kill (ffelex_current_wl_);
3142   ffewhere_column_kill (ffelex_current_wc_);
3143   ffelex_current_wl_ = ffewhere_line_new (ffelex_linecount_current_);
3144   ffelex_current_wc_ = ffewhere_column_new (ffelex_card_length_ + 1);
3145
3146   /* Figure out which column to start parsing at. */
3147
3148   if (continuation_line)
3149     {
3150       if (continuation_column == 0)
3151         {
3152           if (ffelex_raw_mode_ != 0)
3153             {
3154               ffelex_bad_1_ (FFEBAD_BAD_CHAR_CONTINUE,
3155                              ffelex_linecount_current_, column + 1);
3156             }
3157           else if (ffelex_token_->type != FFELEX_typeNONE)
3158             {
3159               ffelex_bad_1_ (FFEBAD_BAD_LEXTOK_CONTINUE,
3160                              ffelex_linecount_current_, column + 1);
3161             }
3162         }
3163       else if (ffelex_is_free_char_ctx_contin_ (continuation_column))
3164         {                       /* Line contains only a single "&" as only
3165                                    nonblank character. */
3166           ffelex_bad_1_ (FFEBAD_BAD_FREE_CONTINUE,
3167                          ffelex_linecount_current_, continuation_column);
3168           goto beginning_of_line;       /* :::::::::::::::::::: */
3169         }
3170       column = continuation_column;
3171     }
3172   else
3173     column = 0;
3174
3175   c = ffelex_card_image_[column];
3176   continuation_line = FALSE;
3177
3178   /* Here is the main engine for parsing.  c holds the character at column.
3179      It is already known that c is not a blank, end of line, or shriek,
3180      unless ffelex_raw_mode_ is not 0 (indicating we are in a
3181      character/hollerith constant).  A partially filled token may already
3182      exist in ffelex_token_. */
3183
3184   if (ffelex_raw_mode_ != 0)
3185     {
3186
3187     parse_raw_character:        /* :::::::::::::::::::: */
3188
3189       switch (c)
3190         {
3191         case '&':
3192           if (ffelex_is_free_char_ctx_contin_ (column + 1))
3193             {
3194               continuation_line = TRUE;
3195               goto beginning_of_line;   /* :::::::::::::::::::: */
3196             }
3197           break;
3198
3199         case '\0':
3200           ffelex_finish_statement_ ();
3201           goto beginning_of_line;       /* :::::::::::::::::::: */
3202
3203         default:
3204           break;
3205         }
3206
3207       switch (ffelex_raw_mode_)
3208         {
3209         case -3:
3210           c = ffelex_backslash_ (c, column);
3211           if (c == EOF)
3212             break;
3213
3214           if (!ffelex_backslash_reconsider_)
3215             ffelex_append_to_token_ (c);
3216           ffelex_raw_mode_ = -1;
3217           break;
3218
3219         case -2:
3220           if (c == ffelex_raw_char_)
3221             {
3222               ffelex_raw_mode_ = -1;
3223               ffelex_append_to_token_ (c);
3224             }
3225           else
3226             {
3227               ffelex_raw_mode_ = 0;
3228               ffelex_backslash_reconsider_ = TRUE;
3229             }
3230           break;
3231
3232         case -1:
3233           if (c == ffelex_raw_char_)
3234             ffelex_raw_mode_ = -2;
3235           else
3236             {
3237               c = ffelex_backslash_ (c, column);
3238               if (c == EOF)
3239                 {
3240                   ffelex_raw_mode_ = -3;
3241                   break;
3242                 }
3243
3244               ffelex_append_to_token_ (c);
3245             }
3246           break;
3247
3248         default:
3249           c = ffelex_backslash_ (c, column);
3250           if (c == EOF)
3251             break;
3252
3253           if (!ffelex_backslash_reconsider_)
3254             {
3255               ffelex_append_to_token_ (c);
3256               --ffelex_raw_mode_;
3257             }
3258           break;
3259         }
3260
3261       if (ffelex_backslash_reconsider_)
3262         ffelex_backslash_reconsider_ = FALSE;
3263       else
3264         c = ffelex_card_image_[++column];
3265
3266       if (ffelex_raw_mode_ == 0)
3267         {
3268           ffelex_send_token_ ();
3269           assert (ffelex_raw_mode_ == 0);
3270           while (c == ' ')
3271             c = ffelex_card_image_[++column];
3272           if ((c == '\0') || (c == '!'))
3273             {
3274               ffelex_finish_statement_ ();
3275               goto beginning_of_line;   /* :::::::::::::::::::: */
3276             }
3277           if ((c == '&') && ffelex_is_free_nonc_ctx_contin_ (column + 1))
3278             {
3279               continuation_line = TRUE;
3280               goto beginning_of_line;   /* :::::::::::::::::::: */
3281             }
3282           goto parse_nonraw_character_noncontin;        /* :::::::::::::::::::: */
3283         }
3284       goto parse_raw_character; /* :::::::::::::::::::: */
3285     }
3286
3287  parse_nonraw_character:        /* :::::::::::::::::::: */
3288
3289   if ((c == '&') && ffelex_is_free_nonc_ctx_contin_ (column + 1))
3290     {
3291       continuation_line = TRUE;
3292       goto beginning_of_line;   /* :::::::::::::::::::: */
3293     }
3294
3295  parse_nonraw_character_noncontin:      /* :::::::::::::::::::: */
3296
3297   switch (ffelex_token_->type)
3298     {
3299     case FFELEX_typeNONE:
3300       if (c == ' ')
3301         {                       /* Otherwise
3302                                    finish-statement/continue-statement
3303                                    already checked. */
3304           while (c == ' ')
3305             c = ffelex_card_image_[++column];
3306           if ((c == '\0') || (c == '!'))
3307             {
3308               ffelex_finish_statement_ ();
3309               goto beginning_of_line;   /* :::::::::::::::::::: */
3310             }
3311           if ((c == '&') && ffelex_is_free_nonc_ctx_contin_ (column + 1))
3312             {
3313               continuation_line = TRUE;
3314               goto beginning_of_line;   /* :::::::::::::::::::: */
3315             }
3316         }
3317
3318       switch (c)
3319         {
3320         case '\"':
3321           ffelex_token_->type = FFELEX_typeQUOTE;
3322           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
3323           ffelex_token_->where_col = ffewhere_column_new (column + 1);
3324           ffelex_send_token_ ();
3325           break;
3326
3327         case '$':
3328           ffelex_token_->type = FFELEX_typeDOLLAR;
3329           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
3330           ffelex_token_->where_col = ffewhere_column_new (column + 1);
3331           ffelex_send_token_ ();
3332           break;
3333
3334         case '%':
3335           ffelex_token_->type = FFELEX_typePERCENT;
3336           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
3337           ffelex_token_->where_col = ffewhere_column_new (column + 1);
3338           ffelex_send_token_ ();
3339           break;
3340
3341         case '&':
3342           ffelex_token_->type = FFELEX_typeAMPERSAND;
3343           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
3344           ffelex_token_->where_col = ffewhere_column_new (column + 1);
3345           ffelex_send_token_ ();
3346           break;
3347
3348         case '\'':
3349           ffelex_token_->type = FFELEX_typeAPOSTROPHE;
3350           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
3351           ffelex_token_->where_col = ffewhere_column_new (column + 1);
3352           ffelex_send_token_ ();
3353           break;
3354
3355         case '(':
3356           ffelex_token_->type = FFELEX_typeOPEN_PAREN;
3357           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
3358           ffelex_token_->where_col = ffewhere_column_new (column + 1);
3359           break;
3360
3361         case ')':
3362           ffelex_token_->type = FFELEX_typeCLOSE_PAREN;
3363           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
3364           ffelex_token_->where_col = ffewhere_column_new (column + 1);
3365           ffelex_send_token_ ();
3366           break;
3367
3368         case '*':
3369           ffelex_token_->type = FFELEX_typeASTERISK;
3370           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
3371           ffelex_token_->where_col = ffewhere_column_new (column + 1);
3372           break;
3373
3374         case '+':
3375           ffelex_token_->type = FFELEX_typePLUS;
3376           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
3377           ffelex_token_->where_col = ffewhere_column_new (column + 1);
3378           ffelex_send_token_ ();
3379           break;
3380
3381         case ',':
3382           ffelex_token_->type = FFELEX_typeCOMMA;
3383           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
3384           ffelex_token_->where_col = ffewhere_column_new (column + 1);
3385           ffelex_send_token_ ();
3386           break;
3387
3388         case '-':
3389           ffelex_token_->type = FFELEX_typeMINUS;
3390           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
3391           ffelex_token_->where_col = ffewhere_column_new (column + 1);
3392           ffelex_send_token_ ();
3393           break;
3394
3395         case '.':
3396           ffelex_token_->type = FFELEX_typePERIOD;
3397           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
3398           ffelex_token_->where_col = ffewhere_column_new (column + 1);
3399           ffelex_send_token_ ();
3400           break;
3401
3402         case '/':
3403           ffelex_token_->type = FFELEX_typeSLASH;
3404           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
3405           ffelex_token_->where_col = ffewhere_column_new (column + 1);
3406           break;
3407
3408         case '0':
3409         case '1':
3410         case '2':
3411         case '3':
3412         case '4':
3413         case '5':
3414         case '6':
3415         case '7':
3416         case '8':
3417         case '9':
3418           ffelex_token_->type
3419             = ffelex_hexnum_ ? FFELEX_typeNAME : FFELEX_typeNUMBER;
3420           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
3421           ffelex_token_->where_col = ffewhere_column_new (column + 1);
3422           ffelex_append_to_token_ (c);
3423           break;
3424
3425         case ':':
3426           ffelex_token_->type = FFELEX_typeCOLON;
3427           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
3428           ffelex_token_->where_col = ffewhere_column_new (column + 1);
3429           break;
3430
3431         case ';':
3432           ffelex_token_->type = FFELEX_typeSEMICOLON;
3433           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
3434           ffelex_token_->where_col = ffewhere_column_new (column + 1);
3435           ffelex_permit_include_ = TRUE;
3436           ffelex_send_token_ ();
3437           ffelex_permit_include_ = FALSE;
3438           break;
3439
3440         case '<':
3441           ffelex_token_->type = FFELEX_typeOPEN_ANGLE;
3442           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
3443           ffelex_token_->where_col = ffewhere_column_new (column + 1);
3444           break;
3445
3446         case '=':
3447           ffelex_token_->type = FFELEX_typeEQUALS;
3448           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
3449           ffelex_token_->where_col = ffewhere_column_new (column + 1);
3450           break;
3451
3452         case '>':
3453           ffelex_token_->type = FFELEX_typeCLOSE_ANGLE;
3454           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
3455           ffelex_token_->where_col = ffewhere_column_new (column + 1);
3456           break;
3457
3458         case '?':
3459           ffelex_token_->type = FFELEX_typeQUESTION;
3460           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
3461           ffelex_token_->where_col = ffewhere_column_new (column + 1);
3462           ffelex_send_token_ ();
3463           break;
3464
3465         case '_':
3466           if (1 || ffe_is_90 ())
3467             {
3468               ffelex_token_->type = FFELEX_typeUNDERSCORE;
3469               ffelex_token_->where_line
3470                 = ffewhere_line_use (ffelex_current_wl_);
3471               ffelex_token_->where_col
3472                 = ffewhere_column_new (column + 1);
3473               ffelex_send_token_ ();
3474               break;
3475             }
3476           /* Fall through. */
3477         case 'A':
3478         case 'B':
3479         case 'C':
3480         case 'D':
3481         case 'E':
3482         case 'F':
3483         case 'G':
3484         case 'H':
3485         case 'I':
3486         case 'J':
3487         case 'K':
3488         case 'L':
3489         case 'M':
3490         case 'N':
3491         case 'O':
3492         case 'P':
3493         case 'Q':
3494         case 'R':
3495         case 'S':
3496         case 'T':
3497         case 'U':
3498         case 'V':
3499         case 'W':
3500         case 'X':
3501         case 'Y':
3502         case 'Z':
3503         case 'a':
3504         case 'b':
3505         case 'c':
3506         case 'd':
3507         case 'e':
3508         case 'f':
3509         case 'g':
3510         case 'h':
3511         case 'i':
3512         case 'j':
3513         case 'k':
3514         case 'l':
3515         case 'm':
3516         case 'n':
3517         case 'o':
3518         case 'p':
3519         case 'q':
3520         case 'r':
3521         case 's':
3522         case 't':
3523         case 'u':
3524         case 'v':
3525         case 'w':
3526         case 'x':
3527         case 'y':
3528         case 'z':
3529           c = ffesrc_char_source (c);
3530
3531           if (ffesrc_char_match_init (c, 'H', 'h')
3532               && ffelex_expecting_hollerith_ != 0)
3533             {
3534               ffelex_raw_mode_ = ffelex_expecting_hollerith_;
3535               ffelex_token_->type = FFELEX_typeHOLLERITH;
3536               ffelex_token_->where_line = ffelex_raw_where_line_;
3537               ffelex_token_->where_col = ffelex_raw_where_col_;
3538               ffelex_raw_where_line_ = ffewhere_line_unknown ();
3539               ffelex_raw_where_col_ = ffewhere_column_unknown ();
3540               c = ffelex_card_image_[++column];
3541               goto parse_raw_character; /* :::::::::::::::::::: */
3542             }
3543
3544           if (ffelex_names_pure_)
3545             {
3546               ffelex_token_->where_line
3547                 = ffewhere_line_use (ffelex_token_->currentnames_line
3548                                      = ffewhere_line_use (ffelex_current_wl_));
3549               ffelex_token_->where_col
3550                 = ffewhere_column_use (ffelex_token_->currentnames_col
3551                                        = ffewhere_column_new (column + 1));
3552               ffelex_token_->type = FFELEX_typeNAMES;
3553             }
3554           else
3555             {
3556               ffelex_token_->where_line
3557                 = ffewhere_line_use (ffelex_current_wl_);
3558               ffelex_token_->where_col = ffewhere_column_new (column + 1);
3559               ffelex_token_->type = FFELEX_typeNAME;
3560             }
3561           ffelex_append_to_token_ (c);
3562           break;
3563
3564         default:
3565           ffelex_bad_1_ (FFEBAD_UNRECOGNIZED_CHARACTER,
3566                          ffelex_linecount_current_, column + 1);
3567           ffelex_finish_statement_ ();
3568           goto beginning_of_line;       /* :::::::::::::::::::: */
3569         }
3570       break;
3571
3572     case FFELEX_typeNAME:
3573       switch (c)
3574         {
3575         case 'A':
3576         case 'B':
3577         case 'C':
3578         case 'D':
3579         case 'E':
3580         case 'F':
3581         case 'G':
3582         case 'H':
3583         case 'I':
3584         case 'J':
3585         case 'K':
3586         case 'L':
3587         case 'M':
3588         case 'N':
3589         case 'O':
3590         case 'P':
3591         case 'Q':
3592         case 'R':
3593         case 'S':
3594         case 'T':
3595         case 'U':
3596         case 'V':
3597         case 'W':
3598         case 'X':
3599         case 'Y':
3600         case 'Z':
3601         case 'a':
3602         case 'b':
3603         case 'c':
3604         case 'd':
3605         case 'e':
3606         case 'f':
3607         case 'g':
3608         case 'h':
3609         case 'i':
3610         case 'j':
3611         case 'k':
3612         case 'l':
3613         case 'm':
3614         case 'n':
3615         case 'o':
3616         case 'p':
3617         case 'q':
3618         case 'r':
3619         case 's':
3620         case 't':
3621         case 'u':
3622         case 'v':
3623         case 'w':
3624         case 'x':
3625         case 'y':
3626         case 'z':
3627           c = ffesrc_char_source (c);
3628           /* Fall through.  */
3629         case '0':
3630         case '1':
3631         case '2':
3632         case '3':
3633         case '4':
3634         case '5':
3635         case '6':
3636         case '7':
3637         case '8':
3638         case '9':
3639         case '_':
3640         case '$':
3641           if ((c == '$')
3642               && !ffe_is_dollar_ok ())
3643             {
3644               ffelex_send_token_ ();
3645               goto parse_next_character;        /* :::::::::::::::::::: */
3646             }
3647           ffelex_append_to_token_ (c);
3648           break;
3649
3650         default:
3651           ffelex_send_token_ ();
3652           goto parse_next_character;    /* :::::::::::::::::::: */
3653         }
3654       break;
3655
3656     case FFELEX_typeNAMES:
3657       switch (c)
3658         {
3659         case 'A':
3660         case 'B':
3661         case 'C':
3662         case 'D':
3663         case 'E':
3664         case 'F':
3665         case 'G':
3666         case 'H':
3667         case 'I':
3668         case 'J':
3669         case 'K':
3670         case 'L':
3671         case 'M':
3672         case 'N':
3673         case 'O':
3674         case 'P':
3675         case 'Q':
3676         case 'R':
3677         case 'S':
3678         case 'T':
3679         case 'U':
3680         case 'V':
3681         case 'W':
3682         case 'X':
3683         case 'Y':
3684         case 'Z':
3685         case 'a':
3686         case 'b':
3687         case 'c':
3688         case 'd':
3689         case 'e':
3690         case 'f':
3691         case 'g':
3692         case 'h':
3693         case 'i':
3694         case 'j':
3695         case 'k':
3696         case 'l':
3697         case 'm':
3698         case 'n':
3699         case 'o':
3700         case 'p':
3701         case 'q':
3702         case 'r':
3703         case 's':
3704         case 't':
3705         case 'u':
3706         case 'v':
3707         case 'w':
3708         case 'x':
3709         case 'y':
3710         case 'z':
3711           c = ffesrc_char_source (c);
3712           /* Fall through.  */
3713         case '0':
3714         case '1':
3715         case '2':
3716         case '3':
3717         case '4':
3718         case '5':
3719         case '6':
3720         case '7':
3721         case '8':
3722         case '9':
3723         case '_':
3724         case '$':
3725           if ((c == '$')
3726               && !ffe_is_dollar_ok ())
3727             {
3728               ffelex_send_token_ ();
3729               goto parse_next_character;        /* :::::::::::::::::::: */
3730             }
3731           if (ffelex_token_->length < FFEWHERE_indexMAX)
3732             {
3733               ffewhere_track (&ffelex_token_->currentnames_line,
3734                               &ffelex_token_->currentnames_col,
3735                               ffelex_token_->wheretrack,
3736                               ffelex_token_->length,
3737                               ffelex_linecount_current_,
3738                               column + 1);
3739             }
3740           ffelex_append_to_token_ (c);
3741           break;
3742
3743         default:
3744           ffelex_send_token_ ();
3745           goto parse_next_character;    /* :::::::::::::::::::: */
3746         }
3747       break;
3748
3749     case FFELEX_typeNUMBER:
3750       switch (c)
3751         {
3752         case '0':
3753         case '1':
3754         case '2':
3755         case '3':
3756         case '4':
3757         case '5':
3758         case '6':
3759         case '7':
3760         case '8':
3761         case '9':
3762           ffelex_append_to_token_ (c);
3763           break;
3764
3765         default:
3766           ffelex_send_token_ ();
3767           goto parse_next_character;    /* :::::::::::::::::::: */
3768         }
3769       break;
3770
3771     case FFELEX_typeASTERISK:
3772       switch (c)
3773         {
3774         case '*':               /* ** */
3775           ffelex_token_->type = FFELEX_typePOWER;
3776           ffelex_send_token_ ();
3777           break;
3778
3779         default:                /* * not followed by another *. */
3780           ffelex_send_token_ ();
3781           goto parse_next_character;    /* :::::::::::::::::::: */
3782         }
3783       break;
3784
3785     case FFELEX_typeCOLON:
3786       switch (c)
3787         {
3788         case ':':               /* :: */
3789           ffelex_token_->type = FFELEX_typeCOLONCOLON;
3790           ffelex_send_token_ ();
3791           break;
3792
3793         default:                /* : not followed by another :. */
3794           ffelex_send_token_ ();
3795           goto parse_next_character;    /* :::::::::::::::::::: */
3796         }
3797       break;
3798
3799     case FFELEX_typeSLASH:
3800       switch (c)
3801         {
3802         case '/':               /* // */
3803           ffelex_token_->type = FFELEX_typeCONCAT;
3804           ffelex_send_token_ ();
3805           break;
3806
3807         case ')':               /* /) */
3808           ffelex_token_->type = FFELEX_typeCLOSE_ARRAY;
3809           ffelex_send_token_ ();
3810           break;
3811
3812         case '=':               /* /= */
3813           ffelex_token_->type = FFELEX_typeREL_NE;
3814           ffelex_send_token_ ();
3815           break;
3816
3817         default:
3818           ffelex_send_token_ ();
3819           goto parse_next_character;    /* :::::::::::::::::::: */
3820         }
3821       break;
3822
3823     case FFELEX_typeOPEN_PAREN:
3824       switch (c)
3825         {
3826         case '/':               /* (/ */
3827           ffelex_token_->type = FFELEX_typeOPEN_ARRAY;
3828           ffelex_send_token_ ();
3829           break;
3830
3831         default:
3832           ffelex_send_token_ ();
3833           goto parse_next_character;    /* :::::::::::::::::::: */
3834         }
3835       break;
3836
3837     case FFELEX_typeOPEN_ANGLE:
3838       switch (c)
3839         {
3840         case '=':               /* <= */
3841           ffelex_token_->type = FFELEX_typeREL_LE;
3842           ffelex_send_token_ ();
3843           break;
3844
3845         default:
3846           ffelex_send_token_ ();
3847           goto parse_next_character;    /* :::::::::::::::::::: */
3848         }
3849       break;
3850
3851     case FFELEX_typeEQUALS:
3852       switch (c)
3853         {
3854         case '=':               /* == */
3855           ffelex_token_->type = FFELEX_typeREL_EQ;
3856           ffelex_send_token_ ();
3857           break;
3858
3859         case '>':               /* => */
3860           ffelex_token_->type = FFELEX_typePOINTS;
3861           ffelex_send_token_ ();
3862           break;
3863
3864         default:
3865           ffelex_send_token_ ();
3866           goto parse_next_character;    /* :::::::::::::::::::: */
3867         }
3868       break;
3869
3870     case FFELEX_typeCLOSE_ANGLE:
3871       switch (c)
3872         {
3873         case '=':               /* >= */
3874           ffelex_token_->type = FFELEX_typeREL_GE;
3875           ffelex_send_token_ ();
3876           break;
3877
3878         default:
3879           ffelex_send_token_ ();
3880           goto parse_next_character;    /* :::::::::::::::::::: */
3881         }
3882       break;
3883
3884     default:
3885       assert ("Serious error!" == NULL);
3886       abort ();
3887       break;
3888     }
3889
3890   c = ffelex_card_image_[++column];
3891
3892  parse_next_character:          /* :::::::::::::::::::: */
3893
3894   if (ffelex_raw_mode_ != 0)
3895     goto parse_raw_character;   /* :::::::::::::::::::: */
3896
3897   if ((c == '\0') || (c == '!'))
3898     {
3899       ffelex_finish_statement_ ();
3900       goto beginning_of_line;   /* :::::::::::::::::::: */
3901     }
3902   goto parse_nonraw_character;  /* :::::::::::::::::::: */
3903 }
3904
3905 /* See the code in com.c that calls this to understand why.  */
3906
3907 void
3908 ffelex_hash_kludge (FILE *finput)
3909 {
3910   /* If you change this constant string, you have to change whatever
3911      code might thus be affected by it in terms of having to use
3912      ffelex_getc_() instead of getc() in the lexers and _hash_.  */
3913   static char match[] = "# 1 \"";
3914   static int kludge[ARRAY_SIZE (match) + 1];
3915   int c;
3916   char *p;
3917   int *q;
3918
3919   /* Read chars as long as they match the target string.
3920      Copy them into an array that will serve as a record
3921      of what we read (essentially a multi-char ungetc(),
3922      for code that uses ffelex_getc_ instead of getc() elsewhere
3923      in the lexer.  */
3924   for (p = &match[0], q = &kludge[0], c = getc (finput);
3925        (c == *p) && (*p != '\0') && (c != EOF);
3926        ++p, ++q, c = getc (finput))
3927     *q = c;
3928
3929   *q = c;                       /* Might be EOF, which requires int. */
3930   *++q = 0;
3931
3932   ffelex_kludge_chars_ = &kludge[0];
3933
3934   if (*p == 0)
3935     {
3936       ffelex_kludge_flag_ = TRUE;
3937       ++ffelex_kludge_chars_;
3938       ffelex_hash_ (finput);    /* Handle it NOW rather than later. */
3939       ffelex_kludge_flag_ = FALSE;
3940     }
3941 }
3942
3943 void
3944 ffelex_init_1 ()
3945 {
3946   unsigned int i;
3947
3948   ffelex_final_nontab_column_ = ffe_fixed_line_length ();
3949   ffelex_card_size_ = FFELEX_columnINITIAL_SIZE_;
3950   ffelex_card_image_ = malloc_new_ksr (malloc_pool_image (),
3951                                        "FFELEX card image",
3952                                        FFELEX_columnINITIAL_SIZE_ + 9);
3953   ffelex_card_image_[0] = '\0';
3954
3955   for (i = 0; i < 256; ++i)
3956     ffelex_first_char_[i] = FFELEX_typeERROR;
3957
3958   ffelex_first_char_['\t'] = FFELEX_typeRAW;
3959   ffelex_first_char_['\n'] = FFELEX_typeCOMMENT;
3960   ffelex_first_char_['\v'] = FFELEX_typeCOMMENT;
3961   ffelex_first_char_['\f'] = FFELEX_typeCOMMENT;
3962   ffelex_first_char_['\r'] = FFELEX_typeRAW;
3963   ffelex_first_char_[' '] = FFELEX_typeRAW;
3964   ffelex_first_char_['!'] = FFELEX_typeCOMMENT;
3965   ffelex_first_char_['*'] = FFELEX_typeCOMMENT;
3966   ffelex_first_char_['/'] = FFELEX_typeSLASH;
3967   ffelex_first_char_['&'] = FFELEX_typeRAW;
3968   ffelex_first_char_['#'] = FFELEX_typeHASH;
3969
3970   for (i = '0'; i <= '9'; ++i)
3971     ffelex_first_char_[i] = FFELEX_typeRAW;
3972
3973   if ((ffe_case_match () == FFE_caseNONE)
3974       || ((ffe_case_match () == FFE_caseUPPER)
3975           && (ffe_case_source () != FFE_caseLOWER))     /* Idiot!  :-) */
3976       || ((ffe_case_match () == FFE_caseLOWER)
3977           && (ffe_case_source () == FFE_caseLOWER)))
3978     {
3979       ffelex_first_char_['C'] = FFELEX_typeCOMMENT;
3980       ffelex_first_char_['D'] = FFELEX_typeCOMMENT;
3981     }
3982   if ((ffe_case_match () == FFE_caseNONE)
3983       || ((ffe_case_match () == FFE_caseLOWER)
3984           && (ffe_case_source () != FFE_caseUPPER))     /* Idiot!  :-) */
3985       || ((ffe_case_match () == FFE_caseUPPER)
3986           && (ffe_case_source () == FFE_caseUPPER)))
3987     {
3988       ffelex_first_char_['c'] = FFELEX_typeCOMMENT;
3989       ffelex_first_char_['d'] = FFELEX_typeCOMMENT;
3990     }
3991
3992   ffelex_linecount_current_ = 0;
3993   ffelex_linecount_next_ = 1;
3994   ffelex_raw_mode_ = 0;
3995   ffelex_set_include_ = FALSE;
3996   ffelex_permit_include_ = FALSE;
3997   ffelex_names_ = TRUE;         /* First token in program is a names. */
3998   ffelex_names_pure_ = FALSE;   /* Free-form lexer does NAMES only for
3999                                    FORMAT. */
4000   ffelex_hexnum_ = FALSE;
4001   ffelex_expecting_hollerith_ = 0;
4002   ffelex_raw_where_line_ = ffewhere_line_unknown ();
4003   ffelex_raw_where_col_ = ffewhere_column_unknown ();
4004
4005   ffelex_token_ = ffelex_token_new_ ();
4006   ffelex_token_->type = FFELEX_typeNONE;
4007   ffelex_token_->uses = 1;
4008   ffelex_token_->where_line = ffewhere_line_unknown ();
4009   ffelex_token_->where_col = ffewhere_column_unknown ();
4010   ffelex_token_->text = NULL;
4011
4012   ffelex_handler_ = NULL;
4013 }
4014
4015 /* ffelex_is_names_expected -- Is the current parser expecting NAMES vs. NAME?
4016
4017    if (ffelex_is_names_expected())
4018        // Deliver NAMES token
4019      else
4020        // Deliver NAME token
4021
4022    Must be called while lexer is active, obviously.  */
4023
4024 bool
4025 ffelex_is_names_expected ()
4026 {
4027   return ffelex_names_;
4028 }
4029
4030 /* Current card image, which has the master linecount number
4031    ffelex_linecount_current_.  */
4032
4033 char *
4034 ffelex_line ()
4035 {
4036   return ffelex_card_image_;
4037 }
4038
4039 /* ffelex_line_length -- Return length of current lexer line
4040
4041    printf("Length is %lu\n",ffelex_line_length());
4042
4043    Must be called while lexer is active, obviously.  */
4044
4045 ffewhereColumnNumber
4046 ffelex_line_length ()
4047 {
4048   return ffelex_card_length_;
4049 }
4050
4051 /* Master line count of current card image, or 0 if no card image
4052    is current.  */
4053
4054 ffewhereLineNumber
4055 ffelex_line_number ()
4056 {
4057   return ffelex_linecount_current_;
4058 }
4059
4060 /* ffelex_set_expecting_hollerith -- Set hollerith expectation status
4061
4062    ffelex_set_expecting_hollerith(0);
4063
4064    Lex initially assumes no hollerith constant is about to show up.  If
4065    syntactic analysis expects one, it should call this function with the
4066    number of characters expected in the constant immediately after recognizing
4067    the decimal number preceding the "H" and the constant itself.  Then, if
4068    the next character is indeed H, the lexer will interpret it as beginning
4069    a hollerith constant and ship the token formed by reading the specified
4070    number of characters (interpreting blanks and otherwise-comments too)
4071    from the input file.  It is up to syntactic analysis to call this routine
4072    again with 0 to turn hollerith detection off immediately upon receiving
4073    the token that might or might not be HOLLERITH.
4074
4075    Also call this after seeing an APOSTROPHE or QUOTE token that begins a
4076    character constant.  Pass the expected termination character (apostrophe
4077    or quote).
4078
4079    Pass for length either the length of the hollerith (must be > 0), -1
4080    meaning expecting a character constant, or 0 to cancel expectation of
4081    a hollerith only after calling it with a length of > 0 and receiving the
4082    next token (which may or may not have been a HOLLERITH token).
4083
4084    Pass for which either an apostrophe or quote when passing length of -1.
4085    Else which is a don't-care.
4086
4087    Pass for line and column the line/column info for the token beginning the
4088    character or hollerith constant, for use in error messages, when passing
4089    a length of -1 -- this function will invoke ffewhere_line/column_use to
4090    make its own copies.  Else line and column are don't-cares (when length
4091    is 0) and the outstanding copies of the previous line/column info, if
4092    still around, are killed.
4093
4094    21-Feb-90  JCB  3.1
4095       When called with length of 0, also zero ffelex_raw_mode_.  This is
4096       so ffest_save_ can undo the effects of replaying tokens like
4097       APOSTROPHE and QUOTE.
4098    25-Jan-90  JCB  3.0
4099       New line, column arguments allow error messages to point to the true
4100       beginning of a character/hollerith constant, rather than the beginning
4101       of the content part, which makes them more consistent and helpful.
4102    05-Nov-89  JCB  2.0
4103       New "which" argument allows caller to specify termination character,
4104       which should be apostrophe or double-quote, to support Fortran 90.  */
4105
4106 void
4107 ffelex_set_expecting_hollerith (long length, char which,
4108                                 ffewhereLine line, ffewhereColumn column)
4109 {
4110
4111   /* First kill the pending line/col info, if any (should only be pending
4112      when this call has length==0, the previous call had length>0, and a
4113      non-HOLLERITH token was sent in between the calls, but play it safe). */
4114
4115   ffewhere_line_kill (ffelex_raw_where_line_);
4116   ffewhere_column_kill (ffelex_raw_where_col_);
4117
4118   /* Now handle the length function. */
4119   switch (length)
4120     {
4121     case 0:
4122       ffelex_expecting_hollerith_ = 0;
4123       ffelex_raw_mode_ = 0;
4124       ffelex_raw_where_line_ = ffewhere_line_unknown ();
4125       ffelex_raw_where_col_ = ffewhere_column_unknown ();
4126       return;                   /* Don't set new line/column info from args. */
4127
4128     case -1:
4129       ffelex_raw_mode_ = -1;
4130       ffelex_raw_char_ = which;
4131       break;
4132
4133     default:                    /* length > 0 */
4134       ffelex_expecting_hollerith_ = length;
4135       break;
4136     }
4137
4138   /* Now set new line/column information from passed args. */
4139
4140   ffelex_raw_where_line_ = ffewhere_line_use (line);
4141   ffelex_raw_where_col_ = ffewhere_column_use (column);
4142 }
4143
4144 /* ffelex_set_handler -- Set handler for tokens before calling _fixed or _free
4145
4146    ffelex_set_handler((ffelexHandler) my_first_handler);
4147
4148    Must be called before calling ffelex_file_fixed or ffelex_file_free or
4149    after they return, but not while they are active.  */
4150
4151 void
4152 ffelex_set_handler (ffelexHandler first)
4153 {
4154   ffelex_handler_ = first;
4155 }
4156
4157 /* ffelex_set_hexnum -- Set hexnum flag
4158
4159    ffelex_set_hexnum(TRUE);
4160
4161    Lex normally interprets a token starting with [0-9] as a NUMBER token,
4162    so if it sees a [A-Za-z] in it, it stops parsing the NUMBER and leaves
4163    the character as the first of the next token.  But when parsing a
4164    hexadecimal number, by calling this function with TRUE before starting
4165    the parse of the token itself, lex will interpret [0-9] as the start
4166    of a NAME token.  */
4167
4168 void
4169 ffelex_set_hexnum (bool f)
4170 {
4171   ffelex_hexnum_ = f;
4172 }
4173
4174 /* ffelex_set_include -- Set INCLUDE file to be processed next
4175
4176    ffewhereFile wf;  // The ffewhereFile object for the file.
4177    bool free_form;  // TRUE means read free-form file, FALSE fixed-form.
4178    FILE *fi;  // The file to INCLUDE.
4179    ffelex_set_include(wf,free_form,fi);
4180
4181    Must be called only after receiving the EOS token following a valid
4182    INCLUDE statement specifying a file that has already been successfully
4183    opened.  */
4184
4185 void
4186 ffelex_set_include (ffewhereFile wf, bool free_form, FILE *fi)
4187 {
4188   assert (ffelex_permit_include_);
4189   assert (!ffelex_set_include_);
4190   ffelex_set_include_ = TRUE;
4191   ffelex_include_free_form_ = free_form;
4192   ffelex_include_file_ = fi;
4193   ffelex_include_wherefile_ = wf;
4194 }
4195
4196 /* ffelex_set_names -- Set names/name flag, names = TRUE
4197
4198    ffelex_set_names(FALSE);
4199
4200    Lex initially assumes multiple names should be formed.  If this function is
4201    called with FALSE, then single names are formed instead.  The differences
4202    are a difference in the token type (FFELEX_typeNAMES vs. FFELEX_typeNAME)
4203    and in whether full source-location tracking is performed (it is for
4204    multiple names, not for single names), which is more expensive in terms of
4205    CPU time.  */
4206
4207 void
4208 ffelex_set_names (bool f)
4209 {
4210   ffelex_names_ = f;
4211   if (!f)
4212     ffelex_names_pure_ = FALSE;
4213 }
4214
4215 /* ffelex_set_names_pure -- Set names/name (pure) flag, names = TRUE
4216
4217    ffelex_set_names_pure(FALSE);
4218
4219    Like ffelex_set_names, except affects both lexers.  Normally, the
4220    free-form lexer need not generate NAMES tokens because adjacent NAME
4221    tokens must be separated by spaces which causes the lexer to generate
4222    separate tokens for analysis (whereas in fixed-form the spaces are
4223    ignored resulting in one long token).  But in FORMAT statements, for
4224    some reason, the Fortran 90 standard specifies that spaces can occur
4225    anywhere within a format-item-list with no effect on the format spec
4226    (except of course within character string edit descriptors), which means
4227    that "1PE14.2" and "1 P E 1 4 . 2" are equivalent.  For the FORMAT
4228    statement handling, the existence of spaces makes it hard to deal with,
4229    because each token is seen distinctly (i.e. seven tokens in the latter
4230    example).  But when no spaces are provided, as in the former example,
4231    then only four tokens are generated, NUMBER("1"), NAME("PE14"), PERIOD,
4232    NUMBER ("2").  By generating a NAMES instead of NAME, three things happen:
4233    One, ffest_kw_format_ does a substring rather than full-string match,
4234    and thus matches "PE14" to "PE"; two, ffelex_token_xyz_from_names functions
4235    may be used to pull NAME/NAMES and NUMBER tokens out of the NAMES token;
4236    and three, error reporting can point to the actual character rather than
4237    at or prior to it.  The first two things could be resolved by providing
4238    alternate functions fairly easy, thus allowing FORMAT handling to expect
4239    both lexers to generate NAME tokens instead of NAMES (with otherwise minor
4240    changes to FORMAT parsing), but the third, error reporting, would suffer,
4241    and when one makes mistakes in a FORMAT, believe me, one wants a pointer
4242    to exactly where the compilers thinks the problem is, to even begin to get
4243    a handle on it.  So there.  */
4244
4245 void
4246 ffelex_set_names_pure (bool f)
4247 {
4248   ffelex_names_pure_ = f;
4249   ffelex_names_ = f;
4250 }
4251
4252 /* ffelex_splice_tokens -- Splice off and send tokens from a NAMES
4253
4254    return (ffelexHandler) ffelex_splice_tokens(first_handler,master_token,
4255          start_char_index);
4256
4257    Returns first_handler if start_char_index chars into master_token (which
4258    must be a NAMES token) is '\0'. Else, creates a subtoken from that
4259    char, either NUMBER (if it is a digit), a NAME (if a valid firstnamechar),
4260    an UNDERSCORE (if an underscore), or DOLLAR (if a dollar sign)
4261    and sends it to first_handler. If anything other than NAME is sent, the
4262    character at the end of it in the master token is examined to see if it
4263    begins a NAME, NUMBER, UNDERSCORE, or DOLLAR, and, if so,
4264    the handler returned by first_handler is invoked with that token, and
4265    this process is repeated until the end of the master token or a NAME
4266    token is reached.  */
4267
4268 ffelexHandler
4269 ffelex_splice_tokens (ffelexHandler first, ffelexToken master,
4270                       ffeTokenLength start)
4271 {
4272   unsigned char *p;
4273   ffeTokenLength i;
4274   ffelexToken t;
4275
4276   p = ffelex_token_text (master) + (i = start);
4277
4278   while (*p != '\0')
4279     {
4280       if (ISDIGIT (*p))
4281         {
4282           t = ffelex_token_number_from_names (master, i);
4283           p += ffelex_token_length (t);
4284           i += ffelex_token_length (t);
4285         }
4286       else if (ffesrc_is_name_init (*p))
4287         {
4288           t = ffelex_token_name_from_names (master, i, 0);
4289           p += ffelex_token_length (t);
4290           i += ffelex_token_length (t);
4291         }
4292       else if (*p == '$')
4293         {
4294           t = ffelex_token_dollar_from_names (master, i);
4295           ++p;
4296           ++i;
4297         }
4298       else if (*p == '_')
4299         {
4300           t = ffelex_token_uscore_from_names (master, i);
4301           ++p;
4302           ++i;
4303         }
4304       else
4305         {
4306           assert ("not a valid NAMES character" == NULL);
4307           t = NULL;
4308         }
4309       assert (first != NULL);
4310       first = (ffelexHandler) (*first) (t);
4311       ffelex_token_kill (t);
4312     }
4313
4314   return first;
4315 }
4316
4317 /* ffelex_swallow_tokens -- Eat all tokens delivered to me
4318
4319    return ffelex_swallow_tokens;
4320
4321    Return this handler when you don't want to look at any more tokens in the
4322    statement because you've encountered an unrecoverable error in the
4323    statement.  */
4324
4325 ffelexHandler
4326 ffelex_swallow_tokens (ffelexToken t, ffelexHandler handler)
4327 {
4328   assert (handler != NULL);
4329
4330   if ((t != NULL) && ((ffelex_token_type (t) == FFELEX_typeEOS)
4331                       || (ffelex_token_type (t) == FFELEX_typeSEMICOLON)))
4332     return (ffelexHandler) (*handler) (t);
4333
4334   ffelex_eos_handler_ = handler;
4335   return (ffelexHandler) ffelex_swallow_tokens_;
4336 }
4337
4338 /* ffelex_token_dollar_from_names -- Return a dollar from within a names token
4339
4340    ffelexToken t;
4341    t = ffelex_token_dollar_from_names(t,6);
4342
4343    It's as if you made a new token of dollar type having the dollar
4344    at, in the example above, the sixth character of the NAMES token.  */
4345
4346 ffelexToken
4347 ffelex_token_dollar_from_names (ffelexToken t, ffeTokenLength start)
4348 {
4349   ffelexToken nt;
4350
4351   assert (t != NULL);
4352   assert (ffelex_token_type (t) == FFELEX_typeNAMES);
4353   assert (start < t->length);
4354   assert (t->text[start] == '$');
4355
4356   /* Now make the token. */
4357
4358   nt = ffelex_token_new_ ();
4359   nt->type = FFELEX_typeDOLLAR;
4360   nt->length = 0;
4361   nt->uses = 1;
4362   ffewhere_set_from_track (&nt->where_line, &nt->where_col, t->where_line,
4363                            t->where_col, t->wheretrack, start);
4364   nt->text = NULL;
4365   return nt;
4366 }
4367
4368 /* ffelex_token_kill -- Decrement use count for token, kill if no uses left
4369
4370    ffelexToken t;
4371    ffelex_token_kill(t);
4372
4373    Complements a call to ffelex_token_use or ffelex_token_new_....  */
4374
4375 void
4376 ffelex_token_kill (ffelexToken t)
4377 {
4378   assert (t != NULL);
4379
4380   assert (t->uses > 0);
4381
4382   if (--t->uses != 0)
4383     return;
4384
4385   --ffelex_total_tokens_;
4386
4387   if (t->type == FFELEX_typeNAMES)
4388     ffewhere_track_kill (t->where_line, t->where_col,
4389                          t->wheretrack, t->length);
4390   ffewhere_line_kill (t->where_line);
4391   ffewhere_column_kill (t->where_col);
4392   if (t->text != NULL)
4393     malloc_kill_ksr (malloc_pool_image (), t->text, t->size + 1);
4394   malloc_kill_ks (malloc_pool_image (), t, sizeof (*t));
4395 }
4396
4397 /* Make a new NAME token that is a substring of a NAMES token.  */
4398
4399 ffelexToken
4400 ffelex_token_name_from_names (ffelexToken t, ffeTokenLength start,
4401                               ffeTokenLength len)
4402 {
4403   ffelexToken nt;
4404
4405   assert (t != NULL);
4406   assert (ffelex_token_type (t) == FFELEX_typeNAMES);
4407   assert (start < t->length);
4408   if (len == 0)
4409     len = t->length - start;
4410   else
4411     {
4412       assert (len > 0);
4413       assert ((start + len) <= t->length);
4414     }
4415   assert (ffelex_is_firstnamechar ((unsigned char)(t->text[start])));
4416
4417   nt = ffelex_token_new_ ();
4418   nt->type = FFELEX_typeNAME;
4419   nt->size = len;               /* Assume nobody's gonna fiddle with token
4420                                    text. */
4421   nt->length = len;
4422   nt->uses = 1;
4423   ffewhere_set_from_track (&nt->where_line, &nt->where_col, t->where_line,
4424                            t->where_col, t->wheretrack, start);
4425   nt->text = malloc_new_ksr (malloc_pool_image (), "FFELEX token text",
4426                              len + 1);
4427   strncpy (nt->text, t->text + start, len);
4428   nt->text[len] = '\0';
4429   return nt;
4430 }
4431
4432 /* Make a new NAMES token that is a substring of another NAMES token.  */
4433
4434 ffelexToken
4435 ffelex_token_names_from_names (ffelexToken t, ffeTokenLength start,
4436                                ffeTokenLength len)
4437 {
4438   ffelexToken nt;
4439
4440   assert (t != NULL);
4441   assert (ffelex_token_type (t) == FFELEX_typeNAMES);
4442   assert (start < t->length);
4443   if (len == 0)
4444     len = t->length - start;
4445   else
4446     {
4447       assert (len > 0);
4448       assert ((start + len) <= t->length);
4449     }
4450   assert (ffelex_is_firstnamechar ((unsigned char)(t->text[start])));
4451
4452   nt = ffelex_token_new_ ();
4453   nt->type = FFELEX_typeNAMES;
4454   nt->size = len;               /* Assume nobody's gonna fiddle with token
4455                                    text. */
4456   nt->length = len;
4457   nt->uses = 1;
4458   ffewhere_set_from_track (&nt->where_line, &nt->where_col, t->where_line,
4459                            t->where_col, t->wheretrack, start);
4460   ffewhere_track_copy (nt->wheretrack, t->wheretrack, start, len);
4461   nt->text = malloc_new_ksr (malloc_pool_image (), "FFELEX token text",
4462                              len + 1);
4463   strncpy (nt->text, t->text + start, len);
4464   nt->text[len] = '\0';
4465   return nt;
4466 }
4467
4468 /* Make a new CHARACTER token.  */
4469
4470 ffelexToken
4471 ffelex_token_new_character (const char *s, ffewhereLine l, ffewhereColumn c)
4472 {
4473   ffelexToken t;
4474
4475   t = ffelex_token_new_ ();
4476   t->type = FFELEX_typeCHARACTER;
4477   t->length = t->size = strlen (s);     /* Assume it won't get bigger. */
4478   t->uses = 1;
4479   t->text = malloc_new_ksr (malloc_pool_image (), "FFELEX token text",
4480                             t->size + 1);
4481   strcpy (t->text, s);
4482   t->where_line = ffewhere_line_use (l);
4483   t->where_col = ffewhere_column_new (c);
4484   return t;
4485 }
4486
4487 /* Make a new EOF token right after end of file.  */
4488
4489 ffelexToken
4490 ffelex_token_new_eof ()
4491 {
4492   ffelexToken t;
4493
4494   t = ffelex_token_new_ ();
4495   t->type = FFELEX_typeEOF;
4496   t->uses = 1;
4497   t->text = NULL;
4498   t->where_line = ffewhere_line_new (ffelex_linecount_current_);
4499   t->where_col = ffewhere_column_new (1);
4500   return t;
4501 }
4502
4503 /* Make a new NAME token.  */
4504
4505 ffelexToken
4506 ffelex_token_new_name (const char *s, ffewhereLine l, ffewhereColumn c)
4507 {
4508   ffelexToken t;
4509
4510   assert (ffelex_is_firstnamechar ((unsigned char)*s));
4511
4512   t = ffelex_token_new_ ();
4513   t->type = FFELEX_typeNAME;
4514   t->length = t->size = strlen (s);     /* Assume it won't get bigger. */
4515   t->uses = 1;
4516   t->text = malloc_new_ksr (malloc_pool_image (), "FFELEX token text",
4517                             t->size + 1);
4518   strcpy (t->text, s);
4519   t->where_line = ffewhere_line_use (l);
4520   t->where_col = ffewhere_column_new (c);
4521   return t;
4522 }
4523
4524 /* Make a new NAMES token.  */
4525
4526 ffelexToken
4527 ffelex_token_new_names (const char *s, ffewhereLine l, ffewhereColumn c)
4528 {
4529   ffelexToken t;
4530
4531   assert (ffelex_is_firstnamechar ((unsigned char)*s));
4532
4533   t = ffelex_token_new_ ();
4534   t->type = FFELEX_typeNAMES;
4535   t->length = t->size = strlen (s);     /* Assume it won't get bigger. */
4536   t->uses = 1;
4537   t->text = malloc_new_ksr (malloc_pool_image (), "FFELEX token text",
4538                             t->size + 1);
4539   strcpy (t->text, s);
4540   t->where_line = ffewhere_line_use (l);
4541   t->where_col = ffewhere_column_new (c);
4542   ffewhere_track_clear (t->wheretrack, t->length);      /* Assume contiguous
4543                                                            names. */
4544   return t;
4545 }
4546
4547 /* Make a new NUMBER token.
4548
4549    The first character of the string must be a digit, and only the digits
4550    are copied into the new number.  So this may be used to easily extract
4551    a NUMBER token from within any text string.  Then the length of the
4552    resulting token may be used to calculate where the digits stopped
4553    in the original string.  */
4554
4555 ffelexToken
4556 ffelex_token_new_number (const char *s, ffewhereLine l, ffewhereColumn c)
4557 {
4558   ffelexToken t;
4559   ffeTokenLength len;
4560
4561   /* How long is the string of decimal digits at s? */
4562
4563   len = strspn (s, "0123456789");
4564
4565   /* Make sure there is at least one digit. */
4566
4567   assert (len != 0);
4568
4569   /* Now make the token. */
4570
4571   t = ffelex_token_new_ ();
4572   t->type = FFELEX_typeNUMBER;
4573   t->length = t->size = len;    /* Assume it won't get bigger. */
4574   t->uses = 1;
4575   t->text = malloc_new_ksr (malloc_pool_image (), "FFELEX token text",
4576                             len + 1);
4577   strncpy (t->text, s, len);
4578   t->text[len] = '\0';
4579   t->where_line = ffewhere_line_use (l);
4580   t->where_col = ffewhere_column_new (c);
4581   return t;
4582 }
4583
4584 /* Make a new token of any type that doesn't contain text.  A private
4585    function that is used by public macros in the interface file.  */
4586
4587 ffelexToken
4588 ffelex_token_new_simple_ (ffelexType type, ffewhereLine l, ffewhereColumn c)
4589 {
4590   ffelexToken t;
4591
4592   t = ffelex_token_new_ ();
4593   t->type = type;
4594   t->uses = 1;
4595   t->text = NULL;
4596   t->where_line = ffewhere_line_use (l);
4597   t->where_col = ffewhere_column_new (c);
4598   return t;
4599 }
4600
4601 /* Make a new NUMBER token from an existing NAMES token.
4602
4603    Like ffelex_token_new_number, this function calculates the length
4604    of the digit string itself.  */
4605
4606 ffelexToken
4607 ffelex_token_number_from_names (ffelexToken t, ffeTokenLength start)
4608 {
4609   ffelexToken nt;
4610   ffeTokenLength len;
4611
4612   assert (t != NULL);
4613   assert (ffelex_token_type (t) == FFELEX_typeNAMES);
4614   assert (start < t->length);
4615
4616   /* How long is the string of decimal digits at s? */
4617
4618   len = strspn (t->text + start, "0123456789");
4619
4620   /* Make sure there is at least one digit. */
4621
4622   assert (len != 0);
4623
4624   /* Now make the token. */
4625
4626   nt = ffelex_token_new_ ();
4627   nt->type = FFELEX_typeNUMBER;
4628   nt->size = len;               /* Assume nobody's gonna fiddle with token
4629                                    text. */
4630   nt->length = len;
4631   nt->uses = 1;
4632   ffewhere_set_from_track (&nt->where_line, &nt->where_col, t->where_line,
4633                            t->where_col, t->wheretrack, start);
4634   nt->text = malloc_new_ksr (malloc_pool_image (), "FFELEX token text",
4635                              len + 1);
4636   strncpy (nt->text, t->text + start, len);
4637   nt->text[len] = '\0';
4638   return nt;
4639 }
4640
4641 /* Make a new UNDERSCORE token from a NAMES token.  */
4642
4643 ffelexToken
4644 ffelex_token_uscore_from_names (ffelexToken t, ffeTokenLength start)
4645 {
4646   ffelexToken nt;
4647
4648   assert (t != NULL);
4649   assert (ffelex_token_type (t) == FFELEX_typeNAMES);
4650   assert (start < t->length);
4651   assert (t->text[start] == '_');
4652
4653   /* Now make the token. */
4654
4655   nt = ffelex_token_new_ ();
4656   nt->type = FFELEX_typeUNDERSCORE;
4657   nt->uses = 1;
4658   ffewhere_set_from_track (&nt->where_line, &nt->where_col, t->where_line,
4659                            t->where_col, t->wheretrack, start);
4660   nt->text = NULL;
4661   return nt;
4662 }
4663
4664 /* ffelex_token_use -- Return another instance of a token
4665
4666    ffelexToken t;
4667    t = ffelex_token_use(t);
4668
4669    In a sense, the new token is a copy of the old, though it might be the
4670    same with just a new use count.
4671
4672    We use the use count method (easy).  */
4673
4674 ffelexToken
4675 ffelex_token_use (ffelexToken t)
4676 {
4677   if (t == NULL)
4678     assert ("_token_use: null token" == NULL);
4679   t->uses++;
4680   return t;
4681 }