gcc/f/lex.c

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