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         gfc_current_locus = old_loc;
 684     }
 685   else
 686     {
 687       /* Fixed form continuation.  */
 688       if (!in_string && c == '!')
 689         {
 690           /* Skip comment at end of line.  */
 691           do
 692             {
 693               c = next_char ();
 694             }
 695           while (c != '\n');
 696
 697           /* Avoid truncation warnings for comment ending lines.  */
 698           gfc_current_locus.lb->truncated = 0;
 699         }
 700
 701       if (c != '\n')
 702         goto done;
 703
 704       prev_openmp_flag = openmp_flag;
 705       continue_flag = 1;
 706       old_loc = gfc_current_locus;
 707
 708       gfc_advance_line ();
 709       gfc_skip_comments ();
 710
 711       /* See if this line is a continuation line.  */
 712       if (openmp_flag != prev_openmp_flag)
 713         {
 714           openmp_flag = prev_openmp_flag;
 715           goto not_continuation;
 716         }
 717
 718       if (!openmp_flag)
 719         for (i = 0; i < 5; i++)
 720           {
 721             c = next_char ();
 722             if (c != ' ')
 723               goto not_continuation;
 724           }
 725       else
 726         for (i = 0; i < 5; i++)
 727           {
 728             c = next_char ();
 729             if (TOLOWER (c) != "*$omp"[i])
 730               goto not_continuation;
 731           }
 732
 733       c = next_char ();
 734       if (c == '0' || c == ' ' || c == '\n')
 735         goto not_continuation;
 736     }
 737
 738   /* Ready to read first character of continuation line, which might
 739      be another continuation line!  */
 740   goto restart;
 741
 742 not_continuation:
 743   c = '\n';
 744   gfc_current_locus = old_loc;
 745
 746 done:
 747   continue_flag = 0;
 748   return c;
 749 }
 750
 751
 752 /* Get the next character of input, folded to lowercase.  In fixed
 753    form mode, we also ignore spaces.  When matcher subroutines are
 754    parsing character literals, they have to call
 755    gfc_next_char_literal().  */
 756
 757 int
 758 gfc_next_char (void)
 759 {
 760   int c;
 761
 762   do
 763     {
 764       c = gfc_next_char_literal (0);
 765     }
 766   while (gfc_current_form == FORM_FIXED && gfc_is_whitespace (c));
 767
 768   return TOLOWER (c);
 769 }
 770
 771
 772 int
 773 gfc_peek_char (void)
 774 {
 775   locus old_loc;
 776   int c;
 777
 778   old_loc = gfc_current_locus;
 779   c = gfc_next_char ();
 780   gfc_current_locus = old_loc;
 781
 782   return c;
 783 }
 784
 785
 786 /* Recover from an error.  We try to get past the current statement
 787    and get lined up for the next.  The next statement follows a '\n'
 788    or a ';'.  We also assume that we are not within a character
 789    constant, and deal with finding a '\'' or '"'.  */
 790
 791 void
 792 gfc_error_recovery (void)
 793 {
 794   char c, delim;
 795
 796   if (gfc_at_eof ())
 797     return;
 798
 799   for (;;)
 800     {
 801       c = gfc_next_char ();
 802       if (c == '\n' || c == ';')
 803         break;
 804
 805       if (c != '\'' && c != '"')
 806         {
 807           if (gfc_at_eof ())
 808             break;
 809           continue;
 810         }
 811       delim = c;
 812
 813       for (;;)
 814         {
 815           c = next_char ();
 816
 817           if (c == delim)
 818             break;
 819           if (c == '\n')
 820             return;
 821           if (c == '\\')
 822             {
 823               c = next_char ();
 824               if (c == '\n')
 825                 return;
 826             }
 827         }
 828       if (gfc_at_eof ())
 829         break;
 830     }
 831 }
 832
 833
 834 /* Read ahead until the next character to be read is not whitespace.  */
 835
 836 void
 837 gfc_gobble_whitespace (void)
 838 {
 839   locus old_loc;
 840   int c;
 841
 842   do
 843     {
 844       old_loc = gfc_current_locus;
 845       c = gfc_next_char_literal (0);
 846     }
 847   while (gfc_is_whitespace (c));
 848
 849   gfc_current_locus = old_loc;
 850 }
 851
 852
 853 /* Load a single line into pbuf.
 854
 855    If pbuf points to a NULL pointer, it is allocated.
 856    We truncate lines that are too long, unless we're dealing with
 857    preprocessor lines or if the option -ffixed-line-length-none is set,
 858    in which case we reallocate the buffer to fit the entire line, if
 859    need be.
 860    In fixed mode, we expand a tab that occurs within the statement
 861    label region to expand to spaces that leave the next character in
 862    the source region.
 863    load_line returns whether the line was truncated.  */
 864
 865 static int
 866 load_line (FILE * input, char **pbuf, int *pbuflen)
 867 {
 868   int c, maxlen, i, preprocessor_flag, buflen = *pbuflen;
 869   int trunc_flag = 0;
 870   char *buffer;
 871
 872   /* Determine the maximum allowed line length.
 873      The default for free-form is GFC_MAX_LINE, for fixed-form or for
 874      unknown form it is 72. Refer to the documentation in gfc_option_t.  */
 875   if (gfc_current_form == FORM_FREE)
 876     {
 877       if (gfc_option.free_line_length == -1)
 878         maxlen = GFC_MAX_LINE;
 879       else
 880         maxlen = gfc_option.free_line_length;
 881     }
 882   else if (gfc_current_form == FORM_FIXED)
 883     {
 884       if (gfc_option.fixed_line_length == -1)
 885         maxlen = 72;
 886       else
 887         maxlen = gfc_option.fixed_line_length;
 888     }
 889   else
 890     maxlen = 72;
 891
 892   if (*pbuf == NULL)
 893     {
 894       /* Allocate the line buffer, storing its length into buflen.  */
 895       if (maxlen > 0)
 896         buflen = maxlen;
 897       else
 898         buflen = GFC_MAX_LINE;
 899
 900       *pbuf = gfc_getmem (buflen + 1);
 901     }
 902
 903   i = 0;
 904   buffer = *pbuf;
 905
 906   preprocessor_flag = 0;
 907   c = fgetc (input);
 908   if (c == '#')
 909     /* In order to not truncate preprocessor lines, we have to
 910        remember that this is one.  */
 911     preprocessor_flag = 1;
 912   ungetc (c, input);
 913
 914   for (;;)
 915     {
 916       c = fgetc (input);
 917
 918       if (c == EOF)
 919         break;
 920       if (c == '\n')
 921         break;
 922
 923       if (c == '\r')
 924         continue;               /* Gobble characters.  */
 925       if (c == '\0')
 926         continue;
 927
 928       if (c == '\032')
 929         {
 930           /* Ctrl-Z ends the file.  */
 931           while (fgetc (input) != EOF);
 932           break;
 933         }
 934
 935       if (gfc_current_form == FORM_FIXED && c == '\t' && i <= 6)
 936         {                       /* Tab expansion.  */
 937           while (i <= 6)
 938             {
 939               *buffer++ = ' ';
 940               i++;
 941             }
 942
 943           continue;
 944         }
 945
 946       *buffer++ = c;
 947       i++;
 948
 949       if (maxlen == 0 || preprocessor_flag)
 950         {
 951           if (i >= buflen)
 952             {
 953               /* Reallocate line buffer to double size to hold the
 954                  overlong line.  */
 955               buflen = buflen * 2;
 956               *pbuf = xrealloc (*pbuf, buflen + 1);
 957               buffer = (*pbuf)+i;
 958             }
 959         }
 960       else if (i >= maxlen)
 961         {
 962           /* Truncate the rest of the line.  */
 963           for (;;)
 964             {
 965               c = fgetc (input);
 966               if (c == '\n' || c == EOF)
 967                 break;
 968
 969               trunc_flag = 1;
 970             }
 971
 972           ungetc ('\n', input);
 973         }
 974     }
 975
 976   /* Pad lines to the selected line length in fixed form.  */
 977   if (gfc_current_form == FORM_FIXED
 978       && gfc_option.fixed_line_length != 0
 979       && !preprocessor_flag
 980       && c != EOF)
 981     {
 982       while (i++ < maxlen)
 983         *buffer++ = ' ';
 984     }
 985
 986   *buffer = '\0';
 987   *pbuflen = buflen;
 988
 989   return trunc_flag;
 990 }
 991
 992
 993 /* Get a gfc_file structure, initialize it and add it to
 994    the file stack.  */
 995
 996 static gfc_file *
 997 get_file (const char *name, enum lc_reason reason ATTRIBUTE_UNUSED)
 998 {
 999   gfc_file *f;
1000
1001   f = gfc_getmem (sizeof (gfc_file));
1002
1003   f->filename = gfc_getmem (strlen (name) + 1);
1004   strcpy (f->filename, name);
1005
1006   f->next = file_head;
1007   file_head = f;
1008
1009   f->included_by = current_file;
1010   if (current_file != NULL)
1011     f->inclusion_line = current_file->line;
1012
1013 #ifdef USE_MAPPED_LOCATION
1014   linemap_add (&line_table, reason, false, f->filename, 1);
1015 #endif
1016
1017   return f;
1018 }
1019
1020 /* Deal with a line from the C preprocessor. The
1021    initial octothorp has already been seen.  */
1022
1023 static void
1024 preprocessor_line (char *c)
1025 {
1026   bool flag[5];
1027   int i, line;
1028   char *filename;
1029   gfc_file *f;
1030   int escaped, unescape;
1031
1032   c++;
1033   while (*c == ' ' || *c == '\t')
1034     c++;
1035
1036   if (*c < '0' || *c > '9')
1037     goto bad_cpp_line;
1038
1039   line = atoi (c);
1040
1041   c = strchr (c, ' ');
1042   if (c == NULL)
1043     {
1044       /* No file name given.  Set new line number.  */
1045       current_file->line = line;
1046       return;
1047     }
1048
1049   /* Skip spaces.  */
1050   while (*c == ' ' || *c == '\t')
1051     c++;
1052
1053   /* Skip quote.  */
1054   if (*c != '"')
1055     goto bad_cpp_line;
1056   ++c;
1057
1058   filename = c;
1059
1060   /* Make filename end at quote.  */
1061   unescape = 0;
1062   escaped = false;
1063   while (*c && ! (! escaped && *c == '"'))
1064     {
1065       if (escaped)
1066         escaped = false;
1067       else if (*c == '\\')
1068         {
1069           escaped = true;
1070           unescape++;
1071         }
1072       ++c;
1073     }
1074
1075   if (! *c)
1076     /* Preprocessor line has no closing quote.  */
1077     goto bad_cpp_line;
1078
1079   *c++ = '\0';
1080
1081   /* Undo effects of cpp_quote_string.  */
1082   if (unescape)
1083     {
1084       char *s = filename;
1085       char *d = gfc_getmem (c - filename - unescape);
1086
1087       filename = d;
1088       while (*s)
1089         {
1090           if (*s == '\\')
1091             *d++ = *++s;
1092           else
1093             *d++ = *s;
1094           s++;
1095         }
1096       *d = '\0';
1097     }
1098
1099   /* Get flags.  */
1100
1101   flag[1] = flag[2] = flag[3] = flag[4] = false;
1102
1103   for (;;)
1104     {
1105       c = strchr (c, ' ');
1106       if (c == NULL)
1107         break;
1108
1109       c++;
1110       i = atoi (c);
1111
1112       if (1 <= i && i <= 4)
1113         flag[i] = true;
1114     }
1115
1116   /* Interpret flags.  */
1117
1118   if (flag[1]) /* Starting new file.  */
1119     {
1120       f = get_file (filename, LC_RENAME);
1121       f->up = current_file;
1122       current_file = f;
1123     }
1124
1125   if (flag[2]) /* Ending current file.  */
1126     {
1127       if (!current_file->up
1128           || strcmp (current_file->up->filename, filename) != 0)
1129         {
1130           gfc_warning_now ("%s:%d: file %s left but not entered",
1131                            current_file->filename, current_file->line,
1132                            filename);
1133           if (unescape)
1134             gfc_free (filename);
1135           return;
1136         }
1137       current_file = current_file->up;
1138     }
1139
1140   /* The name of the file can be a temporary file produced by
1141      cpp. Replace the name if it is different.  */
1142
1143   if (strcmp (current_file->filename, filename) != 0)
1144     {
1145       gfc_free (current_file->filename);
1146       current_file->filename = gfc_getmem (strlen (filename) + 1);
1147       strcpy (current_file->filename, filename);
1148     }
1149
1150   /* Set new line number.  */
1151   current_file->line = line;
1152   if (unescape)
1153     gfc_free (filename);
1154   return;
1155
1156  bad_cpp_line:
1157   gfc_warning_now ("%s:%d: Illegal preprocessor directive",
1158                    current_file->filename, current_file->line);
1159   current_file->line++;
1160 }
1161
1162
1163 static try load_file (const char *, bool);
1164
1165 /* include_line()-- Checks a line buffer to see if it is an include
1166    line.  If so, we call load_file() recursively to load the included
1167    file.  We never return a syntax error because a statement like
1168    "include = 5" is perfectly legal.  We return false if no include was
1169    processed or true if we matched an include.  */
1170
1171 static bool
1172 include_line (char *line)
1173 {
1174   char quote, *c, *begin, *stop;
1175
1176   c = line;
1177   while (*c == ' ' || *c == '\t')
1178     c++;
1179
1180   if (strncasecmp (c, "include", 7))
1181       return false;
1182
1183   c += 7;
1184   while (*c == ' ' || *c == '\t')
1185     c++;
1186
1187   /* Find filename between quotes.  */
1188
1189   quote = *c++;
1190   if (quote != '"' && quote != '\'')
1191     return false;
1192
1193   begin = c;
1194
1195   while (*c != quote && *c != '\0')
1196     c++;
1197
1198   if (*c == '\0')
1199     return false;
1200
1201   stop = c++;
1202
1203   while (*c == ' ' || *c == '\t')
1204     c++;
1205
1206   if (*c != '\0' && *c != '!')
1207     return false;
1208
1209   /* We have an include line at this point.  */
1210
1211   *stop = '\0'; /* It's ok to trash the buffer, as this line won't be
1212                    read by anything else.  */
1213
1214   load_file (begin, false);
1215   return true;
1216 }
1217
1218 /* Load a file into memory by calling load_line until the file ends.  */
1219
1220 static try
1221 load_file (const char *filename, bool initial)
1222 {
1223   char *line;
1224   gfc_linebuf *b;
1225   gfc_file *f;
1226   FILE *input;
1227   int len, line_len;
1228
1229   for (f = current_file; f; f = f->up)
1230     if (strcmp (filename, f->filename) == 0)
1231       {
1232         gfc_error_now ("File '%s' is being included recursively", filename);
1233         return FAILURE;
1234       }
1235
1236   if (initial)
1237     {
1238       if (gfc_src_file)
1239         {
1240           input = gfc_src_file;
1241           gfc_src_file = NULL;
1242         }
1243       else
1244         input = gfc_open_file (filename);
1245       if (input == NULL)
1246         {
1247           gfc_error_now ("Can't open file '%s'", filename);
1248           return FAILURE;
1249         }
1250     }
1251   else
1252     {
1253       input = gfc_open_included_file (filename, false);
1254       if (input == NULL)
1255         {
1256           gfc_error_now ("Can't open included file '%s'", filename);
1257           return FAILURE;
1258         }
1259     }
1260
1261   /* Load the file.  */
1262
1263   f = get_file (filename, initial ? LC_RENAME : LC_ENTER);
1264   f->up = current_file;
1265   current_file = f;
1266   current_file->line = 1;
1267   line = NULL;
1268   line_len = 0;
1269
1270   if (initial && gfc_src_preprocessor_lines[0])
1271     {
1272       preprocessor_line (gfc_src_preprocessor_lines[0]);
1273       gfc_free (gfc_src_preprocessor_lines[0]);
1274       gfc_src_preprocessor_lines[0] = NULL;
1275       if (gfc_src_preprocessor_lines[1])
1276         {
1277           preprocessor_line (gfc_src_preprocessor_lines[1]);
1278           gfc_free (gfc_src_preprocessor_lines[1]);
1279           gfc_src_preprocessor_lines[1] = NULL;
1280         }
1281     }
1282
1283   for (;;)
1284     {
1285       int trunc = load_line (input, &line, &line_len);
1286
1287       len = strlen (line);
1288       if (feof (input) && len == 0)
1289         break;
1290
1291       /* There are three things this line can be: a line of Fortran
1292          source, an include line or a C preprocessor directive.  */
1293
1294       if (line[0] == '#')
1295         {
1296           preprocessor_line (line);
1297           continue;
1298         }
1299
1300       if (include_line (line))
1301         {
1302           current_file->line++;
1303           continue;
1304         }
1305
1306       /* Add line.  */
1307
1308       b = gfc_getmem (gfc_linebuf_header_size + len + 1);
1309
1310 #ifdef USE_MAPPED_LOCATION
1311       b->location
1312         = linemap_line_start (&line_table, current_file->line++, 120);
1313 #else
1314       b->linenum = current_file->line++;
1315 #endif
1316       b->file = current_file;
1317       b->truncated = trunc;
1318       strcpy (b->line, line);
1319
1320       if (line_head == NULL)
1321         line_head = b;
1322       else
1323         line_tail->next = b;
1324
1325       line_tail = b;
1326     }
1327
1328   /* Release the line buffer allocated in load_line.  */
1329   gfc_free (line);
1330
1331   fclose (input);
1332
1333   current_file = current_file->up;
1334 #ifdef USE_MAPPED_LOCATION
1335   linemap_add (&line_table, LC_LEAVE, 0, NULL, 0);
1336 #endif
1337   return SUCCESS;
1338 }
1339
1340
1341 /* Open a new file and start scanning from that file. Returns SUCCESS
1342    if everything went OK, FAILURE otherwise.  If form == FORM_UKNOWN
1343    it tries to determine the source form from the filename, defaulting
1344    to free form.  */
1345
1346 try
1347 gfc_new_file (void)
1348 {
1349   try result;
1350
1351   result = load_file (gfc_source_file, true);
1352
1353   gfc_current_locus.lb = line_head;
1354   gfc_current_locus.nextc = (line_head == NULL) ? NULL : line_head->line;
1355
1356 #if 0 /* Debugging aid.  */
1357   for (; line_head; line_head = line_head->next)
1358     gfc_status ("%s:%3d %s\n", line_head->file->filename,
1359 #ifdef USE_MAPPED_LOCATION
1360                 LOCATION_LINE (line_head->location),
1361 #else
1362                 line_head->linenum,
1363 #endif
1364                 line_head->line);
1365
1366   exit (0);
1367 #endif
1368
1369   return result;
1370 }
1371
1372 static char *
1373 unescape_filename (const char *ptr)
1374 {
1375   const char *p = ptr, *s;
1376   char *d, *ret;
1377   int escaped, unescape = 0;
1378
1379   /* Make filename end at quote.  */
1380   escaped = false;
1381   while (*p && ! (! escaped && *p == '"'))
1382     {
1383       if (escaped)
1384         escaped = false;
1385       else if (*p == '\\')
1386         {
1387           escaped = true;
1388           unescape++;
1389         }
1390       ++p;
1391     }
1392
1393   if (! *p || p[1])
1394     return NULL;
1395
1396   /* Undo effects of cpp_quote_string.  */
1397   s = ptr;
1398   d = gfc_getmem (p + 1 - ptr - unescape);
1399   ret = d;
1400
1401   while (s != p)
1402     {
1403       if (*s == '\\')
1404         *d++ = *++s;
1405       else
1406         *d++ = *s;
1407       s++;
1408     }
1409   *d = '\0';
1410   return ret;
1411 }
1412
1413 /* For preprocessed files, if the first tokens are of the form # NUM.
1414    handle the directives so we know the original file name.  */
1415
1416 const char *
1417 gfc_read_orig_filename (const char *filename, const char **canon_source_file)
1418 {
1419   int c, len;
1420   char *dirname;
1421
1422   gfc_src_file = gfc_open_file (filename);
1423   if (gfc_src_file == NULL)
1424     return NULL;
1425
1426   c = fgetc (gfc_src_file);
1427   ungetc (c, gfc_src_file);
1428
1429   if (c != '#')
1430     return NULL;
1431
1432   len = 0;
1433   load_line (gfc_src_file, &gfc_src_preprocessor_lines[0], &len);
1434
1435   if (strncmp (gfc_src_preprocessor_lines[0], "# 1 \"", 5) != 0)
1436     return NULL;
1437
1438   filename = unescape_filename (gfc_src_preprocessor_lines[0] + 5);
1439   if (filename == NULL)
1440     return NULL;
1441
1442   c = fgetc (gfc_src_file);
1443   ungetc (c, gfc_src_file);
1444
1445   if (c != '#')
1446     return filename;
1447
1448   len = 0;
1449   load_line (gfc_src_file, &gfc_src_preprocessor_lines[1], &len);
1450
1451   if (strncmp (gfc_src_preprocessor_lines[1], "# 1 \"", 5) != 0)
1452     return filename;
1453
1454   dirname = unescape_filename (gfc_src_preprocessor_lines[1] + 5);
1455   if (dirname == NULL)
1456     return filename;
1457
1458   len = strlen (dirname);
1459   if (len < 3 || dirname[len - 1] != '/' || dirname[len - 2] != '/')
1460     {
1461       gfc_free (dirname);
1462       return filename;
1463     }
1464   dirname[len - 2] = '\0';
1465   set_src_pwd (dirname);
1466
1467   if (! IS_ABSOLUTE_PATH (filename))
1468     {
1469       char *p = gfc_getmem (len + strlen (filename));
1470
1471       memcpy (p, dirname, len - 2);
1472       p[len - 2] = '/';
1473       strcpy (p + len - 1, filename);
1474       *canon_source_file = p;
1475     }
1476
1477   gfc_free (dirname);
1478   return filename;
1479 }