gcc/f/lex.c

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