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         {
 857 #ifdef USE_MAPPED_LOCATION
 858           int cur_linenum = LOCATION_LINE (gfc_current_locus.lb->location);
 859 #else
 860           int cur_linenum = gfc_current_locus.lb->linenum;
 861 #endif
 862           if (cur_linenum != linenum)
 863             {
 864               linenum = cur_linenum;
 865               gfc_warning_now ("Nonconforming tab character at %C");
 866             }
 867         }
 868     }
 869   while (gfc_is_whitespace (c));
 870
 871   gfc_current_locus = old_loc;
 872 }
 873
 874
 875 /* Load a single line into pbuf.
 876
 877    If pbuf points to a NULL pointer, it is allocated.
 878    We truncate lines that are too long, unless we're dealing with
 879    preprocessor lines or if the option -ffixed-line-length-none is set,
 880    in which case we reallocate the buffer to fit the entire line, if
 881    need be.
 882    In fixed mode, we expand a tab that occurs within the statement
 883    label region to expand to spaces that leave the next character in
 884    the source region.
 885    load_line returns whether the line was truncated.  */
 886
 887 static int
 888 load_line (FILE * input, char **pbuf, int *pbuflen)
 889 {
 890   static int linenum = 0, current_line = 1;
 891   int c, maxlen, i, preprocessor_flag, buflen = *pbuflen;
 892   int trunc_flag = 0, seen_comment = 0;
 893   char *buffer;
 894
 895   /* Determine the maximum allowed line length.
 896      The default for free-form is GFC_MAX_LINE, for fixed-form or for
 897      unknown form it is 72. Refer to the documentation in gfc_option_t.  */
 898   if (gfc_current_form == FORM_FREE)
 899     {
 900       if (gfc_option.free_line_length == -1)
 901         maxlen = GFC_MAX_LINE;
 902       else
 903         maxlen = gfc_option.free_line_length;
 904     }
 905   else if (gfc_current_form == FORM_FIXED)
 906     {
 907       if (gfc_option.fixed_line_length == -1)
 908         maxlen = 72;
 909       else
 910         maxlen = gfc_option.fixed_line_length;
 911     }
 912   else
 913     maxlen = 72;
 914
 915   if (*pbuf == NULL)
 916     {
 917       /* Allocate the line buffer, storing its length into buflen.  */
 918       if (maxlen > 0)
 919         buflen = maxlen;
 920       else
 921         buflen = GFC_MAX_LINE;
 922
 923       *pbuf = gfc_getmem (buflen + 1);
 924     }
 925
 926   i = 0;
 927   buffer = *pbuf;
 928
 929   preprocessor_flag = 0;
 930   c = fgetc (input);
 931   if (c == '#')
 932     /* In order to not truncate preprocessor lines, we have to
 933        remember that this is one.  */
 934     preprocessor_flag = 1;
 935   ungetc (c, input);
 936
 937   for (;;)
 938     {
 939       c = fgetc (input);
 940
 941       if (c == EOF)
 942         break;
 943       if (c == '\n')
 944         break;
 945
 946       if (c == '\r')
 947         continue;               /* Gobble characters.  */
 948       if (c == '\0')
 949         continue;
 950
 951       if (c == '\032')
 952         {
 953           /* Ctrl-Z ends the file.  */
 954           while (fgetc (input) != EOF);
 955           break;
 956         }
 957
 958       /* Is this a fixed-form comment?  */
 959       if (gfc_current_form == FORM_FIXED && i == 0
 960           && (c == '*' || c == 'c' || c == 'd'))
 961         seen_comment = 1;
 962
 963       if (gfc_current_form == FORM_FIXED && c == '\t' && i <= 6)
 964         {
 965           /* The error machinery isn't available at this point, so we can't
 966              easily report line and column numbers consistent with other
 967              parts of gfortran.  */
 968           if (!gfc_option.warn_tabs && seen_comment == 0
 969               && current_line != linenum)
 970             {
 971               linenum = current_line;
 972               gfc_warning_now (
 973                 "Nonconforming tab character in column 1 of line %d", linenum);
 974             }
 975
 976           while (i <= 6)
 977             {
 978               *buffer++ = ' ';
 979               i++;
 980             }
 981
 982           continue;
 983         }
 984
 985       *buffer++ = c;
 986       i++;
 987
 988       if (maxlen == 0 || preprocessor_flag)
 989         {
 990           if (i >= buflen)
 991             {
 992               /* Reallocate line buffer to double size to hold the
 993                 overlong line.  */
 994               buflen = buflen * 2;
 995               *pbuf = xrealloc (*pbuf, buflen + 1);
 996               buffer = (*pbuf)+i;
 997             }
 998         }
 999       else if (i >= maxlen)
1000         {
1001           /* Truncate the rest of the line.  */
1002           for (;;)
1003             {
1004               c = fgetc (input);
1005               if (c == '\n' || c == EOF)
1006                 break;
1007
1008               trunc_flag = 1;
1009             }
1010
1011           ungetc ('\n', input);
1012         }
1013     }
1014
1015   /* Pad lines to the selected line length in fixed form.  */
1016   if (gfc_current_form == FORM_FIXED
1017       && gfc_option.fixed_line_length != 0
1018       && !preprocessor_flag
1019       && c != EOF)
1020     {
1021       while (i++ < maxlen)
1022         *buffer++ = ' ';
1023     }
1024
1025   *buffer = '\0';
1026   *pbuflen = buflen;
1027   current_line++;
1028
1029   return trunc_flag;
1030 }
1031
1032
1033 /* Get a gfc_file structure, initialize it and add it to
1034    the file stack.  */
1035
1036 static gfc_file *
1037 get_file (const char *name, enum lc_reason reason ATTRIBUTE_UNUSED)
1038 {
1039   gfc_file *f;
1040
1041   f = gfc_getmem (sizeof (gfc_file));
1042
1043   f->filename = gfc_getmem (strlen (name) + 1);
1044   strcpy (f->filename, name);
1045
1046   f->next = file_head;
1047   file_head = f;
1048
1049   f->included_by = current_file;
1050   if (current_file != NULL)
1051     f->inclusion_line = current_file->line;
1052
1053 #ifdef USE_MAPPED_LOCATION
1054   linemap_add (&line_table, reason, false, f->filename, 1);
1055 #endif
1056
1057   return f;
1058 }
1059
1060 /* Deal with a line from the C preprocessor. The
1061    initial octothorp has already been seen.  */
1062
1063 static void
1064 preprocessor_line (char *c)
1065 {
1066   bool flag[5];
1067   int i, line;
1068   char *filename;
1069   gfc_file *f;
1070   int escaped, unescape;
1071
1072   c++;
1073   while (*c == ' ' || *c == '\t')
1074     c++;
1075
1076   if (*c < '0' || *c > '9')
1077     goto bad_cpp_line;
1078
1079   line = atoi (c);
1080
1081   c = strchr (c, ' ');
1082   if (c == NULL)
1083     {
1084       /* No file name given.  Set new line number.  */
1085       current_file->line = line;
1086       return;
1087     }
1088
1089   /* Skip spaces.  */
1090   while (*c == ' ' || *c == '\t')
1091     c++;
1092
1093   /* Skip quote.  */
1094   if (*c != '"')
1095     goto bad_cpp_line;
1096   ++c;
1097
1098   filename = c;
1099
1100   /* Make filename end at quote.  */
1101   unescape = 0;
1102   escaped = false;
1103   while (*c && ! (! escaped && *c == '"'))
1104     {
1105       if (escaped)
1106         escaped = false;
1107       else if (*c == '\\')
1108         {
1109           escaped = true;
1110           unescape++;
1111         }
1112       ++c;
1113     }
1114
1115   if (! *c)
1116     /* Preprocessor line has no closing quote.  */
1117     goto bad_cpp_line;
1118
1119   *c++ = '\0';
1120
1121   /* Undo effects of cpp_quote_string.  */
1122   if (unescape)
1123     {
1124       char *s = filename;
1125       char *d = gfc_getmem (c - filename - unescape);
1126
1127       filename = d;
1128       while (*s)
1129         {
1130           if (*s == '\\')
1131             *d++ = *++s;
1132           else
1133             *d++ = *s;
1134           s++;
1135         }
1136       *d = '\0';
1137     }
1138
1139   /* Get flags.  */
1140
1141   flag[1] = flag[2] = flag[3] = flag[4] = false;
1142
1143   for (;;)
1144     {
1145       c = strchr (c, ' ');
1146       if (c == NULL)
1147         break;
1148
1149       c++;
1150       i = atoi (c);
1151
1152       if (1 <= i && i <= 4)
1153         flag[i] = true;
1154     }
1155
1156   /* Interpret flags.  */
1157
1158   if (flag[1]) /* Starting new file.  */
1159     {
1160       f = get_file (filename, LC_RENAME);
1161       f->up = current_file;
1162       current_file = f;
1163     }
1164
1165   if (flag[2]) /* Ending current file.  */
1166     {
1167       if (!current_file->up
1168           || strcmp (current_file->up->filename, filename) != 0)
1169         {
1170           gfc_warning_now ("%s:%d: file %s left but not entered",
1171                            current_file->filename, current_file->line,
1172                            filename);
1173           if (unescape)
1174             gfc_free (filename);
1175           return;
1176         }
1177       current_file = current_file->up;
1178     }
1179
1180   /* The name of the file can be a temporary file produced by
1181      cpp. Replace the name if it is different.  */
1182
1183   if (strcmp (current_file->filename, filename) != 0)
1184     {
1185       gfc_free (current_file->filename);
1186       current_file->filename = gfc_getmem (strlen (filename) + 1);
1187       strcpy (current_file->filename, filename);
1188     }
1189
1190   /* Set new line number.  */
1191   current_file->line = line;
1192   if (unescape)
1193     gfc_free (filename);
1194   return;
1195
1196  bad_cpp_line:
1197   gfc_warning_now ("%s:%d: Illegal preprocessor directive",
1198                    current_file->filename, current_file->line);
1199   current_file->line++;
1200 }
1201
1202
1203 static try load_file (const char *, bool);
1204
1205 /* include_line()-- Checks a line buffer to see if it is an include
1206    line.  If so, we call load_file() recursively to load the included
1207    file.  We never return a syntax error because a statement like
1208    "include = 5" is perfectly legal.  We return false if no include was
1209    processed or true if we matched an include.  */
1210
1211 static bool
1212 include_line (char *line)
1213 {
1214   char quote, *c, *begin, *stop;
1215
1216   c = line;
1217   while (*c == ' ' || *c == '\t')
1218     c++;
1219
1220   if (strncasecmp (c, "include", 7))
1221       return false;
1222
1223   c += 7;
1224   while (*c == ' ' || *c == '\t')
1225     c++;
1226
1227   /* Find filename between quotes.  */
1228
1229   quote = *c++;
1230   if (quote != '"' && quote != '\'')
1231     return false;
1232
1233   begin = c;
1234
1235   while (*c != quote && *c != '\0')
1236     c++;
1237
1238   if (*c == '\0')
1239     return false;
1240
1241   stop = c++;
1242
1243   while (*c == ' ' || *c == '\t')
1244     c++;
1245
1246   if (*c != '\0' && *c != '!')
1247     return false;
1248
1249   /* We have an include line at this point.  */
1250
1251   *stop = '\0'; /* It's ok to trash the buffer, as this line won't be
1252                    read by anything else.  */
1253
1254   load_file (begin, false);
1255   return true;
1256 }
1257
1258 /* Load a file into memory by calling load_line until the file ends.  */
1259
1260 static try
1261 load_file (const char *filename, bool initial)
1262 {
1263   char *line;
1264   gfc_linebuf *b;
1265   gfc_file *f;
1266   FILE *input;
1267   int len, line_len;
1268
1269   for (f = current_file; f; f = f->up)
1270     if (strcmp (filename, f->filename) == 0)
1271       {
1272         gfc_error_now ("File '%s' is being included recursively", filename);
1273         return FAILURE;
1274       }
1275
1276   if (initial)
1277     {
1278       if (gfc_src_file)
1279         {
1280           input = gfc_src_file;
1281           gfc_src_file = NULL;
1282         }
1283       else
1284         input = gfc_open_file (filename);
1285       if (input == NULL)
1286         {
1287           gfc_error_now ("Can't open file '%s'", filename);
1288           return FAILURE;
1289         }
1290     }
1291   else
1292     {
1293       input = gfc_open_included_file (filename, false);
1294       if (input == NULL)
1295         {
1296           gfc_error_now ("Can't open included file '%s'", filename);
1297           return FAILURE;
1298         }
1299     }
1300
1301   /* Load the file.  */
1302
1303   f = get_file (filename, initial ? LC_RENAME : LC_ENTER);
1304   f->up = current_file;
1305   current_file = f;
1306   current_file->line = 1;
1307   line = NULL;
1308   line_len = 0;
1309
1310   if (initial && gfc_src_preprocessor_lines[0])
1311     {
1312       preprocessor_line (gfc_src_preprocessor_lines[0]);
1313       gfc_free (gfc_src_preprocessor_lines[0]);
1314       gfc_src_preprocessor_lines[0] = NULL;
1315       if (gfc_src_preprocessor_lines[1])
1316         {
1317           preprocessor_line (gfc_src_preprocessor_lines[1]);
1318           gfc_free (gfc_src_preprocessor_lines[1]);
1319           gfc_src_preprocessor_lines[1] = NULL;
1320         }
1321     }
1322
1323   for (;;)
1324     {
1325       int trunc = load_line (input, &line, &line_len);
1326
1327       len = strlen (line);
1328       if (feof (input) && len == 0)
1329         break;
1330
1331       /* There are three things this line can be: a line of Fortran
1332          source, an include line or a C preprocessor directive.  */
1333
1334       if (line[0] == '#')
1335         {
1336           preprocessor_line (line);
1337           continue;
1338         }
1339
1340       if (include_line (line))
1341         {
1342           current_file->line++;
1343           continue;
1344         }
1345
1346       /* Add line.  */
1347
1348       b = gfc_getmem (gfc_linebuf_header_size + len + 1);
1349
1350 #ifdef USE_MAPPED_LOCATION
1351       b->location
1352         = linemap_line_start (&line_table, current_file->line++, 120);
1353 #else
1354       b->linenum = current_file->line++;
1355 #endif
1356       b->file = current_file;
1357       b->truncated = trunc;
1358       strcpy (b->line, line);
1359
1360       if (line_head == NULL)
1361         line_head = b;
1362       else
1363         line_tail->next = b;
1364
1365       line_tail = b;
1366     }
1367
1368   /* Release the line buffer allocated in load_line.  */
1369   gfc_free (line);
1370
1371   fclose (input);
1372
1373   current_file = current_file->up;
1374 #ifdef USE_MAPPED_LOCATION
1375   linemap_add (&line_table, LC_LEAVE, 0, NULL, 0);
1376 #endif
1377   return SUCCESS;
1378 }
1379
1380
1381 /* Open a new file and start scanning from that file. Returns SUCCESS
1382    if everything went OK, FAILURE otherwise.  If form == FORM_UKNOWN
1383    it tries to determine the source form from the filename, defaulting
1384    to free form.  */
1385
1386 try
1387 gfc_new_file (void)
1388 {
1389   try result;
1390
1391   result = load_file (gfc_source_file, true);
1392
1393   gfc_current_locus.lb = line_head;
1394   gfc_current_locus.nextc = (line_head == NULL) ? NULL : line_head->line;
1395
1396 #if 0 /* Debugging aid.  */
1397   for (; line_head; line_head = line_head->next)
1398     gfc_status ("%s:%3d %s\n", line_head->file->filename,
1399 #ifdef USE_MAPPED_LOCATION
1400                 LOCATION_LINE (line_head->location),
1401 #else
1402                 line_head->linenum,
1403 #endif
1404                 line_head->line);
1405
1406   exit (0);
1407 #endif
1408
1409   return result;
1410 }
1411
1412 static char *
1413 unescape_filename (const char *ptr)
1414 {
1415   const char *p = ptr, *s;
1416   char *d, *ret;
1417   int escaped, unescape = 0;
1418
1419   /* Make filename end at quote.  */
1420   escaped = false;
1421   while (*p && ! (! escaped && *p == '"'))
1422     {
1423       if (escaped)
1424         escaped = false;
1425       else if (*p == '\\')
1426         {
1427           escaped = true;
1428           unescape++;
1429         }
1430       ++p;
1431     }
1432
1433   if (! *p || p[1])
1434     return NULL;
1435
1436   /* Undo effects of cpp_quote_string.  */
1437   s = ptr;
1438   d = gfc_getmem (p + 1 - ptr - unescape);
1439   ret = d;
1440
1441   while (s != p)
1442     {
1443       if (*s == '\\')
1444         *d++ = *++s;
1445       else
1446         *d++ = *s;
1447       s++;
1448     }
1449   *d = '\0';
1450   return ret;
1451 }
1452
1453 /* For preprocessed files, if the first tokens are of the form # NUM.
1454    handle the directives so we know the original file name.  */
1455
1456 const char *
1457 gfc_read_orig_filename (const char *filename, const char **canon_source_file)
1458 {
1459   int c, len;
1460   char *dirname;
1461
1462   gfc_src_file = gfc_open_file (filename);
1463   if (gfc_src_file == NULL)
1464     return NULL;
1465
1466   c = fgetc (gfc_src_file);
1467   ungetc (c, gfc_src_file);
1468
1469   if (c != '#')
1470     return NULL;
1471
1472   len = 0;
1473   load_line (gfc_src_file, &gfc_src_preprocessor_lines[0], &len);
1474
1475   if (strncmp (gfc_src_preprocessor_lines[0], "# 1 \"", 5) != 0)
1476     return NULL;
1477
1478   filename = unescape_filename (gfc_src_preprocessor_lines[0] + 5);
1479   if (filename == NULL)
1480     return NULL;
1481
1482   c = fgetc (gfc_src_file);
1483   ungetc (c, gfc_src_file);
1484
1485   if (c != '#')
1486     return filename;
1487
1488   len = 0;
1489   load_line (gfc_src_file, &gfc_src_preprocessor_lines[1], &len);
1490
1491   if (strncmp (gfc_src_preprocessor_lines[1], "# 1 \"", 5) != 0)
1492     return filename;
1493
1494   dirname = unescape_filename (gfc_src_preprocessor_lines[1] + 5);
1495   if (dirname == NULL)
1496     return filename;
1497
1498   len = strlen (dirname);
1499   if (len < 3 || dirname[len - 1] != '/' || dirname[len - 2] != '/')
1500     {
1501       gfc_free (dirname);
1502       return filename;
1503     }
1504   dirname[len - 2] = '\0';
1505   set_src_pwd (dirname);
1506
1507   if (! IS_ABSOLUTE_PATH (filename))
1508     {
1509       char *p = gfc_getmem (len + strlen (filename));
1510
1511       memcpy (p, dirname, len - 2);
1512       p[len - 2] = '/';
1513       strcpy (p + len - 1, filename);
1514       *canon_source_file = p;
1515     }
1516
1517   gfc_free (dirname);
1518   return filename;
1519 }