gcc/fortran/scanner.c

   1 /* Character scanner.
   2    Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007
   3    Free Software Foundation, Inc.
   4    Contributed by Andy Vaught
   5
   6 This file is part of GCC.
   7
   8 GCC is free software; you can redistribute it and/or modify it under
   9 the terms of the GNU General Public License as published by the Free
  10 Software Foundation; either version 3, or (at your option) any later
  11 version.
  12
  13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
  14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
  15 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  16 for more details.
  17
  18 You should have received a copy of the GNU General Public License
  19 along with GCC; see the file COPYING3.  If not see
  20 <http://www.gnu.org/licenses/>.  */
  21
  22 /* Set of subroutines to (ultimately) return the next character to the
  23    various matching subroutines.  This file's job is to read files and
  24    build up lines that are parsed by the parser.  This means that we
  25    handle continuation lines and "include" lines.
  26
  27    The first thing the scanner does is to load an entire file into
  28    memory.  We load the entire file into memory for a couple reasons.
  29    The first is that we want to be able to deal with nonseekable input
  30    (pipes, stdin) and there is a lot of backing up involved during
  31    parsing.
  32
  33    The second is that we want to be able to print the locus of errors,
  34    and an error on line 999999 could conflict with something on line
  35    one.  Given nonseekable input, we've got to store the whole thing.
  36
  37    One thing that helps are the column truncation limits that give us
  38    an upper bound on the size of individual lines.  We don't store the
  39    truncated stuff.
  40
  41    From the scanner's viewpoint, the higher level subroutines ask for
  42    new characters and do a lot of jumping backwards.  */
  43
  44 #include "config.h"
  45 #include "system.h"
  46 #include "gfortran.h"
  47 #include "toplev.h"
  48
  49 /* Structure for holding module and include file search path.  */
  50 typedef struct gfc_directorylist
  51 {
  52   char *path;
  53   bool use_for_modules;
  54   struct gfc_directorylist *next;
  55 }
  56 gfc_directorylist;
  57
  58 /* List of include file search directories.  */
  59 static gfc_directorylist *include_dirs, *intrinsic_modules_dirs;
  60
  61 static gfc_file *file_head, *current_file;
  62
  63 static int continue_flag, end_flag, openmp_flag;
  64 static int continue_count, continue_line;
  65 static locus openmp_locus;
  66
  67 gfc_source_form gfc_current_form;
  68 static gfc_linebuf *line_head, *line_tail;
  69
  70 locus gfc_current_locus;
  71 const char *gfc_source_file;
  72 static FILE *gfc_src_file;
  73 static char *gfc_src_preprocessor_lines[2];
  74
  75 extern int pedantic;
  76
  77 /* Main scanner initialization.  */
  78
  79 void
  80 gfc_scanner_init_1 (void)
  81 {
  82   file_head = NULL;
  83   line_head = NULL;
  84   line_tail = NULL;
  85
  86   continue_count = 0;
  87   continue_line = 0;
  88
  89   end_flag = 0;
  90 }
  91
  92
  93 /* Main scanner destructor.  */
  94
  95 void
  96 gfc_scanner_done_1 (void)
  97 {
  98   gfc_linebuf *lb;
  99   gfc_file *f;
 100
 101   while(line_head != NULL)
 102     {
 103       lb = line_head->next;
 104       gfc_free(line_head);
 105       line_head = lb;
 106     }
 107
 108   while(file_head != NULL)
 109     {
 110       f = file_head->next;
 111       gfc_free(file_head->filename);
 112       gfc_free(file_head);
 113       file_head = f;
 114     }
 115 }
 116
 117
 118 /* Adds path to the list pointed to by list.  */
 119
 120 static void
 121 add_path_to_list (gfc_directorylist **list, const char *path,
 122                   bool use_for_modules)
 123 {
 124   gfc_directorylist *dir;
 125   const char *p;
 126
 127   p = path;
 128   while (*p == ' ' || *p == '\t')  /* someone might do "-I include" */
 129     if (*p++ == '\0')
 130       return;
 131
 132   dir = *list;
 133   if (!dir)
 134     dir = *list = gfc_getmem (sizeof (gfc_directorylist));
 135   else
 136     {
 137       while (dir->next)
 138         dir = dir->next;
 139
 140       dir->next = gfc_getmem (sizeof (gfc_directorylist));
 141       dir = dir->next;
 142     }
 143
 144   dir->next = NULL;
 145   dir->use_for_modules = use_for_modules;
 146   dir->path = gfc_getmem (strlen (p) + 2);
 147   strcpy (dir->path, p);
 148   strcat (dir->path, "/");      /* make '/' last character */
 149 }
 150
 151
 152 void
 153 gfc_add_include_path (const char *path, bool use_for_modules)
 154 {
 155   add_path_to_list (&include_dirs, path, use_for_modules);
 156 }
 157
 158
 159 void
 160 gfc_add_intrinsic_modules_path (const char *path)
 161 {
 162   add_path_to_list (&intrinsic_modules_dirs, path, true);
 163 }
 164
 165
 166 /* Release resources allocated for options.  */
 167
 168 void
 169 gfc_release_include_path (void)
 170 {
 171   gfc_directorylist *p;
 172
 173   while (include_dirs != NULL)
 174     {
 175       p = include_dirs;
 176       include_dirs = include_dirs->next;
 177       gfc_free (p->path);
 178       gfc_free (p);
 179     }
 180
 181   while (intrinsic_modules_dirs != NULL)
 182     {
 183       p = intrinsic_modules_dirs;
 184       intrinsic_modules_dirs = intrinsic_modules_dirs->next;
 185       gfc_free (p->path);
 186       gfc_free (p);
 187     }
 188
 189   gfc_free (gfc_option.module_dir);
 190 }
 191
 192
 193 static FILE *
 194 open_included_file (const char *name, gfc_directorylist *list, bool module)
 195 {
 196   char *fullname;
 197   gfc_directorylist *p;
 198   FILE *f;
 199
 200   for (p = list; p; p = p->next)
 201     {
 202       if (module && !p->use_for_modules)
 203         continue;
 204
 205       fullname = (char *) alloca(strlen (p->path) + strlen (name) + 1);
 206       strcpy (fullname, p->path);
 207       strcat (fullname, name);
 208
 209       f = gfc_open_file (fullname);
 210       if (f != NULL)
 211         return f;
 212     }
 213
 214   return NULL;
 215 }
 216
 217
 218 /* Opens file for reading, searching through the include directories
 219    given if necessary.  If the include_cwd argument is true, we try
 220    to open the file in the current directory first.  */
 221
 222 FILE *
 223 gfc_open_included_file (const char *name, bool include_cwd, bool module)
 224 {
 225   FILE *f;
 226
 227   if (IS_ABSOLUTE_PATH (name))
 228     return gfc_open_file (name);
 229
 230   if (include_cwd)
 231     {
 232       f = gfc_open_file (name);
 233       if (f != NULL)
 234         return f;
 235     }
 236
 237   return open_included_file (name, include_dirs, module);
 238 }
 239
 240 FILE *
 241 gfc_open_intrinsic_module (const char *name)
 242 {
 243   if (IS_ABSOLUTE_PATH (name))
 244     return gfc_open_file (name);
 245
 246   return open_included_file (name, intrinsic_modules_dirs, true);
 247 }
 248
 249
 250 /* Test to see if we're at the end of the main source file.  */
 251
 252 int
 253 gfc_at_end (void)
 254 {
 255   return end_flag;
 256 }
 257
 258
 259 /* Test to see if we're at the end of the current file.  */
 260
 261 int
 262 gfc_at_eof (void)
 263 {
 264   if (gfc_at_end ())
 265     return 1;
 266
 267   if (line_head == NULL)
 268     return 1;                   /* Null file */
 269
 270   if (gfc_current_locus.lb == NULL)
 271     return 1;
 272
 273   return 0;
 274 }
 275
 276
 277 /* Test to see if we're at the beginning of a new line.  */
 278
 279 int
 280 gfc_at_bol (void)
 281 {
 282   if (gfc_at_eof ())
 283     return 1;
 284
 285   return (gfc_current_locus.nextc == gfc_current_locus.lb->line);
 286 }
 287
 288
 289 /* Test to see if we're at the end of a line.  */
 290
 291 int
 292 gfc_at_eol (void)
 293 {
 294   if (gfc_at_eof ())
 295     return 1;
 296
 297   return (*gfc_current_locus.nextc == '\0');
 298 }
 299
 300
 301 /* Advance the current line pointer to the next line.  */
 302
 303 void
 304 gfc_advance_line (void)
 305 {
 306   if (gfc_at_end ())
 307     return;
 308
 309   if (gfc_current_locus.lb == NULL)
 310     {
 311       end_flag = 1;
 312       return;
 313     }
 314
 315   gfc_current_locus.lb = gfc_current_locus.lb->next;
 316
 317   if (gfc_current_locus.lb != NULL)
 318     gfc_current_locus.nextc = gfc_current_locus.lb->line;
 319   else
 320     {
 321       gfc_current_locus.nextc = NULL;
 322       end_flag = 1;
 323     }
 324 }
 325
 326
 327 /* Get the next character from the input, advancing gfc_current_file's
 328    locus.  When we hit the end of the line or the end of the file, we
 329    start returning a '\n' in order to complete the current statement.
 330    No Fortran line conventions are implemented here.
 331
 332    Requiring explicit advances to the next line prevents the parse
 333    pointer from being on the wrong line if the current statement ends
 334    prematurely.  */
 335
 336 static int
 337 next_char (void)
 338 {
 339   int c;
 340
 341   if (gfc_current_locus.nextc == NULL)
 342     return '\n';
 343
 344   c = (unsigned char) *gfc_current_locus.nextc++;
 345   if (c == '\0')
 346     {
 347       gfc_current_locus.nextc--; /* Remain on this line.  */
 348       c = '\n';
 349     }
 350
 351   return c;
 352 }
 353
 354
 355 /* Skip a comment.  When we come here the parse pointer is positioned
 356    immediately after the comment character.  If we ever implement
 357    compiler directives withing comments, here is where we parse the
 358    directive.  */
 359
 360 static void
 361 skip_comment_line (void)
 362 {
 363   char c;
 364
 365   do
 366     {
 367       c = next_char ();
 368     }
 369   while (c != '\n');
 370
 371   gfc_advance_line ();
 372 }
 373
 374
 375 /* Comment lines are null lines, lines containing only blanks or lines
 376    on which the first nonblank line is a '!'.
 377    Return true if !$ openmp conditional compilation sentinel was
 378    seen.  */
 379
 380 static bool
 381 skip_free_comments (void)
 382 {
 383   locus start;
 384   char c;
 385   int at_bol;
 386
 387   for (;;)
 388     {
 389       at_bol = gfc_at_bol ();
 390       start = gfc_current_locus;
 391       if (gfc_at_eof ())
 392         break;
 393
 394       do
 395         c = next_char ();
 396       while (gfc_is_whitespace (c));
 397
 398       if (c == '\n')
 399         {
 400           gfc_advance_line ();
 401           continue;
 402         }
 403
 404       if (c == '!')
 405         {
 406           /* If -fopenmp, we need to handle here 2 things:
 407              1) don't treat !$omp as comments, but directives
 408              2) handle OpenMP conditional compilation, where
 409                 !$ should be treated as 2 spaces (for initial lines
 410                 only if followed by space).  */
 411           if (gfc_option.flag_openmp && at_bol)
 412             {
 413               locus old_loc = gfc_current_locus;
 414               if (next_char () == '$')
 415                 {
 416                   c = next_char ();
 417                   if (c == 'o' || c == 'O')
 418                     {
 419                       if (((c = next_char ()) == 'm' || c == 'M')
 420                           && ((c = next_char ()) == 'p' || c == 'P'))
 421                         {
 422                           if ((c = next_char ()) == ' ' || continue_flag)
 423                             {
 424                               while (gfc_is_whitespace (c))
 425                                 c = next_char ();
 426                               if (c != '\n' && c != '!')
 427                                 {
 428                                   openmp_flag = 1;
 429                                   openmp_locus = old_loc;
 430                                   gfc_current_locus = start;
 431                                   return false;
 432                                 }
 433                             }
 434                           else
 435                             gfc_warning_now ("!$OMP at %C starts a commented "
 436                                              "line as it neither is followed "
 437                                              "by a space nor is a "
 438                                              "continuation line");
 439                         }
 440                       gfc_current_locus = old_loc;
 441                       next_char ();
 442                       c = next_char ();
 443                     }
 444                   if (continue_flag || c == ' ')
 445                     {
 446                       gfc_current_locus = old_loc;
 447                       next_char ();
 448                       openmp_flag = 0;
 449                       return true;
 450                     }
 451                 }
 452               gfc_current_locus = old_loc;
 453             }
 454           skip_comment_line ();
 455           continue;
 456         }
 457
 458       break;
 459     }
 460
 461   if (openmp_flag && at_bol)
 462     openmp_flag = 0;
 463   gfc_current_locus = start;
 464   return false;
 465 }
 466
 467
 468 /* Skip comment lines in fixed source mode.  We have the same rules as
 469    in skip_free_comment(), except that we can have a 'c', 'C' or '*'
 470    in column 1, and a '!' cannot be in column 6.  Also, we deal with
 471    lines with 'd' or 'D' in column 1, if the user requested this.  */
 472
 473 static void
 474 skip_fixed_comments (void)
 475 {
 476   locus start;
 477   int col;
 478   char c;
 479
 480   if (! gfc_at_bol ())
 481     {
 482       start = gfc_current_locus;
 483       if (! gfc_at_eof ())
 484         {
 485           do
 486             c = next_char ();
 487           while (gfc_is_whitespace (c));
 488
 489           if (c == '\n')
 490             gfc_advance_line ();
 491           else if (c == '!')
 492             skip_comment_line ();
 493         }
 494
 495       if (! gfc_at_bol ())
 496         {
 497           gfc_current_locus = start;
 498           return;
 499         }
 500     }
 501
 502   for (;;)
 503     {
 504       start = gfc_current_locus;
 505       if (gfc_at_eof ())
 506         break;
 507
 508       c = next_char ();
 509       if (c == '\n')
 510         {
 511           gfc_advance_line ();
 512           continue;
 513         }
 514
 515       if (c == '!' || c == 'c' || c == 'C' || c == '*')
 516         {
 517           /* If -fopenmp, we need to handle here 2 things:
 518              1) don't treat !$omp|c$omp|*$omp as comments, but directives
 519              2) handle OpenMP conditional compilation, where
 520                 !$|c$|*$ should be treated as 2 spaces if the characters
 521                 in columns 3 to 6 are valid fixed form label columns
 522                 characters.  */
 523           if (gfc_option.flag_openmp)
 524             {
 525               if (next_char () == '$')
 526                 {
 527                   c = next_char ();
 528                   if (c == 'o' || c == 'O')
 529                     {
 530                       if (((c = next_char ()) == 'm' || c == 'M')
 531                           && ((c = next_char ()) == 'p' || c == 'P'))
 532                         {
 533                           c = next_char ();
 534                           if (c != '\n'
 535                               && ((openmp_flag && continue_flag)
 536                                   || c == ' ' || c == '0'))
 537                             {
 538                               c = next_char ();
 539                               while (gfc_is_whitespace (c))
 540                                 c = next_char ();
 541                               if (c != '\n' && c != '!')
 542                                 {
 543                                   /* Canonicalize to *$omp.  */
 544                                   *start.nextc = '*';
 545                                   openmp_flag = 1;
 546                                   gfc_current_locus = start;
 547                                   return;
 548                                 }
 549                             }
 550                         }
 551                     }
 552                   else
 553                     {
 554                       int digit_seen = 0;
 555
 556                       for (col = 3; col < 6; col++, c = next_char ())
 557                         if (c == ' ')
 558                           continue;
 559                         else if (c < '0' || c > '9')
 560                           break;
 561                         else
 562                           digit_seen = 1;
 563
 564                       if (col == 6 && c != '\n'
 565                           && ((continue_flag && !digit_seen)
 566                               || c == ' ' || c == '0'))
 567                         {
 568                           gfc_current_locus = start;
 569                           start.nextc[0] = ' ';
 570                           start.nextc[1] = ' ';
 571                           continue;
 572                         }
 573                     }
 574                 }
 575               gfc_current_locus = start;
 576             }
 577           skip_comment_line ();
 578           continue;
 579         }
 580
 581       if (gfc_option.flag_d_lines != -1 && (c == 'd' || c == 'D'))
 582         {
 583           if (gfc_option.flag_d_lines == 0)
 584             {
 585               skip_comment_line ();
 586               continue;
 587             }
 588           else
 589             *start.nextc = c = ' ';
 590         }
 591
 592       col = 1;
 593
 594       while (gfc_is_whitespace (c))
 595         {
 596           c = next_char ();
 597           col++;
 598         }
 599
 600       if (c == '\n')
 601         {
 602           gfc_advance_line ();
 603           continue;
 604         }
 605
 606       if (col != 6 && c == '!')
 607         {
 608           skip_comment_line ();
 609           continue;
 610         }
 611
 612       break;
 613     }
 614
 615   openmp_flag = 0;
 616   gfc_current_locus = start;
 617 }
 618
 619
 620 /* Skips the current line if it is a comment.  */
 621
 622 void
 623 gfc_skip_comments (void)
 624 {
 625   if (gfc_current_form == FORM_FREE)
 626     skip_free_comments ();
 627   else
 628     skip_fixed_comments ();
 629 }
 630
 631
 632 /* Get the next character from the input, taking continuation lines
 633    and end-of-line comments into account.  This implies that comment
 634    lines between continued lines must be eaten here.  For higher-level
 635    subroutines, this flattens continued lines into a single logical
 636    line.  The in_string flag denotes whether we're inside a character
 637    context or not.  */
 638
 639 int
 640 gfc_next_char_literal (int in_string)
 641 {
 642   locus old_loc;
 643   int i, c, prev_openmp_flag;
 644
 645   continue_flag = 0;
 646
 647 restart:
 648   c = next_char ();
 649   if (gfc_at_end ())
 650     {
 651       continue_count = 0;
 652       return c;
 653     }
 654
 655   if (gfc_current_form == FORM_FREE)
 656     {
 657       bool openmp_cond_flag;
 658
 659       if (!in_string && c == '!')
 660         {
 661           if (openmp_flag
 662               && memcmp (&gfc_current_locus, &openmp_locus,
 663                  sizeof (gfc_current_locus)) == 0)
 664             goto done;
 665
 666           /* This line can't be continued */
 667           do
 668             {
 669               c = next_char ();
 670             }
 671           while (c != '\n');
 672
 673           /* Avoid truncation warnings for comment ending lines.  */
 674           gfc_current_locus.lb->truncated = 0;
 675
 676           goto done;
 677         }
 678
 679       if (c != '&')
 680         goto done;
 681
 682       /* If the next nonblank character is a ! or \n, we've got a
 683          continuation line.  */
 684       old_loc = gfc_current_locus;
 685
 686       c = next_char ();
 687       while (gfc_is_whitespace (c))
 688         c = next_char ();
 689
 690       /* Character constants to be continued cannot have commentary
 691          after the '&'.  */
 692
 693       if (in_string && c != '\n')
 694         {
 695           gfc_current_locus = old_loc;
 696           c = '&';
 697           goto done;
 698         }
 699
 700       if (c != '!' && c != '\n')
 701         {
 702           gfc_current_locus = old_loc;
 703           c = '&';
 704           goto done;
 705         }
 706
 707       prev_openmp_flag = openmp_flag;
 708       continue_flag = 1;
 709       if (c == '!')
 710         skip_comment_line ();
 711       else
 712         gfc_advance_line ();
 713
 714       if (gfc_at_eof())
 715         goto not_continuation;
 716
 717       /* We've got a continuation line.  If we are on the very next line after
 718          the last continuation, increment the continuation line count and
 719          check whether the limit has been exceeded.  */
 720       if (gfc_linebuf_linenum (gfc_current_locus.lb) == continue_line + 1)
 721         {
 722           if (++continue_count == gfc_option.max_continue_free)
 723             {
 724               if (gfc_notification_std (GFC_STD_GNU) || pedantic)
 725                 gfc_warning ("Limit of %d continuations exceeded in "
 726                              "statement at %C", gfc_option.max_continue_free);
 727             }
 728         }
 729       continue_line = gfc_linebuf_linenum (gfc_current_locus.lb);
 730
 731       /* Now find where it continues. First eat any comment lines.  */
 732       openmp_cond_flag = skip_free_comments ();
 733
 734       if (prev_openmp_flag != openmp_flag)
 735         {
 736           gfc_current_locus = old_loc;
 737           openmp_flag = prev_openmp_flag;
 738           c = '&';
 739           goto done;
 740         }
 741
 742       /* Now that we have a non-comment line, probe ahead for the
 743          first non-whitespace character.  If it is another '&', then
 744          reading starts at the next character, otherwise we must back
 745          up to where the whitespace started and resume from there.  */
 746
 747       old_loc = gfc_current_locus;
 748
 749       c = next_char ();
 750       while (gfc_is_whitespace (c))
 751         c = next_char ();
 752
 753       if (openmp_flag)
 754         {
 755           for (i = 0; i < 5; i++, c = next_char ())
 756             {
 757               gcc_assert (TOLOWER (c) == "!$omp"[i]);
 758               if (i == 4)
 759                 old_loc = gfc_current_locus;
 760             }
 761           while (gfc_is_whitespace (c))
 762             c = next_char ();
 763         }
 764
 765       if (c != '&')
 766         {
 767           if (in_string)
 768             {
 769               if (gfc_option.warn_ampersand)
 770                 gfc_warning_now ("Missing '&' in continued character "
 771                                  "constant at %C");
 772               gfc_current_locus.nextc--;
 773             }
 774           /* Both !$omp and !$ -fopenmp continuation lines have & on the
 775              continuation line only optionally.  */
 776           else if (openmp_flag || openmp_cond_flag)
 777             gfc_current_locus.nextc--;
 778           else
 779             {
 780               c = ' ';
 781               gfc_current_locus = old_loc;
 782               goto done;
 783             }
 784         }
 785     }
 786   else
 787     {
 788       /* Fixed form continuation.  */
 789       if (!in_string && c == '!')
 790         {
 791           /* Skip comment at end of line.  */
 792           do
 793             {
 794               c = next_char ();
 795             }
 796           while (c != '\n');
 797
 798           /* Avoid truncation warnings for comment ending lines.  */
 799           gfc_current_locus.lb->truncated = 0;
 800         }
 801
 802       if (c != '\n')
 803         goto done;
 804
 805       prev_openmp_flag = openmp_flag;
 806       continue_flag = 1;
 807       old_loc = gfc_current_locus;
 808
 809       gfc_advance_line ();
 810       skip_fixed_comments ();
 811
 812       /* See if this line is a continuation line.  */
 813       if (openmp_flag != prev_openmp_flag)
 814         {
 815           openmp_flag = prev_openmp_flag;
 816           goto not_continuation;
 817         }
 818
 819       if (!openmp_flag)
 820         for (i = 0; i < 5; i++)
 821           {
 822             c = next_char ();
 823             if (c != ' ')
 824               goto not_continuation;
 825           }
 826       else
 827         for (i = 0; i < 5; i++)
 828           {
 829             c = next_char ();
 830             if (TOLOWER (c) != "*$omp"[i])
 831               goto not_continuation;
 832           }
 833
 834       c = next_char ();
 835       if (c == '0' || c == ' ' || c == '\n')
 836         goto not_continuation;
 837
 838       /* We've got a continuation line.  If we are on the very next line after
 839          the last continuation, increment the continuation line count and
 840          check whether the limit has been exceeded.  */
 841       if (gfc_linebuf_linenum (gfc_current_locus.lb) == continue_line + 1)
 842         {
 843           if (++continue_count == gfc_option.max_continue_fixed)
 844             {
 845               if (gfc_notification_std (GFC_STD_GNU) || pedantic)
 846                 gfc_warning ("Limit of %d continuations exceeded in "
 847                              "statement at %C",
 848                              gfc_option.max_continue_fixed);
 849             }
 850         }
 851
 852       if (continue_line < gfc_linebuf_linenum (gfc_current_locus.lb))
 853         continue_line = gfc_linebuf_linenum (gfc_current_locus.lb);
 854     }
 855
 856   /* Ready to read first character of continuation line, which might
 857      be another continuation line!  */
 858   goto restart;
 859
 860 not_continuation:
 861   c = '\n';
 862   gfc_current_locus = old_loc;
 863
 864 done:
 865   if (c == '\n')
 866     continue_count = 0;
 867   continue_flag = 0;
 868   return c;
 869 }
 870
 871
 872 /* Get the next character of input, folded to lowercase.  In fixed
 873    form mode, we also ignore spaces.  When matcher subroutines are
 874    parsing character literals, they have to call
 875    gfc_next_char_literal().  */
 876
 877 int
 878 gfc_next_char (void)
 879 {
 880   int c;
 881
 882   do
 883     {
 884       c = gfc_next_char_literal (0);
 885     }
 886   while (gfc_current_form == FORM_FIXED && gfc_is_whitespace (c));
 887
 888   return TOLOWER (c);
 889 }
 890
 891
 892 int
 893 gfc_peek_char (void)
 894 {
 895   locus old_loc;
 896   int c;
 897
 898   old_loc = gfc_current_locus;
 899   c = gfc_next_char ();
 900   gfc_current_locus = old_loc;
 901
 902   return c;
 903 }
 904
 905
 906 /* Recover from an error.  We try to get past the current statement
 907    and get lined up for the next.  The next statement follows a '\n'
 908    or a ';'.  We also assume that we are not within a character
 909    constant, and deal with finding a '\'' or '"'.  */
 910
 911 void
 912 gfc_error_recovery (void)
 913 {
 914   char c, delim;
 915
 916   if (gfc_at_eof ())
 917     return;
 918
 919   for (;;)
 920     {
 921       c = gfc_next_char ();
 922       if (c == '\n' || c == ';')
 923         break;
 924
 925       if (c != '\'' && c != '"')
 926         {
 927           if (gfc_at_eof ())
 928             break;
 929           continue;
 930         }
 931       delim = c;
 932
 933       for (;;)
 934         {
 935           c = next_char ();
 936
 937           if (c == delim)
 938             break;
 939           if (c == '\n')
 940             return;
 941           if (c == '\\')
 942             {
 943               c = next_char ();
 944               if (c == '\n')
 945                 return;
 946             }
 947         }
 948       if (gfc_at_eof ())
 949         break;
 950     }
 951 }
 952
 953
 954 /* Read ahead until the next character to be read is not whitespace.  */
 955
 956 void
 957 gfc_gobble_whitespace (void)
 958 {
 959   static int linenum = 0;
 960   locus old_loc;
 961   int c;
 962
 963   do
 964     {
 965       old_loc = gfc_current_locus;
 966       c = gfc_next_char_literal (0);
 967       /* Issue a warning for nonconforming tabs.  We keep track of the line
 968          number because the Fortran matchers will often back up and the same
 969          line will be scanned multiple times.  */
 970       if (!gfc_option.warn_tabs && c == '\t')
 971         {
 972 #ifdef USE_MAPPED_LOCATION
 973           int cur_linenum = LOCATION_LINE (gfc_current_locus.lb->location);
 974 #else
 975           int cur_linenum = gfc_current_locus.lb->linenum;
 976 #endif
 977           if (cur_linenum != linenum)
 978             {
 979               linenum = cur_linenum;
 980               gfc_warning_now ("Nonconforming tab character at %C");
 981             }
 982         }
 983     }
 984   while (gfc_is_whitespace (c));
 985
 986   gfc_current_locus = old_loc;
 987 }
 988
 989
 990 /* Load a single line into pbuf.
 991
 992    If pbuf points to a NULL pointer, it is allocated.
 993    We truncate lines that are too long, unless we're dealing with
 994    preprocessor lines or if the option -ffixed-line-length-none is set,
 995    in which case we reallocate the buffer to fit the entire line, if
 996    need be.
 997    In fixed mode, we expand a tab that occurs within the statement
 998    label region to expand to spaces that leave the next character in
 999    the source region.
1000    load_line returns whether the line was truncated.
1001
1002    NOTE: The error machinery isn't available at this point, so we can't
1003          easily report line and column numbers consistent with other
1004          parts of gfortran.  */
1005
1006 static int
1007 load_line (FILE *input, char **pbuf, int *pbuflen)
1008 {
1009   static int linenum = 0, current_line = 1;
1010   int c, maxlen, i, preprocessor_flag, buflen = *pbuflen;
1011   int trunc_flag = 0, seen_comment = 0;
1012   int seen_printable = 0, seen_ampersand = 0;
1013   char *buffer;
1014
1015   /* Determine the maximum allowed line length.  */
1016   if (gfc_current_form == FORM_FREE)
1017     maxlen = gfc_option.free_line_length;
1018   else if (gfc_current_form == FORM_FIXED)
1019     maxlen = gfc_option.fixed_line_length;
1020   else
1021     maxlen = 72;
1022
1023   if (*pbuf == NULL)
1024     {
1025       /* Allocate the line buffer, storing its length into buflen.
1026          Note that if maxlen==0, indicating that arbitrary-length lines
1027          are allowed, the buffer will be reallocated if this length is
1028          insufficient; since 132 characters is the length of a standard
1029          free-form line, we use that as a starting guess.  */
1030       if (maxlen > 0)
1031         buflen = maxlen;
1032       else
1033         buflen = 132;
1034
1035       *pbuf = gfc_getmem (buflen + 1);
1036     }
1037
1038   i = 0;
1039   buffer = *pbuf;
1040
1041   preprocessor_flag = 0;
1042   c = getc (input);
1043   if (c == '#')
1044     /* In order to not truncate preprocessor lines, we have to
1045        remember that this is one.  */
1046     preprocessor_flag = 1;
1047   ungetc (c, input);
1048
1049   for (;;)
1050     {
1051       c = getc (input);
1052
1053       if (c == EOF)
1054         break;
1055       if (c == '\n')
1056         {
1057           /* Check for illegal use of ampersand. See F95 Standard 3.3.1.3.  */
1058           if (gfc_current_form == FORM_FREE
1059               && !seen_printable && seen_ampersand)
1060             {
1061               if (pedantic)
1062                 gfc_error_now ("'&' not allowed by itself in line %d",
1063                                current_line);
1064               else
1065                 gfc_warning_now ("'&' not allowed by itself in line %d",
1066                                  current_line);
1067             }
1068           break;
1069         }
1070
1071       if (c == '\r')
1072         continue;               /* Gobble characters.  */
1073       if (c == '\0')
1074         continue;
1075
1076       if (c == '&')
1077         {
1078           if (seen_ampersand)
1079             seen_ampersand = 0;
1080           else
1081             seen_ampersand = 1;
1082         }
1083
1084       if ((c != '&' && c != '!') || (c == '!' && !seen_ampersand))
1085         seen_printable = 1;
1086
1087       /* Is this a fixed-form comment?  */
1088       if (gfc_current_form == FORM_FIXED && i == 0
1089           && (c == '*' || c == 'c' || c == 'd'))
1090         seen_comment = 1;
1091
1092       if (gfc_current_form == FORM_FIXED && c == '\t' && i <= 6)
1093         {
1094           if (!gfc_option.warn_tabs && seen_comment == 0
1095               && current_line != linenum)
1096             {
1097               linenum = current_line;
1098               gfc_warning_now ("Nonconforming tab character in column 1 "
1099                                "of line %d", linenum);
1100             }
1101
1102           while (i <= 6)
1103             {
1104               *buffer++ = ' ';
1105               i++;
1106             }
1107
1108           continue;
1109         }
1110
1111       *buffer++ = c;
1112       i++;
1113
1114       if (maxlen == 0 || preprocessor_flag)
1115         {
1116           if (i >= buflen)
1117             {
1118               /* Reallocate line buffer to double size to hold the
1119                 overlong line.  */
1120               buflen = buflen * 2;
1121               *pbuf = xrealloc (*pbuf, buflen + 1);
1122               buffer = (*pbuf) + i;
1123             }
1124         }
1125       else if (i >= maxlen)
1126         {
1127           /* Truncate the rest of the line.  */
1128           for (;;)
1129             {
1130               c = getc (input);
1131               if (c == '\n' || c == EOF)
1132                 break;
1133
1134               trunc_flag = 1;
1135             }
1136
1137           ungetc ('\n', input);
1138         }
1139     }
1140
1141   /* Pad lines to the selected line length in fixed form.  */
1142   if (gfc_current_form == FORM_FIXED
1143       && gfc_option.fixed_line_length != 0
1144       && !preprocessor_flag
1145       && c != EOF)
1146     {
1147       while (i++ < maxlen)
1148         *buffer++ = ' ';
1149     }
1150
1151   *buffer = '\0';
1152   *pbuflen = buflen;
1153   current_line++;
1154
1155   return trunc_flag;
1156 }
1157
1158
1159 /* Get a gfc_file structure, initialize it and add it to
1160    the file stack.  */
1161
1162 static gfc_file *
1163 get_file (const char *name, enum lc_reason reason ATTRIBUTE_UNUSED)
1164 {
1165   gfc_file *f;
1166
1167   f = gfc_getmem (sizeof (gfc_file));
1168
1169   f->filename = gfc_getmem (strlen (name) + 1);
1170   strcpy (f->filename, name);
1171
1172   f->next = file_head;
1173   file_head = f;
1174
1175   f->included_by = current_file;
1176   if (current_file != NULL)
1177     f->inclusion_line = current_file->line;
1178
1179 #ifdef USE_MAPPED_LOCATION
1180   linemap_add (line_table, reason, false, f->filename, 1);
1181 #endif
1182
1183   return f;
1184 }
1185
1186 /* Deal with a line from the C preprocessor. The
1187    initial octothorp has already been seen.  */
1188
1189 static void
1190 preprocessor_line (char *c)
1191 {
1192   bool flag[5];
1193   int i, line;
1194   char *filename;
1195   gfc_file *f;
1196   int escaped, unescape;
1197
1198   c++;
1199   while (*c == ' ' || *c == '\t')
1200     c++;
1201
1202   if (*c < '0' || *c > '9')
1203     goto bad_cpp_line;
1204
1205   line = atoi (c);
1206
1207   c = strchr (c, ' ');
1208   if (c == NULL)
1209     {
1210       /* No file name given.  Set new line number.  */
1211       current_file->line = line;
1212       return;
1213     }
1214
1215   /* Skip spaces.  */
1216   while (*c == ' ' || *c == '\t')
1217     c++;
1218
1219   /* Skip quote.  */
1220   if (*c != '"')
1221     goto bad_cpp_line;
1222   ++c;
1223
1224   filename = c;
1225
1226   /* Make filename end at quote.  */
1227   unescape = 0;
1228   escaped = false;
1229   while (*c && ! (!escaped && *c == '"'))
1230     {
1231       if (escaped)
1232         escaped = false;
1233       else if (*c == '\\')
1234         {
1235           escaped = true;
1236           unescape++;
1237         }
1238       ++c;
1239     }
1240
1241   if (! *c)
1242     /* Preprocessor line has no closing quote.  */
1243     goto bad_cpp_line;
1244
1245   *c++ = '\0';
1246
1247   /* Undo effects of cpp_quote_string.  */
1248   if (unescape)
1249     {
1250       char *s = filename;
1251       char *d = gfc_getmem (c - filename - unescape);
1252
1253       filename = d;
1254       while (*s)
1255         {
1256           if (*s == '\\')
1257             *d++ = *++s;
1258           else
1259             *d++ = *s;
1260           s++;
1261         }
1262       *d = '\0';
1263     }
1264
1265   /* Get flags.  */
1266
1267   flag[1] = flag[2] = flag[3] = flag[4] = false;
1268
1269   for (;;)
1270     {
1271       c = strchr (c, ' ');
1272       if (c == NULL)
1273         break;
1274
1275       c++;
1276       i = atoi (c);
1277
1278       if (1 <= i && i <= 4)
1279         flag[i] = true;
1280     }
1281
1282   /* Interpret flags.  */
1283
1284   if (flag[1]) /* Starting new file.  */
1285     {
1286       f = get_file (filename, LC_RENAME);
1287       f->up = current_file;
1288       current_file = f;
1289     }
1290
1291   if (flag[2]) /* Ending current file.  */
1292     {
1293       if (!current_file->up
1294           || strcmp (current_file->up->filename, filename) != 0)
1295         {
1296           gfc_warning_now ("%s:%d: file %s left but not entered",
1297                            current_file->filename, current_file->line,
1298                            filename);
1299           if (unescape)
1300             gfc_free (filename);
1301           return;
1302         }
1303       current_file = current_file->up;
1304     }
1305
1306   /* The name of the file can be a temporary file produced by
1307      cpp. Replace the name if it is different.  */
1308
1309   if (strcmp (current_file->filename, filename) != 0)
1310     {
1311       gfc_free (current_file->filename);
1312       current_file->filename = gfc_getmem (strlen (filename) + 1);
1313       strcpy (current_file->filename, filename);
1314     }
1315
1316   /* Set new line number.  */
1317   current_file->line = line;
1318   if (unescape)
1319     gfc_free (filename);
1320   return;
1321
1322  bad_cpp_line:
1323   gfc_warning_now ("%s:%d: Illegal preprocessor directive",
1324                    current_file->filename, current_file->line);
1325   current_file->line++;
1326 }
1327
1328
1329 static try load_file (const char *, bool);
1330
1331 /* include_line()-- Checks a line buffer to see if it is an include
1332    line.  If so, we call load_file() recursively to load the included
1333    file.  We never return a syntax error because a statement like
1334    "include = 5" is perfectly legal.  We return false if no include was
1335    processed or true if we matched an include.  */
1336
1337 static bool
1338 include_line (char *line)
1339 {
1340   char quote, *c, *begin, *stop;
1341
1342   c = line;
1343
1344   if (gfc_option.flag_openmp)
1345     {
1346       if (gfc_current_form == FORM_FREE)
1347         {
1348           while (*c == ' ' || *c == '\t')
1349             c++;
1350           if (*c == '!' && c[1] == '$' && (c[2] == ' ' || c[2] == '\t'))
1351             c += 3;
1352         }
1353       else
1354         {
1355           if ((*c == '!' || *c == 'c' || *c == 'C' || *c == '*')
1356               && c[1] == '$' && (c[2] == ' ' || c[2] == '\t'))
1357             c += 3;
1358         }
1359     }
1360
1361   while (*c == ' ' || *c == '\t')
1362     c++;
1363
1364   if (strncasecmp (c, "include", 7))
1365       return false;
1366
1367   c += 7;
1368   while (*c == ' ' || *c == '\t')
1369     c++;
1370
1371   /* Find filename between quotes.  */
1372
1373   quote = *c++;
1374   if (quote != '"' && quote != '\'')
1375     return false;
1376
1377   begin = c;
1378
1379   while (*c != quote && *c != '\0')
1380     c++;
1381
1382   if (*c == '\0')
1383     return false;
1384
1385   stop = c++;
1386
1387   while (*c == ' ' || *c == '\t')
1388     c++;
1389
1390   if (*c != '\0' && *c != '!')
1391     return false;
1392
1393   /* We have an include line at this point.  */
1394
1395   *stop = '\0'; /* It's ok to trash the buffer, as this line won't be
1396                    read by anything else.  */
1397
1398   load_file (begin, false);
1399   return true;
1400 }
1401
1402
1403 /* Load a file into memory by calling load_line until the file ends.  */
1404
1405 static try
1406 load_file (const char *filename, bool initial)
1407 {
1408   char *line;
1409   gfc_linebuf *b;
1410   gfc_file *f;
1411   FILE *input;
1412   int len, line_len;
1413   bool first_line;
1414
1415   for (f = current_file; f; f = f->up)
1416     if (strcmp (filename, f->filename) == 0)
1417       {
1418         gfc_error_now ("File '%s' is being included recursively", filename);
1419         return FAILURE;
1420       }
1421
1422   if (initial)
1423     {
1424       if (gfc_src_file)
1425         {
1426           input = gfc_src_file;
1427           gfc_src_file = NULL;
1428         }
1429       else
1430         input = gfc_open_file (filename);
1431       if (input == NULL)
1432         {
1433           gfc_error_now ("Can't open file '%s'", filename);
1434           return FAILURE;
1435         }
1436     }
1437   else
1438     {
1439       input = gfc_open_included_file (filename, false, false);
1440       if (input == NULL)
1441         {
1442           gfc_error_now ("Can't open included file '%s'", filename);
1443           return FAILURE;
1444         }
1445     }
1446
1447   /* Load the file.  */
1448
1449   f = get_file (filename, initial ? LC_RENAME : LC_ENTER);
1450   f->up = current_file;
1451   current_file = f;
1452   current_file->line = 1;
1453   line = NULL;
1454   line_len = 0;
1455   first_line = true;
1456
1457   if (initial && gfc_src_preprocessor_lines[0])
1458     {
1459       preprocessor_line (gfc_src_preprocessor_lines[0]);
1460       gfc_free (gfc_src_preprocessor_lines[0]);
1461       gfc_src_preprocessor_lines[0] = NULL;
1462       if (gfc_src_preprocessor_lines[1])
1463         {
1464           preprocessor_line (gfc_src_preprocessor_lines[1]);
1465           gfc_free (gfc_src_preprocessor_lines[1]);
1466           gfc_src_preprocessor_lines[1] = NULL;
1467         }
1468     }
1469
1470   for (;;)
1471     {
1472       int trunc = load_line (input, &line, &line_len);
1473
1474       len = strlen (line);
1475       if (feof (input) && len == 0)
1476         break;
1477
1478       /* If this is the first line of the file, it can contain a byte
1479          order mark (BOM), which we will ignore:
1480            FF FE is UTF-16 little endian,
1481            FE FF is UTF-16 big endian,
1482            EF BB BF is UTF-8.  */
1483       if (first_line
1484           && ((line_len >= 2 && line[0] == '\xFF' && line[1] == '\xFE')
1485               || (line_len >= 2 && line[0] == '\xFE' && line[1] == '\xFF')
1486               || (line_len >= 3 && line[0] == '\xEF' && line[1] == '\xBB'
1487                   && line[2] == '\xBF')))
1488         {
1489           int n = line[1] == '\xBB' ? 3 : 2;
1490           char * new = gfc_getmem (line_len);
1491
1492           strcpy (new, line + n);
1493           gfc_free (line);
1494           line = new;
1495           len -= n;
1496         }
1497
1498       /* There are three things this line can be: a line of Fortran
1499          source, an include line or a C preprocessor directive.  */
1500
1501       if (line[0] == '#')
1502         {
1503           preprocessor_line (line);
1504           continue;
1505         }
1506
1507       /* Preprocessed files have preprocessor lines added before the byte
1508          order mark, so first_line is not about the first line of the file
1509          but the first line that's not a preprocessor line.  */
1510       first_line = false;
1511
1512       if (include_line (line))
1513         {
1514           current_file->line++;
1515           continue;
1516         }
1517
1518       /* Add line.  */
1519
1520       b = gfc_getmem (gfc_linebuf_header_size + len + 1);
1521
1522 #ifdef USE_MAPPED_LOCATION
1523       b->location
1524         = linemap_line_start (line_table, current_file->line++, 120);
1525 #else
1526       b->linenum = current_file->line++;
1527 #endif
1528       b->file = current_file;
1529       b->truncated = trunc;
1530       strcpy (b->line, line);
1531
1532       if (line_head == NULL)
1533         line_head = b;
1534       else
1535         line_tail->next = b;
1536
1537       line_tail = b;
1538     }
1539
1540   /* Release the line buffer allocated in load_line.  */
1541   gfc_free (line);
1542
1543   fclose (input);
1544
1545   current_file = current_file->up;
1546 #ifdef USE_MAPPED_LOCATION
1547   linemap_add (line_table, LC_LEAVE, 0, NULL, 0);
1548 #endif
1549   return SUCCESS;
1550 }
1551
1552
1553 /* Open a new file and start scanning from that file. Returns SUCCESS
1554    if everything went OK, FAILURE otherwise.  If form == FORM_UKNOWN
1555    it tries to determine the source form from the filename, defaulting
1556    to free form.  */
1557
1558 try
1559 gfc_new_file (void)
1560 {
1561   try result;
1562
1563   result = load_file (gfc_source_file, true);
1564
1565   gfc_current_locus.lb = line_head;
1566   gfc_current_locus.nextc = (line_head == NULL) ? NULL : line_head->line;
1567
1568 #if 0 /* Debugging aid.  */
1569   for (; line_head; line_head = line_head->next)
1570     gfc_status ("%s:%3d %s\n", line_head->file->filename,
1571 #ifdef USE_MAPPED_LOCATION
1572                 LOCATION_LINE (line_head->location),
1573 #else
1574                 line_head->linenum,
1575 #endif
1576                 line_head->line);
1577
1578   exit (0);
1579 #endif
1580
1581   return result;
1582 }
1583
1584 static char *
1585 unescape_filename (const char *ptr)
1586 {
1587   const char *p = ptr, *s;
1588   char *d, *ret;
1589   int escaped, unescape = 0;
1590
1591   /* Make filename end at quote.  */
1592   escaped = false;
1593   while (*p && ! (! escaped && *p == '"'))
1594     {
1595       if (escaped)
1596         escaped = false;
1597       else if (*p == '\\')
1598         {
1599           escaped = true;
1600           unescape++;
1601         }
1602       ++p;
1603     }
1604
1605   if (!*p || p[1])
1606     return NULL;
1607
1608   /* Undo effects of cpp_quote_string.  */
1609   s = ptr;
1610   d = gfc_getmem (p + 1 - ptr - unescape);
1611   ret = d;
1612
1613   while (s != p)
1614     {
1615       if (*s == '\\')
1616         *d++ = *++s;
1617       else
1618         *d++ = *s;
1619       s++;
1620     }
1621   *d = '\0';
1622   return ret;
1623 }
1624
1625 /* For preprocessed files, if the first tokens are of the form # NUM.
1626    handle the directives so we know the original file name.  */
1627
1628 const char *
1629 gfc_read_orig_filename (const char *filename, const char **canon_source_file)
1630 {
1631   int c, len;
1632   char *dirname;
1633
1634   gfc_src_file = gfc_open_file (filename);
1635   if (gfc_src_file == NULL)
1636     return NULL;
1637
1638   c = getc (gfc_src_file);
1639   ungetc (c, gfc_src_file);
1640
1641   if (c != '#')
1642     return NULL;
1643
1644   len = 0;
1645   load_line (gfc_src_file, &gfc_src_preprocessor_lines[0], &len);
1646
1647   if (strncmp (gfc_src_preprocessor_lines[0], "# 1 \"", 5) != 0)
1648     return NULL;
1649
1650   filename = unescape_filename (gfc_src_preprocessor_lines[0] + 5);
1651   if (filename == NULL)
1652     return NULL;
1653
1654   c = getc (gfc_src_file);
1655   ungetc (c, gfc_src_file);
1656
1657   if (c != '#')
1658     return filename;
1659
1660   len = 0;
1661   load_line (gfc_src_file, &gfc_src_preprocessor_lines[1], &len);
1662
1663   if (strncmp (gfc_src_preprocessor_lines[1], "# 1 \"", 5) != 0)
1664     return filename;
1665
1666   dirname = unescape_filename (gfc_src_preprocessor_lines[1] + 5);
1667   if (dirname == NULL)
1668     return filename;
1669
1670   len = strlen (dirname);
1671   if (len < 3 || dirname[len - 1] != '/' || dirname[len - 2] != '/')
1672     {
1673       gfc_free (dirname);
1674       return filename;
1675     }
1676   dirname[len - 2] = '\0';
1677   set_src_pwd (dirname);
1678
1679   if (! IS_ABSOLUTE_PATH (filename))
1680     {
1681       char *p = gfc_getmem (len + strlen (filename));
1682
1683       memcpy (p, dirname, len - 2);
1684       p[len - 2] = '/';
1685       strcpy (p + len - 1, filename);
1686       *canon_source_file = p;
1687     }
1688
1689   gfc_free (dirname);
1690   return filename;
1691 }