contrib/gcc/f/lex.c

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