gcc/fortran/scanner.c

   1 /* Character scanner.
   2    Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005
   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
  49 /* Structure for holding module and include file search path.  */
  50 typedef struct gfc_directorylist
  51 {
  52   char *path;
  53   struct gfc_directorylist *next;
  54 }
  55 gfc_directorylist;
  56
  57 /* List of include file search directories.  */
  58 static gfc_directorylist *include_dirs;
  59
  60 static gfc_file *file_head, *current_file;
  61
  62 static int continue_flag, end_flag;
  63
  64 gfc_source_form gfc_current_form;
  65 static gfc_linebuf *line_head, *line_tail;
  66
  67 locus gfc_current_locus;
  68 const char *gfc_source_file;
  69
  70
  71 /* Main scanner initialization.  */
  72
  73 void
  74 gfc_scanner_init_1 (void)
  75 {
  76   file_head = NULL;
  77   line_head = NULL;
  78   line_tail = NULL;
  79
  80   end_flag = 0;
  81 }
  82
  83
  84 /* Main scanner destructor.  */
  85
  86 void
  87 gfc_scanner_done_1 (void)
  88 {
  89   gfc_linebuf *lb;
  90   gfc_file *f;
  91
  92   while(line_head != NULL)
  93     {
  94       lb = line_head->next;
  95       gfc_free(line_head);
  96       line_head = lb;
  97     }
  98
  99   while(file_head != NULL)
 100     {
 101       f = file_head->next;
 102       gfc_free(file_head->filename);
 103       gfc_free(file_head);
 104       file_head = f;
 105     }
 106
 107 }
 108
 109
 110 /* Adds path to the list pointed to by list.  */
 111
 112 void
 113 gfc_add_include_path (const char *path)
 114 {
 115   gfc_directorylist *dir;
 116   const char *p;
 117
 118   p = path;
 119   while (*p == ' ' || *p == '\t')  /* someone might do 'gfortran "-I include"' */
 120     if (*p++ == '\0')
 121       return;
 122
 123   dir = include_dirs;
 124   if (!dir)
 125     {
 126       dir = include_dirs = gfc_getmem (sizeof (gfc_directorylist));
 127     }
 128   else
 129     {
 130       while (dir->next)
 131         dir = dir->next;
 132
 133       dir->next = gfc_getmem (sizeof (gfc_directorylist));
 134       dir = dir->next;
 135     }
 136
 137   dir->next = NULL;
 138   dir->path = gfc_getmem (strlen (p) + 2);
 139   strcpy (dir->path, p);
 140   strcat (dir->path, "/");      /* make '/' last character */
 141 }
 142
 143
 144 /* Release resources allocated for options.  */
 145
 146 void
 147 gfc_release_include_path (void)
 148 {
 149   gfc_directorylist *p;
 150
 151   gfc_free (gfc_option.module_dir);
 152   while (include_dirs != NULL)
 153     {
 154       p = include_dirs;
 155       include_dirs = include_dirs->next;
 156       gfc_free (p->path);
 157       gfc_free (p);
 158     }
 159 }
 160
 161 /* Opens file for reading, searching through the include directories
 162    given if necessary.  If the include_cwd argument is true, we try
 163    to open the file in the current directory first.  */
 164
 165 FILE *
 166 gfc_open_included_file (const char *name, const bool include_cwd)
 167 {
 168   char *fullname;
 169   gfc_directorylist *p;
 170   FILE *f;
 171
 172   if (include_cwd)
 173     {
 174       f = gfc_open_file (name);
 175       if (f != NULL)
 176         return f;
 177     }
 178
 179   for (p = include_dirs; p; p = p->next)
 180     {
 181       fullname = (char *) alloca(strlen (p->path) + strlen (name) + 1);
 182       strcpy (fullname, p->path);
 183       strcat (fullname, name);
 184
 185       f = gfc_open_file (fullname);
 186       if (f != NULL)
 187         return f;
 188     }
 189
 190   return NULL;
 191 }
 192
 193 /* Test to see if we're at the end of the main source file.  */
 194
 195 int
 196 gfc_at_end (void)
 197 {
 198
 199   return end_flag;
 200 }
 201
 202
 203 /* Test to see if we're at the end of the current file.  */
 204
 205 int
 206 gfc_at_eof (void)
 207 {
 208
 209   if (gfc_at_end ())
 210     return 1;
 211
 212   if (line_head == NULL)
 213     return 1;                   /* Null file */
 214
 215   if (gfc_current_locus.lb == NULL)
 216     return 1;
 217
 218   return 0;
 219 }
 220
 221
 222 /* Test to see if we're at the beginning of a new line.  */
 223
 224 int
 225 gfc_at_bol (void)
 226 {
 227   if (gfc_at_eof ())
 228     return 1;
 229
 230   return (gfc_current_locus.nextc == gfc_current_locus.lb->line);
 231 }
 232
 233
 234 /* Test to see if we're at the end of a line.  */
 235
 236 int
 237 gfc_at_eol (void)
 238 {
 239
 240   if (gfc_at_eof ())
 241     return 1;
 242
 243   return (*gfc_current_locus.nextc == '\0');
 244 }
 245
 246
 247 /* Advance the current line pointer to the next line.  */
 248
 249 void
 250 gfc_advance_line (void)
 251 {
 252   if (gfc_at_end ())
 253     return;
 254
 255   if (gfc_current_locus.lb == NULL)
 256     {
 257       end_flag = 1;
 258       return;
 259     }
 260
 261   gfc_current_locus.lb = gfc_current_locus.lb->next;
 262
 263   if (gfc_current_locus.lb != NULL)
 264     gfc_current_locus.nextc = gfc_current_locus.lb->line;
 265   else
 266     {
 267       gfc_current_locus.nextc = NULL;
 268       end_flag = 1;
 269     }
 270 }
 271
 272
 273 /* Get the next character from the input, advancing gfc_current_file's
 274    locus.  When we hit the end of the line or the end of the file, we
 275    start returning a '\n' in order to complete the current statement.
 276    No Fortran line conventions are implemented here.
 277
 278    Requiring explicit advances to the next line prevents the parse
 279    pointer from being on the wrong line if the current statement ends
 280    prematurely.  */
 281
 282 static int
 283 next_char (void)
 284 {
 285   int c;
 286
 287   if (gfc_current_locus.nextc == NULL)
 288     return '\n';
 289
 290   c = *gfc_current_locus.nextc++;
 291   if (c == '\0')
 292     {
 293       gfc_current_locus.nextc--; /* Remain on this line.  */
 294       c = '\n';
 295     }
 296
 297   return c;
 298 }
 299
 300 /* Skip a comment.  When we come here the parse pointer is positioned
 301    immediately after the comment character.  If we ever implement
 302    compiler directives withing comments, here is where we parse the
 303    directive.  */
 304
 305 static void
 306 skip_comment_line (void)
 307 {
 308   char c;
 309
 310   do
 311     {
 312       c = next_char ();
 313     }
 314   while (c != '\n');
 315
 316   gfc_advance_line ();
 317 }
 318
 319
 320 /* Comment lines are null lines, lines containing only blanks or lines
 321    on which the first nonblank line is a '!'.  */
 322
 323 static void
 324 skip_free_comments (void)
 325 {
 326   locus start;
 327   char c;
 328
 329   for (;;)
 330     {
 331       start = gfc_current_locus;
 332       if (gfc_at_eof ())
 333         break;
 334
 335       do
 336         {
 337           c = next_char ();
 338         }
 339       while (gfc_is_whitespace (c));
 340
 341       if (c == '\n')
 342         {
 343           gfc_advance_line ();
 344           continue;
 345         }
 346
 347       if (c == '!')
 348         {
 349           skip_comment_line ();
 350           continue;
 351         }
 352
 353       break;
 354     }
 355
 356   gfc_current_locus = start;
 357 }
 358
 359
 360 /* Skip comment lines in fixed source mode.  We have the same rules as
 361    in skip_free_comment(), except that we can have a 'c', 'C' or '*'
 362    in column 1, and a '!' cannot be in column 6.  Also, we deal with
 363    lines with 'd' or 'D' in column 1, if the user requested this.  */
 364
 365 static void
 366 skip_fixed_comments (void)
 367 {
 368   locus start;
 369   int col;
 370   char c;
 371
 372   for (;;)
 373     {
 374       start = gfc_current_locus;
 375       if (gfc_at_eof ())
 376         break;
 377
 378       c = next_char ();
 379       if (c == '\n')
 380         {
 381           gfc_advance_line ();
 382           continue;
 383         }
 384
 385       if (c == '!' || c == 'c' || c == 'C' || c == '*')
 386         {
 387           skip_comment_line ();
 388           continue;
 389         }
 390
 391       if (gfc_option.flag_d_lines != -1 && (c == 'd' || c == 'D'))
 392         {
 393           if (gfc_option.flag_d_lines == 0)
 394             {
 395               skip_comment_line ();
 396               continue;
 397             }
 398           else
 399             *start.nextc = c = ' ';
 400         }
 401
 402       col = 1;
 403
 404       while (gfc_is_whitespace (c))
 405         {
 406           c = next_char ();
 407           col++;
 408         }
 409
 410       if (c == '\n')
 411         {
 412           gfc_advance_line ();
 413           continue;
 414         }
 415
 416       if (col != 6 && c == '!')
 417         {
 418           skip_comment_line ();
 419           continue;
 420         }
 421
 422       break;
 423     }
 424
 425   gfc_current_locus = start;
 426 }
 427
 428
 429 /* Skips the current line if it is a comment.  Assumes that we are at
 430    the start of the current line.  */
 431
 432 void
 433 gfc_skip_comments (void)
 434 {
 435
 436   if (!gfc_at_bol () || gfc_current_form == FORM_FREE)
 437     skip_free_comments ();
 438   else
 439     skip_fixed_comments ();
 440 }
 441
 442
 443 /* Get the next character from the input, taking continuation lines
 444    and end-of-line comments into account.  This implies that comment
 445    lines between continued lines must be eaten here.  For higher-level
 446    subroutines, this flattens continued lines into a single logical
 447    line.  The in_string flag denotes whether we're inside a character
 448    context or not.  */
 449
 450 int
 451 gfc_next_char_literal (int in_string)
 452 {
 453   locus old_loc;
 454   int i, c;
 455
 456   continue_flag = 0;
 457
 458 restart:
 459   c = next_char ();
 460   if (gfc_at_end ())
 461     return c;
 462
 463   if (gfc_current_form == FORM_FREE)
 464     {
 465
 466       if (!in_string && c == '!')
 467         {
 468           /* This line can't be continued */
 469           do
 470             {
 471               c = next_char ();
 472             }
 473           while (c != '\n');
 474
 475           /* Avoid truncation warnings for comment ending lines.  */
 476           gfc_current_locus.lb->truncated = 0;
 477
 478           goto done;
 479         }
 480
 481       if (c != '&')
 482         goto done;
 483
 484       /* If the next nonblank character is a ! or \n, we've got a
 485          continuation line.  */
 486       old_loc = gfc_current_locus;
 487
 488       c = next_char ();
 489       while (gfc_is_whitespace (c))
 490         c = next_char ();
 491
 492       /* Character constants to be continued cannot have commentary
 493          after the '&'.  */
 494
 495       if (in_string && c != '\n')
 496         {
 497           gfc_current_locus = old_loc;
 498           c = '&';
 499           goto done;
 500         }
 501
 502       if (c != '!' && c != '\n')
 503         {
 504           gfc_current_locus = old_loc;
 505           c = '&';
 506           goto done;
 507         }
 508
 509       continue_flag = 1;
 510       if (c == '!')
 511         skip_comment_line ();
 512       else
 513         gfc_advance_line ();
 514
 515       /* We've got a continuation line and need to find where it continues.
 516          First eat any comment lines.  */
 517       gfc_skip_comments ();
 518
 519       /* Now that we have a non-comment line, probe ahead for the
 520          first non-whitespace character.  If it is another '&', then
 521          reading starts at the next character, otherwise we must back
 522          up to where the whitespace started and resume from there.  */
 523
 524       old_loc = gfc_current_locus;
 525
 526       c = next_char ();
 527       while (gfc_is_whitespace (c))
 528         c = next_char ();
 529
 530       if (c != '&')
 531         gfc_current_locus = old_loc;
 532
 533     }
 534   else
 535     {
 536       /* Fixed form continuation.  */
 537       if (!in_string && c == '!')
 538         {
 539           /* Skip comment at end of line.  */
 540           do
 541             {
 542               c = next_char ();
 543             }
 544           while (c != '\n');
 545
 546           /* Avoid truncation warnings for comment ending lines.  */
 547           gfc_current_locus.lb->truncated = 0;
 548         }
 549
 550       if (c != '\n')
 551         goto done;
 552
 553       continue_flag = 1;
 554       old_loc = gfc_current_locus;
 555
 556       gfc_advance_line ();
 557       gfc_skip_comments ();
 558
 559       /* See if this line is a continuation line.  */
 560       for (i = 0; i < 5; i++)
 561         {
 562           c = next_char ();
 563           if (c != ' ')
 564             goto not_continuation;
 565         }
 566
 567       c = next_char ();
 568       if (c == '0' || c == ' ')
 569         goto not_continuation;
 570     }
 571
 572   /* Ready to read first character of continuation line, which might
 573      be another continuation line!  */
 574   goto restart;
 575
 576 not_continuation:
 577   c = '\n';
 578   gfc_current_locus = old_loc;
 579
 580 done:
 581   continue_flag = 0;
 582   return c;
 583 }
 584
 585
 586 /* Get the next character of input, folded to lowercase.  In fixed
 587    form mode, we also ignore spaces.  When matcher subroutines are
 588    parsing character literals, they have to call
 589    gfc_next_char_literal().  */
 590
 591 int
 592 gfc_next_char (void)
 593 {
 594   int c;
 595
 596   do
 597     {
 598       c = gfc_next_char_literal (0);
 599     }
 600   while (gfc_current_form == FORM_FIXED && gfc_is_whitespace (c));
 601
 602   return TOLOWER (c);
 603 }
 604
 605
 606 int
 607 gfc_peek_char (void)
 608 {
 609   locus old_loc;
 610   int c;
 611
 612   old_loc = gfc_current_locus;
 613   c = gfc_next_char ();
 614   gfc_current_locus = old_loc;
 615
 616   return c;
 617 }
 618
 619
 620 /* Recover from an error.  We try to get past the current statement
 621    and get lined up for the next.  The next statement follows a '\n'
 622    or a ';'.  We also assume that we are not within a character
 623    constant, and deal with finding a '\'' or '"'.  */
 624
 625 void
 626 gfc_error_recovery (void)
 627 {
 628   char c, delim;
 629
 630   if (gfc_at_eof ())
 631     return;
 632
 633   for (;;)
 634     {
 635       c = gfc_next_char ();
 636       if (c == '\n' || c == ';')
 637         break;
 638
 639       if (c != '\'' && c != '"')
 640         {
 641           if (gfc_at_eof ())
 642             break;
 643           continue;
 644         }
 645       delim = c;
 646
 647       for (;;)
 648         {
 649           c = next_char ();
 650
 651           if (c == delim)
 652             break;
 653           if (c == '\n')
 654             return;
 655           if (c == '\\')
 656             {
 657               c = next_char ();
 658               if (c == '\n')
 659                 return;
 660             }
 661         }
 662       if (gfc_at_eof ())
 663         break;
 664     }
 665 }
 666
 667
 668 /* Read ahead until the next character to be read is not whitespace.  */
 669
 670 void
 671 gfc_gobble_whitespace (void)
 672 {
 673   locus old_loc;
 674   int c;
 675
 676   do
 677     {
 678       old_loc = gfc_current_locus;
 679       c = gfc_next_char_literal (0);
 680     }
 681   while (gfc_is_whitespace (c));
 682
 683   gfc_current_locus = old_loc;
 684 }
 685
 686
 687 /* Load a single line into pbuf.
 688
 689    If pbuf points to a NULL pointer, it is allocated.
 690    We truncate lines that are too long, unless we're dealing with
 691    preprocessor lines or if the option -ffixed-line-length-none is set,
 692    in which case we reallocate the buffer to fit the entire line, if
 693    need be.
 694    In fixed mode, we expand a tab that occurs within the statement
 695    label region to expand to spaces that leave the next character in
 696    the source region.
 697    load_line returns wether the line was truncated.  */
 698
 699 static int
 700 load_line (FILE * input, char **pbuf, int *pbuflen)
 701 {
 702   int c, maxlen, i, preprocessor_flag, buflen = *pbuflen;
 703   int trunc_flag = 0;
 704   char *buffer;
 705
 706   /* Determine the maximum allowed line length.  */
 707   if (gfc_current_form == FORM_FREE)
 708     maxlen = GFC_MAX_LINE;
 709   else
 710     maxlen = gfc_option.fixed_line_length;
 711
 712   if (*pbuf == NULL)
 713     {
 714       /* Allocate the line buffer, storing its length into buflen.  */
 715       if (maxlen > 0)
 716         buflen = maxlen;
 717       else
 718         buflen = GFC_MAX_LINE;
 719
 720       *pbuf = gfc_getmem (buflen + 1);
 721     }
 722
 723   i = 0;
 724   buffer = *pbuf;
 725
 726   preprocessor_flag = 0;
 727   c = fgetc (input);
 728   if (c == '#')
 729     /* In order to not truncate preprocessor lines, we have to
 730        remember that this is one.  */
 731     preprocessor_flag = 1;
 732   ungetc (c, input);
 733
 734   for (;;)
 735     {
 736       c = fgetc (input);
 737
 738       if (c == EOF)
 739         break;
 740       if (c == '\n')
 741         break;
 742
 743       if (c == '\r')
 744         continue;               /* Gobble characters.  */
 745       if (c == '\0')
 746         continue;
 747
 748       if (c == '\032')
 749         {
 750           /* Ctrl-Z ends the file.  */
 751           while (fgetc (input) != EOF);
 752           break;
 753         }
 754
 755       if (gfc_current_form == FORM_FIXED && c == '\t' && i <= 6)
 756         {                       /* Tab expansion.  */
 757           while (i <= 6)
 758             {
 759               *buffer++ = ' ';
 760               i++;
 761             }
 762
 763           continue;
 764         }
 765
 766       *buffer++ = c;
 767       i++;
 768
 769       if (maxlen == 0 || preprocessor_flag)
 770         {
 771           if (i >= buflen)
 772             {
 773               /* Reallocate line buffer to double size to hold the
 774                  overlong line.  */
 775               buflen = buflen * 2;
 776               *pbuf = xrealloc (*pbuf, buflen + 1);
 777               buffer = (*pbuf)+i;
 778             }
 779         }
 780       else if (i >= maxlen)
 781         {
 782           /* Truncate the rest of the line.  */
 783           for (;;)
 784             {
 785               c = fgetc (input);
 786               if (c == '\n' || c == EOF)
 787                 break;
 788
 789               trunc_flag = 1;
 790             }
 791
 792           ungetc ('\n', input);
 793         }
 794     }
 795
 796   /* Pad lines to the selected line length in fixed form.  */
 797   if (gfc_current_form == FORM_FIXED
 798       && gfc_option.fixed_line_length > 0
 799       && !preprocessor_flag
 800       && c != EOF)
 801     while (i++ < gfc_option.fixed_line_length)
 802       *buffer++ = ' ';
 803
 804   *buffer = '\0';
 805   *pbuflen = buflen;
 806
 807   return trunc_flag;
 808 }
 809
 810
 811 /* Get a gfc_file structure, initialize it and add it to
 812    the file stack.  */
 813
 814 static gfc_file *
 815 get_file (const char *name, enum lc_reason reason ATTRIBUTE_UNUSED)
 816 {
 817   gfc_file *f;
 818
 819   f = gfc_getmem (sizeof (gfc_file));
 820
 821   f->filename = gfc_getmem (strlen (name) + 1);
 822   strcpy (f->filename, name);
 823
 824   f->next = file_head;
 825   file_head = f;
 826
 827   f->included_by = current_file;
 828   if (current_file != NULL)
 829     f->inclusion_line = current_file->line;
 830
 831 #ifdef USE_MAPPED_LOCATION
 832   linemap_add (&line_table, reason, false, f->filename, 1);
 833 #endif
 834
 835   return f;
 836 }
 837
 838 /* Deal with a line from the C preprocessor. The
 839    initial octothorp has already been seen.  */
 840
 841 static void
 842 preprocessor_line (char *c)
 843 {
 844   bool flag[5];
 845   int i, line;
 846   char *filename;
 847   gfc_file *f;
 848   int escaped;
 849
 850   c++;
 851   while (*c == ' ' || *c == '\t')
 852     c++;
 853
 854   if (*c < '0' || *c > '9')
 855     goto bad_cpp_line;
 856
 857   line = atoi (c);
 858
 859   c = strchr (c, ' ');
 860   if (c == NULL)
 861     {
 862       /* No file name given.  Set new line number.  */
 863       current_file->line = line;
 864       return;
 865     }
 866
 867   /* Skip spaces.  */
 868   while (*c == ' ' || *c == '\t')
 869     c++;
 870
 871   /* Skip quote.  */
 872   if (*c != '"')
 873     goto bad_cpp_line;
 874   ++c;
 875
 876   filename = c;
 877
 878   /* Make filename end at quote.  */
 879   escaped = false;
 880   while (*c && ! (! escaped && *c == '"'))
 881     {
 882       if (escaped)
 883         escaped = false;
 884       else
 885         escaped = *c == '\\';
 886       ++c;
 887     }
 888
 889   if (! *c)
 890     /* Preprocessor line has no closing quote.  */
 891     goto bad_cpp_line;
 892
 893   *c++ = '\0';
 894
 895
 896
 897   /* Get flags.  */
 898
 899   flag[1] = flag[2] = flag[3] = flag[4] = false;
 900
 901   for (;;)
 902     {
 903       c = strchr (c, ' ');
 904       if (c == NULL)
 905         break;
 906
 907       c++;
 908       i = atoi (c);
 909
 910       if (1 <= i && i <= 4)
 911         flag[i] = true;
 912     }
 913
 914   /* Interpret flags.  */
 915
 916   if (flag[1]) /* Starting new file.  */
 917     {
 918       f = get_file (filename, LC_RENAME);
 919       f->up = current_file;
 920       current_file = f;
 921     }
 922
 923   if (flag[2]) /* Ending current file.  */
 924     {
 925       if (!current_file->up
 926           || strcmp (current_file->up->filename, filename) != 0)
 927         {
 928           gfc_warning_now ("%s:%d: file %s left but not entered",
 929                            current_file->filename, current_file->line,
 930                            filename);
 931           return;
 932         }
 933       current_file = current_file->up;
 934     }
 935
 936   /* The name of the file can be a temporary file produced by
 937      cpp. Replace the name if it is different.  */
 938
 939   if (strcmp (current_file->filename, filename) != 0)
 940     {
 941       gfc_free (current_file->filename);
 942       current_file->filename = gfc_getmem (strlen (filename) + 1);
 943       strcpy (current_file->filename, filename);
 944     }
 945
 946   /* Set new line number.  */
 947   current_file->line = line;
 948   return;
 949
 950  bad_cpp_line:
 951   gfc_warning_now ("%s:%d: Illegal preprocessor directive",
 952                    current_file->filename, current_file->line);
 953   current_file->line++;
 954 }
 955
 956
 957 static try load_file (const char *, bool);
 958
 959 /* include_line()-- Checks a line buffer to see if it is an include
 960    line.  If so, we call load_file() recursively to load the included
 961    file.  We never return a syntax error because a statement like
 962    "include = 5" is perfectly legal.  We return false if no include was
 963    processed or true if we matched an include.  */
 964
 965 static bool
 966 include_line (char *line)
 967 {
 968   char quote, *c, *begin, *stop;
 969
 970   c = line;
 971   while (*c == ' ' || *c == '\t')
 972     c++;
 973
 974   if (strncasecmp (c, "include", 7))
 975       return false;
 976
 977   c += 7;
 978   while (*c == ' ' || *c == '\t')
 979     c++;
 980
 981   /* Find filename between quotes.  */
 982
 983   quote = *c++;
 984   if (quote != '"' && quote != '\'')
 985     return false;
 986
 987   begin = c;
 988
 989   while (*c != quote && *c != '\0')
 990     c++;
 991
 992   if (*c == '\0')
 993     return false;
 994
 995   stop = c++;
 996
 997   while (*c == ' ' || *c == '\t')
 998     c++;
 999
1000   if (*c != '\0' && *c != '!')
1001     return false;
1002
1003   /* We have an include line at this point.  */
1004
1005   *stop = '\0'; /* It's ok to trash the buffer, as this line won't be
1006                    read by anything else.  */
1007
1008   load_file (begin, false);
1009   return true;
1010 }
1011
1012 /* Load a file into memory by calling load_line until the file ends.  */
1013
1014 static try
1015 load_file (const char *filename, bool initial)
1016 {
1017   char *line;
1018   gfc_linebuf *b;
1019   gfc_file *f;
1020   FILE *input;
1021   int len, line_len;
1022
1023   for (f = current_file; f; f = f->up)
1024     if (strcmp (filename, f->filename) == 0)
1025       {
1026         gfc_error_now ("File '%s' is being included recursively", filename);
1027         return FAILURE;
1028       }
1029
1030   if (initial)
1031     {
1032       input = gfc_open_file (filename);
1033       if (input == NULL)
1034         {
1035           gfc_error_now ("Can't open file '%s'", filename);
1036           return FAILURE;
1037         }
1038     }
1039   else
1040     {
1041       input = gfc_open_included_file (filename, false);
1042       if (input == NULL)
1043         {
1044           gfc_error_now ("Can't open included file '%s'", filename);
1045           return FAILURE;
1046         }
1047     }
1048
1049   /* Load the file.  */
1050
1051   f = get_file (filename, initial ? LC_RENAME : LC_ENTER);
1052   f->up = current_file;
1053   current_file = f;
1054   current_file->line = 1;
1055   line = NULL;
1056   line_len = 0;
1057
1058   for (;;)
1059     {
1060       int trunc = load_line (input, &line, &line_len);
1061
1062       len = strlen (line);
1063       if (feof (input) && len == 0)
1064         break;
1065
1066       /* There are three things this line can be: a line of Fortran
1067          source, an include line or a C preprocessor directive.  */
1068
1069       if (line[0] == '#')
1070         {
1071           preprocessor_line (line);
1072           continue;
1073         }
1074
1075       if (include_line (line))
1076         {
1077           current_file->line++;
1078           continue;
1079         }
1080
1081       /* Add line.  */
1082
1083       b = gfc_getmem (gfc_linebuf_header_size + len + 1);
1084
1085 #ifdef USE_MAPPED_LOCATION
1086       b->location
1087         = linemap_line_start (&line_table, current_file->line++, 120);
1088 #else
1089       b->linenum = current_file->line++;
1090 #endif
1091       b->file = current_file;
1092       b->truncated = trunc;
1093       strcpy (b->line, line);
1094
1095       if (line_head == NULL)
1096         line_head = b;
1097       else
1098         line_tail->next = b;
1099
1100       line_tail = b;
1101     }
1102
1103   /* Release the line buffer allocated in load_line.  */
1104   gfc_free (line);
1105
1106   fclose (input);
1107
1108   current_file = current_file->up;
1109 #ifdef USE_MAPPED_LOCATION
1110   linemap_add (&line_table, LC_LEAVE, 0, NULL, 0);
1111 #endif
1112   return SUCCESS;
1113 }
1114
1115
1116 /* Open a new file and start scanning from that file. Returns SUCCESS
1117    if everything went OK, FAILURE otherwise.  If form == FORM_UKNOWN
1118    it tries to determine the source form from the filename, defaulting
1119    to free form.  */
1120
1121 try
1122 gfc_new_file (void)
1123 {
1124   try result;
1125
1126   result = load_file (gfc_source_file, true);
1127
1128   gfc_current_locus.lb = line_head;
1129   gfc_current_locus.nextc = (line_head == NULL) ? NULL : line_head->line;
1130
1131 #if 0 /* Debugging aid.  */
1132   for (; line_head; line_head = line_head->next)
1133     gfc_status ("%s:%3d %s\n", line_head->file->filename,
1134 #ifdef USE_MAPPED_LOCATION
1135                 LOCATION_LINE (line_head->location),
1136 #else
1137                 line_head->linenum,
1138 #endif
1139                 line_head->line);
1140
1141   exit (0);
1142 #endif
1143
1144   return result;
1145 }