gcc/fortran/scanner.c

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