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