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