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       if (gfc_at_eof())
 709         goto not_continuation;
 710
 711       /* We've got a continuation line.  If we are on the very next line after
 712          the last continuation, increment the continuation line count and
 713          check whether the limit has been exceeded.  */
 714       if (gfc_current_locus.lb->linenum == continue_line + 1)
 715         {
 716           if (++continue_count == gfc_option.max_continue_free)
 717             {
 718               if (gfc_notification_std (GFC_STD_GNU) || pedantic)
 719                 gfc_warning ("Limit of %d continuations exceeded in "
 720                              "statement at %C", gfc_option.max_continue_free);
 721             }
 722         }
 723       continue_line = gfc_current_locus.lb->linenum;
 724
 725       /* Now find where it continues. First eat any comment lines.  */
 726       openmp_cond_flag = skip_free_comments ();
 727
 728       if (prev_openmp_flag != openmp_flag)
 729         {
 730           gfc_current_locus = old_loc;
 731           openmp_flag = prev_openmp_flag;
 732           c = '&';
 733           goto done;
 734         }
 735
 736       /* Now that we have a non-comment line, probe ahead for the
 737          first non-whitespace character.  If it is another '&', then
 738          reading starts at the next character, otherwise we must back
 739          up to where the whitespace started and resume from there.  */
 740
 741       old_loc = gfc_current_locus;
 742
 743       c = next_char ();
 744       while (gfc_is_whitespace (c))
 745         c = next_char ();
 746
 747       if (openmp_flag)
 748         {
 749           for (i = 0; i < 5; i++, c = next_char ())
 750             {
 751               gcc_assert (TOLOWER (c) == "!$omp"[i]);
 752               if (i == 4)
 753                 old_loc = gfc_current_locus;
 754             }
 755           while (gfc_is_whitespace (c))
 756             c = next_char ();
 757         }
 758
 759       if (c != '&')
 760         {
 761           if (in_string)
 762             {
 763               if (gfc_option.warn_ampersand)
 764                 gfc_warning_now ("Missing '&' in continued character "
 765                                  "constant at %C");
 766               gfc_current_locus.nextc--;
 767             }
 768           /* Both !$omp and !$ -fopenmp continuation lines have & on the
 769              continuation line only optionally.  */
 770           else if (openmp_flag || openmp_cond_flag)
 771             gfc_current_locus.nextc--;
 772           else
 773             {
 774               c = ' ';
 775               gfc_current_locus = old_loc;
 776               goto done;
 777             }
 778         }
 779     }
 780   else
 781     {
 782       /* Fixed form continuation.  */
 783       if (!in_string && c == '!')
 784         {
 785           /* Skip comment at end of line.  */
 786           do
 787             {
 788               c = next_char ();
 789             }
 790           while (c != '\n');
 791
 792           /* Avoid truncation warnings for comment ending lines.  */
 793           gfc_current_locus.lb->truncated = 0;
 794         }
 795
 796       if (c != '\n')
 797         goto done;
 798
 799       prev_openmp_flag = openmp_flag;
 800       continue_flag = 1;
 801       old_loc = gfc_current_locus;
 802
 803       gfc_advance_line ();
 804       skip_fixed_comments ();
 805
 806       /* See if this line is a continuation line.  */
 807       if (openmp_flag != prev_openmp_flag)
 808         {
 809           openmp_flag = prev_openmp_flag;
 810           goto not_continuation;
 811         }
 812
 813       if (!openmp_flag)
 814         for (i = 0; i < 5; i++)
 815           {
 816             c = next_char ();
 817             if (c != ' ')
 818               goto not_continuation;
 819           }
 820       else
 821         for (i = 0; i < 5; i++)
 822           {
 823             c = next_char ();
 824             if (TOLOWER (c) != "*$omp"[i])
 825               goto not_continuation;
 826           }
 827
 828       c = next_char ();
 829       if (c == '0' || c == ' ' || c == '\n')
 830         goto not_continuation;
 831
 832       /* We've got a continuation line.  If we are on the very next line after
 833          the last continuation, increment the continuation line count and
 834          check whether the limit has been exceeded.  */
 835       if (gfc_current_locus.lb->linenum == continue_line + 1)
 836         {
 837           if (++continue_count == gfc_option.max_continue_fixed)
 838             {
 839               if (gfc_notification_std (GFC_STD_GNU) || pedantic)
 840                 gfc_warning ("Limit of %d continuations exceeded in "
 841                              "statement at %C",
 842                              gfc_option.max_continue_fixed);
 843             }
 844         }
 845
 846       if (continue_line < gfc_current_locus.lb->linenum)
 847         continue_line = gfc_current_locus.lb->linenum;
 848     }
 849
 850   /* Ready to read first character of continuation line, which might
 851      be another continuation line!  */
 852   goto restart;
 853
 854 not_continuation:
 855   c = '\n';
 856   gfc_current_locus = old_loc;
 857
 858 done:
 859   if (c == '\n')
 860     continue_count = 0;
 861   continue_flag = 0;
 862   return c;
 863 }
 864
 865
 866 /* Get the next character of input, folded to lowercase.  In fixed
 867    form mode, we also ignore spaces.  When matcher subroutines are
 868    parsing character literals, they have to call
 869    gfc_next_char_literal().  */
 870
 871 int
 872 gfc_next_char (void)
 873 {
 874   int c;
 875
 876   do
 877     {
 878       c = gfc_next_char_literal (0);
 879     }
 880   while (gfc_current_form == FORM_FIXED && gfc_is_whitespace (c));
 881
 882   return TOLOWER (c);
 883 }
 884
 885
 886 int
 887 gfc_peek_char (void)
 888 {
 889   locus old_loc;
 890   int c;
 891
 892   old_loc = gfc_current_locus;
 893   c = gfc_next_char ();
 894   gfc_current_locus = old_loc;
 895
 896   return c;
 897 }
 898
 899
 900 /* Recover from an error.  We try to get past the current statement
 901    and get lined up for the next.  The next statement follows a '\n'
 902    or a ';'.  We also assume that we are not within a character
 903    constant, and deal with finding a '\'' or '"'.  */
 904
 905 void
 906 gfc_error_recovery (void)
 907 {
 908   char c, delim;
 909
 910   if (gfc_at_eof ())
 911     return;
 912
 913   for (;;)
 914     {
 915       c = gfc_next_char ();
 916       if (c == '\n' || c == ';')
 917         break;
 918
 919       if (c != '\'' && c != '"')
 920         {
 921           if (gfc_at_eof ())
 922             break;
 923           continue;
 924         }
 925       delim = c;
 926
 927       for (;;)
 928         {
 929           c = next_char ();
 930
 931           if (c == delim)
 932             break;
 933           if (c == '\n')
 934             return;
 935           if (c == '\\')
 936             {
 937               c = next_char ();
 938               if (c == '\n')
 939                 return;
 940             }
 941         }
 942       if (gfc_at_eof ())
 943         break;
 944     }
 945 }
 946
 947
 948 /* Read ahead until the next character to be read is not whitespace.  */
 949
 950 void
 951 gfc_gobble_whitespace (void)
 952 {
 953   static int linenum = 0;
 954   locus old_loc;
 955   int c;
 956
 957   do
 958     {
 959       old_loc = gfc_current_locus;
 960       c = gfc_next_char_literal (0);
 961       /* Issue a warning for nonconforming tabs.  We keep track of the line
 962          number because the Fortran matchers will often back up and the same
 963          line will be scanned multiple times.  */
 964       if (!gfc_option.warn_tabs && c == '\t')
 965         {
 966 #ifdef USE_MAPPED_LOCATION
 967           int cur_linenum = LOCATION_LINE (gfc_current_locus.lb->location);
 968 #else
 969           int cur_linenum = gfc_current_locus.lb->linenum;
 970 #endif
 971           if (cur_linenum != linenum)
 972             {
 973               linenum = cur_linenum;
 974               gfc_warning_now ("Nonconforming tab character at %C");
 975             }
 976         }
 977     }
 978   while (gfc_is_whitespace (c));
 979
 980   gfc_current_locus = old_loc;
 981 }
 982
 983
 984 /* Load a single line into pbuf.
 985
 986    If pbuf points to a NULL pointer, it is allocated.
 987    We truncate lines that are too long, unless we're dealing with
 988    preprocessor lines or if the option -ffixed-line-length-none is set,
 989    in which case we reallocate the buffer to fit the entire line, if
 990    need be.
 991    In fixed mode, we expand a tab that occurs within the statement
 992    label region to expand to spaces that leave the next character in
 993    the source region.
 994    load_line returns whether the line was truncated.
 995
 996    NOTE: The error machinery isn't available at this point, so we can't
 997          easily report line and column numbers consistent with other
 998          parts of gfortran.  */
 999
1000 static int
1001 load_line (FILE *input, char **pbuf, int *pbuflen)
1002 {
1003   static int linenum = 0, current_line = 1;
1004   int c, maxlen, i, preprocessor_flag, buflen = *pbuflen;
1005   int trunc_flag = 0, seen_comment = 0;
1006   int seen_printable = 0, seen_ampersand = 0;
1007   char *buffer;
1008
1009   /* Determine the maximum allowed line length.  */
1010   if (gfc_current_form == FORM_FREE)
1011     maxlen = gfc_option.free_line_length;
1012   else if (gfc_current_form == FORM_FIXED)
1013     maxlen = gfc_option.fixed_line_length;
1014   else
1015     maxlen = 72;
1016
1017   if (*pbuf == NULL)
1018     {
1019       /* Allocate the line buffer, storing its length into buflen.
1020          Note that if maxlen==0, indicating that arbitrary-length lines
1021          are allowed, the buffer will be reallocated if this length is
1022          insufficient; since 132 characters is the length of a standard
1023          free-form line, we use that as a starting guess.  */
1024       if (maxlen > 0)
1025         buflen = maxlen;
1026       else
1027         buflen = 132;
1028
1029       *pbuf = gfc_getmem (buflen + 1);
1030     }
1031
1032   i = 0;
1033   buffer = *pbuf;
1034
1035   preprocessor_flag = 0;
1036   c = getc (input);
1037   if (c == '#')
1038     /* In order to not truncate preprocessor lines, we have to
1039        remember that this is one.  */
1040     preprocessor_flag = 1;
1041   ungetc (c, input);
1042
1043   for (;;)
1044     {
1045       c = getc (input);
1046
1047       if (c == EOF)
1048         break;
1049       if (c == '\n')
1050         {
1051           /* Check for illegal use of ampersand. See F95 Standard 3.3.1.3.  */
1052           if (gfc_current_form == FORM_FREE
1053               && !seen_printable && seen_ampersand)
1054             {
1055               if (pedantic)
1056                 gfc_error_now ("'&' not allowed by itself in line %d",
1057                                current_line);
1058               else
1059                 gfc_warning_now ("'&' not allowed by itself in line %d",
1060                                  current_line);
1061             }
1062           break;
1063         }
1064
1065       if (c == '\r')
1066         continue;               /* Gobble characters.  */
1067       if (c == '\0')
1068         continue;
1069
1070       if (c == '&')
1071         {
1072           if (seen_ampersand)
1073             seen_ampersand = 0;
1074           else
1075             seen_ampersand = 1;
1076         }
1077
1078       if ((c != '&' && c != '!') || (c == '!' && !seen_ampersand))
1079         seen_printable = 1;
1080
1081       /* Is this a fixed-form comment?  */
1082       if (gfc_current_form == FORM_FIXED && i == 0
1083           && (c == '*' || c == 'c' || c == 'd'))
1084         seen_comment = 1;
1085
1086       if (gfc_current_form == FORM_FIXED && c == '\t' && i <= 6)
1087         {
1088           if (!gfc_option.warn_tabs && seen_comment == 0
1089               && current_line != linenum)
1090             {
1091               linenum = current_line;
1092               gfc_warning_now ("Nonconforming tab character in column 1 "
1093                                "of line %d", linenum);
1094             }
1095
1096           while (i <= 6)
1097             {
1098               *buffer++ = ' ';
1099               i++;
1100             }
1101
1102           continue;
1103         }
1104
1105       *buffer++ = c;
1106       i++;
1107
1108       if (maxlen == 0 || preprocessor_flag)
1109         {
1110           if (i >= buflen)
1111             {
1112               /* Reallocate line buffer to double size to hold the
1113                 overlong line.  */
1114               buflen = buflen * 2;
1115               *pbuf = xrealloc (*pbuf, buflen + 1);
1116               buffer = (*pbuf) + i;
1117             }
1118         }
1119       else if (i >= maxlen)
1120         {
1121           /* Truncate the rest of the line.  */
1122           for (;;)
1123             {
1124               c = getc (input);
1125               if (c == '\n' || c == EOF)
1126                 break;
1127
1128               trunc_flag = 1;
1129             }
1130
1131           ungetc ('\n', input);
1132         }
1133     }
1134
1135   /* Pad lines to the selected line length in fixed form.  */
1136   if (gfc_current_form == FORM_FIXED
1137       && gfc_option.fixed_line_length != 0
1138       && !preprocessor_flag
1139       && c != EOF)
1140     {
1141       while (i++ < maxlen)
1142         *buffer++ = ' ';
1143     }
1144
1145   *buffer = '\0';
1146   *pbuflen = buflen;
1147   current_line++;
1148
1149   return trunc_flag;
1150 }
1151
1152
1153 /* Get a gfc_file structure, initialize it and add it to
1154    the file stack.  */
1155
1156 static gfc_file *
1157 get_file (const char *name, enum lc_reason reason ATTRIBUTE_UNUSED)
1158 {
1159   gfc_file *f;
1160
1161   f = gfc_getmem (sizeof (gfc_file));
1162
1163   f->filename = gfc_getmem (strlen (name) + 1);
1164   strcpy (f->filename, name);
1165
1166   f->next = file_head;
1167   file_head = f;
1168
1169   f->included_by = current_file;
1170   if (current_file != NULL)
1171     f->inclusion_line = current_file->line;
1172
1173 #ifdef USE_MAPPED_LOCATION
1174   linemap_add (&line_table, reason, false, f->filename, 1);
1175 #endif
1176
1177   return f;
1178 }
1179
1180 /* Deal with a line from the C preprocessor. The
1181    initial octothorp has already been seen.  */
1182
1183 static void
1184 preprocessor_line (char *c)
1185 {
1186   bool flag[5];
1187   int i, line;
1188   char *filename;
1189   gfc_file *f;
1190   int escaped, unescape;
1191
1192   c++;
1193   while (*c == ' ' || *c == '\t')
1194     c++;
1195
1196   if (*c < '0' || *c > '9')
1197     goto bad_cpp_line;
1198
1199   line = atoi (c);
1200
1201   c = strchr (c, ' ');
1202   if (c == NULL)
1203     {
1204       /* No file name given.  Set new line number.  */
1205       current_file->line = line;
1206       return;
1207     }
1208
1209   /* Skip spaces.  */
1210   while (*c == ' ' || *c == '\t')
1211     c++;
1212
1213   /* Skip quote.  */
1214   if (*c != '"')
1215     goto bad_cpp_line;
1216   ++c;
1217
1218   filename = c;
1219
1220   /* Make filename end at quote.  */
1221   unescape = 0;
1222   escaped = false;
1223   while (*c && ! (!escaped && *c == '"'))
1224     {
1225       if (escaped)
1226         escaped = false;
1227       else if (*c == '\\')
1228         {
1229           escaped = true;
1230           unescape++;
1231         }
1232       ++c;
1233     }
1234
1235   if (! *c)
1236     /* Preprocessor line has no closing quote.  */
1237     goto bad_cpp_line;
1238
1239   *c++ = '\0';
1240
1241   /* Undo effects of cpp_quote_string.  */
1242   if (unescape)
1243     {
1244       char *s = filename;
1245       char *d = gfc_getmem (c - filename - unescape);
1246
1247       filename = d;
1248       while (*s)
1249         {
1250           if (*s == '\\')
1251             *d++ = *++s;
1252           else
1253             *d++ = *s;
1254           s++;
1255         }
1256       *d = '\0';
1257     }
1258
1259   /* Get flags.  */
1260
1261   flag[1] = flag[2] = flag[3] = flag[4] = false;
1262
1263   for (;;)
1264     {
1265       c = strchr (c, ' ');
1266       if (c == NULL)
1267         break;
1268
1269       c++;
1270       i = atoi (c);
1271
1272       if (1 <= i && i <= 4)
1273         flag[i] = true;
1274     }
1275
1276   /* Interpret flags.  */
1277
1278   if (flag[1]) /* Starting new file.  */
1279     {
1280       f = get_file (filename, LC_RENAME);
1281       f->up = current_file;
1282       current_file = f;
1283     }
1284
1285   if (flag[2]) /* Ending current file.  */
1286     {
1287       if (!current_file->up
1288           || strcmp (current_file->up->filename, filename) != 0)
1289         {
1290           gfc_warning_now ("%s:%d: file %s left but not entered",
1291                            current_file->filename, current_file->line,
1292                            filename);
1293           if (unescape)
1294             gfc_free (filename);
1295           return;
1296         }
1297       current_file = current_file->up;
1298     }
1299
1300   /* The name of the file can be a temporary file produced by
1301      cpp. Replace the name if it is different.  */
1302
1303   if (strcmp (current_file->filename, filename) != 0)
1304     {
1305       gfc_free (current_file->filename);
1306       current_file->filename = gfc_getmem (strlen (filename) + 1);
1307       strcpy (current_file->filename, filename);
1308     }
1309
1310   /* Set new line number.  */
1311   current_file->line = line;
1312   if (unescape)
1313     gfc_free (filename);
1314   return;
1315
1316  bad_cpp_line:
1317   gfc_warning_now ("%s:%d: Illegal preprocessor directive",
1318                    current_file->filename, current_file->line);
1319   current_file->line++;
1320 }
1321
1322
1323 static try load_file (const char *, bool);
1324
1325 /* include_line()-- Checks a line buffer to see if it is an include
1326    line.  If so, we call load_file() recursively to load the included
1327    file.  We never return a syntax error because a statement like
1328    "include = 5" is perfectly legal.  We return false if no include was
1329    processed or true if we matched an include.  */
1330
1331 static bool
1332 include_line (char *line)
1333 {
1334   char quote, *c, *begin, *stop;
1335
1336   c = line;
1337
1338   if (gfc_option.flag_openmp)
1339     {
1340       if (gfc_current_form == FORM_FREE)
1341         {
1342           while (*c == ' ' || *c == '\t')
1343             c++;
1344           if (*c == '!' && c[1] == '$' && (c[2] == ' ' || c[2] == '\t'))
1345             c += 3;
1346         }
1347       else
1348         {
1349           if ((*c == '!' || *c == 'c' || *c == 'C' || *c == '*')
1350               && c[1] == '$' && (c[2] == ' ' || c[2] == '\t'))
1351             c += 3;
1352         }
1353     }
1354
1355   while (*c == ' ' || *c == '\t')
1356     c++;
1357
1358   if (strncasecmp (c, "include", 7))
1359       return false;
1360
1361   c += 7;
1362   while (*c == ' ' || *c == '\t')
1363     c++;
1364
1365   /* Find filename between quotes.  */
1366
1367   quote = *c++;
1368   if (quote != '"' && quote != '\'')
1369     return false;
1370
1371   begin = c;
1372
1373   while (*c != quote && *c != '\0')
1374     c++;
1375
1376   if (*c == '\0')
1377     return false;
1378
1379   stop = c++;
1380
1381   while (*c == ' ' || *c == '\t')
1382     c++;
1383
1384   if (*c != '\0' && *c != '!')
1385     return false;
1386
1387   /* We have an include line at this point.  */
1388
1389   *stop = '\0'; /* It's ok to trash the buffer, as this line won't be
1390                    read by anything else.  */
1391
1392   load_file (begin, false);
1393   return true;
1394 }
1395
1396
1397 /* Load a file into memory by calling load_line until the file ends.  */
1398
1399 static try
1400 load_file (const char *filename, bool initial)
1401 {
1402   char *line;
1403   gfc_linebuf *b;
1404   gfc_file *f;
1405   FILE *input;
1406   int len, line_len;
1407   bool first_line;
1408
1409   for (f = current_file; f; f = f->up)
1410     if (strcmp (filename, f->filename) == 0)
1411       {
1412         gfc_error_now ("File '%s' is being included recursively", filename);
1413         return FAILURE;
1414       }
1415
1416   if (initial)
1417     {
1418       if (gfc_src_file)
1419         {
1420           input = gfc_src_file;
1421           gfc_src_file = NULL;
1422         }
1423       else
1424         input = gfc_open_file (filename);
1425       if (input == NULL)
1426         {
1427           gfc_error_now ("Can't open file '%s'", filename);
1428           return FAILURE;
1429         }
1430     }
1431   else
1432     {
1433       input = gfc_open_included_file (filename, false, false);
1434       if (input == NULL)
1435         {
1436           gfc_error_now ("Can't open included file '%s'", filename);
1437           return FAILURE;
1438         }
1439     }
1440
1441   /* Load the file.  */
1442
1443   f = get_file (filename, initial ? LC_RENAME : LC_ENTER);
1444   f->up = current_file;
1445   current_file = f;
1446   current_file->line = 1;
1447   line = NULL;
1448   line_len = 0;
1449   first_line = true;
1450
1451   if (initial && gfc_src_preprocessor_lines[0])
1452     {
1453       preprocessor_line (gfc_src_preprocessor_lines[0]);
1454       gfc_free (gfc_src_preprocessor_lines[0]);
1455       gfc_src_preprocessor_lines[0] = NULL;
1456       if (gfc_src_preprocessor_lines[1])
1457         {
1458           preprocessor_line (gfc_src_preprocessor_lines[1]);
1459           gfc_free (gfc_src_preprocessor_lines[1]);
1460           gfc_src_preprocessor_lines[1] = NULL;
1461         }
1462     }
1463
1464   for (;;)
1465     {
1466       int trunc = load_line (input, &line, &line_len);
1467
1468       len = strlen (line);
1469       if (feof (input) && len == 0)
1470         break;
1471
1472       /* If this is the first line of the file, it can contain a byte
1473          order mark (BOM), which we will ignore:
1474            FF FE is UTF-16 little endian,
1475            FE FF is UTF-16 big endian,
1476            EF BB BF is UTF-8.  */
1477       if (first_line
1478           && ((line_len >= 2 && line[0] == '\xFF' && line[1] == '\xFE')
1479               || (line_len >= 2 && line[0] == '\xFE' && line[1] == '\xFF')
1480               || (line_len >= 3 && line[0] == '\xEF' && line[1] == '\xBB'
1481                   && line[2] == '\xBF')))
1482         {
1483           int n = line[1] == '\xBB' ? 3 : 2;
1484           char * new = gfc_getmem (line_len);
1485
1486           strcpy (new, line + n);
1487           gfc_free (line);
1488           line = new;
1489           len -= n;
1490         }
1491
1492       /* There are three things this line can be: a line of Fortran
1493          source, an include line or a C preprocessor directive.  */
1494
1495       if (line[0] == '#')
1496         {
1497           preprocessor_line (line);
1498           continue;
1499         }
1500
1501       /* Preprocessed files have preprocessor lines added before the byte
1502          order mark, so first_line is not about the first line of the file
1503          but the first line that's not a preprocessor line.  */
1504       first_line = false;
1505
1506       if (include_line (line))
1507         {
1508           current_file->line++;
1509           continue;
1510         }
1511
1512       /* Add line.  */
1513
1514       b = gfc_getmem (gfc_linebuf_header_size + len + 1);
1515
1516 #ifdef USE_MAPPED_LOCATION
1517       b->location
1518         = linemap_line_start (&line_table, current_file->line++, 120);
1519 #else
1520       b->linenum = current_file->line++;
1521 #endif
1522       b->file = current_file;
1523       b->truncated = trunc;
1524       strcpy (b->line, line);
1525
1526       if (line_head == NULL)
1527         line_head = b;
1528       else
1529         line_tail->next = b;
1530
1531       line_tail = b;
1532     }
1533
1534   /* Release the line buffer allocated in load_line.  */
1535   gfc_free (line);
1536
1537   fclose (input);
1538
1539   current_file = current_file->up;
1540 #ifdef USE_MAPPED_LOCATION
1541   linemap_add (&line_table, LC_LEAVE, 0, NULL, 0);
1542 #endif
1543   return SUCCESS;
1544 }
1545
1546
1547 /* Open a new file and start scanning from that file. Returns SUCCESS
1548    if everything went OK, FAILURE otherwise.  If form == FORM_UKNOWN
1549    it tries to determine the source form from the filename, defaulting
1550    to free form.  */
1551
1552 try
1553 gfc_new_file (void)
1554 {
1555   try result;
1556
1557   result = load_file (gfc_source_file, true);
1558
1559   gfc_current_locus.lb = line_head;
1560   gfc_current_locus.nextc = (line_head == NULL) ? NULL : line_head->line;
1561
1562 #if 0 /* Debugging aid.  */
1563   for (; line_head; line_head = line_head->next)
1564     gfc_status ("%s:%3d %s\n", line_head->file->filename,
1565 #ifdef USE_MAPPED_LOCATION
1566                 LOCATION_LINE (line_head->location),
1567 #else
1568                 line_head->linenum,
1569 #endif
1570                 line_head->line);
1571
1572   exit (0);
1573 #endif
1574
1575   return result;
1576 }
1577
1578 static char *
1579 unescape_filename (const char *ptr)
1580 {
1581   const char *p = ptr, *s;
1582   char *d, *ret;
1583   int escaped, unescape = 0;
1584
1585   /* Make filename end at quote.  */
1586   escaped = false;
1587   while (*p && ! (! escaped && *p == '"'))
1588     {
1589       if (escaped)
1590         escaped = false;
1591       else if (*p == '\\')
1592         {
1593           escaped = true;
1594           unescape++;
1595         }
1596       ++p;
1597     }
1598
1599   if (!*p || p[1])
1600     return NULL;
1601
1602   /* Undo effects of cpp_quote_string.  */
1603   s = ptr;
1604   d = gfc_getmem (p + 1 - ptr - unescape);
1605   ret = d;
1606
1607   while (s != p)
1608     {
1609       if (*s == '\\')
1610         *d++ = *++s;
1611       else
1612         *d++ = *s;
1613       s++;
1614     }
1615   *d = '\0';
1616   return ret;
1617 }
1618
1619 /* For preprocessed files, if the first tokens are of the form # NUM.
1620    handle the directives so we know the original file name.  */
1621
1622 const char *
1623 gfc_read_orig_filename (const char *filename, const char **canon_source_file)
1624 {
1625   int c, len;
1626   char *dirname;
1627
1628   gfc_src_file = gfc_open_file (filename);
1629   if (gfc_src_file == NULL)
1630     return NULL;
1631
1632   c = getc (gfc_src_file);
1633   ungetc (c, gfc_src_file);
1634
1635   if (c != '#')
1636     return NULL;
1637
1638   len = 0;
1639   load_line (gfc_src_file, &gfc_src_preprocessor_lines[0], &len);
1640
1641   if (strncmp (gfc_src_preprocessor_lines[0], "# 1 \"", 5) != 0)
1642     return NULL;
1643
1644   filename = unescape_filename (gfc_src_preprocessor_lines[0] + 5);
1645   if (filename == NULL)
1646     return NULL;
1647
1648   c = getc (gfc_src_file);
1649   ungetc (c, gfc_src_file);
1650
1651   if (c != '#')
1652     return filename;
1653
1654   len = 0;
1655   load_line (gfc_src_file, &gfc_src_preprocessor_lines[1], &len);
1656
1657   if (strncmp (gfc_src_preprocessor_lines[1], "# 1 \"", 5) != 0)
1658     return filename;
1659
1660   dirname = unescape_filename (gfc_src_preprocessor_lines[1] + 5);
1661   if (dirname == NULL)
1662     return filename;
1663
1664   len = strlen (dirname);
1665   if (len < 3 || dirname[len - 1] != '/' || dirname[len - 2] != '/')
1666     {
1667       gfc_free (dirname);
1668       return filename;
1669     }
1670   dirname[len - 2] = '\0';
1671   set_src_pwd (dirname);
1672
1673   if (! IS_ABSOLUTE_PATH (filename))
1674     {
1675       char *p = gfc_getmem (len + strlen (filename));
1676
1677       memcpy (p, dirname, len - 2);
1678       p[len - 2] = '/';
1679       strcpy (p + len - 1, filename);
1680       *canon_source_file = p;
1681     }
1682
1683   gfc_free (dirname);
1684   return filename;
1685 }