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 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 /* Adds path to the list pointed to by list.  */
 120
 121 static void
 122 add_path_to_list (gfc_directorylist **list, const char *path,
 123                   bool use_for_modules)
 124 {
 125   gfc_directorylist *dir;
 126   const char *p;
 127
 128   p = path;
 129   while (*p == ' ' || *p == '\t')  /* someone might do "-I include" */
 130     if (*p++ == '\0')
 131       return;
 132
 133   dir = *list;
 134   if (!dir)
 135     dir = *list = gfc_getmem (sizeof (gfc_directorylist));
 136   else
 137     {
 138       while (dir->next)
 139         dir = dir->next;
 140
 141       dir->next = gfc_getmem (sizeof (gfc_directorylist));
 142       dir = dir->next;
 143     }
 144
 145   dir->next = NULL;
 146   dir->use_for_modules = use_for_modules;
 147   dir->path = gfc_getmem (strlen (p) + 2);
 148   strcpy (dir->path, p);
 149   strcat (dir->path, "/");      /* make '/' last character */
 150 }
 151
 152
 153 void
 154 gfc_add_include_path (const char *path, bool use_for_modules)
 155 {
 156   add_path_to_list (&include_dirs, path, use_for_modules);
 157 }
 158
 159
 160 void
 161 gfc_add_intrinsic_modules_path (const char *path)
 162 {
 163   add_path_to_list (&intrinsic_modules_dirs, path, true);
 164 }
 165
 166
 167 /* Release resources allocated for options.  */
 168
 169 void
 170 gfc_release_include_path (void)
 171 {
 172   gfc_directorylist *p;
 173
 174   while (include_dirs != NULL)
 175     {
 176       p = include_dirs;
 177       include_dirs = include_dirs->next;
 178       gfc_free (p->path);
 179       gfc_free (p);
 180     }
 181
 182   while (intrinsic_modules_dirs != NULL)
 183     {
 184       p = intrinsic_modules_dirs;
 185       intrinsic_modules_dirs = intrinsic_modules_dirs->next;
 186       gfc_free (p->path);
 187       gfc_free (p);
 188     }
 189
 190   gfc_free (gfc_option.module_dir);
 191 }
 192
 193
 194 static FILE *
 195 open_included_file (const char *name, gfc_directorylist *list, bool module)
 196 {
 197   char *fullname;
 198   gfc_directorylist *p;
 199   FILE *f;
 200
 201   for (p = list; p; p = p->next)
 202     {
 203       if (module && !p->use_for_modules)
 204         continue;
 205
 206       fullname = (char *) alloca(strlen (p->path) + strlen (name) + 1);
 207       strcpy (fullname, p->path);
 208       strcat (fullname, name);
 209
 210       f = gfc_open_file (fullname);
 211       if (f != NULL)
 212         return f;
 213     }
 214
 215   return NULL;
 216 }
 217
 218
 219 /* Opens file for reading, searching through the include directories
 220    given if necessary.  If the include_cwd argument is true, we try
 221    to open the file in the current directory first.  */
 222
 223 FILE *
 224 gfc_open_included_file (const char *name, bool include_cwd, bool module)
 225 {
 226   FILE *f;
 227
 228   if (IS_ABSOLUTE_PATH (name))
 229     return gfc_open_file (name);
 230
 231   if (include_cwd)
 232     {
 233       f = gfc_open_file (name);
 234       if (f != NULL)
 235         return f;
 236     }
 237
 238   return open_included_file (name, include_dirs, module);
 239 }
 240
 241 FILE *
 242 gfc_open_intrinsic_module (const char *name)
 243 {
 244   if (IS_ABSOLUTE_PATH (name))
 245     return gfc_open_file (name);
 246
 247   return open_included_file (name, intrinsic_modules_dirs, true);
 248 }
 249
 250
 251 /* Test to see if we're at the end of the main source file.  */
 252
 253 int
 254 gfc_at_end (void)
 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   if (gfc_at_end ())
 266     return 1;
 267
 268   if (line_head == NULL)
 269     return 1;                   /* Null file */
 270
 271   if (gfc_current_locus.lb == NULL)
 272     return 1;
 273
 274   return 0;
 275 }
 276
 277
 278 /* Test to see if we're at the beginning of a new line.  */
 279
 280 int
 281 gfc_at_bol (void)
 282 {
 283   if (gfc_at_eof ())
 284     return 1;
 285
 286   return (gfc_current_locus.nextc == gfc_current_locus.lb->line);
 287 }
 288
 289
 290 /* Test to see if we're at the end of a line.  */
 291
 292 int
 293 gfc_at_eol (void)
 294 {
 295   if (gfc_at_eof ())
 296     return 1;
 297
 298   return (*gfc_current_locus.nextc == '\0');
 299 }
 300
 301
 302 /* Advance the current line pointer to the next line.  */
 303
 304 void
 305 gfc_advance_line (void)
 306 {
 307   if (gfc_at_end ())
 308     return;
 309
 310   if (gfc_current_locus.lb == NULL)
 311     {
 312       end_flag = 1;
 313       return;
 314     }
 315
 316   gfc_current_locus.lb = gfc_current_locus.lb->next;
 317
 318   if (gfc_current_locus.lb != NULL)
 319     gfc_current_locus.nextc = gfc_current_locus.lb->line;
 320   else
 321     {
 322       gfc_current_locus.nextc = NULL;
 323       end_flag = 1;
 324     }
 325 }
 326
 327
 328 /* Get the next character from the input, advancing gfc_current_file's
 329    locus.  When we hit the end of the line or the end of the file, we
 330    start returning a '\n' in order to complete the current statement.
 331    No Fortran line conventions are implemented here.
 332
 333    Requiring explicit advances to the next line prevents the parse
 334    pointer from being on the wrong line if the current statement ends
 335    prematurely.  */
 336
 337 static int
 338 next_char (void)
 339 {
 340   int c;
 341
 342   if (gfc_current_locus.nextc == NULL)
 343     return '\n';
 344
 345   c = (unsigned char) *gfc_current_locus.nextc++;
 346   if (c == '\0')
 347     {
 348       gfc_current_locus.nextc--; /* Remain on this line.  */
 349       c = '\n';
 350     }
 351
 352   return c;
 353 }
 354
 355
 356 /* Skip a comment.  When we come here the parse pointer is positioned
 357    immediately after the comment character.  If we ever implement
 358    compiler directives withing comments, here is where we parse the
 359    directive.  */
 360
 361 static void
 362 skip_comment_line (void)
 363 {
 364   char c;
 365
 366   do
 367     {
 368       c = next_char ();
 369     }
 370   while (c != '\n');
 371
 372   gfc_advance_line ();
 373 }
 374
 375
 376 /* Comment lines are null lines, lines containing only blanks or lines
 377    on which the first nonblank line is a '!'.
 378    Return true if !$ openmp conditional compilation sentinel was
 379    seen.  */
 380
 381 static bool
 382 skip_free_comments (void)
 383 {
 384   locus start;
 385   char c;
 386   int at_bol;
 387
 388   for (;;)
 389     {
 390       at_bol = gfc_at_bol ();
 391       start = gfc_current_locus;
 392       if (gfc_at_eof ())
 393         break;
 394
 395       do
 396         c = next_char ();
 397       while (gfc_is_whitespace (c));
 398
 399       if (c == '\n')
 400         {
 401           gfc_advance_line ();
 402           continue;
 403         }
 404
 405       if (c == '!')
 406         {
 407           /* If -fopenmp, we need to handle here 2 things:
 408              1) don't treat !$omp as comments, but directives
 409              2) handle OpenMP conditional compilation, where
 410                 !$ should be treated as 2 spaces (for initial lines
 411                 only if followed by space).  */
 412           if (gfc_option.flag_openmp && at_bol)
 413             {
 414               locus old_loc = gfc_current_locus;
 415               if (next_char () == '$')
 416                 {
 417                   c = next_char ();
 418                   if (c == 'o' || c == 'O')
 419                     {
 420                       if (((c = next_char ()) == 'm' || c == 'M')
 421                           && ((c = next_char ()) == 'p' || c == 'P')
 422                           && ((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                       gfc_current_locus = old_loc;
 435                       next_char ();
 436                       c = next_char ();
 437                     }
 438                   if (continue_flag || c == ' ')
 439                     {
 440                       gfc_current_locus = old_loc;
 441                       next_char ();
 442                       openmp_flag = 0;
 443                       return true;
 444                     }
 445                 }
 446               gfc_current_locus = old_loc;
 447             }
 448           skip_comment_line ();
 449           continue;
 450         }
 451
 452       break;
 453     }
 454
 455   if (openmp_flag && at_bol)
 456     openmp_flag = 0;
 457   gfc_current_locus = start;
 458   return false;
 459 }
 460
 461
 462 /* Skip comment lines in fixed source mode.  We have the same rules as
 463    in skip_free_comment(), except that we can have a 'c', 'C' or '*'
 464    in column 1, and a '!' cannot be in column 6.  Also, we deal with
 465    lines with 'd' or 'D' in column 1, if the user requested this.  */
 466
 467 static void
 468 skip_fixed_comments (void)
 469 {
 470   locus start;
 471   int col;
 472   char c;
 473
 474   if (! gfc_at_bol ())
 475     {
 476       start = gfc_current_locus;
 477       if (! gfc_at_eof ())
 478         {
 479           do
 480             c = next_char ();
 481           while (gfc_is_whitespace (c));
 482
 483           if (c == '\n')
 484             gfc_advance_line ();
 485           else if (c == '!')
 486             skip_comment_line ();
 487         }
 488
 489       if (! gfc_at_bol ())
 490         {
 491           gfc_current_locus = start;
 492           return;
 493         }
 494     }
 495
 496   for (;;)
 497     {
 498       start = gfc_current_locus;
 499       if (gfc_at_eof ())
 500         break;
 501
 502       c = next_char ();
 503       if (c == '\n')
 504         {
 505           gfc_advance_line ();
 506           continue;
 507         }
 508
 509       if (c == '!' || c == 'c' || c == 'C' || c == '*')
 510         {
 511           /* If -fopenmp, we need to handle here 2 things:
 512              1) don't treat !$omp|c$omp|*$omp as comments, but directives
 513              2) handle OpenMP conditional compilation, where
 514                 !$|c$|*$ should be treated as 2 spaces if the characters
 515                 in columns 3 to 6 are valid fixed form label columns
 516                 characters.  */
 517           if (gfc_option.flag_openmp)
 518             {
 519               if (next_char () == '$')
 520                 {
 521                   c = next_char ();
 522                   if (c == 'o' || c == 'O')
 523                     {
 524                       if (((c = next_char ()) == 'm' || c == 'M')
 525                           && ((c = next_char ()) == 'p' || c == 'P'))
 526                         {
 527                           c = next_char ();
 528                           if (c != '\n'
 529                               && ((openmp_flag && continue_flag)
 530                                   || c == ' ' || c == '0'))
 531                             {
 532                               c = next_char ();
 533                               while (gfc_is_whitespace (c))
 534                                 c = next_char ();
 535                               if (c != '\n' && c != '!')
 536                                 {
 537                                   /* Canonicalize to *$omp.  */
 538                                   *start.nextc = '*';
 539                                   openmp_flag = 1;
 540                                   gfc_current_locus = start;
 541                                   return;
 542                                 }
 543                             }
 544                         }
 545                     }
 546                   else
 547                     {
 548                       int digit_seen = 0;
 549
 550                       for (col = 3; col < 6; col++, c = next_char ())
 551                         if (c == ' ')
 552                           continue;
 553                         else if (c < '0' || c > '9')
 554                           break;
 555                         else
 556                           digit_seen = 1;
 557
 558                       if (col == 6 && c != '\n'
 559                           && ((continue_flag && !digit_seen)
 560                               || c == ' ' || c == '0'))
 561                         {
 562                           gfc_current_locus = start;
 563                           start.nextc[0] = ' ';
 564                           start.nextc[1] = ' ';
 565                           continue;
 566                         }
 567                     }
 568                 }
 569               gfc_current_locus = start;
 570             }
 571           skip_comment_line ();
 572           continue;
 573         }
 574
 575       if (gfc_option.flag_d_lines != -1 && (c == 'd' || c == 'D'))
 576         {
 577           if (gfc_option.flag_d_lines == 0)
 578             {
 579               skip_comment_line ();
 580               continue;
 581             }
 582           else
 583             *start.nextc = c = ' ';
 584         }
 585
 586       col = 1;
 587
 588       while (gfc_is_whitespace (c))
 589         {
 590           c = next_char ();
 591           col++;
 592         }
 593
 594       if (c == '\n')
 595         {
 596           gfc_advance_line ();
 597           continue;
 598         }
 599
 600       if (col != 6 && c == '!')
 601         {
 602           skip_comment_line ();
 603           continue;
 604         }
 605
 606       break;
 607     }
 608
 609   openmp_flag = 0;
 610   gfc_current_locus = start;
 611 }
 612
 613
 614 /* Skips the current line if it is a comment.  */
 615
 616 void
 617 gfc_skip_comments (void)
 618 {
 619   if (gfc_current_form == FORM_FREE)
 620     skip_free_comments ();
 621   else
 622     skip_fixed_comments ();
 623 }
 624
 625
 626 /* Get the next character from the input, taking continuation lines
 627    and end-of-line comments into account.  This implies that comment
 628    lines between continued lines must be eaten here.  For higher-level
 629    subroutines, this flattens continued lines into a single logical
 630    line.  The in_string flag denotes whether we're inside a character
 631    context or not.  */
 632
 633 int
 634 gfc_next_char_literal (int in_string)
 635 {
 636   locus old_loc;
 637   int i, c, prev_openmp_flag;
 638
 639   continue_flag = 0;
 640
 641 restart:
 642   c = next_char ();
 643   if (gfc_at_end ())
 644     {
 645       continue_count = 0;
 646       return c;
 647     }
 648
 649   if (gfc_current_form == FORM_FREE)
 650     {
 651       bool openmp_cond_flag;
 652
 653       if (!in_string && c == '!')
 654         {
 655           if (openmp_flag
 656               && memcmp (&gfc_current_locus, &openmp_locus,
 657                  sizeof (gfc_current_locus)) == 0)
 658             goto done;
 659
 660           /* This line can't be continued */
 661           do
 662             {
 663               c = next_char ();
 664             }
 665           while (c != '\n');
 666
 667           /* Avoid truncation warnings for comment ending lines.  */
 668           gfc_current_locus.lb->truncated = 0;
 669
 670           goto done;
 671         }
 672
 673       if (c != '&')
 674         goto done;
 675
 676       /* If the next nonblank character is a ! or \n, we've got a
 677          continuation line.  */
 678       old_loc = gfc_current_locus;
 679
 680       c = next_char ();
 681       while (gfc_is_whitespace (c))
 682         c = next_char ();
 683
 684       /* Character constants to be continued cannot have commentary
 685          after the '&'.  */
 686
 687       if (in_string && c != '\n')
 688         {
 689           gfc_current_locus = old_loc;
 690           c = '&';
 691           goto done;
 692         }
 693
 694       if (c != '!' && c != '\n')
 695         {
 696           gfc_current_locus = old_loc;
 697           c = '&';
 698           goto done;
 699         }
 700
 701       prev_openmp_flag = openmp_flag;
 702       continue_flag = 1;
 703       if (c == '!')
 704         skip_comment_line ();
 705       else
 706         gfc_advance_line ();
 707
 708       /* We've got a continuation line.  If we are on the very next line after
 709          the last continuation, increment the continuation line count and
 710          check whether the limit has been exceeded.  */
 711       if (gfc_current_locus.lb->linenum == continue_line + 1)
 712         {
 713           if (++continue_count == gfc_option.max_continue_free)
 714             {
 715               if (gfc_notification_std (GFC_STD_GNU) || pedantic)
 716                 gfc_warning ("Limit of %d continuations exceeded in "
 717                              "statement at %C", gfc_option.max_continue_free);
 718             }
 719         }
 720       continue_line = gfc_current_locus.lb->linenum;
 721
 722       /* Now find where it continues. First eat any comment lines.  */
 723       openmp_cond_flag = skip_free_comments ();
 724
 725       if (prev_openmp_flag != openmp_flag)
 726         {
 727           gfc_current_locus = old_loc;
 728           openmp_flag = prev_openmp_flag;
 729           c = '&';
 730           goto done;
 731         }
 732
 733       /* Now that we have a non-comment line, probe ahead for the
 734          first non-whitespace character.  If it is another '&', then
 735          reading starts at the next character, otherwise we must back
 736          up to where the whitespace started and resume from there.  */
 737
 738       old_loc = gfc_current_locus;
 739
 740       c = next_char ();
 741       while (gfc_is_whitespace (c))
 742         c = next_char ();
 743
 744       if (openmp_flag)
 745         {
 746           for (i = 0; i < 5; i++, c = next_char ())
 747             {
 748               gcc_assert (TOLOWER (c) == "!$omp"[i]);
 749               if (i == 4)
 750                 old_loc = gfc_current_locus;
 751             }
 752           while (gfc_is_whitespace (c))
 753             c = next_char ();
 754         }
 755
 756       if (c != '&')
 757         {
 758           if (in_string)
 759             {
 760               if (gfc_option.warn_ampersand)
 761                 gfc_warning_now ("Missing '&' in continued character "
 762                                  "constant at %C");
 763               gfc_current_locus.nextc--;
 764             }
 765           /* Both !$omp and !$ -fopenmp continuation lines have & on the
 766              continuation line only optionally.  */
 767           else if (openmp_flag || openmp_cond_flag)
 768             gfc_current_locus.nextc--;
 769           else
 770             {
 771               c = ' ';
 772               gfc_current_locus = old_loc;
 773               goto done;
 774             }
 775         }
 776     }
 777   else
 778     {
 779       /* Fixed form continuation.  */
 780       if (!in_string && c == '!')
 781         {
 782           /* Skip comment at end of line.  */
 783           do
 784             {
 785               c = next_char ();
 786             }
 787           while (c != '\n');
 788
 789           /* Avoid truncation warnings for comment ending lines.  */
 790           gfc_current_locus.lb->truncated = 0;
 791         }
 792
 793       if (c != '\n')
 794         goto done;
 795
 796       prev_openmp_flag = openmp_flag;
 797       continue_flag = 1;
 798       old_loc = gfc_current_locus;
 799
 800       gfc_advance_line ();
 801       skip_fixed_comments ();
 802
 803       /* See if this line is a continuation line.  */
 804       if (openmp_flag != prev_openmp_flag)
 805         {
 806           openmp_flag = prev_openmp_flag;
 807           goto not_continuation;
 808         }
 809
 810       if (!openmp_flag)
 811         for (i = 0; i < 5; i++)
 812           {
 813             c = next_char ();
 814             if (c != ' ')
 815               goto not_continuation;
 816           }
 817       else
 818         for (i = 0; i < 5; i++)
 819           {
 820             c = next_char ();
 821             if (TOLOWER (c) != "*$omp"[i])
 822               goto not_continuation;
 823           }
 824
 825       c = next_char ();
 826       if (c == '0' || c == ' ' || c == '\n')
 827         goto not_continuation;
 828
 829       /* We've got a continuation line.  If we are on the very next line after
 830          the last continuation, increment the continuation line count and
 831          check whether the limit has been exceeded.  */
 832       if (gfc_current_locus.lb->linenum == continue_line + 1)
 833         {
 834           if (++continue_count == gfc_option.max_continue_fixed)
 835             {
 836               if (gfc_notification_std (GFC_STD_GNU) || pedantic)
 837                 gfc_warning ("Limit of %d continuations exceeded in "
 838                              "statement at %C",
 839                              gfc_option.max_continue_fixed);
 840             }
 841         }
 842
 843       if (continue_line < gfc_current_locus.lb->linenum)
 844         continue_line = gfc_current_locus.lb->linenum;
 845     }
 846
 847   /* Ready to read first character of continuation line, which might
 848      be another continuation line!  */
 849   goto restart;
 850
 851 not_continuation:
 852   c = '\n';
 853   gfc_current_locus = old_loc;
 854
 855 done:
 856   if (c == '\n')
 857     continue_count = 0;
 858   continue_flag = 0;
 859   return c;
 860 }
 861
 862
 863 /* Get the next character of input, folded to lowercase.  In fixed
 864    form mode, we also ignore spaces.  When matcher subroutines are
 865    parsing character literals, they have to call
 866    gfc_next_char_literal().  */
 867
 868 int
 869 gfc_next_char (void)
 870 {
 871   int c;
 872
 873   do
 874     {
 875       c = gfc_next_char_literal (0);
 876     }
 877   while (gfc_current_form == FORM_FIXED && gfc_is_whitespace (c));
 878
 879   return TOLOWER (c);
 880 }
 881
 882
 883 int
 884 gfc_peek_char (void)
 885 {
 886   locus old_loc;
 887   int c;
 888
 889   old_loc = gfc_current_locus;
 890   c = gfc_next_char ();
 891   gfc_current_locus = old_loc;
 892
 893   return c;
 894 }
 895
 896
 897 /* Recover from an error.  We try to get past the current statement
 898    and get lined up for the next.  The next statement follows a '\n'
 899    or a ';'.  We also assume that we are not within a character
 900    constant, and deal with finding a '\'' or '"'.  */
 901
 902 void
 903 gfc_error_recovery (void)
 904 {
 905   char c, delim;
 906
 907   if (gfc_at_eof ())
 908     return;
 909
 910   for (;;)
 911     {
 912       c = gfc_next_char ();
 913       if (c == '\n' || c == ';')
 914         break;
 915
 916       if (c != '\'' && c != '"')
 917         {
 918           if (gfc_at_eof ())
 919             break;
 920           continue;
 921         }
 922       delim = c;
 923
 924       for (;;)
 925         {
 926           c = next_char ();
 927
 928           if (c == delim)
 929             break;
 930           if (c == '\n')
 931             return;
 932           if (c == '\\')
 933             {
 934               c = next_char ();
 935               if (c == '\n')
 936                 return;
 937             }
 938         }
 939       if (gfc_at_eof ())
 940         break;
 941     }
 942 }
 943
 944
 945 /* Read ahead until the next character to be read is not whitespace.  */
 946
 947 void
 948 gfc_gobble_whitespace (void)
 949 {
 950   static int linenum = 0;
 951   locus old_loc;
 952   int c;
 953
 954   do
 955     {
 956       old_loc = gfc_current_locus;
 957       c = gfc_next_char_literal (0);
 958       /* Issue a warning for nonconforming tabs.  We keep track of the line
 959          number because the Fortran matchers will often back up and the same
 960          line will be scanned multiple times.  */
 961       if (!gfc_option.warn_tabs && c == '\t')
 962         {
 963 #ifdef USE_MAPPED_LOCATION
 964           int cur_linenum = LOCATION_LINE (gfc_current_locus.lb->location);
 965 #else
 966           int cur_linenum = gfc_current_locus.lb->linenum;
 967 #endif
 968           if (cur_linenum != linenum)
 969             {
 970               linenum = cur_linenum;
 971               gfc_warning_now ("Nonconforming tab character at %C");
 972             }
 973         }
 974     }
 975   while (gfc_is_whitespace (c));
 976
 977   gfc_current_locus = old_loc;
 978 }
 979
 980
 981 /* Load a single line into pbuf.
 982
 983    If pbuf points to a NULL pointer, it is allocated.
 984    We truncate lines that are too long, unless we're dealing with
 985    preprocessor lines or if the option -ffixed-line-length-none is set,
 986    in which case we reallocate the buffer to fit the entire line, if
 987    need be.
 988    In fixed mode, we expand a tab that occurs within the statement
 989    label region to expand to spaces that leave the next character in
 990    the source region.
 991    load_line returns whether the line was truncated.
 992
 993    NOTE: The error machinery isn't available at this point, so we can't
 994          easily report line and column numbers consistent with other
 995          parts of gfortran.  */
 996
 997 static int
 998 load_line (FILE *input, char **pbuf, int *pbuflen)
 999 {
1000   static int linenum = 0, current_line = 1;
1001   int c, maxlen, i, preprocessor_flag, buflen = *pbuflen;
1002   int trunc_flag = 0, seen_comment = 0;
1003   int seen_printable = 0, seen_ampersand = 0;
1004   char *buffer;
1005
1006   /* Determine the maximum allowed line length.  */
1007   if (gfc_current_form == FORM_FREE)
1008     maxlen = gfc_option.free_line_length;
1009   else if (gfc_current_form == FORM_FIXED)
1010     maxlen = gfc_option.fixed_line_length;
1011   else
1012     maxlen = 72;
1013
1014   if (*pbuf == NULL)
1015     {
1016       /* Allocate the line buffer, storing its length into buflen.
1017          Note that if maxlen==0, indicating that arbitrary-length lines
1018          are allowed, the buffer will be reallocated if this length is
1019          insufficient; since 132 characters is the length of a standard
1020          free-form line, we use that as a starting guess.  */
1021       if (maxlen > 0)
1022         buflen = maxlen;
1023       else
1024         buflen = 132;
1025
1026       *pbuf = gfc_getmem (buflen + 1);
1027     }
1028
1029   i = 0;
1030   buffer = *pbuf;
1031
1032   preprocessor_flag = 0;
1033   c = fgetc (input);
1034   if (c == '#')
1035     /* In order to not truncate preprocessor lines, we have to
1036        remember that this is one.  */
1037     preprocessor_flag = 1;
1038   ungetc (c, input);
1039
1040   for (;;)
1041     {
1042       c = fgetc (input);
1043
1044       if (c == EOF)
1045         break;
1046       if (c == '\n')
1047         {
1048           /* Check for illegal use of ampersand. See F95 Standard 3.3.1.3.  */
1049           if (gfc_current_form == FORM_FREE
1050                 && !seen_printable && seen_ampersand)
1051             {
1052               if (pedantic)
1053                 gfc_error_now ("'&' not allowed by itself in line %d",
1054                                current_line);
1055               else
1056                 gfc_warning_now ("'&' not allowed by itself in line %d",
1057                                  current_line);
1058             }
1059           break;
1060         }
1061
1062       if (c == '\r')
1063         continue;               /* Gobble characters.  */
1064       if (c == '\0')
1065         continue;
1066
1067       if (c == '\032')
1068         {
1069           /* Ctrl-Z ends the file.  */
1070           while (fgetc (input) != EOF);
1071           break;
1072         }
1073
1074       /* Check for illegal use of ampersand. See F95 Standard 3.3.1.3.  */
1075       if (c == '&')
1076         seen_ampersand = 1;
1077
1078       if ((c != ' ' && c != '&' && c != '!') || (c == '!' && !seen_ampersand))
1079         seen_printable = 1;
1080
1081       if (gfc_current_form == FORM_FREE
1082             && c == '!' && !seen_printable && seen_ampersand)
1083         {
1084           if (pedantic)
1085             gfc_error_now ("'&' not allowed by itself with comment in "
1086                            "line %d", current_line);
1087           else
1088             gfc_warning_now ("'&' not allowed by itself with comment in "
1089                              "line %d", current_line);
1090           seen_printable = 1;
1091         }
1092
1093       /* Is this a fixed-form comment?  */
1094       if (gfc_current_form == FORM_FIXED && i == 0
1095           && (c == '*' || c == 'c' || c == 'd'))
1096         seen_comment = 1;
1097
1098       if (gfc_current_form == FORM_FIXED && c == '\t' && i <= 6)
1099         {
1100           if (!gfc_option.warn_tabs && seen_comment == 0
1101               && current_line != linenum)
1102             {
1103               linenum = current_line;
1104               gfc_warning_now ("Nonconforming tab character in column 1 "
1105                                "of line %d", linenum);
1106             }
1107
1108           while (i <= 6)
1109             {
1110               *buffer++ = ' ';
1111               i++;
1112             }
1113
1114           continue;
1115         }
1116
1117       *buffer++ = c;
1118       i++;
1119
1120       if (maxlen == 0 || preprocessor_flag)
1121         {
1122           if (i >= buflen)
1123             {
1124               /* Reallocate line buffer to double size to hold the
1125                 overlong line.  */
1126               buflen = buflen * 2;
1127               *pbuf = xrealloc (*pbuf, buflen + 1);
1128               buffer = (*pbuf) + i;
1129             }
1130         }
1131       else if (i >= maxlen)
1132         {
1133           /* Truncate the rest of the line.  */
1134           for (;;)
1135             {
1136               c = fgetc (input);
1137               if (c == '\n' || c == EOF)
1138                 break;
1139
1140               trunc_flag = 1;
1141             }
1142
1143           ungetc ('\n', input);
1144         }
1145     }
1146
1147   /* Pad lines to the selected line length in fixed form.  */
1148   if (gfc_current_form == FORM_FIXED
1149       && gfc_option.fixed_line_length != 0
1150       && !preprocessor_flag
1151       && c != EOF)
1152     {
1153       while (i++ < maxlen)
1154         *buffer++ = ' ';
1155     }
1156
1157   *buffer = '\0';
1158   *pbuflen = buflen;
1159   current_line++;
1160
1161   return trunc_flag;
1162 }
1163
1164
1165 /* Get a gfc_file structure, initialize it and add it to
1166    the file stack.  */
1167
1168 static gfc_file *
1169 get_file (const char *name, enum lc_reason reason ATTRIBUTE_UNUSED)
1170 {
1171   gfc_file *f;
1172
1173   f = gfc_getmem (sizeof (gfc_file));
1174
1175   f->filename = gfc_getmem (strlen (name) + 1);
1176   strcpy (f->filename, name);
1177
1178   f->next = file_head;
1179   file_head = f;
1180
1181   f->included_by = current_file;
1182   if (current_file != NULL)
1183     f->inclusion_line = current_file->line;
1184
1185 #ifdef USE_MAPPED_LOCATION
1186   linemap_add (&line_table, reason, false, f->filename, 1);
1187 #endif
1188
1189   return f;
1190 }
1191
1192 /* Deal with a line from the C preprocessor. The
1193    initial octothorp has already been seen.  */
1194
1195 static void
1196 preprocessor_line (char *c)
1197 {
1198   bool flag[5];
1199   int i, line;
1200   char *filename;
1201   gfc_file *f;
1202   int escaped, unescape;
1203
1204   c++;
1205   while (*c == ' ' || *c == '\t')
1206     c++;
1207
1208   if (*c < '0' || *c > '9')
1209     goto bad_cpp_line;
1210
1211   line = atoi (c);
1212
1213   c = strchr (c, ' ');
1214   if (c == NULL)
1215     {
1216       /* No file name given.  Set new line number.  */
1217       current_file->line = line;
1218       return;
1219     }
1220
1221   /* Skip spaces.  */
1222   while (*c == ' ' || *c == '\t')
1223     c++;
1224
1225   /* Skip quote.  */
1226   if (*c != '"')
1227     goto bad_cpp_line;
1228   ++c;
1229
1230   filename = c;
1231
1232   /* Make filename end at quote.  */
1233   unescape = 0;
1234   escaped = false;
1235   while (*c && ! (!escaped && *c == '"'))
1236     {
1237       if (escaped)
1238         escaped = false;
1239       else if (*c == '\\')
1240         {
1241           escaped = true;
1242           unescape++;
1243         }
1244       ++c;
1245     }
1246
1247   if (! *c)
1248     /* Preprocessor line has no closing quote.  */
1249     goto bad_cpp_line;
1250
1251   *c++ = '\0';
1252
1253   /* Undo effects of cpp_quote_string.  */
1254   if (unescape)
1255     {
1256       char *s = filename;
1257       char *d = gfc_getmem (c - filename - unescape);
1258
1259       filename = d;
1260       while (*s)
1261         {
1262           if (*s == '\\')
1263             *d++ = *++s;
1264           else
1265             *d++ = *s;
1266           s++;
1267         }
1268       *d = '\0';
1269     }
1270
1271   /* Get flags.  */
1272
1273   flag[1] = flag[2] = flag[3] = flag[4] = false;
1274
1275   for (;;)
1276     {
1277       c = strchr (c, ' ');
1278       if (c == NULL)
1279         break;
1280
1281       c++;
1282       i = atoi (c);
1283
1284       if (1 <= i && i <= 4)
1285         flag[i] = true;
1286     }
1287
1288   /* Interpret flags.  */
1289
1290   if (flag[1]) /* Starting new file.  */
1291     {
1292       f = get_file (filename, LC_RENAME);
1293       f->up = current_file;
1294       current_file = f;
1295     }
1296
1297   if (flag[2]) /* Ending current file.  */
1298     {
1299       if (!current_file->up
1300           || strcmp (current_file->up->filename, filename) != 0)
1301         {
1302           gfc_warning_now ("%s:%d: file %s left but not entered",
1303                            current_file->filename, current_file->line,
1304                            filename);
1305           if (unescape)
1306             gfc_free (filename);
1307           return;
1308         }
1309       current_file = current_file->up;
1310     }
1311
1312   /* The name of the file can be a temporary file produced by
1313      cpp. Replace the name if it is different.  */
1314
1315   if (strcmp (current_file->filename, filename) != 0)
1316     {
1317       gfc_free (current_file->filename);
1318       current_file->filename = gfc_getmem (strlen (filename) + 1);
1319       strcpy (current_file->filename, filename);
1320     }
1321
1322   /* Set new line number.  */
1323   current_file->line = line;
1324   if (unescape)
1325     gfc_free (filename);
1326   return;
1327
1328  bad_cpp_line:
1329   gfc_warning_now ("%s:%d: Illegal preprocessor directive",
1330                    current_file->filename, current_file->line);
1331   current_file->line++;
1332 }
1333
1334
1335 static try load_file (const char *, bool);
1336
1337 /* include_line()-- Checks a line buffer to see if it is an include
1338    line.  If so, we call load_file() recursively to load the included
1339    file.  We never return a syntax error because a statement like
1340    "include = 5" is perfectly legal.  We return false if no include was
1341    processed or true if we matched an include.  */
1342
1343 static bool
1344 include_line (char *line)
1345 {
1346   char quote, *c, *begin, *stop;
1347
1348   c = line;
1349
1350   if (gfc_option.flag_openmp)
1351     {
1352       if (gfc_current_form == FORM_FREE)
1353         {
1354           while (*c == ' ' || *c == '\t')
1355             c++;
1356           if (*c == '!' && c[1] == '$' && (c[2] == ' ' || c[2] == '\t'))
1357             c += 3;
1358         }
1359       else
1360         {
1361           if ((*c == '!' || *c == 'c' || *c == 'C' || *c == '*')
1362               && c[1] == '$' && (c[2] == ' ' || c[2] == '\t'))
1363             c += 3;
1364         }
1365     }
1366
1367   while (*c == ' ' || *c == '\t')
1368     c++;
1369
1370   if (strncasecmp (c, "include", 7))
1371       return false;
1372
1373   c += 7;
1374   while (*c == ' ' || *c == '\t')
1375     c++;
1376
1377   /* Find filename between quotes.  */
1378
1379   quote = *c++;
1380   if (quote != '"' && quote != '\'')
1381     return false;
1382
1383   begin = c;
1384
1385   while (*c != quote && *c != '\0')
1386     c++;
1387
1388   if (*c == '\0')
1389     return false;
1390
1391   stop = c++;
1392
1393   while (*c == ' ' || *c == '\t')
1394     c++;
1395
1396   if (*c != '\0' && *c != '!')
1397     return false;
1398
1399   /* We have an include line at this point.  */
1400
1401   *stop = '\0'; /* It's ok to trash the buffer, as this line won't be
1402                    read by anything else.  */
1403
1404   load_file (begin, false);
1405   return true;
1406 }
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 }