1/* Character scanner. 2 Copyright (C) 2000-2022 Free Software Foundation, Inc. 3 Contributed by Andy Vaught 4 5This file is part of GCC. 6 7GCC is free software; you can redistribute it and/or modify it under 8the terms of the GNU General Public License as published by the Free 9Software Foundation; either version 3, or (at your option) any later 10version. 11 12GCC is distributed in the hope that it will be useful, but WITHOUT ANY 13WARRANTY; without even the implied warranty of MERCHANTABILITY or 14FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License 15for more details. 16 17You should have received a copy of the GNU General Public License 18along with GCC; see the file COPYING3. If not see 19<http://www.gnu.org/licenses/>. */ 20 21/* Set of subroutines to (ultimately) return the next character to the 22 various matching subroutines. This file's job is to read files and 23 build up lines that are parsed by the parser. This means that we 24 handle continuation lines and "include" lines. 25 26 The first thing the scanner does is to load an entire file into 27 memory. We load the entire file into memory for a couple reasons. 28 The first is that we want to be able to deal with nonseekable input 29 (pipes, stdin) and there is a lot of backing up involved during 30 parsing. 31 32 The second is that we want to be able to print the locus of errors, 33 and an error on line 999999 could conflict with something on line 34 one. Given nonseekable input, we've got to store the whole thing. 35 36 One thing that helps are the column truncation limits that give us 37 an upper bound on the size of individual lines. We don't store the 38 truncated stuff. 39 40 From the scanner's viewpoint, the higher level subroutines ask for 41 new characters and do a lot of jumping backwards. */ 42 43#include "config.h" 44#include "system.h" 45#include "coretypes.h" 46#include "gfortran.h" 47#include "toplev.h" /* For set_src_pwd. */ 48#include "debug.h" 49#include "options.h" 50#include "diagnostic-core.h" /* For fatal_error. */ 51#include "cpp.h" 52#include "scanner.h" 53 54/* List of include file search directories. */ 55gfc_directorylist *include_dirs, *intrinsic_modules_dirs; 56 57static gfc_file *file_head, *current_file; 58 59static int continue_flag, end_flag, gcc_attribute_flag; 60/* If !$omp/!$acc occurred in current comment line. */ 61static int openmp_flag, openacc_flag; 62static int continue_count, continue_line; 63static locus openmp_locus; 64static locus openacc_locus; 65static locus gcc_attribute_locus; 66 67gfc_source_form gfc_current_form; 68static gfc_linebuf *line_head, *line_tail; 69 70locus gfc_current_locus; 71const char *gfc_source_file; 72static FILE *gfc_src_file; 73static gfc_char_t *gfc_src_preprocessor_lines[2]; 74 75static struct gfc_file_change 76{ 77 const char *filename; 78 gfc_linebuf *lb; 79 int line; 80} *file_changes; 81static size_t file_changes_cur, file_changes_count; 82static size_t file_changes_allocated; 83 84static gfc_char_t *last_error_char; 85 86/* Functions dealing with our wide characters (gfc_char_t) and 87 sequences of such characters. */ 88 89int 90gfc_wide_fits_in_byte (gfc_char_t c) 91{ 92 return (c <= UCHAR_MAX); 93} 94 95static inline int 96wide_is_ascii (gfc_char_t c) 97{ 98 return (gfc_wide_fits_in_byte (c) && ((unsigned char) c & ~0x7f) == 0); 99} 100 101int 102gfc_wide_is_printable (gfc_char_t c) 103{ 104 return (gfc_wide_fits_in_byte (c) && ISPRINT ((unsigned char) c)); 105} 106 107gfc_char_t 108gfc_wide_tolower (gfc_char_t c) 109{ 110 return (wide_is_ascii (c) ? (gfc_char_t) TOLOWER((unsigned char) c) : c); 111} 112 113gfc_char_t 114gfc_wide_toupper (gfc_char_t c) 115{ 116 return (wide_is_ascii (c) ? (gfc_char_t) TOUPPER((unsigned char) c) : c); 117} 118 119int 120gfc_wide_is_digit (gfc_char_t c) 121{ 122 return (c >= '0' && c <= '9'); 123} 124 125static inline int 126wide_atoi (gfc_char_t *c) 127{ 128#define MAX_DIGITS 20 129 char buf[MAX_DIGITS+1]; 130 int i = 0; 131 132 while (gfc_wide_is_digit(*c) && i < MAX_DIGITS) 133 buf[i++] = *c++; 134 buf[i] = '\0'; 135 return atoi (buf); 136} 137 138size_t 139gfc_wide_strlen (const gfc_char_t *str) 140{ 141 size_t i; 142 143 for (i = 0; str[i]; i++) 144 ; 145 146 return i; 147} 148 149gfc_char_t * 150gfc_wide_memset (gfc_char_t *b, gfc_char_t c, size_t len) 151{ 152 size_t i; 153 154 for (i = 0; i < len; i++) 155 b[i] = c; 156 157 return b; 158} 159 160static gfc_char_t * 161wide_strcpy (gfc_char_t *dest, const gfc_char_t *src) 162{ 163 gfc_char_t *d; 164 165 for (d = dest; (*d = *src) != '\0'; ++src, ++d) 166 ; 167 168 return dest; 169} 170 171static gfc_char_t * 172wide_strchr (const gfc_char_t *s, gfc_char_t c) 173{ 174 do { 175 if (*s == c) 176 { 177 return CONST_CAST(gfc_char_t *, s); 178 } 179 } while (*s++); 180 return 0; 181} 182 183char * 184gfc_widechar_to_char (const gfc_char_t *s, int length) 185{ 186 size_t len, i; 187 char *res; 188 189 if (s == NULL) 190 return NULL; 191 192 /* Passing a negative length is used to indicate that length should be 193 calculated using gfc_wide_strlen(). */ 194 len = (length >= 0 ? (size_t) length : gfc_wide_strlen (s)); 195 res = XNEWVEC (char, len + 1); 196 197 for (i = 0; i < len; i++) 198 { 199 gcc_assert (gfc_wide_fits_in_byte (s[i])); 200 res[i] = (unsigned char) s[i]; 201 } 202 203 res[len] = '\0'; 204 return res; 205} 206 207gfc_char_t * 208gfc_char_to_widechar (const char *s) 209{ 210 size_t len, i; 211 gfc_char_t *res; 212 213 if (s == NULL) 214 return NULL; 215 216 len = strlen (s); 217 res = gfc_get_wide_string (len + 1); 218 219 for (i = 0; i < len; i++) 220 res[i] = (unsigned char) s[i]; 221 222 res[len] = '\0'; 223 return res; 224} 225 226static int 227wide_strncmp (const gfc_char_t *s1, const char *s2, size_t n) 228{ 229 gfc_char_t c1, c2; 230 231 while (n-- > 0) 232 { 233 c1 = *s1++; 234 c2 = *s2++; 235 if (c1 != c2) 236 return (c1 > c2 ? 1 : -1); 237 if (c1 == '\0') 238 return 0; 239 } 240 return 0; 241} 242 243int 244gfc_wide_strncasecmp (const gfc_char_t *s1, const char *s2, size_t n) 245{ 246 gfc_char_t c1, c2; 247 248 while (n-- > 0) 249 { 250 c1 = gfc_wide_tolower (*s1++); 251 c2 = TOLOWER (*s2++); 252 if (c1 != c2) 253 return (c1 > c2 ? 1 : -1); 254 if (c1 == '\0') 255 return 0; 256 } 257 return 0; 258} 259 260 261/* Main scanner initialization. */ 262 263void 264gfc_scanner_init_1 (void) 265{ 266 file_head = NULL; 267 line_head = NULL; 268 line_tail = NULL; 269 270 continue_count = 0; 271 continue_line = 0; 272 273 end_flag = 0; 274 last_error_char = NULL; 275} 276 277 278/* Main scanner destructor. */ 279 280void 281gfc_scanner_done_1 (void) 282{ 283 gfc_linebuf *lb; 284 gfc_file *f; 285 286 while(line_head != NULL) 287 { 288 lb = line_head->next; 289 free (line_head); 290 line_head = lb; 291 } 292 293 while(file_head != NULL) 294 { 295 f = file_head->next; 296 free (file_head->filename); 297 free (file_head); 298 file_head = f; 299 } 300} 301 302static bool 303gfc_do_check_include_dir (const char *path, bool warn) 304{ 305 struct stat st; 306 if (stat (path, &st)) 307 { 308 if (errno != ENOENT) 309 gfc_warning_now (0, "Include directory %qs: %s", 310 path, xstrerror(errno)); 311 else if (warn) 312 gfc_warning_now (OPT_Wmissing_include_dirs, 313 "Nonexistent include directory %qs", path); 314 return false; 315 } 316 else if (!S_ISDIR (st.st_mode)) 317 { 318 gfc_fatal_error ("%qs is not a directory", path); 319 return false; 320 } 321 return true; 322} 323 324/* In order that -W(no-)missing-include-dirs works, the diagnostic can only be 325 run after processing the commandline. */ 326static void 327gfc_do_check_include_dirs (gfc_directorylist **list, bool do_warn) 328{ 329 gfc_directorylist *prev, *q, *n; 330 prev = NULL; 331 n = *list; 332 while (n) 333 { 334 q = n; n = n->next; 335 if (gfc_do_check_include_dir (q->path, q->warn && do_warn)) 336 { 337 prev = q; 338 continue; 339 } 340 if (prev == NULL) 341 *list = n; 342 else 343 prev->next = n; 344 free (q->path); 345 free (q); 346 } 347} 348 349void 350gfc_check_include_dirs (bool verbose_missing_dir_warn) 351{ 352 /* This is a bit convoluted: If gfc_cpp_enabled () and 353 verbose_missing_dir_warn, the warning is shown by libcpp. Otherwise, 354 it is shown here, still conditional on OPT_Wmissing_include_dirs. */ 355 bool warn = !gfc_cpp_enabled () || !verbose_missing_dir_warn; 356 gfc_do_check_include_dirs (&include_dirs, warn); 357 gfc_do_check_include_dirs (&intrinsic_modules_dirs, verbose_missing_dir_warn); 358 if (gfc_option.module_dir && gfc_cpp_enabled ()) 359 gfc_do_check_include_dirs (&include_dirs, true); 360} 361 362/* Adds path to the list pointed to by list. */ 363 364static void 365add_path_to_list (gfc_directorylist **list, const char *path, 366 bool use_for_modules, bool head, bool warn, bool defer_warn) 367{ 368 gfc_directorylist *dir; 369 const char *p; 370 char *q; 371 size_t len; 372 int i; 373 374 p = path; 375 while (*p == ' ' || *p == '\t') /* someone might do "-I include" */ 376 if (*p++ == '\0') 377 return; 378 379 /* Strip trailing directory separators from the path, as this 380 will confuse Windows systems. */ 381 len = strlen (p); 382 q = (char *) alloca (len + 1); 383 memcpy (q, p, len + 1); 384 i = len - 1; 385 while (i >=0 && IS_DIR_SEPARATOR (q[i])) 386 q[i--] = '\0'; 387 388 if (!defer_warn && !gfc_do_check_include_dir (q, warn)) 389 return; 390 391 if (head || *list == NULL) 392 { 393 dir = XCNEW (gfc_directorylist); 394 if (!head) 395 *list = dir; 396 } 397 else 398 { 399 dir = *list; 400 while (dir->next) 401 dir = dir->next; 402 403 dir->next = XCNEW (gfc_directorylist); 404 dir = dir->next; 405 } 406 407 dir->next = head ? *list : NULL; 408 if (head) 409 *list = dir; 410 dir->use_for_modules = use_for_modules; 411 dir->warn = warn; 412 dir->path = xstrdup (p); 413} 414 415/* defer_warn is set to true while parsing the commandline. */ 416 417void 418gfc_add_include_path (const char *path, bool use_for_modules, bool file_dir, 419 bool warn, bool defer_warn) 420{ 421 add_path_to_list (&include_dirs, path, use_for_modules, file_dir, warn, 422 defer_warn); 423 424 /* For '#include "..."' these directories are automatically searched. */ 425 if (!file_dir) 426 gfc_cpp_add_include_path (xstrdup(path), true); 427} 428 429 430void 431gfc_add_intrinsic_modules_path (const char *path) 432{ 433 add_path_to_list (&intrinsic_modules_dirs, path, true, false, false, false); 434} 435 436 437/* Release resources allocated for options. */ 438 439void 440gfc_release_include_path (void) 441{ 442 gfc_directorylist *p; 443 444 while (include_dirs != NULL) 445 { 446 p = include_dirs; 447 include_dirs = include_dirs->next; 448 free (p->path); 449 free (p); 450 } 451 452 while (intrinsic_modules_dirs != NULL) 453 { 454 p = intrinsic_modules_dirs; 455 intrinsic_modules_dirs = intrinsic_modules_dirs->next; 456 free (p->path); 457 free (p); 458 } 459 460 free (gfc_option.module_dir); 461} 462 463 464static FILE * 465open_included_file (const char *name, gfc_directorylist *list, 466 bool module, bool system) 467{ 468 char *fullname; 469 gfc_directorylist *p; 470 FILE *f; 471 472 for (p = list; p; p = p->next) 473 { 474 if (module && !p->use_for_modules) 475 continue; 476 477 fullname = (char *) alloca(strlen (p->path) + strlen (name) + 2); 478 strcpy (fullname, p->path); 479 strcat (fullname, "/"); 480 strcat (fullname, name); 481 482 f = gfc_open_file (fullname); 483 if (f != NULL) 484 { 485 if (gfc_cpp_makedep ()) 486 gfc_cpp_add_dep (fullname, system); 487 488 return f; 489 } 490 } 491 492 return NULL; 493} 494 495 496/* Opens file for reading, searching through the include directories 497 given if necessary. If the include_cwd argument is true, we try 498 to open the file in the current directory first. */ 499 500FILE * 501gfc_open_included_file (const char *name, bool include_cwd, bool module) 502{ 503 FILE *f = NULL; 504 505 if (IS_ABSOLUTE_PATH (name) || include_cwd) 506 { 507 f = gfc_open_file (name); 508 if (f && gfc_cpp_makedep ()) 509 gfc_cpp_add_dep (name, false); 510 } 511 512 if (!f) 513 f = open_included_file (name, include_dirs, module, false); 514 515 return f; 516} 517 518 519/* Test to see if we're at the end of the main source file. */ 520 521int 522gfc_at_end (void) 523{ 524 return end_flag; 525} 526 527 528/* Test to see if we're at the end of the current file. */ 529 530int 531gfc_at_eof (void) 532{ 533 if (gfc_at_end ()) 534 return 1; 535 536 if (line_head == NULL) 537 return 1; /* Null file */ 538 539 if (gfc_current_locus.lb == NULL) 540 return 1; 541 542 return 0; 543} 544 545 546/* Test to see if we're at the beginning of a new line. */ 547 548int 549gfc_at_bol (void) 550{ 551 if (gfc_at_eof ()) 552 return 1; 553 554 return (gfc_current_locus.nextc == gfc_current_locus.lb->line); 555} 556 557 558/* Test to see if we're at the end of a line. */ 559 560int 561gfc_at_eol (void) 562{ 563 if (gfc_at_eof ()) 564 return 1; 565 566 return (*gfc_current_locus.nextc == '\0'); 567} 568 569static void 570add_file_change (const char *filename, int line) 571{ 572 if (file_changes_count == file_changes_allocated) 573 { 574 if (file_changes_allocated) 575 file_changes_allocated *= 2; 576 else 577 file_changes_allocated = 16; 578 file_changes = XRESIZEVEC (struct gfc_file_change, file_changes, 579 file_changes_allocated); 580 } 581 file_changes[file_changes_count].filename = filename; 582 file_changes[file_changes_count].lb = NULL; 583 file_changes[file_changes_count++].line = line; 584} 585 586static void 587report_file_change (gfc_linebuf *lb) 588{ 589 size_t c = file_changes_cur; 590 while (c < file_changes_count 591 && file_changes[c].lb == lb) 592 { 593 if (file_changes[c].filename) 594 (*debug_hooks->start_source_file) (file_changes[c].line, 595 file_changes[c].filename); 596 else 597 (*debug_hooks->end_source_file) (file_changes[c].line); 598 ++c; 599 } 600 file_changes_cur = c; 601} 602 603void 604gfc_start_source_files (void) 605{ 606 /* If the debugger wants the name of the main source file, 607 we give it. */ 608 if (debug_hooks->start_end_main_source_file) 609 (*debug_hooks->start_source_file) (0, gfc_source_file); 610 611 file_changes_cur = 0; 612 report_file_change (gfc_current_locus.lb); 613} 614 615void 616gfc_end_source_files (void) 617{ 618 report_file_change (NULL); 619 620 if (debug_hooks->start_end_main_source_file) 621 (*debug_hooks->end_source_file) (0); 622} 623 624/* Advance the current line pointer to the next line. */ 625 626void 627gfc_advance_line (void) 628{ 629 if (gfc_at_end ()) 630 return; 631 632 if (gfc_current_locus.lb == NULL) 633 { 634 end_flag = 1; 635 return; 636 } 637 638 if (gfc_current_locus.lb->next 639 && !gfc_current_locus.lb->next->dbg_emitted) 640 { 641 report_file_change (gfc_current_locus.lb->next); 642 gfc_current_locus.lb->next->dbg_emitted = true; 643 } 644 645 gfc_current_locus.lb = gfc_current_locus.lb->next; 646 647 if (gfc_current_locus.lb != NULL) 648 gfc_current_locus.nextc = gfc_current_locus.lb->line; 649 else 650 { 651 gfc_current_locus.nextc = NULL; 652 end_flag = 1; 653 } 654} 655 656 657/* Get the next character from the input, advancing gfc_current_file's 658 locus. When we hit the end of the line or the end of the file, we 659 start returning a '\n' in order to complete the current statement. 660 No Fortran line conventions are implemented here. 661 662 Requiring explicit advances to the next line prevents the parse 663 pointer from being on the wrong line if the current statement ends 664 prematurely. */ 665 666static gfc_char_t 667next_char (void) 668{ 669 gfc_char_t c; 670 671 if (gfc_current_locus.nextc == NULL) 672 return '\n'; 673 674 c = *gfc_current_locus.nextc++; 675 if (c == '\0') 676 { 677 gfc_current_locus.nextc--; /* Remain on this line. */ 678 c = '\n'; 679 } 680 681 return c; 682} 683 684 685/* Skip a comment. When we come here the parse pointer is positioned 686 immediately after the comment character. If we ever implement 687 compiler directives within comments, here is where we parse the 688 directive. */ 689 690static void 691skip_comment_line (void) 692{ 693 gfc_char_t c; 694 695 do 696 { 697 c = next_char (); 698 } 699 while (c != '\n'); 700 701 gfc_advance_line (); 702} 703 704 705int 706gfc_define_undef_line (void) 707{ 708 char *tmp; 709 710 /* All lines beginning with '#' are either #define or #undef. */ 711 if (debug_info_level != DINFO_LEVEL_VERBOSE || gfc_peek_ascii_char () != '#') 712 return 0; 713 714 if (wide_strncmp (gfc_current_locus.nextc, "#define ", 8) == 0) 715 { 716 tmp = gfc_widechar_to_char (&gfc_current_locus.nextc[8], -1); 717 (*debug_hooks->define) (gfc_linebuf_linenum (gfc_current_locus.lb), 718 tmp); 719 free (tmp); 720 } 721 722 if (wide_strncmp (gfc_current_locus.nextc, "#undef ", 7) == 0) 723 { 724 tmp = gfc_widechar_to_char (&gfc_current_locus.nextc[7], -1); 725 (*debug_hooks->undef) (gfc_linebuf_linenum (gfc_current_locus.lb), 726 tmp); 727 free (tmp); 728 } 729 730 /* Skip the rest of the line. */ 731 skip_comment_line (); 732 733 return 1; 734} 735 736 737/* Return true if GCC$ was matched. */ 738static bool 739skip_gcc_attribute (locus start) 740{ 741 bool r = false; 742 char c; 743 locus old_loc = gfc_current_locus; 744 745 if ((c = next_char ()) == 'g' || c == 'G') 746 if ((c = next_char ()) == 'c' || c == 'C') 747 if ((c = next_char ()) == 'c' || c == 'C') 748 if ((c = next_char ()) == '$') 749 r = true; 750 751 if (r == false) 752 gfc_current_locus = old_loc; 753 else 754 { 755 gcc_attribute_flag = 1; 756 gcc_attribute_locus = old_loc; 757 gfc_current_locus = start; 758 } 759 760 return r; 761} 762 763/* Return true if CC was matched. */ 764static bool 765skip_free_oacc_sentinel (locus start, locus old_loc) 766{ 767 bool r = false; 768 char c; 769 770 if ((c = next_char ()) == 'c' || c == 'C') 771 if ((c = next_char ()) == 'c' || c == 'C') 772 r = true; 773 774 if (r) 775 { 776 if ((c = next_char ()) == ' ' || c == '\t' 777 || continue_flag) 778 { 779 while (gfc_is_whitespace (c)) 780 c = next_char (); 781 if (c != '\n' && c != '!') 782 { 783 openacc_flag = 1; 784 openacc_locus = old_loc; 785 gfc_current_locus = start; 786 } 787 else 788 r = false; 789 } 790 else 791 { 792 gfc_warning_now (0, "!$ACC at %C starts a commented " 793 "line as it neither is followed " 794 "by a space nor is a " 795 "continuation line"); 796 r = false; 797 } 798 } 799 800 return r; 801} 802 803/* Return true if MP was matched. */ 804static bool 805skip_free_omp_sentinel (locus start, locus old_loc) 806{ 807 bool r = false; 808 char c; 809 810 if ((c = next_char ()) == 'm' || c == 'M') 811 if ((c = next_char ()) == 'p' || c == 'P') 812 r = true; 813 814 if (r) 815 { 816 if ((c = next_char ()) == ' ' || c == '\t' 817 || continue_flag) 818 { 819 while (gfc_is_whitespace (c)) 820 c = next_char (); 821 if (c != '\n' && c != '!') 822 { 823 openmp_flag = 1; 824 openmp_locus = old_loc; 825 gfc_current_locus = start; 826 } 827 else 828 r = false; 829 } 830 else 831 { 832 gfc_warning_now (0, "!$OMP at %C starts a commented " 833 "line as it neither is followed " 834 "by a space nor is a " 835 "continuation line"); 836 r = false; 837 } 838 } 839 840 return r; 841} 842 843/* Comment lines are null lines, lines containing only blanks or lines 844 on which the first nonblank line is a '!'. 845 Return true if !$ openmp or openacc conditional compilation sentinel was 846 seen. */ 847 848static bool 849skip_free_comments (void) 850{ 851 locus start; 852 gfc_char_t c; 853 int at_bol; 854 855 for (;;) 856 { 857 at_bol = gfc_at_bol (); 858 start = gfc_current_locus; 859 if (gfc_at_eof ()) 860 break; 861 862 do 863 c = next_char (); 864 while (gfc_is_whitespace (c)); 865 866 if (c == '\n') 867 { 868 gfc_advance_line (); 869 continue; 870 } 871 872 if (c == '!') 873 { 874 /* Keep the !GCC$ line. */ 875 if (at_bol && skip_gcc_attribute (start)) 876 return false; 877 878 /* If -fopenmp/-fopenacc, we need to handle here 2 things: 879 1) don't treat !$omp/!$acc as comments, but directives 880 2) handle OpenMP/OpenACC conditional compilation, where 881 !$ should be treated as 2 spaces (for initial lines 882 only if followed by space). */ 883 if (at_bol) 884 { 885 if ((flag_openmp || flag_openmp_simd) 886 && flag_openacc) 887 { 888 locus old_loc = gfc_current_locus; 889 if (next_char () == '$') 890 { 891 c = next_char (); 892 if (c == 'o' || c == 'O') 893 { 894 if (skip_free_omp_sentinel (start, old_loc)) 895 return false; 896 gfc_current_locus = old_loc; 897 next_char (); 898 c = next_char (); 899 } 900 else if (c == 'a' || c == 'A') 901 { 902 if (skip_free_oacc_sentinel (start, old_loc)) 903 return false; 904 gfc_current_locus = old_loc; 905 next_char (); 906 c = next_char (); 907 } 908 if (continue_flag || c == ' ' || c == '\t') 909 { 910 gfc_current_locus = old_loc; 911 next_char (); 912 openmp_flag = openacc_flag = 0; 913 return true; 914 } 915 } 916 gfc_current_locus = old_loc; 917 } 918 else if ((flag_openmp || flag_openmp_simd) 919 && !flag_openacc) 920 { 921 locus old_loc = gfc_current_locus; 922 if (next_char () == '$') 923 { 924 c = next_char (); 925 if (c == 'o' || c == 'O') 926 { 927 if (skip_free_omp_sentinel (start, old_loc)) 928 return false; 929 gfc_current_locus = old_loc; 930 next_char (); 931 c = next_char (); 932 } 933 if (continue_flag || c == ' ' || c == '\t') 934 { 935 gfc_current_locus = old_loc; 936 next_char (); 937 openmp_flag = 0; 938 return true; 939 } 940 } 941 gfc_current_locus = old_loc; 942 } 943 else if (flag_openacc 944 && !(flag_openmp || flag_openmp_simd)) 945 { 946 locus old_loc = gfc_current_locus; 947 if (next_char () == '$') 948 { 949 c = next_char (); 950 if (c == 'a' || c == 'A') 951 { 952 if (skip_free_oacc_sentinel (start, old_loc)) 953 return false; 954 gfc_current_locus = old_loc; 955 next_char(); 956 c = next_char(); 957 } 958 } 959 gfc_current_locus = old_loc; 960 } 961 } 962 skip_comment_line (); 963 continue; 964 } 965 966 break; 967 } 968 969 if (openmp_flag && at_bol) 970 openmp_flag = 0; 971 972 if (openacc_flag && at_bol) 973 openacc_flag = 0; 974 975 gcc_attribute_flag = 0; 976 gfc_current_locus = start; 977 return false; 978} 979 980/* Return true if MP was matched in fixed form. */ 981static bool 982skip_fixed_omp_sentinel (locus *start) 983{ 984 gfc_char_t c; 985 if (((c = next_char ()) == 'm' || c == 'M') 986 && ((c = next_char ()) == 'p' || c == 'P')) 987 { 988 c = next_char (); 989 if (c != '\n' 990 && (continue_flag 991 || c == ' ' || c == '\t' || c == '0')) 992 { 993 if (c == ' ' || c == '\t' || c == '0') 994 openacc_flag = 0; 995 do 996 c = next_char (); 997 while (gfc_is_whitespace (c)); 998 if (c != '\n' && c != '!') 999 { 1000 /* Canonicalize to *$omp. */ 1001 *start->nextc = '*'; 1002 openmp_flag = 1; 1003 gfc_current_locus = *start; 1004 return true; 1005 } 1006 } 1007 } 1008 return false; 1009} 1010 1011/* Return true if CC was matched in fixed form. */ 1012static bool 1013skip_fixed_oacc_sentinel (locus *start) 1014{ 1015 gfc_char_t c; 1016 if (((c = next_char ()) == 'c' || c == 'C') 1017 && ((c = next_char ()) == 'c' || c == 'C')) 1018 { 1019 c = next_char (); 1020 if (c != '\n' 1021 && (continue_flag 1022 || c == ' ' || c == '\t' || c == '0')) 1023 { 1024 if (c == ' ' || c == '\t' || c == '0') 1025 openmp_flag = 0; 1026 do 1027 c = next_char (); 1028 while (gfc_is_whitespace (c)); 1029 if (c != '\n' && c != '!') 1030 { 1031 /* Canonicalize to *$acc. */ 1032 *start->nextc = '*'; 1033 openacc_flag = 1; 1034 gfc_current_locus = *start; 1035 return true; 1036 } 1037 } 1038 } 1039 return false; 1040} 1041 1042/* Skip comment lines in fixed source mode. We have the same rules as 1043 in skip_free_comment(), except that we can have a 'c', 'C' or '*' 1044 in column 1, and a '!' cannot be in column 6. Also, we deal with 1045 lines with 'd' or 'D' in column 1, if the user requested this. */ 1046 1047static void 1048skip_fixed_comments (void) 1049{ 1050 locus start; 1051 int col; 1052 gfc_char_t c; 1053 1054 if (! gfc_at_bol ()) 1055 { 1056 start = gfc_current_locus; 1057 if (! gfc_at_eof ()) 1058 { 1059 do 1060 c = next_char (); 1061 while (gfc_is_whitespace (c)); 1062 1063 if (c == '\n') 1064 gfc_advance_line (); 1065 else if (c == '!') 1066 skip_comment_line (); 1067 } 1068 1069 if (! gfc_at_bol ()) 1070 { 1071 gfc_current_locus = start; 1072 return; 1073 } 1074 } 1075 1076 for (;;) 1077 { 1078 start = gfc_current_locus; 1079 if (gfc_at_eof ()) 1080 break; 1081 1082 c = next_char (); 1083 if (c == '\n') 1084 { 1085 gfc_advance_line (); 1086 continue; 1087 } 1088 1089 if (c == '!' || c == 'c' || c == 'C' || c == '*') 1090 { 1091 if (skip_gcc_attribute (start)) 1092 { 1093 /* Canonicalize to *$omp. */ 1094 *start.nextc = '*'; 1095 return; 1096 } 1097 1098 if (gfc_current_locus.lb != NULL 1099 && continue_line < gfc_linebuf_linenum (gfc_current_locus.lb)) 1100 continue_line = gfc_linebuf_linenum (gfc_current_locus.lb); 1101 1102 /* If -fopenmp/-fopenacc, we need to handle here 2 things: 1103 1) don't treat !$omp/!$acc|c$omp/c$acc|*$omp / *$acc as comments, 1104 but directives 1105 2) handle OpenMP/OpenACC conditional compilation, where 1106 !$|c$|*$ should be treated as 2 spaces if the characters 1107 in columns 3 to 6 are valid fixed form label columns 1108 characters. */ 1109 if ((flag_openmp || flag_openmp_simd) && !flag_openacc) 1110 { 1111 if (next_char () == '$') 1112 { 1113 c = next_char (); 1114 if (c == 'o' || c == 'O') 1115 { 1116 if (skip_fixed_omp_sentinel (&start)) 1117 return; 1118 } 1119 else 1120 goto check_for_digits; 1121 } 1122 gfc_current_locus = start; 1123 } 1124 else if (flag_openacc && !(flag_openmp || flag_openmp_simd)) 1125 { 1126 if (next_char () == '$') 1127 { 1128 c = next_char (); 1129 if (c == 'a' || c == 'A') 1130 { 1131 if (skip_fixed_oacc_sentinel (&start)) 1132 return; 1133 } 1134 } 1135 gfc_current_locus = start; 1136 } 1137 else if (flag_openacc || flag_openmp || flag_openmp_simd) 1138 { 1139 if (next_char () == '$') 1140 { 1141 c = next_char (); 1142 if (c == 'a' || c == 'A') 1143 { 1144 if (skip_fixed_oacc_sentinel (&start)) 1145 return; 1146 } 1147 else if (c == 'o' || c == 'O') 1148 { 1149 if (skip_fixed_omp_sentinel (&start)) 1150 return; 1151 } 1152 else 1153 goto check_for_digits; 1154 } 1155 gfc_current_locus = start; 1156 } 1157 1158 skip_comment_line (); 1159 continue; 1160 1161check_for_digits: 1162 { 1163 /* Required for OpenMP's conditional compilation sentinel. */ 1164 int digit_seen = 0; 1165 1166 for (col = 3; col < 6; col++, c = next_char ()) 1167 if (c == ' ') 1168 continue; 1169 else if (c == '\t') 1170 { 1171 col = 6; 1172 break; 1173 } 1174 else if (c < '0' || c > '9') 1175 break; 1176 else 1177 digit_seen = 1; 1178 1179 if (col == 6 && c != '\n' 1180 && ((continue_flag && !digit_seen) 1181 || c == ' ' || c == '\t' || c == '0')) 1182 { 1183 gfc_current_locus = start; 1184 start.nextc[0] = ' '; 1185 start.nextc[1] = ' '; 1186 continue; 1187 } 1188 } 1189 skip_comment_line (); 1190 continue; 1191 } 1192 1193 if (gfc_option.flag_d_lines != -1 && (c == 'd' || c == 'D')) 1194 { 1195 if (gfc_option.flag_d_lines == 0) 1196 { 1197 skip_comment_line (); 1198 continue; 1199 } 1200 else 1201 *start.nextc = c = ' '; 1202 } 1203 1204 col = 1; 1205 1206 while (gfc_is_whitespace (c)) 1207 { 1208 c = next_char (); 1209 col++; 1210 } 1211 1212 if (c == '\n') 1213 { 1214 gfc_advance_line (); 1215 continue; 1216 } 1217 1218 if (col != 6 && c == '!') 1219 { 1220 if (gfc_current_locus.lb != NULL 1221 && continue_line < gfc_linebuf_linenum (gfc_current_locus.lb)) 1222 continue_line = gfc_linebuf_linenum (gfc_current_locus.lb); 1223 skip_comment_line (); 1224 continue; 1225 } 1226 1227 break; 1228 } 1229 1230 openmp_flag = 0; 1231 openacc_flag = 0; 1232 gcc_attribute_flag = 0; 1233 gfc_current_locus = start; 1234} 1235 1236 1237/* Skips the current line if it is a comment. */ 1238 1239void 1240gfc_skip_comments (void) 1241{ 1242 if (gfc_current_form == FORM_FREE) 1243 skip_free_comments (); 1244 else 1245 skip_fixed_comments (); 1246} 1247 1248 1249/* Get the next character from the input, taking continuation lines 1250 and end-of-line comments into account. This implies that comment 1251 lines between continued lines must be eaten here. For higher-level 1252 subroutines, this flattens continued lines into a single logical 1253 line. The in_string flag denotes whether we're inside a character 1254 context or not. */ 1255 1256gfc_char_t 1257gfc_next_char_literal (gfc_instring in_string) 1258{ 1259 static locus omp_acc_err_loc = {}; 1260 locus old_loc; 1261 int i, prev_openmp_flag, prev_openacc_flag; 1262 gfc_char_t c; 1263 1264 continue_flag = 0; 1265 prev_openacc_flag = prev_openmp_flag = 0; 1266 1267restart: 1268 c = next_char (); 1269 if (gfc_at_end ()) 1270 { 1271 continue_count = 0; 1272 return c; 1273 } 1274 1275 if (gfc_current_form == FORM_FREE) 1276 { 1277 bool openmp_cond_flag; 1278 1279 if (!in_string && c == '!') 1280 { 1281 if (gcc_attribute_flag 1282 && memcmp (&gfc_current_locus, &gcc_attribute_locus, 1283 sizeof (gfc_current_locus)) == 0) 1284 goto done; 1285 1286 if (openmp_flag 1287 && memcmp (&gfc_current_locus, &openmp_locus, 1288 sizeof (gfc_current_locus)) == 0) 1289 goto done; 1290 1291 if (openacc_flag 1292 && memcmp (&gfc_current_locus, &openacc_locus, 1293 sizeof (gfc_current_locus)) == 0) 1294 goto done; 1295 1296 /* This line can't be continued */ 1297 do 1298 { 1299 c = next_char (); 1300 } 1301 while (c != '\n'); 1302 1303 /* Avoid truncation warnings for comment ending lines. */ 1304 gfc_current_locus.lb->truncated = 0; 1305 1306 goto done; 1307 } 1308 1309 /* Check to see if the continuation line was truncated. */ 1310 if (warn_line_truncation && gfc_current_locus.lb != NULL 1311 && gfc_current_locus.lb->truncated) 1312 { 1313 int maxlen = flag_free_line_length; 1314 gfc_char_t *current_nextc = gfc_current_locus.nextc; 1315 1316 gfc_current_locus.lb->truncated = 0; 1317 gfc_current_locus.nextc = gfc_current_locus.lb->line + maxlen; 1318 gfc_warning_now (OPT_Wline_truncation, 1319 "Line truncated at %L", &gfc_current_locus); 1320 gfc_current_locus.nextc = current_nextc; 1321 } 1322 1323 if (c != '&') 1324 goto done; 1325 1326 /* If the next nonblank character is a ! or \n, we've got a 1327 continuation line. */ 1328 old_loc = gfc_current_locus; 1329 1330 c = next_char (); 1331 while (gfc_is_whitespace (c)) 1332 c = next_char (); 1333 1334 /* Character constants to be continued cannot have commentary 1335 after the '&'. However, there are cases where we may think we 1336 are still in a string and we are looking for a possible 1337 doubled quote and we end up here. See PR64506. */ 1338 1339 if (in_string && c != '\n') 1340 { 1341 gfc_current_locus = old_loc; 1342 c = '&'; 1343 goto done; 1344 } 1345 1346 if (c != '!' && c != '\n') 1347 { 1348 gfc_current_locus = old_loc; 1349 c = '&'; 1350 goto done; 1351 } 1352 1353 if (flag_openmp) 1354 prev_openmp_flag = openmp_flag; 1355 if (flag_openacc) 1356 prev_openacc_flag = openacc_flag; 1357 1358 /* This can happen if the input file changed or via cpp's #line 1359 without getting reset (e.g. via input_stmt). It also happens 1360 when pre-including files via -fpre-include=. */ 1361 if (continue_count == 0 1362 && gfc_current_locus.lb 1363 && continue_line > gfc_linebuf_linenum (gfc_current_locus.lb) + 1) 1364 continue_line = gfc_linebuf_linenum (gfc_current_locus.lb) + 1; 1365 1366 continue_flag = 1; 1367 if (c == '!') 1368 skip_comment_line (); 1369 else 1370 gfc_advance_line (); 1371 1372 if (gfc_at_eof ()) 1373 goto not_continuation; 1374 1375 /* We've got a continuation line. If we are on the very next line after 1376 the last continuation, increment the continuation line count and 1377 check whether the limit has been exceeded. */ 1378 if (gfc_linebuf_linenum (gfc_current_locus.lb) == continue_line + 1) 1379 { 1380 if (++continue_count == gfc_option.max_continue_free) 1381 { 1382 if (gfc_notification_std (GFC_STD_GNU) || pedantic) 1383 gfc_warning (0, "Limit of %d continuations exceeded in " 1384 "statement at %C", gfc_option.max_continue_free); 1385 } 1386 } 1387 1388 /* Now find where it continues. First eat any comment lines. */ 1389 openmp_cond_flag = skip_free_comments (); 1390 1391 if (gfc_current_locus.lb != NULL 1392 && continue_line < gfc_linebuf_linenum (gfc_current_locus.lb)) 1393 continue_line = gfc_linebuf_linenum (gfc_current_locus.lb); 1394 1395 if (flag_openmp) 1396 if (prev_openmp_flag != openmp_flag && !openacc_flag) 1397 { 1398 gfc_current_locus = old_loc; 1399 openmp_flag = prev_openmp_flag; 1400 c = '&'; 1401 goto done; 1402 } 1403 1404 if (flag_openacc) 1405 if (prev_openacc_flag != openacc_flag && !openmp_flag) 1406 { 1407 gfc_current_locus = old_loc; 1408 openacc_flag = prev_openacc_flag; 1409 c = '&'; 1410 goto done; 1411 } 1412 1413 /* Now that we have a non-comment line, probe ahead for the 1414 first non-whitespace character. If it is another '&', then 1415 reading starts at the next character, otherwise we must back 1416 up to where the whitespace started and resume from there. */ 1417 1418 old_loc = gfc_current_locus; 1419 1420 c = next_char (); 1421 while (gfc_is_whitespace (c)) 1422 c = next_char (); 1423 1424 if (openmp_flag && !openacc_flag) 1425 { 1426 for (i = 0; i < 5; i++, c = next_char ()) 1427 { 1428 gcc_assert (gfc_wide_tolower (c) == (unsigned char) "!$omp"[i]); 1429 if (i == 4) 1430 old_loc = gfc_current_locus; 1431 } 1432 while (gfc_is_whitespace (c)) 1433 c = next_char (); 1434 } 1435 if (openacc_flag && !openmp_flag) 1436 { 1437 for (i = 0; i < 5; i++, c = next_char ()) 1438 { 1439 gcc_assert (gfc_wide_tolower (c) == (unsigned char) "!$acc"[i]); 1440 if (i == 4) 1441 old_loc = gfc_current_locus; 1442 } 1443 while (gfc_is_whitespace (c)) 1444 c = next_char (); 1445 } 1446 1447 /* In case we have an OpenMP directive continued by OpenACC 1448 sentinel, or vice versa, we get both openmp_flag and 1449 openacc_flag on. */ 1450 1451 if (openacc_flag && openmp_flag) 1452 { 1453 int is_openmp = 0; 1454 for (i = 0; i < 5; i++, c = next_char ()) 1455 { 1456 if (gfc_wide_tolower (c) != (unsigned char) "!$acc"[i]) 1457 is_openmp = 1; 1458 } 1459 if (omp_acc_err_loc.nextc != gfc_current_locus.nextc 1460 || omp_acc_err_loc.lb != gfc_current_locus.lb) 1461 gfc_error_now (is_openmp 1462 ? G_("Wrong OpenACC continuation at %C: " 1463 "expected !$ACC, got !$OMP") 1464 : G_("Wrong OpenMP continuation at %C: " 1465 "expected !$OMP, got !$ACC")); 1466 omp_acc_err_loc = gfc_current_locus; 1467 goto not_continuation; 1468 } 1469 1470 if (c != '&') 1471 { 1472 if (in_string && gfc_current_locus.nextc) 1473 { 1474 gfc_current_locus.nextc--; 1475 if (warn_ampersand && in_string == INSTRING_WARN) 1476 gfc_warning (OPT_Wampersand, 1477 "Missing %<&%> in continued character " 1478 "constant at %C"); 1479 } 1480 else if (!in_string && (c == '\'' || c == '"')) 1481 goto done; 1482 /* Both !$omp and !$ -fopenmp continuation lines have & on the 1483 continuation line only optionally. */ 1484 else if (openmp_flag || openacc_flag || openmp_cond_flag) 1485 { 1486 if (gfc_current_locus.nextc) 1487 gfc_current_locus.nextc--; 1488 } 1489 else 1490 { 1491 c = ' '; 1492 gfc_current_locus = old_loc; 1493 goto done; 1494 } 1495 } 1496 } 1497 else /* Fixed form. */ 1498 { 1499 /* Fixed form continuation. */ 1500 if (in_string != INSTRING_WARN && c == '!') 1501 { 1502 /* Skip comment at end of line. */ 1503 do 1504 { 1505 c = next_char (); 1506 } 1507 while (c != '\n'); 1508 1509 /* Avoid truncation warnings for comment ending lines. */ 1510 gfc_current_locus.lb->truncated = 0; 1511 } 1512 1513 if (c != '\n') 1514 goto done; 1515 1516 /* Check to see if the continuation line was truncated. */ 1517 if (warn_line_truncation && gfc_current_locus.lb != NULL 1518 && gfc_current_locus.lb->truncated) 1519 { 1520 gfc_current_locus.lb->truncated = 0; 1521 gfc_warning_now (OPT_Wline_truncation, 1522 "Line truncated at %L", &gfc_current_locus); 1523 } 1524 1525 if (flag_openmp) 1526 prev_openmp_flag = openmp_flag; 1527 if (flag_openacc) 1528 prev_openacc_flag = openacc_flag; 1529 1530 /* This can happen if the input file changed or via cpp's #line 1531 without getting reset (e.g. via input_stmt). It also happens 1532 when pre-including files via -fpre-include=. */ 1533 if (continue_count == 0 1534 && gfc_current_locus.lb 1535 && continue_line > gfc_linebuf_linenum (gfc_current_locus.lb) + 1) 1536 continue_line = gfc_linebuf_linenum (gfc_current_locus.lb) + 1; 1537 1538 continue_flag = 1; 1539 old_loc = gfc_current_locus; 1540 1541 gfc_advance_line (); 1542 skip_fixed_comments (); 1543 1544 /* See if this line is a continuation line. */ 1545 if (flag_openmp && openmp_flag != prev_openmp_flag && !openacc_flag) 1546 { 1547 openmp_flag = prev_openmp_flag; 1548 goto not_continuation; 1549 } 1550 if (flag_openacc && openacc_flag != prev_openacc_flag && !openmp_flag) 1551 { 1552 openacc_flag = prev_openacc_flag; 1553 goto not_continuation; 1554 } 1555 1556 /* In case we have an OpenMP directive continued by OpenACC 1557 sentinel, or vice versa, we get both openmp_flag and 1558 openacc_flag on. */ 1559 if (openacc_flag && openmp_flag) 1560 { 1561 int is_openmp = 0; 1562 for (i = 0; i < 5; i++) 1563 { 1564 c = next_char (); 1565 if (gfc_wide_tolower (c) != (unsigned char) "*$acc"[i]) 1566 is_openmp = 1; 1567 } 1568 if (omp_acc_err_loc.nextc != gfc_current_locus.nextc 1569 || omp_acc_err_loc.lb != gfc_current_locus.lb) 1570 gfc_error_now (is_openmp 1571 ? G_("Wrong OpenACC continuation at %C: " 1572 "expected !$ACC, got !$OMP") 1573 : G_("Wrong OpenMP continuation at %C: " 1574 "expected !$OMP, got !$ACC")); 1575 omp_acc_err_loc = gfc_current_locus; 1576 goto not_continuation; 1577 } 1578 else if (!openmp_flag && !openacc_flag) 1579 for (i = 0; i < 5; i++) 1580 { 1581 c = next_char (); 1582 if (c != ' ') 1583 goto not_continuation; 1584 } 1585 else if (openmp_flag) 1586 for (i = 0; i < 5; i++) 1587 { 1588 c = next_char (); 1589 if (gfc_wide_tolower (c) != (unsigned char) "*$omp"[i]) 1590 goto not_continuation; 1591 } 1592 else if (openacc_flag) 1593 for (i = 0; i < 5; i++) 1594 { 1595 c = next_char (); 1596 if (gfc_wide_tolower (c) != (unsigned char) "*$acc"[i]) 1597 goto not_continuation; 1598 } 1599 1600 c = next_char (); 1601 if (c == '0' || c == ' ' || c == '\n') 1602 goto not_continuation; 1603 1604 /* We've got a continuation line. If we are on the very next line after 1605 the last continuation, increment the continuation line count and 1606 check whether the limit has been exceeded. */ 1607 if (gfc_linebuf_linenum (gfc_current_locus.lb) == continue_line + 1) 1608 { 1609 if (++continue_count == gfc_option.max_continue_fixed) 1610 { 1611 if (gfc_notification_std (GFC_STD_GNU) || pedantic) 1612 gfc_warning (0, "Limit of %d continuations exceeded in " 1613 "statement at %C", 1614 gfc_option.max_continue_fixed); 1615 } 1616 } 1617 1618 if (gfc_current_locus.lb != NULL 1619 && continue_line < gfc_linebuf_linenum (gfc_current_locus.lb)) 1620 continue_line = gfc_linebuf_linenum (gfc_current_locus.lb); 1621 } 1622 1623 /* Ready to read first character of continuation line, which might 1624 be another continuation line! */ 1625 goto restart; 1626 1627not_continuation: 1628 c = '\n'; 1629 gfc_current_locus = old_loc; 1630 end_flag = 0; 1631 1632done: 1633 if (c == '\n') 1634 continue_count = 0; 1635 continue_flag = 0; 1636 return c; 1637} 1638 1639 1640/* Get the next character of input, folded to lowercase. In fixed 1641 form mode, we also ignore spaces. When matcher subroutines are 1642 parsing character literals, they have to call 1643 gfc_next_char_literal(). */ 1644 1645gfc_char_t 1646gfc_next_char (void) 1647{ 1648 gfc_char_t c; 1649 1650 do 1651 { 1652 c = gfc_next_char_literal (NONSTRING); 1653 } 1654 while (gfc_current_form == FORM_FIXED && gfc_is_whitespace (c)); 1655 1656 return gfc_wide_tolower (c); 1657} 1658 1659char 1660gfc_next_ascii_char (void) 1661{ 1662 gfc_char_t c = gfc_next_char (); 1663 1664 return (gfc_wide_fits_in_byte (c) ? (unsigned char) c 1665 : (unsigned char) UCHAR_MAX); 1666} 1667 1668 1669gfc_char_t 1670gfc_peek_char (void) 1671{ 1672 locus old_loc; 1673 gfc_char_t c; 1674 1675 old_loc = gfc_current_locus; 1676 c = gfc_next_char (); 1677 gfc_current_locus = old_loc; 1678 1679 return c; 1680} 1681 1682 1683char 1684gfc_peek_ascii_char (void) 1685{ 1686 gfc_char_t c = gfc_peek_char (); 1687 1688 return (gfc_wide_fits_in_byte (c) ? (unsigned char) c 1689 : (unsigned char) UCHAR_MAX); 1690} 1691 1692 1693/* Recover from an error. We try to get past the current statement 1694 and get lined up for the next. The next statement follows a '\n' 1695 or a ';'. We also assume that we are not within a character 1696 constant, and deal with finding a '\'' or '"'. */ 1697 1698void 1699gfc_error_recovery (void) 1700{ 1701 gfc_char_t c, delim; 1702 1703 if (gfc_at_eof ()) 1704 return; 1705 1706 for (;;) 1707 { 1708 c = gfc_next_char (); 1709 if (c == '\n' || c == ';') 1710 break; 1711 1712 if (c != '\'' && c != '"') 1713 { 1714 if (gfc_at_eof ()) 1715 break; 1716 continue; 1717 } 1718 delim = c; 1719 1720 for (;;) 1721 { 1722 c = next_char (); 1723 1724 if (c == delim) 1725 break; 1726 if (c == '\n') 1727 return; 1728 if (c == '\\') 1729 { 1730 c = next_char (); 1731 if (c == '\n') 1732 return; 1733 } 1734 } 1735 if (gfc_at_eof ()) 1736 break; 1737 } 1738} 1739 1740 1741/* Read ahead until the next character to be read is not whitespace. */ 1742 1743void 1744gfc_gobble_whitespace (void) 1745{ 1746 static int linenum = 0; 1747 locus old_loc; 1748 gfc_char_t c; 1749 1750 do 1751 { 1752 old_loc = gfc_current_locus; 1753 c = gfc_next_char_literal (NONSTRING); 1754 /* Issue a warning for nonconforming tabs. We keep track of the line 1755 number because the Fortran matchers will often back up and the same 1756 line will be scanned multiple times. */ 1757 if (warn_tabs && c == '\t') 1758 { 1759 int cur_linenum = LOCATION_LINE (gfc_current_locus.lb->location); 1760 if (cur_linenum != linenum) 1761 { 1762 linenum = cur_linenum; 1763 gfc_warning_now (OPT_Wtabs, "Nonconforming tab character at %C"); 1764 } 1765 } 1766 } 1767 while (gfc_is_whitespace (c)); 1768 1769 if (!ISPRINT(c) && c != '\n' && last_error_char != gfc_current_locus.nextc) 1770 { 1771 char buf[20]; 1772 last_error_char = gfc_current_locus.nextc; 1773 snprintf (buf, 20, "%2.2X", c); 1774 gfc_error_now ("Invalid character 0x%s at %C", buf); 1775 } 1776 1777 gfc_current_locus = old_loc; 1778} 1779 1780 1781/* Load a single line into pbuf. 1782 1783 If pbuf points to a NULL pointer, it is allocated. 1784 We truncate lines that are too long, unless we're dealing with 1785 preprocessor lines or if the option -ffixed-line-length-none is set, 1786 in which case we reallocate the buffer to fit the entire line, if 1787 need be. 1788 In fixed mode, we expand a tab that occurs within the statement 1789 label region to expand to spaces that leave the next character in 1790 the source region. 1791 1792 If first_char is not NULL, it's a pointer to a single char value holding 1793 the first character of the line, which has already been read by the 1794 caller. This avoids the use of ungetc(). 1795 1796 load_line returns whether the line was truncated. 1797 1798 NOTE: The error machinery isn't available at this point, so we can't 1799 easily report line and column numbers consistent with other 1800 parts of gfortran. */ 1801 1802static int 1803load_line (FILE *input, gfc_char_t **pbuf, int *pbuflen, const int *first_char) 1804{ 1805 int c, maxlen, i, preprocessor_flag, buflen = *pbuflen; 1806 int quoted = ' ', comment_ix = -1; 1807 bool seen_comment = false; 1808 bool first_comment = true; 1809 bool trunc_flag = false; 1810 bool seen_printable = false; 1811 bool seen_ampersand = false; 1812 bool found_tab = false; 1813 bool warned_tabs = false; 1814 gfc_char_t *buffer; 1815 1816 /* Determine the maximum allowed line length. */ 1817 if (gfc_current_form == FORM_FREE) 1818 maxlen = flag_free_line_length; 1819 else if (gfc_current_form == FORM_FIXED) 1820 maxlen = flag_fixed_line_length; 1821 else 1822 maxlen = 72; 1823 1824 if (*pbuf == NULL) 1825 { 1826 /* Allocate the line buffer, storing its length into buflen. 1827 Note that if maxlen==0, indicating that arbitrary-length lines 1828 are allowed, the buffer will be reallocated if this length is 1829 insufficient; since 132 characters is the length of a standard 1830 free-form line, we use that as a starting guess. */ 1831 if (maxlen > 0) 1832 buflen = maxlen; 1833 else 1834 buflen = 132; 1835 1836 *pbuf = gfc_get_wide_string (buflen + 1); 1837 } 1838 1839 i = 0; 1840 buffer = *pbuf; 1841 1842 if (first_char) 1843 c = *first_char; 1844 else 1845 c = getc (input); 1846 1847 /* In order to not truncate preprocessor lines, we have to 1848 remember that this is one. */ 1849 preprocessor_flag = (c == '#'); 1850 1851 for (;;) 1852 { 1853 if (c == EOF) 1854 break; 1855 1856 if (c == '\n') 1857 { 1858 /* Check for illegal use of ampersand. See F95 Standard 3.3.1.3. */ 1859 if (gfc_current_form == FORM_FREE 1860 && !seen_printable && seen_ampersand) 1861 { 1862 if (pedantic) 1863 gfc_error_now ("%<&%> not allowed by itself in line %d", 1864 current_file->line); 1865 else 1866 gfc_warning_now (0, "%<&%> not allowed by itself in line %d", 1867 current_file->line); 1868 } 1869 break; 1870 } 1871 1872 if (c == '\r' || c == '\0') 1873 goto next_char; /* Gobble characters. */ 1874 1875 if (c == '&') 1876 { 1877 if (seen_ampersand) 1878 { 1879 seen_ampersand = false; 1880 seen_printable = true; 1881 } 1882 else 1883 seen_ampersand = true; 1884 } 1885 1886 if ((c != '&' && c != '!' && c != ' ') || (c == '!' && !seen_ampersand)) 1887 seen_printable = true; 1888 1889 /* Is this a fixed-form comment? */ 1890 if (gfc_current_form == FORM_FIXED && i == 0 1891 && (c == '*' || c == 'c' || c == 'C' 1892 || (gfc_option.flag_d_lines != -1 && (c == 'd' || c == 'D')))) 1893 { 1894 seen_comment = true; 1895 comment_ix = i; 1896 } 1897 1898 if (quoted == ' ') 1899 { 1900 if (c == '\'' || c == '"') 1901 quoted = c; 1902 } 1903 else if (c == quoted) 1904 quoted = ' '; 1905 1906 /* Is this a free-form comment? */ 1907 if (c == '!' && quoted == ' ') 1908 { 1909 if (seen_comment) 1910 first_comment = false; 1911 seen_comment = true; 1912 comment_ix = i; 1913 } 1914 1915 /* For truncation and tab warnings, set seen_comment to false if one has 1916 either an OpenMP or OpenACC directive - or a !GCC$ attribute. If 1917 OpenMP is enabled, use '!$' as conditional compilation sentinel 1918 and OpenMP directive ('!$omp'). */ 1919 if (seen_comment && first_comment && flag_openmp && comment_ix + 1 == i 1920 && c == '$') 1921 first_comment = seen_comment = false; 1922 if (seen_comment && first_comment && comment_ix + 4 == i) 1923 { 1924 if (((*pbuf)[comment_ix+1] == 'g' || (*pbuf)[comment_ix+1] == 'G') 1925 && ((*pbuf)[comment_ix+2] == 'c' || (*pbuf)[comment_ix+2] == 'C') 1926 && ((*pbuf)[comment_ix+3] == 'c' || (*pbuf)[comment_ix+3] == 'C') 1927 && c == '$') 1928 first_comment = seen_comment = false; 1929 if (flag_openacc 1930 && (*pbuf)[comment_ix+1] == '$' 1931 && ((*pbuf)[comment_ix+2] == 'a' || (*pbuf)[comment_ix+2] == 'A') 1932 && ((*pbuf)[comment_ix+3] == 'c' || (*pbuf)[comment_ix+3] == 'C') 1933 && (c == 'c' || c == 'C')) 1934 first_comment = seen_comment = false; 1935 } 1936 1937 /* Vendor extension: "<tab>1" marks a continuation line. */ 1938 if (found_tab) 1939 { 1940 found_tab = false; 1941 if (c >= '1' && c <= '9') 1942 { 1943 *(buffer-1) = c; 1944 goto next_char; 1945 } 1946 } 1947 1948 if (gfc_current_form == FORM_FIXED && c == '\t' && i < 6) 1949 { 1950 found_tab = true; 1951 1952 if (warn_tabs && seen_comment == 0 && !warned_tabs) 1953 { 1954 warned_tabs = true; 1955 gfc_warning_now (OPT_Wtabs, 1956 "Nonconforming tab character in column %d " 1957 "of line %d", i + 1, current_file->line); 1958 } 1959 1960 while (i < 6) 1961 { 1962 *buffer++ = ' '; 1963 i++; 1964 } 1965 1966 goto next_char; 1967 } 1968 1969 *buffer++ = c; 1970 i++; 1971 1972 if (maxlen == 0 || preprocessor_flag) 1973 { 1974 if (i >= buflen) 1975 { 1976 /* Reallocate line buffer to double size to hold the 1977 overlong line. */ 1978 buflen = buflen * 2; 1979 *pbuf = XRESIZEVEC (gfc_char_t, *pbuf, (buflen + 1)); 1980 buffer = (*pbuf) + i; 1981 } 1982 } 1983 else if (i >= maxlen) 1984 { 1985 bool trunc_warn = true; 1986 1987 /* Enhancement, if the very next non-space character is an ampersand 1988 or comment that we would otherwise warn about, don't mark as 1989 truncated. */ 1990 1991 /* Truncate the rest of the line. */ 1992 for (;;) 1993 { 1994 c = getc (input); 1995 if (c == '\r' || c == ' ') 1996 continue; 1997 1998 if (c == '\n' || c == EOF) 1999 break; 2000 2001 if (!trunc_warn && c != '!') 2002 trunc_warn = true; 2003 2004 if (trunc_warn && ((gfc_current_form == FORM_FIXED && c == '&') 2005 || c == '!')) 2006 trunc_warn = false; 2007 2008 if (c == '!') 2009 seen_comment = 1; 2010 2011 if (trunc_warn && !seen_comment) 2012 trunc_flag = 1; 2013 } 2014 2015 c = '\n'; 2016 continue; 2017 } 2018 2019next_char: 2020 c = getc (input); 2021 } 2022 2023 /* Pad lines to the selected line length in fixed form. */ 2024 if (gfc_current_form == FORM_FIXED 2025 && flag_fixed_line_length != 0 2026 && flag_pad_source 2027 && !preprocessor_flag 2028 && c != EOF) 2029 { 2030 while (i++ < maxlen) 2031 *buffer++ = ' '; 2032 } 2033 2034 *buffer = '\0'; 2035 *pbuflen = buflen; 2036 2037 return trunc_flag; 2038} 2039 2040 2041/* Get a gfc_file structure, initialize it and add it to 2042 the file stack. */ 2043 2044static gfc_file * 2045get_file (const char *name, enum lc_reason reason) 2046{ 2047 gfc_file *f; 2048 2049 f = XCNEW (gfc_file); 2050 2051 f->filename = xstrdup (name); 2052 2053 f->next = file_head; 2054 file_head = f; 2055 2056 f->up = current_file; 2057 if (current_file != NULL) 2058 f->inclusion_line = current_file->line; 2059 2060 linemap_add (line_table, reason, false, f->filename, 1); 2061 2062 return f; 2063} 2064 2065 2066/* Deal with a line from the C preprocessor. The 2067 initial octothorp has already been seen. */ 2068 2069static void 2070preprocessor_line (gfc_char_t *c) 2071{ 2072 bool flag[5]; 2073 int i, line; 2074 gfc_char_t *wide_filename; 2075 gfc_file *f; 2076 int escaped, unescape; 2077 char *filename; 2078 2079 c++; 2080 while (*c == ' ' || *c == '\t') 2081 c++; 2082 2083 if (*c < '0' || *c > '9') 2084 goto bad_cpp_line; 2085 2086 line = wide_atoi (c); 2087 2088 c = wide_strchr (c, ' '); 2089 if (c == NULL) 2090 { 2091 /* No file name given. Set new line number. */ 2092 current_file->line = line; 2093 return; 2094 } 2095 2096 /* Skip spaces. */ 2097 while (*c == ' ' || *c == '\t') 2098 c++; 2099 2100 /* Skip quote. */ 2101 if (*c != '"') 2102 goto bad_cpp_line; 2103 ++c; 2104 2105 wide_filename = c; 2106 2107 /* Make filename end at quote. */ 2108 unescape = 0; 2109 escaped = false; 2110 while (*c && ! (!escaped && *c == '"')) 2111 { 2112 if (escaped) 2113 escaped = false; 2114 else if (*c == '\\') 2115 { 2116 escaped = true; 2117 unescape++; 2118 } 2119 ++c; 2120 } 2121 2122 if (! *c) 2123 /* Preprocessor line has no closing quote. */ 2124 goto bad_cpp_line; 2125 2126 *c++ = '\0'; 2127 2128 /* Undo effects of cpp_quote_string. */ 2129 if (unescape) 2130 { 2131 gfc_char_t *s = wide_filename; 2132 gfc_char_t *d = gfc_get_wide_string (c - wide_filename - unescape); 2133 2134 wide_filename = d; 2135 while (*s) 2136 { 2137 if (*s == '\\') 2138 *d++ = *++s; 2139 else 2140 *d++ = *s; 2141 s++; 2142 } 2143 *d = '\0'; 2144 } 2145 2146 /* Get flags. */ 2147 2148 flag[1] = flag[2] = flag[3] = flag[4] = false; 2149 2150 for (;;) 2151 { 2152 c = wide_strchr (c, ' '); 2153 if (c == NULL) 2154 break; 2155 2156 c++; 2157 i = wide_atoi (c); 2158 2159 if (i >= 1 && i <= 4) 2160 flag[i] = true; 2161 } 2162 2163 /* Convert the filename in wide characters into a filename in narrow 2164 characters. */ 2165 filename = gfc_widechar_to_char (wide_filename, -1); 2166 2167 /* Interpret flags. */ 2168 2169 if (flag[1]) /* Starting new file. */ 2170 { 2171 f = get_file (filename, LC_RENAME); 2172 add_file_change (f->filename, f->inclusion_line); 2173 current_file = f; 2174 } 2175 2176 if (flag[2]) /* Ending current file. */ 2177 { 2178 if (!current_file->up 2179 || filename_cmp (current_file->up->filename, filename) != 0) 2180 { 2181 linemap_line_start (line_table, current_file->line, 80); 2182 /* ??? One could compute the exact column where the filename 2183 starts and compute the exact location here. */ 2184 gfc_warning_now_at (linemap_position_for_column (line_table, 1), 2185 0, "file %qs left but not entered", 2186 filename); 2187 current_file->line++; 2188 if (unescape) 2189 free (wide_filename); 2190 free (filename); 2191 return; 2192 } 2193 2194 add_file_change (NULL, line); 2195 current_file = current_file->up; 2196 linemap_add (line_table, LC_RENAME, false, current_file->filename, 2197 current_file->line); 2198 } 2199 2200 /* The name of the file can be a temporary file produced by 2201 cpp. Replace the name if it is different. */ 2202 2203 if (filename_cmp (current_file->filename, filename) != 0) 2204 { 2205 /* FIXME: we leak the old filename because a pointer to it may be stored 2206 in the linemap. Alternative could be using GC or updating linemap to 2207 point to the new name, but there is no API for that currently. */ 2208 current_file->filename = xstrdup (filename); 2209 2210 /* We need to tell the linemap API that the filename changed. Just 2211 changing current_file is insufficient. */ 2212 linemap_add (line_table, LC_RENAME, false, current_file->filename, line); 2213 } 2214 2215 /* Set new line number. */ 2216 current_file->line = line; 2217 if (unescape) 2218 free (wide_filename); 2219 free (filename); 2220 return; 2221 2222 bad_cpp_line: 2223 linemap_line_start (line_table, current_file->line, 80); 2224 /* ??? One could compute the exact column where the directive 2225 starts and compute the exact location here. */ 2226 gfc_warning_now_at (linemap_position_for_column (line_table, 2), 0, 2227 "Illegal preprocessor directive"); 2228 current_file->line++; 2229} 2230 2231 2232static void load_file (const char *, const char *, bool); 2233 2234/* include_line()-- Checks a line buffer to see if it is an include 2235 line. If so, we call load_file() recursively to load the included 2236 file. We never return a syntax error because a statement like 2237 "include = 5" is perfectly legal. We return 0 if no include was 2238 processed, 1 if we matched an include or -1 if include was 2239 partially processed, but will need continuation lines. */ 2240 2241static int 2242include_line (gfc_char_t *line) 2243{ 2244 gfc_char_t quote, *c, *begin, *stop; 2245 char *filename; 2246 const char *include = "include"; 2247 bool allow_continuation = flag_dec_include; 2248 int i; 2249 2250 c = line; 2251 2252 if (flag_openmp || flag_openmp_simd) 2253 { 2254 if (gfc_current_form == FORM_FREE) 2255 { 2256 while (*c == ' ' || *c == '\t') 2257 c++; 2258 if (*c == '!' && c[1] == '$' && (c[2] == ' ' || c[2] == '\t')) 2259 c += 3; 2260 } 2261 else 2262 { 2263 if ((*c == '!' || *c == 'c' || *c == 'C' || *c == '*') 2264 && c[1] == '$' && c[2] == ' ') 2265 c += 3; 2266 } 2267 } 2268 2269 if (gfc_current_form == FORM_FREE) 2270 { 2271 while (*c == ' ' || *c == '\t') 2272 c++; 2273 if (gfc_wide_strncasecmp (c, "include", 7)) 2274 { 2275 if (!allow_continuation) 2276 return 0; 2277 for (i = 0; i < 7; ++i) 2278 { 2279 gfc_char_t c1 = gfc_wide_tolower (*c); 2280 if (c1 != (unsigned char) include[i]) 2281 break; 2282 c++; 2283 } 2284 if (i == 0 || *c != '&') 2285 return 0; 2286 c++; 2287 while (*c == ' ' || *c == '\t') 2288 c++; 2289 if (*c == '\0' || *c == '!') 2290 return -1; 2291 return 0; 2292 } 2293 2294 c += 7; 2295 } 2296 else 2297 { 2298 while (*c == ' ' || *c == '\t') 2299 c++; 2300 if (flag_dec_include && *c == '0' && c - line == 5) 2301 { 2302 c++; 2303 while (*c == ' ' || *c == '\t') 2304 c++; 2305 } 2306 if (c - line < 6) 2307 allow_continuation = false; 2308 for (i = 0; i < 7; ++i) 2309 { 2310 gfc_char_t c1 = gfc_wide_tolower (*c); 2311 if (c1 != (unsigned char) include[i]) 2312 break; 2313 c++; 2314 while (*c == ' ' || *c == '\t') 2315 c++; 2316 } 2317 if (!allow_continuation) 2318 { 2319 if (i != 7) 2320 return 0; 2321 } 2322 else if (i != 7) 2323 { 2324 if (i == 0) 2325 return 0; 2326 2327 /* At the end of line or comment this might be continued. */ 2328 if (*c == '\0' || *c == '!') 2329 return -1; 2330 2331 return 0; 2332 } 2333 } 2334 2335 while (*c == ' ' || *c == '\t') 2336 c++; 2337 2338 /* Find filename between quotes. */ 2339 2340 quote = *c++; 2341 if (quote != '"' && quote != '\'') 2342 { 2343 if (allow_continuation) 2344 { 2345 if (gfc_current_form == FORM_FREE) 2346 { 2347 if (quote == '&') 2348 { 2349 while (*c == ' ' || *c == '\t') 2350 c++; 2351 if (*c == '\0' || *c == '!') 2352 return -1; 2353 } 2354 } 2355 else if (quote == '\0' || quote == '!') 2356 return -1; 2357 } 2358 return 0; 2359 } 2360 2361 begin = c; 2362 2363 bool cont = false; 2364 while (*c != quote && *c != '\0') 2365 { 2366 if (allow_continuation && gfc_current_form == FORM_FREE) 2367 { 2368 if (*c == '&') 2369 cont = true; 2370 else if (*c != ' ' && *c != '\t') 2371 cont = false; 2372 } 2373 c++; 2374 } 2375 2376 if (*c == '\0') 2377 { 2378 if (allow_continuation 2379 && (cont || gfc_current_form != FORM_FREE)) 2380 return -1; 2381 return 0; 2382 } 2383 2384 stop = c++; 2385 2386 while (*c == ' ' || *c == '\t') 2387 c++; 2388 2389 if (*c != '\0' && *c != '!') 2390 return 0; 2391 2392 /* We have an include line at this point. */ 2393 2394 *stop = '\0'; /* It's ok to trash the buffer, as this line won't be 2395 read by anything else. */ 2396 2397 filename = gfc_widechar_to_char (begin, -1); 2398 load_file (filename, NULL, false); 2399 free (filename); 2400 return 1; 2401} 2402 2403/* Similarly, but try to parse an INCLUDE statement, using gfc_next_char etc. 2404 APIs. Return 1 if recognized as valid INCLUDE statement and load_file has 2405 been called, 0 if it is not a valid INCLUDE statement and -1 if eof has 2406 been encountered while parsing it. */ 2407static int 2408include_stmt (gfc_linebuf *b) 2409{ 2410 int ret = 0, i, length; 2411 const char *include = "include"; 2412 gfc_char_t c, quote = 0; 2413 locus str_locus; 2414 char *filename; 2415 2416 continue_flag = 0; 2417 end_flag = 0; 2418 gcc_attribute_flag = 0; 2419 openmp_flag = 0; 2420 openacc_flag = 0; 2421 continue_count = 0; 2422 continue_line = 0; 2423 gfc_current_locus.lb = b; 2424 gfc_current_locus.nextc = b->line; 2425 2426 gfc_skip_comments (); 2427 gfc_gobble_whitespace (); 2428 2429 for (i = 0; i < 7; i++) 2430 { 2431 c = gfc_next_char (); 2432 if (c != (unsigned char) include[i]) 2433 { 2434 if (gfc_current_form == FORM_FIXED 2435 && i == 0 2436 && c == '0' 2437 && gfc_current_locus.nextc == b->line + 6) 2438 { 2439 gfc_gobble_whitespace (); 2440 i--; 2441 continue; 2442 } 2443 gcc_assert (i != 0); 2444 if (c == '\n') 2445 { 2446 gfc_advance_line (); 2447 gfc_skip_comments (); 2448 if (gfc_at_eof ()) 2449 ret = -1; 2450 } 2451 goto do_ret; 2452 } 2453 } 2454 gfc_gobble_whitespace (); 2455 2456 c = gfc_next_char (); 2457 if (c == '\'' || c == '"') 2458 quote = c; 2459 else 2460 { 2461 if (c == '\n') 2462 { 2463 gfc_advance_line (); 2464 gfc_skip_comments (); 2465 if (gfc_at_eof ()) 2466 ret = -1; 2467 } 2468 goto do_ret; 2469 } 2470 2471 str_locus = gfc_current_locus; 2472 length = 0; 2473 do 2474 { 2475 c = gfc_next_char_literal (INSTRING_NOWARN); 2476 if (c == quote) 2477 break; 2478 if (c == '\n') 2479 { 2480 gfc_advance_line (); 2481 gfc_skip_comments (); 2482 if (gfc_at_eof ()) 2483 ret = -1; 2484 goto do_ret; 2485 } 2486 length++; 2487 } 2488 while (1); 2489 2490 gfc_gobble_whitespace (); 2491 c = gfc_next_char (); 2492 if (c != '\n') 2493 goto do_ret; 2494 2495 gfc_current_locus = str_locus; 2496 ret = 1; 2497 filename = XNEWVEC (char, length + 1); 2498 for (i = 0; i < length; i++) 2499 { 2500 c = gfc_next_char_literal (INSTRING_WARN); 2501 gcc_assert (gfc_wide_fits_in_byte (c)); 2502 filename[i] = (unsigned char) c; 2503 } 2504 filename[length] = '\0'; 2505 load_file (filename, NULL, false); 2506 free (filename); 2507 2508do_ret: 2509 continue_flag = 0; 2510 end_flag = 0; 2511 gcc_attribute_flag = 0; 2512 openmp_flag = 0; 2513 openacc_flag = 0; 2514 continue_count = 0; 2515 continue_line = 0; 2516 memset (&gfc_current_locus, '\0', sizeof (locus)); 2517 memset (&openmp_locus, '\0', sizeof (locus)); 2518 memset (&openacc_locus, '\0', sizeof (locus)); 2519 memset (&gcc_attribute_locus, '\0', sizeof (locus)); 2520 return ret; 2521} 2522 2523 2524 2525/* Load a file into memory by calling load_line until the file ends. */ 2526 2527static void 2528load_file (const char *realfilename, const char *displayedname, bool initial) 2529{ 2530 gfc_char_t *line; 2531 gfc_linebuf *b, *include_b = NULL; 2532 gfc_file *f; 2533 FILE *input; 2534 int len, line_len; 2535 bool first_line; 2536 struct stat st; 2537 int stat_result; 2538 const char *filename; 2539 /* If realfilename and displayedname are different and non-null then 2540 surely realfilename is the preprocessed form of 2541 displayedname. */ 2542 bool preprocessed_p = (realfilename && displayedname 2543 && strcmp (realfilename, displayedname)); 2544 2545 filename = displayedname ? displayedname : realfilename; 2546 2547 for (f = current_file; f; f = f->up) 2548 if (filename_cmp (filename, f->filename) == 0) 2549 fatal_error (linemap_line_start (line_table, current_file->line, 0), 2550 "File %qs is being included recursively", filename); 2551 if (initial) 2552 { 2553 if (gfc_src_file) 2554 { 2555 input = gfc_src_file; 2556 gfc_src_file = NULL; 2557 } 2558 else 2559 input = gfc_open_file (realfilename); 2560 2561 if (input == NULL) 2562 gfc_fatal_error ("Cannot open file %qs", filename); 2563 } 2564 else 2565 { 2566 input = gfc_open_included_file (realfilename, false, false); 2567 if (input == NULL) 2568 { 2569 /* For -fpre-include file, current_file is NULL. */ 2570 if (current_file) 2571 fatal_error (linemap_line_start (line_table, current_file->line, 0), 2572 "Cannot open included file %qs", filename); 2573 else 2574 gfc_fatal_error ("Cannot open pre-included file %qs", filename); 2575 } 2576 stat_result = stat (realfilename, &st); 2577 if (stat_result == 0 && !S_ISREG (st.st_mode)) 2578 { 2579 fclose (input); 2580 if (current_file) 2581 fatal_error (linemap_line_start (line_table, current_file->line, 0), 2582 "Included file %qs is not a regular file", filename); 2583 else 2584 gfc_fatal_error ("Included file %qs is not a regular file", filename); 2585 } 2586 } 2587 2588 /* Load the file. 2589 2590 A "non-initial" file means a file that is being included. In 2591 that case we are creating an LC_ENTER map. 2592 2593 An "initial" file means a main file; one that is not included. 2594 That file has already got at least one (surely more) line map(s) 2595 created by gfc_init. So the subsequent map created in that case 2596 must have LC_RENAME reason. 2597 2598 This latter case is not true for a preprocessed file. In that 2599 case, although the file is "initial", the line maps created by 2600 gfc_init was used during the preprocessing of the file. Now that 2601 the preprocessing is over and we are being fed the result of that 2602 preprocessing, we need to create a brand new line map for the 2603 preprocessed file, so the reason is going to be LC_ENTER. */ 2604 2605 f = get_file (filename, (initial && !preprocessed_p) ? LC_RENAME : LC_ENTER); 2606 if (!initial) 2607 add_file_change (f->filename, f->inclusion_line); 2608 current_file = f; 2609 current_file->line = 1; 2610 line = NULL; 2611 line_len = 0; 2612 first_line = true; 2613 2614 if (initial && gfc_src_preprocessor_lines[0]) 2615 { 2616 preprocessor_line (gfc_src_preprocessor_lines[0]); 2617 free (gfc_src_preprocessor_lines[0]); 2618 gfc_src_preprocessor_lines[0] = NULL; 2619 if (gfc_src_preprocessor_lines[1]) 2620 { 2621 preprocessor_line (gfc_src_preprocessor_lines[1]); 2622 free (gfc_src_preprocessor_lines[1]); 2623 gfc_src_preprocessor_lines[1] = NULL; 2624 } 2625 } 2626 2627 for (;;) 2628 { 2629 int trunc = load_line (input, &line, &line_len, NULL); 2630 int inc_line; 2631 2632 len = gfc_wide_strlen (line); 2633 if (feof (input) && len == 0) 2634 break; 2635 2636 /* If this is the first line of the file, it can contain a byte 2637 order mark (BOM), which we will ignore: 2638 FF FE is UTF-16 little endian, 2639 FE FF is UTF-16 big endian, 2640 EF BB BF is UTF-8. */ 2641 if (first_line 2642 && ((line_len >= 2 && line[0] == (unsigned char) '\xFF' 2643 && line[1] == (unsigned char) '\xFE') 2644 || (line_len >= 2 && line[0] == (unsigned char) '\xFE' 2645 && line[1] == (unsigned char) '\xFF') 2646 || (line_len >= 3 && line[0] == (unsigned char) '\xEF' 2647 && line[1] == (unsigned char) '\xBB' 2648 && line[2] == (unsigned char) '\xBF'))) 2649 { 2650 int n = line[1] == (unsigned char) '\xBB' ? 3 : 2; 2651 gfc_char_t *new_char = gfc_get_wide_string (line_len); 2652 2653 wide_strcpy (new_char, &line[n]); 2654 free (line); 2655 line = new_char; 2656 len -= n; 2657 } 2658 2659 /* There are three things this line can be: a line of Fortran 2660 source, an include line or a C preprocessor directive. */ 2661 2662 if (line[0] == '#') 2663 { 2664 /* When -g3 is specified, it's possible that we emit #define 2665 and #undef lines, which we need to pass to the middle-end 2666 so that it can emit correct debug info. */ 2667 if (debug_info_level == DINFO_LEVEL_VERBOSE 2668 && (wide_strncmp (line, "#define ", 8) == 0 2669 || wide_strncmp (line, "#undef ", 7) == 0)) 2670 ; 2671 else 2672 { 2673 preprocessor_line (line); 2674 continue; 2675 } 2676 } 2677 2678 /* Preprocessed files have preprocessor lines added before the byte 2679 order mark, so first_line is not about the first line of the file 2680 but the first line that's not a preprocessor line. */ 2681 first_line = false; 2682 2683 inc_line = include_line (line); 2684 if (inc_line > 0) 2685 { 2686 current_file->line++; 2687 continue; 2688 } 2689 2690 /* Add line. */ 2691 2692 b = XCNEWVAR (gfc_linebuf, gfc_linebuf_header_size 2693 + (len + 1) * sizeof (gfc_char_t)); 2694 2695 2696 b->location 2697 = linemap_line_start (line_table, current_file->line++, len); 2698 /* ??? We add the location for the maximum column possible here, 2699 because otherwise if the next call creates a new line-map, it 2700 will not reserve space for any offset. */ 2701 if (len > 0) 2702 linemap_position_for_column (line_table, len); 2703 2704 b->file = current_file; 2705 b->truncated = trunc; 2706 wide_strcpy (b->line, line); 2707 2708 if (line_head == NULL) 2709 line_head = b; 2710 else 2711 line_tail->next = b; 2712 2713 line_tail = b; 2714 2715 while (file_changes_cur < file_changes_count) 2716 file_changes[file_changes_cur++].lb = b; 2717 2718 if (flag_dec_include) 2719 { 2720 if (include_b && b != include_b) 2721 { 2722 int inc_line2 = include_stmt (include_b); 2723 if (inc_line2 == 0) 2724 include_b = NULL; 2725 else if (inc_line2 > 0) 2726 { 2727 do 2728 { 2729 if (gfc_current_form == FORM_FIXED) 2730 { 2731 for (gfc_char_t *p = include_b->line; *p; p++) 2732 *p = ' '; 2733 } 2734 else 2735 include_b->line[0] = '\0'; 2736 if (include_b == b) 2737 break; 2738 include_b = include_b->next; 2739 } 2740 while (1); 2741 include_b = NULL; 2742 } 2743 } 2744 if (inc_line == -1 && !include_b) 2745 include_b = b; 2746 } 2747 } 2748 2749 /* Release the line buffer allocated in load_line. */ 2750 free (line); 2751 2752 fclose (input); 2753 2754 if (!initial) 2755 add_file_change (NULL, current_file->inclusion_line + 1); 2756 current_file = current_file->up; 2757 linemap_add (line_table, LC_LEAVE, 0, NULL, 0); 2758} 2759 2760 2761/* Open a new file and start scanning from that file. Returns true 2762 if everything went OK, false otherwise. If form == FORM_UNKNOWN 2763 it tries to determine the source form from the filename, defaulting 2764 to free form. */ 2765 2766void 2767gfc_new_file (void) 2768{ 2769 if (flag_pre_include != NULL) 2770 load_file (flag_pre_include, NULL, false); 2771 2772 if (gfc_cpp_enabled ()) 2773 { 2774 gfc_cpp_preprocess (gfc_source_file); 2775 if (!gfc_cpp_preprocess_only ()) 2776 load_file (gfc_cpp_temporary_file (), gfc_source_file, true); 2777 } 2778 else 2779 load_file (gfc_source_file, NULL, true); 2780 2781 gfc_current_locus.lb = line_head; 2782 gfc_current_locus.nextc = (line_head == NULL) ? NULL : line_head->line; 2783 2784#if 0 /* Debugging aid. */ 2785 for (; line_head; line_head = line_head->next) 2786 printf ("%s:%3d %s\n", LOCATION_FILE (line_head->location), 2787 LOCATION_LINE (line_head->location), line_head->line); 2788 2789 exit (SUCCESS_EXIT_CODE); 2790#endif 2791} 2792 2793static char * 2794unescape_filename (const char *ptr) 2795{ 2796 const char *p = ptr, *s; 2797 char *d, *ret; 2798 int escaped, unescape = 0; 2799 2800 /* Make filename end at quote. */ 2801 escaped = false; 2802 while (*p && ! (! escaped && *p == '"')) 2803 { 2804 if (escaped) 2805 escaped = false; 2806 else if (*p == '\\') 2807 { 2808 escaped = true; 2809 unescape++; 2810 } 2811 ++p; 2812 } 2813 2814 if (!*p || p[1]) 2815 return NULL; 2816 2817 /* Undo effects of cpp_quote_string. */ 2818 s = ptr; 2819 d = XCNEWVEC (char, p + 1 - ptr - unescape); 2820 ret = d; 2821 2822 while (s != p) 2823 { 2824 if (*s == '\\') 2825 *d++ = *++s; 2826 else 2827 *d++ = *s; 2828 s++; 2829 } 2830 *d = '\0'; 2831 return ret; 2832} 2833 2834/* For preprocessed files, if the first tokens are of the form # NUM. 2835 handle the directives so we know the original file name. */ 2836 2837const char * 2838gfc_read_orig_filename (const char *filename, const char **canon_source_file) 2839{ 2840 int c, len; 2841 char *dirname, *tmp; 2842 2843 gfc_src_file = gfc_open_file (filename); 2844 if (gfc_src_file == NULL) 2845 return NULL; 2846 2847 c = getc (gfc_src_file); 2848 2849 if (c != '#') 2850 return NULL; 2851 2852 len = 0; 2853 load_line (gfc_src_file, &gfc_src_preprocessor_lines[0], &len, &c); 2854 2855 if (wide_strncmp (gfc_src_preprocessor_lines[0], "# 1 \"", 5) != 0) 2856 return NULL; 2857 2858 tmp = gfc_widechar_to_char (&gfc_src_preprocessor_lines[0][5], -1); 2859 filename = unescape_filename (tmp); 2860 free (tmp); 2861 if (filename == NULL) 2862 return NULL; 2863 2864 c = getc (gfc_src_file); 2865 2866 if (c != '#') 2867 return filename; 2868 2869 len = 0; 2870 load_line (gfc_src_file, &gfc_src_preprocessor_lines[1], &len, &c); 2871 2872 if (wide_strncmp (gfc_src_preprocessor_lines[1], "# 1 \"", 5) != 0) 2873 return filename; 2874 2875 tmp = gfc_widechar_to_char (&gfc_src_preprocessor_lines[1][5], -1); 2876 dirname = unescape_filename (tmp); 2877 free (tmp); 2878 if (dirname == NULL) 2879 return filename; 2880 2881 len = strlen (dirname); 2882 if (len < 3 || dirname[len - 1] != '/' || dirname[len - 2] != '/') 2883 { 2884 free (dirname); 2885 return filename; 2886 } 2887 dirname[len - 2] = '\0'; 2888 set_src_pwd (dirname); 2889 2890 if (! IS_ABSOLUTE_PATH (filename)) 2891 { 2892 char *p = XCNEWVEC (char, len + strlen (filename)); 2893 2894 memcpy (p, dirname, len - 2); 2895 p[len - 2] = '/'; 2896 strcpy (p + len - 1, filename); 2897 *canon_source_file = p; 2898 } 2899 2900 free (dirname); 2901 return filename; 2902} 2903