gcc/fortran/scanner.c

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