gcc/fortran/scanner.c

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