gcc/f/lex.c

   1 /* Implementation of Fortran lexer
   2    Copyright (C) 1995-1997 Free Software Foundation, Inc.
   3    Contributed by James Craig Burley (burley@gnu.ai.mit.edu).
   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 <ctype.h>
  24 #include "top.h"
  25 #include "bad.h"
  26 #include "com.h"
  27 #include "lex.h"
  28 #include "malloc.h"
  29 #include "src.h"
  30 #if FFECOM_targetCURRENT == FFECOM_targetGCC
  31 #include "config.j"
  32 #include "flags.j"
  33 #include "input.j"
  34 #include "tree.j"
  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                                    another 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 static int
1081 ffelex_hash_ (FILE *finput)
1082 {
1083   register int c;
1084   ffelexToken token = NULL;
1085
1086   /* Read first nonwhite char after the `#'.  */
1087
1088   c = ffelex_getc_ (finput);
1089   while (c == ' ' || c == '\t')
1090     c = ffelex_getc_ (finput);
1091
1092   /* If a letter follows, then if the word here is `line', skip
1093      it and ignore it; otherwise, ignore the line, with an error
1094      if the word isn't `pragma', `ident', `define', or `undef'.  */
1095
1096   if ((c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z'))
1097     {
1098       if (c == 'p')
1099         {
1100           if (getc (finput) == 'r'
1101               && getc (finput) == 'a'
1102               && getc (finput) == 'g'
1103               && getc (finput) == 'm'
1104               && getc (finput) == 'a'
1105               && ((c = getc (finput)) == ' ' || c == '\t' || c == '\n'
1106                   || c == EOF))
1107             {
1108               goto skipline;
1109 #if 0   /* g77 doesn't handle pragmas, so ignores them FOR NOW. */
1110 #ifdef HANDLE_SYSV_PRAGMA
1111               return handle_sysv_pragma (finput, c);
1112 #else /* !HANDLE_SYSV_PRAGMA */
1113 #ifdef HANDLE_PRAGMA
1114               HANDLE_PRAGMA (finput);
1115 #endif /* HANDLE_PRAGMA */
1116               goto skipline;
1117 #endif /* !HANDLE_SYSV_PRAGMA */
1118 #endif /* 0 */
1119             }
1120         }
1121
1122       else if (c == 'd')
1123         {
1124           if (getc (finput) == 'e'
1125               && getc (finput) == 'f'
1126               && getc (finput) == 'i'
1127               && getc (finput) == 'n'
1128               && getc (finput) == 'e'
1129               && ((c = getc (finput)) == ' ' || c == '\t' || c == '\n'
1130                   || c == EOF))
1131             {
1132               char *text;
1133
1134               c = ffelex_get_directive_line_ (&text, finput);
1135
1136 #ifdef DWARF_DEBUGGING_INFO
1137               if ((debug_info_level == DINFO_LEVEL_VERBOSE)
1138                   && (write_symbols == DWARF_DEBUG))
1139                 dwarfout_define (lineno, text);
1140 #endif /* DWARF_DEBUGGING_INFO */
1141
1142               goto skipline;
1143             }
1144         }
1145       else if (c == 'u')
1146         {
1147           if (getc (finput) == 'n'
1148               && getc (finput) == 'd'
1149               && getc (finput) == 'e'
1150               && getc (finput) == 'f'
1151               && ((c = getc (finput)) == ' ' || c == '\t' || c == '\n'
1152                   || c == EOF))
1153             {
1154               char *text;
1155
1156               c = ffelex_get_directive_line_ (&text, finput);
1157
1158 #ifdef DWARF_DEBUGGING_INFO
1159               if ((debug_info_level == DINFO_LEVEL_VERBOSE)
1160                   && (write_symbols == DWARF_DEBUG))
1161                 dwarfout_undef (lineno, text);
1162 #endif /* DWARF_DEBUGGING_INFO */
1163
1164               goto skipline;
1165             }
1166         }
1167       else if (c == 'l')
1168         {
1169           if (getc (finput) == 'i'
1170               && getc (finput) == 'n'
1171               && getc (finput) == 'e'
1172               && ((c = getc (finput)) == ' ' || c == '\t'))
1173             goto linenum;
1174         }
1175       else if (c == 'i')
1176         {
1177           if (getc (finput) == 'd'
1178               && getc (finput) == 'e'
1179               && getc (finput) == 'n'
1180               && getc (finput) == 't'
1181               && ((c = getc (finput)) == ' ' || c == '\t'))
1182             {
1183               /* #ident.  The pedantic warning is now in cccp.c.  */
1184
1185               /* Here we have just seen `#ident '.
1186                  A string constant should follow.  */
1187
1188               while (c == ' ' || c == '\t')
1189                 c = getc (finput);
1190
1191               /* If no argument, ignore the line.  */
1192               if (c == '\n' || c == EOF)
1193                 return c;
1194
1195               c = ffelex_cfelex_ (&token, finput, c);
1196
1197               if ((token == NULL)
1198                   || (ffelex_token_type (token) != FFELEX_typeCHARACTER))
1199                 {
1200                   error ("invalid #ident");
1201                   goto skipline;
1202                 }
1203
1204               if (ffe_is_ident ())
1205                 {
1206 #ifdef ASM_OUTPUT_IDENT
1207                   ASM_OUTPUT_IDENT (asm_out_file,
1208                                     ffelex_token_text (token));
1209 #endif
1210                 }
1211
1212               /* Skip the rest of this line.  */
1213               goto skipline;
1214             }
1215         }
1216
1217       error ("undefined or invalid # directive");
1218       goto skipline;
1219     }
1220
1221  linenum:
1222   /* Here we have either `#line' or `# <nonletter>'.
1223      In either case, it should be a line number; a digit should follow.  */
1224
1225   while (c == ' ' || c == '\t')
1226     c = ffelex_getc_ (finput);
1227
1228   /* If the # is the only nonwhite char on the line,
1229      just ignore it.  Check the new newline.  */
1230   if (c == '\n' || c == EOF)
1231     return c;
1232
1233   /* Something follows the #; read a token.  */
1234
1235   c = ffelex_cfelex_ (&token, finput, c);
1236
1237   if ((token != NULL)
1238       && (ffelex_token_type (token) == FFELEX_typeNUMBER))
1239     {
1240       int old_lineno = lineno;
1241       char *old_input_filename = input_filename;
1242       ffewhereFile wf;
1243
1244       /* subtract one, because it is the following line that
1245          gets the specified number */
1246       int l = atoi (ffelex_token_text (token)) - 1;
1247
1248       /* Is this the last nonwhite stuff on the line?  */
1249       while (c == ' ' || c == '\t')
1250         c = ffelex_getc_ (finput);
1251       if (c == '\n' || c == EOF)
1252         {
1253           /* No more: store the line number and check following line.  */
1254           lineno = l;
1255           if (!ffelex_kludge_flag_)
1256             {
1257               ffewhere_file_set (NULL, TRUE, (ffewhereLineNumber) l);
1258
1259               if (token != NULL)
1260                 ffelex_token_kill (token);
1261             }
1262           return c;
1263         }
1264
1265       /* More follows: it must be a string constant (filename).  */
1266
1267       /* Read the string constant.  */
1268       c = ffelex_cfelex_ (&token, finput, c);
1269
1270       if ((token == NULL)
1271           || (ffelex_token_type (token) != FFELEX_typeCHARACTER))
1272         {
1273           error ("invalid #line");
1274           goto skipline;
1275         }
1276
1277       lineno = l;
1278
1279       if (ffelex_kludge_flag_)
1280         input_filename = ffelex_token_text (token);
1281       else
1282         {
1283           wf = ffewhere_file_new (ffelex_token_text (token),
1284                                   ffelex_token_length (token));
1285           input_filename = ffewhere_file_name (wf);
1286           ffewhere_file_set (wf, TRUE, (ffewhereLineNumber) l);
1287         }
1288
1289 #if 0   /* Not sure what g77 should do with this yet. */
1290       /* Each change of file name
1291          reinitializes whether we are now in a system header.  */
1292       in_system_header = 0;
1293 #endif
1294
1295       if (main_input_filename == 0)
1296         main_input_filename = input_filename;
1297
1298       /* Is this the last nonwhite stuff on the line?  */
1299       while (c == ' ' || c == '\t')
1300         c = getc (finput);
1301       if (c == '\n' || c == EOF)
1302         {
1303           if (!ffelex_kludge_flag_)
1304             {
1305               /* Update the name in the top element of input_file_stack.  */
1306               if (input_file_stack)
1307                 input_file_stack->name = input_filename;
1308
1309               if (token != NULL)
1310                 ffelex_token_kill (token);
1311             }
1312           return c;
1313         }
1314
1315       c = ffelex_cfelex_ (&token, finput, c);
1316
1317       /* `1' after file name means entering new file.
1318          `2' after file name means just left a file.  */
1319
1320       if ((token != NULL)
1321           && (ffelex_token_type (token) == FFELEX_typeNUMBER))
1322         {
1323           int num = atoi (ffelex_token_text (token));
1324
1325           if (ffelex_kludge_flag_)
1326             {
1327               lineno = 1;
1328               input_filename = old_input_filename;
1329               fatal ("Use `#line ...' instead of `# ...' in first line");
1330             }
1331
1332           if (num == 1)
1333             {
1334               /* Pushing to a new file.  */
1335               ffelex_file_push_ (old_lineno, input_filename);
1336             }
1337           else if (num == 2)
1338             {
1339               /* Popping out of a file.  */
1340               ffelex_file_pop_ (input_filename);
1341             }
1342
1343           /* Is this the last nonwhite stuff on the line?  */
1344           while (c == ' ' || c == '\t')
1345             c = getc (finput);
1346           if (c == '\n' || c == EOF)
1347             {
1348               if (token != NULL)
1349                 ffelex_token_kill (token);
1350               return c;
1351             }
1352
1353           c = ffelex_cfelex_ (&token, finput, c);
1354         }
1355
1356       /* `3' after file name means this is a system header file.  */
1357
1358 #if 0   /* Not sure what g77 should do with this yet. */
1359       if ((token != NULL)
1360           && (ffelex_token_type (token) == FFELEX_typeNUMBER)
1361           && (atoi (ffelex_token_text (token)) == 3))
1362         in_system_header = 1;
1363 #endif
1364
1365       while (c == ' ' || c == '\t')
1366         c = getc (finput);
1367       if (((token != NULL)
1368            || (c != '\n' && c != EOF))
1369           && ffelex_kludge_flag_)
1370         {
1371           lineno = 1;
1372           input_filename = old_input_filename;
1373           fatal ("Use `#line ...' instead of `# ...' in first line");
1374         }
1375     }
1376   else
1377     error ("invalid #-line");
1378
1379   /* skip the rest of this line.  */
1380  skipline:
1381   if ((token != NULL) && !ffelex_kludge_flag_)
1382     ffelex_token_kill (token);
1383   while ((c = getc (finput)) != EOF && c != '\n')
1384     ;
1385   return c;
1386 }
1387 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
1388
1389 /* "Image" a character onto the card image, return incremented column number.
1390
1391    Normally invoking this function as in
1392      column = ffelex_image_char_ (c, column);
1393    is the same as doing:
1394      ffelex_card_image_[column++] = c;
1395
1396    However, tabs and carriage returns are handled specially, to preserve
1397    the visual "image" of the input line (in most editors) in the card
1398    image.
1399
1400    Carriage returns are ignored, as they are assumed to be followed
1401    by newlines.
1402
1403    A tab is handled by first doing:
1404      ffelex_card_image_[column++] = ' ';
1405    That is, it translates to at least one space.  Then, as many spaces
1406    are imaged as necessary to bring the column number to the next tab
1407    position, where tab positions start in the ninth column and each
1408    eighth column afterwards.  ALSO, a static var named ffelex_saw_tab_
1409    is set to TRUE to notify the lexer that a tab was seen.
1410
1411    Columns are numbered and tab stops set as illustrated below:
1412
1413    012345670123456701234567...
1414    x       y       z
1415    xx      yy      zz
1416    ...
1417    xxxxxxx yyyyyyy zzzzzzz
1418    xxxxxxxx        yyyyyyyy...  */
1419
1420 static ffewhereColumnNumber
1421 ffelex_image_char_ (int c, ffewhereColumnNumber column)
1422 {
1423   ffewhereColumnNumber old_column = column;
1424
1425   if (column >= ffelex_card_size_)
1426     {
1427       ffewhereColumnNumber newmax = ffelex_card_size_ << 1;
1428
1429       if (ffelex_bad_line_)
1430         return column;
1431
1432       if ((newmax >> 1) != ffelex_card_size_)
1433         {                       /* Overflowed column number. */
1434         overflow:       /* :::::::::::::::::::: */
1435
1436           ffelex_bad_line_ = TRUE;
1437           strcpy (&ffelex_card_image_[column - 3], "...");
1438           ffelex_card_length_ = column;
1439           ffelex_bad_1_ (FFEBAD_LINE_TOO_LONG,
1440                          ffelex_linecount_current_, column + 1);
1441           return column;
1442         }
1443
1444       ffelex_card_image_
1445         = malloc_resize_ksr (malloc_pool_image (),
1446                              ffelex_card_image_,
1447                              newmax + 9,
1448                              ffelex_card_size_ + 9);
1449       ffelex_card_size_ = newmax;
1450     }
1451
1452   switch (c)
1453     {
1454     case '\r':
1455       break;
1456
1457     case '\t':
1458       ffelex_saw_tab_ = TRUE;
1459       ffelex_card_image_[column++] = ' ';
1460       while ((column & 7) != 0)
1461         ffelex_card_image_[column++] = ' ';
1462       break;
1463
1464     case '\0':
1465       if (!ffelex_bad_line_)
1466         {
1467           ffelex_bad_line_ = TRUE;
1468           strcpy (&ffelex_card_image_[column], "[\\0]");
1469           ffelex_card_length_ = column + 4;
1470           ffebad_start_msg_lex ("Null character at %0 -- line ignored",
1471                                 FFEBAD_severityFATAL);
1472           ffelex_bad_here_ (0, ffelex_linecount_current_, column + 1);
1473           ffebad_finish ();
1474           column += 4;
1475         }
1476       break;
1477
1478     default:
1479       ffelex_card_image_[column++] = c;
1480       break;
1481     }
1482
1483   if (column < old_column)
1484     {
1485       column = old_column;
1486       goto overflow;    /* :::::::::::::::::::: */
1487     }
1488
1489   return column;
1490 }
1491
1492 static void
1493 ffelex_include_ ()
1494 {
1495   ffewhereFile include_wherefile = ffelex_include_wherefile_;
1496   FILE *include_file = ffelex_include_file_;
1497   /* The rest of this is to push, and after the INCLUDE file is processed,
1498      pop, the static lexer state info that pertains to each particular
1499      input file.  */
1500   char *card_image;
1501   ffewhereColumnNumber card_size = ffelex_card_size_;
1502   ffewhereColumnNumber card_length = ffelex_card_length_;
1503   ffewhereLine current_wl = ffelex_current_wl_;
1504   ffewhereColumn current_wc = ffelex_current_wc_;
1505   bool saw_tab = ffelex_saw_tab_;
1506   ffewhereColumnNumber final_nontab_column = ffelex_final_nontab_column_;
1507   ffewhereFile current_wf = ffelex_current_wf_;
1508   ffewhereLineNumber linecount_current = ffelex_linecount_current_;
1509   ffewhereLineNumber linecount_offset
1510     = ffewhere_line_filelinenum (current_wl);
1511 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1512   int old_lineno = lineno;
1513   char *old_input_filename = input_filename;
1514 #endif
1515
1516   if (card_length != 0)
1517     {
1518       card_image = malloc_new_ks (malloc_pool_image (),
1519                                   "FFELEX saved card image",
1520                                   card_length);
1521       memcpy (card_image, ffelex_card_image_, card_length);
1522     }
1523   else
1524     card_image = NULL;
1525
1526   ffelex_set_include_ = FALSE;
1527
1528   ffelex_next_line_ ();
1529
1530   ffewhere_file_set (include_wherefile, TRUE, 0);
1531
1532 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1533   ffelex_file_push_ (old_lineno, ffewhere_file_name (include_wherefile));
1534 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
1535
1536   if (ffelex_include_free_form_)
1537     ffelex_file_free (include_wherefile, include_file);
1538   else
1539     ffelex_file_fixed (include_wherefile, include_file);
1540
1541 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1542   ffelex_file_pop_ (ffewhere_file_name (current_wf));
1543 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
1544
1545   ffewhere_file_set (current_wf, TRUE, linecount_offset);
1546
1547   ffecom_close_include (include_file);
1548
1549   if (card_length != 0)
1550     {
1551 #ifdef REDUCE_CARD_SIZE_AFTER_BIGGY     /* Define if occasional large lines. */
1552 #error "need to handle possible reduction of card size here!!"
1553 #endif
1554       assert (ffelex_card_size_ >= card_length);        /* It shrunk?? */
1555       memcpy (ffelex_card_image_, card_image, card_length);
1556     }
1557   ffelex_card_image_[card_length] = '\0';
1558
1559 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1560   input_filename = old_input_filename;
1561   lineno = old_lineno;
1562 #endif
1563   ffelex_linecount_current_ = linecount_current;
1564   ffelex_current_wf_ = current_wf;
1565   ffelex_final_nontab_column_ = final_nontab_column;
1566   ffelex_saw_tab_ = saw_tab;
1567   ffelex_current_wc_ = current_wc;
1568   ffelex_current_wl_ = current_wl;
1569   ffelex_card_length_ = card_length;
1570   ffelex_card_size_ = card_size;
1571 }
1572
1573 /* ffelex_is_free_char_ctx_contin_ -- Character Context Continuation?
1574
1575    ffewhereColumnNumber col;
1576    int c;  // Char at col.
1577    if ((c == '&') && ffelex_is_free_char_ctx_contin_(col + 1))
1578        // We have a continuation indicator.
1579
1580    If there are <n> spaces starting at ffelex_card_image_[col] up through
1581    the null character, where <n> is 0 or greater, returns TRUE.  */
1582
1583 static bool
1584 ffelex_is_free_char_ctx_contin_ (ffewhereColumnNumber col)
1585 {
1586   while (ffelex_card_image_[col] != '\0')
1587     {
1588       if (ffelex_card_image_[col++] != ' ')
1589         return FALSE;
1590     }
1591   return TRUE;
1592 }
1593
1594 /* ffelex_is_free_nonc_ctx_contin_ -- Noncharacter Context Continuation?
1595
1596    ffewhereColumnNumber col;
1597    int c;  // Char at col.
1598    if ((c == '&') && ffelex_is_free_nonc_ctx_contin_(col + 1))
1599        // We have a continuation indicator.
1600
1601    If there are <n> spaces starting at ffelex_card_image_[col] up through
1602    the null character or '!', where <n> is 0 or greater, returns TRUE.  */
1603
1604 static bool
1605 ffelex_is_free_nonc_ctx_contin_ (ffewhereColumnNumber col)
1606 {
1607   while ((ffelex_card_image_[col] != '\0') && (ffelex_card_image_[col] != '!'))
1608     {
1609       if (ffelex_card_image_[col++] != ' ')
1610         return FALSE;
1611     }
1612   return TRUE;
1613 }
1614
1615 static void
1616 ffelex_next_line_ ()
1617 {
1618   ffelex_linecount_current_ = ffelex_linecount_next_;
1619   ++ffelex_linecount_next_;
1620 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1621   ++lineno;
1622 #endif
1623 }
1624
1625 static void
1626 ffelex_send_token_ ()
1627 {
1628   ++ffelex_number_of_tokens_;
1629
1630   ffelex_backslash_ (EOF, 0);
1631
1632   if (ffelex_token_->text == NULL)
1633     {
1634       if (ffelex_token_->type == FFELEX_typeCHARACTER)
1635         {
1636           ffelex_append_to_token_ ('\0');
1637           ffelex_token_->length = 0;
1638         }
1639     }
1640   else
1641     ffelex_token_->text[ffelex_token_->length] = '\0';
1642
1643   assert (ffelex_raw_mode_ == 0);
1644
1645   if (ffelex_token_->type == FFELEX_typeNAMES)
1646     {
1647       ffewhere_line_kill (ffelex_token_->currentnames_line);
1648       ffewhere_column_kill (ffelex_token_->currentnames_col);
1649     }
1650
1651   assert (ffelex_handler_ != NULL);
1652   ffelex_handler_ = (ffelexHandler) (*ffelex_handler_) (ffelex_token_);
1653   assert (ffelex_handler_ != NULL);
1654
1655   ffelex_token_kill (ffelex_token_);
1656
1657   ffelex_token_ = ffelex_token_new_ ();
1658   ffelex_token_->uses = 1;
1659   ffelex_token_->text = NULL;
1660   if (ffelex_raw_mode_ < 0)
1661     {
1662       ffelex_token_->type = FFELEX_typeCHARACTER;
1663       ffelex_token_->where_line = ffelex_raw_where_line_;
1664       ffelex_token_->where_col = ffelex_raw_where_col_;
1665       ffelex_raw_where_line_ = ffewhere_line_unknown ();
1666       ffelex_raw_where_col_ = ffewhere_column_unknown ();
1667     }
1668   else
1669     {
1670       ffelex_token_->type = FFELEX_typeNONE;
1671       ffelex_token_->where_line = ffewhere_line_unknown ();
1672       ffelex_token_->where_col = ffewhere_column_unknown ();
1673     }
1674
1675   if (ffelex_set_include_)
1676     ffelex_include_ ();
1677 }
1678
1679 /* ffelex_swallow_tokens_ -- Eat all tokens delivered to me
1680
1681    return ffelex_swallow_tokens_;
1682
1683    Return this handler when you don't want to look at any more tokens in the
1684    statement because you've encountered an unrecoverable error in the
1685    statement.  */
1686
1687 static ffelexHandler
1688 ffelex_swallow_tokens_ (ffelexToken t)
1689 {
1690   assert (ffelex_eos_handler_ != NULL);
1691
1692   if ((ffelex_token_type (t) == FFELEX_typeEOS)
1693       || (ffelex_token_type (t) == FFELEX_typeSEMICOLON))
1694     return (ffelexHandler) (*ffelex_eos_handler_) (t);
1695
1696   return (ffelexHandler) ffelex_swallow_tokens_;
1697 }
1698
1699 static ffelexToken
1700 ffelex_token_new_ ()
1701 {
1702   ffelexToken t;
1703
1704   ++ffelex_total_tokens_;
1705
1706   t = (ffelexToken) malloc_new_ks (malloc_pool_image (),
1707                                    "FFELEX token", sizeof (*t));
1708   t->id_ = ffelex_token_nextid_++;
1709   return t;
1710 }
1711
1712 static char *
1713 ffelex_type_string_ (ffelexType type)
1714 {
1715   static char *types[] = {
1716     "FFELEX_typeNONE",
1717     "FFELEX_typeCOMMENT",
1718     "FFELEX_typeEOS",
1719     "FFELEX_typeEOF",
1720     "FFELEX_typeERROR",
1721     "FFELEX_typeRAW",
1722     "FFELEX_typeQUOTE",
1723     "FFELEX_typeDOLLAR",
1724     "FFELEX_typeHASH",
1725     "FFELEX_typePERCENT",
1726     "FFELEX_typeAMPERSAND",
1727     "FFELEX_typeAPOSTROPHE",
1728     "FFELEX_typeOPEN_PAREN",
1729     "FFELEX_typeCLOSE_PAREN",
1730     "FFELEX_typeASTERISK",
1731     "FFELEX_typePLUS",
1732     "FFELEX_typeMINUS",
1733     "FFELEX_typePERIOD",
1734     "FFELEX_typeSLASH",
1735     "FFELEX_typeNUMBER",
1736     "FFELEX_typeOPEN_ANGLE",
1737     "FFELEX_typeEQUALS",
1738     "FFELEX_typeCLOSE_ANGLE",
1739     "FFELEX_typeNAME",
1740     "FFELEX_typeCOMMA",
1741     "FFELEX_typePOWER",
1742     "FFELEX_typeCONCAT",
1743     "FFELEX_typeDEBUG",
1744     "FFELEX_typeNAMES",
1745     "FFELEX_typeHOLLERITH",
1746     "FFELEX_typeCHARACTER",
1747     "FFELEX_typeCOLON",
1748     "FFELEX_typeSEMICOLON",
1749     "FFELEX_typeUNDERSCORE",
1750     "FFELEX_typeQUESTION",
1751     "FFELEX_typeOPEN_ARRAY",
1752     "FFELEX_typeCLOSE_ARRAY",
1753     "FFELEX_typeCOLONCOLON",
1754     "FFELEX_typeREL_LE",
1755     "FFELEX_typeREL_NE",
1756     "FFELEX_typeREL_EQ",
1757     "FFELEX_typePOINTS",
1758     "FFELEX_typeREL_GE"
1759   };
1760
1761   if (type >= ARRAY_SIZE (types))
1762     return "???";
1763   return types[type];
1764 }
1765
1766 void
1767 ffelex_display_token (ffelexToken t)
1768 {
1769   if (t == NULL)
1770     t = ffelex_token_;
1771
1772   fprintf (dmpout, "; Token #%lu is %s (line %" ffewhereLineNumber_f "u, col %"
1773            ffewhereColumnNumber_f "u)",
1774            t->id_,
1775            ffelex_type_string_ (t->type),
1776            ffewhere_line_number (t->where_line),
1777            ffewhere_column_number (t->where_col));
1778
1779   if (t->text != NULL)
1780     fprintf (dmpout, ": \"%.*s\"\n",
1781              (int) t->length,
1782              t->text);
1783   else
1784     fprintf (dmpout, ".\n");
1785 }
1786
1787 /* ffelex_expecting_character -- Tells if next token expected to be CHARACTER
1788
1789    if (ffelex_expecting_character())
1790        // next token delivered by lexer will be CHARACTER.
1791
1792    If the most recent call to ffelex_set_expecting_hollerith since the last
1793    token was delivered by the lexer passed a length of -1, then we return
1794    TRUE, because the next token we deliver will be typeCHARACTER, else we
1795    return FALSE.  */
1796
1797 bool
1798 ffelex_expecting_character ()
1799 {
1800   return (ffelex_raw_mode_ != 0);
1801 }
1802
1803 /* ffelex_file_fixed -- Lex a given file in fixed source form
1804
1805    ffewhere wf;
1806    FILE *f;
1807    ffelex_file_fixed(wf,f);
1808
1809    Lexes the file according to Fortran 90 ANSI + VXT specifications.  */
1810
1811 ffelexHandler
1812 ffelex_file_fixed (ffewhereFile wf, FILE *f)
1813 {
1814   register int c;               /* Character currently under consideration. */
1815   register ffewhereColumnNumber column; /* Not really; 0 means column 1... */
1816   bool disallow_continuation_line;
1817   bool ignore_disallowed_continuation;
1818   int latest_char_in_file = 0;  /* For getting back into comment-skipping
1819                                    code. */
1820   ffelexType lextype;
1821   ffewhereColumnNumber first_label_char;        /* First char of label --
1822                                                    column number. */
1823   char label_string[6];         /* Text of label. */
1824   int labi;                     /* Length of label text. */
1825   bool finish_statement;        /* Previous statement finished? */
1826   bool have_content;            /* This line have content? */
1827   bool just_do_label;           /* Nothing but label (and continuation?) on
1828                                    line. */
1829
1830   /* Lex is called for a particular file, not for a particular program unit.
1831      Yet the two events do share common characteristics.  The first line in a
1832      file or in a program unit cannot be a continuation line.  No token can
1833      be in mid-formation.  No current label for the statement exists, since
1834      there is no current statement. */
1835
1836   assert (ffelex_handler_ != NULL);
1837
1838 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1839   lineno = 0;
1840   input_filename = ffewhere_file_name (wf);
1841 #endif
1842   ffelex_current_wf_ = wf;
1843   disallow_continuation_line = TRUE;
1844   ignore_disallowed_continuation = FALSE;
1845   ffelex_token_->type = FFELEX_typeNONE;
1846   ffelex_number_of_tokens_ = 0;
1847   ffelex_label_tokens_ = 0;
1848   ffelex_current_wl_ = ffewhere_line_unknown ();
1849   ffelex_current_wc_ = ffewhere_column_unknown ();
1850   latest_char_in_file = '\n';
1851   goto first_line;              /* :::::::::::::::::::: */
1852
1853   /* Come here to get a new line. */
1854
1855  beginning_of_line:             /* :::::::::::::::::::: */
1856
1857   disallow_continuation_line = FALSE;
1858
1859   /* Come here directly when last line didn't clarify the continuation issue. */
1860
1861  beginning_of_line_again:       /* :::::::::::::::::::: */
1862
1863 #ifdef REDUCE_CARD_SIZE_AFTER_BIGGY     /* Define if occasional large lines. */
1864   if (ffelex_card_size_ != FFELEX_columnINITIAL_SIZE_)
1865     {
1866       ffelex_card_image_
1867         = malloc_resize_ks (malloc_pool_image (),
1868                             ffelex_card_image_,
1869                             FFELEX_columnINITIAL_SIZE_ + 9,
1870                             ffelex_card_size_ + 9);
1871       ffelex_card_size_ = FFELEX_columnINITIAL_SIZE_;
1872     }
1873 #endif
1874
1875  first_line:                    /* :::::::::::::::::::: */
1876
1877   c = latest_char_in_file;
1878   if ((c == EOF) || ((c = ffelex_getc_ (f)) == EOF))
1879     {
1880
1881     end_of_file:                /* :::::::::::::::::::: */
1882
1883       /* Line ending in EOF instead of \n still counts as a whole line. */
1884
1885       ffelex_finish_statement_ ();
1886       ffewhere_line_kill (ffelex_current_wl_);
1887       ffewhere_column_kill (ffelex_current_wc_);
1888       return (ffelexHandler) ffelex_handler_;
1889     }
1890
1891   ffelex_next_line_ ();
1892
1893   ffelex_bad_line_ = FALSE;
1894
1895   /* Skip over comment (and otherwise ignored) lines as quickly as possible! */
1896
1897   while (((lextype = ffelex_first_char_[c]) == FFELEX_typeCOMMENT)
1898          || (lextype == FFELEX_typeERROR)
1899          || (lextype == FFELEX_typeSLASH)
1900          || (lextype == FFELEX_typeHASH))
1901     {
1902       /* Test most frequent type of line first, etc.  */
1903       if ((lextype == FFELEX_typeCOMMENT)
1904           || ((lextype == FFELEX_typeSLASH)
1905               && ((c = getc (f)) == '*')))      /* NOTE SIDE-EFFECT. */
1906         {
1907           /* Typical case (straight comment), just ignore rest of line. */
1908         comment_line:           /* :::::::::::::::::::: */
1909
1910           while ((c != '\n') && (c != EOF))
1911             c = getc (f);
1912         }
1913 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1914       else if (lextype == FFELEX_typeHASH)
1915         c = ffelex_hash_ (f);
1916 #endif
1917       else if (lextype == FFELEX_typeSLASH)
1918         {
1919           /* SIDE-EFFECT ABOVE HAS HAPPENED. */
1920           ffelex_card_image_[0] = '/';
1921           ffelex_card_image_[1] = c;
1922           column = 2;
1923           goto bad_first_character;     /* :::::::::::::::::::: */
1924         }
1925       else
1926         /* typeERROR or unsupported typeHASH.  */
1927         {                       /* Bad first character, get line and display
1928                                    it with message. */
1929           column = ffelex_image_char_ (c, 0);
1930
1931         bad_first_character:    /* :::::::::::::::::::: */
1932
1933           ffelex_bad_line_ = TRUE;
1934           while (((c = getc (f)) != '\n') && (c != EOF))
1935             column = ffelex_image_char_ (c, column);
1936           ffelex_card_image_[column] = '\0';
1937           ffelex_card_length_ = column;
1938           ffelex_bad_1_ (FFEBAD_FIRST_CHAR_INVALID,
1939                          ffelex_linecount_current_, 1);
1940         }
1941
1942       /* Read past last char in line.  */
1943
1944       if (c == EOF)
1945         {
1946           ffelex_next_line_ ();
1947           goto end_of_file;     /* :::::::::::::::::::: */
1948         }
1949
1950       c = getc (f);
1951
1952       ffelex_next_line_ ();
1953
1954       if (c == EOF)
1955         goto end_of_file;       /* :::::::::::::::::::: */
1956
1957       ffelex_bad_line_ = FALSE;
1958     }                           /* while [c, first char, means comment] */
1959
1960   ffelex_saw_tab_
1961     = (c == '&')
1962       || (ffelex_final_nontab_column_ == 0);
1963
1964   if (lextype == FFELEX_typeDEBUG)
1965     c = ' ';                    /* A 'D' or 'd' in column 1 with the
1966                                    debug-lines option on. */
1967
1968   column = ffelex_image_char_ (c, 0);
1969
1970   /* Read the entire line in as is (with whitespace processing).  */
1971
1972   while (((c = getc (f)) != '\n') && (c != EOF))
1973     column = ffelex_image_char_ (c, column);
1974
1975   if (ffelex_bad_line_)
1976     {
1977       ffelex_card_image_[column] = '\0';
1978       ffelex_card_length_ = column;
1979       goto comment_line;                /* :::::::::::::::::::: */
1980     }
1981
1982   /* If no tab, cut off line after column 72/132.  */
1983
1984   if (!ffelex_saw_tab_ && (column > ffelex_final_nontab_column_))
1985     {
1986       /* Technically, we should now fill ffelex_card_image_ up thru column
1987          72/132 with spaces, since character/hollerith constants must count
1988          them in that manner. To save CPU time in several ways (avoid a loop
1989          here that would be used only when we actually end a line in
1990          character-constant mode; avoid writing memory unnecessarily; avoid a
1991          loop later checking spaces when not scanning for character-constant
1992          characters), we don't do this, and we do the appropriate thing when
1993          we encounter end-of-line while actually processing a character
1994          constant. */
1995
1996       column = ffelex_final_nontab_column_;
1997     }
1998   ffelex_card_image_[column] = '\0';
1999   ffelex_card_length_ = column;
2000
2001   /* Save next char in file so we can use register-based c while analyzing
2002      line we just read. */
2003
2004   latest_char_in_file = c;      /* Should be either '\n' or EOF. */
2005
2006   have_content = FALSE;
2007
2008   /* Handle label, if any. */
2009
2010   labi = 0;
2011   first_label_char = FFEWHERE_columnUNKNOWN;
2012   for (column = 0; column < 5; ++column)
2013     {
2014       switch (c = ffelex_card_image_[column])
2015         {
2016         case '\0':
2017         case '!':
2018           goto stop_looking;    /* :::::::::::::::::::: */
2019
2020         case ' ':
2021           break;
2022
2023         case '0':
2024         case '1':
2025         case '2':
2026         case '3':
2027         case '4':
2028         case '5':
2029         case '6':
2030         case '7':
2031         case '8':
2032         case '9':
2033           label_string[labi++] = c;
2034           if (first_label_char == FFEWHERE_columnUNKNOWN)
2035             first_label_char = column + 1;
2036           break;
2037
2038         case '&':
2039           if (column != 0)
2040             {
2041               ffelex_bad_1_ (FFEBAD_LABEL_FIELD_NOT_NUMERIC,
2042                              ffelex_linecount_current_,
2043                              column + 1);
2044               goto beginning_of_line_again;     /* :::::::::::::::::::: */
2045             }
2046           if (ffe_is_pedantic ())
2047             ffelex_bad_1_ (FFEBAD_AMPERSAND,
2048                            ffelex_linecount_current_, 1);
2049           finish_statement = FALSE;
2050           just_do_label = FALSE;
2051           goto got_a_continuation;      /* :::::::::::::::::::: */
2052
2053         case '/':
2054           if (ffelex_card_image_[column + 1] == '*')
2055             goto stop_looking;  /* :::::::::::::::::::: */
2056           /* Fall through. */
2057         default:
2058           ffelex_bad_1_ (FFEBAD_LABEL_FIELD_NOT_NUMERIC,
2059                          ffelex_linecount_current_, column + 1);
2060           goto beginning_of_line_again; /* :::::::::::::::::::: */
2061         }
2062     }
2063
2064  stop_looking:                  /* :::::::::::::::::::: */
2065
2066   label_string[labi] = '\0';
2067
2068   /* Find first nonblank char starting with continuation column. */
2069
2070   if (column == 5)              /* In which case we didn't see end of line in
2071                                    label field. */
2072     while ((c = ffelex_card_image_[column]) == ' ')
2073       ++column;
2074
2075   /* Now we're trying to figure out whether this is a continuation line and
2076      whether there's anything else of substance on the line.  The cases are
2077      as follows:
2078
2079      1. If a line has an explicit continuation character (other than the digit
2080      zero), then if it also has a label, the label is ignored and an error
2081      message is printed.  Any remaining text on the line is passed to the
2082      parser tasks, thus even an all-blank line (possibly with an ignored
2083      label) aside from a positive continuation character might have meaning
2084      in the midst of a character or hollerith constant.
2085
2086      2. If a line has no explicit continuation character (that is, it has a
2087      space in column 6 and the first non-space character past column 6 is
2088      not a digit 0-9), then there are two possibilities:
2089
2090      A. A label is present and/or a non-space (and non-comment) character
2091      appears somewhere after column 6.  Terminate processing of the previous
2092      statement, if any, send the new label for the next statement, if any,
2093      and start processing a new statement with this non-blank character, if
2094      any.
2095
2096      B. The line is essentially blank, except for a possible comment character.
2097      Don't terminate processing of the previous statement and don't pass any
2098      characters to the parser tasks, since the line is not flagged as a
2099      continuation line.  We treat it just like a completely blank line.
2100
2101      3. If a line has a continuation character of zero (0), then we terminate
2102      processing of the previous statement, if any, send the new label for the
2103      next statement, if any, and start processing a new statement, if any
2104      non-blank characters are present.
2105
2106      If, when checking to see if we should terminate the previous statement, it
2107      is found that there is no previous statement but that there is an
2108      outstanding label, substitute CONTINUE as the statement for the label
2109      and display an error message. */
2110
2111   finish_statement = FALSE;
2112   just_do_label = FALSE;
2113
2114   switch (c)
2115     {
2116     case '!':                   /* ANSI Fortran 90 says ! in column 6 is
2117                                    continuation. */
2118       /* VXT Fortran says ! anywhere is comment, even column 6. */
2119       if (ffe_is_vxt () || (column != 5))
2120         goto no_tokens_on_line; /* :::::::::::::::::::: */
2121       goto got_a_continuation;  /* :::::::::::::::::::: */
2122
2123     case '/':
2124       if (ffelex_card_image_[column + 1] != '*')
2125         goto some_other_character;      /* :::::::::::::::::::: */
2126       /* Fall through. */
2127       if (column == 5)
2128         {
2129           /* This seems right to do. But it is close to call, since / * starting
2130              in column 6 will thus be interpreted as a continuation line
2131              beginning with '*'. */
2132
2133           goto got_a_continuation;/* :::::::::::::::::::: */
2134         }
2135       /* Fall through. */
2136     case '\0':
2137       /* End of line.  Therefore may be continued-through line, so handle
2138          pending label as possible to-be-continued and drive end-of-statement
2139          for any previous statement, else treat as blank line. */
2140
2141      no_tokens_on_line:         /* :::::::::::::::::::: */
2142
2143       if (ffe_is_pedantic () && (c == '/'))
2144         ffelex_bad_1_ (FFEBAD_NON_ANSI_COMMENT,
2145                        ffelex_linecount_current_, column + 1);
2146       if (first_label_char != FFEWHERE_columnUNKNOWN)
2147         {                       /* Can't be a continued-through line if it
2148                                    has a label. */
2149           finish_statement = TRUE;
2150           have_content = TRUE;
2151           just_do_label = TRUE;
2152           break;
2153         }
2154       goto beginning_of_line_again;     /* :::::::::::::::::::: */
2155
2156     case '0':
2157       if (ffe_is_pedantic () && (column != 5))
2158         ffelex_bad_1_ (FFEBAD_NON_ANSI_CONTINUATION_COLUMN,
2159                        ffelex_linecount_current_, column + 1);
2160       finish_statement = TRUE;
2161       goto check_for_content;   /* :::::::::::::::::::: */
2162
2163     case '1':
2164     case '2':
2165     case '3':
2166     case '4':
2167     case '5':
2168     case '6':
2169     case '7':
2170     case '8':
2171     case '9':
2172
2173       /* NOTE: This label can be reached directly from the code
2174          that lexes the label field in columns 1-5.  */
2175      got_a_continuation:        /* :::::::::::::::::::: */
2176
2177       if (first_label_char != FFEWHERE_columnUNKNOWN)
2178         {
2179           ffelex_bad_2_ (FFEBAD_LABEL_ON_CONTINUATION,
2180                          ffelex_linecount_current_,
2181                          first_label_char,
2182                          ffelex_linecount_current_,
2183                          column + 1);
2184           first_label_char = FFEWHERE_columnUNKNOWN;
2185         }
2186       if (disallow_continuation_line)
2187         {
2188           if (!ignore_disallowed_continuation)
2189             ffelex_bad_1_ (FFEBAD_INVALID_CONTINUATION,
2190                            ffelex_linecount_current_, column + 1);
2191           goto beginning_of_line_again; /* :::::::::::::::::::: */
2192         }
2193       if (ffe_is_pedantic () && (column != 5))
2194         ffelex_bad_1_ (FFEBAD_NON_ANSI_CONTINUATION_COLUMN,
2195                        ffelex_linecount_current_, column + 1);
2196       if ((ffelex_raw_mode_ != 0)
2197           && (((c = ffelex_card_image_[column + 1]) != '\0')
2198               || !ffelex_saw_tab_))
2199         {
2200           ++column;
2201           have_content = TRUE;
2202           break;
2203         }
2204
2205      check_for_content:         /* :::::::::::::::::::: */
2206
2207       while ((c = ffelex_card_image_[++column]) == ' ')
2208         ;
2209       if ((c == '\0')
2210           || (c == '!')
2211           || ((c == '/')
2212               && (ffelex_card_image_[column + 1] == '*')))
2213         {
2214           if (ffe_is_pedantic () && (c == '/'))
2215             ffelex_bad_1_ (FFEBAD_NON_ANSI_COMMENT,
2216                            ffelex_linecount_current_, column + 1);
2217           just_do_label = TRUE;
2218         }
2219       else
2220         have_content = TRUE;
2221       break;
2222
2223     default:
2224
2225      some_other_character:      /* :::::::::::::::::::: */
2226
2227       if (column == 5)
2228         goto got_a_continuation;/* :::::::::::::::::::: */
2229
2230       /* Here is the very normal case of a regular character starting in
2231          column 7 or beyond with a blank in column 6. */
2232
2233       finish_statement = TRUE;
2234       have_content = TRUE;
2235       break;
2236     }
2237
2238   if (have_content
2239       || (first_label_char != FFEWHERE_columnUNKNOWN))
2240     {
2241       /* The line has content of some kind, install new end-statement
2242          point for error messages.  Note that "content" includes cases
2243          where there's little apparent content but enough to finish
2244          a statement.  That's because finishing a statement can trigger
2245          an impending INCLUDE, and that requires accurate line info being
2246          maintained by the lexer.  */
2247
2248       if (finish_statement)
2249         ffelex_prepare_eos_ (); /* Prepare EOS before we move current pointer. */
2250
2251       ffewhere_line_kill (ffelex_current_wl_);
2252       ffewhere_column_kill (ffelex_current_wc_);
2253       ffelex_current_wl_ = ffewhere_line_new (ffelex_linecount_current_);
2254       ffelex_current_wc_ = ffewhere_column_new (ffelex_card_length_ + 1);
2255     }
2256
2257   /* We delay this for a combination of reasons.  Mainly, it can start
2258      INCLUDE processing, and we want to delay that until the lexer's
2259      info on the line is coherent.  And we want to delay that until we're
2260      sure there's a reason to make that info coherent, to avoid saving
2261      lots of useless lines.  */
2262
2263   if (finish_statement)
2264     ffelex_finish_statement_ ();
2265
2266   /* If label is present, enclose it in a NUMBER token and send it along. */
2267
2268   if (first_label_char != FFEWHERE_columnUNKNOWN)
2269     {
2270       assert (ffelex_token_->type == FFELEX_typeNONE);
2271       ffelex_token_->type = FFELEX_typeNUMBER;
2272       ffelex_append_to_token_ ('\0');   /* Make room for label text. */
2273       strcpy (ffelex_token_->text, label_string);
2274       ffelex_token_->where_line
2275         = ffewhere_line_use (ffelex_current_wl_);
2276       ffelex_token_->where_col = ffewhere_column_new (first_label_char);
2277       ffelex_token_->length = labi;
2278       ffelex_send_token_ ();
2279       ++ffelex_label_tokens_;
2280     }
2281
2282   if (just_do_label)
2283     goto beginning_of_line;     /* :::::::::::::::::::: */
2284
2285   /* Here is the main engine for parsing.  c holds the character at column.
2286      It is already known that c is not a blank, end of line, or shriek,
2287      unless ffelex_raw_mode_ is not 0 (indicating we are in a
2288      character/hollerith constant). A partially filled token may already
2289      exist in ffelex_token_.  One special case: if, when the end of the line
2290      is reached, continuation_line is FALSE and the only token on the line is
2291      END, then it is indeed the last statement. We don't look for
2292      continuation lines during this program unit in that case. This is
2293      according to ANSI. */
2294
2295   if (ffelex_raw_mode_ != 0)
2296     {
2297
2298     parse_raw_character:        /* :::::::::::::::::::: */
2299
2300       if (c == '\0')
2301         {
2302           ffewhereColumnNumber i;
2303
2304           if (ffelex_saw_tab_ || (column >= ffelex_final_nontab_column_))
2305             goto beginning_of_line;     /* :::::::::::::::::::: */
2306
2307           /* Pad out line with "virtual" spaces. */
2308
2309           for (i = column; i < ffelex_final_nontab_column_; ++i)
2310             ffelex_card_image_[i] = ' ';
2311           ffelex_card_image_[i] = '\0';
2312           ffelex_card_length_ = i;
2313           c = ' ';
2314         }
2315
2316       switch (ffelex_raw_mode_)
2317         {
2318         case -3:
2319           c = ffelex_backslash_ (c, column);
2320           if (c == EOF)
2321             break;
2322
2323           if (!ffelex_backslash_reconsider_)
2324             ffelex_append_to_token_ (c);
2325           ffelex_raw_mode_ = -1;
2326           break;
2327
2328         case -2:
2329           if (c == ffelex_raw_char_)
2330             {
2331               ffelex_raw_mode_ = -1;
2332               ffelex_append_to_token_ (c);
2333             }
2334           else
2335             {
2336               ffelex_raw_mode_ = 0;
2337               ffelex_backslash_reconsider_ = TRUE;
2338             }
2339           break;
2340
2341         case -1:
2342           if (c == ffelex_raw_char_)
2343             ffelex_raw_mode_ = -2;
2344           else
2345             {
2346               c = ffelex_backslash_ (c, column);
2347               if (c == EOF)
2348                 {
2349                   ffelex_raw_mode_ = -3;
2350                   break;
2351                 }
2352
2353               ffelex_append_to_token_ (c);
2354             }
2355           break;
2356
2357         default:
2358           c = ffelex_backslash_ (c, column);
2359           if (c == EOF)
2360             break;
2361
2362           if (!ffelex_backslash_reconsider_)
2363             {
2364               ffelex_append_to_token_ (c);
2365               --ffelex_raw_mode_;
2366             }
2367           break;
2368         }
2369
2370       if (ffelex_backslash_reconsider_)
2371         ffelex_backslash_reconsider_ = FALSE;
2372       else
2373         c = ffelex_card_image_[++column];
2374
2375       if (ffelex_raw_mode_ == 0)
2376         {
2377           ffelex_send_token_ ();
2378           assert (ffelex_raw_mode_ == 0);
2379           while (c == ' ')
2380             c = ffelex_card_image_[++column];
2381           if ((c == '\0')
2382               || (c == '!')
2383               || ((c == '/')
2384                   && (ffelex_card_image_[column + 1] == '*')))
2385             goto beginning_of_line;     /* :::::::::::::::::::: */
2386           goto parse_nonraw_character;  /* :::::::::::::::::::: */
2387         }
2388       goto parse_raw_character; /* :::::::::::::::::::: */
2389     }
2390
2391  parse_nonraw_character:        /* :::::::::::::::::::: */
2392
2393   switch (ffelex_token_->type)
2394     {
2395     case FFELEX_typeNONE:
2396       switch (c)
2397         {
2398         case '\"':
2399           ffelex_token_->type = FFELEX_typeQUOTE;
2400           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
2401           ffelex_token_->where_col = ffewhere_column_new (column + 1);
2402           ffelex_send_token_ ();
2403           break;
2404
2405         case '$':
2406           ffelex_token_->type = FFELEX_typeDOLLAR;
2407           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
2408           ffelex_token_->where_col = ffewhere_column_new (column + 1);
2409           ffelex_send_token_ ();
2410           break;
2411
2412         case '%':
2413           ffelex_token_->type = FFELEX_typePERCENT;
2414           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
2415           ffelex_token_->where_col = ffewhere_column_new (column + 1);
2416           ffelex_send_token_ ();
2417           break;
2418
2419         case '&':
2420           ffelex_token_->type = FFELEX_typeAMPERSAND;
2421           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
2422           ffelex_token_->where_col = ffewhere_column_new (column + 1);
2423           ffelex_send_token_ ();
2424           break;
2425
2426         case '\'':
2427           ffelex_token_->type = FFELEX_typeAPOSTROPHE;
2428           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
2429           ffelex_token_->where_col = ffewhere_column_new (column + 1);
2430           ffelex_send_token_ ();
2431           break;
2432
2433         case '(':
2434           ffelex_token_->type = FFELEX_typeOPEN_PAREN;
2435           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
2436           ffelex_token_->where_col = ffewhere_column_new (column + 1);
2437           break;
2438
2439         case ')':
2440           ffelex_token_->type = FFELEX_typeCLOSE_PAREN;
2441           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
2442           ffelex_token_->where_col = ffewhere_column_new (column + 1);
2443           ffelex_send_token_ ();
2444           break;
2445
2446         case '*':
2447           ffelex_token_->type = FFELEX_typeASTERISK;
2448           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
2449           ffelex_token_->where_col = ffewhere_column_new (column + 1);
2450           break;
2451
2452         case '+':
2453           ffelex_token_->type = FFELEX_typePLUS;
2454           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
2455           ffelex_token_->where_col = ffewhere_column_new (column + 1);
2456           ffelex_send_token_ ();
2457           break;
2458
2459         case ',':
2460           ffelex_token_->type = FFELEX_typeCOMMA;
2461           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
2462           ffelex_token_->where_col = ffewhere_column_new (column + 1);
2463           ffelex_send_token_ ();
2464           break;
2465
2466         case '-':
2467           ffelex_token_->type = FFELEX_typeMINUS;
2468           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
2469           ffelex_token_->where_col = ffewhere_column_new (column + 1);
2470           ffelex_send_token_ ();
2471           break;
2472
2473         case '.':
2474           ffelex_token_->type = FFELEX_typePERIOD;
2475           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
2476           ffelex_token_->where_col = ffewhere_column_new (column + 1);
2477           ffelex_send_token_ ();
2478           break;
2479
2480         case '/':
2481           ffelex_token_->type = FFELEX_typeSLASH;
2482           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
2483           ffelex_token_->where_col = ffewhere_column_new (column + 1);
2484           break;
2485
2486         case '0':
2487         case '1':
2488         case '2':
2489         case '3':
2490         case '4':
2491         case '5':
2492         case '6':
2493         case '7':
2494         case '8':
2495         case '9':
2496           ffelex_token_->type
2497             = ffelex_hexnum_ ? FFELEX_typeNAME : FFELEX_typeNUMBER;
2498           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
2499           ffelex_token_->where_col = ffewhere_column_new (column + 1);
2500           ffelex_append_to_token_ (c);
2501           break;
2502
2503         case ':':
2504           ffelex_token_->type = FFELEX_typeCOLON;
2505           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
2506           ffelex_token_->where_col = ffewhere_column_new (column + 1);
2507           break;
2508
2509         case ';':
2510           ffelex_token_->type = FFELEX_typeSEMICOLON;
2511           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
2512           ffelex_token_->where_col = ffewhere_column_new (column + 1);
2513           ffelex_permit_include_ = TRUE;
2514           ffelex_send_token_ ();
2515           ffelex_permit_include_ = FALSE;
2516           break;
2517
2518         case '<':
2519           ffelex_token_->type = FFELEX_typeOPEN_ANGLE;
2520           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
2521           ffelex_token_->where_col = ffewhere_column_new (column + 1);
2522           break;
2523
2524         case '=':
2525           ffelex_token_->type = FFELEX_typeEQUALS;
2526           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
2527           ffelex_token_->where_col = ffewhere_column_new (column + 1);
2528           break;
2529
2530         case '>':
2531           ffelex_token_->type = FFELEX_typeCLOSE_ANGLE;
2532           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
2533           ffelex_token_->where_col = ffewhere_column_new (column + 1);
2534           break;
2535
2536         case '?':
2537           ffelex_token_->type = FFELEX_typeQUESTION;
2538           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
2539           ffelex_token_->where_col = ffewhere_column_new (column + 1);
2540           ffelex_send_token_ ();
2541           break;
2542
2543         case '_':
2544           if (1 || ffe_is_90 ())
2545             {
2546               ffelex_token_->type = FFELEX_typeUNDERSCORE;
2547               ffelex_token_->where_line
2548                 = ffewhere_line_use (ffelex_current_wl_);
2549               ffelex_token_->where_col
2550                 = ffewhere_column_new (column + 1);
2551               ffelex_send_token_ ();
2552               break;
2553             }
2554           /* Fall through. */
2555         case 'A':
2556         case 'B':
2557         case 'C':
2558         case 'D':
2559         case 'E':
2560         case 'F':
2561         case 'G':
2562         case 'H':
2563         case 'I':
2564         case 'J':
2565         case 'K':
2566         case 'L':
2567         case 'M':
2568         case 'N':
2569         case 'O':
2570         case 'P':
2571         case 'Q':
2572         case 'R':
2573         case 'S':
2574         case 'T':
2575         case 'U':
2576         case 'V':
2577         case 'W':
2578         case 'X':
2579         case 'Y':
2580         case 'Z':
2581         case 'a':
2582         case 'b':
2583         case 'c':
2584         case 'd':
2585         case 'e':
2586         case 'f':
2587         case 'g':
2588         case 'h':
2589         case 'i':
2590         case 'j':
2591         case 'k':
2592         case 'l':
2593         case 'm':
2594         case 'n':
2595         case 'o':
2596         case 'p':
2597         case 'q':
2598         case 'r':
2599         case 's':
2600         case 't':
2601         case 'u':
2602         case 'v':
2603         case 'w':
2604         case 'x':
2605         case 'y':
2606         case 'z':
2607           c = ffesrc_char_source (c);
2608
2609           if (ffesrc_char_match_init (c, 'H', 'h')
2610               && ffelex_expecting_hollerith_ != 0)
2611             {
2612               ffelex_raw_mode_ = ffelex_expecting_hollerith_;
2613               ffelex_token_->type = FFELEX_typeHOLLERITH;
2614               ffelex_token_->where_line = ffelex_raw_where_line_;
2615               ffelex_token_->where_col = ffelex_raw_where_col_;
2616               ffelex_raw_where_line_ = ffewhere_line_unknown ();
2617               ffelex_raw_where_col_ = ffewhere_column_unknown ();
2618               c = ffelex_card_image_[++column];
2619               goto parse_raw_character; /* :::::::::::::::::::: */
2620             }
2621
2622           if (ffelex_names_)
2623             {
2624               ffelex_token_->where_line
2625                 = ffewhere_line_use (ffelex_token_->currentnames_line
2626                                      = ffewhere_line_use (ffelex_current_wl_));
2627               ffelex_token_->where_col
2628                 = ffewhere_column_use (ffelex_token_->currentnames_col
2629                                        = ffewhere_column_new (column + 1));
2630               ffelex_token_->type = FFELEX_typeNAMES;
2631             }
2632           else
2633             {
2634               ffelex_token_->where_line
2635                 = ffewhere_line_use (ffelex_current_wl_);
2636               ffelex_token_->where_col = ffewhere_column_new (column + 1);
2637               ffelex_token_->type = FFELEX_typeNAME;
2638             }
2639           ffelex_append_to_token_ (c);
2640           break;
2641
2642         default:
2643           ffelex_bad_1_ (FFEBAD_UNRECOGNIZED_CHARACTER,
2644                          ffelex_linecount_current_, column + 1);
2645           ffelex_finish_statement_ ();
2646           disallow_continuation_line = TRUE;
2647           ignore_disallowed_continuation = TRUE;
2648           goto beginning_of_line_again; /* :::::::::::::::::::: */
2649         }
2650       break;
2651
2652     case FFELEX_typeNAME:
2653       switch (c)
2654         {
2655         case 'A':
2656         case 'B':
2657         case 'C':
2658         case 'D':
2659         case 'E':
2660         case 'F':
2661         case 'G':
2662         case 'H':
2663         case 'I':
2664         case 'J':
2665         case 'K':
2666         case 'L':
2667         case 'M':
2668         case 'N':
2669         case 'O':
2670         case 'P':
2671         case 'Q':
2672         case 'R':
2673         case 'S':
2674         case 'T':
2675         case 'U':
2676         case 'V':
2677         case 'W':
2678         case 'X':
2679         case 'Y':
2680         case 'Z':
2681         case 'a':
2682         case 'b':
2683         case 'c':
2684         case 'd':
2685         case 'e':
2686         case 'f':
2687         case 'g':
2688         case 'h':
2689         case 'i':
2690         case 'j':
2691         case 'k':
2692         case 'l':
2693         case 'm':
2694         case 'n':
2695         case 'o':
2696         case 'p':
2697         case 'q':
2698         case 'r':
2699         case 's':
2700         case 't':
2701         case 'u':
2702         case 'v':
2703         case 'w':
2704         case 'x':
2705         case 'y':
2706         case 'z':
2707           c = ffesrc_char_source (c);
2708           /* Fall through.  */
2709         case '0':
2710         case '1':
2711         case '2':
2712         case '3':
2713         case '4':
2714         case '5':
2715         case '6':
2716         case '7':
2717         case '8':
2718         case '9':
2719         case '_':
2720         case '$':
2721           if ((c == '$')
2722               && !ffe_is_dollar_ok ())
2723             {
2724               ffelex_send_token_ ();
2725               goto parse_next_character;        /* :::::::::::::::::::: */
2726             }
2727           ffelex_append_to_token_ (c);
2728           break;
2729
2730         default:
2731           ffelex_send_token_ ();
2732           goto parse_next_character;    /* :::::::::::::::::::: */
2733         }
2734       break;
2735
2736     case FFELEX_typeNAMES:
2737       switch (c)
2738         {
2739         case 'A':
2740         case 'B':
2741         case 'C':
2742         case 'D':
2743         case 'E':
2744         case 'F':
2745         case 'G':
2746         case 'H':
2747         case 'I':
2748         case 'J':
2749         case 'K':
2750         case 'L':
2751         case 'M':
2752         case 'N':
2753         case 'O':
2754         case 'P':
2755         case 'Q':
2756         case 'R':
2757         case 'S':
2758         case 'T':
2759         case 'U':
2760         case 'V':
2761         case 'W':
2762         case 'X':
2763         case 'Y':
2764         case 'Z':
2765         case 'a':
2766         case 'b':
2767         case 'c':
2768         case 'd':
2769         case 'e':
2770         case 'f':
2771         case 'g':
2772         case 'h':
2773         case 'i':
2774         case 'j':
2775         case 'k':
2776         case 'l':
2777         case 'm':
2778         case 'n':
2779         case 'o':
2780         case 'p':
2781         case 'q':
2782         case 'r':
2783         case 's':
2784         case 't':
2785         case 'u':
2786         case 'v':
2787         case 'w':
2788         case 'x':
2789         case 'y':
2790         case 'z':
2791           c = ffesrc_char_source (c);
2792           /* Fall through.  */
2793         case '0':
2794         case '1':
2795         case '2':
2796         case '3':
2797         case '4':
2798         case '5':
2799         case '6':
2800         case '7':
2801         case '8':
2802         case '9':
2803         case '_':
2804         case '$':
2805           if ((c == '$')
2806               && !ffe_is_dollar_ok ())
2807             {
2808               ffelex_send_token_ ();
2809               goto parse_next_character;        /* :::::::::::::::::::: */
2810             }
2811           if (ffelex_token_->length < FFEWHERE_indexMAX)
2812             {
2813               ffewhere_track (&ffelex_token_->currentnames_line,
2814                               &ffelex_token_->currentnames_col,
2815                               ffelex_token_->wheretrack,
2816                               ffelex_token_->length,
2817                               ffelex_linecount_current_,
2818                               column + 1);
2819             }
2820           ffelex_append_to_token_ (c);
2821           break;
2822
2823         default:
2824           ffelex_send_token_ ();
2825           goto parse_next_character;    /* :::::::::::::::::::: */
2826         }
2827       break;
2828
2829     case FFELEX_typeNUMBER:
2830       switch (c)
2831         {
2832         case '0':
2833         case '1':
2834         case '2':
2835         case '3':
2836         case '4':
2837         case '5':
2838         case '6':
2839         case '7':
2840         case '8':
2841         case '9':
2842           ffelex_append_to_token_ (c);
2843           break;
2844
2845         default:
2846           ffelex_send_token_ ();
2847           goto parse_next_character;    /* :::::::::::::::::::: */
2848         }
2849       break;
2850
2851     case FFELEX_typeASTERISK:
2852       switch (c)
2853         {
2854         case '*':               /* ** */
2855           ffelex_token_->type = FFELEX_typePOWER;
2856           ffelex_send_token_ ();
2857           break;
2858
2859         default:                /* * not followed by another *. */
2860           ffelex_send_token_ ();
2861           goto parse_next_character;    /* :::::::::::::::::::: */
2862         }
2863       break;
2864
2865     case FFELEX_typeCOLON:
2866       switch (c)
2867         {
2868         case ':':               /* :: */
2869           ffelex_token_->type = FFELEX_typeCOLONCOLON;
2870           ffelex_send_token_ ();
2871           break;
2872
2873         default:                /* : not followed by another :. */
2874           ffelex_send_token_ ();
2875           goto parse_next_character;    /* :::::::::::::::::::: */
2876         }
2877       break;
2878
2879     case FFELEX_typeSLASH:
2880       switch (c)
2881         {
2882         case '/':               /* // */
2883           ffelex_token_->type = FFELEX_typeCONCAT;
2884           ffelex_send_token_ ();
2885           break;
2886
2887         case ')':               /* /) */
2888           ffelex_token_->type = FFELEX_typeCLOSE_ARRAY;
2889           ffelex_send_token_ ();
2890           break;
2891
2892         case '=':               /* /= */
2893           ffelex_token_->type = FFELEX_typeREL_NE;
2894           ffelex_send_token_ ();
2895           break;
2896
2897         default:
2898           ffelex_send_token_ ();
2899           goto parse_next_character;    /* :::::::::::::::::::: */
2900         }
2901       break;
2902
2903     case FFELEX_typeOPEN_PAREN:
2904       switch (c)
2905         {
2906         case '/':               /* (/ */
2907           ffelex_token_->type = FFELEX_typeOPEN_ARRAY;
2908           ffelex_send_token_ ();
2909           break;
2910
2911         default:
2912           ffelex_send_token_ ();
2913           goto parse_next_character;    /* :::::::::::::::::::: */
2914         }
2915       break;
2916
2917     case FFELEX_typeOPEN_ANGLE:
2918       switch (c)
2919         {
2920         case '=':               /* <= */
2921           ffelex_token_->type = FFELEX_typeREL_LE;
2922           ffelex_send_token_ ();
2923           break;
2924
2925         default:
2926           ffelex_send_token_ ();
2927           goto parse_next_character;    /* :::::::::::::::::::: */
2928         }
2929       break;
2930
2931     case FFELEX_typeEQUALS:
2932       switch (c)
2933         {
2934         case '=':               /* == */
2935           ffelex_token_->type = FFELEX_typeREL_EQ;
2936           ffelex_send_token_ ();
2937           break;
2938
2939         case '>':               /* => */
2940           ffelex_token_->type = FFELEX_typePOINTS;
2941           ffelex_send_token_ ();
2942           break;
2943
2944         default:
2945           ffelex_send_token_ ();
2946           goto parse_next_character;    /* :::::::::::::::::::: */
2947         }
2948       break;
2949
2950     case FFELEX_typeCLOSE_ANGLE:
2951       switch (c)
2952         {
2953         case '=':               /* >= */
2954           ffelex_token_->type = FFELEX_typeREL_GE;
2955           ffelex_send_token_ ();
2956           break;
2957
2958         default:
2959           ffelex_send_token_ ();
2960           goto parse_next_character;    /* :::::::::::::::::::: */
2961         }
2962       break;
2963
2964     default:
2965       assert ("Serious error!!" == NULL);
2966       abort ();
2967       break;
2968     }
2969
2970   c = ffelex_card_image_[++column];
2971
2972  parse_next_character:          /* :::::::::::::::::::: */
2973
2974   if (ffelex_raw_mode_ != 0)
2975     goto parse_raw_character;   /* :::::::::::::::::::: */
2976
2977   while (c == ' ')
2978     c = ffelex_card_image_[++column];
2979
2980   if ((c == '\0')
2981       || (c == '!')
2982       || ((c == '/')
2983           && (ffelex_card_image_[column + 1] == '*')))
2984     {
2985       if ((ffelex_number_of_tokens_ == ffelex_label_tokens_)
2986           && (ffelex_token_->type == FFELEX_typeNAMES)
2987           && (ffelex_token_->length == 3)
2988           && (ffesrc_strncmp_2c (ffe_case_match (),
2989                                  ffelex_token_->text,
2990                                  "END", "end", "End",
2991                                  3)
2992            == 0))
2993         {
2994           ffelex_finish_statement_ ();
2995           disallow_continuation_line = TRUE;
2996           ignore_disallowed_continuation = FALSE;
2997           goto beginning_of_line_again; /* :::::::::::::::::::: */
2998         }
2999       goto beginning_of_line;   /* :::::::::::::::::::: */
3000     }
3001   goto parse_nonraw_character;  /* :::::::::::::::::::: */
3002 }
3003
3004 /* ffelex_file_free -- Lex a given file in free source form
3005
3006    ffewhere wf;
3007    FILE *f;
3008    ffelex_file_free(wf,f);
3009
3010    Lexes the file according to Fortran 90 ANSI + VXT specifications.  */
3011
3012 ffelexHandler
3013 ffelex_file_free (ffewhereFile wf, FILE *f)
3014 {
3015   register int c;               /* Character currently under consideration. */
3016   register ffewhereColumnNumber column; /* Not really; 0 means column 1... */
3017   bool continuation_line;
3018   ffewhereColumnNumber continuation_column;
3019   int latest_char_in_file;      /* For getting back into comment-skipping
3020                                    code. */
3021
3022   /* Lex is called for a particular file, not for a particular program unit.
3023      Yet the two events do share common characteristics.  The first line in a
3024      file or in a program unit cannot be a continuation line.  No token can
3025      be in mid-formation.  No current label for the statement exists, since
3026      there is no current statement. */
3027
3028   assert (ffelex_handler_ != NULL);
3029
3030 #if FFECOM_targetCURRENT == FFECOM_targetGCC
3031   lineno = 0;
3032   input_filename = ffewhere_file_name (wf);
3033 #endif
3034   ffelex_current_wf_ = wf;
3035   continuation_line = FALSE;
3036   ffelex_token_->type = FFELEX_typeNONE;
3037   ffelex_number_of_tokens_ = 0;
3038   ffelex_current_wl_ = ffewhere_line_unknown ();
3039   ffelex_current_wc_ = ffewhere_column_unknown ();
3040   latest_char_in_file = '\n';
3041
3042   /* Come here to get a new line. */
3043
3044  beginning_of_line:             /* :::::::::::::::::::: */
3045
3046   c = latest_char_in_file;
3047   if ((c == EOF) || ((c = ffelex_getc_ (f)) == EOF))
3048     {
3049
3050      end_of_file:               /* :::::::::::::::::::: */
3051
3052       /* Line ending in EOF instead of \n still counts as a whole line. */
3053
3054       ffelex_finish_statement_ ();
3055       ffewhere_line_kill (ffelex_current_wl_);
3056       ffewhere_column_kill (ffelex_current_wc_);
3057       return (ffelexHandler) ffelex_handler_;
3058     }
3059
3060   ffelex_next_line_ ();
3061
3062   ffelex_bad_line_ = FALSE;
3063
3064   /* Skip over initial-comment and empty lines as quickly as possible! */
3065
3066   while ((c == '\n')
3067          || (c == '!')
3068          || (c == '#'))
3069     {
3070       if (c == '#')
3071         {
3072 #if FFECOM_targetCURRENT == FFECOM_targetGCC
3073           c = ffelex_hash_ (f);
3074 #else
3075           /* Don't skip over # line after all.  */
3076           break;
3077 #endif
3078         }
3079
3080      comment_line:              /* :::::::::::::::::::: */
3081
3082       while ((c != '\n') && (c != EOF))
3083         c = getc (f);
3084
3085       if (c == EOF)
3086         {
3087           ffelex_next_line_ ();
3088           goto end_of_file;     /* :::::::::::::::::::: */
3089         }
3090
3091       c = getc (f);
3092
3093       ffelex_next_line_ ();
3094
3095       if (c == EOF)
3096         goto end_of_file;       /* :::::::::::::::::::: */
3097     }
3098
3099   ffelex_saw_tab_ = FALSE;
3100
3101   column = ffelex_image_char_ (c, 0);
3102
3103   /* Read the entire line in as is (with whitespace processing).  */
3104
3105   while (((c = getc (f)) != '\n') && (c != EOF))
3106     column = ffelex_image_char_ (c, column);
3107
3108   if (ffelex_bad_line_)
3109     {
3110       ffelex_card_image_[column] = '\0';
3111       ffelex_card_length_ = column;
3112       goto comment_line;                /* :::::::::::::::::::: */
3113     }
3114
3115   /* If no tab, cut off line after column 132.  */
3116
3117   if (!ffelex_saw_tab_ && (column > FFELEX_FREE_MAX_COLUMNS_))
3118     column = FFELEX_FREE_MAX_COLUMNS_;
3119
3120   ffelex_card_image_[column] = '\0';
3121   ffelex_card_length_ = column;
3122
3123   /* Save next char in file so we can use register-based c while analyzing
3124      line we just read. */
3125
3126   latest_char_in_file = c;      /* Should be either '\n' or EOF. */
3127
3128   column = 0;
3129   continuation_column = 0;
3130
3131   /* Skip over initial spaces to see if the first nonblank character
3132      is exclamation point, newline, or EOF (line is therefore a comment) or
3133      ampersand (line is therefore a continuation line). */
3134
3135   while ((c = ffelex_card_image_[column]) == ' ')
3136     ++column;
3137
3138   switch (c)
3139     {
3140     case '!':
3141     case '\0':
3142       goto beginning_of_line;   /* :::::::::::::::::::: */
3143
3144     case '&':
3145       continuation_column = column + 1;
3146       break;
3147
3148     default:
3149       break;
3150     }
3151
3152   /* The line definitely has content of some kind, install new end-statement
3153      point for error messages. */
3154
3155   ffewhere_line_kill (ffelex_current_wl_);
3156   ffewhere_column_kill (ffelex_current_wc_);
3157   ffelex_current_wl_ = ffewhere_line_new (ffelex_linecount_current_);
3158   ffelex_current_wc_ = ffewhere_column_new (ffelex_card_length_ + 1);
3159
3160   /* Figure out which column to start parsing at. */
3161
3162   if (continuation_line)
3163     {
3164       if (continuation_column == 0)
3165         {
3166           if (ffelex_raw_mode_ != 0)
3167             {
3168               ffelex_bad_1_ (FFEBAD_BAD_CHAR_CONTINUE,
3169                              ffelex_linecount_current_, column + 1);
3170             }
3171           else if (ffelex_token_->type != FFELEX_typeNONE)
3172             {
3173               ffelex_bad_1_ (FFEBAD_BAD_LEXTOK_CONTINUE,
3174                              ffelex_linecount_current_, column + 1);
3175             }
3176         }
3177       else if (ffelex_is_free_char_ctx_contin_ (continuation_column))
3178         {                       /* Line contains only a single "&" as only
3179                                    nonblank character. */
3180           ffelex_bad_1_ (FFEBAD_BAD_FREE_CONTINUE,
3181                          ffelex_linecount_current_, continuation_column);
3182           goto beginning_of_line;       /* :::::::::::::::::::: */
3183         }
3184       column = continuation_column;
3185     }
3186   else
3187     column = 0;
3188
3189   c = ffelex_card_image_[column];
3190   continuation_line = FALSE;
3191
3192   /* Here is the main engine for parsing.  c holds the character at column.
3193      It is already known that c is not a blank, end of line, or shriek,
3194      unless ffelex_raw_mode_ is not 0 (indicating we are in a
3195      character/hollerith constant).  A partially filled token may already
3196      exist in ffelex_token_. */
3197
3198   if (ffelex_raw_mode_ != 0)
3199     {
3200
3201     parse_raw_character:        /* :::::::::::::::::::: */
3202
3203       switch (c)
3204         {
3205         case '&':
3206           if (ffelex_is_free_char_ctx_contin_ (column + 1))
3207             {
3208               continuation_line = TRUE;
3209               goto beginning_of_line;   /* :::::::::::::::::::: */
3210             }
3211           break;
3212
3213         case '\0':
3214           ffelex_finish_statement_ ();
3215           goto beginning_of_line;       /* :::::::::::::::::::: */
3216
3217         default:
3218           break;
3219         }
3220
3221       switch (ffelex_raw_mode_)
3222         {
3223         case -3:
3224           c = ffelex_backslash_ (c, column);
3225           if (c == EOF)
3226             break;
3227
3228           if (!ffelex_backslash_reconsider_)
3229             ffelex_append_to_token_ (c);
3230           ffelex_raw_mode_ = -1;
3231           break;
3232
3233         case -2:
3234           if (c == ffelex_raw_char_)
3235             {
3236               ffelex_raw_mode_ = -1;
3237               ffelex_append_to_token_ (c);
3238             }
3239           else
3240             {
3241               ffelex_raw_mode_ = 0;
3242               ffelex_backslash_reconsider_ = TRUE;
3243             }
3244           break;
3245
3246         case -1:
3247           if (c == ffelex_raw_char_)
3248             ffelex_raw_mode_ = -2;
3249           else
3250             {
3251               c = ffelex_backslash_ (c, column);
3252               if (c == EOF)
3253                 {
3254                   ffelex_raw_mode_ = -3;
3255                   break;
3256                 }
3257
3258               ffelex_append_to_token_ (c);
3259             }
3260           break;
3261
3262         default:
3263           c = ffelex_backslash_ (c, column);
3264           if (c == EOF)
3265             break;
3266
3267           if (!ffelex_backslash_reconsider_)
3268             {
3269               ffelex_append_to_token_ (c);
3270               --ffelex_raw_mode_;
3271             }
3272           break;
3273         }
3274
3275       if (ffelex_backslash_reconsider_)
3276         ffelex_backslash_reconsider_ = FALSE;
3277       else
3278         c = ffelex_card_image_[++column];
3279
3280       if (ffelex_raw_mode_ == 0)
3281         {
3282           ffelex_send_token_ ();
3283           assert (ffelex_raw_mode_ == 0);
3284           while (c == ' ')
3285             c = ffelex_card_image_[++column];
3286           if ((c == '\0') || (c == '!'))
3287             {
3288               ffelex_finish_statement_ ();
3289               goto beginning_of_line;   /* :::::::::::::::::::: */
3290             }
3291           if ((c == '&') && ffelex_is_free_nonc_ctx_contin_ (column + 1))
3292             {
3293               continuation_line = TRUE;
3294               goto beginning_of_line;   /* :::::::::::::::::::: */
3295             }
3296           goto parse_nonraw_character_noncontin;        /* :::::::::::::::::::: */
3297         }
3298       goto parse_raw_character; /* :::::::::::::::::::: */
3299     }
3300
3301  parse_nonraw_character:        /* :::::::::::::::::::: */
3302
3303   if ((c == '&') && ffelex_is_free_nonc_ctx_contin_ (column + 1))
3304     {
3305       continuation_line = TRUE;
3306       goto beginning_of_line;   /* :::::::::::::::::::: */
3307     }
3308
3309  parse_nonraw_character_noncontin:      /* :::::::::::::::::::: */
3310
3311   switch (ffelex_token_->type)
3312     {
3313     case FFELEX_typeNONE:
3314       if (c == ' ')
3315         {                       /* Otherwise
3316                                    finish-statement/continue-statement
3317                                    already checked. */
3318           while (c == ' ')
3319             c = ffelex_card_image_[++column];
3320           if ((c == '\0') || (c == '!'))
3321             {
3322               ffelex_finish_statement_ ();
3323               goto beginning_of_line;   /* :::::::::::::::::::: */
3324             }
3325           if ((c == '&') && ffelex_is_free_nonc_ctx_contin_ (column + 1))
3326             {
3327               continuation_line = TRUE;
3328               goto beginning_of_line;   /* :::::::::::::::::::: */
3329             }
3330         }
3331
3332       switch (c)
3333         {
3334         case '\"':
3335           ffelex_token_->type = FFELEX_typeQUOTE;
3336           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
3337           ffelex_token_->where_col = ffewhere_column_new (column + 1);
3338           ffelex_send_token_ ();
3339           break;
3340
3341         case '$':
3342           ffelex_token_->type = FFELEX_typeDOLLAR;
3343           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
3344           ffelex_token_->where_col = ffewhere_column_new (column + 1);
3345           ffelex_send_token_ ();
3346           break;
3347
3348         case '%':
3349           ffelex_token_->type = FFELEX_typePERCENT;
3350           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
3351           ffelex_token_->where_col = ffewhere_column_new (column + 1);
3352           ffelex_send_token_ ();
3353           break;
3354
3355         case '&':
3356           ffelex_token_->type = FFELEX_typeAMPERSAND;
3357           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
3358           ffelex_token_->where_col = ffewhere_column_new (column + 1);
3359           ffelex_send_token_ ();
3360           break;
3361
3362         case '\'':
3363           ffelex_token_->type = FFELEX_typeAPOSTROPHE;
3364           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
3365           ffelex_token_->where_col = ffewhere_column_new (column + 1);
3366           ffelex_send_token_ ();
3367           break;
3368
3369         case '(':
3370           ffelex_token_->type = FFELEX_typeOPEN_PAREN;
3371           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
3372           ffelex_token_->where_col = ffewhere_column_new (column + 1);
3373           break;
3374
3375         case ')':
3376           ffelex_token_->type = FFELEX_typeCLOSE_PAREN;
3377           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
3378           ffelex_token_->where_col = ffewhere_column_new (column + 1);
3379           ffelex_send_token_ ();
3380           break;
3381
3382         case '*':
3383           ffelex_token_->type = FFELEX_typeASTERISK;
3384           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
3385           ffelex_token_->where_col = ffewhere_column_new (column + 1);
3386           break;
3387
3388         case '+':
3389           ffelex_token_->type = FFELEX_typePLUS;
3390           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
3391           ffelex_token_->where_col = ffewhere_column_new (column + 1);
3392           ffelex_send_token_ ();
3393           break;
3394
3395         case ',':
3396           ffelex_token_->type = FFELEX_typeCOMMA;
3397           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
3398           ffelex_token_->where_col = ffewhere_column_new (column + 1);
3399           ffelex_send_token_ ();
3400           break;
3401
3402         case '-':
3403           ffelex_token_->type = FFELEX_typeMINUS;
3404           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
3405           ffelex_token_->where_col = ffewhere_column_new (column + 1);
3406           ffelex_send_token_ ();
3407           break;
3408
3409         case '.':
3410           ffelex_token_->type = FFELEX_typePERIOD;
3411           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
3412           ffelex_token_->where_col = ffewhere_column_new (column + 1);
3413           ffelex_send_token_ ();
3414           break;
3415
3416         case '/':
3417           ffelex_token_->type = FFELEX_typeSLASH;
3418           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
3419           ffelex_token_->where_col = ffewhere_column_new (column + 1);
3420           break;
3421
3422         case '0':
3423         case '1':
3424         case '2':
3425         case '3':
3426         case '4':
3427         case '5':
3428         case '6':
3429         case '7':
3430         case '8':
3431         case '9':
3432           ffelex_token_->type
3433             = ffelex_hexnum_ ? FFELEX_typeNAME : FFELEX_typeNUMBER;
3434           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
3435           ffelex_token_->where_col = ffewhere_column_new (column + 1);
3436           ffelex_append_to_token_ (c);
3437           break;
3438
3439         case ':':
3440           ffelex_token_->type = FFELEX_typeCOLON;
3441           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
3442           ffelex_token_->where_col = ffewhere_column_new (column + 1);
3443           break;
3444
3445         case ';':
3446           ffelex_token_->type = FFELEX_typeSEMICOLON;
3447           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
3448           ffelex_token_->where_col = ffewhere_column_new (column + 1);
3449           ffelex_permit_include_ = TRUE;
3450           ffelex_send_token_ ();
3451           ffelex_permit_include_ = FALSE;
3452           break;
3453
3454         case '<':
3455           ffelex_token_->type = FFELEX_typeOPEN_ANGLE;
3456           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
3457           ffelex_token_->where_col = ffewhere_column_new (column + 1);
3458           break;
3459
3460         case '=':
3461           ffelex_token_->type = FFELEX_typeEQUALS;
3462           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
3463           ffelex_token_->where_col = ffewhere_column_new (column + 1);
3464           break;
3465
3466         case '>':
3467           ffelex_token_->type = FFELEX_typeCLOSE_ANGLE;
3468           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
3469           ffelex_token_->where_col = ffewhere_column_new (column + 1);
3470           break;
3471
3472         case '?':
3473           ffelex_token_->type = FFELEX_typeQUESTION;
3474           ffelex_token_->where_line = ffewhere_line_use (ffelex_current_wl_);
3475           ffelex_token_->where_col = ffewhere_column_new (column + 1);
3476           ffelex_send_token_ ();
3477           break;
3478
3479         case '_':
3480           if (1 || ffe_is_90 ())
3481             {
3482               ffelex_token_->type = FFELEX_typeUNDERSCORE;
3483               ffelex_token_->where_line
3484                 = ffewhere_line_use (ffelex_current_wl_);
3485               ffelex_token_->where_col
3486                 = ffewhere_column_new (column + 1);
3487               ffelex_send_token_ ();
3488               break;
3489             }
3490           /* Fall through. */
3491         case 'A':
3492         case 'B':
3493         case 'C':
3494         case 'D':
3495         case 'E':
3496         case 'F':
3497         case 'G':
3498         case 'H':
3499         case 'I':
3500         case 'J':
3501         case 'K':
3502         case 'L':
3503         case 'M':
3504         case 'N':
3505         case 'O':
3506         case 'P':
3507         case 'Q':
3508         case 'R':
3509         case 'S':
3510         case 'T':
3511         case 'U':
3512         case 'V':
3513         case 'W':
3514         case 'X':
3515         case 'Y':
3516         case 'Z':
3517         case 'a':
3518         case 'b':
3519         case 'c':
3520         case 'd':
3521         case 'e':
3522         case 'f':
3523         case 'g':
3524         case 'h':
3525         case 'i':
3526         case 'j':
3527         case 'k':
3528         case 'l':
3529         case 'm':
3530         case 'n':
3531         case 'o':
3532         case 'p':
3533         case 'q':
3534         case 'r':
3535         case 's':
3536         case 't':
3537         case 'u':
3538         case 'v':
3539         case 'w':
3540         case 'x':
3541         case 'y':
3542         case 'z':
3543           c = ffesrc_char_source (c);
3544
3545           if (ffesrc_char_match_init (c, 'H', 'h')
3546               && ffelex_expecting_hollerith_ != 0)
3547             {
3548               ffelex_raw_mode_ = ffelex_expecting_hollerith_;
3549               ffelex_token_->type = FFELEX_typeHOLLERITH;
3550               ffelex_token_->where_line = ffelex_raw_where_line_;
3551               ffelex_token_->where_col = ffelex_raw_where_col_;
3552               ffelex_raw_where_line_ = ffewhere_line_unknown ();
3553               ffelex_raw_where_col_ = ffewhere_column_unknown ();
3554               c = ffelex_card_image_[++column];
3555               goto parse_raw_character; /* :::::::::::::::::::: */
3556             }
3557
3558           if (ffelex_names_pure_)
3559             {
3560               ffelex_token_->where_line
3561                 = ffewhere_line_use (ffelex_token_->currentnames_line
3562                                      = ffewhere_line_use (ffelex_current_wl_));
3563               ffelex_token_->where_col
3564                 = ffewhere_column_use (ffelex_token_->currentnames_col
3565                                        = ffewhere_column_new (column + 1));
3566               ffelex_token_->type = FFELEX_typeNAMES;
3567             }
3568           else
3569             {
3570               ffelex_token_->where_line
3571                 = ffewhere_line_use (ffelex_current_wl_);
3572               ffelex_token_->where_col = ffewhere_column_new (column + 1);
3573               ffelex_token_->type = FFELEX_typeNAME;
3574             }
3575           ffelex_append_to_token_ (c);
3576           break;
3577
3578         default:
3579           ffelex_bad_1_ (FFEBAD_UNRECOGNIZED_CHARACTER,
3580                          ffelex_linecount_current_, column + 1);
3581           ffelex_finish_statement_ ();
3582           goto beginning_of_line;       /* :::::::::::::::::::: */
3583         }
3584       break;
3585
3586     case FFELEX_typeNAME:
3587       switch (c)
3588         {
3589         case 'A':
3590         case 'B':
3591         case 'C':
3592         case 'D':
3593         case 'E':
3594         case 'F':
3595         case 'G':
3596         case 'H':
3597         case 'I':
3598         case 'J':
3599         case 'K':
3600         case 'L':
3601         case 'M':
3602         case 'N':
3603         case 'O':
3604         case 'P':
3605         case 'Q':
3606         case 'R':
3607         case 'S':
3608         case 'T':
3609         case 'U':
3610         case 'V':
3611         case 'W':
3612         case 'X':
3613         case 'Y':
3614         case 'Z':
3615         case 'a':
3616         case 'b':
3617         case 'c':
3618         case 'd':
3619         case 'e':
3620         case 'f':
3621         case 'g':
3622         case 'h':
3623         case 'i':
3624         case 'j':
3625         case 'k':
3626         case 'l':
3627         case 'm':
3628         case 'n':
3629         case 'o':
3630         case 'p':
3631         case 'q':
3632         case 'r':
3633         case 's':
3634         case 't':
3635         case 'u':
3636         case 'v':
3637         case 'w':
3638         case 'x':
3639         case 'y':
3640         case 'z':
3641           c = ffesrc_char_source (c);
3642           /* Fall through.  */
3643         case '0':
3644         case '1':
3645         case '2':
3646         case '3':
3647         case '4':
3648         case '5':
3649         case '6':
3650         case '7':
3651         case '8':
3652         case '9':
3653         case '_':
3654         case '$':
3655           if ((c == '$')
3656               && !ffe_is_dollar_ok ())
3657             {
3658               ffelex_send_token_ ();
3659               goto parse_next_character;        /* :::::::::::::::::::: */
3660             }
3661           ffelex_append_to_token_ (c);
3662           break;
3663
3664         default:
3665           ffelex_send_token_ ();
3666           goto parse_next_character;    /* :::::::::::::::::::: */
3667         }
3668       break;
3669
3670     case FFELEX_typeNAMES:
3671       switch (c)
3672         {
3673         case 'A':
3674         case 'B':
3675         case 'C':
3676         case 'D':
3677         case 'E':
3678         case 'F':
3679         case 'G':
3680         case 'H':
3681         case 'I':
3682         case 'J':
3683         case 'K':
3684         case 'L':
3685         case 'M':
3686         case 'N':
3687         case 'O':
3688         case 'P':
3689         case 'Q':
3690         case 'R':
3691         case 'S':
3692         case 'T':
3693         case 'U':
3694         case 'V':
3695         case 'W':
3696         case 'X':
3697         case 'Y':
3698         case 'Z':
3699         case 'a':
3700         case 'b':
3701         case 'c':
3702         case 'd':
3703         case 'e':
3704         case 'f':
3705         case 'g':
3706         case 'h':
3707         case 'i':
3708         case 'j':
3709         case 'k':
3710         case 'l':
3711         case 'm':
3712         case 'n':
3713         case 'o':
3714         case 'p':
3715         case 'q':
3716         case 'r':
3717         case 's':
3718         case 't':
3719         case 'u':
3720         case 'v':
3721         case 'w':
3722         case 'x':
3723         case 'y':
3724         case 'z':
3725           c = ffesrc_char_source (c);
3726           /* Fall through.  */
3727         case '0':
3728         case '1':
3729         case '2':
3730         case '3':
3731         case '4':
3732         case '5':
3733         case '6':
3734         case '7':
3735         case '8':
3736         case '9':
3737         case '_':
3738         case '$':
3739           if ((c == '$')
3740               && !ffe_is_dollar_ok ())
3741             {
3742               ffelex_send_token_ ();
3743               goto parse_next_character;        /* :::::::::::::::::::: */
3744             }
3745           if (ffelex_token_->length < FFEWHERE_indexMAX)
3746             {
3747               ffewhere_track (&ffelex_token_->currentnames_line,
3748                               &ffelex_token_->currentnames_col,
3749                               ffelex_token_->wheretrack,
3750                               ffelex_token_->length,
3751                               ffelex_linecount_current_,
3752                               column + 1);
3753             }
3754           ffelex_append_to_token_ (c);
3755           break;
3756
3757         default:
3758           ffelex_send_token_ ();
3759           goto parse_next_character;    /* :::::::::::::::::::: */
3760         }
3761       break;
3762
3763     case FFELEX_typeNUMBER:
3764       switch (c)
3765         {
3766         case '0':
3767         case '1':
3768         case '2':
3769         case '3':
3770         case '4':
3771         case '5':
3772         case '6':
3773         case '7':
3774         case '8':
3775         case '9':
3776           ffelex_append_to_token_ (c);
3777           break;
3778
3779         default:
3780           ffelex_send_token_ ();
3781           goto parse_next_character;    /* :::::::::::::::::::: */
3782         }
3783       break;
3784
3785     case FFELEX_typeASTERISK:
3786       switch (c)
3787         {
3788         case '*':               /* ** */
3789           ffelex_token_->type = FFELEX_typePOWER;
3790           ffelex_send_token_ ();
3791           break;
3792
3793         default:                /* * not followed by another *. */
3794           ffelex_send_token_ ();
3795           goto parse_next_character;    /* :::::::::::::::::::: */
3796         }
3797       break;
3798
3799     case FFELEX_typeCOLON:
3800       switch (c)
3801         {
3802         case ':':               /* :: */
3803           ffelex_token_->type = FFELEX_typeCOLONCOLON;
3804           ffelex_send_token_ ();
3805           break;
3806
3807         default:                /* : not followed by another :. */
3808           ffelex_send_token_ ();
3809           goto parse_next_character;    /* :::::::::::::::::::: */
3810         }
3811       break;
3812
3813     case FFELEX_typeSLASH:
3814       switch (c)
3815         {
3816         case '/':               /* // */
3817           ffelex_token_->type = FFELEX_typeCONCAT;
3818           ffelex_send_token_ ();
3819           break;
3820
3821         case ')':               /* /) */
3822           ffelex_token_->type = FFELEX_typeCLOSE_ARRAY;
3823           ffelex_send_token_ ();
3824           break;
3825
3826         case '=':               /* /= */
3827           ffelex_token_->type = FFELEX_typeREL_NE;
3828           ffelex_send_token_ ();
3829           break;
3830
3831         default:
3832           ffelex_send_token_ ();
3833           goto parse_next_character;    /* :::::::::::::::::::: */
3834         }
3835       break;
3836
3837     case FFELEX_typeOPEN_PAREN:
3838       switch (c)
3839         {
3840         case '/':               /* (/ */
3841           ffelex_token_->type = FFELEX_typeOPEN_ARRAY;
3842           ffelex_send_token_ ();
3843           break;
3844
3845         default:
3846           ffelex_send_token_ ();
3847           goto parse_next_character;    /* :::::::::::::::::::: */
3848         }
3849       break;
3850
3851     case FFELEX_typeOPEN_ANGLE:
3852       switch (c)
3853         {
3854         case '=':               /* <= */
3855           ffelex_token_->type = FFELEX_typeREL_LE;
3856           ffelex_send_token_ ();
3857           break;
3858
3859         default:
3860           ffelex_send_token_ ();
3861           goto parse_next_character;    /* :::::::::::::::::::: */
3862         }
3863       break;
3864
3865     case FFELEX_typeEQUALS:
3866       switch (c)
3867         {
3868         case '=':               /* == */
3869           ffelex_token_->type = FFELEX_typeREL_EQ;
3870           ffelex_send_token_ ();
3871           break;
3872
3873         case '>':               /* => */
3874           ffelex_token_->type = FFELEX_typePOINTS;
3875           ffelex_send_token_ ();
3876           break;
3877
3878         default:
3879           ffelex_send_token_ ();
3880           goto parse_next_character;    /* :::::::::::::::::::: */
3881         }
3882       break;
3883
3884     case FFELEX_typeCLOSE_ANGLE:
3885       switch (c)
3886         {
3887         case '=':               /* >= */
3888           ffelex_token_->type = FFELEX_typeREL_GE;
3889           ffelex_send_token_ ();
3890           break;
3891
3892         default:
3893           ffelex_send_token_ ();
3894           goto parse_next_character;    /* :::::::::::::::::::: */
3895         }
3896       break;
3897
3898     default:
3899       assert ("Serious error!" == NULL);
3900       abort ();
3901       break;
3902     }
3903
3904   c = ffelex_card_image_[++column];
3905
3906  parse_next_character:          /* :::::::::::::::::::: */
3907
3908   if (ffelex_raw_mode_ != 0)
3909     goto parse_raw_character;   /* :::::::::::::::::::: */
3910
3911   if ((c == '\0') || (c == '!'))
3912     {
3913       ffelex_finish_statement_ ();
3914       goto beginning_of_line;   /* :::::::::::::::::::: */
3915     }
3916   goto parse_nonraw_character;  /* :::::::::::::::::::: */
3917 }
3918
3919 /* See the code in com.c that calls this to understand why.  */
3920
3921 #if FFECOM_targetCURRENT == FFECOM_targetGCC
3922 void
3923 ffelex_hash_kludge (FILE *finput)
3924 {
3925   /* If you change this constant string, you have to change whatever
3926      code might thus be affected by it in terms of having to use
3927      ffelex_getc_() instead of getc() in the lexers and _hash_.  */
3928   static char match[] = "# 1 \"";
3929   static int kludge[ARRAY_SIZE (match) + 1];
3930   int c;
3931   char *p;
3932   int *q;
3933
3934   /* Read chars as long as they match the target string.
3935      Copy them into an array that will serve as a record
3936      of what we read (essentially a multi-char ungetc(),
3937      for code that uses ffelex_getc_ instead of getc() elsewhere
3938      in the lexer.  */
3939   for (p = &match[0], q = &kludge[0], c = getc (finput);
3940        (c == *p) && (*p != '\0') && (c != EOF);
3941        ++p, ++q, c = getc (finput))
3942     *q = c;
3943
3944   *q = c;                       /* Might be EOF, which requires int. */
3945   *++q = 0;
3946
3947   ffelex_kludge_chars_ = &kludge[0];
3948
3949   if (*p == 0)
3950     {
3951       ffelex_kludge_flag_ = TRUE;
3952       ++ffelex_kludge_chars_;
3953       ffelex_hash_ (finput);    /* Handle it NOW rather than later. */
3954       ffelex_kludge_flag_ = FALSE;
3955     }
3956 }
3957
3958 #endif
3959 void
3960 ffelex_init_1 ()
3961 {
3962   unsigned int i;
3963
3964   ffelex_final_nontab_column_ = ffe_fixed_line_length ();
3965   ffelex_card_size_ = FFELEX_columnINITIAL_SIZE_;
3966   ffelex_card_image_ = malloc_new_ksr (malloc_pool_image (),
3967                                        "FFELEX card image",
3968                                        FFELEX_columnINITIAL_SIZE_ + 9);
3969   ffelex_card_image_[0] = '\0';
3970
3971   for (i = 0; i < 256; ++i)
3972     ffelex_first_char_[i] = FFELEX_typeERROR;
3973
3974   ffelex_first_char_['\t'] = FFELEX_typeRAW;
3975   ffelex_first_char_['\n'] = FFELEX_typeCOMMENT;
3976   ffelex_first_char_['\v'] = FFELEX_typeCOMMENT;
3977   ffelex_first_char_['\f'] = FFELEX_typeCOMMENT;
3978   ffelex_first_char_['\r'] = FFELEX_typeRAW;
3979   ffelex_first_char_[' '] = FFELEX_typeRAW;
3980   ffelex_first_char_['!'] = FFELEX_typeCOMMENT;
3981   ffelex_first_char_['*'] = FFELEX_typeCOMMENT;
3982   ffelex_first_char_['/'] = FFELEX_typeSLASH;
3983   ffelex_first_char_['&'] = FFELEX_typeRAW;
3984   ffelex_first_char_['#'] = FFELEX_typeHASH;
3985
3986   for (i = '0'; i <= '9'; ++i)
3987     ffelex_first_char_[i] = FFELEX_typeRAW;
3988
3989   if ((ffe_case_match () == FFE_caseNONE)
3990       || ((ffe_case_match () == FFE_caseUPPER)
3991           && (ffe_case_source () != FFE_caseLOWER))     /* Idiot!  :-) */
3992       || ((ffe_case_match () == FFE_caseLOWER)
3993           && (ffe_case_source () == FFE_caseLOWER)))
3994     {
3995       ffelex_first_char_['C'] = FFELEX_typeCOMMENT;
3996       ffelex_first_char_['D'] = FFELEX_typeCOMMENT;
3997     }
3998   if ((ffe_case_match () == FFE_caseNONE)
3999       || ((ffe_case_match () == FFE_caseLOWER)
4000           && (ffe_case_source () != FFE_caseUPPER))     /* Idiot!  :-) */
4001       || ((ffe_case_match () == FFE_caseUPPER)
4002           && (ffe_case_source () == FFE_caseUPPER)))
4003     {
4004       ffelex_first_char_['c'] = FFELEX_typeCOMMENT;
4005       ffelex_first_char_['d'] = FFELEX_typeCOMMENT;
4006     }
4007
4008   ffelex_linecount_current_ = 0;
4009   ffelex_linecount_next_ = 1;
4010   ffelex_raw_mode_ = 0;
4011   ffelex_set_include_ = FALSE;
4012   ffelex_permit_include_ = FALSE;
4013   ffelex_names_ = TRUE;         /* First token in program is a names. */
4014   ffelex_names_pure_ = FALSE;   /* Free-form lexer does NAMES only for
4015                                    FORMAT. */
4016   ffelex_hexnum_ = FALSE;
4017   ffelex_expecting_hollerith_ = 0;
4018   ffelex_raw_where_line_ = ffewhere_line_unknown ();
4019   ffelex_raw_where_col_ = ffewhere_column_unknown ();
4020
4021   ffelex_token_ = ffelex_token_new_ ();
4022   ffelex_token_->type = FFELEX_typeNONE;
4023   ffelex_token_->uses = 1;
4024   ffelex_token_->where_line = ffewhere_line_unknown ();
4025   ffelex_token_->where_col = ffewhere_column_unknown ();
4026   ffelex_token_->text = NULL;
4027
4028   ffelex_handler_ = NULL;
4029 }
4030
4031 /* ffelex_is_names_expected -- Is the current parser expecting NAMES vs. NAME?
4032
4033    if (ffelex_is_names_expected())
4034        // Deliver NAMES token
4035      else
4036        // Deliver NAME token
4037
4038    Must be called while lexer is active, obviously.  */
4039
4040 bool
4041 ffelex_is_names_expected ()
4042 {
4043   return ffelex_names_;
4044 }
4045
4046 /* Current card image, which has the master linecount number
4047    ffelex_linecount_current_.  */
4048
4049 char *
4050 ffelex_line ()
4051 {
4052   return ffelex_card_image_;
4053 }
4054
4055 /* ffelex_line_length -- Return length of current lexer line
4056
4057    printf("Length is %lu\n",ffelex_line_length());
4058
4059    Must be called while lexer is active, obviously.  */
4060
4061 ffewhereColumnNumber
4062 ffelex_line_length ()
4063 {
4064   return ffelex_card_length_;
4065 }
4066
4067 /* Master line count of current card image, or 0 if no card image
4068    is current.  */
4069
4070 ffewhereLineNumber
4071 ffelex_line_number ()
4072 {
4073   return ffelex_linecount_current_;
4074 }
4075
4076 /* ffelex_set_expecting_hollerith -- Set hollerith expectation status
4077
4078    ffelex_set_expecting_hollerith(0);
4079
4080    Lex initially assumes no hollerith constant is about to show up.  If
4081    syntactic analysis expects one, it should call this function with the
4082    number of characters expected in the constant immediately after recognizing
4083    the decimal number preceding the "H" and the constant itself.  Then, if
4084    the next character is indeed H, the lexer will interpret it as beginning
4085    a hollerith constant and ship the token formed by reading the specified
4086    number of characters (interpreting blanks and otherwise-comments too)
4087    from the input file.  It is up to syntactic analysis to call this routine
4088    again with 0 to turn hollerith detection off immediately upon receiving
4089    the token that might or might not be HOLLERITH.
4090
4091    Also call this after seeing an APOSTROPHE or QUOTE token that begins a
4092    character constant.  Pass the expected termination character (apostrophe
4093    or quote).
4094
4095    Pass for length either the length of the hollerith (must be > 0), -1
4096    meaning expecting a character constant, or 0 to cancel expectation of
4097    a hollerith only after calling it with a length of > 0 and receiving the
4098    next token (which may or may not have been a HOLLERITH token).
4099
4100    Pass for which either an apostrophe or quote when passing length of -1.
4101    Else which is a don't-care.
4102
4103    Pass for line and column the line/column info for the token beginning the
4104    character or hollerith constant, for use in error messages, when passing
4105    a length of -1 -- this function will invoke ffewhere_line/column_use to
4106    make its own copies.  Else line and column are don't-cares (when length
4107    is 0) and the outstanding copies of the previous line/column info, if
4108    still around, are killed.
4109
4110    21-Feb-90  JCB  3.1
4111       When called with length of 0, also zero ffelex_raw_mode_.  This is
4112       so ffest_save_ can undo the effects of replaying tokens like
4113       APOSTROPHE and QUOTE.
4114    25-Jan-90  JCB  3.0
4115       New line, column arguments allow error messages to point to the true
4116       beginning of a character/hollerith constant, rather than the beginning
4117       of the content part, which makes them more consistent and helpful.
4118    05-Nov-89  JCB  2.0
4119       New "which" argument allows caller to specify termination character,
4120       which should be apostrophe or double-quote, to support Fortran 90.  */
4121
4122 void
4123 ffelex_set_expecting_hollerith (long length, char which,
4124                                 ffewhereLine line, ffewhereColumn column)
4125 {
4126
4127   /* First kill the pending line/col info, if any (should only be pending
4128      when this call has length==0, the previous call had length>0, and a
4129      non-HOLLERITH token was sent in between the calls, but play it safe). */
4130
4131   ffewhere_line_kill (ffelex_raw_where_line_);
4132   ffewhere_column_kill (ffelex_raw_where_col_);
4133
4134   /* Now handle the length function. */
4135   switch (length)
4136     {
4137     case 0:
4138       ffelex_expecting_hollerith_ = 0;
4139       ffelex_raw_mode_ = 0;
4140       ffelex_raw_where_line_ = ffewhere_line_unknown ();
4141       ffelex_raw_where_col_ = ffewhere_column_unknown ();
4142       return;                   /* Don't set new line/column info from args. */
4143
4144     case -1:
4145       ffelex_raw_mode_ = -1;
4146       ffelex_raw_char_ = which;
4147       break;
4148
4149     default:                    /* length > 0 */
4150       ffelex_expecting_hollerith_ = length;
4151       break;
4152     }
4153
4154   /* Now set new line/column information from passed args. */
4155
4156   ffelex_raw_where_line_ = ffewhere_line_use (line);
4157   ffelex_raw_where_col_ = ffewhere_column_use (column);
4158 }
4159
4160 /* ffelex_set_handler -- Set handler for tokens before calling _fixed or _free
4161
4162    ffelex_set_handler((ffelexHandler) my_first_handler);
4163
4164    Must be called before calling ffelex_file_fixed or ffelex_file_free or
4165    after they return, but not while they are active.  */
4166
4167 void
4168 ffelex_set_handler (ffelexHandler first)
4169 {
4170   ffelex_handler_ = first;
4171 }
4172
4173 /* ffelex_set_hexnum -- Set hexnum flag
4174
4175    ffelex_set_hexnum(TRUE);
4176
4177    Lex normally interprets a token starting with [0-9] as a NUMBER token,
4178    so if it sees a [A-Za-z] in it, it stops parsing the NUMBER and leaves
4179    the character as the first of the next token.  But when parsing a
4180    hexadecimal number, by calling this function with TRUE before starting
4181    the parse of the token itself, lex will interpret [0-9] as the start
4182    of a NAME token.  */
4183
4184 void
4185 ffelex_set_hexnum (bool f)
4186 {
4187   ffelex_hexnum_ = f;
4188 }
4189
4190 /* ffelex_set_include -- Set INCLUDE file to be processed next
4191
4192    ffewhereFile wf;  // The ffewhereFile object for the file.
4193    bool free_form;  // TRUE means read free-form file, FALSE fixed-form.
4194    FILE *fi;  // The file to INCLUDE.
4195    ffelex_set_include(wf,free_form,fi);
4196
4197    Must be called only after receiving the EOS token following a valid
4198    INCLUDE statement specifying a file that has already been successfully
4199    opened.  */
4200
4201 void
4202 ffelex_set_include (ffewhereFile wf, bool free_form, FILE *fi)
4203 {
4204   assert (ffelex_permit_include_);
4205   assert (!ffelex_set_include_);
4206   ffelex_set_include_ = TRUE;
4207   ffelex_include_free_form_ = free_form;
4208   ffelex_include_file_ = fi;
4209   ffelex_include_wherefile_ = wf;
4210 }
4211
4212 /* ffelex_set_names -- Set names/name flag, names = TRUE
4213
4214    ffelex_set_names(FALSE);
4215
4216    Lex initially assumes multiple names should be formed.  If this function is
4217    called with FALSE, then single names are formed instead.  The differences
4218    are a difference in the token type (FFELEX_typeNAMES vs. FFELEX_typeNAME)
4219    and in whether full source-location tracking is performed (it is for
4220    multiple names, not for single names), which is more expensive in terms of
4221    CPU time.  */
4222
4223 void
4224 ffelex_set_names (bool f)
4225 {
4226   ffelex_names_ = f;
4227   if (!f)
4228     ffelex_names_pure_ = FALSE;
4229 }
4230
4231 /* ffelex_set_names_pure -- Set names/name (pure) flag, names = TRUE
4232
4233    ffelex_set_names_pure(FALSE);
4234
4235    Like ffelex_set_names, except affects both lexers.  Normally, the
4236    free-form lexer need not generate NAMES tokens because adjacent NAME
4237    tokens must be separated by spaces which causes the lexer to generate
4238    separate tokens for analysis (whereas in fixed-form the spaces are
4239    ignored resulting in one long token).  But in FORMAT statements, for
4240    some reason, the Fortran 90 standard specifies that spaces can occur
4241    anywhere within a format-item-list with no effect on the format spec
4242    (except of course within character string edit descriptors), which means
4243    that "1PE14.2" and "1 P E 1 4 . 2" are equivalent.  For the FORMAT
4244    statement handling, the existence of spaces makes it hard to deal with,
4245    because each token is seen distinctly (i.e. seven tokens in the latter
4246    example).  But when no spaces are provided, as in the former example,
4247    then only four tokens are generated, NUMBER("1"), NAME("PE14"), PERIOD,
4248    NUMBER ("2").  By generating a NAMES instead of NAME, three things happen:
4249    One, ffest_kw_format_ does a substring rather than full-string match,
4250    and thus matches "PE14" to "PE"; two, ffelex_token_xyz_from_names functions
4251    may be used to pull NAME/NAMES and NUMBER tokens out of the NAMES token;
4252    and three, error reporting can point to the actual character rather than
4253    at or prior to it.  The first two things could be resolved by providing
4254    alternate functions fairly easy, thus allowing FORMAT handling to expect
4255    both lexers to generate NAME tokens instead of NAMES (with otherwise minor
4256    changes to FORMAT parsing), but the third, error reporting, would suffer,
4257    and when one makes mistakes in a FORMAT, believe me, one wants a pointer
4258    to exactly where the compilers thinks the problem is, to even begin to get
4259    a handle on it.  So there.  */
4260
4261 void
4262 ffelex_set_names_pure (bool f)
4263 {
4264   ffelex_names_pure_ = f;
4265   ffelex_names_ = f;
4266 }
4267
4268 /* ffelex_splice_tokens -- Splice off and send tokens from a NAMES
4269
4270    return (ffelexHandler) ffelex_splice_tokens(first_handler,master_token,
4271          start_char_index);
4272
4273    Returns first_handler if start_char_index chars into master_token (which
4274    must be a NAMES token) is '\0'. Else, creates a subtoken from that
4275    char, either NUMBER (if it is a digit), a NAME (if a valid firstnamechar),
4276    an UNDERSCORE (if an underscore), or DOLLAR (if a dollar sign)
4277    and sends it to first_handler. If anything other than NAME is sent, the
4278    character at the end of it in the master token is examined to see if it
4279    begins a NAME, NUMBER, UNDERSCORE, or DOLLAR, and, if so,
4280    the handler returned by first_handler is invoked with that token, and
4281    this process is repeated until the end of the master token or a NAME
4282    token is reached.  */
4283
4284 ffelexHandler
4285 ffelex_splice_tokens (ffelexHandler first, ffelexToken master,
4286                       ffeTokenLength start)
4287 {
4288   char *p;
4289   ffeTokenLength i;
4290   ffelexToken t;
4291
4292   p = ffelex_token_text (master) + (i = start);
4293
4294   while (*p != '\0')
4295     {
4296       if (isdigit (*p))
4297         {
4298           t = ffelex_token_number_from_names (master, i);
4299           p += ffelex_token_length (t);
4300           i += ffelex_token_length (t);
4301         }
4302       else if (ffesrc_is_name_init (*p))
4303         {
4304           t = ffelex_token_name_from_names (master, i, 0);
4305           p += ffelex_token_length (t);
4306           i += ffelex_token_length (t);
4307         }
4308       else if (*p == '$')
4309         {
4310           t = ffelex_token_dollar_from_names (master, i);
4311           ++p;
4312           ++i;
4313         }
4314       else if (*p == '_')
4315         {
4316           t = ffelex_token_uscore_from_names (master, i);
4317           ++p;
4318           ++i;
4319         }
4320       else
4321         {
4322           assert ("not a valid NAMES character" == NULL);
4323           t = NULL;
4324         }
4325       assert (first != NULL);
4326       first = (ffelexHandler) (*first) (t);
4327       ffelex_token_kill (t);
4328     }
4329
4330   return first;
4331 }
4332
4333 /* ffelex_swallow_tokens -- Eat all tokens delivered to me
4334
4335    return ffelex_swallow_tokens;
4336
4337    Return this handler when you don't want to look at any more tokens in the
4338    statement because you've encountered an unrecoverable error in the
4339    statement.  */
4340
4341 ffelexHandler
4342 ffelex_swallow_tokens (ffelexToken t, ffelexHandler handler)
4343 {
4344   assert (handler != NULL);
4345
4346   if ((t != NULL) && ((ffelex_token_type (t) == FFELEX_typeEOS)
4347                       || (ffelex_token_type (t) == FFELEX_typeSEMICOLON)))
4348     return (ffelexHandler) (*handler) (t);
4349
4350   ffelex_eos_handler_ = handler;
4351   return (ffelexHandler) ffelex_swallow_tokens_;
4352 }
4353
4354 /* ffelex_token_dollar_from_names -- Return a dollar from within a names token
4355
4356    ffelexToken t;
4357    t = ffelex_token_dollar_from_names(t,6);
4358
4359    It's as if you made a new token of dollar type having the dollar
4360    at, in the example above, the sixth character of the NAMES token.  */
4361
4362 ffelexToken
4363 ffelex_token_dollar_from_names (ffelexToken t, ffeTokenLength start)
4364 {
4365   ffelexToken nt;
4366
4367   assert (t != NULL);
4368   assert (ffelex_token_type (t) == FFELEX_typeNAMES);
4369   assert (start < t->length);
4370   assert (t->text[start] == '$');
4371
4372   /* Now make the token. */
4373
4374   nt = ffelex_token_new_ ();
4375   nt->type = FFELEX_typeDOLLAR;
4376   nt->length = 0;
4377   nt->uses = 1;
4378   ffewhere_set_from_track (&nt->where_line, &nt->where_col, t->where_line,
4379                            t->where_col, t->wheretrack, start);
4380   nt->text = NULL;
4381   return nt;
4382 }
4383
4384 /* ffelex_token_kill -- Decrement use count for token, kill if no uses left
4385
4386    ffelexToken t;
4387    ffelex_token_kill(t);
4388
4389    Complements a call to ffelex_token_use or ffelex_token_new_....  */
4390
4391 void
4392 ffelex_token_kill (ffelexToken t)
4393 {
4394   assert (t != NULL);
4395
4396   assert (t->uses > 0);
4397
4398   if (--t->uses != 0)
4399     return;
4400
4401   --ffelex_total_tokens_;
4402
4403   if (t->type == FFELEX_typeNAMES)
4404     ffewhere_track_kill (t->where_line, t->where_col,
4405                          t->wheretrack, t->length);
4406   ffewhere_line_kill (t->where_line);
4407   ffewhere_column_kill (t->where_col);
4408   if (t->text != NULL)
4409     malloc_kill_ksr (malloc_pool_image (), t->text, t->size + 1);
4410   malloc_kill_ks (malloc_pool_image (), t, sizeof (*t));
4411 }
4412
4413 /* Make a new NAME token that is a substring of a NAMES token.  */
4414
4415 ffelexToken
4416 ffelex_token_name_from_names (ffelexToken t, ffeTokenLength start,
4417                               ffeTokenLength len)
4418 {
4419   ffelexToken nt;
4420
4421   assert (t != NULL);
4422   assert (ffelex_token_type (t) == FFELEX_typeNAMES);
4423   assert (start < t->length);
4424   if (len == 0)
4425     len = t->length - start;
4426   else
4427     {
4428       assert (len > 0);
4429       assert ((start + len) <= t->length);
4430     }
4431   assert (ffelex_is_firstnamechar (t->text[start]));
4432
4433   nt = ffelex_token_new_ ();
4434   nt->type = FFELEX_typeNAME;
4435   nt->size = len;               /* Assume nobody's gonna fiddle with token
4436                                    text. */
4437   nt->length = len;
4438   nt->uses = 1;
4439   ffewhere_set_from_track (&nt->where_line, &nt->where_col, t->where_line,
4440                            t->where_col, t->wheretrack, start);
4441   nt->text = malloc_new_ksr (malloc_pool_image (), "FFELEX token text",
4442                              len + 1);
4443   strncpy (nt->text, t->text + start, len);
4444   nt->text[len] = '\0';
4445   return nt;
4446 }
4447
4448 /* Make a new NAMES token that is a substring of another NAMES token.  */
4449
4450 ffelexToken
4451 ffelex_token_names_from_names (ffelexToken t, ffeTokenLength start,
4452                                ffeTokenLength len)
4453 {
4454   ffelexToken nt;
4455
4456   assert (t != NULL);
4457   assert (ffelex_token_type (t) == FFELEX_typeNAMES);
4458   assert (start < t->length);
4459   if (len == 0)
4460     len = t->length - start;
4461   else
4462     {
4463       assert (len > 0);
4464       assert ((start + len) <= t->length);
4465     }
4466   assert (ffelex_is_firstnamechar (t->text[start]));
4467
4468   nt = ffelex_token_new_ ();
4469   nt->type = FFELEX_typeNAMES;
4470   nt->size = len;               /* Assume nobody's gonna fiddle with token
4471                                    text. */
4472   nt->length = len;
4473   nt->uses = 1;
4474   ffewhere_set_from_track (&nt->where_line, &nt->where_col, t->where_line,
4475                            t->where_col, t->wheretrack, start);
4476   ffewhere_track_copy (nt->wheretrack, t->wheretrack, start, len);
4477   nt->text = malloc_new_ksr (malloc_pool_image (), "FFELEX token text",
4478                              len + 1);
4479   strncpy (nt->text, t->text + start, len);
4480   nt->text[len] = '\0';
4481   return nt;
4482 }
4483
4484 /* Make a new CHARACTER token.  */
4485
4486 ffelexToken
4487 ffelex_token_new_character (char *s, ffewhereLine l, ffewhereColumn c)
4488 {
4489   ffelexToken t;
4490
4491   t = ffelex_token_new_ ();
4492   t->type = FFELEX_typeCHARACTER;
4493   t->length = t->size = strlen (s);     /* Assume it won't get bigger. */
4494   t->uses = 1;
4495   t->text = malloc_new_ksr (malloc_pool_image (), "FFELEX token text",
4496                             t->size + 1);
4497   strcpy (t->text, s);
4498   t->where_line = ffewhere_line_use (l);
4499   t->where_col = ffewhere_column_new (c);
4500   return t;
4501 }
4502
4503 /* Make a new EOF token right after end of file.  */
4504
4505 ffelexToken
4506 ffelex_token_new_eof ()
4507 {
4508   ffelexToken t;
4509
4510   t = ffelex_token_new_ ();
4511   t->type = FFELEX_typeEOF;
4512   t->uses = 1;
4513   t->text = NULL;
4514   t->where_line = ffewhere_line_new (ffelex_linecount_current_);
4515   t->where_col = ffewhere_column_new (1);
4516   return t;
4517 }
4518
4519 /* Make a new NAME token.  */
4520
4521 ffelexToken
4522 ffelex_token_new_name (char *s, ffewhereLine l, ffewhereColumn c)
4523 {
4524   ffelexToken t;
4525
4526   assert (ffelex_is_firstnamechar (*s));
4527
4528   t = ffelex_token_new_ ();
4529   t->type = FFELEX_typeNAME;
4530   t->length = t->size = strlen (s);     /* Assume it won't get bigger. */
4531   t->uses = 1;
4532   t->text = malloc_new_ksr (malloc_pool_image (), "FFELEX token text",
4533                             t->size + 1);
4534   strcpy (t->text, s);
4535   t->where_line = ffewhere_line_use (l);
4536   t->where_col = ffewhere_column_new (c);
4537   return t;
4538 }
4539
4540 /* Make a new NAMES token.  */
4541
4542 ffelexToken
4543 ffelex_token_new_names (char *s, ffewhereLine l, ffewhereColumn c)
4544 {
4545   ffelexToken t;
4546
4547   assert (ffelex_is_firstnamechar (*s));
4548
4549   t = ffelex_token_new_ ();
4550   t->type = FFELEX_typeNAMES;
4551   t->length = t->size = strlen (s);     /* Assume it won't get bigger. */
4552   t->uses = 1;
4553   t->text = malloc_new_ksr (malloc_pool_image (), "FFELEX token text",
4554                             t->size + 1);
4555   strcpy (t->text, s);
4556   t->where_line = ffewhere_line_use (l);
4557   t->where_col = ffewhere_column_new (c);
4558   ffewhere_track_clear (t->wheretrack, t->length);      /* Assume contiguous
4559                                                            names. */
4560   return t;
4561 }
4562
4563 /* Make a new NUMBER token.
4564
4565    The first character of the string must be a digit, and only the digits
4566    are copied into the new number.  So this may be used to easily extract
4567    a NUMBER token from within any text string.  Then the length of the
4568    resulting token may be used to calculate where the digits stopped
4569    in the original string.  */
4570
4571 ffelexToken
4572 ffelex_token_new_number (char *s, ffewhereLine l, ffewhereColumn c)
4573 {
4574   ffelexToken t;
4575   ffeTokenLength len;
4576
4577   /* How long is the string of decimal digits at s? */
4578
4579   len = strspn (s, "0123456789");
4580
4581   /* Make sure there is at least one digit. */
4582
4583   assert (len != 0);
4584
4585   /* Now make the token. */
4586
4587   t = ffelex_token_new_ ();
4588   t->type = FFELEX_typeNUMBER;
4589   t->length = t->size = len;    /* Assume it won't get bigger. */
4590   t->uses = 1;
4591   t->text = malloc_new_ksr (malloc_pool_image (), "FFELEX token text",
4592                             len + 1);
4593   strncpy (t->text, s, len);
4594   t->text[len] = '\0';
4595   t->where_line = ffewhere_line_use (l);
4596   t->where_col = ffewhere_column_new (c);
4597   return t;
4598 }
4599
4600 /* Make a new token of any type that doesn't contain text.  A private
4601    function that is used by public macros in the interface file.  */
4602
4603 ffelexToken
4604 ffelex_token_new_simple_ (ffelexType type, ffewhereLine l, ffewhereColumn c)
4605 {
4606   ffelexToken t;
4607
4608   t = ffelex_token_new_ ();
4609   t->type = type;
4610   t->uses = 1;
4611   t->text = NULL;
4612   t->where_line = ffewhere_line_use (l);
4613   t->where_col = ffewhere_column_new (c);
4614   return t;
4615 }
4616
4617 /* Make a new NUMBER token from an existing NAMES token.
4618
4619    Like ffelex_token_new_number, this function calculates the length
4620    of the digit string itself.  */
4621
4622 ffelexToken
4623 ffelex_token_number_from_names (ffelexToken t, ffeTokenLength start)
4624 {
4625   ffelexToken nt;
4626   ffeTokenLength len;
4627
4628   assert (t != NULL);
4629   assert (ffelex_token_type (t) == FFELEX_typeNAMES);
4630   assert (start < t->length);
4631
4632   /* How long is the string of decimal digits at s? */
4633
4634   len = strspn (t->text + start, "0123456789");
4635
4636   /* Make sure there is at least one digit. */
4637
4638   assert (len != 0);
4639
4640   /* Now make the token. */
4641
4642   nt = ffelex_token_new_ ();
4643   nt->type = FFELEX_typeNUMBER;
4644   nt->size = len;               /* Assume nobody's gonna fiddle with token
4645                                    text. */
4646   nt->length = len;
4647   nt->uses = 1;
4648   ffewhere_set_from_track (&nt->where_line, &nt->where_col, t->where_line,
4649                            t->where_col, t->wheretrack, start);
4650   nt->text = malloc_new_ksr (malloc_pool_image (), "FFELEX token text",
4651                              len + 1);
4652   strncpy (nt->text, t->text + start, len);
4653   nt->text[len] = '\0';
4654   return nt;
4655 }
4656
4657 /* Make a new UNDERSCORE token from a NAMES token.  */
4658
4659 ffelexToken
4660 ffelex_token_uscore_from_names (ffelexToken t, ffeTokenLength start)
4661 {
4662   ffelexToken nt;
4663
4664   assert (t != NULL);
4665   assert (ffelex_token_type (t) == FFELEX_typeNAMES);
4666   assert (start < t->length);
4667   assert (t->text[start] == '_');
4668
4669   /* Now make the token. */
4670
4671   nt = ffelex_token_new_ ();
4672   nt->type = FFELEX_typeUNDERSCORE;
4673   nt->uses = 1;
4674   ffewhere_set_from_track (&nt->where_line, &nt->where_col, t->where_line,
4675                            t->where_col, t->wheretrack, start);
4676   nt->text = NULL;
4677   return nt;
4678 }
4679
4680 /* ffelex_token_use -- Return another instance of a token
4681
4682    ffelexToken t;
4683    t = ffelex_token_use(t);
4684
4685    In a sense, the new token is a copy of the old, though it might be the
4686    same with just a new use count.
4687
4688    We use the use count method (easy).  */
4689
4690 ffelexToken
4691 ffelex_token_use (ffelexToken t)
4692 {
4693   if (t == NULL)
4694     assert ("_token_use: null token" == NULL);
4695   t->uses++;
4696   return t;
4697 }