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