gcc/f/lex.c

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